diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 0000000..ba20c6e --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,30 @@ +name: Test + +on: + pull_request: + branches: + - master + - main + push: + branches: + - master + - main + +jobs: + test: + runs-on: ubuntu-latest + + steps: + - name: Checkout code + uses: actions/checkout@v4 + + - name: Install Nix + uses: cachix/install-nix-action@v27 + with: + nix_path: nixpkgs=channel:nixos-unstable + + - name: Build project + run: nix build + + - name: Run tests + run: nix flake check diff --git a/Changelog.md b/Changelog.md index 04be8d4..fff3bd8 100644 --- a/Changelog.md +++ b/Changelog.md @@ -1,5 +1,8 @@ # ReScript Linter Changelog +### 2026-01-27 - v0.4.0 +* Updated the AST to ReScript v12.1.0 + ### 2025-09-30 - v0.3.3 * Adds support for JSON output * To enable JSON output, use the `--json` flag when running the linter diff --git a/jscomp/common/bs_loc.ml b/compiler/common/bs_loc.ml similarity index 88% rename from jscomp/common/bs_loc.ml rename to compiler/common/bs_loc.ml index b7e2071..ff7df2b 100644 --- a/jscomp/common/bs_loc.ml +++ b/compiler/common/bs_loc.ml @@ -23,9 +23,9 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = Location.t = { - loc_start : Lexing.position; - loc_end : Lexing.position; - loc_ghost : bool; + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; } let is_ghost x = x.loc_ghost @@ -35,7 +35,7 @@ let merge (l : t) (r : t) = else if is_ghost r then l else match (l, r) with - | { loc_start; _ }, { loc_end; _ } (* TODO: improve*) -> - { loc_start; loc_end; loc_ghost = false } + | {loc_start; _}, {loc_end; _} (* TODO: improve*) -> + {loc_start; loc_end; loc_ghost = false} (* let none = Location.none *) diff --git a/jscomp/common/bs_loc.mli b/compiler/common/bs_loc.mli similarity index 94% rename from jscomp/common/bs_loc.mli rename to compiler/common/bs_loc.mli index a642957..de22c2d 100644 --- a/jscomp/common/bs_loc.mli +++ b/compiler/common/bs_loc.mli @@ -23,9 +23,9 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = Location.t = { - loc_start : Lexing.position; - loc_end : Lexing.position; - loc_ghost : bool; + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; } (* val is_ghost : t -> bool *) diff --git a/jscomp/common/bs_version.ml b/compiler/common/bs_version.ml similarity index 96% rename from jscomp/common/bs_version.ml rename to compiler/common/bs_version.ml index b60de7a..2f7032c 100644 --- a/jscomp/common/bs_version.ml +++ b/compiler/common/bs_version.ml @@ -21,6 +21,5 @@ * You should have received a copy of the GNU Lesser General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let version = "11.1.4" +let version = "12.1.0" let header = "// Generated by ReScript, PLEASE EDIT WITH CARE" -let package_name = ref "rescript" diff --git a/jscomp/common/bs_version.mli b/compiler/common/bs_version.mli similarity index 97% rename from jscomp/common/bs_version.mli rename to compiler/common/bs_version.mli index 4d3721e..4ad826e 100644 --- a/jscomp/common/bs_version.mli +++ b/compiler/common/bs_version.mli @@ -25,5 +25,3 @@ val version : string val header : string - -val package_name : string ref diff --git a/jscomp/common/bs_warnings.ml b/compiler/common/bs_warnings.ml similarity index 93% rename from jscomp/common/bs_warnings.ml rename to compiler/common/bs_warnings.ml index 698a307..aeea997 100644 --- a/jscomp/common/bs_warnings.ml +++ b/compiler/common/bs_warnings.ml @@ -22,9 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let warn_missing_primitive loc txt = - Location.prerr_warning loc (Bs_unimplemented_primitive txt) - let warn_literal_overflow loc = Location.prerr_warning loc Bs_integer_literal_overflow diff --git a/jscomp/common/bs_warnings.mli b/compiler/common/bs_warnings.mli similarity index 96% rename from jscomp/common/bs_warnings.mli rename to compiler/common/bs_warnings.mli index 6533581..3807bbf 100644 --- a/jscomp/common/bs_warnings.mli +++ b/compiler/common/bs_warnings.mli @@ -22,8 +22,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val warn_missing_primitive : Location.t -> string -> unit - val warn_literal_overflow : Location.t -> unit val error_unescaped_delimiter : Location.t -> string -> unit diff --git a/compiler/common/dune b/compiler/common/dune new file mode 100644 index 0000000..b6962b3 --- /dev/null +++ b/compiler/common/dune @@ -0,0 +1,9 @@ +(library + (name common) + (wrapped false) + (preprocess + (action + (run %{bin:cppo} %{env:CPPO_FLAGS=} %{input-file}))) + (flags + (:standard -w +a-9-40-42)) + (libraries syntax)) diff --git a/jscomp/common/ext_log.ml b/compiler/common/ext_log.ml similarity index 94% rename from jscomp/common/ext_log.ml rename to compiler/common/ext_log.ml index ab58b99..5f88492 100644 --- a/jscomp/common/ext_log.ml +++ b/compiler/common/ext_log.ml @@ -30,7 +30,7 @@ let dwarn ?(__POS__ : (string * int * int * int) option) f = match __POS__ with | None -> Format.fprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") | Some (file, line, _, _) -> - Format.fprintf Format.err_formatter - ("WARN: %s,%d " ^^ f ^^ "@.") - file line + Format.fprintf Format.err_formatter + ("WARN: %s,%d " ^^ f ^^ "@.") + file line else Format.ifprintf Format.err_formatter ("WARN: " ^^ f ^^ "@.") diff --git a/jscomp/common/ext_log.mli b/compiler/common/ext_log.mli similarity index 100% rename from jscomp/common/ext_log.mli rename to compiler/common/ext_log.mli diff --git a/jscomp/common/js_config.ml b/compiler/common/js_config.ml similarity index 77% rename from jscomp/common/js_config.ml rename to compiler/common/js_config.ml index 7602c68..24aa8b6 100644 --- a/jscomp/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -24,9 +24,8 @@ (** Browser is not set via command line only for internal use *) -type jsx_version = Jsx_v3 | Jsx_v4 -type jsx_module = React | Generic of {moduleName: string} -type jsx_mode = Classic | Automatic +type jsx_version = Jsx_v4 +type jsx_module = React | Generic of {module_name: string} let no_version_header = ref false @@ -51,41 +50,25 @@ let force_cmi = ref false let force_cmj = ref false let jsx_version = ref None let jsx_module = ref React -let jsx_mode = ref Automatic +let jsx_preserve = ref false let js_stdout = ref true let all_module_aliases = ref false let no_stdlib = ref false let no_export = ref false -let as_ppx = ref false - let int_of_jsx_version = function -| Jsx_v3 -> 3 -| Jsx_v4 -> 4 + | Jsx_v4 -> 4 let string_of_jsx_module = function -| React -> "react" -| Generic {moduleName} -> moduleName - -let string_of_jsx_mode = function -| Classic -> "classic" -| Automatic -> "automatic" + | React -> "react" + | Generic {module_name} -> module_name let jsx_version_of_int = function -| 3 -> Some Jsx_v3 -| 4 -> Some Jsx_v4 -| _ -> None + | 4 -> Some Jsx_v4 + | _ -> None let jsx_module_of_string = function -| "react" -> React -| moduleName -> Generic {moduleName} - -let jsx_mode_of_string = function -| "classic" -> Classic -| "automatic" -> Automatic -| _ -> Classic + | "react" -> React + | module_name -> Generic {module_name} -(* option to config `@rescript/std`*) -let customize_runtime : string option ref = ref None let as_pp = ref false let self_stack : string Stack.t = Stack.create () -let modules = ref false \ No newline at end of file diff --git a/jscomp/common/js_config.mli b/compiler/common/js_config.mli similarity index 88% rename from jscomp/common/js_config.mli rename to compiler/common/js_config.mli index fd9df57..d6f4bd8 100644 --- a/jscomp/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -22,9 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type jsx_version = Jsx_v3 | Jsx_v4 -type jsx_module = React | Generic of {moduleName: string} -type jsx_mode = Classic | Automatic +type jsx_version = Jsx_v4 +type jsx_module = React | Generic of {module_name: string} (* val get_packages_info : unit -> Js_packages_info.t *) @@ -79,9 +78,9 @@ val force_cmj : bool ref val jsx_version : jsx_version option ref -val jsx_module: jsx_module ref +val jsx_module : jsx_module ref -val jsx_mode: jsx_mode ref +val jsx_preserve : bool ref val js_stdout : bool ref @@ -91,24 +90,14 @@ val no_stdlib : bool ref val no_export : bool ref -val as_ppx : bool ref - val int_of_jsx_version : jsx_version -> int val string_of_jsx_module : jsx_module -> string -val string_of_jsx_mode : jsx_mode -> string - val jsx_version_of_int : int -> jsx_version option val jsx_module_of_string : string -> jsx_module -val jsx_mode_of_string : string -> jsx_mode - -val customize_runtime : string option ref - val as_pp : bool ref val self_stack : string Stack.t - -val modules : bool ref diff --git a/compiler/common/ml_binary.ml b/compiler/common/ml_binary.ml new file mode 100644 index 0000000..ae7e441 --- /dev/null +++ b/compiler/common/ml_binary.ml @@ -0,0 +1,57 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind + +type ast0 = Impl of Parsetree0.structure | Intf of Parsetree0.signature + +let magic_of_ast0 : ast0 -> string = function + | Impl _ -> Config.ast_impl_magic_number + | Intf _ -> Config.ast_intf_magic_number + +let to_ast0 : type a. a kind -> a -> ast0 = + fun kind ast -> + match kind with + | Ml -> + Impl + (Ast_mapper_to0.default_mapper.structure Ast_mapper_to0.default_mapper ast) + | Mli -> + Intf + (Ast_mapper_to0.default_mapper.signature Ast_mapper_to0.default_mapper ast) + +let ast0_to_structure : ast0 -> Parsetree.structure = function + | Impl str0 -> + Ast_mapper_from0.default_mapper.structure Ast_mapper_from0.default_mapper + str0 + | Intf _ -> assert false + +let ast0_to_signature : ast0 -> Parsetree.signature = function + | Impl _ -> assert false + | Intf sig0 -> + Ast_mapper_from0.default_mapper.signature Ast_mapper_from0.default_mapper + sig0 + +let magic_of_kind : type a. a kind -> string = function + | Ml -> Config.ast_impl_magic_number + | Mli -> Config.ast_intf_magic_number diff --git a/jscomp/common/ml_binary.mli b/compiler/common/ml_binary.mli similarity index 85% rename from jscomp/common/ml_binary.mli rename to compiler/common/ml_binary.mli index fd40316..7749e8c 100644 --- a/jscomp/common/ml_binary.mli +++ b/compiler/common/ml_binary.mli @@ -27,8 +27,10 @@ *) type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind -val read_ast : 'a kind -> in_channel -> 'a - -val write_ast : 'a kind -> string -> 'a -> out_channel -> unit +type ast0 = Impl of Parsetree0.structure | Intf of Parsetree0.signature val magic_of_kind : 'a kind -> string +val magic_of_ast0 : ast0 -> string +val to_ast0 : 'a kind -> 'a -> ast0 +val ast0_to_structure : ast0 -> Parsetree.structure +val ast0_to_signature : ast0 -> Parsetree.signature diff --git a/compiler/common/pattern_printer.ml b/compiler/common/pattern_printer.ml new file mode 100644 index 0000000..603f980 --- /dev/null +++ b/compiler/common/pattern_printer.ml @@ -0,0 +1,108 @@ +open Types +open Typedtree +open Parsetree +open Asttypes + +let mkpat desc = Ast_helper.Pat.mk desc + +let[@warning "-4"] is_generated_optional_constructor + (lid : Longident.t Location.loc) = + match lid.txt with + | Longident.Lident name -> + String.length name >= 2 && name.[0] = '#' && name.[1] = '$' + | _ -> false + +(* Optional fields become “option-of-option” internally: the outer layer is + added by the compiler to track presence, while the inner layer is the user’s + payload. When printing counterexamples we only need to know which of these + situations we saw. *) +type optional_field_state = + | Field_normal (* Regular user patterns: `{b: Some(_)}`, `{b}`, `_`, etc. *) + | Field_missing + (* The outer constructor was the synthetic `#$None…`, i.e. the field was + not provided at all. This is what should print as `{b: ?None}`. *) + | Field_present_none +(* The outer constructor was the synthetic `#$Some…` but its payload was `None`. + This means the optional field exists with value `None`, so we should + print `{b: None}`. *) + +(* Optional record fields are lowered into an extra option layer; we re-infer + whether we’re looking at a missing field vs. a present-but-`None` value so + we can render useful surface syntax in error messages. *) +let[@warning "-4"] rec classify_optional_field_state pat = + match pat.pat_desc with + | Tpat_construct (lid, cstr, []) + when is_generated_optional_constructor lid && cstr.cstr_name = "None" -> + Field_missing + | Tpat_construct (lid, cstr, [inner]) + when is_generated_optional_constructor lid && cstr.cstr_name = "Some" -> ( + match classify_optional_field_state inner with + | Field_missing | Field_present_none -> Field_present_none + | Field_normal -> Field_normal) + | _ -> Field_normal + +let none_pattern = + mkpat (Ppat_construct (mknoloc (Longident.Lident "None"), None)) + +let[@warning "-4"] strip_synthetic_some pat = + match pat.pat_desc with + | Tpat_construct (lid, cstr, [inner]) + when is_generated_optional_constructor lid && cstr.cstr_name = "Some" -> + inner + | _ -> pat + +let untype typed = + let rec loop pat = + match pat.pat_desc with + | Tpat_or (p1, {pat_desc = Tpat_or (p2, p3, r_i)}, r_o) -> + (* Turn A | (B | C) into (A | B) | C for pretty printing without parens *) + let new_inner = {pat with pat_desc = Tpat_or (p1, p2, r_i)} in + let new_outer = {pat with pat_desc = Tpat_or (new_inner, p3, r_o)} in + loop new_outer + | Tpat_or (pa, pb, _) -> mkpat (Ppat_or (loop pa, loop pb)) + | Tpat_any | Tpat_var _ -> mkpat Ppat_any + | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) + | Tpat_alias (p, _, _) -> loop p + | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) + | Tpat_construct (cstr_lid, cstr, lst) -> + let lid = {cstr_lid with txt = Longident.Lident cstr.cstr_name} in + let arg = + match List.map loop lst with + | [] -> None + | [p] -> Some p + | lst -> Some (mkpat (Ppat_tuple lst)) + in + mkpat (Ppat_construct (lid, arg)) + | Tpat_variant (label, p_opt, _row_desc) -> + let arg = Option.map loop p_opt in + mkpat (Ppat_variant (label, arg)) + | Tpat_record (subpatterns, closed_flag) -> + let fields, saw_optional_rewrite = + List.fold_right + (fun (_, lbl, p, opt) (fields, saw_optional_rewrite) -> + let state = + if lbl.lbl_optional then classify_optional_field_state p + else Field_normal + in + let opt, par_pat, rewrote_optional = + match state with + | Field_missing -> (true, none_pattern, true) + | Field_present_none -> (opt, loop (strip_synthetic_some p), true) + | Field_normal -> (opt, loop p, false) + in + let field = + {lid = mknoloc (Longident.Lident lbl.lbl_name); x = par_pat; opt} + in + (field :: fields, saw_optional_rewrite || rewrote_optional)) + subpatterns ([], false) + in + let closed_flag = if saw_optional_rewrite then Closed else closed_flag in + mkpat (Ppat_record (fields, closed_flag)) + | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) + in + loop typed + +let print_pattern typed = + let pat = untype typed in + let doc = Res_printer.print_pattern pat Res_comments_table.empty in + Res_doc.to_string ~width:80 doc diff --git a/jscomp/common/pattern_printer.mli b/compiler/common/pattern_printer.mli similarity index 100% rename from jscomp/common/pattern_printer.mli rename to compiler/common/pattern_printer.mli diff --git a/compiler/dune b/compiler/dune new file mode 100644 index 0000000..9739601 --- /dev/null +++ b/compiler/dune @@ -0,0 +1,31 @@ +(dirs + common + flow_parser + ext + ml + syntax) + +(library + (name compiler) + (wrapped false) + (libraries ext ml syntax)) + +(env + (dev + (env-vars + (CPPO_FLAGS -U=RELEASE))) + (release + (env-vars + (CPPO_FLAGS -D=RELEASE)) + (ocamlopt_flags + (:standard -O3 -unbox-closures))) + (static + (env-vars + (CPPO_FLAGS -D=RELEASE)) + (ocamlopt_flags + (:standard -O3 -unbox-closures))) + (browser + (env-vars + (CPPO_FLAGS -D=BROWSER)) + (ocamlopt_flags + (:standard -O3 -unbox-closures)))) diff --git a/jscomp/ext/README.md b/compiler/ext/README.md similarity index 100% rename from jscomp/ext/README.md rename to compiler/ext/README.md diff --git a/jscomp/ext/bs_hash_stubs.ml b/compiler/ext/bs_hash_stubs.ml similarity index 100% rename from jscomp/ext/bs_hash_stubs.ml rename to compiler/ext/bs_hash_stubs.ml diff --git a/jscomp/ext/bsb_db.ml b/compiler/ext/bsb_db.ml similarity index 88% rename from jscomp/ext/bsb_db.ml rename to compiler/ext/bsb_db.ml index 001824a..b08e694 100644 --- a/jscomp/ext/bsb_db.ml +++ b/compiler/ext/bsb_db.ml @@ -31,19 +31,16 @@ type info = | Impl | Impl_intf -type syntax_kind = Ml | Res - type module_info = { - mutable info : info; - dir : string; - syntax_kind : syntax_kind; - case : bool; - name_sans_extension : string; + mutable info: info; + dir: string; + case: bool; + name_sans_extension: string; } type map = module_info Map_string.t -type 'a cat = { mutable lib : 'a; mutable dev : 'a } +type 'a cat = {mutable lib: 'a; mutable dev: 'a} type t = map cat (** indexed by the group *) diff --git a/jscomp/ext/bsb_db.mli b/compiler/ext/bsb_db.mli similarity index 83% rename from jscomp/ext/bsb_db.mli rename to compiler/ext/bsb_db.mli index 31df8b6..3b54f9f 100644 --- a/jscomp/ext/bsb_db.mli +++ b/compiler/ext/bsb_db.mli @@ -37,23 +37,16 @@ type info = | Impl | Impl_intf -type syntax_kind = Ml | Res - type module_info = { - mutable info : info; - dir : string; - syntax_kind : syntax_kind; - (* This is actually not stored in bsbuild meta info - since creating .d file only emit .cmj/.cmi dependencies, so it does not - need know which syntax it is written - *) - case : bool; - name_sans_extension : string; + mutable info: info; + dir: string; + case: bool; + name_sans_extension: string; } type map = module_info Map_string.t -type 'a cat = { mutable lib : 'a; mutable dev : 'a } +type 'a cat = {mutable lib: 'a; mutable dev: 'a} type t = map cat diff --git a/compiler/ext/bsc_args.ml b/compiler/ext/bsc_args.ml new file mode 100644 index 0000000..1f907eb --- /dev/null +++ b/compiler/ext/bsc_args.ml @@ -0,0 +1,131 @@ +(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +type anon_fun = rev_args:string list -> unit + +type string_action = + | String_call of (string -> unit) + | String_set of string ref + | String_optional_set of string option ref + | String_list_add of string list ref + +type unit_action = + | Unit_call of (unit -> unit) + | Unit_lazy of unit lazy_t + | Unit_set of bool ref + | Unit_clear of bool ref + +type spec = Unit_dummy | Unit of unit_action | String of string_action + +exception Bad = Arg.Bad + +let bad_arg s = raise_notrace (Bad s) + +type error = Unknown of string | Missing of string + +type t = spec Ext_spec.t + +let ( +> ) = Ext_buffer.add_string + +let usage_b (buf : Ext_buffer.t) ~usage (speclist : t) = + buf +> usage; + buf +> "\nOptions:\n"; + let max_col = ref 0 in + Ext_array.iter speclist (fun (key, _, _) -> + if String.length key > !max_col then max_col := String.length key); + Ext_array.iter speclist (fun (key, _, doc) -> + if not (Ext_string.starts_with doc "*internal*") then ( + buf +> " "; + buf +> key; + buf +> String.make (!max_col - String.length key + 2) ' '; + let cur = ref 0 in + let doc_length = String.length doc in + while !cur < doc_length do + match String.index_from_opt doc !cur '\n' with + | None -> + if !cur <> 0 then ( + buf +> "\n"; + buf +> String.make (!max_col + 4) ' '); + buf +> String.sub doc !cur (String.length doc - !cur); + cur := doc_length + | Some new_line_pos -> + if !cur <> 0 then ( + buf +> "\n"; + buf +> String.make (!max_col + 4) ' '); + buf +> String.sub doc !cur (new_line_pos - !cur); + cur := new_line_pos + 1 + done; + buf +> "\n")) + +let stop_raise ~usage ~(error : error) (speclist : t) = + let b = Ext_buffer.create 200 in + (match error with + | Unknown ("-help" | "--help" | "-h") -> + usage_b b ~usage speclist; + Ext_buffer.output_buffer stdout b; + exit 0 + | Unknown s -> + b +> "Unknown option \""; + b +> s; + b +> "\".\n" + | Missing s -> + b +> "Option \""; + b +> s; + b +> "\" needs an argument.\n"); + usage_b b ~usage speclist; + bad_arg (Ext_buffer.contents b) + +let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) + (speclist : t) (anonfun : rev_args:string list -> unit) = + let current = ref start in + let rev_list = ref [] in + while !current < finish do + let s = argv.(!current) in + incr current; + if s <> "" && s.[0] = '-' then + match Ext_spec.assoc3 speclist s with + | Some action -> ( + match action with + | Unit_dummy -> () + | Unit r -> ( + match r with + | Unit_set r -> r := true + | Unit_clear r -> r := false + | Unit_call f -> f () + | Unit_lazy f -> Lazy.force f) + | String f -> ( + if !current >= finish then + stop_raise ~usage ~error:(Missing s) speclist + else + let arg = argv.(!current) in + incr current; + match f with + | String_call f -> f arg + | String_set u -> u := arg + | String_optional_set s -> s := Some arg + | String_list_add s -> s := arg :: !s)) + | None -> stop_raise ~usage ~error:(Unknown s) speclist + else rev_list := s :: !rev_list + done; + anonfun ~rev_args:!rev_list diff --git a/jscomp/ext/bsc_args.mli b/compiler/ext/bsc_args.mli similarity index 100% rename from jscomp/ext/bsc_args.mli rename to compiler/ext/bsc_args.mli diff --git a/compiler/ext/bsc_warnings.ml b/compiler/ext/bsc_warnings.ml new file mode 100644 index 0000000..83ec412 --- /dev/null +++ b/compiler/ext/bsc_warnings.ml @@ -0,0 +1,52 @@ +(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(* + The purpose of the default warning set is to make it strict while not annoying the user too much. + + - 4 Fragile pattern matching: matching that will remain complete even if additional constructors are added to one of the variant types matched. + We turn it off since the following is a common pattern: + {[ + switch x { | A => .. | _ => false } + ]} + + - 9 Missing fields in a record pattern. + Only in some special cases that we need all fields being listed + + - 41 Ambiguous constructor or label name. + It is turned off since it prevents such cases below: + {[ + type a = A | B + type b = A | B | C + ]} + + - 50 Unexpected documentation comment. + + - 102 Bs_polymorphic_comparison. +*) +(* If you change this, don't forget to adapt docs/docson/build-schema.json as well. *) +let defaults_w = "+a-4-9-20-41-50-102" + +let defaults_warn_error = "-a+5+6+101+109" +(*TODO: add +10*) diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml new file mode 100644 index 0000000..d9f7bb6 --- /dev/null +++ b/compiler/ext/config.ml @@ -0,0 +1,9 @@ +let cmi_magic_number = "Caml1999I022" + +and ast_impl_magic_number = "Caml1999M022" + +and ast_intf_magic_number = "Caml1999N022" + +and cmt_magic_number = "Caml1999T022" + +let load_path = ref ([] : string list) diff --git a/jscomp/ext/config.mli b/compiler/ext/config.mli similarity index 77% rename from jscomp/ext/config.mli rename to compiler/ext/config.mli index d409fe0..fe13a03 100644 --- a/jscomp/ext/config.mli +++ b/compiler/ext/config.mli @@ -15,23 +15,8 @@ (* System configuration *) -val version : string -(* The current version number of the system *) - -val standard_library : string -(* The directory containing the standard libraries *) - -val syntax_kind : [ `ml | `rescript ] ref - -val bs_only : bool ref - -val unsafe_empty_array : bool ref - -val load_path : string list ref (* Directories in the search path for .cmi and .cmo files *) - -val interface_suffix : string ref -(* Suffix for interface file names *) +val load_path : string list ref val cmi_magic_number : string @@ -44,8 +29,3 @@ val ast_impl_magic_number : string (* Magic number for file holding an implementation syntax tree *) val cmt_magic_number : string (* Magic number for compiled interface files *) - -val print_config : out_channel -> unit - -type uncurried = Legacy | Uncurried | Swap -val uncurried : uncurried ref \ No newline at end of file diff --git a/compiler/ext/dune b/compiler/ext/dune new file mode 100644 index 0000000..0896ec2 --- /dev/null +++ b/compiler/ext/dune @@ -0,0 +1,126 @@ +(library + (name ext) + (wrapped false) + (preprocess + (action + (run + %{bin:cppo} + -V + OCAML:%{ocaml_version} + %{env:CPPO_FLAGS=} + %{input-file}))) + (flags + (:standard -w +a-4-42-40-9-48-70)) + (foreign_stubs + (language c) + (names ext_basic_hash_stubs))) + +(ocamllex ext_json_parse) + +(rule + (targets hash_set_string.ml) + (deps hash_set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) + +(rule + (targets hash_set_int.ml) + (deps hash_set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) + +(rule + (targets hash_set_ident.ml) + (deps hash_set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) + +(rule + (targets hash_set.ml) + (deps hash_set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) + +(rule + (targets hash_set_poly.ml) + (deps hash_set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_POLY %{deps} -o %{targets}))) + +(rule + (targets vec_int.ml) + (deps vec.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) + +(rule + (targets vec.ml) + (deps vec.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) + +(rule + (targets set_string.ml) + (deps set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) + +(rule + (targets set_int.ml) + (deps set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) + +(rule + (targets set_ident.ml) + (deps set.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) + +(rule + (targets map_string.ml) + (deps map.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) + +(rule + (targets map_int.ml) + (deps map.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) + +(rule + (targets map_ident.ml) + (deps map.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) + +(rule + (targets ordered_hash_map_local_ident.ml) + (deps ordered_hash_map.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_LOCAL_IDENT %{deps} -o %{targets}))) + +(rule + (targets hash_string.ml) + (deps hash.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) + +(rule + (targets hash_int.ml) + (deps hash.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) + +(rule + (targets hash_ident.ml) + (deps hash.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) + +(rule + (targets hash.ml) + (deps hash.cppo.ml) + (action + (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) diff --git a/jscomp/ext/encoding.md b/compiler/ext/encoding.md similarity index 100% rename from jscomp/ext/encoding.md rename to compiler/ext/encoding.md diff --git a/jscomp/ext/ext_array.ml b/compiler/ext/ext_array.ml similarity index 76% rename from jscomp/ext/ext_array.ml rename to compiler/ext/ext_array.ml index 0f3f1a7..9a416e5 100644 --- a/jscomp/ext/ext_array.ml +++ b/compiler/ext/ext_array.ml @@ -50,15 +50,15 @@ let reverse a = let reverse_of_list = function | [] -> [||] | hd :: tl -> - let len = List.length tl in - let a = Array.make (len + 1) hd in - let rec fill i = function - | [] -> a - | hd :: tl -> - Array.unsafe_set a i hd; - fill (i - 1) tl - in - fill (len - 1) tl + let len = List.length tl in + let a = Array.make (len + 1) hd in + let rec fill i = function + | [] -> a + | hd :: tl -> + Array.unsafe_set a i hd; + fill (i - 1) tl + in + fill (len - 1) tl let filter a f = let arr_len = Array.length a in @@ -76,7 +76,21 @@ let filter_map a (f : _ -> _ option) = if i = arr_len then reverse_of_list acc else let v = Array.unsafe_get a i in - match f v with Some v -> aux (v :: acc) (i + 1) | None -> aux acc (i + 1) + match f v with + | Some v -> aux (v :: acc) (i + 1) + | None -> aux acc (i + 1) + in + aux [] 0 + +let filter_mapi a (f : _ -> _ -> _ option) = + let arr_len = Array.length a in + let rec aux acc i = + if i = arr_len then reverse_of_list acc + else + let v = Array.unsafe_get a i in + match f i v with + | Some v -> aux (v :: acc) (i + 1) + | None -> aux acc (i + 1) in aux [] 0 @@ -101,7 +115,9 @@ let rec tolist_aux a f i res = if i < 0 then res else tolist_aux a f (i - 1) - (match f a.!(i) with Some v -> v :: res | None -> res) + (match f a.!(i) with + | Some v -> v :: res + | None -> res) let to_list_map a f = tolist_aux a f (Array.length a - 1) [] @@ -110,50 +126,50 @@ let to_list_map_acc a acc f = tolist_aux a f (Array.length a - 1) acc let of_list_map a f = match a with | [] -> [||] - | [ a0 ] -> - let b0 = f a0 in - [| b0 |] - | [ a0; a1 ] -> - let b0 = f a0 in - let b1 = f a1 in - [| b0; b1 |] - | [ a0; a1; a2 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - [| b0; b1; b2 |] - | [ a0; a1; a2; a3 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - [| b0; b1; b2; b3 |] - | [ a0; a1; a2; a3; a4 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - [| b0; b1; b2; b3; b4 |] + | [a0] -> + let b0 = f a0 in + [|b0|] + | [a0; a1] -> + let b0 = f a0 in + let b1 = f a1 in + [|b0; b1|] + | [a0; a1; a2] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + [|b0; b1; b2|] + | [a0; a1; a2; a3] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + [|b0; b1; b2; b3|] + | [a0; a1; a2; a3; a4] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + [|b0; b1; b2; b3; b4|] | a0 :: a1 :: a2 :: a3 :: a4 :: tl -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - let len = List.length tl + 5 in - let arr = Array.make len b0 in - Array.unsafe_set arr 1 b1; - Array.unsafe_set arr 2 b2; - Array.unsafe_set arr 3 b3; - Array.unsafe_set arr 4 b4; - let rec fill i = function - | [] -> arr - | hd :: tl -> - Array.unsafe_set arr i (f hd); - fill (i + 1) tl - in - fill 5 tl + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + let len = List.length tl + 5 in + let arr = Array.make len b0 in + Array.unsafe_set arr 1 b1; + Array.unsafe_set arr 2 b2; + Array.unsafe_set arr 3 b3; + Array.unsafe_set arr 4 b4; + let rec fill i = function + | [] -> arr + | hd :: tl -> + Array.unsafe_set arr i (f hd); + fill (i + 1) tl + in + fill 5 tl (** {[ diff --git a/jscomp/ext/ext_array.mli b/compiler/ext/ext_array.mli similarity index 97% rename from jscomp/ext/ext_array.mli rename to compiler/ext/ext_array.mli index 6e55062..b55bd1a 100644 --- a/jscomp/ext/ext_array.mli +++ b/compiler/ext/ext_array.mli @@ -35,6 +35,8 @@ val filter : 'a array -> ('a -> bool) -> 'a array val filter_map : 'a array -> ('a -> 'b option) -> 'b array +val filter_mapi : 'a array -> (int -> 'a -> 'b option) -> 'b array + val range : int -> int -> int array val map2i : (int -> 'a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array diff --git a/jscomp/ext/ext_basic_hash_stubs.c b/compiler/ext/ext_basic_hash_stubs.c similarity index 100% rename from jscomp/ext/ext_basic_hash_stubs.c rename to compiler/ext/ext_basic_hash_stubs.c diff --git a/jscomp/ext/ext_buffer.ml b/compiler/ext/ext_buffer.ml similarity index 98% rename from jscomp/ext/ext_buffer.ml rename to compiler/ext/ext_buffer.ml index 1e478b3..5dbb839 100644 --- a/jscomp/ext/ext_buffer.ml +++ b/compiler/ext/ext_buffer.ml @@ -15,16 +15,12 @@ (* Extensible buffers *) -type t = { - mutable buffer : bytes; - mutable position : int; - mutable length : int; -} +type t = {mutable buffer: bytes; mutable position: int; mutable length: int} let create n = let n = if n < 1 then 1 else n in let s = Bytes.create n in - { buffer = s; position = 0; length = n } + {buffer = s; position = 0; length = n} let contents b = Bytes.sub_string b.buffer 0 b.position (* let to_bytes b = Bytes.sub b.buffer 0 b.position *) diff --git a/jscomp/ext/ext_buffer.mli b/compiler/ext/ext_buffer.mli similarity index 99% rename from jscomp/ext/ext_buffer.mli rename to compiler/ext/ext_buffer.mli index 38ae58e..a00115b 100644 --- a/jscomp/ext/ext_buffer.mli +++ b/compiler/ext/ext_buffer.mli @@ -51,7 +51,6 @@ val clear : t -> unit (** Empty the buffer. *) val add_char : t -> char -> unit - [@@inline] (** [add_char b c] appends the character [c] at the end of the buffer [b]. *) val add_string : t -> string -> unit diff --git a/jscomp/ext/ext_bytes.ml b/compiler/ext/ext_bytes.ml similarity index 99% rename from jscomp/ext/ext_bytes.ml rename to compiler/ext/ext_bytes.ml index f4148eb..68808ab 100644 --- a/jscomp/ext/ext_bytes.ml +++ b/compiler/ext/ext_bytes.ml @@ -24,4 +24,4 @@ external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" - [@@noalloc] +[@@noalloc] diff --git a/jscomp/ext/ext_bytes.mli b/compiler/ext/ext_bytes.mli similarity index 99% rename from jscomp/ext/ext_bytes.mli rename to compiler/ext/ext_bytes.mli index f4148eb..68808ab 100644 --- a/jscomp/ext/ext_bytes.mli +++ b/compiler/ext/ext_bytes.mli @@ -24,4 +24,4 @@ external unsafe_blit_string : string -> int -> bytes -> int -> int -> unit = "caml_blit_string" - [@@noalloc] +[@@noalloc] diff --git a/jscomp/ext/ext_char.ml b/compiler/ext/ext_char.ml similarity index 95% rename from jscomp/ext/ext_char.ml rename to compiler/ext/ext_char.ml index 9dcb31a..3754665 100644 --- a/jscomp/ext/ext_char.ml +++ b/compiler/ext/ext_char.ml @@ -27,7 +27,9 @@ *) let valid_hex x = - match x with '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true | _ -> false + match x with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false let is_lower_case c = (c >= 'a' && c <= 'z') diff --git a/jscomp/ext/ext_char.mli b/compiler/ext/ext_char.mli similarity index 100% rename from jscomp/ext/ext_char.mli rename to compiler/ext/ext_char.mli diff --git a/jscomp/ext/ext_color.ml b/compiler/ext/ext_color.ml similarity index 90% rename from jscomp/ext/ext_color.ml rename to compiler/ext/ext_color.ml index d5ed3bb..db926ea 100644 --- a/jscomp/ext/ext_color.ml +++ b/compiler/ext/ext_color.ml @@ -59,11 +59,11 @@ let code_of_style = function (** TODO: add more styles later *) let style_of_tag s = match s with - | Format.String_tag "error" -> [ Bold; FG Red ] - | Format.String_tag "warning" -> [ Bold; FG Magenta ] - | Format.String_tag "info" -> [ Bold; FG Yellow ] - | Format.String_tag "dim" -> [ Dim ] - | Format.String_tag "filename" -> [ FG Cyan ] + | Format.String_tag "error" -> [Bold; FG Red] + | Format.String_tag "warning" -> [Bold; FG Magenta] + | Format.String_tag "info" -> [Bold; FG Yellow] + | Format.String_tag "dim" -> [Dim] + | Format.String_tag "filename" -> [FG Cyan] | _ -> [] let ansi_of_tag s = diff --git a/jscomp/ext/ext_color.mli b/compiler/ext/ext_color.mli similarity index 100% rename from jscomp/ext/ext_color.mli rename to compiler/ext/ext_color.mli diff --git a/jscomp/ext/ext_digest.ml b/compiler/ext/ext_digest.ml similarity index 100% rename from jscomp/ext/ext_digest.ml rename to compiler/ext/ext_digest.ml diff --git a/jscomp/ext/ext_digest.mli b/compiler/ext/ext_digest.mli similarity index 100% rename from jscomp/ext/ext_digest.mli rename to compiler/ext/ext_digest.mli diff --git a/compiler/ext/ext_file_extensions.ml b/compiler/ext/ext_file_extensions.ml new file mode 100644 index 0000000..9004b58 --- /dev/null +++ b/compiler/ext/ext_file_extensions.ml @@ -0,0 +1,16 @@ +type valid_input = Res | Resi | Intf_ast | Impl_ast | Mlmap | Cmi | Unknown + +(** This is per-file based, + when [ocamlc] [-c -o another_dir/xx.cmi] + it will return (another_dir/xx) +*) + +let classify_input ext = + match () with + | _ when ext = Literals.suffix_ast -> Impl_ast + | _ when ext = Literals.suffix_iast -> Intf_ast + | _ when ext = Literals.suffix_mlmap -> Mlmap + | _ when ext = Literals.suffix_cmi -> Cmi + | _ when ext = Literals.suffix_res -> Res + | _ when ext = Literals.suffix_resi -> Resi + | _ -> Unknown diff --git a/jscomp/ext/ext_filename.ml b/compiler/ext/ext_filename.ml similarity index 89% rename from jscomp/ext/ext_filename.ml rename to compiler/ext/ext_filename.ml index a12e0cc..cb3302b 100644 --- a/jscomp/ext/ext_filename.ml +++ b/compiler/ext/ext_filename.ml @@ -34,7 +34,7 @@ let maybe_quote (s : string) = Ext_string.for_all s (function | '0' .. '9' | 'a' .. 'z' | 'A' .. 'Z' | '_' | '+' | '-' | '.' | '/' | '@' -> - true + true | _ -> false) in if noneed_quote then s else Filename.quote s @@ -59,7 +59,9 @@ let get_extension_maybe name = let chop_all_extensions_maybe name = let rec search_dot i last = if i < 0 || is_dir_sep (String.unsafe_get name i) then - match last with None -> name | Some i -> String.sub name 0 i + match last with + | None -> name + | Some i -> String.sub name 0 i else if String.unsafe_get name i = '.' then search_dot (i - 1) (Some i) else search_dot (i - 1) last in @@ -95,7 +97,7 @@ let module_name name = let name_len = String.length name in search_dot (name_len - 1) name -type module_info = { module_name : string; case : bool } +type module_info = {module_name: string; case: bool} let rec valid_module_name_aux name off len = if off >= len then true @@ -103,7 +105,7 @@ let rec valid_module_name_aux name off len = let c = String.unsafe_get name off in match c with | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' | '.' | '[' | ']' -> - valid_module_name_aux name (off + 1) len + valid_module_name_aux name (off + 1) len | _ -> false type state = Invalid | Upper | Lower @@ -115,7 +117,7 @@ let valid_module_name name len = match c with | 'A' .. 'Z' -> if valid_module_name_aux name 1 len then Upper else Invalid | 'a' .. 'z' | '0' .. '9' | '_' | '[' | ']' -> - if valid_module_name_aux name 1 len then Lower else Invalid + if valid_module_name_aux name 1 len then Lower else Invalid | _ -> Invalid let as_module ~basename = @@ -124,17 +126,17 @@ let as_module ~basename = (* Input e.g, [a_b] *) match valid_module_name name name_len with | Invalid -> None - | Upper -> Some { module_name = name; case = true } + | Upper -> Some {module_name = name; case = true} | Lower -> - Some { module_name = Ext_string.capitalize_ascii name; case = false } + Some {module_name = Ext_string.capitalize_ascii name; case = false} else if String.unsafe_get name i = '.' then (*Input e.g, [A_b] *) match valid_module_name name i with | Invalid -> None | Upper -> - Some { module_name = Ext_string.capitalize_sub name i; case = true } + Some {module_name = Ext_string.capitalize_sub name i; case = true} | Lower -> - Some { module_name = Ext_string.capitalize_sub name i; case = false } + Some {module_name = Ext_string.capitalize_sub name i; case = false} else search_dot (i - 1) name name_len in let name_len = String.length basename in diff --git a/jscomp/ext/ext_filename.mli b/compiler/ext/ext_filename.mli similarity index 97% rename from jscomp/ext/ext_filename.mli rename to compiler/ext/ext_filename.mli index e95c3f2..e111ee2 100644 --- a/jscomp/ext/ext_filename.mli +++ b/compiler/ext/ext_filename.mli @@ -47,6 +47,6 @@ val chop_all_extensions_maybe : string -> string (* OCaml specific abstraction*) val module_name : string -> string -type module_info = { module_name : string; case : bool } +type module_info = {module_name: string; case: bool} val as_module : basename:string -> module_info option diff --git a/jscomp/ext/ext_fmt.ml b/compiler/ext/ext_fmt.ml similarity index 100% rename from jscomp/ext/ext_fmt.ml rename to compiler/ext/ext_fmt.ml diff --git a/compiler/ext/ext_ident.ml b/compiler/ext/ext_ident.ml new file mode 100644 index 0000000..8a7910c --- /dev/null +++ b/compiler/ext/ext_ident.ml @@ -0,0 +1,183 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * 2017 - Hongbo Zhang, Authors of ReScript + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let js_flag = 0b1_000 (* check with ocaml compiler *) + +(* let js_module_flag = 0b10_000 (\* javascript external modules *\) *) +(* TODO: + check name conflicts with javascript conventions + {[ + Ext_ident.convert "^";; + - : string = "$caret" + ]} +*) +let js_object_flag = 0b100_000 (* javascript object flags *) + +let is_js (i : Ident.t) = i.flags land js_flag <> 0 + +let is_js_or_global (i : Ident.t) = i.flags land (8 lor 1) <> 0 + +let is_js_object (i : Ident.t) = i.flags land js_object_flag <> 0 + +let make_js_object (i : Ident.t) = i.flags <- i.flags lor js_object_flag + +(* It's a js function hard coded by js api, so when printing, + it should preserve the name +*) +let create_js (name : string) : Ident.t = {name; flags = js_flag; stamp = 0} + +let create = Ident.create + +(* FIXME: no need for `$' operator *) +let create_tmp ?(name = Literals.tmp) () = create name + +let js_module_table : Ident.t Hash_string.t = Hash_string.create 31 + +(* This is for a js exeternal module, we can change it when printing + for example + {[ + var React$1 = require('react'); + React$1.render(..) + ]} + + Given a name, if duplicated, they should have the same id +*) +(* let create_js_module (name : string) : Ident.t = + let name = + String.concat "" @@ Ext_list.map + (Ext_string.split name '-') Ext_string.capitalize_ascii in + (* TODO: if we do such transformation, we should avoid collision for example: + react-dom + react--dom + check collision later + *) + match Hash_string.find_exn js_module_table name with + | exception Not_found -> + let ans = Ident.create name in + (* let ans = { v with flags = js_module_flag} in *) + Hash_string.add js_module_table name ans; + ans + | v -> (* v *) Ident.rename v +*) + +let[@inline] convert ?(op = false) (c : char) : string = + match c with + | '*' -> "$star" + | '\'' -> "$p" + | '!' -> "$bang" + | '>' -> "$great" + | '<' -> "$less" + | '=' -> "$eq" + | '+' -> "$plus" + | '-' -> if op then "$neg" else "$" + | '@' -> "$at" + | '^' -> "$caret" + | '/' -> "$slash" + | '|' -> "$pipe" + | '.' -> "$dot" + | '%' -> "$percent" + | '~' -> "$tilde" + | '#' -> "$hash" + | ':' -> "$colon" + | '?' -> "$question" + | '&' -> "$amp" + | '(' -> "$lpar" + | ')' -> "$rpar" + | '{' -> "$lbrace" + | '}' -> "$lbrace" + | '[' -> "$lbrack" + | ']' -> "$rbrack" + | _ -> "$unknown" +let[@inline] no_escape (c : char) = + match c with + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '$' -> true + | _ -> false + +let is_uident name = + let len = String.length name in + if len > 0 then + match name.[0] with + | 'A' .. 'Z' -> true + | _ -> false + else false + +let is_uppercase_exotic name = + let len = String.length name in + len >= 3 && name.[0] = '\\' && name.[1] = '\"' && name.[len - 1] = '\"' + +let unwrap_uppercase_exotic name = + if is_uppercase_exotic name then + let len = String.length name in + String.sub name 2 (len - 3) + else name + +exception Not_normal_letter of int +let name_mangle name = + let len = String.length name in + try + for i = 0 to len - 1 do + if not (no_escape (String.unsafe_get name i)) then + raise_notrace (Not_normal_letter i) + done; + name (* Normal letter *) + with Not_normal_letter i -> + let buffer = Ext_buffer.create len in + for j = 0 to len - 1 do + let c = String.unsafe_get name j in + if no_escape c then Ext_buffer.add_char buffer c + else Ext_buffer.add_string buffer (convert ~op:(i = 0) c) + done; + Ext_buffer.contents buffer + +(** + [convert name] if [name] is a js keyword or js global, add "$$" + otherwise do the name mangling to make sure ocaml identifier it is + a valid js identifier +*) +let convert (name : string) = + let name = unwrap_uppercase_exotic name in + if Js_reserved_map.is_js_keyword name || Js_reserved_map.is_js_global name + then "$$" ^ name + else name_mangle name + +(** keyword could be used in property *) + +(* It is currently made a persistent ident to avoid fresh ids + which would result in different signature files + - other solution: use lazy values +*) +let make_unused () = create "_" + +let reset () = Hash_string.clear js_module_table + +(* Has to be total order, [x < y] + and [x > y] should be consistent + flags are not relevant here +*) +let compare (x : Ident.t) (y : Ident.t) = + let u = x.stamp - y.stamp in + if u = 0 then Ext_string.compare x.name y.name else u + +let equal (x : Ident.t) (y : Ident.t) = + if x.stamp <> 0 then x.stamp = y.stamp else y.stamp = 0 && x.name = y.name diff --git a/jscomp/ext/ext_ident.mli b/compiler/ext/ext_ident.mli similarity index 85% rename from jscomp/ext/ext_ident.mli rename to compiler/ext/ext_ident.mli index 290a635..ff21fca 100644 --- a/jscomp/ext/ext_ident.mli +++ b/compiler/ext/ext_ident.mli @@ -22,44 +22,37 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - (** A wrapper around [Ident] module in compiler-libs*) -val is_js : Ident.t -> bool +val is_js : Ident.t -> bool val is_js_object : Ident.t -> bool -(** create identifiers for predefined [js] global variables *) val create_js : string -> Ident.t +(** create identifiers for predefined [js] global variables *) val create : string -> Ident.t -val make_js_object : Ident.t -> unit +val make_js_object : Ident.t -> unit val reset : unit -> unit -val create_tmp : ?name:string -> unit -> Ident.t +val create_tmp : ?name:string -> unit -> Ident.t + +val make_unused : unit -> Ident.t -val make_unused : unit -> Ident.t +val is_uident : string -> bool +val is_uppercase_exotic : string -> bool +val unwrap_uppercase_exotic : string -> string +val convert : string -> string (** Invariant: if name is not converted, the reference should be equal *) -val convert : string -> string - - val is_js_or_global : Ident.t -> bool - - val compare : Ident.t -> Ident.t -> int -val equal : Ident.t -> Ident.t -> bool +val equal : Ident.t -> Ident.t -> bool diff --git a/jscomp/ext/ext_int.ml b/compiler/ext/ext_int.ml similarity index 81% rename from jscomp/ext/ext_int.ml rename to compiler/ext/ext_int.ml index f31d425..3c71537 100644 --- a/jscomp/ext/ext_int.ml +++ b/compiler/ext/ext_int.ml @@ -34,3 +34,15 @@ let move = 0x1_0000_0000 let int32_unsigned_to_int (n : int32) : int = let i = Int32.to_int n in if i < 0 then i + move else i + +let int32_pow (x : int32) (y : int32) = + let x_float = Int32.to_float x in + let y_float = Int32.to_float y in + let result = x_float ** y_float in + let truncated = + if result > 2147483647.0 || result < -2147483648.0 then + let i = int_of_float result in + i land 0xFFFFFFFF + else int_of_float result + in + Int32.of_int truncated diff --git a/jscomp/ext/ext_int.mli b/compiler/ext/ext_int.mli similarity index 97% rename from jscomp/ext/ext_int.mli rename to compiler/ext/ext_int.mli index acfc7af..0c61810 100644 --- a/jscomp/ext/ext_int.mli +++ b/compiler/ext/ext_int.mli @@ -33,3 +33,5 @@ val int32_unsigned_to_int : int32 -> int works on 64 bit platform only given input as an uint32 and convert it io int64 *) + +val int32_pow : int32 -> int32 -> int32 diff --git a/jscomp/ext/ext_io.ml b/compiler/ext/ext_io.ml similarity index 98% rename from jscomp/ext/ext_io.ml rename to compiler/ext/ext_io.ml index ee3a96e..ffb84a4 100644 --- a/jscomp/ext/ext_io.ml +++ b/compiler/ext/ext_io.ml @@ -35,8 +35,8 @@ let rev_lines_of_chann chan = match input_line chan with | line -> loop (line :: acc) chan | exception End_of_file -> - close_in chan; - acc + close_in chan; + acc in loop [] chan diff --git a/jscomp/ext/ext_io.mli b/compiler/ext/ext_io.mli similarity index 100% rename from jscomp/ext/ext_io.mli rename to compiler/ext/ext_io.mli diff --git a/jscomp/ext/ext_js_file_kind.ml b/compiler/ext/ext_js_file_kind.ml similarity index 95% rename from jscomp/ext/ext_js_file_kind.ml rename to compiler/ext/ext_js_file_kind.ml index 196ba32..2efce68 100644 --- a/jscomp/ext/ext_js_file_kind.ml +++ b/compiler/ext/ext_js_file_kind.ml @@ -23,4 +23,4 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type case = Upper | Little -type [@warning "-69"] t = { case : case; suffix : string } +type t = {case: case; suffix: string} [@@warning "-69"] diff --git a/jscomp/ext/ext_json.ml b/compiler/ext/ext_json.ml similarity index 85% rename from jscomp/ext/ext_json.ml rename to compiler/ext/ext_json.ml index 3dedb8d..90915a2 100644 --- a/jscomp/ext/ext_json.ml +++ b/compiler/ext/ext_json.ml @@ -44,18 +44,20 @@ let test ?(fail = fun () -> ()) key (cb : callback) (m : Ext_json_types.t Map_string.t) = (match (Map_string.find_exn m key, cb) with | exception Not_found -> ( - match cb with `Not_found f -> f () | _ -> fail ()) + match cb with + | `Not_found f -> f () + | _ -> fail ()) | True _, `Bool cb -> cb true | False _, `Bool cb -> cb false - | Flo { flo = s }, `Flo cb -> cb s - | Flo { flo = s; loc }, `Flo_loc cb -> cb s loc - | Obj { map = b }, `Obj cb -> cb b - | Arr { content }, `Arr cb -> cb content - | Arr { content; loc_start; loc_end }, `Arr_loc cb -> - cb content loc_start loc_end + | Flo {flo = s}, `Flo cb -> cb s + | Flo {flo = s; loc}, `Flo_loc cb -> cb s loc + | Obj {map = b}, `Obj cb -> cb b + | Arr {content}, `Arr cb -> cb content + | Arr {content; loc_start; loc_end}, `Arr_loc cb -> + cb content loc_start loc_end | Null _, `Null cb -> cb () - | Str { str = s }, `Str cb -> cb s - | Str { str = s; loc }, `Str_loc cb -> cb s loc + | Str {str = s}, `Str cb -> cb s + | Str {str = s; loc}, `Str_loc cb -> cb s loc | any, `Id cb -> cb any | _, _ -> fail ()); m diff --git a/jscomp/ext/ext_json.mli b/compiler/ext/ext_json.mli similarity index 100% rename from jscomp/ext/ext_json.mli rename to compiler/ext/ext_json.mli diff --git a/compiler/ext/ext_json_noloc.ml b/compiler/ext/ext_json_noloc.ml new file mode 100644 index 0000000..4977770 --- /dev/null +++ b/compiler/ext/ext_json_noloc.ml @@ -0,0 +1,127 @@ +(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(* This file is only used in bsb watcher searlization *) +type t = + | True + | False + | Null + | Flo of string + | Str of string + | Arr of t array + | Obj of t Map_string.t + +(** poor man's serialization *) +let naive_escaped (text : string) : string = + let ln = String.length text in + let buf = Buffer.create ln in + let rec loop i = + if i < ln then ( + (match text.[i] with + | '\012' -> Buffer.add_string buf "\\f" + | '\\' -> Buffer.add_string buf "\\\\" + | '"' -> Buffer.add_string buf "\\\"" + | '\n' -> Buffer.add_string buf "\\n" + | '\b' -> Buffer.add_string buf "\\b" + | '\r' -> Buffer.add_string buf "\\r" + | '\t' -> Buffer.add_string buf "\\t" + | c -> + let code = Char.code c in + if code < 0x20 then Printf.bprintf buf "\\u%04x" code + else Buffer.add_char buf c); + loop (i + 1)) + in + loop 0; + Buffer.contents buf + +let quot x = "\"" ^ naive_escaped x ^ "\"" + +let true_ = True + +let false_ = False + +let null = Null + +let str s = Str s + +let flo s = Flo s + +let arr s = Arr s + +let obj s = Obj s + +let kvs s = Obj (Map_string.of_list s) + +let rec encode_buf (x : t) (buf : Buffer.t) : unit = + let a str = Buffer.add_string buf str in + match x with + | Null -> a "null" + | Str s -> a (quot s) + | Flo s -> + a s + (* + since our parsing keep the original float representation, we just dump it as is, there is no cases like [nan] *) + | Arr content -> ( + match content with + | [||] -> a "[]" + | _ -> + a "[ "; + encode_buf (Array.unsafe_get content 0) buf; + for i = 1 to Array.length content - 1 do + a " , "; + encode_buf (Array.unsafe_get content i) buf + done; + a " ]") + | True -> a "true" + | False -> a "false" + | Obj map -> + if Map_string.is_empty map then a "{}" + else ( + (*prerr_endline "WEIRD"; + prerr_endline (string_of_int @@ Map_string.cardinal map ); *) + a "{ "; + let (_ : int) = + Map_string.fold map 0 (fun k v i -> + if i <> 0 then a " , "; + a (quot k); + a " : "; + encode_buf v buf; + i + 1) + in + a " }") + +let to_string x = + let buf = Buffer.create 1024 in + encode_buf x buf; + Buffer.contents buf + +let to_channel (oc : out_channel) x = + let buf = Buffer.create 1024 in + encode_buf x buf; + Buffer.output_buffer oc buf + +let to_file name v = + let ochan = open_out_bin name in + to_channel ochan v; + close_out ochan diff --git a/jscomp/ext/ext_json_noloc.mli b/compiler/ext/ext_json_noloc.mli similarity index 100% rename from jscomp/ext/ext_json_noloc.mli rename to compiler/ext/ext_json_noloc.mli diff --git a/jscomp/ext/ext_json_parse.mli b/compiler/ext/ext_json_parse.mli similarity index 100% rename from jscomp/ext/ext_json_parse.mli rename to compiler/ext/ext_json_parse.mli diff --git a/jscomp/ext/ext_json_parse.mll b/compiler/ext/ext_json_parse.mll similarity index 100% rename from jscomp/ext/ext_json_parse.mll rename to compiler/ext/ext_json_parse.mll diff --git a/jscomp/ext/ext_json_types.ml b/compiler/ext/ext_json_types.ml similarity index 87% rename from jscomp/ext/ext_json_types.ml rename to compiler/ext/ext_json_types.ml index 1eb6212..3c33844 100644 --- a/jscomp/ext/ext_json_types.ml +++ b/compiler/ext/ext_json_types.ml @@ -24,13 +24,13 @@ type loc = Lexing.position -type json_str = { str : string; loc : loc } +type json_str = {str: string; loc: loc} -type json_flo = { flo : string; loc : loc } +type json_flo = {flo: string; loc: loc} -type json_array = { content : t array; loc_start : loc; loc_end : loc } +type json_array = {content: t array; loc_start: loc; loc_end: loc} -and json_map = { map : t Map_string.t; loc : loc } +and json_map = {map: t Map_string.t; loc: loc} and t = | True of loc diff --git a/compiler/ext/ext_list.ml b/compiler/ext/ext_list.ml new file mode 100644 index 0000000..e7681ae --- /dev/null +++ b/compiler/ext/ext_list.ml @@ -0,0 +1,780 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +external ( .!() ) : 'a array -> int -> 'a = "%array_unsafe_get" + +let rec map l f = + match l with + | [] -> [] + | [x1] -> + let y1 = f x1 in + [y1] + | [x1; x2] -> + let y1 = f x1 in + let y2 = f x2 in + [y1; y2] + | [x1; x2; x3] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + [y1; y2; y3] + | [x1; x2; x3; x4] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + [y1; y2; y3; y4] + | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + let y5 = f x5 in + y1 :: y2 :: y3 :: y4 :: y5 :: map tail f + +let rec has_string l f = + match l with + | [] -> false + | [x1] -> x1 = f + | [x1; x2] -> x1 = f || x2 = f + | [x1; x2; x3] -> x1 = f || x2 = f || x3 = f + | x1 :: x2 :: x3 :: x4 -> x1 = f || x2 = f || x3 = f || has_string x4 f + +let rec map_combine l1 l2 f = + match (l1, l2) with + | [], [] -> [] + | a1 :: l1, a2 :: l2 -> (f a1, a2) :: map_combine l1 l2 f + | _, _ -> invalid_arg "Ext_list.map_combine" + +let rec arr_list_combine_unsafe arr l i j acc f = + if i = j then acc + else + match l with + | [] -> invalid_arg "Ext_list.combine" + | h :: tl -> + (f arr.!(i), h) :: arr_list_combine_unsafe arr tl (i + 1) j acc f + +let combine_array_append arr l acc f = + let len = Array.length arr in + arr_list_combine_unsafe arr l 0 len acc f + +let combine_array arr l f = + let len = Array.length arr in + arr_list_combine_unsafe arr l 0 len [] f + +let rec arr_list_filter_map_unasfe arr l i j acc f = + if i = j then acc + else + match l with + | [] -> invalid_arg "Ext_list.arr_list_filter_map_unsafe" + | h :: tl -> ( + match f arr.!(i) h with + | None -> arr_list_filter_map_unasfe arr tl (i + 1) j acc f + | Some v -> v :: arr_list_filter_map_unasfe arr tl (i + 1) j acc f) + +let array_list_filter_map arr l f = + let len = Array.length arr in + arr_list_filter_map_unasfe arr l 0 len [] f + +let rec map_split_opt (xs : 'a list) (f : 'a -> 'b option * 'c option) : + 'b list * 'c list = + match xs with + | [] -> ([], []) + | x :: xs -> ( + let c, d = f x in + let cs, ds = map_split_opt xs f in + ( (match c with + | Some c -> c :: cs + | None -> cs), + match d with + | Some d -> d :: ds + | None -> ds )) + +let rec map_snd l f = + match l with + | [] -> [] + | [(v1, x1)] -> + let y1 = f x1 in + [(v1, y1)] + | [(v1, x1); (v2, x2)] -> + let y1 = f x1 in + let y2 = f x2 in + [(v1, y1); (v2, y2)] + | [(v1, x1); (v2, x2); (v3, x3)] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + [(v1, y1); (v2, y2); (v3, y3)] + | [(v1, x1); (v2, x2); (v3, x3); (v4, x4)] -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + [(v1, y1); (v2, y2); (v3, y3); (v4, y4)] + | (v1, x1) :: (v2, x2) :: (v3, x3) :: (v4, x4) :: (v5, x5) :: tail -> + let y1 = f x1 in + let y2 = f x2 in + let y3 = f x3 in + let y4 = f x4 in + let y5 = f x5 in + (v1, y1) :: (v2, y2) :: (v3, y3) :: (v4, y4) :: (v5, y5) :: map_snd tail f + +let rec map_last l f = + match l with + | [] -> [] + | [x1] -> + let y1 = f true x1 in + [y1] + | [x1; x2] -> + let y1 = f false x1 in + let y2 = f true x2 in + [y1; y2] + | [x1; x2; x3] -> + let y1 = f false x1 in + let y2 = f false x2 in + let y3 = f true x3 in + [y1; y2; y3] + | [x1; x2; x3; x4] -> + let y1 = f false x1 in + let y2 = f false x2 in + let y3 = f false x3 in + let y4 = f true x4 in + [y1; y2; y3; y4] + | x1 :: x2 :: x3 :: x4 :: tail -> + (* make sure that tail is not empty *) + let y1 = f false x1 in + let y2 = f false x2 in + let y3 = f false x3 in + let y4 = f false x4 in + y1 :: y2 :: y3 :: y4 :: map_last tail f + +let rec mapi_aux lst i f tail = + match lst with + | [] -> tail + | a :: l -> + let r = f i a in + r :: mapi_aux l (i + 1) f tail + +let mapi lst f = mapi_aux lst 0 f [] + +let mapi_append lst f tail = mapi_aux lst 0 f tail + +let rec last xs = + match xs with + | [x] -> x + | _ :: tl -> last tl + | [] -> invalid_arg "Ext_list.last" + +let rec append_aux l1 l2 = + match l1 with + | [] -> l2 + | [a0] -> a0 :: l2 + | [a0; a1] -> a0 :: a1 :: l2 + | [a0; a1; a2] -> a0 :: a1 :: a2 :: l2 + | [a0; a1; a2; a3] -> a0 :: a1 :: a2 :: a3 :: l2 + | [a0; a1; a2; a3; a4] -> a0 :: a1 :: a2 :: a3 :: a4 :: l2 + | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> + a0 :: a1 :: a2 :: a3 :: a4 :: append_aux rest l2 + +let append l1 l2 = + match l2 with + | [] -> l1 + | _ -> append_aux l1 l2 + +let append_one l1 x = append_aux l1 [x] + +let rec map_append l1 l2 f = + match l1 with + | [] -> l2 + | [a0] -> f a0 :: l2 + | [a0; a1] -> + let b0 = f a0 in + let b1 = f a1 in + b0 :: b1 :: l2 + | [a0; a1; a2] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + b0 :: b1 :: b2 :: l2 + | [a0; a1; a2; a3] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + b0 :: b1 :: b2 :: b3 :: l2 + | [a0; a1; a2; a3; a4] -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + b0 :: b1 :: b2 :: b3 :: b4 :: l2 + | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> + let b0 = f a0 in + let b1 = f a1 in + let b2 = f a2 in + let b3 = f a3 in + let b4 = f a4 in + b0 :: b1 :: b2 :: b3 :: b4 :: map_append rest l2 f + +let rec fold_right l acc f = + match l with + | [] -> acc + | [a0] -> f a0 acc + | [a0; a1] -> f a0 (f a1 acc) + | [a0; a1; a2] -> f a0 (f a1 (f a2 acc)) + | [a0; a1; a2; a3] -> f a0 (f a1 (f a2 (f a3 acc))) + | [a0; a1; a2; a3; a4] -> f a0 (f a1 (f a2 (f a3 (f a4 acc)))) + | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> + f a0 (f a1 (f a2 (f a3 (f a4 (fold_right rest acc f))))) + +let rec fold_right2 l r acc f = + match (l, r) with + | [], [] -> acc + | [a0], [b0] -> f a0 b0 acc + | [a0; a1], [b0; b1] -> f a0 b0 (f a1 b1 acc) + | [a0; a1; a2], [b0; b1; b2] -> f a0 b0 (f a1 b1 (f a2 b2 acc)) + | [a0; a1; a2; a3], [b0; b1; b2; b3] -> + f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 acc))) + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4] -> + f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 acc)))) + | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> + f a0 b0 + (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 (fold_right2 arest brest acc f))))) + | _, _ -> invalid_arg "Ext_list.fold_right2" + +let rec fold_right3 l r last acc f = + match (l, r, last) with + | [], [], [] -> acc + | [a0], [b0], [c0] -> f a0 b0 c0 acc + | [a0; a1], [b0; b1], [c0; c1] -> f a0 b0 c0 (f a1 b1 c1 acc) + | [a0; a1; a2], [b0; b1; b2], [c0; c1; c2] -> + f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 acc)) + | [a0; a1; a2; a3], [b0; b1; b2; b3], [c0; c1; c2; c3] -> + f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 acc))) + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4], [c0; c1; c2; c3; c4] -> + f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 (f a4 b4 c4 acc)))) + | ( a0 :: a1 :: a2 :: a3 :: a4 :: arest, + b0 :: b1 :: b2 :: b3 :: b4 :: brest, + c0 :: c1 :: c2 :: c3 :: c4 :: crest ) -> + f a0 b0 c0 + (f a1 b1 c1 + (f a2 b2 c2 + (f a3 b3 c3 (f a4 b4 c4 (fold_right3 arest brest crest acc f))))) + | _, _, _ -> invalid_arg "Ext_list.fold_right2" + +let rec map2i l r f = + match (l, r) with + | [], [] -> [] + | [a0], [b0] -> [f 0 a0 b0] + | [a0; a1], [b0; b1] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + [c0; c1] + | [a0; a1; a2], [b0; b1; b2] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + [c0; c1; c2] + | [a0; a1; a2; a3], [b0; b1; b2; b3] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + let c3 = f 3 a3 b3 in + [c0; c1; c2; c3] + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4] -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + let c3 = f 3 a3 b3 in + let c4 = f 4 a4 b4 in + [c0; c1; c2; c3; c4] + | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> + let c0 = f 0 a0 b0 in + let c1 = f 1 a1 b1 in + let c2 = f 2 a2 b2 in + let c3 = f 3 a3 b3 in + let c4 = f 4 a4 b4 in + c0 :: c1 :: c2 :: c3 :: c4 :: map2i arest brest f + | _, _ -> invalid_arg "Ext_list.map2" + +let rec map2 l r f = + match (l, r) with + | [], [] -> [] + | [a0], [b0] -> [f a0 b0] + | [a0; a1], [b0; b1] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + [c0; c1] + | [a0; a1; a2], [b0; b1; b2] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + [c0; c1; c2] + | [a0; a1; a2; a3], [b0; b1; b2; b3] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + let c3 = f a3 b3 in + [c0; c1; c2; c3] + | [a0; a1; a2; a3; a4], [b0; b1; b2; b3; b4] -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + let c3 = f a3 b3 in + let c4 = f a4 b4 in + [c0; c1; c2; c3; c4] + | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> + let c0 = f a0 b0 in + let c1 = f a1 b1 in + let c2 = f a2 b2 in + let c3 = f a3 b3 in + let c4 = f a4 b4 in + c0 :: c1 :: c2 :: c3 :: c4 :: map2 arest brest f + | _, _ -> invalid_arg "Ext_list.map2" + +let rec fold_left_with_offset l accu i f = + match l with + | [] -> accu + | a :: l -> fold_left_with_offset l (f a accu i) (i + 1) f + +let rec filter_map xs (f : 'a -> 'b option) = + match xs with + | [] -> [] + | y :: ys -> ( + match f y with + | None -> filter_map ys f + | Some z -> z :: filter_map ys f) + +let rec exclude (xs : 'a list) (p : 'a -> bool) : 'a list = + match xs with + | [] -> [] + | x :: xs -> if p x then exclude xs p else x :: exclude xs p + +let rec exclude_with_val l p = + match l with + | [] -> None + | a0 :: xs -> ( + if p a0 then Some (exclude xs p) + else + match xs with + | [] -> None + | a1 :: rest -> ( + if p a1 then Some (a0 :: exclude rest p) + else + match exclude_with_val rest p with + | None -> None + | Some rest -> Some (a0 :: a1 :: rest))) + +let rec same_length xs ys = + match (xs, ys) with + | [], [] -> true + | _ :: xs, _ :: ys -> same_length xs ys + | _, _ -> false + +let init n f = + match n with + | 0 -> [] + | 1 -> + let a0 = f 0 in + [a0] + | 2 -> + let a0 = f 0 in + let a1 = f 1 in + [a0; a1] + | 3 -> + let a0 = f 0 in + let a1 = f 1 in + let a2 = f 2 in + [a0; a1; a2] + | 4 -> + let a0 = f 0 in + let a1 = f 1 in + let a2 = f 2 in + let a3 = f 3 in + [a0; a1; a2; a3] + | 5 -> + let a0 = f 0 in + let a1 = f 1 in + let a2 = f 2 in + let a3 = f 3 in + let a4 = f 4 in + [a0; a1; a2; a3; a4] + | _ -> Array.to_list (Array.init n f) + +let rec rev_append l1 l2 = + match l1 with + | [] -> l2 + | [a0] -> a0 :: l2 (* single element is common *) + | [a0; a1] -> a1 :: a0 :: l2 + | a0 :: a1 :: a2 :: rest -> rev_append rest (a2 :: a1 :: a0 :: l2) + +let rev l = rev_append l [] + +let rec small_split_at n acc l = + if n <= 0 then (rev acc, l) + else + match l with + | x :: xs -> small_split_at (n - 1) (x :: acc) xs + | _ -> invalid_arg "Ext_list.split_at" + +let split_at l n = small_split_at n [] l + +let rec split_at_last_aux acc x = + match x with + | [] -> invalid_arg "Ext_list.split_at_last" + | [x] -> (rev acc, x) + | y0 :: ys -> split_at_last_aux (y0 :: acc) ys + +let split_at_last (x : 'a list) = + match x with + | [] -> invalid_arg "Ext_list.split_at_last" + | [a0] -> ([], a0) + | [a0; a1] -> ([a0], a1) + | [a0; a1; a2] -> ([a0; a1], a2) + | [a0; a1; a2; a3] -> ([a0; a1; a2], a3) + | [a0; a1; a2; a3; a4] -> ([a0; a1; a2; a3], a4) + | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> + let rev, last = split_at_last_aux [] rest in + (a0 :: a1 :: a2 :: a3 :: a4 :: rev, last) + +(** + can not do loop unroll due to state combination +*) +let filter_mapi xs f = + let rec aux i xs = + match xs with + | [] -> [] + | y :: ys -> ( + match f y i with + | None -> aux (i + 1) ys + | Some z -> z :: aux (i + 1) ys) + in + aux 0 xs + +let rec filter_map2 xs ys (f : 'a -> 'b -> 'c option) = + match (xs, ys) with + | [], [] -> [] + | u :: us, v :: vs -> ( + match f u v with + | None -> filter_map2 us vs f (* idea: rec f us vs instead? *) + | Some z -> z :: filter_map2 us vs f) + | _ -> invalid_arg "Ext_list.filter_map2" + +let rec rev_map_append l1 l2 f = + match l1 with + | [] -> l2 + | a :: l -> rev_map_append l (f a :: l2) f + +(** It is not worth loop unrolling, + it is already tail-call, and we need to be careful + about evaluation order when unroll +*) +let rec flat_map_aux f acc append lx = + match lx with + | [] -> rev_append acc append + | a0 :: rest -> + let new_acc = + match f a0 with + | [] -> acc + | [a0] -> a0 :: acc + | [a0; a1] -> a1 :: a0 :: acc + | a0 :: a1 :: a2 :: rest -> rev_append rest (a2 :: a1 :: a0 :: acc) + in + flat_map_aux f new_acc append rest + +let flat_map lx f = flat_map_aux f [] [] lx + +let flat_map_append lx append f = flat_map_aux f [] append lx + +let rec length_compare l n = + if n < 0 then `Gt + else + match l with + | _ :: xs -> length_compare xs (n - 1) + | [] -> if n = 0 then `Eq else `Lt + +let rec length_ge l n = + if n > 0 then + match l with + | _ :: tl -> length_ge tl (n - 1) + | [] -> false + else true + +(** + {[length xs = length ys + n ]} +*) +let rec length_larger_than_n xs ys n = + match (xs, ys) with + | _, [] -> length_compare xs n = `Eq + | _ :: xs, _ :: ys -> length_larger_than_n xs ys n + | [], _ -> false + +let rec group (eq : 'a -> 'a -> bool) lst = + match lst with + | [] -> [] + | x :: xs -> aux eq x (group eq xs) + +and aux eq (x : 'a) (xss : 'a list list) : 'a list list = + match xss with + | [] -> [[x]] + | (y0 :: _ as y) :: ys -> + (* cannot be empty *) + if eq x y0 then (x :: y) :: ys else y :: aux eq x ys + | _ :: _ -> assert false + +let stable_group lst eq = group eq lst |> rev + +let rec drop h n = + if n < 0 then invalid_arg "Ext_list.drop" + else if n = 0 then h + else + match h with + | [] -> invalid_arg "Ext_list.drop" + | _ :: tl -> drop tl (n - 1) + +let rec find_first x p = + match x with + | [] -> None + | x :: l -> if p x then Some x else find_first l p + +let rec find_first_not xs p = + match xs with + | [] -> None + | a :: l -> if p a then find_first_not l p else Some a + +let rec rev_iter l f = + match l with + | [] -> () + | [x1] -> f x1 + | [x1; x2] -> + f x2; + f x1 + | [x1; x2; x3] -> + f x3; + f x2; + f x1 + | [x1; x2; x3; x4] -> + f x4; + f x3; + f x2; + f x1 + | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> + rev_iter tail f; + f x5; + f x4; + f x3; + f x2; + f x1 + +let rec iter l f = + match l with + | [] -> () + | [x1] -> f x1 + | [x1; x2] -> + f x1; + f x2 + | [x1; x2; x3] -> + f x1; + f x2; + f x3 + | [x1; x2; x3; x4] -> + f x1; + f x2; + f x3; + f x4 + | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> + f x1; + f x2; + f x3; + f x4; + f x5; + iter tail f + +let rec for_all lst p = + match lst with + | [] -> true + | a :: l -> p a && for_all l p + +let rec for_all_snd lst p = + match lst with + | [] -> true + | (_, a) :: l -> p a && for_all_snd l p + +let rec for_all2_no_exn l1 l2 p = + match (l1, l2) with + | [], [] -> true + | a1 :: l1, a2 :: l2 -> p a1 a2 && for_all2_no_exn l1 l2 p + | _, _ -> false + +let rec find_opt xs p = + match xs with + | [] -> None + | x :: l -> ( + match p x with + | Some _ as v -> v + | None -> find_opt l p) + +let rec find_def xs p def = + match xs with + | [] -> def + | x :: l -> ( + match p x with + | Some v -> v + | None -> find_def l p def) + +let rec split_map l f = + match l with + | [] -> ([], []) + | [x1] -> + let a0, b0 = f x1 in + ([a0], [b0]) + | [x1; x2] -> + let a1, b1 = f x1 in + let a2, b2 = f x2 in + ([a1; a2], [b1; b2]) + | [x1; x2; x3] -> + let a1, b1 = f x1 in + let a2, b2 = f x2 in + let a3, b3 = f x3 in + ([a1; a2; a3], [b1; b2; b3]) + | [x1; x2; x3; x4] -> + let a1, b1 = f x1 in + let a2, b2 = f x2 in + let a3, b3 = f x3 in + let a4, b4 = f x4 in + ([a1; a2; a3; a4], [b1; b2; b3; b4]) + | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> + let a1, b1 = f x1 in + let a2, b2 = f x2 in + let a3, b3 = f x3 in + let a4, b4 = f x4 in + let a5, b5 = f x5 in + let ass, bss = split_map tail f in + (a1 :: a2 :: a3 :: a4 :: a5 :: ass, b1 :: b2 :: b3 :: b4 :: b5 :: bss) + +let sort_via_array lst cmp = + let arr = Array.of_list lst in + Array.sort cmp arr; + Array.to_list arr + +let sort_via_arrayf lst cmp f = + let arr = Array.of_list lst in + Array.sort cmp arr; + Ext_array.to_list_f arr f + +let rec assoc_by_string lst (k : string) def = + match lst with + | [] -> ( + match def with + | None -> assert false + | Some x -> x) + | (k1, v1) :: rest -> if k1 = k then v1 else assoc_by_string rest k def + +let rec assoc_by_int lst (k : int) def = + match lst with + | [] -> ( + match def with + | None -> assert false + | Some x -> x) + | (k1, v1) :: rest -> if k1 = k then v1 else assoc_by_int rest k def + +let rec nth_aux l n = + match l with + | [] -> None + | a :: l -> if n = 0 then Some a else nth_aux l (n - 1) + +let nth_opt l n = if n < 0 then None else nth_aux l n + +let rec iter_snd lst f = + match lst with + | [] -> () + | (_, x) :: xs -> + f x; + iter_snd xs f + +let rec iter_fst lst f = + match lst with + | [] -> () + | (x, _) :: xs -> + f x; + iter_fst xs f + +let rec exists l p = + match l with + | [] -> false + | x :: xs -> p x || exists xs p + +let rec exists_fst l p = + match l with + | [] -> false + | (a, _) :: l -> p a || exists_fst l p + +let rec exists_snd l p = + match l with + | [] -> false + | (_, a) :: l -> p a || exists_snd l p + +let rec concat_append (xss : 'a list list) (xs : 'a list) : 'a list = + match xss with + | [] -> xs + | l :: r -> append l (concat_append r xs) + +let rec fold_left l accu f = + match l with + | [] -> accu + | a :: l -> fold_left l (f accu a) f + +let reduce_from_left lst fn = + match lst with + | first :: rest -> fold_left rest first fn + | _ -> invalid_arg "Ext_list.reduce_from_left" + +let rec fold_left2 l1 l2 accu f = + match (l1, l2) with + | [], [] -> accu + | a1 :: l1, a2 :: l2 -> fold_left2 l1 l2 (f a1 a2 accu) f + | _, _ -> invalid_arg "Ext_list.fold_left2" + +let singleton_exn xs = + match xs with + | [x] -> x + | _ -> assert false + +let rec mem_string (xs : string list) (x : string) = + match xs with + | [] -> false + | a :: l -> a = x || mem_string l x + +let filter lst p = + let rec find ~p accu lst = + match lst with + | [] -> rev accu + | x :: l -> if p x then find (x :: accu) l ~p else find accu l ~p + in + find [] lst ~p + +let is_empty = function + | [] -> true + | _ :: _ -> false diff --git a/jscomp/ext/ext_list.mli b/compiler/ext/ext_list.mli similarity index 98% rename from jscomp/ext/ext_list.mli rename to compiler/ext/ext_list.mli index 95a078b..c5e6514 100644 --- a/jscomp/ext/ext_list.mli +++ b/compiler/ext/ext_list.mli @@ -108,7 +108,7 @@ val filter_mapi : 'a list -> ('a -> int -> 'b option) -> 'b list val filter_map2 : 'a list -> 'b list -> ('a -> 'b -> 'c option) -> 'c list -val length_compare : 'a list -> int -> [ `Gt | `Eq | `Lt ] +val length_compare : 'a list -> int -> [`Gt | `Eq | `Lt] val length_ge : 'a list -> int -> bool @@ -231,3 +231,5 @@ val filter : 'a list -> ('a -> bool) -> 'a list val array_list_filter_map : 'a array -> 'b list -> ('a -> 'b -> 'c option) -> 'c list + +val is_empty : 'a list -> bool diff --git a/jscomp/ext/ext_marshal.ml b/compiler/ext/ext_marshal.ml similarity index 100% rename from jscomp/ext/ext_marshal.ml rename to compiler/ext/ext_marshal.ml diff --git a/jscomp/ext/ext_marshal.mli b/compiler/ext/ext_marshal.mli similarity index 100% rename from jscomp/ext/ext_marshal.mli rename to compiler/ext/ext_marshal.mli diff --git a/compiler/ext/ext_module_system.ml b/compiler/ext/ext_module_system.ml new file mode 100644 index 0000000..c8a0734 --- /dev/null +++ b/compiler/ext/ext_module_system.ml @@ -0,0 +1 @@ +type t = Commonjs | Esmodule | Es6_global diff --git a/jscomp/ext/ext_modulename.ml b/compiler/ext/ext_modulename.ml similarity index 91% rename from jscomp/ext/ext_modulename.ml rename to compiler/ext/ext_modulename.ml index ddc0292..d2d4693 100644 --- a/jscomp/ext/ext_modulename.ml +++ b/compiler/ext/ext_modulename.ml @@ -25,7 +25,9 @@ let good_hint_name module_name offset = let len = String.length module_name in len > offset - && (function 'a' .. 'z' | 'A' .. 'Z' -> true | _ -> false) + && (function + | 'a' .. 'z' | 'A' .. 'Z' -> true + | _ -> false) (String.unsafe_get module_name offset) && Ext_string.for_all_from module_name (offset + 1) (function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true @@ -37,11 +39,11 @@ let rec collect_start buf s off len = let next = succ off in match String.unsafe_get s off with | 'a' .. 'z' as c -> - Ext_buffer.add_char buf (Char.uppercase_ascii c); - collect_next buf s next len + Ext_buffer.add_char buf (Char.uppercase_ascii c); + collect_next buf s next len | 'A' .. 'Z' as c -> - Ext_buffer.add_char buf c; - collect_next buf s next len + Ext_buffer.add_char buf c; + collect_next buf s next len | _ -> collect_start buf s next len and collect_next buf s off len = @@ -50,8 +52,8 @@ and collect_next buf s off len = let next = off + 1 in match String.unsafe_get s off with | ('a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_') as c -> - Ext_buffer.add_char buf c; - collect_next buf s next len + Ext_buffer.add_char buf c; + collect_next buf s next len | '.' | '-' -> collect_start buf s next len | _ -> collect_next buf s next len diff --git a/jscomp/ext/ext_modulename.mli b/compiler/ext/ext_modulename.mli similarity index 100% rename from jscomp/ext/ext_modulename.mli rename to compiler/ext/ext_modulename.mli diff --git a/jscomp/ext/ext_namespace.ml b/compiler/ext/ext_namespace.ml similarity index 91% rename from jscomp/ext/ext_namespace.ml rename to compiler/ext/ext_namespace.ml index deccf1f..faad692 100644 --- a/jscomp/ext/ext_namespace.ml +++ b/compiler/ext/ext_namespace.ml @@ -43,7 +43,9 @@ let try_split_module_name name = let js_name_of_modulename s (case : Ext_js_file_kind.case) suffix : string = let s = - match case with Little -> Ext_string.uncapitalize_ascii s | Upper -> s + match case with + | Little -> Ext_string.uncapitalize_ascii s + | Upper -> s in change_ext_ns_suffix s suffix @@ -61,10 +63,10 @@ let is_valid_npm_package_name (s : string) = && match String.unsafe_get s 0 with | 'a' .. 'z' | '@' -> - Ext_string.for_all_from s 1 (fun x -> - match x with - | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true - | _ -> false) + Ext_string.for_all_from s 1 (fun x -> + match x with + | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true + | _ -> false) | _ -> false let namespace_of_package_name (s : string) : string = @@ -79,8 +81,8 @@ let namespace_of_package_name (s : string) : string = let ch = String.unsafe_get s off in match ch with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> - add capital ch; - aux false (off + 1) len + add capital ch; + aux false (off + 1) len | '/' | '-' -> aux true (off + 1) len | _ -> aux capital (off + 1) len in diff --git a/jscomp/ext/ext_namespace.mli b/compiler/ext/ext_namespace.mli similarity index 96% rename from jscomp/ext/ext_namespace.mli rename to compiler/ext/ext_namespace.mli index f562729..fa64016 100644 --- a/jscomp/ext/ext_namespace.mli +++ b/compiler/ext/ext_namespace.mli @@ -33,8 +33,7 @@ val try_split_module_name : string -> (string * string) option *) val change_ext_ns_suffix : string -> string -> string -val js_name_of_modulename : - string -> Ext_js_file_kind.case -> string -> string +val js_name_of_modulename : string -> Ext_js_file_kind.case -> string -> string (** [js_name_of_modulename ~little A-Ns] *) diff --git a/jscomp/ext/ext_namespace_encode.ml b/compiler/ext/ext_namespace_encode.ml similarity index 94% rename from jscomp/ext/ext_namespace_encode.ml rename to compiler/ext/ext_namespace_encode.ml index 071a92c..87ad276 100644 --- a/jscomp/ext/ext_namespace_encode.ml +++ b/compiler/ext/ext_namespace_encode.ml @@ -23,4 +23,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let make ?ns cunit = - match ns with None -> cunit | Some ns -> cunit ^ Literals.ns_sep ^ ns + match ns with + | None -> cunit + | Some ns -> cunit ^ Literals.ns_sep ^ ns diff --git a/jscomp/ext/ext_namespace_encode.mli b/compiler/ext/ext_namespace_encode.mli similarity index 100% rename from jscomp/ext/ext_namespace_encode.mli rename to compiler/ext/ext_namespace_encode.mli diff --git a/compiler/ext/ext_obj.ml b/compiler/ext/ext_obj.ml new file mode 100644 index 0000000..c81e86f --- /dev/null +++ b/compiler/ext/ext_obj.ml @@ -0,0 +1,126 @@ +(* Copyright (C) 2019-Present Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let rec dump r = + if Obj.is_int r then string_of_int (Obj.magic r : int) + else + (* Block. *) + let rec get_fields acc = function + | 0 -> acc + | n -> + let n = n - 1 in + get_fields (Obj.field r n :: acc) n + in + let rec is_list r = + if Obj.is_int r then r = Obj.repr 0 (* [] *) + else + let s = Obj.size r and t = Obj.tag r in + t = 0 && s = 2 && is_list (Obj.field r 1) + (* h :: t *) + in + let rec get_list r = + if Obj.is_int r then [] + else + let h = Obj.field r 0 and t = get_list (Obj.field r 1) in + h :: t + in + let opaque name = + (* XXX In future, print the address of value 'r'. Not possible + * in pure OCaml at the moment. *) + "<" ^ name ^ ">" + in + let s = Obj.size r and t = Obj.tag r in + (* From the tag, determine the type of block. *) + match t with + | _ when is_list r -> + let fields = get_list r in + "[" ^ String.concat "; " (Ext_list.map fields dump) ^ "]" + | 0 -> + let fields = get_fields [] s in + "(" ^ String.concat ", " (Ext_list.map fields dump) ^ ")" + | x when x = Obj.lazy_tag -> + (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not + * clear if very large constructed values could have the same + * tag. XXX *) + opaque "lazy" + | x when x = Obj.closure_tag -> opaque "closure" + | x when x = Obj.object_tag -> + let fields = get_fields [] s in + let _clasz, id, slots = + match fields with + | h :: h' :: t -> (h, h', t) + | _ -> assert false + in + (* No information on decoding the class (first field). So just print + * out the ID and the slots. *) + "Object #" ^ dump id ^ " (" + ^ String.concat ", " (Ext_list.map slots dump) + ^ ")" + | x when x = Obj.infix_tag -> opaque "infix" + | x when x = Obj.forward_tag -> opaque "forward" + | x when x < Obj.no_scan_tag -> + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ " (" + ^ String.concat ", " (Ext_list.map fields dump) + ^ ")" + | x when x = Obj.string_tag -> + "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" + | x when x = Obj.double_tag -> string_of_float (Obj.magic r : float) + | x when x = Obj.abstract_tag -> opaque "abstract" + | x when x = Obj.custom_tag -> opaque "custom" + | x when x = Obj.custom_tag -> opaque "final" + | x when x = Obj.double_array_tag -> + "[|" + ^ String.concat ";" + (Array.to_list + (Array.map string_of_float (Obj.magic r : float array))) + ^ "|]" + | _ -> opaque (Printf.sprintf "unknown: tag %d size %d" t s) + +let dump v = dump (Obj.repr v) + +let dump_endline ?(__LOC__ = "") v = + print_endline __LOC__; + print_endline (dump v) + +let pp_any fmt v = Format.fprintf fmt "@[%s@]" (dump v) + +let bt () = + let raw_bt = Printexc.backtrace_slots (Printexc.get_raw_backtrace ()) in + match raw_bt with + | None -> () + | Some raw_bt -> + let acc = ref [] in + for i = Array.length raw_bt - 1 downto 0 do + let slot = raw_bt.(i) in + match Printexc.Slot.location slot with + | None -> () + | Some bt -> ( + match !acc with + | [] -> acc := [bt] + | hd :: _ -> if hd <> bt then acc := bt :: !acc) + done; + Ext_list.iter !acc (fun bt -> + Printf.eprintf "File \"%s\", line %d, characters %d-%d\n" bt.filename + bt.line_number bt.start_char bt.end_char) diff --git a/jscomp/ext/ext_obj.mli b/compiler/ext/ext_obj.mli similarity index 100% rename from jscomp/ext/ext_obj.mli rename to compiler/ext/ext_obj.mli diff --git a/jscomp/ext/ext_option.ml b/compiler/ext/ext_option.ml similarity index 86% rename from jscomp/ext/ext_option.ml rename to compiler/ext/ext_option.ml index 0e4f128..92a2439 100644 --- a/jscomp/ext/ext_option.ml +++ b/compiler/ext/ext_option.ml @@ -22,8 +22,17 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let map v f = match v with None -> None | Some x -> Some (f x) +let map v f = + match v with + | None -> None + | Some x -> Some (f x) -let iter v f = match v with None -> () | Some x -> f x +let iter v f = + match v with + | None -> () + | Some x -> f x -let exists v f = match v with None -> false | Some x -> f x +let exists v f = + match v with + | None -> false + | Some x -> f x diff --git a/jscomp/ext/ext_option.mli b/compiler/ext/ext_option.mli similarity index 100% rename from jscomp/ext/ext_option.mli rename to compiler/ext/ext_option.mli diff --git a/jscomp/ext/ext_path.ml b/compiler/ext/ext_path.ml similarity index 77% rename from jscomp/ext/ext_path.ml rename to compiler/ext/ext_path.ml index 31bbe47..727ea43 100644 --- a/jscomp/ext/ext_path.ml +++ b/compiler/ext/ext_path.ml @@ -23,8 +23,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) (* [@@@warning "-37"] *) -type t = (* | File of string *) - | Dir of string [@@unboxed] +type t = + (* | File of string *) + | Dir of string +[@@unboxed] let simple_convert_node_path_to_os_path = if Sys.unix then fun x -> x @@ -37,37 +39,22 @@ let split_by_sep_per_os : string -> string list = if Ext_sys.is_windows_or_cygwin then fun x -> (* on Windows, we can still accept -bs-package-output lib/js *) Ext_string.split_by - (fun x -> match x with '/' | '\\' -> true | _ -> false) + (fun x -> + match x with + | '/' | '\\' -> true + | _ -> false) x else fun x -> Ext_string.split x '/' -(** example - {[ - "/bb/mbigc/mbig2899/bgit/rescript/jscomp/stdlib/external/pervasives.cmj" - "/bb/mbigc/mbig2899/bgit/rescript/jscomp/stdlib/ocaml_array.ml" - ]} - - The other way - {[ - - "/bb/mbigc/mbig2899/bgit/rescript/jscomp/stdlib/ocaml_array.ml" - "/bb/mbigc/mbig2899/bgit/rescript/jscomp/stdlib/external/pervasives.cmj" - ]} - {[ - "/bb/mbigc/mbig2899/bgit/rescript/jscomp/stdlib//ocaml_array.ml" - ]} - {[ - /a/b - /c/d - ]} -*) let node_relative_path ~from:(file_or_dir_2 : t) (file_or_dir_1 : t) = let relevant_dir1 = - match file_or_dir_1 with Dir x -> x + match file_or_dir_1 with + | Dir x -> x (* | File file1 -> Filename.dirname file1 *) in let relevant_dir2 = - match file_or_dir_2 with Dir x -> x + match file_or_dir_2 with + | Dir x -> x (* | File file2 -> Filename.dirname file2 *) in let dir1 = split_by_sep_per_os relevant_dir1 in @@ -81,7 +68,7 @@ let node_relative_path ~from:(file_or_dir_2 : t) (file_or_dir_1 : t) = in match go dir1 dir2 with | x :: _ as ys when x = Literals.node_parent -> - String.concat Literals.node_sep ys + String.concat Literals.node_sep ys | ys -> String.concat Literals.node_sep @@ (Literals.node_current :: ys) let node_concat ~dir base = dir ^ Literals.node_sep ^ base @@ -90,7 +77,7 @@ let node_rebase_file ~from ~to_ file = node_concat ~dir: (if from = to_ then Literals.node_current - else node_relative_path ~from:(Dir from) (Dir to_)) + else node_relative_path ~from:(Dir from) (Dir to_)) file (*** @@ -164,20 +151,20 @@ let rel_normalized_absolute_path ~from to_ = let rec go xss yss = match (xss, yss) with | x :: xs, y :: ys -> - if Ext_string.equal x y then go xs ys - else if x = Filename.current_dir_name then go xs yss - else if y = Filename.current_dir_name then go xss ys - else - let start = - Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> - acc // Ext_string.parent_dir_lit) - in - Ext_list.fold_left yss start (fun acc v -> acc // v) + if Ext_string.equal x y then go xs ys + else if x = Filename.current_dir_name then go xs yss + else if y = Filename.current_dir_name then go xss ys + else + let start = + Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> + acc // Ext_string.parent_dir_lit) + in + Ext_list.fold_left yss start (fun acc v -> acc // v) | [], [] -> Ext_string.empty | [], y :: ys -> Ext_list.fold_left ys y (fun acc x -> acc // x) | _ :: xs, [] -> - Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> - acc // Ext_string.parent_dir_lit) + Ext_list.fold_left xs Ext_string.parent_dir_lit (fun acc _ -> + acc // Ext_string.parent_dir_lit) in let v = go paths1 paths2 in @@ -211,16 +198,20 @@ let rel_normalized_absolute_path ~from to_ = (** See tests in {!Ounit_path_tests} *) let normalize_absolute_path x = - let drop_if_exist xs = match xs with [] -> [] | _ :: xs -> xs in + let drop_if_exist xs = + match xs with + | [] -> [] + | _ :: xs -> xs + in let rec normalize_list acc paths = match paths with | [] -> acc | x :: xs -> - if Ext_string.equal x Ext_string.current_dir_lit then - normalize_list acc xs - else if Ext_string.equal x Ext_string.parent_dir_lit then - normalize_list (drop_if_exist acc) xs - else normalize_list (x :: acc) xs + if Ext_string.equal x Ext_string.current_dir_lit then + normalize_list acc xs + else if Ext_string.equal x Ext_string.parent_dir_lit then + normalize_list (drop_if_exist acc) xs + else normalize_list (x :: acc) xs in let root, paths = split_aux x in let rev_paths = normalize_list [] paths in @@ -229,7 +220,9 @@ let normalize_absolute_path x = | [] -> Filename.concat root acc | last :: rest -> go (Filename.concat last acc) rest in - match rev_paths with [] -> root | last :: rest -> go last rest + match rev_paths with + | [] -> root + | last :: rest -> go last rest let absolute_path cwd s = let process s = @@ -262,16 +255,20 @@ let check_suffix_case = Ext_string.ends_with (* Input must be absolute directory *) let rec find_root_filename ~cwd filenames = - let file_exists = Ext_list.exists filenames (fun filename -> - Sys.file_exists (Filename.concat cwd filename)) + let file_exists = + Ext_list.exists filenames (fun filename -> + Sys.file_exists (Filename.concat cwd filename)) in if file_exists then cwd else let cwd' = Filename.dirname cwd in if String.length cwd' < String.length cwd then find_root_filename ~cwd:cwd' filenames - else Ext_fmt.failwithf ~loc:__LOC__ "%s not found from %s" (List.hd filenames) cwd + else + Ext_fmt.failwithf ~loc:__LOC__ "%s not found from %s" (List.hd filenames) + cwd -let find_config_dir cwd = find_root_filename ~cwd [Literals.rescript_json; Literals.bsconfig_json] +let find_config_dir cwd = + find_root_filename ~cwd [Literals.rescript_json; Literals.bsconfig_json] let package_dir = lazy (find_config_dir (Lazy.force cwd)) diff --git a/jscomp/ext/ext_path.mli b/compiler/ext/ext_path.mli similarity index 100% rename from jscomp/ext/ext_path.mli rename to compiler/ext/ext_path.mli diff --git a/jscomp/ext/ext_pervasives.ml b/compiler/ext/ext_pervasives.ml similarity index 96% rename from jscomp/ext/ext_pervasives.ml rename to compiler/ext/ext_pervasives.ml index ede7f8a..cdc44d8 100644 --- a/jscomp/ext/ext_pervasives.ml +++ b/compiler/ext/ext_pervasives.ml @@ -22,16 +22,16 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -external reraise : exn -> 'a = "%reraise" +external reraise : exn -> 'a = "%raise" let finally v ~clean:action f = match f v with | exception e -> - action v; - reraise e + action v; + reraise e | e -> - action v; - e + action v; + e (* let try_it f = try ignore (f ()) with _ -> () *) diff --git a/jscomp/ext/ext_pervasives.mli b/compiler/ext/ext_pervasives.mli similarity index 97% rename from jscomp/ext/ext_pervasives.mli rename to compiler/ext/ext_pervasives.mli index a476190..970898d 100644 --- a/jscomp/ext/ext_pervasives.mli +++ b/compiler/ext/ext_pervasives.mli @@ -25,7 +25,7 @@ (** Extension to standard library [Pervavives] module, safe to open *) -external reraise : exn -> 'a = "%reraise" +external reraise : exn -> 'a = "%raise" val finally : 'a -> clean:('a -> unit) -> ('a -> 'b) -> 'b diff --git a/jscomp/ext/ext_position.ml b/compiler/ext/ext_position.ml similarity index 96% rename from jscomp/ext/ext_position.ml rename to compiler/ext/ext_position.ml index 96e575b..a154094 100644 --- a/jscomp/ext/ext_position.ml +++ b/compiler/ext/ext_position.ml @@ -23,10 +23,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = Lexing.position = { - pos_fname : string; - pos_lnum : int; - pos_bol : int; - pos_cnum : int; + pos_fname: string; + pos_lnum: int; + pos_bol: int; + pos_cnum: int; } let offset (x : t) (y : t) = diff --git a/jscomp/ext/ext_position.mli b/compiler/ext/ext_position.mli similarity index 95% rename from jscomp/ext/ext_position.mli rename to compiler/ext/ext_position.mli index 0d17a2c..7d0a056 100644 --- a/jscomp/ext/ext_position.mli +++ b/compiler/ext/ext_position.mli @@ -23,10 +23,10 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) type t = Lexing.position = { - pos_fname : string; - pos_lnum : int; - pos_bol : int; - pos_cnum : int; + pos_fname: string; + pos_lnum: int; + pos_bol: int; + pos_cnum: int; } val offset : t -> t -> t diff --git a/jscomp/ext/ext_pp.ml b/compiler/ext/ext_pp.ml similarity index 94% rename from jscomp/ext/ext_pp.ml rename to compiler/ext/ext_pp.ml index 7ac0502..f9237c2 100644 --- a/jscomp/ext/ext_pp.ml +++ b/compiler/ext/ext_pp.ml @@ -31,11 +31,11 @@ end let indent_length = String.length L.indent_str type t = { - output_string : string -> unit; - output_char : char -> unit; - flush : unit -> unit; - mutable indent_level : int; - mutable last_new_line : bool; + output_string: string -> unit; + output_char: char -> unit; + flush: unit -> unit; + mutable indent_level: int; + mutable last_new_line: bool; (* only when we print newline, we print the indent *) } @@ -160,8 +160,8 @@ let paren_vgroup st n action = let paren_group st n action = group st n (fun _ -> paren st action) -let cond_paren_group st b n action = - if b then paren_group st n action else action () +let cond_paren_group st b action = + if b then paren_group st 0 action else action () let brace_group st n action = group st n (fun _ -> brace st action) diff --git a/jscomp/ext/ext_pp.mli b/compiler/ext/ext_pp.mli similarity index 97% rename from jscomp/ext/ext_pp.mli rename to compiler/ext/ext_pp.mli index 6db5327..aaf2176 100644 --- a/jscomp/ext/ext_pp.mli +++ b/compiler/ext/ext_pp.mli @@ -56,7 +56,7 @@ val brace : t -> (unit -> 'a) -> 'a val paren_group : t -> int -> (unit -> 'a) -> 'a -val cond_paren_group : t -> bool -> int -> (unit -> 'a) -> 'a +val cond_paren_group : t -> bool -> (unit -> 'a) -> 'a val paren_vgroup : t -> int -> (unit -> 'a) -> 'a diff --git a/jscomp/ext/ext_pp_scope.ml b/compiler/ext/ext_pp_scope.ml similarity index 92% rename from jscomp/ext/ext_pp_scope.ml rename to compiler/ext/ext_pp_scope.ml index 66df85d..f074a41 100644 --- a/jscomp/ext/ext_pp_scope.ml +++ b/compiler/ext/ext_pp_scope.ml @@ -42,11 +42,11 @@ let add_ident ~mangled:name (stamp : int) (cxt : t) : int * t = match Map_string.find_opt cxt name with | None -> (0, Map_string.add cxt name (Map_int.add Map_int.empty stamp 0)) | Some imap -> ( - match Map_int.find_opt imap stamp with - | None -> - let v = Map_int.cardinal imap in - (v, Map_string.add cxt name (Map_int.add imap stamp v)) - | Some i -> (i, cxt)) + match Map_int.find_opt imap stamp with + | None -> + let v = Map_int.cardinal imap in + (v, Map_string.add cxt name (Map_int.add imap stamp v)) + | Some i -> (i, cxt)) (** same as {!Js_dump.ident} except it generates a string instead of doing the printing @@ -104,10 +104,10 @@ let merge (cxt : t) (set : Set_ident.t) = update twice, once is enough *) let sub_scope (scope : t) (idents : Set_ident.t) : t = - Set_ident.fold idents empty (fun { name } acc -> + Set_ident.fold idents empty (fun {name} acc -> let mangled = Ext_ident.convert name in match Map_string.find_exn scope mangled with | exception Not_found -> assert false | imap -> - if Map_string.mem acc mangled then acc - else Map_string.add acc mangled imap) + if Map_string.mem acc mangled then acc + else Map_string.add acc mangled imap) diff --git a/jscomp/ext/ext_pp_scope.mli b/compiler/ext/ext_pp_scope.mli similarity index 100% rename from jscomp/ext/ext_pp_scope.mli rename to compiler/ext/ext_pp_scope.mli diff --git a/jscomp/ext/ext_ref.ml b/compiler/ext/ext_ref.ml similarity index 100% rename from jscomp/ext/ext_ref.ml rename to compiler/ext/ext_ref.ml diff --git a/jscomp/ext/ext_ref.mli b/compiler/ext/ext_ref.mli similarity index 100% rename from jscomp/ext/ext_ref.mli rename to compiler/ext/ext_ref.mli diff --git a/jscomp/ext/ext_scc.ml b/compiler/ext/ext_scc.ml similarity index 100% rename from jscomp/ext/ext_scc.ml rename to compiler/ext/ext_scc.ml diff --git a/jscomp/ext/ext_scc.mli b/compiler/ext/ext_scc.mli similarity index 100% rename from jscomp/ext/ext_scc.mli rename to compiler/ext/ext_scc.mli diff --git a/jscomp/ext/ext_spec.ml b/compiler/ext/ext_spec.ml similarity index 100% rename from jscomp/ext/ext_spec.ml rename to compiler/ext/ext_spec.ml diff --git a/jscomp/ext/ext_spec.mli b/compiler/ext/ext_spec.mli similarity index 100% rename from jscomp/ext/ext_spec.mli rename to compiler/ext/ext_spec.mli diff --git a/jscomp/ext/ext_string.ml b/compiler/ext/ext_string.ml similarity index 100% rename from jscomp/ext/ext_string.ml rename to compiler/ext/ext_string.ml diff --git a/jscomp/ext/ext_string.mli b/compiler/ext/ext_string.mli similarity index 100% rename from jscomp/ext/ext_string.mli rename to compiler/ext/ext_string.mli diff --git a/compiler/ext/ext_string_array.ml b/compiler/ext/ext_string_array.ml new file mode 100644 index 0000000..0e3fb42 --- /dev/null +++ b/compiler/ext/ext_string_array.ml @@ -0,0 +1,91 @@ +(* Copyright (C) 2020 - Present Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(* Invariant: the same as encoding Map_string.compare_key *) +let cmp = Ext_string.compare + +let rec binary_search_aux (arr : string array) (lo : int) (hi : int) + (key : string) : _ option = + let mid = (lo + hi) / 2 in + let mid_val = Array.unsafe_get arr mid in + let c = cmp key mid_val in + if c = 0 then Some mid + else if c < 0 then + (* a[lo] =< key < a[mid] <= a[hi] *) + if hi = mid then + let lo_val = Array.unsafe_get arr lo in + if lo_val = key then Some lo else None + else binary_search_aux arr lo mid key + else if + (* a[lo] =< a[mid] < key <= a[hi] *) + lo = mid + then + let hi_val = Array.unsafe_get arr hi in + if hi_val = key then Some hi else None + else binary_search_aux arr mid hi key + +let find_sorted sorted key : int option = + let len = Array.length sorted in + if len = 0 then None + else + let lo = Array.unsafe_get sorted 0 in + let c = cmp key lo in + if c < 0 then None + else + let hi = Array.unsafe_get sorted (len - 1) in + let c2 = cmp key hi in + if c2 > 0 then None else binary_search_aux sorted 0 (len - 1) key + +let rec binary_search_assoc (arr : (string * _) array) (lo : int) (hi : int) + (key : string) : _ option = + let mid = (lo + hi) / 2 in + let mid_val = Array.unsafe_get arr mid in + let c = cmp key (fst mid_val) in + if c = 0 then Some (snd mid_val) + else if c < 0 then + (* a[lo] =< key < a[mid] <= a[hi] *) + if hi = mid then + let lo_val = Array.unsafe_get arr lo in + if fst lo_val = key then Some (snd lo_val) else None + else binary_search_assoc arr lo mid key + else if + (* a[lo] =< a[mid] < key <= a[hi] *) + lo = mid + then + let hi_val = Array.unsafe_get arr hi in + if fst hi_val = key then Some (snd hi_val) else None + else binary_search_assoc arr mid hi key + +let find_sorted_assoc (type a) (sorted : (string * a) array) (key : string) : + a option = + let len = Array.length sorted in + if len = 0 then None + else + let lo = Array.unsafe_get sorted 0 in + let c = cmp key (fst lo) in + if c < 0 then None + else + let hi = Array.unsafe_get sorted (len - 1) in + let c2 = cmp key (fst hi) in + if c2 > 0 then None else binary_search_assoc sorted 0 (len - 1) key diff --git a/jscomp/ext/ext_string_array.mli b/compiler/ext/ext_string_array.mli similarity index 100% rename from jscomp/ext/ext_string_array.mli rename to compiler/ext/ext_string_array.mli diff --git a/jscomp/ext/ext_sys.ml b/compiler/ext/ext_sys.ml similarity index 100% rename from jscomp/ext/ext_sys.ml rename to compiler/ext/ext_sys.ml diff --git a/jscomp/ext/ext_sys.mli b/compiler/ext/ext_sys.mli similarity index 100% rename from jscomp/ext/ext_sys.mli rename to compiler/ext/ext_sys.mli diff --git a/jscomp/ext/ext_utf8.ml b/compiler/ext/ext_utf8.ml similarity index 84% rename from jscomp/ext/ext_utf8.ml rename to compiler/ext/ext_utf8.ml index 0d02b2c..04846c1 100644 --- a/jscomp/ext/ext_utf8.ml +++ b/compiler/ext/ext_utf8.ml @@ -29,19 +29,30 @@ let classify chr = let c = int_of_char chr in (* Classify byte according to leftmost 0 bit *) if c land 0b1000_0000 = 0 then Single c - else if (* c 0b0____*) - c land 0b0100_0000 = 0 then Cont (c land 0b0011_1111) - else if (* c 0b10___*) - c land 0b0010_0000 = 0 then Leading (1, c land 0b0001_1111) - else if (* c 0b110__*) - c land 0b0001_0000 = 0 then Leading (2, c land 0b0000_1111) - else if (* c 0b1110_ *) - c land 0b0000_1000 = 0 then Leading (3, c land 0b0000_0111) - else if (* c 0b1111_0___*) - c land 0b0000_0100 = 0 then Leading (4, c land 0b0000_0011) - else if (* c 0b1111_10__*) - c land 0b0000_0010 = 0 then Leading (5, c land 0b0000_0001) - (* c 0b1111_110__ *) + else if + (* c 0b0____*) + c land 0b0100_0000 = 0 + then Cont (c land 0b0011_1111) + else if + (* c 0b10___*) + c land 0b0010_0000 = 0 + then Leading (1, c land 0b0001_1111) + else if + (* c 0b110__*) + c land 0b0001_0000 = 0 + then Leading (2, c land 0b0000_1111) + else if + (* c 0b1110_ *) + c land 0b0000_1000 = 0 + then Leading (3, c land 0b0000_0111) + else if + (* c 0b1111_0___*) + c land 0b0000_0100 = 0 + then Leading (4, c land 0b0000_0011) + else if + (* c 0b1111_10__*) + c land 0b0000_0010 = 0 + then Leading (5, c land 0b0000_0001) (* c 0b1111_110__ *) else Invalid exception Invalid_utf8 of string @@ -74,13 +85,13 @@ let decode_utf8_string s = else match classify s.[i] with | Single c -> - add c; - decode_utf8_cont s (i + 1) s_len + add c; + decode_utf8_cont s (i + 1) s_len | Cont _ -> raise (Invalid_utf8 "Unexpected continuation byte") | Leading (n, c) -> - let c', i' = follow s n c i in - add c'; - decode_utf8_cont s (i' + 1) s_len + let c', i' = follow s n c i in + add c'; + decode_utf8_cont s (i' + 1) s_len | Invalid -> raise (Invalid_utf8 "Invalid byte") in decode_utf8_cont s 0 (String.length s); @@ -128,4 +139,3 @@ let encode_codepoint c = Bytes.unsafe_set bytes 3 (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); Bytes.unsafe_to_string bytes - diff --git a/jscomp/ext/ext_utf8.mli b/compiler/ext/ext_utf8.mli similarity index 100% rename from jscomp/ext/ext_utf8.mli rename to compiler/ext/ext_utf8.mli diff --git a/jscomp/ext/ext_util.ml b/compiler/ext/ext_util.ml similarity index 91% rename from jscomp/ext/ext_util.ml rename to compiler/ext/ext_util.ml index 1be75ff..58b8ad2 100644 --- a/jscomp/ext/ext_util.ml +++ b/compiler/ext/ext_util.ml @@ -34,7 +34,7 @@ let rec power_2_above x n = else power_2_above (x * 2) n let stats_to_string - ({ num_bindings; num_buckets; max_bucket_length; bucket_histogram } : + ({num_bindings; num_buckets; max_bucket_length; bucket_histogram} : Hashtbl.statistics) = Printf.sprintf "bindings: %d,buckets: %d, longest: %d, hist:[%s]" num_bindings num_buckets max_bucket_length @@ -53,9 +53,9 @@ let string_of_int_as_char (i : int) : string = | '\r' -> "\\r" | '\b' -> "\\b" | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s | _ -> Ext_utf8.encode_codepoint i in Printf.sprintf "\'%s\'" str diff --git a/jscomp/ext/ext_util.mli b/compiler/ext/ext_util.mli similarity index 99% rename from jscomp/ext/ext_util.mli rename to compiler/ext/ext_util.mli index d31d11a..720e5b1 100644 --- a/jscomp/ext/ext_util.mli +++ b/compiler/ext/ext_util.mli @@ -27,4 +27,3 @@ val power_2_above : int -> int -> int val stats_to_string : Hashtbl.statistics -> string val string_of_int_as_char : int -> string - diff --git a/jscomp/ext/hash.cppo.ml b/compiler/ext/hash.cppo.ml similarity index 100% rename from jscomp/ext/hash.cppo.ml rename to compiler/ext/hash.cppo.ml diff --git a/jscomp/ext/hash.mli b/compiler/ext/hash.mli similarity index 100% rename from jscomp/ext/hash.mli rename to compiler/ext/hash.mli diff --git a/compiler/ext/hash_gen.ml b/compiler/ext/hash_gen.ml new file mode 100644 index 0000000..589639a --- /dev/null +++ b/compiler/ext/hash_gen.ml @@ -0,0 +1,236 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* Hash tables *) + +(* We do dynamic hashing, and resize the table and rehash the elements + when buckets become too long. *) + +type ('a, 'b) bucket = + | Empty + | Cons of {mutable key: 'a; mutable data: 'b; mutable next: ('a, 'b) bucket} + +type ('a, 'b) t = { + mutable size: int; + (* number of entries *) + mutable data: ('a, 'b) bucket array; + (* the buckets *) + initial_size: int; (* initial array size *) +} + +let create initial_size = + let s = Ext_util.power_2_above 16 initial_size in + {initial_size = s; size = 0; data = Array.make s Empty} + +let clear h = + h.size <- 0; + let len = Array.length h.data in + for i = 0 to len - 1 do + Array.unsafe_set h.data i Empty + done + +let reset h = + h.size <- 0; + h.data <- Array.make h.initial_size Empty + +let length h = h.size + +let resize indexfun h = + let odata = h.data in + let osize = Array.length odata in + let nsize = osize * 2 in + if nsize < Sys.max_array_length then ( + let ndata = Array.make nsize Empty in + let ndata_tail = Array.make nsize Empty in + h.data <- ndata; + (* so that indexfun sees the new bucket count *) + let rec insert_bucket = function + | Empty -> () + | Cons {key; next} as cell -> + let nidx = indexfun h key in + (match Array.unsafe_get ndata_tail nidx with + | Empty -> Array.unsafe_set ndata nidx cell + | Cons tail -> tail.next <- cell); + Array.unsafe_set ndata_tail nidx cell; + insert_bucket next + in + for i = 0 to osize - 1 do + insert_bucket (Array.unsafe_get odata i) + done; + for i = 0 to nsize - 1 do + match Array.unsafe_get ndata_tail i with + | Empty -> () + | Cons tail -> tail.next <- Empty + done) + +let iter h f = + let rec do_bucket = function + | Empty -> () + | Cons l -> + f l.key l.data; + do_bucket l.next + in + let d = h.data in + for i = 0 to Array.length d - 1 do + do_bucket (Array.unsafe_get d i) + done + +let fold h init f = + let rec do_bucket b accu = + match b with + | Empty -> accu + | Cons l -> do_bucket l.next (f l.key l.data accu) + in + let d = h.data in + let accu = ref init in + for i = 0 to Array.length d - 1 do + accu := do_bucket (Array.unsafe_get d i) !accu + done; + !accu + +let to_list h f = fold h [] (fun k data acc -> f k data :: acc) + +let rec small_bucket_mem (lst : _ bucket) eq key = + match lst with + | Empty -> false + | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> eq key lst.key || small_bucket_mem lst.next eq key)) + +let rec small_bucket_opt eq key (lst : _ bucket) : _ option = + match lst with + | Empty -> None + | Cons lst -> ( + if eq key lst.key then Some lst.data + else + match lst.next with + | Empty -> None + | Cons lst -> ( + if eq key lst.key then Some lst.data + else + match lst.next with + | Empty -> None + | Cons lst -> + if eq key lst.key then Some lst.data + else small_bucket_opt eq key lst.next)) + +let rec small_bucket_key_opt eq key (lst : _ bucket) : _ option = + match lst with + | Empty -> None + | Cons {key = k; next} -> ( + if eq key k then Some k + else + match next with + | Empty -> None + | Cons {key = k; next} -> ( + if eq key k then Some k + else + match next with + | Empty -> None + | Cons {key = k; next} -> + if eq key k then Some k else small_bucket_key_opt eq key next)) + +let rec small_bucket_default eq key default (lst : _ bucket) = + match lst with + | Empty -> default + | Cons lst -> ( + if eq key lst.key then lst.data + else + match lst.next with + | Empty -> default + | Cons lst -> ( + if eq key lst.key then lst.data + else + match lst.next with + | Empty -> default + | Cons lst -> + if eq key lst.key then lst.data + else small_bucket_default eq key default lst.next)) + +let rec remove_bucket h (i : int) key ~(prec : _ bucket) (buck : _ bucket) + eq_key = + match buck with + | Empty -> () + | Cons {key = k; next} -> + if eq_key k key then ( + h.size <- h.size - 1; + match prec with + | Empty -> Array.unsafe_set h.data i next + | Cons c -> c.next <- next) + else remove_bucket h i key ~prec:buck next eq_key + +let rec replace_bucket key data (buck : _ bucket) eq_key = + match buck with + | Empty -> true + | Cons slot -> + if eq_key slot.key key then ( + slot.key <- key; + slot.data <- data; + false) + else replace_bucket key data slot.next eq_key + +module type S = sig + type key + + type 'a t + + val create : int -> 'a t + + val clear : 'a t -> unit + + val reset : 'a t -> unit + + val add : 'a t -> key -> 'a -> unit + + val add_or_update : 'a t -> key -> update:('a -> 'a) -> 'a -> unit + + val remove : 'a t -> key -> unit + + val find_exn : 'a t -> key -> 'a + + val find_all : 'a t -> key -> 'a list + + val find_opt : 'a t -> key -> 'a option + + val find_key_opt : 'a t -> key -> key option + (** return the key found in the hashtbl. + Use case: when you find the key existed in hashtbl, + you want to use the one stored in the hashtbl. + (they are semantically equivlanent, but may have other information different) + *) + + val find_default : 'a t -> key -> 'a -> 'a + + val replace : 'a t -> key -> 'a -> unit + + val mem : 'a t -> key -> bool + + val iter : 'a t -> (key -> 'a -> unit) -> unit + + val fold : 'a t -> 'b -> (key -> 'a -> 'b -> 'b) -> 'b + + val length : 'a t -> int + + (* val stats: 'a t -> Hashtbl.statistics *) + val to_list : 'a t -> (key -> 'a -> 'c) -> 'c list + + val of_list2 : key list -> 'a list -> 'a t +end diff --git a/compiler/ext/hash_ident.mli b/compiler/ext/hash_ident.mli new file mode 100644 index 0000000..4397186 --- /dev/null +++ b/compiler/ext/hash_ident.mli @@ -0,0 +1 @@ +include Hash_gen.S with type key = Ident.t diff --git a/jscomp/ext/hash_int.mli b/compiler/ext/hash_int.mli similarity index 100% rename from jscomp/ext/hash_int.mli rename to compiler/ext/hash_int.mli diff --git a/jscomp/ext/hash_set.cppo.ml b/compiler/ext/hash_set.cppo.ml similarity index 100% rename from jscomp/ext/hash_set.cppo.ml rename to compiler/ext/hash_set.cppo.ml diff --git a/jscomp/ext/hash_set.mli b/compiler/ext/hash_set.mli similarity index 100% rename from jscomp/ext/hash_set.mli rename to compiler/ext/hash_set.mli diff --git a/jscomp/ext/hash_set_gen.ml b/compiler/ext/hash_set_gen.ml similarity index 76% rename from jscomp/ext/hash_set_gen.ml rename to compiler/ext/hash_set_gen.ml index a187903..db892ca 100644 --- a/jscomp/ext/hash_set_gen.ml +++ b/compiler/ext/hash_set_gen.ml @@ -25,21 +25,19 @@ (* We do dynamic hashing, and resize the table and rehash the elements when buckets become too long. *) -type 'a bucket = - | Empty - | Cons of { mutable key : 'a; mutable next : 'a bucket } +type 'a bucket = Empty | Cons of {mutable key: 'a; mutable next: 'a bucket} type 'a t = { - mutable size : int; + mutable size: int; (* number of entries *) - mutable data : 'a bucket array; + mutable data: 'a bucket array; (* the buckets *) - initial_size : int; (* initial array size *) + initial_size: int; (* initial array size *) } let create initial_size = let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } + {initial_size = s; size = 0; data = Array.make s Empty} let clear h = h.size <- 0; @@ -65,13 +63,13 @@ let resize indexfun h = (* so that indexfun sees the new bucket count *) let rec insert_bucket = function | Empty -> () - | Cons { key; next } as cell -> - let nidx = indexfun h key in - (match Array.unsafe_get ndata_tail nidx with - | Empty -> Array.unsafe_set ndata nidx cell - | Cons tail -> tail.next <- cell); - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next + | Cons {key; next} as cell -> + let nidx = indexfun h key in + (match Array.unsafe_get ndata_tail nidx with + | Empty -> Array.unsafe_set ndata nidx cell + | Cons tail -> tail.next <- cell); + Array.unsafe_set ndata_tail nidx cell; + insert_bucket next in for i = 0 to osize - 1 do insert_bucket (Array.unsafe_get odata i) @@ -86,8 +84,8 @@ let iter h f = let rec do_bucket = function | Empty -> () | Cons l -> - f l.key; - do_bucket l.next + f l.key; + do_bucket l.next in let d = h.data in for i = 0 to Array.length d - 1 do @@ -96,7 +94,9 @@ let iter h f = let fold h init f = let rec do_bucket b accu = - match b with Empty -> accu | Cons l -> do_bucket l.next (f l.key accu) + match b with + | Empty -> accu + | Cons l -> do_bucket l.next (f l.key accu) in let d = h.data in let accu = ref init in @@ -111,28 +111,28 @@ let rec small_bucket_mem eq key lst = match lst with | Empty -> false | Cons lst -> ( + eq key lst.key + || + match lst.next with + | Empty -> false + | Cons lst -> ( eq key lst.key || match lst.next with | Empty -> false - | Cons lst -> ( - eq key lst.key - || - match lst.next with - | Empty -> false - | Cons lst -> eq key lst.key || small_bucket_mem eq key lst.next)) + | Cons lst -> eq key lst.key || small_bucket_mem eq key lst.next)) let rec remove_bucket (h : _ t) (i : int) key ~(prec : _ bucket) (buck : _ bucket) eq_key = match buck with | Empty -> () - | Cons { key = k; next } -> - if eq_key k key then ( - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next) - else remove_bucket h i key ~prec:buck next eq_key + | Cons {key = k; next} -> + if eq_key k key then ( + h.size <- h.size - 1; + match prec with + | Empty -> Array.unsafe_set h.data i next + | Cons c -> c.next <- next) + else remove_bucket h i key ~prec:buck next eq_key module type S = sig type key diff --git a/jscomp/ext/hash_set_ident.mli b/compiler/ext/hash_set_ident.mli similarity index 99% rename from jscomp/ext/hash_set_ident.mli rename to compiler/ext/hash_set_ident.mli index 5fed77b..b32ba8a 100644 --- a/jscomp/ext/hash_set_ident.mli +++ b/compiler/ext/hash_set_ident.mli @@ -22,5 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - include Hash_set_gen.S with type key = Ident.t diff --git a/compiler/ext/hash_set_ident_mask.ml b/compiler/ext/hash_set_ident_mask.ml new file mode 100644 index 0000000..67a78d8 --- /dev/null +++ b/compiler/ext/hash_set_ident_mask.ml @@ -0,0 +1,143 @@ +(* Copyright (C) 2015-2016 Bloomberg Finance L.P. + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +(** A speicalized datastructure for scc algorithm *) + +type ident = Ident.t + +type bucket = Empty | Cons of {ident: ident; mutable mask: bool; rest: bucket} + +type t = { + mutable size: int; + mutable data: bucket array; + mutable mask_size: int; (* mark how many idents are marked *) +} + +let key_index_by_ident (h : t) (key : Ident.t) = + Bs_hash_stubs.hash_string_int key.name key.stamp land (Array.length h.data - 1) + +let create initial_size = + let s = Ext_util.power_2_above 8 initial_size in + {size = 0; data = Array.make s Empty; mask_size = 0} + +let iter_and_unmask h f = + let rec iter_bucket buckets = + match buckets with + | Empty -> () + | Cons k -> + let k_mask = k.mask in + f k.ident k_mask; + if k_mask then ( + k.mask <- false; + (* we can set [h.mask_size] to zero, + however, it would result inconsistent state + once [f] throw + *) + h.mask_size <- h.mask_size - 1); + iter_bucket k.rest + in + let d = h.data in + for i = 0 to Array.length d - 1 do + iter_bucket (Array.unsafe_get d i) + done + +let rec small_bucket_mem key lst = + match lst with + | Empty -> false + | Cons rst -> ( + Ext_ident.equal key rst.ident + || + match rst.rest with + | Empty -> false + | Cons rst -> ( + Ext_ident.equal key rst.ident + || + match rst.rest with + | Empty -> false + | Cons rst -> + Ext_ident.equal key rst.ident || small_bucket_mem key rst.rest)) + +let resize indexfun h = + let odata = h.data in + let osize = Array.length odata in + let nsize = osize * 2 in + if nsize < Sys.max_array_length then ( + let ndata = Array.make nsize Empty in + h.data <- ndata; + (* so that indexfun sees the new bucket count *) + let rec insert_bucket = function + | Empty -> () + | Cons {ident = key; mask; rest} -> + let nidx = indexfun h key in + Array.unsafe_set ndata nidx + (Cons {ident = key; mask; rest = Array.unsafe_get ndata nidx}); + insert_bucket rest + in + for i = 0 to osize - 1 do + insert_bucket (Array.unsafe_get odata i) + done) + +let add_unmask (h : t) (key : Ident.t) = + let i = key_index_by_ident h key in + let h_data = h.data in + let old_bucket = Array.unsafe_get h_data i in + if not (small_bucket_mem key old_bucket) then ( + Array.unsafe_set h_data i + (Cons {ident = key; mask = false; rest = old_bucket}); + h.size <- h.size + 1; + if h.size > Array.length h_data lsl 1 then resize key_index_by_ident h) + +let rec small_bucket_mask key lst = + match lst with + | Empty -> false + | Cons rst -> ( + if Ext_ident.equal key rst.ident then + if rst.mask then false + else ( + rst.mask <- true; + true) + else + match rst.rest with + | Empty -> false + | Cons rst -> ( + if Ext_ident.equal key rst.ident then + if rst.mask then false + else ( + rst.mask <- true; + true) + else + match rst.rest with + | Empty -> false + | Cons rst -> + if Ext_ident.equal key rst.ident then + if rst.mask then false + else ( + rst.mask <- true; + true) + else small_bucket_mask key rst.rest)) + +let mask_and_check_all_hit (h : t) (key : Ident.t) = + if small_bucket_mask key (Array.unsafe_get h.data (key_index_by_ident h key)) + then h.mask_size <- h.mask_size + 1; + h.size = h.mask_size diff --git a/compiler/ext/hash_set_ident_mask.mli b/compiler/ext/hash_set_ident_mask.mli new file mode 100644 index 0000000..1c5bb8f --- /dev/null +++ b/compiler/ext/hash_set_ident_mask.mli @@ -0,0 +1,23 @@ +type ident = Ident.t +(** Based on [hash_set] specialized for mask operations *) + +type t + +val create : int -> t + +(* add one ident + ident is unmaksed by default +*) +val add_unmask : t -> ident -> unit + +val mask_and_check_all_hit : t -> ident -> bool +(** [check_mask h key] if [key] exists mask it otherwise nothing + return true if all keys are masked otherwise false +*) + +val iter_and_unmask : t -> (ident -> bool -> unit) -> unit +(** [iter_and_unmask f h] iterating the collection and mask all idents, + dont consul the collection in function [f] + TODO: what happens if an exception raised in the callback, + would the hashtbl still be in consistent state? +*) diff --git a/jscomp/ext/hash_set_int.mli b/compiler/ext/hash_set_int.mli similarity index 100% rename from jscomp/ext/hash_set_int.mli rename to compiler/ext/hash_set_int.mli diff --git a/jscomp/ext/hash_set_poly.mli b/compiler/ext/hash_set_poly.mli similarity index 100% rename from jscomp/ext/hash_set_poly.mli rename to compiler/ext/hash_set_poly.mli diff --git a/jscomp/ext/hash_set_string.mli b/compiler/ext/hash_set_string.mli similarity index 100% rename from jscomp/ext/hash_set_string.mli rename to compiler/ext/hash_set_string.mli diff --git a/jscomp/ext/hash_string.mli b/compiler/ext/hash_string.mli similarity index 100% rename from jscomp/ext/hash_string.mli rename to compiler/ext/hash_string.mli diff --git a/compiler/ext/ident.ml b/compiler/ext/ident.ml new file mode 100644 index 0000000..a5ca80e --- /dev/null +++ b/compiler/ext/ident.ml @@ -0,0 +1,238 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +open Format + +type t = {stamp: int; name: string; mutable flags: int} + +let[@inlnie] max (x : int) y = if x >= y then x else y +let global_flag = 1 +let predef_exn_flag = 2 + +(* A stamp of 0 denotes a persistent identifier *) + +let currentstamp = ref 0 + +let create s = + incr currentstamp; + {name = s; stamp = !currentstamp; flags = 0} + +let create_predef_exn s = + incr currentstamp; + {name = s; stamp = !currentstamp; flags = predef_exn_flag} + +let create_persistent s = {name = s; stamp = 0; flags = global_flag} + +let rename i = + incr currentstamp; + {i with stamp = !currentstamp} + +let name i = i.name + +let unique_name i = i.name ^ "_" ^ string_of_int i.stamp + +let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp + +let persistent i = i.stamp = 0 + +let equal i1 i2 = i1.name = i2.name + +let same ({stamp; name} : t) i2 = + if stamp <> 0 then stamp = i2.stamp else i2.stamp = 0 && name = i2.name + +let binding_time i = i.stamp + +let current_time () = !currentstamp +let set_current_time t = currentstamp := max !currentstamp t + +let reinit_level = ref (-1) + +let reinit () = + if !reinit_level < 0 then reinit_level := !currentstamp + else currentstamp := !reinit_level + +let hide i = {i with stamp = -1} + +let make_global i = i.flags <- i.flags lor global_flag + +let global i = i.flags land global_flag <> 0 + +let is_predef_exn i = i.flags land predef_exn_flag <> 0 + +let print ppf i = + match i.stamp with + | 0 -> fprintf ppf "%s!" i.name + | -1 -> fprintf ppf "%s#" i.name + | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "") + +type 'a tbl = Empty | Node of 'a tbl * 'a data * 'a tbl * int + +and 'a data = {ident: t; data: 'a; previous: 'a data option} + +let empty = Empty + +(* Inline expansion of height for better speed + * let height = function + * Empty -> 0 + * | Node(_,_,_,h) -> h + *) + +let mknode l d r = + let hl = + match l with + | Empty -> 0 + | Node (_, _, _, h) -> h + and hr = + match r with + | Empty -> 0 + | Node (_, _, _, h) -> h + in + Node (l, d, r, if hl >= hr then hl + 1 else hr + 1) + +let balance l d r = + let hl = + match l with + | Empty -> 0 + | Node (_, _, _, h) -> h + and hr = + match r with + | Empty -> 0 + | Node (_, _, _, h) -> h + in + if hl > hr + 1 then + match l with + | Node (ll, ld, lr, _) + when (match ll with + | Empty -> 0 + | Node (_, _, _, h) -> h) + >= + match lr with + | Empty -> 0 + | Node (_, _, _, h) -> h -> + mknode ll ld (mknode lr d r) + | Node (ll, ld, Node (lrl, lrd, lrr, _), _) -> + mknode (mknode ll ld lrl) lrd (mknode lrr d r) + | _ -> assert false + else if hr > hl + 1 then + match r with + | Node (rl, rd, rr, _) + when (match rr with + | Empty -> 0 + | Node (_, _, _, h) -> h) + >= + match rl with + | Empty -> 0 + | Node (_, _, _, h) -> h -> + mknode (mknode l d rl) rd rr + | Node (Node (rll, rld, rlr, _), rd, rr, _) -> + mknode (mknode l d rll) rld (mknode rlr rd rr) + | _ -> assert false + else mknode l d r + +let rec add id data = function + | Empty -> Node (Empty, {ident = id; data; previous = None}, Empty, 1) + | Node (l, k, r, h) -> + let c = compare id.name k.ident.name in + if c = 0 then Node (l, {ident = id; data; previous = Some k}, r, h) + else if c < 0 then balance (add id data l) k r + else balance l k (add id data r) + +let rec find_stamp s = function + | None -> raise Not_found + | Some k -> if k.ident.stamp = s then k.data else find_stamp s k.previous + +let rec find_same id = function + | Empty -> raise Not_found + | Node (l, k, r, _) -> + let c = compare id.name k.ident.name in + if c = 0 then + if id.stamp = k.ident.stamp then k.data + else find_stamp id.stamp k.previous + else find_same id (if c < 0 then l else r) + +let rec find_name name = function + | Empty -> raise Not_found + | Node (l, k, r, _) -> + let c = compare name k.ident.name in + if c = 0 then (k.ident, k.data) else find_name name (if c < 0 then l else r) + +let rec get_all = function + | None -> [] + | Some k -> (k.ident, k.data) :: get_all k.previous + +let rec find_all name = function + | Empty -> [] + | Node (l, k, r, _) -> + let c = compare name k.ident.name in + if c = 0 then (k.ident, k.data) :: get_all k.previous + else find_all name (if c < 0 then l else r) + +let rec fold_aux f stack accu = function + | Empty -> ( + match stack with + | [] -> accu + | a :: l -> fold_aux f l accu a) + | Node (l, k, r, _) -> fold_aux f (l :: stack) (f k accu) r + +let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl + +let rec fold_data f d accu = + match d with + | None -> accu + | Some k -> f k.ident k.data (fold_data f k.previous accu) + +let fold_all f tbl accu = fold_aux (fun k -> fold_data f (Some k)) [] accu tbl + +(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *) + +let rec iter f = function + | Empty -> () + | Node (l, k, r, _) -> + iter f l; + f k.ident k.data; + iter f r + +(* Idents for sharing keys *) + +(* They should be 'totally fresh' -> neg numbers *) +let key_name = "" + +let make_key_generator () = + let c = ref 1 in + fun id -> + let stamp = !c in + decr c; + {id with name = key_name; stamp} + +let compare x y = + let c = x.stamp - y.stamp in + if c <> 0 then c + else + let c = compare x.name y.name in + if c <> 0 then c else compare x.flags y.flags + +let output oc id = output_string oc (unique_name id) +let hash i = Char.code i.name.[0] lxor i.stamp + +let original_equal = equal +include Identifiable.Make (struct + type nonrec t = t + let compare = compare + let output = output + let print = print + let hash = hash + let equal = same +end) +let equal = original_equal diff --git a/compiler/ext/ident.mli b/compiler/ext/ident.mli new file mode 100644 index 0000000..d73cff6 --- /dev/null +++ b/compiler/ext/ident.mli @@ -0,0 +1,72 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Identifiers (unique names) *) + +type t = {stamp: int; name: string; mutable flags: int} + +include Identifiable.S with type t := t +(* Notes: + - [equal] compares identifiers by name + - [compare x y] is 0 if [same x y] is true. + - [compare] compares identifiers by binding location +*) + +val create : string -> t +val create_persistent : string -> t +val create_predef_exn : string -> t +val rename : t -> t +val name : t -> string +val unique_name : t -> string +val unique_toplevel_name : t -> string +val persistent : t -> bool +val same : t -> t -> bool +(* Compare identifiers by binding location. + Two identifiers are the same either if they are both + non-persistent and have been created by the same call to + [new], or if they are both persistent and have the same + name. *) + +val compare : t -> t -> int +val hide : t -> t +(* Return an identifier with same name as the given identifier, + but stamp different from any stamp returned by new. + When put in a 'a tbl, this identifier can only be looked + up by name. *) + +val make_global : t -> unit +val global : t -> bool +val is_predef_exn : t -> bool + +val binding_time : t -> int +val current_time : unit -> int +val set_current_time : int -> unit +val reinit : unit -> unit + +type 'a tbl +(* Association tables from identifiers to type 'a. *) + +val empty : 'a tbl +val add : t -> 'a -> 'a tbl -> 'a tbl +val find_same : t -> 'a tbl -> 'a +val find_name : string -> 'a tbl -> t * 'a +val find_all : string -> 'a tbl -> (t * 'a) list +val fold_name : (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val fold_all : (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val iter : (t -> 'a -> unit) -> 'a tbl -> unit + +(* Idents for sharing keys *) + +val make_key_generator : unit -> t -> t diff --git a/jscomp/ext/identifiable.ml b/compiler/ext/identifiable.ml similarity index 79% rename from jscomp/ext/identifiable.ml rename to compiler/ext/identifiable.ml index 6ee0519..bd6133c 100644 --- a/jscomp/ext/identifiable.ml +++ b/compiler/ext/identifiable.ml @@ -26,9 +26,7 @@ end module type Set = sig module T : Set.OrderedType - include Set.S - with type elt = T.t - and type t = Set.Make (T).t + include Set.S with type elt = T.t and type t = Set.Make(T).t val output : out_channel -> t -> unit val print : Format.formatter -> t -> unit @@ -39,14 +37,17 @@ end module type Map = sig module T : Map.OrderedType - include Map.S - with type key = T.t - and type 'a t = 'a Map.Make (T).t + include Map.S with type key = T.t and type 'a t = 'a Map.Make(T).t val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t val of_list : (key * 'a) list -> 'a t - val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t + val disjoint_union : + ?eq:('a -> 'a -> bool) -> + ?print:(Format.formatter -> 'a -> unit) -> + 'a t -> + 'a t -> + 'a t val union_right : 'a t -> 'a t -> 'a t @@ -70,9 +71,7 @@ module type Tbl = sig include Map.OrderedType with type t := t include Hashtbl.HashedType with type t := t end - include Hashtbl.S - with type key = T.t - and type 'a t = 'a Hashtbl.Make (T).t + include Hashtbl.S with type key = T.t and type 'a t = 'a Hashtbl.Make(T).t val to_list : 'a t -> (T.t * 'a) list val of_list : (T.t * 'a) list -> 'a t @@ -88,8 +87,7 @@ module Pair (A : Thing) (B : Thing) : Thing with type t = A.t * B.t = struct let compare (a1, b1) (a2, b2) = let c = A.compare a1 a2 in - if c <> 0 then c - else B.compare b1 b2 + if c <> 0 then c else B.compare b1 b2 let output oc (a, b) = Printf.fprintf oc " (%a, %a)" A.output a B.output b let hash (a, b) = Hashtbl.hash (A.hash a, B.hash b) @@ -100,62 +98,62 @@ end module Make_map (T : Thing) = struct include Map.Make (T) - let filter_map f t = - fold (fun id v map -> + let filter_map f t = + fold + (fun id v map -> match f id v with | None -> map - | Some r -> add id r map) t empty + | Some r -> add id r map) + t empty - let of_list l = - List.fold_left (fun map (id, v) -> add id v map) empty l + let of_list l = List.fold_left (fun map (id, v) -> add id v map) empty l let disjoint_union ?eq ?print m1 m2 = - union (fun id v1 v2 -> - let ok = match eq with + union + (fun id v1 v2 -> + let ok = + match eq with | None -> false | Some eq -> eq v1 v2 in if not ok then let err = match print with - | None -> - Format.asprintf "Map.disjoint_union %a" T.print id + | None -> Format.asprintf "Map.disjoint_union %a" T.print id | Some print -> - Format.asprintf "Map.disjoint_union %a => %a <> %a" - T.print id print v1 print v2 + Format.asprintf "Map.disjoint_union %a => %a <> %a" T.print id + print v1 print v2 in Misc.fatal_error err else Some v1) m1 m2 let union_right m1 m2 = - merge (fun _id x y -> match x, y with + merge + (fun _id x y -> + match (x, y) with | None, None -> None - | None, Some v - | Some v, None - | Some _, Some v -> Some v) + | None, Some v | Some v, None | Some _, Some v -> Some v) m1 m2 let union_left m1 m2 = union_right m2 m1 let union_merge f m1 m2 = let aux _ m1 m2 = - match m1, m2 with + match (m1, m2) with | None, m | m, None -> m | Some m1, Some m2 -> Some (f m1 m2) in merge aux m1 m2 - let rename m v = - try find v m - with Not_found -> v + let rename m v = try find v m with Not_found -> v - let map_keys f m = - of_list (List.map (fun (k, v) -> f k, v) (bindings m)) + let map_keys f m = of_list (List.map (fun (k, v) -> (f k, v)) (bindings m)) let print f ppf s = - let elts ppf s = iter (fun id v -> - Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s in + let elts ppf s = + iter (fun id v -> Format.fprintf ppf "@ (@[%a@ %a@])" T.print id f v) s + in Format.fprintf ppf "@[<1>{@[%a@ @]}@]" elts s module T_set = Set.Make (T) @@ -168,13 +166,12 @@ module Make_map (T : Thing) = struct let transpose_keys_and_data map = fold (fun k v m -> add v k m) map empty let transpose_keys_and_data_set map = - fold (fun k v m -> + fold + (fun k v m -> let set = match find v m with - | exception Not_found -> - T_set.singleton k - | set -> - T_set.add k set + | exception Not_found -> T_set.singleton k + | set -> T_set.add k set in add v set m) map empty @@ -194,7 +191,8 @@ module Make_set (T : Thing) = struct let to_string s = Format.asprintf "%a" print s - let of_list l = match l with + let of_list l = + match l with | [] -> empty | [t] -> singleton t | t :: q -> List.fold_left (fun acc e -> add e acc) (singleton t) q @@ -207,8 +205,7 @@ module Make_tbl (T : Thing) = struct module T_map = Make_map (T) - let to_list t = - fold (fun key datum elts -> (key, datum)::elts) t [] + let to_list t = fold (fun key datum elts -> (key, datum) :: elts) t [] let of_list elts = let t = create 42 in @@ -222,15 +219,14 @@ module Make_tbl (T : Thing) = struct T_map.iter (fun k v -> add t k v) m; t - let memoize t f = fun key -> - try find t key with - | Not_found -> + let memoize t f key = + try find t key + with Not_found -> let r = f key in add t key r; r - let map t f = - of_map (T_map.map f (to_map t)) + let map t f = of_map (T_map.map f (to_map t)) end module type S = sig diff --git a/jscomp/ext/identifiable.mli b/compiler/ext/identifiable.mli similarity index 90% rename from jscomp/ext/identifiable.mli rename to compiler/ext/identifiable.mli index 46e1454..9dd8def 100644 --- a/jscomp/ext/identifiable.mli +++ b/compiler/ext/identifiable.mli @@ -30,9 +30,7 @@ module Pair : functor (A : Thing) (B : Thing) -> Thing with type t = A.t * B.t module type Set = sig module T : Set.OrderedType - include Set.S - with type elt = T.t - and type t = Set.Make (T).t + include Set.S with type elt = T.t and type t = Set.Make(T).t val output : out_channel -> t -> unit val print : Format.formatter -> t -> unit @@ -43,24 +41,27 @@ end module type Map = sig module T : Map.OrderedType - include Map.S - with type key = T.t - and type 'a t = 'a Map.Make (T).t + include Map.S with type key = T.t and type 'a t = 'a Map.Make(T).t val filter_map : (key -> 'a -> 'b option) -> 'a t -> 'b t val of_list : (key * 'a) list -> 'a t + val disjoint_union : + ?eq:('a -> 'a -> bool) -> + ?print:(Format.formatter -> 'a -> unit) -> + 'a t -> + 'a t -> + 'a t (** [disjoint_union m1 m2] contains all bindings from [m1] and [m2]. If some binding is present in both and the associated value is not equal, a Fatal_error is raised *) - val disjoint_union : ?eq:('a -> 'a -> bool) -> ?print:(Format.formatter -> 'a -> unit) -> 'a t -> 'a t -> 'a t + val union_right : 'a t -> 'a t -> 'a t (** [union_right m1 m2] contains all bindings from [m1] and [m2]. If some binding is present in both, the one from [m2] is taken *) - val union_right : 'a t -> 'a t -> 'a t - (** [union_left m1 m2 = union_right m2 m1] *) val union_left : 'a t -> 'a t -> 'a t + (** [union_left m1 m2 = union_right m2 m1] *) val union_merge : ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t val rename : key t -> key -> key @@ -80,9 +81,7 @@ module type Tbl = sig include Map.OrderedType with type t := t include Hashtbl.HashedType with type t := t end - include Hashtbl.S - with type key = T.t - and type 'a t = 'a Hashtbl.Make (T).t + include Hashtbl.S with type key = T.t and type 'a t = 'a Hashtbl.Make(T).t val to_list : 'a t -> (T.t * 'a) list val of_list : (T.t * 'a) list -> 'a t diff --git a/jscomp/ext/int_vec_util.ml b/compiler/ext/int_vec_util.ml similarity index 100% rename from jscomp/ext/int_vec_util.ml rename to compiler/ext/int_vec_util.ml diff --git a/jscomp/ext/int_vec_util.mli b/compiler/ext/int_vec_util.mli similarity index 100% rename from jscomp/ext/int_vec_util.mli rename to compiler/ext/int_vec_util.mli diff --git a/jscomp/ext/int_vec_vec.ml b/compiler/ext/int_vec_vec.ml similarity index 100% rename from jscomp/ext/int_vec_vec.ml rename to compiler/ext/int_vec_vec.ml diff --git a/jscomp/ext/int_vec_vec.mli b/compiler/ext/int_vec_vec.mli similarity index 100% rename from jscomp/ext/int_vec_vec.mli rename to compiler/ext/int_vec_vec.mli diff --git a/compiler/ext/js_reserved_map.ml b/compiler/ext/js_reserved_map.ml new file mode 100644 index 0000000..6daaff9 --- /dev/null +++ b/compiler/ext/js_reserved_map.ml @@ -0,0 +1,243 @@ +(* Copyright (C) 2019-Present Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +module STbl = struct + #if OCAML_VERSION >= (5, 0, 0) + include Hashtbl.Make (String) + #else + module StringHash : Hashtbl.HashedType with type t = string = struct + type t = string + let equal = String.equal + let hash = Hashtbl.hash (* polymorphic hash function *) + end + include Hashtbl.Make (StringHash) + #endif + + let of_array arr = + let tbl = create (Array.length arr) in + let () = Array.iter (fun el -> add tbl el ()) arr in + tbl +end + +(** Words that can never be identifier's name. + + See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Lexical_grammar#reserved_words + *) +let js_keywords = STbl.of_array [| + "break"; + "case"; + "catch"; + "class"; + "const"; + "continue"; + "debugger"; + "default"; + "delete"; + "do"; + "else"; + "export"; + "extends"; + "false"; + "finally"; + "for"; + "function"; + "if"; + "import"; + "in"; + "instanceof"; + "new"; + "null"; + "return"; + "super"; + "switch"; + "this"; + "throw"; + "true"; + "try"; + "typeof"; + "var"; + "void"; + "while"; + "with"; + + (* The following are also reserved in strict context, including ESM *) + "let"; + "static"; + "yield"; + + (* `await` is reserved in async context, including ESM *) + "await"; + + (* Future reserved words *) + "enum"; + "implements"; + "interface"; + "package"; + "private"; + "protected"; + "public"; + + (* Special identifiers + + `arguments` and `eval` is not real *keywords* + + However, they cannot be as identifiers in the strict mode, + and the compiler output is always in strict mode. + + See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Lexical_grammar#identifiers_with_special_meanings + *) + "arguments"; + "eval"; +|] + +let is_js_keyword s = STbl.mem js_keywords s + +(** Identifiers with special meanings. + + They can have different meanings depending on the context when used as identifier names, so it should be done carefully. + + See https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Lexical_grammar#identifiers_with_special_meanings + + However, these names are actually used with no problems today. (Except `arguments` and `eval`) + *) +let js_special_words = STbl.of_array [| + "arguments"; + "as"; + "async"; + "eval"; + "from"; + "get"; + "of"; + "set"; +|] + +let is_js_special_word s = STbl.mem js_special_words s + +(** Identifier names _might_ need to care about *) +let js_globals = STbl.of_array [| + (* JavaScript standards built-ins + See https://developer.mozilla.org/ko/docs/Web/JavaScript/Reference/Global_Objects + *) + "AggregateError"; + "Array"; + "ArrayBuffer"; + "AsyncFunction"; + "AsyncGenerator"; + "AsyncGeneratorFunction"; + "AsyncIterator"; + "Atomics"; + "BigInt"; + "BigInt64Array"; + "BigUint64Array"; + "Boolean"; + "DataView"; + "Date"; + "decodeURI"; + "decodeURIComponent"; + "encodeURI"; + "encodeURIComponent"; + "Error"; + "eval"; + "EvalError"; + "FinalizationRegistry"; + "Float16Array"; + "Float32Array"; + "Float64Array"; + "Function"; + "Generator"; + "GeneratorFunction"; + "globalThis"; + "Infinity"; + "Int16Array"; + "Int32Array"; + "Int8Array"; + "Intl"; + "isFinite"; + "isNaN"; + "Iterator"; + "JSON"; + "Map"; + "Math"; + "NaN"; + "Number"; + "Object"; + "parseFloat"; + "parseInt"; + "Promise"; + "Proxy"; + "RangeError"; + "ReferenceError"; + "Reflect"; + "RegExp"; + "Set"; + "SharedArrayBuffer"; + "String"; + "Symbol"; + "SyntaxError"; + "TypedArray"; + "TypeError"; + "Uint16Array"; + "Uint32Array"; + "Uint8Array"; + "Uint8ClampedArray"; + "undefined"; + "URIError"; + "WeakMap"; + "WeakRef"; + "WeakSet"; + + (* A few of the HTML standard globals + + See https://developer.mozilla.org/en-US/docs/Web/API/Window + See https://developer.mozilla.org/en-US/docs/Web/API/WorkerGlobalScope + + But we don't actually need to protect these names. + + "window"; + "self"; + "document"; + "location"; + "navigator"; + "origin"; + *) + + (* A few of the Node.js globals + + Specifically related to the CommonJS module system + They cannot be redeclared in nested scope. + *) + "__dirname"; + "__filename"; + "require"; + "module"; + "exports"; + + (* Bun's global namespace *) + "Bun"; + + (* Deno's global namespace *) + "Deno"; +|] + +let is_js_global s = STbl.mem js_globals s diff --git a/jscomp/ext/js_reserved_map.mli b/compiler/ext/js_reserved_map.mli similarity index 92% rename from jscomp/ext/js_reserved_map.mli rename to compiler/ext/js_reserved_map.mli index 072737f..5ee1982 100644 --- a/jscomp/ext/js_reserved_map.mli +++ b/compiler/ext/js_reserved_map.mli @@ -22,4 +22,8 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val is_reserved : string -> bool +val is_js_keyword : string -> bool + +val is_js_special_word : string -> bool + +val is_js_global : string -> bool diff --git a/jscomp/ext/literals.ml b/compiler/ext/literals.ml similarity index 93% rename from jscomp/ext/literals.ml rename to compiler/ext/literals.ml index b1aa1c2..2b46965 100644 --- a/jscomp/ext/literals.ml +++ b/compiler/ext/literals.ml @@ -50,8 +50,6 @@ let runtime = "runtime" (* runtime directory *) let stdlib = "stdlib" -let imul = "imul" (* signed int32 mul *) - let setter_suffix = "#=" let setter_suffix_len = String.length setter_suffix @@ -99,10 +97,6 @@ let suffix_cmxa = ".cmxa" let suffix_mll = ".mll" -let suffix_ml = ".ml" - -let suffix_mli = ".mli" - let suffix_res = ".res" let suffix_resi = ".resi" @@ -130,10 +124,10 @@ let esmodule = "esmodule" let commonjs = "commonjs" let es6 = "es6" -[@@ocaml.deprecated "Will be removed in v12"] +(* [@@deprecated "Will be removed in v12"] *) let es6_global = "es6-global" -[@@ocaml.deprecated "Will be removed in v12"] +(* [@@deprecated "Will be removed in v12"] *) let unused_attribute = "Unused attribute " @@ -170,8 +164,4 @@ let hd = "hd" let tl = "tl" -let lazy_done = "LAZY_DONE" - -let lazy_val = "VAL" - let pure = "@__PURE__" diff --git a/jscomp/ext/map.cppo.ml b/compiler/ext/map.cppo.ml similarity index 100% rename from jscomp/ext/map.cppo.ml rename to compiler/ext/map.cppo.ml diff --git a/compiler/ext/map_gen.ml b/compiler/ext/map_gen.ml new file mode 100644 index 0000000..7c8af83 --- /dev/null +++ b/compiler/ext/map_gen.ml @@ -0,0 +1,412 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +[@@@warnerror "+55"] +(* adapted from stdlib *) + +type ('key, 'a) t0 = + | Empty + | Leaf of {k: 'key; v: 'a} + | Node of {l: ('key, 'a) t0; k: 'key; v: 'a; r: ('key, 'a) t0; h: int} + +type ('key, 'a) parital_node = { + l: ('key, 'a) t0; + k: 'key; + v: 'a; + r: ('key, 'a) t0; + h: int; +} + +external ( ~! ) : ('key, 'a) t0 -> ('key, 'a) parital_node = "%identity" + +let empty = Empty + +let rec map x f = + match x with + | Empty -> Empty + | Leaf {k; v} -> Leaf {k; v = f v} + | Node ({l; v; r} as x) -> + let l' = map l f in + let d' = f v in + let r' = map r f in + Node {x with l = l'; v = d'; r = r'} + +let rec mapi x f = + match x with + | Empty -> Empty + | Leaf {k; v} -> Leaf {k; v = f k v} + | Node ({l; k; v; r} as x) -> + let l' = mapi l f in + let v' = f k v in + let r' = mapi r f in + Node {x with l = l'; v = v'; r = r'} + +let[@inline] calc_height a b = (if a >= b then a else b) + 1 + +let[@inline] singleton k v = Leaf {k; v} + +let[@inline] height = function + | Empty -> 0 + | Leaf _ -> 1 + | Node {h} -> h + +let[@inline] unsafe_node k v l r h = Node {l; k; v; r; h} + +let[@inline] unsafe_two_elements k1 v1 k2 v2 = + unsafe_node k2 v2 (singleton k1 v1) empty 2 + +let[@inline] unsafe_node_maybe_leaf k v l r h = + if h = 1 then Leaf {k; v} else Node {l; k; v; r; h} + +type ('key, +'a) t = ('key, 'a) t0 = private + | Empty + | Leaf of {k: 'key; v: 'a} + | Node of {l: ('key, 'a) t; k: 'key; v: 'a; r: ('key, 'a) t; h: int} + +let rec cardinal_aux acc = function + | Empty -> acc + | Leaf _ -> acc + 1 + | Node {l; r} -> cardinal_aux (cardinal_aux (acc + 1) r) l + +let cardinal s = cardinal_aux 0 s + +let rec bindings_aux accu = function + | Empty -> accu + | Leaf {k; v} -> (k, v) :: accu + | Node {l; k; v; r} -> bindings_aux ((k, v) :: bindings_aux accu r) l + +let bindings s = bindings_aux [] s + +let rec fill_array_with_f (s : _ t) i arr f : int = + match s with + | Empty -> i + | Leaf {k; v} -> + Array.unsafe_set arr i (f k v); + i + 1 + | Node {l; k; v; r} -> + let inext = fill_array_with_f l i arr f in + Array.unsafe_set arr inext (f k v); + fill_array_with_f r (inext + 1) arr f + +let rec fill_array_aux (s : _ t) i arr : int = + match s with + | Empty -> i + | Leaf {k; v} -> + Array.unsafe_set arr i (k, v); + i + 1 + | Node {l; k; v; r} -> + let inext = fill_array_aux l i arr in + Array.unsafe_set arr inext (k, v); + fill_array_aux r (inext + 1) arr + +let to_sorted_array (s : ('key, 'a) t) : ('key * 'a) array = + match s with + | Empty -> [||] + | Leaf {k; v} -> [|(k, v)|] + | Node {l; k; v; r} -> + let len = cardinal_aux (cardinal_aux 1 r) l in + let arr = Array.make len (k, v) in + ignore (fill_array_aux s 0 arr : int); + arr + +let to_sorted_array_with_f (type key a b) (s : (key, a) t) (f : key -> a -> b) : + b array = + match s with + | Empty -> [||] + | Leaf {k; v} -> [|f k v|] + | Node {l; k; v; r} -> + let len = cardinal_aux (cardinal_aux 1 r) l in + let arr = Array.make len (f k v) in + ignore (fill_array_with_f s 0 arr f : int); + arr + +let rec keys_aux accu = function + | Empty -> accu + | Leaf {k} -> k :: accu + | Node {l; k; r} -> keys_aux (k :: keys_aux accu r) l + +let keys s = keys_aux [] s + +let bal l x d r = + let hl = height l in + let hr = height r in + if hl > hr + 2 then + let {l = ll; r = lr; v = lv; k = lk; h = _} = ~!l in + let hll = height ll in + let hlr = height lr in + if hll >= hlr then + let hnode = calc_height hlr hr in + unsafe_node lk lv ll + (unsafe_node_maybe_leaf x d lr r hnode) + (calc_height hll hnode) + else + let {l = lrl; r = lrr; k = lrk; v = lrv} = ~!lr in + let hlrl = height lrl in + let hlrr = height lrr in + let hlnode = calc_height hll hlrl in + let hrnode = calc_height hlrr hr in + unsafe_node lrk lrv + (unsafe_node_maybe_leaf lk lv ll lrl hlnode) + (unsafe_node_maybe_leaf x d lrr r hrnode) + (calc_height hlnode hrnode) + else if hr > hl + 2 then + let {l = rl; r = rr; k = rk; v = rv} = ~!r in + let hrr = height rr in + let hrl = height rl in + if hrr >= hrl then + let hnode = calc_height hl hrl in + unsafe_node rk rv + (unsafe_node_maybe_leaf x d l rl hnode) + rr (calc_height hnode hrr) + else + let {l = rll; r = rlr; k = rlk; v = rlv} = ~!rl in + let hrll = height rll in + let hrlr = height rlr in + let hlnode = calc_height hl hrll in + let hrnode = calc_height hrlr hrr in + unsafe_node rlk rlv + (unsafe_node_maybe_leaf x d l rll hlnode) + (unsafe_node_maybe_leaf rk rv rlr rr hrnode) + (calc_height hlnode hrnode) + else unsafe_node_maybe_leaf x d l r (calc_height hl hr) + +let[@inline] is_empty = function + | Empty -> true + | _ -> false + +let rec min_binding_exn = function + | Empty -> raise Not_found + | Leaf {k; v} -> (k, v) + | Node {l; k; v} -> ( + match l with + | Empty -> (k, v) + | Leaf _ | Node _ -> min_binding_exn l) + +let rec remove_min_binding = function + | Empty -> invalid_arg "Map.remove_min_elt" + | Leaf _ -> empty + | Node {l = Empty; r} -> r + | Node {l; k; v; r} -> bal (remove_min_binding l) k v r + +let merge t1 t2 = + match (t1, t2) with + | Empty, t -> t + | t, Empty -> t + | _, _ -> + let x, d = min_binding_exn t2 in + bal t1 x d (remove_min_binding t2) + +let rec iter x f = + match x with + | Empty -> () + | Leaf {k; v} -> (f k v : unit) + | Node {l; k; v; r} -> + iter l f; + f k v; + iter r f + +let rec fold m accu f = + match m with + | Empty -> accu + | Leaf {k; v} -> f k v accu + | Node {l; k; v; r} -> fold r (f k v (fold l accu f)) f + +let rec for_all x p = + match x with + | Empty -> true + | Leaf {k; v} -> p k v + | Node {l; k; v; r} -> p k v && for_all l p && for_all r p + +let rec exists x p = + match x with + | Empty -> false + | Leaf {k; v} -> p k v + | Node {l; k; v; r} -> p k v || exists l p || exists r p + +(* Beware: those two functions assume that the added k is *strictly* + smaller (or bigger) than all the present keys in the tree; it + does not test for equality with the current min (or max) key. + + Indeed, they are only used during the "join" operation which + respects this precondition. +*) + +let rec add_min k v = function + | Empty -> singleton k v + | Leaf l -> unsafe_two_elements k v l.k l.v + | Node tree -> bal (add_min k v tree.l) tree.k tree.v tree.r + +let rec add_max k v = function + | Empty -> singleton k v + | Leaf l -> unsafe_two_elements l.k l.v k v + | Node tree -> bal tree.l tree.k tree.v (add_max k v tree.r) + +(* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + +let rec join l v d r = + match l with + | Empty -> add_min v d r + | Leaf leaf -> add_min leaf.k leaf.v (add_min v d r) + | Node xl -> ( + match r with + | Empty -> add_max v d l + | Leaf leaf -> add_max leaf.k leaf.v (add_max v d l) + | Node xr -> + let lh = xl.h in + let rh = xr.h in + if lh > rh + 2 then bal xl.l xl.k xl.v (join xl.r v d r) + else if rh > lh + 2 then bal (join l v d xr.l) xr.k xr.v xr.r + else unsafe_node v d l r (calc_height lh rh)) + +(* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + +let concat t1 t2 = + match (t1, t2) with + | Empty, t -> t + | t, Empty -> t + | _, _ -> + let x, d = min_binding_exn t2 in + join t1 x d (remove_min_binding t2) + +let concat_or_join t1 v d t2 = + match d with + | Some d -> join t1 v d t2 + | None -> concat t1 t2 + +module type S = sig + type key + + type +'a t + + val empty : 'a t + + val compare_key : key -> key -> int + + val is_empty : 'a t -> bool + + val mem : 'a t -> key -> bool + + val to_sorted_array : 'a t -> (key * 'a) array + + val to_sorted_array_with_f : 'a t -> (key -> 'a -> 'b) -> 'b array + + val add : 'a t -> key -> 'a -> 'a t + (** [add x y m] + If [x] was already bound in [m], its previous binding disappears. *) + + val adjust : 'a t -> key -> ('a option -> 'a) -> 'a t + (** [adjust acc k replace ] if not exist [add (replace None ], otherwise + [add k v (replace (Some old))] + *) + + val singleton : key -> 'a -> 'a t + + val remove : 'a t -> key -> 'a t + (** [remove x m] returns a map containing the same bindings as + [m], except for [x] which is unbound in the returned map. *) + + (* val merge: + 'a t -> 'b t -> + (key -> 'a option -> 'b option -> 'c option) -> 'c t *) + (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] + and of [m2]. The presence of each such binding, and the corresponding + value, is determined with the function [f]. + @since 3.12.0 + *) + + val disjoint_merge_exn : 'a t -> 'a t -> (key -> 'a -> 'a -> exn) -> 'a t + (* merge two maps, will raise if they have the same key *) + + val iter : 'a t -> (key -> 'a -> unit) -> unit + (** [iter f m] applies [f] to all bindings in map [m]. + The bindings are passed to [f] in increasing order. *) + + val fold : 'a t -> 'b -> (key -> 'a -> 'b -> 'b) -> 'b + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order) *) + + val for_all : 'a t -> (key -> 'a -> bool) -> bool + (** [for_all p m] checks if all the bindings of the map. + order unspecified + *) + + val exists : 'a t -> (key -> 'a -> bool) -> bool + (** [exists p m] checks if at least one binding of the map + satisfy the predicate [p]. + order unspecified + *) + + (* val filter: 'a t -> (key -> 'a -> bool) -> 'a t *) + (** [filter p m] returns the map with all the bindings in [m] + that satisfy predicate [p]. + order unspecified + *) + + (* val partition: 'a t -> (key -> 'a -> bool) -> 'a t * 'a t *) + (** [partition p m] returns a pair of maps [(m1, m2)], where + [m1] contains all the bindings of [s] that satisfy the + predicate [p], and [m2] is the map with all the bindings of + [s] that do not satisfy [p]. + *) + + val cardinal : 'a t -> int + (** Return the number of bindings of a map. *) + + val bindings : 'a t -> (key * 'a) list + (** Return the list of all bindings of the given map. + The returned list is sorted in increasing order with respect + to the ordering *) + + val keys : 'a t -> key list + (* Increasing order *) + + (* val split: 'a t -> key -> 'a t * 'a option * 'a t *) + (** [split x m] returns a triple [(l, data, r)], where + [l] is the map with all the bindings of [m] whose key + is strictly less than [x]; + [r] is the map with all the bindings of [m] whose key + is strictly greater than [x]; + [data] is [None] if [m] contains no binding for [x], + or [Some v] if [m] binds [v] to [x]. + @since 3.12.0 + *) + + val find_exn : 'a t -> key -> 'a + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. *) + + val find_opt : 'a t -> key -> 'a option + + val find_default : 'a t -> key -> 'a -> 'a + + val map : 'a t -> ('a -> 'b) -> 'b t + (** [map f m] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + + val mapi : 'a t -> (key -> 'a -> 'b) -> 'b t + (** Same as {!Map.S.map}, but the function receives as arguments both the + key and the associated value for each binding of the map. *) + + val of_list : (key * 'a) list -> 'a t + + val of_array : (key * 'a) array -> 'a t + + val add_list : (key * 'b) list -> 'b t -> 'b t +end diff --git a/jscomp/ext/map_gen.mli b/compiler/ext/map_gen.mli similarity index 95% rename from jscomp/ext/map_gen.mli rename to compiler/ext/map_gen.mli index 4ecd007..c5038ff 100644 --- a/jscomp/ext/map_gen.mli +++ b/compiler/ext/map_gen.mli @@ -1,7 +1,7 @@ type ('key, +'a) t = private | Empty - | Leaf of { k : 'key; v : 'a } - | Node of { l : ('key, 'a) t; k : 'key; v : 'a; r : ('key, 'a) t; h : int } + | Leaf of {k: 'key; v: 'a} + | Node of {l: ('key, 'a) t; k: 'key; v: 'a; r: ('key, 'a) t; h: int} val cardinal : ('a, 'b) t -> int @@ -22,10 +22,8 @@ val height : ('a, 'b) t -> int val singleton : 'a -> 'b -> ('a, 'b) t val unsafe_node : 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t -> int -> ('a, 'b) t - [@@inline] val unsafe_two_elements : 'a -> 'b -> 'a -> 'b -> ('a, 'b) t - [@@inline] (** smaller comes first *) val bal : ('a, 'b) t -> 'a -> 'b -> ('a, 'b) t -> ('a, 'b) t diff --git a/jscomp/ext/map_ident.mli b/compiler/ext/map_ident.mli similarity index 96% rename from jscomp/ext/map_ident.mli rename to compiler/ext/map_ident.mli index f4e717e..56b3678 100644 --- a/jscomp/ext/map_ident.mli +++ b/compiler/ext/map_ident.mli @@ -22,4 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -include Map_gen.S with type key = Ident.t \ No newline at end of file +include Map_gen.S with type key = Ident.t diff --git a/jscomp/ext/map_int.mli b/compiler/ext/map_int.mli similarity index 100% rename from jscomp/ext/map_int.mli rename to compiler/ext/map_int.mli diff --git a/jscomp/ext/map_string.mli b/compiler/ext/map_string.mli similarity index 100% rename from jscomp/ext/map_string.mli rename to compiler/ext/map_string.mli diff --git a/compiler/ext/misc.ml b/compiler/ext/misc.ml new file mode 100644 index 0000000..d63856a --- /dev/null +++ b/compiler/ext/misc.ml @@ -0,0 +1,583 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Errors *) + +exception Fatal_error + +let fatal_error msg = + prerr_string ">> Fatal error: "; + prerr_endline msg; + raise Fatal_error + +let fatal_errorf fmt = Format.kasprintf fatal_error fmt + +(* Exceptions *) + +let try_finally work cleanup = + let result = + try work () + with e -> + cleanup (); + raise e + in + cleanup (); + result + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +let protect_refs = + let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in + fun refs f -> + let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in + set_refs refs; + match f () with + | x -> + set_refs backup; + x + | exception e -> + set_refs backup; + raise e + +(* List functions *) + +let rec map_end f l1 l2 = + match l1 with + | [] -> l2 + | hd :: tl -> f hd :: map_end f tl l2 + +let rec map_left_right f = function + | [] -> [] + | hd :: tl -> + let res = f hd in + res :: map_left_right f tl + +let rec for_all2 pred l1 l2 = + match (l1, l2) with + | [], [] -> true + | hd1 :: tl1, hd2 :: tl2 -> pred hd1 hd2 && for_all2 pred tl1 tl2 + | _, _ -> false + +let rec replicate_list elem n = + if n <= 0 then [] else elem :: replicate_list elem (n - 1) + +let rec list_remove x = function + | [] -> [] + | hd :: tl -> if hd = x then tl else hd :: list_remove x tl + +let rec split_last = function + | [] -> assert false + | [x] -> ([], x) + | hd :: tl -> + let lst, last = split_last tl in + (hd :: lst, last) + +let may = Stdlib.Option.iter +let may_map = Stdlib.Option.map + +(* File functions *) + +let find_in_path path name = + if not (Filename.is_implicit name) then + if Sys.file_exists name then name else raise Not_found + else + let rec try_dir = function + | [] -> raise Not_found + | dir :: rem -> + let fullname = Filename.concat dir name in + if Sys.file_exists fullname then fullname else try_dir rem + in + try_dir path + +let find_in_path_rel path name = + let rec simplify s = + let open Filename in + let base = basename s in + let dir = dirname s in + if dir = s then dir + else if base = current_dir_name then simplify dir + else concat (simplify dir) base + in + let rec try_dir = function + | [] -> raise Not_found + | dir :: rem -> + let fullname = simplify (Filename.concat dir name) in + if Sys.file_exists fullname then fullname else try_dir rem + in + try_dir path + +let find_in_path_uncap path name = + let uname = String.uncapitalize_ascii name in + let rec try_dir = function + | [] -> raise Not_found + | dir :: rem -> + let fullname = Filename.concat dir name + and ufullname = Filename.concat dir uname in + if Sys.file_exists ufullname then ufullname + else if Sys.file_exists fullname then fullname + else try_dir rem + in + try_dir path + +let remove_file filename = + try if Sys.file_exists filename then Sys.remove filename + with Sys_error _msg -> () + +(* Expand a -I option: if it starts with +, make it relative to the standard + library directory *) + +let expand_directory alt s = + if String.length s > 0 && s.[0] = '+' then + Filename.concat alt (String.sub s 1 (String.length s - 1)) + else s + +(* Hashtable functions *) + +let create_hashtable init = + let size = Array.length init in + let tbl = Hashtbl.create size in + Array.iter (fun (key, data) -> Hashtbl.add tbl key data) init; + tbl + +(* File copy *) + +let copy_file ic oc = + let buff = Bytes.create 0x1000 in + let rec copy () = + let n = input ic buff 0 0x1000 in + if n = 0 then () + else ( + output oc buff 0 n; + copy ()) + in + copy () + +let copy_file_chunk ic oc len = + let buff = Bytes.create 0x1000 in + let rec copy n = + if n <= 0 then () + else + let r = input ic buff 0 (min n 0x1000) in + if r = 0 then raise End_of_file + else ( + output oc buff 0 r; + copy (n - r)) + in + copy len + +let string_of_file ic = + let b = Buffer.create 0x10000 in + let buff = Bytes.create 0x1000 in + let rec copy () = + let n = input ic buff 0 0x1000 in + if n = 0 then Buffer.contents b + else ( + Buffer.add_subbytes b buff 0 n; + copy ()) + in + copy () + +let output_to_bin_file_directly filename fn = + let oc = open_out_bin filename in + match fn filename oc with + | v -> + close_out oc; + v + | exception e -> + close_out oc; + raise e + +let output_to_file_via_temporary ?(mode = [Open_text]) filename fn = + let temp_filename, oc = + Filename.open_temp_file ~mode ~perms:0o666 + ~temp_dir:(Filename.dirname filename) + (Filename.basename filename) + ".tmp" + in + (* The 0o666 permissions will be modified by the umask. It's just + like what [open_out] and [open_out_bin] do. + With temp_dir = dirname filename, we ensure that the returned + temp file is in the same directory as filename itself, making + it safe to rename temp_filename to filename later. + With prefix = basename filename, we are almost certain that + the first generated name will be unique. A fixed prefix + would work too but might generate more collisions if many + files are being produced simultaneously in the same directory. *) + match fn temp_filename oc with + | res -> ( + close_out oc; + try + Sys.rename temp_filename filename; + res + with exn -> + remove_file temp_filename; + raise exn) + | exception exn -> + close_out oc; + remove_file temp_filename; + raise exn + +(* Integer operations *) + +let rec log2 n = if n <= 1 then 0 else 1 + log2 (n asr 1) + +let align n a = if n >= 0 then (n + a - 1) land -a else n land -a + +let no_overflow_add a b = a lxor b lor (a lxor lnot (a + b)) < 0 + +let no_overflow_sub a b = a lxor lnot b lor (b lxor (a - b)) < 0 + +let no_overflow_mul a b = b <> 0 && a * b / b = a + +let no_overflow_lsl a k = + 0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k + +module Int_literal_converter = struct + (* To convert integer literals, allowing max_int + 1 (PR#4210) *) + let cvt_int_aux str neg of_string = + if String.length str = 0 || str.[0] = '-' then of_string str + else neg (of_string ("-" ^ str)) + let int s = cvt_int_aux s ( ~- ) int_of_string + let int32 s = cvt_int_aux s Int32.neg Int32.of_string + let int64 s = cvt_int_aux s Int64.neg Int64.of_string +end + +(* String operations *) + +let chop_extensions file = + let dirname = Filename.dirname file and basename = Filename.basename file in + try + let pos = String.index basename '.' in + let basename = String.sub basename 0 pos in + if Filename.is_implicit file && dirname = Filename.current_dir_name then + basename + else Filename.concat dirname basename + with Not_found -> file + +let search_substring pat str start = + let rec search i j = + if j >= String.length pat then i + else if i + j >= String.length str then raise Not_found + else if str.[i + j] = pat.[j] then search i (j + 1) + else search (i + 1) 0 + in + search start 0 + +let replace_substring ~before ~after str = + let rec search acc curr = + match search_substring before str curr with + | next -> + let prefix = String.sub str curr (next - curr) in + search (prefix :: acc) (next + String.length before) + | exception Not_found -> + let suffix = String.sub str curr (String.length str - curr) in + List.rev (suffix :: acc) + in + String.concat after (search [] 0) + +let rev_split_words s = + let rec split1 res i = + if i >= String.length s then res + else + match s.[i] with + | ' ' | '\t' | '\r' | '\n' -> split1 res (i + 1) + | _ -> split2 res i (i + 1) + and split2 res i j = + if j >= String.length s then String.sub s i (j - i) :: res + else + match s.[j] with + | ' ' | '\t' | '\r' | '\n' -> + split1 (String.sub s i (j - i) :: res) (j + 1) + | _ -> split2 res i (j + 1) + in + split1 [] 0 + +let get_ref r = + let v = !r in + r := []; + v + +let fst3 (x, _, _) = x +let snd3 (_, x, _) = x +let thd3 (_, _, x) = x + +let fst4 (x, _, _, _) = x +let snd4 (_, x, _, _) = x +let thd4 (_, _, x, _) = x +let for4 (_, _, _, x) = x + +let edit_distance a b cutoff = + let la, lb = (String.length a, String.length b) in + let cutoff = + (* using max_int for cutoff would cause overflows in (i + cutoff + 1); + we bring it back to the (max la lb) worstcase *) + min (max la lb) cutoff + in + if abs (la - lb) > cutoff then None + else + (* initialize with 'cutoff + 1' so that not-yet-written-to cases have + the worst possible cost; this is useful when computing the cost of + a case just at the boundary of the cutoff diagonal. *) + let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in + m.(0).(0) <- 0; + for i = 1 to la do + m.(i).(0) <- i + done; + for j = 1 to lb do + m.(0).(j) <- j + done; + for i = 1 to la do + for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do + let cost = if a.[i - 1] = b.[j - 1] then 0 else 1 in + let best = + (* insert, delete or substitute *) + min (1 + min m.(i - 1).(j) m.(i).(j - 1)) (m.(i - 1).(j - 1) + cost) + in + let best = + (* swap two adjacent letters; we use "cost" again in case of + a swap between two identical letters; this is slightly + redundant as this is a double-substitution case, but it + was done this way in most online implementations and + imitation has its virtues *) + if + not + (i > 1 && j > 1 && a.[i - 1] = b.[j - 2] && a.[i - 2] = b.[j - 1]) + then best + else min best (m.(i - 2).(j - 2) + cost) + in + m.(i).(j) <- best + done + done; + let result = m.(la).(lb) in + if result > cutoff then None else Some result + +let spellcheck env name = + let cutoff = + match String.length name with + | 1 | 2 -> 0 + | 3 | 4 -> 1 + | 5 | 6 -> 2 + | _ -> 3 + in + let compare target acc head = + match edit_distance target head cutoff with + | None -> acc + | Some dist -> + let best_choice, best_dist = acc in + if dist < best_dist then ([head], dist) + else if dist = best_dist then (head :: best_choice, dist) + else acc + in + fst (List.fold_left (compare name) ([], max_int) env) + +let did_you_mean ppf get_choices = + (* flush now to get the error report early, in the (unheard of) case + where the search in the get_choices function would take a bit of + time; in the worst case, the user has seen the error, she can + interrupt the process before the spell-checking terminates. *) + Format.fprintf ppf "@?"; + match get_choices () with + | [] -> () + | choices -> + let rest, last = split_last choices in + Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?" + (String.concat ", " rest) + (if rest = [] then "" else " or ") + last + +let cut_at s c = + let pos = String.index s c in + (String.sub s 0 pos, String.sub s (pos + 1) (String.length s - pos - 1)) + +module StringSet = Set.Make (struct + type t = string + let compare = compare +end) +module StringMap = Map.Make (struct + type t = string + let compare = compare +end) + +(* Color handling *) +module Color = struct + (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) + type color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + + type style = + | FG of color (* foreground *) + | BG of color (* background *) + | Bold + | Reset + | Dim + + let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" + + let code_of_style = function + | FG c -> "3" ^ ansi_of_color c + | BG c -> "4" ^ ansi_of_color c + | Bold -> "1" + | Reset -> "0" + | Dim -> "2" + + let ansi_of_style_l l = + let s = + match l with + | [] -> code_of_style Reset + | [s] -> code_of_style s + | _ -> String.concat ";" (List.map code_of_style l) + in + "\x1b[" ^ s ^ "m" + + type styles = {error: style list; warning: style list; loc: style list} + + let default_styles = + {warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]} + + let cur_styles = ref default_styles + let get_styles () = !cur_styles + let set_styles s = cur_styles := s + + (* map a tag to a style, if the tag is known. + @raise Not_found otherwise *) + let style_of_tag s = + match s with + | Format.String_tag "error" -> !cur_styles.error + | Format.String_tag "warning" -> !cur_styles.warning + | Format.String_tag "loc" -> !cur_styles.loc + | Format.String_tag "info" -> [Bold; FG Yellow] + | Format.String_tag "dim" -> [Dim] + | Format.String_tag "filename" -> [FG Cyan] + | _ -> raise Not_found + + let color_enabled = ref true + + (* either prints the tag of [s] or delegates to [or_else] *) + let mark_open_tag ~or_else s = + try + let style = style_of_tag s in + if !color_enabled then ansi_of_style_l style else "" + with Not_found -> or_else s + + let mark_close_tag ~or_else s = + try + let _ = style_of_tag s in + if !color_enabled then ansi_of_style_l [Reset] else "" + with Not_found -> or_else s + + (* add color handling to formatter [ppf] *) + let set_color_tag_handling ppf = + let open Format in + let functions = pp_get_formatter_stag_functions ppf () in + let functions' = + { + functions with + mark_open_stag = mark_open_tag ~or_else:functions.mark_open_stag; + mark_close_stag = mark_close_tag ~or_else:functions.mark_close_stag; + } + in + pp_set_mark_tags ppf true; + (* enable tags *) + pp_set_formatter_stag_functions ppf functions'; + (* also setup margins *) + pp_set_margin ppf (pp_get_margin std_formatter ()); + () + + external isatty : out_channel -> bool = "caml_sys_isatty" + + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" && term <> "" && isatty stderr + + type setting = Auto | Always | Never + + let setup = + let first = ref true in + (* initialize only once *) + let formatter_l = + [Format.std_formatter; Format.err_formatter; Format.str_formatter] + in + fun o -> + if !first then ( + first := false; + Format.set_mark_tags true; + List.iter set_color_tag_handling formatter_l; + color_enabled := + match o with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()); + () +end + +let normalise_eol s = + let b = Buffer.create 80 in + for i = 0 to String.length s - 1 do + if s.[i] <> '\r' then Buffer.add_char b s.[i] + done; + Buffer.contents b + +let delete_eol_spaces src = + let len_src = String.length src in + let dst = Bytes.create len_src in + let rec loop i_src i_dst = + if i_src = len_src then i_dst + else + match src.[i_src] with + | ' ' | '\t' -> loop_spaces 1 (i_src + 1) i_dst + | c -> + Bytes.set dst i_dst c; + loop (i_src + 1) (i_dst + 1) + and loop_spaces spaces i_src i_dst = + if i_src = len_src then i_dst + else + match src.[i_src] with + | ' ' | '\t' -> loop_spaces (spaces + 1) (i_src + 1) i_dst + | '\n' -> + Bytes.set dst i_dst '\n'; + loop (i_src + 1) (i_dst + 1) + | _ -> + for n = 0 to spaces do + Bytes.set dst (i_dst + n) src.[i_src - spaces + n] + done; + loop (i_src + 1) (i_dst + spaces + 1) + in + let stop = loop 0 0 in + Bytes.sub_string dst 0 stop + +type hook_info = {sourcefile: string} + +exception + HookExnWrapper of {error: exn; hook_name: string; hook_info: hook_info} + +exception HookExn of exn + +let raise_direct_hook_exn e = raise (HookExn e) + +module type HookSig = sig + type t + + val add_hook : string -> (hook_info -> t -> t) -> unit + val apply_hooks : hook_info -> t -> t +end diff --git a/compiler/ext/misc.mli b/compiler/ext/misc.mli new file mode 100644 index 0000000..8e4a1cb --- /dev/null +++ b/compiler/ext/misc.mli @@ -0,0 +1,278 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Miscellaneous useful types and functions *) + +val fatal_error : string -> 'a +val fatal_errorf : ('a, Format.formatter, unit, 'b) format4 -> 'a +exception Fatal_error + +val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a + +val map_end : ('a -> 'b) -> 'a list -> 'b list -> 'b list +(* [map_end f l t] is [map f l @ t], just more efficient. *) + +val map_left_right : ('a -> 'b) -> 'a list -> 'b list +(* Like [List.map], with guaranteed left-to-right evaluation order *) + +val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool +(* Same as [List.for_all] but for a binary predicate. + In addition, this [for_all2] never fails: given two lists + with different lengths, it returns false. *) + +val replicate_list : 'a -> int -> 'a list +(* [replicate_list elem n] is the list with [n] elements + all identical to [elem]. *) + +val list_remove : 'a -> 'a list -> 'a list +(* [list_remove x l] returns a copy of [l] with the first + element equal to [x] removed. *) + +val split_last : 'a list -> 'a list * 'a +(* Return the last element and the other elements of the given list. *) + +val may : ('a -> unit) -> 'a option -> unit +val may_map : ('a -> 'b) -> 'a option -> 'b option + +type ref_and_value = R : 'a ref * 'a -> ref_and_value + +val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a +(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l] + while executing [f]. The previous contents of the references is restored + even if [f] raises an exception. *) + +val find_in_path : string list -> string -> string +(* Search a file in a list of directories. *) + +val find_in_path_rel : string list -> string -> string +(* Search a relative file in a list of directories. *) + +val find_in_path_uncap : string list -> string -> string +(* Same, but search also for uncapitalized name, i.e. + if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml + to match. *) + +val remove_file : string -> unit +(* Delete the given file if it exists. Never raise an error. *) + +val expand_directory : string -> string -> string +(* [expand_directory alt file] eventually expands a [+] at the + beginning of file into [alt] (an alternate root directory) *) + +val create_hashtable : ('a * 'b) array -> ('a, 'b) Hashtbl.t +(* Create a hashtable of the given size and fills it with the + given bindings. *) + +val copy_file : in_channel -> out_channel -> unit +(* [copy_file ic oc] reads the contents of file [ic] and copies + them to [oc]. It stops when encountering EOF on [ic]. *) + +val copy_file_chunk : in_channel -> out_channel -> int -> unit +(* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies + them to [oc]. It raises [End_of_file] when encountering + EOF on [ic]. *) + +val string_of_file : in_channel -> string +(* [string_of_file ic] reads the contents of file [ic] and copies + them to a string. It stops when encountering EOF on [ic]. *) + +val output_to_bin_file_directly : string -> (string -> out_channel -> 'a) -> 'a + +val output_to_file_via_temporary : + ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a +(* Produce output in temporary file, then rename it + (as atomically as possible) to the desired output file name. + [output_to_file_via_temporary filename fn] opens a temporary file + which is passed to [fn] (name + output channel). When [fn] returns, + the channel is closed and the temporary file is renamed to + [filename]. *) + +val log2 : int -> int +(* [log2 n] returns [s] such that [n = 1 lsl s] + if [n] is a power of 2*) + +val align : int -> int -> int +(* [align n a] rounds [n] upwards to a multiple of [a] + (a power of 2). *) + +val no_overflow_add : int -> int -> bool +(* [no_overflow_add n1 n2] returns [true] if the computation of + [n1 + n2] does not overflow. *) + +val no_overflow_sub : int -> int -> bool +(* [no_overflow_sub n1 n2] returns [true] if the computation of + [n1 - n2] does not overflow. *) + +val no_overflow_mul : int -> int -> bool +(* [no_overflow_mul n1 n2] returns [true] if the computation of + [n1 * n2] does not overflow. *) + +val no_overflow_lsl : int -> int -> bool +(* [no_overflow_lsl n k] returns [true] if the computation of + [n lsl k] does not overflow. *) + +module Int_literal_converter : sig + val int : string -> int + val int32 : string -> int32 + val int64 : string -> int64 +end + +val chop_extensions : string -> string +(* Return the given file name without its extensions. The extensions + is the longest suffix starting with a period and not including + a directory separator, [.xyz.uvw] for instance. + + Return the given name if it does not contain an extension. *) + +val search_substring : string -> string -> int -> int +(* [search_substring pat str start] returns the position of the first + occurrence of string [pat] in string [str]. Search starts + at offset [start] in [str]. Raise [Not_found] if [pat] + does not occur. *) + +val replace_substring : before:string -> after:string -> string -> string +(* [replace_substring ~before ~after str] replaces all + occurrences of [before] with [after] in [str] and returns + the resulting string. *) + +val rev_split_words : string -> string list +(* [rev_split_words s] splits [s] in blank-separated words, and returns + the list of words in reverse order. *) + +val get_ref : 'a list ref -> 'a list +(* [get_ref lr] returns the content of the list reference [lr] and reset + its content to the empty list. *) + +val fst3 : 'a * 'b * 'c -> 'a +val snd3 : 'a * 'b * 'c -> 'b +val thd3 : 'a * 'b * 'c -> 'c + +val fst4 : 'a * 'b * 'c * 'd -> 'a +val snd4 : 'a * 'b * 'c * 'd -> 'b +val thd4 : 'a * 'b * 'c * 'd -> 'c +val for4 : 'a * 'b * 'c * 'd -> 'd + +val edit_distance : string -> string -> int -> int option +(** [edit_distance a b cutoff] computes the edit distance between + strings [a] and [b]. To help efficiency, it uses a cutoff: if the + distance [d] is smaller than [cutoff], it returns [Some d], else + [None]. + + The distance algorithm currently used is Damerau-Levenshtein: it + computes the number of insertion, deletion, substitution of + letters, or swapping of adjacent letters to go from one word to the + other. The particular algorithm may change in the future. +*) + +val spellcheck : string list -> string -> string list +(** [spellcheck env name] takes a list of names [env] that exist in + the current environment and an erroneous [name], and returns a + list of suggestions taken from [env], that are close enough to + [name] that it may be a typo for one of them. *) + +val did_you_mean : Format.formatter -> (unit -> string list) -> unit +(** [did_you_mean ppf get_choices] hints that the user may have meant + one of the option returned by calling [get_choices]. It does nothing + if the returned list is empty. + + The [unit -> ...] thunking is meant to delay any potentially-slow + computation (typically computing edit-distance with many things + from the current environment) to when the hint message is to be + printed. You should print an understandable error message before + calling [did_you_mean], so that users get a clear notification of + the failure even if producing the hint is slow. +*) + +val cut_at : string -> char -> string * string +(** [String.cut_at s c] returns a pair containing the sub-string before + the first occurrence of [c] in [s], and the sub-string after the + first occurrence of [c] in [s]. + [let (before, after) = String.cut_at s c in + before ^ String.make 1 c ^ after] is the identity if [s] contains [c]. + + Raise [Not_found] if the character does not appear in the string + @since 4.01 +*) + +module StringSet : Set.S with type elt = string +module StringMap : Map.S with type key = string +(* TODO: replace all custom instantiations of StringSet/StringMap in various + compiler modules with this one. *) + +(* Color handling *) +module Color : sig + type color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + + type style = + | FG of color (* foreground *) + | BG of color (* background *) + | Bold + | Reset + | Dim + + val ansi_of_style_l : style list -> string + (* ANSI escape sequence for the given style *) + + type styles = {error: style list; warning: style list; loc: style list} + + val default_styles : styles + val get_styles : unit -> styles + val set_styles : styles -> unit + + type setting = Auto | Always | Never + + val setup : setting option -> unit + (* [setup opt] will enable or disable color handling on standard formatters + according to the value of color setting [opt]. + Only the first call to this function has an effect. *) + + val set_color_tag_handling : Format.formatter -> unit + (* adds functions to support color tags to the given formatter. *) +end + +val normalise_eol : string -> string +(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters + removed. Intended for pre-processing text which will subsequently be printed + on a channel which performs EOL transformations (i.e. Windows) *) + +val delete_eol_spaces : string -> string +(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of + line spaces removed. Intended to normalize the output of the + toplevel for tests. *) + +(** {1 Hook machinery} + + Hooks machinery: + [add_hook name f] will register a function that will be called on the + argument of a later call to [apply_hooks]. Hooks are applied in the + lexicographical order of their names. +*) + +type hook_info = {sourcefile: string} + +exception + HookExnWrapper of {error: exn; hook_name: string; hook_info: hook_info} +(** An exception raised by a hook will be wrapped into a + [HookExnWrapper] constructor by the hook machinery. *) + +val raise_direct_hook_exn : exn -> 'a +(** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will + not be wrapped into a {!HookExnWrapper}. *) + +module type HookSig = sig + type t + val add_hook : string -> (hook_info -> t -> t) -> unit + val apply_hooks : hook_info -> t -> t +end diff --git a/jscomp/ext/ordered_hash_map.cppo.ml b/compiler/ext/ordered_hash_map.cppo.ml similarity index 100% rename from jscomp/ext/ordered_hash_map.cppo.ml rename to compiler/ext/ordered_hash_map.cppo.ml diff --git a/jscomp/ext/ordered_hash_map_gen.ml b/compiler/ext/ordered_hash_map_gen.ml similarity index 84% rename from jscomp/ext/ordered_hash_map_gen.ml rename to compiler/ext/ordered_hash_map_gen.ml index 31ad7e6..b85ce6e 100644 --- a/jscomp/ext/ordered_hash_map_gen.ml +++ b/compiler/ext/ordered_hash_map_gen.ml @@ -62,19 +62,19 @@ end when buckets become too long. *) type ('a, 'b) bucket = | Empty - | Cons of { key : 'a; ord : int; data : 'b; next : ('a, 'b) bucket } + | Cons of {key: 'a; ord: int; data: 'b; next: ('a, 'b) bucket} type ('a, 'b) t = { - mutable size : int; + mutable size: int; (* number of entries *) - mutable data : ('a, 'b) bucket array; + mutable data: ('a, 'b) bucket array; (* the buckets *) - initial_size : int; (* initial array size *) + initial_size: int; (* initial array size *) } let create initial_size = let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } + {initial_size = s; size = 0; data = Array.make s Empty} let clear h = h.size <- 0; @@ -99,11 +99,11 @@ let resize indexfun h = (* so that indexfun sees the new bucket count *) let rec insert_bucket = function | Empty -> () - | Cons { key; ord; data; next } -> - let nidx = indexfun h key in - Array.unsafe_set ndata nidx - (Cons { key; ord; data; next = Array.unsafe_get ndata nidx }); - insert_bucket next + | Cons {key; ord; data; next} -> + let nidx = indexfun h key in + Array.unsafe_set ndata nidx + (Cons {key; ord; data; next = Array.unsafe_get ndata nidx}); + insert_bucket next in for i = 0 to osize - 1 do insert_bucket (Array.unsafe_get odata i) @@ -112,9 +112,9 @@ let resize indexfun h = let iter h f = let rec do_bucket = function | Empty -> () - | Cons { key; ord; data; next } -> - f key data ord; - do_bucket next + | Cons {key; ord; data; next} -> + f key data ord; + do_bucket next in let d = h.data in for i = 0 to Array.length d - 1 do @@ -127,7 +127,7 @@ let choose h = else match Array.unsafe_get arr offset with | Empty -> aux arr (offset + 1) len - | Cons { key = k; _ } -> k + | Cons {key = k; _} -> k in aux h.data 0 (Array.length h.data) @@ -143,7 +143,7 @@ let fold h init f = let rec do_bucket b accu = match b with | Empty -> accu - | Cons { key; ord; data; next } -> do_bucket next (f key data ord accu) + | Cons {key; ord; data; next} -> do_bucket next (f key data ord accu) in let d = h.data in let accu = ref init in @@ -155,4 +155,6 @@ let fold h init f = let elements set = fold set [] (fun k _ _ acc -> k :: acc) let rec bucket_length acc (x : _ bucket) = - match x with Empty -> 0 | Cons rhs -> bucket_length (acc + 1) rhs.next + match x with + | Empty -> 0 + | Cons rhs -> bucket_length (acc + 1) rhs.next diff --git a/jscomp/ext/ordered_hash_map_local_ident.mli b/compiler/ext/ordered_hash_map_local_ident.mli similarity index 99% rename from jscomp/ext/ordered_hash_map_local_ident.mli rename to compiler/ext/ordered_hash_map_local_ident.mli index c22d678..66af1d0 100644 --- a/jscomp/ext/ordered_hash_map_local_ident.mli +++ b/compiler/ext/ordered_hash_map_local_ident.mli @@ -22,9 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - +include Ordered_hash_map_gen.S with type key = Ident.t (** Hash algorithm only hash stamp, this makes sense when all identifiers are local (no global) *) -include Ordered_hash_map_gen.S with type key = Ident.t diff --git a/compiler/ext/primitive_modules.ml b/compiler/ext/primitive_modules.ml new file mode 100644 index 0000000..b11bc87 --- /dev/null +++ b/compiler/ext/primitive_modules.ml @@ -0,0 +1,55 @@ +(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript + * + * This program is free software: you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, either version 3 of the License, or + * (at your option) any later version. + * + * In addition to the permissions granted to you by the LGPL, you may combine + * or link a "work that uses the Library" with a publicly distributed version + * of this file to produce a combined library or application, then distribute + * that combined work under the terms of your choosing, with no requirement + * to comply with the obligations normally placed on you by section 4 of the + * LGPL version 3 (or the corresponding section of a later version of the LGPL + * should you choose to use a later version). + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + +let bool = "Primitive_bool" + +let int = "Primitive_int" + +let float = "Primitive_float" + +let bigint = "Primitive_bigint" + +let string = "Primitive_string" + +let array = "Primitive_array" + +let dict = "Primitive_dict" + +let object_ = "Primitive_object" + +let promise = "Primitive_promise" + +let module_ = "Primitive_module" + +let option = "Primitive_option" + +let hash = "Primitive_hash" + +let exceptions = "Primitive_exceptions" + +let curry = "Primitive_curry" + +let util = "Primitive_util" + +let pervasives = "Pervasives" diff --git a/compiler/ext/runtime_package.ml b/compiler/ext/runtime_package.ml new file mode 100644 index 0000000..34d4afd --- /dev/null +++ b/compiler/ext/runtime_package.ml @@ -0,0 +1,29 @@ +let name = "@rescript/runtime" + +(* Simple default approach to find the runtime package path. This will not work with all package managers/layouts. *) +let default_path = + let build_path rest path = + String.concat Filename.dir_sep (List.rev_append rest path) + in + match + Sys.executable_name |> Filename.dirname + |> String.split_on_char Filename.dir_sep.[0] + |> List.rev + with + (* 1. Packages installed via npm + - bin: node_modules/@rescript/{platform}/bin + - runtime: node_modules/@rescript/runtime + *) + | "bin" :: _platform :: "@rescript" :: "node_modules" :: rest -> + build_path rest ["node_modules"; "@rescript"; "runtime"] + (* 2. Several other cases that can occur in local development, e.g. + - bin: /packages/@rescript/{platform}/bin, /_build/install/default/bin + - runtime: /packages/@rescript/runtime + *) + | _ :: _ :: _ :: _ :: rest -> + build_path rest ["packages"; "@rescript"; "runtime"] + | _ -> "" + +(* To support pnpm and other package managers/layouts, we determine the path on the JS side and pass it in +via -runtime-path to override the default. *) +let path = ref default_path diff --git a/compiler/ext/runtime_package.mli b/compiler/ext/runtime_package.mli new file mode 100644 index 0000000..cf7cc9f --- /dev/null +++ b/compiler/ext/runtime_package.mli @@ -0,0 +1,2 @@ +val name : string +val path : string ref diff --git a/jscomp/ext/set.cppo.ml b/compiler/ext/set.cppo.ml similarity index 100% rename from jscomp/ext/set.cppo.ml rename to compiler/ext/set.cppo.ml diff --git a/compiler/ext/set_gen.ml b/compiler/ext/set_gen.ml new file mode 100644 index 0000000..0fd5e66 --- /dev/null +++ b/compiler/ext/set_gen.ml @@ -0,0 +1,362 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) +[@@@warnerror "+55"] + +(* balanced tree based on stdlib distribution *) + +type 'a t0 = Empty | Leaf of 'a | Node of {l: 'a t0; v: 'a; r: 'a t0; h: int} + +type 'a partial_node = {l: 'a t0; v: 'a; r: 'a t0; h: int} + +external ( ~! ) : 'a t0 -> 'a partial_node = "%identity" + +let empty = Empty + +let[@inline] height = function + | Empty -> 0 + | Leaf _ -> 1 + | Node {h} -> h + +let[@inline] calc_height a b = (if a >= b then a else b) + 1 + +(* + Invariants: + 1. {[ l < v < r]} + 2. l and r balanced + 3. [height l] - [height r] <= 2 +*) +let[@inline] unsafe_node v l r h = Node {l; v; r; h} + +let[@inline] unsafe_node_maybe_leaf v l r h = + if h = 1 then Leaf v else Node {l; v; r; h} + +let[@inline] singleton x = Leaf x + +let[@inline] unsafe_two_elements x v = unsafe_node v (singleton x) empty 2 + +type 'a t = 'a t0 = private + | Empty + | Leaf of 'a + | Node of {l: 'a t0; v: 'a; r: 'a t0; h: int} + +(* Smallest and greatest element of a set *) + +let rec min_exn = function + | Empty -> raise Not_found + | Leaf v -> v + | Node {l; v} -> ( + match l with + | Empty -> v + | Leaf _ | Node _ -> min_exn l) + +let[@inline] is_empty = function + | Empty -> true + | _ -> false + +let rec cardinal_aux acc = function + | Empty -> acc + | Leaf _ -> acc + 1 + | Node {l; r} -> cardinal_aux (cardinal_aux (acc + 1) r) l + +let cardinal s = cardinal_aux 0 s + +let rec elements_aux accu = function + | Empty -> accu + | Leaf v -> v :: accu + | Node {l; v; r} -> elements_aux (v :: elements_aux accu r) l + +let elements s = elements_aux [] s + +let choose = min_exn + +let rec iter x f = + match x with + | Empty -> () + | Leaf v -> f v + | Node {l; v; r} -> + iter l f; + f v; + iter r f + +let rec fold s accu f = + match s with + | Empty -> accu + | Leaf v -> f v accu + | Node {l; v; r} -> fold r (f v (fold l accu f)) f + +let rec for_all x p = + match x with + | Empty -> true + | Leaf v -> p v + | Node {l; v; r} -> p v && for_all l p && for_all r p + +let rec exists x p = + match x with + | Empty -> false + | Leaf v -> p v + | Node {l; v; r} -> p v || exists l p || exists r p + +exception Height_invariant_broken + +exception Height_diff_borken + +let rec check_height_and_diff = function + | Empty -> 0 + | Leaf _ -> 1 + | Node {l; r; h} -> + let hl = check_height_and_diff l in + let hr = check_height_and_diff r in + if h <> calc_height hl hr then raise Height_invariant_broken + else + let diff = abs (hl - hr) in + if diff > 2 then raise Height_diff_borken else h + +let check tree = ignore (check_height_and_diff tree) + +(* Same as create, but performs one step of rebalancing if necessary. + Invariants: + 1. {[ l < v < r ]} + 2. l and r balanced + 3. | height l - height r | <= 3. + + Proof by indunction + + Lemma: the height of [bal l v r] will bounded by [max l r] + 1 +*) +let bal l v r : _ t = + let hl = height l in + let hr = height r in + if hl > hr + 2 then + let {l = ll; r = lr; v = lv; h = _} = ~!l in + let hll = height ll in + let hlr = height lr in + if hll >= hlr then + let hnode = calc_height hlr hr in + unsafe_node lv ll + (unsafe_node_maybe_leaf v lr r hnode) + (calc_height hll hnode) + else + let {l = lrl; r = lrr; v = lrv} = ~!lr in + let hlrl = height lrl in + let hlrr = height lrr in + let hlnode = calc_height hll hlrl in + let hrnode = calc_height hlrr hr in + unsafe_node lrv + (unsafe_node_maybe_leaf lv ll lrl hlnode) + (unsafe_node_maybe_leaf v lrr r hrnode) + (calc_height hlnode hrnode) + else if hr > hl + 2 then + let {l = rl; r = rr; v = rv} = ~!r in + let hrr = height rr in + let hrl = height rl in + if hrr >= hrl then + let hnode = calc_height hl hrl in + unsafe_node rv + (unsafe_node_maybe_leaf v l rl hnode) + rr (calc_height hnode hrr) + else + let {l = rll; r = rlr; v = rlv} = ~!rl in + let hrll = height rll in + let hrlr = height rlr in + let hlnode = calc_height hl hrll in + let hrnode = calc_height hrlr hrr in + unsafe_node rlv + (unsafe_node_maybe_leaf v l rll hlnode) + (unsafe_node_maybe_leaf rv rlr rr hrnode) + (calc_height hlnode hrnode) + else unsafe_node_maybe_leaf v l r (calc_height hl hr) + +let rec remove_min_elt = function + | Empty -> invalid_arg "Set.remove_min_elt" + | Leaf _ -> empty + | Node {l = Empty; r} -> r + | Node {l; v; r} -> bal (remove_min_elt l) v r + +(* + All elements of l must precede the elements of r. + Assume | height l - height r | <= 2. + weak form of [concat] +*) + +let internal_merge l r = + match (l, r) with + | Empty, t -> t + | t, Empty -> t + | _, _ -> bal l (min_exn r) (remove_min_elt r) + +(* Beware: those two functions assume that the added v is *strictly* + smaller (or bigger) than all the present elements in the tree; it + does not test for equality with the current min (or max) element. + Indeed, they are only used during the "join" operation which + respects this precondition. +*) + +let rec add_min v = function + | Empty -> singleton v + | Leaf x -> unsafe_two_elements v x + | Node n -> bal (add_min v n.l) n.v n.r + +let rec add_max v = function + | Empty -> singleton v + | Leaf x -> unsafe_two_elements x v + | Node n -> bal n.l n.v (add_max v n.r) + +(** + Invariants: + 1. l < v < r + 2. l and r are balanced + + Proof by induction + The height of output will be ~~ (max (height l) (height r) + 2) + Also use the lemma from [bal] +*) +let rec internal_join l v r = + match (l, r) with + | Empty, _ -> add_min v r + | _, Empty -> add_max v l + | Leaf lv, Node {h = rh} -> + if rh > 3 then add_min lv (add_min v r) (* FIXME: could inlined *) + else unsafe_node v l r (rh + 1) + | Leaf _, Leaf _ -> unsafe_node v l r 2 + | Node {h = lh}, Leaf rv -> + if lh > 3 then add_max rv (add_max v l) else unsafe_node v l r (lh + 1) + | Node {l = ll; v = lv; r = lr; h = lh}, Node {l = rl; v = rv; r = rr; h = rh} + -> + if lh > rh + 2 then + (* proof by induction: + now [height of ll] is [lh - 1] + *) + bal ll lv (internal_join lr v r) + else if rh > lh + 2 then bal (internal_join l v rl) rv rr + else unsafe_node v l r (calc_height lh rh) + +(* + Required Invariants: + [t1] < [t2] +*) +let internal_concat t1 t2 = + match (t1, t2) with + | Empty, t -> t + | t, Empty -> t + | _, _ -> internal_join t1 (min_exn t2) (remove_min_elt t2) + +let rec partition x p = + match x with + | Empty -> (empty, empty) + | Leaf v -> + let pv = p v in + if pv then (x, empty) else (empty, x) + | Node {l; v; r} -> + (* call [p] in the expected left-to-right order *) + let lt, lf = partition l p in + let pv = p v in + let rt, rf = partition r p in + if pv then (internal_join lt v rt, internal_concat lf rf) + else (internal_concat lt rt, internal_join lf v rf) + +let of_sorted_array l = + let rec sub start n l = + if n = 0 then empty + else if n = 1 then + let x0 = Array.unsafe_get l start in + singleton x0 + else if n = 2 then + let x0 = Array.unsafe_get l start in + let x1 = Array.unsafe_get l (start + 1) in + unsafe_node x1 (singleton x0) empty 2 + else if n = 3 then + let x0 = Array.unsafe_get l start in + let x1 = Array.unsafe_get l (start + 1) in + let x2 = Array.unsafe_get l (start + 2) in + unsafe_node x1 (singleton x0) (singleton x2) 2 + else + let nl = n / 2 in + let left = sub start nl l in + let mid = start + nl in + let v = Array.unsafe_get l mid in + let right = sub (mid + 1) (n - nl - 1) l in + unsafe_node v left right (calc_height (height left) (height right)) + in + sub 0 (Array.length l) l + +let is_ordered ~cmp tree = + let rec is_ordered_min_max tree = + match tree with + | Empty -> `Empty + | Leaf v -> `V (v, v) + | Node {l; v; r} -> ( + match is_ordered_min_max l with + | `No -> `No + | `Empty -> ( + match is_ordered_min_max r with + | `No -> `No + | `Empty -> `V (v, v) + | `V (l, r) -> if cmp v l < 0 then `V (v, r) else `No) + | `V (min_v, max_v) -> ( + match is_ordered_min_max r with + | `No -> `No + | `Empty -> if cmp max_v v < 0 then `V (min_v, v) else `No + | `V (min_v_r, max_v_r) -> + if cmp max_v min_v_r < 0 then `V (min_v, max_v_r) else `No)) + in + is_ordered_min_max tree <> `No + +let invariant ~cmp t = + check t; + is_ordered ~cmp t + +module type S = sig + type elt + + type t + + val empty : t + + val is_empty : t -> bool + + val iter : t -> (elt -> unit) -> unit + + val fold : t -> 'a -> (elt -> 'a -> 'a) -> 'a + + val for_all : t -> (elt -> bool) -> bool + + val exists : t -> (elt -> bool) -> bool + + val singleton : elt -> t + + val cardinal : t -> int + + val elements : t -> elt list + + val choose : t -> elt + + val mem : t -> elt -> bool + + val add : t -> elt -> t + + val remove : t -> elt -> t + + val union : t -> t -> t + + val inter : t -> t -> t + + val diff : t -> t -> t + + val of_list : elt list -> t + + val of_sorted_array : elt array -> t + + val invariant : t -> bool + + val print : Format.formatter -> t -> unit +end diff --git a/jscomp/ext/set_gen.mli b/compiler/ext/set_gen.mli similarity index 94% rename from jscomp/ext/set_gen.mli rename to compiler/ext/set_gen.mli index a1c838c..f3f39f0 100644 --- a/jscomp/ext/set_gen.mli +++ b/compiler/ext/set_gen.mli @@ -1,11 +1,11 @@ type 'a t = private | Empty | Leaf of 'a - | Node of { l : 'a t; v : 'a; r : 'a t; h : int } + | Node of {l: 'a t; v: 'a; r: 'a t; h: int} val empty : 'a t -val is_empty : 'a t -> bool [@@inline] +val is_empty : 'a t -> bool val unsafe_two_elements : 'a -> 'a -> 'a t diff --git a/jscomp/ext/set_ident.mli b/compiler/ext/set_ident.mli similarity index 99% rename from jscomp/ext/set_ident.mli rename to compiler/ext/set_ident.mli index 2209243..49638c9 100644 --- a/jscomp/ext/set_ident.mli +++ b/compiler/ext/set_ident.mli @@ -22,9 +22,4 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - include Set_gen.S with type elt = Ident.t - - - - diff --git a/jscomp/ext/set_int.mli b/compiler/ext/set_int.mli similarity index 100% rename from jscomp/ext/set_int.mli rename to compiler/ext/set_int.mli diff --git a/jscomp/ext/set_string.mli b/compiler/ext/set_string.mli similarity index 100% rename from jscomp/ext/set_string.mli rename to compiler/ext/set_string.mli diff --git a/jscomp/ext/vec.cppo.ml b/compiler/ext/vec.cppo.ml similarity index 100% rename from jscomp/ext/vec.cppo.ml rename to compiler/ext/vec.cppo.ml diff --git a/jscomp/ext/vec.mli b/compiler/ext/vec.mli similarity index 100% rename from jscomp/ext/vec.mli rename to compiler/ext/vec.mli diff --git a/jscomp/ext/vec_gen.ml b/compiler/ext/vec_gen.ml similarity index 100% rename from jscomp/ext/vec_gen.ml rename to compiler/ext/vec_gen.ml diff --git a/jscomp/ext/vec_int.mli b/compiler/ext/vec_int.mli similarity index 100% rename from jscomp/ext/vec_int.mli rename to compiler/ext/vec_int.mli diff --git a/compiler/ext/warnings.ml b/compiler/ext/warnings.ml new file mode 100644 index 0000000..f25b91b --- /dev/null +++ b/compiler/ext/warnings.ml @@ -0,0 +1,692 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 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. *) +(* *) +(**************************************************************************) + +(* When you change this, you need to update the documentation: + - man/ocamlc.m + - man/ocamlopt.m + - manual/manual/cmds/comp.etex + - manual/manual/cmds/native.etex +*) + +type loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +type top_level_unit_help = FunctionCall | Other + +type t = + | Comment_start (* 1 *) + | Comment_not_end (* 2 *) + | Deprecated of string * loc * loc * bool (* 3 *) + | Fragile_match of string (* 4 *) + | Partial_application (* 5 *) + | Method_override of string list (* 7 *) + | Partial_match of string (* 8 *) + | Non_closed_record_pattern of string (* 9 *) + | Statement_type (* 10 *) + | Unused_match (* 11 *) + | Unused_pat (* 12 *) + | Instance_variable_override of string list (* 13 *) + | Illegal_backslash (* 14 *) + | Implicit_public_methods of string list (* 15 *) + | Unerasable_optional_argument (* 16 *) + | Unused_argument (* 20 *) + | Nonreturning_statement (* 21 *) + | Preprocessor of string (* 22 *) + | Useless_record_with (* 23 *) + | Bad_module_name of string (* 24 *) + | All_clauses_guarded (* 8, used to be 25 *) + | Unused_var of string (* 26 *) + | Unused_var_strict of string (* 27 *) + | Wildcard_arg_to_constant_constr (* 28 *) + | Eol_in_string (* 29 *) + | Duplicate_definitions of string * string * string * string (*30 *) + | Unused_value_declaration of string (* 32 *) + | Unused_open of string (* 33 *) + | Unused_type_declaration of string (* 34 *) + | Unused_for_index of string (* 35 *) + | Unused_constructor of string * bool * bool (* 37 *) + | Unused_extension of string * bool * bool * bool (* 38 *) + | Unused_rec_flag (* 39 *) + | Ambiguous_name of string list * string list * bool (* 41 *) + | Nonoptional_label of string (* 43 *) + | Open_shadow_identifier of string * string (* 44 *) + | Open_shadow_label_constructor of string * string (* 45 *) + | Attribute_payload of string * string (* 47 *) + | Eliminated_optional_arguments of string list (* 48 *) + | No_cmi_file of string * string option (* 49 *) + | Bad_docstring of bool (* 50 *) + | Fragile_literal_pattern (* 52 *) + | Misplaced_attribute of string (* 53 *) + | Duplicated_attribute of string (* 54 *) + | Unreachable_case (* 56 *) + | Ambiguous_pattern of string list (* 57 *) + | Unused_module of string (* 60 *) + | Constraint_on_gadt (* 62 *) + | Bs_unused_attribute of string (* 101 *) + | Bs_polymorphic_comparison (* 102 *) + | Bs_ffi_warning of string (* 103 *) + | Bs_derive_warning of string (* 104 *) + | Bs_fragile_external of string (* 105 *) + | Bs_unimplemented_primitive of string (* 106 *) + | Bs_integer_literal_overflow (* 107 *) + | Bs_uninterpreted_delimiters of string (* 108 *) + | Bs_toplevel_expression_unit of + (string * top_level_unit_help) option (* 109 *) + | Bs_todo of string option (* 110 *) + +(* If you remove a warning, leave a hole in the numbering. NEVER change + the numbers of existing warnings. + If you add a new warning, add it at the end with a new number; + do NOT reuse one of the holes. +*) + +let number = function + | Comment_start -> 1 + | Comment_not_end -> 2 + | Deprecated _ -> 3 + | Fragile_match _ -> 4 + | Partial_application -> 5 + | Method_override _ -> 7 + | Partial_match _ -> 8 + | Non_closed_record_pattern _ -> 9 + | Statement_type -> 10 + | Unused_match -> 11 + | Unused_pat -> 12 + | Instance_variable_override _ -> 13 + | Illegal_backslash -> 14 + | Implicit_public_methods _ -> 15 + | Unerasable_optional_argument -> 16 + | Unused_argument -> 20 + | Nonreturning_statement -> 21 + | Preprocessor _ -> 22 + | Useless_record_with -> 23 + | Bad_module_name _ -> 24 + | All_clauses_guarded -> 8 (* used to be 25 *) + | Unused_var _ -> 26 + | Unused_var_strict _ -> 27 + | Wildcard_arg_to_constant_constr -> 28 + | Eol_in_string -> 29 + | Duplicate_definitions _ -> 30 + | Unused_value_declaration _ -> 32 + | Unused_open _ -> 33 + | Unused_type_declaration _ -> 34 + | Unused_for_index _ -> 35 + | Unused_constructor _ -> 37 + | Unused_extension _ -> 38 + | Unused_rec_flag -> 39 + | Ambiguous_name _ -> 41 + | Nonoptional_label _ -> 43 + | Open_shadow_identifier _ -> 44 + | Open_shadow_label_constructor _ -> 45 + | Attribute_payload _ -> 47 + | Eliminated_optional_arguments _ -> 48 + | No_cmi_file _ -> 49 + | Bad_docstring _ -> 50 + | Fragile_literal_pattern -> 52 + | Misplaced_attribute _ -> 53 + | Duplicated_attribute _ -> 54 + | Unreachable_case -> 56 + | Ambiguous_pattern _ -> 57 + | Unused_module _ -> 60 + | Constraint_on_gadt -> 62 + | Bs_unused_attribute _ -> 101 + | Bs_polymorphic_comparison -> 102 + | Bs_ffi_warning _ -> 103 + | Bs_derive_warning _ -> 104 + | Bs_fragile_external _ -> 105 + | Bs_unimplemented_primitive _ -> 106 + | Bs_integer_literal_overflow -> 107 + | Bs_uninterpreted_delimiters _ -> 108 + | Bs_toplevel_expression_unit _ -> 109 + | Bs_todo _ -> 110 + +let last_warning_number = 110 + +let letter_all = + let rec loop i = if i = 0 then [] else i :: loop (i - 1) in + loop last_warning_number + +(* Must be the max number returned by the [number] function. *) + +let letter = function + | 'a' -> letter_all + | 'b' -> [] + | 'c' -> [1; 2] + | 'd' -> [3] + | 'e' -> [4] + | 'f' -> [5] + | 'g' -> [] + | 'h' -> [] + | 'i' -> [] + | 'j' -> [] + | 'k' -> [32; 33; 34; 35; 36; 37; 38; 39] + | 'l' -> [6] + | 'm' -> [7] + | 'n' -> [] + | 'o' -> [] + | 'p' -> [8] + | 'q' -> [] + | 'r' -> [9] + | 's' -> [10] + | 't' -> [] + | 'u' -> [11; 12] + | 'v' -> [13] + | 'w' -> [] + | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30] + | 'y' -> [26] + | 'z' -> [27] + | _ -> assert false + +type state = {active: bool array; error: bool array} + +let current = + ref + { + active = Array.make (last_warning_number + 1) true; + error = Array.make (last_warning_number + 1) false; + } + +let disabled = ref false + +let without_warnings f = Misc.protect_refs [Misc.R (disabled, true)] f + +let backup () = !current + +let restore x = current := x + +let is_active x = (not !disabled) && !current.active.(number x) + +let is_error x = (not !disabled) && !current.error.(number x) + +let mk_lazy f = + let state = backup () in + lazy + (let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn) + +let parse_opt error active flags s = + let set i = flags.(i) <- true in + let clear i = flags.(i) <- false in + let set_all i = + active.(i) <- true; + error.(i) <- true + in + let error () = raise (Arg.Bad "Ill-formed list of warnings") in + let rec get_num n i = + if i >= String.length s then (i, n) + else + match s.[i] with + | '0' .. '9' -> + get_num ((10 * n) + Char.code s.[i] - Char.code '0') (i + 1) + | _ -> (i, n) + in + let get_range i = + let i, n1 = get_num 0 i in + if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then ( + let i, n2 = get_num 0 (i + 2) in + if n2 < n1 then error (); + (i, n1, n2)) + else (i, n1, n1) + in + let rec loop i = + if i >= String.length s then () + else + match s.[i] with + | 'A' .. 'Z' -> + List.iter set (letter (Char.lowercase_ascii s.[i])); + loop (i + 1) + | 'a' .. 'z' -> + List.iter clear (letter s.[i]); + loop (i + 1) + | '+' -> loop_letter_num set (i + 1) + | '-' -> loop_letter_num clear (i + 1) + | '@' -> loop_letter_num set_all (i + 1) + | _ -> error () + and loop_letter_num myset i = + if i >= String.length s then error () + else + match s.[i] with + | '0' .. '9' -> + let i, n1, n2 = get_range i in + for n = n1 to Ext_pervasives.min_int n2 last_warning_number do + myset n + done; + loop i + | 'A' .. 'Z' -> + List.iter myset (letter (Char.lowercase_ascii s.[i])); + loop (i + 1) + | 'a' .. 'z' -> + List.iter myset (letter s.[i]); + loop (i + 1) + | _ -> error () + in + loop 0 + +let parse_options errflag s = + let error = Array.copy !current.error in + let active = Array.copy !current.active in + parse_opt error active (if errflag then error else active) s; + current := {error; active} + +let reset () = + parse_options false Bsc_warnings.defaults_w; + parse_options true Bsc_warnings.defaults_warn_error + +let () = reset () + +let message = function + | Comment_start -> "this is the start of a comment." + | Comment_not_end -> "this is not the end of a comment." + | Deprecated (s, _, _, can_be_automigrated) -> + (* Reduce \r\n to \n: + - Prevents any \r characters being printed on Unix when processing + Windows sources + - Prevents \r\r\n being generated on Windows, which affects the + testsuite + *) + "deprecated: " ^ Misc.normalise_eol s + ^ + if can_be_automigrated then + "\n\n\ + \ This can be automatically migrated by the ReScript migration tool. \ + Run `rescript-tools migrate-all ` to run all automatic \ + migrations available in your project, or `rescript-tools migrate \ + ` to migrate a single file." + else "" + | Fragile_match "" -> "this pattern-matching is fragile." + | Fragile_match s -> + "this pattern-matching is fragile.\n\ + It will remain exhaustive when constructors are added to type " ^ s ^ "." + | Partial_application -> + "this function application is partial,\nmaybe some arguments are missing." + | Method_override [lab] -> "the method " ^ lab ^ " is overridden." + | Method_override (cname :: slist) -> + String.concat " " + ("the following methods are overridden by the class" :: cname :: ":\n " + :: slist) + | Method_override [] -> assert false + | Partial_match "" -> + "You forgot to handle a possible case here, though we don't have more \ + information on the value." + | Partial_match s -> + "You forgot to handle a possible case here, for example: \n " ^ s + | Non_closed_record_pattern s -> + "the following labels are not bound in this record pattern: " ^ s + ^ "\nEither bind these labels explicitly or add ', _' to the pattern." + | Statement_type -> + "This expression returns a value, but you're not doing anything with it. \ + If this is on purpose, wrap it with `ignore`." + | Unused_match -> "this match case is unused." + | Unused_pat -> "this sub-pattern is unused." + | Instance_variable_override [lab] -> + "the instance variable " ^ lab ^ " is overridden.\n" + ^ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + | Instance_variable_override (cname :: slist) -> + String.concat " " + ("the following instance variables are overridden by the class" :: cname + :: ":\n " :: slist) + ^ "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + | Instance_variable_override [] -> assert false + | Illegal_backslash -> "illegal backslash escape in string." + | Implicit_public_methods l -> + "the following private methods were made public implicitly:\n " + ^ String.concat " " l ^ "." + | Unerasable_optional_argument -> + String.concat "" + [ + "This optional parameter in final position will, in practice, not be \ + optional.\n"; + " Reorder the parameters so that at least one non-optional one is in \ + final position or, if all parameters are optional, insert a final \ + ().\n\n"; + " Explanation: If the final parameter is optional, it'd be unclear \ + whether a function application that omits it should be considered \ + fully applied, or partially applied. Imagine writing `let title = \ + display(\"hello!\")`, only to realize `title` isn't your desired \ + result, but a curried call that takes a final optional argument, e.g. \ + `~showDate`.\n\n"; + " Formal rule: an optional argument is considered intentionally \ + omitted when the 1st positional (i.e. neither labeled nor optional) \ + argument defined after it is passed in."; + ] + | Unused_argument -> "this argument will not be used by the function." + | Nonreturning_statement -> + "this statement never returns (or has an unsound type.)" + | Preprocessor s -> s + | Useless_record_with -> + "All the fields are already explicitly listed in this record. You can \ + remove the `...` spread." + | Bad_module_name modname -> + "This file's name is potentially invalid. The build systems conventionally \ + turn a file name into a module name by upper-casing the first letter. " + ^ modname ^ " isn't a valid module name.\n" + ^ "Note: some build systems might e.g. turn kebab-case into CamelCase \ + module, which is why this isn't a hard error." + | All_clauses_guarded -> + "this pattern-matching is not exhaustive.\n\ + All clauses in this pattern-matching are guarded." + | Unused_var v | Unused_var_strict v -> + Format.sprintf + "unused variable %s.\n\n\ + Fix this by:\n\ + - Deleting the variable if it's not used anymore.\n\ + - Prepending the variable name with `_` (like `_%s`) to ignore that the \ + variable is unused.\n\ + - Using the variable somewhere." + v v + | Wildcard_arg_to_constant_constr -> + "wildcard pattern given as argument to a constant constructor" + | Eol_in_string -> + "unescaped end-of-line in a string constant (non-portable code)" + | Duplicate_definitions (kind, cname, tc1, tc2) -> + Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname + tc1 tc2 + | Unused_value_declaration v -> "unused value " ^ v ^ "." + | Unused_open s -> "unused open " ^ s ^ "." + | Unused_type_declaration s -> "unused type " ^ s ^ "." + | Unused_for_index s -> "unused for-loop index " ^ s ^ "." + | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "." + | Unused_constructor (s, true, _) -> + "constructor " ^ s + ^ " is never used to build values.\n\ + (However, this constructor appears in patterns.)" + | Unused_constructor (s, false, true) -> + "constructor " ^ s + ^ " is never used to build values.\nIts type is exported as a private type." + | Unused_extension (s, is_exception, cu_pattern, cu_privatize) -> ( + let kind = if is_exception then "exception" else "extension constructor" in + let name = kind ^ " " ^ s in + match (cu_pattern, cu_privatize) with + | false, false -> "unused " ^ name + | true, _ -> + name + ^ " is never used to build values.\n\ + (However, this constructor appears in patterns.)" + | false, true -> + name + ^ " is never used to build values.\n\ + It is exported or rebound as a private extension.") + | Unused_rec_flag -> "unused rec flag." + | Ambiguous_name ([s], tl, false) -> + s ^ " belongs to several types: " ^ String.concat " " tl + ^ "\nThe first one was selected. Disambiguate if this is wrong." + | Ambiguous_name (_, _, false) -> assert false + | Ambiguous_name (_slist, tl, true) -> + "these field labels belong to several types: " ^ String.concat " " tl + ^ "\nThe first one was selected. Disambiguate if this is wrong." + | Nonoptional_label s -> "the label " ^ s ^ " is not optional." + | Open_shadow_identifier (kind, s) -> + Printf.sprintf + "this open statement shadows the %s identifier %s (which is later used)" + kind s + | Open_shadow_label_constructor (kind, s) -> + Printf.sprintf "this open statement shadows the %s %s (which is later used)" + kind s + | Attribute_payload (a, s) -> + Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s + | Eliminated_optional_arguments sl -> + Printf.sprintf "implicit elimination of optional argument%s %s" + (if List.length sl = 1 then "" else "s") + (String.concat ", " sl) + | No_cmi_file (name, None) -> + "no cmi file was found in path for module " ^ name + | No_cmi_file (name, Some msg) -> + Printf.sprintf "no valid cmi file was found in path for module %s. %s" name + msg + | Bad_docstring unattached -> + if unattached then "unattached documentation comment (ignored)" + else "ambiguous documentation comment" + | Fragile_literal_pattern -> + Printf.sprintf + "Code should not depend on the actual values of\n\ + this constructor's arguments. They are only for information\n\ + and may change in future versions. (See manual section 8.5)" + | Unreachable_case -> + "this match case is unreachable.\n\ + Consider replacing it with a refutation case ' -> .'" + | Misplaced_attribute attr_name -> + Printf.sprintf "the %S attribute cannot appear in this context" attr_name + | Duplicated_attribute attr_name -> + Printf.sprintf "the %S attribute is used more than once on this expression" + attr_name + | Ambiguous_pattern vars -> + let msg = + let vars = List.sort String.compare vars in + match vars with + | [] -> assert false + | [x] -> "variable " ^ x + | _ :: _ -> "variables " ^ String.concat "," vars + in + Printf.sprintf + "Ambiguous or-pattern variables under guard;\n\ + %s may match different arguments. (See manual section 8.5)" + msg + | Unused_module s -> "unused module " ^ s ^ "." + | Constraint_on_gadt -> + "Type constraints do not apply to GADT cases of variant types." + | Bs_unused_attribute s -> + "Unused attribute: @" ^ s + ^ "\n\ + This attribute has no effect here.\n\ + For example, some attributes are only meaningful in externals.\n" + | Bs_polymorphic_comparison -> + "Polymorphic comparison introduced (maybe unsafe)" + | Bs_ffi_warning s -> "FFI warning: " ^ s + | Bs_derive_warning s -> "@deriving warning: " ^ s + | Bs_fragile_external s -> + s + ^ " : using an empty string as a shorthand to infer the external's name \ + from the value's name is dangerous when refactoring, and therefore \ + deprecated" + | Bs_unimplemented_primitive s -> "Unimplemented primitive used: " ^ s + | Bs_integer_literal_overflow -> + "Integer literal exceeds the range of representable integers of type int" + | Bs_uninterpreted_delimiters s -> "Uninterpreted delimiters " ^ s + | Bs_toplevel_expression_unit help -> + Printf.sprintf + "This%sis at the top level and is expected to return `unit`. But it's \ + returning %s.\n\n\ + \ In ReScript, anything at the top level must evaluate to `unit`. You \ + can fix this by assigning the expression to a value, or piping it into \ + the `ignore` function.%s" + (match help with + | Some (_, FunctionCall) -> " function call " + | _ -> " ") + (match help with + | Some (return_type, _) -> Printf.sprintf "`%s`" return_type + | None -> "something that is not `unit`") + (match help with + | Some (_, help_typ) -> + let help_text = + match help_typ with + | FunctionCall -> "yourFunctionCall()" + | Other -> "yourExpression" + in + Printf.sprintf + "\n\n\ + \ Possible solutions:\n\ + \ - Assigning to a value that is then ignored: `let _ = %s`\n\ + \ - Piping into the built-in ignore function to ignore the result: \ + `%s->ignore`" + help_text help_text + | _ -> "") + | Bs_todo maybe_text -> + (match maybe_text with + | None -> "Todo found." + | Some todo -> "Todo found: " ^ todo) + ^ "\n\n\ + \ This code is not implemented yet and will crash at runtime. Make sure \ + you implement this before running the code." + +let sub_locs = function + | Deprecated (_, def, use, _) -> + [(def, "Definition"); (use, "Expected signature")] + | _ -> [] + +let has_warnings = ref false + +let nerrors = ref 0 + +type reporting_information = { + number: int; + message: string; + is_error: bool; + sub_locs: (loc * string) list; +} + +let report w = + match is_active w with + | false -> `Inactive + | true -> + has_warnings := true; + if is_error w then incr nerrors; + `Active + { + number = number w; + message = message w; + is_error = is_error w; + sub_locs = sub_locs w; + } + +exception Errors + +let reset_fatal () = nerrors := 0 + +let check_fatal () = + if !nerrors > 0 then ( + nerrors := 0; + raise Errors) + +let descriptions = + [ + (1, "Suspicious-looking start-of-comment mark."); + (2, "Suspicious-looking end-of-comment mark."); + (3, "Deprecated feature."); + ( 4, + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched." ); + ( 5, + "Partially applied function: expression whose result has function\n\ + \ type and is ignored." ); + (7, "Method overridden."); + (8, "Partial match: missing cases in pattern-matching."); + (9, "Missing fields in a record pattern."); + ( 10, + "Expression on the left-hand side of a sequence that doesn't have type\n\ + \ \"unit\" (and that is not a function, see warning number 5)." ); + (11, "Redundant case in a pattern matching (unused match case)."); + (12, "Redundant sub-pattern in a pattern-matching."); + (13, "Instance variable overridden."); + (14, "Illegal backslash escape in a string constant."); + (15, "Private method made public implicitly."); + (16, "Unerasable optional argument."); + (17, "Undeclared virtual method."); + (18, "Non-principal type."); + (19, "Type without principality."); + (20, "Unused function argument."); + (21, "Non-returning statement."); + (22, "Preprocessor warning."); + (23, "Useless record \"with\" clause."); + ( 24, + "Bad module name: the source file name is not a valid ReScript module \ + name." ); + (25, "Deprecated: now part of warning 8."); + ( 26, + "Suspicious unused variable: unused variable that is bound\n\ + \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character." ); + ( 27, + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character." ); + (28, "Wildcard pattern given as argument to a constant constructor."); + (29, "Unescaped end-of-line in a string constant (non-portable code)."); + ( 30, + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types." ); + (31, "A module is linked twice in the same executable."); + (32, "Unused value declaration."); + (33, "Unused open statement."); + (34, "Unused type declaration."); + (35, "Unused for-loop index."); + (36, "Unused ancestor variable."); + (37, "Unused constructor."); + (38, "Unused extension constructor."); + (39, "Unused rec flag."); + (41, "Ambiguous constructor or label name."); + (43, "Nonoptional label applied as optional."); + (44, "Open statement shadows an already defined identifier."); + (45, "Open statement shadows an already defined label or constructor."); + (46, "Error in environment variable."); + (47, "Illegal attribute payload."); + (48, "Implicit elimination of optional arguments."); + (49, "Absent cmi file when looking up module alias."); + (50, "Unexpected documentation comment."); + (52, "Fragile constant pattern."); + (53, "Attribute cannot appear in this context"); + (54, "Attribute used more than once on an expression"); + (55, "Inlining impossible"); + (56, "Unreachable case in a pattern-matching (based on type information)."); + (57, "Ambiguous or-pattern variables under guard"); + (59, "Assignment to non-mutable value"); + (60, "Unused module declaration"); + (62, "Type constraint on GADT type declaration"); + (101, "Unused bs attributes"); + (102, "Polymorphic comparison introduced (maybe unsafe)"); + (103, "Fragile FFI definitions"); + (104, "@deriving warning with customized message "); + ( 105, + "External name is inferred from val name is unsafe from refactoring when \ + changing value name" ); + (106, "Unimplemented primitive used:"); + ( 107, + "Integer literal exceeds the range of representable integers of type int" + ); + (108, "Uninterpreted delimiters (for unicode)"); + (109, "Toplevel expression has unit type"); + (110, "Todo found"); + ] + +let help_warnings () = + List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions; + print_endline " A all warnings"; + for i = Char.code 'b' to Char.code 'z' do + let c = Char.chr i in + match letter c with + | [] -> () + | [n] -> + Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n + | l -> + Printf.printf " %c warnings %s.\n" (Char.uppercase_ascii c) + (String.concat ", " (List.map string_of_int l)) + done; + exit 0 + +let loc_to_string (loc : loc) : string = + Format.sprintf "(%02d,%02d--%02d,%02d)" loc.loc_start.pos_lnum + (loc.loc_start.pos_cnum - loc.loc_start.pos_bol) + loc.loc_end.pos_lnum + (loc.loc_end.pos_cnum - loc.loc_end.pos_bol) diff --git a/jscomp/ext/warnings.mli b/compiler/ext/warnings.mli similarity index 88% rename from jscomp/ext/warnings.mli rename to compiler/ext/warnings.mli index b5dab78..ba1a03c 100644 --- a/jscomp/ext/warnings.mli +++ b/compiler/ext/warnings.mli @@ -14,17 +14,17 @@ (**************************************************************************) type loc = { - loc_start : Lexing.position; - loc_end : Lexing.position; - loc_ghost : bool; + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; } -type topLevelUnitHelp = FunctionCall | Other +type top_level_unit_help = FunctionCall | Other type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) - | Deprecated of string * loc * loc (* 3 *) + | Deprecated of string * loc * loc * bool (* 3 *) | Fragile_match of string (* 4 *) | Partial_application (* 5 *) | Method_override of string list (* 7 *) @@ -78,7 +78,8 @@ type t = | Bs_unimplemented_primitive of string (* 106 *) | Bs_integer_literal_overflow (* 107 *) | Bs_uninterpreted_delimiters of string (* 108 *) - | Bs_toplevel_expression_unit of (string * topLevelUnitHelp) option (* 109 *) + | Bs_toplevel_expression_unit of + (string * top_level_unit_help) option (* 109 *) | Bs_todo of string option (* 110 *) val parse_options : bool -> string -> unit @@ -90,13 +91,13 @@ val is_active : t -> bool val is_error : t -> bool type reporting_information = { - number : int; - message : string; - is_error : bool; - sub_locs : (loc * string) list; + number: int; + message: string; + is_error: bool; + sub_locs: (loc * string) list; } -val report : t -> [ `Active of reporting_information | `Inactive ] +val report : t -> [`Active of reporting_information | `Inactive] exception Errors @@ -125,3 +126,8 @@ val message : t -> string val number : t -> int val reset : unit -> unit + +val loc_to_string : loc -> string +(** +Turn the location into a string with (line,column--line,column) format. +*) diff --git a/jscomp/ml/annot.ml b/compiler/ml/annot.ml similarity index 93% rename from jscomp/ml/annot.ml rename to compiler/ml/annot.ml index 3cae8f2..13a5865 100644 --- a/jscomp/ml/annot.ml +++ b/compiler/ml/annot.ml @@ -15,10 +15,9 @@ (* Data types for annotations (Stypes.ml) *) -type call = Tail | Stack | Inline;; +type call = Tail | Stack | Inline type ident = | Iref_internal of Location.t (* defining occurrence *) | Iref_external - | Idef of Location.t (* scope *) -;; + | Idef of Location.t (* scope *) diff --git a/compiler/ml/ast_async.ml b/compiler/ml/ast_async.ml new file mode 100644 index 0000000..d5494eb --- /dev/null +++ b/compiler/ml/ast_async.ml @@ -0,0 +1,29 @@ +let rec dig_async_payload_from_function (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_fun {async} -> async + | Pexp_newtype (_, body) -> dig_async_payload_from_function body + | _ -> false + +let add_promise_type ?(loc = Location.none) ~async + (result : Parsetree.expression) = + if async then + let unsafe_async = + Ast_helper.Exp.ident ~loc + {txt = Ldot (Lident Primitive_modules.promise, "unsafe_async"); loc} + in + Ast_helper.Exp.apply ~loc unsafe_async [(Nolabel, result)] + else result + +let rec add_promise_to_result ~loc (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_fun f -> + let rhs = add_promise_to_result ~loc f.rhs in + {e with pexp_desc = Pexp_fun {f with rhs}} + | _ -> add_promise_type ~loc ~async:true e + +let make_function_async ~async (e : Parsetree.expression) = + if async then + match e.pexp_desc with + | Pexp_fun {lhs = {ppat_loc}} -> add_promise_to_result ~loc:ppat_loc e + | _ -> assert false + else e diff --git a/compiler/ml/ast_await.ml b/compiler/ml/ast_await.ml new file mode 100644 index 0000000..588a0fa --- /dev/null +++ b/compiler/ml/ast_await.ml @@ -0,0 +1,61 @@ +let is_await : Parsetree.attribute -> bool = + fun ({txt}, _) -> txt = "await" || txt = "res.await" + +let create_await_expression (e : Parsetree.expression) = + let loc = {e.pexp_loc with loc_ghost = true} in + let unsafe_await = + Ast_helper.Exp.ident ~loc + {txt = Ldot (Lident Primitive_modules.promise, "unsafe_await"); loc} + in + Ast_helper.Exp.apply ~loc unsafe_await [(Nolabel, e)] + +let is_await_expr (e : Parsetree.expression) = + match e with + | { + pexp_loc = {loc_ghost = true}; + pexp_desc = + Pexp_apply + { + funct = + { + pexp_loc = {loc_ghost = true}; + pexp_desc = Pexp_ident {txt = Ldot (Lident ident, "unsafe_await")}; + }; + args = [(Nolabel, _)]; + }; + } + when ident = Primitive_modules.promise -> + true + | _ -> false + +(* Transform `@res.await M` to unpack(@res.await Js.import(module(M: __M0__))) *) +let create_await_module_expression ~module_type_lid (e : Parsetree.module_expr) + = + let open Ast_helper in + let remove_await_attribute = + List.filter (fun ((loc, _) : Parsetree.attribute) -> loc.txt != "res.await") + in + { + e with + pmod_desc = + Pmod_unpack + (create_await_expression + (Exp.apply ~loc:e.pmod_loc + (Exp.ident ~loc:e.pmod_loc + { + txt = + Longident.Ldot (Lident Primitive_modules.module_, "import"); + loc = e.pmod_loc; + }) + [ + ( Nolabel, + Exp.constraint_ ~loc:e.pmod_loc + (Exp.pack ~loc:e.pmod_loc + { + e with + pmod_attributes = + remove_await_attribute e.pmod_attributes; + }) + (Typ.package ~loc:e.pmod_loc module_type_lid []) ); + ])); + } diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml new file mode 100644 index 0000000..2fae640 --- /dev/null +++ b/compiler/ml/ast_helper.ml @@ -0,0 +1,448 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments *) + +open Asttypes +open Parsetree + +type lid = Longident.t loc +type str = string loc +type loc = Location.t +type attrs = attribute list + +let default_loc = ref Location.none + +let with_default_loc l f = + let old = !default_loc in + default_loc := l; + try + let r = f () in + default_loc := old; + r + with exn -> + default_loc := old; + raise exn + +module Const = struct + let integer ?suffix i = Pconst_integer (i, suffix) + let int ?suffix i = integer ?suffix (string_of_int i) + let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) + let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) + let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) + let float ?suffix f = Pconst_float (f, suffix) + let char c = Pconst_char (Char.code c) + let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) +end + +module Typ = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} + let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) + let arrow ?loc ?attrs ~arity arg ret = + mk ?loc ?attrs (Ptyp_arrow {arg; ret; arity}) + let arrows ?loc ?attrs args ret = + let arity = Some (List.length args) in + let rec build_arrows arity_to_use = function + | [] -> ret + | [arg] -> arrow ?loc ?attrs ~arity:arity_to_use arg ret + | arg :: rest -> + arrow ?loc ?attrs ~arity:arity_to_use arg (build_arrows None rest) + in + build_arrows arity args + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) + let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) + let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) + let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) + let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) + + let force_poly t = + match t.ptyp_desc with + | Ptyp_poly _ -> t + | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) + + let varify_constructors var_names t = + let check_variable vl loc v = + if List.mem v vl then raise Syntaxerr.(Error (Variable_in_scope (loc, v))) + in + let var_names = List.map (fun v -> v.txt) var_names in + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc x; + Ptyp_var x + | Ptyp_arrow ({arg; ret} as arr) -> + Ptyp_arrow + {arr with arg = {arr.arg with typ = loop arg.typ}; ret = loop ret} + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names + -> + Ptyp_var s + | Ptyp_constr (longident, lst) -> + Ptyp_constr (longident, List.map loop lst) + | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o) + | Ptyp_alias (core_type, string) -> + check_variable var_names t.ptyp_loc string; + Ptyp_alias (loop core_type, string) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + (List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly (string_lst, core_type) -> + List.iter + (fun v -> check_variable var_names t.ptyp_loc v.txt) + string_lst; + Ptyp_poly (string_lst, loop core_type) + | Ptyp_package (longident, lst) -> + Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) + | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) + in + {t with ptyp_desc = desc} + and loop_row_field = function + | Rtag (label, attrs, flag, lst) -> + Rtag (label, attrs, flag, List.map loop lst) + | Rinherit t -> Rinherit (loop t) + and loop_object_field = function + | Otag (label, attrs, t) -> Otag (label, attrs, loop t) + | Oinherit t -> Oinherit (loop t) + in + loop t +end + +module Pat = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} + let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) + let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) + let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) + let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) + let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) + let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) +end + +module Exp = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} + let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) + let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) + let fun_ ?loc ?attrs ?(async = false) ~arity a b c d = + mk ?loc ?attrs + (Pexp_fun {arg_label = a; default = b; lhs = c; rhs = d; arity; async}) + let apply ?loc ?attrs ?(partial = false) ?(transformed_jsx = false) funct args + = + mk ?loc ?attrs (Pexp_apply {funct; args; partial; transformed_jsx}) + let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) + let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) + let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) + let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) + let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) + let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) + let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) + let coerce ?loc ?attrs a c = mk ?loc ?attrs (Pexp_coerce (a, (), c)) + let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) + let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) + let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) + let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) + let await ?loc ?attrs a = mk ?loc ?attrs (Pexp_await a) + let jsx_fragment ?loc ?attrs a b c = + mk ?loc ?attrs + (Pexp_jsx_element + (Jsx_fragment + { + jsx_fragment_opening = a; + jsx_fragment_children = b; + jsx_fragment_closing = c; + })) + let jsx_unary_element ?loc ?attrs a b = + mk ?loc ?attrs + (Pexp_jsx_element + (Jsx_unary_element + {jsx_unary_element_tag_name = a; jsx_unary_element_props = b})) + + let jsx_container_element ?loc ?attrs a b c d e = + mk ?loc ?attrs + (Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = a; + jsx_container_element_props = b; + jsx_container_element_opening_tag_end = c; + jsx_container_element_children = d; + jsx_container_element_closing_tag = e; + })) + + let case ?bar lhs ?guard rhs = + {pc_bar = bar; pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs} + + let make_list_expression loc seq ext_opt = + let rec handle_seq = function + | [] -> ( + match ext_opt with + | Some ext -> ext + | None -> + let loc = {loc with Location.loc_ghost = true} in + let nil = Location.mkloc (Longident.Lident "[]") loc in + construct ~loc nil None) + | e1 :: el -> + let exp_el = handle_seq el in + let loc = + Location. + { + loc_start = e1.Parsetree.pexp_loc.Location.loc_start; + loc_end = exp_el.pexp_loc.loc_end; + loc_ghost = false; + } + in + let arg = tuple ~loc [e1; exp_el] in + construct ~loc (Location.mkloc (Longident.Lident "::") loc) (Some arg) + in + let expr = handle_seq seq in + {expr with pexp_loc = loc} +end + +module Mty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} + let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) + let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) + let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) + let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) + let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) +end + +module Mod = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} + let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} + + let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) + let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) + let functor_ ?loc ?attrs arg arg_ty body = + mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) + let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) + let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) + let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) +end + +module Sig = struct + let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} + + let value ?loc a = mk ?loc (Psig_value a) + let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Psig_typext a) + let exception_ ?loc a = mk ?loc (Psig_exception a) + let module_ ?loc a = mk ?loc (Psig_module a) + let rec_module ?loc a = mk ?loc (Psig_recmodule a) + let modtype ?loc a = mk ?loc (Psig_modtype a) + let open_ ?loc a = mk ?loc (Psig_open a) + let include_ ?loc a = mk ?loc (Psig_include a) + + let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Psig_attribute a) +end + +module Str = struct + let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} + + let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) + let value ?loc a b = mk ?loc (Pstr_value (a, b)) + let primitive ?loc a = mk ?loc (Pstr_primitive a) + let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Pstr_typext a) + let exception_ ?loc a = mk ?loc (Pstr_exception a) + let module_ ?loc a = mk ?loc (Pstr_module a) + let rec_module ?loc a = mk ?loc (Pstr_recmodule a) + let modtype ?loc a = mk ?loc (Pstr_modtype a) + let open_ ?loc a = mk ?loc (Pstr_open a) + let include_ ?loc a = mk ?loc (Pstr_include a) + let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Pstr_attribute a) +end + +module Val = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ = + { + pval_name = name; + pval_type = typ; + pval_attributes = attrs; + pval_loc = loc; + pval_prim = prim; + } +end + +module Md = struct + let mk ?(loc = !default_loc) ?(attrs = []) name typ = + {pmd_name = name; pmd_type = typ; pmd_attributes = attrs; pmd_loc = loc} +end + +module Mtd = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?typ name = + {pmtd_name = name; pmtd_type = typ; pmtd_attributes = attrs; pmtd_loc = loc} +end + +module Mb = struct + let mk ?(loc = !default_loc) ?(attrs = []) name expr = + {pmb_name = name; pmb_expr = expr; pmb_attributes = attrs; pmb_loc = loc} +end + +module Opn = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid = + { + popen_lid = lid; + popen_override = override; + popen_loc = loc; + popen_attributes = attrs; + } +end + +module Incl = struct + let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + {pincl_mod = mexpr; pincl_loc = loc; pincl_attributes = attrs} +end + +module Vb = struct + let mk ?(loc = !default_loc) ?(attrs = []) pat expr = + {pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc} +end + +module Type = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(cstrs = []) + ?(kind = Ptype_abstract) ?(priv = Public) ?manifest name = + { + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = attrs; + ptype_loc = loc; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) + ?res name = + { + pcd_name = name; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = attrs; + } + + let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) + ?(optional = false) name typ = + { + pld_name = name; + pld_mutable = mut; + pld_optional = optional; + pld_type = typ; + pld_loc = loc; + pld_attributes = attrs; + } +end + +(** Type extensions *) +module Te = struct + let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors = + { + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_attributes = attrs; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) name kind = + { + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = attrs; + } + + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res + name = + { + pext_name = name; + pext_kind = Pext_decl (args, res); + pext_loc = loc; + pext_attributes = attrs; + } + + let rebind ?(loc = !default_loc) ?(attrs = []) name lid = + { + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = attrs; + } +end + +module Jsx = struct + let string_of_jsx_tag_name (tag_name : Parsetree.jsx_tag_name) : string = + match tag_name with + | Parsetree.JsxLowerTag name -> name + | Parsetree.JsxQualifiedLowerTag {path; name} -> + String.concat "." (Longident.flatten path) ^ "." ^ name + | Parsetree.JsxUpperTag path -> String.concat "." (Longident.flatten path) + | Parsetree.JsxTagInvalid name -> name + + let longident_of_jsx_tag_name (tag_name : Parsetree.jsx_tag_name) : + Longident.t = + match tag_name with + | Parsetree.JsxLowerTag name -> Longident.Lident name + | Parsetree.JsxQualifiedLowerTag {path; name} -> Longident.Ldot (path, name) + | Parsetree.JsxUpperTag path -> path + | Parsetree.JsxTagInvalid name -> Longident.Lident name +end diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli new file mode 100644 index 0000000..11227b9 --- /dev/null +++ b/compiler/ml/ast_helper.mli @@ -0,0 +1,432 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments *) + +open Asttypes +open Parsetree + +type lid = Longident.t loc +type str = string loc +type loc = Location.t +type attrs = attribute list + +(** {1 Default locations} *) + +val default_loc : loc ref +(** Default value for all optional location arguments. *) + +val with_default_loc : loc -> (unit -> 'a) -> 'a +(** Set the [default_loc] within the scope of the execution + of the provided function. *) + +(** {1 Constants} *) + +module Const : sig + val char : char -> constant + val string : ?quotation_delimiter:string -> string -> constant + val integer : ?suffix:char -> string -> constant + val int : ?suffix:char -> int -> constant + val int32 : ?suffix:char -> int32 -> constant + val int64 : ?suffix:char -> int64 -> constant + val nativeint : ?suffix:char -> nativeint -> constant + val float : ?suffix:char -> string -> constant +end + +(** {1 Core language} *) + +(** Type expressions *) +module Typ : sig + val mk : ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type + val attr : core_type -> attribute -> core_type + + val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type + val var : ?loc:loc -> ?attrs:attrs -> string -> core_type + val arrow : + ?loc:loc -> ?attrs:attrs -> arity:arity -> arg -> core_type -> core_type + val arrows : ?loc:loc -> ?attrs:attrs -> arg list -> core_type -> core_type + val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type + val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type + val object_ : + ?loc:loc -> ?attrs:attrs -> object_field list -> closed_flag -> core_type + val alias : ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type + val variant : + ?loc:loc -> + ?attrs:attrs -> + row_field list -> + closed_flag -> + label list option -> + core_type + val poly : ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type + val package : + ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list -> core_type + val extension : ?loc:loc -> ?attrs:attrs -> extension -> core_type + + val force_poly : core_type -> core_type + + val varify_constructors : str list -> core_type -> core_type + (** [varify_constructors newtypes te] is type expression [te], of which + any of nullary type constructor [tc] is replaced by type variable of + the same name, if [tc]'s name appears in [newtypes]. + Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] + appears in [newtypes]. + @since 4.05 + *) +end + +(** Patterns *) +module Pat : sig + val mk : ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern + val attr : pattern -> attribute -> pattern + + val any : ?loc:loc -> ?attrs:attrs -> unit -> pattern + val var : ?loc:loc -> ?attrs:attrs -> str -> pattern + val alias : ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern + val constant : ?loc:loc -> ?attrs:attrs -> constant -> pattern + val interval : ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern + val tuple : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern + val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern + val record : + ?loc:loc -> + ?attrs:attrs -> + pattern record_element list -> + closed_flag -> + pattern + val array : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + val or_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern + val constraint_ : ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern + val type_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern + val unpack : ?loc:loc -> ?attrs:attrs -> str -> pattern + val open_ : ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern + val exception_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern + val extension : ?loc:loc -> ?attrs:attrs -> extension -> pattern +end + +(** Expressions *) +module Exp : sig + val mk : ?loc:loc -> ?attrs:attrs -> expression_desc -> expression + val attr : expression -> attribute -> expression + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> expression + val constant : ?loc:loc -> ?attrs:attrs -> constant -> expression + val let_ : + ?loc:loc -> + ?attrs:attrs -> + rec_flag -> + value_binding list -> + expression -> + expression + val fun_ : + ?loc:loc -> + ?attrs:attrs -> + ?async:bool -> + arity:int option -> + arg_label -> + expression option -> + pattern -> + expression -> + expression + val apply : + ?loc:loc -> + ?attrs:attrs -> + ?partial:bool -> + ?transformed_jsx:bool -> + expression -> + (arg_label * expression) list -> + expression + val match_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression + val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression + val construct : + ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression + val variant : + ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression + val record : + ?loc:loc -> + ?attrs:attrs -> + expression record_element list -> + expression option -> + expression + val field : ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression + val setfield : + ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression -> expression + val array : ?loc:loc -> ?attrs:attrs -> expression list -> expression + val ifthenelse : + ?loc:loc -> + ?attrs:attrs -> + expression -> + expression -> + expression option -> + expression + val sequence : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + val while_ : + ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression + val for_ : + ?loc:loc -> + ?attrs:attrs -> + pattern -> + expression -> + expression -> + direction_flag -> + expression -> + expression + val coerce : ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression + val constraint_ : + ?loc:loc -> ?attrs:attrs -> expression -> core_type -> expression + val send : ?loc:loc -> ?attrs:attrs -> expression -> str -> expression + val letmodule : + ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression -> expression + val letexception : + ?loc:loc -> + ?attrs:attrs -> + extension_constructor -> + expression -> + expression + val assert_ : ?loc:loc -> ?attrs:attrs -> expression -> expression + val newtype : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression + val pack : ?loc:loc -> ?attrs:attrs -> module_expr -> expression + val open_ : + ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression -> expression + val extension : ?loc:loc -> ?attrs:attrs -> extension -> expression + val jsx_fragment : + ?loc:loc -> + ?attrs:attrs -> + Lexing.position -> + Parsetree.jsx_children -> + Lexing.position -> + expression + val jsx_unary_element : + ?loc:loc -> + ?attrs:attrs -> + Parsetree.jsx_tag_name Location.loc -> + Parsetree.jsx_props -> + expression + val jsx_container_element : + ?loc:loc -> + ?attrs:attrs -> + Parsetree.jsx_tag_name Location.loc -> + Parsetree.jsx_props -> + Lexing.position -> + Parsetree.jsx_children -> + Parsetree.jsx_closing_container_tag option -> + expression + + val case : + ?bar:Lexing.position -> pattern -> ?guard:expression -> expression -> case + val await : ?loc:loc -> ?attrs:attrs -> expression -> expression + + val make_list_expression : + Location.t -> expression list -> expression option -> expression +end + +(** Value declarations *) +module Val : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?prim:string list -> + str -> + core_type -> + value_description +end + +(** Type declarations *) +module Type : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?params:(core_type * variance) list -> + ?cstrs:(core_type * core_type * loc) list -> + ?kind:type_kind -> + ?priv:private_flag -> + ?manifest:core_type -> + str -> + type_declaration + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + constructor_declaration + val field : + ?loc:loc -> + ?attrs:attrs -> + ?mut:mutable_flag -> + ?optional:bool -> + str -> + core_type -> + label_declaration +end + +(** Type extensions *) +module Te : sig + val mk : + ?attrs:attrs -> + ?params:(core_type * variance) list -> + ?priv:private_flag -> + lid -> + extension_constructor list -> + type_extension + + val constructor : + ?loc:loc -> + ?attrs:attrs -> + str -> + extension_constructor_kind -> + extension_constructor + + val decl : + ?loc:loc -> + ?attrs:attrs -> + ?args:constructor_arguments -> + ?res:core_type -> + str -> + extension_constructor + val rebind : ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor +end + +module Jsx : sig + val string_of_jsx_tag_name : Parsetree.jsx_tag_name -> string + val longident_of_jsx_tag_name : Parsetree.jsx_tag_name -> Longident.t +end + +(** {1 Module language} *) + +(** Module type expressions *) +module Mty : sig + val mk : ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type + val attr : module_type -> attribute -> module_type + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_type + val alias : ?loc:loc -> ?attrs:attrs -> lid -> module_type + val signature : ?loc:loc -> ?attrs:attrs -> signature -> module_type + val functor_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + module_type option -> + module_type -> + module_type + val with_ : + ?loc:loc -> + ?attrs:attrs -> + module_type -> + with_constraint list -> + module_type + val typeof_ : ?loc:loc -> ?attrs:attrs -> module_expr -> module_type + val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_type +end + +(** Module expressions *) +module Mod : sig + val mk : ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr + val attr : module_expr -> attribute -> module_expr + + val ident : ?loc:loc -> ?attrs:attrs -> lid -> module_expr + val structure : ?loc:loc -> ?attrs:attrs -> structure -> module_expr + val functor_ : + ?loc:loc -> + ?attrs:attrs -> + str -> + module_type option -> + module_expr -> + module_expr + val apply : + ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> module_expr + val constraint_ : + ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> module_expr + val unpack : ?loc:loc -> ?attrs:attrs -> expression -> module_expr + val extension : ?loc:loc -> ?attrs:attrs -> extension -> module_expr +end + +(** Signature items *) +module Sig : sig + val mk : ?loc:loc -> signature_item_desc -> signature_item + + val value : ?loc:loc -> value_description -> signature_item + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> signature_item + val type_extension : ?loc:loc -> type_extension -> signature_item + val exception_ : ?loc:loc -> extension_constructor -> signature_item + val module_ : ?loc:loc -> module_declaration -> signature_item + val rec_module : ?loc:loc -> module_declaration list -> signature_item + val modtype : ?loc:loc -> module_type_declaration -> signature_item + val open_ : ?loc:loc -> open_description -> signature_item + val include_ : ?loc:loc -> include_description -> signature_item + val extension : ?loc:loc -> ?attrs:attrs -> extension -> signature_item + val attribute : ?loc:loc -> attribute -> signature_item +end + +(** Structure items *) +module Str : sig + val mk : ?loc:loc -> structure_item_desc -> structure_item + + val eval : ?loc:loc -> ?attrs:attributes -> expression -> structure_item + val value : ?loc:loc -> rec_flag -> value_binding list -> structure_item + val primitive : ?loc:loc -> value_description -> structure_item + val type_ : ?loc:loc -> rec_flag -> type_declaration list -> structure_item + val type_extension : ?loc:loc -> type_extension -> structure_item + val exception_ : ?loc:loc -> extension_constructor -> structure_item + val module_ : ?loc:loc -> module_binding -> structure_item + val rec_module : ?loc:loc -> module_binding list -> structure_item + val modtype : ?loc:loc -> module_type_declaration -> structure_item + val open_ : ?loc:loc -> open_description -> structure_item + val include_ : ?loc:loc -> include_declaration -> structure_item + val extension : ?loc:loc -> ?attrs:attrs -> extension -> structure_item + val attribute : ?loc:loc -> attribute -> structure_item +end + +(** Module declarations *) +module Md : sig + val mk : ?loc:loc -> ?attrs:attrs -> str -> module_type -> module_declaration +end + +(** Module type declarations *) +module Mtd : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?typ:module_type -> + str -> + module_type_declaration +end + +(** Module bindings *) +module Mb : sig + val mk : ?loc:loc -> ?attrs:attrs -> str -> module_expr -> module_binding +end + +(** Opens *) +module Opn : sig + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?override:override_flag -> + lid -> + open_description +end + +(** Includes *) +module Incl : sig + val mk : ?loc:loc -> ?attrs:attrs -> 'a -> 'a include_infos +end + +(** Value bindings *) +module Vb : sig + val mk : ?loc:loc -> ?attrs:attrs -> pattern -> expression -> value_binding +end diff --git a/compiler/ml/ast_helper0.ml b/compiler/ml/ast_helper0.ml new file mode 100644 index 0000000..cc008b3 --- /dev/null +++ b/compiler/ml/ast_helper0.ml @@ -0,0 +1,368 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(** Helpers to produce Parsetree fragments *) + +open Asttypes +open Parsetree0 + +type lid = Longident.t loc +type str = string loc +type loc = Location.t +type attrs = attribute list + +let default_loc = ref Location.none + +let with_default_loc l f = + let old = !default_loc in + default_loc := l; + try + let r = f () in + default_loc := old; + r + with exn -> + default_loc := old; + raise exn + +module Const = struct + let integer ?suffix i = Pconst_integer (i, suffix) + let int ?suffix i = integer ?suffix (string_of_int i) + let int32 ?(suffix = 'l') i = integer ~suffix (Int32.to_string i) + let int64 ?(suffix = 'L') i = integer ~suffix (Int64.to_string i) + let nativeint ?(suffix = 'n') i = integer ~suffix (Nativeint.to_string i) + let float ?suffix f = Pconst_float (f, suffix) + let char c = Pconst_char (Char.code c) + let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) +end + +module Typ = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} + let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) + let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) + let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) + let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) + let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) + let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) + + let force_poly t = + match t.ptyp_desc with + | Ptyp_poly _ -> t + | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) + + let varify_constructors var_names t = + let check_variable vl loc v = + if List.mem v vl then raise Syntaxerr.(Error (Variable_in_scope (loc, v))) + in + let var_names = List.map (fun v -> v.txt) var_names in + let rec loop t = + let desc = + match t.ptyp_desc with + | Ptyp_any -> Ptyp_any + | Ptyp_var x -> + check_variable var_names t.ptyp_loc x; + Ptyp_var x + | Ptyp_arrow (label, core_type, core_type') -> + Ptyp_arrow (label, loop core_type, loop core_type') + | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) + | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names + -> + Ptyp_var s + | Ptyp_constr (longident, lst) -> + Ptyp_constr (longident, List.map loop lst) + | Ptyp_object (lst, o) -> Ptyp_object (List.map loop_object_field lst, o) + | Ptyp_class () -> assert false + | Ptyp_alias (core_type, string) -> + check_variable var_names t.ptyp_loc string; + Ptyp_alias (loop core_type, string) + | Ptyp_variant (row_field_list, flag, lbl_lst_option) -> + Ptyp_variant + (List.map loop_row_field row_field_list, flag, lbl_lst_option) + | Ptyp_poly (string_lst, core_type) -> + List.iter + (fun v -> check_variable var_names t.ptyp_loc v.txt) + string_lst; + Ptyp_poly (string_lst, loop core_type) + | Ptyp_package (longident, lst) -> + Ptyp_package (longident, List.map (fun (n, typ) -> (n, loop typ)) lst) + | Ptyp_extension (s, arg) -> Ptyp_extension (s, arg) + in + {t with ptyp_desc = desc} + and loop_row_field = function + | Rtag (label, attrs, flag, lst) -> + Rtag (label, attrs, flag, List.map loop lst) + | Rinherit t -> Rinherit (loop t) + and loop_object_field = function + | Otag (label, attrs, t) -> Otag (label, attrs, loop t) + | Oinherit t -> Oinherit (loop t) + in + loop t +end + +module Pat = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} + let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} + + let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any + let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) + let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) + let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) + let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) + let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) + let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) + let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) + let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) + let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) + let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) +end + +module Exp = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} + let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) + let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) + let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) + let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) + let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) + let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) + let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) + let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) + let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) + let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) + let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) + let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) + let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) + let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) + let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) + let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) + let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) + let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) + let coerce ?loc ?attrs a c = mk ?loc ?attrs (Pexp_coerce (a, (), c)) + let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) + let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) + let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) + let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) + let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) + let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) + let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) + let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) + let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) + let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) + let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) + let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) + + let case lhs ?guard rhs = {pc_lhs = lhs; pc_guard = guard; pc_rhs = rhs} +end + +module Mty = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} + let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} + + let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) + let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) + let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) + let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) + let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) + let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) +end + +module Mod = struct + let mk ?(loc = !default_loc) ?(attrs = []) d = + {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} + let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} + + let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) + let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) + let functor_ ?loc ?attrs arg arg_ty body = + mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) + let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) + let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) + let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) + let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) +end + +module Sig = struct + let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} + + let value ?loc a = mk ?loc (Psig_value a) + let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Psig_typext a) + let exception_ ?loc a = mk ?loc (Psig_exception a) + let module_ ?loc a = mk ?loc (Psig_module a) + let rec_module ?loc a = mk ?loc (Psig_recmodule a) + let modtype ?loc a = mk ?loc (Psig_modtype a) + let open_ ?loc a = mk ?loc (Psig_open a) + let include_ ?loc a = mk ?loc (Psig_include a) + + let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Psig_attribute a) +end + +module Str = struct + let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} + + let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) + let value ?loc a b = mk ?loc (Pstr_value (a, b)) + let primitive ?loc a = mk ?loc (Pstr_primitive a) + let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) + let type_extension ?loc a = mk ?loc (Pstr_typext a) + let exception_ ?loc a = mk ?loc (Pstr_exception a) + let module_ ?loc a = mk ?loc (Pstr_module a) + let rec_module ?loc a = mk ?loc (Pstr_recmodule a) + let modtype ?loc a = mk ?loc (Pstr_modtype a) + let open_ ?loc a = mk ?loc (Pstr_open a) + let include_ ?loc a = mk ?loc (Pstr_include a) + let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) + let attribute ?loc a = mk ?loc (Pstr_attribute a) +end + +module Val = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(prim = []) name typ = + { + pval_name = name; + pval_type = typ; + pval_attributes = attrs; + pval_loc = loc; + pval_prim = prim; + } +end + +module Md = struct + let mk ?(loc = !default_loc) ?(attrs = []) name typ = + {pmd_name = name; pmd_type = typ; pmd_attributes = attrs; pmd_loc = loc} +end + +module Mtd = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?typ name = + {pmtd_name = name; pmtd_type = typ; pmtd_attributes = attrs; pmtd_loc = loc} +end + +module Mb = struct + let mk ?(loc = !default_loc) ?(attrs = []) name expr = + {pmb_name = name; pmb_expr = expr; pmb_attributes = attrs; pmb_loc = loc} +end + +module Opn = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(override = Fresh) lid = + { + popen_lid = lid; + popen_override = override; + popen_loc = loc; + popen_attributes = attrs; + } +end + +module Incl = struct + let mk ?(loc = !default_loc) ?(attrs = []) mexpr = + {pincl_mod = mexpr; pincl_loc = loc; pincl_attributes = attrs} +end + +module Vb = struct + let mk ?(loc = !default_loc) ?(attrs = []) pat expr = + {pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc} +end + +module Type = struct + let mk ?(loc = !default_loc) ?(attrs = []) ?(params = []) ?(cstrs = []) + ?(kind = Ptype_abstract) ?(priv = Public) ?manifest name = + { + ptype_name = name; + ptype_params = params; + ptype_cstrs = cstrs; + ptype_kind = kind; + ptype_private = priv; + ptype_manifest = manifest; + ptype_attributes = attrs; + ptype_loc = loc; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) + ?res name = + { + pcd_name = name; + pcd_args = args; + pcd_res = res; + pcd_loc = loc; + pcd_attributes = attrs; + } + + let field ?(loc = !default_loc) ?(attrs = []) ?(mut = Immutable) name typ = + { + pld_name = name; + pld_mutable = mut; + pld_type = typ; + pld_loc = loc; + pld_attributes = attrs; + } +end + +(** Type extensions *) +module Te = struct + let mk ?(attrs = []) ?(params = []) ?(priv = Public) path constructors = + { + ptyext_path = path; + ptyext_params = params; + ptyext_constructors = constructors; + ptyext_private = priv; + ptyext_attributes = attrs; + } + + let constructor ?(loc = !default_loc) ?(attrs = []) name kind = + { + pext_name = name; + pext_kind = kind; + pext_loc = loc; + pext_attributes = attrs; + } + + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res + name = + { + pext_name = name; + pext_kind = Pext_decl (args, res); + pext_loc = loc; + pext_attributes = attrs; + } + + let rebind ?(loc = !default_loc) ?(attrs = []) name lid = + { + pext_name = name; + pext_kind = Pext_rebind lid; + pext_loc = loc; + pext_attributes = attrs; + } +end diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml new file mode 100644 index 0000000..a430bb0 --- /dev/null +++ b/compiler/ml/ast_iterator.ml @@ -0,0 +1,529 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Ojeda Bar, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +open Parsetree +open Location + +type iterator = { + attribute: iterator -> attribute -> unit; + attributes: iterator -> attribute list -> unit; + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + constructor_declaration: iterator -> constructor_declaration -> unit; + expr: iterator -> expression -> unit; + extension: iterator -> extension -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + include_declaration: iterator -> include_declaration -> unit; + include_description: iterator -> include_description -> unit; + label_declaration: iterator -> label_declaration -> unit; + location: iterator -> Location.t -> unit; + module_binding: iterator -> module_binding -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + open_description: iterator -> open_description -> unit; + pat: iterator -> pattern -> unit; + payload: iterator -> payload -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_extension: iterator -> type_extension -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} +(** A [iterator] record implements one "method" per syntactic category, + using an open recursion style: each method takes as its first + argument the iterator to be applied to children in the syntax + tree. *) + +let iter_fst f (x, _) = f x +let iter_snd f (_, y) = f y +let iter_tuple f1 f2 (x, y) = + f1 x; + f2 y +let iter_tuple3 f1 f2 f3 (x, y, z) = + f1 x; + f2 y; + f3 z +let iter_opt f = function + | None -> () + | Some x -> f x + +let iter_loc sub {loc; txt = _} = sub.location sub loc + +module T = struct + (* Type expressions for the core language *) + + let row_field sub = function + | Rtag (_, attrs, _, tl) -> + sub.attributes sub attrs; + List.iter (sub.typ sub) tl + | Rinherit t -> sub.typ sub t + + let object_field sub = function + | Otag (_, attrs, t) -> + sub.attributes sub attrs; + sub.typ sub t + | Oinherit t -> sub.typ sub t + + let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ptyp_any | Ptyp_var _ -> () + | Ptyp_arrow {arg; ret} -> + sub.typ sub arg.typ; + sub.typ sub ret + | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl + | Ptyp_constr (lid, tl) -> + iter_loc sub lid; + List.iter (sub.typ sub) tl + | Ptyp_object (ol, _o) -> List.iter (object_field sub) ol + | Ptyp_alias (t, _) -> sub.typ sub t + | Ptyp_variant (rl, _b, _ll) -> List.iter (row_field sub) rl + | Ptyp_poly (_, t) -> sub.typ sub t + | Ptyp_package (lid, l) -> + iter_loc sub lid; + List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l + | Ptyp_extension x -> sub.extension sub x + + let iter_type_declaration sub + { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private = _; + ptype_manifest; + ptype_attributes; + ptype_loc; + } = + iter_loc sub ptype_name; + List.iter (iter_fst (sub.typ sub)) ptype_params; + List.iter + (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs; + sub.type_kind sub ptype_kind; + iter_opt (sub.typ sub) ptype_manifest; + sub.location sub ptype_loc; + sub.attributes sub ptype_attributes + + let iter_type_kind sub = function + | Ptype_abstract -> () + | Ptype_variant l -> List.iter (sub.constructor_declaration sub) l + | Ptype_record l -> List.iter (sub.label_declaration sub) l + | Ptype_open -> () + + let iter_constructor_arguments sub = function + | Pcstr_tuple l -> List.iter (sub.typ sub) l + | Pcstr_record l -> List.iter (sub.label_declaration sub) l + + let iter_type_extension sub + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private = _; + ptyext_attributes; + } = + iter_loc sub ptyext_path; + List.iter (sub.extension_constructor sub) ptyext_constructors; + List.iter (iter_fst (sub.typ sub)) ptyext_params; + sub.attributes sub ptyext_attributes + + let iter_extension_constructor_kind sub = function + | Pext_decl (ctl, cto) -> + iter_constructor_arguments sub ctl; + iter_opt (sub.typ sub) cto + | Pext_rebind li -> iter_loc sub li + + let iter_extension_constructor sub + {pext_name; pext_kind; pext_loc; pext_attributes} = + iter_loc sub pext_name; + iter_extension_constructor_kind sub pext_kind; + sub.location sub pext_loc; + sub.attributes sub pext_attributes +end + +module MT = struct + (* Type expressions for the module language *) + + let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmty_ident s -> iter_loc sub s + | Pmty_alias s -> iter_loc sub s + | Pmty_signature sg -> sub.signature sub sg + | Pmty_functor (s, mt1, mt2) -> + iter_loc sub s; + iter_opt (sub.module_type sub) mt1; + sub.module_type sub mt2 + | Pmty_with (mt, l) -> + sub.module_type sub mt; + List.iter (sub.with_constraint sub) l + | Pmty_typeof me -> sub.module_expr sub me + | Pmty_extension x -> sub.extension sub x + + let iter_with_constraint sub = function + | Pwith_type (lid, d) -> + iter_loc sub lid; + sub.type_declaration sub d + | Pwith_module (lid, lid2) -> + iter_loc sub lid; + iter_loc sub lid2 + | Pwith_typesubst (lid, d) -> + iter_loc sub lid; + sub.type_declaration sub d + | Pwith_modsubst (s, lid) -> + iter_loc sub s; + iter_loc sub lid + + let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = + sub.location sub loc; + match desc with + | Psig_value vd -> sub.value_description sub vd + | Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l + | Psig_typext te -> sub.type_extension sub te + | Psig_exception ed -> sub.extension_constructor sub ed + | Psig_module x -> sub.module_declaration sub x + | Psig_recmodule l -> List.iter (sub.module_declaration sub) l + | Psig_modtype x -> sub.module_type_declaration sub x + | Psig_open x -> sub.open_description sub x + | Psig_include x -> sub.include_description sub x + | Psig_extension (x, attrs) -> + sub.extension sub x; + sub.attributes sub attrs + | Psig_attribute x -> sub.attribute sub x +end + +module M = struct + (* Value expressions for the module language *) + + let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pmod_ident x -> iter_loc sub x + | Pmod_structure str -> sub.structure sub str + | Pmod_functor (arg, arg_ty, body) -> + iter_loc sub arg; + iter_opt (sub.module_type sub) arg_ty; + sub.module_expr sub body + | Pmod_apply (m1, m2) -> + sub.module_expr sub m1; + sub.module_expr sub m2 + | Pmod_constraint (m, mty) -> + sub.module_expr sub m; + sub.module_type sub mty + | Pmod_unpack e -> sub.expr sub e + | Pmod_extension x -> sub.extension sub x + + let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + sub.location sub loc; + match desc with + | Pstr_eval (x, attrs) -> + sub.expr sub x; + sub.attributes sub attrs + | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs + | Pstr_primitive vd -> sub.value_description sub vd + | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l + | Pstr_typext te -> sub.type_extension sub te + | Pstr_exception ed -> sub.extension_constructor sub ed + | Pstr_module x -> sub.module_binding sub x + | Pstr_recmodule l -> List.iter (sub.module_binding sub) l + | Pstr_modtype x -> sub.module_type_declaration sub x + | Pstr_open x -> sub.open_description sub x + | Pstr_include x -> sub.include_declaration sub x + | Pstr_extension (x, attrs) -> + sub.extension sub x; + sub.attributes sub attrs + | Pstr_attribute x -> sub.attribute sub x +end + +module E = struct + let iter_jsx_children sub xs = List.iter (sub.expr sub) xs + + let iter_jsx_prop sub = function + | JSXPropPunning (_, name) -> iter_loc sub name + | JSXPropValue (name, _, value) -> + iter_loc sub name; + sub.expr sub value + | JSXPropSpreading (_, e) -> sub.expr sub e + + let iter_jsx_props sub = List.iter (iter_jsx_prop sub) + + (* Value expressions for the core language *) + + let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Pexp_ident x -> iter_loc sub x + | Pexp_constant _ -> () + | Pexp_let (_r, vbs, e) -> + List.iter (sub.value_binding sub) vbs; + sub.expr sub e + | Pexp_fun {default = def; lhs = p; rhs = e} -> + iter_opt (sub.expr sub) def; + sub.pat sub p; + sub.expr sub e + | Pexp_apply {funct = e; args = l} -> + sub.expr sub e; + List.iter (iter_snd (sub.expr sub)) l + | Pexp_match (e, pel) -> + sub.expr sub e; + sub.cases sub pel + | Pexp_try (e, pel) -> + sub.expr sub e; + sub.cases sub pel + | Pexp_tuple el -> List.iter (sub.expr sub) el + | Pexp_construct (lid, arg) -> + iter_loc sub lid; + iter_opt (sub.expr sub) arg + | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo + | Pexp_record (l, eo) -> + List.iter + (fun {lid; x = exp} -> + iter_loc sub lid; + sub.expr sub exp) + l; + iter_opt (sub.expr sub) eo + | Pexp_field (e, lid) -> + sub.expr sub e; + iter_loc sub lid + | Pexp_setfield (e1, lid, e2) -> + sub.expr sub e1; + iter_loc sub lid; + sub.expr sub e2 + | Pexp_array el -> List.iter (sub.expr sub) el + | Pexp_ifthenelse (e1, e2, e3) -> + sub.expr sub e1; + sub.expr sub e2; + iter_opt (sub.expr sub) e3 + | Pexp_sequence (e1, e2) -> + sub.expr sub e1; + sub.expr sub e2 + | Pexp_while (e1, e2) -> + sub.expr sub e1; + sub.expr sub e2 + | Pexp_for (p, e1, e2, _d, e3) -> + sub.pat sub p; + sub.expr sub e1; + sub.expr sub e2; + sub.expr sub e3 + | Pexp_coerce (e, (), t2) -> + sub.expr sub e; + sub.typ sub t2 + | Pexp_constraint (e, t) -> + sub.expr sub e; + sub.typ sub t + | Pexp_send (e, _s) -> sub.expr sub e + | Pexp_letmodule (s, me, e) -> + iter_loc sub s; + sub.module_expr sub me; + sub.expr sub e + | Pexp_letexception (cd, e) -> + sub.extension_constructor sub cd; + sub.expr sub e + | Pexp_assert e -> sub.expr sub e + | Pexp_newtype (_s, e) -> sub.expr sub e + | Pexp_pack me -> sub.module_expr sub me + | Pexp_open (_ovf, lid, e) -> + iter_loc sub lid; + sub.expr sub e + | Pexp_extension x -> sub.extension sub x + | Pexp_await e -> sub.expr sub e + | Pexp_jsx_element (Jsx_fragment {jsx_fragment_children = children}) -> + iter_jsx_children sub children + | Pexp_jsx_element + (Jsx_unary_element + {jsx_unary_element_tag_name = name; jsx_unary_element_props = props}) + -> + iter_loc sub name; + iter_jsx_props sub props + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = name; + jsx_container_element_props = props; + jsx_container_element_children = children; + }) -> + iter_loc sub name; + iter_jsx_props sub props; + iter_jsx_children sub children +end + +module P = struct + (* Patterns *) + + let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + sub.location sub loc; + sub.attributes sub attrs; + match desc with + | Ppat_any -> () + | Ppat_var s -> iter_loc sub s + | Ppat_alias (p, s) -> + sub.pat sub p; + iter_loc sub s + | Ppat_constant _ -> () + | Ppat_interval _ -> () + | Ppat_tuple pl -> List.iter (sub.pat sub) pl + | Ppat_construct (l, p) -> + iter_loc sub l; + iter_opt (sub.pat sub) p + | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p + | Ppat_record (lpl, _cf) -> + List.iter + (fun {lid; x = pat} -> + iter_loc sub lid; + sub.pat sub pat) + lpl + | Ppat_array pl -> List.iter (sub.pat sub) pl + | Ppat_or (p1, p2) -> + sub.pat sub p1; + sub.pat sub p2 + | Ppat_constraint (p, t) -> + sub.pat sub p; + sub.typ sub t + | Ppat_type s -> iter_loc sub s + | Ppat_unpack s -> iter_loc sub s + | Ppat_exception p -> sub.pat sub p + | Ppat_extension x -> sub.extension sub x + | Ppat_open (lid, p) -> + iter_loc sub lid; + sub.pat sub p +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_iterator = + { + structure = (fun this l -> List.iter (this.structure_item this) l); + structure_item = M.iter_structure_item; + module_expr = M.iter; + signature = (fun this l -> List.iter (this.signature_item this) l); + signature_item = MT.iter_signature_item; + module_type = MT.iter; + with_constraint = MT.iter_with_constraint; + type_declaration = T.iter_type_declaration; + type_kind = T.iter_type_kind; + typ = T.iter; + type_extension = T.iter_type_extension; + extension_constructor = T.iter_extension_constructor; + value_description = + (fun this + {pval_name; pval_type; pval_prim = _; pval_loc; pval_attributes} + -> + iter_loc this pval_name; + this.typ this pval_type; + this.attributes this pval_attributes; + this.location this pval_loc); + pat = P.iter; + expr = E.iter; + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + iter_loc this pmd_name; + this.module_type this pmd_type; + this.attributes this pmd_attributes; + this.location this pmd_loc); + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + iter_loc this pmtd_name; + iter_opt (this.module_type this) pmtd_type; + this.attributes this pmtd_attributes; + this.location this pmtd_loc); + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + iter_loc this pmb_name; + this.module_expr this pmb_expr; + this.attributes this pmb_attributes; + this.location this pmb_loc); + open_description = + (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} -> + iter_loc this popen_lid; + this.location this popen_loc; + this.attributes this popen_attributes); + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_type this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes); + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + this.module_expr this pincl_mod; + this.location this pincl_loc; + this.attributes this pincl_attributes); + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + this.pat this pvb_pat; + this.expr this pvb_expr; + this.location this pvb_loc; + this.attributes this pvb_attributes); + constructor_declaration = + (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + iter_loc this pcd_name; + T.iter_constructor_arguments this pcd_args; + iter_opt (this.typ this) pcd_res; + this.location this pcd_loc; + this.attributes this pcd_attributes); + label_declaration = + (fun this + {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes} + -> + iter_loc this pld_name; + this.typ this pld_type; + this.location this pld_loc; + this.attributes this pld_attributes); + cases = (fun this l -> List.iter (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + this.pat this pc_lhs; + iter_opt (this.expr this) pc_guard; + this.expr this pc_rhs); + location = (fun _this _l -> ()); + extension = + (fun this (s, e) -> + iter_loc this s; + this.payload this e); + attribute = + (fun this (s, e) -> + iter_loc this s; + this.payload this e); + attributes = (fun this l -> List.iter (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> this.structure this x + | PSig x -> this.signature this x + | PTyp x -> this.typ this x + | PPat (x, g) -> + this.pat this x; + iter_opt (this.expr this) g); + } diff --git a/jscomp/ml/ast_iterator.mli b/compiler/ml/ast_iterator.mli old mode 100755 new mode 100644 similarity index 88% rename from jscomp/ml/ast_iterator.mli rename to compiler/ml/ast_iterator.mli index 4f5058f..8c7b7a5 --- a/jscomp/ml/ast_iterator.mli +++ b/compiler/ml/ast_iterator.mli @@ -26,13 +26,6 @@ type iterator = { attributes: iterator -> attribute list -> unit; case: iterator -> case -> unit; cases: iterator -> case list -> unit; - class_expr: iterator -> class_expr -> unit; - class_field: iterator -> class_field -> unit; - class_signature: iterator -> class_signature -> unit; - class_structure: iterator -> class_structure -> unit; - class_type: iterator -> class_type -> unit; - class_type_declaration: iterator -> class_type_declaration -> unit; - class_type_field: iterator -> class_type_field -> unit; constructor_declaration: iterator -> constructor_declaration -> unit; expr: iterator -> expression -> unit; extension: iterator -> extension -> unit; @@ -66,5 +59,5 @@ type iterator = { argument the iterator to be applied to children in the syntax tree. *) -val default_iterator: iterator +val default_iterator : iterator (** A default iterator, which implements a "do not do anything" mapping. *) diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml new file mode 100644 index 0000000..6734654 --- /dev/null +++ b/compiler/ml/ast_mapper.ml @@ -0,0 +1,803 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +open Parsetree +open Ast_helper +open Location + +type mapper = { + attribute: mapper -> attribute -> attribute; + attributes: mapper -> attribute list -> attribute list; + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + constructor_declaration: + mapper -> constructor_declaration -> constructor_declaration; + expr: mapper -> expression -> expression; + extension: mapper -> extension -> extension; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; + include_declaration: mapper -> include_declaration -> include_declaration; + include_description: mapper -> include_description -> include_description; + label_declaration: mapper -> label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> module_binding; + module_declaration: mapper -> module_declaration -> module_declaration; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + open_description: mapper -> open_description -> open_description; + pat: mapper -> pattern -> pattern; + payload: mapper -> payload -> payload; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_extension: mapper -> type_extension -> type_extension; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function + | None -> None + | Some x -> Some (f x) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +module T = struct + (* Type expressions for the core language *) + + let row_field sub = function + | Rtag (l, attrs, b, tl) -> + Rtag + (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) + + let object_field sub = function + | Otag (l, attrs, t) -> + Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) + | Oinherit t -> Oinherit (sub.typ sub t) + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ptyp_any -> Typ.any ~loc ~attrs () + | Ptyp_var s -> Typ.var ~loc ~attrs s + | Ptyp_arrow {arg; ret; arity} -> + Typ.arrow ~loc ~attrs ~arity + {arg with typ = sub.typ sub arg.typ} + (sub.typ sub ret) + | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr (lid, tl) -> + Typ.constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_object (l, o) -> + Typ.object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_alias (t, s) -> Typ.alias ~loc ~attrs (sub.typ sub t) s + | Ptyp_variant (rl, b, ll) -> + Typ.variant ~loc ~attrs (List.map (row_field sub) rl) b ll + | Ptyp_poly (sl, t) -> + Typ.poly ~loc ~attrs (List.map (map_loc sub) sl) (sub.typ sub t) + | Ptyp_package (lid, l) -> + Typ.package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_extension x -> Typ.extension ~loc ~attrs (sub.extension sub x) + + let map_type_declaration sub + { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } = + Type.mk (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub.typ sub)) ptype_params) + ~priv:ptype_private + ~cstrs: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + ~loc:(sub.location sub ptype_loc) + ~attrs:(sub.attributes sub ptype_attributes) + + let map_type_kind sub = function + | Ptype_abstract -> Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes; + } = + Te.mk (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + ~attrs:(sub.attributes sub ptyext_attributes) + + let map_extension_constructor_kind sub = function + | Pext_decl (ctl, cto) -> + Pext_decl (map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) + | Pext_rebind li -> Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; pext_kind; pext_loc; pext_attributes} = + Te.constructor (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + ~loc:(sub.location sub pext_loc) + ~attrs:(sub.attributes sub pext_attributes) +end + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) + | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) + | Pmty_functor (s, mt1, mt2) -> + functor_ ~loc ~attrs (map_loc sub s) + (Misc.may_map (sub.module_type sub) mt1) + (sub.module_type sub mt2) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) + | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pwith_type (map_loc sub lid, sub.type_declaration sub d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub.location sub loc in + match desc with + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) + | Psig_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Psig_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) + | Pmod_functor (arg, arg_ty, body) -> + functor_ ~loc ~attrs (map_loc sub arg) + (Misc.may_map (sub.module_type sub) arg_ty) + (sub.module_expr sub body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) + | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub.location sub loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Pstr_open x -> open_ ~loc (sub.open_description sub x) + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module E = struct + let map_jsx_children sub xs = List.map (sub.expr sub) xs + + let map_jsx_prop sub = function + | JSXPropPunning (optional, name) -> + JSXPropPunning (optional, map_loc sub name) + | JSXPropValue (name, optional, value) -> + JSXPropValue (map_loc sub name, optional, sub.expr sub value) + | JSXPropSpreading (loc, e) -> + JSXPropSpreading (sub.location sub loc, sub.expr sub e) + + let map_jsx_props sub = List.map (map_jsx_prop sub) + + (* Value expressions for the core language *) + + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs x + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) + | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async} + -> + fun_ ~loc ~attrs ~arity ~async lab + (map_opt (sub.expr sub) def) + (sub.pat sub p) (sub.expr sub e) + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> + apply ~loc ~attrs ~partial ~transformed_jsx (sub.expr sub e) + (List.map (map_snd (sub.expr sub)) l) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs + (List.map + (fun {lid; x = exp; opt} -> + {lid = map_loc sub lid; x = sub.expr sub exp; opt}) + l) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) + | Pexp_coerce (e, (), t2) -> + coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_newtype (s, e) -> + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_open (ovf, lid, e) -> + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pexp_await e -> await ~loc ~attrs (sub.expr sub e) + | Pexp_jsx_element + (Jsx_fragment + { + jsx_fragment_opening = o; + jsx_fragment_children = children; + jsx_fragment_closing = c; + }) -> + jsx_fragment ~loc ~attrs o (map_jsx_children sub children) c + | Pexp_jsx_element + (Jsx_unary_element + {jsx_unary_element_tag_name = name; jsx_unary_element_props = props}) + -> + jsx_unary_element ~loc ~attrs (map_loc sub name) (map_jsx_props sub props) + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = name; + jsx_container_element_opening_tag_end = ote; + jsx_container_element_props = props; + jsx_container_element_children = children; + jsx_container_element_closing_tag = closing_tag; + }) -> + jsx_container_element ~loc ~attrs (map_loc sub name) + (map_jsx_props sub props) ote + (map_jsx_children sub children) + closing_tag +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let open Pat in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ppat_any -> any ~loc ~attrs () + | Ppat_var s -> var ~loc ~attrs (map_loc sub s) + | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs c + | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs + (List.map + (fun {lid; x = pat; opt} -> + {lid = map_loc sub lid; x = sub.pat sub pat; opt}) + lpl) + cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid, p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_mapper = + { + structure = (fun this l -> List.map (this.structure_item this) l); + structure_item = M.map_structure_item; + module_expr = M.map; + signature = (fun this l -> List.map (this.signature_item this) l); + signature_item = MT.map_signature_item; + module_type = MT.map; + with_constraint = MT.map_with_constraint; + type_declaration = T.map_type_declaration; + type_kind = T.map_type_kind; + typ = T.map; + type_extension = T.map_type_extension; + extension_constructor = T.map_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> + Val.mk (map_loc this pval_name) (this.typ this pval_type) + ~attrs:(this.attributes this pval_attributes) + ~loc:(this.location this pval_loc) + ~prim:pval_prim); + pat = P.map; + expr = E.map; + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + Md.mk (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc)); + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + Mtd.mk (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc)); + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + Mb.mk (map_loc this pmb_name) + (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc)); + open_description = + (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_lid) ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes)); + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes)); + constructor_declaration = + (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor (map_loc this pcd_name) + ~args:(T.map_constructor_arguments this pcd_args) + ?res:(map_opt (this.typ this) pcd_res) + ~loc:(this.location this pcd_loc) + ~attrs:(this.attributes this pcd_attributes)); + label_declaration = + (fun this + {pld_name; pld_type; pld_loc; pld_mutable; pld_optional; pld_attributes} + -> + Type.field (map_loc this pld_name) (this.typ this pld_type) + ~mut:pld_mutable ~optional:pld_optional + ~loc:(this.location this pld_loc) + ~attrs:(this.attributes this pld_attributes)); + cases = (fun this l -> List.map (this.case this) l); + case = + (fun this {pc_bar; pc_lhs; pc_guard; pc_rhs} -> + { + pc_bar; + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + }); + location = (fun _this l -> l); + extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attributes = (fun this l -> List.map (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); + } + +let rec extension_of_error {loc; msg; if_highlight; sub} = + ( {loc; txt = "ocaml.error"}, + PStr + ([ + Str.eval (Exp.constant (Pconst_string (msg, None))); + Str.eval (Exp.constant (Pconst_string (if_highlight, None))); + ] + @ List.map (fun ext -> Str.extension (extension_of_error ext)) sub) ) + +let attribute_of_warning loc s = + ( {loc; txt = "ocaml.ppwarning"}, + PStr [Str.eval ~loc (Exp.constant (Pconst_string (s, None)))] ) + +module StringMap = Map.Make (struct + type t = string + let compare = compare +end) + +let cookies = ref StringMap.empty + +let get_cookie k = try Some (StringMap.find k !cookies) with Not_found -> None + +let set_cookie k v = cookies := StringMap.add k v !cookies + +let tool_name_ref = ref "_none_" + +let tool_name () = !tool_name_ref + +module PpxContext = struct + open Longident + open Asttypes + open Ast_helper + + let lid name = {txt = Lident name; loc = Location.none} + + let make_string x = Exp.constant (Pconst_string (x, None)) + + let make_bool x = + if x then Exp.construct (lid "true") None + else Exp.construct (lid "false") None + + let rec make_list f lst = + match lst with + | x :: rest -> + Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) + | [] -> Exp.construct (lid "[]") None + + let make_pair f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] + + let get_cookies () = + { + lid = lid "cookies"; + x = + make_list + (make_pair make_string (fun x -> x)) + (StringMap.bindings !cookies); + opt = false; + } + + let mk fields = + ( {txt = "ocaml.ppx.context"; loc = Location.none}, + Parsetree.PStr [Str.eval (Exp.record fields None)] ) + + let make ~tool_name () = + let fields = + [ + {lid = lid "tool_name"; x = make_string tool_name; opt = false}; + { + lid = lid "include_dirs"; + x = make_list make_string !Clflags.include_dirs; + opt = false; + }; + { + lid = lid "load_path"; + x = make_list make_string !Config.load_path; + opt = false; + }; + { + lid = lid "open_modules"; + x = make_list make_string !Clflags.open_modules; + opt = false; + }; + {lid = lid "debug"; x = make_bool !Clflags.debug; opt = false}; + get_cookies (); + ] + in + mk fields + + let get_fields = function + | PStr + [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (fields, None)}, [])}] + -> + fields + | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" + + let restore fields = + let field name payload = + let rec get_string = function + | {pexp_desc = Pexp_constant (Pconst_string (str, None))} -> str + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] string \ + syntax" + name + and get_bool pexp = + match pexp with + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} + -> + true + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} + -> + false + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax" + name + and get_list elem = function + | { + pexp_desc = + Pexp_construct + ( {txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple [exp; rest]} ); + } -> + elem exp :: get_list elem rest + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> + [] + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" + name + and get_pair f1 f2 = function + | {pexp_desc = Pexp_tuple [e1; e2]} -> (f1 e1, f2 e2) + | _ -> + raise_errorf + "Internal error: invalid [@@@ocaml.ppx.context { %s }] pair syntax" + name + in + match name with + | "tool_name" -> tool_name_ref := get_string payload + | "include_dirs" -> Clflags.include_dirs := get_list get_string payload + | "load_path" -> Config.load_path := get_list get_string payload + | "open_modules" -> Clflags.open_modules := get_list get_string payload + | "debug" -> Clflags.debug := get_bool payload + | "cookies" -> + let l = get_list (get_pair get_string (fun x -> x)) payload in + cookies := + List.fold_left (fun s (k, v) -> StringMap.add k v s) StringMap.empty l + | _ -> () + in + List.iter + (function + | {lid = {txt = Lident name}; x} -> field name x + | _ -> ()) + fields + + let update_cookies fields = + let fields = + Ext_list.filter fields (function + | {lid = {txt = Lident "cookies"}} -> false + | _ -> true) + in + fields @ [get_cookies ()] +end + +let ppx_context = PpxContext.make + +let extension_of_exn exn = + match error_of_exn exn with + | Some (`Ok error) -> extension_of_error error + | Some `Already_displayed -> + ({loc = Location.none; txt = "ocaml.error"}, PStr []) + | None -> raise exn + +let apply_lazy ~source ~target mapper = + let implem ast = + let fields, ast = + match ast with + | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + (PpxContext.get_fields x, l) + | _ -> ([], ast) + in + PpxContext.restore fields; + let ast = + try + let mapper = mapper () in + mapper.structure mapper ast + with exn -> + [ + { + pstr_desc = Pstr_extension (extension_of_exn exn, []); + pstr_loc = Location.none; + }; + ] + in + let fields = PpxContext.update_cookies fields in + Str.attribute (PpxContext.mk fields) :: ast + in + let iface ast = + let fields, ast = + match ast with + | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> + (PpxContext.get_fields x, l) + | _ -> ([], ast) + in + PpxContext.restore fields; + let ast = + try + let mapper = mapper () in + mapper.signature mapper ast + with exn -> + [ + { + psig_desc = Psig_extension (extension_of_exn exn, []); + psig_loc = Location.none; + }; + ] + in + let fields = PpxContext.update_cookies fields in + Sig.attribute (PpxContext.mk fields) :: ast + in + + let ic = open_in_bin source in + let magic = + really_input_string ic (String.length Config.ast_impl_magic_number) + in + + let rewrite transform = + Location.set_input_name @@ input_value ic; + let ast = input_value ic in + close_in ic; + let ast = transform ast in + let oc = open_out_bin target in + output_string oc magic; + output_value oc !Location.input_name; + output_value oc ast; + close_out oc + and fail () = + close_in ic; + failwith "Ast_mapper: OCaml version mismatch or malformed input" + in + + if magic = Config.ast_impl_magic_number then + rewrite (implem : structure -> structure) + else if magic = Config.ast_intf_magic_number then + rewrite (iface : signature -> signature) + else fail () + +let drop_ppx_context_str ~restore = function + | {pstr_desc = Pstr_attribute ({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let drop_ppx_context_sig ~restore = function + | {psig_desc = Psig_attribute ({Location.txt = "ocaml.ppx.context"}, a)} + :: items -> + if restore then PpxContext.restore (PpxContext.get_fields a); + items + | items -> items + +let add_ppx_context_str ~tool_name ast = + Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast + +let add_ppx_context_sig ~tool_name ast = + Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast + +let apply ~source ~target mapper = apply_lazy ~source ~target (fun () -> mapper) + +let run_main mapper = + try + let a = Sys.argv in + let n = Array.length a in + if n > 2 then + let mapper () = + try mapper (Array.to_list (Array.sub a 1 (n - 3))) + with exn -> + (* PR#6463 *) + let f _ _ = raise exn in + {default_mapper with structure = f; signature = f} + in + apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper + else ( + Printf.eprintf "Usage: %s [extra_args] \n%!" + Sys.executable_name; + exit 2) + with exn -> + prerr_endline (Printexc.to_string exn); + exit 2 + +let register_function = ref (fun _name f -> run_main f) +let register name f = !register_function name f diff --git a/jscomp/ml/ast_mapper.mli b/compiler/ml/ast_mapper.mli similarity index 80% rename from jscomp/ml/ast_mapper.mli rename to compiler/ml/ast_mapper.mli index 3a4044d..745fdb8 100644 --- a/jscomp/ml/ast_mapper.mli +++ b/compiler/ml/ast_mapper.mli @@ -57,20 +57,12 @@ type mapper = { attributes: mapper -> attribute list -> attribute list; case: mapper -> case -> case; cases: mapper -> case list -> case list; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; + constructor_declaration: + mapper -> constructor_declaration -> constructor_declaration; expr: mapper -> expression -> expression; extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; include_declaration: mapper -> include_declaration -> include_declaration; include_description: mapper -> include_description -> include_description; label_declaration: mapper -> label_declaration -> label_declaration; @@ -79,8 +71,8 @@ type mapper = { module_declaration: mapper -> module_declaration -> module_declaration; module_expr: mapper -> module_expr -> module_expr; module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; open_description: mapper -> open_description -> open_description; pat: mapper -> pattern -> pattern; payload: mapper -> payload -> payload; @@ -101,12 +93,12 @@ type mapper = { argument the mapper to be applied to children in the syntax tree. *) -val default_mapper: mapper +val default_mapper : mapper (** A default mapper, which implements a "deep identity" mapping. *) (** {1 Apply mappers to compilation units} *) -val tool_name: unit -> string +val tool_name : unit -> string (** Can be used within a ppx preprocessor to know which tool is calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], ["ocaml"], ... Some global variables that reflect command-line @@ -115,14 +107,13 @@ val tool_name: unit -> string {!Config.load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, {!Clflags.debug}. *) - -val apply: source:string -> target:string -> mapper -> unit +val apply : source:string -> target:string -> mapper -> unit (** Apply a mapper (parametrized by the unit name) to a dumped parsetree found in the [source] file and put the result in the [target] file. The [structure] or [signature] field of the mapper is applied to the implementation or interface. *) -val run_main: (string list -> mapper) -> unit +val run_main : (string list -> mapper) -> unit (** Entry point to call to implement a standalone -ppx rewriter from a mapper, parametrized by the command line arguments. The current unit name can be obtained from {!Location.input_name}. This @@ -131,9 +122,9 @@ val run_main: (string list -> mapper) -> unit (** {1 Registration API} *) -val register_function: (string -> (string list -> mapper) -> unit) ref +val register_function : (string -> (string list -> mapper) -> unit) ref -val register: string -> (string list -> mapper) -> unit +val register : string -> (string list -> mapper) -> unit (** Apply the [register_function]. The default behavior is to run the mapper immediately, taking arguments from the process command line. This is to support a scenario where a mapper is linked as a @@ -150,42 +141,41 @@ val register: string -> (string list -> mapper) -> unit The first argument to [register] is a symbolic name to be used by the ppx driver. *) - (** {1 Convenience functions to write mappers} *) -val map_opt: ('a -> 'b) -> 'a option -> 'b option +val map_opt : ('a -> 'b) -> 'a option -> 'b option -val extension_of_error: Location.error -> extension +val extension_of_error : Location.error -> extension (** Encode an error into an 'ocaml.error' extension node which can be inserted in a generated Parsetree. The compiler will be responsible for reporting the error. *) -val attribute_of_warning: Location.t -> string -> attribute +val attribute_of_warning : Location.t -> string -> attribute (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be inserted in a generated Parsetree. The compiler will be responsible for reporting the warning. *) (** {1 Helper functions to call external mappers} *) -val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure +val add_ppx_context_str : + tool_name:string -> Parsetree.structure -> Parsetree.structure (** Extract information from the current environment and encode it into an attribute which is prepended to the list of structure items in order to pass the information to an external processor. *) -val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature +val add_ppx_context_sig : + tool_name:string -> Parsetree.signature -> Parsetree.signature (** Same as [add_ppx_context_str], but for signatures. *) -val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure +val drop_ppx_context_str : + restore:bool -> Parsetree.structure -> Parsetree.structure (** Drop the ocaml.ppx.context attribute from a structure. If [restore] is true, also restore the associated data in the current process. *) -val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature +val drop_ppx_context_sig : + restore:bool -> Parsetree.signature -> Parsetree.signature (** Same as [drop_ppx_context_str], but for signatures. *) (** {1 Cookies} *) @@ -194,5 +184,5 @@ val drop_ppx_context_sig: a further invocation of itself, when called from the OCaml toplevel (or other tools that support cookies). *) -val set_cookie: string -> Parsetree.expression -> unit -val get_cookie: string -> Parsetree.expression option +val set_cookie : string -> Parsetree.expression -> unit +val get_cookie : string -> Parsetree.expression option diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml new file mode 100644 index 0000000..3f91d6a --- /dev/null +++ b/compiler/ml/ast_mapper_from0.ml @@ -0,0 +1,705 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +open Parsetree0 +open Ast_helper +open Location +module Pt = Parsetree + +type mapper = { + attribute: mapper -> attribute -> Pt.attribute; + attributes: mapper -> attribute list -> Pt.attribute list; + case: mapper -> case -> Pt.case; + cases: mapper -> case list -> Pt.case list; + constructor_declaration: + mapper -> constructor_declaration -> Pt.constructor_declaration; + expr: mapper -> expression -> Pt.expression; + extension: mapper -> extension -> Pt.extension; + extension_constructor: + mapper -> extension_constructor -> Pt.extension_constructor; + include_declaration: mapper -> include_declaration -> Pt.include_declaration; + include_description: mapper -> include_description -> Pt.include_description; + label_declaration: mapper -> label_declaration -> Pt.label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> Pt.module_binding; + module_declaration: mapper -> module_declaration -> Pt.module_declaration; + module_expr: mapper -> module_expr -> Pt.module_expr; + module_type: mapper -> module_type -> Pt.module_type; + module_type_declaration: + mapper -> module_type_declaration -> Pt.module_type_declaration; + open_description: mapper -> open_description -> Pt.open_description; + pat: mapper -> pattern -> Pt.pattern; + payload: mapper -> payload -> Pt.payload; + signature: mapper -> signature -> Pt.signature; + signature_item: mapper -> signature_item -> Pt.signature_item; + structure: mapper -> structure -> Pt.structure; + structure_item: mapper -> structure_item -> Pt.structure_item; + typ: mapper -> core_type -> Pt.core_type; + type_declaration: mapper -> type_declaration -> Pt.type_declaration; + type_extension: mapper -> type_extension -> Pt.type_extension; + type_kind: mapper -> type_kind -> Pt.type_kind; + value_binding: mapper -> value_binding -> Pt.value_binding; + value_description: mapper -> value_description -> Pt.value_description; + with_constraint: mapper -> with_constraint -> Pt.with_constraint; +} + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function + | None -> None + | Some x -> Some (f x) +let map_constant = function + | Pconst_integer (s, suffix) -> Pt.Pconst_integer (s, suffix) + | Pconst_char c -> Pconst_char c + | Pconst_string (s, q) -> Pconst_string (s, q) + | Pconst_float (s, suffix) -> Pconst_float (s, suffix) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +module T = struct + (* Type expressions for the core language *) + + let row_field sub = function + | Rtag (l, attrs, b, tl) -> + Pt.Rtag + (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) + + let object_field sub = function + | Otag (l, attrs, t) -> + Pt.Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) + | Oinherit t -> Oinherit (sub.typ sub t) + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ptyp_any -> Typ.any ~loc ~attrs () + | Ptyp_var s -> Typ.var ~loc ~attrs s + | Ptyp_arrow (lbl, t1, t2) -> + let lbl = Asttypes.to_arg_label lbl in + Typ.arrow ~loc ~arity:None + {attrs; lbl; typ = sub.typ sub t1} + (sub.typ sub t2) + | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr (lid, tl) -> ( + let typ0 = + Typ.constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + in + match typ0.ptyp_desc with + | Ptyp_constr (lid, [({ptyp_desc = Ptyp_arrow arr} as fun_t); t_arity]) + when lid.txt = Lident "function$" -> + let decode_arity_string arity_s = + int_of_string + ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) + in + let arity_from_type (typ : Parsetree.core_type) = + match typ.ptyp_desc with + | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> + decode_arity_string txt + | _ -> assert false + in + let arity = arity_from_type t_arity in + {fun_t with ptyp_desc = Ptyp_arrow {arr with arity = Some arity}} + | _ -> typ0) + | Ptyp_object (l, o) -> + Typ.object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_class () -> assert false + | Ptyp_alias (t, s) -> Typ.alias ~loc ~attrs (sub.typ sub t) s + | Ptyp_variant (rl, b, ll) -> + Typ.variant ~loc ~attrs (List.map (row_field sub) rl) b ll + | Ptyp_poly (sl, t) -> + Typ.poly ~loc ~attrs (List.map (map_loc sub) sl) (sub.typ sub t) + | Ptyp_package (lid, l) -> + Typ.package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_extension x -> Typ.extension ~loc ~attrs (sub.extension sub x) + + let map_type_declaration sub + { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } = + Type.mk (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub.typ sub)) ptype_params) + ~priv:ptype_private + ~cstrs: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + ~loc:(sub.location sub ptype_loc) + ~attrs:(sub.attributes sub ptype_attributes) + + let map_type_kind sub = function + | Ptype_abstract -> Pt.Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pt.Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> Pt.Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes; + } = + Te.mk (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + ~attrs:(sub.attributes sub ptyext_attributes) + + let map_extension_constructor_kind sub = function + | Pext_decl (ctl, cto) -> + Pt.Pext_decl (map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) + | Pext_rebind li -> Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; pext_kind; pext_loc; pext_attributes} = + Te.constructor (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + ~loc:(sub.location sub pext_loc) + ~attrs:(sub.attributes sub pext_attributes) +end + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) + | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) + | Pmty_functor (s, mt1, mt2) -> + functor_ ~loc ~attrs (map_loc sub s) + (Misc.may_map (sub.module_type sub) mt1) + (sub.module_type sub mt2) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) + | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pt.Pwith_type (map_loc sub lid, sub.type_declaration sub d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub.location sub loc in + match desc with + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) + | Psig_class _ -> assert false + | Psig_class_type _ -> assert false + | Psig_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Psig_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) + | Pmod_functor (arg, arg_ty, body) -> + functor_ ~loc ~attrs (map_loc sub arg) + (Misc.may_map (sub.module_type sub) arg_ty) + (sub.module_expr sub body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) + | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub.location sub loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Pstr_open x -> open_ ~loc (sub.open_description sub x) + | Pstr_class () -> failwith "Pstr_class is no longer present in ReScript" + | Pstr_class_type () -> + failwith "Pstr_class_type is no longer present in ReScript" + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module E = struct + (* Value expressions for the core language *) + + let has_await_attribute attrs = + List.exists + (function + | {Location.txt = "res.await"}, _ -> true + | _ -> false) + attrs + + let remove_await_attribute attrs = + List.filter + (function + | {Location.txt = "res.await"}, _ -> false + | _ -> true) + attrs + + let map_jsx_children sub (e : expression) : Pt.jsx_children = + let rec visit (e : expression) : Pt.expression list = + match e.pexp_desc with + | Pexp_construct + ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [e1; e2]}) + -> + sub.expr sub e1 :: visit e2 + | Pexp_construct ({txt = Longident.Lident "[]"}, ext_opt) -> ( + match ext_opt with + | None -> [] + | Some e -> visit e) + | _ -> [sub.expr sub e] + in + match e.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "[]" | Longident.Lident "::"}, _) + -> + visit e + | _ -> [sub.expr sub e] + + let try_map_jsx_prop (sub : mapper) (lbl : Asttypes.Noloc.arg_label) + (e : expression) : Parsetree.jsx_prop option = + match (lbl, e) with + | Asttypes.Noloc.Labelled "_spreadProps", expr -> + Some (Parsetree.JSXPropSpreading (Location.none, sub.expr sub expr)) + | ( Asttypes.Noloc.Labelled name, + {pexp_desc = Pexp_ident {txt = Longident.Lident v}; pexp_loc = name_loc} + ) + when name = v -> + Some (Parsetree.JSXPropPunning (false, {txt = name; loc = name_loc})) + | ( Asttypes.Noloc.Optional name, + {pexp_desc = Pexp_ident {txt = Longident.Lident v}; pexp_loc = name_loc} + ) + when name = v -> + Some (Parsetree.JSXPropPunning (true, {txt = name; loc = name_loc})) + | Asttypes.Noloc.Labelled name, exp -> + Some + (Parsetree.JSXPropValue + ({txt = name; loc = Location.none}, false, sub.expr sub exp)) + | Asttypes.Noloc.Optional name, exp -> + Some + (Parsetree.JSXPropValue + ({txt = name; loc = Location.none}, true, sub.expr sub exp)) + | _ -> None + + let extract_props_and_children (sub : mapper) items = + let rec visit props items = + match items with + | [] | [_] -> (List.rev props, None) + | [(Asttypes.Noloc.Labelled "children", children_expr); _] -> + (List.rev props, Some (map_jsx_children sub children_expr)) + | (lbl, e) :: rest -> ( + match try_map_jsx_prop sub lbl e with + | Some prop -> visit (prop :: props) rest + | None -> visit props rest) + in + let props, children = visit [] items in + (props, children) + + let map sub e = + let {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = e in + let open Exp in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + let has_jsx_attribute () = + attrs |> List.exists (fun ({txt}, _) -> txt = "JSX") + in + match desc with + | _ when has_await_attribute attrs -> + let attrs = remove_await_attribute e.pexp_attributes in + let e = sub.expr sub {e with pexp_attributes = attrs} in + await ~loc e + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs (map_constant x) + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) + | Pexp_fun (lab, def, p, e) -> + let lab = Asttypes.to_arg_label lab in + let async = Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.async") in + fun_ ~loc ~attrs ~async ~arity:None lab + (map_opt (sub.expr sub) def) + (sub.pat sub p) (sub.expr sub e) + | Pexp_function _ -> assert false + | Pexp_apply ({pexp_desc = Pexp_ident tag_name}, args) + when has_jsx_attribute () -> ( + let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "JSX") in + let props, children = extract_props_and_children sub args in + let jsx_tag : Pt.jsx_tag_name = + match tag_name.txt with + | Longident.Lident s + when String.length s > 0 && Char.lowercase_ascii s.[0] = s.[0] -> + Pt.JsxLowerTag s + | Longident.Lident _ -> Pt.JsxUpperTag tag_name.txt + | Longident.Ldot (path, last) + when String.length last > 0 + && Char.lowercase_ascii last.[0] = last.[0] -> + Pt.JsxQualifiedLowerTag {path; name = last} + | _ -> Pt.JsxUpperTag tag_name.txt + in + let jsx_tag_name = {txt = jsx_tag; loc = tag_name.loc} in + match children with + | None -> jsx_unary_element ~loc ~attrs jsx_tag_name props + | Some children -> + jsx_container_element ~loc ~attrs jsx_tag_name props Lexing.dummy_pos + children None) + | Pexp_apply (e, l) -> + let e = + match (e.pexp_desc, l) with + | ( Pexp_ident ({txt = Longident.Lident "|."} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "->"}} + | ( Pexp_ident ({txt = Longident.Lident "^"} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "++"}} + | ( Pexp_ident ({txt = Longident.Lident "<>"} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "!="}} + | ( Pexp_ident ({txt = Longident.Lident "!="} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + { + e with + pexp_desc = Pexp_ident {lid with txt = Longident.Lident "!=="}; + } + | ( Pexp_ident ({txt = Longident.Lident "="} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "=="}} + | ( Pexp_ident ({txt = Longident.Lident "=="} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + { + e with + pexp_desc = Pexp_ident {lid with txt = Longident.Lident "==="}; + } + | _ -> e + in + let process_partial_app_attribute attrs = + let rec process partial_app acc attrs = + match attrs with + | [] -> (partial_app, List.rev acc) + | ({Location.txt = "res.partial"}, _) :: rest -> process true acc rest + | attr :: rest -> process partial_app (attr :: acc) rest + in + process false [] attrs + in + let partial, attrs = process_partial_app_attribute attrs in + apply ~loc ~attrs ~partial (sub.expr sub e) + (List.map + (fun (lbl, e) -> (Asttypes.to_arg_label lbl, sub.expr sub e)) + l) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + (* <> *) + | Pexp_construct ({txt = Longident.Lident "[]" | Longident.Lident "::"}, _) + when has_jsx_attribute () -> + let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "JSX") in + jsx_fragment ~loc ~attrs loc.loc_start (map_jsx_children sub e) + loc.loc_end + | Pexp_construct (lid, arg) -> ( + let lid1 = map_loc sub lid in + let arg1 = map_opt (sub.expr sub) arg in + let exp1 = construct ~loc ~attrs lid1 arg1 in + match lid.txt with + | Lident "Function$" -> ( + let rec attributes_to_arity (attrs : Parsetree.attributes) = + match attrs with + | ( {txt = "res.arity"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ( {pexp_desc = Pexp_constant (Pconst_integer (arity, _))}, + _ ); + }; + ] ) + :: _ -> + int_of_string arity + | _ :: rest -> attributes_to_arity rest + | [] -> assert false + in + match arg1 with + | Some ({pexp_desc = Pexp_fun f} as e1) -> + let arity = Some (attributes_to_arity attrs) in + {e1 with pexp_desc = Pexp_fun {f with arity}} + | _ -> exp1) + | _ -> exp1) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs + (Ext_list.map l (fun (lid, e) -> + let lid1 = map_loc sub lid in + let e1 = sub.expr sub e in + let optional, attrs = + Parsetree0.get_optional_attr e1.pexp_attributes + in + { + Pt.lid = lid1; + x = {e1 with pexp_attributes = attrs}; + opt = optional; + })) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) + | Pexp_coerce (e, (), t2) -> + coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_new _ -> failwith "Pexp_new is no longer present in ReScript" + | Pexp_setinstvar _ -> + failwith "Pexp_setinstvar is no longer present in ReScript" + | Pexp_override _ -> + failwith "Pexp_override is no longer present in ReScript" + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_lazy _ -> failwith "Pexp_lazy is no longer present in ReScript" + | Pexp_poly _ -> failwith "Pexp_poly is no longer present in ReScript" + | Pexp_object () -> assert false + | Pexp_newtype (s, e) -> + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_open (ovf, lid, e) -> + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pexp_unreachable -> assert false +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let open Pat in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ppat_any -> any ~loc ~attrs () + | Ppat_var s -> var ~loc ~attrs (map_loc sub s) + | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs (map_constant c) + | Ppat_interval (c1, c2) -> + interval ~loc ~attrs (map_constant c1) (map_constant c2) + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs + (Ext_list.map lpl (fun (lid, p) -> + let lid1 = map_loc sub lid in + let p1 = sub.pat sub p in + let optional, attrs = + Parsetree0.get_optional_attr p1.ppat_attributes + in + { + Pt.lid = lid1; + x = {p1 with ppat_attributes = attrs}; + opt = optional; + })) + cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_lazy _ -> failwith "Ppat_lazy is no longer present in ReScript" + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid, p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_mapper = + { + structure = (fun this l -> List.map (this.structure_item this) l); + structure_item = M.map_structure_item; + module_expr = M.map; + signature = (fun this l -> List.map (this.signature_item this) l); + signature_item = MT.map_signature_item; + module_type = MT.map; + with_constraint = MT.map_with_constraint; + type_declaration = T.map_type_declaration; + type_kind = T.map_type_kind; + typ = T.map; + type_extension = T.map_type_extension; + extension_constructor = T.map_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> + Val.mk (map_loc this pval_name) (this.typ this pval_type) + ~attrs:(this.attributes this pval_attributes) + ~loc:(this.location this pval_loc) + ~prim:pval_prim); + pat = P.map; + expr = E.map; + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + Md.mk (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc)); + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + Mtd.mk (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc)); + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + Mb.mk (map_loc this pmb_name) + (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc)); + open_description = + (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_lid) ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes)); + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes)); + constructor_declaration = + (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor (map_loc this pcd_name) + ~args:(T.map_constructor_arguments this pcd_args) + ?res:(map_opt (this.typ this) pcd_res) + ~loc:(this.location this pcd_loc) + ~attrs:(this.attributes this pcd_attributes)); + label_declaration = + (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> + let optional, attrs = + Parsetree0.get_optional_attr (this.attributes this pld_attributes) + in + Type.field (map_loc this pld_name) (this.typ this pld_type) + ~mut:pld_mutable ~optional + ~loc:(this.location this pld_loc) + ~attrs); + cases = (fun this l -> List.map (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + { + pc_bar = None; + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + }); + location = (fun _this l -> l); + extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attributes = (fun this l -> List.map (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); + } diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml new file mode 100644 index 0000000..d0ac43d --- /dev/null +++ b/compiler/ml/ast_mapper_to0.ml @@ -0,0 +1,684 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(* A generic Parsetree mapping class *) + +(* +[@@@warning "+9"] + (* Ensure that record patterns don't miss any field. *) +*) + +open Parsetree +open Ast_helper0 +open Location +module Pt = Parsetree0 + +type mapper = { + attribute: mapper -> attribute -> Pt.attribute; + attributes: mapper -> attribute list -> Pt.attribute list; + case: mapper -> case -> Pt.case; + cases: mapper -> case list -> Pt.case list; + constructor_declaration: + mapper -> constructor_declaration -> Pt.constructor_declaration; + expr: mapper -> expression -> Pt.expression; + extension: mapper -> extension -> Pt.extension; + extension_constructor: + mapper -> extension_constructor -> Pt.extension_constructor; + include_declaration: mapper -> include_declaration -> Pt.include_declaration; + include_description: mapper -> include_description -> Pt.include_description; + label_declaration: mapper -> label_declaration -> Pt.label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> module_binding -> Pt.module_binding; + module_declaration: mapper -> module_declaration -> Pt.module_declaration; + module_expr: mapper -> module_expr -> Pt.module_expr; + module_type: mapper -> module_type -> Pt.module_type; + module_type_declaration: + mapper -> module_type_declaration -> Pt.module_type_declaration; + open_description: mapper -> open_description -> Pt.open_description; + pat: mapper -> pattern -> Pt.pattern; + payload: mapper -> payload -> Pt.payload; + signature: mapper -> signature -> Pt.signature; + signature_item: mapper -> signature_item -> Pt.signature_item; + structure: mapper -> structure -> Pt.structure; + structure_item: mapper -> structure_item -> Pt.structure_item; + typ: mapper -> core_type -> Pt.core_type; + type_declaration: mapper -> type_declaration -> Pt.type_declaration; + type_extension: mapper -> type_extension -> Pt.type_extension; + type_kind: mapper -> type_kind -> Pt.type_kind; + value_binding: mapper -> value_binding -> Pt.value_binding; + value_description: mapper -> value_description -> Pt.value_description; + with_constraint: mapper -> with_constraint -> Pt.with_constraint; +} + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function + | None -> None + | Some x -> Some (f x) +let map_constant = function + | Pconst_integer (s, suffix) -> Pt.Pconst_integer (s, suffix) + | Pconst_char c -> Pconst_char c + | Pconst_string (s, q) -> Pconst_string (s, q) + | Pconst_float (s, suffix) -> Pconst_float (s, suffix) + +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} + +module T = struct + (* Type expressions for the core language *) + + let row_field sub = function + | Rtag (l, attrs, b, tl) -> + Pt.Rtag + (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) + + let object_field sub = function + | Otag (l, attrs, t) -> + Pt.Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) + | Oinherit t -> Oinherit (sub.typ sub t) + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = + let open Typ in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ptyp_any -> any ~loc ~attrs () + | Ptyp_var s -> var ~loc ~attrs s + | Ptyp_arrow {arg; ret; arity} -> ( + let lbl = Asttypes.to_noloc arg.lbl in + let typ0 = + arrow ~loc + ~attrs:(attrs @ sub.attributes sub arg.attrs) + lbl (sub.typ sub arg.typ) (sub.typ sub ret) + in + match arity with + | None -> typ0 + | Some arity -> + let arity_string = "Has_arity" ^ string_of_int arity in + let arity_type = + Ast_helper0.Typ.variant ~loc + [Rtag (Location.mknoloc arity_string, [], true, [])] + Closed None + in + Ast_helper0.Typ.constr ~loc + {txt = Lident "function$"; loc} + [typ0; arity_type]) + | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) + | Ptyp_constr (lid, tl) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s + | Ptyp_variant (rl, b, ll) -> + variant ~loc ~attrs (List.map (row_field sub) rl) b ll + | Ptyp_poly (sl, t) -> + poly ~loc ~attrs (List.map (map_loc sub) sl) (sub.typ sub t) + | Ptyp_package (lid, l) -> + package ~loc ~attrs (map_loc sub lid) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) + | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_type_declaration sub + { + ptype_name; + ptype_params; + ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc; + } = + Type.mk (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub.typ sub)) ptype_params) + ~priv:ptype_private + ~cstrs: + (List.map + (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) + ptype_cstrs) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + ~loc:(sub.location sub ptype_loc) + ~attrs:(sub.attributes sub ptype_attributes) + + let map_type_kind sub = function + | Ptype_abstract -> Pt.Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) + | Ptype_open -> Ptype_open + + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pt.Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> Pt.Pcstr_record (List.map (sub.label_declaration sub) l) + + let map_type_extension sub + { + ptyext_path; + ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_attributes; + } = + Te.mk (map_loc sub ptyext_path) + (List.map (sub.extension_constructor sub) ptyext_constructors) + ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) + ~priv:ptyext_private + ~attrs:(sub.attributes sub ptyext_attributes) + + let map_extension_constructor_kind sub = function + | Pext_decl (ctl, cto) -> + Pt.Pext_decl (map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) + | Pext_rebind li -> Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; pext_kind; pext_loc; pext_attributes} = + Te.constructor (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + ~loc:(sub.location sub pext_loc) + ~attrs:(sub.attributes sub pext_attributes) +end + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) + | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) + | Pmty_functor (s, mt1, mt2) -> + functor_ ~loc ~attrs (map_loc sub s) + (Misc.may_map (sub.module_type sub) mt1) + (sub.module_type sub mt2) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) + | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pt.Pwith_type (map_loc sub lid, sub.type_declaration sub d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) + | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub.location sub loc in + match desc with + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) + | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_open x -> open_ ~loc (sub.open_description sub x) + | Psig_include x -> include_ ~loc (sub.include_description sub x) + | Psig_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Psig_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) + | Pmod_functor (arg, arg_ty, body) -> + functor_ ~loc ~attrs (map_loc sub arg) + (Misc.may_map (sub.module_type sub) arg_ty) + (sub.module_expr sub body) + | Pmod_apply (m1, m2) -> + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) + | Pmod_constraint (m, mty) -> + constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) + | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub.location sub loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) + | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) + | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Pstr_open x -> open_ ~loc (sub.open_description sub x) + | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) + | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) +end + +module E = struct + let jsx_attr sub = + sub.attribute sub (Location.mknoloc "JSX", Parsetree.PStr []) + + let offset_position (pos : Lexing.position) (offset : int) : Lexing.position = + if offset <= 0 then pos + else + let open Lexing in + let rec aux pos offset = + if offset <= 0 then pos + else if offset <= pos.pos_cnum - pos.pos_bol then + (* We're on the same line *) + {pos with pos_cnum = pos.pos_cnum - offset} + else + (* Move to previous line and continue *) + let remaining = offset - (pos.pos_cnum - pos.pos_bol) in + aux + { + pos with + pos_lnum = pos.pos_lnum - 1; + pos_cnum = pos.pos_bol; + pos_bol = max 0 (pos.pos_bol - remaining); + } + remaining + in + aux pos offset + + let jsx_unit_expr = + Ast_helper0.Exp.construct ~loc:!Ast_helper0.default_loc + {txt = Lident "()"; loc = !Ast_helper0.default_loc} + None + + let map_jsx_props sub props = + props + |> List.map (function + | JSXPropPunning (is_optional, name) -> + let ident = + Exp.ident ~loc:name.loc + {txt = Longident.Lident name.txt; loc = name.loc} + in + let label = + if is_optional then Asttypes.Noloc.Optional name.txt + else Asttypes.Noloc.Labelled name.txt + in + (label, ident) + | JSXPropValue (name, is_optional, value) -> + let label = + if is_optional then Asttypes.Noloc.Optional name.txt + else Asttypes.Noloc.Labelled name.txt + in + (label, sub.expr sub value) + | JSXPropSpreading (_, value) -> + (Asttypes.Noloc.Labelled "_spreadProps", sub.expr sub value)) + + let map_jsx_children sub loc children = + match children with + | xs -> + let list_expr = Ast_helper.Exp.make_list_expression loc xs None in + sub.expr sub list_expr + + (* Value expressions for the core language *) + + let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pexp_constant x -> constant ~loc ~attrs (map_constant x) + | Pexp_let (r, vbs, e) -> + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) + | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async} + -> ( + let lab = Asttypes.to_noloc lab in + let attrs = + if async then + ({txt = "res.async"; loc = Location.none}, Pt.PStr []) :: attrs + else attrs + in + let e = + fun_ ~loc ~attrs lab + (map_opt (sub.expr sub) def) + (sub.pat sub p) (sub.expr sub e) + in + match arity with + | None -> e + | Some arity -> + let arity_to_attributes arity = + [ + ( Location.mknoloc "res.arity", + Parsetree0.PStr + [ + Ast_helper0.Str.eval + (Ast_helper0.Exp.constant + (Pconst_integer (string_of_int arity, None))); + ] ); + ] + in + Ast_helper0.Exp.construct + ~attrs:(arity_to_attributes arity) + (Location.mkloc (Longident.Lident "Function$") e.pexp_loc) + (Some e)) + | Pexp_apply {funct = e; args; partial} -> + let e = + match (e.pexp_desc, args) with + | ( Pexp_ident ({txt = Longident.Lident "->"} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "|."}} + | ( Pexp_ident ({txt = Longident.Lident "++"} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "^"}} + | ( Pexp_ident ({txt = Longident.Lident "!="} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "<>"}} + | ( Pexp_ident ({txt = Longident.Lident "!=="} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "!="}} + | ( Pexp_ident ({txt = Longident.Lident "==="} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "=="}} + | ( Pexp_ident ({txt = Longident.Lident "=="} as lid), + [(Nolabel, _); (Nolabel, _)] ) -> + {e with pexp_desc = Pexp_ident {lid with txt = Longident.Lident "="}} + | _ -> e + in + let attrs = + if partial then (Location.mknoloc "res.partial", Pt.PStr []) :: attrs + else attrs + in + apply ~loc ~attrs (sub.expr sub e) + (List.map + (fun (lbl, e) -> (Asttypes.to_noloc lbl, sub.expr sub e)) + args) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) + | Pexp_variant (lab, eo) -> + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_record (l, eo) -> + record ~loc ~attrs + (Ext_list.map l (fun {lid; x = e; opt = optional} -> + let lid1 = map_loc sub lid in + let e1 = sub.expr sub e in + let attr = + Parsetree0.add_optional_attr ~optional e1.pexp_attributes + in + (lid1, {e1 with pexp_attributes = attr}))) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) + | Pexp_setfield (e1, lid, e2) -> + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) + | Pexp_ifthenelse (e1, e2, e3) -> + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) + | Pexp_sequence (e1, e2) -> + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> + while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_for (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) + | Pexp_coerce (e, (), t2) -> + coerce ~loc ~attrs (sub.expr sub e) (sub.typ sub t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) + | Pexp_letmodule (s, me, e) -> + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_letexception (cd, e) -> + letexception ~loc ~attrs + (sub.extension_constructor sub cd) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_newtype (s, e) -> + newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) + | Pexp_open (ovf, lid, e) -> + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) + | Pexp_await e -> + let e = sub.expr sub e in + { + e with + pexp_attributes = + (Location.mknoloc "res.await", Pt.PStr []) :: e.pexp_attributes; + } + | Pexp_jsx_element + (Jsx_fragment + { + jsx_fragment_opening = o; + jsx_fragment_children = children; + jsx_fragment_closing = c; + }) -> + (* + The location of Pexp_jsx_fragment is from the start of < till the end of />. + This is not the case in the old AST. There it is from >... + let tag_ident : Longident.t Location.loc = + tag_name |> Location.map_loc Ast_helper.Jsx.longident_of_jsx_tag_name + in + let props = map_jsx_props sub props in + let children_expr = + let loc = + { + loc_ghost = true; + loc_start = offset_position loc.loc_end 2; + loc_end = offset_position loc.loc_end 1; + } + in + Ast_helper0.Exp.construct ~loc {txt = Lident "[]"; loc} None + in + let unit_expr = + Ast_helper0.Exp.construct ~loc:!Ast_helper0.default_loc + {txt = Lident "()"; loc = !Ast_helper0.default_loc} + None + in + apply ~loc ~attrs:(jsx_attr sub :: attrs) (ident tag_ident) + (props + @ [ + (Asttypes.Noloc.Labelled "children", children_expr); + (Asttypes.Noloc.Nolabel, unit_expr); + ]) + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = tag_name; + jsx_container_element_props = props; + jsx_container_element_children = children; + }) -> + let tag_ident : Longident.t Location.loc = + tag_name |> Location.map_loc Ast_helper.Jsx.longident_of_jsx_tag_name + in + let props = map_jsx_props sub props in + let children_expr = map_jsx_children sub loc children in + apply ~loc ~attrs:(jsx_attr sub :: attrs) (ident tag_ident) + (props + @ [ + (Asttypes.Noloc.Labelled "children", children_expr); + (Asttypes.Noloc.Nolabel, jsx_unit_expr); + ]) +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = + let open Pat in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in + match desc with + | Ppat_any -> any ~loc ~attrs () + | Ppat_var s -> var ~loc ~attrs (map_loc sub s) + | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) + | Ppat_constant c -> constant ~loc ~attrs (map_constant c) + | Ppat_interval (c1, c2) -> + interval ~loc ~attrs (map_constant c1) (map_constant c2) + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_record (lpl, cf) -> + record ~loc ~attrs + (Ext_list.map lpl (fun {lid; x = p; opt = optional} -> + let lid1 = map_loc sub lid in + let p1 = sub.pat sub p in + let attr = + Parsetree0.add_optional_attr ~optional p1.ppat_attributes + in + (lid1, {p1 with ppat_attributes = attr}))) + cf + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) + | Ppat_constraint (p, t) -> + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) + | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) + | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) + | Ppat_open (lid, p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) + | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) + | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) +end + +(* Now, a generic AST mapper, to be extended to cover all kinds and + cases of the OCaml grammar. The default behavior of the mapper is + the identity. *) + +let default_mapper = + { + structure = (fun this l -> List.map (this.structure_item this) l); + structure_item = M.map_structure_item; + module_expr = M.map; + signature = (fun this l -> List.map (this.signature_item this) l); + signature_item = MT.map_signature_item; + module_type = MT.map; + with_constraint = MT.map_with_constraint; + type_declaration = T.map_type_declaration; + type_kind = T.map_type_kind; + typ = T.map; + type_extension = T.map_type_extension; + extension_constructor = T.map_extension_constructor; + value_description = + (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> + Val.mk (map_loc this pval_name) (this.typ this pval_type) + ~attrs:(this.attributes this pval_attributes) + ~loc:(this.location this pval_loc) + ~prim:pval_prim); + pat = P.map; + expr = E.map; + module_declaration = + (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> + Md.mk (map_loc this pmd_name) + (this.module_type this pmd_type) + ~attrs:(this.attributes this pmd_attributes) + ~loc:(this.location this pmd_loc)); + module_type_declaration = + (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + Mtd.mk (map_loc this pmtd_name) + ?typ:(map_opt (this.module_type this) pmtd_type) + ~attrs:(this.attributes this pmtd_attributes) + ~loc:(this.location this pmtd_loc)); + module_binding = + (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> + Mb.mk (map_loc this pmb_name) + (this.module_expr this pmb_expr) + ~attrs:(this.attributes this pmb_attributes) + ~loc:(this.location this pmb_loc)); + open_description = + (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> + Opn.mk (map_loc this popen_lid) ~override:popen_override + ~loc:(this.location this popen_loc) + ~attrs:(this.attributes this popen_attributes)); + include_description = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_type this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + include_declaration = + (fun this {pincl_mod; pincl_attributes; pincl_loc} -> + Incl.mk + (this.module_expr this pincl_mod) + ~loc:(this.location this pincl_loc) + ~attrs:(this.attributes this pincl_attributes)); + value_binding = + (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes)); + constructor_declaration = + (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + Type.constructor (map_loc this pcd_name) + ~args:(T.map_constructor_arguments this pcd_args) + ?res:(map_opt (this.typ this) pcd_res) + ~loc:(this.location this pcd_loc) + ~attrs:(this.attributes this pcd_attributes)); + label_declaration = + (fun this + {pld_name; pld_type; pld_loc; pld_mutable; pld_optional; pld_attributes} + -> + Type.field (map_loc this pld_name) (this.typ this pld_type) + ~mut:pld_mutable + ~loc:(this.location this pld_loc) + ~attrs: + (Parsetree0.add_optional_attr ~optional:pld_optional + (this.attributes this pld_attributes))); + cases = (fun this l -> List.map (this.case this) l); + case = + (fun this {pc_lhs; pc_guard; pc_rhs} -> + { + pc_lhs = this.pat this pc_lhs; + pc_guard = map_opt (this.expr this) pc_guard; + pc_rhs = this.expr this pc_rhs; + }); + location = (fun _this l -> l); + extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); + attributes = (fun this l -> List.map (this.attribute this) l); + payload = + (fun this -> function + | PStr x -> PStr (this.structure this x) + | PSig x -> PSig (this.signature this x) + | PTyp x -> PTyp (this.typ this x) + | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); + } diff --git a/jscomp/ml/ast_payload.ml b/compiler/ml/ast_payload.ml similarity index 85% rename from jscomp/ml/ast_payload.ml rename to compiler/ml/ast_payload.ml index f49ac59..eb953cd 100644 --- a/jscomp/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -64,7 +64,10 @@ let is_single_int (x : t) : int option = ({pexp_desc = Pexp_constant (Pconst_integer (name, char)); _}, _); _; }; - ] when (match char with Some n when n = 'n' -> false | _ -> true) -> + ] + when match char with + | Some n when n = 'n' -> false + | _ -> true -> Some (int_of_string name) | _ -> None @@ -89,7 +92,8 @@ let is_single_bigint (x : t) : string option = { pstr_desc = Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_integer (name, Some 'n')); _}, _); + ( {pexp_desc = Pexp_constant (Pconst_integer (name, Some 'n')); _}, + _ ); _; }; ] -> @@ -143,20 +147,22 @@ let raw_as_string_exp_exn ~(kind : Js_raw_info.raw_kind) ?is_function (x : t) : (match kind with | Raw_re | Raw_exp -> let ((_loc, e) as prog), errors = - Parser_flow.parse_expression (Parser_env.init_env None str) false + let open Parser_flow in + let env = Parser_env.init_env None str in + do_parse env Parse.expression false in (if kind = Raw_re then - match e with - | Literal {value = RegExp _} -> () - | _ -> - Location.raise_errorf ~loc - "Syntax error: a valid JS regex literal expected"); + match e with + | RegExpLiteral _ -> () + | _ -> + Location.raise_errorf ~loc + "Syntax error: a valid JS regex literal expected"); (match is_function with - | Some is_function -> ( - match Classify_function.classify_exp prog with - | Js_function {arity; _} -> is_function := Some arity - | _ -> ()) - | None -> ()); + | Some is_function -> ( + match Classify_function.classify_exp prog with + | Js_function {arity; _} -> is_function := Some arity + | _ -> ()) + | None -> ()); errors | Raw_program -> snd (Parser_flow.parse_program false None str)); Some {e with pexp_desc = Pexp_constant (Pconst_string (str, None))} @@ -184,7 +190,7 @@ type action = lid * Parsetree.expression option {[ { x = exp }]} *) -let unrecognizedConfigRecord loc text = +let unrecognized_config_record loc text = Location.prerr_warning loc (Warnings.Bs_derive_warning text) let ident_or_record_as_config loc (x : t) : @@ -204,14 +210,17 @@ let ident_or_record_as_config loc (x : t) : | None -> Ext_list.map label_exprs (fun u -> match u with - | ( {txt = Lident name; loc}, - {Parsetree.pexp_desc = Pexp_ident {txt = Lident name2}} ) + | { + lid = {txt = Lident name; loc}; + x = {Parsetree.pexp_desc = Pexp_ident {txt = Lident name2}}; + } when name2 = name -> ({Asttypes.txt = name; loc}, None) - | {txt = Lident name; loc}, y -> ({Asttypes.txt = name; loc}, Some y) + | {lid = {txt = Lident name; loc}; x = y} -> + ({Asttypes.txt = name; loc}, Some y) | _ -> Location.raise_errorf ~loc "Qualified label is not allowed") | Some _ -> - unrecognizedConfigRecord loc "`with` is not supported, discarding"; + unrecognized_config_record loc "`with` is not supported, discarding"; []) | PStr [ @@ -224,7 +233,7 @@ let ident_or_record_as_config loc (x : t) : [({Asttypes.txt; loc = lloc}, None)] | PStr [] -> [] | _ -> - unrecognizedConfigRecord loc "invalid attribute config-record, ignoring"; + unrecognized_config_record loc "invalid attribute config-record, ignoring"; [] let assert_strings loc (x : t) : string list = diff --git a/jscomp/ml/ast_payload.mli b/compiler/ml/ast_payload.mli similarity index 94% rename from jscomp/ml/ast_payload.mli rename to compiler/ml/ast_payload.mli index dfd2426..493ad8e 100644 --- a/jscomp/ml/ast_payload.mli +++ b/compiler/ml/ast_payload.mli @@ -65,11 +65,11 @@ val assert_strings : Location.t -> t -> string list (** as a record or empty it will accept - {[ [@@@bs.config ]]} + {[ [@@@config ]]} or - {[ [@@@bs.config no_export ] ]} + {[ [@@@config no_export ] ]} or - {[ [@@@bs.config { property .. } ]]} + {[ [@@@config { property .. } ]]} Note that we only {[ { flat_property} @@ -89,6 +89,6 @@ val empty : t val table_dispatch : (Parsetree.expression option -> 'a) Map_string.t -> action -> 'a -val unrecognizedConfigRecord : Location.t -> string -> unit +val unrecognized_config_record : Location.t -> string -> unit (** Report to the user, as a warning, that the bs-attribute parser is bailing out. (This is to allow external ppx, like ppx_deriving, to pick up where the builtin ppx leave off.) *) diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml new file mode 100644 index 0000000..3cd794e --- /dev/null +++ b/compiler/ml/ast_uncurried.ml @@ -0,0 +1,21 @@ +(* Uncurried AST *) + +let uncurried_type ~arity (t_arg : Parsetree.core_type) = + match t_arg.ptyp_desc with + | Ptyp_arrow arr -> + {t_arg with ptyp_desc = Ptyp_arrow {arr with arity = Some arity}} + | _ -> assert false + +let uncurried_fun ?(async = false) ~arity fun_expr = + let fun_expr = + match fun_expr.Parsetree.pexp_desc with + | Pexp_fun f -> + {fun_expr with pexp_desc = Pexp_fun {f with arity = Some arity; async}} + | _ -> assert false + in + fun_expr + +let expr_is_uncurried_fun (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_fun {arity = Some _} -> true + | _ -> false diff --git a/compiler/ml/ast_untagged_variants.ml b/compiler/ml/ast_untagged_variants.ml new file mode 100644 index 0000000..06673db --- /dev/null +++ b/compiler/ml/ast_untagged_variants.ml @@ -0,0 +1,706 @@ +module Instance = struct + type t = + | Array + | ArrayBuffer + | BigInt64Array + | BigUint64Array + | Blob + | DataView + | Date + | File + | Float32Array + | Float64Array + | Int16Array + | Int32Array + | Int8Array + | Promise + | RegExp + | Uint16Array + | Uint32Array + | Uint8Array + | Uint8ClampedArray + | Set + | Map + | WeakSet + | WeakMap + let to_string = function + | Array -> "Array" + | ArrayBuffer -> "ArrayBuffer" + | BigInt64Array -> "BigInt64Array" + | BigUint64Array -> "BigUint64Array" + | Blob -> "Blob" + | DataView -> "DataView" + | Date -> "Date" + | File -> "File" + | Float32Array -> "Float32Array" + | Float64Array -> "Float64Array" + | Int16Array -> "Int16Array" + | Int32Array -> "Int32Array" + | Int8Array -> "Int8Array" + | Promise -> "Promise" + | RegExp -> "RegExp" + | Uint16Array -> "Uint16Array" + | Uint32Array -> "Uint32Array" + | Uint8Array -> "Uint8Array" + | Uint8ClampedArray -> "Uint8ClampedArray" + | Set -> "Set" + | Map -> "Map" + | WeakSet -> "WeakSet" + | WeakMap -> "WeakMap" +end + +type untagged_error = + | OnlyOneUnknown of string + | AtMostOneObject + | AtMostOneInstance of Instance.t + | AtMostOneFunction + | AtMostOneString + | AtMostOneNumber + | AtMostOneBigint + | AtMostOneBoolean + | DuplicateLiteral of string + | ConstructorMoreThanOneArg of string +type error = + | InvalidVariantAsAnnotation + | Duplicated_bs_as + | InvalidVariantTagAnnotation + | InvalidUntaggedVariantDefinition of untagged_error + | TagFieldNameConflict of string * string * string +exception Error of Location.t * error + +let report_error ppf = + let open Format in + function + | InvalidVariantAsAnnotation -> + fprintf ppf + "A variant case annotation @as(...) must be a string or integer, \ + boolean, null, undefined" + | Duplicated_bs_as -> fprintf ppf "duplicate @as " + | InvalidVariantTagAnnotation -> + fprintf ppf "A variant tag annotation @tag(...) must be a string" + | InvalidUntaggedVariantDefinition untagged_variant -> + fprintf ppf "This untagged variant definition is invalid: %s" + (match untagged_variant with + | OnlyOneUnknown name -> + "Case " ^ name + ^ " has a payload that is not of one of the recognized shapes (object, \ + array, etc). Then it must be the only case with payloads." + | AtMostOneObject -> "At most one case can be an object type." + | AtMostOneInstance Array -> + "At most one case can be an array or tuple type." + | AtMostOneInstance i -> + "At most one case can be a " ^ Instance.to_string i ^ " type." + | AtMostOneFunction -> "At most one case can be a function type." + | AtMostOneString -> "At most one case can be a string type." + | AtMostOneBoolean -> "At most one case can be a boolean type." + | AtMostOneNumber -> + "At most one case can be a number type (int or float)." + | AtMostOneBigint -> "At most one case can be a bigint type." + | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." + | ConstructorMoreThanOneArg name -> + "Constructor " ^ name ^ " has more than one argument.") + | TagFieldNameConflict (constructor_name, field_name, runtime_value) -> + fprintf ppf + "Constructor \"%s\": the @tag name \"%s\" conflicts with the runtime \ + value of inline record field \"%s\". Use a different @tag name or \ + rename the field." + constructor_name runtime_value field_name + +(* Type of the runtime representation of an untagged block (case with payoad) *) +type block_type = + | IntType + | StringType + | FloatType + | BigintType + | BooleanType + | InstanceType of Instance.t + | FunctionType + | ObjectType + | UnknownType + +let block_type_to_user_visible_string = function + | IntType -> "int" + | StringType -> "string" + | FloatType -> "float" + | BigintType -> "bigint" + | BooleanType -> "bool" + | InstanceType i -> Instance.to_string i + | FunctionType -> "function" + | ObjectType -> "object" + | UnknownType -> "unknown" + +(* + Type of the runtime representation of a tag. + Can be a literal (case with no payload), or a block (case with payload). + In the case of block it can be tagged or untagged. +*) +type tag_type = + | String of string + | Int of int + | Float of string + | BigInt of string + | Bool of bool + | Null + | Undefined (* literal or tagged block *) + | Untagged of block_type (* untagged block *) +type tag = {name: string; tag_type: tag_type option} +type block = {tag: tag; tag_name: string option; block_type: block_type option} +type switch_names = {consts: tag array; blocks: block array} + +let tag_type_to_user_visible_string = function + | String _ -> "string" + | Int _ -> "int" + | Float _ -> "float" + | BigInt _ -> "bigint" + | Bool _ -> "bool" + | Null -> "null" + | Undefined -> "undefined" + | Untagged block_type -> block_type_to_user_visible_string block_type + +let untagged = "unboxed" + +let block_type_can_be_undefined = function + | IntType | StringType | FloatType | BigintType | BooleanType | InstanceType _ + | FunctionType | ObjectType -> + false + | UnknownType -> true + +let tag_can_be_undefined tag = + match tag.tag_type with + | None -> false + | Some (String _ | Int _ | Float _ | BigInt _ | Bool _ | Null) -> false + | Some (Untagged block_type) -> block_type_can_be_undefined block_type + | Some Undefined -> true + +let has_untagged (attrs : Parsetree.attributes) = + Ext_list.exists attrs (function {txt}, _ -> txt = untagged) + +let process_untagged (attrs : Parsetree.attributes) = + let st = ref false in + Ext_list.iter attrs (fun ({txt}, _) -> + match txt with + | "unboxed" -> st := true + | _ -> ()); + !st + +let extract_concrete_typedecl : + (Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration) ref = + ref (Obj.magic ()) + +let expand_head : (Env.t -> Types.type_expr -> Types.type_expr) ref = + ref (Obj.magic ()) + +let process_tag_type (attrs : Parsetree.attributes) = + let st : tag_type option ref = ref None in + Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> + match txt with + | "as" -> + if !st = None then ( + (match Ast_payload.is_single_string payload with + | None -> () + | Some (s, _dec) -> st := Some (String s)); + (match Ast_payload.is_single_int payload with + | None -> () + | Some i -> st := Some (Int i)); + (match Ast_payload.is_single_float payload with + | None -> () + | Some f -> st := Some (Float f)); + (match Ast_payload.is_single_bigint payload with + | None -> () + | Some i -> st := Some (BigInt i)); + (match Ast_payload.is_single_bool payload with + | None -> () + | Some b -> st := Some (Bool b)); + (match Ast_payload.is_single_ident payload with + | None -> () + | Some (Lident "null") -> st := Some Null + | Some (Lident "undefined") -> st := Some Undefined + | Some _ -> raise (Error (loc, InvalidVariantAsAnnotation))); + if !st = None then raise (Error (loc, InvalidVariantAsAnnotation)) + else Used_attributes.mark_used_attribute attr) + else raise (Error (loc, Duplicated_bs_as)) + | _ -> ()); + !st + +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) + +let report_constructor_more_than_one_arg ~loc ~name = + raise + (Error + (loc, InvalidUntaggedVariantDefinition (ConstructorMoreThanOneArg name))) + +let type_is_builtin_object (t : Types.type_expr) = + match t.desc with + | Tconstr (Path.Pident ident, [_], _) when Ident.name ident = "dict" -> true + | Tconstr (path, _, _) -> + let name = Path.name path in + name = "Js.Dict.t" || name = "Js_dict.t" + | _ -> false + +let type_to_instanceof_backed_obj (t : Types.type_expr) = + match t.desc with + | Tconstr (path, _, _) when Path.same path Predef.path_promise -> + Some Instance.Promise + | Tconstr (path, _, _) when Path.same path Predef.path_array -> Some Array + | Tconstr (path, _, _) -> ( + match Path.name path with + | "Stdlib_ArrayBuffer.t" -> Some ArrayBuffer + | "Stdlib.BigInt64Array.t" -> Some BigInt64Array + | "Stdlib.BigUint64Array.t" -> Some BigUint64Array + | "Stdlib.DataView.t" -> Some DataView + | "Stdlib_Date.t" -> Some Date + | "Stdlib.Float32Array.t" -> Some Float32Array + | "Stdlib.Float64Array.t" -> Some Float64Array + | "Stdlib.Int16Array.t" -> Some Int16Array + | "Stdlib.Int32Array.t" -> Some Int32Array + | "Stdlib.Int8Array.t" -> Some Int8Array + | "Stdlib_RegExp.t" -> Some RegExp + | "Stdlib.Uint16Array.t" -> Some Uint16Array + | "Stdlib.Uint32Array.t" -> Some Uint32Array + | "Stdlib.Uint8Array.t" -> Some Uint8Array + | "Stdlib.Uint8ClampedArray.t" -> Some Uint8ClampedArray + | "Js_file.t" -> Some File + | "Js_blob.t" -> Some Blob + | "Stdlib.Set.t" -> Some Set + | "Stdlib.Map.t" -> Some Map + | "Stdlib.WeakSet.t" -> Some WeakSet + | "Stdlib.WeakMap.t" -> Some WeakMap + | _ -> None) + | _ -> None + +let get_block_type_from_typ ~env (t : Types.type_expr) : block_type option = + (* First check the original (unexpanded) type for typed arrays and other instance types *) + match type_to_instanceof_backed_obj t with + | Some instance_type -> Some (InstanceType instance_type) + | None -> ( + (* If original type didn't match, expand and try standard checks *) + let expanded_t = !expand_head env t in + match expanded_t with + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> + Some StringType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_int -> + Some IntType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float -> + Some FloatType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint -> + Some BigintType + | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool -> + Some BooleanType + | {desc = Tarrow _} -> Some FunctionType + | {desc = Tconstr _} as expanded_t when type_is_builtin_object expanded_t -> + Some ObjectType + | {desc = Tconstr _} as expanded_t + when type_to_instanceof_backed_obj expanded_t |> Option.is_some -> ( + match type_to_instanceof_backed_obj expanded_t with + | None -> None + | Some instance_type -> Some (InstanceType instance_type)) + | {desc = Ttuple _} -> Some (InstanceType Array) + | _ -> None) + +let get_block_type ~env (cstr : Types.constructor_declaration) : + block_type option = + match (process_untagged cstr.cd_attributes, cstr.cd_args) with + | false, _ -> None + | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some + -> + get_block_type_from_typ ~env t + | true, Cstr_tuple [ty] -> ( + let default = Some UnknownType in + match !extract_concrete_typedecl env ty with + | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default + | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType + | _ -> default + | exception _ -> default) + | true, Cstr_tuple (_ :: _ :: _) -> + (* C(_, _) with at least 2 args is an object *) + Some ObjectType + | true, Cstr_record _ -> + (* inline record is an object *) + Some ObjectType + | true, _ -> None (* TODO: add restrictions here *) + +let process_tag_name (attrs : Parsetree.attributes) = + let st = ref None in + Ext_list.iter attrs (fun ({txt; loc}, payload) -> + match txt with + | "tag" -> + if !st = None then ( + (match Ast_payload.is_single_string payload with + | None -> () + | Some (s, _dec) -> st := Some s); + if !st = None then raise (Error (loc, InvalidVariantTagAnnotation))) + else raise (Error (loc, Duplicated_bs_as)) + | _ -> ()); + !st + +let get_tag_name (cstr : Types.constructor_declaration) = + process_tag_name cstr.cd_attributes + +let is_nullary_variant (x : Types.constructor_arguments) = + match x with + | Types.Cstr_tuple [] -> true + | _ -> false + +let check_invariant ~is_untagged_def ~(consts : (Location.t * tag) list) + ~(blocks : (Location.t * block) list) = + let module StringSet = Set.Make (String) in + let string_literals_consts = ref StringSet.empty in + let string_literals_blocks = ref StringSet.empty in + let nonstring_literals_consts = ref StringSet.empty in + let nonstring_literals_blocks = ref StringSet.empty in + let instance_types = Hashtbl.create 1 in + let function_types = ref 0 in + let object_types = ref 0 in + let string_types = ref 0 in + let number_types = ref 0 in + let bigint_types = ref 0 in + let boolean_types = ref 0 in + let unknown_types = ref 0 in + let add_string_literal ~is_const ~loc s = + let set = + if is_const then string_literals_consts else string_literals_blocks + in + if StringSet.mem s !set then + raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); + set := StringSet.add s !set + in + let add_nonstring_literal ~is_const ~loc s = + let set = + if is_const then nonstring_literals_consts else nonstring_literals_blocks + in + if StringSet.mem s !set then + raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); + set := StringSet.add s !set + in + let invariant loc name = + if !unknown_types <> 0 && List.length blocks <> 1 then + raise + (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); + if !object_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); + Hashtbl.iter + (fun i count -> + if count > 1 then + raise + (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) + instance_types; + if !function_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); + if !string_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); + if !number_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); + if !bigint_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); + if !boolean_types > 1 then + raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); + if + !boolean_types > 0 + && (StringSet.mem "true" !nonstring_literals_consts + || StringSet.mem "false" !nonstring_literals_consts) + then raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); + () + in + let check_literal ~is_const ~loc (literal : tag) = + match literal.tag_type with + | Some (String s) -> add_string_literal ~is_const ~loc s + | Some (Int i) -> add_nonstring_literal ~is_const ~loc (string_of_int i) + | Some (Float f) -> add_nonstring_literal ~is_const ~loc f + | Some (BigInt i) -> add_nonstring_literal ~is_const ~loc i + | Some Null -> add_nonstring_literal ~is_const ~loc "null" + | Some Undefined -> add_nonstring_literal ~is_const ~loc "undefined" + | Some (Bool b) -> + add_nonstring_literal ~is_const ~loc (if b then "true" else "false") + | Some (Untagged _) -> () + | None -> add_string_literal ~is_const ~loc literal.name + in + + Ext_list.rev_iter consts (fun (loc, literal) -> + check_literal ~is_const:true ~loc literal); + if is_untagged_def then + Ext_list.rev_iter blocks (fun (loc, block) -> + match block.block_type with + | Some block_type -> + (match block_type with + | UnknownType -> incr unknown_types + | ObjectType -> incr object_types + | InstanceType i -> + let count = + Hashtbl.find_opt instance_types i |> Option.value ~default:0 + in + Hashtbl.replace instance_types i (count + 1) + | FunctionType -> incr function_types + | IntType | FloatType -> incr number_types + | BigintType -> incr bigint_types + | BooleanType -> incr boolean_types + | StringType -> incr string_types); + invariant loc block.tag.name + | None -> ()) + else + Ext_list.rev_iter blocks (fun (loc, block) -> + check_literal ~is_const:false ~loc block.tag) + +let get_cstr_loc_tag (cstr : Types.constructor_declaration) = + ( cstr.cd_loc, + { + name = Ident.name cstr.cd_id; + tag_type = process_tag_type cstr.cd_attributes; + } ) + +let constructor_declaration_from_constructor_description ~env + (cd : Types.constructor_description) : Types.constructor_declaration option + = + match cd.cstr_res.desc with + | Tconstr (path, _, _) -> ( + match Env.find_type path env with + | {type_kind = Type_variant cstrs} -> + Ext_list.find_opt cstrs (fun cstr -> + if cstr.cd_id.name = cd.cstr_name then Some cstr else None) + | _ -> None) + | _ -> None + +let names_from_type_variant ?(is_untagged_def = false) ~env + (cstrs : Types.constructor_declaration list) = + let get_block (cstr : Types.constructor_declaration) : block = + let tag = snd (get_cstr_loc_tag cstr) in + {tag; tag_name = get_tag_name cstr; block_type = get_block_type ~env cstr} + in + let consts, blocks = + Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr -> + if is_nullary_variant cstr.cd_args then + (get_cstr_loc_tag cstr :: consts, blocks) + else (consts, (cstr.cd_loc, get_block cstr) :: blocks)) + in + check_invariant ~is_untagged_def ~consts ~blocks; + let blocks = blocks |> List.map snd in + let consts = consts |> List.map snd in + let consts = Ext_array.reverse_of_list consts in + let blocks = Ext_array.reverse_of_list blocks in + Some {consts; blocks} + +let check_tag_field_conflicts (cstrs : Types.constructor_declaration list) = + List.iter + (fun (cstr : Types.constructor_declaration) -> + let constructor_name = Ident.name cstr.cd_id in + let effective_tag_name = + match process_tag_name cstr.cd_attributes with + | Some explicit_tag -> explicit_tag + | None -> constructor_name + in + match cstr.cd_args with + | Cstr_record fields -> + List.iter + (fun (field : Types.label_declaration) -> + let field_name = Ident.name field.ld_id in + let effective_field_name = + match process_tag_type field.ld_attributes with + | Some (String as_name) -> as_name + (* @as payload types other than string have no effect on record fields *) + | Some _ | None -> field_name + in + (* Check if effective field name conflicts with tag *) + if effective_field_name = effective_tag_name then + raise + (Error + ( cstr.cd_loc, + TagFieldNameConflict + (constructor_name, field_name, effective_field_name) ))) + fields + | _ -> ()) + cstrs + +type well_formedness_check = { + is_untagged_def: bool; + cstrs: Types.constructor_declaration list; +} + +let check_well_formed ~env {is_untagged_def; cstrs} = + check_tag_field_conflicts cstrs; + ignore (names_from_type_variant ~env ~is_untagged_def cstrs) + +let has_undefined_literal attrs = process_tag_type attrs = Some Undefined + +let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType + +module DynamicChecks = struct + type op = EqEqEq | NotEqEq | Or | And + type 'a t = + | BinOp of op * 'a t * 'a t + | TagType of tag_type + | TypeOf of 'a t + | IsInstanceOf of Instance.t * 'a t + | Not of 'a t + | Expr of 'a + + let rec size = function + | BinOp (_, x, y) -> 1 + size x + size y + | TagType _ -> 1 + | TypeOf x -> 1 + size x + | IsInstanceOf (_, x) -> 1 + size x + | Not x -> 1 + size x + | Expr _ -> 1 + + let bin op x y = BinOp (op, x, y) + let tag_type t = TagType t + let typeof x = TypeOf x + let str s = String s |> tag_type + let is_instance i x = IsInstanceOf (i, x) + let not x = Not x + let nil = Null |> tag_type + let undefined = Undefined |> tag_type + let object_ = Untagged ObjectType |> tag_type + + let function_ = Untagged FunctionType |> tag_type + let string = Untagged StringType |> tag_type + let number = Untagged IntType |> tag_type + + let bigint = Untagged BigintType |> tag_type + + let boolean = Untagged BooleanType |> tag_type + + let ( == ) x y = bin EqEqEq x y + let ( != ) x y = bin NotEqEq x y + let ( ||| ) x y = bin Or x y + let ( &&& ) x y = bin And x y + + let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases + ~list_literal_cases (e : _ t) = + let literals_overlaps_with_string () = + Ext_list.exists literal_cases (function + | String _ -> true + | _ -> false) + in + let literals_overlaps_with_number () = + Ext_list.exists literal_cases (function + | Int _ | Float _ -> true + | _ -> false) + in + let literals_overlaps_with_bigint () = + Ext_list.exists literal_cases (function + | BigInt _ -> true + | _ -> false) + in + let literals_overlaps_with_boolean () = + Ext_list.exists literal_cases (function + | Bool _ -> true + | _ -> false) + in + let literals_overlaps_with_object () = + Ext_list.exists literal_cases (function + | Null -> true + | _ -> false) + in + let is_literal_case (t : tag_type) : _ t = e == tag_type t in + let is_not_block_case (c : block_type) : _ t = + match c with + | StringType + when literals_overlaps_with_string () = false (* No overlap *) -> + typeof e != string + | IntType when literals_overlaps_with_number () = false -> + typeof e != number + | FloatType when literals_overlaps_with_number () = false -> + typeof e != number + | BigintType when literals_overlaps_with_bigint () = false -> + typeof e != bigint + | BooleanType when literals_overlaps_with_boolean () = false -> + typeof e != boolean + | InstanceType i -> not (is_instance i e) + | FunctionType -> typeof e != function_ + | ObjectType when literals_overlaps_with_object () = false -> + typeof e != object_ + | ObjectType (* overlap *) -> e == nil ||| (typeof e != object_) + | StringType (* overlap *) + | IntType (* overlap *) + | FloatType (* overlap *) + | BigintType (* overlap *) + | BooleanType (* overlap *) + | UnknownType -> ( + (* We don't know the type of unknown, so we need to express: + this is not one of the literals *) + match literal_cases with + | [] -> + (* this should not happen *) + assert false + | l1 :: others -> + let is_literal_1 = is_literal_case l1 in + Ext_list.fold_right others is_literal_1 (fun literal_n acc -> + is_literal_case literal_n ||| acc)) + in + if list_literal_cases then + let rec mk cases = + match List.rev cases with + | [case] -> is_literal_case case + | case :: rest -> is_literal_case case ||| mk rest + | [] -> assert false + in + mk literal_cases + else + match block_cases with + | [c] -> is_not_block_case c + | c1 :: (_ :: _ as rest) -> + is_not_block_case c1 + &&& is_a_literal_case ~literal_cases ~block_cases:rest + ~list_literal_cases e + | [] -> assert false + + let is_a_literal_case ~literal_cases ~block_cases e = + let with_literal_cases = + is_a_literal_case ~literal_cases ~block_cases ~list_literal_cases:true e + in + let without_literal_cases = + is_a_literal_case ~literal_cases ~block_cases ~list_literal_cases:false e + in + if size with_literal_cases <= size without_literal_cases then + with_literal_cases + else without_literal_cases + + let is_int_tag ?(has_null_undefined_other = (false, false, false)) (e : _ t) : + _ t = + let has_null, has_undefined, has_other = has_null_undefined_other in + if has_null && has_undefined = false && has_other = false then + (* null *) + bin EqEqEq e nil + else if has_null && has_undefined && has_other = false then + (* null + undefined *) + e == nil ||| e == undefined + else if has_null = false && has_undefined && has_other = false then + (* undefined *) + e == undefined + else if has_null then + (* (null + undefined + other) || (null + other) *) + e == nil ||| typeof e != object_ + else (* (undefiled + other) || other *) + typeof e != object_ + + let add_runtime_type_check ~tag_type ~has_null_case + ~(block_cases : block_type list) x y = + let instances = + Ext_list.filter_map block_cases (function + | InstanceType i -> Some i + | _ -> None) + in + match tag_type with + | Untagged + ( IntType | StringType | FloatType | BigintType | BooleanType + | FunctionType ) -> + typeof y == x + | Untagged ObjectType -> + let object_case = + if has_null_case then typeof y == x &&& (y != nil) else typeof y == x + in + if instances <> [] then + let not_one_of_the_instances = + Ext_list.fold_right instances object_case (fun i x -> + x &&& not (is_instance i y)) + in + not_one_of_the_instances + else object_case + | Untagged (InstanceType i) -> is_instance i y + | Untagged UnknownType -> + (* This should not happen because unknown must be the only non-literal case *) + assert false + | Bool _ | Float _ | Int _ | BigInt _ | String _ | Null | Undefined -> x +end diff --git a/compiler/ml/asttypes.ml b/compiler/ml/asttypes.ml new file mode 100644 index 0000000..e12960a --- /dev/null +++ b/compiler/ml/asttypes.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Auxiliary AST types used by parsetree and typedtree. *) + +type constant = + | Const_int of int + | Const_char of int + | Const_string of string * string option + | Const_float of string + | Const_int32 of int32 + | Const_int64 of int64 + | Const_bigint of bool * string + +type rec_flag = Nonrecursive | Recursive + +type direction_flag = Upto | Downto + +(* Order matters, used in polymorphic comparison *) +type private_flag = Private | Public + +type mutable_flag = Immutable | Mutable + +type virtual_flag = Virtual | Concrete + +type override_flag = Override | Fresh + +type closed_flag = Closed | Open + +type label = string + +type arity = int option + +type 'a loc = 'a Location.loc = {txt: 'a; loc: Location.t} + +type variance = Covariant | Contravariant | Invariant + +type arg_label = + | Nolabel (* x => ...*) + | Labelled of string loc (* ~label => ... *) + | Optional of string loc (* ~(label=e) => ... *) + +module Noloc = struct + type arg_label = + | Nolabel (* x => ...*) + | Labelled of string (* ~label => ... *) + | Optional of string (* ~(label=e) => ... *) +end + +let to_arg_label ?(loc = Location.none) lbl = + match lbl with + | Noloc.Nolabel -> Nolabel + | Labelled s -> Labelled {loc; txt = s} + | Optional s -> Optional {loc; txt = s} + +let to_noloc = function + | Nolabel -> Noloc.Nolabel + | Labelled {txt} -> Labelled txt + | Optional {txt} -> Optional txt + +let same_arg_label (x : arg_label) y = + match x with + | Nolabel -> y = Nolabel + | Labelled {txt = s} -> ( + match y with + | Labelled {txt = s0} -> s = s0 + | _ -> false) + | Optional {txt = s} -> ( + match y with + | Optional {txt = s0} -> s = s0 + | _ -> false) + +let get_lbl_loc = function + | Nolabel -> Location.none + | Labelled {loc} | Optional {loc} -> loc diff --git a/compiler/ml/bigint_utils.ml b/compiler/ml/bigint_utils.ml new file mode 100644 index 0000000..286a805 --- /dev/null +++ b/compiler/ml/bigint_utils.ml @@ -0,0 +1,96 @@ +let is_neg s = String.length s > 0 && s.[0] = '-' +let is_pos s = String.length s > 0 && s.[0] = '+' + +let to_string sign s = (if sign then "" else "-") ^ s + +let remove_leading_sign str : bool * string = + let len = String.length str in + if len = 0 then (false, str) + else if is_neg str || is_pos str then + (not (is_neg str), String.sub str 1 (len - 1)) + else (true, str) + +(* + Removes leading zeros from the string only if the first non-zero character + encountered is a digit. Unlike int and float, bigint cannot be of_string, so + This function removes only leading 0s. Instead, values like 00x1 are not converted + and are intended to be syntax errors. + + 000n -> 0n + 001n -> 1n + 01_000_000n -> 1000000n + -00100n -> -100n + + The following values are syntax errors + + 00o1n -> 00o1n + 00x1_000_000n -> 00x1000000n +*) +let remove_leading_zeros str = + let aux str = + let len = String.length str in + if len = 0 then "" + else + let is_digit c = c >= '0' && c <= '9' in + let idx = ref 0 in + while !idx < len && str.[!idx] = '0' do + incr idx + done; + if !idx >= len then "0" + (* If the string contains only '0's, return '0'. *) + else if is_digit str.[!idx] then String.sub str !idx (len - !idx) + (* Remove leading zeros and return the rest of the string. *) + else str + in + (* Replace the delimiters '_' inside number *) + let str = String.concat "" (String.split_on_char '_' str) in + (* Check if negative *) + let starts_with_minus = str <> "" && str.[0] = '-' in + let str = + if is_neg str || is_pos str then String.sub str 1 (String.length str - 1) + else str + in + let processed_str = aux str in + if starts_with_minus then "-" ^ processed_str else processed_str + +let parse_bigint s = + let sign, i = remove_leading_sign s in + (sign, remove_leading_zeros i) + +let is_valid s = + let len = String.length s in + if len = 0 then false + else + let is_digit c = (c >= '0' && c <= '9') || c = '_' in + let first_char = s.[0] in + if first_char <> '-' && first_char <> '+' && not (is_digit first_char) then + false + else + let rec check idx = + if idx >= len then true + else + let c = s.[idx] in + if is_digit c then check (idx + 1) else false + in + check 1 + +let compare (p0, s0) (p1, s1) = + match (p0, p1) with + | false, true -> -1 (* If only s1 is positive, s0 is smaller. *) + | true, false -> 1 (* If only s0 is positive, s0 is larger. *) + | _ -> + (* If both numbers are either negative or positive, compare their lengths. *) + let len0, len1 = (String.length s0, String.length s1) in + if len0 = len1 then + if p0 then String.compare s0 s1 + else + String.compare s1 + s0 (* If lengths are equal, compare the strings directly. *) + else if len0 > len1 then + if p0 then 1 + else -1 (* A longer s0 means it's larger unless it's negative. *) + else if + (* len0 < len1 *) + p0 + then -1 + else 1 (* A longer s1 means s0 is smaller unless s1 is negative. *) diff --git a/compiler/ml/bigint_utils.mli b/compiler/ml/bigint_utils.mli new file mode 100644 index 0000000..14b09a9 --- /dev/null +++ b/compiler/ml/bigint_utils.mli @@ -0,0 +1,8 @@ +val is_neg : string -> bool +val is_pos : string -> bool +val to_string : bool -> string -> string +val remove_leading_sign : string -> bool * string +val remove_leading_zeros : string -> string +val parse_bigint : string -> bool * string +val is_valid : string -> bool +val compare : bool * string -> bool * string -> int diff --git a/jscomp/ml/bs_flow_ast_utils.ml b/compiler/ml/bs_flow_ast_utils.ml similarity index 100% rename from jscomp/ml/bs_flow_ast_utils.ml rename to compiler/ml/bs_flow_ast_utils.ml diff --git a/jscomp/ml/bs_flow_ast_utils.mli b/compiler/ml/bs_flow_ast_utils.mli similarity index 100% rename from jscomp/ml/bs_flow_ast_utils.mli rename to compiler/ml/bs_flow_ast_utils.mli diff --git a/compiler/ml/btype.ml b/compiler/ml/btype.ml new file mode 100644 index 0000000..2af606a --- /dev/null +++ b/compiler/ml/btype.ml @@ -0,0 +1,737 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, 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. *) +(* *) +(**************************************************************************) + +(* Basic operations on core types *) + +open Misc +open Asttypes +open Types + +(**** Sets, maps and hashtables of types ****) + +module TypeSet = Set.Make (TypeOps) +module TypeMap = Map.Make (TypeOps) +module TypeHash = Hashtbl.Make (TypeOps) + +(**** Forward declarations ****) + +let print_raw = + ref (fun _ -> assert false : Format.formatter -> type_expr -> unit) + +(**** Type level management ****) + +let generic_level = 100000000 + +(* Used to mark a type during a traversal. *) +let lowest_level = 0 +let pivot_level = (2 * lowest_level) - 1 +(* pivot_level - lowest_level < lowest_level *) + +(**** Some type creators ****) + +let new_id = ref (-1) + +let newty2 level desc = + incr new_id; + {desc; level; id = !new_id} +let newgenty desc = newty2 generic_level desc +let newgenvar ?name () = newgenty (Tvar name) +(* +let newmarkedvar level = + incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } +let newmarkedgenvar () = + incr new_id; + { desc = Tvar; level = pivot_level - generic_level; id = !new_id } +*) + +(**** Check some types ****) + +let is_Tvar = function + | {desc = Tvar _} -> true + | _ -> false +let is_Tunivar = function + | {desc = Tunivar _} -> true + | _ -> false +let is_Tconstr = function + | {desc = Tconstr _} -> true + | _ -> false + +let dummy_method = "*dummy method*" +let default_mty = function + | Some mty -> mty + | None -> Mty_signature [] + +(**** Definitions for backtracking ****) + +type change = + | Ctype of type_expr * type_desc + | Ccompress of type_expr * type_desc * type_desc + | Clevel of type_expr * int + | Cname of + (Path.t * type_expr list) option ref * (Path.t * type_expr list) option + | Crow of row_field option ref * row_field option + | Ckind of field_kind option ref * field_kind option + | Ccommu of commutable ref * commutable + | Cuniv of type_expr option ref * type_expr option + | Ctypeset of TypeSet.t ref * TypeSet.t + +type changes = Change of change * changes ref | Unchanged | Invalid + +let trail = Weak.create 1 + +let log_change ch = + match Weak.get trail 0 with + | None -> () + | Some r -> + let r' = ref Unchanged in + r := Change (ch, r'); + Weak.set trail 0 (Some r') + +(**** Representative of a type ****) + +let rec field_kind_repr = function + | Fvar {contents = Some kind} -> field_kind_repr kind + | kind -> kind + +let rec repr_link compress t d = function + | {desc = Tlink t' as d'} -> repr_link true t d' t' + | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> + repr_link true t d' t' + | t' -> + if compress then ( + log_change (Ccompress (t, t.desc, d)); + t.desc <- d); + t' + +let repr t = + match t.desc with + | Tlink t' as d -> repr_link false t d t' + | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent -> + repr_link false t d t' + | _ -> t + +let rec commu_repr = function + | Clink r when !r <> Cunknown -> commu_repr !r + | c -> c + +let rec row_field_repr_aux tl = function + | Reither (_, tl', _, {contents = Some fi}) -> + row_field_repr_aux (tl @ tl') fi + | Reither (c, tl', m, r) -> Reither (c, tl @ tl', m, r) + | Rpresent (Some _) when tl <> [] -> Rpresent (Some (List.hd tl)) + | fi -> fi + +let row_field_repr fi = row_field_repr_aux [] fi + +let rec rev_concat l ll = + match ll with + | [] -> l + | l' :: ll -> rev_concat (l' @ l) ll + +let rec row_repr_aux ll row = + match (repr row.row_more).desc with + | Tvariant row' -> + let f = row.row_fields in + row_repr_aux (if f = [] then ll else f :: ll) row' + | _ -> + if ll = [] then row + else {row with row_fields = rev_concat row.row_fields ll} + +let row_repr row = row_repr_aux [] row + +let rec row_field tag row = + let rec find = function + | (tag', f) :: fields -> + if tag = tag' then row_field_repr f else find fields + | [] -> ( + match repr row.row_more with + | {desc = Tvariant row'} -> row_field tag row' + | _ -> Rabsent) + in + find row.row_fields + +let rec row_more row = + match repr row.row_more with + | {desc = Tvariant row'} -> row_more row' + | ty -> ty + +let row_fixed row = + let row = row_repr row in + row.row_fixed + || + match (repr row.row_more).desc with + | Tvar _ | Tnil -> false + | Tunivar _ | Tconstr _ -> true + | _ -> assert false + +let static_row row = + let row = row_repr row in + row.row_closed + && List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither _ -> false + | _ -> true) + row.row_fields + +let hash_variant s = + let accu = ref 0 in + for i = 0 to String.length s - 1 do + accu := (223 * !accu) + Char.code s.[i] + done; + (* reduce to 31 bits *) + accu := !accu land ((1 lsl 31) - 1); + (* make it signed for 64 bits architectures *) + if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu + +let proxy ty = + let ty0 = repr ty in + match ty0.desc with + | Tvariant row when not (static_row row) -> row_more row + | Tobject (ty, _) -> + let rec proxy_obj ty = + match ty.desc with + | Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty + | Tvar _ | Tunivar _ | Tconstr _ -> ty + | Tnil -> ty0 + | _ -> assert false + in + proxy_obj ty + | _ -> ty0 + +(**** Utilities for fixed row private types ****) + +let row_of_type t = + match (repr t).desc with + | Tobject (t, _) -> + let rec get_row t = + let t = repr t in + match t.desc with + | Tfield (_, _, _, t) -> get_row t + | _ -> t + in + get_row t + | Tvariant row -> row_more row + | _ -> t + +let has_constr_row t = (not (is_Tconstr t)) && is_Tconstr (row_of_type t) + +let is_row_name s = + let l = String.length s in + if l < 4 then false else String.sub s (l - 4) 4 = "#row" + +let is_constr_row ~allow_ident t = + match t.desc with + | Tconstr (Path.Pident id, _, _) when allow_ident -> + is_row_name (Ident.name id) + | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s + | _ -> false + +(**********************************) +(* Utilities for type traversal *) +(**********************************) + +let rec iter_row f row = + List.iter + (fun (_, fi) -> + match row_field_repr fi with + | Rpresent (Some ty) -> f ty + | Reither (_, tl, _, _) -> List.iter f tl + | _ -> ()) + row.row_fields; + match (repr row.row_more).desc with + | Tvariant row -> iter_row f row + | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> + Misc.may (fun (_, l) -> List.iter f l) row.row_name + | _ -> assert false + +let iter_type_expr f ty = + match ty.desc with + | Tvar _ -> () + | Tarrow ({typ = ty1}, ty2, _, _) -> + f ty1; + f ty2 + | Ttuple l -> List.iter f l + | Tconstr (_, l, _) -> List.iter f l + | Tobject (ty, {contents = Some (_, p)}) -> + f ty; + List.iter f p + | Tobject (ty, _) -> f ty + | Tvariant row -> + iter_row f row; + f (row_more row) + | Tfield (_, _, ty1, ty2) -> + f ty1; + f ty2 + | Tnil -> () + | Tlink ty -> f ty + | Tsubst ty -> f ty + | Tunivar _ -> () + | Tpoly (ty, tyl) -> + f ty; + List.iter f tyl + | Tpackage (_, _, l) -> List.iter f l + +let rec iter_abbrev f = function + | Mnil -> () + | Mcons (_, _, ty, ty', rem) -> + f ty; + f ty'; + iter_abbrev f rem + | Mlink rem -> iter_abbrev f !rem + +type type_iterators = { + it_signature: type_iterators -> signature -> unit; + it_signature_item: type_iterators -> signature_item -> unit; + it_value_description: type_iterators -> value_description -> unit; + it_type_declaration: type_iterators -> type_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; + it_module_declaration: type_iterators -> module_declaration -> unit; + it_modtype_declaration: type_iterators -> modtype_declaration -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_type_kind: type_iterators -> type_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; + it_type_expr: type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; +} + +let iter_type_expr_cstr_args f = function + | Cstr_tuple tl -> List.iter f tl + | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls + +let map_type_expr_cstr_args f = function + | Cstr_tuple tl -> Cstr_tuple (List.map f tl) + | Cstr_record lbls -> + Cstr_record (List.map (fun d -> {d with ld_type = f d.ld_type}) lbls) + +let iter_type_expr_kind f = function + | Type_abstract -> () + | Type_variant cstrs -> + List.iter + (fun cd -> + iter_type_expr_cstr_args f cd.cd_args; + Misc.may f cd.cd_res) + cstrs + | Type_record (lbls, _) -> List.iter (fun d -> f d.ld_type) lbls + | Type_open -> () + +let type_iterators = + let it_signature it = List.iter (it.it_signature_item it) + and it_signature_item it = function + | Sig_value (_, vd) -> it.it_value_description it vd + | Sig_type (_, td, _) -> it.it_type_declaration it td + | Sig_typext (_, td, _) -> it.it_extension_constructor it td + | Sig_module (_, md, _) -> it.it_module_declaration it md + | Sig_modtype (_, mtd) -> it.it_modtype_declaration it mtd + | Sig_class () -> assert false + | Sig_class_type () -> assert false + and it_value_description it vd = it.it_type_expr it vd.val_type + and it_type_declaration it td = + List.iter (it.it_type_expr it) td.type_params; + may (it.it_type_expr it) td.type_manifest; + it.it_type_kind it td.type_kind + and it_extension_constructor it td = + it.it_path td.ext_type_path; + List.iter (it.it_type_expr it) td.ext_type_params; + iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; + may (it.it_type_expr it) td.ext_ret_type + and it_module_declaration it md = it.it_module_type it md.md_type + and it_modtype_declaration it mtd = may (it.it_module_type it) mtd.mtd_type + and it_module_type it = function + | Mty_ident p | Mty_alias (_, p) -> it.it_path p + | Mty_signature sg -> it.it_signature it sg + | Mty_functor (_, mto, mt) -> + may (it.it_module_type it) mto; + it.it_module_type it mt + and it_type_kind it kind = iter_type_expr_kind (it.it_type_expr it) kind + and it_do_type_expr it ty = + iter_type_expr (it.it_type_expr it) ty; + match ty.desc with + | Tconstr (p, _, _) + | Tobject (_, {contents = Some (p, _)}) + | Tpackage (p, _, _) -> + it.it_path p + | Tvariant row -> may (fun (p, _) -> it.it_path p) (row_repr row).row_name + | _ -> () + and it_path _p = () in + { + it_path; + it_type_expr = it_do_type_expr; + it_do_type_expr; + it_type_kind; + it_module_type; + it_signature; + it_modtype_declaration; + it_module_declaration; + it_extension_constructor; + it_type_declaration; + it_value_description; + it_signature_item; + } + +let copy_row f fixed row keep more = + let fields = + List.map + (fun (l, fi) -> + ( l, + match row_field_repr fi with + | Rpresent (Some ty) -> Rpresent (Some (f ty)) + | Reither (c, tl, m, e) -> + let e = if keep then e else ref None in + let m = if row.row_fixed then fixed else m in + let tl = List.map f tl in + Reither (c, tl, m, e) + | _ -> fi )) + row.row_fields + in + let name = + match row.row_name with + | None -> None + | Some (path, tl) -> Some (path, List.map f tl) + in + { + row_fields = fields; + row_more = more; + row_fixed = row.row_fixed && fixed; + row_closed = row.row_closed; + row_name = name; + } + +let rec copy_kind = function + | Fvar {contents = Some k} -> copy_kind k + | Fvar _ -> Fvar (ref None) + | Fpresent -> Fpresent + | Fabsent -> assert false + +let copy_commu c = if commu_repr c = Cok then Cok else Clink (ref Cunknown) + +(* Since univars may be used as row variables, we need to do some + encoding during substitution *) +let rec norm_univar ty = + match ty.desc with + | Tunivar _ | Tsubst _ -> ty + | Tlink ty -> norm_univar ty + | Ttuple (ty :: _) -> norm_univar ty + | _ -> assert false + +let rec copy_type_desc ?(keep_names = false) f = function + | Tvar _ as ty -> if keep_names then ty else Tvar None + | Tarrow (arg, ret, c, arity) -> + Tarrow ({arg with typ = f arg.typ}, f ret, copy_commu c, arity) + | Ttuple l -> Ttuple (List.map f l) + | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) + | Tobject (ty, {contents = Some (p, tl)}) -> + Tobject (f ty, ref (Some (p, List.map f tl))) + | Tobject (ty, _) -> Tobject (f ty, ref None) + | Tvariant _ -> assert false (* too ambiguous *) + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared *) + Tfield (p, field_kind_repr k, f ty1, f ty2) + | Tnil -> Tnil + | Tlink ty -> copy_type_desc f ty.desc + | Tsubst _ -> assert false + | Tunivar _ as ty -> ty (* always keep the name *) + | Tpoly (ty, tyl) -> + let tyl = List.map (fun x -> norm_univar (f x)) tyl in + Tpoly (f ty, tyl) + | Tpackage (p, n, l) -> Tpackage (p, n, List.map f l) + +(* Utilities for copying *) + +let saved_desc = ref [] +(* Saved association of generic nodes with their description. *) + +let save_desc ty desc = saved_desc := (ty, desc) :: !saved_desc + +let saved_kinds = ref [] (* duplicated kind variables *) +let new_kinds = ref [] (* new kind variables *) +let dup_kind r = + (match !r with + | None -> () + | Some _ -> assert false); + if not (List.memq r !new_kinds) then ( + saved_kinds := r :: !saved_kinds; + let r' = ref None in + new_kinds := r' :: !new_kinds; + r := Some (Fvar r')) + +(* Restored type descriptions. *) +let cleanup_types () = + List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc; + List.iter (fun r -> r := None) !saved_kinds; + saved_desc := []; + saved_kinds := []; + new_kinds := [] + +(* Mark a type. *) +let rec mark_type ty = + let ty = repr ty in + if ty.level >= lowest_level then ( + ty.level <- pivot_level - ty.level; + iter_type_expr mark_type ty) + +let mark_type_node ty = + let ty = repr ty in + if ty.level >= lowest_level then ty.level <- pivot_level - ty.level + +let mark_type_params ty = iter_type_expr mark_type ty + +let type_iterators = + let it_type_expr it ty = + let ty = repr ty in + if ty.level >= lowest_level then ( + mark_type_node ty; + it.it_do_type_expr it ty) + in + {type_iterators with it_type_expr} + +(* Remove marks from a type. *) +let rec unmark_type ty = + let ty = repr ty in + if ty.level < lowest_level then ( + ty.level <- pivot_level - ty.level; + iter_type_expr unmark_type ty) + +let unmark_iterators = + let it_type_expr _it ty = unmark_type ty in + {type_iterators with it_type_expr} + +let unmark_type_decl decl = + unmark_iterators.it_type_declaration unmark_iterators decl + +let unmark_extension_constructor ext = + List.iter unmark_type ext.ext_type_params; + iter_type_expr_cstr_args unmark_type ext.ext_args; + Misc.may unmark_type ext.ext_ret_type + +(*******************************************) +(* Memorization of abbreviation expansion *) +(*******************************************) + +(* Search whether the expansion has been memorized. *) + +let lte_public p1 p2 = + (* Private <= Public *) + match (p1, p2) with + | Private, _ | _, Public -> true + | Public, Private -> false + +let rec find_expans priv p1 = function + | Mnil -> None + | Mcons (priv', p2, _ty0, ty, _) when lte_public priv priv' && Path.same p1 p2 + -> + Some ty + | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem + | Mlink {contents = rem} -> find_expans priv p1 rem + +(* debug: check for cycles in abbreviation. only works with -principal + let rec check_expans visited ty = + let ty = repr ty in + assert (not (List.memq ty visited)); + match ty.desc with + Tconstr (path, args, abbrev) -> + begin match find_expans path !abbrev with + Some ty' -> check_expans (ty :: visited) ty' + | None -> () + end + | _ -> () +*) + +let memo = ref [] +(* Contains the list of saved abbreviation expansions. *) + +let cleanup_abbrev () = + (* Remove all memorized abbreviation expansions. *) + List.iter (fun abbr -> abbr := Mnil) !memo; + memo := [] + +let memorize_abbrev mem priv path v v' = + (* Memorize the expansion of an abbreviation. *) + mem := Mcons (priv, path, v, v', !mem); + (* check_expans [] v; *) + memo := mem :: !memo + +let rec forget_abbrev_rec mem path = + match mem with + | Mnil -> assert false + | Mcons (_, path', _, _, rem) when Path.same path path' -> rem + | Mcons (priv, path', v, v', rem) -> + Mcons (priv, path', v, v', forget_abbrev_rec rem path) + | Mlink mem' -> + mem' := forget_abbrev_rec !mem' path; + raise Exit + +let forget_abbrev mem path = + try mem := forget_abbrev_rec !mem path with Exit -> () + +(* debug: check for invalid abbreviations + let rec check_abbrev_rec = function + Mnil -> true + | Mcons (_, ty1, ty2, rem) -> + repr ty1 != repr ty2 + | Mlink mem' -> + check_abbrev_rec !mem' + + let check_memorized_abbrevs () = + List.for_all (fun mem -> check_abbrev_rec !mem) !memo +*) + +(**********************************) +(* Utilities for labels *) +(**********************************) + +let is_optional = function + | Optional _ -> true + | _ -> false + +let label_name = function + | Nolabel -> "" + | Labelled {txt} | Optional {txt} -> txt + +let prefixed_label_name = function + | Nolabel -> "" + | Labelled {txt = s} -> "~" ^ s + | Optional {txt = s} -> "?" ^ s + +type sargs = (Asttypes.arg_label * Parsetree.expression) list + +let rec extract_label_aux hd l = function + | [] -> None + | ((l', t) as p) :: ls -> + if label_name l' = l then Some (l', t, List.rev_append hd ls) + else extract_label_aux (p :: hd) l ls + +let extract_label l (ls : sargs) : + (arg_label * Parsetree.expression * sargs) option = + extract_label_aux [] l ls + +let rec label_assoc x (args : sargs) = + match args with + | [] -> false + | (a, _) :: l -> Asttypes.same_arg_label a x || label_assoc x l + +(**********************************) +(* Utilities for backtracking *) +(**********************************) + +let undo_change = function + | Ctype (ty, desc) -> ty.desc <- desc + | Ccompress (ty, desc, _) -> ty.desc <- desc + | Clevel (ty, level) -> ty.level <- level + | Cname (r, v) -> r := v + | Crow (r, v) -> r := v + | Ckind (r, v) -> r := v + | Ccommu (r, v) -> r := v + | Cuniv (r, v) -> r := v + | Ctypeset (r, v) -> r := v + +type snapshot = changes ref * int +let last_snapshot = ref 0 + +let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +let link_type ty ty' = + log_type ty; + let desc = ty.desc in + ty.desc <- Tlink ty'; + (* Name is a user-supplied name for this unification variable (obtained + * through a type annotation for instance). *) + match (desc, ty'.desc) with + | Tvar name, Tvar name' -> ( + match (name, name') with + | Some _, None -> + log_type ty'; + ty'.desc <- Tvar name + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then ( + log_type ty'; + ty'.desc <- Tvar name) + | None, None -> ()) + | _ -> () + +(* ; assert (check_memorized_abbrevs ()) *) +(* ; check_expans [] ty' *) +let set_level ty level = + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + ty.level <- level +let set_univar rty ty = + log_change (Cuniv (rty, !rty)); + rty := Some ty +let set_name nm v = + log_change (Cname (nm, !nm)); + nm := v +let set_row_field e v = + log_change (Crow (e, !e)); + e := Some v +let set_kind rk k = + log_change (Ckind (rk, !rk)); + rk := Some k +let set_commu rc c = + log_change (Ccommu (rc, !rc)); + rc := c +let set_typeset rs s = + log_change (Ctypeset (rs, !rs)); + rs := s + +let snapshot () = + let old = !last_snapshot in + last_snapshot := !new_id; + match Weak.get trail 0 with + | Some r -> (r, old) + | None -> + let r = ref Unchanged in + Weak.set trail 0 (Some r); + (r, old) + +let rec rev_log accu = function + | Unchanged -> accu + | Invalid -> assert false + | Change (ch, next) -> + let d = !next in + next := Invalid; + rev_log (ch :: accu) d + +let backtrack (changes, old) = + match !changes with + | Unchanged -> last_snapshot := old + | Invalid -> failwith "Btype.backtrack" + | Change _ as change -> + cleanup_abbrev (); + let backlog = rev_log [] change in + List.iter undo_change backlog; + changes := Unchanged; + last_snapshot := old; + Weak.set trail 0 (Some changes) + +let rec rev_compress_log log r = + match !r with + | Unchanged | Invalid -> log + | Change (Ccompress _, next) -> rev_compress_log (r :: log) next + | Change (_, next) -> rev_compress_log log next + +let undo_compress (changes, _old) = + match !changes with + | Unchanged | Invalid -> () + | Change _ -> + let log = rev_compress_log [] changes in + List.iter + (fun r -> + match !r with + | Change (Ccompress (ty, desc, d), next) when ty.desc == d -> + ty.desc <- desc; + r := !next + | _ -> ()) + log diff --git a/compiler/ml/btype.mli b/compiler/ml/btype.mli new file mode 100644 index 0000000..ef099af --- /dev/null +++ b/compiler/ml/btype.mli @@ -0,0 +1,242 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Basic operations on core types *) + +open Asttypes +open Types + +(**** Sets, maps and hashtables of types ****) + +module TypeSet : Set.S with type elt = type_expr +module TypeMap : Map.S with type key = type_expr +module TypeHash : Hashtbl.S with type key = type_expr + +(**** Levels ****) + +val generic_level : int + +val newty2 : int -> type_desc -> type_expr +(* Create a type *) + +val newgenty : type_desc -> type_expr +(* Create a generic type *) + +val newgenvar : ?name:string -> unit -> type_expr +(* Return a fresh generic variable *) + +(* Use Tsubst instead + val newmarkedvar: int -> type_expr + (* Return a fresh marked variable *) + val newmarkedgenvar: unit -> type_expr + (* Return a fresh marked generic variable *) +*) + +(**** Types ****) + +val is_Tvar : type_expr -> bool +val is_Tunivar : type_expr -> bool +val is_Tconstr : type_expr -> bool +val dummy_method : label +val default_mty : module_type option -> module_type + +val repr : type_expr -> type_expr +(* Return the canonical representative of a type. *) + +val field_kind_repr : field_kind -> field_kind +(* Return the canonical representative of an object field + kind. *) + +val commu_repr : commutable -> commutable +(* Return the canonical representative of a commutation lock *) + +(**** polymorphic variants ****) + +val row_repr : row_desc -> row_desc +(* Return the canonical representative of a row description *) + +val row_field_repr : row_field -> row_field +val row_field : label -> row_desc -> row_field +(* Return the canonical representative of a row field *) + +val row_more : row_desc -> type_expr +(* Return the extension variable of the row *) + +val row_fixed : row_desc -> bool +(* Return whether the row should be treated as fixed or not *) + +val static_row : row_desc -> bool +(* Return whether the row is static or not *) + +val hash_variant : label -> int +(* Hash function for variant tags *) + +val proxy : type_expr -> type_expr +(* Return the proxy representative of the type: either itself + or a row variable *) + +(**** Utilities for private abbreviations with fixed rows ****) +val row_of_type : type_expr -> type_expr +val has_constr_row : type_expr -> bool +val is_row_name : string -> bool +val is_constr_row : allow_ident:bool -> type_expr -> bool + +(**** Utilities for type traversal ****) + +val iter_type_expr : (type_expr -> unit) -> type_expr -> unit +(* Iteration on types *) + +val iter_row : (type_expr -> unit) -> row_desc -> unit +(* Iteration on types in a row *) + +val iter_abbrev : (type_expr -> unit) -> abbrev_memo -> unit +(* Iteration on types in an abbreviation list *) + +type type_iterators = { + it_signature: type_iterators -> signature -> unit; + it_signature_item: type_iterators -> signature_item -> unit; + it_value_description: type_iterators -> value_description -> unit; + it_type_declaration: type_iterators -> type_declaration -> unit; + it_extension_constructor: type_iterators -> extension_constructor -> unit; + it_module_declaration: type_iterators -> module_declaration -> unit; + it_modtype_declaration: type_iterators -> modtype_declaration -> unit; + it_module_type: type_iterators -> module_type -> unit; + it_type_kind: type_iterators -> type_kind -> unit; + it_do_type_expr: type_iterators -> type_expr -> unit; + it_type_expr: type_iterators -> type_expr -> unit; + it_path: Path.t -> unit; +} +val type_iterators : type_iterators +(* Iteration on arbitrary type information. + [it_type_expr] calls [mark_type_node] to avoid loops. *) + +val unmark_iterators : type_iterators +(* Unmark any structure containing types. See [unmark_type] below. *) + +val copy_type_desc : + ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc +(* Copy on types *) + +val copy_row : + (type_expr -> type_expr) -> bool -> row_desc -> bool -> type_expr -> row_desc +val copy_kind : field_kind -> field_kind + +val save_desc : type_expr -> type_desc -> unit +(* Save a type description *) + +val dup_kind : field_kind option ref -> unit +(* Save a None field_kind, and make it point to a fresh Fvar *) + +val cleanup_types : unit -> unit +(* Restore type descriptions *) + +val lowest_level : int +(* Marked type: ty.level < lowest_level *) + +val pivot_level : int +(* Type marking: ty.level <- pivot_level - ty.level *) + +val mark_type : type_expr -> unit +(* Mark a type *) + +val mark_type_node : type_expr -> unit +(* Mark a type node (but not its sons) *) + +val mark_type_params : type_expr -> unit +(* Mark the sons of a type node *) + +val unmark_type : type_expr -> unit +val unmark_type_decl : type_declaration -> unit +val unmark_extension_constructor : extension_constructor -> unit + +(**** Memorization of abbreviation expansion ****) + +val find_expans : private_flag -> Path.t -> abbrev_memo -> type_expr option +(* Look up a memorized abbreviation *) + +val cleanup_abbrev : unit -> unit +(* Flush the cache of abbreviation expansions. + When some types are saved (using [output_value]), this + function MUST be called just before. *) + +val memorize_abbrev : + abbrev_memo ref -> private_flag -> Path.t -> type_expr -> type_expr -> unit +(* Add an expansion in the cache *) + +val forget_abbrev : abbrev_memo ref -> Path.t -> unit +(* Remove an abbreviation from the cache *) + +(**** Utilities for labels ****) + +val is_optional : arg_label -> bool +val label_name : arg_label -> label + +(* Returns the label name with first character '?' or '~' as appropriate. *) +val prefixed_label_name : arg_label -> label + +type sargs = (arg_label * Parsetree.expression) list + +val extract_label : + label -> sargs -> (arg_label * Parsetree.expression * sargs) option +(* actual label, value, new list with the same order *) + +val label_assoc : arg_label -> sargs -> bool +(**** Utilities for backtracking ****) + +type snapshot +(* A snapshot for backtracking *) + +val snapshot : unit -> snapshot +(* Make a snapshot for later backtracking. Costs nothing *) + +val backtrack : snapshot -> unit +(* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) + +val undo_compress : snapshot -> unit +(* Backtrack only path compression. Only meaningful if you have + not already backtracked to a previous snapshot. + Does not call [cleanup_abbrev] *) + +(* Functions to use when modifying a type (only Ctype?) *) +val link_type : type_expr -> type_expr -> unit +(* Set the desc field of [t1] to [Tlink t2], logging the old + value if there is an active snapshot *) + +val set_level : type_expr -> int -> unit +val set_name : + (Path.t * type_expr list) option ref -> + (Path.t * type_expr list) option -> + unit +val set_row_field : row_field option ref -> row_field -> unit +val set_univar : type_expr option ref -> type_expr -> unit +val set_kind : field_kind option ref -> field_kind -> unit +val set_commu : commutable ref -> commutable -> unit +val set_typeset : TypeSet.t ref -> TypeSet.t -> unit +(* Set references, logging the old value *) + +val log_type : type_expr -> unit +(* Log the old value of a type, before modifying it by hand *) + +(**** Forward declarations ****) +val print_raw : (Format.formatter -> type_expr -> unit) ref + +val iter_type_expr_kind : (type_expr -> unit) -> type_kind -> unit + +val iter_type_expr_cstr_args : + (type_expr -> unit) -> constructor_arguments -> unit +val map_type_expr_cstr_args : + (type_expr -> type_expr) -> constructor_arguments -> constructor_arguments diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml new file mode 100644 index 0000000..a4d0731 --- /dev/null +++ b/compiler/ml/builtin_attributes.ml @@ -0,0 +1,254 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Parsetree + +let string_of_cst = function + | Pconst_string (s, _) -> Some s + | _ -> None + +let string_of_payload = function + | PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant c}, _)}] -> + string_of_cst c + | _ -> None + +let string_of_opt_payload p = + match string_of_payload p with + | Some s -> s + | None -> "" + +let rec error_of_extension ext = + match ext with + | {txt = ("ocaml.error" | "error") as txt; loc}, p -> ( + let rec sub_from inner = + match inner with + | {pstr_desc = Pstr_extension (ext, _)} :: rest -> + error_of_extension ext :: sub_from rest + | _ :: rest -> + Location.errorf ~loc "Invalid syntax for sub-error of extension '%s'." + txt + :: sub_from rest + | [] -> [] + in + match p with + | PStr [] -> raise Location.Already_displayed_error + | PStr + ({ + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (msg, _))}, _); + } + :: { + pstr_desc = + Pstr_eval + ( {pexp_desc = Pexp_constant (Pconst_string (if_highlight, _))}, + _ ); + } + :: inner) -> + Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg + | PStr + ({ + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (msg, _))}, _); + } + :: inner) -> + Location.error ~loc ~sub:(sub_from inner) msg + | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt) + | {txt; loc}, _ -> Location.errorf ~loc "Uninterpreted extension '%s'." txt + +let cat s1 s2 = + if s2 = "" then s1 + else (* 2 spaces indentation for the next line *) + s1 ^ "\n " ^ s2 + +let rec deprecated_of_attrs = function + | [] -> None + | ({txt = "ocaml.deprecated" | "deprecated"; _}, p) :: _ -> + Some (string_of_opt_payload p) + | _ :: tl -> deprecated_of_attrs tl + +let rec deprecated_of_attrs_with_migrate = function + | [] -> None + | ( {txt = "deprecated"; _}, + PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (fields, _)}, _)}] + ) + :: _ -> ( + let reason = + fields + |> List.find_map (fun field -> + match field with + | { + lid = {txt = Lident "reason"}; + x = {pexp_desc = Pexp_constant (Pconst_string (reason, _))}; + } -> + Some reason + | _ -> None) + in + let migration_template = + fields + |> List.find_map (fun field -> + match field with + | {lid = {txt = Lident "migrate"}; x = migration_template} -> + Some migration_template + | _ -> None) + in + let migration_in_pipe_chain_template = + fields + |> List.find_map (fun field -> + match field with + | { + lid = {txt = Lident "migrateInPipeChain"}; + x = migration_in_pipe_chain_template; + } -> + Some migration_in_pipe_chain_template + | _ -> None) + in + + (* TODO: Validate and error if expected shape mismatches *) + match reason with + | Some reason -> + Some (reason, migration_template, migration_in_pipe_chain_template) + | None -> None) + | ({txt = "ocaml.deprecated" | "deprecated"; _}, p) :: _ -> + Some (string_of_opt_payload p, None, None) + | _ :: tl -> deprecated_of_attrs_with_migrate tl + +let check_deprecated ?deprecated_context loc attrs s = + match deprecated_of_attrs_with_migrate attrs with + | None -> () + | Some (txt, migration_template, migration_in_pipe_chain_template) -> + !Cmt_utils.record_deprecated_used + ?deprecated_context ?migration_template ?migration_in_pipe_chain_template + loc txt; + Location.deprecated + ~can_be_automigrated: + (Option.is_some migration_template + || Option.is_some migration_in_pipe_chain_template) + loc (cat s txt) + +let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s = + match (deprecated_of_attrs attrs1, deprecated_of_attrs attrs2) with + | None, _ | Some _, Some _ -> () + | Some txt, None -> Location.deprecated ~def ~use loc (cat s txt) + +let rec deprecated_mutable_of_attrs = function + | [] -> None + | ({txt = "ocaml.deprecated_mutable" | "deprecated_mutable"; _}, p) :: _ -> + Some (string_of_opt_payload p) + | _ :: tl -> deprecated_mutable_of_attrs tl + +let check_deprecated_mutable loc attrs s = + match deprecated_mutable_of_attrs attrs with + | None -> () + | Some txt -> + Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) + +let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = + match + (deprecated_mutable_of_attrs attrs1, deprecated_mutable_of_attrs attrs2) + with + | None, _ | Some _, Some _ -> () + | Some txt, None -> + Location.deprecated ~def ~use loc + (Printf.sprintf "mutating field %s" (cat s txt)) + +let check_bs_attributes_inclusion = ref (fun _attrs1 _attrs2 _s -> None) + +let check_duplicated_labels : (_ -> _ option) ref = ref (fun _lbls -> None) + +let rec deprecated_of_sig = function + | {psig_desc = Psig_attribute a} :: tl -> ( + match deprecated_of_attrs [a] with + | None -> deprecated_of_sig tl + | Some _ as r -> r) + | _ -> None + +let rec deprecated_of_str = function + | {pstr_desc = Pstr_attribute a} :: tl -> ( + match deprecated_of_attrs [a] with + | None -> deprecated_of_str tl + | Some _ as r -> r) + | _ -> None + +let warning_attribute ?(ppwarning = true) = + let process loc txt errflag payload = + match string_of_payload payload with + | Some s -> ( + try Warnings.parse_options errflag s + with Arg.Bad _ -> + Location.prerr_warning loc + (Warnings.Attribute_payload (txt, "Ill-formed list of warnings"))) + | None -> + Location.prerr_warning loc + (Warnings.Attribute_payload (txt, "A single string literal is expected")) + in + function + | {txt = ("ocaml.warning" | "warning") as txt; loc}, payload -> + process loc txt false payload + | {txt = ("ocaml.warnerror" | "warnerror") as txt; loc}, payload -> + process loc txt true payload + | ( {txt = "ocaml.ppwarning" | "ppwarning"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _); + pstr_loc; + }; + ] ) + when ppwarning -> + Location.prerr_warning pstr_loc (Warnings.Preprocessor s) + | _ -> () + +let warning_scope ?ppwarning attrs f = + let prev = Warnings.backup () in + try + List.iter (warning_attribute ?ppwarning) (List.rev attrs); + let ret = f () in + Warnings.restore prev; + ret + with exn -> + Warnings.restore prev; + raise exn + +let warn_on_literal_pattern = + List.exists (function + | {txt = "ocaml.warn_on_literal_pattern" | "warn_on_literal_pattern"; _}, _ + -> + true + | _ -> false) + +let explicit_arity = + List.exists (function + | {txt = "ocaml.explicit_arity" | "explicit_arity"; _}, _ -> true + | _ -> false) + +let immediate = + List.exists (function + | {txt = "ocaml.immediate" | "immediate"; _}, _ -> true + | _ -> false) + +(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" + attributes cannot be input by the user, they are added by the + compiler when applying the default setting. This is done to record + in the .cmi the default used by the compiler when compiling the + source file because the default can change between compiler + invocations. *) + +let check l (x, _) = List.mem x.txt l + +let has_unboxed attr = List.exists (check ["ocaml.unboxed"; "unboxed"]) attr + +let has_boxed attr = List.exists (check ["ocaml.boxed"; "boxed"]) attr diff --git a/compiler/ml/builtin_attributes.mli b/compiler/ml/builtin_attributes.mli new file mode 100644 index 0000000..63bf762 --- /dev/null +++ b/compiler/ml/builtin_attributes.mli @@ -0,0 +1,97 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2012 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. *) +(* *) +(**************************************************************************) + +(* Support for some of the builtin attributes: + + ocaml.deprecated + ocaml.error + ocaml.ppwarning + ocaml.warning + ocaml.warnerror + ocaml.explicit_arity (for camlp4/camlp5) + ocaml.warn_on_literal_pattern + ocaml.deprecated_mutable + ocaml.immediate + ocaml.boxed / ocaml.unboxed +*) + +val check_deprecated : + ?deprecated_context:Cmt_utils.deprecated_used_context -> + Location.t -> + Parsetree.attributes -> + string -> + unit +val check_deprecated_inclusion : + def:Location.t -> + use:Location.t -> + Location.t -> + Parsetree.attributes -> + Parsetree.attributes -> + string -> + unit +val deprecated_of_attrs : Parsetree.attributes -> string option +val deprecated_of_sig : Parsetree.signature -> string option +val deprecated_of_str : Parsetree.structure -> string option + +val check_deprecated_mutable : + Location.t -> Parsetree.attributes -> string -> unit +val check_deprecated_mutable_inclusion : + def:Location.t -> + use:Location.t -> + Location.t -> + Parsetree.attributes -> + Parsetree.attributes -> + string -> + unit + +val check_bs_attributes_inclusion : + (Parsetree.attributes -> + Parsetree.attributes -> + string -> + (string * string) option) + ref + +val check_duplicated_labels : + (Parsetree.label_declaration list -> string Asttypes.loc option) ref +val error_of_extension : Parsetree.extension -> Location.error + +val warning_attribute : ?ppwarning:bool -> Parsetree.attribute -> unit +(** Apply warning settings from the specified attribute. + "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) + are processed and other attributes are ignored. + + Also implement ocaml.ppwarning (unless ~ppwarning:false is + passed). + *) + +val warning_scope : + ?ppwarning:bool -> Parsetree.attributes -> (unit -> 'a) -> 'a +(** Execute a function in a new scope for warning settings. This + means that the effect of any call to [warning_attribute] during + the execution of this function will be discarded after + execution. + + The function also takes a list of attributes which are processed + with [warning_attribute] in the fresh scope before the function + is executed. + *) + +val warn_on_literal_pattern : Parsetree.attributes -> bool +val explicit_arity : Parsetree.attributes -> bool + +val immediate : Parsetree.attributes -> bool + +val has_unboxed : Parsetree.attributes -> bool +val has_boxed : Parsetree.attributes -> bool diff --git a/compiler/ml/ccomp.ml b/compiler/ml/ccomp.ml new file mode 100644 index 0000000..d6fb5f1 --- /dev/null +++ b/compiler/ml/ccomp.ml @@ -0,0 +1,6 @@ +let command cmdline = + if !Clflags.verbose then ( + prerr_string "+ "; + prerr_string cmdline; + prerr_newline ()); + Sys.command cmdline diff --git a/compiler/ml/ccomp.mli b/compiler/ml/ccomp.mli new file mode 100644 index 0000000..87678cc --- /dev/null +++ b/compiler/ml/ccomp.mli @@ -0,0 +1 @@ +val command : string -> int diff --git a/jscomp/ml/classify_function.ml b/compiler/ml/classify_function.ml similarity index 87% rename from jscomp/ml/classify_function.ml rename to compiler/ml/classify_function.ml index 5565b23..1a7b0f4 100644 --- a/jscomp/ml/classify_function.ml +++ b/compiler/ml/classify_function.ml @@ -24,7 +24,10 @@ let rec is_obj_literal (x : _ Flow_ast.Expression.t) : bool = match snd x with - | Identifier (_, {name = "undefined"}) | Literal _ -> true + | Identifier (_, {name = "undefined"}) + | StringLiteral _ | BooleanLiteral _ | NullLiteral _ | NumberLiteral _ + | BigIntLiteral _ | RegExpLiteral _ | ModuleRefLiteral _ -> + true | Unary {operator = Minus; argument} -> is_obj_literal argument | Object {properties} -> Ext_list.for_all properties is_literal_kv | Array {elements} -> @@ -61,7 +64,13 @@ let classify_exp (prog : _ Flow_ast.Expression.t) : Js_raw_info.exp = predicate = None; } ) -> Js_function {arity = List.length params; arrow = true} - | _, Literal {comments} -> + | _, StringLiteral {comments} + | _, BooleanLiteral {comments} + | _, NullLiteral comments + | _, NumberLiteral {comments} + | _, BigIntLiteral {comments} + | _, RegExpLiteral {comments} + | _, ModuleRefLiteral {comments} -> let comment = match comments with | None -> None @@ -84,7 +93,9 @@ let classify_exp (prog : _ Flow_ast.Expression.t) : Js_raw_info.exp = let classify ?(check : (Location.t * int) option) (prog : string) : Js_raw_info.exp = let prog, errors = - Parser_flow.parse_expression (Parser_env.init_env None prog) false + let open Parser_flow in + let env = Parser_env.init_env None prog in + do_parse env Parse.expression false in match (check, errors) with | Some (loc, offset), _ :: _ -> diff --git a/jscomp/ml/classify_function.mli b/compiler/ml/classify_function.mli similarity index 100% rename from jscomp/ml/classify_function.mli rename to compiler/ml/classify_function.mli diff --git a/compiler/ml/clflags.ml b/compiler/ml/clflags.ml new file mode 100644 index 0000000..f0cd881 --- /dev/null +++ b/compiler/ml/clflags.ml @@ -0,0 +1,73 @@ +let output_name = ref (None : string option) (* -o *) + +and include_dirs = ref ([] : string list) (* -I *) + +and debug = ref false (* -g *) + +and fast = ref false (* -unsafe *) + +and nopervasives = ref false (* -nopervasives *) + +and preprocessor = ref (None : string option) (* -pp *) + +and all_ppx = ref ([] : string list) + +(* -ppx *) +let annotations = ref false (* -annot *) +let binary_annotations = ref false (* -annot *) + +and noassert = ref false (* -noassert *) + +and verbose = ref false (* -verbose *) + +and open_modules = ref [] (* -open *) + +and real_paths = ref true (* -short-paths *) + +and applicative_functors = ref true (* -no-app-funct *) + +and error_size = ref 500 (* -error-size *) + +and transparent_modules = ref false (* -trans-mod *) +let dump_source = ref false (* -dsource *) +let dump_parsetree = ref false (* -dparsetree *) + +and dump_typedtree = ref false (* -dtypedtree *) + +and dump_rawlambda = ref false (* -drawlambda *) + +and dump_lambda = ref false (* -dlambda *) + +and only_parse = ref false (* -only-parse *) + +and editor_mode = ref false (* -editor-mode *) + +and ignore_parse_errors = ref false (* -ignore-parse-errors *) + +let dont_write_files = ref false (* set to true under ocamldoc *) + +let reset_dump_state () = + dump_source := false; + dump_parsetree := false; + dump_typedtree := false; + dump_rawlambda := false + +let keep_locs = ref true (* -keep-locs *) + +let parse_color_setting = function + | "auto" -> Some Misc.Color.Auto + | "always" -> Some Misc.Color.Always + | "never" -> Some Misc.Color.Never + | _ -> None +let color = ref None + +(* -color *) + +let unboxed_types = ref false + +type mli_status = Mli_exists | Mli_non_exists +let assume_no_mli = ref Mli_non_exists +let dont_record_crc_unit : string option ref = ref None +let bs_gentype = ref false +let no_assert_false = ref false +let dump_location = ref true diff --git a/jscomp/ml/clflags.mli b/compiler/ml/clflags.mli similarity index 87% rename from jscomp/ml/clflags.mli rename to compiler/ml/clflags.mli index 80b1704..0cb5f1e 100644 --- a/jscomp/ml/clflags.mli +++ b/compiler/ml/clflags.mli @@ -22,24 +22,21 @@ val dump_typedtree : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref val dont_write_files : bool ref -val keep_docs : bool ref val keep_locs : bool ref val only_parse : bool ref -val ignore_parse_errors: bool ref - +val ignore_parse_errors : bool ref +val editor_mode : bool ref val parse_color_setting : string -> Misc.Color.setting option val color : Misc.Color.setting option ref val unboxed_types : bool ref -val reset_dump_state: unit -> unit - +val reset_dump_state : unit -> unit -type mli_status = Mli_exists | Mli_non_exists +type mli_status = Mli_exists | Mli_non_exists val assume_no_mli : mli_status ref val dont_record_crc_unit : string option ref val bs_gentype : bool ref val no_assert_false : bool ref val dump_location : bool ref - diff --git a/compiler/ml/cmi_format.ml b/compiler/ml/cmi_format.ml new file mode 100644 index 0000000..1a708b9 --- /dev/null +++ b/compiler/ml/cmi_format.ml @@ -0,0 +1,134 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 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 pers_flags = Deprecated of string + +type error = + | Not_an_interface of string + | Wrong_version_interface of string * string + | Corrupted_interface of string + +exception Error of error + +type cmi_infos = { + cmi_name: string; + cmi_sign: Types.signature_item list; + cmi_crcs: (string * Digest.t option) list; + cmi_flags: pers_flags list; +} + +let input_cmi ic = + let name, sign = input_value ic in + let crcs = input_value ic in + let flags = input_value ic in + {cmi_name = name; cmi_sign = sign; cmi_crcs = crcs; cmi_flags = flags} + +let read_cmi filename = + let ic = open_in_bin filename in + try + let buffer = + really_input_string ic (String.length Config.cmi_magic_number) + in + if buffer <> Config.cmi_magic_number then ( + close_in ic; + let pre_len = String.length Config.cmi_magic_number - 3 in + if + String.sub buffer 0 pre_len + = String.sub Config.cmi_magic_number 0 pre_len + then + let msg = + if buffer < Config.cmi_magic_number then "an older" else "a newer" + in + raise (Error (Wrong_version_interface (filename, msg))) + else raise (Error (Not_an_interface filename))); + let cmi = input_cmi ic in + close_in ic; + cmi + with + | End_of_file | Failure _ -> + close_in ic; + raise (Error (Corrupted_interface filename)) + | Error e -> + close_in ic; + raise (Error e) + +let output_cmi filename oc cmi = + (* beware: the provided signature must have been substituted for saving *) + output_string oc Config.cmi_magic_number; + output_value oc (cmi.cmi_name, cmi.cmi_sign); + flush oc; + let crc = Digest.file filename in + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + output_value oc crcs; + output_value oc cmi.cmi_flags; + crc + +(* This function is also called by [save_cmt] as cmi_format is subset of + cmt_format, so dont close the channel yet +*) +let create_cmi ?check_exists filename (cmi : cmi_infos) = + (* beware: the provided signature must have been substituted for saving *) + let content = + Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) [] + (* checkout [output_value] in {!Pervasives} module *) + in + let crc = Digest.string content in + let cmi_infos = + if check_exists <> None && Sys.file_exists filename then + Some (read_cmi filename) + else None + in + match cmi_infos with + | Some + { + cmi_name = _; + cmi_sign = _; + cmi_crcs = (old_name, Some old_crc) :: rest; + cmi_flags; + } + (* TODO: design the cmi format so that we don't need read the whole cmi *) + when cmi.cmi_name = old_name && crc = old_crc && cmi.cmi_crcs = rest + && cmi_flags = cmi.cmi_flags -> + crc + | _ -> + let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in + let oc = open_out_bin filename in + output_string oc content; + output_value oc crcs; + output_value oc cmi.cmi_flags; + close_out oc; + crc + +(* Error report *) + +open Format + +let report_error ppf = function + | Not_an_interface filename -> + fprintf ppf "%a@ is not a compiled interface" Location.print_filename + filename + | Wrong_version_interface (filename, older_newer) -> + fprintf ppf + "%a@ is not a compiled interface for this version of OCaml.@.It seems to \ + be for %s version of OCaml." + Location.print_filename filename older_newer + | Corrupted_interface filename -> + fprintf ppf "Corrupted compiled interface@ %a" Location.print_filename + filename + +let () = + Location.register_error_of_exn (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None) diff --git a/jscomp/ml/cmi_format.mli b/compiler/ml/cmi_format.mli similarity index 86% rename from jscomp/ml/cmi_format.mli rename to compiler/ml/cmi_format.mli index 7aa7f8d..ca608d3 100644 --- a/jscomp/ml/cmi_format.mli +++ b/compiler/ml/cmi_format.mli @@ -13,16 +13,13 @@ (* *) (**************************************************************************) -type pers_flags = - | Deprecated of string - - +type pers_flags = Deprecated of string type cmi_infos = { - cmi_name : string; - cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t option) list; - cmi_flags : pers_flags list; + cmi_name: string; + cmi_sign: Types.signature_item list; + cmi_crcs: (string * Digest.t option) list; + cmi_flags: pers_flags list; } (* write the magic + the cmi information *) @@ -39,7 +36,7 @@ val read_cmi : string -> cmi_infos (* Error report *) type error = - Not_an_interface of string + | Not_an_interface of string | Wrong_version_interface of string * string | Corrupted_interface of string @@ -47,4 +44,4 @@ exception Error of error open Format -val report_error: formatter -> error -> unit +val report_error : formatter -> error -> unit diff --git a/jscomp/ml/cmt_format.ml b/compiler/ml/cmt_format.ml similarity index 90% rename from jscomp/ml/cmt_format.ml rename to compiler/ml/cmt_format.ml index b3a6b66..ff30fc0 100644 --- a/jscomp/ml/cmt_format.ml +++ b/compiler/ml/cmt_format.ml @@ -63,6 +63,7 @@ type cmt_infos = { cmt_imports : (string * Digest.t option) list; cmt_interface_digest : Digest.t option; cmt_use_summaries : bool; + cmt_extra_info: Cmt_utils.cmt_extra_info; } type error = @@ -154,15 +155,30 @@ let read_cmi filename = let saved_types = ref [] let value_deps = ref [] +let deprecated_used = ref [] let clear () = saved_types := []; - value_deps := [] + value_deps := []; + deprecated_used := [] let add_saved_type b = saved_types := b :: !saved_types let get_saved_types () = !saved_types let set_saved_types l = saved_types := l +let record_deprecated_used ?deprecated_context ?migration_template ?migration_in_pipe_chain_template source_loc deprecated_text = + deprecated_used := + { + Cmt_utils.source_loc; + deprecated_text; + migration_template; + migration_in_pipe_chain_template; + context = deprecated_context; + } + :: !deprecated_used + +let _ = Cmt_utils.record_deprecated_used := record_deprecated_used + let record_value_dependency vd1 vd2 = if vd1.Types.val_loc <> vd2.Types.val_loc then value_deps := (vd1, vd2) :: !value_deps @@ -174,9 +190,7 @@ open Cmi_format let save_cmt filename modname binary_annots sourcefile initial_env cmi = if !Clflags.binary_annotations then begin - (if !Config.bs_only then Misc.output_to_bin_file_directly else - Misc.output_to_file_via_temporary - ~mode:[Open_binary] ) filename + Misc.output_to_bin_file_directly filename (fun temp_file_name oc -> let this_crc = match cmi with @@ -188,7 +202,7 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi = cmt_modname = modname; cmt_annots = clear_env binary_annots; cmt_value_dependencies = !value_deps; - cmt_comments = Lexer.comments (); + cmt_comments = []; cmt_args = Sys.argv; cmt_sourcefile = sourcefile; cmt_builddir = Sys.getcwd (); @@ -199,8 +213,9 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi = cmt_imports = List.sort compare (Env.imports ()); cmt_interface_digest = this_crc; cmt_use_summaries = need_to_clear_env; + cmt_extra_info = {deprecated_used = !deprecated_used}; } in output_cmt oc cmt) end; clear () -#endif \ No newline at end of file +#endif diff --git a/jscomp/ml/cmt_format.mli b/compiler/ml/cmt_format.mli similarity index 78% rename from jscomp/ml/cmt_format.mli rename to compiler/ml/cmt_format.mli index 6daf643..66589f0 100644 --- a/jscomp/ml/cmt_format.mli +++ b/compiler/ml/cmt_format.mli @@ -49,27 +49,28 @@ and binary_part = | Partial_module_type of module_type type cmt_infos = { - cmt_modname : string; - cmt_annots : binary_annots; - cmt_value_dependencies : + cmt_modname: string; + cmt_annots: binary_annots; + cmt_value_dependencies: (Types.value_description * Types.value_description) list; - cmt_comments : (string * Location.t) list; - cmt_args : string array; - cmt_sourcefile : string option; - cmt_builddir : string; - cmt_loadpath : string list; - cmt_source_digest : string option; - cmt_initial_env : Env.t; - cmt_imports : (string * Digest.t option) list; - cmt_interface_digest : Digest.t option; - cmt_use_summaries : bool; + cmt_comments: (string * Location.t) list; + cmt_args: string array; + cmt_sourcefile: string option; + cmt_builddir: string; + cmt_loadpath: string list; + cmt_source_digest: string option; + cmt_initial_env: Env.t; + cmt_imports: (string * Digest.t option) list; + cmt_interface_digest: Digest.t option; + cmt_use_summaries: bool; + cmt_extra_info: Cmt_utils.cmt_extra_info; } -type error = - Not_a_typedtree of string +type error = Not_a_typedtree of string exception Error of error +val read : string -> Cmi_format.cmi_infos option * cmt_infos option (** [read filename] opens filename, and extract both the cmi_infos, if it exists, and the cmt_infos, if it exists. Thus, it can be used with .cmi, .cmt and .cmti files. @@ -78,35 +79,46 @@ exception Error of error only contain a cmi_infos at the beginning if there is no associated .cmti file. *) -val read : string -> Cmi_format.cmi_infos option * cmt_infos option val read_cmt : string -> cmt_infos val read_cmi : string -> Cmi_format.cmi_infos -(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] - writes a cmt(i) file. *) val save_cmt : - string -> (* filename.cmt to generate *) - string -> (* module name *) + string -> + (* filename.cmt to generate *) + string -> + (* module name *) binary_annots -> - string option -> (* source file *) - Env.t -> (* initial env *) - Cmi_format.cmi_infos option -> (* if a .cmi was generated *) + string option -> + (* source file *) + Env.t -> + (* initial env *) + Cmi_format.cmi_infos option -> + (* if a .cmi was generated *) unit +(** [save_cmt filename modname binary_annots sourcefile initial_env cmi] + writes a cmt(i) file. *) (* Miscellaneous functions *) val read_magic_number : in_channel -> string -val clear: unit -> unit +val clear : unit -> unit val add_saved_type : binary_part -> unit val get_saved_types : unit -> binary_part list val set_saved_types : binary_part list -> unit -val record_value_dependency: +val record_value_dependency : Types.value_description -> Types.value_description -> unit +val record_deprecated_used : + ?deprecated_context:Cmt_utils.deprecated_used_context -> + ?migration_template:Parsetree.expression -> + ?migration_in_pipe_chain_template:Parsetree.expression -> + Location.t -> + string -> + unit (* diff --git a/compiler/ml/cmt_utils.ml b/compiler/ml/cmt_utils.ml new file mode 100644 index 0000000..3e08cd9 --- /dev/null +++ b/compiler/ml/cmt_utils.ml @@ -0,0 +1,31 @@ +type deprecated_used_context = FunctionCall | Reference + +type deprecated_used = { + source_loc: Location.t; + deprecated_text: string; + migration_template: Parsetree.expression option; + migration_in_pipe_chain_template: Parsetree.expression option; + context: deprecated_used_context option; +} + +type cmt_extra_info = {deprecated_used: deprecated_used list} + +let record_deprecated_used : + (?deprecated_context:deprecated_used_context -> + ?migration_template:Parsetree.expression -> + ?migration_in_pipe_chain_template:Parsetree.expression -> + Location.t -> + string -> + unit) + ref = + ref + (fun + ?deprecated_context + ?migration_template + ?migration_in_pipe_chain_template + _ + _ + -> + ignore deprecated_context; + ignore migration_template; + ignore migration_in_pipe_chain_template) diff --git a/compiler/ml/code_frame.ml b/compiler/ml/code_frame.ml new file mode 100644 index 0000000..9f75c76 --- /dev/null +++ b/compiler/ml/code_frame.ml @@ -0,0 +1,284 @@ +let digits_count n = + let rec loop n base count = + if n >= base then loop n (base * 10) (count + 1) else count + in + loop (abs n) 1 0 + +let seek_2_lines_before src (pos : Lexing.position) = + let original_line = pos.pos_lnum in + let rec loop current_line current_char = + if current_line + 2 >= original_line then (current_char, current_line) + else + loop + (if src.[current_char] = '\n' then current_line + 1 else current_line) + (current_char + 1) + in + loop 1 0 + +let seek_2_lines_after src (pos : Lexing.position) = + let original_line = pos.pos_lnum in + let rec loop current_line current_char = + if current_char = String.length src then (current_char, current_line) + else + match src.[current_char] with + | '\n' when current_line = original_line + 2 -> + (current_char, current_line) + | '\n' -> loop (current_line + 1) (current_char + 1) + | _ -> loop current_line (current_char + 1) + in + loop original_line pos.pos_cnum + +let leading_space_count str = + let rec loop i count = + if i = String.length str then count + else if str.[i] != ' ' then count + else loop (i + 1) (count + 1) + in + loop 0 0 + +let break_long_line max_width line = + let rec loop pos accum = + if pos = String.length line then accum + else + let chunk_length = min max_width (String.length line - pos) in + let chunk = String.sub line pos chunk_length in + loop (pos + chunk_length) (chunk :: accum) + in + loop 0 [] |> List.rev + +let filter_mapi f l = + let rec loop f l i accum = + match l with + | [] -> accum + | head :: rest -> + let accum = + match f i head with + | None -> accum + | Some result -> result :: accum + in + loop f rest (i + 1) accum + in + loop f l 0 [] |> List.rev + +(* Spiritual equivalent of + https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 +*) +module Color = struct + type color = + | Dim + (* | Filename *) + | Err + | Warn + | NoColor + + let dim = "\x1b[2m" + + (* let filename = "\x1b[46m" *) + let err = "\x1b[1;31m" + let warn = "\x1b[1;33m" + let reset = "\x1b[0m" + + external isatty : out_channel -> bool = "caml_sys_isatty" + + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" && term <> "" && isatty stderr + + let color_enabled = ref true + + let setup = + let first = ref true in + (* initialize only once *) + fun o -> + if !first then ( + first := false; + color_enabled := + match o with + | Some Misc.Color.Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()); + () +end + +let setup = Color.setup + +type gutter = Number of int | Elided +type highlighted_string = {s: string; start: int; end_: int} +type line = {gutter: gutter; content: highlighted_string list} + +(* + Features: + - display a line gutter + - break long line into multiple for terminal display + - peek 2 lines before & after for context + - center snippet when it's heavily indented + - ellide intermediate lines when the reported range is huge +*) +let print ~is_warning ~src ~(start_pos : Lexing.position) + ~(end_pos : Lexing.position) = + let indent = 2 in + let highlight_line_start_line = start_pos.pos_lnum in + let highlight_line_end_line = end_pos.pos_lnum in + let start_line_line_offset, first_shown_line = + seek_2_lines_before src start_pos + in + let end_line_line_end_offset, last_shown_line = + seek_2_lines_after src end_pos + in + + let more_than_5_highlighted_lines = + highlight_line_end_line - highlight_line_start_line + 1 > 5 + in + let max_line_digits_count = digits_count last_shown_line in + (* TODO: change this back to a fixed 100? *) + (* 3 for separator + the 2 spaces around it *) + let line_width = 78 - max_line_digits_count - indent - 3 in + let lines = + if + start_line_line_offset >= 0 + && end_line_line_end_offset >= start_line_line_offset + then + String.sub src start_line_line_offset + (end_line_line_end_offset - start_line_line_offset) + |> String.split_on_char '\n' + |> filter_mapi (fun i line -> + let line_number = i + first_shown_line in + if more_than_5_highlighted_lines then + if line_number = highlight_line_start_line + 2 then + Some (Elided, line) + else if + line_number > highlight_line_start_line + 2 + && line_number < highlight_line_end_line - 1 + then None + else Some (Number line_number, line) + else Some (Number line_number, line)) + else [] + in + let leading_space_to_cut = + lines + |> List.fold_left + (fun current_max (_, line) -> + let leading_spaces = leading_space_count line in + if String.length line = leading_spaces then + (* the line's nothing but spaces. Doesn't count *) + current_max + else min leading_spaces current_max) + 99999 + in + let separator = if leading_space_to_cut = 0 then "│" else "┆" in + let stripped_lines = + lines + |> List.map (fun (gutter, line) -> + let new_content = + if String.length line <= leading_space_to_cut then + [{s = ""; start = 0; end_ = 0}] + else + String.sub line leading_space_to_cut + (String.length line - leading_space_to_cut) + |> break_long_line line_width + |> List.mapi (fun i line -> + match gutter with + | Elided -> {s = line; start = 0; end_ = 0} + | Number line_number -> + let highlight_line_start_offset = + start_pos.pos_cnum - start_pos.pos_bol + in + let highlight_line_end_offset = + end_pos.pos_cnum - end_pos.pos_bol + in + let start = + if i = 0 && line_number = highlight_line_start_line + then + highlight_line_start_offset - leading_space_to_cut + else 0 + in + let end_ = + if line_number < highlight_line_start_line then 0 + else if + line_number = highlight_line_start_line + && line_number = highlight_line_end_line + then highlight_line_end_offset - leading_space_to_cut + else if line_number = highlight_line_start_line then + String.length line + else if + line_number > highlight_line_start_line + && line_number < highlight_line_end_line + then String.length line + else if line_number = highlight_line_end_line then + highlight_line_end_offset - leading_space_to_cut + else 0 + in + {s = line; start; end_}) + in + {gutter; content = new_content}) + in + let buf = Buffer.create 100 in + let open Color in + let add_ch = + let last_color = ref NoColor in + fun color ch -> + if (not !Color.color_enabled) || !last_color = color then + Buffer.add_char buf ch + else + let ansi = + match (!last_color, color) with + | NoColor, Dim -> dim + (* | NoColor, Filename -> filename *) + | NoColor, Err -> err + | NoColor, Warn -> warn + | _, NoColor -> reset + | _, Dim -> reset ^ dim + (* | _, Filename -> reset ^ filename *) + | _, Err -> reset ^ err + | _, Warn -> reset ^ warn + in + Buffer.add_string buf ansi; + Buffer.add_char buf ch; + last_color := color + in + let draw_gutter color s = + for _i = 1 to max_line_digits_count + indent - String.length s do + add_ch NoColor ' ' + done; + s |> String.iter (add_ch color); + add_ch NoColor ' '; + separator |> String.iter (add_ch Dim); + add_ch NoColor ' ' + in + stripped_lines + |> List.iter (fun {gutter; content} -> + match gutter with + | Elided -> + draw_gutter Dim "."; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch Dim '.'; + add_ch NoColor '\n' + | Number line_number -> + content + |> List.iteri (fun i line -> + let gutter_content = + if i = 0 then string_of_int line_number else "" + in + let gutter_color = + if + i = 0 + && line_number >= highlight_line_start_line + && line_number <= highlight_line_end_line + then if is_warning then Warn else Err + else NoColor + in + draw_gutter gutter_color gutter_content; + + line.s + |> String.iteri (fun ii ch -> + let c = + if ii >= line.start && ii < line.end_ then + if is_warning then Warn else Err + else NoColor + in + add_ch c ch); + add_ch NoColor '\n')); + Buffer.contents buf diff --git a/compiler/ml/consistbl.ml b/compiler/ml/consistbl.ml new file mode 100644 index 0000000..37047a2 --- /dev/null +++ b/compiler/ml/consistbl.ml @@ -0,0 +1,64 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 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. *) +(* *) +(**************************************************************************) + +(* Consistency tables: for checking consistency of module CRCs *) + +type t = (string, Digest.t * string) Hashtbl.t + +let create () = Hashtbl.create 13 + +let clear = Hashtbl.clear + +exception Inconsistency of string * string * string + +exception Not_available of string + +let check tbl name crc source = + try + let old_crc, old_source = Hashtbl.find tbl name in + if crc <> old_crc then raise (Inconsistency (name, source, old_source)) + with Not_found -> Hashtbl.add tbl name (crc, source) + +let check_noadd tbl name crc source = + try + let old_crc, old_source = Hashtbl.find tbl name in + if crc <> old_crc then raise (Inconsistency (name, source, old_source)) + with Not_found -> raise (Not_available name) + +let set tbl name crc source = Hashtbl.add tbl name (crc, source) + +let source tbl name = snd (Hashtbl.find tbl name) + +let extract l tbl = + let l = List.sort_uniq String.compare l in + List.fold_left + (fun assc name -> + try + let crc, _ = Hashtbl.find tbl name in + (name, Some crc) :: assc + with Not_found -> (name, None) :: assc) + [] l + +let filter p tbl = + let to_remove = ref [] in + Hashtbl.iter + (fun name _ -> if not (p name) then to_remove := name :: !to_remove) + tbl; + List.iter + (fun name -> + while Hashtbl.mem tbl name do + Hashtbl.remove tbl name + done) + !to_remove diff --git a/compiler/ml/consistbl.mli b/compiler/ml/consistbl.mli new file mode 100644 index 0000000..cfee26f --- /dev/null +++ b/compiler/ml/consistbl.mli @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 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. *) +(* *) +(**************************************************************************) + +(* Consistency tables: for checking consistency of module CRCs *) + +type t + +val create : unit -> t + +val clear : t -> unit + +val check : t -> string -> Digest.t -> string -> unit +(* [check tbl name crc source] + checks consistency of ([name], [crc]) with infos previously + stored in [tbl]. If no CRC was previously associated with + [name], record ([name], [crc]) in [tbl]. + [source] is the name of the file from which the information + comes from. This is used for error reporting. *) + +val check_noadd : t -> string -> Digest.t -> string -> unit +(* Same as [check], but raise [Not_available] if no CRC was previously + associated with [name]. *) + +val set : t -> string -> Digest.t -> string -> unit +(* [set tbl name crc source] forcefully associates [name] with + [crc] in [tbl], even if [name] already had a different CRC + associated with [name] in [tbl]. *) + +val source : t -> string -> string +(* [source tbl name] returns the file name associated with [name] + if the latter has an associated CRC in [tbl]. + Raise [Not_found] otherwise. *) + +val extract : string list -> t -> (string * Digest.t option) list +(* [extract tbl names] returns an associative list mapping each string + in [names] to the CRC associated with it in [tbl]. If no CRC is + associated with a name then it is mapped to [None]. *) + +val filter : (string -> bool) -> t -> unit +(* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs + such that [pred name] is [false]. *) + +exception Inconsistency of string * string * string +(* Raised by [check] when a CRC mismatch is detected. + First string is the name of the compilation unit. + Second string is the source that caused the inconsistency. + Third string is the source that set the CRC. *) + +exception Not_available of string +(* Raised by [check_noadd] when a name doesn't have an associated CRC. *) diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml new file mode 100644 index 0000000..e15adf3 --- /dev/null +++ b/compiler/ml/ctype.ml @@ -0,0 +1,4449 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, 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. *) +(* *) +(**************************************************************************) + +(* Operations on core types *) + +open Misc +open Asttypes +open Types +open Btype + +(* + Type manipulation after type inference + ====================================== + If one wants to manipulate a type after type inference (for + instance, during code generation or in the debugger), one must + first make sure that the type levels are correct, using the + function [correct_levels]. Then, this type can be correctly + manipulated by [apply], [expand_head] and [moregeneral]. +*) + +(* + General notes + ============= + - As much sharing as possible should be kept : it makes types + smaller and better abbreviated. + When necessary, some sharing can be lost. Types will still be + printed correctly (+++ TO DO...), and abbreviations defined by a + class do not depend on sharing thanks to constrained + abbreviations. (Of course, even if some sharing is lost, typing + will still be correct.) + - All nodes of a type have a level : that way, one know whether a + node need to be duplicated or not when instantiating a type. + - Levels of a type are decreasing (generic level being considered + as greatest). + - The level of a type constructor is superior to the binding + time of its path. + - Recursive types without limitation should be handled (even if + there is still an occur check). This avoid treating specially the + case for objects, for instance. Furthermore, the occur check + policy can then be easily changed. +*) + +(**** Errors ****) +type type_pairs = (type_expr * type_expr) list + +exception Unify of type_pairs + +exception Tags of label * label + +let () = + Location.register_error_of_exn (function + | Tags (l, l') -> + Some + Location.( + errorf ~loc:(in_file !input_name) + "In this program,@ variant constructors@ #%s and #%s@ have the \ + same hash value.@ Change one of them." + l l') + | _ -> None) + +type subtype_context = + | Generic of {errorCode: string} + | Coercion_target_variant_not_unboxed of { + variant_name: Path.t; + primitive: Path.t; + } + | Coercion_target_variant_does_not_cover_type of { + variant_name: Path.t; + primitive: Path.t; + } + | Variant_constructor_runtime_representation_mismatch of { + variant_name: Path.t; + issues: Variant_coercion.variant_runtime_representation_issue list; + } + | Variant_configurations_mismatch of { + left_variant_name: Path.t; + right_variant_name: Path.t; + issue: Variant_coercion.variant_configuration_issue; + } + | Different_type_kinds of { + left_typename: Path.t; + right_typename: Path.t; + left_type_kind: type_kind; + right_type_kind: type_kind; + } + | Record_fields_mismatch of { + left_record_name: Path.t; + right_record_name: Path.t; + issues: Record_coercion.record_field_subtype_violation list; + } + +exception Subtype of type_pairs * type_pairs * subtype_context option + +exception Cannot_expand + +exception Cannot_apply + +exception Recursive_abbrev + +(* GADT: recursive abbrevs can appear as a result of local constraints *) +exception Unification_recursive_abbrev of type_pairs + +(**** Type level management ****) + +let current_level = ref 0 +let nongen_level = ref 0 +let global_level = ref 1 +let saved_level = ref [] + +type levels = { + current_level: int; + nongen_level: int; + global_level: int; + saved_level: (int * int) list; +} +let save_levels () = + { + current_level = !current_level; + nongen_level = !nongen_level; + global_level = !global_level; + saved_level = !saved_level; + } +let set_levels l = + current_level := l.current_level; + nongen_level := l.nongen_level; + global_level := l.global_level; + saved_level := l.saved_level + +let get_current_level () = !current_level +let init_def level = + current_level := level; + nongen_level := level +let begin_def () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + incr current_level; + nongen_level := !current_level +let begin_class_def () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + incr current_level +let raise_nongen_level () = + saved_level := (!current_level, !nongen_level) :: !saved_level; + nongen_level := !current_level +let end_def () = + let cl, nl = List.hd !saved_level in + saved_level := List.tl !saved_level; + current_level := cl; + nongen_level := nl + +let reset_global_level () = global_level := !current_level + 1 +let increase_global_level () = + let gl = !global_level in + global_level := !current_level; + gl +let restore_global_level gl = global_level := gl + +(**** Whether a path points to an object type (with hidden row variable) ****) +let is_object_type path = + let name = + match path with + | Path.Pident id -> Ident.name id + | Path.Pdot (_, s, _) -> s + | Path.Papply _ -> assert false + in + name.[0] = '#' + +(**** Control tracing of GADT instances *) + +let trace_gadt_instances = ref false +let check_trace_gadt_instances env = + (not !trace_gadt_instances) + && Env.has_local_constraints env + && + (trace_gadt_instances := true; + cleanup_abbrev (); + true) + +let reset_trace_gadt_instances b = if b then trace_gadt_instances := false + +let wrap_trace_gadt_instances env f x = + let b = check_trace_gadt_instances env in + let y = f x in + reset_trace_gadt_instances b; + y + +(**** Abbreviations without parameters ****) +(* Shall reset after generalizing *) + +let simple_abbrevs = ref Mnil + +let proper_abbrevs path tl abbrev = + if tl <> [] || !trace_gadt_instances || is_object_type path then abbrev + else simple_abbrevs + +(**** Some type creators ****) + +(* Re-export generic type creators *) + +let newty2 = Btype.newty2 +let newty desc = newty2 !current_level desc + +let newvar ?name () = newty2 !current_level (Tvar name) +let newvar2 ?name level = newty2 level (Tvar name) +let new_global_var ?name () = newty2 !global_level (Tvar name) + +let newobj fields = newty (Tobject (fields, ref None)) + +let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) + +let none = newty (Ttuple []) (* Clearly ill-formed type *) + +(**** Representative of a type ****) + +(* Re-export repr *) +let repr = repr + +(**** Type maps ****) + +module TypePairs = Hashtbl.Make (struct + type t = type_expr * type_expr + let equal (t1, t1') (t2, t2') = t1 == t2 && t1' == t2' + let hash (t, t') = t.id + (93 * t'.id) +end) + +(**** unification mode ****) + +type unification_mode = + | Expression (* unification in expression *) + | Pattern (* unification in pattern which may add local constraints *) + +let umode = ref Expression +let generate_equations = ref false +let assume_injective = ref false +let variant_is_subtype = ref (fun _env _row _p1 -> false) +let set_mode_pattern ~generate ~injective f = + let old_unification_mode = !umode + and old_gen = !generate_equations + and old_inj = !assume_injective in + try + umode := Pattern; + generate_equations := generate; + assume_injective := injective; + let ret = f () in + umode := old_unification_mode; + generate_equations := old_gen; + assume_injective := old_inj; + ret + with e -> + umode := old_unification_mode; + generate_equations := old_gen; + assume_injective := old_inj; + raise e + +(*** Checks for type definitions ***) + +let in_current_module = function + | Path.Pident _ -> true + | Path.Pdot _ | Path.Papply _ -> false + +let in_pervasives p = + in_current_module p + && + try + ignore (Env.find_type p Env.initial_safe_string); + true + with Not_found -> false + +let is_datatype decl = + match decl.type_kind with + | Type_record _ | Type_variant _ | Type_open -> true + | Type_abstract -> false + +(**********************************************) +(* Miscellaneous operations on object types *) +(**********************************************) + +(* Note: + We need to maintain some invariants: + * cty_self must be a Tobject + * ... +*) +type fields = (string * Types.field_kind * Types.type_expr) list +(**** Object field manipulation. ****) + +let object_fields ty = + match (repr ty).desc with + | Tobject (fields, _) -> fields + | _ -> assert false + +let flatten_fields (ty : Types.type_expr) : fields * _ = + let rec flatten (l : fields) ty = + let ty = repr ty in + match ty.desc with + | Tfield (s, k, ty1, ty2) -> flatten ((s, k, ty1) :: l) ty2 + | _ -> (l, ty) + in + let l, r = flatten [] ty in + (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) + +let build_fields level = + List.fold_right (fun (s, k, ty1) ty2 -> + newty2 level (Tfield (s, k, ty1, ty2))) + +let associate_fields (fields1 : fields) (fields2 : fields) : _ * fields * fields + = + let rec associate p s s' : fields * fields -> _ = function + | l, [] -> (List.rev p, List.rev s @ l, List.rev s') + | [], l' -> (List.rev p, List.rev s, List.rev s' @ l') + | (n, k, t) :: r, (n', k', t') :: r' when n = n' -> + associate ((n, k, t, k', t') :: p) s s' (r, r') + | (n, k, t) :: r, ((n', _k', _t') :: _ as l') when n < n' -> + associate p ((n, k, t) :: s) s' (r, l') + | ((_n, _k, _t) :: _ as l), (n', k', t') :: r' (* when n > n' *) -> + associate p s ((n', k', t') :: s') (l, r') + in + associate [] [] [] (fields1, fields2) + +(**** Check whether an object is open ****) + +(* +++ The abbreviation should eventually be expanded *) +let rec object_row ty = + let ty = repr ty in + match ty.desc with + | Tobject (t, _) -> object_row t + | Tfield (_, _, _, t) -> object_row t + | _ -> ty + +let opened_object ty = + match (object_row ty).desc with + | Tvar _ | Tunivar _ | Tconstr _ -> true + | _ -> false + +let concrete_object ty = + match (object_row ty).desc with + | Tvar _ -> false + | _ -> true + +(**** Close an object ****) + +let close_object ty = + let rec close ty = + let ty = repr ty in + match ty.desc with + | Tvar _ -> link_type ty (newty2 ty.level Tnil) + | Tfield (_, _, _, ty') -> close ty' + | _ -> assert false + in + match (repr ty).desc with + | Tobject (ty, _) -> close ty + | _ -> assert false + +(**** Row variable of an object type ****) + +let row_variable ty = + let rec find ty = + let ty = repr ty in + match ty.desc with + | Tfield (_, _, _, ty) -> find ty + | Tvar _ -> ty + | _ -> assert false + in + match (repr ty).desc with + | Tobject (fi, _) -> find fi + | _ -> assert false + +(**** Object name manipulation ****) +(* +++ Bientot obsolete *) + +let set_object_name id rv params ty = + match (repr ty).desc with + | Tobject (_fi, nm) -> set_name nm (Some (Path.Pident id, rv :: params)) + | _ -> assert false + +let remove_object_name ty = + match (repr ty).desc with + | Tobject (_, nm) -> set_name nm None + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.remove_object_name" + +(**** Hiding of private methods ****) + +let hide_private_methods ty = + match (repr ty).desc with + | Tobject (fi, nm) -> + nm := None; + let fl, _ = flatten_fields fi in + List.iter + (function + | _, k, _ -> ( + match field_kind_repr k with + | Fvar r -> set_kind r Fabsent + | _ -> ())) + fl + | _ -> assert false + +(*******************************) +(* Operations on class types *) +(*******************************) + +(*******************************************) +(* Miscellaneous operations on row types *) +(*******************************************) +type row_fields = (Asttypes.label * Types.row_field) list +type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list +let sort_row_fields : row_fields -> row_fields = + List.sort (fun (p, _) (q, _) -> compare (p : string) q) + +let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) + (fi1 : row_fields) (fi2 : row_fields) = + match (fi1, fi2) with + | ((l1, f1) as p1) :: fi1', ((l2, f2) as p2) :: fi2' -> + if l1 = l2 then merge_rf r1 r2 ((l1, f1, f2) :: pairs) fi1' fi2' + else if l1 < l2 then merge_rf (p1 :: r1) r2 pairs fi1' fi2 + else merge_rf r1 (p2 :: r2) pairs fi1 fi2' + | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) + | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) + +let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : + row_fields * row_fields * row_pairs = + match (fi1, fi2) with + | [], _ | _, [] -> (fi1, fi2, []) + | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) + | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) + | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) + +let rec filter_row_fields erase = function + | [] -> [] + | ((_l, f) as p) :: fi -> ( + let fi = filter_row_fields erase fi in + match row_field_repr f with + | Rabsent -> fi + | Reither (_, _, false, e) when erase -> + set_row_field e Rabsent; + fi + | _ -> p :: fi) + +(**************************************) +(* Check genericity of type schemes *) +(**************************************) + +exception Non_closed of type_expr * bool + +let free_variables = ref [] +let really_closed = ref None + +let rec free_vars_rec real ty = + let ty = repr ty in + if ty.level >= lowest_level then ( + ty.level <- pivot_level - ty.level; + match (ty.desc, !really_closed) with + | Tvar _, _ -> free_variables := (ty, real) :: !free_variables + | Tconstr (path, tl, _), Some env -> + (try + let _, body, _ = Env.find_type_expansion path env in + if (repr body).level <> generic_level then + free_variables := (ty, real) :: !free_variables + with Not_found -> ()); + List.iter (free_vars_rec true) tl + (* Do not count "virtual" free variables + | Tobject(ty, {contents = Some (_, p)}) -> + free_vars_rec false ty; List.iter (free_vars_rec true) p + *) + | Tobject (ty, _), _ -> free_vars_rec false ty + | Tfield (_, _, ty1, ty2), _ -> + free_vars_rec true ty1; + free_vars_rec false ty2 + | Tvariant row, _ -> + let row = row_repr row in + iter_row (free_vars_rec true) row; + if not (static_row row) then free_vars_rec false row.row_more + | _ -> iter_type_expr (free_vars_rec true) ty) + +let free_vars ?env ty = + free_variables := []; + really_closed := env; + free_vars_rec true ty; + let res = !free_variables in + free_variables := []; + really_closed := None; + res + +let free_variables ?env ty = + let tl = List.map fst (free_vars ?env ty) in + unmark_type ty; + tl + +let closed_type ty = + match free_vars ty with + | [] -> () + | (v, real) :: _ -> raise (Non_closed (v, real)) + +let closed_parameterized_type params ty = + List.iter mark_type params; + let ok = + try + closed_type ty; + true + with Non_closed _ -> false + in + List.iter unmark_type params; + unmark_type ty; + ok + +let closed_type_decl decl = + try + List.iter mark_type decl.type_params; + (match decl.type_kind with + | Type_abstract -> () + | Type_variant v -> + List.iter + (fun {cd_args; cd_res; _} -> + match cd_res with + | Some _ -> () + | None -> ( + match cd_args with + | Cstr_tuple l -> List.iter closed_type l + | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l)) + v + | Type_record (r, _rep) -> List.iter (fun l -> closed_type l.ld_type) r + | Type_open -> ()); + (match decl.type_manifest with + | None -> () + | Some ty -> closed_type ty); + unmark_type_decl decl; + None + with Non_closed (ty, _) -> + unmark_type_decl decl; + Some ty + +let closed_extension_constructor ext = + try + List.iter mark_type ext.ext_type_params; + (match ext.ext_ret_type with + | Some _ -> () + | None -> iter_type_expr_cstr_args closed_type ext.ext_args); + unmark_extension_constructor ext; + None + with Non_closed (ty, _) -> + unmark_extension_constructor ext; + Some ty + +type closed_class_failure = + | CC_Method of type_expr * bool * string * type_expr + | CC_Value of type_expr * bool * string * type_expr + +(**********************) +(* Type duplication *) +(**********************) + +(* Duplicate a type, preserving only type variables *) +let duplicate_type ty = Subst.type_expr Subst.identity ty + +(* Same, for class types *) + +(*****************************) +(* Type level manipulation *) +(*****************************) + +(* + It would be a bit more efficient to remove abbreviation expansions + rather than generalizing them: these expansions will usually not be + used anymore. However, this is not possible in the general case, as + [expand_abbrev] (via [subst]) requires these expansions to be + preserved. Does it worth duplicating this code ? +*) +let rec generalize ty = + let ty = repr ty in + if ty.level > !current_level && ty.level <> generic_level then ( + set_level ty generic_level; + (match ty.desc with + | Tconstr (_, _, abbrev) -> iter_abbrev generalize !abbrev + | _ -> ()); + iter_type_expr generalize ty) + +let generalize ty = + simple_abbrevs := Mnil; + generalize ty + +(* Generalize the structure and lower the variables *) + +let rec generalize_structure var_level ty = + let ty = repr ty in + if ty.level <> generic_level then + if is_Tvar ty && ty.level > var_level then set_level ty var_level + else if + ty.level > !current_level + && + match ty.desc with + | Tconstr (p, _, abbrev) -> + (not (is_object_type p)) + && + (abbrev := Mnil; + true) + | _ -> true + then ( + set_level ty generic_level; + iter_type_expr (generalize_structure var_level) ty) + +let generalize_structure var_level ty = + simple_abbrevs := Mnil; + generalize_structure var_level ty + +let forward_try_expand_once = + (* Forward declaration *) + ref (fun _env _ty -> raise Cannot_expand) + +(* + Lower the levels of a type (assume [level] is not + [generic_level]). +*) +(* + The level of a type constructor must be greater than its binding + time. That way, a type constructor cannot escape the scope of its + definition, as would be the case in + let x = ref [] + module M = struct type t let _ = (x : t list ref) end + (without this constraint, the type system would actually be unsound.) +*) +let get_level env p = + try + match (Env.find_type p env).type_newtype_level with + | None -> Path.binding_time p + | Some (x, _) -> x + with Not_found -> + (* no newtypes in predef *) + Path.binding_time p + +let rec normalize_package_path env p = + let t = try (Env.find_modtype p env).mtd_type with Not_found -> None in + match t with + | Some (Mty_ident p) -> normalize_package_path env p + | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None -> ( + match p with + | Path.Pdot (p1, s, n) -> + (* For module aliases *) + let p1' = Env.normalize_path None env p1 in + if Path.same p1 p1' then p + else normalize_package_path env (Path.Pdot (p1', s, n)) + | _ -> p) + +let rec update_level env level expand ty = + let ty = repr ty in + if ty.level > level then ( + (match Env.gadt_instance_level env ty with + | Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]) + | None -> ()); + match ty.desc with + | Tconstr (p, _tl, _abbrev) when level < get_level env p -> ( + (* Try first to replace an abbreviation by its expansion. *) + try + (* if is_newtype env p then raise Cannot_expand; *) + link_type ty (!forward_try_expand_once env ty); + update_level env level expand ty + with Cannot_expand -> + (* +++ Levels should be restored... *) + (* Format.printf "update_level: %i < %i@." level (get_level env p); *) + if level < get_level env p then raise (Unify [(ty, newvar2 level)]); + iter_type_expr (update_level env level expand) ty) + | Tconstr (_, _ :: _, _) when expand -> ( + try + link_type ty (!forward_try_expand_once env ty); + update_level env level expand ty + with Cannot_expand -> + set_level ty level; + iter_type_expr (update_level env level expand) ty) + | Tpackage (p, nl, tl) when level < Path.binding_time p -> + let p' = normalize_package_path env p in + if Path.same p p' then raise (Unify [(ty, newvar2 level)]); + log_type ty; + ty.desc <- Tpackage (p', nl, tl); + update_level env level expand ty + | Tobject (_, ({contents = Some (p, _tl)} as nm)) + when level < get_level env p -> + set_name nm None; + update_level env level expand ty + | Tvariant row -> + let row = row_repr row in + (match row.row_name with + | Some (p, _tl) when level < get_level env p -> + log_type ty; + ty.desc <- Tvariant {row with row_name = None} + | _ -> ()); + set_level ty level; + iter_type_expr (update_level env level expand) ty + | Tfield (lab, _, ty1, _) + when lab = dummy_method && (repr ty1).level > level -> + raise (Unify [(ty1, newvar2 level)]) + | _ -> + set_level ty level; + (* XXX what about abbreviations in Tconstr ? *) + iter_type_expr (update_level env level expand) ty) + +(* First try without expanding, then expand everything, + to avoid combinatorial blow-up *) +let update_level env level ty = + let ty = repr ty in + if ty.level > level then ( + let snap = snapshot () in + try update_level env level false ty + with Unify _ -> + backtrack snap; + update_level env level true ty) + +(* Generalize and lower levels of contravariant branches simultaneously *) + +let rec generalize_expansive env var_level visited ty = + let ty = repr ty in + if ty.level = generic_level || ty.level <= var_level then () + else if not (Hashtbl.mem visited ty.id) then ( + Hashtbl.add visited ty.id (); + match ty.desc with + | Tconstr (path, tyl, abbrev) -> + let variance = + try (Env.find_type path env).type_variance + with Not_found -> List.map (fun _ -> Variance.may_inv) tyl + in + abbrev := Mnil; + List.iter2 + (fun v t -> + if Variance.(mem May_weak v) then generalize_structure var_level t + else generalize_expansive env var_level visited t) + variance tyl + | Tpackage (_, _, tyl) -> List.iter (generalize_structure var_level) tyl + | Tarrow (arg, ret, _, _) -> + generalize_structure var_level arg.typ; + generalize_expansive env var_level visited ret + | _ -> iter_type_expr (generalize_expansive env var_level visited) ty) + +let generalize_expansive env ty = + simple_abbrevs := Mnil; + try generalize_expansive env !nongen_level (Hashtbl.create 7) ty + with Unify ([(_, ty')] as tr) -> raise (Unify ((ty, ty') :: tr)) + +let generalize_global ty = generalize_structure !global_level ty +let generalize_structure ty = generalize_structure !current_level ty + +(* Correct the levels of type [ty]. *) +let correct_levels ty = duplicate_type ty + +(* Only generalize the type ty0 in ty *) +let limited_generalize ty0 ty = + let ty0 = repr ty0 in + + let graph = Hashtbl.create 17 in + let idx = ref lowest_level in + let roots = ref [] in + + let rec inverse pty ty = + let ty = repr ty in + if ty.level > !current_level || ty.level = generic_level then ( + decr idx; + Hashtbl.add graph !idx (ty, ref pty); + if ty.level = generic_level || ty == ty0 then roots := ty :: !roots; + set_level ty !idx; + iter_type_expr (inverse [ty]) ty) + else if ty.level < lowest_level then + let _, parents = Hashtbl.find graph ty.level in + parents := pty @ !parents + and generalize_parents ty = + let idx = ty.level in + if idx <> generic_level then ( + set_level ty generic_level; + List.iter generalize_parents !(snd (Hashtbl.find graph idx)); + (* Special case for rows: must generalize the row variable *) + match ty.desc with + | Tvariant row -> + let more = row_more row in + let lv = more.level in + if (lv < lowest_level || lv > !current_level) && lv <> generic_level + then set_level more generic_level + | _ -> ()) + in + + inverse [] ty; + if ty0.level < lowest_level then iter_type_expr (inverse []) ty0; + List.iter generalize_parents !roots; + Hashtbl.iter + (fun _ (ty, _) -> + if ty.level <> generic_level then set_level ty !current_level) + graph + +(* Compute statically the free univars of all nodes in a type *) +(* This avoids doing it repeatedly during instantiation *) + +type inv_type_expr = { + inv_type: type_expr; + mutable inv_parents: inv_type_expr list; +} + +let rec inv_type hash pty ty = + let ty = repr ty in + try + let inv = TypeHash.find hash ty in + inv.inv_parents <- pty @ inv.inv_parents + with Not_found -> + let inv = {inv_type = ty; inv_parents = pty} in + TypeHash.add hash ty inv; + iter_type_expr (inv_type hash [inv]) ty + +let compute_univars ty = + let inverted = TypeHash.create 17 in + inv_type inverted [] ty; + let node_univars = TypeHash.create 17 in + let rec add_univar univ inv = + match inv.inv_type.desc with + | Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () + | _ -> ( + try + let univs = TypeHash.find node_univars inv.inv_type in + if not (TypeSet.mem univ !univs) then ( + univs := TypeSet.add univ !univs; + List.iter (add_univar univ) inv.inv_parents) + with Not_found -> + TypeHash.add node_univars inv.inv_type (ref (TypeSet.singleton univ)); + List.iter (add_univar univ) inv.inv_parents) + in + TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) inverted; + fun ty -> + try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty + +(*******************) +(* Instantiation *) +(*******************) + +let rec find_repr p1 = function + | Mnil -> None + | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> Some ty + | Mcons (_, _, _, _, rem) -> find_repr p1 rem + | Mlink {contents = rem} -> find_repr p1 rem + +(* + Generic nodes are duplicated, while non-generic nodes are left + as-is. + During instantiation, the description of a generic node is first + replaced by a link to a stub ([Tsubst (newvar ())]). Once the + copy is made, it replaces the stub. + After instantiation, the description of generic node, which was + stored by [save_desc], must be put back, using [cleanup_types]. +*) + +let abbreviations = ref (ref Mnil) +(* Abbreviation memorized. *) + +(* partial: we may not wish to copy the non generic types + before we call type_pat *) +let rec copy ?env ?partial ?keep_names ty = + let copy = copy ?env ?partial ?keep_names in + let ty = repr ty in + match ty.desc with + | Tsubst ty -> ty + | _ -> + if ty.level <> generic_level && partial = None then ty + else + (* We only forget types that are non generic and do not contain + free univars *) + let forget = + if ty.level = generic_level then generic_level + else + match partial with + | None -> assert false + | Some (free_univars, keep) -> + if TypeSet.is_empty (free_univars ty) then + if keep then ty.level else !current_level + else generic_level + in + if forget <> generic_level then newty2 forget (Tvar None) + else + let desc = ty.desc in + save_desc ty desc; + let t = newvar () in + (* Stub *) + (match env with + | Some env when Env.has_local_constraints env -> ( + match Env.gadt_instance_level env ty with + | Some lv -> Env.add_gadt_instances env lv [t] + | None -> ()) + | _ -> ()); + ty.desc <- Tsubst t; + t.desc <- + (match desc with + | Tconstr (p, tl, _) -> ( + let abbrevs = proper_abbrevs p tl !abbreviations in + match find_repr p !abbrevs with + | Some ty when repr ty != t -> Tlink ty + | _ -> + (* + One must allocate a new reference, so that abbrevia- + tions belonging to different branches of a type are + independent. + Moreover, a reference containing a [Mcons] must be + shared, so that the memorized expansion of an abbrevi- + ation can be released by changing the content of just + one reference. + *) + Tconstr + ( p, + List.map copy tl, + ref + (match !(!abbreviations) with + | Mcons _ -> Mlink !abbreviations + | abbrev -> abbrev) )) + | Tvariant row0 -> ( + let row = row_repr row0 in + let more = repr row.row_more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + match more.desc with + | Tsubst {desc = Ttuple [_; ty2]} -> + (* This variant type has been already copied *) + ty.desc <- Tsubst ty2; + (* avoid Tlink in the new type *) + Tlink ty2 + | _ -> + (* If the row variable is not generic, we must keep it *) + let keep = more.level <> generic_level in + let more' = + match more.desc with + | Tsubst ty -> ty + | Tconstr _ | Tnil -> + if keep then save_desc more more.desc; + copy more + | Tvar _ | Tunivar _ -> + save_desc more more.desc; + if keep then more else newty more.desc + | _ -> assert false + in + let row = + match repr more' with + (* PR#6163 *) + | {desc = Tconstr _} when not row.row_fixed -> + {row with row_fixed = true} + | _ -> row + in + (* Open row if partial for pattern and contains Reither *) + let more', row = + match partial with + | Some (free_univars, false) -> + let more' = + if more.id != more'.id then more' + else + let lv = if keep then more.level else !current_level in + newty2 lv (Tvar None) + in + let not_reither (_, f) = + match row_field_repr f with + | Reither _ -> false + | _ -> true + in + if + row.row_closed && (not row.row_fixed) + && TypeSet.is_empty (free_univars ty) + && not (List.for_all not_reither row.row_fields) + then + ( more', + { + row_fields = Ext_list.filter row.row_fields not_reither; + row_more = more'; + row_closed = false; + row_fixed = false; + row_name = None; + } ) + else (more', row) + | _ -> (more', row) + in + (* Register new type first for recursion *) + more.desc <- Tsubst (newgenty (Ttuple [more'; t])); + (* Return a new copy *) + Tvariant (copy_row copy true row keep more')) + | Tfield (_p, k, _ty1, ty2) -> ( + match field_kind_repr k with + | Fabsent -> Tlink (copy ty2) + | Fpresent -> copy_type_desc copy desc + | Fvar r -> + dup_kind r; + copy_type_desc copy desc) + | Tobject (ty1, _) when partial <> None -> Tobject (copy ty1, ref None) + | _ -> copy_type_desc ?keep_names copy desc); + t + +let simple_copy t = copy t + +(**** Variants of instantiations ****) + +let gadt_env env = if Env.has_local_constraints env then Some env else None + +let instance ?partial env sch = + let env = gadt_env env in + let partial = + match partial with + | None -> None + | Some keep -> Some (compute_univars sch, keep) + in + let ty = copy ?env ?partial sch in + cleanup_types (); + ty + +let instance_def sch = + let ty = copy sch in + cleanup_types (); + ty + +let generic_instance env sch = + let old = !current_level in + current_level := generic_level; + let ty = instance env sch in + current_level := old; + ty + +let instance_list env schl = + let env = gadt_env env in + let tyl = List.map (fun t -> copy ?env t) schl in + cleanup_types (); + tyl + +let reified_var_counter = ref Vars.empty +let reset_reified_var_counter () = reified_var_counter := Vars.empty + +(* names given to new type constructors. + Used for existential types and + local constraints *) +let get_new_abstract_name s = + let index = try Vars.find s !reified_var_counter + 1 with Not_found -> 0 in + reified_var_counter := Vars.add s index !reified_var_counter; + if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s + else Printf.sprintf "%s%d" s index + +let new_declaration newtype manifest = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = manifest; + type_variance = []; + type_newtype_level = newtype; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + +let instance_constructor ?in_pattern cstr = + (match in_pattern with + | None -> () + | Some (env, newtype_lev) -> + let process existential = + let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in + let name = + match repr existential with + | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name + | _ -> "$" ^ cstr.cstr_name + in + let path = Path.Pident (Ident.create (get_new_abstract_name name)) in + let new_env = Env.add_local_type path decl !env in + env := new_env; + let to_unify = newty (Tconstr (path, [], ref Mnil)) in + let tv = copy existential in + assert (is_Tvar tv); + link_type tv to_unify + in + List.iter process cstr.cstr_existentials); + let ty_res = copy cstr.cstr_res in + let ty_args = List.map simple_copy cstr.cstr_args in + cleanup_types (); + (ty_args, ty_res) + +let instance_parameterized_type ?keep_names sch_args sch = + let ty_args = List.map (fun t -> copy ?keep_names t) sch_args in + let ty = copy sch in + cleanup_types (); + (ty_args, ty) + +let instance_parameterized_type_2 sch_args sch_lst sch = + let ty_args = List.map simple_copy sch_args in + let ty_lst = List.map simple_copy sch_lst in + let ty = copy sch in + cleanup_types (); + (ty_args, ty_lst, ty) + +let map_kind f = function + | Type_abstract -> Type_abstract + | Type_open -> Type_open + | Type_variant cl -> + Type_variant + (List.map + (fun c -> + { + c with + cd_args = map_type_expr_cstr_args f c.cd_args; + cd_res = may_map f c.cd_res; + }) + cl) + | Type_record (fl, rr) -> + Type_record (List.map (fun l -> {l with ld_type = f l.ld_type}) fl, rr) + +let instance_declaration decl = + let decl = + { + decl with + type_params = List.map simple_copy decl.type_params; + type_manifest = may_map simple_copy decl.type_manifest; + type_kind = map_kind simple_copy decl.type_kind; + } + in + cleanup_types (); + decl + +(**** Instantiation for types with free universal variables ****) + +let rec diff_list l1 l2 = + if l1 == l2 then [] + else + match l1 with + | [] -> invalid_arg "Ctype.diff_list" + | a :: l1 -> a :: diff_list l1 l2 + +let conflicts free bound = + let bound = List.map repr bound in + TypeSet.exists (fun t -> List.memq (repr t) bound) free + +let delayed_copy = ref [] +(* copying to do later *) + +(* Copy without sharing until there are no free univars left *) +(* all free univars must be included in [visited] *) +let rec copy_sep fixed free bound visited ty = + let ty = repr ty in + let univars = free ty in + if TypeSet.is_empty univars then ( + if ty.level <> generic_level then ty + else + let t = newvar () in + delayed_copy := lazy (t.desc <- Tlink (copy ty)) :: !delayed_copy; + t) + else + try + let t, bound_t = List.assq ty visited in + let dl = if is_Tunivar ty then [] else diff_list bound bound_t in + if dl <> [] && conflicts univars dl then raise Not_found; + t + with Not_found -> + let t = newvar () in + (* Stub *) + let visited = + match ty.desc with + | Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ + -> + (ty, (t, bound)) :: visited + | _ -> visited + in + let copy_rec = copy_sep fixed free bound visited in + t.desc <- + (match ty.desc with + | Tvariant row0 -> + let row = row_repr row0 in + let more = repr row.row_more in + (* We shall really check the level on the row variable *) + let keep = is_Tvar more && more.level <> generic_level in + let more' = copy_rec more in + let fixed' = fixed && is_Tvar (repr more') in + let row = copy_row copy_rec fixed' row keep more' in + Tvariant row + | Tpoly (t1, tl) -> + let tl = List.map repr tl in + let tl' = List.map (fun t -> newty t.desc) tl in + let bound = tl @ bound in + let visited = + List.map2 (fun ty t -> (ty, (t, bound))) tl tl' @ visited + in + Tpoly (copy_sep fixed free bound visited t1, tl') + | _ -> copy_type_desc copy_rec ty.desc); + t + +let instance_poly ?(keep_names = false) fixed univars sch = + let univars = List.map repr univars in + let copy_var ty = + match ty.desc with + | Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | _ -> assert false + in + let vars = List.map copy_var univars in + let pairs = List.map2 (fun u v -> (u, (v, []))) univars vars in + delayed_copy := []; + let ty = copy_sep fixed (compute_univars sch) [] pairs sch in + List.iter Lazy.force !delayed_copy; + delayed_copy := []; + cleanup_types (); + (vars, ty) + +let instance_label fixed lbl = + let ty_res = copy lbl.lbl_res in + let vars, ty_arg = + match repr lbl.lbl_arg with + | {desc = Tpoly (ty, tl)} -> instance_poly fixed tl ty + | _ -> ([], copy lbl.lbl_arg) + in + cleanup_types (); + (vars, ty_arg, ty_res) + +(**** Instantiation with parameter substitution ****) + +let unify' = + (* Forward declaration *) + ref (fun _env _ty1 _ty2 -> raise (Unify [])) + +let subst env level priv abbrev ty params args body = + if List.length params <> List.length args then raise (Unify []); + let old_level = !current_level in + current_level := level; + try + let body0 = newvar () in + (* Stub *) + (match ty with + | None -> () + | Some ({desc = Tconstr (path, tl, _)} as ty) -> + let abbrev = proper_abbrevs path tl abbrev in + memorize_abbrev abbrev priv path ty body0 + | _ -> assert false); + abbreviations := abbrev; + let params', body' = instance_parameterized_type params body in + abbreviations := ref Mnil; + !unify' env body0 body'; + List.iter2 (!unify' env) params' args; + current_level := old_level; + body' + with Unify _ as exn -> + current_level := old_level; + raise exn + +(* + Only the shape of the type matters, not whether it is generic or + not. [generic_level] might be somewhat slower, but it ensures + invariants on types are enforced (decreasing levels), and we don't + care about efficiency here. +*) +let apply env params body args = + try subst env generic_level Public (ref Mnil) None params args body + with Unify _ -> raise Cannot_apply + +let () = Subst.ctype_apply_env_empty := apply Env.empty + +(****************************) +(* Abbreviation expansion *) +(****************************) + +(* + If the environment has changed, memorized expansions might not + be correct anymore, and so we flush the cache. This is safe but + quite pessimistic: it would be enough to flush the cache when a + type or module definition is overridden in the environment. +*) +let previous_env = ref Env.empty + +(*let string_of_kind = function Public -> "public" | Private -> "private"*) +let check_abbrev_env env = + if env != !previous_env then ( + (* prerr_endline "cleanup expansion cache"; *) + cleanup_abbrev (); + previous_env := env) + +(* Expand an abbreviation. The expansion is memorized. *) +(* + Assume the level is greater than the path binding time of the + expanded abbreviation. +*) +(* + An abbreviation expansion will fail in either of these cases: + 1. The type constructor does not correspond to a manifest type. + 2. The type constructor is defined in an external file, and this + file is not in the path (missing -I options). + 3. The type constructor is not in the "local" environment. This can + happens when a non-generic type variable has been instantiated + afterwards to the not yet defined type constructor. (Actually, + this cannot happen at the moment due to the strong constraints + between type levels and constructor binding time.) + 4. The expansion requires the expansion of another abbreviation, + and this other expansion fails. +*) +let expand_abbrev_gen kind find_type_expansion env ty = + check_abbrev_env env; + match ty with + | {desc = Tconstr (path, args, abbrev); level} -> ( + let lookup_abbrev = proper_abbrevs path args abbrev in + match find_expans kind path !lookup_abbrev with + | Some ty' -> + (* prerr_endline + ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) + (if level <> generic_level then + try update_level env level ty' + with Unify _ -> + (* XXX This should not happen. + However, levels are not correctly restored after a + typing error *) + ()); + let ty' = repr ty' in + (* assert (ty != ty'); *) + (* PR#7324 *) + ty' + | None -> ( + match find_type_expansion path env with + | exception Not_found -> + (* another way to expand is to normalize the path itself *) + let path' = Env.normalize_path None env path in + if Path.same path path' then raise Cannot_expand + else newty2 level (Tconstr (path', args, abbrev)) + | params, body, lv -> + (* prerr_endline + ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) + let ty' = subst env level kind abbrev (Some ty) params args body in + (* For gadts, remember type as non exportable *) + (* The ambiguous level registered for ty' should be the highest *) + (if !trace_gadt_instances then + match + Ext_pervasives.max_int_option lv (Env.gadt_instance_level env ty) + with + | None -> () + | Some lv -> + if level < lv then raise (Unify [(ty, newvar2 level)]); + Env.add_gadt_instances env lv [ty; ty']); + ty')) + | _ -> assert false + +(* Expand respecting privacy *) +let expand_abbrev env ty = + expand_abbrev_gen Public Env.find_type_expansion env ty + +(* Expand once the head of a type *) +let expand_head_once env ty = + try expand_abbrev env (repr ty) with Cannot_expand -> assert false + +(* Check whether a type can be expanded *) +let safe_abbrev env ty = + let snap = Btype.snapshot () in + try + ignore (expand_abbrev env ty); + true + with Cannot_expand | Unify _ -> + Btype.backtrack snap; + false + +(* Expand the head of a type once. + Raise Cannot_expand if the type cannot be expanded. + May raise Unify, if a recursion was hidden in the type. *) +let try_expand_once env ty = + let ty = repr ty in + match ty.desc with + | Tconstr _ -> repr (expand_abbrev env ty) + | _ -> raise Cannot_expand + +(* This one only raises Cannot_expand *) +let try_expand_safe env ty = + let snap = Btype.snapshot () in + try try_expand_once env ty + with Unify _ -> + Btype.backtrack snap; + raise Cannot_expand + +(* Fully expand the head of a type. *) +let rec try_expand_head try_once env ty = + let ty' = try_once env ty in + try try_expand_head try_once env ty' with Cannot_expand -> ty' + +let try_expand_head try_once env ty = + let ty' = try_expand_head try_once env ty in + (match Env.gadt_instance_level env ty' with + | None -> () + | Some lv -> Env.add_gadt_instance_chain env lv ty); + ty' + +(* Unsafe full expansion, may raise Unify. *) +let expand_head_unif env ty = + try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty + +(* Safe version of expand_head, never fails *) +let expand_head env ty = + try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty + +let _ = forward_try_expand_once := try_expand_safe + +(* Expand until we find a non-abstract type declaration *) + +let rec extract_concrete_typedecl env ty = + let ty = repr ty in + match ty.desc with + | Tconstr (p, _, _) -> + let decl = Env.find_type p env in + if decl.type_kind <> Type_abstract then (p, p, decl) + else + let ty = + try try_expand_once env ty with Cannot_expand -> raise Not_found + in + let _, p', decl = extract_concrete_typedecl env ty in + (p, p', decl) + | _ -> raise Not_found + +(* Implementing function [expand_head_opt], the compiler's own version of + [expand_head] used for type-based optimisations. + [expand_head_opt] uses [Env.find_type_expansion_opt] to access the + manifest type information of private abstract data types which is + normally hidden to the type-checker out of the implementation module of + the private abbreviation. *) + +let expand_abbrev_opt = expand_abbrev_gen Private Env.find_type_expansion_opt + +let try_expand_once_opt env ty = + let ty = repr ty in + match ty.desc with + | Tconstr _ -> repr (expand_abbrev_opt env ty) + | _ -> raise Cannot_expand + +let rec try_expand_head_opt env ty = + let ty' = try_expand_once_opt env ty in + try try_expand_head_opt env ty' with Cannot_expand -> ty' + +let expand_head_opt env ty = + let snap = Btype.snapshot () in + try try_expand_head_opt env ty + with Cannot_expand | Unify _ -> + (* expand_head shall never fail *) + Btype.backtrack snap; + repr ty + +(* Make sure that the type parameters of the type constructor [ty] + respect the type constraints *) +let enforce_constraints env ty = + match ty with + | {desc = Tconstr (path, args, _abbrev); level} -> ( + try + let decl = Env.find_type path env in + ignore + (subst env level Public (ref Mnil) None decl.type_params args + (newvar2 level)) + with Not_found -> ()) + | _ -> assert false + +(* Recursively expand the head of a type. + Also expand #-types. *) +let full_expand env ty = + let ty = repr (expand_head env ty) in + match ty.desc with + | Tobject (fi, {contents = Some (_, v :: _)}) when is_Tvar (repr v) -> + newty2 ty.level (Tobject (fi, ref None)) + | _ -> ty + +(* + Check whether the abbreviation expands to a well-defined type. + During the typing of a class, abbreviations for correspondings + types expand to non-generic types. +*) +let generic_abbrev env path = + try + let _, body, _ = Env.find_type_expansion path env in + (repr body).level = generic_level + with Not_found -> false + +let generic_private_abbrev env path = + try + match Env.find_type path env with + | { + type_kind = Type_abstract; + type_private = Private; + type_manifest = Some body; + } -> + (repr body).level = generic_level + | _ -> false + with Not_found -> false + +let is_contractive env p = + try + let decl = Env.find_type p env in + (in_pervasives p && decl.type_manifest = None) || is_datatype decl + with Not_found -> false + +(*****************) +(* Occur check *) +(*****************) + +exception Occur + +let rec occur_rec env allow_recursive visited ty0 = function + | {desc = Tlink ty} -> occur_rec env allow_recursive visited ty0 ty + | ty -> ( + if ty == ty0 then raise Occur; + match ty.desc with + | Tconstr (p, _tl, _abbrev) -> ( + if allow_recursive && is_contractive env p then () + else + try + if TypeSet.mem ty visited then raise Occur; + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty + with Occur -> ( + try + let ty' = try_expand_head try_expand_once env ty in + (* This call used to be inlined, but there seems no reason for it. + Message was referring to change in rev. 1.58 of the CVS repo. *) + occur_rec env allow_recursive visited ty0 ty' + with Cannot_expand -> raise Occur)) + | Tobject _ | Tvariant _ -> () + | _ -> + if allow_recursive || TypeSet.mem ty visited then () + else + let visited = TypeSet.add ty visited in + iter_type_expr (occur_rec env allow_recursive visited ty0) ty) + +let type_changed = ref false (* trace possible changes to the studied type *) + +let merge r b = if b then r := true + +let occur env ty0 ty = + let allow_recursive = (*!Clflags.recursive_types ||*) !umode = Pattern in + let old = !type_changed in + try + while + type_changed := false; + occur_rec env allow_recursive TypeSet.empty ty0 ty; + !type_changed + do + () (* prerr_endline "changed" *) + done; + merge type_changed old + with exn -> + merge type_changed old; + raise + (match exn with + | Occur -> Unify [] + | _ -> exn) + +let occur_in env ty0 t = + try + occur env ty0 t; + false + with Unify _ -> true + +(* Check that a local constraint is well-founded *) +(* PR#6405: not needed since we allow recursion and work on normalized types *) +(* PR#6992: we actually need it for contractiveness *) +(* This is a simplified version of occur, only for the rectypes case *) + +let rec local_non_recursive_abbrev strict visited env p ty = + (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*) + let ty = repr ty in + if not (List.memq ty visited) then + match ty.desc with + | Tconstr (p', args, _abbrev) -> ( + if Path.same p p' then raise Occur; + if (not strict) && is_contractive env p' then () + else + let visited = ty :: visited in + try + (* try expanding, since [p] could be hidden *) + local_non_recursive_abbrev strict visited env p + (try_expand_head try_expand_once env ty) + with Cannot_expand -> + let params = + try (Env.find_type p' env).type_params with Not_found -> args + in + List.iter2 + (fun tv ty -> + let strict = strict || not (is_Tvar (repr tv)) in + local_non_recursive_abbrev strict visited env p ty) + params args) + | _ -> + if strict then + (* PR#7374 *) + let visited = ty :: visited in + iter_type_expr (local_non_recursive_abbrev true visited env p) ty + +let local_non_recursive_abbrev env p ty = + try + (* PR#7397: need to check trace_gadt_instances *) + wrap_trace_gadt_instances env (local_non_recursive_abbrev false [] env p) ty; + true + with Occur -> false + +(*****************************) +(* Polymorphic Unification *) +(*****************************) + +(* Since we cannot duplicate universal variables, unification must + be done at meta-level, using bindings in univar_pairs *) +let rec unify_univar t1 t2 = function + | (cl1, cl2) :: rem -> ( + let find_univ t cl = + try + let _, r = List.find (fun (t', _) -> t == repr t') cl in + Some r + with Not_found -> None + in + match (find_univ t1 cl1, find_univ t2 cl2) with + | Some {contents = Some t'2}, Some _ when t2 == repr t'2 -> () + | Some ({contents = None} as r1), Some ({contents = None} as r2) -> + set_univar r1 t2; + set_univar r2 t1 + | None, None -> unify_univar t1 t2 rem + | _ -> raise (Unify [])) + | [] -> raise (Unify []) + +(* Test the occurrence of free univars in a type *) +(* that's way too expensive. Must do some kind of caching *) +let occur_univar env ty = + let visited = ref TypeMap.empty in + let rec occur_rec bound ty = + let ty = repr ty in + if + ty.level >= lowest_level + && + if TypeSet.is_empty bound then ( + ty.level <- pivot_level - ty.level; + true) + else + try + let bound' = TypeMap.find ty !visited in + if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then ( + visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; + true) + else false + with Not_found -> + visited := TypeMap.add ty bound !visited; + true + then + match ty.desc with + | Tunivar _ -> + if not (TypeSet.mem ty bound) then raise (Unify [(ty, newgenvar ())]) + | Tpoly (ty, tyl) -> + let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in + occur_rec bound ty + | Tconstr (_, [], _) -> () + | Tconstr (p, tl, _) -> ( + try + let td = Env.find_type p env in + List.iter2 + (fun t v -> + if Variance.(mem May_pos v || mem May_neg v) then + occur_rec bound t) + tl td.type_variance + with Not_found -> List.iter (occur_rec bound) tl) + | _ -> iter_type_expr (occur_rec bound) ty + in + try + occur_rec TypeSet.empty ty; + unmark_type ty + with exn -> + unmark_type ty; + raise exn + +(* Grouping univars by families according to their binders *) +let add_univars = List.fold_left (fun s (t, _) -> TypeSet.add (repr t) s) + +let get_univar_family univar_pairs univars = + if univars = [] then TypeSet.empty + else + let insert s = function + | cl1, (_ :: _ as cl2) -> + if List.exists (fun (t1, _) -> TypeSet.mem (repr t1) s) cl1 then + add_univars s cl2 + else s + | _ -> s + in + let s = List.fold_right TypeSet.add univars TypeSet.empty in + List.fold_left insert s univar_pairs + +(* Whether a family of univars escapes from a type *) +let univars_escape env univar_pairs vl ty = + let family = get_univar_family univar_pairs vl in + let visited = ref TypeSet.empty in + let rec occur t = + let t = repr t in + if TypeSet.mem t !visited then () + else ( + visited := TypeSet.add t !visited; + match t.desc with + | Tpoly (t, tl) -> + if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () + else occur t + | Tunivar _ -> if TypeSet.mem t family then raise Occur + | Tconstr (_, [], _) -> () + | Tconstr (p, tl, _) -> ( + try + let td = Env.find_type p env in + List.iter2 + (fun t v -> + if Variance.(mem May_pos v || mem May_neg v) then occur t) + tl td.type_variance + with Not_found -> List.iter occur tl) + | _ -> iter_type_expr occur t) + in + try + occur ty; + false + with Occur -> true + +(* Wrapper checking that no variable escapes and updating univar_pairs *) +let enter_poly env univar_pairs t1 tl1 t2 tl2 f = + let old_univars = !univar_pairs in + let known_univars = + List.fold_left (fun s (cl, _) -> add_univars s cl) TypeSet.empty old_univars + in + let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in + if + List.exists (fun t -> TypeSet.mem t known_univars) tl1 + && univars_escape env old_univars tl1 (newty (Tpoly (t2, tl2))) + || List.exists (fun t -> TypeSet.mem t known_univars) tl2 + && univars_escape env old_univars tl2 (newty (Tpoly (t1, tl1))) + then raise (Unify []); + let cl1 = List.map (fun t -> (t, ref None)) tl1 + and cl2 = List.map (fun t -> (t, ref None)) tl2 in + univar_pairs := (cl1, cl2) :: (cl2, cl1) :: old_univars; + try + let res = f t1 t2 in + univar_pairs := old_univars; + res + with exn -> + univar_pairs := old_univars; + raise exn + +let univar_pairs = ref [] + +(*****************) +(* Unification *) +(*****************) + +let rec has_cached_expansion p abbrev = + match abbrev with + | Mnil -> false + | Mcons (_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem + | Mlink rem -> has_cached_expansion p !rem + +(**** Transform error trace ****) +(* +++ Move it to some other place ? *) + +let expand_trace env trace = + List.fold_right + (fun (t1, t2) rem -> + (repr t1, full_expand env t1) :: (repr t2, full_expand env t2) :: rem) + trace [] + +(* build a dummy variant type *) +let mkvariant fields closed = + newgenty + (Tvariant + { + row_fields = fields; + row_closed = closed; + row_more = newvar (); + row_fixed = false; + row_name = None; + }) + +(**** Unification ****) + +(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) +let deep_occur t0 ty = + let rec occur_rec ty = + let ty = repr ty in + if ty.level >= lowest_level then ( + if ty == t0 then raise Occur; + ty.level <- pivot_level - ty.level; + iter_type_expr occur_rec ty) + in + try + occur_rec ty; + unmark_type ty; + false + with Occur -> + unmark_type ty; + true + +(* + 1. When unifying two non-abbreviated types, one type is made a link + to the other. When unifying an abbreviated type with a + non-abbreviated type, the non-abbreviated type is made a link to + the other one. When unifying to abbreviated types, these two + types are kept distincts, but they are made to (temporally) + expand to the same type. + 2. Abbreviations with at least one parameter are systematically + expanded. The overhead does not seem too high, and that way + abbreviations where some parameters does not appear in the + expansion, such as ['a t = int], are correctly handled. In + particular, for this example, unifying ['a t] with ['b t] keeps + ['a] and ['b] distincts. (Is it really important ?) + 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield + ['a t as 'a]. Indeed, the type variable would otherwise be lost. + This problem occurs for abbreviations expanding to a type + variable, but also to many other constrained abbreviations (for + instance, [(< x : 'a > -> unit) t = ]). The solution is + that, if an abbreviation is unified with some subpart of its + parameters, then the parameter actually does not get + abbreviated. It would be possible to check whether some + information is indeed lost, but it probably does not worth it. +*) + +let newtype_level = ref None + +let get_newtype_level () = + match !newtype_level with + | None -> assert false + | Some x -> x + +(* a local constraint can be added only if the rhs + of the constraint does not contain any Tvars. + They need to be removed using this function *) +let reify env t = + let newtype_level = get_newtype_level () in + let create_fresh_constr lev name = + let decl = new_declaration (Some (newtype_level, newtype_level)) None in + let name = + match name with + | Some s -> "$'" ^ s + | _ -> "$" + in + let path = Path.Pident (Ident.create (get_new_abstract_name name)) in + let new_env = Env.add_local_type path decl !env in + let t = newty2 lev (Tconstr (path, [], ref Mnil)) in + env := new_env; + t + in + let visited = ref TypeSet.empty in + let rec iterator ty = + let ty = repr ty in + if TypeSet.mem ty !visited then () + else ( + visited := TypeSet.add ty !visited; + match ty.desc with + | Tvar o -> + let t = create_fresh_constr ty.level o in + link_type ty t; + if ty.level < newtype_level then raise (Unify [(t, newvar2 ty.level)]) + | Tvariant r -> + let r = row_repr r in + (if not (static_row r) then + if r.row_fixed then iterator (row_more r) + else + let m = r.row_more in + match m.desc with + | Tvar o -> + let t = create_fresh_constr m.level o in + let row = + {r with row_fields = []; row_fixed = true; row_more = t} + in + link_type m (newty2 m.level (Tvariant row)); + if m.level < newtype_level then + raise (Unify [(t, newvar2 m.level)]) + | _ -> assert false); + iter_row iterator r + | Tconstr (p, _, _) when is_object_type p -> + iter_type_expr iterator (full_expand !env ty) + | _ -> iter_type_expr iterator ty) + in + iterator t + +let is_newtype env p = + try + let decl = Env.find_type p env in + decl.type_newtype_level <> None + && decl.type_kind = Type_abstract + && decl.type_private = Public + with Not_found -> false + +let non_aliasable p decl = + (* in_pervasives p || (subsumed by in_current_module) *) + in_current_module p && decl.type_newtype_level = None + +let is_instantiable env p = + try + let decl = Env.find_type p env in + decl.type_kind = Type_abstract + && decl.type_private = Public && decl.type_arity = 0 + && decl.type_manifest = None + && not (non_aliasable p decl) + with Not_found -> false + +(* PR#7113: -safe-string should be a global property *) +let compatible_paths p1 p2 = Path.same p1 p2 + +(* Check for datatypes carefully; see PR#6348 *) +let rec expands_to_datatype env ty = + let ty = repr ty in + match ty.desc with + | Tconstr (p, _, _) -> ( + try + is_datatype (Env.find_type p env) + || expands_to_datatype env (try_expand_once env ty) + with Not_found | Cannot_expand -> false) + | _ -> false + +(* mcomp type_pairs subst env t1 t2 does not raise an + exception if it is possible that t1 and t2 are actually + equal, assuming the types in type_pairs are equal and + that the mapping subst holds. + Assumes that both t1 and t2 do not contain any tvars + and that both their objects and variants are closed +*) + +let rec mcomp type_pairs env t1 t2 = + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if t1 == t2 then () + else + match (t1.desc, t2.desc) with + | Tvar _, _ | _, Tvar _ -> () + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> () + | _ -> ( + let t1' = expand_head_opt env t1 in + let t2' = expand_head_opt env t2 in + (* Expansion may have changed the representative of the types... *) + let t1' = repr t1' and t2' = repr t2' in + if t1' == t2' then () + else + try TypePairs.find type_pairs (t1', t2') + with Not_found -> ( + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with + | Tvar _, Tvar _ -> assert false + | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) + when Asttypes.same_arg_label arg1.lbl arg2.lbl + || not (is_optional arg1.lbl || is_optional arg2.lbl) -> + mcomp type_pairs env arg1.typ arg2.typ; + mcomp type_pairs env ret1 ret2 + | Ttuple tl1, Ttuple tl2 -> mcomp_list type_pairs env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) -> + mcomp_type_decl type_pairs env p1 p2 tl1 tl2 + | Tconstr (p, _, _), _ | _, Tconstr (p, _, _) -> ( + try + let decl = Env.find_type p env in + if non_aliasable p decl || is_datatype decl then + raise (Unify []) + with Not_found -> ()) + (* + | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> + mcomp_list type_pairs env tl1 tl2 + *) + | Tpackage _, Tpackage _ -> () + | Tvariant row1, Tvariant row2 -> mcomp_row type_pairs env row1 row2 + | Tobject (fi1, _), Tobject (fi2, _) -> + mcomp_fields type_pairs env fi1 fi2 + | Tfield _, Tfield _ -> + (* Actually unused *) + mcomp_fields type_pairs env t1' t2' + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> mcomp type_pairs env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 (mcomp type_pairs env) + | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | _, _ -> raise (Unify []))) + +and mcomp_list type_pairs env tl1 tl2 = + if List.length tl1 <> List.length tl2 then raise (Unify []); + List.iter2 (mcomp type_pairs env) tl1 tl2 + +and mcomp_fields type_pairs env ty1 ty2 = + if not (concrete_object ty1 && concrete_object ty2) then assert false; + let fields2, rest2 = flatten_fields ty2 in + let fields1, rest1 = flatten_fields ty1 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in + let has_present = + List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) + in + mcomp type_pairs env rest1 rest2; + if + (has_present miss1 && (object_row ty2).desc = Tnil) + || (has_present miss2 && (object_row ty1).desc = Tnil) + then raise (Unify []); + List.iter + (function + | _n, k1, t1, k2, t2 -> + mcomp_kind k1 k2; + mcomp type_pairs env t1 t2) + pairs + +and mcomp_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + match (k1, k2) with + | Fpresent, Fabsent | Fabsent, Fpresent -> raise (Unify []) + | _ -> () + +and mcomp_row type_pairs env row1 row2 = + let row1 = row_repr row1 and row2 = row_repr row2 in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let cannot_erase (_, f) = + match row_field_repr f with + | Rpresent _ -> true + | Rabsent | Reither _ -> false + in + if + (row1.row_closed && List.exists cannot_erase r2) + || (row2.row_closed && List.exists cannot_erase r1) + then raise (Unify []); + List.iter + (fun (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | Rpresent None, (Rpresent (Some _) | Reither (_, _ :: _, _, _) | Rabsent) + | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent) + | (Reither (_, _ :: _, _, _) | Rabsent), Rpresent None + | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) -> + raise (Unify []) + | Rpresent (Some t1), Rpresent (Some t2) -> mcomp type_pairs env t1 t2 + | Rpresent (Some t1), Reither (false, tl2, _, _) -> + List.iter (mcomp type_pairs env t1) tl2 + | Reither (false, tl1, _, _), Rpresent (Some t2) -> + List.iter (mcomp type_pairs env t2) tl1 + | _ -> ()) + pairs + +and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = + try + let decl = Env.find_type p1 env in + let decl' = Env.find_type p2 env in + if compatible_paths p1 p2 then + let inj = + try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1, t2) -> if i then mcomp type_pairs env t1 t2) + inj (List.combine tl1 tl2) + else if non_aliasable p1 decl && non_aliasable p2 decl' then + raise (Unify []) + else + match (decl.type_kind, decl'.type_kind) with + | Type_record (lst, r), Type_record (lst', r') + when Types.same_record_representation r r' -> + mcomp_list type_pairs env tl1 tl2; + mcomp_record_description type_pairs env lst lst' + | Type_variant v1, Type_variant v2 -> + mcomp_list type_pairs env tl1 tl2; + mcomp_variant_description type_pairs env v1 v2 + | Type_open, Type_open -> mcomp_list type_pairs env tl1 tl2 + | Type_abstract, Type_abstract -> () + | Type_abstract, _ when not (non_aliasable p1 decl) -> () + | _, Type_abstract when not (non_aliasable p2 decl') -> () + | _ -> raise (Unify []) + with Not_found -> () + +and mcomp_type_option type_pairs env t t' = + match (t, t') with + | None, None -> () + | Some t, Some t' -> mcomp type_pairs env t t' + | _ -> raise (Unify []) + +and mcomp_variant_description type_pairs env xs ys = + let rec iter x y = + match (x, y) with + | c1 :: xs, c2 :: ys -> + mcomp_type_option type_pairs env c1.cd_res c2.cd_res; + (match (c1.cd_args, c2.cd_args) with + | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 + | Cstr_record l1, Cstr_record l2 -> + mcomp_record_description type_pairs env l1 l2 + | _ -> raise (Unify [])); + if Ident.name c1.cd_id = Ident.name c2.cd_id then iter xs ys + else raise (Unify []) + | [], [] -> () + | _ -> raise (Unify []) + in + iter xs ys + +and mcomp_record_description type_pairs env = + let rec iter x y = + match (x, y) with + | l1 :: xs, l2 :: ys -> + mcomp type_pairs env l1.ld_type l2.ld_type; + if + Ident.name l1.ld_id = Ident.name l2.ld_id + && l1.ld_mutable = l2.ld_mutable + && l1.ld_optional = l2.ld_optional + then iter xs ys + else raise (Unify []) + | [], [] -> () + | _ -> raise (Unify []) + in + iter + +let mcomp env t1 t2 = mcomp (TypePairs.create 4) env t1 t2 + +(* Real unification *) + +let find_newtype_level env path = + try + match (Env.find_type path env).type_newtype_level with + | Some x -> x + | None -> raise Not_found + with Not_found -> + let lev = Path.binding_time path in + (lev, lev) + +let add_gadt_equation env source destination = + if local_non_recursive_abbrev !env source destination then ( + let destination = duplicate_type destination in + let source_lev = find_newtype_level !env source in + let decl = new_declaration (Some source_lev) (Some destination) in + let newtype_level = get_newtype_level () in + env := Env.add_local_constraint source decl newtype_level !env; + cleanup_abbrev ()) + +let unify_eq_set = TypePairs.create 11 + +let order_type_pair t1 t2 = if t1.id <= t2.id then (t1, t2) else (t2, t1) + +let add_type_equality t1 t2 = + TypePairs.add unify_eq_set (order_type_pair t1 t2) () + +let eq_package_path env p1 p2 = + Path.same p1 p2 + || Path.same (normalize_package_path env p1) (normalize_package_path env p2) + +let nondep_type' = ref (fun _ _ _ -> assert false) +let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false) + +let rec concat_longident lid1 = + let open Longident in + function + | Lident s -> Ldot (lid1, s) + | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s) + | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid) + +let nondep_instance env level id ty = + let ty = !nondep_type' env id ty in + if level = generic_level then duplicate_type ty + else + let old = !current_level in + current_level := level; + let ty = instance env ty in + current_level := old; + ty + +(* Find the type paths nl1 in the module type mty2, and add them to the + list (nl2, tl2). raise Not_found if impossible *) +let complete_type_list ?(allow_absent = false) env nl1 lv2 mty2 nl2 tl2 = + let id2 = Ident.create "Pkg" in + let env' = Env.add_module id2 mty2 env in + let rec complete nl1 ntl2 = + match (nl1, ntl2) with + | [], _ -> ntl2 + | n :: nl, ((n2, _) as nt2) :: ntl' when Longident.cmp n n2 >= 0 -> + nt2 :: complete (if Longident.cmp n n2 = 0 then nl else nl1) ntl' + | n :: nl, _ -> ( + try + let path = + Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env' + in + match Env.find_type path env' with + | { + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = Some t2; + } -> + (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 + | { + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + } + when allow_absent -> + complete nl ntl2 + | _ -> raise Exit + with + | Not_found when allow_absent -> complete nl ntl2 + | Exit -> raise Not_found) + in + complete nl1 (List.combine nl2 tl2) + +(* raise Not_found rather than Unify if the module types are incompatible *) +let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = + let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2 + and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in + unify_list (List.map snd ntl1) (List.map snd ntl2); + if + eq_package_path env p1 p2 + || !package_subtype env p1 n1 tl1 p2 n2 tl2 + && !package_subtype env p2 n2 tl2 p1 n1 tl1 + then () + else raise Not_found + +(* force unification in Reither when one side has a non-conjunctive type *) +let rigid_variants = ref false + +(* drop not force unification in Reither, even in fixed case + (not sound, only use it when checking exhaustiveness) *) +let passive_variants = ref false +let with_passive_variants f x = + if !passive_variants then f x + else + match + passive_variants := true; + f x + with + | r -> + passive_variants := false; + r + | exception e -> + passive_variants := false; + raise e + +let unify_eq t1 t2 = + t1 == t2 + || + match !umode with + | Expression -> false + | Pattern -> ( + try + TypePairs.find unify_eq_set (order_type_pair t1 t2); + true + with Not_found -> false) + +let unify1_var env t1 t2 = + assert (is_Tvar t1); + occur env t1 t2; + occur_univar env t2; + let d1 = t1.desc in + link_type t1 t2; + try update_level env t1.level t2 + with Unify _ as e -> + t1.desc <- d1; + raise e + +let rec unify (env : Env.t ref) t1 t2 = + (* First step: special cases (optimizations) *) + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if unify_eq t1 t2 then () + else + let reset_tracing = check_trace_gadt_instances !env in + + try + type_changed := true; + (match (t1.desc, t2.desc) with + | Tvar _, Tconstr _ when deep_occur t1 t2 -> unify2 env t1 t2 + | Tconstr _, Tvar _ when deep_occur t2 t1 -> unify2 env t1 t2 + | Tvar _, _ -> unify1_var !env t1 t2 + | _, Tvar _ -> unify1_var !env t2 t1 + | Tunivar _, Tunivar _ -> + unify_univar t1 t2 !univar_pairs; + update_level !env t1.level t2; + link_type t1 t2 + | Tconstr (p1, [], a1), Tconstr (p2, [], a2) + when Path.same p1 p2 (* && actual_mode !env = Old *) + (* This optimization assumes that t1 does not expand to t2 + (and conversely), so we fall back to the general case + when any of the types has a cached expansion. *) + && not + (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) + -> + update_level !env t1.level t2; + link_type t1 t2 + | Tconstr (p1, [], _), Tconstr (p2, [], _) + when Env.has_local_constraints !env + && is_newtype !env p1 && is_newtype !env p2 -> ( + (* Do not use local constraints more than necessary *) + try + let[@local] ( < ) ((a : int), (b : int)) (c, d) = + a < c || (a = c && b < d) + in + if find_newtype_level !env p1 < find_newtype_level !env p2 then + unify env t1 (try_expand_once !env t2) + else unify env (try_expand_once !env t1) t2 + with Cannot_expand -> unify2 env t1 t2) + | _ -> unify2 env t1 t2); + reset_trace_gadt_instances reset_tracing + with Unify trace -> + reset_trace_gadt_instances reset_tracing; + raise (Unify ((t1, t2) :: trace)) + +and unify2 env t1 t2 = + (* Second step: expansion of abbreviations *) + (* Expansion may change the representative of the types. *) + ignore (expand_head_unif !env t1); + ignore (expand_head_unif !env t2); + let t1' = expand_head_unif !env t1 in + let t2' = expand_head_unif !env t2 in + let lv = Ext_pervasives.min_int t1'.level t2'.level in + update_level !env lv t2; + update_level !env lv t1; + if unify_eq t1' t2' then () + else + let t1 = repr t1 and t2 = repr t2 in + (if !trace_gadt_instances then + (* All types in chains already have the same ambiguity levels *) + let ilevel t = + match Env.gadt_instance_level !env t with + | None -> 0 + | Some lv -> lv + in + let lv1 = ilevel t1 and lv2 = ilevel t2 in + if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 + else if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1); + if unify_eq t1 t1' || not (unify_eq t2 t2') then unify3 env t1 t1' t2 t2' + else + try unify3 env t2 t2' t1 t1' + with Unify trace -> + raise (Unify (List.map (fun (x, y) -> (y, x)) trace)) + +and unify3 env t1 t1' t2 t2' = + (* Third step: truly unification *) + (* Assumes either [t1 == t1'] or [t2 != t2'] *) + let d1 = t1'.desc and d2 = t2'.desc in + let create_recursion = t2 != t2' && deep_occur t1' t2 in + + match (d1, d2) with + (* handle vars and univars specially *) + | Tunivar _, Tunivar _ -> + unify_univar t1' t2' !univar_pairs; + link_type t1' t2' + | Tvar _, _ -> + occur !env t1' t2; + occur_univar !env t2; + link_type t1' t2 + | _, Tvar _ -> + occur !env t2' t1; + occur_univar !env t1; + link_type t2' t1 + | Tfield _, Tfield _ -> + (* special case for GADTs *) + unify_fields env t1' t2' + | Tconstr (Pident {name = "function$"}, [t_fun], _), Tarrow _ -> + (* subtype: an uncurried function is cast to a curried one *) + unify2 env t_fun t2 + | _ -> ( + (match !umode with + | Expression -> + occur !env t1' t2'; + link_type t1' t2 + | Pattern -> add_type_equality t1' t2'); + try + (match (d1, d2) with + | Tarrow (arg1, ret1, c1, a1), Tarrow (arg2, ret2, c2, a2) + when a1 = a2 + && (Asttypes.same_arg_label arg1.lbl arg2.lbl + || !umode = Pattern + && not (is_optional arg1.lbl || is_optional arg2.lbl)) -> ( + unify env arg1.typ arg2.typ; + unify env ret1 ret2; + match (commu_repr c1, commu_repr c2) with + | Clink r, c2 -> set_commu r c2 + | c1, Clink r -> set_commu r c1 + | _ -> ()) + | Ttuple tl1, Ttuple tl2 -> unify_list env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 -> + if !umode = Expression || not !generate_equations then + unify_list env tl1 tl2 + else if !assume_injective then + set_mode_pattern ~generate:true ~injective:false (fun () -> + unify_list env tl1 tl2) + else if + in_current_module p1 (* || in_pervasives p1 *) + || List.exists (expands_to_datatype !env) [t1'; t1; t2] + then unify_list env tl1 tl2 + else + let inj = + try + List.map Variance.(mem Inj) (Env.find_type p1 !env).type_variance + with Not_found -> List.map (fun _ -> false) tl1 + in + List.iter2 + (fun i (t1, t2) -> + if i then unify env t1 t2 + else + set_mode_pattern ~generate:false ~injective:false (fun () -> + let snap = snapshot () in + try unify env t1 t2 + with Unify _ -> + backtrack snap; + reify env t1; + reify env t2)) + inj (List.combine tl1 tl2) + | Tconstr (path, [], _), Tconstr (path', [], _) + when is_instantiable !env path && is_instantiable !env path' + && !generate_equations -> + let[@local] ( > ) ((a : int), (b : int)) (c, d) = + a > c || (a = c && b > d) + in + let source, destination = + if find_newtype_level !env path > find_newtype_level !env path' then + (path, t2') + else (path', t1') + in + add_gadt_equation env source destination + | Tconstr (path, [], _), _ + when is_instantiable !env path && !generate_equations -> + reify env t2'; + add_gadt_equation env path t2' + | _, Tconstr (path, [], _) + when is_instantiable !env path && !generate_equations -> + reify env t1'; + add_gadt_equation env path t1' + | (Tconstr (_, _, _), _ | _, Tconstr (_, _, _)) when !umode = Pattern -> + reify env t1'; + reify env t2'; + if !generate_equations then mcomp !env t1' t2' + | Tobject (fi1, nm1), Tobject (fi2, _) -> ( + unify_fields env fi1 fi2; + (* Type [t2'] may have been instantiated by [unify_fields] *) + (* XXX One should do some kind of unification... *) + match (repr t2').desc with + | Tobject (_, {contents = Some (_, va :: _)}) + when match (repr va).desc with + | Tvar _ | Tunivar _ | Tnil -> true + | _ -> false -> + () + | Tobject (_, nm2) -> set_name nm2 !nm1 + | _ -> ()) + | Tvariant row1, Tvariant row2 -> ( + if !umode = Expression then unify_row env row1 row2 + else + let snap = snapshot () in + try unify_row env row1 row2 + with Unify _ -> + backtrack snap; + reify env t1'; + reify env t2'; + if !generate_equations then mcomp !env t1' t2') + | Tfield (f, kind, _, rem), Tnil | Tnil, Tfield (f, kind, _, rem) -> ( + match field_kind_repr kind with + | Fvar r when f <> dummy_method -> + set_kind r Fabsent; + if d2 = Tnil then unify env rem t2' + else unify env (newty2 rem.level Tnil) rem + | _ -> raise (Unify [])) + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> unify env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env) + | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) -> ( + try + unify_package !env (unify_list env) t1.level p1 n1 tl1 t2.level p2 n2 + tl2 + with Not_found -> + if !umode = Expression then raise (Unify []); + List.iter (reify env) (tl1 @ tl2) + (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *)) + | _, _ -> raise (Unify [])); + (* XXX Commentaires + changer "create_recursion" + ||| Comments + change "create_recursion" *) + if create_recursion then + match t2.desc with + | Tconstr (p, tl, abbrev) -> + forget_abbrev abbrev p; + let t2'' = expand_head_unif !env t2 in + if not (closed_parameterized_type tl t2'') then + link_type (repr t2) (repr t2') + | _ -> () (* t2 has already been expanded by update_level *) + with Unify trace -> + t1'.desc <- d1; + raise (Unify trace)) + +and unify_list env tl1 tl2 = + if List.length tl1 <> List.length tl2 then raise (Unify []); + List.iter2 (unify env) tl1 tl2 + +(* Build a fresh row variable for unification *) +and make_rowvar level use1 rest1 use2 rest2 = + let set_name ty name = + match ty.desc with + | Tvar None -> + log_type ty; + ty.desc <- Tvar name + | _ -> () + in + let name = + match (rest1.desc, rest2.desc) with + | Tvar (Some _ as name1), Tvar (Some _ as name2) -> + if rest1.level <= rest2.level then name1 else name2 + | Tvar (Some _ as name), _ -> + if use2 then set_name rest2 name; + name + | _, Tvar (Some _ as name) -> + if use1 then set_name rest2 name; + name + | _ -> None + in + if use1 then rest1 else if use2 then rest2 else newvar2 ?name level + +and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = + (* Optimization *) + let fields1, rest1 = flatten_fields ty1 + and fields2, rest2 = flatten_fields ty2 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in + let l1 = (repr ty1).level and l2 = (repr ty2).level in + let va = + make_rowvar + (Ext_pervasives.min_int l1 l2) + (miss2 = []) rest1 (miss1 = []) rest2 + in + let d1 = rest1.desc and d2 = rest2.desc in + try + unify env (build_fields l1 miss1 va) rest2; + unify env rest1 (build_fields l2 miss2 va); + List.iter + (fun (n, k1, t1, k2, t2) -> + unify_kind k1 k2; + try + if !trace_gadt_instances then update_level !env va.level t1; + unify env t1 t2 + with Unify trace -> + raise + (Unify + (( newty (Tfield (n, k1, t1, newty Tnil)), + newty (Tfield (n, k2, t2, newty Tnil)) ) + :: trace))) + pairs + with exn -> + log_type rest1; + rest1.desc <- d1; + log_type rest2; + rest2.desc <- d2; + raise exn + +and unify_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + if k1 == k2 then () + else + match (k1, k2) with + | Fvar r, (Fvar _ | Fpresent) -> set_kind r k2 + | Fpresent, Fvar r -> set_kind r k1 + | Fpresent, Fpresent -> () + | _ -> assert false + +and unify_row env row1 row2 = + let row1 = row_repr row1 and row2 = row_repr row2 in + let rm1 = row_more row1 and rm2 = row_more row2 in + if unify_eq rm1 rm2 then () + else + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in + let more = + if fixed1 then rm1 + else if fixed2 then rm2 + else newty2 (Ext_pervasives.min_int rm1.level rm2.level) (Tvar None) + in + let fixed = fixed1 || fixed2 + and closed = row1.row_closed || row2.row_closed in + let keep switch = + List.for_all + (fun (_, f1, f2) -> + let f1, f2 = switch f1 f2 in + row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent) + pairs + in + let empty fields = + List.for_all (fun (_, f) -> row_field_repr f = Rabsent) fields + in + (* Check whether we are going to build an empty type *) + if + closed + && (empty r1 || row2.row_closed) + && (empty r2 || row1.row_closed) + && List.for_all + (fun (_, f1, f2) -> + row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) + pairs + then raise (Unify [(mkvariant [] true, mkvariant [] true)]); + let name = + if + row1.row_name <> None + && (row1.row_closed || empty r2) + && ((not row2.row_closed) || (keep (fun f1 f2 -> (f1, f2)) && empty r1)) + then row1.row_name + else if + row2.row_name <> None + && (row2.row_closed || empty r1) + && ((not row1.row_closed) || (keep (fun f1 f2 -> (f2, f1)) && empty r2)) + then row2.row_name + else None + in + let row0 = + { + row_fields = []; + row_more = more; + row_closed = closed; + row_fixed = fixed; + row_name = name; + } + in + let set_more row rest = + let rest = + if closed then filter_row_fields row.row_closed rest else rest + in + (if + (rest <> [] && (row.row_closed || row_fixed row)) + || (closed && row_fixed row && not row.row_closed) + then + let t1 = mkvariant [] true and t2 = mkvariant rest false in + raise (Unify [(if row == row1 then (t1, t2) else (t2, t1))])); + (* The following test is not principal... should rather use Tnil *) + let rm = row_more row in + (*if !trace_gadt_instances && rm.desc = Tnil then () else*) + if !trace_gadt_instances then + update_level !env rm.level (newgenty (Tvariant row)); + if row_fixed row then + if more == rm then () + else if is_Tvar rm then link_type rm more + else unify env rm more + else + let ty = newgenty (Tvariant {row0 with row_fields = rest}) in + update_level !env rm.level ty; + link_type rm ty + in + let md1 = rm1.desc and md2 = rm2.desc in + try + set_more row2 r1; + set_more row1 r2; + List.iter + (fun (l, f1, f2) -> + try unify_row_field env fixed1 fixed2 more l f1 f2 + with Unify trace -> + raise + (Unify + ((mkvariant [(l, f1)] true, mkvariant [(l, f2)] true) :: trace))) + pairs; + if static_row row1 then + let rm = row_more row1 in + if is_Tvar rm then link_type rm (newty2 rm.level Tnil) + with exn -> + log_type rm1; + rm1.desc <- md1; + log_type rm2; + rm2.desc <- md2; + raise exn + +and unify_row_field env fixed1 fixed2 more l f1 f2 = + let f1 = row_field_repr f1 and f2 = row_field_repr f2 in + if f1 == f2 then () + else + match (f1, f2) with + | Rpresent (Some t1), Rpresent (Some t2) -> unify env t1 t2 + | Rpresent None, Rpresent None -> () + | Reither (c1, tl1, m1, e1), Reither (c2, tl2, m2, e2) -> + if e1 == e2 then () + else if + (fixed1 || fixed2) + && (not (c1 || c2)) + && List.length tl1 = List.length tl2 + then ( + (* PR#7496 *) + let f = Reither (c1 || c2, [], m1 || m2, ref None) in + set_row_field e1 f; + set_row_field e2 f; + List.iter2 (unify env) tl1 tl2) + else + let redo = + (not !passive_variants) + && (m1 || m2 || fixed1 || fixed2 + || (!rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) + ) + && + match tl1 @ tl2 with + | [] -> false + | t1 :: tl -> + if c1 || c2 then raise (Unify []); + List.iter (unify env t1) tl; + !e1 <> None || !e2 <> None + in + if redo then unify_row_field env fixed1 fixed2 more l f1 f2 + else + let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in + let rec remq tl = function + | [] -> [] + | ty :: tl' -> + if List.memq ty tl then remq tl tl' else ty :: remq tl tl' + in + let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in + (* PR#6744 *) + let split_univars = + List.partition (fun ty -> + try + occur_univar !env ty; + true + with Unify _ -> false) + in + let tl1', tlu1 = split_univars tl1' + and tl2', tlu2 = split_univars tl2' in + (match (tlu1, tlu2) with + | [], [] -> () + | tu1 :: tlu1, _ :: _ -> + (* Attempt to merge all the types containing univars *) + if not !passive_variants then List.iter (unify env tu1) (tlu1 @ tlu2) + | tu :: _, [] | [], tu :: _ -> occur_univar !env tu); + (* Is this handling of levels really principal? *) + List.iter (update_level !env (repr more).level) (tl1' @ tl2'); + let e = ref None in + let f1' = Reither (c1 || c2, tl1', m1 || m2, e) + and f2' = Reither (c1 || c2, tl2', m1 || m2, e) in + set_row_field e1 f1'; + set_row_field e2 f2' + | Reither (_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 + | Rabsent, Reither (_, _, false, e2) when not fixed2 -> set_row_field e2 f1 + | Rabsent, Rabsent -> () + | Reither (false, tl, _, e1), Rpresent (Some t2) when not fixed1 -> ( + set_row_field e1 f2; + update_level !env (repr more).level t2; + try List.iter (fun t1 -> unify env t1 t2) tl + with exn -> + e1 := None; + raise exn) + | Rpresent (Some t1), Reither (false, tl, _, e2) when not fixed2 -> ( + set_row_field e2 f1; + update_level !env (repr more).level t1; + try List.iter (unify env t1) tl + with exn -> + e2 := None; + raise exn) + | Reither (true, [], _, e1), Rpresent None when not fixed1 -> + set_row_field e1 f2 + | Rpresent None, Reither (true, [], _, e2) when not fixed2 -> + set_row_field e2 f1 + | _ -> raise (Unify []) + +let unify env ty1 ty2 = + let snap = Btype.snapshot () in + try unify env ty1 ty2 with + | Unify trace -> + undo_compress snap; + raise (Unify (expand_trace !env trace)) + | Recursive_abbrev -> + undo_compress snap; + raise (Unification_recursive_abbrev (expand_trace !env [(ty1, ty2)])) + +let unify_gadt ~newtype_level:lev (env : Env.t ref) ty1 ty2 = + try + univar_pairs := []; + newtype_level := Some lev; + set_mode_pattern ~generate:true ~injective:true (fun () -> + unify env ty1 ty2); + newtype_level := None; + TypePairs.clear unify_eq_set + with e -> + newtype_level := None; + TypePairs.clear unify_eq_set; + raise e + +let unify_var env t1 t2 = + let t1 = repr t1 and t2 = repr t2 in + if t1 == t2 then () + else + match (t1.desc, t2.desc) with + | Tvar _, Tconstr _ when deep_occur t1 t2 -> unify (ref env) t1 t2 + | Tvar _, _ -> ( + let reset_tracing = check_trace_gadt_instances env in + try + occur env t1 t2; + update_level env t1.level t2; + link_type t1 t2; + reset_trace_gadt_instances reset_tracing + with Unify trace -> + reset_trace_gadt_instances reset_tracing; + let expanded_trace = expand_trace env ((t1, t2) :: trace) in + raise (Unify expanded_trace)) + | _ -> unify (ref env) t1 t2 + +let _ = unify' := unify_var + +let unify_pairs env ty1 ty2 pairs = + univar_pairs := pairs; + unify env ty1 ty2 + +let unify env ty1 ty2 = unify_pairs (ref env) ty1 ty2 [] + +(**** Special cases of unification ****) + +let expand_head_trace env t = + let reset_tracing = check_trace_gadt_instances env in + let t = expand_head_unif env t in + reset_trace_gadt_instances reset_tracing; + t + +(* + Unify [t] and [l:'a -> 'b]. Return ['a] and ['b]. + In label mode, label mismatch is accepted when + (1) the requested label is "" + (2) the original label is not optional +*) + +let filter_arrow ~env ~arity t l = + let t = expand_head_trace env t in + match t.desc with + | Tvar _ -> + let lv = t.level in + let t1 = newvar2 lv and t2 = newvar2 lv in + let t' = newty2 lv (Tarrow ({lbl = l; typ = t1}, t2, Cok, arity)) in + link_type t t'; + (t1, t2) + | Tarrow (arg, ret, _, _) when Asttypes.same_arg_label l arg.lbl -> + (arg.typ, ret) + | _ -> raise (Unify []) + +(* Used by [filter_method]. *) +let rec filter_method_field env name priv ty = + let ty = expand_head_trace env ty in + match ty.desc with + | Tvar _ -> + let level = ty.level in + let ty1 = newvar2 level and ty2 = newvar2 level in + let ty' = + newty2 level + (Tfield + ( name, + (match priv with + | Private -> Fvar (ref None) + | Public -> Fpresent), + ty1, + ty2 )) + in + link_type ty ty'; + ty1 + | Tfield (n, kind, ty1, ty2) -> + let kind = field_kind_repr kind in + if n = name && kind <> Fabsent then ( + if priv = Public then unify_kind kind Fpresent; + ty1) + else filter_method_field env name priv ty2 + | _ -> raise (Unify []) + +(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) +let filter_method env name priv ty = + let ty = expand_head_trace env ty in + match ty.desc with + | Tvar _ -> + let ty1 = newvar () in + let ty' = newobj ty1 in + update_level env ty.level ty'; + link_type ty ty'; + filter_method_field env name priv ty1 + | Tobject (f, _) -> filter_method_field env name priv f + | _ -> raise (Unify []) + +let check_filter_method env name priv ty = + ignore (filter_method env name priv ty) + +let filter_self_method env lab priv meths ty = + let ty' = filter_method env lab priv ty in + try Meths.find lab !meths + with Not_found -> + let pair = (Ident.create lab, ty') in + meths := Meths.add lab pair !meths; + pair + +(***********************************) +(* Matching between type schemes *) +(***********************************) + +(* + Update the level of [ty]. First check that the levels of generic + variables from the subject are not lowered. +*) +let moregen_occur env level ty = + let rec occur ty = + let ty = repr ty in + if ty.level > level then ( + if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur; + ty.level <- pivot_level - ty.level; + match ty.desc with + | Tvariant row when static_row row -> iter_row occur row + | _ -> iter_type_expr occur ty) + in + (try + occur ty; + unmark_type ty + with Occur -> + unmark_type ty; + raise (Unify [])); + (* also check for free univars *) + occur_univar env ty; + update_level env level ty + +let may_instantiate inst_nongen t1 = + if inst_nongen then t1.level <> generic_level - 1 + else t1.level = generic_level + +let rec moregen inst_nongen type_pairs env t1 t2 = + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if t1 == t2 then () + else + try + match (t1.desc, t2.desc) with + | Tvar _, _ when may_instantiate inst_nongen t1 -> + moregen_occur env t1.level t2; + occur env t1 t2; + link_type t1 t2 + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> () + | _ -> ( + let t1' = expand_head env t1 in + let t2' = expand_head env t2 in + (* Expansion may have changed the representative of the types... *) + let t1' = repr t1' and t2' = repr t2' in + if t1' == t2' then () + else + try TypePairs.find type_pairs (t1', t2') + with Not_found -> ( + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with + | Tvar _, _ when may_instantiate inst_nongen t1' -> + moregen_occur env t1'.level t2; + link_type t1' t2 + | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) + when Asttypes.same_arg_label arg1.lbl arg2.lbl -> + moregen inst_nongen type_pairs env arg1.typ arg2.typ; + moregen inst_nongen type_pairs env ret1 ret2 + | Ttuple tl1, Ttuple tl2 -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 + -> + moregen_list inst_nongen type_pairs env tl1 tl2 + | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) -> ( + try + unify_package env + (moregen_list inst_nongen type_pairs env) + t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 + with Not_found -> raise (Unify [])) + | Tvariant row1, Tvariant row2 -> + moregen_row inst_nongen type_pairs env row1 row2 + | Tobject (fi1, _nm1), Tobject (fi2, _nm2) -> + moregen_fields inst_nongen type_pairs env fi1 fi2 + | Tfield _, Tfield _ -> + (* Actually unused *) + moregen_fields inst_nongen type_pairs env t1' t2' + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> + moregen inst_nongen type_pairs env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (moregen inst_nongen type_pairs env) + | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | _, _ -> raise (Unify []))) + with Unify trace -> raise (Unify ((t1, t2) :: trace)) + +and moregen_list inst_nongen type_pairs env tl1 tl2 = + if List.length tl1 <> List.length tl2 then raise (Unify []); + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + +and moregen_fields inst_nongen type_pairs env ty1 ty2 = + let fields1, rest1 = flatten_fields ty1 + and fields2, rest2 = flatten_fields ty2 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in + if miss1 <> [] then raise (Unify []); + moregen inst_nongen type_pairs env rest1 + (build_fields (repr ty2).level miss2 rest2); + List.iter + (fun (n, k1, t1, k2, t2) -> + moregen_kind k1 k2; + try moregen inst_nongen type_pairs env t1 t2 + with Unify trace -> + raise + (Unify + (( newty (Tfield (n, k1, t1, rest2)), + newty (Tfield (n, k2, t2, rest2)) ) + :: trace))) + pairs + +and moregen_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + if k1 == k2 then () + else + match (k1, k2) with + | Fvar r, (Fvar _ | Fpresent) -> set_kind r k2 + | Fpresent, Fpresent -> () + | _ -> raise (Unify []) + +and moregen_row inst_nongen type_pairs env row1 row2 = + let row1 = row_repr row1 and row2 = row_repr row2 in + let rm1 = repr row1.row_more and rm2 = repr row2.row_more in + if rm1 == rm2 then () + else + let may_inst = + (is_Tvar rm1 && may_instantiate inst_nongen rm1) || rm1.desc = Tnil + in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let r1, r2 = + if row2.row_closed then + (filter_row_fields may_inst r1, filter_row_fields false r2) + else (r1, r2) + in + if r1 <> [] || (row1.row_closed && ((not row2.row_closed) || r2 <> [])) then + raise (Unify []); + (match (rm1.desc, rm2.desc) with + | Tunivar _, Tunivar _ -> unify_univar rm1 rm2 !univar_pairs + | Tunivar _, _ | _, Tunivar _ -> raise (Unify []) + | _ when static_row row1 -> () + | _ when may_inst -> + let ext = + newgenty (Tvariant {row2 with row_fields = r2; row_name = None}) + in + moregen_occur env rm1.level ext; + link_type rm1 ext + | Tconstr _, Tconstr _ -> moregen inst_nongen type_pairs env rm1 rm2 + | _ -> raise (Unify [])); + List.iter + (fun (_l, f1, f2) -> + let f1 = row_field_repr f1 and f2 = row_field_repr f2 in + if f1 == f2 then () + else + match (f1, f2) with + | Rpresent (Some t1), Rpresent (Some t2) -> + moregen inst_nongen type_pairs env t1 t2 + | Rpresent None, Rpresent None -> () + | Reither (false, tl1, _, e1), Rpresent (Some t2) when may_inst -> + set_row_field e1 f2; + List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 + | Reither (c1, tl1, _, e1), Reither (c2, tl2, m2, e2) -> + if e1 != e2 then ( + if c1 && not c2 then raise (Unify []); + set_row_field e1 (Reither (c2, [], m2, e2)); + if List.length tl1 = List.length tl2 then + List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 + else + match tl2 with + | t2 :: _ -> + List.iter + (fun t1 -> moregen inst_nongen type_pairs env t1 t2) + tl1 + | [] -> if tl1 <> [] then raise (Unify [])) + | Reither (true, [], _, e1), Rpresent None when may_inst -> + set_row_field e1 f2 + | Reither (_, _, _, e1), Rabsent when may_inst -> set_row_field e1 f2 + | Rabsent, Rabsent -> () + | _ -> raise (Unify [])) + pairs + +(* Must empty univar_pairs first *) +let moregen inst_nongen type_pairs env patt subj = + univar_pairs := []; + moregen inst_nongen type_pairs env patt subj + +(* + Non-generic variable can be instantiated only if [inst_nongen] is + true. So, [inst_nongen] should be set to false if the subject might + contain non-generic variables (and we do not want them to be + instantiated). + Usually, the subject is given by the user, and the pattern + is unimportant. So, no need to propagate abbreviations. +*) +let moregeneral env inst_nongen pat_sch subj_sch = + let old_level = !current_level in + current_level := generic_level - 1; + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [generic_level - 1]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let subj = duplicate_type (instance env subj_sch) in + current_level := generic_level; + (* Duplicate generic variables *) + let patt = instance env pat_sch in + let res = + try + moregen inst_nongen (TypePairs.create 13) env patt subj; + true + with Unify _ -> false + in + current_level := old_level; + res + +(* Alternative approach: "rigidify" a type scheme, + and check validity after unification *) +(* Simpler, no? *) + +let rec rigidify_rec vars ty = + let ty = repr ty in + if ty.level >= lowest_level then ( + ty.level <- pivot_level - ty.level; + match ty.desc with + | Tvar _ -> if not (List.memq ty !vars) then vars := ty :: !vars + | Tvariant row -> + let row = row_repr row in + let more = repr row.row_more in + (if is_Tvar more && not (row_fixed row) then + let more' = newty2 more.level more.desc in + let row' = + {row with row_fixed = true; row_fields = []; row_more = more'} + in + link_type more (newty2 ty.level (Tvariant row'))); + iter_row (rigidify_rec vars) row; + (* only consider the row variable if the variant is not static *) + if not (static_row row) then rigidify_rec vars (row_more row) + | _ -> iter_type_expr (rigidify_rec vars) ty) + +let rigidify ty = + let vars = ref [] in + rigidify_rec vars ty; + unmark_type ty; + !vars + +let all_distinct_vars env vars = + let tyl = ref [] in + List.for_all + (fun ty -> + let ty = expand_head env ty in + if List.memq ty !tyl then false + else ( + tyl := ty :: !tyl; + is_Tvar ty)) + vars + +let matches env ty ty' = + let snap = snapshot () in + let vars = rigidify ty in + cleanup_abbrev (); + let ok = + try + unify env ty ty'; + all_distinct_vars env vars + with Unify _ -> false + in + backtrack snap; + ok + +(*********************************************) +(* Equivalence between parameterized types *) +(*********************************************) + +let expand_head_rigid env ty = + let old = !rigid_variants in + rigid_variants := true; + let ty' = expand_head env ty in + rigid_variants := old; + ty' + +let normalize_subst subst = + if + List.exists + (function + | {desc = Tlink _}, _ | _, {desc = Tlink _} -> true + | _ -> false) + !subst + then subst := List.map (fun (t1, t2) -> (repr t1, repr t2)) !subst + +let rec eqtype rename type_pairs subst env t1 t2 = + if t1 == t2 then () + else + let t1 = repr t1 in + let t2 = repr t2 in + if t1 == t2 then () + else + try + match (t1.desc, t2.desc) with + | Tvar _, Tvar _ when rename -> ( + try + normalize_subst subst; + if List.assq t1 !subst != t2 then raise (Unify []) + with Not_found -> + if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []); + subst := (t1, t2) :: !subst) + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> () + | _ -> ( + let t1' = expand_head_rigid env t1 in + let t2' = expand_head_rigid env t2 in + (* Expansion may have changed the representative of the types... *) + let t1' = repr t1' and t2' = repr t2' in + if t1' == t2' then () + else + try TypePairs.find type_pairs (t1', t2') + with Not_found -> ( + TypePairs.add type_pairs (t1', t2') (); + match (t1'.desc, t2'.desc) with + | Tvar _, Tvar _ when rename -> ( + try + normalize_subst subst; + if List.assq t1' !subst != t2' then raise (Unify []) + with Not_found -> + if List.exists (fun (_, t) -> t == t2') !subst then + raise (Unify []); + subst := (t1', t2') :: !subst) + | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) + when Asttypes.same_arg_label arg1.lbl arg2.lbl -> + eqtype rename type_pairs subst env arg1.typ arg2.typ; + eqtype rename type_pairs subst env ret1 ret2 + | Ttuple tl1, Ttuple tl2 -> + eqtype_list rename type_pairs subst env tl1 tl2 + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 + -> + eqtype_list rename type_pairs subst env tl1 tl2 + | Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2) -> ( + try + unify_package env + (eqtype_list rename type_pairs subst env) + t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 + with Not_found -> raise (Unify [])) + | Tvariant row1, Tvariant row2 -> + eqtype_row rename type_pairs subst env row1 row2 + | Tobject (fi1, _nm1), Tobject (fi2, _nm2) -> + eqtype_fields rename type_pairs subst env fi1 fi2 + | Tfield _, Tfield _ -> + (* Actually unused *) + eqtype_fields rename type_pairs subst env t1' t2' + | Tnil, Tnil -> () + | Tpoly (t1, []), Tpoly (t2, []) -> + eqtype rename type_pairs subst env t1 t2 + | Tpoly (t1, tl1), Tpoly (t2, tl2) -> + enter_poly env univar_pairs t1 tl1 t2 tl2 + (eqtype rename type_pairs subst env) + | Tunivar _, Tunivar _ -> unify_univar t1' t2' !univar_pairs + | _, _ -> raise (Unify []))) + with Unify trace -> raise (Unify ((t1, t2) :: trace)) + +and eqtype_list rename type_pairs subst env tl1 tl2 = + if List.length tl1 <> List.length tl2 then raise (Unify []); + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + +and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = + let fields1, rest1 = flatten_fields ty1 in + let fields2, rest2 = flatten_fields ty2 in + (* First check if same row => already equal *) + let same_row = + rest1 == rest2 + || TypePairs.mem type_pairs (rest1, rest2) + || (rename && List.mem (rest1, rest2) !subst) + in + if same_row then () + else + (* Try expansion, needed when called from Includecore.type_manifest *) + match expand_head_rigid env rest2 with + | {desc = Tobject (ty2, _)} -> + eqtype_fields rename type_pairs subst env ty1 ty2 + | _ -> + let pairs, miss1, miss2 = associate_fields fields1 fields2 in + eqtype rename type_pairs subst env rest1 rest2; + if miss1 <> [] || miss2 <> [] then raise (Unify []); + List.iter + (function + | n, k1, t1, k2, t2 -> ( + eqtype_kind k1 k2; + try eqtype rename type_pairs subst env t1 t2 + with Unify trace -> + raise + (Unify + (( newty (Tfield (n, k1, t1, rest2)), + newty (Tfield (n, k2, t2, rest2)) ) + :: trace)))) + pairs + +and eqtype_kind k1 k2 = + let k1 = field_kind_repr k1 in + let k2 = field_kind_repr k2 in + match (k1, k2) with + | Fvar _, Fvar _ | Fpresent, Fpresent -> () + | _ -> raise (Unify []) + +and eqtype_row rename type_pairs subst env row1 row2 = + (* Try expansion, needed when called from Includecore.type_manifest *) + match expand_head_rigid env (row_more row2) with + | {desc = Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 + | _ -> + let row1 = row_repr row1 and row2 = row_repr row2 in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + if + row1.row_closed <> row2.row_closed + || ((not row1.row_closed) && (r1 <> [] || r2 <> [])) + || filter_row_fields false (r1 @ r2) <> [] + then raise (Unify []); + if not (static_row row1) then + eqtype rename type_pairs subst env row1.row_more row2.row_more; + List.iter + (fun (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | Rpresent (Some t1), Rpresent (Some t2) -> + eqtype rename type_pairs subst env t1 t2 + | Reither (c1, [], _, _), Reither (c2, [], _, _) when c1 = c2 -> () + | Reither (c1, t1 :: tl1, _, _), Reither (c2, t2 :: tl2, _, _) + when c1 = c2 -> + eqtype rename type_pairs subst env t1 t2; + if List.length tl1 = List.length tl2 then + (* if same length allow different types (meaning?) *) + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + else ( + (* otherwise everything must be equal *) + List.iter (eqtype rename type_pairs subst env t1) tl2; + List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1) + | Rpresent None, Rpresent None -> () + | Rabsent, Rabsent -> () + | _ -> raise (Unify [])) + pairs + +(* Must empty univar_pairs first *) +let eqtype_list rename type_pairs subst env tl1 tl2 = + univar_pairs := []; + let snap = Btype.snapshot () in + try + eqtype_list rename type_pairs subst env tl1 tl2; + backtrack snap + with exn -> + backtrack snap; + raise exn + +(* Two modes: with or without renaming of variables *) +let equal env rename tyl1 tyl2 = + try + eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; + true + with Unify _ -> false + +(*************************) +(* Class type matching *) +(*************************) + +type class_match_failure = + | CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list + | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list + | CM_Non_mutable_value of string + | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string + | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string + +(***************) +(* Subtyping *) +(***************) + +(**** Build a subtype of a given type. ****) + +(* build_subtype: + [visited] traces traversed object and variant types + [loops] is a mapping from variables to variables, to reproduce + positive loops in a class type + [posi] true if the current variance is positive + [level] number of expansions/enlargement allowed on this branch *) + +let warn = ref false (* whether double coercion might do better *) +let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n +let pred_enlarge n = if n mod 2 = 1 then pred n else n + +type change = Unchanged | Equiv | Changed [@@immediate] + +let[@inline] max (c1 : change) (c2 : change) : change = + Obj.magic (Ext_pervasives.max_int (Obj.magic c1 : int) (Obj.magic c2 : int)) +let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l + +let rec filter_visited = function + | [] -> [] + | {desc = Tobject _ | Tvariant _} :: _ as l -> l + | _ :: l -> filter_visited l + +let memq_warn t visited = + if List.memq t visited then ( + warn := true; + true) + else false + +let rec lid_of_path ?(hash = "") = function + | Path.Pident id -> Longident.Lident (hash ^ Ident.name id) + | Path.Pdot (p1, s, _) -> Longident.Ldot (lid_of_path p1, hash ^ s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2) + +let find_cltype_for_path env p = + let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in + let cl_abbr = Env.find_type cl_path env in + + match cl_abbr.type_manifest with + | Some ty -> ( + match (repr ty).desc with + | Tobject (_, {contents = Some (p', _)}) when Path.same p p' -> (cl_abbr, ty) + | _ -> raise Not_found) + | None -> assert false + +let has_constr_row' env t = has_constr_row (expand_abbrev env t) + +let rec build_subtype env visited loops posi level t = + let t = repr t in + match t.desc with + | Tvar _ -> + if posi then + try + let t' = List.assq t loops in + warn := true; + (t', Equiv) + with Not_found -> (t, Unchanged) + else (t, Unchanged) + | Tarrow (arg, ret, _, a) -> + if memq_warn t visited then (t, Unchanged) + else + let visited = t :: visited in + let t1, c1 = build_subtype env visited loops (not posi) level arg.typ in + let t2, c2 = build_subtype env visited loops posi level ret in + let c = max c1 c2 in + if c > Unchanged then (newty (Tarrow ({arg with typ = t1}, t2, Cok, a)), c) + else (t, Unchanged) + | Ttuple tlist -> + if memq_warn t visited then (t, Unchanged) + else + let visited = t :: visited in + let tlist' = + List.map (build_subtype env visited loops posi level) tlist + in + let c = collect tlist' in + if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c) + else (t, Unchanged) + | Tconstr (p, tl, abbrev) + when level > 0 && generic_abbrev env p && safe_abbrev env t + && not (has_constr_row' env t) -> ( + let t' = repr (expand_abbrev env t) in + let level' = pred_expand level in + try + match t'.desc with + | Tobject _ when posi && not (opened_object t') -> + let cl_abbr, body = find_cltype_for_path env p in + let ty = + subst env !current_level Public abbrev None cl_abbr.type_params tl + body + in + let ty = repr ty in + let ty1, tl1 = + match ty.desc with + | Tobject (ty1, {contents = Some (p', tl1)}) when Path.same p p' -> + (ty1, tl1) + | _ -> raise Not_found + in + (* Fix PR#4505: do not set ty to Tvar when it appears in tl1, + as this occurrence might break the occur check. + XXX not clear whether this correct anyway... *) + if List.exists (deep_occur ty) tl1 then raise Not_found; + ty.desc <- Tvar None; + let t'' = newvar () in + let loops = (ty, t'') :: loops in + (* May discard [visited] as level is going down *) + let ty1', c = + build_subtype env [t'] loops posi (pred_enlarge level') ty1 + in + assert (is_Tvar t''); + let nm = + if c > Equiv || deep_occur ty ty1' then None else Some (p, tl1) + in + t''.desc <- Tobject (ty1', ref nm); + (try unify_var env ty t with Unify _ -> assert false); + (t'', Changed) + | _ -> raise Not_found + with Not_found -> + let t'', c = build_subtype env visited loops posi level' t' in + if c > Unchanged then (t'', c) else (t, Unchanged)) + | Tconstr (p, tl, _abbrev) -> ( + if + (* Must check recursion on constructors, since we do not always + expand them *) + memq_warn t visited + then (t, Unchanged) + else + let visited = t :: visited in + try + let decl = Env.find_type p env in + if + level = 0 && generic_abbrev env p && safe_abbrev env t + && not (has_constr_row' env t) + then warn := true; + let tl' = + List.map2 + (fun v t -> + let co, cn = Variance.get_upper v in + if cn then + if co then (t, Unchanged) + else build_subtype env visited loops (not posi) level t + else if co then build_subtype env visited loops posi level t + else (newvar (), Changed)) + decl.type_variance tl + in + let c = collect tl' in + if c > Unchanged then (newconstr p (List.map fst tl'), c) + else (t, Unchanged) + with Not_found -> (t, Unchanged)) + | Tvariant row -> + let row = row_repr row in + if memq_warn t visited || not (static_row row) then (t, Unchanged) + else + let level' = pred_enlarge level in + let visited = + t :: (if level' < level then [] else filter_visited visited) + in + let fields = filter_row_fields false row.row_fields in + let fields = + List.map + (fun ((l, f) as orig) -> + match row_field_repr f with + | Rpresent None -> + if posi then ((l, Reither (true, [], false, ref None)), Unchanged) + else (orig, Unchanged) + | Rpresent (Some t) -> + let t', c = build_subtype env visited loops posi level' t in + let f = + if posi && level > 0 then Reither (false, [t'], false, ref None) + else Rpresent (Some t') + in + ((l, f), c) + | _ -> assert false) + fields + in + let c = collect fields in + let row = + { + row_fields = List.map fst fields; + row_more = newvar (); + row_closed = posi; + row_fixed = false; + row_name = (if c > Unchanged then None else row.row_name); + } + in + (newty (Tvariant row), Changed) + | Tobject (t1, _) -> + if memq_warn t visited || opened_object t1 then (t, Unchanged) + else + let level' = pred_enlarge level in + let visited = + t :: (if level' < level then [] else filter_visited visited) + in + let t1', c = build_subtype env visited loops posi level' t1 in + if c > Unchanged then (newty (Tobject (t1', ref None)), c) + else (t, Unchanged) + | Tfield (s, _, t1, t2) (* Always present *) -> + let t1', c1 = build_subtype env visited loops posi level t1 in + let t2', c2 = build_subtype env visited loops posi level t2 in + let c = max c1 c2 in + if c > Unchanged then (newty (Tfield (s, Fpresent, t1', t2')), c) + else (t, Unchanged) + | Tnil -> + if posi then + let v = newvar () in + (v, Changed) + else ( + warn := true; + (t, Unchanged)) + | Tsubst _ | Tlink _ -> assert false + | Tpoly (t1, tl) -> + let t1', c = build_subtype env visited loops posi level t1 in + if c > Unchanged then (newty (Tpoly (t1', tl)), c) else (t, Unchanged) + | Tunivar _ | Tpackage _ -> (t, Unchanged) + +let enlarge_type env ty = + warn := false; + (* [level = 4] allows 2 expansions involving objects/variants *) + let ty', _ = build_subtype env [] [] true 4 ty in + (ty', !warn) + +(**** Check whether a type is a subtype of another type. ****) + +(* + During the traversal, a trace of visited types is maintained. It + is printed in case of error. + Constraints (pairs of types that must be equals) are accumulated + rather than being enforced straight. Indeed, the result would + otherwise depend on the order in which these constraints are + enforced. + A function enforcing these constraints is returned. That way, type + variables can be bound to their actual values before this function + is called (see Typecore). + Only well-defined abbreviations are expanded (hence the tests + [generic_abbrev ...]). +*) + +let subtypes = TypePairs.create 17 + +let subtype_error ?ctx env trace = + raise (Subtype (expand_trace env (List.rev trace), [], ctx)) + +let extract_concrete_typedecl_opt env t = + match extract_concrete_typedecl env t with + | v -> Some v + | exception Not_found -> None + +let rec subtype_rec env trace t1 t2 cstrs = + let t1 = repr t1 in + let t2 = repr t2 in + if t1 == t2 then cstrs + else + try + TypePairs.find subtypes (t1, t2); + cstrs + with Not_found -> ( + TypePairs.add subtypes (t1, t2) (); + match (t1.desc, t2.desc) with + | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs + | Tarrow (arg1, ret1, _, _), Tarrow (arg2, ret2, _, _) + when Asttypes.same_arg_label arg1.lbl arg2.lbl -> + let cstrs = + subtype_rec env + ((arg2.typ, arg1.typ) :: trace) + arg2.typ arg1.typ cstrs + in + subtype_rec env ((ret1, ret2) :: trace) ret1 ret2 cstrs + | Ttuple tl1, Ttuple tl2 -> + (* TODO(subtype-errors) Tuple as context *) + subtype_list env trace tl1 tl2 cstrs + | Tconstr (p1, [], _), Tconstr (p2, [], _) when Path.same p1 p2 -> cstrs + | Tconstr (p1, _tl1, _abbrev1), _ + when generic_abbrev env p1 && safe_abbrev env t1 -> + subtype_rec env trace (expand_abbrev env t1) t2 cstrs + | _, Tconstr (p2, _tl2, _abbrev2) + when generic_abbrev env p2 && safe_abbrev env t2 -> + subtype_rec env trace t1 (expand_abbrev env t2) cstrs + | Tconstr (p1, tl1, _), Tconstr (p2, tl2, _) when Path.same p1 p2 -> ( + try + let decl = Env.find_type p1 env in + List.fold_left2 + (fun cstrs v (t1, t2) -> + let co, cn = Variance.get_upper v in + if co then + if cn then + (* Invariant type argument: check both ways *) + if + subtype_rec env ((t1, t2) :: trace) t1 t2 [] = [] + && subtype_rec env ((t2, t1) :: trace) t2 t1 [] = [] + then cstrs + else + ( trace, + newty2 t1.level (Ttuple [t1]), + newty2 t2.level (Ttuple [t2]), + !univar_pairs, + None ) + :: cstrs + else subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + else if cn then subtype_rec env ((t2, t1) :: trace) t2 t1 cstrs + else cstrs) + cstrs decl.type_variance (List.combine tl1 tl2) + with Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | Tconstr (p1, _, _), _ when generic_private_abbrev env p1 -> + subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs + | Tconstr (p1, [], _), Tconstr (p2, [], _) + when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float -> + (* Int can always be coerced to float *) + cstrs + | Tconstr (path, [], _), Tconstr (_, [], _) + when Variant_coercion.can_coerce_primitive path + && extract_concrete_typedecl_opt env t2 + |> Variant_coercion.can_try_coerce_variant_to_primitive_opt + |> Option.is_some -> ( + (* type coercion for primitives (int/float/string) to elgible unboxed variants: + - must be unboxed + - must have a constructor case with a supported and matching primitive payload *) + match + Variant_coercion.can_try_coerce_variant_to_primitive_opt + (extract_concrete_typedecl_opt env t2) + with + | Some (p, _, false) -> + (* Not @unboxed *) + ( trace, + t1, + t2, + !univar_pairs, + Some + (Coercion_target_variant_not_unboxed + {variant_name = p; primitive = path}) ) + :: cstrs + | Some (p, constructors, true) -> + if + Variant_coercion.variant_has_case_covering_type constructors + ~path_is_same_fn:(fun p -> Path.same p path) + then cstrs + else + ( trace, + t1, + t2, + !univar_pairs, + Some + (Coercion_target_variant_does_not_cover_type + {variant_name = p; primitive = path}) ) + :: cstrs + | None -> + (* Unclear when this case actually happens. *) + (trace, t1, t2, !univar_pairs, Some (Generic {errorCode = "VCPMMVD"})) + :: cstrs) + | Tconstr (_, [], _), Tconstr (path, [], _) + when Variant_coercion.can_coerce_primitive path + && extract_concrete_typedecl_opt env t1 + |> Variant_coercion.can_try_coerce_variant_to_primitive_opt + |> Option.is_some -> ( + (* type coercion for variants to primitives *) + match + Variant_coercion.can_try_coerce_variant_to_primitive_opt + (extract_concrete_typedecl_opt env t1) + with + | Some (p, constructors, unboxed) -> + let runtime_representation_issues = + constructors + |> Variant_coercion + .variant_has_same_runtime_representation_as_target + ~target_path:path ~unboxed + in + if List.length runtime_representation_issues <> 0 then + ( trace, + t1, + t2, + !univar_pairs, + Some + (Variant_constructor_runtime_representation_mismatch + {issues = runtime_representation_issues; variant_name = p}) + ) + :: cstrs + else cstrs + | None -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | Tconstr (_, [], _), Tconstr (_, [], _) -> ( + (* type coercion for variants and records *) + match + (extract_concrete_typedecl env t1, extract_concrete_typedecl env t2) + with + | ( (p1, _, {type_kind = Type_variant c1; type_attributes = t1attrs}), + (p2, _, {type_kind = Type_variant c2; type_attributes = t2attrs}) ) + -> ( + match + Variant_coercion.variant_configuration_can_be_coerced t1attrs + t2attrs + with + | Error issue -> + ( trace, + t1, + t2, + !univar_pairs, + Some + (Variant_configurations_mismatch + {left_variant_name = p1; right_variant_name = p2; issue}) ) + :: cstrs + | Ok () -> + let c1_len = List.length c1 in + if c1_len > List.length c2 then + let c1_constructor_names = + c1 |> List.map (fun c -> c.cd_id.name) + in + let c2_constructor_names = + c2 |> List.map (fun c -> c.cd_id.name) + in + let incompatible_constructor_names = + c1_constructor_names + |> List.filter (fun name -> + not (List.mem name c2_constructor_names)) + in + ( trace, + t1, + t2, + !univar_pairs, + Some + (Variant_configurations_mismatch + { + left_variant_name = p1; + right_variant_name = p2; + issue = + Incompatible_constructor_count + {constructor_names = incompatible_constructor_names}; + }) ) + :: cstrs + else + let constructor_map = Hashtbl.create c1_len in + c2 + |> List.iter (fun (c : Types.constructor_declaration) -> + Hashtbl.add constructor_map (Ident.name c.cd_id) c); + let field_subtype_violations = + c1 + |> List.filter_map (fun (c : Types.constructor_declaration) -> + match + ( c, + Hashtbl.find_opt constructor_map (Ident.name c.cd_id) + ) + with + | ( { + Types.cd_args = Cstr_record fields1; + cd_attributes = c1_attributes; + }, + Some + { + Types.cd_args = Cstr_record fields2; + cd_attributes = c2_attributes; + } ) -> + if + Variant_coercion.variant_representation_matches + c1_attributes c2_attributes + then + let violations, tl1, tl2 = + Record_coercion.check_record_fields fields1 fields2 + in + match violations with + | [] -> ( + try + let lst = subtype_list env trace tl1 tl2 cstrs in + if List.length lst = List.length cstrs then None + else + Some + [ (* TODO(subtype-errors) Variant constructor inline record mismatch *) ] + with _ -> + Some + [ (* TODO(subtype-errors) Variant constructor inline record mismatch *) ] + ) + | violations -> Some violations + else + Some + [ (* TODO(subtype-errors) Variant constructor representation mismatch*) ] + | ( { + Types.cd_args = Cstr_tuple tl1; + cd_attributes = c1_attributes; + }, + Some + { + Types.cd_args = Cstr_tuple tl2; + cd_attributes = c2_attributes; + } ) -> + if + Variant_coercion.variant_representation_matches + c1_attributes c2_attributes + then + try + let lst = subtype_list env trace tl1 tl2 cstrs in + if List.length lst = List.length cstrs then None + else + Some + [ (* TODO(subtype-errors) Variant constructor tuple mismatch *) ] + with _ -> + Some + [ (* TODO(subtype-errors) Variant constructor tuple mismatch *) ] + else + Some + [ (* TODO(subtype-errors) Variant constructor tuple mismatch *) ] + | _ -> + Some [ (* TODO(subtype-errors) Variant other issue *) ]) + in + if field_subtype_violations = [] then cstrs + else (trace, t1, t2, !univar_pairs, None) :: cstrs) + | ( (p1, _, {type_kind = Type_record (fields1, repr1)}), + (p2, _, {type_kind = Type_record (fields2, repr2)}) ) -> + let same_repr = + match (repr1, repr2) with + | Record_regular, Record_regular -> + true (* handled in the fields checks *) + | Record_unboxed b1, Record_unboxed b2 -> b1 = b2 + | Record_inlined _, Record_inlined _ -> repr1 = repr2 + | Record_extension, Record_extension -> true + | _ -> false + in + if same_repr then + let violations, tl1, tl2 = + Record_coercion.check_record_fields fields1 fields2 + in + if violations <> [] then + ( trace, + t1, + t2, + !univar_pairs, + Some + (Record_fields_mismatch + { + left_record_name = p1; + right_record_name = p2; + issues = violations; + }) ) + :: cstrs + else subtype_list env trace tl1 tl2 cstrs + else + ( trace, + t1, + t2, + !univar_pairs, + None (* TODO(subtype-errors) Record representation *) ) + :: cstrs + | (p1, _, {type_kind = tk1}), (p2, _, {type_kind = tk2}) -> + ( trace, + t1, + t2, + !univar_pairs, + Some + (Different_type_kinds + { + left_typename = p1; + right_typename = p2; + left_type_kind = tk1; + right_type_kind = tk2; + }) ) + :: cstrs + | exception Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> + subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) + | Tobject (f1, _), Tobject (f2, _) + when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> + (* Same row variable implies same object. *) + (trace, t1, t2, !univar_pairs, None) :: cstrs + | Tobject (f1, _), Tobject (f2, _) -> subtype_fields env trace f1 f2 cstrs + | Tvariant row1, Tvariant row2 -> ( + try subtype_row env trace row1 row2 cstrs + with Exit -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | Tvariant {row_closed = true; row_fields}, Tconstr (_, [], _) + when extract_concrete_typedecl_opt env t2 + |> Variant_coercion.type_is_variant -> ( + (* TODO(subtype-errors) Polyvariant to variant *) + match extract_concrete_typedecl env t2 with + | _, _, {type_kind = Type_variant variant_constructors; type_attributes} + -> ( + match + Variant_coercion.can_coerce_polyvariant_to_variant ~row_fields + ~variant_constructors ~type_attributes + with + | Ok _ -> cstrs + | Error _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | Tvariant v, _ when !variant_is_subtype env (row_repr v) t2 -> cstrs + | Tpoly (u1, []), Tpoly (u2, []) -> subtype_rec env trace u1 u2 cstrs + | Tpoly (u1, tl1), Tpoly (u2, []) -> + let _, u1' = instance_poly false tl1 u1 in + subtype_rec env trace u1' u2 cstrs + | Tpoly (u1, tl1), Tpoly (u2, tl2) -> ( + try + enter_poly env univar_pairs u1 tl1 u2 tl2 (fun t1 t2 -> + subtype_rec env trace t1 t2 cstrs) + with Unify _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2) -> ( + try + let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1 + and ntl2 = + complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2 + ~allow_absent:true + in + let cstrs' = + List.map + (fun (n2, t2) -> + (trace, List.assoc n2 ntl1, t2, !univar_pairs, None)) + ntl2 + in + if eq_package_path env p1 p2 then cstrs' @ cstrs + else + (* need to check module subtyping *) + let snap = Btype.snapshot () in + try + List.iter (fun (_, t1, t2, _, _) -> unify env t1 t2) cstrs'; + if !package_subtype env p1 nl1 tl1 p2 nl2 tl2 then ( + Btype.backtrack snap; + cstrs' @ cstrs) + else raise (Unify []) + with Unify _ -> + Btype.backtrack snap; + raise Not_found + with Not_found -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + | _, _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs) + +and subtype_list env trace tl1 tl2 cstrs = + if List.length tl1 <> List.length tl2 then subtype_error env trace; + List.fold_left2 + (fun cstrs t1 t2 -> subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs) + cstrs tl1 tl2 + +and subtype_fields env trace ty1 ty2 cstrs = + (* Assume that either rest1 or rest2 is not Tvar *) + let fields1, rest1 = flatten_fields ty1 in + let fields2, rest2 = flatten_fields ty2 in + let pairs, miss1, miss2 = associate_fields fields1 fields2 in + let cstrs = + if rest2.desc = Tnil then cstrs + else if miss1 = [] then + subtype_rec env ((rest1, rest2) :: trace) rest1 rest2 cstrs + else + ( trace, + build_fields (repr ty1).level miss1 rest1, + rest2, + !univar_pairs, + None ) + :: cstrs + in + let cstrs = + if miss2 = [] then cstrs + else + ( trace, + rest1, + build_fields (repr ty2).level miss2 (newvar ()), + !univar_pairs, + None ) + :: cstrs + in + List.fold_left + (fun cstrs (_, _k1, t1, _k2, t2) -> + (* These fields are always present *) + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs) + cstrs pairs + +and subtype_row env trace row1 row2 cstrs = + let row1 = row_repr row1 and row2 = row_repr row2 in + let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let more1 = repr row1.row_more and more2 = repr row2.row_more in + match (more1.desc, more2.desc) with + | Tconstr (p1, _, _), Tconstr (p2, _, _) when Path.same p1 p2 -> + subtype_rec env ((more1, more2) :: trace) more1 more2 cstrs + | (Tvar _ | Tconstr _ | Tnil), (Tvar _ | Tconstr _ | Tnil) + when row1.row_closed && r1 = [] -> + List.fold_left + (fun cstrs (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | (Rpresent None | Reither (true, _, _, _)), Rpresent None -> cstrs + | Rpresent (Some t1), Rpresent (Some t2) -> + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + | Reither (false, t1 :: _, _, _), Rpresent (Some t2) -> + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + | Rabsent, _ -> cstrs + | _ -> raise Exit) + cstrs pairs + | Tunivar _, Tunivar _ + when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] -> + let cstrs = subtype_rec env ((more1, more2) :: trace) more1 more2 cstrs in + List.fold_left + (fun cstrs (_, f1, f2) -> + match (row_field_repr f1, row_field_repr f2) with + | Rpresent None, Rpresent None + | Reither (true, [], _, _), Reither (true, [], _, _) + | Rabsent, Rabsent -> + cstrs + | Rpresent (Some t1), Rpresent (Some t2) + | Reither (false, [t1], _, _), Reither (false, [t2], _, _) -> + subtype_rec env ((t1, t2) :: trace) t1 t2 cstrs + | _ -> raise Exit) + cstrs pairs + | _ -> raise Exit + +let subtype env ty1 ty2 = + TypePairs.clear subtypes; + univar_pairs := []; + (* Build constraint set. *) + let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in + TypePairs.clear subtypes; + (* Enforce constraints. *) + function + | () -> + List.iter + (function + | trace0, t1, t2, pairs, ctx -> ( + try unify_pairs (ref env) t1 t2 pairs + with Unify trace -> + raise + (Subtype + ( expand_trace env (List.rev trace0), + List.tl (List.tl trace), + ctx )))) + (List.rev cstrs) + +(*******************) +(* Miscellaneous *) +(*******************) + +(* Utility for printing. The resulting type is not used in computation. *) +let rec unalias_object ty = + let ty = repr ty in + match ty.desc with + | Tfield (s, k, t1, t2) -> + newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil -> newty2 ty.level ty.desc + | Tunivar _ -> ty + | Tconstr _ -> newvar2 ty.level + | _ -> assert false + +let unalias ty = + let ty = repr ty in + match ty.desc with + | Tvar _ | Tunivar _ -> ty + | Tvariant row -> + let row = row_repr row in + let more = row.row_more in + newty2 ty.level (Tvariant {row with row_more = newty2 more.level more.desc}) + | Tobject (ty, nm) -> newty2 ty.level (Tobject (unalias_object ty, nm)) + | _ -> newty2 ty.level ty.desc + +(* Return the arity (as for curried functions) of the given type. *) +let rec arity ty = + match (repr ty).desc with + | Tarrow (_, ret, _, _) -> 1 + arity ret + | _ -> 0 + +(* Check whether an abbreviation expands to itself. *) +let cyclic_abbrev env id ty = + let rec check_cycle seen ty = + let ty = repr ty in + match ty.desc with + | Tconstr (p, _tl, _abbrev) -> ( + (match p with + | Path.Pident p -> Ident.same p id + | _ -> false) + || List.memq ty seen + || + try check_cycle (ty :: seen) (expand_abbrev_opt env ty) with + | Cannot_expand -> false + | Unify _ -> true) + | _ -> false + in + check_cycle [] ty + +(* Check for non-generalizable type variables *) +exception Non_closed0 +let visited = ref TypeSet.empty + +let rec closed_schema_rec env ty = + let ty = repr ty in + if TypeSet.mem ty !visited then () + else ( + visited := TypeSet.add ty !visited; + match ty.desc with + | Tvar _ when ty.level <> generic_level -> raise Non_closed0 + | Tconstr _ -> ( + let old = !visited in + try iter_type_expr (closed_schema_rec env) ty + with Non_closed0 -> ( + try + visited := old; + closed_schema_rec env (try_expand_head try_expand_safe env ty) + with Cannot_expand -> raise Non_closed0)) + | Tfield (_, kind, t1, t2) -> + if field_kind_repr kind = Fpresent then closed_schema_rec env t1; + closed_schema_rec env t2 + | Tvariant row -> + let row = row_repr row in + iter_row (closed_schema_rec env) row; + if not (static_row row) then closed_schema_rec env row.row_more + | _ -> iter_type_expr (closed_schema_rec env) ty) + +(* Return whether all variables of type [ty] are generic. *) +let closed_schema env ty = + visited := TypeSet.empty; + try + closed_schema_rec env ty; + visited := TypeSet.empty; + true + with Non_closed0 -> + visited := TypeSet.empty; + false + +(* Normalize a type before printing, saving... *) +(* Cannot use mark_type because deep_occur uses it too *) +let rec normalize_type_rec env visited ty = + let ty = repr ty in + if not (TypeSet.mem ty !visited) then ( + visited := TypeSet.add ty !visited; + let tm = row_of_type ty in + (if (not (is_Tconstr ty)) && is_constr_row ~allow_ident:false tm then + match tm.desc with + (* PR#7348 *) + | Tconstr (Path.Pdot (m, i, pos), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + log_type ty; + ty.desc <- Tconstr (Path.Pdot (m, i', pos), tl, ref Mnil) + | _ -> assert false + else + match ty.desc with + | Tvariant row -> + let row = row_repr row in + let fields = + List.map + (fun (l, f0) -> + let f = row_field_repr f0 in + ( l, + match f with + | Reither (b, ty :: (_ :: _ as tyl), m, e) -> + let tyl' = + List.fold_left + (fun tyl ty -> + if + List.exists + (fun ty' -> equal env false [ty] [ty']) + tyl + then tyl + else ty :: tyl) + [ty] tyl + in + if f != f0 || List.length tyl' < List.length tyl then + Reither (b, List.rev tyl', m, e) + else f + | _ -> f )) + row.row_fields + in + let fields = + List.sort + (fun (p, _) (q, _) -> compare p q) + (Ext_list.filter fields (fun (_, fi) -> fi <> Rabsent)) + in + log_type ty; + ty.desc <- Tvariant {row with row_fields = fields} + | Tobject (fi, nm) -> + (match !nm with + | None -> () + | Some (n, v :: l) -> ( + if deep_occur ty (newgenty (Ttuple l)) then + (* The abbreviation may be hiding something, so remove it *) + set_name nm None + else + let v' = repr v in + match v'.desc with + | Tvar _ | Tunivar _ -> + if v' != v then set_name nm (Some (n, v' :: l)) + | Tnil -> + log_type ty; + ty.desc <- Tconstr (n, l, ref Mnil) + | _ -> set_name nm None) + | _ -> fatal_error "Ctype.normalize_type_rec"); + let fi = repr fi in + if fi.level < lowest_level then () + else + let fields, row = flatten_fields fi in + let fi' = build_fields fi.level fields row in + log_type ty; + fi.desc <- fi'.desc + | _ -> ()); + iter_type_expr (normalize_type_rec env visited) ty) + +let normalize_type env ty = normalize_type_rec env (ref TypeSet.empty) ty + +(*************************) +(* Remove dependencies *) +(*************************) + +(* + Variables are left unchanged. Other type nodes are duplicated, with + levels set to generic level. + We cannot use Tsubst here, because unification may be called by + expand_abbrev. +*) + +let nondep_hash = TypeHash.create 47 +let nondep_variants = TypeHash.create 17 +let clear_hash () = + TypeHash.clear nondep_hash; + TypeHash.clear nondep_variants + +let rec nondep_type_rec env id ty = + match ty.desc with + | Tvar _ | Tunivar _ -> ty + | Tlink ty -> nondep_type_rec env id ty + | _ -> ( + try TypeHash.find nondep_hash ty + with Not_found -> + let ty' = newgenvar () in + (* Stub *) + TypeHash.add nondep_hash ty ty'; + ty'.desc <- + (match ty.desc with + | Tconstr (p, tl, _abbrev) -> + if Path.isfree id p then + try + Tlink + (nondep_type_rec env id + (expand_abbrev env (newty2 ty.level ty.desc))) + (* + The [Tlink] is important. The expanded type may be a + variable, or may not be completely copied yet + (recursive type), so one cannot just take its + description. + *) + with Cannot_expand | Unify _ -> raise Not_found + else Tconstr (p, List.map (nondep_type_rec env id) tl, ref Mnil) + | Tpackage (p, nl, tl) when Path.isfree id p -> + let p' = normalize_package_path env p in + if Path.isfree id p' then raise Not_found; + Tpackage (p', nl, List.map (nondep_type_rec env id) tl) + | Tobject (t1, name) -> + Tobject + ( nondep_type_rec env id t1, + ref + (match !name with + | None -> None + | Some (p, tl) -> + if Path.isfree id p then None + else Some (p, List.map (nondep_type_rec env id) tl)) ) + | Tvariant row -> ( + let row = row_repr row in + let more = repr row.row_more in + (* We must keep sharing according to the row variable *) + try + let ty2 = TypeHash.find nondep_variants more in + (* This variant type has been already copied *) + TypeHash.add nondep_hash ty ty2; + Tlink ty2 + with Not_found -> ( + (* Register new type first for recursion *) + TypeHash.add nondep_variants more ty'; + let static = static_row row in + let more' = if static then newgenty Tnil else more in + (* Return a new copy *) + let row = copy_row (nondep_type_rec env id) true row true more' in + match row.row_name with + | Some (p, _tl) when Path.isfree id p -> + Tvariant {row with row_name = None} + | _ -> Tvariant row)) + | _ -> copy_type_desc (nondep_type_rec env id) ty.desc); + ty') + +let nondep_type env id ty = + try + let ty' = nondep_type_rec env id ty in + clear_hash (); + ty' + with Not_found -> + clear_hash (); + raise Not_found + +let () = nondep_type' := nondep_type + +let unroll_abbrev id tl ty = + let ty = repr ty and path = Path.Pident id in + if is_Tvar ty || List.exists (deep_occur ty) tl || is_object_type path then ty + else + let ty' = newty2 ty.level ty.desc in + link_type ty (newty2 ty.level (Tconstr (path, tl, ref Mnil))); + ty' + +(* Preserve sharing inside type declarations. *) +let nondep_type_decl env mid id is_covariant decl = + try + let params = List.map (nondep_type_rec env mid) decl.type_params in + let tk = + try map_kind (nondep_type_rec env mid) decl.type_kind + with Not_found when is_covariant -> Type_abstract + and tm = + try + match decl.type_manifest with + | None -> None + | Some ty -> Some (unroll_abbrev id params (nondep_type_rec env mid ty)) + with Not_found when is_covariant -> None + in + clear_hash (); + let priv = + match tm with + | Some ty when Btype.has_constr_row ty -> Private + | _ -> decl.type_private + in + { + type_params = params; + type_arity = decl.type_arity; + type_kind = tk; + type_manifest = tm; + type_private = priv; + type_variance = decl.type_variance; + type_newtype_level = None; + type_loc = decl.type_loc; + type_attributes = decl.type_attributes; + type_immediate = decl.type_immediate; + type_unboxed = decl.type_unboxed; + type_inlined_types = decl.type_inlined_types; + } + with Not_found -> + clear_hash (); + raise Not_found + +(* Preserve sharing inside extension constructors. *) +let nondep_extension_constructor env mid ext = + try + let type_path, type_params = + if Path.isfree mid ext.ext_type_path then + let ty = + newgenty (Tconstr (ext.ext_type_path, ext.ext_type_params, ref Mnil)) + in + let ty' = nondep_type_rec env mid ty in + match (repr ty').desc with + | Tconstr (p, tl, _) -> (p, tl) + | _ -> raise Not_found + else + let type_params = + List.map (nondep_type_rec env mid) ext.ext_type_params + in + (ext.ext_type_path, type_params) + in + let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in + let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in + clear_hash (); + { + ext_type_path = type_path; + ext_type_params = type_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = ext.ext_private; + ext_attributes = ext.ext_attributes; + ext_loc = ext.ext_loc; + ext_is_exception = ext.ext_is_exception; + } + with Not_found -> + clear_hash (); + raise Not_found + +(* collapse conjunctive types in class parameters *) +let rec collapse_conj env visited ty = + let ty = repr ty in + if List.memq ty visited then () + else + let visited = ty :: visited in + match ty.desc with + | Tvariant row -> + let row = row_repr row in + List.iter + (fun (_l, fi) -> + match row_field_repr fi with + | Reither (c, t1 :: (_ :: _ as tl), m, e) -> + List.iter (unify env t1) tl; + set_row_field e (Reither (c, [t1], m, ref None)) + | _ -> ()) + row.row_fields; + iter_row (collapse_conj env visited) row + | _ -> iter_type_expr (collapse_conj env visited) ty + +let collapse_conj_params env params = List.iter (collapse_conj env []) params + +let same_constr env t1 t2 = + let t1 = expand_head env t1 in + let t2 = expand_head env t2 in + match (t1.desc, t2.desc) with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 + | _ -> false + +let () = Env.same_constr := same_constr + +let maybe_pointer_type env typ = + match (repr typ).desc with + | Tconstr (p, _args, _abbrev) -> ( + try + let type_decl = Env.find_type p env in + not type_decl.type_immediate + with Not_found -> + true + (* This can happen due to e.g. missing -I options, + causing some .cmi files to be unavailable. + Maybe we should emit a warning. *) + ) + | Tvariant row -> + let row = Btype.row_repr row in + (* if all labels are devoid of arguments, not a pointer *) + (not row.row_closed) + || List.exists + (function + | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true + | _ -> false) + row.row_fields + | _ -> true + +let get_arity env typ = + match (expand_head env typ).desc with + | Tarrow (_, _, _, arity) -> arity + | _ -> None diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli new file mode 100644 index 0000000..6785374 --- /dev/null +++ b/compiler/ml/ctype.mli @@ -0,0 +1,363 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Operations on core types *) + +open Asttypes +open Types + +type subtype_context = + | Generic of {errorCode: string} + (** A generic subtype error, intended to be extended to be handled later. *) + | Coercion_target_variant_not_unboxed of { + variant_name: Path.t; + primitive: Path.t; + } (** Coercing a primitive to a variant that is not unboxed. *) + | Coercion_target_variant_does_not_cover_type of { + variant_name: Path.t; + primitive: Path.t; + } + (** Coercing a primitive to a variant that does not have a catch-all case. *) + | Variant_constructor_runtime_representation_mismatch of { + variant_name: Path.t; + issues: Variant_coercion.variant_runtime_representation_issue list; + } + (** A variant constructor's runtime representation does not match the target variant. *) + | Variant_configurations_mismatch of { + left_variant_name: Path.t; + right_variant_name: Path.t; + issue: Variant_coercion.variant_configuration_issue; + } (** Variants are configured differently. *) + | Different_type_kinds of { + left_typename: Path.t; + right_typename: Path.t; + left_type_kind: type_kind; + right_type_kind: type_kind; + } (** The types are of different kinds. *) + | Record_fields_mismatch of { + left_record_name: Path.t; + right_record_name: Path.t; + issues: Record_coercion.record_field_subtype_violation list; + } (** Records have fields that are not compatible. *) + +type type_pairs = (type_expr * type_expr) list +exception Unify of type_pairs +exception Tags of label * label +exception Subtype of type_pairs * type_pairs * subtype_context option +exception Cannot_expand +exception Cannot_apply +exception Recursive_abbrev +exception Unification_recursive_abbrev of type_pairs + +val init_def : int -> unit +(* Set the initial variable level *) + +val begin_def : unit -> unit +(* Raise the variable level by one at the beginning of a definition. *) + +val end_def : unit -> unit +(* Lower the variable level by one at the end of a definition *) + +val begin_class_def : unit -> unit +val raise_nongen_level : unit -> unit +val reset_global_level : unit -> unit +(* Reset the global level before typing an expression *) + +val increase_global_level : unit -> int +val restore_global_level : int -> unit +(* This pair of functions is only used in Typetexp *) + +type levels = { + current_level: int; + nongen_level: int; + global_level: int; + saved_level: (int * int) list; +} +val save_levels : unit -> levels +val set_levels : levels -> unit + +val newty : type_desc -> type_expr +val newvar : ?name:string -> unit -> type_expr +val newvar2 : ?name:string -> int -> type_expr +(* Return a fresh variable *) + +val new_global_var : ?name:string -> unit -> type_expr +(* Return a fresh variable, bound at toplevel + (as type variables ['a] in type constraints). *) + +val newobj : type_expr -> type_expr +val newconstr : Path.t -> type_expr list -> type_expr +val none : type_expr +(* A dummy type expression *) + +val repr : type_expr -> type_expr +(* Return the canonical representative of a type. *) + +val object_fields : type_expr -> type_expr +val flatten_fields : + type_expr -> (string * field_kind * type_expr) list * type_expr + +(* Transform a field type into a list of pairs label-type *) +(* The fields are sorted *) +val associate_fields : + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr) list -> + (string * field_kind * type_expr * field_kind * type_expr) list + * (string * field_kind * type_expr) list + * (string * field_kind * type_expr) list +val opened_object : type_expr -> bool +val close_object : type_expr -> unit +val row_variable : type_expr -> type_expr +(* Return the row variable of an open object type *) + +val set_object_name : + Ident.t -> type_expr -> type_expr list -> type_expr -> unit +val remove_object_name : type_expr -> unit +val hide_private_methods : type_expr -> unit +val find_cltype_for_path : Env.t -> Path.t -> type_declaration * type_expr +val lid_of_path : ?hash:string -> Path.t -> Longident.t + +val sort_row_fields : (label * row_field) list -> (label * row_field) list +val merge_row_fields : + (label * row_field) list -> + (label * row_field) list -> + (label * row_field) list + * (label * row_field) list + * (label * row_field * row_field) list +val filter_row_fields : + bool -> (label * row_field) list -> (label * row_field) list + +val generalize : type_expr -> unit +(* Generalize in-place the given type *) + +val generalize_expansive : Env.t -> type_expr -> unit +(* Generalize the covariant part of a type, making + contravariant branches non-generalizable *) + +val generalize_global : type_expr -> unit +(* Generalize the structure of a type, lowering variables + to !global_level *) + +val generalize_structure : type_expr -> unit +(* Same, but variables are only lowered to !current_level *) + +val correct_levels : type_expr -> type_expr +(* Returns a copy with decreasing levels *) + +val limited_generalize : type_expr -> type_expr -> unit +(* Only generalize some part of the type + Make the remaining of the type non-generalizable *) + +val instance : ?partial:bool -> Env.t -> type_expr -> type_expr + +(* Take an instance of a type scheme *) +(* partial=None -> normal + partial=false -> newvar() for non generic subterms + partial=true -> newty2 ty.level Tvar for non generic subterms *) +val instance_def : type_expr -> type_expr +(* use defaults *) + +val generic_instance : Env.t -> type_expr -> type_expr +(* Same as instance, but new nodes at generic_level *) + +val instance_list : Env.t -> type_expr list -> type_expr list +(* Take an instance of a list of type schemes *) + +val instance_constructor : + ?in_pattern:Env.t ref * int -> + constructor_description -> + type_expr list * type_expr +(* Same, for a constructor *) + +val instance_parameterized_type : + ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr +val instance_parameterized_type_2 : + type_expr list -> + type_expr list -> + type_expr -> + type_expr list * type_expr list * type_expr +val instance_declaration : type_declaration -> type_declaration +val instance_poly : + ?keep_names:bool -> + bool -> + type_expr list -> + type_expr -> + type_expr list * type_expr +(* Take an instance of a type scheme containing free univars *) + +val instance_label : + bool -> label_description -> type_expr list * type_expr * type_expr +(* Same, for a label *) + +val apply : Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr +(* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to + the parameters [pi] and returns the corresponding instance of + [t]. Exception [Cannot_apply] is raised in case of failure. *) + +val expand_head_once : Env.t -> type_expr -> type_expr +val expand_head : Env.t -> type_expr -> type_expr +val try_expand_once_opt : Env.t -> type_expr -> type_expr + +val expand_head_opt : Env.t -> type_expr -> type_expr +(** The compiler's own version of [expand_head] necessary for type-based + optimisations. *) + +val full_expand : Env.t -> type_expr -> type_expr +val extract_concrete_typedecl : + Env.t -> type_expr -> Path.t * Path.t * type_declaration +(* Return the original path of the types, and the first concrete + type declaration found expanding it. + Raise [Not_found] if none appears or not a type constructor. *) + +val enforce_constraints : Env.t -> type_expr -> unit + +val unify : Env.t -> type_expr -> type_expr -> unit +(* Unify the two types given. Raise [Unify] if not possible. *) + +val unify_gadt : + newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit +(* Unify the two types given and update the environment with the + local constraints. Raise [Unify] if not possible. *) + +val unify_var : Env.t -> type_expr -> type_expr -> unit +(* Same as [unify], but allow free univars when first type + is a variable. *) + +val with_passive_variants : ('a -> 'b) -> 'a -> 'b +(* Call [f] in passive_variants mode, for exhaustiveness check. *) + +val filter_arrow : + env:Env.t -> arity:arity -> type_expr -> arg_label -> type_expr * type_expr +(* A special case of unification (with l:'a -> 'b). *) + +val filter_method : Env.t -> string -> private_flag -> type_expr -> type_expr +(* A special case of unification (with {m : 'a; 'b}). *) + +val check_filter_method : Env.t -> string -> private_flag -> type_expr -> unit +(* A special case of unification (with {m : 'a; 'b}), returning unit. *) + +val occur_in : Env.t -> type_expr -> type_expr -> bool +val deep_occur : type_expr -> type_expr -> bool +val filter_self_method : + Env.t -> + string -> + private_flag -> + (Ident.t * type_expr) Meths.t ref -> + type_expr -> + Ident.t * type_expr +val moregeneral : Env.t -> bool -> type_expr -> type_expr -> bool +(* Check if the first type scheme is more general than the second. *) + +val rigidify : type_expr -> type_expr list +(* "Rigidify" a type and return its type variable *) + +val all_distinct_vars : Env.t -> type_expr list -> bool +(* Check those types are all distinct type variables *) + +val matches : Env.t -> type_expr -> type_expr -> bool +(* Same as [moregeneral false], implemented using the two above + functions and backtracking. Ignore levels *) + +type class_match_failure = + | CM_Virtual_class + | CM_Parameter_arity_mismatch of int * int + | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list + | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list + | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list + | CM_Non_mutable_value of string + | CM_Non_concrete_value of string + | CM_Missing_value of string + | CM_Missing_method of string + | CM_Hide_public of string + | CM_Hide_virtual of string * string + | CM_Public_method of string + | CM_Private_method of string + | CM_Virtual_method of string +val equal : Env.t -> bool -> type_expr list -> type_expr list -> bool +(* [equal env [x1...xn] tau [y1...yn] sigma] + checks whether the parameterized types + [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) + +val enlarge_type : Env.t -> type_expr -> type_expr * bool +(* Make a type larger, flag is true if some pruning had to be done *) + +val subtype : Env.t -> type_expr -> type_expr -> unit -> unit +(* [subtype env t1 t2] checks that [t1] is a subtype of [t2]. + It accumulates the constraints the type variables must + enforce and returns a function that enforces this + constraints. *) + +val nondep_type : Env.t -> Ident.t -> type_expr -> type_expr +(* Return a type equivalent to the given type but without + references to the given module identifier. Raise [Not_found] + if no such type exists. *) + +val nondep_type_decl : + Env.t -> Ident.t -> Ident.t -> bool -> type_declaration -> type_declaration +(* Same for type declarations. *) + +val nondep_extension_constructor : + Env.t -> Ident.t -> extension_constructor -> extension_constructor + +(* Same for extension constructor *) +(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) +val cyclic_abbrev : Env.t -> Ident.t -> type_expr -> bool +val is_contractive : Env.t -> Path.t -> bool +val normalize_type : Env.t -> type_expr -> unit + +val closed_schema : Env.t -> type_expr -> bool +(* Check whether the given type scheme contains no non-generic + type variables *) + +val free_variables : ?env:Env.t -> type_expr -> type_expr list +(* If env present, then check for incomplete definitions too *) + +val closed_type_decl : type_declaration -> type_expr option +val closed_extension_constructor : extension_constructor -> type_expr option +type closed_class_failure = + | CC_Method of type_expr * bool * string * type_expr + | CC_Value of type_expr * bool * string * type_expr + +val unalias : type_expr -> type_expr +val arity : type_expr -> int +(* Return the arity (as for curried functions) of the given type. *) + +val collapse_conj_params : Env.t -> type_expr list -> unit +(* Collapse conjunctive types in class parameters *) + +val get_current_level : unit -> int +val wrap_trace_gadt_instances : Env.t -> ('a -> 'b) -> 'a -> 'b +val reset_reified_var_counter : unit -> unit + +val maybe_pointer_type : Env.t -> type_expr -> bool +(* True if type is possibly pointer, false if definitely not a pointer *) + +(* Stubs *) +val package_subtype : + (Env.t -> + Path.t -> + Longident.t list -> + type_expr list -> + Path.t -> + Longident.t list -> + type_expr list -> + bool) + ref + +val variant_is_subtype : + (Env.t -> Types.row_desc -> Types.type_expr -> bool) ref + +val get_arity : Env.t -> type_expr -> int option diff --git a/compiler/ml/datarepr.ml b/compiler/ml/datarepr.ml new file mode 100644 index 0000000..df16f61 --- /dev/null +++ b/compiler/ml/datarepr.ml @@ -0,0 +1,298 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Compute constructor and label descriptions from type declarations, + determining their representation. *) + +open Asttypes +open Types +open Btype + +(* Simplified version of Ctype.free_vars *) +let free_vars ?(param = false) ty = + let ret = ref TypeSet.empty in + let rec loop ty = + let ty = repr ty in + if ty.level >= lowest_level then ( + ty.level <- pivot_level - ty.level; + match ty.desc with + | Tvar _ -> ret := TypeSet.add ty !ret + | Tvariant row -> ( + let row = row_repr row in + iter_row loop row; + if not (static_row row) then + match row.row_more.desc with + | Tvar _ when param -> ret := TypeSet.add ty !ret + | _ -> loop row.row_more) + (* XXX: What about Tobject ? *) + | _ -> iter_type_expr loop ty) + in + loop ty; + unmark_type ty; + !ret + +let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) + +let constructor_existentials cd_args cd_res = + let tyl = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record l -> List.map (fun l -> l.ld_type) l + in + let existentials = + match cd_res with + | None -> [] + | Some type_ret -> + let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in + let res_vars = free_vars type_ret in + TypeSet.elements (TypeSet.diff arg_vars_set res_vars) + in + (tyl, existentials) + +let constructor_args priv cd_args cd_res path rep = + let tyl, existentials = constructor_existentials cd_args cd_res in + match cd_args with + | Cstr_tuple l -> (existentials, l, None) + | Cstr_record lbls -> + let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in + let type_params = TypeSet.elements arg_vars_set in + let type_unboxed = + match rep with + | Record_unboxed _ -> unboxed_true_default_false + | _ -> unboxed_false_default_false + in + let tdecl = + { + type_params; + type_arity = List.length type_params; + type_kind = Type_record (lbls, rep); + type_private = priv; + type_manifest = None; + type_variance = List.map (fun _ -> Variance.full) type_params; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_unboxed; + type_inlined_types = []; + } + in + (existentials, [newgenconstr path type_params], Some tdecl) + +let internal_optional = "internal.optional" + +let optional_shape : Parsetree.attribute = + ({txt = internal_optional; loc = Location.none}, Parsetree.PStr []) + +let constructor_has_optional_shape + ({cstr_attributes = attrs} : constructor_description) = + List.exists (fun (x, _) -> x.txt = internal_optional) attrs + +let constructor_descrs ty_path decl cstrs = + let ty_res = newgenconstr ty_path decl.type_params in + let num_consts = ref 0 and num_nonconsts = ref 0 in + List.iter + (fun {cd_args; _} -> + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) + cstrs; + let rec describe_constructors idx_const idx_nonconst = function + | [] -> [] + | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> + let ty_res = + match cd_res with + | Some ty_res' -> ty_res' + | None -> ty_res + in + let tag, descr_rem = + match cd_args with + | _ when decl.type_unboxed.unboxed -> + assert (rem = []); + (Cstr_unboxed, []) + | Cstr_tuple [] -> + ( Cstr_constant idx_const, + describe_constructors (idx_const + 1) idx_nonconst rem ) + | _ -> + ( Cstr_block idx_nonconst, + describe_constructors idx_const (idx_nonconst + 1) rem ) + in + let cstr_name = Ident.name cd_id in + let existentials, cstr_args, cstr_inlined = + let representation = + if decl.type_unboxed.unboxed then Record_unboxed true + else + Record_inlined + { + tag = idx_nonconst; + name = cstr_name; + num_nonconsts = !num_nonconsts; + attrs = cd_attributes; + } + in + constructor_args decl.type_private cd_args cd_res + (Path.Pdot (ty_path, cstr_name, Path.nopos)) + representation + in + let cstr = + { + cstr_name; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = tag; + cstr_consts = !num_consts; + cstr_nonconsts = !num_nonconsts; + cstr_private = decl.type_private; + cstr_generalized = cd_res <> None; + cstr_loc = cd_loc; + cstr_attributes = cd_attributes; + cstr_inlined; + } + in + (cd_id, cstr) :: descr_rem + in + let result = describe_constructors 0 0 cstrs in + match result with + | [ + (({Ident.name = "None"} as a_id), ({cstr_args = []} as a_descr)); + (({Ident.name = "Some"} as b_id), ({cstr_args = [_]} as b_descr)); + ] + | [ + (({Ident.name = "Some"} as a_id), ({cstr_args = [_]} as a_descr)); + (({Ident.name = "None"} as b_id), ({cstr_args = []} as b_descr)); + ] -> + [ + ( a_id, + { + a_descr with + cstr_attributes = optional_shape :: a_descr.cstr_attributes; + } ); + ( b_id, + { + b_descr with + cstr_attributes = optional_shape :: b_descr.cstr_attributes; + } ); + ] + | _ -> result + +let extension_descr path_ext ext = + let ty_res = + match ext.ext_ret_type with + | Some type_ret -> type_ret + | None -> newgenconstr ext.ext_type_path ext.ext_type_params + in + let existentials, cstr_args, cstr_inlined = + constructor_args ext.ext_private ext.ext_args ext.ext_ret_type path_ext + Record_extension + in + { + cstr_name = Path.last path_ext; + cstr_res = ty_res; + cstr_existentials = existentials; + cstr_args; + cstr_arity = List.length cstr_args; + cstr_tag = Cstr_extension path_ext; + cstr_consts = -1; + cstr_nonconsts = -1; + cstr_private = ext.ext_private; + cstr_generalized = ext.ext_ret_type <> None; + cstr_loc = ext.ext_loc; + cstr_attributes = ext.ext_attributes; + cstr_inlined; + } + +let none = {desc = Ttuple []; level = -1; id = -1} +(* Clearly ill-formed type *) + +let dummy_label = + { + lbl_name = ""; + lbl_res = none; + lbl_arg = none; + lbl_mut = Immutable; + lbl_optional = false; + lbl_pos = -1; + lbl_all = [||]; + lbl_repres = Record_regular; + lbl_private = Public; + lbl_loc = Location.none; + lbl_attributes = []; + } + +let label_descrs ty_res lbls repres priv = + let all_labels = Array.make (List.length lbls) dummy_label in + let rec describe_labels num = function + | [] -> [] + | l :: rest -> + let lbl = + { + lbl_name = Ident.name l.ld_id; + lbl_res = ty_res; + lbl_arg = l.ld_type; + lbl_mut = l.ld_mutable; + lbl_optional = l.ld_optional; + lbl_pos = num; + lbl_all = all_labels; + lbl_repres = repres; + lbl_private = priv; + lbl_loc = l.ld_loc; + lbl_attributes = l.ld_attributes; + } + in + all_labels.(num) <- lbl; + (l.ld_id, lbl) :: describe_labels (num + 1) rest + in + describe_labels 0 lbls + +exception Constr_not_found + +let rec find_constr tag num_const num_nonconst = function + | [] -> raise Constr_not_found + | ({cd_args = Cstr_tuple []; _} as c) :: rem -> + if Types.equal_tag tag (Cstr_constant num_const) then c + else find_constr tag (num_const + 1) num_nonconst rem + | c :: rem -> + if Types.equal_tag tag (Cstr_block num_nonconst) || tag = Cstr_unboxed then + c + else find_constr tag num_const (num_nonconst + 1) rem + +let find_constr_by_tag tag cstrlist = find_constr tag 0 0 cstrlist + +let constructors_of_type ty_path decl = + match decl.type_kind with + | Type_variant cstrs -> constructor_descrs ty_path decl cstrs + | Type_record _ | Type_abstract | Type_open -> [] + +let labels_of_type ty_path decl = + match decl.type_kind with + | Type_record (labels, rep) -> + label_descrs + (newgenconstr ty_path decl.type_params) + labels rep decl.type_private + | Type_variant _ | Type_abstract | Type_open -> [] + +(* Set row_name in Env, cf. GPR#1204/1329 *) +let set_row_name decl path = + match decl.type_manifest with + | None -> () + | Some ty -> ( + let ty = repr ty in + match ty.desc with + | Tvariant row when static_row row -> + let row = + {(row_repr row) with row_name = Some (path, decl.type_params)} + in + ty.desc <- Tvariant row + | _ -> ()) diff --git a/compiler/ml/datarepr.mli b/compiler/ml/datarepr.mli new file mode 100644 index 0000000..47113d8 --- /dev/null +++ b/compiler/ml/datarepr.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Compute constructor and label descriptions from type declarations, + determining their representation. *) + +open Types + +val constructor_has_optional_shape : Types.constructor_description -> bool + +val extension_descr : Path.t -> extension_constructor -> constructor_description + +val labels_of_type : + Path.t -> type_declaration -> (Ident.t * label_description) list +val constructors_of_type : + Path.t -> type_declaration -> (Ident.t * constructor_description) list + +exception Constr_not_found + +val find_constr_by_tag : + constructor_tag -> constructor_declaration list -> constructor_declaration + +val constructor_existentials : + constructor_arguments -> type_expr option -> type_expr list * type_expr list +(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and + returns: + - the types of the constructor's arguments + - the existential variables introduced by the constructor + *) + +(* Set the polymorphic variant row_name field *) +val set_row_name : type_declaration -> Path.t -> unit diff --git a/jscomp/ml/delayed_checks.ml b/compiler/ml/delayed_checks.ml similarity index 83% rename from jscomp/ml/delayed_checks.ml rename to compiler/ml/delayed_checks.ml index 029831a..631425c 100644 --- a/jscomp/ml/delayed_checks.ml +++ b/compiler/ml/delayed_checks.ml @@ -8,8 +8,10 @@ let force_delayed_checks () = let snap = Btype.snapshot () in let w_old = Warnings.backup () in List.iter - (fun (f, w) -> Warnings.restore w; f ()) + (fun (f, w) -> + Warnings.restore w; + f ()) (List.rev !delayed_checks); Warnings.restore w_old; reset_delayed_checks (); - Btype.backtrack snap \ No newline at end of file + Btype.backtrack snap diff --git a/jscomp/ml/delayed_checks.mli b/compiler/ml/delayed_checks.mli similarity index 97% rename from jscomp/ml/delayed_checks.mli rename to compiler/ml/delayed_checks.mli index df0a346..ac83a67 100644 --- a/jscomp/ml/delayed_checks.mli +++ b/compiler/ml/delayed_checks.mli @@ -1,6 +1,3 @@ - - - val reset_delayed_checks : unit -> unit val add_delayed_check : (unit -> unit) -> unit val force_delayed_checks : unit -> unit diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml new file mode 100644 index 0000000..e5e39eb --- /dev/null +++ b/compiler/ml/depend.ml @@ -0,0 +1,517 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Location +open Longident +open Parsetree + +let pp_deps = ref [] + +module StringSet = Set.Make (struct + type t = string + let compare = compare +end) +module StringMap = Map.Make (String) + +(* Module resolution map *) +(* Node (set of imports for this path, map for submodules) *) +type map_tree = Node of StringSet.t * bound_map +and bound_map = map_tree StringMap.t +let bound = Node (StringSet.empty, StringMap.empty) + +(*let get_free (Node (s, _m)) = s*) +let get_map (Node (_s, m)) = m +let make_leaf s = Node (StringSet.singleton s, StringMap.empty) +let make_node m = Node (StringSet.empty, m) +let rec weaken_map s (Node (s0, m0)) = + Node (StringSet.union s s0, StringMap.map (weaken_map s) m0) +let rec collect_free (Node (s, m)) = + StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s + +(* Returns the imports required to access the structure at path p *) +(* Only raises Not_found if the head of p is not in the toplevel map *) +let rec lookup_free p m = + match p with + | [] -> raise Not_found + | s :: p -> ( + let (Node (f, m')) = StringMap.find s m in + try lookup_free p m' with Not_found -> f) + +(* Returns the node corresponding to the structure at path p *) +let rec lookup_map lid m = + match lid with + | Lident s -> StringMap.find s m + | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m)) + | Lapply _ -> raise Not_found + +(* Collect free module identifiers in the a.s.t. *) + +let free_structure_names = ref StringSet.empty + +let add_names s = + free_structure_names := StringSet.union s !free_structure_names + +let rec add_path bv ?(p = []) = function + | Lident s -> + let free = + try lookup_free (s :: p) bv with Not_found -> StringSet.singleton s + in + (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free; + prerr_endline "";*) + add_names free + | Ldot (l, s) -> add_path bv ~p:(s :: p) l + | Lapply (l1, l2) -> + add_path bv l1; + add_path bv l2 + +let open_module bv lid = + match lookup_map lid bv with + | Node (s, m) -> + add_names s; + StringMap.fold StringMap.add m bv + | exception Not_found -> + add_path bv lid; + bv + +let add_parent bv lid = + match lid.txt with + | Ldot (l, _s) -> add_path bv l + | _ -> () + +let add = add_parent + +let addmodule bv lid = add_path bv lid.txt + +let handle_extension ext = + match (fst ext).txt with + | "error" | "ocaml.error" -> + raise (Location.Error (Builtin_attributes.error_of_extension ext)) + | _ -> () + +let rec add_type bv ty = + match ty.ptyp_desc with + | Ptyp_any -> () + | Ptyp_var _ -> () + | Ptyp_arrow {arg; ret} -> + add_type bv arg.typ; + add_type bv ret + | Ptyp_tuple tl -> List.iter (add_type bv) tl + | Ptyp_constr (c, tl) -> + add bv c; + List.iter (add_type bv) tl + | Ptyp_object (fl, _) -> + List.iter + (function + | Otag (_, _, t) -> add_type bv t + | Oinherit t -> add_type bv t) + fl + | Ptyp_alias (t, _) -> add_type bv t + | Ptyp_variant (fl, _, _) -> + List.iter + (function + | Rtag (_, _, _, stl) -> List.iter (add_type bv) stl + | Rinherit sty -> add_type bv sty) + fl + | Ptyp_poly (_, t) -> add_type bv t + | Ptyp_package pt -> add_package_type bv pt + | Ptyp_extension e -> handle_extension e + +and add_package_type bv (lid, l) = + add bv lid; + List.iter (add_type bv) (List.map (fun (_, e) -> e) l) + +let add_opt add_fn bv = function + | None -> () + | Some x -> add_fn bv x + +let add_constructor_arguments bv = function + | Pcstr_tuple l -> List.iter (add_type bv) l + | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l + +let add_constructor_decl bv pcd = + add_constructor_arguments bv pcd.pcd_args; + Misc.may (add_type bv) pcd.pcd_res + +let add_type_declaration bv td = + List.iter + (fun (ty1, ty2, _) -> + add_type bv ty1; + add_type bv ty2) + td.ptype_cstrs; + add_opt add_type bv td.ptype_manifest; + let add_tkind = function + | Ptype_abstract -> () + | Ptype_variant cstrs -> List.iter (add_constructor_decl bv) cstrs + | Ptype_record lbls -> List.iter (fun pld -> add_type bv pld.pld_type) lbls + | Ptype_open -> () + in + add_tkind td.ptype_kind + +let add_extension_constructor bv ext = + match ext.pext_kind with + | Pext_decl (args, rty) -> + add_constructor_arguments bv args; + Misc.may (add_type bv) rty + | Pext_rebind lid -> add bv lid + +let add_type_extension bv te = + add bv te.ptyext_path; + List.iter (add_extension_constructor bv) te.ptyext_constructors + +let pattern_bv = ref StringMap.empty + +let rec add_pattern bv pat = + match pat.ppat_desc with + | Ppat_any -> () + | Ppat_var _ -> () + | Ppat_alias (p, _) -> add_pattern bv p + | Ppat_interval _ | Ppat_constant _ -> () + | Ppat_tuple pl -> List.iter (add_pattern bv) pl + | Ppat_construct (c, op) -> + add bv c; + add_opt add_pattern bv op + | Ppat_record (pl, _) -> + List.iter + (fun {lid = lbl; x = p} -> + add bv lbl; + add_pattern bv p) + pl + | Ppat_array pl -> List.iter (add_pattern bv) pl + | Ppat_or (p1, p2) -> + add_pattern bv p1; + add_pattern bv p2 + | Ppat_constraint (p, ty) -> + add_pattern bv p; + add_type bv ty + | Ppat_variant (_, op) -> add_opt add_pattern bv op + | Ppat_type li -> add bv li + | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv + | Ppat_open (m, p) -> + let bv = open_module bv m.txt in + add_pattern bv p + | Ppat_exception p -> add_pattern bv p + | Ppat_extension e -> handle_extension e + +let add_pattern bv pat = + pattern_bv := bv; + add_pattern bv pat; + !pattern_bv + +let rec add_expr bv exp = + match exp.pexp_desc with + | Pexp_ident l -> add bv l + | Pexp_constant _ -> () + | Pexp_let (rf, pel, e) -> + let bv = add_bindings rf bv pel in + add_expr bv e + | Pexp_fun {default = opte; lhs = p; rhs = e} -> + add_opt add_expr bv opte; + add_expr (add_pattern bv p) e + | Pexp_apply {funct = e; args = el} -> + add_expr bv e; + List.iter (fun (_, e) -> add_expr bv e) el + | Pexp_match (e, pel) -> + add_expr bv e; + add_cases bv pel + | Pexp_try (e, pel) -> + add_expr bv e; + add_cases bv pel + | Pexp_tuple el -> List.iter (add_expr bv) el + | Pexp_construct (c, opte) -> + add bv c; + add_opt add_expr bv opte + | Pexp_variant (_, opte) -> add_opt add_expr bv opte + | Pexp_record (lblel, opte) -> + List.iter + (fun {lid = lbl; x = e} -> + add bv lbl; + add_expr bv e) + lblel; + add_opt add_expr bv opte + | Pexp_field (e, fld) -> + add_expr bv e; + add bv fld + | Pexp_setfield (e1, fld, e2) -> + add_expr bv e1; + add bv fld; + add_expr bv e2 + | Pexp_array el -> List.iter (add_expr bv) el + | Pexp_ifthenelse (e1, e2, opte3) -> + add_expr bv e1; + add_expr bv e2; + add_opt add_expr bv opte3 + | Pexp_sequence (e1, e2) -> + add_expr bv e1; + add_expr bv e2 + | Pexp_while (e1, e2) -> + add_expr bv e1; + add_expr bv e2 + | Pexp_for (_, e1, e2, _, e3) -> + add_expr bv e1; + add_expr bv e2; + add_expr bv e3 + | Pexp_coerce (e1, (), ty3) -> + add_expr bv e1; + add_type bv ty3 + | Pexp_constraint (e1, ty2) -> + add_expr bv e1; + add_type bv ty2 + | Pexp_send (e, _m) -> add_expr bv e + | Pexp_letmodule (id, m, e) -> + let b = add_module_binding bv m in + add_expr (StringMap.add id.txt b bv) e + | Pexp_letexception (_, e) -> add_expr bv e + | Pexp_assert e -> add_expr bv e + | Pexp_newtype (_, e) -> add_expr bv e + | Pexp_pack m -> add_module bv m + | Pexp_open (_ovf, m, e) -> + let bv = open_module bv m.txt in + add_expr bv e + | Pexp_extension + (( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, + PStr [item] ) as e) -> ( + match item.pstr_desc with + | Pstr_eval ({pexp_desc = Pexp_construct (c, None)}, _) -> add bv c + | _ -> handle_extension e) + | Pexp_extension e -> handle_extension e + | Pexp_await e -> add_expr bv e + | Pexp_jsx_element (Jsx_fragment {jsx_fragment_children = children}) -> + add_jsx_children bv children + | Pexp_jsx_element + (Jsx_unary_element + {jsx_unary_element_tag_name = name; jsx_unary_element_props = props}) + -> + (* Conservatively add all module path segments referenced by the tag name *) + (match name.txt with + | JsxLowerTag _ | JsxTagInvalid _ -> () + | JsxQualifiedLowerTag {path; _} | JsxUpperTag path -> add_path bv path); + and_jsx_props bv props + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = name; + jsx_container_element_props = props; + jsx_container_element_children = children; + }) -> + (match name.txt with + | JsxLowerTag _ | JsxTagInvalid _ -> () + | JsxQualifiedLowerTag {path; _} | JsxUpperTag path -> add_path bv path); + and_jsx_props bv props; + add_jsx_children bv children + +and add_jsx_children bv xs = List.iter (add_expr bv) xs + +and add_jsx_prop bv = function + | JSXPropPunning (_, _) -> () + | JSXPropValue (_, _, e) -> add_expr bv e + | JSXPropSpreading (_, e) -> add_expr bv e + +and and_jsx_props bv = List.iter (add_jsx_prop bv) + +and add_cases bv cases = List.iter (add_case bv) cases + +and add_case bv {pc_lhs; pc_guard; pc_rhs} = + let bv = add_pattern bv pc_lhs in + add_opt add_expr bv pc_guard; + add_expr bv pc_rhs + +and add_bindings recf bv pel = + let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in + let bv = if recf = Recursive then bv' else bv in + List.iter (fun x -> add_expr bv x.pvb_expr) pel; + bv' + +and add_modtype bv mty = + match mty.pmty_desc with + | Pmty_ident l -> add bv l + | Pmty_alias l -> addmodule bv l + | Pmty_signature s -> add_signature bv s + | Pmty_functor (id, mty1, mty2) -> + Misc.may (add_modtype bv) mty1; + add_modtype (StringMap.add id.txt bound bv) mty2 + | Pmty_with (mty, cstrl) -> + add_modtype bv mty; + List.iter + (function + | Pwith_type (_, td) -> add_type_declaration bv td + | Pwith_module (_, lid) -> addmodule bv lid + | Pwith_typesubst (_, td) -> add_type_declaration bv td + | Pwith_modsubst (_, lid) -> addmodule bv lid) + cstrl + | Pmty_typeof m -> add_module bv m + | Pmty_extension e -> handle_extension e + +and add_module_alias bv l = + try + add_parent bv l; + lookup_map l.txt bv + with Not_found -> ( + match l.txt with + | Lident s -> make_leaf s + | _ -> + addmodule bv l; + bound (* cannot delay *)) + +and add_modtype_binding bv mty = + if not !Clflags.transparent_modules then add_modtype bv mty; + match mty.pmty_desc with + | Pmty_alias l -> add_module_alias bv l + | Pmty_signature s -> make_node (add_signature_binding bv s) + | Pmty_typeof modl -> add_module_binding bv modl + | _ -> + if !Clflags.transparent_modules then add_modtype bv mty; + bound + +and add_signature bv sg = ignore (add_signature_binding bv sg) + +and add_signature_binding bv sg = + snd (List.fold_left add_sig_item (bv, StringMap.empty) sg) + +and add_sig_item (bv, m) item = + match item.psig_desc with + | Psig_value vd -> + add_type bv vd.pval_type; + (bv, m) + | Psig_type (_, dcls) -> + List.iter (add_type_declaration bv) dcls; + (bv, m) + | Psig_typext te -> + add_type_extension bv te; + (bv, m) + | Psig_exception pext -> + add_extension_constructor bv pext; + (bv, m) + | Psig_module pmd -> + let m' = add_modtype_binding bv pmd.pmd_type in + let add = StringMap.add pmd.pmd_name.txt m' in + (add bv, add m) + | Psig_recmodule decls -> + let add = + List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound) decls + in + let bv' = add bv and m' = add m in + List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; + (bv', m') + | Psig_modtype x -> + (match x.pmtd_type with + | None -> () + | Some mty -> add_modtype bv mty); + (bv, m) + | Psig_open od -> (open_module bv od.popen_lid.txt, m) + | Psig_include incl -> + let (Node (s, m')) = add_modtype_binding bv incl.pincl_mod in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) + | Psig_attribute _ -> (bv, m) + | Psig_extension (e, _) -> + handle_extension e; + (bv, m) + +and add_module_binding bv modl = + if not !Clflags.transparent_modules then add_module bv modl; + match modl.pmod_desc with + | Pmod_ident l -> ( + try + add_parent bv l; + lookup_map l.txt bv + with Not_found -> ( + match l.txt with + | Lident s -> make_leaf s + | _ -> + addmodule bv l; + bound)) + | Pmod_structure s -> make_node (snd (add_structure_binding bv s)) + | _ -> + if !Clflags.transparent_modules then add_module bv modl; + bound + +and add_module bv modl = + match modl.pmod_desc with + | Pmod_ident l -> addmodule bv l + | Pmod_structure s -> ignore (add_structure bv s) + | Pmod_functor (id, mty, modl) -> + Misc.may (add_modtype bv) mty; + add_module (StringMap.add id.txt bound bv) modl + | Pmod_apply (mod1, mod2) -> + add_module bv mod1; + add_module bv mod2 + | Pmod_constraint (modl, mty) -> + add_module bv modl; + add_modtype bv mty + | Pmod_unpack e -> add_expr bv e + | Pmod_extension e -> handle_extension e + +and add_structure bv item_list = + let bv, m = add_structure_binding bv item_list in + add_names (collect_free (make_node m)); + bv + +and add_structure_binding bv item_list = + List.fold_left add_struct_item (bv, StringMap.empty) item_list + +and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = + match item.pstr_desc with + | Pstr_eval (e, _attrs) -> + add_expr bv e; + (bv, m) + | Pstr_value (rf, pel) -> + let bv = add_bindings rf bv pel in + (bv, m) + | Pstr_primitive vd -> + add_type bv vd.pval_type; + (bv, m) + | Pstr_type (_, dcls) -> + List.iter (add_type_declaration bv) dcls; + (bv, m) + | Pstr_typext te -> + add_type_extension bv te; + (bv, m) + | Pstr_exception pext -> + add_extension_constructor bv pext; + (bv, m) + | Pstr_module x -> + let b = add_module_binding bv x.pmb_expr in + let add = StringMap.add x.pmb_name.txt b in + (add bv, add m) + | Pstr_recmodule bindings -> + let add = + List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings + in + let bv' = add bv and m = add m in + List.iter (fun x -> add_module bv' x.pmb_expr) bindings; + (bv', m) + | Pstr_modtype x -> + (match x.pmtd_type with + | None -> () + | Some mty -> add_modtype bv mty); + (bv, m) + | Pstr_open od -> (open_module bv od.popen_lid.txt, m) + | Pstr_include incl -> + let (Node (s, m')) = add_module_binding bv incl.pincl_mod in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) + | Pstr_attribute _ -> (bv, m) + | Pstr_extension (e, _) -> + handle_extension e; + (bv, m) + +and add_implementation bv l = + if !Clflags.transparent_modules then ignore (add_structure_binding bv l) + else ignore (add_structure bv l) + +and add_implementation_binding bv l = snd (add_structure_binding bv l) diff --git a/jscomp/ml/depend.mli b/compiler/ml/depend.mli similarity index 97% rename from jscomp/ml/depend.mli rename to compiler/ml/depend.mli index 23ad60d..b4fb4c8 100644 --- a/jscomp/ml/depend.mli +++ b/compiler/ml/depend.mli @@ -19,7 +19,7 @@ module StringSet : Set.S with type elt = string module StringMap : Map.S with type key = string type map_tree = Node of StringSet.t * bound_map -and bound_map = map_tree StringMap.t +and bound_map = map_tree StringMap.t val make_leaf : string -> map_tree val make_node : bound_map -> map_tree val weaken_map : StringSet.t -> map_tree -> map_tree @@ -31,8 +31,6 @@ val pp_deps : string list ref val open_module : bound_map -> Longident.t -> bound_map - - val add_signature : bound_map -> Parsetree.signature -> unit val add_implementation : bound_map -> Parsetree.structure -> unit diff --git a/compiler/ml/dict_type_helpers.ml b/compiler/ml/dict_type_helpers.ml new file mode 100644 index 0000000..0f5a807 --- /dev/null +++ b/compiler/ml/dict_type_helpers.ml @@ -0,0 +1,49 @@ +(* + An overview of the implementation of dicts in ReScript: + ### What is a dict? + Dicts are effectively an object with unknown fields, but a single known type of the values it holds. + + ### How are they implemented? + Dicts in ReScript are implemented as predefined record type, with a single (magic) field that holds + the type of the dict's values. This field is called `dictValuesType`, and it represent every possible + key in the dict. It's just an implementation detail - it's never actually exposed to the user, just + used internally. + + The compiler will route any label lookup on the dict record type to the magic field, which creates a + record with unknown keys, but of a single type. + + The reason for this seemingly convoluted implementation is that it allows us to piggyback on the + existing record pattern matching mechanism, which means we get pattern matching on dicts for free. + + ### Modifications to the type checker + We've made a few smaller modifications to the type checker to support this implementation: + + - We've added a new predefined type `dict` that is a record with a single field called `dictValuesType`. + This type is used to represent the type of the values in a dict. + - We've modified the type checker to recognize `dict` patterns, and route them to the predefined `dict` type. + This allows us to get full inference for dicts in patterns. + + ### Syntax + There's first class syntax support for dicts, both as expressions and as patterns. + A dict pattern is treated as a record pattern in the compiler and syntax, with an attriubute `@res.dictPattern` + attached to it. This attribute is used to tell the compiler that the pattern is a dict pattern, and is what + triggers the compiler to treat the dict record type differently to regular record types. + *) +let dict_magic_field_name = "dictValuesType" + +let has_dict_pattern_attribute attrs = + attrs + |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> + txt = "res.dictPattern") + |> Option.is_some + +let has_dict_attribute attrs = + attrs + |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> txt = "res.$dict") + |> Option.is_some + +let dict_attr : Parsetree.attribute = + (Location.mknoloc "res.$dict", Parsetree.PStr []) + +let dict_magic_field_attr : Parsetree.attribute = + (Location.mknoloc "res.$dictMagicField", Parsetree.PStr []) diff --git a/compiler/ml/dune b/compiler/ml/dune new file mode 100644 index 0000000..f4dde0e --- /dev/null +++ b/compiler/ml/dune @@ -0,0 +1,9 @@ +(library + (name ml) + (wrapped false) + (preprocess + (action + (run %{bin:cppo} %{env:CPPO_FLAGS=} %{input-file}))) + (flags + (:standard -w +a-4-42-40-41-44-45-9-48-67-70)) + (libraries ext flow_parser)) diff --git a/compiler/ml/env.ml b/compiler/ml/env.ml new file mode 100644 index 0000000..970634b --- /dev/null +++ b/compiler/ml/env.ml @@ -0,0 +1,2141 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Environment handling *) + +open Cmi_format +open Config +open Misc +open Asttypes +open Longident +open Path +open Types +open Btype + +let value_declarations : (string * Location.t, unit -> unit) Hashtbl.t = + Hashtbl.create 16 +(* This table is used to usage of value declarations. A declaration is + identified with its name and location. The callback attached to a + declaration is called whenever the value is used explicitly + (lookup_value) or implicitly (inclusion test between signatures, + cf Includemod.value_descriptions). *) + +let type_declarations = Hashtbl.create 16 +let module_declarations = Hashtbl.create 16 + +type constructor_usage = Positive | Pattern | Privatize +type constructor_usages = { + mutable cu_positive: bool; + mutable cu_pattern: bool; + mutable cu_privatize: bool; +} +let add_constructor_usage cu = function + | Positive -> cu.cu_positive <- true + | Pattern -> cu.cu_pattern <- true + | Privatize -> cu.cu_privatize <- true +let constructor_usages () = + {cu_positive = false; cu_pattern = false; cu_privatize = false} + +let used_constructors : + (string * Location.t * string, constructor_usage -> unit) Hashtbl.t = + Hashtbl.create 16 + +let prefixed_sg = Hashtbl.create 113 + +type error = + | Illegal_renaming of string * string * string + | Inconsistent_import of string * string * string + | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string + +exception Error of error + +let error err = raise (Error err) + +module EnvLazy : sig + type ('a, 'b) t + + type log + + val force : ('a -> 'b) -> ('a, 'b) t -> 'b + val create : 'a -> ('a, 'b) t + val get_arg : ('a, 'b) t -> 'a option + + (* [force_logged log f t] is equivalent to [force f t] but if [f] returns [None] then + [t] is recorded in [log]. [backtrack log] will then reset all the recorded [t]s back + to their original state. *) + val log : unit -> log + val force_logged : log -> ('a -> 'b option) -> ('a, 'b option) t -> 'b option + val backtrack : log -> unit +end = struct + type ('a, 'b) t = ('a, 'b) eval ref + + and ('a, 'b) eval = Done of 'b | Raise of exn | Thunk of 'a + + type undo = Nil | Cons : ('a, 'b) t * 'a * undo -> undo + + type log = undo ref + + let force f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> ( + match f e with + | y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e) + + let get_arg x = + match !x with + | Thunk a -> Some a + | _ -> None + + let create x = ref (Thunk x) + + let log () = ref Nil + + let force_logged log f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> ( + match f e with + | None -> + x := Done None; + log := Cons (x, e, !log); + None + | Some _ as y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e) + + let backtrack log = + let rec loop = function + | Nil -> () + | Cons (x, e, rest) -> + x := Thunk e; + loop rest + in + loop !log +end + +module PathMap = Map.Make (Path) + +type summary = + | Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_extension of summary * Ident.t * extension_constructor + | Env_module of summary * Ident.t * module_declaration + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_open of summary * Path.t + | Env_functor_arg of summary * Ident.t + | Env_constraints of summary * type_declaration PathMap.t + | Env_copy_types of summary * string list + +module TycompTbl = struct + (** This module is used to store components of types (i.e. labels + and constructors). We keep a representation of each nested + "open" and the set of local bindings between each of them. *) + + type 'a t = { + current: 'a Ident.tbl; (** Local bindings since the last open. *) + opened: 'a opened option; + (** Symbolic representation of the last (innermost) open, if any. *) + } + + and 'a opened = { + components: (string, 'a list) Tbl.t; + (** Components from the opened module. We keep a list of + bindings for each name, as in comp_labels and + comp_constrs. *) + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) + next: 'a t; (** The table before opening the module. *) + } + + let empty = {current = Ident.empty; opened = None} + + let add id x tbl = {tbl with current = Ident.add id x tbl.current} + + let add_open slot wrap components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + {current = Ident.empty; opened = Some {using; components; next}} + + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> ( + match tbl.opened with + | Some {next; _} -> find_same id next + | None -> raise exn) + + let nothing () = () + + let mk_callback rest name desc = function + | None -> nothing + | Some f -> ( + fun () -> + match rest with + | [] -> f name None + | (hidden, _) :: _ -> f name (Some (desc, hidden))) + + let rec find_all name tbl = + List.map + (fun (_id, desc) -> (desc, nothing)) + (Ident.find_all name tbl.current) + @ + match tbl.opened with + | None -> [] + | Some {using; next; components} -> ( + let rest = find_all name next in + match Tbl.find_str name components with + | exception Not_found -> rest + | opened -> + List.map (fun desc -> (desc, mk_callback rest name desc using)) opened + @ rest) + + let rec fold_name f tbl acc = + let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in + match tbl.opened with + | Some {using = _; next; components} -> + acc + |> Tbl.fold (fun _name -> List.fold_right (fun desc -> f desc)) components + |> fold_name f next + | None -> acc + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k :: accu) tbl.current acc in + match tbl.opened with + | Some o -> local_keys o.next acc + | None -> acc + + let diff_keys is_local tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + Ext_list.filter keys2 (fun id -> + is_local (find_same id tbl2) + && + try + ignore (find_same id tbl1); + false + with Not_found -> true) +end + +module IdTbl = struct + (** This module is used to store all kinds of components except + (labels and constructors) in environments. We keep a + representation of each nested "open" and the set of local + bindings between each of them. *) + + type 'a t = { + current: 'a Ident.tbl; (** Local bindings since the last open *) + opened: 'a opened option; + (** Symbolic representation of the last (innermost) open, if any. *) + } + + and 'a opened = { + root: Path.t; + (** The path of the opened module, to be prefixed in front of + its local names to produce a valid path in the current + environment. *) + components: (string, 'a * int) Tbl.t; + (** Components from the opened module. *) + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) + next: 'a t; (** The table before opening the module. *) + } + + let empty = {current = Ident.empty; opened = None} + + let add id x tbl = {tbl with current = Ident.add id x tbl.current} + + let add_open slot wrap root components next = + let using = + match slot with + | None -> None + | Some f -> Some (fun s x -> f s (wrap x)) + in + {current = Ident.empty; opened = Some {using; root; components; next}} + + let rec find_same id tbl = + try Ident.find_same id tbl.current + with Not_found as exn -> ( + match tbl.opened with + | Some {next; _} -> find_same id next + | None -> raise exn) + + let rec find_name mark name tbl = + try + let id, desc = Ident.find_name name tbl.current in + (Pident id, desc) + with Not_found as exn -> ( + match tbl.opened with + | Some {using; root; next; components} -> ( + try + let descr, pos = Tbl.find_str name components in + let res = (Pdot (root, name, pos), descr) in + (if mark then + match using with + | None -> () + | Some f -> ( + try f name (Some (snd (find_name false name next), snd res)) + with Not_found -> f name None)); + res + with Not_found -> find_name mark name next) + | None -> raise exn) + + let find_name name tbl = find_name true name tbl + + let rec update name f tbl = + try + let id, desc = Ident.find_name name tbl.current in + let new_desc = f desc in + {tbl with current = Ident.add id new_desc tbl.current} + with Not_found -> ( + match tbl.opened with + | Some {root; using; next; components} -> ( + try + let desc, pos = Tbl.find_str name components in + let new_desc = f desc in + let components = Tbl.add name (new_desc, pos) components in + {tbl with opened = Some {root; using; next; components}} + with Not_found -> + let next = update name f next in + {tbl with opened = Some {root; using; next; components}}) + | None -> tbl) + + let rec find_all name tbl = + List.map + (fun (id, desc) -> (Pident id, desc)) + (Ident.find_all name tbl.current) + @ + match tbl.opened with + | None -> [] + | Some {root; using = _; next; components} -> ( + try + let desc, pos = Tbl.find_str name components in + (Pdot (root, name, pos), desc) :: find_all name next + with Not_found -> find_all name next) + + let rec fold_name f tbl acc = + let acc = + Ident.fold_name + (fun id d -> f (Ident.name id) (Pident id, d)) + tbl.current acc + in + match tbl.opened with + | Some {root; using = _; next; components} -> + acc + |> Tbl.fold + (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc)) + components + |> fold_name f next + | None -> acc + + let rec local_keys tbl acc = + let acc = Ident.fold_all (fun k _ accu -> k :: accu) tbl.current acc in + match tbl.opened with + | Some o -> local_keys o.next acc + | None -> acc + + let rec iter f tbl = + Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; + match tbl.opened with + | Some {root; using = _; next; components} -> + Tbl.iter + (fun s (x, pos) -> + f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)) + components; + iter f next + | None -> () + + let diff_keys tbl1 tbl2 = + let keys2 = local_keys tbl2 [] in + Ext_list.filter keys2 (fun id -> + try + ignore (find_same id tbl1); + false + with Not_found -> true) +end + +type type_descriptions = constructor_description list * label_description list + +let in_signature_flag = 0x01 +let implicit_coercion_flag = 0x02 + +type t = { + values: value_description IdTbl.t; + constrs: constructor_description TycompTbl.t; + labels: label_description TycompTbl.t; + types: (type_declaration * type_descriptions) IdTbl.t; + modules: (Subst.t * module_declaration, module_declaration) EnvLazy.t IdTbl.t; + modtypes: modtype_declaration IdTbl.t; + components: module_components IdTbl.t; + functor_args: unit Ident.tbl; + summary: summary; + local_constraints: type_declaration PathMap.t; + gadt_instances: (int * TypeSet.t ref) list; + flags: int; +} + +and module_components = { + deprecated: string option; + loc: Location.t; + comps: + ( t * Subst.t * Path.t * Types.module_type, + module_components_repr option ) + EnvLazy.t; +} + +and module_components_repr = + | Structure_comps of structure_components + | Functor_comps of functor_components + +and 'a comp_tbl = (string, 'a * int) Tbl.t + +and structure_components = { + mutable comp_values: value_description comp_tbl; + mutable comp_constrs: (string, constructor_description list) Tbl.t; + mutable comp_labels: (string, label_description list) Tbl.t; + mutable comp_types: (type_declaration * type_descriptions) comp_tbl; + mutable comp_modules: + (Subst.t * module_declaration, module_declaration) EnvLazy.t comp_tbl; + mutable comp_modtypes: modtype_declaration comp_tbl; + mutable comp_components: module_components comp_tbl; (* warning -69*) +} + +and functor_components = { + fcomp_param: Ident.t; (* Formal parameter *) + fcomp_arg: module_type option; (* Argument signature *) + fcomp_res: module_type; (* Result signature *) + fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) + fcomp_subst_cache: (Path.t, module_type) Hashtbl.t; +} + +let copy_local ~from env = + { + env with + local_constraints = from.local_constraints; + gadt_instances = from.gadt_instances; + flags = from.flags; + } + +let same_constr = ref (fun _ _ _ -> assert false) + +(* Helper to decide whether to report an identifier shadowing + by some 'open'. For labels and constructors, we do not report + if the two elements are from the same re-exported declaration. + + Later, one could also interpret some attributes on value and + type declarations to silence the shadowing warnings. *) + +let check_shadowing env = function + | `Constructor (Some (c1, c2)) + when not (!same_constr env c1.cstr_res c2.cstr_res) -> + Some "constructor" + | `Label (Some (l1, l2)) when not (!same_constr env l1.lbl_res l2.lbl_res) -> + Some "label" + | `Value (Some _) -> Some "value" + | `Type (Some _) -> Some "type" + | `Module (Some _) | `Component (Some _) -> Some "module" + | `Module_type (Some _) -> Some "module type" + | `Constructor _ | `Label _ + | `Value None + | `Type None + | `Module None + | `Module_type None + | `Component None -> + None + +let subst_modtype_maker (subst, md) = + if subst == Subst.identity then md + else {md with md_type = Subst.modtype subst md.md_type} + +let empty = + { + values = IdTbl.empty; + constrs = TycompTbl.empty; + labels = TycompTbl.empty; + types = IdTbl.empty; + modules = IdTbl.empty; + modtypes = IdTbl.empty; + components = IdTbl.empty; + summary = Env_empty; + local_constraints = PathMap.empty; + gadt_instances = []; + flags = 0; + functor_args = Ident.empty; + } + +let in_signature b env = + let flags = + if b then env.flags lor in_signature_flag + else env.flags land lnot in_signature_flag + in + {env with flags} + +let implicit_coercion env = + {env with flags = env.flags lor implicit_coercion_flag} + +let is_in_signature env = env.flags land in_signature_flag <> 0 +let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0 + +let is_ident = function + | Pident _ -> true + | Pdot _ | Papply _ -> false + +let is_local_ext = function + | {cstr_tag = Cstr_extension p} -> is_ident p + | _ -> false + +let diff env1 env2 = + IdTbl.diff_keys env1.values env2.values + @ TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs + @ IdTbl.diff_keys env1.modules env2.modules + +type can_load_cmis = Can_load_cmis | Cannot_load_cmis of EnvLazy.log + +let can_load_cmis = ref Can_load_cmis + +let without_cmis f x = + let log = EnvLazy.log () in + let res = + Misc.( + protect_refs [R (can_load_cmis, Cannot_load_cmis log)] (fun () -> f x)) + in + EnvLazy.backtrack log; + res + +(* Forward declarations *) + +let components_of_module' = + ref + (fun ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false + : deprecated:string option -> + loc:Location.t -> + t -> + Subst.t -> + Path.t -> + module_type -> + module_components) +let components_of_module_maker' = + ref + (fun (_env, _sub, _path, _mty) -> assert false + : t * Subst.t * Path.t * module_type -> module_components_repr option) +let components_of_functor_appl' = + ref + (fun _f _env _p1 _p2 -> assert false + : functor_components -> t -> Path.t -> Path.t -> module_components) +let check_modtype_inclusion = + (* to be filled with Includemod.check_modtype_inclusion *) + ref + (fun ~loc:_ _env _mty1 _path1 _mty2 -> assert false + : loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) +let strengthen = + (* to be filled with Mtype.strengthen *) + ref + (fun ~aliasable:_ _env _mty _path -> assert false + : aliasable:bool -> t -> module_type -> Path.t -> module_type) + +let md md_type = {md_type; md_attributes = []; md_loc = Location.none} + +let get_components_opt c = + match !can_load_cmis with + | Can_load_cmis -> EnvLazy.force !components_of_module_maker' c.comps + | Cannot_load_cmis log -> + EnvLazy.force_logged log !components_of_module_maker' c.comps + +let empty_structure = + Structure_comps + { + comp_values = Tbl.empty; + comp_constrs = Tbl.empty; + comp_labels = Tbl.empty; + comp_types = Tbl.empty; + comp_modules = Tbl.empty; + comp_modtypes = Tbl.empty; + comp_components = Tbl.empty; + } + +let get_components c = + match get_components_opt c with + | None -> empty_structure + | Some c -> c + +(* The name of the compilation unit currently compiled. + "" if outside a compilation unit. *) + +let current_unit = ref "" + +(* Persistent structure descriptions *) + +type pers_struct = { + ps_name: string; + ps_sig: signature Lazy.t; + ps_comps: module_components; + ps_crcs: (string * Digest.t option) list; + ps_filename: string; + ps_flags: pers_flags list; +} +[@@warning "-69"] + +let persistent_structures = + (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) + +(* Consistency between persistent structures *) + +let crc_units = Consistbl.create () + +module StringSet = Set.Make (struct + type t = string + let compare = String.compare +end) + +let imported_units = ref StringSet.empty + +let add_import s = imported_units := StringSet.add s !imported_units + +let clear_imports () = + Consistbl.clear crc_units; + imported_units := StringSet.empty + +let check_consistency ps = + try + List.iter + (fun (name, crco) -> + match crco with + | None -> () + | Some crc -> + add_import name; + Consistbl.check crc_units name crc ps.ps_filename) + ps.ps_crcs + with Consistbl.Inconsistency (name, source, auth) -> + error (Inconsistent_import (name, auth, source)) + +(* Reading persistent structures from .cmi files *) + +let save_pers_struct crc ps = + let modname = ps.ps_name in + Hashtbl.add persistent_structures modname (Some ps); + Consistbl.set crc_units modname crc ps.ps_filename; + add_import modname + +module Persistent_signature = struct + type t = {filename: string; cmi: Cmi_format.cmi_infos} + + let load = + ref (fun ~unit_name -> + match find_in_path_uncap !load_path (unit_name ^ ".cmi") with + | filename -> Some {filename; cmi = read_cmi filename} + | exception Not_found -> None) +end + +let acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} = + let name = cmi.cmi_name in + let sign = cmi.cmi_sign in + let crcs = cmi.cmi_crcs in + let flags = cmi.cmi_flags in + let deprecated = + List.fold_left + (fun _ -> function + | Deprecated s -> Some s) + None flags + in + let comps = + !components_of_module' ~deprecated ~loc:Location.none empty Subst.identity + (Pident (Ident.create_persistent name)) + (Mty_signature sign) + in + let ps = + { + ps_name = name; + ps_sig = lazy (Subst.signature Subst.identity sign); + ps_comps = comps; + ps_crcs = crcs; + ps_filename = filename; + ps_flags = flags; + } + in + if ps.ps_name <> modname then + error (Illegal_renaming (modname, ps.ps_name, filename)); + if check then check_consistency ps; + Hashtbl.add persistent_structures modname (Some ps); + ps + +let read_pers_struct check modname filename = + add_import modname; + let cmi = read_cmi filename in + acknowledge_pers_struct check modname {Persistent_signature.filename; cmi} + +let find_pers_struct check name = + if name = "*predef*" then raise Not_found; + match Hashtbl.find persistent_structures name with + | Some ps -> ps + | None -> raise Not_found + | exception Not_found -> ( + match !can_load_cmis with + | Cannot_load_cmis _ -> raise Not_found + | Can_load_cmis -> + let ps = + match !Persistent_signature.load ~unit_name:name with + | Some ps -> ps + | None -> + Hashtbl.add persistent_structures name None; + raise Not_found + in + add_import name; + acknowledge_pers_struct check name ps) + +(* Emits a warning if there is no valid cmi for name *) +let check_pers_struct name = + try ignore (find_pers_struct false name) with + | Not_found -> + let warn = Warnings.No_cmi_file (name, None) in + Location.prerr_warning Location.none warn + | Cmi_format.Error err -> + let msg = Format.asprintf "%a" Cmi_format.report_error err in + let warn = Warnings.No_cmi_file (name, Some msg) in + Location.prerr_warning Location.none warn + | Error err -> + let msg = + match err with + | Illegal_renaming (name, ps_name, filename) -> + Format.asprintf + " %a@ contains the compiled interface for @ %s when %s was expected" + Location.print_filename filename ps_name name + | Inconsistent_import _ -> assert false + | Missing_module _ -> assert false + | Illegal_value_name _ -> assert false + in + let warn = Warnings.No_cmi_file (name, Some msg) in + Location.prerr_warning Location.none warn + +let read_pers_struct modname filename = read_pers_struct true modname filename + +let find_pers_struct name = find_pers_struct true name + +let check_pers_struct name = + if not (Hashtbl.mem persistent_structures name) then ( + (* PR#6843: record the weak dependency ([add_import]) regardless of + whether the check succeeds, to help make builds more + deterministic. *) + add_import name; + if Warnings.is_active (Warnings.No_cmi_file ("", None)) then + Delayed_checks.add_delayed_check (fun () -> check_pers_struct name)) + +let reset_cache () = + current_unit := ""; + Hashtbl.clear persistent_structures; + clear_imports (); + Hashtbl.clear value_declarations; + Hashtbl.clear type_declarations; + Hashtbl.clear module_declarations; + Hashtbl.clear used_constructors; + Hashtbl.clear prefixed_sg + +let reset_cache_toplevel () = + (* Delete 'missing cmi' entries from the cache. *) + let l = + Hashtbl.fold + (fun name r acc -> if r = None then name :: acc else acc) + persistent_structures [] + in + List.iter (Hashtbl.remove persistent_structures) l; + Hashtbl.clear value_declarations; + Hashtbl.clear type_declarations; + Hashtbl.clear module_declarations; + Hashtbl.clear used_constructors; + Hashtbl.clear prefixed_sg + +let set_unit_name name = current_unit := name + +let get_unit_name () = !current_unit + +(* Lookup by identifier *) + +let rec find_module_descr path env = + match path with + | Pident id -> ( + try IdTbl.find_same id env.components + with Not_found -> + if Ident.persistent id && not (Ident.name id = !current_unit) then + (find_pers_struct (Ident.name id)).ps_comps + else raise Not_found) + | Pdot (p, s, _pos) -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let descr, _pos = Tbl.find_str s c.comp_components in + descr + | Functor_comps _ -> raise Not_found) + | Papply (p1, p2) -> ( + match get_components (find_module_descr p1 env) with + | Functor_comps f -> !components_of_functor_appl' f env p1 p2 + | Structure_comps _ -> raise Not_found) + +let find proj1 proj2 path env = + match path with + | Pident id -> IdTbl.find_same id (proj1 env) + | Pdot (p, s, _pos) -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s (proj2 c) in + data + | Functor_comps _ -> raise Not_found) + | Papply _ -> raise Not_found + +let find_value = find (fun env -> env.values) (fun sc -> sc.comp_values) + +and find_type_full = find (fun env -> env.types) (fun sc -> sc.comp_types) + +and find_modtype = find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + +let type_of_cstr path = function + | {cstr_inlined = Some d; _} -> + (d, ([], List.map snd (Datarepr.labels_of_type path d))) + | _ -> assert false + +let find_type_full path env = + match Path.constructor_typath path with + | Regular p -> ( + try (PathMap.find p env.local_constraints, ([], [])) + with Not_found -> find_type_full p env) + | Cstr (ty_path, s) -> + let _, (cstrs, _) = + try find_type_full ty_path env with Not_found -> assert false + in + let cstr = + try List.find (fun cstr -> cstr.cstr_name = s) cstrs + with Not_found -> assert false + in + type_of_cstr path cstr + | LocalExt id -> + let cstr = + try TycompTbl.find_same id env.constrs with Not_found -> assert false + in + type_of_cstr path cstr + | Ext (mod_path, s) -> ( + let comps = + try find_module_descr mod_path env with Not_found -> assert false + in + let comps = + match get_components comps with + | Structure_comps c -> c + | Functor_comps _ -> assert false + in + let exts = + Ext_list.filter + (try Tbl.find_str s comps.comp_constrs with Not_found -> assert false) + (function + | {cstr_tag = Cstr_extension _} -> true + | _ -> false) + in + + match exts with + | [cstr] -> type_of_cstr path cstr + | _ -> assert false) + +let find_type p env = fst (find_type_full p env) +let find_type_descrs p env = snd (find_type_full p env) + +let find_module ~alias path env = + match path with + | Pident id -> ( + try + let data = IdTbl.find_same id env.modules in + EnvLazy.force subst_modtype_maker data + with Not_found -> + if Ident.persistent id && not (Ident.name id = !current_unit) then + let ps = find_pers_struct (Ident.name id) in + md (Mty_signature (Lazy.force ps.ps_sig)) + else raise Not_found) + | Pdot (p, s, _pos) -> ( + match get_components (find_module_descr p env) with + | Structure_comps c -> + let data, _pos = Tbl.find_str s c.comp_modules in + EnvLazy.force subst_modtype_maker data + | Functor_comps _ -> raise Not_found) + | Papply (p1, p2) -> ( + let desc1 = find_module_descr p1 env in + match get_components desc1 with + | Functor_comps f -> + md + (match f.fcomp_res with + | Mty_alias _ as mty -> mty + | mty -> ( + if alias then mty + else + try Hashtbl.find f.fcomp_subst_cache p2 + with Not_found -> + let mty = + Subst.modtype + (Subst.add_module f.fcomp_param p2 Subst.identity) + f.fcomp_res + in + Hashtbl.add f.fcomp_subst_cache p2 mty; + mty)) + | Structure_comps _ -> raise Not_found) + +let rec normalize_path lax env path = + let path = + match path with + | Pdot (p, s, pos) -> Pdot (normalize_path lax env p, s, pos) + | Papply (p1, p2) -> + Papply (normalize_path lax env p1, normalize_path true env p2) + | _ -> path + in + try + match find_module ~alias:true path env with + | {md_type = Mty_alias (_, path1)} -> normalize_path lax env path1 + | _ -> path + with + | Not_found + when lax + || + match path with + | Pident id -> not (Ident.persistent id) + | _ -> true + -> + path + +let normalize_path oloc env path = + try normalize_path (oloc = None) env path + with Not_found -> ( + match oloc with + | None -> assert false + | Some loc -> + raise (Error (Missing_module (loc, path, normalize_path true env path)))) + +let normalize_path_prefix oloc env path = + match path with + | Pdot (p, s, pos) -> Pdot (normalize_path oloc env p, s, pos) + | Pident _ -> path + | Papply _ -> assert false + +let find_module = find_module ~alias:false + +(* Find the manifest type associated to a type when appropriate: + - the type should be public or should have a private row, + - the type should have an associated manifest type. *) +let find_type_expansion path env = + let decl = find_type path env in + match decl.type_manifest with + | Some body + when decl.type_private = Public + || decl.type_kind <> Type_abstract + || Btype.has_constr_row body -> + (decl.type_params, body, may_map snd decl.type_newtype_level) + (* The manifest type of Private abstract data types without + private row are still considered unknown to the type system. + Hence, this case is caught by the following clause that also handles + purely abstract data types without manifest type definition. *) + | _ -> raise Not_found + +(* Find the manifest type information associated to a type, i.e. + the necessary information for the compiler's type-based optimisations. + In particular, the manifest type associated to a private abstract type + is revealed for the sake of compiler's type-based optimisations. *) +let find_type_expansion_opt path env = + let decl = find_type path env in + match decl.type_manifest with + (* The manifest type of Private abstract data types can still get + an approximation using their manifest type. *) + | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level) + | _ -> raise Not_found + +let find_modtype_expansion path env = + match (find_modtype path env).mtd_type with + | None -> raise Not_found + | Some mty -> mty + +let rec is_functor_arg path env = + match path with + | Pident id -> ( + try + Ident.find_same id env.functor_args; + true + with Not_found -> false) + | Pdot (p, _s, _) -> is_functor_arg p env + | Papply _ -> true + +(* Lookup by name *) + +exception Recmodule + +let report_deprecated ?loc p deprecated = + match (loc, deprecated) with + | Some loc, Some txt -> + let txt = if txt = "" then "" else "\n" ^ txt in + Location.deprecated loc (Printf.sprintf "module %s%s" (Path.name p) txt) + | _ -> () + +let mark_module_used env name loc = + if not (is_implicit_coercion env) then + try Hashtbl.find module_declarations (name, loc) () with Not_found -> () + +let rec lookup_module_descr_aux ?loc lid env = + match lid with + | Lident s -> ( + try IdTbl.find_name s env.components + with Not_found -> + if s = !current_unit then raise Not_found; + let ps = find_pers_struct s in + (Pident (Ident.create_persistent s), ps.ps_comps)) + | Ldot (l, s) -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let descr, pos = Tbl.find_str s c.comp_components in + (Pdot (p, s, pos), descr) + | Functor_comps _ -> raise Not_found) + | Lapply (l1, l2) -> ( + let p1, desc1 = lookup_module_descr ?loc l1 env in + let p2 = lookup_module ~load:true ?loc l2 env in + let {md_type = mty2} = find_module p2 env in + match get_components desc1 with + | Functor_comps f -> + let loc = + match loc with + | Some l -> l + | None -> Location.none + in + Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; + (Papply (p1, p2), !components_of_functor_appl' f env p1 p2) + | Structure_comps _ -> raise Not_found) + +and lookup_module_descr ?loc lid env = + let ((p, comps) as res) = lookup_module_descr_aux ?loc lid env in + mark_module_used env (Path.last p) comps.loc; + report_deprecated ?loc p comps.deprecated; + res + +and lookup_module ~load ?loc lid env : Path.t = + match lid with + | Lident s -> ( + try + let p, data = IdTbl.find_name s env.modules in + let {md_loc; md_attributes; md_type} = + EnvLazy.force subst_modtype_maker data + in + mark_module_used env s md_loc; + (match md_type with + | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" -> + (* see #5965 *) + raise Recmodule + | Mty_alias (_, Path.Pident id) -> + if (not !Clflags.transparent_modules) && Ident.persistent id then + find_pers_struct (Ident.name id) |> ignore + | _ -> ()); + report_deprecated ?loc p + (Builtin_attributes.deprecated_of_attrs md_attributes); + p + with Not_found -> + if s = !current_unit then raise Not_found; + let p = Pident (Ident.create_persistent s) in + (if !Clflags.transparent_modules && not load then check_pers_struct s + else + let ps = find_pers_struct s in + report_deprecated ?loc p ps.ps_comps.deprecated); + p) + | Ldot (l, s) -> ( + let p, descr = lookup_module_descr ?loc l env in + match get_components descr with + | Structure_comps c -> + let _data, pos = Tbl.find_str s c.comp_modules in + let comps, _ = Tbl.find_str s c.comp_components in + mark_module_used env s comps.loc; + let p = Pdot (p, s, pos) in + report_deprecated ?loc p comps.deprecated; + p + | Functor_comps _ -> raise Not_found) + | Lapply (l1, l2) -> ( + let p1, desc1 = lookup_module_descr ?loc l1 env in + let p2 = lookup_module ~load:true ?loc l2 env in + let {md_type = mty2} = find_module p2 env in + let p = Papply (p1, p2) in + match get_components desc1 with + | Functor_comps f -> + let loc = + match loc with + | Some l -> l + | None -> Location.none + in + Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; + p + | Structure_comps _ -> raise Not_found) + +let lookup proj1 proj2 ?loc lid env = + match lid with + | Lident s -> IdTbl.find_name s (proj1 env) + | Ldot (l, s) -> ( + let p, desc = lookup_module_descr ?loc l env in + match get_components desc with + | Structure_comps c -> + let data, pos = Tbl.find_str s (proj2 c) in + (Pdot (p, s, pos), data) + | Functor_comps _ -> raise Not_found) + | Lapply _ -> raise Not_found + +let lookup_all_simple proj1 proj2 shadow ?loc lid env = + match lid with + | Lident s -> + let xl = TycompTbl.find_all s (proj1 env) in + let rec do_shadow = function + | [] -> [] + | (x, f) :: xs -> + (x, f) + :: do_shadow (Ext_list.filter xs (fun (y, _) -> not (shadow x y))) + in + do_shadow xl + | Ldot (l, s) -> ( + let _p, desc = lookup_module_descr ?loc l env in + match get_components desc with + | Structure_comps c -> + let comps = try Tbl.find_str s (proj2 c) with Not_found -> [] in + List.map (fun data -> (data, fun () -> ())) comps + | Functor_comps _ -> raise Not_found) + | Lapply _ -> raise Not_found + +let has_local_constraints env = not (PathMap.is_empty env.local_constraints) + +let cstr_shadow cstr1 cstr2 = + match (cstr1.cstr_tag, cstr2.cstr_tag) with + | Cstr_extension _, Cstr_extension _ -> true + | _ -> false + +let lbl_shadow _lbl1 _lbl2 = false + +let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) +let lookup_all_constructors = + lookup_all_simple + (fun env -> env.constrs) + (fun sc -> sc.comp_constrs) + cstr_shadow +let lookup_all_labels = + lookup_all_simple + (fun env -> env.labels) + (fun sc -> sc.comp_labels) + lbl_shadow +let lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) +let lookup_modtype = + lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + +let copy_types l env = + let f desc = + {desc with val_type = Subst.type_expr Subst.identity desc.val_type} + in + let values = + List.fold_left (fun env s -> IdTbl.update s f env) env.values l + in + {env with values; summary = Env_copy_types (env.summary, l)} + +let mark_value_used env name vd = + if not (is_implicit_coercion env) then + try Hashtbl.find value_declarations (name, vd.val_loc) () + with Not_found -> () + +let mark_type_used env name vd = + if not (is_implicit_coercion env) then + try Hashtbl.find type_declarations (name, vd.type_loc) () + with Not_found -> () + +let mark_constructor_used usage env name vd constr = + if not (is_implicit_coercion env) then + try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage + with Not_found -> () + +let mark_extension_used usage env ext name = + if not (is_implicit_coercion env) then + let ty_name = Path.last ext.ext_type_path in + try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage + with Not_found -> () + +let set_value_used_callback name vd callback = + let key = (name, vd.val_loc) in + try + let old = Hashtbl.find value_declarations key in + Hashtbl.replace value_declarations key (fun () -> + old (); + callback ()) + (* this is to support cases like: + let x = let x = 1 in x in x + where the two declarations have the same location + (e.g. resulting from Camlp4 expansion of grammar entries) *) + with Not_found -> Hashtbl.add value_declarations key callback + +let set_type_used_callback name td callback = + let loc = td.type_loc in + if loc.Location.loc_ghost then () + else + let key = (name, loc) in + let old = + try Hashtbl.find type_declarations key with Not_found -> assert false + in + Hashtbl.replace type_declarations key (fun () -> callback old) + +let lookup_value ?loc lid env = + let ((_, desc) as r) = lookup_value ?loc lid env in + mark_value_used env (Longident.last lid) desc; + r + +let lookup_type ?loc lid env = + let path, (decl, _) = lookup_type ?loc lid env in + mark_type_used env (Longident.last lid) decl; + path + +let mark_type_path env path = + try + let decl = find_type path env in + mark_type_used env (Path.last path) decl + with Not_found -> () + +let ty_path t = + match repr t with + | {desc = Tconstr (path, _, _)} -> path + | _ -> assert false + +let lookup_constructor ?loc lid env = + match lookup_all_constructors ?loc lid env with + | [] -> raise Not_found + | (desc, use) :: _ -> + mark_type_path env (ty_path desc.cstr_res); + use (); + desc + +let is_lident = function + | Lident _ -> true + | _ -> false + +let lookup_all_constructors ?loc lid env = + try + let cstrs = lookup_all_constructors ?loc lid env in + let wrap_use desc use () = + mark_type_path env (ty_path desc.cstr_res); + use () + in + List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs + with Not_found when is_lident lid -> [] + +let mark_constructor usage env name desc = + if not (is_implicit_coercion env) then + match desc.cstr_tag with + | Cstr_extension _ -> ( + let ty_path = ty_path desc.cstr_res in + let ty_name = Path.last ty_path in + try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage + with Not_found -> ()) + | _ -> + let ty_path = ty_path desc.cstr_res in + let ty_decl = + try find_type ty_path env with Not_found -> assert false + in + let ty_name = Path.last ty_path in + mark_constructor_used usage env ty_name ty_decl name + +let lookup_label ?loc lid env = + match lookup_all_labels ?loc lid env with + | [] -> raise Not_found + | (desc, use) :: _ -> + mark_type_path env (ty_path desc.lbl_res); + use (); + desc + +let lookup_all_labels ?loc lid env = + try + let lbls = lookup_all_labels ?loc lid env in + let wrap_use desc use () = + mark_type_path env (ty_path desc.lbl_res); + use () + in + List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls + with Not_found when is_lident lid -> [] + +(* Iter on an environment (ignoring the body of functors and + not yet evaluated structures) *) + +type iter_cont = unit -> unit +let iter_env_cont = ref [] + +let rec scrape_alias_for_visit env mty = + match mty with + | Mty_alias (_, Pident id) + when Ident.persistent id + && not (Hashtbl.mem persistent_structures (Ident.name id)) -> + false + | Mty_alias (_, path) -> ( + (* PR#6600: find_module may raise Not_found *) + try scrape_alias_for_visit env (find_module path env).md_type + with Not_found -> false) + | _ -> true + +let iter_env proj1 proj2 f env () = + IdTbl.iter (fun id x -> f (Pident id) x) (proj1 env); + let rec iter_components path path' mcomps = + let cont () = + let visit = + match EnvLazy.get_arg mcomps.comps with + | None -> true + | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty + in + if not visit then () + else + match get_components mcomps with + | Structure_comps comps -> + Tbl.iter + (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) + (proj2 comps); + Tbl.iter + (fun s (c, n) -> + iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c) + comps.comp_components + | Functor_comps _ -> () + in + iter_env_cont := (path, cont) :: !iter_env_cont + in + Hashtbl.iter + (fun s pso -> + match pso with + | None -> () + | Some ps -> + let id = Pident (Ident.create_persistent s) in + iter_components id id ps.ps_comps) + persistent_structures; + IdTbl.iter + (fun id (path, comps) -> iter_components (Pident id) path comps) + env.components + +let run_iter_cont l = + iter_env_cont := []; + List.iter (fun c -> c ()) l; + let cont = List.rev !iter_env_cont in + iter_env_cont := []; + cont + +let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f + +let same_types env1 env2 = + env1.types == env2.types && env1.components == env2.components + +let used_persistent () = + let r = ref Concr.empty in + Hashtbl.iter + (fun s pso -> if pso != None then r := Concr.add s !r) + persistent_structures; + !r + +let find_all_comps proj s (p, mcomps) = + match get_components mcomps with + | Functor_comps _ -> [] + | Structure_comps comps -> ( + try + let c, n = Tbl.find_str s (proj comps) in + [(Pdot (p, s, n), c)] + with Not_found -> []) + +let rec find_shadowed_comps path env = + match path with + | Pident id -> IdTbl.find_all (Ident.name id) env.components + | Pdot (p, s, _) -> + let l = find_shadowed_comps p env in + let l' = + List.map (find_all_comps (fun comps -> comps.comp_components) s) l + in + List.flatten l' + | Papply _ -> [] + +let find_shadowed proj1 proj2 path env = + match path with + | Pident id -> IdTbl.find_all (Ident.name id) (proj1 env) + | Pdot (p, s, _) -> + let l = find_shadowed_comps p env in + let l' = List.map (find_all_comps proj2 s) l in + List.flatten l' + | Papply _ -> [] + +let find_shadowed_types path env = + List.map fst + (find_shadowed + (fun env -> env.types) + (fun comps -> comps.comp_types) + path env) + +(* GADT instance tracking *) + +let add_gadt_instance_level lv env = + {env with gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} + +let is_Tlink = function + | {desc = Tlink _} -> true + | _ -> false + +let gadt_instance_level env t = + let rec find_instance = function + | [] -> None + | (lv, r) :: rem -> + if TypeSet.exists is_Tlink !r then + (* Should we use set_typeset ? *) + r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; + if TypeSet.mem t !r then Some lv else find_instance rem + in + find_instance env.gadt_instances + +let add_gadt_instances env lv tl = + let r = + try List.assoc lv env.gadt_instances with Not_found -> assert false + in + (* Format.eprintf "Added"; + List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl; + Format.eprintf "@."; *) + set_typeset r (List.fold_right TypeSet.add tl !r) + +(* Only use this after expand_head! *) +let add_gadt_instance_chain env lv t = + let r = + try List.assoc lv env.gadt_instances with Not_found -> assert false + in + let rec add_instance t = + let t = repr t in + if not (TypeSet.mem t !r) then ( + (* Format.eprintf "@ %a" !Btype.print_raw t; *) + set_typeset r (TypeSet.add t !r); + match t.desc with + | Tconstr (p, _, memo) -> may add_instance (find_expans Private p !memo) + | _ -> ()) + in + (* Format.eprintf "Added chain"; *) + add_instance t +(* Format.eprintf "@." *) + +(* Expand manifest module type names at the top of the given module type *) + +let rec scrape_alias env ?path mty = + match (mty, path) with + | Mty_ident p, _ -> ( + try scrape_alias env (find_modtype_expansion p env) ?path + with Not_found -> mty) + | Mty_alias (_, path), _ -> ( + try scrape_alias env (find_module path env).md_type ~path + with Not_found -> + (*Location.prerr_warning Location.none + (Warnings.No_cmi_file (Path.name path));*) + mty) + | mty, Some path -> !strengthen ~aliasable:true env mty path + | _ -> mty + +let scrape_alias env mty = scrape_alias env mty + +(* Given a signature and a root path, prefix all idents in the signature + by the root path and build the corresponding substitution. *) + +let rec prefix_idents root pos sub = function + | [] -> ([], sub) + | Sig_value (id, decl) :: rem -> + let p = Pdot (root, Ident.name id, pos) in + let nextpos = + match decl.val_kind with + | Val_prim _ -> pos + | _ -> pos + 1 + in + let pl, final_sub = prefix_idents root nextpos sub rem in + (p :: pl, final_sub) + | Sig_type (id, _, _) :: rem -> + let p = Pdot (root, Ident.name id, nopos) in + let pl, final_sub = prefix_idents root pos (Subst.add_type id p sub) rem in + (p :: pl, final_sub) + | Sig_typext (id, _, _) :: rem -> + let p = Pdot (root, Ident.name id, pos) in + (* we extend the substitution in case of an inlined record *) + let pl, final_sub = + prefix_idents root (pos + 1) (Subst.add_type id p sub) rem + in + (p :: pl, final_sub) + | Sig_module (id, _, _) :: rem -> + let p = Pdot (root, Ident.name id, pos) in + let pl, final_sub = + prefix_idents root (pos + 1) (Subst.add_module id p sub) rem + in + (p :: pl, final_sub) + | Sig_modtype (id, _) :: rem -> + let p = Pdot (root, Ident.name id, nopos) in + let pl, final_sub = + prefix_idents root pos (Subst.add_modtype id (Mty_ident p) sub) rem + in + (p :: pl, final_sub) + | Sig_class _ :: _ -> assert false + | Sig_class_type _ :: _ -> assert false + +let prefix_idents root sub sg = + if sub = Subst.identity then ( + let sgs = + try Hashtbl.find prefixed_sg root + with Not_found -> + let sgs = ref [] in + Hashtbl.add prefixed_sg root sgs; + sgs + in + try List.assq sg !sgs + with Not_found -> + let r = prefix_idents root 0 sub sg in + sgs := (sg, r) :: !sgs; + r) + else prefix_idents root 0 sub sg + +(* Compute structure descriptions *) + +let add_to_tbl id decl tbl = + let decls = try Tbl.find_str id tbl with Not_found -> [] in + Tbl.add id (decl :: decls) tbl + +let rec components_of_module ~deprecated ~loc env sub path mty = + {deprecated; loc; comps = EnvLazy.create (env, sub, path, mty)} + +and components_of_module_maker (env, sub, path, mty) = + match scrape_alias env mty with + | Mty_signature sg -> + let c = + { + comp_values = Tbl.empty; + comp_constrs = Tbl.empty; + comp_labels = Tbl.empty; + comp_types = Tbl.empty; + comp_modules = Tbl.empty; + comp_modtypes = Tbl.empty; + comp_components = Tbl.empty; + } + in + let pl, sub = prefix_idents path sub sg in + let env = ref env in + let pos = ref 0 in + List.iter2 + (fun item path -> + match item with + | Sig_value (id, decl) -> ( + let decl' = Subst.value_description sub decl in + c.comp_values <- Tbl.add (Ident.name id) (decl', !pos) c.comp_values; + match decl.val_kind with + | Val_prim _ -> () + | _ -> incr pos) + | Sig_type (id, decl, _) -> + let decl' = Subst.type_declaration sub decl in + Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); + let constructors = + List.map snd (Datarepr.constructors_of_type path decl') + in + let labels = List.map snd (Datarepr.labels_of_type path decl') in + c.comp_types <- + Tbl.add (Ident.name id) + ((decl', (constructors, labels)), nopos) + c.comp_types; + List.iter + (fun descr -> + c.comp_constrs <- add_to_tbl descr.cstr_name descr c.comp_constrs) + constructors; + List.iter + (fun descr -> + c.comp_labels <- add_to_tbl descr.lbl_name descr c.comp_labels) + labels; + env := store_type_infos id decl !env + | Sig_typext (id, ext, _) -> + let ext' = Subst.extension_constructor sub ext in + let descr = Datarepr.extension_descr path ext' in + c.comp_constrs <- add_to_tbl (Ident.name id) descr c.comp_constrs; + incr pos + | Sig_module (id, md, _) -> + let md' = EnvLazy.create (sub, md) in + c.comp_modules <- Tbl.add (Ident.name id) (md', !pos) c.comp_modules; + let deprecated = + Builtin_attributes.deprecated_of_attrs md.md_attributes + in + let comps = + components_of_module ~deprecated ~loc:md.md_loc !env sub path + md.md_type + in + c.comp_components <- + Tbl.add (Ident.name id) (comps, !pos) c.comp_components; + env := store_module ~check:false id md !env; + incr pos + | Sig_modtype (id, decl) -> + let decl' = Subst.modtype_declaration sub decl in + c.comp_modtypes <- + Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; + env := store_modtype id decl !env + | Sig_class () -> assert false + | Sig_class_type () -> assert false) + sg pl; + Some (Structure_comps c) + | Mty_functor (param, ty_arg, ty_res) -> + Some + (Functor_comps + { + fcomp_param = param; + (* fcomp_arg and fcomp_res must be prefixed eagerly, because + they are interpreted in the outer environment *) + fcomp_arg = may_map (Subst.modtype sub) ty_arg; + fcomp_res = Subst.modtype sub ty_res; + fcomp_cache = Hashtbl.create 17; + fcomp_subst_cache = Hashtbl.create 17; + }) + | Mty_ident _ | Mty_alias _ -> None + +(* Insertion of bindings by identifier + path *) + +and check_usage loc id warn tbl = + if (not loc.Location.loc_ghost) && Warnings.is_active (warn "") then ( + let name = Ident.name id in + let key = (name, loc) in + if Hashtbl.mem tbl key then () + else + let used = ref false in + Hashtbl.add tbl key (fun () -> used := true); + if not (name = "" || name.[0] = '_' || name.[0] = '#') then + Delayed_checks.add_delayed_check (fun () -> + if not !used then Location.prerr_warning loc (warn name))) + +and check_value_name name loc = + (* Note: we could also check here general validity of the + identifier, to protect against bad identifiers forged by -pp or + -ppx preprocessors. *) + if name = "->" then raise (Error (Illegal_value_name (loc, name))) + else if String.length name > 0 && name.[0] = '#' then + for i = 1 to String.length name - 1 do + if name.[i] = '#' then raise (Error (Illegal_value_name (loc, name))) + done + +and store_value ?check id decl env = + check_value_name (Ident.name id) decl.val_loc; + may (fun f -> check_usage decl.val_loc id f value_declarations) check; + { + env with + values = IdTbl.add id decl env.values; + summary = Env_value (env.summary, id, decl); + } + +and store_type ~check id info env = + let loc = info.type_loc in + if check then + check_usage loc id + (fun s -> Warnings.Unused_type_declaration s) + type_declarations; + let path = Pident id in + let constructors = Datarepr.constructors_of_type path info in + let labels = Datarepr.labels_of_type path info in + let descrs = (List.map snd constructors, List.map snd labels) in + + (if + check + && (not loc.Location.loc_ghost) + && Warnings.is_active (Warnings.Unused_constructor ("", false, false)) + then + let ty = Ident.name id in + List.iter + (fun (_, {cstr_name = c; _}) -> + let k = (ty, loc, c) in + if not (Hashtbl.mem used_constructors k) then ( + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); + if not (ty = "" || ty.[0] = '_') then + Delayed_checks.add_delayed_check (fun () -> + if (not (is_in_signature env)) && not used.cu_positive then + Location.prerr_warning loc + (Warnings.Unused_constructor + (c, used.cu_pattern, used.cu_privatize))))) + constructors); + { + env with + constrs = + List.fold_right + (fun (id, descr) constrs -> TycompTbl.add id descr constrs) + constructors env.constrs; + labels = + List.fold_right + (fun (id, descr) labels -> TycompTbl.add id descr labels) + labels env.labels; + types = IdTbl.add id (info, descrs) env.types; + summary = Env_type (env.summary, id, info); + } + +and store_type_infos id info env = + (* Simplified version of store_type that doesn't compute and store + constructor and label infos, but simply record the arity and + manifest-ness of the type. Used in components_of_module to + keep track of type abbreviations (e.g. type t = float) in the + computation of label representations. *) + { + env with + types = IdTbl.add id (info, ([], [])) env.types; + summary = Env_type (env.summary, id, info); + } + +and store_extension ~check id ext env = + let loc = ext.ext_loc in + (if + check + && (not loc.Location.loc_ghost) + && Warnings.is_active (Warnings.Unused_extension ("", false, false, false)) + then + let ty = Path.last ext.ext_type_path in + let n = Ident.name id in + let k = (ty, loc, n) in + if not (Hashtbl.mem used_constructors k) then ( + let used = constructor_usages () in + Hashtbl.add used_constructors k (add_constructor_usage used); + Delayed_checks.add_delayed_check (fun () -> + if (not (is_in_signature env)) && not used.cu_positive then + Location.prerr_warning loc + (Warnings.Unused_extension + (n, ext.ext_is_exception, used.cu_pattern, used.cu_privatize))))); + { + env with + constrs = + TycompTbl.add id (Datarepr.extension_descr (Pident id) ext) env.constrs; + summary = Env_extension (env.summary, id, ext); + } + +and store_module ~check id md env = + let loc = md.md_loc in + if check then + check_usage loc id (fun s -> Warnings.Unused_module s) module_declarations; + + let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in + { + env with + modules = IdTbl.add id (EnvLazy.create (Subst.identity, md)) env.modules; + components = + IdTbl.add id + (components_of_module ~deprecated ~loc:md.md_loc env Subst.identity + (Pident id) md.md_type) + env.components; + summary = Env_module (env.summary, id, md); + } + +and store_modtype id info env = + { + env with + modtypes = IdTbl.add id info env.modtypes; + summary = Env_modtype (env.summary, id, info); + } + +(* Compute the components of a functor application in a path. *) + +let components_of_functor_appl f env p1 p2 = + try Hashtbl.find f.fcomp_cache p2 + with Not_found -> + let p = Papply (p1, p2) in + let sub = Subst.add_module f.fcomp_param p2 Subst.identity in + let mty = Subst.modtype sub f.fcomp_res in + let comps = + components_of_module ~deprecated:None ~loc:Location.none (*???*) + env Subst.identity p mty + in + Hashtbl.add f.fcomp_cache p2 comps; + comps + +(* Define forward functions *) + +let _ = + components_of_module' := components_of_module; + components_of_functor_appl' := components_of_functor_appl; + components_of_module_maker' := components_of_module_maker + +(* Insertion of bindings by identifier *) + +let add_functor_arg id env = + { + env with + functor_args = Ident.add id () env.functor_args; + summary = Env_functor_arg (env.summary, id); + } + +let add_value ?check id desc env = store_value ?check id desc env + +let add_type ~check id info env = store_type ~check id info env + +and add_extension ~check id ext env = store_extension ~check id ext env + +and add_module_declaration ?(arg = false) ~check id md env = + let env = store_module ~check id md env in + if arg then add_functor_arg id env else env + +and add_modtype id info env = store_modtype id info env + +let add_module ?arg id mty env = + add_module_declaration ~check:false ?arg id (md mty) env + +let add_local_type path info env = + {env with local_constraints = PathMap.add path info env.local_constraints} + +let add_local_constraint path info elv env = + match info with + | {type_manifest = Some _; type_newtype_level = Some (lv, _)} -> + (* elv is the expansion level, lv is the definition level *) + let info = {info with type_newtype_level = Some (lv, elv)} in + add_local_type path info env + | _ -> assert false + +(* Insertion of bindings by name *) + +let enter store_fun name data env = + let id = Ident.create name in + (id, store_fun id data env) + +let enter_value ?check = enter (store_value ?check) + +and enter_type = enter (store_type ~check:true) + +and enter_extension = enter (store_extension ~check:true) + +and enter_module_declaration ?arg id md env = + add_module_declaration ?arg ~check:true id md env +(* let (id, env) = enter store_module name md env in + (id, add_functor_arg ?arg id env) *) + +and enter_modtype = enter store_modtype + +let enter_module ?arg s mty env = + let id = Ident.create s in + (id, enter_module_declaration ?arg id (md mty) env) + +(* Insertion of all components of a signature *) + +let add_item comp env = + match comp with + | Sig_value (id, decl) -> add_value id decl env + | Sig_type (id, decl, _) -> add_type ~check:false id decl env + | Sig_typext (id, ext, _) -> add_extension ~check:false id ext env + | Sig_module (id, md, _) -> add_module_declaration ~check:false id md env + | Sig_modtype (id, decl) -> add_modtype id decl env + | Sig_class () -> env + | Sig_class_type () -> env + +let rec add_signature sg env = + match sg with + | [] -> env + | comp :: rem -> add_signature rem (add_item comp env) + +(* Open a signature path *) + +let add_components slot root env0 comps = + let add_l w comps env0 = TycompTbl.add_open slot w comps env0 in + + let add w comps env0 = IdTbl.add_open slot w root comps env0 in + + let constrs = + add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs + in + let labels = add_l (fun x -> `Label x) comps.comp_labels env0.labels in + + let values = add (fun x -> `Value x) comps.comp_values env0.values in + let types = add (fun x -> `Type x) comps.comp_types env0.types in + let modtypes = + add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes + in + let components = + add (fun x -> `Component x) comps.comp_components env0.components + in + + let modules = add (fun x -> `Module x) comps.comp_modules env0.modules in + + { + env0 with + summary = Env_open (env0.summary, root); + constrs; + labels; + values; + types; + modtypes; + components; + modules; + } + +let open_signature slot root env0 = + match get_components (find_module_descr root env0) with + | Functor_comps _ -> None + | Structure_comps comps -> Some (add_components slot root env0 comps) + +(* Open a signature from a file *) + +let open_signature ?(used_slot = ref false) ?(loc = Location.none) + ?(toplevel = false) ovf root env = + if + (not toplevel) && ovf = Asttypes.Fresh + && (not loc.Location.loc_ghost) + && (Warnings.is_active (Warnings.Unused_open "") + || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) + || Warnings.is_active (Warnings.Open_shadow_label_constructor ("", ""))) + then ( + let used = used_slot in + Delayed_checks.add_delayed_check (fun () -> + if not !used then ( + used := true; + Location.prerr_warning loc (Warnings.Unused_open (Path.name root)))); + let shadowed = ref [] in + let slot s b = + (match check_shadowing env b with + | Some kind when not (List.mem (kind, s) !shadowed) -> + shadowed := (kind, s) :: !shadowed; + let w = + match kind with + | "label" | "constructor" -> + Warnings.Open_shadow_label_constructor (kind, s) + | _ -> Warnings.Open_shadow_identifier (kind, s) + in + Location.prerr_warning loc w + | _ -> ()); + used := true + in + open_signature (Some slot) root env) + else open_signature None root env + +(* Read a signature from a file *) + +let read_signature modname filename = + let ps = read_pers_struct modname filename in + Lazy.force ps.ps_sig + +(* Return the CRC of the interface of the given compilation unit *) + +let crc_of_unit name = + let ps = find_pers_struct name in + let crco = try List.assoc name ps.ps_crcs with Not_found -> assert false in + match crco with + | None -> assert false + | Some crc -> crc + +(* Return the list of imported interfaces with their CRCs *) + +let imports () = + let dont_record_crc_unit = !Clflags.dont_record_crc_unit in + match dont_record_crc_unit with + | None -> Consistbl.extract (StringSet.elements !imported_units) crc_units + | Some x -> + Consistbl.extract + (StringSet.fold + (fun m acc -> if m = x then acc else m :: acc) + !imported_units []) + crc_units + +(* Save a signature to a file *) + +let save_signature_with_imports ?check_exists ~deprecated sg modname filename + imports = + (*prerr_endline filename; + List.iter (fun (name, crc) -> prerr_endline name) imports;*) + Btype.cleanup_abbrev (); + Subst.reset_for_saving (); + let sg = Subst.signature (Subst.for_saving Subst.identity) sg in + let flags = + match deprecated with + | Some s -> [Deprecated s] + | None -> [] + in + try + let cmi = + {cmi_name = modname; cmi_sign = sg; cmi_crcs = imports; cmi_flags = flags} + in + let crc = create_cmi ?check_exists filename cmi in + (* Enter signature in persistent table so that imported_unit() + will also return its crc *) + let comps = + components_of_module ~deprecated ~loc:Location.none empty Subst.identity + (Pident (Ident.create_persistent modname)) + (Mty_signature sg) + in + let ps = + { + ps_name = modname; + ps_sig = lazy (Subst.signature Subst.identity sg); + ps_comps = comps; + ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_filename = filename; + ps_flags = cmi.cmi_flags; + } + in + save_pers_struct crc ps; + cmi + with exn -> + remove_file filename; + raise exn + +let save_signature ?check_exists ~deprecated sg modname filename = + save_signature_with_imports ?check_exists ~deprecated sg modname filename + (imports ()) + +(* Folding on environments *) + +let find_all proj1 proj2 f lid env acc = + match lid with + | None -> + IdTbl.fold_name + (fun name (p, data) acc -> f name p data acc) + (proj1 env) acc + | Some l -> ( + let p, desc = lookup_module_descr l env in + match get_components desc with + | Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) + (proj2 c) acc + | Functor_comps _ -> acc) + +let find_all_simple_list proj1 proj2 f lid env acc = + match lid with + | None -> TycompTbl.fold_name (fun data acc -> f data acc) (proj1 env) acc + | Some l -> ( + let _p, desc = lookup_module_descr l env in + match get_components desc with + | Structure_comps c -> + Tbl.fold + (fun _s comps acc -> + match comps with + | [] -> acc + | data :: _ -> f data acc) + (proj2 c) acc + | Functor_comps _ -> acc) + +let fold_modules f lid env acc = + match lid with + | None -> + let acc = + IdTbl.fold_name + (fun name (p, data) acc -> + let data = EnvLazy.force subst_modtype_maker data in + f name p data acc) + env.modules acc + in + Hashtbl.fold + (fun name ps acc -> + match ps with + | None -> acc + | Some ps -> + f name + (Pident (Ident.create_persistent name)) + (md (Mty_signature (Lazy.force ps.ps_sig))) + acc) + persistent_structures acc + | Some l -> ( + let p, desc = lookup_module_descr l env in + match get_components desc with + | Structure_comps c -> + Tbl.fold + (fun s (data, pos) acc -> + f s (Pdot (p, s, pos)) (EnvLazy.force subst_modtype_maker data) acc) + c.comp_modules acc + | Functor_comps _ -> acc) + +let fold_values f = + find_all (fun env -> env.values) (fun sc -> sc.comp_values) f + +and fold_constructors f = + find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f + +and fold_labels f = + find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f + +and fold_types f = find_all (fun env -> env.types) (fun sc -> sc.comp_types) f + +and fold_modtypes f = + find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f + +(* Make the initial environment *) +let initial_safe_string = + Predef.build_initial_env (add_type ~check:false) + (add_extension ~check:false) + empty + +(* Return the environment summary *) + +let summary env = + if PathMap.is_empty env.local_constraints then env.summary + else Env_constraints (env.summary, env.local_constraints) + +let last_env = ref empty +let last_reduced_env = ref empty + +let keep_only_summary env = + if !last_env == env then !last_reduced_env + else + let new_env = + { + empty with + summary = env.summary; + local_constraints = env.local_constraints; + flags = env.flags; + } + in + last_env := env; + last_reduced_env := new_env; + new_env + +let env_of_only_summary env_from_summary env = + let new_env = env_from_summary env.summary Subst.identity in + {new_env with local_constraints = env.local_constraints; flags = env.flags} + +(* Error report *) + +open Format + +(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/env.ml#L1842 *) +(* modified branches are commented *) +let report_error ppf = function + | Illegal_renaming (name, modname, _filename) -> + (* modified *) + fprintf ppf + "@[You referred to the module %s, but we've found one called %s \ + instead.@ Is the name's casing right?@]" + name modname + | Inconsistent_import (name, source1, source2) -> + (* modified *) + fprintf ppf + "@[@[@{It's possible that your build is stale.@}@ Try to clean \ + the artifacts and build again?@]@,\ + @,\ + @[@{Here's the original error message@}@]@,\ + @]"; + fprintf ppf + "@[The files %a@ and %a@ make inconsistent assumptions@ over \ + interface %s@]" + Location.print_filename source1 Location.print_filename source2 name + | Missing_module (_, path1, path2) -> + fprintf ppf "@[@["; + if Path.same path1 path2 then + fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1) + else + fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling." + (Path.name path1) (Path.name path2); + fprintf ppf "@]@ @[%s@ %s@ %s.@]@]" "The compiled interface for module" + (Ident.name (Path.head path2)) + "was not found" + | Illegal_value_name (_loc, name) -> + fprintf ppf "'%s' is not a valid value identifier." name + +let () = + Location.register_error_of_exn (function + | Error ((Missing_module (loc, _, _) | Illegal_value_name (loc, _)) as err) + when loc <> Location.none -> + Some (Location.error_of_printer loc report_error err) + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None) diff --git a/compiler/ml/env.mli b/compiler/ml/env.mli new file mode 100644 index 0000000..48eaba1 --- /dev/null +++ b/compiler/ml/env.mli @@ -0,0 +1,329 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Environment handling *) + +open Types + +module PathMap : + Map.S with type key = Path.t and type 'a t = 'a Map.Make(Path).t + +type summary = + | Env_empty + | Env_value of summary * Ident.t * value_description + | Env_type of summary * Ident.t * type_declaration + | Env_extension of summary * Ident.t * extension_constructor + | Env_module of summary * Ident.t * module_declaration + | Env_modtype of summary * Ident.t * modtype_declaration + | Env_open of summary * Path.t + | Env_functor_arg of summary * Ident.t + | Env_constraints of summary * type_declaration PathMap.t + | Env_copy_types of summary * string list + +type t + +val empty : t +val initial_safe_string : t + +val diff : t -> t -> Ident.t list +val copy_local : from:t -> t -> t + +type type_descriptions = constructor_description list * label_description list + +(* For short-paths *) +type iter_cont +val iter_types : + (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> + t -> + iter_cont +val run_iter_cont : iter_cont list -> (Path.t * iter_cont) list +val same_types : t -> t -> bool +val used_persistent : unit -> Concr.t +val find_shadowed_types : Path.t -> t -> Path.t list +val without_cmis : ('a -> 'b) -> 'a -> 'b +(* [without_cmis f arg] applies [f] to [arg], but does not + allow opening cmis during its execution *) + +(* Lookup by paths *) + +val find_value : Path.t -> t -> value_description +val find_type : Path.t -> t -> type_declaration +val find_type_descrs : Path.t -> t -> type_descriptions +val find_module : Path.t -> t -> module_declaration +val find_modtype : Path.t -> t -> modtype_declaration + +val find_type_expansion : Path.t -> t -> type_expr list * type_expr * int option +val find_type_expansion_opt : + Path.t -> t -> type_expr list * type_expr * int option + +(* Find the manifest type information associated to a type for the sake + of the compiler's type-based optimisations. *) +val find_modtype_expansion : Path.t -> t -> module_type +val add_functor_arg : Ident.t -> t -> t +val is_functor_arg : Path.t -> t -> bool +val normalize_path : Location.t option -> t -> Path.t -> Path.t + +(* Normalize the path to a concrete value or module. + If the option is None, allow returning dangling paths. + Otherwise raise a Missing_module error, and may add forgotten + head as required global. *) +val normalize_path_prefix : Location.t option -> t -> Path.t -> Path.t +(* Only normalize the prefix part of the path *) + +val has_local_constraints : t -> bool +val add_gadt_instance_level : int -> t -> t +val gadt_instance_level : t -> type_expr -> int option +val add_gadt_instances : t -> int -> type_expr list -> unit +val add_gadt_instance_chain : t -> int -> type_expr -> unit + +(* Lookup by long identifiers *) + +(* ?loc is used to report 'deprecated module' warnings *) + +val lookup_value : + ?loc:Location.t -> Longident.t -> t -> Path.t * value_description +val lookup_constructor : + ?loc:Location.t -> Longident.t -> t -> constructor_description +val lookup_all_constructors : + ?loc:Location.t -> + Longident.t -> + t -> + (constructor_description * (unit -> unit)) list +val lookup_label : ?loc:Location.t -> Longident.t -> t -> label_description +val lookup_all_labels : + ?loc:Location.t -> + Longident.t -> + t -> + (label_description * (unit -> unit)) list +val lookup_type : ?loc:Location.t -> Longident.t -> t -> Path.t +(* Since 4.04, this function no longer returns [type_description]. + To obtain it, you should either call [Env.find_type], or replace + it by [Typetexp.find_type] *) + +val lookup_module : load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t +val lookup_modtype : + ?loc:Location.t -> Longident.t -> t -> Path.t * modtype_declaration + +val copy_types : string list -> t -> t +(* Used only in Typecore.duplicate_ident_types. *) + +exception Recmodule +(* Raise by lookup_module when the identifier refers + to one of the modules of a recursive definition + during the computation of its approximation (see #5965). *) + +(* Insertion by identifier *) + +val add_value : + ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t +val add_type : check:bool -> Ident.t -> type_declaration -> t -> t +val add_extension : check:bool -> Ident.t -> extension_constructor -> t -> t +val add_module : ?arg:bool -> Ident.t -> module_type -> t -> t +val add_module_declaration : + ?arg:bool -> check:bool -> Ident.t -> module_declaration -> t -> t +val add_modtype : Ident.t -> modtype_declaration -> t -> t + +val add_local_constraint : Path.t -> type_declaration -> int -> t -> t +val add_local_type : Path.t -> type_declaration -> t -> t + +(* Insertion of all fields of a signature. *) + +val add_item : signature_item -> t -> t +val add_signature : signature -> t -> t + +(* Insertion of all fields of a signature, relative to the given path. + Used to implement open. Returns None if the path refers to a functor, + not a structure. *) +val open_signature : + ?used_slot:bool ref -> + ?loc:Location.t -> + ?toplevel:bool -> + Asttypes.override_flag -> + Path.t -> + t -> + t option + +(* Insertion by name *) + +val enter_value : + ?check:(string -> Warnings.t) -> + string -> + value_description -> + t -> + Ident.t * t +val enter_type : string -> type_declaration -> t -> Ident.t * t +val enter_extension : string -> extension_constructor -> t -> Ident.t * t +val enter_module : ?arg:bool -> string -> module_type -> t -> Ident.t * t +val enter_module_declaration : + ?arg:bool -> Ident.t -> module_declaration -> t -> t +val enter_modtype : string -> modtype_declaration -> t -> Ident.t * t + +(* Initialize the cache of in-core module interfaces. *) +val reset_cache : unit -> unit + +(* To be called before each toplevel phrase. *) +val reset_cache_toplevel : unit -> unit + +(* Remember the name of the current compilation unit. *) +val set_unit_name : string -> unit +val get_unit_name : unit -> string + +(* Read, save a signature to/from a file *) + +val read_signature : string -> string -> signature +(* Arguments: module name, file name. Results: signature. *) + +val save_signature : + ?check_exists:unit -> + deprecated:string option -> + signature -> + string -> + string -> + Cmi_format.cmi_infos +(* Arguments: signature, module name, file name. *) + +val save_signature_with_imports : + ?check_exists:unit -> + deprecated:string option -> + signature -> + string -> + string -> + (string * Digest.t option) list -> + Cmi_format.cmi_infos +(* Arguments: signature, module name, file name, + imported units with their CRCs. *) + +(* Return the CRC of the interface of the given compilation unit *) + +val crc_of_unit : string -> Digest.t + +(* Return the set of compilation units imported, with their CRC *) + +val imports : unit -> (string * Digest.t option) list + +(* Direct access to the table of imported compilation units with their CRC *) + +val crc_units : Consistbl.t +val add_import : string -> unit + +(* Summaries -- compact representation of an environment, to be + exported in debugging information. *) + +val summary : t -> summary + +(* Return an equivalent environment where all fields have been reset, + except the summary. The initial environment can be rebuilt from the + summary, using Envaux.env_of_only_summary. *) + +val keep_only_summary : t -> t +val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t + +(* Error report *) + +type error = + | Illegal_renaming of string * string * string + | Inconsistent_import of string * string * string + | Missing_module of Location.t * Path.t * Path.t + | Illegal_value_name of Location.t * string + +exception Error of error + +open Format + +val report_error : formatter -> error -> unit + +val mark_value_used : t -> string -> value_description -> unit +val mark_module_used : t -> string -> Location.t -> unit +val mark_type_used : t -> string -> type_declaration -> unit + +type constructor_usage = Positive | Pattern | Privatize +val mark_constructor_used : + constructor_usage -> t -> string -> type_declaration -> string -> unit +val mark_constructor : + constructor_usage -> t -> string -> constructor_description -> unit +val mark_extension_used : + constructor_usage -> t -> extension_constructor -> string -> unit + +val in_signature : bool -> t -> t +val implicit_coercion : t -> t + +val is_in_signature : t -> bool + +val set_value_used_callback : + string -> value_description -> (unit -> unit) -> unit +val set_type_used_callback : + string -> type_declaration -> ((unit -> unit) -> unit) -> unit + +(* Forward declaration to break mutual recursion with Includemod. *) +val check_modtype_inclusion : + (loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref + +(* Forward declaration to break mutual recursion with Mtype. *) +val strengthen : + (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref + +(* Forward declaration to break mutual recursion with Ctype. *) +val same_constr : (t -> type_expr -> type_expr -> bool) ref + +(** Folding over all identifiers (for analysis purpose) *) + +val fold_values : + (string -> Path.t -> value_description -> 'a -> 'a) -> + Longident.t option -> + t -> + 'a -> + 'a +val fold_types : + (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) -> + Longident.t option -> + t -> + 'a -> + 'a +val fold_constructors : + (constructor_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a +val fold_labels : + (label_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a + +val fold_modules : + (string -> Path.t -> module_declaration -> 'a -> 'a) -> + Longident.t option -> + t -> + 'a -> + 'a +(** Persistent structures are only traversed if they are already loaded. *) + +val fold_modtypes : + (string -> Path.t -> modtype_declaration -> 'a -> 'a) -> + Longident.t option -> + t -> + 'a -> + 'a + +val scrape_alias : t -> module_type -> module_type +(** Utilities *) + +val check_value_name : string -> Location.t -> unit + +module Persistent_signature : sig + type t = { + filename: string; (** Name of the file containing the signature. *) + cmi: Cmi_format.cmi_infos; + } + + val load : (unit_name:string -> t option) ref + (** Function used to load a persistent signature. The default is to look for + the .cmi file in the load path. This function can be overridden to load + it from memory, for instance to build a self-contained toplevel. *) +end diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml new file mode 100644 index 0000000..1805844 --- /dev/null +++ b/compiler/ml/error_message_utils.ml @@ -0,0 +1,932 @@ +type extract_concrete_typedecl = + Env.t -> Types.type_expr -> Path.t * Path.t * Types.type_declaration + +let configured_jsx_module : string option ref = ref None + +let with_configured_jsx_module s = + match !configured_jsx_module with + | None -> s + | Some module_name -> module_name ^ "." ^ s + +module Parser : sig + type comment + + val extract_text_at_loc : Location.t -> string + + val parse_source : (string -> Parsetree.structure * comment list) ref + + val reprint_source : (Parsetree.structure -> comment list -> string) ref + + val parse_expr_at_loc : + Warnings.loc -> (Parsetree.expression * comment list) option + + val reprint_expr_at_loc : + ?mapper:(Parsetree.expression -> Parsetree.expression option) -> + Warnings.loc -> + string option +end = struct + type comment + + let parse_source : (string -> Parsetree.structure * comment list) ref = + ref (fun _ -> ([], [])) + + let reprint_source : (Parsetree.structure -> comment list -> string) ref = + ref (fun _ _ -> "") + + let extract_location_string ~src (loc : Location.t) = + let start_pos = loc.loc_start in + let end_pos = loc.loc_end in + let start_offset = start_pos.pos_cnum in + let end_offset = end_pos.pos_cnum in + String.sub src start_offset (end_offset - start_offset) + + let extract_text_at_loc loc = + if loc.Location.loc_start.pos_fname = "_none_" then "" + else + try + (* TODO: Maybe cache later on *) + let src = Ext_io.load_file loc.Location.loc_start.pos_fname in + extract_location_string ~src loc + with _ -> "" + + let parse_expr_at_loc loc = + let sub_src = extract_text_at_loc loc in + let parsed, comments = !parse_source sub_src in + match parsed with + | [{Parsetree.pstr_desc = Pstr_eval (exp, _)}] -> Some (exp, comments) + | _ -> None + + let wrap_in_structure exp = + [{Parsetree.pstr_desc = Pstr_eval (exp, []); pstr_loc = Location.none}] + + let reprint_expr_at_loc ?(mapper = fun _ -> None) loc = + match parse_expr_at_loc loc with + | Some (exp, comments) -> ( + match mapper exp with + | Some exp -> + Some (!reprint_source (wrap_in_structure exp) comments |> String.trim) + | None -> None) + | None -> None +end + +let type_expr ppf typ = + (* print a type and avoid infinite loops *) + Printtyp.reset_and_mark_loops typ; + Printtyp.type_expr ppf typ + +type jsx_prop_error_info = { + fields: Types.label_declaration list; + props_record_path: Path.t; + jsx_type: [`Fragment | `CustomComponent | `LowercaseComponent]; +} + +type type_clash_statement = FunctionCall +type type_clash_context = + | SetRecordField of string (* field name *) + | RecordField of { + jsx: jsx_prop_error_info option; + record_type: Types.type_expr; + field_name: string; + optional: bool; + } + | ArrayValue + | MaybeUnwrapOption + | IfCondition + | AssertCondition + | IfReturn + | TernaryReturn + | SwitchReturn + | LetUnwrapReturn + | TryReturn + | StringConcat + | ComparisonOperator + | WhileCondition + | MathOperator of { + for_float: bool; + operator: string; + is_constant: string option; + } + | FunctionArgument of {optional: bool; name: string option} + | BracedIdent + | Statement of type_clash_statement + | ForLoopCondition + | Await + +let context_to_string = function + | Some WhileCondition -> "WhileCondition" + | Some ForLoopCondition -> "ForLoopCondition" + | Some AssertCondition -> "AssertCondition" + | Some IfCondition -> "IfCondition" + | Some (Statement _) -> "Statement" + | Some (MathOperator _) -> "MathOperator" + | Some ArrayValue -> "ArrayValue" + | Some (SetRecordField _) -> "SetRecordField" + | Some (RecordField _) -> "RecordField" + | Some MaybeUnwrapOption -> "MaybeUnwrapOption" + | Some SwitchReturn -> "SwitchReturn" + | Some TryReturn -> "TryReturn" + | Some StringConcat -> "StringConcat" + | Some (FunctionArgument _) -> "FunctionArgument" + | Some ComparisonOperator -> "ComparisonOperator" + | Some IfReturn -> "IfReturn" + | Some TernaryReturn -> "TernaryReturn" + | Some Await -> "Await" + | Some BracedIdent -> "BracedIdent" + | Some LetUnwrapReturn -> "LetUnwrapReturn" + | None -> "None" + +let fprintf = Format.fprintf + +let error_type_text ppf type_clash_context = + let text = + match type_clash_context with + | Some (Statement FunctionCall) -> "This function call returns:" + | Some (MathOperator {is_constant = Some _}) -> "This value has type:" + | Some ArrayValue -> "This array item has type:" + | Some (SetRecordField _) -> + "You're assigning something to this field that has type:" + | _ -> "This has type:" + in + fprintf ppf "%s" text + +let error_expected_type_text ppf type_clash_context = + match type_clash_context with + | Some (FunctionArgument {optional; name}) -> + fprintf ppf "But this%s function argument" + (match optional with + | false -> "" + | true -> " optional"); + + (match name with + | Some name -> fprintf ppf " @{~%s@}" name + | None -> ()); + + fprintf ppf " is expecting:" + | Some ComparisonOperator -> + fprintf ppf "But it's being compared to something of type:" + | Some SwitchReturn -> fprintf ppf "But this switch is expected to return:" + | Some LetUnwrapReturn -> + fprintf ppf "But this @{let?@} is used where this type is expected:" + | Some TryReturn -> fprintf ppf "But this try/catch is expected to return:" + | Some WhileCondition -> + fprintf ppf "But a @{while@} loop condition must always be of type:" + | Some ForLoopCondition -> + fprintf ppf "But a @{for@} loop bounds must always be of type:" + | Some IfCondition -> + fprintf ppf "But @{if@} conditions must always be of type:" + | Some AssertCondition -> fprintf ppf "But assertions must always be of type:" + | Some IfReturn -> + fprintf ppf "But this @{if@} statement is expected to return:" + | Some TernaryReturn -> fprintf ppf "But this ternary is expected to return:" + | Some ArrayValue -> + fprintf ppf "But this array is expected to have items of type:" + | Some (SetRecordField _) -> fprintf ppf "But the record field is of type:" + | Some + (RecordField {field_name = "children"; jsx = Some {jsx_type = `Fragment}}) + -> + fprintf ppf "But children of JSX fragments must be of type:" + | Some + (RecordField + {field_name = "children"; jsx = Some {jsx_type = `CustomComponent}}) -> + fprintf ppf "But children passed to this component must be of type:" + | Some (RecordField {field_name; jsx = Some _}) -> + fprintf ppf "But the component prop @{%s@} is expected to have type:" + field_name + | Some (RecordField {field_name}) -> + fprintf ppf "But the record field @{%s@} is expected to have type:" + field_name + | Some (Statement FunctionCall) -> fprintf ppf "But it's expected to return:" + | Some (MathOperator {operator}) -> + fprintf ppf + "But it's being used with the @{%s@} operator, which works on:" + operator + | Some StringConcat -> fprintf ppf "But string concatenation is expecting:" + | Some Await -> + fprintf ppf + "But you're using @{await@} on this expression, so it is expected \ + to be of type:" + | Some MaybeUnwrapOption | Some BracedIdent | None -> + fprintf ppf "But it's expected to have type:" + +let is_record_type ~(extract_concrete_typedecl : extract_concrete_typedecl) ~env + ty = + try + match extract_concrete_typedecl env ty with + | _, _, {Types.type_kind = Type_record _; _} -> true + | _ -> false + with _ -> false + +let is_variant_type ~(extract_concrete_typedecl : extract_concrete_typedecl) + ~env ty = + try + match extract_concrete_typedecl env ty with + | _, _, {Types.type_kind = Type_variant _; _} -> true + | _ -> false + with _ -> false + +let get_variant_constructors + ~(extract_concrete_typedecl : extract_concrete_typedecl) ~env ty = + match extract_concrete_typedecl env ty with + | _, _, {Types.type_kind = Type_variant constructors; _} -> constructors + | _ -> [] + +let extract_string_constant text = + match !Parser.parse_source text with + | ( [ + { + Parsetree.pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _); + }; + ], + _ ) -> + Some s + | _ -> None + +let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf + (bottom_aliases : (Types.type_expr * Types.type_expr) option) trace + type_clash_context = + match (type_clash_context, bottom_aliases) with + | Some (MathOperator {for_float; operator; is_constant}), _ -> ( + let operator_for_other_type = + match operator with + | "+" -> "+." + | "+." -> "+" + | "/" -> "/." + | "/." -> "/" + | "-" -> "-." + | "*" -> "*." + | "*." -> "*" + | v -> v + in + let operator_text = + match operator.[0] with + | '+' -> "add" + | '-' -> "subtract" + | '/' -> "divide" + | '*' -> "multiply" + | _ -> "compute" + in + (* TODO check int vs float explicitly before showing this *) + (match (operator, bottom_aliases) with + | "+", Some ({Types.desc = Tconstr (p1, _, _)}, {desc = Tconstr (p2, _, _)}) + when Path.same Predef.path_string p1 || Path.same Predef.path_string p2 -> + fprintf ppf + "\n\n\ + \ Are you looking to concatenate strings? Use the operator \ + @{++@}, which concatenates strings.\n\n\ + \ Possible solutions:\n\ + \ - Change the @{+@} operator to @{++@} to concatenate \ + strings instead." + | _ -> + fprintf ppf + "\n\n\ + \ Floats and ints have their own mathematical operators. This means \ + you cannot %s a float and an int without converting between the two.\n\n\ + \ Possible solutions:\n\ + \ - Ensure all values in this calculation have the type @{%s@}. \ + You can convert between floats and ints via @{Float.toInt@} and \ + @{Int.fromFloat@}." + operator_text + (if for_float then "float" else "int")); + match (is_constant, bottom_aliases) with + | Some constant, _ -> + if for_float then + fprintf ppf + "\n\ + \ - Make @{%s@} a @{float@} by adding a trailing dot: \ + @{%s.@}" + constant constant + else + fprintf ppf + "\n\ + \ - Make @{%s@} an @{int@} by removing the dot or \ + explicitly converting to int" + constant + | _, Some ({Types.desc = Tconstr (p1, _, _)}, {desc = Tconstr (p2, _, _)}) + -> ( + match (Path.name p1, Path.name p2) with + | "float", "int" | "int", "float" -> + fprintf ppf + "\n\ + \ - Change the operator to @{%s@}, which works on @{%s@}" + operator_for_other_type + (if for_float then "int" else "float") + | _ -> ()) + | _ -> ()) + | Some SwitchReturn, _ -> + fprintf ppf + "\n\n\ + \ All branches in a @{switch@} must return the same type.@,\ + To fix this, change your branch to return the expected type." + | Some LetUnwrapReturn, bottom_aliases -> ( + let kind = + match bottom_aliases with + | Some ({Types.desc = Tconstr (p, _, _)}, _) + when Path.same p Predef.path_option -> + `Option + | Some (_, {Types.desc = Tconstr (p, _, _)}) + when Path.same p Predef.path_option -> + `Option + | Some ({Types.desc = Tconstr (p, _, _)}, _) + when Path.same p Predef.path_result -> + `Result + | Some (_, {Types.desc = Tconstr (p, _, _)}) + when Path.same p Predef.path_result -> + `Result + | _ -> `Unknown + in + match kind with + | `Option -> + fprintf ppf + "\n\n\ + \ This @{let?@} unwraps an @{option@}; use it where the \ + enclosing function or let binding returns an @{option@} so \ + @{None@} can propagate.\n\n\ + \ Possible solutions:\n\ + \ - Change the enclosing function or let binding to return \ + @{option<'t>@} and use @{Some@} for success; \ + @{let?@} will propagate @{None@}.\n\ + \ - Replace @{let?@} with a @{switch@} and handle the \ + @{None@} case explicitly.\n\ + \ - If you want a default value instead of early return, unwrap using \ + @{Option.getOr(default)@}." + | `Result -> + fprintf ppf + "\n\n\ + \ This @{let?@} unwraps a @{result@}; use it where the \ + enclosing function or let binding returns a @{result@} so \ + @{Error@} can propagate.\n\n\ + \ Possible solutions:\n\ + \ - Change the enclosing function or let binding to return \ + @{result<'ok, 'error>@}; use @{Ok@} for success, and \ + @{let?@} will propagate @{Error@}.\n\ + \ - Replace @{let?@} with a @{switch@} and handle the \ + @{Error@} case explicitly.\n\ + \ - If you want a default value instead of early return, unwrap using \ + @{Result.getOr(default)@}." + | `Unknown -> + fprintf ppf + "\n\n\ + \ @{let?@} can only be used in a context that expects \ + @{option@} or @{result@}.\n\n\ + \ Possible solutions:\n\ + \ - Change the enclosing function or let binding to return an \ + @{option<'t>@} or @{result<'ok, 'error>@} and propagate \ + with @{Some/Ok@}.\n\ + \ - Replace @{let?@} with a @{switch@} and handle the \ + @{None/Error@} case explicitly.\n\ + \ - If you want a default value instead of early return, unwrap using \ + @{Option.getOr(default)@} or @{Result.getOr(default)@}.") + | Some TryReturn, _ -> + fprintf ppf + "\n\n\ + \ The @{try@} body and the @{catch@} block must return the \ + same type.@,\ + To fix this, change your try/catch blocks to return the expected type." + | Some IfCondition, _ -> + fprintf ppf + "\n\n\ + \ To fix this, change the highlighted code so it evaluates to a \ + @{bool@}." + | Some Await, _ -> + fprintf ppf + "\n\n\ + \ You're trying to await something that is not a promise.\n\n\ + Possible solutions:\n\ + \ - Remove the @{await@} if this is not expected to be a promise\n\ + \ - Wrap the expression in @{Promise.resolve@} to convert the \ + expression to a promise" + | Some IfReturn, _ -> + fprintf ppf + "\n\n\ + \ @{if@} expressions must return the same type in all branches \ + (@{if@}, @{else if@}, @{else@})." + | Some TernaryReturn, _ -> + fprintf ppf + "\n\n\ + \ Ternaries (@{?@} and @{:@}) must return the same type in \ + both branches." + | Some MaybeUnwrapOption, _ -> + fprintf ppf + "\n\n\ + \ Possible solutions:\n\ + \ - Unwrap the option to its underlying value using \ + `yourValue->Option.getOr(someDefaultValue)`" + | Some ComparisonOperator, _ -> + fprintf ppf "\n\n You can only compare things of the same type." + | Some ArrayValue, _ -> + fprintf ppf + "\n\n\ + \ Arrays can only contain items of the same type.\n\n\ + \ Possible solutions:\n\ + \ - Convert all values in the array to the same type.\n\ + \ - Use a tuple, if your array is of fixed length. Tuples can mix types \ + freely, and compiles to a JavaScript array. Example of a tuple: `let \ + myTuple = (10, \"hello\", 15.5, true)" + | _, Some (_, {desc = Tconstr (p2, _, _)}) when Path.same Predef.path_dict p2 + -> + fprintf ppf + "@,@,Dicts are written like: @{dict{\"a\": 1, \"b\": 2}@}@," + | ( _, + Some + (({Types.desc = Tconstr (_p1, _, _)} as ty), {desc = Tconstr (p2, _, _)}) + ) + when Path.same Predef.path_unit p2 -> + fprintf ppf "\n\n"; + let is_jsx_element = + match Ctype.expand_head env ty with + | {desc = Tconstr (Pdot (Pident {name = "Jsx"}, "element", _), _, _)} -> + true + | _ -> false + in + if is_jsx_element then + fprintf ppf + " - Did you forget to wrap this + adjacent JSX in a JSX fragment \ + (@{<>@})?\n\ + \ - Did you mean to assign this to a variable?\n\n" + else + fprintf ppf + " - Did you mean to assign this to a variable?\n\ + \ - If you don't care about the result of this expression, you can \ + assign it to @{_@} via @{let _ = ...@} or pipe it to \ + @{ignore@} via @{expression->ignore@}\n\n" + | _, Some ({desc = Tobject _}, ({Types.desc = Tconstr _} as t1)) + when is_record_type ~extract_concrete_typedecl ~env t1 -> + fprintf ppf + "@,\ + @,\ + You're passing a @{ReScript object@} where a @{record@} is \ + expected. Objects are written with quoted keys, and records with \ + unquoted keys."; + + let suggested_rewrite = + Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> + match exp.Parsetree.pexp_desc with + | Pexp_extension + ( {txt = "obj"}, + PStr + [ + { + pstr_desc = + Pstr_eval (({pexp_desc = Pexp_record _} as record), _); + }; + ] ) -> + Some record + | _ -> None) + in + fprintf ppf + "@,\ + @,\ + Possible solutions: @,\ + - Rewrite the object to a record%s@{%s@}@," + (match suggested_rewrite with + | Some _ -> ", like: " + | None -> "") + (match suggested_rewrite with + | Some rewrite -> rewrite + | None -> "") + | _, Some ({Types.desc = Tconstr (p1, _, _)}, _) + when Path.same p1 Predef.path_promise -> + fprintf ppf "\n\n - Did you mean to await this promise before using it?\n" + | _, Some ({Types.desc = Tconstr (p1, _, _)}, {Types.desc = Ttuple _}) + when Path.same p1 Predef.path_array -> + let suggested_rewrite = + Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> + match exp.Parsetree.pexp_desc with + | Pexp_array items -> + Some {exp with Parsetree.pexp_desc = Pexp_tuple items} + | _ -> None) + in + fprintf ppf + "\n\n - Fix this by passing a tuple instead of an array%s@{%s@}\n" + (match suggested_rewrite with + | Some _ -> ", like: " + | None -> "") + (match suggested_rewrite with + | Some rewrite -> rewrite + | None -> "") + | ( _, + Some + ( {desc = Tconstr (p, type_params, _)}, + {desc = Tconstr (Pdot (Pident {name = "Jsx"}, "element", _), _, _)} ) + ) -> ( + (* Looking for a JSX element but got something else *) + let is_jsx_element ty = + match Ctype.expand_head env ty with + | {desc = Tconstr (Pdot (Pident {name = "Jsx"}, "element", _), _, _)} -> + true + | _ -> false + in + + let print_jsx_msg ?(extra = "") name target_fn = + fprintf ppf + "@,\ + @,\ + In JSX, all content must be JSX elements. You can convert %s to a JSX \ + element with @{%s@}%s.@," + name target_fn extra + in + + match type_params with + | _ when Path.same p Predef.path_int -> + print_jsx_msg "int" (with_configured_jsx_module "int") + | _ when Path.same p Predef.path_string -> + print_jsx_msg "string" (with_configured_jsx_module "string") + | _ when Path.same p Predef.path_float -> + print_jsx_msg "float" (with_configured_jsx_module "float") + | [_] when Path.same p Predef.path_option -> + fprintf ppf + "@,\ + @,\ + You need to unwrap this option to its underlying value first, then \ + turn that value into a JSX element.@,\ + For @{None@}, you can use @{%s@} to output nothing into \ + JSX.@," + (with_configured_jsx_module "null") + | [tp] when Path.same p Predef.path_array && is_jsx_element tp -> + print_jsx_msg + ~extra: + (" (for example by using a pipe: ->" + ^ with_configured_jsx_module "array" + ^ ".") + "array" + (with_configured_jsx_module "array") + | [_] when Path.same p Predef.path_array -> + fprintf ppf + "@,\ + @,\ + You need to convert each item in this array to a JSX element first, \ + then use @{%s@} to convert the array of JSX elements into a \ + single JSX element.@," + (with_configured_jsx_module "array") + | _ -> ()) + | ( Some (RecordField {optional = true; field_name; jsx = None}), + Some ({desc = Tconstr (p, _, _)}, _) ) + when Path.same Predef.path_option p -> + fprintf ppf + "@,\ + @,\ + @{%s@} is an optional record field, and you're passing an \ + optional value to it.@,\ + Values passed to an optional record field don't need to be wrapped in \ + an option. You might need to adjust the type of the value supplied.\n\ + \ @,\ + Possible solutions: @,\ + - Unwrap the option from the value you're passing in@,\ + - If you really do want to pass the optional value, prepend the value \ + with @{?@} to show you want to pass the option, like: \ + @{{%s: ?%s@}}" + field_name field_name + (Parser.extract_text_at_loc loc) + | ( Some (RecordField {optional = true; field_name; jsx = Some _}), + Some ({desc = Tconstr (p, _, _)}, _) ) + when Path.same Predef.path_option p -> + fprintf ppf + "@,\ + @,\ + @{%s@} is an optional component prop, and you're passing an \ + optional value to it.@,\ + Values passed to an optional component prop don't need to be wrapped in \ + an option. You might need to adjust the type of the value supplied.\n\ + \ @,\ + Possible solutions: @,\ + - Unwrap the option from the value you're passing in@,\ + - If you really do want to pass the optional value, prepend the value \ + with @{?@} to show you want to pass the option, like: \ + @{%s=?%s@}" + field_name field_name + (Parser.extract_text_at_loc loc) + | ( Some (FunctionArgument {optional = true}), + Some ({desc = Tconstr (p, _, _)}, _) ) + when Path.same Predef.path_option p -> + fprintf ppf + "@,\ + @,\ + You're passing an optional value into an optional function argument.@,\ + Values passed to an optional function argument don't need to be wrapped \ + in an option. You might need to adjust the type of the value supplied.\n\ + \ @,\ + Possible solutions: @,\ + - Unwrap the option from the value you're passing in@,\ + - If you really do want to pass the optional value, prepend the value \ + with @{?@} to show you want to pass the option, like: \ + @{?%s@}" + (Parser.extract_text_at_loc loc) + | Some BracedIdent, Some (_, ({desc = Tconstr (_, _, _)} as t)) + when is_record_type ~extract_concrete_typedecl ~env t -> + fprintf ppf + "@,\ + @,\ + You might have meant to pass this as a record, but wrote it as a block.@,\ + Braces with a single identifier counts as a block, not a record with a \ + single (punned) field.@,\ + @,\ + Possible solutions: @,\ + - Write out the full record with field and value, like: @{%s@}@,\ + - Return the expected record from the block" + (match + Parser.reprint_expr_at_loc + ~mapper:(fun e -> + match e.pexp_desc with + | Pexp_ident {txt} -> + Some + { + e with + pexp_desc = + Pexp_record + ([{lid = Location.mknoloc txt; opt = false; x = e}], None); + } + | _ -> None) + loc + with + | None -> "" + | Some s -> s) + | _, Some ({Types.desc = Tconstr (p1, _, _)}, {desc = Tvariant row_desc}) + when Path.same Predef.path_string p1 -> ( + (* Check if we have a string constant that could be a polymorphic variant constructor *) + let target_expr_text = Parser.extract_text_at_loc loc in + match extract_string_constant target_expr_text with + | Some string_value -> ( + let variant_constructors = List.map fst row_desc.row_fields in + let reprinted = + Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> + match exp.Parsetree.pexp_desc with + | Pexp_constant (Pconst_string (s, _)) -> + Some {exp with Parsetree.pexp_desc = Pexp_variant (s, None)} + | _ -> None) + in + match (reprinted, List.mem string_value variant_constructors) with + | Some reprinted, true -> + fprintf ppf + "\n\n\ + \ Possible solutions:\n\ + \ - The constant passed matches one of the expected polymorphic \ + variant constructors. Did you mean to pass this as a polymorphic \ + variant? If so, rewrite @{\"%s\"@} to @{%s@}" + string_value reprinted + | _ -> ()) + | None -> ()) + | _, Some ({Types.desc = Tconstr (p1, _, _)}, ({desc = Tconstr _} as t2)) + when Path.same Predef.path_string p1 + && is_variant_type ~extract_concrete_typedecl ~env t2 -> ( + (* Check if we have a string constant that could be a regular variant constructor *) + let target_expr_text = Parser.extract_text_at_loc loc in + match extract_string_constant target_expr_text with + | Some string_value -> ( + let constructors = + get_variant_constructors ~extract_concrete_typedecl ~env t2 + in + (* Extract runtime representations from constructor declarations *) + let constructor_mappings = + List.filter_map + (fun (cd : Types.constructor_declaration) -> + let constructor_name = Ident.name cd.cd_id in + let runtime_repr = + match Ast_untagged_variants.process_tag_type cd.cd_attributes with + | Some (String s) -> Some s (* @as("string_value") *) + | Some _ -> None (* @as with non-string values *) + | None -> Some constructor_name (* No @as, use constructor name *) + in + match runtime_repr with + | Some repr -> Some (repr, constructor_name) + | None -> None) + constructors + in + let matching_constructor = + List.find_opt + (fun (runtime_repr, _) -> runtime_repr = string_value) + constructor_mappings + in + match matching_constructor with + | Some (_, constructor_name) -> ( + let reprinted = + Parser.reprint_expr_at_loc loc ~mapper:(fun exp -> + match exp.Parsetree.pexp_desc with + | Pexp_constant (Pconst_string (_, _)) -> + Some + { + exp with + Parsetree.pexp_desc = + Pexp_construct + ( {txt = Lident constructor_name; loc = exp.pexp_loc}, + None ); + } + | _ -> None) + in + match reprinted with + | Some reprinted -> + fprintf ppf + "\n\n\ + \ Possible solutions:\n\ + \ - The constant passed matches the runtime representation of one \ + of the expected variant constructors. Did you mean to pass this \ + as a variant constructor? If so, rewrite @{\"%s\"@} to \ + @{%s@}" + string_value reprinted + | None -> ()) + | None -> ()) + | _ -> ()) + | _, Some (_supplied_type, target_type) -> + (* Coercion should always target the top level types. *) + let top_level_types = + match trace with + | (_, t1_top) :: (_, t2_top) :: _ -> Some (t1_top, t2_top) + | _ -> None + in + let can_show_coercion_message = + match top_level_types with + | Some ({Types.desc = Tvariant _}, {Types.desc = Tvariant _}) -> + (* Subtyping polymorphic variants give some weird messages sometimes, + so let's turn it off for now. For an example, turn them on again and try: + ``` + let a: [#Resize | #KeyDown] = #Resize + let b: [#Click] = a + ``` + *) + false + | Some (t1, t2) -> ( + try + Ctype.subtype env t1 t2 (); + true + with _ -> false) + | None -> false + in + let target_type_string = Format.asprintf "%a" type_expr target_type in + let target_expr_text = Parser.extract_text_at_loc loc in + let suggested_rewrite = + match + !Parser.parse_source + (Printf.sprintf "(%s :> %s)" target_expr_text target_type_string) + with + | [], _ -> None + | structure, comments -> Some (!Parser.reprint_source structure comments) + in + + (* Suggesting coercion only makes sense for non-constant values. *) + let is_constant = + match !Parser.parse_source target_expr_text with + | ( [{Parsetree.pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant _}, _)}], + _ ) -> + true + | _ -> false + in + + if can_show_coercion_message && not is_constant then ( + fprintf ppf + "@,\ + @,\ + Possible solutions: @,\ + - These types are compatible at runtime. You can use the coercion \ + operator to convert to the expected type"; + match suggested_rewrite with + | Some rewrite -> fprintf ppf ": @{%s@}@," rewrite + | None -> fprintf ppf ": @{:>@}@,") + | _ -> () + +let type_clash_context_from_function sexp sfunct = + let is_constant = + match sexp.Parsetree.pexp_desc with + | Pexp_constant (Pconst_integer (txt, _) | Pconst_float (txt, _)) -> + Some txt + | _ -> None + in + match sfunct.Parsetree.pexp_desc with + | Pexp_ident + {txt = Lident ("==" | "===" | "!=" | "!==" | ">" | ">=" | "<" | "<=")} -> + Some ComparisonOperator + | Pexp_ident {txt = Lident "++"} -> Some StringConcat + | Pexp_ident {txt = Lident (("/." | "*." | "+." | "-.") as operator)} -> + Some (MathOperator {for_float = true; operator; is_constant}) + | Pexp_ident {txt = Lident (("/" | "*" | "+" | "-") as operator)} -> + Some (MathOperator {for_float = false; operator; is_constant}) + | _ -> if Ast_await.is_await_expr sexp then Some Await else None + +let type_clash_context_for_function_argument ~label type_clash_context sarg0 = + match type_clash_context with + | Some (MathOperator {for_float; operator}) -> + Some + (MathOperator + { + for_float; + operator; + is_constant = + (match sarg0.Parsetree.pexp_desc with + | Pexp_constant (Pconst_integer (txt, _) | Pconst_float (txt, _)) + -> + Some txt + | _ -> None); + }) + | None -> + Some + (FunctionArgument + { + optional = false; + name = + (match label with + | Asttypes.Nolabel -> None + | Optional {txt = l} | Labelled {txt = l} -> Some l); + }) + | type_clash_context -> type_clash_context + +let type_clash_context_maybe_option ty_expected ty_res = + match (ty_expected, ty_res) with + | ( {Types.desc = Tconstr (expected_path, _, _)}, + {Types.desc = Tconstr (type_path, _, _)} ) + when Path.same Predef.path_option type_path + && Path.same expected_path Predef.path_option = false -> + Some MaybeUnwrapOption + | _ -> None + +let type_clash_context_in_statement sexp = + match sexp.Parsetree.pexp_desc with + | Pexp_apply {transformed_jsx = false} -> Some (Statement FunctionCall) + | _ -> None + +let print_contextual_unification_error ppf t1 t2 = + (* TODO: Maybe we should do the same for Null.t and Nullable.t as we do for options + below, now that they also are more first class for values that might not exist? *) + match (t1.Types.desc, t2.Types.desc) with + | Tconstr (p1, _, _), Tconstr (p2, _, _) + when Path.same p1 Predef.path_option + && Path.same p2 Predef.path_option <> true -> + fprintf ppf + "@,\ + @\n\ + @[You're expecting the value you're pattern matching on to be an \ + @{option@}, but the value is actually not an option.@ Change your \ + pattern match to work on the concrete value (remove @{Some(_)@} \ + or @{None@} from the pattern) to make it work.@]" + | Tconstr (p1, _, _), Tconstr (p2, _, _) + when Path.same p2 Predef.path_option + && Path.same p1 Predef.path_option <> true -> + fprintf ppf + "@,\ + @\n\ + @[The value you're pattern matching on here is wrapped in an \ + @{option@}, but you're trying to match on the actual value.@ Wrap \ + the highlighted pattern in @{Some()@} to make it work.@]" + | _ -> () + +let attributes_include_jsx_component_props (attrs : Parsetree.attributes) = + attrs + |> List.exists (fun ({Location.txt}, _) -> txt = "res.jsxComponentProps") + +let path_to_jsx_component_name p = + match p |> Path.name |> String.split_on_char '.' |> List.rev with + | "props" :: component_name :: _ -> Some component_name + | _ -> None + +let get_jsx_component_props + ~(extract_concrete_typedecl : extract_concrete_typedecl) env ty p = + match p with + | Path.Pdot (Path.Pident {Ident.name = jsx_module_name}, "fragmentProps", _) + when Some jsx_module_name = !configured_jsx_module -> + Some {props_record_path = p; fields = []; jsx_type = `Fragment} + | _ -> ( + (* TODO: handle lowercase components using JSXDOM.domProps *) + match Path.last p with + | "props" -> ( + try + match extract_concrete_typedecl env ty with + | ( _p0, + _p, + {Types.type_kind = Type_record (fields, _repr); type_attributes} ) + when attributes_include_jsx_component_props type_attributes -> + Some {props_record_path = p; fields; jsx_type = `CustomComponent} + | _ -> None + with _ -> None) + | _ -> None) + +let print_component_name ppf (p : Path.t) = + match path_to_jsx_component_name p with + | Some component_name -> fprintf ppf "@{<%s />@} " component_name + | None -> () + +let print_component_wrong_prop_error ppf (p : Path.t) + (_fields : Types.label_declaration list) name = + fprintf ppf "@["; + (match name with + | "children" -> + fprintf ppf + "@[<2>This JSX component does not accept child elements. It has no \ + @{children@} prop " + | _ -> + fprintf ppf + "@[<2>The prop @{%s@} does not belong to the JSX component " name); + print_component_name ppf p; + fprintf ppf "@]@,@," + +let print_component_labels_missing_error ppf labels + (error_info : jsx_prop_error_info) = + fprintf ppf "@[The component "; + print_component_name ppf error_info.props_record_path; + fprintf ppf "is missing these required props:@\n"; + labels |> List.iter (fun lbl -> fprintf ppf "@ %s" lbl); + fprintf ppf "@]" + +let get_jsx_component_error_info ~extract_concrete_typedecl opath env ty_record + () = + match opath with + | Some (p, _) -> + get_jsx_component_props ~extract_concrete_typedecl env ty_record p + | None -> None diff --git a/compiler/ml/experimental_features.ml b/compiler/ml/experimental_features.ml new file mode 100644 index 0000000..662157b --- /dev/null +++ b/compiler/ml/experimental_features.ml @@ -0,0 +1,25 @@ +type feature = LetUnwrap + +let to_string (f : feature) : string = + match f with + | LetUnwrap -> "LetUnwrap" + +let from_string (s : string) : feature option = + match s with + | "LetUnwrap" -> Some LetUnwrap + | _ -> None + +module FeatureSet = Set.Make (struct + type t = feature + let compare = compare +end) + +let enabled_features : FeatureSet.t ref = ref FeatureSet.empty +let enable_from_string (s : string) = + match from_string s with + | Some f -> enabled_features := FeatureSet.add f !enabled_features + | None -> () + +let reset () = enabled_features := FeatureSet.empty + +let is_enabled (f : feature) = FeatureSet.mem f !enabled_features diff --git a/compiler/ml/experimental_features.mli b/compiler/ml/experimental_features.mli new file mode 100644 index 0000000..5c28eca --- /dev/null +++ b/compiler/ml/experimental_features.mli @@ -0,0 +1,6 @@ +type feature = LetUnwrap + +val enable_from_string : string -> unit +val is_enabled : feature -> bool +val to_string : feature -> string +val reset : unit -> unit diff --git a/compiler/ml/includecore.ml b/compiler/ml/includecore.ml new file mode 100644 index 0000000..05753d3 --- /dev/null +++ b/compiler/ml/includecore.ml @@ -0,0 +1,486 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the core language *) + +open Asttypes +open Path +open Types +open Typedtree + +(* Inclusion between value descriptions *) + +exception Dont_match + +(* When comparing externals in signatures, re-derive arity/from_constructor from + the value's type so abstract aliases (e.g. opaque function types) don't keep + default zeros stored in the primitive descriptor, which would make equal + externals look different. *) +let normalize_primitive ~env val_type (prim : Primitive.description) = + match Ctype.get_arity env val_type with + | Some prim_arity -> + let prim_from_constructor = + match (Ctype.repr val_type).desc with + | Tconstr _ -> true + | _ -> prim.prim_from_constructor + in + Primitive.with_arity prim ~arity:prim_arity + ~from_constructor:prim_from_constructor + | None -> prim + +let value_descriptions ~loc env name (vd1 : Types.value_description) + (vd2 : Types.value_description) = + Builtin_attributes.check_deprecated_inclusion ~def:vd1.val_loc + ~use:vd2.val_loc loc vd1.val_attributes vd2.val_attributes (Ident.name name); + if Ctype.moregeneral env true vd1.val_type vd2.val_type then + match (vd1.val_kind, vd2.val_kind) with + | Val_prim p1, Val_prim p2 -> + let p1 = normalize_primitive ~env vd1.val_type p1 in + let p2 = normalize_primitive ~env vd2.val_type p2 in + if !Primitive.coerce p1 p2 then Tcoerce_none else raise Dont_match + | Val_prim p, _ -> + let pc = + { + pc_desc = p; + pc_type = vd2.Types.val_type; + pc_env = env; + pc_loc = vd1.Types.val_loc; + pc_id = name; + } + in + Tcoerce_primitive pc + | _, Val_prim _ -> raise Dont_match + | _, _ -> Tcoerce_none + else raise Dont_match + +(* Inclusion between "private" annotations *) + +let private_flags decl1 decl2 = + match (decl1.type_private, decl2.type_private) with + | Private, Public -> + decl2.type_kind = Type_abstract + && (decl2.type_manifest = None || decl1.type_kind <> Type_abstract) + | _, _ -> true + +(* Inclusion between manifest types (particularly for private row types) *) + +let is_absrow env ty = + match ty.desc with + | Tconstr (Pident _, _, _) -> ( + match Ctype.expand_head env ty with + | {desc = Tobject _ | Tvariant _} -> true + | _ -> false) + | _ -> false + +let type_manifest env ty1 params1 ty2 params2 priv2 = + let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in + match (ty1'.desc, ty2'.desc) with + | Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> + let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in + Ctype.equal env true (ty1 :: params1) (row2.row_more :: params2) + && (match row1.row_more with + | {desc = Tvar _ | Tconstr _ | Tnil} -> true + | _ -> false) + && + let r1, r2, pairs = + Ctype.merge_row_fields row1.row_fields row2.row_fields + in + ((not row2.row_closed) + || (row1.row_closed && Ctype.filter_row_fields false r1 = [])) + && List.for_all + (fun (_, f) -> + match Btype.row_field_repr f with + | Rabsent | Reither _ -> true + | Rpresent _ -> false) + r2 + && + let to_equal = ref (List.combine params1 params2) in + List.for_all + (fun (_, f1, f2) -> + match (Btype.row_field_repr f1, Btype.row_field_repr f2) with + | Rpresent (Some t1), (Rpresent (Some t2) | Reither (false, [t2], _, _)) + -> + to_equal := (t1, t2) :: !to_equal; + true + | Rpresent None, (Rpresent None | Reither (true, [], _, _)) -> true + | Reither (c1, tl1, _, _), Reither (c2, tl2, _, _) + when List.length tl1 = List.length tl2 && c1 = c2 -> + to_equal := List.combine tl1 tl2 @ !to_equal; + true + | Rabsent, (Reither _ | Rabsent) -> true + | _ -> false) + pairs + && + let tl1, tl2 = List.split !to_equal in + Ctype.equal env true tl1 tl2 + | Tobject (fi1, _), Tobject (fi2, _) + when is_absrow env (snd (Ctype.flatten_fields fi2)) -> + let fields2, rest2 = Ctype.flatten_fields fi2 in + Ctype.equal env true (ty1 :: params1) (rest2 :: params2) + && + let fields1, rest1 = Ctype.flatten_fields fi1 in + (match rest1 with + | {desc = Tnil | Tvar _ | Tconstr _} -> true + | _ -> false) + && + let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in + miss2 = [] + && + let tl1, tl2 = + List.split (List.map (fun (_, _, t1, _, t2) -> (t1, t2)) pairs) + in + Ctype.equal env true (params1 @ tl1) (params2 @ tl2) + | _ -> + let rec check_super ty1 = + Ctype.equal env true (ty1 :: params1) (ty2 :: params2) + || priv2 = Private + && + try + check_super + (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) + with Ctype.Cannot_expand -> false + in + check_super ty1 + +(* Inclusion between type declarations *) + +type type_mismatch = + | Arity + | Privacy + | Kind + | Constraint + | Manifest + | Variance + | Field_type of Ident.t + | Field_mutable of Ident.t + | Field_optional of Ident.t + | Field_arity of Ident.t + | Field_names of int * string * string + | Field_missing of bool * Ident.t + | Record_representation of record_representation * record_representation + | Unboxed_representation of bool (* true means second one is unboxed *) + | Immediate + | Tag_name + | Variant_representation of Ident.t + +let report_type_mismatch0 first second decl ppf err = + let pr fmt = Format.fprintf ppf fmt in + match err with + | Arity -> pr "They have different arities" + | Privacy -> pr "A private type would be revealed" + | Kind -> pr "Their kinds differ" + | Constraint -> pr "Their constraints differ" + | Manifest -> () + | Variance -> pr "Their variances do not agree" + | Field_type s -> pr "The types for field %s are not equal" (Ident.name s) + | Field_mutable s -> + pr "The mutability of field %s is different" (Ident.name s) + | Field_optional s -> + pr "The optional attribute of field %s is different" (Ident.name s) + | Field_arity s -> pr "The arities for field %s differ" (Ident.name s) + | Field_names (n, name1, name2) -> + pr "Fields number %i have different names, %s and %s" n name1 name2 + | Field_missing (b, s) -> + pr "The field %s is only present in %s %s" (Ident.name s) + (if b then second else first) + decl + | Record_representation (_rep1, _rep2) -> + pr "Their internal representations differ" + | Unboxed_representation b -> + pr "Their internal representations differ:@ %s %s %s" + (if b then second else first) + decl "uses unboxed representation" + | Immediate -> pr "%s is not an immediate type" first + | Tag_name -> pr "Their @tag annotations differ" + | Variant_representation s -> + pr "The internal representations for case %s are not equal" (Ident.name s) + +let report_type_mismatch first second decl ppf = + List.iter (fun err -> + if err = Manifest then () + else + Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) + +let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 = + match (arg1, arg2) with + | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> + if List.length arg1 <> List.length arg2 then [Field_arity cstr] + else if + (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) + Ctype.equal env true (params1 @ arg1) (params2 @ arg2) + then [] + else [Field_type cstr] + | Types.Cstr_record l1, Types.Cstr_record l2 -> + compare_records env ~loc params1 params2 0 l1 l2 + | _ -> [Field_type cstr] + +and compare_variants ~loc env params1 params2 n + (cstrs1 : Types.constructor_declaration list) + (cstrs2 : Types.constructor_declaration list) = + match (cstrs1, cstrs2) with + | [], [] -> [] + | [], c :: _ -> [Field_missing (true, c.Types.cd_id)] + | c :: _, [] -> [Field_missing (false, c.Types.cd_id)] + | cd1 :: rem1, cd2 :: rem2 -> + if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then + [Field_names (n, cd1.cd_id.name, cd2.cd_id.name)] + else ( + Builtin_attributes.check_deprecated_inclusion ~def:cd1.cd_loc + ~use:cd2.cd_loc loc cd1.cd_attributes cd2.cd_attributes + (Ident.name cd1.cd_id); + let r = + match (cd1.cd_res, cd2.cd_res) with + | Some r1, Some r2 -> + if Ctype.equal env true [r1] [r2] then + compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2] + cd1.cd_args cd2.cd_args + else [Field_type cd1.cd_id] + | Some _, None | None, Some _ -> [Field_type cd1.cd_id] + | _ -> + compare_constructor_arguments ~loc env cd1.cd_id params1 params2 + cd1.cd_args cd2.cd_args + in + let r = + if r <> [] then r + else + match Ast_untagged_variants.is_nullary_variant cd1.cd_args with + | true -> + let tag_type1 = + Ast_untagged_variants.process_tag_type cd1.cd_attributes + in + let tag_type2 = + Ast_untagged_variants.process_tag_type cd2.cd_attributes + in + if tag_type1 <> tag_type2 then [Variant_representation cd1.cd_id] + else [] + | false -> r + in + if r <> [] then r + else compare_variants ~loc env params1 params2 (n + 1) rem1 rem2) + +and compare_records ~loc env params1_ params2_ n_ + (labels1_ : Types.label_declaration list) + (labels2_ : Types.label_declaration list) = + (* First try a fast path that checks if all the fields at once are consistent. + When that fails, try a slow path that blames the first inconsistent field *) + let rec aux ~fast params1 params2 n labels1 labels2 = + match (labels1, labels2) with + | [], [] -> + if fast then + if Ctype.equal env true params1 params2 then [] + else aux ~fast:false params1_ params2_ n_ labels1_ labels2_ + else [] + | [], l :: _ -> [Field_missing (true, l.Types.ld_id)] + | l :: _, [] -> [Field_missing (false, l.Types.ld_id)] + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id then + [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)] + else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] + else if ld1.ld_optional <> ld2.ld_optional then [Field_optional ld1.ld_id] + else ( + Builtin_attributes.check_deprecated_mutable_inclusion ~def:ld1.ld_loc + ~use:ld2.ld_loc loc ld1.ld_attributes ld2.ld_attributes + (Ident.name ld1.ld_id); + let field_mismatch = + !Builtin_attributes.check_bs_attributes_inclusion + ld1.ld_attributes ld2.ld_attributes (Ident.name ld1.ld_id) + in + match field_mismatch with + | Some (a, b) -> [Field_names (n, a, b)] + | None -> + let current_field_consistent = + if fast then true + else + Ctype.equal env true (ld1.ld_type :: params1) + (ld2.ld_type :: params2) + in + if current_field_consistent then + (* add arguments to the parameters, cf. PR#7378 *) + aux ~fast (ld1.ld_type :: params1) (ld2.ld_type :: params2) (n + 1) + rem1 rem2 + else [Field_type ld1.ld_id]) + in + aux ~fast:true params1_ params2_ n_ labels1_ labels2_ + +let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = + Builtin_attributes.check_deprecated_inclusion ~def:decl1.type_loc + ~use:decl2.type_loc loc decl1.type_attributes decl2.type_attributes name; + if decl1.type_arity <> decl2.type_arity then [Arity] + else if not (private_flags decl1 decl2) then [Privacy] + else + let err = + match (decl1.type_manifest, decl2.type_manifest) with + | _, None -> + if Ctype.equal env true decl1.type_params decl2.type_params then [] + else [Constraint] + | Some ty1, Some ty2 -> + if + type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private + then [] + else [Manifest] + | None, Some ty2 -> + let ty1 = + Btype.newgenty (Tconstr (Pident id, decl2.type_params, ref Mnil)) + in + if Ctype.equal env true decl1.type_params decl2.type_params then + if Ctype.equal env false [ty1] [ty2] then [] else [Manifest] + else [Constraint] + in + if err <> [] then err + else + let err = + let untagged1 = + Ast_untagged_variants.process_untagged decl1.type_attributes + in + let untagged2 = + Ast_untagged_variants.process_untagged decl2.type_attributes + in + match + ( decl2.type_kind, + decl1.type_unboxed.unboxed || untagged1, + decl2.type_unboxed.unboxed || untagged2 ) + with + | Type_abstract, _, _ -> [] + | _, true, false -> [Unboxed_representation false] + | _, false, true -> [Unboxed_representation true] + | _ -> [] + in + if err <> [] then err + else + let err = + let tag1 = + Ast_untagged_variants.process_tag_name decl1.type_attributes + in + let tag2 = + Ast_untagged_variants.process_tag_name decl2.type_attributes + in + if tag1 <> tag2 then [Tag_name] else err + in + if err <> [] then err + else + let err = + match (decl1.type_kind, decl2.type_kind) with + | _, Type_abstract -> [] + | Type_variant cstrs1, Type_variant cstrs2 -> + let mark cstrs usage name decl = + List.iter + (fun c -> + Env.mark_constructor_used usage env name decl + (Ident.name c.Types.cd_id)) + cstrs + in + let usage = + if decl1.type_private = Private || decl2.type_private = Public + then Env.Positive + else Env.Privatize + in + mark cstrs1 usage name decl1; + if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; + compare_variants ~loc env decl1.type_params decl2.type_params 1 + cstrs1 cstrs2 + | Type_record (labels1, rep1), Type_record (labels2, rep2) -> + let err = + compare_records ~loc env decl1.type_params decl2.type_params 1 + labels1 labels2 + in + if err <> [] || rep1 = rep2 then err + else [Record_representation (rep1, rep2)] + | Type_open, Type_open -> [] + | _, _ -> [Kind] + in + if err <> [] then err + else + let abstr = + decl2.type_kind = Type_abstract && decl2.type_manifest = None + in + (* If attempt to assign a non-immediate type (e.g. string) to a type that + * must be immediate, then we error *) + let err = + if abstr && (not decl1.type_immediate) && decl2.type_immediate + then [Immediate] + else [] + in + if err <> [] then err + else + let need_variance = + abstr + || decl1.type_private = Private + || decl1.type_kind = Type_open + in + if not need_variance then [] + else + let abstr = abstr || decl2.type_private = Private in + let opn = + decl2.type_kind = Type_open && decl2.type_manifest = None + in + let constrained ty = not Btype.(is_Tvar (repr ty)) in + if + List.for_all2 + (fun ty (v1, v2) -> + let open Variance in + let imp a b = (not a) || b in + let co1, cn1 = get_upper v1 and co2, cn2 = get_upper v2 in + (if abstr then imp co1 co2 && imp cn1 cn2 + else if opn || constrained ty then co1 = co2 && cn1 = cn2 + else true) + && + let p1, n1, i1, j1 = get_lower v1 + and p2, n2, i2, j2 = get_lower v2 in + imp abstr + (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1)) + decl2.type_params + (List.combine decl1.type_variance decl2.type_variance) + then [] + else [Variance] + +(* Inclusion between extension constructors *) + +let extension_constructors ~loc env id ext1 ext2 = + let usage = + if ext1.ext_private = Private || ext2.ext_private = Public then Env.Positive + else Env.Privatize + in + Env.mark_extension_used usage env ext1 (Ident.name id); + let ty1 = + Btype.newgenty + (Tconstr (ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) + in + let ty2 = + Btype.newgenty + (Tconstr (ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) + in + if + Ctype.equal env true + (ty1 :: ext1.ext_type_params) + (ty2 :: ext2.ext_type_params) + then + if + compare_constructor_arguments ~loc env (Ident.create "") + ext1.ext_type_params ext2.ext_type_params ext1.ext_args ext2.ext_args + = [] + then + if + match (ext1.ext_ret_type, ext2.ext_ret_type) with + | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false + | Some _, None | None, Some _ -> false + | _ -> true + then + match (ext1.ext_private, ext2.ext_private) with + | Private, Public -> false + | _, _ -> true + else false + else false + else false diff --git a/jscomp/ml/includecore.mli b/compiler/ml/includecore.mli similarity index 76% rename from jscomp/ml/includecore.mli rename to compiler/ml/includecore.mli index 2908a07..aec316d 100644 --- a/jscomp/ml/includecore.mli +++ b/compiler/ml/includecore.mli @@ -21,7 +21,7 @@ open Types exception Dont_match type type_mismatch = - Arity + | Arity | Privacy | Kind | Constraint @@ -29,6 +29,7 @@ type type_mismatch = | Variance | Field_type of Ident.t | Field_mutable of Ident.t + | Field_optional of Ident.t | Field_arity of Ident.t | Field_names of int * string * string | Field_missing of bool * Ident.t @@ -38,24 +39,35 @@ type type_mismatch = | Tag_name | Variant_representation of Ident.t -val value_descriptions: - loc:Location.t -> Env.t -> Ident.t -> - value_description -> value_description -> module_coercion - -val type_declarations: +val value_descriptions : + loc:Location.t -> + Env.t -> + Ident.t -> + value_description -> + value_description -> + module_coercion + +val type_declarations : ?equality:bool -> loc:Location.t -> - Env.t -> string -> - type_declaration -> Ident.t -> type_declaration -> type_mismatch list + Env.t -> + string -> + type_declaration -> + Ident.t -> + type_declaration -> + type_mismatch list -val extension_constructors: +val extension_constructors : loc:Location.t -> - Env.t -> Ident.t -> - extension_constructor -> extension_constructor -> bool + Env.t -> + Ident.t -> + extension_constructor -> + extension_constructor -> + bool (* val class_types: Env.t -> class_type -> class_type -> bool *) -val report_type_mismatch: - string -> string -> string -> Format.formatter -> type_mismatch list -> unit +val report_type_mismatch : + string -> string -> string -> Format.formatter -> type_mismatch list -> unit diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml new file mode 100644 index 0000000..d4c01d4 --- /dev/null +++ b/compiler/ml/includemod.ml @@ -0,0 +1,643 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the module language *) + +open Misc +open Path +open Typedtree +open Types + +type symptom = + | Missing_field of Ident.t * Location.t * string (* kind *) + | Value_descriptions of Ident.t * value_description * value_description + | Type_declarations of + Ident.t + * type_declaration + * type_declaration + * Includecore.type_mismatch list + | Extension_constructors of + Ident.t * extension_constructor * extension_constructor + | Module_types of module_type * module_type + | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Modtype_permutation + | Interface_mismatch of string * string + | Unbound_modtype_path of Path.t + | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t + +type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of Ident.t + | Body of Ident.t +type error = pos list * Env.t * symptom + +exception Error of error list + +(* All functions "blah env x1 x2" check that x1 is included in x2, + i.e. that x1 is the type of an implementation that fulfills the + specification x2. If not, Error is raised with a backtrace of the error. *) + +(* Inclusion between value descriptions *) + +let value_descriptions ~loc env cxt subst id vd1 vd2 = + Cmt_format.record_value_dependency vd1 vd2; + Env.mark_value_used env (Ident.name id) vd1; + let vd2 = Subst.value_description subst vd2 in + try Includecore.value_descriptions ~loc env id vd1 vd2 + with Includecore.Dont_match -> + raise (Error [(cxt, env, Value_descriptions (id, vd1, vd2))]) + +(* Inclusion between type declarations *) + +let type_declarations ~loc env ?(old_env = env) cxt subst id decl1 decl2 = + Env.mark_type_used env (Ident.name id) decl1; + let decl2 = Subst.type_declaration subst decl2 in + let err = + Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2 + in + if err <> [] then + raise (Error [(cxt, old_env, Type_declarations (id, decl1, decl2, err))]) + +(* Inclusion between extension constructors *) + +let extension_constructors ~loc env cxt subst id ext1 ext2 = + let ext2 = Subst.extension_constructor subst ext2 in + if Includecore.extension_constructors ~loc env id ext1 ext2 then () + else raise (Error [(cxt, env, Extension_constructors (id, ext1, ext2))]) + +(* Expand a module type identifier when possible *) + +exception Dont_match + +let may_expand_module_path env path = + try + ignore (Env.find_modtype_expansion path env); + true + with Not_found -> false + +let expand_module_path env cxt path = + try Env.find_modtype_expansion path env + with Not_found -> raise (Error [(cxt, env, Unbound_modtype_path path)]) + +let expand_module_alias env cxt path = + try (Env.find_module path env).md_type + with Not_found -> raise (Error [(cxt, env, Unbound_module_path path)]) + +(* +let rec normalize_module_path env cxt path = + match expand_module_alias env cxt path with + Mty_alias path' -> normalize_module_path env cxt path' + | _ -> path +*) + +(* Extract name, kind and ident from a signature item *) + +type field_desc = + | Field_value of string + | Field_type of string + | Field_typext of string + | Field_module of string + | Field_modtype of string + +let kind_of_field_desc = function + | Field_value _ -> "value" + | Field_type _ -> "type" + | Field_typext _ -> "extension constructor" + | Field_module _ -> "module" + | Field_modtype _ -> "module type" + +let item_ident_name = function + | Sig_value (id, d) -> (id, d.val_loc, Field_value (Ident.name id)) + | Sig_type (id, d, _) -> (id, d.type_loc, Field_type (Ident.name id)) + | Sig_typext (id, d, _) -> (id, d.ext_loc, Field_typext (Ident.name id)) + | Sig_module (id, d, _) -> (id, d.md_loc, Field_module (Ident.name id)) + | Sig_modtype (id, d) -> (id, d.mtd_loc, Field_modtype (Ident.name id)) + | Sig_class () -> assert false + | Sig_class_type () -> assert false + +let is_runtime_component = function + | Sig_value (_, {val_kind = Val_prim _}) + | Sig_type (_, _, _) + | Sig_modtype (_, _) + | Sig_class_type () -> + false + | Sig_value (_, _) + | Sig_typext (_, _, _) + | Sig_module (_, _, _) + | Sig_class () -> + true + +(* Print a coercion *) + +let rec print_list pr ppf = function + | [] -> () + | [a] -> pr ppf a + | a :: l -> + pr ppf a; + Format.fprintf ppf ";@ "; + print_list pr ppf l +let print_list pr ppf l = Format.fprintf ppf "[@[%a@]]" (print_list pr) l + +let rec print_coercion ppf c = + let pr fmt = Format.fprintf ppf fmt in + match c with + | Tcoerce_none -> pr "id" + | Tcoerce_structure (fl, nl, _) -> + pr "@[<2>struct@ %a@ %a@]" + (print_list print_coercion2) + fl + (print_list print_coercion3) + nl + | Tcoerce_functor (inp, out) -> + pr "@[<2>functor@ (%a)@ (%a)@]" print_coercion inp print_coercion out + | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> + pr "prim %s@ (%a)" pc_desc.Primitive.prim_name Printtyp.raw_type_expr + pc_type + | Tcoerce_alias (p, c) -> + pr "@[<2>alias %a@ (%a)@]" Printtyp.path p print_coercion c + +and print_coercion2 ppf (n, c) = + Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c + +and print_coercion3 ppf (i, n, c) = + Format.fprintf ppf "@[%s, %d,@ %a@]" (Ident.unique_name i) n print_coercion c + +(* Simplify a structure coercion *) + +let simplify_structure_coercion cc id_pos_list runtime_fields = + let rec is_identity_coercion pos = function + | [] -> true + | (n, c) :: rem -> + n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem + in + if is_identity_coercion 0 cc then Tcoerce_none + else Tcoerce_structure (cc, id_pos_list, runtime_fields) + +(* Inclusion between module types. + Return the restriction that transforms a value of the smaller type + into a value of the bigger type. *) + +let rec modtypes ~loc env cxt subst mty1 mty2 = + try try_modtypes ~loc env cxt subst mty1 mty2 with + | Dont_match -> + raise (Error [(cxt, env, Module_types (mty1, Subst.modtype subst mty2))]) + | Error reasons as err -> ( + match (mty1, mty2) with + | Mty_alias _, _ | _, Mty_alias _ -> raise err + | _ -> + raise + (Error + ((cxt, env, Module_types (mty1, Subst.modtype subst mty2)) :: reasons)) + ) + +and try_modtypes ~loc env cxt subst mty1 mty2 = + match (mty1, mty2) with + | Mty_alias (pres1, p1), Mty_alias (pres2, p2) -> ( + if Env.is_functor_arg p2 env then + raise (Error [(cxt, env, Invalid_module_alias p2)]); + (if not (Path.same p1 p2) then + let p1 = Env.normalize_path None env p1 + and p2 = Env.normalize_path None env (Subst.module_path subst p2) in + if not (Path.same p1 p2) then raise Dont_match); + match (pres1, pres2) with + | Mta_present, Mta_present -> + Tcoerce_none (* Should really be Tcoerce_ignore if it existed *) + | Mta_absent, Mta_absent -> + Tcoerce_none (* Should really be Tcoerce_empty if it existed *) + | Mta_present, Mta_absent -> Tcoerce_none + | Mta_absent, Mta_present -> + let p1 = + try Env.normalize_path (Some Location.none) env p1 + with Env.Error (Env.Missing_module (_, _, path)) -> + raise (Error [(cxt, env, Unbound_module_path path)]) + in + Tcoerce_alias (p1, Tcoerce_none)) + | Mty_alias (pres1, p1), _ -> ( + let p1 = + try Env.normalize_path (Some Location.none) env p1 + with Env.Error (Env.Missing_module (_, _, path)) -> + raise (Error [(cxt, env, Unbound_module_path path)]) + in + let mty1 = + Mtype.strengthen ~aliasable:true env (expand_module_alias env cxt p1) p1 + in + let cc = modtypes ~loc env cxt subst mty1 mty2 in + match pres1 with + | Mta_present -> cc + | Mta_absent -> Tcoerce_alias (p1, cc)) + | Mty_ident p1, _ when may_expand_module_path env p1 -> + try_modtypes ~loc env cxt subst (expand_module_path env cxt p1) mty2 + | _, Mty_ident _ -> try_modtypes2 ~loc env cxt mty1 (Subst.modtype subst mty2) + | Mty_signature sig1, Mty_signature sig2 -> + signatures ~loc env cxt subst sig1 sig2 + | Mty_functor (param1, None, res1), Mty_functor (_param2, None, res2) -> ( + match modtypes ~loc env (Body param1 :: cxt) subst res1 res2 with + | Tcoerce_none -> Tcoerce_none + | cc -> Tcoerce_functor (Tcoerce_none, cc)) + | Mty_functor (param1, Some arg1, res1), Mty_functor (param2, Some arg2, res2) + -> ( + let arg2' = Subst.modtype subst arg2 in + let cc_arg = + modtypes ~loc env (Arg param1 :: cxt) Subst.identity arg2' arg1 + in + let cc_res = + modtypes ~loc + (Env.add_module param1 arg2' env) + (Body param1 :: cxt) + (Subst.add_module param2 (Pident param1) subst) + res1 res2 + in + match (cc_arg, cc_res) with + | Tcoerce_none, Tcoerce_none -> Tcoerce_none + | _ -> Tcoerce_functor (cc_arg, cc_res)) + | _, _ -> raise Dont_match + +and try_modtypes2 ~loc env cxt mty1 mty2 = + (* mty2 is an identifier *) + match (mty1, mty2) with + | Mty_ident p1, Mty_ident p2 + when Path.same + (Env.normalize_path_prefix None env p1) + (Env.normalize_path_prefix None env p2) -> + Tcoerce_none + | _, Mty_ident p2 when may_expand_module_path env p2 -> + try_modtypes ~loc env cxt Subst.identity mty1 + (expand_module_path env cxt p2) + | _, _ -> raise Dont_match + +(* Inclusion between signatures *) + +and signatures ~loc env cxt subst sig1 sig2 = + (* Environment used to check inclusion of components *) + let new_env = Env.add_signature sig1 (Env.in_signature true env) in + (* Keep ids for module aliases *) + let id_pos_list, _ = + List.fold_left + (fun ((l, pos) as id_pos) -> function + | Sig_module (id, _, _) -> ((id, pos, Tcoerce_none) :: l, pos + 1) + | item -> if is_runtime_component item then (l, pos + 1) else id_pos) + ([], 0) sig1 + in + + let runtime_fields = + let get_id = function + | Sig_value (i, _) + | Sig_module (i, _, _) + | Sig_typext (i, _, _) + | Sig_modtype (i, _) + | Sig_type (i, _, _) -> + Ident.name i + | Sig_class () | Sig_class_type () -> assert false + in + List.fold_right + (fun item fields -> + if is_runtime_component item then get_id item :: fields else fields) + sig2 [] + in + + (* Build a table of the components of sig1, along with their positions. + The table is indexed by kind and name of component *) + let rec build_component_table pos tbl = function + | [] -> (pos, tbl) + | item :: rem -> + let id, _loc, name = item_ident_name item in + let nextpos = if is_runtime_component item then pos + 1 else pos in + build_component_table nextpos (Tbl.add name (id, item, pos) tbl) rem + in + let len1, comps1 = build_component_table 0 Tbl.empty sig1 in + let len2 = + List.fold_left + (fun n i -> if is_runtime_component i then n + 1 else n) + 0 sig2 + in + (* Pair each component of sig2 with a component of sig1, + identifying the names along the way. + Return a coercion list indicating, for all run-time components + of sig2, the position of the matching run-time components of sig1 + and the coercion to be applied to it. *) + let rec pair_components subst paired unpaired = function + | [] -> ( + match unpaired with + | [] -> + let cc = + signature_components ~loc env new_env cxt subst (List.rev paired) + in + if len1 = len2 then + (* see PR#5098 *) + simplify_structure_coercion cc id_pos_list runtime_fields + else Tcoerce_structure (cc, id_pos_list, runtime_fields) + | _ -> raise (Error unpaired)) + | item2 :: rem -> ( + let id2, loc, name2 = item_ident_name item2 in + let name2, report = + match (item2, name2) with + | Sig_type (_, {type_manifest = None}, _), Field_type s + when Btype.is_row_name s -> + (* Do not report in case of failure, + as the main type will generate an error *) + (Field_type (String.sub s 0 (String.length s - 4)), false) + | _ -> (name2, true) + in + match Tbl.find name2 comps1 with + | id1, item1, pos1 -> + let new_subst = + match item2 with + | Sig_type _ -> Subst.add_type id2 (Pident id1) subst + | Sig_module _ -> Subst.add_module id2 (Pident id1) subst + | Sig_modtype _ -> + Subst.add_modtype id2 (Mty_ident (Pident id1)) subst + | Sig_value _ | Sig_typext _ | Sig_class _ | Sig_class_type () -> + subst + in + pair_components new_subst ((item1, item2, pos1) :: paired) unpaired rem + | exception Not_found -> + let unpaired = + if report then + (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) + :: unpaired + else unpaired + in + pair_components subst paired unpaired rem) + in + (* Do the pairing and checking, and return the final coercion *) + pair_components subst [] [] sig2 + +(* Inclusion between signature components *) + +and signature_components ~loc old_env env cxt subst paired = + let comps_rec rem = signature_components ~loc old_env env cxt subst rem in + match paired with + | [] -> [] + | (Sig_value (id1, valdecl1), Sig_value (_id2, valdecl2), pos) :: rem -> ( + let cc = value_descriptions ~loc env cxt subst id1 valdecl1 valdecl2 in + match valdecl2.val_kind with + | Val_prim _ -> comps_rec rem + | _ -> (pos, cc) :: comps_rec rem) + | (Sig_type (id1, tydecl1, _), Sig_type (_id2, tydecl2, _), _pos) :: rem -> + type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2; + comps_rec rem + | (Sig_typext (id1, ext1, _), Sig_typext (_id2, ext2, _), pos) :: rem -> + extension_constructors ~loc env cxt subst id1 ext1 ext2; + (pos, Tcoerce_none) :: comps_rec rem + | (Sig_module (id1, mty1, _), Sig_module (_id2, mty2, _), pos) :: rem -> + let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in + (pos, cc) :: comps_rec rem + | (Sig_modtype (id1, info1), Sig_modtype (_id2, info2), _pos) :: rem -> + modtype_infos ~loc env cxt subst id1 info1 info2; + comps_rec rem + | (Sig_class (), Sig_class (), _) :: _ -> assert false + | (Sig_class_type (), Sig_class_type (), _pos) :: _ -> assert false + | _ -> assert false + +and module_declarations ~loc env cxt subst id1 md1 md2 = + Builtin_attributes.check_deprecated_inclusion ~def:md1.md_loc ~use:md2.md_loc + loc md1.md_attributes md2.md_attributes (Ident.name id1); + let p1 = Pident id1 in + Env.mark_module_used env (Ident.name id1) md1.md_loc; + modtypes ~loc env (Module id1 :: cxt) subst + (Mtype.strengthen ~aliasable:true env md1.md_type p1) + md2.md_type + +(* Inclusion between module type specifications *) + +and modtype_infos ~loc env cxt subst id info1 info2 = + Builtin_attributes.check_deprecated_inclusion ~def:info1.mtd_loc + ~use:info2.mtd_loc loc info1.mtd_attributes info2.mtd_attributes + (Ident.name id); + let info2 = Subst.modtype_declaration subst info2 in + let cxt' = Modtype id :: cxt in + try + match (info1.mtd_type, info2.mtd_type) with + | None, None -> () + | Some _, None -> () + | Some mty1, Some mty2 -> check_modtype_equiv ~loc env cxt' mty1 mty2 + | None, Some mty2 -> + check_modtype_equiv ~loc env cxt' (Mty_ident (Pident id)) mty2 + with Error reasons -> + raise (Error ((cxt, env, Modtype_infos (id, info1, info2)) :: reasons)) + +and check_modtype_equiv ~loc env cxt mty1 mty2 = + match + ( modtypes ~loc env cxt Subst.identity mty1 mty2, + modtypes ~loc env cxt Subst.identity mty2 mty1 ) + with + | Tcoerce_none, Tcoerce_none -> () + | _c1, _c2 -> + (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." + print_coercion _c1 print_coercion _c2; *) + raise (Error [(cxt, env, Modtype_permutation)]) + +(* Simplified inclusion check between module types (for Env) *) + +let can_alias env path = + let rec no_apply = function + | Pident _ -> true + | Pdot (p, _, _) -> no_apply p + | Papply _ -> false + in + no_apply path && not (Env.is_functor_arg path env) + +let check_modtype_inclusion ~loc env mty1 path1 mty2 = + try + let aliasable = can_alias env path1 in + ignore + (modtypes ~loc env [] Subst.identity + (Mtype.strengthen ~aliasable env mty1 path1) + mty2) + with Error _ -> raise Not_found + +let _ = Env.check_modtype_inclusion := check_modtype_inclusion + +(* Check that an implementation of a compilation unit meets its + interface. *) + +let compunit env impl_name impl_sig intf_name intf_sig = + try + signatures + ~loc:(Location.in_file impl_name) + env [] Subst.identity impl_sig intf_sig + with Error reasons -> + raise + (Error + (([], Env.empty, Interface_mismatch (impl_name, intf_name)) :: reasons)) + +(* Hide the context and substitution parameters to the outside world *) + +let modtypes ~loc env mty1 mty2 = modtypes ~loc env [] Subst.identity mty1 mty2 +let signatures env sig1 sig2 = + signatures ~loc:Location.none env [] Subst.identity sig1 sig2 +let type_declarations ~loc env id decl1 decl2 = + type_declarations ~loc env [] Subst.identity id decl1 decl2 + +(* +let modtypes env m1 m2 = + let c = modtypes env m1 m2 in + Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@." + Printtyp.modtype m1 Printtyp.modtype m2 + print_coercion c; + c +*) + +(* Error report *) + +open Format +open Printtyp + +let show_loc msg ppf loc = + fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg + +let show_locs ppf (loc1, loc2) = + show_loc "Expected declaration" ppf loc2; + show_loc "Actual declaration" ppf loc1 + +let include_err ppf = function + | Missing_field (id, loc, kind) -> + fprintf ppf "The %s `%a' is required but not provided" kind ident id; + show_loc "Expected declaration" ppf loc + | Value_descriptions (id, d1, d2) -> + let curry_kind_1, curry_kind_2 = ("", "") in + fprintf ppf + "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" + (value_description id) d1 curry_kind_1 (value_description id) d2 + curry_kind_2; + show_locs ppf (d1.val_loc, d2.val_loc) + | Type_declarations (id, d1, d2, errs) -> + fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" + "Type declarations do not match" (type_declaration id) d1 + "is not included in" (type_declaration id) d2 show_locs + (d1.type_loc, d2.type_loc) + (Includecore.report_type_mismatch "the first" "the second" "declaration") + errs + | Extension_constructors (id, x1, x2) -> + fprintf ppf + "@[Extension declarations do not match:@ %a@;\ + <1 -2>is not included in@ %a@]" + (extension_constructor id) x1 (extension_constructor id) x2; + show_locs ppf (x1.ext_loc, x2.ext_loc) + | Module_types (mty1, mty2) -> + fprintf ppf + "@[Modules do not match:@ %a@;<1 -2>is not included in@ %a@]" + modtype mty1 modtype mty2 + | Modtype_infos (id, d1, d2) -> + fprintf ppf + "@[Module type declarations do not match:@ %a@;\ + <1 -2>does not match@ %a@]" + (modtype_declaration id) d1 (modtype_declaration id) d2 + | Modtype_permutation -> fprintf ppf "Illegal permutation of structure fields" + | Interface_mismatch (impl_name, intf_name) -> + fprintf ppf "@[The implementation %s@ does not match the interface %s:" + impl_name intf_name + | Unbound_modtype_path path -> + fprintf ppf "Unbound module type %a" Printtyp.path path + | Unbound_module_path path -> + fprintf ppf "Unbound module %a" Printtyp.path path + | Invalid_module_alias path -> + fprintf ppf "Module %a cannot be aliased" Printtyp.path path + +let rec context ppf = function + | Module id :: rem -> fprintf ppf "@[<2>module %a%a@]" ident id args rem + | Modtype id :: rem -> + fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem + | Body x :: rem -> + fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + | Arg x :: rem -> + fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem + | [] -> fprintf ppf "" + +and context_mty ppf = function + | (Module _ | Modtype _) :: _ as rem -> + fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | cxt -> context ppf cxt + +and args ppf = function + | Body x :: rem -> fprintf ppf "(%s)%a" (argname x) args rem + | Arg x :: rem -> fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem + | cxt -> fprintf ppf " :@ %a" context_mty cxt + +and argname x = + let s = Ident.name x in + if s = "*" then "" else s + +let path_of_context = function + | Module id :: rem -> + let rec subm path = function + | [] -> path + | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem + | _ -> assert false + in + subm (Pident id) rem + | _ -> assert false + +let context ppf cxt = + if cxt = [] then () + else if + List.for_all + (function + | Module _ -> true + | _ -> false) + cxt + then fprintf ppf "In module %a:@ " path (path_of_context cxt) + else fprintf ppf "@[At position@ %a@]@ " context cxt + +let include_err ppf (cxt, env, err) = + Printtyp.wrap_printing_env env (fun () -> + fprintf ppf "@[%a%a@]" context (List.rev cxt) include_err err) + +let buffer = ref Bytes.empty +let is_big obj = + let size = !Clflags.error_size in + size > 0 + && + (if Bytes.length !buffer < size then buffer := Bytes.create size; + try + ignore (Marshal.to_buffer !buffer 0 size obj []); + false + with _ -> true) + +let report_error ppf errs = + if errs = [] then () + else + let errs, err = split_last errs in + let pe = ref true in + let include_err' ppf ((_, _, obj) as err) = + if not (is_big obj) then fprintf ppf "%a@ " include_err err + else if !pe then ( + fprintf ppf "...@ "; + pe := false) + in + let print_errs ppf = List.iter (include_err' ppf) in + fprintf ppf "@[%a%a@]" print_errs errs include_err err + +let better_candidate_loc (x : error list) = + match x with + | [(_, _, Interface_mismatch _); (_, _, descr)] -> ( + match descr with + | Value_descriptions (_, d1, _) -> Some d1.val_loc + | Type_declarations (_, tdcl1, _, _) -> Some tdcl1.type_loc + | Missing_field (_, loc, _) -> Some loc + | _ -> None) + | _ -> None + +(* We could do a better job to split the individual error items + as sub-messages of the main interface mismatch on the whole unit. *) +let () = + Location.register_error_of_exn (function + | Error err -> ( + match better_candidate_loc err with + | None -> Some (Location.error_of_printer_file report_error err) + | Some loc -> Some (Location.error_of_printer loc report_error err)) + | _ -> None) diff --git a/compiler/ml/includemod.mli b/compiler/ml/includemod.mli new file mode 100644 index 0000000..9399f2b --- /dev/null +++ b/compiler/ml/includemod.mli @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Inclusion checks for the module language *) + +open Typedtree +open Types +open Format + +val modtypes : + loc:Location.t -> Env.t -> module_type -> module_type -> module_coercion + +val signatures : Env.t -> signature -> signature -> module_coercion + +val compunit : + Env.t -> string -> signature -> string -> signature -> module_coercion + +val type_declarations : + loc:Location.t -> + Env.t -> + Ident.t -> + type_declaration -> + type_declaration -> + unit + +val print_coercion : formatter -> module_coercion -> unit + +type symptom = + | Missing_field of Ident.t * Location.t * string (* kind *) + | Value_descriptions of Ident.t * value_description * value_description + | Type_declarations of + Ident.t + * type_declaration + * type_declaration + * Includecore.type_mismatch list + | Extension_constructors of + Ident.t * extension_constructor * extension_constructor + | Module_types of module_type * module_type + | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration + | Modtype_permutation + | Interface_mismatch of string * string + | Unbound_modtype_path of Path.t + | Unbound_module_path of Path.t + | Invalid_module_alias of Path.t + +type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of Ident.t + | Body of Ident.t +type error = pos list * Env.t * symptom + +exception Error of error list + +val report_error : formatter -> error list -> unit +val expand_module_alias : Env.t -> pos list -> Path.t -> Types.module_type diff --git a/jscomp/ml/js_raw_info.ml b/compiler/ml/js_raw_info.ml similarity index 100% rename from jscomp/ml/js_raw_info.ml rename to compiler/ml/js_raw_info.ml diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml new file mode 100644 index 0000000..db810d4 --- /dev/null +++ b/compiler/ml/lambda.ml @@ -0,0 +1,731 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS + +type tag_info = + | Blk_constructor of { + name: string; + num_nonconst: int; + tag: int; + attrs: Parsetree.attributes; + } + | Blk_record_inlined of { + name: string; + num_nonconst: int; + tag: int; + fields: (string * bool (* optional *)) array; + mutable_flag: Asttypes.mutable_flag; + attrs: Parsetree.attributes; + } + | Blk_tuple + | Blk_poly_var of string + | Blk_record of { + fields: (string * bool (* optional *)) array; + mutable_flag: Asttypes.mutable_flag; + } + | Blk_module of string list + | Blk_module_export of Ident.t list + | Blk_extension + | Blk_some + | Blk_some_not_nested + (* ['a option] where ['a] can not inhabit a non-like value *) + | Blk_record_ext of { + fields: string array; + mutable_flag: Asttypes.mutable_flag; + } + +let tag_of_tag_info (tag : tag_info) = + match tag with + | Blk_constructor {tag} | Blk_record_inlined {tag} -> tag + | Blk_tuple | Blk_poly_var _ | Blk_record _ | Blk_module _ + | Blk_module_export _ | Blk_extension | Blk_some (* tag not make sense *) + | Blk_some_not_nested (* tag not make sense *) + | Blk_record_ext _ (* similar to Blk_extension*) -> + 0 + +let mutable_flag_of_tag_info (tag : tag_info) = + match tag with + | Blk_record_inlined {mutable_flag} + | Blk_record {mutable_flag} + | Blk_record_ext {mutable_flag} -> + mutable_flag + | Blk_tuple | Blk_constructor _ | Blk_poly_var _ | Blk_module _ + | Blk_module_export _ | Blk_extension | Blk_some_not_nested | Blk_some -> + Immutable + +type label = Types.label_description + +let find_name (attr : Parsetree.attribute) = + match attr with + | ( {txt = "as"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _); + }; + ] ) -> + Some s + | _ -> None + +let blk_record (fields : (label * _ * _) array) mut = + let all_labels_info = + Ext_array.map fields (fun (lbl, _, _) -> + ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, + lbl.lbl_optional )) + in + Blk_record {fields = all_labels_info; mutable_flag = mut} + +let blk_record_ext fields mutable_flag = + let all_labels_info = + Array.map + (fun ((lbl : label), _, _) -> + Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name) + fields + in + Blk_record_ext {fields = all_labels_info; mutable_flag} + +let blk_record_inlined fields name num_nonconst ~tag ~attrs mutable_flag = + let fields = + Array.map + (fun ((lbl : label), _, _) -> + ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, + lbl.lbl_optional )) + fields + in + Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; attrs} + +let ref_tag_info : tag_info = + Blk_record {fields = [|("contents", false)|]; mutable_flag = Mutable} + +type field_dbg_info = + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} + | Fld_module of {name: string} + | Fld_record_inline of {name: string} + | Fld_record_extension of {name: string} + | Fld_tuple + | Fld_poly_var_tag + | Fld_poly_var_content + | Fld_extension + | Fld_variant + | Fld_cons + +let fld_record (lbl : label) = + Fld_record + { + name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name; + mutable_flag = lbl.lbl_mut; + } + +let fld_record_extension (lbl : label) = + Fld_record_extension + {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} + +let ref_field_info : field_dbg_info = + Fld_record {name = "contents"; mutable_flag = Mutable} + +type set_field_dbg_info = + | Fld_record_set of string + | Fld_record_inline_set of string + | Fld_record_extension_set of string + +let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents" +let fld_record_set (lbl : label) = + Fld_record_set (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + +let fld_record_inline (lbl : label) = + Fld_record_inline + {name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name} + +let fld_record_inline_set (lbl : label) = + Fld_record_inline_set + (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + +let fld_record_extension_set (lbl : label) = + Fld_record_extension_set + (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) + +type immediate_or_pointer = Immediate | Pointer + +type primitive = + | Pidentity + | Pignore + | Pdebugger + | Ptypeof + | Pnull + | Pundefined + | Pfn_arity + | Prevapply + | Pdirapply + | Ploc of loc_kind (* Globals *) + | Pgetglobal of Ident.t + (* Operations on heap blocks *) + | Pmakeblock of tag_info + | Pfield of int * field_dbg_info + | Psetfield of int * set_field_dbg_info + | Pduprecord + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* object operations *) + | Pobjcomp of comparison + | Pobjorder + | Pobjmin + | Pobjmax + | Pobjtag + | Pobjsize + (* Boolean operations *) + | Psequand + | Psequor + | Pnot + | Pboolcomp of comparison + | Pboolorder + | Pboolmin + | Pboolmax + (* Integer operations *) + | Pnegint + | Paddint + | Psubint + | Pmulint + | Pdivint + | Pmodint + | Ppowint + | Pandint + | Porint + | Pxorint + | Pnotint + | Plslint + | Plsrint + | Pasrint + | Pintcomp of comparison + | Pintorder + | Pintmin + | Pintmax + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Pmodfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Ppowfloat + | Pfloatcomp of comparison + | Pfloatorder + | Pfloatmin + | Pfloatmax + (* BigInt operations *) + | Pnegbigint + | Paddbigint + | Psubbigint + | Ppowbigint + | Pmulbigint + | Pdivbigint + | Pmodbigint + | Pandbigint + | Porbigint + | Pxorbigint + | Pnotbigint + | Plslbigint + | Pasrbigint + | Pbigintcomp of comparison + | Pbigintorder + | Pbigintmin + | Pbigintmax + (* String operations *) + | Pstringlength + | Pstringrefu + | Pstringrefs + | Pstringcomp of comparison + | Pstringorder + | Pstringmin + | Pstringmax + | Pstringadd + (* Array operations *) + | Pmakearray of Asttypes.mutable_flag + | Parraylength + | Parrayrefu + | Parraysetu + | Parrayrefs + | Parraysets + (* List primitives *) + | Pmakelist of Asttypes.mutable_flag + (* dict primitives *) + | Pmakedict + | Pdict_has + (* promise *) + | Pawait + (* module *) + | Pimport + | Pinit_mod + | Pupdate_mod + (* hash *) + | Phash + | Phash_mixint + | Phash_mixstring + | Phash_finalmix + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Test if the argument is null or undefined *) + | Pisnullable + (* exn *) + | Pcreate_extension of string + | Pextension_slot_eq + | Pwrap_exn + (* js *) + | Pcurry_apply of int + | Pjscomp of comparison + | Pnull_to_opt + | Pnullable_to_opt + | Pis_not_none + | Pval_from_option + | Pval_from_option_not_nest + | Pis_poly_var_block + | Pjs_raw_expr + | Pjs_raw_stmt + | Pjs_fn_make of int + | Pjs_fn_make_unit + | Pjs_fn_method + +and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge + +and value_kind = Pgenval + +and raise_kind = Raise_regular | Raise_reraise + +type pointer_info = + | Pt_constructor of { + name: string; + const: int; + non_const: int; + attrs: Parsetree.attributes; + } + | Pt_variant of {name: string} + | Pt_module_alias + | Pt_shape_none + | Pt_assertfalse + +type structured_constant = + | Const_base of Asttypes.constant + | Const_pointer of int * pointer_info + | Const_block of tag_info * structured_constant list + | Const_immstring of string + | Const_false + | Const_true +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Default_inline (* no [@inline] attribute *) + +type let_kind = Strict | Alias | StrictOpt | Variable + +type function_attribute = { + inline: inline_attribute; + is_a_functor: bool; + return_unit: bool; + async: bool; + directive: string option; + one_unit_arg: bool; +} + +type lambda = + | Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list * Location.t + | Lswitch of lambda * lambda_switch * Location.t + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * Ident.t list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * Asttypes.direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of string * lambda * Location.t + +and lfunction = { + params: Ident.t list; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; +} + +and lambda_apply = { + ap_func: lambda; + ap_args: lambda list; + ap_loc: Location.t; + ap_inlined: inline_attribute; + ap_transformed_jsx: bool; +} + +and lambda_switch = { + sw_numconsts: int; + sw_consts: (int * lambda) list; + sw_numblocks: int; + sw_blocks: (int * lambda) list; + sw_failaction: lambda option; + sw_names: Ast_untagged_variants.switch_names option; +} + +(* This is actually a dummy value + not necessary "()", it can be used as a place holder for module + alias etc. +*) +let const_unit = + Const_pointer + (0, Pt_constructor {name = "()"; const = 1; non_const = 0; attrs = []}) + +let lambda_assert_false = Lconst (Const_pointer (0, Pt_assertfalse)) + +let lambda_module_alias = Lconst (Const_pointer (0, Pt_module_alias)) + +let lambda_unit = Lconst const_unit + +let default_function_attribute = + { + inline = Default_inline; + is_a_functor = false; + return_unit = false; + async = false; + one_unit_arg = false; + directive = None; + } + +(* Build sharing keys *) +(* + Those keys are later compared with Pervasives.compare. + For that reason, they should not include cycles. +*) + +exception Not_simple + +let max_raw = 32 + +let make_key e = + let count = ref 0 (* Used for controling size *) + and make_key = Ident.make_key_generator () in + (* make_key is used for normalizing let-bound variables *) + let rec tr_rec env e = + incr count; + if !count > max_raw then raise_notrace Not_simple; + (* Too big ! *) + match e with + | Lvar id -> ( try Ident.find_same id env with Not_found -> e) + | Lconst (Const_base (Const_string _)) -> + (* Mutable constants are not shared *) + raise_notrace Not_simple + | Lconst _ -> e + | Lapply ap -> + Lapply + { + ap with + ap_func = tr_rec env ap.ap_func; + ap_args = tr_recs env ap.ap_args; + ap_loc = Location.none; + } + | Llet (Alias, _k, x, ex, e) -> + (* Ignore aliases -> substitute *) + let ex = tr_rec env ex in + tr_rec (Ident.add x ex env) e + | Llet ((Strict | StrictOpt), _k, x, ex, Lvar v) when Ident.same v x -> + tr_rec env ex + | Llet (str, k, x, ex, e) -> + (* Because of side effects, keep other lets with normalized names *) + let ex = tr_rec env ex in + let y = make_key x in + Llet (str, k, y, ex, tr_rec (Ident.add x (Lvar y) env) e) + | Lprim (p, es, _) -> Lprim (p, tr_recs env es, Location.none) + | Lswitch (e, sw, loc) -> Lswitch (tr_rec env e, tr_sw env sw, loc) + | Lstringswitch (e, sw, d, _) -> + Lstringswitch + ( tr_rec env e, + List.map (fun (s, e) -> (s, tr_rec env e)) sw, + tr_opt env d, + Location.none ) + | Lstaticraise (i, es) -> Lstaticraise (i, tr_recs env es) + | Lstaticcatch (e1, xs, e2) -> + Lstaticcatch (tr_rec env e1, xs, tr_rec env e2) + | Ltrywith (e1, x, e2) -> Ltrywith (tr_rec env e1, x, tr_rec env e2) + | Lifthenelse (cond, ifso, ifnot) -> + Lifthenelse (tr_rec env cond, tr_rec env ifso, tr_rec env ifnot) + | Lsequence (e1, e2) -> Lsequence (tr_rec env e1, tr_rec env e2) + | Lassign (x, e) -> Lassign (x, tr_rec env e) + | Lsend (m, e1, _loc) -> Lsend (m, tr_rec env e1, Location.none) + | Lletrec _ | Lfunction _ | Lfor _ | Lwhile _ -> raise_notrace Not_simple + and tr_recs env es = List.map (tr_rec env) es + and tr_sw env sw = + { + sw with + sw_consts = List.map (fun (i, e) -> (i, tr_rec env e)) sw.sw_consts; + sw_blocks = List.map (fun (i, e) -> (i, tr_rec env e)) sw.sw_blocks; + sw_failaction = tr_opt env sw.sw_failaction; + } + and tr_opt env = function + | None -> None + | Some e -> Some (tr_rec env e) + in + + try Some (tr_rec Ident.empty e) with Not_simple -> None + +(***************) + +let name_lambda strict arg fn = + match arg with + | Lvar id -> fn id + | _ -> + let id = Ident.create "let" in + Llet (strict, Pgenval, id, arg, fn id) + +let iter_opt f = function + | None -> () + | Some e -> f e + +let iter f = function + | Lvar _ | Lconst _ -> () + | Lapply {ap_func = fn; ap_args = args} -> + f fn; + List.iter f args + | Lfunction {body} -> f body + | Llet (_str, _k, _id, arg, body) -> + f arg; + f body + | Lletrec (decl, body) -> + f body; + List.iter (fun (_id, exp) -> f exp) decl + | Lprim (_p, args, _loc) -> List.iter f args + | Lswitch (arg, sw, _) -> + f arg; + List.iter (fun (_key, case) -> f case) sw.sw_consts; + List.iter (fun (_key, case) -> f case) sw.sw_blocks; + iter_opt f sw.sw_failaction + | Lstringswitch (arg, cases, default, _) -> + f arg; + List.iter (fun (_, act) -> f act) cases; + iter_opt f default + | Lstaticraise (_, args) -> List.iter f args + | Lstaticcatch (e1, _, e2) -> + f e1; + f e2 + | Ltrywith (e1, _, e2) -> + f e1; + f e2 + | Lifthenelse (e1, e2, e3) -> + f e1; + f e2; + f e3 + | Lsequence (e1, e2) -> + f e1; + f e2 + | Lwhile (e1, e2) -> + f e1; + f e2 + | Lfor (_v, e1, e2, _dir, e3) -> + f e1; + f e2; + f e3 + | Lassign (_, e) -> f e + | Lsend (_k, obj, _) -> f obj + +module IdentSet = Set.Make (Ident) + +let free_ids get l = + let fv = ref IdentSet.empty in + let rec free l = + iter free l; + fv := List.fold_right IdentSet.add (get l) !fv; + match l with + | Lfunction {params} -> + List.iter (fun param -> fv := IdentSet.remove param !fv) params + | Llet (_str, _k, id, _arg, _body) -> fv := IdentSet.remove id !fv + | Lletrec (decl, _body) -> + List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl + | Lstaticcatch (_e1, (_, vars), _e2) -> + List.iter (fun id -> fv := IdentSet.remove id !fv) vars + | Ltrywith (_e1, exn, _e2) -> fv := IdentSet.remove exn !fv + | Lfor (v, _e1, _e2, _dir, _e3) -> fv := IdentSet.remove v !fv + | Lassign (id, _e) -> fv := IdentSet.add id !fv + | Lvar _ | Lconst _ | Lapply _ | Lprim _ | Lswitch _ | Lstringswitch _ + | Lstaticraise _ | Lifthenelse _ | Lsequence _ | Lwhile _ | Lsend _ -> + () + in + free l; + !fv + +let free_variables l = + free_ids + (function + | Lvar id -> [id] + | _ -> []) + l + +(* Check if an action has a "when" guard *) +let raise_count = ref 0 + +let next_raise_count () = + incr raise_count; + !raise_count + +let negative_raise_count = ref 0 + +let next_negative_raise_count () = + decr negative_raise_count; + !negative_raise_count + +(* Anticipated staticraise, for guards *) +let staticfail = Lstaticraise (0, []) + +let rec is_guarded = function + | Lifthenelse (_cond, _body, Lstaticraise (0, [])) -> true + | Llet (_str, _k, _id, _lam, body) -> is_guarded body + | _ -> false + +let rec patch_guarded patch = function + | Lifthenelse (cond, body, Lstaticraise (0, [])) -> + Lifthenelse (cond, body, patch) + | Llet (str, k, id, lam, body) -> + Llet (str, k, id, lam, patch_guarded patch body) + | _ -> assert false + +(* Translate an access path *) + +let rec transl_normal_path = function + | Path.Pident id -> + if Ident.global id then Lprim (Pgetglobal id, [], Location.none) + else Lvar id + | Pdot (p, s, pos) -> + Lprim + ( Pfield (pos, Fld_module {name = s}), + [transl_normal_path p], + Location.none ) + | Papply _ -> assert false + +(* Translation of identifiers *) + +let transl_module_path ?(loc = Location.none) env path = + transl_normal_path (Env.normalize_path (Some loc) env path) + +let transl_value_path ?(loc = Location.none) env path = + transl_normal_path (Env.normalize_path_prefix (Some loc) env path) + +let transl_extension_path = transl_value_path + +(* Apply a substitution to a lambda-term. + Assumes that the bound variables of the lambda-term do not + belong to the domain of the substitution. + Assumes that the image of the substitution is out of reach + of the bound variables of the lambda-term (no capture). *) + +let subst_lambda s lam = + let rec subst = function + | Lvar id as l -> ( try Ident.find_same id s with Not_found -> l) + | Lconst _ as l -> l + | Lapply ap -> + Lapply + { + ap with + ap_func = subst ap.ap_func; + ap_args = List.map subst ap.ap_args; + } + | Lfunction {params; body; attr; loc} -> + Lfunction {params; body = subst body; attr; loc} + | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) + | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) + | Lprim (p, args, loc) -> Lprim (p, List.map subst args, loc) + | Lswitch (arg, sw, loc) -> + Lswitch + ( subst arg, + { + sw with + sw_consts = List.map subst_case sw.sw_consts; + sw_blocks = List.map subst_case sw.sw_blocks; + sw_failaction = subst_opt sw.sw_failaction; + }, + loc ) + | Lstringswitch (arg, cases, default, loc) -> + Lstringswitch + (subst arg, List.map subst_strcase cases, subst_opt default, loc) + | Lstaticraise (i, args) -> Lstaticraise (i, List.map subst args) + | Lstaticcatch (e1, io, e2) -> Lstaticcatch (subst e1, io, subst e2) + | Ltrywith (e1, exn, e2) -> Ltrywith (subst e1, exn, subst e2) + | Lifthenelse (e1, e2, e3) -> Lifthenelse (subst e1, subst e2, subst e3) + | Lsequence (e1, e2) -> Lsequence (subst e1, subst e2) + | Lwhile (e1, e2) -> Lwhile (subst e1, subst e2) + | Lfor (v, e1, e2, dir, e3) -> Lfor (v, subst e1, subst e2, dir, subst e3) + | Lassign (id, e) -> Lassign (id, subst e) + | Lsend (k, obj, loc) -> Lsend (k, subst obj, loc) + and subst_decl (id, exp) = (id, subst exp) + and subst_case (key, case) = (key, subst case) + and subst_strcase (key, case) = (key, subst case) + and subst_opt = function + | None -> None + | Some e -> Some (subst e) + in + subst lam + +(* To let-bind expressions to variables *) + +let bind str var exp body = + match exp with + | Lvar var' when Ident.same var var' -> body + | _ -> Llet (str, Pgenval, var, exp, body) + +let raise_kind = function + | Raise_regular -> "raise" + | Raise_reraise -> "reraise" + +let lam_of_loc kind loc = + let loc_start = loc.Location.loc_start in + let file, lnum, cnum = Location.get_pos_info loc_start in + let file = Filename.basename file in + let enum = + loc.Location.loc_end.Lexing.pos_cnum - loc_start.Lexing.pos_cnum + cnum + in + match kind with + | Loc_POS -> + Lconst + (Const_block + ( Blk_tuple, + [ + Const_immstring file; + Const_base (Const_int lnum); + Const_base (Const_int cnum); + Const_base (Const_int enum); + ] )) + | Loc_FILE -> Lconst (Const_immstring file) + | Loc_MODULE -> + let filename = Filename.basename file in + let name = Env.get_unit_name () in + let module_name = if name = "" then "//" ^ filename ^ "//" else name in + Lconst (Const_immstring module_name) + | Loc_LOC -> + let loc = + Printf.sprintf "File %S, line %d, characters %d-%d" file lnum cnum enum + in + Lconst (Const_immstring loc) + | Loc_LINE -> Lconst (Const_base (Const_int lnum)) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli new file mode 100644 index 0000000..d8eaf57 --- /dev/null +++ b/compiler/ml/lambda.mli @@ -0,0 +1,422 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* The "lambda" intermediate code *) + +open Asttypes + +type loc_kind = Loc_FILE | Loc_LINE | Loc_MODULE | Loc_LOC | Loc_POS + +type tag_info = + | Blk_constructor of { + name: string; + num_nonconst: int; + tag: int; + attrs: Parsetree.attributes; + } + | Blk_record_inlined of { + name: string; + num_nonconst: int; + tag: int; + fields: (string * bool (* optional *)) array; + mutable_flag: mutable_flag; + attrs: Parsetree.attributes; + } + | Blk_tuple + | Blk_poly_var of string + | Blk_record of { + fields: (string * bool (* optional *)) array; + mutable_flag: mutable_flag; + } + | Blk_module of string list + | Blk_module_export of Ident.t list + | Blk_extension + (* underlying is the same as tuple, immutable block + {[ + exception A of int * int + ]} + is translated into + {[ + [A, x, y] + ]} + *) + | Blk_some + | Blk_some_not_nested + (* ['a option] where ['a] can not inhabit a non-like value *) + | Blk_record_ext of {fields: string array; mutable_flag: mutable_flag} + +val find_name : Parsetree.attribute -> Asttypes.label option + +val tag_of_tag_info : tag_info -> int +val mutable_flag_of_tag_info : tag_info -> mutable_flag +val blk_record : + (Types.label_description * Typedtree.record_label_definition * bool) array -> + mutable_flag -> + tag_info + +val blk_record_ext : + (Types.label_description * Typedtree.record_label_definition * bool) array -> + mutable_flag -> + tag_info + +val blk_record_inlined : + (Types.label_description * Typedtree.record_label_definition * bool) array -> + string -> + int -> + tag:int -> + attrs:Parsetree.attributes -> + mutable_flag -> + tag_info + +val ref_tag_info : tag_info + +type field_dbg_info = + | Fld_record of {name: string; mutable_flag: Asttypes.mutable_flag} + | Fld_module of {name: string} + | Fld_record_inline of {name: string} + | Fld_record_extension of {name: string} + | Fld_tuple + | Fld_poly_var_tag + | Fld_poly_var_content + | Fld_extension + | Fld_variant + | Fld_cons + +val fld_record : Types.label_description -> field_dbg_info + +val fld_record_inline : Types.label_description -> field_dbg_info + +val fld_record_extension : Types.label_description -> field_dbg_info + +val ref_field_info : field_dbg_info + +type set_field_dbg_info = + | Fld_record_set of string + | Fld_record_inline_set of string + | Fld_record_extension_set of string + +val ref_field_set_info : set_field_dbg_info + +val fld_record_set : Types.label_description -> set_field_dbg_info + +val fld_record_inline_set : Types.label_description -> set_field_dbg_info + +val fld_record_extension_set : Types.label_description -> set_field_dbg_info + +type immediate_or_pointer = Immediate | Pointer + +type pointer_info = + | Pt_constructor of { + name: string; + const: int; + non_const: int; + attrs: Parsetree.attributes; + } + | Pt_variant of {name: string} + | Pt_module_alias + | Pt_shape_none + | Pt_assertfalse + +type primitive = + | Pidentity + | Pignore + | Pdebugger + | Ptypeof + | Pnull + | Pundefined + | Pfn_arity + | Prevapply + | Pdirapply + | Ploc of loc_kind (* Globals *) + | Pgetglobal of Ident.t + (* Operations on heap blocks *) + | Pmakeblock of tag_info + | Pfield of int * field_dbg_info + | Psetfield of int * set_field_dbg_info + | Pduprecord + (* External call *) + | Pccall of Primitive.description + (* Exceptions *) + | Praise of raise_kind + (* object primitives *) + | Pobjcomp of comparison + | Pobjorder + | Pobjmin + | Pobjmax + | Pobjtag + | Pobjsize + (* Boolean operations *) + | Psequand + | Psequor + | Pnot + | Pboolcomp of comparison + | Pboolorder + | Pboolmin + | Pboolmax + (* Integer operations *) + | Pnegint + | Paddint + | Psubint + | Pmulint + | Pdivint + | Pmodint + | Ppowint + | Pandint + | Porint + | Pxorint + | Pnotint + | Plslint + | Plsrint + | Pasrint + | Pintcomp of comparison + | Pintorder + | Pintmin + | Pintmax + | Poffsetint of int + | Poffsetref of int + (* Float operations *) + | Pintoffloat + | Pfloatofint + | Pnegfloat + | Pabsfloat + | Pmodfloat + | Paddfloat + | Psubfloat + | Pmulfloat + | Pdivfloat + | Ppowfloat + | Pfloatcomp of comparison + | Pfloatorder + | Pfloatmin + | Pfloatmax + (* BigInt operations *) + | Pnegbigint + | Paddbigint + | Psubbigint + | Ppowbigint + | Pmulbigint + | Pdivbigint + | Pmodbigint + | Pandbigint + | Porbigint + | Pxorbigint + | Pnotbigint + | Plslbigint + | Pasrbigint + | Pbigintcomp of comparison + | Pbigintorder + | Pbigintmin + | Pbigintmax + (* String operations *) + | Pstringlength + | Pstringrefu + | Pstringrefs + | Pstringcomp of comparison + | Pstringorder + | Pstringmin + | Pstringmax + | Pstringadd + (* Array operations *) + | Pmakearray of mutable_flag + | Parraylength + | Parrayrefu + | Parraysetu + | Parrayrefs + | Parraysets + (* List primitives *) + | Pmakelist of Asttypes.mutable_flag + (* dict primitives *) + | Pmakedict + | Pdict_has + (* promise *) + | Pawait + (* modules *) + | Pimport + | Pinit_mod + | Pupdate_mod + (* hash *) + | Phash + | Phash_mixint + | Phash_mixstring + | Phash_finalmix + (* Test if the argument is a block or an immediate integer *) + | Pisint + (* Test if the (integer) argument is outside an interval *) + | Pisout + (* Test if the argument is null or undefined *) + | Pisnullable + (* exn *) + | Pcreate_extension of string + | Pextension_slot_eq + | Pwrap_exn + (* js *) + | Pcurry_apply of int + | Pjscomp of comparison + | Pnull_to_opt + | Pnullable_to_opt + | Pis_not_none + | Pval_from_option + | Pval_from_option_not_nest + | Pis_poly_var_block + | Pjs_raw_expr + | Pjs_raw_stmt + | Pjs_fn_make of int + | Pjs_fn_make_unit + | Pjs_fn_method + +and comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge + +and value_kind = Pgenval + +and raise_kind = Raise_regular | Raise_reraise + +type structured_constant = + | Const_base of constant + | Const_pointer of int * pointer_info + | Const_block of tag_info * structured_constant list + | Const_immstring of string + | Const_false + | Const_true + +type inline_attribute = + | Always_inline (* [@inline] or [@inline always] *) + | Never_inline (* [@inline never] *) + | Default_inline (* no [@inline] attribute *) + +type let_kind = Strict | Alias | StrictOpt | Variable +(* Meaning of kinds for let x = e in e': + Strict: e may have side-effects; always evaluate e first + (If e is a simple expression, e.g. a variable or constant, + we may still substitute e'[x/e].) + Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences + in e' + StrictOpt: e does not have side-effects, but depend on the store; + we can discard e if x does not appear in e' + Variable: the variable x is assigned later in e' +*) + +(* [true] means yes, [false] may mean unknown *) +type function_attribute = { + inline: inline_attribute; + is_a_functor: bool; + return_unit: bool; + async: bool; + directive: string option; + one_unit_arg: bool; +} + +type lambda = + | Lvar of Ident.t + | Lconst of structured_constant + | Lapply of lambda_apply + | Lfunction of lfunction + | Llet of let_kind * value_kind * Ident.t * lambda * lambda + | Lletrec of (Ident.t * lambda) list * lambda + | Lprim of primitive * lambda list * Location.t + | Lswitch of lambda * lambda_switch * Location.t + (* switch on strings, clauses are sorted by string order, + strings are pairwise distinct *) + | Lstringswitch of + lambda * (string * lambda) list * lambda option * Location.t + | Lstaticraise of int * lambda list + | Lstaticcatch of lambda * (int * Ident.t list) * lambda + | Ltrywith of lambda * Ident.t * lambda + | Lifthenelse of lambda * lambda * lambda + | Lsequence of lambda * lambda + | Lwhile of lambda * lambda + | Lfor of Ident.t * lambda * lambda * direction_flag * lambda + | Lassign of Ident.t * lambda + | Lsend of string * lambda * Location.t + +and lfunction = { + params: Ident.t list; + body: lambda; + attr: function_attribute; (* specified with [@inline] attribute *) + loc: Location.t; +} + +and lambda_apply = { + ap_func: lambda; + ap_args: lambda list; + ap_loc: Location.t; + ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) + ap_transformed_jsx: bool; +} + +and lambda_switch = { + sw_numconsts: int; (* Number of integer cases *) + sw_consts: (int * lambda) list; (* Integer cases *) + sw_numblocks: int; (* Number of tag block cases *) + sw_blocks: (int * lambda) list; (* Tag block cases *) + sw_failaction: lambda option; (* Action to take if failure *) + sw_names: Ast_untagged_variants.switch_names option; +} + +(* Lambda code for the middle-end. + * In the closure case the code is a sequence of assignments to a + preallocated block of size [main_module_block_size] using + (Setfield(Getglobal(module_ident))). The size is used to preallocate + the block. + * In the flambda case the code is an expression returning a block + value of size [main_module_block_size]. The size is used to build + the module root as an initialize_symbol + Initialize_symbol(module_name, 0, + [getfield 0; ...; getfield (main_module_block_size - 1)]) +*) + +(* Sharing key *) +val make_key : lambda -> lambda option + +val const_unit : structured_constant +val lambda_assert_false : lambda +val lambda_unit : lambda +val lambda_module_alias : lambda +val name_lambda : let_kind -> lambda -> (Ident.t -> lambda) -> lambda + +val iter : (lambda -> unit) -> lambda -> unit +module IdentSet : Set.S with type elt = Ident.t +val free_variables : lambda -> IdentSet.t + +val transl_normal_path : Path.t -> lambda (* Path.t is already normal *) + +val transl_module_path : ?loc:Location.t -> Env.t -> Path.t -> lambda +val transl_value_path : ?loc:Location.t -> Env.t -> Path.t -> lambda +val transl_extension_path : ?loc:Location.t -> Env.t -> Path.t -> lambda + +val subst_lambda : lambda Ident.tbl -> lambda -> lambda +val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda + +val default_function_attribute : function_attribute + +(***********************) +(* For static failures *) +(***********************) + +(* Get a new static failure ident *) +val next_raise_count : unit -> int +val next_negative_raise_count : unit -> int +(* Negative raise counts are used to compile 'match ... with + exception x -> ...'. This disabled some simplifications + performed by the Simplif module that assume that static raises + are in tail position in their handler. *) + +val staticfail : lambda (* Anticipated static failure *) + +(* Check anticipated failure, substitute its final value *) +val is_guarded : lambda -> bool +val patch_guarded : lambda -> lambda -> lambda + +val raise_kind : raise_kind -> string +val lam_of_loc : loc_kind -> Location.t -> lambda diff --git a/compiler/ml/location.ml b/compiler/ml/location.ml new file mode 100644 index 0000000..fa2e806 --- /dev/null +++ b/compiler/ml/location.ml @@ -0,0 +1,305 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +open Lexing + +type t = Warnings.loc = { + loc_start: position; + loc_end: position; + loc_ghost: bool; +} + +let in_file name = + let loc = {pos_fname = name; pos_lnum = 1; pos_bol = 0; pos_cnum = -1} in + {loc_start = loc; loc_end = loc; loc_ghost = true} + +let none = in_file "_none_" + +let input_name = ref "_none_" +let set_input_name name = if name <> "" then input_name := name +(* Terminal info *) + +(* Print the location in some way or another *) + +open Format + +let show_filename file = if file = "_none_" then !input_name else file + +let print_filename ppf file = Format.fprintf ppf "%s" (show_filename file) + +(* return file, line, char from the given position *) +let get_pos_info pos = (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) + +let setup_colors () = + Misc.Color.setup !Clflags.color; + Code_frame.setup !Clflags.color + +(* ocaml's reported line/col numbering is horrible and super error-prone + when being handled programmatically (or humanly for that matter. If you're + an ocaml contributor reading this: who the heck reads the character count + starting from the first erroring character?) *) +let normalize_range loc = + (* TODO: lots of the handlings here aren't needed anymore because the new + rescript syntax has much stronger invariants regarding positions, e.g. + no -1 *) + let _, start_line, start_char = get_pos_info loc.loc_start in + let _, end_line, end_char = get_pos_info loc.loc_end in + (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) + (* start_char is inclusive, end_char is exclusive *) + if start_char == -1 || end_char == -1 then + (* happens sometimes. Syntax error for example *) + None + else if start_line = end_line && start_char >= end_char then + (* in some errors, starting char and ending char can be the same. But + since ending char was supposed to be exclusive, here it might end up + smaller than the starting char if we naively did start_char + 1 to + just the starting char and forget ending char *) + let same_char = start_char + 1 in + Some ((start_line, same_char), (end_line, same_char)) + else + (* again: end_char is exclusive, so +1-1=0 *) + Some ((start_line, start_char + 1), (end_line, end_char)) + +let print_loc ppf (loc : t) = + setup_colors (); + let normalized_range = normalize_range loc in + let dim_loc ppf = function + | None -> () + | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) + -> + if start_line = end_line then + if start_line_start_char = end_line_end_char then + fprintf ppf ":@{%i:%i@}" start_line start_line_start_char + else + fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char + end_line_end_char + else + fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char + end_line end_line_end_char + in + fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname + dim_loc normalized_range + +let print ?(src = None) ~message_kind intro ppf (loc : t) = + (match message_kind with + | `warning -> fprintf ppf "@[@{%s@}@]@," intro + | `warning_as_error -> + fprintf ppf "@[@{%s@} (configured as error) @]@," intro + | `error -> fprintf ppf "@[@{%s@}@]@," intro); + (* ocaml's reported line/col numbering is horrible and super error-prone + when being handled programmatically (or humanly for that matter. If you're + an ocaml contributor reading this: who the heck reads the character count + starting from the first erroring character?) *) + let file, start_line, start_char = get_pos_info loc.loc_start in + let _, end_line, end_char = get_pos_info loc.loc_end in + (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) + (* start_char is inclusive, end_char is exclusive *) + let normalized_range = + (* TODO: lots of the handlings here aren't needed anymore because the new + rescript syntax has much stronger invariants regarding positions, e.g. + no -1 *) + if start_char == -1 || end_char == -1 then + (* happens sometimes. Syntax error for example *) + None + else if start_line = end_line && start_char >= end_char then + (* in some errors, starting char and ending char can be the same. But + since ending char was supposed to be exclusive, here it might end up + smaller than the starting char if we naively did start_char + 1 to + just the starting char and forget ending char *) + let same_char = start_char + 1 in + Some ((start_line, same_char), (end_line, same_char)) + else + (* again: end_char is exclusive, so +1-1=0 *) + Some ((start_line, start_char + 1), (end_line, end_char)) + in + fprintf ppf " @[%a@]@," print_loc loc; + match normalized_range with + | None -> () + | Some _ -> ( + try + (* Print a syntax error that is a list of Res_diagnostics.t. + Instead of reading file for every error, it uses the source that the parser already has. *) + let src = + match src with + | Some src -> src + | None -> Ext_io.load_file file + in + (* we're putting the line break `@,` here rather than above, because this + branch might not be reached (aka no inline file content display) so + we don't wanna end up with two line breaks in the the consequent *) + fprintf ppf "@,%s" + (Code_frame.print ~is_warning:(message_kind = `warning) ~src + ~start_pos:loc.loc_start ~end_pos:loc.loc_end) + with + (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. + we've already printed the location above, so nothing more to do here. *) + | Sys_error _ -> + ()) + +let default_warning_printer loc ppf w = + match Warnings.report w with + | `Inactive -> () + | `Active {Warnings.number = _; message = _; is_error; sub_locs = _} -> + setup_colors (); + let message_kind = if is_error then `warning_as_error else `warning in + Format.fprintf ppf "@[@, %a@, %s@,@]@." + (print ~message_kind + ("Warning number " ^ (Warnings.number w |> string_of_int))) + loc (Warnings.message w) +(* at this point, you can display sub_locs too, from e.g. https://github.com/ocaml/ocaml/commit/f6d53cc38f87c67fbf49109f5fb79a0334bab17a + but we won't bother for now *) + +let warning_printer = ref default_warning_printer + +let print_warning loc ppf w = !warning_printer loc ppf w + +let formatter_for_warnings = ref err_formatter +let prerr_warning loc w = print_warning loc !formatter_for_warnings w + +type 'a loc = {txt: 'a; loc: t} + +let mkloc txt loc = {txt; loc} +let mknoloc txt = mkloc txt none + +type error = { + loc: t; + msg: string; + sub: error list; + if_highlight: string; (* alternative message if locations are highlighted *) +} + +let pp_ksprintf ?before k fmt = + let buf = Buffer.create 64 in + let ppf = Format.formatter_of_buffer buf in + Misc.Color.set_color_tag_handling ppf; + (match before with + | None -> () + | Some f -> f ppf); + kfprintf + (fun _ -> + pp_print_flush ppf (); + let msg = Buffer.contents buf in + k msg) + ppf fmt + +(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L354 *) +(* Shift the formatter's offset by the length of the error prefix, which + is always added by the compiler after the message has been formatted *) +let print_phanton_error_prefix ppf = + (* modified from the original. We use only 2 indentations for error report + (see super_error_reporter above) *) + Format.pp_print_as ppf 2 "" + +let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt = + pp_ksprintf ~before:print_phanton_error_prefix + (fun msg -> {loc; msg; sub; if_highlight}) + fmt + +let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg = + {loc; msg; sub; if_highlight} + +let error_of_exn : (exn -> error option) list ref = ref [] + +let register_error_of_exn f = error_of_exn := f :: !error_of_exn + +exception Already_displayed_error = Warnings.Errors + +let error_of_exn exn = + match exn with + | Already_displayed_error -> Some `Already_displayed + | _ -> + let rec loop = function + | [] -> None + | f :: rest -> ( + match f exn with + | Some error -> Some (`Ok error) + | None -> loop rest) + in + loop !error_of_exn + +(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) +(* This is the error report entry point. We'll replace the default reporter with this one. *) +let rec default_error_reporter ?(custom_intro = None) ?(src = None) ppf + {loc; msg; sub} = + setup_colors (); + (* open a vertical box. Everything in our message is indented 2 spaces *) + (* If src is given, it will display a syntax error after parsing. *) + let intro = + match (custom_intro, src) with + | Some intro, _ -> intro + | None, Some _ -> "Syntax error!" + | None, None -> "We've found a bug for you!" + in + Format.fprintf ppf "@[@, %a@, %s@,@]" + (print ~src ~message_kind:`error intro) + loc msg; + List.iter + (Format.fprintf ppf "@,@[%a@]" (default_error_reporter ~custom_intro ~src)) + sub +(* no need to flush here; location's report_exception (which uses this ultimately) flushes *) + +let error_reporter = ref default_error_reporter + +let report_error ?(custom_intro = None) ?(src = None) ppf err = + !error_reporter ~custom_intro ~src ppf err + +let error_of_printer loc print x = errorf ~loc "%a@?" print x + +let error_of_printer_file print x = + error_of_printer (in_file !input_name) print x + +let () = + register_error_of_exn (function + | Sys_error msg -> + Some (errorf ~loc:(in_file !input_name) "I/O error: %s" msg) + | Misc.HookExnWrapper {error = e; hook_name; hook_info = {Misc.sourcefile}} + -> + let sub = + match error_of_exn e with + | None | Some `Already_displayed -> error (Printexc.to_string e) + | Some (`Ok err) -> err + in + Some (errorf ~loc:(in_file sourcefile) "In hook %S:" hook_name ~sub:[sub]) + | _ -> None) + +external reraise : exn -> 'a = "%reraise" + +let rec report_exception_rec n ppf exn = + try + match error_of_exn exn with + | None -> reraise exn + | Some `Already_displayed -> () + | Some (`Ok err) -> + fprintf ppf "@[%a@]@." (report_error ~custom_intro:None ~src:None) err + with exn when n > 0 -> report_exception_rec (n - 1) ppf exn + +let report_exception ppf exn = report_exception_rec 5 ppf exn + +exception Error of error + +let () = + register_error_of_exn (function + | Error e -> Some e + | _ -> None) + +let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") = + pp_ksprintf ~before:print_phanton_error_prefix (fun msg -> + raise (Error {loc; msg; sub; if_highlight})) + +let deprecated ?(can_be_automigrated = false) ?(def = none) ?(use = none) loc + msg = + prerr_warning loc (Warnings.Deprecated (msg, def, use, can_be_automigrated)) + +let map_loc f {txt; loc} = {txt = f txt; loc} diff --git a/compiler/ml/location.mli b/compiler/ml/location.mli new file mode 100644 index 0000000..76f4db2 --- /dev/null +++ b/compiler/ml/location.mli @@ -0,0 +1,136 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Source code locations (ranges of positions), used in parsetree. *) + +open Format + +type t = Warnings.loc = { + loc_start: Lexing.position; + loc_end: Lexing.position; + loc_ghost: bool; +} + +(** Note on the use of Lexing.position in this module. + If [pos_fname = ""], then use [!input_name] instead. + If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and + re-parse the file to get the line and character numbers. + Else all fields are correct. +*) + +val none : t +(** An arbitrary value of type [t]; describes an empty ghost range. *) + +val in_file : string -> t +(** Return an empty ghost range located in a given file. *) + +val input_name : string ref +val set_input_name : string -> unit + +val get_pos_info : Lexing.position -> string * int * int (* file, line, char *) +val print_loc : formatter -> t -> unit + +val prerr_warning : t -> Warnings.t -> unit + +val warning_printer : (t -> formatter -> Warnings.t -> unit) ref +(** Hook for intercepting warnings. *) + +val formatter_for_warnings : formatter ref + +val default_warning_printer : t -> formatter -> Warnings.t -> unit +(** Original warning printer for use in hooks. *) + +type 'a loc = {txt: 'a; loc: t} + +val mknoloc : 'a -> 'a loc +val mkloc : 'a -> t -> 'a loc + +val print_filename : formatter -> string -> unit + +val show_filename : string -> string + +(** Support for located errors *) + +type error = { + loc: t; + msg: string; + sub: error list; + if_highlight: string; (* alternative message if locations are highlighted *) +} + +exception Already_displayed_error +exception Error of error + +val error : ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error + +val errorf : + ?loc:t -> + ?sub:error list -> + ?if_highlight:string -> + ('a, Format.formatter, unit, error) format4 -> + 'a + +val raise_errorf : + ?loc:t -> + ?sub:error list -> + ?if_highlight:string -> + ('a, Format.formatter, unit, 'b) format4 -> + 'a + +val error_of_printer : t -> (formatter -> 'a -> unit) -> 'a -> error + +val error_of_printer_file : (formatter -> 'a -> unit) -> 'a -> error + +val error_of_exn : exn -> [`Ok of error | `Already_displayed] option + +val register_error_of_exn : (exn -> error option) -> unit +(** Each compiler module which defines a custom type of exception + which can surface as a user-visible error should register + a "printer" for this exception using [register_error_of_exn]. + The result of the printer is an [error] value containing + a location, a message, and optionally sub-messages (each of them + being located as well). *) + +val report_error : + ?custom_intro:string option -> + ?src:string option -> + formatter -> + error -> + unit + +val error_reporter : + (?custom_intro:string option -> + ?src:string option -> + formatter -> + error -> + unit) + ref +(** Hook for intercepting error reports. *) + +val default_error_reporter : + ?custom_intro:string option -> + ?src:string option -> + formatter -> + error -> + unit +(** Original error reporter for use in hooks. *) + +val report_exception : formatter -> exn -> unit +(** Reraise the exception if it is unknown. *) + +val deprecated : + ?can_be_automigrated:bool -> ?def:t -> ?use:t -> t -> string -> unit + +val map_loc : ('a -> 'b) -> 'a loc -> 'b loc diff --git a/compiler/ml/longident.ml b/compiler/ml/longident.ml new file mode 100644 index 0000000..721a131 --- /dev/null +++ b/compiler/ml/longident.ml @@ -0,0 +1,65 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +type t = Lident of string | Ldot of t * string | Lapply of t * t +let rec cmp : t -> t -> int = + fun a b -> + if a == b then 0 + else + match (a, b) with + | Lident a, Lident b -> compare a b + | Lident _, _ -> -1 + | _, Lident _ -> 1 + | Ldot (a, b), Ldot (c, d) -> ( + match cmp a c with + | 0 -> compare b d + | n -> n) + | Ldot _, _ -> -1 + | _, Ldot _ -> 1 + | Lapply (a, b), Lapply (c, d) -> ( + match cmp a c with + | 0 -> cmp b d + | n -> n) + +let rec flat accu = function + | Lident s -> s :: accu + | Ldot (lid, s) -> flat (s :: accu) lid + | Lapply (_, _) -> Misc.fatal_error "Longident.flat" + +let flatten lid = flat [] lid + +let last = function + | Lident s -> s + | Ldot (_, s) -> s + | Lapply (_, _) -> Misc.fatal_error "Longident.last" + +let rec split_at_dots s pos = + try + let dot = String.index_from s pos '.' in + String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) + with Not_found -> [String.sub s pos (String.length s - pos)] + +let unflatten l = + match l with + | [] -> None + | hd :: tl -> Some (List.fold_left (fun p s -> Ldot (p, s)) (Lident hd) tl) + +let parse s = + match unflatten (split_at_dots s 0) with + | None -> + Lident "" + (* should not happen, but don't put assert false + so as not to crash the toplevel (see Genprintval) *) + | Some v -> v diff --git a/jscomp/ml/longident.mli b/compiler/ml/longident.mli similarity index 84% rename from jscomp/ml/longident.mli rename to compiler/ml/longident.mli index 4c65fa6..26ed938 100644 --- a/jscomp/ml/longident.mli +++ b/compiler/ml/longident.mli @@ -15,13 +15,10 @@ (** Long identifiers, used in parsetree. *) -type t = - Lident of string - | Ldot of t * string - | Lapply of t * t +type t = Lident of string | Ldot of t * string | Lapply of t * t -val cmp : t -> t -> int -val flatten: t -> string list -val unflatten: string list -> t option -val last: t -> string -val parse: string -> t +val cmp : t -> t -> int +val flatten : t -> string list +val unflatten : string list -> t option +val last : t -> string +val parse : string -> t diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml new file mode 100644 index 0000000..b84339a --- /dev/null +++ b/compiler/ml/matching.ml @@ -0,0 +1,2978 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Compilation of pattern matching *) + +open Misc +open Asttypes +open Types +open Typedtree +open Lambda +open Parmatch +open Printf + +let dbg = false + +(* See Peyton-Jones, ``The Implementation of functional programming + languages'', chapter 5. *) +(* + Well, it was true at the beginning of the world. + Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 +*) + +(* + Compatibility predicate that considers potential rebindings of constructors + of an extension type. + + "may_compat p q" returns false when p and q never admit a common instance; + returns true when they may have a common instance. +*) + +let equal_cd c1 c2 = Types.may_equal_constr c1 c2 + +let may_compat = Parmatch.Compat.compat ~equal_cd + +and may_compats = Parmatch.Compat.compats ~equal_cd + +(* + Many functions on the various data structures of the algorithm : + - Pattern matrices. + - Default environments: mapping from matrices to exit numbers. + - Contexts: matrices whose column are partitioned into + left and right. + - Jump summaries: mapping from exit numbers to contexts +*) + +let string_of_lam lam = + Printlambda.lambda Format.str_formatter lam; + Format.flush_str_formatter () + +type matrix = pattern list list + +let add_omega_column pss = List.map (fun ps -> omega :: ps) pss + +type ctx = {left: pattern list; right: pattern list} + +let pretty_ctx ctx = + List.iter + (fun {left; right} -> + prerr_string "LEFT:"; + pretty_line left; + prerr_string " RIGHT:"; + pretty_line right; + prerr_endline "") + ctx + +let le_ctx c1 c2 = le_pats c1.left c2.left && le_pats c1.right c2.right + +let lshift {left; right} = + match right with + | x :: xs -> {left = x :: left; right = xs} + | _ -> assert false + +let lforget {left; right} = + match right with + | _ :: xs -> {left = omega :: left; right = xs} + | _ -> assert false + +let rec small_enough n = function + | [] -> true + | _ :: rem -> if n <= 0 then false else small_enough (n - 1) rem + +let ctx_lshift ctx = + if small_enough 31 ctx then List.map lshift ctx + else (* Context pruning *) get_mins le_ctx (List.map lforget ctx) + +let rshift {left; right} = + match left with + | p :: ps -> {left = ps; right = p :: right} + | _ -> assert false + +let ctx_rshift ctx = List.map rshift ctx + +let rec nchars n ps = + if n <= 0 then ([], ps) + else + match ps with + | p :: rem -> + let chars, cdrs = nchars (n - 1) rem in + (p :: chars, cdrs) + | _ -> assert false + +let rshift_num n {left; right} = + let shifted, left = nchars n left in + {left; right = shifted @ right} + +let ctx_rshift_num n ctx = List.map (rshift_num n) ctx + +(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem) + All mutable fields are replaced by '_', since side-effects in + guards can alter these fields *) + +let combine {left; right} = + match left with + | p :: ps -> {left = ps; right = set_args_erase_mutable p right} + | _ -> assert false + +let ctx_combine ctx = List.map combine ctx + +let ncols = function + | [] -> 0 + | ps :: _ -> List.length ps + +exception NoMatch +exception OrPat + +let filter_matrix matcher pss = + let rec filter_rec = function + | (p :: ps) :: rem -> ( + match p.pat_desc with + | Tpat_alias (p, _, _) -> filter_rec ((p :: ps) :: rem) + | Tpat_var _ -> filter_rec ((omega :: ps) :: rem) + | _ -> ( + let rem = filter_rec rem in + try matcher p ps :: rem with + | NoMatch -> rem + | OrPat -> ( + match p.pat_desc with + | Tpat_or (p1, p2, _) -> filter_rec [p1 :: ps; p2 :: ps] @ rem + | _ -> assert false))) + | [] -> [] + | _ -> + pretty_matrix pss; + fatal_error "Matching.filter_matrix" + in + filter_rec pss + +let make_default matcher env = + let rec make_rec = function + | [] -> [] + | ([[]], i) :: _ -> [([[]], i)] + | (pss, i) :: rem -> ( + let rem = make_rec rem in + match filter_matrix matcher pss with + | [] -> rem + | [] :: _ -> ([[]], i) :: rem + | pss -> (pss, i) :: rem) + in + make_rec env + +let ctx_matcher p = + let p = normalize_pat p in + match p.pat_desc with + | Tpat_construct (_, cstr, omegas) -> ( + fun q rem -> + match q.pat_desc with + | Tpat_construct (_, cstr', args) + (* NB: may_constr_equal considers (potential) constructor rebinding *) + when Types.may_equal_constr cstr cstr' -> + (p, args @ rem) + | Tpat_any -> (p, omegas @ rem) + | _ -> raise NoMatch) + | Tpat_constant cst -> ( + fun q rem -> + match q.pat_desc with + | Tpat_constant cst' when const_compare cst cst' = 0 -> (p, rem) + | Tpat_any -> (p, rem) + | _ -> raise NoMatch) + | Tpat_variant (lab, Some omega, _) -> ( + fun q rem -> + match q.pat_desc with + | Tpat_variant (lab', Some arg, _) when lab = lab' -> (p, arg :: rem) + | Tpat_any -> (p, omega :: rem) + | _ -> raise NoMatch) + | Tpat_variant (lab, None, _) -> ( + fun q rem -> + match q.pat_desc with + | Tpat_variant (lab', None, _) when lab = lab' -> (p, rem) + | Tpat_any -> (p, rem) + | _ -> raise NoMatch) + | Tpat_array omegas -> ( + let len = List.length omegas in + fun q rem -> + match q.pat_desc with + | Tpat_array args when List.length args = len -> (p, args @ rem) + | Tpat_any -> (p, omegas @ rem) + | _ -> raise NoMatch) + | Tpat_tuple omegas -> ( + let len = List.length omegas in + fun q rem -> + match q.pat_desc with + | Tpat_tuple args when List.length args = len -> (p, args @ rem) + | Tpat_any -> (p, omegas @ rem) + | _ -> raise NoMatch) + | Tpat_record (((_, lbl, _, _) :: _ as l), _) -> ( + (* Records are normalized *) + let len = Array.length lbl.lbl_all in + fun q rem -> + match q.pat_desc with + | Tpat_record (((_, lbl', _, _) :: _ as l'), _) + when Array.length lbl'.lbl_all = len -> + let l' = all_record_args l' in + (p, List.fold_right (fun (_, _, p, _) r -> p :: r) l' rem) + | Tpat_any -> (p, List.fold_right (fun (_, _, p, _) r -> p :: r) l rem) + | _ -> raise NoMatch) + | _ -> fatal_error "Matching.ctx_matcher" + +let filter_ctx q ctx = + let matcher = ctx_matcher q in + + let rec filter_rec = function + | ({right = p :: ps} as l) :: rem -> ( + match p.pat_desc with + | Tpat_or (p1, p2, _) -> + filter_rec + ({l with right = p1 :: ps} :: {l with right = p2 :: ps} :: rem) + | Tpat_alias (p, _, _) -> filter_rec ({l with right = p :: ps} :: rem) + | Tpat_var _ -> filter_rec ({l with right = omega :: ps} :: rem) + | _ -> ( + let rem = filter_rec rem in + try + let to_left, right = matcher p ps in + {left = to_left :: l.left; right} :: rem + with NoMatch -> rem)) + | [] -> [] + | _ -> fatal_error "Matching.filter_ctx" + in + + filter_rec ctx + +let select_columns pss ctx = + let n = ncols pss in + List.fold_right + (fun ps r -> + List.fold_right + (fun {left; right} r -> + let transfert, right = nchars n right in + try {left = lubs transfert ps @ left; right} :: r with Empty -> r) + ctx r) + pss [] + +let ctx_lub p ctx = + List.fold_right + (fun {left; right} r -> + match right with + | q :: rem -> ( try {left; right = lub p q :: rem} :: r with Empty -> r) + | _ -> fatal_error "Matching.ctx_lub") + ctx [] + +let ctx_match ctx pss = + List.exists + (fun {right = qs} -> List.exists (fun ps -> may_compats qs ps) pss) + ctx + +type jumps = (int * ctx list) list + +let pretty_jumps (env : jumps) = + match env with + | [] -> () + | _ -> + List.iter + (fun (i, ctx) -> + Printf.fprintf stderr "jump for %d\n" i; + pretty_ctx ctx) + env + +let rec jumps_extract (i : int) = function + | [] -> ([], []) + | ((j, pss) as x) :: rem as all -> + if i = j then (pss, rem) + else if j < i then ([], all) + else + let r, rem = jumps_extract i rem in + (r, x :: rem) + +let rec jumps_remove (i : int) = function + | [] -> [] + | (j, _) :: rem when i = j -> rem + | x :: rem -> x :: jumps_remove i rem + +let jumps_empty = [] + +and jumps_is_empty = function + | [] -> true + | _ -> false + +let jumps_singleton i = function + | [] -> [] + | ctx -> [(i, ctx)] + +let jumps_add i pss jumps = + match pss with + | [] -> jumps + | _ -> + let rec add = function + | [] -> [(i, pss)] + | ((j, qss) as x) :: rem as all -> + if (j : int) > i then x :: add rem + else if j < i then (i, pss) :: all + else (i, get_mins le_ctx (pss @ qss)) :: rem + in + add jumps + +let rec jumps_union (env1 : (int * ctx list) list) env2 = + match (env1, env2) with + | [], _ -> env2 + | _, [] -> env1 + | ((i1, pss1) as x1) :: rem1, ((i2, pss2) as x2) :: rem2 -> + if i1 = i2 then (i1, get_mins le_ctx (pss1 @ pss2)) :: jumps_union rem1 rem2 + else if i1 > i2 then x1 :: jumps_union rem1 env2 + else x2 :: jumps_union env1 rem2 + +let rec merge = function + | env1 :: env2 :: rem -> jumps_union env1 env2 :: merge rem + | envs -> envs + +let rec jumps_unions envs = + match envs with + | [] -> [] + | [env] -> env + | _ -> jumps_unions (merge envs) + +let jumps_map f env = List.map (fun (i, pss) -> (i, f pss)) env + +(* Pattern matching before any compilation *) + +type pattern_matching = { + mutable cases: (pattern list * lambda) list; + args: (lambda * let_kind) list; + default: (matrix * int) list; +} + +(* Pattern matching after application of both the or-pat rule and the + mixture rule *) + +type pm_or_compiled = { + body: pattern_matching; + handlers: (matrix * int * Ident.t list * pattern_matching) list; + or_matrix: matrix; +} + +type pm_half_compiled = + | PmOr of pm_or_compiled + | PmVar of pm_var_compiled + | Pm of pattern_matching + +and pm_var_compiled = {inside: pm_half_compiled; var_arg: lambda} + +type pm_half_compiled_info = { + me: pm_half_compiled; + matrix: matrix; + top_default: (matrix * int) list; +} + +let pretty_cases cases = + List.iter + (fun (ps, _l) -> + List.iter + (fun p -> + Parmatch.top_pretty Format.str_formatter p; + prerr_string " "; + prerr_string (Format.flush_str_formatter ())) + ps; + (* + prerr_string " -> " ; + Printlambda.lambda Format.str_formatter l ; + prerr_string (Format.flush_str_formatter ()) ; +*) + prerr_endline "") + cases + +let pretty_def def = + prerr_endline "+++++ Defaults +++++"; + List.iter + (fun (pss, i) -> + Printf.fprintf stderr "Matrix for %d\n" i; + pretty_matrix pss) + def; + prerr_endline "+++++++++++++++++++++" + +let pretty_pm pm = + pretty_cases pm.cases; + if pm.default <> [] then pretty_def pm.default + +let rec pretty_precompiled = function + | Pm pm -> + prerr_endline "++++ PM ++++"; + pretty_pm pm + | PmVar x -> + prerr_endline "++++ VAR ++++"; + pretty_precompiled x.inside + | PmOr x -> + prerr_endline "++++ OR ++++"; + pretty_pm x.body; + pretty_matrix x.or_matrix; + List.iter + (fun (_, i, _, pm) -> + eprintf "++ Handler %d ++\n" i; + pretty_pm pm) + x.handlers + +let pretty_precompiled_res first nexts = + pretty_precompiled first; + List.iter + (fun (e, pmh) -> + eprintf "** DEFAULT %d **\n" e; + pretty_precompiled pmh) + nexts + +(* Identifying some semantically equivalent lambda-expressions, + Our goal here is also to + find alpha-equivalent (simple) terms *) + +(* However, as shown by PR#6359 such sharing may hinders the + lambda-code invariant that all bound idents are unique, + when switches are compiled to test sequences. + The definitive fix is the systematic introduction of exit/catch + in case action sharing is present. +*) + +module StoreExp = Switch.Store (struct + type t = lambda + type key = lambda + let compare_key = compare + let make_key = Lambda.make_key +end) + +let make_exit i = Lstaticraise (i, []) + +(* Introduce a catch, if worth it *) +let make_catch d k = + match d with + | Lstaticraise (_, []) -> k d + | _ -> + let e = next_raise_count () in + Lstaticcatch (k (make_exit e), (e, []), d) + +(* Introduce a catch, if worth it, delayed version *) +let rec as_simple_exit = function + | Lstaticraise (i, []) -> Some i + | Llet (Alias, _k, _, _, e) -> as_simple_exit e + | _ -> None + +let make_catch_delayed handler = + match as_simple_exit handler with + | Some i -> (i, fun act -> act) + | None -> ( + let i = next_raise_count () in + (* + Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); +*) + ( i, + fun body -> + match body with + | Lstaticraise (j, _) -> if i = j then handler else body + | _ -> Lstaticcatch (body, (i, []), handler) )) + +let raw_action l = + match make_key l with + | Some l -> l + | None -> l + +let tr_raw act = + match make_key act with + | Some act -> act + | None -> raise Exit + +let same_actions = function + | [] -> None + | [(_, act)] -> Some act + | (_, act0) :: rem -> ( + try + let raw_act0 = tr_raw act0 in + let rec s_rec = function + | [] -> Some act0 + | (_, act) :: rem -> if raw_act0 = tr_raw act then s_rec rem else None + in + s_rec rem + with Exit -> None) + +(* Test for swapping two clauses *) + +let up_ok_action act1 act2 = + try + let raw1 = tr_raw act1 and raw2 = tr_raw act2 in + raw1 = raw2 + with Exit -> false + +let up_ok (ps, act_p) l = + List.for_all + (fun (qs, act_q) -> up_ok_action act_p act_q || not (may_compats ps qs)) + l + +(* + The simplify function normalizes the first column of the match + - records are expanded so that they possess all fields + - aliases are removed and replaced by bindings in actions. + However or-patterns are simplified differently, + - aliases are not removed + - or-patterns (_|p) are changed into _ +*) + +exception Var of pattern + +let simplify_or p = + let rec simpl_rec p = + match p with + | {pat_desc = Tpat_any | Tpat_var _} -> raise (Var p) + | {pat_desc = Tpat_alias (q, id, s)} -> ( + try {p with pat_desc = Tpat_alias (simpl_rec q, id, s)} + with Var q -> raise (Var {p with pat_desc = Tpat_alias (q, id, s)})) + | {pat_desc = Tpat_or (p1, p2, o)} -> ( + let q1 = simpl_rec p1 in + try + let q2 = simpl_rec p2 in + {p with pat_desc = Tpat_or (q1, q2, o)} + with Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)})) + | {pat_desc = Tpat_record (lbls, closed)} -> + let all_lbls = all_record_args lbls in + {p with pat_desc = Tpat_record (all_lbls, closed)} + | _ -> p + in + try simpl_rec p with Var p -> p + +let simplify_cases args cls = + match args with + | [] -> assert false + | (arg, _) :: _ -> + let rec simplify = function + | [] -> [] + | ((pat :: patl, action) as cl) :: rem -> ( + match pat.pat_desc with + | Tpat_var (id, _) -> + (omega :: patl, bind Alias id arg action) :: simplify rem + | Tpat_any -> cl :: simplify rem + | Tpat_alias (p, id, _) -> + simplify ((p :: patl, bind Alias id arg action) :: rem) + | Tpat_record ([], _) -> (omega :: patl, action) :: simplify rem + | Tpat_record (lbls, closed) -> + let all_lbls = all_record_args lbls in + let full_pat = {pat with pat_desc = Tpat_record (all_lbls, closed)} in + (full_pat :: patl, action) :: simplify rem + | Tpat_or _ -> ( + let pat_simple = simplify_or pat in + match pat_simple.pat_desc with + | Tpat_or _ -> (pat_simple :: patl, action) :: simplify rem + | _ -> simplify ((pat_simple :: patl, action) :: rem)) + | _ -> cl :: simplify rem) + | _ -> assert false + in + + simplify cls + +(* Once matchings are simplified one can easily find + their nature *) + +let rec what_is_cases cases = + match cases with + | ({pat_desc = Tpat_any} :: _, _) :: rem -> what_is_cases rem + | ({pat_desc = Tpat_var _ | Tpat_or (_, _, _) | Tpat_alias (_, _, _)} :: _, _) + :: _ -> + assert false (* applies to simplified matchings only *) + | (p :: _, _) :: _ -> p + | [] -> omega + | _ -> assert false + +(* A few operations on default environments *) +let as_matrix cases = get_mins le_pats (List.map (fun (ps, _) -> ps) cases) + +let cons_default matrix raise_num default = + match matrix with + | [] -> default + | _ -> (matrix, raise_num) :: default + +let default_compat p def = + List.fold_right + (fun (pss, i) r -> + let qss = + List.fold_right + (fun qs r -> + match qs with + | q :: rem when may_compat p q -> rem :: r + | _ -> r) + pss [] + in + match qss with + | [] -> r + | _ -> (qss, i) :: r) + def [] + +(* Or-pattern expansion, variables are a complication w.r.t. the article *) +let rec extract_vars r p = + match p.pat_desc with + | Tpat_var (id, _) -> IdentSet.add id r + | Tpat_alias (p, id, _) -> extract_vars (IdentSet.add id r) p + | Tpat_tuple pats -> List.fold_left extract_vars r pats + | Tpat_record (lpats, _) -> + List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats + | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats + | Tpat_array pats -> List.fold_left extract_vars r pats + | Tpat_variant (_, Some p, _) -> extract_vars r p + | Tpat_or (p, _, _) -> extract_vars r p + | Tpat_constant _ | Tpat_any | Tpat_variant (_, None, _) -> r + +exception Cannot_flatten + +let mk_alpha_env arg aliases ids = + List.map + (fun id -> + ( id, + if List.mem id aliases then + match arg with + | Some v -> v + | _ -> raise Cannot_flatten + else Ident.create (Ident.name id) )) + ids + +let rec explode_or_pat arg patl mk_action rem vars aliases = function + | {pat_desc = Tpat_or (p1, p2, _)} -> + explode_or_pat arg patl mk_action + (explode_or_pat arg patl mk_action rem vars aliases p2) + vars aliases p1 + | {pat_desc = Tpat_alias (p, id, _)} -> + explode_or_pat arg patl mk_action rem vars (id :: aliases) p + | {pat_desc = Tpat_var (x, _)} -> + let env = mk_alpha_env arg (x :: aliases) vars in + (omega :: patl, mk_action (List.map snd env)) :: rem + | p -> + let env = mk_alpha_env arg aliases vars in + (alpha_pat env p :: patl, mk_action (List.map snd env)) :: rem + +let pm_free_variables {cases} = + List.fold_right + (fun (_, act) r -> IdentSet.union (free_variables act) r) + cases IdentSet.empty + +(* Basic grouping predicates *) +let pat_as_constr = function + | {pat_desc = Tpat_construct (_, cstr, _)} -> cstr + | _ -> fatal_error "Matching.pat_as_constr" + +let group_constant = function + | {pat_desc = Tpat_constant _} -> true + | _ -> false + +and group_constructor = function + | {pat_desc = Tpat_construct (_, _, _)} -> true + | _ -> false + +and group_variant = function + | {pat_desc = Tpat_variant (_, _, _)} -> true + | _ -> false + +and group_var = function + | {pat_desc = Tpat_any} -> true + | _ -> false + +and group_tuple = function + | {pat_desc = Tpat_tuple _ | Tpat_any} -> true + | _ -> false + +and group_record = function + | {pat_desc = Tpat_record _ | Tpat_any} -> true + | _ -> false + +and group_array = function + | {pat_desc = Tpat_array _} -> true + | _ -> false + +let get_group p = + match p.pat_desc with + | Tpat_any -> group_var + | Tpat_constant _ -> group_constant + | Tpat_construct _ -> group_constructor + | Tpat_tuple _ -> group_tuple + | Tpat_record _ -> group_record + | Tpat_array _ -> group_array + | Tpat_variant (_, _, _) -> group_variant + | _ -> fatal_error "Matching.get_group" + +let is_or p = + match p.pat_desc with + | Tpat_or _ -> true + | _ -> false + +(* Conditions for appending to the Or matrix *) +let conda p q = not (may_compat p q) + +and condb act ps qs = (not (is_guarded act)) && Parmatch.le_pats qs ps + +let or_ok p ps l = + List.for_all + (function + | ({pat_desc = Tpat_or _} as q) :: qs, act -> conda p q || condb act ps qs + | _ -> true) + l + +(* Insert or append a pattern in the Or matrix *) + +let equiv_pat p q = le_pat p q && le_pat q p + +let rec get_equiv p l = + match l with + | ((q :: _, _) as cl) :: rem -> + if equiv_pat p q then + let others, rem = get_equiv p rem in + (cl :: others, rem) + else ([], l) + | _ -> ([], l) + +let insert_or_append p ps act ors no = + let rec attempt seen = function + | ((q :: qs, act_q) as cl) :: rem -> + if is_or q then + if may_compat p q then + if + IdentSet.is_empty (extract_vars IdentSet.empty p) + && IdentSet.is_empty (extract_vars IdentSet.empty q) + && equiv_pat p q + then + (* attempt insert, for equivalent orpats with no variables *) + let _, not_e = get_equiv q rem in + if + or_ok p ps not_e + && + (* check append condition for head of O *) + List.for_all (* check insert condition for tail of O *) + (fun cl -> + match cl with + | q :: _, _ -> not (may_compat p q) + | _ -> assert false) + seen + then + (* insert *) + (List.rev_append seen ((p :: ps, act) :: cl :: rem), no) + else (* fail to insert or append *) + (ors, (p :: ps, act) :: no) + else if condb act_q ps qs then + (* check condition (b) for append *) + attempt (cl :: seen) rem + else (ors, (p :: ps, act) :: no) + else (* p # q, go on with append/insert *) + attempt (cl :: seen) rem + else + (* q is not an or-pat, go on with append/insert *) + attempt (cl :: seen) rem + | _ -> + (* [] in fact *) + ((p :: ps, act) :: ors, no) + in + (* success in appending *) + attempt [] ors + +(* Reconstruct default information from half_compiled pm list *) + +let rec rebuild_matrix pmh = + match pmh with + | Pm pm -> as_matrix pm.cases + | PmOr {or_matrix = m} -> m + | PmVar x -> add_omega_column (rebuild_matrix x.inside) + +let rec rebuild_default nexts def = + match nexts with + | [] -> def + | (e, pmh) :: rem -> + (add_omega_column (rebuild_matrix pmh), e) :: rebuild_default rem def + +let rebuild_nexts arg nexts k = + List.fold_right + (fun (e, pm) k -> (e, PmVar {inside = pm; var_arg = arg}) :: k) + nexts k + +(* + Split a matching. + Splitting is first directed by or-patterns, then by + tests (e.g. constructors)/variable transitions. + + The approach is greedy, every split function attempts to + raise rows as much as possible in the top matrix, + then splitting applies again to the remaining rows. + + Some precompilation of or-patterns and + variable pattern occurs. Mostly this means that bindings + are performed now, being replaced by let-bindings + in actions (cf. simplify_cases). + + Additionally, if the match argument is a variable, matchings whose + first column is made of variables only are splitted further + (cf. precompile_var). + +*) + +let rec split_or argo cls args def = + let cls = simplify_cases args cls in + + let rec do_split before ors no = function + | [] -> cons_next (List.rev before) (List.rev ors) (List.rev no) + | ((p :: ps, act) as cl) :: rem -> + if up_ok cl no then + if is_or p then + let ors, no = insert_or_append p ps act ors no in + do_split before ors no rem + else if up_ok cl ors then do_split (cl :: before) ors no rem + else if or_ok p ps ors then do_split before (cl :: ors) no rem + else do_split before ors (cl :: no) rem + else do_split before ors (cl :: no) rem + | _ -> assert false + and cons_next yes yesor = function + | [] -> precompile_or argo yes yesor args def [] + | rem -> + let {me = next; matrix; top_default = def}, nexts = + do_split [] [] [] rem + in + let idef = next_raise_count () in + precompile_or argo yes yesor args + (cons_default matrix idef def) + ((idef, next) :: nexts) + in + + do_split [] [] [] cls + +(* Ultra-naive splitting, close to semantics, used for extension, + as potential rebind prevents any kind of optimisation *) + +and split_naive cls args def k = + let rec split_exc cstr0 yes = function + | [] -> + let yes = List.rev yes in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + k ) + | ((p :: _, _) as cl) :: rem -> + if group_constructor p then + let cstr = pat_as_constr p in + if cstr = cstr0 then split_exc cstr0 (cl :: yes) rem + else + let yes = List.rev yes in + let {me = next; matrix; top_default = def}, nexts = + split_exc cstr [cl] rem + in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + (idef, next) :: nexts ) + else + let yes = List.rev yes in + let {me = next; matrix; top_default = def}, nexts = + split_noexc [cl] rem + in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + (idef, next) :: nexts ) + | _ -> assert false + and split_noexc yes = function + | [] -> precompile_var args (List.rev yes) def k + | ((p :: _, _) as cl) :: rem -> + if group_constructor p then + let yes = List.rev yes in + let {me = next; matrix; top_default = def}, nexts = + split_exc (pat_as_constr p) [cl] rem + in + let idef = next_raise_count () in + precompile_var args yes + (cons_default matrix idef def) + ((idef, next) :: nexts) + else split_noexc (cl :: yes) rem + | _ -> assert false + in + + match cls with + | [] -> assert false + | ((p :: _, _) as cl) :: rem -> + if group_constructor p then split_exc (pat_as_constr p) [cl] rem + else split_noexc [cl] rem + | _ -> assert false + +and split_constr cls args def k = + let ex_pat = what_is_cases cls in + match ex_pat.pat_desc with + | Tpat_any -> precompile_var args cls def k + | Tpat_construct (_, {cstr_tag = Cstr_extension _}, _) -> + split_naive cls args def k + | _ -> ( + let group = get_group ex_pat in + + let rec split_ex yes no = function + | [] -> ( + let yes = List.rev yes and no = List.rev no in + match no with + | [] -> + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + k ) + | cl :: rem -> ( + match yes with + | [] -> + (* Could not success in raising up a constr matching up *) + split_noex [cl] [] rem + | _ -> + let {me = next; matrix; top_default = def}, nexts = + split_noex [cl] [] rem + in + let idef = next_raise_count () in + let def = cons_default matrix idef def in + ( { + me = Pm {cases = yes; args; default = def}; + matrix = as_matrix yes; + top_default = def; + }, + (idef, next) :: nexts ))) + | ((p :: _, _) as cl) :: rem -> + if group p && up_ok cl no then split_ex (cl :: yes) no rem + else split_ex yes (cl :: no) rem + | _ -> assert false + and split_noex yes no = function + | [] -> ( + let yes = List.rev yes and no = List.rev no in + match no with + | [] -> precompile_var args yes def k + | cl :: rem -> + let {me = next; matrix; top_default = def}, nexts = + split_ex [cl] [] rem + in + let idef = next_raise_count () in + precompile_var args yes + (cons_default matrix idef def) + ((idef, next) :: nexts)) + | [((ps, _) as cl)] when List.for_all group_var ps && yes <> [] -> + (* This enables an extra division in some frequent cases : + last row is made of variables only *) + split_noex yes (cl :: no) [] + | ((p :: _, _) as cl) :: rem -> + if (not (group p)) && up_ok cl no then split_noex (cl :: yes) no rem + else split_noex yes (cl :: no) rem + | _ -> assert false + in + + match cls with + | ((p :: _, _) as cl) :: rem -> + if group p then split_ex [cl] [] rem else split_noex [cl] [] rem + | _ -> assert false) + +and precompile_var args cls def k = + match args with + | [] -> assert false + | _ :: (((Lvar v as av), _) as arg) :: rargs -> ( + match cls with + | [_] -> + (* as splitted as it can *) + dont_precompile_var args cls def k + | _ -> ( + (* Precompile *) + let var_cls = + List.map + (fun (ps, act) -> + match ps with + | _ :: ps -> (ps, act) + | _ -> assert false) + cls + and var_def = make_default (fun _ rem -> rem) def in + let {me = first; matrix}, nexts = + split_or (Some v) var_cls (arg :: rargs) var_def + in + + (* Compute top information *) + match nexts with + | [] -> + (* If you need *) + dont_precompile_var args cls def k + | _ -> + let rfirst = + { + me = PmVar {inside = first; var_arg = av}; + matrix = add_omega_column matrix; + top_default = rebuild_default nexts def; + } + and rnexts = rebuild_nexts av nexts k in + (rfirst, rnexts))) + | _ -> dont_precompile_var args cls def k + +and dont_precompile_var args cls def k = + ( { + me = Pm {cases = cls; args; default = def}; + matrix = as_matrix cls; + top_default = def; + }, + k ) + +and precompile_or argo cls ors args def k = + match ors with + | [] -> split_constr cls args def k + | _ -> + let rec do_cases = function + | (({pat_desc = Tpat_or _} as orp) :: patl, action) :: rem -> + let others, rem = get_equiv orp rem in + let orpm = + { + cases = + (patl, action) + :: List.map + (function + | _ :: ps, action -> (ps, action) + | _ -> assert false) + others; + args = + (match args with + | _ :: r -> r + | _ -> assert false); + default = default_compat orp def; + } + in + let vars = + IdentSet.elements + (IdentSet.inter + (extract_vars IdentSet.empty orp) + (pm_free_variables orpm)) + in + let or_num = next_raise_count () in + let new_patl = Parmatch.omega_list patl in + + let mk_new_action vs = + Lstaticraise (or_num, List.map (fun v -> Lvar v) vs) + in + + let body, handlers = do_cases rem in + ( explode_or_pat argo new_patl mk_new_action body vars [] orp, + let mat = [[orp]] in + (mat, or_num, vars, orpm) :: handlers ) + | cl :: rem -> + let new_ord, new_to_catch = do_cases rem in + (cl :: new_ord, new_to_catch) + | [] -> ([], []) + in + + let end_body, handlers = do_cases ors in + let matrix = as_matrix (cls @ ors) + and body = {cases = cls @ end_body; args; default = def} in + ( {me = PmOr {body; handlers; or_matrix = matrix}; matrix; top_default = def}, + k ) + +let split_precompile argo pm = + let {me = next}, nexts = split_or argo pm.cases pm.args pm.default in + if + dbg + && (nexts <> [] + || + match next with + | PmOr _ -> true + | _ -> false) + then ( + prerr_endline "** SPLIT **"; + pretty_pm pm; + pretty_precompiled_res next nexts); + (next, nexts) + +(* General divide functions *) + +let add_line patl_action pm = + pm.cases <- patl_action :: pm.cases; + pm + +type cell = {pm: pattern_matching; ctx: ctx list; pat: pattern} + +let add make_matching_fun division eq_key key patl_action args = + try + let _, cell = List.find (fun (k, _) -> eq_key key k) division in + cell.pm.cases <- patl_action :: cell.pm.cases; + division + with Not_found -> + let cell = make_matching_fun args in + cell.pm.cases <- [patl_action]; + (key, cell) :: division + +let divide make eq_key get_key get_args ctx pm = + let rec divide_rec = function + | (p :: patl, action) :: rem -> + let this_match = divide_rec rem in + add (make p pm.default ctx) this_match eq_key (get_key p) + (get_args p patl, action) + pm.args + | _ -> [] + in + + divide_rec pm.cases + +let divide_line make_ctx make get_args pat ctx pm = + let rec divide_rec = function + | (p :: patl, action) :: rem -> + let this_match = divide_rec rem in + add_line (get_args p patl, action) this_match + | _ -> make pm.default pm.args + in + + {pm = divide_rec pm.cases; ctx = make_ctx ctx; pat} + +(* Then come various functions, + There is one set of functions per matching style + (constants, constructors etc.) + + - matcher functions are arguments to make_default (for default handlers) + They may raise NoMatch or OrPat and perform the full + matching (selection + arguments). + + + - get_args and get_key are for the compiled matrices, note that + selection and getting arguments are separated. + + - make_ _matching combines the previous functions for producing + new ``pattern_matching'' records. +*) + +let rec matcher_const cst p rem = + match p.pat_desc with + | Tpat_or (p1, p2, _) -> ( + try matcher_const cst p1 rem with NoMatch -> matcher_const cst p2 rem) + | Tpat_constant c1 when const_compare c1 cst = 0 -> rem + | Tpat_any -> rem + | _ -> raise NoMatch + +let get_key_constant caller = function + | {pat_desc = Tpat_constant cst} -> cst + | p -> + prerr_endline ("BAD: " ^ caller); + pretty_pat p; + assert false + +let get_args_constant _ rem = rem + +let make_constant_matching p def ctx = function + | [] -> fatal_error "Matching.make_constant_matching" + | _ :: argl -> + let def = make_default (matcher_const (get_key_constant "make" p)) def + and ctx = filter_ctx p ctx in + {pm = {cases = []; args = argl; default = def}; ctx; pat = normalize_pat p} + +let divide_constant ctx m = + divide make_constant_matching + (fun c d -> const_compare c d = 0) + (get_key_constant "divide") + get_args_constant ctx m + +(* Matching against a constructor *) + +let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = + let rec make_args pos = + if pos > last_pos then argl + else + (Lprim (Pfield (pos, fld_info), [arg], loc), binding_kind) + :: make_args (pos + 1) + in + make_args first_pos + +let get_key_constr = function + | {pat_desc = Tpat_construct (_, cstr, _)} -> cstr.cstr_tag + | _ -> assert false + +let get_args_constr p rem = + match p with + | {pat_desc = Tpat_construct (_, _, args)} -> args @ rem + | _ -> assert false + +(* NB: matcher_constr applies to default matrices. + + In that context, matching by constructors of extensible + types degrades to arity checking, due to potential rebinding. + This comparison is performed by Types.may_equal_constr. +*) + +let matcher_constr cstr = + match cstr.cstr_arity with + | 0 -> + let rec matcher_rec q rem = + match q.pat_desc with + | Tpat_or (p1, p2, _) -> ( + try matcher_rec p1 rem with NoMatch -> matcher_rec p2 rem) + | Tpat_construct (_, cstr', []) when Types.may_equal_constr cstr cstr' -> + rem + | Tpat_any -> rem + | _ -> raise NoMatch + in + matcher_rec + | 1 -> + let rec matcher_rec q rem = + match q.pat_desc with + | Tpat_or (p1, p2, _) -> ( + let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None + and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in + match (r1, r2) with + | None, None -> raise NoMatch + | Some r1, None -> r1 + | None, Some r2 -> r2 + | Some (a1 :: _), Some (a2 :: _) -> + {a1 with pat_loc = Location.none; pat_desc = Tpat_or (a1, a2, None)} + :: rem + | _, _ -> assert false) + | Tpat_construct (_, cstr', [arg]) when Types.may_equal_constr cstr cstr' + -> + arg :: rem + | Tpat_any -> omega :: rem + | _ -> raise NoMatch + in + matcher_rec + | _ -> ( + fun q rem -> + match q.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_construct (_, cstr', args) when Types.may_equal_constr cstr cstr' + -> + args @ rem + | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem + | _ -> raise NoMatch) + +let make_constr_matching p def ctx = function + | [] -> fatal_error "Matching.make_constr_matching" + | (arg, _mut) :: argl -> + let cstr = pat_as_constr p in + let untagged = Ast_untagged_variants.has_untagged cstr.cstr_attributes in + let newargs = + if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then + (arg, Alias) :: argl + else + match cstr.cstr_tag with + | Cstr_block _ when Datarepr.constructor_has_optional_shape cstr -> + let from_option = + match p.pat_desc with + | Tpat_construct (_, _, [{pat_type; pat_env}]) + when Typeopt.type_cannot_contain_undefined pat_type pat_env -> + Pval_from_option_not_nest + | _ -> Pval_from_option + in + (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl + | Cstr_constant _ | Cstr_block _ -> + make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl + ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) + | Cstr_unboxed -> (arg, Alias) :: argl + | Cstr_extension _ -> + make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl + ~fld_info:Fld_extension + in + { + pm = + { + cases = []; + args = newargs; + default = make_default (matcher_constr cstr) def; + }; + ctx = filter_ctx p ctx; + pat = normalize_pat p; + } + +let divide_constructor ctx pm = + divide make_constr_matching Types.equal_tag get_key_constr get_args_constr ctx + pm + +(* Matching against a variant *) + +let rec matcher_variant_const lab p rem = + match p.pat_desc with + | Tpat_or (p1, p2, _) -> ( + try matcher_variant_const lab p1 rem + with NoMatch -> matcher_variant_const lab p2 rem) + | Tpat_variant (lab1, _, _) when lab1 = lab -> rem + | Tpat_any -> rem + | _ -> raise NoMatch + +let make_variant_matching_constant p lab def ctx = function + | [] -> fatal_error "Matching.make_variant_matching_constant" + | _ :: argl -> + let def = make_default (matcher_variant_const lab) def + and ctx = filter_ctx p ctx in + {pm = {cases = []; args = argl; default = def}; ctx; pat = normalize_pat p} + +let matcher_variant_nonconst lab p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_variant (lab1, Some arg, _) when lab1 = lab -> arg :: rem + | Tpat_any -> omega :: rem + | _ -> raise NoMatch + +let make_variant_matching_nonconst p lab def ctx = function + | [] -> fatal_error "Matching.make_variant_matching_nonconst" + | (arg, _mut) :: argl -> + let def = make_default (matcher_variant_nonconst lab) def + and ctx = filter_ctx p ctx in + { + pm = + { + cases = []; + args = + (Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) + :: argl; + default = def; + }; + ctx; + pat = normalize_pat p; + } + +let divide_variant row ctx {cases = cl; args = al; default = def} = + let row = Btype.row_repr row in + let rec divide = function + | (({pat_desc = Tpat_variant (lab, pato, _)} as p) :: patl, action) :: rem + -> ( + let variants = divide rem in + if + try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent + with Not_found -> true + then variants + else + let tag = Btype.hash_variant lab in + let ( = ) ((a : string), (b : Types.constructor_tag)) (c, d) = + a = c && Types.equal_tag b d + in + match pato with + | None -> + add + (make_variant_matching_constant p lab def ctx) + variants ( = ) (lab, Cstr_constant tag) (patl, action) al + | Some pat -> + add + (make_variant_matching_nonconst p lab def ctx) + variants ( = ) (lab, Cstr_block tag) + (pat :: patl, action) + al) + | _ -> [] + in + divide cl + +(* + Three ``no-test'' cases + *) + +(* Matching against a variable *) + +let get_args_var _ rem = rem + +let make_var_matching def = function + | [] -> fatal_error "Matching.make_var_matching" + | _ :: argl -> + {cases = []; args = argl; default = make_default get_args_var def} + +let divide_var ctx pm = + divide_line ctx_lshift make_var_matching get_args_var omega ctx pm + +(* Matching against a tuple pattern *) + +let get_args_tuple arity p rem = + match p with + | {pat_desc = Tpat_any} -> omegas arity @ rem + | {pat_desc = Tpat_tuple args} -> args @ rem + | _ -> assert false + +let matcher_tuple arity p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_any | Tpat_var _ -> omegas arity @ rem + | Tpat_tuple args when List.length args = arity -> args @ rem + | _ -> raise NoMatch + +let make_tuple_matching loc arity def = function + | [] -> fatal_error "Matching.make_tuple_matching" + | (arg, _mut) :: argl -> + let rec make_args pos = + if pos >= arity then argl + else + (Lprim (Pfield (pos, Fld_tuple), [arg], loc), Alias) + :: make_args (pos + 1) + in + { + cases = []; + args = make_args 0; + default = make_default (matcher_tuple arity) def; + } + +let divide_tuple arity p ctx pm = + divide_line (filter_ctx p) + (make_tuple_matching p.pat_loc arity) + (get_args_tuple arity) p ctx pm + +(* Matching against a record pattern *) + +let record_matching_line num_fields lbl_pat_list = + let patv = Array.make num_fields omega in + List.iter (fun (_, lbl, pat, _) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; + Array.to_list patv + +let get_args_record num_fields p rem = + match p with + | {pat_desc = Tpat_any} -> record_matching_line num_fields [] @ rem + | {pat_desc = Tpat_record (lbl_pat_list, _)} -> + record_matching_line num_fields lbl_pat_list @ rem + | _ -> assert false + +let matcher_record num_fields p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_any | Tpat_var _ -> record_matching_line num_fields [] @ rem + | Tpat_record ([], _) when num_fields = 0 -> rem + | Tpat_record (((_, lbl, _, _) :: _ as lbl_pat_list), _) + when Array.length lbl.lbl_all = num_fields -> + record_matching_line num_fields lbl_pat_list @ rem + | _ -> raise NoMatch + +let make_record_matching loc all_labels def = function + | [] -> fatal_error "Matching.make_record_matching" + | (arg, _mut) :: argl -> + let rec make_args pos = + if pos >= Array.length all_labels then argl + else + let lbl = all_labels.(pos) in + let access = + match lbl.lbl_repres with + | Record_float_unused -> assert false + | Record_regular -> + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) + | Record_inlined _ -> + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) + | Record_unboxed _ -> arg + | Record_extension -> + Lprim + ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), + [arg], + loc ) + in + let str = + match lbl.lbl_mut with + | Immutable -> Alias + | Mutable -> StrictOpt + in + (access, str) :: make_args (pos + 1) + in + let nfields = Array.length all_labels in + let def = make_default (matcher_record nfields) def in + {cases = []; args = make_args 0; default = def} + +let divide_record all_labels p ctx pm = + let get_args = get_args_record (Array.length all_labels) in + divide_line (filter_ctx p) + (make_record_matching p.pat_loc all_labels) + get_args p ctx pm + +(* Matching against an array pattern *) + +let get_key_array = function + | {pat_desc = Tpat_array patl} -> List.length patl + | _ -> assert false + +let get_args_array p rem = + match p with + | {pat_desc = Tpat_array patl} -> patl @ rem + | _ -> assert false + +let matcher_array len p rem = + match p.pat_desc with + | Tpat_or (_, _, _) -> raise OrPat + | Tpat_array args when List.length args = len -> args @ rem + | Tpat_any -> Parmatch.omegas len @ rem + | _ -> raise NoMatch + +let make_array_matching p def ctx = function + | [] -> fatal_error "Matching.make_array_matching" + | (arg, _mut) :: argl -> + let len = get_key_array p in + let rec make_args pos = + if pos >= len then argl + else + ( Lprim + (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc), + StrictOpt ) + :: make_args (pos + 1) + in + let def = make_default (matcher_array len) def and ctx = filter_ctx p ctx in + { + pm = {cases = []; args = make_args 0; default = def}; + ctx; + pat = normalize_pat p; + } + +let divide_array ctx pm = + divide make_array_matching ( = ) get_key_array get_args_array ctx pm + +(* + Specific string test sequence + Will be called by the bytecode compiler, from bytegen.ml. + The strategy is first dichotomic search (we perform 3-way tests + with compare_string), then sequence of equality tests + when there are less then T=strings_test_threshold static strings to match. + + Increasing T entails (slightly) less code, decreasing T + (slightly) favors runtime speed. + T=8 looks a decent tradeoff. +*) + +(* Utilities *) + +let strings_test_threshold = 8 + +let bind_sw arg k = + match arg with + | Lvar _ -> k arg + | _ -> + let id = Ident.create "switch" in + Llet (Strict, Pgenval, id, arg, k (Lvar id)) + +(* Sequential equality tests *) + +let make_string_test_sequence loc arg sw d = + let d, sw = + match d with + | None -> ( + match sw with + | (_, d) :: sw -> (d, sw) + | [] -> assert false) + | Some d -> (d, sw) + in + bind_sw arg (fun arg -> + List.fold_right + (fun (s, lam) k -> + Lifthenelse + ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc), + k, + lam )) + sw d) + +let rec split k xs = + match xs with + | [] -> assert false + | x0 :: xs -> + if k <= 1 then ([], x0, xs) + else + let xs, y0, ys = split (k - 2) xs in + (x0 :: xs, y0, ys) + +let zero_lam = Lconst (Const_base (Const_int 0)) + +let tree_way_test loc arg lt eq gt = + Lifthenelse + ( Lprim (Pintcomp Clt, [arg; zero_lam], loc), + lt, + Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc), gt, eq) ) + +(* Dichotomic tree *) + +let rec do_make_string_test_tree loc arg sw delta d = + let len = List.length sw in + if len <= strings_test_threshold + delta then + make_string_test_sequence loc arg sw d + else + let lt, (s, act), gt = split len sw in + bind_sw + (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc)) + (fun r -> + tree_way_test loc r + (do_make_string_test_tree loc arg lt delta d) + act + (do_make_string_test_tree loc arg gt delta d)) + +(* Entry point *) +let expand_stringswitch loc arg sw d = + match d with + | None -> bind_sw arg (fun arg -> do_make_string_test_tree loc arg sw 0 None) + | Some e -> + bind_sw arg (fun arg -> + make_catch e (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) + +(**********************) +(* Generic test trees *) +(**********************) + +(* Sharing *) + +(* Add handler, if shared *) +let handle_shared () = + let hs = ref (fun x -> x) in + let handle_shared act = + match act with + | Switch.Single act -> act + | Switch.Shared act -> + let i, h = make_catch_delayed act in + let ohs = !hs in + (hs := fun act -> h (ohs act)); + make_exit i + in + (hs, handle_shared) + +let share_actions_tree sw d = + let store = StoreExp.mk_store () in + (* Default action is always shared *) + let d = + match d with + | None -> None + | Some d -> Some (store.Switch.act_store_shared d) + in + (* Store all other actions *) + let sw = List.map (fun (cst, act) -> (cst, store.Switch.act_store act)) sw in + + (* Retrieve all actions, including potential default *) + let acts = store.Switch.act_get_shared () in + + (* Array of actual actions *) + let hs, handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + + (* Reconstruct default and switch list *) + let d = + match d with + | None -> None + | Some d -> Some acts.(d) + in + let sw = List.map (fun (cst, j) -> (cst, acts.(j))) sw in + (!hs, sw, d) + +(* Note: dichotomic search requires sorted input with no duplicates *) +let rec uniq_lambda_list sw = + match sw with + | [] | [_] -> sw + | ((c1, _) as p1) :: ((c2, _) :: sw2 as sw1) -> + if const_compare c1 c2 = 0 then uniq_lambda_list (p1 :: sw2) + else p1 :: uniq_lambda_list sw1 + +let sort_lambda_list l = + let l = List.stable_sort (fun (x, _) (y, _) -> const_compare x y) l in + uniq_lambda_list l + +let rec cut n l = + if n = 0 then ([], l) + else + match l with + | [] -> raise (Invalid_argument "cut") + | a :: l -> + let l1, l2 = cut (n - 1) l in + (a :: l1, l2) + +let rec do_tests_fail loc fail tst arg = function + | [] -> fail + | (c, act) :: rem -> + Lifthenelse + ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + do_tests_fail loc fail tst arg rem, + act ) + +let rec do_tests_nofail loc tst arg = function + | [] -> fatal_error "Matching.do_tests_nofail" + | [(_, act)] -> act + | (c, act) :: rem -> + Lifthenelse + ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + do_tests_nofail loc tst arg rem, + act ) + +let make_test_sequence loc fail tst lt_tst arg const_lambda_list = + let const_lambda_list = sort_lambda_list const_lambda_list in + let hs, const_lambda_list, fail = share_actions_tree const_lambda_list fail in + + let rec make_test_sequence const_lambda_list = + if List.length const_lambda_list >= 4 && lt_tst <> Pignore then + split_sequence const_lambda_list + else + match fail with + | None -> do_tests_nofail loc tst arg const_lambda_list + | Some fail -> do_tests_fail loc fail tst arg const_lambda_list + and split_sequence const_lambda_list = + let list1, list2 = + cut (List.length const_lambda_list / 2) const_lambda_list + in + Lifthenelse + ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc), + make_test_sequence list1, + make_test_sequence list2 ) + in + hs (make_test_sequence const_lambda_list) + +module SArg = struct + type primitive = Lambda.primitive + + let eqint = Pintcomp Ceq + let neint = Pintcomp Cneq + let leint = Pintcomp Cle + let ltint = Pintcomp Clt + let geint = Pintcomp Cge + let gtint = Pintcomp Cgt + + type act = Lambda.lambda + + let make_prim p args = Lprim (p, args, Location.none) + let make_offset arg n = + match n with + | 0 -> arg + | _ -> Lprim (Poffsetint n, [arg], Location.none) + + let bind arg body = + let newvar, newarg = + match arg with + | Lvar v -> (v, arg) + | _ -> + let newvar = Ident.create "switcher" in + (newvar, Lvar newvar) + in + bind Alias newvar arg (body newarg) + let make_const i = Lconst (Const_base (Const_int i)) + let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) + let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) + let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) + let make_switch loc arg cases acts ~offset sw_names = + let l = ref [] in + for i = Array.length cases - 1 downto 0 do + l := (offset + i, acts.(cases.(i))) :: !l + done; + Lswitch + ( arg, + { + sw_numconsts = Array.length cases; + sw_consts = !l; + sw_numblocks = 0; + sw_blocks = []; + sw_failaction = None; + sw_names; + }, + loc ) + let make_catch = make_catch_delayed + let make_exit = make_exit +end + +(* Action sharing for Lswitch argument *) +let share_actions_sw sw = + (* Attempt sharing on all actions *) + let store = StoreExp.mk_store () in + let fail = + match sw.sw_failaction with + | None -> None + | Some fail -> + (* Fail is translated to exit, whatever happens *) + Some (store.Switch.act_store_shared fail) + in + let consts = + List.map (fun (i, e) -> (i, store.Switch.act_store e)) sw.sw_consts + and blocks = + List.map (fun (i, e) -> (i, store.Switch.act_store e)) sw.sw_blocks + in + let acts = store.Switch.act_get_shared () in + let hs, handle_shared = handle_shared () in + let acts = Array.map handle_shared acts in + let fail = + match fail with + | None -> None + | Some fail -> Some acts.(fail) + in + ( !hs, + { + sw with + sw_consts = List.map (fun (i, j) -> (i, acts.(j))) consts; + sw_blocks = List.map (fun (i, j) -> (i, acts.(j))) blocks; + sw_failaction = fail; + } ) + +(* Reintroduce fail action in switch argument, + for the sake of avoiding carrying over huge switches *) + +let reintroduce_fail sw = + match sw.sw_failaction with + | None -> + let t = Hashtbl.create 17 in + let seen (_, l) = + match as_simple_exit l with + | Some i -> + let old = try Hashtbl.find t i with Not_found -> 0 in + Hashtbl.replace t i (old + 1) + | None -> () + in + List.iter seen sw.sw_consts; + List.iter seen sw.sw_blocks; + let i_max = ref (-1) and max = ref (-1) in + Hashtbl.iter + (fun i c -> + if + c > !max || (c = !max && i > !i_max) + (* tie-break for determinism: choose the largest index *) + then ( + i_max := i; + max := c)) + t; + if !max >= 3 then + let default = !i_max in + let remove ls = + Ext_list.filter ls (fun (_, lam) -> + match as_simple_exit lam with + | Some j -> j <> default + | None -> true) + in + { + sw with + sw_consts = remove sw.sw_consts; + sw_blocks = remove sw.sw_blocks; + sw_failaction = Some (make_exit default); + } + else sw + | Some _ -> sw + +module Switcher = Switch.Make (SArg) +open Switch + +let rec last def = function + | [] -> def + | [(x, _)] -> x + | _ :: rem -> last def rem + +let get_edges low high l = + match l with + | [] -> (low, high) + | (x, _) :: _ -> (x, last high l) + +let as_interval_canfail fail low high l = + let store = StoreExp.mk_store () in + + let do_store _tag act = + let i = store.act_store act in + (* + eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; +*) + i + in + + let rec nofail_rec cur_low cur_high cur_act = function + | [] -> + if cur_high = high then [(cur_low, cur_high, cur_act)] + else [(cur_low, cur_high, cur_act); (cur_high + 1, high, 0)] + | (i, act_i) :: rem as all -> + let act_index = do_store "NO" act_i in + if cur_high + 1 = i then + if act_index = cur_act then nofail_rec cur_low i cur_act rem + else if act_index = 0 then (cur_low, i - 1, cur_act) :: fail_rec i i rem + else (cur_low, i - 1, cur_act) :: nofail_rec i i act_index rem + else if act_index = 0 then + (cur_low, cur_high, cur_act) + :: fail_rec (cur_high + 1) (cur_high + 1) all + else + (cur_low, cur_high, cur_act) + :: (cur_high + 1, i - 1, 0) + :: nofail_rec i i act_index rem + and fail_rec cur_low cur_high = function + | [] -> [(cur_low, cur_high, 0)] + | (i, act_i) :: rem -> + let index = do_store "YES" act_i in + if index = 0 then fail_rec cur_low i rem + else (cur_low, i - 1, 0) :: nofail_rec i i index rem + in + + let init_rec = function + | [] -> [(low, high, 0)] + | (i, act_i) :: rem -> + let index = do_store "INIT" act_i in + if index = 0 then fail_rec low i rem + else if low < i then (low, i - 1, 0) :: nofail_rec i i index rem + else nofail_rec i i index rem + in + + assert (do_store "FAIL" fail = 0); + (* fail has action index 0 *) + let r = init_rec l in + (Array.of_list r, store) + +let as_interval_nofail l = + let store = StoreExp.mk_store () in + let rec some_hole = function + | [] | [_] -> false + | (i, _) :: ((j, _) :: _ as rem) -> j > i + 1 || some_hole rem + in + let rec i_rec cur_low cur_high cur_act = function + | [] -> [(cur_low, cur_high, cur_act)] + | (i, act) :: rem -> + let act_index = store.act_store act in + if act_index = cur_act then i_rec cur_low i cur_act rem + else (cur_low, cur_high, cur_act) :: i_rec i i act_index rem + in + let inters = + match l with + | (i, act) :: rem -> + let act_index = + (* In case there is some hole and that a switch is emitted, + action 0 will be used as the action of unreachable + cases (cf. switch.ml, make_switch). + Hence, this action will be shared *) + if some_hole rem then store.act_store_shared act + else store.act_store act + in + assert (act_index = 0); + i_rec i i act_index rem + | _ -> assert false + in + + (Array.of_list inters, store) + +let sort_int_lambda_list l = + List.sort + (fun (i1, _) (i2, _) -> if i1 < i2 then -1 else if i2 < i1 then 1 else 0) + l + +let as_interval fail low high l = + let l = sort_int_lambda_list l in + ( get_edges low high l, + match fail with + | None -> as_interval_nofail l + | Some act -> as_interval_canfail act low high l ) + +let call_switcher loc fail arg low high int_lambda_list sw_names = + let edges, (cases, actions) = as_interval fail low high int_lambda_list in + Switcher.zyva loc edges arg cases actions sw_names + +let rec list_as_pat = function + | [] -> fatal_error "Matching.list_as_pat" + | [pat] -> pat + | pat :: rem -> {pat with pat_desc = Tpat_or (pat, list_as_pat rem, None)} + +let complete_pats_constrs = function + | p :: _ as pats -> + List.map (pat_of_constr p) + (complete_constrs p (List.map get_key_constr pats)) + | _ -> assert false + +(* + Following two ``failaction'' function compute n, the trap handler + to jump to in case of failure of elementary tests +*) + +let mk_failaction_neg partial ctx def = + match partial with + | Partial -> ( + match def with + | (_, idef) :: _ -> + (Some (Lstaticraise (idef, [])), jumps_singleton idef ctx) + | [] -> + (* Act as Total, this means + If no appropriate default matrix exists, + then this switch cannot fail *) + (None, jumps_empty)) + | Total -> (None, jumps_empty) + +(* In line with the article and simpler than before *) +let mk_failaction_pos partial seen ctx defs = + if dbg then ( + prerr_endline "**POS**"; + pretty_def defs; + ()); + let rec scan_def env to_test defs = + match (to_test, defs) with + | [], _ | _, [] -> + List.fold_left + (fun (klist, jumps) (pats, i) -> + let action = Lstaticraise (i, []) in + let klist = + List.fold_right + (fun pat r -> (get_key_constr pat, action) :: r) + pats klist + and jumps = jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in + (klist, jumps)) + ([], jumps_empty) env + | _, (pss, idef) :: rem -> ( + let now, later = + List.partition (fun (_p, p_ctx) -> ctx_match p_ctx pss) to_test + in + match now with + | [] -> scan_def env to_test rem + | _ -> scan_def ((List.map fst now, idef) :: env) later rem) + in + + let fail_pats = complete_pats_constrs seen in + if List.length fail_pats < 32 then ( + let fail, jmps = + scan_def [] (List.map (fun pat -> (pat, ctx_lub pat ctx)) fail_pats) defs + in + if dbg then ( + eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); + pretty_jumps jmps); + (None, fail, jmps)) + else ( + (* Too many non-matched constructors -> reduced information *) + if dbg then eprintf "POS->NEG!!!\n%!"; + let fail, jumps = mk_failaction_neg partial ctx defs in + if dbg then + eprintf "FAIL: %s\n" + (match fail with + | None -> "" + | Some lam -> string_of_lam lam); + (fail, [], jumps)) + +let combine_constant names loc arg cst partial ctx def + (const_lambda_list, total, _pats) = + let fail, local_jumps = mk_failaction_neg partial ctx def in + let lambda1 = + match cst with + | Const_int _ -> + let int_lambda_list = + List.map + (function + | Const_int n, l -> (n, l) + | _ -> assert false) + const_lambda_list + in + call_switcher loc fail arg min_int max_int int_lambda_list names + | Const_char _ -> + let int_lambda_list = + List.map + (function + | Const_char c, l -> (c, l) + | _ -> assert false) + const_lambda_list + in + call_switcher loc fail arg 0 max_int int_lambda_list names + | Const_string _ -> + (* Note as the bytecode compiler may resort to dichotomic search, + the clauses of stringswitch are sorted with duplicates removed. + This partly applies to the native code compiler, which requires + no duplicates *) + let const_lambda_list = sort_lambda_list const_lambda_list in + let sw = + List.map + (fun (c, act) -> + match c with + | Const_string (s, _) -> (s, act) + | _ -> assert false) + const_lambda_list + in + let hs, sw, fail = share_actions_tree sw fail in + hs (Lstringswitch (arg, sw, fail, loc)) + | Const_float _ -> + make_test_sequence loc fail (Pfloatcomp Cneq) (Pfloatcomp Clt) arg + const_lambda_list + | Const_int32 _ -> assert false + | Const_int64 _ -> assert false + | Const_bigint _ -> + make_test_sequence loc fail (Pbigintcomp Cneq) (Pbigintcomp Clt) arg + const_lambda_list + in + (lambda1, jumps_union local_jumps total) + +let split_cases tag_lambda_list = + let rec split_rec = function + | [] -> ([], []) + | (cstr, act) :: rem -> ( + let consts, nonconsts = split_rec rem in + match cstr with + | Cstr_constant n -> ((n, act) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, act) :: nonconsts) + | Cstr_unboxed -> (consts, (0, act) :: nonconsts) + | Cstr_extension _ -> assert false) + in + let const, nonconst = split_rec tag_lambda_list in + (sort_int_lambda_list const, sort_int_lambda_list nonconst) + +(* refine [split_cases] and [split_variant_cases] *) +let split_variant_cases tag_lambda_list = + let rec split_rec = function + | [] -> ([], []) + | ((name, cstr), act) :: rem -> ( + let consts, nonconsts = split_rec rem in + match cstr with + | Cstr_constant n -> ((n, (name, act)) :: consts, nonconsts) + | Cstr_block n -> (consts, (n, (name, act)) :: nonconsts) + | Cstr_unboxed -> assert false + | Cstr_extension _ -> assert false) + in + let const, nonconst = split_rec tag_lambda_list in + (sort_int_lambda_list const, sort_int_lambda_list nonconst) + +let get_extension_cases tag_lambda_list = + let rec split_rec = function + | [] -> [] + | (cstr, act) :: rem -> ( + let nonconsts = split_rec rem in + match cstr with + | Cstr_extension path -> (path, act) :: nonconsts + | _ -> assert false) + in + split_rec tag_lambda_list + +let combine_constructor sw_names loc arg ex_pat cstr partial ctx def + (tag_lambda_list, total1, pats) = + if cstr.cstr_consts < 0 then + (* Special cases for extensions *) + let fail, local_jumps = mk_failaction_neg partial ctx def in + let lambda1 = + let extension_cases = get_extension_cases tag_lambda_list in + let default, extension_cases = + match fail with + | None -> ( + match extension_cases with + | (_, act) :: rem -> (act, rem) + | _ -> assert false) + | Some fail -> (fail, extension_cases) + in + match extension_cases with + | [] -> default + | _ -> + let tag = Ident.create "tag" in + let tests = + List.fold_right + (fun (path, act) rem -> + let ext = transl_extension_path ex_pat.pat_env path in + Lifthenelse + (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc), act, rem)) + extension_cases default + in + Llet (Alias, Pgenval, tag, arg, tests) + in + (lambda1, jumps_union local_jumps total1) + else + (* Regular concrete type *) + let ncases = List.length tag_lambda_list + and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in + let sig_complete = ncases = nconstrs in + let fail_opt, fails, local_jumps = + if sig_complete then (None, [], jumps_empty) + else mk_failaction_pos partial pats ctx def + in + + let tag_lambda_list = fails @ tag_lambda_list in + let consts, nonconsts = split_cases tag_lambda_list in + let lambda1 = + match (fail_opt, same_actions tag_lambda_list) with + | None, Some act -> act (* Identical actions, no failure *) + | _ -> ( + match (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) with + | 1, 1, [(0, act1)], [(0, act2)] + when cstr.cstr_name = "::" || cstr.cstr_name = "[]" + || Datarepr.constructor_has_optional_shape cstr -> + (* Typically, match on lists, will avoid isint primitive in that + case *) + let arg = + if Datarepr.constructor_has_optional_shape cstr then + Lprim (Pis_not_none, [arg], loc) + else + Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) + in + Lifthenelse (arg, act2, act1) + | 2, 0, [(i1, act1); (_, act2)], [] + when cstr.cstr_name = "true" || cstr.cstr_name = "false" -> + if i1 = 0 then Lifthenelse (arg, act2, act1) + else Lifthenelse (arg, act1, act2) + | n, 0, _, [] when false (* relies on tag being an int *) -> + (* The type defines constant constructors only *) + call_switcher loc fail_opt arg 0 (n - 1) consts sw_names + | n, _, _, _ -> ( + let act0 = + (* = Some act when all non-const constructors match to act *) + match (fail_opt, nonconsts) with + | Some a, [] -> Some a + | Some _, _ -> + if List.length nonconsts = cstr.cstr_nonconsts then + same_actions nonconsts + else None + | None, _ -> same_actions nonconsts + in + match act0 with + | Some act when false (* relies on tag being an int *) -> + Lifthenelse + ( Lprim (Pisint, [arg], loc), + call_switcher loc fail_opt arg 0 (n - 1) consts sw_names, + act ) + (* Emit a switch, as bytecode implements this sophisticated instruction *) + | _ -> + let sw = + { + sw_numconsts = cstr.cstr_consts; + sw_consts = consts; + sw_numblocks = cstr.cstr_nonconsts; + sw_blocks = nonconsts; + sw_failaction = fail_opt; + sw_names; + } + in + let hs, sw = share_actions_sw sw in + let sw = reintroduce_fail sw in + hs (Lswitch (arg, sw, loc)))) + in + (lambda1, jumps_union local_jumps total1) + +let make_test_sequence_variant_constant fail arg int_lambda_list = + let _, (cases, actions) = + as_interval fail min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) + in + Switcher.test_sequence arg cases actions + +let call_switcher_variant_constant loc fail arg int_lambda_list names = + call_switcher loc fail arg min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) + names + +let call_switcher_variant_constr loc fail arg int_lambda_list names = + let v = Ident.create "variant" in + Llet + ( Alias, + Pgenval, + v, + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + call_switcher loc fail (Lvar v) min_int max_int + (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) + names ) + +let call_switcher_variant_constant : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref = + ref call_switcher_variant_constant + +let call_switcher_variant_constr : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref = + ref call_switcher_variant_constr + +let make_test_sequence_variant_constant : + (Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.lambda) + ref = + ref make_test_sequence_variant_constant + +let combine_variant names loc row arg partial ctx def + (tag_lambda_list, total1, _pats) = + let row = Btype.row_repr row in + let num_constr = ref 0 in + if row.row_closed then + List.iter + (fun (_, f) -> + match Btype.row_field_repr f with + | Rabsent | Reither (true, _ :: _, _, _) -> () + | _ -> incr num_constr) + row.row_fields + else num_constr := max_int; + let test_int_or_block arg if_int if_block = + Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) + in + let sig_complete = List.length tag_lambda_list = !num_constr + and one_action = same_actions tag_lambda_list in + (* reduandant work under bs context *) + let fail, local_jumps = + if + sig_complete + || + match partial with + | Total -> true + | _ -> false + then (None, jumps_empty) + else mk_failaction_neg partial ctx def + in + let consts, nonconsts = split_variant_cases tag_lambda_list in + let lambda1 = + match (fail, one_action) with + | None, Some act -> act + | _, _ -> ( + match (consts, nonconsts) with + | [(_, (_, act1))], [(_, (_, act2))] when fail = None -> + test_int_or_block arg act1 act2 + | _, [] -> + (* One can compare integers and pointers *) + !make_test_sequence_variant_constant fail arg consts + | [], _ -> ( + let lam = !call_switcher_variant_constr loc fail arg nonconsts names in + (* One must not dereference integers *) + match fail with + | None -> lam + | Some fail -> test_int_or_block arg fail lam) + | _, _ -> + let lam_const = + !call_switcher_variant_constant loc fail arg consts names + and lam_nonconst = + !call_switcher_variant_constr loc fail arg nonconsts names + in + test_int_or_block arg lam_const lam_nonconst) + in + (lambda1, jumps_union local_jumps total1) + +let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats) + = + let fail, local_jumps = mk_failaction_neg partial ctx def in + let lambda1 = + let newvar = Ident.create "len" in + let switch = + call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list names + in + bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch + in + (lambda1, jumps_union local_jumps total1) + +(* Insertion of debugging events *) + +(* let[@inline] event_branch _repr lam = lam *) + +(* + This exception is raised when the compiler cannot produce code + because control cannot reach the compiled clause, + + Unused is raised initially in compile_test. + + compile_list (for compiling switch results) catch Unused + + comp_match_handlers (for compiling splitted matches) + may reraise Unused + + +*) + +exception Unused + +let compile_list compile_fun division = + let rec c_rec totals = function + | [] -> ([], jumps_unions totals, []) + | (key, cell) :: rem -> ( + match cell.ctx with + | [] -> c_rec totals rem + | _ -> ( + try + let lambda1, total1 = compile_fun cell.ctx cell.pm in + let c_rem, total, new_pats = + c_rec (jumps_map ctx_combine total1 :: totals) rem + in + ((key, lambda1) :: c_rem, total, cell.pat :: new_pats) + with Unused -> c_rec totals rem)) + in + c_rec [] division + +let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = + let rec do_rec r total_r = function + | [] -> (r, total_r) + | (mat, i, vars, pm) :: rem -> ( + try + let ctx = select_columns mat ctx in + let handler_i, total_i = compile_fun ctx pm in + match raw_action r with + | Lstaticraise (j, args) -> + if i = j then + ( List.fold_right2 (bind Alias) vars args handler_i, + jumps_map (ctx_rshift_num (ncols mat)) total_i ) + else do_rec r total_r rem + | _ -> + do_rec + (Lstaticcatch (r, (i, vars), handler_i)) + (jumps_union (jumps_remove i total_r) + (jumps_map (ctx_rshift_num (ncols mat)) total_i)) + rem + with Unused -> + do_rec (Lstaticcatch (r, (i, vars), lambda_unit)) total_r rem) + in + do_rec lambda1 total1 to_catch + +let compile_test compile_fun partial divide combine ctx to_match = + let division = divide ctx to_match in + let c_div = compile_list compile_fun division in + match c_div with + | [], _, _ -> ( + match mk_failaction_neg partial ctx to_match.default with + | None, _ -> raise Unused + | Some l, total -> (l, total)) + | _ -> combine ctx to_match.default c_div + +(* Attempt to avoid some useless bindings by lowering them *) + +(* Approximation of v present in lam *) +let rec approx_present v = function + | Lconst _ -> false + | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args + | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args + | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 + | Lvar vv -> Ident.same v vv + | _ -> true + +let rec lower_bind v arg lam = + match lam with + | Lifthenelse (cond, ifso, ifnot) -> ( + let pcond = approx_present v cond + and pso = approx_present v ifso + and pnot = approx_present v ifnot in + match (pcond, pso, pnot) with + | false, false, false -> lam + | false, true, false -> Lifthenelse (cond, lower_bind v arg ifso, ifnot) + | false, false, true -> Lifthenelse (cond, ifso, lower_bind v arg ifnot) + | _, _, _ -> bind Alias v arg lam) + | Lswitch (ls, ({sw_consts = [(i, act)]; sw_blocks = []} as sw), loc) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_consts = [(i, lower_bind v arg act)]}, loc) + | Lswitch (ls, ({sw_consts = []; sw_blocks = [(i, act)]} as sw), loc) + when not (approx_present v ls) -> + Lswitch (ls, {sw with sw_blocks = [(i, lower_bind v arg act)]}, loc) + | Llet (Alias, k, vv, lv, l) -> + if approx_present v lv then bind Alias v arg lam + else Llet (Alias, k, vv, lv, lower_bind v arg l) + | Lvar u when Ident.same u v && Ident.name u = "*sth*" -> + arg (* eliminate let *sth* = from_option x in *sth* *) + | _ -> bind Alias v arg lam + +let bind_check str v arg lam = + match (str, arg) with + | _, Lvar _ -> bind str v arg lam + | Alias, _ -> lower_bind v arg lam + | _, _ -> bind str v arg lam + +let comp_exit ctx m = + match m.default with + | (_, i) :: _ -> (Lstaticraise (i, []), jumps_singleton i ctx) + | _ -> fatal_error "Matching.comp_exit" + +let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = + match next_matchs with + | [] -> comp_fun partial ctx arg first_match + | rem -> ( + let rec c_rec body total_body = function + | [] -> (body, total_body) + (* Hum, -1 means never taken + | (-1,pm)::rem -> c_rec body total_body rem *) + | (i, pm) :: rem -> ( + let ctx_i, total_rem = jumps_extract i total_body in + match ctx_i with + | [] -> c_rec body total_body rem + | _ -> ( + try + let li, total_i = + comp_fun + (match rem with + | [] -> partial + | _ -> Partial) + ctx_i arg pm + in + c_rec + (Lstaticcatch (body, (i, []), li)) + (jumps_union total_i total_rem) + rem + with Unused -> + c_rec (Lstaticcatch (body, (i, []), lambda_unit)) total_rem rem)) + in + try + let first_lam, total = comp_fun Partial ctx arg first_match in + c_rec first_lam total rem + with Unused -> ( + match next_matchs with + | [] -> raise Unused + | (_, x) :: xs -> comp_match_handlers comp_fun partial ctx arg x xs)) + +(* To find reasonable names for variables *) + +let rec name_pattern default = function + | (pat :: _, _) :: rem -> ( + match Typecore.id_of_pattern pat with + | Some id -> id + | None -> name_pattern default rem) + | _ -> Ident.create default + +let arg_to_var arg cls = + match arg with + | Lvar v -> (v, arg) + | _ -> + let v = name_pattern "match" cls in + (v, Lvar v) + +(* To be set by Lam_compile *) +let names_from_construct_pattern : + (pattern -> Ast_untagged_variants.switch_names option) ref = + ref (fun _ -> None) + +(* + The main compilation function. + Input: + repr=used for inserting debug events + partial=exhaustiveness information from Parmatch + ctx=a context + m=a pattern matching + + Output: a lambda term, a jump summary {..., exit number -> context, .. } +*) + +let rec compile_match repr partial ctx m = + match m with + | {cases = []; args = []} -> comp_exit ctx m + | {cases = ([], action) :: rem} -> + if is_guarded action then + let lambda, total = compile_match None partial ctx {m with cases = rem} in + (patch_guarded lambda action, total) + else (action, jumps_empty) + | {args = (arg, str) :: argl} -> + let v, newarg = arg_to_var arg m.cases in + let first_match, rem = + split_precompile (Some v) {m with args = (newarg, Alias) :: argl} + in + let lam, total = + comp_match_handlers + ((if dbg then do_compile_matching_pr else do_compile_matching) repr) + partial ctx newarg first_match rem + in + (bind_check str v arg lam, total) + | _ -> assert false + +(* verbose version of do_compile_matching, for debug *) + +and do_compile_matching_pr repr partial ctx arg x = + prerr_string "COMPILE: "; + prerr_endline + (match partial with + | Partial -> "Partial" + | Total -> "Total"); + prerr_endline "MATCH"; + pretty_precompiled x; + prerr_endline "CTX"; + pretty_ctx ctx; + let ((_, jumps) as r) = do_compile_matching repr partial ctx arg x in + prerr_endline "JUMPS"; + pretty_jumps jumps; + r + +and do_compile_matching repr partial ctx arg pmh = + match pmh with + | Pm pm -> ( + let pat = what_is_cases pm.cases in + match pat.pat_desc with + | Tpat_any -> compile_no_test divide_var ctx_rshift repr partial ctx pm + | Tpat_tuple patl -> + compile_no_test + (divide_tuple (List.length patl) (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_record ((_, lbl, _, _) :: _, _) -> + compile_no_test + (divide_record lbl.lbl_all (normalize_pat pat)) + ctx_combine repr partial ctx pm + | Tpat_constant cst -> + let names = None in + compile_test + (compile_match repr partial) + partial divide_constant + (combine_constant names pat.pat_loc arg cst partial) + ctx pm + | Tpat_construct (_, cstr, _) -> + let sw_names = !names_from_construct_pattern pat in + compile_test + (compile_match repr partial) + partial divide_constructor + (combine_constructor sw_names pat.pat_loc arg pat cstr partial) + ctx pm + | Tpat_array _ -> + let names = None in + compile_test + (compile_match repr partial) + partial divide_array + (combine_array names pat.pat_loc arg partial) + ctx pm + | Tpat_variant (_, _, row) -> + let names = None in + compile_test + (compile_match repr partial) + partial (divide_variant !row) + (combine_variant names pat.pat_loc !row arg partial) + ctx pm + | _ -> assert false) + | PmVar {inside = pmh; var_arg = arg} -> + let lam, total = + do_compile_matching repr partial (ctx_lshift ctx) arg pmh + in + (lam, jumps_map ctx_rshift total) + | PmOr {body; handlers} -> + let lam, total = compile_match repr partial ctx body in + compile_orhandlers (compile_match repr partial) lam total ctx handlers + +and compile_no_test divide up_ctx repr partial ctx to_match = + let {pm = this_match; ctx = this_ctx} = divide ctx to_match in + let lambda, total = compile_match repr partial this_ctx this_match in + (lambda, jumps_map up_ctx total) + +(* The entry points *) + +(* + If there is a guard in a matching or a lazy pattern, + then set exhaustiveness info to Partial. + (because of side effects, assume the worst). + + Notice that exhaustiveness information is trusted by the compiler, + that is, a match flagged as Total should not fail at runtime. + More specifically, for instance if match y with x::_ -> x is flagged + total (as it happens during JoCaml compilation) then y cannot be [] + at runtime. As a consequence, the static Total exhaustiveness information + have to be downgraded to Partial, in the dubious cases where guards + or lazy pattern execute arbitrary code that may perform side effects + and change the subject values. +LM: + Lazy pattern was PR#5992, initial patch by lpw25. + I have generalized the patch, so as to also find mutable fields. +*) + +let find_in_pat pred = + let rec find_rec p = + pred p.pat_desc + || + match p.pat_desc with + | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> find_rec p + | Tpat_tuple ps | Tpat_construct (_, _, ps) | Tpat_array ps -> + List.exists find_rec ps + | Tpat_record (lpats, _) -> + List.exists (fun (_, _, p, _) -> find_rec p) lpats + | Tpat_or (p, q, _) -> find_rec p || find_rec q + | Tpat_constant _ | Tpat_var _ | Tpat_any | Tpat_variant (_, None, _) -> + false + in + find_rec + +let have_mutable_field p = + match p with + | Tpat_record (lps, _) -> + List.exists + (fun (_, lbl, _, _) -> + match lbl.Types.lbl_mut with + | Mutable -> true + | Immutable -> false) + lps + | Tpat_alias _ | Tpat_variant _ | Tpat_tuple _ | Tpat_construct _ + | Tpat_array _ | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any -> + false + +let is_mutable p = find_in_pat have_mutable_field p + +(* Downgrade Total when + 1. Matching accesses some mutable fields; + 2. And there are guards or lazy patterns. +*) + +let check_partial is_mutable pat_act_list = function + | Partial -> Partial + | Total -> + if + pat_act_list = [] + || + (* allow empty case list *) + List.exists + (fun (pats, lam) -> is_mutable pats && is_guarded lam) + pat_act_list + then Partial + else Total + +let check_partial_list = check_partial (List.exists is_mutable) +let check_partial = check_partial is_mutable + +(* have toplevel handler when appropriate *) + +let start_ctx n = [{left = []; right = omegas n}] + +let check_total total lambda i handler_fun = + if jumps_is_empty total then lambda + else Lstaticcatch (lambda, (i, []), handler_fun ()) + +let compile_matching repr handler_fun arg pat_act_list partial = + let partial = check_partial pat_act_list partial in + match partial with + | Partial -> ( + let raise_num = next_raise_count () in + let pm = + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(arg, Strict)]; + default = [([[omega]], raise_num)]; + } + in + try + let lambda, total = compile_match repr partial (start_ctx 1) pm in + check_total total lambda raise_num handler_fun + with Unused -> assert false (* ; handler_fun() *)) + | Total -> + let pm = + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(arg, Strict)]; + default = []; + } + in + let lambda, total = compile_match repr partial (start_ctx 1) pm in + assert (jumps_is_empty total); + lambda + +let partial_function loc () = + (* [Location.get_pos_info] is too expensive *) + let fname, line, char = Location.get_pos_info loc.Location.loc_start in + let fname = Filename.basename fname in + Lprim + ( Praise Raise_regular, + [ + Lprim + ( Pmakeblock Blk_extension, + [ + transl_normal_path Predef.path_match_failure; + Lconst + (Const_block + ( Blk_tuple, + [ + Const_base (Const_string (fname, None)); + Const_base (Const_int line); + Const_base (Const_int char); + ] )); + ], + loc ); + ], + loc ) + +let for_function loc repr param pat_act_list partial = + compile_matching repr (partial_function loc) param pat_act_list partial + +(* In the following two cases, exhaustiveness info is not available! *) +let for_trywith param pat_act_list = + compile_matching None + (fun () -> Lprim (Praise Raise_reraise, [param], Location.none)) + param pat_act_list Partial + +let simple_for_let loc param pat body = + compile_matching None (partial_function loc) param [(pat, body)] Partial + +(* Optimize binding of immediate tuples + + The goal of the implementation of 'for_let' below, which replaces + 'simple_for_let', is to avoid tuple allocation in cases such as + this one: + + let (x,y) = + let foo = ... in + if foo then (1, 2) else (3,4) + in bar + + The compiler easily optimizes the simple `let (x,y) = (1,2) in ...` + case (call to Matching.for_multiple_match from Translcore), but + didn't optimize situations where the rhs tuples are hidden under + a more complex context. + + The idea comes from Alain Frisch who suggested and implemented + the following compilation method, based on Lassign: + + let x = dummy in let y = dummy in + begin + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1) + else + (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2) + end; + bar + + The current implementation from Gabriel Scherer uses Lstaticcatch / + Lstaticraise instead: + + catch + let foo = ... in + if foo then + (let x1 = 1 in let y1 = 2 in exit x1 y1) + else + (let x2 = 3 in let y2 = 4 in exit x2 y2) + with x y -> + bar + + The catch/exit is used to avoid duplication of the let body ('bar' + in the example), on 'if' branches for example; it is useless for + linear contexts such as 'let', but we don't need to be careful to + generate nice code because Simplif will remove such useless + catch/exit. +*) + +let for_let loc param pat body = + match pat.pat_desc with + | Tpat_any -> + (* This eliminates a useless variable (and stack slot in bytecode) + for "let _ = ...". See #6865. *) + Lsequence (param, body) + | Tpat_var (id, _) -> + (* fast path, and keep track of simple bindings to unboxable numbers *) + Llet (Strict, Pgenval, id, param, body) + | _ -> simple_for_let loc param pat body + +(* Handling of tupled functions and matchings *) + +(* Easy case since variables are available *) +let for_tupled_function loc paraml pats_act_list partial = + let partial = check_partial_list pats_act_list partial in + let raise_num = next_raise_count () in + let omegas = [List.map (fun _ -> omega) paraml] in + let pm = + { + cases = pats_act_list; + args = List.map (fun id -> (Lvar id, Strict)) paraml; + default = [(omegas, raise_num)]; + } + in + try + let lambda, total = + compile_match None partial (start_ctx (List.length paraml)) pm + in + check_total total lambda raise_num (partial_function loc) + with Unused -> partial_function loc () + +let flatten_pattern size p = + match p.pat_desc with + | Tpat_tuple args -> args + | Tpat_any -> omegas size + | _ -> raise Cannot_flatten + +let rec flatten_pat_line size p k = + match p.pat_desc with + | Tpat_any -> omegas size :: k + | Tpat_tuple args -> args :: k + | Tpat_or (p1, p2, _) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) + | Tpat_alias (p, _, _) -> + (* Note: if this 'as' pat is here, then this is a + useless binding, solves PR#3780 *) + flatten_pat_line size p k + | _ -> fatal_error "Matching.flatten_pat_line" + +let flatten_cases size cases = + List.map + (fun (ps, action) -> + match ps with + | [p] -> (flatten_pattern size p, action) + | _ -> fatal_error "Matching.flatten_case") + cases + +let flatten_matrix size pss = + List.fold_right + (fun ps r -> + match ps with + | [p] -> flatten_pat_line size p r + | _ -> fatal_error "Matching.flatten_matrix") + pss [] + +let flatten_def size def = + List.map (fun (pss, i) -> (flatten_matrix size pss, i)) def + +let flatten_pm size args pm = + { + args; + cases = flatten_cases size pm.cases; + default = flatten_def size pm.default; + } + +let flatten_precompiled size args pmh = + match pmh with + | Pm pm -> Pm (flatten_pm size args pm) + | PmOr {body = b; handlers = hs; or_matrix = m} -> + PmOr + { + body = flatten_pm size args b; + handlers = + List.map + (fun (mat, i, vars, pm) -> (flatten_matrix size mat, i, vars, pm)) + hs; + or_matrix = flatten_matrix size m; + } + | PmVar _ -> assert false + +(* + compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. + Hence it needs a fourth argument, which it ignores +*) + +let compile_flattened repr partial ctx _ pmh = + match pmh with + | Pm pm -> compile_match repr partial ctx pm + | PmOr {body = b; handlers = hs} -> + let lam, total = compile_match repr partial ctx b in + compile_orhandlers (compile_match repr partial) lam total ctx hs + | PmVar _ -> assert false + +let do_for_multiple_match loc paraml pat_act_list partial = + let repr = None in + let partial = check_partial pat_act_list partial in + let raise_num, pm1 = + match partial with + | Partial -> + let raise_num = next_raise_count () in + ( raise_num, + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + default = [([[omega]], raise_num)]; + } ) + | _ -> + ( -1, + { + cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + default = []; + } ) + in + + try + try + (* Once for checking that compilation is possible *) + let next, nexts = split_precompile None pm1 in + + let size = List.length paraml + and idl = List.map (fun _ -> Ident.create "match") paraml in + let args = List.map (fun id -> (Lvar id, Alias)) idl in + + let flat_next = flatten_precompiled size args next + and flat_nexts = + List.map (fun (e, pm) -> (e, flatten_precompiled size args pm)) nexts + in + + let lam, total = + comp_match_handlers (compile_flattened repr) partial (start_ctx size) () + flat_next flat_nexts + in + List.fold_right2 (bind Strict) idl paraml + (match partial with + | Partial -> check_total total lam raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total); + lam) + with Cannot_flatten -> ( + let lambda, total = compile_match None partial (start_ctx 1) pm1 in + match partial with + | Partial -> check_total total lambda raise_num (partial_function loc) + | Total -> + assert (jumps_is_empty total); + lambda) + with Unused -> assert false (* ; partial_function loc () *) + +(* PR#4828: Believe it or not, the 'paraml' argument below + may not be side effect free. *) + +let param_to_var param = + match param with + | Lvar v -> (v, None) + | _ -> (Ident.create "match", Some param) + +let bind_opt (v, eo) k = + match eo with + | None -> k + | Some e -> Lambda.bind Strict v e k + +let for_multiple_match loc paraml pat_act_list partial = + let v_paraml = List.map param_to_var paraml in + let paraml = List.map (fun (v, _) -> Lvar v) v_paraml in + List.fold_right bind_opt v_paraml + (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/compiler/ml/matching.mli b/compiler/ml/matching.mli new file mode 100644 index 0000000..43d1d2c --- /dev/null +++ b/compiler/ml/matching.mli @@ -0,0 +1,76 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Compilation of pattern-matching *) + +open Typedtree +open Lambda + +val call_switcher_variant_constant : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref + +val call_switcher_variant_constr : + (Location.t -> + Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Ast_untagged_variants.switch_names option -> + Lambda.lambda) + ref + +val make_test_sequence_variant_constant : + (Lambda.lambda option -> + Lambda.lambda -> + (int * (string * Lambda.lambda)) list -> + Lambda.lambda) + ref + +(* Entry points to match compiler *) +val for_function : + Location.t -> + int ref option -> + lambda -> + (pattern * lambda) list -> + partial -> + lambda +val for_trywith : lambda -> (pattern * lambda) list -> lambda +val for_let : Location.t -> lambda -> pattern -> lambda -> lambda +val for_multiple_match : + Location.t -> lambda list -> (pattern * lambda) list -> partial -> lambda + +val for_tupled_function : + Location.t -> + Ident.t list -> + (pattern list * lambda) list -> + partial -> + lambda + +exception Cannot_flatten + +val flatten_pattern : int -> pattern -> pattern list + +(* Expand stringswitch to string test tree *) +val expand_stringswitch : + Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda + +(* To be set by Lam_compile *) +val names_from_construct_pattern : + (pattern -> Ast_untagged_variants.switch_names option) ref diff --git a/compiler/ml/mtype.ml b/compiler/ml/mtype.ml new file mode 100644 index 0000000..449d89a --- /dev/null +++ b/compiler/ml/mtype.ml @@ -0,0 +1,410 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Operations on module types *) + +open Asttypes +open Path +open Types + +let rec scrape env mty = + match mty with + | Mty_ident p -> ( + try scrape env (Env.find_modtype_expansion p env) with Not_found -> mty) + | _ -> mty + +let freshen mty = Subst.modtype Subst.identity mty + +let rec strengthen ~aliasable env mty p = + match scrape env mty with + | Mty_signature sg -> Mty_signature (strengthen_sig ~aliasable env sg p 0) + | Mty_functor (param, arg, res) + when !Clflags.applicative_functors && Ident.name param <> "*" -> + Mty_functor + ( param, + arg, + strengthen ~aliasable:false env res (Papply (p, Pident param)) ) + | mty -> mty + +and strengthen_sig ~aliasable env sg p pos = + match sg with + | [] -> [] + | (Sig_value (_, desc) as sigelt) :: rem -> + let nextpos = + match desc.val_kind with + | Val_prim _ -> pos + | _ -> pos + 1 + in + sigelt :: strengthen_sig ~aliasable env rem p nextpos + | Sig_type (id, {type_kind = Type_abstract}, _) + :: (Sig_type (id', {type_private = Private}, _) :: _ as rem) + when Ident.name id = Ident.name id' ^ "#row" -> + strengthen_sig ~aliasable env rem p pos + | Sig_type (id, decl, rs) :: rem -> + let newdecl = + match (decl.type_manifest, decl.type_private, decl.type_kind) with + | Some _, Public, _ -> decl + | Some _, Private, (Type_record _ | Type_variant _) -> decl + | _ -> + let manif = + Some + (Btype.newgenty + (Tconstr + (Pdot (p, Ident.name id, nopos), decl.type_params, ref Mnil))) + in + if decl.type_kind = Type_abstract then + {decl with type_private = Public; type_manifest = manif} + else {decl with type_manifest = manif} + in + Sig_type (id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos + | (Sig_typext _ as sigelt) :: rem -> + sigelt :: strengthen_sig ~aliasable env rem p (pos + 1) + | Sig_module (id, md, rs) :: rem -> + let str = + strengthen_decl ~aliasable env md (Pdot (p, Ident.name id, pos)) + in + Sig_module (id, str, rs) + :: strengthen_sig ~aliasable + (Env.add_module_declaration ~check:false id md env) + rem p (pos + 1) + (* Need to add the module in case it defines manifest module types *) + | Sig_modtype (id, decl) :: rem -> + let newdecl = + match decl.mtd_type with + | None -> + {decl with mtd_type = Some (Mty_ident (Pdot (p, Ident.name id, nopos)))} + | Some _ -> decl + in + Sig_modtype (id, newdecl) + :: strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos + (* Need to add the module type in case it is manifest *) + | (Sig_class _ as sigelt) :: rem -> + sigelt :: strengthen_sig ~aliasable env rem p (pos + 1) + | (Sig_class_type _ as sigelt) :: rem -> + sigelt :: strengthen_sig ~aliasable env rem p pos + +and strengthen_decl ~aliasable env md p = + match md.md_type with + | Mty_alias _ -> md + | _ when aliasable -> {md with md_type = Mty_alias (Mta_present, p)} + | mty -> {md with md_type = strengthen ~aliasable env mty p} + +let () = Env.strengthen := strengthen + +(* In nondep_supertype, env is only used for the type it assigns to id. + Hence there is no need to keep env up-to-date by adding the bindings + traversed. *) + +type variance = Co | Contra | Strict + +let nondep_supertype env mid mty = + let rec nondep_mty env va mty = + match mty with + | Mty_ident p -> + if Path.isfree mid p then + nondep_mty env va (Env.find_modtype_expansion p env) + else mty + | Mty_alias (_, p) -> + if Path.isfree mid p then + nondep_mty env va (Env.find_module p env).md_type + else mty + | Mty_signature sg -> Mty_signature (nondep_sig env va sg) + | Mty_functor (param, arg, res) -> + let var_inv = + match va with + | Co -> Contra + | Contra -> Co + | Strict -> Strict + in + Mty_functor + ( param, + Misc.may_map (nondep_mty env var_inv) arg, + nondep_mty + (Env.add_module ~arg:true param (Btype.default_mty arg) env) + va res ) + and nondep_sig env va = function + | [] -> [] + | item :: rem -> ( + let rem' = nondep_sig env va rem in + match item with + | Sig_value (id, d) -> + Sig_value (id, {d with val_type = Ctype.nondep_type env mid d.val_type}) + :: rem' + | Sig_type (id, d, rs) -> + Sig_type (id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) :: rem' + | Sig_typext (id, ext, es) -> + Sig_typext (id, Ctype.nondep_extension_constructor env mid ext, es) + :: rem' + | Sig_module (id, md, rs) -> + Sig_module (id, {md with md_type = nondep_mty env va md.md_type}, rs) + :: rem' + | Sig_modtype (id, d) -> ( + try Sig_modtype (id, nondep_modtype_decl env d) :: rem' + with Not_found -> ( + match va with + | Co -> + Sig_modtype + ( id, + {mtd_type = None; mtd_loc = Location.none; mtd_attributes = []} + ) + :: rem' + | _ -> raise Not_found)) + | Sig_class () -> assert false + | Sig_class_type () -> assert false) + and nondep_modtype_decl env mtd = + {mtd with mtd_type = Misc.may_map (nondep_mty env Strict) mtd.mtd_type} + in + + nondep_mty env Co mty + +let enrich_typedecl env p decl = + match decl.type_manifest with + | Some _ -> decl + | None -> ( + try + let orig_decl = Env.find_type p env in + if orig_decl.type_arity <> decl.type_arity then decl + else + { + decl with + type_manifest = + Some (Btype.newgenty (Tconstr (p, decl.type_params, ref Mnil))); + } + with Not_found -> decl) + +let rec enrich_modtype env p mty = + match mty with + | Mty_signature sg -> Mty_signature (List.map (enrich_item env p) sg) + | _ -> mty + +and enrich_item env p = function + | Sig_type (id, decl, rs) -> + Sig_type (id, enrich_typedecl env (Pdot (p, Ident.name id, nopos)) decl, rs) + | Sig_module (id, md, rs) -> + Sig_module + ( id, + { + md with + md_type = + enrich_modtype env (Pdot (p, Ident.name id, nopos)) md.md_type; + }, + rs ) + | item -> item + +let rec type_paths env p mty = + match scrape env mty with + | Mty_ident _ -> [] + | Mty_alias _ -> [] + | Mty_signature sg -> type_paths_sig env p 0 sg + | Mty_functor _ -> [] + +and type_paths_sig env p pos sg = + match sg with + | [] -> [] + | Sig_value (_id, decl) :: rem -> + let pos' = + match decl.val_kind with + | Val_prim _ -> pos + | _ -> pos + 1 + in + type_paths_sig env p pos' rem + | Sig_type (id, _decl, _) :: rem -> + Pdot (p, Ident.name id, nopos) :: type_paths_sig env p pos rem + | Sig_module (id, md, _) :: rem -> + type_paths env (Pdot (p, Ident.name id, pos)) md.md_type + @ type_paths_sig + (Env.add_module_declaration ~check:false id md env) + p (pos + 1) rem + | Sig_modtype (id, decl) :: rem -> + type_paths_sig (Env.add_modtype id decl env) p pos rem + | (Sig_typext _ | Sig_class _) :: rem -> type_paths_sig env p (pos + 1) rem + | Sig_class_type _ :: rem -> type_paths_sig env p pos rem + +let rec no_code_needed env mty = + match scrape env mty with + | Mty_ident _ -> false + | Mty_signature sg -> no_code_needed_sig env sg + | Mty_functor (_, _, _) -> false + | Mty_alias (Mta_absent, _) -> true + | Mty_alias (Mta_present, _) -> false + +and no_code_needed_sig env sg = + match sg with + | [] -> true + | Sig_value (_id, decl) :: rem -> ( + match decl.val_kind with + | Val_prim _ -> no_code_needed_sig env rem + | _ -> false) + | Sig_module (id, md, _) :: rem -> + no_code_needed env md.md_type + && no_code_needed_sig + (Env.add_module_declaration ~check:false id md env) + rem + | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> + no_code_needed_sig env rem + | (Sig_typext _ | Sig_class _) :: _ -> false + +(* Check whether a module type may return types *) + +let rec contains_type env = function + | Mty_ident path -> ( + try + match (Env.find_modtype path env).mtd_type with + | None -> raise Exit (* PR#6427 *) + | Some mty -> contains_type env mty + with Not_found -> raise Exit) + | Mty_signature sg -> contains_type_sig env sg + | Mty_functor (_, _, body) -> contains_type env body + | Mty_alias _ -> () + +and contains_type_sig env = List.iter (contains_type_item env) + +and contains_type_item env = function + | Sig_type + ( _, + ( {type_manifest = None} + | {type_kind = Type_abstract; type_private = Private} ), + _ ) + | Sig_modtype _ + | Sig_typext (_, {ext_args = Cstr_record _}, _) -> + (* We consider that extension constructors with an inlined + record create a type (the inlined record), even though + it would be technically safe to ignore that considering + the current constraints which guarantee that this type + is kept local to expressions. *) + raise Exit + | Sig_module (_, {md_type = mty}, _) -> contains_type env mty + | Sig_value _ | Sig_type _ | Sig_typext _ | Sig_class _ | Sig_class_type _ -> + () + +let contains_type env mty = + try + contains_type env mty; + false + with Exit -> true + +(* Remove module aliases from a signature *) + +module PathSet = Set.Make (Path) +module PathMap = Map.Make (Path) +module IdentSet = Set.Make (Ident) + +let rec get_prefixes = function + | Pident _ -> PathSet.empty + | Pdot (p, _, _) | Papply (p, _) -> PathSet.add p (get_prefixes p) + +let rec get_arg_paths = function + | Pident _ -> PathSet.empty + | Pdot (p, _, _) -> get_arg_paths p + | Papply (p1, p2) -> + PathSet.add p2 + (PathSet.union (get_prefixes p2) + (PathSet.union (get_arg_paths p1) (get_arg_paths p2))) + +let rec rollback_path subst p = + try Pident (PathMap.find p subst) + with Not_found -> ( + match p with + | Pident _ | Papply _ -> p + | Pdot (p1, s, n) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n))) + +let rec collect_ids subst bindings p = + match rollback_path subst p with + | Pident id -> + let ids = + try collect_ids subst bindings (Ident.find_same id bindings) + with Not_found -> IdentSet.empty + in + IdentSet.add id ids + | _ -> IdentSet.empty + +let collect_arg_paths mty = + let open Btype in + let paths = ref PathSet.empty + and subst = ref PathMap.empty + and bindings = ref Ident.empty in + (* let rt = Ident.create "Root" in + and prefix = ref (Path.Pident rt) in *) + let it_path p = paths := PathSet.union (get_arg_paths p) !paths + and it_signature_item it si = + type_iterators.it_signature_item it si; + match si with + | Sig_module (id, {md_type = Mty_alias (_, p)}, _) -> + bindings := Ident.add id p !bindings + | Sig_module (id, {md_type = Mty_signature sg}, _) -> + List.iter + (function + | Sig_module (id', _, _) -> + subst := + PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst + | _ -> ()) + sg + | _ -> () + in + let it = {type_iterators with it_path; it_signature_item} in + it.it_module_type it mty; + it.it_module_type unmark_iterators mty; + PathSet.fold + (fun p -> IdentSet.union (collect_ids !subst !bindings p)) + !paths IdentSet.empty + +let rec remove_aliases env excl mty = + match mty with + | Mty_signature sg -> Mty_signature (remove_aliases_sig env excl sg) + | Mty_alias _ -> + let mty' = Env.scrape_alias env mty in + if mty' = mty then mty + else (* nested polymorphic comparison *) + remove_aliases env excl mty' + | mty -> mty + +and remove_aliases_sig env excl sg = + match sg with + | [] -> [] + | Sig_module (id, md, rs) :: rem -> + let mty = + match md.md_type with + | Mty_alias _ when IdentSet.mem id excl -> md.md_type + | mty -> remove_aliases env excl mty + in + Sig_module (id, {md with md_type = mty}, rs) + :: remove_aliases_sig (Env.add_module id mty env) excl rem + | Sig_modtype (id, mtd) :: rem -> + Sig_modtype (id, mtd) + :: remove_aliases_sig (Env.add_modtype id mtd env) excl rem + | it :: rem -> it :: remove_aliases_sig env excl rem + +let remove_aliases env sg = + let excl = collect_arg_paths sg in + (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl; + Format.eprintf "@."; *) + remove_aliases env excl sg + +(* Lower non-generalizable type variables *) + +let lower_nongen nglev mty = + let open Btype in + let it_type_expr it ty = + let ty = repr ty in + match ty with + | {desc = Tvar _; level} -> + if level < generic_level && level > nglev then set_level ty nglev + | _ -> type_iterators.it_type_expr it ty + in + let it = {type_iterators with it_type_expr} in + it.it_module_type it mty; + it.it_module_type unmark_iterators mty diff --git a/compiler/ml/mtype.mli b/compiler/ml/mtype.mli new file mode 100644 index 0000000..64198df --- /dev/null +++ b/compiler/ml/mtype.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Operations on module types *) + +open Types + +val scrape : Env.t -> module_type -> module_type +(* Expand toplevel module type abbreviations + till hitting a "hard" module type (signature, functor, + or abstract module type ident. *) + +val freshen : module_type -> module_type +(* Return an alpha-equivalent copy of the given module type + where bound identifiers are fresh. *) + +val strengthen : aliasable:bool -> Env.t -> module_type -> Path.t -> module_type +(* Strengthen abstract type components relative to the + given path. *) + +val strengthen_decl : + aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration +val nondep_supertype : Env.t -> Ident.t -> module_type -> module_type +(* Return the smallest supertype of the given type + in which the given ident does not appear. + Raise [Not_found] if no such type exists. *) + +val no_code_needed : Env.t -> module_type -> bool +val no_code_needed_sig : Env.t -> signature -> bool +(* Determine whether a module needs no implementation code, + i.e. consists only of type definitions. *) + +val enrich_modtype : Env.t -> Path.t -> module_type -> module_type +val enrich_typedecl : Env.t -> Path.t -> type_declaration -> type_declaration +val type_paths : Env.t -> Path.t -> module_type -> Path.t list +val contains_type : Env.t -> module_type -> bool +val remove_aliases : Env.t -> module_type -> module_type +val lower_nongen : int -> module_type -> unit diff --git a/compiler/ml/oprint.ml b/compiler/ml/oprint.ml new file mode 100644 index 0000000..153d68f --- /dev/null +++ b/compiler/ml/oprint.ml @@ -0,0 +1,732 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 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. *) +(* *) +(**************************************************************************) + +open Format +open Outcometree + +exception Ellipsis + +let cautious f ppf arg = try f ppf arg with Ellipsis -> fprintf ppf "..." + +let out_ident = ref pp_print_string +let map_primitive_name = ref (fun x -> x) + +let print_lident ppf = function + | "::" -> !out_ident ppf "(::)" + | s -> !out_ident ppf s + +let rec print_ident ppf = function + | Oide_ident s -> print_lident ppf s + | Oide_dot (id, s) -> + print_ident ppf id; + pp_print_char ppf '.'; + print_lident ppf s + | Oide_apply (id1, id2) -> + fprintf ppf "%a(%a)" print_ident id1 print_ident id2 + +let parenthesized_ident name = + List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"] + || + match name.[0] with + | 'a' .. 'z' | 'A' .. 'Z' | '\223' .. '\246' | '\248' .. '\255' | '_' -> false + | _ -> true + +let value_ident ppf name = + if parenthesized_ident name then fprintf ppf "( %s )" name + else pp_print_string ppf name + +(* Values *) + +let valid_float_lexeme s = + let l = String.length s in + let rec loop i = + if i >= l then s ^ "." + else + match s.[i] with + | '0' .. '9' | '-' -> loop (i + 1) + | _ -> s + in + loop 0 + +let float_repres f = + match classify_float f with + | FP_nan -> "nan" + | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" + | _ -> + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = float_of_string s1 then s1 + else + let s2 = Printf.sprintf "%.15g" f in + if f = float_of_string s2 then s2 else Printf.sprintf "%.18g" f + in + valid_float_lexeme float_val + +let parenthesize_if_neg ppf fmt v isneg = + if isneg then pp_print_char ppf '('; + fprintf ppf fmt v; + if isneg then pp_print_char ppf ')' + +let escape_string s = + (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' and '"' *) + let n = ref 0 in + for i = 0 to String.length s - 1 do + n := + !n + + + match String.unsafe_get s i with + | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 + | '\x00' .. '\x1F' | '\x7F' -> 4 + | _ -> 1 + done; + if !n = String.length s then s + else + let s' = Bytes.create !n in + n := 0; + for i = 0 to String.length s - 1 do + (match String.unsafe_get s i with + | ('\"' | '\\') as c -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n c + | '\n' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'n' + | '\t' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 't' + | '\r' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'r' + | '\b' -> + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n 'b' + | ('\x00' .. '\x1F' | '\x7F') as c -> + let a = Char.code c in + Bytes.unsafe_set s' !n '\\'; + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 100))); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10 mod 10))); + incr n; + Bytes.unsafe_set s' !n (Char.chr (48 + (a mod 10))) + | c -> Bytes.unsafe_set s' !n c); + incr n + done; + Bytes.to_string s' + +let print_out_string ppf s = + let not_escaped = + (* let the user dynamically choose if strings should be escaped: *) + match Sys.getenv_opt "OCAMLTOP_UTF_8" with + | None -> true + | Some x -> ( + match bool_of_string_opt x with + | None -> true + | Some f -> f) + in + if not_escaped then fprintf ppf "\"%s\"" (escape_string s) + else fprintf ppf "%S" s + +let print_out_value ppf tree = + let rec print_tree_1 ppf = function + | Oval_constr (name, [param]) -> + fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param + | Oval_constr (name, (_ :: _ as params)) -> + fprintf ppf "@[<1>%a@ (%a)@]" print_ident name + (print_tree_list print_tree_1 ",") + params + | Oval_variant (name, Some param) -> + fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param + | tree -> print_simple_tree ppf tree + and print_constr_param ppf = function + | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) + | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l) + | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L) + | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) + | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0) + | Oval_string (_, _, Ostr_bytes) as tree -> + pp_print_char ppf '('; + print_simple_tree ppf tree; + pp_print_char ppf ')' + | tree -> print_simple_tree ppf tree + and print_simple_tree ppf = function + | Oval_int i -> fprintf ppf "%i" i + | Oval_int32 i -> fprintf ppf "%lil" i + | Oval_int64 i -> fprintf ppf "%LiL" i + | Oval_nativeint i -> fprintf ppf "%nin" i + | Oval_float f -> pp_print_string ppf (float_repres f) + | Oval_char c -> fprintf ppf "%C" c + | Oval_string (s, maxlen, kind) -> ( + try + let len = String.length s in + let s = if len > maxlen then String.sub s 0 maxlen else s in + (match kind with + | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s + | Ostr_string -> print_out_string ppf s); + if len > maxlen then + fprintf ppf "... (* string length %d; truncated *)" len + with Invalid_argument _ (* "String.create" *) -> + fprintf ppf "") + | Oval_list tl -> + fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl + | Oval_array tl -> + fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl + | Oval_constr (name, []) -> print_ident ppf name + | Oval_variant (name, None) -> fprintf ppf "`%s" name + | Oval_stuff s -> pp_print_string ppf s + | Oval_record fel -> + fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel + | Oval_ellipsis -> raise Ellipsis + | Oval_printer f -> f ppf + | Oval_tuple tree_list -> + fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list + | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree + and print_fields first ppf = function + | [] -> () + | (name, tree) :: fields -> + if not first then fprintf ppf ";@ "; + fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) + tree; + print_fields false ppf fields + and print_tree_list print_item sep ppf tree_list = + let rec print_list first ppf = function + | [] -> () + | tree :: tree_list -> + if not first then fprintf ppf "%s@ " sep; + print_item ppf tree; + print_list false ppf tree_list + in + cautious (print_list true) ppf tree_list + in + cautious print_tree_1 ppf tree + +let out_value = ref print_out_value + +(* Types *) + +let rec print_list_init pr sep ppf = function + | [] -> () + | a :: l -> + sep ppf; + pr ppf a; + print_list_init pr sep ppf l + +let rec print_list pr sep ppf = function + | [] -> () + | [a] -> pr ppf a + | a :: l -> + pr ppf a; + sep ppf; + print_list pr sep ppf l + +let pr_present = + print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") + +let pr_vars = + print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") + +let rec print_out_type ppf = function + | Otyp_alias (ty, s) -> fprintf ppf "@[%a@ as '%s@]" print_out_type ty s + | Otyp_poly (sl, ty) -> + fprintf ppf "@[%a.@ %a@]" pr_vars sl print_out_type ty + | ty -> print_out_type_1 ppf ty + +and print_out_type_1 ppf = function + | Otyp_arrow (lab, ty1, ty2, _) -> + pp_open_box ppf 0; + if lab <> "" then ( + pp_print_string ppf lab; + pp_print_char ppf ':'); + print_out_type_2 ppf ty1; + pp_print_string ppf " ->"; + pp_print_space ppf (); + print_out_type_1 ppf ty2; + pp_close_box ppf () + | ty -> print_out_type_2 ppf ty + +and print_out_type_2 ppf = function + | Otyp_tuple tyl -> + fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl + | ty -> print_simple_out_type ppf ty + +and print_simple_out_type ppf = function + | Otyp_class (ng, id, tyl) -> + fprintf ppf "@[%a%s#%a@]" print_typargs tyl + (if ng then "_" else "") + print_ident id + | Otyp_constr (id, tyl) -> + pp_open_box ppf 0; + print_typargs ppf tyl; + print_ident ppf id; + pp_close_box ppf () + | Otyp_object (fields, rest) -> + fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields + | Otyp_stuff s -> pp_print_string ppf s + | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s + | Otyp_variant (non_gen, row_fields, closed, tags) -> + let print_present ppf = function + | None | Some [] -> () + | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l + in + let print_fields ppf = function + | Ovar_fields fields -> + print_list print_row_field + (fun ppf -> fprintf ppf "@;<1 -2>| ") + ppf fields + | Ovar_typ typ -> print_simple_out_type ppf typ + in + fprintf ppf "%s[%s@[@[%a@]%a ]@]" + (if non_gen then "_" else "") + (if closed then if tags = None then " " else "< " + else if tags = None then "> " + else "? ") + print_fields row_fields print_present tags + | (Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _) as ty -> + pp_open_box ppf 1; + pp_print_char ppf '('; + print_out_type ppf ty; + pp_print_char ppf ')'; + pp_close_box ppf () + | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_manifest (_, _) -> () + | Otyp_record lbls -> print_record_decl ppf lbls + | Otyp_module (p, n, tyl) -> + fprintf ppf "@[<1>(module %s" p; + let first = ref true in + List.iter2 + (fun s t -> + let sep = + if !first then ( + first := false; + "with") + else "and" + in + fprintf ppf " %s type %s = %a" sep s print_out_type t) + n tyl; + fprintf ppf ")@]" + | Otyp_attribute (t, attr) -> + fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name + +and print_record_decl ppf lbls = + fprintf ppf "{%a@;<1 -2>}" + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) + lbls + +and print_fields rest ppf = function + | [] -> ( + match rest with + | Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") + | None -> ()) + | [(s, t)] -> + fprintf ppf "%s : %a" s print_out_type t; + (match rest with + | Some _ -> fprintf ppf ";@ " + | None -> ()); + print_fields rest ppf [] + | (s, t) :: l -> + fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l + +and print_row_field ppf (l, opt_amp, tyl) = + let pr_of ppf = + if opt_amp then fprintf ppf " of@ &@ " + else if tyl <> [] then fprintf ppf " of@ " + else fprintf ppf "" + in + fprintf ppf "@[`%s%t%a@]" l pr_of + (print_typlist print_out_type " &") + tyl + +and print_typlist print_elem sep ppf = function + | [] -> () + | [ty] -> print_elem ppf ty + | ty :: tyl -> + print_elem ppf ty; + pp_print_string ppf sep; + pp_print_space ppf (); + print_typlist print_elem sep ppf tyl + +and print_typargs ppf = function + | [] -> () + | [ty1] -> + print_simple_out_type ppf ty1; + pp_print_space ppf () + | tyl -> + pp_open_box ppf 1; + pp_print_char ppf '('; + print_typlist print_out_type "," ppf tyl; + pp_print_char ppf ')'; + pp_close_box ppf (); + pp_print_space ppf () + +and print_out_label ppf (name, mut, opt, arg) = + fprintf ppf "@[<2>%s%s%s :@ %a@];" + (if opt then "@optional " else "") + (if mut then "mutable " else "") + name print_out_type arg + +let out_type = ref print_out_type + +(* Class types *) + +let type_parameter ppf (ty, (co, cn)) = + fprintf ppf "%s%s" + (if not cn then "+" else if not co then "-" else "") + (if ty = "_" then ty else "'" ^ ty) + +let print_out_class_params ppf = function + | [] -> () + | tyl -> + fprintf ppf "@[<1>[%a]@]@ " + (print_list type_parameter (fun ppf -> fprintf ppf ", ")) + tyl + +let rec print_out_class_type ppf = function + | Octy_constr (id, tyl) -> + let pr_tyl ppf = function + | [] -> () + | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl + in + fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id + | Octy_arrow (lab, ty, cty) -> + fprintf ppf "@[%s%a ->@ %a@]" + (if lab <> "" then lab ^ ":" else "") + print_out_type_2 ty print_out_class_type cty + | Octy_signature (self_ty, csil) -> + let pr_param ppf = function + | Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty + | None -> () + in + fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty + (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) + csil + +and print_out_class_sig_item ppf = function + | Ocsg_constraint (ty1, ty2) -> + fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2 + | Ocsg_method (name, priv, virt, ty) -> + fprintf ppf "@[<2>method %s%s%s :@ %a@]" + (if priv then "private " else "") + (if virt then "virtual " else "") + name !out_type ty + | Ocsg_value (name, mut, vr, ty) -> + fprintf ppf "@[<2>val %s%s%s :@ %a@]" + (if mut then "mutable " else "") + (if vr then "virtual " else "") + name !out_type ty + +let out_class_type = ref print_out_class_type + +(* Signature *) + +let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") +let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") +let out_signature = ref (fun _ -> failwith "Oprint.out_signature") +let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") + +let rec print_out_functor funct ppf = function + | Omty_functor (_, None, mty_res) -> + if funct then fprintf ppf "() %a" (print_out_functor true) mty_res + else fprintf ppf "functor@ () %a" (print_out_functor true) mty_res + | Omty_functor (name, Some mty_arg, mty_res) -> ( + match (name, funct) with + | "_", true -> + fprintf ppf "->@ %a ->@ %a" print_out_module_type mty_arg + (print_out_functor false) mty_res + | "_", false -> + fprintf ppf "%a ->@ %a" print_out_module_type mty_arg + (print_out_functor false) mty_res + | name, true -> + fprintf ppf "(%s : %a) %a" name print_out_module_type mty_arg + (print_out_functor true) mty_res + | name, false -> + fprintf ppf "functor@ (%s : %a) %a" name print_out_module_type mty_arg + (print_out_functor true) mty_res) + | m -> + if funct then fprintf ppf "->@ %a" print_out_module_type m + else print_out_module_type ppf m + +and print_out_module_type ppf = function + | Omty_abstract -> () + | Omty_functor _ as t -> fprintf ppf "@[<2>%a@]" (print_out_functor false) t + | Omty_ident id -> fprintf ppf "%a" print_ident id + | Omty_signature sg -> + fprintf ppf "@[sig@ %a@;<1 -2>end@]" !out_signature sg + | Omty_alias id -> fprintf ppf "(module %a)" print_ident id + +and print_out_signature ppf = function + | [] -> () + | [item] -> !out_sig_item ppf item + | Osig_typext (ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + | Osig_typext (ext, Oext_next) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + items + in + let te = + { + otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items + | item :: items -> + fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items + +and print_out_sig_item ppf = function + | Osig_class (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" + (if rs = Orec_next then "and" else "class") + (if vir_flag then " virtual" else "") + print_out_class_params params name !out_class_type clt + | Osig_class_type (vir_flag, name, params, clt, rs) -> + fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" + (if rs = Orec_next then "and" else "class type") + (if vir_flag then " virtual" else "") + print_out_class_params params name !out_class_type clt + | Osig_typext (ext, Oext_exception) -> + fprintf ppf "@[<2>exception %a@]" print_out_constr + (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + | Osig_typext (ext, _es) -> print_out_extension_constructor ppf ext + | Osig_modtype (name, Omty_abstract) -> + fprintf ppf "@[<2>module type %s@]" name + | Osig_modtype (name, mty) -> + fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty + | Osig_module (name, Omty_alias id, _) -> + fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id + | Osig_module (name, mty, rs) -> + fprintf ppf "@[<2>%s %s :@ %a@]" + (match rs with + | Orec_not -> "module" + | Orec_first -> "module rec" + | Orec_next -> "and") + name !out_module_type mty + | Osig_type (td, rs) -> + print_out_type_decl + (match rs with + | Orec_not -> "type nonrec" + | Orec_first -> "type" + | Orec_next -> "and") + ppf td + | Osig_value vd -> + let kwd = if vd.oval_prims = [] then "val" else "external" in + let pr_prims ppf = function + | [] -> () + | s :: sl -> + fprintf ppf "@ = \"%s\"" s; + List.iter + (fun s -> + (* TODO: in general, we should print bs attributes, some attributes like + variadic do need it *) + fprintf ppf "@ \"%s\"" (!map_primitive_name s)) + sl + in + fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name !out_type + vd.oval_type pr_prims vd.oval_prims + (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)) + vd.oval_attributes + | Osig_ellipsis -> fprintf ppf "..." + +and print_out_type_decl kwd ppf td = + let print_constraints ppf = + List.iter + (fun (ty1, ty2) -> + fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 !out_type ty2) + td.otype_cstrs + in + let type_defined ppf = + match td.otype_params with + | [] -> pp_print_string ppf td.otype_name + | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) + td.otype_params td.otype_name + in + let print_manifest ppf = function + | Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty + | _ -> () + in + let print_name_params ppf = + fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type + in + let ty = + match td.otype_type with + | Otyp_manifest (_, ty) -> ty + | _ -> td.otype_type + in + let print_private ppf = function + | Asttypes.Private -> fprintf ppf " private" + | Asttypes.Public -> () + in + let print_immediate ppf = + if td.otype_immediate then fprintf ppf " [%@%@immediate]" else () + in + let print_unboxed ppf = + if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else () + in + let print_out_tkind ppf = function + | Otyp_abstract -> () + | Otyp_record lbls -> + fprintf ppf " =%a %a" print_private td.otype_private print_record_decl + lbls + | Otyp_sum constrs -> + fprintf ppf " =%a@;<1 2>%a" print_private td.otype_private + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) + constrs + | Otyp_open -> fprintf ppf " =%a .." print_private td.otype_private + | ty -> + fprintf ppf " =%a@;<1 2>%a" print_private td.otype_private !out_type ty + in + fprintf ppf "@[<2>@[%t%a@]%t%t%t@]" print_name_params print_out_tkind ty + print_constraints print_immediate print_unboxed + +and print_out_constr ppf (name, tyl, ret_type_opt, repr) = + let () = + match repr with + | None -> () + | Some s -> pp_print_string ppf s + in + let name = + match name with + | "::" -> "(::)" (* #7200 *) + | s -> s + in + match ret_type_opt with + | None -> ( + match tyl with + | [] -> pp_print_string ppf name + | _ -> + fprintf ppf "@[<2>%s of@ %a@]" name + (print_typlist print_simple_out_type " *") + tyl) + | Some ret_type -> ( + match tyl with + | [] -> fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type + | _ -> + fprintf ppf "@[<2>%s :@ %a -> %a@]" name + (print_typlist print_simple_out_type " *") + tyl print_simple_out_type ret_type) + +and print_out_extension_constructor ppf ext = + let print_extended_type ppf = + let print_type_parameter ppf ty = + fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty) + in + match ext.oext_type_params with + | [] -> fprintf ppf "%s" ext.oext_type_name + | [ty_param] -> + fprintf ppf "@[%a@ %s@]" print_type_parameter ty_param ext.oext_type_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + ext.oext_type_params ext.oext_type_name + in + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type + (if ext.oext_private = Asttypes.Private then " private" else "") + print_out_constr + (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + +and print_out_type_extension ppf te = + let print_extended_type ppf = + let print_type_parameter ppf ty = + fprintf ppf "%s" (if ty = "_" then ty else "'" ^ ty) + in + match te.otyext_params with + | [] -> fprintf ppf "%s" te.otyext_name + | [param] -> + fprintf ppf "@[%a@ %s@]" print_type_parameter param te.otyext_name + | _ -> + fprintf ppf "@[(@[%a)@]@ %s@]" + (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) + te.otyext_params te.otyext_name + in + fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type + (if te.otyext_private = Asttypes.Private then " private" else "") + (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) + te.otyext_constructors + +let _ = out_module_type := print_out_module_type +let _ = out_signature := print_out_signature +let _ = out_sig_item := print_out_sig_item +let _ = out_type_extension := print_out_type_extension + +(* Phrases *) + +let print_out_exception ppf exn outv = + match exn with + | Sys.Break -> fprintf ppf "Interrupted.@." + | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." + | Stack_overflow -> + fprintf ppf "Stack overflow during evaluation (looping recursion?).@." + | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv + +let rec print_items ppf = function + | [] -> () + | (Osig_typext (ext, Oext_first), None) :: items -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Osig_typext (ext, Oext_next), None) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + items + in + let te = + { + otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + fprintf ppf "@[%a@]" !out_type_extension te; + if items <> [] then fprintf ppf "@ %a" print_items items + | (tree, valopt) :: items -> + (match valopt with + | Some v -> fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree !out_value v + | None -> fprintf ppf "@[%a@]" !out_sig_item tree); + if items <> [] then fprintf ppf "@ %a" print_items items + +let print_out_phrase ppf = function + | Ophr_eval (outv, ty) -> + fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv + | Ophr_signature [] -> () + | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items + | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv + +let out_phrase = ref print_out_phrase diff --git a/jscomp/ml/oprint.mli b/compiler/ml/oprint.mli similarity index 99% rename from jscomp/ml/oprint.mli rename to compiler/ml/oprint.mli index 7c53634..4bdd95a 100644 --- a/jscomp/ml/oprint.mli +++ b/compiler/ml/oprint.mli @@ -16,7 +16,6 @@ open Format open Outcometree - val out_ident : (formatter -> string -> unit) ref val map_primitive_name : (string -> string) ref diff --git a/compiler/ml/outcometree.ml b/compiler/ml/outcometree.ml new file mode 100644 index 0000000..1372420 --- /dev/null +++ b/compiler/ml/outcometree.ml @@ -0,0 +1,146 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 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. *) +(* *) +(**************************************************************************) + +(* Module [Outcometree]: results displayed by the toplevel *) + +(* These types represent messages that the toplevel displays as normal + results or errors. The real displaying is customisable using the hooks: + [Toploop.print_out_value] + [Toploop.print_out_type] + [Toploop.print_out_sig_item] + [Toploop.print_out_phrase] *) + +type out_ident = + | Oide_apply of out_ident * out_ident + | Oide_dot of out_ident * string + | Oide_ident of string + +type out_string = Ostr_string | Ostr_bytes + +type out_attribute = {oattr_name: string} + +type out_value = + | Oval_array of out_value list + | Oval_char of char + | Oval_constr of out_ident * out_value list + | Oval_ellipsis + | Oval_float of float + | Oval_int of int + | Oval_int32 of int32 + | Oval_int64 of int64 + | Oval_nativeint of nativeint + | Oval_list of out_value list + | Oval_printer of (Format.formatter -> unit) + | Oval_record of (out_ident * out_value) list + | Oval_string of string * int * out_string (* string, size-to-print, kind *) + | Oval_stuff of string + | Oval_tuple of out_value list + | Oval_variant of string * out_value option + +type out_type = + | Otyp_abstract + | Otyp_open + | Otyp_alias of out_type * string + | Otyp_arrow of string * out_type * out_type * Asttypes.arity + | Otyp_class of bool * out_ident * out_type list + | Otyp_constr of out_ident * out_type list + | Otyp_manifest of out_type * out_type + | Otyp_object of (string * out_type) list * bool option + | Otyp_record of (string * bool * bool * out_type) list + | Otyp_stuff of string + | Otyp_sum of (string * out_type list * out_type option * string option) list + | Otyp_tuple of out_type list + | Otyp_var of bool * string + | Otyp_variant of bool * out_variant * bool * string list option + | Otyp_poly of string list * out_type + | Otyp_module of string * string list * out_type list + | Otyp_attribute of out_type * out_attribute + +and out_variant = + | Ovar_fields of (string * bool * out_type list) list + | Ovar_typ of out_type + +type out_class_type = + | Octy_constr of out_ident * out_type list + | Octy_arrow of string * out_type * out_class_type + | Octy_signature of out_type option * out_class_sig_item list +and out_class_sig_item = + | Ocsg_constraint of out_type * out_type + | Ocsg_method of string * bool * bool * out_type + | Ocsg_value of string * bool * bool * out_type + +type out_module_type = + | Omty_abstract + | Omty_functor of string * out_module_type option * out_module_type + | Omty_ident of out_ident + | Omty_signature of out_sig_item list + | Omty_alias of out_ident +and out_sig_item = + | Osig_class of + bool + * string + * (string * (bool * bool)) list + * out_class_type + * out_rec_status + | Osig_class_type of + bool + * string + * (string * (bool * bool)) list + * out_class_type + * out_rec_status + | Osig_typext of out_extension_constructor * out_ext_status + | Osig_modtype of string * out_module_type + | Osig_module of string * out_module_type * out_rec_status + | Osig_type of out_type_decl * out_rec_status + | Osig_value of out_val_decl + | Osig_ellipsis +and out_type_decl = { + otype_name: string; + otype_params: (string * (bool * bool)) list; + otype_type: out_type; + otype_private: Asttypes.private_flag; + otype_immediate: bool; + otype_unboxed: bool; + otype_cstrs: (out_type * out_type) list; +} +and out_extension_constructor = { + oext_name: string; + oext_type_name: string; + oext_type_params: string list; + oext_args: out_type list; + oext_ret_type: out_type option; + oext_repr: string option; + oext_private: Asttypes.private_flag; +} +and out_type_extension = { + otyext_name: string; + otyext_params: string list; + otyext_constructors: + (string * out_type list * out_type option * string option) list; + otyext_private: Asttypes.private_flag; +} +and out_val_decl = { + oval_name: string; + oval_type: out_type; + oval_prims: string list; + oval_attributes: out_attribute list; +} +and out_rec_status = Orec_not | Orec_first | Orec_next +and out_ext_status = Oext_first | Oext_next | Oext_exception + +type out_phrase = + | Ophr_eval of out_value * out_type + | Ophr_signature of (out_sig_item * out_value option) list + | Ophr_exception of (exn * out_value) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml new file mode 100644 index 0000000..9e66800 --- /dev/null +++ b/compiler/ml/parmatch.ml @@ -0,0 +1,2555 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Detection of partial matches and unused match cases. *) + +open Misc +open Asttypes +open Types +open Typedtree + +(*************************************) +(* Utilities for building patterns *) +(*************************************) + +let make_pat desc ty tenv = + { + pat_desc = desc; + pat_loc = Location.none; + pat_extra = []; + pat_type = ty; + pat_env = tenv; + pat_attributes = []; + } + +let omega = make_pat Tpat_any Ctype.none Env.empty + +let extra_pat = + make_pat (Tpat_var (Ident.create "+", mknoloc "+")) Ctype.none Env.empty + +let rec omegas i = if i <= 0 then [] else omega :: omegas (i - 1) + +let omega_list l = List.map (fun _ -> omega) l + +let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty + +(*******************) +(* Coherence check *) +(*******************) + +(* For some of the operations we do in this module, we would like (because it + simplifies matters) to assume that patterns appearing on a given column in a + pattern matrix are /coherent/ (think "of the same type"). + Unfortunately that is not always true. + + Consider the following (well-typed) example: + {[ + type _ t = S : string t | U : unit t + + let f (type a) (t1 : a t) (t2 : a t) (a : a) = + match t1, t2, a with + | U, _, () -> () + | _, S, "" -> () + ]} + + Clearly the 3rd column contains incoherent patterns. + + On the example above, most of the algorithms will explore the pattern matrix + as illustrated by the following tree: + + {v + S + -------> | "" | + U | S, "" | __/ | () | + --------> | _, () | \ ¬ S + | U, _, () | __/ -------> | () | + | _, S, "" | \ + ---------> | S, "" | ----------> | "" | + ¬ U S + v} + + where following an edge labelled by a pattern P means "assuming the value I + am matching on is filtered by [P] on the column I am currently looking at, + then the following submatrix is still reachable". + + Notice that at any point of that tree, if the first column of a matrix is + incoherent, then the branch leading to it can only be taken if the scrutinee + is ill-typed. + In the example above the only case where we have a matrix with an incoherent + first column is when we consider [t1, t2, a] to be [U, S, ...]. However such + a value would be ill-typed, so we can never actually get there. + + Checking the first column at each step of the recursion and making the + concious decision of "aborting" the algorithm whenever the first column + becomes incoherent, allows us to retain the initial assumption in later + stages of the algorithms. + + --- + + N.B. two patterns can be considered coherent even though they might not be of + the same type. + + That's in part because we only care about the "head" of patterns and leave + checking coherence of subpatterns for the next steps of the algorithm: + ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples + of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1). + + But also because it can be hard/costly to determine exactly whether two + patterns are of the same type or not (eg. in the example above with _ and S, + but see also the module [Coherence_illustration] in + testsuite/tests/basic-more/robustmatch.ml). + + For the moment our weak, loosely-syntactic, coherence check seems to be + enough and we leave it to each user to consider (and document!) what happens + when an "incoherence" is not detected by this check. +*) + +let simplify_head_pat p k = + let rec simplify_head_pat p k = + match p.pat_desc with + | Tpat_alias (p, _, _) -> simplify_head_pat p k + | Tpat_var (_, _) -> omega :: k + | Tpat_or (p1, p2, _) -> simplify_head_pat p1 (simplify_head_pat p2 k) + | _ -> p :: k + in + simplify_head_pat p k + +let rec simplified_first_col = function + | [] -> [] + | [] :: _ -> assert false (* the rows are non-empty! *) + | (p :: _) :: rows -> simplify_head_pat p (simplified_first_col rows) + +(* Given the simplified first column of a matrix, this function first looks for + a "discriminating" pattern on that column (i.e. a non-omega one) and then + check that every other head pattern in the column is coherent with that one. +*) +let all_coherent column = + let coherent_heads hp1 hp2 = + match (hp1.pat_desc, hp2.pat_desc) with + | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _ + | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) -> + assert false + | Tpat_construct (_, c, _), Tpat_construct (_, c', _) -> + c.cstr_consts = c'.cstr_consts && c.cstr_nonconsts = c'.cstr_nonconsts + | Tpat_constant c1, Tpat_constant c2 -> ( + match (c1, c2) with + | Const_char _, Const_char _ + | Const_int _, Const_int _ + | Const_int32 _, Const_int32 _ + | Const_int64 _, Const_int64 _ + | Const_bigint _, Const_bigint _ + | Const_float _, Const_float _ + | Const_string _, Const_string _ -> + true + | ( ( Const_char _ | Const_int _ | Const_int32 _ | Const_int64 _ + | Const_bigint _ | Const_float _ | Const_string _ ), + _ ) -> + false) + | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 + | ( Tpat_record ((_, lbl1, _, _) :: _, _), + Tpat_record ((_, lbl2, _, _) :: _, _) ) -> + Array.length lbl1.lbl_all = Array.length lbl2.lbl_all + | Tpat_any, _ + | _, Tpat_any + | Tpat_record ([], _), Tpat_record (_, _) + | Tpat_record (_, _), Tpat_record ([], _) + | Tpat_variant _, Tpat_variant _ + | Tpat_array _, Tpat_array _ -> + true + | _, _ -> false + in + match + List.find + (fun head_pat -> + match head_pat.pat_desc with + | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false + | Tpat_any -> false + | _ -> true) + column + with + | exception Not_found -> + (* only omegas on the column: the column is coherent. *) + true + | discr_pat -> List.for_all (coherent_heads discr_pat) column + +let first_column simplified_matrix = List.map fst simplified_matrix + +(***********************) +(* Compatibility check *) +(***********************) + +(* Patterns p and q compatible means: + there exists value V that matches both, However.... + + The case of extension types is dubious, as constructor rebind permits + that different constructors are the same (and are thus compatible). + + Compilation must take this into account, consider: + + type t = .. + type t += A|B + type t += C=A + + let f x y = match x,y with + | true,A -> '1' + | _,C -> '2' + | false,A -> '3' + | _,_ -> '_' + + As C is bound to A the value of f false A is '2' (and not '3' as it would + be in the absence of rebinding). + + Not considering rebinding, patterns "false,A" and "_,C" are incompatible + and the compiler can swap the second and third clause, resulting in the + (more efficiently compiled) matching + + match x,y with + | true,A -> '1' + | false,A -> '3' + | _,C -> '2' + | _,_ -> '_' + + This is not correct: when C is bound to A, "f false A" returns '2' (not '3') + + + However, diagnostics do not take constructor rebinding into account. + Notice, that due to module abstraction constructor rebinding is hidden. + + module X : sig type t = .. type t += A|B end = struct + type t = .. + type t += A + type t += B=A + end + + open X + + let f x = match x with + | A -> '1' + | B -> '2' + | _ -> '_' + + The second clause above will NOT (and cannot) be flagged as useless. + + Finally, there are two compatibility fonction + compat p q ---> 'syntactic compatibility, used for diagnostics. + may_compat p q ---> a safe approximation of possible compat, + for compilation +*) + +let is_absent tag row = Btype.row_field tag !row = Rabsent + +let is_absent_pat p = + match p.pat_desc with + | Tpat_variant (tag, _, row) -> is_absent tag row + | _ -> false + +let const_compare x y = + match (x, y) with + | Const_float f1, Const_float f2 -> + compare (float_of_string f1) (float_of_string f2) + | Const_bigint (s1, b1), Const_bigint (s2, b2) -> + Bigint_utils.compare (s1, b1) (s2, b2) + | Const_string (s1, _), Const_string (s2, _) -> String.compare s1 s2 + | _, _ -> compare x y + +let records_args l1 l2 = + (* Invariant: fields are already sorted by Typecore.type_label_a_list *) + let rec combine r1 r2 l1 l2 = + match (l1, l2) with + | [], [] -> (List.rev r1, List.rev r2) + | [], (_, _, p2, _) :: rem2 -> combine (omega :: r1) (p2 :: r2) [] rem2 + | (_, _, p1, _) :: rem1, [] -> combine (p1 :: r1) (omega :: r2) rem1 [] + | (_, lbl1, p1, _) :: rem1, (_, lbl2, p2, _) :: rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + combine (p1 :: r1) (omega :: r2) rem1 l2 + else if lbl1.lbl_pos > lbl2.lbl_pos then + combine (omega :: r1) (p2 :: r2) l1 rem2 + else (* same label on both sides *) + combine (p1 :: r1) (p2 :: r2) rem1 rem2 + in + combine [] [] l1 l2 + +module Compat = struct + type eq_cd = constructor_description -> constructor_description -> bool + + let rec compat ~(equal_cd : eq_cd) p q = + match (p.pat_desc, q.pat_desc) with + (* Variables match any value *) + | (Tpat_any | Tpat_var _), _ | _, (Tpat_any | Tpat_var _) -> true + (* Structural induction *) + | Tpat_alias (p, _, _), _ -> compat ~equal_cd p q + | _, Tpat_alias (q, _, _) -> compat ~equal_cd p q + | Tpat_or (p1, p2, _), _ -> compat ~equal_cd p1 q || compat ~equal_cd p2 q + | _, Tpat_or (q1, q2, _) -> compat ~equal_cd p q1 || compat ~equal_cd p q2 + (* Constructors, with special case for extension *) + | Tpat_construct (_, c1, ps1), Tpat_construct (_, c2, ps2) -> + equal_cd c1 c2 && compats ~equal_cd ps1 ps2 + (* More standard stuff *) + | Tpat_variant (l1, op1, _), Tpat_variant (l2, op2, _) -> + l1 = l2 && ocompat ~equal_cd op1 op2 + | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 + | Tpat_tuple ps, Tpat_tuple qs -> compats ~equal_cd ps qs + | Tpat_record (l1, _), Tpat_record (l2, _) -> + let ps, qs = records_args l1 l2 in + compats ~equal_cd ps qs + | Tpat_array ps, Tpat_array qs -> + List.length ps = List.length qs && compats ~equal_cd ps qs + | _, _ -> false + + and ocompat ~equal_cd op oq = + match (op, oq) with + | None, None -> true + | Some p, Some q -> compat ~equal_cd p q + | None, Some _ | Some _, None -> false + + and compats ~equal_cd ps qs = + match (ps, qs) with + | [], [] -> true + | p :: ps, q :: qs -> compat ~equal_cd p q && compats ~equal_cd ps qs + | _, _ -> false +end + +let equal_tag c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag + +let compat = Compat.compat ~equal_cd:equal_tag + +and compats = Compat.compats ~equal_cd:equal_tag + +(* Due to (potential) rebinding, two extension constructors + of the same arity type may equal *) + +exception Empty (* Empty pattern *) + +(****************************************) +(* Utilities for retrieving type paths *) +(****************************************) + +(* May need a clean copy, cf. PR#4745 *) +let clean_copy ty = + if ty.level = Btype.generic_level then ty + else Subst.type_expr Subst.identity ty + +let get_type_path ty tenv = + let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in + match ty.desc with + | Tconstr (path, _, _) -> path + | _ -> fatal_error "Parmatch.get_type_path" + +(*************************************) +(* Values as patterns pretty printer *) +(*************************************) + +let print_res_pat : (Typedtree.pattern -> string) ref = + ref (fun _ -> assert false) + +open Format + +let is_cons = function + | {cstr_name = "::"} -> true + | _ -> false + +let pretty_const c = + match c with + | Const_int i -> Printf.sprintf "%d" i + | Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) + | Const_string (s, _) -> Printf.sprintf "%S" s + | Const_float f -> Printf.sprintf "%s" f + | Const_int32 i -> Printf.sprintf "%ldl" i + | Const_int64 i -> Printf.sprintf "%LdL" i + | Const_bigint (sign, i) -> + Printf.sprintf "%s" (Bigint_utils.to_string sign i) + +let rec pretty_val ppf v = + match v.pat_extra with + | (cstr, _loc, _attrs) :: rem -> ( + match cstr with + | Tpat_unpack -> + fprintf ppf "@[(module %a)@]" pretty_val {v with pat_extra = rem} + | Tpat_constraint _ -> + fprintf ppf "@[(%a : _)@]" pretty_val {v with pat_extra = rem} + | Tpat_type _ -> + fprintf ppf "@[(# %a)@]" pretty_val {v with pat_extra = rem} + | Tpat_open _ -> + fprintf ppf "@[(# %a)@]" pretty_val {v with pat_extra = rem}) + | [] -> ( + match v.pat_desc with + | Tpat_any -> fprintf ppf "_" + | Tpat_var (x, _) -> fprintf ppf "%s" (Ident.name x) + | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) + | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs + | Tpat_construct (_, cstr, []) -> fprintf ppf "%s" cstr.cstr_name + | Tpat_construct (_, cstr, [w]) -> + fprintf ppf "@[<2>%s(%a)@]" cstr.cstr_name pretty_arg w + | Tpat_construct (_, cstr, vs) -> ( + let name = cstr.cstr_name in + match (name, vs) with + | "::", [v1; v2] -> fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 + | _ -> fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs) + | Tpat_variant (l, None, _) -> fprintf ppf "#%s" l + | Tpat_variant (l, Some w, _) -> fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w + | Tpat_record (lvs, _) -> ( + let filtered_lvs = + Ext_list.filter lvs (function + | _, _, {pat_desc = Tpat_any}, _ -> false (* do not show lbl=_ *) + | _ -> true) + in + match filtered_lvs with + | [] -> fprintf ppf "_" + | (_, _lbl, _, _) :: _q -> + let elision_mark _ = () in + fprintf ppf "@[{%a%t}@]" pretty_lvals filtered_lvs elision_mark) + | Tpat_array vs -> fprintf ppf "@[[%a]@]" (pretty_vals ",") vs + | Tpat_alias (v, x, _) -> + fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x + | Tpat_or (v, w, _) -> fprintf ppf "@[%a | @,%a@]" pretty_or v pretty_or w) + +and pretty_car ppf v = + match v.pat_desc with + | Tpat_construct (_, cstr, [_; _]) when is_cons cstr -> + fprintf ppf "(%a)" pretty_val v + | _ -> pretty_val ppf v + +and pretty_cdr ppf v = + match v.pat_desc with + | Tpat_construct (_, cstr, [v1; v2]) when is_cons cstr -> + fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 + | _ -> pretty_val ppf v + +and pretty_arg ppf v = + match v.pat_desc with + | Tpat_construct (_, _, _ :: _) | Tpat_variant (_, Some _, _) -> + fprintf ppf "(%a)" pretty_val v + | _ -> pretty_val ppf v + +and pretty_or ppf v = + match v.pat_desc with + | Tpat_or (v, w, _) -> fprintf ppf "%a | @,%a" pretty_or v pretty_or w + | _ -> pretty_val ppf v + +and pretty_vals sep ppf = function + | [] -> () + | [v] -> pretty_val ppf v + | v :: vs -> fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs + +and pretty_lvals ppf = function + | [] -> () + | [(_, lbl, v, _)] -> fprintf ppf "%s: %a" lbl.lbl_name pretty_val v + | (_, lbl, v, _) :: rest -> + fprintf ppf "%s: %a,@ %a" lbl.lbl_name pretty_val v pretty_lvals rest + +let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v + +let pretty_pat p = + top_pretty Format.str_formatter p; + prerr_string (Format.flush_str_formatter ()) + +type matrix = pattern list list + +let pretty_line ps = + List.iter + (fun p -> + top_pretty Format.str_formatter p; + prerr_string " <"; + prerr_string (Format.flush_str_formatter ()); + prerr_string ">") + ps + +let pretty_matrix (pss : matrix) = + prerr_endline "begin matrix"; + List.iter + (fun ps -> + pretty_line ps; + prerr_endline "") + pss; + prerr_endline "end matrix" + +(****************************) +(* Utilities for matching *) +(****************************) + +(* Check top matching *) +let simple_match p1 p2 = + match (p1.pat_desc, p2.pat_desc) with + | Tpat_construct (_, c1, _), Tpat_construct (_, c2, _) -> + Types.equal_tag c1.cstr_tag c2.cstr_tag + | Tpat_variant (l1, _, _), Tpat_variant (l2, _, _) -> l1 = l2 + | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 + | Tpat_record _, Tpat_record _ -> true + | Tpat_tuple p1s, Tpat_tuple p2s | Tpat_array p1s, Tpat_array p2s -> + List.length p1s = List.length p2s + | _, (Tpat_any | Tpat_var _) -> true + | _, _ -> false + +(* extract record fields as a whole *) +let record_arg p = + match p.pat_desc with + | Tpat_any -> [] + | Tpat_record (args, _) -> args + | _ -> fatal_error "Parmatch.as_record" + +(* Raise Not_found when pos is not present in arg *) +let get_field pos arg = + let _, _, p, _ = List.find (fun (_, lbl, _, _) -> pos = lbl.lbl_pos) arg in + p + +let extract_fields omegas arg = + List.map + (fun (_, lbl, _, _) -> + try get_field lbl.lbl_pos arg with Not_found -> omega) + omegas + +let all_record_args lbls = + match lbls with + | (_, {lbl_all}, _, opt) :: _ -> + let t = + Array.map + (fun lbl -> (mknoloc (Longident.Lident "?temp?"), lbl, omega, opt)) + lbl_all + in + List.iter + (fun ((id, lbl, pat, o) as x) -> + let lbl_is_optional () = + match lbl.lbl_repres with + | Record_inlined _ -> false + | _ -> lbl.lbl_optional + in + let x = + match pat.pat_desc with + | Tpat_construct + ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")}, + _, + [({pat_desc = Tpat_constant _} as c)] ) + when lbl_is_optional () -> + (id, lbl, c, o) + | Tpat_construct + ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")}, + _, + [({pat_desc = Tpat_construct (_, cd, _)} as pat_construct)] ) + when lbl_is_optional () -> ( + let cdecl = + Ast_untagged_variants + .constructor_declaration_from_constructor_description + ~env:pat.pat_env cd + in + match cdecl with + | None -> x + | Some cstr -> ( + match + Ast_untagged_variants.get_block_type ~env:pat.pat_env cstr + with + | Some block_type + when not + (Ast_untagged_variants.block_type_can_be_undefined + block_type) -> + (id, lbl, pat_construct, o) + | _ -> x)) + | _ -> x + in + t.(lbl.lbl_pos) <- x) + lbls; + Array.to_list t + | _ -> fatal_error "Parmatch.all_record_args" + +(* Build argument list when p2 >= p1, where p1 is a simple pattern *) +let rec simple_match_args p1 p2 = + match p2.pat_desc with + | Tpat_alias (p2, _, _) -> simple_match_args p1 p2 + | Tpat_construct (_, _, args) -> args + | Tpat_variant (_, Some arg, _) -> [arg] + | Tpat_tuple args -> args + | Tpat_record (args, _) -> extract_fields (record_arg p1) args + | Tpat_array args -> args + | Tpat_any | Tpat_var _ -> ( + match p1.pat_desc with + | Tpat_construct (_, _, args) -> omega_list args + | Tpat_variant (_, Some _, _) -> [omega] + | Tpat_tuple args -> omega_list args + | Tpat_record (args, _) -> omega_list args + | Tpat_array args -> omega_list args + | _ -> []) + | _ -> [] + +(* + Normalize a pattern -> + all arguments are omega (simple pattern) and no more variables +*) + +let rec normalize_pat q = + match q.pat_desc with + | Tpat_any | Tpat_constant _ -> q + | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env + | Tpat_alias (p, _, _) -> normalize_pat p + | Tpat_tuple args -> + make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env + | Tpat_construct (lid, c, args) -> + make_pat (Tpat_construct (lid, c, omega_list args)) q.pat_type q.pat_env + | Tpat_variant (l, arg, row) -> + make_pat + (Tpat_variant (l, may_map (fun _ -> omega) arg, row)) + q.pat_type q.pat_env + | Tpat_array args -> + make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env + | Tpat_record (largs, closed) -> + make_pat + (Tpat_record + ( List.map (fun (lid, lbl, _, opt) -> (lid, lbl, omega, opt)) largs, + closed )) + q.pat_type q.pat_env + | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" + +(* + Build normalized (cf. supra) discriminating pattern, + in the non-data type case +*) + +let discr_pat q pss = + let rec acc_pat acc pss = + match pss with + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + acc_pat acc ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + acc_pat acc ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> acc_pat acc pss + | (({pat_desc = Tpat_tuple _} as p) :: _) :: _ -> normalize_pat p + | (({pat_desc = Tpat_record (largs, closed)} as p) :: _) :: pss -> + let new_omegas = + List.fold_right + (fun (lid, lbl, _, opt) r -> + try + let _ = get_field lbl.lbl_pos r in + r + with Not_found -> (lid, lbl, omega, opt) :: r) + largs (record_arg acc) + in + acc_pat + (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env) + pss + | _ -> acc + in + + match normalize_pat q with + | {pat_desc = Tpat_any | Tpat_record _} as q -> acc_pat q pss + | q -> q + +(* + In case a matching value is found, set actual arguments + of the matching pattern. +*) + +let rec read_args xs r = + match (xs, r) with + | [], _ -> ([], r) + | _ :: xs, arg :: rest -> + let args, rest = read_args xs rest in + (arg :: args, rest) + | _, _ -> fatal_error "Parmatch.read_args" + +let do_set_args erase_mutable q r = + match q with + | {pat_desc = Tpat_tuple omegas} -> + let args, rest = read_args omegas r in + make_pat (Tpat_tuple args) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_record (omegas, closed)} -> + let args, rest = read_args omegas r in + make_pat + (Tpat_record + ( List.map2 + (fun (lid, lbl, _, opt) arg -> + if + erase_mutable + && + match lbl.lbl_mut with + | Mutable -> true + | Immutable -> false + then (lid, lbl, omega, opt) + else (lid, lbl, arg, opt)) + omegas args, + closed )) + q.pat_type q.pat_env + :: rest + | {pat_desc = Tpat_construct (lid, c, omegas)} -> + let args, rest = read_args omegas r in + make_pat (Tpat_construct (lid, c, args)) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_variant (l, omega, row)} -> + let arg, rest = + match (omega, r) with + | Some _, a :: r -> (Some a, r) + | None, r -> (None, r) + | _ -> assert false + in + make_pat (Tpat_variant (l, arg, row)) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_array omegas} -> + let args, rest = read_args omegas r in + make_pat (Tpat_array args) q.pat_type q.pat_env :: rest + | {pat_desc = Tpat_constant _ | Tpat_any} -> + q :: r (* case any is used in matching.ml *) + | _ -> fatal_error "Parmatch.set_args" + +let set_args q r = do_set_args false q r + +and set_args_erase_mutable q r = do_set_args true q r + +(* filter pss according to pattern q *) +let filter_one q pss = + let rec filter_rec = function + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_rec ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_rec ((p1 :: ps) :: (p2 :: ps) :: pss) + | (p :: ps) :: pss -> + if simple_match q p then (simple_match_args q p @ ps) :: filter_rec pss + else filter_rec pss + | _ -> [] + in + filter_rec pss + +(* + Filter pss in the ``extra case''. This applies : + - According to an extra constructor (datatype case, non-complete signature). + - According to anything (all-variables case). +*) +let filter_extra pss = + let rec filter_rec = function + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_rec ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_rec ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: qs) :: pss -> qs :: filter_rec pss + | _ :: pss -> filter_rec pss + | [] -> [] + in + filter_rec pss + +(* + Pattern p0 is the discriminating pattern, + returns [(q0,pss0) ; ... ; (qn,pssn)] + where the qi's are simple patterns and the pssi's are + matched matrices. + + NOTES + * (qi,[]) is impossible. + * In the case when matching is useless (all-variable case), + returns [] +*) + +let filter_all pat0 pss = + let rec insert q qs env = + match env with + | [] -> + let q0 = normalize_pat q in + [(q0, [simple_match_args q0 q @ qs])] + | ((q0, pss) as c) :: env -> + if simple_match q0 q then + (q0, (simple_match_args q0 q @ qs) :: pss) :: env + else c :: insert q qs env + in + + let rec filter_rec env = function + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_rec env ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_rec env ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: _) :: pss -> filter_rec env pss + | (p :: ps) :: pss -> filter_rec (insert p ps env) pss + | _ -> env + and filter_omega env = function + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + filter_omega env ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + filter_omega env ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: ps) :: pss -> + filter_omega + (List.map + (fun (q, qss) -> (q, (simple_match_args q omega @ ps) :: qss)) + env) + pss + | _ :: pss -> filter_omega env pss + | [] -> env + in + + filter_omega + (filter_rec + (match pat0.pat_desc with + | Tpat_record _ | Tpat_tuple _ -> [(pat0, [])] + | _ -> []) + pss) + pss + +(* Variant related functions *) + +let rec set_last a = function + | [] -> [] + | [_] -> [a] + | x :: l -> x :: set_last a l + +(* mark constructor lines for failure when they are incomplete *) +let rec mark_partial = function + | ({pat_desc = Tpat_alias (p, _, _)} :: ps) :: pss -> + mark_partial ((p :: ps) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps) :: pss -> + mark_partial ((p1 :: ps) :: (p2 :: ps) :: pss) + | ({pat_desc = Tpat_any | Tpat_var _} :: _ as ps) :: pss -> + ps :: mark_partial pss + | ps :: pss -> set_last zero ps :: mark_partial pss + | [] -> [] + +let close_variant env row = + let row = Btype.row_repr row in + let nm = + List.fold_left + (fun nm (_tag, f) -> + match Btype.row_field_repr f with + | Reither (_, _, false, e) -> + (* m=false means that this tag is not explicitly matched *) + Btype.set_row_field e Rabsent; + None + | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) + row.row_name row.row_fields + in + if (not row.row_closed) || nm != row.row_name then + (* this unification cannot fail *) + Ctype.unify env row.row_more + (Btype.newgenty + (Tvariant + { + row with + row_fields = []; + row_more = Btype.newgenvar (); + row_closed = true; + row_name = nm; + })) + +let row_of_pat pat = + match Ctype.expand_head pat.pat_env pat.pat_type with + | {desc = Tvariant row} -> Btype.row_repr row + | _ -> assert false + +(* + Check whether the first column of env makes up a complete signature or + not. +*) + +let full_match closing env = + match env with + | ({pat_desc = Tpat_construct (_, c, _)}, _) :: _ -> + if c.cstr_consts < 0 then false (* extensions *) + else List.length env = c.cstr_consts + c.cstr_nonconsts + | (({pat_desc = Tpat_variant _} as p), _) :: _ -> + let fields = + List.map + (function + | {pat_desc = Tpat_variant (tag, _, _)}, _ -> tag + | _ -> assert false) + env + in + let row = row_of_pat p in + if closing && not (Btype.row_fixed row) then + (* closing=true, we are considering the variant as closed *) + List.for_all + (fun (tag, f) -> + match Btype.row_field_repr f with + | Rabsent | Reither (_, _, false, _) -> true + | Reither (_, _, true, _) + (* m=true, do not discard matched tags, rather warn *) + | Rpresent _ -> + List.mem tag fields) + row.row_fields + else + row.row_closed + && List.for_all + (fun (tag, f) -> + Btype.row_field_repr f = Rabsent || List.mem tag fields) + row.row_fields + | ({pat_desc = Tpat_constant _}, _) :: _ -> false + | ({pat_desc = Tpat_tuple _}, _) :: _ -> true + | ({pat_desc = Tpat_record _}, _) :: _ -> true + | ({pat_desc = Tpat_array _}, _) :: _ -> false + | ({pat_desc = Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _}, _) :: _ | [] + -> + assert false + +(* Written as a non-fragile matching, PR#7451 originated from a fragile matching below. *) +let should_extend ext env = + match ext with + | None -> false + | Some ext -> ( + match env with + | [] -> assert false + | (p, _) :: _ -> ( + match p.pat_desc with + | Tpat_construct + (_, {cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed}, _) -> + let path = get_type_path p.pat_type p.pat_env in + Path.same path ext + | Tpat_construct (_, {cstr_tag = Cstr_extension _}, _) -> false + | Tpat_constant _ | Tpat_tuple _ | Tpat_variant _ | Tpat_record _ + | Tpat_array _ -> + false + | Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false)) + +module ConstructorTagHashtbl = Hashtbl.Make (struct + type t = Types.constructor_tag + let hash = Hashtbl.hash + let equal = Types.equal_tag +end) + +(* complement constructor tags *) +let complete_tags nconsts nconstrs tags = + let seen_const = Array.make nconsts false + and seen_constr = Array.make nconstrs false in + List.iter + (function + | Cstr_constant i -> seen_const.(i) <- true + | Cstr_block i -> seen_constr.(i) <- true + | _ -> assert false) + tags; + let r = ConstructorTagHashtbl.create (nconsts + nconstrs) in + for i = 0 to nconsts - 1 do + if not seen_const.(i) then ConstructorTagHashtbl.add r (Cstr_constant i) () + done; + for i = 0 to nconstrs - 1 do + if not seen_constr.(i) then ConstructorTagHashtbl.add r (Cstr_block i) () + done; + r + +(* build a pattern from a constructor list *) +let pat_of_constr ex_pat cstr = + { + ex_pat with + pat_desc = + Tpat_construct + ( mknoloc (Longident.Lident "?pat_of_constr?"), + cstr, + omegas cstr.cstr_arity ); + } + +let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env + +let rec orify_many = function + | [] -> assert false + | [x] -> x + | x :: xs -> orify x (orify_many xs) + +let pat_of_constrs ex_pat cstrs = + if cstrs = [] then raise Empty + else orify_many (List.map (pat_of_constr ex_pat) cstrs) + +let pats_of_type ?(always = false) env ty = + let ty' = Ctype.expand_head env ty in + match ty'.desc with + | Tconstr (path, _, _) -> ( + try + match (Env.find_type path env).type_kind with + | Type_variant cl + when always + || List.length cl = 1 + || List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> + let cstrs = fst (Env.find_type_descrs path env) in + List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs + | Type_record _ -> + let labels = snd (Env.find_type_descrs path env) in + let fields = + List.map + (fun ld -> + (mknoloc (Longident.Lident "?pat_of_label?"), ld, omega, false)) + labels + in + [make_pat (Tpat_record (fields, Closed)) ty env] + | _ -> [omega] + with Not_found -> [omega]) + | Ttuple tl -> [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] + | _ -> [omega] + +let rec get_variant_constructors env ty = + match (Ctype.repr ty).desc with + | Tconstr (path, _, _) -> ( + try + match Env.find_type path env with + | {type_kind = Type_variant _} -> fst (Env.find_type_descrs path env) + | {type_manifest = Some _} -> + get_variant_constructors env + (Ctype.expand_head_once env (clean_copy ty)) + | _ -> fatal_error "Parmatch.get_variant_constructors" + with Not_found -> fatal_error "Parmatch.get_variant_constructors") + | _ -> fatal_error "Parmatch.get_variant_constructors" + +(* Sends back a pattern that complements constructor tags all_tag *) +let complete_constrs p all_tags = + let c = + match p.pat_desc with + | Tpat_construct (_, c, _) -> c + | _ -> assert false + in + let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in + let constrs = get_variant_constructors p.pat_env c.cstr_res in + let others = + Ext_list.filter constrs (fun cnstr -> + ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) + in + let const, nonconst = + List.partition (fun cnstr -> cnstr.cstr_arity = 0) others + in + const @ nonconst + +let build_other_constrs env p = + match p.pat_desc with + | Tpat_construct (_, {cstr_tag = Cstr_constant _ | Cstr_block _}, _) -> + let get_tag = function + | {pat_desc = Tpat_construct (_, c, _)} -> c.cstr_tag + | _ -> fatal_error "Parmatch.get_tag" + in + let all_tags = List.map (fun (p, _) -> get_tag p) env in + pat_of_constrs p (complete_constrs p all_tags) + | _ -> extra_pat + +(* Auxiliary for build_other *) + +let build_other_constant proj make first next p env = + let all = List.map (fun (p, _) -> proj p.pat_desc) env in + let rec try_const i = + if List.mem i all then try_const (next i) + else make_pat (make i) p.pat_type p.pat_env + in + try_const first + +(* + Builds a pattern that is incompatible with all patterns in + in the first column of env +*) + +let some_other_tag = "" + +let build_other ext env : Typedtree.pattern = + match env with + | ({pat_desc = Tpat_construct (lid, {cstr_tag = Cstr_extension _}, _)}, _) + :: _ -> + (* let c = {c with cstr_name = "*extension*"} in *) + (* PR#7330 *) + make_pat + (Tpat_var (Ident.create "*extension*", {lid with txt = "*extension*"})) + Ctype.none Env.empty + | (({pat_desc = Tpat_construct _} as p), _) :: _ -> ( + match ext with + | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> + extra_pat + | _ -> build_other_constrs env p) + | (({pat_desc = Tpat_variant (_, _, r)} as p), _) :: _ -> ( + let tags = + List.map + (function + | {pat_desc = Tpat_variant (tag, _, _)}, _ -> tag + | _ -> assert false) + env + in + let row = row_of_pat p in + let make_other_pat tag const = + let arg = if const then None else Some omega in + make_pat (Tpat_variant (tag, arg, r)) p.pat_type p.pat_env + in + match + List.fold_left + (fun others (tag, f) -> + if List.mem tag tags then others + else + match Btype.row_field_repr f with + | Rabsent (* | Reither _ *) -> others + (* This one is called after erasing pattern info *) + | Reither (c, _, _, _) -> make_other_pat tag c :: others + | Rpresent arg -> make_other_pat tag (arg = None) :: others) + [] row.row_fields + with + | [] -> make_other_pat some_other_tag true + | pat :: other_pats -> + List.fold_left + (fun p_res pat -> + make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) + pat other_pats) + | (({pat_desc = Tpat_constant (Const_int _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_int i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_int i)) + 0 succ p env + | (({pat_desc = Tpat_constant (Const_char _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_char i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_char i)) + 0 succ p env + | (({pat_desc = Tpat_constant (Const_int32 _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_int32 i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_int32 i)) + 0l Int32.succ p env + | (({pat_desc = Tpat_constant (Const_int64 _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_int64 i) -> i + | _ -> assert false) + (function + | i -> Tpat_constant (Const_int64 i)) + 0L Int64.succ p env + | (({pat_desc = Tpat_constant (Const_bigint _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_bigint (sign, i)) -> + String.length (Bigint_utils.to_string sign i) + | _ -> assert false) + (function + | i -> Tpat_constant (Const_bigint (true, string_of_int i))) + 0 succ p env + | (({pat_desc = Tpat_constant (Const_string _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_string (s, _)) -> String.length s + | _ -> assert false) + (function + | i -> Tpat_constant (Const_string (String.make i '*', None))) + 0 succ p env + | (({pat_desc = Tpat_constant (Const_float _)} as p), _) :: _ -> + build_other_constant + (function + | Tpat_constant (Const_float f) -> float_of_string f + | _ -> assert false) + (function + | f -> Tpat_constant (Const_float (string_of_float f))) + 0.0 + (fun f -> f +. 1.0) + p env + | (({pat_desc = Tpat_array _} as p), _) :: _ -> + let all_lengths = + List.map + (fun (p, _) -> + match p.pat_desc with + | Tpat_array args -> List.length args + | _ -> assert false) + env + in + let rec try_arrays l = + if List.mem l all_lengths then try_arrays (l + 1) + else make_pat (Tpat_array (omegas l)) p.pat_type p.pat_env + in + try_arrays 0 + | [] -> omega + | _ -> omega + +(* + Core function : + Is the last row of pattern matrix pss + qs satisfiable ? + That is : + Does there exists at least one value vector, es such that : + 1- for all ps in pss ps # es (ps and es are not compatible) + 2- qs <= es (es matches qs) +*) + +let rec has_instance p = + match p.pat_desc with + | Tpat_variant (l, _, r) when is_absent l r -> false + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> true + | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> has_instance p + | Tpat_or (p1, p2, _) -> has_instance p1 || has_instance p2 + | Tpat_construct (_, _, ps) | Tpat_tuple ps | Tpat_array ps -> + has_instances ps + | Tpat_record (lps, _) -> has_instances (List.map (fun (_, _, x, _) -> x) lps) + +and has_instances = function + | [] -> true + | q :: rem -> has_instance q && has_instances rem + +(* + In two places in the following function, we check the coherence of the first + column of (pss + qs). + If it is incoherent, then we exit early saying that (pss + qs) is not + satisfiable (which is equivalent to saying "oh, we shouldn't have considered + that branch, no good result came come from here"). + + But what happens if we have a coherent but ill-typed column? + - we might end up returning [false], which is equivalent to noticing the + incompatibility: clearly this is fine. + - if we end up returning [true] then we're saying that [qs] is useful while + it is not. This is sad but not the end of the world, we're just allowing dead + code to survive. +*) +let rec satisfiable pss qs = + match pss with + | [] -> has_instances qs + | _ -> ( + match qs with + | [] -> false + | {pat_desc = Tpat_or (q1, q2, _)} :: qs -> + satisfiable pss (q1 :: qs) || satisfiable pss (q2 :: qs) + | {pat_desc = Tpat_alias (q, _, _)} :: qs -> satisfiable pss (q :: qs) + | {pat_desc = Tpat_any | Tpat_var _} :: qs -> ( + if not (all_coherent (simplified_first_col pss)) then false + else + let q0 = discr_pat omega pss in + match filter_all q0 pss with + (* first column of pss is made of variables only *) + | [] -> satisfiable (filter_extra pss) qs + | constrs -> + if full_match false constrs then + List.exists + (fun (p, pss) -> + (not (is_absent_pat p)) + && satisfiable pss (simple_match_args p omega @ qs)) + constrs + else satisfiable (filter_extra pss) qs) + | {pat_desc = Tpat_variant (l, _, r)} :: _ when is_absent l r -> false + | q :: qs -> + if not (all_coherent (q :: simplified_first_col pss)) then false + else + let q0 = discr_pat q pss in + satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)) + +(* Also return the remaining cases, to enable GADT handling + + For considerations regarding the coherence check, see the comment on + [satisfiable] above. *) +let rec satisfiables pss qs = + match pss with + | [] -> if has_instances qs then [qs] else [] + | _ -> ( + match qs with + | [] -> [] + | {pat_desc = Tpat_or (q1, q2, _)} :: qs -> + satisfiables pss (q1 :: qs) @ satisfiables pss (q2 :: qs) + | {pat_desc = Tpat_alias (q, _, _)} :: qs -> satisfiables pss (q :: qs) + | {pat_desc = Tpat_any | Tpat_var _} :: qs -> ( + if not (all_coherent (simplified_first_col pss)) then [] + else + let q0 = discr_pat omega pss in + let wild p = + List.map (fun qs -> p :: qs) (satisfiables (filter_extra pss) qs) + in + match filter_all q0 pss with + (* first column of pss is made of variables only *) + | [] -> wild omega + | (p, _) :: _ as constrs -> ( + let for_constrs () = + List.flatten + (List.map + (fun (p, pss) -> + if is_absent_pat p then [] + else + List.map (set_args p) + (satisfiables pss (simple_match_args p omega @ qs))) + constrs) + in + if full_match false constrs then for_constrs () + else + match p.pat_desc with + | Tpat_construct _ -> + (* activate this code for checking non-gadt constructors *) + wild (build_other_constrs constrs p) @ for_constrs () + | _ -> wild omega)) + | {pat_desc = Tpat_variant (l, _, r)} :: _ when is_absent l r -> [] + | q :: qs -> + if not (all_coherent (q :: simplified_first_col pss)) then [] + else + let q0 = discr_pat q pss in + List.map (set_args q0) + (satisfiables (filter_one q0 pss) (simple_match_args q0 q @ qs))) + +(* + Now another satisfiable function that additionally + supplies an example of a matching value. + + This function should be called for exhaustiveness check only. +*) + +type 'a result = + | Rnone (* No matching value *) + | Rsome of 'a (* This matching value *) + +(* +let rec try_many f = function + | [] -> Rnone + | (p,pss)::rest -> + match f (p,pss) with + | Rnone -> try_many f rest + | r -> r +*) + +let rappend r1 r2 = + match (r1, r2) with + | Rnone, _ -> r2 + | _, Rnone -> r1 + | Rsome l1, Rsome l2 -> Rsome (l1 @ l2) + +let rec try_many_gadt f = function + | [] -> Rnone + | (p, pss) :: rest -> rappend (f (p, pss)) (try_many_gadt f rest) + +(* +let rec exhaust ext pss n = match pss with +| [] -> Rsome (omegas n) +| []::_ -> Rnone +| pss -> + let q0 = discr_pat omega pss in + begin match filter_all q0 pss with + (* first column of pss is made of variables only *) + | [] -> + begin match exhaust ext (filter_extra pss) (n-1) with + | Rsome r -> Rsome (q0::r) + | r -> r + end + | constrs -> + let try_non_omega (p,pss) = + if is_absent_pat p then + Rnone + else + match + exhaust + ext pss (List.length (simple_match_args p omega) + n - 1) + with + | Rsome r -> Rsome (set_args p r) + | r -> r in + if + full_match true false constrs && not (should_extend ext constrs) + then + try_many try_non_omega constrs + else + (* + D = filter_extra pss is the default matrix + as it is included in pss, one can avoid + recursive calls on specialized matrices, + Essentially : + * D exhaustive => pss exhaustive + * D non-exhaustive => we have a non-filtered value + *) + let r = exhaust ext (filter_extra pss) (n-1) in + match r with + | Rnone -> Rnone + | Rsome r -> + try + Rsome (build_other ext constrs::r) + with + (* cannot occur, since constructors don't make a full signature *) + | Empty -> fatal_error "Parmatch.exhaust" + end + +let combinations f lst lst' = + let rec iter2 x = + function + [] -> [] + | y :: ys -> + f x y :: iter2 x ys + in + let rec iter = + function + [] -> [] + | x :: xs -> iter2 x lst' @ iter xs + in + iter lst +*) +(* +let print_pat pat = + let rec string_of_pat pat = + match pat.pat_desc with + Tpat_var _ -> "v" + | Tpat_any -> "_" + | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p) + | Tpat_constant n -> "0" + | Tpat_construct (_, lid, _) -> + Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt)) + | Tpat_lazy p -> + Printf.sprintf "(lazy %s)" (string_of_pat p) + | Tpat_or (p1,p2,_) -> + Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2) + | Tpat_tuple list -> + Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) + | Tpat_variant (_, _, _) -> "variant" + | Tpat_record (_, _) -> "record" + | Tpat_array _ -> "array" + in + Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) +*) + +(* strictly more powerful than exhaust; however, exhaust + was kept for backwards compatibility *) + +(* Limit to prevent exponential blowup in exhaustiveness checking. + When the limit is exceeded, we conservatively report the pattern as + non-exhaustive (Rnone) which may cause false warnings but prevents hangs. *) +let exhaust_gadt_limit = 1000 + +let rec exhaust_gadt_aux count (ext : Path.t option) pss n = + (* Bail out if we've done too many recursive calls to prevent exponential blowup *) + if !count > exhaust_gadt_limit then Rnone + else ( + incr count; + match pss with + | [] -> Rsome [omegas n] + | [] :: _ -> Rnone + | pss -> ( + if not (all_coherent (simplified_first_col pss)) then + (* We're considering an ill-typed branch, we won't actually be able to + produce a well typed value taking that branch. *) + Rnone + else + (* Assuming the first column is ill-typed but considered coherent, we + might end up producing an ill-typed witness of non-exhaustivity + corresponding to the current branch. + + If [exhaust] has been called by [do_check_partial], then the witnesses + produced get typechecked and the ill-typed ones are discarded. + + If [exhaust] has been called by [do_check_fragile], then it is possible + we might fail to warn the user that the matching is fragile. See for + example testsuite/tests/warnings/w04_failure.ml. *) + let q0 = discr_pat omega pss in + match filter_all q0 pss with + (* first column of pss is made of variables only *) + | [] -> ( + match exhaust_gadt_aux count ext (filter_extra pss) (n - 1) with + | Rsome r -> Rsome (List.map (fun row -> q0 :: row) r) + | r -> r) + | constrs -> ( + let try_non_omega (p, pss) = + if is_absent_pat p then Rnone + else + match + exhaust_gadt_aux count ext pss + (List.length (simple_match_args p omega) + n - 1) + with + | Rsome r -> Rsome (List.map (fun row -> set_args p row) r) + | r -> r + in + let before = try_many_gadt try_non_omega constrs in + if full_match false constrs && not (should_extend ext constrs) then + before + else + (* + D = filter_extra pss is the default matrix + as it is included in pss, one can avoid + recursive calls on specialized matrices, + Essentially : + * D exhaustive => pss exhaustive + * D non-exhaustive => we have a non-filtered value + *) + let r = exhaust_gadt_aux count ext (filter_extra pss) (n - 1) in + match r with + | Rnone -> before + | Rsome r -> ( + try + let p = build_other ext constrs in + let dug = List.map (fun tail -> p :: tail) r in + match before with + | Rnone -> Rsome dug + | Rsome x -> Rsome (x @ dug) + with + (* cannot occur, since constructors don't make a full signature *) + | Empty -> + fatal_error "Parmatch.exhaust")))) + +let exhaust_gadt ext pss n = + let count = ref 0 in + let ret = exhaust_gadt_aux count ext pss n in + match ret with + | Rnone -> Rnone + | Rsome lst -> + (* The following line is needed to compile stdlib/printf.ml *) + if lst = [] then Rsome (omegas n) + else + let singletons = + List.map + (function + | [x] -> x + | _ -> assert false) + lst + in + Rsome [orify_many singletons] + +(* + Another exhaustiveness check, enforcing variant typing. + Note that it does not check exact exhaustiveness, but whether a + matching could be made exhaustive by closing all variant types. + When this is true of all other columns, the current column is left + open (even if it means that the whole matching is not exhaustive as + a result). + When this is false for the matrix minus the current column, and the + current column is composed of variant tags, we close the variant + (even if it doesn't help in making the matching exhaustive). +*) + +let rec pressure_variants tdefs = function + | [] -> false + | [] :: _ -> true + | pss -> ( + if not (all_coherent (simplified_first_col pss)) then true + else + let q0 = discr_pat omega pss in + match filter_all q0 pss with + | [] -> pressure_variants tdefs (filter_extra pss) + | constrs -> + let rec try_non_omega = function + | (_p, pss) :: rem -> + let ok = pressure_variants tdefs pss in + try_non_omega rem && ok + | [] -> true + in + if full_match (tdefs = None) constrs then try_non_omega constrs + else if tdefs = None then pressure_variants None (filter_extra pss) + else + let full = full_match true constrs in + let ok = + if full then try_non_omega constrs + else try_non_omega (filter_all q0 (mark_partial pss)) + in + (match (constrs, tdefs) with + | (({pat_desc = Tpat_variant _} as p), _) :: _, Some env -> + let row = row_of_pat p in + if Btype.row_fixed row || pressure_variants None (filter_extra pss) + then () + else close_variant env row + | _ -> ()); + ok) + +(* Yet another satisfiable function *) + +(* + This time every_satisfiable pss qs checks the + utility of every expansion of qs. + Expansion means expansion of or-patterns inside qs +*) + +type answer = + | Used (* Useful pattern *) + | Unused (* Useless pattern *) + | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) + +(* this row type enable column processing inside the matrix + - left -> elements not to be processed, + - right -> elements to be processed +*) +type 'a row = {no_ors: 'a list; ors: 'a list; active: 'a list} + +(* +let pretty_row {ors=ors ; no_ors=no_ors; active=active} = + pretty_line ors ; prerr_string " *" ; + pretty_line no_ors ; prerr_string " *" ; + pretty_line active + +let pretty_rows rs = + prerr_endline "begin matrix" ; + List.iter + (fun r -> + pretty_row r ; + prerr_endline "") + rs ; + prerr_endline "end matrix" +*) + +(* Initial build *) +let make_row ps = {ors = []; no_ors = []; active = ps} + +let make_rows pss = List.map make_row pss + +(* Useful to detect and expand or pats inside as pats *) +let rec unalias p = + match p.pat_desc with + | Tpat_alias (p, _, _) -> unalias p + | _ -> p + +let is_var p = + match (unalias p).pat_desc with + | Tpat_any | Tpat_var _ -> true + | _ -> false + +let is_var_column rs = + List.for_all + (fun r -> + match r.active with + | p :: _ -> is_var p + | [] -> assert false) + rs + +(* Standard or-args for left-to-right matching *) +let rec or_args p = + match p.pat_desc with + | Tpat_or (p1, p2, _) -> (p1, p2) + | Tpat_alias (p, _, _) -> or_args p + | _ -> assert false + +(* Just remove current column *) +let remove r = + match r.active with + | _ :: rem -> {r with active = rem} + | [] -> assert false + +let remove_column rs = List.map remove rs + +(* Current column has been processed *) +let push_no_or r = + match r.active with + | p :: rem -> {r with no_ors = p :: r.no_ors; active = rem} + | [] -> assert false + +let push_or r = + match r.active with + | p :: rem -> {r with ors = p :: r.ors; active = rem} + | [] -> assert false + +let push_or_column rs = List.map push_or rs + +and push_no_or_column rs = List.map push_no_or rs + +(* Those are adaptations of the previous homonymous functions that + work on the current column, instead of the first column +*) + +let discr_pat q rs = discr_pat q (List.map (fun r -> r.active) rs) + +let filter_one q rs = + let rec filter_rec rs = + match rs with + | [] -> [] + | r :: rem -> ( + match r.active with + | [] -> assert false + | {pat_desc = Tpat_alias (p, _, _)} :: ps -> + filter_rec ({r with active = p :: ps} :: rem) + | {pat_desc = Tpat_or (p1, p2, _)} :: ps -> + filter_rec + ({r with active = p1 :: ps} :: {r with active = p2 :: ps} :: rem) + | p :: ps -> + if simple_match q p then + {r with active = simple_match_args q p @ ps} :: filter_rec rem + else filter_rec rem) + in + filter_rec rs + +(* Back to normal matrices *) +let make_vector r = List.rev r.no_ors + +let make_matrix rs = List.map make_vector rs + +(* Standard union on answers *) +let union_res r1 r2 = + match (r1, r2) with + | Unused, _ | _, Unused -> Unused + | Used, _ -> r2 + | _, Used -> r1 + | Upartial u1, Upartial u2 -> Upartial (u1 @ u2) + +(* propose or pats for expansion *) +let extract_elements qs = + let rec do_rec seen = function + | [] -> [] + | q :: rem -> + {no_ors = List.rev_append seen rem @ qs.no_ors; ors = []; active = [q]} + :: do_rec (q :: seen) rem + in + do_rec [] qs.ors + +(* idem for matrices *) +let transpose rs = + match rs with + | [] -> assert false + | r :: rem -> + let i = List.map (fun x -> [x]) r in + List.fold_left (List.map2 (fun r x -> x :: r)) i rem + +let extract_columns pss qs = + match pss with + | [] -> List.map (fun _ -> []) qs.ors + | _ -> + let rows = List.map extract_elements pss in + transpose rows + +(* Core function + The idea is to first look for or patterns (recursive case), then + check or-patterns argument usefulness (terminal case) +*) +let rec simplified_first_usefulness_col = function + | [] -> [] + | row :: rows -> ( + match row.active with + | [] -> assert false (* the rows are non-empty! *) + | p :: _ -> simplify_head_pat p (simplified_first_usefulness_col rows)) + +let rec every_satisfiables pss qs = + match qs.active with + | [] -> ( + (* qs is now partitionned, check usefulness *) + match qs.ors with + | [] -> + (* no or-patterns *) + if satisfiable (make_matrix pss) (make_vector qs) then Used else Unused + | _ -> + (* n or-patterns -> 2n expansions *) + List.fold_right2 + (fun pss qs r -> + match r with + | Unused -> Unused + | _ -> ( + match qs.active with + | [q] -> + let q1, q2 = or_args q in + let r_loc = every_both pss qs q1 q2 in + union_res r r_loc + | _ -> assert false)) + (extract_columns pss qs) (extract_elements qs) Used) + | q :: rem -> ( + let uq = unalias q in + match uq.pat_desc with + | Tpat_any | Tpat_var _ -> + if is_var_column pss then + (* forget about ``all-variable'' columns now *) + every_satisfiables (remove_column pss) (remove qs) + else + (* otherwise this is direct food for satisfiable *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + | Tpat_or (q1, q2, _) -> + if q1.pat_loc.Location.loc_ghost && q2.pat_loc.Location.loc_ghost then + (* syntactically generated or-pats should not be expanded *) + every_satisfiables (push_no_or_column pss) (push_no_or qs) + else + (* this is a real or-pattern *) + every_satisfiables (push_or_column pss) (push_or qs) + | Tpat_variant (l, _, r) when is_absent l r -> + (* Ah Jacques... *) + Unused + | _ -> + (* standard case, filter matrix *) + (* The handling of incoherent matrices is kept in line with + [satisfiable] *) + if not (all_coherent (uq :: simplified_first_usefulness_col pss)) then + Unused + else + let q0 = discr_pat q pss in + every_satisfiables (filter_one q0 pss) + {qs with active = simple_match_args q0 q @ rem}) + +(* + This function ``every_both'' performs the usefulness check + of or-pat q1|q2. + The trick is to call every_satisfied twice with + current active columns restricted to q1 and q2, + That way, + - others orpats in qs.ors will not get expanded. + - all matching work performed on qs.no_ors is not performed again. + *) +and every_both pss qs q1 q2 = + let qs1 = {qs with active = [q1]} and qs2 = {qs with active = [q2]} in + let r1 = every_satisfiables pss qs1 + and r2 = every_satisfiables (if compat q1 q2 then qs1 :: pss else pss) qs2 in + match r1 with + | Unused -> ( + match r2 with + | Unused -> Unused + | Used -> Upartial [q1] + | Upartial u2 -> Upartial (q1 :: u2)) + | Used -> ( + match r2 with + | Unused -> Upartial [q2] + | _ -> r2) + | Upartial u1 -> ( + match r2 with + | Unused -> Upartial (u1 @ [q2]) + | Used -> r1 + | Upartial u2 -> Upartial (u1 @ u2)) + +(* le_pat p q means, forall V, V matches q implies V matches p *) +let rec le_pat p q = + match (p.pat_desc, q.pat_desc) with + | (Tpat_var _ | Tpat_any), _ -> true + | Tpat_alias (p, _, _), _ -> le_pat p q + | _, Tpat_alias (q, _, _) -> le_pat p q + | Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0 + | Tpat_construct (_, c1, ps), Tpat_construct (_, c2, qs) -> + Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs + | Tpat_variant (l1, Some p1, _), Tpat_variant (l2, Some p2, _) -> + l1 = l2 && le_pat p1 p2 + | Tpat_variant (l1, None, _r1), Tpat_variant (l2, None, _) -> l1 = l2 + | Tpat_variant (_, _, _), Tpat_variant (_, _, _) -> false + | Tpat_tuple ps, Tpat_tuple qs -> le_pats ps qs + | Tpat_record (l1, _), Tpat_record (l2, _) -> + let ps, qs = records_args l1 l2 in + le_pats ps qs + | Tpat_array ps, Tpat_array qs -> Ext_list.same_length ps qs && le_pats ps qs + (* In all other cases, enumeration is performed *) + | _, _ -> not (satisfiable [[p]] [q]) + +and le_pats ps qs = + match (ps, qs) with + | p :: ps, q :: qs -> le_pat p q && le_pats ps qs + | _, _ -> true + +let get_mins le ps = + let rec select_rec r = function + | [] -> r + | p :: ps -> + if List.exists (fun p0 -> le p0 p) ps then select_rec r ps + else select_rec (p :: r) ps + in + select_rec [] (select_rec [] ps) + +(* + lub p q is a pattern that matches all values matched by p and q + may raise Empty, when p and q are not compatible +*) + +let rec lub p q = + match (p.pat_desc, q.pat_desc) with + | Tpat_alias (p, _, _), _ -> lub p q + | _, Tpat_alias (q, _, _) -> lub p q + | (Tpat_any | Tpat_var _), _ -> q + | _, (Tpat_any | Tpat_var _) -> p + | Tpat_or (p1, p2, _), _ -> orlub p1 p2 q + | _, Tpat_or (q1, q2, _) -> orlub q1 q2 p (* Thanks god, lub is commutative *) + | Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p + | Tpat_tuple ps, Tpat_tuple qs -> + let rs = lubs ps qs in + make_pat (Tpat_tuple rs) p.pat_type p.pat_env + | Tpat_construct (lid, c1, ps1), Tpat_construct (_, c2, ps2) + when Types.equal_tag c1.cstr_tag c2.cstr_tag -> + let rs = lubs ps1 ps2 in + make_pat (Tpat_construct (lid, c1, rs)) p.pat_type p.pat_env + | Tpat_variant (l1, Some p1, row), Tpat_variant (l2, Some p2, _) when l1 = l2 + -> + let r = lub p1 p2 in + make_pat (Tpat_variant (l1, Some r, row)) p.pat_type p.pat_env + | Tpat_variant (l1, None, _row), Tpat_variant (l2, None, _) when l1 = l2 -> p + | Tpat_record (l1, closed), Tpat_record (l2, _) -> + let rs = record_lubs l1 l2 in + make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env + | Tpat_array ps, Tpat_array qs when List.length ps = List.length qs -> + let rs = lubs ps qs in + make_pat (Tpat_array rs) p.pat_type p.pat_env + | _, _ -> raise Empty + +and orlub p1 p2 q = + try + let r1 = lub p1 q in + try {q with pat_desc = Tpat_or (r1, lub p2 q, None)} with Empty -> r1 + with Empty -> lub p2 q + +and record_lubs l1 l2 = + let rec lub_rec l1 l2 = + match (l1, l2) with + | [], _ -> l2 + | _, [] -> l1 + | (lid1, lbl1, p1, o1) :: rem1, (lid2, lbl2, p2, o2) :: rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + (lid1, lbl1, p1, o1) :: lub_rec rem1 l2 + else if lbl2.lbl_pos < lbl1.lbl_pos then + (lid2, lbl2, p2, o2) :: lub_rec l1 rem2 + else + let o = if o1 = o2 then o1 else raise Empty in + (lid1, lbl1, lub p1 p2, o) :: lub_rec rem1 rem2 + in + lub_rec l1 l2 + +and lubs ps qs = + match (ps, qs) with + | p :: ps, q :: qs -> lub p q :: lubs ps qs + | _, _ -> [] + +(******************************) +(* Exported variant closing *) +(******************************) + +(* Apply pressure to variants *) + +let pressure_variants tdefs patl = + let pss = List.map (fun p -> [p; omega]) patl in + ignore (pressure_variants (Some tdefs) pss) + +(*****************************) +(* Utilities for diagnostics *) +(*****************************) + +(* + Build up a working pattern matrix by forgetting + about guarded patterns +*) + +let rec initial_matrix = function + | [] -> [] + | {c_guard = Some _} :: rem -> initial_matrix rem + | {c_guard = None; c_lhs = p} :: rem -> [p] :: initial_matrix rem + +(******************************************) +(* Look for a row that matches some value *) +(******************************************) + +(* + Useful for seeing if the example of + non-matched value can indeed be matched + (by a guarded clause) +*) + +exception NoGuard + +let rec initial_all no_guard = function + | [] -> if no_guard then raise NoGuard else [] + | {c_lhs = pat; c_guard; _} :: rem -> + ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem + +let rec do_filter_var = function + | (_ :: ps, loc) :: rem -> (ps, loc) :: do_filter_var rem + | _ -> [] + +let do_filter_one q pss = + let rec filter_rec = function + | ({pat_desc = Tpat_alias (p, _, _)} :: ps, loc) :: pss -> + filter_rec ((p :: ps, loc) :: pss) + | ({pat_desc = Tpat_or (p1, p2, _)} :: ps, loc) :: pss -> + filter_rec ((p1 :: ps, loc) :: (p2 :: ps, loc) :: pss) + | (p :: ps, loc) :: pss -> + if simple_match q p then + (simple_match_args q p @ ps, loc) :: filter_rec pss + else filter_rec pss + | _ -> [] + in + filter_rec pss + +let rec do_match pss qs = + match qs with + | [] -> ( + match pss with + | ([], loc) :: _ -> Some loc + | _ -> None) + | q :: qs -> ( + match q with + | {pat_desc = Tpat_or (q1, q2, _)} -> ( + match do_match pss (q1 :: qs) with + | None -> do_match pss (q2 :: qs) + | r -> r) + | {pat_desc = Tpat_any} -> do_match (do_filter_var pss) qs + | _ -> + let q0 = normalize_pat q in + (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of + its first column. *) + do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs)) + +let check_partial_all v casel = + try + let pss = initial_all true casel in + do_match pss [v] + with NoGuard -> None + +(************************) +(* Exhaustiveness check *) +(************************) + +(* conversion from Typedtree.pattern to Parsetree.pattern list *) +module Conv = struct + open Parsetree + let mkpat desc = Ast_helper.Pat.mk desc + + let name_counter = ref 0 + let fresh name = + let current = !name_counter in + name_counter := !name_counter + 1; + "#$" ^ name ^ string_of_int current + + let conv typed = + let constrs = Hashtbl.create 7 in + let labels = Hashtbl.create 7 in + let rec loop pat = + match pat.pat_desc with + | Tpat_or (pa, pb, _) -> mkpat (Ppat_or (loop pa, loop pb)) + | Tpat_var (_, ({txt = "*extension*"} as nm)) -> + (* PR#7330 *) + mkpat (Ppat_var nm) + | Tpat_any | Tpat_var _ -> mkpat Ppat_any + | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) + | Tpat_alias (p, _, _) -> loop p + | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) + | Tpat_construct (cstr_lid, cstr, lst) -> + let id = fresh cstr.cstr_name in + let lid = {cstr_lid with txt = Longident.Lident id} in + Hashtbl.add constrs id cstr; + let arg = + match List.map loop lst with + | [] -> None + | [p] -> Some p + | lst -> Some (mkpat (Ppat_tuple lst)) + in + mkpat (Ppat_construct (lid, arg)) + | Tpat_variant (label, p_opt, _row_desc) -> + let arg = Misc.may_map loop p_opt in + mkpat (Ppat_variant (label, arg)) + | Tpat_record (subpatterns, _closed_flag) -> + let fields = + List.map + (fun (_, lbl, p, optional) -> + let id = fresh lbl.lbl_name in + Hashtbl.add labels id lbl; + {lid = mknoloc (Longident.Lident id); x = loop p; opt = optional}) + subpatterns + in + mkpat (Ppat_record (fields, Open)) + | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) + in + let ps = loop typed in + (ps, constrs, labels) +end + +(* Whether the counter-example contains an extension pattern *) +let contains_extension pat = + let r = ref false in + let rec loop = function + | {pat_desc = Tpat_var (_, {txt = "*extension*"})} -> r := true + | p -> Typedtree.iter_pattern_desc loop p.pat_desc + in + loop pat; + !r + +(* Build an untyped or-pattern from its expected type *) +let ppat_of_type env ty = + match pats_of_type env ty with + | [{pat_desc = Tpat_any}] -> + (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0) + | pats -> Conv.conv (orify_many pats) + +let do_check_partial ?partial_match_warning_hint ?pred exhaust loc casel pss = + match pss with + | [] -> + (* + This can occur + - For empty matches generated by ocamlp4 (no warning) + - when all patterns have guards (then, casel <> []) + (specific warning) + Then match MUST be considered non-exhaustive, + otherwise compilation of PM is broken. + *) + (match casel with + | [] -> () + | _ -> + if Warnings.is_active Warnings.All_clauses_guarded then + Location.prerr_warning loc Warnings.All_clauses_guarded); + Partial + | ps :: _ -> ( + match exhaust None pss (List.length ps) with + | Rnone -> Total + | Rsome [u] -> ( + let v = + match pred with + | Some pred -> + let pattern, constrs, labels = Conv.conv u in + let u' = pred constrs labels pattern in + (* pretty_pat u; + begin match u' with + None -> prerr_endline ": impossible" + | Some _ -> prerr_endline ": possible" + end; *) + u' + | None -> Some u + in + match v with + | None -> Total + | Some v -> + (if Warnings.is_active (Warnings.Partial_match "") then + let errmsg = + try + let buf = Buffer.create 16 in + Buffer.add_string buf "| "; + Buffer.add_string buf (!print_res_pat v); + (match check_partial_all v casel with + | None -> () + | Some _ -> + (* This is 'Some loc', where loc is the location of + a possibly matching clause. + Forget about loc, because printing two locations + is a pain in the top-level *) + Buffer.add_string buf + "\n(However, some guarded clause may match this value.)"); + if contains_extension v then + Buffer.add_string buf + "\n\ + Matching over values of extensible variant types (the \ + *extension* above)\n\ + must include a wild card pattern in order to be exhaustive."; + (match partial_match_warning_hint with + | None -> () + | Some h when String.length h > 0 -> + Buffer.add_string buf ("\n\n " ^ h) + | Some _ -> ()); + Buffer.contents buf + with _ -> "" + in + Location.prerr_warning loc (Warnings.Partial_match errmsg)); + Partial) + | _ -> fatal_error "Parmatch.check_partial") + +(* +let do_check_partial_normal loc casel pss = + do_check_partial exhaust loc casel pss + *) + +let do_check_partial_gadt ?partial_match_warning_hint pred loc casel pss = + do_check_partial ?partial_match_warning_hint ~pred exhaust_gadt loc casel pss + +(*****************) +(* Fragile check *) +(*****************) + +(* Collect all data types in a pattern *) + +let rec add_path path = function + | [] -> [path] + | x :: rem as paths -> + if Path.same path x then paths else x :: add_path path rem + +let extendable_path path = + not + (Path.same path Predef.path_bool + || Path.same path Predef.path_list + || Path.same path Predef.path_unit + || Path.same path Predef.path_option) + +let rec collect_paths_from_pat r p = + match p.pat_desc with + | Tpat_construct + (_, {cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed}, ps) -> + let path = get_type_path p.pat_type p.pat_env in + List.fold_left collect_paths_from_pat + (if extendable_path path then add_path path r else r) + ps + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) -> r + | Tpat_tuple ps + | Tpat_array ps + | Tpat_construct (_, {cstr_tag = Cstr_extension _}, ps) -> + List.fold_left collect_paths_from_pat r ps + | Tpat_record (lps, _) -> + List.fold_left (fun r (_, _, p, _) -> collect_paths_from_pat r p) r lps + | Tpat_variant (_, Some p, _) | Tpat_alias (p, _, _) -> + collect_paths_from_pat r p + | Tpat_or (p1, p2, _) -> + collect_paths_from_pat (collect_paths_from_pat r p1) p2 + +(* + Actual fragile check + 1. Collect data types in the patterns of the match. + 2. One exhaustivity check per datatype, considering that + the type is extended. +*) + +let do_check_fragile_param exhaust loc casel pss = + let exts = + List.fold_left (fun r c -> collect_paths_from_pat r c.c_lhs) [] casel + in + match exts with + | [] -> () + | _ -> ( + match pss with + | [] -> () + | ps :: _ -> + List.iter + (fun ext -> + match exhaust (Some ext) pss (List.length ps) with + | Rnone -> + Location.prerr_warning loc (Warnings.Fragile_match (Path.name ext)) + | Rsome _ -> ()) + exts) + +(*let do_check_fragile_normal = do_check_fragile_param exhaust*) +let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt + +(********************************) +(* Exported unused clause check *) +(********************************) + +let check_unused pred casel = + if Warnings.is_active Warnings.Unused_match then + let rec do_rec pref = function + | [] -> () + | {c_lhs = q; c_guard} :: rem -> + let qs = [q] in + (try + let pss = get_mins le_pats (Ext_list.filter pref (compats qs)) in + (* First look for redundant or partially redundant patterns *) + let r = every_satisfiables (make_rows pss) (make_row qs) in + (* Do not warn for unused [pat -> .] *) + let r = + (* Do not refine if there are no other lines *) + let skip = + r = Unused || pref = [] + || not (Warnings.is_active Warnings.Unreachable_case) + in + if skip then r + else + (* Then look for empty patterns *) + let sfs = satisfiables pss qs in + if sfs = [] then Unused + else + let sfs = + List.map + (function + | [u] -> u + | _ -> assert false) + sfs + in + let u = orify_many sfs in + (*Format.eprintf "%a@." pretty_val u;*) + let pattern, constrs, labels = Conv.conv u in + let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in + match pred constrs labels pattern with + | None -> + Location.prerr_warning q.pat_loc Warnings.Unreachable_case; + Used + | _ -> r + in + match r with + | Unused -> Location.prerr_warning q.pat_loc Warnings.Unused_match + | Upartial ps -> + ps + |> List.filter (fun p -> + not (Variant_type_spread.is_pat_from_variant_spread_attr p)) + |> List.iter (fun p -> + Location.prerr_warning p.pat_loc Warnings.Unused_pat) + | Used -> () + with Empty | Not_found | NoGuard -> assert false); + + if c_guard <> None then do_rec pref rem else do_rec ([q] :: pref) rem + in + + do_rec [] casel + +(*********************************) +(* Exported irrefutability tests *) +(*********************************) + +let irrefutable pat = le_pat pat omega + +let inactive ~partial pat = + match partial with + | Partial -> false + | Total -> + let rec loop pat = + match pat.pat_desc with + | Tpat_array _ -> false + | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) -> true + | Tpat_constant c -> ( + match c with + | Const_string _ -> true (*Config.safe_string*) + | Const_int _ | Const_char _ | Const_float _ | Const_int32 _ + | Const_int64 _ | Const_bigint _ -> + true) + | Tpat_tuple ps | Tpat_construct (_, _, ps) -> + List.for_all (fun p -> loop p) ps + | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> loop p + | Tpat_record (ldps, _) -> + List.for_all + (fun (_, lbl, p, _) -> lbl.lbl_mut = Immutable && loop p) + ldps + | Tpat_or (p, q, _) -> loop p && loop q + in + loop pat + +(*********************************) +(* Exported exhaustiveness check *) +(*********************************) + +(* + Fragile check is performed when required and + on exhaustive matches only. +*) + +let check_partial_param do_check_partial do_check_fragile loc casel = + let pss = initial_matrix casel in + let pss = get_mins le_pats pss in + let total = do_check_partial loc casel pss in + if total = Total && Warnings.is_active (Warnings.Fragile_match "") then + do_check_fragile loc casel pss; + total + +(*let check_partial = + check_partial_param + do_check_partial_normal + do_check_fragile_normal*) + +let check_partial_gadt ?partial_match_warning_hint pred loc casel = + check_partial_param + (do_check_partial_gadt ?partial_match_warning_hint pred) + do_check_fragile_gadt loc casel + +(*************************************) +(* Ambiguous variable in or-patterns *) +(*************************************) + +(* Specification: ambiguous variables in or-patterns. + + The semantics of or-patterns in OCaml is specified with + a left-to-right bias: a value [v] matches the pattern [p | q] if it + matches [p] or [q], but if it matches both, the environment + captured by the match is the environment captured by [p], never the + one captured by [q]. + + While this property is generally well-understood, one specific case + where users expect a different semantics is when a pattern is + followed by a when-guard: [| p when g -> e]. Consider for example: + + | ((Const x, _) | (_, Const x)) when is_neutral x -> branch + + The semantics is clear: match the scrutinee against the pattern, if + it matches, test the guard, and if the guard passes, take the + branch. + + However, consider the input [(Const a, Const b)], where [a] fails + the test [is_neutral f], while [b] passes the test [is_neutral + b]. With the left-to-right semantics, the clause above is *not* + taken by its input: matching [(Const a, Const b)] against the + or-pattern succeeds in the left branch, it returns the environment + [x -> a], and then the guard [is_neutral a] is tested and fails, + the branch is not taken. Most users, however, intuitively expect + that any pair that has one side passing the test will take the + branch. They assume it is equivalent to the following: + + | (Const x, _) when is_neutral x -> branch + | (_, Const x) when is_neutral x -> branch + + while it is not. + + The code below is dedicated to finding these confusing cases: the + cases where a guard uses "ambiguous" variables, that are bound to + different parts of the scrutinees by different sides of + a or-pattern. In other words, it finds the cases where the + specified left-to-right semantics is not equivalent to + a non-deterministic semantics (any branch can be taken) relatively + to a specific guard. +*) + +module IdSet = Set.Make (Ident) + +let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p) + +(* Row for ambiguous variable search, + unseen is the traditional pattern row, + seen is a list of position bindings *) + +type amb_row = {unseen: pattern list; seen: IdSet.t list} + +(* Push binding variables now *) + +let rec do_push r p ps seen k = + match p.pat_desc with + | Tpat_alias (p, x, _) -> do_push (IdSet.add x r) p ps seen k + | Tpat_var (x, _) -> (omega, {unseen = ps; seen = IdSet.add x r :: seen}) :: k + | Tpat_or (p1, p2, _) -> do_push r p1 ps seen (do_push r p2 ps seen k) + | _ -> (p, {unseen = ps; seen = r :: seen}) :: k + +let rec push_vars = function + | [] -> [] + | {unseen = []} :: _ -> assert false + | {unseen = p :: ps; seen} :: rem -> + do_push IdSet.empty p ps seen (push_vars rem) + +let collect_stable = function + | [] -> assert false + | {seen = xss; _} :: rem -> + let rec c_rec xss = function + | [] -> xss + | {seen = yss; _} :: rem -> + let xss = List.map2 IdSet.inter xss yss in + c_rec xss rem + in + let inters = c_rec xss rem in + List.fold_left IdSet.union IdSet.empty inters + +(*********************************************) +(* Filtering utilities for our specific rows *) +(*********************************************) + +(* Take a pattern matrix as a list (rows) of lists (columns) of patterns + | p1, p2, .., pn + | q1, q2, .., qn + | r1, r2, .., rn + | ... + + We split this matrix into a list of sub-matrices, one for each head + constructor appearing in the leftmost column. For each row whose + left column starts with a head constructor, remove this head + column, prepend one column for each argument of the constructor, + and add the resulting row in the sub-matrix corresponding to this + head constructor. + + Rows whose left column is omega (the Any pattern _) may match any + head constructor, so they are added to all groups. + + The list of sub-matrices is represented as a list of pair + (head constructor, submatrix) +*) + +let filter_all = + (* the head constructor (as a pattern with omega arguments) of + a pattern *) + let discr_head pat = + match pat.pat_desc with + | Tpat_record (lbls, closed) -> + (* a partial record pattern { f1 = p1; f2 = p2; _ } + needs to be expanded, otherwise matching against this head + would drop the pattern arguments for non-mentioned fields *) + let lbls = all_record_args lbls in + normalize_pat {pat with pat_desc = Tpat_record (lbls, closed)} + | _ -> normalize_pat pat + in + + (* insert a row of head [p] and rest [r] into the right group *) + let rec insert p r env = + match env with + | [] -> + (* if no group matched this row, it has a head constructor that + was never seen before; add a new sub-matrix for this head *) + let p0 = discr_head p in + [(p0, [{r with unseen = simple_match_args p0 p @ r.unseen}])] + | ((q0, rs) as bd) :: env -> + if simple_match q0 p then + let r = {r with unseen = simple_match_args q0 p @ r.unseen} in + (q0, r :: rs) :: env + else bd :: insert p r env + in + + (* insert a row of head omega into all groups *) + let insert_omega r env = + List.map + (fun (q0, rs) -> + let r = {r with unseen = simple_match_args q0 omega @ r.unseen} in + (q0, r :: rs)) + env + in + + let rec filter_rec env = function + | [] -> env + | ({pat_desc = Tpat_var _ | Tpat_alias _ | Tpat_or _}, _) :: _ -> + assert false + | ({pat_desc = Tpat_any}, _) :: rs -> filter_rec env rs + | (p, r) :: rs -> filter_rec (insert p r env) rs + in + + let rec filter_omega env = function + | [] -> env + | ({pat_desc = Tpat_var _ | Tpat_alias _ | Tpat_or _}, _) :: _ -> + assert false + | ({pat_desc = Tpat_any}, r) :: rs -> filter_omega (insert_omega r env) rs + | _ :: rs -> filter_omega env rs + in + + fun rs -> + (* first insert the rows with head constructors, + to get the definitive list of groups *) + let env = filter_rec [] rs in + (* then add the omega rows to all groups *) + filter_omega env rs + +(* Compute stable bindings *) + +let rec do_stable rs = + match rs with + | [] -> assert false (* No empty matrix *) + | {unseen = []; _} :: _ -> collect_stable rs + | _ -> ( + let rs = push_vars rs in + if not (all_coherent (first_column rs)) then + (* If the first column is incoherent, then all the variables of this + matrix are stable. *) + List.fold_left + (fun acc (_, {seen; _}) -> List.fold_left IdSet.union acc seen) + IdSet.empty rs + else + (* If the column is ill-typed but deemed coherent, we might spuriously + warn about some variables being unstable. + As sad as that might be, the warning can be silenced by splitting the + or-pattern... *) + match filter_all rs with + | [] -> do_stable (List.map snd rs) + | (_, rs) :: env -> + List.fold_left + (fun xs (_, rs) -> IdSet.inter xs (do_stable rs)) + (do_stable rs) env) + +let stable p = do_stable [{unseen = [p]; seen = []}] + +(* All identifier paths that appear in an expression that occurs + as a clause right hand side or guard. + + The function is rather complex due to the compilation of + unpack patterns by introducing code in rhs expressions + and **guards**. + + For pattern (module M:S) -> e the code is + let module M_mod = unpack M .. in e + + Hence M is "free" in e iff M_mod is free in e. + + Not doing so will yield excessive warning in + (module (M:S) } ...) when true -> .... + as M is always present in + let module M_mod = unpack M .. in true +*) + +let all_rhs_idents exp = + let ids = ref IdSet.empty in + let module Iterator = TypedtreeIter.MakeIterator (struct + include TypedtreeIter.DefaultIteratorArgument + let enter_expression exp = + match exp.exp_desc with + | Texp_ident (path, _lid, _descr) -> + List.iter (fun id -> ids := IdSet.add id !ids) (Path.heads path) + | _ -> () + + (* Very hackish, detect unpack pattern compilation + and perform "indirect check for them" *) + let is_unpack exp = + List.exists (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes + + let leave_expression exp = + if is_unpack exp then + match exp.exp_desc with + | Texp_letmodule + ( id_mod, + _, + { + mod_desc = + Tmod_unpack + ({exp_desc = Texp_ident (Path.Pident id_exp, _, _)}, _); + }, + _ ) -> + assert (IdSet.mem id_exp !ids); + if not (IdSet.mem id_mod !ids) then ids := IdSet.remove id_exp !ids + | _ -> assert false + end) in + Iterator.iter_expression exp; + !ids + +let check_ambiguous_bindings = + let open Warnings in + let warn0 = Ambiguous_pattern [] in + fun cases -> + if is_active warn0 then + List.iter + (fun case -> + match case with + | {c_guard = None; _} -> () + | {c_lhs = p; c_guard = Some g; _} -> + let all = IdSet.inter (pattern_vars p) (all_rhs_idents g) in + if not (IdSet.is_empty all) then + let st = stable p in + let ambiguous = IdSet.diff all st in + if not (IdSet.is_empty ambiguous) then + let pps = IdSet.elements ambiguous |> List.map Ident.name in + let warn = Ambiguous_pattern pps in + Location.prerr_warning p.pat_loc warn) + cases diff --git a/compiler/ml/parmatch.mli b/compiler/ml/parmatch.mli new file mode 100644 index 0000000..517206a --- /dev/null +++ b/compiler/ml/parmatch.mli @@ -0,0 +1,100 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Detection of partial matches and unused match cases. *) +open Asttypes +open Typedtree +open Types + +val top_pretty : Format.formatter -> pattern -> unit +val pretty_pat : pattern -> unit +val pretty_line : pattern list -> unit +val pretty_matrix : pattern list list -> unit + +val print_res_pat : (Typedtree.pattern -> string) ref + +val omega : pattern +val omegas : int -> pattern list +val omega_list : 'a list -> pattern list +val normalize_pat : pattern -> pattern +val all_record_args : + (Longident.t loc * label_description * pattern * bool) list -> + (Longident.t loc * label_description * pattern * bool) list +val const_compare : constant -> constant -> int + +val le_pat : pattern -> pattern -> bool +val le_pats : pattern list -> pattern list -> bool + +(* Exported compatibility, abstracted over constructor equality *) +module Compat : sig + type eq_cd = constructor_description -> constructor_description -> bool + val compat : equal_cd:eq_cd -> pattern -> pattern -> bool + val compats : equal_cd:eq_cd -> pattern list -> pattern list -> bool +end + +exception Empty +val lub : pattern -> pattern -> pattern +val lubs : pattern list -> pattern list -> pattern list + +val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list + +(* Those two functions recombine one pattern and its arguments: + For instance: + (_,_)::p1::p2::rem -> (p1, p2)::rem + The second one will replace mutable arguments by '_' +*) +val set_args_erase_mutable : pattern -> pattern list -> pattern list + +val pat_of_constr : pattern -> constructor_description -> pattern +val complete_constrs : + pattern -> constructor_tag list -> constructor_description list +val ppat_of_type : + Env.t -> + type_expr -> + Parsetree.pattern + * (string, constructor_description) Hashtbl.t + * (string, label_description) Hashtbl.t + +val pressure_variants : Env.t -> pattern list -> unit +val check_partial_gadt : + ?partial_match_warning_hint:string -> + ((string, constructor_description) Hashtbl.t -> + (string, label_description) Hashtbl.t -> + Parsetree.pattern -> + pattern option) -> + Location.t -> + case list -> + partial +val check_unused : + ((string, constructor_description) Hashtbl.t -> + (string, label_description) Hashtbl.t -> + Parsetree.pattern -> + pattern option) -> + case list -> + unit + +(* Irrefutability tests *) +val irrefutable : pattern -> bool + +val inactive : partial:partial -> pattern -> bool +(** An inactive pattern is a pattern, matching against which can be duplicated, erased or + delayed without change in observable behavior of the program. Patterns containing + (lazy _) subpatterns or reads of mutable fields are active. *) + +(* Ambiguous bindings *) +val check_ambiguous_bindings : case list -> unit + +(* The tag used for open polymorphic variant types *) +val some_other_tag : label diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml new file mode 100644 index 0000000..78c9899 --- /dev/null +++ b/compiler/ml/parsetree.ml @@ -0,0 +1,665 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree produced by parsing *) + +open Asttypes + +type constant = + | Pconst_integer of string * char option + (* 3 3l 3L 3n + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes except 'l', 'L' are rejected by the typechecker + *) + | Pconst_char of int + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option +(* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. +*) + +(** {1 Extension points} *) + +type attribute = string loc * payload +(* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. +*) + +and extension = string loc * payload +(* [%id ARG] + [%%id ARG] + + Sub-language placeholder -- rejected by the typechecker. +*) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (* : SIG *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option +(* ? P or ? P when E *) + +(* Type expressions *) + +(** {1 Core language} *) + +and core_type = { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and arg = {attrs: attributes; lbl: arg_label; typ: core_type} + +and core_type_desc = + | Ptyp_any (* _ *) + | Ptyp_var of string (* 'a *) + | Ptyp_arrow of {arg: arg; ret: core_type; arity: arity} + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_alias of core_type * string (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string loc list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + | Ptyp_package of package_type (* (module S) *) + | Ptyp_extension of extension +(* [%id] *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list +(* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + +and row_field = + | Rtag of label loc * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type +(* [ T ] *) + +and object_field = + | Otag of label loc * attributes * core_type + | Oinherit of core_type + +(* Patterns *) +and pattern = { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and pattern_desc = + | Ppat_any (* _ *) + | Ppat_var of string loc (* x *) + | Ppat_alias of pattern * string loc (* P as 'a *) + | Ppat_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of pattern record_element list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern (* P1 | P2 *) + | Ppat_constraint of pattern * core_type (* (P : T) *) + | Ppat_type of Longident.t loc (* #tconst *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern (* exception P *) + | Ppat_extension of extension (* [%id] *) + | Ppat_open of Longident.t loc * pattern +(* M.(P) *) + +and pat_record_label = Longident.t loc * pattern * bool (* optional *) + +(* Value expressions *) +and expression = { + pexp_desc: expression_desc; + pexp_loc: Location.t; + (* Hack: made pexp_attributes mutable for use in analysis exe. Please do not use elsewhere! *) + mutable pexp_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and expression_desc = + | Pexp_ident of Longident.t loc (* x + M.x + *) + | Pexp_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_fun of { + arg_label: arg_label; + default: expression option; + lhs: pattern; + rhs: expression; + arity: arity; + async: bool; + } + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of { + funct: expression; + args: (arg_label * expression) list; + partial: bool; + transformed_jsx: bool; + } + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pexp_match of expression * case list + (* match E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * case list + (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_tuple of expression list + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of expression record_element list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 + *) + | Pexp_field of expression * Longident.t loc (* E.l *) + | Pexp_setfield of expression * Longident.t loc * expression (* E1.l <- E2 *) + | Pexp_array of expression list (* [| E1; ...; En |] *) + | Pexp_ifthenelse of expression * expression * expression option + (* if E1 then E2 else E3 *) + | Pexp_sequence of expression * expression (* E1; E2 *) + | Pexp_while of expression * expression (* while E1 do E2 done *) + | Pexp_for of pattern * expression * expression * direction_flag * expression + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type (* (E : T) *) + | Pexp_coerce of expression * unit * core_type + (* (E :> T) (None, T) + *) + | Pexp_send of expression * label loc (* E # m *) + | Pexp_letmodule of string loc * module_expr * expression + (* let module M = ME in E *) + | Pexp_letexception of extension_constructor * expression + (* let exception C in E *) + | Pexp_assert of expression + (* assert E + Note: "assert false" is treated in a special way by the + type-checker. *) + | Pexp_newtype of string loc * expression (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_extension of extension + (* [%id] *) + (* . *) + | Pexp_await of expression + | Pexp_jsx_element of jsx_element + +(* an element of a record pattern or expression *) +and 'a record_element = {lid: Longident.t loc; x: 'a; opt: bool (* optional *)} + +and jsx_element = + | Jsx_fragment of jsx_fragment + | Jsx_unary_element of jsx_unary_element + | Jsx_container_element of jsx_container_element + +and jsx_tag_name = + | JsxLowerTag of string + | JsxQualifiedLowerTag of {path: Longident.t; name: string} + | JsxUpperTag of Longident.t + | JsxTagInvalid of string + +and jsx_fragment = { + (* > *) jsx_fragment_opening: Lexing.position; + (* children *) jsx_fragment_children: jsx_children; + (* *) + jsx_container_element_opening_tag_end: Lexing.position; + jsx_container_element_props: jsx_props; + jsx_container_element_children: jsx_children; + jsx_container_element_closing_tag: jsx_closing_container_tag option; +} + +and jsx_prop = + (* + * | lident + * | ?lident + *) + | JSXPropPunning of (* optional *) bool * (* name *) string loc + (* + * | lident = jsx_expr + * | lident = ?jsx_expr + *) + | JSXPropValue of + (* name *) string loc * (* optional *) bool * (* value *) expression + (* + * | {...jsx_expr} + *) + | JSXPropSpreading of + (* entire {...expr} location *) + Location.t + * expression + +and jsx_children = expression list + +and jsx_props = jsx_prop list + +and jsx_closing_container_tag = { + (* *) + jsx_closing_container_tag_end: Lexing.position; +} + +and case = { + (* (P -> E) or (P when E0 -> E) *) + pc_bar: Lexing.position option; + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; +} + +(* Value descriptions *) +and value_description = { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_loc: Location.t; +} + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + +(* Type declarations *) +and type_declaration = { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; +} + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) +and type_kind = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty list *) + | Ptype_record of label_declaration list (* Invariant: non-empty list *) + | Ptype_open + +and label_declaration = { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_optional: bool; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (* l : T [@id1] [@id2] *) +} + +(* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. +*) +and constructor_declaration = { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) +} + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) +*) +and type_extension = { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) +} +(* + type t += ... +*) + +and extension_constructor = { + pext_name: string loc; + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (* C of ... [@id1] [@id2] *) +} + +and extension_constructor_kind = + | Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc +(* + | C = D + *) + +(* Type expressions for the module language *) + +(** {1 Module language} *) + +and module_type = { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and module_type_desc = + | Pmty_ident of Longident.t loc (* S *) + | Pmty_signature of signature (* sig ... end *) + | Pmty_functor of string loc * module_type option * module_type + (* functor(X : MT1) -> MT2 *) + | Pmty_with of module_type * with_constraint list (* MT with ... *) + | Pmty_typeof of module_expr (* module type of ME *) + | Pmty_extension of extension (* [%id] *) + | Pmty_alias of Longident.t loc +(* (module M) *) + +and signature = signature_item list + +and signature_item = {psig_desc: signature_item_desc; psig_loc: Location.t} + +and signature_item_desc = + | Psig_value of value_description + (* + val x: T + external x: T = "s1" ... "sn" + *) + | Psig_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Psig_typext of type_extension (* type t1 += ... *) + | Psig_exception of extension_constructor (* exception C of T *) + | Psig_module of module_declaration (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + module type S *) + | Psig_open of open_description (* open X *) + | Psig_include of include_description (* include MT *) + | Psig_attribute of attribute (* [@@@id] *) + | Psig_extension of extension * attributes +(* [%%id] *) + +and module_declaration = { + pmd_name: string loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; +} +(* S : MT *) + +and module_type_declaration = { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_loc: Location.t; +} +(* S = MT + S (abstract module type declaration, pmtd_type = None) +*) + +and open_description = { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; +} +(* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh +*) + +and 'a include_infos = { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; +} + +and include_description = module_type include_infos +(* include MT *) + +and include_declaration = module_expr include_infos +(* include ME *) + +and with_constraint = + | Pwith_type of Longident.t loc * type_declaration + (* with type X.t = ... + + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of Longident.t loc * Longident.t loc (* with module X.Y = Z *) + | Pwith_typesubst of Longident.t loc * type_declaration + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_modsubst of Longident.t loc * Longident.t loc +(* with module X.Y := Z *) + +(* Value expressions for the module language *) + +and module_expr = { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and module_expr_desc = + | Pmod_ident of Longident.t loc (* X *) + | Pmod_structure of structure (* struct ... end *) + | Pmod_functor of string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr (* ME1(ME2) *) + | Pmod_constraint of module_expr * module_type (* (ME : MT) *) + | Pmod_unpack of expression (* (val E) *) + | Pmod_extension of extension +(* [%id] *) + +and structure = structure_item list + +and structure_item = {pstr_desc: structure_item_desc; pstr_loc: Location.t} + +and structure_item_desc = + | Pstr_eval of expression * attributes (* E *) + | Pstr_value of rec_flag * value_binding list + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = Recursive) + *) + | Pstr_primitive of value_description + (* val x: T + external x: T = "s1" ... "sn" *) + | Pstr_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Pstr_typext of type_extension (* type t1 += ... *) + | Pstr_exception of extension_constructor + (* exception C of T + exception C = M.X *) + | Pstr_module of module_binding (* module X = ME *) + | Pstr_recmodule of module_binding list + (* module rec X1 = ME1 and ... and Xn = MEn *) + | Pstr_modtype of module_type_declaration (* module type S = MT *) + | Pstr_open of open_description (* open X *) + | Pstr_include of include_declaration (* include ME *) + | Pstr_attribute of attribute (* [@@@id] *) + | Pstr_extension of extension * attributes +(* [%%id] *) + +and value_binding = { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; +} + +and module_binding = { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; +} +(* X = ME *) diff --git a/compiler/ml/parsetree0.ml b/compiler/ml/parsetree0.ml new file mode 100644 index 0000000..ef786df --- /dev/null +++ b/compiler/ml/parsetree0.ml @@ -0,0 +1,610 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree produced by parsing *) + +open Asttypes + +type constant = + | Pconst_integer of string * char option + (* 3 3l 3L 3n + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes except 'l', 'L' are rejected by the typechecker + *) + | Pconst_char of int + (* 'c' *) + | Pconst_string of string * string option + (* "constant" + {delim|other constant|delim} + *) + | Pconst_float of string * char option +(* 3.4 2e5 1.4e-4 + + Suffixes [g-z][G-Z] are accepted by the parser. + Suffixes are rejected by the typechecker. +*) + +(** {1 Extension points} *) + +type attribute = string loc * payload +(* [@id ARG] + [@@id ARG] + + Metadata containers passed around within the AST. + The compiler ignores unknown attributes. +*) + +and extension = string loc * payload +(* [%id ARG] + [%%id ARG] + + Sub-language placeholder -- rejected by the typechecker. +*) + +and attributes = attribute list + +and payload = + | PStr of structure + | PSig of signature (* : SIG *) + | PTyp of core_type (* : T *) + | PPat of pattern * expression option +(* ? P or ? P when E *) + +(* Type expressions *) + +(** {1 Core language} *) + +and core_type = { + ptyp_desc: core_type_desc; + ptyp_loc: Location.t; + ptyp_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and core_type_desc = + | Ptyp_any (* _ *) + | Ptyp_var of string (* 'a *) + | Ptyp_arrow of Noloc.arg_label * core_type * core_type + (* T1 -> T2 Simple + ~l:T1 -> T2 Labelled + ?l:T1 -> T2 Optional + *) + | Ptyp_tuple of core_type list + (* T1 * ... * Tn + + Invariant: n >= 2 + *) + | Ptyp_constr of Longident.t loc * core_type list + (* tconstr + T tconstr + (T1, ..., Tn) tconstr + *) + | Ptyp_object of object_field list * closed_flag + (* < l1:T1; ...; ln:Tn > (flag = Closed) + < l1:T1; ...; ln:Tn; .. > (flag = Open) + *) + | Ptyp_class of unit (* dummy AST node *) + | Ptyp_alias of core_type * string (* T as 'a *) + | Ptyp_variant of row_field list * closed_flag * label list option + (* [ `A|`B ] (flag = Closed; labels = None) + [> `A|`B ] (flag = Open; labels = None) + [< `A|`B ] (flag = Closed; labels = Some []) + [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) + *) + | Ptyp_poly of string loc list * core_type + (* 'a1 ... 'an. T + + Can only appear in the following context: + + - As the core_type of a Ppat_constraint node corresponding + to a constraint on a let-binding: let x : 'a1 ... 'an. T + = e ... + + - Under Cfk_virtual for methods (not values). + + - As the core_type of a Pctf_method node. + + - As the core_type of a Pexp_poly node. + + - As the pld_type field of a label_declaration. + + - As a core_type of a Ptyp_object node. + *) + | Ptyp_package of package_type (* (module S) *) + | Ptyp_extension of extension +(* [%id] *) + +and package_type = Longident.t loc * (Longident.t loc * core_type) list +(* + (module S) + (module S with type t1 = T1 and ... and tn = Tn) + *) + +and row_field = + | Rtag of label loc * attributes * bool * core_type list + (* [`A] ( true, [] ) + [`A of T] ( false, [T] ) + [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) + [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + + - The 2nd field is true if the tag contains a + constant (empty) constructor. + - '&' occurs when several types are used for the same constructor + (see 4.2 in the manual) + + - TODO: switch to a record representation, and keep location + *) + | Rinherit of core_type +(* [ T ] *) + +and object_field = + | Otag of label loc * attributes * core_type + | Oinherit of core_type + +(* Patterns *) +and pattern = { + ppat_desc: pattern_desc; + ppat_loc: Location.t; + ppat_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and pattern_desc = + | Ppat_any (* _ *) + | Ppat_var of string loc (* x *) + | Ppat_alias of pattern * string loc (* P as 'a *) + | Ppat_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Ppat_interval of constant * constant + (* 'a'..'z' + + Other forms of interval are recognized by the parser + but rejected by the type-checker. *) + | Ppat_tuple of pattern list (* (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Ppat_construct of Longident.t loc * pattern option + (* C None + C P Some P + C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + *) + | Ppat_variant of label * pattern option + (* `A (None) + `A P (Some P) + *) + | Ppat_record of (Longident.t loc * pattern) list * closed_flag + (* { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Ppat_array of pattern list (* [| P1; ...; Pn |] *) + | Ppat_or of pattern * pattern (* P1 | P2 *) + | Ppat_constraint of pattern * core_type (* (P : T) *) + | Ppat_type of Longident.t loc (* #tconst *) + | Ppat_lazy of pattern (* lazy P *) + | Ppat_unpack of string loc + (* (module P) + Note: (module P : S) is represented as + Ppat_constraint(Ppat_unpack, Ptyp_package) + *) + | Ppat_exception of pattern (* exception P *) + | Ppat_extension of extension (* [%id] *) + | Ppat_open of Longident.t loc * pattern +(* M.(P) *) + +(* Value expressions *) + +and expression = { + pexp_desc: expression_desc; + pexp_loc: Location.t; + (* Hack: made pexp_attributes mutable for use in analysis exe. Please do not use elsewhere! *) + mutable pexp_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and expression_desc = + | Pexp_ident of Longident.t loc (* x + M.x + *) + | Pexp_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Pexp_let of rec_flag * value_binding list * expression + (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Pexp_function of case list (* function P1 -> E1 | ... | Pn -> En *) + | Pexp_fun of Noloc.arg_label * expression option * pattern * expression + (* fun P -> E1 (Simple, None) + fun ~l:P -> E1 (Labelled l, None) + fun ?l:P -> E1 (Optional l, None) + fun ?l:(P = E0) -> E1 (Optional l, Some E0) + + Notes: + - If E0 is provided, only Optional is allowed. + - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - "let f P = E" is represented using Pexp_fun. + *) + | Pexp_apply of expression * (Noloc.arg_label * expression) list + (* E0 ~l1:E1 ... ~ln:En + li can be empty (non labeled argument) or start with '?' + (optional argument). + + Invariant: n > 0 + *) + | Pexp_match of expression * case list + (* match E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_try of expression * case list + (* try E0 with P1 -> E1 | ... | Pn -> En *) + | Pexp_tuple of expression list + (* (E1, ..., En) + + Invariant: n >= 2 + *) + | Pexp_construct of Longident.t loc * expression option + (* C None + C E Some E + C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + *) + | Pexp_variant of label * expression option + (* `A (None) + `A E (Some E) + *) + | Pexp_record of (Longident.t loc * expression) list * expression option + (* { l1=P1; ...; ln=Pn } (None) + { E0 with l1=P1; ...; ln=Pn } (Some E0) + + Invariant: n > 0 + *) + | Pexp_field of expression * Longident.t loc (* E.l *) + | Pexp_setfield of expression * Longident.t loc * expression (* E1.l <- E2 *) + | Pexp_array of expression list (* [| E1; ...; En |] *) + | Pexp_ifthenelse of expression * expression * expression option + (* if E1 then E2 else E3 *) + | Pexp_sequence of expression * expression (* E1; E2 *) + | Pexp_while of expression * expression (* while E1 do E2 done *) + | Pexp_for of pattern * expression * expression * direction_flag * expression + (* for i = E1 to E2 do E3 done (flag = Upto) + for i = E1 downto E2 do E3 done (flag = Downto) + *) + | Pexp_constraint of expression * core_type (* (E : T) *) + | Pexp_coerce of expression * unit * core_type + (* (E :> T) (None, T) + *) + | Pexp_send of expression * label loc (* E # m *) + | Pexp_new of Longident.t loc (* new M.c *) + | Pexp_setinstvar of label loc * expression (* x <- 2 *) + | Pexp_override of (label loc * expression) list + (* {< x1 = E1; ...; Xn = En >} *) + | Pexp_letmodule of string loc * module_expr * expression + (* let module M = ME in E *) + | Pexp_letexception of extension_constructor * expression + (* let exception C in E *) + | Pexp_assert of expression + (* assert E + Note: "assert false" is treated in a special way by the + type-checker. *) + | Pexp_lazy of expression (* lazy E *) + | Pexp_poly of expression * core_type option + (* Used for method bodies. + + Can only be used as the expression under Cfk_concrete + for methods (not values). *) + | Pexp_object of unit (* dummy AST node *) + | Pexp_newtype of string loc * expression (* fun (type t) -> E *) + | Pexp_pack of module_expr + (* (module ME) + + (module ME : S) is represented as + Pexp_constraint(Pexp_pack, Ptyp_package S) *) + | Pexp_open of override_flag * Longident.t loc * expression + (* M.(E) + let open M in E + let! open M in E *) + | Pexp_extension of extension (* [%id] *) + | Pexp_unreachable +(* . *) + +and case = { + (* (P -> E) or (P when E0 -> E) *) + pc_lhs: pattern; + pc_guard: expression option; + pc_rhs: expression; +} + +(* Value descriptions *) +and value_description = { + pval_name: string loc; + pval_type: core_type; + pval_prim: string list; + pval_attributes: attributes; (* ... [@@id1] [@@id2] *) + pval_loc: Location.t; +} + +(* + val x: T (prim = []) + external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) +*) + +(* Type declarations *) +and type_declaration = { + ptype_name: string loc; + ptype_params: (core_type * variance) list; + (* ('a1,...'an) t; None represents _*) + ptype_cstrs: (core_type * core_type * Location.t) list; + (* ... constraint T1=T1' ... constraint Tn=Tn' *) + ptype_kind: type_kind; + ptype_private: private_flag; (* = private ... *) + ptype_manifest: core_type option; (* = T *) + ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + ptype_loc: Location.t; +} + +(* + type t (abstract, no manifest) + type t = T0 (abstract, manifest=T0) + type t = C of T | ... (variant, no manifest) + type t = T0 = C of T | ... (variant, manifest=T0) + type t = {l: T; ...} (record, no manifest) + type t = T0 = {l : T; ...} (record, manifest=T0) + type t = .. (open, no manifest) +*) +and type_kind = + | Ptype_abstract + | Ptype_variant of constructor_declaration list + (* Invariant: non-empty list *) + | Ptype_record of label_declaration list (* Invariant: non-empty list *) + | Ptype_open + +and label_declaration = { + pld_name: string loc; + pld_mutable: mutable_flag; + pld_type: core_type; + pld_loc: Location.t; + pld_attributes: attributes; (* l : T [@id1] [@id2] *) +} + +(* { ...; l: T; ... } (mutable=Immutable) + { ...; mutable l: T; ... } (mutable=Mutable) + + Note: T can be a Ptyp_poly. +*) +and constructor_declaration = { + pcd_name: string loc; + pcd_args: constructor_arguments; + pcd_res: core_type option; + pcd_loc: Location.t; + pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) +} + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + +(* + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) +*) +and type_extension = { + ptyext_path: Longident.t loc; + ptyext_params: (core_type * variance) list; + ptyext_constructors: extension_constructor list; + ptyext_private: private_flag; + ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) +} +(* + type t += ... +*) + +and extension_constructor = { + pext_name: string loc; + pext_kind: extension_constructor_kind; + pext_loc: Location.t; + pext_attributes: attributes; (* C of ... [@id1] [@id2] *) +} + +and extension_constructor_kind = + | Pext_decl of constructor_arguments * core_type option + (* + | C of T1 * ... * Tn ([T1; ...; Tn], None) + | C: T0 ([], Some T0) + | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) + *) + | Pext_rebind of Longident.t loc +(* + | C = D + *) + +(* Type expressions for the module language *) + +(** {1 Module language} *) + +and module_type = { + pmty_desc: module_type_desc; + pmty_loc: Location.t; + pmty_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and module_type_desc = + | Pmty_ident of Longident.t loc (* S *) + | Pmty_signature of signature (* sig ... end *) + | Pmty_functor of string loc * module_type option * module_type + (* functor(X : MT1) -> MT2 *) + | Pmty_with of module_type * with_constraint list (* MT with ... *) + | Pmty_typeof of module_expr (* module type of ME *) + | Pmty_extension of extension (* [%id] *) + | Pmty_alias of Longident.t loc +(* (module M) *) + +and signature = signature_item list + +and signature_item = {psig_desc: signature_item_desc; psig_loc: Location.t} + +and signature_item_desc = + | Psig_value of value_description + (* + val x: T + external x: T = "s1" ... "sn" + *) + | Psig_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Psig_typext of type_extension (* type t1 += ... *) + | Psig_exception of extension_constructor (* exception C of T *) + | Psig_module of module_declaration (* module X : MT *) + | Psig_recmodule of module_declaration list + (* module rec X1 : MT1 and ... and Xn : MTn *) + | Psig_modtype of module_type_declaration + (* module type S = MT + module type S *) + | Psig_open of open_description (* open X *) + | Psig_include of include_description (* include MT *) + | Psig_class of unit (* Dummy AST node *) + | Psig_class_type of unit (* Dummy AST node *) + | Psig_attribute of attribute (* [@@@id] *) + | Psig_extension of extension * attributes +(* [%%id] *) + +and module_declaration = { + pmd_name: string loc; + pmd_type: module_type; + pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmd_loc: Location.t; +} +(* S : MT *) + +and module_type_declaration = { + pmtd_name: string loc; + pmtd_type: module_type option; + pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) + pmtd_loc: Location.t; +} +(* S = MT + S (abstract module type declaration, pmtd_type = None) +*) + +and open_description = { + popen_lid: Longident.t loc; + popen_override: override_flag; + popen_loc: Location.t; + popen_attributes: attributes; +} +(* open! X - popen_override = Override (silences the 'used identifier + shadowing' warning) + open X - popen_override = Fresh +*) + +and 'a include_infos = { + pincl_mod: 'a; + pincl_loc: Location.t; + pincl_attributes: attributes; +} + +and include_description = module_type include_infos +(* include MT *) + +and include_declaration = module_expr include_infos +(* include ME *) + +and with_constraint = + | Pwith_type of Longident.t loc * type_declaration + (* with type X.t = ... + + Note: the last component of the longident must match + the name of the type_declaration. *) + | Pwith_module of Longident.t loc * Longident.t loc (* with module X.Y = Z *) + | Pwith_typesubst of Longident.t loc * type_declaration + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_modsubst of Longident.t loc * Longident.t loc +(* with module X.Y := Z *) + +(* Value expressions for the module language *) + +and module_expr = { + pmod_desc: module_expr_desc; + pmod_loc: Location.t; + pmod_attributes: attributes; (* ... [@id1] [@id2] *) +} + +and module_expr_desc = + | Pmod_ident of Longident.t loc (* X *) + | Pmod_structure of structure (* struct ... end *) + | Pmod_functor of string loc * module_type option * module_expr + (* functor(X : MT1) -> ME *) + | Pmod_apply of module_expr * module_expr (* ME1(ME2) *) + | Pmod_constraint of module_expr * module_type (* (ME : MT) *) + | Pmod_unpack of expression (* (val E) *) + | Pmod_extension of extension +(* [%id] *) + +and structure = structure_item list + +and structure_item = {pstr_desc: structure_item_desc; pstr_loc: Location.t} + +and structure_item_desc = + | Pstr_eval of expression * attributes (* E *) + | Pstr_value of rec_flag * value_binding list + (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN (flag = Recursive) + *) + | Pstr_primitive of value_description + (* val x: T + external x: T = "s1" ... "sn" *) + | Pstr_type of rec_flag * type_declaration list + (* type t1 = ... and ... and tn = ... *) + | Pstr_typext of type_extension (* type t1 += ... *) + | Pstr_exception of extension_constructor + (* exception C of T + exception C = M.X *) + | Pstr_module of module_binding (* module X = ME *) + | Pstr_recmodule of module_binding list + (* module rec X1 = ME1 and ... and Xn = MEn *) + | Pstr_modtype of module_type_declaration (* module type S = MT *) + | Pstr_open of open_description (* open X *) + | Pstr_class of unit (* Dummy AST node *) + | Pstr_class_type of unit (* Dummy AST node *) + | Pstr_include of include_declaration (* include ME *) + | Pstr_attribute of attribute (* [@@@id] *) + | Pstr_extension of extension * attributes +(* [%%id] *) + +and value_binding = { + pvb_pat: pattern; + pvb_expr: expression; + pvb_attributes: attributes; + pvb_loc: Location.t; +} + +and module_binding = { + pmb_name: string loc; + pmb_expr: module_expr; + pmb_attributes: attributes; + pmb_loc: Location.t; +} +(* X = ME *) + +let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr []) +let optional_attr0 = (Location.mknoloc "res.optional", PStr []) + +let add_optional_attr ~optional attrs = + if optional then optional_attr0 :: attrs else attrs + +let get_optional_attr attrs_ = + let remove_optional_attr attrs = + List.filter (fun a -> a <> optional_attr) attrs + in + let attrs = remove_optional_attr attrs_ in + let optional = List.length attrs <> List.length attrs_ in + (optional, attrs) diff --git a/compiler/ml/path.ml b/compiler/ml/path.ml new file mode 100644 index 0000000..d3c78a3 --- /dev/null +++ b/compiler/ml/path.ml @@ -0,0 +1,106 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +type t = Pident of Ident.t | Pdot of t * string * int | Papply of t * t + +let nopos = -1 + +let rec same p1 p2 = + match (p1, p2) with + | Pident id1, Pident id2 -> Ident.same id1 id2 + | Pdot (p1, s1, _pos1), Pdot (p2, s2, _pos2) -> s1 = s2 && same p1 p2 + | Papply (fun1, arg1), Papply (fun2, arg2) -> same fun1 fun2 && same arg1 arg2 + | _, _ -> false + +let rec compare p1 p2 = + match (p1, p2) with + | Pident id1, Pident id2 -> Ident.compare id1 id2 + | Pdot (p1, s1, _pos1), Pdot (p2, s2, _pos2) -> + let h = compare p1 p2 in + if h <> 0 then h else String.compare s1 s2 + | Papply (fun1, arg1), Papply (fun2, arg2) -> + let h = compare fun1 fun2 in + if h <> 0 then h else compare arg1 arg2 + | (Pident _ | Pdot _), (Pdot _ | Papply _) -> -1 + | (Pdot _ | Papply _), (Pident _ | Pdot _) -> 1 + +let rec isfree id = function + | Pident id' -> Ident.same id id' + | Pdot (p, _s, _pos) -> isfree id p + | Papply (p1, p2) -> isfree id p1 || isfree id p2 + +let rec binding_time = function + | Pident id -> Ident.binding_time id + | Pdot (p, _s, _pos) -> binding_time p + | Papply (p1, p2) -> + Ext_pervasives.max_int (binding_time p1) (binding_time p2) + +let kfalse _ = false + +let rec name ?(paren = kfalse) = function + | Pident id -> Ident.name id + | Pdot (p, s, _pos) -> + name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s + | Papply (p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" + +let rec head = function + | Pident id -> id + | Pdot (p, _s, _pos) -> head p + | Papply _ -> assert false + +let flatten = + let rec flatten acc = function + | Pident id -> `Ok (id, acc) + | Pdot (p, s, _) -> flatten (s :: acc) p + | Papply _ -> `Contains_apply + in + fun t -> flatten [] t + +let heads p = + let rec heads p acc = + match p with + | Pident id -> id :: acc + | Pdot (p, _s, _pos) -> heads p acc + | Papply (p1, p2) -> heads p1 (heads p2 acc) + in + heads p [] + +let rec last = function + | Pident id -> Ident.name id + | Pdot (_, s, _) -> s + | Papply (_, p) -> last p + +let is_uident s = + assert (s <> ""); + match s.[0] with + | 'A' .. 'Z' -> true + | _ -> false + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +let constructor_typath = function + | Pident id when is_uident (Ident.name id) -> LocalExt id + | Pdot (ty_path, s, _) when is_uident s -> + if is_uident (last ty_path) then Ext (ty_path, s) else Cstr (ty_path, s) + | p -> Regular p + +let is_constructor_typath p = + match constructor_typath p with + | Regular _ -> false + | _ -> true diff --git a/compiler/ml/path.mli b/compiler/ml/path.mli new file mode 100644 index 0000000..0c24ae1 --- /dev/null +++ b/compiler/ml/path.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Access paths *) + +type t = Pident of Ident.t | Pdot of t * string * int | Papply of t * t + +val same : t -> t -> bool +val compare : t -> t -> int +val isfree : Ident.t -> t -> bool +val binding_time : t -> int +val flatten : t -> [`Contains_apply | `Ok of Ident.t * string list] + +val nopos : int + +val name : ?paren:(string -> bool) -> t -> string +(* [paren] tells whether a path suffix needs parentheses *) + +val head : t -> Ident.t + +val heads : t -> Ident.t list + +val last : t -> string + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +val constructor_typath : t -> typath +val is_constructor_typath : t -> bool diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml new file mode 100644 index 0000000..585ac64 --- /dev/null +++ b/compiler/ml/pprintast.ml @@ -0,0 +1,1361 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire, OCamlPro *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* Hongbo Zhang, University of Pennsylvania *) +(* *) +(* Copyright 2007 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. *) +(* *) +(**************************************************************************) + +(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) +(* Printing code expressions *) +(* Authors: Ed Pizzi, Fabrice Le Fessant *) +(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) +(* TODO more fine-grained precedence pretty-printing *) + +open Asttypes +open Format +open Location +open Longident +open Parsetree +open Ast_helper + +let prefix_symbols = ['!'; '?'; '~'] +let infix_symbols = + ['='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%'; '#'] + +(* type fixity = Infix| Prefix *) +let special_infix_strings = + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::"] + +(* determines if the string is an infix string. + checks backwards, first allowing a renaming postfix ("_102") which + may have resulted from Pexp -> Texp -> Pexp translation, then checking + if all the characters in the beginning of the string are valid infix + characters. *) +let fixity_of_string = function + | s when List.mem s special_infix_strings -> `Infix s + | s when List.mem s.[0] infix_symbols -> `Infix s + | s when List.mem s.[0] prefix_symbols -> `Prefix s + | s when s.[0] = '.' -> `Mixfix s + | _ -> `Normal + +let view_fixity_of_exp = function + | {pexp_desc = Pexp_ident {txt = Lident l; _}; pexp_attributes = []} -> + fixity_of_string l + | _ -> `Normal + +let is_infix = function + | `Infix _ -> true + | _ -> false +let is_mixfix = function + | `Mixfix _ -> true + | _ -> false + +(* which identifiers are in fact operators needing parentheses *) +let needs_parens txt = + let fix = fixity_of_string txt in + is_infix fix || is_mixfix fix || List.mem txt.[0] prefix_symbols + +(* some infixes need spaces around parens to avoid clashes with comment + syntax *) +let needs_spaces txt = txt.[0] = '*' || txt.[String.length txt - 1] = '*' + +(* add parentheses to binders when they are in fact infix or prefix operators *) +let protect_ident ppf txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%s" + else if needs_spaces txt then "(@;%s@;)" + else "(%s)" + in + fprintf ppf format txt + +let protect_longident ppf print_longident longprefix txt = + let format : (_, _, _) format = + if not (needs_parens txt) then "%a.%s" + else if needs_spaces txt then "%a.(@;%s@;)" + else "%a.(%s)" + in + fprintf ppf format print_longident longprefix txt + +type space_formatter = (unit, Format.formatter, unit) format + +let override = function + | Override -> "!" + | Fresh -> "" + +(* variance encoding: need to sync up with the [parser.mly] *) +let type_variance = function + | Invariant -> "" + | Covariant -> "+" + | Contravariant -> "-" + +type construct = + [ `cons of expression list + | `list of expression list + | `nil + | `normal + | `simple of Longident.t + | `tuple ] + +let view_expr x = + match x.pexp_desc with + | Pexp_construct ({txt = Lident "()"; _}, _) -> `tuple + | Pexp_construct ({txt = Lident "[]"; _}, _) -> `nil + | Pexp_construct ({txt = Lident "::"; _}, Some _) -> + let rec loop exp acc = + match exp with + | { + pexp_desc = Pexp_construct ({txt = Lident "[]"; _}, _); + pexp_attributes = []; + } -> + (List.rev acc, true) + | { + pexp_desc = + Pexp_construct + ( {txt = Lident "::"; _}, + Some {pexp_desc = Pexp_tuple [e1; e2]; pexp_attributes = []} ); + pexp_attributes = []; + } -> + loop e2 (e1 :: acc) + | e -> (List.rev (e :: acc), false) + in + let ls, b = loop x [] in + if b then `list ls else `cons ls + | Pexp_construct (x, None) -> `simple x.txt + | _ -> `normal + +let is_simple_construct : construct -> bool = function + | `nil | `tuple | `list _ | `simple _ -> true + | `cons _ | `normal -> false + +let pp = fprintf + +type ctxt = {pipe: bool; semi: bool; ifthenelse: bool} + +let reset_ctxt = {pipe = false; semi = false; ifthenelse = false} +let under_pipe ctxt = {ctxt with pipe = true} +let under_semi ctxt = {ctxt with semi = true} +let under_ifthenelse ctxt = {ctxt with ifthenelse = true} +(* +let reset_semi ctxt = { ctxt with semi=false } +let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } +let reset_pipe ctxt = { ctxt with pipe=false } +*) + +let list : + 'a. + ?sep:space_formatter -> + ?first:space_formatter -> + ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a list -> + unit = + fun ?sep ?first ?last fu f xs -> + let first = + match first with + | Some x -> x + | None -> ("" : _ format6) + and last = + match last with + | Some x -> x + | None -> ("" : _ format6) + and sep = + match sep with + | Some x -> x + | None -> ("@ " : _ format6) + in + let aux f = function + | [] -> () + | [x] -> fu f x + | xs -> + let rec loop f = function + | [x] -> fu f x + | x :: xs -> + fu f x; + pp f sep; + loop f xs + | _ -> assert false + in + pp f first; + loop f xs; + pp f last + in + aux f xs + +let option : + 'a. + ?first:space_formatter -> + ?last:space_formatter -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a option -> + unit = + fun ?first ?last fu f a -> + let first = + match first with + | Some x -> x + | None -> ("" : _ format6) + and last = + match last with + | Some x -> x + | None -> ("" : _ format6) + in + match a with + | None -> () + | Some x -> + pp f first; + fu f x; + pp f last + +let paren : + 'a. + ?first:space_formatter -> + ?last:space_formatter -> + bool -> + (Format.formatter -> 'a -> unit) -> + Format.formatter -> + 'a -> + unit = + fun ?(first = ("" : _ format6)) ?(last = ("" : _ format6)) b fu f x -> + if b then ( + pp f "("; + pp f first; + fu f x; + pp f last; + pp f ")") + else fu f x + +let rec longident f = function + | Lident s -> protect_ident f s + | Ldot (y, s) -> protect_longident f longident y s + | Lapply (y, s) -> pp f "%a(%a)" longident y longident s + +let longident_loc f x = pp f "%a" longident x.txt + +let string_of_int_as_char i = Ext_util.string_of_int_as_char i + +let constant f = function + | Pconst_char i -> pp f "%s" (string_of_int_as_char i) + | Pconst_string (i, None) -> pp f "%S" i + | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim + | Pconst_integer (i, None) -> paren (i.[0] = '-') (fun f -> pp f "%s") f i + | Pconst_integer (i, Some m) -> + paren (i.[0] = '-') (fun f (i, m) -> pp f "%s%c" i m) f (i, m) + | Pconst_float (i, None) -> paren (i.[0] = '-') (fun f -> pp f "%s") f i + | Pconst_float (i, Some m) -> + paren (i.[0] = '-') (fun f (i, m) -> pp f "%s%c" i m) f (i, m) + +(* trailing space*) +let mutable_flag f = function + | Immutable -> () + | Mutable -> pp f "mutable@;" + +let optional_flag f = function + | false -> () + | true -> pp f "?" + +(* trailing space added *) +let rec_flag f rf = + match rf with + | Nonrecursive -> () + | Recursive -> pp f "rec " +let nonrec_flag f rf = + match rf with + | Nonrecursive -> pp f "nonrec " + | Recursive -> () +let direction_flag f = function + | Upto -> pp f "to@ " + | Downto -> pp f "downto@ " +let private_flag f = function + | Public -> () + | Private -> pp f "private@ " + +let constant_string f s = pp f "%S" s +let tyvar f str = pp f "'%s" str +let tyvar_loc f str = pp f "'%s" str.txt +let string_quot f x = pp f "`%s" x + +let rec type_with_label ctxt f arg = + match arg.lbl with + | Nolabel -> + pp f "%a%a" (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs + (* otherwise parenthesize *) + | Labelled {txt = s} -> + pp f "%s:%a%a" s (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs + | Optional {txt = s} -> + pp f "?%s:%a%a" s (core_type1 ctxt) arg.typ (attributes ctxt) arg.attrs + +and core_type ctxt f x = + if x.ptyp_attributes <> [] then + pp f "((%a)%a)" (core_type ctxt) + {x with ptyp_attributes = []} + (attributes ctxt) x.ptyp_attributes + else + match x.ptyp_desc with + | Ptyp_arrow {arg; ret; arity} -> + pp f "@[<2>%a@;->@;%a%s@]" (* FIXME remove parens later *) + (type_with_label ctxt) arg (core_type ctxt) ret + (match arity with + | None -> "" + | Some n -> " (a:" ^ string_of_int n ^ ")") + | Ptyp_alias (ct, s) -> pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s + | Ptyp_poly ([], ct) -> core_type ctxt f ct + | Ptyp_poly (sl, ct) -> + pp f "@[<2>%a%a@]" + (fun f l -> + pp f "%a" + (fun f l -> + match l with + | [] -> () + | _ -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") l) + l) + sl (core_type ctxt) ct + | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x + +and core_type1 ctxt f x = + if x.ptyp_attributes <> [] then core_type ctxt f x + else + match x.ptyp_desc with + | Ptyp_any -> pp f "_" + | Ptyp_var s -> tyvar f s + | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Ptyp_constr (li, l) -> + pp f (* "%a%a@;" *) "%a%a" + (fun f l -> + match l with + | [] -> () + | [x] -> pp f "%a@;" (core_type1 ctxt) x + | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) + l longident_loc li + | Ptyp_variant (l, closed, low) -> + let type_variant_helper f x = + match x with + | Rtag (l, attrs, _, ctl) -> + pp f "@[<2>%a%a@;%a@]" string_quot l.txt + (fun f l -> + match l with + | [] -> () + | _ -> pp f "@;of@;%a" (list (core_type ctxt) ~sep:"&") ctl) + ctl (attributes ctxt) attrs + | Rinherit ct -> core_type ctxt f ct + in + pp f "@[<2>[%a%a]@]" + (fun f l -> + match (l, closed) with + | [], Closed -> () + | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) + | _ -> + pp f "%s@;%a" + (match (closed, low) with + | Closed, None -> "" + | Closed, Some _ -> "<" (* FIXME desugar the syntax sugar*) + | Open, _ -> ">") + (list type_variant_helper ~sep:"@;<1 -2>| ") + l) + l + (fun f low -> + match low with + | Some [] | None -> () + | Some xs -> pp f ">@ %a" (list string_quot) xs) + low + | Ptyp_object (l, o) -> + let core_field_type f = function + | Otag (l, attrs, ct) -> + pp f "@[%s: %a@ %a@ @]" l.txt (core_type ctxt) ct + (attributes ctxt) attrs (* Cf #7200 *) + | Oinherit ct -> pp f "@[%a@ @]" (core_type ctxt) ct + in + let field_var f = function + | Asttypes.Closed -> () + | Asttypes.Open -> ( + match l with + | [] -> pp f ".." + | _ -> pp f " ;..") + in + pp f "@[<@ %a%a@ > @]" + (list core_field_type ~sep:";") + l field_var o (* Cf #7200 *) + | Ptyp_package (lid, cstrs) -> ( + let aux f (s, ct) = + pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct + in + match cstrs with + | [] -> pp f "@[(module@ %a)@]" longident_loc lid + | _ -> + pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid + (list aux ~sep:"@ and@ ") cstrs) + | Ptyp_extension e -> extension ctxt f e + | _ -> paren true (core_type ctxt) f x + +(********************pattern********************) +(* be cautious when use [pattern], [pattern1] is preferred *) +and pattern ctxt f x = + let rec list_of_pattern acc = function + (* only consider ((A|B)|C)*) + | {ppat_desc = Ppat_or (p1, p2); ppat_attributes = []} -> + list_of_pattern (p2 :: acc) p1 + | x -> x :: acc + in + if x.ppat_attributes <> [] then + pp f "((%a)%a)" (pattern ctxt) + {x with ppat_attributes = []} + (attributes ctxt) x.ppat_attributes + else + match x.ppat_desc with + | Ppat_alias (p, s) -> + pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) + | Ppat_or _ -> + (* *) + pp f "@[%a@]" + (list ~sep:"@,|" (pattern ctxt)) + (list_of_pattern [] x) + | _ -> pattern1 ctxt f x + +and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = + let rec pattern_list_helper f = function + | { + ppat_desc = + Ppat_construct + ( {txt = Lident "::"; _}, + Some {ppat_desc = Ppat_tuple [pat1; pat2]; _} ); + ppat_attributes = []; + } -> + pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) + | p -> pattern1 ctxt f p + in + if x.ppat_attributes <> [] then pattern ctxt f x + else + match x.ppat_desc with + | Ppat_variant (l, Some p) -> + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_construct ({txt = Lident ("()" | "[]"); _}, _) -> + simple_pattern ctxt f x + | Ppat_construct (({txt; _} as li), po) -> ( + if + (* FIXME The third field always false *) + txt = Lident "::" + then pp f "%a" pattern_list_helper x + else + match po with + | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | None -> pp f "%a" longident_loc li) + | _ -> simple_pattern ctxt f x + +and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = + if x.ppat_attributes <> [] then pattern ctxt f x + else + match x.ppat_desc with + | Ppat_construct ({txt = Lident (("()" | "[]") as x); _}, _) -> pp f "%s" x + | Ppat_any -> pp f "_" + | Ppat_var {txt; _} -> protect_ident f txt + | Ppat_array l -> pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l + | Ppat_unpack s -> pp f "(module@ %s)@ " s.txt + | Ppat_type li -> pp f "#%a" longident_loc li + | Ppat_record (l, closed) -> ( + let longident_x_pattern f {lid = li; x = p; opt} = + let opt_str = if opt then "?" else "" in + match (li, p) with + | ( {txt = Lident s; _}, + {ppat_desc = Ppat_var {txt; _}; ppat_attributes = []; _} ) + when s = txt -> + pp f "@[<2>%a%s@]" longident_loc li opt_str + | _ -> + pp f "@[<2>%a%s@;=@;%a@]" longident_loc li opt_str (pattern1 ctxt) p + in + match closed with + | Closed -> pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l + | _ -> pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l) + | Ppat_tuple l -> + pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) + | Ppat_constant c -> pp f "%a" constant c + | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 + | Ppat_variant (l, None) -> pp f "`%s" l + | Ppat_constraint (p, ct) -> + pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct + | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p + | Ppat_extension e -> extension ctxt f e + | Ppat_open (lid, p) -> + let with_paren = + match p.ppat_desc with + | Ppat_array _ | Ppat_record _ + | Ppat_construct ({txt = Lident ("()" | "[]"); _}, _) -> + false + | _ -> true + in + pp f "@[<2>%a.%a @]" longident_loc lid + (paren with_paren @@ pattern1 ctxt) + p + | _ -> paren true (pattern ctxt) f x + +and label_exp ctxt f (l, opt, p) = + match l with + | Nolabel -> + (* single case pattern parens needed here *) + pp f "%a@ " (simple_pattern ctxt) p + | Optional {txt = rest} -> ( + match p with + | {ppat_desc = Ppat_var {txt; _}; ppat_attributes = []} when txt = rest -> ( + match opt with + | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o + | None -> pp f "?%s@ " rest) + | _ -> ( + match opt with + | Some o -> + pp f "?%s:(%a=@;%a)@;" rest (pattern1 ctxt) p (expression ctxt) o + | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p)) + | Labelled {txt = l} -> ( + match p with + | {ppat_desc = Ppat_var {txt; _}; ppat_attributes = []} when txt = l -> + pp f "~%s@;" l + | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p) + +and sugar_expr ctxt f e = + if e.pexp_attributes <> [] then false + else + match e.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = id; _}; pexp_attributes = []; _}; + args; + } + when List.for_all (fun (lab, _) -> lab = Nolabel) args -> ( + let print_indexop a path_prefix assign left right print_index indices + rem_args = + let print_path ppf = function + | None -> () + | Some m -> pp ppf ".%a" longident m + in + match (assign, rem_args) with + | false, [] -> + pp f "@[%a%a%s%a%s@]" (simple_expr ctxt) a print_path path_prefix left + (list ~sep:"," print_index) + indices right; + true + | true, [v] -> + pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" (simple_expr ctxt) a print_path + path_prefix left + (list ~sep:"," print_index) + indices right (simple_expr ctxt) v; + true + | _ -> false + in + match (id, List.map snd args) with + | Lident "!", [e] -> + pp f "@[!%a@]" (simple_expr ctxt) e; + true + | Ldot (path, (("get" | "set") as func)), a :: other_args -> ( + let assign = func = "set" in + let print = print_indexop a None assign in + match (path, other_args) with + | Lident "Array", i :: rest -> print ".(" ")" (expression ctxt) [i] rest + | Lident "String", i :: rest -> + print ".[" "]" (expression ctxt) [i] rest + | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1] rest + | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2] rest + | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> + print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest + | ( Ldot (Lident "Bigarray", "Genarray"), + {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest ) -> + print ".{" "}" (simple_expr ctxt) indexes rest + | _ -> false) + | (Lident s | Ldot (_, s)), a :: i :: rest when s.[0] = '.' -> + let n = String.length s in + (* extract operator: + assignment operators end with [right_bracket ^ "<-"], + access operators end with [right_bracket] directly + *) + let assign = s.[n - 1] = '-' in + let kind = + (* extract the right end bracket *) + if assign then s.[n - 3] else s.[n - 1] + in + let left, right = + match kind with + | ')' -> ('(', ")") + | ']' -> ('[', "]") + | '}' -> ('{', "}") + | _ -> assert false + in + let path_prefix = + match id with + | Ldot (m, _) -> Some m + | _ -> None + in + let left = String.sub s 0 (1 + String.index s left) in + print_indexop a path_prefix assign left right (expression ctxt) [i] rest + | _ -> false) + | _ -> false + +and expression ctxt f x = + if x.pexp_attributes <> [] then + pp f "((%a)@,%a)" (expression ctxt) + {x with pexp_attributes = []} + (attributes ctxt) x.pexp_attributes + else + match x.pexp_desc with + | (Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _) + when ctxt.pipe || ctxt.semi -> + paren true (expression reset_ctxt) f x + | (Pexp_ifthenelse _ | Pexp_sequence _) when ctxt.ifthenelse -> + paren true (expression reset_ctxt) f x + | (Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _) + when ctxt.semi -> + paren true (expression reset_ctxt) f x + | Pexp_fun {arg_label = l; default = e0; lhs = p; rhs = e; arity; async} -> + let arity_str = + match arity with + | None -> "" + | Some arity -> "[arity:" ^ string_of_int arity ^ "]" + in + let async_str = if async then "async " else "" in + pp f "@[<2>%sfun@;%s%a->@;%a@]" async_str arity_str (label_exp ctxt) + (l, e0, p) (expression ctxt) e + | Pexp_match (e, l) -> + pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) e + (case_list ctxt) l + | Pexp_try (e, l) -> + pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" + (* "try@;@[<2>%a@]@\nwith@\n%a"*) + (expression reset_ctxt) + e (case_list ctxt) l + | Pexp_let (rf, l, e) -> + (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" + (*no indentation here, a new line*) *) + (* rec_flag rf *) + pp f "@[<2>%a in@;<1 -2>%a@]" (bindings reset_ctxt) (rf, l) + (expression ctxt) e + | Pexp_apply {funct = e; args = l; partial} -> ( + if not (sugar_expr ctxt f x) then + match view_fixity_of_exp e with + | `Infix s -> ( + match l with + | [((Nolabel, _) as arg1); ((Nolabel, _) as arg2)] -> + (* FIXME associativity label_x_expression_param *) + pp f "@[<2>%a@;%s@;%a@]" + (label_x_expression_param reset_ctxt) + arg1 s + (label_x_expression_param ctxt) + arg2 + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) + l) + | `Prefix s -> ( + let s = + if + List.mem s ["~+"; "~-"; "~+."; "~-."; "~~"] + && + match l with + (* See #7200: avoid turning (~- 1) into (- 1) which is + parsed as an int literal *) + | [(_, {pexp_desc = Pexp_constant _})] -> false + | _ -> true + then String.sub s 1 (String.length s - 1) + else s + in + match l with + | [(Nolabel, x)] -> pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x + | _ -> + pp f "@[<2>%a %a@]" (simple_expr ctxt) e + (list (label_x_expression_param ctxt)) + l) + | _ -> + let partial_str = if partial then " ..." else "" in + pp f "@[%a%s@]" + (fun f (e, l) -> + pp f "%a@ %a" (expression2 ctxt) e + (list (label_x_expression_param reset_ctxt)) + l) + (* reset here only because [function,match,try,sequence] + are lower priority *) + (e, l) partial_str) + | Pexp_construct (li, Some eo) when not (is_simple_construct (view_expr x)) + -> ( + (* Not efficient FIXME*) + match view_expr x with + | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" + | `normal -> pp f "@[<2>%a@;%a@]" longident_loc li (simple_expr ctxt) eo + | _ -> assert false) + | Pexp_setfield (e1, li, e2) -> + pp f "@[<2>%a.%a@ <-@ %a@]" (simple_expr ctxt) e1 longident_loc li + (simple_expr ctxt) e2 + | Pexp_ifthenelse (e1, e2, eo) -> + (* @;@[<2>else@ %a@]@] *) + let fmt : (_, _, _) format = + "@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" + in + let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in + pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 + (fun f eo -> + match eo with + | Some x -> pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x + | None -> () (* pp f "()" *)) + eo + | Pexp_sequence _ -> + let rec sequence_helper acc = function + | {pexp_desc = Pexp_sequence (e1, e2); pexp_attributes = []} -> + sequence_helper (e1 :: acc) e2 + | v -> List.rev (v :: acc) + in + let lst = sequence_helper [] x in + pp f "@[%a@]" (list (expression (under_semi ctxt)) ~sep:";@;") lst + | Pexp_letmodule (s, me, e) -> + pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt + (module_expr reset_ctxt) me (expression ctxt) e + | Pexp_letexception (cd, e) -> + pp f "@[let@ exception@ %a@ in@ %a@]" + (extension_constructor ctxt) + cd (expression ctxt) e + | Pexp_assert e -> pp f "@[assert@ %a@]" (simple_expr ctxt) e + | Pexp_open (ovf, lid, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + (expression ctxt) e + | Pexp_variant (l, Some eo) -> pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_extension e -> extension ctxt f e + | Pexp_await e -> pp f "@[await@ %a@]" (simple_expr ctxt) e + | _ -> expression1 ctxt f x + +and expression1 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x else expression2 ctxt f x +(* used in [Pexp_apply] *) + +and expression2 ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else + match x.pexp_desc with + | Pexp_field (e, li) -> + pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li + | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt + | _ -> simple_expr ctxt f x + +and simple_expr ctxt f x = + if x.pexp_attributes <> [] then expression ctxt f x + else + match x.pexp_desc with + | Pexp_construct _ when is_simple_construct (view_expr x) -> ( + match view_expr x with + | `nil -> pp f "[]" + | `tuple -> pp f "()" + | `list xs -> + pp f "@[[%a]@]" (list (expression (under_semi ctxt)) ~sep:";@;") xs + | `simple x -> longident f x + | _ -> assert false) + | Pexp_ident li -> longident_loc f li + (* (match view_fixity_of_exp x with *) + (* |`Normal -> longident_loc f li *) + (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) + | Pexp_constant c -> constant f c + | Pexp_pack me -> pp f "(module@;%a)" (module_expr ctxt) me + | Pexp_newtype (lid, e) -> + pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e + | Pexp_tuple l -> + pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l + | Pexp_constraint (e, ct) -> + pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_coerce (e, (), ct) -> + pp f "(%a :> %a)" (expression ctxt) e (core_type ctxt) ct + | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_record (l, eo) -> + let longident_x_expression f {lid = li; x = e; opt} = + let opt_str = if opt then "?" else "" in + match e with + | {pexp_desc = Pexp_ident {txt; _}; pexp_attributes = []; _} + when li.txt = txt -> + pp f "@[%a%s@]" longident_loc li opt_str + | _ -> + pp f "@[%a@;=@;%s%a@]" longident_loc li opt_str + (simple_expr ctxt) e + in + pp f "@[@[{@;%a%a@]@;}@]" (* "@[{%a%a}@]" *) + (option ~last:" with@;" (simple_expr ctxt)) + eo + (list longident_x_expression ~sep:";@;") + l + | Pexp_array l -> + pp f "@[<0>@[<2>[|%a|]@]@]" + (list (simple_expr (under_semi ctxt)) ~sep:";") + l + | Pexp_while (e1, e2) -> + let fmt : (_, _, _) format = "@[<2>while@;%a@;do@;%a@;done@]" in + pp f fmt (expression ctxt) e1 (expression ctxt) e2 + | Pexp_for (s, e1, e2, df, e3) -> + let fmt : (_, _, _) format = + "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" + in + let expression = expression ctxt in + pp f fmt (pattern ctxt) s expression e1 direction_flag df expression e2 + expression e3 + | Pexp_jsx_element (Jsx_fragment {jsx_fragment_children = children}) -> + pp f "<>%a" (list (simple_expr ctxt)) children + | Pexp_jsx_element + (Jsx_unary_element + { + jsx_unary_element_tag_name = tag_name; + jsx_unary_element_props = props; + }) -> ( + let name = Ast_helper.Jsx.string_of_jsx_tag_name tag_name.txt in + match props with + | [] -> pp f "<%s />" name + | _ -> pp f "<%s %a />" name (print_jsx_props ctxt) props) + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = tag_name; + jsx_container_element_props = props; + jsx_container_element_children = children; + jsx_container_element_closing_tag = closing_tag; + }) -> ( + let name = Ast_helper.Jsx.string_of_jsx_tag_name tag_name.txt in + let closing_name = + match closing_tag with + | None -> "" + | Some closing_tag -> + Format.sprintf "" + (Ast_helper.Jsx.string_of_jsx_tag_name + closing_tag.jsx_closing_container_tag_name.txt) + in + match props with + | [] -> + pp f "<%s>%a%s" name (list (simple_expr ctxt)) children closing_name + | _ -> + pp f "<%s %a>%a%s" name (print_jsx_props ctxt) props + (list (simple_expr ctxt)) + children closing_name) + | _ -> paren true (expression ctxt) f x + +and print_jsx_prop ctxt f = function + | JSXPropPunning (is_optional, name) -> + pp f "%s" (if is_optional then "?" ^ name.txt else name.txt) + | JSXPropValue (name, is_optional, value) -> + pp f "%s=%s%a" name.txt + (if is_optional then "?" else "") + (simple_expr ctxt) value + | JSXPropSpreading (_, expr) -> pp f "{...%a}" (simple_expr ctxt) expr + +and print_jsx_props ctxt f = list ~sep:" " (print_jsx_prop ctxt) f + +and attributes ctxt f l = List.iter (attribute ctxt f) l + +and item_attributes ctxt f l = List.iter (item_attribute ctxt f) l + +and attribute ctxt f (s, e) = pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e + +and item_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and floating_attribute ctxt f (s, e) = + pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e + +and value_description ctxt f x = + (* note: value_description has an attribute field, + but they're already printed by the callers this method *) + pp f "@[%a%a@]" (core_type ctxt) x.pval_type + (fun f x -> + if x.pval_prim <> [] then + pp f "@ =@ %a" (list constant_string) x.pval_prim) + x + +and extension ctxt f (s, e) = pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e + +and item_extension ctxt f (s, e) = + pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e + +and exception_declaration ctxt f ext = + pp f "@[exception@ %a@]" (extension_constructor ctxt) ext + +and module_type ctxt f x = + if x.pmty_attributes <> [] then + pp f "((%a)%a)" (module_type ctxt) + {x with pmty_attributes = []} + (attributes ctxt) x.pmty_attributes + else + match x.pmty_desc with + | Pmty_ident li -> pp f "%a" longident_loc li + | Pmty_alias li -> pp f "(module %a)" longident_loc li + | Pmty_signature s -> + pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) + (list (signature_item ctxt)) + s (* FIXME wrong indentation*) + | Pmty_functor (_, None, mt2) -> + pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 + | Pmty_functor (s, Some mt1, mt2) -> + if s.txt = "_" then + pp f "@[%a@ ->@ %a@]" (module_type ctxt) mt1 (module_type ctxt) + mt2 + else + pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt (module_type ctxt) + mt1 (module_type ctxt) mt2 + | Pmty_with (mt, l) -> ( + let with_constraint f = function + | Pwith_type (li, ({ptype_params = ls; _} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2 + | Pwith_typesubst (li, ({ptype_params = ls; _} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 + in + match l with + | [] -> pp f "@[%a@]" (module_type ctxt) mt + | _ -> + pp f "@[(%a@ with@ %a)@]" (module_type ctxt) mt + (list with_constraint ~sep:"@ and@ ") + l) + | Pmty_typeof me -> + pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me + | Pmty_extension e -> extension ctxt f e + +and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x + +and signature_item ctxt f x : unit = + match x.psig_desc with + | Psig_type (rf, l) -> type_def_list ctxt f (rf, l) + | Psig_value vd -> + let intro = if vd.pval_prim = [] then "val" else "external" in + pp f "@[<2>%s@ %a@ :@ %a@]%a" intro protect_ident vd.pval_name.txt + (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes + | Psig_typext te -> type_extension ctxt f te + | Psig_exception ed -> exception_declaration ctxt f ed + | Psig_module + ({pmd_type = {pmty_desc = Pmty_alias alias; pmty_attributes = []; _}; _} + as pmd) -> + pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt longident_loc alias + (item_attributes ctxt) pmd.pmd_attributes + | Psig_module pmd -> + pp f "@[module@ %s@ :@ %a@]%a" pmd.pmd_name.txt (module_type ctxt) + pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes + | Psig_open od -> + pp f "@[open%s@ %a@]%a" + (override od.popen_override) + longident_loc od.popen_lid (item_attributes ctxt) od.popen_attributes + | Psig_include incl -> + pp f "@[include@ %a@]%a" (module_type ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Psig_modtype {pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs} -> + pp f "@[module@ type@ %s%a@]%a" s.txt + (fun f md -> + match md with + | None -> () + | Some mt -> + pp_print_space f (); + pp f "@ =@ %a" (module_type ctxt) mt) + md (item_attributes ctxt) attrs + | Psig_recmodule decls -> + let rec string_x_module_type_list f ?(first = true) l = + match l with + | [] -> () + | pmd :: tl -> + if not first then + pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt (module_type ctxt) + pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes + else + pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt + (module_type ctxt) pmd.pmd_type (item_attributes ctxt) + pmd.pmd_attributes; + string_x_module_type_list f ~first:false tl + in + string_x_module_type_list f decls + | Psig_attribute a -> floating_attribute ctxt f a + | Psig_extension (e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and module_expr ctxt f x = + if x.pmod_attributes <> [] then + pp f "((%a)%a)" (module_expr ctxt) + {x with pmod_attributes = []} + (attributes ctxt) x.pmod_attributes + else + match x.pmod_desc with + | Pmod_structure s -> + pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" + (list (structure_item ctxt) ~sep:"@\n") + s + | Pmod_constraint (me, mt) -> + pp f "@[(%a@ :@ %a)@]" (module_expr ctxt) me (module_type ctxt) mt + | Pmod_ident li -> pp f "%a" longident_loc li + | Pmod_functor (_, None, me) -> + pp f "functor ()@;->@;%a" (module_expr ctxt) me + | Pmod_functor (s, Some mt, me) -> + pp f "functor@ (%s@ :@ %a)@;->@;%a" s.txt (module_type ctxt) mt + (module_expr ctxt) me + | Pmod_apply (me1, me2) -> + pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 + (* Cf: #7200 *) + | Pmod_unpack e -> pp f "(val@ %a)" (expression ctxt) e + | Pmod_extension e -> extension ctxt f e + +and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x + +and payload ctxt f = function + | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> + pp f "@[<2>%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs + | PStr x -> structure ctxt f x + | PTyp x -> + pp f ":"; + core_type ctxt f x + | PSig x -> + pp f ":"; + signature ctxt f x + | PPat (x, None) -> + pp f "?"; + pattern ctxt f x + | PPat (x, Some e) -> + pp f "?"; + pattern ctxt f x; + pp f " when "; + expression ctxt f e + +(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) +and binding ctxt f {pvb_pat = p; pvb_expr = x; _} = + (* .pvb_attributes have already been printed by the caller, #bindings *) + let rec pp_print_pexp_function f x = + if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x + else + match x.pexp_desc with + | Pexp_fun + {arg_label = label; default = eo; lhs = p; rhs = e; arity; async} -> + let arity_str = + match arity with + | None -> "" + | Some arity -> "[arity:" ^ string_of_int arity ^ "]" + in + let async_str = if async then "async " else "" in + if label = Nolabel then + pp f "%s%s%a@ %a" async_str arity_str (simple_pattern ctxt) p + pp_print_pexp_function e + else + pp f "%s%s%a@ %a" async_str arity_str (label_exp ctxt) (label, eo, p) + pp_print_pexp_function e + | Pexp_newtype (str, e) -> + pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e + | _ -> pp f "=@;%a" (expression ctxt) x + in + let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in + let is_desugared_gadt p e = + let gadt_pattern = + match p with + | { + ppat_desc = + Ppat_constraint + ( ({ppat_desc = Ppat_var _} as pat), + {ptyp_desc = Ptyp_poly (args_tyvars, rt)} ); + ppat_attributes = []; + } -> + Some (pat, args_tyvars, rt) + | _ -> None + in + let rec gadt_exp tyvars e = + match e with + | {pexp_desc = Pexp_newtype (tyvar, e); pexp_attributes = []} -> + gadt_exp (tyvar :: tyvars) e + | {pexp_desc = Pexp_constraint (e, ct); pexp_attributes = []} -> + Some (List.rev tyvars, e, ct) + | _ -> None + in + let gadt_exp = gadt_exp [] e in + match (gadt_pattern, gadt_exp) with + | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) + when tyvars_str pt_tyvars = tyvars_str e_tyvars -> + let ety = Typ.varify_constructors e_tyvars e_ct in + if ety = pt_ct then Some (p, pt_tyvars, e_ct, e) else None + | _ -> None + in + if x.pexp_attributes <> [] then + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ct + (expression ctxt) e + | Some (p, tyvars, ct, e) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p + (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + | None -> ( + match p with + | {ppat_desc = Ppat_constraint (p, ty); ppat_attributes = []} -> ( + (* special case for the first*) + match ty with + | {ptyp_desc = Ptyp_poly _; ptyp_attributes = []} -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty + (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty + (expression ctxt) x) + | {ppat_desc = Ppat_var _; ppat_attributes = []} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x) + +(* [in] is not printed *) +and bindings ctxt f (rf, l) = + let binding kwd rf f x = + pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf (binding ctxt) x + (item_attributes ctxt) x.pvb_attributes + in + match l with + | [] -> () + | [x] -> binding "let" rf f x + | x :: xs -> + pp f "@[%a@,%a@]" (binding "let" rf) x + (list ~sep:"@," (binding "and" Nonrecursive)) + xs + +and structure_item ctxt f x = + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + pp f "@[;;%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs + | Pstr_type (_, []) -> assert false + | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) + | Pstr_value (rf, l) -> + (* pp f "@[let %a%a@]" rec_flag rf bindings l *) + pp f "@[<2>%a@]" (bindings ctxt) (rf, l) + | Pstr_typext te -> type_extension ctxt f te + | Pstr_exception ed -> exception_declaration ctxt f ed + | Pstr_module x -> + let rec module_helper = function + | {pmod_desc = Pmod_functor (s, mt, me'); pmod_attributes = []} -> + if mt = None then pp f "()" + else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; + module_helper me' + | me -> me + in + pp f "@[module %s%a@]%a" x.pmb_name.txt + (fun f me -> + let me = module_helper me in + match me with + | { + pmod_desc = + Pmod_constraint + (me', ({pmty_desc = Pmty_ident _ | Pmty_signature _; _} as mt)); + pmod_attributes = []; + } -> + pp f " :@;%a@;=@;%a@;" (module_type ctxt) mt (module_expr ctxt) me' + | _ -> pp f " =@ %a" (module_expr ctxt) me) + x.pmb_expr (item_attributes ctxt) x.pmb_attributes + | Pstr_open od -> + pp f "@[<2>open%s@;%a@]%a" + (override od.popen_override) + longident_loc od.popen_lid (item_attributes ctxt) od.popen_attributes + | Pstr_modtype {pmtd_name = s; pmtd_type = md; pmtd_attributes = attrs} -> + pp f "@[module@ type@ %s%a@]%a" s.txt + (fun f md -> + match md with + | None -> () + | Some mt -> + pp_print_space f (); + pp f "@ =@ %a" (module_type ctxt) mt) + md (item_attributes ctxt) attrs + | Pstr_primitive vd -> + pp f "@[external@ %a@ :@ %a@]%a" protect_ident vd.pval_name.txt + (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes + | Pstr_include incl -> + pp f "@[include@ %a@]%a" (module_expr ctxt) incl.pincl_mod + (item_attributes ctxt) incl.pincl_attributes + | Pstr_recmodule decls -> ( + (* 3.07 *) + let aux f = function + | {pmb_expr = {pmod_desc = Pmod_constraint (expr, typ)}} as pmb -> + pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt + (module_type ctxt) typ (module_expr ctxt) expr (item_attributes ctxt) + pmb.pmb_attributes + | _ -> assert false + in + match decls with + | ({pmb_expr = {pmod_desc = Pmod_constraint (expr, typ)}} as pmb) :: l2 -> + pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" pmb.pmb_name.txt + (module_type ctxt) typ (module_expr ctxt) expr (item_attributes ctxt) + pmb.pmb_attributes + (fun f l2 -> List.iter (aux f) l2) + l2 + | _ -> assert false) + | Pstr_attribute a -> floating_attribute ctxt f a + | Pstr_extension (e, a) -> + item_extension ctxt f e; + item_attributes ctxt f a + +and type_param ctxt f (ct, a) = + pp f "%s%a" (type_variance a) (core_type ctxt) ct + +and type_params ctxt f = function + | [] -> () + | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l + +and type_def_list ctxt f (rf, l) = + let type_decl kwd rf f x = + let eq = + if x.ptype_kind = Ptype_abstract && x.ptype_manifest = None then "" + else " =" + in + pp f "@[<2>%s %a%a%s%s%a@]%a" kwd nonrec_flag rf (type_params ctxt) + x.ptype_params x.ptype_name.txt eq (type_declaration ctxt) x + (item_attributes ctxt) x.ptype_attributes + in + match l with + | [] -> assert false + | [x] -> type_decl "type" rf f x + | x :: xs -> + pp f "@[%a@,%a@]" (type_decl "type" rf) x + (list ~sep:"@," (type_decl "and" Recursive)) + xs + +and record_declaration ctxt f lbls = + let type_record_field f pld = + pp f "@[<2>%a%s%a:@;%a@;%a@]" mutable_flag pld.pld_mutable pld.pld_name.txt + optional_flag pld.pld_optional (core_type ctxt) pld.pld_type + (attributes ctxt) pld.pld_attributes + in + pp f "{@\n%a}" (list type_record_field ~sep:";@\n") lbls + +and type_declaration ctxt f x = + (* type_declaration has an attribute field, + but it's been printed by the caller of this method *) + let priv f = + match x.ptype_private with + | Public -> () + | Private -> pp f "@;private" + in + let manifest f = + match x.ptype_manifest with + | None -> () + | Some y -> + if x.ptype_kind = Ptype_abstract then + pp f "%t@;%a" priv (core_type ctxt) y + else pp f "@;%a" (core_type ctxt) y + in + let constructor_declaration f pcd = + pp f "|@;"; + constructor_declaration ctxt f + (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) + in + let repr f = + let intro f = if x.ptype_manifest = None then () else pp f "@;=" in + match x.ptype_kind with + | Ptype_variant xs -> + pp f "%t%t@\n%a" intro priv (list ~sep:"@\n" constructor_declaration) xs + | Ptype_abstract -> () + | Ptype_record l -> pp f "%t%t@;%a" intro priv (record_declaration ctxt) l + | Ptype_open -> pp f "%t%t@;.." intro priv + in + let constraints f = + List.iter + (fun (ct1, ct2, _) -> + pp f "@[@ constraint@ %a@ =@ %a@]" (core_type ctxt) ct1 + (core_type ctxt) ct2) + x.ptype_cstrs + in + pp f "%t%t%t" manifest repr constraints + +and type_extension ctxt f x = + let extension_constructor f x = + pp f "@\n|@;%a" (extension_constructor ctxt) x + in + pp f "@[<2>type %a%a += %a@ %a@]%a" + (fun f -> function + | [] -> () + | l -> + pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) + x.ptyext_params longident_loc x.ptyext_path private_flag + x.ptyext_private (* Cf: #7200 *) + (list ~sep:"" extension_constructor) + x.ptyext_constructors (item_attributes ctxt) x.ptyext_attributes + +and constructor_declaration ctxt f (name, args, res, attrs) = + let name = + match name with + | "::" -> "(::)" + | s -> s + in + match res with + | None -> + pp f "%s%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> + pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l) + args (attributes ctxt) attrs + | Some r -> + pp f "%s:@;%a@;%a" name + (fun f -> function + | Pcstr_tuple [] -> core_type1 ctxt f r + | Pcstr_tuple l -> + pp f "%a@;->@;%a" + (list (core_type1 ctxt) ~sep:"@;*@;") + l (core_type1 ctxt) r + | Pcstr_record l -> + pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r) + args (attributes ctxt) attrs + +and extension_constructor ctxt f x = + (* Cf: #7200 *) + match x.pext_kind with + | Pext_decl (l, r) -> + constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) + | Pext_rebind li -> + pp f "%s%a@;=@;%a" x.pext_name.txt (attributes ctxt) x.pext_attributes + longident_loc li + +and case_list ctxt f l : unit = + let aux f {pc_lhs; pc_guard; pc_rhs} = + pp f "@;| @[<2>%a%a@;->@;%a@]" (pattern ctxt) pc_lhs + (option (expression ctxt) ~first:"@;when@;") + pc_guard + (expression (under_pipe ctxt)) + pc_rhs + in + list aux f l ~sep:"" + +and label_x_expression_param ctxt f (l, e) = + let simple_name = + match e with + | {pexp_desc = Pexp_ident {txt = Lident l; _}; pexp_attributes = []} -> + Some l + | _ -> None + in + match l with + | Nolabel -> expression2 ctxt f e (* level 2*) + | Optional {txt = str} -> + if Some str = simple_name then pp f "?%s" str + else pp f "?%s:%a" str (simple_expr ctxt) e + | Labelled {txt = lbl} -> + if Some lbl = simple_name then pp f "~%s" lbl + else pp f "~%s:%a" lbl (simple_expr ctxt) e + +let expression f x = pp f "@[%a@]" (expression reset_ctxt) x + +let string_of_expression x = + ignore (flush_str_formatter ()); + let f = str_formatter in + expression f x; + flush_str_formatter () + +let string_of_structure x = + ignore (flush_str_formatter ()); + let f = str_formatter in + structure reset_ctxt f x; + flush_str_formatter () + +let core_type = core_type reset_ctxt +let pattern = pattern reset_ctxt +let signature = signature reset_ctxt +let structure = structure reset_ctxt diff --git a/jscomp/ml/pprintast.mli b/compiler/ml/pprintast.mli similarity index 78% rename from jscomp/ml/pprintast.mli rename to compiler/ml/pprintast.mli index 7da9ee0..fb26664 100644 --- a/jscomp/ml/pprintast.mli +++ b/compiler/ml/pprintast.mli @@ -15,13 +15,12 @@ type space_formatter = (unit, Format.formatter, unit) format - val expression : Format.formatter -> Parsetree.expression -> unit val string_of_expression : Parsetree.expression -> string -val core_type: Format.formatter -> Parsetree.core_type -> unit -val pattern: Format.formatter -> Parsetree.pattern -> unit -val signature: Format.formatter -> Parsetree.signature -> unit -val structure: Format.formatter -> Parsetree.structure -> unit -val string_of_structure: Parsetree.structure -> string -val string_of_int_as_char: int -> string +val core_type : Format.formatter -> Parsetree.core_type -> unit +val pattern : Format.formatter -> Parsetree.pattern -> unit +val signature : Format.formatter -> Parsetree.signature -> unit +val structure : Format.formatter -> Parsetree.structure -> unit +val string_of_structure : Parsetree.structure -> string +val string_of_int_as_char : int -> string diff --git a/compiler/ml/predef.ml b/compiler/ml/predef.ml new file mode 100644 index 0000000..5913791 --- /dev/null +++ b/compiler/ml/predef.ml @@ -0,0 +1,417 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Predefined type constructors (with special typing rules in typecore) *) + +open Path +open Types +open Btype + +let builtin_idents = ref [] + +let wrap create s = + let id = create s in + builtin_idents := (s, id) :: !builtin_idents; + id + +let ident_create = wrap Ident.create +let ident_create_predef_exn = wrap Ident.create_predef_exn + +let ident_int = ident_create "int" + +and ident_char = ident_create "char" + +and ident_float = ident_create "float" + +and ident_bool = ident_create "bool" + +and ident_unit = ident_create "unit" + +and ident_exn = ident_create "exn" + +and ident_array = ident_create "array" + +and ident_list = ident_create "list" + +and ident_option = ident_create "option" + +and ident_result = ident_create "result" + +and ident_dict = ident_create "dict" + +and ident_bigint = ident_create "bigint" + +and ident_string = ident_create "string" + +and ident_extension_constructor = ident_create "extension_constructor" + +and ident_unknown = ident_create "unknown" + +and ident_promise = ident_create "promise" + +type test = For_sure_yes | For_sure_no | NA + +let type_is_builtin_path_but_option (p : Path.t) : test = + match p with + | Pident {stamp} when stamp = ident_option.stamp -> For_sure_no + | Pident {stamp} when stamp = ident_unit.stamp -> For_sure_no + | Pident {stamp} when stamp >= ident_int.stamp && stamp <= ident_promise.stamp + -> + For_sure_yes + | _ -> NA + +let path_int = Pident ident_int + +and path_char = Pident ident_char + +and path_float = Pident ident_float + +and path_bool = Pident ident_bool + +and path_unit = Pident ident_unit + +and path_exn = Pident ident_exn + +and path_array = Pident ident_array + +and path_list = Pident ident_list + +and path_option = Pident ident_option + +and path_result = Pident ident_result + +and path_dict = Pident ident_dict + +and path_bigint = Pident ident_bigint + +and path_string = Pident ident_string + +and path_unkonwn = Pident ident_unknown + +and path_extension_constructor = Pident ident_extension_constructor + +and path_promise = Pident ident_promise + +let type_int = newgenty (Tconstr (path_int, [], ref Mnil)) + +and type_char = newgenty (Tconstr (path_char, [], ref Mnil)) + +and type_float = newgenty (Tconstr (path_float, [], ref Mnil)) + +and type_bool = newgenty (Tconstr (path_bool, [], ref Mnil)) + +and type_unit = newgenty (Tconstr (path_unit, [], ref Mnil)) + +and type_exn = newgenty (Tconstr (path_exn, [], ref Mnil)) + +and type_array t = newgenty (Tconstr (path_array, [t], ref Mnil)) + +and type_list t = newgenty (Tconstr (path_list, [t], ref Mnil)) + +and type_option t = newgenty (Tconstr (path_option, [t], ref Mnil)) + +and type_result t1 t2 = newgenty (Tconstr (path_result, [t1; t2], ref Mnil)) + +and type_dict t = newgenty (Tconstr (path_dict, [t], ref Mnil)) + +and type_bigint = newgenty (Tconstr (path_bigint, [], ref Mnil)) + +and type_string = newgenty (Tconstr (path_string, [], ref Mnil)) + +and type_unknown = newgenty (Tconstr (path_unkonwn, [], ref Mnil)) + +and type_extension_constructor = + newgenty (Tconstr (path_extension_constructor, [], ref Mnil)) + +let ident_match_failure = ident_create_predef_exn "Match_failure" + +and ident_invalid_argument = ident_create_predef_exn "Invalid_argument" + +and ident_failure = ident_create_predef_exn "Failure" + +and ident_ok = ident_create_predef_exn "Ok" + +and ident_error = ident_create_predef_exn "Error" + +and ident_dict_magic_field_name = + ident_create Dict_type_helpers.dict_magic_field_name + +and ident_js_exn = ident_create_predef_exn "JsExn" + +and ident_not_found = ident_create_predef_exn "Not_found" + +and ident_end_of_file = ident_create_predef_exn "End_of_file" + +and ident_division_by_zero = ident_create_predef_exn "Division_by_zero" + +and ident_assert_failure = ident_create_predef_exn "Assert_failure" + +and ident_undefined_recursive_module = + ident_create_predef_exn "Undefined_recursive_module" + +let all_predef_exns = + [ + ident_match_failure; + ident_invalid_argument; + ident_failure; + ident_js_exn; + ident_not_found; + ident_end_of_file; + ident_division_by_zero; + ident_assert_failure; + ident_undefined_recursive_module; + ] + +let path_match_failure = Pident ident_match_failure + +and path_assert_failure = Pident ident_assert_failure + +and path_undefined_recursive_module = Pident ident_undefined_recursive_module + +let decl_abstr = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_loc = Location.none; + type_private = Asttypes.Public; + type_manifest = None; + type_variance = []; + type_newtype_level = None; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + +let decl_abstr_imm = {decl_abstr with type_immediate = true} + +let cstr id args = + { + cd_id = id; + cd_args = Cstr_tuple args; + cd_res = None; + cd_loc = Location.none; + cd_attributes = []; + } + +let ident_false = ident_create "false" + +and ident_true = ident_create "true" + +and ident_void = ident_create "()" + +and ident_nil = ident_create "[]" + +and ident_cons = ident_create "::" + +and ident_none = ident_create "None" + +and ident_some = ident_create "Some" + +and ident_ctor_unknown = ident_create "Unknown" + +let common_initial_env add_type add_extension empty_env = + let decl_bool = + { + decl_abstr with + type_kind = Type_variant [cstr ident_false []; cstr ident_true []]; + type_immediate = true; + } + and decl_unit = + { + decl_abstr with + type_kind = Type_variant [cstr ident_void []]; + type_immediate = true; + } + and decl_exn = {decl_abstr with type_kind = Type_open} + and decl_array = + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_variance = [Variance.full]; + } + and decl_list = + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_kind = + Type_variant [cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]; + type_variance = [Variance.covariant]; + } + and decl_option = + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_kind = Type_variant [cstr ident_none []; cstr ident_some [tvar]]; + type_variance = [Variance.covariant]; + } + and decl_result = + let tvar1, tvar2 = (newgenvar (), newgenvar ()) in + { + decl_abstr with + type_params = [tvar1; tvar2]; + type_arity = 2; + type_kind = Type_variant [cstr ident_ok [tvar1]; cstr ident_error [tvar2]]; + type_variance = [Variance.covariant; Variance.covariant]; + } + and decl_dict = + let tvar = newgenvar () in + (* Dicts are implemented as a single "magic" field record. This magic field + is the medium through which we can piggy back on the existing record pattern + matching mechanism. We do this by letting the compiler route any label lookup + for the dict record type to the magic field, which has the type of the values + of the dict. + + So, this definition is important for the dict pattern matching functionality, + but not something intended to be exposed to the user. *) + { + decl_abstr with + type_attributes = + [ + Dict_type_helpers.dict_attr; + (Location.mknoloc "live", Parsetree.PStr []); + ]; + type_params = [tvar]; + type_arity = 1; + type_variance = [Variance.full]; + type_kind = + Type_record + ( [ + { + ld_id = ident_dict_magic_field_name; + ld_attributes = [Dict_type_helpers.dict_magic_field_attr]; + ld_loc = Location.none; + ld_mutable = Immutable; + ld_optional = true; + ld_type = newgenty (Tconstr (path_option, [tvar], ref Mnil)); + }; + ], + Record_regular ); + } + and decl_unknown = + let tvar = newgenvar () in + { + decl_abstr with + type_params = []; + type_arity = 0; + type_kind = + Type_variant + [ + { + cd_id = ident_ctor_unknown; + cd_args = Cstr_tuple [tvar]; + cd_res = Some type_unknown; + cd_loc = Location.none; + cd_attributes = []; + }; + ]; + type_unboxed = Types.unboxed_true_default_false; + } + and decl_promise = + let tvar = newgenvar () in + { + decl_abstr with + type_params = [tvar]; + type_arity = 1; + type_variance = [Variance.covariant]; + } + in + + let add_exception id l = + add_extension id + { + ext_type_path = path_exn; + ext_type_params = []; + ext_args = Cstr_tuple l; + ext_ret_type = None; + ext_private = Asttypes.Public; + ext_loc = Location.none; + ext_attributes = + [ + ( { + Asttypes.txt = "ocaml.warn_on_literal_pattern"; + loc = Location.none; + }, + Parsetree.PStr [] ); + ]; + ext_is_exception = true; + } + in + empty_env + |> add_type ident_bool decl_bool + |> add_type ident_int decl_abstr_imm + |> add_type ident_float decl_abstr + |> add_type ident_bigint decl_abstr + |> add_type ident_string decl_abstr + |> add_type ident_unit decl_unit + |> add_type ident_extension_constructor decl_abstr + |> add_type ident_exn decl_exn + |> add_type ident_option decl_option + |> add_type ident_result decl_result + |> add_type ident_promise decl_promise + |> add_type ident_array decl_array + |> add_type ident_list decl_list + |> add_type ident_dict decl_dict + |> add_type ident_unknown decl_unknown + |> add_exception ident_undefined_recursive_module + [newgenty (Ttuple [type_string; type_int; type_int])] + |> add_exception ident_assert_failure + [newgenty (Ttuple [type_string; type_int; type_int])] + |> add_exception ident_division_by_zero [] + |> add_exception ident_end_of_file [] + |> add_exception ident_not_found [] + |> add_exception ident_failure [type_string] + |> add_exception ident_js_exn [type_unknown] + |> add_exception ident_invalid_argument [type_string] + |> add_exception ident_match_failure + [newgenty (Ttuple [type_string; type_int; type_int])] + +let build_initial_env add_type add_exception empty_env = + let common = common_initial_env add_type add_exception empty_env in + let decl_type_char = + {decl_abstr with type_manifest = Some type_int; type_private = Private} + in + add_type ident_char decl_type_char common + +let builtin_values = + List.map + (fun id -> + Ident.make_global id; + (Ident.name id, id)) + [ + ident_match_failure; + ident_invalid_argument; + ident_failure; + ident_js_exn; + ident_not_found; + ident_end_of_file; + ident_division_by_zero; + ident_assert_failure; + ident_undefined_recursive_module; + ] + +(* Start non-predef identifiers at 1000. This way, more predefs can + be defined in this file (above!) without breaking .cmi + compatibility. *) + +let _ = Ident.set_current_time 999 +let builtin_idents = List.rev !builtin_idents diff --git a/compiler/ml/predef.mli b/compiler/ml/predef.mli new file mode 100644 index 0000000..8e3330f --- /dev/null +++ b/compiler/ml/predef.mli @@ -0,0 +1,82 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Predefined type constructors (with special typing rules in typecore) *) + +open Types + +val type_int : type_expr +val type_char : type_expr +val type_string : type_expr +val type_float : type_expr +val type_bool : type_expr +val type_unit : type_expr +val type_exn : type_expr +val type_array : type_expr -> type_expr +val type_list : type_expr -> type_expr +val type_option : type_expr -> type_expr +val type_result : type_expr -> type_expr -> type_expr +val type_dict : type_expr -> type_expr + +val type_bigint : type_expr +val type_extension_constructor : type_expr + +val path_int : Path.t +val path_char : Path.t +val path_string : Path.t +val path_float : Path.t +val path_bool : Path.t +val path_unit : Path.t +val path_exn : Path.t +val path_array : Path.t +val path_list : Path.t +val path_option : Path.t +val path_result : Path.t +val path_dict : Path.t + +val path_bigint : Path.t +val path_extension_constructor : Path.t +val path_promise : Path.t + +val path_match_failure : Path.t +val path_assert_failure : Path.t +val path_undefined_recursive_module : Path.t + +(* To build the initial environment. Since there is a nasty mutual + recursion between predef and env, we break it by parameterizing + over Env.t, Env.add_type and Env.add_extension. *) + +val build_initial_env : + (Ident.t -> type_declaration -> 'a -> 'a) -> + (Ident.t -> extension_constructor -> 'a -> 'a) -> + 'a -> + 'a + +(* To initialize linker tables *) + +val builtin_values : (string * Ident.t) list +val builtin_idents : (string * Ident.t) list + +val ident_division_by_zero : Ident.t +(** All predefined exceptions, exposed as [Ident.t] for flambda (for + building value approximations). + The [Ident.t] for division by zero is also exported explicitly + so flambda can generate code to raise it. *) + +val all_predef_exns : Ident.t list + +type test = For_sure_yes | For_sure_no | NA + +val type_is_builtin_path_but_option : Path.t -> test diff --git a/compiler/ml/primitive.ml b/compiler/ml/primitive.ml new file mode 100644 index 0000000..f632606 --- /dev/null +++ b/compiler/ml/primitive.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Description of primitive functions *) + +open Misc +open Parsetree + +type description = { + prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_from_constructor: bool; + (* Is it from a type constructor instead of a concrete function type? *) + transformed_jsx: bool; +} + +let set_transformed_jsx d ~transformed_jsx = {d with transformed_jsx} + +let with_arity d ~arity ~from_constructor = + {d with prim_arity = arity; prim_from_constructor = from_constructor} + +let coerce : (description -> description -> bool) ref = + ref (fun (p1 : description) (p2 : description) -> p1 = p2) + +let parse_declaration valdecl ~arity ~from_constructor = + let name, native_name = + match valdecl.pval_prim with + | name :: name2 :: _ -> (name, name2) + | name :: _ -> (name, "") + | [] -> fatal_error "Primitive.parse_declaration" + in + { + prim_name = name; + prim_arity = arity; + prim_alloc = true; + prim_native_name = native_name; + prim_from_constructor = from_constructor; + transformed_jsx = false; + } + +open Outcometree + +let print p osig_val_decl = + let prims = + if p.prim_native_name <> "" then [p.prim_name; p.prim_native_name] + else [p.prim_name] + in + {osig_val_decl with oval_prims = prims; oval_attributes = []} diff --git a/compiler/ml/primitive.mli b/compiler/ml/primitive.mli new file mode 100644 index 0000000..c5b43c3 --- /dev/null +++ b/compiler/ml/primitive.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Description of primitive functions *) + +type description = private { + prim_name: string; (* Name of primitive or C function *) + prim_arity: int; (* Number of arguments *) + prim_alloc: bool; (* Does it allocates or raise? *) + prim_native_name: string; (* Name of C function for the nat. code gen. *) + prim_from_constructor: bool; + (* Is it from a type constructor instead of a concrete function type? *) + transformed_jsx: bool; +} + +val set_transformed_jsx : description -> transformed_jsx:bool -> description + +val with_arity : + description -> arity:int -> from_constructor:bool -> description + +(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *) + +val parse_declaration : + Parsetree.value_description -> + arity:int -> + from_constructor:bool -> + description + +val print : description -> Outcometree.out_val_decl -> Outcometree.out_val_decl + +val coerce : (description -> description -> bool) ref diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml new file mode 100644 index 0000000..44d699e --- /dev/null +++ b/compiler/ml/printast.ml @@ -0,0 +1,732 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Para, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Format +open Lexing +open Location +open Parsetree + +let fmt_position with_name f l = + let fname = if with_name then l.pos_fname else "" in + if l.pos_lnum = -1 then fprintf f "%s[%d]" fname l.pos_cnum + else + fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol (l.pos_cnum - l.pos_bol) + +let fmt_location f loc = + if !Clflags.dump_location then ( + let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in + fprintf f "(%a..%a)" (fmt_position true) loc.loc_start + (fmt_position p_2nd_name) loc.loc_end; + if loc.loc_ghost then fprintf f " ghost") + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident s -> fprintf f "%s" s + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + +let fmt_longident_loc f (x : Longident.t loc) = + fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc + +let fmt_jsx_tag_name f (x : jsx_tag_name loc) = + let loc = x.loc in + match x.txt with + | JsxLowerTag name -> fprintf f "\"%s\" %a" name fmt_location loc + | JsxQualifiedLowerTag {path; name} -> + fprintf f "\"%a.%s\" %a" fmt_longident_aux path name fmt_location loc + | JsxUpperTag path -> + fprintf f "\"%a\" %a" fmt_longident_aux path fmt_location loc + | JsxTagInvalid name -> fprintf f "\"%s\" %a" name fmt_location loc + +let fmt_string_loc f (x : string loc) = + fprintf f "\"%s\" %a" x.txt fmt_location x.loc + +let fmt_char_option f = function + | None -> fprintf f "None" + | Some c -> fprintf f "Some %c" c + +let fmt_constant f x = + match x with + | Pconst_integer (i, m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m + | Pconst_char c -> fprintf f "PConst_char %02x" c + | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s + | Pconst_string (s, Some delim) -> + fprintf f "PConst_string (%S,Some %S)" s delim + | Pconst_float (s, m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" + +let line i f s (*...*) = + fprintf f "%s" (String.make (2 * i mod 72) ' '); + fprintf f s (*...*) + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n" + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i + 1) ppf) l; + line i ppf "]\n" + +let option i f ppf x = + match x with + | None -> line i ppf "None\n" + | Some x -> + line i ppf "Some\n"; + f (i + 1) ppf x + +let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li +let string i ppf s = line i ppf "\"%s\"\n" s +let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s + +let arg_label_loc i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional {txt = s} -> line i ppf "Optional \"%s\"\n" s + | Labelled {txt = s} -> line i ppf "Labelled \"%s\"\n" s + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ptyp_loc; + attributes i ppf x.ptyp_attributes; + let i = i + 1 in + match x.ptyp_desc with + | Ptyp_any -> line i ppf "Ptyp_any\n" + | Ptyp_var s -> line i ppf "Ptyp_var %s\n" s + | Ptyp_arrow {arg; ret; arity} -> + line i ppf "Ptyp_arrow\n"; + let () = + match arity with + | None -> () + | Some n -> line i ppf "arity = %d\n" n + in + arg_label_loc i ppf arg.lbl; + core_type i ppf arg.typ; + core_type i ppf ret + | Ptyp_tuple l -> + line i ppf "Ptyp_tuple\n"; + list i core_type ppf l + | Ptyp_constr (li, l) -> + line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; + list i core_type ppf l + | Ptyp_variant (l, closed, low) -> + line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ptyp_object (l, c) -> + line i ppf "Ptyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter + (function + | Otag (l, attrs, t) -> + line i ppf "method %s\n" l.txt; + attributes i ppf attrs; + core_type (i + 1) ppf t + | Oinherit ct -> + line i ppf "Oinherit\n"; + core_type (i + 1) ppf ct) + l + | Ptyp_alias (ct, s) -> + line i ppf "Ptyp_alias \"%s\"\n" s; + core_type i ppf ct + | Ptyp_poly (sl, ct) -> + line i ppf "Ptyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) + sl; + core_type i ppf ct + | Ptyp_package (s, l) -> + line i ppf "Ptyp_package %a\n" fmt_longident_loc s; + list i package_with ppf l + | Ptyp_extension (s, arg) -> + line i ppf "Ptyp_extension \"%s\"\n" s.txt; + payload i ppf arg + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident_loc s; + core_type i ppf t + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.ppat_loc; + attributes i ppf x.ppat_attributes; + let i = i + 1 in + match x.ppat_desc with + | Ppat_any -> line i ppf "Ppat_any\n" + | Ppat_var s -> line i ppf "Ppat_var %a\n" fmt_string_loc s + | Ppat_alias (p, s) -> + line i ppf "Ppat_alias %a\n" fmt_string_loc s; + pattern i ppf p + | Ppat_constant c -> line i ppf "Ppat_constant %a\n" fmt_constant c + | Ppat_interval (c1, c2) -> + line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2 + | Ppat_tuple l -> + line i ppf "Ppat_tuple\n"; + list i pattern ppf l + | Ppat_construct (li, po) -> + line i ppf "Ppat_construct %a\n" fmt_longident_loc li; + option i pattern ppf po + | Ppat_variant (l, po) -> + line i ppf "Ppat_variant \"%s\"\n" l; + option i pattern ppf po + | Ppat_record (l, c) -> + line i ppf "Ppat_record %a\n" fmt_closed_flag c; + list i longident_x_pattern ppf l + | Ppat_array l -> + line i ppf "Ppat_array\n"; + list i pattern ppf l + | Ppat_or (p1, p2) -> + line i ppf "Ppat_or\n"; + pattern i ppf p1; + pattern i ppf p2 + | Ppat_constraint (p, ct) -> + line i ppf "Ppat_constraint\n"; + pattern i ppf p; + core_type i ppf ct + | Ppat_type li -> + line i ppf "Ppat_type\n"; + longident_loc i ppf li + | Ppat_unpack s -> line i ppf "Ppat_unpack %a\n" fmt_string_loc s + | Ppat_exception p -> + line i ppf "Ppat_exception\n"; + pattern i ppf p + | Ppat_open (m, p) -> + line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; + pattern i ppf p + | Ppat_extension (s, arg) -> + line i ppf "Ppat_extension \"%s\"\n" s.txt; + payload i ppf arg + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.pexp_loc; + attributes i ppf x.pexp_attributes; + let i = i + 1 in + match x.pexp_desc with + | Pexp_ident li -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li + | Pexp_constant c -> line i ppf "Pexp_constant %a\n" fmt_constant c + | Pexp_let (rf, l, e) -> + line i ppf "Pexp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e + | Pexp_fun {arg_label = l; default = eo; lhs = p; rhs = e; arity; async} -> + line i ppf "Pexp_fun\n"; + let () = if async then line i ppf "async\n" in + let () = + match arity with + | None -> () + | Some arity -> line i ppf "arity:%d\n" arity + in + arg_label_loc i ppf l; + option i expression ppf eo; + pattern i ppf p; + expression i ppf e + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> + line i ppf "Pexp_apply\n"; + if partial then line i ppf "partial\n"; + expression i ppf e; + list i label_x_expression ppf l; + line i ppf "transformed_jsx: %b\n" transformed_jsx + | Pexp_match (e, l) -> + line i ppf "Pexp_match\n"; + expression i ppf e; + list i case ppf l + | Pexp_try (e, l) -> + line i ppf "Pexp_try\n"; + expression i ppf e; + list i case ppf l + | Pexp_tuple l -> + line i ppf "Pexp_tuple\n"; + list i expression ppf l + | Pexp_construct (li, eo) -> + line i ppf "Pexp_construct %a\n" fmt_longident_loc li; + option i expression ppf eo + | Pexp_variant (l, eo) -> + line i ppf "Pexp_variant \"%s\"\n" l; + option i expression ppf eo + | Pexp_record (l, eo) -> + line i ppf "Pexp_record\n"; + list i longident_x_expression ppf l; + option i expression ppf eo + | Pexp_field (e, li) -> + line i ppf "Pexp_field\n"; + expression i ppf e; + longident_loc i ppf li + | Pexp_setfield (e1, li, e2) -> + line i ppf "Pexp_setfield\n"; + expression i ppf e1; + longident_loc i ppf li; + expression i ppf e2 + | Pexp_array l -> + line i ppf "Pexp_array\n"; + list i expression ppf l + | Pexp_ifthenelse (e1, e2, eo) -> + line i ppf "Pexp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo + | Pexp_sequence (e1, e2) -> + line i ppf "Pexp_sequence\n"; + expression i ppf e1; + expression i ppf e2 + | Pexp_while (e1, e2) -> + line i ppf "Pexp_while\n"; + expression i ppf e1; + expression i ppf e2 + | Pexp_for (p, e1, e2, df, e3) -> + line i ppf "Pexp_for %a\n" fmt_direction_flag df; + pattern i ppf p; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3 + | Pexp_constraint (e, ct) -> + line i ppf "Pexp_constraint\n"; + expression i ppf e; + core_type i ppf ct + | Pexp_coerce (e, (), cto2) -> + line i ppf "Pexp_coerce\n"; + expression i ppf e; + core_type i ppf cto2 + | Pexp_send (e, s) -> + line i ppf "Pexp_send \"%s\"\n" s.txt; + expression i ppf e + | Pexp_letmodule (s, me, e) -> + line i ppf "Pexp_letmodule %a\n" fmt_string_loc s; + module_expr i ppf me; + expression i ppf e + | Pexp_letexception (cd, e) -> + line i ppf "Pexp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e + | Pexp_assert e -> + line i ppf "Pexp_assert\n"; + expression i ppf e + | Pexp_newtype (s, e) -> + line i ppf "Pexp_newtype \"%s\"\n" s.txt; + expression i ppf e + | Pexp_pack me -> + line i ppf "Pexp_pack\n"; + module_expr i ppf me + | Pexp_open (ovf, m, e) -> + line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf fmt_longident_loc m; + expression i ppf e + | Pexp_extension (s, arg) -> + line i ppf "Pexp_extension \"%s\"\n" s.txt; + payload i ppf arg + | Pexp_await e -> + line i ppf "Pexp_await\n"; + expression i ppf e + | Pexp_jsx_element (Jsx_fragment {jsx_fragment_children = children}) -> + line i ppf "Pexp_jsx_fragment"; + jsx_children i ppf children + | Pexp_jsx_element + (Jsx_unary_element + {jsx_unary_element_tag_name = name; jsx_unary_element_props = props}) + -> + line i ppf "Pexp_jsx_unary_element %a\n" fmt_jsx_tag_name name; + jsx_props i ppf props + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = name; + jsx_container_element_props = props; + jsx_container_element_opening_tag_end = gt; + jsx_container_element_children = children; + jsx_container_element_closing_tag = closing_tag; + }) -> ( + line i ppf "Pexp_jsx_container_element %a\n" fmt_jsx_tag_name name; + jsx_props i ppf props; + if !Clflags.dump_location then line i ppf "> %a\n" (fmt_position false) gt; + jsx_children i ppf children; + match closing_tag with + | None -> () + | Some closing_tag -> + line i ppf "closing_tag =%a\n" fmt_jsx_tag_name + closing_tag.jsx_closing_container_tag_name) + +and jsx_children i ppf children = + line i ppf "jsx_children =\n"; + list (i + 1) expression ppf children + +and jsx_prop i ppf = function + | JSXPropPunning (opt, name) -> + line i ppf "%s%s" (if opt then "?" else "") name.txt + | JSXPropValue (name, opt, expr) -> + line i ppf "%s=%s" name.txt (if opt then "?" else ""); + expression i ppf expr + | JSXPropSpreading (loc, e) -> + line i ppf "{... %a\n" fmt_location loc; + expression (i + 1) ppf e; + line i ppf "}\n" + +and jsx_props i ppf xs = + line i ppf "jsx_props =\n"; + list (i + 1) jsx_prop ppf xs + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location + x.pval_loc; + attributes i ppf x.pval_attributes; + core_type (i + 1) ppf x.pval_type; + list (i + 1) string ppf x.pval_prim + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name fmt_location + x.ptype_loc; + attributes i ppf x.ptype_attributes; + let i = i + 1 in + line i ppf "ptype_params =\n"; + list (i + 1) type_parameter ppf x.ptype_params; + line i ppf "ptype_cstrs =\n"; + list (i + 1) core_type_x_core_type_x_location ppf x.ptype_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i + 1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; + line i ppf "ptype_manifest =\n"; + option (i + 1) core_type ppf x.ptype_manifest + +and attributes i ppf l = + let i = i + 1 in + List.iter + (fun (s, arg) -> + line i ppf "attribute %a \"%s\"\n" fmt_location (s : _ Asttypes.loc).loc + s.txt; + payload (i + 1) ppf arg) + l + +and payload i ppf = function + | PStr x -> structure i ppf x + | PSig x -> signature i ppf x + | PTyp x -> core_type i ppf x + | PPat (x, None) -> pattern i ppf x + | PPat (x, Some g) -> + pattern i ppf x; + line i ppf "\n"; + expression (i + 1) ppf g + +and type_kind i ppf x = + match x with + | Ptype_abstract -> line i ppf "Ptype_abstract\n" + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; + list (i + 1) constructor_decl ppf l + | Ptype_record l -> + line i ppf "Ptype_record\n"; + list (i + 1) label_decl ppf l + | Ptype_open -> line i ppf "Ptype_open\n" + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.ptyext_attributes; + let i = i + 1 in + line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; + line i ppf "ptyext_params =\n"; + list (i + 1) type_parameter ppf x.ptyext_params; + line i ppf "ptyext_constructors =\n"; + list (i + 1) extension_constructor ppf x.ptyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; + attributes i ppf x.pext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.pext_kind + +and extension_constructor_kind i ppf x = + match x with + | Pext_decl (a, r) -> + line i ppf "Pext_decl\n"; + constructor_arguments (i + 1) ppf a; + option (i + 1) core_type ppf r + | Pext_rebind li -> + line i ppf "Pext_rebind\n"; + line (i + 1) ppf "%a\n" fmt_longident_loc li + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.pmty_loc; + attributes i ppf x.pmty_attributes; + let i = i + 1 in + match x.pmty_desc with + | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li + | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li + | Pmty_signature s -> + line i ppf "Pmty_signature\n"; + signature i ppf s + | Pmty_functor (s, mt1, mt2) -> + line i ppf "Pmty_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt1; + module_type i ppf mt2 + | Pmty_with (mt, l) -> + line i ppf "Pmty_with\n"; + module_type i ppf mt; + list i with_constraint ppf l + | Pmty_typeof m -> + line i ppf "Pmty_typeof\n"; + module_expr i ppf m + | Pmty_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and signature i ppf x = list i signature_item ppf x + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.psig_loc; + let i = i + 1 in + match x.psig_desc with + | Psig_value vd -> + line i ppf "Psig_value\n"; + value_description i ppf vd + | Psig_type (rf, l) -> + line i ppf "Psig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l + | Psig_typext te -> + line i ppf "Psig_typext\n"; + type_extension i ppf te + | Psig_exception ext -> + line i ppf "Psig_exception\n"; + extension_constructor i ppf ext + | Psig_module pmd -> + line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type i ppf pmd.pmd_type + | Psig_recmodule decls -> + line i ppf "Psig_recmodule\n"; + list i module_declaration ppf decls + | Psig_modtype x -> + line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Psig_open od -> + line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes + | Psig_include incl -> + line i ppf "Psig_include\n"; + module_type i ppf incl.pincl_mod; + attributes i ppf incl.pincl_attributes + | Psig_extension ((s, arg), attrs) -> + line i ppf "Psig_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Psig_attribute (s, arg) -> + line i ppf "Psig_attribute \"%s\"\n" s.txt; + payload i ppf arg + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i + 1) ppf mt + +and with_constraint i ppf x = + match x with + | Pwith_type (lid, td) -> + line i ppf "Pwith_type %a\n" fmt_longident_loc lid; + type_declaration (i + 1) ppf td + | Pwith_typesubst (lid, td) -> + line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; + type_declaration (i + 1) ppf td + | Pwith_module (lid1, lid2) -> + line i ppf "Pwith_module %a = %a\n" fmt_longident_loc lid1 fmt_longident_loc + lid2 + | Pwith_modsubst (lid1, lid2) -> + line i ppf "Pwith_modsubst %a = %a\n" fmt_longident_loc lid1 + fmt_longident_loc lid2 + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.pmod_loc; + attributes i ppf x.pmod_attributes; + let i = i + 1 in + match x.pmod_desc with + | Pmod_ident li -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li + | Pmod_structure s -> + line i ppf "Pmod_structure\n"; + structure i ppf s + | Pmod_functor (s, mt, me) -> + line i ppf "Pmod_functor %a\n" fmt_string_loc s; + Misc.may (module_type i ppf) mt; + module_expr i ppf me + | Pmod_apply (me1, me2) -> + line i ppf "Pmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2 + | Pmod_constraint (me, mt) -> + line i ppf "Pmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt + | Pmod_unpack e -> + line i ppf "Pmod_unpack\n"; + expression i ppf e + | Pmod_extension (s, arg) -> + line i ppf "Pmod_extension \"%s\"\n" s.txt; + payload i ppf arg + +and structure i ppf x = list i structure_item ppf x + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.pstr_loc; + let i = i + 1 in + match x.pstr_desc with + | Pstr_eval (e, attrs) -> + line i ppf "Pstr_eval\n"; + attributes i ppf attrs; + expression i ppf e + | Pstr_value (rf, l) -> + line i ppf "Pstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l + | Pstr_primitive vd -> + line i ppf "Pstr_primitive\n"; + value_description i ppf vd + | Pstr_type (rf, l) -> + line i ppf "Pstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l + | Pstr_typext te -> + line i ppf "Pstr_typext\n"; + type_extension i ppf te + | Pstr_exception ext -> + line i ppf "Pstr_exception\n"; + extension_constructor i ppf ext + | Pstr_module x -> + line i ppf "Pstr_module\n"; + module_binding i ppf x + | Pstr_recmodule bindings -> + line i ppf "Pstr_recmodule\n"; + list i module_binding ppf bindings + | Pstr_modtype x -> + line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type + | Pstr_open od -> + line i ppf "Pstr_open %a %a\n" fmt_override_flag od.popen_override + fmt_longident_loc od.popen_lid; + attributes i ppf od.popen_attributes + | Pstr_include incl -> + line i ppf "Pstr_include"; + attributes i ppf incl.pincl_attributes; + module_expr i ppf incl.pincl_mod + | Pstr_extension ((s, arg), attrs) -> + line i ppf "Pstr_extension \"%s\"\n" s.txt; + attributes i ppf attrs; + payload i ppf arg + | Pstr_attribute (s, arg) -> + line i ppf "Pstr_attribute \"%s\"\n" s.txt; + payload i ppf arg + +and module_declaration i ppf pmd = + string_loc i ppf pmd.pmd_name; + attributes i ppf pmd.pmd_attributes; + module_type (i + 1) ppf pmd.pmd_type + +and module_binding i ppf x = + string_loc i ppf x.pmb_name; + attributes i ppf x.pmb_attributes; + module_expr (i + 1) ppf x.pmb_expr + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i + 1) ppf ct1; + core_type (i + 1) ppf ct2 + +and constructor_decl i ppf + {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = + line i ppf "%a\n" fmt_location pcd_loc; + line (i + 1) ppf "%a\n" fmt_string_loc pcd_name; + attributes i ppf pcd_attributes; + constructor_arguments (i + 1) ppf pcd_args; + option (i + 1) core_type ppf pcd_res + +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + +and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} + = + line i ppf "%a\n" fmt_location pld_loc; + attributes i ppf pld_attributes; + line (i + 1) ppf "%a\n" fmt_mutable_flag pld_mutable; + line (i + 1) ppf "%a" fmt_string_loc pld_name; + core_type (i + 1) ppf pld_type + +and longident_x_pattern i ppf {lid = li; x = p; opt} = + line i ppf "%a%s\n" fmt_longident_loc li (if opt then "?" else ""); + pattern (i + 1) ppf p + +and case i ppf {pc_bar; pc_lhs; pc_guard; pc_rhs} = + line i ppf "\n"; + pc_bar + |> Option.iter (fun bar -> line i ppf "| %a\n" (fmt_position false) bar); + pattern (i + 1) ppf pc_lhs; + (match pc_guard with + | None -> () + | Some g -> + line (i + 1) ppf "\n"; + expression (i + 2) ppf g); + expression (i + 1) ppf pc_rhs + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i + 1) ppf x.pvb_attributes; + pattern (i + 1) ppf x.pvb_pat; + expression (i + 1) ppf x.pvb_expr + +and longident_x_expression i ppf {lid = li; x = e; opt} = + line i ppf "%a%s\n" fmt_longident_loc li (if opt then "?" else ""); + expression (i + 1) ppf e + +and label_x_expression i ppf (l, e) = + line i ppf "\n"; + arg_label_loc i ppf l; + expression (i + 1) ppf e + +and label_x_bool_x_core_type_list i ppf x = + match x with + | Rtag (l, attrs, b, ctl) -> + line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i + 1) ppf attrs; + list (i + 1) core_type ppf ctl + | Rinherit ct -> + line i ppf "Rinherit\n"; + core_type (i + 1) ppf ct + +let interface ppf x = list 0 signature_item ppf x + +let implementation ppf x = list 0 structure_item ppf x diff --git a/jscomp/ml/printast.mli b/compiler/ml/printast.mli similarity index 77% rename from jscomp/ml/printast.mli rename to compiler/ml/printast.mli index eb94a3b..87da253 100644 --- a/jscomp/ml/printast.mli +++ b/compiler/ml/printast.mli @@ -13,13 +13,12 @@ (* *) (**************************************************************************) -open Parsetree;; -open Format;; +open Parsetree +open Format -val interface : formatter -> signature_item list -> unit;; -val implementation : formatter -> structure_item list -> unit;; +val interface : formatter -> signature_item list -> unit +val implementation : formatter -> structure_item list -> unit - -val expression: int -> formatter -> expression -> unit -val structure: int -> formatter -> structure -> unit -val payload: int -> formatter -> payload -> unit +val expression : int -> formatter -> expression -> unit +val structure : int -> formatter -> structure -> unit +val payload : int -> formatter -> payload -> unit diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml new file mode 100644 index 0000000..0282f6e --- /dev/null +++ b/compiler/ml/printlambda.ml @@ -0,0 +1,398 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +open Format +open Asttypes +open Primitive +open Lambda + +let rec struct_const ppf = function + | Const_base (Const_int n) -> fprintf ppf "%i" n + | Const_base (Const_char i) -> + fprintf ppf "%s" (Pprintast.string_of_int_as_char i) + | Const_base (Const_string (s, _)) -> fprintf ppf "%S" s + | Const_immstring s -> fprintf ppf "#%S" s + | Const_base (Const_float f) -> fprintf ppf "%s" f + | Const_base (Const_int32 n) -> fprintf ppf "%lil" n + | Const_base (Const_int64 n) -> fprintf ppf "%LiL" n + | Const_base (Const_bigint (sign, n)) -> + fprintf ppf "%sn" (Bigint_utils.to_string sign n) + | Const_pointer (n, _) -> fprintf ppf "%ia" n + | Const_block (tag_info, []) -> + let tag = Lambda.tag_of_tag_info tag_info in + fprintf ppf "[%i]" tag + | Const_block (tag_info, sc1 :: scl) -> + let tag = Lambda.tag_of_tag_info tag_info in + let sconsts ppf scl = + List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl + in + fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl + | Const_false -> fprintf ppf "false" + | Const_true -> fprintf ppf "true" + +let value_kind = function + | Pgenval -> "" + +(* let field_kind = function + | Pgenval -> "*" + | Pintval -> "int" + | Pfloatval -> "float" + | Pboxedintval bi -> boxed_integer_name bi *) + +let string_of_loc_kind = function + | Loc_FILE -> "loc_FILE" + | Loc_LINE -> "loc_LINE" + | Loc_MODULE -> "loc_MODULE" + | Loc_POS -> "loc_POS" + | Loc_LOC -> "loc_LOC" + +(* let block_shape ppf shape = match shape with + | None | Some [] -> () + | Some l when List.for_all ((=) Pgenval) l -> () + | Some [elt] -> + Format.fprintf ppf " (%s)" (field_kind elt) + | Some (h :: t) -> + Format.fprintf ppf " (%s" (field_kind h); + List.iter (fun elt -> + Format.fprintf ppf ",%s" (field_kind elt)) + t; + Format.fprintf ppf ")" *) + +let str_of_field_info (fld_info : Lambda.field_dbg_info) = + match fld_info with + | Fld_module {name} + | Fld_record {name} + | Fld_record_inline {name} + | Fld_record_extension {name} -> + name + | Fld_tuple -> "[]" + | Fld_poly_var_tag -> "`" + | Fld_poly_var_content -> "#" + | Fld_extension -> "ext" + | Fld_variant -> "var" + | Fld_cons -> "cons" +let print_taginfo ppf = function + | Blk_extension -> fprintf ppf "ext" + | Blk_record_ext {fields = ss} -> + fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss)) + | Blk_tuple -> fprintf ppf "tuple" + | Blk_constructor {name; num_nonconst} -> + fprintf ppf "%s/%i" name num_nonconst + | Blk_poly_var name -> fprintf ppf "`%s" name + | Blk_record {fields = ss} -> + fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) + | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) + | Blk_some -> fprintf ppf "some" + | Blk_some_not_nested -> fprintf ppf "some_not_nested" + | Blk_module_export _ -> fprintf ppf "module/exports" + | Blk_record_inlined {fields = ss} -> + fprintf ppf "[%s]" (String.concat ";" (List.map fst (Array.to_list ss))) + +let primitive ppf = function + | Pidentity -> fprintf ppf "id" + | Pignore -> fprintf ppf "ignore" + | Pdebugger -> fprintf ppf "debugger" + | Ptypeof -> fprintf ppf "typeof" + | Pnull -> fprintf ppf "null" + | Pundefined -> fprintf ppf "undefined" + | Pfn_arity -> fprintf ppf "fn.length" + | Prevapply -> fprintf ppf "revapply" + | Pdirapply -> fprintf ppf "dirapply" + | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) + | Pgetglobal id -> fprintf ppf "global %a" Ident.print id + | Pmakeblock taginfo -> fprintf ppf "makeblock %a" print_taginfo taginfo + | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n + | Psetfield (n, _) -> fprintf ppf "setfield %i" n + | Pduprecord -> fprintf ppf "duprecord" + | Pccall p -> fprintf ppf "%s" p.prim_name + | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) + | Pobjcomp Ceq -> fprintf ppf "==" + | Pobjcomp Cneq -> fprintf ppf "!=" + | Pobjcomp Clt -> fprintf ppf "<" + | Pobjcomp Cle -> fprintf ppf "<=" + | Pobjcomp Cgt -> fprintf ppf ">" + | Pobjcomp Cge -> fprintf ppf ">=" + | Pobjorder -> fprintf ppf "compare" + | Pobjmin -> fprintf ppf "min" + | Pobjmax -> fprintf ppf "max" + | Pobjtag -> fprintf ppf "tag" + | Pobjsize -> fprintf ppf "length" + | Psequand -> fprintf ppf "&&" + | Psequor -> fprintf ppf "||" + | Pnot -> fprintf ppf "not" + | Pboolcomp Ceq -> fprintf ppf "==" + | Pboolcomp Cneq -> fprintf ppf "!=" + | Pboolcomp Clt -> fprintf ppf "<" + | Pboolcomp Cle -> fprintf ppf "<=" + | Pboolcomp Cgt -> fprintf ppf ">" + | Pboolcomp Cge -> fprintf ppf ">=" + | Pboolorder -> fprintf ppf "compare" + | Pboolmin -> fprintf ppf "min" + | Pboolmax -> fprintf ppf "max" + | Pnegint -> fprintf ppf "~-" + | Paddint -> fprintf ppf "+" + | Psubint -> fprintf ppf "-" + | Pmulint -> fprintf ppf "*" + | Pdivint -> fprintf ppf "/" + | Pmodint -> fprintf ppf "mod" + | Ppowint -> fprintf ppf "**" + | Pandint -> fprintf ppf "and" + | Porint -> fprintf ppf "or" + | Pxorint -> fprintf ppf "xor" + | Pnotint -> fprintf ppf "~~" + | Plslint -> fprintf ppf "lsl" + | Plsrint -> fprintf ppf "lsr" + | Pasrint -> fprintf ppf "asr" + | Pintcomp Ceq -> fprintf ppf "==" + | Pintcomp Cneq -> fprintf ppf "!=" + | Pintcomp Clt -> fprintf ppf "<" + | Pintcomp Cle -> fprintf ppf "<=" + | Pintcomp Cgt -> fprintf ppf ">" + | Pintcomp Cge -> fprintf ppf ">=" + | Pintorder -> fprintf ppf "compare" + | Pintmin -> fprintf ppf "min" + | Pintmax -> fprintf ppf "max" + | Poffsetint n -> fprintf ppf "%i+" n + | Poffsetref n -> fprintf ppf "+:=%i" n + | Pintoffloat -> fprintf ppf "int_of_float" + | Pfloatofint -> fprintf ppf "float_of_int" + | Pnegfloat -> fprintf ppf "~-." + | Pabsfloat -> fprintf ppf "abs." + | Paddfloat -> fprintf ppf "+." + | Psubfloat -> fprintf ppf "-." + | Pmulfloat -> fprintf ppf "*." + | Pdivfloat -> fprintf ppf "/." + | Pmodfloat -> fprintf ppf "mod" + | Ppowfloat -> fprintf ppf "**" + | Pfloatcomp Ceq -> fprintf ppf "==." + | Pfloatcomp Cneq -> fprintf ppf "!=." + | Pfloatcomp Clt -> fprintf ppf "<." + | Pfloatcomp Cle -> fprintf ppf "<=." + | Pfloatcomp Cgt -> fprintf ppf ">." + | Pfloatcomp Cge -> fprintf ppf ">=." + | Pfloatorder -> fprintf ppf "compare" + | Pfloatmin -> fprintf ppf "min" + | Pfloatmax -> fprintf ppf "max" + | Pnegbigint -> fprintf ppf "~-" + | Paddbigint -> fprintf ppf "+" + | Psubbigint -> fprintf ppf "-" + | Pmulbigint -> fprintf ppf "*" + | Ppowbigint -> fprintf ppf "**" + | Pandbigint -> fprintf ppf "and" + | Porbigint -> fprintf ppf "or" + | Pxorbigint -> fprintf ppf "xor" + | Pnotbigint -> fprintf ppf "~~" + | Plslbigint -> fprintf ppf "lsl" + | Pasrbigint -> fprintf ppf "asr" + | Pdivbigint -> fprintf ppf "/" + | Pmodbigint -> fprintf ppf "mod" + | Pbigintcomp Ceq -> fprintf ppf "==," + | Pbigintcomp Cneq -> fprintf ppf "!=," + | Pbigintcomp Clt -> fprintf ppf "<," + | Pbigintcomp Cle -> fprintf ppf "<=," + | Pbigintcomp Cgt -> fprintf ppf ">," + | Pbigintcomp Cge -> fprintf ppf ">=," + | Pbigintorder -> fprintf ppf "compare" + | Pbigintmin -> fprintf ppf "min" + | Pbigintmax -> fprintf ppf "max" + | Pstringlength -> fprintf ppf "string.length" + | Pstringrefu -> fprintf ppf "string.unsafe_get" + | Pstringrefs -> fprintf ppf "string.get" + | Pstringcomp Ceq -> fprintf ppf "==" + | Pstringcomp Cneq -> fprintf ppf "!=" + | Pstringcomp Clt -> fprintf ppf "<" + | Pstringcomp Cle -> fprintf ppf "<=" + | Pstringcomp Cgt -> fprintf ppf ">" + | Pstringcomp Cge -> fprintf ppf ">=" + | Pstringorder -> fprintf ppf "compare" + | Pstringmin -> fprintf ppf "min" + | Pstringmax -> fprintf ppf "max" + | Pstringadd -> fprintf ppf "string.concat" + | Parraylength -> fprintf ppf "array.length" + | Pmakearray Mutable -> fprintf ppf "makearray" + | Pmakearray Immutable -> fprintf ppf "makearray_imm" + | Parrayrefu -> fprintf ppf "array.unsafe_get" + | Parraysetu -> fprintf ppf "array.unsafe_set" + | Parrayrefs -> fprintf ppf "array.get" + | Parraysets -> fprintf ppf "array.set" + | Pmakelist Mutable -> fprintf ppf "makelist" + | Pmakelist Immutable -> fprintf ppf "makelist_imm" + | Pmakedict -> fprintf ppf "makedict" + | Pdict_has -> fprintf ppf "dict.has" + | Pisint -> fprintf ppf "isint" + | Pisout -> fprintf ppf "isout" + | Pisnullable -> fprintf ppf "isnullable" + | Pcreate_extension s -> fprintf ppf "extension[%s]" s + | Pextension_slot_eq -> fprintf ppf "#extension_slot_eq" + | Pwrap_exn -> fprintf ppf "wrap_exn" + | Pawait -> fprintf ppf "await" + | Pimport -> fprintf ppf "import" + | Pinit_mod -> fprintf ppf "#init_mod" + | Pupdate_mod -> fprintf ppf "#update_mod" + | Phash -> fprintf ppf "hash" + | Phash_mixint -> fprintf ppf "hash_mix_int" + | Phash_mixstring -> fprintf ppf "hash_mix_string" + | Phash_finalmix -> fprintf ppf "hash_final_mix" + | Pcurry_apply i -> fprintf ppf "apply[%d]" i + | Pjscomp Ceq -> fprintf ppf "==" + | Pjscomp Cneq -> fprintf ppf "!=" + | Pjscomp Clt -> fprintf ppf "<" + | Pjscomp Cle -> fprintf ppf "<=" + | Pjscomp Cgt -> fprintf ppf ">" + | Pjscomp Cge -> fprintf ppf ">=" + | Pnull_to_opt -> fprintf ppf "null_to_opt" + | Pnullable_to_opt -> fprintf ppf "nullable_to_opt" + | Pis_not_none -> fprintf ppf "#is_not_none" + | Pval_from_option -> fprintf ppf "#val_from_option" + | Pval_from_option_not_nest -> fprintf ppf "#val_from_option_not_nest" + | Pis_poly_var_block -> fprintf ppf "#is_poly_var_block" + | Pjs_raw_expr -> fprintf ppf "#raw_expr" + | Pjs_raw_stmt -> fprintf ppf "#raw_stmt" + | Pjs_fn_make arity -> fprintf ppf "#fn_mk(%d)" arity + | Pjs_fn_make_unit -> fprintf ppf "#fn_mk_unit" + | Pjs_fn_method -> fprintf ppf "#fn_method" + +let function_attribute ppf {inline; is_a_functor; return_unit} = + if is_a_functor then fprintf ppf "is_a_functor@ "; + if return_unit then fprintf ppf "void@ "; + match inline with + | Default_inline -> () + | Always_inline -> fprintf ppf "always_inline@ " + | Never_inline -> fprintf ppf "never_inline@ " + +let apply_inlined_attribute ppf = function + | Default_inline -> () + | Always_inline -> fprintf ppf " always_inline" + | Never_inline -> fprintf ppf " never_inline" + +let rec lam ppf = function + | Lvar id -> Ident.print ppf id + | Lconst cst -> struct_const ppf cst + | Lapply ap -> + let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(apply@ %a%a%a)@]" lam ap.ap_func lams ap.ap_args + apply_inlined_attribute ap.ap_inlined + | Lfunction {params; body; attr} -> + let pr_params ppf params = + List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params + in + fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params function_attribute + attr lam body + | Llet (str, k, id, arg, body) -> + let kind = function + | Alias -> "a" + | Strict -> "" + | StrictOpt -> "o" + | Variable -> "v" + in + let rec letbody = function + | Llet (str, k, id, arg, body) -> + fprintf ppf "@ @[<2>%a =%s%s@ %a@]" Ident.print id (kind str) + (value_kind k) lam arg; + letbody body + | expr -> expr + in + fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" Ident.print id + (kind str) (value_kind k) lam arg; + let expr = letbody body in + fprintf ppf ")@]@ %a)@]" lam expr + | Lletrec (id_arg_list, body) -> + let bindings ppf id_arg_list = + let spc = ref false in + List.iter + (fun (id, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) + id_arg_list + in + fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam + body + | Lprim (prim, largs, _) -> + let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs + | Lswitch (larg, sw, _loc) -> + let switch ppf sw = + let spc = ref false in + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case int %i:@ %a@]" n lam l) + sw.sw_consts; + List.iter + (fun (n, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case tag %i:@ %a@]" n lam l) + sw.sw_blocks; + match sw.sw_failaction with + | None -> () + | Some l -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam l + in + fprintf ppf "@[<1>(%s %a@ @[%a@])@]" + (match sw.sw_failaction with + | None -> "switch*" + | _ -> "switch") + lam larg switch sw + | Lstringswitch (arg, cases, default, _) -> + let switch ppf cases = + let spc = ref false in + List.iter + (fun (s, l) -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) + cases; + match default with + | Some default -> + if !spc then fprintf ppf "@ " else spc := true; + fprintf ppf "@[default:@ %a@]" lam default + | None -> () + in + fprintf ppf "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases + | Lstaticraise (i, ls) -> + let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in + fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls + | Lstaticcatch (lbody, (i, vars), lhandler) -> + fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i + (fun ppf vars -> + match vars with + | [] -> () + | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) + vars lam lhandler + | Ltrywith (lbody, param, lhandler) -> + fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print + param lam lhandler + | Lifthenelse (lcond, lif, lelse) -> + fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse + | Lsequence (l1, l2) -> fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 + | Lwhile (lcond, lbody) -> + fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody + | Lfor (param, lo, hi, dir, body) -> + fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo + (match dir with + | Upto -> "to" + | Downto -> "downto") + lam hi lam body + | Lassign (id, expr) -> + fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr + | Lsend (name, obj, _) -> fprintf ppf "@[<2>(send%s@ %a@ )@]" name lam obj + +and sequence ppf = function + | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 + | l -> lam ppf l + +let structured_constant = struct_const + +let lambda = lam diff --git a/jscomp/ml/printlambda.mli b/compiler/ml/printlambda.mli similarity index 82% rename from jscomp/ml/printlambda.mli rename to compiler/ml/printlambda.mli index d9d2420..d20fa3e 100644 --- a/jscomp/ml/printlambda.mli +++ b/compiler/ml/printlambda.mli @@ -17,9 +17,5 @@ open Lambda open Format -val structured_constant: formatter -> structured_constant -> unit -val lambda: formatter -> lambda -> unit - -val primitive: formatter -> primitive -> unit -val name_of_primitive : primitive -> string -val value_kind : value_kind -> string +val structured_constant : formatter -> structured_constant -> unit +val lambda : formatter -> lambda -> unit diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml new file mode 100644 index 0000000..9cf370d --- /dev/null +++ b/compiler/ml/printtyp.ml @@ -0,0 +1,1829 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, 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. *) +(* *) +(**************************************************************************) + +(* Printing functions *) + +open Misc +open Ctype +open Format +open Longident +open Path +open Asttypes +open Types +open Btype +open Outcometree + +type printing_context = {inlined_types: type_inlined_type list} + +let print_res_poly_identifier : (string -> string) ref = + ref (fun _ -> assert false) + +(* Print a long identifier *) + +let rec longident ppf = function + | Lident s -> pp_print_string ppf s + | Ldot (p, s) -> fprintf ppf "%a.%s" longident p s + | Lapply (p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 + +(* Print an identifier *) + +let unique_names = ref Ident.empty + +let ident_name id = + try Ident.find_same id !unique_names with Not_found -> Ident.name id + +let add_unique id = + try ignore (Ident.find_same id !unique_names) + with Not_found -> + unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names + +let ident ppf id = pp_print_string ppf (ident_name id) + +(* Print a path *) + +let ident_pervasives = Ident.create_persistent "Pervasives" +let ident_stdlib = Ident.create_persistent "Stdlib" +let printing_env = ref Env.empty +let non_shadowed_pervasive_or_stdlib = function + | Pdot (Pident id, s, _pos) as path -> ( + (Ident.same id ident_pervasives || Ident.same id ident_stdlib) + && + try Path.same path (Env.lookup_type (Lident s) !printing_env) + with Not_found -> true) + | _ -> false + +let rec tree_of_path = function + | Pident id -> Oide_ident (ident_name id) + | Pdot (_, s, _pos) as path when non_shadowed_pervasive_or_stdlib path -> + Oide_ident s + | Pdot (p, s, _pos) when String.starts_with (Path.name p) ~prefix:"Stdlib_" -> + let path_name = Path.name p in + let ident_without_stdlib_prefix = + String.sub path_name 7 (String.length path_name - 7) + in + Oide_dot (Oide_ident ident_without_stdlib_prefix, s) + | Pdot (p, s, _pos) -> Oide_dot (tree_of_path p, s) + | Papply (p1, p2) -> Oide_apply (tree_of_path p1, tree_of_path p2) + +let rec path ppf = function + | Pident id -> ident ppf id + | Pdot (_, s, _pos) as path when non_shadowed_pervasive_or_stdlib path -> + pp_print_string ppf s + | Pdot (p, s, _pos) -> + path ppf p; + pp_print_char ppf '.'; + pp_print_string ppf s + | Papply (p1, p2) -> fprintf ppf "%a(%a)" path p1 path p2 + +let rec string_of_out_ident = function + | Oide_ident s -> s + | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s] + | Oide_apply (id1, id2) -> + String.concat "" + [string_of_out_ident id1; "("; string_of_out_ident id2; ")"] + +let string_of_path p = string_of_out_ident (tree_of_path p) + +(* Print a recursive annotation *) + +let tree_of_rec = function + | Trec_not -> Orec_not + | Trec_first -> Orec_first + | Trec_next -> Orec_next + +(* Print a raw type expression, with sharing *) + +let raw_list pr ppf = function + | [] -> fprintf ppf "[]" + | a :: l -> + fprintf ppf "@[<1>[%a%t]@]" pr a (fun ppf -> + List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) + +let kind_vars = ref [] +let kind_count = ref 0 + +let rec safe_kind_repr v = function + | Fvar {contents = Some k} -> + if List.memq k v then "Fvar loop" else safe_kind_repr (k :: v) k + | Fvar r -> + let vid = + try List.assq r !kind_vars + with Not_found -> + let c = + incr kind_count; + !kind_count + in + kind_vars := (r, c) :: !kind_vars; + c + in + Printf.sprintf "Fvar {None}@%d" vid + | Fpresent -> "Fpresent" + | Fabsent -> "Fabsent" + +let rec safe_commu_repr v = function + | Cok -> "Cok" + | Cunknown -> "Cunknown" + | Clink r -> + if List.memq r v then "Clink loop" else safe_commu_repr (r :: v) !r + +let rec safe_repr v = function + | {desc = Tlink t} when not (List.memq t v) -> safe_repr (t :: v) t + | t -> t + +let rec list_of_memo = function + | Mnil -> [] + | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem + | Mlink rem -> list_of_memo !rem + +let print_name ppf = function + | None -> fprintf ppf "None" + | Some name -> fprintf ppf "\"%s\"" name + +let string_of_label = function + | Nolabel -> "" + | Labelled {txt} -> txt + | Optional {txt} -> "?" ^ txt + +let string_of_arity = function + | None -> "" + | Some arity -> string_of_int arity + +let visited = ref [] +let rec raw_type ppf ty = + let ty = safe_repr [] ty in + if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id + else ( + visited := ty :: !visited; + fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level raw_type_desc + ty.desc) + +and raw_type_list tl = raw_list raw_type tl + +and raw_type_desc ppf = function + | Tvar name -> fprintf ppf "Tvar %a" print_name name + | Tarrow (arg, ret, c, a) -> + fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s,@,%s)@]" + (string_of_label arg.lbl) raw_type arg.typ raw_type ret + (safe_commu_repr [] c) (string_of_arity a) + | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl + | Tconstr (p, tl, abbrev) -> + fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p raw_type_list tl + (raw_list path) (list_of_memo !abbrev) + | Tobject (t, nm) -> + fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t (fun ppf -> + match !nm with + | None -> fprintf ppf " None" + | Some (p, tl) -> + fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) + | Tfield (f, k, t1, t2) -> + fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f + (safe_kind_repr [] k) raw_type t1 raw_type t2 + | Tnil -> fprintf ppf "Tnil" + | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t + | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t + | Tunivar name -> fprintf ppf "Tunivar %a" print_name name + | Tpoly (t, tl) -> + fprintf ppf "@[Tpoly(@,%a,@,%a)@]" raw_type t raw_type_list tl + | Tvariant row -> + fprintf ppf + "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%B;@ @[<1>%s%t@]}@]" + "row_fields=" + (raw_list (fun ppf (l, f) -> fprintf ppf "@[%s,@ %a@]" l raw_field f)) + row.row_fields "row_more=" raw_type row.row_more "row_closed=" + row.row_closed "row_fixed=" row.row_fixed "row_name=" + (fun ppf -> + match row.row_name with + | None -> fprintf ppf "None" + | Some (p, tl) -> fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) + | Tpackage (p, _, tl) -> + fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p raw_type_list tl + +and raw_field ppf = function + | Rpresent None -> fprintf ppf "Rpresent None" + | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t + | Reither (c, tl, m, e) -> + fprintf ppf "@[Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c raw_type_list + tl m (fun ppf -> + match !e with + | None -> fprintf ppf " None" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) + | Rabsent -> fprintf ppf "Rabsent" + +let raw_type_expr ppf t = + visited := []; + kind_vars := []; + kind_count := 0; + raw_type ppf t; + visited := []; + kind_vars := [] + +let () = Btype.print_raw := raw_type_expr + +(* Normalize paths *) + +type param_subst = Id | Nth of int | Map of int list + +let is_nth = function + | Nth _ -> true + | _ -> false + +let compose l1 = function + | Id -> Map l1 + | Map l2 -> Map (List.map (List.nth l1) l2) + | Nth n -> Nth (List.nth l1 n) + +let apply_subst s1 tyl = + if tyl = [] then [] + (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) + else + match s1 with + | Nth n1 -> [List.nth tyl n1] + | Map l1 -> List.map (List.nth tyl) l1 + | Id -> tyl + +type best_path = Paths of Path.t list | Best of Path.t + +let printing_depth = ref 0 +let printing_cont = ref ([] : Env.iter_cont list) +let printing_old = ref Env.empty +let printing_pers = ref Concr.empty +module PathMap = Map.Make (Path) +let printing_map = ref PathMap.empty + +let same_type t t' = repr t == repr t' + +let rec index l x = + match l with + | [] -> raise Not_found + | a :: l -> if x == a then 0 else 1 + index l x + +let rec uniq = function + | [] -> true + | a :: l -> (not (List.memq a l)) && uniq l + +let rec normalize_type_path ?(cache = false) env p = + try + let params, ty, _ = Env.find_type_expansion p env in + let params = List.map repr params in + match repr ty with + | {desc = Tconstr (p1, tyl, _)} -> + let tyl = List.map repr tyl in + if List.length params = List.length tyl && List.for_all2 ( == ) params tyl + then normalize_type_path ~cache env p1 + else if cache || List.length params <= List.length tyl || not (uniq tyl) + then (p, Id) + else + let l1 = List.map (index params) tyl in + let p2, s2 = normalize_type_path ~cache env p1 in + (p2, compose l1 s2) + | ty -> (p, Nth (index params ty)) + with Not_found -> (Env.normalize_path None env p, Id) + +let penalty s = + if s <> "" && s.[0] = '_' then 10 + else + try + for i = 0 to String.length s - 2 do + if s.[i] = '_' && s.[i + 1] = '_' then raise Exit + done; + 1 + with Exit -> 10 + +let rec path_size = function + | Pident id -> (penalty (Ident.name id), -Ident.binding_time id) + | Pdot (p, _, _) -> + let l, b = path_size p in + (1 + l, b) + | Papply (p1, p2) -> + let l, b = path_size p1 in + (l + fst (path_size p2), b) + +let same_printing_env env = + let used_pers = Env.used_persistent () in + Env.same_types !printing_old env && Concr.equal !printing_pers used_pers + +let set_printing_env env = + printing_env := env; + if !Clflags.real_paths || !printing_env == Env.empty || same_printing_env env + then () + else ( + (* printf "Reset printing_map@."; *) + printing_old := env; + printing_pers := Env.used_persistent (); + printing_map := PathMap.empty; + printing_depth := 0; + (* printf "Recompute printing_map.@."; *) + let cont = + Env.iter_types + (fun p (p', _decl) -> + let p1, s1 = normalize_type_path env p' ~cache:true in + (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) + if s1 = Id then + try + let r = PathMap.find p1 !printing_map in + match !r with + | Paths l -> r := Paths (p :: l) + | Best p' -> r := Paths [p; p'] + (* assert false *) + with Not_found -> + printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map) + env + in + printing_cont := [cont]) + +let wrap_printing_env env f = + set_printing_env env; + try_finally f (fun () -> set_printing_env Env.empty) + +let wrap_printing_env env f = Env.without_cmis (wrap_printing_env env) f + +let is_unambiguous path env = + let l = Env.find_shadowed_types path env in + List.exists (Path.same path) l + || + (* concrete paths are ok *) + match l with + | [] -> true + | p :: rem -> + (* allow also coherent paths: *) + let normalize p = fst (normalize_type_path ~cache:true env p) in + let p' = normalize p in + List.for_all (fun p -> Path.same (normalize p) p') rem + || + (* also allow repeatedly defining and opening (for toplevel) *) + let id = lid_of_path p in + List.for_all (fun p -> lid_of_path p = id) rem + && Path.same p (Env.lookup_type id env) + +let rec get_best_path r = + match !r with + | Best p' -> p' + | Paths [] -> raise Not_found + | Paths l -> + r := Paths []; + List.iter + (fun p -> + (* Format.eprintf "evaluating %a@." path p; *) + match !r with + | Best p' when path_size p >= path_size p' -> () + | _ -> if is_unambiguous p !printing_env then r := Best p) + (* else Format.eprintf "%a ignored as ambiguous@." path p *) + l; + get_best_path r + +let best_type_path p = + if !Clflags.real_paths || !printing_env == Env.empty then (p, Id) + else + let p', s = normalize_type_path !printing_env p in + let get_path () = get_best_path (PathMap.find p' !printing_map) in + while + !printing_cont <> [] + && + try fst (path_size (get_path ())) > !printing_depth + with Not_found -> true + do + printing_cont := List.map snd (Env.run_iter_cont !printing_cont); + incr printing_depth + done; + let p'' = try get_path () with Not_found -> p' in + (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) + (p'', s) + +(* Print a type expression *) + +let names = ref ([] : (type_expr * string) list) +let name_counter = ref 0 +let named_vars = ref ([] : string list) + +let weak_counter = ref 1 +let weak_var_map = ref TypeMap.empty +let named_weak_vars = ref StringSet.empty + +let reset_names () = + names := []; + name_counter := 0; + named_vars := [] +let add_named_var ty = + match ty.desc with + | Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else named_vars := name :: !named_vars + | _ -> () + +let name_is_already_used name = + List.mem name !named_vars + || List.exists (fun (_, name') -> name = name') !names + || StringSet.mem name !named_weak_vars + +let rec new_name () = + let name = + if !name_counter < 26 then String.make 1 (Char.chr (97 + !name_counter)) + else + String.make 1 (Char.chr (97 + (!name_counter mod 26))) + ^ string_of_int (!name_counter / 26) + in + incr name_counter; + if name_is_already_used name then new_name () else name + +let rec new_weak_name ty () = + let name = "weak" ^ string_of_int !weak_counter in + incr weak_counter; + if name_is_already_used name then new_weak_name ty () + else ( + named_weak_vars := StringSet.add name !named_weak_vars; + weak_var_map := TypeMap.add ty name !weak_var_map; + name) + +let name_of_type name_generator t = + (* We've already been through repr at this stage, so t is our representative + of the union-find class. *) + try List.assq t !names + with Not_found -> ( + try TypeMap.find t !weak_var_map + with Not_found -> + let name = + match t.desc with + | Tvar (Some name) | Tunivar (Some name) -> + (* Some part of the type we've already printed has assigned another + * unification variable to that name. We want to keep the name, so try + * adding a number until we find a name that's not taken. *) + let current_name = ref name in + let i = ref 0 in + while List.exists (fun (_, name') -> !current_name = name') !names do + current_name := name ^ string_of_int !i; + i := !i + 1 + done; + !current_name + | _ -> + (* No name available, create a new one *) + name_generator () + in + (* Exception for type declarations *) + if name <> "_" then names := (t, name) :: !names; + name) + +let check_name_of_type t = ignore (name_of_type new_name t) + +let remove_names tyl = + let tyl = List.map repr tyl in + names := Ext_list.filter !names (fun (ty, _) -> not (List.memq ty tyl)) + +let visited_objects = ref ([] : type_expr list) +let aliased = ref ([] : type_expr list) +let delayed = ref ([] : type_expr list) + +let add_delayed t = if not (List.memq t !delayed) then delayed := t :: !delayed + +let is_aliased ty = List.memq (proxy ty) !aliased +let add_alias ty = + let px = proxy ty in + if not (is_aliased px) then ( + aliased := px :: !aliased; + add_named_var px) + +let aliasable ty = + match ty.desc with + | Tvar _ | Tunivar _ | Tpoly _ -> false + | Tconstr (p, _, _) -> not (is_nth (snd (best_type_path p))) + | _ -> true + +let namable_row row = + row.row_name <> None + && List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither (c, l, _, _) -> + row.row_closed && if c then l = [] else List.length l = 1 + | _ -> true) + row.row_fields + +let rec mark_loops_rec visited ty = + let ty = repr ty in + let px = proxy ty in + if List.memq px visited && aliasable ty then add_alias px + else + let visited = px :: visited in + match ty.desc with + | Tvar _ -> add_named_var ty + | Tarrow (arg, ret, _, _) -> + mark_loops_rec visited arg.typ; + mark_loops_rec visited ret + | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl + | Tconstr (p, tyl, _) -> + let _p', s = best_type_path p in + List.iter (mark_loops_rec visited) (apply_subst s tyl) + | Tpackage (_, _, tyl) -> List.iter (mark_loops_rec visited) tyl + | Tvariant row -> ( + if List.memq px !visited_objects then add_alias px + else + let row = row_repr row in + if not (static_row row) then visited_objects := px :: !visited_objects; + match row.row_name with + | Some (_p, tyl) when namable_row row -> + List.iter (mark_loops_rec visited) tyl + | _ -> iter_row (mark_loops_rec visited) row) + | Tobject (fi, nm) -> + if List.memq px !visited_objects then add_alias px + else ( + if opened_object ty then visited_objects := px :: !visited_objects; + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpresent then mark_loops_rec visited ty) + fields + | Some (_, l) -> List.iter (mark_loops_rec visited) (List.tl l)) + | Tfield (_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> + mark_loops_rec visited ty1; + mark_loops_rec visited ty2 + | Tfield (_, _, _, ty2) -> mark_loops_rec visited ty2 + | Tnil -> () + | Tsubst ty -> mark_loops_rec visited ty + | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" + | Tpoly (ty, tyl) -> + List.iter (fun t -> add_alias t) tyl; + mark_loops_rec visited ty + | Tunivar _ -> add_named_var ty + +let mark_loops ty = + normalize_type Env.empty ty; + mark_loops_rec [] ty + +let reset_loop_marks () = + visited_objects := []; + aliased := []; + delayed := [] + +let reset () = + unique_names := Ident.empty; + reset_names (); + reset_loop_marks () + +let reset_and_mark_loops ty = + reset (); + mark_loops ty + +let reset_and_mark_loops_list tyl = + reset (); + List.iter mark_loops tyl + +let filter_params tyl = + let params = + List.fold_left + (fun tyl ty -> + let ty = repr ty in + if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl + else ty :: tyl) + [] tyl + in + List.rev params + +let mark_loops_constructor_arguments = function + | Cstr_tuple l -> List.iter mark_loops l + | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l + +let find_inlined_type name (printing_context : printing_context option) = + match printing_context with + | None -> None + | Some {inlined_types} -> + inlined_types + |> List.find_opt (fun inlined_type -> + match inlined_type with + | Record {type_name} -> type_name = name) + +(* Disabled in classic mode when printing an unification error *) + +let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = + let ty = repr ty in + let px = proxy ty in + if List.mem_assq px !names && not (List.memq px !delayed) then + let mark = is_non_gen sch ty in + let name = name_of_type (if mark then new_weak_name ty else new_name) px in + Otyp_var (mark, name) + else + let pr_typ () = + match ty.desc with + | Tvar _ -> + (*let lev = + if is_non_gen sch ty then "/" ^ string_of_int ty.level else "" in*) + let non_gen = is_non_gen sch ty in + let name_gen = if non_gen then new_weak_name ty else new_name in + Otyp_var (non_gen, name_of_type name_gen ty) + | Tarrow (arg, ret, _, arity) -> + let lab = string_of_label arg.lbl in + let t1 = + if is_optional arg.lbl then + match (repr arg.typ).desc with + | Tconstr (path, [ty], _) when Path.same path Predef.path_option -> + tree_of_typexp ?printing_context sch ty + | _ -> Otyp_stuff "" + else tree_of_typexp ?printing_context sch arg.typ + in + (* should pass arity here? *) + Otyp_arrow (lab, t1, tree_of_typexp ?printing_context sch ret, arity) + | Ttuple tyl -> Otyp_tuple (tree_of_typlist ?printing_context sch tyl) + | Tconstr (p, _tyl, _abbrev) + when printing_context + |> find_inlined_type (Path.name p) + |> Option.is_some -> ( + match + find_inlined_type (Path.name p) printing_context |> Option.get + with + | Record {labels} -> + (* Print inlined records as actual inlined record structures, not a reference to the inlined type only. *) + Otyp_record (List.map (tree_of_label ?printing_context) labels)) + | Tconstr (p, tyl, _abbrev) -> + let p', s = best_type_path p in + let tyl' = apply_subst s tyl in + if is_nth s && not (tyl' = []) then + tree_of_typexp ?printing_context sch (List.hd tyl') + else + Otyp_constr + (tree_of_path p', tree_of_typlist ?printing_context sch tyl') + | Tvariant row -> ( + let row = row_repr row in + let fields = + if row.row_closed then + Ext_list.filter row.row_fields (fun (_, f) -> + row_field_repr f <> Rabsent) + else row.row_fields + in + let present = + Ext_list.filter fields (fun (_, f) -> + match row_field_repr f with + | Rpresent _ -> true + | _ -> false) + in + let all_present = List.length present = List.length fields in + match row.row_name with + | Some (p, tyl) when namable_row row -> + let p', s = best_type_path p in + let id = tree_of_path p' in + let args = + tree_of_typlist ?printing_context sch (apply_subst s tyl) + in + let out_variant = + if is_nth s then List.hd args else Otyp_constr (id, args) + in + if row.row_closed && all_present then out_variant + else + let non_gen = is_non_gen sch px in + let tags = + if all_present then None else Some (List.map fst present) + in + Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags) + | _ -> + let non_gen = + (not (row.row_closed && all_present)) && is_non_gen sch px + in + let fields = + List.map (tree_of_row_field ?printing_context sch) fields + in + let tags = + if all_present then None else Some (List.map fst present) + in + Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)) + | Tobject (fi, nm) -> tree_of_typobject ?printing_context sch fi !nm + | Tnil | Tfield _ -> tree_of_typobject ?printing_context sch ty None + | Tsubst ty -> tree_of_typexp ?printing_context sch ty + | Tlink _ -> fatal_error "Printtyp.tree_of_typexp" + | Tpoly (ty, []) -> tree_of_typexp ?printing_context sch ty + | Tpoly (ty, tyl) -> + (*let print_names () = + List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; + prerr_string "; " in *) + let tyl = List.map repr tyl in + if tyl = [] then tree_of_typexp ?printing_context sch ty + else + let old_delayed = !delayed in + (* Make the names delayed, so that the real type is + printed once when used as proxy *) + List.iter add_delayed tyl; + let tl = List.map (name_of_type new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp ?printing_context sch ty) in + (* Forget names when we leave scope *) + remove_names tyl; + delayed := old_delayed; + tr + | Tunivar _ -> Otyp_var (false, name_of_type new_name ty) + | Tpackage (p, n, tyl) -> + let n = + List.map (fun li -> String.concat "." (Longident.flatten li)) n + in + Otyp_module (Path.name p, n, tree_of_typlist ?printing_context sch tyl) + in + if List.memq px !delayed then + delayed := Ext_list.filter !delayed (( != ) px); + if is_aliased px && aliasable ty then ( + check_name_of_type px; + Otyp_alias (pr_typ (), name_of_type new_name px)) + else pr_typ () + +and tree_of_row_field ?printing_context sch (l, f) = + match row_field_repr f with + | Rpresent None | Reither (true, [], _, _) -> (l, false, []) + | Rpresent (Some ty) -> (l, false, [tree_of_typexp ?printing_context sch ty]) + | Reither (c, tyl, _, _) -> + if c (* contradiction: constant constructor with an argument *) then + (l, true, tree_of_typlist ?printing_context sch tyl) + else (l, false, tree_of_typlist ?printing_context sch tyl) + | Rabsent -> (l, false, [] (* actually, an error *)) + +and tree_of_typlist ?printing_context sch tyl = + List.map ((tree_of_typexp ?printing_context) sch) tyl + +and tree_of_typobject ?printing_context sch fi nm = + match nm with + | None -> + let pr_fields fi = + let fields, rest = flatten_fields fi in + let present_fields = + List.fold_right + (fun (n, k, t) l -> + match field_kind_repr k with + | Fpresent -> (n, t) :: l + | _ -> l) + fields [] + in + let sorted_fields = + List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields + in + tree_of_typfields ?printing_context sch rest sorted_fields + in + let fields, rest = pr_fields fi in + Otyp_object (fields, rest) + | Some (p, ty :: tyl) -> + let non_gen = is_non_gen sch (repr ty) in + let args = tree_of_typlist ?printing_context sch tyl in + let p', s = best_type_path p in + assert (s = Id); + Otyp_class (non_gen, tree_of_path p', args) + | _ -> fatal_error "Printtyp.tree_of_typobject" + +and is_non_gen sch ty = sch && is_Tvar ty && ty.level <> generic_level + +and tree_of_typfields ?printing_context sch rest = function + | [] -> + let rest = + match rest.desc with + | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) + | Tconstr _ -> Some false + | Tnil -> None + | _ -> fatal_error "typfields (1)" + in + ([], rest) + | (s, t) :: l -> + let field = (s, tree_of_typexp ?printing_context sch t) in + let fields, rest = tree_of_typfields ?printing_context sch rest l in + (field :: fields, rest) + +and tree_of_type_decl id decl = + reset (); + + let inlined_types = decl.type_inlined_types in + let printing_context = {inlined_types} in + let params = filter_params decl.type_params in + + (match decl.type_manifest with + | Some ty -> + let vars = free_variables ty in + List.iter + (function + | {desc = Tvar (Some "_")} as ty -> + if List.memq ty vars then ty.desc <- Tvar None + | _ -> ()) + params + | None -> ()); + + List.iter add_alias params; + List.iter mark_loops params; + List.iter check_name_of_type (List.map proxy params); + let ty_manifest = + match decl.type_manifest with + | None -> None + | Some ty -> + let ty = + (* Special hack to hide variant name *) + match repr ty with + | {desc = Tvariant row} -> ( + let row = row_repr row in + match row.row_name with + | Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant {row with row_name = None}) + | _ -> ty) + | _ -> ty + in + mark_loops ty; + Some ty + in + (match decl.type_kind with + | Type_abstract -> () + | Type_variant cstrs -> + List.iter + (fun c -> + mark_loops_constructor_arguments c.cd_args; + may mark_loops c.cd_res) + cstrs + | Type_record (l, _rep) -> List.iter (fun l -> mark_loops l.ld_type) l + | Type_open -> ()); + + let type_param = function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let type_defined decl = + let abstr = + match decl.type_kind with + | Type_abstract -> + decl.type_manifest = None || decl.type_private = Private + | Type_record _ -> decl.type_private = Private + | Type_variant tll -> + decl.type_private = Private + || List.exists (fun cd -> cd.cd_res <> None) tll + | Type_open -> decl.type_manifest = None + in + let vari = + List.map2 + (fun ty v -> + if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v + else (true, true)) + decl.type_params decl.type_variance + in + ( Ident.name id, + List.map2 + (fun ty cocn -> + (type_param (tree_of_typexp ~printing_context false ty), cocn)) + params vari ) + in + let tree_of_manifest ty1 = + match ty_manifest with + | None -> ty1 + | Some ty -> Otyp_manifest (tree_of_typexp ~printing_context false ty, ty1) + in + let name, args = type_defined decl in + let constraints = tree_of_constraints ~printing_context params in + let untagged = ref false in + let ty, priv = + match decl.type_kind with + | Type_abstract -> ( + match ty_manifest with + | None -> (Otyp_abstract, Public) + | Some ty -> (tree_of_typexp ~printing_context false ty, decl.type_private) + ) + | Type_variant cstrs -> + untagged := Ast_untagged_variants.process_untagged decl.type_attributes; + ( tree_of_manifest + (Otyp_sum (List.map (tree_of_constructor ~printing_context) cstrs)), + decl.type_private ) + | Type_record (lbls, _rep) -> + ( tree_of_manifest + (Otyp_record (List.map (tree_of_label ~printing_context) lbls)), + decl.type_private ) + | Type_open -> (tree_of_manifest Otyp_open, decl.type_private) + in + let immediate = Builtin_attributes.immediate decl.type_attributes in + { + otype_name = name; + otype_params = args; + otype_type = ty; + otype_private = priv; + otype_immediate = immediate; + otype_unboxed = decl.type_unboxed.unboxed || !untagged; + otype_cstrs = constraints; + } + +and tree_of_constructor_arguments ?printing_context = function + | Cstr_tuple l -> tree_of_typlist ?printing_context false l + | Cstr_record l -> [Otyp_record (List.map tree_of_label l)] + +and tree_of_constructor ?printing_context cd = + let name = Ident.name cd.cd_id in + let nullary = Ast_untagged_variants.is_nullary_variant cd.cd_args in + let repr = + if not nullary then None + else + match Ast_untagged_variants.process_tag_type cd.cd_attributes with + | Some Null -> Some "@as(null)" + | Some Undefined -> Some "@as(undefined)" + | Some (String s) -> Some (Printf.sprintf "@as(%S)" s) + | Some (Int i) -> Some (Printf.sprintf "@as(%d)" i) + | Some (Float f) -> Some (Printf.sprintf "@as(%s)" f) + | Some (Bool b) -> Some (Printf.sprintf "@as(%b)" b) + | Some (BigInt s) -> Some (Printf.sprintf "@as(%sn)" s) + | Some (Untagged _) (* should never happen *) | None -> None + in + let arg () = tree_of_constructor_arguments ?printing_context cd.cd_args in + match cd.cd_res with + | None -> (name, arg (), None, repr) + | Some res -> + let nm = !names in + names := []; + let ret = tree_of_typexp ?printing_context false res in + let args = arg () in + names := nm; + (name, args, Some ret, repr) + +and tree_of_label ?printing_context l = + let opt = l.ld_optional in + let typ = + match l.ld_type.desc with + | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 + | _ -> l.ld_type + in + ( Ident.name l.ld_id, + l.ld_mutable = Mutable, + opt, + tree_of_typexp ?printing_context false typ ) + +and tree_of_constraints ?printing_context params = + List.fold_right + (fun ty list -> + let ty' = unalias ty in + if proxy ty != proxy ty' then + let tr = tree_of_typexp ?printing_context true ty in + (tr, tree_of_typexp ?printing_context true ty') :: list + else list) + params [] + +let typexp ?printing_context sch ppf ty = + !Oprint.out_type ppf (tree_of_typexp ?printing_context sch ty) + +let type_expr ppf ty = typexp false ppf ty + +and type_sch ppf ty = typexp true ppf ty + +and type_scheme ppf ty = + reset_and_mark_loops ty; + typexp true ppf ty + +(* Maxence *) +let type_scheme_max ?(b_reset_names = true) ppf ty = + if b_reset_names then reset_names (); + typexp true ppf ty +(* End Maxence *) + +let tree_of_type_scheme ty = + reset_and_mark_loops ty; + tree_of_typexp true ty + +(* Print one type declaration *) + +let tree_of_type_declaration id decl rs = + Osig_type (tree_of_type_decl id decl, tree_of_rec rs) + +let type_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_not) + +let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + +(* Print an extension declaration *) + +let tree_of_extension_constructor id ext es = + reset (); + let ty_name = Path.name ext.ext_type_path in + let ty_params = filter_params ext.ext_type_params in + List.iter add_alias ty_params; + List.iter mark_loops ty_params; + List.iter check_name_of_type (List.map proxy ty_params); + mark_loops_constructor_arguments ext.ext_args; + may mark_loops ext.ext_ret_type; + let type_param = function + | Otyp_var (_, id) -> id + | _ -> "?" + in + let ty_params = + List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params + in + let name = Ident.name id in + let args, ret = + match ext.ext_ret_type with + | None -> (tree_of_constructor_arguments ext.ext_args, None) + | Some res -> + let nm = !names in + names := []; + let ret = tree_of_typexp false res in + let args = tree_of_constructor_arguments ext.ext_args in + names := nm; + (args, Some ret) + in + let ext = + { + oext_name = name; + oext_type_name = ty_name; + oext_type_params = ty_params; + oext_args = args; + oext_ret_type = ret; + oext_repr = None; + oext_private = ext.ext_private; + } + in + let es = + match es with + | Text_first -> Oext_first + | Text_next -> Oext_next + | Text_exception -> Oext_exception + in + Osig_typext (ext, es) + +let extension_constructor id ppf ext = + !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) + +(* Print a value declaration *) + +let tree_of_value_description id decl = + (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) + let id = Ident.name id in + let ty = tree_of_type_scheme decl.val_type in + let vd = + {oval_name = id; oval_type = ty; oval_prims = []; oval_attributes = []} + in + let vd = + match decl.val_kind with + | Val_prim p -> Primitive.print p vd + | _ -> vd + in + Osig_value vd + +let value_description id ppf decl = + !Oprint.out_sig_item ppf (tree_of_value_description id decl) + +(* Print a class type *) + +(* Print a module type *) + +let wrap_env fenv ftree arg = + let env = !printing_env in + set_printing_env (fenv env); + let tree = ftree arg in + set_printing_env env; + tree + +let filter_rem_sig item rem = + match (item, rem) with + | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> ([tydecl1; tydecl2], rem) + | _ -> ([], rem) + +let dummy = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = []; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + +let hide_rec_items = function + | Sig_type (id, _decl, rs) :: rem + when rs = Trec_first && not !Clflags.real_paths -> + let rec get_ids = function + | Sig_type (id, _, Trec_next) :: rem -> id :: get_ids rem + | _ -> [] + in + let ids = id :: get_ids rem in + set_printing_env + (List.fold_right + (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) + ids !printing_env) + | _ -> () + +let rec tree_of_modtype ?(ellipsis = false) = function + | Mty_ident p -> Omty_ident (tree_of_path p) + | Mty_signature sg -> + Omty_signature (if ellipsis then [Osig_ellipsis] else tree_of_signature sg) + | Mty_functor (param, ty_arg, ty_res) -> + let res = + match ty_arg with + | None -> tree_of_modtype ~ellipsis ty_res + | Some mty -> + wrap_env + (Env.add_module ~arg:true param mty) + (tree_of_modtype ~ellipsis) + ty_res + in + Omty_functor + (Ident.name param, may_map (tree_of_modtype ~ellipsis:false) ty_arg, res) + | Mty_alias (_, p) -> Omty_alias (tree_of_path p) + +and tree_of_signature sg = + wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg + +and tree_of_signature_rec env' in_type_group = function + | [] -> [] + | item :: rem as items -> + let in_type_group = + match (in_type_group, item) with + | true, Sig_type (_, _, Trec_next) -> true + | _, Sig_type (_, _, (Trec_not | Trec_first)) -> + set_printing_env env'; + true + | _ -> + set_printing_env env'; + false + in + let sg, rem = filter_rem_sig item rem in + hide_rec_items items; + let trees = trees_of_sigitem item in + let env' = Env.add_signature (item :: sg) env' in + trees @ tree_of_signature_rec env' in_type_group rem + +and trees_of_sigitem = function + | Sig_value (id, decl) -> [tree_of_value_description id decl] + | Sig_type (id, _, _) when is_row_name (Ident.name id) -> [] + | Sig_type (id, decl, rs) -> [tree_of_type_declaration id decl rs] + | Sig_typext (id, ext, es) -> [tree_of_extension_constructor id ext es] + | Sig_module (id, md, rs) -> + let ellipsis = + List.exists + (function + | {txt = "..."}, Parsetree.PStr [] -> true + | _ -> false) + md.md_attributes + in + [tree_of_module id md.md_type rs ~ellipsis] + | Sig_modtype (id, decl) -> [tree_of_modtype_declaration id decl] + | Sig_class () -> [] + | Sig_class_type () -> [] + +and tree_of_modtype_declaration id decl = + let mty = + match decl.mtd_type with + | None -> Omty_abstract + | Some mty -> tree_of_modtype mty + in + Osig_modtype (Ident.name id, mty) + +and tree_of_module id ?ellipsis mty rs = + Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) + +let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) +let modtype_declaration id ppf decl = + !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) + +(* For the toplevel: merge with tree_of_signature? *) + +(* Refresh weak variable map in the toplevel *) +let refresh_weak () = + let refresh t name (m, s) = + if is_non_gen true (repr t) then (TypeMap.add t name m, StringSet.add name s) + else (m, s) + in + let m, s = + TypeMap.fold refresh !weak_var_map (TypeMap.empty, StringSet.empty) + in + named_weak_vars := s; + weak_var_map := m + +let print_items showval env x = + refresh_weak (); + let rec print showval env = function + | [] -> [] + | item :: rem as items -> + let _sg, rem = filter_rem_sig item rem in + hide_rec_items items; + let trees = trees_of_sigitem item in + List.map (fun d -> (d, showval env item)) trees @ print showval env rem + in + print showval env x + +(* Print a signature body (used by -i when compiling a .ml) *) + +let print_signature ppf tree = + fprintf ppf "@[%a@]" !Oprint.out_signature tree + +let signature ppf sg = fprintf ppf "%a" print_signature (tree_of_signature sg) + +(* Print an unification error *) + +let same_path t t' = + let t = repr t and t' = repr t' in + t == t' + || + match (t.desc, t'.desc) with + | Tconstr (p, tl, _), Tconstr (p', tl', _) -> ( + let p1, s1 = best_type_path p and p2, s2 = best_type_path p' in + match (s1, s2) with + | Nth n1, Nth n2 when n1 = n2 -> true + | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> + let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in + List.length tl = List.length tl' && List.for_all2 same_type tl tl' + | _ -> false) + | _ -> false + +let type_expansion t ppf t' = + if same_path t t' then ( + add_delayed (proxy t); + type_expr ppf t) + else + let t' = if proxy t == proxy t' then unalias t' else t' in + fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t' + +let type_path_expansion tp ppf tp' = + if Path.same tp tp' then path ppf tp + else fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp' + +let rec trace fst txt ppf = function + | (t1, t1') :: (t2, t2') :: rem -> + if not fst then fprintf ppf "@,"; + fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a" (type_expansion t1) t1' txt + (type_expansion t2) t2' (trace false txt) rem + | _ -> () + +let rec filter_trace keep_last = function + | [(_, t1'); (_, t2')] when is_Tvar t1' || is_Tvar t2' -> [] + | (t1, t1') :: (t2, t2') :: rem -> + let rem' = filter_trace keep_last rem in + if + is_constr_row ~allow_ident:true t1' + || is_constr_row ~allow_ident:true t2' + || (same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = [])) + then rem' + else (t1, t1') :: (t2, t2') :: rem' + | _ -> [] + +let rec type_path_list ppf = function + | [(tp, tp')] -> type_path_expansion tp ppf tp' + | (tp, tp') :: rem -> + fprintf ppf "%a@;<2 0>%a" (type_path_expansion tp) tp' type_path_list rem + | [] -> () + +(* Hide variant name and var, to force printing the expanded type *) +let hide_variant_name t = + match repr t with + | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> + newty2 t.level + (Tvariant + { + (row_repr row) with + row_name = None; + row_more = newvar2 (row_more row).level; + }) + | _ -> t + +let prepare_expansion (t, t') = + let t' = hide_variant_name t' in + mark_loops t; + if not (same_path t t') then mark_loops t'; + (t, t') + +let may_prepare_expansion compact (t, t') = + match (repr t').desc with + | (Tvariant _ | Tobject _) when compact -> + mark_loops t; + (t, t) + | _ -> prepare_expansion (t, t') + +let print_tags ppf fields = + match fields with + | [] -> () + | (t, _) :: fields -> + fprintf ppf "%s" (!print_res_poly_identifier t); + List.iter + (fun (t, _) -> fprintf ppf ",@ %s" (!print_res_poly_identifier t)) + fields + +let has_explanation t3 t4 = + match (t3.desc, t4.desc) with + | Tfield _, (Tnil | Tconstr _) + | (Tnil | Tconstr _), Tfield _ + | Tnil, Tconstr _ + | Tconstr _, Tnil + | _, Tvar _ + | Tvar _, _ + | Tvariant _, Tvariant _ -> + true + | Tfield (l, _, _, {desc = Tnil}), Tfield (l', _, _, {desc = Tnil}) -> l = l' + | _ -> false + +let rec mismatch = function + | (_, t) :: (_, t') :: rem -> ( + match mismatch rem with + | Some _ as m -> m + | None -> if has_explanation t t' then Some (t, t') else None) + | [] -> None + | _ -> assert false + +let explanation unif t3 t4 ppf = + match (t3.desc, t4.desc) with + | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> + fprintf ppf "@,Self type cannot escape its class" + | Tconstr (p, _, _), Tvar _ when unif && t4.level < Path.binding_time p -> + fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p + | Tvar _, Tconstr (p, _, _) when unif && t3.level < Path.binding_time p -> + fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p + | Tvar _, Tunivar _ | Tunivar _, Tvar _ -> + fprintf ppf "@,The universal variable %a would escape its scope" type_expr + (if is_Tunivar t3 then t3 else t4) + | Tvar _, _ | _, Tvar _ -> + let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in + if occur_in Env.empty t t' then + fprintf ppf "@,@[The type variable %a occurs inside@ %a@]" type_expr + t type_expr t' + else + fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]" type_expr + t' "it would escape the scope of its equation" + | Tfield (lab, _, _, _), _ when lab = dummy_method -> + fprintf ppf "@,Self type cannot be unified with a closed object type" + | _, Tfield (lab, _, _, _) when lab = dummy_method -> + fprintf ppf "@,Self type cannot be unified with a closed object type" + | Tfield (l, _, f1, {desc = Tnil}), Tfield (l', _, f2, {desc = Tnil}) + when l = l' -> + fprintf ppf + "@,\ + @,\ + Types for field @{\"%s\"@} are incompatible:@,\ + Field @{\"%s\"@} in the passed object has type @{%a@}, but \ + is expected to have type @{%a@}." + l l type_expr f1 type_expr f2 + | (Tnil | Tconstr _), Tfield (l, _, f1, _) -> + fprintf ppf + "@,\ + @,\ + @[The first object is expected to have a field @{\"%s\"@} of type \ + @{%a@}, but it does not.@]" + l type_expr f1 + | Tfield (l, _, f1, _), (Tnil | Tconstr _) -> + fprintf ppf + "@,\ + @,\ + @[The second object is expected to have a field @{\"%s\"@} of \ + type @{%a@}, but it does not.@]" + l type_expr f1 + | Tnil, Tconstr _ | Tconstr _, Tnil -> + fprintf ppf + "@,@[The %s object type has an abstract row, it cannot be closed@]" + (if t4.desc = Tnil then "first" else "second") + | Tvariant row1, Tvariant row2 -> ( + let row1 = row_repr row1 and row2 = row_repr row2 in + match + (row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed) + with + | [], true, [], true -> + fprintf ppf + "@,\ + @,\ + These polymorphic variants are incompatible - they share no common \ + constructors." + | [], true, (_ :: _ as fields), _ -> + (* TODO(ai) Future opportunity to provide a way for an LLM to lookup the + full polyvariant type definitions if wanted.*) + let constructors_txt = + if List.length fields = 1 then "constructor" else "constructors" + in + fprintf ppf + "@,\ + @,\ + The first polymorphic variant is @{closed@} and doesn't include \ + the %s: @{%a@}.@,\ + @,\ + Possible solutions:\n\ + \ - Either make the first variant @{open@} so it can accept \ + additional constructors. To do this, make sure the type starts with \ + @{[>@} instead of @{[@}\n\ + \ - Or add the missing %s to it." + constructors_txt print_tags fields constructors_txt + | (_ :: _ as fields), _, [], true -> + let constructors_txt = + if List.length fields = 1 then "constructor" else "constructors" + in + fprintf ppf + "@,\ + @,\ + The second polymorphic variant is @{closed@} and doesn't \ + include the %s: @{%a@}.@,\ + @,\ + Possible solutions:\n\ + \ - Either make the second variant @{open@} so it can accept \ + additional constructors. To do this, make sure the type starts with \ + @{[>@} instead of @{[@}\n\ + \ - Or add the missing %s to it." + constructors_txt print_tags fields constructors_txt + | [(l1, _)], true, [(l2, _)], true when l1 = l2 -> + fprintf ppf + "@,\ + @,\ + Both polymorphic variants have the constructor @{%s@}, but \ + their payload types are incompatible.@,\ + Make sure the payload types for @{%s@} match exactly in both \ + polymorphic variants." + (!print_res_poly_identifier l1) + (!print_res_poly_identifier l1) + | _ -> ()) + | _ -> () + +let warn_on_missing_def env ppf t = + match t.desc with + | Tconstr (p, _, _) -> ( + try ignore (Env.find_type p env : Types.type_declaration) + with Not_found -> + fprintf ppf + "@,\ + @[%a is abstract because no corresponding cmi file was found in \ + path.@]" + path p) + | _ -> () + +let explanation unif mis ppf = + match mis with + | None -> () + | Some (t3, t4) -> explanation unif t3 t4 ppf + +let ident_same_name id1 id2 = + if Ident.equal id1 id2 && not (Ident.same id1 id2) then ( + add_unique id1; + add_unique id2) + +let rec path_same_name p1 p2 = + match (p1, p2) with + | Pident id1, Pident id2 -> ident_same_name id1 id2 + | Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2 + | Papply (p1, p1'), Papply (p2, p2') -> + path_same_name p1 p2; + path_same_name p1' p2' + | _ -> () + +let type_same_name t1 t2 = + match ((repr t1).desc, (repr t2).desc) with + | Tconstr (p1, _, _), Tconstr (p2, _, _) -> + path_same_name (fst (best_type_path p1)) (fst (best_type_path p2)) + | _ -> () + +let rec trace_same_names = function + | (t1, t1') :: (t2, t2') :: rem -> + type_same_name t1 t2; + type_same_name t1' t2'; + trace_same_names rem + | _ -> () + +let unification_error env unif tr txt1 ppf txt2 = + reset (); + trace_same_names tr; + let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in + let mis = mismatch tr in + match tr with + | [] | _ :: [] -> assert false + | t1 :: t2 :: tr -> ( + try + let tr = filter_trace (mis = None) tr in + let t1, t1' = may_prepare_expansion (tr = []) t1 + and t2, t2' = may_prepare_expansion (tr = []) t2 in + let tr = List.map prepare_expansion tr in + fprintf ppf "@[@[%t@;<1 2>%a@ %t@;<1 2>%a@]%a%t@]" txt1 + (type_expansion t1) t1' txt2 (type_expansion t2) t2' + (trace false "is not compatible with type") + tr (explanation unif mis); + if env <> Env.empty then ( + warn_on_missing_def env ppf t1; + warn_on_missing_def env ppf t2) + with exn -> raise exn) + +let report_unification_error ppf env ?(unif = true) tr txt1 txt2 = + wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2) + +let super_type_expansion ~tag t ppf t' = + let tag = Format.String_tag tag in + if same_path t t' then ( + Format.pp_open_stag ppf tag; + type_expr ppf t; + Format.pp_close_stag ppf ()) + else + let t' = if proxy t == proxy t' then unalias t' else t' in + fprintf ppf "@[<2>"; + Format.pp_open_stag ppf tag; + fprintf ppf "%a" type_expr t; + Format.pp_close_stag ppf (); + fprintf ppf "@ @{(defined as@}@ "; + Format.pp_open_stag ppf tag; + fprintf ppf "%a" type_expr t'; + Format.pp_close_stag ppf (); + fprintf ppf "@{)@}"; + fprintf ppf "@]" + +let super_trace ppf = + let rec super_trace first_report ppf = function + | (t1, t1') :: (t2, t2') :: rem -> + fprintf ppf "@,@,@["; + if first_report then fprintf ppf "The incompatible parts:@," + else fprintf ppf "Further expanded:@,"; + fprintf ppf "@[%a@ vs@ %a@]%a" + (super_type_expansion ~tag:"error" t1) + t1' + (super_type_expansion ~tag:"info" t2) + t2' (super_trace false) rem; + fprintf ppf "@]" + | _ -> () + in + super_trace true ppf + +let super_unification_error ?print_extra_info unif tr txt1 ppf txt2 = + reset (); + trace_same_names tr; + let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in + let mis = mismatch tr in + match tr with + | [] | _ :: [] -> assert false + | t1 :: t2 :: tr -> ( + try + let tr = filter_trace (mis = None) tr in + let t1, t1' = may_prepare_expansion (tr = []) t1 + and t2, t2' = may_prepare_expansion (tr = []) t2 in + let tr = List.map prepare_expansion tr in + fprintf ppf "@[@[%t@ %a@]@,@[%t@ %a@]%a%t%t@]" txt1 + (super_type_expansion ~tag:"error" t1) t1' txt2 + (super_type_expansion ~tag:"info" t2) + t2' super_trace tr (explanation unif mis) (fun ppf -> + match print_extra_info with + | None -> () + | Some f -> f ppf t1 t2) + with exn -> raise exn) + +let super_report_unification_error ?print_extra_info ppf env ?(unif = true) tr + txt1 txt2 = + wrap_printing_env env (fun () -> + super_unification_error ?print_extra_info unif tr txt1 ppf txt2) + +let trace fst keep_last txt ppf tr = + trace_same_names tr; + try + match tr with + | t1 :: t2 :: tr' -> + if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr') + else trace fst txt ppf (filter_trace keep_last tr) + | _ -> () + with exn -> raise exn + +let print_variant_runtime_representation_issue ppf variant_name + (issue : Variant_coercion.variant_runtime_representation_issue) = + match issue with + | Cannot_coerce_non_unboxed_with_payload {constructor_name; expected_typename} + -> + fprintf ppf + "The constructor @{%s@} of variant @{%s@} has a payload, but \ + the variant itself is not unboxed. @ This means that the constructor \ + @{%s@} will be encoded as an object at runtime, which is not \ + compatible with @{%s@}." + constructor_name (Path.name variant_name) constructor_name + (Path.name expected_typename) + | Inline_record_cannot_be_coerced {constructor_name} -> + fprintf ppf + "The constructor @{%s@} of variant @{%s@} has an inline \ + record as payload. Currently, inline records cannot be coerced." + constructor_name (Path.name variant_name) + | As_payload_not_elgible_for_coercion + {constructor_name; as_payload; expected_typename} -> + fprintf ppf + "The constructor @{%s@} of variant @{%s@} has an \ + @{@as@} payload that has a runtime representation of \ + @{%s@}, which is not compatible with the expected @{%s@}." + constructor_name (Path.name variant_name) + (Ast_untagged_variants.tag_type_to_user_visible_string as_payload) + (Path.name expected_typename) + | Mismatched_unboxed_payload _ -> () + | Mismatched_as_payload {constructor_name; expected_typename; as_payload} -> + fprintf ppf "The constructor @{%s@} of variant @{%s@} has " + constructor_name (Path.name variant_name); + (match as_payload with + | None -> + fprintf ppf + "no @{@as@} payload, which makes it a @{string@} at \ + runtime." + | Some payload -> + fprintf ppf + "an @{@as@} payload that gives it the runtime type of \ + @{%s@}." + (Ast_untagged_variants.tag_type_to_user_visible_string payload)); + fprintf ppf + "@ That runtime representation is not compatible with the expected \ + runtime representation of @{%s@}." + (Path.name expected_typename); + fprintf ppf + "@,\ + @ Fix this by making sure all constructors in variant @{%s@} has \ + a runtime representation of @{%s@}." + (Path.name variant_name) + (Path.name expected_typename) + +let print_variant_configuration_issue ppf + (issue : Variant_coercion.variant_configuration_issue) ~left_variant_name + ~right_variant_name = + match issue with + | Unboxed_config_not_matching {left_unboxed; right_unboxed} -> + fprintf ppf + "@ The variants have different @{@unboxed@} configurations."; + let print_unboxed_status ppf unboxed name = + fprintf ppf "@ - Variant @{%s@} is @{%s@}unboxed." + (Path.name name) + (if unboxed then "not " else "") + in + print_unboxed_status ppf left_unboxed left_variant_name; + print_unboxed_status ppf right_unboxed right_variant_name; + fprintf ppf + "@,\ + @ Fix this by making sure the variants either both have, or don't have, \ + the @{@unboxed@} attribute." + | Tag_name_not_matching {left_tag; right_tag} -> + fprintf ppf "@ The variants have different @{@tag@} configurations."; + let print_tag ppf tag variant_name = + match tag with + | Some tag -> + fprintf ppf "@ - @{%s@} has tag @{%s@}." + (Path.name variant_name) tag + | None -> + fprintf ppf "@ - @{%s@} has no explicit tag." + (Path.name variant_name) + in + print_tag ppf left_tag left_variant_name; + print_tag ppf right_tag right_variant_name; + fprintf ppf + "@,\ + @ Fix this by making sure the variants either have the exact same \ + @{@tag@} configuration, or no @{@tag@} at all." + | Incompatible_constructor_count {constructor_names} -> + let total_constructor_count = List.length constructor_names in + let constructor_names_to_print = + match constructor_names with + | a :: b :: c :: _ -> [a; b; c] + | names -> names + in + let not_printed_constructor_count = + total_constructor_count - List.length constructor_names_to_print + in + fprintf ppf + "@ @{%s@} has %i constructor%s that @{%s@} does not have: " + (Path.name left_variant_name) + total_constructor_count + (if total_constructor_count = 1 then "" else "s") + (Path.name right_variant_name); + + constructor_names_to_print + |> List.iteri (fun index name -> + if index = 0 then () else fprintf ppf ", "; + fprintf ppf "@{%s@}" name); + if not_printed_constructor_count > 0 then + fprintf ppf " (+%i more)" not_printed_constructor_count; + + fprintf ppf + "@ Therefore, it is not possible for @{%s@} to represent \ + @{%s@}." + (Path.name right_variant_name) + (Path.name left_variant_name) + +let print_record_field_subtype_violation ppf + (issue : Record_coercion.record_field_subtype_violation) ~left_record_name + ~right_record_name = + match issue with + | Optional_mismatch {label; left_optional; right_optional} -> ( + fprintf ppf "The field @{%s@} " label; + match (left_optional, right_optional) with + | true, false -> + fprintf ppf + "is optional in record @{%s@}, but is not optional in record \ + @{%s@}" + (Path.name left_record_name) + (Path.name right_record_name) + | false, true -> + fprintf ppf + "is not optional in record @{%s@}, but is optional in record \ + @{%s@}" + (Path.name left_record_name) + (Path.name right_record_name) + | _ -> failwith "Invalid optional mismatch") + | Field_runtime_name_mismatch {label; left_as; right_as} -> + fprintf ppf "Field @{%s@} runtime representation" label; + (match left_as with + | Some as_name -> + fprintf ppf + " is configured to be @{\"%s\"@} (via the @as attribute)" as_name + | None -> fprintf ppf " is @{\"%s\"@}" label); + fprintf ppf " in record @{%s@}, but in record @{%s@}" + (Path.name right_record_name) + (Path.name left_record_name); + (match right_as with + | Some as_name -> + fprintf ppf + " it is configured to be @{\"%s\"@} (via the @as attribute)." + as_name + | None -> fprintf ppf " it is @{\"%s\"@}." label); + fprintf ppf " Runtime representations must match." + | Field_missing {label} -> + fprintf ppf + "The field @{%s@} is missing in record @{%s@}, but present \ + in record @{%s@}" + label + (Path.name right_record_name) + (Path.name left_record_name) + +let report_subtyping_error ppf env tr1 txt1 tr2 ctx = + wrap_printing_env env (fun () -> + reset (); + let tr1 = List.map prepare_expansion tr1 + and tr2 = List.map prepare_expansion tr2 in + fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; + (if tr2 = [] then fprintf ppf "@]" + else + let mis = mismatch tr2 in + fprintf ppf "%a%t@]" + (trace false (mis = None) "is not compatible with type") + tr2 (explanation true mis)); + match ctx with + | Some ctx -> ( + fprintf ppf "@,@,@["; + match ctx with + | Generic {errorCode} -> fprintf ppf "Error: %s" errorCode + | Coercion_target_variant_not_unboxed {variant_name; primitive} -> + fprintf ppf + "@ The variant @{%s@} is not unboxed, so it cannot be \ + coerced to a @{%s@}. @ Fix this by adding the \ + @{@unboxed@} attribute to the variant @{%s@}." + (Path.name variant_name) (Path.name primitive) + (Path.name variant_name) + | Coercion_target_variant_does_not_cover_type {variant_name; primitive} + -> + fprintf ppf + "@ The variant @{%s@} is unboxed, but has no catch-all case \ + for the primitive @{%s@}, and therefore does not cover all \ + values of type @{%s@}. @ Fix this by adding a catch-all for \ + @{%s@} to @{%s@}, like @{%s(%s)@}." + (Path.name variant_name) (Path.name primitive) (Path.name primitive) + (Path.name variant_name) (Path.name primitive) + (String.capitalize_ascii (Path.name primitive)) + (Path.name primitive) + | Variant_constructor_runtime_representation_mismatch + {variant_name; issues} -> + List.iter + (fun issue -> + fprintf ppf "@ "; + print_variant_runtime_representation_issue ppf variant_name issue) + issues + | Variant_configurations_mismatch + {left_variant_name; right_variant_name; issue} -> + print_variant_configuration_issue ppf issue ~left_variant_name + ~right_variant_name + | Different_type_kinds + {left_typename; right_typename; left_type_kind; right_type_kind} -> + let type_kind_to_string = function + | Type_abstract -> "an abstract type" + | Type_record _ -> "a record" + | Type_variant _ -> "a variant" + | Type_open -> "an open type" + in + fprintf ppf + "@ The types of @{%s@} and @{%s@} are different:" + (Path.name left_typename) (Path.name right_typename); + fprintf ppf "@ - @{%s@} is %s" (Path.name left_typename) + (type_kind_to_string left_type_kind); + fprintf ppf "@ - @{%s@} is %s" (Path.name right_typename) + (type_kind_to_string right_type_kind) + | Record_fields_mismatch {left_record_name; right_record_name; issues} + -> + fprintf ppf + "@ The record @{%s@} cannot be coerced to the record \ + @{%s@} because:" + (Path.name left_record_name) + (Path.name right_record_name); + List.iter + (fun issue -> + fprintf ppf "@ - "; + print_record_field_subtype_violation ppf issue ~left_record_name + ~right_record_name) + issues) + | None -> ()) + +let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = + wrap_printing_env env (fun () -> + reset (); + List.iter + (fun (tp, tp') -> + path_same_name tp0 tp; + path_same_name tp0' tp') + tpl; + match tpl with + | [] -> assert false + | [(tp, tp')] -> + fprintf ppf "@[%t@;<1 2>%a@ %t@;<1 2>%a@]" txt1 (type_path_expansion tp) + tp' txt3 (type_path_expansion tp0) tp0' + | _ -> + fprintf ppf "@[%t@;<1 2>@[%a@]@ %t@;<1 2>%a@]" txt2 type_path_list + tpl txt3 (type_path_expansion tp0) tp0') diff --git a/compiler/ml/printtyp.mli b/compiler/ml/printtyp.mli new file mode 100644 index 0000000..0fe84f3 --- /dev/null +++ b/compiler/ml/printtyp.mli @@ -0,0 +1,117 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Printing functions *) + +open Format +open Types +open Outcometree + +type printing_context = {inlined_types: type_inlined_type list} +(** Tracks things like inlined records, to help with printing. *) + +val print_res_poly_identifier : (string -> string) ref +val longident : formatter -> Longident.t -> unit +val ident : formatter -> Ident.t -> unit +val tree_of_path : Path.t -> out_ident +val path : formatter -> Path.t -> unit +val string_of_path : Path.t -> string +val raw_type_expr : formatter -> type_expr -> unit +val string_of_label : Asttypes.arg_label -> string + +val wrap_printing_env : Env.t -> (unit -> 'a) -> 'a +(* Call the function using the environment for type path shortening *) +(* This affects all the printing functions below *) + +val reset : unit -> unit +val mark_loops : type_expr -> unit +val reset_and_mark_loops : type_expr -> unit +val reset_and_mark_loops_list : type_expr list -> unit +val type_expr : formatter -> type_expr -> unit +val constructor_arguments : formatter -> constructor_arguments -> unit +val tree_of_type_scheme : type_expr -> out_type +val type_sch : formatter -> type_expr -> unit +val type_scheme : formatter -> type_expr -> unit + +(* Maxence *) +val reset_names : unit -> unit +val type_scheme_max : ?b_reset_names:bool -> formatter -> type_expr -> unit + +(* End Maxence *) +val tree_of_value_description : Ident.t -> value_description -> out_sig_item +val value_description : Ident.t -> formatter -> value_description -> unit +val tree_of_type_declaration : + Ident.t -> type_declaration -> rec_status -> out_sig_item +val type_declaration : Ident.t -> formatter -> type_declaration -> unit +val tree_of_extension_constructor : + Ident.t -> extension_constructor -> ext_status -> out_sig_item +val extension_constructor : + Ident.t -> formatter -> extension_constructor -> unit +val tree_of_module : + Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item +val modtype : formatter -> module_type -> unit +val signature : formatter -> signature -> unit +val tree_of_modtype_declaration : Ident.t -> modtype_declaration -> out_sig_item +val tree_of_signature : Types.signature -> out_sig_item list +val tree_of_typexp : + ?printing_context:printing_context -> bool -> type_expr -> out_type +val modtype_declaration : Ident.t -> formatter -> modtype_declaration -> unit +val type_expansion : type_expr -> Format.formatter -> type_expr -> unit +val prepare_expansion : type_expr * type_expr -> type_expr * type_expr +val trace : + bool -> bool -> string -> formatter -> (type_expr * type_expr) list -> unit +val report_unification_error : + formatter -> + Env.t -> + ?unif:bool -> + (type_expr * type_expr) list -> + (formatter -> unit) -> + (formatter -> unit) -> + unit + +val super_report_unification_error : + ?print_extra_info:(formatter -> type_expr -> type_expr -> unit) -> + formatter -> + Env.t -> + ?unif:bool -> + (type_expr * type_expr) list -> + (formatter -> unit) -> + (formatter -> unit) -> + unit + +val report_subtyping_error : + formatter -> + Env.t -> + Ctype.type_pairs -> + string -> + Ctype.type_pairs -> + Ctype.subtype_context option -> + unit +val report_ambiguous_type_error : + formatter -> + Env.t -> + Path.t * Path.t -> + (Path.t * Path.t) list -> + (formatter -> unit) -> + (formatter -> unit) -> + (formatter -> unit) -> + unit + +(* for toploop *) +val print_items : + (Env.t -> signature_item -> 'a option) -> + Env.t -> + signature_item list -> + (out_sig_item * 'a option) list diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml new file mode 100644 index 0000000..6e36b42 --- /dev/null +++ b/compiler/ml/printtyped.ml @@ -0,0 +1,675 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 1999 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Format +open Lexing +open Location +open Typedtree + +let fmt_position f l = + if l.pos_lnum = -1 then fprintf f "%s[%d]" l.pos_fname l.pos_cnum + else + fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol + (l.pos_cnum - l.pos_bol) + +let fmt_location f loc = + if !Clflags.dump_location then ( + fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; + if loc.loc_ghost then fprintf f " ghost") + +let rec fmt_longident_aux f x = + match x with + | Longident.Lident s -> fprintf f "%s" s + | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s + | Longident.Lapply (y, z) -> + fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z + +let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt + +let fmt_ident = Ident.print + +let rec fmt_path_aux f x = + match x with + | Path.Pident s -> fprintf f "%a" fmt_ident s + | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s + | Path.Papply (y, z) -> fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z + +let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x + +let fmt_constant f x = + match x with + | Const_int i -> fprintf f "Const_int %d" i + | Const_char c -> fprintf f "Const_char %02x" c + | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s + | Const_string (s, Some delim) -> + fprintf f "Const_string (%S,Some %S)" s delim + | Const_float s -> fprintf f "Const_float %s" s + | Const_int32 i -> fprintf f "Const_int32 %ld" i + | Const_int64 i -> fprintf f "Const_int64 %Ld" i + | Const_bigint (sign, i) -> + fprintf f "Const_bigint %s" (Bigint_utils.to_string sign i) + +let fmt_mutable_flag f x = + match x with + | Immutable -> fprintf f "Immutable" + | Mutable -> fprintf f "Mutable" + +let fmt_override_flag f x = + match x with + | Override -> fprintf f "Override" + | Fresh -> fprintf f "Fresh" + +let fmt_closed_flag f x = + match x with + | Closed -> fprintf f "Closed" + | Open -> fprintf f "Open" + +let fmt_rec_flag f x = + match x with + | Nonrecursive -> fprintf f "Nonrec" + | Recursive -> fprintf f "Rec" + +let fmt_direction_flag f x = + match x with + | Upto -> fprintf f "Up" + | Downto -> fprintf f "Down" + +let fmt_private_flag f x = + match x with + | Public -> fprintf f "Public" + | Private -> fprintf f "Private" + +let line i f s (*...*) = + fprintf f "%s" (String.make (2 * i) ' '); + fprintf f s (*...*) + +let list i f ppf l = + match l with + | [] -> line i ppf "[]\n" + | _ :: _ -> + line i ppf "[\n"; + List.iter (f (i + 1) ppf) l; + line i ppf "]\n" + +let array i f ppf a = + if Array.length a = 0 then line i ppf "[]\n" + else ( + line i ppf "[\n"; + Array.iter (f (i + 1) ppf) a; + line i ppf "]\n") + +let option i f ppf x = + match x with + | None -> line i ppf "None\n" + | Some x -> + line i ppf "Some\n"; + f (i + 1) ppf x + +let longident i ppf li = line i ppf "%a\n" fmt_longident li +let string i ppf s = line i ppf "\"%s\"\n" s +let arg_label i ppf = function + | Nolabel -> line i ppf "Nolabel\n" + | Optional {txt} -> line i ppf "Optional \"%s\"\n" txt + | Labelled {txt} -> line i ppf "Labelled \"%s\"\n" txt + +let record_representation i ppf = + let open Types in + function + | Record_regular -> line i ppf "Record_regular\n" + | Record_float_unused -> assert false + | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b + | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i + | Record_extension -> line i ppf "Record_extension\n" + +let attributes i ppf l = + let i = i + 1 in + List.iter + (fun (s, arg) -> + line i ppf "attribute \"%s\"\n" s.txt; + Printast.payload (i + 1) ppf arg) + l + +let rec core_type i ppf x = + line i ppf "core_type %a\n" fmt_location x.ctyp_loc; + attributes i ppf x.ctyp_attributes; + let i = i + 1 in + match x.ctyp_desc with + | Ttyp_any -> line i ppf "Ttyp_any\n" + | Ttyp_var s -> line i ppf "Ttyp_var %s\n" s + | Ttyp_arrow (arg, ret, _) -> + line i ppf "Ttyp_arrow\n"; + arg_label i ppf arg.lbl; + attributes i ppf arg.attrs; + core_type i ppf arg.typ; + core_type i ppf ret + | Ttyp_tuple l -> + line i ppf "Ttyp_tuple\n"; + list i core_type ppf l + | Ttyp_constr (li, _, l) -> + line i ppf "Ttyp_constr %a\n" fmt_path li; + list i core_type ppf l + | Ttyp_variant (l, closed, low) -> + line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed; + list i label_x_bool_x_core_type_list ppf l; + option i (fun i -> list i string) ppf low + | Ttyp_object (l, c) -> + line i ppf "Ttyp_object %a\n" fmt_closed_flag c; + let i = i + 1 in + List.iter + (function + | OTtag (s, attrs, t) -> + line i ppf "method %s\n" s.txt; + attributes i ppf attrs; + core_type (i + 1) ppf t + | OTinherit ct -> + line i ppf "OTinherit\n"; + core_type (i + 1) ppf ct) + l + | Ttyp_alias (ct, s) -> + line i ppf "Ttyp_alias \"%s\"\n" s; + core_type i ppf ct + | Ttyp_poly (sl, ct) -> + line i ppf "Ttyp_poly%a\n" + (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) + sl; + core_type i ppf ct + | Ttyp_package {pack_path = s; pack_fields = l} -> + line i ppf "Ttyp_package %a\n" fmt_path s; + list i package_with ppf l + +and package_with i ppf (s, t) = + line i ppf "with type %a\n" fmt_longident s; + core_type i ppf t + +and pattern i ppf x = + line i ppf "pattern %a\n" fmt_location x.pat_loc; + attributes i ppf x.pat_attributes; + let i = i + 1 in + match x.pat_extra with + | (Tpat_unpack, _, attrs) :: rem -> + line i ppf "Tpat_unpack\n"; + attributes i ppf attrs; + pattern i ppf {x with pat_extra = rem} + | (Tpat_constraint cty, _, attrs) :: rem -> + line i ppf "Tpat_constraint\n"; + attributes i ppf attrs; + core_type i ppf cty; + pattern i ppf {x with pat_extra = rem} + | (Tpat_type (id, _), _, attrs) :: rem -> + line i ppf "Tpat_type %a\n" fmt_path id; + attributes i ppf attrs; + pattern i ppf {x with pat_extra = rem} + | (Tpat_open (id, _, _), _, attrs) :: rem -> + line i ppf "Tpat_open \"%a\"\n" fmt_path id; + attributes i ppf attrs; + pattern i ppf {x with pat_extra = rem} + | [] -> ( + match x.pat_desc with + | Tpat_any -> line i ppf "Tpat_any\n" + | Tpat_var (s, _) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s + | Tpat_alias (p, s, _) -> + line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; + pattern i ppf p + | Tpat_constant c -> line i ppf "Tpat_constant %a\n" fmt_constant c + | Tpat_tuple l -> + line i ppf "Tpat_tuple\n"; + list i pattern ppf l + | Tpat_construct (li, _, po) -> + line i ppf "Tpat_construct %a\n" fmt_longident li; + list i pattern ppf po + | Tpat_variant (l, po, _) -> + line i ppf "Tpat_variant \"%s\"\n" l; + option i pattern ppf po + | Tpat_record (l, _c) -> + line i ppf "Tpat_record\n"; + list i longident_x_pattern ppf l + | Tpat_array l -> + line i ppf "Tpat_array\n"; + list i pattern ppf l + | Tpat_or (p1, p2, _) -> + line i ppf "Tpat_or\n"; + pattern i ppf p1; + pattern i ppf p2) + +and expression_extra i ppf x attrs = + match x with + | Texp_constraint ct -> + line i ppf "Texp_constraint\n"; + attributes i ppf attrs; + core_type i ppf ct + | Texp_coerce cto2 -> + line i ppf "Texp_coerce\n"; + attributes i ppf attrs; + core_type i ppf cto2 + | Texp_open (ovf, m, _, _) -> + line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + attributes i ppf attrs + | Texp_newtype s -> + line i ppf "Texp_newtype \"%s\"\n" s; + attributes i ppf attrs + +and expression i ppf x = + line i ppf "expression %a\n" fmt_location x.exp_loc; + attributes i ppf x.exp_attributes; + let i = + List.fold_left + (fun i (extra, _, attrs) -> + expression_extra i ppf extra attrs; + i + 1) + (i + 1) x.exp_extra + in + match x.exp_desc with + | Texp_ident (li, _, _) -> line i ppf "Texp_ident %a\n" fmt_path li + | Texp_constant c -> line i ppf "Texp_constant %a\n" fmt_constant c + | Texp_let (rf, l, e) -> + line i ppf "Texp_let %a\n" fmt_rec_flag rf; + list i value_binding ppf l; + expression i ppf e + | Texp_function + {arg_label = p; arity; async; param; case = case_; partial = _} -> + line i ppf "Texp_function\n"; + if async then line i ppf "async\n"; + (match arity with + | Some arity -> line i ppf "arity: %d\n" arity + | None -> ()); + line i ppf "%a" Ident.print param; + arg_label i ppf p; + case i ppf case_ + | Texp_apply {funct = e; args = l; partial} -> + if partial then line i ppf "partial\n"; + line i ppf "Texp_apply\n"; + expression i ppf e; + list i label_x_expression ppf l + | Texp_match (e, l1, l2, _partial) -> + line i ppf "Texp_match\n"; + expression i ppf e; + list i case ppf l1; + list i case ppf l2 + | Texp_try (e, l) -> + line i ppf "Texp_try\n"; + expression i ppf e; + list i case ppf l + | Texp_tuple l -> + line i ppf "Texp_tuple\n"; + list i expression ppf l + | Texp_construct (li, _, eo) -> + line i ppf "Texp_construct %a\n" fmt_longident li; + list i expression ppf eo + | Texp_variant (l, eo) -> + line i ppf "Texp_variant \"%s\"\n" l; + option i expression ppf eo + | Texp_record {fields; representation; extended_expression} -> + line i ppf "Texp_record\n"; + let i = i + 1 in + line i ppf "fields =\n"; + array (i + 1) record_field ppf fields; + line i ppf "representation =\n"; + record_representation (i + 1) ppf representation; + line i ppf "extended_expression =\n"; + option (i + 1) expression ppf extended_expression + | Texp_field (e, li, _) -> + line i ppf "Texp_field\n"; + expression i ppf e; + longident i ppf li + | Texp_setfield (e1, li, _, e2) -> + line i ppf "Texp_setfield\n"; + expression i ppf e1; + longident i ppf li; + expression i ppf e2 + | Texp_array l -> + line i ppf "Texp_array\n"; + list i expression ppf l + | Texp_ifthenelse (e1, e2, eo) -> + line i ppf "Texp_ifthenelse\n"; + expression i ppf e1; + expression i ppf e2; + option i expression ppf eo + | Texp_sequence (e1, e2) -> + line i ppf "Texp_sequence\n"; + expression i ppf e1; + expression i ppf e2 + | Texp_while (e1, e2) -> + line i ppf "Texp_while\n"; + expression i ppf e1; + expression i ppf e2 + | Texp_for (s, _, e1, e2, df, e3) -> + line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; + expression i ppf e1; + expression i ppf e2; + expression i ppf e3 + | Texp_send (e, Tmeth_name s, eo) -> + line i ppf "Texp_send \"%s\"\n" s; + expression i ppf e; + option i expression ppf eo + | Texp_letmodule (s, _, me, e) -> + line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s; + module_expr i ppf me; + expression i ppf e + | Texp_letexception (cd, e) -> + line i ppf "Texp_letexception\n"; + extension_constructor i ppf cd; + expression i ppf e + | Texp_assert e -> + line i ppf "Texp_assert"; + expression i ppf e + | Texp_pack me -> + line i ppf "Texp_pack"; + module_expr i ppf me + | Texp_extension_constructor (li, _) -> + line i ppf "Texp_extension_constructor %a" fmt_longident li + +and value_description i ppf x = + line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location + x.val_loc; + attributes i ppf x.val_attributes; + core_type (i + 1) ppf x.val_desc; + list (i + 1) string ppf x.val_prim + +and type_parameter i ppf (x, _variance) = core_type i ppf x + +and type_declaration i ppf x = + line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location + x.typ_loc; + attributes i ppf x.typ_attributes; + let i = i + 1 in + line i ppf "ptype_params =\n"; + list (i + 1) type_parameter ppf x.typ_params; + line i ppf "ptype_cstrs =\n"; + list (i + 1) core_type_x_core_type_x_location ppf x.typ_cstrs; + line i ppf "ptype_kind =\n"; + type_kind (i + 1) ppf x.typ_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; + line i ppf "ptype_manifest =\n"; + option (i + 1) core_type ppf x.typ_manifest + +and type_kind i ppf x = + match x with + | Ttype_abstract -> line i ppf "Ttype_abstract\n" + | Ttype_variant l -> + line i ppf "Ttype_variant\n"; + list (i + 1) constructor_decl ppf l + | Ttype_record l -> + line i ppf "Ttype_record\n"; + list (i + 1) label_decl ppf l + | Ttype_open -> line i ppf "Ttype_open\n" + +and type_extension i ppf x = + line i ppf "type_extension\n"; + attributes i ppf x.tyext_attributes; + let i = i + 1 in + line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path; + line i ppf "ptyext_params =\n"; + list (i + 1) type_parameter ppf x.tyext_params; + line i ppf "ptyext_constructors =\n"; + list (i + 1) extension_constructor ppf x.tyext_constructors; + line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private + +and extension_constructor i ppf x = + line i ppf "extension_constructor %a\n" fmt_location x.ext_loc; + attributes i ppf x.ext_attributes; + let i = i + 1 in + line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id; + line i ppf "pext_kind =\n"; + extension_constructor_kind (i + 1) ppf x.ext_kind + +and extension_constructor_kind i ppf x = + match x with + | Text_decl (a, r) -> + line i ppf "Text_decl\n"; + constructor_arguments (i + 1) ppf a; + option (i + 1) core_type ppf r + | Text_rebind (p, _) -> + line i ppf "Text_rebind\n"; + line (i + 1) ppf "%a\n" fmt_path p + +and module_type i ppf x = + line i ppf "module_type %a\n" fmt_location x.mty_loc; + attributes i ppf x.mty_attributes; + let i = i + 1 in + match x.mty_desc with + | Tmty_ident (li, _) -> line i ppf "Tmty_ident %a\n" fmt_path li + | Tmty_alias (li, _) -> line i ppf "Tmty_alias %a\n" fmt_path li + | Tmty_signature s -> + line i ppf "Tmty_signature\n"; + signature i ppf s + | Tmty_functor (s, _, mt1, mt2) -> + line i ppf "Tmty_functor \"%a\"\n" fmt_ident s; + Misc.may (module_type i ppf) mt1; + module_type i ppf mt2 + | Tmty_with (mt, l) -> + line i ppf "Tmty_with\n"; + module_type i ppf mt; + list i longident_x_with_constraint ppf l + | Tmty_typeof m -> + line i ppf "Tmty_typeof\n"; + module_expr i ppf m + +and signature i ppf x = list i signature_item ppf x.sig_items + +and signature_item i ppf x = + line i ppf "signature_item %a\n" fmt_location x.sig_loc; + let i = i + 1 in + match x.sig_desc with + | Tsig_value vd -> + line i ppf "Tsig_value\n"; + value_description i ppf vd + | Tsig_type (rf, l) -> + line i ppf "Tsig_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l + | Tsig_typext e -> + line i ppf "Tsig_typext\n"; + type_extension i ppf e + | Tsig_exception ext -> + line i ppf "Tsig_exception\n"; + extension_constructor i ppf ext + | Tsig_module md -> + line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id; + attributes i ppf md.md_attributes; + module_type i ppf md.md_type + | Tsig_recmodule decls -> + line i ppf "Tsig_recmodule\n"; + list i module_declaration ppf decls + | Tsig_modtype x -> + line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tsig_open od -> + line i ppf "Tsig_open %a %a\n" fmt_override_flag od.open_override fmt_path + od.open_path; + attributes i ppf od.open_attributes + | Tsig_include incl -> + line i ppf "Tsig_include\n"; + attributes i ppf incl.incl_attributes; + module_type i ppf incl.incl_mod + | Tsig_attribute (s, arg) -> + line i ppf "Tsig_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg + +and module_declaration i ppf md = + line i ppf "%a" fmt_ident md.md_id; + attributes i ppf md.md_attributes; + module_type (i + 1) ppf md.md_type + +and module_binding i ppf x = + line i ppf "%a\n" fmt_ident x.mb_id; + attributes i ppf x.mb_attributes; + module_expr (i + 1) ppf x.mb_expr + +and modtype_declaration i ppf = function + | None -> line i ppf "#abstract" + | Some mt -> module_type (i + 1) ppf mt + +and with_constraint i ppf x = + match x with + | Twith_type td -> + line i ppf "Twith_type\n"; + type_declaration (i + 1) ppf td + | Twith_typesubst td -> + line i ppf "Twith_typesubst\n"; + type_declaration (i + 1) ppf td + | Twith_module (li, _) -> line i ppf "Twith_module %a\n" fmt_path li + | Twith_modsubst (li, _) -> line i ppf "Twith_modsubst %a\n" fmt_path li + +and module_expr i ppf x = + line i ppf "module_expr %a\n" fmt_location x.mod_loc; + attributes i ppf x.mod_attributes; + let i = i + 1 in + match x.mod_desc with + | Tmod_ident (li, _) -> line i ppf "Tmod_ident %a\n" fmt_path li + | Tmod_structure s -> + line i ppf "Tmod_structure\n"; + structure i ppf s + | Tmod_functor (s, _, mt, me) -> + line i ppf "Tmod_functor \"%a\"\n" fmt_ident s; + Misc.may (module_type i ppf) mt; + module_expr i ppf me + | Tmod_apply (me1, me2, _) -> + line i ppf "Tmod_apply\n"; + module_expr i ppf me1; + module_expr i ppf me2 + | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> + line i ppf "Tmod_constraint\n"; + module_expr i ppf me; + module_type i ppf mt + | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me + | Tmod_unpack (e, _) -> + line i ppf "Tmod_unpack\n"; + expression i ppf e + +and structure i ppf x = list i structure_item ppf x.str_items + +and structure_item i ppf x = + line i ppf "structure_item %a\n" fmt_location x.str_loc; + let i = i + 1 in + match x.str_desc with + | Tstr_eval (e, attrs) -> + line i ppf "Tstr_eval\n"; + attributes i ppf attrs; + expression i ppf e + | Tstr_value (rf, l) -> + line i ppf "Tstr_value %a\n" fmt_rec_flag rf; + list i value_binding ppf l + | Tstr_primitive vd -> + line i ppf "Tstr_primitive\n"; + value_description i ppf vd + | Tstr_type (rf, l) -> + line i ppf "Tstr_type %a\n" fmt_rec_flag rf; + list i type_declaration ppf l + | Tstr_typext te -> + line i ppf "Tstr_typext\n"; + type_extension i ppf te + | Tstr_exception ext -> + line i ppf "Tstr_exception\n"; + extension_constructor i ppf ext + | Tstr_module x -> + line i ppf "Tstr_module\n"; + module_binding i ppf x + | Tstr_recmodule bindings -> + line i ppf "Tstr_recmodule\n"; + list i module_binding ppf bindings + | Tstr_modtype x -> + line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type + | Tstr_open od -> + line i ppf "Tstr_open %a %a\n" fmt_override_flag od.open_override fmt_path + od.open_path; + attributes i ppf od.open_attributes + | Tstr_include incl -> + line i ppf "Tstr_include"; + attributes i ppf incl.incl_attributes; + module_expr i ppf incl.incl_mod + | Tstr_attribute (s, arg) -> + line i ppf "Tstr_attribute \"%s\"\n" s.txt; + Printast.payload i ppf arg + +and longident_x_with_constraint i ppf (li, _, wc) = + line i ppf "%a\n" fmt_path li; + with_constraint (i + 1) ppf wc + +and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = + line i ppf " %a\n" fmt_location l; + core_type (i + 1) ppf ct1; + core_type (i + 1) ppf ct2 + +and constructor_decl i ppf + {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attributes} = + line i ppf "%a\n" fmt_location cd_loc; + line (i + 1) ppf "%a\n" fmt_ident cd_id; + attributes i ppf cd_attributes; + constructor_arguments (i + 1) ppf cd_args; + option (i + 1) core_type ppf cd_res + +and constructor_arguments i ppf = function + | Cstr_tuple l -> list i core_type ppf l + | Cstr_record l -> list i label_decl ppf l + +and label_decl i ppf + {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} = + line i ppf "%a\n" fmt_location ld_loc; + attributes i ppf ld_attributes; + line (i + 1) ppf "%a\n" fmt_mutable_flag ld_mutable; + line (i + 1) ppf "%a" fmt_ident ld_id; + core_type (i + 1) ppf ld_type + +and longident_x_pattern i ppf (li, _, p, opt) = + line i ppf "%a%s\n" fmt_longident li (if opt then "?" else ""); + pattern (i + 1) ppf p + +and case i ppf {c_lhs; c_guard; c_rhs} = + line i ppf "\n"; + pattern (i + 1) ppf c_lhs; + (match c_guard with + | None -> () + | Some g -> + line (i + 1) ppf "\n"; + expression (i + 2) ppf g); + expression (i + 1) ppf c_rhs + +and value_binding i ppf x = + line i ppf "\n"; + attributes (i + 1) ppf x.vb_attributes; + pattern (i + 1) ppf x.vb_pat; + expression (i + 1) ppf x.vb_expr + +and record_field i ppf = function + | _, Overridden (li, e), opt -> + line i ppf "%a%s\n" fmt_longident li (if opt then "?" else ""); + expression (i + 1) ppf e + | _, Kept _, _ -> line i ppf "" + +and label_x_expression i ppf (l, e) = + line i ppf "\n"; + arg_label (i + 1) ppf l; + match e with + | None -> () + | Some e -> expression (i + 1) ppf e + +and label_x_bool_x_core_type_list i ppf x = + match x with + | Ttag (l, attrs, b, ctl) -> + line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b); + attributes (i + 1) ppf attrs; + list (i + 1) core_type ppf ctl + | Tinherit ct -> + line i ppf "Tinherit\n"; + core_type (i + 1) ppf ct + +let interface ppf x = list 0 signature_item ppf x.sig_items + +let implementation ppf x = list 0 structure_item ppf x.str_items + +let implementation_with_coercion ppf (x, _) = implementation ppf x diff --git a/jscomp/ml/printtyped.mli b/compiler/ml/printtyped.mli similarity index 85% rename from jscomp/ml/printtyped.mli rename to compiler/ml/printtyped.mli index ded42bb..11837f1 100644 --- a/jscomp/ml/printtyped.mli +++ b/compiler/ml/printtyped.mli @@ -13,11 +13,11 @@ (* *) (**************************************************************************) -open Typedtree;; -open Format;; +open Typedtree +open Format -val interface : formatter -> signature -> unit;; -val implementation : formatter -> structure -> unit;; +val interface : formatter -> signature -> unit +val implementation : formatter -> structure -> unit val implementation_with_coercion : - formatter -> (structure * module_coercion) -> unit;; + formatter -> structure * module_coercion -> unit diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml new file mode 100644 index 0000000..3d016a7 --- /dev/null +++ b/compiler/ml/rec_check.ml @@ -0,0 +1,464 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +type error = Illegal_letrec_expr + +exception Error of Location.t * error + +module Rec_context = struct + type access = + | Dereferenced + (** [Dereferenced] indicates that the value (not just the address) of a + variable is accessed *) + | Guarded + (** [Guarded] indicates that the address of a variable is used in a + guarded context, i.e. under a constructor. A variable that is + dereferenced within a function body or lazy context is also considered + guarded. *) + | Unguarded + (** [Unguarded] indicates that the address of a variable is used in an + unguarded context, i.e. not under a constructor. *) + + (** [guard] represents guarded contexts such as [C -] and [{l = -}] *) + let guard : access -> access = function + | Dereferenced -> Dereferenced + | Guarded -> Guarded + | Unguarded -> Guarded + + (** [inspect] represents elimination contexts such as [match - with cases], + [e -] and [- e] *) + let inspect : access -> access = function + | Dereferenced -> Dereferenced + | Guarded -> Dereferenced + | Unguarded -> Dereferenced + + (** [delay] represents contexts that delay evaluation such as [fun p -> -] + or [lazy -] *) + let delay : access -> access = function + | Dereferenced -> Guarded + | Guarded -> Guarded + | Unguarded -> Guarded + + module Use : sig + type t + + val guard : t -> t + (** An expression appears in a guarded context *) + + val discard : t -> t + (** The address of a subexpression is not used, but may be bound *) + + val inspect : t -> t + (** The value of a subexpression is inspected with match, application, etc. *) + + val delay : t -> t + (** An expression appears under 'fun p ->' or 'lazy' *) + + val join : t -> t -> t + (** Combine the access information of two expressions *) + + val single : Ident.t -> access -> t + (** Combine the access information of two expressions *) + + val empty : t + (** No variables are accessed in an expression; it might be a + constant or a global identifier *) + + val unguarded : t -> Ident.t list + (** The list of identifiers that are used in an unguarded context *) + + val dependent : t -> Ident.t list + (** The list of all used identifiers *) + end = struct + module M = Map.Make (Ident) + + type t = access M.t + (** A "t" maps each rec-bound variable to an access status *) + + let map f tbl = M.map f tbl + + let guard t = map guard t + + let inspect t = map inspect t + + let delay t = map delay t + + let discard = guard + + let prec x y = + match (x, y) with + | Dereferenced, _ | _, Dereferenced -> Dereferenced + | Unguarded, _ | _, Unguarded -> Unguarded + | _ -> Guarded + + let join x y = + M.fold + (fun id v tbl -> + let v' = try M.find id tbl with Not_found -> Guarded in + M.add id (prec v v') tbl) + x y + + let single id access = M.add id access M.empty + + let empty = M.empty + + let list_matching p t = + let r = ref [] in + M.iter (fun id v -> if p v then r := id :: !r) t; + !r + + let unguarded = + list_matching (function + | Unguarded | Dereferenced -> true + | _ -> false) + + let dependent = list_matching (function _ -> true) + end + + module Env = struct + (* A typing environment maps identifiers to types *) + type env = Use.t Ident.tbl + + let empty = Ident.empty + + let join x y = + let r = + Ident.fold_all + (fun id v tbl -> + let v' = try Ident.find_same id tbl with Not_found -> Use.empty in + Ident.add id (Use.join v v') tbl) + x y + in + r + end +end + +let rec pattern_variables : Typedtree.pattern -> Ident.t list = + fun pat -> + match pat.pat_desc with + | Tpat_any -> [] + | Tpat_var (id, _) -> [id] + | Tpat_alias (pat, id, _) -> id :: pattern_variables pat + | Tpat_constant _ -> [] + | Tpat_tuple pats -> List.concat (List.map pattern_variables pats) + | Tpat_construct (_, _, pats) -> List.concat (List.map pattern_variables pats) + | Tpat_variant (_, Some pat, _) -> pattern_variables pat + | Tpat_variant (_, None, _) -> [] + | Tpat_record (fields, _) -> + List.concat (List.map (fun (_, _, p, _) -> pattern_variables p) fields) + | Tpat_array pats -> List.concat (List.map pattern_variables pats) + | Tpat_or (l, r, _) -> pattern_variables l @ pattern_variables r + +open Rec_context +open Asttypes +open Typedtree + +let build_unguarded_env : Ident.t list -> Env.env = + fun idlist -> + List.fold_left + (fun env id -> Ident.add id (Use.single id Unguarded) env) + Env.empty idlist + +let is_ref : Types.value_description -> bool = function + | { + Types.val_kind = + Types.Val_prim {Primitive.prim_name = "%makeref"; prim_arity = 1}; + } -> + true + | _ -> false + +type sd = Static | Dynamic + +let value_default f ~default a = + match a with + | None -> default + | Some a -> f a + +let rec classify_expression : Typedtree.expression -> sd = + fun exp -> + match exp.exp_desc with + | Texp_let (_, _, e) + | Texp_letmodule (_, _, _, e) + | Texp_sequence (_, e) + | Texp_letexception (_, e) -> + classify_expression e + | Texp_ident _ | Texp_for _ | Texp_constant _ | Texp_tuple _ | Texp_array _ + | Texp_construct _ | Texp_variant _ | Texp_record _ | Texp_setfield _ + | Texp_while _ | Texp_pack _ | Texp_function _ | Texp_extension_constructor _ + -> + Static + | Texp_apply {funct = {exp_desc = Texp_ident (_, _, vd)}} when is_ref vd -> + Static + | Texp_apply _ | Texp_match _ | Texp_ifthenelse _ | Texp_send _ | Texp_field _ + | Texp_assert _ | Texp_try _ -> + Dynamic + +let rec expression : Env.env -> Typedtree.expression -> Use.t = + fun env exp -> + match exp.exp_desc with + | Texp_ident (pth, _, _) -> path env pth + | Texp_let (rec_flag, bindings, body) -> + let env', ty = value_bindings rec_flag env bindings in + (* Here and in other binding constructs 'discard' is used in a + similar way to the way it's used in sequence: uses are + propagated, but unguarded access are not. *) + Use.join (Use.discard ty) (expression (Env.join env env') body) + | Texp_letmodule (x, _, m, e) -> + let ty = modexp env m in + Use.join (Use.discard ty) (expression (Ident.add x ty env) e) + | Texp_match (e, val_cases, exn_cases, _) -> + let t = expression env e in + let exn_case env {Typedtree.c_rhs} = expression env c_rhs in + let cs = list (case ~scrutinee:t) env val_cases + and es = list exn_case env exn_cases in + Use.(join cs es) + | Texp_for (_, _, e1, e2, _, e3) -> + Use.( + join + (join (inspect (expression env e1)) (inspect (expression env e2))) + (* The body is evaluated, but not used, and not available + for inclusion in another value *) + (discard (expression env e3))) + | Texp_constant _ -> Use.empty + | Texp_apply + {funct = {exp_desc = Texp_ident (_, _, vd)}; args = [(_, Some arg)]} + when is_ref vd -> + Use.guard (expression env arg) + | Texp_apply {funct = e; args} -> + let arg env (_, eo) = option expression env eo in + Use.(join (inspect (expression env e)) (inspect (list arg env args))) + | Texp_tuple exprs -> Use.guard (list expression env exprs) + | Texp_array exprs -> Use.guard (list expression env exprs) + | Texp_construct (_, desc, exprs) -> + let access_constructor = + match desc.cstr_tag with + | Cstr_extension pth -> Use.inspect (path env pth) + | _ -> Use.empty + in + let use = + match desc.cstr_tag with + | Cstr_unboxed -> fun x -> x + | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> Use.guard + in + Use.join access_constructor (use (list expression env exprs)) + | Texp_variant (_, eo) -> Use.guard (option expression env eo) + | Texp_record {fields = es; extended_expression = eo; representation = rep} -> + let use = + match rep with + | Record_unboxed _ -> fun x -> x + | Record_float_unused -> assert false + | Record_regular | Record_inlined _ | Record_extension -> Use.guard + in + let field env = function + | _, Kept _, _ -> Use.empty + | _, Overridden (_, e), _ -> expression env e + in + Use.join (use (array field env es)) (option expression env eo) + | Texp_ifthenelse (cond, ifso, ifnot) -> + Use.( + join + (inspect (expression env cond)) + (join (expression env ifso) (option expression env ifnot))) + | Texp_setfield (e1, _, _, e2) -> + Use.(join (inspect (expression env e1)) (inspect (expression env e2))) + | Texp_sequence (e1, e2) -> + Use.(join (discard (expression env e1)) (expression env e2)) + | Texp_while (e1, e2) -> + Use.(join (inspect (expression env e1)) (discard (expression env e2))) + | Texp_send (e1, _, eo) -> + Use.( + join (inspect (expression env e1)) (inspect (option expression env eo))) + | Texp_field (e, _, _) -> Use.(inspect (expression env e)) + | Texp_letexception (_, e) -> expression env e + | Texp_assert e -> Use.inspect (expression env e) + | Texp_pack m -> modexp env m + | Texp_try (e, cases) -> + (* This is more permissive than the old check. *) + let case env {Typedtree.c_rhs} = expression env c_rhs in + Use.join (expression env e) (list case env cases) + | Texp_function {case = case_} -> + Use.delay (list (case ~scrutinee:Use.empty) env [case_]) + | Texp_extension_constructor _ -> Use.empty + +and option : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a option -> Use.t = + fun f env -> value_default (f env) ~default:Use.empty + +and list : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a list -> Use.t = + fun f env -> + List.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty + +and array : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a array -> Use.t = + fun f env -> + Array.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty + +and modexp : Env.env -> Typedtree.module_expr -> Use.t = + fun env m -> + match m.mod_desc with + | Tmod_ident (pth, _) -> path env pth + | Tmod_structure s -> structure env s + | Tmod_functor (_, _, _, e) -> Use.delay (modexp env e) + | Tmod_apply (f, p, _) -> + Use.(join (inspect (modexp env f)) (inspect (modexp env p))) + | Tmod_constraint (m, _, _, Tcoerce_none) -> modexp env m + | Tmod_constraint (m, _, _, _) -> Use.inspect (modexp env m) + | Tmod_unpack (e, _) -> expression env e + +and path : Env.env -> Path.t -> Use.t = + fun env pth -> + match pth with + | Path.Pident x -> ( try Ident.find_same x env with Not_found -> Use.empty) + | Path.Pdot (t, _, _) -> Use.inspect (path env t) + | Path.Papply (f, p) -> Use.(inspect (join (path env f) (path env p))) + +and structure : Env.env -> Typedtree.structure -> Use.t = + fun env s -> + let _, ty = + List.fold_left + (fun (env, ty) item -> + let env', ty' = structure_item env item in + (Env.join env env', Use.join ty ty')) + (env, Use.empty) s.str_items + in + Use.guard ty + +and structure_item : Env.env -> Typedtree.structure_item -> Env.env * Use.t = + fun env s -> + match s.str_desc with + | Tstr_eval (e, _) -> (Env.empty, expression env e) + | Tstr_value (rec_flag, valbinds) -> value_bindings rec_flag env valbinds + | Tstr_module {mb_id; mb_expr} -> + let ty = modexp env mb_expr in + (Ident.add mb_id ty Env.empty, ty) + | Tstr_recmodule mbs -> + let modbind env {mb_expr} = modexp env mb_expr in + (* Over-approximate: treat any access as a use *) + (Env.empty, Use.inspect (list modbind env mbs)) + | Tstr_primitive _ -> (Env.empty, Use.empty) + | Tstr_type _ -> (Env.empty, Use.empty) + | Tstr_typext _ -> (Env.empty, Use.empty) + | Tstr_exception _ -> (Env.empty, Use.empty) + | Tstr_modtype _ -> (Env.empty, Use.empty) + | Tstr_open _ -> (Env.empty, Use.empty) + | Tstr_include inc -> + (* This is a kind of projection. There's no need to add + anything to the environment because everything is used in + the type component already *) + (Env.empty, Use.inspect (modexp env inc.incl_mod)) + | Tstr_attribute _ -> (Env.empty, Use.empty) + +and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t = + fun env {Typedtree.c_lhs; c_guard; c_rhs} ~scrutinee:ty -> + let ty = + if is_destructuring_pattern c_lhs then Use.inspect ty else Use.discard ty + (* as in 'let' *) + in + let vars = pattern_variables c_lhs in + let env = List.fold_left (fun env id -> Ident.add id ty env) env vars in + Use.( + join ty + (join (expression env c_rhs) (inspect (option expression env c_guard)))) + +and value_bindings : + rec_flag -> Env.env -> Typedtree.value_binding list -> Env.env * Use.t = + fun rec_flag env bindings -> + match rec_flag with + | Recursive -> + (* Approximation: + let rec y = + let rec x1 = e1 + and x2 = e2 + in e + treated as + let rec y = + let rec x = (e1, e2)[x1:=fst x, x2:=snd x] in + e[x1:=fst x, x2:=snd x] + Further, use the fact that x1,x2 cannot occur unguarded in e1, e2 + to avoid recursive trickiness. + *) + let ids, ty = + List.fold_left + (fun (pats, tys) {vb_pat = p; vb_expr = e} -> + (pattern_variables p @ pats, Use.join (expression env e) tys)) + ([], Use.empty) bindings + in + ( List.fold_left + (fun (env : Env.env) (id : Ident.t) -> Ident.add id ty env) + Env.empty ids, + ty ) + | Nonrecursive -> + List.fold_left + (fun (env2, ty) binding -> + let env', ty' = value_binding env binding in + (Env.join env2 env', Use.join ty ty')) + (Env.empty, Use.empty) bindings + +and value_binding : Env.env -> Typedtree.value_binding -> Env.env * Use.t = + (* NB: returns new environment only *) + fun env {vb_pat; vb_expr} -> + let vars = pattern_variables vb_pat in + let ty = expression env vb_expr in + let ty = if is_destructuring_pattern vb_pat then Use.inspect ty else ty in + (List.fold_left (fun env id -> Ident.add id ty env) Env.empty vars, ty) + +and is_destructuring_pattern : Typedtree.pattern -> bool = + fun pat -> + match pat.pat_desc with + | Tpat_any -> false + | Tpat_var (_, _) -> false + | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat + | Tpat_constant _ -> true + | Tpat_tuple _ -> true + | Tpat_construct (_, _, _) -> true + | Tpat_variant _ -> true + | Tpat_record (_, _) -> true + | Tpat_array _ -> true + | Tpat_or (l, r, _) -> + is_destructuring_pattern l || is_destructuring_pattern r + +let check_recursive_expression idlist expr = + let ty = expression (build_unguarded_env idlist) expr in + match (Use.unguarded ty, Use.dependent ty, classify_expression expr) with + | _ :: _, _, _ (* The expression inspects rec-bound variables *) + | _, _ :: _, Dynamic -> + (* The expression depends on rec-bound variables + and its size is unknown *) + raise (Error (expr.exp_loc, Illegal_letrec_expr)) + | [], _, Static (* The expression has known size *) | [], [], Dynamic -> + (* The expression has unknown size, + but does not depend on rec-bound variables *) + () + +let check_recursive_bindings valbinds = + let ids = + List.concat (List.map (fun b -> pattern_variables b.vb_pat) valbinds) + in + Ext_list.iter valbinds (fun {vb_expr} -> + match vb_expr.exp_desc with + | Texp_record + {fields = [|(_, Overridden (_, {exp_desc = Texp_function _}), _)|]} + | Texp_function _ -> + () + (*TODO: add uncurried function too*) + | _ -> check_recursive_expression ids vb_expr) + +let report_error ppf = function + | Illegal_letrec_expr -> + Format.fprintf ppf + "This kind of expression is not allowed as right-hand side of `let rec'" + +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) diff --git a/compiler/ml/rec_check.mli b/compiler/ml/rec_check.mli new file mode 100644 index 0000000..28469fa --- /dev/null +++ b/compiler/ml/rec_check.mli @@ -0,0 +1 @@ +val check_recursive_bindings : Typedtree.value_binding list -> unit diff --git a/compiler/ml/record_coercion.ml b/compiler/ml/record_coercion.ml new file mode 100644 index 0000000..1c14225 --- /dev/null +++ b/compiler/ml/record_coercion.ml @@ -0,0 +1,60 @@ +type record_field_subtype_violation = + | Optional_mismatch of { + label: string; + left_optional: bool; + right_optional: bool; + } + | Field_runtime_name_mismatch of { + label: string; + left_as: string option; + right_as: string option; + } + | Field_missing of {label: string} + +let check_record_fields (fields1 : Types.label_declaration list) + (fields2 : Types.label_declaration list) = + let violations = ref [] in + let add_violation v = violations := v :: !violations in + let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) = + match + Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name) + with + | Some ld1 -> + if ld1.ld_optional <> ld2.ld_optional then + (* optional field can't be modified *) + add_violation + (Optional_mismatch + { + label = ld1.ld_id.name; + left_optional = ld1.ld_optional; + right_optional = ld2.ld_optional; + }); + let get_as (({txt}, payload) : Parsetree.attribute) = + if txt = "as" then Ast_payload.is_single_string payload else None + in + let get_as_name (ld : Types.label_declaration) = + match Ext_list.filter_map ld.ld_attributes get_as with + | [] -> None + | (s, _) :: _ -> Some s + in + let get_label_runtime_name (ld : Types.label_declaration) = + match get_as_name ld with + | None -> ld.ld_id.name + | Some s -> s + in + if get_label_runtime_name ld1 <> get_label_runtime_name ld2 then + add_violation + (Field_runtime_name_mismatch + { + label = ld1.ld_id.name; + left_as = get_as_name ld1; + right_as = get_as_name ld2; + }); + (ld1.ld_type :: acc1, ld2.ld_type :: acc2) + | None -> + (* field must be present *) + add_violation (Field_missing {label = ld2.ld_id.name}); + (acc1, acc2) + in + let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in + (!violations, tl1, tl2) diff --git a/compiler/ml/record_type_spread.ml b/compiler/ml/record_type_spread.ml new file mode 100644 index 0000000..bf7b286 --- /dev/null +++ b/compiler/ml/record_type_spread.ml @@ -0,0 +1,140 @@ +module StringMap = Map.Make (String) + +let t_equals t1 t2 = t1.Types.level = t2.Types.level && t1.id = t2.id + +let substitute_types ~type_map (t : Types.type_expr) = + if StringMap.is_empty type_map then t + else + let apply_substitution type_variable_name t = + match StringMap.find_opt type_variable_name type_map with + | None -> t + | Some substituted_type -> substituted_type + in + let rec loop (t : Types.type_expr) = + match t.desc with + | Tlink t -> {t with desc = Tlink (loop t)} + | Tvar (Some type_variable_name) -> + apply_substitution type_variable_name t + | Tvar None -> t + | Tunivar _ -> t + | Tconstr (path, args, _memo) -> + {t with desc = Tconstr (path, args |> List.map loop, ref Types.Mnil)} + | Tsubst t -> {t with desc = Tsubst (loop t)} + | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} + | Tnil -> t + | Tarrow (arg, ret, c, arity) -> + { + t with + desc = Tarrow ({arg with typ = loop arg.typ}, loop ret, c, arity); + } + | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} + | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} + | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} + | Tpoly (t, []) -> loop t + | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} + | Tpackage (p, l, tl) -> + {t with desc = Tpackage (p, l, tl |> List.map loop)} + and row_desc (rd : Types.row_desc) = + let row_fields = + rd.row_fields |> List.map (fun (l, rf) -> (l, row_field rf)) + in + let row_more = loop rd.row_more in + let row_name = + match rd.row_name with + | None -> None + | Some (p, tl) -> Some (p, tl |> List.map loop) + in + {rd with row_fields; row_more; row_name} + and row_field (rf : Types.row_field) = + match rf with + | Rpresent None -> rf + | Rpresent (Some t) -> Rpresent (Some (loop t)) + | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r) + | Rabsent -> Rabsent + in + loop t + +let substitute_type_vars (type_vars : (string * Types.type_expr) list) + (typ : Types.type_expr) = + let type_map = + type_vars + |> List.fold_left + (fun acc (tvar_name, tvar_typ) -> StringMap.add tvar_name tvar_typ acc) + StringMap.empty + in + substitute_types ~type_map typ + +let has_type_spread (lbls : Typedtree.label_declaration list) = + lbls + |> List.exists (fun (l : Typedtree.label_declaration) -> + match l with + | {ld_name = {txt = "..."}} -> true + | _ -> false) + +let extract_type_vars (type_params : Types.type_expr list) + (typ : Types.type_expr) = + (* The type variables applied to the record spread itself. *) + let applied_type_vars = + match Ctype.repr typ with + | {desc = Tpoly ({desc = Tconstr (_, tvars, _)}, _)} -> tvars + | _ -> [] + in + if List.length type_params = List.length applied_type_vars then + (* Track which type param in the record we're spreading + belongs to which type variable applied to the spread itself. *) + let paired_type_vars = List.combine type_params applied_type_vars in + paired_type_vars + |> List.filter_map (fun (t, applied_tvar) -> + match t.Types.desc with + | Tvar (Some tname) -> Some (tname, applied_tvar) + | _ -> None) + else [] + +let expand_labels_with_type_spreads (env : Env.t) + (lbls : Typedtree.label_declaration list) + (lbls' : Types.label_declaration list) = + match has_type_spread lbls with + | false -> Some (lbls, lbls') + | true -> + let rec extract (t : Types.type_expr) = + match t.desc with + | Tpoly (t, []) -> extract t + | _ -> Ctype.repr t + in + let mk_lbl (l : Types.label_declaration) (ld_type : Typedtree.core_type) + (type_vars : (string * Types.type_expr) list) : + Typedtree.label_declaration = + { + ld_id = l.ld_id; + ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; + ld_mutable = l.ld_mutable; + ld_optional = l.ld_optional; + ld_type = + {ld_type with ctyp_type = substitute_type_vars type_vars l.ld_type}; + ld_loc = l.ld_loc; + ld_attributes = l.ld_attributes; + } + in + let rec process_lbls acc (lbls : Typedtree.label_declaration list) + (lbls' : Types.label_declaration list) = + match (lbls, lbls') with + | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> ( + match + Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) + with + | _p0, _p, {type_kind = Type_record (fields, _repr); type_params} -> + let type_vars = extract_type_vars type_params ld_type.ctyp_type in + process_lbls + ( fst acc @ Ext_list.map fields (fun l -> mk_lbl l ld_type type_vars), + snd acc + @ Ext_list.map fields (fun l -> + {l with ld_type = substitute_type_vars type_vars l.ld_type}) + ) + rest rest' + | _ -> None + | exception _ -> None) + | lbl :: rest, lbl' :: rest' -> + process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' + | _ -> Some acc + in + process_lbls ([], []) lbls lbls' diff --git a/compiler/ml/stypes.ml b/compiler/ml/stypes.ml new file mode 100644 index 0000000..0584b16 --- /dev/null +++ b/compiler/ml/stypes.ml @@ -0,0 +1,188 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2003 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. *) +(* *) +(**************************************************************************) + +(* Recording and dumping (partial) type information *) + +(* + We record all types in a list as they are created. + This means we can dump type information even if type inference fails, + which is extremely important, since type information is most + interesting in case of errors. +*) + +open Annot +open Lexing +open Location +open Typedtree + +let output_int oc i = output_string oc (string_of_int i) + +type annotation = + | Ti_pat of pattern + | Ti_expr of expression + | Ti_class of unit + | Ti_mod of module_expr + | An_call of Location.t * Annot.call + | An_ident of Location.t * string * Annot.ident + +let get_location ti = + match ti with + | Ti_pat p -> p.pat_loc + | Ti_expr e -> e.exp_loc + | Ti_class () -> assert false + | Ti_mod m -> m.mod_loc + | An_call (l, _k) -> l + | An_ident (l, _s, _k) -> l + +let annotations = ref ([] : annotation list) +let phrases = ref ([] : Location.t list) + +let record ti = + if !Clflags.annotations && not (get_location ti).Location.loc_ghost then + annotations := ti :: !annotations + +let record_phrase loc = if !Clflags.annotations then phrases := loc :: !phrases + +(* comparison order: + the intervals are sorted by order of increasing upper bound + same upper bound -> sorted by decreasing lower bound +*) +let cmp_loc_inner_first loc1 loc2 = + match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with + | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum + | x -> x +let cmp_ti_inner_first ti1 ti2 = + cmp_loc_inner_first (get_location ti1) (get_location ti2) + +let print_position pp pos = + if pos = dummy_pos then output_string pp "--" + else ( + output_char pp '\"'; + output_string pp (String.escaped pos.pos_fname); + output_string pp "\" "; + output_int pp pos.pos_lnum; + output_char pp ' '; + output_int pp pos.pos_bol; + output_char pp ' '; + output_int pp pos.pos_cnum) + +let print_location pp loc = + print_position pp loc.loc_start; + output_char pp ' '; + print_position pp loc.loc_end + +let sort_filter_phrases () = + let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in + let rec loop accu cur l = + match l with + | [] -> accu + | loc :: t -> + if + cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum + && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum + then loop accu cur t + else loop (loc :: accu) loc t + in + phrases := loop [] Location.none ph + +let rec printtyp_reset_maybe loc = + match !phrases with + | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> + Printtyp.reset (); + phrases := t; + printtyp_reset_maybe loc + | _ -> () + +let call_kind_string k = + match k with + | Tail -> "tail" + | Stack -> "stack" + | Inline -> "inline" + +let print_ident_annot pp str k = + match k with + | Idef l -> + output_string pp "def "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' + | Iref_internal l -> + output_string pp "int_ref "; + output_string pp str; + output_char pp ' '; + print_location pp l; + output_char pp '\n' + | Iref_external -> + output_string pp "ext_ref "; + output_string pp str; + output_char pp '\n' + +(* The format of the annotation file is documented in emacs/caml-types.el. *) + +let print_info pp prev_loc ti = + match ti with + | Ti_class _ | Ti_mod _ -> prev_loc + | Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env} + | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} -> + if loc <> prev_loc then ( + print_location pp loc; + output_char pp '\n'); + output_string pp "type(\n"; + printtyp_reset_maybe loc; + Printtyp.mark_loops typ; + Format.pp_print_string Format.str_formatter " "; + Printtyp.wrap_printing_env env (fun () -> + Printtyp.type_sch Format.str_formatter typ); + Format.pp_print_newline Format.str_formatter (); + let s = Format.flush_str_formatter () in + output_string pp s; + output_string pp ")\n"; + loc + | An_call (loc, k) -> + if loc <> prev_loc then ( + print_location pp loc; + output_char pp '\n'); + output_string pp "call(\n "; + output_string pp (call_kind_string k); + output_string pp "\n)\n"; + loc + | An_ident (loc, str, k) -> + if loc <> prev_loc then ( + print_location pp loc; + output_char pp '\n'); + output_string pp "ident(\n "; + print_ident_annot pp str k; + output_string pp ")\n"; + loc + +let get_info () = + let info = List.fast_sort cmp_ti_inner_first !annotations in + annotations := []; + info + +let dump filename = + if !Clflags.annotations then ( + let do_dump _temp_filename pp = + let info = get_info () in + sort_filter_phrases (); + ignore (List.fold_left (print_info pp) Location.none info) + in + (match filename with + | None -> do_dump "" stdout + | Some filename -> + Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump); + phrases := []) + else annotations := [] diff --git a/jscomp/ml/stypes.mli b/compiler/ml/stypes.mli similarity index 81% rename from jscomp/ml/stypes.mli rename to compiler/ml/stypes.mli index 770956c..3182f7e 100644 --- a/jscomp/ml/stypes.mli +++ b/compiler/ml/stypes.mli @@ -17,20 +17,19 @@ (* Clflags.save_types must be true *) -open Typedtree;; +open Typedtree type annotation = - | Ti_pat of pattern - | Ti_expr of expression + | Ti_pat of pattern + | Ti_expr of expression | Ti_class of unit - | Ti_mod of module_expr + | Ti_mod of module_expr | An_call of Location.t * Annot.call | An_ident of Location.t * string * Annot.ident -;; -val record : annotation -> unit;; -val record_phrase : Location.t -> unit;; -val dump : string option -> unit;; +val record : annotation -> unit +val record_phrase : Location.t -> unit +val dump : string option -> unit -val get_location : annotation -> Location.t;; -val get_info : unit -> annotation list;; +val get_location : annotation -> Location.t +val get_info : unit -> annotation list diff --git a/compiler/ml/subst.ml b/compiler/ml/subst.ml new file mode 100644 index 0000000..b30d32c --- /dev/null +++ b/compiler/ml/subst.ml @@ -0,0 +1,392 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Substitutions *) + +open Misc +open Path +open Types +open Btype + +type type_replacement = + | Path of Path.t + | Type_function of {params: type_expr list; body: type_expr} + +module PathMap = Map.Make (Path) + +type t = { + types: type_replacement PathMap.t; + modules: Path.t PathMap.t; + modtypes: (Ident.t, module_type) Tbl.t; + for_saving: bool; +} + +let identity = + { + types = PathMap.empty; + modules = PathMap.empty; + modtypes = Tbl.empty; + for_saving = false; + } + +let add_type_path id p s = {s with types = PathMap.add id (Path p) s.types} +let add_type id p s = add_type_path (Pident id) p s + +let add_type_function id ~params ~body s = + {s with types = PathMap.add id (Type_function {params; body}) s.types} + +let add_module_path id p s = {s with modules = PathMap.add id p s.modules} +let add_module id p s = add_module_path (Pident id) p s + +let add_modtype id ty s = {s with modtypes = Tbl.add id ty s.modtypes} + +let for_saving s = {s with for_saving = true} + +let loc s x = + if s.for_saving && not !Clflags.keep_locs then Location.none else x + +let remove_loc = + let open Ast_mapper in + {default_mapper with location = (fun _this _loc -> Location.none)} + +let attrs s x = + if s.for_saving && not !Clflags.keep_locs then + remove_loc.Ast_mapper.attributes remove_loc x + else x + +let rec module_path s path = + try PathMap.find path s.modules + with Not_found -> ( + match path with + | Pident _ -> path + | Pdot (p, n, pos) -> Pdot (module_path s p, n, pos) + | Papply (p1, p2) -> Papply (module_path s p1, module_path s p2)) + +let modtype_path s = function + | Pident id as p -> ( + try + match Tbl.find id s.modtypes with + | Mty_ident p -> p + | _ -> fatal_error "Subst.modtype_path" + with Not_found -> p) + | Pdot (p, n, pos) -> Pdot (module_path s p, n, pos) + | Papply _ -> fatal_error "Subst.modtype_path" + +let type_path s path = + match PathMap.find path s.types with + | Path p -> p + | Type_function _ -> assert false + | exception Not_found -> ( + match path with + | Pident _ -> path + | Pdot (p, n, pos) -> Pdot (module_path s p, n, pos) + | Papply _ -> fatal_error "Subst.type_path") + +let type_path s p = + match Path.constructor_typath p with + | Regular p -> type_path s p + | Cstr (ty_path, cstr) -> Pdot (type_path s ty_path, cstr, nopos) + | LocalExt _ -> type_path s p + | Ext (p, cstr) -> Pdot (module_path s p, cstr, nopos) + +let to_subst_by_type_function s p = + match PathMap.find p s.types with + | Path _ -> false + | Type_function _ -> true + | exception Not_found -> false + +(* Special type ids for saved signatures *) + +let new_id = ref (-1) +let reset_for_saving () = new_id := -1 + +let newpersty desc = + decr new_id; + {desc; level = generic_level; id = !new_id} + +(* ensure that all occurrences of 'Tvar None' are physically shared *) +let tvar_none = Tvar None +let tunivar_none = Tunivar None +let norm = function + | Tvar None -> tvar_none + | Tunivar None -> tunivar_none + | d -> d + +let ctype_apply_env_empty = ref (fun _ -> assert false) + +(* Similar to [Ctype.nondep_type_rec]. *) +let rec typexp s ty = + let ty = repr ty in + match ty.desc with + | (Tvar _ | Tunivar _) as desc -> + if s.for_saving || ty.id < 0 then ( + let ty' = + if s.for_saving then newpersty (norm desc) else newty2 ty.level desc + in + save_desc ty desc; + ty.desc <- Tsubst ty'; + ty') + else ty + | Tsubst ty -> ty + | Tfield (m, k, _t1, _t2) + when (not s.for_saving) && m = dummy_method + && field_kind_repr k <> Fabsent + && (repr ty).level < generic_level -> + (* do not copy the type of self when it is not generalized *) + ty + (* cannot do it, since it would omit substitution + | Tvariant row when not (static_row row) -> + ty + *) + | _ -> + let desc = ty.desc in + save_desc ty desc; + let tm = row_of_type ty in + let has_fixed_row = + (not (is_Tconstr ty)) && is_constr_row ~allow_ident:false tm + in + (* Make a stub *) + let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in + ty.desc <- Tsubst ty'; + ty'.desc <- + (if has_fixed_row then + match tm.desc with + (* PR#7348 *) + | Tconstr (Pdot (m, i, pos), tl, _abbrev) -> + let i' = String.sub i 0 (String.length i - 4) in + Tconstr (type_path s (Pdot (m, i', pos)), tl, ref Mnil) + | _ -> assert false + else + match desc with + | Tconstr (p, args, _abbrev) -> ( + let args = List.map (typexp s) args in + match PathMap.find p s.types with + | exception Not_found -> Tconstr (type_path s p, args, ref Mnil) + | Path _ -> Tconstr (type_path s p, args, ref Mnil) + | Type_function {params; body} -> + (!ctype_apply_env_empty params body args).desc) + | Tpackage (p, n, tl) -> + Tpackage (modtype_path s p, n, List.map (typexp s) tl) + | Tobject (t1, name) -> + Tobject + ( typexp s t1, + ref + (match !name with + | None -> None + | Some (p, tl) -> + if to_subst_by_type_function s p then None + else Some (type_path s p, List.map (typexp s) tl)) ) + | Tvariant row -> ( + let row = row_repr row in + let more = repr row.row_more in + (* We must substitute in a subtle way *) + (* Tsubst takes a tuple containing the row var and the variant *) + match more.desc with + | Tsubst {desc = Ttuple [_; ty2]} -> + (* This variant type has been already copied *) + ty.desc <- Tsubst ty2; + (* avoid Tlink in the new type *) + Tlink ty2 + | _ -> ( + let dup = + s.for_saving || more.level = generic_level || static_row row + || + match more.desc with + | Tconstr _ -> true + | _ -> false + in + (* Various cases for the row variable *) + let more' = + match more.desc with + | Tsubst ty -> ty + | Tconstr _ | Tnil -> typexp s more + | Tunivar _ | Tvar _ -> + save_desc more more.desc; + if s.for_saving then newpersty (norm more.desc) + else if dup && is_Tvar more then newgenty more.desc + else more + | _ -> assert false + in + (* Register new type first for recursion *) + more.desc <- Tsubst (newgenty (Ttuple [more'; ty'])); + (* Return a new copy *) + let row = copy_row (typexp s) true row (not dup) more' in + match row.row_name with + | Some (p, tl) -> + Tvariant + { + row with + row_name = + (if to_subst_by_type_function s p then None + else Some (type_path s p, tl)); + } + | None -> Tvariant row)) + | Tfield (_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> + Tlink (typexp s t2) + | _ -> copy_type_desc (typexp s) desc); + ty' + +(* + Always make a copy of the type. If this is not done, type levels + might not be correct. +*) +let type_expr s ty = + let ty' = typexp s ty in + cleanup_types (); + ty' + +let label_declaration s l = + { + ld_id = l.ld_id; + ld_mutable = l.ld_mutable; + ld_optional = l.ld_optional; + ld_type = typexp s l.ld_type; + ld_loc = loc s l.ld_loc; + ld_attributes = attrs s l.ld_attributes; + } + +let constructor_arguments s = function + | Cstr_tuple l -> Cstr_tuple (List.map (typexp s) l) + | Cstr_record l -> Cstr_record (List.map (label_declaration s) l) + +let constructor_declaration s c = + { + cd_id = c.cd_id; + cd_args = constructor_arguments s c.cd_args; + cd_res = may_map (typexp s) c.cd_res; + cd_loc = loc s c.cd_loc; + cd_attributes = attrs s c.cd_attributes; + } + +let type_declaration s decl = + let decl = + { + type_params = List.map (typexp s) decl.type_params; + type_arity = decl.type_arity; + type_kind = + (match decl.type_kind with + | Type_abstract -> Type_abstract + | Type_variant cstrs -> + Type_variant (List.map (constructor_declaration s) cstrs) + | Type_record (lbls, rep) -> + Type_record (List.map (label_declaration s) lbls, rep) + | Type_open -> Type_open); + type_manifest = + (match decl.type_manifest with + | None -> None + | Some ty -> Some (typexp s ty)); + type_private = decl.type_private; + type_variance = decl.type_variance; + type_newtype_level = None; + type_loc = loc s decl.type_loc; + type_attributes = attrs s decl.type_attributes; + type_immediate = decl.type_immediate; + type_unboxed = decl.type_unboxed; + type_inlined_types = decl.type_inlined_types; + } + in + cleanup_types (); + decl + +let value_description s descr = + { + val_type = type_expr s descr.val_type; + val_kind = descr.val_kind; + val_loc = loc s descr.val_loc; + val_attributes = attrs s descr.val_attributes; + } + +let extension_constructor s ext = + let ext = + { + ext_type_path = type_path s ext.ext_type_path; + ext_type_params = List.map (typexp s) ext.ext_type_params; + ext_args = constructor_arguments s ext.ext_args; + ext_ret_type = may_map (typexp s) ext.ext_ret_type; + ext_private = ext.ext_private; + ext_attributes = attrs s ext.ext_attributes; + ext_loc = (if s.for_saving then Location.none else ext.ext_loc); + ext_is_exception = ext.ext_is_exception; + } + in + cleanup_types (); + ext + +let rec rename_bound_idents s idents = function + | [] -> (List.rev idents, s) + | Sig_type (id, _, _) :: sg -> + let id' = Ident.rename id in + rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg + | Sig_module (id, _, _) :: sg -> + let id' = Ident.rename id in + rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg + | Sig_modtype (id, _) :: sg -> + let id' = Ident.rename id in + rename_bound_idents + (add_modtype id (Mty_ident (Pident id')) s) + (id' :: idents) sg + | Sig_class_type () :: _ -> assert false + | (Sig_value (id, _) | Sig_typext (id, _, _)) :: sg -> + let id' = Ident.rename id in + rename_bound_idents s (id' :: idents) sg + | Sig_class _ :: _ -> assert false +let rec modtype s = function + | Mty_ident p as mty -> ( + match p with + | Pident id -> ( try Tbl.find id s.modtypes with Not_found -> mty) + | Pdot (p, n, pos) -> Mty_ident (Pdot (module_path s p, n, pos)) + | Papply _ -> fatal_error "Subst.modtype") + | Mty_signature sg -> Mty_signature (signature s sg) + | Mty_functor (id, arg, res) -> + let id' = Ident.rename id in + Mty_functor + (id', may_map (modtype s) arg, modtype (add_module id (Pident id') s) res) + | Mty_alias (pres, p) -> Mty_alias (pres, module_path s p) + +and signature s sg = + (* Components of signature may be mutually recursive (e.g. type declarations + or class and type declarations), so first build global renaming + substitution... *) + let new_idents, s' = rename_bound_idents s [] sg in + (* ... then apply it to each signature component in turn *) + List.map2 (signature_component s') sg new_idents + +and signature_component s comp newid = + match comp with + | Sig_value (_id, d) -> Sig_value (newid, value_description s d) + | Sig_type (_id, d, rs) -> Sig_type (newid, type_declaration s d, rs) + | Sig_typext (_id, ext, es) -> + Sig_typext (newid, extension_constructor s ext, es) + | Sig_module (_id, d, rs) -> Sig_module (newid, module_declaration s d, rs) + | Sig_modtype (_id, d) -> Sig_modtype (newid, modtype_declaration s d) + | Sig_class () -> Sig_class () + | Sig_class_type () -> Sig_class_type () + +and module_declaration s decl = + { + md_type = modtype s decl.md_type; + md_attributes = attrs s decl.md_attributes; + md_loc = loc s decl.md_loc; + } + +and modtype_declaration s decl = + { + mtd_type = may_map (modtype s) decl.mtd_type; + mtd_attributes = attrs s decl.mtd_attributes; + mtd_loc = loc s decl.mtd_loc; + } + +(* For every binding k |-> d of m1, add k |-> f d to m2 + and return resulting merged map. *) diff --git a/compiler/ml/subst.mli b/compiler/ml/subst.mli new file mode 100644 index 0000000..62ed5d5 --- /dev/null +++ b/compiler/ml/subst.mli @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Substitutions *) + +open Types + +type t + +(* + Substitutions are used to translate a type from one context to + another. This requires substituting paths for identifiers, and + possibly also lowering the level of non-generic variables so that + they are inferior to the maximum level of the new context. + + Substitutions can also be used to create a "clean" copy of a type. + Indeed, non-variable node of a type are duplicated, with their + levels set to generic level. That way, the resulting type is + well-formed (decreasing levels), even if the original one was not. +*) + +val identity : t + +val add_type : Ident.t -> Path.t -> t -> t +val add_type_path : Path.t -> Path.t -> t -> t +val add_type_function : + Path.t -> params:type_expr list -> body:type_expr -> t -> t +val add_module : Ident.t -> Path.t -> t -> t +val add_module_path : Path.t -> Path.t -> t -> t +val add_modtype : Ident.t -> module_type -> t -> t +val for_saving : t -> t +val reset_for_saving : unit -> unit + +val module_path : t -> Path.t -> Path.t +val type_path : t -> Path.t -> Path.t + +val type_expr : t -> type_expr -> type_expr +val value_description : t -> value_description -> value_description +val type_declaration : t -> type_declaration -> type_declaration +val extension_constructor : t -> extension_constructor -> extension_constructor + +val modtype : t -> module_type -> module_type +val signature : t -> signature -> signature +val modtype_declaration : t -> modtype_declaration -> modtype_declaration +val module_declaration : t -> module_declaration -> module_declaration +val typexp : t -> Types.type_expr -> Types.type_expr + +(* A forward reference to be filled in ctype.ml. *) +val ctype_apply_env_empty : + (type_expr list -> type_expr -> type_expr list -> type_expr) ref diff --git a/compiler/ml/switch.ml b/compiler/ml/switch.ml new file mode 100644 index 0000000..9626f06 --- /dev/null +++ b/compiler/ml/switch.ml @@ -0,0 +1,739 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 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 'a shared = Shared of 'a | Single of 'a + +type 'a t_store = { + act_get_shared: unit -> 'a shared array; + act_store: 'a -> int; + act_store_shared: 'a -> int; +} + +exception Not_simple + +module type Stored = sig + type t + type key + val compare_key : key -> key -> int + val make_key : t -> key option +end + +module Store (A : Stored) = struct + module AMap = Map.Make (struct + type t = A.key + let compare = A.compare_key + end) + + type intern = { + mutable map: (bool * int) AMap.t; + mutable next: int; + mutable acts: (bool * A.t) list; + } + + let mk_store () = + let st = {map = AMap.empty; next = 0; acts = []} in + + let add mustshare act = + let i = st.next in + st.acts <- (mustshare, act) :: st.acts; + st.next <- i + 1; + i + in + + let store mustshare act = + match A.make_key act with + | Some key -> ( + try + let shared, i = AMap.find key st.map in + if not shared then st.map <- AMap.add key (true, i) st.map; + i + with Not_found -> + let i = add mustshare act in + st.map <- AMap.add key (mustshare, i) st.map; + i) + | None -> add mustshare act + and get_shared () = + let acts = + Array.of_list + (List.rev_map + (fun (shared, act) -> if shared then Shared act else Single act) + st.acts) + in + AMap.iter + (fun _ (shared, i) -> + if shared then + match acts.(i) with + | Single act -> acts.(i) <- Shared act + | Shared _ -> ()) + st.map; + acts + in + { + act_store = store false; + act_store_shared = store true; + act_get_shared = get_shared; + } +end + +module type S = sig + type primitive + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + type act + + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + val make_switch : + Location.t -> + act -> + int array -> + act array -> + offset:int -> + Ast_untagged_variants.switch_names option -> + act + val make_catch : act -> int * (act -> act) + val make_exit : int -> act +end + +(* The module will ``produce good code for the case statement'' *) +(* + Adaptation of + R.L. Berstein + ``Producing good code for the case statement'' + Sofware Practice and Experience, 15(10) (1985) + and + D.L. Spuler + ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees + and Split Trees'' + ``Compiler Code Generation for Multiway Branch Statement as + a Static Search Problem'' + Technical Reports, James Cook University +*) +(* + Main adaptation is considering interval tests + (implemented as one addition + one unsigned test and branch) + which leads to exhaustive search for finding the optimal + test sequence in small cases and heuristics otherwise. +*) +module Make (Arg : S) = struct + type 'a inter = {cases: (int * int * int) array; actions: 'a array} + + type 'a t_ctx = {off: int; arg: 'a} + + let cut = ref 8 + + and more_cut = ref 16 + + (* +let pint chan i = + if i = min_int then Printf.fprintf chan "-oo" + else if i=max_int then Printf.fprintf chan "oo" + else Printf.fprintf chan "%d" i + +let pcases chan cases = + for i =0 to Array.length cases-1 do + let l,h,act = cases.(i) in + if l=h then + Printf.fprintf chan "%d:%d " l act + else + Printf.fprintf chan "%a..%a:%d " pint l pint h act + done + +let prerr_inter i = Printf.fprintf stderr + "cases=%a" pcases i.cases +*) + + let get_act cases i = + let _, _, r = cases.(i) in + r + + and get_low cases i = + let r, _, _ = cases.(i) in + r + + type ctests = {mutable n: int; mutable ni: int} + + let too_much = {n = max_int; ni = max_int} + + (* +let ptests chan {n=n ; ni=ni} = + Printf.fprintf chan "{n=%d ; ni=%d}" n ni + +let pta chan t = + for i =0 to Array.length t-1 do + Printf.fprintf chan "%d: %a\n" i ptests t.(i) + done +*) + + let less_tests c1 c2 = + if c1.n < c2.n then true + else if c1.n = c2.n then if c1.ni < c2.ni then true else false + else false + + and eq_tests c1 c2 = c1.n = c2.n && c1.ni = c2.ni + + let less2tests (c1, d1) (c2, d2) = + if eq_tests c1 c2 then less_tests d1 d2 else less_tests c1 c2 + + let add_test t1 t2 = + t1.n <- t1.n + t2.n; + t1.ni <- t1.ni + t2.ni + + type t_ret = Inter of int * int | Sep of int | No + + (* +let pret chan = function + | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j + | Sep i -> Printf.fprintf chan "Sep %d" i + | No -> Printf.fprintf chan "No" +*) + + let coupe cases i = + let l, _, _ = cases.(i) in + (l, Array.sub cases 0 i, Array.sub cases i (Array.length cases - i)) + + let case_append c1 c2 = + let len1 = Array.length c1 and len2 = Array.length c2 in + match (len1, len2) with + | 0, _ -> c2 + | _, 0 -> c1 + | _, _ -> + let l1, h1, act1 = c1.(Array.length c1 - 1) and l2, h2, act2 = c2.(0) in + if act1 = act2 then ( + let r = Array.make (len1 + len2 - 1) c1.(0) in + for i = 0 to len1 - 2 do + r.(i) <- c1.(i) + done; + + let l = + if len1 - 2 >= 0 then + let _, h, _ = r.(len1 - 2) in + if h + 1 < l1 then h + 1 else l1 + else l1 + and h = + if 1 < len2 - 1 then + let l, _, _ = c2.(1) in + if h2 + 1 < l then l - 1 else h2 + else h2 + in + r.(len1 - 1) <- (l, h, act1); + for i = 1 to len2 - 1 do + r.(len1 - 1 + i) <- c2.(i) + done; + r) + else if h1 > l1 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 2 do + r.(i) <- c1.(i) + done; + r.(len1 - 1) <- (l1, l2 - 1, act1); + for i = 0 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else if h2 > l2 then ( + let r = Array.make (len1 + len2) c1.(0) in + for i = 0 to len1 - 1 do + r.(i) <- c1.(i) + done; + r.(len1) <- (h1 + 1, h2, act2); + for i = 1 to len2 - 1 do + r.(len1 + i) <- c2.(i) + done; + r) + else Array.append c1 c2 + + let coupe_inter i j cases = + let lcases = Array.length cases in + let low, _, _ = cases.(i) and _, high, _ = cases.(j) in + ( low, + high, + Array.sub cases i (j - i + 1), + case_append (Array.sub cases 0 i) + (Array.sub cases (j + 1) (lcases - (j + 1))) ) + + type kind = Kvalue of int | Kinter of int | Kempty + + (* +let pkind chan = function + | Kvalue i ->Printf.fprintf chan "V%d" i + | Kinter i -> Printf.fprintf chan "I%d" i + | Kempty -> Printf.fprintf chan "E" + +let rec pkey chan = function + | [] -> () + | [k] -> pkind chan k + | k::rem -> + Printf.fprintf chan "%a %a" pkey rem pkind k +*) + + let t = Hashtbl.create 17 + + let make_key cases = + let seen = ref [] and count = ref 0 in + let rec got_it act = function + | [] -> + seen := (act, !count) :: !seen; + let r = !count in + incr count; + r + | (act0, index) :: rem -> if act0 = act then index else got_it act rem + in + + let make_one (l : int) h act = + if l = h then Kvalue (got_it act !seen) else Kinter (got_it act !seen) + in + + let rec make_rec i pl = + if i < 0 then [] + else + let l, h, act = cases.(i) in + if pl = h + 1 then make_one l h act :: make_rec (i - 1) l + else Kempty :: make_one l h act :: make_rec (i - 1) l + in + + let l, h, act = cases.(Array.length cases - 1) in + make_one l h act :: make_rec (Array.length cases - 2) l + + let same_act t = + let len = Array.length t in + let a = get_act t (len - 1) in + let rec do_rec i = + if i < 0 then true + else + let b = get_act t i in + b = a && do_rec (i - 1) + in + do_rec (len - 2) + + (* + Interval test x in [l,h] works by checking x-l in [0,h-l] + * This may be false for arithmetic modulo 2^31 + * Subtracting l may change the relative ordering of values + and invalid the invariant that matched values are given in + increasing order + + To avoid this, interval check is allowed only when the + integers indeed present in the whole case interval are + in [-2^16 ; 2^16] + + This condition is checked by zyva + *) + + let inter_limit = 1 lsl 16 + + let ok_inter = ref false + + let rec opt_count top cases = + let key = make_key cases in + try Hashtbl.find t key + with Not_found -> + let r = + let lcases = Array.length cases in + match lcases with + | 0 -> assert false + | _ when same_act cases -> (No, ({n = 0; ni = 0}, {n = 0; ni = 0})) + | _ -> + if lcases < !cut then enum top cases + else if lcases < !more_cut then heuristic cases + else divide cases + in + Hashtbl.add t key r; + r + + and divide cases = + let lcases = Array.length cases in + let m = lcases / 2 in + let _, left, right = coupe cases m in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + (Sep m, (cm, ci)) + + and heuristic cases = + let lcases = Array.length cases in + + let sep, csep = divide cases + and inter, cinter = + if !ok_inter then + let _, _, act0 = cases.(0) and _, _, act1 = cases.(lcases - 1) in + if act0 = act1 then ( + let low, high, inside, outside = coupe_inter 1 (lcases - 2) cases in + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = (if low = high then 0 else 1)} + and cij = {n = 1; ni = (if low = high then 0 else 1)} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + (Inter (1, lcases - 2), (cmij, cij))) + else (Inter (-1, -1), (too_much, too_much)) + else (Inter (-1, -1), (too_much, too_much)) + in + if less2tests csep cinter then (sep, csep) else (inter, cinter) + + and enum top cases = + let lcases = Array.length cases in + let lim, with_sep = + let best = ref (-1) and best_cost = ref (too_much, too_much) in + + for i = 1 to lcases - 1 do + let _, left, right = coupe cases i in + let ci = {n = 1; ni = 0} + and cm = {n = 1; ni = 0} + and _, (cml, cleft) = opt_count false left + and _, (cmr, cright) = opt_count false right in + add_test ci cleft; + add_test ci cright; + if less_tests cml cmr then add_test cm cmr else add_test cm cml; + + if less2tests (cm, ci) !best_cost then ( + if top then Printf.fprintf stderr "Get it: %d\n" i; + best := i; + best_cost := (cm, ci)) + done; + (!best, !best_cost) + in + + let ilow, ihigh, with_inter = + if not !ok_inter then ( + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + let low, high, inside, outside = coupe_inter i i cases in + if low = high then ( + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = 0} + and cij = {n = 1; ni = 0} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := i; + best_cost := (cmij, cij))) + done; + (!rlow, !rhigh, !best_cost)) + else + let rlow = ref (-1) + and rhigh = ref (-1) + and best_cost = ref (too_much, too_much) in + for i = 1 to lcases - 2 do + for j = i to lcases - 2 do + let low, high, inside, outside = coupe_inter i j cases in + let _, (cmi, cinside) = opt_count false inside + and _, (cmo, coutside) = opt_count false outside + and cmij = {n = 1; ni = (if low = high then 0 else 1)} + and cij = {n = 1; ni = (if low = high then 0 else 1)} in + add_test cij cinside; + add_test cij coutside; + if less_tests cmi cmo then add_test cmij cmo else add_test cmij cmi; + if less2tests (cmij, cij) !best_cost then ( + rlow := i; + rhigh := j; + best_cost := (cmij, cij)) + done + done; + (!rlow, !rhigh, !best_cost) + in + let r = ref (Inter (ilow, ihigh)) and rc = ref with_inter in + if less2tests with_sep !rc then ( + r := Sep lim; + rc := with_sep); + (!r, !rc) + + let make_if_test test arg i ifso ifnot = + Arg.make_if (Arg.make_prim test [arg; Arg.make_const i]) ifso ifnot + + let make_if_lt arg i ifso ifnot = + match i with + | 1 -> make_if_test Arg.leint arg 0 ifso ifnot + | _ -> make_if_test Arg.ltint arg i ifso ifnot + + and make_if_ge arg i ifso ifnot = + match i with + | 1 -> make_if_test Arg.gtint arg 0 ifso ifnot + | _ -> make_if_test Arg.geint arg i ifso ifnot + + and make_if_eq arg i ifso ifnot = make_if_test Arg.eqint arg i ifso ifnot + + and make_if_ne arg i ifso ifnot = make_if_test Arg.neint arg i ifso ifnot + + let do_make_if_out h arg ifso ifno = + Arg.make_if (Arg.make_isout h arg) ifso ifno + + let make_if_out ctx l d mk_ifso mk_ifno = + match l with + | 0 -> do_make_if_out (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + do_make_if_out (Arg.make_const d) + (Arg.make_offset ctx.arg (-l)) + (mk_ifso ctx) (mk_ifno ctx) + + let do_make_if_in h arg ifso ifno = + Arg.make_if (Arg.make_isin h arg) ifso ifno + + let make_if_in ctx l d mk_ifso mk_ifno = + match l with + | 0 -> do_make_if_in (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) + | _ -> + do_make_if_in (Arg.make_const d) + (Arg.make_offset ctx.arg (-l)) + (mk_ifso ctx) (mk_ifno ctx) + + let rec c_test ctx ({cases; actions} as s) = + let lcases = Array.length cases in + assert (lcases > 0); + if lcases = 1 then actions.(get_act cases 0) ctx + else + let w, _c = opt_count false cases in + (* + Printf.fprintf stderr + "off=%d tactic=%a for %a\n" + ctx.off pret w pcases cases ; + *) + match w with + | No -> actions.(get_act cases 0) ctx + | Inter (i, j) -> + let low, high, inside, outside = coupe_inter i j cases in + let _, (cinside, _) = opt_count false inside + and _, (coutside, _) = opt_count false outside in + (* Costs are retrieved to put the code with more remaining tests + in the privileged (positive) branch of ``if'' *) + if low = high then + if less_tests coutside cinside then + make_if_eq ctx.arg (low + ctx.off) + (c_test ctx {s with cases = inside}) + (c_test ctx {s with cases = outside}) + else + make_if_ne ctx.arg (low + ctx.off) + (c_test ctx {s with cases = outside}) + (c_test ctx {s with cases = inside}) + else if less_tests coutside cinside then + make_if_in ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = inside}) + (fun ctx -> c_test ctx {s with cases = outside}) + else + make_if_out ctx (low + ctx.off) (high - low) + (fun ctx -> c_test ctx {s with cases = outside}) + (fun ctx -> c_test ctx {s with cases = inside}) + | Sep i -> + let lim, left, right = coupe cases i in + let _, (cleft, _) = opt_count false left + and _, (cright, _) = opt_count false right in + let left = {s with cases = left} and right = {s with cases = right} in + + if i = 1 && lim + ctx.off = 1 && get_low cases 0 + ctx.off = 0 then + make_if_ne ctx.arg 0 (c_test ctx right) (c_test ctx left) + else if less_tests cright cleft then + make_if_lt ctx.arg (lim + ctx.off) (c_test ctx left) + (c_test ctx right) + else + make_if_ge ctx.arg (lim + ctx.off) (c_test ctx right) + (c_test ctx left) + + (* Minimal density of switches *) + let theta = ref 0.33333 + + (* Minimal number of tests to make a switch *) + let switch_min = ref 3 + + (* Particular case 0, 1, 2 *) + let particular_case cases i j = + j - i = 2 + && + let l1, _h1, act1 = cases.(i) + and l2, _h2, _act2 = cases.(i + 1) + and l3, h3, act3 = cases.(i + 2) in + l1 + 1 = l2 && l2 + 1 = l3 && l3 = h3 && act1 <> act3 + + let approx_count cases i j = + let l = j - i + 1 in + if l < !cut then + let _, (_, {n = ntests}) = opt_count false (Array.sub cases i l) in + ntests + else l - 1 + + (* Sends back a boolean that says whether is switch is worth or not *) + + let dense {cases} i j = + if i = j then true + else + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + let ntests = approx_count cases i j in + (* + (ntests+1) >= theta * (h-l+1) +*) + particular_case cases i j + || ntests >= !switch_min + && float_of_int ntests +. 1.0 + >= !theta *. (float_of_int h -. float_of_int l +. 1.0) + + (* Compute clusters by dynamic programming + Adaptation of the correction to Bernstein + ``Correction to `Producing Good Code for the Case Statement' '' + S.K. Kannan and T.A. Proebsting + Software Practice and Experience Vol. 24(2) 233 (Feb 1994) + *) + + let comp_clusters s = + let len = Array.length s.cases in + let min_clusters = Array.make len max_int and k = Array.make len 0 in + let get_min i = if i < 0 then 0 else min_clusters.(i) in + + for i = 0 to len - 1 do + for j = 0 to i do + if dense s j i && get_min (j - 1) + 1 < min_clusters.(i) then ( + k.(i) <- j; + min_clusters.(i) <- get_min (j - 1) + 1) + done + done; + (min_clusters.(len - 1), k) + + (* Assume j > i *) + let make_switch loc {cases; actions} i j sw_names = + let ll, _, _ = cases.(i) and _, hh, _ = cases.(j) in + let tbl = Array.make (hh - ll + 1) 0 + and t = Hashtbl.create 17 + and index = ref 0 in + let get_index act = + try Hashtbl.find t act + with Not_found -> + let i = !index in + incr index; + Hashtbl.add t act i; + i + in + + for k = i to j do + let l, h, act = cases.(k) in + let index = get_index act in + for kk = l - ll to h - ll do + tbl.(kk) <- index + done + done; + let acts = Array.make !index actions.(0) in + Hashtbl.iter (fun act i -> acts.(i) <- actions.(act)) t; + fun ctx -> + Arg.make_switch ~offset:(ll + ctx.off) loc ctx.arg tbl acts sw_names + + let make_clusters loc ({cases; actions} as s) n_clusters k sw_names = + let len = Array.length cases in + let r = Array.make n_clusters (0, 0, 0) + and t = Hashtbl.create 17 + and index = ref 0 + and bidon = ref (Array.length actions) in + let get_index act = + try + let i, _ = Hashtbl.find t act in + i + with Not_found -> + let i = !index in + incr index; + Hashtbl.add t act (i, fun _ -> actions.(act)); + i + and add_index act = + let i = !index in + incr index; + incr bidon; + Hashtbl.add t !bidon (i, act); + i + in + + let rec zyva j ir = + let i = k.(j) in + (if i = j then + let l, h, act = cases.(i) in + r.(ir) <- (l, h, get_index act) + else + (* assert i < j *) + let l, _, _ = cases.(i) and _, h, _ = cases.(j) in + r.(ir) <- (l, h, add_index (make_switch loc s i j sw_names))); + if i > 0 then zyva (i - 1) (ir - 1) + in + + zyva (len - 1) (n_clusters - 1); + let acts = Array.make !index (fun _ -> assert false) in + Hashtbl.iter (fun _ (i, act) -> acts.(i) <- act) t; + {cases = r; actions = acts} + + let do_zyva loc (low, high) arg cases actions sw_names = + let old_ok = !ok_inter in + ok_inter := abs low <= inter_limit && abs high <= inter_limit; + if !ok_inter <> old_ok then Hashtbl.clear t; + + let s = {cases; actions} in + + (* + Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; + pcases stderr cases ; + prerr_endline "" ; +*) + let n_clusters, k = comp_clusters s in + let clusters = make_clusters loc s n_clusters k sw_names in + c_test {arg; off = 0} clusters + + let abstract_shared actions = + let handlers = ref (fun x -> x) in + let actions = + Array.map + (fun act -> + match act with + | Single act -> act + | Shared act -> + let i, h = Arg.make_catch act in + let oh = !handlers in + (handlers := fun act -> h (oh act)); + Arg.make_exit i) + actions + in + (!handlers, actions) + + let zyva loc lh arg cases actions names = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + hs (do_zyva loc lh arg cases actions names) + + and test_sequence arg cases actions = + assert (Array.length cases > 0); + let actions = actions.act_get_shared () in + let hs, actions = abstract_shared actions in + let old_ok = !ok_inter in + ok_inter := false; + if !ok_inter <> old_ok then Hashtbl.clear t; + let s = {cases; actions = Array.map (fun act _ -> act) actions} in + (* + Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; + pcases stderr cases ; + prerr_endline "" ; +*) + hs (c_test {arg; off = 0} s) +end diff --git a/compiler/ml/switch.mli b/compiler/ml/switch.mli new file mode 100644 index 0000000..89bce41 --- /dev/null +++ b/compiler/ml/switch.mli @@ -0,0 +1,120 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2000 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. *) +(* *) +(**************************************************************************) + +(* + This module transforms generic switches in combinations + of if tests and switches. +*) + +(* For detecting action sharing, object style *) + +(* Store for actions in object style: + act_store : store an action, returns index in table + In case an action with equal key exists, returns index + of the stored action. Otherwise add entry in table. + act_store_shared : This stored action will always be shared. + act_get : retrieve table + act_get_shared : retrieve table, with sharing explicit +*) + +type 'a shared = Shared of 'a | Single of 'a + +type 'a t_store = { + act_get_shared: unit -> 'a shared array; + act_store: 'a -> int; + act_store_shared: 'a -> int; +} + +exception Not_simple + +module type Stored = sig + type t + type key + val compare_key : key -> key -> int + val make_key : t -> key option +end + +module Store (A : Stored) : sig + val mk_store : unit -> A.t t_store +end + +(* Arguments to the Make functor *) +module type S = sig + (* type of basic tests *) + type primitive + + (* basic tests themselves *) + val eqint : primitive + val neint : primitive + val leint : primitive + val ltint : primitive + val geint : primitive + val gtint : primitive + + (* type of actions *) + type act + + (* Various constructors, for making a binder, + adding one integer, etc. *) + val bind : act -> (act -> act) -> act + val make_const : int -> act + val make_offset : act -> int -> act + val make_prim : primitive -> act list -> act + val make_isout : act -> act -> act + val make_isin : act -> act -> act + val make_if : act -> act -> act -> act + + (* construct an actual switch : + make_switch arg cases acts + NB: cases is in the value form *) + val make_switch : + Location.t -> + act -> + int array -> + act array -> + offset:int -> + Ast_untagged_variants.switch_names option -> + act + + (* Build last minute sharing of action stuff *) + val make_catch : act -> int * (act -> act) + val make_exit : int -> act +end + +(* + Make.zyva arg low high cases actions where + - arg is the argument of the switch. + - low, high are the interval limits. + - cases is a list of sub-interval and action indices + - actions is an array of actions. + + All these arguments specify a switch construct and zyva + returns an action that performs the switch. +*) +module Make : functor (Arg : S) -> sig + (* Standard entry point, sharing is tracked *) + val zyva : + Location.t -> + int * int -> + Arg.act -> + (int * int * int) array -> + Arg.act t_store -> + Ast_untagged_variants.switch_names option -> + Arg.act + + (* Output test sequence, sharing tracked *) + val test_sequence : + Arg.act -> (int * int * int) array -> Arg.act t_store -> Arg.act +end diff --git a/compiler/ml/syntaxerr.ml b/compiler/ml/syntaxerr.ml new file mode 100644 index 0000000..11a12f4 --- /dev/null +++ b/compiler/ml/syntaxerr.ml @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 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. *) +(* *) +(**************************************************************************) + +(* Auxiliary type for reporting syntax errors *) + +type error = Variable_in_scope of Location.t * string + +exception Error of error diff --git a/compiler/ml/syntaxerr.mli b/compiler/ml/syntaxerr.mli new file mode 100644 index 0000000..8d4606d --- /dev/null +++ b/compiler/ml/syntaxerr.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 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. *) +(* *) +(**************************************************************************) + +(** Auxiliary type for reporting syntax errors *) + +type error = Variable_in_scope of Location.t * string + +exception Error of error diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml new file mode 100644 index 0000000..5c12d3d --- /dev/null +++ b/compiler/ml/tast_iterator.ml @@ -0,0 +1,349 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +type iterator = { + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: iterator -> pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> rec_flag * type_declaration list -> unit; + type_extension: iterator -> type_extension -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> rec_flag * value_binding list -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} + +let structure sub {str_items; str_final_env; _} = + List.iter (sub.structure_item sub) str_items; + sub.env sub str_final_env + +let module_type_declaration sub {mtd_type; _} = + Option.iter (sub.module_type sub) mtd_type + +let module_declaration sub {md_type; _} = sub.module_type sub md_type +let include_infos f {incl_mod; _} = f incl_mod + +let structure_item sub {str_desc; str_env; _} = + sub.env sub str_env; + match str_desc with + | Tstr_eval (exp, _) -> sub.expr sub exp + | Tstr_value (rec_flag, list) -> sub.value_bindings sub (rec_flag, list) + | Tstr_primitive v -> sub.value_description sub v + | Tstr_type (rec_flag, list) -> sub.type_declarations sub (rec_flag, list) + | Tstr_typext te -> sub.type_extension sub te + | Tstr_exception ext -> sub.extension_constructor sub ext + | Tstr_module mb -> sub.module_binding sub mb + | Tstr_recmodule list -> List.iter (sub.module_binding sub) list + | Tstr_modtype x -> sub.module_type_declaration sub x + | Tstr_include incl -> include_infos (sub.module_expr sub) incl + | Tstr_open _ -> () + | Tstr_attribute _ -> () + +let value_description sub x = sub.typ sub x.val_desc +let label_decl sub {ld_type; _} = sub.typ sub ld_type + +let constructor_args sub = function + | Cstr_tuple l -> List.iter (sub.typ sub) l + | Cstr_record l -> List.iter (label_decl sub) l + +let constructor_decl sub {cd_args; cd_res; _} = + constructor_args sub cd_args; + Option.iter (sub.typ sub) cd_res + +let type_kind sub = function + | Ttype_abstract -> () + | Ttype_variant list -> List.iter (constructor_decl sub) list + | Ttype_record list -> List.iter (label_decl sub) list + | Ttype_open -> () + +let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} = + List.iter + (fun (c1, c2, _) -> + sub.typ sub c1; + sub.typ sub c2) + typ_cstrs; + sub.type_kind sub typ_kind; + Option.iter (sub.typ sub) typ_manifest; + List.iter (fun (c, _) -> sub.typ sub c) typ_params + +let type_declarations sub (_, list) = List.iter (sub.type_declaration sub) list + +let type_extension sub {tyext_constructors; tyext_params; _} = + List.iter (fun (c, _) -> sub.typ sub c) tyext_params; + List.iter (sub.extension_constructor sub) tyext_constructors + +let extension_constructor sub {ext_kind; _} = + match ext_kind with + | Text_decl (ctl, cto) -> + constructor_args sub ctl; + Option.iter (sub.typ sub) cto + | Text_rebind _ -> () + +let pat sub {pat_extra; pat_desc; pat_env; _} = + let extra = function + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_open (_, _, env) -> sub.env sub env + | Tpat_constraint ct -> sub.typ sub ct + in + sub.env sub pat_env; + List.iter (fun (e, _, _) -> extra e) pat_extra; + match pat_desc with + | Tpat_any -> () + | Tpat_var _ -> () + | Tpat_constant _ -> () + | Tpat_tuple l -> List.iter (sub.pat sub) l + | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l + | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po + | Tpat_record (l, _) -> List.iter (fun (_, _, i, _) -> sub.pat sub i) l + | Tpat_array l -> List.iter (sub.pat sub) l + | Tpat_or (p1, p2, _) -> + sub.pat sub p1; + sub.pat sub p2 + | Tpat_alias (p, _, _) -> sub.pat sub p + +let expr sub {exp_extra; exp_desc; exp_env; _} = + let extra = function + | Texp_constraint cty -> sub.typ sub cty + | Texp_coerce cty2 -> sub.typ sub cty2 + | Texp_newtype _ -> () + | Texp_open (_, _, _, _) -> () + in + List.iter (fun (e, _, _) -> extra e) exp_extra; + sub.env sub exp_env; + match exp_desc with + | Texp_ident _ -> () + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + sub.value_bindings sub (rec_flag, list); + sub.expr sub exp + | Texp_function {case; _} -> sub.case sub case + | Texp_apply {funct = exp; args = list} -> + sub.expr sub exp; + List.iter (fun (_, o) -> Option.iter (sub.expr sub) o) list + | Texp_match (exp, list1, list2, _) -> + sub.expr sub exp; + sub.cases sub list1; + sub.cases sub list2 + | Texp_try (exp, cases) -> + sub.expr sub exp; + sub.cases sub cases + | Texp_tuple list -> List.iter (sub.expr sub) list + | Texp_construct (_, _, args) -> List.iter (sub.expr sub) args + | Texp_variant (_, expo) -> Option.iter (sub.expr sub) expo + | Texp_record {fields; extended_expression; _} -> + Array.iter + (function + | _, Kept _, _ -> () + | _, Overridden (_, exp), _ -> sub.expr sub exp) + fields; + Option.iter (sub.expr sub) extended_expression + | Texp_field (exp, _, _) -> sub.expr sub exp + | Texp_setfield (exp1, _, _, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_array list -> List.iter (sub.expr sub) list + | Texp_ifthenelse (exp1, exp2, expo) -> + sub.expr sub exp1; + sub.expr sub exp2; + Option.iter (sub.expr sub) expo + | Texp_sequence (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_while (exp1, exp2) -> + sub.expr sub exp1; + sub.expr sub exp2 + | Texp_for (_, _, exp1, exp2, _, exp3) -> + sub.expr sub exp1; + sub.expr sub exp2; + sub.expr sub exp3 + | Texp_send (exp, _, expo) -> + sub.expr sub exp; + Option.iter (sub.expr sub) expo + | Texp_letmodule (_, _, mexpr, exp) -> + sub.module_expr sub mexpr; + sub.expr sub exp + | Texp_letexception (cd, exp) -> + sub.extension_constructor sub cd; + sub.expr sub exp + | Texp_assert exp -> sub.expr sub exp + | Texp_pack mexpr -> sub.module_expr sub mexpr + | Texp_extension_constructor _ -> () + +let package_type sub {pack_fields; _} = + List.iter (fun (_, p) -> sub.typ sub p) pack_fields + +let signature sub {sig_items; sig_final_env; _} = + sub.env sub sig_final_env; + List.iter (sub.signature_item sub) sig_items + +let signature_item sub {sig_desc; sig_env; _} = + sub.env sub sig_env; + match sig_desc with + | Tsig_value v -> sub.value_description sub v + | Tsig_type (rf, tdl) -> sub.type_declarations sub (rf, tdl) + | Tsig_typext te -> sub.type_extension sub te + | Tsig_exception ext -> sub.extension_constructor sub ext + | Tsig_module x -> sub.module_declaration sub x + | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list + | Tsig_modtype x -> sub.module_type_declaration sub x + | Tsig_include incl -> include_infos (sub.module_type sub) incl + | Tsig_open _od -> () + | Tsig_attribute _ -> () + +let module_type sub {mty_desc; mty_env; _} = + sub.env sub mty_env; + match mty_desc with + | Tmty_ident _ -> () + | Tmty_alias _ -> () + | Tmty_signature sg -> sub.signature sub sg + | Tmty_functor (_, _, mtype1, mtype2) -> + Option.iter (sub.module_type sub) mtype1; + sub.module_type sub mtype2 + | Tmty_with (mtype, list) -> + sub.module_type sub mtype; + List.iter (fun (_, _, e) -> sub.with_constraint sub e) list + | Tmty_typeof mexpr -> sub.module_expr sub mexpr + +let with_constraint sub = function + | Twith_type decl -> sub.type_declaration sub decl + | Twith_typesubst decl -> sub.type_declaration sub decl + | Twith_module _ -> () + | Twith_modsubst _ -> () + +let module_coercion sub = function + | Tcoerce_none -> () + | Tcoerce_functor (c1, c2) -> + sub.module_coercion sub c1; + sub.module_coercion sub c2 + | Tcoerce_alias (_, c1) -> sub.module_coercion sub c1 + | Tcoerce_structure (l1, l2, _) -> + List.iter (fun (_, c) -> sub.module_coercion sub c) l1; + List.iter (fun (_, _, c) -> sub.module_coercion sub c) l2 + | Tcoerce_primitive {pc_env; _} -> sub.env sub pc_env + +let module_expr sub {mod_desc; mod_env; _} = + sub.env sub mod_env; + match mod_desc with + | Tmod_ident _ -> () + | Tmod_structure st -> sub.structure sub st + | Tmod_functor (_, _, mtype, mexpr) -> + Option.iter (sub.module_type sub) mtype; + sub.module_expr sub mexpr + | Tmod_apply (mexp1, mexp2, c) -> + sub.module_expr sub mexp1; + sub.module_expr sub mexp2; + sub.module_coercion sub c + | Tmod_constraint (mexpr, _, Tmodtype_implicit, c) -> + sub.module_expr sub mexpr; + sub.module_coercion sub c + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, c) -> + sub.module_expr sub mexpr; + sub.module_type sub mtype; + sub.module_coercion sub c + | Tmod_unpack (exp, _) -> sub.expr sub exp + +let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr + +let typ sub {ctyp_desc; ctyp_env; _} = + sub.env sub ctyp_env; + match ctyp_desc with + | Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (arg, ret, _) -> + sub.typ sub arg.typ; + sub.typ sub ret + | Ttyp_tuple list -> List.iter (sub.typ sub) list + | Ttyp_constr (_, _, list) -> List.iter (sub.typ sub) list + | Ttyp_object (list, _) -> List.iter (sub.object_field sub) list + | Ttyp_alias (ct, _) -> sub.typ sub ct + | Ttyp_variant (list, _, _) -> List.iter (sub.row_field sub) list + | Ttyp_poly (_, ct) -> sub.typ sub ct + | Ttyp_package pack -> sub.package_type sub pack + +let row_field sub = function + | Ttag (_label, _attrs, _bool, list) -> List.iter (sub.typ sub) list + | Tinherit ct -> sub.typ sub ct + +let object_field sub = function + | OTtag (_, _, ct) | OTinherit ct -> sub.typ sub ct + +let value_bindings sub (_, list) = List.iter (sub.value_binding sub) list +let cases sub l = List.iter (sub.case sub) l + +let case sub {c_lhs; c_guard; c_rhs} = + sub.pat sub c_lhs; + Option.iter (sub.expr sub) c_guard; + sub.expr sub c_rhs + +let value_binding sub {vb_pat; vb_expr; _} = + sub.pat sub vb_pat; + sub.expr sub vb_expr + +let env _sub _ = () + +let default_iterator = + { + case; + cases; + env; + expr; + extension_constructor; + module_binding; + module_coercion; + module_declaration; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + object_field; + row_field; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + } diff --git a/compiler/ml/tast_iterator.mli b/compiler/ml/tast_iterator.mli new file mode 100644 index 0000000..85df043 --- /dev/null +++ b/compiler/ml/tast_iterator.mli @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Isaac "Izzy" Avram *) +(* *) +(* Copyright 2019 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. *) +(* *) +(**************************************************************************) + +(** +Allows the implementation of typed tree inspection using open recursion +*) + +open Asttypes +open Typedtree + +type iterator = { + case: iterator -> case -> unit; + cases: iterator -> case list -> unit; + env: iterator -> Env.t -> unit; + expr: iterator -> expression -> unit; + extension_constructor: iterator -> extension_constructor -> unit; + module_binding: iterator -> module_binding -> unit; + module_coercion: iterator -> module_coercion -> unit; + module_declaration: iterator -> module_declaration -> unit; + module_expr: iterator -> module_expr -> unit; + module_type: iterator -> module_type -> unit; + module_type_declaration: iterator -> module_type_declaration -> unit; + package_type: iterator -> package_type -> unit; + pat: iterator -> pattern -> unit; + row_field: iterator -> row_field -> unit; + object_field: iterator -> object_field -> unit; + signature: iterator -> signature -> unit; + signature_item: iterator -> signature_item -> unit; + structure: iterator -> structure -> unit; + structure_item: iterator -> structure_item -> unit; + typ: iterator -> core_type -> unit; + type_declaration: iterator -> type_declaration -> unit; + type_declarations: iterator -> rec_flag * type_declaration list -> unit; + type_extension: iterator -> type_extension -> unit; + type_kind: iterator -> type_kind -> unit; + value_binding: iterator -> value_binding -> unit; + value_bindings: iterator -> rec_flag * value_binding list -> unit; + value_description: iterator -> value_description -> unit; + with_constraint: iterator -> with_constraint -> unit; +} + +val default_iterator : iterator diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml new file mode 100644 index 0000000..54eba02 --- /dev/null +++ b/compiler/ml/tast_mapper.ml @@ -0,0 +1,435 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +(* TODO: add 'methods' for location, attribute, extension, + open_description, include_declaration, include_description *) + +type mapper = { + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: mapper -> pattern -> pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: + mapper -> + rec_flag * type_declaration list -> + rec_flag * type_declaration list; + type_extension: mapper -> type_extension -> type_extension; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: + mapper -> rec_flag * value_binding list -> rec_flag * value_binding list; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} + +let id x = x +let tuple2 f1 f2 (x, y) = (f1 x, f2 y) +let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let tuple4 f1 f2 f3 f4 (x, y, z, w) = (f1 x, f2 y, f3 z, f4 w) +let opt f = function + | None -> None + | Some x -> Some (f x) + +let structure sub {str_items; str_type; str_final_env} = + { + str_items = List.map (sub.structure_item sub) str_items; + str_final_env = sub.env sub str_final_env; + str_type; + } + +let module_type_declaration sub x = + let mtd_type = opt (sub.module_type sub) x.mtd_type in + {x with mtd_type} + +let module_declaration sub x = + let md_type = sub.module_type sub x.md_type in + {x with md_type} + +let include_infos f x = {x with incl_mod = f x.incl_mod} + +let structure_item sub {str_desc; str_loc; str_env} = + let str_env = sub.env sub str_env in + let str_desc = + match str_desc with + | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs) + | Tstr_value (rec_flag, list) -> + let rec_flag, list = sub.value_bindings sub (rec_flag, list) in + Tstr_value (rec_flag, list) + | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v) + | Tstr_type (rec_flag, list) -> + let rec_flag, list = sub.type_declarations sub (rec_flag, list) in + Tstr_type (rec_flag, list) + | Tstr_typext te -> Tstr_typext (sub.type_extension sub te) + | Tstr_exception ext -> Tstr_exception (sub.extension_constructor sub ext) + | Tstr_module mb -> Tstr_module (sub.module_binding sub mb) + | Tstr_recmodule list -> + Tstr_recmodule (List.map (sub.module_binding sub) list) + | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x) + | Tstr_include incl -> + Tstr_include (include_infos (sub.module_expr sub) incl) + | (Tstr_open _ | Tstr_attribute _) as d -> d + in + {str_desc; str_env; str_loc} + +let value_description sub x = + let val_desc = sub.typ sub x.val_desc in + {x with val_desc} + +let label_decl sub x = + let ld_type = sub.typ sub x.ld_type in + {x with ld_type} + +let constructor_args sub = function + | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Cstr_record (List.map (label_decl sub) l) + +let constructor_decl sub cd = + let cd_args = constructor_args sub cd.cd_args in + let cd_res = opt (sub.typ sub) cd.cd_res in + {cd with cd_args; cd_res} + +let type_kind sub = function + | Ttype_abstract -> Ttype_abstract + | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list) + | Ttype_record list -> Ttype_record (List.map (label_decl sub) list) + | Ttype_open -> Ttype_open + +let type_declaration sub x = + let typ_cstrs = + List.map (tuple3 (sub.typ sub) (sub.typ sub) id) x.typ_cstrs + in + let typ_kind = sub.type_kind sub x.typ_kind in + let typ_manifest = opt (sub.typ sub) x.typ_manifest in + let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in + {x with typ_cstrs; typ_kind; typ_manifest; typ_params} + +let type_declarations sub (rec_flag, list) = + (rec_flag, List.map (sub.type_declaration sub) list) + +let type_extension sub x = + let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in + let tyext_constructors = + List.map (sub.extension_constructor sub) x.tyext_constructors + in + {x with tyext_constructors; tyext_params} + +let extension_constructor sub x = + let ext_kind = + match x.ext_kind with + | Text_decl (ctl, cto) -> + Text_decl (constructor_args sub ctl, opt (sub.typ sub) cto) + | Text_rebind _ as d -> d + in + {x with ext_kind} + +let pat sub x = + let extra = function + | (Tpat_type _ | Tpat_unpack) as d -> d + | Tpat_open (path, loc, env) -> Tpat_open (path, loc, sub.env sub env) + | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) + in + let pat_env = sub.env sub x.pat_env in + let pat_extra = List.map (tuple3 extra id id) x.pat_extra in + let pat_desc = + match x.pat_desc with + | (Tpat_any | Tpat_var _ | Tpat_constant _) as d -> d + | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) + | Tpat_construct (loc, cd, l) -> + Tpat_construct (loc, cd, List.map (sub.pat sub) l) + | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd) + | Tpat_record (l, closed) -> + Tpat_record (List.map (tuple4 id id (sub.pat sub) id) l, closed) + | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) + | Tpat_or (p1, p2, rd) -> Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) + | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) + in + {x with pat_extra; pat_desc; pat_env} + +let expr sub x = + let extra = function + | Texp_constraint cty -> Texp_constraint (sub.typ sub cty) + | Texp_coerce cty2 -> Texp_coerce (sub.typ sub cty2) + | Texp_open (ovf, path, loc, env) -> + Texp_open (ovf, path, loc, sub.env sub env) + | Texp_newtype _ as d -> d + in + let exp_extra = List.map (tuple3 extra id id) x.exp_extra in + let exp_env = sub.env sub x.exp_env in + let exp_desc = + match x.exp_desc with + | (Texp_ident _ | Texp_constant _) as d -> d + | Texp_let (rec_flag, list, exp) -> + let rec_flag, list = sub.value_bindings sub (rec_flag, list) in + Texp_let (rec_flag, list, sub.expr sub exp) + | Texp_function {arg_label; arity; param; case; partial; async} -> + Texp_function + {arg_label; arity; param; case = sub.case sub case; partial; async} + | Texp_apply {funct = exp; args = list; partial; transformed_jsx} -> + Texp_apply + { + funct = sub.expr sub exp; + args = List.map (tuple2 id (opt (sub.expr sub))) list; + partial; + transformed_jsx; + } + | Texp_match (exp, cases, exn_cases, p) -> + Texp_match + (sub.expr sub exp, sub.cases sub cases, sub.cases sub exn_cases, p) + | Texp_try (exp, cases) -> Texp_try (sub.expr sub exp, sub.cases sub cases) + | Texp_tuple list -> Texp_tuple (List.map (sub.expr sub) list) + | Texp_construct (lid, cd, args) -> + Texp_construct (lid, cd, List.map (sub.expr sub) args) + | Texp_variant (l, expo) -> Texp_variant (l, opt (sub.expr sub) expo) + | Texp_record {fields; representation; extended_expression} -> + let fields = + Array.map + (function + | label, Kept t, o -> (label, Kept t, o) + | label, Overridden (lid, exp), o -> + (label, Overridden (lid, sub.expr sub exp), o)) + fields + in + Texp_record + { + fields; + representation; + extended_expression = opt (sub.expr sub) extended_expression; + } + | Texp_field (exp, lid, ld) -> Texp_field (sub.expr sub exp, lid, ld) + | Texp_setfield (exp1, lid, ld, exp2) -> + Texp_setfield (sub.expr sub exp1, lid, ld, sub.expr sub exp2) + | Texp_array list -> Texp_array (List.map (sub.expr sub) list) + | Texp_ifthenelse (exp1, exp2, expo) -> + Texp_ifthenelse + (sub.expr sub exp1, sub.expr sub exp2, opt (sub.expr sub) expo) + | Texp_sequence (exp1, exp2) -> + Texp_sequence (sub.expr sub exp1, sub.expr sub exp2) + | Texp_while (exp1, exp2) -> + Texp_while (sub.expr sub exp1, sub.expr sub exp2) + | Texp_for (id, p, exp1, exp2, dir, exp3) -> + Texp_for + (id, p, sub.expr sub exp1, sub.expr sub exp2, dir, sub.expr sub exp3) + | Texp_send (exp, meth, expo) -> + Texp_send (sub.expr sub exp, meth, opt (sub.expr sub) expo) + | Texp_letmodule (id, s, mexpr, exp) -> + Texp_letmodule (id, s, sub.module_expr sub mexpr, sub.expr sub exp) + | Texp_letexception (cd, exp) -> + Texp_letexception (sub.extension_constructor sub cd, sub.expr sub exp) + | Texp_assert exp -> Texp_assert (sub.expr sub exp) + | Texp_pack mexpr -> Texp_pack (sub.module_expr sub mexpr) + | Texp_extension_constructor _ as e -> e + in + {x with exp_extra; exp_desc; exp_env} + +let package_type sub x = + let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in + {x with pack_fields} + +let signature sub x = + let sig_final_env = sub.env sub x.sig_final_env in + let sig_items = List.map (sub.signature_item sub) x.sig_items in + {x with sig_items; sig_final_env} + +let signature_item sub x = + let sig_env = sub.env sub x.sig_env in + let sig_desc = + match x.sig_desc with + | Tsig_value v -> Tsig_value (sub.value_description sub v) + | Tsig_type (rec_flag, list) -> + let rec_flag, list = sub.type_declarations sub (rec_flag, list) in + Tsig_type (rec_flag, list) + | Tsig_typext te -> Tsig_typext (sub.type_extension sub te) + | Tsig_exception ext -> Tsig_exception (sub.extension_constructor sub ext) + | Tsig_module x -> Tsig_module (sub.module_declaration sub x) + | Tsig_recmodule list -> + Tsig_recmodule (List.map (sub.module_declaration sub) list) + | Tsig_modtype x -> Tsig_modtype (sub.module_type_declaration sub x) + | Tsig_include incl -> + Tsig_include (include_infos (sub.module_type sub) incl) + | (Tsig_open _ | Tsig_attribute _) as d -> d + in + {x with sig_desc; sig_env} + +let module_type sub x = + let mty_env = sub.env sub x.mty_env in + let mty_desc = + match x.mty_desc with + | (Tmty_ident _ | Tmty_alias _) as d -> d + | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) + | Tmty_functor (id, s, mtype1, mtype2) -> + Tmty_functor + (id, s, opt (sub.module_type sub) mtype1, sub.module_type sub mtype2) + | Tmty_with (mtype, list) -> + Tmty_with + ( sub.module_type sub mtype, + List.map (tuple3 id id (sub.with_constraint sub)) list ) + | Tmty_typeof mexpr -> Tmty_typeof (sub.module_expr sub mexpr) + in + {x with mty_desc; mty_env} + +let with_constraint sub = function + | Twith_type decl -> Twith_type (sub.type_declaration sub decl) + | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) + | (Twith_module _ | Twith_modsubst _) as d -> d + +let module_coercion sub = function + | Tcoerce_none -> Tcoerce_none + | Tcoerce_functor (c1, c2) -> + Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2) + | Tcoerce_alias (p, c1) -> Tcoerce_alias (p, sub.module_coercion sub c1) + | Tcoerce_structure (l1, l2, runtime_fields) -> + let l1' = List.map (fun (i, c) -> (i, sub.module_coercion sub c)) l1 in + let l2' = + List.map (fun (id, i, c) -> (id, i, sub.module_coercion sub c)) l2 + in + Tcoerce_structure (l1', l2', runtime_fields) + | Tcoerce_primitive pc -> + Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env} + +let module_expr sub x = + let mod_env = sub.env sub x.mod_env in + let mod_desc = + match x.mod_desc with + | Tmod_ident _ as d -> d + | Tmod_structure st -> Tmod_structure (sub.structure sub st) + | Tmod_functor (id, s, mtype, mexpr) -> + Tmod_functor + (id, s, opt (sub.module_type sub) mtype, sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, c) -> + Tmod_apply + ( sub.module_expr sub mexp1, + sub.module_expr sub mexp2, + sub.module_coercion sub c ) + | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) -> + Tmod_constraint + ( sub.module_expr sub mexpr, + mt, + Tmodtype_implicit, + sub.module_coercion sub c ) + | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) -> + Tmod_constraint + ( sub.module_expr sub mexpr, + mt, + Tmodtype_explicit (sub.module_type sub mtype), + sub.module_coercion sub c ) + | Tmod_unpack (exp, mty) -> Tmod_unpack (sub.expr sub exp, mty) + in + {x with mod_desc; mod_env} + +let module_binding sub x = + let mb_expr = sub.module_expr sub x.mb_expr in + {x with mb_expr} + +let typ sub x = + let ctyp_env = sub.env sub x.ctyp_env in + let ctyp_desc = + match x.ctyp_desc with + | (Ttyp_any | Ttyp_var _) as d -> d + | Ttyp_arrow (arg, ret, arity) -> + Ttyp_arrow ({arg with typ = sub.typ sub arg.typ}, sub.typ sub ret, arity) + | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list) + | Ttyp_constr (path, lid, list) -> + Ttyp_constr (path, lid, List.map (sub.typ sub) list) + | Ttyp_object (list, closed) -> + Ttyp_object (List.map (sub.object_field sub) list, closed) + | Ttyp_alias (ct, s) -> Ttyp_alias (sub.typ sub ct, s) + | Ttyp_variant (list, closed, labels) -> + Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) + | Ttyp_poly (sl, ct) -> Ttyp_poly (sl, sub.typ sub ct) + | Ttyp_package pack -> Ttyp_package (sub.package_type sub pack) + in + {x with ctyp_desc; ctyp_env} + +let row_field sub = function + | Ttag (label, attrs, b, list) -> + Ttag (label, attrs, b, List.map (sub.typ sub) list) + | Tinherit ct -> Tinherit (sub.typ sub ct) + +let object_field sub = function + | OTtag (label, attrs, ct) -> OTtag (label, attrs, sub.typ sub ct) + | OTinherit ct -> OTinherit (sub.typ sub ct) + +let value_bindings sub (rec_flag, list) = + (rec_flag, List.map (sub.value_binding sub) list) + +let cases sub l = List.map (sub.case sub) l + +let case sub {c_lhs; c_guard; c_rhs} = + { + c_lhs = sub.pat sub c_lhs; + c_guard = opt (sub.expr sub) c_guard; + c_rhs = sub.expr sub c_rhs; + } + +let value_binding sub x = + let vb_pat = sub.pat sub x.vb_pat in + let vb_expr = sub.expr sub x.vb_expr in + {x with vb_pat; vb_expr} + +let env _sub x = x + +let default = + { + case; + cases; + env; + expr; + extension_constructor; + module_binding; + module_coercion; + module_declaration; + module_expr; + module_type; + module_type_declaration; + package_type; + pat; + row_field; + object_field; + signature; + signature_item; + structure; + structure_item; + typ; + type_declaration; + type_declarations; + type_extension; + type_kind; + value_binding; + value_bindings; + value_description; + with_constraint; + } diff --git a/compiler/ml/tast_mapper.mli b/compiler/ml/tast_mapper.mli new file mode 100644 index 0000000..50f3ba2 --- /dev/null +++ b/compiler/ml/tast_mapper.mli @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Alain Frisch, LexiFi *) +(* *) +(* Copyright 2015 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +(** {1 A generic Typedtree mapper} *) + +type mapper = { + case: mapper -> case -> case; + cases: mapper -> case list -> case list; + env: mapper -> Env.t -> Env.t; + expr: mapper -> expression -> expression; + extension_constructor: + mapper -> extension_constructor -> extension_constructor; + module_binding: mapper -> module_binding -> module_binding; + module_coercion: mapper -> module_coercion -> module_coercion; + module_declaration: mapper -> module_declaration -> module_declaration; + module_expr: mapper -> module_expr -> module_expr; + module_type: mapper -> module_type -> module_type; + module_type_declaration: + mapper -> module_type_declaration -> module_type_declaration; + package_type: mapper -> package_type -> package_type; + pat: mapper -> pattern -> pattern; + row_field: mapper -> row_field -> row_field; + object_field: mapper -> object_field -> object_field; + signature: mapper -> signature -> signature; + signature_item: mapper -> signature_item -> signature_item; + structure: mapper -> structure -> structure; + structure_item: mapper -> structure_item -> structure_item; + typ: mapper -> core_type -> core_type; + type_declaration: mapper -> type_declaration -> type_declaration; + type_declarations: + mapper -> + rec_flag * type_declaration list -> + rec_flag * type_declaration list; + type_extension: mapper -> type_extension -> type_extension; + type_kind: mapper -> type_kind -> type_kind; + value_binding: mapper -> value_binding -> value_binding; + value_bindings: + mapper -> rec_flag * value_binding list -> rec_flag * value_binding list; + value_description: mapper -> value_description -> value_description; + with_constraint: mapper -> with_constraint -> with_constraint; +} + +val default : mapper diff --git a/compiler/ml/tbl.ml b/compiler/ml/tbl.ml new file mode 100644 index 0000000..d37ba50 --- /dev/null +++ b/compiler/ml/tbl.ml @@ -0,0 +1,111 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +type ('k, 'v) t = Empty | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int + +let empty = Empty + +let height = function + | Empty -> 0 + | Node (_, _, _, _, h) -> h + +let create l x d r = + let hl = height l and hr = height r in + Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1) + +let bal l x d r = + let hl = height l and hr = height r in + if hl > hr + 1 then + match l with + | Node (ll, lv, ld, lr, _) when height ll >= height lr -> + create ll lv ld (create lr x d r) + | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) -> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + | _ -> assert false + else if hr > hl + 1 then + match r with + | Node (rl, rv, rd, rr, _) when height rr >= height rl -> + create (create l x d rl) rv rd rr + | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + | _ -> assert false + else create l x d r + +let rec add x data = function + | Empty -> Node (Empty, x, data, Empty, 1) + | Node (l, v, d, r, h) -> + let c = compare x v in + if c = 0 then Node (l, x, data, r, h) + else if c < 0 then bal (add x data l) v d r + else bal l v d (add x data r) + +let rec find x = function + | Empty -> raise Not_found + | Node (l, v, d, r, _) -> + let c = compare x v in + if c = 0 then d else find x (if c < 0 then l else r) + +let rec find_str (x : string) = function + | Empty -> raise Not_found + | Node (l, v, d, r, _) -> + let c = compare x v in + if c = 0 then d else find_str x (if c < 0 then l else r) + +let rec mem x = function + | Empty -> false + | Node (l, v, _d, r, _) -> + let c = compare x v in + c = 0 || mem x (if c < 0 then l else r) + +let rec merge t1 t2 = + match (t1, t2) with + | Empty, t -> t + | t, Empty -> t + | Node (l1, v1, d1, r1, _h1), Node (l2, v2, d2, r2, _h2) -> + bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) + +let rec remove x = function + | Empty -> Empty + | Node (l, v, d, r, _h) -> + let c = compare x v in + if c = 0 then merge l r + else if c < 0 then bal (remove x l) v d r + else bal l v d (remove x r) + +let rec iter f = function + | Empty -> () + | Node (l, v, d, r, _) -> + iter f l; + f v d; + iter f r + +let rec map f = function + | Empty -> Empty + | Node (l, v, d, r, h) -> Node (map f l, v, f v d, map f r, h) + +let rec fold f m accu = + match m with + | Empty -> accu + | Node (l, v, d, r, _) -> fold f r (f v d (fold f l accu)) + +open Format + +let print print_key print_data ppf tbl = + let print_tbl ppf tbl = + iter + (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) + tbl + in + fprintf ppf "@[[[%a]]@]" print_tbl tbl diff --git a/compiler/ml/tbl.mli b/compiler/ml/tbl.mli new file mode 100644 index 0000000..7d9296e --- /dev/null +++ b/compiler/ml/tbl.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Association tables from any ordered type to any type. + We use the generic ordering to compare keys. *) + +type ('k, 'v) t + +val empty : ('k, 'v) t +val add : 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t +val find : 'k -> ('k, 'v) t -> 'v +val find_str : string -> (string, 'v) t -> 'v +val mem : 'k -> ('k, 'v) t -> bool +val remove : 'k -> ('k, 'v) t -> ('k, 'v) t +val iter : ('k -> 'v -> unit) -> ('k, 'v) t -> unit +val map : ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t +val fold : ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc + +open Format + +val print : + (formatter -> 'k -> unit) -> + (formatter -> 'v -> unit) -> + formatter -> + ('k, 'v) t -> + unit diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml new file mode 100644 index 0000000..6b89d29 --- /dev/null +++ b/compiler/ml/transl_recmodule.ml @@ -0,0 +1,257 @@ +open Types +open Typedtree +open Lambda + +type error = Circular_dependency of Ident.t + +exception Error of Location.t * error +(* Reorder bindings to honor dependencies. *) + +(* Utilities for compiling "module rec" definitions *) + +let undefined_location loc = + let fname, line, char = Location.get_pos_info loc.Location.loc_start in + let fname = Filename.basename fname in + Lconst + (Const_block + ( Lambda.Blk_tuple, + [ + Const_base (Const_string (fname, None)); + Const_base (Const_int line); + Const_base (Const_int char); + ] )) + +let cstr_const = 3 + +let cstr_non_const = 2 + +let init_shape modl = + let add_name x id = + Const_block (Blk_tuple, [x; Const_base (Const_string (Ident.name id, None))]) + in + let module_tag_info : Lambda.tag_info = + Blk_constructor {name = "Module"; num_nonconst = 2; tag = 0; attrs = []} + in + let value_tag_info : Lambda.tag_info = + Blk_constructor {name = "value"; num_nonconst = 2; tag = 1; attrs = []} + in + let rec init_shape_mod env mty = + match Mtype.scrape env mty with + | Mty_ident _ -> raise Not_found + | Mty_alias _ -> + Const_block (value_tag_info, [Const_pointer (0, Pt_module_alias)]) + | Mty_signature sg -> + Const_block + (module_tag_info, [Const_block (Blk_tuple, init_shape_struct env sg)]) + | Mty_functor _ -> raise Not_found + (* can we do better? *) + and init_shape_struct env sg = + match sg with + | [] -> [] + | Sig_value (id, {val_kind = Val_reg; val_type = ty}) :: rem -> + let is_function t = + match t.desc with + | Tarrow _ -> true + | _ -> false + in + let init_v = + match Ctype.expand_head env ty with + | t when is_function t -> + Const_pointer + ( 0, + Pt_constructor + { + name = "Function"; + const = cstr_const; + non_const = cstr_non_const; + attrs = []; + } ) + | _ -> raise Not_found + in + add_name init_v id :: init_shape_struct env rem + | Sig_value (_, {val_kind = Val_prim _}) :: rem -> init_shape_struct env rem + | Sig_type (id, tdecl, _) :: rem -> + init_shape_struct (Env.add_type ~check:false id tdecl env) rem + | Sig_typext _ :: _ -> raise Not_found + | Sig_module (id, md, _) :: rem -> + add_name (init_shape_mod env md.md_type) id + :: init_shape_struct + (Env.add_module_declaration ~check:false id md env) + rem + | Sig_modtype (id, minfo) :: rem -> + init_shape_struct (Env.add_modtype id minfo env) rem + | Sig_class _ :: _ -> assert false + | Sig_class_type _ :: rem -> init_shape_struct env rem + in + try + Some + ( undefined_location modl.mod_loc, + Lconst (init_shape_mod modl.mod_env modl.mod_type) ) + with Not_found -> None + +type binding_status = Undefined | Inprogress | Defined + +let reorder_rec_bindings bindings = + let id = Array.of_list (List.map (fun (id, _, _, _) -> id) bindings) + and loc = Array.of_list (List.map (fun (_, loc, _, _) -> loc) bindings) + and init = Array.of_list (List.map (fun (_, _, init, _) -> init) bindings) + and rhs = Array.of_list (List.map (fun (_, _, _, rhs) -> rhs) bindings) in + let fv = Array.map Lambda.free_variables rhs in + let num_bindings = Array.length id in + let status = Array.make num_bindings Undefined in + let res = ref [] in + let rec emit_binding i = + match status.(i) with + | Defined -> () + | Inprogress -> raise (Error (loc.(i), Circular_dependency id.(i))) + | Undefined -> + if init.(i) = None then ( + status.(i) <- Inprogress; + for j = 0 to num_bindings - 1 do + if IdentSet.mem id.(j) fv.(i) then emit_binding j + done); + res := (id.(i), init.(i), rhs.(i)) :: !res; + status.(i) <- Defined + in + for i = 0 to num_bindings - 1 do + match status.(i) with + | Undefined -> emit_binding i + | Inprogress -> assert false + | Defined -> () + done; + List.rev !res + +type t = Lambda.lambda + +(* Utilities for compiling "module rec" definitions *) + +type loc = t + +type shape = t + +type binding = Ident.t * (loc * shape) option * t + +let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = + let rec bind_inits args acc = + match args with + | [] -> acc + | (_id, None, _rhs) :: rem -> bind_inits rem acc + | (id, Some (loc, shape), _rhs) :: rem -> + Lambda.Llet + ( Strict, + Pgenval, + id, + Lprim (Pinit_mod, [loc; shape], Location.none), + bind_inits rem acc ) + in + let rec bind_strict args acc = + match args with + | [] -> acc + | (id, None, rhs) :: rem -> + Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) + | (_id, Some _, _rhs) :: rem -> bind_strict rem acc + in + let rec patch_forwards args = + match args with + | [] -> cont + | (_id, None, _rhs) :: rem -> patch_forwards rem + | (id, Some (_loc, shape), rhs) :: rem -> + Lsequence + ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none), + patch_forwards rem ) + in + bind_inits bindings (bind_strict bindings (patch_forwards bindings)) + +(* collect all function declarations + if the module creation is just a set of function declarations and consts, + it is good +*) +let rec is_function_or_const_block (lam : Lambda.lambda) acc = + match lam with + | Lprim (Pmakeblock _, args, _) -> + Ext_list.for_all args (fun x -> + match x with + | Lvar id -> Set_ident.mem acc id + | Lfunction _ | Lconst _ -> true + | _ -> false) + | Llet (_, _, id, Lfunction _, cont) -> + is_function_or_const_block cont (Set_ident.add acc id) + | Lletrec (bindings, cont) -> ( + let rec aux_bindings bindings acc = + match bindings with + | [] -> Some acc + | (id, Lambda.Lfunction _) :: rest -> + aux_bindings rest (Set_ident.add acc id) + | (_, _) :: _ -> None + in + match aux_bindings bindings acc with + | None -> false + | Some acc -> is_function_or_const_block cont acc) + | Llet (_, _, _, Lconst _, cont) -> is_function_or_const_block cont acc + | Llet (_, _, id1, Lvar id2, cont) when Set_ident.mem acc id2 -> + is_function_or_const_block cont (Set_ident.add acc id1) + | _ -> false + +let is_strict_or_all_functions (xs : binding list) = + Ext_list.for_all xs (fun (_, opt, rhs) -> + match opt with + | None -> true + | _ -> is_function_or_const_block rhs Set_ident.empty) + +(* Without such optimizations: + + {[ + module rec X : sig + val f : int -> int + end = struct + let f x = x + 1 + end + and Y : sig + val f : int -> int + end = struct + let f x = x + 2 + end + ]} + would generate such rawlambda: + + {[ + (setglobal Debug_tmp! + (let + (X/1002 = (#init_mod [0: "debug_tmp.ml" 15 6] [0: [0: [0: 0a "f"]]]) + Y/1003 = (#init_mod [0: "debug_tmp.ml" 20 6] [0: [0: [0: 0a "f"]]])) + (seq + (#update_mod [0: [0: [0: 0a "f"]]] X/1002 + (let (f/1010 = (function x/1011 (+ x/1011 1))) + (makeblock 0/[f] f/1010))) + (#update_mod [0: [0: [0: 0a "f"]]] Y/1003 + (let (f/1012 = (function x/1013 (+ x/1013 2))) + (makeblock 0/[f] f/1012))) + (makeblock 0/module/exports X/1002 Y/1003)))) + + ]} +*) +let eval_rec_bindings (bindings : binding list) (cont : t) : t = + if is_strict_or_all_functions bindings then + Lambda.Lletrec (Ext_list.map bindings (fun (id, _, rhs) -> (id, rhs)), cont) + else eval_rec_bindings_aux bindings cont + +let compile_recmodule compile_rhs bindings cont = + eval_rec_bindings + (reorder_rec_bindings + (List.map + (fun {mb_id = id; mb_expr = modl; mb_loc = loc; _} -> + (id, modl.mod_loc, init_shape modl, compile_rhs id modl loc)) + bindings)) + cont + +let report_error ppf = function + | Circular_dependency id -> + Format.fprintf ppf + "@[Cannot safely evaluate the definition@ of the recursively-defined \ + module %a@]" + Printtyp.ident id + +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) diff --git a/jscomp/ml/transl_recmodule.mli b/compiler/ml/transl_recmodule.mli similarity index 99% rename from jscomp/ml/transl_recmodule.mli rename to compiler/ml/transl_recmodule.mli index a94a418..8261108 100644 --- a/jscomp/ml/transl_recmodule.mli +++ b/compiler/ml/transl_recmodule.mli @@ -21,7 +21,6 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - val compile_recmodule : (Ident.t -> Typedtree.module_expr -> Location.t -> Lambda.lambda) -> Typedtree.module_binding list -> diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml new file mode 100644 index 0000000..ed63ecb --- /dev/null +++ b/compiler/ml/translattribute.ml @@ -0,0 +1,128 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2015 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 t = Parsetree.attribute + +let is_inline_attribute (attr : t) = + match attr with + | {txt = "inline"}, _ -> true + | _ -> false + +let is_inlined_attribute (attr : t) = + match attr with + | {txt = "inlined"}, _ -> true + | _ -> false + +let find_attribute p (attributes : t list) = + let inline_attribute, other_attributes = List.partition p attributes in + let attr = + match inline_attribute with + | [] -> None + | [attr] -> Some attr + | _ :: ({txt; loc}, _) :: _ -> + Location.prerr_warning loc (Warnings.Duplicated_attribute txt); + None + in + (attr, other_attributes) + +let parse_inline_attribute (attr : t option) : Lambda.inline_attribute = + match attr with + | None -> Default_inline + | Some ({txt; loc}, payload) -> ( + let open Parsetree in + (* the 'inline' and 'inlined' attributes can be used as + [@inline], [@inline never] or [@inline always]. + [@inline] is equivalent to [@inline always] *) + let warning txt = + Warnings.Attribute_payload + (txt, "It must be either empty, 'always' or 'never'") + in + match payload with + | PStr [] -> Always_inline + | PStr [{pstr_desc = Pstr_eval ({pexp_desc}, [])}] -> ( + match pexp_desc with + | Pexp_ident {txt = Longident.Lident "never"} -> Never_inline + | Pexp_ident {txt = Longident.Lident "always"} -> Always_inline + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline) + | _ -> + Location.prerr_warning loc (warning txt); + Default_inline) + +let get_inline_attribute l = + let attr, _ = find_attribute is_inline_attribute l in + parse_inline_attribute attr + +let rec add_inline_attribute (expr : Lambda.lambda) loc attributes = + match (expr, get_inline_attribute attributes) with + | expr, Default_inline -> expr + | Lfunction ({attr} as funct), inline -> + (match attr.inline with + | Default_inline -> () + | Always_inline | Never_inline -> + Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); + let attr = {attr with inline} in + Lfunction {funct with attr} + | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l), _ -> + Lambda.Lprim (p, [add_inline_attribute e loc attributes], l) + | expr, Always_inline -> + Location.prerr_warning loc (Warnings.Misplaced_attribute "inline1"); + expr + | expr, Never_inline -> + Location.prerr_warning loc (Warnings.Misplaced_attribute "inline2"); + expr + +(* Get the [@inlined] attribute payload (or default if not present). + It also returns the expression without this attribute. This is + used to ensure that this attribute is not misplaced: If it + appears on any expression, it is an error, otherwise it would + have been removed by this function *) +let get_and_remove_inlined_attribute (e : Typedtree.expression) = + let attr, exp_attributes = + find_attribute is_inlined_attribute e.exp_attributes + in + let inlined = parse_inline_attribute attr in + (inlined, {e with exp_attributes}) + +let get_and_remove_inlined_attribute_on_module (e : Typedtree.module_expr) = + let attr, mod_attributes = + find_attribute is_inlined_attribute e.mod_attributes + in + let inlined = parse_inline_attribute attr in + (inlined, {e with mod_attributes}) + +let check_attribute (e : Typedtree.expression) (({txt; loc}, _) : t) = + match txt with + | "inline" -> ( + match e.exp_desc with + | Texp_function _ -> () + | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) + | "inlined" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc (Warnings.Misplaced_attribute txt) + | _ -> () + +let check_attribute_on_module (e : Typedtree.module_expr) (({txt; loc}, _) : t) + = + match txt with + | "inline" -> ( + match e.mod_desc with + | Tmod_functor _ -> () + | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) + | "inlined" -> + (* Removed by the Texp_apply cases *) + Location.prerr_warning loc (Warnings.Misplaced_attribute txt) + | _ -> () diff --git a/jscomp/ml/translattribute.mli b/compiler/ml/translattribute.mli similarity index 100% rename from jscomp/ml/translattribute.mli rename to compiler/ml/translattribute.mli diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml new file mode 100644 index 0000000..078cbf1 --- /dev/null +++ b/compiler/ml/translcore.ml @@ -0,0 +1,1284 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the core language *) + +open Misc +open Asttypes +open Primitive +open Types +open Typedtree +open Typeopt +open Lambda + +type error = Unknown_builtin_primitive of string + +exception Error of Location.t * error + +(* Forward declaration -- to be filled in by Translmod.transl_module *) +let transl_module = + ref + (fun _cc _rootpath _modl -> assert false + : module_coercion -> Path.t option -> module_expr -> lambda) + +(* Compile an exception/extension definition *) + +let transl_extension_constructor env path ext = + let name = + match path (*!Clflags.for_package*) with + | None -> Ident.name ext.ext_id + | Some p -> Path.name p + in + let loc = ext.ext_loc in + match ext.ext_kind with + | Text_decl _ -> Lprim (Pcreate_extension name, [], loc) + | Text_rebind (path, _lid) -> transl_extension_path ~loc env path + +(* Translation of primitives *) + +(** This is ad-hoc translation for unifying specific primitive operations + See [Unified_ops] module for detailed explanation. + *) +let translate_unified_ops (prim : Primitive.description) (env : Env.t) + (lhs_type : type_expr) : Lambda.primitive option = + (* lhs_type is already unified in type-level *) + let entry = Hashtbl.find_opt Unified_ops.index_by_name prim.prim_name in + match entry with + | Some {specialization} -> ( + match specialization with + | {int} + when is_base_type env lhs_type Predef.path_int + || maybe_pointer_type env lhs_type = Immediate -> + Some int + | {float = Some float} when is_base_type env lhs_type Predef.path_float -> + Some float + | {bigint = Some bigint} when is_base_type env lhs_type Predef.path_bigint + -> + Some bigint + | {string = Some string} when is_base_type env lhs_type Predef.path_string + -> + Some string + | {bool = Some bool} when is_base_type env lhs_type Predef.path_bool -> + Some bool + | {int} -> Some int) + | _ -> None + +type specialized = { + objcomp: Lambda.primitive; + intcomp: Lambda.primitive; + boolcomp: Lambda.primitive; + floatcomp: Lambda.primitive; + stringcomp: Lambda.primitive; + bigintcomp: Lambda.primitive; + simplify_constant_constructor: bool; +} + +let comparisons_table = + create_hashtable + [| + ( "%equal", + { + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; + simplify_constant_constructor = true; + } ); + ( "%notequal", + { + objcomp = Pobjcomp Cneq; + intcomp = Pintcomp Cneq; + boolcomp = Pboolcomp Cneq; + floatcomp = Pfloatcomp Cneq; + stringcomp = Pstringcomp Cneq; + bigintcomp = Pbigintcomp Cneq; + simplify_constant_constructor = true; + } ); + ( "%lessthan", + { + objcomp = Pobjcomp Clt; + intcomp = Pintcomp Clt; + boolcomp = Pboolcomp Clt; + floatcomp = Pfloatcomp Clt; + stringcomp = Pstringcomp Clt; + bigintcomp = Pbigintcomp Clt; + simplify_constant_constructor = false; + } ); + ( "%greaterthan", + { + objcomp = Pobjcomp Cgt; + intcomp = Pintcomp Cgt; + boolcomp = Pboolcomp Cgt; + floatcomp = Pfloatcomp Cgt; + stringcomp = Pstringcomp Cgt; + bigintcomp = Pbigintcomp Cgt; + simplify_constant_constructor = false; + } ); + ( "%lessequal", + { + objcomp = Pobjcomp Cle; + intcomp = Pintcomp Cle; + boolcomp = Pboolcomp Cle; + floatcomp = Pfloatcomp Cle; + stringcomp = Pstringcomp Cle; + bigintcomp = Pbigintcomp Cle; + simplify_constant_constructor = false; + } ); + ( "%greaterequal", + { + objcomp = Pobjcomp Cge; + intcomp = Pintcomp Cge; + boolcomp = Pboolcomp Cge; + floatcomp = Pfloatcomp Cge; + stringcomp = Pstringcomp Cge; + bigintcomp = Pbigintcomp Cge; + simplify_constant_constructor = false; + } ); + ( "%compare", + { + objcomp = Pobjorder; + intcomp = Pintorder; + boolcomp = Pboolorder; + floatcomp = Pfloatorder; + stringcomp = Pstringorder; + bigintcomp = Pbigintorder; + simplify_constant_constructor = false; + } ); + ( "%max", + { + objcomp = Pobjmax; + intcomp = Pintmax; + boolcomp = Pboolmax; + floatcomp = Pfloatmax; + stringcomp = Pstringmax; + bigintcomp = Pbigintmax; + simplify_constant_constructor = false; + } ); + ( "%min", + { + objcomp = Pobjmin; + intcomp = Pintmin; + boolcomp = Pboolmin; + floatcomp = Pfloatmin; + stringcomp = Pstringmin; + bigintcomp = Pbigintmin; + simplify_constant_constructor = false; + } ); + ( "%equal_null", + { + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; + simplify_constant_constructor = false; + } ); + ( "%equal_undefined", + { + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; + simplify_constant_constructor = false; + } ); + ( "%equal_nullable", + { + objcomp = Pobjcomp Ceq; + intcomp = Pintcomp Ceq; + boolcomp = Pboolcomp Ceq; + floatcomp = Pfloatcomp Ceq; + stringcomp = Pstringcomp Ceq; + bigintcomp = Pbigintcomp Ceq; + simplify_constant_constructor = false; + } ); + (* FIXME: Core compatibility *) + ( "%bs_min", + { + objcomp = Pobjmin; + intcomp = Pintmin; + boolcomp = Pboolmin; + floatcomp = Pfloatmin; + stringcomp = Pstringmin; + bigintcomp = Pbigintmin; + simplify_constant_constructor = false; + } ); + ( "%bs_max", + { + objcomp = Pobjmax; + intcomp = Pintmax; + boolcomp = Pboolmax; + floatcomp = Pfloatmax; + stringcomp = Pstringmax; + bigintcomp = Pbigintmax; + simplify_constant_constructor = false; + } ); + |] + +let primitives_table = + create_hashtable + [| + ("%identity", Pidentity); + ("%ignore", Pignore); + ("%revapply", Prevapply); + ("%apply", Pdirapply); + ("%loc_LOC", Ploc Loc_LOC); + ("%loc_FILE", Ploc Loc_FILE); + ("%loc_LINE", Ploc Loc_LINE); + ("%loc_POS", Ploc Loc_POS); + ("%loc_MODULE", Ploc Loc_MODULE); + (* BEGIN Triples for ref data type *) + ("%makeref", Pmakeblock Lambda.ref_tag_info); + ("%refset", Psetfield (0, Lambda.ref_field_set_info)); + ("%refget", Pfield (0, Lambda.ref_field_info)); + ("%incr", Poffsetref 1); + ("%decr", Poffsetref (-1)); + (* Finish Triples for ref data type *) + ("%field0", Pfield (0, Fld_tuple)); + ("%field1", Pfield (1, Fld_tuple)); + ("%obj_dup", Pduprecord); + ("%obj_tag", Pobjtag); + ("%obj_size", Pobjsize); + ("%obj_get_field", Parrayrefu); + ("%obj_set_field", Parraysetu); + ("%raise", Praise Raise_regular); + (* bool primitives *) + ("%sequand", Psequand); + ("%sequor", Psequor); + ("%boolnot", Pnot); + ("%boolorder", Pboolorder); + ("%boolmin", Pboolmin); + ("%boolmax", Pboolmax); + (* int primitives *) + ("%obj_is_int", Pisint); + ("%negint", Pnegint); + ("%succint", Poffsetint 1); + ("%predint", Poffsetint (-1)); + ("%addint", Paddint); + ("%subint", Psubint); + ("%mulint", Pmulint); + ("%divint", Pdivint); + ("%modint", Pmodint); + ("%bitnot_int", Pnotint); + ("%andint", Pandint); + ("%orint", Porint); + ("%xorint", Pxorint); + ("%lslint", Plslint); + ("%lsrint", Plsrint); + ("%asrint", Pasrint); + ("%eq", Pintcomp Ceq); + ("%noteq", Pintcomp Cneq); + ("%ltint", Pintcomp Clt); + ("%leint", Pintcomp Cle); + ("%gtint", Pintcomp Cgt); + ("%geint", Pintcomp Cge); + ("%intorder", Pintorder); + ("%intmin", Pintmin); + ("%intmax", Pintmax); + (* float primitives *) + ("%negfloat", Pnegfloat); + ("%absfloat", Pabsfloat); + ("%addfloat", Paddfloat); + ("%subfloat", Psubfloat); + ("%mulfloat", Pmulfloat); + ("%divfloat", Pdivfloat); + ("%modfloat", Pmodfloat); + ("%eqfloat", Pfloatcomp Ceq); + ("%noteqfloat", Pfloatcomp Cneq); + ("%ltfloat", Pfloatcomp Clt); + ("%lefloat", Pfloatcomp Cle); + ("%gtfloat", Pfloatcomp Cgt); + ("%gefloat", Pfloatcomp Cge); + ("%floatorder", Pfloatorder); + ("%floatmin", Pfloatmin); + ("%floatmax", Pfloatmax); + (* bigint primitives *) + ("%negbigint", Pnegbigint); + ("%addbigint", Paddbigint); + ("%subbigint", Psubbigint); + ("%mulbigint", Pmulbigint); + ("%divbigint", Pdivbigint); + ("%powbigint", Ppowbigint); + ("%modbigint", Pmodbigint); + ("%eqbigint", Pbigintcomp Ceq); + ("%noteqbigint", Pbigintcomp Cneq); + ("%ltbigint", Pbigintcomp Clt); + ("%lebigint", Pbigintcomp Cle); + ("%gtbigint", Pbigintcomp Cgt); + ("%gebigint", Pbigintcomp Cge); + ("%bitnot_bigint", Pnotbigint); + ("%andbigint", Pandbigint); + ("%orbigint", Porbigint); + ("%xorbigint", Pxorbigint); + ("%lslbigint", Plslbigint); + ("%asrbigint", Pasrbigint); + ("%bigintorder", Pbigintorder); + ("%bigintmin", Pbigintmin); + ("%bigintmax", Pbigintmax); + (* string primitives *) + ("%string_length", Pstringlength); + ("%string_safe_get", Pstringrefs); + ("%string_unsafe_get", Pstringrefu); + ("%stringorder", Pstringorder); + ("%stringmin", Pstringmin); + ("%stringmax", Pstringmax); + ("%string_concat", Pstringadd); + (* array primitives *) + ("%array_length", Parraylength); + ("%array_safe_get", Parrayrefs); + ("%array_safe_set", Parraysets); + ("%array_unsafe_get", Parrayrefu); + ("%array_unsafe_set", Parraysetu); + (* dict primitives *) + ("%makedict", Pmakedict); + ("%dict_has", Pdict_has); + (* promise *) + ("%await", Pawait); + (* module *) + ("%import", Pimport); + (* hash *) + ("%hash", Phash); + ("%hash_mix_int", Phash_mixint); + ("%hash_mix_string", Phash_mixstring); + ("%hash_final_mix", Phash_finalmix); + (* etc *) + ("%typeof", Ptypeof); + ("%debugger", Pdebugger); + ("%intoffloat", Pintoffloat); + ("%floatofint", Pfloatofint); + ("%unsafe_eq", Pjscomp Ceq); + ("%unsafe_neq", Pjscomp Cneq); + ("%unsafe_lt", Pjscomp Clt); + ("%unsafe_le", Pjscomp Cle); + ("%unsafe_gt", Pjscomp Cgt); + ("%unsafe_ge", Pjscomp Cge); + ("%null", Pnull); + ("%undefined", Pundefined); + ("%is_nullable", Pisnullable); + ("%null_to_opt", Pnull_to_opt); + ("%nullable_to_opt", Pnullable_to_opt); + ("%function_arity", Pfn_arity); + ("%wrap_exn", Pwrap_exn); + ("%curry_apply1", Pcurry_apply 1); + ("%curry_apply2", Pcurry_apply 2); + ("%curry_apply3", Pcurry_apply 3); + ("%curry_apply4", Pcurry_apply 4); + ("%curry_apply5", Pcurry_apply 5); + ("%curry_apply6", Pcurry_apply 6); + ("%curry_apply7", Pcurry_apply 7); + ("%curry_apply8", Pcurry_apply 8); + ("%makemutablelist", Pmakelist Mutable); + ("%unsafe_to_method", Pjs_fn_method); + (* Compiler internals, never expose to ReScript files *) + ("#raw_expr", Pjs_raw_expr); + ("#raw_stmt", Pjs_raw_stmt); + (* FIXME: Core compatibility *) + ("#null", Pnull); + ("#undefined", Pundefined); + ("#typeof", Ptypeof); + ("#is_nullable", Pisnullable); + ("#null_to_opt", Pnull_to_opt); + ("#nullable_to_opt", Pnullable_to_opt); + ("#makemutablelist", Pmakelist Mutable); + ("#import", Pimport); + (* FIXME: Deprecated *) + ("%obj_field", Parrayrefu); + |] + +let find_primitive prim_name = Hashtbl.find primitives_table prim_name + +let specialize_comparison + ({objcomp; intcomp; floatcomp; stringcomp; bigintcomp; boolcomp} : + specialized) env ty = + match () with + | () + when is_base_type env ty Predef.path_int + || is_base_type env ty Predef.path_char + || maybe_pointer_type env ty = Immediate -> + intcomp + | () when is_base_type env ty Predef.path_float -> floatcomp + | () when is_base_type env ty Predef.path_string -> stringcomp + | () when is_base_type env ty Predef.path_bigint -> bigintcomp + | () when is_base_type env ty Predef.path_bool -> boolcomp + | () -> objcomp + +(* Specialize a primitive from available type information, + raise Not_found if primitive is unknown *) + +let specialize_primitive p env ty (* ~has_constant_constructor *) = + let fn_expr = is_function_type env ty in + let unified = + match fn_expr with + | Some (lhs, _) -> translate_unified_ops p env lhs + | None -> None + in + match unified with + | Some primitive -> primitive + | None -> ( + try + let table = Hashtbl.find comparisons_table p.prim_name in + match fn_expr with + | Some (lhs, _rhs) -> specialize_comparison table env lhs + | None -> table.objcomp + with Not_found -> find_primitive p.prim_name) + +(* Eta-expand a primitive *) + +let transl_primitive loc p env ty = + (* Printf.eprintf "----transl_primitive %s----\n" p.prim_name; *) + let prim = + try specialize_primitive p env ty (* ~has_constant_constructor:false *) + with Not_found -> Pccall p + in + match prim with + | Ploc kind -> ( + let lam = lam_of_loc kind loc in + match p.prim_arity with + | 0 -> lam + | 1 -> + (* TODO: we should issue a warning ? *) + let param = Ident.create "prim" in + Lfunction + { + params = [param]; + attr = default_function_attribute; + loc; + body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); + } + | _ -> assert false) + | _ -> + let rec make_params n total = + if n <= 0 then [] + else + Ident.create ("prim" ^ string_of_int (total - n)) + :: make_params (n - 1) total + in + let prim_arity = p.prim_arity in + if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) + else + let params = + if prim_arity = 1 then [Ident.create "prim"] + else make_params prim_arity prim_arity + in + Lfunction + { + params; + attr = default_function_attribute; + loc; + body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); + } + +let transl_primitive_application loc prim env ty args = + let prim_name = prim.prim_name in + let unified = + match args with + | [arg1] | [arg1; _] -> translate_unified_ops prim env arg1.exp_type + | _ -> None + in + match unified with + | Some primitive -> primitive + | None -> ( + try + match args with + | [arg1; _] + when is_base_type env arg1.exp_type Predef.path_bool + && Hashtbl.mem comparisons_table prim_name -> + (Hashtbl.find comparisons_table prim_name).boolcomp + | _ -> + let has_constant_constructor = + match args with + | [ + _; {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; + ] + | [ + {exp_desc = Texp_construct (_, {cstr_tag = Cstr_constant _}, _)}; _; + ] + | [_; {exp_desc = Texp_variant (_, None)}] + | [{exp_desc = Texp_variant (_, None)}; _] -> + true + | _ -> false + in + if has_constant_constructor then + match Hashtbl.find_opt comparisons_table prim_name with + | Some table when table.simplify_constant_constructor -> table.intcomp + | Some _ | None -> specialize_primitive prim env ty + (* ~has_constant_constructor*) + else specialize_primitive prim env ty + with Not_found -> + if String.length prim_name > 0 && prim_name.[0] = '%' then + raise (Error (loc, Unknown_builtin_primitive prim_name)); + Pccall prim) + +(* To propagate structured constants *) + +exception Not_constant + +let extract_constant = function + | Lconst sc -> sc + | _ -> raise_notrace Not_constant + +(* Push the default values under the functional abstractions *) +(* Also push bindings of module patterns, since this sound *) + +type binding = + | Bind_value of value_binding list + | Bind_module of Ident.t * string loc * module_expr + +let rec push_defaults loc bindings case partial = + match case with + | { + c_lhs = pat; + c_guard = None; + c_rhs = + {exp_desc = Texp_function {arg_label; arity; param; case; partial; async}} + as exp; + } -> + let case = push_defaults exp.exp_loc bindings case partial in + + { + c_lhs = pat; + c_guard = None; + c_rhs = + { + exp with + exp_desc = + Texp_function {arg_label; arity; param; case; partial; async}; + }; + } + | { + c_lhs = pat; + c_guard = None; + c_rhs = + { + exp_attributes = [({txt = "#default"}, _)]; + exp_desc = + Texp_let (Nonrecursive, binds, ({exp_desc = Texp_function _} as e2)); + }; + } -> + push_defaults loc + (Bind_value binds :: bindings) + {c_lhs = pat; c_guard = None; c_rhs = e2} + partial + | { + c_lhs = pat; + c_guard = None; + c_rhs = + { + exp_attributes = [({txt = "#modulepat"}, _)]; + exp_desc = + Texp_letmodule (id, name, mexpr, ({exp_desc = Texp_function _} as e2)); + }; + } -> + push_defaults loc + (Bind_module (id, name, mexpr) :: bindings) + {c_lhs = pat; c_guard = None; c_rhs = e2} + partial + | case -> + let exp = + List.fold_left + (fun exp binds -> + { + exp with + exp_desc = + (match binds with + | Bind_value binds -> Texp_let (Nonrecursive, binds, exp) + | Bind_module (id, name, mexpr) -> + Texp_letmodule (id, name, mexpr, exp)); + }) + case.c_rhs bindings + in + {case with c_rhs = exp} + +(* Assertions *) + +let assert_failed exp = + let fname, line, char = + Location.get_pos_info exp.exp_loc.Location.loc_start + in + let fname = Filename.basename fname in + Lprim + ( Praise Raise_regular, + [ + Lprim + ( Pmakeblock Blk_extension, + [ + transl_normal_path Predef.path_assert_failure; + Lconst + (Const_block + ( Blk_tuple, + [ + Const_base (Const_string (fname, None)); + Const_base (Const_int line); + Const_base (Const_int char); + ] )); + ], + exp.exp_loc ); + ], + exp.exp_loc ) + +let rec cut n l = + if n = 0 then ([], l) + else + match l with + | [] -> failwith "Translcore.cut" + | a :: l -> + let l1, l2 = cut (n - 1) l in + (a :: l1, l2) + +(* Translation of expressions *) + +let try_ids = Hashtbl.create 8 + +let extract_directive_for_fn exp = + exp.exp_attributes + |> List.find_map (fun ({txt}, payload) -> + if txt = "directive" then Ast_payload.is_single_string payload + else None) + +let rec transl_exp e = + List.iter (Translattribute.check_attribute e) e.exp_attributes; + transl_exp0 e + +and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = + match e.exp_desc with + | Texp_ident (_, _, {val_kind = Val_prim p}) -> + transl_primitive e.exp_loc p e.exp_env e.exp_type + | Texp_ident (path, _, {val_kind = Val_reg}) -> + transl_value_path ~loc:e.exp_loc e.exp_env path + | Texp_constant cst -> Lconst (Const_base cst) + | Texp_let (rec_flag, pat_expr_list, body) -> + transl_let rec_flag pat_expr_list (transl_exp body) + | Texp_function {arg_label = _; arity; param; case; partial; async} -> ( + let directive = + match extract_directive_for_fn e with + | None -> None + | Some (directive, _) -> Some directive + in + let params, body, return_unit = + let pl = push_defaults e.exp_loc [] case partial in + transl_function e.exp_loc partial param pl + in + let attr = + { + default_function_attribute with + inline = Translattribute.get_inline_attribute e.exp_attributes; + async; + return_unit; + directive; + } + in + let loc = e.exp_loc in + let lambda = Lfunction {params; body; attr; loc} in + match arity with + | Some arity -> + let prim = + let expanded = Ctype.expand_head e.exp_env e.exp_type in + match (Btype.repr expanded).desc with + | Tarrow ({lbl = Nolabel; typ}, _, _, _) -> ( + match (Ctype.expand_head e.exp_env typ).desc with + | Tconstr (Pident {name = "unit"}, [], _) -> Pjs_fn_make_unit + | _ -> Pjs_fn_make arity) + | _ -> Pjs_fn_make arity + in + Lprim + ( prim (* could be replaced with Opaque in the future except arity 0*), + [lambda], + loc ) + | None -> lambda) + | Texp_apply + { + funct = + { + exp_desc = Texp_ident (_, _, {val_kind = Val_prim p}); + exp_type = prim_type; + } as funct; + args = oargs; + transformed_jsx; + } + when List.length oargs >= p.prim_arity + && List.for_all (fun (_, arg) -> arg <> None) oargs -> ( + let args, args' = cut p.prim_arity oargs in + let wrap f = + if args' = [] then f + else + let inlined, _ = + Translattribute.get_and_remove_inlined_attribute funct + in + transl_apply ~inlined ~transformed_jsx f args' e.exp_loc + in + let args = + List.map + (function + | _, Some x -> x + | _ -> assert false) + args + in + let argl = transl_list args in + let prim = + transl_primitive_application e.exp_loc p e.exp_env prim_type args + in + match (prim, args) with + | Praise k, [_] -> + let targ = List.hd argl in + let k = + match (k, targ) with + | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> Raise_reraise + | _ -> k + in + wrap (Lprim (Praise k, [targ], e.exp_loc)) + | Ploc kind, [] -> lam_of_loc kind e.exp_loc + | Ploc kind, [arg1] -> + let lam = lam_of_loc kind arg1.exp_loc in + Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) + | Ploc _, _ -> assert false + | _, _ -> ( + match (prim, argl) with + | Pccall d, _ -> + wrap + (Lprim + (Pccall (set_transformed_jsx d ~transformed_jsx), argl, e.exp_loc)) + | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) + | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> + let inlined, funct = + Translattribute.get_and_remove_inlined_attribute funct + in + let uncurried_partial_application = + (* In case of partial application foo(args, ...) when some args are missing, + get the arity *) + if partial then + let arity_opt = Ctype.get_arity funct.exp_env funct.exp_type in + match arity_opt with + | Some arity -> + let real_args = List.filter (fun (_, x) -> Option.is_some x) oargs in + if arity > List.length real_args then Some arity else None + | None -> None + else None + in + transl_apply ~inlined ~uncurried_partial_application ~transformed_jsx + (transl_exp funct) oargs e.exp_loc + | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) -> + transl_match e arg pat_expr_list exn_pat_expr_list partial + | Texp_try (body, pat_expr_list) -> + let id = Typecore.name_pattern "exn" pat_expr_list in + Ltrywith + ( transl_exp body, + id, + Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list) ) + | Texp_tuple el -> ( + let ll = transl_list el in + try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) + with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) + | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false + | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true + | Texp_construct (lid, cstr, args) -> ( + let ll = transl_list args in + if cstr.cstr_inlined <> None then + match ll with + | [x] -> x + | _ -> assert false + else + match cstr.cstr_tag with + | Cstr_constant n -> + Lconst + (Const_pointer + ( n, + match lid.txt with + | Longident.Ldot (Longident.Lident "*predef*", "None") + | Longident.Lident "None" + when Datarepr.constructor_has_optional_shape cstr -> + Pt_shape_none + | _ -> + if Datarepr.constructor_has_optional_shape cstr then + Pt_shape_none + else + Pt_constructor + { + name = cstr.cstr_name; + const = cstr.cstr_consts; + non_const = cstr.cstr_nonconsts; + attrs = cstr.cstr_attributes; + } )) + | Cstr_unboxed -> ( + match ll with + | [v] -> v + | _ -> assert false) + | Cstr_block n -> ( + let tag_info : Lambda.tag_info = + if Datarepr.constructor_has_optional_shape cstr then + match args with + | [arg] + when Typeopt.type_cannot_contain_undefined arg.exp_type + arg.exp_env -> + (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) + Blk_some_not_nested + | _ -> Blk_some + else + Blk_constructor + { + name = cstr.cstr_name; + num_nonconst = cstr.cstr_nonconsts; + tag = n; + attrs = cstr.cstr_attributes; + } + in + try Lconst (Const_block (tag_info, List.map extract_constant ll)) + with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) + | Cstr_extension path -> + Lprim + ( Pmakeblock Blk_extension, + transl_extension_path e.exp_env path :: ll, + e.exp_loc )) + | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path + | Texp_variant (l, arg) -> ( + let tag = Btype.hash_variant l in + match arg with + | None -> Lconst (Const_pointer (tag, Pt_variant {name = l})) + | Some arg -> ( + let lam = transl_exp arg in + let tag_info = Blk_poly_var l in + try + Lconst + (Const_block + (tag_info, [Const_base (Const_int tag); extract_constant lam])) + with Not_constant -> + Lprim + ( Pmakeblock tag_info, + [Lconst (Const_base (Const_int tag)); lam], + e.exp_loc ))) + | Texp_record {fields; representation; extended_expression} -> + transl_record e.exp_loc e.exp_env fields representation extended_expression + | Texp_field (arg, _, lbl) -> ( + let targ = transl_exp arg in + match lbl.lbl_repres with + | Record_float_unused -> assert false + | Record_regular -> + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) + | Record_inlined _ -> + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc) + | Record_unboxed _ -> targ + | Record_extension -> + Lprim + ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), + [targ], + e.exp_loc )) + | Texp_setfield (arg, _, lbl, newval) -> + let access = + match lbl.lbl_repres with + | Record_float_unused -> assert false + | Record_regular -> Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) + | Record_inlined _ -> + Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) + | Record_unboxed _ -> assert false + | Record_extension -> + Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) + in + Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc) + | Texp_array expr_list -> + let ll = transl_list expr_list in + Lprim (Pmakearray Mutable, ll, e.exp_loc) + | Texp_ifthenelse (cond, ifso, Some ifnot) -> + Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) + | Texp_ifthenelse (cond, ifso, None) -> + Lifthenelse (transl_exp cond, transl_exp ifso, lambda_unit) + | Texp_sequence (expr1, expr2) -> + Lsequence (transl_exp expr1, transl_exp expr2) + | Texp_while (cond, body) -> Lwhile (transl_exp cond, transl_exp body) + | Texp_for (param, _, low, high, dir, body) -> + Lfor (param, transl_exp low, transl_exp high, dir, transl_exp body) + | Texp_send (expr, Tmeth_name nm, _) -> + let obj = transl_exp expr in + Lsend (nm, obj, e.exp_loc) + | Texp_letmodule (id, _loc, modl, body) -> + let defining_expr = !transl_module Tcoerce_none None modl in + Llet (Strict, Pgenval, id, defining_expr, transl_exp body) + | Texp_letexception (cd, body) -> + Llet + ( Strict, + Pgenval, + cd.ext_id, + transl_extension_constructor e.exp_env None cd, + transl_exp body ) + | Texp_pack modl -> !transl_module Tcoerce_none None modl + | Texp_assert {exp_desc = Texp_construct (_, {cstr_name = "false"}, _)} -> + if !Clflags.no_assert_false then Lambda.lambda_assert_false + else assert_failed e + | Texp_assert cond -> + if !Clflags.noassert then lambda_unit + else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) + +and transl_list expr_list = List.map transl_exp expr_list + +and transl_guard guard rhs = + let expr = transl_exp rhs in + match guard with + | None -> expr + | Some cond -> Lifthenelse (transl_exp cond, expr, staticfail) + +and transl_case {c_lhs; c_guard; c_rhs} = (c_lhs, transl_guard c_guard c_rhs) + +and transl_cases cases = List.map transl_case cases + +and transl_case_try {c_lhs; c_guard; c_rhs} = + match c_lhs.pat_desc with + | Tpat_var (id, _) | Tpat_alias (_, id, _) -> + Hashtbl.replace try_ids id (); + Misc.try_finally + (fun () -> (c_lhs, transl_guard c_guard c_rhs)) + (fun () -> Hashtbl.remove try_ids id) + | _ -> (c_lhs, transl_guard c_guard c_rhs) + +and transl_cases_try cases = List.map transl_case_try cases + +and transl_apply ?(inlined = Default_inline) + ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs + loc = + let lapply ap_func ap_args = + Lapply + { + ap_loc = loc; + ap_func; + ap_args; + ap_inlined = inlined; + ap_transformed_jsx = transformed_jsx; + } + in + let rec build_apply lam args = function + | (None, optional) :: l -> + let defs = ref [] in + let protect name lam = + match lam with + | Lvar _ | Lconst _ -> lam + | _ -> + let id = Ident.create name in + defs := (id, lam) :: !defs; + Lvar id + in + let args, args' = + if List.for_all (fun (_, opt) -> opt) args then ([], args) + else (args, []) + in + let lam = if args = [] then lam else lapply lam (List.rev_map fst args) in + let handle = protect "func" lam + and l = List.map (fun (arg, opt) -> (may_map (protect "arg") arg, opt)) l + and id_arg = Ident.create "param" in + let body = + match build_apply handle ((Lvar id_arg, optional) :: args') l with + | Lfunction {params = ids; body = lam; attr; loc} -> + Lfunction {params = id_arg :: ids; body = lam; attr; loc} + | lam -> + Lfunction + { + params = [id_arg]; + body = lam; + attr = default_function_attribute; + loc; + } + in + List.fold_left + (fun body (id, lam) -> Llet (Strict, Pgenval, id, lam, body)) + body !defs + | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l + | [] -> lapply lam (List.rev_map fst args) + in + match uncurried_partial_application with + | Some arity -> + let extra_arity = arity - List.length sargs in + let none_ids = ref [] in + let args = + Ext_list.filter_map sargs (function + | _, Some e -> Some (transl_exp e) + | _, None -> + let id_arg = Ident.create "none" in + none_ids := id_arg :: !none_ids; + Some (Lvar id_arg)) + in + let extra_ids = + Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list + in + let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in + let ap_args = args @ extra_args in + let l0 = + Lapply + { + ap_func = lam; + ap_args; + ap_inlined = inlined; + ap_loc = loc; + ap_transformed_jsx = transformed_jsx; + } + in + Lfunction + { + params = List.rev_append !none_ids extra_ids; + body = l0; + attr = default_function_attribute; + loc; + } + | _ -> + (build_apply lam [] + (List.map + (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l)) + sargs) + : Lambda.lambda) + +and transl_function loc partial param case = + match case with + | { + c_lhs = pat; + c_guard = None; + c_rhs = + { + exp_desc = + Texp_function + { + arg_label = _; + arity = None; + param = param'; + case; + partial = partial'; + async; + }; + } as exp; + } + when Parmatch.inactive ~partial pat && not async -> + let params, body, return_unit = + transl_function exp.exp_loc partial' param' case + in + ( param :: params, + Matching.for_function loc None (Lvar param) [(pat, body)] partial, + return_unit ) + | {c_rhs = {exp_env; exp_type}; _} -> + ( [param], + Matching.for_function loc None (Lvar param) [transl_case case] partial, + is_base_type exp_env exp_type Predef.path_unit ) + +and transl_let rec_flag pat_expr_list body = + match rec_flag with + | Nonrecursive -> + let rec transl = function + | [] -> body + | {vb_pat = pat; vb_expr = expr; vb_attributes = attr; vb_loc} :: rem -> + let lam = transl_exp expr in + let lam = Translattribute.add_inline_attribute lam vb_loc attr in + Matching.for_let pat.pat_loc lam pat (transl rem) + in + transl pat_expr_list + | Recursive -> + let transl_case {vb_expr = expr; vb_attributes; vb_loc; vb_pat = pat} = + let id = + match pat.pat_desc with + | Tpat_var (id, _) -> id + | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> id + | _ -> assert false + (* Illegal_letrec_pat + Only variables are allowed as left-hand side of `let rec' + *) + in + let lam = transl_exp expr in + let lam = Translattribute.add_inline_attribute lam vb_loc vb_attributes in + (id, lam) + in + Lletrec (Ext_list.map pat_expr_list transl_case, body) + +and transl_record loc env fields repres opt_init_expr = + match (opt_init_expr, repres, fields) with + | None, Record_unboxed _, [|({lbl_name; lbl_loc}, Overridden (_, expr), _)|] + -> + (* ReScript uncurried encoding *) + let loc = lbl_loc in + let lambda = transl_exp expr in + if lbl_name.[0] = 'I' then + let arity_s = String.sub lbl_name 1 (String.length lbl_name - 1) in + let arity = Int32.of_string arity_s |> Int32.to_int in + Lprim + ( Pjs_fn_make arity, + (* could be replaced with Opaque in the future except arity 0*) + [lambda], + loc ) + else lambda + | _ -> ( + let size = Array.length fields in + let optional = + Ext_array.exists fields (fun (ld, _, _) -> ld.lbl_optional) + in + (* Determine if there are "enough" fields (only relevant if this is a + functional-style record update *) + let no_init = + match opt_init_expr with + | None -> true + | _ -> false + in + if + no_init || (size < 20 && not optional) + (* TODO: More strategies + 3 + 2 * List.length lbl_expr_list >= size (density) + *) + then + (* Allocate new record with given fields (and remaining fields + taken from init_expr if any *) + let init_id = Ident.create "init" in + let lv = + Array.mapi + (fun i (lbl, definition, _) -> + match definition with + | Kept _ -> + let access = + match repres with + | Record_float_unused -> assert false + | Record_regular -> Pfield (i, Lambda.fld_record lbl) + | Record_inlined _ -> Pfield (i, Lambda.fld_record_inline lbl) + | Record_unboxed _ -> assert false + | Record_extension -> + Pfield (i + 1, Lambda.fld_record_extension lbl) + in + Lprim (access, [Lvar init_id], loc) + | Overridden (_lid, expr) -> transl_exp expr) + fields + in + let ll = Array.to_list lv in + let mut = + if Array.exists (fun (lbl, _, _) -> lbl.lbl_mut = Mutable) fields then + Mutable + else Immutable + in + let lam = + try + if mut = Mutable then raise Not_constant; + let cl = List.map extract_constant ll in + match repres with + | Record_float_unused -> assert false + | Record_regular -> + Lconst (Const_block (Lambda.blk_record fields mut, cl)) + | Record_inlined {tag; name; num_nonconsts; attrs} -> + Lconst + (Const_block + ( Lambda.blk_record_inlined fields name num_nonconsts ~tag + ~attrs mut, + cl )) + | Record_unboxed _ -> + Lconst + (match cl with + | [v] -> v + | _ -> assert false) + | Record_extension -> raise Not_constant + with Not_constant -> ( + match repres with + | Record_regular -> + Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) + | Record_float_unused -> assert false + | Record_inlined {tag; name; num_nonconsts; attrs} -> + Lprim + ( Pmakeblock + (Lambda.blk_record_inlined fields name num_nonconsts ~tag + ~attrs mut), + ll, + loc ) + | Record_unboxed _ -> ( + match ll with + | [v] -> v + | _ -> assert false) + | Record_extension -> + let path = + let label, _, _ = fields.(0) in + match label.lbl_res.desc with + | Tconstr (p, _, _) -> p + | _ -> assert false + in + let slot = transl_extension_path env path in + Lprim + (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc)) + in + match opt_init_expr with + | None -> lam + | Some init_expr -> + Llet (Strict, Pgenval, init_id, transl_exp init_expr, lam) + else + (* Take a shallow copy of the init record, then mutate the fields + of the copy *) + let copy_id = Ident.create "newrecord" in + let update_field cont (lbl, definition, _opt) = + match definition with + | Kept _type -> cont + | Overridden (_lid, expr) -> + let upd = + match repres with + | Record_float_unused -> assert false + | Record_regular -> + Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) + | Record_inlined _ -> + Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) + | Record_unboxed _ -> assert false + | Record_extension -> + Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) + in + Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc), cont) + in + match opt_init_expr with + | None -> assert false + | Some init_expr -> + Llet + ( Strict, + Pgenval, + copy_id, + Lprim (Pduprecord, [transl_exp init_expr], loc), + Array.fold_left update_field (Lvar copy_id) fields )) + +and transl_match e arg pat_expr_list exn_pat_expr_list partial = + let id = Typecore.name_pattern "exn" exn_pat_expr_list + and cases = transl_cases pat_expr_list + and exn_cases = transl_cases_try exn_pat_expr_list in + let static_catch body val_ids handler = + let static_exception_id = next_negative_raise_count () in + Lstaticcatch + ( Ltrywith + ( Lstaticraise (static_exception_id, body), + id, + Matching.for_trywith (Lvar id) exn_cases ), + (static_exception_id, val_ids), + handler ) + in + match (arg, exn_cases) with + | {exp_desc = Texp_tuple argl}, [] -> + Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial + | {exp_desc = Texp_tuple argl}, _ :: _ -> + let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in + let lvars = List.map (fun id -> Lvar id) val_ids in + static_catch (transl_list argl) val_ids + (Matching.for_multiple_match e.exp_loc lvars cases partial) + | arg, [] -> + Matching.for_function e.exp_loc None (transl_exp arg) cases partial + | arg, _ :: _ -> + let val_id = Typecore.name_pattern "val" pat_expr_list in + static_catch + [transl_exp arg] + [val_id] + (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) + +open Format + +let report_error ppf = function + | Unknown_builtin_primitive prim_name -> + fprintf ppf "Unknown builtin primitive \"%s\"" prim_name + +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) diff --git a/jscomp/ml/translcore.mli b/compiler/ml/translcore.mli similarity index 99% rename from jscomp/ml/translcore.mli rename to compiler/ml/translcore.mli index eaf38f2..1847a48 100644 --- a/jscomp/ml/translcore.mli +++ b/compiler/ml/translcore.mli @@ -16,7 +16,6 @@ (* Translation from typed abstract syntax to lambda terms, for the core language *) - val transl_exp : Typedtree.expression -> Lambda.lambda val transl_let : diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml new file mode 100644 index 0000000..87471ac --- /dev/null +++ b/compiler/ml/translmod.ml @@ -0,0 +1,494 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Translation from typed abstract syntax to lambda terms, + for the module language *) + +open Typedtree + +type error = Fragile_pattern_in_toplevel + +exception Error of Location.t * error + +(* Keep track of the root path (from the root of the namespace to the + currently compiled module expression). Useful for naming extensions. *) + +let global_path glob : Path.t option = Some (Pident glob) + +let is_top (rootpath : Path.t option) = + match rootpath with + | Some (Pident _) -> true + | _ -> false + +let functor_path path param : Path.t option = + match path with + | None -> None + | Some p -> Some (Papply (p, Pident param)) + +let field_path path field : Path.t option = + match path with + | None -> None + | Some p -> Some (Pdot (p, Ident.name field, Path.nopos)) + +(* Compile type extensions *) + +let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : + Lambda.lambda = + List.fold_right + (fun ext body -> + let lam = + Translcore.transl_extension_constructor env + (field_path rootpath ext.ext_id) + ext + in + Lambda.Llet (Strict, Pgenval, ext.ext_id, lam, body)) + tyext.tyext_constructors body + +(* Compile a coercion *) + +let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = + match restr with + | Tcoerce_none -> arg + | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> + Lambda.name_lambda strict arg (fun id -> + let get_field_name name pos = + Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc) + in + let lam = + Lambda.Lprim + ( Pmakeblock (Blk_module runtime_fields), + Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> + apply_coercion loc Alias cc + (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc))), + loc ) + in + wrap_id_pos_list loc id_pos_list get_field_name lam) + | Tcoerce_functor (cc_arg, cc_res) -> + let param = Ident.create "funarg" in + let carg = apply_coercion loc Alias cc_arg (Lvar param) in + apply_coercion_result loc strict arg param carg cc_res + | Tcoerce_primitive {pc_loc; pc_desc; pc_env; pc_type} -> + Translcore.transl_primitive pc_loc pc_desc pc_env pc_type + | Tcoerce_alias (path, cc) -> + Lambda.name_lambda strict arg (fun _ -> + apply_coercion loc Alias cc (Lambda.transl_normal_path path)) + +and apply_coercion_result loc strict funct param arg cc_res = + Lambda.name_lambda strict funct (fun id -> + Lfunction + { + params = [param]; + attr = {Lambda.default_function_attribute with is_a_functor = true}; + loc; + body = + apply_coercion loc Strict cc_res + (Lapply + { + ap_loc = loc; + ap_func = Lvar id; + ap_args = [arg]; + ap_inlined = Default_inline; + ap_transformed_jsx = false; + }); + }) + +and wrap_id_pos_list loc id_pos_list get_field lam = + let fv = Lambda.free_variables lam in + (*Format.eprintf "%a@." Printlambda.lambda lam; + IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; + Format.eprintf "@.";*) + let lam, s = + List.fold_left + (fun (lam, s) (id', pos, c) -> + if Lambda.IdentSet.mem id' fv then + let id'' = Ident.create (Ident.name id') in + ( Lambda.Llet + ( Alias, + Pgenval, + id'', + apply_coercion loc Alias c (get_field (Ident.name id') pos), + lam ), + Ident.add id' (Lambda.Lvar id'') s ) + else (lam, s)) + (lam, Ident.empty) id_pos_list + in + if s == Ident.empty then lam else Lambda.subst_lambda s lam + +(* Compose two coercions + apply_coercion c1 (apply_coercion c2 e) behaves like + apply_coercion (compose_coercions c1 c2) e. *) + +let rec compose_coercions c1 c2 = + match (c1, c2) with + | Tcoerce_none, c2 -> c2 + | c1, Tcoerce_none -> c1 + | ( Tcoerce_structure (pc1, ids1, runtime_fields1), + Tcoerce_structure (pc2, ids2, _runtime_fields2) ) -> + let v2 = Array.of_list pc2 in + let ids1 = + List.map + (fun (id, pos1, c1) -> + let pos2, c2 = v2.(pos1) in + (id, pos2, compose_coercions c1 c2)) + ids1 + in + Tcoerce_structure + ( List.map + (function + | (_p1, Tcoerce_primitive _) as x -> + x (* (p1, Tcoerce_primitive p) *) + | p1, c1 -> + let p2, c2 = v2.(p1) in + (p2, compose_coercions c1 c2)) + pc1, + ids1 @ ids2, + runtime_fields1 ) + | Tcoerce_functor (arg1, res1), Tcoerce_functor (arg2, res2) -> + Tcoerce_functor (compose_coercions arg2 arg1, compose_coercions res1 res2) + | c1, Tcoerce_alias (path, c2) -> Tcoerce_alias (path, compose_coercions c1 c2) + | _, _ -> Misc.fatal_error "Translmod.compose_coercions" + +(* +let apply_coercion a b c = + Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; + apply_coercion a b c + +let compose_coercions c1 c2 = + let c3 = compose_coercions c1 c2 in + let open Includemod in + Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." + print_coercion c1 print_coercion c2 print_coercion c3; + c3 +*) + +(* Record the primitive declarations occurring in the module compiled *) + +let rec pure_module m : Lambda.let_kind = + match m.mod_desc with + | Tmod_ident _ -> Alias + | Tmod_constraint (m, _, _, _) -> pure_module m + | _ -> Strict + +(* Generate lambda-code for a reordered list of bindings *) + +(* Extract the list of "value" identifiers bound by a signature. + "Value" identifiers are identifiers for signature components that + correspond to a run-time value: values, extensions, modules, classes. + Note: manifest primitives do not correspond to a run-time value! *) + +let rec bound_value_identifiers : Types.signature_item list -> Ident.t list = + function + | [] -> [] + | Sig_value (id, {val_kind = Val_reg}) :: rem -> + id :: bound_value_identifiers rem + | Sig_typext (id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_module (id, _, _) :: rem -> id :: bound_value_identifiers rem + | Sig_class _ :: _ -> assert false + | _ :: rem -> bound_value_identifiers rem + +(* Compile one or more functors, merging curried functors to produce + multi-argument functors. Any [@inline] attribute on a functor that is + merged must be consistent with any other [@inline] attribute(s) on the + functor(s) being merged with. Such an attribute will be placed on the + resulting merged functor. *) + +let get_functor_params mexp coercion root_path = + match mexp.mod_desc with + | Tmod_functor (param, _, _, body) -> + let inline_attribute = + Translattribute.get_inline_attribute mexp.mod_attributes + in + let arg_coercion, res_coercion = + match coercion with + | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) + | Tcoerce_functor (arg_coercion, res_coercion) -> + (arg_coercion, res_coercion) + | _ -> Misc.fatal_error "Translmod.get_functor_params: bad coercion" + in + let loc = mexp.mod_loc in + let path = functor_path root_path param in + ((param, loc, arg_coercion), body, path, res_coercion, inline_attribute) + | _ -> assert false + +let export_identifiers : Ident.t list ref = ref [] + +let rec compile_functor mexp coercion root_path loc = + let functor_param, body, body_path, res_coercion, inline_attribute = + get_functor_params mexp coercion root_path + in + (* cf. [transl_module] *) + let param, loc_, arg_coercion = functor_param in + let param' = Ident.rename param in + let arg = apply_coercion loc_ Alias arg_coercion (Lvar param') in + let body = + Lambda.Llet + (Alias, Pgenval, param, arg, transl_module res_coercion body_path body) + in + Lambda.Lfunction + { + params = [param']; + attr = + { + inline = inline_attribute; + is_a_functor = true; + return_unit = false; + async = false; + one_unit_arg = false; + directive = None; + }; + loc; + body; + } + +(* Compile a module expression *) +and transl_module cc rootpath mexp = + List.iter (Translattribute.check_attribute_on_module mexp) mexp.mod_attributes; + let loc = mexp.mod_loc in + match mexp.mod_type with + | Mty_alias (Mta_absent, _) -> + apply_coercion loc Alias cc Lambda.lambda_module_alias + | _ -> ( + match mexp.mod_desc with + | Tmod_ident (path, _) -> + apply_coercion loc Strict cc + (Lambda.transl_module_path ~loc mexp.mod_env path) + | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str) + | Tmod_functor _ -> compile_functor mexp cc rootpath loc + | Tmod_apply (funct, arg, ccarg) -> + let inlined_attribute, funct = + Translattribute.get_and_remove_inlined_attribute_on_module funct + in + apply_coercion loc Strict cc + (Lapply + { + ap_loc = loc; + ap_func = transl_module Tcoerce_none None funct; + ap_args = [transl_module ccarg None arg]; + ap_inlined = inlined_attribute; + ap_transformed_jsx = false; + }) + | Tmod_constraint (arg, _, _, ccarg) -> + transl_module (compose_coercions cc ccarg) rootpath arg + | Tmod_unpack (arg, _) -> + apply_coercion loc Strict cc (Translcore.transl_exp arg)) + +and transl_struct loc fields cc rootpath str = + transl_structure loc fields cc rootpath str.str_final_env str.str_items + +and transl_structure loc fields cc rootpath final_env = function + | [] -> ( + let is_top_root_path = is_top rootpath in + + match cc with + | Tcoerce_none -> + let block_fields = + List.fold_left + (fun acc id -> + if is_top_root_path then + export_identifiers := id :: !export_identifiers; + Lambda.Lvar id :: acc) + [] fields + in + ( Lambda.Lprim + ( Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), + block_fields, + loc ), + List.length fields ) + | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> + (* Do not ignore id_pos_list ! *) + (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; + List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) + fields; + Format.eprintf "@]@.";*) + assert (List.length runtime_fields = List.length pos_cc_list); + let v = Ext_array.reverse_of_list fields in + let get_field pos = Lambda.Lvar v.(pos) + and ids = + List.fold_right Lambda.IdentSet.add fields Lambda.IdentSet.empty + in + let get_field_name _name = get_field in + let result = + List.fold_right + (fun (pos, cc) code -> + match cc with + | Tcoerce_primitive p -> + if is_top rootpath then + export_identifiers := p.pc_id :: !export_identifiers; + Translcore.transl_primitive p.pc_loc p.pc_desc p.pc_env p.pc_type + :: code + | _ -> + if is_top rootpath then + export_identifiers := v.(pos) :: !export_identifiers; + apply_coercion loc Strict cc (get_field pos) :: code) + pos_cc_list [] + in + let lam = + Lambda.Lprim + ( Pmakeblock + (if is_top_root_path then Blk_module_export !export_identifiers + else Blk_module runtime_fields), + result, + loc ) + and id_pos_list = + Ext_list.filter id_pos_list (fun (id, _, _) -> + not (Lambda.IdentSet.mem id ids)) + in + ( wrap_id_pos_list loc id_pos_list get_field_name lam, + List.length pos_cc_list ) + | _ -> Misc.fatal_error "Translmod.transl_structure") + | item :: rem -> ( + match item.str_desc with + | Tstr_eval (expr, _) -> + let body, size = transl_structure loc fields cc rootpath final_env rem in + (Lsequence (Translcore.transl_exp expr, body), size) + | Tstr_value (rec_flag, pat_expr_list) -> + let ext_fields = rev_let_bound_idents pat_expr_list @ fields in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + (* Recursve already excludes complex pattern bindings*) + if is_top rootpath && rec_flag = Nonrecursive then + Ext_list.iter pat_expr_list (fun {vb_pat} -> + match vb_pat.pat_desc with + | Tpat_var _ | Tpat_alias _ -> () + | _ -> + if not (Parmatch.irrefutable vb_pat) then + raise (Error (vb_pat.pat_loc, Fragile_pattern_in_toplevel))); + (Translcore.transl_let rec_flag pat_expr_list body, size) + | Tstr_typext tyext -> + let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let body, size = + transl_structure loc + (List.rev_append ids fields) + cc rootpath final_env rem + in + (transl_type_extension item.str_env rootpath tyext body, size) + | Tstr_exception ext -> + let id = ext.ext_id in + let path = field_path rootpath id in + let body, size = + transl_structure loc (id :: fields) cc rootpath final_env rem + in + ( Llet + ( Strict, + Pgenval, + id, + Translcore.transl_extension_constructor item.str_env path ext, + body ), + size ) + | Tstr_module mb as s -> + let id = mb.mb_id in + let body, size = + transl_structure loc + (if Typemod.rescript_hide s then fields else id :: fields) + cc rootpath final_env rem + in + let module_body = + transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr + in + let module_body = + Translattribute.add_inline_attribute module_body mb.mb_loc + mb.mb_attributes + in + (Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), size) + | Tstr_recmodule bindings -> + let ext_fields = + List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields + in + let body, size = + transl_structure loc ext_fields cc rootpath final_env rem + in + let lam = + Transl_recmodule.compile_recmodule + (fun id modl _loc -> + transl_module Tcoerce_none (field_path rootpath id) modl) + bindings body + in + (lam, size) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create "include" in + let rec rebind_idents pos newfields = function + | [] -> transl_structure loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = rebind_idents (pos + 1) (id :: newfields) ids in + ( Llet + ( Alias, + Pgenval, + id, + Lprim + ( Pfield (pos, Fld_module {name = Ident.name id}), + [Lvar mid], + incl.incl_loc ), + body ), + size ) + in + let body, size = rebind_idents 0 fields ids in + ( Llet + ( pure_module modl, + Pgenval, + mid, + transl_module Tcoerce_none None modl, + body ), + size ) + | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ | Tstr_open _ + | Tstr_attribute _ -> + transl_structure loc fields cc rootpath final_env rem) + +(* Update forward declaration in Translcore *) +let _ = Translcore.transl_module := transl_module + +(* Introduce dependencies on modules referenced only by "external". *) + +(* Compile an implementation *) + +let transl_implementation module_name (str, cc) = + export_identifiers := []; + let module_id = Ident.create_persistent module_name in + let body, _ = transl_struct Location.none [] cc (global_path module_id) str in + (body, !export_identifiers) + +(* Build the list of value identifiers defined by a toplevel structure + (excluding primitive declarations). *) + +(* second level idents (module M = struct ... let id = ... end), + and all sub-levels idents *) +(* A variant of transl_structure used to compile toplevel structure definitions + for the native-code compiler. Store the defined values in the fields + of the global as soon as they are defined, in order to reduce register + pressure. Also rewrites the defining expressions so that they + refer to earlier fields of the structure through the fields of + the global, not by their names. + "map" is a table from defined idents to (pos in global block, coercion). + "prim" is a list of (pos in global block, primitive declaration). *) + +(* Compile an implementation using transl_store_structure + (for the native-code compiler). *) + +(* Compile a toplevel phrase *) + +(* Error report *) + +let report_error ppf = function + | Fragile_pattern_in_toplevel -> + Format.fprintf ppf "@[Such fragile pattern not allowed in the toplevel@]" + +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) diff --git a/jscomp/ml/translmod.mli b/compiler/ml/translmod.mli similarity index 99% rename from jscomp/ml/translmod.mli rename to compiler/ml/translmod.mli index af45c84..74ef747 100644 --- a/jscomp/ml/translmod.mli +++ b/compiler/ml/translmod.mli @@ -25,6 +25,3 @@ type error (* exception Error of Location.t * error *) val report_error : Format.formatter -> error -> unit - - - diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml new file mode 100644 index 0000000..ee304df --- /dev/null +++ b/compiler/ml/typecore.ml @@ -0,0 +1,4802 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Typechecking for the core language *) + +open Misc +open Asttypes +open Parsetree +open Types +open Typedtree +open Btype +open Ctype +open Error_message_utils + +type error = + | Polymorphic_label of Longident.t + | Constructor_arity_mismatch of { + name: Longident.t; + constuctor: constructor_description; + expected: int; + provided: int; + } + | Label_mismatch of Longident.t * (type_expr * type_expr) list + | Pattern_type_clash of (type_expr * type_expr) list + | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of { + trace: (type_expr * type_expr) list; + context: type_clash_context option; + } + | Apply_non_function of type_expr + | Apply_wrong_label of arg_label * type_expr + | Label_multiply_defined of { + label: string; + jsx_component_info: jsx_prop_error_info option; + } + | Labels_missing of { + labels: string list; + jsx_component_info: jsx_prop_error_info option; + } + | Label_not_mutable of Longident.t + | Wrong_name of string * type_expr * string * Path.t * string * string list + | Name_type_mismatch of + string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list + | Undefined_method of type_expr * string * string list option + | Private_type of type_expr + | Private_label of Longident.t * type_expr + | Not_subtype of + Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option + | Too_many_arguments of bool * type_expr + | Abstract_wrong_label of arg_label * type_expr + | Scoping_let_module of string * type_expr + | Not_a_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * (type_expr * type_expr) list + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Recursive_local_constraint of (type_expr * type_expr) list + | Unexpected_existential + | Unqualified_gadt_pattern of Path.t * string + | Invalid_interval + | Invalid_for_loop_index + | No_value_clauses + | Exception_pattern_below_toplevel + | Inlined_record_escape + | Inlined_record_expected + | Invalid_extension_constructor_payload + | Not_an_extension_constructor + | Literal_overflow of string + | Unknown_literal of string * char + | Illegal_letrec_pat + | Empty_record_literal + | Uncurried_arity_mismatch of { + function_type: type_expr; + expected_arity: int; + provided_arity: int; + provided_args: Asttypes.arg_label list; + function_name: Longident.t option; + } + | Field_not_optional of string * type_expr + | Type_params_not_supported of Longident.t + | Field_access_on_dict_type + | Jsx_not_enabled + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +(* Forward declaration, to be filled in by Typemod.type_module *) + +let type_module = + ref + (fun _env _md -> assert false + : Env.t -> Parsetree.module_expr -> Typedtree.module_expr) + +(* Forward declaration, to be filled in by Typemod.type_open *) + +let type_open : + (?used_slot:bool ref -> + override_flag -> + Env.t -> + Location.t -> + Longident.t loc -> + Path.t * Env.t) + ref = + ref (fun ?used_slot:_ _ -> assert false) + +(* Forward declaration, to be filled in by Typemod.type_package *) + +let type_package = ref (fun _ -> assert false) + +(* Forward declaration, to be filled in by Typemod.type_package *) + +(* + Saving and outputting type information. + We keep these function names short, because they have to be + called each time we create a record of type [Typedtree.expression] + or [Typedtree.pattern] that will end up in the typed AST. +*) +let re node = + Cmt_format.add_saved_type (Cmt_format.Partial_expression node); + Stypes.record (Stypes.Ti_expr node); + node +let rp node = + Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); + Stypes.record (Stypes.Ti_pat node); + node + +type recarg = Allowed | Required | Rejected + +let case lhs rhs = {c_lhs = lhs; c_guard = None; c_rhs = rhs} + +(* Upper approximation of free identifiers on the parse tree *) + +let iter_expression f e = + let rec expr e = + f e; + match e.pexp_desc with + | Pexp_extension _ (* we don't iterate under extension point *) + | Pexp_ident _ | Pexp_constant _ -> + () + | Pexp_fun {default = eo; rhs = e} -> + may expr eo; + expr e + | Pexp_apply {funct = e; args = lel} -> + expr e; + List.iter (fun (_, e) -> expr e) lel + | Pexp_let (_, pel, e) -> + expr e; + List.iter binding pel + | Pexp_match (e, pel) | Pexp_try (e, pel) -> + expr e; + List.iter case pel + | Pexp_array el | Pexp_tuple el -> List.iter expr el + | Pexp_construct (_, eo) | Pexp_variant (_, eo) -> may expr eo + | Pexp_record (iel, eo) -> + may expr eo; + List.iter (fun {x = e} -> expr e) iel + | Pexp_open (_, _, e) + | Pexp_newtype (_, e) + | Pexp_assert e + | Pexp_send (e, _) + | Pexp_constraint (e, _) + | Pexp_coerce (e, _, _) + | Pexp_letexception (_, e) + | Pexp_field (e, _) -> + expr e + | Pexp_while (e1, e2) | Pexp_sequence (e1, e2) | Pexp_setfield (e1, _, e2) + -> + expr e1; + expr e2 + | Pexp_ifthenelse (e1, e2, eo) -> + expr e1; + expr e2; + may expr eo + | Pexp_for (_, e1, e2, _, e3) -> + expr e1; + expr e2; + expr e3 + | Pexp_letmodule (_, me, e) -> + expr e; + module_expr me + | Pexp_pack me -> module_expr me + | Pexp_await _ -> assert false (* should be handled earlier *) + | Pexp_jsx_element _ -> + raise (Error (e.pexp_loc, Env.empty, Jsx_not_enabled)) + and case {pc_lhs = _; pc_guard; pc_rhs} = + may expr pc_guard; + expr pc_rhs + and binding x = expr x.pvb_expr + and module_expr me = + match me.pmod_desc with + | Pmod_extension _ | Pmod_ident _ -> () + | Pmod_structure str -> List.iter structure_item str + | Pmod_constraint (me, _) | Pmod_functor (_, _, me) -> module_expr me + | Pmod_apply (me1, me2) -> + module_expr me1; + module_expr me2 + | Pmod_unpack e -> expr e + and structure_item str = + match str.pstr_desc with + | Pstr_eval (e, _) -> expr e + | Pstr_value (_, pel) -> List.iter binding pel + | Pstr_primitive _ | Pstr_type _ | Pstr_typext _ | Pstr_exception _ + | Pstr_modtype _ | Pstr_open _ | Pstr_attribute _ | Pstr_extension _ -> + () + | Pstr_include {pincl_mod = me} | Pstr_module {pmb_expr = me} -> + module_expr me + | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l + in + + expr e + +let all_idents_cases el = + let idents = Hashtbl.create 8 in + let f = function + | {pexp_desc = Pexp_ident {txt = Longident.Lident id; _}; _} -> + Hashtbl.replace idents id () + | _ -> () + in + List.iter + (fun cp -> + may (iter_expression f) cp.pc_guard; + iter_expression f cp.pc_rhs) + el; + Hashtbl.fold (fun x () rest -> x :: rest) idents [] + +(* Typing of constants *) + +let type_constant = function + | Const_int _ -> instance_def Predef.type_int + | Const_char _ -> instance_def Predef.type_char + | Const_string _ -> instance_def Predef.type_string + | Const_float _ -> instance_def Predef.type_float + | Const_int64 _ -> assert false + | Const_bigint _ -> instance_def Predef.type_bigint + | Const_int32 _ -> assert false + +let constant : Parsetree.constant -> (Asttypes.constant, error) result = + function + | Pconst_integer (i, None) -> ( + try Ok (Const_int (Misc.Int_literal_converter.int i)) + with Failure _ -> Error (Literal_overflow "int")) + | Pconst_integer (i, Some 'n') -> + let sign, i = Bigint_utils.parse_bigint i in + Ok (Const_bigint (sign, i)) + | Pconst_integer (i, Some c) -> Error (Unknown_literal (i, c)) + | Pconst_char c -> Ok (Const_char c) + | Pconst_string (s, d) -> Ok (Const_string (s, d)) + | Pconst_float (f, None) -> Ok (Const_float f) + | Pconst_float (f, Some c) -> Error (Unknown_literal (f, c)) + +let constant_or_raise env loc cst = + match constant cst with + | Ok c -> c + | Error err -> raise (Error (loc, env, err)) + +(* Specific version of type_option, using newty rather than newgenty *) + +let type_option ty = newty (Tconstr (Predef.path_option, [ty], ref Mnil)) + +let mkexp exp_desc exp_type exp_loc exp_env = + {exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = []} + +let option_none ty loc = + let lid = Longident.Lident "None" and env = Env.initial_safe_string in + let cnone = Env.lookup_constructor lid env in + mkexp (Texp_construct (mknoloc lid, cnone, [])) ty loc env + +let option_some texp = + let lid = Longident.Lident "Some" in + let csome = Env.lookup_constructor lid Env.initial_safe_string in + mkexp + (Texp_construct (mknoloc lid, csome, [texp])) + (type_option texp.exp_type) + texp.exp_loc texp.exp_env + +let extract_option_type env ty = + match expand_head env ty with + | {desc = Tconstr (path, [ty], _)} when Path.same path Predef.path_option -> + ty + | _ -> assert false + +let extract_concrete_record env ty = + match extract_concrete_typedecl env ty with + | p0, p, {type_kind = Type_record (fields, repr)} -> (p0, p, fields, repr) + | _ -> raise Not_found + +let extract_concrete_variant env ty = + match extract_concrete_typedecl env ty with + | p0, p, {type_kind = Type_variant cstrs} -> (p0, p, cstrs) + | p0, p, {type_kind = Type_open} -> (p0, p, []) + | _ -> raise Not_found + +let label_is_optional ld = ld.lbl_optional + +let check_optional_attr env ld optional loc = + let check_redundant () = + if not (label_is_optional ld) then + raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); + true + in + optional && check_redundant () + +(* unification inside type_pat*) +let unify_pat_types loc env ty ty' = + try unify env ty ty' with + | Unify trace -> raise (Error (loc, env, Pattern_type_clash trace)) + | Tags (l1, l2) -> + raise (Typetexp.Error (loc, env, Typetexp.Variant_tags (l1, l2))) + +(* unification inside type_exp and type_expect *) +let unify_exp_types ~context loc env ty expected_ty = + try unify env ty expected_ty with + | Unify trace -> raise (Error (loc, env, Expr_type_clash {trace; context})) + | Tags (l1, l2) -> + raise (Typetexp.Error (loc, env, Typetexp.Variant_tags (l1, l2))) + +(* level at which to create the local type declarations *) +let newtype_level = ref None +let get_newtype_level () = + match !newtype_level with + | Some y -> y + | None -> assert false + +let unify_pat_types_gadt loc env ty ty' = + let newtype_level = + match !newtype_level with + | None -> assert false + | Some x -> x + in + try unify_gadt ~newtype_level env ty ty' with + | Unify trace -> raise (Error (loc, !env, Pattern_type_clash trace)) + | Tags (l1, l2) -> + raise (Typetexp.Error (loc, !env, Typetexp.Variant_tags (l1, l2))) + | Unification_recursive_abbrev trace -> + raise (Error (loc, !env, Recursive_local_constraint trace)) + +(* Creating new conjunctive types is not allowed when typing patterns *) + +let unify_pat env pat expected_ty = + unify_pat_types pat.pat_loc env pat.pat_type expected_ty + +(* make all Reither present in open variants *) +let finalize_variant pat = + match pat.pat_desc with + | Tpat_variant (tag, opat, r) -> ( + let row = + match expand_head pat.pat_env pat.pat_type with + | {desc = Tvariant row} -> + r := row; + row_repr row + | _ -> assert false + in + match row_field tag row with + | Rabsent -> () (* assert false *) + | Reither (true, [], _, e) when not row.row_closed -> + set_row_field e (Rpresent None) + | Reither (false, ty :: tl, _, e) when not row.row_closed -> ( + set_row_field e (Rpresent (Some ty)); + match opat with + | None -> assert false + | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty :: tl)) + | Reither (c, _l, true, e) when not (row_fixed row) -> + set_row_field e (Reither (c, [], false, ref None)) + | _ -> () + (* Force check of well-formedness WHY? *) + (* unify_pat pat.pat_env pat + (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; + row_bound=(); row_fixed=false; row_name=None})); *) + ) + | _ -> () + +let rec iter_pattern f p = + f p; + iter_pattern_desc (iter_pattern f) p.pat_desc + +let has_variants p = + try + iter_pattern + (function + | {pat_desc = Tpat_variant _} -> raise Exit + | _ -> ()) + p; + false + with Exit -> true + +(* pattern environment *) +let pattern_variables = + ref + ([] + : (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) + list) +let pattern_force = ref ([] : (unit -> unit) list) +let pattern_scope = ref (None : Annot.ident option) +let allow_modules = ref false +let module_variables = ref ([] : (string loc * Location.t) list) +let reset_pattern scope allow = + pattern_variables := []; + pattern_force := []; + pattern_scope := scope; + allow_modules := allow; + module_variables := [] + +let enter_variable ?(is_module = false) ?(is_as_variable = false) loc name ty = + if + List.exists + (fun (id, _, _, _, _) -> Ident.name id = name.txt) + !pattern_variables + then raise (Error (loc, Env.empty, Multiply_bound_variable name.txt)); + let id = Ident.create name.txt in + pattern_variables := (id, ty, name, loc, is_as_variable) :: !pattern_variables; + if is_module then ( + (* Note: unpack patterns enter a variable of the same name *) + if not !allow_modules then + raise (Error (loc, Env.empty, Modules_not_allowed)); + module_variables := (name, loc) :: !module_variables) + else + (* moved to genannot *) + may + (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) + !pattern_scope; + id + +let sort_pattern_variables vs = + List.sort + (fun (x, _, _, _, _) (y, _, _, _, _) -> + compare (Ident.name x) (Ident.name y)) + vs + +let enter_orpat_variables loc env p1_vs p2_vs = + (* unify_vars operate on sorted lists *) + let p1_vs = sort_pattern_variables p1_vs + and p2_vs = sort_pattern_variables p2_vs in + + let rec unify_vars p1_vs p2_vs = + let vars vs = List.map (fun (x, _t, _, _l, _a) -> x) vs in + match (p1_vs, p2_vs) with + | (x1, t1, _, _l1, _a1) :: rem1, (x2, t2, _, _l2, _a2) :: rem2 + when Ident.equal x1 x2 -> + if x1 == x2 then unify_vars rem1 rem2 + else ( + (try unify env t1 t2 + with Unify trace -> + raise (Error (loc, env, Or_pattern_type_clash (x1, trace)))); + (x2, x1) :: unify_vars rem1 rem2) + | [], [] -> [] + | (x, _, _, _, _) :: _, [] -> raise (Error (loc, env, Orpat_vars (x, []))) + | [], (y, _, _, _, _) :: _ -> raise (Error (loc, env, Orpat_vars (y, []))) + | (x, _, _, _, _) :: _, (y, _, _, _, _) :: _ -> + let err = + if Ident.name x < Ident.name y then Orpat_vars (x, vars p2_vs) + else Orpat_vars (y, vars p1_vs) + in + raise (Error (loc, env, err)) + in + unify_vars p1_vs p2_vs + +let rec build_as_type env p = + match p.pat_desc with + | Tpat_alias (p1, _, _) -> build_as_type env p1 + | Tpat_tuple pl -> + let tyl = List.map (build_as_type env) pl in + newty (Ttuple tyl) + | Tpat_construct (_, cstr, pl) -> + let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in + if keep then p.pat_type + else + let tyl = List.map (build_as_type env) pl in + let ty_args, ty_res = instance_constructor cstr in + List.iter2 + (fun (p, ty) -> unify_pat env {p with pat_type = ty}) + (List.combine pl tyl) ty_args; + ty_res + | Tpat_variant (l, p', _) -> + let ty = may_map (build_as_type env) p' in + newty + (Tvariant + { + row_fields = [(l, Rpresent ty)]; + row_more = newvar (); + row_name = None; + row_fixed = false; + row_closed = false; + }) + | Tpat_record (lpl, _) -> + let lbl = snd4 (List.hd lpl) in + if lbl.lbl_private = Private then p.pat_type + else + let ty = newvar () in + let ppl = List.map (fun (_, l, p, _) -> (l.lbl_pos, p)) lpl in + let do_label lbl = + let _, ty_arg, ty_res = instance_label false lbl in + unify_pat env {p with pat_type = ty} ty_res; + let refinable = + lbl.lbl_mut = Immutable + && List.mem_assoc lbl.lbl_pos ppl + && + match (repr lbl.lbl_arg).desc with + | Tpoly _ -> false + | _ -> true + in + if refinable then + let arg = List.assoc lbl.lbl_pos ppl in + unify_pat env {arg with pat_type = build_as_type env arg} ty_arg + else + let _, ty_arg', ty_res' = instance_label false lbl in + unify env ty_arg ty_arg'; + unify_pat env p ty_res' + in + Array.iter do_label lbl.lbl_all; + ty + | Tpat_or (p1, p2, row) -> ( + match row with + | None -> + let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in + unify_pat env {p2 with pat_type = ty2} ty1; + ty1 + | Some row -> + let row = row_repr row in + newty (Tvariant {row with row_closed = false; row_more = newvar ()})) + | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_array _ -> p.pat_type + +let build_or_pat env loc lid = + let path, decl = Typetexp.find_type env lid.loc lid.txt in + let tyl = List.map (fun _ -> newvar ()) decl.type_params in + let row0 = + let ty = expand_head env (newty (Tconstr (path, tyl, ref Mnil))) in + match ty.desc with + | Tvariant row when static_row row -> row + | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) + in + let pats, fields = + List.fold_left + (fun (pats, fields) (l, f) -> + match row_field_repr f with + | Rpresent None -> + ((l, None) :: pats, (l, Reither (true, [], true, ref None)) :: fields) + | Rpresent (Some ty) -> + ( ( l, + Some + { + pat_desc = Tpat_any; + pat_loc = Location.none; + pat_env = env; + pat_type = ty; + pat_extra = []; + pat_attributes = []; + } ) + :: pats, + (l, Reither (false, [ty], true, ref None)) :: fields ) + | _ -> (pats, fields)) + ([], []) (row_repr row0).row_fields + in + let row = + { + row_fields = List.rev fields; + row_more = newvar (); + row_closed = false; + row_fixed = false; + row_name = Some (path, tyl); + } + in + let ty = newty (Tvariant row) in + let gloc = {loc with Location.loc_ghost = true} in + let row' = ref {row with row_more = newvar ()} in + let pats = + List.map + (fun (l, p) -> + { + pat_desc = Tpat_variant (l, p, row'); + pat_loc = gloc; + pat_env = env; + pat_type = ty; + pat_extra = []; + pat_attributes = []; + }) + pats + in + match pats with + | [] -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) + | pat :: pats -> + let r = + List.fold_left + (fun pat pat0 -> + { + pat_desc = Tpat_or (pat0, pat, Some row0); + pat_extra = []; + pat_loc = gloc; + pat_env = env; + pat_type = ty; + pat_attributes = []; + }) + pat pats + in + (path, rp {r with pat_loc = loc}, ty) + +let extract_type_from_pat_variant_spread env lid expected_ty = + let path, decl = Typetexp.find_type env lid.loc lid.txt in + match decl with + | {type_kind = Type_variant constructors; type_params} -> + if List.length type_params > 0 then + raise (Error (lid.loc, env, Type_params_not_supported lid.txt)); + let ty = newgenty (Tconstr (path, [], ref Mnil)) in + (try Ctype.subtype env ty expected_ty () + with Ctype.Subtype (tr1, tr2, ctx) -> + raise (Error (lid.loc, env, Not_subtype (tr1, tr2, ctx)))); + (path, decl, constructors, ty) + | _ -> raise (Error (lid.loc, env, Not_a_variant_type lid.txt)) + +let build_ppat_or_for_variant_spread pat env expected_ty = + match pat with + | {ppat_desc = Ppat_type lident; ppat_attributes} + when Variant_coercion.has_res_pat_variant_spread_attribute ppat_attributes + -> + let _, _, constructors, ty = + extract_type_from_pat_variant_spread !env lident expected_ty + in + let synthetic_or_patterns = + constructors + |> List.map (fun (c : Types.constructor_declaration) -> + Ast_helper.Pat.mk + ~attrs:[Variant_type_spread.mk_pat_from_variant_spread_attr ()] + ~loc:lident.loc + (Ppat_construct + ( Location.mkloc + (Longident.Lident (Ident.name c.cd_id)) + lident.loc, + match c.cd_args with + | Cstr_tuple [] -> None + | _ -> Some (Ast_helper.Pat.any ()) ))) + |> List.rev + in + let pat = + match synthetic_or_patterns with + | [] -> pat + | pat :: pats -> + List.fold_left (fun p1 p2 -> Ast_helper.Pat.or_ p1 p2) pat pats + in + Some (pat, ty) + | _ -> None + +let maybe_expand_variant_spread_in_pattern pattern env expected_ty = + match pattern.Parsetree.ppat_desc with + | Ppat_type _ + when Variant_coercion.has_res_pat_variant_spread_attribute + pattern.ppat_attributes -> ( + match build_ppat_or_for_variant_spread pattern env expected_ty with + | None -> assert false (* TODO: Fix. *) + | Some (pattern, _) -> pattern) + | _ -> pattern + +(* Type paths *) + +let rec expand_path env p = + let decl = try Some (Env.find_type p env) with Not_found -> None in + match decl with + | Some {type_manifest = Some ty} -> ( + match repr ty with + | {desc = Tconstr (p, _, _)} -> expand_path env p + | _ -> p (* PR#6394: recursive module may introduce incoherent manifest *)) + | _ -> + let p' = Env.normalize_path None env p in + if Path.same p p' then p else expand_path env p' + +let compare_type_path env tpath1 tpath2 = + Path.same (expand_path env tpath1) (expand_path env tpath2) + +let fprintf = Format.fprintf + +let rec bottom_aliases = function + | (_, one) :: (_, two) :: rest -> ( + match bottom_aliases rest with + | Some types -> Some types + | None -> Some (one, two)) + | _ -> None + +let simple_conversions = + [ + (("float", "int"), "Float.toInt"); + (("float", "string"), "Float.toString"); + (("int", "float"), "Int.toFloat"); + (("int", "string"), "Int.toString"); + (("string", "float"), "Float.fromString"); + (("string", "int"), "Int.fromString"); + ] + +let print_simple_conversion ppf (actual, expected) = + try + let converter = List.assoc (actual, expected) simple_conversions in + fprintf ppf + "@,\ + @,\ + @[You can convert @{%s@} to @{%s@} with @{%s@}.@]" + actual expected converter + with Not_found -> () + +let print_simple_message ppf = function + | "float", "int" -> + fprintf ppf + "@ If this is a literal, try a number without a trailing dot (e.g. \ + @{20@})." + | "int", "float" -> + fprintf ppf + "@ If this is a literal, try a number with a trailing dot (e.g. \ + @{20.@})." + | _ -> () + +let show_extra_help ppf _env trace = + match bottom_aliases trace with + | Some + ( {Types.desc = Tconstr (actual_path, actual_args, _)}, + {desc = Tconstr (expected_path, expexted_args, _)} ) -> ( + match (actual_path, actual_args, expected_path, expexted_args) with + | Pident {name = actual_name}, [], Pident {name = expected_name}, [] -> + print_simple_conversion ppf (actual_name, expected_name); + print_simple_message ppf (actual_name, expected_name) + | _ -> ()) + | _ -> () + +let rec collect_missing_arguments env type1 type2 = + match type1 with + (* why do we use Ctype.matches here? Please see https://github.com/rescript-lang/rescript-compiler/pull/2554 *) + | {Types.desc = Tarrow (arg, ret, _, _)} when Ctype.matches env ret type2 -> + Some [(arg.lbl, arg.typ)] + | {desc = Tarrow (arg, ret, _, _)} -> ( + match collect_missing_arguments env ret type2 with + | Some res -> Some ((arg.lbl, arg.typ) :: res) + | None -> None) + | _ -> None + +let print_expr_type_clash ~context env loc trace ppf = + (* this is the most frequent error. We should do whatever we can to provide + specific guidance to this generic error before giving up *) + let bottom_aliases_result = bottom_aliases trace in + let missing_arguments = + match bottom_aliases_result with + | Some (actual, expected) -> collect_missing_arguments env actual expected + | None -> assert false + in + let print_arguments = + Format.pp_print_list + ~pp_sep:(fun ppf _ -> fprintf ppf ",@ ") + (fun ppf (label, argtype) -> + match label with + | Asttypes.Nolabel -> fprintf ppf "@[%a@]" Printtyp.type_expr argtype + | Labelled {txt = label} -> + fprintf ppf "@[(~%s: %a)@]" label Printtyp.type_expr argtype + | Optional {txt = label} -> + fprintf ppf "@[(?%s: %a)@]" label Printtyp.type_expr argtype) + in + match missing_arguments with + | Some [single_argument] -> + (* btw, you can't say "final arguments". Intermediate labeled + arguments might be the ones missing *) + fprintf ppf "@[@{This call is missing an argument@} of type@ %a@]" + print_arguments [single_argument] + | Some arguments -> + fprintf ppf "@[@{This call is missing arguments@} of type:@ %a@]" + print_arguments arguments + | None -> + let missing_parameters = + match bottom_aliases_result with + | Some (actual, expected) -> collect_missing_arguments env expected actual + | None -> assert false + in + (match missing_parameters with + | Some [single_parameter] -> + fprintf ppf + "@[This value might need to be @{wrapped in a function@ that@ \ + takes@ an@ extra@ parameter@}@ of@ type@ %a@]@,\ + @," + print_arguments [single_parameter]; + fprintf ppf "@[@{Here's the original error message@}@]@," + | Some arguments -> + fprintf ppf + "@[This value seems to @{need to be wrapped in a function that \ + takes extra@ arguments@}@ of@ type:@ @[%a@]@]@,\ + @," + print_arguments arguments; + fprintf ppf "@[@{Here's the original error message@}@]@," + | None -> ()); + + Printtyp.super_report_unification_error ppf env trace + (function + | ppf -> error_type_text ppf context) + (function ppf -> error_expected_type_text ppf context); + print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf + bottom_aliases_result trace context; + show_extra_help ppf env trace + +let report_arity_mismatch ~arity_a ~arity_b ppf = + fprintf ppf + "This function is expected to have @{%s@} %s, but%s has @{%s@}" + arity_b + (if arity_b = "1" then "argument" else "arguments") + (if int_of_string arity_a < int_of_string arity_b then " only" else "") + arity_a + +(* Records *) +let label_of_kind kind = if kind = "record" then "field" else "constructor" + +module NameChoice (Name : sig + type t + val type_kind : string + val get_name : t -> string + val get_type : t -> type_expr + val get_descrs : Env.type_descriptions -> t list + + val unsafe_do_not_use__add_with_name : t -> string -> t + val unbound_name_error : + ?from_type:type_expr -> Env.t -> Longident.t loc -> 'a +end) = +struct + open Name + + let get_type_path d = + match (repr (get_type d)).desc with + | Tconstr (p, _, _) -> p + | _ -> assert false + + let lookup_from_type env tpath (lid : Longident.t loc) : Name.t = + let descrs = get_descrs (Env.find_type_descrs tpath env) in + Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env); + if Path.same tpath Predef.path_dict then + (* [dict] Handle directing any label lookup to the magic dict field. *) + match lid.txt with + | Longident.Lident s -> + let x = + List.find + (fun nd -> get_name nd = Dict_type_helpers.dict_magic_field_name) + descrs + in + unsafe_do_not_use__add_with_name x s + | _ -> raise Not_found + else + match lid.txt with + | Longident.Lident s -> ( + try List.find (fun nd -> get_name nd = s) descrs + with Not_found -> + let names = List.map get_name descrs in + raise + (Error + ( lid.loc, + env, + Wrong_name ("", newvar (), type_kind, tpath, s, names) ))) + | _ -> raise Not_found + + let rec unique eq acc = function + | [] -> List.rev acc + | x :: rem -> + if List.exists (eq x) acc then unique eq acc rem + else unique eq (x :: acc) rem + + let ambiguous_types env lbl others = + let tpath = get_type_path lbl in + let others = List.map (fun (lbl, _) -> get_type_path lbl) others in + let tpaths = unique (compare_type_path env) [tpath] others in + match tpaths with + | [_] -> [] + | _ -> List.map Printtyp.string_of_path tpaths + + let disambiguate_by_type env tpath lbls = + let check_type (lbl, _) = + let lbl_tpath = get_type_path lbl in + compare_type_path env tpath lbl_tpath + in + List.find check_type lbls + + let disambiguate ?(warn = Location.prerr_warning) ?(check_lk = fun _ _ -> ()) + ?(from_type : Types.type_expr option) ?scope lid env opath lbls = + let scope = + match scope with + | None -> lbls + | Some l -> l + in + let lbl = + match opath with + | None -> ( + match lbls with + | [] -> unbound_name_error ?from_type env lid + | (lbl, use) :: rest -> + use (); + let paths = ambiguous_types env lbl rest in + if paths <> [] then + warn lid.loc + (Warnings.Ambiguous_name ([Longident.last lid.txt], paths, false)); + lbl) + | Some (tpath0, tpath) -> ( + try + let lbl, use = disambiguate_by_type env tpath scope in + use (); + lbl + with Not_found -> ( + try + let lbl = lookup_from_type env tpath lid in + check_lk tpath lbl; + lbl + with Not_found -> + if lbls = [] then unbound_name_error ?from_type env lid + else + let tp = (tpath0, expand_path env tpath) in + let tpl = + List.map + (fun (lbl, _) -> + let tp0 = get_type_path lbl in + let tp = expand_path env tp0 in + (tp0, tp)) + lbls + in + raise + (Error + ( lid.loc, + env, + Name_type_mismatch (type_kind, lid.txt, tp, tpl) )))) + in + lbl +end + +let wrap_disambiguate kind ty f x = + try f x + with Error (loc, env, Wrong_name ("", _, tk, tp, name, valid_names)) -> + raise (Error (loc, env, Wrong_name (kind, ty, tk, tp, name, valid_names))) + +module Label = NameChoice (struct + type t = label_description + let type_kind = "record" + let get_name lbl = lbl.lbl_name + + let unsafe_do_not_use__add_with_name lbl name = + (* [dict] This is used in dicts and shouldn't be used anywhere else. + It adds a new field to an existing record type, to "fool" the pattern + matching into thinking the label exists. *) + let l = + { + lbl with + lbl_name = name; + lbl_pos = Array.length lbl.lbl_all; + lbl_repres = Record_regular; + } + in + let lbl_all_list = Array.to_list lbl.lbl_all @ [l] in + let lbl_all = Array.of_list lbl_all_list in + Ext_array.iter lbl_all (fun lbl -> lbl.lbl_all <- lbl_all); + l + let get_type lbl = lbl.lbl_res + let get_descrs = snd + let unbound_name_error = Typetexp.unbound_label_error +end) + +let disambiguate_label_by_ids closed ids labels = + let check_ids (lbl, _) = + (* check that all ids are present *) + let lbls = Hashtbl.create 8 in + Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; + List.for_all (Hashtbl.mem lbls) ids + in + let mandatory_labels_are_present num_ids lbl = + (* check that all mandatory labels are present *) + let has_optional_labels = Ext_array.exists lbl.lbl_all label_is_optional in + if has_optional_labels then ( + let mandatory_lbls = ref 0 in + Ext_array.iter lbl.lbl_all (fun l -> + if not (label_is_optional l) then incr mandatory_lbls); + num_ids >= !mandatory_lbls) + else num_ids = Array.length lbl.lbl_all + in + let check_closed (lbl, _) = + (not closed) || mandatory_labels_are_present (List.length ids) lbl + in + let labels' = Ext_list.filter labels check_ids in + if labels' = [] then (false, labels) + else + let labels'' = Ext_list.filter labels' check_closed in + if labels'' = [] then (false, labels') else (true, labels'') + +(* Only issue warnings once per record constructor/pattern *) +let disambiguate_record_elem_list loc closed env opath record_elem_list = + let ids = List.map (fun {lid} -> Longident.last lid.txt) record_elem_list in + let w_amb = ref [] in + let warn loc msg = + let open Warnings in + match msg with + | Ambiguous_name ([s], l, _) -> w_amb := (s, l) :: !w_amb + | _ -> Location.prerr_warning loc msg + in + let process_label lid = + (* Strategy for each field: + * collect all the labels in scope for that name + * if the type is known and principal, just eventually warn + if the real label was not in scope + * fail if there is no known type and no label found + * otherwise use other fields to reduce the list of candidates + * if there is no known type reduce it incrementally, so that + there is still at least one candidate (for error message) + * if the reduced list is valid, call Label.disambiguate + *) + let scope = Typetexp.find_all_labels env lid.loc lid.txt in + if opath = None && scope = [] then Typetexp.unbound_label_error env lid; + let ok, labels = + match opath with + | Some _ -> (true, scope) (* disambiguate only checks scope *) + | _ -> disambiguate_label_by_ids closed ids scope + in + if ok then Label.disambiguate lid env opath labels ~warn ~scope + else fst (List.hd labels) + (* will fail later *) + in + let lbl_a_list = + List.map + (fun {lid; x; opt} -> (lid, process_label lid, x, opt)) + record_elem_list + in + (match List.rev !w_amb with + | (_, types) :: _ as amb -> + let paths = + List.map (fun (_, lbl, _, _) -> Label.get_type_path lbl) lbl_a_list + in + let path = List.hd paths in + if List.for_all (compare_type_path env path) (List.tl paths) then + Location.prerr_warning loc + (Warnings.Ambiguous_name (List.map fst amb, types, true)) + else + List.iter + (fun (s, l) -> + Location.prerr_warning loc (Warnings.Ambiguous_name ([s], l, false))) + amb + | _ -> ()); + lbl_a_list + +let rec find_record_qual = function + | [] -> None + | {lid = {txt = Longident.Ldot (modname, _)}} :: _ -> Some modname + | _ :: rest -> find_record_qual rest + +let map_fold_cont f xs k = + List.fold_right + (fun x k ys -> f x (fun y -> k (y :: ys))) + xs + (fun ys -> k (List.rev ys)) + [] + +let type_record_elem_list ?labels loc closed env type_lbl_a opath + record_elem_list k = + let lbl_a_list = + match (record_elem_list, labels) with + | {lid = {txt = Longident.Lident s}} :: _, Some labels + when Hashtbl.mem labels s -> + (* Special case for rebuilt syntax trees *) + List.map + (function + | {lid; x = a; opt} -> ( + match lid.txt with + | Longident.Lident s -> (lid, Hashtbl.find labels s, a, opt) + | _ -> assert false)) + record_elem_list + | _ -> + let record_elem_list = + match find_record_qual record_elem_list with + | None -> record_elem_list + | Some modname -> + List.map + (fun ({lid; x = a; opt} as el) -> + match lid.txt with + | Longident.Lident s -> + {lid = {lid with txt = Longident.Ldot (modname, s)}; x = a; opt} + | _ -> el) + record_elem_list + in + disambiguate_record_elem_list loc closed env opath record_elem_list + in + (* Invariant: records are sorted in the typed tree *) + let lbl_a_list = + List.sort + (fun (_, lbl1, _, _) (_, lbl2, _, _) -> compare lbl1.lbl_pos lbl2.lbl_pos) + lbl_a_list + in + map_fold_cont type_lbl_a lbl_a_list k + +(* Checks over the labels mentioned in a record pattern: + no duplicate definitions (error); properly closed (warning) *) + +let check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list closed + = + match lbl_pat_list with + | [] -> () (* should not happen *) + | ((l : Longident.t loc), label1, _, _) :: _ -> + let all = label1.lbl_all in + let defined = Array.make (Array.length all) false in + let check_defined (_, label, _, _) = + if defined.(label.lbl_pos) then + raise + (Error + ( l.loc, + Env.empty, + Label_multiply_defined + { + label = label.lbl_name; + jsx_component_info = get_jsx_component_error_info (); + } )) + else defined.(label.lbl_pos) <- true + in + List.iter check_defined lbl_pat_list; + if + closed = Closed + && Warnings.is_active (Warnings.Non_closed_record_pattern "") + then ( + let undefined = ref [] in + for i = 0 to Array.length all - 1 do + if not defined.(i) then undefined := all.(i).lbl_name :: !undefined + done; + if !undefined <> [] then + let u = String.concat ", " (List.rev !undefined) in + Location.prerr_warning loc (Warnings.Non_closed_record_pattern u)) + +(* Constructors *) + +module Constructor = NameChoice (struct + type t = constructor_description + let type_kind = "variant" + let get_name cstr = cstr.cstr_name + let get_type cstr = cstr.cstr_res + + let unsafe_do_not_use__add_with_name _cstr _name = assert false + let get_descrs = fst + let unbound_name_error = Typetexp.unbound_constructor_error +end) + +(* unification of a type with a tconstr with + freshly created arguments *) +let unify_head_only loc env ty constr = + let _, ty_res = instance_constructor constr in + match (repr ty_res).desc with + | Tconstr (p, args, m) -> + ty_res.desc <- Tconstr (p, List.map (fun _ -> newvar ()) args, m); + enforce_constraints env ty_res; + unify_pat_types loc env ty_res ty + | _ -> assert false + +(* Typing of patterns *) + +(* Remember current state for backtracking. + No variable information, as we only backtrack on + patterns without variables (cf. assert statements). *) +type state = {snapshot: Btype.snapshot; levels: Ctype.levels; env: Env.t} +let save_state env = + {snapshot = Btype.snapshot (); levels = Ctype.save_levels (); env = !env} +let set_state s env = + Btype.backtrack s.snapshot; + Ctype.set_levels s.levels; + env := s.env + +(* type_pat does not generate local constraints inside or patterns *) +type type_pat_mode = + | Normal + | Splitting_or (* splitting an or-pattern *) + | Inside_or (* inside a non-split or-pattern *) + | Split_or (* always split or-patterns *) + +exception Need_backtrack + +(* type_pat propagates the expected type as well as maps for + constructors and labels. + Unification may update the typing environment. *) +(* constrs <> None => called from parmatch: backtrack on or-patterns + explode > 0 => explode Ppat_any for gadts *) +let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env sp + expected_ty k = + Builtin_attributes.warning_scope sp.ppat_attributes (fun () -> + type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp + expected_ty k) + +and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp + expected_ty k = + let sp = maybe_expand_variant_spread_in_pattern sp env expected_ty in + let mode' = if mode = Splitting_or then Normal else mode in + let type_pat ?(constrs = constrs) ?(labels = labels) ?(mode = mode') + ?(explode = explode) ?(env = env) = + type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env + in + let loc = sp.ppat_loc in + let rp k x : pattern = if constrs = None then k (rp x) else k x in + match sp.ppat_desc with + | Ppat_any -> + let k' d = + rp k + { + pat_desc = d; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + in + if explode > 0 then + let sp, constrs, labels = Parmatch.ppat_of_type !env expected_ty in + if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any + else if mode = Inside_or then raise Need_backtrack + else + let explode = + match sp.ppat_desc with + | Parsetree.Ppat_or _ -> explode - 5 + | _ -> explode - 1 + in + type_pat ~constrs:(Some constrs) ~labels:(Some labels) ~explode sp + expected_ty k + else k' Tpat_any + | Ppat_var name -> + let id = + (* PR#7330 *) + if name.txt = "*extension*" then Ident.create name.txt + else enter_variable loc name expected_ty + in + rp k + { + pat_desc = Tpat_var (id, name); + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + | Ppat_unpack name -> + assert (constrs = None); + let id = enter_variable loc name expected_ty ~is_module:true in + rp k + { + pat_desc = Tpat_var (id, name); + pat_loc = sp.ppat_loc; + pat_extra = [(Tpat_unpack, loc, sp.ppat_attributes)]; + pat_type = expected_ty; + pat_attributes = []; + pat_env = !env; + } + | Ppat_constraint + ( {ppat_desc = Ppat_var name; ppat_loc = lloc}, + ({ptyp_desc = Ptyp_poly _} as sty) ) -> ( + (* explicitly polymorphic type *) + assert (constrs = None); + let cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in + unify_pat_types lloc !env ty expected_ty; + pattern_force := force :: !pattern_force; + match ty.desc with + | Tpoly (body, tyl) -> + begin_def (); + let _, ty' = instance_poly ~keep_names:true false tyl body in + end_def (); + generalize ty'; + let id = enter_variable lloc name ty' in + rp k + { + pat_desc = Tpat_var (id, name); + pat_loc = lloc; + pat_extra = [(Tpat_constraint cty, loc, sp.ppat_attributes)]; + pat_type = ty; + pat_attributes = []; + pat_env = !env; + } + | _ -> assert false) + | Ppat_alias (sq, name) -> + let override_type_from_variant_spread, sq = + match sq with + | {ppat_desc = Ppat_type _; ppat_attributes} + when Variant_coercion.has_res_pat_variant_spread_attribute + ppat_attributes -> ( + match build_ppat_or_for_variant_spread sq env expected_ty with + | Some (p, ty) -> (Some ty, p) + | None -> (None, sq)) + | _ -> (None, sq) + in + assert (constrs = None); + type_pat sq expected_ty (fun q -> + begin_def (); + let ty_var = + match override_type_from_variant_spread with + | Some ty -> ty + | None -> build_as_type !env q + in + end_def (); + generalize ty_var; + let id = enter_variable ~is_as_variable:true loc name ty_var in + rp k + { + pat_desc = Tpat_alias (q, id, name); + pat_loc = loc; + pat_extra = []; + pat_type = q.pat_type; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_constant cst -> + let cst = constant_or_raise !env loc cst in + unify_pat_types loc !env (type_constant cst) expected_ty; + rp k + { + pat_desc = Tpat_constant cst; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + | Ppat_interval (Pconst_char c1, Pconst_char c2) -> + let open Ast_helper.Pat in + let gloc = {loc with Location.loc_ghost = true} in + let rec loop c1 c2 = + if c1 = c2 then constant ~loc:gloc (Pconst_char c1) + else + or_ ~loc:gloc (constant ~loc:gloc (Pconst_char c1)) (loop (c1 + 1) c2) + in + let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in + let p = {p with ppat_loc = loc} in + type_pat ~explode:0 p expected_ty k + (* TODO: record 'extra' to remember about interval *) + | Ppat_interval _ -> raise (Error (loc, !env, Invalid_interval)) + | Ppat_tuple spl -> + assert (List.length spl >= 2); + let spl_ann = List.map (fun p -> (p, newvar ())) spl in + let ty = newty (Ttuple (List.map snd spl_ann)) in + unify_pat_types loc !env ty expected_ty; + map_fold_cont + (fun (p, t) -> type_pat p t) + spl_ann + (fun pl -> + rp k + { + pat_desc = Tpat_tuple pl; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_construct (lid, sarg) -> + let opath = + try + let p0, p, _ = extract_concrete_variant !env expected_ty in + Some (p0, p) + with Not_found -> None + in + let candidates = + match (lid.txt, constrs) with + | Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> + [(Hashtbl.find constrs s, fun () -> ())] + | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt + in + let check_lk tpath constr = + if constr.cstr_generalized then + raise + (Error + (lid.loc, !env, Unqualified_gadt_pattern (tpath, constr.cstr_name))) + in + let constr = + wrap_disambiguate "This variant pattern is expected to have" expected_ty + (Constructor.disambiguate lid !env opath ~check_lk) + candidates + in + if constr.cstr_generalized && constrs <> None && mode = Inside_or then + raise Need_backtrack; + Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; + Builtin_attributes.check_deprecated loc constr.cstr_attributes + constr.cstr_name; + if no_existentials && constr.cstr_existentials <> [] then + raise (Error (loc, !env, Unexpected_existential)); + (* if constructor is gadt, we must verify that the expected type has the + correct head *) + if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; + let sargs = + match sarg with + | None -> [] + | Some {ppat_desc = Ppat_tuple spl} + when constr.cstr_arity > 1 + || Builtin_attributes.explicit_arity sp.ppat_attributes -> + spl + | Some ({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> + if constr.cstr_arity = 0 then + Location.prerr_warning sp.ppat_loc + Warnings.Wildcard_arg_to_constant_constr; + replicate_list sp constr.cstr_arity + | Some sp -> [sp] + in + (match sargs with + | [({ppat_desc = Ppat_constant _} as sp)] + when Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes -> + Location.prerr_warning sp.ppat_loc Warnings.Fragile_literal_pattern + | _ -> ()); + if List.length sargs <> constr.cstr_arity then + raise + (Error + ( loc, + !env, + Constructor_arity_mismatch + { + name = lid.txt; + constuctor = constr; + expected = constr.cstr_arity; + provided = List.length sargs; + } )); + let ty_args, ty_res = + instance_constructor ~in_pattern:(env, get_newtype_level ()) constr + in + (* PR#7214: do not use gadt unification for toplevel lets *) + if (not constr.cstr_generalized) || mode = Inside_or || no_existentials then + unify_pat_types loc !env ty_res expected_ty + else unify_pat_types_gadt loc env ty_res expected_ty; + + let rec check_non_escaping p = + match p.ppat_desc with + | Ppat_or (p1, p2) -> + check_non_escaping p1; + check_non_escaping p2 + | Ppat_alias (p, _) -> check_non_escaping p + | Ppat_constraint _ -> + raise (Error (p.ppat_loc, !env, Inlined_record_escape)) + | _ -> () + in + if constr.cstr_inlined <> None then List.iter check_non_escaping sargs; + + map_fold_cont + (fun (p, t) -> type_pat p t) + (List.combine sargs ty_args) + (fun args -> + rp k + { + pat_desc = Tpat_construct (lid, constr, args); + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_variant (l, sarg) -> ( + let arg_type = + match sarg with + | None -> [] + | Some _ -> [newvar ()] + in + let row = + { + row_fields = [(l, Reither (sarg = None, arg_type, true, ref None))]; + row_closed = false; + row_more = newvar (); + row_fixed = false; + row_name = None; + } + in + (* PR#7404: allow some_other_tag blindly, as it would not unify with + the abstract row variable *) + if l = Parmatch.some_other_tag then assert (constrs <> None) + else unify_pat_types loc !env (newty (Tvariant row)) expected_ty; + let k arg = + rp k + { + pat_desc = Tpat_variant (l, arg, ref {row with row_more = newvar ()}); + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + in + (* PR#6235: propagate type information *) + match (sarg, arg_type) with + | Some p, [ty] -> type_pat p ty (fun p -> k (Some p)) + | _ -> k None) + | Ppat_record (lid_sp_list, closed) -> + let has_dict_pattern_attr = + Dict_type_helpers.has_dict_pattern_attribute sp.ppat_attributes + in + let opath, record_ty = + if has_dict_pattern_attr then + ( (* [dict] Make sure dict patterns are inferred as actual dicts *) + Some (Predef.path_dict, Predef.path_dict), + newgenty (Tconstr (Predef.path_dict, [newvar ()], ref Mnil)) ) + else + try + let p0, p, _, _ = extract_concrete_record !env expected_ty in + (Some (p0, p), expected_ty) + with Not_found -> (None, newvar ()) + in + let get_jsx_component_error_info = + get_jsx_component_error_info ~extract_concrete_typedecl opath !env + record_ty + in + let process_optional_label (ld, pat, optional) = + let exp_optional_attr = + check_optional_attr !env ld optional pat.ppat_loc + in + let is_from_pamatch = + match pat.ppat_desc with + | Ppat_construct ({txt = Lident s}, _) -> + String.length s >= 2 && s.[0] = '#' && s.[1] = '$' + | _ -> false + in + if label_is_optional ld && (not exp_optional_attr) && not is_from_pamatch + then + let lid = mknoloc Longident.(Ldot (Lident "*predef*", "Some")) in + Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat) + else pat + in + let type_label_pat (label_lid, label, sarg, opt) k = + let sarg = process_optional_label (label, sarg, opt) in + begin_def (); + let vars, ty_arg, ty_res = instance_label false label in + if vars = [] then end_def (); + (try unify_pat_types loc !env ty_res record_ty + with Unify trace -> + raise + (Error (label_lid.loc, !env, Label_mismatch (label_lid.txt, trace)))); + type_pat sarg ty_arg (fun arg -> + if vars <> [] then ( + end_def (); + generalize ty_arg; + List.iter generalize vars; + let instantiated tv = + let tv = expand_head !env tv in + (not (is_Tvar tv)) || tv.level <> generic_level + in + if List.exists instantiated vars then + raise + (Error (label_lid.loc, !env, Polymorphic_label label_lid.txt))); + k (label_lid, label, arg, opt)) + in + let k' k lbl_pat_list = + check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list + closed; + unify_pat_types loc !env record_ty expected_ty; + rp k + { + pat_desc = Tpat_record (lbl_pat_list, closed); + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + in + if constrs = None then + k + (wrap_disambiguate "This record pattern is expected to have" expected_ty + (type_record_elem_list ?labels loc false !env type_label_pat opath + lid_sp_list) + (k' (fun x -> x))) + else + type_record_elem_list ?labels loc false !env type_label_pat opath + lid_sp_list (k' k) + | Ppat_array spl -> + let ty_elt = newvar () in + unify_pat_types loc !env + (instance_def (Predef.type_array ty_elt)) + expected_ty; + let spl_ann = List.map (fun p -> (p, newvar ())) spl in + map_fold_cont + (fun (p, _) -> type_pat p ty_elt) + spl_ann + (fun pl -> + rp k + { + pat_desc = Tpat_array pl; + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + }) + | Ppat_or (sp1, sp2) -> ( + let state = save_state env in + match + if mode = Split_or || mode = Splitting_or then raise Need_backtrack; + let initial_pattern_variables = !pattern_variables in + let initial_module_variables = !module_variables in + let p1 = + try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x)) + with Need_backtrack -> None + in + let p1_variables = !pattern_variables in + let p1_module_variables = !module_variables in + pattern_variables := initial_pattern_variables; + module_variables := initial_module_variables; + let p2 = + try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x)) + with Need_backtrack -> None + in + let p2_variables = !pattern_variables in + match (p1, p2) with + | None, None -> raise Need_backtrack + | Some p, None | None, Some p -> p (* no variables in this case *) + | Some p1, Some p2 -> + let alpha_env = + enter_orpat_variables loc !env p1_variables p2_variables + in + pattern_variables := p1_variables; + module_variables := p1_module_variables; + { + pat_desc = Tpat_or (p1, alpha_pat alpha_env p2, None); + pat_loc = loc; + pat_extra = []; + pat_type = expected_ty; + pat_attributes = sp.ppat_attributes; + pat_env = !env; + } + with + | p -> rp k p + | exception Need_backtrack when mode <> Inside_or -> ( + assert (constrs <> None); + set_state state env; + let mode = if mode = Split_or then mode else Splitting_or in + try type_pat ~mode sp1 expected_ty k + with Error _ -> + set_state state env; + type_pat ~mode sp2 expected_ty k)) + | Ppat_constraint (sp, sty) -> + (* Separate when not already separated by !principal *) + let separate = true in + if separate then begin_def (); + let cty, force = Typetexp.transl_simple_type_delayed !env sty in + let ty = cty.ctyp_type in + let ty, expected_ty' = + if separate then ( + end_def (); + generalize_structure ty; + (instance !env ty, instance !env ty)) + else (ty, ty) + in + unify_pat_types loc !env ty expected_ty; + type_pat sp expected_ty' (fun p -> + (*Format.printf "%a@.%a@." + Printtyp.raw_type_expr ty + Printtyp.raw_type_expr p.pat_type;*) + pattern_force := force :: !pattern_force; + let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in + let p = + if not separate then p + else + match p.pat_desc with + | Tpat_var (id, s) -> + { + p with + pat_type = ty; + pat_desc = + Tpat_alias + ({p with pat_desc = Tpat_any; pat_attributes = []}, id, s); + pat_extra = [extra]; + } + | _ -> {p with pat_type = ty; pat_extra = extra :: p.pat_extra} + in + k p) + | Ppat_type lid -> + let path, p, ty = build_or_pat !env loc lid in + unify_pat_types loc !env ty expected_ty; + k + { + p with + pat_extra = + (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra; + } + | Ppat_open (lid, p) -> + let path, new_env = !type_open Asttypes.Fresh !env sp.ppat_loc lid in + let new_env = ref new_env in + type_pat ~env:new_env p expected_ty (fun p -> + env := Env.copy_local !env ~from:!new_env; + k + { + p with + pat_extra = + (Tpat_open (path, lid, !new_env), loc, sp.ppat_attributes) + :: p.pat_extra; + }) + | Ppat_exception _ -> + raise (Error (loc, !env, Exception_pattern_below_toplevel)) + | Ppat_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +let type_pat ?(allow_existentials = false) ?constrs ?labels ?(mode = Normal) + ?(explode = 0) ?(lev = get_current_level ()) env sp expected_ty = + newtype_level := Some lev; + try + let r = + type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels ~mode + ~explode ~env sp expected_ty (fun x -> x) + in + iter_pattern (fun p -> p.pat_env <- !env) r; + newtype_level := None; + r + with e -> + newtype_level := None; + raise e + +(* this function is passed to Partial.parmatch + to type check gadt nonexhaustiveness *) +let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p = + let env = ref env in + let state = save_state env in + try + reset_pattern None true; + let typed_p = + Ctype.with_passive_variants + (type_pat ~allow_existentials:true ~lev ~constrs ~labels ?mode ?explode + env p) + expected_ty + in + set_state state env; + (* types are invalidated but we don't need them here *) + Some typed_p + with Error _ -> + set_state state env; + None + +let check_partial ?(lev = get_current_level ()) ?partial_match_warning_hint env + expected_ty loc cases = + let explode = + match cases with + | [_] -> 5 + | _ -> 0 + in + Parmatch.check_partial_gadt ?partial_match_warning_hint + (partial_pred ~lev ~explode env expected_ty) + loc cases + +let check_unused ?(lev = get_current_level ()) env expected_ty cases = + Parmatch.check_unused + (fun constrs labels spat -> + partial_pred ~lev ~mode:Split_or ~explode:5 env expected_ty constrs labels + spat) + cases + +let add_pattern_variables ?check ?check_as env = + let pv = get_ref pattern_variables in + ( List.fold_right + (fun (id, ty, _name, loc, as_var) env -> + let check = if as_var then check_as else check in + Env.add_value ?check id + { + val_type = ty; + val_kind = Val_reg; + Types.val_loc = loc; + val_attributes = []; + } + env) + pv env, + get_ref module_variables ) + +let type_pattern ~lev env spat scope expected_ty = + reset_pattern scope true; + let new_env = ref env in + let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in + let new_env, unpacks = + add_pattern_variables !new_env + ~check:(fun s -> Warnings.Unused_var_strict s) + ~check_as:(fun s -> Warnings.Unused_var s) + in + (pat, new_env, get_ref pattern_force, unpacks) + +let type_pattern_list env spatl scope expected_tys allow = + reset_pattern scope allow; + let new_env = ref env in + let type_pat (attrs, pat) ty = + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + type_pat new_env pat ty) + in + let patl = List.map2 type_pat spatl expected_tys in + let new_env, unpacks = add_pattern_variables !new_env in + (patl, new_env, get_ref pattern_force, unpacks) + +let rec final_subexpression sexp = + match sexp.pexp_desc with + | Pexp_let (_, _, e) + | Pexp_sequence (_, e) + | Pexp_try (e, _) + | Pexp_ifthenelse (_, e, _) + | Pexp_match (_, {pc_rhs = e} :: _) -> + final_subexpression e + | _ -> sexp + +(* Generalization criterion for expressions *) + +let rec is_nonexpansive exp = + List.exists + (function + | (({txt = "internal.expansive"}, _) : Parsetree.attribute) -> true + | _ -> false) + exp.exp_attributes + || + match exp.exp_desc with + | Texp_ident (_, _, _) -> true + | Texp_constant _ -> true + | Texp_let (_rec_flag, pat_exp_list, body) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list + && is_nonexpansive body + | Texp_function _ -> true + | Texp_apply {funct = e; args = (_, None) :: el} -> + is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) + | Texp_match (e, cases, [], _) -> + is_nonexpansive e + && List.for_all + (fun {c_lhs = _; c_guard; c_rhs} -> + is_nonexpansive_opt c_guard && is_nonexpansive c_rhs) + cases + | Texp_tuple el -> List.for_all is_nonexpansive el + | Texp_construct (_, _, el) -> List.for_all is_nonexpansive el + | Texp_variant (_, arg) -> is_nonexpansive_opt arg + | Texp_record {fields; extended_expression} -> + Array.for_all + (fun (lbl, definition, _) -> + match definition with + | Overridden (_, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp + | Kept _ -> true) + fields + && is_nonexpansive_opt extended_expression + | Texp_field (exp, _, _) -> is_nonexpansive exp + | Texp_array [] -> false + | Texp_ifthenelse (_cond, ifso, ifnot) -> + is_nonexpansive ifso && is_nonexpansive_opt ifnot + | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) + (* Note: nonexpansive only means no _observable_ side effects *) + | Texp_letmodule (_, _, mexp, e) -> + is_nonexpansive_mod mexp && is_nonexpansive e + | Texp_pack mexp -> is_nonexpansive_mod mexp + (* Computations which raise exceptions are nonexpansive, since (raise e) is equivalent + to (raise e; diverge), and a nonexpansive "diverge" can be produced using lazy values + or the relaxed value restriction. See GPR#1142 *) + | Texp_assert exp -> is_nonexpansive exp + | Texp_apply + { + funct = + { + exp_desc = + Texp_ident + (_, _, {val_kind = Val_prim {Primitive.prim_name = "%raise"}}); + }; + args = [(Nolabel, Some e)]; + } -> + is_nonexpansive e + | _ -> false + +and is_nonexpansive_mod mexp = + match mexp.mod_desc with + | Tmod_ident _ -> true + | Tmod_functor _ -> true + | Tmod_unpack (e, _) -> is_nonexpansive e + | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m + | Tmod_structure str -> + List.for_all + (fun item -> + match item.str_desc with + | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ + | Tstr_open _ -> + true + | Tstr_value (_, pat_exp_list) -> + List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list + | Tstr_module {mb_expr = m; _} | Tstr_include {incl_mod = m; _} -> + is_nonexpansive_mod m + | Tstr_recmodule id_mod_list -> + List.for_all + (fun {mb_expr = m; _} -> is_nonexpansive_mod m) + id_mod_list + | Tstr_exception {ext_kind = Text_decl _} -> + false (* true would be unsound *) + | Tstr_exception {ext_kind = Text_rebind _} -> true + | Tstr_typext te -> + List.for_all + (function + | {ext_kind = Text_decl _} -> false + | {ext_kind = Text_rebind _} -> true) + te.tyext_constructors + | Tstr_attribute _ -> true) + str.str_items + | Tmod_apply _ -> false + +and is_nonexpansive_opt = function + | None -> true + | Some e -> is_nonexpansive e + +(* Approximate the type of an expression, for better recursion *) + +let rec approx_type env sty = + match sty.ptyp_desc with + | Ptyp_arrow {arg = {lbl = p}; ret = sty; arity} -> + let ty1 = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow ({lbl = p; typ = ty1}, approx_type env sty, Cok, arity)) + | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) + | Ptyp_constr (lid, ctl) -> ( + try + let path = Env.lookup_type lid.txt env in + let decl = Env.find_type path env in + if List.length ctl <> decl.type_arity then raise Not_found; + let tyl = List.map (approx_type env) ctl in + newconstr path tyl + with Not_found -> newvar ()) + | Ptyp_poly (_, sty) -> approx_type env sty + | _ -> newvar () + +let rec type_approx env sexp = + match sexp.pexp_desc with + | Pexp_let (_, _, e) -> type_approx env e + | Pexp_fun {arg_label = p; rhs = e; arity} -> + let ty = if is_optional p then type_option (newvar ()) else newvar () in + newty (Tarrow ({lbl = p; typ = ty}, type_approx env e, Cok, arity)) + | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e + | Pexp_try (e, _) -> type_approx env e + | Pexp_tuple l -> newty (Ttuple (List.map (type_approx env) l)) + | Pexp_ifthenelse (_, e, _) -> type_approx env e + | Pexp_sequence (_, e) -> type_approx env e + | Pexp_constraint (e, sty) -> + let ty = type_approx env e in + let ty1 = approx_type env sty in + (try unify env ty ty1 + with Unify trace -> + raise + (Error (sexp.pexp_loc, env, Expr_type_clash {trace; context = None}))); + ty1 + | Pexp_coerce (e, (), sty2) -> + let approx_ty_opt = function + | None -> newvar () + | Some sty -> approx_type env sty + in + let ty = type_approx env e + and ty1 = approx_ty_opt None + and ty2 = approx_type env sty2 in + (try unify env ty ty1 + with Unify trace -> + raise + (Error (sexp.pexp_loc, env, Expr_type_clash {trace; context = None}))); + ty2 + | _ -> newvar () + +(* List labels in a function type, and whether return type is a variable *) +let rec list_labels_aux env visited ls ty_fun = + let ty = expand_head env ty_fun in + if List.memq ty visited then (List.rev ls, false) + else + match ty.desc with + | Tarrow (arg, ty_res, _, arity) when arity = None || visited = [] -> + list_labels_aux env (ty :: visited) (arg.lbl :: ls) ty_res + | _ -> (List.rev ls, is_Tvar ty) + +let list_labels env ty = + wrap_trace_gadt_instances env (list_labels_aux env [] []) ty + +(* Check that all univars are safe in a type *) +let check_univars env expans kind exp ty_expected vars = + if expans && not (is_nonexpansive exp) then + generalize_expansive env exp.exp_type; + (* need to expand twice? cf. Ctype.unify2 *) + let vars = List.map (expand_head env) vars in + let vars = List.map (expand_head env) vars in + let vars' = + Ext_list.filter vars (fun t -> + let t = repr t in + generalize t; + match t.desc with + | Tvar name when t.level = generic_level -> + log_type t; + t.desc <- Tunivar name; + true + | _ -> false) + in + if List.length vars = List.length vars' then () + else + let ty = newgenty (Tpoly (repr exp.exp_type, vars')) + and ty_expected = repr ty_expected in + raise + (Error + ( exp.exp_loc, + env, + Less_general (kind, [(ty, ty); (ty_expected, ty_expected)]) )) + +(* Check that a type is not a function *) +let check_application_result env statement exp = + let loc = exp.exp_loc in + match (expand_head env exp.exp_type).desc with + | Tarrow _ -> Location.prerr_warning exp.exp_loc Warnings.Partial_application + | Tvar _ -> () + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | _ -> if statement then Location.prerr_warning loc Warnings.Statement_type + +(* Check that a type is generalizable at some level *) +let generalizable level ty = + let rec check ty = + let ty = repr ty in + if ty.level < lowest_level then () + else if ty.level <= level then raise Exit + else ( + mark_type_node ty; + iter_type_expr check ty) + in + try + check ty; + unmark_type ty; + true + with Exit -> + unmark_type ty; + false + +(* Helpers for packaged modules. *) + +let wrap_unpacks sexp unpacks = + let open Ast_helper in + List.fold_left + (fun sexp (name, loc) -> + Exp.letmodule ~loc:sexp.pexp_loc + ~attrs:[(mknoloc "#modulepat", PStr [])] + name + (Mod.unpack ~loc + (Exp.ident ~loc:name.loc + (mkloc (Longident.Lident name.txt) name.loc))) + sexp) + sexp unpacks + +(* Helpers for type_cases *) + +let contains_variant_either ty = + let rec loop ty = + let ty = repr ty in + if ty.level >= lowest_level then ( + mark_type_node ty; + match ty.desc with + | Tvariant row -> + let row = row_repr row in + if not row.row_fixed then + List.iter + (fun (_, f) -> + match row_field_repr f with + | Reither _ -> raise Exit + | _ -> ()) + row.row_fields; + iter_row loop row + | _ -> iter_type_expr loop ty) + in + try + loop ty; + unmark_type ty; + false + with Exit -> + unmark_type ty; + true + +let iter_ppat f p = + match p.ppat_desc with + | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ | Ppat_extension _ + | Ppat_type _ | Ppat_unpack _ -> + () + | Ppat_array pats -> List.iter f pats + | Ppat_or (p1, p2) -> + f p1; + f p2 + | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg + | Ppat_tuple lst -> List.iter f lst + | Ppat_exception p + | Ppat_alias (p, _) + | Ppat_open (_, p) + | Ppat_constraint (p, _) -> + f p + | Ppat_record (args, _flag) -> List.iter (fun {x = p} -> f p) args + +let contains_polymorphic_variant p = + let rec loop p = + match p.ppat_desc with + | Ppat_variant _ | Ppat_type _ -> raise Exit + | _ -> iter_ppat loop p + in + try + loop p; + false + with Exit -> true + +let contains_gadt env p = + let rec loop env p = + match p.ppat_desc with + | Ppat_construct (lid, _) -> + (try + let cstrs = Env.lookup_all_constructors lid.txt env in + List.iter + (fun (cstr, _) -> if cstr.cstr_generalized then raise_notrace Exit) + cstrs + with Not_found -> ()); + iter_ppat (loop env) p + | Ppat_open (lid, sub_p) -> + let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in + loop new_env sub_p + | _ -> iter_ppat (loop env) p + in + try + loop env p; + false + with Exit -> true + +let check_absent_variant env = + iter_pattern (function + | {pat_desc = Tpat_variant (s, arg, row)} as pat -> + let row = row_repr !row in + if + List.exists + (fun (s', fi) -> s = s' && row_field_repr fi <> Rabsent) + row.row_fields + || ((not row.row_fixed) && not (static_row row)) + (* same as Ctype.poly *) + then () + else + let ty_arg = + match arg with + | None -> [] + | Some p -> [correct_levels p.pat_type] + in + let row' = + { + row_fields = [(s, Reither (arg = None, ty_arg, true, ref None))]; + row_more = newvar (); + row_closed = false; + row_fixed = false; + row_name = None; + } + in + (* Should fail *) + unify_pat env + {pat with pat_type = newty (Tvariant row')} + (correct_levels pat.pat_type) + | _ -> ()) + +(* Duplicate types of values in the environment *) +(* XXX Should we do something about global type variables too? *) + +let duplicate_ident_types caselist env = + let caselist = + Ext_list.filter caselist (fun {pc_lhs} -> contains_gadt env pc_lhs) + in + Env.copy_types (all_idents_cases caselist) env + +(* type_label_a_list returns a list of labels sorted by lbl_pos *) +(* note: check_duplicates would better be implemented in + type_label_a_list directly *) +let rec check_duplicates ~get_jsx_component_error_info loc env = function + | (_, lbl1, _, _) :: ((l : Longident.t loc), lbl2, _, _) :: _ + when lbl1.lbl_pos = lbl2.lbl_pos -> + raise + (Error + ( l.loc, + env, + Label_multiply_defined + { + label = lbl1.lbl_name; + jsx_component_info = get_jsx_component_error_info (); + } )) + | _ :: rem -> check_duplicates ~get_jsx_component_error_info loc env rem + | [] -> () + +(* Getting proper location of already typed expressions. + + Used to avoid confusing locations on type error messages in presence of + type constraints. + For example: + + (* Before patch *) + # let x : string = (5 : int);; + ^ + (* After patch *) + # let x : string = (5 : int);; + ^^^^^^^^^ +*) +let proper_exp_loc exp = + let rec aux = function + | [] -> exp.exp_loc + | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc + | _ :: rest -> aux rest + in + aux exp.exp_extra + +let id_of_pattern : Typedtree.pattern -> Ident.t option = + fun pat -> + match pat.pat_desc with + | Tpat_var (id, _) -> Some id + | Tpat_alias (_, id, _) -> Some id + | Tpat_construct + (_, _, [{pat_desc = Tpat_var (id, _) | Tpat_alias (_, id, _)}]) -> + Some (Ident.rename id) + | _ -> None +(* To find reasonable names for let-bound and lambda-bound idents *) + +let rec name_pattern default = function + | [] -> Ident.create default + | {c_lhs = p; _} :: rem -> ( + match id_of_pattern p with + | None -> name_pattern default rem + | Some id -> id) + +(* Typing of expressions *) + +let unify_exp ~context env exp expected_ty = + let loc = proper_exp_loc exp in + unify_exp_types ~context loc env exp.exp_type expected_ty + +let is_ignore ~env ~arity funct = + match funct.exp_desc with + | Texp_ident (_, _, {val_kind = Val_prim {Primitive.prim_name = "%ignore"}}) + -> ( + try + ignore (filter_arrow ~env ~arity (instance env funct.exp_type) Nolabel); + true + with Unify _ -> false) + | _ -> false + +let not_identity = function + | Texp_ident (_, _, {val_kind = Val_prim {Primitive.prim_name = "%identity"}}) + -> + false + | _ -> true + +let rec lower_args env seen ty_fun = + let ty = expand_head env ty_fun in + if List.memq ty seen then () + else + match ty.desc with + | Tarrow (arg, ty_fun, _com, _) -> + (try unify_var env (newvar ()) arg.typ with Unify _ -> assert false); + lower_args env (ty :: seen) ty_fun + | _ -> () + +let not_function env ty = + let ls, tvar = list_labels env ty in + ls = [] && not tvar + +let extract_function_name funct = + match funct.exp_desc with + | Texp_ident (path, _, _) -> Some (Longident.parse (Path.name path)) + | _ -> None + +type lazy_args = + (Asttypes.arg_label * (unit -> Typedtree.expression) option) list + +type targs = (Asttypes.arg_label * Typedtree.expression option) list +let rec type_exp ?deprecated_context ~context ?recarg env sexp = + (* We now delegate everything to type_expect *) + type_expect ?deprecated_context ~context ?recarg env sexp (newvar ()) + +(* Typing of an expression with an expected type. + This provide better error messages, and allows controlled + propagation of return type information. + In the principal case, [type_expected'] may be at generic_level. +*) + +and type_expect ~context ?deprecated_context ?in_function ?recarg env sexp + ty_expected = + (* Special errors for braced identifiers passed to records *) + let context = + match sexp.pexp_desc with + | Pexp_ident _ -> + if + sexp.pexp_attributes + |> List.exists (fun (attr, _) -> attr.txt = "res.braces") + then Some Error_message_utils.BracedIdent + else context + | _ -> context + in + let previous_saved_types = Cmt_format.get_saved_types () in + let exp = + Builtin_attributes.warning_scope sexp.pexp_attributes (fun () -> + type_expect_ ?deprecated_context ~context ?in_function ?recarg env sexp + ty_expected) + in + Cmt_format.set_saved_types + (Cmt_format.Partial_expression exp :: previous_saved_types); + exp + +and type_expect_ ?deprecated_context ~context ?in_function ?(recarg = Rejected) + env sexp ty_expected = + let loc = sexp.pexp_loc in + (* Record the expression type before unifying it with the expected type *) + let rue exp = + unify_exp ~context env (re exp) (instance env ty_expected); + exp + in + let process_optional_label (id, ld, e, opt) = + let exp_optional_attr = check_optional_attr env ld opt e.pexp_loc in + if label_is_optional ld && not exp_optional_attr then + let lid = mknoloc Longident.(Ldot (Lident "*predef*", "Some")) in + let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) in + (id, ld, e, opt) + else (id, ld, e, opt) + in + match sexp.pexp_desc with + | Pexp_ident lid -> + let path, desc = + Typetexp.find_value + ?deprecated_context: + (match deprecated_context with + | None -> Some Reference + | v -> v) + env lid.loc lid.txt + in + (if !Clflags.annotations then + let dloc = desc.Types.val_loc in + let annot = + if dloc.Location.loc_ghost then Annot.Iref_external + else Annot.Iref_internal dloc + in + let name = Path.name ~paren:Oprint.parenthesized_ident path in + Stypes.record (Stypes.An_ident (loc, name, annot))); + let is_recarg = + match (repr desc.val_type).desc with + | Tconstr (p, _, _) -> Path.is_constructor_typath p + | _ -> false + in + + (match (is_recarg, recarg, (repr desc.val_type).desc) with + | _, Allowed, _ | true, Required, _ | false, Rejected, _ -> () + | true, Rejected, _ | false, Required, (Tvar _ | Tconstr _) -> + raise (Error (loc, env, Inlined_record_escape)) + | false, Required, _ -> () (* will fail later *)); + rue + { + exp_desc = Texp_ident (path, lid, desc); + exp_loc = loc; + exp_extra = []; + exp_type = instance env desc.val_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_constant cst -> + let cst = constant_or_raise env loc cst in + rue + { + exp_desc = Texp_constant cst; + exp_loc = loc; + exp_extra = []; + exp_type = type_constant cst; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_let + ( Nonrecursive, + [{pvb_pat = spat; pvb_expr = sval; pvb_attributes = []}], + sbody ) + when contains_gadt env spat -> + (* TODO: allow non-empty attributes? *) + type_expect ~context:None ?in_function env + { + sexp with + pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody]); + } + ty_expected + | Pexp_let (rec_flag, spat_sexp_list, sbody) -> + let scp = + match (sexp.pexp_attributes, rec_flag) with + | [({txt = "#default"}, _)], _ -> None + | _, Recursive -> Some (Annot.Idef loc) + | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) + in + let pat_exp_list, new_env, unpacks = + type_let ~context:None env rec_flag spat_sexp_list scp true + in + let body = + type_expect ~context:None new_env (wrap_unpacks sbody unpacks) ty_expected + in + let () = + if rec_flag = Recursive then + Rec_check.check_recursive_bindings pat_exp_list + in + re + { + exp_desc = Texp_let (rec_flag, pat_exp_list, body); + exp_loc = loc; + exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_fun + { + arg_label = l; + default = Some default; + lhs = spat; + rhs = sbody; + arity; + async; + } -> + assert (is_optional l); + (* default allowed only with optional argument *) + let open Ast_helper in + let default_loc = default.pexp_loc in + let scases = + [ + Exp.case + (Pat.construct ~loc:default_loc + (mknoloc Longident.(Ldot (Lident "*predef*", "Some"))) + (Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))) + (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"))); + Exp.case + (Pat.construct ~loc:default_loc + (mknoloc Longident.(Ldot (Lident "*predef*", "None"))) + None) + default; + ] + in + let sloc = + { + Location.loc_start = spat.ppat_loc.Location.loc_start; + loc_end = default_loc.Location.loc_end; + loc_ghost = true; + } + in + let smatch = + Exp.match_ ~loc:sloc + (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) + scases + in + let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in + let body = + Exp.let_ ~loc Nonrecursive + ~attrs:[(mknoloc "#default", PStr [])] + [Vb.mk spat smatch] + sbody + in + type_function ?in_function ~arity ~async loc sexp.pexp_attributes env + ty_expected l + [Exp.case pat body] + | Pexp_fun + {arg_label = l; default = None; lhs = spat; rhs = sbody; arity; async} -> + type_function ?in_function ~arity ~async loc sexp.pexp_attributes env + ty_expected l + [Ast_helper.Exp.case spat sbody] + | Pexp_apply {funct = sfunct; args = sargs; partial; transformed_jsx} -> + assert (sargs <> []); + begin_def (); + (* one more level for non-returning functions *) + let funct = + type_exp ~deprecated_context:FunctionCall ~context:None env sfunct + in + let ty = instance env funct.exp_type in + end_def (); + wrap_trace_gadt_instances env (lower_args env []) ty; + begin_def (); + let total_app = not partial in + let context = type_clash_context_from_function sexp sfunct in + let args, ty_res, fully_applied = + match translate_unified_ops env funct sargs with + | Some (targs, result_type) -> (targs, result_type, true) + | None -> type_application ~context total_app env funct sargs + in + end_def (); + unify_var env (newvar ()) funct.exp_type; + + let mk_apply funct args = + rue + { + exp_desc = Texp_apply {funct; args; partial; transformed_jsx}; + exp_loc = loc; + exp_extra = []; + exp_type = ty_res; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + in + + let is_primitive = + match funct.exp_desc with + | Texp_ident (_, _, {val_kind = Val_prim _}) -> true + | _ -> false + in + + if fully_applied && not is_primitive then rue (mk_apply funct args) + else rue (mk_apply funct args) + | Pexp_match (sarg, caselist) -> + begin_def (); + let arg = type_exp ~context:None env sarg in + end_def (); + if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type; + generalize arg.exp_type; + let rec split_cases vc ec = function + | [] -> (List.rev vc, List.rev ec) + | ({pc_lhs = {ppat_desc = Ppat_exception p}} as c) :: rest -> + split_cases vc ({c with pc_lhs = p} :: ec) rest + | c :: rest -> split_cases (c :: vc) ec rest + in + let val_caselist, exn_caselist = split_cases [] [] caselist in + if val_caselist = [] && exn_caselist <> [] then + raise (Error (loc, env, No_value_clauses)); + (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully + empty pattern matching can be generated by Camlp4 with its + revised syntax. Let's accept it for backward compatibility. *) + let call_context = + if + Ext_list.exists sexp.pexp_attributes (fun ({txt}, _) -> + match txt with + | "let.unwrap" -> true + | _ -> false) + then `LetUnwrap + else `Switch + in + let val_cases, partial = + type_cases ~call_context env arg.exp_type ty_expected true loc + val_caselist + in + let exn_cases, _ = + type_cases ~call_context env Predef.type_exn ty_expected false loc + exn_caselist + in + re + { + exp_desc = Texp_match (arg, val_cases, exn_cases, partial); + exp_loc = loc; + exp_extra = []; + exp_type = instance env ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_try (sbody, caselist) -> + let body = type_expect ~context:None env sbody ty_expected in + let cases, _ = + type_cases ~call_context:`Try env Predef.type_exn ty_expected false loc + caselist + in + re + { + exp_desc = Texp_try (body, cases); + exp_loc = loc; + exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_tuple sexpl -> + assert (List.length sexpl >= 2); + let subtypes = List.map (fun _ -> newgenvar ()) sexpl in + let to_unify = newgenty (Ttuple subtypes) in + unify_exp_types ~context:None loc env to_unify ty_expected; + let expl = + List.map2 + (fun body ty -> type_expect ~context:None env body ty) + sexpl subtypes + in + re + { + exp_desc = Texp_tuple expl; + exp_loc = loc; + exp_extra = []; + (* Keep sharing *) + exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_construct (lid, sarg) -> + type_construct ~context env loc lid sarg ty_expected sexp.pexp_attributes + | Pexp_variant (l, sarg) -> ( + (* Keep sharing *) + let ty_expected0 = instance env ty_expected in + try + match + (sarg, expand_head env ty_expected, expand_head env ty_expected0) + with + | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> ( + let row = row_repr row in + match + ( row_field_repr (List.assoc l row.row_fields), + row_field_repr (List.assoc l row0.row_fields) ) + with + | Rpresent (Some ty), Rpresent (Some ty0) -> + let arg = type_argument ~context:None env sarg ty ty0 in + re + { + exp_desc = Texp_variant (l, Some arg); + exp_loc = loc; + exp_extra = []; + exp_type = ty_expected0; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | _ -> raise Not_found) + | _ -> raise Not_found + with Not_found -> + let arg = + may_map + (fun sarg -> type_expect ~context:None env sarg (newvar ())) + sarg + in + let arg_type = may_map (fun arg -> arg.exp_type) arg in + rue + { + exp_desc = Texp_variant (l, arg); + exp_loc = loc; + exp_extra = []; + exp_type = + newty + (Tvariant + { + row_fields = [(l, Rpresent arg_type)]; + row_more = newvar (); + row_closed = false; + row_fixed = false; + row_name = None; + }); + exp_attributes = sexp.pexp_attributes; + exp_env = env; + }) + | Pexp_record (lid_sexp_list, None) -> + let ty_record, opath, fields, repr_opt = + match extract_concrete_record env ty_expected with + | p0, p, fields, repr -> + (* XXX level may be wrong *) + (ty_expected, Some (p0, p), fields, Some repr) + | exception Not_found -> (newvar (), None, [], None) + in + + let get_jsx_component_error_info () = + match opath with + | Some (p, _) -> + get_jsx_component_props ~extract_concrete_typedecl env ty_record p + | None -> None + in + let jsx_component_error_info = get_jsx_component_error_info () in + let lbl_exp_list = + wrap_disambiguate "This record expression is expected to have" ty_record + (type_record_elem_list loc true env + (fun e k -> + k + (type_label_exp ~call_context:(`Regular jsx_component_error_info) + true env loc ty_record (process_optional_label e))) + opath lid_sexp_list) + (fun x -> x) + in + unify_exp_types ~context:None loc env ty_record (instance env ty_expected); + check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; + let label_descriptions, representation = + match (lbl_exp_list, repr_opt) with + | ( (_, {lbl_all = label_descriptions; lbl_repres = representation}, _, _) + :: _, + _ ) -> + (label_descriptions, representation) + | [], Some representation when lid_sexp_list = [] -> + let filter_missing (ld : Types.label_declaration) = + if ld.ld_optional then None else Some (Ident.name ld.ld_id) + in + let labels_missing = fields |> List.filter_map filter_missing in + if labels_missing <> [] then + raise + (Error + ( loc, + env, + Labels_missing + { + labels = labels_missing; + jsx_component_info = jsx_component_error_info; + } )); + ([||], representation) + | [], _ -> + if fields = [] && repr_opt <> None then ([||], Record_regular) + else raise (Error (loc, env, Empty_record_literal)) + in + let labels_missing = ref [] in + let label_definitions = + let matching_label lbl = + List.find + (fun (_, lbl', _, _) -> lbl'.lbl_pos = lbl.lbl_pos) + lbl_exp_list + in + Array.map + (fun lbl -> + match matching_label lbl with + | lid, _lbl, lbl_exp, _ -> Overridden (lid, lbl_exp) + | exception Not_found -> + if not (label_is_optional lbl) then + labels_missing := lbl.lbl_name :: !labels_missing; + Overridden + ({loc; txt = Lident lbl.lbl_name}, option_none lbl.lbl_arg loc)) + label_descriptions + in + if !labels_missing <> [] then + raise + (Error + ( loc, + env, + Labels_missing + { + labels = List.rev !labels_missing; + jsx_component_info = jsx_component_error_info; + } )); + let fields = + Array.map2 + (fun descr def -> (descr, def, false)) + label_descriptions label_definitions + in + re + { + exp_desc = + Texp_record {fields; representation; extended_expression = None}; + exp_loc = loc; + exp_extra = []; + exp_type = instance env ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_record (lid_sexp_list, Some sexp) -> + assert (lid_sexp_list <> []); + let exp = type_exp ~context:None ~recarg env sexp in + let ty_record, opath = + let get_path ty = + try + let p0, p, _, _ = extract_concrete_record env ty in + (* XXX level may be wrong *) + Some (p0, p) + with Not_found -> None + in + match get_path ty_expected with + | None -> ( + match get_path exp.exp_type with + | None -> (newvar (), None) + | Some (_, p') as op -> + let decl = Env.find_type p' env in + begin_def (); + let ty = newconstr p' (instance_list env decl.type_params) in + end_def (); + generalize_structure ty; + (ty, op)) + | op -> (ty_expected, op) + in + let get_jsx_component_error_info = + get_jsx_component_error_info ~extract_concrete_typedecl opath env + ty_record + in + let closed = false in + let jsx_component_error_info = get_jsx_component_error_info () in + let lbl_exp_list = + wrap_disambiguate "This record expression is expected to have" ty_record + (type_record_elem_list loc closed env + (fun e k -> + k + (type_label_exp ~call_context:(`Regular jsx_component_error_info) + true env loc ty_record (process_optional_label e))) + opath lid_sexp_list) + (fun x -> x) + in + unify_exp_types ~context:None loc env ty_record (instance env ty_expected); + check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; + let opt_exp, label_definitions = + let _lid, lbl, _lbl_exp, _opt = List.hd lbl_exp_list in + let matching_label lbl = + List.find + (fun (_, lbl', _, _) -> lbl'.lbl_pos = lbl.lbl_pos) + lbl_exp_list + in + let ty_exp = instance env exp.exp_type in + let unify_kept lbl = + let _, ty_arg1, ty_res1 = instance_label false lbl in + unify_exp_types ~context:None exp.exp_loc env ty_exp ty_res1; + match matching_label lbl with + | lid, _lbl, lbl_exp, _ -> + (* do not connect result types for overridden labels *) + Overridden (lid, lbl_exp) + | exception Not_found -> + let _, ty_arg2, ty_res2 = instance_label false lbl in + unify_exp_types ~context:None loc env ty_arg1 ty_arg2; + unify_exp_types ~context:None loc env (instance env ty_expected) + ty_res2; + Kept ty_arg1 + in + let label_definitions = Array.map unify_kept lbl.lbl_all in + (Some {exp with exp_type = ty_exp}, label_definitions) + in + let num_fields = + match lbl_exp_list with + | [] -> assert false + | (_, lbl, _, _) :: _ -> Array.length lbl.lbl_all + in + let opt_exp = + if List.length lid_sexp_list = num_fields then ( + Location.prerr_warning loc Warnings.Useless_record_with; + None) + else opt_exp + in + let label_descriptions, representation = + let _, {lbl_all; lbl_repres}, _, _ = List.hd lbl_exp_list in + (lbl_all, lbl_repres) + in + let fields = + Array.map2 + (fun descr def -> (descr, def, false)) + label_descriptions label_definitions + in + re + { + exp_desc = + Texp_record {fields; representation; extended_expression = opt_exp}; + exp_loc = loc; + exp_extra = []; + exp_type = instance env ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_field (srecord, lid) -> + let record, label, _ = type_label_access env srecord lid in + let _, ty_arg, ty_res = instance_label false label in + unify_exp ~context:None env record ty_res; + rue + { + exp_desc = Texp_field (record, lid, label); + exp_loc = loc; + exp_extra = []; + exp_type = ty_arg; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_setfield (srecord, lid, snewval) -> + let record, label, opath = type_label_access env srecord lid in + let ty_record = if opath = None then newvar () else record.exp_type in + let label_loc, label, newval, _ = + type_label_exp ~call_context:`SetRecordField false env loc ty_record + (lid, label, snewval, false) + in + unify_exp ~context:None env record ty_record; + if label.lbl_mut = Immutable then + raise (Error (loc, env, Label_not_mutable lid.txt)); + Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes + (Longident.last lid.txt); + rue + { + exp_desc = Texp_setfield (record, label_loc, label, newval); + exp_loc = loc; + exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_array sargl -> + let ty = newgenvar () in + let to_unify = Predef.type_array ty in + unify_exp_types ~context:None loc env to_unify ty_expected; + let argl = + List.map + (fun sarg -> type_expect ~context:(Some ArrayValue) env sarg ty) + sargl + in + re + { + exp_desc = Texp_array argl; + exp_loc = loc; + exp_extra = []; + exp_type = instance env ty_expected; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_ifthenelse (scond, sifso, sifnot) -> ( + (* TODO(attributes) Unify the attribute handling in the parser and rest of the compiler. *) + let is_ternary = + let rec has_ternary = function + | [] -> false + | ({Location.txt = "res.ternary"}, _) :: _ -> true + | _ :: rest -> has_ternary rest + in + has_ternary sexp.pexp_attributes + in + let return_context = + if is_ternary then Some TernaryReturn else Some IfReturn + in + let cond = + type_expect ~context:(Some IfCondition) env scond Predef.type_bool + in + match sifnot with + | None -> + let ifso = + type_expect ~context:return_context env sifso Predef.type_unit + in + rue + { + exp_desc = Texp_ifthenelse (cond, ifso, None); + exp_loc = loc; + exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Some sifnot -> + let ifso = type_expect ~context:return_context env sifso ty_expected in + let ifnot = type_expect ~context:return_context env sifnot ty_expected in + (* Keep sharing *) + unify_exp ~context:return_context env ifnot ifso.exp_type; + re + { + exp_desc = Texp_ifthenelse (cond, ifso, Some ifnot); + exp_loc = loc; + exp_extra = []; + exp_type = ifso.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + }) + | Pexp_sequence (sexp1, sexp2) -> + let exp1 = type_statement ~context:None env sexp1 in + let exp2 = type_expect ~context:None env sexp2 ty_expected in + re + { + exp_desc = Texp_sequence (exp1, exp2); + exp_loc = loc; + exp_extra = []; + exp_type = exp2.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_while (scond, sbody) -> + let cond = + type_expect ~context:(Some WhileCondition) env scond Predef.type_bool + in + let body = type_statement ~context:None env sbody in + rue + { + exp_desc = Texp_while (cond, body); + exp_loc = loc; + exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_for (param, slow, shigh, dir, sbody) -> + let low = + type_expect ~context:(Some ForLoopCondition) env slow Predef.type_int + in + let high = + type_expect ~context:(Some ForLoopCondition) env shigh Predef.type_int + in + let id, new_env = + match param.ppat_desc with + | Ppat_any -> (Ident.create "_for", env) + | Ppat_var {txt} -> + Env.enter_value txt + { + val_type = instance_def Predef.type_int; + val_attributes = []; + val_kind = Val_reg; + Types.val_loc = loc; + } + env + ~check:(fun s -> Warnings.Unused_for_index s) + | _ -> raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) + in + let body = type_statement ~context:None new_env sbody in + rue + { + exp_desc = Texp_for (id, param, low, high, dir, body); + exp_loc = loc; + exp_extra = []; + exp_type = instance_def Predef.type_unit; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_constraint (sarg, sty) -> + let separate = true in + (* always separate, 1% slowdown for lablgtk *) + if separate then begin_def (); + let cty = Typetexp.transl_simple_type env false sty in + let ty = cty.ctyp_type in + let arg, ty' = + if separate then ( + end_def (); + generalize_structure ty; + ( type_argument ~context:None env sarg ty (instance env ty), + instance env ty )) + else (type_argument ~context:None env sarg ty ty, ty) + in + rue + { + exp_desc = arg.exp_desc; + exp_loc = arg.exp_loc; + exp_type = ty'; + exp_attributes = arg.exp_attributes; + exp_env = env; + exp_extra = + (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra; + } + | Pexp_coerce (sarg, (), sty') -> + let separate = true in + (* always separate, 1% slowdown for lablgtk *) + (* Also see PR#7199 for a problem with the following: + let separate = Env.has_local_constraints env in*) + let arg, ty', cty' = + let cty', force = Typetexp.transl_simple_type_delayed env sty' in + let ty' = cty'.ctyp_type in + if separate then begin_def (); + let arg = type_exp ~context:None env sarg in + let gen = + if separate then ( + end_def (); + let tv = newvar () in + let gen = generalizable tv.level arg.exp_type in + (try unify_var env tv arg.exp_type + with Unify trace -> + raise + (Error (arg.exp_loc, env, Expr_type_clash {trace; context = None}))); + gen) + else true + in + (if + (not gen) + && + (* first try a single coercion *) + let snap = snapshot () in + let ty, _b = enlarge_type env ty' in + try + force (); + Ctype.unify env arg.exp_type ty; + true + with Unify _ -> + backtrack snap; + false + then () + else + try + let force' = subtype env arg.exp_type ty' in + force (); + force' () + with Subtype (tr1, tr2, ctx) -> + (* prerr_endline "coercion failed"; *) + raise (Error (loc, env, Not_subtype (tr1, tr2, ctx)))); + (arg, ty', cty') + in + rue + { + exp_desc = arg.exp_desc; + exp_loc = arg.exp_loc; + exp_type = ty'; + exp_attributes = arg.exp_attributes; + exp_env = env; + exp_extra = + (Texp_coerce cty', loc, sexp.pexp_attributes) :: arg.exp_extra; + } + | Pexp_send (e, {txt = met}) -> ( + let obj = type_exp ~context:None env e in + let obj_meths = ref None in + try + let meth, exp, typ = + match obj.exp_desc with + | _ -> (Tmeth_name met, None, filter_method env met Public obj.exp_type) + in + let typ = + match repr typ with + | {desc = Tpoly (ty, [])} -> instance env ty + | {desc = Tpoly (ty, tl); level = _} -> snd (instance_poly false tl ty) + | {desc = Tvar _} as ty -> + let ty' = newvar () in + unify env (instance_def ty) (newty (Tpoly (ty', []))); + (* if not !Clflags.nolabels then + Location.prerr_warning loc (Warnings.Unknown_method met); *) + ty' + | _ -> assert false + in + rue + { + exp_desc = Texp_send (obj, meth, exp); + exp_loc = loc; + exp_extra = []; + exp_type = typ; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + with Unify _ -> + let valid_methods = + match !obj_meths with + | Some meths -> + Some (Meths.fold (fun meth _meth_ty li -> meth :: li) !meths []) + | None -> ( + match (expand_head env obj.exp_type).desc with + | Tobject (fields, _) -> + let fields, _ = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if meth_kind = Fpresent then meth :: li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None) + in + raise + (Error + (e.pexp_loc, env, Undefined_method (obj.exp_type, met, valid_methods))) + ) + | Pexp_letmodule (name, smodl, sbody) -> + let ty = newvar () in + (* remember original level *) + begin_def (); + Ident.set_current_time ty.level; + let context = Typetexp.narrow () in + let modl = !type_module env smodl in + let id, new_env = Env.enter_module name.txt modl.mod_type env in + Ctype.init_def (Ident.current_time ()); + Typetexp.widen context; + let body = type_expect ~context:None new_env sbody ty_expected in + (* go back to original level *) + end_def (); + (* Unification of body.exp_type with the fresh variable ty + fails if and only if the prefix condition is violated, + i.e. if generative types rooted at id show up in the + type body.exp_type. Thus, this unification enforces the + scoping condition on "let module". *) + (* Note that this code will only be reached if ty_expected + is a generic type variable, otherwise the error will occur + above in type_expect *) + (try Ctype.unify_var new_env ty body.exp_type + with Unify _ -> + raise (Error (loc, env, Scoping_let_module (name.txt, body.exp_type)))); + re + { + exp_desc = Texp_letmodule (id, name, modl, body); + exp_loc = loc; + exp_extra = []; + exp_type = ty; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_letexception (cd, sbody) -> + let cd, newenv = Typedecl.transl_exception env cd in + let body = type_expect ~context:None newenv sbody ty_expected in + re + { + exp_desc = Texp_letexception (cd, body); + exp_loc = loc; + exp_extra = []; + exp_type = body.exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_assert e -> + let cond = + type_expect ~context:(Some AssertCondition) env e Predef.type_bool + in + let exp_type = + match cond.exp_desc with + | Texp_construct (_, {cstr_name = "false"}, _) -> instance env ty_expected + | _ -> instance_def Predef.type_unit + in + rue + { + exp_desc = Texp_assert cond; + exp_loc = loc; + exp_extra = []; + exp_type; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_newtype ({txt = name}, sbody) -> + let ty = newvar () in + (* remember original level *) + begin_def (); + (* Create a fake abstract type declaration for name. *) + let level = get_current_level () in + let decl = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = []; + type_newtype_level = Some (level, level); + type_loc = loc; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + in + Ident.set_current_time ty.level; + let id, new_env = Env.enter_type name decl env in + Ctype.init_def (Ident.current_time ()); + + let body = type_exp ~context:None new_env sbody in + (* Replace every instance of this type constructor in the resulting + type. *) + let seen = Hashtbl.create 8 in + let rec replace t = + if Hashtbl.mem seen t.id then () + else ( + Hashtbl.add seen t.id (); + match t.desc with + | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty + | _ -> Btype.iter_type_expr replace t) + in + let ety = Subst.type_expr Subst.identity body.exp_type in + replace ety; + (* back to original level *) + end_def (); + + (* lower the levels of the result type *) + (* unify_var env ty ety; *) + + (* non-expansive if the body is non-expansive, so we don't introduce + any new extra node in the typed AST. *) + rue + { + body with + exp_loc = loc; + exp_type = ety; + exp_extra = + (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra; + } + | Pexp_pack m -> + let p, nl = + match Ctype.expand_head env (instance env ty_expected) with + | {desc = Tpackage (p, nl, _tl)} -> (p, nl) + | {desc = Tvar _} -> raise (Error (loc, env, Cannot_infer_signature)) + | _ -> raise (Error (loc, env, Not_a_packed_module ty_expected)) + in + let modl, tl' = !type_package env m p nl in + rue + { + exp_desc = Texp_pack modl; + exp_loc = loc; + exp_extra = []; + exp_type = newty (Tpackage (p, nl, tl')); + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | Pexp_open (ovf, lid, e) -> + let path, newenv = !type_open ovf env sexp.pexp_loc lid in + let exp = type_expect ~context:None newenv e ty_expected in + { + exp with + exp_extra = + (Texp_open (ovf, path, lid, newenv), loc, sexp.pexp_attributes) + :: exp.exp_extra; + } + | Pexp_extension + ( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, + payload ) -> ( + match payload with + | PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_construct (lid, None); _}, _); + }; + ] -> + let path = + match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with + | Cstr_extension path -> path + | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) + in + rue + { + exp_desc = Texp_extension_constructor (lid, path); + exp_loc = loc; + exp_extra = []; + exp_type = instance_def Predef.type_extension_constructor; + exp_attributes = sexp.pexp_attributes; + exp_env = env; + } + | _ -> raise (Error (loc, env, Invalid_extension_constructor_payload))) + | Pexp_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pexp_await _ -> (* should be handled earlier *) assert false + | Pexp_jsx_element _ -> + raise (Error (sexp.pexp_loc, Env.empty, Jsx_not_enabled)) + +and type_function ?in_function ~arity ~async loc attrs env ty_expected_ l + caselist = + let state = Warnings.backup () in + (* Disable Unerasable_optional_argument for uncurried functions *) + let unerasable_optional_argument = + Warnings.number Unerasable_optional_argument + in + Warnings.parse_options false ("-" ^ string_of_int unerasable_optional_argument); + let ty_expected = + match arity with + | None -> ty_expected_ + | Some arity -> + let fun_t = + newty (Tarrow ({lbl = l; typ = newvar ()}, newvar (), Cok, Some arity)) + in + unify_exp_types ~context:None loc env fun_t ty_expected_; + fun_t + in + let loc_fun, ty_fun = + match in_function with + | Some p -> p + | None -> (loc, instance env ty_expected) + in + let separate = Env.has_local_constraints env in + if separate then begin_def (); + let ty_arg, ty_res = + try filter_arrow ~env ~arity (instance env ty_expected) l + with Unify _ -> ( + match expand_head env ty_expected with + | {desc = Tarrow _} as ty -> + raise (Error (loc, env, Abstract_wrong_label (l, ty))) + | _ -> + raise + (Error (loc_fun, env, Too_many_arguments (in_function <> None, ty_fun)))) + in + let ty_arg = + if is_optional l then ( + let tv = newvar () in + (try unify env ty_arg (type_option tv) with Unify _ -> assert false); + type_option tv) + else ty_arg + in + if separate then ( + end_def (); + generalize_structure ty_arg; + generalize_structure ty_res); + let cases, partial = + type_cases ~call_context:`Function ~in_function:(loc_fun, ty_fun) env ty_arg + ty_res true loc caselist + in + let case = List.hd cases in + if is_optional l && not_function env ty_res then + Location.prerr_warning case.c_lhs.pat_loc + Warnings.Unerasable_optional_argument; + let param = name_pattern "param" cases in + let exp_type = + instance env + (newgenty (Tarrow ({lbl = l; typ = ty_arg}, ty_res, Cok, arity))) + in + Warnings.restore state; + re + { + exp_desc = + Texp_function {arg_label = l; arity; param; case; partial; async}; + exp_loc = loc; + exp_extra = []; + exp_type; + exp_attributes = attrs; + exp_env = env; + } + +and type_label_access env srecord lid = + let record = type_exp ~context:None ~recarg:Allowed env srecord in + let ty_exp = record.exp_type in + let opath = + try + match extract_concrete_typedecl env ty_exp with + | p0, _, {type_attributes} + when Path.same p0 Predef.path_dict + && Dict_type_helpers.has_dict_attribute type_attributes -> + (* [dict] Cover the case when trying to direct field access on a dict, e.g. `someDict.name`. + We need to disallow this because the fact that a dict is represented as a single magic + field record internally is just an implementation detail, and not intended to be exposed + to the user. *) + raise (Error (lid.loc, env, Field_access_on_dict_type)) + | p0, p, {type_kind = Type_record _} -> Some (p0, p) + | _ -> None + with Not_found -> None + in + let labels = Typetexp.find_all_labels env lid.loc lid.txt in + let label = + wrap_disambiguate "This expression has" ty_exp + (Label.disambiguate ~from_type:ty_exp lid env opath) + labels + in + (record, label, opath) + +(* Typing format strings for printing or reading. + These formats are used by functions in modules Printf, Format, and Scanf. + (Handling of * modifiers contributed by Thorsten Ohl.) *) +and type_label_exp ~call_context create env loc ty_expected + (lid, label, sarg, opt) = + (* Here also ty_expected may be at generic_level *) + begin_def (); + let separate = Env.has_local_constraints env in + if separate then ( + begin_def (); + begin_def ()); + let vars, ty_arg, ty_res = instance_label true label in + if separate then ( + end_def (); + (* Generalize label information *) + generalize_structure ty_arg; + generalize_structure ty_res); + (try unify env (instance_def ty_res) (instance env ty_expected) + with Unify trace -> + raise (Error (lid.loc, env, Label_mismatch (lid.txt, trace)))); + (* Instantiate so that we can generalize internal nodes *) + let ty_arg = instance_def ty_arg in + if separate then ( + end_def (); + (* Generalize information merged from ty_expected *) + generalize_structure ty_arg); + if label.lbl_private = Private then + if create then raise (Error (loc, env, Private_type ty_expected)) + else raise (Error (lid.loc, env, Private_label (lid.txt, ty_expected))); + let arg = + let snap = if vars = [] then None else Some (Btype.snapshot ()) in + let field_name = Longident.last lid.txt in + let field_context = + match call_context with + | `SetRecordField -> Some (Error_message_utils.SetRecordField field_name) + | `Regular jsx -> + Some + (Error_message_utils.RecordField + {jsx; record_type = ty_expected; field_name; optional = false}) + in + let arg = + type_argument ~context:field_context env sarg ty_arg (instance env ty_arg) + in + end_def (); + try + check_univars env (vars <> []) "field value" arg label.lbl_arg vars; + arg + with exn when not (is_nonexpansive arg) -> ( + try + (* Try to retype without propagating ty_arg, cf PR#4862 *) + may Btype.backtrack snap; + begin_def (); + let arg = type_exp ~context:field_context env sarg in + end_def (); + generalize_expansive env arg.exp_type; + unify_exp ~context:field_context env arg ty_arg; + check_univars env false "field value" arg label.lbl_arg vars; + arg + with + | Error (_, _, Less_general _) as e -> raise e + | _ -> raise exn (* In case of failure return the first error *)) + in + (lid, label, {arg with exp_type = instance env arg.exp_type}, opt) + +and type_argument ~context ?recarg env sarg ty_expected' ty_expected = + let texp = type_expect ~context ?recarg env sarg ty_expected' in + unify_exp ~context env texp ty_expected; + texp + +(** This is ad-hoc translation for unifying specific primitive operations + See [Unified_ops] module for detailed explanation. + *) +and translate_unified_ops (env : Env.t) (funct : Typedtree.expression) + (sargs : sargs) : (targs * Types.type_expr) option = + match funct.exp_desc with + | Texp_ident (path, _, _) -> ( + let entry = Hashtbl.find_opt Unified_ops.index_by_path (Path.name path) in + match (entry, sargs) with + | Some {form = Unary; specialization}, [(lhs_label, lhs_expr)] -> + let lhs = type_exp ~context:None env lhs_expr in + let lhs_type = expand_head env lhs.exp_type in + let result_type = + match (lhs_type.desc, specialization) with + | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> + instance_def Predef.type_int + | Tconstr (path, _, _), {bool = Some _} + when Path.same path Predef.path_bool -> + instance_def Predef.type_bool + | Tconstr (path, _, _), {float = Some _} + when Path.same path Predef.path_float -> + instance_def Predef.type_float + | Tconstr (path, _, _), {bigint = Some _} + when Path.same path Predef.path_bigint -> + instance_def Predef.type_bigint + | Tconstr (path, _, _), {string = Some _} + when Path.same path Predef.path_string -> + instance_def Predef.type_string + | _ -> ( + try + unify env lhs_type (instance_def Predef.type_int); + instance_def Predef.type_int + with Ctype.Unify trace -> + raise + (Error (lhs.exp_loc, env, Expr_type_clash {trace; context = None})) + ) + in + let targs = [(lhs_label, Some lhs)] in + Some (targs, result_type) + | ( Some {form = Binary; specialization}, + [(lhs_label, lhs_expr); (rhs_label, rhs_expr)] ) -> + let lhs = type_exp ~context:None env lhs_expr in + let lhs_type = expand_head env lhs.exp_type in + let rhs = type_exp ~context:None env rhs_expr in + let rhs_type = expand_head env rhs.exp_type in + let lhs, rhs, result_type = + (* Rule 1. Try unifying to lhs *) + match (lhs_type.desc, specialization) with + | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> + let rhs = type_expect ~context:None env rhs_expr Predef.type_int in + (lhs, rhs, instance_def Predef.type_int) + | Tconstr (path, _, _), {bool = Some _} + when Path.same path Predef.path_bool -> + let rhs = type_expect ~context:None env rhs_expr Predef.type_bool in + (lhs, rhs, instance_def Predef.type_bool) + | Tconstr (path, _, _), {float = Some _} + when Path.same path Predef.path_float -> + let rhs = type_expect ~context:None env rhs_expr Predef.type_float in + (lhs, rhs, instance_def Predef.type_float) + | Tconstr (path, _, _), {bigint = Some _} + when Path.same path Predef.path_bigint -> + let rhs = type_expect ~context:None env rhs_expr Predef.type_bigint in + (lhs, rhs, instance_def Predef.type_bigint) + | Tconstr (path, _, _), {string = Some _} + when Path.same path Predef.path_string -> + let rhs = type_expect ~context:None env rhs_expr Predef.type_string in + (lhs, rhs, instance_def Predef.type_string) + | _ -> ( + (* Rule 2. Try unifying to rhs *) + match (rhs_type.desc, specialization) with + | Tconstr (path, _, _), _ when Path.same path Predef.path_int -> + let lhs = type_expect ~context:None env lhs_expr Predef.type_int in + (lhs, rhs, instance_def Predef.type_int) + | Tconstr (path, _, _), {bool = Some _} + when Path.same path Predef.path_bool -> + let lhs = type_expect ~context:None env lhs_expr Predef.type_bool in + (lhs, rhs, instance_def Predef.type_bool) + | Tconstr (path, _, _), {float = Some _} + when Path.same path Predef.path_float -> + let lhs = + type_expect ~context:None env lhs_expr Predef.type_float + in + (lhs, rhs, instance_def Predef.type_float) + | Tconstr (path, _, _), {bigint = Some _} + when Path.same path Predef.path_bigint -> + let lhs = + type_expect ~context:None env lhs_expr Predef.type_bigint + in + (lhs, rhs, instance_def Predef.type_bigint) + | Tconstr (path, _, _), {string = Some _} + when Path.same path Predef.path_string -> + let lhs = + type_expect ~context:None env lhs_expr Predef.type_string + in + (lhs, rhs, instance_def Predef.type_string) + | _ -> + (* Rule 3. Fallback to int *) + let lhs = type_expect ~context:None env lhs_expr Predef.type_int in + let rhs = type_expect ~context:None env rhs_expr Predef.type_int in + (lhs, rhs, instance_def Predef.type_int)) + in + let targs = [(lhs_label, Some lhs); (rhs_label, Some rhs)] in + Some (targs, result_type) + | _ -> None) + | _ -> None + +and type_application ~context total_app env funct (sargs : sargs) : + targs * Types.type_expr * bool = + let result_type omitted ty_fun = + List.fold_left + (fun ty_fun (l, ty, lv) -> + newty2 lv (Tarrow ({lbl = l; typ = ty}, ty_fun, Cok, None))) + ty_fun omitted + in + let has_label l ty_fun = + let ls, tvar = list_labels env ty_fun in + tvar || List.mem l ls + in + let ignored = ref [] in + let force_tvar = + let t = funct.exp_type in + match (expand_head env t).desc with + | Tvar _ when total_app -> true + | _ -> false + in + let has_arity funct = + if force_tvar then Some (List.length sargs) + else + match (expand_head env funct.exp_type).desc with + | Tarrow (_, _, _, Some arity) -> Some arity + | _ -> None + in + let force_uncurried_type funct = + if force_tvar then () + else if Ctype.get_arity env funct.exp_type = None then + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) )) + in + let get_max_arity funct = + match has_arity funct with + | Some arity -> + if List.length sargs > arity then + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch + { + function_type = funct.exp_type; + expected_arity = arity; + provided_arity = List.length sargs; + provided_args = sargs |> List.map (fun (a, _) -> a); + function_name = extract_function_name funct; + } )); + arity + | None -> max_int + in + let update_uncurried_arity ~nargs funct new_t = + match has_arity funct with + | Some arity -> + let newarity = arity - nargs in + let fully_applied = newarity <= 0 in + (if total_app && not fully_applied then + let required_args = List.length sargs in + raise + (Error + ( funct.exp_loc, + env, + Uncurried_arity_mismatch + { + function_type = funct.exp_type; + expected_arity = required_args + newarity; + provided_arity = required_args; + provided_args = sargs |> List.map (fun (a, _) -> a); + function_name = extract_function_name funct; + } ))); + let new_t = + if fully_applied then new_t + else + match new_t.desc with + | Tarrow (arg, ret, c, _) -> + {new_t with desc = Tarrow (arg, ret, c, Some newarity)} + | _ -> new_t + in + (fully_applied, new_t) + | None -> (false, new_t) + in + let rec type_unknown_args max_arity ~(args : lazy_args) ~top_arity omitted + ty_fun (syntax_args : sargs) : targs * _ = + match syntax_args with + | [] -> + let collect_args () = + ( List.map + (function + | l, None -> (l, None) + | l, Some f -> (l, Some (f ()))) + (List.rev args), + instance env (result_type omitted ty_fun) ) + in + if List.length args < max_arity && total_app then + match (expand_head env ty_fun).desc with + | Tarrow ({lbl; typ = t1}, t2, _, _) when is_optional lbl -> + ignored := (lbl, t1, ty_fun.level) :: !ignored; + let arg = + (lbl, Some (fun () -> option_none (instance env t1) Location.none)) + in + type_unknown_args max_arity ~args:(arg :: args) ~top_arity:None + omitted t2 [] + | _ -> collect_args () + else collect_args () + | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] + when total_app && omitted = [] && args <> [] + && List.length args = List.length !ignored -> + (* foo(. ) treated as empty application if all args are optional (hence ignored) *) + type_unknown_args max_arity ~args ~top_arity:None omitted ty_fun [] + | (l1, sarg1) :: sargl -> + let ty1, ty2 = + let ty_fun = expand_head env ty_fun in + let arity_ok = List.length args < max_arity in + match ty_fun.desc with + | Tvar _ when force_tvar -> + (* This is a total application when the toplevel type is a polymorphic variable, + so the function type including arity can be inferred. *) + let t1 = newvar () and t2 = newvar () in + if ty_fun.level >= t1.level && not_identity funct.exp_desc then + Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; + unify env ty_fun + (newty + (Tarrow + ({lbl = l1; typ = t1}, t2, Clink (ref Cunknown), top_arity))); + (t1, t2) + | Tarrow ({lbl = l; typ = t1}, t2, _, _) + when Asttypes.same_arg_label l l1 && arity_ok -> + (t1, t2) + | td -> ( + let ty_fun = + match td with + | Tarrow _ -> newty td + | _ -> ty_fun + in + let ty_res = result_type (omitted @ !ignored) ty_fun in + match ty_res.desc with + | Tarrow _ -> + if not arity_ok then + raise + (Error + (sarg1.pexp_loc, env, Apply_wrong_label (l1, funct.exp_type))) + else if not (has_label l1 ty_fun) then + raise + (Error (sarg1.pexp_loc, env, Apply_wrong_label (l1, ty_res))) + else raise (Error (funct.exp_loc, env, Incoherent_label_order)) + | _ -> + raise + (Error + ( funct.exp_loc, + env, + Apply_non_function (expand_head env funct.exp_type) ))) + in + let optional = is_optional l1 in + let arg1 () = + let arg1 = type_expect ~context env sarg1 ty1 in + if optional then unify_exp ~context env arg1 (type_option (newvar ())); + arg1 + in + type_unknown_args max_arity ~args:((l1, Some arg1) :: args) + ~top_arity:None omitted ty2 sargl + in + let rec type_args ~context max_arity args omitted ~ty_fun ty_fun0 + ~(sargs : sargs) ~top_arity = + match (expand_head env ty_fun, expand_head env ty_fun0) with + | ( {desc = Tarrow ({lbl = l; typ = ty}, ty_fun, com, _); level = lv}, + {desc = Tarrow ({typ = ty0}, ty_fun0, _, _)} ) + when sargs <> [] && commu_repr com = Cok && List.length args < max_arity + -> + let name = label_name l and optional = is_optional l in + let sargs, omitted, arg = + match extract_label name sargs with + | None -> + if optional && (total_app || label_assoc Nolabel sargs) then ( + ignored := (l, ty, lv) :: !ignored; + ( sargs, + omitted, + Some (fun () -> option_none (instance env ty) Location.none) )) + else (sargs, (l, ty, lv) :: omitted, None) + | Some (l', sarg0, sargs) -> + if (not optional) && is_optional l' then + Location.prerr_warning sarg0.pexp_loc + (Warnings.Nonoptional_label (Printtyp.string_of_label l)); + ( sargs, + omitted, + Some + (if (not optional) || is_optional l' then fun () -> + type_argument + ~context: + (type_clash_context_for_function_argument ~label:l' context + sarg0) + env sarg0 ty ty0 + else fun () -> + option_some + (type_argument + ~context: + (Some + (FunctionArgument + { + optional = true; + name = + (match l' with + | Nolabel -> None + | Optional l | Labelled l -> Some l.txt); + })) + env sarg0 + (extract_option_type env ty) + (extract_option_type env ty0))) ) + in + type_args ~context max_arity ((l, arg) :: args) omitted ~ty_fun ty_fun0 + ~sargs ~top_arity + | _ -> + type_unknown_args max_arity ~args ~top_arity omitted ty_fun0 + sargs (* This is the hot path for non-labeled function*) + in + if total_app then force_uncurried_type funct; + let max_arity = get_max_arity funct in + let top_arity = if total_app then Some max_arity else None in + match sargs with + (* Special case for ignore: avoid discarding warning *) + | [(Nolabel, sarg)] when is_ignore ~env ~arity:top_arity funct -> + let ty_arg, ty_res = + filter_arrow ~env ~arity:top_arity (instance env funct.exp_type) Nolabel + in + let exp = type_expect ~context env sarg ty_arg in + (match (expand_head env exp.exp_type).desc with + | Tarrow _ when not total_app -> + Location.prerr_warning exp.exp_loc Warnings.Partial_application + | Tvar _ -> + Delayed_checks.add_delayed_check (fun () -> + check_application_result env false exp) + | _ -> ()); + ([(Nolabel, Some exp)], ty_res, false) + | _ -> + let targs, ret_t = + type_args ~context max_arity [] [] ~ty_fun:funct.exp_type + (instance env funct.exp_type) + ~sargs ~top_arity + in + let fully_applied, ret_t = + update_uncurried_arity funct + ~nargs:(List.length !ignored + List.length sargs) + ret_t + in + (targs, ret_t, fully_applied) + +and type_construct ~context env loc lid sarg ty_expected attrs = + let opath = + try + let p0, p, _ = extract_concrete_variant env ty_expected in + Some (p0, p) + with Not_found -> None + in + let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in + let constr = + wrap_disambiguate "This variant expression is expected to have" ty_expected + (Constructor.disambiguate lid env opath) + constrs + in + Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; + Builtin_attributes.check_deprecated loc constr.cstr_attributes + constr.cstr_name; + let sargs = + match sarg with + | None -> [] + | Some {pexp_desc = Pexp_tuple sel} + when constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs -> + sel + | Some se -> [se] + in + if List.length sargs <> constr.cstr_arity then + raise + (Error + ( loc, + env, + Constructor_arity_mismatch + { + name = lid.txt; + constuctor = constr; + expected = constr.cstr_arity; + provided = List.length sargs; + } )); + let separate = Env.has_local_constraints env in + if separate then ( + begin_def (); + begin_def ()); + let ty_args, ty_res = instance_constructor constr in + let texp = + re + { + exp_desc = Texp_construct (lid, constr, []); + exp_loc = loc; + exp_extra = []; + exp_type = ty_res; + exp_attributes = attrs; + exp_env = env; + } + in + (* Forward context if this is a Some constructor injected (meaning it's + an optional field) *) + let context = + match lid.txt with + | Longident.Ldot (Lident "*predef*", "Some") -> ( + match context with + | Some (RecordField {record_type; jsx; field_name}) -> + Some + (Error_message_utils.RecordField + {record_type; jsx; field_name; optional = true}) + | _ -> None) + | _ -> None + in + if separate then ( + end_def (); + generalize_structure ty_res; + unify_exp ~context env + {texp with exp_type = instance_def ty_res} + (instance env ty_expected); + end_def (); + List.iter generalize_structure ty_args; + generalize_structure ty_res); + let ty_args0, ty_res = + match instance_list env (ty_res :: ty_args) with + | t :: tl -> (tl, t) + | _ -> assert false + in + let texp = {texp with exp_type = ty_res} in + if not separate then unify_exp ~context env texp (instance env ty_expected); + let recarg = + match constr.cstr_inlined with + | None -> Rejected + | Some _ -> ( + match sargs with + | [ + { + pexp_desc = + ( Pexp_ident _ + | Pexp_record (_, (Some {pexp_desc = Pexp_ident _} | None)) ); + }; + ] -> + Required + | _ -> raise (Error (loc, env, Inlined_record_expected))) + in + let args = + List.map2 + (fun e (t, t0) -> type_argument ~context ~recarg env e t t0) + sargs + (List.combine ty_args ty_args0) + in + if constr.cstr_private = Private then + raise (Error (loc, env, Private_type ty_res)); + (* NOTE: shouldn't we call "re" on this final expression? -- AF *) + {texp with exp_desc = Texp_construct (lid, constr, args)} + +(* Typing of statements (expressions whose values are discarded) *) + +and type_statement ~context env sexp = + let loc = (final_subexpression sexp).pexp_loc in + begin_def (); + let exp = type_exp ~context env sexp in + end_def (); + let ty = expand_head env exp.exp_type and tv = newvar () in + if is_Tvar ty && ty.level > tv.level then + Location.prerr_warning loc Warnings.Nonreturning_statement; + let expected_ty = instance_def Predef.type_unit in + let context = type_clash_context_in_statement sexp in + unify_exp ~context env exp expected_ty; + exp + +(* Typing of match cases *) + +and type_cases ~(call_context : [`LetUnwrap | `Switch | `Function | `Try]) + ?in_function env ty_arg ty_res partial_flag loc caselist : + _ * Typedtree.partial = + (* ty_arg is _fully_ generalized *) + let patterns = List.map (fun {pc_lhs = p} -> p) caselist in + let contains_polyvars = List.exists contains_polymorphic_variant patterns in + let erase_either = contains_polyvars && contains_variant_either ty_arg + and has_gadts = List.exists (contains_gadt env) patterns in + (* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) + let ty_arg = + if has_gadts || erase_either then correct_levels ty_arg else ty_arg + and ty_res, env = + if has_gadts then (correct_levels ty_res, duplicate_ident_types caselist env) + else (ty_res, env) + in + let rec is_var spat = + match spat.ppat_desc with + | Ppat_any | Ppat_var _ -> true + | Ppat_alias (spat, _) -> is_var spat + | _ -> false + in + let needs_exhaust_check = + match caselist with + | [{pc_lhs}] when is_var pc_lhs -> false + | _ -> true + in + let init_env () = + (* raise level for existentials *) + begin_def (); + Ident.set_current_time (get_current_level ()); + let lev = Ident.current_time () in + Ctype.init_def (lev + 1000); + (* up to 1000 existentials *) + (lev, Env.add_gadt_instance_level lev env) + in + let lev, env = + if has_gadts then init_env () else (get_current_level (), env) + in + (* if has_gadts then + Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *) + (* Do we need to propagate polymorphism *) + let propagate = + has_gadts + || (repr ty_arg).level = generic_level + || + match caselist with + | [{pc_lhs}] when is_var pc_lhs -> false + | _ -> true + in + if propagate then begin_def (); + (* propagation of the argument *) + let pattern_force = ref [] in + (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_arg; *) + let pat_env_list = + List.map + (fun {pc_lhs; pc_guard; pc_rhs} -> + let loc = + let open Location in + match pc_guard with + | None -> pc_rhs.pexp_loc + | Some g -> {pc_rhs.pexp_loc with loc_start = g.pexp_loc.loc_start} + in + let scope = Some (Annot.Idef loc) in + let pat, ext_env, force, unpacks = + let partial = if erase_either then Some false else None in + let ty_arg = instance ?partial env ty_arg in + type_pattern ~lev env pc_lhs scope ty_arg + in + pattern_force := force @ !pattern_force; + (pat, (ext_env, unpacks))) + caselist + in + (* Unify all cases (delayed to keep it order-free) *) + let ty_arg' = newvar () in + let unify_pats ty = + List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty) pat_env_list + in + unify_pats ty_arg'; + (* Check for polymorphic variants to close *) + let patl = List.map fst pat_env_list in + if List.exists has_variants patl then ( + Parmatch.pressure_variants env patl; + List.iter (iter_pattern finalize_variant) patl); + (* `Contaminating' unifications start here *) + List.iter (fun f -> f ()) !pattern_force; + (* Post-processing and generalization *) + if propagate || erase_either then unify_pats (instance env ty_arg); + if propagate then ( + List.iter + (iter_pattern (fun {pat_type = t} -> unify_var env t (newvar ()))) + patl; + end_def (); + List.iter (iter_pattern (fun {pat_type = t} -> generalize t)) patl); + (* type bodies *) + let in_function = if List.length caselist = 1 then in_function else None in + let cases = + List.map2 + (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} -> + let sexp = wrap_unpacks pc_rhs unpacks in + let ty_res' = + if contains_gadt env pc_lhs then correct_levels ty_res else ty_res + in + (* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) + Printtyp.raw_type_expr ty_res'; *) + let guard = + match pc_guard with + | None -> None + | Some scond -> + Some + (type_expect ~context:(Some IfCondition) ext_env + (wrap_unpacks scond unpacks) + Predef.type_bool) + in + let exp = + type_expect + ~context: + (match call_context with + | `Switch -> Some SwitchReturn + | `Try -> Some TryReturn + | `LetUnwrap -> Some LetUnwrapReturn + | `Function -> None) + ?in_function ext_env sexp ty_res' + in + { + c_lhs = pat; + c_guard = guard; + c_rhs = {exp with exp_type = instance env ty_res'}; + }) + pat_env_list caselist + in + (if has_gadts then + let ty_res' = instance env ty_res in + List.iter (fun c -> unify_exp ~context:None env c.c_rhs ty_res') cases); + let do_init = has_gadts || needs_exhaust_check in + let lev, env = if do_init && not has_gadts then init_env () else (lev, env) in + let ty_arg_check = + if do_init then + (* Hack: use for_saving to copy variables too *) + Subst.type_expr (Subst.for_saving Subst.identity) ty_arg + else ty_arg + in + let partial = + if partial_flag then check_partial ~lev env ty_arg_check loc cases + else Partial + in + let unused_check () = + List.iter (fun (pat, (env, _)) -> check_absent_variant env pat) pat_env_list; + check_unused ~lev env (instance env ty_arg_check) cases; + Parmatch.check_ambiguous_bindings cases + in + if contains_polyvars || do_init then + Delayed_checks.add_delayed_check unused_check + else unused_check (); + (* Check for unused cases, do not delay because of gadts *) + if do_init then ( + end_def (); + (* Ensure that existential types do not escape *) + unify_exp_types ~context:None loc env (instance env ty_res) (newvar ())); + (cases, partial) + +(* Typing of let bindings *) + +and type_let ~context ?(check = fun s -> Warnings.Unused_var s) + ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag + spat_sexp_list scope allow = + begin_def (); + let is_fake_let = + match spat_sexp_list with + | [ + { + pvb_expr = + { + pexp_desc = + Pexp_match + ({pexp_desc = Pexp_ident {txt = Longident.Lident "*opt*"}}, _); + }; + }; + ] -> + true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) + | _ -> false + in + let check = if is_fake_let then check_strict else check in + + let spatl = + List.map + (fun {pvb_pat = spat; pvb_attributes = attrs} -> (attrs, spat)) + spat_sexp_list + in + let nvs = List.map (fun _ -> newvar ()) spatl in + let pat_list, new_env, force, unpacks = + type_pattern_list env spatl scope nvs allow + in + let attrs_list = List.map fst spatl in + let is_recursive = rec_flag = Recursive in + (* If recursive, first unify with an approximation of the expression *) + if is_recursive then + List.iter2 + (fun pat binding -> + let pat = + match pat.pat_type.desc with + | Tpoly (ty, tl) -> + { + pat with + pat_type = snd (instance_poly ~keep_names:true false tl ty); + } + | _ -> pat + in + unify_pat env pat (type_approx env binding.pvb_expr)) + pat_list spat_sexp_list; + (* Polymorphic variant processing *) + List.iter + (fun pat -> + if has_variants pat then ( + Parmatch.pressure_variants env [pat]; + iter_pattern finalize_variant pat)) + pat_list; + (* Only bind pattern variables after generalizing *) + List.iter (fun f -> f ()) force; + let exp_env = if is_recursive then new_env else env in + + let current_slot = ref None in + let rec_needed = ref false in + let warn_about_unused_bindings = + List.exists + (fun attrs -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + Warnings.is_active (check "") + || Warnings.is_active (check_strict "") + || (is_recursive && Warnings.is_active Warnings.Unused_rec_flag))) + attrs_list + in + let pat_slot_list = + (* Algorithm to detect unused declarations in recursive bindings: + - During type checking of the definitions, we capture the 'value_used' + events on the bound identifiers and record them in a slot corresponding + to the current definition (!current_slot). + In effect, this creates a dependency graph between definitions. + + - After type checking the definition (!current_slot = None), + when one of the bound identifier is effectively used, we trigger + again all the events recorded in the corresponding slot. + The effect is to traverse the transitive closure of the graph created + in the first step. + + We also keep track of whether *all* variables in a given pattern + are unused. If this is the case, for local declarations, the issued + warning is 26, not 27. + *) + List.map2 + (fun attrs pat -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + if not warn_about_unused_bindings then (pat, None) + else + let some_used = ref false in + (* has one of the identifier of this pattern been used? *) + let slot = ref [] in + List.iter + (fun id -> + let vd = Env.find_value (Path.Pident id) new_env in + (* note: Env.find_value does not trigger the value_used event *) + let name = Ident.name id in + let used = ref false in + if not (name = "" || name.[0] = '_' || name.[0] = '#') then + Delayed_checks.add_delayed_check (fun () -> + if not !used then + Location.prerr_warning vd.Types.val_loc + ((if !some_used then check_strict else check) name)); + Env.set_value_used_callback name vd (fun () -> + match !current_slot with + | Some slot -> + slot := (name, vd) :: !slot; + rec_needed := true + | None -> + List.iter + (fun (name, vd) -> Env.mark_value_used env name vd) + (get_ref slot); + used := true; + some_used := true)) + (Typedtree.pat_bound_idents pat); + (pat, Some slot))) + attrs_list pat_list + in + let exp_list = + List.map2 + (fun {pvb_expr = sexp; pvb_attributes; _} (pat, slot) -> + let sexp = + if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp + in + if is_recursive then current_slot := slot; + match pat.pat_type.desc with + | Tpoly (ty, tl) -> + begin_def (); + let vars, ty' = instance_poly ~keep_names:true true tl ty in + let exp = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect ~context exp_env sexp ty') + in + end_def (); + check_univars env true "definition" exp pat.pat_type vars; + {exp with exp_type = instance env exp.exp_type} + | _ -> + Builtin_attributes.warning_scope pvb_attributes (fun () -> + type_expect ~context exp_env sexp pat.pat_type)) + spat_sexp_list pat_slot_list + in + current_slot := None; + (if + is_recursive && (not !rec_needed) + && Warnings.is_active Warnings.Unused_rec_flag + then + let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in + (* See PR#6677 *) + Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes (fun () -> + Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag)); + List.iter2 + (fun pat (attrs, exp) -> + Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> + let partial_match_warning_hint = + if Experimental_features.is_enabled Experimental_features.LetUnwrap + then + let ty = repr (Ctype.expand_head env pat.pat_type) in + match ty.desc with + | Tconstr (path, _, _) + when Path.same path Predef.path_option + || Path.same path Predef.path_result -> + Some + "Hint: You can use `let?` to automatically unwrap this \ + expression." + | _ -> None + else None + in + ignore + (check_partial ?partial_match_warning_hint env pat.pat_type + pat.pat_loc + [case pat exp]))) + pat_list + (List.map2 (fun (attrs, _) e -> (attrs, e)) spatl exp_list); + end_def (); + List.iter2 + (fun pat exp -> + if not (is_nonexpansive exp) then + iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat) + pat_list exp_list; + List.iter + (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat) + pat_list; + let l = List.combine pat_list exp_list in + let l = + List.map2 + (fun (p, e) pvb -> + { + vb_pat = p; + vb_expr = e; + vb_attributes = pvb.pvb_attributes; + vb_loc = pvb.pvb_loc; + }) + l spat_sexp_list + in + if is_recursive then + List.iter + (fun {vb_pat = pat} -> + match pat.pat_desc with + | Tpat_var _ -> () + | Tpat_alias ({pat_desc = Tpat_any}, _, _) -> () + | _ -> raise (Error (pat.pat_loc, env, Illegal_letrec_pat))) + l; + (l, new_env, unpacks) + +(* Typing of toplevel bindings *) + +let type_binding ~context env rec_flag spat_sexp_list scope = + Typetexp.reset_type_variables (); + let pat_exp_list, new_env, _unpacks = + type_let + ~check:(fun s -> Warnings.Unused_value_declaration s) + ~check_strict:(fun s -> Warnings.Unused_value_declaration s) + ~context env rec_flag spat_sexp_list scope false + in + (pat_exp_list, new_env) + +(* Typing of toplevel expressions *) + +let type_expression ~context env sexp = + Typetexp.reset_type_variables (); + begin_def (); + let exp = type_exp ~context env sexp in + (if Warnings.is_active (Bs_toplevel_expression_unit None) then + try unify env exp.exp_type (instance_def Predef.type_unit) with + | Unify _ -> + let buffer = Buffer.create 10 in + let formatter = Format.formatter_of_buffer buffer in + Printtyp.type_expr formatter exp.exp_type; + Format.pp_print_flush formatter (); + let return_type = Buffer.contents buffer in + Location.prerr_warning sexp.pexp_loc + (Bs_toplevel_expression_unit + (match sexp.pexp_desc with + | Pexp_apply _ -> Some (return_type, FunctionCall) + | _ -> Some (return_type, Other))) + | Tags _ -> + Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit None)); + end_def (); + if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; + generalize exp.exp_type; + match sexp.pexp_desc with + | Pexp_ident lid -> + (* Special case for keeping type variables when looking-up a variable *) + let _path, desc = Env.lookup_value lid.txt env in + {exp with exp_type = desc.val_type} + | _ -> exp + +(* Error report *) + +let spellcheck ppf unbound_name valid_names = + Misc.did_you_mean ppf (fun () -> Misc.spellcheck valid_names unbound_name) + +let spellcheck_idents ppf unbound valid_idents = + spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) + +let strip_arity_suffix name = + let len = String.length name in + let rec scan_back i = + if i < 0 || name.[i] < '0' || name.[i] > '9' then i + 1 + else scan_back (i - 1) + in + let start_of_digits = scan_back (len - 1) in + if start_of_digits > 0 && start_of_digits < len then + String.sub name 0 start_of_digits + else name + +let find_arity_suggestion env function_name target_arity = + let base_name = strip_arity_suffix function_name in + let candidate = + if target_arity = 1 then base_name + else base_name ^ string_of_int target_arity + in + try + let path, desc = Env.lookup_value (Longident.parse candidate) env in + if Builtin_attributes.deprecated_of_attrs desc.val_attributes <> None then + None + else + let expanded_type = Ctype.expand_head env desc.val_type in + let actual_arity = + match Ctype.get_arity env expanded_type with + | Some arity -> arity + | None -> 0 + in + if actual_arity = target_arity then Some (Printtyp.string_of_path path) + else None + with + | Not_found -> None + | _ -> None + +open Format +let longident = Printtyp.longident +let super_report_unification_error = Printtyp.super_report_unification_error +let report_ambiguous_type_error = Printtyp.report_ambiguous_type_error +let report_subtyping_error = Printtyp.report_subtyping_error + +let type_expr = Error_message_utils.type_expr + +let report_error env loc ppf error = + match error with + | Polymorphic_label lid -> + fprintf ppf "@[The record field %a is polymorphic.@ %s@]" longident lid + "You cannot instantiate it in a pattern." + | Constructor_arity_mismatch {name; constuctor; expected; provided} -> + (* modified *) + let is_inline_record = Option.is_some constuctor.cstr_inlined in + if is_inline_record && expected = 1 then + fprintf ppf + "@[This variant constructor @{%a@} expects an inline record as \ + payload%s.@]" + longident name + (if provided = 0 then ", but it's not being passed any arguments" + else "") + else + fprintf ppf + "@[This variant constructor @{%a@} expects %i %s, but it's%s \ + being passed %i.@]" + longident name expected + (if expected == 1 then "argument" else "arguments") + (if provided < expected then " only" else "") + provided + | Label_mismatch (lid, trace) -> + (* modified *) + super_report_unification_error ppf env trace + (function + | ppf -> + fprintf ppf "The record field %a@ belongs to the type" longident lid) + (function ppf -> fprintf ppf "but is mixed here with fields of type") + | Pattern_type_clash trace -> + (* modified *) + super_report_unification_error ppf env trace + ~print_extra_info:Error_message_utils.print_contextual_unification_error + (function + | ppf -> fprintf ppf "This pattern matches values of type") + (function + | ppf -> + fprintf ppf "but a pattern was expected which matches values of type") + | Or_pattern_type_clash (id, trace) -> + (* modified *) + super_report_unification_error ppf env trace + (function + | ppf -> + fprintf ppf + "The variable %s on the left-hand side of this or-pattern has type" + (Ident.name id)) + (function ppf -> fprintf ppf "but on the right-hand side it has type") + | Multiply_bound_variable name -> + fprintf ppf "Variable %s is bound several times in this matching" name + | Orpat_vars (id, valid_idents) -> + fprintf ppf "Variable %s must occur on both sides of this | pattern" + (Ident.name id); + spellcheck_idents ppf id valid_idents + | Expr_type_clash + { + trace = + (_, {desc = Tarrow (_, _, _, None)}) + :: (_, {desc = Tarrow (_, _, _, Some _)}) + :: _; + } -> + fprintf ppf + "This function is a curried function where an uncurried function is \ + expected" + | Expr_type_clash + { + trace = + (_, {desc = Tarrow (_, _, _, Some arity_a)}) + :: (_, {desc = Tarrow (_, _, _, Some arity_b)}) + :: _; + } + when arity_a <> arity_b -> + let arity_a = arity_a |> string_of_int in + let arity_b = arity_b |> string_of_int in + report_arity_mismatch ~arity_a ~arity_b ppf + | Expr_type_clash {trace; context} -> + (* modified *) + fprintf ppf "@["; + print_expr_type_clash ~context env loc trace ppf; + fprintf ppf "@]" + | Apply_non_function typ -> ( + (* modified *) + match (repr typ).desc with + | Tarrow (_, return_type, _, _) -> + let rec count_number_of_args count {Types.desc} = + match desc with + | Tarrow (_, return_type, _, _) -> + count_number_of_args (count + 1) return_type + | _ -> count + in + let count_number_of_args = count_number_of_args 1 in + let accepts_count = count_number_of_args return_type in + fprintf ppf "@[@[<2>This function has type@ @{%a@}@]" type_expr + typ; + fprintf ppf "@ @[It only accepts %i %s; here, it's called with more.@]@]" + accepts_count + (if accepts_count == 1 then "argument" else "arguments") + | _ -> + fprintf ppf + "@[@[<2>This can't be called, it's not a function.@]@,\ + The function has type: %a@]" + type_expr typ) + | Apply_wrong_label (l, ty) -> + let print_message ppf = function + | Nolabel -> + fprintf ppf "The argument at this position should be labelled." + | l -> + fprintf ppf "This function does not take the argument @{%s@}." + (prefixed_label_name l) + in + fprintf ppf "@[@[<2>%a@]@,This function has type: %a@]" print_message l + type_expr ty + | Label_multiply_defined {label; jsx_component_info = Some jsx_component_info} + -> + fprintf ppf + "The prop @{%s@} has already been passed to the component " label; + print_component_name ppf jsx_component_info.props_record_path; + fprintf ppf "@,@,You can't pass the same prop more than once." + | Label_multiply_defined {label} -> + fprintf ppf "The record field label %s is defined several times" label + | Labels_missing {labels; jsx_component_info = Some jsx_component_info} -> + print_component_labels_missing_error ppf labels jsx_component_info + | Labels_missing {labels} -> + let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in + fprintf ppf "@[Some required record fields are missing:%a.@]" + print_labels labels + | Label_not_mutable lid -> + fprintf ppf "The record field %a is not mutable" longident lid + | Wrong_name (eorp, ty, kind, p, name, valid_names) -> ( + match get_jsx_component_props ~extract_concrete_typedecl env ty p with + | Some {fields} -> + print_component_wrong_prop_error ppf p fields name; + spellcheck ppf name valid_names + | None -> + (* modified *) + if Path.is_constructor_typath p then + fprintf ppf + "@[The field %s is not part of the record argument for the %a \ + constructor@]" + name Printtyp.path p + else ( + fprintf ppf "@["; + + fprintf ppf + "@[<2>The %s @{%s@} does not belong to type @{%a@}@]@,@," + (label_of_kind kind) name (*kind*) Printtyp.path p; + + fprintf ppf "@[<2>%s type@ @{%a@}@]" eorp type_expr ty; + + fprintf ppf "@]"); + spellcheck ppf name valid_names) + | Name_type_mismatch (kind, lid, tp, tpl) -> + let name = label_of_kind kind in + report_ambiguous_type_error ppf env tp tpl + (function + | ppf -> + fprintf ppf "The %s %a@ belongs to the %s type" name longident lid + kind) + (function + | ppf -> + fprintf ppf "The %s %a@ belongs to one of the following %s types:" + name longident lid kind) + (function + | ppf -> + fprintf ppf "but a %s was expected belonging to the %s type" name kind) + | Undefined_method (ty, me, valid_methods) -> ( + fprintf ppf + "@[@[This expression has type@;<1 2>%a@]@,It has no field %s@]" + type_expr ty me; + match valid_methods with + | None -> () + | Some valid_methods -> spellcheck ppf me valid_methods) + | Not_subtype (tr1, tr2, ctx) -> + report_subtyping_error ppf env tr1 "is not a subtype of" tr2 ctx + | Too_many_arguments (in_function, ty) -> + if + (* modified *) + in_function + then ( + fprintf ppf "@[This function expects too many arguments,@ "; + fprintf ppf "it should have type@ %a@]" type_expr ty) + else ( + fprintf ppf "@[This expression should not be a function,@ "; + fprintf ppf "the expected type is@ %a@]" type_expr ty) + | Abstract_wrong_label (l, ty) -> + let label_mark = function + | Nolabel -> "but its first argument is not labelled" + | l -> + sprintf "but its first argument is labelled %s" (prefixed_label_name l) + in + fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]" type_expr + ty (label_mark l) + | Scoping_let_module (id, ty) -> + fprintf ppf "This `let module' expression has type@ %a@ " type_expr ty; + fprintf ppf + "In this type, the locally bound module name %s escapes its scope" id + | Private_type ty -> + fprintf ppf "Cannot create values of the private type %a" type_expr ty + | Private_label (lid, ty) -> + fprintf ppf "Cannot assign field %a of the private type %a" longident lid + type_expr ty + | Not_a_variant_type lid -> + fprintf ppf "The type %a@ is not a variant type" longident lid + | Incoherent_label_order -> + fprintf ppf "This labeled function is applied to arguments@ "; + fprintf ppf "in an order different from other calls.@ "; + fprintf ppf "This is only allowed when the real type is known." + | Less_general (kind, trace) -> + (* modified *) + super_report_unification_error ppf env trace + (fun ppf -> fprintf ppf "This %s has type" kind) + (fun ppf -> fprintf ppf "which is less general than") + | Modules_not_allowed -> + fprintf ppf "Modules are not allowed in this pattern." + | Cannot_infer_signature -> + fprintf ppf "The signature for this packaged module couldn't be inferred." + | Not_a_packed_module ty -> + fprintf ppf "This expression is packed module, but the expected type is@ %a" + type_expr ty + | Recursive_local_constraint trace -> + (* modified *) + super_report_unification_error ppf env trace + (function + | ppf -> fprintf ppf "Recursive local constraint when unifying") + (function ppf -> fprintf ppf "with") + | Unexpected_existential -> fprintf ppf "Unexpected existential" + | Unqualified_gadt_pattern (tpath, name) -> + fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]" name Printtyp.path + tpath "must be qualified in this pattern" + | Invalid_interval -> + fprintf ppf "@[Only character intervals are supported in patterns.@]" + | Invalid_for_loop_index -> + fprintf ppf "@[Invalid for-loop index: only variables and _ are allowed.@]" + | No_value_clauses -> + fprintf ppf "None of the patterns in this 'match' expression match values." + | Exception_pattern_below_toplevel -> + fprintf ppf + "@[Exception patterns must be at the top level of a match case.@]" + | Inlined_record_escape -> + fprintf ppf + "@[This use of an inlined record is not allowed: its anonymous type \ + would escape its constructor scope.@,\ + @,\ + Possible solutions: @,\ + - Destructure the fields you're interested in from the inline record@,\ + - Change the underlying type to use a defined record as payload instead \ + of an inline record. That will let you use the payload without \ + destructuring it first" + | Inlined_record_expected -> + fprintf ppf "@[This constructor expects an inlined record argument.@]" + | Invalid_extension_constructor_payload -> + fprintf ppf + "Invalid [%%extension_constructor] payload, a constructor is expected." + | Not_an_extension_constructor -> + fprintf ppf "This constructor is not an extension constructor." + | Literal_overflow ty -> + fprintf ppf + "Integer literal exceeds the range of representable integers of type %s" + ty + | Unknown_literal (n, m) -> + fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m + | Illegal_letrec_pat -> + fprintf ppf "Only variables are allowed as left-hand side of `let rec'" + | Empty_record_literal -> + fprintf ppf + "Empty record literal {} should be type annotated or used in a record \ + context." + | Uncurried_arity_mismatch + { + function_type = typ; + expected_arity = arity; + provided_arity = args; + provided_args = sargs; + function_name = function_name_opt; + } -> + (* We need: + - Any arg that's required but isn't passed + - Any arg that is passed but isn't in the fn definition (optional or labelled) + - Any mismatch in the number of unlabelled args (since all of them are required) + *) + let rec collect_args ?(acc = []) typ = + match typ.desc with + | Tarrow (arg, next, _, _) -> collect_args ~acc:(arg.lbl :: acc) next + | _ -> acc + in + let args_from_type = collect_args typ in + + (* Unlabelled arg counts *) + let args_from_type_unlabelled = + args_from_type |> List.filter (fun arg -> arg = Nolabel) |> List.length + in + let sargs_unlabelled = + sargs |> List.filter (fun arg -> arg = Nolabel) |> List.length + in + let mismatch_in_unlabelled_args = + args_from_type_unlabelled <> sargs_unlabelled + in + + (* Required args that aren't passed *) + let required_args = + args_from_type + |> List.filter_map (fun arg -> + match arg with + | Labelled {txt = n} -> Some n + | Optional _ | Nolabel -> None) + in + let passed_named_args = + sargs + |> List.filter_map (fun arg -> + match arg with + | Labelled {txt} | Optional {txt} -> Some txt + | Nolabel -> None) + in + let missing_required_args = + required_args + |> List.filter (fun arg -> not (List.mem arg passed_named_args)) + in + + (* Passed args that the fn does not take *) + let named_args_of_fn_type = + args_from_type + |> List.filter_map (fun arg -> + match arg with + | Labelled {txt = n} | Optional {txt = n} -> Some n + | Nolabel -> None) + in + let superfluous_args = + passed_named_args + |> List.filter (fun arg -> not (List.mem arg named_args_of_fn_type)) + in + + let is_fallback = + List.length missing_required_args = 0 + && List.length superfluous_args = 0 + && mismatch_in_unlabelled_args = false + in + + fprintf ppf "@[@[<2>This function call is incorrect.@]"; + fprintf ppf "@,The function has type:@ %a" type_expr typ; + + if not is_fallback then fprintf ppf "@,"; + + if List.length missing_required_args > 0 then ( + fprintf ppf "@,- Missing arguments that must be provided: %s" + (missing_required_args + |> List.map (fun v -> "~" ^ v) + |> String.concat ", "); + + fprintf ppf + "@,\ + - Hint: Did you want to partially apply the function? You can do that \ + by putting `...` just before the closing parens of the function call. \ + Example: @{yourFn(~arg1=someVar, ...)@}"); + + if List.length superfluous_args > 0 then + fprintf ppf "@,- Called with arguments it does not take: %s" + (superfluous_args |> String.concat ", "); + + let unlabelled_msg a b pos = + match (a, pos) with + | 0, `left -> "no" + | 0, `right -> "none" + | _ when a > b -> string_of_int a + | _ -> "just " ^ string_of_int a + in + + if mismatch_in_unlabelled_args then + fprintf ppf + "@,\ + - The function takes @{%s@} unlabelled argument%s, but is \ + called with @{%s@}" + (unlabelled_msg args_from_type_unlabelled sargs_unlabelled `left) + (if args_from_type_unlabelled = 1 then "" else "s") + (unlabelled_msg sargs_unlabelled args_from_type_unlabelled `right); + + (* Print fallback if nothing above matched *) + if is_fallback then + fprintf ppf + "@,\ + @,\ + It is called with @{%d@} argument%s but%s requires \ + @{%d@}." + args + (if args = 1 then "" else "s") + (if args > arity then " just" else "") + arity; + + (* Add suggestions for related functions with correct arity *) + (match function_name_opt with + | Some function_name -> ( + let function_name_str = + let buffer = Buffer.create 16 in + let formatter = Format.formatter_of_buffer buffer in + Printtyp.longident formatter function_name; + Format.pp_print_flush formatter (); + Buffer.contents buffer + in + let suggestion = find_arity_suggestion env function_name_str args in + match suggestion with + | None -> () + | Some suggestion_str -> + fprintf ppf + "@,@,Hint: Try @{%s@} instead (takes @{%d@} argument%s)." + suggestion_str args + (if args = 1 then "" else "s")) + | None -> ()); + + fprintf ppf "@]" + | Field_not_optional (name, typ) -> + fprintf ppf "Field @{%s@} is not optional in type %a. Use without ?" + name type_expr typ + | Type_params_not_supported lid -> + fprintf ppf + "The type %a@ has type parameters, but type parameters is not supported \ + here." + longident lid + | Field_access_on_dict_type -> + fprintf ppf + "Direct field access on a dict is not supported. Use Dict.get instead." + | Jsx_not_enabled -> + fprintf ppf + "Cannot compile JSX expression because JSX support is not enabled. Add \ + \"jsx\" settings to rescript.json to enable JSX support." + +let report_error env loc ppf err = + Printtyp.wrap_printing_env env (fun () -> report_error env loc ppf err) + +let () = + Location.register_error_of_exn (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env loc) err) + | Error_forward err -> Some err + | _ -> None) + +let type_exp env e = type_exp env e diff --git a/compiler/ml/typecore.mli b/compiler/ml/typecore.mli new file mode 100644 index 0000000..eef17d0 --- /dev/null +++ b/compiler/ml/typecore.mli @@ -0,0 +1,160 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Type inference for the core language *) + +open Asttypes +open Types +open Format + +val is_nonexpansive : Typedtree.expression -> bool + +val type_binding : + context:Error_message_utils.type_clash_context option -> + Env.t -> + rec_flag -> + Parsetree.value_binding list -> + Annot.ident option -> + Typedtree.value_binding list * Env.t +val type_expression : + context:Error_message_utils.type_clash_context option -> + Env.t -> + Parsetree.expression -> + Typedtree.expression +val check_partial : + ?lev:int -> + ?partial_match_warning_hint:string -> + Env.t -> + type_expr -> + Location.t -> + Typedtree.case list -> + Typedtree.partial +val type_exp : + Env.t -> + Parsetree.expression -> + context:Error_message_utils.type_clash_context option -> + Typedtree.expression +val type_approx : Env.t -> Parsetree.expression -> type_expr + +val option_some : Typedtree.expression -> Typedtree.expression +val option_none : type_expr -> Location.t -> Typedtree.expression +val extract_option_type : Env.t -> type_expr -> type_expr +val iter_pattern : (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit +val generalizable : int -> type_expr -> bool + +val id_of_pattern : Typedtree.pattern -> Ident.t option +val name_pattern : string -> Typedtree.case list -> Ident.t + +type error = + | Polymorphic_label of Longident.t + | Constructor_arity_mismatch of { + name: Longident.t; + constuctor: constructor_description; + expected: int; + provided: int; + } + | Label_mismatch of Longident.t * (type_expr * type_expr) list + | Pattern_type_clash of (type_expr * type_expr) list + | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list + | Multiply_bound_variable of string + | Orpat_vars of Ident.t * Ident.t list + | Expr_type_clash of { + trace: (type_expr * type_expr) list; + context: Error_message_utils.type_clash_context option; + } + | Apply_non_function of type_expr + | Apply_wrong_label of arg_label * type_expr + | Label_multiply_defined of { + label: string; + jsx_component_info: Error_message_utils.jsx_prop_error_info option; + } + | Labels_missing of { + labels: string list; + jsx_component_info: Error_message_utils.jsx_prop_error_info option; + } + | Label_not_mutable of Longident.t + | Wrong_name of string * type_expr * string * Path.t * string * string list + | Name_type_mismatch of + string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list + | Undefined_method of type_expr * string * string list option + | Private_type of type_expr + | Private_label of Longident.t * type_expr + | Not_subtype of + Ctype.type_pairs * Ctype.type_pairs * Ctype.subtype_context option + | Too_many_arguments of bool * type_expr + | Abstract_wrong_label of arg_label * type_expr + | Scoping_let_module of string * type_expr + | Not_a_variant_type of Longident.t + | Incoherent_label_order + | Less_general of string * (type_expr * type_expr) list + | Modules_not_allowed + | Cannot_infer_signature + | Not_a_packed_module of type_expr + | Recursive_local_constraint of (type_expr * type_expr) list + | Unexpected_existential + | Unqualified_gadt_pattern of Path.t * string + | Invalid_interval + | Invalid_for_loop_index + | No_value_clauses + | Exception_pattern_below_toplevel + | Inlined_record_escape + | Inlined_record_expected + | Invalid_extension_constructor_payload + | Not_an_extension_constructor + | Literal_overflow of string + | Unknown_literal of string * char + | Illegal_letrec_pat + | Empty_record_literal + | Uncurried_arity_mismatch of { + function_type: type_expr; + expected_arity: int; + provided_arity: int; + provided_args: Asttypes.arg_label list; + function_name: Longident.t option; + } + | Field_not_optional of string * type_expr + | Type_params_not_supported of Longident.t + | Field_access_on_dict_type + | Jsx_not_enabled + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error : Env.t -> Location.t -> formatter -> error -> unit +(* Deprecated. Use Location.{error_of_exn, report_error}. *) + +(* Forward declaration, to be filled in by Typemod.type_module *) +val type_module : (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref + +(* Forward declaration, to be filled in by Typemod.type_open *) +val type_open : + (?used_slot:bool ref -> + override_flag -> + Env.t -> + Location.t -> + Longident.t loc -> + Path.t * Env.t) + ref + +(* Forward declaration, to be filled in by Typemod.type_package *) +val type_package : + (Env.t -> + Parsetree.module_expr -> + Path.t -> + Longident.t list -> + Typedtree.module_expr * type_expr list) + ref + +val constant : Parsetree.constant -> (Asttypes.constant, error) result diff --git a/compiler/ml/typedecl.ml b/compiler/ml/typedecl.ml new file mode 100644 index 0000000..da35de5 --- /dev/null +++ b/compiler/ml/typedecl.ml @@ -0,0 +1,2325 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Jerome Vouillon, 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. *) +(* *) +(**************************************************************************) + +(**** Typing of type definitions ****) + +open Misc +open Asttypes +open Parsetree +open Primitive +open Types +open Typetexp + +type native_repr_kind = Unboxed | Untagged + +type error = + | Repeated_parameter + | Duplicate_constructor of string + | Duplicate_label of string * string option + | Object_spread_with_record_field of string + | Recursive_abbrev of string + | Cycle_in_def of string * type_expr + | Definition_mismatch of type_expr * Includecore.type_mismatch list + | Constraint_failed of type_expr * type_expr + | Inconsistent_constraint of Env.t * (type_expr * type_expr) list + | Type_clash of Env.t * (type_expr * type_expr) list + | Parameters_differ of Path.t * type_expr * type_expr + | Null_arity_external + | Unbound_type_var of type_expr * type_declaration + | Cannot_extend_private_type of Path.t + | Not_extensible_type of Path.t + | Extension_mismatch of Path.t * Includecore.type_mismatch list + | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list + | Rebind_mismatch of Longident.t * Path.t * Path.t + | Rebind_private of Longident.t + | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool) + | Unavailable_type_constructor of Path.t + | Bad_fixed_type of string + | Unbound_type_var_ext of type_expr * extension_constructor + | Varying_anonymous + | Val_in_structure + | Invalid_attribute of string + | Bad_immediate_attribute + | Bad_unboxed_attribute of string + | Boxed_and_unboxed + | Nonrec_gadt + | Variant_runtime_representation_mismatch of Variant_coercion.variant_error + | Variant_spread_fail of Variant_type_spread.variant_type_spread_error + +open Typedtree + +exception Error of Location.t * error + +(* Note: do not factor the branches in the following pattern-matching: + the records must be constants for the compiler to do sharing on them. +*) +let get_unboxed_from_attributes sdecl = + let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in + let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in + match (boxed, unboxed, !Clflags.unboxed_types) with + | true, true, _ -> raise (Error (sdecl.ptype_loc, Boxed_and_unboxed)) + | true, false, _ -> unboxed_false_default_false + | false, true, _ -> unboxed_true_default_false + | false, false, false -> unboxed_false_default_true + | false, false, true -> unboxed_true_default_true + +(* Enter all declared types in the environment as abstract types *) + +let enter_type rec_flag env sdecl id = + let needed = + match rec_flag with + | Asttypes.Nonrecursive -> + (match sdecl.ptype_kind with + | Ptype_variant scds -> + List.iter + (fun cd -> + if cd.pcd_res <> None then raise (Error (cd.pcd_loc, Nonrec_gadt))) + scds + | _ -> ()); + Btype.is_row_name (Ident.name id) + | Asttypes.Recursive -> true + in + if not needed then env + else + let decl = + { + type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; + type_arity = List.length sdecl.ptype_params; + type_kind = Type_abstract; + type_private = sdecl.ptype_private; + type_manifest = + (match sdecl.ptype_manifest with + | None -> None + | Some _ -> Some (Ctype.newvar ())); + type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params; + type_newtype_level = None; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + in + Env.add_type ~check:true id decl env + +let update_type temp_env env id loc = + let path = Path.Pident id in + let decl = Env.find_type path temp_env in + match decl.type_manifest with + | None -> () + | Some ty -> ( + let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in + try Ctype.unify env (Ctype.newconstr path params) ty + with Ctype.Unify trace -> raise (Error (loc, Type_clash (env, trace)))) + +(* We use the Ctype.expand_head_opt version of expand_head to get access + to the manifest type of private abbreviations. *) +let rec get_unboxed_type_representation env ty fuel = + if fuel < 0 then None + else + let ty = Ctype.repr (Ctype.expand_head_opt env ty) in + match ty.desc with + | Tconstr (p, args, _) -> ( + match Env.find_type p env with + | exception Not_found -> Some ty + | {type_unboxed = {unboxed = false}} -> Some ty + | { + type_params; + type_kind = + ( Type_record ([{ld_type = ty2; _}], _) + | Type_variant [{cd_args = Cstr_tuple [ty2]; _}] + | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}] ); + } -> + get_unboxed_type_representation env + (Ctype.apply env type_params ty2 args) + (fuel - 1) + | {type_kind = Type_abstract} -> + None + (* This case can occur when checking a recursive unboxed type + declaration. *) + | _ -> assert false (* only the above can be unboxed *)) + | _ -> Some ty + +let get_unboxed_type_representation env ty = + (* Do not give too much fuel: PR#7424 *) + get_unboxed_type_representation env ty 100 + +(* Determine if a type definition defines a fixed type. (PW) *) +let is_fixed_type sd = + let rec has_row_var sty = + match sty.ptyp_desc with + | Ptyp_alias (sty, _) -> has_row_var sty + | Ptyp_object (_, Open) + | Ptyp_variant (_, Open, _) + | Ptyp_variant (_, Closed, Some _) -> + true + | _ -> false + in + match sd.ptype_manifest with + | None -> false + | Some sty -> + sd.ptype_kind = Ptype_abstract + && sd.ptype_private = Private && has_row_var sty + +(* Set the row variable in a fixed type *) +let set_fixed_row env loc p decl = + let tm = + match decl.type_manifest with + | None -> assert false + | Some t -> Ctype.expand_head env t + in + let rv = + match tm.desc with + | Tvariant row -> + let row = Btype.row_repr row in + tm.desc <- Tvariant {row with row_fixed = true}; + if Btype.static_row row then Btype.newgenty Tnil else row.row_more + | Tobject (ty, _) -> snd (Ctype.flatten_fields ty) + | _ -> raise (Error (loc, Bad_fixed_type "is not an object or variant")) + in + if not (Btype.is_Tvar rv) then + raise (Error (loc, Bad_fixed_type "has no row variable")); + rv.desc <- Tconstr (p, decl.type_params, ref Mnil) + +(* Translate one type declaration *) + +module StringSet = Set.Make (struct + type t = string + let compare (x : t) y = compare x y +end) + +let make_params env params = + let make_param (sty, v) = + try (transl_type_param env sty, v) + with Already_bound -> raise (Error (sty.ptyp_loc, Repeated_parameter)) + in + List.map make_param params + +let transl_labels ?record_name env closed lbls = + (match !Builtin_attributes.check_duplicated_labels lbls with + | None -> () + | Some {loc; txt = name} -> + raise (Error (loc, Duplicate_label (name, record_name)))); + let mk + { + pld_name = name; + pld_mutable = mut; + pld_optional = optional; + pld_type = arg; + pld_loc = loc; + pld_attributes = attrs; + } = + Builtin_attributes.warning_scope attrs (fun () -> + let arg = Ast_helper.Typ.force_poly arg in + let cty = transl_simple_type env closed arg in + { + ld_id = Ident.create name.txt; + ld_name = name; + ld_mutable = mut; + ld_optional = optional; + ld_type = cty; + ld_loc = loc; + ld_attributes = attrs; + }) + in + let lbls = List.map mk lbls in + let lbls' = + List.map + (fun ld -> + let ty = ld.ld_type.ctyp_type in + let ty = + match ty.desc with + | Tpoly (t, []) -> t + | _ -> ty + in + { + Types.ld_id = ld.ld_id; + ld_mutable = ld.ld_mutable; + ld_optional = ld.ld_optional; + ld_type = ty; + ld_loc = ld.ld_loc; + ld_attributes = ld.ld_attributes; + }) + lbls + in + (lbls, lbls') + +let first_non_spread_field (lbls_ : Parsetree.label_declaration list) = + List.find_map + (fun (ld : Parsetree.label_declaration) -> + if ld.pld_name.txt <> "..." then Some ld else None) + lbls_ + +let transl_constructor_arguments env closed = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env closed) l in + (Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), Cstr_tuple l) + | Pcstr_record l -> ( + let lbls, lbls' = transl_labels env closed l in + let expanded = + Record_type_spread.expand_labels_with_type_spreads env lbls lbls' + in + match expanded with + | Some (lbls, lbls') -> (Types.Cstr_record lbls', Cstr_record lbls) + | None -> ( + match l with + | [{pld_name = {txt = "..."}; pld_type = spread_typ; _}] -> + (* Ambiguous `{...t}`: if only spread present and it doesn't resolve to a + record type, treat it as an object-typed tuple argument. *) + let obj_ty = + Ast_helper.Typ.object_ ~loc:spread_typ.ptyp_loc + [Parsetree.Oinherit spread_typ] + Asttypes.Closed + in + let cty = transl_simple_type env closed obj_ty in + (Types.Cstr_tuple [cty.ctyp_type], Cstr_tuple [cty]) + | _ -> ( + (* Could not resolve spread to a record type, but additional record + fields are present. Mirror declaration logic and reject mixing + object-type spreads with record fields. *) + match first_non_spread_field l with + | Some ld -> + raise + (Error (ld.pld_loc, Object_spread_with_record_field ld.pld_name.txt)) + | None -> ( + (* Be defensive: treat as an object-typed tuple if somehow only spreads + are present but not caught by the single-spread case. *) + let fields = + Ext_list.filter_map l (fun ld -> + match ld.pld_name.txt with + | "..." -> Some (Parsetree.Oinherit ld.pld_type) + | _ -> None) + in + match fields with + | [] -> (Types.Cstr_record lbls', Cstr_record lbls) + | _ -> + let obj_ty = + Ast_helper.Typ.object_ ~loc:(List.hd l).pld_loc fields + Asttypes.Closed + in + let cty = transl_simple_type env closed obj_ty in + (Types.Cstr_tuple [cty.ctyp_type], Cstr_tuple [cty]))))) + +let make_constructor env type_path type_params sargs sret_type = + match sret_type with + | None -> + let args, targs = transl_constructor_arguments env true sargs in + (targs, None, args, None, type_params) + | Some sret_type -> + (* if it's a generalized constructor we must first narrow and + then widen so as to not introduce any new constraints *) + let z = narrow () in + reset_type_variables (); + let args, targs = transl_constructor_arguments env false sargs in + let tret_type = transl_simple_type env false sret_type in + let ret_type = tret_type.ctyp_type in + let params = + match (Ctype.repr ret_type).desc with + | Tconstr (p', params, _) when Path.same type_path p' -> params + | _ -> + raise + (Error + ( sret_type.ptyp_loc, + Constraint_failed + (ret_type, Ctype.newconstr type_path type_params) )) + in + widen z; + (targs, Some tret_type, args, Some ret_type, params) + +let is_not_undefined_attr (attr : attribute) = + match attr with + | {Location.txt = "notUndefined"; _}, _ -> true + | _ -> false + +(* Check that all the variables found in [ty] are in [univ]. + Because [ty] is the argument to an abstract type, the representation + of that abstract type could be any subexpression of [ty], in particular + any type variable present in [ty]. +*) + +let transl_declaration ~type_record_as_object ~untagged_wfc env sdecl id = + (* Check for @notUndefined attribute *) + let has_not_undefined = + List.exists is_not_undefined_attr sdecl.ptype_attributes + in + (if has_not_undefined then + match (sdecl.ptype_kind, sdecl.ptype_manifest) with + | Ptype_abstract, None -> () + | _ -> + raise + (Error + ( sdecl.ptype_loc, + Invalid_attribute + "@notUndefined can only be used on abstract types" ))); + + (* Bind type parameters *) + reset_type_variables (); + Ctype.begin_def (); + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in + let cstrs = + List.map + (fun (sty, sty', loc) -> + ( transl_simple_type env false sty, + transl_simple_type env false sty', + loc )) + sdecl.ptype_cstrs + in + let raw_status = get_unboxed_from_attributes sdecl in + + let check_untagged_variant () = + match sdecl.ptype_kind with + | Ptype_variant cds -> + Ext_list.for_all cds (function + | {pcd_args = Pcstr_tuple ([] | [_])} -> + (* at most one payload allowed for untagged variants *) + true + | {pcd_args = Pcstr_tuple (_ :: _ :: _); pcd_name = {txt = name}} -> + Ast_untagged_variants.report_constructor_more_than_one_arg + ~loc:sdecl.ptype_loc ~name + | {pcd_args = Pcstr_record _} -> true) + | _ -> false + in + + (if + raw_status.unboxed && (not raw_status.default) + && not (check_untagged_variant ()) + then + match sdecl.ptype_kind with + | Ptype_abstract -> + raise (Error (sdecl.ptype_loc, Bad_unboxed_attribute "it is abstract")) + | Ptype_variant _ -> () + | Ptype_record [{pld_mutable = Immutable; _}] -> () + | Ptype_record [{pld_mutable = Mutable; _}] -> + raise (Error (sdecl.ptype_loc, Bad_unboxed_attribute "it is mutable")) + | Ptype_record _ -> + raise + (Error + (sdecl.ptype_loc, Bad_unboxed_attribute "it has more than one field")) + | Ptype_open -> + raise + (Error + ( sdecl.ptype_loc, + Bad_unboxed_attribute "extensible variant types cannot be unboxed" + ))); + let unboxed_status = + match sdecl.ptype_kind with + | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] -> + unboxed_false_default_false + | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] + | Ptype_variant + [{pcd_args = Pcstr_record [{pld_mutable = Immutable; _}]; _}] + | Ptype_record [{pld_mutable = Immutable; _}] -> + raw_status + | _ -> + (* The type is not unboxable, mark it as boxed *) + unboxed_false_default_false + in + let unbox = unboxed_status.unboxed in + let tkind, kind, sdecl = + match sdecl.ptype_kind with + | Ptype_abstract -> (Ttype_abstract, Type_abstract, sdecl) + | Ptype_variant scstrs -> + assert (scstrs <> []); + (if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then + match cstrs with + | [] -> () + | (_, _, loc) :: _ -> + Location.prerr_warning loc Warnings.Constraint_on_gadt); + let scstrs = + Ext_list.map scstrs (fun ({pcd_args} as cstr) -> + match pcd_args with + | Pcstr_tuple _ -> cstr + | Pcstr_record lds -> + { + cstr with + pcd_args = + Pcstr_record + (Ext_list.map lds (fun ld -> + if ld.pld_optional then + let typ = ld.pld_type in + let typ = + { + typ with + ptyp_desc = + Ptyp_constr + ( {txt = Lident "option"; loc = typ.ptyp_loc}, + [typ] ); + } + in + {ld with pld_type = typ} + else ld)); + }) + in + let all_constrs = ref StringSet.empty in + List.iter + (fun {pcd_name = {txt = name}} -> + if StringSet.mem name !all_constrs then + raise (Error (sdecl.ptype_loc, Duplicate_constructor name)); + all_constrs := StringSet.add name !all_constrs) + scstrs; + let copy_tag_attr_from_decl attr = + let tag_attrs = + Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> + txt = "tag" || txt = Ast_untagged_variants.untagged) + in + if tag_attrs = [] then attr else tag_attrs @ attr + in + let constructors_from_variant_spreads = Hashtbl.create 10 in + let make_cstr scstr = + let name = Ident.create scstr.pcd_name.txt in + let targs, tret_type, args, ret_type, _cstr_params = + make_constructor env (Path.Pident id) params scstr.pcd_args + scstr.pcd_res + in + if String.starts_with scstr.pcd_name.txt ~prefix:"..." then ( + (* Any constructor starting with "..." represents a variant type spread, and + will have the spread variant itself as a single argument. + + We pull that variant type out, and then track the type of each of its + constructors, so that we can replace our dummy constructors added before + type checking with the realtypes for each constructor. + *) + (match args with + | Cstr_tuple [spread_variant] -> ( + match Ctype.extract_concrete_typedecl env spread_variant with + | _, _, {type_kind = Type_variant constructors} -> + constructors + |> List.iter (fun (c : Types.constructor_declaration) -> + Hashtbl.add constructors_from_variant_spreads c.cd_id.name + c) + | _ -> ()) + | _ -> ()); + None) + else + (* Check if this constructor is from a variant spread. If so, we need to replace + its type with the right type we've pulled from the type checked spread variant + itself. *) + let tcstr, cstr = + match + Hashtbl.find_opt constructors_from_variant_spreads + (Ident.name name) + with + | Some cstr -> + let tcstr = + { + cd_id = name; + cd_name = scstr.pcd_name; + cd_args = + (match cstr.cd_args with + | Cstr_tuple args -> + Cstr_tuple + (args + |> List.map (fun texpr : Typedtree.core_type -> + { + ctyp_attributes = cstr.cd_attributes; + ctyp_loc = cstr.cd_loc; + ctyp_env = env; + ctyp_type = texpr; + ctyp_desc = Ttyp_any; + (* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *) + })) + | Cstr_record lbls -> + Cstr_record + (lbls + |> List.map + (fun + (l : Types.label_declaration) + : + Typedtree.label_declaration + -> + { + ld_id = l.ld_id; + ld_name = + Location.mkloc (Ident.name l.ld_id) l.ld_loc; + ld_mutable = l.ld_mutable; + ld_optional = l.ld_optional; + ld_type = + { + ctyp_desc = Ttyp_any; + ctyp_type = l.ld_type; + ctyp_env = env; + ctyp_loc = l.ld_loc; + ctyp_attributes = []; + }; + ld_loc = l.ld_loc; + ld_attributes = l.ld_attributes; + }))); + cd_res = tret_type; + (* This is also strictly wrong, but is fine because the type checker does not look at this field. *) + cd_loc = scstr.pcd_loc; + cd_attributes = + scstr.pcd_attributes |> copy_tag_attr_from_decl; + } + in + (tcstr, cstr) + | None -> + let tcstr = + { + cd_id = name; + cd_name = scstr.pcd_name; + cd_args = targs; + cd_res = tret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = + scstr.pcd_attributes |> copy_tag_attr_from_decl; + } + in + let cstr = + { + Types.cd_id = name; + cd_args = args; + cd_res = ret_type; + cd_loc = scstr.pcd_loc; + cd_attributes = + scstr.pcd_attributes |> copy_tag_attr_from_decl; + } + in + (tcstr, cstr) + in + Some (tcstr, cstr) + in + let make_cstr scstr = + Builtin_attributes.warning_scope scstr.pcd_attributes (fun () -> + make_cstr scstr) + in + let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in + let is_untagged_def = + Ast_untagged_variants.has_untagged sdecl.ptype_attributes + in + let well_formedness_check : Ast_untagged_variants.well_formedness_check = + {is_untagged_def; cstrs} + in + (* delay the check until the newenv is created to handle recursive types *) + untagged_wfc := well_formedness_check :: !untagged_wfc; + (Ttype_variant tcstrs, Type_variant cstrs, sdecl) + | Ptype_record lbls_ -> ( + let optional_labels = + Ext_list.filter_map lbls_ (fun lbl -> + if lbl.pld_optional then Some lbl.pld_name.txt else None) + in + let lbls = + if optional_labels = [] then lbls_ + else + Ext_list.map lbls_ (fun lbl -> + let typ = lbl.pld_type in + let typ = + if lbl.pld_optional then + { + typ with + ptyp_desc = + Ptyp_constr + ({txt = Lident "option"; loc = typ.ptyp_loc}, [typ]); + } + else typ + in + {lbl with pld_type = typ}) + in + let lbls, lbls' = + transl_labels ~record_name:sdecl.ptype_name.txt env true lbls + in + let lbls_opt = + Record_type_spread.expand_labels_with_type_spreads env lbls lbls' + in + let rec check_duplicates loc (lbls : Typedtree.label_declaration list) + seen = + match lbls with + | [] -> () + | lbl :: rest -> + let name = lbl.ld_id.name in + if StringSet.mem name seen then + raise + (Error (loc, Duplicate_label (name, Some sdecl.ptype_name.txt))); + check_duplicates loc rest (StringSet.add name seen) + in + match lbls_opt with + | Some (lbls, lbls') -> + check_duplicates sdecl.ptype_loc lbls StringSet.empty; + let optional = Ext_list.exists lbls (fun lbl -> lbl.ld_optional) in + ( Ttype_record lbls, + Type_record + ( lbls', + if unbox then Record_unboxed false + else if optional then Record_regular + else Record_regular ), + sdecl ) + | None -> ( + (* Could not find record type decl for ...t. This happens when the spread + target is not a record type (e.g. an object type). If additional + fields are present in the record, this mixes a record field with an + object-type spread and should be rejected. If only the spread exists, + reinterpret as an object type for backwards compatibility. *) + (* TODO: We really really need to make this "spread that needs to be resolved" + concept 1st class in the AST or similar. This is quite hacky and fragile as + is.*) + match first_non_spread_field lbls_ with + | Some ld -> + (* Error on the first record field mixed with an object spread. *) + raise + (Error (ld.pld_loc, Object_spread_with_record_field ld.pld_name.txt)) + | None -> + (* Only a spread present: treat as object type (syntax ambiguity). *) + type_record_as_object := true; + let fields = + Ext_list.map lbls_ (fun ld -> + match ld.pld_name.txt with + | "..." -> Parsetree.Oinherit ld.pld_type + | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) + in + let sdecl = + { + sdecl with + ptype_kind = Ptype_abstract; + ptype_manifest = + Some (Ast_helper.Typ.object_ ~loc:sdecl.ptype_loc fields Closed); + } + in + (Ttype_abstract, Type_abstract, sdecl))) + | Ptype_open -> (Ttype_open, Type_open, sdecl) + in + let tman, man = + match sdecl.ptype_manifest with + | None -> (None, None) + | Some sty -> + let no_row = not (is_fixed_type sdecl) in + let cty = transl_simple_type env no_row sty in + (Some cty, Some cty.ctyp_type) + in + let decl = + { + type_params = params; + type_arity = List.length params; + type_kind = kind; + type_private = sdecl.ptype_private; + type_manifest = man; + type_variance = List.map (fun _ -> Variance.full) params; + type_newtype_level = None; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = false; + type_unboxed = unboxed_status; + type_inlined_types = []; + } + in + + (* Check constraints *) + List.iter + (fun (cty, cty', loc) -> + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + try Ctype.unify env ty ty' + with Ctype.Unify tr -> + raise (Error (loc, Inconsistent_constraint (env, tr)))) + cstrs; + Ctype.end_def (); + (* Add abstract row *) + (if is_fixed_type sdecl then + let p = + try Env.lookup_type (Longident.Lident (Ident.name id ^ "#row")) env + with Not_found -> assert false + in + set_fixed_row env sdecl.ptype_loc p decl); + (* Check for cyclic abbreviations *) + (match decl.type_manifest with + | None -> () + | Some ty -> + if Ctype.cyclic_abbrev env id ty then + raise (Error (sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt))); + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = decl; + typ_cstrs = cstrs; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = tkind; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + +(* Generalize a type declaration *) + +let generalize_decl decl = + List.iter Ctype.generalize decl.type_params; + Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; + match decl.type_manifest with + | None -> () + | Some ty -> Ctype.generalize ty + +(* Check that all constraints are enforced *) + +module TypeSet = Btype.TypeSet +module TypeMap = Btype.TypeMap + +let rec check_constraints_rec env loc visited ty = + let ty = Ctype.repr ty in + if TypeSet.mem ty !visited then () + else ( + visited := TypeSet.add ty !visited; + match ty.desc with + | Tconstr (path, args, _) -> + let args' = List.map (fun _ -> Ctype.newvar ()) args in + let ty' = Ctype.newconstr path args' in + (try Ctype.enforce_constraints env ty' with + | Ctype.Unify _ -> assert false + | Not_found -> raise (Error (loc, Unavailable_type_constructor path))); + if not (Ctype.matches env ty ty') then + raise (Error (loc, Constraint_failed (ty, ty'))); + List.iter (check_constraints_rec env loc visited) args + | Tpoly (ty, tl) -> + let _, ty = Ctype.instance_poly false tl ty in + check_constraints_rec env loc visited ty + | _ -> Btype.iter_type_expr (check_constraints_rec env loc visited) ty) + +module SMap = Map.Make (String) + +let check_constraints_labels env visited l pl = + let rec get_loc name = function + | [] -> Location.none + | pld :: tl -> + if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl + in + List.iter + (fun {Types.ld_id = name; ld_type = ty} -> + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) + l + +let check_constraints ~type_record_as_object env sdecl (_, decl) = + let visited = ref TypeSet.empty in + (match decl.type_kind with + | Type_abstract -> () + | Type_variant l -> + let find_pl = function + | Ptype_variant pl -> pl + | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + let pl_index = + let foldf acc x = SMap.add x.pcd_name.txt x acc in + List.fold_left foldf SMap.empty pl + in + List.iter + (fun {Types.cd_id = name; cd_args; cd_res} -> + let {pcd_args; pcd_res; _} = + try SMap.find (Ident.name name) pl_index + with Not_found -> assert false + in + (match (cd_args, pcd_args) with + | Cstr_tuple tyl, Pcstr_tuple styl -> + List.iter2 + (fun sty ty -> check_constraints_rec env sty.ptyp_loc visited ty) + styl tyl + | Cstr_record tyl, Pcstr_record styl -> + check_constraints_labels env visited tyl styl + | ( Cstr_tuple [ty], + Pcstr_record [{pld_name = {txt = "..."}; pld_type; _}] ) -> + (* Ambiguous `{...t}` parsed as record with a single spread; typer may + reinterpret as an object tuple argument. Accept this and check the + single tuple arg against the source location of the spread type. *) + check_constraints_rec env pld_type.ptyp_loc visited ty + | _ -> assert false); + match (pcd_res, cd_res) with + | Some sr, Some r -> check_constraints_rec env sr.ptyp_loc visited r + | _ -> ()) + l + | Type_record (l, _) -> + let find_pl = function + | Ptype_record pl -> pl + | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false + in + let pl = find_pl sdecl.ptype_kind in + check_constraints_labels env visited l pl + | Type_open -> ()); + match decl.type_manifest with + | None -> () + | Some ty -> + if not !type_record_as_object then + let sty = + match sdecl.ptype_manifest with + | Some sty -> sty + | _ -> assert false + in + check_constraints_rec env sty.ptyp_loc visited ty + +(* + If both a variant/record definition and a type equation are given, + need to check that the equation refers to a type of the same kind + with the same constructors and labels. +*) +let check_coherence env loc id decl = + match decl with + | { + type_kind = Type_variant _ | Type_record _ | Type_open; + type_manifest = Some ty; + } -> ( + match (Ctype.repr ty).desc with + | Tconstr (path, args, _) -> ( + try + let decl' = Env.find_type path env in + let err = + if List.length args <> List.length decl.type_params then + [Includecore.Arity] + else if not (Ctype.equal env false args decl.type_params) then + [Includecore.Constraint] + else + Includecore.type_declarations ~loc ~equality:true env + (Path.last path) decl' id + (Subst.type_declaration + (Subst.add_type id path Subst.identity) + decl) + in + if err <> [] then raise (Error (loc, Definition_mismatch (ty, err))) + with Not_found -> raise (Error (loc, Unavailable_type_constructor path))) + | _ -> raise (Error (loc, Definition_mismatch (ty, [])))) + | _ -> () + +let check_abbrev env sdecl (id, decl) = + check_coherence env sdecl.ptype_loc id decl + +(* Check that recursion is well-founded *) + +let check_well_founded env loc path to_check ty = + let visited = ref TypeMap.empty in + let rec check ty0 parents ty = + let ty = Btype.repr ty in + if TypeSet.mem ty parents then + (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) + if + match ty0.desc with + | Tconstr (p, _, _) -> Path.same p path + | _ -> false + then raise (Error (loc, Recursive_abbrev (Path.name path))) + else raise (Error (loc, Cycle_in_def (Path.name path, ty0))); + let fini, parents = + try + let prev = TypeMap.find ty !visited in + if TypeSet.subset parents prev then (true, parents) + else (false, TypeSet.union parents prev) + with Not_found -> (false, parents) + in + if fini then () + else + let rec_ok = + match ty.desc with + | Tconstr (_p, _, _) -> + false (*!Clflags.recursive_types && Ctype.is_contractive env p*) + | Tobject _ | Tvariant _ -> true + | _ -> false (* !Clflags.recursive_types*) + in + let visited' = TypeMap.add ty parents !visited in + let arg_exn = + try + visited := visited'; + let parents = + if rec_ok then TypeSet.empty else TypeSet.add ty parents + in + Btype.iter_type_expr (check ty0 parents) ty; + None + with e -> + visited := visited'; + Some e + in + match ty.desc with + | Tconstr (p, _, _) when arg_exn <> None || to_check p -> ( + if to_check p then may raise arg_exn + else Btype.iter_type_expr (check ty0 TypeSet.empty) ty; + try + let ty' = Ctype.try_expand_once_opt env ty in + let ty0 = if TypeSet.is_empty parents then ty else ty0 in + check ty0 (TypeSet.add ty parents) ty' + with Ctype.Cannot_expand -> may raise arg_exn) + | _ -> may raise arg_exn + in + let snap = Btype.snapshot () in + try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty + with Ctype.Unify _ -> + (* Will be detected by check_recursion *) + Btype.backtrack snap + +let check_well_founded_manifest env loc path decl = + if decl.type_manifest = None then () + else + let args = List.map (fun _ -> Ctype.newvar ()) decl.type_params in + check_well_founded env loc path (Path.same path) (Ctype.newconstr path args) + +let check_well_founded_decl env loc path decl to_check = + let open Btype in + let it = + { + type_iterators with + it_type_expr = (fun _ -> check_well_founded env loc path to_check); + } + in + it.it_type_declaration it (Ctype.instance_declaration decl) + +(* Check for ill-defined abbrevs *) + +let check_recursion env loc path decl to_check = + (* to_check is true for potentially mutually recursive paths. + (path, decl) is the type declaration to be checked. *) + if decl.type_params = [] then () + else + let visited = ref [] in + + let rec check_regular cpath args prev_exp ty = + let ty = Ctype.repr ty in + if not (List.memq ty !visited) then ( + visited := ty :: !visited; + match ty.desc with + | Tconstr (path', args', _) -> + (if Path.same path path' then ( + if not (Ctype.equal env false args args') then + raise + (Error + ( loc, + Parameters_differ (cpath, ty, Ctype.newconstr path args) + ))) + else if + (* Attempt to expand a type abbreviation if: + 1- [to_check path'] holds + (otherwise the expansion cannot involve [path]); + 2- we haven't expanded this type constructor before + (otherwise we could loop if [path'] is itself + a non-regular abbreviation). *) + to_check path' && not (List.mem path' prev_exp) + then + try + (* Attempt expansion *) + let params0, body0, _ = Env.find_type_expansion path' env in + let params, body = + Ctype.instance_parameterized_type params0 body0 + in + (try List.iter2 (Ctype.unify env) params args' + with Ctype.Unify _ -> + raise + (Error + ( loc, + Constraint_failed (ty, Ctype.newconstr path' params0) + ))); + check_regular path' args (path' :: prev_exp) body + with Not_found -> ()); + List.iter (check_regular cpath args prev_exp) args' + | Tpoly (ty, tl) -> + let _, ty = Ctype.instance_poly ~keep_names:true false tl ty in + check_regular cpath args prev_exp ty + | _ -> Btype.iter_type_expr (check_regular cpath args prev_exp) ty) + in + + Misc.may + (fun body -> + let args, body = + Ctype.instance_parameterized_type ~keep_names:true decl.type_params + body + in + check_regular path args [] body) + decl.type_manifest + +let check_abbrev_recursion env id_loc_list to_check tdecl = + let decl = tdecl.typ_type in + let id = tdecl.typ_id in + check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check + +(* Compute variance *) + +let get_variance ty visited = + try TypeMap.find ty !visited with Not_found -> Variance.null + +let compute_variance env visited vari ty = + let rec compute_variance_rec vari ty = + (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) + let ty = Ctype.repr ty in + let vari' = get_variance ty visited in + if Variance.subset vari vari' then () + else + let vari = Variance.union vari vari' in + visited := TypeMap.add ty vari !visited; + let compute_same = compute_variance_rec vari in + match ty.desc with + | Tarrow (arg, ret, _, _) -> + let open Variance in + let v = conjugate vari in + let v1 = + if mem May_pos v || mem May_neg v then set May_weak true v else v + in + compute_variance_rec v1 arg.typ; + compute_same ret + | Ttuple tl -> List.iter compute_same tl + | Tconstr (path, tl, _) -> ( + let open Variance in + if tl = [] then () + else + try + let decl = Env.find_type path env in + let cvari f = mem f vari in + List.iter2 + (fun ty v -> + let cv f = mem f v in + let strict = + (cvari Inv && cv Inj) || ((cvari Pos || cvari Neg) && cv Inv) + in + if strict then compute_variance_rec full ty + else + let p1 = inter v vari and n1 = inter v (conjugate vari) in + let v1 = + union + (inter covariant (union p1 (conjugate p1))) + (inter (conjugate covariant) (union n1 (conjugate n1))) + and weak = + (cvari May_weak && (cv May_pos || cv May_neg)) + || ((cvari May_pos || cvari May_neg) && cv May_weak) + in + let v2 = set May_weak weak v1 in + compute_variance_rec v2 ty) + tl decl.type_variance + with Not_found -> List.iter (compute_variance_rec may_inv) tl) + | Tobject (ty, _) -> compute_same ty + | Tfield (_, _, ty1, ty2) -> + compute_same ty1; + compute_same ty2 + | Tsubst ty -> compute_same ty + | Tvariant row -> + let row = Btype.row_repr row in + List.iter + (fun (_, f) -> + match Btype.row_field_repr f with + | Rpresent (Some ty) -> compute_same ty + | Reither (_, tyl, _, _) -> + let open Variance in + let upper = + List.fold_left + (fun s f -> set f true s) + null + [May_pos; May_neg; May_weak] + in + let v = inter vari upper in + (* cf PR#7269: + if List.length tyl > 1 then upper else inter vari upper *) + List.iter (compute_variance_rec v) tyl + | _ -> ()) + row.row_fields; + compute_same row.row_more + | Tpoly (ty, _) -> compute_same ty + | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () + | Tpackage (_, _, tyl) -> + let v = + Variance.(if mem Pos vari || mem Neg vari then full else may_inv) + in + List.iter (compute_variance_rec v) tyl + in + compute_variance_rec vari ty + +let make p n i = + let open Variance in + set May_pos p (set May_neg n (set May_weak n (set Inj i null))) + +let compute_variance_type env check (required, loc) decl tyl = + (* Requirements *) + let required = + List.map + (fun (c, n, i) -> if c || n then (c, n, i) else (true, true, i)) + required + in + (* Prepare *) + let params = List.map Btype.repr decl.type_params in + let tvl = ref TypeMap.empty in + (* Compute occurrences in the body *) + let open Variance in + List.iter + (fun (cn, ty) -> + compute_variance env tvl (if cn then full else covariant) ty) + tyl; + if check then ( + (* Check variance of parameters *) + let pos = ref 0 in + List.iter2 + (fun ty (c, n, i) -> + incr pos; + let var = get_variance ty tvl in + let co, cn = get_upper var and ij = mem Inj var in + if + Btype.is_Tvar ty && ((co && not c) || (cn && not n) || ((not ij) && i)) + then raise (Error (loc, Bad_variance (!pos, (co, cn, ij), (c, n, i))))) + params required; + (* Check propagation from constrained parameters *) + let args = Btype.newgenty (Ttuple params) in + let fvl = Ctype.free_variables args in + let fvl = Ext_list.filter fvl (fun v -> not (List.memq v params)) in + (* If there are no extra variables there is nothing to do *) + if fvl = [] then () + else + let tvl2 = ref TypeMap.empty in + List.iter2 + (fun ty (p, n, _) -> + if Btype.is_Tvar ty then () + else + let v = + if p then if n then full else covariant else conjugate covariant + in + compute_variance env tvl2 v ty) + params required; + let visited = ref TypeSet.empty in + let rec check ty = + let ty = Ctype.repr ty in + if TypeSet.mem ty !visited then () + else + let visited' = TypeSet.add ty !visited in + visited := visited'; + let v1 = get_variance ty tvl in + let snap = Btype.snapshot () in + let v2 = + TypeMap.fold + (fun t vt v -> + if Ctype.equal env false [ty] [t] then union vt v else v) + !tvl2 null + in + Btype.backtrack snap; + let c1, n1 = get_upper v1 and c2, n2, _, i2 = get_lower v2 in + if (c1 && not c2) || (n1 && not n2) then + if List.memq ty fvl then + let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in + raise + (Error + (loc, Bad_variance (code, (c1, n1, false), (c2, n2, false)))) + else Btype.iter_type_expr check ty + in + List.iter (fun (_, ty) -> check ty) tyl); + List.map2 + (fun ty (p, n, i) -> + let v = get_variance ty tvl in + let tr = decl.type_private in + (* Use required variance where relevant *) + let concr = + decl.type_kind <> Type_abstract + (*|| tr = Type_new*) + in + let p, n = + if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *) + else (false, false) + (* only check *) + and i = concr || (i && tr = Private) in + let v = union v (make p n i) in + let v = + if not concr then v + else if mem Pos v && mem Neg v then full + else if Btype.is_Tvar ty then v + else + union v + (if p then if n then full else covariant else conjugate covariant) + in + if decl.type_kind = Type_abstract && tr = Public then v + else set May_weak (mem May_neg v) v) + params required + +let add_false = List.map (fun ty -> (false, ty)) + +(* A parameter is constrained if it is either instantiated, + or it is a variable appearing in another parameter *) +let constrained vars ty = + match ty.desc with + | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars + | _ -> true + +let for_constr = function + | Types.Cstr_tuple l -> add_false l + | Types.Cstr_record l -> + List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + l + +let compute_variance_gadt env check ((required, loc) as rloc) decl + (tl, ret_type_opt) = + match ret_type_opt with + | None -> + compute_variance_type env check rloc + {decl with type_private = Private} + (for_constr tl) + | Some ret_type -> ( + match Ctype.repr ret_type with + | {desc = Tconstr (_, tyl, _)} -> + (* let tyl = List.map (Ctype.expand_head env) tyl in *) + let tyl = List.map Ctype.repr tyl in + let fvl = List.map (Ctype.free_variables ?env:None) tyl in + let _ = + List.fold_left2 + (fun (fv1, fv2) ty (c, n, _) -> + match fv2 with + | [] -> assert false + | fv :: fv2 -> + (* fv1 @ fv2 = free_variables of other parameters *) + if (c || n) && constrained (fv1 @ fv2) ty then + raise (Error (loc, Varying_anonymous)); + (fv :: fv1, fv2)) + ([], fvl) tyl required + in + compute_variance_type env check rloc + {decl with type_params = tyl; type_private = Private} + (for_constr tl) + | _ -> assert false) + +let compute_variance_extension env check decl ext rloc = + compute_variance_gadt env check rloc + {decl with type_params = ext.ext_type_params} + (ext.ext_args, ext.ext_ret_type) + +let compute_variance_decl env check decl ((required, _) as rloc) = + if + (decl.type_kind = Type_abstract || decl.type_kind = Type_open) + && decl.type_manifest = None + then + List.map + (fun (c, n, i) -> + make (not n) (not c) (decl.type_kind <> Type_abstract || i)) + required + else + let mn = + match decl.type_manifest with + | None -> [] + | Some ty -> [(false, ty)] + in + match decl.type_kind with + | Type_abstract | Type_open -> compute_variance_type env check rloc decl mn + | Type_variant tll -> ( + if List.for_all (fun c -> c.Types.cd_res = None) tll then + compute_variance_type env check rloc decl + (mn + @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) tll)) + else + let mn = List.map (fun (_, ty) -> (Types.Cstr_tuple [ty], None)) mn in + let tll = + mn @ List.map (fun c -> (c.Types.cd_args, c.Types.cd_res)) tll + in + match List.map (compute_variance_gadt env check rloc decl) tll with + | vari :: rem -> + let varl = List.fold_left (List.map2 Variance.union) vari rem in + List.map + Variance.(fun v -> if mem Pos v && mem Neg v then full else v) + varl + | _ -> assert false) + | Type_record (ftl, _) -> + compute_variance_type env check rloc decl + (mn + @ List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + ftl) + +let is_hash id = + let s = Ident.name id in + String.length s > 0 && s.[0] = '#' + +let marked_as_immediate decl = Builtin_attributes.immediate decl.type_attributes + +let compute_immediacy env tdecl = + match (tdecl.type_kind, tdecl.type_manifest) with + | Type_variant [{cd_args = Cstr_tuple [arg]; _}], _ + | Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _ + | Type_record ([{ld_type = arg; _}], _), _ + when tdecl.type_unboxed.unboxed -> ( + match get_unboxed_type_representation env arg with + | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr) + | None -> false) + | Type_variant (_ :: _ as cstrs), _ -> + not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) + | Type_abstract, Some typ -> not (Ctype.maybe_pointer_type env typ) + | Type_abstract, None -> marked_as_immediate tdecl + | _ -> false + +(* Computes the fixpoint for the variance and immediacy of type declarations *) + +let rec compute_properties_fixpoint env decls required variances immediacies = + let new_decls = + List.map2 + (fun (id, decl) (variance, immediacy) -> + (id, {decl with type_variance = variance; type_immediate = immediacy})) + decls + (List.combine variances immediacies) + in + let new_env = + List.fold_right + (fun (id, decl) env -> Env.add_type ~check:true id decl env) + new_decls env + in + let new_variances = + List.map2 + (fun (_id, decl) -> compute_variance_decl new_env false decl) + new_decls required + in + let new_variances = + List.map2 (List.map2 Variance.union) new_variances variances + in + let new_immediacies = + List.map (fun (_id, decl) -> compute_immediacy new_env decl) new_decls + in + if new_variances <> variances || new_immediacies <> immediacies then + compute_properties_fixpoint env decls required new_variances new_immediacies + else ( + (* List.iter (fun (id, decl) -> + Printf.eprintf "%s:" (Ident.name id); + List.iter (fun (v : Variance.t) -> + Printf.eprintf " %x" (Obj.magic v : int)) + decl.type_variance; + prerr_endline "") + new_decls; *) + List.iter + (fun (_, decl) -> + if marked_as_immediate decl && not decl.type_immediate then + raise (Error (decl.type_loc, Bad_immediate_attribute)) + else ()) + new_decls; + List.iter2 + (fun (id, decl) req -> + if not (is_hash id) then + ignore (compute_variance_decl new_env true decl req)) + new_decls required; + (new_decls, new_env)) + +let init_variance (_id, decl) = + List.map (fun _ -> Variance.null) decl.type_params + +let add_injectivity = + List.map (function + | Covariant -> (true, false, false) + | Contravariant -> (false, true, false) + | Invariant -> (false, false, false)) + +(* Check multiple declarations of labels/constructors *) + +let check_duplicates sdecl_list = + let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in + List.iter + (fun sdecl -> + match sdecl.ptype_kind with + | Ptype_variant cl -> + List.iter + (fun pcd -> + try + let name' = Hashtbl.find constrs pcd.pcd_name.txt in + Location.prerr_warning pcd.pcd_loc + (Warnings.Duplicate_definitions + ("constructor", pcd.pcd_name.txt, name', sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) + cl + | Ptype_record fl -> + List.iter + (fun {pld_name = cname; pld_loc = loc} -> + try + let name' = Hashtbl.find labels cname.txt in + if cname.txt <> "..." then + Location.prerr_warning loc + (Warnings.Duplicate_definitions + ("label", cname.txt, name', sdecl.ptype_name.txt)) + with Not_found -> + Hashtbl.add labels cname.txt sdecl.ptype_name.txt) + fl + | Ptype_abstract -> () + | Ptype_open -> ()) + sdecl_list + +(* Force recursion to go through id for private types*) +let name_recursion sdecl id decl = + match decl with + | {type_kind = Type_abstract; type_manifest = Some ty; type_private = Private} + when is_fixed_type sdecl -> + let ty = Ctype.repr ty in + let ty' = Btype.newty2 ty.level ty.desc in + if Ctype.deep_occur ty ty' then ( + let td = Tconstr (Path.Pident id, decl.type_params, ref Mnil) in + Btype.link_type ty (Btype.newty2 ty.level td); + {decl with type_manifest = Some ty'}) + else decl + | _ -> decl + +(* Translate a set of type declarations, mutually recursive or not *) +let transl_type_decl env rec_flag sdecl_list = + (* Add dummy types for fixed rows *) + let fixed_types = Ext_list.filter sdecl_list is_fixed_type in + let sdecl_list = + List.map + (fun sdecl -> + let ptype_name = + mkloc (sdecl.ptype_name.txt ^ "#row") sdecl.ptype_name.loc + in + { + sdecl with + ptype_name; + ptype_kind = Ptype_abstract; + ptype_manifest = None; + }) + fixed_types + @ + try sdecl_list |> Variant_type_spread.expand_variant_spreads env with + | Variant_coercion.VariantConfigurationError + (VariantError {left_loc} as err) -> + raise (Error (left_loc, Variant_runtime_representation_mismatch err)) + | Variant_type_spread.VariantTypeSpreadError (loc, err) -> + raise (Error (loc, Variant_spread_fail err)) + in + + (* Create identifiers. *) + let id_list = + List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list + in + (* + Since we've introduced fresh idents, make sure the definition + level is at least the binding time of these events. Otherwise, + passing one of the recursively-defined type constrs as argument + to an abbreviation may fail. + *) + Ctype.init_def (Ident.current_time ()); + Ctype.begin_def (); + (* Enter types. *) + let temp_env = List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in + (* Translate each declaration. *) + let current_slot = ref None in + let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in + let id_slots id = + match rec_flag with + | Asttypes.Recursive when warn_unused -> + (* See typecore.ml for a description of the algorithm used + to detect unused declarations in a set of recursive definitions. *) + let slot = ref [] in + let td = Env.find_type (Path.Pident id) temp_env in + let name = Ident.name id in + Env.set_type_used_callback name td (fun old_callback -> + match !current_slot with + | Some slot -> slot := (name, td) :: !slot + | None -> + List.iter + (fun (name, d) -> Env.mark_type_used env name d) + (get_ref slot); + old_callback ()); + (id, Some slot) + | Asttypes.Recursive | Asttypes.Nonrecursive -> (id, None) + in + let type_record_as_object = ref false in + let untagged_wfc = ref [] in + let transl_declaration name_sdecl (id, slot) = + current_slot := slot; + Builtin_attributes.warning_scope name_sdecl.ptype_attributes (fun () -> + transl_declaration ~type_record_as_object ~untagged_wfc temp_env + name_sdecl id) + in + let tdecls = + List.map2 transl_declaration sdecl_list (List.map id_slots id_list) + in + let inline_types = + tdecls + |> List.filter (fun tdecl -> + tdecl.typ_attributes + |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> + txt = "res.inlineRecordDefinition") + |> Option.is_some) + |> List.filter_map (fun tdecl -> + match tdecl.typ_type.type_kind with + | Type_record (labels, _) -> + Some (Record {type_name = tdecl.typ_name.txt; labels}) + | _ -> None) + in + let decls = + List.map + (fun tdecl -> + (tdecl.typ_id, {tdecl.typ_type with type_inlined_types = inline_types})) + tdecls + in + let sdecl_list = + Variant_type_spread.expand_dummy_constructor_args sdecl_list decls + in + current_slot := None; + (* Check for duplicates *) + check_duplicates sdecl_list; + (* Build the final env. *) + let newenv = + List.fold_right + (fun (id, decl) env -> Env.add_type ~check:true id decl env) + decls env + in + (* Update stubs *) + (match rec_flag with + | Asttypes.Nonrecursive -> () + | Asttypes.Recursive -> + List.iter2 + (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc) + id_list sdecl_list); + (* Generalize type declarations. *) + Ctype.end_def (); + List.iter (fun (_, decl) -> generalize_decl decl) decls; + (* Check for ill-formed abbrevs *) + let id_loc_list = + List.map2 (fun id sdecl -> (id, sdecl.ptype_loc)) id_list sdecl_list + in + List.iter + (fun (id, decl) -> + check_well_founded_manifest newenv + (List.assoc id id_loc_list) + (Path.Pident id) decl) + decls; + let to_check = function + | Path.Pident id -> List.mem_assoc id id_loc_list + | _ -> false + in + List.iter + (fun (id, decl) -> + check_well_founded_decl newenv + (List.assoc id id_loc_list) + (Path.Pident id) decl to_check) + decls; + List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls; + (* Check that all type variables are closed *) + List.iter2 + (fun sdecl tdecl -> + let decl = tdecl.typ_type in + match Ctype.closed_type_decl decl with + | Some ty -> raise (Error (sdecl.ptype_loc, Unbound_type_var (ty, decl))) + | None -> ()) + sdecl_list tdecls; + (* Check that constraints are enforced *) + List.iter + (fun check -> Ast_untagged_variants.check_well_formed ~env:newenv check) + !untagged_wfc; + List.iter2 (check_constraints ~type_record_as_object newenv) sdecl_list decls; + (* Name recursion *) + let decls = + List.map2 + (fun sdecl (id, decl) -> (id, name_recursion sdecl id decl)) + sdecl_list decls + in + (* Add variances to the environment *) + let required = + List.map + (fun sdecl -> + (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)) + sdecl_list + in + let final_decls, final_env = + compute_properties_fixpoint env decls required + (List.map init_variance decls) + (List.map (fun _ -> false) decls) + in + (* Check re-exportation *) + List.iter2 (check_abbrev final_env) sdecl_list final_decls; + (* Keep original declaration *) + let final_decls = + List.map2 + (fun tdecl (_id2, decl) -> {tdecl with typ_type = decl}) + tdecls final_decls + in + (* Done *) + (final_decls, final_env) + +(* Translating type extensions *) + +let transl_extension_constructor env type_path type_params typext_params priv + sext = + let id = Ident.create sext.pext_name.txt in + let args, ret_type, kind = + match sext.pext_kind with + | Pext_decl (sargs, sret_type) -> + let targs, tret_type, args, ret_type, _ = + make_constructor env type_path typext_params sargs sret_type + in + (args, ret_type, Text_decl (targs, tret_type)) + | Pext_rebind lid -> + let cdescr = Typetexp.find_constructor env lid.loc lid.txt in + let usage = + if cdescr.cstr_private = Private || priv = Public then Env.Positive + else Env.Privatize + in + Env.mark_constructor usage env (Longident.last lid.txt) cdescr; + let args, cstr_res = Ctype.instance_constructor cdescr in + let res, ret_type = + if cdescr.cstr_generalized then + let params = Ctype.instance_list env type_params in + let res = Ctype.newconstr type_path params in + let ret_type = Some (Ctype.newconstr type_path params) in + (res, ret_type) + else (Ctype.newconstr type_path typext_params, None) + in + (try Ctype.unify env cstr_res res + with Ctype.Unify trace -> + raise (Error (lid.loc, Rebind_wrong_type (lid.txt, env, trace)))); + (* Remove "_" names from parameters used in the constructor *) + (if not cdescr.cstr_generalized then + let vars = Ctype.free_variables (Btype.newgenty (Ttuple args)) in + List.iter + (function + | {desc = Tvar (Some "_")} as ty -> + if List.memq ty vars then ty.desc <- Tvar None + | _ -> ()) + typext_params); + (* Ensure that constructor's type matches the type being extended *) + let cstr_type_path, cstr_type_params = + match cdescr.cstr_res.desc with + | Tconstr (p, _, _) -> + let decl = Env.find_type p env in + (p, decl.type_params) + | _ -> assert false + in + let cstr_types = + Btype.newgenty (Tconstr (cstr_type_path, cstr_type_params, ref Mnil)) + :: cstr_type_params + in + let ext_types = + Btype.newgenty (Tconstr (type_path, type_params, ref Mnil)) + :: type_params + in + if not (Ctype.equal env true cstr_types ext_types) then + raise + (Error (lid.loc, Rebind_mismatch (lid.txt, cstr_type_path, type_path))); + (* Disallow rebinding private constructors to non-private *) + (match (cdescr.cstr_private, priv) with + | Private, Public -> raise (Error (lid.loc, Rebind_private lid.txt)) + | _ -> ()); + let path = + match cdescr.cstr_tag with + | Cstr_extension path -> path + | _ -> assert false + in + let args = + match cdescr.cstr_inlined with + | None -> Types.Cstr_tuple args + | Some decl -> + let tl = + match args with + | [{desc = Tconstr (_, tl, _)}] -> tl + | _ -> assert false + in + let decl = Ctype.instance_declaration decl in + assert (List.length decl.type_params = List.length tl); + List.iter2 (Ctype.unify env) decl.type_params tl; + let lbls = + match decl.type_kind with + | Type_record (lbls, Record_extension) -> lbls + | _ -> assert false + in + Types.Cstr_record lbls + in + (args, ret_type, Text_rebind (path, lid)) + in + let is_exception = Path.same type_path Predef.path_exn in + let ext = + { + Types.ext_type_path = type_path; + ext_type_params = typext_params; + ext_args = args; + ext_ret_type = ret_type; + ext_private = priv; + ext_loc = sext.pext_loc; + ext_attributes = sext.pext_attributes; + ext_is_exception = is_exception; + } + in + { + Typedtree.ext_id = id; + ext_name = sext.pext_name; + ext_type = ext; + ext_kind = kind; + ext_loc = sext.pext_loc; + ext_attributes = sext.pext_attributes; + } + +let transl_extension_constructor env type_path type_params typext_params priv + sext = + Builtin_attributes.warning_scope sext.pext_attributes (fun () -> + transl_extension_constructor env type_path type_params typext_params priv + sext) + +let transl_type_extension extend env loc styext = + reset_type_variables (); + Ctype.begin_def (); + let type_path, type_decl = + let lid = styext.ptyext_path in + Typetexp.find_type env lid.loc lid.txt + in + (match type_decl.type_kind with + | Type_open -> ( + match type_decl.type_private with + | Private when extend -> ( + match + List.find + (function + | {pext_kind = Pext_decl _} -> true + | {pext_kind = Pext_rebind _} -> false) + styext.ptyext_constructors + with + | {pext_loc} -> + raise (Error (pext_loc, Cannot_extend_private_type type_path)) + | exception Not_found -> ()) + | _ -> ()) + | _ -> raise (Error (loc, Not_extensible_type type_path))); + let type_variance = + List.map + (fun v -> + let co, cn = Variance.get_upper v in + (not cn, not co, false)) + type_decl.type_variance + in + let err = + if type_decl.type_arity <> List.length styext.ptyext_params then + [Includecore.Arity] + else if + List.for_all2 + (fun (c1, n1, _) (c2, n2, _) -> ((not c2) || c1) && ((not n2) || n1)) + type_variance + (add_injectivity (List.map snd styext.ptyext_params)) + then [] + else [Includecore.Variance] + in + if err <> [] then raise (Error (loc, Extension_mismatch (type_path, err))); + let ttype_params = make_params env styext.ptyext_params in + let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in + List.iter2 (Ctype.unify_var env) + (Ctype.instance_list env type_decl.type_params) + type_params; + let constructors = + List.map + (transl_extension_constructor env type_path type_decl.type_params + type_params styext.ptyext_private) + styext.ptyext_constructors + in + Ctype.end_def (); + (* Generalize types *) + List.iter Ctype.generalize type_params; + List.iter + (fun ext -> + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + may Ctype.generalize ext.ext_type.ext_ret_type) + constructors; + (* Check that all type variables are closed *) + List.iter + (fun ext -> + match Ctype.closed_extension_constructor ext.ext_type with + | Some ty -> + raise (Error (ext.ext_loc, Unbound_type_var_ext (ty, ext.ext_type))) + | None -> ()) + constructors; + (* Check variances are correct *) + List.iter + (fun ext -> + ignore + (compute_variance_extension env true type_decl ext.ext_type + (type_variance, loc))) + constructors; + (* Add extension constructors to the environment *) + let newenv = + List.fold_left + (fun env ext -> Env.add_extension ~check:true ext.ext_id ext.ext_type env) + env constructors + in + let tyext = + { + tyext_path = type_path; + tyext_txt = styext.ptyext_path; + tyext_params = ttype_params; + tyext_constructors = constructors; + tyext_private = styext.ptyext_private; + tyext_attributes = styext.ptyext_attributes; + } + in + (tyext, newenv) + +let transl_type_extension extend env loc styext = + Builtin_attributes.warning_scope styext.ptyext_attributes (fun () -> + transl_type_extension extend env loc styext) + +let transl_exception env sext = + reset_type_variables (); + Ctype.begin_def (); + let ext = + transl_extension_constructor env Predef.path_exn [] [] Asttypes.Public sext + in + Ctype.end_def (); + (* Generalize types *) + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; + may Ctype.generalize ext.ext_type.ext_ret_type; + (* Check that all type variables are closed *) + (match Ctype.closed_extension_constructor ext.ext_type with + | Some ty -> + raise (Error (ext.ext_loc, Unbound_type_var_ext (ty, ext.ext_type))) + | None -> ()); + let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in + (ext, newenv) + +let rec arity_from_arrow_type env core_type ty = + match (core_type.ptyp_desc, (Ctype.repr ty).desc) with + | Ptyp_arrow {ret = ct2}, Tarrow (_, ret, _, _) -> + 1 + arity_from_arrow_type env ct2 ret + | Ptyp_arrow _, _ | _, Tarrow _ -> assert false + | _ -> 0 + +let parse_arity env core_type ty = + match Ctype.get_arity env ty with + | Some arity -> + let from_constructor = + match ty.desc with + | Tconstr (_, _, _) -> true + | _ -> false + in + (arity, from_constructor) + | None -> (arity_from_arrow_type env core_type ty, false) + +(* Translate a value declaration *) +let transl_value_decl env loc valdecl = + let cty = Typetexp.transl_type_scheme env valdecl.pval_type in + let ty = cty.ctyp_type in + let v = + match valdecl.pval_prim with + | [] when Env.is_in_signature env -> + { + val_type = ty; + val_kind = Val_reg; + Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + } + | [] -> raise (Error (valdecl.pval_loc, Val_in_structure)) + | _ -> + let arity, from_constructor = parse_arity env valdecl.pval_type ty in + let prim = Primitive.parse_declaration valdecl ~arity ~from_constructor in + let prim_native_name = prim.prim_native_name in + if + prim.prim_arity = 0 + && (not + (String.length prim_native_name >= 20 + && String.unsafe_get prim_native_name 0 = '\132' + && String.unsafe_get prim_native_name 1 = '\149')) + && (prim.prim_name = "" + || (prim.prim_name.[0] <> '%' && prim.prim_name.[0] <> '#')) + then raise (Error (valdecl.pval_type.ptyp_loc, Null_arity_external)); + { + val_type = ty; + val_kind = Val_prim prim; + Types.val_loc = loc; + val_attributes = valdecl.pval_attributes; + } + in + let id, newenv = + Env.enter_value valdecl.pval_name.txt v env ~check:(fun s -> + Warnings.Unused_value_declaration s) + in + let desc = + { + val_id = id; + val_name = valdecl.pval_name; + val_desc = cty; + val_val = v; + val_prim = valdecl.pval_prim; + val_loc = valdecl.pval_loc; + val_attributes = valdecl.pval_attributes; + } + in + (desc, newenv) + +let transl_value_decl env loc valdecl = + Builtin_attributes.warning_scope valdecl.pval_attributes (fun () -> + transl_value_decl env loc valdecl) + +(* Translate a "with" constraint -- much simplified version of + transl_type_decl. *) +let transl_with_constraint env id row_path orig_decl sdecl = + Env.mark_type_used env (Ident.name id) orig_decl; + reset_type_variables (); + Ctype.begin_def (); + let tparams = make_params env sdecl.ptype_params in + let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in + let orig_decl = Ctype.instance_declaration orig_decl in + let arity_ok = List.length params = orig_decl.type_arity in + if arity_ok then List.iter2 (Ctype.unify_var env) params orig_decl.type_params; + let constraints = + List.map + (function + | ty, ty', loc -> ( + try + let cty = transl_simple_type env false ty in + let cty' = transl_simple_type env false ty' in + let ty = cty.ctyp_type in + let ty' = cty'.ctyp_type in + Ctype.unify env ty ty'; + (cty, cty', loc) + with Ctype.Unify tr -> + raise (Error (loc, Inconsistent_constraint (env, tr))))) + sdecl.ptype_cstrs + in + let no_row = not (is_fixed_type sdecl) in + let tman, man = + match sdecl.ptype_manifest with + | None -> (None, None) + | Some sty -> + let cty = transl_simple_type env no_row sty in + (Some cty, Some cty.ctyp_type) + in + let priv = + if sdecl.ptype_private = Private then Private + else if arity_ok && orig_decl.type_kind <> Type_abstract then + orig_decl.type_private + else sdecl.ptype_private + in + if + arity_ok + && orig_decl.type_kind <> Type_abstract + && sdecl.ptype_private = Private + then Location.deprecated sdecl.ptype_loc "spurious use of private"; + let type_kind, type_unboxed = + if arity_ok && man <> None then (orig_decl.type_kind, orig_decl.type_unboxed) + else (Type_abstract, unboxed_false_default_false) + in + let decl = + { + type_params = params; + type_arity = List.length params; + type_kind; + type_private = priv; + type_manifest = man; + type_variance = []; + type_newtype_level = None; + type_loc = sdecl.ptype_loc; + type_attributes = sdecl.ptype_attributes; + type_immediate = false; + type_unboxed; + type_inlined_types = []; + } + in + (match row_path with + | None -> () + | Some p -> set_fixed_row env sdecl.ptype_loc p decl); + (match Ctype.closed_type_decl decl with + | None -> () + | Some ty -> raise (Error (sdecl.ptype_loc, Unbound_type_var (ty, decl)))); + let decl = name_recursion sdecl id decl in + let type_variance = + compute_variance_decl env true decl + (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc) + in + let type_immediate = compute_immediacy env decl in + let decl = {decl with type_variance; type_immediate} in + Ctype.end_def (); + generalize_decl decl; + { + typ_id = id; + typ_name = sdecl.ptype_name; + typ_params = tparams; + typ_type = decl; + typ_cstrs = constraints; + typ_loc = sdecl.ptype_loc; + typ_manifest = tman; + typ_kind = Ttype_abstract; + typ_private = sdecl.ptype_private; + typ_attributes = sdecl.ptype_attributes; + } + +(* Approximate a type declaration: just make all types abstract *) + +let abstract_type_decl arity = + let rec make_params n = + if n <= 0 then [] else Ctype.newvar () :: make_params (n - 1) + in + Ctype.begin_def (); + let decl = + { + type_params = make_params arity; + type_arity = arity; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = replicate_list Variance.full arity; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + in + Ctype.end_def (); + generalize_decl decl; + decl + +let approx_type_decl sdecl_list = + List.map + (fun sdecl -> + ( Ident.create sdecl.ptype_name.txt, + abstract_type_decl (List.length sdecl.ptype_params) )) + sdecl_list + +(* Variant of check_abbrev_recursion to check the well-formedness + conditions on type abbreviations defined within recursive modules. *) + +let check_recmod_typedecl env loc recmod_ids path decl = + (* recmod_ids is the list of recursively-defined module idents. + (path, decl) is the type declaration to be checked. *) + let to_check path = List.exists (fun id -> Path.isfree id path) recmod_ids in + check_well_founded_decl env loc path decl to_check; + check_recursion env loc path decl to_check + +(**** Error report ****) + +open Format + +let explain_unbound_gen ppf tv tl typ kwd pr = + try + let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in + let ty0 = + (* Hack to force aliasing when needed *) + Btype.newgenty (Tobject (tv, ref None)) + in + Printtyp.reset_and_mark_loops_list [typ ti; ty0]; + fprintf ppf ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]" kwd + pr ti Printtyp.type_expr tv + with Not_found -> () + +let explain_unbound ppf tv tl typ kwd lab = + explain_unbound_gen ppf tv tl typ kwd (fun ppf ti -> + fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) + +let explain_unbound_single ppf tv ty = + let trivial ty = + explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") + in + match (Ctype.repr ty).desc with + | Tobject (fi, _) -> + let tl, rv = Ctype.flatten_fields fi in + if rv == tv then trivial ty + else + explain_unbound ppf tv tl + (fun (_, _, t) -> t) + "method" + (fun (lab, _, _) -> lab ^ ": ") + | Tvariant row -> + let row = Btype.row_repr row in + if row.row_more == tv then trivial ty + else + explain_unbound ppf tv row.row_fields + (fun (_l, f) -> + match Btype.row_field_repr f with + | Rpresent (Some t) -> t + | Reither (_, [t], _, _) -> t + | Reither (_, tl, _, _) -> Btype.newgenty (Ttuple tl) + | _ -> Btype.newgenty (Ttuple [])) + "case" + (fun (lab, _) -> "`" ^ lab ^ " of ") + | _ -> trivial ty + +let tys_of_constr_args = function + | Types.Cstr_tuple tl -> tl + | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls + +let report_error ppf = function + | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" + | Duplicate_constructor s -> fprintf ppf "Two constructors are named %s" s + | Duplicate_label (s, None) -> + fprintf ppf + "The field @{%s@} is defined several times in this record. Fields \ + can only be added once to a record." + s + | Object_spread_with_record_field field_name -> + fprintf ppf + "@[You cannot mix a record field with an object type spread.@\n\ + Remove the record field or change it to an object field (e.g. \"%s\": \ + ...).@]" + field_name + | Invalid_attribute msg -> fprintf ppf "%s" msg + | Duplicate_label (s, Some record_name) -> + fprintf ppf + "The field @{%s@} is defined several times in the record \ + @{%s@}. Fields can only be added once to a record." + s record_name + | Recursive_abbrev s -> fprintf ppf "The type abbreviation %s is cyclic" s + | Cycle_in_def (s, ty) -> + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[The definition of %s contains a cycle:@ %a@]" s + Printtyp.type_expr ty + | Definition_mismatch (ty, errs) -> + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" + "This variant or record definition" "does not match that of type" + Printtyp.type_expr ty + (Includecore.report_type_mismatch "the original" "this" "definition") + errs + | Constraint_failed (ty, ty') -> + Printtyp.reset_and_mark_loops ty; + Printtyp.mark_loops ty'; + fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]" + "Constraints are not satisfied in this type." Printtyp.type_expr ty + Printtyp.type_expr ty' + | Parameters_differ (path, ty, ty') -> + Printtyp.reset_and_mark_loops ty; + Printtyp.mark_loops ty'; + fprintf ppf "@[In the definition of %s, type@ %a@ should be@ %a@]" + (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty' + | Inconsistent_constraint (env, trace) -> + fprintf ppf "The type constraints are not consistent.@."; + Printtyp.report_unification_error ppf env trace + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "is not compatible with type") + | Type_clash (env, trace) -> + Printtyp.report_unification_error ppf env trace + (function + | ppf -> fprintf ppf "This type constructor expands to type") + (function ppf -> fprintf ppf "but is used here with type") + | Null_arity_external -> fprintf ppf "External identifiers must be functions" + | Unbound_type_var (ty, decl) -> ( + fprintf ppf "A type variable is unbound in this type declaration"; + let ty = Ctype.repr ty in + match (decl.type_kind, decl.type_manifest) with + | Type_variant tl, _ -> + explain_unbound_gen ppf ty tl + (fun c -> + let tl = tys_of_constr_args c.Types.cd_args in + Btype.newgenty (Ttuple tl)) + "case" + (fun ppf c -> + fprintf ppf "%s of %a" (Ident.name c.Types.cd_id) + Printtyp.constructor_arguments c.Types.cd_args) + | Type_record (tl, _), _ -> + explain_unbound ppf ty tl + (fun l -> l.Types.ld_type) + "field" + (fun l -> Ident.name l.Types.ld_id ^ ": ") + | Type_abstract, Some ty' -> explain_unbound_single ppf ty ty' + | _ -> ()) + | Unbound_type_var_ext (ty, ext) -> + fprintf ppf "A type variable is unbound in this extension constructor"; + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") + | Cannot_extend_private_type path -> + fprintf ppf "@[%s@ %a@]" "Cannot extend private type definition" + Printtyp.path path + | Not_extensible_type path -> + fprintf ppf "@[%s@ %a@ %s@]" "Type definition" Printtyp.path path + "is not extensible" + | Extension_mismatch (path, errs) -> + fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]" "This extension" + "does not match the definition of type" (Path.name path) + (Includecore.report_type_mismatch "the type" "this extension" "definition") + errs + | Rebind_wrong_type (lid, env, trace) -> + Printtyp.report_unification_error ppf env trace + (function + | ppf -> + fprintf ppf "The constructor %a@ has type" Printtyp.longident lid) + (function ppf -> fprintf ppf "but was expected to be of type") + | Rebind_mismatch (lid, p, p') -> + fprintf ppf "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]" "The constructor" + Printtyp.longident lid "extends type" (Path.name p) + "whose declaration does not match" "the declaration of type" + (Path.name p') + | Rebind_private lid -> + fprintf ppf "@[%s@ %a@ %s@]" "The constructor" Printtyp.longident lid + "is private" + | Bad_variance (n, v1, v2) -> + let variance (p, n, i) = + let inj = if i then "injective " else "" in + match (p, n) with + | true, true -> inj ^ "invariant" + | true, false -> inj ^ "covariant" + | false, true -> inj ^ "contravariant" + | false, false -> if inj = "" then "unrestricted" else inj + in + let suffix n = + let teen = n mod 100 / 10 = 1 in + match n mod 10 with + | 1 when not teen -> "st" + | 2 when not teen -> "nd" + | 3 when not teen -> "rd" + | _ -> "th" + in + if n = -1 then + fprintf ppf "@[%s@ %s@ It" + "In this definition, a type variable has a variance that" + "is not reflected by its occurrence in type parameters." + else if n = -2 then + fprintf ppf "@[%s@ %s@]" + "In this definition, a type variable cannot be deduced" + "from the type parameters." + else if n = -3 then + fprintf ppf "@[%s@ %s@ It" + "In this definition, a type variable has a variance that" + "cannot be deduced from the type parameters." + else + fprintf ppf "@[%s@ %s@ The %d%s type parameter" + "In this definition, expected parameter" "variances are not satisfied." + n (suffix n); + if n <> -2 then + fprintf ppf " was expected to be %s,@ but it is %s.@]" (variance v2) + (variance v1) + | Unavailable_type_constructor p -> + fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p + | Bad_fixed_type r -> fprintf ppf "This fixed type %s" r + | Varying_anonymous -> + fprintf ppf "@[%s@ %s@ %s@]" "In this GADT definition," + "the variance of some parameter" "cannot be checked" + | Val_in_structure -> + fprintf ppf "Value declarations are only allowed in signatures" + | Bad_immediate_attribute -> + fprintf ppf "@[%s@ %s@]" "Types marked with the immediate attribute must be" + "non-pointer types like int or bool" + | Bad_unboxed_attribute msg -> + fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg + | Boxed_and_unboxed -> + fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]" + | Nonrec_gadt -> + fprintf ppf "@[GADT case syntax cannot be used in a 'nonrec' block.@]" + | Variant_runtime_representation_mismatch + (Variant_coercion.VariantError + { + is_spread_context; + error = Variant_coercion.Untagged {left_is_unboxed}; + }) -> + let other_variant_text = + if is_spread_context then "the variant where this is spread" + else "the other variant" + in + fprintf ppf "@[%s.@]" + ("This variant is " + ^ (if left_is_unboxed then "unboxed" else "not unboxed") + ^ ", but " ^ other_variant_text + ^ " is not. Both variants unboxed configuration must match") + | Variant_runtime_representation_mismatch + (Variant_coercion.VariantError + {is_spread_context; error = Variant_coercion.TagName _}) -> + let other_variant_text = + if is_spread_context then "the variant where this is spread" + else "the other variant" + in + fprintf ppf "@[%s.@]" + ("The @tag attribute does not match for this variant and " + ^ other_variant_text + ^ ". Both variants must have the same @tag attribute configuration, or no \ + @tag attribute at all") + | Variant_spread_fail Variant_type_spread.InvalidType -> + fprintf ppf + "@[This type is not a valid type to spread. It's only possible to spread \ + other variants.@]" + | Variant_spread_fail Variant_type_spread.CouldNotFindType -> + fprintf ppf + "@[This type could not be found. It's only possible to spread variants \ + that are known as the spread happens. This means for example that you \ + can't spread variants in recursive definitions.@]" + | Variant_spread_fail Variant_type_spread.HasTypeParams -> + fprintf ppf "@[Type parameters are not supported in variant type spreads.@]" + | Variant_spread_fail + (Variant_type_spread.DuplicateConstructor + {variant_with_overlapping_constructor; overlapping_constructor_name}) + -> + fprintf ppf + "@[Variant %s has a constructor named %s, but a constructor named %s \ + already exists in the variant it's spread into.@ You cannot spread \ + variants with overlapping constructors.@]" + variant_with_overlapping_constructor overlapping_constructor_name + overlapping_constructor_name + +let () = + Location.register_error_of_exn (function + | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) + | _ -> None) diff --git a/compiler/ml/typedecl.mli b/compiler/ml/typedecl.mli new file mode 100644 index 0000000..b9910bf --- /dev/null +++ b/compiler/ml/typedecl.mli @@ -0,0 +1,73 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Typing of type definitions and primitive definitions *) + +open Types +open Format + +val transl_type_decl : + Env.t -> + Asttypes.rec_flag -> + Parsetree.type_declaration list -> + Typedtree.type_declaration list * Env.t + +val transl_exception : + Env.t -> + Parsetree.extension_constructor -> + Typedtree.extension_constructor * Env.t + +val transl_type_extension : + bool -> + Env.t -> + Location.t -> + Parsetree.type_extension -> + Typedtree.type_extension * Env.t + +val transl_value_decl : + Env.t -> + Location.t -> + Parsetree.value_description -> + Typedtree.value_description * Env.t + +val transl_with_constraint : + Env.t -> + Ident.t -> + Path.t option -> + Types.type_declaration -> + Parsetree.type_declaration -> + Typedtree.type_declaration + +val abstract_type_decl : int -> type_declaration +val approx_type_decl : + Parsetree.type_declaration list -> (Ident.t * type_declaration) list +val check_recmod_typedecl : + Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit +val check_coherence : Env.t -> Location.t -> Ident.t -> type_declaration -> unit + +(* for fixed types *) +val is_fixed_type : Parsetree.type_declaration -> bool + +(* for typeopt.ml *) +val get_unboxed_type_representation : Env.t -> type_expr -> type_expr option +val is_not_undefined_attr : Parsetree.attribute -> bool + +type native_repr_kind = Unboxed | Untagged + +type error + +exception Error of Location.t * error + +val report_error : formatter -> error -> unit diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml new file mode 100644 index 0000000..e7274f1 --- /dev/null +++ b/compiler/ml/typedtree.ml @@ -0,0 +1,489 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Abstract syntax tree after typing *) + +open Misc +open Asttypes +open Types + +(* Value expressions for the core language *) + +type partial = Partial | Total + +type attribute = Parsetree.attribute +type attributes = attribute list + +type pattern = { + pat_desc: pattern_desc; + pat_loc: Location.t; + pat_extra: (pat_extra * Location.t * attribute list) list; + pat_type: type_expr; + mutable pat_env: Env.t; + pat_attributes: attribute list; +} + +and pat_extra = + | Tpat_constraint of core_type + | Tpat_type of Path.t * Longident.t loc + | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_unpack + +and pattern_desc = + | Tpat_any + | Tpat_var of Ident.t * string loc + | Tpat_alias of pattern * Ident.t * string loc + | Tpat_constant of constant + | Tpat_tuple of pattern list + | Tpat_construct of Longident.t loc * constructor_description * pattern list + | Tpat_variant of label * pattern option * row_desc ref + | Tpat_record of + (Longident.t loc * label_description * pattern * bool (* optional *)) list + * closed_flag + | Tpat_array of pattern list + | Tpat_or of pattern * pattern * row_desc option + +and expression = { + exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attribute list) list; + exp_type: type_expr; + exp_env: Env.t; + exp_attributes: attribute list; +} + +and exp_extra = + | Texp_constraint of core_type + | Texp_coerce of core_type + | Texp_open of override_flag * Path.t * Longident.t loc * Env.t + | Texp_newtype of string + +and expression_desc = + | Texp_ident of Path.t * Longident.t loc * Types.value_description + | Texp_constant of constant + | Texp_let of rec_flag * value_binding list * expression + | Texp_function of { + arg_label: arg_label; + arity: arity; + param: Ident.t; + case: case; + partial: partial; + async: bool; + } + | Texp_apply of { + funct: expression; + args: (arg_label * expression option) list; + partial: bool; + transformed_jsx: bool; + } + | Texp_match of expression * case list * case list * partial + | Texp_try of expression * case list + | Texp_tuple of expression list + | Texp_construct of + Longident.t loc * constructor_description * expression list + | Texp_variant of label * expression option + | Texp_record of { + fields: + (Types.label_description + * record_label_definition + * bool (* optional *)) + array; + representation: Types.record_representation; + extended_expression: expression option; + } + | Texp_field of expression * Longident.t loc * label_description + | Texp_setfield of + expression * Longident.t loc * label_description * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_while of expression * expression + | Texp_for of + Ident.t + * Parsetree.pattern + * expression + * expression + * direction_flag + * expression + | Texp_send of expression * meth * expression option + | Texp_letmodule of Ident.t * string loc * module_expr * expression + | Texp_letexception of extension_constructor * expression + | Texp_assert of expression + | Texp_pack of module_expr + | Texp_extension_constructor of Longident.t loc * Path.t + +and meth = Tmeth_name of string + +and case = {c_lhs: pattern; c_guard: expression option; c_rhs: expression} + +and record_label_definition = + | Kept of Types.type_expr + | Overridden of Longident.t loc * expression + +(* Value expressions for the module language *) +and module_expr = { + mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attribute list; +} + +and module_type_constraint = + | Tmodtype_implicit + | Tmodtype_explicit of module_type + +and module_expr_desc = + | Tmod_ident of Path.t * Longident.t loc + | Tmod_structure of structure + | Tmod_functor of Ident.t * string loc * module_type option * module_expr + | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + | Tmod_unpack of expression * Types.module_type + +and structure = { + str_items: structure_item list; + str_type: Types.signature; + str_final_env: Env.t; +} + +and structure_item = { + str_desc: structure_item_desc; + str_loc: Location.t; + str_env: Env.t; +} + +and structure_item_desc = + | Tstr_eval of expression * attributes + | Tstr_value of rec_flag * value_binding list + | Tstr_primitive of value_description + | Tstr_type of rec_flag * type_declaration list + | Tstr_typext of type_extension + | Tstr_exception of extension_constructor + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of module_type_declaration + | Tstr_open of open_description + | Tstr_include of include_declaration + | Tstr_attribute of attribute + +and module_binding = { + mb_id: Ident.t; + mb_name: string loc; + mb_expr: module_expr; + mb_attributes: attribute list; + mb_loc: Location.t; +} + +and value_binding = { + vb_pat: pattern; + vb_expr: expression; + vb_attributes: attributes; + vb_loc: Location.t; +} + +and module_coercion = + | Tcoerce_none + | Tcoerce_structure of + (int * module_coercion) list + * (Ident.t * int * module_coercion) list + * string list (* runtime fields *) + | Tcoerce_functor of module_coercion * module_coercion + | Tcoerce_primitive of primitive_coercion + | Tcoerce_alias of Path.t * module_coercion + +and module_type = { + mty_desc: module_type_desc; + mty_type: Types.module_type; + mty_env: Env.t; + mty_loc: Location.t; + mty_attributes: attribute list; +} + +and module_type_desc = + | Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of Ident.t * string loc * module_type option * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc + +(* Keep primitive type information for type-based lambda-code specialization *) +and primitive_coercion = { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc: Location.t; + pc_id: Ident.t; (*RE:Added *) +} + +and signature = { + sig_items: signature_item list; + sig_type: Types.signature; + sig_final_env: Env.t; +} + +and signature_item = { + sig_desc: signature_item_desc; + sig_env: Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t; +} + +and signature_item_desc = + | Tsig_value of value_description + | Tsig_type of rec_flag * type_declaration list + | Tsig_typext of type_extension + | Tsig_exception of extension_constructor + | Tsig_module of module_declaration + | Tsig_recmodule of module_declaration list + | Tsig_modtype of module_type_declaration + | Tsig_open of open_description + | Tsig_include of include_description + | Tsig_attribute of attribute + +and module_declaration = { + md_id: Ident.t; + md_name: string loc; + md_type: module_type; + md_attributes: attribute list; + md_loc: Location.t; +} + +and module_type_declaration = { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_type: module_type option; + mtd_attributes: attribute list; + mtd_loc: Location.t; +} + +and open_description = { + open_path: Path.t; + open_txt: Longident.t loc; + open_override: override_flag; + open_loc: Location.t; + open_attributes: attribute list; +} + +and 'a include_infos = { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; +} + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + +and with_constraint = + | Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + +and core_type = { + ctyp_desc: core_type_desc; + ctyp_type: type_expr; + ctyp_env: Env.t; (* BINANNOT ADDED *) + ctyp_loc: Location.t; + ctyp_attributes: attribute list; +} + +and arg = {attrs: attributes; lbl: arg_label; typ: core_type} + +and core_type_desc = + | Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of arg * core_type * arity + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of object_field list * closed_flag + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_path: Path.t; + pack_fields: (Longident.t loc * core_type) list; + pack_type: Types.module_type; + pack_txt: Longident.t loc; +} + +and row_field = + | Ttag of string loc * attributes * bool * core_type list + | Tinherit of core_type + +and object_field = + | OTtag of string loc * attributes * core_type + | OTinherit of core_type + +and value_description = { + val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attribute list; +} + +and type_declaration = { + typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * variance) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attribute list; +} + +and type_kind = + | Ttype_abstract + | Ttype_variant of constructor_declaration list + | Ttype_record of label_declaration list + | Ttype_open + +and label_declaration = { + ld_id: Ident.t; + ld_name: string loc; + ld_mutable: mutable_flag; + ld_optional: bool; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attribute list; +} + +and constructor_declaration = { + cd_id: Ident.t; + cd_name: string loc; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attribute list; +} + +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * variance) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_attributes: attribute list; +} + +and extension_constructor = { + ext_id: Ident.t; + ext_name: string loc; + ext_type: Types.extension_constructor; + ext_kind: extension_constructor_kind; + ext_loc: Location.t; + ext_attributes: attribute list; +} + +and extension_constructor_kind = + | Text_decl of constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + +(* Auxiliary functions over the a.s.t. *) + +let iter_pattern_desc f = function + | Tpat_alias (p, _, _) -> f p + | Tpat_tuple patl -> List.iter f patl + | Tpat_construct (_, _, patl) -> List.iter f patl + | Tpat_variant (_, pat, _) -> may f pat + | Tpat_record (lbl_pat_list, _) -> + List.iter (fun (_, _, pat, _) -> f pat) lbl_pat_list + | Tpat_array patl -> List.iter f patl + | Tpat_or (p1, p2, _) -> + f p1; + f p2 + | Tpat_any | Tpat_var _ | Tpat_constant _ -> () + +let map_pattern_desc f d = + match d with + | Tpat_alias (p1, id, s) -> Tpat_alias (f p1, id, s) + | Tpat_tuple pats -> Tpat_tuple (List.map f pats) + | Tpat_record (lpats, closed) -> + Tpat_record (List.map (fun (lid, l, p, o) -> (lid, l, f p, o)) lpats, closed) + | Tpat_construct (lid, c, pats) -> Tpat_construct (lid, c, List.map f pats) + | Tpat_array pats -> Tpat_array (List.map f pats) + | Tpat_variant (x1, Some p1, x2) -> Tpat_variant (x1, Some (f p1), x2) + | Tpat_or (p1, p2, path) -> Tpat_or (f p1, f p2, path) + | Tpat_var _ | Tpat_constant _ | Tpat_any | Tpat_variant (_, None, _) -> d + +(* List the identifiers bound by a pattern or a let *) + +let idents = ref ([] : (Ident.t * string loc) list) + +let rec bound_idents pat = + match pat.pat_desc with + | Tpat_var (id, s) -> idents := (id, s) :: !idents + | Tpat_alias (p, id, s) -> + bound_idents p; + idents := (id, s) :: !idents + | Tpat_or (p1, _, _) -> + (* Invariant : both arguments binds the same variables *) + bound_idents p1 + | d -> iter_pattern_desc bound_idents d + +let pat_bound_idents pat = + idents := []; + bound_idents pat; + let res = !idents in + idents := []; + List.map fst res + +let rev_let_bound_idents_with_loc bindings = + idents := []; + List.iter (fun vb -> bound_idents vb.vb_pat) bindings; + let res = !idents in + idents := []; + res + +let let_bound_idents_with_loc pat_expr_list = + List.rev (rev_let_bound_idents_with_loc pat_expr_list) + +let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat) +let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) + +let alpha_var env id = List.assoc id env + +let rec alpha_pat env p = + match p.pat_desc with + | Tpat_var (id, s) -> + (* note the ``Not_found'' case *) + { + p with + pat_desc = + (try Tpat_var (alpha_var env id, s) with Not_found -> Tpat_any); + } + | Tpat_alias (p1, id, s) -> ( + let new_p = alpha_pat env p1 in + try {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} + with Not_found -> new_p) + | d -> {p with pat_desc = map_pattern_desc (alpha_pat env) d} + +let mkloc = Location.mkloc +let mknoloc = Location.mknoloc diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli new file mode 100644 index 0000000..b1e7083 --- /dev/null +++ b/compiler/ml/typedtree.mli @@ -0,0 +1,529 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Abstract syntax tree after typing *) + +(** By comparison with {!Parsetree}: + - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. + +*) + +open Asttypes +open Types + +(* Value expressions for the core language *) + +type partial = Partial | Total + +(** {1 Extension points} *) + +type attribute = Parsetree.attribute +type attributes = attribute list + +(** {1 Core language} *) + +type pattern = { + pat_desc: pattern_desc; + pat_loc: Location.t; + pat_extra: (pat_extra * Location.t * attributes) list; + pat_type: type_expr; + mutable pat_env: Env.t; + pat_attributes: attributes; +} + +and pat_extra = + | Tpat_constraint of core_type + (** P : T { pat_desc = P + ; pat_extra = (Tpat_constraint T, _, _) :: ... } + *) + | Tpat_type of Path.t * Longident.t loc + (** #tconst { pat_desc = disjunction + ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...} + + where [disjunction] is a [Tpat_or _] representing the + branches of [tconst]. + *) + | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_unpack + (** (module P) { pat_desc = Tpat_var "P" + ; pat_extra = (Tpat_unpack, _, _) :: ... } + *) + +and pattern_desc = + | Tpat_any (** _ *) + | Tpat_var of Ident.t * string loc (** x *) + | Tpat_alias of pattern * Ident.t * string loc (** P as a *) + | Tpat_constant of constant (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Tpat_tuple of pattern list + (** (P1, ..., Pn) + + Invariant: n >= 2 + *) + | Tpat_construct of Longident.t loc * constructor_description * pattern list + (** C [] + C P [P] + C (P1, ..., Pn) [P1; ...; Pn] + *) + | Tpat_variant of label * pattern option * row_desc ref + (** `A (None) + `A P (Some P) + + See {!Types.row_desc} for an explanation of the last parameter. + *) + | Tpat_record of + (Longident.t loc * label_description * pattern * bool (* optional *)) list + * closed_flag + (** { l1=P1; ...; ln=Pn } (flag = Closed) + { l1=P1; ...; ln=Pn; _} (flag = Open) + + Invariant: n > 0 + *) + | Tpat_array of pattern list (** [| P1; ...; Pn |] *) + | Tpat_or of pattern * pattern * row_desc option + (** P1 | P2 + + [row_desc] = [Some _] when translating [Ppat_type _], + [None] otherwise. + *) + +and expression = { + exp_desc: expression_desc; + exp_loc: Location.t; + exp_extra: (exp_extra * Location.t * attributes) list; + exp_type: type_expr; + exp_env: Env.t; + exp_attributes: attributes; +} + +and exp_extra = + | Texp_constraint of core_type (** E : T *) + | Texp_coerce of core_type (** E :> T [Texp_coerce T] + *) + | Texp_open of override_flag * Path.t * Longident.t loc * Env.t + (** let open[!] M in [Texp_open (!, P, M, env)] + where [env] is the environment after opening [P] + *) + | Texp_newtype of string (** fun (type t) -> *) + +and expression_desc = + | Texp_ident of Path.t * Longident.t loc * Types.value_description + (** x + M.x + *) + | Texp_constant of constant (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) + | Texp_let of rec_flag * value_binding list * expression + (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) + let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) + *) + | Texp_function of { + arg_label: arg_label; + arity: arity; + param: Ident.t; + case: case; + partial: partial; + async: bool; + } + (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. + See {!Parsetree} for more details. + + [param] is the identifier that is to be used to name the + parameter of the function. + + partial = + [Partial] if the pattern match is partial + [Total] otherwise. + *) + | Texp_apply of { + funct: expression; + args: (arg_label * expression option) list; + partial: bool; + transformed_jsx: bool; + } + (** E0 ~l1:E1 ... ~ln:En + + The expression can be None if the expression is abstracted over + this argument. It currently appears when a label is applied. + + For example: + let f x ~y = x + y in + f ~y:3 + + The resulting typedtree for the application is: + Texp_apply (Texp_ident "f/1037", + [(Nolabel, None); + (Labelled "y", Some (Texp_constant Const_int 3)) + ]) + *) + | Texp_match of expression * case list * case list * partial + (** match E0 with + | P1 -> E1 + | P2 -> E2 + | exception P3 -> E3 + + [Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)] + *) + | Texp_try of expression * case list + (** try E with P1 -> E1 | ... | PN -> EN *) + | Texp_tuple of expression list (** (E1, ..., EN) *) + | Texp_construct of + Longident.t loc * constructor_description * expression list + (** C [] + C E [E] + C (E1, ..., En) [E1;...;En] + *) + | Texp_variant of label * expression option + | Texp_record of { + fields: + (Types.label_description + * record_label_definition + * bool (* optional *)) + array; + representation: Types.record_representation; + extended_expression: expression option; + } + (** { l1=P1; ...; ln=Pn } (extended_expression = None) + { E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0) + + Invariant: n > 0 + + If the type is { l1: t1; l2: t2 }, the expression + { E0 with t2=P2 } is represented as + Texp_record + { fields = [| l1, Kept t1; l2 Override P2 |]; representation; + extended_expression = Some E0 } + *) + | Texp_field of expression * Longident.t loc * label_description + | Texp_setfield of + expression * Longident.t loc * label_description * expression + | Texp_array of expression list + | Texp_ifthenelse of expression * expression * expression option + | Texp_sequence of expression * expression + | Texp_while of expression * expression + | Texp_for of + Ident.t + * Parsetree.pattern + * expression + * expression + * direction_flag + * expression + | Texp_send of expression * meth * expression option + | Texp_letmodule of Ident.t * string loc * module_expr * expression + | Texp_letexception of extension_constructor * expression + | Texp_assert of expression + | Texp_pack of module_expr + | Texp_extension_constructor of Longident.t loc * Path.t + +and meth = Tmeth_name of string + +and case = {c_lhs: pattern; c_guard: expression option; c_rhs: expression} + +and record_label_definition = + | Kept of Types.type_expr + | Overridden of Longident.t loc * expression + +(* Value expressions for the module language *) +and module_expr = { + mod_desc: module_expr_desc; + mod_loc: Location.t; + mod_type: Types.module_type; + mod_env: Env.t; + mod_attributes: attributes; +} + +(** Annotations for [Tmod_constraint]. *) +and module_type_constraint = + | Tmodtype_implicit + (** The module type constraint has been synthesized during typechecking. *) + | Tmodtype_explicit of module_type + (** The module type was in the source file. *) + +and module_expr_desc = + | Tmod_ident of Path.t * Longident.t loc + | Tmod_structure of structure + | Tmod_functor of Ident.t * string loc * module_type option * module_expr + | Tmod_apply of module_expr * module_expr * module_coercion + | Tmod_constraint of + module_expr * Types.module_type * module_type_constraint * module_coercion + (** ME (constraint = Tmodtype_implicit) + (ME : MT) (constraint = Tmodtype_explicit MT) + *) + | Tmod_unpack of expression * Types.module_type + +and structure = { + str_items: structure_item list; + str_type: Types.signature; + str_final_env: Env.t; +} + +and structure_item = { + str_desc: structure_item_desc; + str_loc: Location.t; + str_env: Env.t; +} + +and structure_item_desc = + | Tstr_eval of expression * attributes + | Tstr_value of rec_flag * value_binding list + | Tstr_primitive of value_description + | Tstr_type of rec_flag * type_declaration list + | Tstr_typext of type_extension + | Tstr_exception of extension_constructor + | Tstr_module of module_binding + | Tstr_recmodule of module_binding list + | Tstr_modtype of module_type_declaration + | Tstr_open of open_description + | Tstr_include of include_declaration + | Tstr_attribute of attribute + +and module_binding = { + mb_id: Ident.t; + mb_name: string loc; + mb_expr: module_expr; + mb_attributes: attributes; + mb_loc: Location.t; +} + +and value_binding = { + vb_pat: pattern; + vb_expr: expression; + vb_attributes: attributes; + vb_loc: Location.t; +} + +and module_coercion = + | Tcoerce_none + | Tcoerce_structure of + (int * module_coercion) list + * (Ident.t * int * module_coercion) list + * string list (* runtime fields *) + | Tcoerce_functor of module_coercion * module_coercion + | Tcoerce_primitive of primitive_coercion + | Tcoerce_alias of Path.t * module_coercion + +and module_type = { + mty_desc: module_type_desc; + mty_type: Types.module_type; + mty_env: Env.t; + mty_loc: Location.t; + mty_attributes: attributes; +} + +and module_type_desc = + | Tmty_ident of Path.t * Longident.t loc + | Tmty_signature of signature + | Tmty_functor of Ident.t * string loc * module_type option * module_type + | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list + | Tmty_typeof of module_expr + | Tmty_alias of Path.t * Longident.t loc + +and primitive_coercion = { + pc_desc: Primitive.description; + pc_type: type_expr; + pc_env: Env.t; + pc_loc: Location.t; + pc_id: Ident.t; +} + +and signature = { + sig_items: signature_item list; + sig_type: Types.signature; + sig_final_env: Env.t; +} + +and signature_item = { + sig_desc: signature_item_desc; + sig_env: Env.t; (* BINANNOT ADDED *) + sig_loc: Location.t; +} + +and signature_item_desc = + | Tsig_value of value_description + | Tsig_type of rec_flag * type_declaration list + | Tsig_typext of type_extension + | Tsig_exception of extension_constructor + | Tsig_module of module_declaration + | Tsig_recmodule of module_declaration list + | Tsig_modtype of module_type_declaration + | Tsig_open of open_description + | Tsig_include of include_description + | Tsig_attribute of attribute + +and module_declaration = { + md_id: Ident.t; + md_name: string loc; + md_type: module_type; + md_attributes: attributes; + md_loc: Location.t; +} + +and module_type_declaration = { + mtd_id: Ident.t; + mtd_name: string loc; + mtd_type: module_type option; + mtd_attributes: attributes; + mtd_loc: Location.t; +} + +and open_description = { + open_path: Path.t; + open_txt: Longident.t loc; + open_override: override_flag; + open_loc: Location.t; + open_attributes: attribute list; +} + +and 'a include_infos = { + incl_mod: 'a; + incl_type: Types.signature; + incl_loc: Location.t; + incl_attributes: attribute list; +} + +and include_description = module_type include_infos + +and include_declaration = module_expr include_infos + +and with_constraint = + | Twith_type of type_declaration + | Twith_module of Path.t * Longident.t loc + | Twith_typesubst of type_declaration + | Twith_modsubst of Path.t * Longident.t loc + +and core_type = { + ctyp_desc: core_type_desc; + ctyp_type: type_expr; + ctyp_env: Env.t; (* BINANNOT ADDED *) + ctyp_loc: Location.t; + ctyp_attributes: attributes; +} + +and arg = {attrs: attributes; lbl: arg_label; typ: core_type} + +and core_type_desc = + | Ttyp_any + | Ttyp_var of string + | Ttyp_arrow of arg * core_type * arity + | Ttyp_tuple of core_type list + | Ttyp_constr of Path.t * Longident.t loc * core_type list + | Ttyp_object of object_field list * closed_flag + | Ttyp_alias of core_type * string + | Ttyp_variant of row_field list * closed_flag * label list option + | Ttyp_poly of string list * core_type + | Ttyp_package of package_type + +and package_type = { + pack_path: Path.t; + pack_fields: (Longident.t loc * core_type) list; + pack_type: Types.module_type; + pack_txt: Longident.t loc; +} + +and row_field = + | Ttag of string loc * attributes * bool * core_type list + | Tinherit of core_type + +and object_field = + | OTtag of string loc * attributes * core_type + | OTinherit of core_type + +and value_description = { + val_id: Ident.t; + val_name: string loc; + val_desc: core_type; + val_val: Types.value_description; + val_prim: string list; + val_loc: Location.t; + val_attributes: attributes; +} + +and type_declaration = { + typ_id: Ident.t; + typ_name: string loc; + typ_params: (core_type * variance) list; + typ_type: Types.type_declaration; + typ_cstrs: (core_type * core_type * Location.t) list; + typ_kind: type_kind; + typ_private: private_flag; + typ_manifest: core_type option; + typ_loc: Location.t; + typ_attributes: attributes; +} + +and type_kind = + | Ttype_abstract + | Ttype_variant of constructor_declaration list + | Ttype_record of label_declaration list + | Ttype_open + +and label_declaration = { + ld_id: Ident.t; + ld_name: string loc; + ld_mutable: mutable_flag; + ld_optional: bool; + ld_type: core_type; + ld_loc: Location.t; + ld_attributes: attributes; +} + +and constructor_declaration = { + cd_id: Ident.t; + cd_name: string loc; + cd_args: constructor_arguments; + cd_res: core_type option; + cd_loc: Location.t; + cd_attributes: attributes; +} + +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + +and type_extension = { + tyext_path: Path.t; + tyext_txt: Longident.t loc; + tyext_params: (core_type * variance) list; + tyext_constructors: extension_constructor list; + tyext_private: private_flag; + tyext_attributes: attributes; +} + +and extension_constructor = { + ext_id: Ident.t; + ext_name: string loc; + ext_type: Types.extension_constructor; + ext_kind: extension_constructor_kind; + ext_loc: Location.t; + ext_attributes: attributes; +} + +and extension_constructor_kind = + | Text_decl of constructor_arguments * core_type option + | Text_rebind of Path.t * Longident.t loc + +(* Auxiliary functions over the a.s.t. *) + +val iter_pattern_desc : (pattern -> unit) -> pattern_desc -> unit +val map_pattern_desc : (pattern -> pattern) -> pattern_desc -> pattern_desc + +val let_bound_idents : value_binding list -> Ident.t list +val rev_let_bound_idents : value_binding list -> Ident.t list + +val alpha_pat : (Ident.t * Ident.t) list -> pattern -> pattern +(** Alpha conversion of patterns *) + +val mknoloc : 'a -> 'a Asttypes.loc +val mkloc : 'a -> Location.t -> 'a Asttypes.loc + +val pat_bound_idents : pattern -> Ident.t list diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml new file mode 100644 index 0000000..9a31b9b --- /dev/null +++ b/compiler/ml/typedtreeIter.ml @@ -0,0 +1,446 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 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. *) +(* *) +(**************************************************************************) + +(* +TODO: + - 2012/05/10: Follow camlp4 way of building map and iter using classes + and inheritance ? +*) + +open Asttypes +open Typedtree + +module type IteratorArgument = sig + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit + + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit +end + +module MakeIterator (Iter : IteratorArgument) : sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit +end = struct + let may_iter f v = + match v with + | None -> () + | Some x -> f x + + let rec iter_structure str = + Iter.enter_structure str; + List.iter iter_structure_item str.str_items; + Iter.leave_structure str + + and iter_binding vb = + Iter.enter_binding vb; + iter_pattern vb.vb_pat; + iter_expression vb.vb_expr; + Iter.leave_binding vb + + and iter_bindings rec_flag list = + Iter.enter_bindings rec_flag; + List.iter iter_binding list; + Iter.leave_bindings rec_flag + + and iter_case {c_lhs; c_guard; c_rhs} = + iter_pattern c_lhs; + may_iter iter_expression c_guard; + iter_expression c_rhs + + and iter_cases cases = List.iter iter_case cases + + and iter_structure_item item = + Iter.enter_structure_item item; + (match item.str_desc with + | Tstr_eval (exp, _attrs) -> iter_expression exp + | Tstr_value (rec_flag, list) -> iter_bindings rec_flag list + | Tstr_primitive vd -> iter_value_description vd + | Tstr_type (rf, list) -> iter_type_declarations rf list + | Tstr_typext tyext -> iter_type_extension tyext + | Tstr_exception ext -> iter_extension_constructor ext + | Tstr_module x -> iter_module_binding x + | Tstr_recmodule list -> List.iter iter_module_binding list + | Tstr_modtype mtd -> iter_module_type_declaration mtd + | Tstr_open _ -> () + | Tstr_include incl -> iter_module_expr incl.incl_mod + | Tstr_attribute _ -> ()); + Iter.leave_structure_item item + + and iter_module_binding x = iter_module_expr x.mb_expr + + and iter_value_description v = + Iter.enter_value_description v; + iter_core_type v.val_desc; + Iter.leave_value_description v + + and iter_constructor_arguments = function + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l + + and iter_constructor_declaration cd = + iter_constructor_arguments cd.cd_args; + option iter_core_type cd.cd_res + + and iter_type_parameter (ct, _v) = iter_core_type ct + + and iter_type_declaration decl = + Iter.enter_type_declaration decl; + List.iter iter_type_parameter decl.typ_params; + List.iter + (fun (ct1, ct2, _loc) -> + iter_core_type ct1; + iter_core_type ct2) + decl.typ_cstrs; + (match decl.typ_kind with + | Ttype_abstract -> () + | Ttype_variant list -> List.iter iter_constructor_declaration list + | Ttype_record list -> List.iter (fun ld -> iter_core_type ld.ld_type) list + | Ttype_open -> ()); + option iter_core_type decl.typ_manifest; + Iter.leave_type_declaration decl + + and iter_type_declarations rec_flag decls = + Iter.enter_type_declarations rec_flag; + List.iter iter_type_declaration decls; + Iter.leave_type_declarations rec_flag + + and iter_extension_constructor ext = + Iter.enter_extension_constructor ext; + (match ext.ext_kind with + | Text_decl (args, ret) -> + iter_constructor_arguments args; + option iter_core_type ret + | Text_rebind _ -> ()); + Iter.leave_extension_constructor ext + + and iter_type_extension tyext = + Iter.enter_type_extension tyext; + List.iter iter_type_parameter tyext.tyext_params; + List.iter iter_extension_constructor tyext.tyext_constructors; + Iter.leave_type_extension tyext + + and iter_pattern pat = + Iter.enter_pattern pat; + List.iter + (fun (cstr, _, _attrs) -> + match cstr with + | Tpat_type _ -> () + | Tpat_unpack -> () + | Tpat_open _ -> () + | Tpat_constraint ct -> iter_core_type ct) + pat.pat_extra; + (match pat.pat_desc with + | Tpat_any -> () + | Tpat_var _ -> () + | Tpat_alias (pat1, _, _) -> iter_pattern pat1 + | Tpat_constant _ -> () + | Tpat_tuple list -> List.iter iter_pattern list + | Tpat_construct (_, _, args) -> List.iter iter_pattern args + | Tpat_variant (_, pato, _) -> ( + match pato with + | None -> () + | Some pat -> iter_pattern pat) + | Tpat_record (list, _closed) -> + List.iter (fun (_, _, pat, _) -> iter_pattern pat) list + | Tpat_array list -> List.iter iter_pattern list + | Tpat_or (p1, p2, _) -> + iter_pattern p1; + iter_pattern p2); + Iter.leave_pattern pat + + and option f x = + match x with + | None -> () + | Some e -> f e + + and iter_expression exp = + Iter.enter_expression exp; + List.iter + (function + | cstr, _, _attrs -> ( + match cstr with + | Texp_constraint ct -> iter_core_type ct + | Texp_coerce cty2 -> iter_core_type cty2 + | Texp_open _ -> () + | Texp_newtype _ -> ())) + exp.exp_extra; + (match exp.exp_desc with + | Texp_ident _ -> () + | Texp_constant _ -> () + | Texp_let (rec_flag, list, exp) -> + iter_bindings rec_flag list; + iter_expression exp + | Texp_function {case; _} -> iter_case case + | Texp_apply {funct = exp; args = list} -> + iter_expression exp; + List.iter + (fun (_label, expo) -> + match expo with + | None -> () + | Some exp -> iter_expression exp) + list + | Texp_match (exp, list1, list2, _) -> + iter_expression exp; + iter_cases list1; + iter_cases list2 + | Texp_try (exp, list) -> + iter_expression exp; + iter_cases list + | Texp_tuple list -> List.iter iter_expression list + | Texp_construct (_, _, args) -> List.iter iter_expression args + | Texp_variant (_label, expo) -> ( + match expo with + | None -> () + | Some exp -> iter_expression exp) + | Texp_record {fields; extended_expression; _} -> ( + Array.iter + (function + | _, Kept _, _ -> () + | _, Overridden (_, exp), _ -> iter_expression exp) + fields; + match extended_expression with + | None -> () + | Some exp -> iter_expression exp) + | Texp_field (exp, _, _label) -> iter_expression exp + | Texp_setfield (exp1, _, _label, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_array list -> List.iter iter_expression list + | Texp_ifthenelse (exp1, exp2, expo) -> ( + iter_expression exp1; + iter_expression exp2; + match expo with + | None -> () + | Some exp -> iter_expression exp) + | Texp_sequence (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_while (exp1, exp2) -> + iter_expression exp1; + iter_expression exp2 + | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> + iter_expression exp1; + iter_expression exp2; + iter_expression exp3 + | Texp_send (exp, _meth, expo) -> ( + iter_expression exp; + match expo with + | None -> () + | Some exp -> iter_expression exp) + | Texp_letmodule (_id, _, mexpr, exp) -> + iter_module_expr mexpr; + iter_expression exp + | Texp_letexception (cd, exp) -> + iter_extension_constructor cd; + iter_expression exp + | Texp_assert exp -> iter_expression exp + | Texp_pack mexpr -> iter_module_expr mexpr + | Texp_extension_constructor _ -> ()); + Iter.leave_expression exp + + and iter_package_type pack = + Iter.enter_package_type pack; + List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; + Iter.leave_package_type pack + + and iter_signature sg = + Iter.enter_signature sg; + List.iter iter_signature_item sg.sig_items; + Iter.leave_signature sg + + and iter_signature_item item = + Iter.enter_signature_item item; + (match item.sig_desc with + | Tsig_value vd -> iter_value_description vd + | Tsig_type (rf, list) -> iter_type_declarations rf list + | Tsig_exception ext -> iter_extension_constructor ext + | Tsig_typext tyext -> iter_type_extension tyext + | Tsig_module md -> iter_module_type md.md_type + | Tsig_recmodule list -> + List.iter (fun md -> iter_module_type md.md_type) list + | Tsig_modtype mtd -> iter_module_type_declaration mtd + | Tsig_open _ -> () + | Tsig_include incl -> iter_module_type incl.incl_mod + | Tsig_attribute _ -> ()); + Iter.leave_signature_item item + + and iter_module_type_declaration mtd = + Iter.enter_module_type_declaration mtd; + (match mtd.mtd_type with + | None -> () + | Some mtype -> iter_module_type mtype); + Iter.leave_module_type_declaration mtd + + and iter_module_type mty = + Iter.enter_module_type mty; + (match mty.mty_desc with + | Tmty_ident _ -> () + | Tmty_alias _ -> () + | Tmty_signature sg -> iter_signature sg + | Tmty_functor (_, _, mtype1, mtype2) -> + Misc.may iter_module_type mtype1; + iter_module_type mtype2 + | Tmty_with (mtype, list) -> + iter_module_type mtype; + List.iter (fun (_path, _, withc) -> iter_with_constraint withc) list + | Tmty_typeof mexpr -> iter_module_expr mexpr); + Iter.leave_module_type mty + + and iter_with_constraint cstr = + Iter.enter_with_constraint cstr; + (match cstr with + | Twith_type decl -> iter_type_declaration decl + | Twith_module _ -> () + | Twith_typesubst decl -> iter_type_declaration decl + | Twith_modsubst _ -> ()); + Iter.leave_with_constraint cstr + + and iter_module_expr mexpr = + Iter.enter_module_expr mexpr; + (match mexpr.mod_desc with + | Tmod_ident _ -> () + | Tmod_structure st -> iter_structure st + | Tmod_functor (_, _, mtype, mexpr) -> + Misc.may iter_module_type mtype; + iter_module_expr mexpr + | Tmod_apply (mexp1, mexp2, _) -> + iter_module_expr mexp1; + iter_module_expr mexp2 + | Tmod_constraint (mexpr, _, Tmodtype_implicit, _) -> iter_module_expr mexpr + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + iter_module_expr mexpr; + iter_module_type mtype + | Tmod_unpack (exp, _mty) -> iter_expression exp) + (* iter_module_type mty *); + Iter.leave_module_expr mexpr + + and iter_core_type ct = + Iter.enter_core_type ct; + (match ct.ctyp_desc with + | Ttyp_any -> () + | Ttyp_var _ -> () + | Ttyp_arrow (arg, ret, _) -> + iter_core_type arg.typ; + iter_core_type ret + | Ttyp_tuple list -> List.iter iter_core_type list + | Ttyp_constr (_path, _, list) -> List.iter iter_core_type list + | Ttyp_object (list, _o) -> List.iter iter_object_field list + | Ttyp_alias (ct, _s) -> iter_core_type ct + | Ttyp_variant (list, _bool, _labels) -> List.iter iter_row_field list + | Ttyp_poly (_list, ct) -> iter_core_type ct + | Ttyp_package pack -> iter_package_type pack); + Iter.leave_core_type ct + + and iter_row_field rf = + match rf with + | Ttag (_label, _attrs, _bool, list) -> List.iter iter_core_type list + | Tinherit ct -> iter_core_type ct + + and iter_object_field ofield = + match ofield with + | OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct +end + +module DefaultIteratorArgument = struct + let enter_structure _ = () + let enter_value_description _ = () + let enter_type_extension _ = () + let enter_extension_constructor _ = () + let enter_pattern _ = () + let enter_expression _ = () + let enter_package_type _ = () + let enter_signature _ = () + let enter_signature_item _ = () + let enter_module_type_declaration _ = () + let enter_module_type _ = () + let enter_module_expr _ = () + let enter_with_constraint _ = () + + let enter_core_type _ = () + let enter_structure_item _ = () + + let leave_structure _ = () + let leave_value_description _ = () + let leave_type_extension _ = () + let leave_extension_constructor _ = () + let leave_pattern _ = () + let leave_expression _ = () + let leave_package_type _ = () + let leave_signature _ = () + let leave_signature_item _ = () + let leave_module_type_declaration _ = () + let leave_module_type _ = () + let leave_module_expr _ = () + let leave_with_constraint _ = () + + let leave_core_type _ = () + let leave_structure_item _ = () + + let enter_binding _ = () + let leave_binding _ = () + + let enter_bindings _ = () + let leave_bindings _ = () + + let enter_type_declaration _ = () + let leave_type_declaration _ = () + + let enter_type_declarations _ = () + let leave_type_declarations _ = () +end diff --git a/compiler/ml/typedtreeIter.mli b/compiler/ml/typedtreeIter.mli new file mode 100644 index 0000000..17adaa6 --- /dev/null +++ b/compiler/ml/typedtreeIter.mli @@ -0,0 +1,74 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Typedtree + +module type IteratorArgument = sig + val enter_structure : structure -> unit + val enter_value_description : value_description -> unit + val enter_type_extension : type_extension -> unit + val enter_extension_constructor : extension_constructor -> unit + val enter_pattern : pattern -> unit + val enter_expression : expression -> unit + val enter_package_type : package_type -> unit + val enter_signature : signature -> unit + val enter_signature_item : signature_item -> unit + val enter_module_type_declaration : module_type_declaration -> unit + val enter_module_type : module_type -> unit + val enter_module_expr : module_expr -> unit + val enter_with_constraint : with_constraint -> unit + val enter_core_type : core_type -> unit + val enter_structure_item : structure_item -> unit + + val leave_structure : structure -> unit + val leave_value_description : value_description -> unit + val leave_type_extension : type_extension -> unit + val leave_extension_constructor : extension_constructor -> unit + val leave_pattern : pattern -> unit + val leave_expression : expression -> unit + val leave_package_type : package_type -> unit + val leave_signature : signature -> unit + val leave_signature_item : signature_item -> unit + val leave_module_type_declaration : module_type_declaration -> unit + val leave_module_type : module_type -> unit + val leave_module_expr : module_expr -> unit + val leave_with_constraint : with_constraint -> unit + val leave_core_type : core_type -> unit + val leave_structure_item : structure_item -> unit + + val enter_bindings : rec_flag -> unit + val enter_binding : value_binding -> unit + val leave_binding : value_binding -> unit + val leave_bindings : rec_flag -> unit + + val enter_type_declarations : rec_flag -> unit + val enter_type_declaration : type_declaration -> unit + val leave_type_declaration : type_declaration -> unit + val leave_type_declarations : rec_flag -> unit +end + +module MakeIterator : functor (Iter : IteratorArgument) -> sig + val iter_structure : structure -> unit + val iter_signature : signature -> unit + val iter_structure_item : structure_item -> unit + val iter_signature_item : signature_item -> unit + val iter_expression : expression -> unit + val iter_module_type : module_type -> unit + val iter_pattern : pattern -> unit +end +[@@warning "-67"] + +module DefaultIteratorArgument : IteratorArgument diff --git a/compiler/ml/typemod.ml b/compiler/ml/typemod.ml new file mode 100644 index 0000000..0932c62 --- /dev/null +++ b/compiler/ml/typemod.ml @@ -0,0 +1,1908 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +open Misc +open Longident +open Path +open Asttypes +open Parsetree +open Types +open Format + +type error = + | Cannot_apply of module_type + | Not_included of Includemod.error list + | Cannot_eliminate_dependency of module_type + | Signature_expected + | Structure_expected of module_type + | With_no_component of Longident.t + | With_mismatch of Longident.t * Includemod.error list + | With_makes_applicative_functor_ill_typed of + Longident.t * Path.t * Includemod.error list + | With_changes_module_alias of Longident.t * Ident.t * Path.t + | With_cannot_remove_constrained_type + | Repeated_name of string * string * Warnings.loc + | Non_generalizable of type_expr + | Non_generalizable_module of module_type + | Interface_not_compiled of string + | Not_allowed_in_functor_body + | Not_a_packed_module of type_expr + | Incomplete_packed_module of type_expr + | Scoping_pack of Longident.t * type_expr + | Recursive_module_require_explicit_type + | Apply_generative + | Cannot_scrape_alias of Path.t + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +let rescript_hide_attributes (x : Typedtree.attributes) = + match x with + | [] -> false + | ({txt = "internal.local"; _}, _) :: _ -> true + | _ :: rest -> Ext_list.exists rest (fun (x, _) -> x.txt = "internal.local") + +let rescript_hide (x : Typedtree.structure_item_desc) = + match x with + | Tstr_module {mb_attributes} -> rescript_hide_attributes mb_attributes + | _ -> false + +open Typedtree + +let fst3 (x, _, _) = x + +let rec path_concat head p = + match p with + | Pident tail -> Pdot (Pident head, Ident.name tail, 0) + | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos) + | Papply _ -> assert false + +(* Extract a signature from a module type *) + +let extract_sig env loc mty = + match Env.scrape_alias env mty with + | Mty_signature sg -> sg + | Mty_alias (_, path) -> raise (Error (loc, env, Cannot_scrape_alias path)) + | _ -> raise (Error (loc, env, Signature_expected)) + +let extract_sig_open env loc mty = + match Env.scrape_alias env mty with + | Mty_signature sg -> sg + | Mty_alias (_, path) -> raise (Error (loc, env, Cannot_scrape_alias path)) + | mty -> raise (Error (loc, env, Structure_expected mty)) + +(* Compute the environment after opening a module *) + +let type_open_ ?used_slot ?toplevel ovf env loc lid = + let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in + match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with + | Some env -> (path, env) + | None -> + let md = Env.find_module path env in + ignore (extract_sig_open env lid.loc md.md_type); + assert false + +let type_open ?toplevel env sod = + let path, newenv = + Builtin_attributes.warning_scope sod.popen_attributes (fun () -> + type_open_ ?toplevel sod.popen_override env sod.popen_loc sod.popen_lid) + in + let od = + { + open_override = sod.popen_override; + open_path = path; + open_txt = sod.popen_lid; + open_attributes = sod.popen_attributes; + open_loc = sod.popen_loc; + } + in + (path, newenv, od) + +(* Record a module type *) +let rm node = + Stypes.record (Stypes.Ti_mod node); + node + +(* Forward declaration, to be filled in by type_module_type_of *) +let type_module_type_of_fwd : + (Env.t -> + Parsetree.module_expr -> + Typedtree.module_expr * Types.module_type) + ref = + ref (fun _env _m -> assert false) + +(* Merge one "with" constraint in a signature *) + +let rec add_rec_types env = function + | Sig_type (id, decl, Trec_next) :: rem -> + add_rec_types (Env.add_type ~check:true id decl env) rem + | _ -> env + +let check_type_decl env loc id row_id newdecl decl rs rem = + let env = Env.add_type ~check:true id newdecl env in + let env = + match row_id with + | None -> env + | Some id -> Env.add_type ~check:false id newdecl env + in + let env = if rs = Trec_not then env else add_rec_types env rem in + Includemod.type_declarations ~loc env id newdecl decl; + Typedecl.check_coherence env loc id newdecl + +let update_rec_next rs rem = + match rs with + | Trec_next -> rem + | Trec_first | Trec_not -> ( + match rem with + | Sig_type (id, decl, Trec_next) :: rem -> Sig_type (id, decl, rs) :: rem + | Sig_module (id, mty, Trec_next) :: rem -> Sig_module (id, mty, rs) :: rem + | _ -> rem) + +let make p n i = + let open Variance in + set May_pos p (set May_neg n (set May_weak n (set Inj i null))) + +let rec iter_path_apply p ~f = + match p with + | Pident _ -> () + | Pdot (p, _, _) -> iter_path_apply p ~f + | Papply (p1, p2) -> + iter_path_apply p1 ~f; + iter_path_apply p2 ~f; + f p1 p2 (* after recursing, so we know both paths are well typed *) + +let path_is_strict_prefix = + let rec list_is_strict_prefix l ~prefix = + match (l, prefix) with + | [], [] -> false + | _ :: _, [] -> true + | [], _ :: _ -> false + | s1 :: t1, s2 :: t2 -> + String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2 + in + fun path ~prefix -> + match (Path.flatten path, Path.flatten prefix) with + | `Contains_apply, _ | _, `Contains_apply -> false + | `Ok (ident1, l1), `Ok (ident2, l2) -> + Ident.same ident1 ident2 && list_is_strict_prefix l1 ~prefix:l2 + +let iterator_with_env env = + let env = ref env in + let super = Btype.type_iterators in + ( env, + { + super with + Btype.it_signature = + (fun self sg -> + (* add all items to the env before recursing down, to handle recursive + definitions *) + let env_before = !env in + List.iter (fun i -> env := Env.add_item i !env) sg; + super.Btype.it_signature self sg; + env := env_before); + Btype.it_module_type = + (fun self -> function + | Mty_functor (param, mty_arg, mty_body) -> + may (self.Btype.it_module_type self) mty_arg; + let env_before = !env in + env := + Env.add_module ~arg:true param (Btype.default_mty mty_arg) !env; + self.Btype.it_module_type self mty_body; + env := env_before + | mty -> super.Btype.it_module_type self mty); + } ) + +let retype_applicative_functor_type ~loc env funct arg = + let mty_functor = (Env.find_module funct env).md_type in + let mty_arg = (Env.find_module arg env).md_type in + let mty_param = + match Env.scrape_alias env mty_functor with + | Mty_functor (_, Some mty_param, _) -> mty_param + | _ -> assert false (* could trigger due to MPR#7611 *) + in + let aliasable = not (Env.is_functor_arg arg env) in + ignore + (Includemod.modtypes ~loc env + (Mtype.strengthen ~aliasable env mty_arg arg) + mty_param) + +(* When doing a deep destructive substitution with type M.N.t := .., we change M + and M.N and so we have to check that uses of the modules other than just + extracting components from them still make sense. There are only two such + kinds of uses: + - applicative functor types: F(M).t might not be well typed anymore + - aliases: module A = M still makes sense but it doesn't mean the same thing + anymore, so it's forbidden until it's clear what we should do with it. + This function would be called with M.N.t and N.t to check for these uses. *) +let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid = + let iterator = + let env, super = iterator_with_env env in + { + super with + Btype.it_signature_item = + (fun self -> function + | Sig_module (id, {md_type = Mty_alias (_, aliased_path); _}, _) + when List.exists + (fun path -> path_is_strict_prefix path ~prefix:aliased_path) + paths -> + let e = With_changes_module_alias (lid.txt, id, aliased_path) in + raise (Error (loc, !env, e)) + | sig_item -> super.Btype.it_signature_item self sig_item); + Btype.it_path = + (fun referenced_path -> + iter_path_apply referenced_path ~f:(fun funct arg -> + if + List.exists + (fun path -> path_is_strict_prefix path ~prefix:arg) + paths + then + let env = !env in + try retype_applicative_functor_type ~loc env funct arg + with Includemod.Error explanation -> + raise + (Error + ( loc, + env, + With_makes_applicative_functor_ill_typed + (lid.txt, referenced_path, explanation) )))); + } + in + iterator.Btype.it_signature iterator signature; + Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature + +let type_decl_is_alias sdecl = + (* assuming no explicit constraint *) + match sdecl.ptype_manifest with + | Some {ptyp_desc = Ptyp_constr (lid, stl)} + when List.length stl = List.length sdecl.ptype_params -> ( + match + List.iter2 + (fun x (y, _) -> + match (x, y) with + | {ptyp_desc = Ptyp_var sx}, {ptyp_desc = Ptyp_var sy} when sx = sy -> + () + | _, _ -> raise Exit) + stl sdecl.ptype_params + with + | exception Exit -> None + | () -> Some lid) + | _ -> None + +let params_are_constrained = + let rec loop = function + | [] -> false + | hd :: tl -> ( + match (Btype.repr hd).desc with + | Tvar _ -> List.memq hd tl || loop tl + | _ -> true) + in + loop + +let merge_constraint initial_env loc sg constr = + let lid = + match constr with + | Pwith_type (lid, _) + | Pwith_module (lid, _) + | Pwith_typesubst (lid, _) + | Pwith_modsubst (lid, _) -> + lid + in + let destructive_substitution = + match constr with + | Pwith_type _ | Pwith_module _ -> false + | Pwith_typesubst _ | Pwith_modsubst _ -> true + in + let real_ids = ref [] in + let rec merge env sg namelist row_id = + match (sg, namelist, constr) with + | [], _, _ -> raise (Error (loc, env, With_no_component lid.txt)) + | ( Sig_type (id, decl, rs) :: rem, + [s], + Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl)) ) + when Ident.name id = s && Typedecl.is_fixed_type sdecl -> + let decl_row = + { + type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; + type_arity = List.length sdecl.ptype_params; + type_kind = Type_abstract; + type_private = Private; + type_manifest = None; + type_variance = + List.map + (fun (_, v) -> + let c, n = + match v with + | Covariant -> (true, false) + | Contravariant -> (false, true) + | Invariant -> (false, false) + in + make (not n) (not c) false) + sdecl.ptype_params; + type_loc = sdecl.ptype_loc; + type_newtype_level = None; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + and id_row = Ident.create (s ^ "#row") in + let initial_env = Env.add_type ~check:false id_row decl_row initial_env in + let tdecl = + Typedecl.transl_with_constraint initial_env id (Some (Pident id_row)) + decl sdecl + in + let newdecl = tdecl.typ_type in + check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; + let decl_row = {decl_row with type_params = newdecl.type_params} in + let rs' = if rs = Trec_first then Trec_not else rs in + ( (Pident id, lid, Twith_type tdecl), + Sig_type (id_row, decl_row, rs') :: Sig_type (id, newdecl, rs) :: rem ) + | Sig_type (id, decl, rs) :: rem, [s], Pwith_type (_, sdecl) + when Ident.name id = s -> + let tdecl = + Typedecl.transl_with_constraint initial_env id None decl sdecl + in + let newdecl = tdecl.typ_type in + check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; + ((Pident id, lid, Twith_type tdecl), Sig_type (id, newdecl, rs) :: rem) + | Sig_type (id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _) + when Ident.name id = s ^ "#row" -> + merge env rem namelist (Some id) + | Sig_type (id, decl, rs) :: rem, [s], Pwith_typesubst (_, sdecl) + when Ident.name id = s -> + (* Check as for a normal with constraint, but discard definition *) + let tdecl = + Typedecl.transl_with_constraint initial_env id None decl sdecl + in + let newdecl = tdecl.typ_type in + check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; + real_ids := [Pident id]; + ((Pident id, lid, Twith_typesubst tdecl), update_rec_next rs rem) + | Sig_module (id, md, rs) :: rem, [s], Pwith_module (_, lid') + when Ident.name id = s -> + let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in + let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in + ignore (Includemod.modtypes ~loc env newmd.md_type md.md_type); + ( (Pident id, lid, Twith_module (path, lid')), + Sig_module (id, newmd, rs) :: rem ) + | Sig_module (id, md, rs) :: rem, [s], Pwith_modsubst (_, lid') + when Ident.name id = s -> + let path, md' = Typetexp.find_module initial_env loc lid'.txt in + let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in + ignore (Includemod.modtypes ~loc env newmd.md_type md.md_type); + real_ids := [Pident id]; + ((Pident id, lid, Twith_modsubst (path, lid')), update_rec_next rs rem) + | Sig_module (id, md, rs) :: rem, s :: namelist, _ when Ident.name id = s -> + let (path, _path_loc, tcstr), newsg = + merge env (extract_sig env loc md.md_type) namelist None + in + let path = path_concat id path in + real_ids := path :: !real_ids; + let item = Sig_module (id, {md with md_type = Mty_signature newsg}, rs) in + ((path, lid, tcstr), item :: rem) + | item :: rem, _, _ -> + let cstr, items = merge (Env.add_item item env) rem namelist row_id in + (cstr, item :: items) + in + try + let names = Longident.flatten lid.txt in + let tcstr, sg = merge initial_env sg names None in + (if destructive_substitution then + match List.rev !real_ids with + | [] -> assert false + | last :: rest -> ( + (* The last item is the one that's removed. We don't need to check how + it's used since it's replaced by a more specific type/module. *) + assert ( + match last with + | Pident _ -> true + | _ -> false); + match rest with + | [] -> () + | _ :: _ -> + check_usage_of_path_of_substituted_item rest initial_env sg ~loc ~lid + )); + let sg = + match tcstr with + | _, _, Twith_typesubst tdecl -> + let how_to_extend_subst = + let sdecl = + match constr with + | Pwith_typesubst (_, sdecl) -> sdecl + | _ -> assert false + in + match type_decl_is_alias sdecl with + | Some lid -> + let replacement = + try Env.lookup_type lid.txt initial_env + with Not_found -> assert false + in + fun s path -> Subst.add_type_path path replacement s + | None -> + let body = + match tdecl.typ_type.type_manifest with + | None -> assert false + | Some x -> x + in + let params = tdecl.typ_type.type_params in + if params_are_constrained params then + raise + (Error (loc, initial_env, With_cannot_remove_constrained_type)); + fun s path -> Subst.add_type_function path ~params ~body s + in + let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in + Subst.signature sub sg + | _, _, Twith_modsubst (real_path, _) -> + let sub = + List.fold_left + (fun s path -> Subst.add_module_path path real_path s) + Subst.identity !real_ids + in + Subst.signature sub sg + | _ -> sg + in + (tcstr, sg) + with Includemod.Error explanation -> + raise (Error (loc, initial_env, With_mismatch (lid.txt, explanation))) + +(* Add recursion flags on declarations arising from a mutually recursive + block. *) + +let map_rec fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem + +let map_rec_type ~rec_flag fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> + let first = + match rec_flag with + | Recursive -> Trec_first + | Nonrecursive -> Trec_not + in + fn first d1 :: map_end (fn Trec_next) dl rem + +let rec map_rec_type_with_row_types ~rec_flag fn decls rem = + match decls with + | [] -> rem + | d1 :: dl -> + if Btype.is_row_name (Ident.name d1.typ_id) then + fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem + else map_rec_type ~rec_flag fn decls rem + +(* Add type extension flags to extension constructors *) +let map_ext fn exts rem = + match exts with + | [] -> rem + | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem + +(* Auxiliary for translating recursively-defined module types. + Return a module type that approximates the shape of the given module + type AST. Retain only module, type, and module type + components of signatures. For types, retain only their arity, + making them abstract otherwise. *) + +let rec approx_modtype env smty = + match smty.pmty_desc with + | Pmty_ident lid -> + let path, _info = Typetexp.find_modtype env smty.pmty_loc lid.txt in + Mty_ident path + | Pmty_alias lid -> + let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in + Mty_alias (Mta_absent, path) + | Pmty_signature ssg -> Mty_signature (approx_sig env ssg) + | Pmty_functor (param, sarg, sres) -> + let arg = may_map (approx_modtype env) sarg in + let id, newenv = + Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env + in + let res = approx_modtype newenv sres in + Mty_functor (id, arg, res) + | Pmty_with (sbody, _constraints) -> approx_modtype env sbody + | Pmty_typeof smod -> + let _, mty = !type_module_type_of_fwd env smod in + mty + | Pmty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and approx_module_declaration env pmd = + { + Types.md_type = approx_modtype env pmd.pmd_type; + md_attributes = pmd.pmd_attributes; + md_loc = pmd.pmd_loc; + } + +and approx_sig env ssg = + match ssg with + | [] -> [] + | item :: srem -> ( + match item.psig_desc with + | Psig_type (rec_flag, sdecls) -> + let decls = Typedecl.approx_type_decl sdecls in + let rem = approx_sig env srem in + map_rec_type ~rec_flag + (fun rs (id, info) -> Sig_type (id, info, rs)) + decls rem + | Psig_module pmd -> + let id = Ident.create pmd.pmd_name.txt in + let md = approx_module_declaration env pmd in + let newenv = Env.enter_module_declaration id md env in + Sig_module (id, md, Trec_not) :: approx_sig newenv srem + | Psig_recmodule sdecls -> + let decls = + List.map + (fun pmd -> + (Ident.create pmd.pmd_name.txt, approx_module_declaration env pmd)) + sdecls + in + let newenv = + List.fold_left + (fun env (id, md) -> + Env.add_module_declaration ~check:false id md env) + env decls + in + map_rec + (fun rs (id, md) -> Sig_module (id, md, rs)) + decls (approx_sig newenv srem) + | Psig_modtype d -> + let info = approx_modtype_info env d in + let id, newenv = Env.enter_modtype d.pmtd_name.txt info env in + Sig_modtype (id, info) :: approx_sig newenv srem + | Psig_open sod -> + let _path, mty, _od = type_open env sod in + approx_sig mty srem + | Psig_include sincl -> + let smty = sincl.pincl_mod in + let mty = approx_modtype env smty in + let sg = + Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) + in + let newenv = Env.add_signature sg env in + sg @ approx_sig newenv srem + | _ -> approx_sig env srem) + +and approx_modtype_info env sinfo = + { + mtd_type = may_map (approx_modtype env) sinfo.pmtd_type; + mtd_attributes = sinfo.pmtd_attributes; + mtd_loc = sinfo.pmtd_loc; + } + +let approx_modtype env smty = + Warnings.without_warnings (fun () -> approx_modtype env smty) + +(* Additional validity checks on type definitions arising from + recursive modules *) + +let check_recmod_typedecls env sdecls decls = + let recmod_ids = List.map fst3 decls in + List.iter2 + (fun pmd (id, _, mty) -> + let mty = mty.mty_type in + List.iter + (fun path -> + Typedecl.check_recmod_typedecl env pmd.pmd_type.pmty_loc recmod_ids + path (Env.find_type path env)) + (Mtype.type_paths env (Pident id) mty)) + sdecls decls + +(* Auxiliaries for checking uniqueness of names in signatures and structures *) + +module StringSet = Set.Make (struct + type t = string + let compare (x : t) y = String.compare x y +end) + +let check cl loc tbl name = + match Hashtbl.find_opt tbl name with + | Some repeated_loc -> + raise (Error (loc, Env.empty, Repeated_name (cl, name, repeated_loc))) + | None -> Hashtbl.add tbl name loc + +type names = { + types: (string, Warnings.loc) Hashtbl.t; + modules: (string, Warnings.loc) Hashtbl.t; + modtypes: (string, Warnings.loc) Hashtbl.t; + typexts: (string, Warnings.loc) Hashtbl.t; +} + +let new_names () = + { + types = Hashtbl.create 10; + modules = Hashtbl.create 10; + modtypes = Hashtbl.create 10; + typexts = Hashtbl.create 10; + } + +let check_name check names name = check names name.loc name.txt +let check_type names loc s = check "type" loc names.types s +let check_module names loc s = check "module" loc names.modules s +let check_modtype names loc s = check "module type" loc names.modtypes s +let check_typext names loc s = check "extension constructor" loc names.typexts s + +let check_sig_item names loc = function + | Sig_type (id, _, _) -> check_type names loc (Ident.name id) + | Sig_module (id, _, _) -> check_module names loc (Ident.name id) + | Sig_modtype (id, _) -> check_modtype names loc (Ident.name id) + | Sig_typext (id, _, _) -> check_typext names loc (Ident.name id) + | _ -> () + +(* Simplify multiple specifications of a value or an extension in a signature. + (Other signature components, e.g. types, modules, etc, are checked for + name uniqueness.) If multiple specifications with the same name, + keep only the last (rightmost) one. *) + +let simplify_signature sg = + let rec aux = function + | [] -> ([], StringSet.empty) + | (Sig_value (id, _descr) as component) :: sg -> + let ((sg, val_names) as k) = aux sg in + let name = Ident.name id in + if StringSet.mem name val_names then k + else (component :: sg, StringSet.add name val_names) + | component :: sg -> + let sg, val_names = aux sg in + (component :: sg, val_names) + in + let sg, _ = aux sg in + sg + +(* Check and translate a module type expression *) + +let transl_modtype_longident loc env lid = + let path, _info = Typetexp.find_modtype env loc lid in + path + +let transl_module_alias loc env lid = Typetexp.lookup_module env loc lid + +let mkmty desc typ env loc attrs = + let mty = + { + mty_desc = desc; + mty_type = typ; + mty_loc = loc; + mty_env = env; + mty_attributes = attrs; + } + in + Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); + mty + +let mksig desc env loc = + let sg = {sig_desc = desc; sig_loc = loc; sig_env = env} in + Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); + sg + +(* let signature sg = List.map (fun item -> item.sig_type) sg *) + +let rec transl_modtype env smty = + Builtin_attributes.warning_scope smty.pmty_attributes (fun () -> + transl_modtype_aux env smty) + +and transl_modtype_aux env smty = + let loc = smty.pmty_loc in + match smty.pmty_desc with + | Pmty_ident lid -> + let path = transl_modtype_longident loc env lid.txt in + mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc smty.pmty_attributes + | Pmty_alias lid -> + let path = transl_module_alias loc env lid.txt in + mkmty + (Tmty_alias (path, lid)) + (Mty_alias (Mta_absent, path)) + env loc smty.pmty_attributes + | Pmty_signature ssg -> + let sg = transl_signature env ssg in + mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc + smty.pmty_attributes + | Pmty_functor (param, sarg, sres) -> + let arg = Misc.may_map (transl_modtype env) sarg in + let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in + let id, newenv = + Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env + in + Ctype.init_def (Ident.current_time ()); + (* PR#6513 *) + let res = transl_modtype newenv sres in + mkmty + (Tmty_functor (id, param, arg, res)) + (Mty_functor (id, ty_arg, res.mty_type)) + env loc smty.pmty_attributes + | Pmty_with (sbody, constraints) -> + let body = transl_modtype env sbody in + let init_sg = extract_sig env sbody.pmty_loc body.mty_type in + let rev_tcstrs, final_sg = + List.fold_left + (fun (rev_tcstrs, sg) sdecl -> + let tcstr, sg = merge_constraint env smty.pmty_loc sg sdecl in + (tcstr :: rev_tcstrs, sg)) + ([], init_sg) constraints + in + mkmty + (Tmty_with (body, List.rev rev_tcstrs)) + (Mtype.freshen (Mty_signature final_sg)) + env loc smty.pmty_attributes + | Pmty_typeof smod -> + let env = Env.in_signature false env in + let tmty, mty = !type_module_type_of_fwd env smod in + mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes + | Pmty_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and transl_signature env sg = + let names = new_names () in + let rec transl_sig env sg = + Ctype.init_def (Ident.current_time ()); + match sg with + | [] -> ([], [], env) + | item :: srem -> ( + let loc = item.psig_loc in + match item.psig_desc with + | Psig_value sdesc -> + let tdesc, newenv = + Typedecl.transl_value_decl env item.psig_loc sdesc + in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_value tdesc) env loc :: trem, + Sig_value (tdesc.val_id, tdesc.val_val) :: rem, + final_env ) + | Psig_type (rec_flag, sdecls) -> + List.iter + (fun decl -> check_name check_type names decl.ptype_name) + sdecls; + let decls, newenv = Typedecl.transl_type_decl env rec_flag sdecls in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_type (rec_flag, decls)) env loc :: trem, + map_rec_type_with_row_types ~rec_flag + (fun rs td -> Sig_type (td.typ_id, td.typ_type, rs)) + decls rem, + final_env ) + | Psig_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let tyext, newenv = + Typedecl.transl_type_extension false env item.psig_loc styext + in + let trem, rem, final_env = transl_sig newenv srem in + let constructors = tyext.tyext_constructors in + ( mksig (Tsig_typext tyext) env loc :: trem, + map_ext + (fun es ext -> Sig_typext (ext.ext_id, ext.ext_type, es)) + constructors rem, + final_env ) + | Psig_exception sext -> + check_name check_typext names sext.pext_name; + let ext, newenv = Typedecl.transl_exception env sext in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_exception ext) env loc :: trem, + Sig_typext (ext.ext_id, ext.ext_type, Text_exception) :: rem, + final_env ) + | Psig_module pmd -> + check_name check_module names pmd.pmd_name; + let id = Ident.create pmd.pmd_name.txt in + let tmty = + Builtin_attributes.warning_scope pmd.pmd_attributes (fun () -> + transl_modtype env pmd.pmd_type) + in + let md = + { + md_type = tmty.mty_type; + md_attributes = pmd.pmd_attributes; + md_loc = pmd.pmd_loc; + } + in + let newenv = Env.enter_module_declaration id md env in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig + (Tsig_module + { + md_id = id; + md_name = pmd.pmd_name; + md_type = tmty; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + }) + env loc + :: trem, + Sig_module (id, md, Trec_not) :: rem, + final_env ) + | Psig_recmodule sdecls -> + List.iter (fun pmd -> check_name check_module names pmd.pmd_name) sdecls; + let decls, newenv = transl_recmodule_modtypes env sdecls in + let trem, rem, final_env = transl_sig newenv srem in + ( mksig (Tsig_recmodule decls) env loc :: trem, + map_rec + (fun rs md -> + let d = + { + Types.md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Sig_module (md.md_id, d, rs)) + decls rem, + final_env ) + | Psig_modtype pmtd -> + let newenv, mtd, sg = transl_modtype_decl names env pmtd in + let trem, rem, final_env = transl_sig newenv srem in + (mksig (Tsig_modtype mtd) env loc :: trem, sg :: rem, final_env) + | Psig_open sod -> + let _path, newenv, od = type_open env sod in + let trem, rem, final_env = transl_sig newenv srem in + (mksig (Tsig_open od) env loc :: trem, rem, final_env) + | Psig_include sincl -> + let smty = sincl.pincl_mod in + let tmty = + Builtin_attributes.warning_scope sincl.pincl_attributes (fun () -> + transl_modtype env smty) + in + let mty = tmty.mty_type in + let sg = + Subst.signature Subst.identity (extract_sig env smty.pmty_loc mty) + in + List.iter (check_sig_item names item.psig_loc) sg; + let newenv = Env.add_signature sg env in + let incl = + { + incl_mod = tmty; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + let trem, rem, final_env = transl_sig newenv srem in + (mksig (Tsig_include incl) env loc :: trem, sg @ rem, final_env) + | Psig_attribute x -> + Builtin_attributes.warning_attribute x; + let trem, rem, final_env = transl_sig env srem in + (mksig (Tsig_attribute x) env loc :: trem, rem, final_env) + | Psig_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext))) + in + let previous_saved_types = Cmt_format.get_saved_types () in + Builtin_attributes.warning_scope [] (fun () -> + let trem, rem, final_env = transl_sig (Env.in_signature true env) sg in + let rem = simplify_signature rem in + let sg = {sig_items = trem; sig_type = rem; sig_final_env = final_env} in + Cmt_format.set_saved_types + (Cmt_format.Partial_signature sg :: previous_saved_types); + sg) + +and transl_modtype_decl names env pmtd = + Builtin_attributes.warning_scope pmtd.pmtd_attributes (fun () -> + transl_modtype_decl_aux names env pmtd) + +and transl_modtype_decl_aux names env + {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = + check_name check_modtype names pmtd_name; + let tmty = Misc.may_map (transl_modtype env) pmtd_type in + let decl = + { + Types.mtd_type = may_map (fun t -> t.mty_type) tmty; + mtd_attributes = pmtd_attributes; + mtd_loc = pmtd_loc; + } + in + let id, newenv = Env.enter_modtype pmtd_name.txt decl env in + let mtd = + { + mtd_id = id; + mtd_name = pmtd_name; + mtd_type = tmty; + mtd_attributes = pmtd_attributes; + mtd_loc = pmtd_loc; + } + in + (newenv, mtd, Sig_modtype (id, decl)) + +and transl_recmodule_modtypes env sdecls = + let make_env curr = + List.fold_left + (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env) + env curr + in + let make_env2 curr = + List.fold_left + (fun env (id, _, mty) -> Env.add_module ~arg:true id mty.mty_type env) + env curr + in + let transition env_c curr = + List.map2 + (fun pmd (id, id_loc, _mty) -> + let tmty = + Builtin_attributes.warning_scope pmd.pmd_attributes (fun () -> + transl_modtype env_c pmd.pmd_type) + in + (id, id_loc, tmty)) + sdecls curr + in + let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in + let approx_env = + (* + cf #5965 + We use a dummy module type in order to detect a reference to one + of the module being defined during the call to approx_modtype. + It will be detected in Env.lookup_module. + *) + List.fold_left + (fun env id -> + let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in + Env.add_module ~arg:true id dummy env) + env ids + in + Ctype.init_def (Ident.current_time ()); + (* PR#7082 *) + let init = + List.map2 + (fun id pmd -> (id, pmd.pmd_name, approx_modtype approx_env pmd.pmd_type)) + ids sdecls + in + let env0 = make_env init in + let dcl1 = Warnings.without_warnings (fun () -> transition env0 init) in + let env1 = make_env2 dcl1 in + check_recmod_typedecls env1 sdecls dcl1; + let dcl2 = transition env1 dcl1 in + (* + List.iter + (fun (id, mty) -> + Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) + dcl2; +*) + let env2 = make_env2 dcl2 in + check_recmod_typedecls env2 sdecls dcl2; + let dcl2 = + List.map2 + (fun pmd (id, id_loc, mty) -> + { + md_id = id; + md_name = id_loc; + md_type = mty; + md_loc = pmd.pmd_loc; + md_attributes = pmd.pmd_attributes; + }) + sdecls dcl2 + in + (dcl2, env2) + +(* Try to convert a module expression to a module path. *) + +exception Not_a_path + +let rec path_of_module mexp = + match mexp.mod_desc with + | Tmod_ident (p, _) -> p + | Tmod_apply (funct, arg, _coercion) when !Clflags.applicative_functors -> + Papply (path_of_module funct, path_of_module arg) + | Tmod_constraint (mexp, _, _, _) -> path_of_module mexp + | _ -> raise Not_a_path + +let path_of_module mexp = + try Some (path_of_module mexp) with Not_a_path -> None + +(* Check that all core type schemes in a structure are closed *) + +let rec closed_modtype env = function + | Mty_ident _ -> true + | Mty_alias _ -> true + | Mty_signature sg -> + let env = Env.add_signature sg env in + List.for_all (closed_signature_item env) sg + | Mty_functor (id, param, body) -> + let env = Env.add_module ~arg:true id (Btype.default_mty param) env in + closed_modtype env body + +and closed_signature_item env = function + | Sig_value (_id, desc) -> Ctype.closed_schema env desc.val_type + | Sig_module (_id, md, _) -> closed_modtype env md.md_type + | _ -> true + +let check_nongen_scheme env sig_item = + match sig_item with + | Sig_value (_id, vd) -> + if not (Ctype.closed_schema env vd.val_type) then + raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) + | Sig_module (_id, md, _) -> + if not (closed_modtype env md.md_type) then + raise (Error (md.md_loc, env, Non_generalizable_module md.md_type)) + | _ -> () + +let check_nongen_schemes env sg = List.iter (check_nongen_scheme env) sg + +(* Helpers for typing recursive modules *) + +let anchor_submodule name anchor = + match anchor with + | None -> None + | Some p -> Some (Pdot (p, name, nopos)) +let anchor_recmodule id = Some (Pident id) + +let enrich_type_decls anchor decls oldenv newenv = + match anchor with + | None -> newenv + | Some p -> + List.fold_left + (fun e info -> + let id = info.typ_id in + let info' = + Mtype.enrich_typedecl oldenv + (Pdot (p, Ident.name id, nopos)) + info.typ_type + in + Env.add_type ~check:true id info' e) + oldenv decls + +let enrich_module_type anchor name mty env = + match anchor with + | None -> mty + | Some p -> Mtype.enrich_modtype env (Pdot (p, name, nopos)) mty + +let check_recmodule_inclusion env bindings = + (* PR#4450, PR#4470: consider + module rec X : DECL = MOD where MOD has inferred type ACTUAL + The "natural" typing condition + E, X: ACTUAL |- ACTUAL <: DECL + leads to circularities through manifest types. + Instead, we "unroll away" the potential circularities a finite number + of times. The (weaker) condition we implement is: + E, X: DECL, + X1: ACTUAL, + X2: ACTUAL{X <- X1}/X1 + ... + Xn: ACTUAL{X <- X(n-1)}/X(n-1) + |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn} + so that manifest types rooted at X(n+1) are expanded in terms of X(n), + avoiding circularities. The strengthenings ensure that + Xn.t = X(n-1).t = ... = X2.t = X1.t. + N can be chosen arbitrarily; larger values of N result in more + recursive definitions being accepted. A good choice appears to be + the number of mutually recursive declarations. *) + let subst_and_strengthen env s id mty = + Mtype.strengthen ~aliasable:false env (Subst.modtype s mty) + (Subst.module_path s (Pident id)) + in + + let rec check_incl first_time n env s = + if n > 0 then + (* Generate fresh names Y_i for the rec. bound module idents X_i *) + let bindings1 = + List.map + (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) -> + (id, Ident.rename id, mty_actual)) + bindings + in + (* Enter the Y_i in the environment with their actual types substituted + by the input substitution s *) + let env' = + List.fold_left + (fun env (id, id', mty_actual) -> + let mty_actual' = + if first_time then mty_actual + else subst_and_strengthen env s id mty_actual + in + Env.add_module ~arg:false id' mty_actual' env) + env bindings1 + in + (* Build the output substitution Y_i <- X_i *) + let s' = + List.fold_left + (fun s (id, id', _mty_actual) -> Subst.add_module id (Pident id') s) + Subst.identity bindings1 + in + (* Recurse with env' and s' *) + check_incl false (n - 1) env' s' + else + (* Base case: check inclusion of s(mty_actual) in s(mty_decl) + and insert coercion if needed *) + let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs, loc) = + let mty_decl' = Subst.modtype s mty_decl.mty_type + and mty_actual' = subst_and_strengthen env s id mty_actual in + let coercion = + try Includemod.modtypes ~loc:modl.mod_loc env mty_actual' mty_decl' + with Includemod.Error msg -> + raise (Error (modl.mod_loc, env, Not_included msg)) + in + let modl' = + { + mod_desc = + Tmod_constraint + (modl, mty_decl.mty_type, Tmodtype_explicit mty_decl, coercion); + mod_type = mty_decl.mty_type; + mod_env = env; + mod_loc = modl.mod_loc; + mod_attributes = []; + } + in + { + mb_id = id; + mb_name = id_loc; + mb_expr = modl'; + mb_attributes = attrs; + mb_loc = loc; + } + in + List.map check_inclusion bindings + in + check_incl true (List.length bindings) env Subst.identity + +(* Helper for unpack *) + +let rec package_constraints env loc mty constrs = + if constrs = [] then mty + else + let sg = extract_sig env loc mty in + let sg' = + List.map + (function + | Sig_type (id, ({type_params = []} as td), rs) + when List.mem_assoc [Ident.name id] constrs -> + let ty = List.assoc [Ident.name id] constrs in + Sig_type (id, {td with type_manifest = Some ty}, rs) + | Sig_module (id, md, rs) -> + let rec aux = function + | (m :: (_ :: _ as l), t) :: rest when m = Ident.name id -> + (l, t) :: aux rest + | _ :: rest -> aux rest + | [] -> [] + in + let md = + { + md with + md_type = package_constraints env loc md.md_type (aux constrs); + } + in + Sig_module (id, md, rs) + | item -> item) + sg + in + Mty_signature sg' + +let modtype_of_package env loc p nl tl = + try + match (Env.find_modtype p env).mtd_type with + | Some mty when nl <> [] -> + package_constraints env loc mty + (List.combine (List.map Longident.flatten nl) tl) + | _ -> + if nl = [] then Mty_ident p + else raise (Error (loc, env, Signature_expected)) + with Not_found -> + let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in + raise (Typetexp.Error (loc, env, error)) + +let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = + let mkmty p nl tl = + let ntl = + Ext_list.filter (List.combine nl tl) (fun (_n, t) -> + Ctype.free_variables t = []) + in + let nl, tl = List.split ntl in + modtype_of_package env Location.none p nl tl + in + let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in + try Includemod.modtypes ~loc:Location.none env mty1 mty2 = Tcoerce_none + with Includemod.Error _msg -> false +(* raise(Error(Location.none, env, Not_included msg)) *) + +let () = Ctype.package_subtype := package_subtype + +let wrap_constraint env arg mty explicit = + let coercion = + try Includemod.modtypes ~loc:arg.mod_loc env arg.mod_type mty + with Includemod.Error msg -> + raise (Error (arg.mod_loc, env, Not_included msg)) + in + { + mod_desc = Tmod_constraint (arg, mty, explicit, coercion); + mod_type = mty; + mod_env = env; + mod_attributes = []; + mod_loc = arg.mod_loc; + } + +(* Type a module value expression *) + +let rec type_module ?(alias = false) sttn funct_body anchor env smod = + Builtin_attributes.warning_scope smod.pmod_attributes (fun () -> + type_module_aux ~alias sttn funct_body anchor env smod) + +and type_module_aux ~alias sttn funct_body anchor env smod = + match smod.pmod_desc with + | Pmod_ident lid -> + let path = + Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt + in + let md = + { + mod_desc = Tmod_ident (path, lid); + mod_type = Mty_alias (Mta_absent, path); + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + in + let aliasable = not (Env.is_functor_arg path env) in + let md = + if alias && aliasable then md + else + match (Env.find_module path env).md_type with + | Mty_alias (_, p1) when not alias -> + let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in + let mty = Includemod.expand_module_alias env [] p1 in + { + md with + mod_desc = + Tmod_constraint + (md, mty, Tmodtype_implicit, Tcoerce_alias (p1, Tcoerce_none)); + mod_type = + (if sttn then Mtype.strengthen ~aliasable:true env mty p1 else mty); + } + | mty -> + let mty = + if sttn then Mtype.strengthen ~aliasable env mty path else mty + in + {md with mod_type = mty} + in + rm md + | Pmod_structure sstr -> + let str, sg, _finalenv = + type_structure funct_body anchor env sstr smod.pmod_loc + in + let md = + rm + { + mod_desc = Tmod_structure str; + mod_type = Mty_signature sg; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + in + let sg' = simplify_signature sg in + if List.length sg' = List.length sg then md + else + wrap_constraint + (Env.implicit_coercion env) + md (Mty_signature sg') Tmodtype_implicit + | Pmod_functor (name, smty, sbody) -> + let mty = may_map (transl_modtype env) smty in + let ty_arg = may_map (fun m -> m.mty_type) mty in + let (id, newenv), funct_body = + match ty_arg with + | None -> ((Ident.create "*", env), false) + | Some mty -> (Env.enter_module ~arg:true name.txt mty env, true) + in + Ctype.init_def (Ident.current_time ()); + (* PR#6981 *) + let body = type_module sttn funct_body None newenv sbody in + rm + { + mod_desc = Tmod_functor (id, name, mty, body); + mod_type = Mty_functor (id, ty_arg, body.mod_type); + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + | Pmod_apply (sfunct, sarg) -> ( + let arg = type_module true funct_body None env sarg in + let path = path_of_module arg in + let funct = type_module (sttn && path <> None) funct_body None env sfunct in + match Env.scrape_alias env funct.mod_type with + | Mty_functor (param, mty_param, mty_res) as mty_functor -> + let generative, mty_param = + (mty_param = None, Btype.default_mty mty_param) + in + if generative then ( + if sarg.pmod_desc <> Pmod_structure [] then + raise (Error (sfunct.pmod_loc, env, Apply_generative)); + if funct_body && Mtype.contains_type env funct.mod_type then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body))); + let coercion = + try Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param + with Includemod.Error msg -> + raise (Error (sarg.pmod_loc, env, Not_included msg)) + in + let mty_appl = + match path with + | Some path -> + Subst.modtype (Subst.add_module param path Subst.identity) mty_res + | None -> ( + if generative then mty_res + else + try + Mtype.nondep_supertype + (Env.add_module ~arg:true param arg.mod_type env) + param mty_res + with Not_found -> + raise + (Error + (smod.pmod_loc, env, Cannot_eliminate_dependency mty_functor)) + ) + in + rm + { + mod_desc = Tmod_apply (funct, arg, coercion); + mod_type = mty_appl; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + | Mty_alias (_, path) -> + raise (Error (sfunct.pmod_loc, env, Cannot_scrape_alias path)) + | _ -> raise (Error (sfunct.pmod_loc, env, Cannot_apply funct.mod_type))) + | Pmod_constraint (sarg, smty) -> + let arg = type_module ~alias true funct_body anchor env sarg in + let mty = transl_modtype env smty in + rm + { + (wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with + mod_loc = smod.pmod_loc; + mod_attributes = smod.pmod_attributes; + } + | Pmod_unpack sexp -> + let exp = Typecore.type_exp ~context:None env sexp in + let mty = + match Ctype.expand_head env exp.exp_type with + | {desc = Tpackage (p, nl, tl)} -> + if List.exists (fun t -> Ctype.free_variables t <> []) tl then + raise + (Error (smod.pmod_loc, env, Incomplete_packed_module exp.exp_type)); + modtype_of_package env smod.pmod_loc p nl tl + | {desc = Tvar _} -> + raise + (Typecore.Error (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) + | _ -> + raise (Error (smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) + in + if funct_body && Mtype.contains_type env mty then + raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); + rm + { + mod_desc = Tmod_unpack (exp, mty); + mod_type = mty; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + | Pmod_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and type_structure ?(toplevel = false) funct_body anchor env sstr scope = + let names = new_names () in + + let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = + match desc with + | Pstr_eval (sexpr, attrs) -> + let expr = + Builtin_attributes.warning_scope attrs (fun () -> + Typecore.type_expression ~context:None env sexpr) + in + (Tstr_eval (expr, attrs), [], env) + | Pstr_value (rec_flag, sdefs) -> + let scope = + match rec_flag with + | Recursive -> + Some + (Annot.Idef {scope with Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> + let start = + match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start + in + Some (Annot.Idef {scope with Location.loc_start = start}) + in + let defs, newenv = + Typecore.type_binding ~context:None env rec_flag sdefs scope + in + let () = + if rec_flag = Recursive then Rec_check.check_recursive_bindings defs + in + (* Note: Env.find_value does not trigger the value_used event. Values + will be marked as being used during the signature inclusion test. *) + ( Tstr_value (rec_flag, defs), + List.map + (fun id -> Sig_value (id, Env.find_value (Pident id) newenv)) + (let_bound_idents defs), + newenv ) + | Pstr_primitive sdesc -> + let desc, newenv = Typedecl.transl_value_decl env loc sdesc in + (Tstr_primitive desc, [Sig_value (desc.val_id, desc.val_val)], newenv) + | Pstr_type (rec_flag, sdecls) -> + List.iter (fun decl -> check_name check_type names decl.ptype_name) sdecls; + let decls, newenv = Typedecl.transl_type_decl env rec_flag sdecls in + ( Tstr_type (rec_flag, decls), + map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type (info.typ_id, info.typ_type, rs)) + decls [], + enrich_type_decls anchor decls env newenv ) + | Pstr_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let tyext, newenv = Typedecl.transl_type_extension true env loc styext in + ( Tstr_typext tyext, + map_ext + (fun es ext -> Sig_typext (ext.ext_id, ext.ext_type, es)) + tyext.tyext_constructors [], + newenv ) + | Pstr_exception sext -> + check_name check_typext names sext.pext_name; + let ext, newenv = Typedecl.transl_exception env sext in + ( Tstr_exception ext, + [Sig_typext (ext.ext_id, ext.ext_type, Text_exception)], + newenv ) + | Pstr_module + {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc} -> + check_name check_module names name; + let id = Ident.create name.txt in + (* create early for PR#6752 *) + let modl = + Builtin_attributes.warning_scope attrs (fun () -> + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) + env smodl) + in + let md = + { + md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; + md_loc = pmb_loc; + } + in + (*prerr_endline (Ident.unique_toplevel_name id);*) + Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; + let newenv = Env.enter_module_declaration id md env in + ( Tstr_module + { + mb_id = id; + mb_name = name; + mb_expr = modl; + mb_attributes = attrs; + mb_loc = pmb_loc; + }, + [ + Sig_module + ( id, + {md_type = modl.mod_type; md_attributes = attrs; md_loc = pmb_loc}, + Trec_not ); + ], + newenv ) + | Pstr_recmodule sbind -> + let sbind = + List.map + (function + | { + pmb_name = name; + pmb_expr = {pmod_desc = Pmod_constraint (expr, typ)}; + pmb_attributes = attrs; + pmb_loc = loc; + } -> + (name, typ, expr, attrs, loc) + | mb -> + raise + (Error + ( mb.pmb_expr.pmod_loc, + env, + Recursive_module_require_explicit_type ))) + sbind + in + List.iter + (fun (name, _, _, _, _) -> check_name check_module names name) + sbind; + let decls, newenv = + transl_recmodule_modtypes env + (List.map + (fun (name, smty, _smodl, attrs, loc) -> + { + pmd_name = name; + pmd_type = smty; + pmd_attributes = attrs; + pmd_loc = loc; + }) + sbind) + in + let bindings1 = + List.map2 + (fun {md_id = id; md_type = mty} (name, _, smodl, attrs, loc) -> + let modl = + Builtin_attributes.warning_scope attrs (fun () -> + type_module true funct_body (anchor_recmodule id) newenv smodl) + in + let mty' = + enrich_module_type anchor (Ident.name id) modl.mod_type newenv + in + (id, name, mty, modl, mty', attrs, loc)) + decls sbind + in + let newenv = + (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env md -> + let mdecl = + { + md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Env.add_module_declaration ~check:true md.md_id mdecl env) + env decls + in + let bindings2 = check_recmodule_inclusion newenv bindings1 in + ( Tstr_recmodule bindings2, + map_rec + (fun rs mb -> + Sig_module + ( mb.mb_id, + { + md_type = mb.mb_expr.mod_type; + md_attributes = mb.mb_attributes; + md_loc = mb.mb_loc; + }, + rs )) + bindings2 [], + newenv ) + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, sg = transl_modtype_decl names env pmtd in + (Tstr_modtype mtd, [sg], newenv) + | Pstr_open sod -> + let _path, newenv, od = type_open ~toplevel env sod in + (Tstr_open od, [], newenv) + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl = + Builtin_attributes.warning_scope sincl.pincl_attributes (fun () -> + type_module true funct_body None env smodl) + in + (* Rename all identifiers bound by this signature to avoid clashes *) + let sg = + Subst.signature Subst.identity + (extract_sig_open env smodl.pmod_loc modl.mod_type) + in + List.iter (check_sig_item names loc) sg; + let new_env = Env.add_signature sg env in + let incl = + { + incl_mod = modl; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + (Tstr_include incl, sg, new_env) + | Pstr_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pstr_attribute x -> + Builtin_attributes.warning_attribute x; + (Tstr_attribute x, [], env) + in + let rec type_struct env sstr = + Ctype.init_def (Ident.current_time ()); + match sstr with + | [] -> ([], [], env) + | pstr :: srem -> + let previous_saved_types = Cmt_format.get_saved_types () in + let desc, sg, new_env = type_str_item env srem pstr in + let str = {str_desc = desc; str_loc = pstr.pstr_loc; str_env = env} in + Cmt_format.set_saved_types + (Cmt_format.Partial_structure_item str :: previous_saved_types); + let str_rem, sig_rem, final_env = type_struct new_env srem in + let new_sg = if rescript_hide desc then sig_rem else sg @ sig_rem in + (str :: str_rem, new_sg, final_env) + in + if !Clflags.annotations then + (* moved to genannot *) + List.iter + (function + | {pstr_loc = l} -> Stypes.record_phrase l) + sstr; + let previous_saved_types = Cmt_format.get_saved_types () in + let run () = + let items, sg, final_env = type_struct env sstr in + let str = {str_items = items; str_type = sg; str_final_env = final_env} in + Cmt_format.set_saved_types + (Cmt_format.Partial_structure str :: previous_saved_types); + (str, sg, final_env) + in + if toplevel then run () else Builtin_attributes.warning_scope [] run + +let type_toplevel_phrase env s = + type_structure ~toplevel:true false None env s Location.none + +let type_module_alias = type_module ~alias:true true false None +let type_module = type_module true false None +let type_structure = type_structure false None + +(* Normalize types in a signature *) + +let rec normalize_modtype env = function + | Mty_ident _ | Mty_alias _ -> () + | Mty_signature sg -> normalize_signature env sg + | Mty_functor (_id, _param, body) -> normalize_modtype env body + +and normalize_signature env = List.iter (normalize_signature_item env) + +and normalize_signature_item env = function + | Sig_value (_id, desc) -> Ctype.normalize_type env desc.val_type + | Sig_module (_id, md, _) -> normalize_modtype env md.md_type + | _ -> () + +(* Extract the module type of a module expression *) + +let type_module_type_of env smod = + let tmty = + match smod.pmod_desc with + | Pmod_ident lid -> + (* turn off strengthening in this case *) + let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in + rm + { + mod_desc = Tmod_ident (path, lid); + mod_type = md.md_type; + mod_env = env; + mod_attributes = smod.pmod_attributes; + mod_loc = smod.pmod_loc; + } + | _ -> type_module env smod + in + let mty = tmty.mod_type in + (* PR#6307: expand aliases at root and submodules *) + let mty = Mtype.remove_aliases env mty in + (* PR#5036: must not contain non-generalized type variables *) + if not (closed_modtype env mty) then + raise (Error (smod.pmod_loc, env, Non_generalizable_module mty)); + (tmty, mty) + +(* For Typecore *) + +let type_package env m p nl = + (* Same as Pexp_letmodule *) + (* remember original level *) + let lv = Ctype.get_current_level () in + Ctype.begin_def (); + Ident.set_current_time lv; + let context = Typetexp.narrow () in + let modl = type_module env m in + Ctype.init_def (Ident.current_time ()); + Typetexp.widen context; + let mp, env = + match modl.mod_desc with + | Tmod_ident (mp, _) -> (mp, env) + | Tmod_constraint ({mod_desc = Tmod_ident (mp, _)}, _, Tmodtype_implicit, _) + -> + (mp, env) (* PR#6982 *) + | _ -> + let id, new_env = Env.enter_module ~arg:true "%M" modl.mod_type env in + (Pident id, new_env) + in + let rec mkpath mp = function + | Lident name -> Pdot (mp, name, nopos) + | Ldot (m, name) -> Pdot (mkpath mp m, name, nopos) + | _ -> assert false + in + let tl' = + List.map + (fun name -> Btype.newgenty (Tconstr (mkpath mp name, [], ref Mnil))) + (* beware of interactions with Printtyp and short-path: + mp.name may have an arity > 0, cf. PR#7534 *) + nl + in + (* go back to original level *) + Ctype.end_def (); + if nl = [] then (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, []) + else + let mty = modtype_of_package env modl.mod_loc p nl tl' in + List.iter2 + (fun n ty -> + try Ctype.unify env ty (Ctype.newvar ()) + with Ctype.Unify _ -> + raise (Error (m.pmod_loc, env, Scoping_pack (n, ty)))) + nl tl'; + (wrap_constraint env modl mty Tmodtype_implicit, tl') + +(* Fill in the forward declarations *) +let () = + Typecore.type_module := type_module_alias; + Typetexp.transl_modtype_longident := transl_modtype_longident; + Typetexp.transl_modtype := transl_modtype; + Typecore.type_open := type_open_ ?toplevel:None; + Typecore.type_package := type_package; + type_module_type_of_fwd := type_module_type_of + +(* Typecheck an implementation file *) + +let type_implementation_more ?check_exists sourcefile outputprefix modulename + initial_env ast = + Cmt_format.clear (); + try + Delayed_checks.reset_delayed_checks (); + let str, sg, finalenv = + type_structure initial_env ast (Location.in_file sourcefile) + in + let simple_sg = simplify_signature sg in + let mli_status = !Clflags.assume_no_mli in + if mli_status = Clflags.Mli_exists then ( + let intf_file = + try find_in_path_uncap !Config.load_path (modulename ^ ".cmi") + with Not_found -> + let sourceintf = + Filename.remove_extension sourcefile ^ Literals.suffix_resi + in + raise + (Error + ( Location.in_file sourcefile, + Env.empty, + Interface_not_compiled sourceintf )) + in + let dclsig = Env.read_signature modulename intf_file in + let coercion = + Includemod.compunit initial_env sourcefile sg intf_file dclsig + in + Delayed_checks.force_delayed_checks (); + (* It is important to run these checks after the inclusion test above, + so that value declarations which are not used internally but exported + are not reported as being unused. *) + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env None; + (str, coercion, finalenv, dclsig) + (* identifier is useless might read from serialized cmi files*)) + else + let coercion = + Includemod.compunit initial_env sourcefile sg "(inferred signature)" + simple_sg + in + check_nongen_schemes finalenv simple_sg; + normalize_signature finalenv simple_sg; + Delayed_checks.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the value being exported. We can still capture unused + declarations like "let x = true;; let x = 1;;", because in this + case, the inferred signature contains only the last declaration. *) + (if not !Clflags.dont_write_files then + let deprecated = Builtin_attributes.deprecated_of_str ast in + let cmi = + Env.save_signature ?check_exists ~deprecated simple_sg modulename + (outputprefix ^ ".cmi") + in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env + (Some cmi)); + (str, coercion, finalenv, simple_sg) + with e -> + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ()))) + (Some sourcefile) initial_env None; + raise e + +let save_signature modname tsg outputprefix source_file initial_env cmi = + Cmt_format.save_cmt (outputprefix ^ ".cmti") modname + (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) + +(* "Packaging" of several compilation units into one unit + having them as sub-modules. *) + +(* Error report *) + +open Printtyp + +let non_generalizable_msg ppf print_fallback_msg = + fprintf ppf + "%a@,\ + @,\ + @[This happens when the type system senses there's a \ + mutation/side-effect,@ in combination with a polymorphic value.@,\ + @{Using or annotating that value usually solves it.@}@]" + print_fallback_msg () + +let report_error ppf = function + | Cannot_apply mty -> + fprintf ppf "@[This module is not a functor; it has type@ %a@]" modtype mty + | Not_included errs -> + fprintf ppf "@[Signature mismatch:@ %a@]" Includemod.report_error errs + | Cannot_eliminate_dependency mty -> + fprintf ppf + "@[This functor has type@ %a@ The parameter cannot be eliminated in the \ + result type.@ Bind the argument to a module identifier.@]" + modtype mty + | Signature_expected -> fprintf ppf "This module type is not a signature" + | Structure_expected mty -> + fprintf ppf "@[This module is not a structure; it has type@ %a" modtype mty + | With_no_component lid -> + fprintf ppf + "@[The signature constrained by `with' has no component named %a@]" + longident lid + | With_mismatch (lid, explanation) -> + fprintf ppf + "@[@[In this `with' constraint, the new definition of %a@ does not \ + match its original definition@ in the constrained signature:@]@ %a@]" + longident lid Includemod.report_error explanation + | With_makes_applicative_functor_ill_typed (lid, path, explanation) -> + fprintf ppf + "@[@[This `with' constraint on %a makes the applicative functor @ \ + type %s ill-typed in the constrained signature:@]@ %a@]" + longident lid (Path.name path) Includemod.report_error explanation + | With_changes_module_alias (lid, id, path) -> + fprintf ppf + "@[@[This `with' constraint on %a changes %s, which is aliased @ in \ + the constrained signature (as %s)@].@]" + longident lid (Path.name path) (Ident.name id) + | With_cannot_remove_constrained_type -> + fprintf ppf + "@[Destructive substitutions are not supported for constrained @ \ + types (other than when replacing a type constructor with @ a type \ + constructor with the same arguments).@]" + | Repeated_name (kind, name, repeated_loc) -> + fprintf ppf + "@[Multiple definition of the %s name %s @ at @{%a@}@ @ Names must \ + be unique in a given structure or signature.@]" + kind name Location.print_loc repeated_loc + | Non_generalizable typ -> + (* modified *) + fprintf ppf "@["; + non_generalizable_msg ppf (fun ppf () -> + fprintf ppf + "@[This expression's type contains type variables that cannot be \ + generalized:@,\ + @{%a@}@]" + type_scheme typ); + fprintf ppf "@]" + | Non_generalizable_module mty -> + (* modified *) + fprintf ppf "@["; + non_generalizable_msg ppf (fun ppf () -> + fprintf ppf + "@[The type of this module contains type variables that cannot be \ + generalized:@,\ + @{%a@}@]" + modtype mty); + fprintf ppf "@]" + | Interface_not_compiled intf_name -> + fprintf ppf "@[Could not find the .cmi file for interface@ %a.@]" + Location.print_filename intf_name + | Not_allowed_in_functor_body -> + fprintf ppf "@[This expression creates fresh types.@ %s@]" + "It is not allowed inside applicative functors." + | Not_a_packed_module ty -> + fprintf ppf "This expression is not a packed module. It has type@ %a" + type_expr ty + | Incomplete_packed_module ty -> + fprintf ppf "The type of this packed module contains variables:@ %a" + type_expr ty + | Scoping_pack (lid, ty) -> + fprintf ppf "The type %a in this module cannot be exported.@ " longident lid; + fprintf ppf "Its type contains local dependencies:@ %a" type_expr ty + | Recursive_module_require_explicit_type -> + fprintf ppf "Recursive modules require an explicit module type." + | Apply_generative -> + fprintf ppf "This is a generative functor. It can only be applied to ()" + | Cannot_scrape_alias p -> + fprintf ppf "This is an alias for module %a, which is missing" path p + +let report_error env ppf err = + Printtyp.wrap_printing_env env (fun () -> report_error ppf err) + +let () = + Location.register_error_of_exn (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> Some err + | _ -> None) diff --git a/compiler/ml/typemod.mli b/compiler/ml/typemod.mli new file mode 100644 index 0000000..0f36cf6 --- /dev/null +++ b/compiler/ml/typemod.mli @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** Type-checking of the module language and typed ast plugin hooks *) + +open Types +open Format + +val type_module : Env.t -> Parsetree.module_expr -> Typedtree.module_expr +val type_structure : + Env.t -> + Parsetree.structure -> + Location.t -> + Typedtree.structure * Types.signature * Env.t +val type_toplevel_phrase : + Env.t -> Parsetree.structure -> Typedtree.structure * Types.signature * Env.t + +val rescript_hide : Typedtree.structure_item_desc -> bool + +val type_implementation_more : + ?check_exists:unit -> + string -> + string -> + string -> + Env.t -> + Parsetree.structure -> + Typedtree.structure * Typedtree.module_coercion * Env.t * Types.signature + +val transl_signature : Env.t -> Parsetree.signature -> Typedtree.signature +val check_nongen_schemes : Env.t -> Types.signature -> unit +val type_open_ : + ?used_slot:bool ref -> + ?toplevel:bool -> + Asttypes.override_flag -> + Env.t -> + Location.t -> + Longident.t Asttypes.loc -> + Path.t * Env.t +val simplify_signature : signature -> signature + +val path_of_module : Typedtree.module_expr -> Path.t option + +val save_signature : + string -> + Typedtree.signature -> + string -> + string -> + Env.t -> + Cmi_format.cmi_infos -> + unit + +type error = + | Cannot_apply of module_type + | Not_included of Includemod.error list + | Cannot_eliminate_dependency of module_type + | Signature_expected + | Structure_expected of module_type + | With_no_component of Longident.t + | With_mismatch of Longident.t * Includemod.error list + | With_makes_applicative_functor_ill_typed of + Longident.t * Path.t * Includemod.error list + | With_changes_module_alias of Longident.t * Ident.t * Path.t + | With_cannot_remove_constrained_type + | Repeated_name of string * string * Warnings.loc + | Non_generalizable of type_expr + | Non_generalizable_module of module_type + | Interface_not_compiled of string + | Not_allowed_in_functor_body + | Not_a_packed_module of type_expr + | Incomplete_packed_module of type_expr + | Scoping_pack of Longident.t * type_expr + | Recursive_module_require_explicit_type + | Apply_generative + | Cannot_scrape_alias of Path.t + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +val report_error : Env.t -> formatter -> error -> unit diff --git a/compiler/ml/typeopt.ml b/compiler/ml/typeopt.ml new file mode 100644 index 0000000..7f2cfe7 --- /dev/null +++ b/compiler/ml/typeopt.ml @@ -0,0 +1,105 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 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. *) +(* *) +(**************************************************************************) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +open Types +open Lambda + +let scrape_ty env ty = + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + match ty.desc with + | Tconstr (p, _, _) -> ( + match Env.find_type p env with + | {type_unboxed = {unboxed = true; _}; _} -> ( + match Typedecl.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2) + | _ -> ty + | exception Not_found -> ty) + | _ -> ty + +let scrape env ty = (scrape_ty env ty).desc + +(** [Types.constructor_description] + records the type at the definition type so for ['a option] + it will always be [Tvar] +*) +let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = + match scrape env typ with + | Tconstr (p, _, _) -> ( + (* all built in types could not inhabit none-like values: + int, char, float, bool, unit, exn, array, list, nativeint, + int32, int64, bytes + *) + match Predef.type_is_builtin_path_but_option p with + | For_sure_yes -> true + | For_sure_no -> false + | NA -> ( + let decl = Env.find_type p env in + match decl.type_kind with + | exception _ -> false + | Type_abstract -> + List.exists Typedecl.is_not_undefined_attr decl.type_attributes + | Type_open -> false + | Type_record _ -> true + | Type_variant + ( [ + {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; + {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; + ] + | [ + {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}; + {cd_id = {name = "None"}; cd_args = Cstr_tuple []}; + ] + | [{cd_id = {name = "()"}; cd_args = Cstr_tuple []}] ) -> + false (* conservative *) + | Type_variant cdecls -> + let untagged = + Ast_untagged_variants.has_untagged decl.type_attributes + in + Ext_list.for_all cdecls (fun cd -> + if Ast_untagged_variants.has_undefined_literal cd.cd_attributes then + false + else if untagged then + match cd.cd_args with + | Cstr_tuple [t] -> + Ast_untagged_variants.type_is_builtin_object t + || type_cannot_contain_undefined t env + | Cstr_tuple [] -> true + | Cstr_tuple (_ :: _ :: _) -> + true (* Not actually possible for untagged *) + | Cstr_record [{ld_type = t}] -> + Ast_untagged_variants.type_is_builtin_object t + || type_cannot_contain_undefined t env + | Cstr_record ([] | _ :: _ :: _) -> true + else true))) + | Ttuple _ | Tvariant _ | Tpackage _ | Tarrow _ -> true + | Tfield _ | Tpoly _ | Tunivar _ | Tlink _ | Tsubst _ | Tnil | Tvar _ + | Tobject _ -> + false + +let is_function_type env ty = + match scrape env ty with + | Tarrow (arg, rhs, _, _) -> Some (arg.typ, rhs) + | _ -> None + +let is_base_type env ty base_ty_path = + match scrape env ty with + | Tconstr (p, _, _) -> Path.same p base_ty_path + | _ -> false + +let maybe_pointer_type env ty = + if Ctype.maybe_pointer_type env ty then Pointer else Immediate diff --git a/compiler/ml/typeopt.mli b/compiler/ml/typeopt.mli new file mode 100644 index 0000000..f51b022 --- /dev/null +++ b/compiler/ml/typeopt.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 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. *) +(* *) +(**************************************************************************) + +(* Auxiliaries for type-based optimizations, e.g. array kinds *) + +val is_function_type : + Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option +val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool + +val maybe_pointer_type : Env.t -> Types.type_expr -> Lambda.immediate_or_pointer + +val type_cannot_contain_undefined : Types.type_expr -> Env.t -> bool diff --git a/compiler/ml/types.ml b/compiler/ml/types.ml new file mode 100644 index 0000000..eeca29a --- /dev/null +++ b/compiler/ml/types.ml @@ -0,0 +1,320 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Representation of types and declarations *) + +open Asttypes + +(* Type expressions for the core language *) + +type type_expr = {mutable desc: type_desc; mutable level: int; id: int} + +and arg = {lbl: arg_label; typ: type_expr} + +and type_desc = + | Tvar of string option + | Tarrow of arg * type_expr * commutable * arity + | Ttuple of type_expr list + | Tconstr of Path.t * type_expr list * abbrev_memo ref + | Tobject of type_expr * (Path.t * type_expr list) option ref + | Tfield of string * field_kind * type_expr * type_expr + | Tnil + | Tlink of type_expr + | Tsubst of type_expr (* for copying *) + | Tvariant of row_desc + | Tunivar of string option + | Tpoly of type_expr * type_expr list + | Tpackage of Path.t * Longident.t list * type_expr list + +and row_desc = { + row_fields: (label * row_field) list; + row_more: type_expr; + row_closed: bool; + row_fixed: bool; + row_name: (Path.t * type_expr list) option; +} + +and row_field = + | Rpresent of type_expr option + | Reither of bool * type_expr list * bool * row_field option ref + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +and abbrev_memo = + | Mnil + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + | Mlink of abbrev_memo ref + +and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent + +and commutable = Cok | Cunknown | Clink of commutable ref + +module TypeOps = struct + type t = type_expr + let compare t1 t2 = t1.id - t2.id + let hash t = t.id + let equal t1 t2 = t1 == t2 +end + +(* Maps of methods and instance variables *) + +module OrderedString = struct + type t = string + let compare (x : t) y = compare x y +end +module Meths = Map.Make (OrderedString) +module Vars = Meths + +(* Value descriptions *) + +type value_description = { + val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; +} + +and value_kind = + | Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) + +(* Variance *) + +module Variance = struct + type t = int + type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv + let single = function + | May_pos -> 1 + | May_neg -> 2 + | May_weak -> 4 + | Inj -> 8 + | Pos -> 16 + | Neg -> 32 + | Inv -> 64 + let union v1 v2 = v1 lor v2 + let inter v1 v2 = v1 land v2 + let subset v1 v2 = v1 land v2 = v1 + let set x b v = if b then v lor single x else v land lnot (single x) + let mem x = subset (single x) + let null = 0 + let may_inv = 7 + let full = 127 + let covariant = single May_pos lor single Pos lor single Inj + let swap f1 f2 v = + let v' = set f1 (mem f2 v) v in + set f2 (mem f1 v) v' + let conjugate v = swap May_pos May_neg (swap Pos Neg v) + let get_upper v = (mem May_pos v, mem May_neg v) + let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v) +end + +(* Type definitions *) + +type type_declaration = { + type_params: type_expr list; + type_arity: int; + type_kind: type_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + type_newtype_level: (int * int) option; + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: bool; + type_unboxed: unboxed_status; + type_inlined_types: type_inlined_type list; +} + +and type_inlined_type = + | Record of {type_name: string; labels: label_declaration list} + +and type_kind = + | Type_abstract + | Type_record of label_declaration list * record_representation + | Type_variant of constructor_declaration list + | Type_open + +and record_representation = + | Record_regular (* All fields are boxed / tagged *) + | Record_float_unused (* Was: all fields are floats. Now: unused *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of + (* Inlined record *) + { + tag: int; + name: string; + num_nonconsts: int; + attrs: Parsetree.attributes; + } + | Record_extension (* Inlined record under extension *) + +and label_declaration = { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_optional: bool; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; +} + +and constructor_declaration = { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; +} + +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +and unboxed_status = { + unboxed: bool; + default: bool; (* False if the unboxed field was set from an attribute. *) +} + +let unboxed_false_default_false = {unboxed = false; default = false} +let unboxed_false_default_true = {unboxed = false; default = true} +let unboxed_true_default_false = {unboxed = true; default = false} +let unboxed_true_default_true = {unboxed = true; default = true} + +type extension_constructor = { + ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_is_exception: bool; +} + +(* Type expressions for the class language *) + +module Concr = Set.Make (OrderedString) + +(* Type expressions for the module language *) + +type module_type = + | Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of Ident.t * module_type option * module_type + | Mty_alias of alias_presence * Path.t + +and alias_presence = Mta_present | Mta_absent + +and signature = signature_item list + +and signature_item = + | Sig_value of Ident.t * value_description + | Sig_type of Ident.t * type_declaration * rec_status + | Sig_typext of Ident.t * extension_constructor * ext_status + | Sig_module of Ident.t * module_declaration * rec_status + | Sig_modtype of Ident.t * modtype_declaration + | Sig_class of unit + | Sig_class_type of unit (* Dummy AST node *) + +and module_declaration = { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; +} + +and modtype_declaration = { + mtd_type: module_type option; (* Note: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; +} + +and rec_status = + | Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) + +and ext_status = + | Text_first (* first constructor of an extension *) + | Text_next (* not first constructor of an extension *) + | Text_exception (* an exception *) + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = { + cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; +} + +and constructor_tag = + | Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t (* Extension constructor *) + +let equal_tag t1 t2 = + match (t1, t2) with + | Cstr_constant i1, Cstr_constant i2 -> i2 = i1 + | Cstr_block i1, Cstr_block i2 -> i2 = i1 + | Cstr_unboxed, Cstr_unboxed -> true + | Cstr_extension path1, Cstr_extension path2 -> Path.same path1 path2 + | (Cstr_constant _ | Cstr_block _ | Cstr_unboxed | Cstr_extension _), _ -> + false + +let may_equal_constr c1 c2 = + match (c1.cstr_tag, c2.cstr_tag) with + | Cstr_extension _, Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity + | tag1, tag2 -> equal_tag tag1 tag2 + +type label_description = { + lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_optional: bool; (* Is this an optional field? *) + lbl_pos: int; (* Position in block *) + mutable lbl_all: label_description array; + (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; +} +let same_record_representation x y = + match x with + | Record_regular -> y = Record_regular + | Record_float_unused -> y = Record_float_unused + | Record_inlined {tag; name; num_nonconsts} -> ( + match y with + | Record_inlined y -> + tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts + | _ -> false) + | Record_extension -> y = Record_extension + | Record_unboxed x -> ( + match y with + | Record_unboxed y -> x = y + | _ -> false) diff --git a/compiler/ml/types.mli b/compiler/ml/types.mli new file mode 100644 index 0000000..cb9bf06 --- /dev/null +++ b/compiler/ml/types.mli @@ -0,0 +1,433 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(** {0 Representation of types and declarations} *) + +(** [Types] defines the representation of types and declarations (that is, the + content of module signatures). + + CMI files are made of marshalled types. +*) + +open Asttypes +(** Asttypes exposes basic definitions shared both by Parsetree and Types. *) + +type type_expr = {mutable desc: type_desc; mutable level: int; id: int} +(** Type expressions for the core language. + + The [type_desc] variant defines all the possible type expressions one can + find in OCaml. [type_expr] wraps this with some annotations. + + The [level] field tracks the level of polymorphism associated to a type, + guiding the generalization algorithm. + Put shortly, when referring to a type in a given environment, both the type + and the environment have a level. If the type has an higher level, then it + can be considered fully polymorphic (type variables will be printed as + ['a]), otherwise it'll be weakly polymorphic, or non generalized (type + variables printed as ['_a]). + See [http://okmij.org/ftp/ML/generalization.html] for more information. + + Note about [type_declaration]: one should not make the confusion between + [type_expr] and [type_declaration]. + + [type_declaration] refers specifically to the [type] construct in OCaml + language, where you create and name a new type or type alias. + + [type_expr] is used when you refer to existing types, e.g. when annotating + the expected type of a value. + + Also, as the type system of OCaml is generative, a [type_declaration] can + have the side-effect of introducing a new type constructor, different from + all other known types. + Whereas [type_expr] is a pure construct which allows referring to existing + types. + + Note on mutability: TBD. + *) + +and arg = {lbl: arg_label; typ: type_expr} + +and type_desc = + | Tvar of string option + (** [Tvar (Some "a")] ==> ['a] or ['_a] + [Tvar None] ==> [_] *) + | Tarrow of arg * type_expr * commutable * arity + (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] + [Tarrow (Labelled {txt="l"}, e1, e2, c)] ==> [l:e1 -> e2] + [Tarrow (Optional {txt="l"}, e1, e2, c)] ==> [?l:e1 -> e2] + + See [commutable] for the last argument. *) + | Ttuple of type_expr list (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) + | Tconstr of Path.t * type_expr list * abbrev_memo ref + (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] + The last parameter keep tracks of known expansions, see [abbrev_memo]. *) + | Tobject of type_expr * (Path.t * type_expr list) option ref + (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] + f1, fn are represented as a linked list of types using Tfield and Tnil + constructors. + + [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct]. + where A.ct is the type of some class. + + There are also special cases for so-called "class-types", cf. [Typeclass] + and [Ctype.set_object_name]: + + [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...), + Some(`A.#ct`, [rv;t1;...;tn])] + ==> [(t1, ..., tn) #A.ct] + [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct] + + where [rv] is the hidden row variable. + *) + | Tfield of string * field_kind * type_expr * type_expr + (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) + | Tnil (** [Tnil] ==> [<...; >] *) + | Tlink of type_expr (** Indirection used by unification engine. *) + | Tsubst of type_expr (* for copying *) + (** [Tsubst] is used temporarily to store information in low-level + functions manipulating representation of types, such as + instantiation or copy. + This constructor should not appear outside of these cases. *) + | Tvariant of row_desc + (** Representation of polymorphic variants, see [row_desc]. *) + | Tunivar of string option + (** Occurrence of a type variable introduced by a + forall quantifier / [Tpoly]. *) + | Tpoly of type_expr * type_expr list + (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty], + where 'a1 ... 'an are names given to types in tyl + and occurrences of those types in ty. *) + | Tpackage of Path.t * Longident.t list * type_expr list + (** Type of a first-class module (a.k.a package). *) + +and row_desc = { + row_fields: (label * row_field) list; + row_more: type_expr; + row_closed: bool; + row_fixed: bool; + row_name: (Path.t * type_expr list) option; +} +(** [ `X | `Y ] (row_closed = true) + [< `X | `Y ] (row_closed = true) + [> `X | `Y ] (row_closed = false) + [< `X | `Y > `X ] (row_closed = true) + + type t = [> `X ] as 'a (row_more = Tvar a) + type t = private [> `X ] (row_more = Tconstr (t#row, [], ref Mnil) + + And for: + + let f = function `X -> `X -> | `Y -> `X + + the type of "f" will be a [Tarrow] whose lhs will (basically) be: + + Tvariant { row_fields = [("X", _)]; + row_more = + Tvariant { row_fields = [("Y", _)]; + row_more = + Tvariant { row_fields = []; + row_more = _; + _ }; + _ }; + _ + } + +*) + +and row_field = + | Rpresent of type_expr option + | Reither of bool * type_expr list * bool * row_field option ref + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +(** [abbrev_memo] allows one to keep track of different expansions of a type + alias. This is done for performance purposes. + + For instance, when defining [type 'a pair = 'a * 'a], when one refers to an + ['a pair], it is just a shortcut for the ['a * 'a] type. + This expansion will be stored in the [abbrev_memo] of the corresponding + [Tconstr] node. + + In practice, [abbrev_memo] behaves like list of expansions with a mutable + tail. + + Note on marshalling: [abbrev_memo] must not appear in saved types. + [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and + removing abbreviations. +*) +and abbrev_memo = + | Mnil (** No known abbreviation *) + | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo + (** Found one abbreviation. + A valid abbreviation should be at least as visible and reachable by the + same path. + The first expression is the abbreviation and the second the expansion. *) + | Mlink of abbrev_memo ref + (** Abbreviations can be found after this indirection *) + +and field_kind = Fvar of field_kind option ref | Fpresent | Fabsent + +(** [commutable] is a flag appended to every arrow type. + + When typing an application, if the type of the functional is + known, its type is instantiated with [Cok] arrows, otherwise as + [Clink (ref Cunknown)]. + + When the type is not known, the application will be used to infer + the actual type. This is fragile in presence of labels where + there is no principal type. + + Two incompatible applications relying on [Cunknown] arrows will + trigger an error. + + let f g = + g ~a:() ~b:(); + g ~b:() ~a:(); + + Error: This function is applied to arguments + in an order different from other calls. + This is only allowed when the real type is known. +*) +and commutable = Cok | Cunknown | Clink of commutable ref + +module TypeOps : sig + type t = type_expr + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +(* Maps of methods and instance variables *) + +module Meths : Map.S with type key = string +module Vars : Map.S with type key = string + +(* Value descriptions *) + +type value_description = { + val_type: type_expr; (* Type of the value *) + val_kind: value_kind; + val_loc: Location.t; + val_attributes: Parsetree.attributes; +} + +and value_kind = + | Val_reg (* Regular value *) + | Val_prim of Primitive.description (* Primitive *) + +(* Variance *) + +module Variance : sig + type t + type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv + val null : t (* no occurrence *) + val full : t (* strictly invariant *) + val covariant : t (* strictly covariant *) + val may_inv : t (* maybe invariant *) + val union : t -> t -> t + val inter : t -> t -> t + val subset : t -> t -> bool + val set : f -> bool -> t -> t + val mem : f -> t -> bool + val conjugate : t -> t (* exchange positive and negative *) + val get_upper : t -> bool * bool (* may_pos, may_neg *) + val get_lower : t -> bool * bool * bool * bool (* pos, neg, inv, inj *) +end + +(* Type definitions *) + +type type_declaration = { + type_params: type_expr list; + type_arity: int; + type_kind: type_kind; + type_private: private_flag; + type_manifest: type_expr option; + type_variance: Variance.t list; + (* covariant, contravariant, weakly contravariant, injective *) + type_newtype_level: (int * int) option; + (* definition level * expansion level *) + type_loc: Location.t; + type_attributes: Parsetree.attributes; + type_immediate: bool; (* true iff type should not be a pointer *) + type_unboxed: unboxed_status; + type_inlined_types: type_inlined_type list; + (** Representation of inlined types, needed for printing *) +} + +and type_inlined_type = + | Record of {type_name: string; labels: label_declaration list} + +and type_kind = + | Type_abstract + | Type_record of label_declaration list * record_representation + | Type_variant of constructor_declaration list + | Type_open + +and record_representation = + | Record_regular (* All fields are boxed / tagged *) + | Record_float_unused (* Was: all fields are floats. Now: unused *) + | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) + | Record_inlined of + (* Inlined record *) + { + tag: int; + name: string; + num_nonconsts: int; + attrs: Parsetree.attributes; + } + | Record_extension (* Inlined record under extension *) + +and label_declaration = { + ld_id: Ident.t; + ld_mutable: mutable_flag; + ld_optional: bool; + ld_type: type_expr; + ld_loc: Location.t; + ld_attributes: Parsetree.attributes; +} + +and constructor_declaration = { + cd_id: Ident.t; + cd_args: constructor_arguments; + cd_res: type_expr option; + cd_loc: Location.t; + cd_attributes: Parsetree.attributes; +} + +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of label_declaration list + +and unboxed_status = + private + (* This type must be private in order to ensure perfect sharing of the + four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce + different executables. *) { + unboxed: bool; + default: bool; (* True for unannotated unboxable types. *) +} + +val unboxed_false_default_false : unboxed_status +val unboxed_false_default_true : unboxed_status +val unboxed_true_default_false : unboxed_status +val unboxed_true_default_true : unboxed_status + +type extension_constructor = { + ext_type_path: Path.t; + ext_type_params: type_expr list; + ext_args: constructor_arguments; + ext_ret_type: type_expr option; + ext_private: private_flag; + ext_loc: Location.t; + ext_attributes: Parsetree.attributes; + ext_is_exception: bool; +} + +module Concr : Set.S with type elt = string + +(* Type expressions for the module language *) + +type module_type = + | Mty_ident of Path.t + | Mty_signature of signature + | Mty_functor of Ident.t * module_type option * module_type + | Mty_alias of alias_presence * Path.t + +and alias_presence = Mta_present | Mta_absent + +and signature = signature_item list + +and signature_item = + | Sig_value of Ident.t * value_description + | Sig_type of Ident.t * type_declaration * rec_status + | Sig_typext of Ident.t * extension_constructor * ext_status + | Sig_module of Ident.t * module_declaration * rec_status + | Sig_modtype of Ident.t * modtype_declaration + | Sig_class of unit + | Sig_class_type of unit (* Dummy AST node *) + +and module_declaration = { + md_type: module_type; + md_attributes: Parsetree.attributes; + md_loc: Location.t; +} + +and modtype_declaration = { + mtd_type: module_type option; (* None: abstract *) + mtd_attributes: Parsetree.attributes; + mtd_loc: Location.t; +} + +and rec_status = + | Trec_not (* first in a nonrecursive group *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive/nonrecursive group *) + +and ext_status = + | Text_first (* first constructor in an extension *) + | Text_next (* not first constructor in an extension *) + | Text_exception + +(* Constructor and record label descriptions inserted held in typing + environments *) + +type constructor_description = { + cstr_name: string; (* Constructor name *) + cstr_res: type_expr; (* Type of the result *) + cstr_existentials: type_expr list; (* list of existentials *) + cstr_args: type_expr list; (* Type of the arguments *) + cstr_arity: int; (* Number of arguments *) + cstr_tag: constructor_tag; (* Tag for heap blocks *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_generalized: bool; (* Constrained return type? *) + cstr_private: private_flag; (* Read-only constructor? *) + cstr_loc: Location.t; + cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; +} + +and constructor_tag = + | Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) + | Cstr_unboxed (* Constructor of an unboxed type *) + | Cstr_extension of Path.t (* Extension constructor *) + +(* Constructors are the same *) +val equal_tag : constructor_tag -> constructor_tag -> bool + +(* Constructors may be the same, given potential rebinding *) +val may_equal_constr : + constructor_description -> constructor_description -> bool + +type label_description = { + lbl_name: string; (* Short name *) + lbl_res: type_expr; (* Type of the result *) + lbl_arg: type_expr; (* Type of the argument *) + lbl_mut: mutable_flag; (* Is this a mutable field? *) + lbl_optional: bool; (* Is this an optional field? *) + lbl_pos: int; (* Position in block *) + mutable lbl_all: label_description array; + (* All the labels in this type. This is mutable only because of a specific feature related to dicts, and should not be mutated elsewhere. *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag; (* Read-only field? *) + lbl_loc: Location.t; + lbl_attributes: Parsetree.attributes; +} + +val same_record_representation : + record_representation -> record_representation -> bool diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml new file mode 100644 index 0000000..9867baa --- /dev/null +++ b/compiler/ml/typetexp.ml @@ -0,0 +1,989 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *) + +(* Typechecking of type expressions for the core language *) + +open Asttypes +open Parsetree +open Typedtree +open Types +open Ctype + +exception Already_bound + +type error = + | Unbound_type_variable of string + | Unbound_type_constructor of Longident.t + | Unbound_type_constructor_2 of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Type_mismatch of (type_expr * type_expr) list + | Alias_type_mismatch of (type_expr * type_expr) list + | Present_has_conjunction of string + | Present_has_no_type of string + | Constructor_mismatch of type_expr * type_expr + | Not_a_variant of type_expr + | Variant_tags of string * string + | Invalid_variable_name of string + | Cannot_quantify of string * type_expr + | Multiple_constraints_on_type of Longident.t + | Method_mismatch of string * type_expr * type_expr + | Unbound_value of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t * type_expr option + | Unbound_module of Longident.t + | Unbound_modtype of Longident.t + | Ill_typed_functor_application of Longident.t + | Illegal_reference_to_recursive_module + | Access_functor_as_structure of Longident.t + | Apply_structure_as_functor of Longident.t + | Cannot_scrape_alias of Longident.t * Path.t + | Opened_object of Path.t option + | Not_an_object of type_expr + +exception Error of Location.t * Env.t * error +exception Error_forward of Location.error + +type variable_context = int * (string, type_expr) Tbl.t + +(* Local definitions *) + +let instance_list = Ctype.instance_list Env.empty + +(* Narrowing unbound identifier errors. *) + +let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = + fun env loc lid make_error -> + let check_module mlid = + try ignore (Env.lookup_module ~load:true mlid env) with + | Not_found -> + narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid) + | Env.Recmodule -> + raise (Error (loc, env, Illegal_reference_to_recursive_module)) + in + (match lid with + | Longident.Lident _ -> () + | Longident.Ldot (mlid, _) -> ( + check_module mlid; + let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in + match Env.scrape_alias env md.md_type with + | Mty_functor _ -> + raise (Error (loc, env, Access_functor_as_structure mlid)) + | Mty_alias (_, p) -> + raise (Error (loc, env, Cannot_scrape_alias (mlid, p))) + | _ -> ()) + | Longident.Lapply (flid, mlid) -> ( + check_module flid; + let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in + (match Env.scrape_alias env fmd.md_type with + | Mty_signature _ -> + raise (Error (loc, env, Apply_structure_as_functor flid)) + | Mty_alias (_, p) -> + raise (Error (loc, env, Cannot_scrape_alias (flid, p))) + | _ -> ()); + check_module mlid; + let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in + match Env.scrape_alias env mmd.md_type with + | Mty_alias (_, p) -> + raise (Error (loc, env, Cannot_scrape_alias (mlid, p))) + | _ -> raise (Error (loc, env, Ill_typed_functor_application lid)))); + raise (Error (loc, env, make_error lid)) + +let find_component (lookup : ?loc:_ -> _) make_error env loc lid = + try + match lid with + | Longident.Ldot (Longident.Lident "*predef*", s) -> + lookup ~loc (Longident.Lident s) Env.initial_safe_string + | _ -> lookup ~loc lid env + with + | Not_found -> narrow_unbound_lid_error env loc lid make_error + | Env.Recmodule -> + raise (Error (loc, env, Illegal_reference_to_recursive_module)) + +let find_type env loc lid = + let path = + find_component Env.lookup_type + (fun lid -> Unbound_type_constructor lid) + env loc lid + in + let decl = Env.find_type path env in + Builtin_attributes.check_deprecated ~deprecated_context:Cmt_utils.Reference + loc decl.type_attributes (Path.name path); + (path, decl) + +let find_constructor = + find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) +let find_all_constructors = + find_component Env.lookup_all_constructors (fun lid -> + Unbound_constructor lid) +let find_all_labels = + find_component Env.lookup_all_labels (fun lid -> Unbound_label (lid, None)) + +let find_value ?deprecated_context env loc lid = + Env.check_value_name (Longident.last lid) loc; + let ((path, decl) as r) = + find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid + in + Builtin_attributes.check_deprecated ?deprecated_context loc + decl.val_attributes (Path.name path); + r + +let lookup_module ?(load = false) env loc lid = + find_component + (fun ?loc lid env -> Env.lookup_module ~load ?loc lid env) + (fun lid -> Unbound_module lid) + env loc lid + +let find_module env loc lid = + let path = lookup_module ~load:true env loc lid in + let decl = Env.find_module path env in + (* No need to check for deprecated here, this is done in Env. *) + (path, decl) + +let find_modtype env loc lid = + let ((path, decl) as r) = + find_component Env.lookup_modtype + (fun lid -> Unbound_modtype lid) + env loc lid + in + Builtin_attributes.check_deprecated loc decl.mtd_attributes (Path.name path); + r + +let unbound_constructor_error ?from_type env lid = + ignore from_type; + narrow_unbound_lid_error env lid.loc lid.txt (fun lid -> + Unbound_constructor lid) + +let unbound_label_error ?from_type env lid = + narrow_unbound_lid_error env lid.loc lid.txt (fun lid -> + Unbound_label (lid, from_type)) + +(* Support for first-class modules. *) + +let transl_modtype_longident = ref (fun _ -> assert false) +let transl_modtype = ref (fun _ -> assert false) + +let create_package_mty fake loc env (p, l) = + let l = + List.sort + (fun (s1, _t1) (s2, _t2) -> + if s1.txt = s2.txt then + raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); + compare s1.txt s2.txt) + l + in + ( l, + List.fold_left + (fun mty (s, t) -> + let d = + { + ptype_name = mkloc (Longident.last s.txt) s.loc; + ptype_params = []; + ptype_cstrs = []; + ptype_kind = Ptype_abstract; + ptype_private = Asttypes.Public; + ptype_manifest = (if fake then None else Some t); + ptype_attributes = []; + ptype_loc = loc; + } + in + Ast_helper.Mty.mk ~loc + (Pmty_with (mty, [Pwith_type ({txt = s.txt; loc}, d)]))) + (Ast_helper.Mty.mk ~loc (Pmty_ident p)) + l ) + +(* Translation of type expressions *) + +let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t) +let univars = ref ([] : (string * type_expr) list) +let pre_univars = ref ([] : type_expr list) +let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t) + +let reset_type_variables () = + reset_global_level (); + Ctype.reset_reified_var_counter (); + type_variables := Tbl.empty + +let narrow () = (increase_global_level (), !type_variables) + +let widen (gl, tv) = + restore_global_level gl; + type_variables := tv + +let strict_ident c = c = '_' || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') + +let validate_name = function + | None -> None + | Some name as s -> if name <> "" && strict_ident name.[0] then s else None + +let new_global_var ?name () = new_global_var ?name:(validate_name name) () +let newvar ?name () = newvar ?name:(validate_name name) () + +let transl_type_param env styp = + let loc = styp.ptyp_loc in + match styp.ptyp_desc with + | Ptyp_any -> + let ty = new_global_var ~name:"_" () in + { + ctyp_desc = Ttyp_any; + ctyp_type = ty; + ctyp_env = env; + ctyp_loc = loc; + ctyp_attributes = styp.ptyp_attributes; + } + | Ptyp_var name -> + let ty = + try + if name <> "" && name.[0] = '_' then + raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); + ignore (Tbl.find name !type_variables); + raise Already_bound + with Not_found -> + let v = new_global_var ~name () in + type_variables := Tbl.add name v !type_variables; + v + in + { + ctyp_desc = Ttyp_var name; + ctyp_type = ty; + ctyp_env = env; + ctyp_loc = loc; + ctyp_attributes = styp.ptyp_attributes; + } + | _ -> assert false + +let transl_type_param env styp = + (* Currently useless, since type parameters cannot hold attributes + (but this could easily be lifted in the future). *) + Builtin_attributes.warning_scope styp.ptyp_attributes (fun () -> + transl_type_param env styp) + +let new_pre_univar ?name () = + let v = newvar ?name () in + pre_univars := v :: !pre_univars; + v + +let rec swap_list = function + | x :: y :: l -> y :: x :: swap_list l + | l -> l + +type policy = Fixed | Extensible | Univars + +let rec transl_type env policy styp = + Builtin_attributes.warning_scope styp.ptyp_attributes (fun () -> + transl_type_aux env policy styp) + +and transl_type_aux env policy styp = + let loc = styp.ptyp_loc in + let ctyp ctyp_desc ctyp_type = + { + ctyp_desc; + ctyp_type; + ctyp_env = env; + ctyp_loc = loc; + ctyp_attributes = styp.ptyp_attributes; + } + in + match styp.ptyp_desc with + | Ptyp_any -> + let ty = + if policy = Univars then new_pre_univar () + else if policy = Fixed then + raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_")) + else newvar () + in + ctyp Ttyp_any ty + | Ptyp_var name -> + let ty = + if name <> "" && name.[0] = '_' then + raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); + try instance env (List.assoc name !univars) + with Not_found -> ( + try instance env (fst (Tbl.find name !used_variables)) + with Not_found -> + let v = + if policy = Univars then new_pre_univar ~name () + else newvar ~name () + in + used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; + v) + in + ctyp (Ttyp_var name) ty + | Ptyp_arrow {arg; ret; arity} -> + let lbl = arg.lbl in + let cty1 = transl_type env policy arg.typ in + let cty2 = transl_type env policy ret in + let ty1 = cty1.ctyp_type in + let ty1 = + if Btype.is_optional lbl then + newty (Tconstr (Predef.path_option, [ty1], ref Mnil)) + else ty1 + in + let ty = newty (Tarrow ({lbl; typ = ty1}, cty2.ctyp_type, Cok, arity)) in + ctyp (Ttyp_arrow ({attrs = arg.attrs; lbl; typ = cty1}, cty2, arity)) ty + | Ptyp_tuple stl -> + assert (List.length stl >= 2); + let ctys = List.map (transl_type env policy) stl in + let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in + ctyp (Ttyp_tuple ctys) ty + | Ptyp_constr (lid, stl) -> + let path, decl = find_type env lid.loc lid.txt in + let stl = + match stl with + | [({ptyp_desc = Ptyp_any} as t)] when decl.type_arity > 1 -> + List.map (fun _ -> t) decl.type_params + | _ -> stl + in + if List.length stl <> decl.type_arity then + raise + (Error + ( styp.ptyp_loc, + env, + Type_arity_mismatch (lid.txt, decl.type_arity, List.length stl) )); + let args = List.map (transl_type env policy) stl in + let params = instance_list decl.type_params in + let unify_param = + match decl.type_manifest with + | None -> unify_var + | Some ty -> + if (repr ty).level = Btype.generic_level then unify_var else unify + in + List.iter2 + (fun (sty, cty) ty' -> + try unify_param env ty' cty.ctyp_type + with Unify trace -> + raise (Error (sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) + (List.combine stl args) params; + let constr = newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in + (try Ctype.enforce_constraints env constr + with Unify trace -> + raise (Error (styp.ptyp_loc, env, Type_mismatch trace))); + ctyp (Ttyp_constr (path, lid, args)) constr + | Ptyp_object (fields, o) -> + let ty, fields = transl_fields env policy o fields in + ctyp (Ttyp_object (fields, o)) (newobj ty) + | Ptyp_alias (st, alias) -> + let cty = + try + let t = + try List.assoc alias !univars + with Not_found -> + instance env (fst (Tbl.find alias !used_variables)) + in + let ty = transl_type env policy st in + (try unify_var env t ty.ctyp_type + with Unify trace -> + let trace = swap_list trace in + raise (Error (styp.ptyp_loc, env, Alias_type_mismatch trace))); + ty + with Not_found -> + let t = newvar () in + used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; + let ty = transl_type env policy st in + (try unify_var env t ty.ctyp_type + with Unify trace -> + let trace = swap_list trace in + raise (Error (styp.ptyp_loc, env, Alias_type_mismatch trace))); + let t = instance env t in + let px = Btype.proxy t in + (match px.desc with + | Tvar None -> + Btype.log_type px; + px.desc <- Tvar (Some alias) + | Tunivar None -> + Btype.log_type px; + px.desc <- Tunivar (Some alias) + | _ -> ()); + {ty with ctyp_type = t} + in + ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type + | Ptyp_variant (fields, closed, present) -> + let name = ref None in + let mkfield l f = + newty + (Tvariant + { + row_fields = [(l, f)]; + row_more = newvar (); + row_closed = true; + row_fixed = false; + row_name = None; + }) + in + let hfields = Hashtbl.create 17 in + let add_typed_field loc l f = + try + let _, f' = Hashtbl.find hfields l in + let ty = mkfield l f and ty' = mkfield l f' in + if equal env false [ty] [ty'] then () + else + try unify env ty ty' + with Unify _trace -> + raise (Error (loc, env, Constructor_mismatch (ty, ty'))) + with Not_found -> Hashtbl.add hfields l (l, f) + in + let add_field = function + | Rtag (l, attrs, c, stl) -> + name := None; + let tl = + Builtin_attributes.warning_scope attrs (fun () -> + List.map (transl_type env policy) stl) + in + let f = + match present with + | Some present when not (List.mem l.txt present) -> + let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in + Reither (c, ty_tl, false, ref None) + | _ -> ( + if List.length stl > 1 || (c && stl <> []) then + raise (Error (styp.ptyp_loc, env, Present_has_conjunction l.txt)); + match tl with + | [] -> Rpresent None + | st :: _ -> Rpresent (Some st.ctyp_type)) + in + add_typed_field styp.ptyp_loc l.txt f; + Ttag (l, attrs, c, tl) + | Rinherit sty -> + let cty = transl_type env policy sty in + let ty = cty.ctyp_type in + let nm = + match repr cty.ctyp_type with + | {desc = Tconstr (p, tl, _)} -> Some (p, tl) + | _ -> None + in + (* Set name if there are no fields yet *) + if Hashtbl.length hfields <> 0 then name := None else name := nm; + let fl = + match (expand_head env cty.ctyp_type, nm) with + | {desc = Tvariant row}, _ when Btype.static_row row -> + let row = Btype.row_repr row in + row.row_fields + | {desc = Tvar _}, Some (p, _) -> + raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p)) + | _ -> raise (Error (sty.ptyp_loc, env, Not_a_variant ty)) + in + List.iter + (fun (l, f) -> + let f = + match present with + | Some present when not (List.mem l present) -> ( + match f with + | Rpresent (Some ty) -> Reither (false, [ty], false, ref None) + | Rpresent None -> Reither (true, [], false, ref None) + | _ -> assert false) + | _ -> f + in + add_typed_field sty.ptyp_loc l f) + fl; + Tinherit cty + in + let tfields = List.map add_field fields in + let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in + (match present with + | None -> () + | Some present -> + List.iter + (fun l -> + if not (List.mem_assoc l fields) then + raise (Error (styp.ptyp_loc, env, Present_has_no_type l))) + present); + let row = + { + row_fields = List.rev fields; + row_more = newvar (); + row_closed = closed = Closed; + row_fixed = false; + row_name = !name; + } + in + let static = Btype.static_row row in + let row = + if static then {row with row_more = newty Tnil} + else if policy <> Univars then row + else {row with row_more = new_pre_univar ()} + in + let ty = newty (Tvariant row) in + ctyp (Ttyp_variant (tfields, closed, present)) ty + | Ptyp_poly (vars, st) -> + let vars = List.map (fun v -> v.txt) vars in + begin_def (); + let new_univars = List.map (fun name -> (name, newvar ~name ())) vars in + let old_univars = !univars in + univars := new_univars @ !univars; + let cty = transl_type env policy st in + let ty = cty.ctyp_type in + univars := old_univars; + end_def (); + generalize ty; + let ty_list = + List.fold_left + (fun tyl (name, ty1) -> + let v = Btype.proxy ty1 in + if deep_occur v ty then + match v.desc with + | Tvar name when v.level = Btype.generic_level -> + v.desc <- Tunivar name; + v :: tyl + | _ -> raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v))) + else tyl) + [] new_univars + in + let ty' = Btype.newgenty (Tpoly (ty, List.rev ty_list)) in + unify_var env (newvar ()) ty'; + ctyp (Ttyp_poly (vars, cty)) ty' + | Ptyp_package (p, l) -> + let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in + let z = narrow () in + let mty = !transl_modtype env mty in + widen z; + let ptys = List.map (fun (s, pty) -> (s, transl_type env policy pty)) l in + let path = !transl_modtype_longident styp.ptyp_loc env p.txt in + let ty = + newty + (Tpackage + ( path, + List.map (fun (s, _pty) -> s.txt) l, + List.map (fun (_, cty) -> cty.ctyp_type) ptys )) + in + ctyp + (Ttyp_package + { + pack_path = path; + pack_type = mty.mty_type; + pack_fields = ptys; + pack_txt = p; + }) + ty + | Ptyp_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and transl_poly_type env policy t = + transl_type env policy (Ast_helper.Typ.force_poly t) + +and transl_fields env policy o fields = + let hfields = Hashtbl.create 17 in + let add_typed_field loc l ty = + try + let ty' = Hashtbl.find hfields l in + if equal env false [ty] [ty'] then () + else + try unify env ty ty' + with Unify _trace -> + raise (Error (loc, env, Method_mismatch (l, ty, ty'))) + with Not_found -> Hashtbl.add hfields l ty + in + let add_field = function + | Otag (s, a, ty1) -> + let ty1 = + Builtin_attributes.warning_scope a (fun () -> + transl_poly_type env policy ty1) + in + let field = OTtag (s, a, ty1) in + add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; + field + | Oinherit sty -> ( + let cty = transl_type env policy sty in + let nm = + match repr cty.ctyp_type with + | {desc = Tconstr (p, _, _)} -> Some p + | _ -> None + in + let t = expand_head env cty.ctyp_type in + match (t, nm) with + | {desc = Tobject ({desc = (Tfield _ | Tnil) as tf}, _)}, _ -> + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add = function + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2.desc + | Tnil -> () + | _ -> assert false + in + iter_add tf; + OTinherit cty + | {desc = Tvar _}, Some p -> + raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p)) + | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t))) + in + let object_fields = List.map add_field fields in + let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in + let ty_init = + match (o, policy) with + | Closed, _ -> newty Tnil + | Open, Univars -> new_pre_univar () + | Open, _ -> newvar () + in + let ty = + List.fold_left + (fun ty (s, ty') -> newty (Tfield (s, Fpresent, ty', ty))) + ty_init fields + in + (ty, object_fields) + +(* Make the rows "fixed" in this type, to make universal check easier *) +let rec make_fixed_univars ty = + let ty = repr ty in + if ty.level >= Btype.lowest_level then ( + Btype.mark_type_node ty; + match ty.desc with + | Tvariant row -> + let row = Btype.row_repr row in + if Btype.is_Tunivar (Btype.row_more row) then + ty.desc <- + Tvariant + { + row with + row_fixed = true; + row_fields = + List.map + (fun ((s, f) as p) -> + match Btype.row_field_repr f with + | Reither (c, tl, _m, r) -> (s, Reither (c, tl, true, r)) + | _ -> p) + row.row_fields; + }; + Btype.iter_row make_fixed_univars row + | _ -> Btype.iter_type_expr make_fixed_univars ty) + +let make_fixed_univars ty = + make_fixed_univars ty; + Btype.unmark_type ty + +let globalize_used_variables env fixed = + let r = ref [] in + Tbl.iter + (fun name (ty, loc) -> + let v = new_global_var () in + let snap = Btype.snapshot () in + if + try + unify env v ty; + true + with _ -> + Btype.backtrack snap; + false + then ( + try r := (loc, v, Tbl.find name !type_variables) :: !r + with Not_found -> + if fixed && Btype.is_Tvar (repr ty) then + raise (Error (loc, env, Unbound_type_variable ("'" ^ name))); + let v2 = new_global_var () in + r := (loc, v, v2) :: !r; + type_variables := Tbl.add name v2 !type_variables)) + !used_variables; + used_variables := Tbl.empty; + fun () -> + List.iter + (function + | loc, t1, t2 -> ( + try unify env t1 t2 + with Unify trace -> raise (Error (loc, env, Type_mismatch trace)))) + !r + +let transl_simple_type env fixed styp = + univars := []; + used_variables := Tbl.empty; + let typ = transl_type env (if fixed then Fixed else Extensible) styp in + globalize_used_variables env fixed (); + make_fixed_univars typ.ctyp_type; + typ + +let transl_simple_type_delayed env styp = + univars := []; + used_variables := Tbl.empty; + let typ = transl_type env Extensible styp in + make_fixed_univars typ.ctyp_type; + (typ, globalize_used_variables env false) + +let transl_type_scheme env styp = + reset_type_variables (); + begin_def (); + let typ = transl_simple_type env false styp in + end_def (); + generalize typ.ctyp_type; + typ + +(* Error report *) + +open Format +open Printtyp + +let did_you_mean ppf choices : bool = + (* flush now to get the error report early, in the (unheard of) case + where the linear search would take a bit of time; in the worst + case, the user has seen the error, she can interrupt the process + before the spell-checking terminates. *) + Format.fprintf ppf "@?"; + match choices () with + | [] -> false + | last :: rev_rest -> + Format.fprintf ppf "@[@,@,@{Hint: Did you mean %s%s%s?@}@]" + (String.concat ", " (List.rev rev_rest)) + (if rev_rest = [] then "" else " or ") + last; + true + +let super_spellcheck ppf fold env lid = + let choices path name : string list = + let env : string list = fold (fun x _ _ xs -> x :: xs) path env [] in + Misc.spellcheck env name + in + match lid with + | Longident.Lapply _ -> false + | Longident.Lident s -> did_you_mean ppf (fun _ -> choices None s) + | Longident.Ldot (r, s) -> did_you_mean ppf (fun _ -> choices (Some r) s) + +let spellcheck ppf fold env lid = + let choices ~path name = + let env = fold (fun x xs -> x :: xs) path env [] in + Misc.spellcheck env name + in + match lid with + | Longident.Lapply _ -> () + | Longident.Lident s -> Misc.did_you_mean ppf (fun () -> choices ~path:None s) + | Longident.Ldot (r, s) -> + Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) + +let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc) +let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc) + +let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name) +let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name) +let fold_modtypes = fold_simple Env.fold_modtypes + +let report_error env ppf = function + | Unbound_type_variable name -> + (* we don't use "spellcheck" here: the function that raises this + error seems not to be called anywhere, so it's unclear how it + should be handled *) + fprintf ppf "Unbound type parameter %s@." name + | Unbound_type_constructor lid -> + (* modified *) + Format.fprintf ppf "@[This type constructor, `%a`, can't be found.@ " + Printtyp.longident lid; + let has_candidate = super_spellcheck ppf Env.fold_types env lid in + if not has_candidate then + Format.fprintf ppf + "If you wanted to write a recursive type, don't forget the `rec` in \ + `type rec`@]" + | Unbound_type_constructor_2 p -> + fprintf ppf "The type constructor@ %a@ is not yet completely defined" path p + | Type_arity_mismatch (lid, expected, provided) -> + if expected == 0 then + fprintf ppf + "@[The type %a is not generic so expects no arguments,@ but is here \ + applied to %i argument(s).@ Have you tried removing the angular \ + brackets `<` and `>` and the@ arguments within them and just writing \ + `%a` instead? @]" + longident lid provided longident lid + else + fprintf ppf + "@[The type constructor %a@ expects %i argument(s),@ but is here \ + applied to %i argument(s)@]" + longident lid expected provided + | Type_mismatch trace -> + Printtyp.report_unification_error ppf Env.empty trace + (function + | ppf -> fprintf ppf "This type") + (function ppf -> fprintf ppf "should be an instance of type") + | Alias_type_mismatch trace -> + Printtyp.report_unification_error ppf Env.empty trace + (function + | ppf -> fprintf ppf "This alias is bound to type") + (function ppf -> fprintf ppf "but is used as an instance of type") + | Present_has_conjunction l -> + fprintf ppf "The present constructor %s has a conjunctive type" l + | Present_has_no_type l -> + fprintf ppf "The present constructor %s has no type" l + | Constructor_mismatch (ty, ty') -> + wrap_printing_env env (fun () -> + Printtyp.reset_and_mark_loops_list [ty; ty']; + fprintf ppf "@[%s %a@ %s@ %a@]" + "This variant type contains a constructor" Printtyp.type_expr ty + "which should be" Printtyp.type_expr ty') + | Not_a_variant ty -> ( + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[The type %a@ does not expand to a polymorphic variant type@]" + Printtyp.type_expr ty; + match ty.desc with + | Tvar (Some s) -> + (* PR#7012: help the user that wrote 'Foo instead of `Foo *) + Misc.did_you_mean ppf (fun () -> ["`" ^ s]) + | _ -> ()) + | Variant_tags (lab1, lab2) -> + fprintf ppf "@[Variant tags %s@ and %s have the same hash value.@ %s@]" + (!Printtyp.print_res_poly_identifier lab1) + (!Printtyp.print_res_poly_identifier lab2) + "Change one of them." + | Invalid_variable_name name -> + fprintf ppf "The type variable name %s is not allowed in programs" name + | Cannot_quantify (name, v) -> + fprintf ppf + "@[The universal type variable '%s cannot be generalized:@ %s.@]" + name + (if Btype.is_Tvar v then "it escapes its scope" + else if Btype.is_Tunivar v then "it is already bound to another variable" + else "it is not a variable") + | Multiple_constraints_on_type s -> + fprintf ppf "Multiple constraints for type %a" longident s + | Method_mismatch (l, ty, ty') -> + wrap_printing_env env (fun () -> + Printtyp.reset_and_mark_loops_list [ty; ty']; + fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" l + Printtyp.type_expr ty Printtyp.type_expr ty') + | Unbound_value lid -> ( + (* modified *) + (match lid with + | Ldot (outer, inner) -> + Format.fprintf ppf "The value %s can't be found in %a" inner + Printtyp.longident outer + | other_ident -> + Format.fprintf ppf "The value %a can't be found" Printtyp.longident + other_ident); + let did_spellcheck = super_spellcheck ppf Env.fold_values env lid in + (* For cases such as when the user refers to something that's a value with + a lowercase identifier in JS but a module in ReScript. + + 'Console' is a typical example, where JS is `console.log` and ReScript is `Console.log`. *) + (* TODO(codemods) Add codemod for refering to the module instead. *) + let as_module = + match lid with + | Lident name -> ( + try + Some + (env + |> Env.lookup_module ~load:false + (Lident (String.capitalize_ascii name))) + with _ -> None) + | _ -> None + in + match as_module with + | None -> () + | Some module_path -> + Format.fprintf ppf "@,@[@,@[%s to use the module @{%a@}?@]@]" + (if did_spellcheck then "Or did you mean" else "Maybe you meant") + Printtyp.path module_path) + | Unbound_module lid -> + (* modified *) + (match lid with + | Lident "Str" -> + Format.fprintf ppf + "@[@{The module or file %a can't be found.@}@,\ + @,\ + Are you trying to use the standard library's Str?@ If you're \ + compiling to JavaScript,@ use @{Js.Re@} instead.@ Otherwise, \ + add str.cma to your ocamlc/ocamlopt command.@]" + Printtyp.longident lid + | lid -> + Format.fprintf ppf + "@[@{The module or file %a can't be found.@}@,\ + @[- If it's a third-party dependency:@,\ + - Did you add it to the \"dependencies\" or \"dev-dependencies\" in \ + rescript.json?@]@,\ + - Did you include the file's directory to the \"sources\" in \ + rescript.json?@," + Printtyp.longident lid); + super_spellcheck ppf Env.fold_modules env lid |> ignore + | Unbound_constructor lid -> + (* modified *) + Format.fprintf ppf + "@[@{The variant constructor %a can't be found.@}@,\ + @,\ + @[- If it's defined in another module or file, bring it into scope \ + by:@,\ + @[- Prefixing it with said module name:@ @{TheModule.%a@}@]@,\ + @[- Or specifying its type:@ @{let theValue: TheModule.theType = \ + %a@}@]@]@,\ + - @[Constructors and modules are both capitalized.@ Did you want the \ + latter?@ Then instead of @{let foo = Bar@}, try @{module Foo \ + = Bar@}.@]@]" + Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid; + spellcheck ppf fold_constructors env lid + | Unbound_label (lid, from_type) -> + (* modified *) + (match from_type with + | Some {desc = Tconstr (p, _, _)} when Path.same p Predef.path_option -> + (* TODO: Extend for nullable/null? *) + Format.fprintf ppf + "@[You're trying to access the record field @{%a@}, but the \ + value you're trying to access it on is an @{option@}.@ You need \ + to unwrap the option first before accessing the record field.@,\ + @\n\ + Possible solutions:@,\ + @[- Use @{Option.map@} to transform the option: \ + @{xx->Option.map(field => field.%a)@}@]@,\ + @[- Or use @{Option.getOr@} with a default: \ + @{xx->Option.getOr(defaultRecord).%a@}@]@]" + Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid + | Some {desc = Tconstr (p, _, _)} when Path.same p Predef.path_array -> + Format.fprintf ppf + "@[You're trying to access the record field @{%a@}, but the \ + value you're trying to access it on is an @{array@}.@ You need \ + to access an individual element of the array if you want to access an \ + individual record field.@]" + Printtyp.longident lid + | Some ({desc = Tconstr (_p, _, _)} as t1) -> + Format.fprintf ppf + "@[You're trying to access the record field @{%a@}, but the \ + thing you're trying to access it on is not a record. @,\n\ + The type of the thing you're trying to access it on is:@,\n\ + %a@,\n\ + @,\ + Only records have fields that can be accessed with dot notation.@]" + Printtyp.longident lid Error_message_utils.type_expr t1 + | None | Some _ -> + Format.fprintf ppf + "@[@{%a@} refers to a record field, but no corresponding \ + record type is in scope.@,\ + @,\ + If it's defined in another module or file, bring it into scope by:@,\ + @[- Prefixing the field name with the module name:@ \ + @{TheModule.%a@}@]@,\ + @[- Or specifying the record type explicitly:@ @{let theValue: \ + TheModule.theType = {%a: VALUE}@}@]@]" + Printtyp.longident lid Printtyp.longident lid Printtyp.longident lid); + spellcheck ppf fold_labels env lid + | Unbound_modtype lid -> + fprintf ppf "Unbound module type %a" longident lid; + spellcheck ppf fold_modtypes env lid + | Ill_typed_functor_application lid -> + fprintf ppf "Ill-typed functor application %a" longident lid + | Illegal_reference_to_recursive_module -> + fprintf ppf "Illegal recursive module reference" + | Access_functor_as_structure lid -> + fprintf ppf "The module %a is a functor, not a structure" longident lid + | Apply_structure_as_functor lid -> + fprintf ppf "The module %a is a structure, not a functor" longident lid + | Cannot_scrape_alias (lid, p) -> + fprintf ppf "The module %a is an alias for module %a, which is missing" + longident lid path p + | Opened_object nm -> + fprintf ppf "Illegal open object type%a" + (fun ppf -> function + | Some p -> fprintf ppf "@ %a" path p + | None -> fprintf ppf "") + nm + | Not_an_object ty -> + Printtyp.reset_and_mark_loops ty; + fprintf ppf "@[The type %a@ is not an object type@]" Printtyp.type_expr ty + +let () = + Location.register_error_of_exn (function + | Error (loc, env, err) -> + Some (Location.error_of_printer loc (report_error env) err) + | Error_forward err -> Some err + | _ -> None) diff --git a/compiler/ml/typetexp.mli b/compiler/ml/typetexp.mli new file mode 100644 index 0000000..8f40096 --- /dev/null +++ b/compiler/ml/typetexp.mli @@ -0,0 +1,106 @@ +(**************************************************************************) +(* *) +(* 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. *) +(* *) +(**************************************************************************) + +(* Typechecking of type expressions for the core language *) + +open Types + +val transl_simple_type : + Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type +val transl_simple_type_delayed : + Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit) +(* Translate a type, but leave type variables unbound. Returns + the type and a function that binds the type variable. *) + +val transl_type_scheme : Env.t -> Parsetree.core_type -> Typedtree.core_type +val reset_type_variables : unit -> unit +val transl_type_param : Env.t -> Parsetree.core_type -> Typedtree.core_type + +type variable_context +val narrow : unit -> variable_context +val widen : variable_context -> unit + +exception Already_bound + +type error = + | Unbound_type_variable of string + | Unbound_type_constructor of Longident.t + | Unbound_type_constructor_2 of Path.t + | Type_arity_mismatch of Longident.t * int * int + | Type_mismatch of (type_expr * type_expr) list + | Alias_type_mismatch of (type_expr * type_expr) list + | Present_has_conjunction of string + | Present_has_no_type of string + | Constructor_mismatch of type_expr * type_expr + | Not_a_variant of type_expr + | Variant_tags of string * string + | Invalid_variable_name of string + | Cannot_quantify of string * type_expr + | Multiple_constraints_on_type of Longident.t + | Method_mismatch of string * type_expr * type_expr + | Unbound_value of Longident.t + | Unbound_constructor of Longident.t + | Unbound_label of Longident.t * type_expr option + | Unbound_module of Longident.t + | Unbound_modtype of Longident.t + | Ill_typed_functor_application of Longident.t + | Illegal_reference_to_recursive_module + | Access_functor_as_structure of Longident.t + | Apply_structure_as_functor of Longident.t + | Cannot_scrape_alias of Longident.t * Path.t + | Opened_object of Path.t option + | Not_an_object of type_expr + +exception Error of Location.t * Env.t * error + +val report_error : Env.t -> Format.formatter -> error -> unit + +(* Support for first-class modules. *) +val transl_modtype_longident : + (* from Typemod *) + (Location.t -> Env.t -> Longident.t -> Path.t) ref +val transl_modtype : + (* from Typemod *) + (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref + +val find_type : Env.t -> Location.t -> Longident.t -> Path.t * type_declaration +val find_constructor : + Env.t -> Location.t -> Longident.t -> constructor_description +val find_all_constructors : + Env.t -> + Location.t -> + Longident.t -> + (constructor_description * (unit -> unit)) list +val find_all_labels : + Env.t -> + Location.t -> + Longident.t -> + (label_description * (unit -> unit)) list +val find_value : + ?deprecated_context:Cmt_utils.deprecated_used_context -> + Env.t -> + Location.t -> + Longident.t -> + Path.t * value_description +val find_module : + Env.t -> Location.t -> Longident.t -> Path.t * module_declaration +val lookup_module : ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t +val find_modtype : + Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration + +val unbound_constructor_error : + ?from_type:type_expr -> Env.t -> Longident.t Location.loc -> 'a +val unbound_label_error : + ?from_type:type_expr -> Env.t -> Longident.t Location.loc -> 'a diff --git a/compiler/ml/unified_ops.ml b/compiler/ml/unified_ops.ml new file mode 100644 index 0000000..50d0ed9 --- /dev/null +++ b/compiler/ml/unified_ops.ml @@ -0,0 +1,268 @@ +open Misc + +(* + Unified_ops is for specialization of some primitive operators. + + For example adding two values. We have `+` for ints, `+.` for floats, and `++` for strings. + That because we don't allow implicit conversion or overloading for operations. + + It is a fundamental property of the ReScript language, but it is far from the best DX we can think of, + and it became a problem when new primitives like bigint were introduced. + + See discussion: https://github.com/rescript-lang/rescript-compiler/issues/6525 + + Unified ops mitigate the problem by adding ad-hoc translation rules on applications of the core built-in operators + which have form of binary infix ('a -> 'a -> 'a) or unary ('a -> 'a) + + Translation rules should be applied in its application, in both type-level and IR(lambda)-level. + + The rules: + + 1. If the lhs type is a primitive type, unify the rhs and the result type to the lhs type. + 2. If the lhs type is not a primitive type but the rhs type is, unify lhs and the result type to the rhs type. + 3. If both lhs type and rhs type is not a primitive type, unify the whole types to the int. + + Since these are simple ad-hoc translations for primitive applications, we cannot use the result type defined in other contexts. + So falling back to int type is the simplest behavior that ensures backwards compatibility. + + Actual implementations of translation are colocated into core modules + + You can find it in: + - Type-level : ml/typecore.ml + - IR-level : ml/translcore.ml + + With function name "translate_unified_ops" +*) + +type form = Unary | Binary + +(* Note: unified op must support int type *) +type specialization = { + int: Lambda.primitive; + bool: Lambda.primitive option; + float: Lambda.primitive option; + bigint: Lambda.primitive option; + string: Lambda.primitive option; +} + +type entry = { + path: string; + (** TODO: Maybe it can be a Path.t in Predef instead of string *) + name: string; + form: form; + specialization: specialization; +} + +let builtin x = Primitive_modules.pervasives ^ "." ^ x + +let entries = + [| + { + path = builtin "~+"; + name = "%plus"; + form = Unary; + specialization = + { + int = Pidentity; + bool = None; + float = Some Pidentity; + bigint = Some Pidentity; + string = None; + }; + }; + { + path = builtin "~-"; + name = "%neg"; + form = Unary; + specialization = + { + int = Pnegint; + bool = None; + float = Some Pnegfloat; + bigint = Some Pnegbigint; + string = None; + }; + }; + { + path = builtin "+"; + name = "%add"; + form = Binary; + specialization = + { + int = Paddint; + bool = None; + float = Some Paddfloat; + bigint = Some Paddbigint; + string = Some Pstringadd; + }; + }; + { + path = builtin "-"; + name = "%sub"; + form = Binary; + specialization = + { + int = Psubint; + bool = None; + float = Some Psubfloat; + bigint = Some Psubbigint; + string = None; + }; + }; + { + path = builtin "*"; + name = "%mul"; + form = Binary; + specialization = + { + int = Pmulint; + bool = None; + float = Some Pmulfloat; + bigint = Some Pmulbigint; + string = None; + }; + }; + { + path = builtin "/"; + name = "%div"; + form = Binary; + specialization = + { + int = Pdivint; + bool = None; + float = Some Pdivfloat; + bigint = Some Pdivbigint; + string = None; + }; + }; + { + path = builtin "%"; + name = "%mod"; + form = Binary; + specialization = + { + int = Pmodint; + bool = None; + float = Some Pmodfloat; + bigint = Some Pmodbigint; + string = None; + }; + }; + { + path = builtin "<<"; + name = "%lsl"; + form = Binary; + specialization = + { + int = Plslint; + bool = None; + float = None; + bigint = Some Plslbigint; + string = None; + }; + }; + { + path = builtin ">>"; + name = "%asr"; + form = Binary; + specialization = + { + int = Pasrint; + bool = None; + float = None; + bigint = Some Pasrbigint; + string = None; + }; + }; + { + path = builtin ">>>"; + name = "%lsr"; + form = Binary; + specialization = + {int = Plsrint; bool = None; float = None; bigint = None; string = None}; + }; + { + path = builtin "mod"; + name = "%mod"; + form = Binary; + specialization = + { + int = Pmodint; + bool = None; + float = Some Pmodfloat; + bigint = Some Pmodbigint; + string = None; + }; + }; + { + path = builtin "**"; + name = "%pow"; + form = Binary; + specialization = + { + int = Ppowint; + bool = None; + float = Some Ppowfloat; + bigint = Some Ppowbigint; + string = None; + }; + }; + { + path = builtin "~~~"; + name = "%bitnot"; + form = Unary; + specialization = + { + int = Pnotint; + bool = None; + float = None; + bigint = Some Pnotbigint; + string = None; + }; + }; + { + path = builtin "|||"; + name = "%bitor"; + form = Binary; + specialization = + { + int = Porint; + bool = None; + float = None; + bigint = Some Porbigint; + string = None; + }; + }; + { + path = builtin "^^^"; + name = "%bitxor"; + form = Binary; + specialization = + { + int = Pxorint; + bool = None; + float = None; + bigint = Some Pxorbigint; + string = None; + }; + }; + { + path = builtin "&&&"; + name = "%bitand"; + form = Binary; + specialization = + { + int = Pandint; + bool = None; + float = None; + bigint = Some Pandbigint; + string = None; + }; + }; + |] + +let index_by_path = + entries |> Array.map (fun entry -> (entry.path, entry)) |> create_hashtable + +let index_by_name = + entries |> Array.map (fun entry -> (entry.name, entry)) |> create_hashtable diff --git a/compiler/ml/unified_ops.mli b/compiler/ml/unified_ops.mli new file mode 100644 index 0000000..b52e052 --- /dev/null +++ b/compiler/ml/unified_ops.mli @@ -0,0 +1,20 @@ +type form = Unary | Binary + +type specialization = { + int: Lambda.primitive; + bool: Lambda.primitive option; + float: Lambda.primitive option; + bigint: Lambda.primitive option; + string: Lambda.primitive option; +} + +type entry = { + path: string; + name: string; + form: form; + specialization: specialization; +} + +val index_by_path : (string, entry) Hashtbl.t + +val index_by_name : (string, entry) Hashtbl.t diff --git a/compiler/ml/untypeast.ml b/compiler/ml/untypeast.ml new file mode 100644 index 0000000..1ae24b6 --- /dev/null +++ b/compiler/ml/untypeast.ml @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 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. *) +(* *) +(**************************************************************************) + +open Asttypes +open Parsetree + +let constant = function + | Const_char c -> Pconst_char c + | Const_string (s, d) -> Pconst_string (s, d) + | Const_int i -> Pconst_integer (string_of_int i, None) + | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') + | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') + | Const_bigint (sign, i) -> + Pconst_integer (Bigint_utils.to_string sign i, Some 'n') + | Const_float f -> Pconst_float (f, None) diff --git a/compiler/ml/untypeast.mli b/compiler/ml/untypeast.mli new file mode 100644 index 0000000..b4471a1 --- /dev/null +++ b/compiler/ml/untypeast.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) +(* *) +(* Copyright 2007 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. *) +(* *) +(**************************************************************************) + +val constant : Asttypes.constant -> Parsetree.constant diff --git a/compiler/ml/used_attributes.ml b/compiler/ml/used_attributes.ml new file mode 100644 index 0000000..0dcdf9f --- /dev/null +++ b/compiler/ml/used_attributes.ml @@ -0,0 +1,18 @@ +let used_attributes : string Asttypes.loc Hash_set_poly.t = + Hash_set_poly.create 16 + +(* let dump_attribute fmt = (fun ( (sloc : string Asttypes.loc)) -> + Format.fprintf fmt "@[%s@]" sloc.txt + ) + + let dump_used_attributes fmt = + Format.fprintf fmt "Used attributes Listing Start:@."; + Hash_set_poly.iter used_attributes (fun attr -> dump_attribute fmt attr) ; + Format.fprintf fmt "Used attributes Listing End:@." *) + +(* only mark non-ghost used bs attribute *) +let mark_used_attribute ((x, _) : Parsetree.attribute) = + if not x.loc.loc_ghost then Hash_set_poly.add used_attributes x + +let is_used_attribute (sloc : string Asttypes.loc) = + Hash_set_poly.mem used_attributes sloc diff --git a/compiler/ml/used_attributes.mli b/compiler/ml/used_attributes.mli new file mode 100644 index 0000000..52dfa56 --- /dev/null +++ b/compiler/ml/used_attributes.mli @@ -0,0 +1,3 @@ +val mark_used_attribute : Parsetree.attribute -> unit + +val is_used_attribute : string Asttypes.loc -> bool diff --git a/compiler/ml/variant_coercion.ml b/compiler/ml/variant_coercion.ml new file mode 100644 index 0000000..b3599dc --- /dev/null +++ b/compiler/ml/variant_coercion.ml @@ -0,0 +1,299 @@ +type variant_runtime_representation_issue = + | Mismatched_unboxed_payload of { + constructor_name: string; + expected_typename: Path.t; + } + | Mismatched_as_payload of { + constructor_name: string; + expected_typename: Path.t; + as_payload: Ast_untagged_variants.tag_type option; + } + | As_payload_not_elgible_for_coercion of { + constructor_name: string; + expected_typename: Path.t; + as_payload: Ast_untagged_variants.tag_type; + } + | Inline_record_cannot_be_coerced of {constructor_name: string} + | Cannot_coerce_non_unboxed_with_payload of { + constructor_name: string; + expected_typename: Path.t; + } + +(* Right now we only allow coercing to primitives string/int/float *) +let can_coerce_primitive (path : Path.t) = + Path.same path Predef.path_string + || Path.same path Predef.path_int + || Path.same path Predef.path_float + || Path.same path Predef.path_bigint + +let check_paths_same p1 p2 target_path = + Path.same p1 target_path && Path.same p2 target_path + +let variant_has_case_covering_type + (constructors : Types.constructor_declaration list) ~path_is_same_fn = + let has_catch_all_string_case (c : Types.constructor_declaration) = + let args = c.cd_args in + match args with + | Cstr_tuple [{desc = Tconstr (p, [], _)}] -> path_is_same_fn p + | _ -> false + in + + constructors |> List.exists has_catch_all_string_case + +(* Checks if every case of the variant has the same runtime representation as the target type. *) +let variant_has_same_runtime_representation_as_target ~(target_path : Path.t) + ~unboxed (constructors : Types.constructor_declaration list) = + (* Helper function to check if a constructor has the same runtime representation as the target type *) + let has_same_runtime_representation (c : Types.constructor_declaration) = + let args = c.cd_args in + let as_payload = Ast_untagged_variants.process_tag_type c.cd_attributes in + + match args with + | Cstr_tuple [{desc = Tconstr (p, [], _)}] when unboxed -> + (* Unboxed type, and the constructor has a single item payload.*) + let path_same = check_paths_same p target_path in + if + (* unboxed String(string) :> string *) + path_same Predef.path_string + (* unboxed Number(float) :> float *) + || path_same Predef.path_float + || + (* unboxed BigInt(bigint) :> bigint *) + path_same Predef.path_bigint + then None + else + Some + (Mismatched_unboxed_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + }) + | Cstr_tuple [] -> ( + (* Check that @as payloads match with the target path to coerce to. + No @as means the default encoding, which is string *) + match as_payload with + | None | Some (String _) -> + if Path.same target_path Predef.path_string then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some (Int _) -> + if Path.same target_path Predef.path_int then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some (Float _) -> + if Path.same target_path Predef.path_float then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some (BigInt _) -> + if Path.same target_path Predef.path_bigint then None + else + Some + (Mismatched_as_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + as_payload; + }) + | Some ((Null | Undefined | Bool _ | Untagged _) as as_payload) -> + Some + (As_payload_not_elgible_for_coercion + { + constructor_name = Ident.name c.cd_id; + as_payload; + expected_typename = target_path; + })) + | Cstr_tuple _ -> + Some + (Cannot_coerce_non_unboxed_with_payload + { + constructor_name = Ident.name c.cd_id; + expected_typename = target_path; + }) + | Cstr_record _ -> + Some + (Inline_record_cannot_be_coerced {constructor_name = Ident.name c.cd_id}) + in + + List.filter_map has_same_runtime_representation constructors + +let can_try_coerce_variant_to_primitive + ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = + match typedecl with + | {type_kind = Type_variant constructors; type_params = []; type_attributes} + when not (Path.same p Predef.path_bool) -> + (* bool is represented as a variant internally, so we need to account for that *) + (* TODO(subtype-errors) Report about bool? *) + Some (p, constructors, type_attributes |> Ast_untagged_variants.has_untagged) + | _ -> None + +let can_try_coerce_variant_to_primitive_opt p = + match p with + | None -> None + | Some p -> can_try_coerce_variant_to_primitive p + +let variant_representation_matches (c1_attrs : Parsetree.attributes) + (c2_attrs : Parsetree.attributes) = + match + ( Ast_untagged_variants.process_tag_type c1_attrs, + Ast_untagged_variants.process_tag_type c2_attrs ) + with + | None, None -> true + | Some s1, Some s2 when s1 = s2 -> true + | _ -> false + +type variant_configuration_error = + | Untagged of {left_is_unboxed: bool} + | TagName of {left_tag: string option; right_tag: string option} + +type variant_error = + | VariantError of { + left_loc: Location.t; + right_loc: Location.t; + error: variant_configuration_error; + is_spread_context: bool; + } + +exception VariantConfigurationError of variant_error + +type variant_configuration_issue = + | Unboxed_config_not_matching of {left_unboxed: bool; right_unboxed: bool} + | Tag_name_not_matching of {left_tag: string option; right_tag: string option} + | Incompatible_constructor_count of {constructor_names: string list} + +let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) + (a2 : Parsetree.attributes) = + let unboxed = + match + ( Ast_untagged_variants.process_untagged a1, + Ast_untagged_variants.process_untagged a2 ) + with + | true, true | false, false -> Ok () + | left, right -> + Error + (Unboxed_config_not_matching + {left_unboxed = left; right_unboxed = right}) + in + let tag = + match + ( Ast_untagged_variants.process_tag_name a1, + Ast_untagged_variants.process_tag_name a2 ) + with + | Some tag1, Some tag2 when tag1 = tag2 -> Ok () + | None, None -> Ok () + | tag1, tag2 -> + Error (Tag_name_not_matching {left_tag = tag1; right_tag = tag2}) + in + match (unboxed, tag) with + | Ok (), Ok () -> Ok () + | Error e, _ | _, Error e -> Error e + +let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc + ~right_loc ~(left_attributes : Parsetree.attributes) + ~(right_attributes : Parsetree.attributes) = + (match + ( Ast_untagged_variants.process_untagged left_attributes, + Ast_untagged_variants.process_untagged right_attributes ) + with + | true, true | false, false -> () + | left, _right -> + raise + (VariantConfigurationError + (VariantError + { + is_spread_context; + left_loc; + right_loc; + error = Untagged {left_is_unboxed = left}; + }))); + + match + ( Ast_untagged_variants.process_tag_name left_attributes, + Ast_untagged_variants.process_tag_name right_attributes ) + with + | Some host_tag, Some spread_tag when host_tag = spread_tag -> () + | None, None -> () + | left_tag, right_tag -> + raise + (VariantConfigurationError + (VariantError + { + is_spread_context; + left_loc; + right_loc; + error = TagName {left_tag; right_tag}; + })) + +let can_coerce_polyvariant_to_variant ~row_fields ~variant_constructors + ~type_attributes = + let polyvariant_runtime_representations = + row_fields + |> List.filter_map (fun (label, (field : Types.row_field)) -> + (* Check that there's no payload in the polyvariant *) + match field with + | Rpresent None -> Some label + | _ -> None) + in + if List.length polyvariant_runtime_representations <> List.length row_fields + then + (* Error: At least one polyvariant constructor has a payload. Cannot have payloads. *) + Error `PolyvariantConstructorHasPayload + else + let is_unboxed = Ast_untagged_variants.has_untagged type_attributes in + if + List.for_all + (fun polyvariant_value -> + variant_constructors + |> List.exists (fun (c : Types.constructor_declaration) -> + let constructor_name = Ident.name c.cd_id in + match + Ast_untagged_variants.process_tag_type c.cd_attributes + with + | Some (String as_runtime_string) -> + (* `@as("")`, does the configured string match the polyvariant value? *) + as_runtime_string = polyvariant_value + | Some _ -> + (* Any other `@as` can't match since it's by definition not a string *) + false + | None -> ( + (* No `@as` means the runtime representation will be the constructor + name as a string. + + However, there's a special case with unboxed types where there's a + string catch-all case. In that case, any polyvariant will match, + since the catch-all case will match any string. *) + match (is_unboxed, c.cd_args) with + | true, Cstr_tuple [{desc = Tconstr (p, _, _)}] -> + Path.same p Predef.path_string + | _ -> polyvariant_value = constructor_name))) + polyvariant_runtime_representations + then Ok () + else Error `Unknown + +let type_is_variant (typ : (Path.t * Path.t * Types.type_declaration) option) = + match typ with + | Some (_, _, {type_kind = Type_variant _; _}) -> true + | _ -> false + +let has_res_pat_variant_spread_attribute attrs = + attrs + |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> + txt = "res.patVariantSpread") + |> Option.is_some diff --git a/jscomp/ml/variant_type_spread.ml b/compiler/ml/variant_type_spread.ml similarity index 94% rename from jscomp/ml/variant_type_spread.ml rename to compiler/ml/variant_type_spread.ml index bb1c380..029d98c 100644 --- a/jscomp/ml/variant_type_spread.ml +++ b/compiler/ml/variant_type_spread.ml @@ -1,6 +1,16 @@ let mk_constructor_comes_from_spread_attr () : Parsetree.attribute = (Location.mknoloc "res.constructor_from_spread", PStr []) +let mk_pat_from_variant_spread_attr () : Parsetree.attribute = + (Location.mknoloc "res.patFromVariantSpread", PStr []) + +let is_pat_from_variant_spread_attr pat = + pat.Typedtree.pat_attributes + |> List.exists (fun (a : Parsetree.attribute) -> + match a with + | {txt = "res.patFromVariantSpread"}, PStr [] -> true + | _ -> false) + type variant_type_spread_error = | CouldNotFindType | HasTypeParams @@ -32,7 +42,8 @@ let map_constructors ~(sdecl : Parsetree.type_declaration) ~all_constructors env in match type_decl with - | {type_kind = Type_variant [] } -> raise (VariantTypeSpreadError (loc.loc, InvalidType)) + | {type_kind = Type_variant []} -> + raise (VariantTypeSpreadError (loc.loc, InvalidType)) | {type_kind = Type_variant cstrs; type_attributes; type_params} -> if List.length type_params > 0 then raise (VariantTypeSpreadError (loc.loc, HasTypeParams)); @@ -167,6 +178,7 @@ let expand_dummy_constructor_args (sdecl_list : Parsetree.type_declaration list) pld_mutable = l.ld_mutable; pld_loc = l.ld_loc; pld_attributes = []; + pld_optional = l.ld_optional; pld_type = { ptyp_desc = Ptyp_any; diff --git a/jscomp/syntax/LICENSE b/compiler/syntax/LICENSE similarity index 100% rename from jscomp/syntax/LICENSE rename to compiler/syntax/LICENSE diff --git a/compiler/syntax/cli/dune b/compiler/syntax/cli/dune new file mode 100644 index 0000000..ba5f1ea --- /dev/null +++ b/compiler/syntax/cli/dune @@ -0,0 +1,14 @@ +(env + (static + (flags + (:standard -ccopt -static)))) + +(executable + (name res_cli) + (public_name res_parser) + (package rescript) + (enabled_if + (<> %{profile} browser)) + (flags + (:standard -w +a-4-42-40-9-48-70)) + (libraries syntax)) diff --git a/compiler/syntax/cli/res_cli.ml b/compiler/syntax/cli/res_cli.ml new file mode 100644 index 0000000..201a3ac --- /dev/null +++ b/compiler/syntax/cli/res_cli.ml @@ -0,0 +1,327 @@ +(* + This CLI isn't used apart for this repo's testing purposes. The syntax + itself is used by ReScript's compiler programmatically through various other apis. +*) + +(* + This is OCaml's Misc.ml's Color module. More specifically, this is + ReScript's OCaml fork's Misc.ml's Color module: + https://github.com/rescript-lang/ocaml/blob/92e58bedced8d7e3e177677800a38922327ab860/utils/misc.ml#L540 + + The syntax's printing's coloring logic depends on: + 1. a global mutable variable that's set in the compiler: Misc.Color.color_enabled + 2. the colors tags supported by Misc.Color, e.g. style_of_tag, which Format + tags like @{hello@} use + 3. etc. + + When this syntax is programmatically used inside ReScript, the various + Format tags like and get properly colored depending on the + above points. + + But when used by this cli file, that coloring logic doesn't render properly + because we're compiling against vanilla OCaml 4.06 instead of ReScript's + OCaml fork. For example, the vanilla compiler doesn't support the `dim` + color (grey). So we emulate the right coloring logic by copy pasting how our + forked OCaml compiler does it. +*) +module Color = struct + (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) + type[@warning "-37"] color = + | Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + + type[@warning "-37"] style = + | FG of color (* foreground *) + | BG of color (* background *) + | Bold + | Reset + | Dim + + let ansi_of_color = function + | Black -> "0" + | Red -> "1" + | Green -> "2" + | Yellow -> "3" + | Blue -> "4" + | Magenta -> "5" + | Cyan -> "6" + | White -> "7" + + let code_of_style = function + | FG c -> "3" ^ ansi_of_color c + | BG c -> "4" ^ ansi_of_color c + | Bold -> "1" + | Reset -> "0" + | Dim -> "2" + + let ansi_of_style_l l = + let s = + match l with + | [] -> code_of_style Reset + | [s] -> code_of_style s + | _ -> String.concat ";" (List.map code_of_style l) + in + "\x1b[" ^ s ^ "m" + + type styles = {error: style list; warning: style list; loc: style list} + + let default_styles = + {warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]} + + let cur_styles = ref default_styles + + (* let get_styles () = !cur_styles *) + (* let set_styles s = cur_styles := s *) + + (* map a tag to a style, if the tag is known. + @raise Not_found otherwise *) + let style_of_tag s = + match s with + | Format.String_tag "error" -> !cur_styles.error + | Format.String_tag "warning" -> !cur_styles.warning + | Format.String_tag "loc" -> !cur_styles.loc + | Format.String_tag "info" -> [Bold; FG Yellow] + | Format.String_tag "dim" -> [Dim] + | Format.String_tag "filename" -> [FG Cyan] + | _ -> raise Not_found + [@@raises Not_found] + + let color_enabled = ref true + + (* either prints the tag of [s] or delegates to [or_else] *) + let mark_open_tag ~or_else s = + try + let style = style_of_tag s in + if !color_enabled then ansi_of_style_l style else "" + with Not_found -> or_else s + + let mark_close_tag ~or_else s = + try + let _ = style_of_tag s in + if !color_enabled then ansi_of_style_l [Reset] else "" + with Not_found -> or_else s + + (* add color handling to formatter [ppf] *) + let set_color_tag_handling ppf = + let open Format in + let functions = pp_get_formatter_stag_functions ppf () in + let functions' = + { + functions with + mark_open_stag = mark_open_tag ~or_else:functions.mark_open_stag; + mark_close_stag = mark_close_tag ~or_else:functions.mark_close_stag; + } + in + pp_set_mark_tags ppf true; + (* enable tags *) + pp_set_formatter_stag_functions ppf functions'; + (* also setup margins *) + pp_set_margin ppf (pp_get_margin std_formatter ()); + () + + external isatty : out_channel -> bool = "caml_sys_isatty" + + (* reasonable heuristic on whether colors should be enabled *) + let should_enable_color () = + let term = try Sys.getenv "TERM" with Not_found -> "" in + term <> "dumb" && term <> "" && isatty stderr + + type[@warning "-37"] setting = Auto | Always | Never + + let setup = + let first = ref true in + (* initialize only once *) + let formatter_l = + [Format.std_formatter; Format.err_formatter; Format.str_formatter] + in + fun o -> + if !first then ( + first := false; + Format.set_mark_tags true; + List.iter set_color_tag_handling formatter_l; + color_enabled := + match o with + | Some Always -> true + | Some Auto -> should_enable_color () + | Some Never -> false + | None -> should_enable_color ()); + () +end + +(* command line flags *) +module ResClflags : sig + val recover : bool ref + val print : string ref + val width : int ref + val file : string ref + val interface : bool ref + val jsx_version : int ref + val jsx_module : string ref + val typechecker : bool ref + val test_ast_conversion : bool ref + + val parse : unit -> unit +end = struct + let recover = ref false + let width = ref 100 + + let print = ref "res" + let interface = ref false + let jsx_version = ref (-1) + let jsx_module = ref "react" + let file = ref "" + let typechecker = ref false + let test_ast_conversion = ref false + + let usage = + "\n\ + **This command line is for the repo developer's testing purpose only. DO \ + NOT use it in production**!\n\n" + ^ "Usage:\n res_parser \n\n" ^ "Examples:\n" + ^ " res_parser myFile.res\n" + ^ " res_parser -parse ml -print res myFile.ml\n" + ^ " res_parser -parse res -print binary -interface myFile.resi\n\n" + ^ "Options are:" + + let spec = + [ + ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); + ( "-print", + Arg.String (fun txt -> print := txt), + "Print either binary, ml, ast, sexp, comments, tokens or res. Default: \ + res" ); + ( "-width", + Arg.Int (fun w -> width := w), + "Specify the line length for the printer (formatter)" ); + ( "-interface", + Arg.Unit (fun () -> interface := true), + "Parse as interface" ); + ( "-jsx-version", + Arg.Int (fun i -> jsx_version := i), + "Apply a specific built-in ppx before parsing, none or 3, 4. Default: \ + none" ); + ( "-jsx-module", + Arg.String (fun txt -> jsx_module := txt), + "Specify the jsx module. Default: react" ); + ( "-typechecker", + Arg.Unit (fun () -> typechecker := true), + "Parses the ast as it would be passed to the typechecker and not the \ + printer" ); + ( "-test-ast-conversion", + Arg.Unit (fun () -> test_ast_conversion := true), + "Test the ast conversion" ); + ] + + let parse () = Arg.parse spec (fun f -> file := f) usage +end + +module CliArgProcessor = struct + type backend = Parser : 'diagnostics Res_driver.parsing_engine -> backend + [@@unboxed] + + let process_file ~is_interface ~width ~recover ~target ~jsx_version + ~jsx_module ~typechecker ~test_ast_conversion filename = + let len = String.length filename in + let process_interface = + is_interface + || (len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i') + in + let parsing_engine = Parser Res_driver.parsing_engine in + let print_engine = + match target with + | "binary" -> Res_driver_binary.print_engine + | "ml" -> Res_driver_ml_printer.print_engine + | "ast" -> Res_ast_debugger.print_engine + | "sexp" -> Res_ast_debugger.sexp_print_engine + | "comments" -> Res_ast_debugger.comments_print_engine + | "tokens" -> Res_token_debugger.token_print_engine + | "res" -> Res_driver.print_engine + | target -> + print_endline + ("-print needs to be either binary, ml, ast, sexp, comments, tokens \ + or res. You provided " ^ target); + exit 1 + in + + let for_printer = + match target with + | ("res" | "sexp") when not typechecker -> true + | _ -> false + in + + let (Parser backend) = parsing_engine in + (* This is the whole purpose of the Color module above *) + Color.setup None; + + (* Special case for tokens - bypass parsing entirely *) + if target = "tokens" then + print_engine.print_implementation ~width ~filename ~comments:[] [] + else if process_interface then + let parse_result = backend.parse_interface ~for_printer ~filename in + if parse_result.invalid then ( + backend.string_of_diagnostics ~source:parse_result.source + ~filename:parse_result.filename parse_result.diagnostics; + if recover then + print_engine.print_interface ~width ~filename + ~comments:parse_result.comments parse_result.parsetree + else exit 1) + else + let parsetree = + if not test_ast_conversion then parse_result.parsetree + else + let tree0 = + Ast_mapper_to0.default_mapper.signature + Ast_mapper_to0.default_mapper parse_result.parsetree + in + Ast_mapper_from0.default_mapper.signature + Ast_mapper_from0.default_mapper tree0 + in + let parsetree = + Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module parsetree + in + print_engine.print_interface ~width ~filename + ~comments:parse_result.comments parsetree + else + let parse_result = backend.parse_implementation ~for_printer ~filename in + if parse_result.invalid then ( + backend.string_of_diagnostics ~source:parse_result.source + ~filename:parse_result.filename parse_result.diagnostics; + if recover then + print_engine.print_implementation ~width ~filename + ~comments:parse_result.comments parse_result.parsetree + else exit 1) + else + let parsetree = + if not test_ast_conversion then parse_result.parsetree + else + let tree0 = + Ast_mapper_to0.default_mapper.structure + Ast_mapper_to0.default_mapper parse_result.parsetree + in + Ast_mapper_from0.default_mapper.structure + Ast_mapper_from0.default_mapper tree0 + in + let parsetree = + Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module parsetree + in + print_engine.print_implementation ~width ~filename + ~comments:parse_result.comments parsetree + [@@raises exit] +end + +let () = + if not !Sys.interactive then ( + ResClflags.parse (); + CliArgProcessor.process_file ~is_interface:!ResClflags.interface + ~width:!ResClflags.width ~recover:!ResClflags.recover + ~target:!ResClflags.print ~jsx_version:!ResClflags.jsx_version + ~jsx_module:!ResClflags.jsx_module ~typechecker:!ResClflags.typechecker + !ResClflags.file + ~test_ast_conversion:!ResClflags.test_ast_conversion) +[@@raises exit] diff --git a/compiler/syntax/dune b/compiler/syntax/dune new file mode 100644 index 0000000..ae61e90 --- /dev/null +++ b/compiler/syntax/dune @@ -0,0 +1,9 @@ +(dirs compiler-libs-406 src) + +(env + (dev + (flags + (:standard -w +a-4-42-40-9-48))) + (release + (flags + (:standard -w +a-4-42-40-9-48)))) diff --git a/compiler/syntax/src/dune b/compiler/syntax/src/dune new file mode 100644 index 0000000..7765dcb --- /dev/null +++ b/compiler/syntax/src/dune @@ -0,0 +1,6 @@ +(library + (name syntax) + (wrapped false) + (flags + (:standard -w +a-4-42-40-9-48-70)) + (libraries ml)) diff --git a/compiler/syntax/src/jsx_common.ml b/compiler/syntax/src/jsx_common.ml new file mode 100644 index 0000000..a48cf11 --- /dev/null +++ b/compiler/syntax/src/jsx_common.ml @@ -0,0 +1,58 @@ +open Asttypes +open Parsetree + +type jsx_config = { + mutable version: int; + mutable module_: string; + mutable nested_modules: string list; + mutable has_component: bool; +} + +(* Helper method to look up the [@react.component] attribute *) +let has_attr (loc, _) = + match loc.txt with + | "react.component" | "jsx.component" -> true + | _ -> false + +let has_attr_with_props (loc, _) = + match loc.txt with + | "react.componentWithProps" | "jsx.componentWithProps" -> true + | _ -> false + +(* Iterate over the attributes and try to find the [@react.component] attribute *) +let has_attr_on_binding pred {pvb_attributes} = + List.find_opt pred pvb_attributes <> None + +let core_type_of_attrs attributes = + List.find_map + (fun ({txt}, payload) -> + match (txt, payload) with + | ("react.component" | "jsx.component"), PTyp core_type -> Some core_type + | _ -> None) + attributes + +let typ_vars_of_core_type {ptyp_desc} = + match ptyp_desc with + | Ptyp_constr (_, core_types) -> + List.filter + (fun {ptyp_desc} -> + match ptyp_desc with + | Ptyp_var _ -> true + | _ -> false) + core_types + | _ -> [] + +let raise_error ~loc msg = Location.raise_errorf ~loc msg + +let raise_error_multiple_component ~loc = + raise_error ~loc + "Only one component definition is allowed for each module. Move to a \ + submodule or other file if necessary." + +let async_component ~async expr = + if async then + let open Ast_helper in + Exp.apply + (Exp.ident {loc = Location.none; txt = Ldot (Lident "Jsx", "promise")}) + [(Nolabel, expr)] + else expr diff --git a/compiler/syntax/src/jsx_ppx.ml b/compiler/syntax/src/jsx_ppx.ml new file mode 100644 index 0000000..4b05e19 --- /dev/null +++ b/compiler/syntax/src/jsx_ppx.ml @@ -0,0 +1,162 @@ +open Ast_mapper +open Asttypes +open Parsetree +open Longident + +let get_payload_fields payload = + match payload with + | PStr + ({ + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_record (record_fields, None)}, _); + } + :: _rest) -> + record_fields + | _ -> [] + +type config_key = Int | String + +let get_jsx_config_by_key ~key ~type_ record_fields = + let values = + List.filter_map + (fun ({lid; x = expr} : expression record_element) -> + match (type_, lid, expr) with + | ( Int, + {txt = Lident k}, + {pexp_desc = Pexp_constant (Pconst_integer (value, None))} ) + when k = key -> + Some value + | ( String, + {txt = Lident k}, + (* accept both normal strings and "js" strings *) + {pexp_desc = Pexp_constant (Pconst_string (value, _))} ) + when k = key -> + Some value + | _ -> None) + record_fields + in + match values with + | [] -> None + | [v] | v :: _ -> Some v + +let get_int ~key fields = + match fields |> get_jsx_config_by_key ~key ~type_:Int with + | None -> None + | Some s -> int_of_string_opt s + +let get_string ~key fields = fields |> get_jsx_config_by_key ~key ~type_:String + +let update_config config payload = + let fields = get_payload_fields payload in + let module_raw = get_string ~key:"module_" fields in + let is_generic = + match module_raw |> Option.map (fun m -> String.lowercase_ascii m) with + | Some "react" | None -> false + | Some _ -> true + in + (match (is_generic, get_int ~key:"version" fields) with + | true, _ -> config.Jsx_common.version <- 4 + | false, Some i -> config.Jsx_common.version <- i + | _ -> ()); + match module_raw with + | None -> () + | Some s -> config.module_ <- s + +let is_jsx_config_attr ((loc, _) : attribute) = loc.txt = "jsxConfig" + +let process_config_attribute attribute config = + if is_jsx_config_attr attribute then update_config config (snd attribute) + +let get_mapper ~config = + let ( expr4, + module_binding4, + transform_signature_item4, + transform_structure_item4 ) = + Jsx_v4.jsx_mapper ~config + in + + let expr mapper e = + match config.version with + | 4 -> expr4 mapper e + | _ -> default_mapper.expr mapper e + in + let module_binding mapper mb = + match config.version with + | 4 -> module_binding4 mapper mb + | _ -> default_mapper.module_binding mapper mb + in + let save_config () = + { + config with + version = config.version; + module_ = config.module_; + has_component = config.has_component; + } + in + let restore_config old_config = + config.version <- old_config.Jsx_common.version; + config.module_ <- old_config.module_; + config.has_component <- old_config.has_component + in + let signature mapper items = + let old_config = save_config () in + config.has_component <- false; + let result = + List.map + (fun item -> + (match item.psig_desc with + | Psig_attribute attr -> process_config_attribute attr config + | _ -> ()); + let item = default_mapper.signature_item mapper item in + if config.version = 4 then transform_signature_item4 item else [item]) + items + |> List.flatten + in + restore_config old_config; + result + in + let structure mapper items = + let old_config = save_config () in + config.has_component <- false; + let result = + List.map + (fun item -> + (match item.pstr_desc with + | Pstr_attribute attr -> process_config_attribute attr config + | _ -> ()); + let item = default_mapper.structure_item mapper item in + if config.version = 4 then transform_structure_item4 item else [item]) + items + |> List.flatten + in + restore_config old_config; + result + in + + {default_mapper with expr; module_binding; signature; structure} + +let rewrite_implementation ~jsx_version ~jsx_module (code : Parsetree.structure) + : Parsetree.structure = + let config = + { + Jsx_common.version = jsx_version; + module_ = jsx_module; + nested_modules = []; + has_component = false; + } + in + let mapper = get_mapper ~config in + mapper.structure mapper code + +let rewrite_signature ~jsx_version ~jsx_module (code : Parsetree.signature) : + Parsetree.signature = + let config = + { + Jsx_common.version = jsx_version; + module_ = jsx_module; + nested_modules = []; + has_component = false; + } + in + let mapper = get_mapper ~config in + mapper.signature mapper code diff --git a/compiler/syntax/src/jsx_ppx.mli b/compiler/syntax/src/jsx_ppx.mli new file mode 100644 index 0000000..36ff84f --- /dev/null +++ b/compiler/syntax/src/jsx_ppx.mli @@ -0,0 +1,18 @@ +(* + This is the module that handles turning Reason JSX' agnostic function call into + a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx + facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension- + points-in-ocaml/ +*) + +val rewrite_implementation : + jsx_version:int -> + jsx_module:string -> + Parsetree.structure -> + Parsetree.structure + +val rewrite_signature : + jsx_version:int -> + jsx_module:string -> + Parsetree.signature -> + Parsetree.signature diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml new file mode 100644 index 0000000..4cf9c9a --- /dev/null +++ b/compiler/syntax/src/jsx_v4.ml @@ -0,0 +1,1369 @@ +open! Ast_helper +open Ast_mapper +open Asttypes +open! Parsetree +open Longident + +let module_access_name config value = + String.capitalize_ascii config.Jsx_common.module_ ^ "." ^ value + |> Longident.parse + +let nolabel = Nolabel + +let is_optional str = + match str with + | Optional _ -> true + | _ -> false + +let is_labelled str = + match str with + | Labelled _ -> true + | _ -> false + +let is_forward_ref = function + | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true + | _ -> false + +let get_label str = + match str with + | Optional {txt = str} | Labelled {txt = str} -> str + | Nolabel -> "" + +let constant_string ~loc str = + Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) + +let unit_expr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None + +let safe_type_from_value value_str = + let value_str = get_label value_str in + if value_str = "" || (value_str.[0] [@doesNotRaise]) <> '_' then value_str + else "T" ^ value_str + +let ref_type_var loc = Typ.var ~loc "ref" + +let ref_type loc = + Typ.constr ~loc + {loc; txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")} + [ref_type_var loc] + +let jsx_element_type config ~loc = + Typ.constr ~loc {loc; txt = module_access_name config "element"} [] + +(* Helper method to filter out any attribute that isn't [@react.component] *) +let other_attrs_pure (loc, _) = + match loc.txt with + | "react.component" | "jsx.component" | "react.componentWithProps" + | "jsx.componentWithProps" -> + false + | _ -> true + +(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) +let rec get_fn_name binding = + match binding with + | {ppat_desc = Ppat_var {txt}} -> txt + | {ppat_desc = Ppat_constraint (pat, _)} -> get_fn_name pat + | {ppat_loc} -> + Jsx_common.raise_error ~loc:ppat_loc + "JSX component calls cannot be destructured." + +let make_new_binding binding expression new_name = + match binding with + | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> + { + binding with + pvb_pat = + {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = new_name}}; + pvb_expr = expression; + pvb_attributes = []; + } + | {pvb_loc} -> + Jsx_common.raise_error ~loc:pvb_loc + "JSX component calls cannot be destructured." + +(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) +let filename_from_loc (pstr_loc : Location.t) = + let file_name = + match pstr_loc.loc_start.pos_fname with + | "" -> !Location.input_name + | file_name -> file_name + in + let file_name = + try Filename.chop_extension (Filename.basename file_name) + with Invalid_argument _ -> file_name + in + let file_name = String.capitalize_ascii file_name in + file_name + +(* Build a string representation of a module name with segments separated by $ *) +let make_module_name file_name nested_modules fn_name = + let full_module_name = + match (file_name, nested_modules, fn_name) with + (* TODO: is this even reachable? It seems like the fileName always exists *) + | "", nested_modules, "make" -> nested_modules + | "", nested_modules, fn_name -> List.rev (fn_name :: nested_modules) + | file_name, nested_modules, "make" -> file_name :: List.rev nested_modules + | file_name, nested_modules, fn_name -> + file_name :: List.rev (fn_name :: nested_modules) + in + let full_module_name = String.concat "$" full_module_name in + full_module_name + +(* make type params for make fn arguments *) +(* let make = ({id, name, children}: props<'id, 'name, 'children>) *) +let make_props_type_params_tvar named_type_list = + named_type_list + |> List.filter_map (fun (_isOptional, label, _, loc, _interiorType) -> + if label = "key" then None + else + Some + (Typ.var ~loc + @@ safe_type_from_value + (Labelled {txt = label; loc = Location.none}))) + +let strip_option core_type = + match core_type with + | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, core_types)} -> + List.nth_opt core_types 0 [@doesNotRaise] + | _ -> Some core_type + +let strip_js_nullable core_type = + match core_type with + | { + ptyp_desc = + Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")}, core_types); + } -> + List.nth_opt core_types 0 [@doesNotRaise] + | _ -> Some core_type + +(* Make type params of the props type *) +(* (Sig) let make: React.componentLike, React.element> *) +(* (Str) let make = ({x, _}: props<'x>) => body *) +(* (Str) external make: React.componentLike, React.element> = "default" *) +let make_props_type_params ?(strip_explicit_option = false) + ?(strip_explicit_js_nullable_of_ref = false) named_type_list = + named_type_list + |> List.filter_map (fun (is_optional, label, _, loc, interior_type) -> + if label = "key" then None + (* TODO: Worth thinking how about "ref_" or "_ref" usages *) + else if label = "ref" then + (* + If ref has a type annotation then use it, else 'ref. + For example, if JSX ppx is used for React Native, type would be different. + *) + match interior_type with + | {ptyp_desc = Ptyp_any} -> Some (ref_type_var loc) + | _ -> + (* Strip explicit Js.Nullable.t in case of forwardRef *) + if strip_explicit_js_nullable_of_ref then + strip_js_nullable interior_type + else Some interior_type + (* Strip the explicit option type in implementation *) + (* let make = (~x: option=?) => ... *) + else if is_optional && strip_explicit_option then + strip_option interior_type + else Some interior_type) + +let make_label_decls named_type_list = + let rec check_duplicated_label l = + let rec mem_label ((_, (la : string), _, _, _) as x) = function + | [] -> false + | (_, (lb : string), _, _, _) :: l -> lb = la || mem_label x l + in + match l with + | [] -> () + | hd :: tl -> + if mem_label hd tl then + let _, label, _, loc, _ = hd in + Jsx_common.raise_error ~loc + "The prop `%s` is defined several times in this component." label + else check_duplicated_label tl + in + let () = named_type_list |> List.rev |> check_duplicated_label in + + named_type_list + |> List.map (fun (is_optional, label, attrs, loc, interior_type) -> + if label = "key" then + Type.field ~loc ~attrs ~optional:true {txt = label; loc} + interior_type + else if is_optional then + Type.field ~loc ~attrs ~optional:true {txt = label; loc} + (Typ.var @@ safe_type_from_value + @@ Labelled {txt = label; loc = Location.none}) + else + Type.field ~loc ~attrs {txt = label; loc} + (Typ.var @@ safe_type_from_value + @@ Labelled {txt = label; loc = Location.none})) + +let make_type_decls ~attrs props_name loc named_type_list = + let label_decl_list = make_label_decls named_type_list in + (* 'id, 'className, ... *) + let params = + make_props_type_params_tvar named_type_list + |> List.map (fun core_type -> (core_type, Invariant)) + in + [ + Type.mk ~attrs ~loc ~params {txt = props_name; loc} + ~kind:(Ptype_record label_decl_list); + ] + +let make_type_decls_with_core_type props_name loc core_type typ_vars = + [ + Type.mk ~loc {txt = props_name; loc} ~kind:Ptype_abstract + ~params:(typ_vars |> List.map (fun v -> (v, Invariant))) + ~manifest:core_type; + ] + +let live_attr = ({txt = "live"; loc = Location.none}, PStr []) +let jsx_component_props_attr = + ({txt = "res.jsxComponentProps"; loc = Location.none}, PStr []) + +(* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) +let make_props_record_type ~core_type_of_attr ~external_ ~typ_vars_of_core_type + props_name loc named_type_list = + let attrs = + if external_ then [jsx_component_props_attr; live_attr] + else [jsx_component_props_attr] + in + Str.type_ Nonrecursive + (match core_type_of_attr with + | None -> make_type_decls ~attrs props_name loc named_type_list + | Some core_type -> + make_type_decls_with_core_type props_name loc core_type + typ_vars_of_core_type) + +(* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) +let make_props_record_type_sig ~core_type_of_attr ~external_ + ~typ_vars_of_core_type props_name loc named_type_list = + let attrs = + if external_ then [jsx_component_props_attr; live_attr] + else [jsx_component_props_attr] + in + Sig.type_ Nonrecursive + (match core_type_of_attr with + | None -> make_type_decls ~attrs props_name loc named_type_list + | Some core_type -> + make_type_decls_with_core_type props_name loc core_type + typ_vars_of_core_type) + +let rec recursively_transform_named_args_for_make expr args newtypes core_type = + match expr.pexp_desc with + (* TODO: make this show up with a loc. *) + | Pexp_fun {arg_label = Labelled {txt = "key"} | Optional {txt = "key"}} -> + Jsx_common.raise_error ~loc:expr.pexp_loc + "Key cannot be accessed inside of a component. Don't worry - you can \ + always key a component from its parent!" + | Pexp_fun {arg_label = arg; default; lhs = pattern; rhs = expression} + when is_optional arg || is_labelled arg -> + let () = + match (is_optional arg, pattern, default) with + | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( + match ptyp_desc with + | Ptyp_constr ({txt = Lident "option"}, [_]) -> () + | _ -> + let current_type = + match ptyp_desc with + | Ptyp_constr ({txt}, []) -> + String.concat "." (Longident.flatten txt) + | Ptyp_constr ({txt}, _innerTypeArgs) -> + String.concat "." (Longident.flatten txt) ^ "(...)" + | _ -> "..." + in + Location.prerr_warning pattern.ppat_loc + (Preprocessor + (Printf.sprintf + "React: optional argument annotations must have explicit \ + `option`. Did you mean `option<%s>=?`?" + current_type))) + | _ -> () + in + let alias = + match pattern with + | { + ppat_desc = + ( Ppat_alias (_, {txt}) + | Ppat_var {txt} + | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) ); + } -> + txt + | {ppat_desc = Ppat_any} -> "_" + | _ -> get_label arg + in + let type_ = + match pattern with + | {ppat_desc = Ppat_constraint (_, {ptyp_desc = Ptyp_package _})} -> None + | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ + | _ -> None + in + + recursively_transform_named_args_for_make expression + ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) + newtypes core_type + | Pexp_fun + { + arg_label = Nolabel; + lhs = {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}; + } -> + (args, newtypes, core_type) + | Pexp_fun + { + arg_label = Nolabel; + lhs = + { + ppat_desc = + Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + } as pattern; + } -> + if txt = "ref" then + let type_ = + match pattern with + | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ + | _ -> None + in + (* The ref arguement of forwardRef should be optional *) + ( ( Optional {txt = "ref"; loc = Location.none}, + None, + pattern, + txt, + pattern.ppat_loc, + type_ ) + :: args, + newtypes, + core_type ) + else (args, newtypes, core_type) + | Pexp_fun {arg_label = Nolabel; lhs = pattern} -> + Location.raise_errorf ~loc:pattern.ppat_loc + "React: react.component refs only support plain arguments and type \ + annotations." + | Pexp_newtype (label, expression) -> + recursively_transform_named_args_for_make expression args + (label :: newtypes) core_type + | Pexp_constraint (expression, core_type) -> + recursively_transform_named_args_for_make expression args newtypes + (Some core_type) + | _ -> (args, newtypes, core_type) + +let arg_to_type types + ((name, default, {ppat_attributes = attrs}, _alias, loc, type_) : + arg_label * expression option * pattern * label * 'loc * core_type option) + = + match (type_, name, default) with + | Some type_, name, _ when is_optional name -> + (true, get_label name, attrs, loc, type_) :: types + | Some type_, name, _ -> (false, get_label name, attrs, loc, type_) :: types + | None, name, _ when is_optional name -> + (true, get_label name, attrs, loc, Typ.any ~loc ()) :: types + | None, name, _ when is_labelled name -> + (false, get_label name, attrs, loc, Typ.any ~loc ()) :: types + | _ -> types + +let has_default_value name_arg_list = + name_arg_list + |> List.exists (fun (name, default, _, _, _, _) -> + Option.is_some default && is_optional name) + +let arg_to_concrete_type types (name, attrs, loc, type_) = + match name with + | name when is_labelled name -> + (false, get_label name, attrs, loc, type_) :: types + | name when is_optional name -> + (true, get_label name, attrs, loc, type_) :: types + | _ -> types + +let check_string_int_attribute_iter = + let attribute _ ({txt; loc}, _) = + if txt = "string" || txt = "int" then + Jsx_common.raise_error ~loc + "@string and @int attributes not supported. See \ + https://github.com/rescript-lang/rescript-compiler/issues/5724" + in + + {Ast_iterator.default_iterator with attribute} + +let check_multiple_components ~config ~loc = + (* If there is another component, throw error *) + if config.Jsx_common.has_component then + Jsx_common.raise_error_multiple_component ~loc + else config.has_component <- true + +let modified_binding_old binding = + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunk_for_fun_expression expression = + match expression with + (* let make = (~prop) => ... *) + | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> expression + (* let make = {let foo = bar in (~prop) => ...} *) + | {pexp_desc = Pexp_let (_recursive, _vbs, return_expression)} -> + (* here's where we spelunk! *) + spelunk_for_fun_expression return_expression + (* let make = React.forwardRef((~prop) => ...) *) + | {pexp_desc = Pexp_apply {args = [(Nolabel, inner_function_expression)]}} + -> + spelunk_for_fun_expression inner_function_expression + | { + pexp_desc = Pexp_sequence (_wrapperExpression, inner_function_expression); + } -> + spelunk_for_fun_expression inner_function_expression + | {pexp_desc = Pexp_constraint (inner_function_expression, _typ)} -> + spelunk_for_fun_expression inner_function_expression + | {pexp_loc} -> + Jsx_common.raise_error ~loc:pexp_loc + "JSX component calls can only be on function definitions or component \ + wrappers (forwardRef, memo)." + in + spelunk_for_fun_expression expression + +let modified_binding ~binding_loc ~binding_pat_loc ~fn_name binding = + let has_application = ref false in + let wrap_expression_with_binding expression_fn expression = + Vb.mk ~loc:binding_loc ~attrs:binding.pvb_attributes + (Pat.var ~loc:binding_pat_loc {loc = binding_pat_loc; txt = fn_name}) + (expression_fn expression) + in + let expression = binding.pvb_expr in + (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) + let rec spelunk_for_fun_expression expression = + match expression with + (* let make = (~prop) => ... with no final unit *) + | { + pexp_desc = + Pexp_fun + ({ + arg_label = Labelled _ | Optional _; + rhs = {pexp_desc = Pexp_fun _} as internal_expression; + } as f); + } -> + let wrap, has_forward_ref, exp = + spelunk_for_fun_expression internal_expression + in + ( wrap, + has_forward_ref, + {expression with pexp_desc = Pexp_fun {f with rhs = exp}} ) + (* let make = (()) => ... *) + (* let make = (_) => ... *) + | { + pexp_desc = + Pexp_fun + { + arg_label = Nolabel; + lhs = + {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}; + }; + } -> + ((fun a -> a), false, expression) + (* let make = (~prop) => ... *) + | {pexp_desc = Pexp_fun {arg_label = Labelled _ | Optional _}} -> + ((fun a -> a), false, expression) + (* let make = (prop) => ... *) + | {pexp_desc = Pexp_fun {lhs = pattern}} -> + if !has_application then ((fun a -> a), false, expression) + else + Location.raise_errorf ~loc:pattern.ppat_loc + "React: props need to be labelled arguments.\n\ + \ If you are working with refs be sure to wrap with React.forwardRef.\n\ + \ If your component doesn't have any props use () or _ instead of a \ + name." + (* let make = {let foo = bar in (~prop) => ...} *) + | {pexp_desc = Pexp_let (recursive, vbs, internal_expression)} -> + (* here's where we spelunk! *) + let wrap, has_forward_ref, exp = + spelunk_for_fun_expression internal_expression + in + ( wrap, + has_forward_ref, + {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} ) + (* let make = React.forwardRef((~prop) => ...) *) + | { + pexp_desc = + Pexp_apply + {funct = wrapper_expression; args = [(Nolabel, internal_expression)]}; + } -> + let () = has_application := true in + let _, _, exp = spelunk_for_fun_expression internal_expression in + let has_forward_ref = is_forward_ref wrapper_expression in + ( (fun exp -> Exp.apply wrapper_expression [(nolabel, exp)]), + has_forward_ref, + exp ) + | {pexp_desc = Pexp_sequence (wrapper_expression, internal_expression)} -> + let wrap, has_forward_ref, exp = + spelunk_for_fun_expression internal_expression + in + ( wrap, + has_forward_ref, + {expression with pexp_desc = Pexp_sequence (wrapper_expression, exp)} ) + | e -> ((fun a -> a), false, e) + in + let wrap_expression, has_forward_ref, expression = + spelunk_for_fun_expression expression + in + (wrap_expression_with_binding wrap_expression, has_forward_ref, expression) + +let vb_match ~expr (name, default, _, alias, loc, _) = + let label = get_label name in + match default with + | Some default -> + let value_binding = + Vb.mk + (Pat.var (Location.mkloc alias loc)) + (Exp.match_ + (Exp.ident {txt = Lident ("__" ^ alias); loc = Location.none}) + [ + Exp.case + (Pat.construct + (Location.mknoloc @@ Lident "Some") + (Some (Pat.var (Location.mknoloc label)))) + (Exp.ident (Location.mknoloc @@ Lident label)); + Exp.case + (Pat.construct (Location.mknoloc @@ Lident "None") None) + default; + ]) + in + Exp.let_ Nonrecursive [value_binding] expr + | None -> expr + +let vb_match_expr named_arg_list expr = + let rec aux named_arg_list = + match named_arg_list with + | [] -> expr + | named_arg :: rest -> vb_match named_arg ~expr:(aux rest) + in + aux (List.rev named_arg_list) + +let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = + (* Traverse the component body and force every reachable return expression to + be annotated as `Jsx.element`. This walks through the wrapper constructs the + PPX introduces (fun/newtype/let/sequence) so that the constraint ends up on + the real return position even after we rewrite the function. *) + let rec constrain_jsx_return expr = + let jsx_element_constraint expr = + Exp.constraint_ expr (jsx_element_type config ~loc:expr.pexp_loc) + in + match expr.pexp_desc with + | Pexp_fun ({rhs} as desc) -> + { + expr with + pexp_desc = Pexp_fun {desc with rhs = constrain_jsx_return rhs}; + } + | Pexp_newtype (param, inner) -> + {expr with pexp_desc = Pexp_newtype (param, constrain_jsx_return inner)} + | Pexp_constraint (inner, _) -> + let constrained_inner = constrain_jsx_return inner in + jsx_element_constraint constrained_inner + | Pexp_let (rec_flag, bindings, body) -> + { + expr with + pexp_desc = Pexp_let (rec_flag, bindings, constrain_jsx_return body); + } + | Pexp_sequence (first, second) -> + {expr with pexp_desc = Pexp_sequence (first, constrain_jsx_return second)} + | _ -> jsx_element_constraint expr + in + if Jsx_common.has_attr_on_binding Jsx_common.has_attr binding then ( + check_multiple_components ~config ~loc:pstr_loc; + let core_type_of_attr = + Jsx_common.core_type_of_attrs binding.pvb_attributes + in + let typ_vars_of_core_type = + core_type_of_attr + |> Option.map Jsx_common.typ_vars_of_core_type + |> Option.value ~default:[] + in + let binding_loc = binding.pvb_loc in + let binding_pat_loc = binding.pvb_pat.ppat_loc in + let binding = + { + binding with + pvb_pat = {binding.pvb_pat with ppat_loc = empty_loc}; + pvb_loc = empty_loc; + pvb_attributes = binding.pvb_attributes |> List.filter other_attrs_pure; + } + in + let fn_name = get_fn_name binding.pvb_pat in + let internal_fn_name = fn_name ^ "$Internal" in + let full_module_name = + make_module_name file_name config.nested_modules fn_name + in + let binding_wrapper, has_forward_ref, expression = + modified_binding ~binding_loc ~binding_pat_loc ~fn_name binding + in + let is_async = Ast_async.dig_async_payload_from_function binding.pvb_expr in + let named_arg_list, newtypes, _typeConstraints = + recursively_transform_named_args_for_make + (modified_binding_old binding) + [] [] None + in + let named_type_list = List.fold_left arg_to_type [] named_arg_list in + (* type props = { ... } *) + let props_record_type = + make_props_record_type ~core_type_of_attr ~external_:false + ~typ_vars_of_core_type "props" pstr_loc named_type_list + in + let inner_expression = + Exp.apply + (Exp.ident + (Location.mknoloc + @@ Lident + (match rec_flag with + | Recursive -> internal_fn_name + | Nonrecursive -> fn_name))) + ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] + @ + match has_forward_ref with + | true -> [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] + | false -> []) + in + let make_props_pattern = function + | [] -> Pat.var @@ Location.mknoloc "props" + | _ -> + Pat.constraint_ + (Pat.var @@ Location.mknoloc "props") + (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) + in + let inner_expression = + Jsx_common.async_component ~async:is_async inner_expression + in + let full_expression = + (* React component name should start with uppercase letter *) + (* let make = { let \"App" = props => make(props); \"App" } *) + (* let make = React.forwardRef({ + let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) + })*) + let total_arity = if has_forward_ref then 2 else 1 in + Exp.fun_ ~arity:(Some total_arity) Nolabel None + (match core_type_of_attr with + | None -> make_props_pattern named_type_list + | Some _ -> make_props_pattern typ_vars_of_core_type) + (if has_forward_ref then + Exp.fun_ ~arity:None Nolabel None + (Pat.var @@ Location.mknoloc "ref") + inner_expression + else inner_expression) + ~attrs:binding.pvb_expr.pexp_attributes + in + let full_expression = + match full_module_name with + | "" -> full_expression + | txt -> + Exp.let_ Nonrecursive + [ + Vb.mk ~loc:empty_loc + (Pat.var ~loc:empty_loc {loc = empty_loc; txt}) + full_expression; + ] + (Exp.ident ~loc:pstr_loc {loc = empty_loc; txt = Lident txt}) + in + let rec strip_constraint_unpack ~label pattern = + match pattern with + | {ppat_desc = Ppat_constraint (_, {ptyp_desc = Ptyp_package _})} -> + pattern + | {ppat_desc = Ppat_constraint (pattern, _)} -> + strip_constraint_unpack ~label pattern + | _ -> pattern + in + let safe_pattern_label pattern = + match pattern with + | {ppat_desc = Ppat_var {txt; loc}} -> + {pattern with ppat_desc = Ppat_var {txt = "__" ^ txt; loc}} + | {ppat_desc = Ppat_alias (p, {txt; loc})} -> + {pattern with ppat_desc = Ppat_alias (p, {txt = "__" ^ txt; loc})} + | _ -> pattern + in + let rec returned_expression patterns_with_label patterns_with_nolabel + ({pexp_desc} as expr) = + match pexp_desc with + | Pexp_newtype (_, expr) -> + returned_expression patterns_with_label patterns_with_nolabel expr + | Pexp_constraint (expr, _) -> + returned_expression patterns_with_label patterns_with_nolabel expr + | Pexp_fun + { + lhs = {ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}; + rhs = expr; + } -> + (patterns_with_label, patterns_with_nolabel, expr) + | Pexp_fun + { + arg_label; + default; + lhs = {ppat_loc; ppat_desc} as pattern; + rhs = expr; + } -> ( + let pattern_without_constraint = + strip_constraint_unpack ~label:(get_label arg_label) pattern + in + (* + If prop has the default value as Ident, it will get a build error + when the referenced Ident value and the prop have the same name. + So we add a "__" to label to resolve the build error. + *) + let pattern_with_safe_label = + match default with + | Some _ -> safe_pattern_label pattern_without_constraint + | _ -> pattern_without_constraint + in + if is_labelled arg_label || is_optional arg_label then + returned_expression + ({ + lid = {loc = ppat_loc; txt = Lident (get_label arg_label)}; + x = + { + pattern_with_safe_label with + ppat_attributes = pattern.ppat_attributes; + }; + opt = is_optional arg_label; + } + :: patterns_with_label) + patterns_with_nolabel expr + else + (* Special case of nolabel arg "ref" in forwardRef fn *) + (* let make = React.forwardRef(ref => body) *) + match ppat_desc with + | Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) + -> + returned_expression patterns_with_label + (( {loc = ppat_loc; txt = Lident txt}, + {pattern with ppat_attributes = pattern.ppat_attributes}, + true ) + :: patterns_with_nolabel) + expr + | _ -> + returned_expression patterns_with_label patterns_with_nolabel expr) + | _ -> (patterns_with_label, patterns_with_nolabel, expr) + in + let patterns_with_label, patterns_with_nolabel, expression = + returned_expression [] [] expression + in + (* add pattern matching for optional prop value *) + let expression = + if has_default_value named_arg_list then + vb_match_expr named_arg_list expression + else expression + in + let expression = constrain_jsx_return expression in + (* (ref) => expr *) + let expression = + List.fold_left + (fun expr (_, pattern, _opt) -> + let pattern = + match pattern.ppat_desc with + | Ppat_var {txt} when txt = "ref" -> + Pat.constraint_ pattern (ref_type Location.none) + | _ -> pattern + in + Exp.fun_ ~arity:None Nolabel None pattern expr) + expression patterns_with_nolabel + in + (* ({a, b, _}: props<'a, 'b>) *) + let record_pattern = + match patterns_with_label with + | [] -> Pat.any () + | _ -> Pat.record (List.rev patterns_with_label) Open + in + let expression = + (* Shape internal implementation to match wrapper: uncurried when using forwardRef. *) + let total_arity = if has_forward_ref then 2 else 1 in + Exp.fun_ ~arity:(Some total_arity) ~async:is_async Nolabel None + (Pat.constraint_ record_pattern + (Typ.constr ~loc:empty_loc + {txt = Lident "props"; loc = empty_loc} + (match core_type_of_attr with + | None -> + make_props_type_params ~strip_explicit_option:true + ~strip_explicit_js_nullable_of_ref:has_forward_ref + named_type_list + | Some _ -> ( + match typ_vars_of_core_type with + | [] -> [] + | _ -> [Typ.any ()])))) + expression + in + let expression = + (* Add new tupes (type a,b,c) to make's definition *) + newtypes + |> List.fold_left (fun e newtype -> Exp.newtype newtype e) expression + in + (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) + let binding, new_binding = + match rec_flag with + | Recursive -> + ( binding_wrapper + (Exp.let_ ~loc:empty_loc Nonrecursive + [make_new_binding binding expression internal_fn_name] + (Exp.let_ ~loc:empty_loc Nonrecursive + [ + Vb.mk + (Pat.var {loc = empty_loc; txt = fn_name}) + full_expression; + ] + (Exp.ident {loc = empty_loc; txt = Lident fn_name}))), + None ) + | Nonrecursive -> + ( { + binding with + pvb_expr = expression; + pvb_pat = Pat.var {txt = fn_name; loc = Location.none}; + }, + Some (binding_wrapper full_expression) ) + in + (Some props_record_type, binding, new_binding)) + else if Jsx_common.has_attr_on_binding Jsx_common.has_attr_with_props binding + then + let modified_binding = + { + binding with + pvb_attributes = binding.pvb_attributes |> List.filter other_attrs_pure; + } + in + let fn_name = get_fn_name modified_binding.pvb_pat in + let internal_fn_name = fn_name ^ "$Internal" in + let full_module_name = + make_module_name file_name config.nested_modules fn_name + in + + let is_async = + Ast_async.dig_async_payload_from_function modified_binding.pvb_expr + in + + let make_new_binding ~loc ~full_module_name binding = + let props_pattern = + match binding.pvb_expr with + | { + pexp_desc = + Pexp_apply {funct = wrapper_expr; args = [(Nolabel, func_expr)]}; + } + when is_forward_ref wrapper_expr -> + (* Case when using React.forwardRef *) + let rec check_invalid_forward_ref expr = + match expr.pexp_desc with + | Pexp_fun {arg_label = Labelled _ | Optional _} -> + Location.raise_errorf ~loc:expr.pexp_loc + "Components using React.forwardRef cannot use \ + @react.componentWithProps. Use @react.component instead." + | Pexp_fun {arg_label = Nolabel; rhs = body} -> + check_invalid_forward_ref body + | _ -> () + in + check_invalid_forward_ref func_expr; + Pat.var {txt = "props"; loc} + | {pexp_desc = Pexp_fun {lhs = {ppat_desc = Ppat_constraint (_, typ)}}} + -> ( + match typ with + | {ptyp_desc = Ptyp_constr ({txt = Lident "props"}, args)} -> + (* props<_> *) + if List.length args > 0 then + Pat.constraint_ + (Pat.var {txt = "props"; loc}) + (Typ.constr {txt = Lident "props"; loc} [Typ.any ()]) + (* props *) + else + Pat.constraint_ + (Pat.var {txt = "props"; loc}) + (Typ.constr {txt = Lident "props"; loc} []) + | _ -> Pat.var {txt = "props"; loc}) + | _ -> Pat.var {txt = "props"; loc} + in + + let applied_expression = + Exp.apply + (Exp.ident + { + txt = + Lident + (match rec_flag with + | Recursive -> internal_fn_name + | Nonrecursive -> fn_name); + loc; + }) + [(Nolabel, Exp.ident {txt = Lident "props"; loc})] + in + let applied_expression = + Jsx_common.async_component ~async:is_async applied_expression + in + let applied_expression = constrain_jsx_return applied_expression in + let wrapper_expr = + Exp.fun_ ~arity:(Some 1) Nolabel None props_pattern + ~attrs:binding.pvb_expr.pexp_attributes applied_expression + in + let internal_expression = + Exp.let_ Nonrecursive + [Vb.mk (Pat.var {txt = full_module_name; loc}) wrapper_expr] + (Exp.ident {txt = Lident full_module_name; loc}) + in + + Vb.mk ~attrs:modified_binding.pvb_attributes + (Pat.var {txt = fn_name; loc}) + internal_expression + in + + let new_binding = + match rec_flag with + | Recursive -> None + | Nonrecursive -> + Some + (make_new_binding ~loc:empty_loc ~full_module_name modified_binding) + in + let binding_expr = + { + binding.pvb_expr with + (* moved to wrapper_expr *) + pexp_attributes = []; + } + in + ( None, + { + binding with + pvb_attributes = binding.pvb_attributes |> List.filter other_attrs_pure; + pvb_expr = binding_expr |> constrain_jsx_return; + }, + new_binding ) + else (None, binding, None) + +let rec collect_prop_types types {ptyp_loc; ptyp_desc} = + match ptyp_desc with + | Ptyp_arrow {arg; ret = {ptyp_desc = Ptyp_arrow _} as rest} + when is_labelled arg.lbl || is_optional arg.lbl -> + collect_prop_types ((arg.lbl, arg.attrs, ptyp_loc, arg.typ) :: types) rest + | Ptyp_arrow {arg = {lbl = Nolabel}; ret} -> collect_prop_types types ret + | Ptyp_arrow {arg; ret = return_value} + when is_labelled arg.lbl || is_optional arg.lbl -> + (arg.lbl, arg.attrs, return_value.ptyp_loc, arg.typ) :: types + | _ -> types + +let transform_structure_item ~config item = + match item with + (* external *) + | { + pstr_loc; + pstr_desc = + Pstr_primitive ({pval_attributes; pval_type} as value_description); + } as pstr -> ( + match + ( List.filter Jsx_common.has_attr pval_attributes, + List.filter Jsx_common.has_attr_with_props pval_attributes ) + with + | [], [] -> [item] + | _, [_] -> + Jsx_common.raise_error ~loc:pstr_loc + "Components cannot be defined as externals when using \ + @react.componentWithProps.\n\n\ + If you intended to define an external for a React component using a \ + props type,\n\ + use the type React.component instead.\n\ + Alternatively, use @react.component for an external definition with \ + labeled arguments." + | [_], [] -> + check_multiple_components ~config ~loc:pstr_loc; + check_string_int_attribute_iter.structure_item + check_string_int_attribute_iter item; + let core_type_of_attr = Jsx_common.core_type_of_attrs pval_attributes in + let typ_vars_of_core_type = + core_type_of_attr + |> Option.map Jsx_common.typ_vars_of_core_type + |> Option.value ~default:[] + in + let prop_types = collect_prop_types [] pval_type in + let named_type_list = List.fold_left arg_to_concrete_type [] prop_types in + let ret_props_type = + Typ.constr ~loc:pstr_loc + (Location.mkloc (Lident "props") pstr_loc) + (match core_type_of_attr with + | None -> make_props_type_params named_type_list + | Some _ -> ( + match typ_vars_of_core_type with + | [] -> [] + | _ -> [Typ.any ()])) + in + (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) + let props_record_type = + make_props_record_type ~core_type_of_attr ~external_:true + ~typ_vars_of_core_type "props" pstr_loc named_type_list + in + (* can't be an arrow because it will defensively uncurry *) + let new_external_type = + Ptyp_constr + ( {loc = pstr_loc; txt = module_access_name config "component"}, + [ret_props_type] ) + in + let new_structure = + { + pstr with + pstr_desc = + Pstr_primitive + { + value_description with + pval_type = {pval_type with ptyp_desc = new_external_type}; + pval_attributes = List.filter other_attrs_pure pval_attributes; + }; + } + in + [props_record_type; new_structure] + | _ -> + Jsx_common.raise_error ~loc:pstr_loc + "Only one JSX component call can exist on a component at one time") + (* let component = ... *) + | {pstr_loc; pstr_desc = Pstr_value (rec_flag, value_bindings)} -> ( + let file_name = filename_from_loc pstr_loc in + let empty_loc = Location.in_file file_name in + let process_binding binding (new_items, bindings, new_bindings) = + let new_item, binding, new_binding = + map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding + in + let new_items = + match new_item with + | Some item -> item :: new_items + | None -> new_items + in + let new_bindings = + match new_binding with + | Some new_binding -> new_binding :: new_bindings + | None -> new_bindings + in + (new_items, binding :: bindings, new_bindings) + in + let new_items, bindings, new_bindings = + List.fold_right process_binding value_bindings ([], [], []) + in + new_items + @ [{pstr_loc; pstr_desc = Pstr_value (rec_flag, bindings)}] + @ + match new_bindings with + | [] -> [] + | new_bindings -> + [{pstr_loc = empty_loc; pstr_desc = Pstr_value (rec_flag, new_bindings)}]) + | _ -> [item] + +let transform_signature_item ~config item = + match item with + | { + psig_loc; + psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); + } as psig -> ( + match List.filter Jsx_common.has_attr pval_attributes with + | [] -> [item] + | [_] -> + check_multiple_components ~config ~loc:psig_loc; + check_string_int_attribute_iter.signature_item + check_string_int_attribute_iter item; + let core_type_of_attr = Jsx_common.core_type_of_attrs pval_attributes in + let typ_vars_of_core_type = + core_type_of_attr + |> Option.map Jsx_common.typ_vars_of_core_type + |> Option.value ~default:[] + in + let prop_types = collect_prop_types [] pval_type in + let named_type_list = List.fold_left arg_to_concrete_type [] prop_types in + let ret_props_type = + Typ.constr + (Location.mkloc (Lident "props") psig_loc) + (match core_type_of_attr with + | None -> make_props_type_params named_type_list + | Some _ -> ( + match typ_vars_of_core_type with + | [] -> [] + | _ -> [Typ.any ()])) + in + let external_ = psig_desc.pval_prim <> [] in + let props_record_type = + make_props_record_type_sig ~core_type_of_attr ~external_ + ~typ_vars_of_core_type "props" psig_loc named_type_list + in + (* can't be an arrow because it will defensively uncurry *) + let new_external_type = + Ptyp_constr + ( {loc = psig_loc; txt = module_access_name config "component"}, + [ret_props_type] ) + in + let new_structure = + { + psig with + psig_desc = + Psig_value + { + psig_desc with + pval_type = {pval_type with ptyp_desc = new_external_type}; + pval_attributes = List.filter other_attrs_pure pval_attributes; + }; + } + in + [props_record_type; new_structure] + | _ -> + Jsx_common.raise_error ~loc:psig_loc + "Only one JSX component call can exist on a component at one time") + | _ -> [item] + +(* There appear to be slightly different rules of transformation whether the component is upper-, lowercase or a fragment *) +type componentDescription = + | LowercasedComponent + | UppercasedComponent + | FragmentComponent + +let loc_from_prop = function + | JSXPropPunning (_, name) -> name.loc + | JSXPropValue (name, _, value) -> + {name.loc with loc_end = value.pexp_loc.loc_end} + | JSXPropSpreading (loc, _) -> loc + +let mk_record_from_props mapper (jsx_expr_loc : Location.t) (props : jsx_props) + : expression = + (* Create an artificial range from the first till the last prop *) + let loc = + match props with + | [] -> jsx_expr_loc + | head :: tail -> + let rec visit props = + match props with + | [] -> head + | [last] -> last + | _ :: rest -> visit rest + in + let first_item = head |> loc_from_prop in + let last_item = visit tail |> loc_from_prop in + { + loc_start = first_item.loc_start; + loc_end = last_item.loc_end; + loc_ghost = false; + } + in + (* key should be filtered out *) + let props = + props + |> List.filter (function + | JSXPropPunning (_, {txt = "key"}) | JSXPropValue ({txt = "key"}, _, _) + -> + false + | _ -> true) + in + let props, spread_props = + match props with + | JSXPropSpreading (_, expr) :: rest -> + (rest, Some (mapper.expr mapper expr)) + | _ -> (props, None) + in + + let record_fields = + props + |> List.map (function + | JSXPropPunning (is_optional, name) -> + { + lid = {txt = Lident name.txt; loc = name.loc}; + x = Exp.ident ~loc:name.loc {txt = Lident name.txt; loc = name.loc}; + opt = is_optional; + } + | JSXPropValue (name, is_optional, value) -> + { + lid = {txt = Lident name.txt; loc = name.loc}; + x = mapper.expr mapper value; + opt = is_optional; + } + | JSXPropSpreading (loc, _) -> + (* There can only be one spread expression and it is expected to be the first prop *) + Jsx_common.raise_error ~loc + "JSX: use {...p} {x: v} not {x: v} {...p} \n\ + \ multiple spreads {...p} {...p} not allowed.") + in + match (record_fields, spread_props) with + | [], Some spread_props -> + {pexp_desc = spread_props.pexp_desc; pexp_loc = loc; pexp_attributes = []} + | record_fields, spread_props -> + { + pexp_desc = Pexp_record (record_fields, spread_props); + pexp_loc = loc; + pexp_attributes = []; + } + +let try_find_key_prop (props : jsx_props) : (arg_label * expression) option = + props + |> List.find_map (function + | JSXPropPunning (is_optional, ({txt = "key"} as name)) -> + let arg_label = if is_optional then Optional name else Labelled name in + Some (arg_label, Exp.ident {txt = Lident "key"; loc = name.loc}) + | JSXPropValue (({txt = "key"} as name), is_optional, expr) -> + let arg_label = if is_optional then Optional name else Labelled name in + Some (arg_label, expr) + | _ -> None) + +let append_children_prop (config : Jsx_common.jsx_config) mapper + (component_description : componentDescription) (props : jsx_props) + (children : jsx_children) : jsx_props = + match children with + | [] -> props + | [child] -> + let expr = + (* I don't quite know why fragment and uppercase don't do this additional ReactDOM.someElement wrapping *) + match component_description with + | FragmentComponent | UppercasedComponent -> mapper.expr mapper child + | LowercasedComponent -> + let element_binding = + match config.module_ |> String.lowercase_ascii with + | "react" -> Lident "ReactDOM" + | _generic -> module_access_name config "Elements" + in + Exp.apply + (Exp.ident + {txt = Ldot (element_binding, "someElement"); loc = Location.none}) + [(Nolabel, mapper.expr mapper child)] + in + let is_optional = + match component_description with + | LowercasedComponent -> true + | FragmentComponent | UppercasedComponent -> false + in + props + @ [ + JSXPropValue + ({txt = "children"; loc = child.pexp_loc}, is_optional, expr); + ] + | head :: _ as xs -> + let loc = + match List.rev xs with + | [] -> head.pexp_loc + | lastChild :: _ -> + {head.pexp_loc with loc_end = lastChild.pexp_loc.loc_end} + in + (* this is a hack to support react components that introspect into their children *) + props + @ [ + JSXPropValue + ( {txt = "children"; loc}, + false, + Exp.apply ~loc + (Exp.ident {txt = module_access_name config "array"; loc}) + [(Nolabel, Exp.array (List.map (mapper.expr mapper) xs))] ); + ] + +let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs + (component_description : componentDescription) (elementTag : expression) + (props : jsx_props) (children : jsx_children) : expression = + let more_than_one_children = List.length children > 1 in + let props_with_children = + append_children_prop config mapper component_description props children + in + let props_record = mk_record_from_props mapper loc props_with_children in + let jsx_expr, key_and_unit = + let mk_element_bind (jsx_part : string) : Longident.t = + match component_description with + | FragmentComponent | UppercasedComponent -> + module_access_name config jsx_part + | LowercasedComponent -> + let element_binding = + match config.module_ |> String.lowercase_ascii with + | "react" -> Lident "ReactDOM" + | _generic -> module_access_name config "Elements" + in + Ldot (element_binding, jsx_part) + in + match try_find_key_prop props with + | None -> + ( Exp.ident + { + loc = Location.none; + txt = + mk_element_bind (if more_than_one_children then "jsxs" else "jsx"); + }, + [] ) + | Some key_prop -> + ( Exp.ident + { + loc = Location.none; + txt = + mk_element_bind + (if more_than_one_children then "jsxsKeyed" else "jsxKeyed"); + }, + [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) + in + let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in + Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args + +(* In most situations, the component name is the make function from a module. + However, if the name contains a lowercase letter, it means it probably an external component. + In this case, we use the name as is. + See tests/syntax_tests/data/ppx/react/externalWithCustomName.res +*) +let mk_uppercase_tag_name_expr tag_name = + let tag_identifier : Longident.t = + match tag_name.txt with + | JsxTagInvalid _ | JsxLowerTag _ -> + failwith "Unreachable code at mk_uppercase_tag_name_expr" + | JsxQualifiedLowerTag {path; name} -> Longident.Ldot (path, name) + | JsxUpperTag path -> Longident.Ldot (path, "make") + in + let loc = tag_name.loc in + Exp.ident ~loc {txt = tag_identifier; loc} + +let expr ~(config : Jsx_common.jsx_config) mapper expression = + match expression with + | { + pexp_desc = Pexp_jsx_element jsx_element; + pexp_loc = loc; + pexp_attributes = attrs; + } -> ( + match jsx_element with + | Jsx_fragment {jsx_fragment_children = children} -> + let fragment = + Exp.ident ~loc {loc; txt = module_access_name config "jsxFragment"} + in + mk_react_jsx config mapper loc attrs FragmentComponent fragment [] + children + | Jsx_unary_element + {jsx_unary_element_tag_name = tag_name; jsx_unary_element_props = props} + -> ( + let name = Ast_helper.Jsx.string_of_jsx_tag_name tag_name.txt in + let tag_loc = tag_name.loc in + match tag_name.txt with + | JsxLowerTag _ -> + (* For example 'input' *) + let component_name_expr = constant_string ~loc:tag_loc name in + mk_react_jsx config mapper loc attrs LowercasedComponent + component_name_expr props [] + | JsxUpperTag _ | JsxQualifiedLowerTag _ -> + (* MyModule.make *) + let make_id = mk_uppercase_tag_name_expr tag_name in + mk_react_jsx config mapper loc attrs UppercasedComponent make_id props + [] + | JsxTagInvalid name -> + Jsx_common.raise_error ~loc + "JSX: element name is neither upper- or lowercase, got \"%s\"" name) + | Jsx_container_element + { + jsx_container_element_tag_name_start = tag_name; + jsx_container_element_props = props; + jsx_container_element_children = children; + } -> ( + let name, tag_loc = + (Ast_helper.Jsx.string_of_jsx_tag_name tag_name.txt, tag_name.loc) + in + (* For example:


+ This has an impact if we want to use ReactDOM.jsx or ReactDOM.jsxs + *) + match tag_name.txt with + | JsxLowerTag _ -> + let component_name_expr = constant_string ~loc:tag_loc name in + mk_react_jsx config mapper loc attrs LowercasedComponent + component_name_expr props children + | JsxQualifiedLowerTag _ | JsxUpperTag _ -> + (* MyModule.make *) + let make_id = mk_uppercase_tag_name_expr tag_name in + mk_react_jsx config mapper loc attrs UppercasedComponent make_id props + children + | JsxTagInvalid name -> + Jsx_common.raise_error ~loc + "JSX: element name is neither upper- or lowercase, got \"%s\"" name)) + | e -> default_mapper.expr mapper e + +let module_binding ~(config : Jsx_common.jsx_config) mapper module_binding = + config.nested_modules <- module_binding.pmb_name.txt :: config.nested_modules; + let mapped = default_mapper.module_binding mapper module_binding in + let () = + match config.nested_modules with + | _ :: rest -> config.nested_modules <- rest + | [] -> () + in + mapped + +(* TODO: some line number might still be wrong *) +let jsx_mapper ~config = + let expr = expr ~config in + let module_binding = module_binding ~config in + let transform_structure_item = transform_structure_item ~config in + let transform_signature_item = transform_signature_item ~config in + (expr, module_binding, transform_signature_item, transform_structure_item) diff --git a/compiler/syntax/src/jsx_v4.mli b/compiler/syntax/src/jsx_v4.mli new file mode 100644 index 0000000..b582340 --- /dev/null +++ b/compiler/syntax/src/jsx_v4.mli @@ -0,0 +1,8 @@ +open Parsetree + +val jsx_mapper : + config:Jsx_common.jsx_config -> + (Ast_mapper.mapper -> expression -> expression) + * (Ast_mapper.mapper -> module_binding -> module_binding) + * (signature_item -> signature_item list) + * (structure_item -> structure_item list) diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml new file mode 100644 index 0000000..52a57b8 --- /dev/null +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -0,0 +1,972 @@ +module Doc = Res_doc +module CommentTable = Res_comments_table + +let print_engine = + Res_driver. + { + print_implementation = + (fun ~width:_ ~filename:_ ~comments:_ structure -> + Printast.implementation Format.std_formatter structure); + print_interface = + (fun ~width:_ ~filename:_ ~comments:_ signature -> + Printast.interface Format.std_formatter signature); + } + +module Sexp : sig + type t + + val atom : string -> t + val list : t list -> t + val to_string : t -> string +end = struct + type t = Atom of string | List of t list + + let atom s = Atom s + let list l = List l + + let rec to_doc t = + match t with + | Atom s -> Doc.text s + | List [] -> Doc.text "()" + | List [sexpr] -> Doc.concat [Doc.lparen; to_doc sexpr; Doc.rparen] + | List (hd :: tail) -> + Doc.group + (Doc.concat + [ + Doc.lparen; + to_doc hd; + Doc.indent + (Doc.concat + [Doc.line; Doc.join ~sep:Doc.line (List.map to_doc tail)]); + Doc.rparen; + ]) + + let to_string sexpr = + let doc = to_doc sexpr in + Doc.to_string ~width:80 doc +end + +module SexpAst = struct + open Parsetree + + let map_empty ~f items = + match items with + | [] -> [Sexp.list []] + | items -> List.map f items + + let string txt = + Sexp.atom ("\"" ^ Ext_ident.unwrap_uppercase_exotic txt ^ "\"") + + let char c = Sexp.atom ("'" ^ Char.escaped c ^ "'") + + let opt_char oc = + match oc with + | None -> Sexp.atom "None" + | Some c -> Sexp.list [Sexp.atom "Some"; char c] + + let longident l = + let rec loop l = + match l with + | Longident.Lident ident -> Sexp.list [Sexp.atom "Lident"; string ident] + | Longident.Ldot (lident, txt) -> + Sexp.list [Sexp.atom "Ldot"; loop lident; string txt] + | Longident.Lapply (l1, l2) -> + Sexp.list [Sexp.atom "Lapply"; loop l1; loop l2] + in + Sexp.list [Sexp.atom "longident"; loop l] + + let closed_flag flag = + match flag with + | Asttypes.Closed -> Sexp.atom "Closed" + | Open -> Sexp.atom "Open" + + let direction_flag flag = + match flag with + | Asttypes.Upto -> Sexp.atom "Upto" + | Downto -> Sexp.atom "Downto" + + let rec_flag flag = + match flag with + | Asttypes.Recursive -> Sexp.atom "Recursive" + | Nonrecursive -> Sexp.atom "Nonrecursive" + + let override_flag flag = + match flag with + | Asttypes.Override -> Sexp.atom "Override" + | Fresh -> Sexp.atom "Fresh" + + let private_flag flag = + match flag with + | Asttypes.Public -> Sexp.atom "Public" + | Private -> Sexp.atom "Private" + + let mutable_flag flag = + match flag with + | Asttypes.Immutable -> Sexp.atom "Immutable" + | Mutable -> Sexp.atom "Mutable" + + let variance v = + match v with + | Asttypes.Covariant -> Sexp.atom "Covariant" + | Contravariant -> Sexp.atom "Contravariant" + | Invariant -> Sexp.atom "Invariant" + + let arg_label_loc lbl = + match lbl with + | Asttypes.Nolabel -> Sexp.atom "Nolabel" + | Labelled {txt} -> Sexp.list [Sexp.atom "Labelled"; string txt] + | Optional {txt} -> Sexp.list [Sexp.atom "Optional"; string txt] + + let constant c = + let sexpr = + match c with + | Pconst_integer (txt, tag) -> + Sexp.list [Sexp.atom "Pconst_integer"; string txt; opt_char tag] + | Pconst_char _ -> Sexp.list [Sexp.atom "Pconst_char"] + | Pconst_string (_, Some "INTERNAL_RES_CHAR_CONTENTS") -> + Sexp.list [Sexp.atom "Pconst_char"] + | Pconst_string (txt, tag) -> + Sexp.list + [ + Sexp.atom "Pconst_string"; + string txt; + (match tag with + | Some txt -> Sexp.list [Sexp.atom "Some"; string txt] + | None -> Sexp.atom "None"); + ] + | Pconst_float (txt, tag) -> + Sexp.list [Sexp.atom "Pconst_float"; string txt; opt_char tag] + in + Sexp.list [Sexp.atom "constant"; sexpr] + + let rec structure s = + Sexp.list (Sexp.atom "structure" :: List.map structure_item s) + + and structure_item si = + let desc = + match si.pstr_desc with + | Pstr_eval (expr, attrs) -> + Sexp.list [Sexp.atom "Pstr_eval"; expression expr; attributes attrs] + | Pstr_value (flag, vbs) -> + Sexp.list + [ + Sexp.atom "Pstr_value"; + rec_flag flag; + Sexp.list (map_empty ~f:value_binding vbs); + ] + | Pstr_primitive vd -> + Sexp.list [Sexp.atom "Pstr_primitive"; value_description vd] + | Pstr_type (flag, tds) -> + Sexp.list + [ + Sexp.atom "Pstr_type"; + rec_flag flag; + Sexp.list (map_empty ~f:type_declaration tds); + ] + | Pstr_typext typext -> + Sexp.list [Sexp.atom "Pstr_type"; type_extension typext] + | Pstr_exception ec -> + Sexp.list [Sexp.atom "Pstr_exception"; extension_constructor ec] + | Pstr_module mb -> Sexp.list [Sexp.atom "Pstr_module"; module_binding mb] + | Pstr_recmodule mbs -> + Sexp.list + [ + Sexp.atom "Pstr_recmodule"; + Sexp.list (map_empty ~f:module_binding mbs); + ] + | Pstr_modtype mod_typ_decl -> + Sexp.list + [Sexp.atom "Pstr_modtype"; module_type_declaration mod_typ_decl] + | Pstr_open open_desc -> + Sexp.list [Sexp.atom "Pstr_open"; open_description open_desc] + | Pstr_include id -> + Sexp.list [Sexp.atom "Pstr_include"; include_declaration id] + | Pstr_attribute attr -> + Sexp.list [Sexp.atom "Pstr_attribute"; attribute attr] + | Pstr_extension (ext, attrs) -> + Sexp.list [Sexp.atom "Pstr_extension"; extension ext; attributes attrs] + in + Sexp.list [Sexp.atom "structure_item"; desc] + + and include_declaration id = + Sexp.list + [ + Sexp.atom "include_declaration"; + module_expression id.pincl_mod; + attributes id.pincl_attributes; + ] + + and open_description od = + Sexp.list + [ + Sexp.atom "open_description"; + longident od.popen_lid.Asttypes.txt; + attributes od.popen_attributes; + ] + + and module_type_declaration mtd = + Sexp.list + [ + Sexp.atom "module_type_declaration"; + string mtd.pmtd_name.Asttypes.txt; + (match mtd.pmtd_type with + | None -> Sexp.atom "None" + | Some mod_type -> Sexp.list [Sexp.atom "Some"; module_type mod_type]); + attributes mtd.pmtd_attributes; + ] + + and module_binding mb = + Sexp.list + [ + Sexp.atom "module_binding"; + string mb.pmb_name.Asttypes.txt; + module_expression mb.pmb_expr; + attributes mb.pmb_attributes; + ] + + and module_expression me = + let desc = + match me.pmod_desc with + | Pmod_ident mod_name -> + Sexp.list [Sexp.atom "Pmod_ident"; longident mod_name.Asttypes.txt] + | Pmod_structure s -> Sexp.list [Sexp.atom "Pmod_structure"; structure s] + | Pmod_functor (lbl, opt_mod_type, mod_expr) -> + Sexp.list + [ + Sexp.atom "Pmod_functor"; + string lbl.Asttypes.txt; + (match opt_mod_type with + | None -> Sexp.atom "None" + | Some mod_type -> + Sexp.list [Sexp.atom "Some"; module_type mod_type]); + module_expression mod_expr; + ] + | Pmod_apply (call_mod_expr, mod_expr_arg) -> + Sexp.list + [ + Sexp.atom "Pmod_apply"; + module_expression call_mod_expr; + module_expression mod_expr_arg; + ] + | Pmod_constraint (mod_expr, mod_type) -> + Sexp.list + [ + Sexp.atom "Pmod_constraint"; + module_expression mod_expr; + module_type mod_type; + ] + | Pmod_unpack expr -> Sexp.list [Sexp.atom "Pmod_unpack"; expression expr] + | Pmod_extension ext -> + Sexp.list [Sexp.atom "Pmod_extension"; extension ext] + in + Sexp.list [Sexp.atom "module_expr"; desc; attributes me.pmod_attributes] + + and module_type mt = + let desc = + match mt.pmty_desc with + | Pmty_ident longident_loc -> + Sexp.list [Sexp.atom "Pmty_ident"; longident longident_loc.Asttypes.txt] + | Pmty_signature s -> Sexp.list [Sexp.atom "Pmty_signature"; signature s] + | Pmty_functor (lbl, opt_mod_type, mod_type) -> + Sexp.list + [ + Sexp.atom "Pmty_functor"; + string lbl.Asttypes.txt; + (match opt_mod_type with + | None -> Sexp.atom "None" + | Some mod_type -> + Sexp.list [Sexp.atom "Some"; module_type mod_type]); + module_type mod_type; + ] + | Pmty_alias longident_loc -> + Sexp.list [Sexp.atom "Pmty_alias"; longident longident_loc.Asttypes.txt] + | Pmty_extension ext -> + Sexp.list [Sexp.atom "Pmty_extension"; extension ext] + | Pmty_typeof mod_expr -> + Sexp.list [Sexp.atom "Pmty_typeof"; module_expression mod_expr] + | Pmty_with (mod_type, with_constraints) -> + Sexp.list + [ + Sexp.atom "Pmty_with"; + module_type mod_type; + Sexp.list (map_empty ~f:with_constraint with_constraints); + ] + in + Sexp.list [Sexp.atom "module_type"; desc; attributes mt.pmty_attributes] + + and with_constraint wc = + match wc with + | Pwith_type (longident_loc, td) -> + Sexp.list + [ + Sexp.atom "Pmty_with"; + longident longident_loc.Asttypes.txt; + type_declaration td; + ] + | Pwith_module (l1, l2) -> + Sexp.list + [ + Sexp.atom "Pwith_module"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] + | Pwith_typesubst (longident_loc, td) -> + Sexp.list + [ + Sexp.atom "Pwith_typesubst"; + longident longident_loc.Asttypes.txt; + type_declaration td; + ] + | Pwith_modsubst (l1, l2) -> + Sexp.list + [ + Sexp.atom "Pwith_modsubst"; + longident l1.Asttypes.txt; + longident l2.Asttypes.txt; + ] + + and signature s = + Sexp.list (Sexp.atom "signature" :: List.map signature_item s) + + and signature_item si = + let descr = + match si.psig_desc with + | Psig_value vd -> + Sexp.list [Sexp.atom "Psig_value"; value_description vd] + | Psig_type (flag, type_declarations) -> + Sexp.list + [ + Sexp.atom "Psig_type"; + rec_flag flag; + Sexp.list (map_empty ~f:type_declaration type_declarations); + ] + | Psig_typext typ_ext -> + Sexp.list [Sexp.atom "Psig_typext"; type_extension typ_ext] + | Psig_exception ext_constr -> + Sexp.list [Sexp.atom "Psig_exception"; extension_constructor ext_constr] + | Psig_module mod_decl -> + Sexp.list [Sexp.atom "Psig_module"; module_declaration mod_decl] + | Psig_recmodule mod_decls -> + Sexp.list + [ + Sexp.atom "Psig_recmodule"; + Sexp.list (map_empty ~f:module_declaration mod_decls); + ] + | Psig_modtype mod_typ_decl -> + Sexp.list + [Sexp.atom "Psig_modtype"; module_type_declaration mod_typ_decl] + | Psig_open open_desc -> + Sexp.list [Sexp.atom "Psig_open"; open_description open_desc] + | Psig_include incl_decl -> + Sexp.list [Sexp.atom "Psig_include"; include_description incl_decl] + | Psig_attribute attr -> + Sexp.list [Sexp.atom "Psig_attribute"; attribute attr] + | Psig_extension (ext, attrs) -> + Sexp.list [Sexp.atom "Psig_extension"; extension ext; attributes attrs] + in + Sexp.list [Sexp.atom "signature_item"; descr] + + and include_description id = + Sexp.list + [ + Sexp.atom "include_description"; + module_type id.pincl_mod; + attributes id.pincl_attributes; + ] + + and module_declaration md = + Sexp.list + [ + Sexp.atom "module_declaration"; + string md.pmd_name.Asttypes.txt; + module_type md.pmd_type; + attributes md.pmd_attributes; + ] + + and value_binding vb = + Sexp.list + [ + Sexp.atom "value_binding"; + pattern vb.pvb_pat; + expression vb.pvb_expr; + attributes vb.pvb_attributes; + ] + + and value_description vd = + Sexp.list + [ + Sexp.atom "value_description"; + string vd.pval_name.Asttypes.txt; + core_type vd.pval_type; + Sexp.list (map_empty ~f:string vd.pval_prim); + attributes vd.pval_attributes; + ] + + and type_declaration td = + Sexp.list + [ + Sexp.atom "type_declaration"; + string td.ptype_name.Asttypes.txt; + Sexp.list + [ + Sexp.atom "ptype_params"; + Sexp.list + (map_empty + ~f:(fun (typexpr, var) -> + Sexp.list [core_type typexpr; variance var]) + td.ptype_params); + ]; + Sexp.list + [ + Sexp.atom "ptype_cstrs"; + Sexp.list + (map_empty + ~f:(fun (typ1, typ2, _loc) -> + Sexp.list [core_type typ1; core_type typ2]) + td.ptype_cstrs); + ]; + Sexp.list [Sexp.atom "ptype_kind"; type_kind td.ptype_kind]; + Sexp.list + [ + Sexp.atom "ptype_manifest"; + (match td.ptype_manifest with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); + ]; + Sexp.list [Sexp.atom "ptype_private"; private_flag td.ptype_private]; + attributes td.ptype_attributes; + ] + + and extension_constructor ec = + Sexp.list + [ + Sexp.atom "extension_constructor"; + string ec.pext_name.Asttypes.txt; + extension_constructor_kind ec.pext_kind; + attributes ec.pext_attributes; + ] + + and extension_constructor_kind kind = + match kind with + | Pext_decl (args, opt_typ_expr) -> + Sexp.list + [ + Sexp.atom "Pext_decl"; + constructor_arguments args; + (match opt_typ_expr with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); + ] + | Pext_rebind longident_loc -> + Sexp.list [Sexp.atom "Pext_rebind"; longident longident_loc.Asttypes.txt] + + and type_extension te = + Sexp.list + [ + Sexp.atom "type_extension"; + Sexp.list + [Sexp.atom "ptyext_path"; longident te.ptyext_path.Asttypes.txt]; + Sexp.list + [ + Sexp.atom "ptyext_parms"; + Sexp.list + (map_empty + ~f:(fun (typexpr, var) -> + Sexp.list [core_type typexpr; variance var]) + te.ptyext_params); + ]; + Sexp.list + [ + Sexp.atom "ptyext_constructors"; + Sexp.list + (map_empty ~f:extension_constructor te.ptyext_constructors); + ]; + Sexp.list [Sexp.atom "ptyext_private"; private_flag te.ptyext_private]; + attributes te.ptyext_attributes; + ] + + and type_kind kind = + match kind with + | Ptype_abstract -> Sexp.atom "Ptype_abstract" + | Ptype_variant constr_decls -> + Sexp.list + [ + Sexp.atom "Ptype_variant"; + Sexp.list (map_empty ~f:constructor_declaration constr_decls); + ] + | Ptype_record lbl_decls -> + Sexp.list + [ + Sexp.atom "Ptype_record"; + Sexp.list (map_empty ~f:label_declaration lbl_decls); + ] + | Ptype_open -> Sexp.atom "Ptype_open" + + and constructor_declaration cd = + Sexp.list + [ + Sexp.atom "constructor_declaration"; + string cd.pcd_name.Asttypes.txt; + Sexp.list [Sexp.atom "pcd_args"; constructor_arguments cd.pcd_args]; + Sexp.list + [ + Sexp.atom "pcd_res"; + (match cd.pcd_res with + | None -> Sexp.atom "None" + | Some typ -> Sexp.list [Sexp.atom "Some"; core_type typ]); + ]; + attributes cd.pcd_attributes; + ] + + and constructor_arguments args = + match args with + | Pcstr_tuple types -> + Sexp.list + [Sexp.atom "Pcstr_tuple"; Sexp.list (map_empty ~f:core_type types)] + | Pcstr_record lds -> + Sexp.list + [ + Sexp.atom "Pcstr_record"; + Sexp.list (map_empty ~f:label_declaration lds); + ] + + and label_declaration ld = + Sexp.list + [ + Sexp.atom "label_declaration"; + string ld.pld_name.Asttypes.txt; + mutable_flag ld.pld_mutable; + core_type ld.pld_type; + attributes ld.pld_attributes; + ] + + and expression expr = + let desc = + match expr.pexp_desc with + | Pexp_ident longident_loc -> + Sexp.list [Sexp.atom "Pexp_ident"; longident longident_loc.Asttypes.txt] + | Pexp_constant c -> Sexp.list [Sexp.atom "Pexp_constant"; constant c] + | Pexp_let (flag, vbs, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_let"; + rec_flag flag; + Sexp.list (map_empty ~f:value_binding vbs); + expression expr; + ] + | Pexp_fun + {arg_label = arg_lbl; default = expr_opt; lhs = pat; rhs = expr} -> + Sexp.list + [ + Sexp.atom "Pexp_fun"; + arg_label_loc arg_lbl; + (match expr_opt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + pattern pat; + expression expr; + ] + | Pexp_apply {funct = expr; args} -> + Sexp.list + [ + Sexp.atom "Pexp_apply"; + expression expr; + Sexp.list + (map_empty + ~f:(fun (arg_lbl, expr) -> + Sexp.list [arg_label_loc arg_lbl; expression expr]) + args); + ] + | Pexp_match (expr, cases) -> + Sexp.list + [ + Sexp.atom "Pexp_match"; + expression expr; + Sexp.list (map_empty ~f:case cases); + ] + | Pexp_try (expr, cases) -> + Sexp.list + [ + Sexp.atom "Pexp_try"; + expression expr; + Sexp.list (map_empty ~f:case cases); + ] + | Pexp_tuple exprs -> + Sexp.list + [Sexp.atom "Pexp_tuple"; Sexp.list (map_empty ~f:expression exprs)] + | Pexp_construct (longident_loc, expr_opt) -> + Sexp.list + [ + Sexp.atom "Pexp_construct"; + longident longident_loc.Asttypes.txt; + (match expr_opt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_variant (lbl, expr_opt) -> + Sexp.list + [ + Sexp.atom "Pexp_variant"; + string lbl; + (match expr_opt with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_record (rows, opt_expr) -> + Sexp.list + [ + Sexp.atom "Pexp_record"; + Sexp.list + (map_empty + ~f:(fun {lid = longident_loc; x = expr} -> + Sexp.list + [longident longident_loc.Asttypes.txt; expression expr]) + rows); + (match opt_expr with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_field (expr, longident_loc) -> + Sexp.list + [ + Sexp.atom "Pexp_field"; + expression expr; + longident longident_loc.Asttypes.txt; + ] + | Pexp_setfield (expr1, longident_loc, expr2) -> + Sexp.list + [ + Sexp.atom "Pexp_setfield"; + expression expr1; + longident longident_loc.Asttypes.txt; + expression expr2; + ] + | Pexp_array exprs -> + Sexp.list + [Sexp.atom "Pexp_array"; Sexp.list (map_empty ~f:expression exprs)] + | Pexp_ifthenelse (expr1, expr2, opt_expr) -> + Sexp.list + [ + Sexp.atom "Pexp_ifthenelse"; + expression expr1; + expression expr2; + (match opt_expr with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ] + | Pexp_sequence (expr1, expr2) -> + Sexp.list + [Sexp.atom "Pexp_sequence"; expression expr1; expression expr2] + | Pexp_while (expr1, expr2) -> + Sexp.list [Sexp.atom "Pexp_while"; expression expr1; expression expr2] + | Pexp_for (pat, e1, e2, flag, e3) -> + Sexp.list + [ + Sexp.atom "Pexp_for"; + pattern pat; + expression e1; + expression e2; + direction_flag flag; + expression e3; + ] + | Pexp_constraint (expr, typexpr) -> + Sexp.list + [Sexp.atom "Pexp_constraint"; expression expr; core_type typexpr] + | Pexp_coerce (expr, (), typexpr) -> + Sexp.list [Sexp.atom "Pexp_coerce"; expression expr; core_type typexpr] + | Pexp_send _ -> Sexp.list [Sexp.atom "Pexp_send"] + | Pexp_letmodule (mod_name, mod_expr, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_letmodule"; + string mod_name.Asttypes.txt; + module_expression mod_expr; + expression expr; + ] + | Pexp_letexception (ext_constr, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_letexception"; + extension_constructor ext_constr; + expression expr; + ] + | Pexp_assert expr -> Sexp.list [Sexp.atom "Pexp_assert"; expression expr] + | Pexp_newtype (lbl, expr) -> + Sexp.list + [Sexp.atom "Pexp_newtype"; string lbl.Asttypes.txt; expression expr] + | Pexp_pack mod_expr -> + Sexp.list [Sexp.atom "Pexp_pack"; module_expression mod_expr] + | Pexp_open (flag, longident_loc, expr) -> + Sexp.list + [ + Sexp.atom "Pexp_open"; + override_flag flag; + longident longident_loc.Asttypes.txt; + expression expr; + ] + | Pexp_extension ext -> + Sexp.list [Sexp.atom "Pexp_extension"; extension ext] + | Pexp_await e -> Sexp.list [Sexp.atom "Pexp_await"; expression e] + | Pexp_jsx_element (Jsx_fragment {jsx_fragment_children = xs}) -> + Sexp.list + [ + Sexp.atom "Pexp_jsx_fragment"; Sexp.list (map_empty ~f:expression xs); + ] + | Pexp_jsx_element (Jsx_unary_element {jsx_unary_element_props = props}) + -> + Sexp.list + [ + Sexp.atom "Pexp_jsx_unary_element"; + Sexp.list (map_empty ~f:jsx_prop props); + ] + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_props = props; + jsx_container_element_children = xs; + }) -> + Sexp.list + [ + Sexp.atom "Pexp_jsx_container_element"; + Sexp.list (map_empty ~f:jsx_prop props); + Sexp.list (map_empty ~f:expression xs); + ] + in + Sexp.list [Sexp.atom "expression"; desc] + + and jsx_prop = function + | JSXPropPunning (_, name) -> Sexp.atom name.txt + | JSXPropValue (name, _, expr) -> + Sexp.list [Sexp.atom name.txt; expression expr] + | JSXPropSpreading (_, expr) -> expression expr + + and case c = + Sexp.list + [ + Sexp.atom "case"; + Sexp.list [Sexp.atom "pc_lhs"; pattern c.pc_lhs]; + Sexp.list + [ + Sexp.atom "pc_guard"; + (match c.pc_guard with + | None -> Sexp.atom "None" + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + ]; + Sexp.list [Sexp.atom "pc_rhs"; expression c.pc_rhs]; + ] + + and pattern p = + let descr = + match p.ppat_desc with + | Ppat_any -> Sexp.atom "Ppat_any" + | Ppat_var var -> + Sexp.list [Sexp.atom "Ppat_var"; string var.Location.txt] + | Ppat_alias (p, alias) -> + Sexp.list [Sexp.atom "Ppat_alias"; pattern p; string alias.txt] + | Ppat_constant c -> Sexp.list [Sexp.atom "Ppat_constant"; constant c] + | Ppat_interval (lo, hi) -> + Sexp.list [Sexp.atom "Ppat_interval"; constant lo; constant hi] + | Ppat_tuple patterns -> + Sexp.list + [Sexp.atom "Ppat_tuple"; Sexp.list (map_empty ~f:pattern patterns)] + | Ppat_construct (longident_loc, opt_pattern) -> + Sexp.list + [ + Sexp.atom "Ppat_construct"; + longident longident_loc.Location.txt; + (match opt_pattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [Sexp.atom "some"; pattern p]); + ] + | Ppat_variant (lbl, opt_pattern) -> + Sexp.list + [ + Sexp.atom "Ppat_variant"; + string lbl; + (match opt_pattern with + | None -> Sexp.atom "None" + | Some p -> Sexp.list [Sexp.atom "Some"; pattern p]); + ] + | Ppat_record (rows, flag) -> + Sexp.list + [ + Sexp.atom "Ppat_record"; + closed_flag flag; + Sexp.list + (map_empty + ~f:(fun {lid = longident_loc; x = p} -> + Sexp.list [longident longident_loc.Location.txt; pattern p]) + rows); + ] + | Ppat_array patterns -> + Sexp.list + [Sexp.atom "Ppat_array"; Sexp.list (map_empty ~f:pattern patterns)] + | Ppat_or (p1, p2) -> + Sexp.list [Sexp.atom "Ppat_or"; pattern p1; pattern p2] + | Ppat_constraint (p, typexpr) -> + Sexp.list [Sexp.atom "Ppat_constraint"; pattern p; core_type typexpr] + | Ppat_type longident_loc -> + Sexp.list [Sexp.atom "Ppat_type"; longident longident_loc.Location.txt] + | Ppat_unpack string_loc -> + Sexp.list [Sexp.atom "Ppat_unpack"; string string_loc.Location.txt] + | Ppat_exception p -> Sexp.list [Sexp.atom "Ppat_exception"; pattern p] + | Ppat_extension ext -> + Sexp.list [Sexp.atom "Ppat_extension"; extension ext] + | Ppat_open (longident_loc, p) -> + Sexp.list + [ + Sexp.atom "Ppat_open"; + longident longident_loc.Location.txt; + pattern p; + ] + in + Sexp.list [Sexp.atom "pattern"; descr] + + and object_field field = + match field with + | Otag (lbl_loc, attrs, typexpr) -> + Sexp.list + [ + Sexp.atom "Otag"; + string lbl_loc.txt; + attributes attrs; + core_type typexpr; + ] + | Oinherit typexpr -> Sexp.list [Sexp.atom "Oinherit"; core_type typexpr] + + and row_field field = + match field with + | Rtag (label_loc, attrs, truth, types) -> + Sexp.list + [ + Sexp.atom "Rtag"; + string label_loc.txt; + attributes attrs; + Sexp.atom (if truth then "true" else "false"); + Sexp.list (map_empty ~f:core_type types); + ] + | Rinherit typexpr -> Sexp.list [Sexp.atom "Rinherit"; core_type typexpr] + + and package_type (mod_name_loc, package_constraints) = + Sexp.list + [ + Sexp.atom "package_type"; + longident mod_name_loc.Asttypes.txt; + Sexp.list + (map_empty + ~f:(fun (mod_name_loc, typexpr) -> + Sexp.list + [longident mod_name_loc.Asttypes.txt; core_type typexpr]) + package_constraints); + ] + + and core_type typexpr = + let desc = + match typexpr.ptyp_desc with + | Ptyp_any -> Sexp.atom "Ptyp_any" + | Ptyp_var var -> Sexp.list [Sexp.atom "Ptyp_var"; string var] + | Ptyp_arrow {arg; ret} -> + Sexp.list + [ + Sexp.atom "Ptyp_arrow"; + arg_label_loc arg.lbl; + core_type arg.typ; + core_type ret; + ] + | Ptyp_tuple types -> + Sexp.list + [Sexp.atom "Ptyp_tuple"; Sexp.list (map_empty ~f:core_type types)] + | Ptyp_constr (longident_loc, types) -> + Sexp.list + [ + Sexp.atom "Ptyp_constr"; + longident longident_loc.txt; + Sexp.list (map_empty ~f:core_type types); + ] + | Ptyp_alias (typexpr, alias) -> + Sexp.list [Sexp.atom "Ptyp_alias"; core_type typexpr; string alias] + | Ptyp_object (fields, flag) -> + Sexp.list + [ + Sexp.atom "Ptyp_object"; + closed_flag flag; + Sexp.list (map_empty ~f:object_field fields); + ] + | Ptyp_variant (fields, flag, opt_labels) -> + Sexp.list + [ + Sexp.atom "Ptyp_variant"; + Sexp.list (map_empty ~f:row_field fields); + closed_flag flag; + (match opt_labels with + | None -> Sexp.atom "None" + | Some lbls -> Sexp.list (map_empty ~f:string lbls)); + ] + | Ptyp_poly (lbls, typexpr) -> + Sexp.list + [ + Sexp.atom "Ptyp_poly"; + Sexp.list (map_empty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); + core_type typexpr; + ] + | Ptyp_package package -> + Sexp.list [Sexp.atom "Ptyp_package"; package_type package] + | Ptyp_extension ext -> + Sexp.list [Sexp.atom "Ptyp_extension"; extension ext] + in + Sexp.list [Sexp.atom "core_type"; desc] + + and payload p = + match p with + | PStr s -> Sexp.list (Sexp.atom "PStr" :: map_empty ~f:structure_item s) + | PSig s -> Sexp.list [Sexp.atom "PSig"; signature s] + | PTyp ct -> Sexp.list [Sexp.atom "PTyp"; core_type ct] + | PPat (pat, opt_expr) -> + Sexp.list + [ + Sexp.atom "PPat"; + pattern pat; + (match opt_expr with + | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr] + | None -> Sexp.atom "None"); + ] + + and attribute (string_loc, p) = + Sexp.list + [Sexp.atom "attribute"; Sexp.atom string_loc.Asttypes.txt; payload p] + + and extension (string_loc, p) = + Sexp.list + [Sexp.atom "extension"; Sexp.atom string_loc.Asttypes.txt; payload p] + + and attributes attrs = + let sexprs = map_empty ~f:attribute attrs in + Sexp.list (Sexp.atom "attributes" :: sexprs) + + let print_engine = + Res_driver. + { + print_implementation = + (fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> structure |> Sexp.to_string |> print_string); + print_interface = + (fun ~width:_ ~filename:_ ~comments:_ parsetree -> + parsetree |> signature |> Sexp.to_string |> print_string); + } +end + +let sexp_print_engine = SexpAst.print_engine + +let comments_print_engine = + { + Res_driver.print_implementation = + (fun ~width:_ ~filename:_ ~comments s -> + let cmt_tbl = CommentTable.make () in + CommentTable.walk_structure s cmt_tbl comments; + CommentTable.log cmt_tbl); + print_interface = + (fun ~width:_ ~filename:_ ~comments s -> + let cmt_tbl = CommentTable.make () in + CommentTable.walk_signature s cmt_tbl comments; + CommentTable.log cmt_tbl); + } diff --git a/compiler/syntax/src/res_ast_debugger.mli b/compiler/syntax/src/res_ast_debugger.mli new file mode 100644 index 0000000..66588af --- /dev/null +++ b/compiler/syntax/src/res_ast_debugger.mli @@ -0,0 +1,3 @@ +val print_engine : Res_driver.print_engine +val sexp_print_engine : Res_driver.print_engine +val comments_print_engine : Res_driver.print_engine diff --git a/compiler/syntax/src/res_comment.ml b/compiler/syntax/src/res_comment.ml new file mode 100644 index 0000000..f03209f --- /dev/null +++ b/compiler/syntax/src/res_comment.ml @@ -0,0 +1,64 @@ +type style = SingleLine | MultiLine | DocComment | ModuleComment + +let style_to_string s = + match s with + | SingleLine -> "SingleLine" + | MultiLine -> "MultiLine" + | DocComment -> "DocComment" + | ModuleComment -> "ModuleComment" + +type t = { + txt: string; + style: style; + loc: Location.t; + mutable prev_tok_end_pos: Lexing.position; +} + +let loc t = t.loc +let txt t = t.txt +let prev_tok_end_pos t = t.prev_tok_end_pos + +let set_prev_tok_end_pos t pos = t.prev_tok_end_pos <- pos + +let is_single_line_comment t = t.style = SingleLine + +let is_doc_comment t = t.style = DocComment + +let is_module_comment t = t.style = ModuleComment + +let to_string t = + let {Location.loc_start; loc_end} = t.loc in + Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt + (style_to_string t.style) loc_start.pos_lnum + (loc_start.pos_cnum - loc_start.pos_bol) + loc_end.pos_lnum + (loc_end.pos_cnum - loc_end.pos_bol) + +let make_single_line_comment ~loc txt = + {txt; loc; style = SingleLine; prev_tok_end_pos = Lexing.dummy_pos} + +let make_multi_line_comment ~loc ~doc_comment ~standalone txt = + { + txt; + loc; + style = + (if doc_comment then if standalone then ModuleComment else DocComment + else MultiLine); + prev_tok_end_pos = Lexing.dummy_pos; + } + +let trim_spaces s = + let len = String.length s in + if len = 0 then s + else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' + then ( + let i = ref 0 in + while !i < len && String.unsafe_get s !i = ' ' do + incr i + done; + let j = ref (len - 1) in + while !j >= !i && String.unsafe_get s !j = ' ' do + decr j + done; + if !j >= !i then (String.sub [@doesNotRaise]) s !i (!j - !i + 1) else "") + else s diff --git a/compiler/syntax/src/res_comment.mli b/compiler/syntax/src/res_comment.mli new file mode 100644 index 0000000..ce788dd --- /dev/null +++ b/compiler/syntax/src/res_comment.mli @@ -0,0 +1,20 @@ +type t + +val to_string : t -> string + +val loc : t -> Location.t +val txt : t -> string +val prev_tok_end_pos : t -> Lexing.position + +val set_prev_tok_end_pos : t -> Lexing.position -> unit + +val is_doc_comment : t -> bool + +val is_module_comment : t -> bool + +val is_single_line_comment : t -> bool + +val make_single_line_comment : loc:Location.t -> string -> t +val make_multi_line_comment : + loc:Location.t -> doc_comment:bool -> standalone:bool -> string -> t +val trim_spaces : string -> string diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml new file mode 100644 index 0000000..6774b2b --- /dev/null +++ b/compiler/syntax/src/res_comments_table.ml @@ -0,0 +1,2335 @@ +module Comment = Res_comment +module Doc = Res_doc +module ParsetreeViewer = Res_parsetree_viewer + +type t = { + leading: (Location.t, Comment.t list) Hashtbl.t; + inside: (Location.t, Comment.t list) Hashtbl.t; + trailing: (Location.t, Comment.t list) Hashtbl.t; +} + +let make () = + { + leading = Hashtbl.create 100; + inside = Hashtbl.create 100; + trailing = Hashtbl.create 100; + } + +let copy tbl = + { + leading = Hashtbl.copy tbl.leading; + inside = Hashtbl.copy tbl.inside; + trailing = Hashtbl.copy tbl.trailing; + } + +let empty = make () + +let rec list_last = function + | [] -> failwith "list_last: empty list" + | [x] -> x + | _ :: rest -> list_last rest + +let print_location (k : Warnings.loc) = + Doc.concat + [ + Doc.lbracket; + Doc.text (string_of_int k.loc_start.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); + Doc.text "-"; + Doc.text (string_of_int k.loc_end.pos_lnum); + Doc.text ":"; + Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); + Doc.rbracket; + ] + +let print_entries tbl = + Hashtbl.fold + (fun (k : Location.t) (v : Comment.t list) acc -> + let loc = print_location k in + let doc = + Doc.breakable_group ~force_break:true + (Doc.concat + [ + loc; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun c -> Doc.text (Comment.txt c)) v); + ]); + Doc.line; + ]) + in + doc :: acc) + tbl [] + +let log t = + let leading_stuff = print_entries t.leading in + let trailing_stuff = print_entries t.trailing in + let stuff_inside = print_entries t.inside in + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.text "leading comments:"; + Doc.indent (Doc.concat [Doc.line; Doc.concat leading_stuff]); + Doc.line; + Doc.text "comments inside:"; + Doc.indent (Doc.concat [Doc.line; Doc.concat stuff_inside]); + Doc.line; + Doc.text "trailing comments:"; + Doc.indent (Doc.concat [Doc.line; Doc.concat trailing_stuff]); + Doc.line; + ]) + |> Doc.to_string ~width:80 |> print_endline + +let attach tbl loc comments = + match comments with + | [] -> () + | comments -> Hashtbl.replace tbl loc comments + +(* Partitions a list of comments into three groups based on their position relative to a location: + * - leading: comments that end before the location's start position + * - inside: comments that overlap with the location + * - trailing: comments that start after the location's end position + * + * For example, given code: + * /* comment1 */ let x = /* comment2 */ 5 /* comment3 */ + * + * When splitting around the location of `x = 5`: + * - leading: [comment1] + * - inside: [comment2] + * - trailing: [comment3] + * + * This is the primary comment partitioning function used for associating comments + * with AST nodes during the tree traversal. + * + * Parameters: + * - comments: list of comments to partition + * - loc: location to split around + * + * Returns: (leading_comments, inside_comments, trailing_comments) + *) +let partition_by_loc comments loc = + let rec loop (leading, inside, trailing) comments = + let open Location in + match comments with + | comment :: rest -> + let cmt_loc = Comment.loc comment in + if cmt_loc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, inside, trailing) rest + else if cmt_loc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then + loop (leading, inside, comment :: trailing) rest + else loop (leading, comment :: inside, trailing) rest + | [] -> (List.rev leading, List.rev inside, List.rev trailing) + in + loop ([], [], []) comments + +(* Splits a list of comments into two groups based on their position relative to a location: + * - leading: comments that end before the location's start + * - trailing: comments that start at or after the location's start + * + * For example, given the code: + * /* comment1 */ let /* comment2 */ x = 1 /* comment3 */ + * + * When splitting around `x`'s location: + * - leading: [comment1, comment2] + * - trailing: [comment3] + * + * Parameters: + * - comments: list of comments to partition + * - loc: location to split around + * + * Returns: (leading_comments, trailing_comments) + *) +let partition_leading_trailing comments loc = + let rec loop (leading, trailing) comments = + let open Location in + match comments with + | comment :: rest -> + let cmt_loc = Comment.loc comment in + if cmt_loc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then + loop (comment :: leading, trailing) rest + else loop (leading, comment :: trailing) rest + | [] -> (List.rev leading, List.rev trailing) + in + loop ([], []) comments + +(* Splits comments into two groups based on whether they start on the same line as a location's end position. + * + * This is particularly useful for handling comments that appear on the same line as a syntax element + * versus comments that appear on subsequent lines. + * + * For example, given code: + * let x = 1 /* same line comment */ + * /* different line comment */ + * + * When splitting around `x = 1`'s location: + * - on_same_line: [/* same line comment */] + * - on_other_line: [/* different line comment */] + * + * This function is often used for formatting decisions where comments on the same line + * should be treated differently than comments on different lines (like in JSX elements). + * + * Parameters: + * - loc: location to compare line numbers against + * - comments: list of comments to partition + * + * Returns: (on_same_line_comments, on_other_line_comments) + *) +let partition_by_on_same_line loc comments = + let rec loop (on_same_line, on_other_line) comments = + let open Location in + match comments with + | [] -> (List.rev on_same_line, List.rev on_other_line) + | comment :: rest -> + let cmt_loc = Comment.loc comment in + if cmt_loc.loc_start.pos_lnum == loc.loc_end.pos_lnum then + loop (comment :: on_same_line, on_other_line) rest + else loop (on_same_line, comment :: on_other_line) rest + in + loop ([], []) comments + +let partition_adjacent_trailing loc1 comments = + let open Location in + let open Lexing in + let rec loop ~prev_end_pos after_loc1 comments = + match comments with + | [] -> (List.rev after_loc1, []) + | comment :: rest as comments -> + let cmt_prev_end_pos = Comment.prev_tok_end_pos comment in + if prev_end_pos.Lexing.pos_cnum == cmt_prev_end_pos.pos_cnum then + let comment_end = (Comment.loc comment).loc_end in + loop ~prev_end_pos:comment_end (comment :: after_loc1) rest + else (List.rev after_loc1, comments) + in + loop ~prev_end_pos:loc1.loc_end [] comments + +(* Splits comments that follow a location but come before another token. + * This is particularly useful for handling comments between two tokens + * where traditional leading/trailing partitioning isn't precise enough. + * + * For example, given code: + * let x = 1 /* comment */ + 2 + * + * When splitting comments between `1` and `+`: + * - first_part: [/* comment */] (comments on same line as loc and before next_token) + * - rest: [] (remaining comments) + * + * Parameters: + * - loc: location of the reference token + * - next_token: location of the next token + * - comments: list of comments to partition + * + * Returns: (first_part, rest) where first_part contains comments on the same line as loc + * that appear entirely before next_token, and rest contains all other comments. + * + * This function is useful for precisely attaching comments between specific tokens + * in constructs like JSX props, function arguments, and other multi-token expressions. + *) +let partition_adjacent_trailing_before_next_token_on_same_line + (loc : Warnings.loc) (next_token : Warnings.loc) (comments : Comment.t list) + : Comment.t list * Comment.t list = + let open Location in + let open Lexing in + let rec loop after_loc comments = + match comments with + | [] -> (List.rev after_loc, []) + | comment :: rest -> + (* Check if the comment is on the same line as the loc, and is entirely before the next_token *) + let cmt_loc = Comment.loc comment in + if + (* Same line *) + cmt_loc.loc_start.pos_lnum == loc.loc_end.pos_lnum + (* comment after loc *) + && cmt_loc.loc_start.pos_cnum > loc.loc_end.pos_cnum + (* comment before next_token *) + && cmt_loc.loc_end.pos_cnum <= next_token.loc_start.pos_cnum + then loop (comment :: after_loc) rest + else (List.rev after_loc, comments) + in + loop [] comments + +(* Extracts comments that appear between two specified line numbers in a source file. + * + * This function is particularly useful for handling comments that should be preserved + * between two syntax elements that appear on different lines, such as comments between + * opening and closing tags in JSX elements. + * + * For example, given code: + *
+ * // comment 1 + * // comment 2 + *
+ * + * When calling partition_between_lines with the line numbers of the opening and closing tags: + * - between_comments: [comment 1, comment 2] + * - rest: any comments that appear before or after the specified lines + * + * Parameters: + * - start_line: the line number after which to start collecting comments + * - end_line: the line number before which to stop collecting comments + * - comments: list of comments to partition + * + * Returns: (between_comments, rest) where between_comments contains all comments + * entirely between the start_line and end_line, and rest contains all other comments. + *) +let partition_between_lines start_line end_line comments = + let open Location in + let open Lexing in + let rec loop between_comments comments = + match comments with + | [] -> (List.rev between_comments, []) + | comment :: rest -> + (* Check if the comment is between the start_line and end_line *) + let cmt_loc = Comment.loc comment in + if + cmt_loc.loc_start.pos_lnum > start_line + && cmt_loc.loc_end.pos_lnum < end_line + then loop (comment :: between_comments) rest + else (List.rev between_comments, comments) + in + loop [] comments + +let rec collect_list_patterns acc pattern = + let open Parsetree in + match pattern.ppat_desc with + | Ppat_construct + ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) + -> + collect_list_patterns (pat :: acc) rest + | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> List.rev acc + | _ -> List.rev (pattern :: acc) + +let rec collect_list_exprs acc expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_construct + ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [expr; rest]}) + -> + collect_list_exprs (expr :: acc) rest + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc + | _ -> List.rev (expr :: acc) + +(* TODO: use ParsetreeViewer *) +let arrow_type ct = + let open Parsetree in + let rec process attrs_before acc typ = + match typ with + | { + ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel} as arg; ret}; + ptyp_attributes = []; + } -> + let arg = ([], arg.lbl, arg.typ) in + process attrs_before (arg :: acc) ret + | { + ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel} as arg; ret}; + ptyp_attributes = [({txt = "bs"}, _)] as attrs; + } -> + let arg = (attrs, arg.lbl, arg.typ) in + process attrs_before (arg :: acc) ret + | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}} as return_type -> + let args = List.rev acc in + (attrs_before, args, return_type) + | {ptyp_desc = Ptyp_arrow {arg; ret}; ptyp_attributes = attrs} -> + let arg = (attrs, arg.lbl, arg.typ) in + process attrs_before (arg :: acc) ret + | typ -> (attrs_before, List.rev acc, typ) + in + match ct with + | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}; ptyp_attributes = attrs} as + typ -> + process attrs [] {typ with ptyp_attributes = []} + | typ -> process [] [] typ + +(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) +let mod_expr_apply mod_expr = + let rec loop acc mod_expr = + match mod_expr with + | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | _ -> mod_expr :: acc + in + loop [] mod_expr + +(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) +let mod_expr_functor mod_expr = + let rec loop acc mod_expr = + match mod_expr with + | { + Parsetree.pmod_desc = Pmod_functor (lbl, mod_type, return_mod_expr); + pmod_attributes = attrs; + } -> + let param = (attrs, lbl, mod_type) in + loop (param :: acc) return_mod_expr + | return_mod_expr -> (List.rev acc, return_mod_expr) + in + loop [] mod_expr + +let functor_type modtype = + let rec process acc modtype = + match modtype with + | { + Parsetree.pmty_desc = Pmty_functor (lbl, arg_type, return_type); + pmty_attributes = attrs; + } -> + let arg = (attrs, lbl, arg_type) in + process (arg :: acc) return_type + | mod_type -> (List.rev acc, mod_type) + in + process [] modtype + +let fun_expr expr = + let open Parsetree in + (* Turns (type t, type u, type z) into "type t u z" *) + let rec collect_new_types acc return_expr = + match return_expr with + | {pexp_desc = Pexp_newtype (string_loc, return_expr); pexp_attributes = []} + -> + collect_new_types (string_loc :: acc) return_expr + | return_expr -> + let loc = + match (acc, List.rev acc) with + | _startLoc :: _, end_loc :: _ -> + {end_loc.loc with loc_end = end_loc.loc.loc_end} + | _ -> Location.none + in + let txt = + List.fold_right + (fun curr acc -> acc ^ " " ^ curr.Location.txt) + acc "type" + in + (Location.mkloc txt loc, return_expr) + in + (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, + * otherwise this function would need to return a variant: + * | NormalParamater(...) + * | NewType(...) + * This complicates printing with an extra variant/boxing/allocation for a code-path + * that is not often used. Lets just keep it simple for now *) + let rec collect attrs_before acc expr = + match expr with + | { + pexp_desc = + Pexp_fun + { + arg_label = lbl; + default = default_expr; + lhs = pattern; + rhs = return_expr; + }; + pexp_attributes = []; + } -> + let parameter = ([], lbl, default_expr, pattern) in + collect attrs_before (parameter :: acc) return_expr + | {pexp_desc = Pexp_newtype (string_loc, rest); pexp_attributes = attrs} -> + let var, return_expr = collect_new_types [string_loc] rest in + let parameter = + ( attrs, + Asttypes.Nolabel, + None, + Ast_helper.Pat.var ~loc:string_loc.loc var ) + in + collect attrs_before (parameter :: acc) return_expr + | { + pexp_desc = + Pexp_fun + { + arg_label = lbl; + default = default_expr; + lhs = pattern; + rhs = return_expr; + }; + pexp_attributes = [({txt = "bs"}, _)] as attrs; + } -> + let parameter = (attrs, lbl, default_expr, pattern) in + collect attrs_before (parameter :: acc) return_expr + | { + pexp_desc = + Pexp_fun + { + arg_label = (Labelled _ | Optional _) as lbl; + default = default_expr; + lhs = pattern; + rhs = return_expr; + }; + pexp_attributes = attrs; + } -> + let parameter = (attrs, lbl, default_expr, pattern) in + collect attrs_before (parameter :: acc) return_expr + | expr -> (attrs_before, List.rev acc, expr) + in + match expr with + | {pexp_desc = Pexp_fun {arg_label = Nolabel}; pexp_attributes = attrs} as + expr -> + collect attrs [] {expr with pexp_attributes = []} + | expr -> collect [] [] expr + +let rec is_block_expr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ + | Pexp_sequence _ -> + true + | Pexp_apply {funct = call_expr} when is_block_expr call_expr -> true + | Pexp_constraint (expr, _) when is_block_expr expr -> true + | Pexp_field (expr, _) when is_block_expr expr -> true + | Pexp_setfield (expr, _, _) when is_block_expr expr -> true + | _ -> false + +let is_if_then_else_expr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_ifthenelse _ -> true + | _ -> false + +type node = + | Case of Parsetree.case + | CoreType of Parsetree.core_type + | ExprArgument of {expr: Parsetree.expression; loc: Location.t} + | Expression of Parsetree.expression + | ExprRecordRow of Longident.t Asttypes.loc * Parsetree.expression + | ExtensionConstructor of Parsetree.extension_constructor + | LabelDeclaration of Parsetree.label_declaration + | ModuleBinding of Parsetree.module_binding + | ModuleDeclaration of Parsetree.module_declaration + | ModuleExpr of Parsetree.module_expr + | ObjectField of Parsetree.object_field + | PackageConstraint of Longident.t Asttypes.loc * Parsetree.core_type + | Pattern of Parsetree.pattern + | PatternRecordRow of Longident.t Asttypes.loc * Parsetree.pattern + | RowField of Parsetree.row_field + | SignatureItem of Parsetree.signature_item + | StructureItem of Parsetree.structure_item + | TypeDeclaration of Parsetree.type_declaration + | ValueBinding of Parsetree.value_binding + | JsxProp of Parsetree.jsx_prop + +let get_loc node = + let open Parsetree in + match node with + | Case case -> + { + case.pc_lhs.ppat_loc with + loc_end = + (match ParsetreeViewer.process_braces_attr case.pc_rhs with + | None, _ -> case.pc_rhs.pexp_loc.loc_end + | Some ({loc}, _), _ -> loc.Location.loc_end); + } + | CoreType ct -> ct.ptyp_loc + | ExprArgument {loc} -> loc + | Expression e -> ( + match e.pexp_attributes with + | ({txt = "res.braces" | "ns.braces"; loc}, _) :: _ -> loc + | _ -> e.pexp_loc) + | ExprRecordRow (li, e) -> {li.loc with loc_end = e.pexp_loc.loc_end} + | ExtensionConstructor ec -> ec.pext_loc + | LabelDeclaration ld -> ld.pld_loc + | ModuleBinding mb -> mb.pmb_loc + | ModuleDeclaration md -> md.pmd_loc + | ModuleExpr me -> me.pmod_loc + | ObjectField field -> ( + match field with + | Parsetree.Otag (lbl, _, typ) -> + {lbl.loc with loc_end = typ.ptyp_loc.loc_end} + | _ -> Location.none) + | PackageConstraint (li, te) -> {li.loc with loc_end = te.ptyp_loc.loc_end} + | Pattern p -> p.ppat_loc + | PatternRecordRow (li, p) -> {li.loc with loc_end = p.ppat_loc.loc_end} + | RowField rf -> ( + match rf with + | Parsetree.Rtag ({loc}, _, _, _) -> loc + | Rinherit {ptyp_loc} -> ptyp_loc) + | SignatureItem si -> si.psig_loc + | StructureItem si -> si.pstr_loc + | TypeDeclaration td -> td.ptype_loc + | ValueBinding vb -> vb.pvb_loc + | JsxProp prop -> ParsetreeViewer.get_jsx_prop_loc prop + +let rec walk_structure s t comments = + match s with + | _ when comments = [] -> () + | [] -> attach t.inside Location.none comments + | s -> walk_list (s |> List.map (fun si -> StructureItem si)) t comments + +and walk_structure_item si t comments = + match si.Parsetree.pstr_desc with + | _ when comments = [] -> () + | Pstr_primitive value_description -> + walk_value_description value_description t comments + | Pstr_open open_description -> + walk_open_description open_description t comments + | Pstr_value (_, value_bindings) -> + walk_value_bindings value_bindings t comments + | Pstr_type (_, type_declarations) -> + walk_type_declarations type_declarations t comments + | Pstr_eval (expr, _) -> walk_expression expr t comments + | Pstr_module module_binding -> walk_module_binding module_binding t comments + | Pstr_recmodule module_bindings -> + walk_list + (module_bindings |> List.map (fun mb -> ModuleBinding mb)) + t comments + | Pstr_modtype mod_typ_decl -> + walk_module_type_declaration mod_typ_decl t comments + | Pstr_attribute attribute -> walk_attribute attribute t comments + | Pstr_extension (extension, _) -> walk_extension extension t comments + | Pstr_include include_declaration -> + walk_include_declaration include_declaration t comments + | Pstr_exception extension_constructor -> + walk_extension_constructor extension_constructor t comments + | Pstr_typext type_extension -> walk_type_extension type_extension t comments + +and walk_value_description vd t comments = + let leading, trailing = + partition_leading_trailing comments vd.pval_name.loc + in + attach t.leading vd.pval_name.loc leading; + let after_name, rest = + partition_adjacent_trailing vd.pval_name.loc trailing + in + attach t.trailing vd.pval_name.loc after_name; + let before, inside, after = partition_by_loc rest vd.pval_type.ptyp_loc in + attach t.leading vd.pval_type.ptyp_loc before; + walk_core_type vd.pval_type t inside; + attach t.trailing vd.pval_type.ptyp_loc after + +and walk_type_extension te t comments = + let leading, trailing = + partition_leading_trailing comments te.ptyext_path.loc + in + attach t.leading te.ptyext_path.loc leading; + let after_path, rest = + partition_adjacent_trailing te.ptyext_path.loc trailing + in + attach t.trailing te.ptyext_path.loc after_path; + + (* type params *) + let rest = + match te.ptyext_params with + | [] -> rest + | type_params -> + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walk_node:walk_type_param ~newline_delimited:false type_params t rest + in + walk_list + (te.ptyext_constructors |> List.map (fun ec -> ExtensionConstructor ec)) + t rest + +and walk_include_declaration incl_decl t comments = + let before, inside, after = + partition_by_loc comments incl_decl.pincl_mod.pmod_loc + in + attach t.leading incl_decl.pincl_mod.pmod_loc before; + walk_module_expr incl_decl.pincl_mod t inside; + attach t.trailing incl_decl.pincl_mod.pmod_loc after + +and walk_module_type_declaration mtd t comments = + let leading, trailing = + partition_leading_trailing comments mtd.pmtd_name.loc + in + attach t.leading mtd.pmtd_name.loc leading; + match mtd.pmtd_type with + | None -> attach t.trailing mtd.pmtd_name.loc trailing + | Some mod_type -> + let after_name, rest = + partition_adjacent_trailing mtd.pmtd_name.loc trailing + in + attach t.trailing mtd.pmtd_name.loc after_name; + let before, inside, after = partition_by_loc rest mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after + +and walk_module_binding mb t comments = + let leading, trailing = partition_leading_trailing comments mb.pmb_name.loc in + attach t.leading mb.pmb_name.loc leading; + let after_name, rest = partition_adjacent_trailing mb.pmb_name.loc trailing in + attach t.trailing mb.pmb_name.loc after_name; + let leading, inside, trailing = partition_by_loc rest mb.pmb_expr.pmod_loc in + (match mb.pmb_expr.pmod_desc with + | Pmod_constraint _ -> + walk_module_expr mb.pmb_expr t (List.concat [leading; inside]) + | _ -> + attach t.leading mb.pmb_expr.pmod_loc leading; + walk_module_expr mb.pmb_expr t inside); + attach t.trailing mb.pmb_expr.pmod_loc trailing + +and walk_signature signature t comments = + match signature with + | _ when comments = [] -> () + | [] -> attach t.inside Location.none comments + | _s -> + walk_list (signature |> List.map (fun si -> SignatureItem si)) t comments + +and walk_signature_item (si : Parsetree.signature_item) t comments = + match si.psig_desc with + | _ when comments = [] -> () + | Psig_value value_description -> + walk_value_description value_description t comments + | Psig_type (_, type_declarations) -> + walk_type_declarations type_declarations t comments + | Psig_typext type_extension -> walk_type_extension type_extension t comments + | Psig_exception extension_constructor -> + walk_extension_constructor extension_constructor t comments + | Psig_module module_declaration -> + walk_module_declaration module_declaration t comments + | Psig_recmodule module_declarations -> + walk_list + (module_declarations |> List.map (fun md -> ModuleDeclaration md)) + t comments + | Psig_modtype module_type_declaration -> + walk_module_type_declaration module_type_declaration t comments + | Psig_open open_description -> + walk_open_description open_description t comments + | Psig_include include_description -> + walk_include_description include_description t comments + | Psig_attribute attribute -> walk_attribute attribute t comments + | Psig_extension (extension, _) -> walk_extension extension t comments + +and walk_include_description id t comments = + let before, inside, after = partition_by_loc comments id.pincl_mod.pmty_loc in + attach t.leading id.pincl_mod.pmty_loc before; + walk_mod_type id.pincl_mod t inside; + attach t.trailing id.pincl_mod.pmty_loc after + +and walk_module_declaration md t comments = + let leading, trailing = partition_leading_trailing comments md.pmd_name.loc in + attach t.leading md.pmd_name.loc leading; + let after_name, rest = partition_adjacent_trailing md.pmd_name.loc trailing in + attach t.trailing md.pmd_name.loc after_name; + let leading, inside, trailing = partition_by_loc rest md.pmd_type.pmty_loc in + attach t.leading md.pmd_type.pmty_loc leading; + walk_mod_type md.pmd_type t inside; + attach t.trailing md.pmd_type.pmty_loc trailing + +and walk_node node tbl comments = + match node with + | Case c -> walk_case c tbl comments + | CoreType ct -> walk_core_type ct tbl comments + | ExprArgument ea -> walk_expr_argument ea.expr ea.loc tbl comments + | Expression e -> walk_expression e tbl comments + | ExprRecordRow (ri, e) -> walk_expr_record_row (ri, e) tbl comments + | ExtensionConstructor ec -> walk_extension_constructor ec tbl comments + | LabelDeclaration ld -> walk_label_declaration ld tbl comments + | ModuleBinding mb -> walk_module_binding mb tbl comments + | ModuleDeclaration md -> walk_module_declaration md tbl comments + | ModuleExpr me -> walk_module_expr me tbl comments + | ObjectField f -> walk_object_field f tbl comments + | PackageConstraint (li, te) -> walk_package_constraint (li, te) tbl comments + | Pattern p -> walk_pattern p tbl comments + | PatternRecordRow (li, p) -> walk_pattern_record_row (li, p) tbl comments + | RowField rf -> walk_row_field rf tbl comments + | SignatureItem si -> walk_signature_item si tbl comments + | StructureItem si -> walk_structure_item si tbl comments + | TypeDeclaration td -> walk_type_declaration td tbl comments + | ValueBinding vb -> walk_value_binding vb tbl comments + | JsxProp prop -> walk_jsx_prop prop tbl comments + +and walk_list : ?prev_loc:Location.t -> node list -> t -> Comment.t list -> unit + = + fun ?prev_loc l t comments -> + match l with + | _ when comments = [] -> () + | [] -> ( + match prev_loc with + | Some loc -> attach t.trailing loc comments + | None -> ()) + | node :: rest -> + let curr_loc = get_loc node in + let leading, inside, trailing = partition_by_loc comments curr_loc in + (match prev_loc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading curr_loc leading + | Some prev_loc -> + (* Same line *) + if prev_loc.loc_end.pos_lnum == curr_loc.loc_start.pos_lnum then ( + let after_prev, before_curr = + partition_adjacent_trailing prev_loc leading + in + attach t.trailing prev_loc after_prev; + attach t.leading curr_loc before_curr) + else + let on_same_line_as_prev, after_prev = + partition_by_on_same_line prev_loc leading + in + attach t.trailing prev_loc on_same_line_as_prev; + let leading, _inside, _trailing = + partition_by_loc after_prev curr_loc + in + attach t.leading curr_loc leading); + walk_node node t inside; + walk_list ~prev_loc:curr_loc rest t trailing + +(* The parsetree doesn't always contain location info about the opening or + * closing token of a "list-of-things". This routine visits the whole list, + * but returns any remaining comments that likely fall after the whole list. *) +and visit_list_but_continue_with_remaining_comments : + 'node. + ?prev_loc:Location.t -> + newline_delimited:bool -> + get_loc:('node -> Location.t) -> + walk_node:('node -> t -> Comment.t list -> unit) -> + 'node list -> + t -> + Comment.t list -> + Comment.t list = + fun ?prev_loc ~newline_delimited ~get_loc ~walk_node l t comments -> + let open Location in + match l with + | _ when comments = [] -> [] + | [] -> ( + match prev_loc with + | Some loc -> + let after_prev, rest = + if newline_delimited then partition_by_on_same_line loc comments + else partition_adjacent_trailing loc comments + in + attach t.trailing loc after_prev; + rest + | None -> comments) + | node :: rest -> + let curr_loc = get_loc node in + let leading, inside, trailing = partition_by_loc comments curr_loc in + let () = + match prev_loc with + | None -> + (* first node, all leading comments attach here *) + attach t.leading curr_loc leading; + () + | Some prev_loc -> + (* Same line *) + if prev_loc.loc_end.pos_lnum == curr_loc.loc_start.pos_lnum then + let after_prev, before_curr = + partition_adjacent_trailing prev_loc leading + in + let () = attach t.trailing prev_loc after_prev in + let () = attach t.leading curr_loc before_curr in + () + else + let on_same_line_as_prev, after_prev = + partition_by_on_same_line prev_loc leading + in + let () = attach t.trailing prev_loc on_same_line_as_prev in + let leading, _inside, _trailing = + partition_by_loc after_prev curr_loc + in + let () = attach t.leading curr_loc leading in + () + in + walk_node node t inside; + visit_list_but_continue_with_remaining_comments ~prev_loc:curr_loc ~get_loc + ~walk_node ~newline_delimited rest t trailing + +and walk_value_bindings vbs t comments = + walk_list (vbs |> List.map (fun vb -> ValueBinding vb)) t comments + +and walk_open_description open_description t comments = + let loc = open_description.popen_lid.loc in + let leading, trailing = partition_leading_trailing comments loc in + attach t.leading loc leading; + attach t.trailing loc trailing + +and walk_type_declarations type_declarations t comments = + walk_list + (type_declarations |> List.map (fun td -> TypeDeclaration td)) + t comments + +and walk_type_param (typexpr, _variance) t comments = + walk_core_type typexpr t comments + +and walk_type_declaration (td : Parsetree.type_declaration) t comments = + let before_name, rest = + partition_leading_trailing comments td.ptype_name.loc + in + attach t.leading td.ptype_name.loc before_name; + + let after_name, rest = partition_adjacent_trailing td.ptype_name.loc rest in + attach t.trailing td.ptype_name.loc after_name; + + (* type params *) + let rest = + match td.ptype_params with + | [] -> rest + | type_params -> + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) + ~walk_node:walk_type_param ~newline_delimited:false type_params t rest + in + + (* manifest: = typexpr *) + let rest = + match td.ptype_manifest with + | Some typexpr -> + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + let after_typ, rest = + partition_adjacent_trailing typexpr.Parsetree.ptyp_loc after_typ + in + attach t.trailing typexpr.ptyp_loc after_typ; + rest + | None -> rest + in + + let rest = + match td.ptype_kind with + | Ptype_abstract | Ptype_open -> rest + | Ptype_record label_declarations -> + let () = + if label_declarations = [] then attach t.inside td.ptype_loc rest + else + walk_list + (label_declarations |> List.map (fun ld -> LabelDeclaration ld)) + t rest + in + [] + | Ptype_variant constructor_declarations -> + walk_constructor_declarations constructor_declarations t rest + in + attach t.trailing td.ptype_loc rest + +and walk_label_declarations lds t comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun ld -> ld.Parsetree.pld_loc) + ~walk_node:walk_label_declaration ~newline_delimited:false lds t comments + +and walk_label_declaration ld t comments = + let before_name, rest = partition_leading_trailing comments ld.pld_name.loc in + attach t.leading ld.pld_name.loc before_name; + let after_name, rest = partition_adjacent_trailing ld.pld_name.loc rest in + attach t.trailing ld.pld_name.loc after_name; + let before_typ, inside_typ, after_typ = + partition_by_loc rest ld.pld_type.ptyp_loc + in + attach t.leading ld.pld_type.ptyp_loc before_typ; + walk_core_type ld.pld_type t inside_typ; + attach t.trailing ld.pld_type.ptyp_loc after_typ + +and walk_constructor_declarations cds t comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun cd -> cd.Parsetree.pcd_loc) + ~walk_node:walk_constructor_declaration ~newline_delimited:false cds t + comments + +and walk_constructor_declaration cd t comments = + let before_name, rest = partition_leading_trailing comments cd.pcd_name.loc in + attach t.leading cd.pcd_name.loc before_name; + let after_name, rest = partition_adjacent_trailing cd.pcd_name.loc rest in + attach t.trailing cd.pcd_name.loc after_name; + let rest = walk_constructor_arguments cd.pcd_args t rest in + + let rest = + match cd.pcd_res with + | Some typexpr -> + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + let after_typ, rest = + partition_adjacent_trailing typexpr.Parsetree.ptyp_loc after_typ + in + attach t.trailing typexpr.ptyp_loc after_typ; + rest + | None -> rest + in + attach t.trailing cd.pcd_loc rest + +and walk_constructor_arguments args t comments = + match args with + | Pcstr_tuple typexprs -> + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun n -> n.Parsetree.ptyp_loc) + ~walk_node:walk_core_type ~newline_delimited:false typexprs t comments + | Pcstr_record label_declarations -> + walk_label_declarations label_declarations t comments + +and walk_value_binding vb t comments = + let open Location in + let vb = + let open Parsetree in + match (vb.pvb_pat, vb.pvb_expr) with + | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, + {pexp_desc = Pexp_constraint (expr, _typ)} ) -> + { + vb with + pvb_pat = + Ast_helper.Pat.constraint_ + ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} + pat t; + pvb_expr = expr; + } + | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_ :: _, t)})}, + {pexp_desc = Pexp_fun _} ) -> + { + vb with + pvb_pat = + { + vb.pvb_pat with + ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}; + }; + } + | ( ({ + ppat_desc = + Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_ :: _, t)} as typ)); + } as constrained_pattern), + {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} + ) -> + (* + * The location of the Ptyp_poly on the pattern is the whole thing. + * let x: + * type t. (int, int) => int = + * (a, b) => { + * // comment + * a + b + * } + *) + { + vb with + pvb_pat = + { + constrained_pattern with + ppat_desc = Ppat_constraint (pat, typ); + ppat_loc = + {constrained_pattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; + }; + pvb_expr = expr; + } + | _ -> vb + in + let pattern_loc = vb.Parsetree.pvb_pat.ppat_loc in + let expr_loc = vb.Parsetree.pvb_expr.pexp_loc in + let expr = vb.pvb_expr in + + let leading, inside, trailing = partition_by_loc comments pattern_loc in + + (* everything before start of pattern can only be leading on the pattern: + * let |* before *| a = 1 *) + attach t.leading pattern_loc leading; + walk_pattern vb.Parsetree.pvb_pat t inside; + let after_pat, surrounding_expr = + partition_adjacent_trailing pattern_loc trailing + in + attach t.trailing pattern_loc after_pat; + let before_expr, inside_expr, after_expr = + partition_by_loc surrounding_expr expr_loc + in + if is_block_expr expr then + walk_expression expr t (List.concat [before_expr; inside_expr; after_expr]) + else ( + attach t.leading expr_loc before_expr; + walk_expression expr t inside_expr; + attach t.trailing expr_loc after_expr) + +and walk_expression expr t comments = + let open Location in + let walk_apply_expr call_expr arguments t comments = + let before, inside, after = + partition_by_loc comments call_expr.Parsetree.pexp_loc + in + let after = + if is_block_expr call_expr then ( + let after_expr, rest = + partition_adjacent_trailing call_expr.Parsetree.pexp_loc after + in + walk_expression call_expr t (List.concat [before; inside; after_expr]); + rest) + else ( + attach t.leading call_expr.Parsetree.pexp_loc before; + walk_expression call_expr t inside; + after) + in + let after_expr, rest = + partition_adjacent_trailing call_expr.Parsetree.pexp_loc after + in + attach t.trailing call_expr.Parsetree.pexp_loc after_expr; + walk_list + (arguments + |> List.map (fun (lbl, expr) -> + let loc = + match lbl with + | Asttypes.Labelled {loc} | Optional {loc} -> + {loc with loc_end = expr.Parsetree.pexp_loc.loc_end} + | _ -> expr.pexp_loc + in + ExprArgument {expr; loc})) + t rest + in + match expr.Parsetree.pexp_desc with + | _ when comments = [] -> () + | Pexp_constant _ -> + let leading, trailing = partition_leading_trailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + attach t.trailing expr.pexp_loc trailing + | Pexp_ident longident -> + let leading, trailing = partition_leading_trailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pexp_let + ( _recFlag, + value_bindings, + {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} ) -> + walk_value_bindings value_bindings t comments + | Pexp_let (_recFlag, value_bindings, expr2) -> + let comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun n -> + if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc + else n.Parsetree.pvb_loc) + ~walk_node:walk_value_binding ~newline_delimited:true value_bindings t + comments + in + if is_block_expr expr2 then walk_expression expr2 t comments + else + let leading, inside, trailing = + partition_by_loc comments expr2.pexp_loc + in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_sequence (expr1, expr2) -> + let leading, inside, trailing = partition_by_loc comments expr1.pexp_loc in + let comments = + if is_block_expr expr1 then ( + let after_expr, comments = + partition_by_on_same_line expr1.pexp_loc trailing + in + walk_expression expr1 t (List.concat [leading; inside; after_expr]); + comments) + else ( + attach t.leading expr1.pexp_loc leading; + walk_expression expr1 t inside; + let after_expr, comments = + partition_by_on_same_line expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc after_expr; + comments) + in + if is_block_expr expr2 then walk_expression expr2 t comments + else + let leading, inside, trailing = + partition_by_loc comments expr2.pexp_loc + in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_open (_override, longident, expr2) -> + let leading, comments = partition_leading_trailing comments expr.pexp_loc in + attach t.leading + {expr.pexp_loc with loc_end = longident.loc.loc_end} + leading; + let leading, trailing = partition_leading_trailing comments longident.loc in + attach t.leading longident.loc leading; + let after_longident, rest = + partition_by_on_same_line longident.loc trailing + in + attach t.trailing longident.loc after_longident; + if is_block_expr expr2 then walk_expression expr2 t rest + else + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_extension + ( {txt = "obj"}, + PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] + ) -> + walk_list + (Ext_list.map rows (fun {lid; x = e} -> ExprRecordRow (lid, e))) + t comments + | Pexp_extension extension -> walk_extension extension t comments + | Pexp_letexception (extension_constructor, expr2) -> + let leading, comments = partition_leading_trailing comments expr.pexp_loc in + attach t.leading + {expr.pexp_loc with loc_end = extension_constructor.pext_loc.loc_end} + leading; + let leading, inside, trailing = + partition_by_loc comments extension_constructor.pext_loc + in + attach t.leading extension_constructor.pext_loc leading; + walk_extension_constructor extension_constructor t inside; + let after_ext_constr, rest = + partition_by_on_same_line extension_constructor.pext_loc trailing + in + attach t.trailing extension_constructor.pext_loc after_ext_constr; + if is_block_expr expr2 then walk_expression expr2 t rest + else + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_letmodule (string_loc, mod_expr, expr2) -> + let leading, comments = partition_leading_trailing comments expr.pexp_loc in + attach t.leading + {expr.pexp_loc with loc_end = mod_expr.pmod_loc.loc_end} + leading; + let leading, trailing = + partition_leading_trailing comments string_loc.loc + in + attach t.leading string_loc.loc leading; + let after_string, rest = + partition_adjacent_trailing string_loc.loc trailing + in + attach t.trailing string_loc.loc after_string; + let before_mod_expr, inside_mod_expr, after_mod_expr = + partition_by_loc rest mod_expr.pmod_loc + in + attach t.leading mod_expr.pmod_loc before_mod_expr; + walk_module_expr mod_expr t inside_mod_expr; + let after_mod_expr, rest = + partition_by_on_same_line mod_expr.pmod_loc after_mod_expr + in + attach t.trailing mod_expr.pmod_loc after_mod_expr; + if is_block_expr expr2 then walk_expression expr2 t rest + else + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_assert expr -> + if is_block_expr expr then walk_expression expr t comments + else + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc trailing + | Pexp_coerce (expr, (), typexpr) -> + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc after_expr; + let leading, inside, trailing = partition_by_loc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walk_core_type typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing + | Pexp_constraint (expr, typexpr) -> + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc after_expr; + let leading, inside, trailing = partition_by_loc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc leading; + walk_core_type typexpr t inside; + attach t.trailing typexpr.ptyp_loc trailing + | Pexp_tuple [] + | Pexp_array [] + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + attach t.inside expr.pexp_loc comments + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + walk_list + (collect_list_exprs [] expr |> List.map (fun e -> Expression e)) + t comments + | Pexp_construct (longident, args) -> ( + let leading, trailing = partition_leading_trailing comments longident.loc in + attach t.leading longident.loc leading; + match args with + | Some expr -> + let after_longident, rest = + partition_adjacent_trailing longident.loc trailing + in + attach t.trailing longident.loc after_longident; + walk_expression expr t rest + | None -> attach t.trailing longident.loc trailing) + | Pexp_variant (_label, None) -> () + | Pexp_variant (_label, Some expr) -> walk_expression expr t comments + | Pexp_array exprs | Pexp_tuple exprs -> + walk_list (exprs |> List.map (fun e -> Expression e)) t comments + | Pexp_record (rows, spread_expr) -> + if rows = [] then attach t.inside expr.pexp_loc comments + else + let comments = + match spread_expr with + | None -> comments + | Some expr -> + let leading, inside, trailing = + partition_by_loc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + let after_expr, rest = + partition_adjacent_trailing expr.pexp_loc trailing + in + attach t.trailing expr.pexp_loc after_expr; + rest + in + walk_list + (Ext_list.map rows (fun {lid; x = e} -> ExprRecordRow (lid, e))) + t comments + | Pexp_field (expr, longident) -> + let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in + let trailing = + if is_block_expr expr then ( + let after_expr, rest = + partition_adjacent_trailing expr.pexp_loc trailing + in + walk_expression expr t (List.concat [leading; inside; after_expr]); + rest) + else ( + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + trailing) + in + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc trailing in + attach t.trailing expr.pexp_loc after_expr; + let leading, trailing = partition_leading_trailing rest longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pexp_setfield (expr1, longident, expr2) -> + let leading, inside, trailing = partition_by_loc comments expr1.pexp_loc in + let rest = + if is_block_expr expr1 then ( + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing + in + walk_expression expr1 t (List.concat [leading; inside; after_expr]); + rest) + else + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing + in + attach t.leading expr1.pexp_loc leading; + walk_expression expr1 t inside; + attach t.trailing expr1.pexp_loc after_expr; + rest + in + let before_longident, after_longident = + partition_leading_trailing rest longident.loc + in + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident + in + attach t.trailing longident.loc after_longident; + if is_block_expr expr2 then walk_expression expr2 t rest + else + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_ifthenelse (if_expr, then_expr, else_expr) -> ( + let leading, rest = partition_leading_trailing comments expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + let leading, inside, trailing = partition_by_loc rest if_expr.pexp_loc in + let comments = + if is_block_expr if_expr then ( + let after_expr, comments = + partition_adjacent_trailing if_expr.pexp_loc trailing + in + walk_expression if_expr t (List.concat [leading; inside; after_expr]); + comments) + else ( + attach t.leading if_expr.pexp_loc leading; + walk_expression if_expr t inside; + let after_expr, comments = + partition_adjacent_trailing if_expr.pexp_loc trailing + in + attach t.trailing if_expr.pexp_loc after_expr; + comments) + in + let leading, inside, trailing = + partition_by_loc comments then_expr.pexp_loc + in + let comments = + if is_block_expr then_expr then ( + let after_expr, trailing = + partition_adjacent_trailing then_expr.pexp_loc trailing + in + walk_expression then_expr t (List.concat [leading; inside; after_expr]); + trailing) + else ( + attach t.leading then_expr.pexp_loc leading; + walk_expression then_expr t inside; + let after_expr, comments = + partition_adjacent_trailing then_expr.pexp_loc trailing + in + attach t.trailing then_expr.pexp_loc after_expr; + comments) + in + match else_expr with + | None -> () + | Some expr -> + if is_block_expr expr || is_if_then_else_expr expr then + walk_expression expr t comments + else + let leading, inside, trailing = + partition_by_loc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc trailing) + | Pexp_while (expr1, expr2) -> + let leading, inside, trailing = partition_by_loc comments expr1.pexp_loc in + let rest = + if is_block_expr expr1 then ( + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing + in + walk_expression expr1 t (List.concat [leading; inside; after_expr]); + rest) + else ( + attach t.leading expr1.pexp_loc leading; + walk_expression expr1 t inside; + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc after_expr; + rest) + in + if is_block_expr expr2 then walk_expression expr2 t rest + else + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + attach t.trailing expr2.pexp_loc trailing + | Pexp_for (pat, expr1, expr2, _, expr3) -> + let leading, inside, trailing = partition_by_loc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walk_pattern pat t inside; + let after_pat, rest = partition_adjacent_trailing pat.ppat_loc trailing in + attach t.trailing pat.ppat_loc after_pat; + let leading, inside, trailing = partition_by_loc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc leading; + walk_expression expr1 t inside; + let after_expr, rest = + partition_adjacent_trailing expr1.pexp_loc trailing + in + attach t.trailing expr1.pexp_loc after_expr; + let leading, inside, trailing = partition_by_loc rest expr2.pexp_loc in + attach t.leading expr2.pexp_loc leading; + walk_expression expr2 t inside; + let after_expr, rest = + partition_adjacent_trailing expr2.pexp_loc trailing + in + attach t.trailing expr2.pexp_loc after_expr; + if is_block_expr expr3 then walk_expression expr3 t rest + else + let leading, inside, trailing = partition_by_loc rest expr3.pexp_loc in + attach t.leading expr3.pexp_loc leading; + walk_expression expr3 t inside; + attach t.trailing expr3.pexp_loc trailing + | Pexp_pack mod_expr -> + let before, inside, after = partition_by_loc comments mod_expr.pmod_loc in + attach t.leading mod_expr.pmod_loc before; + walk_module_expr mod_expr t inside; + attach t.trailing mod_expr.pmod_loc after + | Pexp_match (expr1, [case; else_branch]) + when Res_parsetree_viewer.has_if_let_attribute expr.pexp_attributes -> + let before, inside, after = + partition_by_loc comments case.pc_lhs.ppat_loc + in + attach t.leading case.pc_lhs.ppat_loc before; + walk_pattern case.pc_lhs t inside; + let after_pat, rest = + partition_adjacent_trailing case.pc_lhs.ppat_loc after + in + attach t.trailing case.pc_lhs.ppat_loc after_pat; + let before, inside, after = partition_by_loc rest expr1.pexp_loc in + attach t.leading expr1.pexp_loc before; + walk_expression expr1 t inside; + let after_expr, rest = partition_adjacent_trailing expr1.pexp_loc after in + attach t.trailing expr1.pexp_loc after_expr; + let before, inside, after = partition_by_loc rest case.pc_rhs.pexp_loc in + let after = + if is_block_expr case.pc_rhs then ( + let after_expr, rest = + partition_adjacent_trailing case.pc_rhs.pexp_loc after + in + walk_expression case.pc_rhs t (List.concat [before; inside; after_expr]); + rest) + else ( + attach t.leading case.pc_rhs.pexp_loc before; + walk_expression case.pc_rhs t inside; + after) + in + let after_expr, rest = + partition_adjacent_trailing case.pc_rhs.pexp_loc after + in + attach t.trailing case.pc_rhs.pexp_loc after_expr; + let before, inside, after = + partition_by_loc rest else_branch.pc_rhs.pexp_loc + in + let after = + if is_block_expr else_branch.pc_rhs then ( + let after_expr, rest = + partition_adjacent_trailing else_branch.pc_rhs.pexp_loc after + in + walk_expression else_branch.pc_rhs t + (List.concat [before; inside; after_expr]); + rest) + else ( + attach t.leading else_branch.pc_rhs.pexp_loc before; + walk_expression else_branch.pc_rhs t inside; + after) + in + attach t.trailing else_branch.pc_rhs.pexp_loc after + | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> + let before, inside, after = partition_by_loc comments expr.pexp_loc in + let after = + if is_block_expr expr then ( + let after_expr, rest = + partition_adjacent_trailing expr.pexp_loc after + in + walk_expression expr t (List.concat [before; inside; after_expr]); + rest) + else ( + attach t.leading expr.pexp_loc before; + walk_expression expr t inside; + after) + in + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc after in + attach t.trailing expr.pexp_loc after_expr; + walk_list (cases |> List.map (fun case -> Case case)) t rest + (* unary expression: todo use parsetreeviewer *) + | Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident + { + txt = + Longident.Lident + ("~+" | "~+." | "~-" | "~-." | "~~~" | "not" | "!"); + }; + }; + args = [(Nolabel, arg_expr)]; + } -> + let before, inside, after = partition_by_loc comments arg_expr.pexp_loc in + attach t.leading arg_expr.pexp_loc before; + walk_expression arg_expr t inside; + attach t.trailing arg_expr.pexp_loc after + (* binary expression *) + | Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident + { + txt = + Longident.Lident + ( ":=" | "||" | "&&" | "==" | "===" | "<" | ">" | "!=" + | "!==" | "<=" | ">=" | "+" | "+." | "-" | "-." | "++" + | "|||" | "^^^" | "&&&" | "*" | "*." | "/" | "/." | "**" + | "->" | "<>" ); + }; + }; + args = [(Nolabel, operand1); (Nolabel, operand2)]; + } -> + let before, inside, after = partition_by_loc comments operand1.pexp_loc in + attach t.leading operand1.pexp_loc before; + walk_expression operand1 t inside; + let after_operand1, rest = + partition_adjacent_trailing operand1.pexp_loc after + in + attach t.trailing operand1.pexp_loc after_operand1; + let before, inside, after = partition_by_loc rest operand2.pexp_loc in + attach t.leading operand2.pexp_loc before; + walk_expression operand2 t inside; + (* (List.concat [inside; after]); *) + attach t.trailing operand2.pexp_loc after + | Pexp_apply + { + funct = + { + pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}; + }; + args = [(Nolabel, parent_expr); (Nolabel, member_expr)]; + } -> + walk_list [Expression parent_expr; Expression member_expr] t comments + | Pexp_apply + { + funct = + { + pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}; + }; + args = + [ + (Nolabel, parent_expr); + (Nolabel, member_expr); + (Nolabel, target_expr); + ]; + } -> + walk_list + [Expression parent_expr; Expression member_expr; Expression target_expr] + t comments + | Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident + {txt = Longident.Ldot (Lident "Primitive_dict", "make")}; + }; + args = [(Nolabel, key_values)]; + } + when Res_parsetree_viewer.is_tuple_array key_values -> + walk_list [Expression key_values] t comments + | Pexp_apply {funct = call_expr; args = arguments} -> ( + (* Special handling for Belt.Array.concatMany - treat like an array *) + match call_expr.pexp_desc with + | Pexp_ident + { + txt = + Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "Array"), "concatMany"); + } + when List.length arguments = 1 -> ( + match arguments with + | [(_, {pexp_desc = Pexp_array sub_arrays})] -> + (* Collect all individual expressions from sub-arrays *) + let all_exprs = + List.fold_left + (fun acc sub_array -> + match sub_array.Parsetree.pexp_desc with + | Pexp_array exprs -> acc @ exprs + | _ -> acc @ [sub_array]) + [] sub_arrays + in + walk_list (all_exprs |> List.map (fun e -> Expression e)) t comments + | _ -> + (* Fallback to regular apply handling *) + walk_apply_expr call_expr arguments t comments) + | _ -> + (* Regular apply handling *) + walk_apply_expr call_expr arguments t comments) + | Pexp_fun _ | Pexp_newtype _ -> ( + let _, parameters, return_expr = fun_expr expr in + let comments = + visit_list_but_continue_with_remaining_comments ~newline_delimited:false + ~walk_node:walk_expr_parameter + ~get_loc:(fun (_attrs, argLbl, expr_opt, pattern) -> + let label_loc = Asttypes.get_lbl_loc argLbl in + let open Parsetree in + let start_pos = + if label_loc <> Location.none then label_loc.loc_start + else pattern.ppat_loc.loc_start + in + match expr_opt with + | None -> {pattern.ppat_loc with loc_start = start_pos} + | Some expr -> + { + pattern.ppat_loc with + loc_start = start_pos; + loc_end = expr.pexp_loc.loc_end; + }) + parameters t comments + in + match return_expr.pexp_desc with + | Pexp_constraint (expr, typ) + when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum -> + let leading, inside, trailing = partition_by_loc comments typ.ptyp_loc in + attach t.leading typ.ptyp_loc leading; + walk_core_type typ t inside; + let after_typ, comments = + partition_adjacent_trailing typ.ptyp_loc trailing + in + attach t.trailing typ.ptyp_loc after_typ; + if is_block_expr expr then walk_expression expr t comments + else + let leading, inside, trailing = + partition_by_loc comments expr.pexp_loc + in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc trailing + | _ -> + if is_block_expr return_expr then walk_expression return_expr t comments + else + let leading, inside, trailing = + partition_by_loc comments return_expr.pexp_loc + in + attach t.leading return_expr.pexp_loc leading; + walk_expression return_expr t inside; + attach t.trailing return_expr.pexp_loc trailing) + | Pexp_jsx_element + (Jsx_fragment + { + jsx_fragment_opening = opening_greater_than; + jsx_fragment_children = children; + jsx_fragment_closing = _closing_lesser_than; + }) -> + let opening_token = {expr.pexp_loc with loc_end = opening_greater_than} in + let on_same_line, rest = partition_by_on_same_line opening_token comments in + attach t.trailing opening_token on_same_line; + let xs = children |> List.map (fun e -> Expression e) in + walk_list xs t rest + | Pexp_jsx_element + (Jsx_unary_element + { + jsx_unary_element_tag_name = tag_name; + jsx_unary_element_props = props; + }) -> ( + let closing_token_loc = + ParsetreeViewer.unary_element_closing_token expr.pexp_loc + in + + let after_opening_tag_name, rest = + (* Either the first prop or the closing /> token *) + let next_token = + match props with + | [] -> closing_token_loc + | head :: _ -> ParsetreeViewer.get_jsx_prop_loc head + in + let name_loc = tag_name.loc in + partition_adjacent_trailing_before_next_token_on_same_line name_loc + next_token comments + in + + (* Only attach comments to the element name if they are on the same line *) + let name_loc = tag_name.loc in + attach t.trailing name_loc after_opening_tag_name; + match props with + | [] -> + let before_closing_token, _rest = + partition_leading_trailing rest closing_token_loc + in + (* attach comments to the closing /> token *) + attach t.leading closing_token_loc before_closing_token + (* the _rest comments are going to be attached after the entire expression, + dealt with in the parent node. *) + | props -> + let comments_for_props, _rest = + partition_leading_trailing rest closing_token_loc + in + let prop_nodes = List.map (fun prop -> JsxProp prop) props in + walk_list prop_nodes t comments_for_props) + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = tag_name_start; + jsx_container_element_props = props; + jsx_container_element_opening_tag_end = opening_greater_than; + jsx_container_element_children = children; + jsx_container_element_closing_tag = closing_tag; + }) -> ( + let opening_greater_than_loc = + { + loc_start = opening_greater_than; + loc_end = opening_greater_than; + loc_ghost = false; + } + in + let after_opening_tag_name, rest = + (* Either the first prop or the closing > token *) + let next_token = + match props with + | [] -> opening_greater_than_loc + | head :: _ -> ParsetreeViewer.get_jsx_prop_loc head + in + let name_loc = tag_name_start.loc in + partition_adjacent_trailing_before_next_token_on_same_line name_loc + next_token comments + in + (* Only attach comments to the element name if they are on the same line *) + let name_loc = tag_name_start.loc in + attach t.trailing name_loc after_opening_tag_name; + let rest = + match props with + | [] -> + let before_greater_than, rest = + partition_leading_trailing rest opening_greater_than_loc + in + (* attach comments to the closing > token *) + attach t.leading opening_greater_than_loc before_greater_than; + rest + | props -> + let comments_for_props, rest = + partition_leading_trailing rest opening_greater_than_loc + in + let prop_nodes = List.map (fun prop -> JsxProp prop) props in + walk_list prop_nodes t comments_for_props; + rest + in + + (* comments after '>' on the same line should be attached to '>' *) + let after_opening_greater_than, rest = + partition_by_on_same_line opening_greater_than_loc rest + in + attach t.trailing opening_greater_than_loc after_opening_greater_than; + + let comments_for_children, _rest = + match closing_tag with + | None -> (rest, []) + | Some closing_tag -> + let closing_tag_loc = + ParsetreeViewer.container_element_closing_tag_loc closing_tag + in + partition_leading_trailing rest closing_tag_loc + in + match children with + | [] -> ( + (* attach all comments to the closing tag if there are no children *) + match closing_tag with + | None -> + (* if there is no closing tag, the comments will attached after the expression *) + () + | Some closing_tag -> + let closing_tag_loc = + ParsetreeViewer.container_element_closing_tag_loc closing_tag + in + if + opening_greater_than_loc.loc_end.pos_lnum + < closing_tag_loc.loc_start.pos_lnum + 1 + then ( + (* In this case, there are no children but there are comments between the opening and closing tag, + We can attach these the inside table, to easily print them later as indented comments + For example: +
+ // comment 1 + // comment 2 +
+ *) + let inside_comments, leading_for_closing_tag = + partition_between_lines opening_greater_than_loc.loc_end.pos_lnum + closing_tag_loc.loc_start.pos_lnum comments_for_children + in + attach t.inside expr.pexp_loc inside_comments; + attach t.leading closing_tag_loc leading_for_closing_tag) + else + (* if the closing tag is on the same line, attach comments to the opening tag *) + attach t.leading closing_tag_loc comments_for_children) + | children -> + let children_nodes = List.map (fun e -> Expression e) children in + + walk_list children_nodes t comments_for_children + (* It is less likely that there are comments inside the closing tag, + so we don't process them right now, + if you ever need this, feel free to update process _rest. + Comments after the closing tag will already be taking into account by the parent node. *) + ) + | Pexp_await expr -> walk_expression expr t comments + | Pexp_send _ -> () + +and walk_expr_parameter (_attrs, _argLbl, expr_opt, pattern) t comments = + let leading, inside, trailing = partition_by_loc comments pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walk_pattern pattern t inside; + match expr_opt with + | Some expr -> + let _afterPat, rest = + partition_adjacent_trailing pattern.ppat_loc trailing + in + attach t.trailing pattern.ppat_loc trailing; + if is_block_expr expr then walk_expression expr t rest + else + let leading, inside, trailing = partition_by_loc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc trailing + | None -> attach t.trailing pattern.ppat_loc trailing + +and walk_expr_argument expr loc t comments = + let leading, trailing = partition_leading_trailing comments loc in + attach t.leading loc leading; + let after_label, rest = partition_adjacent_trailing loc trailing in + attach t.trailing loc after_label; + let before, inside, after = partition_by_loc rest expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc after + +and walk_case (case : Parsetree.case) t comments = + let before, inside, after = partition_by_loc comments case.pc_lhs.ppat_loc in + (* cases don't have a location on their own, leading comments should go + * after the bar on the pattern *) + walk_pattern case.pc_lhs t (List.concat [before; inside]); + let after_pat, rest = + partition_adjacent_trailing case.pc_lhs.ppat_loc after + in + attach t.trailing case.pc_lhs.ppat_loc after_pat; + let comments = + match case.pc_guard with + | Some expr -> + let before, inside, after = partition_by_loc rest expr.pexp_loc in + let after_expr, rest = partition_adjacent_trailing expr.pexp_loc after in + if is_block_expr expr then + walk_expression expr t (List.concat [before; inside; after_expr]) + else ( + attach t.leading expr.pexp_loc before; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc after_expr); + rest + | None -> rest + in + if is_block_expr case.pc_rhs then walk_expression case.pc_rhs t comments + else + let before, inside, after = + partition_by_loc comments case.pc_rhs.pexp_loc + in + attach t.leading case.pc_rhs.pexp_loc before; + walk_expression case.pc_rhs t inside; + attach t.trailing case.pc_rhs.pexp_loc after + +and walk_expr_record_row (longident, expr) t comments = + let before_longident, after_longident = + partition_leading_trailing comments longident.loc + in + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident + in + attach t.trailing longident.loc after_longident; + let leading, inside, trailing = partition_by_loc rest expr.pexp_loc in + attach t.leading expr.pexp_loc leading; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc trailing + +and walk_extension_constructor ext_constr t comments = + let leading, trailing = + partition_leading_trailing comments ext_constr.pext_name.loc + in + attach t.leading ext_constr.pext_name.loc leading; + let after_name, rest = + partition_adjacent_trailing ext_constr.pext_name.loc trailing + in + attach t.trailing ext_constr.pext_name.loc after_name; + walk_extension_constructor_kind ext_constr.pext_kind t rest + +and walk_extension_constructor_kind kind t comments = + match kind with + | Pext_rebind longident -> + let leading, trailing = partition_leading_trailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pext_decl (constructor_arguments, maybe_typ_expr) -> ( + let rest = walk_constructor_arguments constructor_arguments t comments in + match maybe_typ_expr with + | None -> () + | Some typexpr -> + let before, inside, after = partition_by_loc rest typexpr.ptyp_loc in + attach t.leading typexpr.ptyp_loc before; + walk_core_type typexpr t inside; + attach t.trailing typexpr.ptyp_loc after) + +and walk_module_expr mod_expr t comments = + match mod_expr.pmod_desc with + | Pmod_ident longident -> + let before, after = partition_leading_trailing comments longident.loc in + attach t.leading longident.loc before; + attach t.trailing longident.loc after + | Pmod_structure [] -> attach t.inside mod_expr.pmod_loc comments + | Pmod_structure structure -> walk_structure structure t comments + | Pmod_extension extension -> walk_extension extension t comments + | Pmod_unpack expr -> + let before, inside, after = partition_by_loc comments expr.pexp_loc in + attach t.leading expr.pexp_loc before; + walk_expression expr t inside; + attach t.trailing expr.pexp_loc after + | Pmod_constraint (modexpr, modtype) -> + if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( + let before, inside, after = partition_by_loc comments modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walk_module_expr modexpr t inside; + let after, rest = partition_adjacent_trailing modexpr.pmod_loc after in + attach t.trailing modexpr.pmod_loc after; + let before, inside, after = partition_by_loc rest modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walk_mod_type modtype t inside; + attach t.trailing modtype.pmty_loc after) + else + let before, inside, after = partition_by_loc comments modtype.pmty_loc in + attach t.leading modtype.pmty_loc before; + walk_mod_type modtype t inside; + let after, rest = partition_adjacent_trailing modtype.pmty_loc after in + attach t.trailing modtype.pmty_loc after; + let before, inside, after = partition_by_loc rest modexpr.pmod_loc in + attach t.leading modexpr.pmod_loc before; + walk_module_expr modexpr t inside; + attach t.trailing modexpr.pmod_loc after + | Pmod_apply (_callModExpr, _argModExpr) -> + let mod_exprs = mod_expr_apply mod_expr in + walk_list (mod_exprs |> List.map (fun me -> ModuleExpr me)) t comments + | Pmod_functor _ -> ( + let parameters, return_mod_expr = mod_expr_functor mod_expr in + let comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (_, lbl, mod_type_option) -> + match mod_type_option with + | None -> lbl.Asttypes.loc + | Some mod_type -> + {lbl.loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end}) + ~walk_node:walk_mod_expr_parameter ~newline_delimited:false parameters t + comments + in + match return_mod_expr.pmod_desc with + | Pmod_constraint (mod_expr, mod_type) + when mod_type.pmty_loc.loc_end.pos_cnum + <= mod_expr.pmod_loc.loc_start.pos_cnum -> + let before, inside, after = partition_by_loc comments mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + let after, rest = partition_adjacent_trailing mod_type.pmty_loc after in + attach t.trailing mod_type.pmty_loc after; + let before, inside, after = partition_by_loc rest mod_expr.pmod_loc in + attach t.leading mod_expr.pmod_loc before; + walk_module_expr mod_expr t inside; + attach t.trailing mod_expr.pmod_loc after + | _ -> + let before, inside, after = + partition_by_loc comments return_mod_expr.pmod_loc + in + attach t.leading return_mod_expr.pmod_loc before; + walk_module_expr return_mod_expr t inside; + attach t.trailing return_mod_expr.pmod_loc after) + +and walk_mod_expr_parameter parameter t comments = + let _attrs, lbl, mod_type_option = parameter in + let leading, trailing = partition_leading_trailing comments lbl.loc in + attach t.leading lbl.loc leading; + match mod_type_option with + | None -> attach t.trailing lbl.loc trailing + | Some mod_type -> + let after_lbl, rest = partition_adjacent_trailing lbl.loc trailing in + attach t.trailing lbl.loc after_lbl; + let before, inside, after = partition_by_loc rest mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after + +and walk_mod_type mod_type t comments = + match mod_type.pmty_desc with + | Pmty_ident longident | Pmty_alias longident -> + let leading, trailing = partition_leading_trailing comments longident.loc in + attach t.leading longident.loc leading; + attach t.trailing longident.loc trailing + | Pmty_signature [] -> attach t.inside mod_type.pmty_loc comments + | Pmty_signature signature -> walk_signature signature t comments + | Pmty_extension extension -> walk_extension extension t comments + | Pmty_typeof mod_expr -> + let before, inside, after = partition_by_loc comments mod_expr.pmod_loc in + attach t.leading mod_expr.pmod_loc before; + walk_module_expr mod_expr t inside; + attach t.trailing mod_expr.pmod_loc after + | Pmty_with (mod_type, _withConstraints) -> + let before, inside, after = partition_by_loc comments mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after + (* TODO: withConstraints*) + | Pmty_functor _ -> + let parameters, return_mod_type = functor_type mod_type in + let comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (_, lbl, mod_type_option) -> + match mod_type_option with + | None -> lbl.Asttypes.loc + | Some mod_type -> + if lbl.txt = "_" then mod_type.Parsetree.pmty_loc + else {lbl.loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end}) + ~walk_node:walk_mod_type_parameter ~newline_delimited:false parameters t + comments + in + let before, inside, after = + partition_by_loc comments return_mod_type.pmty_loc + in + attach t.leading return_mod_type.pmty_loc before; + walk_mod_type return_mod_type t inside; + attach t.trailing return_mod_type.pmty_loc after + +and walk_mod_type_parameter (_, lbl, mod_type_option) t comments = + let leading, trailing = partition_leading_trailing comments lbl.loc in + attach t.leading lbl.loc leading; + match mod_type_option with + | None -> attach t.trailing lbl.loc trailing + | Some mod_type -> + let after_lbl, rest = partition_adjacent_trailing lbl.loc trailing in + attach t.trailing lbl.loc after_lbl; + let before, inside, after = partition_by_loc rest mod_type.pmty_loc in + attach t.leading mod_type.pmty_loc before; + walk_mod_type mod_type t inside; + attach t.trailing mod_type.pmty_loc after + +and walk_pattern pat t comments = + let open Location in + match pat.Parsetree.ppat_desc with + | _ when comments = [] -> () + | Ppat_alias (pat, alias) -> + let leading, inside, trailing = partition_by_loc comments pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walk_pattern pat t inside; + let after_pat, rest = partition_adjacent_trailing pat.ppat_loc trailing in + attach t.leading pat.ppat_loc leading; + attach t.trailing pat.ppat_loc after_pat; + let before_alias, after_alias = partition_leading_trailing rest alias.loc in + attach t.leading alias.loc before_alias; + attach t.trailing alias.loc after_alias + | Ppat_tuple [] + | Ppat_array [] + | Ppat_construct ({txt = Longident.Lident "()"}, _) + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> + attach t.inside pat.ppat_loc comments + | Ppat_array patterns -> + walk_list (patterns |> List.map (fun p -> Pattern p)) t comments + | Ppat_tuple patterns -> + walk_list (patterns |> List.map (fun p -> Pattern p)) t comments + | Ppat_construct ({txt = Longident.Lident "::"}, _) -> + walk_list + (collect_list_patterns [] pat |> List.map (fun p -> Pattern p)) + t comments + | Ppat_construct (constr, None) -> + let before_constr, after_constr = + partition_leading_trailing comments constr.loc + in + attach t.leading constr.loc before_constr; + attach t.trailing constr.loc after_constr + | Ppat_construct (constr, Some pat) -> + let leading, trailing = partition_leading_trailing comments constr.loc in + attach t.leading constr.loc leading; + let after_constructor, rest = + partition_adjacent_trailing constr.loc trailing + in + attach t.trailing constr.loc after_constructor; + let leading, inside, trailing = partition_by_loc rest pat.ppat_loc in + attach t.leading pat.ppat_loc leading; + walk_pattern pat t inside; + attach t.trailing pat.ppat_loc trailing + | Ppat_variant (_label, None) -> () + | Ppat_variant (_label, Some pat) -> walk_pattern pat t comments + | Ppat_type _ -> () + | Ppat_record (record_rows, _) -> + walk_list + (Ext_list.map record_rows (fun {lid; x = p} -> PatternRecordRow (lid, p))) + t comments + | Ppat_or _ -> + walk_list + (Res_parsetree_viewer.collect_or_pattern_chain pat + |> List.map (fun pat -> Pattern pat)) + t comments + | Ppat_constraint (pattern, typ) -> + let before_pattern, inside_pattern, after_pattern = + partition_by_loc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc before_pattern; + walk_pattern pattern t inside_pattern; + let after_pattern, rest = + partition_adjacent_trailing pattern.ppat_loc after_pattern + in + attach t.trailing pattern.ppat_loc after_pattern; + let before_typ, inside_typ, after_typ = + partition_by_loc rest typ.ptyp_loc + in + attach t.leading typ.ptyp_loc before_typ; + walk_core_type typ t inside_typ; + attach t.trailing typ.ptyp_loc after_typ + | Ppat_exception pattern -> + let leading, inside, trailing = + partition_by_loc comments pattern.ppat_loc + in + attach t.leading pattern.ppat_loc leading; + walk_pattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing + | Ppat_unpack string_loc -> + let leading, trailing = + partition_leading_trailing comments string_loc.loc + in + attach t.leading string_loc.loc leading; + attach t.trailing string_loc.loc trailing + | Ppat_extension extension -> walk_extension extension t comments + | _ -> () + +(* name: firstName *) +and walk_pattern_record_row row t comments = + match row with + (* punned {x}*) + | ( {Location.txt = Longident.Lident ident; loc = longident_loc}, + {Parsetree.ppat_desc = Ppat_var {txt; _}} ) + when ident = txt -> + let before_lbl, after_lbl = + partition_leading_trailing comments longident_loc + in + attach t.leading longident_loc before_lbl; + attach t.trailing longident_loc after_lbl + | longident, pattern -> + let before_lbl, after_lbl = + partition_leading_trailing comments longident.loc + in + attach t.leading longident.loc before_lbl; + let after_lbl, rest = partition_adjacent_trailing longident.loc after_lbl in + attach t.trailing longident.loc after_lbl; + let leading, inside, trailing = partition_by_loc rest pattern.ppat_loc in + attach t.leading pattern.ppat_loc leading; + walk_pattern pattern t inside; + attach t.trailing pattern.ppat_loc trailing + +and walk_row_field (row_field : Parsetree.row_field) t comments = + match row_field with + | Parsetree.Rtag ({loc}, _, _, _) -> + let before, after = partition_leading_trailing comments loc in + attach t.leading loc before; + attach t.trailing loc after + | Rinherit _ -> () + +and walk_core_type typ t comments = + match typ.Parsetree.ptyp_desc with + | _ when comments = [] -> () + | Ptyp_tuple typexprs -> + walk_list (typexprs |> List.map (fun ct -> CoreType ct)) t comments + | Ptyp_extension extension -> walk_extension extension t comments + | Ptyp_package package_type -> walk_package_type package_type t comments + | Ptyp_alias (typexpr, _alias) -> + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + | Ptyp_poly (strings, typexpr) -> + let comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun n -> n.Asttypes.loc) + ~walk_node:(fun longident t comments -> + let before_longident, after_longident = + partition_leading_trailing comments longident.loc + in + attach t.leading longident.loc before_longident; + attach t.trailing longident.loc after_longident) + ~newline_delimited:false strings t comments + in + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + | Ptyp_variant (row_fields, _, _) -> + walk_list (row_fields |> List.map (fun rf -> RowField rf)) t comments + | Ptyp_constr (longident, typexprs) -> + let before_longident, _afterLongident = + partition_leading_trailing comments longident.loc + in + let after_longident, rest = + partition_adjacent_trailing longident.loc comments + in + attach t.leading longident.loc before_longident; + attach t.trailing longident.loc after_longident; + walk_list (typexprs |> List.map (fun ct -> CoreType ct)) t rest + | Ptyp_arrow _ -> + let _, parameters, typexpr = arrow_type typ in + let comments = walk_type_parameters parameters t comments in + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + | Ptyp_object (fields, _) -> walk_typ_object_fields fields t comments + | _ -> () + +and walk_typ_object_fields fields t comments = + walk_list (fields |> List.map (fun f -> ObjectField f)) t comments + +and walk_object_field field t comments = + match field with + | Otag (lbl, _, typexpr) -> + let before_lbl, after_lbl = partition_leading_trailing comments lbl.loc in + attach t.leading lbl.loc before_lbl; + let after_lbl, rest = partition_adjacent_trailing lbl.loc after_lbl in + attach t.trailing lbl.loc after_lbl; + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + | _ -> () + +and walk_type_parameters type_parameters t comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (_, lbl, typexpr) -> + let lbl_loc = Asttypes.get_lbl_loc lbl in + if lbl_loc <> Location.none then + {lbl_loc with loc_end = typexpr.Parsetree.ptyp_loc.loc_end} + else typexpr.ptyp_loc) + ~walk_node:walk_type_parameter ~newline_delimited:false type_parameters t + comments + +and walk_type_parameter (_attrs, _lbl, typexpr) t comments = + let before_typ, inside_typ, after_typ = + partition_by_loc comments typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + +and walk_package_type package_type t comments = + let longident, package_constraints = package_type in + let before_longident, after_longident = + partition_leading_trailing comments longident.loc + in + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident + in + attach t.trailing longident.loc after_longident; + walk_package_constraints package_constraints t rest + +and walk_package_constraints package_constraints t comments = + walk_list + (package_constraints + |> List.map (fun (li, te) -> PackageConstraint (li, te))) + t comments + +and walk_package_constraint package_constraint t comments = + let longident, typexpr = package_constraint in + let before_longident, after_longident = + partition_leading_trailing comments longident.loc + in + attach t.leading longident.loc before_longident; + let after_longident, rest = + partition_adjacent_trailing longident.loc after_longident + in + attach t.trailing longident.loc after_longident; + let before_typ, inside_typ, after_typ = + partition_by_loc rest typexpr.ptyp_loc + in + attach t.leading typexpr.ptyp_loc before_typ; + walk_core_type typexpr t inside_typ; + attach t.trailing typexpr.ptyp_loc after_typ + +and walk_extension extension t comments = + let id, payload = extension in + let before_id, after_id = partition_leading_trailing comments id.loc in + attach t.leading id.loc before_id; + let after_id, rest = partition_adjacent_trailing id.loc after_id in + attach t.trailing id.loc after_id; + walk_payload payload t rest + +and walk_attribute (id, payload) t comments = + let before_id, after_id = partition_leading_trailing comments id.loc in + attach t.leading id.loc before_id; + let after_id, rest = partition_adjacent_trailing id.loc after_id in + attach t.trailing id.loc after_id; + walk_payload payload t rest + +and walk_payload payload t comments = + match payload with + | PStr s -> walk_structure s t comments + | _ -> () + +and walk_jsx_prop prop t comments = + match prop with + | Parsetree.JSXPropPunning _ -> + (* this is covered by walk_list, as the location for the prop is cover there. *) + () + | Parsetree.JSXPropValue (name, _, value) -> + if name.loc.loc_end.pos_lnum == value.pexp_loc.loc_start.pos_lnum then + (* In the rare case that comments are found between name=value, + where both are on the same line, + we assign them to the value, and not to the name. *) + walk_list [Expression value] t comments + else + (* otherwise we attach comments that come directly after the name to the name *) + let after_name, rest = partition_by_on_same_line name.loc comments in + attach t.trailing name.loc after_name; + walk_list [Expression value] t rest + | Parsetree.JSXPropSpreading (_, value) -> + (* We assign all comments to the spreaded expression *) + walk_list [Expression value] t comments diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml new file mode 100644 index 0000000..0d7ef55 --- /dev/null +++ b/compiler/syntax/src/res_core.ml @@ -0,0 +1,7365 @@ +module Doc = Res_doc +module Grammar = Res_grammar +module Token = Res_token +module Diagnostics = Res_diagnostics +module CommentTable = Res_comments_table +module ResPrinter = Res_printer +module Scanner = Res_scanner +module Parser = Res_parser + +let mk_loc start_loc end_loc = + Location.{loc_start = start_loc; loc_end = end_loc; loc_ghost = false} + +let rec skip_doc_comments p = + match p.Parser.token with + | DocComment _ -> + Parser.next p; + skip_doc_comments p + | _ -> () + +type inline_types_context = { + mutable found_inline_types: + (string * Warnings.loc * Parsetree.type_kind) list; + params: (Parsetree.core_type * Asttypes.variance) list; +} + +let extend_current_type_name_path current_type_name_path field_name = + match current_type_name_path with + | None -> None + | Some path -> Some (path @ [field_name]) + +module Recover = struct + let default_expr () = + let id = Location.mknoloc "rescript.exprhole" in + Ast_helper.Exp.mk (Pexp_extension (id, PStr [])) + + let default_type () = + let id = Location.mknoloc "rescript.typehole" in + Ast_helper.Typ.extension (id, PStr []) + + let default_pattern () = + let id = Location.mknoloc "rescript.patternhole" in + Ast_helper.Pat.extension (id, PStr []) + + let default_module_expr () = Ast_helper.Mod.structure [] + let default_module_type () = Ast_helper.Mty.signature [] + + let default_signature_item = + let id = Location.mknoloc "rescript.sigitemhole" in + Ast_helper.Sig.extension (id, PStr []) + + let recover_equal_greater p = + Parser.expect EqualGreater p; + match p.Parser.token with + | MinusGreater -> Parser.next p + | _ -> () + + let should_abort_list_parse p = + let rec check breadcrumbs = + match breadcrumbs with + | [] -> false + | (grammar, _) :: rest -> + if Grammar.is_part_of_list grammar p.Parser.token then true + else check rest + in + check p.breadcrumbs +end + +module ErrorMessages = struct + let list_pattern_spread = + "List pattern matches only supports one `...` spread, at the end.\n\ + Explanation: a list spread at the tail is efficient, but a spread in the \ + middle would create new lists; out of performance concern, our pattern \ + matching currently guarantees to never create new intermediate data." + + let record_pattern_spread = + "Record spread (`...`) is not supported in pattern matches.\n\ + Explanation: you can't collect a subset of a record's field into its own \ + record, since a record needs an explicit declaration and that subset \ + wouldn't have one.\n\ + Solution: you need to pull out each field you want explicitly." + (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) + [@@live] + + let array_pattern_spread = + "Array spread (`...`) is not supported in pattern matches.\n\n\ + Explanation: Allowing `...` here would require creating a new subarray at \ + match time, but for performance reasons pattern matching is guaranteed to \ + never create intermediate data.\n\n\ + Possible solutions:\n\ + - To validate specific elements: Use `if` with length checks and \ + `Array.get`\n\ + - To extract a subarray: Use `Array.slice`" + + let record_expr_spread = + "Records can only have one `...` spread, at the beginning.\n\ + Explanation: since records have a known, fixed shape, a spread like `{a, \ + ...b}` wouldn't make sense, as `b` would override every field of `a` \ + anyway." + + let dict_expr_spread = "Dict literals do not support spread (`...`) yet." + + let record_field_missing_colon = + "Records use `:` when assigning fields. Example: `{field: value}`" + + let record_pattern_field_missing_colon = + "Record patterns use `:` when matching fields. Example: `{field: value}`" + + let record_type_field_missing_colon = + "Record fields in type declarations use `:`. Example: `{field: string}`" + + let dict_field_missing_colon = + "Dict entries use `:` to separate keys from values. Example: `{\"k\": v}`" + + let labelled_argument_missing_equal = + "Use `=` to pass a labelled argument. Example: `~label=value`" + + let optional_labelled_argument_missing_equal = + "Optional labelled arguments use `=?`. Example: `~label=?value`" + + let variant_ident = + "A polymorphic variant (e.g. #id) must start with an alphabetical letter \ + or be a number (e.g. #742)" + + let experimental_if_let expr = + let switch_expr = {expr with Parsetree.pexp_attributes = []} in + Doc.concat + [ + Doc.text "If-let is currently highly experimental."; + Doc.line; + Doc.text "Use a regular `switch` with pattern matching instead:"; + Doc.concat + [ + Doc.hard_line; + Doc.hard_line; + ResPrinter.print_expression switch_expr CommentTable.empty; + ]; + ] + |> Doc.to_string ~width:80 + + let experimental_let_unwrap_rec = + "let? is not allowed to be recursive. Use a regular `let` or remove `rec`." + + let experimental_let_unwrap_sig = + "let? is not allowed in signatures. Use a regular `let` instead." + + let type_param = + "A type param consists of a singlequote followed by a name like `'a` or \ + `'A`" + let type_var = + "A type variable consists of a singlequote followed by a name like `'a` or \ + `'A`" + + let attribute_without_node (attr : Parsetree.attribute) = + let {Asttypes.txt = attr_name}, _ = attr in + "Did you forget to attach `" ^ attr_name + ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" + ^ attr_name ^ "`" + + let type_declaration_name_longident longident = + "A type declaration's name cannot contain a module access. Did you mean `" + ^ Longident.last longident ^ "`?" + + let tuple_single_element = "A tuple needs at least two elements" + + let missing_tilde_labeled_parameter name = + if name = "" then "A labeled parameter starts with a `~`." + else "A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?" + + let string_interpolation_in_pattern = + "String interpolation is not supported in pattern matching." + + let object_quoted_field_name name = + "An object type declaration needs quoted field names. Did you mean \"" + ^ name ^ "\"?" + + let forbidden_inline_record_declaration = + "An inline record type declaration is only allowed in a variant \ + constructor's declaration or nested inside of a record type declaration" + + let poly_var_int_with_suffix number = + "A numeric polymorphic variant cannot be followed by a letter. Did you \ + mean `#" ^ number ^ "`?" + + let multiple_inline_record_definitions_at_same_path = + "Only one inline record definition is allowed per record field. This \ + defines more than one inline record." + + let keyword_field_in_expr keyword_txt = + "Cannot use keyword `" ^ keyword_txt + ^ "` as a record field name. Suggestion: rename it (e.g. `" ^ keyword_txt + ^ "_`)" + + let keyword_field_in_pattern keyword_txt = + "Cannot use keyword `" ^ keyword_txt + ^ "` here. Keywords are not allowed as record field names." + + let keyword_field_in_type keyword_txt = + "Cannot use keyword `" ^ keyword_txt + ^ "` as a record field name. Suggestion: rename it (e.g. `" ^ keyword_txt + ^ "_`)\n If you need the field to be \"" ^ keyword_txt + ^ "\" at runtime, annotate the field: `@as(\"" ^ keyword_txt ^ "\") " + ^ keyword_txt ^ "_ : ...`" + + let type_definition_in_function = + "Type definitions are not allowed inside functions.\n" + ^ " Move this `type` declaration to the top level or into a module." + + let spread_children_no_longer_supported = + "Spreading JSX children is no longer supported." +end + +module InExternal = struct + let status = ref false +end + +let ternary_attr = (Location.mknoloc "res.ternary", Parsetree.PStr []) +let if_let_attr = (Location.mknoloc "res.iflet", Parsetree.PStr []) +let make_await_attr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) +let suppress_fragile_match_warning_attr = + ( Location.mknoloc "warning", + Parsetree.PStr + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant (Pconst_string ("-4", None))); + ] ) +let make_braces_attr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr []) +let template_literal_attr = (Location.mknoloc "res.template", Parsetree.PStr []) +let make_pat_variant_spread_attr = + (Location.mknoloc "res.patVariantSpread", Parsetree.PStr []) + +let tagged_template_literal_attr = + (Location.mknoloc "res.taggedTemplate", Parsetree.PStr []) + +let spread_attr = (Location.mknoloc "res.spread", Parsetree.PStr []) + +type argument = {label: Asttypes.arg_label; expr: Parsetree.expression} + +type type_parameter = { + attrs: Ast_helper.attrs; + label: Asttypes.arg_label; + typ: Parsetree.core_type; + start_pos: Lexing.position; +} + +type typ_def_or_ext = + | TypeDef of { + rec_flag: Asttypes.rec_flag; + types: Parsetree.type_declaration list; + } + | TypeExt of Parsetree.type_extension + +type fundef_type_param = { + attrs: Parsetree.attributes; + locs: string Location.loc list; + p_pos: Lexing.position; +} + +type fundef_term_param = { + attrs: Parsetree.attributes; + p_label: Asttypes.arg_label; + expr: Parsetree.expression option; + pat: Parsetree.pattern; + p_pos: Lexing.position; +} + +(* Single parameter of a function definition (type a b, x, ~y) *) +type fundef_parameter = + | TermParameter of fundef_term_param + | TypeParameter of fundef_type_param + +type record_pattern_item = + | PatUnderscore + | PatField of Parsetree.pattern Parsetree.record_element + +type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr + +(* Extracts type and term parameters from a list of function definition parameters, combining all type parameters into one *) +let rec extract_fundef_params ~(type_acc : fundef_type_param option) + ~(term_acc : fundef_term_param list) (params : fundef_parameter list) : + fundef_type_param option * fundef_term_param list = + match params with + | TermParameter tp :: rest -> + extract_fundef_params ~type_acc ~term_acc:(tp :: term_acc) rest + | TypeParameter tp :: rest -> + let type_acc = + match type_acc with + | Some tpa -> + Some + { + attrs = tpa.attrs @ tp.attrs; + locs = tpa.locs @ tp.locs; + p_pos = tpa.p_pos; + } + | None -> Some tp + in + extract_fundef_params ~type_acc ~term_acc rest + | [] -> (type_acc, List.rev term_acc) + +let get_closing_token = function + | Token.Lparen -> Token.Rparen + | Lbrace -> Rbrace + | Lbracket -> Rbracket + | List -> Rbrace + | Dict -> Rbrace + | LessThan -> GreaterThan + | _ -> assert false + +let rec go_to_closing closing_token state = + match (state.Parser.token, closing_token) with + | Rparen, Token.Rparen + | Rbrace, Rbrace + | Rbracket, Rbracket + | GreaterThan, GreaterThan -> + Parser.next state; + () + | ((Token.Lbracket | Lparen | Lbrace | List | Dict | LessThan) as t), _ -> + Parser.next state; + go_to_closing (get_closing_token t) state; + go_to_closing closing_token state + | (Rparen | Token.Rbrace | Rbracket | Eof), _ -> + () (* TODO: how do report errors here? *) + | _ -> + Parser.next state; + go_to_closing closing_token state + +(* Madness *) +let is_es6_arrow_expression ~in_ternary p = + Parser.lookahead p (fun state -> + let _async = + match state.Parser.token with + | Lident "async" -> + Parser.next state; + true + | _ -> false + in + match state.Parser.token with + | Lident _ | Underscore -> ( + Parser.next state; + match state.Parser.token with + (* Don't think that this valid + * Imagine: let x = (a: int) + * This is a parenthesized expression with a type constraint, wait for + * the arrow *) + (* | Colon when not inTernary -> true *) + | EqualGreater -> true + | _ -> false) + | Lparen -> ( + let prev_end_pos = state.prev_end_pos in + Parser.next state; + match state.token with + (* arrived at `()` here *) + | Rparen -> ( + Parser.next state; + match state.Parser.token with + (* arrived at `() :` here *) + | Colon when not in_ternary -> ( + Parser.next state; + match state.Parser.token with + (* arrived at `() :typ` here *) + | Lident _ -> ( + Parser.next state; + (match state.Parser.token with + (* arrived at `() :typ<` here *) + | LessThan -> + Scanner.set_diamond_mode state.scanner; + Parser.next state; + go_to_closing GreaterThan state; + Scanner.pop_mode state.scanner Diamond + | _ -> ()); + match state.Parser.token with + (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) + | EqualGreater -> true + | _ -> false) + | _ -> true) + | EqualGreater -> true + | _ -> false) + | Dot (* uncurried *) -> true + | Backtick -> + false + (* (` always indicates the start of an expr, can't be es6 parameter *) + | _ -> ( + go_to_closing Rparen state; + match state.Parser.token with + | EqualGreater -> true + (* | Lbrace TODO: detect missing =>, is this possible? *) + | Colon when not in_ternary -> true + | Rparen -> + (* imagine having something as : + * switch colour { + * | Red + * when l == l' + * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) + * We'll arrive at the outer rparen just before the =>. + * This is not an es6 arrow. + *) + false + | _ -> ( + Parser.next_unsafe state; + (* error recovery, peek at the next token, + * (elements, providerId] => { + * in the example above, we have an unbalanced ] here + *) + match state.Parser.token with + | EqualGreater + when state.start_pos.pos_lnum == prev_end_pos.pos_lnum -> + true + | _ -> false))) + | _ -> false) + +let is_es6_arrow_functor p = + Parser.lookahead p (fun state -> + match state.Parser.token with + (* | Uident _ | Underscore -> *) + (* Parser.next state; *) + (* begin match state.Parser.token with *) + (* | EqualGreater -> true *) + (* | _ -> false *) + (* end *) + | Lparen -> ( + Parser.next state; + match state.token with + | Rparen -> ( + Parser.next state; + match state.token with + | Colon | EqualGreater -> true + | _ -> false) + | _ -> ( + go_to_closing Rparen state; + match state.Parser.token with + | EqualGreater | Lbrace -> true + | Colon -> true + | _ -> false)) + | _ -> false) + +let is_es6_arrow_type p = + Parser.lookahead p (fun state -> + match state.Parser.token with + | Lparen -> ( + Parser.next state; + match state.Parser.token with + | Rparen -> ( + Parser.next state; + match state.Parser.token with + | EqualGreater -> true + | _ -> false) + | Tilde | Dot -> true + | _ -> ( + go_to_closing Rparen state; + match state.Parser.token with + | EqualGreater -> true + | _ -> false)) + | Tilde -> true + | _ -> false) + +let build_longident words = + match List.rev words with + | [] -> assert false + | hd :: tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl + +let emit_keyword_field_error (p : Parser.t) ~mk_message = + let keyword_txt = Token.to_string p.token in + let keyword_start = p.Parser.start_pos in + let keyword_end = p.Parser.end_pos in + Parser.err ~start_pos:keyword_start ~end_pos:keyword_end p + (Diagnostics.message (mk_message keyword_txt)) + +(* Recovers a keyword used as field name if it's probable that it's a full + field name (not punning etc), by checking if there's a colon after it. *) +let recover_keyword_field_name_if_probably_field p ~mk_message : + (string * Location.t) option = + if + Token.is_keyword p.Parser.token + && Parser.lookahead p (fun st -> + Parser.next st; + st.Parser.token = Colon) + then ( + emit_keyword_field_error p ~mk_message; + let loc = mk_loc p.Parser.start_pos p.Parser.end_pos in + let recovered_field_name = Token.to_string p.token ^ "_" in + Parser.next p; + Some (recovered_field_name, loc)) + else None + +let make_infix_operator (p : Parser.t) token start_pos end_pos = + let stringified_token = + if token = Token.Equal then ( + (* TODO: could have a totally different meaning like x->fooSet(y)*) + Parser.err ~start_pos ~end_pos p + (Diagnostics.message "Did you mean `==` here?"); + "=") + else Token.to_string token + in + let loc = mk_loc start_pos end_pos in + let operator = Location.mkloc (Longident.Lident stringified_token) loc in + Ast_helper.Exp.ident ~loc operator + +let negate_string s = + if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' then + (String.sub [@doesNotRaise]) s 1 (String.length s - 1) + else "-" ^ s + +let make_unary_expr start_pos token_end token operand = + match (token, operand.Parsetree.pexp_desc) with + | (Token.Plus | PlusDot), Pexp_constant (Pconst_integer _ | Pconst_float _) -> + operand + | Minus, Pexp_constant (Pconst_integer (n, m)) -> + { + operand with + pexp_desc = Pexp_constant (Pconst_integer (negate_string n, m)); + } + | (Minus | MinusDot), Pexp_constant (Pconst_float (n, m)) -> + {operand with pexp_desc = Pexp_constant (Pconst_float (negate_string n, m))} + | (Token.Plus | PlusDot | Minus | MinusDot | Bnot), _ -> + let token_loc = mk_loc start_pos token_end in + let token_string = Token.to_string token in + let operator = + if token_string.[0] = '~' then token_string else "~" ^ token_string + in + Ast_helper.Exp.apply + ~loc:(mk_loc start_pos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:token_loc + (Location.mkloc (Longident.Lident operator) token_loc)) + [(Nolabel, operand)] + | Token.Bang, _ -> + let token_loc = mk_loc start_pos token_end in + Ast_helper.Exp.apply + ~loc:(mk_loc start_pos operand.Parsetree.pexp_loc.loc_end) + (Ast_helper.Exp.ident ~loc:token_loc + (Location.mkloc (Longident.Lident "not") token_loc)) + [(Nolabel, operand)] + | _ -> operand + +let make_list_pattern loc seq ext_opt = + let rec handle_seq = function + | [] -> + let base_case = + match ext_opt with + | Some ext -> ext + | None -> + let loc = {loc with Location.loc_ghost = true} in + let nil = {Location.txt = Longident.Lident "[]"; loc} in + Ast_helper.Pat.construct ~loc nil None + in + base_case + | p1 :: pl -> + let pat_pl = handle_seq pl in + let loc = + mk_loc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end + in + let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in + Ast_helper.Pat.mk ~loc + (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) + in + handle_seq seq + +(* TODO: diagnostic reporting *) +let lident_of_path longident = + match Longident.flatten longident |> List.rev with + | [] -> "" + | ident :: _ -> ident + +let make_newtypes ~attrs ~loc newtypes exp = + let expr = + List.fold_right + (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) + newtypes exp + in + {expr with pexp_attributes = attrs} + +(* locally abstract types syntax sugar + * Transforms + * let f: type t u v. = (foo : list) => ... + * into + * let f = (type t u v. foo : list) => ... + *) +let wrap_type_annotation ~loc newtypes core_type body = + let exp = + make_newtypes ~attrs:[] ~loc newtypes + (Ast_helper.Exp.constraint_ ~loc body core_type) + in + let typ = + Ast_helper.Typ.poly ~loc newtypes + (Ast_helper.Typ.varify_constructors newtypes core_type) + in + (exp, typ) + +(** + * process the occurrence of _ in the arguments of a function application + * replace _ with a new variable, currently __x, in the arguments + * return a wrapping function that wraps ((__x) => ...) around an expression + * e.g. foo(_, 3) becomes (__x) => foo(__x, 3) + *) +let process_underscore_application args = + let exp_question = ref None in + let hidden_var = "__x" in + let check_arg ((lab, exp) as arg) = + match exp.Parsetree.pexp_desc with + | Pexp_ident ({txt = Lident "_"} as id) -> + let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in + let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in + exp_question := Some new_exp; + (lab, new_exp) + | _ -> arg + in + let args = List.map check_arg args in + let wrap (exp_apply : Parsetree.expression) = + match !exp_question with + | Some {pexp_loc = loc} -> + let pattern = + Ast_helper.Pat.mk + (Ppat_var (Location.mkloc hidden_var loc)) + ~loc:Location.none + in + Ast_helper.Exp.fun_ ~loc ~arity:(Some 1) Nolabel None pattern exp_apply + | None -> exp_apply + in + (args, wrap) + +(* Transform A.a into a. For use with punned record fields as in {A.a, b}. *) +let remove_module_name_from_punned_field_value exp = + match exp.Parsetree.pexp_desc with + | Pexp_ident path_ident -> + { + exp with + pexp_desc = + Pexp_ident + {path_ident with txt = Lident (Longident.last path_ident.txt)}; + } + | _ -> exp + +let rec parse_lident p = + let recover_lident p = + if + Token.is_keyword p.Parser.token + && p.Parser.prev_end_pos.pos_lnum == p.start_pos.pos_lnum + then ( + Parser.err p (Diagnostics.lident p.Parser.token); + Parser.next p; + None) + else + let rec loop p = + if (not (Recover.should_abort_list_parse p)) && p.token <> Eof then ( + Parser.next p; + loop p) + in + Parser.err p (Diagnostics.lident p.Parser.token); + Parser.next p; + loop p; + match p.Parser.token with + | Lident _ -> Some () + | _ -> None + in + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + (ident, loc) + | Eof -> + Parser.err ~start_pos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("_", mk_loc start_pos p.prev_end_pos) + | _ -> ( + match recover_lident p with + | Some () -> parse_lident p + | None -> ("_", mk_loc start_pos p.prev_end_pos)) + +let parse_ident ~msg ~start_pos p = + match p.Parser.token with + | Lident ident | Uident ident -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + (ident, loc) + | token + when Token.is_keyword token + && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let token_txt = Token.to_string token in + let msg = + "`" ^ token_txt + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token_txt + ^ "\"" + in + Parser.err ~start_pos p (Diagnostics.message msg); + Parser.next p; + (token_txt, mk_loc start_pos p.prev_end_pos) + | _token -> + Parser.err ~start_pos p (Diagnostics.message msg); + Parser.next p; + ("", mk_loc start_pos p.prev_end_pos) + +let parse_hash_ident ~start_pos p = + Parser.expect Hash p; + match p.token with + | String text -> + Parser.next p; + (text, mk_loc start_pos p.prev_end_pos) + | Int {i; suffix} -> + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message (ErrorMessages.poly_var_int_with_suffix i)) + | None -> () + in + Parser.next p; + (i, mk_loc start_pos p.prev_end_pos) + | Eof -> + Parser.err ~start_pos p (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mk_loc start_pos p.prev_end_pos) + | _ -> parse_ident ~start_pos ~msg:ErrorMessages.variant_ident p + +(* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) +let parse_value_path p = + let start_pos = p.Parser.start_pos in + let rec aux p path = + let start_pos = p.Parser.start_pos in + let token = p.token in + + Parser.next p; + if p.Parser.token = Dot then ( + Parser.expect Dot p; + + match p.Parser.token with + | Lident ident -> Longident.Ldot (path, ident) + | Uident uident -> aux p (Ldot (path, uident)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Longident.Ldot (path, "_")) + else ( + Parser.err p ~start_pos ~end_pos:p.prev_end_pos (Diagnostics.lident token); + path) + in + let ident = + match p.Parser.token with + | Lident ident -> + Parser.next p; + Longident.Lident ident + | Uident ident -> + let res = aux p (Lident ident) in + Parser.next_unsafe p; + res + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Parser.next_unsafe p; + Longident.Lident "_" + in + Location.mkloc ident (mk_loc start_pos p.prev_end_pos) + +let parse_value_path_after_dot p = + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | Lident _ | Uident _ -> parse_value_path p + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mkloc (Longident.Lident "_") (mk_loc start_pos p.prev_end_pos) + +let parse_value_path_tail p start_pos ident = + let rec loop p path = + match p.Parser.token with + | Lident ident -> + Parser.next p; + Location.mkloc + (Longident.Ldot (path, ident)) + (mk_loc start_pos p.prev_end_pos) + | Uident ident -> + Parser.next p; + Parser.expect Dot p; + loop p (Longident.Ldot (path, ident)) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Location.mkloc + (Longident.Ldot (path, "_")) + (mk_loc start_pos p.prev_end_pos) + in + loop p ident + +let parse_module_long_ident_tail ~lowercase p start_pos ident = + let rec loop p acc = + match p.Parser.token with + | Lident ident when lowercase -> + Parser.next p; + let lident = Longident.Ldot (acc, ident) in + Location.mkloc lident (mk_loc start_pos p.prev_end_pos) + | Uident ident -> ( + Parser.next p; + let end_pos = p.prev_end_pos in + let lident = Longident.Ldot (acc, ident) in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p lident + | _ -> Location.mkloc lident (mk_loc start_pos end_pos)) + | t -> + Parser.err p (Diagnostics.uident t); + Location.mkloc + (Longident.Ldot (acc, "_")) + (mk_loc start_pos p.prev_end_pos) + in + loop p ident + +(* jsx allows for `-` token in the name, we need to combine some tokens into a single ident *) +(* This function returns Some token when a combined token is created, None when no change is needed. + When it returns Some token: + - All immediately following ("-" IDENT) chunks have been consumed from the scanner + - No hyphen that belongs to the JSX name remains unconsumed + - The returned token is the combined Lident/Uident for the full name *) +(* Non-mutating helpers to parse JSX identifiers with optional hyphen chains *) +type jsx_ident_kind = [`Lower | `Upper] + +(* Inspect current token; do not advance *) +let peek_ident (p : Parser.t) : (string * Location.t * jsx_ident_kind) option = + match p.Parser.token with + | Lident txt -> Some (txt, mk_loc p.start_pos p.end_pos, `Lower) + | Uident txt -> Some (txt, mk_loc p.start_pos p.end_pos, `Upper) + | _ -> None + +(* Consume one Lident/Uident if present *) +let expect_ident (p : Parser.t) : (string * Location.t * jsx_ident_kind) option + = + match peek_ident p with + | None -> None + | Some (txt, loc, k) -> + Parser.next p; + Some (txt, loc, k) + +(* Consume ("-" IDENT)*, appending to buffer; update last_end; diagnose trailing '-' *) +let rec read_hyphen_chain (p : Parser.t) (buf : Buffer.t) + (last_end : Lexing.position ref) : unit = + match p.Parser.token with + | Minus -> ( + Parser.next p; + (* after '-' *) + match peek_ident p with + | Some (txt, _loc, _) -> + Buffer.add_char buf '-'; + Buffer.add_string buf txt; + (* consume ident *) + Parser.next p; + last_end := p.prev_end_pos; + read_hyphen_chain p buf last_end + | None -> + (* Match previous behavior: rely on parser's current location *) + Parser.err p + (Diagnostics.message "JSX identifier cannot end with a hyphen")) + | _ -> () + +(* Read local jsx name: returns combined name + loc + kind of head ident *) +let read_local_jsx_name (p : Parser.t) : + (string * Location.t * jsx_ident_kind) option = + match expect_ident p with + | None -> None + | Some (head, head_loc, kind) -> + let buf = Buffer.create (String.length head + 8) in + Buffer.add_string buf head; + let start_pos = head_loc.Location.loc_start in + let last_end = ref head_loc.Location.loc_end in + read_hyphen_chain p buf last_end; + let name = Buffer.contents buf in + let loc = mk_loc start_pos !last_end in + Some (name, loc, kind) + +(* Build a Longident from a non-empty list of segments *) +let longident_of_segments (segs : string list) : Longident.t = + match segs with + | [] -> invalid_arg "longident_of_segments: empty list" + | hd :: tl -> + List.fold_left + (fun acc s -> Longident.Ldot (acc, s)) + (Longident.Lident hd) tl + +(* Read a JSX tag name and return a jsx_tag_name; does not mutate tokens beyond what it consumes *) +let read_jsx_tag_name (p : Parser.t) : + (Parsetree.jsx_tag_name Location.loc, string) result = + match peek_ident p with + | None -> Error "" + | Some (_, _, `Lower) -> + read_local_jsx_name p + |> Option.map (fun (name, loc, _) -> + {Location.txt = Parsetree.JsxLowerTag name; loc}) + |> Option.to_result ~none:"" + | Some (first_seg, first_loc, `Upper) -> + let start_pos = first_loc.Location.loc_start in + (* consume first Uident *) + Parser.next p; + let string_of_rev_segments segs = String.concat "." (List.rev segs) in + let rec loop rev_segs last_end = + match p.Parser.token with + | Dot -> ( + Parser.next p; + (* after '.' *) + match peek_ident p with + | None -> + Parser.err p + (Diagnostics.message "expected identifier after '.' in JSX tag name"); + Error (string_of_rev_segments rev_segs ^ ".") + | Some (txt, _loc, `Upper) -> + (* another path segment *) + Parser.next p; + loop (txt :: rev_segs) p.prev_end_pos + | Some (_, _, `Lower) -> ( + (* final lowercase with optional hyphens *) + match read_local_jsx_name p with + | Some (lname, l_loc, _) -> ( + match rev_segs with + | [] -> Error "" + | _ -> + let path = longident_of_segments (List.rev rev_segs) in + let loc = mk_loc start_pos l_loc.Location.loc_end in + Ok + { + Location.txt = + Parsetree.JsxQualifiedLowerTag {path; name = lname}; + loc; + }) + | None -> Error "")) + | _ -> ( + (* pure Upper path *) + match rev_segs with + | [] -> Error "" + | _ -> + let path = longident_of_segments (List.rev rev_segs) in + let loc = mk_loc start_pos last_end in + Ok {txt = Parsetree.JsxUpperTag path; loc}) + in + (* seed with the first segment already consumed *) + loop [first_seg] first_loc.Location.loc_end + +(* Parses module identifiers: + Foo + Foo.Bar *) +let parse_module_long_ident ~lowercase p = + (* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *) + let start_pos = p.Parser.start_pos in + let module_ident = + match p.Parser.token with + | Lident ident when lowercase -> + let loc = mk_loc start_pos p.end_pos in + let lident = Longident.Lident ident in + Parser.next p; + Location.mkloc lident loc + | Uident ident -> ( + let lident = Longident.Lident ident in + let end_pos = p.end_pos in + Parser.next p; + match p.Parser.token with + | Dot -> + Parser.next p; + parse_module_long_ident_tail ~lowercase p start_pos lident + | _ -> Location.mkloc lident (mk_loc start_pos end_pos)) + | t -> + Parser.err p (Diagnostics.uident t); + Location.mkloc (Longident.Lident "_") (mk_loc start_pos p.prev_end_pos) + in + (* Parser.eatBreadcrumb p; *) + module_ident + +(* open-def ::= + * | open module-path + * | open! module-path *) +let parse_open_description ~attrs p = + Parser.leave_breadcrumb p Grammar.OpenDescription; + let start_pos = p.Parser.start_pos in + Parser.expect Open p; + let override = + if Parser.optional p Token.Bang then Asttypes.Override else Asttypes.Fresh + in + let modident = parse_module_long_ident ~lowercase:false p in + let loc = mk_loc start_pos p.prev_end_pos in + Parser.eat_breadcrumb p; + Ast_helper.Opn.mk ~loc ~attrs ~override modident + +(* constant ::= integer-literal *) +(* ∣ float-literal *) +(* ∣ string-literal *) +let parse_constant p = + let is_negative = + match p.Parser.token with + | Token.Minus -> + Parser.next p; + true + | Plus -> + Parser.next p; + false + | _ -> false + in + let constant = + match p.Parser.token with + | Int {i; suffix} -> + (* Only decimal literal is allowed for bigint *) + if suffix = Some 'n' && not (Bigint_utils.is_valid i) then + Parser.err p + (Diagnostics.message + "Invalid bigint literal. Only decimal literal is allowed for \ + bigint."); + let int_txt = if is_negative then "-" ^ i else i in + Parsetree.Pconst_integer (int_txt, suffix) + | Float {f; suffix} -> + let float_txt = if is_negative then "-" ^ f else f in + Parsetree.Pconst_float (float_txt, suffix) + | String s -> + Pconst_string (s, if p.mode = ParseForTypeChecker then Some "js" else None) + | Codepoint {c; original} -> + if p.mode = ParseForTypeChecker then Pconst_char c + else + (* Pconst_char char does not have enough information for formatting. + * When parsing for the printer, we encode the char contents as a string + * with a special prefix. *) + Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Pconst_string ("", None) + in + Parser.next_unsafe p; + constant + +let parse_template_constant ~prefix (p : Parser.t) = + (* Arrived at the ` char *) + let start_pos = p.start_pos in + Parser.next_template_literal_token p; + match p.token with + | TemplateTail (txt, _) -> + Parser.next p; + Parsetree.Pconst_string (txt, prefix) + | _ -> + let rec skip_tokens () = + if p.token <> Eof then ( + Parser.next p; + match p.token with + | Backtick -> + Parser.next p; + () + | _ -> skip_tokens ()) + in + skip_tokens (); + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.string_interpolation_in_pattern); + Pconst_string ("", None) + +let parse_comma_delimited_region p ~grammar ~closing ~f = + Parser.leave_breadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> ( + match p.Parser.token with + | Comma -> + Parser.next p; + loop (node :: nodes) + | token when token = closing || token = Eof -> List.rev (node :: nodes) + | _ when Grammar.is_list_element grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node :: nodes) + | _ -> + if + not + (p.token = Eof || p.token = closing + || Recover.should_abort_list_parse p) + then Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node :: nodes)) + | None -> + if p.token = Eof || p.token = closing || Recover.should_abort_list_parse p + then List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) + in + let nodes = loop [] in + Parser.eat_breadcrumb p; + nodes + +let parse_comma_delimited_reversed_list p ~grammar ~closing ~f = + Parser.leave_breadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> ( + match p.Parser.token with + | Comma -> + Parser.next p; + loop (node :: nodes) + | token when token = closing || token = Eof -> node :: nodes + | _ when Grammar.is_list_element grammar p.token -> + (* missing comma between nodes in the region and the current token + * looks like the start of something valid in the current region. + * Example: + * type student<'extraInfo> = { + * name: string, + * age: int + * otherInfo: 'extraInfo + * } + * There is a missing comma between `int` and `otherInfo`. + * `otherInfo` looks like a valid start of the record declaration. + * We report the error here and then continue parsing the region. + *) + Parser.expect Comma p; + loop (node :: nodes) + | _ -> + if + not + (p.token = Eof || p.token = closing + || Recover.should_abort_list_parse p) + then Parser.expect Comma p; + if p.token = Semicolon then Parser.next p; + loop (node :: nodes)) + | None -> + if p.token = Eof || p.token = closing || Recover.should_abort_list_parse p + then nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) + in + let nodes = loop [] in + Parser.eat_breadcrumb p; + nodes + +let parse_delimited_region p ~grammar ~closing ~f = + Parser.leave_breadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> loop (node :: nodes) + | None -> + if + p.Parser.token = Token.Eof || p.token = closing + || Recover.should_abort_list_parse p + then List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) + in + let nodes = loop [] in + Parser.eat_breadcrumb p; + nodes + +let parse_region p ~grammar ~f = + Parser.leave_breadcrumb p grammar; + let rec loop nodes = + match f p with + | Some node -> loop (node :: nodes) + | None -> + if p.Parser.token = Token.Eof || Recover.should_abort_list_parse p then + List.rev nodes + else ( + Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); + Parser.next p; + loop nodes) + in + let nodes = loop [] in + Parser.eat_breadcrumb p; + nodes + +(* let-binding ::= pattern = expr *) +(* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr *) +(* ∣ value-name : poly-typexpr = expr *) + +(* pattern ::= value-name *) +(* ∣ _ *) +(* ∣ constant *) +(* ∣ pattern as value-name *) +(* ∣ ( pattern ) *) +(* ∣ ( pattern : typexpr ) *) +(* ∣ pattern | pattern *) +(* ∣ constr pattern *) +(* ∣ #variant variant-pattern *) +(* ∣ #...type *) +(* ∣ / pattern { , pattern }+ / *) +(* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } *) +(* ∣ [ pattern { ; pattern } [ ; ] ] *) +(* ∣ pattern :: pattern *) +(* ∣ [| pattern { ; pattern } [ ; ] |] *) +(* ∣ char-literal .. char-literal *) +(* ∣ exception pattern *) +let rec parse_pattern ?(alias = true) ?(or_ = true) p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in + let pat = + match p.Parser.token with + | (True | False) as token -> + let end_pos = p.end_pos in + Parser.next p; + let loc = mk_loc start_pos end_pos in + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident (Token.to_string token)) loc) + None + | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( + let c = parse_constant p in + match p.token with + | DotDot -> + Parser.next p; + let c2 = parse_constant p in + Ast_helper.Pat.interval ~loc:(mk_loc start_pos p.prev_end_pos) c c2 + | _ -> Ast_helper.Pat.constant ~loc:(mk_loc start_pos p.prev_end_pos) c) + | Backtick -> + let constant = parse_template_constant ~prefix:(Some "js") p in + Ast_helper.Pat.constant ~attrs:[template_literal_attr] + ~loc:(mk_loc start_pos p.prev_end_pos) + constant + | Lparen -> ( + Parser.next p; + match p.token with + | Rparen -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct ~loc lid None + | _ -> ( + let pat = parse_constrained_pattern p in + match p.token with + | Comma -> + Parser.next p; + parse_tuple_pattern ~attrs ~first:pat ~start_pos p + | _ -> + Parser.expect Rparen p; + let loc = mk_loc start_pos p.prev_end_pos in + { + pat with + ppat_loc = loc; + ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; + })) + | Lbracket -> parse_array_pattern ~attrs p + | Lbrace -> parse_record_pattern ~attrs p + | Underscore -> + let end_pos = p.end_pos in + let loc = mk_loc start_pos end_pos in + Parser.next p; + Ast_helper.Pat.any ~loc ~attrs () + | Lident ident -> ( + let end_pos = p.end_pos in + let loc = mk_loc start_pos end_pos in + Parser.next p; + match p.token with + | Backtick -> + let constant = parse_template_constant ~prefix:(Some ident) p in + Ast_helper.Pat.constant ~loc:(mk_loc start_pos p.prev_end_pos) constant + | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) + | Uident _ -> ( + let constr = parse_module_long_ident ~lowercase:false p in + match p.Parser.token with + | Lparen -> parse_constructor_pattern_args p constr start_pos attrs + | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) + | DotDotDot -> + Parser.next p; + let ident = parse_value_path p in + let loc = mk_loc start_pos ident.loc.loc_end in + Ast_helper.Pat.type_ ~loc + ~attrs:(make_pat_variant_spread_attr :: attrs) + ident + | Hash -> ( + Parser.next p; + if p.Parser.token == DotDotDot then ( + Parser.next p; + let ident = parse_value_path p in + let loc = mk_loc start_pos ident.loc.loc_end in + Ast_helper.Pat.type_ ~loc ~attrs ident) + else + let ident, loc = + match p.token with + | String text -> + Parser.next p; + (text, mk_loc start_pos p.prev_end_pos) + | Int {i; suffix} -> + let () = + match suffix with + | Some _ -> + Parser.err p + (Diagnostics.message + (ErrorMessages.poly_var_int_with_suffix i)) + | None -> () + in + Parser.next p; + (i, mk_loc start_pos p.prev_end_pos) + | Eof -> + Parser.err ~start_pos p + (Diagnostics.unexpected p.token p.breadcrumbs); + ("", mk_loc start_pos p.prev_end_pos) + | _ -> parse_ident ~msg:ErrorMessages.variant_ident ~start_pos p + in + match p.Parser.token with + | Lparen -> parse_variant_pattern_args p ident start_pos attrs + | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) + | Exception -> + Parser.next p; + let pat = parse_pattern ~alias:false ~or_:false p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.exception_ ~loc ~attrs pat + | List -> + Parser.next p; + parse_list_pattern ~start_pos ~attrs p + | Dict -> + Parser.next p; + parse_dict_pattern ~start_pos ~attrs p + | Module -> parse_module_pattern ~attrs p + | Percent -> + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.extension ~loc ~attrs extension + | Eof -> + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.default_pattern () + | token -> ( + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skip_tokens_and_maybe_retry p + ~is_start_of_grammar:Grammar.is_atomic_pattern_start + with + | None -> Recover.default_pattern () + | Some () -> parse_pattern p) + in + let pat = if alias then parse_alias_pattern ~attrs pat p else pat in + if or_ then parse_or_pattern pat p else pat + +and skip_tokens_and_maybe_retry p ~is_start_of_grammar = + if + Token.is_keyword p.Parser.token + && p.Parser.prev_end_pos.pos_lnum == p.start_pos.pos_lnum + then ( + Parser.next p; + None) + else if Recover.should_abort_list_parse p then + if is_start_of_grammar p.Parser.token then ( + Parser.next p; + Some ()) + else None + else ( + Parser.next p; + let rec loop p = + if not (Recover.should_abort_list_parse p) then ( + Parser.next p; + loop p) + in + loop p; + if is_start_of_grammar p.Parser.token then Some () else None) + +(* alias ::= pattern as lident *) +and parse_alias_pattern ~attrs pattern p = + match p.Parser.token with + | As -> + Parser.next p; + let name, loc = parse_lident p in + let name = Location.mkloc name loc in + Ast_helper.Pat.alias + ~loc:{pattern.ppat_loc with loc_end = p.prev_end_pos} + ~attrs pattern name + | _ -> pattern + +(* or ::= pattern | pattern + * precedence: Red | Blue | Green is interpreted as (Red | Blue) | Green *) +and parse_or_pattern pattern1 p = + let rec loop pattern1 = + match p.Parser.token with + | Bar -> + Parser.next p; + let pattern2 = parse_pattern ~or_:false p in + let loc = + {pattern1.Parsetree.ppat_loc with loc_end = pattern2.ppat_loc.loc_end} + in + loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) + | _ -> pattern1 + in + loop pattern1 + +and parse_non_spread_pattern ~msg p = + let () = + match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message msg); + Parser.next p + | _ -> () + in + match p.Parser.token with + | token when Grammar.is_pattern_start token -> ( + let pat = parse_pattern p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parse_typ_expr p in + let loc = mk_loc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Some (Ast_helper.Pat.constraint_ ~loc pat typ) + | _ -> Some pat) + | _ -> None + +and parse_constrained_pattern p = + let pat = parse_pattern p in + match p.Parser.token with + | Colon -> + Parser.next p; + let typ = parse_typ_expr p in + let loc = mk_loc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in + Ast_helper.Pat.constraint_ ~loc pat typ + | _ -> pat + +and parse_constrained_pattern_region p = + match p.Parser.token with + | token when Grammar.is_pattern_start token -> + Some (parse_constrained_pattern p) + | _ -> None + +and parse_optional_label p = + match p.Parser.token with + | Question -> + Parser.next p; + true + | _ -> false + +(* field ::= + * | longident + * | longident : pattern + * | longident as lident + * + * row ::= + * | field , + * | field , _ + * | field , _, + *) +and parse_record_pattern_row_field ~attrs p = + let label = parse_value_path p in + let pattern, optional = + match p.Parser.token with + | Colon -> + Parser.next p; + let optional = parse_optional_label p in + let pat = parse_pattern p in + (pat, optional) + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_pattern_field_missing_colon); + Parser.next p; + let optional = parse_optional_label p in + let pat = parse_pattern p in + (pat, optional) + | _ -> + ( Ast_helper.Pat.var ~loc:label.loc ~attrs + (Location.mkloc (Longident.last label.txt) label.loc), + false ) + in + {Parsetree.lid = label; x = pattern; opt = optional} + +(* TODO: there are better representations than PatField|Underscore ? *) +and parse_record_pattern_row p = + let attrs = parse_attributes p in + match p.Parser.token with + | DotDotDot -> + Parser.next p; + Some (true, PatField (parse_record_pattern_row_field ~attrs p)) + | Uident _ | Lident _ -> + Some (false, PatField (parse_record_pattern_row_field ~attrs p)) + | Question -> ( + Parser.next p; + match p.token with + | Uident _ | Lident _ -> + let {Parsetree.lid; x = pat} = parse_record_pattern_row_field ~attrs p in + Some (false, PatField {lid; x = pat; opt = true}) + | _ -> None) + | Underscore -> + Parser.next p; + Some (false, PatUnderscore) + | _ -> + if Token.is_keyword p.token then ( + match + recover_keyword_field_name_if_probably_field p + ~mk_message:ErrorMessages.keyword_field_in_pattern + with + | Some (recovered_field_name, loc) -> + Parser.expect Colon p; + let optional = parse_optional_label p in + let pat = parse_pattern p in + let field = + Location.mkloc (Longident.Lident recovered_field_name) loc + in + Some (false, PatField {lid = field; x = pat; opt = optional}) + | None -> + emit_keyword_field_error p + ~mk_message:ErrorMessages.keyword_field_in_pattern; + None) + else None + +and parse_record_pattern ~attrs p = + let start_pos = p.start_pos in + Parser.expect Lbrace p; + let raw_fields = + parse_comma_delimited_reversed_list p ~grammar:PatternRecord ~closing:Rbrace + ~f:parse_record_pattern_row + in + Parser.expect Rbrace p; + let fields, closed_flag = + let raw_fields, flag = + match raw_fields with + | (_hasSpread, PatUnderscore) :: rest -> (rest, Asttypes.Open) + | raw_fields -> (raw_fields, Asttypes.Closed) + in + List.fold_left + (fun (fields, flag) curr -> + let has_spread, field = curr in + match field with + | PatField field -> + (if has_spread then + let pattern = field.x in + Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.record_pattern_spread)); + (field :: fields, flag) + | PatUnderscore -> (fields, flag)) + ([], flag) raw_fields + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.record ~loc ~attrs fields closed_flag + +and parse_tuple_pattern ~attrs ~first ~start_pos p = + let patterns = + first + :: parse_comma_delimited_region p ~grammar:Grammar.PatternList + ~closing:Rparen ~f:parse_constrained_pattern_region + in + Parser.expect Rparen p; + let () = + match patterns with + | [_] -> + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.tuple_single_element) + | _ -> () + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.tuple ~loc ~attrs patterns + +and parse_pattern_region p = + match p.Parser.token with + | DotDotDot -> + Parser.next p; + Some (true, parse_constrained_pattern p) + | token when Grammar.is_pattern_start token -> + Some (false, parse_constrained_pattern p) + | _ -> None + +and parse_module_pattern ~attrs p = + let start_pos = p.Parser.start_pos in + Parser.expect Module p; + Parser.expect Lparen p; + let uident = + match p.token with + | Uident uident -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Location.mkloc uident loc + | _ -> + (* TODO: error recovery *) + Location.mknoloc "_" + in + match p.token with + | Colon -> + let colon_start = p.Parser.start_pos in + Parser.next p; + let package_typ_attrs = parse_attributes p in + let package_type = + parse_package_type ~start_pos:colon_start ~attrs:package_typ_attrs p + in + Parser.expect Rparen p; + let loc = mk_loc start_pos p.prev_end_pos in + let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in + Ast_helper.Pat.constraint_ ~loc ~attrs unpack package_type + | _ -> + Parser.expect Rparen p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.unpack ~loc ~attrs uident + +and parse_list_pattern ~start_pos ~attrs p = + let list_patterns = + parse_comma_delimited_reversed_list p ~grammar:Grammar.PatternOcamlList + ~closing:Rbrace ~f:parse_pattern_region + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let filter_spread (has_spread, pattern) = + if has_spread then ( + Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p + (Diagnostics.message ErrorMessages.list_pattern_spread); + pattern) + else pattern + in + match list_patterns with + | (true, pattern) :: patterns -> + let patterns = patterns |> List.map filter_spread |> List.rev in + let pat = make_list_pattern loc patterns (Some pattern) in + {pat with ppat_loc = loc; ppat_attributes = attrs} + | patterns -> + let patterns = patterns |> List.map filter_spread |> List.rev in + let pat = make_list_pattern loc patterns None in + {pat with ppat_loc = loc; ppat_attributes = attrs} + +and parse_dict_pattern_row p = + match p.Parser.token with + | String s -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + let fieldName = Location.mkloc (Longident.Lident s) loc in + Parser.expect Colon p; + let optional = parse_optional_label p in + let pat = parse_pattern p in + Some {Parsetree.lid = fieldName; x = pat; opt = optional} + | _ -> None + +and parse_dict_pattern ~start_pos ~attrs (p : Parser.t) = + let fields = + parse_comma_delimited_region p ~grammar:DictRows ~closing:Rbrace + ~f:parse_dict_pattern_row + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.record ~loc + ~attrs:((Location.mknoloc "res.dictPattern", PStr []) :: attrs) + fields Open + +and parse_array_pattern ~attrs p = + let start_pos = p.start_pos in + Parser.expect Lbracket p; + let patterns = + parse_comma_delimited_region p ~grammar:Grammar.PatternList + ~closing:Rbracket + ~f:(parse_non_spread_pattern ~msg:ErrorMessages.array_pattern_spread) + in + Parser.expect Rbracket p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.array ~loc ~attrs patterns + +and parse_constructor_pattern_args p constr start_pos attrs = + let lparen = p.start_pos in + Parser.expect Lparen p; + let args = + parse_comma_delimited_region p ~grammar:Grammar.PatternList ~closing:Rparen + ~f:parse_constrained_pattern_region + in + Parser.expect Rparen p; + let args = + match args with + | [] -> + let loc = mk_loc lparen p.prev_end_pos in + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some pat + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) + | [pattern] -> Some pattern + | patterns -> + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) + in + Ast_helper.Pat.construct + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs constr args + +and parse_variant_pattern_args p ident start_pos attrs = + let lparen = p.start_pos in + Parser.expect Lparen p; + let patterns = + parse_comma_delimited_region p ~grammar:Grammar.PatternList ~closing:Rparen + ~f:parse_constrained_pattern_region + in + let args = + match patterns with + | [] -> + let loc = mk_loc lparen p.prev_end_pos in + Some + (Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None) + | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> + if p.mode = ParseForTypeChecker then + (* #ident(1, 2) for type-checker *) + Some pat + else + (* #ident((1, 2)) for printer *) + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) + | [pattern] -> Some pattern + | patterns -> + Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) + in + Parser.expect Rparen p; + Ast_helper.Pat.variant + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs ident args + +and parse_expr ?(context = OrdinaryExpr) p = + let expr = parse_operand_expr ~context p in + let expr = parse_binary_expr ~context ~a:expr p 1 in + parse_ternary_expr expr p + +(* expr ? expr : expr *) +and parse_ternary_expr left_operand p = + match p.Parser.token with + | Question -> + Parser.leave_breadcrumb p Grammar.Ternary; + Parser.next p; + let true_branch = parse_expr ~context:TernaryTrueBranchExpr p in + Parser.expect Colon p; + let false_branch = parse_expr p in + Parser.eat_breadcrumb p; + let loc = + { + left_operand.Parsetree.pexp_loc with + loc_start = left_operand.pexp_loc.loc_start; + loc_end = false_branch.Parsetree.pexp_loc.loc_end; + } + in + Ast_helper.Exp.ifthenelse ~attrs:[ternary_attr] ~loc left_operand + true_branch (Some false_branch) + | _ -> left_operand + +and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) + ?context ?term_parameters ~async p = + let start_pos = p.Parser.start_pos in + Parser.leave_breadcrumb p Grammar.Es6ArrowExpr; + (* Parsing function parameters and attributes: + 1. Basically, attributes outside of `(...)` are added to the function, except + the uncurried attribute `(.)` is added to the function. e.g. async, uncurried + + 2. Attributes inside `(...)` are added to the arguments regardless of whether + labeled, optional or nolabeled *) + let parameters = + match term_parameters with + | Some params -> (None, params) + | None -> parse_parameters p + in + let parameters = + let update_attrs attrs = arrow_attrs @ attrs in + let update_pos pos = + match arrow_start_pos with + | Some start_pos -> start_pos + | None -> pos + in + match parameters with + | None, termp :: rest -> + ( None, + { + termp with + attrs = update_attrs termp.attrs; + p_pos = update_pos termp.p_pos; + } + :: rest ) + | Some (tpa : fundef_type_param), term_params -> + ( Some + { + tpa with + attrs = update_attrs tpa.attrs; + p_pos = update_pos tpa.p_pos; + }, + term_params ) + | _ -> parameters + in + let return_type = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parse_typ_expr ~es6_arrow:false p) + | _ -> None + in + Parser.expect EqualGreater p; + let body = + let expr = parse_expr ?context p in + match return_type with + | Some typ -> + Ast_helper.Exp.constraint_ + ~loc:(mk_loc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) + expr typ + | None -> expr + in + Parser.eat_breadcrumb p; + let end_pos = p.prev_end_pos in + let type_param_opt, term_parameters = parameters in + let arrow_expr = + List.fold_right + (fun parameter expr -> + let {attrs; p_label = lbl; expr = default_expr; pat; p_pos = start_pos} + = + parameter + in + let loc = mk_loc start_pos end_pos in + Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None lbl default_expr pat expr) + term_parameters body + in + let arrow_expr = + Ast_uncurried.uncurried_fun + ~arity:(List.length term_parameters) + ~async arrow_expr + in + let arrow_expr = + match type_param_opt with + | None -> arrow_expr + | Some {attrs; locs = newtypes; p_pos = start_pos} -> + make_newtypes ~attrs ~loc:(mk_loc start_pos end_pos) newtypes arrow_expr + in + {arrow_expr with pexp_loc = {arrow_expr.pexp_loc with loc_start = start_pos}} + +(* + * dotted_parameter ::= + * | . parameter + * + * parameter ::= + * | pattern + * | pattern : type + * | ~ labelName + * | ~ labelName as pattern + * | ~ labelName as pattern : type + * | ~ labelName = expr + * | ~ labelName as pattern = expr + * | ~ labelName as pattern : type = expr + * | ~ labelName = ? + * | ~ labelName as pattern = ? + * | ~ labelName as pattern : type = ? + * + * labelName ::= lident + *) +and parse_parameter p = + if + p.Parser.token = Token.Typ || p.token = Tilde || p.token = Dot + || Grammar.is_pattern_start p.token + then + let start_pos = p.Parser.start_pos in + let _ = + Parser.optional p Token.Dot + (* dot is ignored *) + in + let attrs = parse_attributes p in + if p.Parser.token = Typ then ( + Parser.next p; + let lidents = parse_lident_list p in + Some (TypeParameter {attrs; locs = lidents; p_pos = start_pos})) + else + let attrs, lbl, lbl_loc, pat = + match p.Parser.token with + | Tilde -> ( + Parser.next p; + let lbl_name, lbl_loc = parse_lident p in + match p.Parser.token with + | Comma | Equal | Rparen -> + let loc = mk_loc start_pos p.prev_end_pos in + ( [], + Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, + lbl_loc, + Ast_helper.Pat.var ~attrs ~loc (Location.mkloc lbl_name loc) ) + | Colon -> + let lbl_end = p.prev_end_pos in + Parser.next p; + let typ = parse_typ_expr p in + let loc = mk_loc start_pos lbl_end in + let pat = + let pat = Ast_helper.Pat.var ~loc (Location.mkloc lbl_name loc) in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Pat.constraint_ ~attrs ~loc pat typ + in + ([], Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, pat) + | As -> + Parser.next p; + let pat = + let pat = parse_constrained_pattern p in + {pat with ppat_attributes = attrs @ pat.ppat_attributes} + in + ([], Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, pat) + | t -> + Parser.err p (Diagnostics.unexpected t p.breadcrumbs); + let loc = mk_loc start_pos p.prev_end_pos in + ( [], + Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, + lbl_loc, + Ast_helper.Pat.var ~attrs ~loc (Location.mkloc lbl_name loc) )) + | _ -> + let pattern = parse_constrained_pattern p in + let attrs = List.concat [pattern.ppat_attributes; attrs] in + ( [], + Asttypes.Nolabel, + Location.none, + {pattern with ppat_attributes = attrs} ) + in + match p.Parser.token with + | Equal -> ( + Parser.next p; + let lbl = + match lbl with + | Asttypes.Labelled lbl_name -> Asttypes.Optional lbl_name + | Asttypes.Nolabel -> + let lbl_name = + match pat.ppat_desc with + | Ppat_var var -> var.txt + | _ -> "" + in + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message + (ErrorMessages.missing_tilde_labeled_parameter lbl_name)); + Asttypes.Optional {txt = lbl_name; loc = lbl_loc} + | lbl -> lbl + in + match p.Parser.token with + | Question -> + Parser.next p; + Some + (TermParameter + {attrs; p_label = lbl; expr = None; pat; p_pos = start_pos}) + | _ -> + let expr = parse_constrained_or_coerced_expr p in + Some + (TermParameter + {attrs; p_label = lbl; expr = Some expr; pat; p_pos = start_pos}) + ) + | _ -> + Some + (TermParameter + {attrs; p_label = lbl; expr = None; pat; p_pos = start_pos}) + else None + +and parse_parameter_list p = + let parameters = + parse_comma_delimited_region ~grammar:Grammar.ParameterList + ~f:parse_parameter ~closing:Rparen p + in + Parser.expect Rparen p; + extract_fundef_params ~type_acc:None ~term_acc:[] parameters + +(* parameters ::= + * | _ + * | lident + * | () + * | (.) + * | ( parameter {, parameter} [,] ) + *) +and parse_parameters p : fundef_type_param option * fundef_term_param list = + let start_pos = p.Parser.start_pos in + let unit_term_parameter () = + let loc = mk_loc start_pos p.Parser.prev_end_pos in + let unit_pattern = + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + { + attrs = []; + p_label = Asttypes.Nolabel; + expr = None; + pat = unit_pattern; + p_pos = start_pos; + } + in + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mk_loc start_pos p.Parser.prev_end_pos in + ( None, + [ + { + attrs = []; + p_label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); + p_pos = start_pos; + }; + ] ) + | Underscore -> + Parser.next p; + let loc = mk_loc start_pos p.Parser.prev_end_pos in + ( None, + [ + { + attrs = []; + p_label = Asttypes.Nolabel; + expr = None; + pat = Ast_helper.Pat.any ~loc (); + p_pos = start_pos; + }; + ] ) + | Lparen -> + Parser.next p; + ignore (Parser.optional p Dot); + let type_params, term_params = parse_parameter_list p in + let term_params = + if term_params <> [] then term_params else [unit_term_parameter ()] + in + (type_params, term_params) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + (None, []) + +and parse_coerced_expr ~(expr : Parsetree.expression) p = + Parser.expect ColonGreaterThan p; + let typ = parse_typ_expr p in + let loc = mk_loc expr.pexp_loc.loc_start p.prev_end_pos in + Ast_helper.Exp.coerce ~loc expr typ + +and parse_constrained_or_coerced_expr p = + let expr = parse_expr p in + match p.Parser.token with + | ColonGreaterThan -> parse_coerced_expr ~expr p + | Colon -> ( + Parser.next p; + match p.token with + | _ -> ( + let typ = parse_typ_expr p in + let loc = mk_loc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + match p.token with + | ColonGreaterThan -> parse_coerced_expr ~expr p + | _ -> expr)) + | _ -> expr + +and parse_constrained_expr_region p = + match p.Parser.token with + | token when Grammar.is_expr_start token -> ( + let expr = parse_expr p in + match p.Parser.token with + | ColonGreaterThan -> Some (parse_coerced_expr ~expr p) + | Colon -> + Parser.next p; + let typ = parse_typ_expr p in + let loc = mk_loc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + Some (Ast_helper.Exp.constraint_ ~loc expr typ) + | _ -> Some expr) + | _ -> None + +and parse_regex ~start_pos p pattern flags = + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let payload = + Parsetree.PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc + (Pconst_string + ( "/" ^ pattern ^ "/" ^ flags, + if p.mode = ParseForTypeChecker then Some "js" else None ))); + ] + in + Ast_helper.Exp.extension (Location.mkloc "re" loc, payload) + +(* Atomic expressions represent unambiguous expressions. + * This means that regardless of the context, these expressions + * are always interpreted correctly. *) +and parse_atomic_expr p = + Parser.leave_breadcrumb p Grammar.ExprOperand; + let start_pos = p.Parser.start_pos in + let expr = + match p.Parser.token with + | (True | False) as token -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident (Token.to_string token)) loc) + None + | Int _ | String _ | Float _ | Codepoint _ -> + let c = parse_constant p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.constant ~loc c + | Backtick -> + let expr = parse_template_expr p in + {expr with pexp_loc = mk_loc start_pos p.prev_end_pos} + | Uident _ | Lident _ -> parse_value_or_constructor p + | Hash -> parse_poly_variant_expr p + | Lparen -> ( + Parser.next p; + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + | _t -> ( + let expr = parse_constrained_or_coerced_expr p in + match p.token with + | Comma -> + Parser.next p; + parse_tuple_expr ~start_pos ~first:expr p + | _ -> + Parser.expect Rparen p; + expr + (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} + * What does this location mean here? It means that when there's + * a parenthesized we keep the location here for whitespace interleaving. + * Without the closing paren in the location there will always be an extra + * line. For now we don't include it, because it does weird things + * with for comments. *))) + | List -> + Parser.next p; + parse_list_expr ~start_pos p + | Dict -> + Parser.next p; + parse_dict_expr ~start_pos p + | Module -> + Parser.next p; + parse_first_class_module_expr ~start_pos p + | Lbracket -> parse_array_exp p + | Lbrace -> parse_braced_or_record_expr p + | LessThan -> parse_jsx p + | Percent -> + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.extension ~loc extension + | Underscore as token -> + (* This case is for error recovery. Not sure if it's the correct place *) + Parser.err p (Diagnostics.lident token); + Parser.next p; + Recover.default_expr () + | Eof -> + Parser.err ~start_pos:p.prev_end_pos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.default_expr () + | Forwardslash -> ( + Parser.next_regex_token p; + match p.token with + | Regex (pattern, flags) -> parse_regex ~start_pos p pattern flags + | _ -> Ast_helper.Exp.extension (Location.mknoloc "re", Parsetree.PStr []) + ) + | ForwardslashDot -> ( + Parser.next_regex_token p; + match p.token with + | Regex (pattern, flags) -> parse_regex ~start_pos p ("." ^ pattern) flags + | _ -> Ast_helper.Exp.extension (Location.mknoloc "re", Parsetree.PStr []) + ) + | token -> ( + let err_pos = p.prev_end_pos in + Parser.err ~start_pos:err_pos p + (Diagnostics.unexpected token p.breadcrumbs); + match + skip_tokens_and_maybe_retry p + ~is_start_of_grammar:Grammar.is_atomic_expr_start + with + | None -> Recover.default_expr () + | Some () -> parse_atomic_expr p) + in + Parser.eat_breadcrumb p; + expr + +(* module(module-expr) + * module(module-expr : package-type) *) +and parse_first_class_module_expr ~start_pos p = + Parser.expect Lparen p; + + let mod_expr = parse_module_expr p in + let mod_end_loc = p.prev_end_pos in + match p.Parser.token with + | Colon -> + let colon_start = p.Parser.start_pos in + Parser.next p; + let attrs = parse_attributes p in + let package_type = parse_package_type ~start_pos:colon_start ~attrs p in + Parser.expect Rparen p; + let loc = mk_loc start_pos mod_end_loc in + let first_class_module = Ast_helper.Exp.pack ~loc mod_expr in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.constraint_ ~loc first_class_module package_type + | _ -> + Parser.expect Rparen p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.pack ~loc mod_expr + +and parse_bracket_access p expr start_pos = + Parser.leave_breadcrumb p Grammar.ExprArrayAccess; + let lbracket = p.start_pos in + Parser.expect Lbracket p; + let string_start = p.start_pos in + match p.Parser.token with + | String s -> ( + Parser.next p; + let string_end = p.prev_end_pos in + Parser.expect Rbracket p; + Parser.eat_breadcrumb p; + let rbracket = p.prev_end_pos in + let e = + let ident_loc = mk_loc string_start string_end in + let loc = mk_loc start_pos rbracket in + Ast_helper.Exp.send ~loc expr (Location.mkloc s ident_loc) + in + let e = parse_primary_expr ~operand:e p in + let equal_start = p.start_pos in + match p.token with + | Equal -> + Parser.next p; + let equal_end = p.prev_end_pos in + let rhs_expr = parse_expr p in + let loc = mk_loc start_pos rhs_expr.pexp_loc.loc_end in + let operator_loc = mk_loc equal_start equal_end in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc:operator_loc + (Location.mkloc (Longident.Lident "#=") operator_loc)) + [(Nolabel, e); (Nolabel, rhs_expr)] + | _ -> e) + | _ -> ( + let access_expr = parse_constrained_or_coerced_expr p in + Parser.expect Rbracket p; + Parser.eat_breadcrumb p; + let rbracket = p.prev_end_pos in + let array_loc = mk_loc lbracket rbracket in + match p.token with + | Equal -> + Parser.leave_breadcrumb p ExprArrayMutation; + Parser.next p; + let rhs_expr = parse_expr p in + (* FIXME: Do not implicitly rely on specific module name, even primitive one + + This can be abused like + module Array = MyModule + + Find better mechanism to support it + *) + let array_set = + Location.mkloc (Longident.Ldot (Lident "Array", "set")) array_loc + in + let end_pos = p.prev_end_pos in + let array_set = + Ast_helper.Exp.apply ~loc:(mk_loc start_pos end_pos) + (Ast_helper.Exp.ident ~loc:array_loc array_set) + [(Nolabel, expr); (Nolabel, access_expr); (Nolabel, rhs_expr)] + in + Parser.eat_breadcrumb p; + array_set + | _ -> + let end_pos = p.prev_end_pos in + let e = + Ast_helper.Exp.apply ~loc:(mk_loc start_pos end_pos) + (Ast_helper.Exp.ident ~loc:array_loc + (Location.mkloc (Longident.Ldot (Lident "Array", "get")) array_loc)) + [(Nolabel, expr); (Nolabel, access_expr)] + in + parse_primary_expr ~operand:e p) + +(* * A primary expression represents + * - atomic-expr + * - john.age + * - array[0] + * - applyFunctionTo(arg1, arg2) + * + * The "operand" represents the expression that is operated on + *) +and parse_primary_expr ~operand ?(no_call = false) p = + let start_pos = operand.pexp_loc.loc_start in + let rec loop p expr = + match p.Parser.token with + | Dot -> ( + Parser.next p; + let lident = parse_value_path_after_dot p in + match p.Parser.token with + | Equal when no_call = false -> + Parser.leave_breadcrumb p Grammar.ExprSetField; + Parser.next p; + let target_expr = parse_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + let setfield = Ast_helper.Exp.setfield ~loc expr lident target_expr in + Parser.eat_breadcrumb p; + setfield + | _ -> + let end_pos = p.prev_end_pos in + let loc = mk_loc start_pos end_pos in + loop p (Ast_helper.Exp.field ~loc expr lident)) + | Lbracket + when no_call = false && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + parse_bracket_access p expr start_pos + | Lparen + when no_call = false && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + loop p (parse_call_expr p expr) + | Backtick + when no_call = false && p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum + -> ( + match expr.pexp_desc with + | Pexp_ident long_ident -> parse_template_expr ~prefix:long_ident p + | _ -> + Parser.err ~start_pos:expr.pexp_loc.loc_start + ~end_pos:expr.pexp_loc.loc_end p + (Diagnostics.message + "Tagged template literals are currently restricted to names like: \ + myTagFunction`foo ${bar}`."); + parse_template_expr p) + | _ -> expr + in + loop p operand + +(* a unary expression is an expression with only one operand and + * unary operator. Examples: + * -1 + * !condition + * -. 1.6 + *) +and parse_unary_expr p = + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | (Minus | MinusDot | Plus | PlusDot | Bang | Bnot) as token -> + Parser.leave_breadcrumb p Grammar.ExprUnary; + let token_end = p.end_pos in + Parser.next p; + let operand = parse_unary_expr p in + let unary_expr = make_unary_expr start_pos token_end token operand in + Parser.eat_breadcrumb p; + unary_expr + | _ -> parse_primary_expr ~operand:(parse_atomic_expr p) p + +(* Represents an "operand" in a binary expression. + * If you have `a + b`, `a` and `b` both represent + * the operands of the binary expression with opeartor `+` *) +and parse_operand_expr ~context p = + let start_pos = p.Parser.start_pos in + let attrs = ref (parse_attributes p) in + let expr = + match p.Parser.token with + | Assert -> + Parser.next p; + let expr = parse_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.assert_ ~loc expr + | Lident "async" + (* we need to be careful when we're in a ternary true branch: + `condition ? ternary-true-branch : false-branch` + Arrow expressions could be of the form: `async (): int => stuff()` + But if we're in a ternary, the `:` of the ternary takes precedence + *) + when is_es6_arrow_expression + ~in_ternary:(context = TernaryTrueBranchExpr) + p -> + let arrow_attrs = !attrs in + let () = attrs := [] in + parse_async_arrow_expression ~arrow_attrs p + | Await -> parse_await_expression p + | Try -> parse_try_expression p + | If -> parse_if_or_if_let_expression p + | For -> parse_for_expression p + | While -> parse_while_expression p + | Switch -> parse_switch_expression p + | _ -> + if + context != WhenExpr + && is_es6_arrow_expression + ~in_ternary:(context = TernaryTrueBranchExpr) + p + then + let arrow_attrs = !attrs in + let () = attrs := [] in + parse_es6_arrow_expression ~async:false ~arrow_attrs ~context p + else parse_unary_expr p + in + (* let endPos = p.Parser.prevEndPos in *) + { + expr with + pexp_attributes = List.concat [expr.Parsetree.pexp_attributes; !attrs]; + (* pexp_loc = mkLoc startPos endPos *) + } + +(* a binary expression is an expression that combines two expressions with an + * operator. Examples: + * a + b + * f(x) |> g(y) + *) +and parse_binary_expr ?(context = OrdinaryExpr) ?a p prec = + let a = + match a with + | Some e -> e + | None -> parse_operand_expr ~context p + in + let rec loop a = + let token = p.Parser.token in + let token_prec = + match token with + (* Can the minus be interpreted as a binary operator? Or is it a unary? + * let w = { + * x + * -10 + * } + * vs + * let w = { + * width + * - gap + * } + * + * First case is unary, second is a binary operator. + * See Scanner.isBinaryOp *) + | (Minus | MinusDot | LessThan | Percent) + when (not + (Scanner.is_binary_op p.scanner.src p.start_pos.pos_cnum + p.end_pos.pos_cnum)) + && p.start_pos.pos_lnum > p.prev_end_pos.pos_lnum -> + -1 + | token -> Token.precedence token + in + if token_prec < prec then a + else ( + Parser.leave_breadcrumb p (Grammar.ExprBinaryAfterOp token); + let start_pos = p.start_pos in + Parser.next p; + let end_pos = p.prev_end_pos in + let token_prec = + (* exponentiation operator is right-associative *) + if token = Exponentiation then token_prec else token_prec + 1 + in + let b = parse_binary_expr ~context p token_prec in + let loc = mk_loc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in + let expr = + Ast_helper.Exp.apply ~loc + (make_infix_operator p token start_pos end_pos) + [(Nolabel, a); (Nolabel, b)] + in + Parser.eat_breadcrumb p; + loop expr) + in + loop a + +(* If we even need this, determines if < might be the start of jsx. Not 100% complete *) +(* and isStartOfJsx p = *) +(* Parser.lookahead p (fun p -> *) +(* match p.Parser.token with *) +(* | LessThan -> *) +(* Parser.next p; *) +(* begin match p.token with *) +(* | GreaterThan (* <> *) -> true *) +(* | Lident _ | Uident _ | List -> *) +(* ignore (parseJsxName p); *) +(* begin match p.token with *) +(* | GreaterThan (*
*) -> true *) +(* | Question (* true *) +(* | Lident _ | List -> *) +(* Parser.next p; *) +(* begin match p.token with *) +(* | Equal (* true *) +(* | _ -> false (* TODO *) *) +(* end *) +(* | Forwardslash (* *) +(* Parser.next p; *) +(* begin match p.token with *) +(* | GreaterThan (* *) -> true *) +(* | _ -> false *) +(* end *) +(* | _ -> *) +(* false *) +(* end *) +(* | _ -> false *) +(* end *) +(* | _ -> false *) +(* ) *) + +and parse_template_expr ?prefix p = + let part_prefix = + (* we could stop treating json prefix as something special + but we would first need to remove @as(json`true`) feature *) + match prefix with + | Some {txt = Longident.Lident ("json" as prefix); _} -> Some prefix + | _ -> Some "js" + in + + let parse_parts p = + let rec aux acc = + let start_pos = p.Parser.start_pos in + Parser.next_template_literal_token p; + match p.token with + | TemplateTail (txt, last_pos) -> + Parser.next p; + let loc = mk_loc start_pos last_pos in + let str = + Ast_helper.Exp.constant ~attrs:[template_literal_attr] ~loc + (Pconst_string (txt, part_prefix)) + in + List.rev ((str, None) :: acc) + | TemplatePart (txt, last_pos) -> + Parser.next p; + let loc = mk_loc start_pos last_pos in + let expr = parse_expr_block p in + let str = + Ast_helper.Exp.constant ~attrs:[template_literal_attr] ~loc + (Pconst_string (txt, part_prefix)) + in + aux ((str, Some expr) :: acc) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + [] + in + aux [] + in + let parts = parse_parts p in + let strings = List.map fst parts in + let values = Ext_list.filter_map parts snd in + + let gen_tagged_template_call (lident_loc : Longident.t Location.loc) = + let ident = Ast_helper.Exp.ident ~attrs:[] ~loc:lident_loc.loc lident_loc in + let strings_array = + Ast_helper.Exp.array ~attrs:[] ~loc:Location.none strings + in + let values_array = + Ast_helper.Exp.array ~attrs:[] ~loc:Location.none values + in + Ast_helper.Exp.apply + ~attrs:[tagged_template_literal_attr] + ~loc:lident_loc.loc ident + [(Nolabel, strings_array); (Nolabel, values_array)] + in + + let hidden_operator = + let op = Location.mknoloc (Longident.Lident "++") in + Ast_helper.Exp.ident op + in + let concat (e1 : Parsetree.expression) (e2 : Parsetree.expression) = + let loc = mk_loc e1.pexp_loc.loc_start e2.pexp_loc.loc_end in + Ast_helper.Exp.apply ~attrs:[template_literal_attr] ~loc hidden_operator + [(Nolabel, e1); (Nolabel, e2)] + in + let gen_interpolated_string () = + let subparts = + List.flatten + (List.map + (fun part -> + match part with + | s, Some v -> [s; v] + | s, None -> [s]) + parts) + in + let expr_option = + List.fold_left + (fun acc subpart -> + Some + (match acc with + | Some expr -> concat expr subpart + | None -> subpart)) + None subparts + in + match expr_option with + | Some expr -> expr + | None -> Ast_helper.Exp.constant (Pconst_string ("", None)) + in + + match prefix with + | Some {txt = Longident.Lident "json"; _} | None -> gen_interpolated_string () + | Some lident_loc -> gen_tagged_template_call lident_loc + +(* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => + * Also overparse constraints: + * let x = { + * let a = 1 + * a + pi: int + * } + * + * We want to give a nice error message in these cases + *) +and over_parse_constrained_or_coerced_or_arrow_expression p expr = + match p.Parser.token with + | ColonGreaterThan -> parse_coerced_expr ~expr p + | Colon -> ( + Parser.next p; + let typ = parse_typ_expr ~es6_arrow:false p in + match p.Parser.token with + | EqualGreater -> + Parser.next p; + let body = parse_expr p in + let pat, expr_is_unit = + match expr.pexp_desc with + | Pexp_ident longident -> + ( Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc + (Longident.flatten longident.txt |> String.concat ".") + longident.loc), + false ) + | Pexp_construct (({txt = Longident.Lident "()"} as lid), None) -> + (Ast_helper.Pat.construct ~loc:expr.pexp_loc lid None, true) + (* TODO: can we convert more expressions to patterns?*) + | _ -> + ( Ast_helper.Pat.var ~loc:expr.pexp_loc + (Location.mkloc "pattern" expr.pexp_loc), + false ) + in + let arrow1 = + Ast_helper.Exp.fun_ + ~loc:(mk_loc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + ~arity:None Asttypes.Nolabel None pat + (Ast_helper.Exp.constraint_ body typ) + in + (* When the "expr" was `()`, the colon must apply to the return type, so + skip the ambiguity diagnostic and keep the parameter as unit. *) + if expr_is_unit then arrow1 + else + let arrow2 = + Ast_helper.Exp.fun_ + ~loc:(mk_loc expr.pexp_loc.loc_start body.pexp_loc.loc_end) + ~arity:None Asttypes.Nolabel None + (Ast_helper.Pat.constraint_ pat typ) + body + in + let msg = + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.text + "Did you mean to annotate the parameter type or the return \ + type?"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.text "1) "; + ResPrinter.print_expression arrow1 CommentTable.empty; + Doc.line; + Doc.text "2) "; + ResPrinter.print_expression arrow2 CommentTable.empty; + ]); + ]) + |> Doc.to_string ~width:80 + in + Parser.err ~start_pos:expr.pexp_loc.loc_start + ~end_pos:body.pexp_loc.loc_end p (Diagnostics.message msg); + arrow1 + | _ -> + let loc = mk_loc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in + let expr = Ast_helper.Exp.constraint_ ~loc expr typ in + let () = + Parser.err ~start_pos:expr.pexp_loc.loc_start + ~end_pos:typ.ptyp_loc.loc_end p + (Diagnostics.message + (Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.text + "Expressions with type constraints need to be wrapped \ + in parens:"; + Doc.indent + (Doc.concat + [ + Doc.line; + ResPrinter.add_parens + (ResPrinter.print_expression expr + CommentTable.empty); + ]); + ]) + |> Doc.to_string ~width:80)) + in + expr) + | _ -> expr + +and parse_let_binding_body ~start_pos ~attrs p = + Parser.begin_region p; + Parser.leave_breadcrumb p Grammar.LetBinding; + let pat, exp = + Parser.leave_breadcrumb p Grammar.Pattern; + let pat = parse_pattern p in + Parser.eat_breadcrumb p; + match p.Parser.token with + | Colon -> ( + Parser.next p; + match p.token with + | Typ -> + (* locally abstract types *) + Parser.next p; + let newtypes = parse_lident_list p in + Parser.expect Dot p; + let typ = parse_typ_expr p in + Parser.expect Equal p; + let expr = parse_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + let exp, poly = wrap_type_annotation ~loc newtypes typ expr in + let pat = Ast_helper.Pat.constraint_ ~loc pat poly in + (pat, exp) + | _ -> + let poly_type = parse_poly_type_expr p in + let loc = + {pat.ppat_loc with loc_end = poly_type.Parsetree.ptyp_loc.loc_end} + in + let pat = Ast_helper.Pat.constraint_ ~loc pat poly_type in + Parser.expect Token.Equal p; + let exp = parse_expr p in + let exp = over_parse_constrained_or_coerced_or_arrow_expression p exp in + (pat, exp)) + | _ -> + Parser.expect Token.Equal p; + let exp = + over_parse_constrained_or_coerced_or_arrow_expression p (parse_expr p) + in + (pat, exp) + in + let loc = mk_loc start_pos p.prev_end_pos in + let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in + Parser.eat_breadcrumb p; + Parser.end_region p; + vb + +(* TODO: find a better way? Is it possible? + * let a = 1 + * @attr + * and b = 2 + * + * The problem is that without semi we need a lookahead to determine + * if the attr is on the letbinding or the start of a new thing + * + * let a = 1 + * @attr + * let b = 1 + * + * Here @attr should attach to something "new": `let b = 1` + * The parser state is forked, which is quite expensive… + *) +and parse_attributes_and_binding (p : Parser.t) = + let err = p.scanner.err in + let ch = p.scanner.ch in + let offset = p.scanner.offset in + let offset16 = p.scanner.offset16 in + let line_offset = p.scanner.line_offset in + let lnum = p.scanner.lnum in + let mode = p.scanner.mode in + let token = p.token in + let start_pos = p.start_pos in + let end_pos = p.end_pos in + let prev_end_pos = p.prev_end_pos in + let breadcrumbs = p.breadcrumbs in + let errors = p.errors in + let diagnostics = p.diagnostics in + let comments = p.comments in + + match p.Parser.token with + | At | DocComment (_, _) -> ( + let attrs = parse_attributes p in + match p.Parser.token with + | And -> attrs + | _ -> + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.offset16 <- offset16; + p.scanner.line_offset <- line_offset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.start_pos <- start_pos; + p.end_pos <- end_pos; + p.prev_end_pos <- prev_end_pos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + []) + | _ -> [] + +(* definition ::= let [rec] let-binding { and let-binding } *) +and parse_let_bindings ~unwrap ~attrs ~start_pos p = + Parser.optional p (Let {unwrap}) |> ignore; + let rec_flag = + if Parser.optional p Token.Rec then Asttypes.Recursive + else Asttypes.Nonrecursive + in + let end_pos = p.Parser.start_pos in + if rec_flag = Asttypes.Recursive && unwrap then + Parser.err ~start_pos ~end_pos p + (Diagnostics.message ErrorMessages.experimental_let_unwrap_rec); + let add_unwrap_attr ~unwrap ~start_pos ~end_pos attrs = + if unwrap then + ( {Asttypes.txt = "let.unwrap"; loc = mk_loc start_pos end_pos}, + Ast_payload.empty ) + :: attrs + else attrs + in + let attrs = add_unwrap_attr ~unwrap ~start_pos ~end_pos attrs in + let first = parse_let_binding_body ~start_pos ~attrs p in + + let rec loop p bindings = + let start_pos = p.Parser.start_pos in + let end_pos = p.Parser.end_pos in + let attrs = parse_attributes_and_binding p in + let attrs = add_unwrap_attr ~unwrap ~start_pos ~end_pos attrs in + match p.Parser.token with + | And -> + Parser.next p; + ignore (Parser.optional p (Let {unwrap = false})); + (* overparse for fault tolerance *) + let let_binding = parse_let_binding_body ~start_pos ~attrs p in + loop p (let_binding :: bindings) + | _ -> List.rev bindings + in + (rec_flag, loop p [first]) + +and parse_jsx_name p : Parsetree.jsx_tag_name Location.loc = + match read_jsx_tag_name p with + | Ok name -> name + | Error invalid_str -> + let msg = + "A jsx name must be a lowercase or uppercase name, like: div in
\ + or Navbar in " + in + Parser.err p (Diagnostics.message msg); + {txt = Parsetree.JsxTagInvalid invalid_str; loc = Location.none} + +and parse_jsx_opening_or_self_closing_element (* start of the opening < *) + ~start_pos p : Parsetree.expression = + let name = parse_jsx_name p in + let jsx_props = parse_jsx_props p in + match p.Parser.token with + | Forwardslash -> + (* *) + Parser.next p; + let jsx_end_pos = p.end_pos in + Parser.expect GreaterThan p; + let loc = mk_loc start_pos jsx_end_pos in + Ast_helper.Exp.jsx_unary_element ~loc name jsx_props + | GreaterThan -> ( + (* bar *) + let opening_tag_end = p.Parser.start_pos in + Parser.next p; + let children = parse_jsx_children p in + let closing_tag_start = + match p.token with + | LessThan when Scanner.peekSlash p.scanner -> + let pos = p.start_pos in + (* Move to slash *) + Parser.next p; + (* Move to ident *) + Parser.next p; + Some pos + | token when Grammar.is_structure_item_start token -> None + | _ -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message "Did you forget a ` ( + (* Consume the closing name without mutating tokens beforehand *) + let closing_name_res = read_jsx_tag_name p in + match closing_name_res with + | Ok closing_name + when Ast_helper.Jsx.longident_of_jsx_tag_name closing_name.txt + = Ast_helper.Jsx.longident_of_jsx_tag_name name.txt -> + let end_tag_name = closing_name in + let closing_tag_end = p.start_pos in + Parser.expect GreaterThan p; + let loc = mk_loc start_pos p.prev_end_pos in + let closing_tag = + closing_tag_start + |> Option.map (fun closing_tag_start -> + { + Parsetree.jsx_closing_container_tag_start = closing_tag_start; + jsx_closing_container_tag_name = end_tag_name; + jsx_closing_container_tag_end = closing_tag_end; + }) + in + Ast_helper.Exp.jsx_container_element ~loc name jsx_props opening_tag_end + children closing_tag + | _ -> + let () = + if Grammar.is_structure_item_start token0 then ( + let closing = + "" + in + let msg = Diagnostics.message ("Missing " ^ closing) in + Parser.err ~start_pos ~end_pos:p.prev_end_pos p msg; + (* We attempted to read a closing name; consume the '>' to keep AST shape stable *) + Parser.expect GreaterThan p) + else + let opening = + "" + in + let msg = + "Closing jsx name should be the same as the opening name. Did \ + you mean " ^ opening ^ " ?" + in + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message msg); + (* read_jsx_tag_name already consumed the name; expect the '>') *) + Parser.expect GreaterThan p + in + let end_tag_name = + match closing_name_res with + | Ok closing_name -> closing_name + | Error invalid_str -> + {txt = Parsetree.JsxTagInvalid invalid_str; loc = Location.none} + in + let closing_tag_end = p.prev_end_pos in + let closing_tag = + closing_tag_start + |> Option.map (fun closing_tag_start -> + { + Parsetree.jsx_closing_container_tag_start = closing_tag_start; + jsx_closing_container_tag_name = end_tag_name; + jsx_closing_container_tag_end = closing_tag_end; + }) + in + Ast_helper.Exp.jsx_container_element + ~loc:(mk_loc start_pos p.prev_end_pos) + name jsx_props opening_tag_end children closing_tag) + | token -> + let () = + if Grammar.is_structure_item_start token then + let closing = + "" + in + let msg = Diagnostics.message ("Missing " ^ closing) in + Parser.err ~start_pos ~end_pos:p.prev_end_pos p msg + else + let opening = + "" + in + let msg = + "Closing jsx name should be the same as the opening name. Did you \ + mean " ^ opening ^ " ?" + in + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message msg) + in + Ast_helper.Exp.jsx_container_element + ~loc:(mk_loc start_pos p.prev_end_pos) + name jsx_props opening_tag_end children None) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Ast_helper.Exp.jsx_unary_element + ~loc:(mk_loc start_pos p.prev_end_pos) + name jsx_props + +(* + * jsx ::= + * | <> jsx-children + * | + * | jsx-children + * + * jsx-children ::= primary-expr* * => 0 or more + *) +and parse_jsx p = + Parser.leave_breadcrumb p Grammar.Jsx; + let start_pos = p.Parser.start_pos in + Parser.expect LessThan p; + let jsx_expr = + match p.Parser.token with + | Lident _ | Uident _ -> + parse_jsx_opening_or_self_closing_element ~start_pos p + | GreaterThan -> + (* fragment: <> foo *) + parse_jsx_fragment start_pos p + | _ -> + let tag_name = parse_jsx_name p in + let (loc : Location.t) = tag_name.loc in + let lid = Ast_helper.Jsx.longident_of_jsx_tag_name tag_name.txt in + Ast_helper.Exp.ident ~loc (Location.mkloc lid loc) + in + Parser.eat_breadcrumb p; + jsx_expr + +(* + * jsx-fragment ::= + * | <> + * | <> jsx-children + *) +and parse_jsx_fragment start_pos p = + let children_start_pos = p.Parser.start_pos in + Parser.expect GreaterThan p; + let children = parse_jsx_children p in + let children_end_pos = p.Parser.start_pos in + Parser.expect LessThan p; + Parser.expect Forwardslash p; + let end_pos = p.Parser.end_pos in + Parser.expect GreaterThan p; + (* location is from starting < till closing > *) + let loc = mk_loc start_pos end_pos in + Ast_helper.Exp.jsx_fragment ~attrs:[] ~loc children_start_pos children + children_end_pos + +(* + * jsx-prop ::= + * | lident + * | ?lident + * | lident = jsx_expr + * | lident = ?jsx_expr + * | {...jsx_expr} + *) +and parse_jsx_prop p : Parsetree.jsx_prop option = + match p.Parser.token with + | Question | Lident _ -> ( + let optional = Parser.optional p Question in + (* allow hyphens inside prop names by reading a local jsx name *) + match read_local_jsx_name p with + | Some (name, loc, `Lower) -> ( + if optional then Some (Parsetree.JSXPropPunning (true, {txt = name; loc})) + else + match p.Parser.token with + | Equal -> + Parser.next p; + let optional = Parser.optional p Question in + let attr_expr = parse_primary_expr ~operand:(parse_atomic_expr p) p in + Some (Parsetree.JSXPropValue ({txt = name; loc}, optional, attr_expr)) + | _ -> Some (Parsetree.JSXPropPunning (false, {txt = name; loc}))) + | Some (_name, _loc, `Upper) -> + Parser.err p (Diagnostics.message "JSX prop names must be lowercase"); + None + | None -> None) + (* {...props} *) + | Lbrace -> ( + let spread_start = p.Parser.start_pos in + Parser.next p; + match p.Parser.token with + | DotDotDot -> ( + Parser.next p; + let attr_expr = parse_primary_expr ~operand:(parse_expr p) p in + match p.Parser.token with + | Rbrace -> + let spread_end = p.Parser.end_pos in + let loc = mk_loc spread_start spread_end in + Parser.next p; + Some (Parsetree.JSXPropSpreading (loc, attr_expr)) + (* Some (label, attr_expr) *) + | _ -> None) + | _ -> None) + | _ -> None + +and parse_jsx_props p : Parsetree.jsx_prop list = + parse_region ~grammar:Grammar.JsxAttribute ~f:parse_jsx_prop p + +and parse_jsx_children p : Parsetree.jsx_children = + let rec loop p children = + match p.Parser.token with + | Token.Eof -> children + | LessThan when Scanner.peekSlash p.scanner -> children + | LessThan -> + (* Imagine:
< + * is `<` the start of a jsx-child?
+ * reconsiderLessThan peeks at the next token and + * determines the correct token to disambiguate *) + let child = + parse_primary_expr ~operand:(parse_atomic_expr p) ~no_call:true p + in + loop p (child :: children) + | token when Grammar.is_jsx_child_start token -> + let child = + parse_primary_expr ~operand:(parse_atomic_expr p) ~no_call:true p + in + loop p (child :: children) + | _ -> children + in + match p.Parser.token with + | DotDotDot -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.spread_children_no_longer_supported); + Parser.next p; + [parse_primary_expr ~operand:(parse_atomic_expr p) ~no_call:true p] + | _ -> List.rev (loop p []) + +and parse_braced_or_record_expr p = + let start_pos = p.Parser.start_pos in + Parser.expect Lbrace p; + match p.Parser.token with + | token when Token.is_keyword token -> ( + match + recover_keyword_field_name_if_probably_field p + ~mk_message:ErrorMessages.keyword_field_in_expr + with + | Some (recovered_field_name, loc) -> + Parser.expect Colon p; + let optional = parse_optional_label p in + let field_expr = parse_expr p in + let field = Location.mkloc (Longident.Lident recovered_field_name) loc in + let first_row = {Parsetree.lid = field; x = field_expr; opt = optional} in + let expr = parse_record_expr ~start_pos [first_row] p in + Parser.expect Rbrace p; + expr + | None -> + let expr = parse_expr_block p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes}) + | Rbrace -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.record ~loc [] None + | DotDotDot -> + (* beginning of record spread, parse record *) + Parser.next p; + let spread_expr = parse_constrained_or_coerced_expr p in + Parser.expect Comma p; + let expr = parse_record_expr ~start_pos ~spread:(Some spread_expr) [] p in + Parser.expect Rbrace p; + expr + | String s -> ( + let field = + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Location.mkloc (Longident.Lident s) loc + in + match p.Parser.token with + | Colon -> + Parser.next p; + let field_expr = parse_expr p in + Parser.optional p Comma |> ignore; + let expr = + parse_record_expr_with_string_keys ~start_pos + {Parsetree.lid = field; x = field_expr; opt = false} + p + in + Parser.expect Rbrace p; + expr + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_field_missing_colon); + Parser.next p; + let field_expr = parse_expr p in + Parser.optional p Comma |> ignore; + let expr = + parse_record_expr_with_string_keys ~start_pos + {Parsetree.lid = field; x = field_expr; opt = false} + p + in + Parser.expect Rbrace p; + expr + | _ -> ( + let tag = if p.mode = ParseForTypeChecker then Some "js" else None in + let constant = + Ast_helper.Exp.constant ~loc:field.loc + (Parsetree.Pconst_string (s, tag)) + in + let a = parse_primary_expr ~operand:constant p in + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in + match p.Parser.token with + | Semicolon -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + { + expr with + Parsetree.pexp_attributes = braces :: expr.Parsetree.pexp_attributes; + } + | Rbrace -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {e with pexp_attributes = braces :: e.pexp_attributes} + | _ -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | Question -> + let expr = parse_record_expr ~start_pos [] p in + Parser.expect Rbrace p; + expr + (* + The branch below takes care of the "braced" expression {async}. + The big reason that we need all these branches is that {x} isn't a record with a punned field x, but a braced expression… There's lots of "ambiguity" between a record with a single punned field and a braced expression… + What is {x}? + 1) record {x: x} + 2) expression x which happens to wrapped in braces + Due to historical reasons, we always follow 2 + *) + | Lident "async" when is_es6_arrow_expression ~in_ternary:false p -> + let expr = parse_async_arrow_expression p in + let expr = parse_expr_block ~first:expr p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes} + | Uident _ | Lident _ -> ( + let start_token = p.token in + let value_or_constructor = parse_value_or_constructor p in + match value_or_constructor.pexp_desc with + | Pexp_ident path_ident -> ( + let ident_end_pos = p.prev_end_pos in + match p.Parser.token with + | Comma -> + Parser.next p; + let value_or_constructor = + match start_token with + | Uident _ -> + remove_module_name_from_punned_field_value value_or_constructor + | _ -> value_or_constructor + in + let expr = + parse_record_expr ~start_pos + [ + {Parsetree.lid = path_ident; x = value_or_constructor; opt = false}; + ] + p + in + Parser.expect Rbrace p; + expr + | Colon -> ( + Parser.next p; + let optional = parse_optional_label p in + let field_expr = parse_expr p in + match p.token with + | Rbrace -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.record ~loc + [{lid = path_ident; x = field_expr; opt = optional}] + None + | _ -> + Parser.expect Comma p; + let expr = + parse_record_expr ~start_pos + [{lid = path_ident; x = field_expr; opt = optional}] + p + in + Parser.expect Rbrace p; + expr) + | Equal -> ( + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_field_missing_colon); + Parser.next p; + let optional = parse_optional_label p in + let field_expr = parse_expr p in + match p.Parser.token with + | Rbrace -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.record ~loc + [{lid = path_ident; x = field_expr; opt = optional}] + None + | _ -> + Parser.expect Comma p; + let expr = + parse_record_expr ~start_pos + [{lid = path_ident; x = field_expr; opt = optional}] + p + in + Parser.expect Rbrace p; + expr) + (* error case *) + | Lident _ -> + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then ( + Parser.expect Comma p; + let expr = + parse_record_expr ~start_pos + [{lid = path_ident; x = value_or_constructor; opt = false}] + p + in + Parser.expect Rbrace p; + expr) + else ( + Parser.expect Colon p; + let expr = + parse_record_expr ~start_pos + [{lid = path_ident; x = value_or_constructor; opt = false}] + p + in + Parser.expect Rbrace p; + expr) + | Semicolon -> + let expr = + parse_expr_block ~first:(Ast_helper.Exp.ident path_ident) p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let expr = Ast_helper.Exp.ident ~loc:path_ident.loc path_ident in + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes} + | EqualGreater -> ( + let loc = mk_loc start_pos ident_end_pos in + let ident = Location.mkloc (Longident.last path_ident.txt) loc in + let a = + parse_es6_arrow_expression ~async:false + ~term_parameters: + [ + { + attrs = []; + p_label = Nolabel; + expr = None; + pat = Ast_helper.Pat.var ~loc:ident.loc ident; + p_pos = start_pos; + }; + ] + p + in + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in + match p.Parser.token with + | Semicolon -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {e with pexp_attributes = braces :: e.pexp_attributes} + | _ -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes}) + | _ -> ( + Parser.leave_breadcrumb p Grammar.ExprBlock; + let a = + parse_primary_expr + ~operand:(Ast_helper.Exp.ident ~loc:path_ident.loc path_ident) + p + in + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in + Parser.eat_breadcrumb p; + match p.Parser.token with + | Semicolon -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {e with pexp_attributes = braces :: e.pexp_attributes} + | _ -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | _ -> ( + Parser.leave_breadcrumb p Grammar.ExprBlock; + let a = parse_primary_expr ~operand:value_or_constructor p in + let e = parse_binary_expr ~a p 1 in + let e = parse_ternary_expr e p in + Parser.eat_breadcrumb p; + match p.Parser.token with + | Semicolon -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes} + | Rbrace -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {e with pexp_attributes = braces :: e.pexp_attributes} + | _ -> + let expr = parse_expr_block ~first:e p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | _ -> + let expr = parse_expr_block p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let braces = make_braces_attr loc in + {expr with pexp_attributes = braces :: expr.pexp_attributes} + +and parse_record_expr_row_with_string_key p : + Parsetree.expression Parsetree.record_element option = + match p.Parser.token with + | String s -> ( + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + let field = Location.mkloc (Longident.Lident s) loc in + match p.Parser.token with + | Colon -> + Parser.next p; + let field_expr = parse_expr p in + Some {lid = field; x = field_expr; opt = false} + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_field_missing_colon); + Parser.next p; + let field_expr = parse_expr p in + Some {lid = field; x = field_expr; opt = false} + | _ -> + Some + { + lid = field; + x = Ast_helper.Exp.ident ~loc:field.loc field; + opt = false; + }) + | _ -> None + +and parse_record_expr_row p : + Parsetree.expression Parsetree.record_element option = + let attrs = parse_attributes p in + let () = + match p.Parser.token with + | Token.DotDotDot -> + Parser.err p (Diagnostics.message ErrorMessages.record_expr_spread); + Parser.next p + | _ -> () + in + match p.Parser.token with + | Lident _ | Uident _ -> ( + let start_token = p.token in + let field = parse_value_path p in + match p.Parser.token with + | Colon -> + Parser.next p; + let optional = parse_optional_label p in + let field_expr = parse_expr p in + Some {lid = field; x = field_expr; opt = optional} + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_field_missing_colon); + Parser.next p; + let optional = parse_optional_label p in + let field_expr = parse_expr p in + Some {lid = field; x = field_expr; opt = optional} + | _ -> + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match start_token with + | Uident _ -> remove_module_name_from_punned_field_value value + | _ -> value + in + Some {lid = field; x = value; opt = false}) + | Question -> ( + Parser.next p; + match p.Parser.token with + | Lident _ | Uident _ -> + let start_token = p.token in + let field = parse_value_path p in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match start_token with + | Uident _ -> remove_module_name_from_punned_field_value value + | _ -> value + in + Some {lid = field; x = value; opt = true} + | _ -> None) + | _ -> + if Token.is_keyword p.token then ( + match + recover_keyword_field_name_if_probably_field p + ~mk_message:ErrorMessages.keyword_field_in_expr + with + | Some (recovered_field_name, loc) -> + Parser.expect Colon p; + let optional = parse_optional_label p in + let field_expr = parse_expr p in + let field = + Location.mkloc (Longident.Lident recovered_field_name) loc + in + Some {lid = field; x = field_expr; opt = optional} + | None -> + emit_keyword_field_error p + ~mk_message:ErrorMessages.keyword_field_in_expr; + None) + else None + +and parse_dict_expr_row p = + match p.Parser.token with + | DotDotDot -> + Parser.err p (Diagnostics.message ErrorMessages.dict_expr_spread); + Parser.next p; + (* Parse the expr so it's consumed *) + let _spread_expr = parse_constrained_or_coerced_expr p in + None + | String s -> ( + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + let field = Location.mkloc (Longident.Lident s) loc in + match p.Parser.token with + | Colon -> + Parser.next p; + let fieldExpr = parse_expr p in + Some (field, fieldExpr) + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.dict_field_missing_colon); + Parser.next p; + let fieldExpr = parse_expr p in + Some (field, fieldExpr) + | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) + | _ -> None + +and parse_record_expr_with_string_keys ~start_pos first_row p = + let rows = + first_row + :: parse_comma_delimited_region ~grammar:Grammar.RecordRowsStringKey + ~closing:Rbrace ~f:parse_record_expr_row_with_string_key p + in + let loc = mk_loc start_pos p.end_pos in + let record_str_expr = + Ast_helper.Str.eval ~loc (Ast_helper.Exp.record ~loc rows None) + in + Ast_helper.Exp.extension ~loc + (Location.mkloc "obj" loc, Parsetree.PStr [record_str_expr]) + +and parse_record_expr ~start_pos ?(spread = None) rows p = + let exprs = + parse_comma_delimited_region ~grammar:Grammar.RecordRows ~closing:Rbrace + ~f:parse_record_expr_row p + in + let rows = rows @ exprs in + let () = + match rows with + | [] -> + let msg = "Record spread needs at least one field that's updated" in + Parser.err p (Diagnostics.message msg) + | _rows -> () + in + let loc = mk_loc start_pos p.end_pos in + Ast_helper.Exp.record ~loc rows spread + +and parse_newline_or_semicolon_expr_block p = + match p.Parser.token with + | Semicolon -> Parser.next p + | token when Grammar.is_block_expr_start token -> + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then () + else + Parser.err ~start_pos:p.prev_end_pos ~end_pos:p.end_pos p + (Diagnostics.message + "consecutive expressions on a line must be separated by ';' or a \ + newline") + | _ -> () + +and parse_expr_block_item p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in + match p.Parser.token with + | Module -> ( + Parser.next p; + match p.token with + | Lparen -> + let expr = parse_first_class_module_expr ~start_pos p in + let a = parse_primary_expr ~operand:expr p in + let expr = parse_binary_expr ~a p 1 in + parse_ternary_expr expr p + | _ -> + let name = + match p.Parser.token with + | Uident ident -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parse_module_binding_body p in + parse_newline_or_semicolon_expr_block p; + let expr = parse_expr_block p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.letmodule ~loc name body expr) + | Exception -> + let extension_constructor = parse_exception_def ~attrs p in + parse_newline_or_semicolon_expr_block p; + let block_expr = parse_expr_block p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.letexception ~loc extension_constructor block_expr + | Open -> + let od = parse_open_description ~attrs p in + parse_newline_or_semicolon_expr_block p; + let block_expr = parse_expr_block p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid block_expr + | Let {unwrap} -> + let rec_flag, let_bindings = + parse_let_bindings ~unwrap ~attrs ~start_pos p + in + parse_newline_or_semicolon_expr_block p; + let next = + if Grammar.is_block_expr_start p.Parser.token then parse_expr_block p + else + let loc = mk_loc p.start_pos p.end_pos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.let_ ~loc rec_flag let_bindings next + | Typ -> + (* Parse to be able to give a good error message. *) + let type_start = start_pos in + Parser.begin_region p; + let _ = parse_type_definition_or_extension ~attrs p in + Parser.end_region p; + Parser.err ~start_pos:type_start ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.type_definition_in_function); + parse_newline_or_semicolon_expr_block p; + parse_expr_block p + | _ -> + let e1 = + let expr = parse_expr p in + {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} + in + parse_newline_or_semicolon_expr_block p; + if Grammar.is_block_expr_start p.Parser.token then + let e2 = parse_expr_block p in + let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in + Ast_helper.Exp.sequence ~loc e1 e2 + else e1 + +(* blockExpr ::= expr + * | expr ; + * | expr ; blockExpr + * | module ... ; blockExpr + * | open ... ; blockExpr + * | exception ... ; blockExpr + * | let ... + * | let ... ; + * | let ... ; blockExpr + * + * note: semi should be made optional + * a block of expression is always + *) +and parse_expr_block ?first p = + Parser.leave_breadcrumb p Grammar.ExprBlock; + let item = + match first with + | Some e -> e + | None -> parse_expr_block_item p + in + parse_newline_or_semicolon_expr_block p; + let block_expr = + if Grammar.is_block_expr_start p.Parser.token then + let next = parse_expr_block_item p in + let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in + Ast_helper.Exp.sequence ~loc item next + else item + in + Parser.eat_breadcrumb p; + over_parse_constrained_or_coerced_or_arrow_expression p block_expr + +and parse_async_arrow_expression ?(arrow_attrs = []) p = + let start_pos = p.Parser.start_pos in + Parser.expect (Lident "async") p; + parse_es6_arrow_expression ~async:true ~arrow_attrs + ~arrow_start_pos:(Some start_pos) p + +and parse_await_expression p = + let await_loc = mk_loc p.Parser.start_pos p.end_pos in + Parser.expect Await p; + let token_prec = Token.precedence MinusGreater in + let expr = parse_binary_expr ~context:OrdinaryExpr p token_prec in + Ast_helper.Exp.await + ~loc:{expr.pexp_loc with loc_start = await_loc.loc_start} + ~attrs:[] expr + +and parse_try_expression p = + let start_pos = p.Parser.start_pos in + Parser.expect Try p; + let expr = parse_expr ~context:WhenExpr p in + Parser.expect Res_token.catch p; + Parser.expect Lbrace p; + let cases = parse_pattern_matching p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.try_ ~loc expr cases + +and parse_if_condition p = + Parser.leave_breadcrumb p Grammar.IfCondition; + (* doesn't make sense to try es6 arrow here? *) + let condition_expr = parse_expr ~context:WhenExpr p in + Parser.eat_breadcrumb p; + condition_expr + +and parse_then_branch p = + Parser.leave_breadcrumb p IfBranch; + Parser.expect Lbrace p; + let then_expr = parse_expr_block p in + Parser.expect Rbrace p; + Parser.eat_breadcrumb p; + then_expr + +and parse_else_branch p = + Parser.expect Lbrace p; + let block_expr = parse_expr_block p in + Parser.expect Rbrace p; + block_expr + +and parse_if_expr start_pos p = + let condition_expr = parse_if_condition p in + let then_expr = parse_then_branch p in + let else_expr = + match p.Parser.token with + | Else -> + Parser.end_region p; + Parser.leave_breadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.begin_region p; + let else_expr = + match p.token with + | If -> parse_if_or_if_let_expression p + | _ -> parse_else_branch p + in + Parser.eat_breadcrumb p; + Parser.end_region p; + Some else_expr + | _ -> + Parser.end_region p; + None + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.ifthenelse ~loc condition_expr then_expr else_expr + +and parse_if_let_expr start_pos p = + let pattern = parse_pattern p in + Parser.expect Equal p; + let condition_expr = parse_if_condition p in + let then_expr = parse_then_branch p in + let else_expr = + match p.Parser.token with + | Else -> + Parser.end_region p; + Parser.leave_breadcrumb p Grammar.ElseBranch; + Parser.next p; + Parser.begin_region p; + let else_expr = + match p.token with + | If -> parse_if_or_if_let_expression p + | _ -> parse_else_branch p + in + Parser.eat_breadcrumb p; + Parser.end_region p; + else_expr + | _ -> + Parser.end_region p; + let start_pos = p.Parser.start_pos in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.match_ + ~attrs:[if_let_attr; suppress_fragile_match_warning_attr] + ~loc condition_expr + [ + Ast_helper.Exp.case pattern then_expr; + Ast_helper.Exp.case (Ast_helper.Pat.any ()) else_expr; + ] + +and parse_if_or_if_let_expression p = + Parser.begin_region p; + Parser.leave_breadcrumb p Grammar.ExprIf; + let start_pos = p.Parser.start_pos in + Parser.expect If p; + let expr = + match p.Parser.token with + | Let _ -> + Parser.next p; + let if_let_expr = parse_if_let_expr start_pos p in + Parser.err ~start_pos:if_let_expr.pexp_loc.loc_start + ~end_pos:if_let_expr.pexp_loc.loc_end p + (Diagnostics.message (ErrorMessages.experimental_if_let if_let_expr)); + if_let_expr + | _ -> parse_if_expr start_pos p + in + Parser.eat_breadcrumb p; + expr + +and parse_for_rest has_opening_paren pattern start_pos p = + Parser.expect In p; + let e1 = parse_expr p in + let direction = + match p.Parser.token with + | Lident "to" -> Asttypes.Upto + | Lident "downto" -> Asttypes.Downto + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Asttypes.Upto + in + if p.Parser.token = Eof then + Parser.err ~start_pos:p.start_pos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs) + else Parser.next p; + let e2 = parse_expr ~context:WhenExpr p in + if has_opening_paren then Parser.expect Rparen p; + Parser.expect Lbrace p; + let body_expr = parse_expr_block p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.for_ ~loc pattern e1 e2 direction body_expr + +and parse_for_expression p = + let start_pos = p.Parser.start_pos in + Parser.leave_breadcrumb p Grammar.ExprFor; + Parser.expect For p; + Parser.begin_region p; + let for_expr = + match p.token with + | Lparen -> ( + let lparen = p.start_pos in + Parser.next p; + match p.token with + | Rparen -> + Parser.next p; + let unit_pattern = + let loc = mk_loc lparen p.prev_end_pos in + let lid = Location.mkloc (Longident.Lident "()") loc in + Ast_helper.Pat.construct lid None + in + parse_for_rest false + (parse_alias_pattern ~attrs:[] unit_pattern p) + start_pos p + | _ -> ( + Parser.leave_breadcrumb p Grammar.Pattern; + let pat = parse_pattern p in + Parser.eat_breadcrumb p; + match p.token with + | Comma -> + Parser.next p; + let tuple_pattern = + parse_tuple_pattern ~attrs:[] ~start_pos:lparen ~first:pat p + in + let pattern = parse_alias_pattern ~attrs:[] tuple_pattern p in + parse_for_rest false pattern start_pos p + | _ -> parse_for_rest true pat start_pos p)) + | _ -> + Parser.leave_breadcrumb p Grammar.Pattern; + let pat = parse_pattern p in + Parser.eat_breadcrumb p; + parse_for_rest false pat start_pos p + in + Parser.eat_breadcrumb p; + Parser.end_region p; + for_expr + +and parse_while_expression p = + let start_pos = p.Parser.start_pos in + Parser.expect While p; + let expr1 = parse_expr ~context:WhenExpr p in + Parser.expect Lbrace p; + let expr2 = parse_expr_block p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.while_ ~loc expr1 expr2 + +and parse_pattern_guard p = + match p.Parser.token with + | When | If -> + Parser.next p; + Some (parse_expr ~context:WhenExpr p) + | _ -> None + +and parse_pattern_match_case p = + Parser.begin_region p; + Parser.leave_breadcrumb p Grammar.PatternMatchCase; + match p.Parser.token with + | Token.Bar -> + let bar = p.start_pos in + Parser.next p; + Parser.leave_breadcrumb p Grammar.Pattern; + let lhs = parse_pattern p in + Parser.eat_breadcrumb p; + let guard = parse_pattern_guard p in + let () = + match p.token with + | EqualGreater -> Parser.next p + | _ -> Recover.recover_equal_greater p + in + let rhs = parse_expr_block p in + Parser.end_region p; + Parser.eat_breadcrumb p; + Some (Ast_helper.Exp.case ~bar lhs ?guard rhs) + | _ -> + Parser.end_region p; + Parser.eat_breadcrumb p; + None + +and parse_pattern_matching p = + let cases = + parse_delimited_region ~grammar:Grammar.PatternMatching ~closing:Rbrace + ~f:parse_pattern_match_case p + in + let () = + match cases with + | [] -> + Parser.err ~start_pos:p.prev_end_pos p + (Diagnostics.message "Pattern matching needs at least one case") + | _ -> () + in + cases + +and parse_switch_expression p = + let start_pos = p.Parser.start_pos in + Parser.expect Switch p; + let switch_expr = parse_expr ~context:WhenExpr p in + Parser.expect Lbrace p; + let cases = parse_pattern_matching p in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.match_ ~loc switch_expr cases + +(* + * argument ::= + * | _ (* syntax sugar *) + * | expr + * | expr : type + * | ~ label-name + * | ~ label-name + * | ~ label-name ? + * | ~ label-name = expr + * | ~ label-name = _ (* syntax sugar *) + * | ~ label-name = expr : type + * | ~ label-name = ? expr + * | ~ label-name = ? _ (* syntax sugar *) + * | ~ label-name = ? expr : type + * + * dotted_argument ::= + * | . argument + *) +and parse_argument p : argument option = + if + p.Parser.token = Token.Tilde + || p.token = Dot || p.token = Underscore + || Grammar.is_expr_start p.token + then + match p.Parser.token with + | Dot -> ( + Parser.next p; + match p.token with + (* apply(.) *) + | Rparen -> + let unit_expr = + Ast_helper.Exp.construct + (Location.mknoloc (Longident.Lident "()")) + None + in + Some {label = Asttypes.Nolabel; expr = unit_expr} + | _ -> parse_argument2 p) + | _ -> parse_argument2 p + else None + +and parse_argument2 p : argument option = + match p.Parser.token with + (* foo(_), do not confuse with foo(_ => x), TODO: performance *) + | Underscore when not (is_es6_arrow_expression ~in_ternary:false p) -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + let expr = + Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) + in + Some {label = Nolabel; expr} + | Tilde -> ( + Parser.next p; + (* TODO: nesting of pattern matches not intuitive for error recovery *) + match p.Parser.token with + | Lident ident -> ( + let start_pos = p.start_pos in + Parser.next p; + let end_pos = p.prev_end_pos in + let loc = mk_loc start_pos end_pos in + let named_arg_loc = loc in + let ident_expr = + Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident ident) loc) + in + match p.Parser.token with + | Question -> + Parser.next p; + Some + { + label = Optional {txt = ident; loc = named_arg_loc}; + expr = ident_expr; + } + | Equal -> + Parser.next p; + let label = + match p.Parser.token with + | Question -> + Parser.next p; + Asttypes.Optional {txt = ident; loc = named_arg_loc} + | _ -> Asttypes.Labelled {txt = ident; loc = named_arg_loc} + in + let expr = + match p.Parser.token with + | Underscore when not (is_es6_arrow_expression ~in_ternary:false p) -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Ast_helper.Exp.ident ~loc + (Location.mkloc (Longident.Lident "_") loc) + | _ -> parse_constrained_or_coerced_expr p + in + Some {label; expr} + | Colon -> + let colon_start = p.start_pos in + Parser.next p; + let colon_end = p.prev_end_pos in + if Grammar.is_typ_expr_start p.Parser.token then + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + let expr = Ast_helper.Exp.constraint_ ~loc ident_expr typ in + Some + {label = Asttypes.Labelled {txt = ident; loc = named_arg_loc}; expr} + else + let label, expr = + match p.Parser.token with + | Question -> + Parser.err ~start_pos:colon_start ~end_pos:colon_end p + (Diagnostics.message + ErrorMessages.optional_labelled_argument_missing_equal); + Parser.next p; + let expr = parse_constrained_or_coerced_expr p in + (Asttypes.Optional {txt = ident; loc = named_arg_loc}, expr) + | _ -> + Parser.err ~start_pos:colon_start ~end_pos:colon_end p + (Diagnostics.message + ErrorMessages.labelled_argument_missing_equal); + let expr = + match p.Parser.token with + | Underscore + when not (is_es6_arrow_expression ~in_ternary:false p) -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Ast_helper.Exp.ident ~loc + (Location.mkloc (Longident.Lident "_") loc) + | _ -> parse_constrained_or_coerced_expr p + in + (Asttypes.Labelled {txt = ident; loc = named_arg_loc}, expr) + in + Some {label; expr} + | _ -> + Some + { + label = Asttypes.Labelled {txt = ident; loc = named_arg_loc}; + expr = ident_expr; + }) + | t -> + Parser.err p (Diagnostics.lident t); + Some {label = Nolabel; expr = Recover.default_expr ()}) + | _ -> Some {label = Nolabel; expr = parse_constrained_or_coerced_expr p} + +and parse_call_expr p fun_expr = + Parser.expect Lparen p; + let start_pos = p.Parser.start_pos in + Parser.leave_breadcrumb p Grammar.ExprCall; + let args = + parse_comma_delimited_region ~grammar:Grammar.ArgumentList ~closing:Rparen + ~f:parse_argument p + in + let partial = + match p.token with + | DotDotDot when args <> [] -> + Parser.next p; + true + | _ -> false + in + Parser.expect Rparen p; + let args = + match args with + | [] -> + let loc = mk_loc start_pos p.prev_end_pos in + (* No args -> unit sugar: `foo()` *) + [ + { + label = Nolabel; + expr = + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None; + }; + ] + | args -> args + in + let loc = {fun_expr.pexp_loc with loc_end = p.prev_end_pos} in + let args = + match args with + | {label = lbl; expr} :: args -> + let group (grp, acc) {label = lbl; expr} = ((lbl, expr) :: grp, acc) in + let grp, acc = List.fold_left group ([(lbl, expr)], []) args in + List.rev (List.rev grp :: acc) + | [] -> [] + in + let apply = + Ext_list.fold_left args fun_expr (fun call_body args -> + let args, wrap = process_underscore_application args in + let exp = Ast_helper.Exp.apply ~loc ~partial call_body args in + wrap exp) + in + + Parser.eat_breadcrumb p; + apply + +and parse_value_or_constructor p = + let start_pos = p.Parser.start_pos in + let rec aux p acc = + match p.Parser.token with + | Uident ident -> ( + let end_pos_lident = p.end_pos in + Parser.next p; + match p.Parser.token with + | Dot -> + Parser.next p; + aux p (ident :: acc) + | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let lparen = p.start_pos in + let args = parse_constructor_args p in + let rparen = p.prev_end_pos in + let lident = build_longident (ident :: acc) in + let tail = + match args with + | [] -> None + | [({Parsetree.pexp_desc = Pexp_tuple _} as arg)] as args -> + let loc = mk_loc lparen rparen in + if p.mode = ParseForTypeChecker then + (* Some(1, 2) for type-checker *) + Some arg + else + (* Some((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc args) + | [arg] -> Some arg + | args -> + let loc = mk_loc lparen rparen in + Some (Ast_helper.Exp.tuple ~loc args) + in + let loc = mk_loc start_pos p.prev_end_pos in + let ident_loc = mk_loc start_pos end_pos_lident in + Ast_helper.Exp.construct ~loc (Location.mkloc lident ident_loc) tail + | _ -> + let loc = mk_loc start_pos p.prev_end_pos in + let lident = build_longident (ident :: acc) in + Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) + | Lident ident -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let lident = build_longident (ident :: acc) in + Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) + | token -> + if acc = [] then ( + Parser.next_unsafe p; + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.default_expr ()) + else + let loc = mk_loc start_pos p.prev_end_pos in + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = build_longident ("_" :: acc) in + Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) + in + aux p [] + +and parse_poly_variant_expr p = + let start_pos = p.start_pos in + let ident, _loc = parse_hash_ident ~start_pos p in + match p.Parser.token with + | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let lparen = p.start_pos in + let args = parse_constructor_args p in + let rparen = p.prev_end_pos in + let loc_paren = mk_loc lparen rparen in + let tail = + match args with + | [] -> None + | [({Parsetree.pexp_desc = Pexp_tuple _} as expr)] as args -> + if p.mode = ParseForTypeChecker then + (* #a(1, 2) for type-checker *) + Some expr + else + (* #a((1, 2)) for type-checker *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + | [arg] -> Some arg + | args -> + (* #a((1, 2)) for printer *) + Some (Ast_helper.Exp.tuple ~loc:loc_paren args) + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.variant ~loc ident tail + | _ -> + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.variant ~loc ident None + +and parse_constructor_args p = + let lparen = p.Parser.start_pos in + Parser.expect Lparen p; + let args = + parse_comma_delimited_region ~grammar:Grammar.ExprList + ~f:parse_constrained_expr_region ~closing:Rparen p + in + Parser.expect Rparen p; + match args with + | [] -> + let loc = mk_loc lparen p.prev_end_pos in + [ + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + None; + ] + | args -> args + +and parse_tuple_expr ~first ~start_pos p = + let exprs = + first + :: parse_comma_delimited_region p ~grammar:Grammar.ExprList ~closing:Rparen + ~f:parse_constrained_expr_region + in + Parser.expect Rparen p; + let () = + match exprs with + | [_] -> + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.tuple_single_element) + | _ -> () + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Exp.tuple ~loc exprs + +and parse_spread_expr_region_with_loc p = + let start_pos = p.Parser.prev_end_pos in + match p.Parser.token with + | DotDotDot -> + Parser.next p; + let expr = parse_constrained_or_coerced_expr p in + Some (true, expr, start_pos, p.prev_end_pos) + | token when Grammar.is_expr_start token -> + Some (false, parse_constrained_or_coerced_expr p, start_pos, p.prev_end_pos) + | _ -> None + +and parse_list_expr ~start_pos p = + let split_by_spread exprs = + List.fold_left + (fun acc curr -> + match (curr, acc) with + | (true, expr, start_pos, end_pos), _ -> + (* find a spread expression, prepend a new sublist *) + ([], Some expr, start_pos, end_pos) :: acc + | ( (false, expr, start_pos, _endPos), + (no_spreads, spread, _accStartPos, acc_end_pos) :: acc ) -> + (* find a non-spread expression, and the accumulated is not empty, + * prepend to the first sublist, and update the loc of the first sublist *) + (expr :: no_spreads, spread, start_pos, acc_end_pos) :: acc + | (false, expr, start_pos, end_pos), [] -> + (* find a non-spread expression, and the accumulated is empty *) + [([expr], None, start_pos, end_pos)]) + [] exprs + in + let make_sub_expr = function + | exprs, Some spread, start_pos, end_pos -> + Ast_helper.Exp.make_list_expression (mk_loc start_pos end_pos) exprs + (Some spread) + | exprs, None, start_pos, end_pos -> + Ast_helper.Exp.make_list_expression (mk_loc start_pos end_pos) exprs None + in + let list_exprs_rev = + parse_comma_delimited_reversed_list p ~grammar:Grammar.ListExpr + ~closing:Rbrace ~f:parse_spread_expr_region_with_loc + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + match split_by_spread list_exprs_rev with + | [] -> Ast_helper.Exp.make_list_expression loc [] None + | [(exprs, Some spread, _, _)] -> + Ast_helper.Exp.make_list_expression loc exprs (Some spread) + | [(exprs, None, _, _)] -> Ast_helper.Exp.make_list_expression loc exprs None + | exprs -> + let list_exprs = List.map make_sub_expr exprs in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc ~attrs:[spread_attr] + (Location.mkloc + (Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) + loc)) + [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc list_exprs)] + +and parse_dict_expr ~start_pos p = + let rows = + parse_comma_delimited_region ~grammar:Grammar.DictRows ~closing:Rbrace + ~f:parse_dict_expr_row p + in + let loc = mk_loc start_pos p.end_pos in + let to_key_value_pair + (record_item : Longident.t Location.loc * Parsetree.expression) = + match record_item with + | ( {Location.txt = Longident.Lident key; loc = keyLoc}, + ({pexp_loc = value_loc} as value_expr) ) -> + Some + (Ast_helper.Exp.tuple + ~loc:(mk_loc keyLoc.loc_start value_loc.loc_end) + [ + Ast_helper.Exp.constant ~loc:keyLoc (Pconst_string (key, None)); + value_expr; + ]) + | _ -> None + in + let key_value_pairs = List.filter_map to_key_value_pair rows in + Parser.expect Rbrace p; + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc + (Location.mkloc + (Longident.Ldot (Longident.Lident Primitive_modules.dict, "make")) + loc)) + [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc key_value_pairs)] + +and parse_array_exp p = + let start_pos = p.Parser.start_pos in + Parser.expect Lbracket p; + let split_by_spread exprs = + List.fold_left + (fun acc curr -> + match (curr, acc) with + | (true, expr, start_pos, end_pos), _ -> + (* find a spread expression, prepend a new sublist *) + ([], Some expr, start_pos, end_pos) :: acc + | ( (false, expr, start_pos, _endPos), + (no_spreads, spread, _accStartPos, acc_end_pos) :: acc ) -> + (* find a non-spread expression, and the accumulated is not empty, + * prepend to the first sublist, and update the loc of the first sublist *) + (expr :: no_spreads, spread, start_pos, acc_end_pos) :: acc + | (false, expr, start_pos, end_pos), [] -> + (* find a non-spread expression, and the accumulated is empty *) + [([expr], None, start_pos, end_pos)]) + [] exprs + in + let list_exprs_rev = + parse_comma_delimited_reversed_list p ~grammar:Grammar.ExprList + ~closing:Rbracket ~f:parse_spread_expr_region_with_loc + in + Parser.expect Rbracket p; + let loc = mk_loc start_pos p.prev_end_pos in + let collect_exprs = function + | [], Some spread, _startPos, _endPos -> [spread] + | exprs, Some spread, _startPos, _endPos -> + let els = Ast_helper.Exp.array ~loc exprs in + [els; spread] + | exprs, None, _startPos, _endPos -> + let els = Ast_helper.Exp.array ~loc exprs in + [els] + in + match split_by_spread list_exprs_rev with + | [] -> Ast_helper.Exp.array ~loc:(mk_loc start_pos p.prev_end_pos) [] + | [(exprs, None, _, _)] -> + Ast_helper.Exp.array ~loc:(mk_loc start_pos p.prev_end_pos) exprs + | exprs -> + let xs = List.map collect_exprs exprs in + let list_exprs = + List.fold_right + (fun exprs1 acc -> + List.fold_right (fun expr1 acc1 -> expr1 :: acc1) exprs1 acc) + xs [] + in + Ast_helper.Exp.apply ~loc + (Ast_helper.Exp.ident ~loc ~attrs:[spread_attr] + (Location.mkloc + (Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "Array"), "concatMany")) + loc)) + [(Nolabel, Ast_helper.Exp.array ~loc list_exprs)] + +(* TODO: check attributes in the case of poly type vars, + * might be context dependend: parseFieldDeclaration (see ocaml) *) +and parse_poly_type_expr ?current_type_name_path ?inline_types_context p = + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | SingleQuote -> ( + let vars = parse_type_var_list p in + match vars with + | _v1 :: _v2 :: _ -> + Parser.expect Dot p; + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.poly ~loc vars typ + | [var] -> ( + match p.Parser.token with + | Dot -> + Parser.next p; + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.poly ~loc vars typ + | EqualGreater -> + Parser.next p; + let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc typ.Parsetree.ptyp_loc.loc_start p.prev_end_pos in + Ast_helper.Typ.arrow ~loc ~arity:(Some 1) + {attrs = []; lbl = Nolabel; typ} + return_type + | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) + | _ -> assert false) + | _ -> parse_typ_expr ?current_type_name_path ?inline_types_context p + +(* 'a 'b 'c *) +and parse_type_var_list p = + let rec loop p vars = + match p.Parser.token with + | SingleQuote -> + Parser.next p; + let lident, loc = + parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + in + let var = Location.mkloc lident loc in + loop p (var :: vars) + | _ -> List.rev vars + in + loop p [] + +and parse_lident_list p = + let rec loop p ls = + match p.Parser.token with + | Lident lident -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + loop p (Location.mkloc lident loc :: ls) + | _ -> List.rev ls + in + loop p [] + +and parse_atomic_typ_expr ?current_type_name_path ?inline_types_context ~attrs p + = + Parser.leave_breadcrumb p Grammar.AtomicTypExpr; + let start_pos = p.Parser.start_pos in + let typ = + match p.Parser.token with + | SingleQuote -> + Parser.next p; + let ident, loc = + if p.Parser.token = Eof then ( + Parser.err ~start_pos:p.start_pos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mk_loc p.start_pos p.prev_end_pos)) + else parse_ident ~msg:ErrorMessages.type_var ~start_pos:p.start_pos p + in + Ast_helper.Typ.var ~loc ~attrs ident + | Underscore -> + let end_pos = p.end_pos in + Parser.next p; + Ast_helper.Typ.any ~loc:(mk_loc start_pos end_pos) ~attrs () + | Lparen -> ( + Parser.next p; + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let unit_constr = Location.mkloc (Longident.Lident "unit") loc in + Ast_helper.Typ.constr ~attrs unit_constr [] + | _ -> ( + let t = parse_typ_expr p in + match p.token with + | Comma -> + Parser.next p; + parse_tuple_type ~attrs ~first:t ~start_pos p + | _ -> + Parser.expect Rparen p; + { + t with + ptyp_loc = mk_loc start_pos p.prev_end_pos; + ptyp_attributes = List.concat [attrs; t.ptyp_attributes]; + })) + | Lbracket -> parse_polymorphic_variant_type ~attrs p + | Uident _ | Lident _ -> + let constr = parse_value_path p in + let args = + parse_type_constructor_args ?inline_types_context + ?current_type_name_path ~constr_name:constr p + in + let number_of_inline_records_in_args = + match inline_types_context with + | None -> 0 + | Some inline_types_context -> + let inline_types = inline_types_context.found_inline_types in + args + |> List.filter (fun (c : Parsetree.core_type) -> + match c.ptyp_desc with + | Ptyp_constr ({txt = Lident typename}, _) -> + inline_types + |> List.exists (fun (name, _, _) -> name = typename) + | _ -> false) + |> List.length + in + if number_of_inline_records_in_args > 1 then + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message + ErrorMessages.multiple_inline_record_definitions_at_same_path); + Ast_helper.Typ.constr + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs constr args + | Module -> + Parser.next p; + Parser.expect Lparen p; + let package_type = parse_package_type ~start_pos ~attrs p in + Parser.expect Rparen p; + {package_type with ptyp_loc = mk_loc start_pos p.prev_end_pos} + | Percent -> + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.extension ~attrs ~loc extension + | Lbrace -> + parse_record_or_object_type ?current_type_name_path ?inline_types_context + ~attrs p + | Eof -> + Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + Recover.default_type () + | token -> ( + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + match + skip_tokens_and_maybe_retry p + ~is_start_of_grammar:Grammar.is_atomic_typ_expr_start + with + | Some () -> parse_atomic_typ_expr ~attrs p + | None -> + Parser.err ~start_pos:p.prev_end_pos p + (Diagnostics.unexpected token p.breadcrumbs); + Recover.default_type ()) + in + Parser.eat_breadcrumb p; + typ + +(* package-type ::= + | modtype-path + ∣ modtype-path with package-constraint { and package-constraint } +*) +and parse_package_type ~start_pos ~attrs p = + let mod_type_path = parse_module_long_ident ~lowercase:true p in + match p.Parser.token with + | Lident "with" -> + Parser.next p; + let constraints = parse_package_constraints p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.package ~loc ~attrs mod_type_path constraints + | _ -> + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.package ~loc ~attrs mod_type_path [] + +(* package-constraint { and package-constraint } *) +and parse_package_constraints p = + let first = + Parser.expect Typ p; + let type_constr = parse_value_path p in + Parser.expect Equal p; + let typ = parse_typ_expr p in + (type_constr, typ) + in + let rest = + parse_region ~grammar:Grammar.PackageConstraint ~f:parse_package_constraint + p + in + first :: rest + +(* and type typeconstr = typexpr *) +and parse_package_constraint p = + match p.Parser.token with + | And -> + Parser.next p; + Parser.expect Typ p; + let type_constr = parse_value_path p in + Parser.expect Equal p; + let typ = parse_typ_expr p in + Some (type_constr, typ) + | _ -> None + +and parse_record_or_object_type ?current_type_name_path ?inline_types_context + ~attrs p = + (* for inline record in constructor *) + let start_pos = p.Parser.start_pos in + Parser.expect Lbrace p; + let closed_flag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed + in + match (inline_types_context, current_type_name_path) with + | Some inline_types_context, Some current_type_name_path + when Grammar.is_record_decl_start p.token -> + let labels = + parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f: + (parse_field_declaration_region ~current_type_name_path + ~inline_types_context) + p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let inline_type_name = current_type_name_path |> String.concat "." in + + inline_types_context.found_inline_types <- + (inline_type_name, loc, Parsetree.Ptype_record labels) + :: inline_types_context.found_inline_types; + + let lid = Location.mkloc (Longident.Lident inline_type_name) loc in + Ast_helper.Typ.constr ~loc lid (inline_types_context.params |> List.map fst) + | _ -> + let () = + match p.token with + | Lident _ -> + Parser.err p + (Diagnostics.message ErrorMessages.forbidden_inline_record_declaration) + | _ -> () + in + let fields = + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.object_ ~loc ~attrs fields closed_flag + +(* TODO: check associativity in combination with attributes *) +and parse_type_alias p typ = + match p.Parser.token with + | As -> + Parser.next p; + Parser.expect SingleQuote p; + let ident, _loc = + parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + in + (* TODO: how do we parse attributes here? *) + Ast_helper.Typ.alias + ~loc:(mk_loc typ.Parsetree.ptyp_loc.loc_start p.prev_end_pos) + typ ident + | _ -> typ + +(* type_parameter ::= + * | type_expr + * | ~ident: type_expr + * | ~ident: type_expr=? + * + * note: + * | attrs ~ident: type_expr -> attrs are on the arrow + * | attrs type_expr -> attrs are here part of the type_expr + * + * dotted_type_parameter ::= + * | . type_parameter + *) +and parse_type_parameter p = + let doc_attr : Parsetree.attributes = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + if + p.Parser.token = Token.Tilde + || p.token = Dot + || Grammar.is_typ_expr_start p.token + then + let start_pos = p.Parser.start_pos in + let _ = + Parser.optional p Dot + (* dot is ignored *) + in + let attrs = doc_attr @ parse_attributes p in + match p.Parser.token with + | Tilde -> ( + Parser.next p; + let name, loc = parse_lident p in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parse_typ_expr p in + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some {attrs; label = Optional {txt = name; loc}; typ; start_pos} + | _ -> Some {attrs; label = Labelled {txt = name; loc}; typ; start_pos}) + | Lident _ -> ( + let name, loc = parse_lident p in + match p.token with + | Colon -> ( + let () = + let error = + Diagnostics.message + (ErrorMessages.missing_tilde_labeled_parameter name) + in + Parser.err ~start_pos:loc.loc_start ~end_pos:loc.loc_end p error + in + Parser.next p; + let typ = parse_typ_expr p in + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Some {attrs; label = Optional {txt = name; loc}; typ; start_pos} + | _ -> Some {attrs; label = Labelled {txt = name; loc}; typ; start_pos}) + | _ -> + let constr = Location.mkloc (Longident.Lident name) loc in + let args = parse_type_constructor_args ~constr_name:constr p in + let typ = + Ast_helper.Typ.constr + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs constr args + in + + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in + let typ = parse_type_alias p typ in + Some {attrs = []; label = Nolabel; typ; start_pos}) + | _ -> + let typ = parse_typ_expr p in + let typ_with_attributes = + {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]} + in + Some {attrs = []; label = Nolabel; typ = typ_with_attributes; start_pos} + else None + +(* (int, ~x:string, float) *) +and parse_type_parameters p = + let start_pos = p.Parser.start_pos in + Parser.expect Lparen p; + match p.Parser.token with + | Rparen -> + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let unit_constr = Location.mkloc (Longident.Lident "unit") loc in + let typ = Ast_helper.Typ.constr unit_constr [] in + [{attrs = []; label = Nolabel; typ; start_pos}] + | _ -> + let params = + parse_comma_delimited_region ~grammar:Grammar.TypeParameters + ~closing:Rparen ~f:parse_type_parameter p + in + Parser.expect Rparen p; + params + +and parse_es6_arrow_type ~attrs p = + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | Tilde -> + Parser.next p; + let name, label_loc = parse_lident p in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ = parse_typ_expr ~alias:false ~es6_arrow:false p in + let lbl = + match p.Parser.token with + | Equal -> + Parser.next p; + Parser.expect Question p; + Asttypes.Optional {txt = name; loc = label_loc} + | _ -> Asttypes.Labelled {txt = name; loc = label_loc} + in + Parser.expect EqualGreater p; + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl; typ} return_type + | DocComment _ -> assert false + | _ -> + let parameters = parse_type_parameters p in + Parser.expect EqualGreater p; + let return_type = parse_typ_expr ~alias:false p in + let end_pos = p.prev_end_pos in + let return_type_arity = 0 in + let _paramNum, typ, _arity = + List.fold_right + (fun {attrs; label = arg_lbl; typ; start_pos} (param_num, t, arity) -> + let loc = mk_loc start_pos end_pos in + let arity = + (* Workaround for ~lbl: @as(json`false`) _, which changes the arity *) + match arg_lbl with + | Labelled _s -> + let typ_is_any = + match typ.ptyp_desc with + | Ptyp_any -> true + | _ -> false + in + let has_as = + Ext_list.exists typ.ptyp_attributes (fun (x, _) -> x.txt = "as") + in + if !InExternal.status && typ_is_any && has_as then arity - 1 + else arity + | _ -> arity + in + let t_arg = + Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl = arg_lbl; typ} t + in + if param_num = 1 then + (param_num - 1, Ast_uncurried.uncurried_type ~arity t_arg, 1) + else (param_num - 1, t_arg, arity + 1)) + parameters + (List.length parameters, return_type, return_type_arity + 1) + in + { + typ with + ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; + ptyp_loc = mk_loc start_pos p.prev_end_pos; + } + +(* + * typexpr ::= + * | 'ident + * | _ + * | (typexpr) + * | typexpr => typexpr --> es6 arrow + * | (typexpr, typexpr) => typexpr --> es6 arrow + * | /typexpr, typexpr, typexpr/ --> tuple + * | typeconstr + * | typeconstr + * | typeconstr + * | typexpr as 'ident + * | %attr-id --> extension + * | %attr-id(payload) --> extension + * + * typeconstr ::= + * | lident + * | uident.lident + * | uident.uident.lident --> long module path + *) +and parse_typ_expr ?current_type_name_path ?inline_types_context ?attrs + ?(es6_arrow = true) ?(alias = true) p = + (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) + let start_pos = p.Parser.start_pos in + let attrs = + match attrs with + | Some attrs -> attrs + | None -> parse_attributes p + in + let typ = + if es6_arrow && is_es6_arrow_type p then parse_es6_arrow_type ~attrs p + else + let typ = + parse_atomic_typ_expr ?current_type_name_path ?inline_types_context + ~attrs p + in + parse_arrow_type_rest ~es6_arrow ~start_pos typ p + in + let typ = if alias then parse_type_alias p typ else typ in + (* Parser.eatBreadcrumb p; *) + typ + +and parse_arrow_type_rest ~es6_arrow ~start_pos typ p = + match p.Parser.token with + | (EqualGreater | MinusGreater) as token when es6_arrow == true -> + (* error recovery *) + if token = MinusGreater then Parser.expect EqualGreater p; + Parser.next p; + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.arrow ~loc ~arity:(Some 1) + {attrs = []; lbl = Nolabel; typ} + return_type + | _ -> typ + +and parse_typ_expr_region p = + if Grammar.is_typ_expr_start p.Parser.token then Some (parse_typ_expr p) + else None + +and parse_tuple_type ~attrs ~first ~start_pos p = + let typexprs = + first + :: parse_comma_delimited_region ~grammar:Grammar.TypExprList ~closing:Rparen + ~f:parse_typ_expr_region p + in + Parser.expect Rparen p; + let () = + match typexprs with + | [_] -> + Parser.err ~start_pos ~end_pos:p.prev_end_pos p + (Diagnostics.message ErrorMessages.tuple_single_element) + | _ -> () + in + let tuple_loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.tuple ~attrs ~loc:tuple_loc typexprs + +and parse_type_constructor_arg_region ?inline_types_context + ?current_type_name_path p = + if Grammar.is_typ_expr_start p.Parser.token then + Some (parse_typ_expr ?inline_types_context ?current_type_name_path p) + else if p.token = LessThan then ( + Parser.next p; + parse_type_constructor_arg_region ?inline_types_context + ?current_type_name_path p) + else None + +(* Js.Nullable.value<'a> *) +and parse_type_constructor_args ?inline_types_context ?current_type_name_path + ~constr_name p = + let opening = p.Parser.token in + let opening_start_pos = p.start_pos in + match opening with + | LessThan | Lparen -> + Scanner.set_diamond_mode p.scanner; + Parser.next p; + let type_args = + (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:GreaterThan + ~f: + (parse_type_constructor_arg_region ?inline_types_context + ?current_type_name_path) + p + in + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let typ = Ast_helper.Typ.constr constr_name type_args in + let msg = + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat + [ + Doc.line; + ResPrinter.print_typ_expr typ CommentTable.empty; + ]); + ]) + |> Doc.to_string ~width:80 + in + Parser.err ~start_pos:opening_start_pos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p + in + Scanner.pop_mode p.scanner Diamond; + type_args + | _ -> [] + +(* string-field-decl ::= + * | string: poly-typexpr + * | attributes string-field-decl *) +and parse_string_field_declaration p = + let attrs = parse_attributes p in + match p.Parser.token with + | String name -> + let name_start_pos = p.start_pos in + let name_end_pos = p.end_pos in + Parser.next p; + let field_name = Location.mkloc name (mk_loc name_start_pos name_end_pos) in + (match p.Parser.token with + | Colon -> Parser.next p + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + Parser.next p + | _ -> Parser.expect ~grammar:Grammar.TypeExpression Colon p); + let typ = parse_poly_type_expr p in + Some (Parsetree.Otag (field_name, attrs, typ)) + | DotDotDot -> + Parser.next p; + let typ = parse_typ_expr p in + Some (Parsetree.Oinherit typ) + | Lident name -> + let name_loc = mk_loc p.start_pos p.end_pos in + Parser.err p + (Diagnostics.message (ErrorMessages.object_quoted_field_name name)); + Parser.next p; + let field_name = Location.mkloc name name_loc in + (match p.Parser.token with + | Colon -> Parser.next p + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + Parser.next p + | _ -> Parser.expect ~grammar:Grammar.TypeExpression Colon p); + let typ = parse_poly_type_expr p in + Some (Parsetree.Otag (field_name, attrs, typ)) + | _token -> None + +(* field-decl ::= + * | [mutable] field-name : poly-typexpr + * | attributes field-decl *) +and parse_field_declaration ?current_type_name_path ?inline_types_context p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in + let mut = + if Parser.optional p Token.Mutable then Asttypes.Mutable + else Asttypes.Immutable + in + let lident, loc = + match p.token with + | _ -> parse_lident p + in + let optional = parse_optional_label p in + let name = Location.mkloc lident loc in + let typ = + match p.Parser.token with + | Colon -> + Parser.next p; + let current_type_name_path = + extend_current_type_name_path current_type_name_path name.txt + in + parse_poly_type_expr ?current_type_name_path ?inline_types_context p + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + Parser.next p; + let current_type_name_path = + extend_current_type_name_path current_type_name_path name.txt + in + parse_poly_type_expr ?current_type_name_path ?inline_types_context p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in + Ast_helper.Type.field ~attrs ~loc ~mut ~optional name typ + +and parse_field_declaration_region ?current_type_name_path ?inline_types_context + ?found_object_field p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in + let mut = + if Parser.optional p Token.Mutable then Asttypes.Mutable + else Asttypes.Immutable + in + match p.token with + | DotDotDot -> + Parser.next p; + let name = Location.mkloc "..." (mk_loc start_pos p.prev_end_pos) in + let typ = parse_poly_type_expr p in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in + Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) + | String s when found_object_field <> None -> + Option.get found_object_field := true; + Parser.next p; + let name = Location.mkloc s (mk_loc start_pos p.prev_end_pos) in + Parser.expect Colon p; + let typ = parse_poly_type_expr p in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in + Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) + | Lident _ -> + let lident, loc = parse_lident p in + let name = Location.mkloc lident loc in + let current_type_name_path = + extend_current_type_name_path current_type_name_path name.txt + in + let optional = parse_optional_label p in + let typ = + match p.Parser.token with + | Colon -> + Parser.next p; + parse_poly_type_expr ?current_type_name_path ?inline_types_context p + | Equal -> + Parser.err ~start_pos:p.start_pos ~end_pos:p.end_pos p + (Diagnostics.message ErrorMessages.record_type_field_missing_colon); + Parser.next p; + parse_poly_type_expr ?current_type_name_path ?inline_types_context p + | _ -> + Ast_helper.Typ.constr ~loc:name.loc ~attrs + {name with txt = Lident name.txt} + [] + in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in + Some (Ast_helper.Type.field ~attrs ~loc ~mut ~optional name typ) + | _ -> + if Token.is_keyword p.token then ( + match + recover_keyword_field_name_if_probably_field p + ~mk_message:ErrorMessages.keyword_field_in_type + with + | Some (recovered_field_name, name_loc) -> + let optional = parse_optional_label p in + Parser.expect Colon p; + let typ = + parse_poly_type_expr ?current_type_name_path ?inline_types_context p + in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in + let name = Location.mkloc recovered_field_name name_loc in + Some (Ast_helper.Type.field ~attrs ~loc ~mut ~optional name typ) + | None -> + emit_keyword_field_error p + ~mk_message:ErrorMessages.keyword_field_in_type; + None) + else ( + if attrs <> [] then + Parser.err ~start_pos p + (Diagnostics.message + "Attributes and doc comments can only be used at the beginning of \ + a field declaration"); + if mut = Mutable then + Parser.err ~start_pos p + (Diagnostics.message + "The `mutable` qualifier can only be used at the beginning of a \ + field declaration"); + None) + +(* record-decl ::= + * | { field-decl } + * | { field-decl, field-decl } + * | { field-decl, field-decl, field-decl, } + *) +and parse_record_declaration ?current_type_name_path ?inline_types_context p = + Parser.leave_breadcrumb p Grammar.RecordDecl; + Parser.expect Lbrace p; + let rows = + parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context) + p + in + Parser.expect Rbrace p; + Parser.eat_breadcrumb p; + rows + +(* constr-args ::= + * | (typexpr) + * | (typexpr, typexpr) + * | (typexpr, typexpr, typexpr,) + * | (record-decl) + * + * TODO: should we overparse inline-records in every position? + * Give a good error message afterwards? + *) +and parse_constr_decl_args p = + let constr_args = + match p.Parser.token with + | Lparen -> ( + Parser.next p; + (* TODO: this could use some cleanup/stratification *) + match p.Parser.token with + | Lbrace -> ( + Parser.next p; + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | DotDot | Dot -> + let closed_flag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed + in + let fields = + parse_comma_delimited_region + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parse_string_field_declaration p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag in + Parser.optional p Comma |> ignore; + let more_args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: more_args) + | DotDotDot -> ( + let dotdotdot_start = p.start_pos in + let dotdotdot_end = p.end_pos in + (* start of spread, e.g. `User({...a, "u": int})` *) + Parser.next p; + let spread_typ = parse_typ_expr p in + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.next p; + let spread_field_name = + Location.mkloc "..." (mk_loc dotdotdot_start dotdotdot_end) + in + let spread_field_loc = + mk_loc start_pos spread_typ.ptyp_loc.loc_end + in + let spread_field = + Ast_helper.Type.field ~attrs:[] ~loc:spread_field_loc + ~mut:Asttypes.Immutable spread_field_name spread_typ + in + Parser.optional p Comma |> ignore; + Parser.expect Rparen p; + Parsetree.Pcstr_record [spread_field] + | _ -> ( + let res = + parse_spread_tail_classified ~start_pos ~spread_typ + ~grammar:Grammar.FieldDeclarations p + in + match res with + | `Record fields -> + let spread_field_name = + Location.mkloc "..." (mk_loc dotdotdot_start dotdotdot_end) + in + let spread_field_loc = + mk_loc start_pos spread_typ.ptyp_loc.loc_end + in + let spread_field = + Ast_helper.Type.field ~attrs:[] ~loc:spread_field_loc + ~mut:Asttypes.Immutable spread_field_name spread_typ + in + Parser.optional p Comma |> ignore; + Parser.expect Rparen p; + Parsetree.Pcstr_record (spread_field :: fields) + | `Object typ -> + Parser.optional p Comma |> ignore; + let more_args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: more_args))) + | _ -> ( + let attrs = parse_attributes p in + match p.Parser.token with + | String _ -> + let closed_flag = Asttypes.Closed in + let fields = + match attrs with + | [] -> + parse_comma_delimited_region + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parse_string_field_declaration p + | attrs -> + let first = + Parser.leave_breadcrumb p Grammar.StringFieldDeclarations; + let field = + match parse_string_field_declaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eat_breadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> + Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + in + first + :: parse_comma_delimited_region + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parse_string_field_declaration p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag + |> parse_type_alias p + in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in + Parser.optional p Comma |> ignore; + let more_args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple (typ :: more_args) + | _ -> + let fields = + match attrs with + | [] -> + parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace ~f:parse_field_declaration_region p + | attrs -> + let first = + let field = parse_field_declaration p in + {field with Parsetree.pld_attributes = attrs} + in + if p.token = Rbrace then [first] + else ( + Parser.expect Comma p; + first + :: parse_comma_delimited_region + ~grammar:Grammar.FieldDeclarations ~closing:Rbrace + ~f:parse_field_declaration_region p) + in + Parser.expect Rbrace p; + Parser.optional p Comma |> ignore; + Parser.expect Rparen p; + Parsetree.Pcstr_record fields)) + | _ -> + let args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList + ~closing:Rparen ~f:parse_typ_expr_region p + in + Parser.expect Rparen p; + Parsetree.Pcstr_tuple args) + | _ -> Pcstr_tuple [] + in + let res = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parse_typ_expr p) + | _ -> None + in + (constr_args, res) + +(* Helper to check if current token is a bar or doc comment followed by a bar *) +and is_bar_or_doc_comment_then_bar p = + Parser.lookahead p (fun state -> + match state.Parser.token with + | DocComment _ -> ( + Parser.next state; + match state.token with + | Bar -> true + | _ -> false) + | Bar -> true + | _ -> false) + +(* constr-decl ::= + * | constr-name + * | attrs constr-name + * | constr-name const-args + * | attrs constr-name const-args *) +and parse_type_constructor_declaration_with_bar p = + if is_bar_or_doc_comment_then_bar p then ( + let doc_comment_attrs = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + let start_pos = p.Parser.start_pos in + Parser.next p; + let constr = parse_type_constructor_declaration ~start_pos p in + Some + { + constr with + Parsetree.pcd_attributes = + doc_comment_attrs @ constr.Parsetree.pcd_attributes; + }) + else None + +and parse_type_constructor_declaration ~start_pos p = + Parser.leave_breadcrumb p Grammar.ConstructorDeclaration; + let attrs = parse_attributes p in + match p.Parser.token with + | DotDotDot -> + Parser.next p; + let name = Location.mkloc "..." (mk_loc start_pos p.prev_end_pos) in + let typ = parse_poly_type_expr p in + let loc = mk_loc start_pos typ.ptyp_loc.loc_end in + Ast_helper.Type.constructor ~loc ~attrs ~args:(Pcstr_tuple [typ]) name + | Uident uident -> + let uident_loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + let args, res = parse_constr_decl_args p in + Parser.eat_breadcrumb p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Type.constructor ~loc ~attrs ?res ~args + (Location.mkloc uident uident_loc) + | t -> + Parser.err p (Diagnostics.uident t); + Ast_helper.Type.constructor (Location.mknoloc "_") + +(* [|] constr-decl { | constr-decl } *) +and parse_type_constructor_declarations ?first p = + let first_constr_decl = + match first with + | None -> + let doc_comment_attrs = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + let start_pos = p.Parser.start_pos in + ignore (Parser.optional p Token.Bar); + let constr = parse_type_constructor_declaration ~start_pos p in + {constr with pcd_attributes = doc_comment_attrs @ constr.pcd_attributes} + | Some first_constr_decl -> first_constr_decl + in + first_constr_decl + :: parse_region ~grammar:Grammar.ConstructorDeclaration + ~f:parse_type_constructor_declaration_with_bar p + +(* + * type-representation ::= + * ∣ = [ | ] constr-decl { | constr-decl } + * ∣ = private [ | ] constr-decl { | constr-decl } + * | = | + * ∣ = private | + * ∣ = record-decl + * ∣ = private record-decl + * | = .. + *) +and parse_type_representation ?current_type_name_path ?inline_types_context p = + Parser.leave_breadcrumb p Grammar.TypeRepresentation; + (* = consumed *) + let private_flag = + if Parser.optional p Token.Private then Asttypes.Private + else Asttypes.Public + in + let kind = + match p.Parser.token with + | Bar | Uident _ | DocComment _ -> + Parsetree.Ptype_variant (parse_type_constructor_declarations p) + | At -> ( + (* Attributes can prefix either a variant (constructor list), a record, or an + open/extensible variant marker (`..`). Peek past attributes and any doc + comments to decide which kind it is. *) + let after_attrs = + Parser.lookahead p (fun state -> + ignore (parse_attributes state); + skip_doc_comments state; + state.Parser.token) + in + match after_attrs with + | Lbrace -> + (* consume the attributes and any doc comments before the record *) + ignore (parse_attributes p); + skip_doc_comments p; + Parsetree.Ptype_record + (parse_record_declaration ?current_type_name_path + ?inline_types_context p) + | DotDot -> + (* attributes before an open variant marker; consume attrs/docs then handle `..` *) + ignore (parse_attributes p); + skip_doc_comments p; + Parser.next p; + (* consume DotDot *) + Ptype_open + | _ -> + (* fall back to variant constructor declarations; leave attributes for the + constructor parsing so they attach to the first constructor. *) + Parsetree.Ptype_variant (parse_type_constructor_declarations p)) + | Lbrace -> + Parsetree.Ptype_record + (parse_record_declaration ?current_type_name_path ?inline_types_context + p) + | DotDot -> + Parser.next p; + Ptype_open + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + (* TODO: I have no idea if this is even remotely a good idea *) + Parsetree.Ptype_variant [] + in + Parser.eat_breadcrumb p; + (private_flag, kind) + +(* type-param ::= + * | variance 'lident + * | variance 'uident + * | variance _ + * + * variance ::= + * | + + * | - + * | (* empty *) + *) +and parse_type_param p = + let variance = + match p.Parser.token with + | Plus -> + Parser.next p; + Asttypes.Covariant + | Minus -> + Parser.next p; + Contravariant + | _ -> Invariant + in + match p.Parser.token with + | SingleQuote -> + Parser.next p; + let ident, loc = + if p.Parser.token = Eof then ( + Parser.err ~start_pos:p.start_pos p + (Diagnostics.unexpected p.Parser.token p.breadcrumbs); + ("", mk_loc p.start_pos p.prev_end_pos)) + else parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + in + Some (Ast_helper.Typ.var ~loc ident, variance) + | Underscore -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Some (Ast_helper.Typ.any ~loc (), variance) + | (Uident _ | Lident _) as token -> + Parser.err p + (Diagnostics.message + ("Type params start with a singlequote: '" ^ Token.to_string token)); + let ident, loc = + parse_ident ~msg:ErrorMessages.type_param ~start_pos:p.start_pos p + in + Some (Ast_helper.Typ.var ~loc ident, variance) + | _token -> None + +(* type-params ::= + * | + * ∣ + * ∣ + * ∣ + * + * TODO: when we have pretty-printer show an error + * with the actual code corrected. *) +and parse_type_params ~parent p = + let opening = p.Parser.token in + match opening with + | (LessThan | Lparen) when p.start_pos.pos_lnum == p.prev_end_pos.pos_lnum -> + Scanner.set_diamond_mode p.scanner; + let opening_start_pos = p.start_pos in + Parser.leave_breadcrumb p Grammar.TypeParams; + Parser.next p; + let params = + parse_comma_delimited_region ~grammar:Grammar.TypeParams + ~closing:GreaterThan ~f:parse_type_param p + in + let () = + match p.token with + | Rparen when opening = Token.Lparen -> + let msg = + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.text "Type parameters require angle brackets:"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.concat + [ + ResPrinter.print_longident parent.Location.txt; + ResPrinter.print_type_params params + CommentTable.empty; + ]; + ]); + ]) + |> Doc.to_string ~width:80 + in + Parser.err ~start_pos:opening_start_pos p (Diagnostics.message msg); + Parser.next p + | _ -> Parser.expect GreaterThan p + in + Scanner.pop_mode p.scanner Diamond; + Parser.eat_breadcrumb p; + params + | _ -> [] + +(* type-constraint ::= constraint ' ident = typexpr *) +and parse_type_constraint p = + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | Token.Constraint -> ( + Parser.next p; + Parser.expect SingleQuote p; + match p.Parser.token with + | Lident ident | Uident ident -> + let ident_loc = mk_loc start_pos p.end_pos in + Parser.next p; + Parser.expect Equal p; + let typ = parse_typ_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Typ.var ~loc:ident_loc ident, typ, loc) + | t -> + Parser.err p (Diagnostics.lident t); + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Typ.any (), parse_typ_expr p, loc)) + | _ -> None + +(* type-constraints ::= + * | (* empty *) + * | type-constraint + * | type-constraint type-constraint + * | type-constraint type-constraint type-constraint (* 0 or more *) + *) +and parse_type_constraints p = + parse_region ~grammar:Grammar.TypeConstraint ~f:parse_type_constraint p + +and parse_type_equation_or_constr_decl p = + let uident_start_pos = p.Parser.start_pos in + match p.Parser.token with + | Uident uident -> ( + Parser.next p; + match p.Parser.token with + | Dot -> ( + Parser.next p; + let type_constr = + parse_value_path_tail p uident_start_pos (Longident.Lident uident) + in + let loc = mk_loc uident_start_pos p.prev_end_pos in + let typ = + parse_type_alias p + (Ast_helper.Typ.constr ~loc type_constr + (parse_type_constructor_args ~constr_name:type_constr p)) + in + match p.token with + | Equal -> + Parser.next p; + let priv, kind = parse_type_representation p in + (Some typ, priv, kind) + | EqualGreater -> + Parser.next p; + let return_type = parse_typ_expr ~alias:false p in + let loc = mk_loc uident_start_pos p.prev_end_pos in + let arrow_type = + Ast_helper.Typ.arrow ~loc ~arity:(Some 1) + {attrs = []; lbl = Nolabel; typ} + return_type + in + let typ = parse_type_alias p arrow_type in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) + | _ -> + let uident_end_pos = p.prev_end_pos in + let args, res = parse_constr_decl_args p in + let first = + Some + (let uident_loc = mk_loc uident_start_pos uident_end_pos in + Ast_helper.Type.constructor + ~loc:(mk_loc uident_start_pos p.prev_end_pos) + ?res ~args + (Location.mkloc uident uident_loc)) + in + ( None, + Asttypes.Public, + Parsetree.Ptype_variant (parse_type_constructor_declarations p ?first) + )) + | t -> + Parser.err p (Diagnostics.uident t); + (* TODO: is this a good idea? *) + (None, Asttypes.Public, Parsetree.Ptype_abstract) + +and parse_spread_tail_classified ?current_type_name_path ?inline_types_context + ~start_pos ~spread_typ ~grammar p = + match p.token with + | Rbrace -> + (* `{...t}` no extra fields: treat as record without tail fields *) + Parser.next p; + `Record [] + | _ -> + Parser.expect Comma p; + let found_object_field = ref false in + let (fields : Parsetree.label_declaration list) = + parse_comma_delimited_region ~grammar ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context ~found_object_field) + p + in + Parser.expect Rbrace p; + if !found_object_field then + (* Object-style: build an object type that inherits the spread *) + let obj_fields = + let convert (ld : Parsetree.label_declaration) = + let ({Parsetree.pld_name; pld_type; pld_attributes; _} + : Parsetree.label_declaration) = + ld + in + match pld_name.txt with + | "..." -> Parsetree.Oinherit pld_type + | _ -> Otag (pld_name, pld_attributes, pld_type) + in + Parsetree.Oinherit spread_typ :: List.map convert fields + in + let loc = mk_loc start_pos p.prev_end_pos in + let typ = + Ast_helper.Typ.object_ ~loc obj_fields Asttypes.Closed + |> parse_type_alias p + in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in + `Object typ + else `Record fields + +and parse_record_or_object_decl ?current_type_name_path ?inline_types_context p + = + let start_pos = p.Parser.start_pos in + Parser.expect Lbrace p; + match p.Parser.token with + | DotDot | Dot -> + let closed_flag = + match p.token with + | DotDot -> + Parser.next p; + Asttypes.Open + | Dot -> + Parser.next p; + Asttypes.Closed + | _ -> Asttypes.Closed + in + let fields = + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag + |> parse_type_alias p + in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | DotDotDot -> ( + let dotdotdot_start = p.start_pos in + let dotdotdot_end = p.end_pos in + (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) + Parser.next p; + let typ = parse_typ_expr p in + match p.token with + | Rbrace -> + (* {...x}, spread without extra fields *) + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + let dot_field = + Ast_helper.Type.field ~loc + {txt = "..."; loc = mk_loc dotdotdot_start dotdotdot_end} + typ + in + let kind = Parsetree.Ptype_record [dot_field] in + (None, Public, kind) + | _ -> + Parser.expect Comma p; + let loc = mk_loc start_pos p.prev_end_pos in + let dot_field = + Ast_helper.Type.field ~loc + {txt = "..."; loc = mk_loc dotdotdot_start dotdotdot_end} + typ + in + let found_object_field = ref false in + let fields = + parse_comma_delimited_region ~grammar:Grammar.RecordDecl ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context ~found_object_field) + p + in + Parser.expect Rbrace p; + if !found_object_field then + let fields = + Ext_list.map fields (fun ld -> + match ld.pld_name.txt with + | "..." -> Parsetree.Oinherit ld.pld_type + | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) + in + let dot_field = Parsetree.Oinherit typ in + let typ_obj = Ast_helper.Typ.object_ (dot_field :: fields) Closed in + let typ_obj = parse_type_alias p typ_obj in + let typ_obj = + parse_arrow_type_rest ~es6_arrow:true ~start_pos typ_obj p + in + (Some typ_obj, Public, Ptype_abstract) + else + let kind = Parsetree.Ptype_record (dot_field :: fields) in + (None, Public, kind)) + | _ -> ( + let attrs = parse_attributes p in + match p.Parser.token with + | String _ -> + let closed_flag = Asttypes.Closed in + let fields = + match attrs with + | [] -> + parse_comma_delimited_region ~grammar:Grammar.StringFieldDeclarations + ~closing:Rbrace ~f:parse_string_field_declaration p + | attrs -> + let first = + Parser.leave_breadcrumb p Grammar.StringFieldDeclarations; + let field = + match parse_string_field_declaration p with + | Some field -> field + | None -> assert false + in + (* parse comma after first *) + let () = + match p.Parser.token with + | Rbrace | Eof -> () + | Comma -> Parser.next p + | _ -> Parser.expect Comma p + in + Parser.eat_breadcrumb p; + match field with + | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) + | Oinherit ct -> Oinherit ct + in + first + :: parse_comma_delimited_region + ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace + ~f:parse_string_field_declaration p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + let typ = + Ast_helper.Typ.object_ ~loc ~attrs:[] fields closed_flag + |> parse_type_alias p + in + let typ = parse_arrow_type_rest ~es6_arrow:true ~start_pos typ p in + (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) + | _ -> + Parser.leave_breadcrumb p Grammar.RecordDecl; + let fields = + (* XXX *) + match attrs with + | [] -> + parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context) + p + | attr :: _ as attrs -> + let first = + let field = + parse_field_declaration ?current_type_name_path + ?inline_types_context p + in + Parser.optional p Comma |> ignore; + { + field with + Parsetree.pld_attributes = attrs; + pld_loc = + { + field.Parsetree.pld_loc with + loc_start = (attr |> fst).loc.loc_start; + }; + } + in + first + :: parse_comma_delimited_region ~grammar:Grammar.FieldDeclarations + ~closing:Rbrace + ~f: + (parse_field_declaration_region ?current_type_name_path + ?inline_types_context) + p + in + Parser.expect Rbrace p; + Parser.eat_breadcrumb p; + (None, Asttypes.Public, Parsetree.Ptype_record fields)) + +and parse_private_eq_or_repr p = + Parser.expect Private p; + match p.Parser.token with + | Lbrace -> + let manifest, _, kind = parse_record_or_object_decl p in + (manifest, Asttypes.Private, kind) + | Uident _ -> + let manifest, _, kind = parse_type_equation_or_constr_decl p in + (manifest, Asttypes.Private, kind) + | Bar | DotDot -> + let _, kind = parse_type_representation p in + (None, Asttypes.Private, kind) + | t when Grammar.is_typ_expr_start t -> + (Some (parse_typ_expr p), Asttypes.Private, Parsetree.Ptype_abstract) + | _ -> + let _, kind = parse_type_representation p in + (None, Asttypes.Private, kind) + +(* + polymorphic-variant-type ::= + | [ tag-spec-first { | tag-spec } ] + | [> [ tag-spec ] { | tag-spec } ] + | [< [|] tag-spec-full { | tag-spec-full } [ > { `tag-name }+ ] ] + + tag-spec-first ::= `tag-name [ of typexpr ] + | [ typexpr ] | tag-spec + + tag-spec ::= `tag-name [ of typexpr ] + | typexpr + + tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ] + | typexpr +*) +and parse_polymorphic_variant_type ~attrs p = + let start_pos = p.Parser.start_pos in + Parser.expect Lbracket p; + match p.token with + | GreaterThan -> + Parser.next p; + let row_fields = + match p.token with + | Rbracket -> [] + | Bar -> parse_tag_specs p + | _ -> + let row_field = parse_tag_spec p in + row_field :: parse_tag_specs p + in + let variant = + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.variant ~attrs ~loc row_fields Open None + in + Parser.expect Rbracket p; + variant + | LessThan -> + Parser.next p; + Parser.optional p Bar |> ignore; + let row_field = parse_tag_spec_full p in + let row_fields = parse_tag_spec_fulls p in + let tag_names = parse_tag_names p in + let variant = + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.variant ~attrs ~loc (row_field :: row_fields) Closed + (Some tag_names) + in + Parser.expect Rbracket p; + variant + | _ -> + let row_fields1 = parse_tag_spec_first p in + let row_fields2 = parse_tag_specs p in + let variant = + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Typ.variant ~attrs ~loc (row_fields1 @ row_fields2) Closed None + in + Parser.expect Rbracket p; + variant + +and parse_tag_name p = + match p.Parser.token with + | Hash -> + let ident, _loc = parse_hash_ident ~start_pos:p.start_pos p in + Some ident + | _ -> None + +and parse_tag_names p = + if p.Parser.token == GreaterThan then ( + Parser.next p; + parse_region p ~grammar:Grammar.TagNames ~f:parse_tag_name) + else [] + +and parse_tag_spec_fulls p = + match p.Parser.token with + | Rbracket -> [] + | GreaterThan -> [] + | Bar -> + Parser.next p; + let row_field = parse_tag_spec_full p in + row_field :: parse_tag_spec_fulls p + | _ -> [] + +and parse_tag_spec_full p = + let attrs = parse_attributes p in + match p.Parser.token with + | Hash -> parse_polymorphic_variant_type_spec_hash ~attrs ~full:true p + | _ -> + let typ = parse_typ_expr ~attrs p in + Parsetree.Rinherit typ + +and parse_tag_specs p = + match p.Parser.token with + | (Bar | DocComment _) when is_bar_or_doc_comment_then_bar p -> + let doc_comment_attrs = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + Parser.expect Bar p; + let tag = parse_tag_spec p in + let tag_with_doc = + match tag with + | Parsetree.Rtag (name, attrs, contains_constant, types) -> + Parsetree.Rtag + (name, doc_comment_attrs @ attrs, contains_constant, types) + | Rinherit typ -> + Rinherit + {typ with ptyp_attributes = doc_comment_attrs @ typ.ptyp_attributes} + in + tag_with_doc :: parse_tag_specs p + | _ -> [] + +and parse_tag_spec p = + let doc_comment_attrs = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + let attrs = doc_comment_attrs @ parse_attributes p in + match p.Parser.token with + | Hash -> parse_polymorphic_variant_type_spec_hash ~attrs ~full:false p + | _ -> + let typ = parse_typ_expr ~attrs p in + Parsetree.Rinherit typ + +and parse_tag_spec_first p = + match p.Parser.token with + | (Bar | DocComment _) when is_bar_or_doc_comment_then_bar p -> + let doc_comment_attrs = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + Parser.expect Bar p; + let tag = parse_tag_spec p in + (match tag with + | Parsetree.Rtag (name, attrs, contains_constant, types) -> + Parsetree.Rtag (name, doc_comment_attrs @ attrs, contains_constant, types) + | Rinherit typ -> + Rinherit + {typ with ptyp_attributes = doc_comment_attrs @ typ.ptyp_attributes}) + :: parse_tag_specs p + | DocComment _ | Hash | At -> ( + let doc_comment_attrs = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + let attrs = doc_comment_attrs @ parse_attributes p in + match p.Parser.token with + | Hash -> [parse_polymorphic_variant_type_spec_hash ~attrs ~full:false p] + | _ -> ( + let typ = parse_typ_expr ~attrs p in + match p.token with + | Rbracket -> + (* example: [ListStyleType.t] *) + [Parsetree.Rinherit typ] + | _ -> + Parser.expect Bar p; + [Parsetree.Rinherit typ; parse_tag_spec p])) + | _ -> ( + let typ = parse_typ_expr p in + match p.token with + | Rbracket -> + (* example: [ListStyleType.t] *) + [Parsetree.Rinherit typ] + | _ -> + Parser.expect Bar p; + [Parsetree.Rinherit typ; parse_tag_spec p]) + +and parse_polymorphic_variant_type_spec_hash ~attrs ~full p : + Parsetree.row_field = + let start_pos = p.Parser.start_pos in + let ident, loc = parse_hash_ident ~start_pos p in + let rec loop p = + match p.Parser.token with + | Ampersand when full -> + Parser.next p; + let row_field = parse_polymorphic_variant_type_args p in + row_field :: loop p + | _ -> [] + in + let first_tuple, tag_contains_a_constant_empty_constructor = + match p.Parser.token with + | Ampersand when full -> + Parser.next p; + ([parse_polymorphic_variant_type_args p], true) + | Lparen -> ([parse_polymorphic_variant_type_args p], false) + | _ -> ([], true) + in + let tuples = first_tuple @ loop p in + Parsetree.Rtag + ( Location.mkloc ident loc, + attrs, + tag_contains_a_constant_empty_constructor, + tuples ) + +and parse_polymorphic_variant_type_args p = + let start_pos = p.Parser.start_pos in + Parser.expect Lparen p; + let args = + parse_comma_delimited_region ~grammar:Grammar.TypExprList ~closing:Rparen + ~f:parse_typ_expr_region p + in + Parser.expect Rparen p; + let attrs = [] in + let loc = mk_loc start_pos p.prev_end_pos in + match args with + | [({ptyp_desc = Ptyp_tuple _} as typ)] as types -> + if p.mode = ParseForTypeChecker then typ + else Ast_helper.Typ.tuple ~loc ~attrs types + | [typ] -> typ + | types -> Ast_helper.Typ.tuple ~loc ~attrs types + +and parse_type_equation_and_representation ?current_type_name_path + ?inline_types_context p = + match p.Parser.token with + | (Equal | Bar) as token -> ( + if token = Bar then Parser.expect Equal p; + Parser.next p; + match p.Parser.token with + | Uident _ -> parse_type_equation_or_constr_decl p + | Lbrace -> + parse_record_or_object_decl ?current_type_name_path ?inline_types_context + p + | Private -> parse_private_eq_or_repr p + | Bar | DotDot | DocComment _ -> + let priv, kind = parse_type_representation p in + (None, priv, kind) + | At -> ( + (* Attributes can start a representation (variant/record/open variant) or a manifest. + Look ahead past attributes (and doc comments). If a representation-like token follows, + parse it as a representation; otherwise treat as a manifest. *) + let is_representation_after_attrs = + Parser.lookahead p (fun state -> + ignore (parse_attributes state); + (* optionally skip a run of doc comments before deciding *) + skip_doc_comments state; + match state.Parser.token with + | Lbrace -> ( + (* Disambiguate record declaration vs object type. + Peek inside the braces; if it looks like an object (String/Dot/DotDot/DotDotDot), + then this is a manifest type expression, not a representation. If it looks like + a record field (e.g. Lident or attributes before one), treat as representation. *) + Parser.next state; + (* consume Lbrace *) + ignore (parse_attributes state); + skip_doc_comments state; + match state.Parser.token with + | String _ | Dot | DotDot | DotDotDot -> + false (* object type => manifest *) + | _ -> true + (* record decl => representation *)) + | Bar -> true (* variant constructor list *) + | DotDot -> true (* extensible/open variant ".." *) + | Uident _ -> ( + (* constructor vs module-qualified manifest *) + Parser.next state; + match state.Parser.token with + | Dot -> false (* M.t => manifest *) + | _ -> true + (* Uident starting a constructor *)) + | DocComment _ -> true (* doc before constructor list *) + | _ -> false) + in + if is_representation_after_attrs then + let priv, kind = parse_type_representation p in + (None, priv, kind) + else + let manifest = Some (parse_typ_expr p) in + match p.Parser.token with + | Equal -> + Parser.next p; + let priv, kind = + parse_type_representation ?current_type_name_path + ?inline_types_context p + in + (manifest, priv, kind) + | _ -> (manifest, Public, Parsetree.Ptype_abstract)) + | _ -> ( + let manifest = Some (parse_typ_expr p) in + match p.Parser.token with + | Equal -> + Parser.next p; + let priv, kind = + parse_type_representation ?current_type_name_path + ?inline_types_context p + in + (manifest, priv, kind) + | _ -> (manifest, Public, Parsetree.Ptype_abstract))) + | _ -> (None, Public, Parsetree.Ptype_abstract) + +(* type-definition ::= type [rec] typedef { and typedef } + * typedef ::= typeconstr-name [type-params] type-information + * type-information ::= [type-equation] [type-representation] { type-constraint } + * type-equation ::= = typexpr *) +and parse_type_def ~attrs ~start_pos p = + Parser.leave_breadcrumb p Grammar.TypeDef; + (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *) + Parser.leave_breadcrumb p Grammar.TypeConstrName; + let name, loc = parse_lident p in + let type_constr_name = Location.mkloc name loc in + Parser.eat_breadcrumb p; + let params = + let constr_name = Location.mkloc (Longident.Lident name) loc in + parse_type_params ~parent:constr_name p + in + let type_def = + let manifest, priv, kind = parse_type_equation_and_representation p in + let cstrs = parse_type_constraints p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest + type_constr_name + in + Parser.eat_breadcrumb p; + type_def + +and parse_type_extension ~params ~attrs ~name p = + Parser.expect PlusEqual p; + let priv = + if Parser.optional p Token.Private then Asttypes.Private + else Asttypes.Public + in + let constr_start = p.Parser.start_pos in + Parser.optional p Bar |> ignore; + let first = + let attrs, name, kind = + match p.Parser.token with + | Bar -> + Parser.next p; + parse_constr_def ~parse_attrs:true p + | _ -> parse_constr_def ~parse_attrs:true p + in + let loc = mk_loc constr_start p.prev_end_pos in + Ast_helper.Te.constructor ~loc ~attrs name kind + in + let rec loop p cs = + match p.Parser.token with + | Bar -> + let start_pos = p.Parser.start_pos in + Parser.next p; + let attrs, name, kind = parse_constr_def ~parse_attrs:true p in + let ext_constr = + Ast_helper.Te.constructor ~attrs + ~loc:(mk_loc start_pos p.prev_end_pos) + name kind + in + loop p (ext_constr :: cs) + | _ -> List.rev cs + in + let constructors = loop p [first] in + Ast_helper.Te.mk ~attrs ~params ~priv name constructors + +and parse_type_definitions ~current_type_name_path ~inline_types_context ~attrs + ~name ~params ~start_pos p = + let type_def = + let manifest, priv, kind = + parse_type_equation_and_representation ~current_type_name_path + ~inline_types_context p + in + let cstrs = parse_type_constraints p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest + {name with txt = lident_of_path name.Location.txt} + in + let rec loop p defs = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes_and_binding p in + match p.Parser.token with + | And -> + Parser.next p; + let type_def = parse_type_def ~attrs ~start_pos p in + loop p (type_def :: defs) + | _ -> List.rev defs + in + loop p [type_def] + +(* TODO: decide if we really want type extensions (eg. type x += Blue) + * It adds quite a bit of complexity that can be avoided, + * implemented for now. Needed to get a feel for the complexities of + * this territory of the grammar *) +and parse_type_definition_or_extension ~attrs p = + let start_pos = p.Parser.start_pos in + Parser.expect Token.Typ p; + let rec_flag = + match p.token with + | Rec -> + Parser.next p; + Asttypes.Recursive + | Lident "nonrec" -> + Parser.next p; + Asttypes.Nonrecursive + | _ -> Asttypes.Nonrecursive + in + let name = parse_value_path p in + let params = parse_type_params ~parent:name p in + match p.Parser.token with + | PlusEqual -> TypeExt (parse_type_extension ~params ~attrs ~name p) + | _ -> + (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) + let () = + match name.Location.txt with + | Lident _ -> () + | longident -> + Parser.err ~start_pos:name.loc.loc_start ~end_pos:name.loc.loc_end p + (longident |> ErrorMessages.type_declaration_name_longident + |> Diagnostics.message) + in + let current_type_name_path = Longident.flatten name.txt in + let inline_types_context = {found_inline_types = []; params} in + let type_defs = + parse_type_definitions ~inline_types_context ~current_type_name_path + ~attrs ~name ~params ~start_pos p + in + let rec_flag = + if List.length inline_types_context.found_inline_types > 0 then + Asttypes.Recursive + else rec_flag + in + let inline_types = + inline_types_context.found_inline_types + |> List.map (fun (inline_type_name, loc, kind) -> + Ast_helper.Type.mk ~params + ~attrs:[(Location.mknoloc "res.inlineRecordDefinition", PStr [])] + ~loc ~kind + {name with txt = inline_type_name}) + in + TypeDef {rec_flag; types = inline_types @ type_defs} + +(* external value-name : typexp = external-declaration *) +and parse_external_def ~attrs ~start_pos p = + let in_external = !InExternal.status in + InExternal.status := true; + Parser.leave_breadcrumb p Grammar.External; + Parser.expect Token.External p; + let name, loc = parse_lident p in + let name = Location.mkloc name loc in + Parser.expect ~grammar:Grammar.TypeExpression Colon p; + let typ_expr = parse_typ_expr p in + let equal_start = p.start_pos in + let equal_end = p.end_pos in + Parser.expect Equal p; + let prim = + match p.token with + | String s -> + Parser.next p; + [s] + | _ -> + Parser.err ~start_pos:equal_start ~end_pos:equal_end p + (Diagnostics.message + ("An external requires the name of the JS value you're referring \ + to, like \"" ^ name.txt ^ "\".")); + [] + in + let loc = mk_loc start_pos p.prev_end_pos in + let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typ_expr in + Parser.eat_breadcrumb p; + InExternal.status := in_external; + vb + +(* constr-def ::= + * | constr-decl + * | constr-name = constr + * + * constr-decl ::= constr-name constr-args + * constr-name ::= uident + * constr ::= path-uident *) +and parse_constr_def ~parse_attrs p = + let attrs = if parse_attrs then parse_attributes p else [] in + let name = + match p.Parser.token with + | Uident name -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Location.mkloc name loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let kind = + match p.Parser.token with + | Lparen -> + let args, res = parse_constr_decl_args p in + Parsetree.Pext_decl (args, res) + | Equal -> + Parser.next p; + let longident = parse_module_long_ident ~lowercase:false p in + Parsetree.Pext_rebind longident + | Colon -> + Parser.next p; + let typ = parse_typ_expr p in + Parsetree.Pext_decl (Pcstr_tuple [], Some typ) + | _ -> Parsetree.Pext_decl (Pcstr_tuple [], None) + in + (attrs, name, kind) + +(* + * exception-definition ::= + * | exception constr-decl + * ∣ exception constr-name = constr + * + * constr-name ::= uident + * constr ::= long_uident *) +and parse_exception_def ~attrs p = + let start_pos = p.Parser.start_pos in + Parser.expect Token.Exception p; + let _, name, kind = parse_constr_def ~parse_attrs:false p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Te.constructor ~loc ~attrs name kind + +and parse_newline_or_semicolon_structure p = + match p.Parser.token with + | Semicolon -> Parser.next p + | token when Grammar.is_structure_item_start token -> + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then () + else + Parser.err ~start_pos:p.prev_end_pos ~end_pos:p.end_pos p + (Diagnostics.message + "consecutive statements on a line must be separated by ';' or a \ + newline") + | _ -> () + +and parse_structure_item_region p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in + match p.Parser.token with + | Open -> + let open_description = parse_open_description ~attrs p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.open_ ~loc open_description) + | Let {unwrap} -> + let rec_flag, let_bindings = + parse_let_bindings ~unwrap ~attrs ~start_pos p + in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.value ~loc rec_flag let_bindings) + | Typ -> ( + Parser.begin_region p; + match parse_type_definition_or_extension ~attrs p with + | TypeDef {rec_flag; types} -> + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Str.type_ ~loc rec_flag types) + | TypeExt ext -> + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Str.type_extension ~loc ext)) + | External -> + let external_def = parse_external_def ~attrs ~start_pos p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.primitive ~loc external_def) + | Exception -> + let exception_def = parse_exception_def ~attrs p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.exception_ ~loc exception_def) + | Include -> + let include_statement = parse_include_statement ~attrs p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.include_ ~loc include_statement) + | Module -> + Parser.begin_region p; + let structure_item = + parse_module_or_module_type_impl_or_pack_expr ~attrs p + in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some {structure_item with pstr_loc = loc} + | ModuleComment (loc, s) -> + Parser.next p; + Some + (Ast_helper.Str.attribute ~loc + ( {txt = "res.doc"; loc}, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) + | AtAt -> + let attr = parse_standalone_attribute p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.attribute ~loc attr) + | PercentPercent -> + let extension = parse_extension ~module_language:true p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Str.extension ~attrs ~loc extension) + | token when Grammar.is_expr_start token -> + let prev_end_pos = p.Parser.end_pos in + let exp = parse_expr p in + parse_newline_or_semicolon_structure p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.check_progress ~prev_end_pos + ~result:(Ast_helper.Str.eval ~loc ~attrs exp) + p + | _ -> ( + match attrs with + | (({Asttypes.loc = attr_loc}, _) as attr) :: _ -> + Parser.err ~start_pos:attr_loc.loc_start ~end_pos:attr_loc.loc_end p + (Diagnostics.message (ErrorMessages.attribute_without_node attr)); + let expr = parse_expr p in + Some + (Ast_helper.Str.eval + ~loc:(mk_loc p.start_pos p.prev_end_pos) + ~attrs expr) + | _ -> None) +[@@progress Parser.next, Parser.expect] + +(* include-statement ::= include module-expr *) +and parse_include_statement ~attrs p = + let start_pos = p.Parser.start_pos in + Parser.expect Token.Include p; + let mod_expr = parse_module_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Incl.mk ~loc ~attrs mod_expr + +and parse_atomic_module_expr p = + let start_pos = p.Parser.start_pos in + match p.Parser.token with + | Uident _ident -> + let longident = parse_module_long_ident ~lowercase:false p in + Ast_helper.Mod.ident ~loc:longident.loc longident + | Lbrace -> + Parser.next p; + let structure = + Ast_helper.Mod.structure + (parse_delimited_region ~grammar:Grammar.Structure ~closing:Rbrace + ~f:parse_structure_item_region p) + in + Parser.expect Rbrace p; + let end_pos = p.prev_end_pos in + {structure with pmod_loc = mk_loc start_pos end_pos} + | Lparen -> + Parser.next p; + let mod_expr = + match p.token with + | Rparen -> + Ast_helper.Mod.structure ~loc:(mk_loc start_pos p.prev_end_pos) [] + | _ -> parse_constrained_mod_expr p + in + Parser.expect Rparen p; + mod_expr + | Lident "unpack" -> ( + (* TODO: should this be made a keyword?? *) + Parser.next p; + Parser.expect Lparen p; + let expr = parse_expr p in + match p.Parser.token with + | Colon -> + let colon_start = p.Parser.start_pos in + Parser.next p; + let attrs = parse_attributes p in + let package_type = parse_package_type ~start_pos:colon_start ~attrs p in + Parser.expect Rparen p; + let loc = mk_loc start_pos p.prev_end_pos in + let constraint_expr = Ast_helper.Exp.constraint_ ~loc expr package_type in + Ast_helper.Mod.unpack ~loc constraint_expr + | _ -> + Parser.expect Rparen p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Mod.unpack ~loc expr) + | Percent -> + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Mod.extension ~loc extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.default_module_expr () + +and parse_primary_mod_expr p = + let start_pos = p.Parser.start_pos in + let mod_expr = parse_atomic_module_expr p in + let rec loop p mod_expr = + match p.Parser.token with + | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + loop p (parse_module_application p mod_expr) + | _ -> mod_expr + in + let mod_expr = loop p mod_expr in + {mod_expr with pmod_loc = mk_loc start_pos p.prev_end_pos} + +(* + * functor-arg ::= + * | uident : modtype + * | _ : modtype + * | modtype --> "punning" for _ : modtype + * | attributes functor-arg + *) +and parse_functor_arg p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in + match p.Parser.token with + | Uident ident -> ( + Parser.next p; + let uident_end_pos = p.prev_end_pos in + match p.Parser.token with + | Colon -> + Parser.next p; + let module_type = parse_module_type p in + let loc = mk_loc start_pos uident_end_pos in + let arg_name = Location.mkloc ident loc in + Some (attrs, arg_name, Some module_type, start_pos) + | Dot -> + Parser.next p; + let module_type = + let module_long_ident = + parse_module_long_ident_tail ~lowercase:false p start_pos + (Longident.Lident ident) + in + Ast_helper.Mty.ident ~loc:module_long_ident.loc module_long_ident + in + let arg_name = Location.mknoloc "_" in + Some (attrs, arg_name, Some module_type, start_pos) + | _ -> + let loc = mk_loc start_pos uident_end_pos in + let mod_ident = Location.mkloc (Longident.Lident ident) loc in + let module_type = Ast_helper.Mty.ident ~loc mod_ident in + let arg_name = Location.mknoloc "_" in + Some (attrs, arg_name, Some module_type, start_pos)) + | Underscore -> + Parser.next p; + let arg_name = Location.mkloc "_" (mk_loc start_pos p.prev_end_pos) in + Parser.expect Colon p; + let module_type = parse_module_type p in + Some (attrs, arg_name, Some module_type, start_pos) + | Lparen -> + Parser.next p; + Parser.expect Rparen p; + let arg_name = Location.mkloc "*" (mk_loc start_pos p.prev_end_pos) in + Some (attrs, arg_name, None, start_pos) + | _ -> None + +and parse_functor_args p = + let start_pos = p.Parser.start_pos in + Parser.expect Lparen p; + let args = + parse_comma_delimited_region ~grammar:Grammar.FunctorArgs ~closing:Rparen + ~f:parse_functor_arg p + in + Parser.expect Rparen p; + match args with + | [] -> + [ + ([], Location.mkloc "*" (mk_loc start_pos p.prev_end_pos), None, start_pos); + ] + | args -> args + +and parse_functor_module_expr p = + let start_pos = p.Parser.start_pos in + let args = parse_functor_args p in + let return_type = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parse_module_type ~es6_arrow:false p) + | _ -> None + in + Parser.expect EqualGreater p; + let rhs_module_expr = + let mod_expr = parse_module_expr p in + match return_type with + | Some mod_type -> + Ast_helper.Mod.constraint_ + ~loc: + (mk_loc mod_expr.pmod_loc.loc_start + mod_type.Parsetree.pmty_loc.loc_end) + mod_expr mod_type + | None -> mod_expr + in + let end_pos = p.prev_end_pos in + let mod_expr = + List.fold_right + (fun (attrs, name, module_type, start_pos) acc -> + Ast_helper.Mod.functor_ ~loc:(mk_loc start_pos end_pos) ~attrs name + module_type acc) + args rhs_module_expr + in + {mod_expr with pmod_loc = mk_loc start_pos end_pos} + +(* module-expr ::= + * | module-path + * ∣ { structure-items } + * ∣ functorArgs => module-expr + * ∣ module-expr(module-expr) + * ∣ ( module-expr ) + * ∣ ( module-expr : module-type ) + * | extension + * | attributes module-expr *) +and parse_module_expr p = + let has_await, loc_await = + let start_pos = p.start_pos in + match p.Parser.token with + | Await -> + Parser.expect Await p; + let end_pos = p.end_pos in + (true, mk_loc start_pos end_pos) + | _ -> (false, mk_loc start_pos start_pos) + in + let attrs = parse_attributes p in + let attrs = if has_await then make_await_attr loc_await :: attrs else attrs in + let mod_expr = + if is_es6_arrow_functor p then parse_functor_module_expr p + else parse_primary_mod_expr p + in + { + mod_expr with + pmod_attributes = List.concat [mod_expr.pmod_attributes; attrs]; + } + +and parse_constrained_mod_expr p = + let mod_expr = parse_module_expr p in + match p.Parser.token with + | Colon -> + Parser.next p; + let mod_type = parse_module_type p in + let loc = mk_loc mod_expr.pmod_loc.loc_start mod_type.pmty_loc.loc_end in + Ast_helper.Mod.constraint_ ~loc mod_expr mod_type + | _ -> mod_expr + +and parse_constrained_mod_expr_region p = + if Grammar.is_mod_expr_start p.Parser.token then + Some (parse_constrained_mod_expr p) + else None + +and parse_module_application p mod_expr = + let start_pos = p.Parser.start_pos in + Parser.expect Lparen p; + let args = + parse_comma_delimited_region ~grammar:Grammar.ModExprList ~closing:Rparen + ~f:parse_constrained_mod_expr_region p + in + Parser.expect Rparen p; + let args = + match args with + | [] -> + let loc = mk_loc start_pos p.prev_end_pos in + [Ast_helper.Mod.structure ~loc []] + | args -> args + in + List.fold_left + (fun mod_expr arg -> + Ast_helper.Mod.apply + ~loc: + (mk_loc mod_expr.Parsetree.pmod_loc.loc_start + arg.Parsetree.pmod_loc.loc_end) + mod_expr arg) + mod_expr args + +and parse_module_or_module_type_impl_or_pack_expr ~attrs p = + let start_pos = p.Parser.start_pos in + Parser.expect Module p; + match p.Parser.token with + | Typ -> parse_module_type_impl ~attrs start_pos p + | Lparen -> + let expr = parse_first_class_module_expr ~start_pos p in + let a = parse_primary_expr ~operand:expr p in + let expr = parse_binary_expr ~a p 1 in + let expr = parse_ternary_expr expr p in + Ast_helper.Str.eval ~attrs expr + | _ -> parse_maybe_rec_module_binding ~attrs ~start_pos p + +and parse_module_type_impl ~attrs start_pos p = + Parser.expect Typ p; + let name_start = p.Parser.start_pos in + let name = + match p.Parser.token with + | Lident ident -> + Parser.next p; + let loc = mk_loc name_start p.prev_end_pos in + Location.mkloc ident loc + | Uident ident -> + Parser.next p; + let loc = mk_loc name_start p.prev_end_pos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + Parser.expect Equal p; + let module_type = parse_module_type p in + let module_type_declaration = + Ast_helper.Mtd.mk ~attrs + ~loc:(mk_loc name_start p.prev_end_pos) + ~typ:module_type name + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Str.modtype ~loc module_type_declaration + +(* definition ::= + ∣ module rec module-name : module-type = module-expr { and module-name + : module-type = module-expr } *) +and parse_maybe_rec_module_binding ~attrs ~start_pos p = + match p.Parser.token with + | Token.Rec -> + Parser.next p; + Ast_helper.Str.rec_module (parse_module_bindings ~start_pos ~attrs p) + | _ -> + Ast_helper.Str.module_ + (parse_module_binding ~attrs ~start_pos:p.Parser.start_pos p) + +and parse_module_binding ~attrs ~start_pos p = + let name = + match p.Parser.token with + | Uident ident -> + let start_pos = p.Parser.start_pos in + Parser.next p; + let loc = mk_loc start_pos p.prev_end_pos in + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = parse_module_binding_body p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Mb.mk ~attrs ~loc name body + +and parse_module_binding_body p = + (* TODO: make required with good error message when rec module binding *) + let return_mod_type = + match p.Parser.token with + | Colon -> + Parser.next p; + Some (parse_module_type p) + | _ -> None + in + Parser.expect Equal p; + let mod_expr = parse_module_expr p in + match return_mod_type with + | Some mod_type -> + Ast_helper.Mod.constraint_ + ~loc:(mk_loc mod_type.pmty_loc.loc_start mod_expr.pmod_loc.loc_end) + mod_expr mod_type + | None -> mod_expr + +(* module-name : module-type = module-expr + * { and module-name : module-type = module-expr } *) +and parse_module_bindings ~attrs ~start_pos p = + let rec loop p acc = + let start_pos = p.Parser.start_pos in + let doc_attr : Parsetree.attributes = + match p.Parser.token with + | DocComment (loc, s) -> + Parser.next p; + [doc_comment_to_attribute loc s] + | _ -> [] + in + let attrs = doc_attr @ parse_attributes_and_binding p in + match p.Parser.token with + | And -> + Parser.next p; + ignore (Parser.optional p Module); + (* over-parse for fault-tolerance *) + let mod_binding = parse_module_binding ~attrs ~start_pos p in + loop p (mod_binding :: acc) + | _ -> List.rev acc + in + let first = parse_module_binding ~attrs ~start_pos p in + loop p [first] + +and parse_atomic_module_type p = + let start_pos = p.Parser.start_pos in + let module_type = + match p.Parser.token with + | Uident _ | Lident _ -> + (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } + * lets go with uppercase terminal for now *) + let module_long_ident = parse_module_long_ident ~lowercase:true p in + Ast_helper.Mty.ident ~loc:module_long_ident.loc module_long_ident + | Lparen -> + Parser.next p; + let mty = parse_module_type p in + Parser.expect Rparen p; + {mty with pmty_loc = mk_loc start_pos p.prev_end_pos} + | Lbrace -> + Parser.next p; + let spec = + parse_delimited_region ~grammar:Grammar.Signature ~closing:Rbrace + ~f:parse_signature_item_region p + in + Parser.expect Rbrace p; + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Mty.signature ~loc spec + | Module -> + (* TODO: check if this is still atomic when implementing first class modules*) + parse_module_type_of p + | Percent -> + let extension = parse_extension p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Mty.extension ~loc extension + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.default_module_type () + in + let module_type_loc = mk_loc start_pos p.prev_end_pos in + {module_type with pmty_loc = module_type_loc} + +and parse_functor_module_type p = + let start_pos = p.Parser.start_pos in + let args = parse_functor_args p in + Parser.expect EqualGreater p; + let rhs = parse_module_type p in + let end_pos = p.prev_end_pos in + let mod_type = + List.fold_right + (fun (attrs, name, module_type, start_pos) acc -> + Ast_helper.Mty.functor_ ~loc:(mk_loc start_pos end_pos) ~attrs name + module_type acc) + args rhs + in + {mod_type with pmty_loc = mk_loc start_pos end_pos} + +(* Module types are the module-level equivalent of type expressions: they + * specify the general shape and type properties of modules. + * + * module-type ::= + * | modtype-path + * | { signature } + * | ( module-type ) --> parenthesized module-type + * | functor-args => module-type --> functor + * | module-type => module-type --> functor + * | module type of module-expr + * | attributes module-type + * | module-type with-mod-constraints + * | extension + *) +and parse_module_type ?(es6_arrow = true) ?(with_ = true) p = + let attrs = parse_attributes p in + let modty = + if es6_arrow && is_es6_arrow_functor p then parse_functor_module_type p + else + let modty = parse_atomic_module_type p in + match p.Parser.token with + | EqualGreater when es6_arrow == true -> + Parser.next p; + let rhs = parse_module_type ~with_:false p in + let str = Location.mknoloc "_" in + let loc = mk_loc modty.pmty_loc.loc_start p.prev_end_pos in + Ast_helper.Mty.functor_ ~loc str (Some modty) rhs + | _ -> modty + in + let module_type = + {modty with pmty_attributes = List.concat [modty.pmty_attributes; attrs]} + in + if with_ then parse_with_constraints module_type p else module_type + +and parse_with_constraints module_type p = + match p.Parser.token with + | Lident "with" -> + Parser.next p; + let first = parse_with_constraint p in + let rec loop p acc = + match p.Parser.token with + | And -> + Parser.next p; + loop p (parse_with_constraint p :: acc) + | _ -> List.rev acc + in + let constraints = loop p [first] in + let loc = mk_loc module_type.pmty_loc.loc_start p.prev_end_pos in + Ast_helper.Mty.with_ ~loc module_type constraints + | _ -> module_type + +(* mod-constraint ::= + * | type typeconstr type-equation type-constraints? + * ∣ type typeconstr-name := typexpr + * ∣ module module-path = extended-module-path + * ∣ module module-path := extended-module-path + * + * TODO: split this up into multiple functions, better errors *) +and parse_with_constraint p = + match p.Parser.token with + | Module -> ( + Parser.next p; + let module_path = parse_module_long_ident ~lowercase:false p in + match p.Parser.token with + | ColonEqual -> + Parser.next p; + let lident = parse_module_long_ident ~lowercase:false p in + Parsetree.Pwith_modsubst (module_path, lident) + | Equal -> + Parser.next p; + let lident = parse_module_long_ident ~lowercase:false p in + Parsetree.Pwith_module (module_path, lident) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let lident = parse_module_long_ident ~lowercase:false p in + Parsetree.Pwith_modsubst (module_path, lident)) + | Typ -> ( + Parser.next p; + let type_constr = parse_value_path p in + let params = parse_type_params ~parent:type_constr p in + match p.Parser.token with + | ColonEqual -> + Parser.next p; + let typ_expr = parse_typ_expr p in + Parsetree.Pwith_typesubst + ( type_constr, + Ast_helper.Type.mk ~loc:type_constr.loc ~params ~manifest:typ_expr + (Location.mkloc (Longident.last type_constr.txt) type_constr.loc) ) + | Equal -> + Parser.next p; + let private_flag = + if Parser.optional p Token.Private then Asttypes.Private + else Asttypes.Public + in + let typ_expr = parse_typ_expr p in + let type_constraints = parse_type_constraints p in + Parsetree.Pwith_type + ( type_constr, + Ast_helper.Type.mk ~loc:type_constr.loc ~priv:private_flag ~params + ~manifest:typ_expr ~cstrs:type_constraints + (Location.mkloc (Longident.last type_constr.txt) type_constr.loc) ) + | token -> + (* TODO: revisit *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + let typ_expr = parse_typ_expr p in + let type_constraints = parse_type_constraints p in + Parsetree.Pwith_type + ( type_constr, + Ast_helper.Type.mk ~loc:type_constr.loc ~params ~manifest:typ_expr + ~cstrs:type_constraints + (Location.mkloc (Longident.last type_constr.txt) type_constr.loc) )) + | token -> + (* TODO: implement recovery strategy *) + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Parsetree.Pwith_type + ( Location.mknoloc (Longident.Lident ""), + Ast_helper.Type.mk ~params:[] ~manifest:(Recover.default_type ()) + ~cstrs:[] (Location.mknoloc "") ) + +and parse_module_type_of p = + let start_pos = p.Parser.start_pos in + Parser.expect Module p; + Parser.expect Typ p; + Parser.expect Of p; + let module_expr = parse_module_expr p in + Ast_helper.Mty.typeof_ ~loc:(mk_loc start_pos p.prev_end_pos) module_expr + +and parse_newline_or_semicolon_signature p = + match p.Parser.token with + | Semicolon -> Parser.next p + | token when Grammar.is_signature_item_start token -> + if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then () + else + Parser.err ~start_pos:p.prev_end_pos ~end_pos:p.end_pos p + (Diagnostics.message + "consecutive specifications on a line must be separated by ';' or a \ + newline") + | _ -> () + +and parse_signature_item_region p = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes p in + match p.Parser.token with + | Let {unwrap} -> + if unwrap then ( + Parser.err ~start_pos ~end_pos:p.Parser.end_pos p + (Diagnostics.message ErrorMessages.experimental_let_unwrap_sig); + Parser.next p); + Parser.begin_region p; + let value_desc = parse_sign_let_desc ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.value ~loc value_desc) + | Typ -> ( + Parser.begin_region p; + match parse_type_definition_or_extension ~attrs p with + | TypeDef {rec_flag; types} -> + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.type_ ~loc rec_flag types) + | TypeExt ext -> + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.type_extension ~loc ext)) + | External -> + let external_def = parse_external_def ~attrs ~start_pos p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.value ~loc external_def) + | Exception -> + let exception_def = parse_exception_def ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.exception_ ~loc exception_def) + | Open -> + let open_description = parse_open_description ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.open_ ~loc open_description) + | Include -> + Parser.next p; + let module_type = parse_module_type p in + let include_description = + Ast_helper.Incl.mk + ~loc:(mk_loc start_pos p.prev_end_pos) + ~attrs module_type + in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.include_ ~loc include_description) + | Module -> ( + Parser.begin_region p; + Parser.next p; + match p.Parser.token with + | Uident _ -> + let mod_decl = parse_module_declaration_or_alias ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.module_ ~loc mod_decl) + | Rec -> + let rec_module = parse_rec_module_spec ~attrs ~start_pos p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.rec_module ~loc rec_module) + | Typ -> + let mod_type_decl = parse_module_type_declaration ~attrs ~start_pos p in + Parser.end_region p; + Some mod_type_decl + | _t -> + let mod_decl = parse_module_declaration_or_alias ~attrs p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Parser.end_region p; + Some (Ast_helper.Sig.module_ ~loc mod_decl)) + | AtAt -> + let attr = parse_standalone_attribute p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.attribute ~loc attr) + | ModuleComment (loc, s) -> + Parser.next p; + Some + (Ast_helper.Sig.attribute ~loc + ( {txt = "res.doc"; loc}, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] )) + | PercentPercent -> + let extension = parse_extension ~module_language:true p in + parse_newline_or_semicolon_signature p; + let loc = mk_loc start_pos p.prev_end_pos in + Some (Ast_helper.Sig.extension ~attrs ~loc extension) + | _ -> ( + match attrs with + | (({Asttypes.loc = attr_loc}, _) as attr) :: _ -> + Parser.err ~start_pos:attr_loc.loc_start ~end_pos:attr_loc.loc_end p + (Diagnostics.message (ErrorMessages.attribute_without_node attr)); + Some Recover.default_signature_item + | _ -> None) +[@@progress Parser.next, Parser.expect] + +(* module rec module-name : module-type { and module-name: module-type } *) +and parse_rec_module_spec ~attrs ~start_pos p = + Parser.expect Rec p; + let rec loop p spec = + let start_pos = p.Parser.start_pos in + let attrs = parse_attributes_and_binding p in + match p.Parser.token with + | And -> + (* TODO: give a good error message when with constraint, no parens + * and ASet: (Set.S with type elt = A.t) + * and BTree: (Btree.S with type elt = A.t) + * Without parens, the `and` signals the start of another + * `with-constraint` + *) + Parser.expect And p; + let decl = parse_rec_module_declaration ~attrs ~start_pos p in + loop p (decl :: spec) + | _ -> List.rev spec + in + let first = parse_rec_module_declaration ~attrs ~start_pos p in + loop p [first] + +(* module-name : module-type *) +and parse_rec_module_declaration ~attrs ~start_pos p = + let name = + match p.Parser.token with + | Uident mod_name -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Location.mkloc mod_name loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + Parser.expect Colon p; + let mod_type = parse_module_type p in + Ast_helper.Md.mk ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs name mod_type + +and parse_module_declaration_or_alias ~attrs p = + let start_pos = p.Parser.start_pos in + let module_name = + match p.Parser.token with + | Uident ident -> + let loc = mk_loc p.Parser.start_pos p.end_pos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let body = + match p.Parser.token with + | Colon -> + Parser.next p; + parse_module_type p + | Equal -> ( + Parser.next p; + match p.Parser.token with + | Lbrace -> + (* Parse `module M = {` as `module M : {` *) + parse_module_type p + | _ -> + let lident = parse_module_long_ident ~lowercase:false p in + Ast_helper.Mty.alias lident) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + Recover.default_module_type () + in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Md.mk ~loc ~attrs module_name body + +and parse_module_type_declaration ~attrs ~start_pos p = + Parser.expect Typ p; + let module_name = + match p.Parser.token with + | Uident ident -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Location.mkloc ident loc + | Lident ident -> + let loc = mk_loc p.start_pos p.end_pos in + Parser.next p; + Location.mkloc ident loc + | t -> + Parser.err p (Diagnostics.uident t); + Location.mknoloc "_" + in + let typ = + match p.Parser.token with + | Equal -> + Parser.next p; + Some (parse_module_type p) + | _ -> None + in + let module_decl = Ast_helper.Mtd.mk ~attrs ?typ module_name in + Ast_helper.Sig.modtype ~loc:(mk_loc start_pos p.prev_end_pos) module_decl + +and parse_sign_let_desc ~attrs p = + let start_pos = p.Parser.start_pos in + Parser.optional p (Let {unwrap = false}) |> ignore; + let name, loc = parse_lident p in + let name = Location.mkloc name loc in + Parser.expect Colon p; + let typ_expr = parse_poly_type_expr p in + let loc = mk_loc start_pos p.prev_end_pos in + Ast_helper.Val.mk ~loc ~attrs name typ_expr + +(* attr-id ::= lowercase-ident + ∣ capitalized-ident + ∣ attr-id . attr-id *) +and parse_attribute_id ~start_pos p = + let rec loop p acc = + match p.Parser.token with + | Lident ident | Uident ident -> ( + Parser.next p; + let id = acc ^ ident in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) + | token when Token.is_keyword token -> ( + Parser.next p; + let id = acc ^ Token.to_string token in + match p.Parser.token with + | Dot -> + Parser.next p; + loop p (id ^ ".") + | _ -> id) + | token -> + Parser.err p (Diagnostics.unexpected token p.breadcrumbs); + acc + in + let id = loop p "" in + let end_pos = p.prev_end_pos in + Location.mkloc id (mk_loc start_pos end_pos) + +(* + * payload ::= empty + * | ( structure-item ) + * + * TODO: what about multiple structure items? + * @attr({let x = 1; let x = 2}) + * + * Also what about type-expressions and specifications? + * @attr(:myType) ??? + *) +and parse_payload p = + match p.Parser.token with + | Lparen when p.start_pos.pos_cnum = p.prev_end_pos.pos_cnum -> ( + Parser.leave_breadcrumb p Grammar.AttributePayload; + Parser.next p; + match p.token with + | Colon -> + Parser.next p; + let payload = + if Grammar.is_signature_item_start p.token then + Parsetree.PSig + (parse_delimited_region ~grammar:Grammar.Signature ~closing:Rparen + ~f:parse_signature_item_region p) + else Parsetree.PTyp (parse_typ_expr p) + in + Parser.expect Rparen p; + Parser.eat_breadcrumb p; + payload + | Question -> + Parser.next p; + let pattern = parse_pattern p in + let expr = + match p.token with + | When | If -> + Parser.next p; + Some (parse_expr p) + | _ -> None + in + Parser.expect Rparen p; + Parser.eat_breadcrumb p; + Parsetree.PPat (pattern, expr) + | _ -> + let items = + parse_delimited_region ~grammar:Grammar.Structure ~closing:Rparen + ~f:parse_structure_item_region p + in + Parser.expect Rparen p; + Parser.eat_breadcrumb p; + Parsetree.PStr items) + | _ -> Parsetree.PStr [] + +(* type attribute = string loc * payload *) +and parse_attribute p = + match p.Parser.token with + | At -> + let start_pos = p.start_pos in + Parser.next p; + let attr_id = parse_attribute_id ~start_pos p in + let payload = parse_payload p in + Some (attr_id, payload) + | DocComment (loc, s) -> + Parser.next p; + Some (doc_comment_to_attribute loc s) + | _ -> None + +and doc_comment_to_attribute loc s : Parsetree.attribute = + ( {txt = "res.doc"; loc}, + PStr + [ + Ast_helper.Str.eval ~loc + (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); + ] ) + +and parse_attributes p = + parse_region p ~grammar:Grammar.Attribute ~f:parse_attribute + +(* + * standalone-attribute ::= + * | @@ atribute-id + * | @@ attribute-id ( structure-item ) + *) +and parse_standalone_attribute p = + let start_pos = p.start_pos in + Parser.expect AtAt p; + let attr_id = parse_attribute_id ~start_pos p in + let payload = parse_payload p in + (attr_id, payload) + +(* extension ::= % attr-id attr-payload + * | %% attr-id( + * expr ::= ... + * ∣ extension + * + * typexpr ::= ... + * ∣ extension + * + * pattern ::= ... + * ∣ extension + * + * module-expr ::= ... + * ∣ extension + * + * module-type ::= ... + * ∣ extension + * + * class-expr ::= ... + * ∣ extension + * + * class-type ::= ... + * ∣ extension + * + * + * item extension nodes usable in structures and signature + * + * item-extension ::= %% attr-id + * | %% attr-id(structure-item) + * + * attr-payload ::= structure-item + * + * ~moduleLanguage represents whether we're on the module level or not + *) +and parse_extension ?(module_language = false) p = + let start_pos = p.Parser.start_pos in + if module_language then Parser.expect PercentPercent p + else Parser.expect Percent p; + let attr_id = parse_attribute_id ~start_pos p in + let payload = parse_payload p in + (attr_id, payload) + +(* module signature on the file level *) +let parse_specification p : Parsetree.signature = + parse_region p ~grammar:Grammar.Specification ~f:parse_signature_item_region + +(* module structure on the file level *) +let parse_implementation p : Parsetree.structure = + parse_region p ~grammar:Grammar.Implementation ~f:parse_structure_item_region diff --git a/compiler/syntax/src/res_core.mli b/compiler/syntax/src/res_core.mli new file mode 100644 index 0000000..30d1e5f --- /dev/null +++ b/compiler/syntax/src/res_core.mli @@ -0,0 +1,2 @@ +val parse_implementation : Res_parser.t -> Parsetree.structure +val parse_specification : Res_parser.t -> Parsetree.signature diff --git a/compiler/syntax/src/res_diagnostics.ml b/compiler/syntax/src/res_diagnostics.ml new file mode 100644 index 0000000..76c39a3 --- /dev/null +++ b/compiler/syntax/src/res_diagnostics.ml @@ -0,0 +1,199 @@ +module Grammar = Res_grammar +module Token = Res_token + +type category = + | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} + | Expected of { + context: Grammar.t option; + pos: Lexing.position; (* prev token end*) + token: Token.t; + } + | Message of string + | Uident of Token.t + | Lident of Token.t + | UnclosedString + | UnclosedTemplate + | UnclosedComment + | UnknownUchar of Char.t + +type t = { + start_pos: Lexing.position; + end_pos: Lexing.position; + category: category; +} + +type report = t list + +let get_start_pos t = t.start_pos +let get_end_pos t = t.end_pos + +let default_unexpected token = + "I'm not sure what to parse here when looking at \"" ^ Token.to_string token + ^ "\"." + +let reserved_keyword token = + let token_txt = Token.to_string token in + "`" ^ token_txt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ token_txt ^ "\"" + +let explain t = + match t.category with + | Uident current_token -> ( + match current_token with + | Lident lident -> + let guess = String.capitalize_ascii lident in + "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" + | t when Token.is_keyword t -> + let token = Token.to_string t in + "`" ^ token ^ "` is a reserved keyword." + | _ -> + "At this point, I'm looking for an uppercased name like `Belt` or `Array`" + ) + | Lident current_token -> ( + match current_token with + | Uident uident -> + let guess = String.uncapitalize_ascii uident in + "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" + | t when Token.is_keyword t -> + let token = Token.to_string t in + "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ token ^ "\"" + | Underscore -> "`_` isn't a valid name." + | _ -> "I'm expecting a lowercase name like `user or `age`") + | Message txt -> txt + | UnclosedString -> "This string is missing a double quote at the end" + | UnclosedTemplate -> + "Did you forget to close this template expression with a backtick?" + | UnclosedComment -> "This comment seems to be missing a closing `*/`" + | UnknownUchar uchar -> + "Not sure what to do with this character: \"" ^ Char.escaped uchar ^ "\"." + | Expected {context; token = t} -> + let hint = + match context with + | Some grammar -> " It signals the start of " ^ Grammar.to_string grammar + | None -> "" + in + "Did you forget a `" ^ Token.to_string t ^ "` here?" ^ hint + | Unexpected {token = t; context = breadcrumbs} -> ( + let name = Token.to_string t in + match breadcrumbs with + | (AtomicTypExpr, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, + (String _ | At | Rbrace | Comma | Eof) ) -> + "I'm missing a type here" + | _, t when Grammar.is_structure_item_start t || t = Eof -> + "Missing a type here" + | _ -> default_unexpected t) + | (ExprOperand, _) :: breadcrumbs -> ( + match (breadcrumbs, t) with + | (ExprBlock, _) :: _, Rbrace -> + "It seems that this expression block is empty" + | (ExprBlock, _) :: _, Bar -> + (* Pattern matching *) + "Looks like there might be an expression missing here" + | (ExprSetField, _) :: _, _ -> + "It seems that this record field mutation misses an expression" + | (ExprArrayMutation, _) :: _, _ -> + "Seems that an expression is missing, with what do I mutate the array?" + | ((ExprBinaryAfterOp _ | ExprUnary), _) :: _, _ -> + "Did you forget to write an expression here?" + | (Grammar.LetBinding, _) :: _, _ -> + "This let-binding misses an expression" + | _ :: _, (Rbracket | Rbrace | Eof) -> "Missing expression" + | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + ) + | (TypeParam, _) :: _ -> ( + match t with + | Lident ident -> + "Did you mean '" ^ ident ^ "? A Type parameter starts with a quote." + | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." + ) + | (Pattern, _) :: breadcrumbs -> ( + match (t, breadcrumbs) with + | Equal, (LetBinding, _) :: _ -> + "I was expecting a name for this let-binding. Example: `let message = \ + \"hello\"`" + | In, (ExprFor, _) :: _ -> + "A for-loop has the following form: `for i in 0 to 10`. Did you forget \ + to supply a name before `in`?" + | EqualGreater, (PatternMatchCase, _) :: _ -> + "I was expecting a pattern to match on before the `=>`" + | token, _ when Token.is_keyword t -> reserved_keyword token + | token, _ -> default_unexpected token) + | _ -> + (* TODO: match on circumstance to verify Lident needed ? *) + if Token.is_keyword t then + "`" ^ name + ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" + ^ Token.to_string t ^ "\"" + else "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") + +let make ~start_pos ~end_pos category = {start_pos; end_pos; category} + +let print_report ?(custom_intro = None) ?(formatter = Format.err_formatter) + diagnostics src = + let rec print diagnostics src = + match diagnostics with + | [] -> () + | d :: rest -> + (* A few specializations for best-effort error messages for old syntax etc. *) + let msg = + match d.category with + | Unexpected {token = Token.Bar; _} -> + let idx_prev = d.start_pos.pos_cnum - 1 in + let idx_next = d.end_pos.pos_cnum in + if + idx_prev >= 0 + && idx_prev < String.length src + && String.get src idx_prev = '[' + then + let base = explain d in + base + ^ "\n\n\ + \ Did you mean to write an array literal? Arrays are written \ + with `[ ... ]` (not `[| ... |]`)." + ^ "\n Quick fix: replace `[|` with `[` and `|]` with `]`." + ^ "\n Example: `[|1, 2, 3|]` -> `[1, 2, 3]`" + else if + idx_next >= 0 + && idx_next < String.length src + && String.get src idx_next = '>' + then + let base = explain d in + base + ^ "\n\n\ + \ The old data-last pipe `|>` has been removed from the language.\n\ + \ Refactor to use a data-first `->` pipe instead." + else explain d + | _ -> explain d + in + Location.report_error ~custom_intro ~src:(Some src) formatter + Location. + { + loc = + {loc_start = d.start_pos; loc_end = d.end_pos; loc_ghost = false}; + msg; + sub = []; + if_highlight = ""; + }; + (match rest with + | [] -> () + | _ -> Format.fprintf formatter "@."); + print rest src + in + Format.fprintf formatter "@["; + print (List.rev diagnostics) src; + Format.fprintf formatter "@]@." + +let unexpected token context = Unexpected {token; context} + +let expected ?grammar pos token = Expected {context = grammar; pos; token} + +let uident current_token = Uident current_token +let lident current_token = Lident current_token +let unclosed_string = UnclosedString +let unclosed_comment = UnclosedComment +let unclosed_template = UnclosedTemplate +let unknown_uchar code = UnknownUchar code +let message txt = Message txt diff --git a/compiler/syntax/src/res_diagnostics.mli b/compiler/syntax/src/res_diagnostics.mli new file mode 100644 index 0000000..694788a --- /dev/null +++ b/compiler/syntax/src/res_diagnostics.mli @@ -0,0 +1,30 @@ +module Token = Res_token +module Grammar = Res_grammar + +type t +type category +type report + +val get_start_pos : t -> Lexing.position [@@live] (* for playground *) +val get_end_pos : t -> Lexing.position [@@live] (* for playground *) + +val explain : t -> string [@@live] (* for playground *) + +val unexpected : Token.t -> (Grammar.t * Lexing.position) list -> category +val expected : ?grammar:Grammar.t -> Lexing.position -> Token.t -> category +val uident : Token.t -> category +val lident : Token.t -> category +val unclosed_string : category +val unclosed_template : category +val unclosed_comment : category +val unknown_uchar : Char.t -> category +val message : string -> category + +val make : start_pos:Lexing.position -> end_pos:Lexing.position -> category -> t + +val print_report : + ?custom_intro:string option -> + ?formatter:Format.formatter -> + t list -> + string -> + unit diff --git a/compiler/syntax/src/res_doc.ml b/compiler/syntax/src/res_doc.ml new file mode 100644 index 0000000..301c052 --- /dev/null +++ b/compiler/syntax/src/res_doc.ml @@ -0,0 +1,355 @@ +module MiniBuffer = Res_minibuffer + +type mode = Break | Flat + +type line_style = + | Classic (* fits? -> replace with space *) + | Soft (* fits? -> replaced with nothing *) + | Hard + (* always included, forces breaks in parents *) + (* always included, forces breaks in parents, but doesn't increase indentation + use case: template literals, multiline string content *) + | Literal + +type t = + | Nil + | Text of string + | Concat of t list + | Indent of t + | IfBreaks of {yes: t; no: t; mutable broken: bool} + (* when broken is true, treat as the yes branch *) + | LineSuffix of t + | LineBreak of line_style + | Group of {mutable should_break: bool; doc: t} + | CustomLayout of t list + | BreakParent + +let nil = Nil +let line = LineBreak Classic +let hard_line = LineBreak Hard +let soft_line = LineBreak Soft +let literal_line = LineBreak Literal +let text s = Text s + +(* Optimization. We eagerly collapse and reduce whatever allocation we can *) +let rec _concat acc l = + match l with + | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest + | Nil :: rest -> _concat acc rest + | Concat l2 :: rest -> + _concat (_concat acc rest) l2 (* notice the order here *) + | x :: rest -> + let rest1 = _concat acc rest in + if rest1 == rest then l else x :: rest1 + | [] -> acc + +let concat l = Concat (_concat [] l) + +let indent d = Indent d +let if_breaks t f = IfBreaks {yes = t; no = f; broken = false} +let line_suffix d = LineSuffix d +let group d = Group {should_break = false; doc = d} +let breakable_group ~force_break d = Group {should_break = force_break; doc = d} +let custom_layout gs = CustomLayout gs +let break_parent = BreakParent + +let space = Text " " +let comma = Text "," +let dot = Text "." +let dotdot = Text ".." +let dotdotdot = Text "..." +let less_than = Text "<" +let greater_than = Text ">" +let lbrace = Text "{" +let rbrace = Text "}" +let lparen = Text "(" +let rparen = Text ")" +let lbracket = Text "[" +let rbracket = Text "]" +let question = Text "?" +let tilde = Text "~" +let equal = Text "=" +let trailing_comma = if_breaks comma nil +let double_quote = Text "\"" + +let propagate_forced_breaks doc = + let rec walk doc = + match doc with + | Text _ | Nil | LineSuffix _ -> false + | BreakParent -> true + | LineBreak (Hard | Literal) -> true + | LineBreak (Classic | Soft) -> false + | Indent children -> + let child_forces_break = walk children in + child_forces_break + | IfBreaks ({yes = true_doc; no = false_doc} as ib) -> + let false_force_break = walk false_doc in + if false_force_break then ( + let _ = walk true_doc in + ib.broken <- true; + true) + else + let force_break = walk true_doc in + force_break + | Group ({should_break = force_break; doc = children} as gr) -> + let child_forces_break = walk children in + let should_break = force_break || child_forces_break in + gr.should_break <- should_break; + should_break + | Concat children -> + List.fold_left + (fun force_break child -> + let child_forces_break = walk child in + force_break || child_forces_break) + false children + | CustomLayout children -> + (* When using CustomLayout, we don't want to propagate forced breaks + * from the children up. By definition it picks the first layout that fits + * otherwise it takes the last of the list. + * However we do want to propagate forced breaks in the sublayouts. They + * might need to be broken. We just don't propagate them any higher here *) + let _ = walk (Concat children) in + false + in + let _ = walk doc in + () + +(* See documentation in interface file *) +let rec will_break doc = + match doc with + | LineBreak (Hard | Literal) | BreakParent | Group {should_break = true} -> + true + | Group {doc} | Indent doc | CustomLayout (doc :: _) -> will_break doc + | Concat docs -> List.exists will_break docs + | IfBreaks {yes; no} -> will_break yes || will_break no + | _ -> false + +let join ~sep docs = + let rec loop acc sep docs = + match docs with + | [] -> List.rev acc + | [x] -> List.rev (x :: acc) + | x :: xs -> loop (sep :: x :: acc) sep xs + in + concat (loop [] sep docs) + +let join_with_sep docs_with_sep = + let rec loop acc docs = + match docs with + | [] -> List.rev acc + | [(x, _sep)] -> List.rev (x :: acc) + | (x, sep) :: xs -> loop (sep :: x :: acc) xs + in + concat (loop [] docs_with_sep) + +let fits w stack = + let width = ref w in + let result = ref None in + + let rec calculate indent mode doc = + match (mode, doc) with + | _ when result.contents != None -> () + | _ when width.contents < 0 -> result := Some false + | _, Nil | _, LineSuffix _ | _, BreakParent -> () + | _, Text txt -> width := width.contents - String.length txt + | _, Indent doc -> calculate (indent + 2) mode doc + | Flat, LineBreak Hard | Flat, LineBreak Literal -> result := Some true + | Flat, LineBreak Classic -> width := width.contents - 1 + | Flat, LineBreak Soft -> () + | Break, LineBreak _ -> result := Some true + | _, Group {should_break = true; doc} -> calculate indent Break doc + | _, Group {doc} -> calculate indent mode doc + | _, IfBreaks {yes = break_doc; broken = true} -> + calculate indent mode break_doc + | Break, IfBreaks {yes = break_doc} -> calculate indent mode break_doc + | Flat, IfBreaks {no = flat_doc} -> calculate indent mode flat_doc + | _, Concat docs -> calculate_concat indent mode docs + | _, CustomLayout (hd :: _) -> + (* TODO: if we have nested custom layouts, what we should do here? *) + calculate indent mode hd + | _, CustomLayout [] -> () + and calculate_concat indent mode docs = + if result.contents == None then + match docs with + | [] -> () + | doc :: rest -> + calculate indent mode doc; + calculate_concat indent mode rest + in + let rec calculate_all stack = + match (result.contents, stack) with + | Some r, _ -> r + | None, [] -> !width >= 0 + | None, (indent, mode, doc) :: rest -> + calculate indent mode doc; + calculate_all rest + in + calculate_all stack + +let to_string ~width doc = + propagate_forced_breaks doc; + let buffer = MiniBuffer.create 1000 in + + let rec process ~pos line_suffices stack = + match stack with + | ((ind, mode, doc) as cmd) :: rest -> ( + match doc with + | Nil | BreakParent -> process ~pos line_suffices rest + | Text txt -> + MiniBuffer.add_string buffer txt; + process ~pos:(String.length txt + pos) line_suffices rest + | LineSuffix doc -> process ~pos ((ind, mode, doc) :: line_suffices) rest + | Concat docs -> + let ops = List.map (fun doc -> (ind, mode, doc)) docs in + process ~pos line_suffices (List.append ops rest) + | Indent doc -> process ~pos line_suffices ((ind + 2, mode, doc) :: rest) + | IfBreaks {yes = break_doc; broken = true} -> + process ~pos line_suffices ((ind, mode, break_doc) :: rest) + | IfBreaks {yes = break_doc; no = flat_doc} -> + if mode = Break then + process ~pos line_suffices ((ind, mode, break_doc) :: rest) + else process ~pos line_suffices ((ind, mode, flat_doc) :: rest) + | LineBreak line_style -> + if mode = Break then + match line_suffices with + | [] -> + if line_style = Literal then ( + MiniBuffer.add_char buffer '\n'; + process ~pos:0 [] rest) + else ( + MiniBuffer.flush_newline buffer; + MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); + process ~pos:ind [] rest) + | _docs -> + process ~pos:ind [] + (List.concat [List.rev line_suffices; cmd :: rest]) + else + (* mode = Flat *) + let pos = + match line_style with + | Classic -> + MiniBuffer.add_string buffer " "; + pos + 1 + | Hard -> + MiniBuffer.flush_newline buffer; + 0 + | Literal -> + MiniBuffer.add_char buffer '\n'; + 0 + | Soft -> pos + in + process ~pos line_suffices rest + | Group {should_break; doc} -> + if should_break || not (fits (width - pos) ((ind, Flat, doc) :: rest)) + then process ~pos line_suffices ((ind, Break, doc) :: rest) + else process ~pos line_suffices ((ind, Flat, doc) :: rest) + | CustomLayout docs -> + let rec find_group_that_fits groups = + match groups with + | [] -> Nil + | [last_group] -> last_group + | doc :: docs -> + if fits (width - pos) ((ind, Flat, doc) :: rest) then doc + else find_group_that_fits docs + in + let doc = find_group_that_fits docs in + process ~pos line_suffices ((ind, Flat, doc) :: rest)) + | [] -> ( + match line_suffices with + | [] -> () + | suffices -> process ~pos:0 [] (List.rev suffices)) + in + process ~pos:0 [] [(0, Flat, doc)]; + MiniBuffer.contents buffer + +let debug t = + let rec to_doc = function + | Nil -> text "nil" + | BreakParent -> text "breakparent" + | Text txt -> text ("text(\"" ^ txt ^ "\")") + | LineSuffix doc -> + group + (concat + [ + text "linesuffix("; + indent (concat [line; to_doc doc]); + line; + text ")"; + ]) + | Concat [] -> text "concat()" + | Concat docs -> + group + (concat + [ + text "concat("; + indent + (concat + [ + line; + join ~sep:(concat [text ","; line]) (List.map to_doc docs); + ]); + line; + text ")"; + ]) + | CustomLayout docs -> + group + (concat + [ + text "customLayout("; + indent + (concat + [ + line; + join ~sep:(concat [text ","; line]) (List.map to_doc docs); + ]); + line; + text ")"; + ]) + | Indent doc -> + concat [text "indent("; soft_line; to_doc doc; soft_line; text ")"] + | IfBreaks {yes = true_doc; broken = true} -> to_doc true_doc + | IfBreaks {yes = true_doc; no = false_doc} -> + group + (concat + [ + text "ifBreaks("; + indent + (concat + [ + line; + to_doc true_doc; + concat [text ","; line]; + to_doc false_doc; + ]); + line; + text ")"; + ]) + | LineBreak break -> + let break_txt = + match break with + | Classic -> "Classic" + | Soft -> "Soft" + | Hard -> "Hard" + | Literal -> "Liteal" + in + text ("LineBreak(" ^ break_txt ^ ")") + | Group {should_break; doc} -> + group + (concat + [ + text "Group("; + indent + (concat + [ + line; + text ("{shouldBreak: " ^ string_of_bool should_break ^ "}"); + concat [text ","; line]; + to_doc doc; + ]); + line; + text ")"; + ]) + in + let doc = to_doc t in + to_string ~width:10 doc |> print_endline +[@@live] diff --git a/jscomp/syntax/src/res_doc.mli b/compiler/syntax/src/res_doc.mli similarity index 78% rename from jscomp/syntax/src/res_doc.mli rename to compiler/syntax/src/res_doc.mli index f1a0c6e..763c202 100644 --- a/jscomp/syntax/src/res_doc.mli +++ b/compiler/syntax/src/res_doc.mli @@ -2,34 +2,34 @@ type t val nil : t val line : t -val hardLine : t -val softLine : t -val literalLine : t +val hard_line : t +val soft_line : t +val literal_line : t val text : string -> t val concat : t list -> t val indent : t -> t -val ifBreaks : t -> t -> t -val lineSuffix : t -> t +val if_breaks : t -> t -> t +val line_suffix : t -> t val group : t -> t -val breakableGroup : forceBreak:bool -> t -> t +val breakable_group : force_break:bool -> t -> t (* `customLayout docs` will pick the layout that fits from `docs`. * This is a very expensive computation as every layout from the list * will be checked until one fits. *) -val customLayout : t list -> t -val breakParent : t +val custom_layout : t list -> t +val break_parent : t val join : sep:t -> t list -> t (* [(doc1, sep1); (doc2,sep2)] joins as doc1 sep1 doc2 *) -val joinWithSep : (t * t) list -> t +val join_with_sep : (t * t) list -> t val space : t val comma : t val dot : t val dotdot : t val dotdotdot : t -val lessThan : t -val greaterThan : t +val less_than : t +val greater_than : t val lbrace : t val rbrace : t val lparen : t @@ -39,8 +39,8 @@ val rbracket : t val question : t val tilde : t val equal : t -val trailingComma : t -val doubleQuote : t [@@live] +val trailing_comma : t +val double_quote : t [@@live] (* * `willBreak doc` checks whether `doc` contains forced line breaks. @@ -61,7 +61,7 @@ val doubleQuote : t [@@live] * The consumer can then manually insert a `breakParent` doc, to manually propagate the * force breaks from bottom to top. *) -val willBreak : t -> bool +val will_break : t -> bool -val toString : width:int -> t -> string +val to_string : width:int -> t -> string val debug : t -> unit [@@live] diff --git a/compiler/syntax/src/res_driver.ml b/compiler/syntax/src/res_driver.ml new file mode 100644 index 0000000..64039e7 --- /dev/null +++ b/compiler/syntax/src/res_driver.ml @@ -0,0 +1,162 @@ +module IO = Res_io + +type ('ast, 'diagnostics) parse_result = { + filename: string; [@live] + source: string; + parsetree: 'ast; + diagnostics: 'diagnostics; + invalid: bool; + comments: Res_comment.t list; +} + +type 'diagnostics parsing_engine = { + parse_implementation: + for_printer:bool -> + filename:string -> + (Parsetree.structure, 'diagnostics) parse_result; + parse_interface: + for_printer:bool -> + filename:string -> + (Parsetree.signature, 'diagnostics) parse_result; + string_of_diagnostics: + source:string -> filename:string -> 'diagnostics -> unit; +} + +type print_engine = { + print_implementation: + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.structure -> + unit; + print_interface: + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.signature -> + unit; +} + +let setup ~filename ~for_printer () = + let src = IO.read_file ~filename in + let mode = if for_printer then Res_parser.Default else ParseForTypeChecker in + Res_parser.make ~mode src filename + +let setup_from_source ~display_filename ~source ~for_printer () = + let mode = if for_printer then Res_parser.Default else ParseForTypeChecker in + Res_parser.make ~mode source display_filename + +let parsing_engine = + { + parse_implementation = + (fun ~for_printer ~filename -> + let engine = setup ~filename ~for_printer () in + let structure = Res_core.parse_implementation engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = structure; + diagnostics; + invalid; + comments = List.rev engine.comments; + }); + parse_interface = + (fun ~for_printer ~filename -> + let engine = setup ~filename ~for_printer () in + let signature = Res_core.parse_specification engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = signature; + diagnostics; + invalid; + comments = List.rev engine.comments; + }); + string_of_diagnostics = + (fun ~source ~filename:_ diagnostics -> + Res_diagnostics.print_report diagnostics source); + } + +let parse_implementation_from_source ~for_printer ~display_filename ~source = + let engine = setup_from_source ~display_filename ~source ~for_printer () in + let structure = Res_core.parse_implementation engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = structure; + diagnostics; + invalid; + comments = List.rev engine.comments; + } + +let parse_interface_from_source ~for_printer ~display_filename ~source = + let engine = setup_from_source ~display_filename ~source ~for_printer () in + let signature = Res_core.parse_specification engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = signature; + diagnostics; + invalid; + comments = List.rev engine.comments; + } + +let print_engine = + { + print_implementation = + (fun ~width ~filename:_ ~comments structure -> + print_string + (Res_printer.print_implementation ~width structure ~comments)); + print_interface = + (fun ~width ~filename:_ ~comments signature -> + print_string (Res_printer.print_interface ~width signature ~comments)); + } + +let parse_implementation ?(ignore_parse_errors = false) sourcefile = + Location.input_name := sourcefile; + let parse_result = + parsing_engine.parse_implementation ~for_printer:false ~filename:sourcefile + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + parse_result.parsetree +[@@raises exit] + +let parse_interface ?(ignore_parse_errors = false) sourcefile = + Location.input_name := sourcefile; + let parse_result = + parsing_engine.parse_interface ~for_printer:false ~filename:sourcefile + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + parse_result.parsetree +[@@raises exit] + +(* suppress unused optional arg *) +let _ = + fun s -> + ( parse_implementation ~ignore_parse_errors:false s, + parse_interface ~ignore_parse_errors:false s ) +[@@raises exit] diff --git a/compiler/syntax/src/res_driver.mli b/compiler/syntax/src/res_driver.mli new file mode 100644 index 0000000..2b71701 --- /dev/null +++ b/compiler/syntax/src/res_driver.mli @@ -0,0 +1,63 @@ +type ('ast, 'diagnostics) parse_result = { + filename: string; [@live] + source: string; + parsetree: 'ast; + diagnostics: 'diagnostics; + invalid: bool; + comments: Res_comment.t list; +} + +type 'diagnostics parsing_engine = { + parse_implementation: + for_printer:bool -> + filename:string -> + (Parsetree.structure, 'diagnostics) parse_result; + parse_interface: + for_printer:bool -> + filename:string -> + (Parsetree.signature, 'diagnostics) parse_result; + string_of_diagnostics: + source:string -> filename:string -> 'diagnostics -> unit; +} + +val parse_implementation_from_source : + for_printer:bool -> + display_filename:string -> + source:string -> + (Parsetree.structure, Res_diagnostics.t list) parse_result +[@@live] + +val parse_interface_from_source : + for_printer:bool -> + display_filename:string -> + source:string -> + (Parsetree.signature, Res_diagnostics.t list) parse_result +[@@live] + +type print_engine = { + print_implementation: + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.structure -> + unit; + print_interface: + width:int -> + filename:string -> + comments:Res_comment.t list -> + Parsetree.signature -> + unit; +} + +val parsing_engine : Res_diagnostics.t list parsing_engine + +val print_engine : print_engine + +(* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) +val parse_implementation : + ?ignore_parse_errors:bool -> string -> Parsetree.structure +[@@live] [@@raises Location.Error] + +(* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) +val parse_interface : ?ignore_parse_errors:bool -> string -> Parsetree.signature +[@@live] [@@raises Location.Error] diff --git a/jscomp/syntax/src/res_driver_binary.ml b/compiler/syntax/src/res_driver_binary.ml similarity index 85% rename from jscomp/syntax/src/res_driver_binary.ml rename to compiler/syntax/src/res_driver_binary.ml index 58a8153..71eb12b 100644 --- a/jscomp/syntax/src/res_driver_binary.ml +++ b/compiler/syntax/src/res_driver_binary.ml @@ -1,12 +1,12 @@ -let printEngine = +let print_engine = Res_driver. { - printImplementation = + print_implementation = (fun ~width:_ ~filename ~comments:_ structure -> output_string stdout Config.ast_impl_magic_number; output_value stdout filename; output_value stdout structure); - printInterface = + print_interface = (fun ~width:_ ~filename ~comments:_ signature -> output_string stdout Config.ast_intf_magic_number; output_value stdout filename; diff --git a/compiler/syntax/src/res_driver_binary.mli b/compiler/syntax/src/res_driver_binary.mli new file mode 100644 index 0000000..46358ea --- /dev/null +++ b/compiler/syntax/src/res_driver_binary.mli @@ -0,0 +1 @@ +val print_engine : Res_driver.print_engine diff --git a/compiler/syntax/src/res_driver_ml_printer.ml b/compiler/syntax/src/res_driver_ml_printer.ml new file mode 100644 index 0000000..651ab05 --- /dev/null +++ b/compiler/syntax/src/res_driver_ml_printer.ml @@ -0,0 +1,10 @@ +let print_engine = + Res_driver. + { + print_implementation = + (fun ~width:_ ~filename:_ ~comments:_ structure -> + Pprintast.structure Format.std_formatter structure); + print_interface = + (fun ~width:_ ~filename:_ ~comments:_ signature -> + Pprintast.signature Format.std_formatter signature); + } diff --git a/compiler/syntax/src/res_driver_ml_printer.mli b/compiler/syntax/src/res_driver_ml_printer.mli new file mode 100644 index 0000000..46358ea --- /dev/null +++ b/compiler/syntax/src/res_driver_ml_printer.mli @@ -0,0 +1 @@ +val print_engine : Res_driver.print_engine diff --git a/compiler/syntax/src/res_grammar.ml b/compiler/syntax/src/res_grammar.ml new file mode 100644 index 0000000..8bfbbee --- /dev/null +++ b/compiler/syntax/src/res_grammar.ml @@ -0,0 +1,335 @@ +module Token = Res_token + +type t = + | OpenDescription (* open Belt *) + | ModuleLongIdent (* Foo or Foo.Bar *) [@live] + | Ternary (* condExpr ? trueExpr : falseExpr *) + | Es6ArrowExpr + | Jsx + | JsxAttribute + | JsxChild [@live] + | ExprOperand + | ExprUnary + | ExprSetField + | ExprBinaryAfterOp of Token.t + | ExprBlock + | ExprCall + | ExprList + | ExprArrayAccess + | ExprArrayMutation + | ExprIf + | ExprFor + | IfCondition + | IfBranch + | ElseBranch + | TypeExpression + | External + | PatternMatching + | PatternMatchCase + | LetBinding + | PatternList + | PatternOcamlList + | PatternRecord + | TypeDef + | TypeConstrName + | TypeParams + | TypeParam [@live] + | PackageConstraint + | TypeRepresentation + | RecordDecl + | ConstructorDeclaration + | ParameterList + | StringFieldDeclarations + | FieldDeclarations + | TypExprList + | FunctorArgs + | ModExprList + | TypeParameters + | RecordRows + | RecordRowsStringKey + | ArgumentList + | Signature + | Specification + | Structure + | Implementation + | Attribute + | TypeConstraint + | AtomicTypExpr + | ListExpr + | Pattern + | AttributePayload + | TagNames + | DictRows + +let to_string = function + | OpenDescription -> "an open description" + | ModuleLongIdent -> "a module path" + | Ternary -> "a ternary expression" + | Es6ArrowExpr -> "an es6 arrow function" + | Jsx -> "a jsx expression" + | JsxAttribute -> "a jsx attribute" + | ExprOperand -> "a basic expression" + | ExprUnary -> "a unary expression" + | ExprBinaryAfterOp op -> + "an expression after the operator \"" ^ Token.to_string op ^ "\"" + | ExprIf -> "an if expression" + | IfCondition -> "the condition of an if expression" + | IfBranch -> "the true-branch of an if expression" + | ElseBranch -> "the else-branch of an if expression" + | TypeExpression -> "a type" + | External -> "an external" + | PatternMatching -> "the cases of a pattern match" + | ExprBlock -> "a block with expressions" + | ExprSetField -> "a record field mutation" + | ExprCall -> "a function application" + | ExprArrayAccess -> "an array access expression" + | ExprArrayMutation -> "an array mutation" + | LetBinding -> "a let binding" + | TypeDef -> "a type definition" + | TypeParams -> "type parameters" + | TypeParam -> "a type parameter" + | TypeConstrName -> "a type-constructor name" + | TypeRepresentation -> "a type representation" + | RecordDecl -> "a record declaration" + | PatternMatchCase -> "a pattern match case" + | ConstructorDeclaration -> "a constructor declaration" + | ExprList -> "multiple expressions" + | PatternList -> "multiple patterns" + | PatternOcamlList -> "a list pattern" + | PatternRecord -> "a record pattern" + | ParameterList -> "parameters" + | StringFieldDeclarations -> "string field declarations" + | FieldDeclarations -> "field declarations" + | TypExprList -> "list of types" + | FunctorArgs -> "functor arguments" + | ModExprList -> "list of module expressions" + | TypeParameters -> "list of type parameters" + | RecordRows -> "rows of a record" + | RecordRowsStringKey -> "rows of a record with string keys" + | ArgumentList -> "arguments" + | Signature -> "signature" + | Specification -> "specification" + | Structure -> "structure" + | Implementation -> "implementation" + | Attribute -> "an attribute" + | TypeConstraint -> "constraints on a type" + | AtomicTypExpr -> "a type" + | ListExpr -> "an ocaml list expr" + | PackageConstraint -> "a package constraint" + | JsxChild -> "jsx child" + | Pattern -> "pattern" + | ExprFor -> "a for expression" + | AttributePayload -> "an attribute payload" + | TagNames -> "tag names" + | DictRows -> "rows of a dict" + +let is_signature_item_start = function + | Token.At | Let _ | Typ | External | Exception | Open | Include | Module + | AtAt | PercentPercent -> + true + | _ -> false + +let is_atomic_pattern_start = function + | Token.Int _ | String _ | Codepoint _ | Backtick | Lparen | Lbracket | Lbrace + | Underscore | Lident _ | Uident _ | List | Dict | Exception | Percent -> + true + | _ -> false + +let is_atomic_expr_start = function + | Token.True | False | Int _ | String _ | Float _ | Codepoint _ | Backtick + | Uident _ | Lident _ | Hash | Lparen | List | Lbracket | Lbrace | LessThan + | Module | Percent | Forwardslash | ForwardslashDot | Dict -> + true + | _ -> false + +let is_atomic_typ_expr_start = function + | Token.SingleQuote | Underscore | Lparen | Lbrace | Uident _ | Lident _ + | Percent -> + true + | _ -> false + +let is_expr_start = function + | Token.Assert | At | Await | Backtick | Bang | Codepoint _ | False | Float _ + | For | Hash | If | Int _ | Lbrace | Lbracket | LessThan | Lident _ | List + | Lparen | Minus | MinusDot | Module | Percent | Plus | PlusDot | Bnot | Bor + | Bxor | Band | String _ | Switch | True | Try | Uident _ + | Underscore (* _ => doThings() *) + | While | Forwardslash | ForwardslashDot | Dict -> + true + | _ -> false + +let is_jsx_attribute_start = function + | Token.Lident _ | Question | Lbrace -> true + | _ -> false + +let is_structure_item_start = function + | Token.Open | Let _ | Typ | External | Exception | Include | Module | AtAt + | PercentPercent | At -> + true + | t when is_expr_start t -> true + | _ -> false + +let is_pattern_start = function + | Token.Int _ | Float _ | String _ | Codepoint _ | Backtick | True | False + | Minus | Plus | Lparen | Lbracket | Lbrace | List | Dict | Underscore + | DotDotDot | Lident _ | Uident _ | Hash | Exception | Percent | Module | At + -> + true + | _ -> false + +let is_parameter_start = function + | Token.Typ | Tilde | Dot -> true + | token when is_pattern_start token -> true + | _ -> false + +(* TODO: overparse Uident ? *) +let is_string_field_decl_start = function + | Token.String _ | Lident _ | At | DotDotDot -> true + | _ -> false + +(* TODO: overparse Uident ? *) +let is_field_decl_start = function + | Token.At | Mutable | Lident _ -> true + (* recovery, TODO: this is not ideal… *) + | Uident _ -> true + | t when Token.is_keyword t -> true + | _ -> false + +let is_record_decl_start = function + | Token.At | Mutable | Lident _ | DotDotDot -> true + | _ -> false + +let is_typ_expr_start = function + | Token.At | SingleQuote | Underscore | Lparen | Lbracket | Uident _ + | Lident _ | Module | Percent | Lbrace -> + true + | _ -> false + +let is_type_parameter_start = function + | Token.Tilde | Dot -> true + | token when is_typ_expr_start token -> true + | _ -> false + +let is_type_param_start = function + | Token.Plus | Minus | SingleQuote | Underscore -> true + | _ -> false + +let is_functor_arg_start = function + | Token.At | Uident _ | Underscore | Percent | Lbrace | Lparen -> true + | _ -> false + +let is_mod_expr_start = function + | Token.At | Percent | Uident _ | Lbrace | Lparen | Lident "unpack" | Await -> + true + | _ -> false + +let is_dict_row_start = function + | Token.String _ -> true + | _ -> false + +let is_record_row_start = function + | Token.DotDotDot -> true + | Token.Uident _ | Lident _ -> true + (* TODO *) + | t when Token.is_keyword t -> true + | _ -> false + +let is_record_row_string_key_start = function + | Token.String _ -> true + | _ -> false + +let is_argument_start = function + | Token.Tilde | Dot | Underscore -> true + | t when is_expr_start t -> true + | _ -> false + +let is_pattern_match_start = function + | Token.Bar -> true + | t when is_pattern_start t -> true + | _ -> false + +let is_pattern_ocaml_list_start = function + | Token.DotDotDot -> true + | t when is_pattern_start t -> true + | _ -> false + +let is_pattern_record_item_start = function + | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true + | _ -> false + +let is_attribute_start = function + | Token.At -> true + | _ -> false + +let is_jsx_child_start = is_atomic_expr_start + +let is_block_expr_start = function + | Token.Assert | At | Await | Backtick | Bang | Codepoint _ | Exception + | False | Float _ | For | Forwardslash | ForwardslashDot | Hash | If | Int _ + | Lbrace | Lbracket | LessThan | Let _ | Lident _ | List | Lparen | Minus + | MinusDot | Module | Open | Percent | Plus | PlusDot | String _ | Switch + | True | Try | Uident _ | Underscore | While | Dict -> + true + | _ -> false + +let is_list_element grammar token = + match grammar with + | ExprList -> token = Token.DotDotDot || is_expr_start token + | ListExpr -> token = DotDotDot || is_expr_start token + | PatternList -> token = DotDotDot || is_pattern_start token + | ParameterList -> is_parameter_start token + | StringFieldDeclarations -> is_string_field_decl_start token + | FieldDeclarations -> is_field_decl_start token + | RecordDecl -> is_record_decl_start token + | TypExprList -> is_typ_expr_start token || token = Token.LessThan + | TypeParams -> is_type_param_start token + | FunctorArgs -> is_functor_arg_start token + | ModExprList -> is_mod_expr_start token + | TypeParameters -> is_type_parameter_start token + | DictRows -> is_dict_row_start token + | RecordRows -> is_record_row_start token + | RecordRowsStringKey -> is_record_row_string_key_start token + | ArgumentList -> is_argument_start token + | Signature | Specification -> is_signature_item_start token + | Structure | Implementation -> is_structure_item_start token + | PatternMatching -> is_pattern_match_start token + | PatternOcamlList -> is_pattern_ocaml_list_start token + | PatternRecord -> is_pattern_record_item_start token + | Attribute -> is_attribute_start token + | TypeConstraint -> token = Constraint + | PackageConstraint -> token = And + | ConstructorDeclaration -> token = Bar + | JsxAttribute -> is_jsx_attribute_start token + | AttributePayload -> token = Lparen + | TagNames -> token = Hash + | _ -> false + +let is_list_terminator grammar token = + match (grammar, token) with + | _, Token.Eof + | ExprList, (Rparen | Forwardslash | Rbracket) + | ListExpr, Rparen + | ArgumentList, (Rparen | DotDotDot) + | TypExprList, (Rparen | Forwardslash | GreaterThan | Equal) + | ModExprList, Rparen + | ( (PatternList | PatternOcamlList | PatternRecord), + ( Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) + | In (* for expressions *) + | Equal (* let {x} = foo *) ) ) + | ExprBlock, Rbrace + | (Structure | Signature), Rbrace + | TypeParams, Rparen + | ParameterList, (EqualGreater | Lbrace) + | JsxAttribute, (Forwardslash | GreaterThan) + | StringFieldDeclarations, Rbrace -> + true + | Attribute, token when token <> At -> true + | TypeConstraint, token when token <> Constraint -> true + | PackageConstraint, token when token <> And -> true + | ConstructorDeclaration, token when token <> Bar -> true + | AttributePayload, Rparen -> true + | TagNames, Rbracket -> true + | _ -> false + +let is_part_of_list grammar token = + is_list_element grammar token || is_list_terminator grammar token diff --git a/compiler/syntax/src/res_io.ml b/compiler/syntax/src/res_io.ml new file mode 100644 index 0000000..1912705 --- /dev/null +++ b/compiler/syntax/src/res_io.ml @@ -0,0 +1,14 @@ +let read_file ~filename = + let chan = open_in_bin filename in + let content = + try really_input_string chan (in_channel_length chan) + with End_of_file -> "" + in + close_in_noerr chan; + content + +let write_file ~filename ~contents:txt = + let chan = open_out_bin filename in + output_string chan txt; + close_out chan +[@@raises Sys_error] [@@dead "+write_file"] diff --git a/compiler/syntax/src/res_io.mli b/compiler/syntax/src/res_io.mli new file mode 100644 index 0000000..b0ec5ff --- /dev/null +++ b/compiler/syntax/src/res_io.mli @@ -0,0 +1,8 @@ +(* utilities to read and write to/from files or stdin *) + +(* reads the contents of "filename" into a string *) +val read_file : filename:string -> string + +(* writes "content" into file with name "filename" *) +val write_file : filename:string -> contents:string -> unit +[@@dead "+write_file"] diff --git a/jscomp/syntax/src/res_minibuffer.ml b/compiler/syntax/src/res_minibuffer.ml similarity index 100% rename from jscomp/syntax/src/res_minibuffer.ml rename to compiler/syntax/src/res_minibuffer.ml diff --git a/jscomp/syntax/src/res_minibuffer.mli b/compiler/syntax/src/res_minibuffer.mli similarity index 100% rename from jscomp/syntax/src/res_minibuffer.mli rename to compiler/syntax/src/res_minibuffer.mli diff --git a/compiler/syntax/src/res_multi_printer.ml b/compiler/syntax/src/res_multi_printer.ml new file mode 100644 index 0000000..711241a --- /dev/null +++ b/compiler/syntax/src/res_multi_printer.ml @@ -0,0 +1,33 @@ +(* print res files to res syntax *) +let print_res ~ignore_parse_errors ~is_interface ~filename = + if is_interface then ( + let parse_result = + Res_driver.parsing_engine.parse_interface ~for_printer:true ~filename + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + Res_printer.print_interface ~width:Res_printer.default_print_width + ~comments:parse_result.comments parse_result.parsetree) + else + let parse_result = + Res_driver.parsing_engine.parse_implementation ~for_printer:true ~filename + in + if parse_result.invalid then ( + Res_diagnostics.print_report parse_result.diagnostics parse_result.source; + if not ignore_parse_errors then exit 1); + Res_printer.print_implementation ~width:Res_printer.default_print_width + ~comments:parse_result.comments parse_result.parsetree +[@@raises exit] + +(* print the given file named input to from "language" to res, general interface exposed by the compiler *) +let print ?(ignore_parse_errors = false) input = + let is_interface = + let len = String.length input in + len > 0 && String.unsafe_get input (len - 1) = 'i' + in + print_res ~ignore_parse_errors ~is_interface ~filename:input +[@@raises exit] + +(* suppress unused optional arg *) +let _ = fun s -> print ~ignore_parse_errors:false s [@@raises exit] diff --git a/compiler/syntax/src/res_multi_printer.mli b/compiler/syntax/src/res_multi_printer.mli new file mode 100644 index 0000000..bb66106 --- /dev/null +++ b/compiler/syntax/src/res_multi_printer.mli @@ -0,0 +1,3 @@ +(* Interface to print source code to res. + * Takes a filename called "input" and returns the corresponding formatted res syntax *) +val print : ?ignore_parse_errors:bool -> string -> string [@@dead "+print"] diff --git a/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml new file mode 100644 index 0000000..f6fd5ae --- /dev/null +++ b/compiler/syntax/src/res_outcome_printer.ml @@ -0,0 +1,1094 @@ +(* For the curious: the outcome printer is a printer to print data + * from the outcometree.mli file in the ocaml compiler. + * The outcome tree is used by: + * - ocaml's toplevel/repl, print results/errors + * - super errors, print nice errors + * - editor tooling, e.g. show type on hover + * + * In general it represent messages to show results or errors to the user. *) + +module Doc = Res_doc +module Printer = Res_printer + +(* ReScript doesn't have parenthesized identifiers. + * We don't support custom operators. *) +let parenthesized_ident _name = true + +(* TODO: better allocation strategy for the buffer *) +let escape_string_contents s = + let len = String.length s in + let b = Buffer.create len in + for i = 0 to len - 1 do + let c = (String.get [@doesNotRaise]) s i in + if c = '\008' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'b') + else if c = '\009' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 't') + else if c = '\010' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'n') + else if c = '\013' then ( + Buffer.add_char b '\\'; + Buffer.add_char b 'r') + else if c = '\034' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '"') + else if c = '\092' then ( + Buffer.add_char b '\\'; + Buffer.add_char b '\\') + else Buffer.add_char b c + done; + Buffer.contents b + +(* let rec print_ident fmt ident = match ident with + | Outcometree.Oide_ident s -> Format.pp_print_string fmt s + | Oide_dot (id, s) -> + print_ident fmt id; + Format.pp_print_char fmt '.'; + Format.pp_print_string fmt s + | Oide_apply (id1, id2) -> + print_ident fmt id1; + Format.pp_print_char fmt '('; + print_ident fmt id2; + Format.pp_print_char fmt ')' *) + +let rec print_out_ident_doc ?(allow_uident = true) + (ident : Outcometree.out_ident) = + match ident with + | Oide_ident s -> Printer.print_ident_like ~allow_uident s + | Oide_dot (ident, s) -> + Doc.concat [print_out_ident_doc ident; Doc.dot; Doc.text s] + | Oide_apply (call, arg) -> + Doc.concat + [ + print_out_ident_doc call; Doc.lparen; print_out_ident_doc arg; Doc.rparen; + ] + +let print_out_attribute_doc (out_attribute : Outcometree.out_attribute) = + Doc.concat [Doc.text "@"; Doc.text out_attribute.oattr_name] + +let print_out_attributes_doc (attrs : Outcometree.out_attribute list) = + match attrs with + | [] -> Doc.nil + | attrs -> + Doc.concat + [ + Doc.group + (Doc.join ~sep:Doc.line (List.map print_out_attribute_doc attrs)); + Doc.line; + ] + +let rec collect_arrow_args (out_type : Outcometree.out_type) args = + match out_type with + | Otyp_arrow (label, arg_type, return_type, arity) + when arity = None || args = [] -> + let arg = (label, arg_type) in + collect_arrow_args return_type (arg :: args) + | _ as return_type -> (List.rev args, return_type) + +let rec collect_functor_args (out_module_type : Outcometree.out_module_type) + args = + match out_module_type with + | Omty_functor (lbl, opt_mod_type, return_mod_type) -> + let arg = (lbl, opt_mod_type) in + collect_functor_args return_mod_type (arg :: args) + | _ -> (List.rev args, out_module_type) + +let rec print_out_type_doc (out_type : Outcometree.out_type) = + match out_type with + | Otyp_abstract | Otyp_open -> Doc.nil + | Otyp_variant (non_gen, out_variant, closed, labels) -> + (* bool * out_variant * bool * (string list) option *) + let opening = + match (closed, labels) with + | true, None -> (* [#A | #B] *) Doc.soft_line + | false, None -> + (* [> #A | #B] *) + Doc.concat [Doc.greater_than; Doc.line] + | true, Some [] -> + (* [< #A | #B] *) + Doc.concat [Doc.less_than; Doc.line] + | true, Some _ -> + (* [< #A | #B > #X #Y ] *) + Doc.concat [Doc.less_than; Doc.line] + | false, Some _ -> + (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) + Doc.concat [Doc.text "?"; Doc.line] + in + Doc.group + (Doc.concat + [ + (if non_gen then Doc.text "_" else Doc.nil); + Doc.lbracket; + Doc.indent (Doc.concat [opening; print_out_variant out_variant]); + Doc.soft_line; + Doc.rbracket; + ]) + | Otyp_alias (typ, alias_txt) -> + Doc.concat + [ + Doc.lparen; + print_out_type_doc typ; + Doc.text " as '"; + Doc.text alias_txt; + Doc.rparen; + ] + | Otyp_constr (out_ident, []) -> + print_out_ident_doc ~allow_uident:false out_ident + | Otyp_manifest (typ1, typ2) -> + Doc.concat + [print_out_type_doc typ1; Doc.text " = "; print_out_type_doc typ2] + | Otyp_record record -> print_record_declaration_doc ~inline:true record + | Otyp_stuff txt -> Doc.text txt + | Otyp_var (ng, s) -> + Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] + | Otyp_object (fields, rest) -> print_object_fields fields rest + | Otyp_class _ -> Doc.nil + | Otyp_attribute (typ, attribute) -> + Doc.group + (Doc.concat + [print_out_attribute_doc attribute; Doc.line; print_out_type_doc typ]) + (* example: Red | Blue | Green | CustomColour(float, float, float) *) + | Otyp_sum constructors -> print_out_constructors_doc constructors + (* example: {"name": string, "age": int} *) + | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [Otyp_object (fields, rest)]) + -> + print_object_fields fields rest + (* example: node *) + | Otyp_constr (out_ident, args) -> + let args_doc = + match args with + | [] -> Doc.nil + | args -> + Doc.concat + [ + Doc.less_than; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_out_type_doc args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; + ] + in + Doc.group (Doc.concat [print_out_ident_doc out_ident; args_doc]) + | Otyp_tuple tuple_args -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_out_type_doc tuple_args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + | Otyp_poly (vars, out_type) -> + Doc.group + (Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text ("'" ^ var)) vars); + Doc.dot; + Doc.space; + print_out_type_doc out_type; + ]) + | Otyp_arrow _ as typ -> print_out_arrow_type typ + | Otyp_module (mod_name, string_list, out_types) -> + let package_type_doc = + match (string_list, out_types) with + | [], [] -> Doc.nil + | labels, types -> + let i = ref 0 in + let package = + Doc.join ~sep:Doc.line + ((List.map2 [@doesNotRaise]) + (fun lbl typ -> + let result = + Doc.concat + [ + Doc.text + (if i.contents > 0 then "and type " else "with type "); + Doc.text lbl; + Doc.text " = "; + print_out_type_doc typ; + ] + in + incr i; + result) + labels types) + in + Doc.indent (Doc.concat [Doc.line; package]) + in + Doc.concat + [ + Doc.text "module"; + Doc.lparen; + Doc.text mod_name; + package_type_doc; + Doc.rparen; + ] + +and print_out_arrow_type typ = + let typ_args, typ = collect_arrow_args typ [] in + let args = + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (lbl, typ) -> + let lbl_len = String.length lbl in + if lbl_len = 0 then print_out_type_doc typ + else + let lbl, optional_indicator = + (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) + match String.unsafe_get lbl 0 with + | '?' -> + ( (String.sub [@doesNotRaise]) lbl 1 (lbl_len - 1), + Doc.text "=?" ) + | _ -> (lbl, Doc.nil) + in + Doc.group + (Doc.concat + [ + Doc.text ("~" ^ lbl ^ ": "); + print_out_type_doc typ; + optional_indicator; + ])) + typ_args) + in + let args_doc = + let needs_parens = + match typ_args with + | [(_, (Otyp_tuple _ | Otyp_arrow _))] -> true + (* single argument should not be wrapped *) + | [("", _)] -> false + | _ -> true + in + if needs_parens then + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent (Doc.concat [Doc.soft_line; args]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + else args + in + Doc.concat [args_doc; Doc.text " => "; print_out_type_doc typ] + +and print_out_variant variant = + match variant with + | Ovar_fields fields -> + (* (string * bool * out_type list) list *) + Doc.join ~sep:Doc.line + ((* + * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand + * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand + *) + List.mapi + (fun i (name, ampersand, types) -> + let needs_parens = + match types with + | [Outcometree.Otyp_tuple _] -> false + | _ -> true + in + Doc.concat + [ + (if i > 0 then Doc.text "| " + else Doc.if_breaks (Doc.text "| ") Doc.nil); + Doc.group + (Doc.concat + [ + Doc.text "#"; + Printer.print_poly_var_ident name; + (match types with + | [] -> Doc.nil + | types -> + Doc.concat + [ + (if ampersand then Doc.text " & " else Doc.nil); + Doc.indent + (Doc.concat + [ + Doc.join + ~sep:(Doc.concat [Doc.text " &"; Doc.line]) + (List.map + (fun typ -> + let out_type_doc = + print_out_type_doc typ + in + if needs_parens then + Doc.concat + [ + Doc.lparen; + out_type_doc; + Doc.rparen; + ] + else out_type_doc) + types); + ]); + ]); + ]); + ]) + fields) + | Ovar_typ typ -> print_out_type_doc typ + +and print_object_fields fields rest = + let dots = + match rest with + | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") + | None -> if fields = [] then Doc.dot else Doc.nil + in + Doc.group + (Doc.concat + [ + Doc.lbrace; + dots; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (lbl, out_type) -> + Doc.group + (Doc.concat + [ + Doc.text ("\"" ^ lbl ^ "\": "); + print_out_type_doc out_type; + ])) + fields); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ]) + +and print_out_constructors_doc constructors = + Doc.group + (Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join ~sep:Doc.line + (List.mapi + (fun i constructor -> + Doc.concat + [ + (if i > 0 then Doc.text "| " + else Doc.if_breaks (Doc.text "| ") Doc.nil); + print_out_constructor_doc constructor; + ]) + constructors); + ])) + +and print_out_constructor_doc (name, args, gadt, repr) = + let repr_doc = + match repr with + | None -> Doc.nil + | Some s -> Doc.text (s ^ " ") + in + let gadt_doc = + match gadt with + | Some out_type -> Doc.concat [Doc.text ": "; print_out_type_doc out_type] + | None -> Doc.nil + in + let args_doc = + match args with + | [] -> Doc.nil + | [Otyp_record record] -> + (* inline records + * | Root({ + * mutable value: 'value, + * mutable updatedTime: float, + * }) + *) + Doc.concat + [ + Doc.lparen; + Doc.indent (print_record_declaration_doc ~inline:true record); + Doc.rparen; + ] + | _types -> + Doc.indent + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_out_type_doc args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + in + Doc.group (Doc.concat [repr_doc; Doc.text name; args_doc; gadt_doc]) + +and print_record_decl_row_doc (name, mut, opt, arg) = + Doc.group + (Doc.concat + [ + (if mut then Doc.text "mutable " else Doc.nil); + Printer.print_ident_like ~allow_uident:false name; + (if opt then Doc.text "?" else Doc.nil); + Doc.text ": "; + print_out_type_doc arg; + ]) + +and print_record_declaration_doc ~inline rows = + let content = + Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_record_decl_row_doc rows); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ] + in + if not inline then Doc.group content else content + +let print_out_type fmt out_type = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_type_doc out_type)) + +let print_type_parameter_doc (typ, (co, cn)) = + Doc.concat + [ + (if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil); + (if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ)); + ] + +let rec print_out_sig_item_doc ?(print_name_as_is = false) + (out_sig_item : Outcometree.out_sig_item) = + match out_sig_item with + | Osig_class _ | Osig_class_type _ -> Doc.nil + | Osig_ellipsis -> Doc.dotdotdot + | Osig_value value_decl -> + Doc.group + (Doc.concat + [ + print_out_attributes_doc value_decl.oval_attributes; + Doc.text + (match value_decl.oval_prims with + | [] -> "let " + | _ -> "external "); + Doc.text value_decl.oval_name; + Doc.text ":"; + Doc.space; + print_out_type_doc value_decl.oval_type; + (match value_decl.oval_prims with + | [] -> Doc.nil + | primitives -> + Doc.indent + (Doc.concat + [ + Doc.text " ="; + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map + (fun prim -> + let prim = + if + prim <> "" + && (prim.[0] [@doesNotRaise]) = '\132' + then "#rescript-external" + else prim + in + (* not display those garbage '\132' is a magic number for marshal *) + Doc.text ("\"" ^ prim ^ "\"")) + primitives)); + ])); + ]) + | Osig_typext (out_extension_constructor, _outExtStatus) -> + print_out_extension_constructor_doc out_extension_constructor + | Osig_modtype (mod_name, Omty_signature []) -> + Doc.concat [Doc.text "module type "; Doc.text mod_name] + | Osig_modtype (mod_name, out_module_type) -> + Doc.group + (Doc.concat + [ + Doc.text "module type "; + Doc.text mod_name; + Doc.text " = "; + print_out_module_type_doc out_module_type; + ]) + | Osig_module (mod_name, Omty_alias ident, _) -> + Doc.group + (Doc.concat + [ + Doc.text "module "; + Doc.text mod_name; + Doc.text " ="; + Doc.line; + print_out_ident_doc ident; + ]) + | Osig_module (mod_name, out_mod_type, out_rec_status) -> + Doc.group + (Doc.concat + [ + Doc.text + (match out_rec_status with + | Orec_not -> "module " + | Orec_first -> "module rec " + | Orec_next -> "and "); + Doc.text mod_name; + Doc.text ": "; + print_out_module_type_doc out_mod_type; + ]) + | Osig_type (out_type_decl, out_rec_status) -> + (* TODO: manifest ? *) + let attrs = + match (out_type_decl.otype_immediate, out_type_decl.otype_unboxed) with + | false, false -> Doc.nil + | true, false -> Doc.concat [Doc.text "@immediate"; Doc.line] + | false, true -> Doc.concat [Doc.text "@unboxed"; Doc.line] + | true, true -> Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] + in + let kw = + Doc.text + (match out_rec_status with + | Orec_not -> "type " + | Orec_first -> "type rec " + | Orec_next -> "and ") + in + let type_params = + match out_type_decl.otype_params with + | [] -> Doc.nil + | _params -> + Doc.group + (Doc.concat + [ + Doc.less_than; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_type_parameter_doc + out_type_decl.otype_params); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; + ]) + in + let private_doc = + match out_type_decl.otype_private with + | Asttypes.Private -> Doc.text "private " + | Public -> Doc.nil + in + let kind = + match out_type_decl.otype_type with + | Otyp_open -> Doc.concat [Doc.text " = "; private_doc; Doc.text ".."] + | Otyp_abstract -> Doc.nil + | Otyp_record record -> + Doc.concat + [ + Doc.text " = "; + private_doc; + print_record_declaration_doc ~inline:false record; + ] + | typ -> Doc.concat [Doc.text " = "; print_out_type_doc typ] + in + let constraints = + match out_type_decl.otype_cstrs with + | [] -> Doc.nil + | _ -> + Doc.group + (Doc.indent + (Doc.concat + [ + Doc.hard_line; + Doc.join ~sep:Doc.line + (List.map + (fun (typ1, typ2) -> + Doc.group + (Doc.concat + [ + Doc.text "constraint "; + print_out_type_doc typ1; + Doc.text " ="; + Doc.space; + print_out_type_doc typ2; + ])) + out_type_decl.otype_cstrs); + ])) + in + Doc.group + (Doc.concat + [ + attrs; + Doc.group + (Doc.concat + [ + kw; + (if print_name_as_is then Doc.text out_type_decl.otype_name + else + Printer.print_ident_like ~allow_uident:false + out_type_decl.otype_name); + type_params; + kind; + ]); + constraints; + ]) + +and print_out_module_type_doc (out_mod_type : Outcometree.out_module_type) = + match out_mod_type with + | Omty_abstract -> Doc.nil + | Omty_ident ident -> print_out_ident_doc ident + (* example: module Increment = (M: X_int) => X_int *) + | Omty_functor _ -> + let args, return_mod_type = collect_functor_args out_mod_type [] in + let args_doc = + match args with + | [(_, None)] -> Doc.text "()" + | args -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (lbl, opt_mod_type) -> + Doc.group + (Doc.concat + [ + Doc.text lbl; + (match opt_mod_type with + | None -> Doc.nil + | Some mod_type -> + Doc.concat + [ + Doc.text ": "; + print_out_module_type_doc mod_type; + ]); + ])) + args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + in + Doc.group + (Doc.concat + [args_doc; Doc.text " => "; print_out_module_type_doc return_mod_type]) + | Omty_signature [] -> Doc.nil + | Omty_signature signature -> + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent (Doc.concat [Doc.line; print_out_signature_doc signature]); + Doc.soft_line; + Doc.rbrace; + ]) + | Omty_alias _ident -> Doc.nil + +and print_out_signature_doc (signature : Outcometree.out_sig_item list) = + let rec loop signature acc = + match signature with + | [] -> List.rev acc + | Outcometree.Osig_typext (ext, Oext_first) :: items -> + (* Gather together the extension constructors *) + let rec gather_extensions acc items = + match items with + | Outcometree.Osig_typext (ext, Oext_next) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, items = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + items + in + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = print_out_type_extension_doc te in + loop items (doc :: acc) + | item :: items -> + let doc = print_out_sig_item_doc ~print_name_as_is:false item in + loop items (doc :: acc) + in + match loop signature [] with + | [doc] -> doc + | docs -> Doc.breakable_group ~force_break:true (Doc.join ~sep:Doc.line docs) + +and print_out_extension_constructor_doc + (out_ext : Outcometree.out_extension_constructor) = + let type_params = + match out_ext.oext_type_params with + | [] -> Doc.nil + | params -> + Doc.group + (Doc.concat + [ + Doc.less_than; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.soft_line; + Doc.greater_than; + ]) + in + + Doc.group + (Doc.concat + [ + Doc.text "type "; + Printer.print_ident_like ~allow_uident:false out_ext.oext_type_name; + type_params; + Doc.text " += "; + Doc.line; + (if out_ext.oext_private = Asttypes.Private then Doc.text "private " + else Doc.nil); + print_out_constructor_doc + ( out_ext.oext_name, + out_ext.oext_args, + out_ext.oext_ret_type, + out_ext.oext_repr ); + ]) + +and print_out_type_extension_doc + (type_extension : Outcometree.out_type_extension) = + let type_params = + match type_extension.otyext_params with + | [] -> Doc.nil + | params -> + Doc.group + (Doc.concat + [ + Doc.less_than; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ty -> + Doc.text (if ty = "_" then ty else "'" ^ ty)) + params); + ]); + Doc.soft_line; + Doc.greater_than; + ]) + in + + Doc.group + (Doc.concat + [ + Doc.text "type "; + Printer.print_ident_like ~allow_uident:false type_extension.otyext_name; + type_params; + Doc.text " += "; + (if type_extension.otyext_private = Asttypes.Private then + Doc.text "private " + else Doc.nil); + print_out_constructors_doc type_extension.otyext_constructors; + ]) + +let print_out_sig_item fmt out_sig_item = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_sig_item_doc out_sig_item)) + +let print_out_signature fmt signature = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_signature_doc signature)) + +let valid_float_lexeme s = + let l = String.length s in + let rec loop i = + if i >= l then s ^ "." + else + match s.[i] [@doesNotRaise] with + | '0' .. '9' | '-' -> loop (i + 1) + | _ -> s + in + loop 0 + +let float_repres f = + match classify_float f with + | FP_nan -> "nan" + | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" + | _ -> + let float_val = + let s1 = Printf.sprintf "%.12g" f in + if f = (float_of_string [@doesNotRaise]) s1 then s1 + else + let s2 = Printf.sprintf "%.15g" f in + if f = (float_of_string [@doesNotRaise]) s2 then s2 + else Printf.sprintf "%.18g" f + in + valid_float_lexeme float_val + +let rec print_out_value_doc (out_value : Outcometree.out_value) = + match out_value with + | Oval_array out_values -> + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_out_value_doc out_values); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbracket; + ]) + | Oval_char c -> Doc.text ("'" ^ Char.escaped c ^ "'") + | Oval_constr (out_ident, out_values) -> + Doc.group + (Doc.concat + [ + print_out_ident_doc out_ident; + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_out_value_doc out_values); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + | Oval_ellipsis -> Doc.text "..." + | Oval_int i -> Doc.text (Format.sprintf "%i" i) + | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) + | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) + | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) + | Oval_float f -> Doc.text (float_repres f) + | Oval_list out_values -> + Doc.group + (Doc.concat + [ + Doc.text "list["; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_out_value_doc out_values); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbracket; + ]) + | Oval_printer fn -> + let fmt = Format.str_formatter in + fn fmt; + let str = Format.flush_str_formatter () in + Doc.text str + | Oval_record rows -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (out_ident, out_value) -> + Doc.group + (Doc.concat + [ + print_out_ident_doc out_ident; + Doc.text ": "; + print_out_value_doc out_value; + ])) + rows); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + | Oval_string (txt, _sizeToPrint, _kind) -> + Doc.text (escape_string_contents txt) + | Oval_stuff txt -> Doc.text txt + | Oval_tuple out_values -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_out_value_doc out_values); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + (* Not supported by ReScript *) + | Oval_variant _ -> Doc.nil + +let print_out_exception_doc exc out_value = + match exc with + | Sys.Break -> Doc.text "Interrupted." + | Out_of_memory -> Doc.text "Out of memory during evaluation." + | Stack_overflow -> + Doc.text "Stack overflow during evaluation (looping recursion?)." + | _ -> + Doc.group + (Doc.indent + (Doc.concat + [Doc.text "Exception:"; Doc.line; print_out_value_doc out_value])) + +let print_out_phrase_signature signature = + let rec loop signature acc = + match signature with + | [] -> List.rev acc + | (Outcometree.Osig_typext (ext, Oext_first), None) :: signature -> + (* Gather together extension constructors *) + let rec gather_extensions acc items = + match items with + | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> + gather_extensions + ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) + :: acc) + items + | _ -> (List.rev acc, items) + in + let exts, signature = + gather_extensions + [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] + signature + in + let te = + { + Outcometree.otyext_name = ext.oext_type_name; + otyext_params = ext.oext_type_params; + otyext_constructors = exts; + otyext_private = ext.oext_private; + } + in + let doc = print_out_type_extension_doc te in + loop signature (doc :: acc) + | (sig_item, opt_out_value) :: signature -> + let doc = + match opt_out_value with + | None -> print_out_sig_item_doc sig_item + | Some out_value -> + Doc.group + (Doc.concat + [ + print_out_sig_item_doc sig_item; + Doc.text " = "; + print_out_value_doc out_value; + ]) + in + loop signature (doc :: acc) + in + Doc.breakable_group ~force_break:true + (Doc.join ~sep:Doc.line (loop signature [])) + +let print_out_phrase_doc (out_phrase : Outcometree.out_phrase) = + match out_phrase with + | Ophr_eval (out_value, out_type) -> + Doc.group + (Doc.concat + [ + Doc.text "- : "; + print_out_type_doc out_type; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; print_out_value_doc out_value]); + ]) + | Ophr_signature [] -> Doc.nil + | Ophr_signature signature -> print_out_phrase_signature signature + | Ophr_exception (exc, out_value) -> print_out_exception_doc exc out_value + +let print_out_phrase fmt out_phrase = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_phrase_doc out_phrase)) + +let print_out_module_type fmt out_module_type = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_module_type_doc out_module_type)) + +let print_out_type_extension fmt type_extension = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_type_extension_doc type_extension)) + +let print_out_value fmt out_value = + Format.pp_print_string fmt + (Doc.to_string ~width:80 (print_out_value_doc out_value)) + +(* Not supported in ReScript *) +(* Oprint.out_class_type *) +let setup = + lazy + (Oprint.out_value := print_out_value; + Oprint.out_type := print_out_type; + Oprint.out_module_type := print_out_module_type; + Oprint.out_sig_item := print_out_sig_item; + Oprint.out_signature := print_out_signature; + Oprint.out_type_extension := print_out_type_extension; + Oprint.out_phrase := print_out_phrase) diff --git a/jscomp/syntax/src/res_outcome_printer.mli b/compiler/syntax/src/res_outcome_printer.mli similarity index 76% rename from jscomp/syntax/src/res_outcome_printer.mli rename to compiler/syntax/src/res_outcome_printer.mli index c51bb09..609644e 100644 --- a/jscomp/syntax/src/res_outcome_printer.mli +++ b/compiler/syntax/src/res_outcome_printer.mli @@ -12,7 +12,7 @@ val parenthesized_ident : string -> bool [@@live] val setup : unit lazy_t [@@live] (* Needed for e.g. the playground to print typedtree data *) -val printOutTypeDoc : Outcometree.out_type -> Res_doc.t [@@live] -val printOutSigItemDoc : - ?printNameAsIs:bool -> Outcometree.out_sig_item -> Res_doc.t +val print_out_type_doc : Outcometree.out_type -> Res_doc.t [@@live] +val print_out_sig_item_doc : + ?print_name_as_is:bool -> Outcometree.out_sig_item -> Res_doc.t [@@live] diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml new file mode 100644 index 0000000..8d8aeef --- /dev/null +++ b/compiler/syntax/src/res_parens.ml @@ -0,0 +1,463 @@ +module ParsetreeViewer = Res_parsetree_viewer +type kind = Parenthesized | Braced of Location.t | Nothing + +let expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | _ -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | _ -> Nothing) + +let expr_record_row_rhs ~optional e = + let kind = expr e in + match kind with + | Nothing when optional -> ( + match e.pexp_desc with + | Pexp_ifthenelse _ | Pexp_fun _ -> Parenthesized + | _ when ParsetreeViewer.is_binary_expression e -> Parenthesized + | _ -> kind) + | _ -> kind + +let call_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | _ -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filter_parsing_attrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | _ + when ParsetreeViewer.is_unary_expression expr + || ParsetreeViewer.is_binary_expression expr -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ + | Pexp_setfield _ | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ + | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized + | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ -> Nothing) + +let structure_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | {pexp_desc = Pexp_jsx_element _} -> Nothing + | _ when ParsetreeViewer.has_attributes expr.pexp_attributes -> + Parenthesized + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | _ -> Nothing) + +let unary_expr_operand expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filter_parsing_attrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.is_unary_expression expr + || ParsetreeViewer.is_binary_expression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ + | Pexp_setfield _ | Pexp_extension _ (* readability? maybe remove *) + | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ + | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ -> Nothing) + +let binary_expr_operand ~is_lhs expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> + Nothing + | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_newtype _} -> + Parenthesized + | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized + | expr when ParsetreeViewer.is_binary_expression expr -> Parenthesized + | expr when ParsetreeViewer.is_ternary_expr expr -> Parenthesized + | {pexp_desc = Pexp_assert _} when is_lhs -> Parenthesized + | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | {Parsetree.pexp_attributes = attrs} -> + if ParsetreeViewer.has_printable_attributes attrs then Parenthesized + else Nothing) + +let sub_binary_expr_operand parent_operator child_operator = + let open ParsetreeViewer in + let prec_parent = operator_precedence parent_operator in + let prec_child = operator_precedence child_operator in + prec_parent > prec_child + || is_equality_operator parent_operator + && is_equality_operator child_operator + || + (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) + (parent_operator = "||" && child_operator = "&&") + +let rhs_binary_expr_operand parent_operator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply + { + funct = + { + pexp_attributes = []; + pexp_desc = + Pexp_ident {txt = Longident.Lident operator; loc = operator_loc}; + }; + args = [(_, _left); (_, _right)]; + } + when ParsetreeViewer.not_ghost_operator operator operator_loc -> + let prec_parent = ParsetreeViewer.operator_precedence parent_operator in + let prec_child = ParsetreeViewer.operator_precedence operator in + prec_parent == prec_child + | _ -> false + +let flatten_operand_rhs parent_operator rhs = + match rhs.Parsetree.pexp_desc with + | Parsetree.Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident {txt = Longident.Lident operator; loc = operator_loc}; + }; + args = [(_, _left); (_, _right)]; + } + when ParsetreeViewer.not_ghost_operator operator operator_loc -> + let prec_parent = ParsetreeViewer.operator_precedence parent_operator in + let prec_child = ParsetreeViewer.operator_precedence operator in + prec_parent >= prec_child || rhs.pexp_attributes <> [] + | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> + false + | Pexp_fun {lhs = {ppat_desc = Ppat_var {txt = "__x"}}} -> false + | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true + | _ when ParsetreeViewer.is_ternary_expr rhs -> true + | _ -> false + +let binary_operator_inside_await_needs_parens operator = + ParsetreeViewer.operator_precedence operator + < ParsetreeViewer.operator_precedence "->" + +let assert_or_await_expr_rhs ?(in_await = false) expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filter_parsing_attrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | { + pexp_desc = + Pexp_apply + {funct = {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}}; + } + when ParsetreeViewer.is_binary_expression expr -> + if in_await && not (binary_operator_inside_await_needs_parens operator) + then Nothing + else Parenthesized + | { + pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ + | Pexp_setfield _ | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ + | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when (not in_await) && ParsetreeViewer.expr_is_await expr -> + Parenthesized + | _ -> Nothing) + +let is_negative_constant constant = + let is_neg txt = + let len = String.length txt in + len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' + in + match constant with + | (Parsetree.Pconst_integer (i, _) | Pconst_float (i, _)) when is_neg i -> + true + | _ -> false + +let field_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = attrs} + when match ParsetreeViewer.filter_parsing_attrs attrs with + | _ :: _ -> true + | [] -> false -> + Parenthesized + | expr + when ParsetreeViewer.is_binary_expression expr + || ParsetreeViewer.is_unary_expression expr -> + Parenthesized + | { + pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constant c} when is_negative_constant c -> Parenthesized + | {pexp_desc = Pexp_fun _} + when ParsetreeViewer.is_underscore_apply_sugar expr -> + Nothing + | { + pexp_desc = + ( Pexp_assert _ | Pexp_extension _ (* %extension.x vs (%extension).x *) + | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ + | Pexp_ifthenelse _ ); + } -> + Parenthesized + | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | _ -> Nothing) + +let set_field_expr_rhs expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | _ -> Nothing) + +let ternary_operand expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + } -> + Nothing + | {pexp_desc = Pexp_constraint _} -> Parenthesized + | _ when Res_parsetree_viewer.is_fun_newtype expr -> ( + let _, _parameters, return_expr = ParsetreeViewer.fun_expr expr in + match return_expr.pexp_desc with + | Pexp_constraint _ -> Parenthesized + | _ -> Nothing) + | _ -> Nothing) + +let starts_with_minus txt = + let len = String.length txt in + if len == 0 then false + else + let s = (String.get [@doesNotRaise]) txt 0 in + s = '-' + +let jsx_prop_expr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ + | Pexp_letmodule _ | Pexp_open _ -> + Nothing + | _ -> ( + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when starts_with_minus x -> + Parenthesized + | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + pexp_attributes = []; + } -> + Nothing + | _ -> Parenthesized)) + +let jsx_child_expr expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ + | Pexp_letmodule _ | Pexp_open _ -> + Nothing + | _ -> ( + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | _ -> ( + match expr with + | { + Parsetree.pexp_desc = + Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); + pexp_attributes = []; + } + when starts_with_minus x -> + Parenthesized + | _ when ParsetreeViewer.expr_is_await expr -> Parenthesized + | { + Parsetree.pexp_desc = + ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ + | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ + | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_jsx_element _ ); + pexp_attributes = []; + } -> + Nothing + | { + Parsetree.pexp_desc = + Pexp_constraint + ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); + pexp_attributes = []; + } -> + Nothing + | {pexp_desc = Pexp_jsx_element _} -> Nothing + | _ -> Parenthesized)) + +let binary_expr expr = + let opt_braces, _ = ParsetreeViewer.process_braces_attr expr in + match opt_braces with + | Some ({Location.loc = braces_loc}, _) -> Braced braces_loc + | None -> ( + match expr with + | {Parsetree.pexp_attributes = _ :: _} as expr + when ParsetreeViewer.is_binary_expression expr -> + Parenthesized + | _ -> Nothing) + +let mod_type_functor_return mod_type = + match mod_type with + | {Parsetree.pmty_desc = Pmty_with _} -> true + | _ -> false + +(* Add parens for readability: + module type Functor = SetLike => Set with type t = A.t + This is actually: + module type Functor = (SetLike => Set) with type t = A.t +*) +let mod_type_with_operand mod_type = + match mod_type with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false + +let mod_expr_functor_constraint mod_type = + match mod_type with + | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true + | _ -> false + +let braced_expr expr = + match expr.Parsetree.pexp_desc with + | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> + false + | Pexp_constraint _ -> true + | _ -> false + +let include_mod_expr mod_expr = + match mod_expr.Parsetree.pmod_desc with + | Parsetree.Pmod_constraint _ -> true + | _ -> false + +let mod_expr_parens mod_expr = + match mod_expr with + | { + Parsetree.pmod_desc = + Pmod_constraint + ( {Parsetree.pmod_desc = Pmod_structure _}, + {Parsetree.pmty_desc = Pmty_signature [{psig_desc = Psig_module _}]} ); + } -> + false + | { + Parsetree.pmod_desc = + Pmod_constraint + (_, {Parsetree.pmty_desc = Pmty_signature [{psig_desc = Psig_module _}]}); + } -> + true + | _ -> false + +let arrow_return_typ_expr typ_expr = + match typ_expr.Parsetree.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false + +let pattern_record_row_rhs (pattern : Parsetree.pattern) = + match pattern.ppat_desc with + | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) + -> + false + | Ppat_constraint _ -> true + | _ -> false diff --git a/compiler/syntax/src/res_parens.mli b/compiler/syntax/src/res_parens.mli new file mode 100644 index 0000000..0264264 --- /dev/null +++ b/compiler/syntax/src/res_parens.mli @@ -0,0 +1,41 @@ +type kind = Parenthesized | Braced of Location.t | Nothing + +val expr : Parsetree.expression -> kind +val structure_expr : Parsetree.expression -> kind + +val unary_expr_operand : Parsetree.expression -> kind + +val binary_expr_operand : is_lhs:bool -> Parsetree.expression -> kind +val sub_binary_expr_operand : string -> string -> bool +val rhs_binary_expr_operand : string -> Parsetree.expression -> bool +val flatten_operand_rhs : string -> Parsetree.expression -> bool + +val binary_operator_inside_await_needs_parens : string -> bool +val assert_or_await_expr_rhs : ?in_await:bool -> Parsetree.expression -> kind + +val field_expr : Parsetree.expression -> kind + +val set_field_expr_rhs : Parsetree.expression -> kind + +val ternary_operand : Parsetree.expression -> kind + +val jsx_prop_expr : Parsetree.expression -> kind +val jsx_child_expr : Parsetree.expression -> kind + +val binary_expr : Parsetree.expression -> kind +val mod_type_functor_return : Parsetree.module_type -> bool +val mod_type_with_operand : Parsetree.module_type -> bool +val mod_expr_functor_constraint : Parsetree.module_type -> bool + +val braced_expr : Parsetree.expression -> bool +val call_expr : Parsetree.expression -> kind + +val include_mod_expr : Parsetree.module_expr -> bool + +val mod_expr_parens : Parsetree.module_expr -> bool + +val arrow_return_typ_expr : Parsetree.core_type -> bool + +val pattern_record_row_rhs : Parsetree.pattern -> bool + +val expr_record_row_rhs : optional:bool -> Parsetree.expression -> kind diff --git a/compiler/syntax/src/res_parser.ml b/compiler/syntax/src/res_parser.ml new file mode 100644 index 0000000..9daf79d --- /dev/null +++ b/compiler/syntax/src/res_parser.ml @@ -0,0 +1,200 @@ +module Scanner = Res_scanner +module Diagnostics = Res_diagnostics +module Token = Res_token +module Grammar = Res_grammar +module Reporting = Res_reporting + +module Comment = Res_comment + +type mode = ParseForTypeChecker | Default + +type region_status = Report | Silent + +type t = { + mode: mode; + mutable scanner: Scanner.t; + mutable token: Token.t; + mutable start_pos: Lexing.position; + mutable end_pos: Lexing.position; + mutable prev_end_pos: Lexing.position; + mutable breadcrumbs: (Grammar.t * Lexing.position) list; + mutable errors: Reporting.parse_error list; + mutable diagnostics: Diagnostics.t list; + mutable comments: Comment.t list; + mutable regions: region_status ref list; +} + +let err ?start_pos ?end_pos p error = + match p.regions with + | ({contents = Report} as region) :: _ -> + let d = + Diagnostics.make + ~start_pos: + (match start_pos with + | Some pos -> pos + | None -> p.start_pos) + ~end_pos: + (match end_pos with + | Some pos -> pos + | None -> p.end_pos) + error + in + p.diagnostics <- d :: p.diagnostics; + region := Silent + | _ -> () + +let begin_region p = p.regions <- ref Report :: p.regions +let end_region p = + match p.regions with + | [] -> () + | _ :: rest -> p.regions <- rest + +let doc_comment_to_attribute_token comment = + let txt = Comment.txt comment in + let loc = Comment.loc comment in + Token.DocComment (loc, txt) + +let module_comment_to_attribute_token comment = + let txt = Comment.txt comment in + let loc = Comment.loc comment in + Token.ModuleComment (loc, txt) + +(* Advance to the next non-comment token and store any encountered comment + * in the parser's state. Every comment contains the end position of its + * previous token to facilite comment interleaving *) +let rec next ?prev_end_pos p = + if p.token = Eof then assert false; + let prev_end_pos = + match prev_end_pos with + | Some pos -> pos + | None -> p.end_pos + in + let start_pos, end_pos, token = Scanner.scan p.scanner in + match token with + | Comment c -> + if Comment.is_doc_comment c then ( + p.token <- doc_comment_to_attribute_token c; + p.prev_end_pos <- prev_end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos) + else if Comment.is_module_comment c then ( + p.token <- module_comment_to_attribute_token c; + p.prev_end_pos <- prev_end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos) + else ( + Comment.set_prev_tok_end_pos c p.end_pos; + p.comments <- c :: p.comments; + p.prev_end_pos <- p.end_pos; + p.end_pos <- end_pos; + next ~prev_end_pos p) + | _ -> + p.token <- token; + p.prev_end_pos <- prev_end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos + +let next_unsafe p = if p.token <> Eof then next p + +let next_template_literal_token p = + let start_pos, end_pos, token = + Scanner.scan_template_literal_token p.scanner + in + p.token <- token; + p.prev_end_pos <- p.end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos + +let next_regex_token p = + let start_pos, end_pos, token = Scanner.scan_regex p.scanner in + p.token <- token; + p.prev_end_pos <- p.end_pos; + p.start_pos <- start_pos; + p.end_pos <- end_pos + +let check_progress ~prev_end_pos ~result p = + if p.end_pos == prev_end_pos then None else Some result + +let make ?(mode = ParseForTypeChecker) src filename = + let scanner = Scanner.make ~filename src in + let parser_state = + { + mode; + scanner; + token = Token.Semicolon; + start_pos = Lexing.dummy_pos; + prev_end_pos = Lexing.dummy_pos; + end_pos = Lexing.dummy_pos; + breadcrumbs = []; + errors = []; + diagnostics = []; + comments = []; + regions = [ref Report]; + } + in + parser_state.scanner.err <- + (fun ~start_pos ~end_pos error -> + let diagnostic = Diagnostics.make ~start_pos ~end_pos error in + parser_state.diagnostics <- diagnostic :: parser_state.diagnostics); + next parser_state; + parser_state + +let leave_breadcrumb p circumstance = + let crumb = (circumstance, p.start_pos) in + p.breadcrumbs <- crumb :: p.breadcrumbs + +let eat_breadcrumb p = + match p.breadcrumbs with + | [] -> () + | _ :: crumbs -> p.breadcrumbs <- crumbs + +let optional p token = + if p.token = token then + let () = next p in + true + else false + +let expect ?grammar token p = + if p.token = token then next p + else + let error = Diagnostics.expected ?grammar p.prev_end_pos token in + err ~start_pos:p.prev_end_pos p error + +(* Don't use immutable copies here, it trashes certain heuristics + * in the ocaml compiler, resulting in massive slowdowns of the parser *) +let lookahead p callback = + let err = p.scanner.err in + let ch = p.scanner.ch in + let offset = p.scanner.offset in + let offset16 = p.scanner.offset16 in + let line_offset = p.scanner.line_offset in + let lnum = p.scanner.lnum in + let mode = p.scanner.mode in + let token = p.token in + let start_pos = p.start_pos in + let end_pos = p.end_pos in + let prev_end_pos = p.prev_end_pos in + let breadcrumbs = p.breadcrumbs in + let errors = p.errors in + let diagnostics = p.diagnostics in + let comments = p.comments in + + let res = callback p in + + p.scanner.err <- err; + p.scanner.ch <- ch; + p.scanner.offset <- offset; + p.scanner.offset16 <- offset16; + p.scanner.line_offset <- line_offset; + p.scanner.lnum <- lnum; + p.scanner.mode <- mode; + p.token <- token; + p.start_pos <- start_pos; + p.end_pos <- end_pos; + p.prev_end_pos <- prev_end_pos; + p.breadcrumbs <- breadcrumbs; + p.errors <- errors; + p.diagnostics <- diagnostics; + p.comments <- comments; + + res diff --git a/compiler/syntax/src/res_parser.mli b/compiler/syntax/src/res_parser.mli new file mode 100644 index 0000000..978cc18 --- /dev/null +++ b/compiler/syntax/src/res_parser.mli @@ -0,0 +1,48 @@ +module Scanner = Res_scanner +module Token = Res_token +module Grammar = Res_grammar +module Reporting = Res_reporting +module Diagnostics = Res_diagnostics +module Comment = Res_comment + +type mode = ParseForTypeChecker | Default + +type region_status = Report | Silent + +type t = { + mode: mode; + mutable scanner: Scanner.t; + mutable token: Token.t; + mutable start_pos: Lexing.position; + mutable end_pos: Lexing.position; + mutable prev_end_pos: Lexing.position; + mutable breadcrumbs: (Grammar.t * Lexing.position) list; + mutable errors: Reporting.parse_error list; + mutable diagnostics: Diagnostics.t list; + mutable comments: Comment.t list; + mutable regions: region_status ref list; +} + +val make : ?mode:mode -> string -> string -> t + +val expect : ?grammar:Grammar.t -> Token.t -> t -> unit +val optional : t -> Token.t -> bool +val next : ?prev_end_pos:Lexing.position -> t -> unit +val next_unsafe : t -> unit (* Does not assert on Eof, makes no progress *) +val next_template_literal_token : t -> unit +val next_regex_token : t -> unit +val lookahead : t -> (t -> 'a) -> 'a +val err : + ?start_pos:Lexing.position -> + ?end_pos:Lexing.position -> + t -> + Diagnostics.category -> + unit + +val leave_breadcrumb : t -> Grammar.t -> unit +val eat_breadcrumb : t -> unit + +val begin_region : t -> unit +val end_region : t -> unit + +val check_progress : prev_end_pos:Lexing.position -> result:'a -> t -> 'a option diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml new file mode 100644 index 0000000..391e51b --- /dev/null +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -0,0 +1,833 @@ +open Parsetree + +let arrow_type ?(max_arity = max_int) ct = + let has_as_attr attrs = + Ext_list.exists attrs (fun (x, _) -> x.Asttypes.txt = "as") + in + let rec process attrs_before acc typ max_arity = + match typ with + | _ when max_arity < 0 -> (attrs_before, List.rev acc, typ) + | {ptyp_desc = Ptyp_arrow {arity = Some _; arg = {attrs = []}}} + when acc <> [] -> + (attrs_before, List.rev acc, typ) + | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel; attrs = []} as arg; ret}} + -> + process attrs_before (arg :: acc) ret (max_arity - 1) + | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}; ptyp_attributes = _attrs} + as return_type -> + let args = List.rev acc in + (attrs_before, args, return_type) + | { + ptyp_desc = Ptyp_arrow {arg = {lbl = Labelled _ | Optional _} as arg; ret}; + ptyp_attributes = _attrs; + } -> + (* Res_core.parse_es6_arrow_type has a workaround that removed an extra arity for the function if the + argument is a Ptyp_any with @as attribute i.e. ~x: @as(`{prop: value}`) _. + + When this case is encountered we add that missing arity so the arrow is printed properly. + *) + let arity = + match arg.typ with + | {ptyp_desc = Ptyp_any; ptyp_attributes = attrs1} + when has_as_attr attrs1 -> + max_arity + | _ -> max_arity - 1 + in + process attrs_before (arg :: acc) ret arity + | typ -> (attrs_before, List.rev acc, typ) + in + match ct with + | {ptyp_desc = Ptyp_arrow _; ptyp_attributes = attrs1} as typ -> + process attrs1 [] {typ with ptyp_attributes = []} max_arity + | typ -> process [] [] typ max_arity + +let functor_type modtype = + let rec process acc modtype = + match modtype with + | { + pmty_desc = Pmty_functor (lbl, arg_type, return_type); + pmty_attributes = attrs; + } -> + let arg = (attrs, lbl, arg_type) in + process (arg :: acc) return_type + | mod_type -> (List.rev acc, mod_type) + in + process [] modtype + +let has_await_attribute attrs = + List.exists + (function + | {Location.txt = "res.await"}, _ -> true + | _ -> false) + attrs + +let expr_is_await e = + match e.pexp_desc with + | Pexp_await _ -> true + | _ -> false + +let has_inline_record_definition_attribute attrs = + List.exists + (function + | {Location.txt = "res.inlineRecordDefinition"}, _ -> true + | _ -> false) + attrs + +let has_res_pat_variant_spread_attribute attrs = + List.exists + (function + | {Location.txt = "res.patVariantSpread"}, _ -> true + | _ -> false) + attrs + +let has_dict_pattern_attribute attrs = + attrs + |> List.find_opt (fun (({txt}, _) : Parsetree.attribute) -> + txt = "res.dictPattern") + |> Option.is_some + +let collect_array_expressions expr = + match expr.pexp_desc with + | Pexp_array exprs -> (exprs, None) + | _ -> ([], Some expr) + +let collect_list_expressions expr = + let rec collect acc expr = + match expr.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) + | Pexp_construct + ( {txt = Longident.Lident "::"}, + Some {pexp_desc = Pexp_tuple (hd :: [tail])} ) -> + collect (hd :: acc) tail + | _ -> (List.rev acc, Some expr) + in + collect [] expr + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +let rewrite_underscore_apply expr = + match expr.pexp_desc with + | Pexp_fun + { + arg_label = Nolabel; + default = None; + lhs = {ppat_desc = Ppat_var {txt = "__x"}}; + rhs = {pexp_desc = Pexp_apply {funct = call_expr; args}} as e; + } -> + let new_args = + List.map + (fun arg -> + match arg with + | ( lbl, + ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} + as arg_expr) ) -> + ( lbl, + { + arg_expr with + pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; + } ) + | arg -> arg) + args + in + { + e with + pexp_desc = + Pexp_apply + { + funct = call_expr; + args = new_args; + partial = false; + transformed_jsx = false; + }; + } + | _ -> expr + +(* For pipe RHS: (__x) => f(__x, a, b) -----> f(a, b) + Note: Ppat_var "__x" and Pexp_ident "__x" represent `_` placeholders in user code. + Omits the first __x argument only if it's the sole occurrence. + If multiple __x exist (e.g., f(__x, __x, b)), keeps all to preserve semantics. *) +let rewrite_underscore_apply_in_pipe expr = + let is_underscore_arg = function + | _, {pexp_desc = Pexp_ident {txt = Longident.Lident "__x"}} -> true + | _ -> false + in + let convert_underscore_to_placeholder arg = + match arg with + | ( lbl, + ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} as + arg_expr) ) -> + ( lbl, + { + arg_expr with + pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; + } ) + | arg -> arg + in + match expr.pexp_desc with + | Pexp_fun + { + arg_label = Nolabel; + default = None; + lhs = {ppat_desc = Ppat_var {txt = "__x"}}; + rhs = {pexp_desc = Pexp_apply {funct; args}} as e; + } -> ( + match args with + | first_arg :: rest_args when is_underscore_arg first_arg -> + if List.exists is_underscore_arg rest_args then + (* Multiple __x - keep all to preserve semantics *) + rewrite_underscore_apply expr + else + (* Single __x in first position - safe to omit *) + { + e with + pexp_desc = + Pexp_apply + { + funct; + args = List.map convert_underscore_to_placeholder rest_args; + partial = false; + transformed_jsx = false; + }; + } + | _ -> rewrite_underscore_apply expr) + | _ -> expr + +type fun_param_kind = + | Parameter of { + attrs: Parsetree.attributes; + lbl: Asttypes.arg_label; + default_expr: Parsetree.expression option; + pat: Parsetree.pattern; + } + | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} + +let fun_expr expr_ = + let async = Ast_async.dig_async_payload_from_function expr_ in + let rec collect_params ~n_fun ~params expr = + match expr with + | { + pexp_desc = + Pexp_fun + { + arg_label = lbl; + default = default_expr; + lhs = pattern; + rhs = return_expr; + arity; + }; + pexp_attributes = attrs; + } + when arity = None || n_fun = 0 -> + let parameter = Parameter {attrs; lbl; default_expr; pat = pattern} in + collect_params ~n_fun:(n_fun + 1) ~params:(parameter :: params) + return_expr + | _ -> (async, List.rev params, expr) + in + (* Turns (type t, type u, type z) into "type t u z" *) + let rec collect_new_types acc return_expr = + match return_expr with + | {pexp_desc = Pexp_newtype (string_loc, return_expr)} -> + collect_new_types (string_loc :: acc) return_expr + | return_expr -> (List.rev acc, return_expr) + in + match expr_ with + | {pexp_desc = Pexp_newtype (string_loc, rest)} -> + let string_locs, return_expr = collect_new_types [string_loc] rest in + let param = NewTypes {attrs = []; locs = string_locs} in + collect_params ~n_fun:0 ~params:[param] return_expr + | _ -> collect_params ~n_fun:0 ~params:[] {expr_ with pexp_attributes = []} + +let process_braces_attr expr = + match expr.pexp_attributes with + | (({txt = "res.braces" | "ns.braces"}, _) as attr) :: attrs -> + (Some attr, {expr with pexp_attributes = attrs}) + | _ -> (None, expr) + +let filter_parsing_attrs attrs = + List.filter + (fun attr -> + match attr with + | ( { + Location.txt = + ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" + | "res.await" | "res.template" | "res.taggedTemplate" + | "res.patVariantSpread" | "res.dictPattern" + | "res.inlineRecordDefinition" ); + }, + _ ) -> + false + | _ -> true) + attrs + +let is_block_expr expr = + match expr.pexp_desc with + | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ + | Pexp_sequence _ -> + true + | _ -> false + +let is_braced_expr expr = + match process_braces_attr expr with + | Some _, _ -> true + | _ -> false + +let is_multiline_text txt = + let len = String.length txt in + let rec check i = + if i >= len then false + else + let c = String.unsafe_get txt i in + match c with + | '\010' | '\013' -> true + | '\\' -> if i + 2 = len then false else check (i + 2) + | _ -> check (i + 1) + in + check 0 + +let is_huggable_expression expr = + match expr.pexp_desc with + | Pexp_array _ | Pexp_tuple _ + | Pexp_constant (Pconst_string (_, Some _)) + | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) + | Pexp_extension ({txt = "obj"}, _) + | Pexp_record _ -> + true + | _ when is_block_expr expr -> true + | _ when is_braced_expr expr -> true + | Pexp_constant (Pconst_string (txt, None)) when is_multiline_text txt -> true + | _ -> false + +let is_huggable_rhs expr = + match expr.pexp_desc with + | Pexp_array _ | Pexp_tuple _ + | Pexp_extension ({txt = "obj"}, _) + | Pexp_record _ -> + true + | _ when is_braced_expr expr -> true + | _ -> false + +let is_huggable_pattern pattern = + match pattern.ppat_desc with + | Ppat_array _ | Ppat_tuple _ | Ppat_record _ | Ppat_variant _ + | Ppat_construct _ -> + true + | _ -> false + +let operator_precedence operator = + match operator with + | ":=" -> 1 + | "||" -> 2 + | "&&" -> 3 + | "|||" -> 4 + | "^^^" -> 5 + | "&&&" -> 6 + | "==" | "===" | "<" | ">" | "!=" | "<>" | "!==" | "<=" | ">=" -> 7 + | "<<" | ">>" | ">>>" -> 8 + | "+" | "+." | "-" | "-." | "++" -> 9 + | "*" | "*." | "/" | "/." | "%" -> 10 + | "**" -> 11 + | "#" | "##" | "->" -> 12 + | _ -> 0 + +let is_unary_operator operator = + match operator with + | "~+" | "~+." | "~-" | "~-." | "~~~" | "not" -> true + | _ -> false + +let is_unary_expression expr = + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}; + args = [(Nolabel, _arg)]; + } + when is_unary_operator operator -> + true + | _ -> false + +let is_binary_operator operator = + match operator with + | ":=" | "||" | "&&" | "==" | "===" | "<" | ">" | "!=" | "!==" | "<=" | ">=" + | "+" | "+." | "-" | "-." | "++" | "*" | "*." | "/" | "/." | "**" | "->" + | "<>" | "%" | "|||" | "^^^" | "&&&" | "<<" | ">>" | ">>>" -> + true + | _ -> false + +let not_ghost_operator operator (loc : Location.t) = + is_binary_operator operator && not (loc.loc_ghost && operator = "++") + +let is_binary_expression expr = + match expr.pexp_desc with + | Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident {txt = Longident.Lident operator; loc = operator_loc}; + }; + args = [(Nolabel, _operand1); (Nolabel, _operand2)]; + } + when not_ghost_operator operator operator_loc -> + true + | _ -> false + +let is_equality_operator operator = + match operator with + | "==" | "===" | "!=" | "!==" -> true + | _ -> false + +let is_rhs_binary_operator operator = + match operator with + | "**" -> true + | _ -> false + +let flattenable_operators parent_operator child_operator = + let prec_parent = operator_precedence parent_operator in + let prec_child = operator_precedence child_operator in + if prec_parent == prec_child then + not + (is_equality_operator parent_operator + && is_equality_operator child_operator) + else false + +let rec has_if_let_attribute attrs = + match attrs with + | [] -> false + | ({Location.txt = "res.iflet"}, _) :: _ -> true + | _ :: attrs -> has_if_let_attribute attrs + +let is_if_let_expr expr = + match expr with + | {pexp_attributes = attrs; pexp_desc = Pexp_match _} + when has_if_let_attribute attrs -> + true + | _ -> false + +let has_attributes attrs = + List.exists + (fun attr -> + match attr with + | ( { + Location.txt = + ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" + | "res.await" | "res.template" | "res.inlineRecordDefinition" ); + }, + _ ) -> + false + (* Remove the fragile pattern warning for iflet expressions *) + | ( {Location.txt = "warning"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_string ("-4", None))}, _); + }; + ] ) -> + not (has_if_let_attribute attrs) + | _ -> true) + attrs + +let is_array_access expr = + match expr.pexp_desc with + | Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident + {txt = Longident.Ldot (Longident.Lident "Array", "get")}; + }; + args = [(Nolabel, _parentExpr); (Nolabel, _memberExpr)]; + } -> + true + | _ -> false + +type if_condition_kind = + | If of Parsetree.expression + | IfLet of Parsetree.pattern * Parsetree.expression + +let collect_if_expressions expr = + let rec collect acc expr = + let expr_loc = expr.pexp_loc in + match expr.pexp_desc with + | Pexp_ifthenelse (if_expr, then_expr, Some else_expr) -> + collect ((expr_loc, If if_expr, then_expr) :: acc) else_expr + | Pexp_ifthenelse (if_expr, then_expr, (None as else_expr)) -> + let ifs = List.rev ((expr_loc, If if_expr, then_expr) :: acc) in + (ifs, else_expr) + | Pexp_match + ( condition, + [ + {pc_lhs = pattern; pc_guard = None; pc_rhs = then_expr}; + { + pc_rhs = + {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}; + }; + ] ) + when is_if_let_expr expr -> + let ifs = + List.rev ((expr_loc, IfLet (pattern, condition), then_expr) :: acc) + in + (ifs, None) + | Pexp_match + ( condition, + [ + {pc_lhs = pattern; pc_guard = None; pc_rhs = then_expr}; + {pc_rhs = else_expr}; + ] ) + when is_if_let_expr expr -> + collect + ((expr_loc, IfLet (pattern, condition), then_expr) :: acc) + else_expr + | _ -> (List.rev acc, Some expr) + in + collect [] expr + +let rec has_ternary_attribute attrs = + match attrs with + | [] -> false + | ({Location.txt = "res.ternary"}, _) :: _ -> true + | _ :: attrs -> has_ternary_attribute attrs + +let is_ternary_expr expr = + match expr with + | {pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _} + when has_ternary_attribute attrs -> + true + | _ -> false + +let collect_ternary_parts expr = + let rec collect acc expr = + match expr with + | { + pexp_attributes = attrs; + pexp_desc = Pexp_ifthenelse (condition, consequent, Some alternate); + } + when has_ternary_attribute attrs -> + collect ((condition, consequent) :: acc) alternate + | alternate -> (List.rev acc, alternate) + in + collect [] expr + +let parameters_should_hug parameters = + match parameters with + | [Parameter {attrs = []; lbl = Nolabel; default_expr = None; pat}] + when is_huggable_pattern pat -> + true + | _ -> false + +let filter_ternary_attributes attrs = + List.filter + (fun attr -> + match attr with + | {Location.txt = "res.ternary"}, _ -> false + | _ -> true) + attrs + +let filter_fragile_match_attributes attrs = + List.filter + (fun attr -> + match attr with + | ( {Location.txt = "warning"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_string ("-4", _))}, _); + }; + ] ) -> + false + | _ -> true) + attrs + +let should_indent_binary_expr expr = + let same_precedence_sub_expression operator sub_expression = + match sub_expression with + | { + pexp_desc = + Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident sub_operator}}; + args = [(Nolabel, _lhs); (Nolabel, _rhs)]; + }; + } + when is_binary_operator sub_operator -> + flattenable_operators operator sub_operator + | _ -> true + in + match expr with + | { + pexp_desc = + Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}; + args = [(Nolabel, lhs); (Nolabel, _rhs)]; + }; + } + when is_binary_operator operator -> + is_equality_operator operator + || (not (same_precedence_sub_expression operator lhs)) + || operator = ":=" + | _ -> false + +let should_inline_rhs_binary_expr rhs = + match rhs.pexp_desc with + | Parsetree.Pexp_constant _ | Pexp_let _ | Pexp_letmodule _ + | Pexp_letexception _ | Pexp_sequence _ | Pexp_open _ | Pexp_ifthenelse _ + | Pexp_for _ | Pexp_while _ | Pexp_try _ | Pexp_array _ | Pexp_record _ -> + true + | _ -> false + +let is_printable_attribute attr = + match attr with + | ( { + Location.txt = + ( "res.iflet" | "res.braces" | "ns.braces" | "JSX" | "res.await" + | "res.template" | "res.taggedTemplate" | "res.ternary" + | "res.inlineRecordDefinition" ); + }, + _ ) -> + false + | _ -> true + +let has_printable_attributes attrs = List.exists is_printable_attribute attrs + +let filter_printable_attributes attrs = List.filter is_printable_attribute attrs + +let partition_printable_attributes attrs = + List.partition is_printable_attribute attrs + +let partition_doc_comment_attributes attrs = + List.partition + (fun ((id, payload) : Parsetree.attribute) -> + match (id, payload) with + | ( {txt = "res.doc"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_string (_, _))}, _); + }; + ] ) -> + true + | _ -> false) + attrs + +let is_fun_newtype expr = + match expr.pexp_desc with + | Pexp_fun _ | Pexp_newtype _ -> true + | _ -> false + +let requires_special_callback_printing_last_arg args = + let rec loop args = + match args with + | [] -> false + | [(_, expr)] when is_fun_newtype expr -> true + | (_, expr) :: _ when is_fun_newtype expr -> false + | _ :: rest -> loop rest + in + loop args + +let requires_special_callback_printing_first_arg args = + let rec loop args = + match args with + | [] -> true + | (_, expr) :: _ when is_fun_newtype expr -> false + | _ :: rest -> loop rest + in + match args with + | [(_, expr)] when is_fun_newtype expr -> false + | (_, expr) :: rest when is_fun_newtype expr -> loop rest + | _ -> false + +let mod_expr_apply mod_expr = + let rec loop acc mod_expr = + match mod_expr with + | {pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next + | _ -> (acc, mod_expr) + in + loop [] mod_expr + +let mod_expr_functor mod_expr = + let rec loop acc mod_expr = + match mod_expr with + | { + pmod_desc = Pmod_functor (lbl, mod_type, return_mod_expr); + pmod_attributes = attrs; + } -> + let param = (attrs, lbl, mod_type) in + loop (param :: acc) return_mod_expr + | return_mod_expr -> (List.rev acc, return_mod_expr) + in + loop [] mod_expr + +let rec collect_patterns_from_list_construct acc pattern = + let open Parsetree in + match pattern.ppat_desc with + | Ppat_construct + ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) + -> + collect_patterns_from_list_construct (pat :: acc) rest + | _ -> (List.rev acc, pattern) + +let has_template_literal_attr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.template"}, _ -> true + | _ -> false) + attrs + +let has_tagged_template_literal_attr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.taggedTemplate"}, _ -> true + | _ -> false) + attrs + +let is_template_literal expr = + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "++"}}; + args = [(Nolabel, _); (Nolabel, _)]; + } + when has_template_literal_attr expr.pexp_attributes -> + true + | Pexp_constant (Pconst_string (_, Some "")) -> true + | Pexp_constant _ when has_template_literal_attr expr.pexp_attributes -> true + | _ -> false + +let is_tagged_template_literal expr = + match expr with + | {pexp_desc = Pexp_apply _; pexp_attributes = attrs} -> + has_tagged_template_literal_attr attrs + | _ -> false + +let has_spread_attr attrs = + List.exists + (fun attr -> + match attr with + | {Location.txt = "res.spread"}, _ -> true + | _ -> false) + attrs + +let is_spread_belt_list_concat expr = + match expr.pexp_desc with + | Pexp_ident + { + txt = + Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); + } -> + has_spread_attr expr.pexp_attributes + | _ -> false + +let is_spread_belt_array_concat expr = + match expr.pexp_desc with + | Pexp_ident + { + txt = + Longident.Ldot + (Longident.Ldot (Longident.Lident "Belt", "Array"), "concatMany"); + } -> + has_spread_attr expr.pexp_attributes + | _ -> false + +(* Blue | Red | Green -> [Blue; Red; Green] *) +let collect_or_pattern_chain pat = + let rec loop pattern chain = + match pattern.ppat_desc with + | Ppat_or (left, right) -> loop left (right :: chain) + | _ -> pattern :: chain + in + loop pat [] + +let is_single_pipe_expr expr = + (* handles: + * x + * ->Js.Dict.get("wm-property") + * ->Option.flatMap(Js.Json.decodeString) + * ->Option.flatMap(x => + * switch x { + * | "like-of" => Some(#like) + * | "repost-of" => Some(#repost) + * | _ => None + * } + * ) + *) + let is_pipe_expr expr = + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "->"}}; + args = [(Nolabel, _operand1); (Nolabel, _operand2)]; + } -> + true + | _ -> false + in + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "->"}}; + args = [(Nolabel, operand1); (Nolabel, _operand2)]; + } + when not (is_pipe_expr operand1) -> + true + | _ -> false + +let is_underscore_apply_sugar expr = + match expr.pexp_desc with + | Pexp_fun + { + arg_label = Nolabel; + default = None; + lhs = {ppat_desc = Ppat_var {txt = "__x"}}; + rhs = {pexp_desc = Pexp_apply _}; + } -> + true + | _ -> false + +let is_rewritten_underscore_apply_sugar expr = + match expr.pexp_desc with + | Pexp_ident {txt = Longident.Lident "_"} -> true + | _ -> false + +let is_tuple_array (expr : Parsetree.expression) = + let is_plain_tuple (expr : Parsetree.expression) = + match expr with + | {pexp_desc = Pexp_tuple _} -> true + | _ -> false + in + match expr with + | {pexp_desc = Pexp_array items} -> List.for_all is_plain_tuple items + | _ -> false + +let get_jsx_prop_loc = function + | Parsetree.JSXPropPunning (_, name) -> name.loc + | Parsetree.JSXPropValue (name, _, value) -> + {name.loc with loc_end = value.pexp_loc.loc_end} + | Parsetree.JSXPropSpreading (loc, _) -> loc + +let container_element_closing_tag_loc + (tag : Parsetree.jsx_closing_container_tag) = + { + tag.jsx_closing_container_tag_name.loc with + loc_start = tag.jsx_closing_container_tag_start; + loc_end = tag.jsx_closing_container_tag_end; + } + +(** returns the location of the /> token in a unary element *) +let unary_element_closing_token (expression_loc : Warnings.loc) = + { + expression_loc with + loc_start = + { + expression_loc.loc_end with + pos_cnum = expression_loc.loc_end.pos_cnum - 2; + pos_bol = expression_loc.loc_end.pos_bol - 2; + }; + } diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli new file mode 100644 index 0000000..5fcfb68 --- /dev/null +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -0,0 +1,168 @@ +(* Restructures a nested tree of arrow types into its args & returnType + * The parsetree contains: a => b => c => d, for printing purposes + * we restructure the tree into (a, b, c) and its returnType d *) +val arrow_type : + ?max_arity:int -> + Parsetree.core_type -> + Parsetree.attributes * Parsetree.arg list * Parsetree.core_type + +val functor_type : + Parsetree.module_type -> + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) + list + * Parsetree.module_type + +val expr_is_await : Parsetree.expression -> bool +val has_await_attribute : Parsetree.attributes -> bool +val has_inline_record_definition_attribute : Parsetree.attributes -> bool +val has_res_pat_variant_spread_attribute : Parsetree.attributes -> bool +val has_dict_pattern_attribute : Parsetree.attributes -> bool + +type if_condition_kind = + | If of Parsetree.expression + | IfLet of Parsetree.pattern * Parsetree.expression + +(* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } + * The purpose of this function is to flatten nested ifs into one sequence. + * Basically compute: ([if, else if, else if, else if], else) *) +val collect_if_expressions : + Parsetree.expression -> + (Location.t * if_condition_kind * Parsetree.expression) list + * Parsetree.expression option + +val collect_array_expressions : + Parsetree.expression -> + Parsetree.expression list * Parsetree.expression option + +val collect_list_expressions : + Parsetree.expression -> + Parsetree.expression list * Parsetree.expression option + +type fun_param_kind = + | Parameter of { + attrs: Parsetree.attributes; + lbl: Asttypes.arg_label; + default_expr: Parsetree.expression option; + pat: Parsetree.pattern; + } + | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} + +val fun_expr : + Parsetree.expression -> bool * fun_param_kind list * Parsetree.expression + +(* example: + * `makeCoordinate({ + * x: 1, + * y: 2, + * })` + * Notice howe `({` and `})` "hug" or stick to each other *) +val is_huggable_expression : Parsetree.expression -> bool + +val is_huggable_pattern : Parsetree.pattern -> bool + +val is_huggable_rhs : Parsetree.expression -> bool + +val operator_precedence : string -> int + +val not_ghost_operator : string -> Location.t -> bool +val is_unary_expression : Parsetree.expression -> bool +val is_binary_operator : string -> bool +val is_binary_expression : Parsetree.expression -> bool +val is_rhs_binary_operator : string -> bool +val is_equality_operator : string -> bool + +val flattenable_operators : string -> string -> bool + +val has_attributes : Parsetree.attributes -> bool + +val is_array_access : Parsetree.expression -> bool +val is_ternary_expr : Parsetree.expression -> bool +val is_if_let_expr : Parsetree.expression -> bool + +val collect_ternary_parts : + Parsetree.expression -> + (Parsetree.expression * Parsetree.expression) list * Parsetree.expression + +val parameters_should_hug : fun_param_kind list -> bool + +val filter_ternary_attributes : Parsetree.attributes -> Parsetree.attributes +val filter_fragile_match_attributes : + Parsetree.attributes -> Parsetree.attributes + +val should_indent_binary_expr : Parsetree.expression -> bool +val should_inline_rhs_binary_expr : Parsetree.expression -> bool +val has_printable_attributes : Parsetree.attributes -> bool +val filter_printable_attributes : Parsetree.attributes -> Parsetree.attributes +val partition_printable_attributes : + Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes +val partition_doc_comment_attributes : + Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes + +val requires_special_callback_printing_last_arg : + (Asttypes.arg_label * Parsetree.expression) list -> bool +val requires_special_callback_printing_first_arg : + (Asttypes.arg_label * Parsetree.expression) list -> bool + +val mod_expr_apply : + Parsetree.module_expr -> Parsetree.module_expr list * Parsetree.module_expr + +(* Collection of utilities to view the ast in a more a convenient form, + * allowing for easier processing. + * Example: given a ptyp_arrow type, what are its arguments and what is the + * returnType? *) + +val mod_expr_functor : + Parsetree.module_expr -> + (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) + list + * Parsetree.module_expr + +val collect_patterns_from_list_construct : + Parsetree.pattern list -> + Parsetree.pattern -> + Parsetree.pattern list * Parsetree.pattern + +val is_block_expr : Parsetree.expression -> bool + +val is_template_literal : Parsetree.expression -> bool +val is_tagged_template_literal : Parsetree.expression -> bool +val has_template_literal_attr : Parsetree.attributes -> bool + +val is_spread_belt_list_concat : Parsetree.expression -> bool + +val is_spread_belt_array_concat : Parsetree.expression -> bool + +val collect_or_pattern_chain : Parsetree.pattern -> Parsetree.pattern list + +val process_braces_attr : + Parsetree.expression -> Parsetree.attribute option * Parsetree.expression + +val filter_parsing_attrs : Parsetree.attributes -> Parsetree.attributes + +val is_braced_expr : Parsetree.expression -> bool + +val is_single_pipe_expr : Parsetree.expression -> bool + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +val rewrite_underscore_apply : Parsetree.expression -> Parsetree.expression + +val rewrite_underscore_apply_in_pipe : + Parsetree.expression -> Parsetree.expression + +(* (__x) => f(a, __x, c) -----> f(a, _, c) *) +val is_underscore_apply_sugar : Parsetree.expression -> bool + +val has_if_let_attribute : Parsetree.attributes -> bool + +val is_rewritten_underscore_apply_sugar : Parsetree.expression -> bool + +val is_fun_newtype : Parsetree.expression -> bool + +val is_tuple_array : Parsetree.expression -> bool + +val get_jsx_prop_loc : Parsetree.jsx_prop -> Warnings.loc + +val container_element_closing_tag_loc : + Parsetree.jsx_closing_container_tag -> Warnings.loc + +val unary_element_closing_token : Warnings.loc -> Warnings.loc diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml new file mode 100644 index 0000000..2010d23 --- /dev/null +++ b/compiler/syntax/src/res_printer.ml @@ -0,0 +1,6138 @@ +module Doc = Res_doc +module CommentTable = Res_comments_table +module Comment = Res_comment +module Token = Res_token +module Parens = Res_parens +module ParsetreeViewer = Res_parsetree_viewer + +let default_print_width = 100 + +type callback_style = + (* regular arrow function, example: `let f = x => x + 1` *) + | NoCallback + (* `Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument))` *) + | FitsOnOneLine + (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => + * MyModuleBlah.toList(argument) + * ) + *) + | ArgumentsFitOnOneLine + +let add_parens doc = + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent (Doc.concat [Doc.soft_line; doc]); + Doc.soft_line; + Doc.rparen; + ]) + +let add_braces doc = + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent (Doc.concat [Doc.soft_line; doc]); + Doc.soft_line; + Doc.rbrace; + ]) + +let add_async doc = Doc.concat [Doc.text "async "; doc] + +let has_inline_type_definitions type_declarations = + type_declarations + |> List.find_opt (fun (td : Parsetree.type_declaration) -> + Res_parsetree_viewer.has_inline_record_definition_attribute + td.ptype_attributes) + |> Option.is_some + +let get_first_leading_comment tbl loc = + match Hashtbl.find tbl.CommentTable.leading loc with + | comment :: _ -> Some comment + | [] -> None + | exception Not_found -> None + +(* Checks if `loc` has a leading line comment, i.e. `// comment above`*) +let has_leading_line_comment tbl loc = + match get_first_leading_comment tbl loc with + | Some comment -> Comment.is_single_line_comment comment + | None -> false + +let get_leading_line_comment_count tbl loc = + match Hashtbl.find_opt tbl.CommentTable.leading loc with + | Some comments -> + List.filter Comment.is_single_line_comment comments |> List.length + | None -> 0 + +let has_trailing_single_line_comment tbl loc = + match Hashtbl.find_opt tbl.CommentTable.trailing loc with + | Some (comment :: _) -> Comment.is_single_line_comment comment + | _ -> false + +let has_comment_below tbl loc = + match Hashtbl.find tbl.CommentTable.trailing loc with + | comment :: _ -> + let comment_loc = Comment.loc comment in + comment_loc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum + | [] -> false + | exception Not_found -> false + +let has_comments_inside tbl loc = + match Hashtbl.find_opt tbl.CommentTable.inside loc with + | None -> false + | _ -> true + +let has_trailing_comments tbl loc = + match Hashtbl.find_opt tbl.CommentTable.trailing loc with + | None -> false + | _ -> true + +let has_leading_comments tbl loc = + match Hashtbl.find_opt tbl.CommentTable.leading loc with + | None -> false + | _ -> true + +let print_multiline_comment_content txt = + (* Turns + * |* first line + * * second line + * * third line *| + * Into + * |* first line + * * second line + * * third line *| + * + * What makes a comment suitable for this kind of indentation? + * -> multiple lines + every line starts with a star + *) + let rec indent_stars lines acc = + match lines with + | [] -> Doc.nil + | [last_line] -> + let line = String.trim last_line in + let doc = Doc.text (" " ^ line) in + let trailing_space = if line = "" then Doc.nil else Doc.space in + List.rev (trailing_space :: doc :: acc) |> Doc.concat + | line :: lines -> + let line = String.trim line in + if line != "" && String.unsafe_get line 0 == '*' then + let doc = Doc.text (" " ^ line) in + indent_stars lines (Doc.hard_line :: doc :: acc) + else + let trailing_space = + let len = String.length txt in + if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space + else Doc.nil + in + let content = Comment.trim_spaces txt in + Doc.concat [Doc.text content; trailing_space] + in + let lines = String.split_on_char '\n' txt in + match lines with + | [] -> Doc.text "/* */" + | [line] -> + Doc.concat + [Doc.text "/* "; Doc.text (Comment.trim_spaces line); Doc.text " */"] + | first :: rest -> + let first_line = Comment.trim_spaces first in + Doc.concat + [ + Doc.text "/*"; + (match first_line with + | "" | "*" -> Doc.nil + | _ -> Doc.space); + indent_stars rest [Doc.hard_line; Doc.text first_line]; + Doc.text "*/"; + ] + +let print_trailing_comment (prev_loc : Location.t) (node_loc : Location.t) + comment = + let single_line = Comment.is_single_line_comment comment in + let content = + let txt = Comment.txt comment in + if single_line then Doc.text ("//" ^ txt) + else print_multiline_comment_content txt + in + let diff = + let cmt_start = (Comment.loc comment).loc_start in + cmt_start.pos_lnum - prev_loc.loc_end.pos_lnum + in + let is_below = + (Comment.loc comment).loc_start.pos_lnum > node_loc.loc_end.pos_lnum + in + if diff > 0 || is_below then + Doc.concat + [ + Doc.break_parent; + Doc.line_suffix + (Doc.concat + [ + Doc.hard_line; + (if diff > 1 then Doc.hard_line else Doc.nil); + content; + ]); + ] + else if not single_line then Doc.concat [Doc.space; content] + else Doc.line_suffix (Doc.concat [Doc.space; content]) + +let print_leading_comment ?next_comment comment = + let single_line = Comment.is_single_line_comment comment in + let content = + let txt = Comment.txt comment in + if single_line then Doc.text ("//" ^ txt) + else print_multiline_comment_content txt + in + let separator = + Doc.concat + [ + (if single_line then Doc.concat [Doc.hard_line; Doc.break_parent] + else Doc.nil); + (match next_comment with + | Some next -> + let next_loc = Comment.loc next in + let curr_loc = Comment.loc comment in + let diff = + next_loc.Location.loc_start.pos_lnum + - curr_loc.Location.loc_end.pos_lnum + in + let next_single_line = Comment.is_single_line_comment next in + if single_line && next_single_line then + if diff > 1 then Doc.hard_line else Doc.nil + else if single_line && not next_single_line then + if diff > 1 then Doc.hard_line else Doc.nil + else if diff > 1 then Doc.concat [Doc.hard_line; Doc.hard_line] + else if diff == 1 then Doc.hard_line + else Doc.space + | None -> Doc.nil); + ] + in + Doc.concat [content; separator] + +(* This function is used for printing comments inside an empty block *) +let print_comments_inside cmt_tbl loc = + let print_comment comment = + let single_line = Comment.is_single_line_comment comment in + let txt = Comment.txt comment in + if single_line then Doc.text ("//" ^ txt) + else print_multiline_comment_content txt + in + let force_break = + loc.Location.loc_start.pos_lnum <> loc.Location.loc_end.pos_lnum + in + let rec loop acc comments = + match comments with + | [] -> Doc.nil + | [comment] -> + let cmt_doc = print_comment comment in + let cmts_doc = Doc.concat (Doc.soft_line :: List.rev (cmt_doc :: acc)) in + let doc = + Doc.breakable_group ~force_break + (Doc.concat + [Doc.if_breaks (Doc.indent cmts_doc) cmts_doc; Doc.soft_line]) + in + doc + | comment :: rest -> + let cmt_doc = Doc.concat [print_comment comment; Doc.line] in + loop (cmt_doc :: acc) rest + in + match Hashtbl.find cmt_tbl.CommentTable.inside loc with + | exception Not_found -> Doc.nil + | comments -> + Hashtbl.remove cmt_tbl.inside loc; + loop [] comments + +(* This function is used for printing comments inside an empty file *) +let print_comments_inside_file cmt_tbl = + let rec loop acc comments = + match comments with + | [] -> Doc.nil + | [comment] -> + let cmt_doc = print_leading_comment comment in + let doc = + Doc.group (Doc.concat [Doc.concat (List.rev (cmt_doc :: acc))]) + in + doc + | comment :: (next_comment :: _comments as rest) -> + let cmt_doc = print_leading_comment ~next_comment comment in + loop (cmt_doc :: acc) rest + in + match Hashtbl.find cmt_tbl.CommentTable.inside Location.none with + | exception Not_found -> Doc.nil + | comments -> + Hashtbl.remove cmt_tbl.inside Location.none; + Doc.group (loop [] comments) + +let print_leading_comments node tbl loc = + let rec loop acc comments = + match comments with + | [] -> node + | [comment] -> + let cmt_doc = print_leading_comment comment in + let diff = + loc.Location.loc_start.pos_lnum + - (Comment.loc comment).Location.loc_end.pos_lnum + in + let separator = + if Comment.is_single_line_comment comment then + if diff > 1 then Doc.hard_line else Doc.nil + else if diff == 0 then Doc.space + else if diff > 1 then Doc.concat [Doc.hard_line; Doc.hard_line] + else Doc.hard_line + in + let doc = + Doc.group + (Doc.concat [Doc.concat (List.rev (cmt_doc :: acc)); separator; node]) + in + doc + | comment :: (next_comment :: _comments as rest) -> + let cmt_doc = print_leading_comment ~next_comment comment in + loop (cmt_doc :: acc) rest + in + match Hashtbl.find tbl loc with + | exception Not_found -> node + | comments -> + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + loop [] comments + +let print_trailing_comments node tbl loc = + let rec loop prev acc comments = + match comments with + | [] -> Doc.concat (List.rev acc) + | comment :: comments -> + let cmt_doc = print_trailing_comment prev loc comment in + loop (Comment.loc comment) (cmt_doc :: acc) comments + in + match Hashtbl.find tbl loc with + | exception Not_found -> node + | [] -> node + | _first :: _ as comments -> + (* Remove comments from tbl: Some ast nodes have the same location. + * We only want to print comments once *) + Hashtbl.remove tbl loc; + let cmts_doc = loop loc [] comments in + Doc.concat [node; cmts_doc] + +let print_comments doc (tbl : CommentTable.t) loc = + let doc_with_leading_comments = print_leading_comments doc tbl.leading loc in + print_trailing_comments doc_with_leading_comments tbl.trailing loc + +let print_list ~get_loc ~nodes ~print ?(force_break = false) t = + let rec loop (prev_loc : Location.t) acc nodes = + match nodes with + | [] -> (prev_loc, Doc.concat (List.rev acc)) + | node :: nodes -> + let loc = get_loc node in + let start_pos = + match get_first_leading_comment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if start_pos.pos_lnum - prev_loc.loc_end.pos_lnum > 1 then + Doc.concat [Doc.hard_line; Doc.hard_line] + else Doc.hard_line + in + let doc = print_comments (print node t) t loc in + loop loc (doc :: sep :: acc) nodes + in + match nodes with + | [] -> Doc.nil + | node :: nodes -> + let first_loc = get_loc node in + let doc = print_comments (print node t) t first_loc in + let last_loc, docs = loop first_loc [doc] nodes in + let force_break = + force_break || first_loc.loc_start.pos_lnum != last_loc.loc_end.pos_lnum + in + Doc.breakable_group ~force_break docs + +let print_listi ~get_loc ~nodes ~print ?(ignore_empty_lines = false) + ?(force_break = false) t = + let rec loop i (prev_loc : Location.t) acc nodes = + match nodes with + | [] -> (prev_loc, Doc.concat (List.rev acc)) + | node :: nodes -> + let loc = get_loc node in + let start_pos = + match get_first_leading_comment t loc with + | None -> loc.loc_start + | Some comment -> (Comment.loc comment).loc_start + in + let sep = + if + start_pos.pos_lnum - prev_loc.loc_end.pos_lnum > 1 + && not ignore_empty_lines + then Doc.concat [Doc.hard_line; Doc.hard_line] + else Doc.line + in + let doc = print_comments (print node t i) t loc in + loop (i + 1) loc (doc :: sep :: acc) nodes + in + match nodes with + | [] -> Doc.nil + | node :: nodes -> + let first_loc = get_loc node in + let doc = print_comments (print node t 0) t first_loc in + let last_loc, docs = loop 1 first_loc [doc] nodes in + let force_break = + force_break || first_loc.loc_start.pos_lnum != last_loc.loc_end.pos_lnum + in + Doc.breakable_group ~force_break docs + +let rec print_longident_aux accu = function + | Longident.Lident s -> Doc.text s :: accu + | Ldot (lid, s) -> print_longident_aux (Doc.text s :: accu) lid + | Lapply (lid1, lid2) -> + let d1 = Doc.join ~sep:Doc.dot (print_longident_aux [] lid1) in + let d2 = Doc.join ~sep:Doc.dot (print_longident_aux [] lid2) in + Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu + +let print_longident = function + | Longident.Lident txt -> Doc.text txt + | lid -> Doc.join ~sep:Doc.dot (print_longident_aux [] lid) + +type identifier_style = UppercaseExoticIdent | ExoticIdent | NormalIdent + +let classify_ident_content ?(allow_uident = false) ?(allow_hyphen = false) txt = + if Token.is_keyword_txt txt then ExoticIdent + else + let len = String.length txt in + let rec loop i = + if i == len then NormalIdent + else if i == 0 then + match String.unsafe_get txt i with + | '\\' -> UppercaseExoticIdent + | 'A' .. 'Z' when allow_uident -> loop (i + 1) + | 'a' .. 'z' | '_' -> loop (i + 1) + | _ -> ExoticIdent + else + match String.unsafe_get txt i with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '\'' | '_' -> loop (i + 1) + | '-' when allow_hyphen -> loop (i + 1) + | _ -> ExoticIdent + in + loop 0 + +let print_ident_like ?allow_uident ?allow_hyphen txt = + match classify_ident_content ?allow_uident ?allow_hyphen txt with + | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] + | UppercaseExoticIdent | NormalIdent -> Doc.text txt + +let rec unsafe_for_all_range s ~start ~finish p = + start > finish + || p (String.unsafe_get s start) + && unsafe_for_all_range s ~start:(start + 1) ~finish p + +let for_all_from s start p = + let len = String.length s in + unsafe_for_all_range s ~start ~finish:(len - 1) p + +(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) +let is_valid_numeric_polyvar_number (x : string) = + let len = String.length x in + len > 0 + && + let a = Char.code (String.unsafe_get x 0) in + a <= 57 + && + if len > 1 then + a > 48 + && for_all_from x 1 (function + | '0' .. '9' -> true + | _ -> false) + else a >= 48 + +(* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) +let print_poly_var_ident txt = + (* numeric poly-vars don't need quotes: #644 *) + if is_valid_numeric_polyvar_number txt then Doc.text txt + else + match classify_ident_content ~allow_uident:true txt with + | UppercaseExoticIdent -> + let len = String.length txt in + (* UppercaseExoticIdent follows the \"..." format, + so removing the leading backslash is enough to transform it into polyvar style *) + Doc.text ((String.sub [@doesNotRaise]) txt 1 (len - 1)) + | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | NormalIdent -> ( + match txt with + | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] + | _ -> Doc.text txt) + +let polyvar_ident_to_string poly_var_ident = + Doc.concat [Doc.text "#"; print_poly_var_ident poly_var_ident] + |> Doc.to_string ~width:80 + +let find_inline_record_definition inline_record_name + (inline_record_definitions : Parsetree.type_declaration list option) = + match inline_record_definitions with + | None -> None + | Some inline_record_definitions -> + inline_record_definitions + |> List.find_opt (fun (r : Parsetree.type_declaration) -> + r.ptype_name.txt = inline_record_name) + +let print_lident l = + let flat_lid_opt lid = + let rec flat accu = function + | Longident.Lident s -> Some (s :: accu) + | Ldot (lid, s) -> flat (s :: accu) lid + | Lapply (_, _) -> None + in + flat [] lid + in + match l with + | Longident.Lident txt -> print_ident_like txt + | Longident.Ldot (path, txt) -> + let doc = + match flat_lid_opt path with + | Some txts -> + Doc.concat + [ + Doc.join ~sep:Doc.dot (List.map Doc.text txts); + Doc.dot; + print_ident_like txt; + ] + | None -> Doc.text "printLident: Longident.Lapply is not supported" + in + doc + | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" + +let print_longident_location l cmt_tbl = + let doc = print_longident l.Location.txt in + print_comments doc cmt_tbl l.loc + +(* Module.SubModule.x *) +let print_lident_path path cmt_tbl = + let doc = print_lident path.Location.txt in + print_comments doc cmt_tbl path.loc + +(* Module.SubModule.x or Module.SubModule.X *) +let print_ident_path path cmt_tbl = + let doc = print_lident path.Location.txt in + print_comments doc cmt_tbl path.loc + +let print_string_loc sloc cmt_tbl = + let doc = print_ident_like sloc.Location.txt in + print_comments doc cmt_tbl sloc.loc + +let print_string_contents txt = + let lines = String.split_on_char '\n' txt in + Doc.join ~sep:Doc.literal_line (List.map Doc.text lines) + +let print_constant ?(template_literal = false) c = + match c with + | Parsetree.Pconst_integer (s, suffix) -> ( + match suffix with + | Some c -> Doc.text (s ^ Char.escaped c) + | None -> Doc.text s) + | Pconst_string (txt, None) -> + Doc.concat [Doc.text "\""; print_string_contents txt; Doc.text "\""] + | Pconst_string (txt, Some prefix) -> + if prefix = "INTERNAL_RES_CHAR_CONTENTS" then + Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] + else + let lquote, rquote = + if template_literal then ("`", "`") else ("\"", "\"") + in + Doc.concat + [ + (if prefix = "js" then Doc.nil else Doc.text prefix); + Doc.text lquote; + print_string_contents txt; + Doc.text rquote; + ] + | Pconst_float (s, _) -> Doc.text s + | Pconst_char c -> + let str = + match Char.unsafe_chr c with + | '\'' -> "\\'" + | '\\' -> "\\\\" + | '\n' -> "\\n" + | '\t' -> "\\t" + | '\r' -> "\\r" + | '\b' -> "\\b" + | ' ' .. '~' as c -> + let s = (Bytes.create [@doesNotRaise]) 1 in + Bytes.unsafe_set s 0 c; + Bytes.unsafe_to_string s + | _ -> Res_utf8.encode_code_point c + in + Doc.text ("'" ^ str ^ "'") + +module State = struct + let custom_layout_threshold = 2 + + type t = {custom_layout: int} + + let init () = {custom_layout = 0} + + let next_custom_layout t = {custom_layout = t.custom_layout + 1} + + let should_break_callback t = t.custom_layout > custom_layout_threshold +end + +let rec print_structure ~state (s : Parsetree.structure) t = + match s with + | [] -> print_comments_inside_file t + | structure -> + print_list + ~get_loc:(fun s -> s.Parsetree.pstr_loc) + ~nodes:structure + ~print:(print_structure_item ~state) + t + +and print_structure_item ~state (si : Parsetree.structure_item) cmt_tbl = + match si.pstr_desc with + | Pstr_value (rec_flag, value_bindings) -> + let rec_flag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + print_value_bindings ~state ~rec_flag value_bindings cmt_tbl + | Pstr_type (rec_flag, type_declarations) -> + print_type_declarations ~state ~rec_flag type_declarations cmt_tbl + | Pstr_primitive value_description -> + print_value_description ~state value_description cmt_tbl + | Pstr_eval (expr, attrs) -> + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.structure_expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + Doc.concat [print_attributes ~state attrs cmt_tbl; expr_doc] + | Pstr_attribute attr -> + fst (print_attribute ~state ~standalone:true attr cmt_tbl) + | Pstr_extension (extension, attrs) -> + Doc.concat + [ + print_attributes ~state attrs cmt_tbl; + Doc.concat + [print_extension ~state ~at_module_lvl:true extension cmt_tbl]; + ] + | Pstr_include include_declaration -> + print_include_declaration ~state include_declaration cmt_tbl + | Pstr_open open_description -> + print_open_description ~state open_description cmt_tbl + | Pstr_modtype mod_type_decl -> + print_module_type_declaration ~state mod_type_decl cmt_tbl + | Pstr_module module_binding -> + print_module_binding ~state ~is_rec:false module_binding cmt_tbl 0 + | Pstr_recmodule module_bindings -> + print_listi + ~get_loc:(fun mb -> mb.Parsetree.pmb_loc) + ~nodes:module_bindings + ~print:(print_module_binding ~state ~is_rec:true) + cmt_tbl + | Pstr_exception extension_constructor -> + print_exception_def ~state extension_constructor cmt_tbl + | Pstr_typext type_extension -> + print_type_extension ~state type_extension cmt_tbl + +and print_type_extension ~state (te : Parsetree.type_extension) cmt_tbl = + let prefix = Doc.text "type " in + let name = print_lident_path te.ptyext_path cmt_tbl in + let type_params = print_type_params ~state te.ptyext_params cmt_tbl in + let extension_constructors = + let ecs = te.ptyext_constructors in + let force_break = + match (ecs, List.rev ecs) with + | first :: _, last :: _ -> + first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum + || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum + | _ -> false + in + let private_flag = + match te.ptyext_private with + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Public -> Doc.nil + in + let rows = + print_listi + ~get_loc:(fun n -> n.Parsetree.pext_loc) + ~print:(print_extension_constructor ~state) + ~nodes:ecs ~force_break cmt_tbl + in + Doc.breakable_group ~force_break + (Doc.indent + (Doc.concat + [ + Doc.line; + private_flag; + rows; + (* Doc.join ~sep:Doc.line ( *) + (* List.mapi printExtensionConstructor ecs *) + (* ) *) + ])) + in + Doc.group + (Doc.concat + [ + print_attributes ~state ~loc:te.ptyext_path.loc te.ptyext_attributes + cmt_tbl; + prefix; + name; + type_params; + Doc.text " +="; + extension_constructors; + ]) + +and print_module_binding ~state ~is_rec module_binding cmt_tbl i = + let prefix = + if i = 0 then + Doc.concat + [Doc.text "module "; (if is_rec then Doc.text "rec " else Doc.nil)] + else Doc.text "and " + in + let mod_expr_doc, mod_constraint_doc = + match module_binding.pmb_expr with + | {pmod_desc = Pmod_constraint (mod_expr, mod_type)} + when not + (ParsetreeViewer.has_await_attribute + module_binding.pmb_expr.pmod_attributes) -> + ( print_mod_expr ~state mod_expr cmt_tbl, + Doc.concat [Doc.text ": "; print_mod_type ~state mod_type cmt_tbl] ) + | mod_expr -> (print_mod_expr ~state mod_expr cmt_tbl, Doc.nil) + in + let mod_expr_doc_parens = + if Parens.mod_expr_parens module_binding.pmb_expr then + Doc.concat [Doc.lparen; mod_expr_doc; Doc.rparen] + else mod_expr_doc + in + let mod_name = + let doc = Doc.text module_binding.pmb_name.Location.txt in + print_comments doc cmt_tbl module_binding.pmb_name.loc + in + let doc = + Doc.concat + [ + print_attributes ~state ~loc:module_binding.pmb_name.loc + module_binding.pmb_attributes cmt_tbl; + prefix; + mod_name; + mod_constraint_doc; + Doc.text " = "; + mod_expr_doc_parens; + ] + in + print_comments doc cmt_tbl module_binding.pmb_loc + +and print_module_type_declaration ~state + (mod_type_decl : Parsetree.module_type_declaration) cmt_tbl = + let mod_name = + let doc = Doc.text mod_type_decl.pmtd_name.txt in + print_comments doc cmt_tbl mod_type_decl.pmtd_name.loc + in + Doc.concat + [ + print_attributes ~state mod_type_decl.pmtd_attributes cmt_tbl; + Doc.text "module type "; + mod_name; + (match mod_type_decl.pmtd_type with + | None -> Doc.nil + | Some mod_type -> + Doc.concat [Doc.text " = "; print_mod_type ~state mod_type cmt_tbl]); + ] + +and print_mod_type ~state mod_type cmt_tbl = + let mod_type_doc = + match mod_type.pmty_desc with + | Parsetree.Pmty_ident longident -> + Doc.concat + [ + print_attributes ~state ~loc:longident.loc mod_type.pmty_attributes + cmt_tbl; + print_longident_location longident cmt_tbl; + ] + | Pmty_signature [] -> + if has_comments_inside cmt_tbl mod_type.pmty_loc then + let doc = print_comments_inside cmt_tbl mod_type.pmty_loc in + Doc.concat [Doc.lbrace; doc; Doc.rbrace] + else + let should_break = + mod_type.pmty_loc.loc_start.pos_lnum + < mod_type.pmty_loc.loc_end.pos_lnum + in + Doc.breakable_group ~force_break:should_break + (Doc.concat [Doc.lbrace; Doc.soft_line; Doc.soft_line; Doc.rbrace]) + | Pmty_signature signature -> + let signature_doc = + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.line; print_signature ~state signature cmt_tbl]); + Doc.line; + Doc.rbrace; + ]) + in + Doc.concat + [ + print_attributes ~state mod_type.pmty_attributes cmt_tbl; signature_doc; + ] + | Pmty_functor _ -> + let parameters, return_type = ParsetreeViewer.functor_type mod_type in + let parameters_doc = + match parameters with + | [] -> Doc.nil + | [(attrs, {Location.txt = "_"; loc}, Some mod_type)] -> + let cmt_loc = + {loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end} + in + let attrs = print_attributes ~state attrs cmt_tbl in + let doc = + Doc.concat [attrs; print_mod_type ~state mod_type cmt_tbl] + in + print_comments doc cmt_tbl cmt_loc + | [(attrs, {Location.txt = "*"; loc}, None)] -> + let attrs = print_attributes ~state attrs cmt_tbl in + let doc = Doc.concat [attrs; Doc.text "()"] in + print_comments doc cmt_tbl loc + | params -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun (attrs, lbl, mod_type) -> + let cmt_loc = + match mod_type with + | None -> lbl.Asttypes.loc + | Some mod_type -> + { + lbl.Asttypes.loc with + loc_end = + mod_type.Parsetree.pmty_loc.loc_end; + } + in + let attrs = + print_attributes ~state attrs cmt_tbl + in + let lbl_doc = + if lbl.Location.txt = "_" then Doc.nil + else if lbl.txt = "*" then + let doc = Doc.text "()" in + print_comments doc cmt_tbl lbl.loc + else + let doc = Doc.text lbl.txt in + print_comments doc cmt_tbl lbl.loc + in + let doc = + Doc.concat + [ + attrs; + lbl_doc; + (match mod_type with + | None -> Doc.nil + | Some mod_type -> + Doc.concat + [ + (if lbl.txt = "_" then Doc.nil + else Doc.text ": "); + print_mod_type ~state mod_type + cmt_tbl; + ]); + ] + in + print_comments doc cmt_tbl cmt_loc) + params); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + in + let return_doc = + let doc = print_mod_type ~state return_type cmt_tbl in + if Parens.mod_type_functor_return return_type then add_parens doc + else doc + in + Doc.group + (Doc.concat + [ + parameters_doc; + Doc.group (Doc.concat [Doc.text " =>"; Doc.line; return_doc]); + ]) + | Pmty_typeof mod_expr -> + Doc.concat + [Doc.text "module type of "; print_mod_expr ~state mod_expr cmt_tbl] + | Pmty_extension extension -> + print_extension ~state ~at_module_lvl:false extension cmt_tbl + | Pmty_alias longident -> + Doc.concat + [Doc.text "module "; print_longident_location longident cmt_tbl] + | Pmty_with (mod_type, with_constraints) -> + let operand = + let doc = print_mod_type ~state mod_type cmt_tbl in + if Parens.mod_type_with_operand mod_type then add_parens doc else doc + in + Doc.group + (Doc.concat + [ + operand; + Doc.indent + (Doc.concat + [ + Doc.line; + print_with_constraints ~state with_constraints cmt_tbl; + ]); + ]) + in + let attrs_already_printed = + match mod_type.pmty_desc with + | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true + | _ -> false + in + let doc = + Doc.concat + [ + (if attrs_already_printed then Doc.nil + else print_attributes ~state mod_type.pmty_attributes cmt_tbl); + mod_type_doc; + ] + in + print_comments doc cmt_tbl mod_type.pmty_loc + +and print_with_constraints ~state with_constraints cmt_tbl = + let rows = + List.mapi + (fun i with_constraint -> + Doc.group + (Doc.concat + [ + (if i == 0 then Doc.text "with " else Doc.text "and "); + print_with_constraint ~state with_constraint cmt_tbl; + ])) + with_constraints + in + Doc.join ~sep:Doc.line rows + +and print_with_constraint ~state (with_constraint : Parsetree.with_constraint) + cmt_tbl = + match with_constraint with + (* with type X.t = ... *) + | Pwith_type (longident, type_declaration) -> + Doc.group + (print_type_declaration ~state + ~name:(print_lident_path longident cmt_tbl) + ~equal_sign:"=" ~rec_flag:Doc.nil 0 type_declaration CommentTable.empty) + (* with module X.Y = Z *) + | Pwith_module ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + print_longident longident1; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; print_longident longident2]); + ] + (* with type X.t := ..., same format as [Pwith_type] *) + | Pwith_typesubst (longident, type_declaration) -> + Doc.group + (print_type_declaration ~state + ~name:(print_lident_path longident cmt_tbl) + ~equal_sign:":=" ~rec_flag:Doc.nil 0 type_declaration + CommentTable.empty) + | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> + Doc.concat + [ + Doc.text "module "; + print_longident longident1; + Doc.text " :="; + Doc.indent (Doc.concat [Doc.line; print_longident longident2]); + ] + +and print_signature ~state signature cmt_tbl = + match signature with + | [] -> print_comments_inside_file cmt_tbl + | signature -> + print_list + ~get_loc:(fun s -> s.Parsetree.psig_loc) + ~nodes:signature + ~print:(print_signature_item ~state) + cmt_tbl + +and print_signature_item ~state (si : Parsetree.signature_item) cmt_tbl = + match si.psig_desc with + | Parsetree.Psig_value value_description -> + print_value_description ~state value_description cmt_tbl + | Psig_type (rec_flag, type_declarations) -> + print_type_declarations ~state ~rec_flag type_declarations cmt_tbl + | Psig_typext type_extension -> + print_type_extension ~state type_extension cmt_tbl + | Psig_exception extension_constructor -> + print_exception_def ~state extension_constructor cmt_tbl + | Psig_module module_declaration -> + print_module_declaration ~state module_declaration cmt_tbl + | Psig_recmodule module_declarations -> + print_rec_module_declarations ~state module_declarations cmt_tbl + | Psig_modtype mod_type_decl -> + print_module_type_declaration ~state mod_type_decl cmt_tbl + | Psig_open open_description -> + print_open_description ~state open_description cmt_tbl + | Psig_include include_description -> + print_include_description ~state include_description cmt_tbl + | Psig_attribute attr -> + fst (print_attribute ~state ~standalone:true attr cmt_tbl) + | Psig_extension (extension, attrs) -> + Doc.concat + [ + print_attributes ~state attrs cmt_tbl; + Doc.concat + [print_extension ~state ~at_module_lvl:true extension cmt_tbl]; + ] + +and print_rec_module_declarations ~state module_declarations cmt_tbl = + print_listi + ~get_loc:(fun n -> n.Parsetree.pmd_loc) + ~nodes:module_declarations + ~print:(print_rec_module_declaration ~state) + cmt_tbl + +and print_rec_module_declaration ~state md cmt_tbl i = + let body = + match md.pmd_type.pmty_desc with + | Parsetree.Pmty_alias longident -> + Doc.concat [Doc.text " = "; print_longident_location longident cmt_tbl] + | _ -> + let needs_parens = + match md.pmd_type.pmty_desc with + | Pmty_with _ -> true + | _ -> false + in + let mod_type_doc = + let doc = print_mod_type ~state md.pmd_type cmt_tbl in + if needs_parens then add_parens doc else doc + in + Doc.concat [Doc.text ": "; mod_type_doc] + in + let prefix = if i < 1 then "module rec " else "and " in + Doc.concat + [ + print_attributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmt_tbl; + Doc.text prefix; + print_comments (Doc.text md.pmd_name.txt) cmt_tbl md.pmd_name.loc; + body; + ] + +and print_module_declaration ~state (md : Parsetree.module_declaration) cmt_tbl + = + let body = + match md.pmd_type.pmty_desc with + | Parsetree.Pmty_alias longident -> + Doc.concat [Doc.text " = "; print_longident_location longident cmt_tbl] + | _ -> Doc.concat [Doc.text ": "; print_mod_type ~state md.pmd_type cmt_tbl] + in + Doc.concat + [ + print_attributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmt_tbl; + Doc.text "module "; + print_comments (Doc.text md.pmd_name.txt) cmt_tbl md.pmd_name.loc; + body; + ] + +and print_open_description ~state + (open_description : Parsetree.open_description) cmt_tbl = + Doc.concat + [ + print_attributes ~state open_description.popen_attributes cmt_tbl; + Doc.text "open"; + (match open_description.popen_override with + | Asttypes.Fresh -> Doc.space + | Asttypes.Override -> Doc.text "! "); + print_longident_location open_description.popen_lid cmt_tbl; + ] + +and print_include_description ~state + (include_description : Parsetree.include_description) cmt_tbl = + Doc.concat + [ + print_attributes ~state include_description.pincl_attributes cmt_tbl; + Doc.text "include "; + print_mod_type ~state include_description.pincl_mod cmt_tbl; + ] + +and print_include_declaration ~state + (include_declaration : Parsetree.include_declaration) cmt_tbl = + Doc.concat + [ + print_attributes ~state include_declaration.pincl_attributes cmt_tbl; + Doc.text "include "; + (let include_doc = + match include_declaration.pincl_mod.pmod_desc with + (* + include Module.Name({ type t = t }) + try as oneliner if there is a single type alias declaration + *) + | Pmod_apply + ( {pmod_desc = Pmod_ident longident_loc}, + { + pmod_desc = + Pmod_structure + [ + ({ + pstr_desc = + Pstr_type + ( _, + [ + { + ptype_kind = Ptype_abstract; + ptype_manifest = Some _; + }; + ] ); + } as structure_item); + ]; + } ) -> + Doc.concat + [ + print_longident_location longident_loc cmt_tbl; + Doc.lparen; + Doc.breakable_group ~force_break:false + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + print_structure_item ~state structure_item cmt_tbl; + ]); + Doc.soft_line; + Doc.rbrace; + ]); + Doc.rparen; + ] + | _ -> print_mod_expr ~state include_declaration.pincl_mod cmt_tbl + in + if Parens.include_mod_expr include_declaration.pincl_mod then + add_parens include_doc + else include_doc); + ] + +and print_value_bindings ~state ~rec_flag (vbs : Parsetree.value_binding list) + cmt_tbl = + print_listi + ~get_loc:(fun vb -> vb.Parsetree.pvb_loc) + ~nodes:vbs + ~print:(print_value_binding ~state ~rec_flag) + cmt_tbl + +and print_value_description ~state value_description cmt_tbl = + let is_external = + match value_description.pval_prim with + | [] -> false + | _ -> true + in + let attrs = + print_attributes ~state ~loc:value_description.pval_name.loc + value_description.pval_attributes cmt_tbl + in + let header = if is_external then "external " else "let " in + Doc.group + (Doc.concat + [ + attrs; + Doc.text header; + print_comments + (print_ident_like value_description.pval_name.txt) + cmt_tbl value_description.pval_name.loc; + Doc.text ": "; + print_typ_expr ~state value_description.pval_type cmt_tbl; + (if is_external then + Doc.group + (Doc.concat + [ + Doc.text " ="; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.join ~sep:Doc.line + (List.map + (fun s -> + Doc.concat + [Doc.text "\""; Doc.text s; Doc.text "\""]) + value_description.pval_prim); + ]); + ]) + else Doc.nil); + ]) + +and print_type_declarations ~state ~rec_flag type_declarations cmt_tbl = + if has_inline_type_definitions type_declarations then + let inline_record_definitions, regular_declarations = + type_declarations + |> List.partition (fun (td : Parsetree.type_declaration) -> + Res_parsetree_viewer.has_inline_record_definition_attribute + td.ptype_attributes) + in + let adjusted_rec_flag = + match rec_flag with + | Recursive -> + if List.length regular_declarations > 1 then Doc.text "rec " + else Doc.nil + | Nonrecursive -> Doc.nil + in + print_listi + ~get_loc:(fun n -> n.Parsetree.ptype_loc) + ~nodes:regular_declarations + ~print: + (print_type_declaration2 ~inline_record_definitions ~state + ~rec_flag:adjusted_rec_flag) + cmt_tbl + else + print_listi + ~get_loc:(fun n -> n.Parsetree.ptype_loc) + ~nodes:type_declarations + ~print: + (print_type_declaration2 ~state + ~rec_flag: + (match rec_flag with + | Nonrecursive -> Doc.nil + | Recursive -> Doc.text "rec ")) + cmt_tbl + +(* + * type_declaration = { + * ptype_name: string loc; + * ptype_params: (core_type * variance) list; + * (* ('a1,...'an) t; None represents _*) + * ptype_cstrs: (core_type * core_type * Location.t) list; + * (* ... constraint T1=T1' ... constraint Tn=Tn' *) + * ptype_kind: type_kind; + * ptype_private: private_flag; (* = private ... *) + * ptype_manifest: core_type option; (* = T *) + * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) + * ptype_loc: Location.t; + * } + * + * + * type t (abstract, no manifest) + * type t = T0 (abstract, manifest=T0) + * type t = C of T | ... (variant, no manifest) + * type t = T0 = C of T | ... (variant, manifest=T0) + * type t = {l: T; ...} (record, no manifest) + * type t = T0 = {l : T; ...} (record, manifest=T0) + * type t = .. (open, no manifest) + * + * + * and type_kind = + * | Ptype_abstract + * | Ptype_variant of constructor_declaration list + * (* Invariant: non-empty list *) + * | Ptype_record of label_declaration list + * (* Invariant: non-empty list *) + * | Ptype_open + *) +and print_type_declaration ~state ~name ~equal_sign ~rec_flag i + (td : Parsetree.type_declaration) cmt_tbl = + let attrs = + print_attributes ~state ~loc:td.ptype_loc td.ptype_attributes cmt_tbl + in + let prefix = + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; rec_flag] + in + let type_name = name in + let type_params = print_type_params ~state td.ptype_params cmt_tbl in + let manifest_and_kind = + match td.ptype_kind with + | Ptype_abstract -> ( + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_typ_expr ~state typ cmt_tbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + Doc.text ".."; + ] + | Ptype_record lds -> + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_record_declaration ~record_loc:td.ptype_loc ~state lds cmt_tbl; + ] + | Ptype_variant cds -> + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equal_sign]; + print_constructor_declarations ~state ~private_flag:td.ptype_private + cds cmt_tbl; + ] + in + let constraints = print_type_definition_constraints ~state td.ptype_cstrs in + Doc.group + (Doc.concat + [attrs; prefix; type_name; type_params; manifest_and_kind; constraints]) + +and print_type_declaration2 ?inline_record_definitions ~state ~rec_flag + (td : Parsetree.type_declaration) cmt_tbl i = + let name = + let doc = print_ident_like td.Parsetree.ptype_name.txt in + print_comments doc cmt_tbl td.ptype_name.loc + in + let equal_sign = "=" in + let attrs = + print_attributes ~state ~loc:td.ptype_loc td.ptype_attributes cmt_tbl + in + let prefix = + if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; rec_flag] + in + let type_name = name in + let type_params = print_type_params ~state td.ptype_params cmt_tbl in + let manifest_and_kind = + match td.ptype_kind with + | Ptype_abstract -> ( + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_typ_expr ~state typ cmt_tbl; + ]) + | Ptype_open -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + Doc.text ".."; + ] + | Ptype_record lds -> + if lds = [] then + Doc.concat + [ + Doc.space; + Doc.text equal_sign; + Doc.space; + print_private_flag td.ptype_private; + Doc.lbrace; + print_comments_inside cmt_tbl td.ptype_loc; + Doc.rbrace; + ] + else + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_private_flag td.ptype_private; + print_record_declaration ?inline_record_definitions + ~record_loc:td.ptype_loc ~state lds cmt_tbl; + ] + | Ptype_variant cds -> + let manifest = + match td.ptype_manifest with + | None -> Doc.nil + | Some typ -> + Doc.concat + [ + Doc.concat [Doc.space; Doc.text equal_sign; Doc.space]; + print_typ_expr ~state typ cmt_tbl; + ] + in + Doc.concat + [ + manifest; + Doc.concat [Doc.space; Doc.text equal_sign]; + print_constructor_declarations ~state ~private_flag:td.ptype_private + cds cmt_tbl; + ] + in + let constraints = print_type_definition_constraints ~state td.ptype_cstrs in + Doc.group + (Doc.concat + [attrs; prefix; type_name; type_params; manifest_and_kind; constraints]) + +and print_type_definition_constraints ~state cstrs = + match cstrs with + | [] -> Doc.nil + | cstrs -> + Doc.indent + (Doc.group + (Doc.concat + [ + Doc.line; + Doc.group + (Doc.join ~sep:Doc.line + (List.map (print_type_definition_constraint ~state) cstrs)); + ])) + +and print_type_definition_constraint ~state + ((typ1, typ2, _loc) : + Parsetree.core_type * Parsetree.core_type * Location.t) = + Doc.concat + [ + Doc.text "constraint "; + print_typ_expr ~state typ1 CommentTable.empty; + Doc.text " = "; + print_typ_expr ~state typ2 CommentTable.empty; + ] + +and print_private_flag (flag : Asttypes.private_flag) = + match flag with + | Private -> Doc.text "private " + | Public -> Doc.nil + +and print_type_params ~state type_params cmt_tbl = + match type_params with + | [] -> Doc.nil + | type_params -> + Doc.group + (Doc.concat + [ + Doc.less_than; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun type_param -> + let doc = print_type_param ~state type_param cmt_tbl in + print_comments doc cmt_tbl + (fst type_param).Parsetree.ptyp_loc) + type_params); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; + ]) + +and print_type_param ~state (param : Parsetree.core_type * Asttypes.variance) + cmt_tbl = + let typ, variance = param in + let printed_variance = + match variance with + | Covariant -> Doc.text "+" + | Contravariant -> Doc.text "-" + | Invariant -> Doc.nil + in + Doc.concat [printed_variance; print_typ_expr ~state typ cmt_tbl] + +and print_record_declaration ?check_break_from_loc ?inline_record_definitions + ?record_loc ~state (lds : Parsetree.label_declaration list) cmt_tbl = + let get_field_start_line (ld : Parsetree.label_declaration) = + (* For spread fields (...), use the type location instead of pld_loc + because pld_loc may incorrectly include preceding whitespace *) + if ld.pld_name.txt = "..." then ld.pld_type.ptyp_loc.loc_start.pos_lnum + else ld.pld_loc.loc_start.pos_lnum + in + let force_break = + match (check_break_from_loc, record_loc, lds) with + | Some loc, _, _ -> loc.Location.loc_start.pos_lnum < loc.loc_end.pos_lnum + | None, Some loc, first :: _ -> + (* Check if first field is on a different line than the opening brace *) + loc.loc_start.pos_lnum < get_field_start_line first + | None, None, first :: _ -> + let last = List.hd (List.rev lds) in + get_field_start_line first < last.pld_loc.loc_end.pos_lnum + | _, _, _ -> false + in + Doc.breakable_group ~force_break + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ld -> + let doc = + print_label_declaration ?inline_record_definitions + ~state ld cmt_tbl + in + print_comments doc cmt_tbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ]) + +and print_literal_dict_expr ~state (e : Parsetree.expression) cmt_tbl = + let force_break = + e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum + in + let tuple_to_row (e : Parsetree.expression) = + match e with + | { + pexp_desc = + Pexp_tuple + [ + {pexp_desc = Pexp_constant (Pconst_string (name, _)); pexp_loc}; value; + ]; + } -> + Some ((Location.mkloc (Longident.Lident name) pexp_loc, value), e) + | _ -> None + in + let rows = + match e with + | {pexp_desc = Pexp_array expressions} -> + List.filter_map tuple_to_row expressions + | _ -> [] + in + Doc.breakable_group ~force_break + (Doc.concat + [ + Doc.indent + (Doc.concat + [ + (if rows = [] then Doc.nil else Doc.soft_line); + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun ((row, e) : + (Longident.t Location.loc * Parsetree.expression) + * Parsetree.expression) -> + let doc = print_bs_object_row ~state row cmt_tbl in + print_comments doc cmt_tbl e.pexp_loc) + rows); + ]); + (if rows = [] then Doc.nil + else Doc.concat [Doc.trailing_comma; Doc.soft_line]); + ]) + +and print_constructor_declarations ~state ~private_flag + (cds : Parsetree.constructor_declaration list) cmt_tbl = + let force_break = + match (cds, List.rev cds) with + | first :: _, last :: _ -> + first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum + | _ -> false + in + let private_flag = + match private_flag with + | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] + | Public -> Doc.nil + in + let rows = + print_listi + ~get_loc:(fun cd -> cd.Parsetree.pcd_loc) + ~nodes:cds + ~print:(fun cd cmt_tbl i -> + let doc = print_constructor_declaration2 ~state i cd cmt_tbl in + print_comments doc cmt_tbl cd.Parsetree.pcd_loc) + ~force_break cmt_tbl ~ignore_empty_lines:true + in + Doc.breakable_group ~force_break + (Doc.indent (Doc.concat [Doc.line; private_flag; rows])) + +and print_constructor_declaration2 ~state i + (cd : Parsetree.constructor_declaration) cmt_tbl = + let comment_attrs, attrs = + ParsetreeViewer.partition_doc_comment_attributes cd.pcd_attributes + in + let comment_doc = + match comment_attrs with + | [] -> Doc.nil + | comment_attrs -> + print_doc_comments ~sep:Doc.hard_line ~state cmt_tbl comment_attrs + in + let attrs = print_attributes ~state attrs cmt_tbl in + let is_dot_dot_dot = cd.pcd_name.txt = "..." in + let bar = + if i > 0 || cd.pcd_attributes <> [] || is_dot_dot_dot then Doc.text "| " + else Doc.if_breaks (Doc.text "| ") Doc.nil + in + let constr_name = + let doc = Doc.text cd.pcd_name.txt in + print_comments doc cmt_tbl cd.pcd_name.loc + in + let constr_args = + print_constructor_arguments ~is_dot_dot_dot ~state ~indent:true cd.pcd_args + cmt_tbl + in + let gadt = + match cd.pcd_res with + | None -> Doc.nil + | Some typ -> + Doc.indent (Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl]) + in + Doc.concat + [ + comment_doc; + bar; + Doc.group + (Doc.concat + [ + attrs; + (* TODO: fix parsing of attributes, so when can print them above the bar? *) + constr_name; + constr_args; + gadt; + ]); + ] + +and print_constructor_arguments ?(is_dot_dot_dot = false) ~state ~indent + (cd_args : Parsetree.constructor_arguments) cmt_tbl = + match cd_args with + | Pcstr_tuple [] -> Doc.nil + | Pcstr_tuple types -> + let args = + Doc.concat + [ + (if is_dot_dot_dot then Doc.nil else Doc.lparen); + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> print_typ_expr ~state typexpr cmt_tbl) + types); + ]); + Doc.trailing_comma; + Doc.soft_line; + (if is_dot_dot_dot then Doc.nil else Doc.rparen); + ] + in + Doc.group (if indent then Doc.indent args else args) + | Pcstr_record lds -> + let args = + Doc.concat + [ + Doc.lparen; + (* manually inline the printRecordDeclaration, gives better layout *) + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun ld -> + let doc = print_label_declaration ~state ld cmt_tbl in + print_comments doc cmt_tbl ld.Parsetree.pld_loc) + lds); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + Doc.rparen; + ] + in + if indent then Doc.indent args else args + +and print_label_declaration ?inline_record_definitions ~state + (ld : Parsetree.label_declaration) cmt_tbl = + let attrs = + print_attributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmt_tbl + in + let mutable_flag = + match ld.pld_mutable with + | Mutable -> Doc.text "mutable " + | Immutable -> Doc.nil + in + let name, is_dot = + let doc, is_dot = + if ld.pld_name.txt = "..." then (Doc.text ld.pld_name.txt, true) + else (print_ident_like ld.pld_name.txt, false) + in + (print_comments doc cmt_tbl ld.pld_name.loc, is_dot) + in + let optional = if ld.pld_optional then Doc.text "?" else Doc.nil in + Doc.group + (Doc.concat + [ + attrs; + mutable_flag; + name; + optional; + (if is_dot then Doc.nil else Doc.text ": "); + print_typ_expr ?inline_record_definitions ~state ld.pld_type cmt_tbl; + ]) + +and print_typ_expr ?inline_record_definitions ~(state : State.t) + (typ_expr : Parsetree.core_type) cmt_tbl = + let print_arrow ~arity typ_expr = + let max_arity = + match arity with + | Some arity -> arity + | None -> max_int + in + let attrs_before, args, return_type = + ParsetreeViewer.arrow_type ~max_arity typ_expr + in + let return_type_needs_parens = + match return_type.ptyp_desc with + | Ptyp_alias _ -> true + | _ -> false + in + let return_doc = + let doc = print_typ_expr ~state return_type cmt_tbl in + if return_type_needs_parens then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + match args with + | [] -> Doc.nil + | [{attrs = []; lbl = Nolabel; typ}] -> + let has_attrs_before = not (attrs_before = []) in + let attrs = + if has_attrs_before then + print_attributes ~state ~inline:true attrs_before cmt_tbl + else Doc.nil + in + let typ_doc = + let doc = print_typ_expr ~state typ cmt_tbl in + match typ.ptyp_desc with + | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> add_parens doc + | _ -> doc + in + Doc.group + (Doc.concat + [ + Doc.group attrs; + Doc.group + (if has_attrs_before then + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [Doc.soft_line; typ_doc; Doc.text " => "; return_doc]); + Doc.soft_line; + Doc.rparen; + ] + else Doc.concat [typ_doc; Doc.text " => "; return_doc]); + ]) + | args -> + let attrs = print_attributes ~state ~inline:true attrs_before cmt_tbl in + let rendered_args = + Doc.concat + [ + attrs; + Doc.text "("; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun tp -> print_type_parameter ~state tp cmt_tbl) + args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.text ")"; + ] + in + Doc.group (Doc.concat [rendered_args; Doc.text " => "; return_doc]) + in + let rendered_type = + match typ_expr.ptyp_desc with + | Ptyp_any -> Doc.text "_" + | Ptyp_var var -> + Doc.concat [Doc.text "'"; print_ident_like ~allow_uident:true var] + | Ptyp_extension extension -> + print_extension ~state ~at_module_lvl:false extension cmt_tbl + | Ptyp_alias (typ, alias) -> + let typ = + (* Technically type t = (string, float) => unit as 'x, doesn't require + * parens around the arrow expression. This is very confusing though. + * Is the "as" part of "unit" or "(string, float) => unit". By printing + * parens we guide the user towards its meaning.*) + let needs_parens = + match typ.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false + in + let doc = print_typ_expr ~state typ cmt_tbl in + if needs_parens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc + in + Doc.concat + [ + typ; Doc.text " as "; Doc.concat [Doc.text "'"; print_ident_like alias]; + ] + (* object printings *) + | Ptyp_object (fields, open_flag) -> + print_object ~state ~inline:false fields open_flag cmt_tbl + | Ptyp_arrow {arity} -> print_arrow ~arity typ_expr + | Ptyp_constr ({txt = Lident inline_record_name}, _) + when inline_record_definitions + |> find_inline_record_definition inline_record_name + |> Option.is_some -> ( + match + inline_record_definitions + |> find_inline_record_definition inline_record_name + with + | Some {ptype_kind = Ptype_record lds; ptype_loc} -> + print_record_declaration ~check_break_from_loc:ptype_loc + ~inline_record_definitions:(inline_record_definitions |> Option.get) + ~state lds cmt_tbl + | _ -> assert false) + | Ptyp_constr + (longident_loc, [{ptyp_desc = Ptyp_object (fields, open_flag)}]) -> + (* for foo<{"a": b}>, when the object is long and needs a line break, we + want the <{ and }> to stay hugged together *) + let constr_name = print_lident_path longident_loc cmt_tbl in + Doc.concat + [ + constr_name; + Doc.less_than; + print_object ~state ~inline:true fields open_flag cmt_tbl; + Doc.greater_than; + ] + | Ptyp_constr (longident_loc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> + let constr_name = print_lident_path longident_loc cmt_tbl in + Doc.group + (Doc.concat + [ + constr_name; + Doc.less_than; + print_tuple_type ~state ~inline:true tuple cmt_tbl; + Doc.greater_than; + ]) + | Ptyp_constr (longident_loc, constr_args) -> ( + let constr_name = print_lident_path longident_loc cmt_tbl in + match constr_args with + | [] -> constr_name + | _args -> + Doc.group + (Doc.concat + [ + constr_name; + Doc.less_than; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> + print_typ_expr ?inline_record_definitions ~state + typexpr cmt_tbl) + constr_args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.greater_than; + ])) + | Ptyp_tuple types -> print_tuple_type ~state ~inline:false types cmt_tbl + | Ptyp_poly ([], typ) -> + print_typ_expr ?inline_record_definitions ~state typ cmt_tbl + | Ptyp_poly (string_locs, typ) -> + Doc.concat + [ + Doc.join ~sep:Doc.space + (List.map + (fun {Location.txt; loc} -> + let doc = Doc.concat [Doc.text "'"; Doc.text txt] in + print_comments doc cmt_tbl loc) + string_locs); + Doc.dot; + Doc.space; + print_typ_expr ~state typ cmt_tbl; + ] + | Ptyp_package package_type -> + print_package_type ~state ~print_module_keyword_and_parens:true + package_type cmt_tbl + | Ptyp_variant (row_fields, closed_flag, labels_opt) -> + let force_break = + typ_expr.ptyp_loc.Location.loc_start.pos_lnum + < typ_expr.ptyp_loc.loc_end.pos_lnum + in + let print_row_field i = function + | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> + let comment_attrs, attrs = + ParsetreeViewer.partition_doc_comment_attributes attrs + in + let comment_doc = + match comment_attrs with + | [] -> Doc.nil + | comment_attrs -> + print_doc_comments ~sep:Doc.hard_line ~state cmt_tbl comment_attrs + in + let bar = + if i > 0 || comment_attrs <> [] then Doc.text "| " + else Doc.if_breaks (Doc.text "| ") Doc.nil + in + let tag_doc = + Doc.group + (Doc.concat + [ + print_attributes ~state attrs cmt_tbl; + Doc.concat [Doc.text "#"; print_poly_var_ident txt]; + ]) + in + Doc.concat [comment_doc; bar; print_comments tag_doc cmt_tbl loc] + | Rtag ({txt; loc}, attrs, truth, types) -> + let comment_attrs, attrs = + ParsetreeViewer.partition_doc_comment_attributes attrs + in + let comment_doc = + match comment_attrs with + | [] -> Doc.nil + | comment_attrs -> + print_doc_comments ~sep:Doc.hard_line ~state cmt_tbl comment_attrs + in + let bar = + if i > 0 || comment_attrs <> [] then Doc.text "| " + else Doc.if_breaks (Doc.text "| ") Doc.nil + in + let do_type t = + match t.Parsetree.ptyp_desc with + | Ptyp_tuple _ -> print_typ_expr ~state t cmt_tbl + | _ -> + Doc.concat + [Doc.lparen; print_typ_expr ~state t cmt_tbl; Doc.rparen] + in + let printed_types = List.map do_type types in + let cases = + Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printed_types + in + let cases = + if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases + in + let tag_doc = + Doc.group + (Doc.concat + [ + print_attributes ~state attrs cmt_tbl; + Doc.concat [Doc.text "#"; print_poly_var_ident txt]; + cases; + ]) + in + Doc.concat [comment_doc; bar; print_comments tag_doc cmt_tbl loc] + | Rinherit core_type -> + let bar = + if i > 0 then Doc.text "| " + else Doc.if_breaks (Doc.text "| ") Doc.nil + in + Doc.concat [bar; print_typ_expr ~state core_type cmt_tbl] + in + let docs = List.mapi print_row_field row_fields in + let cases = Doc.join ~sep:Doc.line docs in + let opening_symbol = + if closed_flag = Open then Doc.concat [Doc.greater_than; Doc.line] + else if labels_opt = None then Doc.soft_line + else Doc.concat [Doc.less_than; Doc.line] + in + let labels = + match labels_opt with + | None | Some [] -> Doc.nil + | Some labels -> + Doc.concat + (List.map + (fun label -> + Doc.concat [Doc.line; Doc.text "#"; print_poly_var_ident label]) + labels) + in + let closing_symbol = + match labels_opt with + | None | Some [] -> Doc.nil + | _ -> Doc.text " >" + in + Doc.breakable_group ~force_break + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat [opening_symbol; cases; closing_symbol; labels]); + Doc.soft_line; + Doc.rbracket; + ]) + in + let should_print_its_own_attributes = + match typ_expr.ptyp_desc with + | Ptyp_arrow _ (* es6 arrow types print their own attributes *) -> true + | _ -> false + in + let doc = + match typ_expr.ptyp_attributes with + | _ :: _ as attrs when not should_print_its_own_attributes -> + let doc_comment_attr, attrs = + ParsetreeViewer.partition_doc_comment_attributes attrs + in + let comment_doc = + match doc_comment_attr with + | [] -> Doc.nil + | _ -> print_doc_comments ~state ~sep:Doc.space cmt_tbl doc_comment_attr + in + let attrs_doc = + match attrs with + | [] -> Doc.nil + | _ -> print_attributes ~state attrs cmt_tbl + in + Doc.group (Doc.concat [comment_doc; attrs_doc; rendered_type]) + | _ -> rendered_type + in + print_comments doc cmt_tbl typ_expr.ptyp_loc + +and print_object ~state ~inline fields open_flag cmt_tbl = + let doc = + match fields with + | [] -> + Doc.concat + [ + Doc.lbrace; + (match open_flag with + | Asttypes.Closed -> Doc.dot + | Open -> Doc.dotdot); + Doc.rbrace; + ] + | fields -> + Doc.concat + [ + Doc.lbrace; + (match open_flag with + | Asttypes.Closed -> Doc.nil + | Open -> ( + match fields with + (* handle `type t = {.. ...objType, "x": int}` + * .. and ... should have a space in between *) + | Oinherit _ :: _ -> Doc.text ".. " + | _ -> Doc.dotdot)); + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun field -> print_object_field ~state field cmt_tbl) + fields); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ] + in + if inline then doc else Doc.group doc + +and print_tuple_type ~state ~inline (types : Parsetree.core_type list) cmt_tbl = + let tuple = + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typexpr -> print_typ_expr ~state typexpr cmt_tbl) + types); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ] + in + if inline == false then Doc.group tuple else tuple + +and print_object_field ~state (field : Parsetree.object_field) cmt_tbl = + match field with + | Otag (label_loc, attrs, typ) -> + let lbl = + let doc = Doc.text ("\"" ^ label_loc.txt ^ "\"") in + print_comments doc cmt_tbl label_loc.loc + in + let doc = + Doc.concat + [ + print_attributes ~state ~loc:label_loc.loc attrs cmt_tbl; + lbl; + Doc.text ": "; + print_typ_expr ~state typ cmt_tbl; + ] + in + let cmt_loc = {label_loc.loc with loc_end = typ.ptyp_loc.loc_end} in + print_comments doc cmt_tbl cmt_loc + | Oinherit typexpr -> + Doc.concat [Doc.dotdotdot; print_typ_expr ~state typexpr cmt_tbl] + +(* es6 arrow type arg + * type t = (~foo: string, ~bar: float=?, unit) => unit + * i.e. ~foo: string, ~bar: float *) +and print_type_parameter ~state {attrs; lbl; typ} cmt_tbl = + (* Converting .ml code to .res requires processing uncurried attributes *) + let attrs = print_attributes ~state attrs cmt_tbl in + let label = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Labelled {txt = lbl} -> + Doc.concat [Doc.text "~"; print_ident_like lbl; Doc.text ": "] + | Optional {txt = lbl} -> + Doc.concat [Doc.text "~"; print_ident_like lbl; Doc.text ": "] + in + let optional_indicator = + match lbl with + | Nolabel | Labelled _ -> Doc.nil + | Optional _ -> Doc.text "=?" + in + let loc = {(Asttypes.get_lbl_loc lbl) with loc_end = typ.ptyp_loc.loc_end} in + let doc = + Doc.group + (Doc.concat + [attrs; label; print_typ_expr ~state typ cmt_tbl; optional_indicator]) + in + print_comments doc cmt_tbl loc + +and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl + i = + let has_unwrap = ref false in + let attrs = + vb.pvb_attributes + |> List.filter_map (function + | {Asttypes.txt = "let.unwrap"}, _ -> + has_unwrap := true; + None + | attr -> Some attr) + in + let attrs = print_attributes ~state ~loc:vb.pvb_pat.ppat_loc attrs cmt_tbl in + let header = + if i == 0 then + Doc.concat [Doc.text (if !has_unwrap then "let? " else "let "); rec_flag] + else Doc.text "and " + in + match vb with + | { + pvb_pat = + { + ppat_desc = + Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as pat_typ)); + }; + pvb_expr = {pexp_desc = Pexp_newtype _} as expr; + } -> ( + let _, parameters, return_expr = ParsetreeViewer.fun_expr expr in + let abstract_type = + match parameters with + | [NewTypes {locs = vars}] -> + Doc.concat + [ + Doc.text "type "; + Doc.join ~sep:Doc.space + (List.map (fun var -> Doc.text var.Asttypes.txt) vars); + Doc.dot; + ] + | _ -> Doc.nil + in + match return_expr.pexp_desc with + | Pexp_constraint (expr, typ) -> + Doc.group + (Doc.concat + [ + attrs; + header; + print_pattern ~state pattern cmt_tbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstract_type; + Doc.space; + print_typ_expr ~state typ cmt_tbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + print_expression_with_comments ~state expr cmt_tbl; + ]; + ]); + ]) + | _ -> + (* Example: + * let cancel_and_collect_callbacks: + * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) + *) + Doc.group + (Doc.concat + [ + attrs; + header; + print_pattern ~state pattern cmt_tbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + abstract_type; + Doc.space; + print_typ_expr ~state pat_typ cmt_tbl; + Doc.text " ="; + Doc.concat + [ + Doc.line; + print_expression_with_comments ~state expr cmt_tbl; + ]; + ]); + ])) + | _ -> + let opt_braces, expr = ParsetreeViewer.process_braces_attr vb.pvb_expr in + let printed_expr = + let doc = print_expression_with_comments ~state vb.pvb_expr cmt_tbl in + match Parens.expr vb.pvb_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + let pattern_doc = print_pattern ~state vb.pvb_pat cmt_tbl in + (* + * we want to optimize the layout of one pipe: + * let tbl = data->Js.Array2.reduce((map, curr) => { + * ... + * }) + * important is that we don't do this for multiple pipes: + * let decoratorTags = + * items + * ->Js.Array2.filter(items => {items.category === Decorators}) + * ->Belt.Array.map(...) + * Multiple pipes chained together lend themselves more towards the last layout. + *) + if ParsetreeViewer.is_single_pipe_expr vb.pvb_expr then + Doc.custom_layout + [ + Doc.group + (Doc.concat + [ + attrs; + header; + pattern_doc; + Doc.text " ="; + Doc.space; + printed_expr; + ]); + Doc.group + (Doc.concat + [ + attrs; + header; + pattern_doc; + Doc.text " ="; + Doc.indent (Doc.concat [Doc.line; printed_expr]); + ]); + ] + else + let should_indent = + match opt_braces with + | Some _ -> false + | _ -> ( + ParsetreeViewer.is_binary_expression expr + || + match vb.pvb_expr with + | { + pexp_attributes = [({Location.txt = "res.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (if_expr, _, _); + } -> + ParsetreeViewer.is_binary_expression if_expr + || ParsetreeViewer.has_attributes if_expr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | {pexp_attributes = [({Location.txt = "res.taggedTemplate"}, _)]} -> + false + | {pexp_desc = Pexp_jsx_element _} -> true + | e -> + ParsetreeViewer.has_attributes e.pexp_attributes + || ParsetreeViewer.is_array_access e) + in + Doc.group + (Doc.concat + [ + attrs; + header; + pattern_doc; + Doc.text " ="; + (if should_indent then + Doc.indent (Doc.concat [Doc.line; printed_expr]) + else Doc.concat [Doc.space; printed_expr]); + ]) + +and print_package_type ~state ~print_module_keyword_and_parens + (package_type : Parsetree.package_type) cmt_tbl = + let doc = + match package_type with + | longident_loc, [] -> + Doc.group (Doc.concat [print_longident_location longident_loc cmt_tbl]) + | longident_loc, package_constraints -> + Doc.group + (Doc.concat + [ + print_longident_location longident_loc cmt_tbl; + print_package_constraints ~state package_constraints cmt_tbl; + Doc.soft_line; + ]) + in + if print_module_keyword_and_parens then + Doc.concat [Doc.text "module("; doc; Doc.rparen] + else doc + +and print_package_constraints ~state package_constraints cmt_tbl = + Doc.concat + [ + Doc.text " with"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.join ~sep:Doc.line + (List.mapi + (fun i pc -> + let longident, typexpr = pc in + let cmt_loc = + { + longident.Asttypes.loc with + loc_end = typexpr.Parsetree.ptyp_loc.loc_end; + } + in + let doc = print_package_constraint ~state i cmt_tbl pc in + print_comments doc cmt_tbl cmt_loc) + package_constraints); + ]); + ] + +and print_package_constraint ~state i cmt_tbl (longident_loc, typ) = + let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in + Doc.concat + [ + prefix; + print_longident_location longident_loc cmt_tbl; + Doc.text " = "; + print_typ_expr ~state typ cmt_tbl; + ] + +and print_extension ~state ~at_module_lvl (string_loc, payload) cmt_tbl = + let txt = string_loc.Location.txt in + let ext_name = + let doc = + Doc.concat + [ + Doc.text "%"; + (if at_module_lvl then Doc.text "%" else Doc.nil); + Doc.text txt; + ] + in + print_comments doc cmt_tbl string_loc.Location.loc + in + Doc.group (Doc.concat [ext_name; print_payload ~state payload cmt_tbl]) + +and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = + let pattern_without_attributes = + match p.ppat_desc with + | Ppat_any -> Doc.text "_" + | Ppat_var var -> print_ident_like var.txt + | Ppat_constant c -> + let template_literal = + ParsetreeViewer.has_template_literal_attr p.ppat_attributes + in + print_constant ~template_literal c + | Ppat_tuple patterns -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> print_pattern ~state pat cmt_tbl) + patterns); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + | Ppat_array [] -> + Doc.concat + [Doc.lbracket; print_comments_inside cmt_tbl p.ppat_loc; Doc.rbracket] + | Ppat_array patterns -> + Doc.group + (Doc.concat + [ + Doc.text "["; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun pat -> print_pattern ~state pat cmt_tbl) + patterns); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.text "]"; + ]) + | Ppat_construct ({txt = Longident.Lident "()"}, _) -> + Doc.concat + [Doc.lparen; print_comments_inside cmt_tbl p.ppat_loc; Doc.rparen] + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; print_comments_inside cmt_tbl p.ppat_loc; Doc.rbrace] + | Ppat_construct ({txt = Longident.Lident "::"}, _) -> + let patterns, tail = + ParsetreeViewer.collect_patterns_from_list_construct [] p + in + let should_hug = + match (patterns, tail) with + | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} + when ParsetreeViewer.is_huggable_pattern pat -> + true + | _ -> false + in + let children = + Doc.concat + [ + (if should_hug then Doc.nil else Doc.soft_line); + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map (fun pat -> print_pattern ~state pat cmt_tbl) patterns); + (match tail.Parsetree.ppat_desc with + | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil + | _ -> + let doc = + Doc.concat [Doc.text "..."; print_pattern ~state tail cmt_tbl] + in + let tail = print_comments doc cmt_tbl tail.ppat_loc in + Doc.concat [Doc.text ","; Doc.line; tail]); + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + (if should_hug then children + else + Doc.concat + [ + Doc.indent children; + Doc.if_breaks (Doc.text ",") Doc.nil; + Doc.soft_line; + ]); + Doc.rbrace; + ]) + | Ppat_construct (constr_name, constructor_args) -> + let constr_name = print_longident_location constr_name cmt_tbl in + let args_doc = + match constructor_args with + | None -> Doc.nil + | Some + { + ppat_loc; + ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); + } -> + Doc.concat + [Doc.lparen; print_comments_inside cmt_tbl ppat_loc; Doc.rparen] + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat [Doc.lparen; print_pattern ~state arg cmt_tbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> print_pattern ~state pat cmt_tbl) + patterns); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ] + | Some arg -> + let arg_doc = print_pattern ~state arg cmt_tbl in + let should_hug = ParsetreeViewer.is_huggable_pattern arg in + Doc.concat + [ + Doc.lparen; + (if should_hug then arg_doc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constr_name; args_doc]) + | Ppat_variant (label, None) -> + Doc.concat [Doc.text "#"; print_poly_var_ident label] + | Ppat_variant (label, variant_args) -> + let variant_name = + Doc.concat [Doc.text "#"; print_poly_var_ident label] + in + let args_doc = + match variant_args with + | None -> Doc.nil + | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] + (* Some((1, 2) *) + | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> + Doc.concat [Doc.lparen; print_pattern ~state arg cmt_tbl; Doc.rparen] + | Some {ppat_desc = Ppat_tuple patterns} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> print_pattern ~state pat cmt_tbl) + patterns); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ] + | Some arg -> + let arg_doc = print_pattern ~state arg cmt_tbl in + let should_hug = ParsetreeViewer.is_huggable_pattern arg in + Doc.concat + [ + Doc.lparen; + (if should_hug then arg_doc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variant_name; args_doc]) + | Ppat_type ident + when ParsetreeViewer.has_res_pat_variant_spread_attribute + p.ppat_attributes -> + Doc.concat [Doc.text "..."; print_ident_path ident cmt_tbl] + | Ppat_type ident -> + Doc.concat [Doc.text "#..."; print_ident_path ident cmt_tbl] + | Ppat_record (rows, _) + when ParsetreeViewer.has_dict_pattern_attribute p.ppat_attributes -> + Doc.concat + [ + Doc.text "dict{"; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (Ext_list.map rows (fun row -> + print_pattern_dict_row ~state row cmt_tbl)); + ]); + Doc.if_breaks (Doc.text ",") Doc.nil; + Doc.soft_line; + Doc.rbrace; + ] + | Ppat_record ([], Open) -> + Doc.concat [Doc.lbrace; Doc.text "_"; Doc.rbrace] + | Ppat_record (rows, open_flag) -> + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + print_pattern_record_row ~state row cmt_tbl) + rows); + (match open_flag with + | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] + | Closed -> Doc.nil); + ]); + Doc.if_breaks (Doc.text ",") Doc.nil; + Doc.soft_line; + Doc.rbrace; + ]) + | Ppat_exception p -> + let needs_parens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let pat = + let p = print_pattern ~state p cmt_tbl in + if needs_parens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) + | Ppat_or _ -> + (* Blue | Red | Green -> [Blue; Red; Green] *) + let or_chain = ParsetreeViewer.collect_or_pattern_chain p in + let docs = + List.mapi + (fun i pat -> + let pattern_doc = print_pattern ~state pat cmt_tbl in + Doc.concat + [ + (if i == 0 then Doc.nil else Doc.concat [Doc.line; Doc.text "| "]); + (match pat.ppat_desc with + (* (Blue | Red) | (Green | Black) | White *) + | Ppat_or _ -> add_parens pattern_doc + | _ -> pattern_doc); + ]) + or_chain + in + let is_spread_over_multiple_lines = + match (or_chain, List.rev or_chain) with + | first :: _, last :: _ -> + first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum + | _ -> false + in + Doc.breakable_group ~force_break:is_spread_over_multiple_lines + (Doc.concat docs) + | Ppat_extension ext -> + print_extension ~state ~at_module_lvl:false ext cmt_tbl + | Ppat_alias (p, alias_loc) -> + let needs_parens = + match p.ppat_desc with + | Ppat_or (_, _) | Ppat_alias (_, _) -> true + | _ -> false + in + let rendered_pattern = + let p = print_pattern ~state p cmt_tbl in + if needs_parens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p + in + Doc.concat + [rendered_pattern; Doc.text " as "; print_string_loc alias_loc cmt_tbl] + (* Note: module(P : S) is represented as *) + (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) + | Ppat_constraint + ( {ppat_desc = Ppat_unpack string_loc}, + {ptyp_desc = Ptyp_package package_type; ptyp_loc} ) -> + Doc.concat + [ + Doc.text "module("; + print_comments (Doc.text string_loc.txt) cmt_tbl string_loc.loc; + Doc.text ": "; + print_comments + (print_package_type ~state ~print_module_keyword_and_parens:false + package_type cmt_tbl) + cmt_tbl ptyp_loc; + Doc.rparen; + ] + | Ppat_constraint (pattern, typ) -> + Doc.concat + [ + print_pattern ~state pattern cmt_tbl; + Doc.text ": "; + print_typ_expr ~state typ cmt_tbl; + ] + (* Note: module(P : S) is represented as *) + (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) + | Ppat_unpack string_loc -> + Doc.concat + [ + Doc.text "module("; + print_comments (Doc.text string_loc.txt) cmt_tbl string_loc.loc; + Doc.rparen; + ] + | Ppat_interval (a, b) -> + Doc.concat [print_constant a; Doc.text " .. "; print_constant b] + | Ppat_open _ -> Doc.nil + in + let doc = + match p.ppat_attributes with + | [] -> pattern_without_attributes + | attrs -> + Doc.group + (Doc.concat + [print_attributes ~state attrs cmt_tbl; pattern_without_attributes]) + in + print_comments doc cmt_tbl p.ppat_loc + +and print_pattern_record_row ~state row cmt_tbl = + match row with + (* punned {x}*) + | { + lid = {Location.txt = Longident.Lident ident} as longident; + x = {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes}; + opt; + } + when ident = txt -> + Doc.concat + [ + (if opt then Doc.text "?" else Doc.nil); + print_attributes ~state ppat_attributes cmt_tbl; + print_lident_path longident cmt_tbl; + ] + | {lid = longident; x = pattern; opt} -> + let loc_for_comments = + {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} + in + let rhs_doc = + let doc = print_pattern ~state pattern cmt_tbl in + let doc = + if Parens.pattern_record_row_rhs pattern then add_parens doc else doc + in + if opt then Doc.concat [Doc.text "?"; doc] else doc + in + let doc = + Doc.group + (Doc.concat + [ + print_lident_path longident cmt_tbl; + Doc.text ":"; + (if ParsetreeViewer.is_huggable_pattern pattern then + Doc.concat [Doc.space; rhs_doc] + else Doc.indent (Doc.concat [Doc.line; rhs_doc])); + ]) + in + print_comments doc cmt_tbl loc_for_comments + +and print_pattern_dict_row ~state + ({lid = longident; x = pattern; opt} : + Parsetree.pattern Parsetree.record_element) cmt_tbl = + let loc_for_comments = + {longident.loc with loc_end = pattern.ppat_loc.loc_end} + in + let rhs_doc = + let doc = print_pattern ~state pattern cmt_tbl in + let doc = + if Parens.pattern_record_row_rhs pattern then add_parens doc else doc + in + if opt then Doc.concat [Doc.text "?"; doc] else doc + in + let lbl_doc = + Doc.concat [Doc.text "\""; print_longident longident.txt; Doc.text "\""] + in + let doc = + Doc.group + (Doc.concat + [ + lbl_doc; + Doc.text ":"; + (if ParsetreeViewer.is_huggable_pattern pattern then + Doc.concat [Doc.space; rhs_doc] + else Doc.indent (Doc.concat [Doc.line; rhs_doc])); + ]) + in + print_comments doc cmt_tbl loc_for_comments + +and print_expression_with_comments ~state expr cmt_tbl : Doc.t = + let doc = print_expression ~state expr cmt_tbl in + print_comments doc cmt_tbl expr.Parsetree.pexp_loc + +and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl = + let if_docs = + Doc.join ~sep:Doc.space + (List.mapi + (fun i (outer_loc, if_expr, then_expr) -> + let if_txt = if i > 0 then Doc.text "else if " else Doc.text "if " in + let doc = + match if_expr with + | ParsetreeViewer.If if_expr -> + let condition = + if ParsetreeViewer.is_block_expr if_expr then + print_expression_block ~state ~braces:true if_expr cmt_tbl + else + let doc = + print_expression_with_comments ~state if_expr cmt_tbl + in + match Parens.expr if_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc if_expr braces + | Nothing -> Doc.if_breaks (add_parens doc) doc + in + Doc.concat + [ + if_txt; + Doc.group condition; + Doc.space; + (let then_expr = + match ParsetreeViewer.process_braces_attr then_expr with + (* This case only happens when coming from Reason, we strip braces *) + | Some _, expr -> expr + | _ -> then_expr + in + print_expression_block ~state ~braces:true then_expr cmt_tbl); + ] + | IfLet (pattern, condition_expr) -> + let condition_doc = + let doc = + print_expression_with_comments ~state condition_expr cmt_tbl + in + match Parens.expr condition_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc condition_expr braces + | Nothing -> doc + in + Doc.concat + [ + if_txt; + Doc.text "let "; + print_pattern ~state pattern cmt_tbl; + Doc.text " = "; + condition_doc; + Doc.space; + print_expression_block ~state ~braces:true then_expr cmt_tbl; + ] + in + print_leading_comments doc cmt_tbl.leading outer_loc) + ifs) + in + let else_doc = + match else_expr with + | None -> Doc.nil + | Some expr -> + Doc.concat + [ + Doc.text " else "; + print_expression_block ~state ~braces:true expr cmt_tbl; + ] + in + let attrs = ParsetreeViewer.filter_fragile_match_attributes pexp_attributes in + Doc.concat [print_attributes ~state attrs cmt_tbl; if_docs; else_doc] + +and print_expression ~state (e : Parsetree.expression) cmt_tbl = + let print_arrow e = + let async, parameters, return_expr = ParsetreeViewer.fun_expr e in + let attrs_on_arrow = e.pexp_attributes in + let return_expr, typ_constraint = + match return_expr.pexp_desc with + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; return_expr.pexp_attributes]; + }, + Some typ ) + | _ -> (return_expr, None) + in + let has_constraint = + match typ_constraint with + | Some _ -> true + | None -> false + in + let parameters_doc = + print_expr_fun_parameters ~state ~in_callback:NoCallback ~async + ~has_constraint parameters cmt_tbl + in + let return_expr_doc = + let opt_braces, _ = ParsetreeViewer.process_braces_attr return_expr in + let should_inline = + match (return_expr.pexp_desc, opt_braces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false + in + let should_indent = + match return_expr.pexp_desc with + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ + | Pexp_jsx_element (Jsx_fragment _) -> + false + | _ -> true + in + let return_doc = + let doc = print_expression_with_comments ~state return_expr cmt_tbl in + match Parens.expr return_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc return_expr braces + | Nothing -> doc + in + if should_inline then Doc.concat [Doc.space; return_doc] + else + Doc.group + (if should_indent then Doc.indent (Doc.concat [Doc.line; return_doc]) + else Doc.concat [Doc.space; return_doc]) + in + let typ_constraint_doc = + match typ_constraint with + | Some typ -> + let typ_doc = + let doc = print_typ_expr ~state typ cmt_tbl in + if Parens.arrow_return_typ_expr typ then add_parens doc else doc + in + Doc.concat [Doc.text ": "; typ_doc] + | _ -> Doc.nil + in + let attrs = print_attributes ~state attrs_on_arrow cmt_tbl in + Doc.group + (Doc.concat + [ + attrs; + parameters_doc; + typ_constraint_doc; + Doc.text " =>"; + return_expr_doc; + ]) + in + let printed_expression = + match e.pexp_desc with + | Pexp_fun + { + arg_label = Nolabel; + default = None; + lhs = {ppat_desc = Ppat_var {txt = "__x"}}; + rhs = {pexp_desc = Pexp_apply _}; + } -> + (* (__x) => f(a, __x, c) -----> f(a, _, c) *) + print_expression_with_comments ~state + (ParsetreeViewer.rewrite_underscore_apply e) + cmt_tbl + | Pexp_fun _ | Pexp_newtype _ -> print_arrow e + | Parsetree.Pexp_constant c -> + print_constant ~template_literal:(ParsetreeViewer.is_template_literal e) c + | Pexp_jsx_element + (Jsx_fragment + { + jsx_fragment_opening = o; + jsx_fragment_children = children; + jsx_fragment_closing = c; + }) -> + print_jsx_fragment ~state o children c e.pexp_loc cmt_tbl + | Pexp_jsx_element + (Jsx_unary_element + { + jsx_unary_element_tag_name = tag_name; + jsx_unary_element_props = props; + }) -> + print_jsx_unary_tag ~state tag_name props e.pexp_loc cmt_tbl + | Pexp_jsx_element + (Jsx_container_element + { + jsx_container_element_tag_name_start = tag_name; + jsx_container_element_opening_tag_end = opening_greater_than; + jsx_container_element_props = props; + jsx_container_element_children = children; + jsx_container_element_closing_tag = closing_tag; + }) -> + print_jsx_container_tag ~state tag_name opening_greater_than props + children closing_tag e.pexp_loc cmt_tbl + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" + | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> + Doc.concat + [Doc.text "list{"; print_comments_inside cmt_tbl e.pexp_loc; Doc.rbrace] + | Pexp_construct ({txt = Longident.Lident "::"}, _) -> + let expressions, spread = ParsetreeViewer.collect_list_expressions e in + let spread_doc = + match spread with + | Some expr -> + Doc.concat + [ + Doc.text ","; + Doc.line; + Doc.dotdotdot; + (let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + print_expression_with_comments ~state expr cmt_tbl + in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + expressions); + spread_doc; + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ]) + | Pexp_construct (longident_loc, args) -> + let constr = print_longident_location longident_loc cmt_tbl in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* Some((1, 2)) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = print_expression_with_comments ~state arg cmt_tbl in + match Parens.expr arg with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + print_expression_with_comments ~state expr cmt_tbl + in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ] + | Some arg -> + let arg_doc = + let doc = print_expression_with_comments ~state arg cmt_tbl in + match Parens.expr arg with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces + | Nothing -> doc + in + let should_hug = ParsetreeViewer.is_huggable_expression arg in + Doc.concat + [ + Doc.lparen; + (if should_hug then arg_doc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [constr; args]) + | Pexp_ident path -> print_lident_path path cmt_tbl + | Pexp_tuple exprs -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + print_expression_with_comments ~state expr cmt_tbl + in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.if_breaks (Doc.text ",") Doc.nil; + Doc.soft_line; + Doc.rparen; + ]) + | Pexp_array [] -> + Doc.concat + [Doc.lbracket; print_comments_inside cmt_tbl e.pexp_loc; Doc.rbracket] + | Pexp_array exprs -> + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = + print_expression_with_comments ~state expr cmt_tbl + in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + exprs); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbracket; + ]) + | Pexp_variant (label, args) -> + let variant_name = + Doc.concat [Doc.text "#"; print_poly_var_ident label] + in + let args = + match args with + | None -> Doc.nil + | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} + -> + Doc.text "()" + (* #poly((1, 2) *) + | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> + Doc.concat + [ + Doc.lparen; + (let doc = print_expression_with_comments ~state arg cmt_tbl in + match Parens.expr arg with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces + | Nothing -> doc); + Doc.rparen; + ] + | Some {pexp_desc = Pexp_tuple args} -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun expr -> + let doc = + print_expression_with_comments ~state expr cmt_tbl + in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ] + | Some arg -> + let arg_doc = + let doc = print_expression_with_comments ~state arg cmt_tbl in + match Parens.expr arg with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces + | Nothing -> doc + in + let should_hug = ParsetreeViewer.is_huggable_expression arg in + Doc.concat + [ + Doc.lparen; + (if should_hug then arg_doc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; + ]); + Doc.rparen; + ] + in + Doc.group (Doc.concat [variant_name; args]) + | Pexp_record (rows, spread_expr) -> + if rows = [] then + Doc.concat + [Doc.lbrace; print_comments_inside cmt_tbl e.pexp_loc; Doc.rbrace] + else + let spread = + match spread_expr with + | None -> Doc.nil + | Some ({pexp_desc} as expr) -> + let doc = + match pexp_desc with + | Pexp_ident {txt = expr} -> print_lident expr + | _ -> print_expression ~state expr cmt_tbl + in + let doc_with_spread = + Doc.concat + [ + Doc.dotdotdot; + (match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc); + ] + in + Doc.concat + [ + print_comments doc_with_spread cmt_tbl expr.Parsetree.pexp_loc; + Doc.comma; + Doc.line; + ] + in + (* If the record is written over multiple lines, break automatically + * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded + * `let x = { + * a: 1, + * b: 2, + * }` -> record is written on multiple lines, break the group *) + let force_break = + match (spread_expr, rows) with + | Some expr, _ -> + (* If there's a spread, compare with spread expression's location *) + e.pexp_loc.loc_start.pos_lnum < expr.pexp_loc.loc_start.pos_lnum + | None, first_row :: _ -> + (* Otherwise, compare with the first row's location *) + e.pexp_loc.loc_start.pos_lnum < first_row.lid.loc.loc_start.pos_lnum + | None, [] -> false + in + let punning_allowed = + match (spread_expr, rows) with + | None, [_] -> false (* disallow punning for single-element records *) + | _ -> true + in + Doc.breakable_group ~force_break + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + spread; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun row -> + print_expression_record_row ~state row cmt_tbl + punning_allowed) + rows); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ]) + | Pexp_extension extension -> ( + match extension with + | ( {txt = "obj"}, + PStr + [ + { + pstr_loc = loc; + pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); + }; + ] ) -> + (* If the object is written over multiple lines, break automatically + * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded + * `let x = { + * "a": 1, + * "b": 2, + * }` -> object is written on multiple lines, break the group *) + let force_break = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in + Doc.breakable_group ~force_break + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (Ext_list.map rows (fun {lid; x = e} -> + print_bs_object_row ~state (lid, e) cmt_tbl)); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ]) + | ( {txt = "re"}, + PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_string (expr, _))}, []); + }; + ] ) -> + Doc.text expr + | extension -> + print_extension ~state ~at_module_lvl:false extension cmt_tbl) + | Pexp_apply + {funct = e; args = [(Nolabel, {pexp_desc = Pexp_array sub_lists})]} + when ParsetreeViewer.is_spread_belt_array_concat e -> + print_belt_array_concat_apply ~state sub_lists cmt_tbl + | Pexp_apply + {funct = e; args = [(Nolabel, {pexp_desc = Pexp_array sub_lists})]} + when ParsetreeViewer.is_spread_belt_list_concat e -> + print_belt_list_concat_apply ~state sub_lists cmt_tbl + | Pexp_apply {funct = call_expr; args} -> + if ParsetreeViewer.is_unary_expression e then + print_unary_expression ~state e cmt_tbl + else if ParsetreeViewer.is_template_literal e then + print_template_literal ~state e cmt_tbl + else if ParsetreeViewer.is_tagged_template_literal e then + print_tagged_template_literal ~state call_expr args cmt_tbl + else if ParsetreeViewer.is_binary_expression e then + print_binary_expression ~state e cmt_tbl + else print_pexp_apply ~state e cmt_tbl + | Pexp_field (expr, longident_loc) -> + let lhs = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.field_expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + Doc.concat [lhs; Doc.dot; print_lident_path longident_loc cmt_tbl] + | Pexp_setfield (expr1, longident_loc, expr2) -> + print_set_field_expr ~state e.pexp_attributes expr1 longident_loc expr2 + e.pexp_loc cmt_tbl + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) + when ParsetreeViewer.is_ternary_expr e -> + let parts, alternate = ParsetreeViewer.collect_ternary_parts e in + let ternary_doc = + match parts with + | (condition1, consequent1) :: rest -> + Doc.group + (Doc.concat + [ + print_ternary_operand ~state condition1 cmt_tbl; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.indent + (Doc.concat + [ + Doc.text "? "; + print_ternary_operand ~state consequent1 cmt_tbl; + ]); + Doc.concat + (List.map + (fun (condition, consequent) -> + Doc.concat + [ + Doc.line; + Doc.text ": "; + print_ternary_operand ~state condition + cmt_tbl; + Doc.line; + Doc.text "? "; + print_ternary_operand ~state consequent + cmt_tbl; + ]) + rest); + Doc.line; + Doc.text ": "; + Doc.indent + (print_ternary_operand ~state alternate cmt_tbl); + ]); + ]) + | _ -> Doc.nil + in + let attrs = ParsetreeViewer.filter_ternary_attributes e.pexp_attributes in + let needs_parens = + match ParsetreeViewer.filter_parsing_attrs attrs with + | [] -> false + | _ -> true + in + Doc.concat + [ + print_attributes ~state attrs cmt_tbl; + (if needs_parens then add_parens ternary_doc else ternary_doc); + ] + | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> + let ifs, else_expr = ParsetreeViewer.collect_if_expressions e in + print_if_chain ~state e.pexp_attributes ifs else_expr cmt_tbl + | Pexp_while (expr1, expr2) -> + let condition = + let doc = print_expression_with_comments ~state expr1 cmt_tbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr1 braces + | Nothing -> doc + in + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.text "while "; + (if ParsetreeViewer.is_block_expr expr1 then condition + else Doc.group (Doc.if_breaks (add_parens condition) condition)); + Doc.space; + print_expression_block ~state ~braces:true expr2 cmt_tbl; + ]) + | Pexp_for (pattern, from_expr, to_expr, direction_flag, body) -> + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.text "for "; + print_pattern ~state pattern cmt_tbl; + Doc.text " in "; + (let doc = + print_expression_with_comments ~state from_expr cmt_tbl + in + match Parens.expr from_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc from_expr braces + | Nothing -> doc); + print_direction_flag direction_flag; + (let doc = print_expression_with_comments ~state to_expr cmt_tbl in + match Parens.expr to_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc to_expr braces + | Nothing -> doc); + Doc.space; + print_expression_block ~state ~braces:true body cmt_tbl; + ]) + | Pexp_constraint + ( {pexp_desc = Pexp_pack mod_expr}, + {ptyp_desc = Ptyp_package package_type; ptyp_loc} ) -> + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + print_mod_expr ~state mod_expr cmt_tbl; + Doc.text ": "; + print_comments + (print_package_type ~state + ~print_module_keyword_and_parens:false package_type + cmt_tbl) + cmt_tbl ptyp_loc; + ]); + Doc.soft_line; + Doc.rparen; + ]) + | Pexp_constraint (expr, typ) -> + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + Doc.concat [expr_doc; Doc.text ": "; print_typ_expr ~state typ cmt_tbl] + | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> + print_expression_block ~state ~braces:true e cmt_tbl + | Pexp_letexception (_extensionConstructor, _expr) -> + print_expression_block ~state ~braces:true e cmt_tbl + | Pexp_assert expr -> + let expr = print_expression_with_comments ~state expr cmt_tbl in + Doc.concat [Doc.text "assert("; expr; Doc.text ")"] + | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> + print_expression_block ~state ~braces:true e cmt_tbl + | Pexp_pack mod_expr -> + Doc.group + (Doc.concat + [ + Doc.text "module("; + Doc.indent + (Doc.concat + [Doc.soft_line; print_mod_expr ~state mod_expr cmt_tbl]); + Doc.soft_line; + Doc.rparen; + ]) + | Pexp_sequence _ -> print_expression_block ~state ~braces:true e cmt_tbl + | Pexp_let _ -> print_expression_block ~state ~braces:true e cmt_tbl + | Pexp_try (expr, cases) -> + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "try "; + expr_doc; + Doc.text " catch "; + print_cases ~state cases cmt_tbl; + ] + | Pexp_match (_, [_; _]) when ParsetreeViewer.is_if_let_expr e -> + let ifs, else_expr = ParsetreeViewer.collect_if_expressions e in + print_if_chain ~state e.pexp_attributes ifs else_expr cmt_tbl + | Pexp_match (expr, cases) -> + let expr_doc = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + Doc.concat + [ + Doc.text "switch "; + expr_doc; + Doc.space; + print_cases ~state cases cmt_tbl; + ] + | Pexp_coerce (expr, (), typ) -> + let doc_expr = print_expression_with_comments ~state expr cmt_tbl in + let doc_typ = print_typ_expr ~state typ cmt_tbl in + Doc.concat [Doc.lparen; doc_expr; Doc.text " :> "; doc_typ; Doc.rparen] + | Pexp_send (parent_expr, label) -> + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces + | Nothing -> doc + in + let member = + let member_doc = + print_comments (Doc.text label.txt) cmt_tbl label.loc + in + Doc.concat [Doc.text "\""; member_doc; Doc.text "\""] + in + Doc.group (Doc.concat [parent_doc; Doc.lbracket; member; Doc.rbracket]) + | Pexp_await e -> + let printed_expression = + print_expression_with_comments ~state e cmt_tbl + in + let rhs = + match + Parens.assert_or_await_expr_rhs ~in_await:true + { + e with + pexp_attributes = + List.filter + (function + | {Location.txt = "res.braces" | "ns.braces"}, _ -> false + | _ -> true) + e.pexp_attributes; + } + with + | Parens.Parenthesized -> add_parens printed_expression + | Braced braces -> print_braces printed_expression e braces + | Nothing -> printed_expression + in + Doc.concat [Doc.text "await "; rhs] + in + let should_print_its_own_attributes = + match e.pexp_desc with + | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ + | Pexp_ifthenelse _ -> + true + | Pexp_match _ when ParsetreeViewer.is_if_let_expr e -> true + | Pexp_jsx_element _ -> true + | _ -> false + in + match e.pexp_attributes with + | [] -> printed_expression + | attrs when not should_print_its_own_attributes -> + Doc.group + (Doc.concat [print_attributes ~state attrs cmt_tbl; printed_expression]) + | _ -> printed_expression + +and print_pexp_fun ~state ~in_callback e cmt_tbl = + let async, parameters, return_expr = ParsetreeViewer.fun_expr e in + let attrs_on_arrow = e.pexp_attributes in + let return_expr, typ_constraint = + match return_expr.pexp_desc with + | Pexp_constraint (expr, typ) -> + ( { + expr with + pexp_attributes = + List.concat [expr.pexp_attributes; return_expr.pexp_attributes]; + }, + Some typ ) + | _ -> (return_expr, None) + in + let parameters_doc = + print_expr_fun_parameters ~state ~in_callback ~async + ~has_constraint: + (match typ_constraint with + | Some _ -> true + | None -> false) + parameters cmt_tbl + in + let return_should_indent = + match return_expr.pexp_desc with + | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ + | Pexp_open _ -> + false + | _ -> true + in + let return_expr_doc = + let opt_braces, _ = ParsetreeViewer.process_braces_attr return_expr in + let should_inline = + match (return_expr.pexp_desc, opt_braces) with + | _, Some _ -> true + | ( ( Pexp_array _ | Pexp_tuple _ + | Pexp_construct (_, Some _) + | Pexp_record _ ), + _ ) -> + true + | _ -> false + in + let return_doc = + let doc = print_expression_with_comments ~state return_expr cmt_tbl in + match Parens.expr return_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc return_expr braces + | Nothing -> doc + in + if should_inline then Doc.concat [Doc.space; return_doc] + else + Doc.group + (if return_should_indent then + Doc.concat + [ + Doc.indent (Doc.concat [Doc.line; return_doc]); + (match in_callback with + | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.soft_line + | _ -> Doc.nil); + ] + else Doc.concat [Doc.space; return_doc]) + in + let typ_constraint_doc = + match typ_constraint with + | Some typ -> Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl] + | _ -> Doc.nil + in + Doc.concat + [ + print_attributes ~state attrs_on_arrow cmt_tbl; + parameters_doc; + typ_constraint_doc; + Doc.text " =>"; + return_expr_doc; + ] + +and print_ternary_operand ~state expr cmt_tbl = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.ternary_operand expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + +and print_set_field_expr ~state attrs lhs longident_loc rhs loc cmt_tbl = + let rhs_doc = + let doc = print_expression_with_comments ~state rhs cmt_tbl in + match Parens.set_field_expr_rhs rhs with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc rhs braces + | Nothing -> doc + in + let lhs_doc = + let doc = print_expression_with_comments ~state lhs cmt_tbl in + match Parens.field_expr lhs with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc lhs braces + | Nothing -> doc + in + let should_indent = ParsetreeViewer.is_binary_expression rhs in + let doc = + Doc.group + (Doc.concat + [ + lhs_doc; + Doc.dot; + print_lident_path longident_loc cmt_tbl; + Doc.text " ="; + (if should_indent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) + else Doc.concat [Doc.space; rhs_doc]); + ]) + in + let doc = + match attrs with + | [] -> doc + | attrs -> + Doc.group (Doc.concat [print_attributes ~state attrs cmt_tbl; doc]) + in + print_comments doc cmt_tbl loc + +and print_template_literal ~state expr cmt_tbl = + let tag = ref "js" in + let rec walk_expr expr = + let open Parsetree in + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "++"}}; + args = [(Nolabel, arg1); (Nolabel, arg2)]; + } -> + let lhs = walk_expr arg1 in + let rhs = walk_expr arg2 in + Doc.concat [lhs; rhs] + | Pexp_constant (Pconst_string (txt, Some prefix)) -> + tag := prefix; + print_string_contents txt + | _ -> + let doc = print_expression_with_comments ~state expr cmt_tbl in + let doc = + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) + in + let content = walk_expr expr in + Doc.concat + [ + (if !tag = "js" then Doc.nil else Doc.text !tag); + Doc.text "`"; + content; + Doc.text "`"; + ] + +and print_tagged_template_literal ~state call_expr args cmt_tbl = + let strings_list, values_list = + match args with + | [ + (_, {Parsetree.pexp_desc = Pexp_array strings}); + (_, {Parsetree.pexp_desc = Pexp_array values}); + ] -> + (strings, values) + | _ -> assert false + in + + let strings = + List.map + (fun x -> + match x with + | {Parsetree.pexp_desc = Pexp_constant (Pconst_string (txt, _))} -> + print_string_contents txt + | _ -> assert false) + strings_list + in + + let values = + List.map + (fun x -> + Doc.concat + [ + Doc.text "${"; + print_expression_with_comments ~state x cmt_tbl; + Doc.text "}"; + ]) + values_list + in + + let process strings values = + let rec aux acc = function + | [], [] -> acc + | a_head :: a_rest, b -> aux (Doc.concat [acc; a_head]) (b, a_rest) + | _ -> assert false + in + aux Doc.nil (strings, values) + in + + let content : Doc.t = process strings values in + + let tag = print_expression_with_comments ~state call_expr cmt_tbl in + Doc.concat [tag; Doc.text "`"; content; Doc.text "`"] + +and print_unary_expression ~state expr cmt_tbl = + let print_unary_operator op = + Doc.text + (match op with + | "~+" -> "+" + | "~+." -> "+." + | "~-" -> "-" + | "~-." -> "-." + | "~~~" -> "~~~" + | "not" -> "!" + | _ -> assert false) + in + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}; + args = [(Nolabel, operand)]; + } -> + let printed_operand = + let doc = print_expression_with_comments ~state operand cmt_tbl in + match Parens.unary_expr_operand operand with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc operand braces + | Nothing -> doc + in + let doc = Doc.concat [print_unary_operator operator; printed_operand] in + print_comments doc cmt_tbl expr.pexp_loc + | _ -> assert false + +and print_binary_expression ~state (expr : Parsetree.expression) cmt_tbl = + let print_binary_operator ~inline_rhs operator = + let spacing_before_operator = + if operator = "->" then Doc.soft_line else Doc.space + in + let spacing_after_operator = + if operator = "->" then Doc.nil + else if inline_rhs then Doc.space + else Doc.line + in + Doc.concat + [spacing_before_operator; Doc.text operator; spacing_after_operator] + in + let print_operand ~is_lhs ~is_multiline expr parent_operator = + let rec flatten ~is_lhs ~is_multiline expr parent_operator = + if ParsetreeViewer.is_binary_expression expr then + match expr with + | { + pexp_desc = + Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}; + args = [(_, left); (_, right)]; + }; + } -> + if + ParsetreeViewer.flattenable_operators parent_operator operator + && not (ParsetreeViewer.has_attributes expr.pexp_attributes) + then + let left_printed = + flatten ~is_lhs:true ~is_multiline left operator + in + let right_printed = + let right_printeable_attrs, right_internal_attrs = + ParsetreeViewer.partition_printable_attributes + right.pexp_attributes + in + let doc = + print_expression_with_comments ~state + {right with pexp_attributes = right_internal_attrs} + cmt_tbl + in + let doc = + if Parens.flatten_operand_rhs parent_operator right then + Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + let doc = + Doc.concat + [print_attributes ~state right_printeable_attrs cmt_tbl; doc] + in + match right_printeable_attrs with + | [] -> doc + | _ -> add_parens doc + in + let doc = + if ParsetreeViewer.expr_is_await expr then + let parens = + Res_parens.binary_operator_inside_await_needs_parens operator + in + Doc.concat + [ + Doc.lparen; + Doc.text "await "; + (if parens then Doc.lparen else Doc.nil); + left_printed; + print_binary_operator ~inline_rhs:false operator; + right_printed; + (if parens then Doc.rparen else Doc.nil); + Doc.rparen; + ] + else + match operator with + | "->" when is_multiline -> + (* If the pipe-chain is written over multiple lines, break automatically + * `let x = a->b->c -> same line, break when line-width exceeded + * `let x = a-> + * b->c` -> pipe-chain is written on multiple lines, break the group *) + Doc.breakable_group ~force_break:true + (Doc.concat + [ + left_printed; + print_binary_operator ~inline_rhs:false operator; + right_printed; + ]) + | _ -> + Doc.concat + [ + left_printed; + print_binary_operator ~inline_rhs:false operator; + right_printed; + ] + in + + let doc = + if (not is_lhs) && Parens.rhs_binary_expr_operand operator expr + then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + print_comments doc cmt_tbl expr.pexp_loc + else + let printeable_attrs, internal_attrs = + ParsetreeViewer.partition_printable_attributes + expr.pexp_attributes + in + let doc = + print_expression_with_comments ~state + {expr with pexp_attributes = internal_attrs} + cmt_tbl + in + let doc = + if + Parens.sub_binary_expr_operand parent_operator operator + || printeable_attrs <> [] + && (ParsetreeViewer.is_binary_expression expr + || ParsetreeViewer.is_ternary_expr expr) + then Doc.concat [Doc.lparen; doc; Doc.rparen] + else doc + in + Doc.concat [print_attributes ~state printeable_attrs cmt_tbl; doc] + | _ -> assert false + else + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "++"; loc}}; + args = [(Nolabel, _); (Nolabel, _)]; + } + when loc.loc_ghost -> + let doc = print_template_literal ~state expr cmt_tbl in + print_comments doc cmt_tbl expr.Parsetree.pexp_loc + | Pexp_setfield (lhs, field, rhs) -> + let doc = + print_set_field_expr ~state expr.pexp_attributes lhs field rhs + expr.pexp_loc cmt_tbl + in + if is_lhs then add_parens doc else doc + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}; + args = [(Nolabel, lhs); (Nolabel, rhs)]; + } -> + let rhs_doc = print_expression_with_comments ~state rhs cmt_tbl in + let lhs_doc = print_expression_with_comments ~state lhs cmt_tbl in + (* TODO: unify indentation of "=" *) + let should_indent = ParsetreeViewer.is_binary_expression rhs in + let doc = + Doc.group + (Doc.concat + [ + lhs_doc; + Doc.text " ="; + (if should_indent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) + else Doc.concat [Doc.space; rhs_doc]); + ]) + in + let doc = + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group + (Doc.concat [print_attributes ~state attrs cmt_tbl; doc]) + in + if is_lhs then add_parens doc else doc + | _ -> ( + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.binary_expr_operand ~is_lhs expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + in + flatten ~is_lhs ~is_multiline expr parent_operator + in + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident ("->" as op)}}; + args = [(Nolabel, lhs); (Nolabel, rhs)]; + } + when not + (ParsetreeViewer.is_binary_expression lhs + || ParsetreeViewer.is_binary_expression rhs + || print_attributes ~state expr.pexp_attributes cmt_tbl <> Doc.nil) + -> + let lhs_has_comment_below = has_comment_below cmt_tbl lhs.pexp_loc in + let lhs_doc = print_operand ~is_lhs:true ~is_multiline:false lhs op in + (* For pipe RHS, use pipe-specific rewrite to omit redundant first underscore *) + let rhs = + if op = "->" then ParsetreeViewer.rewrite_underscore_apply_in_pipe rhs + else rhs + in + let rhs_doc = print_operand ~is_lhs:false ~is_multiline:false rhs op in + Doc.group + (Doc.concat + [ + print_attributes ~state expr.pexp_attributes cmt_tbl; + lhs_doc; + (match (lhs_has_comment_below, op) with + | true, "->" -> Doc.concat [Doc.soft_line; Doc.text "->"] + | false, "->" -> Doc.text "->" + | _ -> Doc.nil); + rhs_doc; + ]) + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}; + args = [(Nolabel, lhs); (Nolabel, rhs)]; + } -> + let is_multiline = + lhs.pexp_loc.loc_start.pos_lnum < rhs.pexp_loc.loc_start.pos_lnum + in + + let right = + let operator_with_rhs = + let rhs_doc = + print_operand + ~is_lhs:(ParsetreeViewer.is_rhs_binary_operator operator) + ~is_multiline rhs operator + in + Doc.concat + [ + print_binary_operator + ~inline_rhs:(ParsetreeViewer.should_inline_rhs_binary_expr rhs) + operator; + rhs_doc; + ] + in + if ParsetreeViewer.should_indent_binary_expr expr then + Doc.group (Doc.indent operator_with_rhs) + else operator_with_rhs + in + let doc = + Doc.group + (Doc.concat + [ + print_operand + ~is_lhs:(not @@ ParsetreeViewer.is_rhs_binary_operator operator) + ~is_multiline lhs operator; + right; + ]) + in + Doc.group + (Doc.concat + [ + print_attributes ~state expr.pexp_attributes cmt_tbl; + (match + Parens.binary_expr + { + expr with + pexp_attributes = + ParsetreeViewer.filter_printable_attributes + expr.pexp_attributes; + } + with + | Braced braces_loc -> print_braces doc expr braces_loc + | Parenthesized -> add_parens doc + | Nothing -> doc); + ]) + | _ -> Doc.nil + +and print_belt_array_concat_apply ~state sub_lists cmt_tbl = + let make_spread_doc comma_before_spread = function + | Some expr -> + (* Extract leading comments before dotdotdot *) + let leading_comments_doc = + print_leading_comments Doc.nil cmt_tbl.CommentTable.leading + expr.Parsetree.pexp_loc + in + (* Print expression without leading comments (they're already extracted) *) + let expr_doc = + let doc = print_expression ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + (* Print trailing comments with the expression *) + let expr_with_trailing_comments = + print_trailing_comments expr_doc cmt_tbl.CommentTable.trailing + expr.Parsetree.pexp_loc + in + Doc.concat + [ + comma_before_spread; + leading_comments_doc; + Doc.dotdotdot; + expr_with_trailing_comments; + ] + | None -> Doc.nil + in + let make_sub_list_doc (expressions, spread) = + let comma_before_spread = + match expressions with + | [] -> Doc.nil + | _ -> Doc.concat [Doc.text ","; Doc.line] + in + let spread_doc = make_spread_doc comma_before_spread spread in + let expressions_doc = + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + expressions) + in + Doc.concat [expressions_doc; spread_doc] + in + Doc.group + (Doc.concat + [ + Doc.lbracket; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map make_sub_list_doc + (List.map ParsetreeViewer.collect_array_expressions + sub_lists)); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbracket; + ]) + +and print_belt_list_concat_apply ~state sub_lists cmt_tbl = + let make_spread_doc comma_before_spread = function + | Some expr -> + Doc.concat + [ + comma_before_spread; + Doc.dotdotdot; + (let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc); + ] + | None -> Doc.nil + in + let make_sub_list_doc (expressions, spread) = + let comma_before_spread = + match expressions with + | [] -> Doc.nil + | _ -> Doc.concat [Doc.text ","; Doc.line] + in + let spread_doc = make_spread_doc comma_before_spread spread in + Doc.concat + [ + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map + (fun expr -> + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc) + expressions); + spread_doc; + ] + in + Doc.group + (Doc.concat + [ + Doc.text "list{"; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.text ","; Doc.line]) + (List.map make_sub_list_doc + (List.map ParsetreeViewer.collect_list_expressions + sub_lists)); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rbrace; + ]) + +(* callExpr(arg1, arg2) *) +and print_pexp_apply ~state expr cmt_tbl = + match expr.pexp_desc with + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}; + args = [(Nolabel, parent_expr); (Nolabel, member_expr)]; + } -> + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces + | Nothing -> doc + in + let member = + let member_doc = + match member_expr.pexp_desc with + | Pexp_ident lident -> + print_comments + (print_longident lident.txt) + cmt_tbl member_expr.pexp_loc + | _ -> print_expression_with_comments ~state member_expr cmt_tbl + in + Doc.concat [Doc.text "\""; member_doc; Doc.text "\""] + in + Doc.group + (Doc.concat + [ + print_attributes ~state expr.pexp_attributes cmt_tbl; + parent_doc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + { + funct = {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}; + args = [(Nolabel, lhs); (Nolabel, rhs)]; + } -> ( + let rhs_doc = + let doc = print_expression_with_comments ~state rhs cmt_tbl in + match Parens.expr rhs with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc rhs braces + | Nothing -> doc + in + (* TODO: unify indentation of "=" *) + let should_indent = + (not (ParsetreeViewer.is_braced_expr rhs)) + && ParsetreeViewer.is_binary_expression rhs + in + let doc = + Doc.group + (Doc.concat + [ + print_expression_with_comments ~state lhs cmt_tbl; + Doc.text " ="; + (if should_indent then + Doc.group (Doc.indent (Doc.concat [Doc.line; rhs_doc])) + else Doc.concat [Doc.space; rhs_doc]); + ]) + in + match expr.pexp_attributes with + | [] -> doc + | attrs -> + Doc.group (Doc.concat [print_attributes ~state attrs cmt_tbl; doc])) + | Pexp_apply + { + funct = + { + pexp_desc = + Pexp_ident + {txt = Longident.Ldot (Lident "Primitive_dict", "make")}; + }; + args = [(Nolabel, key_values)]; + } + when Res_parsetree_viewer.is_tuple_array key_values -> + Doc.concat + [ + Doc.text "dict{"; + print_comments_inside cmt_tbl expr.pexp_loc; + print_literal_dict_expr ~state key_values cmt_tbl; + Doc.rbrace; + ] + | Pexp_apply + { + funct = + { + pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}; + }; + args = [(Nolabel, parent_expr); (Nolabel, member_expr)]; + } + when not (ParsetreeViewer.is_rewritten_underscore_apply_sugar parent_expr) + -> + (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) + let member = + let member_doc = + let doc = print_expression_with_comments ~state member_expr cmt_tbl in + match Parens.expr member_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc member_expr braces + | Nothing -> doc + in + let should_inline = + match member_expr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if should_inline then member_doc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.soft_line; member_doc]); Doc.soft_line] + in + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + print_attributes ~state expr.pexp_attributes cmt_tbl; + parent_doc; + Doc.lbracket; + member; + Doc.rbracket; + ]) + | Pexp_apply + { + funct = + { + pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}; + }; + args = + [ + (Nolabel, parent_expr); + (Nolabel, member_expr); + (Nolabel, target_expr); + ]; + } -> + let member = + let member_doc = + let doc = print_expression_with_comments ~state member_expr cmt_tbl in + match Parens.expr member_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc member_expr braces + | Nothing -> doc + in + let should_inline = + match member_expr.pexp_desc with + | Pexp_constant _ | Pexp_ident _ -> true + | _ -> false + in + if should_inline then member_doc + else + Doc.concat + [Doc.indent (Doc.concat [Doc.soft_line; member_doc]); Doc.soft_line] + in + let should_indent_target_expr = + if ParsetreeViewer.is_braced_expr target_expr then false + else + ParsetreeViewer.is_binary_expression target_expr + || + match target_expr with + | { + pexp_attributes = [({Location.txt = "res.ternary"}, _)]; + pexp_desc = Pexp_ifthenelse (if_expr, _, _); + } -> + ParsetreeViewer.is_binary_expression if_expr + || ParsetreeViewer.has_attributes if_expr.pexp_attributes + | {pexp_desc = Pexp_newtype _} -> false + | e -> + ParsetreeViewer.has_attributes e.pexp_attributes + || ParsetreeViewer.is_array_access e + in + let target_expr = + let doc = print_expression_with_comments ~state target_expr cmt_tbl in + match Parens.expr target_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc target_expr braces + | Nothing -> doc + in + let parent_doc = + let doc = print_expression_with_comments ~state parent_expr cmt_tbl in + match Parens.unary_expr_operand parent_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc parent_expr braces + | Nothing -> doc + in + Doc.group + (Doc.concat + [ + print_attributes ~state expr.pexp_attributes cmt_tbl; + parent_doc; + Doc.lbracket; + member; + Doc.rbracket; + Doc.text " ="; + (if should_indent_target_expr then + Doc.indent (Doc.concat [Doc.line; target_expr]) + else Doc.concat [Doc.space; target_expr]); + ]) + | Pexp_apply {funct = call_expr; args; partial} -> + let args = + List.map + (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewrite_underscore_apply arg)) + args + in + let attrs = expr.pexp_attributes in + let args = + if partial then + let dummy = Ast_helper.Exp.constant ~attrs (Ast_helper.Const.int 0) in + args @ [(Asttypes.Labelled {txt = "..."; loc = Location.none}, dummy)] + else args + in + let call_expr_doc = + let doc = print_expression_with_comments ~state call_expr cmt_tbl in + match Parens.call_expr call_expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc call_expr braces + | Nothing -> doc + in + if ParsetreeViewer.requires_special_callback_printing_first_arg args then + let args_doc = + print_arguments_with_callback_in_first_position ~state ~partial args + cmt_tbl + in + Doc.concat + [print_attributes ~state attrs cmt_tbl; call_expr_doc; args_doc] + else if ParsetreeViewer.requires_special_callback_printing_last_arg args + then + let args_doc = + print_arguments_with_callback_in_last_position ~state ~partial args + cmt_tbl + in + (* + * Fixes the following layout (the `[` and `]` should break): + * [fn(x => { + * let _ = x + * }), fn(y => { + * let _ = y + * }), fn(z => { + * let _ = z + * })] + * See `Doc.willBreak documentation in interface file for more context. + * Context: + * https://github.com/rescript-lang/syntax/issues/111 + * https://github.com/rescript-lang/syntax/issues/166 + *) + let maybe_break_parent = + if Doc.will_break args_doc then Doc.break_parent else Doc.nil + in + Doc.concat + [ + maybe_break_parent; + print_attributes ~state attrs cmt_tbl; + call_expr_doc; + args_doc; + ] + else + let args_doc = print_arguments ~state ~partial args cmt_tbl in + Doc.concat + [print_attributes ~state attrs cmt_tbl; call_expr_doc; args_doc] + | _ -> assert false + +and print_jsx_unary_tag ~state tag_name props expr_loc cmt_tbl = + let name = print_jsx_name tag_name.txt in + let formatted_props = print_jsx_props ~state props cmt_tbl in + let tag_loc = tag_name.loc in + let tag_has_trailing_comment = has_trailing_comments cmt_tbl tag_loc in + let tag_has_no_props = List.length props == 0 in + let closing_token_loc = + ParsetreeViewer.unary_element_closing_token expr_loc + in + let props_doc = + if tag_has_no_props then + if has_leading_comments cmt_tbl closing_token_loc then Doc.soft_line + else if tag_has_trailing_comment then Doc.nil + else Doc.space + else + Doc.concat + [ + Doc.indent + (Doc.concat + [Doc.line; Doc.group (Doc.join ~sep:Doc.line formatted_props)]); + Doc.line; + ] + in + let opening_tag = + print_comments (Doc.concat [Doc.less_than; name]) cmt_tbl tag_loc + in + let opening_tag_doc = + if tag_has_trailing_comment && not tag_has_no_props then + Doc.indent opening_tag + else opening_tag + in + let closing_tag_doc = + print_comments (Doc.text "/>") cmt_tbl closing_token_loc + in + Doc.group + (Doc.concat + [ + opening_tag_doc; + props_doc; + (if tag_has_trailing_comment && tag_has_no_props then Doc.space + else Doc.nil); + closing_tag_doc; + ]) + +and print_jsx_container_tag ~state tag_name + (opening_greater_than : Lexing.position) props + (children : Parsetree.jsx_children) + (closing_tag : Parsetree.jsx_closing_container_tag option) + (pexp_loc : Location.t) cmt_tbl = + let name = print_jsx_name tag_name.txt in + let opening_greater_than_loc = + { + Warnings.loc_start = opening_greater_than; + loc_end = opening_greater_than; + loc_ghost = false; + } + in + let _opening_greater_than_has_leading_comments, opening_greater_than_doc = + let has_leading_comments = + has_leading_comments cmt_tbl opening_greater_than_loc + in + ( has_leading_comments, + print_comments Doc.greater_than cmt_tbl opening_greater_than_loc ) + in + let formatted_props = print_jsx_props ~state props cmt_tbl in + (*
*) + let has_children = + match children with + | _ :: _ -> true + | [] -> false + in + let line_sep = get_line_sep_for_jsx_children children in + let print_children children = + Doc.concat + [ + Doc.indent + (Doc.concat [Doc.line; print_jsx_children ~state children cmt_tbl]); + line_sep; + ] + in + + (* comments between the opening and closing tag *) + let has_comments_inside = has_comments_inside cmt_tbl pexp_loc in + let closing_element_doc = + match closing_tag with + | None -> Doc.nil + | Some closing_tag -> + let closing_tag_loc = + ParsetreeViewer.container_element_closing_tag_loc closing_tag + in + let closing_name = + print_jsx_name closing_tag.jsx_closing_container_tag_name.txt + in + print_comments + (Doc.concat [Doc.text "' *) + if has_trailing_single_line_comment cmt_tbl tag_loc then + Doc.concat [Doc.hard_line; opening_greater_than_doc] + else Doc.concat [Doc.soft_line; opening_greater_than_doc] + in + Doc.concat + [ + opening_tag_name_doc; + props_block_doc; + after_name_and_props_doc; + ]); + ]); + Doc.concat + [ + (if has_children then print_children children + else if not has_comments_inside then Doc.soft_line + else print_comments_inside cmt_tbl pexp_loc); + closing_element_doc; + ]; + ]) + +and print_jsx_fragment ~state (opening_greater_than : Lexing.position) + (children : Parsetree.jsx_children) (closing_lesser_than : Lexing.position) + (fragment_loc : Warnings.loc) cmt_tbl = + let opening = + let loc : Location.t = {fragment_loc with loc_end = opening_greater_than} in + print_comments (Doc.text "<>") cmt_tbl loc + in + let closing = + let loc : Location.t = + {fragment_loc with loc_start = closing_lesser_than} + in + print_comments (Doc.text "") cmt_tbl loc + in + let has_children = + match children with + | [] -> false + | _ :: _ -> true + in + let line_sep = get_line_sep_for_jsx_children children in + Doc.group + (Doc.concat + [ + opening; + Doc.indent + (Doc.concat [Doc.line; print_jsx_children ~state children cmt_tbl]); + (if has_children then line_sep else Doc.nil); + closing; + ]) + +and get_line_sep_for_jsx_children (children : Parsetree.jsx_children) = + if + List.length children > 1 + || List.exists + (function + | {Parsetree.pexp_desc = Pexp_jsx_element _} -> true + | _ -> false) + children + then Doc.hard_line + else Doc.line + +and print_jsx_children ~state (children : Parsetree.jsx_children) cmt_tbl = + let open Parsetree in + let get_loc (expr : Parsetree.expression) = + let braces = + expr.pexp_attributes + |> List.find_map (fun (attr, _) -> + match attr with + | {Location.txt = "res.braces"; loc} -> Some loc + | _ -> None) + in + match braces with + | None -> expr.pexp_loc + | Some loc -> loc + in + let sep = get_line_sep_for_jsx_children children in + let print_expr (expr : Parsetree.expression) = + let leading_line_comment_present = + has_leading_line_comment cmt_tbl expr.pexp_loc + in + let expr_doc = print_expression_with_comments ~state expr cmt_tbl in + let add_parens_or_braces expr_doc = + (* {(20: int)} make sure that we also protect the expression inside *) + let inner_doc = + if Parens.braced_expr expr then add_parens expr_doc else expr_doc + in + if leading_line_comment_present then add_braces inner_doc + else Doc.concat [Doc.lbrace; inner_doc; Doc.rbrace] + in + match Parens.jsx_child_expr expr with + | Nothing -> print_comments expr_doc cmt_tbl (get_loc expr) + | Parenthesized -> add_parens_or_braces expr_doc + | Braced braces_loc -> + print_comments (add_parens_or_braces expr_doc) cmt_tbl braces_loc + in + match children with + | [] -> Doc.nil + | children -> + let rec visit acc children = + match children with + | [] -> acc + | [x] -> Doc.concat [acc; print_expr x] + | x :: (y :: _ as rest) -> + let end_line_x = + let loc = get_loc x in + loc.loc_end.pos_lnum + in + let start_line_y = + let loc = get_loc y in + loc.loc_start.pos_lnum + in + let lines_between = start_line_y - end_line_x - 1 in + let leading_single_line_comments = + get_leading_line_comment_count cmt_tbl (get_loc y) + in + (* If there are lines between the jsx elements, we preserve at least one line *) + if + (* Unless they are all comments *) + (* The edge case of comment followed by blank line is not caught here *) + lines_between > 0 && not (lines_between = leading_single_line_comments) + then + let doc = Doc.concat [print_expr x; sep; Doc.hard_line] in + visit (Doc.concat [acc; doc]) rest + else + let doc = Doc.concat [print_expr x; sep] in + visit (Doc.concat [acc; doc]) rest + in + visit Doc.nil children + +and print_jsx_prop ~state prop cmt_tbl = + let open Parsetree in + let prop_loc = ParsetreeViewer.get_jsx_prop_loc prop in + let doc = + match prop with + | JSXPropPunning (is_optional, name) -> + (* We don't print any comments here because they will be attached to the entire prop_loc *) + if is_optional then Doc.concat [Doc.question; print_ident_like name.txt] + else print_ident_like name.txt + | JSXPropValue (name, is_optional, value) -> + let has_trailing_comment_after_name = + has_trailing_single_line_comment cmt_tbl name.loc + in + let value_doc = + let leading_line_comment_present = + (* If the value expression has braces, these will be representend as an attribute containing the brace range *) + (* comment assignment is a little weird that this point, it will be assigned to a child node of the value expression *) + match (Parens.jsx_prop_expr value, value.pexp_desc) with + | ( Braced _, + Parsetree.Pexp_apply {funct = fun_expr; args = (_, head_arg) :: _} + ) -> + has_leading_line_comment cmt_tbl fun_expr.pexp_loc + || has_leading_line_comment cmt_tbl head_arg.pexp_loc + | _ -> has_leading_line_comment cmt_tbl value.pexp_loc + in + let doc = print_expression_with_comments ~state value cmt_tbl in + match Parens.jsx_prop_expr value with + | Parenthesized | Braced _ -> + (* {(20: int)} make sure that we also protect the expression inside *) + let inner_doc = + if Parens.braced_expr value then add_parens doc else doc + in + if leading_line_comment_present then add_braces inner_doc + else Doc.concat [Doc.lbrace; inner_doc; Doc.rbrace] + | _ -> doc + in + let doc = + Doc.concat + [ + print_comments (print_ident_like name.txt) cmt_tbl name.loc; + Doc.equal; + (if is_optional then Doc.question else Doc.nil); + (if has_trailing_comment_after_name then Doc.hard_line else Doc.nil); + Doc.group value_doc; + ] + in + print_comments doc cmt_tbl value.pexp_loc + | JSXPropSpreading (_, value) -> + Doc.group + (Doc.concat + [ + Doc.lbrace; + Doc.dotdotdot; + print_expression_with_comments ~state value cmt_tbl; + Doc.rbrace; + ]) + in + print_comments doc cmt_tbl prop_loc + +and print_jsx_props ~state props cmt_tbl : Doc.t list = + props |> List.map (fun prop -> print_jsx_prop ~state prop cmt_tbl) + +and print_jsx_name (tag_name : Parsetree.jsx_tag_name) = + match tag_name with + | Parsetree.JsxTagInvalid invalid -> + (* Preserve exactly what the parser recorded as invalid *) + Doc.text invalid + | Parsetree.JsxLowerTag name -> + print_ident_like ~allow_uident:true ~allow_hyphen:true name + | Parsetree.JsxQualifiedLowerTag {path; name} -> + let upper_segs = Longident.flatten path in + let printed_upper = + upper_segs |> List.map (print_ident_like ~allow_uident:true) + in + let printed_lower = + print_ident_like ~allow_uident:true ~allow_hyphen:true name + in + Doc.join ~sep:Doc.dot (printed_upper @ [printed_lower]) + | Parsetree.JsxUpperTag path -> + let segs = Longident.flatten path in + let printed = segs |> List.map (print_ident_like ~allow_uident:true) in + Doc.join ~sep:Doc.dot printed + +and print_arguments_with_callback_in_first_position ~state ~partial args cmt_tbl + = + (* Because the same subtree gets printed twice, we need to copy the cmt_tbl. + * consumed comments need to be marked not-consumed and reprinted… + * Cheng's different comment algorithm will solve this. *) + let state = State.next_custom_layout state in + let cmt_tbl_copy = CommentTable.copy cmt_tbl in + let callback, printed_args = + match args with + | (lbl, expr) :: args -> + let lbl_doc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled {txt} -> + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal] + | Asttypes.Optional {txt} -> + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal; Doc.question] + in + let callback = + Doc.concat + [ + lbl_doc; + print_pexp_fun ~state ~in_callback:FitsOnOneLine expr cmt_tbl; + ] + in + let callback = lazy (print_comments callback cmt_tbl expr.pexp_loc) in + let printed_args = + lazy + (Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map (fun arg -> print_argument ~state arg cmt_tbl) args)) + in + (callback, printed_args) + | _ -> assert false + in + + (* Thing.map((arg1, arg2) => MyModuleBlah.toList(argument), foo) *) + (* Thing.map((arg1, arg2) => { + * MyModuleBlah.toList(argument) + * }, longArgumet, veryLooooongArgument) + *) + let fits_on_one_line = + lazy + (Doc.concat + [ + Doc.lparen; + Lazy.force callback; + Doc.comma; + Doc.line; + Lazy.force printed_args; + Doc.rparen; + ]) + in + + (* Thing.map( + * (param1, parm2) => doStuff(param1, parm2), + * arg1, + * arg2, + * arg3, + * ) + *) + let break_all_args = + lazy (print_arguments ~state ~partial args cmt_tbl_copy) + in + + (* Sometimes one of the non-callback arguments will break. + * There might be a single line comment in there, or a multiline string etc. + * showDialog( + * ~onConfirm={() => ()}, + * ` + * Do you really want to leave this workspace? + * Some more text with detailed explanations... + * `, + * ~danger=true, + * // comment --> here a single line comment + * ~confirmText="Yes, I am sure!", + * ) + * In this case, we always want the arguments broken over multiple lines, + * like a normal function call. + *) + if state |> State.should_break_callback then Lazy.force break_all_args + else if Doc.will_break (Lazy.force printed_args) then + Lazy.force break_all_args + else + Doc.custom_layout [Lazy.force fits_on_one_line; Lazy.force break_all_args] + +and print_arguments_with_callback_in_last_position ~state ~partial args cmt_tbl + = + (* Because the same subtree gets printed twice, we need to copy the cmt_tbl. + * consumed comments need to be marked not-consumed and reprinted… + * Cheng's different comment algorithm will solve this. *) + let state = state |> State.next_custom_layout in + let cmt_tbl_copy = CommentTable.copy cmt_tbl in + let cmt_tbl_copy2 = CommentTable.copy cmt_tbl in + let rec loop acc args = + match args with + | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) + | [(lbl, expr)] -> + let lbl_doc = + match lbl with + | Asttypes.Nolabel -> Doc.nil + | Asttypes.Labelled {txt} -> + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal] + | Asttypes.Optional {txt} -> + Doc.concat [Doc.tilde; print_ident_like txt; Doc.equal; Doc.question] + in + let callback_fits_on_one_line = + lazy + (let pexp_fun_doc = + print_pexp_fun ~state ~in_callback:FitsOnOneLine expr cmt_tbl + in + let doc = Doc.concat [lbl_doc; pexp_fun_doc] in + print_comments doc cmt_tbl expr.pexp_loc) + in + let callback_arguments_fits_on_one_line = + lazy + (let pexp_fun_doc = + print_pexp_fun ~state ~in_callback:ArgumentsFitOnOneLine expr + cmt_tbl_copy + in + let doc = Doc.concat [lbl_doc; pexp_fun_doc] in + print_comments doc cmt_tbl_copy expr.pexp_loc) + in + ( lazy (Doc.concat (List.rev acc)), + callback_fits_on_one_line, + callback_arguments_fits_on_one_line ) + | arg :: args -> + let arg_doc = print_argument ~state arg cmt_tbl in + loop (Doc.line :: Doc.comma :: arg_doc :: acc) args + in + let printed_args, callback, callback2 = loop [] args in + + (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *) + let fits_on_one_line = + lazy + (Doc.concat + [Doc.lparen; Lazy.force printed_args; Lazy.force callback; Doc.rparen]) + in + + (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => + * MyModuleBlah.toList(argument) + * ) + *) + let arugments_fit_on_one_line = + lazy + (Doc.concat + [ + Doc.lparen; + Lazy.force printed_args; + Doc.breakable_group ~force_break:true (Lazy.force callback2); + Doc.rparen; + ]) + in + + (* Thing.map( + * arg1, + * arg2, + * arg3, + * (param1, parm2) => doStuff(param1, parm2) + * ) + *) + let break_all_args = + lazy (print_arguments ~state ~partial args cmt_tbl_copy2) + in + + (* Sometimes one of the non-callback arguments will break. + * There might be a single line comment in there, or a multiline string etc. + * showDialog( + * ` + * Do you really want to leave this workspace? + * Some more text with detailed explanations... + * `, + * ~danger=true, + * // comment --> here a single line comment + * ~confirmText="Yes, I am sure!", + * ~onConfirm={() => ()}, + * ) + * In this case, we always want the arguments broken over multiple lines, + * like a normal function call. + *) + if state |> State.should_break_callback then Lazy.force break_all_args + else if Doc.will_break (Lazy.force printed_args) then + Lazy.force break_all_args + else + Doc.custom_layout + [ + Lazy.force fits_on_one_line; + Lazy.force arugments_fit_on_one_line; + Lazy.force break_all_args; + ] + +and print_arguments ~state ~partial + (args : (Asttypes.arg_label * Parsetree.expression) list) cmt_tbl = + match args with + | [ + ( Nolabel, + { + pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); + pexp_loc = loc; + } ); + ] -> + if has_leading_line_comment cmt_tbl loc then + let cmt = print_comments Doc.nil cmt_tbl loc in + Doc.concat + [ + Doc.lparen; + Doc.indent (Doc.group (Doc.concat [Doc.soft_line; cmt])); + Doc.rparen; + ] + else Doc.text "()" + | [(Nolabel, arg)] when ParsetreeViewer.is_huggable_expression arg -> + let arg_doc = + let doc = print_expression_with_comments ~state arg cmt_tbl in + match Parens.expr arg with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc arg braces + | Nothing -> doc + in + Doc.concat [Doc.lparen; arg_doc; Doc.rparen] + | args -> + (* Avoid printing trailing comma when there is ... in function application *) + let printed_args = + List.map (fun arg -> print_argument ~state arg cmt_tbl) args + in + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) printed_args; + ]); + (if partial then Doc.nil else Doc.trailing_comma); + Doc.soft_line; + Doc.rparen; + ]) + +(* + * argument ::= + * | _ (* syntax sugar *) + * | expr + * | expr : type + * | ~ label-name + * | ~ label-name + * | ~ label-name ? + * | ~ label-name = expr + * | ~ label-name = _ (* syntax sugar *) + * | ~ label-name = expr : type + * | ~ label-name = ? expr + * | ~ label-name = ? _ (* syntax sugar *) + * | ~ label-name = ? expr : type *) +and print_argument ~state (arg_lbl, arg) cmt_tbl = + match (arg_lbl, arg) with + (* ~a (punned)*) + | ( Labelled {txt = lbl; loc = l0}, + { + pexp_attributes = []; + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + } ) + when lbl = name && not (ParsetreeViewer.is_braced_expr arg) -> + let loc = {l0 with loc_end = arg.pexp_loc.loc_end} in + let doc = Doc.concat [Doc.tilde; print_ident_like lbl] in + print_comments doc cmt_tbl loc + (* ~a: int (punned)*) + | ( Labelled {txt = lbl; loc = l0}, + { + pexp_desc = + Pexp_constraint + ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as arg_expr), + typ ); + pexp_attributes = []; + } ) + when lbl = name && not (ParsetreeViewer.is_braced_expr arg_expr) -> + let loc = {l0 with loc_end = arg.pexp_loc.loc_end} in + let doc = + Doc.concat + [ + Doc.tilde; + print_ident_like lbl; + Doc.text ": "; + print_typ_expr ~state typ cmt_tbl; + ] + in + print_comments doc cmt_tbl loc + (* ~a? (optional lbl punned)*) + | ( Optional {txt = lbl; loc}, + { + pexp_desc = Pexp_ident {txt = Longident.Lident name}; + pexp_attributes = []; + } ) + when lbl = name -> + let doc = Doc.concat [Doc.tilde; print_ident_like lbl; Doc.question] in + print_comments doc cmt_tbl loc + | _lbl, expr -> + let arg_loc, printed_lbl, dotdotdot = + match arg_lbl with + | Nolabel -> (expr.pexp_loc, Doc.nil, false) + | Labelled {txt = "..."; loc} -> + let arg_loc = loc in + let doc = Doc.text "..." in + (loc, print_comments doc cmt_tbl arg_loc, true) + | Labelled {txt = lbl; loc} -> + let arg_loc = loc in + let doc = Doc.concat [Doc.tilde; print_ident_like lbl; Doc.equal] in + (loc, print_comments doc cmt_tbl arg_loc, false) + | Optional {txt = lbl; loc} -> + let arg_loc = loc in + let doc = + Doc.concat [Doc.tilde; print_ident_like lbl; Doc.equal; Doc.question] + in + (loc, print_comments doc cmt_tbl arg_loc, false) + in + let printed_expr = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + let loc = {arg_loc with loc_end = expr.pexp_loc.loc_end} in + let doc = + if dotdotdot then printed_lbl else Doc.concat [printed_lbl; printed_expr] + in + print_comments doc cmt_tbl loc + +and print_cases ~state (cases : Parsetree.case list) cmt_tbl = + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.lbrace; + Doc.concat + [ + Doc.line; + print_list + ~get_loc:(fun n -> + { + n.Parsetree.pc_lhs.ppat_loc with + loc_end = + (match ParsetreeViewer.process_braces_attr n.pc_rhs with + | None, _ -> n.pc_rhs.pexp_loc.loc_end + | Some ({loc}, _), _ -> loc.Location.loc_end); + }) + ~print:(print_case ~state) ~nodes:cases cmt_tbl; + ]; + Doc.line; + Doc.rbrace; + ]) + +and print_case ~state (case : Parsetree.case) cmt_tbl = + let rhs = + match case.pc_rhs.pexp_desc with + | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ + | Pexp_sequence _ -> + print_expression_block ~state + ~braces:(ParsetreeViewer.is_braced_expr case.pc_rhs) + case.pc_rhs cmt_tbl + | _ -> ( + let doc = print_expression_with_comments ~state case.pc_rhs cmt_tbl in + match Parens.expr case.pc_rhs with + | Parenthesized -> add_parens doc + | _ -> doc) + in + + let guard = + match case.pc_guard with + | None -> Doc.nil + | Some expr -> + Doc.group + (Doc.concat + [ + Doc.line; + Doc.text "if "; + print_expression_with_comments ~state expr cmt_tbl; + ]) + in + let should_inline_rhs = + match case.pc_rhs.pexp_desc with + | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) + | Pexp_constant _ | Pexp_ident _ -> + true + | _ when ParsetreeViewer.is_huggable_rhs case.pc_rhs -> true + | _ -> false + in + let should_indent_pattern = + match case.pc_lhs.ppat_desc with + | Ppat_or _ -> false + | _ -> true + in + let pattern_doc = + let doc = print_pattern ~state case.pc_lhs cmt_tbl in + match case.pc_lhs.ppat_desc with + | Ppat_constraint _ -> add_parens doc + | _ -> doc + in + let content = + Doc.concat + [ + (if should_indent_pattern then Doc.indent pattern_doc else pattern_doc); + Doc.indent guard; + Doc.text " =>"; + Doc.indent + (Doc.concat + [(if should_inline_rhs then Doc.space else Doc.line); rhs]); + ] + in + Doc.group (Doc.concat [Doc.text "| "; content]) + +and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint + parameters cmt_tbl = + match parameters with + (* let f = _ => () *) + | [ + ParsetreeViewer.Parameter + { + attrs = []; + lbl = Nolabel; + default_expr = None; + pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; + }; + ] -> + let any = + let doc = if has_constraint then Doc.text "(_)" else Doc.text "_" in + print_comments doc cmt_tbl ppat_loc + in + if async then add_async any else any + (* let f = a => () *) + | [ + ParsetreeViewer.Parameter + { + attrs = []; + lbl = Nolabel; + default_expr = None; + pat = + { + Parsetree.ppat_desc = Ppat_var string_loc; + Parsetree.ppat_attributes = attrs; + }; + }; + ] -> + let txt_doc = + let var = print_ident_like string_loc.txt in + let var = + match attrs with + | [] -> if has_constraint then add_parens var else var + | attrs -> + let attrs = print_attributes ~state attrs cmt_tbl in + add_parens (Doc.concat [attrs; var]) + in + if async then add_async var else var + in + print_comments txt_doc cmt_tbl string_loc.loc + (* let f = () => () *) + | [ + ParsetreeViewer.Parameter + { + attrs = []; + lbl = Nolabel; + default_expr = None; + pat = + {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; + }; + ] -> + let doc = + let lparen_rparen = Doc.text "()" in + if async then add_async lparen_rparen else lparen_rparen + in + print_comments doc cmt_tbl loc + (* let f = (~greeting, ~from as hometown, ~x=?) => () *) + | parameters -> + let in_callback = + match in_callback with + | FitsOnOneLine -> true + | _ -> false + in + let maybe_async_lparen = + let lparen = Doc.lparen in + if async then add_async lparen else lparen + in + let should_hug = ParsetreeViewer.parameters_should_hug parameters in + let printed_paramaters = + Doc.concat + [ + (if should_hug || in_callback then Doc.nil else Doc.soft_line); + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun p -> print_exp_fun_parameter ~state p cmt_tbl) + parameters); + ] + in + Doc.group + (Doc.concat + [ + maybe_async_lparen; + (if should_hug || in_callback then printed_paramaters + else + Doc.concat + [ + Doc.indent printed_paramaters; + Doc.trailing_comma; + Doc.soft_line; + ]); + Doc.rparen; + ]) + +and print_exp_fun_parameter ~state parameter cmt_tbl = + match parameter with + | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> + Doc.group + (Doc.concat + [ + print_attributes ~state attrs cmt_tbl; + Doc.text "type "; + (* XX *) + Doc.join ~sep:Doc.space + (List.map + (fun lbl -> + print_comments + (print_ident_like lbl.Asttypes.txt) + cmt_tbl lbl.Asttypes.loc) + lbls); + ]) + | Parameter {attrs; lbl; default_expr; pat = pattern} -> + let attrs = print_attributes ~state attrs cmt_tbl in + (* =defaultValue *) + let default_expr_doc = + match default_expr with + | Some expr -> + Doc.concat + [Doc.text "="; print_expression_with_comments ~state expr cmt_tbl] + | None -> Doc.nil + in + (* ~from as hometown + * ~from -> punning *) + let label_with_pattern = + match (lbl, pattern) with + | Nolabel, pattern -> print_pattern ~state pattern cmt_tbl + | ( (Labelled {txt = lbl} | Optional {txt = lbl}), + {ppat_desc = Ppat_var string_loc; ppat_attributes} ) + when lbl = string_loc.txt -> + (* ~d *) + Doc.concat + [ + print_attributes ~state ppat_attributes cmt_tbl; + Doc.text "~"; + print_ident_like lbl; + ] + | ( (Labelled {txt = lbl} | Optional {txt = lbl}), + { + ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); + ppat_attributes; + } ) + when lbl = txt -> + (* ~d: e *) + Doc.concat + [ + print_attributes ~state ppat_attributes cmt_tbl; + Doc.text "~"; + print_ident_like lbl; + Doc.text ": "; + print_typ_expr ~state typ cmt_tbl; + ] + | (Labelled {txt = lbl} | Optional {txt = lbl}), pattern -> + (* ~b as c *) + Doc.concat + [ + Doc.text "~"; + print_ident_like lbl; + Doc.text " as "; + print_pattern ~state pattern cmt_tbl; + ] + in + let optional_label_suffix = + match (lbl, default_expr) with + | Optional _, None -> Doc.text "=?" + | _ -> Doc.nil + in + let doc = + Doc.group + (Doc.concat + [attrs; label_with_pattern; default_expr_doc; optional_label_suffix]) + in + let lbl_loc = Asttypes.get_lbl_loc lbl in + let cmt_loc = + match default_expr with + | None -> {lbl_loc with loc_end = pattern.ppat_loc.loc_end} + | Some expr -> {lbl_loc with loc_end = expr.pexp_loc.loc_end} + in + print_comments doc cmt_tbl cmt_loc + +and print_expression_block ~state ~braces expr cmt_tbl = + let rec collect_rows acc expr = + match expr.Parsetree.pexp_desc with + | Parsetree.Pexp_letmodule (mod_name, mod_expr, expr2) -> + let name = + let doc = Doc.text mod_name.txt in + print_comments doc cmt_tbl mod_name.loc + in + let name, mod_expr = + match mod_expr.pmod_desc with + | Pmod_constraint (mod_expr2, mod_type) + when not + (ParsetreeViewer.has_await_attribute mod_expr.pmod_attributes) + -> + let name = + Doc.concat + [name; Doc.text ": "; print_mod_type ~state mod_type cmt_tbl] + in + (name, mod_expr2) + | _ -> (name, mod_expr) + in + let let_module_doc = + Doc.concat + [ + Doc.text "module "; + name; + Doc.text " = "; + print_mod_expr ~state mod_expr cmt_tbl; + ] + in + let loc = {expr.pexp_loc with loc_end = mod_expr.pmod_loc.loc_end} in + collect_rows ((loc, let_module_doc) :: acc) expr2 + | Pexp_letexception (extension_constructor, expr2) -> + let loc = + let loc = + {expr.pexp_loc with loc_end = extension_constructor.pext_loc.loc_end} + in + match get_first_leading_comment cmt_tbl loc with + | None -> loc + | Some comment -> + let cmt_loc = Comment.loc comment in + {cmt_loc with loc_end = loc.loc_end} + in + let let_exception_doc = + print_exception_def ~state extension_constructor cmt_tbl + in + collect_rows ((loc, let_exception_doc) :: acc) expr2 + | Pexp_open (override_flag, longident_loc, expr2) -> + let open_doc = + Doc.concat + [ + Doc.text "open"; + print_override_flag override_flag; + Doc.space; + print_longident_location longident_loc cmt_tbl; + ] + in + let loc = {expr.pexp_loc with loc_end = longident_loc.loc.loc_end} in + collect_rows ((loc, open_doc) :: acc) expr2 + | Pexp_sequence (expr1, expr2) -> + let expr_doc = + let doc = print_expression ~state expr1 cmt_tbl in + match Parens.expr expr1 with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr1 braces + | Nothing -> doc + in + let loc = expr1.pexp_loc in + collect_rows ((loc, expr_doc) :: acc) expr2 + | Pexp_let (rec_flag, value_bindings, expr2) -> ( + let loc = + let loc = + match (value_bindings, List.rev value_bindings) with + | vb :: _, last_vb :: _ -> + {vb.pvb_loc with loc_end = last_vb.pvb_loc.loc_end} + | _ -> Location.none + in + match get_first_leading_comment cmt_tbl loc with + | None -> loc + | Some comment -> + let cmt_loc = Comment.loc comment in + {cmt_loc with loc_end = loc.loc_end} + in + let rec_flag = + match rec_flag with + | Asttypes.Nonrecursive -> Doc.nil + | Asttypes.Recursive -> Doc.text "rec " + in + let let_doc = + print_value_bindings ~state ~rec_flag value_bindings cmt_tbl + in + (* let () = { + * let () = foo() + * () + * } + * We don't need to print the () on the last line of the block + *) + match expr2.pexp_desc with + | Pexp_construct ({txt = Longident.Lident "()"}, _) -> + List.rev ((loc, let_doc) :: acc) + | _ -> collect_rows ((loc, let_doc) :: acc) expr2) + | _ -> + let expr_doc = + let doc = print_expression ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + List.rev ((expr.pexp_loc, expr_doc) :: acc) + in + let rows = collect_rows [] expr in + let block = + print_list ~get_loc:fst ~nodes:rows + ~print:(fun (_, doc) _ -> doc) + ~force_break:true cmt_tbl + in + Doc.breakable_group ~force_break:true + (if braces then + Doc.concat + [ + Doc.lbrace; + Doc.indent (Doc.concat [Doc.line; block]); + Doc.line; + Doc.rbrace; + ] + else block) + +(* + * // user types: + * let f = (a, b) => { a + b } + * + * // printer: everything is on one line + * let f = (a, b) => { a + b } + * + * // user types: over multiple lines + * let f = (a, b) => { + * a + b + * } + * + * // printer: over multiple lines + * let f = (a, b) => { + * a + b + * } + *) +and print_braces doc expr braces_loc = + let over_multiple_lines = + let open Location in + braces_loc.loc_end.pos_lnum > braces_loc.loc_start.pos_lnum + in + match expr.Parsetree.pexp_desc with + | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ + | Pexp_sequence _ -> + (* already has braces *) + doc + | _ -> + Doc.breakable_group ~force_break:over_multiple_lines + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + (if Parens.braced_expr expr then add_parens doc else doc); + ]); + Doc.soft_line; + Doc.rbrace; + ]) + +and print_override_flag override_flag = + match override_flag with + | Asttypes.Override -> Doc.text "!" + | Fresh -> Doc.nil + +and print_direction_flag flag = + match flag with + | Asttypes.Downto -> Doc.text " downto " + | Asttypes.Upto -> Doc.text " to " + +and print_expression_record_row ~state {lid = lbl; x = expr; opt = optional} + cmt_tbl punning_allowed = + let cmt_loc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let doc = + Doc.group + (match expr.pexp_desc with + | Pexp_ident {txt = Lident key; loc = _keyLoc} + when punning_allowed && Longident.last lbl.txt = key -> + (* print punned field *) + Doc.concat + [ + print_attributes ~state expr.pexp_attributes cmt_tbl; + (if optional then Doc.text "?" else Doc.nil); + print_lident_path lbl cmt_tbl; + ] + | _ -> + Doc.concat + [ + print_lident_path lbl cmt_tbl; + Doc.text ": "; + (if optional then Doc.text "?" else Doc.nil); + (let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr_record_row_rhs ~optional expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc); + ]) + in + print_comments doc cmt_tbl cmt_loc + +and print_bs_object_row ~state (lbl, expr) cmt_tbl = + let cmt_loc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in + let lbl_doc = + let doc = + Doc.concat [Doc.text "\""; print_longident lbl.txt; Doc.text "\""] + in + print_comments doc cmt_tbl lbl.loc + in + let doc = + Doc.concat + [ + lbl_doc; + Doc.text ": "; + (let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc); + ] + in + print_comments doc cmt_tbl cmt_loc + +and print_doc_comments ~state ?(sep = Doc.hard_line) cmt_tbl attrs = + Doc.concat + [ + Doc.group + (Doc.join_with_sep + (List.map (fun attr -> print_attribute ~state attr cmt_tbl) attrs)); + sep; + ] + +(* The optional loc indicates whether we need to print the attributes in + * relation to some location. In practise this means the following: + * `@attr type t = string` -> on the same line, print on the same line + * `@attr + * type t = string` -> attr is on prev line, print the attributes + * with a line break between, we respect the users' original layout *) +and print_attributes ?loc ?(inline = false) ~state + (attrs : Parsetree.attributes) cmt_tbl = + match ParsetreeViewer.filter_parsing_attrs attrs with + | [] -> Doc.nil + | attrs -> + let comment_attrs, attrs = + ParsetreeViewer.partition_doc_comment_attributes attrs + in + let line_break = + match loc with + | None -> Doc.line + | Some loc -> ( + match List.rev attrs with + | ({loc = first_loc}, _) :: _ + when loc.loc_start.pos_lnum > first_loc.loc_end.pos_lnum -> + Doc.hard_line + | _ -> + let has_comment_attrs = not (comment_attrs = []) in + if has_comment_attrs then Doc.space else Doc.line) + in + let comment_doc = + match comment_attrs with + | [] -> Doc.nil + | comment_attrs -> print_doc_comments ~state cmt_tbl comment_attrs + in + let attrs_doc = + match attrs with + | [] -> Doc.nil + | _ -> + Doc.concat + [ + Doc.group + (Doc.join_with_sep + (List.map + (fun attr -> print_attribute ~state attr cmt_tbl) + attrs)); + (if inline then Doc.space else line_break); + ] + in + Doc.concat [comment_doc; attrs_doc] + +and print_payload ~state (payload : Parsetree.payload) cmt_tbl = + match payload with + | PStr [] -> Doc.nil + | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> + let expr_doc = print_expression_with_comments ~state expr cmt_tbl in + let needs_parens = + match attrs with + | [] -> false + | _ -> true + in + let should_hug = ParsetreeViewer.is_huggable_expression expr in + if should_hug then + Doc.concat + [ + Doc.lparen; + print_attributes ~state attrs cmt_tbl; + (if needs_parens then add_parens expr_doc else expr_doc); + Doc.rparen; + ] + else + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + print_attributes ~state attrs cmt_tbl; + (if needs_parens then add_parens expr_doc else expr_doc); + ]); + Doc.soft_line; + Doc.rparen; + ] + | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> + add_parens (print_structure_item ~state si cmt_tbl) + | PStr structure -> add_parens (print_structure ~state structure cmt_tbl) + | PTyp typ -> + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent (Doc.concat [Doc.line; print_typ_expr ~state typ cmt_tbl]); + Doc.soft_line; + Doc.rparen; + ] + | PPat (pat, opt_expr) -> + let when_doc = + match opt_expr with + | Some expr -> + Doc.concat + [ + Doc.line; + Doc.text "if "; + print_expression_with_comments ~state expr cmt_tbl; + ] + | None -> Doc.nil + in + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.text "? "; + print_pattern ~state pat cmt_tbl; + when_doc; + ]); + Doc.soft_line; + Doc.rparen; + ] + | PSig signature -> + Doc.concat + [ + Doc.lparen; + Doc.text ":"; + Doc.indent + (Doc.concat [Doc.line; print_signature ~state signature cmt_tbl]); + Doc.soft_line; + Doc.rparen; + ] + +and print_attribute ?(standalone = false) ~state + ((id, payload) : Parsetree.attribute) cmt_tbl = + match (id, payload) with + | ( {txt = "res.doc"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); + }; + ] ) -> + ( Doc.concat + [ + Doc.text (if standalone then "/***" else "/**"); + Doc.text txt; + Doc.text "*/"; + ], + Doc.hard_line ) + | _ -> + ( Doc.group + (Doc.concat + [ + Doc.text (if standalone then "@@" else "@"); + Doc.text id.txt; + print_payload ~state payload cmt_tbl; + ]), + Doc.line ) + +and print_mod_expr ~state mod_expr cmt_tbl = + let doc = + match mod_expr.pmod_desc with + | Pmod_ident longident_loc -> print_longident_location longident_loc cmt_tbl + | Pmod_structure [] -> + let should_break = + mod_expr.pmod_loc.loc_start.pos_lnum + < mod_expr.pmod_loc.loc_end.pos_lnum + in + Doc.breakable_group ~force_break:should_break + (Doc.concat + [ + Doc.lbrace; + print_comments_inside cmt_tbl mod_expr.pmod_loc; + Doc.rbrace; + ]) + | Pmod_structure structure -> + Doc.breakable_group ~force_break:true + (Doc.concat + [ + Doc.lbrace; + Doc.indent + (Doc.concat + [Doc.soft_line; print_structure ~state structure cmt_tbl]); + Doc.soft_line; + Doc.rbrace; + ]) + | Pmod_unpack expr -> + let should_hug = + match expr.pexp_desc with + | Pexp_let _ -> true + | Pexp_constraint + ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) + -> + true + | _ -> false + in + let expr, module_constraint = + match expr.pexp_desc with + | Pexp_constraint + (expr, {ptyp_desc = Ptyp_package package_type; ptyp_loc}) -> + let package_doc = + let doc = + print_package_type ~state ~print_module_keyword_and_parens:false + package_type cmt_tbl + in + print_comments doc cmt_tbl ptyp_loc + in + let type_doc = + Doc.group + (Doc.concat + [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; package_doc])]) + in + (expr, type_doc) + | _ -> (expr, Doc.nil) + in + let unpack_doc = + Doc.group + (Doc.concat + [ + print_expression_with_comments ~state expr cmt_tbl; + module_constraint; + ]) + in + Doc.group + (Doc.concat + [ + Doc.text "unpack("; + (if should_hug then unpack_doc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.soft_line; unpack_doc]); + Doc.soft_line; + ]); + Doc.rparen; + ]) + | Pmod_extension extension -> + print_extension ~state ~at_module_lvl:false extension cmt_tbl + | Pmod_apply _ -> + let args, call_expr = ParsetreeViewer.mod_expr_apply mod_expr in + let is_unit_sugar = + match args with + | [{pmod_desc = Pmod_structure []}] -> true + | _ -> false + in + let should_hug = + match args with + | [{pmod_desc = Pmod_structure _}] -> true + | _ -> false + in + Doc.group + (Doc.concat + [ + print_mod_expr ~state call_expr cmt_tbl; + (if is_unit_sugar then + print_mod_apply_arg ~state + (List.hd args [@doesNotRaise]) + cmt_tbl + else + Doc.concat + [ + Doc.lparen; + (if should_hug then + print_mod_apply_arg ~state + (List.hd args [@doesNotRaise]) + cmt_tbl + else + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun mod_arg -> + print_mod_apply_arg ~state mod_arg cmt_tbl) + args); + ])); + (if not should_hug then + Doc.concat [Doc.trailing_comma; Doc.soft_line] + else Doc.nil); + Doc.rparen; + ]); + ]) + | Pmod_constraint (mod_expr, mod_type) -> + Doc.concat + [ + print_mod_expr ~state mod_expr cmt_tbl; + Doc.text ": "; + print_mod_type ~state mod_type cmt_tbl; + ] + | Pmod_functor _ -> print_mod_functor ~state mod_expr cmt_tbl + in + let doc = + if ParsetreeViewer.has_await_attribute mod_expr.pmod_attributes then + match mod_expr.pmod_desc with + | Pmod_constraint _ -> + Doc.concat [Doc.text "await "; Doc.lparen; doc; Doc.rparen] + | _ -> Doc.concat [Doc.text "await "; doc] + else doc + in + print_comments doc cmt_tbl mod_expr.pmod_loc + +and print_mod_functor ~state mod_expr cmt_tbl = + let parameters, return_mod_expr = ParsetreeViewer.mod_expr_functor mod_expr in + (* let shouldInline = match returnModExpr.pmod_desc with *) + (* | Pmod_structure _ | Pmod_ident _ -> true *) + (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) + (* | _ -> false *) + (* in *) + let return_constraint, return_mod_expr = + match return_mod_expr.pmod_desc with + | Pmod_constraint (mod_expr, mod_type) -> + let constraint_doc = + let doc = print_mod_type ~state mod_type cmt_tbl in + if Parens.mod_expr_functor_constraint mod_type then add_parens doc + else doc + in + let mod_constraint = Doc.concat [Doc.text ": "; constraint_doc] in + (mod_constraint, print_mod_expr ~state mod_expr cmt_tbl) + | _ -> (Doc.nil, print_mod_expr ~state return_mod_expr cmt_tbl) + in + let parameters_doc = + match parameters with + | [(attrs, {txt = "*"}, None)] -> + Doc.group + (Doc.concat [print_attributes ~state attrs cmt_tbl; Doc.text "()"]) + | [([], {txt = lbl}, None)] -> Doc.text lbl + | parameters -> + Doc.group + (Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun param -> + print_mod_functor_param ~state param cmt_tbl) + parameters); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ]) + in + Doc.group + (Doc.concat + [parameters_doc; return_constraint; Doc.text " => "; return_mod_expr]) + +and print_mod_functor_param ~state (attrs, lbl, opt_mod_type) cmt_tbl = + let cmt_loc = + match opt_mod_type with + | None -> lbl.Asttypes.loc + | Some mod_type -> + {lbl.loc with loc_end = mod_type.Parsetree.pmty_loc.loc_end} + in + let attrs = print_attributes ~state attrs cmt_tbl in + let lbl_doc = + let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in + print_comments doc cmt_tbl lbl.loc + in + let doc = + Doc.group + (Doc.concat + [ + attrs; + lbl_doc; + (match opt_mod_type with + | None -> Doc.nil + | Some mod_type -> + Doc.concat [Doc.text ": "; print_mod_type ~state mod_type cmt_tbl]); + ]) + in + print_comments doc cmt_tbl cmt_loc + +and print_mod_apply_arg ~state mod_expr cmt_tbl = + match mod_expr.pmod_desc with + | Pmod_structure [] -> Doc.text "()" + | _ -> print_mod_expr ~state mod_expr cmt_tbl + +and print_exception_def ~state (constr : Parsetree.extension_constructor) + cmt_tbl = + let kind = + match constr.pext_kind with + | Pext_rebind longident -> + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; print_longident_location longident cmt_tbl]) + | Pext_decl (Pcstr_tuple [], None) -> Doc.nil + | Pext_decl (args, gadt) -> + let gadt_doc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl] + | None -> Doc.nil + in + Doc.concat + [ + print_constructor_arguments ~state ~indent:false args cmt_tbl; gadt_doc; + ] + in + let name = + print_comments (Doc.text constr.pext_name.txt) cmt_tbl constr.pext_name.loc + in + let doc = + Doc.group + (Doc.concat + [ + print_attributes ~state constr.pext_attributes cmt_tbl; + Doc.text "exception "; + name; + kind; + ]) + in + print_comments doc cmt_tbl constr.pext_loc + +and print_extension_constructor ~state + (constr : Parsetree.extension_constructor) cmt_tbl i = + let attrs = print_attributes ~state constr.pext_attributes cmt_tbl in + let bar = + if i > 0 then Doc.text "| " else Doc.if_breaks (Doc.text "| ") Doc.nil + in + let kind = + match constr.pext_kind with + | Pext_rebind longident -> + Doc.indent + (Doc.concat + [Doc.text " ="; Doc.line; print_longident_location longident cmt_tbl]) + | Pext_decl (Pcstr_tuple [], None) -> Doc.nil + | Pext_decl (args, gadt) -> + let gadt_doc = + match gadt with + | Some typ -> + Doc.concat [Doc.text ": "; print_typ_expr ~state typ cmt_tbl] + | None -> Doc.nil + in + Doc.concat + [ + print_constructor_arguments ~state ~indent:false args cmt_tbl; gadt_doc; + ] + in + let name = + print_comments (Doc.text constr.pext_name.txt) cmt_tbl constr.pext_name.loc + in + Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] + +let print_type_params params = print_type_params ~state:(State.init ()) params +let print_typ_expr t = print_typ_expr ~state:(State.init ()) t +let print_expression e = print_expression ~state:(State.init ()) e +let print_pattern p = print_pattern ~state:(State.init ()) p + +let print_implementation ?(width = default_print_width) + (s : Parsetree.structure) ~comments = + let cmt_tbl = CommentTable.make () in + CommentTable.walk_structure s cmt_tbl comments; + (* CommentTable.log cmt_tbl; *) + let doc = print_structure ~state:(State.init ()) s cmt_tbl in + (* Doc.debug doc; *) + Doc.to_string ~width doc ^ "\n" + +let print_interface ?(width = default_print_width) (s : Parsetree.signature) + ~comments = + let cmt_tbl = CommentTable.make () in + CommentTable.walk_signature s cmt_tbl comments; + Doc.to_string ~width (print_signature ~state:(State.init ()) s cmt_tbl) ^ "\n" + +let print_structure = print_structure ~state:(State.init ()) diff --git a/compiler/syntax/src/res_printer.mli b/compiler/syntax/src/res_printer.mli new file mode 100644 index 0000000..33461d7 --- /dev/null +++ b/compiler/syntax/src/res_printer.mli @@ -0,0 +1,32 @@ +val default_print_width : int + +val print_type_params : + (Parsetree.core_type * Asttypes.variance) list -> + Res_comments_table.t -> + Res_doc.t + +val print_longident : Longident.t -> Res_doc.t + +val print_typ_expr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t + +val add_parens : Res_doc.t -> Res_doc.t + +val print_expression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t + +val print_pattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t +[@@live] + +val print_structure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t +[@@live] + +val print_implementation : + ?width:int -> Parsetree.structure -> comments:Res_comment.t list -> string +val print_interface : + ?width:int -> Parsetree.signature -> comments:Res_comment.t list -> string + +val print_ident_like : + ?allow_uident:bool -> ?allow_hyphen:bool -> string -> Res_doc.t + +val print_poly_var_ident : string -> Res_doc.t + +val polyvar_ident_to_string : string -> string [@@live] diff --git a/jscomp/syntax/src/res_reporting.ml b/compiler/syntax/src/res_reporting.ml similarity index 87% rename from jscomp/syntax/src/res_reporting.ml rename to compiler/syntax/src/res_reporting.ml index 77d370a..53a3eed 100644 --- a/jscomp/syntax/src/res_reporting.ml +++ b/compiler/syntax/src/res_reporting.ml @@ -13,4 +13,4 @@ type problem = | Lident [@live] | Unbalanced of Token.t [@live] -type parseError = Lexing.position * problem +type parse_error = Lexing.position * problem diff --git a/compiler/syntax/src/res_scanner.ml b/compiler/syntax/src/res_scanner.ml new file mode 100644 index 0000000..5615b32 --- /dev/null +++ b/compiler/syntax/src/res_scanner.ml @@ -0,0 +1,1057 @@ +module Diagnostics = Res_diagnostics +module Token = Res_token +module Comment = Res_comment + +type mode = Diamond + +(* We hide the implementation detail of the scanner reading character. Our char + will also contain the special -1 value to indicate end-of-file. This isn't + ideal; we should clean this up *) +let hacky_eof_char = Char.unsafe_chr (-1) +type char_encoding = Char.t + +type t = { + filename: string; + src: string; + mutable err: + start_pos:Lexing.position -> + end_pos:Lexing.position -> + Diagnostics.category -> + unit; + mutable ch: char_encoding; (* current character *) + mutable offset: int; (* current byte offset *) + mutable offset16: int; + (* current number of utf16 code units since line start *) + mutable line_offset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; +} + +let set_diamond_mode scanner = scanner.mode <- Diamond :: scanner.mode + +let pop_mode scanner mode = + match scanner.mode with + | m :: ms when m = mode -> scanner.mode <- ms + | _ -> () + +let in_diamond_mode scanner = + match scanner.mode with + | Diamond :: _ -> true + | _ -> false + +let position scanner = + Lexing. + { + pos_fname = scanner.filename; + (* line number *) + pos_lnum = scanner.lnum; + (* offset of the beginning of the line (number + of bytes between the beginning of the scanner and the beginning + of the line) *) + pos_bol = scanner.line_offset; + (* [pos_cnum - pos_bol] is the number of utf16 code units since line start *) + pos_cnum = scanner.line_offset + scanner.offset16; + } + +(* Small debugging util + ❯ echo 'let msg = "hello"' | ./lib/rescript-legacy.exe + let msg = "hello" + ^-^ let 0-3 + let msg = "hello" + ^-^ msg 4-7 + let msg = "hello" + ^ = 8-9 + let msg = "hello" + ^-----^ string "hello" 10-17 + let msg = "hello" + ^ eof 18-18 + let msg = "hello" +*) +let _printDebug ~start_pos ~end_pos scanner token = + let open Lexing in + print_string scanner.src; + print_string ((String.make [@doesNotRaise]) start_pos.pos_cnum ' '); + print_char '^'; + (match end_pos.pos_cnum - start_pos.pos_cnum with + | 0 -> if token = Token.Eof then () else assert false + | 1 -> () + | n -> + print_string ((String.make [@doesNotRaise]) (n - 2) '-'); + print_char '^'); + print_char ' '; + print_string (Res_token.to_string token); + print_char ' '; + print_int start_pos.pos_cnum; + print_char '-'; + print_int end_pos.pos_cnum; + print_endline "" +[@@live] + +let next scanner = + let next_offset = scanner.offset + 1 in + let utf16len = + match Ext_utf8.classify scanner.ch with + | Single _ | Invalid -> 1 + | Leading (n, _) -> ( (((n + 1) / 2) [@doesNotRaise])) + | Cont _ -> 0 + in + let newline = + scanner.ch = '\n' + (* What about CRLF (\r + \n) on windows? + \r\n will always be terminated by a \n + -> we can just bump the line count on \n *) + in + if newline then ( + scanner.line_offset <- next_offset; + scanner.offset16 <- 0; + scanner.lnum <- scanner.lnum + 1) + else scanner.offset16 <- scanner.offset16 + utf16len; + if next_offset < String.length scanner.src then ( + scanner.offset <- next_offset; + scanner.ch <- String.unsafe_get scanner.src next_offset) + else ( + scanner.offset <- String.length scanner.src; + scanner.offset16 <- scanner.offset - scanner.line_offset; + scanner.ch <- hacky_eof_char) + +let next2 scanner = + next scanner; + next scanner + +let next3 scanner = + next scanner; + next scanner; + next scanner + +let peek scanner = + if scanner.offset + 1 < String.length scanner.src then + String.unsafe_get scanner.src (scanner.offset + 1) + else hacky_eof_char + +let peek2 scanner = + if scanner.offset + 2 < String.length scanner.src then + String.unsafe_get scanner.src (scanner.offset + 2) + else hacky_eof_char + +let peek3 scanner = + if scanner.offset + 3 < String.length scanner.src then + String.unsafe_get scanner.src (scanner.offset + 3) + else hacky_eof_char + +let peekChar scanner target_char = + let rec skip_whitespace_and_check offset = + if offset < String.length scanner.src then + let ch = String.unsafe_get scanner.src offset in + match ch with + | ' ' | '\t' | '\n' | '\r' -> skip_whitespace_and_check (offset + 1) + | c -> c = target_char + else false + in + skip_whitespace_and_check scanner.offset + +let peekMinus scanner = peekChar scanner '-' +let peekSlash scanner = peekChar scanner '/' + +let make ~filename src = + { + filename; + src; + err = (fun ~start_pos:_ ~end_pos:_ _ -> ()); + ch = (if src = "" then hacky_eof_char else String.unsafe_get src 0); + offset = 0; + offset16 = 0; + line_offset = 0; + lnum = 1; + mode = []; + } + +(* generic helpers *) + +let is_whitespace ch = + match ch with + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false + +let rec skip_whitespace scanner = + if is_whitespace scanner.ch then ( + next scanner; + skip_whitespace scanner) + +let digit_value ch = + match ch with + | '0' .. '9' -> Char.code ch - 48 + | 'a' .. 'f' -> Char.code ch - Char.code 'a' + 10 + | 'A' .. 'F' -> Char.code ch + 32 - Char.code 'a' + 10 + | _ -> 16 (* larger than any legal value *) + +(* scanning helpers *) + +let scan_identifier scanner = + let start_off = scanner.offset in + let rec skip_good_chars scanner = + match scanner.ch with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' -> + next scanner; + skip_good_chars scanner + | _ -> () + in + skip_good_chars scanner; + let str = + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off) + in + match (scanner, str) with + | {ch = '{'}, "list" -> + next scanner; + (* TODO: this isn't great *) + Token.lookup_keyword "list{" + | {ch = '{'}, "dict" -> + next scanner; + (* TODO: this isn't great *) + Token.lookup_keyword "dict{" + | {ch = '?'}, "let" -> + next scanner; + (* TODO: this isn't great *) + Token.lookup_keyword "let?" + | _ -> Token.lookup_keyword str + +let scan_digits scanner ~base = + if base <= 10 then + let rec loop scanner found_digits = + match scanner.ch with + | '0' .. '9' -> + next scanner; + loop scanner true + | '_' -> + next scanner; + loop scanner false + | _ -> found_digits + in + loop scanner false + else + let rec loop scanner found_digits = + match scanner.ch with + (* hex *) + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> + next scanner; + loop scanner true + | '_' -> + next scanner; + loop scanner false + | _ -> found_digits + in + loop scanner false + +(* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *) +let scan_number scanner = + let start_off = scanner.offset in + + (* integer part *) + let base = + match scanner.ch with + | '0' -> ( + match peek scanner with + | 'x' | 'X' -> + next2 scanner; + 16 + | 'o' | 'O' -> + next2 scanner; + 8 + | 'b' | 'B' -> + next2 scanner; + 2 + | _ -> + next scanner; + 8) + | _ -> 10 + in + let _ : bool = scan_digits scanner ~base in + + (* *) + let is_float = + if '.' == scanner.ch then ( + next scanner; + let _ : bool = scan_digits scanner ~base in + true) + else false + in + + (* exponent part *) + let is_float = + let start_pos = position scanner in + match scanner.ch with + | 'e' | 'E' | 'p' | 'P' -> + (match peek scanner with + | '+' | '-' -> next2 scanner + | _ -> next scanner); + let end_pos = position scanner in + let found_digits = scan_digits scanner ~base in + if not found_digits then + scanner.err ~start_pos ~end_pos + (Diagnostics.message "Expected digits after exponential notation."); + true + | _ -> is_float + in + let literal = + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off) + in + + (* suffix *) + let suffix = + match scanner.ch with + | ('g' .. 'z' | 'G' .. 'Z') as ch -> + next scanner; + Some ch + | _ -> None + in + if is_float then Token.Float {f = literal; suffix} + else Token.Int {i = literal; suffix} + +let scan_exotic_identifier scanner = + let start_pos = position scanner in + let start_off = scanner.offset in + + next2 scanner; + + let rec scan () = + match scanner.ch with + | '"' -> next scanner + | '\n' | '\r' -> + (* line break *) + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos + (Diagnostics.message "A quoted identifier can't contain line breaks."); + next scanner + | ch when ch == hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos + (Diagnostics.message "Did you forget a \" here?") + | _ -> + next scanner; + scan () + in + scan (); + + let ident = + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off) + in + let name = Ext_ident.unwrap_uppercase_exotic ident in + if name = String.empty then ( + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos + (Diagnostics.message "A quoted identifier can't be empty string."); + Token.Lident ident) + else if Ext_ident.is_uident name then Token.Lident ident + (* Exotic ident with uppercase letter should be encoded to avoid confusing in OCaml parsetree *) + else Token.Lident name + +let scan_string_escape_sequence ~start_pos scanner = + let scan ~n ~base ~max = + let rec loop n x = + if n == 0 then x + else + let d = digit_value scanner.ch in + if d >= base then ( + let pos = position scanner in + let msg = + if scanner.ch == hacky_eof_char then "unclosed escape sequence" + else "unknown escape sequence" + in + scanner.err ~start_pos ~end_pos:pos (Diagnostics.message msg); + -1) + else + let () = next scanner in + loop (n - 1) ((x * base) + d) + in + let x = loop n 0 in + if x > max || (0xD800 <= x && x < 0xE000) then + let pos = position scanner in + let msg = "escape sequence is invalid unicode code point" in + scanner.err ~start_pos ~end_pos:pos (Diagnostics.message msg) + in + match scanner.ch with + (* \ already consumed *) + | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> next scanner + | '0' + when let c = peek scanner in + c < '0' || c > '9' -> + (* Allow \0 *) + next scanner + | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 + | 'x' -> + (* hex *) + next scanner; + scan ~n:2 ~base:16 ~max:255 + | 'u' -> ( + next scanner; + match scanner.ch with + | '{' -> ( + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digit_value scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + match scanner.ch with + | '}' -> next scanner + | _ -> ()) + | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) + | _ -> + (* unknown escape sequence + * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) + (* + let pos = position scanner in + let msg = + if ch == -1 then "unclosed escape sequence" + else "unknown escape sequence" + in + scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) + *) + () + +let scan_string scanner = + (* assumption: we've just matched a quote *) + let start_pos_with_quote = position scanner in + next scanner; + + (* If the text needs changing, a buffer is used *) + let buf = Buffer.create 0 in + let first_char_offset = scanner.offset in + let last_offset_in_buf = ref first_char_offset in + + let bring_buf_up_to_date ~start_offset = + let str_up_to_now = + (String.sub scanner.src !last_offset_in_buf + (start_offset - !last_offset_in_buf) [@doesNotRaise]) + in + Buffer.add_string buf str_up_to_now; + last_offset_in_buf := start_offset + in + + let result ~first_char_offset ~last_char_offset = + if Buffer.length buf = 0 then + (String.sub [@doesNotRaise]) scanner.src first_char_offset + (last_char_offset - first_char_offset) + else ( + bring_buf_up_to_date ~start_offset:last_char_offset; + Buffer.contents buf) + in + + let rec scan () = + match scanner.ch with + | '"' -> + let last_char_offset = scanner.offset in + next scanner; + result ~first_char_offset ~last_char_offset + | '\\' -> + let start_pos = position scanner in + let start_offset = scanner.offset + 1 in + next scanner; + scan_string_escape_sequence ~start_pos scanner; + let end_offset = scanner.offset in + convert_octal_to_hex ~start_offset ~end_offset + | ch when ch == hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos:start_pos_with_quote ~end_pos + Diagnostics.unclosed_string; + let last_char_offset = scanner.offset in + result ~first_char_offset ~last_char_offset + | _ -> + next scanner; + scan () + and convert_octal_to_hex ~start_offset ~end_offset = + let len = end_offset - start_offset in + let is_digit = function + | '0' .. '9' -> true + | _ -> false + in + let txt = scanner.src in + let is_numeric_escape = + len = 3 + && (is_digit txt.[start_offset] [@doesNotRaise]) + && (is_digit txt.[start_offset + 1] [@doesNotRaise]) + && (is_digit txt.[start_offset + 2] [@doesNotRaise]) + in + if is_numeric_escape then ( + let str_decimal = (String.sub txt start_offset 3 [@doesNotRaise]) in + bring_buf_up_to_date ~start_offset; + let str_hex = Res_string.convert_decimal_to_hex ~str_decimal in + last_offset_in_buf := start_offset + 3; + Buffer.add_string buf str_hex; + scan ()) + else scan () + in + Token.String (scan ()) + +let scan_escape scanner = + (* '\' consumed *) + let offset = scanner.offset - 1 in + let convert_number scanner ~n ~base = + let x = ref 0 in + for _ = n downto 1 do + let d = digit_value scanner.ch in + x := (!x * base) + d; + next scanner + done; + let c = !x in + if Res_utf8.is_valid_code_point c then c else Res_utf8.repl + in + let codepoint = + match scanner.ch with + | '0' .. '9' -> convert_number scanner ~n:3 ~base:10 + | 'b' -> + next scanner; + 8 + | 'n' -> + next scanner; + 10 + | 'r' -> + next scanner; + 13 + | 't' -> + next scanner; + 009 + | 'x' -> + next scanner; + convert_number scanner ~n:2 ~base:16 + | 'o' -> + next scanner; + convert_number scanner ~n:3 ~base:8 + | 'u' -> ( + next scanner; + match scanner.ch with + | '{' -> + (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) + next scanner; + let x = ref 0 in + while + match scanner.ch with + | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true + | _ -> false + do + x := (!x * 16) + digit_value scanner.ch; + next scanner + done; + (* consume '}' in '\u{7A}' *) + (match scanner.ch with + | '}' -> next scanner + | _ -> ()); + let c = !x in + if Res_utf8.is_valid_code_point c then c else Res_utf8.repl + | _ -> + (* unicode escape sequence: '\u007A', exactly 4 hex digits *) + convert_number scanner ~n:4 ~base:16) + | ch -> + next scanner; + Char.code ch + in + let contents = + (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) + in + next scanner; + (* Consume \' *) + (* TODO: do we know it's \' ? *) + Token.Codepoint {c = codepoint; original = contents} + +let scan_regex scanner = + let start_pos = position scanner in + let buf = Buffer.create 0 in + let first_char_offset = scanner.offset in + let last_offset_in_buf = ref first_char_offset in + + let bring_buf_up_to_date ~start_offset = + let str_up_to_now = + (String.sub scanner.src !last_offset_in_buf + (start_offset - !last_offset_in_buf) [@doesNotRaise]) + in + Buffer.add_string buf str_up_to_now; + last_offset_in_buf := start_offset + in + + let result ~first_char_offset ~last_char_offset = + if Buffer.length buf = 0 then + (String.sub [@doesNotRaise]) scanner.src first_char_offset + (last_char_offset - first_char_offset) + else ( + bring_buf_up_to_date ~start_offset:last_char_offset; + Buffer.contents buf) + in + let rec scan ?(in_char_class = false) () = + match scanner.ch with + | '/' when not in_char_class -> + let last_char_offset = scanner.offset in + next scanner; + let pattern = result ~first_char_offset ~last_char_offset in + let flags = + let flags_buf = Buffer.create 0 in + let rec scan_flags () = + match scanner.ch with + | 'd' | 'g' | 'i' | 'm' | 's' | 'u' | 'v' | 'y' -> + Buffer.add_char flags_buf scanner.ch; + next scanner; + scan_flags () + | _ -> Buffer.contents flags_buf + in + scan_flags () + in + (pattern, flags) + | ch when ch == '\n' || ch == hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos (Diagnostics.message "unterminated regex"); + ("", "") + | '\\' -> + next scanner; + next scanner; + scan ~in_char_class () + | '[' when not in_char_class -> + next scanner; + scan ~in_char_class:true () + | ']' when in_char_class -> + next scanner; + scan ~in_char_class:false () + | _ -> + next scanner; + scan ~in_char_class () + in + let pattern, flags = scan () in + let end_pos = position scanner in + (start_pos, end_pos, Token.Regex (pattern, flags)) + +let scan_single_line_comment scanner = + let start_off = scanner.offset in + let start_pos = position scanner in + let rec skip scanner = + match scanner.ch with + | '\n' | '\r' -> () + | ch when ch == hacky_eof_char -> () + | _ -> + next scanner; + skip scanner + in + skip scanner; + let end_pos = position scanner in + Token.Comment + (Comment.make_single_line_comment + ~loc: + Location.{loc_start = start_pos; loc_end = end_pos; loc_ghost = false} + ((String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - start_off))) + +let scan_multi_line_comment scanner = + (* assumption: we're only ever using this helper in `scan` after detecting a comment *) + let doc_comment = + peek2 scanner = '*' && peek3 scanner <> '/' + (* no /**/ *) + in + let standalone = + doc_comment && peek3 scanner = '*' + (* /*** *) + in + let content_start_off = + scanner.offset + if doc_comment then if standalone then 4 else 3 else 2 + in + let start_pos = position scanner in + let rec scan ~depth = + (* invariant: depth > 0 right after this match. See assumption *) + match (scanner.ch, peek scanner) with + | '/', '*' -> + next2 scanner; + scan ~depth:(depth + 1) + | '*', '/' -> + next2 scanner; + if depth > 1 then scan ~depth:(depth - 1) + | ch, _ when ch == hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos Diagnostics.unclosed_comment + | _ -> + next scanner; + scan ~depth + in + scan ~depth:0; + let length = scanner.offset - 2 - content_start_off in + let length = if length < 0 (* in case of EOF *) then 0 else length in + Token.Comment + (Comment.make_multi_line_comment ~doc_comment ~standalone + ~loc: + Location. + { + loc_start = start_pos; + loc_end = position scanner; + loc_ghost = false; + } + ((String.sub [@doesNotRaise]) scanner.src content_start_off length)) + +let scan_template_literal_token scanner = + let start_off = scanner.offset in + + (* if starting } here, consume it *) + if scanner.ch == '}' then next scanner; + + let start_pos = position scanner in + + let rec scan () = + let last_pos = position scanner in + match scanner.ch with + | '`' -> + next scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - 1 - start_off) + in + Token.TemplateTail (contents, last_pos) + | '$' -> ( + match peek scanner with + | '{' -> + next2 scanner; + let contents = + (String.sub [@doesNotRaise]) scanner.src start_off + (scanner.offset - 2 - start_off) + in + Token.TemplatePart (contents, last_pos) + | _ -> + next scanner; + scan ()) + | '\\' -> ( + match peek scanner with + | '`' | '\\' | '$' | '\n' | '\r' -> + (* line break *) + next2 scanner; + scan () + | _ -> + next scanner; + scan ()) + | ch when ch = hacky_eof_char -> + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos Diagnostics.unclosed_template; + let contents = + (String.sub [@doesNotRaise]) scanner.src start_off + (max (scanner.offset - 1 - start_off) 0) + in + Token.TemplateTail (contents, last_pos) + | _ -> + next scanner; + scan () + in + let token = scan () in + let end_pos = position scanner in + (start_pos, end_pos, token) + +let rec scan scanner = + skip_whitespace scanner; + let start_pos = position scanner in + + let token = + match scanner.ch with + (* peeking 0 char *) + | 'A' .. 'Z' | 'a' .. 'z' -> scan_identifier scanner + | '0' .. '9' -> scan_number scanner + | '`' -> + next scanner; + Token.Backtick + | '~' -> ( + match (peek scanner, peek2 scanner) with + | '~', '~' -> + next3 scanner; + Token.Bnot + | _ -> + next scanner; + Token.Tilde) + | '?' -> + next scanner; + Token.Question + | ';' -> + next scanner; + Token.Semicolon + | '(' -> + next scanner; + Token.Lparen + | ')' -> + next scanner; + Token.Rparen + | '[' -> + next scanner; + Token.Lbracket + | ']' -> + next scanner; + Token.Rbracket + | '{' -> + next scanner; + Token.Lbrace + | '}' -> + next scanner; + Token.Rbrace + | ',' -> + next scanner; + Token.Comma + | '"' -> scan_string scanner + (* peeking 1 char *) + | '_' -> ( + match peek scanner with + | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scan_identifier scanner + | _ -> + next scanner; + Token.Underscore) + | '#' -> ( + match peek scanner with + | '=' -> + next2 scanner; + Token.HashEqual + | _ -> + next scanner; + Token.Hash) + | '*' -> ( + match peek scanner with + | '*' -> + next2 scanner; + Token.Exponentiation + | '.' -> + next2 scanner; + Token.AsteriskDot + | _ -> + next scanner; + Token.Asterisk) + | '@' -> ( + match peek scanner with + | '@' -> + next2 scanner; + Token.AtAt + | _ -> + next scanner; + Token.At) + | '%' -> ( + match peek scanner with + | '%' -> + next2 scanner; + Token.PercentPercent + | _ -> + next scanner; + Token.Percent) + | '|' -> ( + match (peek scanner, peek2 scanner) with + | '|', '|' -> + next3 scanner; + Token.Bor + | '|', _ -> + next2 scanner; + Token.Lor + | _ -> + next scanner; + Token.Bar) + | '&' -> ( + match (peek scanner, peek2 scanner) with + | '&', '&' -> + next3 scanner; + Token.Band + | '&', _ -> + next2 scanner; + Token.Land + | _ -> + next scanner; + Token.Ampersand) + | '^' -> ( + match (peek scanner, peek2 scanner) with + | '^', '^' -> + next3 scanner; + Token.Bxor + | _ -> + next scanner; + Token.Caret) + | ':' -> ( + match peek scanner with + | '=' -> + next2 scanner; + Token.ColonEqual + | '>' -> + next2 scanner; + Token.ColonGreaterThan + | _ -> + next scanner; + Token.Colon) + | '\\' -> scan_exotic_identifier scanner + | '/' -> ( + match peek scanner with + | '/' -> + next2 scanner; + scan_single_line_comment scanner + | '*' -> scan_multi_line_comment scanner + | '.' -> + next2 scanner; + Token.ForwardslashDot + | _ -> + next scanner; + Token.Forwardslash) + | '-' -> ( + match peek scanner with + | '.' -> + next2 scanner; + Token.MinusDot + | '>' -> + next2 scanner; + Token.MinusGreater + | _ -> + next scanner; + Token.Minus) + | '+' -> ( + match peek scanner with + | '.' -> + next2 scanner; + Token.PlusDot + | '+' -> + next2 scanner; + Token.PlusPlus + | '=' -> + next2 scanner; + Token.PlusEqual + | _ -> + next scanner; + Token.Plus) + | '>' when not (in_diamond_mode scanner) -> ( + match peek scanner with + | '=' -> + next2 scanner; + Token.GreaterEqual + | '>' -> ( + match peek2 scanner with + | '>' -> + next3 scanner; + Token.RightShiftUnsigned + | _ -> + next2 scanner; + Token.RightShift) + | _ -> + next scanner; + Token.GreaterThan) + | '>' -> + next scanner; + Token.GreaterThan + | '<' -> ( + match peek scanner with + | '<' when not (in_diamond_mode scanner) -> + next2 scanner; + Token.LeftShift + | '=' -> + next2 scanner; + Token.LessEqual + | _ -> + next scanner; + Token.LessThan) + (* peeking 2 chars *) + | '.' -> ( + match (peek scanner, peek2 scanner) with + | '.', '.' -> + next3 scanner; + Token.DotDotDot + | '.', _ -> + next2 scanner; + Token.DotDot + | _ -> + next scanner; + Token.Dot) + | '\'' -> ( + match (peek scanner, peek2 scanner) with + | '\\', '"' -> + (* careful with this one! We're next-ing _once_ (not twice), + then relying on matching on the quote *) + next scanner; + SingleQuote + | '\\', _ -> + next2 scanner; + scan_escape scanner + | ch, '\'' -> + let offset = scanner.offset + 1 in + next3 scanner; + Token.Codepoint + { + c = Char.code ch; + original = (String.sub [@doesNotRaise]) scanner.src offset 1; + } + | ch, _ -> + next scanner; + let offset = scanner.offset in + let offset16 = scanner.offset16 in + let codepoint, length = + Res_utf8.decode_code_point scanner.offset scanner.src + (String.length scanner.src) + in + for _ = 0 to length - 1 do + next scanner + done; + if scanner.ch = '\'' then ( + let contents = + (String.sub [@doesNotRaise]) scanner.src offset length + in + next scanner; + Token.Codepoint {c = codepoint; original = contents}) + else ( + scanner.ch <- ch; + scanner.offset <- offset; + scanner.offset16 <- offset16; + SingleQuote)) + | '!' -> ( + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.BangEqualEqual + | '=', _ -> + next2 scanner; + Token.BangEqual + | _ -> + next scanner; + Token.Bang) + | '=' -> ( + match (peek scanner, peek2 scanner) with + | '=', '=' -> + next3 scanner; + Token.EqualEqualEqual + | '=', _ -> + next2 scanner; + Token.EqualEqual + | '>', _ -> + next2 scanner; + Token.EqualGreater + | _ -> + next scanner; + Token.Equal) + (* special cases *) + | ch when ch == hacky_eof_char -> + next scanner; + Token.Eof + | ch -> + (* if we arrive here, we're dealing with an unknown character, + * report the error and continue scanning… *) + next scanner; + let end_pos = position scanner in + scanner.err ~start_pos ~end_pos (Diagnostics.unknown_uchar ch); + let _, _, token = scan scanner in + token + in + let end_pos = position scanner in + (* _printDebug ~startPos ~endPos scanner token; *) + (start_pos, end_pos, token) + +(* misc helpers used elsewhere *) + +(* If an operator has whitespace around both sides, it's a binary operator *) +(* TODO: this helper seems out of place *) +let is_binary_op src start_cnum end_cnum = + if start_cnum == 0 then false + else ( + (* we're gonna put some assertions and invariant checks here because this is + used outside of the scanner's normal invariant assumptions *) + assert (end_cnum >= 0); + assert (start_cnum > 0 && start_cnum < String.length src); + let left_ok = is_whitespace (String.unsafe_get src (start_cnum - 1)) in + (* we need some stronger confidence that endCnum is ok *) + let right_ok = + end_cnum >= String.length src + || is_whitespace (String.unsafe_get src end_cnum) + in + left_ok && right_ok) diff --git a/compiler/syntax/src/res_scanner.mli b/compiler/syntax/src/res_scanner.mli new file mode 100644 index 0000000..e558967 --- /dev/null +++ b/compiler/syntax/src/res_scanner.mli @@ -0,0 +1,41 @@ +type mode = Diamond + +type char_encoding + +type t = { + filename: string; + src: string; + mutable err: + start_pos:Lexing.position -> + end_pos:Lexing.position -> + Res_diagnostics.category -> + unit; + mutable ch: char_encoding; (* current character *) + mutable offset: int; (* current byte offset *) + mutable offset16: int; + (* current number of utf16 code units since line start *) + mutable line_offset: int; (* current line offset *) + mutable lnum: int; (* current line number *) + mutable mode: mode list; +} + +val make : filename:string -> string -> t + +(* TODO: make this a record *) +val scan : t -> Lexing.position * Lexing.position * Res_token.t + +val is_binary_op : string -> int -> int -> bool + +val set_diamond_mode : t -> unit +val pop_mode : t -> mode -> unit + +val scan_template_literal_token : + t -> Lexing.position * Lexing.position * Res_token.t + +val scan_regex : t -> Lexing.position * Lexing.position * Res_token.t + +(* Look ahead to see if the next non-whitespace character is a minus *) +val peekMinus : t -> bool + +(* Look ahead to see if the next non-whitespace character is a slash *) +val peekSlash : t -> bool diff --git a/compiler/syntax/src/res_string.ml b/compiler/syntax/src/res_string.ml new file mode 100644 index 0000000..6ef33a2 --- /dev/null +++ b/compiler/syntax/src/res_string.ml @@ -0,0 +1,11 @@ +let hex_table = + [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; |] + [@ocamlformat "disable"] + +let convert_decimal_to_hex ~str_decimal = + try + let int_num = int_of_string str_decimal in + let c1 = Array.get hex_table (int_num lsr 4) in + let c2 = Array.get hex_table (int_num land 15) in + "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] + with Invalid_argument _ | Failure _ -> str_decimal diff --git a/jscomp/syntax/src/res_token.ml b/compiler/syntax/src/res_token.ml similarity index 75% rename from jscomp/syntax/src/res_token.ml rename to compiler/syntax/src/res_token.ml index 5d12e0f..192c976 100644 --- a/jscomp/syntax/src/res_token.ml +++ b/compiler/syntax/src/res_token.ml @@ -17,7 +17,7 @@ type t = | DotDotDot | Bang | Semicolon - | Let + | Let of {unwrap: bool} | And | Rec | Underscore @@ -25,6 +25,7 @@ type t = | Equal | EqualEqual | EqualEqualEqual + | Ampersand | Bar | Lparen | Rparen @@ -39,6 +40,7 @@ type t = | Backslash [@live] | Forwardslash | ForwardslashDot + | Regex of string * string | Asterisk | AsteriskDot | Exponentiation @@ -51,11 +53,9 @@ type t = | ColonGreaterThan | GreaterThan | LessThan - | LessThanSlash | Hash | HashEqual | Assert - | Lazy | Tilde | Question | If @@ -77,7 +77,11 @@ type t = | Of | Land | Lor - | Band (* Bitwise and: & *) + | Bnot (* Bitwise not: ~~~ *) + | Bor (* Bitwise or: ||| *) + | Bxor (* Bitwise xor: ^^^ *) + | Band (* Bitwise and: &&& *) + | Caret | BangEqual | BangEqualEqual | LessEqual @@ -89,29 +93,36 @@ type t = | PercentPercent | Comment of Comment.t | List + | Dict | TemplateTail of string * Lexing.position | TemplatePart of string * Lexing.position | Backtick - | BarGreater | Try | DocComment of Location.t * string | ModuleComment of Location.t * string + | LeftShift + | RightShift + | RightShiftUnsigned let precedence = function | HashEqual | ColonEqual -> 1 | Lor -> 2 | Land -> 3 + | Bor -> 4 + | Bxor -> 5 + | Band -> 6 | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan | BangEqual - | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> - 4 - | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 - | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 - | Exponentiation -> 7 - | MinusGreater -> 8 - | Dot -> 9 + | BangEqualEqual | LessEqual | GreaterEqual -> + 7 + | LeftShift | RightShift | RightShiftUnsigned -> 8 + | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 9 + | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot | Percent -> 10 + | Exponentiation -> 11 + | MinusGreater -> 12 + | Dot -> 13 | _ -> 0 -let toString = function +let to_string = function | Await -> "await" | Open -> "open" | True -> "true" @@ -127,7 +138,8 @@ let toString = function | Float {f} -> "Float: " ^ f | Bang -> "!" | Semicolon -> ";" - | Let -> "let" + | Let {unwrap = true} -> "let?" + | Let {unwrap = false} -> "let" | And -> "and" | Rec -> "rec" | Underscore -> "_" @@ -136,6 +148,7 @@ let toString = function | EqualEqual -> "==" | EqualEqualEqual -> "===" | Eof -> "eof" + | Ampersand -> "&" | Bar -> "|" | As -> "as" | Lparen -> "(" @@ -154,6 +167,7 @@ let toString = function | PlusPlus -> "++" | PlusEqual -> "+=" | Backslash -> "\\" + | Regex (pattern, flags) -> "regex: /" ^ pattern ^ "/" ^ flags | Forwardslash -> "/" | ForwardslashDot -> "/." | Exception -> "exception" @@ -161,13 +175,11 @@ let toString = function | HashEqual -> "#=" | GreaterThan -> ">" | LessThan -> "<" - | LessThanSlash -> " "*" | AsteriskDot -> "*." | Exponentiation -> "**" | Assert -> "assert" - | Lazy -> "lazy" - | Tilde -> "tilde" + | Tilde -> "~" | Question -> "?" | If -> "if" | Else -> "else" @@ -187,7 +199,11 @@ let toString = function | Module -> "module" | Of -> "of" | Lor -> "||" - | Band -> "&" + | Bnot -> "~~~" + | Bor -> "|||" + | Bxor -> "^^^" + | Band -> "&&&" + | Caret -> "^" | Land -> "&&" | BangEqual -> "!=" | BangEqualEqual -> "!==" @@ -198,17 +214,20 @@ let toString = function | AtAt -> "@@" | Percent -> "%" | PercentPercent -> "%%" - | Comment c -> "Comment" ^ Comment.toString c + | Comment c -> "Comment" ^ Comment.to_string c | List -> "list{" + | Dict -> "dict{" | TemplatePart (text, _) -> text ^ "${" | TemplateTail (text, _) -> "TemplateTail(" ^ text ^ ")" | Backtick -> "`" - | BarGreater -> "|>" | Try -> "try" | DocComment (_loc, s) -> "DocComment " ^ s | ModuleComment (_loc, s) -> "ModuleComment " ^ s + | LeftShift -> "<<" + | RightShift -> ">>" + | RightShiftUnsigned -> ">>>" -let keywordTable = function +let keyword_table = function | "and" -> And | "as" -> As | "assert" -> Assert @@ -222,9 +241,10 @@ let keywordTable = function | "if" -> If | "in" -> In | "include" -> Include - | "lazy" -> Lazy - | "let" -> Let + | "let?" -> Let {unwrap = true} + | "let" -> Let {unwrap = false} | "list{" -> List + | "dict{" -> Dict | "module" -> Module | "mutable" -> Mutable | "of" -> Of @@ -240,23 +260,23 @@ let keywordTable = function | _ -> raise Not_found [@@raises Not_found] -let isKeyword = function +let is_keyword = function | Await | And | As | Assert | Constraint | Else | Exception | External | False - | For | If | In | Include | Land | Lazy | Let | List | Lor | Module | Mutable - | Of | Open | Private | Rec | Switch | True | Try | Typ | When | While -> + | For | If | In | Include | Land | Let _ | List | Lor | Module | Mutable | Of + | Open | Private | Rec | Switch | True | Try | Typ | When | While | Dict -> true | _ -> false -let lookupKeyword str = - try keywordTable str +let lookup_keyword str = + try keyword_table str with Not_found -> ( match str.[0] [@doesNotRaise] with | 'A' .. 'Z' -> Uident str | _ -> Lident str) -let isKeywordTxt str = +let is_keyword_txt str = try - let _ = keywordTable str in + let _ = keyword_table str in true with Not_found -> false diff --git a/compiler/syntax/src/res_token_debugger.ml b/compiler/syntax/src/res_token_debugger.ml new file mode 100644 index 0000000..93a4b9f --- /dev/null +++ b/compiler/syntax/src/res_token_debugger.ml @@ -0,0 +1,145 @@ +let dump_tokens filename = + let src = + try + let ic = open_in filename in + let content = really_input_string ic (in_channel_length ic) in + close_in ic; + content + with e -> + Printf.printf "Error reading file %s: %s\n" filename + (Printexc.to_string e); + exit 1 + in + + let scanner = Res_scanner.make ~filename src in + + let rec visit scanner = + let start_pos, end_pos, token = Res_scanner.scan scanner in + let token_str = + match token with + | Res_token.Await -> "Await" + | Res_token.Open -> "Open" + | Res_token.True -> "True" + | Res_token.False -> "False" + | Res_token.Codepoint {original} -> "Codepoint(\"" ^ original ^ "\")" + | Res_token.Int {i} -> "Int(\"" ^ i ^ "\")" + | Res_token.Float {f} -> "Float(\"" ^ f ^ "\")" + | Res_token.String s -> "String(\"" ^ s ^ "\")" + | Res_token.Lident str -> "Lident(\"" ^ str ^ "\")" + | Res_token.Uident str -> "Uident(\"" ^ str ^ "\")" + | Res_token.As -> "As" + | Res_token.Dot -> "Dot" + | Res_token.DotDot -> "DotDot" + | Res_token.DotDotDot -> "DotDotDot" + | Res_token.Bang -> "Bang" + | Res_token.Semicolon -> "Semicolon" + | Res_token.Let {unwrap} -> "Let" ^ if unwrap then "?" else "" + | Res_token.And -> "And" + | Res_token.Rec -> "Rec" + | Res_token.Underscore -> "Underscore" + | Res_token.SingleQuote -> "SingleQuote" + | Res_token.Equal -> "Equal" + | Res_token.EqualEqual -> "EqualEqual" + | Res_token.EqualEqualEqual -> "EqualEqualEqual" + | Res_token.Ampersand -> "Ampersand" + | Res_token.Bar -> "Bar" + | Res_token.Lparen -> "Lparen" + | Res_token.Rparen -> "Rparen" + | Res_token.Lbracket -> "Lbracket" + | Res_token.Rbracket -> "Rbracket" + | Res_token.Lbrace -> "Lbrace" + | Res_token.Rbrace -> "Rbrace" + | Res_token.Colon -> "Colon" + | Res_token.Comma -> "Comma" + | Res_token.Eof -> "Eof" + | Res_token.Exception -> "Exception" + | Res_token.Backslash -> "Backslash" + | Res_token.Forwardslash -> "Forwardslash" + | Res_token.ForwardslashDot -> "ForwardslashDot" + | Res_token.Regex (pattern, flags) -> + "Regex(\"" ^ pattern ^ "\", \"" ^ flags ^ "\")" + | Res_token.Asterisk -> "Asterisk" + | Res_token.AsteriskDot -> "AsteriskDot" + | Res_token.Exponentiation -> "Exponentiation" + | Res_token.Minus -> "Minus" + | Res_token.MinusDot -> "MinusDot" + | Res_token.Plus -> "Plus" + | Res_token.PlusDot -> "PlusDot" + | Res_token.PlusPlus -> "PlusPlus" + | Res_token.PlusEqual -> "PlusEqual" + | Res_token.ColonGreaterThan -> "ColonGreaterThan" + | Res_token.GreaterThan -> "GreaterThan" + | Res_token.LessThan -> "LessThan" + | Res_token.Hash -> "Hash" + | Res_token.HashEqual -> "HashEqual" + | Res_token.Assert -> "Assert" + | Res_token.Tilde -> "Tilde" + | Res_token.Question -> "Question" + | Res_token.If -> "If" + | Res_token.Else -> "Else" + | Res_token.For -> "For" + | Res_token.In -> "In" + | Res_token.While -> "While" + | Res_token.Switch -> "Switch" + | Res_token.When -> "When" + | Res_token.EqualGreater -> "EqualGreater" + | Res_token.MinusGreater -> "MinusGreater" + | Res_token.External -> "External" + | Res_token.Typ -> "Typ" + | Res_token.Private -> "Private" + | Res_token.Constraint -> "Constraint" + | Res_token.Mutable -> "Mutable" + | Res_token.Include -> "Include" + | Res_token.Module -> "Module" + | Res_token.Of -> "Of" + | Res_token.Land -> "Land" + | Res_token.Lor -> "Lor" + | Res_token.Bnot -> "Bnot" + | Res_token.Bor -> "Bor" + | Res_token.Band -> "Band" + | Res_token.Bxor -> "Bxor" + | Res_token.Caret -> "Caret" + | Res_token.BangEqual -> "BangEqual" + | Res_token.BangEqualEqual -> "BangEqualEqual" + | Res_token.LessEqual -> "LessEqual" + | Res_token.GreaterEqual -> "GreaterEqual" + | Res_token.ColonEqual -> "ColonEqual" + | Res_token.At -> "At" + | Res_token.AtAt -> "AtAt" + | Res_token.Percent -> "Percent" + | Res_token.PercentPercent -> "PercentPercent" + | Res_token.Comment c -> "Comment(" ^ Res_comment.to_string c ^ ")" + | Res_token.List -> "List" + | Res_token.Dict -> "Dict" + | Res_token.TemplateTail (text, _) -> "TemplateTail(\"" ^ text ^ "\")" + | Res_token.TemplatePart (text, _) -> "TemplatePart(\"" ^ text ^ "\")" + | Res_token.Backtick -> "Backtick" + | Res_token.Try -> "Try" + | Res_token.DocComment (_, s) -> "DocComment(\"" ^ s ^ "\")" + | Res_token.ModuleComment (_, s) -> "ModuleComment(\"" ^ s ^ "\")" + | Res_token.LeftShift -> "LeftShift" + | Res_token.RightShift -> "RightShift" + | Res_token.RightShiftUnsigned -> "RightShiftUnsigned" + in + + let start_line = start_pos.Lexing.pos_lnum in + let start_col = start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol + 1 in + let end_line = end_pos.Lexing.pos_lnum in + let end_col = end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol + 1 in + + Printf.printf "%s (%d,%d-%d,%d)\n" token_str start_line start_col end_line + end_col; + + match token with + | Res_token.Eof -> () + | _ -> visit scanner + in + visit scanner + +let token_print_engine = + { + Res_driver.print_implementation = + (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens filename); + print_interface = + (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens filename); + } diff --git a/compiler/syntax/src/res_token_debugger.mli b/compiler/syntax/src/res_token_debugger.mli new file mode 100644 index 0000000..f8dea07 --- /dev/null +++ b/compiler/syntax/src/res_token_debugger.mli @@ -0,0 +1 @@ +val token_print_engine : Res_driver.print_engine diff --git a/jscomp/syntax/src/res_utf8.ml b/compiler/syntax/src/res_utf8.ml similarity index 94% rename from jscomp/syntax/src/res_utf8.ml rename to compiler/syntax/src/res_utf8.ml index 69c7d23..c416217 100644 --- a/jscomp/syntax/src/res_utf8.ml +++ b/compiler/syntax/src/res_utf8.ml @@ -6,8 +6,8 @@ let repl = 0xFFFD (* let min = 0x0000 *) let max = 0x10FFFF -let surrogateMin = 0xD800 -let surrogateMax = 0xDFFF +let surrogate_min = 0xD800 +let surrogate_max = 0xDFFF (* * Char. number range | UTF-8 octet sequence @@ -29,7 +29,7 @@ type category = {low: int; high: int; size: int} let locb = 0b1000_0000 let hicb = 0b1011_1111 -let categoryTable = [| +let category_table = [| (* 0 *) {low = -1; high= -1; size= 1}; (* invalid *) (* 1 *) {low = 1; high= -1; size= 1}; (* ascii *) (* 2 *) {low = locb; high= hicb; size= 2}; @@ -62,7 +62,7 @@ let categories = [| 6; 7; 7 ;7; 8; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; |] [@@ocamlformat "disable"] -let decodeCodePoint i s len = +let decode_code_point i s len = if len < 1 then (repl, 1) else let first = int_of_char (String.unsafe_get s i) in @@ -71,7 +71,7 @@ let decodeCodePoint i s len = let index = Array.unsafe_get categories first in if index = 0 then (repl, 1) else - let cat = Array.unsafe_get categoryTable index in + let cat = Array.unsafe_get category_table index in if len < i + cat.size then (repl, 1) else if cat.size == 2 then let c1 = int_of_char (String.unsafe_get s (i + 1)) in @@ -108,7 +108,7 @@ let decodeCodePoint i s len = let uc = i0 lor i3 lor i2 lor i1 in (uc, 4) -let encodeCodePoint c = +let encode_code_point c = if c <= 127 then ( let bytes = (Bytes.create [@doesNotRaise]) 1 in Bytes.unsafe_set bytes 0 (Char.unsafe_chr c); @@ -139,5 +139,5 @@ let encodeCodePoint c = (Char.unsafe_chr (0b1000_0000 lor (c land cont_mask))); Bytes.unsafe_to_string bytes -let isValidCodePoint c = - (0 <= c && c < surrogateMin) || (surrogateMax < c && c <= max) +let is_valid_code_point c = + (0 <= c && c < surrogate_min) || (surrogate_max < c && c <= max) diff --git a/compiler/syntax/src/res_utf8.mli b/compiler/syntax/src/res_utf8.mli new file mode 100644 index 0000000..fc80c8b --- /dev/null +++ b/compiler/syntax/src/res_utf8.mli @@ -0,0 +1,9 @@ +val repl : int + +val max : int + +val decode_code_point : int -> string -> int -> int * int + +val encode_code_point : int -> string + +val is_valid_code_point : int -> bool diff --git a/dune b/dune index edfc76e..ca0859c 100644 --- a/dune +++ b/dune @@ -1,4 +1,4 @@ -(dirs bin lib jscomp test) +(dirs bin lib compiler test) (env (dev diff --git a/dune-project b/dune-project index e8c0376..ac1ebe9 100644 --- a/dune-project +++ b/dune-project @@ -2,7 +2,7 @@ (name rescript_linter) -(version 0.3.3) +(version 0.4.0) (generate_opam_files true) @@ -19,4 +19,4 @@ (name rescript_linter) (synopsis "AST-based linter for ReScript") (description "AST-based linter for ReScript") - (depends dune yojson)) + (depends dune yojson flow_parser)) diff --git a/flake.nix b/flake.nix index 4089ba4..6763ccc 100644 --- a/flake.nix +++ b/flake.nix @@ -29,6 +29,33 @@ # Library functions from nixpkgs lib = legacyPackages.lib; + # Custom flow_parser package from rescript-lang fork + flow_parser = ocamlPackages.buildDunePackage { + pname = "flow_parser"; + version = "0.267.0"; + duneVersion = "3"; + + src = legacyPackages.fetchFromGitHub { + owner = "rescript-lang"; + repo = "flow"; + rev = "9ea4062c0b7e037415c4413a7634c459ebd5c31b"; + sha256 = "sha256-jm8FCscyeBQMyObi90sCMiKFXxh4EHt/3nYWit4qwFs="; + }; + + buildInputs = [ + ocamlPackages.ppx_deriving + ocamlPackages.ppx_gen_rec + ]; + + propagatedBuildInputs = [ + ocamlPackages.base + ocamlPackages.ppxlib + ocamlPackages.wtf8 + ]; + + strictDeps = true; + }; + project-sources = nix-filter.lib { root = ./.; include = [ @@ -49,7 +76,7 @@ (nix-filter.lib.inDirectory "doc") (nix-filter.lib.inDirectory "lib") (nix-filter.lib.inDirectory "test") - (nix-filter.lib.inDirectory "jscomp") + (nix-filter.lib.inDirectory "compiler") ]; }; @@ -100,7 +127,7 @@ rescript-linter = ocamlPackages.buildDunePackage { pname = "rescript_linter"; - version = "0.3.3"; + version = "0.4.0"; duneVersion = "3"; src = sources.all; @@ -108,6 +135,7 @@ ocamlPackages.cppo ]; buildInputs = [ + flow_parser ocamlPackages.yojson ocamlPackages.ppx_deriving_yojson ocamlPackages.ounit2 diff --git a/jscomp/bsb/.ocamlformat b/jscomp/bsb/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/bsb/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/bsb/bsb.md b/jscomp/bsb/bsb.md deleted file mode 100644 index e081fa4..0000000 --- a/jscomp/bsb/bsb.md +++ /dev/null @@ -1,201 +0,0 @@ -# Phony targets - - -# collect file groups - -1. we need check integrity of files here? -cases: -one directory have two same files -- ignore, does not matter here? -two directories ha - -# generate ninja from file groups - -`Bsb_file_groups.file_group list` -one directory, one kind -- -when we merge we will have two `dirs` - -do we allow duplicate modules? - -suppose : -lib -> 0 - -dev -> 1 -dev -> 2 -dev -> 3 - -so that they can have same names - - -.default -All output (not just js in case we support native build) - -.install - -It's hard to bake it in built rules, since it is flag dependent, if you have `-bin-annot` -then you would like to install `cmt` too, however, it might be or not be there - -# meta-data files - -- .bsbuild -- .bsdeps -- .sourcedirs -# post-build - -Here we have `js` generated, we can do either post-build or -create a new rule. - -Note creating new rules will get more concurrency while post-build is easy -and can do in source modification - -https://groups.google.com/forum/#!searchin/ninja-build/post$20process%7Csort:relevance/ninja-build/Q4hpcDmhPzw/KZpDyOEFuTkJ - -# Performance tweaks - -Writing(truncating) files are significantly slower (20~30x) and it destroys cache(see Appendix), we should -try to avoid writing too many files. - -bsb is optimized for incremental build (especially for modifying files ). - -There is a trade off here: if we generate `.bsdep` file, whenever adding or removing file, `.bscache` will not -impact the integrity of `.bsdep`, so that it will run `.bsdep -> .d`. - -The downside is -1. clean build will generate more smaller files (slow down), -2. build system has to track more outputs (latency, stat more files almost doubled) - -Whenever we change a file it will regenerate the ast, optionally update `.bsdep` - -So assuming that merge `.bsdep` into `.mlast`, build system will track not more files. -The integrity of `.mlast` is not impacted by `.bscache`. -`.mlast -> .d` can be still improved, not as good as `.bsdep -> .d` since `.bsdep` -can check `.bsdep` time stamp. - -So let's change the `.mlast` to such format - ----------- -magic number -length of dependent modules -dependent modules -binary ast ----------- - -This file is integrity is not impacted by `.bscache`. whenever `.bscache` changes we check if we need regenerate `.d` - -# Appendix -[source,ocaml] --------------- -module Set_string = Set.Make(String) - -(* let v = Set_string.of_list ["List" ; "Set" ; "String" ; "Test_order"] *) -let v = Set_string.of_list [] -let deseralize f = - let ichan = open_in_bin f in - let v : Set_string.t = input_value ichan in - close_in ichan ; - v - -let time f arg = - let v0 = Unix.gettimeofday () in - ignore @@ f arg; - let v1 = Unix.gettimeofday () in - print_endline (Printf.sprintf "%f elapsed" (v1 -. v0)) - -let deseralize_and_compare f = - ignore @@ Set_string.equal v (deseralize f) - -let seralize f = - let ochan = open_out_bin f in - output_value ochan v ; - close_out ochan - -let try_seralize f = - match open_in_bin f with - | ichan -> - close_in ichan ; - let ochan = open_out_bin f in - output_value ochan v ; - close_out ochan - | exception _ -> - let ochan = open_out_bin f in - output_value ochan v ; - close_out ochan - -let try_seralize2 f = - if Sys.file_exists f then - let ochan = open_out_bin f in - output_value ochan v ; - close_out ochan - else - let ochan = open_out_bin f in - output_value ochan v ; - close_out ochan - - - -let () = - let file = "/Users/hzhang295/git/tmp/bench/e.mldeps" in - time try_seralize file; - Unix.unlink file ; - time try_seralize2 file; - Unix.unlink file ; - time seralize file; - time deseralize_and_compare file; - Unix.unlink file - -(* -0.002452 elapsed -0.002440 elapsed -0.001954 elapsed -0.000079 elapsed - -*) - --------------- - -# package-flags - - when designing bsc command line flags, we ask user to specify the output path of package output - instead of calculating, - the reason is that the user input can be absolute path or relative path, to calculate - we also need the location of package.json. - - - ## document when regenerating `build.ninja` - - - when `bsb.exe` path is changed - - when `bsb.exe` version is changed - - ## other internal options - --no-dev -- don't build dev directory group --install -- install files - -## document when regenerating `.merlin` - -## TODO: seems we can do it - -1. instead of specifying the whole relative path, just specifying the offset - ``` --bs-package-output commonjs:+lib/js -bs-package-output amdjs:+lib/amdjs xx.mlast - ``` - - With this we would simplify the build a lot. - - on Windows - ``` - -bs-package-output commonjs:+lib\js -bs-package-output:+lib\amdjs xx.ml a/b/c/xx.mlast - ``` - - so when the user input is relative path, we do the concat, - if it is absolute path, we calculate the relative path first. - - This is complicated vs - - ``` - -bs-package-output commonjs -bs-package-output amdjs - ``` - - however, the bsc is almost sitting in `lib/bs` - -2. caching Directory operations -3. Read `bsconfig.json` from watchcer side, so that we can caching io operations more effeciently? diff --git a/jscomp/bsb/bsb_arg.ml b/jscomp/bsb/bsb_arg.ml deleted file mode 100644 index 2e5e4cf..0000000 --- a/jscomp/bsb/bsb_arg.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type anon_fun = rev_args:string list -> unit - -type string_action = - | String_call of (string -> unit) - | String_set of string ref - -type unit_action = Unit_call of (unit -> unit) | Unit_set of bool ref - -type spec = Unit of unit_action | String of string_action - -type error = Unknown of string | Missing of string - -type t = spec Ext_spec.t - -exception Bad of string - -let bad_arg s = raise_notrace (Bad s) - -let ( +> ) = Ext_buffer.add_string - -let usage_b (buf : Ext_buffer.t) ~usage (speclist : t) = - buf +> usage; - if Ext_array.is_empty speclist then () - else ( - buf +> "\nOptions:\n"; - let max_col = ref 0 in - Ext_array.iter speclist (fun (key, _, _) -> - if String.length key > !max_col then max_col := String.length key); - Ext_array.iter speclist (fun (key, _, doc) -> - if not (Ext_string.starts_with doc "*internal*") then ( - buf +> " "; - buf +> key; - buf +> String.make (!max_col - String.length key + 2) ' '; - let cur = ref 0 in - let doc_length = String.length doc in - while !cur < doc_length do - if !cur <> 0 then ( - buf +> "\n"; - buf +> String.make (!max_col + 4) ' '); - match String.index_from_opt doc !cur '\n' with - | None -> - buf +> String.sub doc !cur (String.length doc - !cur); - cur := doc_length - | Some new_line_pos -> - buf +> String.sub doc !cur (new_line_pos - !cur); - cur := new_line_pos + 1 - done; - buf +> "\n"))) - -let stop_raise ~usage ~(error : error) (speclist : t) = - let b = Ext_buffer.create 200 in - (match error with - | Unknown ("-help" | "--help" | "-h") -> - usage_b b ~usage speclist; - Ext_buffer.output_buffer stdout b; - exit 0 - | Unknown s -> - b +> "Unknown option \""; - b +> s; - b +> "\".\n" - | Missing s -> - b +> "Option \""; - b +> s; - b +> "\" needs an argument.\n"); - usage_b b ~usage speclist; - bad_arg (Ext_buffer.contents b) - -let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) - (speclist : t) anonfun = - let current = ref start in - let rev_list = ref [] in - while !current < finish do - let s = argv.(!current) in - incr current; - if s <> "" && s.[0] = '-' then - match Ext_spec.assoc3 speclist s with - | Some action -> ( - match action with - | Unit r -> ( - match r with - | Unit_set r -> r.contents <- true - | Unit_call f -> f ()) - | String f -> ( - if !current >= finish then - stop_raise ~usage ~error:(Missing s) speclist - else - let arg = argv.(!current) in - incr current; - match f with - | String_call f -> f arg - | String_set u -> u.contents <- arg)) - | None -> stop_raise ~usage ~error:(Unknown s) speclist - else rev_list := s :: !rev_list - done; - anonfun ~rev_args:!rev_list diff --git a/jscomp/bsb/bsb_arg.mli b/jscomp/bsb/bsb_arg.mli deleted file mode 100644 index 60d21f2..0000000 --- a/jscomp/bsb/bsb_arg.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2020 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type string_action = - | String_call of (string -> unit) - | String_set of string ref - -type unit_action = Unit_call of (unit -> unit) | Unit_set of bool ref - -type spec = Unit of unit_action | String of string_action - -type anon_fun = rev_args:string list -> unit - -exception Bad of string - -val parse_exn : - usage:string -> - argv:string array -> - ?start:int -> - ?finish:int -> - (string * spec * string) array -> - anon_fun -> - unit - -val bad_arg : string -> 'a diff --git a/jscomp/bsb/bsb_build_schemas.ml b/jscomp/bsb/bsb_build_schemas.ml deleted file mode 100644 index 5436f1c..0000000 --- a/jscomp/bsb/bsb_build_schemas.ml +++ /dev/null @@ -1,71 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let name = "name" - -let ppx_flags = "ppx-flags" -let pp_flags = "pp-flags" -let bs_external_includes = "bs-external-includes" -let bs_dependencies = "bs-dependencies" -let pinned_dependencies = "pinned-dependencies" -let bs_dev_dependencies = "bs-dev-dependencies" -let sources = "sources" -let dir = "dir" -let files = "files" -let subdirs = "subdirs" -let bsc_flags = "bsc-flags" -let excludes = "excludes" -let slow_re = "slow-re" -let resources = "resources" -let public = "public" -let js_post_build = "js-post-build" -let cmd = "cmd" -let package_specs = "package-specs" -let type_ = "type" -let export_all = "all" -let export_none = "none" -let use_stdlib = "use-stdlib" -let external_stdlib = "external-stdlib" -let reason = "reason" -let react_jsx = "react-jsx" -let jsx = "jsx" -let jsx_version = "version" -let jsx_module = "module" -let jsx_mode = "mode" -let jsx_v3_dependencies = "v3-dependencies" -let cut_generators = "cut-generators" -let generators = "generators" -let command = "command" -let edge = "edge" -let namespace = "namespace" -let in_source = "in-source" -let warnings = "warnings" -let number = "number" -let error = "error" -let suffix = "suffix" -let gentypeconfig = "gentypeconfig" -let language = "language" -let ignored_dirs = "ignored-dirs" - -let uncurried = "uncurried" \ No newline at end of file diff --git a/jscomp/bsb/bsb_build_util.ml b/jscomp/bsb/bsb_build_util.ml deleted file mode 100644 index 9982b5b..0000000 --- a/jscomp/bsb/bsb_build_util.ml +++ /dev/null @@ -1,228 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let flag_concat flag xs = - String.concat Ext_string.single_space - (Ext_list.flat_map xs (fun x -> [ flag; x ])) - -let ( // ) = Ext_path.combine - -let ppx_flags (xs : Bsb_config_types.ppx list) = - flag_concat "-ppx" - (Ext_list.map xs (fun x -> - if x.args = [] then Ext_filename.maybe_quote x.name - else - let fmt : _ format = - if Ext_sys.is_windows_or_cygwin then "\"%s %s\"" else "'%s %s'" - in - Printf.sprintf fmt x.name (String.concat " " x.args))) - -let pp_flag (xs : string) = "-pp " ^ Ext_filename.maybe_quote xs - -let include_dirs dirs = - String.concat Ext_string.single_space - (Ext_list.flat_map dirs (fun x -> [ "-I"; Ext_filename.maybe_quote x ])) - -let include_dirs_by dirs fn = - String.concat Ext_string.single_space - (Ext_list.flat_map dirs (fun x -> [ "-I"; Ext_filename.maybe_quote (fn x) ])) - -(* we use lazy $src_root_dir *) - -(* It does several conversion: - First, it will convert unix path to windows backward on windows platform. - Then if it is absolute path, it will do thing - Else if it is relative path, it will be rebased on project's root directory *) - -let convert_and_resolve_path : string -> string -> string = - if Sys.unix then ( // ) - else fun cwd path -> - if Ext_sys.is_windows_or_cygwin then - let p = Ext_string.replace_slash_backward path in - cwd // p - else failwith ("Unknown OS :" ^ Sys.os_type) -(* we only need convert the path in the beginning *) - -type result = { path : string; checked : bool } - -(* Magic path resolution: - foo => foo - foo/ => /absolute/path/to/projectRoot/node_modules/foo - foo/bar => /absolute/path/to/projectRoot/node_modules/foo/bar - /foo/bar => /foo/bar - ./foo/bar => /absolute/path/to/projectRoot/./foo/bar - Input is node path, output is OS dependent (normalized) path -*) -let resolve_bsb_magic_file ~cwd ~desc p : result = - let no_slash = Ext_string.no_slash_idx p in - if no_slash < 0 then - (* Single file FIXME: better error message for "" input *) - { path = p; checked = false } - else - let first_char = String.unsafe_get p 0 in - if Filename.is_relative p && first_char <> '.' then - let package_name, rest = Bsb_pkg_types.extract_pkg_name_and_file p in - let relative_path = - if Ext_sys.is_windows_or_cygwin then - Ext_string.replace_slash_backward rest - else rest - in - (* let p = if Ext_sys.is_windows_or_cygwin then Ext_string.replace_slash_backward p else p in *) - let package_dir = Bsb_pkg.resolve_bs_package ~cwd package_name in - let path = package_dir // relative_path in - if Sys.file_exists path then { path; checked = true } - else ( - Bsb_log.error "@{Could not resolve @} %s in %s@." p cwd; - failwith (p ^ " not found when resolving " ^ desc)) - else - (* relative path [./x/y]*) - { path = convert_and_resolve_path cwd p; checked = true } - -(** converting a file from Linux path format to Windows *) - -(** - {[ - mkp "a/b/c/d";; - mkp "/a/b/c/d" - ]} -*) -let rec mkp dir = - if not (Sys.file_exists dir) then - let parent_dir = Filename.dirname dir in - if parent_dir = Filename.current_dir_name then Unix.mkdir dir 0o777 - (* leaf node *) - else ( - mkp parent_dir; - Unix.mkdir dir 0o777) - else if not @@ Sys.is_directory dir then - failwith (dir ^ " exists but it is not a directory, plz remove it first") - else () - -let get_list_string_acc (s : Ext_json_types.t array) acc = - Ext_array.to_list_map_acc s acc (fun x -> - match x with Str x -> Some x.str | _ -> None) - -let get_list_string s = get_list_string_acc s [] - -(* Key is the path *) -let ( |? ) m (key, cb) = m |> Ext_json.test key cb - -type top = Expect_none | Expect_name of string - -type package_context = { proj_dir : string; top : top; is_pinned: bool } - -(** - TODO: check duplicate package name - ?use path as identity? - - Basic requirements - 1. cycle detection - 2. avoid duplication - 3. deterministic, since -make-world will also comes with -clean-world - -*) - -let pp_packages_rev ppf lst = - Ext_list.rev_iter lst (fun s -> Format.fprintf ppf "%s " s) - -let extract_pinned_dependencies (map : Ext_json_types.t Map_string.t) : Set_string.t = - match Map_string.find_opt map Bsb_build_schemas.pinned_dependencies with - | None -> Set_string.empty - | Some (Arr { content }) -> - Set_string.of_list (get_list_string content) - | Some config -> Bsb_exception.config_error config "expect an array of string" - -let rec walk_all_deps_aux (visited : string Hash_string.t) (paths : string list) - ~(top : top) (dir : string) (queue : _ Queue.t) ~pinned_dependencies = - match Bsb_config_load.load_json ~per_proj_dir:dir ~warn_legacy_config:false with - | _, Obj { map; loc } -> - let cur_package_name = - match Map_string.find_opt map Bsb_build_schemas.name with - | Some (Str { str; loc }) -> - (match top with - | Expect_none -> () - | Expect_name s -> - if s <> str then - Bsb_exception.errorf ~loc - "package name is expected to be %s but got %s" s str); - str - | Some _ | None -> - Bsb_exception.errorf ~loc "package name missing in %s/bsconfig.json" - dir - in - if Ext_list.mem_string paths cur_package_name then ( - Bsb_log.error "@{Cyclic dependencies in package stack@}@."; - exit 2); - let package_stacks = cur_package_name :: paths in - Bsb_log.info "@{Package stack:@} %a @." pp_packages_rev - package_stacks; - if Hash_string.mem visited cur_package_name then - Bsb_log.info "@{Visited before@} %s@." cur_package_name - else - let explore_deps (deps : string) pinned_dependencies = - map - |? ( deps, - `Arr - (fun (new_packages : Ext_json_types.t array) -> - Ext_array.iter new_packages (fun js -> - match js with - | Str { str = new_package } -> - let package_dir = - Bsb_pkg.resolve_bs_package ~cwd:dir - (Bsb_pkg_types.string_as_package new_package) - in - walk_all_deps_aux visited package_stacks - ~top:(Expect_name new_package) package_dir queue - ~pinned_dependencies - | _ -> - Bsb_exception.errorf ~loc "%s expect an array" deps)) - ) - |> ignore - in - let is_pinned = match top with - | Expect_name n when Set_string.mem pinned_dependencies n -> true - | _ -> false - in - let pinned_dependencies = match is_pinned with - | true -> - let transitive_pinned_dependencies = extract_pinned_dependencies map - in - Set_string.union transitive_pinned_dependencies pinned_dependencies - | false -> pinned_dependencies - in - explore_deps Bsb_build_schemas.bs_dependencies pinned_dependencies; - (match top with - | Expect_none -> explore_deps Bsb_build_schemas.bs_dev_dependencies pinned_dependencies - | Expect_name _ when is_pinned -> - explore_deps Bsb_build_schemas.bs_dev_dependencies pinned_dependencies - | Expect_name _ -> ()); - Queue.add { top; proj_dir = dir; is_pinned } queue; - Hash_string.add visited cur_package_name dir - | _ -> () - -let walk_all_deps dir ~pinned_dependencies : package_context Queue.t = - let visited = Hash_string.create 0 in - let cb = Queue.create () in - walk_all_deps_aux visited [] ~top:Expect_none dir cb ~pinned_dependencies; - cb diff --git a/jscomp/bsb/bsb_build_util.mli b/jscomp/bsb/bsb_build_util.mli deleted file mode 100644 index 84ba8a2..0000000 --- a/jscomp/bsb/bsb_build_util.mli +++ /dev/null @@ -1,90 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val flag_concat : string -> string list -> string -(** - Use: - {[ - flag_concat "-ppx" [ppxs] - ]} -*) - -val ppx_flags : Bsb_config_types.ppx list -> string -(** - Build quoted commandline arguments for bsc.exe for the given ppx flags - - Use: - {[ - ppx_flags [ppxs] - ]} -*) - -val pp_flag : string -> string - -val include_dirs : string list -> string -(** - Build unquoted command line arguments for bsc.exe for the given include dirs - - Use: - {[ - include_dirs [dirs] - ]} -*) - -val include_dirs_by : 'a list -> ('a -> string) -> string - -val mkp : string -> unit - -(* The path of [bsc] and [bsdep] is normalized so that the invokation of [./jscomp/bin/bsb.exe] - and [bsb.exe] (combined with a dirty bsconfig.json) will not trigger unnecessary rebuild. - - The location of [bsc] and [bsdep] is configured by the combination of [Sys.executable_name] - and [cwd]. - - In theory, we should also check the integrity of [bsb.exe], if it is changed, the rebuild - should be regen, but that is too much in practice, not only you need check the integrity of - path of [bsb.exe] but also the timestamp, to make it 100% correct, also the integrity of - [bsdep.exe] [bsc.exe] etc. -*) - -val get_list_string_acc : Ext_json_types.t array -> string list -> string list - -val get_list_string : Ext_json_types.t array -> string list - -type top = Expect_none | Expect_name of string - -type result = { path : string; checked : bool } - -(* [resolve_bsb_magic_file] - returns a tuple (path,checked) - when checked is true, it means such file should exist without depending on env -*) -val resolve_bsb_magic_file : cwd:string -> desc:string -> string -> result - -type package_context = { proj_dir : string; top : top; is_pinned: bool } - -val extract_pinned_dependencies: Ext_json_types.t Map_string.t -> Set_string.t - -val walk_all_deps : - string -> pinned_dependencies:Set_string.t -> package_context Queue.t diff --git a/jscomp/bsb/bsb_clean.ml b/jscomp/bsb/bsb_clean.ml deleted file mode 100644 index ff8ed40..0000000 --- a/jscomp/bsb/bsb_clean.ml +++ /dev/null @@ -1,62 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Ext_path.combine - -let ninja_clean proj_dir = - try - let cmd = Bsb_global_paths.vendor_ninja in - let lib_artifacts_dir = Bsb_config.lib_bs in - let cwd = proj_dir // lib_artifacts_dir in - if Sys.file_exists cwd then - let eid = - Bsb_unix.run_command_execv { cmd; args = [| cmd; "-t"; "clean" |]; cwd } - in - if eid <> 0 then Bsb_log.warn "@{Failed@}@." - with e -> Bsb_log.warn "@{Failed@}: %s @." (Printexc.to_string e) - -let clean_bs_garbage proj_dir = - Bsb_log.info "@{Cleaning:@} in %s@." proj_dir; - let try_remove x = - let x = proj_dir // x in - if Sys.file_exists x then Bsb_unix.remove_dir_recursive x - in - try - Bsb_parse_sources.clean_re_js proj_dir; - (* clean re.js files*) - ninja_clean proj_dir; - Ext_list.iter Bsb_config.all_lib_artifacts try_remove - with e -> - Bsb_log.warn "@{Failed@} to clean due to %s" (Printexc.to_string e) - -let clean_bs_deps proj_dir = - let _, _, _, pinned_dependencies = Bsb_config_parse.deps_from_bsconfig () in - let queue = Bsb_build_util.walk_all_deps proj_dir ~pinned_dependencies in - Queue.iter - (fun (pkg_cxt : Bsb_build_util.package_context) -> - (* whether top or not always do the cleaning *) - clean_bs_garbage pkg_cxt.proj_dir) - queue - -let clean_self proj_dir = clean_bs_garbage proj_dir diff --git a/jscomp/bsb/bsb_clean.mli b/jscomp/bsb/bsb_clean.mli deleted file mode 100644 index bedebe8..0000000 --- a/jscomp/bsb/bsb_clean.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** clean bsc generated artifacts. - TODO: clean stale in source js artifacts -*) - -val clean_bs_deps : string -> unit - -val clean_self : string -> unit diff --git a/jscomp/bsb/bsb_config.ml b/jscomp/bsb/bsb_config.ml deleted file mode 100644 index 3c3d7d5..0000000 --- a/jscomp/bsb/bsb_config.ml +++ /dev/null @@ -1,68 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -let ( // ) = Ext_path.combine - -let lib_lit = "lib" - -let lib_js = lib_lit // "js" - -let lib_ocaml = lib_lit // "ocaml" - -let lib_bs = lib_lit // "bs" - -let lib_es6 = lib_lit // "es6" - -let lib_es6_global = lib_lit // "es6_global" - -let all_lib_artifacts = [ lib_js; lib_ocaml; lib_bs; lib_es6; lib_es6_global ] - -let rev_lib_bs = ".." // ".." - -(* access the js directory from "lib/bs", - it would be '../js' - - TODO: should be renamed, js -> cjs, es6 -> mjs in v12 -*) -let lib_bs_prefix_of_format (x : Ext_module_system.t) = - ".." - // match x with Commonjs -> "js" | Esmodule -> "es6" | Es6_global -> "es6_global" - -(* lib/js, lib/es6, lib/es6_global *) -let top_prefix_of_format (x : Ext_module_system.t) = - match x with - | Commonjs -> lib_js - | Esmodule -> lib_es6 - | Es6_global -> lib_es6_global - -let rev_lib_bs_prefix p = rev_lib_bs // p - -let ocaml_bin_install_prefix p = lib_ocaml // p - -let proj_rel path = rev_lib_bs // path - -(** it may not be a bad idea to hard code the binary path - of bsb in configuration time -*) - -(* let cmd_package_specs = ref None *) diff --git a/jscomp/bsb/bsb_config.mli b/jscomp/bsb/bsb_config.mli deleted file mode 100644 index c5df914..0000000 --- a/jscomp/bsb/bsb_config.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val ocaml_bin_install_prefix : string -> string - -val proj_rel : string -> string - -val lib_lit : string - -val lib_js : string - -val lib_bs : string - -val lib_es6 : string -[@@ocaml.deprecated "will be removed in v12"] - -val lib_es6_global : string -[@@ocaml.deprecated "will be removed in v12"] - -val lib_ocaml : string - -val all_lib_artifacts : string list - -(* we need generate path relative to [lib/bs] directory in the opposite direction *) -val rev_lib_bs_prefix : string -> string - -val lib_bs_prefix_of_format : Ext_module_system.t -> string - -val top_prefix_of_format : Ext_module_system.t -> string -(** default not install, only when -make-world, its dependencies will be installed *) diff --git a/jscomp/bsb/bsb_config_load.ml b/jscomp/bsb/bsb_config_load.ml deleted file mode 100644 index 0255663..0000000 --- a/jscomp/bsb/bsb_config_load.ml +++ /dev/null @@ -1,24 +0,0 @@ -let ( // ) = Ext_path.combine - -let load_json ~(per_proj_dir : string) ~(warn_legacy_config : bool) - : string * Ext_json_types.t = - let filename, abs, in_chan = - let filename = Literals.rescript_json in - let abs = (per_proj_dir // filename) in - match open_in abs - with - | in_chan -> (filename, abs, in_chan) - | exception e -> - let filename = Literals.bsconfig_json in - let abs = (per_proj_dir // filename) in - match open_in abs - with - | in_chan -> (filename, abs, in_chan) - | exception _ -> raise e (* forward error from rescript.json *) - in - if warn_legacy_config && filename = Literals.bsconfig_json then - print_endline "Warning: bsconfig.json is deprecated. Migrate it to rescript.json\n"; - match Ext_json_parse.parse_json_from_chan abs in_chan - with - | v -> close_in in_chan ; (filename, v) - | exception e -> close_in in_chan ; raise e diff --git a/jscomp/bsb/bsb_config_load.mli b/jscomp/bsb/bsb_config_load.mli deleted file mode 100644 index 7e8cd97..0000000 --- a/jscomp/bsb/bsb_config_load.mli +++ /dev/null @@ -1,2 +0,0 @@ -val load_json : - per_proj_dir:string -> warn_legacy_config:bool -> string * Ext_json_types.t diff --git a/jscomp/bsb/bsb_config_parse.ml b/jscomp/bsb/bsb_config_parse.ml deleted file mode 100644 index 747a2b7..0000000 --- a/jscomp/bsb/bsb_config_parse.ml +++ /dev/null @@ -1,370 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* let get_list_string = Bsb_build_util.get_list_string *) -let ( // ) = Ext_path.combine - -let resolve_package cwd package_name = - let x = Bsb_pkg.resolve_bs_package ~cwd package_name in - { - Bsb_config_types.package_name; - package_install_path = x // Bsb_config.lib_ocaml; - } - -type json_map = Ext_json_types.t Map_string.t - -(* Key is the path *) -let ( |? ) m (key, cb) = m |> Ext_json.test key cb -let ( .?() ) = Map_string.find_opt - -(*TODO: it is a little mess that [cwd] and [project dir] are shared*) - -let extract_package_name_and_namespace (map : json_map) : string * string option - = - let package_name = - match map.?(Bsb_build_schemas.name) with - | Some (Str { str = "_" } as config) -> - Bsb_exception.config_error config "_ is a reserved package name" - | Some (Str { str = name }) -> name - | Some config -> - Bsb_exception.config_error config "name expect a string field" - | None -> Bsb_exception.invalid_spec "field name is required" - in - let namespace = - match map.?(Bsb_build_schemas.namespace) with - | None | Some (False _) -> None - | Some (True _) -> - Some (Ext_namespace.namespace_of_package_name package_name) - | Some (Str { str }) -> - (*TODO : check the validity of namespace *) - Some (Ext_namespace.namespace_of_package_name str) - | Some x -> - Bsb_exception.config_error x "namespace field expects string or boolean" - in - (package_name, namespace) - -(** - There are two things to check: - - the running bsb and vendoring bsb is the same - - the running bsb need delete stale build artifacts - (kinda check npm upgrade) - - Note if the setup is correct: - the running compiler and node_modules/rescript - should be the same version, - The exact check is that the running compiler should have a - compatible runtime version installed, the location of the - compiler is actually not relevant. - We disable the check temporarily - e.g, - ``` - bsc -runtime runtime_dir@version - ``` -*) -let check_stdlib (map : json_map) : bool = - (*built_in_package*) - match map.?(Bsb_build_schemas.use_stdlib) with - | Some (False _) -> false - | None | Some _ -> true - -let extract_gentype_config (map : json_map) : Bsb_config_types.gentype_config = - match map.?(Bsb_build_schemas.gentypeconfig) with - | None -> false - | Some (Obj _) -> true - | Some config -> - Bsb_exception.config_error config "gentypeconfig expect an object" - -let extract_uncurried (map : json_map) : bool = - match map.?(Bsb_build_schemas.uncurried) with - | None -> true - | Some (True _) -> true - | Some (False _) -> false - | Some config -> - Bsb_exception.config_error config "uncurried expects one of: true, false." - -let extract_string (map : json_map) (field : string) cb = - match map.?(field) with - | None -> None - | Some (Str { str }) -> cb str - | Some config -> Bsb_exception.config_error config (field ^ " expect a string") - -let extract_boolean (map : json_map) (field : string) (default : bool) : bool = - match map.?(field) with - | None -> default - | Some (True _) -> true - | Some (False _) -> false - | Some config -> - Bsb_exception.config_error config (field ^ " expect a boolean") - -let extract_reason_react_jsx (map : json_map) = - let default : Bsb_config_types.reason_react_jsx option ref = ref None in - map - |? ( Bsb_build_schemas.reason, - `Obj - (fun m -> - match m.?(Bsb_build_schemas.react_jsx) with - | Some (Flo { loc; flo }) -> ( - match flo with - | "3" -> default := Some Jsx_v3 - | _ -> Bsb_exception.errorf ~loc "Unsupported jsx version %s" flo - ) - | Some x -> - Bsb_exception.config_error x - "Unexpected input (expect a version number) for jsx, note \ - boolean is no longer allowed" - | None -> ()) ) - |> ignore; - !default - -let extract_warning (map : json_map) = - match map.?(Bsb_build_schemas.warnings) with - | None -> Bsb_warning.use_default - | Some (Obj { map }) -> Bsb_warning.from_map map - | Some config -> Bsb_exception.config_error config "expect an object" - -let extract_ignored_dirs (map : json_map) : Set_string.t = - match map.?(Bsb_build_schemas.ignored_dirs) with - | None -> Set_string.empty - | Some (Arr { content }) -> - Set_string.of_list (Bsb_build_util.get_list_string content) - | Some config -> Bsb_exception.config_error config "expect an array of string" - -let extract_generators (map : json_map) = - let generators = ref Map_string.empty in - (match map.?(Bsb_build_schemas.generators) with - | None -> () - | Some (Arr { content = s }) -> - generators := - Ext_array.fold_left s Map_string.empty (fun acc json -> - match json with - | Obj { map = m; loc } -> ( - match - (m.?(Bsb_build_schemas.name), m.?(Bsb_build_schemas.command)) - with - | Some (Str { str = name }), Some (Str { str = command }) -> - Map_string.add acc name command - | _, _ -> - Bsb_exception.errorf ~loc - {| generators exepect format like { "name" : "cppo", "command" : "cppo $in -o $out"} |} - ) - | _ -> acc) - | Some config -> - Bsb_exception.config_error config - (Bsb_build_schemas.generators ^ " expect an array field")); - !generators - -let extract_dependencies (map : json_map) cwd (field : string) : - Bsb_config_types.dependencies = - match map.?(field) with - | None -> [] - | Some (Arr { content = s }) -> - Ext_list.map (Bsb_build_util.get_list_string s) (fun s -> - resolve_package cwd (Bsb_pkg_types.string_as_package s)) - | Some config -> Bsb_exception.config_error config (field ^ " expect an array") - -(* return an empty array if not found *) -let extract_string_list (map : json_map) (field : string) : string list = - match map.?(field) with - | None -> [] - | Some (Arr { content = s }) -> Bsb_build_util.get_list_string s - | Some config -> Bsb_exception.config_error config (field ^ " expect an array") - -let extract_ppx (map : json_map) (field : string) ~(cwd : string) : - Bsb_config_types.ppx list = - match map.?(field) with - | None -> [] - | Some (Arr { content }) -> - let resolve s = - if s = "" then - Bsb_exception.invalid_spec "invalid ppx, empty string found" - else - (Bsb_build_util.resolve_bsb_magic_file ~cwd - ~desc:Bsb_build_schemas.ppx_flags s) - .path - in - Ext_array.to_list_f content (fun x -> - match x with - | Str x -> { Bsb_config_types.name = resolve x.str; args = [] } - | Arr { content } -> ( - let xs = Bsb_build_util.get_list_string content in - match xs with - | [] -> Bsb_exception.config_error x " empty array is not allowed" - | name :: args -> { Bsb_config_types.name = resolve name; args }) - | config -> - Bsb_exception.config_error config - (field ^ "expect each item to be either string or array")) - | Some config -> Bsb_exception.config_error config (field ^ " expect an array") - -let extract_js_post_build (map : json_map) cwd : string option = - let js_post_build_cmd = ref None in - map - |? ( Bsb_build_schemas.js_post_build, - `Obj - (fun m -> - m - |? ( Bsb_build_schemas.cmd, - `Str - (fun s -> - js_post_build_cmd := - Some - (Bsb_build_util.resolve_bsb_magic_file ~cwd - ~desc:Bsb_build_schemas.js_post_build s) - .path) ) - |> ignore) ) - |> ignore; - !js_post_build_cmd - -(** ATT: make sure such function is re-entrant. - With a given [cwd] it works anywhere*) -let interpret_json - ~(filename : string) - ~(json : Ext_json_types.t) - ~(package_kind : Bsb_package_kind.t) - ~(per_proj_dir : string) - : Bsb_config_types.t = - (* we should not resolve it too early, - since it is external configuration, no {!Bsb_build_util.convert_and_resolve_path} - *) - - (* When we plan to add more deps here, - Make sure check it is consistent that for nested deps, we have a - quck check by just re-parsing deps - Make sure it works with [-make-world] [-clean-world] - *) - - (* Setting ninja is a bit complex - 1. if [build.ninja] does use [ninja] we need set a variable - 2. we need store it so that we can call ninja correctly - *) - match json - with - | Obj { map } -> ( - let package_name, namespace = extract_package_name_and_namespace map in - let gentype_config = extract_gentype_config map in - - (* This line has to be before any calls to Bsb_global_backend.backend, because it'll read the entries - array from the bsconfig and set the backend_ref to the first entry, if any. *) - - (* The default situation is empty *) - let built_in_package : bool = check_stdlib map in - - let pp_flags : string option = - extract_string map Bsb_build_schemas.pp_flags (fun p -> - if p = "" then - Bsb_exception.invalid_spec "invalid pp, empty string found" - else - Some - (Bsb_build_util.resolve_bsb_magic_file ~cwd:per_proj_dir - ~desc:Bsb_build_schemas.pp_flags p) - .path) - in - let reason_react_jsx = extract_reason_react_jsx map in - let bs_dependencies = - extract_dependencies map per_proj_dir Bsb_build_schemas.bs_dependencies - in - let bs_dev_dependencies = - match package_kind with - | Toplevel | Pinned_dependency _ -> - extract_dependencies map per_proj_dir - Bsb_build_schemas.bs_dev_dependencies - | Dependency _ -> [] - in - let pinned_dependencies = Bsb_build_util.extract_pinned_dependencies map in - match map.?(Bsb_build_schemas.sources) with - | Some sources -> - let cut_generators = - extract_boolean map Bsb_build_schemas.cut_generators false - in - let groups = - Bsb_parse_sources.scan ~ignored_dirs:(extract_ignored_dirs map) - ~package_kind ~root:per_proj_dir ~cut_generators - (* ~namespace *) - sources - in - let bsc_flags = extract_string_list map Bsb_build_schemas.bsc_flags in - let jsx = Bsb_jsx.from_map map in - let jsx, bsc_flags = - match package_kind with - | Pinned_dependency x | Dependency x -> - if List.mem package_name x.jsx.v3_dependencies then - ( { jsx with version = Some Jsx_v3 }, - "-open ReactV3" :: bsc_flags ) - else (x.jsx, bsc_flags) - | _ -> (jsx, bsc_flags) - in - { - pinned_dependencies; - gentype_config; - package_name; - namespace; - warning = extract_warning map; - external_includes = - extract_string_list map Bsb_build_schemas.bs_external_includes; - bsc_flags; - ppx_files = - extract_ppx map ~cwd:per_proj_dir Bsb_build_schemas.ppx_flags; - pp_file = pp_flags; - bs_dependencies; - bs_dev_dependencies; - (* - reference for quoting - {[ - let tmpfile = Filename.temp_file "ocamlpp" "" in - let comm = Printf.sprintf "%s %s > %s" - pp (Filename.quote sourcefile) tmpfile - in - ]} - *) - js_post_build_cmd = extract_js_post_build map per_proj_dir; - package_specs = - (match package_kind with - | Toplevel -> Bsb_package_specs.from_map ~cwd:per_proj_dir map - | Pinned_dependency x | Dependency x -> x.package_specs); - file_groups = groups; - files_to_install = Queue.create (); - built_in_dependency = built_in_package; - reason_react_jsx; - jsx; - generators = extract_generators map; - cut_generators; - uncurried = - (match package_kind with - | Toplevel -> extract_uncurried map - | Pinned_dependency x | Dependency x -> x.uncurried); - filename; - } - | None -> - Bsb_exception.invalid_spec ("no sources specified in " ^ filename)) - | _ -> Bsb_exception.invalid_spec (filename ^ " expect a json object {}") - -let deps_from_bsconfig () = - let cwd = Bsb_global_paths.cwd in - match Bsb_config_load.load_json ~per_proj_dir:cwd ~warn_legacy_config:false - with - | _, Obj { map } -> - ( Bsb_package_specs.from_map ~cwd map, - Bsb_jsx.from_map map, - extract_uncurried map, - Bsb_build_util.extract_pinned_dependencies map ) - | _, _ -> assert false diff --git a/jscomp/bsb/bsb_config_parse.mli b/jscomp/bsb/bsb_config_parse.mli deleted file mode 100644 index 3aedf98..0000000 --- a/jscomp/bsb/bsb_config_parse.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val deps_from_bsconfig : unit -> Bsb_package_specs.t * Bsb_jsx.t * bool * Set_string.t - -val interpret_json : - filename:string -> - json:Ext_json_types.t -> - package_kind:Bsb_package_kind.t -> - per_proj_dir:string -> - Bsb_config_types.t diff --git a/jscomp/bsb/bsb_config_types.ml b/jscomp/bsb/bsb_config_types.ml deleted file mode 100644 index db5c007..0000000 --- a/jscomp/bsb/bsb_config_types.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type dependency = { - package_name : Bsb_pkg_types.t; - package_install_path : string; -} - -type dependencies = dependency list -type reason_react_jsx = Jsx_v3 -(* string option *) - -type gentype_config = bool -type command = string -type ppx = { name : string; args : string list } - -type t = { - package_name : string; - (* [captial-package] *) - namespace : string option; - (* CapitalPackage *) - external_includes : string list; - bsc_flags : string list; - ppx_files : ppx list; - pp_file : string option; - bs_dependencies : dependencies; - bs_dev_dependencies : dependencies; - pinned_dependencies : Set_string.t; - built_in_dependency : bool; - warning : Bsb_warning.t; - (*TODO: maybe we should always resolve rescript - so that we can calculate correct relative path in - [.merlin] - *) - js_post_build_cmd : string option; - package_specs : Bsb_package_specs.t; - file_groups : Bsb_file_groups.t; - files_to_install : Bsb_db.module_info Queue.t; - reason_react_jsx : reason_react_jsx option; - jsx: Bsb_jsx.t; - (* whether apply PPX transform or not*) - generators : command Map_string.t; - cut_generators : bool; - (* note when used as a dev mode, we will always ignore it *) - gentype_config : gentype_config; - uncurried: bool; - - filename: string; -} diff --git a/jscomp/bsb/bsb_db_encode.ml b/jscomp/bsb/bsb_db_encode.ml deleted file mode 100644 index 50d00e5..0000000 --- a/jscomp/bsb/bsb_db_encode.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* Copyright (C) 2019 - Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let bsbuild_cache = Literals.bsbuild_cache - -let nl buf = Ext_buffer.add_char buf '\n' - -(* IDEAS: - Pros: - - could be even shortened to a single byte - Cons: - - decode would allocate - - code too verbose - - not readable -*) - -let make_encoding length buf : Ext_buffer.t -> int -> unit = - let max_range = (length lsl 1) + 1 in - if max_range <= 0xff then ( - Ext_buffer.add_char buf '1'; - Ext_buffer.add_int_1) - else if max_range <= 0xff_ff then ( - Ext_buffer.add_char buf '2'; - Ext_buffer.add_int_2) - else if length <= 0x7f_ff_ff then ( - Ext_buffer.add_char buf '3'; - Ext_buffer.add_int_3) - else if length <= 0x7f_ff_ff_ff then ( - Ext_buffer.add_char buf '4'; - Ext_buffer.add_int_4) - else assert false - -(* Make sure [tmp_buf1] and [tmp_buf2] is cleared , - they are only used to control the order. - Strictly speaking, [tmp_buf1] is not needed -*) -let encode_single (db : Bsb_db.map) (buf : Ext_buffer.t) = - (* module name section *) - let len = Map_string.cardinal db in - Ext_buffer.add_string_char buf (string_of_int len) '\n'; - if len <> 0 then ( - let mapping = Hash_string.create 50 in - Map_string.iter db (fun name { dir } -> - Ext_buffer.add_string_char buf name '\n'; - if not (Hash_string.mem mapping dir) then - Hash_string.add mapping dir (Hash_string.length mapping)); - let length = Hash_string.length mapping in - let rev_mapping = Array.make length "" in - Hash_string.iter mapping (fun k i -> Array.unsafe_set rev_mapping i k); - (* directory name section *) - Ext_array.iter rev_mapping (fun s -> Ext_buffer.add_string_char buf s '\t'); - nl buf; - (* module name info section *) - let len_encoding = make_encoding length buf in - Map_string.iter db (fun _ module_info -> - len_encoding buf - ((Hash_string.find_exn mapping module_info.dir lsl 1) - + (Obj.magic (module_info.case : bool) : int))); - nl buf) - -let encode (dbs : Bsb_db.t) buf = - encode_single dbs.lib buf; - encode_single dbs.dev buf - -(* shall we avoid writing such file (checking the digest)? - It is expensive to start scanning the whole code base, - we should we avoid it in the first place, if we do start scanning, - this operation seems affordable -*) -let write_build_cache ~dir (bs_files : Bsb_db.t) : string = - let oc = open_out_bin (Filename.concat dir bsbuild_cache) in - let buf = Ext_buffer.create 100_000 in - encode bs_files buf; - Ext_buffer.output_buffer oc buf; - close_out oc; - let digest = Ext_buffer.digest buf in - Digest.to_hex digest diff --git a/jscomp/bsb/bsb_db_encode.mli b/jscomp/bsb/bsb_db_encode.mli deleted file mode 100644 index e769883..0000000 --- a/jscomp/bsb/bsb_db_encode.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2019 - Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val encode : Bsb_db.t -> Ext_buffer.t -> unit - -val write_build_cache : dir:string -> Bsb_db.t -> string diff --git a/jscomp/bsb/bsb_db_util.ml b/jscomp/bsb/bsb_db_util.ml deleted file mode 100644 index 8b2d0d9..0000000 --- a/jscomp/bsb/bsb_db_util.ml +++ /dev/null @@ -1,109 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type module_info = Bsb_db.module_info - -type t = Bsb_db.map - -let conflict_module_info modname (a : module_info) (b : module_info) = - Bsb_exception.conflict_module modname a.dir b.dir - -(* merge data info from two directories*) -let merge (acc : t) (sources : t) : t = - Map_string.disjoint_merge_exn acc sources conflict_module_info - -let sanity_check (map : t) = - Map_string.iter map (fun m module_info -> - if module_info.info = Intf then Bsb_exception.no_implementation m) - -(* invariant check: - ml and mli should have the same case, same path -*) -let check (x : module_info) name_sans_extension case syntax_kind - (module_info : Bsb_db.info) = - let x_ml_info = x.info in - if - x.name_sans_extension <> name_sans_extension - || x.case <> case - || x.syntax_kind <> syntax_kind - || x_ml_info = module_info || x_ml_info = Impl_intf - then - Bsb_exception.invalid_spec - (Printf.sprintf - "implementation and interface have different path names or different \ - cases %s vs %s" - x.name_sans_extension name_sans_extension); - x.info <- Impl_intf; - x - -let warning_unused_file : _ format = - "@{IGNORED@}: file %s under %s is ignored because it can't be \ - turned into a valid module name. \n\ - The build system transforms a file name into a module name by upper-casing \ - the first letter@." -(* TODO: add a link for more explanations *) - -let is_editor_temporary_files basename = Ext_string.starts_with basename ".#" - -(* - Example: .#hi.ml - Note for other files like ~, .swp - it does not pass the suffix rules -*) -let add_basename ~(dir : string) (map : t) ?error_on_invalid_suffix basename : t - = - if is_editor_temporary_files basename then map - else - let info = ref Bsb_db.Impl in - let syntax_kind = ref Bsb_db.Ml in - let invalid_suffix = ref false in - let file_suffix = Ext_filename.get_extension_maybe basename in - (match () with - | _ when file_suffix = Literals.suffix_ml -> () - | _ when file_suffix = Literals.suffix_res -> syntax_kind := Res - | _ when file_suffix = Literals.suffix_mli -> info := Intf - | _ when file_suffix = Literals.suffix_resi -> - info := Intf; - syntax_kind := Res - | _ -> invalid_suffix := true); - let info = !info in - let syntax_kind = !syntax_kind in - let invalid_suffix = !invalid_suffix in - if invalid_suffix then - match error_on_invalid_suffix with - | None -> map - | Some loc -> Bsb_exception.errorf ~loc "invalid suffix %s" basename - else - match Ext_filename.as_module ~basename:(Filename.basename basename) with - | None -> - Bsb_log.warn warning_unused_file basename dir; - map - | Some { module_name; case } -> - let name_sans_extension = - Filename.concat dir (Ext_filename.chop_extension_maybe basename) - in - let dir = Filename.dirname name_sans_extension in - Map_string.adjust map module_name (fun opt_module_info -> - match opt_module_info with - | None -> { dir; name_sans_extension; info; syntax_kind; case } - | Some x -> check x name_sans_extension case syntax_kind info) diff --git a/jscomp/bsb/bsb_db_util.mli b/jscomp/bsb/bsb_db_util.mli deleted file mode 100644 index d4ddf79..0000000 --- a/jscomp/bsb/bsb_db_util.mli +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val conflict_module_info : - string -> Bsb_db.module_info -> Bsb_db.module_info -> exn - -val merge : Bsb_db.map -> Bsb_db.map -> Bsb_db.map - -val sanity_check : Bsb_db.map -> unit - -(** - Currently it is okay to have duplicated module, - In the future, we may emit a warning -*) - -val add_basename : - dir:string -> - Bsb_db.map -> - ?error_on_invalid_suffix:Ext_position.t -> - string -> - Bsb_db.map diff --git a/jscomp/bsb/bsb_exception.ml b/jscomp/bsb/bsb_exception.ml deleted file mode 100644 index 007221c..0000000 --- a/jscomp/bsb/bsb_exception.ml +++ /dev/null @@ -1,104 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error = - | Package_not_found of Bsb_pkg_types.t * string option (* json file *) - | Json_config of Ext_position.t * string - | Invalid_json of string - | Invalid_spec of string - | Conflict_module of string * string * string - | No_implementation of string - | Not_consistent of string - -exception Error of error - -let error err = raise (Error err) - -let package_not_found ~pkg ~json = error (Package_not_found (pkg, json)) - -let print (fmt : Format.formatter) (x : error) = - match x with - | Conflict_module (modname, dir1, dir2) -> - Format.fprintf fmt - "@{Error:@} %s found in two directories: (%s, %s)\n\ - File names must be unique per project" modname dir1 dir2 - | Not_consistent modname -> - Format.fprintf fmt - "@{Error:@} %s has implementation/interface in non-consistent \ - syntax(reason/ocaml)" - modname - | No_implementation modname -> - Format.fprintf fmt - "@{Error:@} %s does not have implementation file" modname - | Package_not_found (name, json_opt) -> - let in_json = - match json_opt with None -> Ext_string.empty | Some x -> " in " ^ x - in - let name = Bsb_pkg_types.to_string name in - if Ext_string.equal name !Bs_version.package_name then - Format.fprintf fmt - "File \"bsconfig.json\", line 1\n\ - @{Error:@} package @{%s@} is not found %s\n\ - It's the basic, required package. If you have it installed globally,\n\ - Please run `npm link rescript` to make it available" name in_json - else - Format.fprintf fmt - "File \"bsconfig.json\", line 1\n\ - @{Error:@} package @{%s@} not found or built %s\n\ - - Did you install it?" name in_json - | Json_config (pos, s) -> - Format.fprintf fmt - "File %S, line %d:\n\ - @{Error:@} %s \n\ - For more details, please check out the schema at \ - https://rescript-lang.org/docs/manual/latest/build-configuration-schema" - pos.pos_fname pos.pos_lnum s - | Invalid_spec s -> - Format.fprintf fmt "@{Error: Invalid bsconfig.json %s@}" s - | Invalid_json s -> - Format.fprintf fmt - "File %S, line 1\n@{Error: Invalid json format@}" s - -let conflict_module modname dir1 dir2 = - Error (Conflict_module (modname, dir1, dir2)) - -let no_implementation modname = error (No_implementation modname) - -let not_consistent modname = error (Not_consistent modname) - -let errorf ~loc fmt = - Format.ksprintf (fun s -> error (Json_config (loc, s))) fmt - -let config_error config fmt = - let loc = Ext_json.loc_of config in - - error (Json_config (loc, fmt)) - -let invalid_spec s = error (Invalid_spec s) - -let invalid_json s = error (Invalid_json s) - -let () = - Printexc.register_printer (fun x -> - match x with Error x -> Some (Format.asprintf "%a" print x) | _ -> None) diff --git a/jscomp/bsb/bsb_exception.mli b/jscomp/bsb/bsb_exception.mli deleted file mode 100644 index 9f40866..0000000 --- a/jscomp/bsb/bsb_exception.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error -(** - This module is used for fatal errros -*) - -exception Error of error - -val print : Format.formatter -> error -> unit - -val package_not_found : pkg:Bsb_pkg_types.t -> json:string option -> 'a - -val conflict_module : string -> string -> string -> exn - -val errorf : loc:Ext_position.t -> ('a, unit, string, 'b) format4 -> 'a - -val config_error : Ext_json_types.t -> string -> 'a - -val invalid_spec : string -> 'a - -val invalid_json : string -> 'a - -val no_implementation : string -> 'a - -val not_consistent : string -> 'a diff --git a/jscomp/bsb/bsb_file.ml b/jscomp/bsb/bsb_file.ml deleted file mode 100644 index ebc696c..0000000 --- a/jscomp/bsb/bsb_file.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** it is not necessary to call [chown] since it is within the same user - and {!Unix.chown} is not implemented under Windows -*) -let set_infos filename (infos : Unix.stats) = - Unix.utimes filename infos.st_atime infos.st_mtime; - Unix.chmod filename infos.st_perm - -(* - try - Unix.chown filename infos.st_uid infos.st_gid - with Unix_error(EPERM,_,_) -> () -*) - -let buffer_size = 8192 - -let buffer = Bytes.create buffer_size - -let file_copy input_name output_name = - let fd_in = Unix.openfile input_name [ O_RDONLY ] 0 in - let fd_out = Unix.openfile output_name [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in - let rec copy_loop () = - match Unix.read fd_in buffer 0 buffer_size with - | 0 -> () - | r -> - ignore (Unix.write fd_out buffer 0 r); - copy_loop () - in - copy_loop (); - Unix.close fd_in; - Unix.close fd_out - -let copy_with_permission input_name output_name = - file_copy input_name output_name; - set_infos output_name (Unix.lstat input_name) - -let install_if_exists ~destdir input_name = - if Sys.file_exists input_name then ( - let output_name = Filename.concat destdir (Filename.basename input_name) in - match (Unix.stat output_name, Unix.stat input_name) with - | { st_mtime = output_stamp; _ }, { st_mtime = input_stamp; _ } - when input_stamp <= output_stamp -> - false - | _ -> - copy_with_permission input_name output_name; - true - | exception _ -> - copy_with_permission input_name output_name; - true) - else false diff --git a/jscomp/bsb/bsb_file.mli b/jscomp/bsb/bsb_file.mli deleted file mode 100644 index 3bd2113..0000000 --- a/jscomp/bsb/bsb_file.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val install_if_exists : destdir:string -> string -> bool -(** return [true] if copied *) diff --git a/jscomp/bsb/bsb_file_groups.ml b/jscomp/bsb/bsb_file_groups.ml deleted file mode 100644 index dac20e0..0000000 --- a/jscomp/bsb/bsb_file_groups.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type public = Export_none | Export_all | Export_set of Set_string.t - -type build_generator = { - input : string list; - output : string list; - command : string; -} - -type file_group = { - dir : string; - sources : Bsb_db.map; - resources : string list; - public : public; - is_dev : bool; - generators : build_generator list; - (* output of [generators] should be added to [sources], - if it is [.ml,.mli,.res,.resi] - *) -} - -type file_groups = file_group list - -type t = { files : file_groups; globbed_dirs : string list } - -let empty : t = { files = []; globbed_dirs = [] } - -let merge (u : t) (v : t) = - if u == empty then v - else if v == empty then u - else - { - files = Ext_list.append u.files v.files; - globbed_dirs = Ext_list.append u.globbed_dirs v.globbed_dirs; - } - -let cons ~file_group ?globbed_dir (v : t) : t = - { - files = file_group :: v.files; - globbed_dirs = - (match globbed_dir with - | None -> v.globbed_dirs - | Some f -> f :: v.globbed_dirs); - } - -(** when [is_empty file_group] - we don't need issue [-I] [-S] in [.merlin] file -*) -let is_empty (x : file_group) = - Map_string.is_empty x.sources && x.resources = [] && x.generators = [] diff --git a/jscomp/bsb/bsb_file_groups.mli b/jscomp/bsb/bsb_file_groups.mli deleted file mode 100644 index 6abc224..0000000 --- a/jscomp/bsb/bsb_file_groups.mli +++ /dev/null @@ -1,56 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type public = Export_none | Export_all | Export_set of Set_string.t - -type build_generator = { - input : string list; - output : string list; - command : string; -} - -type file_group = { - dir : string; - sources : Bsb_db.map; - resources : string list; - public : public; - is_dev : bool; - (* false means not in dev mode *) - generators : build_generator list; - (* output of [generators] should be added to [sources], - if it is [.ml,.mli,.res,.resi] - *) -} - -type file_groups = file_group list - -type t = private { files : file_groups; globbed_dirs : string list } - -val empty : t - -val merge : t -> t -> t - -val cons : file_group:file_group -> ?globbed_dir:string -> t -> t - -val is_empty : file_group -> bool diff --git a/jscomp/bsb/bsb_global_paths.ml b/jscomp/bsb/bsb_global_paths.ml deleted file mode 100644 index 97ccc5f..0000000 --- a/jscomp/bsb/bsb_global_paths.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* Copyright (C) 2019 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let cwd = Sys.getcwd () - -(** - If [Sys.executable_name] gives an absolute path, - nothing needs to be done. - - If [Sys.executable_name] is not an absolute path, for example - (rlwrap ./ocaml) - it is a relative path, - it needs be adapted based on cwd - - if [Sys.executable_name] gives an absolute path, - nothing needs to be done - if it is a relative path - - there are two cases: - - bsb.exe - - ./bsb.exe - The first should also not be touched - Only the latter need be adapted based on project root -*) - -let bsc_dir = - Filename.dirname - (Ext_path.normalize_absolute_path - (Ext_path.combine cwd Sys.executable_name)) - -let vendor_bsc = Filename.concat bsc_dir "bsc.exe" - -let vendor_ninja = Filename.concat bsc_dir "ninja.exe" - -let vendor_bsdep = Filename.concat bsc_dir "bsb_helper.exe";; - -assert (Sys.file_exists bsc_dir) diff --git a/jscomp/bsb/bsb_global_paths.mli b/jscomp/bsb/bsb_global_paths.mli deleted file mode 100644 index 85dda4d..0000000 --- a/jscomp/bsb/bsb_global_paths.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2019 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val cwd : string - -val bsc_dir : string - -val vendor_bsc : string - -val vendor_ninja : string - -val vendor_bsdep : string diff --git a/jscomp/bsb/bsb_jsx.ml b/jscomp/bsb/bsb_jsx.ml deleted file mode 100644 index b9fbd08..0000000 --- a/jscomp/bsb/bsb_jsx.ml +++ /dev/null @@ -1,95 +0,0 @@ -type version = Jsx_v3 | Jsx_v4 -type module_ = React | Generic of {moduleName: string} -type mode = Classic | Automatic -type dependencies = string list - -type t = { - version : version option; - module_ : module_ option; - mode : mode option; - v3_dependencies : dependencies; -} - -let encode_no_nl jsx = - (match jsx.version with - | None -> "" - | Some Jsx_v3 -> "3" - | Some Jsx_v4 -> "4") - ^ (match jsx.module_ with None -> "" | Some React -> "React" | Some Generic {moduleName} -> moduleName) - ^ - match jsx.mode with - | None -> "" - | Some Classic -> "Classic" - | Some Automatic -> "Automatic" - -let ( .?() ) = Map_string.find_opt -let ( |? ) m (key, cb) = m |> Ext_json.test key cb - -let get_list_string_acc (s : Ext_json_types.t array) acc = - Ext_array.to_list_map_acc s acc (fun x -> - match x with Str x -> Some x.str | _ -> None) - -let get_list_string s = get_list_string_acc s [] - -let from_map map = - let version : version option ref = ref None in - let module_ : module_ option ref = ref None in - let mode : mode option ref = ref None in - let v3_dependencies : dependencies ref = ref [] in - map - |? ( Bsb_build_schemas.jsx, - `Obj - (fun m -> - match m.?(Bsb_build_schemas.jsx_version) with - | Some (Flo { loc; flo }) -> ( - match flo with - | "3" -> version := Some Jsx_v3 - | "4" -> version := Some Jsx_v4 - | _ -> Bsb_exception.errorf ~loc "Unsupported jsx version %s" flo - ) - | Some x -> - Bsb_exception.config_error x - "Unexpected input (expect a version number) for jsx version" - | None -> ()) ) - |? ( Bsb_build_schemas.jsx, - `Obj - (fun m -> - match m.?(Bsb_build_schemas.jsx_module) with - | Some (Str { str }) -> ( - match str with - | "react" -> module_ := Some React - | moduleName -> module_ := Some (Generic {moduleName})) - | Some x -> - Bsb_exception.config_error x - "Unexpected input (jsx module name) for jsx module" - | None -> ()) ) - |? ( Bsb_build_schemas.jsx, - `Obj - (fun m -> - match m.?(Bsb_build_schemas.jsx_mode) with - | Some (Str { loc; str }) -> ( - match str with - | "classic" -> mode := Some Classic - | "automatic" -> mode := Some Automatic - | _ -> Bsb_exception.errorf ~loc "Unsupported jsx mode %s" str) - | Some x -> - Bsb_exception.config_error x - "Unexpected input (expect classic or automatic) for jsx mode" - | None -> ()) ) - |? ( Bsb_build_schemas.jsx, - `Obj - (fun m -> - match m.?(Bsb_build_schemas.jsx_v3_dependencies) with - | Some (Arr { content }) -> - v3_dependencies := get_list_string content - | Some x -> - Bsb_exception.config_error x - "Unexpected input for jsx v3-dependencies" - | None -> ()) ) - |> ignore; - { - version = !version; - module_ = !module_; - mode = !mode; - v3_dependencies = !v3_dependencies; - } diff --git a/jscomp/bsb/bsb_log.ml b/jscomp/bsb/bsb_log.ml deleted file mode 100644 index 06401aa..0000000 --- a/jscomp/bsb/bsb_log.ml +++ /dev/null @@ -1,94 +0,0 @@ -(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ninja_ansi_forced = - lazy (try Sys.getenv "NINJA_ANSI_FORCED" with Not_found -> "") - -let color_enabled = lazy (Unix.isatty Unix.stdout) - -(* same logic as [ninja.exe] *) -let get_color_enabled () = - let colorful = - match ninja_ansi_forced with - | (lazy "1") -> true - | (lazy ("0" | "false")) -> false - | _ -> Lazy.force color_enabled - in - colorful - -let color_functions : Format.formatter_stag_functions = - { - mark_open_stag = - (fun s -> - if get_color_enabled () then Ext_color.ansi_of_tag s - else Ext_string.empty); - mark_close_stag = - (fun _ -> - if get_color_enabled () then Ext_color.reset_lit else Ext_string.empty); - print_open_stag = (fun _ -> ()); - print_close_stag = (fun _ -> ()); - } - -(* let set_color ppf = - Format.pp_set_formatter_tag_functions ppf color_functions *) - -let setup () = - Format.pp_set_mark_tags Format.std_formatter true; - Format.pp_set_mark_tags Format.err_formatter true; - Format.pp_set_formatter_stag_functions Format.std_formatter color_functions; - Format.pp_set_formatter_stag_functions Format.err_formatter color_functions - -type level = Debug | Info | Warn | Error - -let int_of_level (x : level) = - match x with Debug -> 0 | Info -> 1 | Warn -> 2 | Error -> 3 - -let log_level = ref Warn - -let verbose () = log_level := Debug - -let dfprintf level fmt = - if int_of_level level >= int_of_level !log_level then Format.fprintf fmt - else Format.ifprintf fmt - -type 'a fmt = Format.formatter -> ('a, Format.formatter, unit) format -> 'a - -type 'a log = ('a, Format.formatter, unit) format -> 'a - -let debug fmt = dfprintf Debug Format.std_formatter fmt - -let info fmt = dfprintf Info Format.std_formatter fmt - -let warn fmt = dfprintf Warn Format.err_formatter fmt - -let error fmt = dfprintf Error Format.err_formatter fmt - -let info_args (args : string array) = - if int_of_level Info >= int_of_level !log_level then ( - for i = 0 to Array.length args - 1 do - Format.pp_print_string Format.std_formatter (Array.unsafe_get args i); - Format.pp_print_string Format.std_formatter Ext_string.single_space - done; - Format.pp_print_newline Format.std_formatter ()) - else () diff --git a/jscomp/bsb/bsb_log.mli b/jscomp/bsb/bsb_log.mli deleted file mode 100644 index de1f1d6..0000000 --- a/jscomp/bsb/bsb_log.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val setup : unit -> unit - -type level = Debug | Info | Warn | Error - -val log_level : level ref - -type 'a fmt = Format.formatter -> ('a, Format.formatter, unit) format -> 'a - -type 'a log = ('a, Format.formatter, unit) format -> 'a - -val verbose : unit -> unit - -val debug : 'a log - -val info : 'a log - -val warn : 'a log - -val error : 'a log - -val info_args : string array -> unit diff --git a/jscomp/bsb/bsb_namespace_map_gen.ml b/jscomp/bsb/bsb_namespace_map_gen.ml deleted file mode 100644 index 5a9b5b4..0000000 --- a/jscomp/bsb/bsb_namespace_map_gen.ml +++ /dev/null @@ -1,57 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Ext_path.combine - -let write_file fname digest contents = - let oc = open_out_bin fname in - Digest.output oc digest; - output_char oc '\n'; - Ext_buffer.output_buffer oc contents; - close_out oc - -(* - TODO: - sort filegroupts to ensure deterministic behavior - - if [.bsbuild] is not changed - [.mlmap] does not need to be changed too - -*) -let output ~dir (namespace : string) (file_groups : Bsb_file_groups.file_groups) - = - let fname = namespace ^ Literals.suffix_mlmap in - let buf = Ext_buffer.create 10000 in - Ext_list.iter file_groups (fun x -> - Map_string.iter x.sources (fun k _ -> - Ext_buffer.add_string_char buf k '\n')); - (* let contents = Buffer.contents buf in *) - let digest = Ext_buffer.digest buf in - let fname = dir // fname in - if Sys.file_exists fname then ( - let ic = open_in_bin fname in - let old_digest = really_input_string ic Ext_digest.length in - close_in ic; - if old_digest <> digest then write_file fname digest buf) - else write_file fname digest buf diff --git a/jscomp/bsb/bsb_namespace_map_gen.mli b/jscomp/bsb/bsb_namespace_map_gen.mli deleted file mode 100644 index 6090fd8..0000000 --- a/jscomp/bsb/bsb_namespace_map_gen.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val output : dir:string -> string -> Bsb_file_groups.file_groups -> unit -(** [output dir namespace file_groups] - when [build.ninja] is generated, we output a module map [.mlmap] file - such [.mlmap] file will be consumed by [bsc.exe] to generate [.cmi] file -*) diff --git a/jscomp/bsb/bsb_ninja_check.ml b/jscomp/bsb/bsb_ninja_check.ml deleted file mode 100644 index b11bf66..0000000 --- a/jscomp/bsb/bsb_ninja_check.ml +++ /dev/null @@ -1,149 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -(* float_of_string_opt *) -external hexstring_of_float : float -> int -> char -> string - = "caml_hexstring_of_float" - -let hex_of_float f = hexstring_of_float f (-1) '-' - -(* This should not lose any preicision *) -(* let id (f : float) = - float_of_string (hex_of_float f) = f -*) - -type check_result = - | Good - | Bsb_file_corrupted - | Bsb_file_not_exist (** We assume that it is a clean repo *) - | Bsb_source_directory_changed - | Bsb_bsc_version_mismatch - | Bsb_forced - | Bsb_package_kind_inconsistent - | Bsb_regenerate_required - | Other of string - -let pp_check_result fmt (check_resoult : check_result) = - Format.pp_print_string fmt - (match check_resoult with - | Good -> "OK" - | Bsb_file_corrupted -> "Stored data corrupted" - | Bsb_file_not_exist -> "Dependencies information missing" - | Bsb_source_directory_changed -> "Bsb source directory changed" - | Bsb_bsc_version_mismatch -> "Bsc or bsb version mismatch" - | Bsb_forced -> "Bsb forced rebuild" - | Bsb_package_kind_inconsistent -> "The package was built in different mode" - | Bsb_regenerate_required -> "Bsb need regenerate build.ninja" - | Other s -> s) - -let rec check_aux cwd (xs : string list) = - match xs with - | [] -> Good - | "===" :: rest -> check_global_atime rest - | item :: rest -> ( - match Ext_string.split item '\t' with - | [ file; stamp ] -> - let stamp = float_of_string stamp in - let cur_file = Filename.concat cwd file in - let stat = Unix.stat cur_file in - if stat.st_mtime <= stamp then check_aux cwd rest else Other cur_file - | _ -> Bsb_file_corrupted) - -and check_global_atime rest = - match rest with - | [] -> Good - | item :: rest -> ( - match Ext_string.split item '\t' with - | [ file; stamp ] -> - let stamp = float_of_string stamp in - let cur_file = file in - let stat = Unix.stat cur_file in - if stat.st_atime <= stamp then check_global_atime rest - else Other cur_file - | _ -> Bsb_file_corrupted) - -(* TODO: for such small data structure, maybe text format is better *) - -let record_global_atime buf name = - let stamp = (Unix.stat name).st_atime in - Ext_buffer.add_string_char buf name '\t'; - Ext_buffer.add_string_char buf (hex_of_float stamp) '\n' - -let record ~(package_kind : Bsb_package_kind.t) ~per_proj_dir ~file - ~(config : Bsb_config_types.t) ~(warn_as_error: string option) (file_or_dirs : string list) : unit = - let buf = Ext_buffer.create 1_000 in - Ext_buffer.add_string_char buf Bs_version.version '\n'; - Ext_buffer.add_string_char buf per_proj_dir '\n'; - Ext_buffer.add_string_char buf - (Bsb_package_kind.encode_no_nl package_kind) - '\n'; - Ext_buffer.add_string_char buf (match warn_as_error with | Some s -> s | None -> "0") '\n'; - Ext_list.iter file_or_dirs (fun f -> - Ext_buffer.add_string_char buf f '\t'; - Ext_buffer.add_string_char buf - (hex_of_float (Unix.stat (Filename.concat per_proj_dir f)).st_mtime) - '\n'); - Ext_buffer.add_string buf "===\n"; - record_global_atime buf Sys.executable_name; - Ext_list.iter config.ppx_files (fun { name; args = _ } -> - try record_global_atime buf name - with _ -> (* record the ppx files as a best effort *) - ()); - let oc = open_out_bin file in - Ext_buffer.output_buffer oc buf; - close_out oc - -(** check time stamp for all files - TODO: those checks system call can be saved later - Return a reason - Even forced, we still need walk through a little - bit in case we found a different version of compiler -*) -let check ~(package_kind : Bsb_package_kind.t) ~(per_proj_dir : string) ~forced ~(warn_as_error: string option) ~file : check_result = - match open_in_bin file with - (* Windows binary mode*) - | exception _ -> Bsb_file_not_exist - | ic -> ( - match List.rev (Ext_io.rev_lines_of_chann ic) with - | exception _ -> Bsb_file_corrupted - | version :: source_directory :: package_kind_str :: previous_warn_as_error :: dir_or_files -> ( - let warn_as_error_changed = match warn_as_error with - | None -> previous_warn_as_error <> "0" - | Some current -> current <> previous_warn_as_error in - - if version <> Bs_version.version then Bsb_bsc_version_mismatch - else if per_proj_dir <> source_directory then - Bsb_source_directory_changed - else if forced then Bsb_forced (* No need walk through *) - else if Bsb_package_kind.encode_no_nl package_kind <> package_kind_str - then Bsb_package_kind_inconsistent - else if warn_as_error_changed then Bsb_regenerate_required - else - try check_aux per_proj_dir dir_or_files - with e -> - Bsb_log.info "@{Stat miss %s@}@." (Printexc.to_string e); - Bsb_file_not_exist) - | _ -> Bsb_file_corrupted) diff --git a/jscomp/bsb/bsb_ninja_check.mli b/jscomp/bsb/bsb_ninja_check.mli deleted file mode 100644 index adff881..0000000 --- a/jscomp/bsb/bsb_ninja_check.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - This module is used to check whether [build.ninja] needs - be regenerated. Everytime [bsb] run [regenerate_ninja], - bsb will try to [check] if it is needed, - if needed, bsb will regenerate ninja file and store the - metadata again -*) - -type check_result = - | Good - | Bsb_file_corrupted - | Bsb_file_not_exist (** We assume that it is a clean repo *) - | Bsb_source_directory_changed - | Bsb_bsc_version_mismatch - | Bsb_forced - | Bsb_package_kind_inconsistent - | Bsb_regenerate_required - | Other of string - -val pp_check_result : Format.formatter -> check_result -> unit - -val record : - package_kind:Bsb_package_kind.t -> - per_proj_dir:string -> - file:string -> - config:Bsb_config_types.t -> - warn_as_error:string option -> - string list -> - unit -(** [record cwd file relevant_file_or_dirs] - The data structure we decided to whether regenerate [build.ninja] - or not. - Note that if we don't record absolute path, ninja will not notice its build spec changed, - it will not trigger rebuild behavior, - It may not be desired behavior, since there is some subtlies here (__FILE__ or __dirname) - - We serialize such data structure and call {!check} to decide - [build.ninja] should be regenerated -*) - -val check : - package_kind:Bsb_package_kind.t -> - per_proj_dir:string -> - forced:bool -> - warn_as_error: string option -> - file:string -> - check_result -(** check if [build.ninja] should be regenerated *) diff --git a/jscomp/bsb/bsb_ninja_file_groups.ml b/jscomp/bsb/bsb_ninja_file_groups.ml deleted file mode 100644 index e490cdf..0000000 --- a/jscomp/bsb/bsb_ninja_file_groups.ml +++ /dev/null @@ -1,127 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Ext_path.combine - -let handle_generators oc (group : Bsb_file_groups.file_group) custom_rules = - let map_to_source_dir x = Bsb_config.proj_rel (group.dir // x) in - Ext_list.iter group.generators (fun { output; input; command } -> - (*TODO: add a loc for better error message *) - match Map_string.find_opt custom_rules command with - | None -> - Ext_fmt.failwithf ~loc:__LOC__ "custom rule %s used but not defined" - command - | Some rule -> - Bsb_ninja_targets.output_build oc - ~outputs:(Ext_list.map output map_to_source_dir) - ~inputs:(Ext_list.map input map_to_source_dir) - ~rule) - -type suffixes = { impl : string; intf : string } - -let ml_suffixes = { impl = Literals.suffix_ml; intf = Literals.suffix_mli } - -let res_suffixes = { impl = Literals.suffix_res; intf = Literals.suffix_resi } - -let emit_module_build (rules : Bsb_ninja_rule.builtin) - (package_specs : Bsb_package_specs.t) (is_dev : bool) oc namespace - (module_info : Bsb_db.module_info) : unit = - let has_intf_file = module_info.info = Impl_intf in - let config, ast_rule = - match module_info.syntax_kind with - | Ml -> (ml_suffixes, rules.build_ast) - | Res -> (res_suffixes, rules.build_ast_from_re) - (* FIXME: better names *) - in - let filename_sans_extension = module_info.name_sans_extension in - let input_impl = - Bsb_config.proj_rel (filename_sans_extension ^ config.impl) - in - let input_intf = - Bsb_config.proj_rel (filename_sans_extension ^ config.intf) - in - let output_ast = filename_sans_extension ^ Literals.suffix_ast in - let output_iast = filename_sans_extension ^ Literals.suffix_iast in - let output_d = filename_sans_extension ^ Literals.suffix_d in - let output_filename_sans_extension = - Ext_namespace_encode.make ?ns:namespace filename_sans_extension - in - let output_cmi = output_filename_sans_extension ^ Literals.suffix_cmi in - let output_cmj = output_filename_sans_extension ^ Literals.suffix_cmj in - let output_js = - Bsb_package_specs.get_list_of_output_js package_specs - output_filename_sans_extension - in - - Bsb_ninja_targets.output_build oc ~outputs:[ output_ast ] - ~inputs:[ input_impl ] ~rule:ast_rule; - Bsb_ninja_targets.output_build oc ~outputs:[ output_d ] - ~inputs: - (if has_intf_file then [ output_ast; output_iast ] else [ output_ast ]) - ~rule:(if is_dev then rules.build_bin_deps_dev else rules.build_bin_deps); - if has_intf_file then ( - Bsb_ninja_targets.output_build oc - ~outputs: - [ output_iast ] - (* TODO: we can get rid of absloute path if we fixed the location to be - [lib/bs], better for testing? - *) - ~inputs:[ input_intf ] ~rule:ast_rule; - Bsb_ninja_targets.output_build oc ~outputs:[ output_cmi ] - ~inputs:[ output_iast ] - ~rule:(if is_dev then rules.mi_dev else rules.mi)); - let rule = - if has_intf_file then if is_dev then rules.mj_dev else rules.mj - else if is_dev then rules.mij_dev - else rules.mij - in - Bsb_ninja_targets.output_build oc - ~outputs: - (if has_intf_file then output_cmj :: output_js - else output_cmj :: output_cmi :: output_js) - ~inputs: - (if has_intf_file then [ output_ast; output_cmi ] else [ output_ast ]) - ~rule - -let handle_files_per_dir oc ~(rules : Bsb_ninja_rule.builtin) ~package_specs - ~files_to_install ~(namespace : string option) - (group : Bsb_file_groups.file_group) : unit = - let is_dev = group.is_dev in - handle_generators oc group rules.customs; - let installable = - match group.public with - | Export_all -> fun _ -> true - | Export_none -> fun _ -> false - | Export_set set -> fun module_name -> Set_string.mem set module_name - in - Map_string.iter group.sources (fun module_name module_info -> - if installable module_name && not is_dev then - Queue.add module_info files_to_install; - emit_module_build rules package_specs is_dev oc namespace module_info) - -(* ; - Bsb_ninja_targets.phony - oc ~order_only_deps:[] ~inputs:[] ~output:group.dir *) - -(* pseuduo targets per directory *) diff --git a/jscomp/bsb/bsb_ninja_file_groups.mli b/jscomp/bsb/bsb_ninja_file_groups.mli deleted file mode 100644 index 60836ef..0000000 --- a/jscomp/bsb/bsb_ninja_file_groups.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val handle_files_per_dir : - out_channel -> - rules:Bsb_ninja_rule.builtin -> - package_specs:Bsb_package_specs.t -> - files_to_install:Bsb_db.module_info Queue.t -> - namespace:string option -> - Bsb_file_groups.file_group -> - unit diff --git a/jscomp/bsb/bsb_ninja_gen.ml b/jscomp/bsb/bsb_ninja_gen.ml deleted file mode 100644 index d10b938..0000000 --- a/jscomp/bsb/bsb_ninja_gen.ml +++ /dev/null @@ -1,240 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Ext_path.combine - -(* we need copy package.json into [_build] since it does affect build output - it is a bad idea to copy package.json which requires to copy js files -*) - -(* let dash_i = "-I" *) - -let get_bsc_flags (bsc_flags : string list) : string = - String.concat Ext_string.single_space bsc_flags - -let emit_bsc_lib_includes (bs_dependencies : Bsb_config_types.dependencies) - (source_dirs : string list) external_includes (namespace : _ option) : - string = - (* TODO: bsc_flags contain stdlib path which is in the latter position currently *) - let all_includes source_dirs = - source_dirs - @ Ext_list.map bs_dependencies (fun x -> x.package_install_path) - @ (* for external includes, if it is absolute path, leave it as is - for relative path './xx', we need '../.././x' since we are in - [lib/bs], [build] is different from merlin though - *) - Ext_list.map external_includes (fun x -> - if Filename.is_relative x then Bsb_config.rev_lib_bs_prefix x else x) - in - - Bsb_build_util.include_dirs - (all_includes - (if namespace = None then source_dirs - else Filename.current_dir_name :: source_dirs - (*working dir is [lib/bs] we include this path to have namespace mapping*))) - -let output_static_resources (static_resources : string list) copy_rule oc = - Ext_list.iter static_resources (fun output -> - Bsb_ninja_targets.output_build oc ~outputs:[ output ] - ~inputs:[ Bsb_config.proj_rel output ] - ~rule:copy_rule); - if static_resources <> [] then - Bsb_ninja_targets.phony oc ~order_only_deps:static_resources ~inputs:[] - ~output:Literals.build_ninja - -(* - FIXME: check if the trick still works - phony build.ninja : | resources -*) -let mark_rescript oc = output_string oc "rescript = 1\n" - -let output_installation_file cwd_lib_bs namespace files_to_install = - let install_oc = open_out_bin (cwd_lib_bs // "install.ninja") in - mark_rescript install_oc; - let o s = output_string install_oc s in - let[@inline] oo suffix ~dest ~src = - o "o "; - o dest; - o suffix; - o " : cp "; - o src; - o suffix; - o "\n" - in - let bs = ".." // "bs" in - let sb = ".." // ".." in - o - (if Ext_sys.is_windows_or_cygwin then - "rule cp\n\ - \ command = cmd.exe /C copy /Y $i $out >NUL\n\ - rule touch\n\ - \ command = cmd.exe /C type nul >>$out & copy $out+,, >NUL\n" - else "rule cp\n command = cp $i $out\nrule touch\n command = touch $out\n"); - let essentials = Ext_buffer.create 1_000 in - files_to_install - |> Queue.iter - (fun ({ name_sans_extension; syntax_kind; info } : Bsb_db.module_info) -> - let base = Filename.basename name_sans_extension in - let dest = Ext_namespace_encode.make ?ns:namespace base in - let ns_origin = - Ext_namespace_encode.make ?ns:namespace name_sans_extension - in - let src = bs // ns_origin in - oo Literals.suffix_cmi ~dest ~src; - oo Literals.suffix_cmj ~dest ~src; - oo Literals.suffix_cmt ~dest ~src; - - Ext_buffer.add_string essentials dest; - Ext_buffer.add_string_char essentials Literals.suffix_cmi ' '; - Ext_buffer.add_string essentials dest; - Ext_buffer.add_string_char essentials Literals.suffix_cmj ' '; - - let suffix = - match syntax_kind with - | Ml -> Literals.suffix_ml - | Res -> Literals.suffix_res - in - oo suffix ~dest:base ~src:(sb // name_sans_extension); - match info with - | Intf -> assert false - | Impl -> () - | Impl_intf -> - let suffix_b = - match syntax_kind with - | Ml -> Literals.suffix_mli - | Res -> Literals.suffix_resi - in - oo suffix_b ~dest:base ~src:(sb // name_sans_extension); - oo Literals.suffix_cmti ~dest ~src); - (match namespace with - | None -> () - | Some dest -> - let src = bs // dest in - oo Literals.suffix_cmi ~dest ~src; - oo Literals.suffix_cmj ~dest ~src; - oo Literals.suffix_cmt ~dest ~src; - Ext_buffer.add_string essentials dest; - Ext_buffer.add_string_char essentials Literals.suffix_cmi ' '; - Ext_buffer.add_string essentials dest; - Ext_buffer.add_string essentials Literals.suffix_cmj); - Ext_buffer.add_char essentials '\n'; - o "build install.stamp : touch "; - Ext_buffer.output_buffer install_oc essentials; - close_out install_oc - -let output_ninja_and_namespace_map ~per_proj_dir ~package_kind - ({ - package_name; - external_includes; - bsc_flags; - pp_file; - ppx_files; - bs_dependencies; - bs_dev_dependencies; - js_post_build_cmd; - package_specs; - file_groups = { files = bs_file_groups }; - files_to_install; - built_in_dependency; - reason_react_jsx; - jsx; - uncurried; - generators; - namespace; - warning; - gentype_config; - } : - Bsb_config_types.t) : unit = - let lib_artifacts_dir = Bsb_config.lib_bs in - let cwd_lib_bs = per_proj_dir // lib_artifacts_dir in - - let warnings = Bsb_warning.to_bsb_string ~package_kind warning in - let bsc_flags = get_bsc_flags bsc_flags in - let dpkg_incls = - Bsb_build_util.include_dirs_by bs_dev_dependencies (fun x -> - x.package_install_path) - in - let bs_groups : Bsb_db.t = - { lib = Map_string.empty; dev = Map_string.empty } - in - let source_dirs : string list Bsb_db.cat = { lib = []; dev = [] } in - let static_resources = - Ext_list.fold_left bs_file_groups [] - (fun (acc_resources : string list) { sources; dir; resources; is_dev } -> - if is_dev then ( - bs_groups.dev <- Bsb_db_util.merge bs_groups.dev sources; - source_dirs.dev <- dir :: source_dirs.dev) - else ( - bs_groups.lib <- Bsb_db_util.merge bs_groups.lib sources; - source_dirs.lib <- dir :: source_dirs.lib); - Ext_list.map_append resources acc_resources (fun x -> dir // x)) - in - let lib = bs_groups.lib in - let dev = bs_groups.dev in - Bsb_db_util.sanity_check lib; - Bsb_db_util.sanity_check dev; - Map_string.iter dev (fun k a -> - if Map_string.mem lib k then - raise (Bsb_db_util.conflict_module_info k a (Map_string.find_exn lib k))); - let dev_incls = Bsb_build_util.include_dirs source_dirs.dev in - let digest = Bsb_db_encode.write_build_cache ~dir:cwd_lib_bs bs_groups in - let lib_incls = - emit_bsc_lib_includes bs_dependencies source_dirs.lib external_includes - namespace - in - let rules : Bsb_ninja_rule.builtin = - Bsb_ninja_rule.make_custom_rules ~gentype_config - ~has_postbuild:js_post_build_cmd ~pp_file ~has_builtin:built_in_dependency - ~reason_react_jsx ~jsx ~uncurried ~package_specs ~namespace ~digest ~package_name - ~warnings ~ppx_files ~bsc_flags ~dpkg_incls (* dev dependencies *) - ~lib_incls (* its own libs *) - ~dev_incls (* its own devs *) - ~bs_dependencies ~bs_dev_dependencies generators - in - - let oc = open_out_bin (cwd_lib_bs // Literals.build_ninja) in - mark_rescript oc; - let finger_file (x : Bsb_config_types.dependency) = - x.package_install_path // "install.stamp" - in - Ext_list.iter bs_dependencies (fun x -> - Bsb_ninja_targets.output_finger Bsb_ninja_global_vars.g_finger - (finger_file x) oc); - Ext_list.iter bs_dev_dependencies (fun x -> - Bsb_ninja_targets.output_finger Bsb_ninja_global_vars.g_finger - (finger_file x) oc); - output_static_resources static_resources rules.copy_resources oc; - (* Generate build statement for each file *) - Ext_list.iter bs_file_groups (fun files_per_dir -> - Bsb_ninja_file_groups.handle_files_per_dir oc ~rules ~package_specs - ~files_to_install ~namespace files_per_dir); - Ext_option.iter namespace (fun ns -> - let namespace_dir = per_proj_dir // lib_artifacts_dir in - Bsb_namespace_map_gen.output ~dir:namespace_dir ns bs_file_groups; - Bsb_ninja_targets.output_build oc - ~outputs:[ ns ^ Literals.suffix_cmi ] - ~inputs:[ ns ^ Literals.suffix_mlmap ] - ~rule:rules.build_package); - close_out oc; - output_installation_file cwd_lib_bs namespace files_to_install diff --git a/jscomp/bsb/bsb_ninja_gen.mli b/jscomp/bsb/bsb_ninja_gen.mli deleted file mode 100644 index 2c03a82..0000000 --- a/jscomp/bsb/bsb_ninja_gen.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val output_ninja_and_namespace_map : - per_proj_dir:string -> - package_kind:Bsb_package_kind.t -> - Bsb_config_types.t -> - unit -(** - generate ninja file based on [cwd] -*) diff --git a/jscomp/bsb/bsb_ninja_global_vars.ml b/jscomp/bsb/bsb_ninja_global_vars.ml deleted file mode 100644 index 998aeed..0000000 --- a/jscomp/bsb/bsb_ninja_global_vars.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Invariant: the two string literal has - to be "a" and "$a" -*) - -(* let src_root_dir = "g_root" - - let lazy_src_root_dir = "$g_root" *) -let g_finger = "g_finger" diff --git a/jscomp/bsb/bsb_ninja_regen.ml b/jscomp/bsb/bsb_ninja_regen.ml deleted file mode 100644 index cabf8d8..0000000 --- a/jscomp/bsb/bsb_ninja_regen.ml +++ /dev/null @@ -1,101 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let bsdeps = ".bsdeps" - -let ( // ) = Ext_path.combine - -(** Regenerate ninja file by need based on [.bsdeps] - return None if we dont need regenerate - otherwise return Some info -*) -let regenerate_ninja ~(package_kind : Bsb_package_kind.t) ~forced ~per_proj_dir ~warn_legacy_config ~warn_as_error - : Bsb_config_types.t option = - let lib_artifacts_dir = Bsb_config.lib_bs in - let lib_bs_dir = per_proj_dir // lib_artifacts_dir in - let output_deps = lib_bs_dir // bsdeps in - let check_result = - Bsb_ninja_check.check ~package_kind ~per_proj_dir ~forced ~warn_as_error ~file:output_deps - in - let config_filename, config_json = - Bsb_config_load.load_json ~per_proj_dir ~warn_legacy_config - in - match check_result with - | Good -> None (* Fast path, no need regenerate ninja *) - | Bsb_forced | Bsb_bsc_version_mismatch | Bsb_package_kind_inconsistent - | Bsb_file_corrupted | Bsb_file_not_exist | Bsb_source_directory_changed - | Bsb_regenerate_required - | Other _ -> - Bsb_log.info "@{BSB check@} build spec : %a @." - Bsb_ninja_check.pp_check_result check_result; - if check_result = Bsb_bsc_version_mismatch then ( - Bsb_log.warn - "@{Different compiler version@}: clean current repo@."; - Bsb_clean.clean_bs_deps per_proj_dir; - Bsb_clean.clean_self per_proj_dir); - - let config : Bsb_config_types.t = - Bsb_config_parse.interpret_json - ~filename:config_filename ~json:config_json ~package_kind ~per_proj_dir - in - - let warning = match config.warning with - | None -> ( - match warn_as_error with - | Some e -> Some {Bsb_warning.number = Some e; error = Warn_error_number e} - | None -> None) - | Some {error} as t -> - match (warn_as_error, error) with - | (Some error_str, Warn_error_false) -> - Some {number = Some error_str; error = Warn_error_number error_str} - | (Some error_str, Warn_error_number prev) -> - let new_error = prev ^ error_str in - Some {number = Some new_error; error = Warn_error_number new_error} - | _ -> t - in - - let config = {config with warning = warning} in - (* create directory, lib/bs, lib/js, lib/es6 etc *) - Bsb_build_util.mkp lib_bs_dir; - Bsb_package_specs.list_dirs_by config.package_specs (fun x -> - let dir = per_proj_dir // x in - (*Unix.EEXIST error*) - if not (Sys.file_exists dir) then Unix.mkdir dir 0o777); - (match package_kind with - | Toplevel -> - Bsb_watcher_gen.generate_sourcedirs_meta - ~name:(lib_bs_dir // Literals.sourcedirs_meta) - config.file_groups - | Pinned_dependency _ (* FIXME: seems need to be watched *) | Dependency _ - -> - ()); - - Bsb_ninja_gen.output_ninja_and_namespace_map ~per_proj_dir ~package_kind - config; - (* PR2184: we still need record empty dir - since it may add files in the future *) - Bsb_ninja_check.record ~package_kind ~per_proj_dir ~config ~warn_as_error - ~file:output_deps - (config.filename :: config.file_groups.globbed_dirs); - Some config diff --git a/jscomp/bsb/bsb_ninja_regen.mli b/jscomp/bsb/bsb_ninja_regen.mli deleted file mode 100644 index 0af5766..0000000 --- a/jscomp/bsb/bsb_ninja_regen.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val regenerate_ninja : - package_kind:Bsb_package_kind.t -> - forced:bool -> - per_proj_dir:string -> - warn_legacy_config:bool -> - warn_as_error:string option -> - Bsb_config_types.t option -(** Regenerate ninja file by need based on [.bsdeps] - return None if we dont need regenerate - otherwise return Some info -*) diff --git a/jscomp/bsb/bsb_ninja_rule.ml b/jscomp/bsb/bsb_ninja_rule.ml deleted file mode 100644 index 1103a3a..0000000 --- a/jscomp/bsb/bsb_ninja_rule.ml +++ /dev/null @@ -1,247 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = { - mutable used : bool; - (* rule_name : string; *) - name : out_channel -> string; -} - -let get_name (x : t) oc = x.name oc - -let print_rule (oc : out_channel) ?description ?(restat : unit option) - ?(dyndep : unit option) ~command name = - output_string oc "rule "; - output_string oc name; - output_string oc "\n"; - output_string oc " command = "; - output_string oc command; - output_string oc "\n"; - if dyndep <> None then output_string oc " dyndep = 1\n"; - if restat <> None then output_string oc " restat = 1\n"; - match description with - | None -> () - | Some description -> - output_string oc " description = "; - output_string oc description; - output_string oc "\n" - -(** allocate an unique name for such rule*) -let define ~command ?dyndep ?restat rule_name : t = - let rec self = - { - used = false; - (* rule_name ; *) - name = - (fun oc -> - if not self.used then ( - print_rule oc ?dyndep ?restat ~command rule_name; - self.used <- true); - rule_name); - } - in - - self - -type command = string - -type builtin = { - build_ast : t; (** TODO: Implement it on top of pp_flags *) - build_ast_from_re : t; - (* build_ast_from_rei : t ; *) - (* platform dependent, on Win32, - invoking cmd.exe - *) - copy_resources : t; - (* Rules below all need restat *) - build_bin_deps : t; - build_bin_deps_dev : t; - mj : t; - mj_dev : t; - mij : t; - mij_dev : t; - mi : t; - mi_dev : t; - build_package : t; - customs : t Map_string.t; -} - -let make_custom_rules ~(gentype_config : Bsb_config_types.gentype_config) - ~(has_postbuild : string option) ~(pp_file : string option) - ~(has_builtin : bool) - ~(reason_react_jsx : Bsb_config_types.reason_react_jsx option) - ~(jsx : Bsb_jsx.t) ~(uncurried: bool) ~(digest : string) ~(package_specs : Bsb_package_specs.t) - ~(namespace : string option) ~package_name ~warnings - ~(ppx_files : Bsb_config_types.ppx list) ~bsc_flags ~(dpkg_incls : string) - ~(lib_incls : string) ~(dev_incls : string) ~bs_dependencies - ~bs_dev_dependencies (custom_rules : command Map_string.t) : builtin = - let bs_dep = Ext_filename.maybe_quote Bsb_global_paths.vendor_bsdep in - let bsc = Ext_filename.maybe_quote Bsb_global_paths.vendor_bsc in - (* FIXME: We don't need set [-o ${out}] when building ast - since the default is already good -- it does not*) - let buf = Ext_buffer.create 100 in - let ns_flag = match namespace with None -> "" | Some n -> " -bs-ns " ^ n in - let add_uncurried_flag b = - if b then Ext_buffer.add_string buf " -uncurried" in - let mk_ml_cmj_cmd ~(read_cmi : [ `yes | `is_cmi | `no ]) ~is_dev ~postbuild : - string = - Ext_buffer.clear buf; - Ext_buffer.add_string buf bsc; - Ext_buffer.add_string buf ns_flag; - if read_cmi = `yes then Ext_buffer.add_string buf " -bs-read-cmi"; - (* The include order matters below *) - if is_dev then Ext_buffer.add_char_string buf ' ' dev_incls; - Ext_buffer.add_char_string buf ' ' lib_incls; - if is_dev then Ext_buffer.add_char_string buf ' ' dpkg_incls; - if not has_builtin then Ext_buffer.add_string buf " -nostdlib"; - Ext_buffer.add_char_string buf ' ' bsc_flags; - Ext_buffer.add_char_string buf ' ' warnings; - (* we need "-w a" in the end position to take effect - in non-toplevel mode - *) - (match gentype_config with - | false -> () - | true -> Ext_buffer.add_string buf " -bs-gentype"); - add_uncurried_flag uncurried; - if read_cmi <> `is_cmi then ( - Ext_buffer.add_string buf " -bs-package-name "; - Ext_buffer.add_string buf (Ext_filename.maybe_quote package_name); - Ext_buffer.add_string buf - (Bsb_package_specs.package_flag_of_package_specs package_specs - ~dirname:"$in_d")); - (match (bs_dependencies, bs_dev_dependencies) with - | [], [] -> () - | _, _ -> - Ext_buffer.add_string buf " -bs-v"; - Ext_buffer.add_ninja_prefix_var buf Bsb_ninja_global_vars.g_finger); - Ext_buffer.add_string buf " $i"; - (match postbuild with - | None -> () - | Some cmd -> - Ext_buffer.add_string buf " && "; - Ext_buffer.add_string buf cmd; - Ext_buffer.add_string buf " $out_last"); - Ext_buffer.contents buf - in - let mk_ast = - Ext_buffer.clear buf; - Ext_buffer.add_string buf bsc; - Ext_buffer.add_char_string buf ' ' warnings; - Ext_buffer.add_string buf " -bs-v "; - Ext_buffer.add_string buf Bs_version.version; - (match ppx_files with - | [] -> () - | _ -> - Ext_list.iter ppx_files (fun x -> - match string_of_float (Unix.stat x.name).st_mtime with - | exception _ -> () - | st -> Ext_buffer.add_char_string buf ',' st); - Ext_buffer.add_char_string buf ' ' (Bsb_build_util.ppx_flags ppx_files)); - (match pp_file with - | None -> () - | Some flag -> - Ext_buffer.add_char_string buf ' ' (Bsb_build_util.pp_flag flag)); - (match (reason_react_jsx, jsx.version) with - | _, Some Jsx_v3 -> Ext_buffer.add_string buf " -bs-jsx 3" - | _, Some Jsx_v4 -> Ext_buffer.add_string buf " -bs-jsx 4" - | Some Jsx_v3, None -> Ext_buffer.add_string buf " -bs-jsx 3" - | None, None -> ()); - (match jsx.module_ with - | None -> () - | Some React -> Ext_buffer.add_string buf " -bs-jsx-module react" - | Some Generic {moduleName} -> Ext_buffer.add_string buf (" -bs-jsx-module " ^ moduleName)); - (match jsx.mode with - | None -> () - | Some Classic -> Ext_buffer.add_string buf " -bs-jsx-mode classic" - | Some Automatic -> Ext_buffer.add_string buf " -bs-jsx-mode automatic"); - add_uncurried_flag uncurried; - - Ext_buffer.add_char_string buf ' ' bsc_flags; - Ext_buffer.add_string buf " -absname -bs-ast -o $out $i"; - Ext_buffer.contents buf - in - let build_ast = define ~command:mk_ast "ast" in - let build_ast_from_re = define ~command:mk_ast "astj" in - - let copy_resources = - define - ~command: - (if Ext_sys.is_windows_or_cygwin then "cmd.exe /C copy /Y $i $out >NUL" - else "cp $i $out") - "copy_resource" - in - - let build_bin_deps = - define ~restat:() - ~command:(bs_dep ^ " -hash " ^ digest ^ ns_flag ^ " $in") - "deps" - (* - it seems we already have restat = 1 - now it is an implicit dependency, we need avoid write duplicated files - *) - in - let build_bin_deps_dev = - define ~restat:() - ~command:(bs_dep ^ " -g -hash " ^ digest ^ ns_flag ^ " $in") - "deps_dev" - in - let aux ~name ~read_cmi ~postbuild = - ( define - ~command:(mk_ml_cmj_cmd ~read_cmi ~is_dev:false ~postbuild) - ~dyndep:() ~restat:() (* Always restat when having mli *) name, - define - ~command:(mk_ml_cmj_cmd ~read_cmi ~is_dev:true ~postbuild) - ~dyndep:() ~restat:() - (* Always restat when having mli *) (name ^ "_dev") ) - in - - let mj, mj_dev = aux ~name:"mj" ~read_cmi:`yes ~postbuild:has_postbuild in - let mij, mij_dev = aux ~read_cmi:`no ~name:"mij" ~postbuild:has_postbuild in - let mi, mi_dev = aux ~read_cmi:`is_cmi ~postbuild:None ~name:"mi" in - let build_package = - define - ~command:(bsc ^ " -w -49 -color always -no-alias-deps $i") - ~restat:() "build_package" - in - { - build_ast; - build_ast_from_re; - (* platform dependent, on Win32, - invoking cmd.exe - *) - copy_resources; - (* Rules below all need restat *) - build_bin_deps; - build_bin_deps_dev; - mj; - mj_dev; - mij; - mi; - mij_dev; - mi_dev; - build_package; - customs = - Map_string.mapi custom_rules (fun name command -> - define ~command ("custom_" ^ name)); - } diff --git a/jscomp/bsb/bsb_ninja_rule.mli b/jscomp/bsb/bsb_ninja_rule.mli deleted file mode 100644 index 5760ed8..0000000 --- a/jscomp/bsb/bsb_ninja_rule.mli +++ /dev/null @@ -1,89 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t -(** The complexity comes from the fact that we allow custom rules which could - conflict with our custom built-in rules -*) - -val get_name : t -> out_channel -> string - -(***********************************************************) - -type builtin = { - build_ast : t; - build_ast_from_re : t; - (* platform dependent, on Win32, - invoking cmd.exe - *) - copy_resources : t; - (* Rules below all need restat *) - build_bin_deps : t; - build_bin_deps_dev : t; - mj : t; - mj_dev : t; - mij : t; - mij_dev : t; - mi : t; - mi_dev : t; - build_package : t; - customs : t Map_string.t; -} -(** A list of existing rules *) - -(***********************************************************) - -(** rules are generally composed of built-in rules and customized rules, there are two design choices: - 1. respect custom rules with the same name, then we need adjust our built-in - rules dynamically in case the conflict. - 2. respect our built-in rules, then we only need re-load custom rules for each bsconfig.json -*) - -type command = string - -(* Since now we generate ninja files per bsconfig.json in a single process, - we must make sure it is re-entrant -*) -val make_custom_rules : - gentype_config:Bsb_config_types.gentype_config -> - has_postbuild:string option -> - pp_file:string option -> - has_builtin:bool -> - reason_react_jsx:Bsb_config_types.reason_react_jsx option -> - jsx:Bsb_jsx.t -> - uncurried:bool -> - digest:string -> - package_specs:Bsb_package_specs.t -> - namespace:string option -> - package_name:string -> - warnings:string -> - ppx_files:Bsb_config_types.ppx list -> - bsc_flags:string -> - dpkg_incls:string -> - lib_incls:string -> - dev_incls:string -> - bs_dependencies:Bsb_config_types.dependencies -> - bs_dev_dependencies:Bsb_config_types.dependencies -> - command Map_string.t -> - builtin diff --git a/jscomp/bsb/bsb_ninja_targets.ml b/jscomp/bsb/bsb_ninja_targets.ml deleted file mode 100644 index 61167b8..0000000 --- a/jscomp/bsb/bsb_ninja_targets.ml +++ /dev/null @@ -1,55 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let oc_list xs oc = - Ext_list.iter xs (fun s -> - output_string oc Ext_string.single_space; - output_string oc s) - -let output_build ~outputs ~inputs ~rule oc = - let rule = Bsb_ninja_rule.get_name rule oc in - (* Trigger building if not used *) - output_string oc "o"; - oc_list outputs oc; - output_string oc " : "; - output_string oc rule; - oc_list inputs oc; - output_string oc "\n" - -let phony ?(order_only_deps = []) ~inputs ~output oc = - output_string oc "o "; - output_string oc output; - output_string oc " : "; - output_string oc "phony"; - oc_list inputs oc; - if order_only_deps <> [] then ( - output_string oc " ||"; - oc_list order_only_deps oc); - output_string oc "\n" - -let output_finger key value oc = - output_string oc key; - output_string oc " := "; - output_string oc value; - output_string oc "\n" diff --git a/jscomp/bsb/bsb_ninja_targets.mli b/jscomp/bsb/bsb_ninja_targets.mli deleted file mode 100644 index 0a62957..0000000 --- a/jscomp/bsb/bsb_ninja_targets.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val output_build : - outputs:string list -> - inputs:string list -> - rule:Bsb_ninja_rule.t -> - out_channel -> - unit -(** output should always be marked explicitly, - otherwise the build system can not figure out clearly - however, for the command we don't need pass `-o` -*) - -val phony : - ?order_only_deps:string list -> - inputs:string list -> - output:string -> - out_channel -> - unit - -val output_finger : string -> string -> out_channel -> unit diff --git a/jscomp/bsb/bsb_package_kind.ml b/jscomp/bsb/bsb_package_kind.ml deleted file mode 100644 index 22c1962..0000000 --- a/jscomp/bsb/bsb_package_kind.ml +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2020 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type dep_payload = { package_specs : Bsb_package_specs.t; jsx : Bsb_jsx.t; uncurried : bool } - -type t = - | Toplevel - | Dependency of dep_payload - | Pinned_dependency of dep_payload -(* This package specs comes from the toplevel to - override the current settings -*) - -let encode_no_nl (x : t) = - match x with - | Toplevel -> "0" - | Dependency x -> - "1" - ^ Bsb_package_specs.package_flag_of_package_specs x.package_specs - ~dirname:"." - ^ Bsb_jsx.encode_no_nl x.jsx - | Pinned_dependency x -> - "2" - ^ Bsb_package_specs.package_flag_of_package_specs x.package_specs - ~dirname:"." - ^ Bsb_jsx.encode_no_nl x.jsx diff --git a/jscomp/bsb/bsb_package_specs.ml b/jscomp/bsb/bsb_package_specs.ml deleted file mode 100644 index bcb88c9..0000000 --- a/jscomp/bsb/bsb_package_specs.ml +++ /dev/null @@ -1,225 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Ext_path.combine - -(*FIXME: use assoc list instead *) -module Spec_set = Bsb_spec_set - -type t = { - modules : Spec_set.t; - runtime : string option; - (* This has to be resolved as early as possible, since - the path will be inherited in sub projects - *) -} - -let ( .?() ) = Map_string.find_opt - -let bad_module_format_message_exn ~loc format = - Bsb_exception.errorf ~loc - "package-specs: `%s` isn't a valid output module format. It has to be one \ - of: %s or %s" - format Literals.esmodule Literals.commonjs - -let supported_format (x : string) loc : Ext_module_system.t = - let _ = - if x = Literals.es6 || x = Literals.es6_global then - let loc_end = - {loc with Lexing.pos_cnum = loc.Lexing.pos_cnum + String.length x} - in - let loc = {Warnings.loc_start = loc; loc_end; loc_ghost = false} in - Location.deprecated loc - (Printf.sprintf "Option \"%s\" is deprecated. Use \"%s\" instead." x - Literals.esmodule) - in - if x = Literals.es6 || x = Literals.esmodule then Esmodule - else if x = Literals.commonjs then Commonjs - else if x = Literals.es6_global then Es6_global - else bad_module_format_message_exn ~loc x - -let string_of_format (x : Ext_module_system.t) = - match x with - | Commonjs -> Literals.commonjs - | Esmodule -> Literals.esmodule - | Es6_global -> Literals.es6_global - -let js_suffix_regexp = Str.regexp "[A-Za-z0-9-_.]*\\.[cm]?js" - -let validate_js_suffix suffix = Str.string_match js_suffix_regexp suffix 0 - -let rec from_array suffix (arr : Ext_json_types.t array) : Spec_set.t = - let spec = ref Spec_set.empty in - let has_in_source = ref false in - Ext_array.iter arr (fun x -> - let result = from_json_single suffix x in - if result.in_source then - if not !has_in_source then has_in_source := true - else - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "package-specs: detected two module formats that are both \ - configured to be in-source."; - spec := Spec_set.add result !spec); - !spec - -(* TODO: FIXME: better API without mutating *) -and from_json_single suffix (x : Ext_json_types.t) : Bsb_spec_set.spec = - match x with - | Str { str = format; loc } -> - { format = supported_format format loc; in_source = false; suffix } - | Obj { map; loc } -> ( - match map.?("module") with - | Some (Str { str = format }) -> - let in_source = - match map.?(Bsb_build_schemas.in_source) with - | Some (True _) -> true - | Some _ | None -> false - in - let suffix = - match map.?(Bsb_build_schemas.suffix) with - | Some (Str { str = suffix; _ }) when validate_js_suffix suffix -> suffix - | Some (Str {str; loc}) -> - Bsb_exception.errorf ~loc - ("invalid suffix \"%s\". The suffix and may contain letters, digits, \"-\", \"_\" and \".\" and must end with .js, .mjs or .cjs.") str - | Some _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "expected a string extension like \".js\"" - | None -> suffix - in - { format = supported_format format loc; in_source; suffix } - | Some _ -> - Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, `module` \ - field should be a string, not an array. If you want to pass \ - multiple module specs, try turning package-specs into an array of \ - objects (or strings) instead." - | None -> - Bsb_exception.errorf ~loc - "package-specs: when the configuration is an object, the `module` \ - field is mandatory.") - | _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of x) - "package-specs: expected either a string or an object." - -let from_json suffix (x : Ext_json_types.t) : Spec_set.t = - match x with - | Arr { content; _ } -> from_array suffix content - | _ -> Spec_set.singleton (from_json_single suffix x) - -let bs_package_output = "-bs-package-output" - -[@@@warning "+9"] - -(* Assume input is valid - coordinate with command line flag - {[ -bs-package-output commonjs:lib/js/jscomp/test:.js ]} -*) -let package_flag ({ format; in_source; suffix } : Bsb_spec_set.spec) dir = - Ext_string.inter2 bs_package_output - (Ext_string.concat5 (string_of_format format) Ext_string.single_colon - (if in_source then dir - else Bsb_config.top_prefix_of_format format // dir) - Ext_string.single_colon - suffix) - -(* FIXME: we should adapt it *) -let package_flag_of_package_specs (package_specs : t) ~(dirname : string) : - string = - let res = - match (package_specs.modules :> Bsb_spec_set.spec list) with - | [] -> Ext_string.empty - | [ format ] -> - Ext_string.inter2 Ext_string.empty (package_flag format dirname) - | [ a; b ] -> - Ext_string.inter3 Ext_string.empty (package_flag a dirname) - (package_flag b dirname) - | [ a; b; c ] -> - Ext_string.inter4 Ext_string.empty (package_flag a dirname) - (package_flag b dirname) (package_flag c dirname) - | _ -> - Spec_set.fold - (fun format acc -> - Ext_string.inter2 acc (package_flag format dirname)) - package_specs.modules Ext_string.empty - in - match package_specs.runtime with - | None -> res - | Some x -> Ext_string.inter3 res "-runtime" x - -let default_package_specs suffix = - (* TODO: swap default to Esmodule in v12 *) - Spec_set.singleton { format = Commonjs; in_source = false; suffix } - -(** - [get_list_of_output_js specs "src/hi/hello"] - -*) -let get_list_of_output_js (package_specs : t) - (output_file_sans_extension : string) = - Spec_set.fold - (fun (spec : Bsb_spec_set.spec) acc -> - let basename = - Ext_namespace.change_ext_ns_suffix output_file_sans_extension spec.suffix - in - (if spec.in_source then Bsb_config.rev_lib_bs_prefix basename - else Bsb_config.lib_bs_prefix_of_format spec.format // basename) - :: acc) - package_specs.modules [] - -let list_dirs_by (package_specs : t) (f : string -> unit) = - Spec_set.iter - (fun (spec : Bsb_spec_set.spec) -> - if not spec.in_source then f (Bsb_config.top_prefix_of_format spec.format)) - package_specs.modules - -type json_map = Ext_json_types.t Map_string.t - -let extract_js_suffix_exn (map : json_map) : string = - match map.?(Bsb_build_schemas.suffix) with - | None -> Literals.suffix_js - | Some (Str { str = suffix; _ }) when validate_js_suffix suffix -> suffix - | Some ((Str {str; _}) as config) -> - Bsb_exception.config_error config - ("invalid suffix \"" ^ str ^ "\". The suffix and may contain letters, digits, \"-\", \"_\" and \".\" and must end with .js, .mjs or .cjs.") - | Some config -> - Bsb_exception.config_error config - "expected a string extension like \".js\"" - -let from_map ~(cwd : string) map = - let suffix = extract_js_suffix_exn map in - let modules = - match map.?(Bsb_build_schemas.package_specs) with - | Some x -> from_json suffix x - | None -> default_package_specs suffix - in - let runtime = - match map.?(Bsb_build_schemas.external_stdlib) with - | None -> None - | Some (Str { str; _ }) -> - Some - (Bsb_pkg.resolve_bs_package ~cwd - (Bsb_pkg_types.string_as_package str)) - | _ -> assert false - in - { runtime; modules } diff --git a/jscomp/bsb/bsb_package_specs.mli b/jscomp/bsb/bsb_package_specs.mli deleted file mode 100644 index a5c575e..0000000 --- a/jscomp/bsb/bsb_package_specs.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t - -val from_map : cwd:string -> Ext_json_types.t Map_string.t -> t - -val get_list_of_output_js : t -> string -> string list - -val package_flag_of_package_specs : t -> dirname:string -> string -(** - Sample output: {[ -bs-package-output commonjs:lib/js/jscomp/test]} -*) - -(* used to ensure each dir does exist *) -val list_dirs_by : t -> (string -> unit) -> unit diff --git a/jscomp/bsb/bsb_parse_sources.ml b/jscomp/bsb/bsb_parse_sources.ml deleted file mode 100644 index e9969e9..0000000 --- a/jscomp/bsb/bsb_parse_sources.ml +++ /dev/null @@ -1,445 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type build_generator = Bsb_file_groups.build_generator - -let ( .?() ) = Map_string.find_opt - -(* type file_group = Bsb_file_groups.file_group *) - -type t = Bsb_file_groups.t - -let is_input_or_output (xs : build_generator list) (x : string) = - Ext_list.exists xs (fun { input; output } -> - let it_is y = y = x in - Ext_list.exists input it_is || Ext_list.exists output it_is) - -let errorf x fmt = Bsb_exception.errorf ~loc:(Ext_json.loc_of x) fmt - -type cxt = { - package_kind : Bsb_package_kind.t; - is_dev : bool; - cwd : string; - root : string; - cut_generators : bool; - traverse : bool; - (* namespace : string option; *) - ignored_dirs : Set_string.t; -} - -(** [public] has a list of modules, we do a sanity check to see if all the listed - modules are indeed valid module components -*) -let collect_pub_modules (xs : Ext_json_types.t array) (cache : Bsb_db.map) : - Set_string.t = - let set = ref Set_string.empty in - for i = 0 to Array.length xs - 1 do - let v = Array.unsafe_get xs i in - match v with - | Str { str; loc } -> - if Map_string.mem cache str then set := Set_string.add !set str - else - Bsb_exception.errorf ~loc "%S in public is not an existing module" str - | _ -> - Bsb_exception.errorf ~loc:(Ext_json.loc_of v) - "public expects a list of strings" - done; - !set - -let extract_pub (input : Ext_json_types.t Map_string.t) - (cur_sources : Bsb_db.map) : Bsb_file_groups.public = - match input.?(Bsb_build_schemas.public) with - | Some (Str { str = s } as x) -> - if s = Bsb_build_schemas.export_all then Export_all - else if s = Bsb_build_schemas.export_none then Export_none - else errorf x "invalid str for %s " s - | Some (Arr { content }) -> - Export_set (collect_pub_modules content cur_sources) - | Some config -> Bsb_exception.config_error config "expect array or string" - | None -> Export_all - -let extract_resources (input : Ext_json_types.t Map_string.t) : string list = - match input.?(Bsb_build_schemas.resources) with - | Some (Arr x) -> Bsb_build_util.get_list_string x.content - | Some config -> Bsb_exception.config_error config "expect array " - | None -> [] - -let extract_input_output (edge : Ext_json_types.t) : string list * string list = - let error () = - errorf edge {| invalid edge format, expect ["output" , ":", "input" ]|} - in - match edge with - | Arr { content } -> ( - match - Ext_array.find_and_split content - (fun x () -> match x with Str { str = ":" } -> true | _ -> false) - () - with - | No_split -> error () - | Split (output, input) -> - ( Ext_array.to_list_map output (fun x -> - match x with - | Str { str = ":" } -> error () - | Str { str } -> Some str - | _ -> None), - Ext_array.to_list_map input (fun x -> - match x with - | Str { str = ":" } -> error () - | Str { str } -> - Some str - (* More rigirous error checking: It would trigger a ninja syntax error *) - | _ -> None) )) - | _ -> error () - -type json_map = Ext_json_types.t Map_string.t - -let extract_generators (input : json_map) : build_generator list = - match input.?(Bsb_build_schemas.generators) with - | Some (Arr { content; loc_start = _ }) -> - (* Need check is dev build or not *) - Ext_array.fold_left content [] (fun acc x -> - match x with - | Obj { map } -> ( - match - (map.?(Bsb_build_schemas.name), map.?(Bsb_build_schemas.edge)) - with - | Some (Str command), Some edge -> - let output, input = extract_input_output edge in - { Bsb_file_groups.input; output; command = command.str } - :: acc - | _ -> errorf x "Invalid generator format") - | _ -> errorf x "Invalid generator format") - | Some x -> errorf x "Invalid generator format" - | None -> [] - -let extract_predicate (m : json_map) : string -> bool = - let excludes = - match m.?(Bsb_build_schemas.excludes) with - | None -> [] - | Some (Arr { content = arr }) -> Bsb_build_util.get_list_string arr - | Some x -> Bsb_exception.config_error x "excludes expect array " - in - let slow_re = m.?(Bsb_build_schemas.slow_re) in - match (slow_re, excludes) with - | Some (Str { str = s }), [] -> - let re = Str.regexp s in - fun name -> Str.string_match re name 0 - | Some (Str { str = s }), _ :: _ -> - let re = Str.regexp s in - fun name -> - Str.string_match re name 0 && not (Ext_list.mem_string excludes name) - | Some config, _ -> - Bsb_exception.config_error config - (Bsb_build_schemas.slow_re ^ " expect a string literal") - | None, _ -> fun name -> not (Ext_list.mem_string excludes name) - -(** [parsing_source_dir_map cxt input] - Major work done in this function, - assume [not toplevel && not (Bsb_dir_index.is_lib_dir dir_index)] - is already checked, so we don't need check it again -*) - -(** This is the only place where we do some removal during scanning, - configurabl -*) - -(********************************************************************) -(* starts parsing *) -let rec parsing_source_dir_map ({ cwd = dir } as cxt) - (input : Ext_json_types.t Map_string.t) : Bsb_file_groups.t = - if Set_string.mem cxt.ignored_dirs dir then Bsb_file_groups.empty - else - let cur_globbed_dirs = ref false in - let has_generators = - match cxt with - | { - cut_generators = false; - package_kind = Toplevel | Pinned_dependency _; - } -> - true - | { cut_generators = false; package_kind = Dependency _ } - | { cut_generators = true; _ } -> - false - in - let scanned_generators = extract_generators input in - let sub_dirs_field = input.?(Bsb_build_schemas.subdirs) in - let base_name_array = - lazy - (cur_globbed_dirs := true; - Sys.readdir (Filename.concat cxt.root dir)) - in - let output_sources = - Ext_list.fold_left - (Ext_list.flat_map scanned_generators (fun x -> x.output)) - Map_string.empty - (fun acc o -> Bsb_db_util.add_basename ~dir acc o) - in - let sources = - match input.?(Bsb_build_schemas.files) with - | None -> - (* We should avoid temporary files *) - Ext_array.fold_left (Lazy.force base_name_array) output_sources - (fun acc basename -> - if is_input_or_output scanned_generators basename then acc - else Bsb_db_util.add_basename ~dir acc basename) - | Some (Arr basenames) -> - Ext_array.fold_left basenames.content output_sources - (fun acc basename -> - match basename with - | Str { str = basename; loc } -> - Bsb_db_util.add_basename ~dir acc basename - ~error_on_invalid_suffix:loc - | _ -> acc) - | Some (Obj { map; loc = _ }) -> - (* { excludes : [], slow_re : "" }*) - let predicate = extract_predicate map in - Ext_array.fold_left (Lazy.force base_name_array) output_sources - (fun acc basename -> - if - is_input_or_output scanned_generators basename - || not (predicate basename) - then acc - else Bsb_db_util.add_basename ~dir acc basename) - | Some x -> - Bsb_exception.config_error x "files field expect array or object " - in - let resources = extract_resources input in - let public = extract_pub input sources in - (* Doing recursive stuff *) - let children = - match (sub_dirs_field, cxt.traverse) with - | None, true | Some (True _), _ -> - let root = cxt.root in - let parent = Filename.concat root dir in - Ext_array.fold_left (Lazy.force base_name_array) Bsb_file_groups.empty - (fun origin x -> - if - (not (Set_string.mem cxt.ignored_dirs x)) - && Ext_sys.is_directory_no_exn (Filename.concat parent x) - then - Bsb_file_groups.merge - (parsing_source_dir_map - { - cxt with - cwd = - Ext_path.concat cxt.cwd - (Ext_path.simple_convert_node_path_to_os_path x); - traverse = true; - } - Map_string.empty) - origin - else origin) - (* readdir parent avoiding scanning twice *) - | None, false | Some (False _), _ -> Bsb_file_groups.empty - | Some s, _ -> parse_sources cxt s - in - (* Do some clean up *) - (* prune_staled_bs_js_files cxt sources ; *) - Bsb_file_groups.cons - ~file_group: - { - dir; - sources; - resources; - public; - is_dev = cxt.is_dev; - generators = (if has_generators then scanned_generators else []); - } - ?globbed_dir:(if !cur_globbed_dirs then Some dir else None) - children - -and parsing_single_source ({ package_kind; is_dev; cwd } as cxt) - (x : Ext_json_types.t) : t = - match x with - | Str { str = dir } -> ( - match (package_kind, is_dev) with - | Dependency _, true -> Bsb_file_groups.empty - | Dependency _, false | (Toplevel | Pinned_dependency _), _ -> - parsing_source_dir_map - { - cxt with - cwd = - Ext_path.concat cwd - (Ext_path.simple_convert_node_path_to_os_path dir); - } - Map_string.empty) - | Obj { map } -> ( - let current_dir_index = - match map.?(Bsb_build_schemas.type_) with - | Some (Str { str = "dev" }) -> true - | Some _ -> - Bsb_exception.config_error x {|type field expect "dev" literal |} - | None -> is_dev - in - match (package_kind, current_dir_index) with - | Dependency _, true -> Bsb_file_groups.empty - | Dependency _, false | (Toplevel | Pinned_dependency _), _ -> - let dir = - match map.?(Bsb_build_schemas.dir) with - | Some (Str { str }) -> - if str = Literals.library_file then - Bsb_exception.config_error x (Printf.sprintf "dir field should be different from `%s`" Literals.library_file) - else - Ext_path.simple_convert_node_path_to_os_path str - | Some x -> - Bsb_exception.config_error x "dir expected to be a string" - | None -> - Bsb_exception.config_error x - ("required field :" ^ Bsb_build_schemas.dir ^ " missing") - in - - parsing_source_dir_map - { - cxt with - is_dev = current_dir_index; - cwd = Ext_path.concat cwd dir; - } - map) - | _ -> Bsb_file_groups.empty - -and parsing_arr_sources cxt (file_groups : Ext_json_types.t array) = - Ext_array.fold_left file_groups Bsb_file_groups.empty (fun origin x -> - Bsb_file_groups.merge (parsing_single_source cxt x) origin) - -and parse_sources (cxt : cxt) (sources : Ext_json_types.t) = - match sources with - | Arr file_groups -> parsing_arr_sources cxt file_groups.content - | _ -> parsing_single_source cxt sources - -let scan ~package_kind ~root ~cut_generators ~(* ~namespace *) - ignored_dirs x : t = - parse_sources - { - ignored_dirs; - package_kind; - is_dev = false; - cwd = Filename.current_dir_name; - root; - cut_generators; - (* namespace; *) - traverse = false; - } - x - -(* Walk through to do some work *) -type walk_cxt = { - cwd : string; - root : string; - traverse : bool; - ignored_dirs : Set_string.t; - gentype_language : string; -} - -let rec walk_sources (cxt : walk_cxt) (sources : Ext_json_types.t) = - match sources with - | Arr { content } -> - Ext_array.iter content (fun x -> walk_single_source cxt x) - | x -> walk_single_source cxt x - -and walk_single_source cxt (x : Ext_json_types.t) = - match x with - | Str { str = dir } -> - let dir = Ext_path.simple_convert_node_path_to_os_path dir in - walk_source_dir_map { cxt with cwd = Ext_path.concat cxt.cwd dir } None - | Obj { map } -> ( - match map.?(Bsb_build_schemas.dir) with - | Some (Str { str }) -> - let dir = Ext_path.simple_convert_node_path_to_os_path str in - walk_source_dir_map - { cxt with cwd = Ext_path.concat cxt.cwd dir } - map.?(Bsb_build_schemas.subdirs) - | _ -> ()) - | _ -> () - -and walk_source_dir_map (cxt : walk_cxt) sub_dirs_field = - let working_dir = Filename.concat cxt.root cxt.cwd in - if not (Set_string.mem cxt.ignored_dirs cxt.cwd) then ( - let file_array = Sys.readdir working_dir in - (* Remove .gen.js/.gen.tsx during clean up *) - Ext_array.iter file_array (fun file -> - let is_typescript = cxt.gentype_language = "typescript" in - if - (not is_typescript) - && Ext_string.ends_with file Literals.suffix_gen_js - || (is_typescript && Ext_string.ends_with file Literals.suffix_gen_tsx) - then Sys.remove (Filename.concat working_dir file)); - let cxt_traverse = cxt.traverse in - match (sub_dirs_field, cxt_traverse) with - | None, true | Some (True _), _ -> - Ext_array.iter file_array (fun f -> - if - (not (Set_string.mem cxt.ignored_dirs f)) - && Ext_sys.is_directory_no_exn (Filename.concat working_dir f) - then - walk_source_dir_map - { - cxt with - cwd = - Ext_path.concat cxt.cwd - (Ext_path.simple_convert_node_path_to_os_path f); - traverse = true; - } - None) - | None, _ | Some (False _), _ -> () - | Some s, _ -> walk_sources cxt s) - -(* It makes use of the side effect when [walk_sources], removing suffix_re_js, - TODO: make it configurable -*) -let clean_re_js root = - match - Ext_json_parse.parse_json_from_file - (Filename.concat root Literals.bsconfig_json) - with - | Obj { map } -> - let ignored_dirs = - match map.?(Bsb_build_schemas.ignored_dirs) with - | Some (Arr { content = x }) -> - Set_string.of_list (Bsb_build_util.get_list_string x) - | Some _ | None -> Set_string.empty - in - let gentype_language = - match map.?(Bsb_build_schemas.gentypeconfig) with - | None -> "" - | Some (Obj { map }) -> ( - match map.?(Bsb_build_schemas.language) with - | None -> "" - | Some (Str { str }) -> str - | Some _ -> "") - | Some _ -> "" - in - Ext_option.iter map.?(Bsb_build_schemas.sources) (fun config -> - try - walk_sources - { - root; - traverse = true; - cwd = Filename.current_dir_name; - ignored_dirs; - gentype_language; - } - config - with _ -> ()) - | _ -> () - | exception _ -> () diff --git a/jscomp/bsb/bsb_parse_sources.mli b/jscomp/bsb/bsb_parse_sources.mli deleted file mode 100644 index 8e48631..0000000 --- a/jscomp/bsb/bsb_parse_sources.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val scan : - package_kind:Bsb_package_kind.t -> - root:string -> - cut_generators:bool -> - (* namespace : string option -> *) - ignored_dirs:Set_string.t -> - Ext_json_types.t -> - Bsb_file_groups.t -(** [scan .. cxt json] - entry is to the [sources] in the schema - given a root, return an object which is - all relative paths, this function will do the IO -*) - -val clean_re_js : string -> unit -(** This function has some duplication - from [scan], - the parsing assuming the format is - already valid -*) diff --git a/jscomp/bsb/bsb_pkg.ml b/jscomp/bsb/bsb_pkg.ml deleted file mode 100644 index f2c1d27..0000000 --- a/jscomp/bsb/bsb_pkg.ml +++ /dev/null @@ -1,129 +0,0 @@ -(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Filename.concat - -type t = Bsb_pkg_types.t - -(* TODO: be more restrict - [bsconfig.json] does not always make sense, - when resolving [ppx-flags] -*) -let make_sub_path (x : t) : string = - Literals.node_modules // Bsb_pkg_types.to_string x - -let node_paths : string list Lazy.t = - lazy - (try - Ext_string.split (Sys.getenv "NODE_PATH") - (if Sys.win32 then ';' else ':') - with _ -> []) - -(** It makes sense to have this function raise, when [bsb] could not resolve a package, it used to mean - a failure -*) -let check_dir dir = - match Sys.file_exists dir with true -> Some dir | false -> None - -let resolve_bs_package_aux ~cwd (pkg : t) = - (* First try to resolve recursively from the current working directory *) - let sub_path = make_sub_path pkg in - let rec aux cwd = - let abs_marker = cwd // sub_path in - if Sys.file_exists abs_marker then abs_marker - else - let another_cwd = Filename.dirname cwd in - (* TODO: may non-terminating when see symlinks *) - if String.length another_cwd < String.length cwd then aux another_cwd - else - (* To the end try other possiblilities [NODE_PATH]*) - match - Ext_list.find_opt (Lazy.force node_paths) (fun dir -> - check_dir (dir // Bsb_pkg_types.to_string pkg)) - with - | Some resolved_dir -> resolved_dir - | None -> Bsb_exception.package_not_found ~pkg ~json:None - in - aux cwd - -module Coll = Hash.Make (struct - type nonrec t = t - - let equal = Bsb_pkg_types.equal - - let hash (x : t) = Hashtbl.hash x -end) - -let cache : string Coll.t = Coll.create 0 - -let to_list cb = Coll.to_list cache cb - -(** TODO: collect all warnings and print later *) -let resolve_bs_package ~cwd (package : t) = - match Coll.find_opt cache package with - | None -> - let result = resolve_bs_package_aux ~cwd package in - Bsb_log.info "@{Package@} %a -> %s@." Bsb_pkg_types.print package - result; - Coll.add cache package result; - result - | Some x -> - let result = resolve_bs_package_aux ~cwd package in - if not (Bsb_real_path.is_same_paths_via_io result x) then - Bsb_log.warn - "@{Duplicated package:@} %a %s (chosen) vs %s in %s @." - Bsb_pkg_types.print package x result cwd; - x - -(** The package does not need to be a bspackage - example: - {[ - resolve_npm_package_file ~cwd "reason/refmt";; - resolve_npm_package_file ~cwd "reason/refmt/xx/yy" - ]} - It also returns the path name - Note the input [sub_path] is already converted to physical meaning path according to OS -*) -(* let resolve_npm_package_file ~cwd sub_path = *) -(* let rec aux cwd = *) -(* let abs_marker = cwd // Literals.node_modules // sub_path in *) -(* if Sys.file_exists abs_marker then Some abs_marker *) -(* else *) -(* let cwd' = Filename.dirname cwd in *) -(* if String.length cwd' < String.length cwd then *) -(* aux cwd' *) -(* else *) -(* try *) -(* let abs_marker = *) -(* Sys.getenv "npm_config_prefix" *) -(* // "lib" // Literals.node_modules // sub_path in *) -(* if Sys.file_exists abs_marker *) -(* then Some abs_marker *) -(* else None *) -(* (\* Bs_exception.error (Bs_package_not_found name) *\) *) -(* with *) -(* Not_found -> None *) -(* (\* Bs_exception.error (Bs_package_not_found name) *\) *) -(* in *) -(* aux cwd *) diff --git a/jscomp/bsb/bsb_pkg.mli b/jscomp/bsb/bsb_pkg.mli deleted file mode 100644 index 2359b41..0000000 --- a/jscomp/bsb/bsb_pkg.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** [resolve cwd module_name], - [cwd] is current working directory, absolute path - Trying to find paths to load [module_name] - it is sepcialized for option [-bs-package-include] which requires - [npm_package_name/lib/ocaml] - - it relies on [npm_config_prefix] env variable for global npm modules -*) - -val resolve_bs_package : cwd:string -> Bsb_pkg_types.t -> string -(** @raise when not found *) - -val to_list : (Bsb_pkg_types.t -> string -> 'a) -> 'a list -(** used by watcher *) diff --git a/jscomp/bsb/bsb_pkg_types.ml b/jscomp/bsb/bsb_pkg_types.ml deleted file mode 100644 index 8a7aa44..0000000 --- a/jscomp/bsb/bsb_pkg_types.ml +++ /dev/null @@ -1,89 +0,0 @@ -(* Copyright (C) 2018- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Filename.concat - -type t = Global of string | Scope of string * scope - -and scope = string - -let to_string (x : t) = - match x with Global s -> s | Scope (s, scope) -> scope // s - -let print fmt (x : t) = - match x with - | Global s -> Format.pp_print_string fmt s - | Scope (name, scope) -> Format.fprintf fmt "%s/%s" scope name - -let equal (x : t) y = - match (x, y) with - | Scope (a0, a1), Scope (b0, b1) -> a0 = b0 && a1 = b1 - | Global a0, Global b0 -> a0 = b0 - | Scope _, Global _ | Global _, Scope _ -> false - -(** - input: {[ - @hello/yy/xx - hello/yy - ]} - FIXME: fix invalid input - {[ - hello//xh//helo - ]} -*) -let extract_pkg_name_and_file (s : string) = - let len = String.length s in - assert (len > 0); - let v = String.unsafe_get s 0 in - if v = '@' then ( - let scope_id = Ext_string.no_slash_idx s in - assert (scope_id > 0); - let pkg_id = Ext_string.no_slash_idx_from s (scope_id + 1) in - let scope = String.sub s 0 scope_id in - - if pkg_id < 0 then - (Scope (String.sub s (scope_id + 1) (len - scope_id - 1), scope), "") - else - ( Scope (String.sub s (scope_id + 1) (pkg_id - scope_id - 1), scope), - String.sub s (pkg_id + 1) (len - pkg_id - 1) )) - else - let pkg_id = Ext_string.no_slash_idx s in - if pkg_id < 0 then (Global s, "") - else - ( Global (String.sub s 0 pkg_id), - String.sub s (pkg_id + 1) (len - pkg_id - 1) ) - -let string_as_package (s : string) : t = - let len = String.length s in - assert (len > 0); - let v = String.unsafe_get s 0 in - if v = '@' then ( - let scope_id = Ext_string.no_slash_idx s in - assert (scope_id > 0); - (* better-eror message for invalid scope package: - @rescript/std - *) - Scope - (String.sub s (scope_id + 1) (len - scope_id - 1), String.sub s 0 scope_id)) - else Global s diff --git a/jscomp/bsb/bsb_pkg_types.mli b/jscomp/bsb/bsb_pkg_types.mli deleted file mode 100644 index ebb1662..0000000 --- a/jscomp/bsb/bsb_pkg_types.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* Copyright (C) 2019- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Global of string | Scope of string * scope - -and scope = string - -val to_string : t -> string - -val print : Format.formatter -> t -> unit - -val equal : t -> t -> bool - -(* The second element could be empty or dropped -*) -val extract_pkg_name_and_file : string -> t * string - -val string_as_package : string -> t diff --git a/jscomp/bsb/bsb_real_path.ml b/jscomp/bsb/bsb_real_path.ml deleted file mode 100644 index d4c33d5..0000000 --- a/jscomp/bsb/bsb_real_path.ml +++ /dev/null @@ -1,50 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Filename.concat - -let normalize_exn (s : string) : string = - let old_cwd = Sys.getcwd () in - Unix.chdir s; - let normalized = Sys.getcwd () in - Unix.chdir old_cwd; - normalized - -let real_path p = - match Sys.is_directory p with - | exception _ -> - let rec resolve dir = - if Sys.file_exists dir then normalize_exn dir - else - let parent = Filename.dirname dir in - if dir = parent then dir else resolve parent // Filename.basename dir - in - let p = if Filename.is_relative p then Sys.getcwd () // p else p in - resolve p - | true -> normalize_exn p - | false -> ( - let dir = normalize_exn (Filename.dirname p) in - match Filename.basename p with "." -> dir | base -> dir // base) - -let is_same_paths_via_io a b = if a = b then true else real_path a = real_path b diff --git a/jscomp/bsb/bsb_real_path.mli b/jscomp/bsb/bsb_real_path.mli deleted file mode 100644 index 65a93ef..0000000 --- a/jscomp/bsb/bsb_real_path.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val is_same_paths_via_io : string -> string -> bool diff --git a/jscomp/bsb/bsb_regex.ml b/jscomp/bsb/bsb_regex.ml deleted file mode 100644 index 98437c3..0000000 --- a/jscomp/bsb/bsb_regex.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let string_after s n = String.sub s n (String.length s - n) - -(* There seems to be a bug in {!Str.global_substitute} - {[ - Str.global_substitute (Str.regexp "\\${rescript:\\([-a-zA-Z0-9]+\\)}") (fun x -> (x^":found")) {| ${rescript:hello-world} ${rescript:x} ${x}|} ;; - - : bytes = - " ${rescript:hello-world} ${rescript:x} ${x}:found ${rescript:hello-world} ${rescript:x} ${x}:found ${x}" - ]} -*) -let global_substitute text ~reg:expr repl_fun = - let text_len = String.length text in - let expr = Str.regexp expr in - let rec replace accu start last_was_empty = - let startpos = if last_was_empty then start + 1 else start in - if startpos > text_len then string_after text start :: accu - else - match Str.search_forward expr text startpos with - | exception Not_found -> string_after text start :: accu - | pos -> - let end_pos = Str.match_end () in - let matched = Str.matched_string text in - let groups = - let rec aux n acc = - match Str.matched_group n text with - | exception (Not_found | Invalid_argument _) -> acc - | v -> aux (succ n) (v :: acc) - in - aux 1 [] - in - let repl_text = repl_fun matched groups in - replace - (repl_text :: String.sub text start (pos - start) :: accu) - end_pos (end_pos = pos) - in - String.concat "" (List.rev (replace [] 0 false)) diff --git a/jscomp/bsb/bsb_regex.mli b/jscomp/bsb/bsb_regex.mli deleted file mode 100644 index 747b9fd..0000000 --- a/jscomp/bsb/bsb_regex.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val global_substitute : - string -> reg:string -> (string -> string list -> string) -> string -(** Used in `bsb -init` command *) diff --git a/jscomp/bsb/bsb_spec_set.ml b/jscomp/bsb/bsb_spec_set.ml deleted file mode 100644 index a53862f..0000000 --- a/jscomp/bsb/bsb_spec_set.ml +++ /dev/null @@ -1,80 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -(* TODO: sync up with {!Js_packages_info.module_system} *) -type format = Ext_module_system.t - -type spec = { format : format; in_source : bool; suffix : string } - -type t = spec list - -let cmp (s1 : spec) ({ format; in_source; suffix } : spec) = - let v = compare s1.format format in - if v <> 0 then v - else - let v = compare s1.in_source in_source in - if v <> 0 then v else compare s1.suffix suffix - -let empty = [] - -let rec insert lst piviot = - match lst with - | [] -> [ piviot ] - | x :: xs -> - let v = cmp piviot x in - if v = 0 then lst - else if v < 0 then piviot :: lst - else x :: insert xs piviot - -let add spec specs = - match specs with - | [] -> [ spec ] - | [ a ] -> - let v = cmp spec a in - if v < 0 then spec :: specs else if v = 0 then specs else [ a; spec ] - | [ a; b ] -> - let v = cmp spec a in - if v < 0 then spec :: specs - else if v = 0 then specs - else - let v1 = cmp spec b in - if v < 0 then [ a; spec; b ] - else if v1 = 0 then specs - else [ a; b; spec ] - | _ :: _ :: _ :: _ -> - (* unlikely to happen *) - insert specs spec - -let singleton x = [ x ] - -let rec fold f t acc = match t with [] -> acc | x :: xs -> fold f xs (f x acc) - -let rec iter f t = - match t with - | [] -> () - | x :: xs -> - f x; - iter f xs diff --git a/jscomp/bsb/bsb_spec_set.mli b/jscomp/bsb/bsb_spec_set.mli deleted file mode 100644 index 996475c..0000000 --- a/jscomp/bsb/bsb_spec_set.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type format = Ext_module_system.t - -type spec = { format : format; in_source : bool; suffix : string } - -type t = private spec list - -val empty : t - -val add : spec -> t -> t - -val singleton : spec -> t - -val fold : (spec -> 'a -> 'a) -> t -> 'a -> 'a - -val iter : (spec -> unit) -> t -> unit diff --git a/jscomp/bsb/bsb_unix.ml b/jscomp/bsb/bsb_unix.ml deleted file mode 100644 index e1c43c2..0000000 --- a/jscomp/bsb/bsb_unix.ml +++ /dev/null @@ -1,84 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type command = { cmd : string; cwd : string; args : string array } - -let log cmd = - Bsb_log.info "@{Entering@} %s @." cmd.cwd; - Bsb_log.info "@{Cmd:@} "; - Bsb_log.info_args cmd.args - -let command_fatal_error cmd eid = - Bsb_log.error "@{Failure:@} %s \nLocation: %s@." cmd.cmd cmd.cwd; - exit eid - -let run_command_execv_unix cmd : int = - match Unix.fork () with - | 0 -> - log cmd; - Unix.chdir cmd.cwd; - Unix.execv cmd.cmd cmd.args - | pid -> ( - match Unix.waitpid [] pid with - | _, process_status -> ( - match process_status with - | Unix.WEXITED eid -> eid - | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> - Bsb_log.error "@{Interrupted:@} %s@." cmd.cmd; - 2)) - -(** TODO: the args are not quoted, here - we are calling a very limited set of `bsb` commands, so that - we are safe -*) -let run_command_execv_win (cmd : command) = - let old_cwd = Unix.getcwd () in - log cmd; - Unix.chdir cmd.cwd; - let eid = - Sys.command - (String.concat Ext_string.single_space - (Filename.quote cmd.cmd :: (List.tl @@ Array.to_list cmd.args))) - in - Bsb_log.info "@{Leaving@} %s => %s @." cmd.cwd old_cwd; - Unix.chdir old_cwd; - eid - -(** it assume you have permissions, so always catch it to fail - gracefully -*) -let run_command_execv = - if Ext_sys.is_windows_or_cygwin then run_command_execv_win - else run_command_execv_unix - -let rec remove_dir_recursive dir = - match Sys.is_directory dir with - | true -> - let files = Sys.readdir dir in - for i = 0 to Array.length files - 1 do - remove_dir_recursive (Filename.concat dir (Array.unsafe_get files i)) - done; - Unix.rmdir dir - | false -> Sys.remove dir - | exception _ -> () diff --git a/jscomp/bsb/bsb_unix.mli b/jscomp/bsb/bsb_unix.mli deleted file mode 100644 index 1df6758..0000000 --- a/jscomp/bsb/bsb_unix.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type command = { cmd : string; cwd : string; args : string array } - -val command_fatal_error : command -> int -> unit - -val run_command_execv : command -> int - -val remove_dir_recursive : string -> unit diff --git a/jscomp/bsb/bsb_warning.ml b/jscomp/bsb/bsb_warning.ml deleted file mode 100644 index 179b77a..0000000 --- a/jscomp/bsb/bsb_warning.ml +++ /dev/null @@ -1,98 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type warning_error = - | Warn_error_false - (* default [false] to make our changes non-intrusive *) - | Warn_error_true - | Warn_error_number of string - -type t0 = { number : string option; error : warning_error } - -type nonrec t = t0 option - -let use_default = None - -let prepare_warning_concat ~(beg : bool) s = - let s = Ext_string.trim s in - if s = "" then s - else - match s.[0] with - | '0' .. '9' -> if beg then "-w +" ^ s else "+" ^ s - | 'a' .. 'z' -> if beg then "-w " ^ s else "-" ^ s - | 'A' .. 'Z' -> if beg then "-w " ^ s else "+" ^ s - | _ -> if beg then "-w " ^ s else s - -let to_merlin_string x = - "-w " ^ Bsc_warnings.defaults_w - ^ - let customize = - match x with - | Some { number = None } | None -> Ext_string.empty - | Some { number = Some x } -> prepare_warning_concat ~beg:false x - in - if customize = "" then customize else customize ^ "-40-42-61" -(* see #4406 to avoid user pass A - Sync up with {!Warnings.report} -*) - -let from_map (m : Ext_json_types.t Map_string.t) = - let number_opt = Map_string.find_opt m Bsb_build_schemas.number in - let error_opt = Map_string.find_opt m Bsb_build_schemas.error in - match (number_opt, error_opt) with - | None, None -> None - | _, _ -> - let error = - match error_opt with - | Some (True _) -> Warn_error_true - | Some (False _) -> Warn_error_false - | Some (Str { str }) -> Warn_error_number str - | Some x -> Bsb_exception.config_error x "expect true/false or string" - | None -> Warn_error_false - (* To make it less intrusive : warning error has to be enabled*) - in - let number = - match number_opt with - | Some (Str { str = number }) -> Some number - | None -> None - | Some x -> Bsb_exception.config_error x "expect a string" - in - Some { number; error } - -let to_bsb_string ~(package_kind : Bsb_package_kind.t) warning = - match package_kind with - | Toplevel | Pinned_dependency _ -> ( - match warning with - | None -> Ext_string.empty - | Some warning -> ( - (match warning.number with - | None -> Ext_string.empty - | Some x -> prepare_warning_concat ~beg:true x) - ^ - match warning.error with - | Warn_error_true -> " -warn-error A" - | Warn_error_number y -> " -warn-error " ^ y - | Warn_error_false -> Ext_string.empty)) - | Dependency _ -> " -w a" -(* TODO: this is the current default behavior *) diff --git a/jscomp/bsb/bsb_warning.mli b/jscomp/bsb/bsb_warning.mli deleted file mode 100644 index b04fb6f..0000000 --- a/jscomp/bsb/bsb_warning.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type warning_error = - | Warn_error_false - (* default [false] to make our changes non-intrusive *) - | Warn_error_true - | Warn_error_number of string - -type t0 = { number : string option; error : warning_error } - -type nonrec t = t0 option - - -val to_merlin_string : t -> string -(** Extra work is need to make merlin happy *) - -val from_map : Ext_json_types.t Map_string.t -> t - -val to_bsb_string : package_kind:Bsb_package_kind.t -> t -> string -(** [to_bsb_string not_dev warning] -*) - -val use_default : t diff --git a/jscomp/bsb/bsb_watcher_gen.ml b/jscomp/bsb/bsb_watcher_gen.ml deleted file mode 100644 index f72c183..0000000 --- a/jscomp/bsb/bsb_watcher_gen.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let kvs = Ext_json_noloc.kvs - -let arr = Ext_json_noloc.arr - -let str = Ext_json_noloc.str - -let generate_sourcedirs_meta ~name (res : Bsb_file_groups.t) = - let v = - kvs - [ - ("dirs", arr (Ext_array.of_list_map res.files (fun x -> str x.dir))); - ( "generated", - arr - (Array.of_list - @@ Ext_list.fold_left res.files [] (fun acc x -> - Ext_list.flat_map_append x.generators acc (fun x -> - Ext_list.map x.output str))) ); - ( "pkgs", - arr - (Array.of_list - (Bsb_pkg.to_list (fun pkg path -> - arr [| str (Bsb_pkg_types.to_string pkg); str path |]))) ); - ] - in - Ext_json_noloc.to_file name v diff --git a/jscomp/bsb/bsb_watcher_gen.mli b/jscomp/bsb/bsb_watcher_gen.mli deleted file mode 100644 index 6e2b989..0000000 --- a/jscomp/bsb/bsb_watcher_gen.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val generate_sourcedirs_meta : name:string -> Bsb_file_groups.t -> unit -(** This module try to generate some meta data so that - everytime [bsconfig.json] is reload, we can re-read - such meta data changes in the watcher. - - Another way of doing it is processing [bsconfig.json] - directly in [watcher] but that would - mean the duplication of logic in [bsb] and [bsb_watcher] -*) diff --git a/jscomp/bsb/bsb_world.ml b/jscomp/bsb/bsb_world.ml deleted file mode 100644 index 30b776c..0000000 --- a/jscomp/bsb/bsb_world.ml +++ /dev/null @@ -1,100 +0,0 @@ -(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ( // ) = Ext_path.combine -let vendor_ninja = Bsb_global_paths.vendor_ninja - -let make_world_deps cwd (config : Bsb_config_types.t option) - (ninja_args : string array) warn_as_error = - let package_specs, jsx, uncurried, pinned_dependencies = - match config with - | None -> - (* When this running bsb does not read rescript.json, - we will read such json file to know which [package-specs] - it wants - *) - Bsb_config_parse.deps_from_bsconfig () - | Some config -> - (config.package_specs, config.jsx, config.uncurried, config.pinned_dependencies) - in - let args = - if Ext_array.is_empty ninja_args then [| vendor_ninja |] - else Array.append [| vendor_ninja |] ninja_args - in - let lib_artifacts_dir = Bsb_config.lib_bs in - let queue = Bsb_build_util.walk_all_deps cwd ~pinned_dependencies in - (* let oc = open_out_bin ".deps.log" in - queue |> Queue.iter (fun ({top; proj_dir} : Bsb_build_util.package_context) -> - match top with - | Expect_none -> () - | Expect_name s -> - output_string oc s ; - output_string oc " : "; - output_string oc proj_dir; - output_string oc "\n" - ); - close_out oc ; *) - queue - |> Queue.iter (fun ({ top; proj_dir; is_pinned } : Bsb_build_util.package_context) -> - match top with - | Expect_none -> () - | Expect_name s -> - if is_pinned then print_endline ("Dependency pinned on " ^ s) - else print_endline ("Dependency on " ^ s); - let lib_bs_dir = proj_dir // lib_artifacts_dir in - Bsb_build_util.mkp lib_bs_dir; - let _config : _ option = - Bsb_ninja_regen.regenerate_ninja - ~package_kind: - (if is_pinned then Pinned_dependency { package_specs; jsx; uncurried } - else Dependency { package_specs; jsx; uncurried }) - ~per_proj_dir:proj_dir ~forced:false - ~warn_legacy_config:false - ~warn_as_error:(if is_pinned then warn_as_error else None) - in - let command = - { Bsb_unix.cmd = vendor_ninja; cwd = lib_bs_dir; args } - in - let eid = Bsb_unix.run_command_execv command in - if eid <> 0 then Bsb_unix.command_fatal_error command eid; - (* When ninja is not regenerated, ninja will still do the build, - still need reinstall check - Note that we can check if ninja print "no work to do", - then don't need reinstall more - *) - Bsb_log.info "@{Installation started@}@."; - let install_dir = proj_dir // "lib" // "ocaml" in - Bsb_build_util.mkp install_dir; - let install_command = - { - Bsb_unix.cmd = vendor_ninja; - cwd = install_dir; - args = - [| vendor_ninja; "-f"; ".." // "bs" // "install.ninja" |]; - } - in - let eid = Bsb_unix.run_command_execv install_command in - if eid <> 0 then Bsb_unix.command_fatal_error install_command eid; - Bsb_log.info "@{Installation finished@}@."); - print_endline "Dependency Finished" diff --git a/jscomp/bsb/bsb_world.mli b/jscomp/bsb/bsb_world.mli deleted file mode 100644 index 123f63e..0000000 --- a/jscomp/bsb/bsb_world.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val make_world_deps : - string -> Bsb_config_types.t option -> string array -> string option -> unit diff --git a/jscomp/bsb/data_format.md b/jscomp/bsb/data_format.md deleted file mode 100644 index a47acf0..0000000 --- a/jscomp/bsb/data_format.md +++ /dev/null @@ -1,24 +0,0 @@ - - -# format about lib/bs/.bsbuild - -This file (in binary) contains all file info needed in build. - -It is encoded in bsb_db_encode.ml and bsb_db_decode.ml, the format is optimized for performance in decoding where it is used most. - - -- The first 16 chars is digest of the following content - -The rest is encoding for each group (source code and test), in most cases, you have one group or two groups (one for lib one for test). - -Begining with a new line, the number of total groups (encoded in text format) are encoded. - - -For each group, it starts with a newline and the -number of modules (text format). - -The following are list of modules in sorted order (Ext_string.compare) separated by newline. - -The following are list of directories separated by tab character. - -The next is a fixed length for module description, its encoding is hard coded in Bsb_db_encode.make_encoding \ No newline at end of file diff --git a/jscomp/bsb/dune b/jscomp/bsb/dune deleted file mode 100644 index c4366af..0000000 --- a/jscomp/bsb/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name bsb) - (wrapped false) - (flags - (:standard -w -A)) - (libraries common ext str unix)) diff --git a/jscomp/bsb_exe/.ocamlformat b/jscomp/bsb_exe/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/bsb_exe/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/bsb_exe/dune b/jscomp/bsb_exe/dune deleted file mode 100644 index 491fbc0..0000000 --- a/jscomp/bsb_exe/dune +++ /dev/null @@ -1,13 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executable - (name rescript_main) - (public_name rescript) - (enabled_if - (<> %{profile} browser)) - (flags - (:standard -w +a-4-9-40-41-42-70)) - (libraries bsb common ext str unix)) diff --git a/jscomp/bsb_exe/rescript_main.ml b/jscomp/bsb_exe/rescript_main.ml deleted file mode 100644 index 3e29b33..0000000 --- a/jscomp/bsb_exe/rescript_main.ml +++ /dev/null @@ -1,252 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let () = Bsb_log.setup () - -let separator = "--" - -let no_deps_mode = ref false - -let do_install = ref false - -let warning_as_error = ref None - -let force_regenerate = ref false - -type spec = Bsb_arg.spec - -let call_spec f : spec = Unit (Unit_call f) - -let unit_set_spec b : spec = Unit (Unit_set b) - -let string_set_spec s : spec = String (String_set s) - -let string_call f: spec = String (String_call f) - -let failed_annon ~rev_args = - match rev_args with - | x :: _ -> Bsb_arg.bad_arg ("Don't know what to do with " ^ x) - | _ -> () - -(*Note that [keepdepfile] only makes sense when combined with [deps] for optimization*) - -(** Invariant: it has to be the last command of [bsb] *) -let exec_command_then_exit (type t) (command : string) : t = - Bsb_log.info "@{CMD:@} %s@." command; - exit (Sys.command command) - -(* Execute the underlying ninja build call, then exit (as opposed to keep watching) *) -let ninja_command_exit (type t) (ninja_args : string array) : t = - let ninja_args_len = Array.length ninja_args in - let lib_artifacts_dir = Bsb_config.lib_bs in - if Ext_sys.is_windows_or_cygwin then - let path_ninja = Filename.quote Bsb_global_paths.vendor_ninja in - exec_command_then_exit - (if ninja_args_len = 0 then - Ext_string.inter3 path_ninja "-C" lib_artifacts_dir - else - let args = - Array.append [| path_ninja; "-C"; lib_artifacts_dir |] ninja_args - in - Ext_string.concat_array Ext_string.single_space args) - else - let ninja_common_args = [| "ninja.exe"; "-C"; lib_artifacts_dir |] in - let args = - if ninja_args_len = 0 then ninja_common_args - else Array.append ninja_common_args ninja_args - in - Bsb_log.info_args args; - Unix.execvp Bsb_global_paths.vendor_ninja args - -(** - Cache files generated: - - .bsdircache in project root dir - - .bsdeps in builddir - - What will happen, some flags are really not good - ninja -C _build -*) -let clean_usage = - "Usage: rescript clean \n\n\ - `rescript clean` cleans build artifacts\n" - -let build_usage = - "Usage: rescript build -- \n\n\ - `rescript build` builds the project with dependencies\n\n\ - `rescript build -- -h` for Ninja options (internal usage only; unstable)\n" - -let install_target () = - let ( // ) = Filename.concat in - let vendor_ninja = Bsb_global_paths.vendor_ninja in - let install_dir = "lib" // "ocaml" in - Bsb_build_util.mkp install_dir; - let install_command = - { - Bsb_unix.cmd = vendor_ninja; - cwd = install_dir; - args = [| vendor_ninja; "-f"; ".." // "bs" // "install.ninja" |]; - } - in - let eid = Bsb_unix.run_command_execv install_command in - if eid <> 0 then Bsb_unix.command_fatal_error install_command eid - -let build_subcommand ~start argv argv_len = - let i = Ext_array.rfind_with_index argv Ext_string.equal separator in - - Bsb_arg.parse_exn ~usage:build_usage ~start - ?finish:(if i < 0 then None else Some i) - ~argv - [| - ("-w", unit_set_spec (ref false), "Watch mode"); - ( "-ws", - string_set_spec (ref ""), - "[host]:port set up host & port for WebSocket build notifications" ); - ("-verbose", call_spec Bsb_log.verbose, "Set the output to be verbose"); - ("-with-deps", unit_set_spec (ref true), "*deprecated* This is the default behavior now. This option will be removed in a future release"); - ( "-install", - unit_set_spec do_install, - "*internal* Install public interface files for dependencies" ); - (* This should be put in a subcommand - previously it works with the implication `bsb && bsb -install` - *) - ( "-regen", - unit_set_spec force_regenerate, - "*internal* \n\ - Always regenerate build.ninja no matter bsconfig.json is changed or \ - not" ); - ("-no-deps", unit_set_spec no_deps_mode, "*internal* Needed for watcher to build without dependencies on file change"); - ("-warn-error", string_call (fun s -> warning_as_error := Some s), "Warning numbers and whether to turn them into errors, e.g., \"+8+32-102\"") - |] - failed_annon; - - let ninja_args = - if i < 0 then [||] else Array.sub argv (i + 1) (argv_len - i - 1) - in - match ninja_args with - | [| "-h" |] -> ninja_command_exit ninja_args - | _ -> - let warn_as_error = match !warning_as_error with - | Some s -> - let () = try Warnings.parse_options true s with Arg.Bad msg -> Bsb_arg.bad_arg (msg ^ "\n") in - Some s - | None -> None in - let config_opt = - Bsb_ninja_regen.regenerate_ninja - ~package_kind:Toplevel - ~per_proj_dir:Bsb_global_paths.cwd - ~forced:!force_regenerate - ~warn_legacy_config:true - ~warn_as_error - in - if not !no_deps_mode then Bsb_world.make_world_deps Bsb_global_paths.cwd config_opt ninja_args warn_as_error; - if !do_install then install_target (); - ninja_command_exit ninja_args - -let clean_subcommand ~start argv = - Bsb_arg.parse_exn ~usage:clean_usage ~start ~argv - [| - ("-verbose", call_spec Bsb_log.verbose, "Set the output to be verbose"); - ( "-with-deps", - unit_set_spec (ref true), - "*deprecated* This is the default behavior now. This option will be removed in a future release" ); - |] - failed_annon; - Bsb_clean.clean_bs_deps Bsb_global_paths.cwd; - Bsb_clean.clean_self Bsb_global_paths.cwd - -let list_files = ref false - -let info_subcommand ~start argv = - Bsb_arg.parse_exn ~usage:"query the project" ~start ~argv - [| ("-list-files", unit_set_spec list_files, "list source files") |] - (fun ~rev_args -> - (match rev_args with - | x :: _ -> raise (Bsb_arg.Bad ("Don't know what to do with " ^ x)) - | [] -> ()); - if !list_files then - match - Bsb_ninja_regen.regenerate_ninja - ~package_kind:Toplevel - ~per_proj_dir:Bsb_global_paths.cwd - ~forced:true - ~warn_legacy_config:true - ~warn_as_error:None - with - | None -> assert false - | Some { file_groups = { files } } -> - Ext_list.iter files (fun { sources } -> - Map_string.iter sources - (fun _ { info; syntax_kind; name_sans_extension } -> - let extensions = - match (syntax_kind, info) with - | _, Intf -> assert false - | Ml, Impl -> [ ".ml" ] - | Ml, Impl_intf -> [ ".ml"; ".mli" ] - | Res, Impl -> [ ".res" ] - | Res, Impl_intf -> [ ".res"; ".resi" ] - in - Ext_list.iter extensions (fun x -> - print_endline (name_sans_extension ^ x))))) - -(* see discussion #929, if we catch the exception, we don't have stacktrace... *) -let () = - let argv = Sys.argv in - let argv_len = Array.length argv in - try - if argv_len = 1 then ( - (* specialize this path which is used in watcher *) - let config_opt = - Bsb_ninja_regen.regenerate_ninja - ~package_kind:Toplevel - ~per_proj_dir:Bsb_global_paths.cwd - ~forced:false - ~warn_legacy_config:true - ~warn_as_error:None - in - Bsb_world.make_world_deps Bsb_global_paths.cwd config_opt [||] None; - ninja_command_exit [||]) - else - match argv.(1) with - | "build" -> build_subcommand ~start:2 argv argv_len - | "clean" -> clean_subcommand ~start:2 argv - | "info" -> - (* internal *) - info_subcommand ~start:2 argv - | first_arg -> - prerr_endline @@ "Unknown subcommand or flags: " ^ first_arg; - exit 1 - with - | Bsb_exception.Error e -> - Bsb_exception.print Format.err_formatter e; - Format.pp_print_newline Format.err_formatter (); - exit 2 - | Ext_json_parse.Error (start, _, e) -> - Format.fprintf Format.err_formatter - "File %S, line %d\n@{Error:@} %a@." start.pos_fname - start.pos_lnum Ext_json_parse.report_error e; - exit 2 - | Bsb_arg.Bad s | Sys_error s -> - Format.fprintf Format.err_formatter "@{Error:@} %s" s; - exit 2 - | e -> Ext_pervasives.reraise e diff --git a/jscomp/bsb_exe/rescript_main.mli b/jscomp/bsb_exe/rescript_main.mli deleted file mode 100644 index aa4fd33..0000000 --- a/jscomp/bsb_exe/rescript_main.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) diff --git a/jscomp/bsb_helper/.ocamlformat b/jscomp/bsb_helper/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/bsb_helper/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/bsb_helper/bsb_db_decode.ml b/jscomp/bsb_helper/bsb_db_decode.ml deleted file mode 100644 index f3f1d6c..0000000 --- a/jscomp/bsb_helper/bsb_db_decode.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* Copyright (C) 2019 - Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let bsbuild_cache = Literals.bsbuild_cache - -type group = - | Dummy - | Group of { - modules : string array; - dir_length : int; - dir_info_offset : int; - module_info_offset : int; - } - -type t = { - lib : group; - dev : group; - content : string; (* string is whole content*) -} - -type cursor = int ref - -(*TODO: special case when module_count is zero *) -let rec decode (x : string) : t = - let (offset : cursor) = ref 0 in - let lib = decode_single x offset in - let dev = decode_single x offset in - { lib; dev; content = x } - -and decode_single (x : string) (offset : cursor) : group = - let module_number = Ext_pervasives.parse_nat_of_string x offset in - incr offset; - if module_number <> 0 then ( - let modules = decode_modules x offset module_number in - let dir_info_offset = !offset in - let module_info_offset = String.index_from x dir_info_offset '\n' + 1 in - let dir_length = Char.code x.[module_info_offset] - 48 (* Char.code '0'*) in - offset := module_info_offset + 1 + (dir_length * module_number) + 1; - Group { modules; dir_info_offset; module_info_offset; dir_length }) - else Dummy - -and decode_modules (x : string) (offset : cursor) module_number : string array = - let result = Array.make module_number "" in - let last = ref !offset in - let cur = ref !offset in - let tasks = ref 0 in - while !tasks <> module_number do - if String.unsafe_get x !cur = '\n' then ( - let offs = !last in - let len = !cur - !last in - Array.unsafe_set result !tasks (Ext_string.unsafe_sub x offs len); - incr tasks; - last := !cur + 1); - incr cur - done; - offset := !cur; - result - -(* TODO: shall we check the consistency of digest *) -let read_build_cache ~dir : t = - let all_content = Ext_io.load_file (Filename.concat dir bsbuild_cache) in - decode all_content - -type module_info = { case : bool; (* which is Bsb_db.case*) dir_name : string } - -let find_opt ({ content = whole } as db : t) lib (key : string) : - module_info option = - match if lib then db.lib else db.dev with - | Dummy -> None - | Group ({ modules } as group) -> ( - let i = Ext_string_array.find_sorted modules key in - match i with - | None -> None - | Some count -> - let encode_len = group.dir_length in - let index = - Ext_string.get_1_2_3_4 whole - ~off:(group.module_info_offset + 1 + (count * encode_len)) - encode_len - in - let case = not (index mod 2 = 0) in - let ith = index lsr 1 in - let dir_name_start = - if ith = 0 then group.dir_info_offset - else Ext_string.index_count whole group.dir_info_offset '\t' ith + 1 - in - let dir_name_finish = String.index_from whole dir_name_start '\t' in - Some - { - case; - dir_name = - String.sub whole dir_name_start - (dir_name_finish - dir_name_start); - }) - -let find db dependent_module is_not_lib_dir = - let opt = find_opt db true dependent_module in - match opt with - | Some _ -> opt - | None -> if is_not_lib_dir then find_opt db false dependent_module else None diff --git a/jscomp/bsb_helper/bsb_db_decode.mli b/jscomp/bsb_helper/bsb_db_decode.mli deleted file mode 100644 index b6e2ccf..0000000 --- a/jscomp/bsb_helper/bsb_db_decode.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2019 - Present Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type group = private - | Dummy - | Group of { - modules : string array; - dir_length : int; - dir_info_offset : int; - module_info_offset : int; - } - -type t = { - lib : group; - dev : group; - content : string; (* string is whole content*) -} - -val read_build_cache : dir:string -> t - -type module_info = { case : bool; (* Bsb_db.case*) dir_name : string } - -val find : - t -> - (* contains global info *) - string -> - (* module name *) - bool -> - (* more likely to be zero *) - module_info option - -val decode : string -> t diff --git a/jscomp/bsb_helper/bsb_helper_depfile_gen.ml b/jscomp/bsb_helper/bsb_helper_depfile_gen.ml deleted file mode 100644 index f91854e..0000000 --- a/jscomp/bsb_helper/bsb_helper_depfile_gen.ml +++ /dev/null @@ -1,172 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let dep_lit = " :" - -let write_buf name buf = - let oc = open_out_bin name in - Ext_buffer.output_buffer oc buf; - close_out oc - -(* should be good for small file *) -let load_file name (buf : Ext_buffer.t) : unit = - let len = Ext_buffer.length buf in - let ic = open_in_bin name in - let n = in_channel_length ic in - if n <> len then ( - close_in ic; - write_buf name buf) - else - let holder = really_input_string ic n in - close_in ic; - if Ext_buffer.not_equal buf holder then write_buf name buf - -let write_file name (buf : Ext_buffer.t) = - if Sys.file_exists name then load_file name buf else write_buf name buf - -(* return an non-decoded string *) -let extract_dep_raw_string (fn : string) : string = - let ic = open_in_bin fn in - let size = input_binary_int ic in - let s = really_input_string ic size in - close_in ic; - s - -(* Make sure it is the same as {!Binary_ast.magic_sep_char}*) -let magic_sep_char = '\n' - -let deps_of_channel (ic : in_channel) : string list = - let size = input_binary_int ic in - let s = really_input_string ic size in - let rec aux (s : string) acc (offset : int) size : string list = - if offset < size then - let next_tab = String.index_from s offset magic_sep_char in - aux s (String.sub s offset (next_tab - offset) :: acc) (next_tab + 1) size - else acc - in - aux s [] 1 size - -(** Please refer to {!Binary_ast} for encoding format, we move it here - mostly for cutting the dependency so that [bsb_helper.exe] does - not depend on compler-libs -*) -(* let read_deps (fn : string) : string list = - let ic = open_in_bin fn in - let v = deps_of_channel ic in - close_in ic; - v -*) - -let output_file (buf : Ext_buffer.t) source namespace = - Ext_buffer.add_string buf (Ext_namespace_encode.make ?ns:namespace source) - -(** for rescript artifacts - [lhs_suffix] is [.cmj] - [rhs_suffix] - is [.cmj] if it has [ml] (in this case does not care about mli or not) - is [.cmi] if it has [mli] -*) -let oc_cmi buf namespace source = - Ext_buffer.add_char buf ' '; - output_file buf source namespace; - Ext_buffer.add_string buf Literals.suffix_cmi - -(* For cases with self cycle - e.g, in b.ml - {[ - include B - ]} - When ns is not turned on, it makes sense that b may come from third party package. - Hoever, this case is wont supported. - It complicates when it has interface file or not. - - if it has interface file, the current interface will have priority, failed to build? - - if it does not have interface file, the build will not open this module at all(-bs-read-cmi) - - When ns is turned on, `B` is interprted as `Ns-B` which is a cyclic dependency, - it can be errored out earlier - - #5368: It turns out there are many false positives on detecting self-cycles (see: `jscomp/build_tests/zerocycle`) - To properly solve this, we would need to `jscomp/ml/depend.ml` because - cmi and cmj is broken in the first place (same problem as in ocaml/ocaml#4618). - So we will just ignore the self-cycles. Even if there is indeed a self-cycle, it should fail to compile anyway. -*) -let oc_deps (ast_file : string) (is_dev : bool) (db : Bsb_db_decode.t) - (namespace : string option) (buf : Ext_buffer.t) (kind : [ `impl | `intf ]) - : unit = - (* TODO: move namespace upper, it is better to resolve ealier *) - let cur_module_name = Ext_filename.module_name ast_file in - let at_most_once : unit lazy_t = - lazy - (output_file buf (Ext_filename.chop_extension_maybe ast_file) namespace; - Ext_buffer.add_string buf - (if kind = `impl then Literals.suffix_cmj else Literals.suffix_cmi); - (* print the source *) - Ext_buffer.add_string buf dep_lit) - in - (match namespace with - | None -> () - | Some ns -> - Lazy.force at_most_once; - Ext_buffer.add_char buf ' '; - Ext_buffer.add_string buf ns; - Ext_buffer.add_string buf Literals.suffix_cmi (* always cmi *)); - (* TODO: moved into static files*) - let s = extract_dep_raw_string ast_file in - let offset = ref 1 in - let size = String.length s in - while !offset < size do - let next_tab = String.index_from s !offset magic_sep_char in - let dependent_module = String.sub s !offset (next_tab - !offset) in - (if dependent_module = cur_module_name then - (*prerr_endline ("FAILED: " ^ cur_module_name ^ " has a self cycle"); - exit 2*) - (* #5368 ignore self dependencies *) () - else - match Bsb_db_decode.find db dependent_module is_dev with - | None -> () - | Some { dir_name; case } -> - Lazy.force at_most_once; - let source = - Filename.concat dir_name - (if case then dependent_module - else Ext_string.uncapitalize_ascii dependent_module) - in - Ext_buffer.add_char buf ' '; - if kind = `impl then ( - output_file buf source namespace; - Ext_buffer.add_string buf Literals.suffix_cmj); - (* #3260 cmj changes does not imply cmi change anymore *) - oc_cmi buf namespace source); - offset := next_tab + 1 - done; - if Lazy.is_val at_most_once then Ext_buffer.add_char buf '\n' - -let emit_d (is_dev : bool) (namespace : string option) (mlast : string) - (mliast : string) = - let data = Bsb_db_decode.read_build_cache ~dir:Filename.current_dir_name in - let buf = Ext_buffer.create 2048 in - let filename = Ext_filename.new_extension mlast Literals.suffix_d in - oc_deps mlast is_dev data namespace buf `impl; - if mliast <> "" then oc_deps mliast is_dev data namespace buf `intf; - write_file filename buf diff --git a/jscomp/bsb_helper/bsb_helper_depfile_gen.mli b/jscomp/bsb_helper/bsb_helper_depfile_gen.mli deleted file mode 100644 index 840ccb7..0000000 --- a/jscomp/bsb_helper/bsb_helper_depfile_gen.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val deps_of_channel : in_channel -> string list -(** [deps_of_channel ic] - given an input_channel dumps all modules it depend on, only used for debugging -*) - -val emit_d : - bool -> - string option -> - string -> - string -> - (* empty string means no mliast *) - unit diff --git a/jscomp/bsb_helper/bsb_helper_extract.ml b/jscomp/bsb_helper/bsb_helper_extract.ml deleted file mode 100644 index 91882e0..0000000 --- a/jscomp/bsb_helper/bsb_helper_extract.ml +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let read_dependency_graph_from_mlast_file fn = - let ic = open_in_bin fn in - try - let dep_size = input_binary_int ic in - let dep_data = really_input_string ic dep_size in - let splitted_data = Ext_string.split dep_data '\n' in - let set = Set_string.of_list splitted_data in - close_in ic; - set - with exn -> - close_in ic; - raise exn diff --git a/jscomp/bsb_helper/bsb_helper_extract.mli b/jscomp/bsb_helper/bsb_helper_extract.mli deleted file mode 100644 index 5538fa0..0000000 --- a/jscomp/bsb_helper/bsb_helper_extract.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* This reads the header part of the mlast file, which simply encodes a set that indicates all of the deps of the current library. *) -val read_dependency_graph_from_mlast_file : string -> Set_string.t diff --git a/jscomp/bsb_helper/dune b/jscomp/bsb_helper/dune deleted file mode 100644 index ba6da72..0000000 --- a/jscomp/bsb_helper/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name bsb_helper) - (wrapped false) - (flags - (:standard -w -A)) - (libraries ext)) diff --git a/jscomp/bsb_helper_exe/.ocamlformat b/jscomp/bsb_helper_exe/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/bsb_helper_exe/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/bsb_helper_exe/bsb_helper_main.ml b/jscomp/bsb_helper_exe/bsb_helper_main.ml deleted file mode 100644 index adbbba6..0000000 --- a/jscomp/bsb_helper_exe/bsb_helper_main.ml +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let () = - let namespace = ref None in - let dev_group = ref false in - let argv = Sys.argv in - let l = Array.length argv in - let current = ref 1 in - let rev_list = ref [] in - while !current < l do - let s = argv.(!current) in - incr current; - if s <> "" && s.[0] = '-' then ( - match s with - | "-hash" -> incr current - | "-bs-ns" -> - let ns = argv.(!current) in - namespace := Some ns; - incr current - | "-g" -> dev_group := true - | s -> - prerr_endline ("unknown options: " ^ s); - prerr_endline "available options: -hash [hash]; -bs-ns [ns]; -g"; - exit 2) - else rev_list := s :: !rev_list - done; - match !rev_list with - | [ x ] -> Bsb_helper_depfile_gen.emit_d !dev_group !namespace x "" - | [ y; x ] (* reverse order *) -> - Bsb_helper_depfile_gen.emit_d !dev_group !namespace x y - | _ -> () diff --git a/jscomp/bsb_helper_exe/bsb_helper_main.mli b/jscomp/bsb_helper_exe/bsb_helper_main.mli deleted file mode 100644 index f30aaad..0000000 --- a/jscomp/bsb_helper_exe/bsb_helper_main.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Used to generate .d file, for example - {[ - bsb_helper.exe -g 0 -MD src/hi/hello.ml - ]} - It will read the cache file and generate the corresponding - [.d] file. This [.d] file will be used as attribute [depfile] - whether we use namespace or not, the filename of [.mlast], [.d] - should be kept the same, we only need change the name of [.cm*] - and the contents of filename in [.d] -*) diff --git a/jscomp/bsb_helper_exe/dune b/jscomp/bsb_helper_exe/dune deleted file mode 100644 index 30e1846..0000000 --- a/jscomp/bsb_helper_exe/dune +++ /dev/null @@ -1,13 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executable - (name bsb_helper_main) - (public_name bsb_helper) - (enabled_if - (<> %{profile} browser)) - (flags - (:standard -w -A)) - (libraries bsb_helper)) diff --git a/jscomp/bsc/.ocamlformat b/jscomp/bsc/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/bsc/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/bsc/dune b/jscomp/bsc/dune deleted file mode 100644 index a1ff7f8..0000000 --- a/jscomp/bsc/dune +++ /dev/null @@ -1,11 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executable - (name rescript_compiler_main) - (public_name bsc) - (flags - (:standard -w -A)) - (libraries common core depends gentype js_parser syntax)) diff --git a/jscomp/bsc/rescript_compiler_main.ml b/jscomp/bsc/rescript_compiler_main.ml deleted file mode 100644 index 40b85d7..0000000 --- a/jscomp/bsc/rescript_compiler_main.ml +++ /dev/null @@ -1,545 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) - - -let set_abs_input_name sourcefile = - let sourcefile = - if !Location.absname && Filename.is_relative sourcefile then - Ext_path.absolute_cwd_path sourcefile - else sourcefile in - Location.set_input_name sourcefile; - sourcefile - -type syntax_kind = [`ml | `rescript] -let setup_compiler_printer (syntax_kind : [ syntax_kind | `default])= - (match syntax_kind with - | `default -> () - | #syntax_kind as k -> Config.syntax_kind := k); - let syntax_kind = !Config.syntax_kind in - if syntax_kind = `rescript then begin - Lazy.force Res_outcome_printer.setup - end - - - -let setup_runtime_path path = - let u0 = Filename.dirname path in - let std = Filename.basename path in - let _path = Filename.dirname u0 in - let rescript = Filename.basename u0 in - (match rescript.[0] with - | '@' -> (* scoped package *) - Bs_version.package_name := rescript ^ "/" ^ std; - | _ -> Bs_version.package_name := std - | exception _ -> - Bs_version.package_name := std); - Js_config.customize_runtime := Some path - - -let process_file sourcefile ?(kind ) ppf = - (* This is a better default then "", it will be changed later - The {!Location.input_name} relies on that we write the binary ast - properly - *) - let uncurried = !Config.uncurried in - let kind = - match kind with - | None -> Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe sourcefile) - | Some kind -> kind in - let res = match kind with - | Ml -> - let sourcefile = set_abs_input_name sourcefile in - setup_compiler_printer `ml; - Js_implementation.implementation - ~parser:Pparse_driver.parse_implementation - ppf sourcefile - | Mli -> - let sourcefile = set_abs_input_name sourcefile in - setup_compiler_printer `ml; - Js_implementation.interface - ~parser:Pparse_driver.parse_interface - ppf sourcefile - | Res -> - let sourcefile = set_abs_input_name sourcefile in - setup_compiler_printer `rescript; - Js_implementation.implementation - ~parser:(Res_driver.parse_implementation ~ignoreParseErrors:!Clflags.ignore_parse_errors) - ppf sourcefile - | Resi -> - let sourcefile = set_abs_input_name sourcefile in - setup_compiler_printer `rescript; - Js_implementation.interface - ~parser:(Res_driver.parse_interface ~ignoreParseErrors:!Clflags.ignore_parse_errors) - ppf sourcefile - | Intf_ast - -> - Js_implementation.interface_mliast ppf sourcefile - setup_compiler_printer - (* The printer setup is done in the runtime depends on - the content of ast - *) - | Impl_ast - -> - Js_implementation.implementation_mlast ppf sourcefile - setup_compiler_printer - | Mlmap - -> - Location.set_input_name sourcefile; - Js_implementation.implementation_map ppf sourcefile - | Cmi - -> - setup_compiler_printer `default; - let cmi_sign = (Cmi_format.read_cmi sourcefile).cmi_sign in - Printtyp.signature Format.std_formatter cmi_sign ; - Format.pp_print_newline Format.std_formatter () - | Unknown -> - Bsc_args.bad_arg ("don't know what to do with " ^ sourcefile) - in - Config.uncurried := uncurried; - res - -let reprint_source_file sourcefile = - let uncurried = !Config.uncurried in - let kind = Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe sourcefile) in - let sourcefile = set_abs_input_name sourcefile in - let res = match kind with - | Res -> - let parseResult = - Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename:sourcefile - in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - exit 1 - ); - Res_compmisc.init_path (); - parseResult.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Ml - |> Ppx_entry.rewrite_implementation - |> Res_printer.printImplementation ~width:100 ~comments:parseResult.comments - |> print_endline - | Resi -> - let parseResult = - Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename:sourcefile - in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - exit 1 - ); - Res_compmisc.init_path (); - parseResult.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name Mli - |> Ppx_entry.rewrite_signature - |> Res_printer.printInterface ~width:100 ~comments:parseResult.comments - |> print_endline - | _ - -> - print_endline ("Invalid input for reprinting ReScript source. Must be a ReScript file: " ^ sourcefile); - exit 2 - in - Config.uncurried := uncurried; - res - -let usage = "Usage: bsc \nOptions are:" - -let ppf = Format.err_formatter - -(* Error messages to standard error formatter *) - -let anonymous ~(rev_args : string list) = - if !Js_config.as_ppx then - match rev_args with - | [output; input] -> - Ppx_apply.apply_lazy - ~source:input - ~target:output - Ppx_entry.rewrite_implementation - Ppx_entry.rewrite_signature - | _ -> Bsc_args.bad_arg "Wrong format when use -as-ppx" - else - begin - match rev_args with - | [filename] -> - process_file filename ppf - | [] -> () - | _ -> - if !Js_config.syntax_only then - Ext_list.rev_iter rev_args (fun filename -> - begin - Clflags.reset_dump_state (); - Warnings.reset (); - process_file filename ppf - end ) - else - Bsc_args.bad_arg "can not handle multiple files" - end - -(** used by -impl -intf *) -let impl filename = - Js_config.js_stdout := false; - process_file filename ~kind:Ml ppf ;; -let intf filename = - Js_config.js_stdout := false ; - process_file filename ~kind:Mli ppf;; - - -let format_file input = - let ext = Ext_file_extensions.classify_input (Ext_filename.get_extension_maybe input) in - let syntax = - match ext with - | Ml | Mli -> `ml - | Res | Resi -> `res - | _ -> Bsc_args.bad_arg ("don't know what to do with " ^ input) in - let formatted = Res_multi_printer.print ~ignoreParseErrors:!Clflags.ignore_parse_errors syntax ~input in - match !Clflags.output_name with - | None -> - output_string stdout formatted - | Some fname -> - Ext_io.write_file fname formatted - -let set_color_option option = - match Clflags.parse_color_setting option with - | None -> () - | Some setting -> Clflags.color := Some setting - -let eval (s : string) ~suffix = - let tmpfile = Filename.temp_file "eval" suffix in - Ext_io.write_file tmpfile s; - anonymous ~rev_args:[tmpfile]; - if not !Clflags.verbose then try Sys.remove tmpfile with _ -> () - - -(* let (//) = Filename.concat *) - - - - -module Pp = Rescript_cpp -let define_variable s = - match Ext_string.split ~keep_empty:true s '=' with - | [key; v] -> - if not (Pp.define_key_value key v) then - Bsc_args.bad_arg ("illegal definition: " ^ s) - | _ -> Bsc_args.bad_arg ("illegal definition: " ^ s) - -let print_standard_library () = - let (//) = Filename.concat in - let standard_library = - Filename.dirname Sys.executable_name - // Filename.parent_dir_name // "lib"// "ocaml" in - print_string standard_library; print_newline(); - exit 0 - -let bs_version_string = - "ReScript " ^ Bs_version.version - -let print_version_string () = - print_endline bs_version_string; - exit 0 - -let [@inline] set s : Bsc_args.spec = Unit (Unit_set s) -let [@inline] clear s : Bsc_args.spec = Unit (Unit_clear s) -let [@inline] string_call s : Bsc_args.spec = - String (String_call s) -let [@inline] string_optional_set s : Bsc_args.spec = - String (String_optional_set s) - -let [@inline] unit_call s : Bsc_args.spec = - Unit (Unit_call s) -let [@inline] string_list_add s : Bsc_args.spec = - String (String_list_add s) - -(* mostly common used to list in the beginning to make search fast -*) -let buckle_script_flags : (string * Bsc_args.spec * string) array = - [| - "-I", string_list_add Clflags.include_dirs , - "*internal* Add to the list of include directories" ; - - "-w", string_call (Warnings.parse_options false), - " Enable or disable warnings according to :\n\ - + enable warnings in \n\ - - disable warnings in \n\ - @ enable warnings in and treat them as errors\n\ - can be:\n\ - a single warning number\n\ - .. a range of consecutive warning numbers\n\ - default setting is " ^ Bsc_warnings.defaults_w; - - - "-o", string_optional_set Clflags.output_name, - "*internal* set output file name to "; - - "-bs-read-cmi", unit_call (fun _ -> Clflags.assume_no_mli := Mli_exists), - "*internal* Assume mli always exist "; - - "-ppx", string_list_add Clflags.all_ppx, - "*internal* Pipe abstract syntax trees through preprocessor "; - - "-open", string_list_add Clflags.open_modules, - "*internal* Opens the module before typing"; - - "-bs-jsx", string_call (fun i -> - (if i <> "3" && i <> "4" then Bsc_args.bad_arg (" Not supported jsx version : " ^ i)); - Js_config.jsx_version := Js_config.jsx_version_of_int @@ int_of_string i), - "*internal* Set jsx version"; - - "-bs-jsx-module", string_call (fun i -> - let isGeneric = match i |> String.lowercase_ascii with - | "react" -> false - | _ -> true in - Js_config.jsx_module := Js_config.jsx_module_of_string i; - if isGeneric then ( - Js_config.jsx_mode := Automatic; - Js_config.jsx_version := Some Jsx_v4 - )), - "*internal* Set jsx module"; - - "-bs-jsx-mode", string_call (fun i -> - (if i <> "classic" && i <> "automatic" then Bsc_args.bad_arg (" Not supported jsx-mode : " ^ i)); - Js_config.jsx_mode := Js_config.jsx_mode_of_string i), - "*internal* Set jsx mode"; - - "-bs-package-output", string_call Js_packages_state.update_npm_package_path, - "*internal* Set npm-output-path: [opt_module]:path, for example: 'lib/cjs', 'amdjs:lib/amdjs', 'es6:lib/es6' "; - - "-bs-ast", unit_call(fun _ -> Js_config.binary_ast := true; Js_config.syntax_only := true), - "*internal* Generate binary .mli_ast and ml_ast and stop"; - - "-bs-syntax-only", set Js_config.syntax_only, - "*internal* Only check syntax"; - - "-bs-g", unit_call (fun _ -> Js_config.debug := true; Pp.replace_directive_bool "DEBUG" true), - "Debug mode"; - - "-bs-v", string_call ignore, - "*internal* version check to force a rebuild"; - "-bs-package-name", string_call Js_packages_state.set_package_name, - "*internal* Set package name, useful when you want to produce npm packages"; - - "-bs-ns", string_call Js_packages_state.set_package_map, - "*internal* Set package map, not only set package name but also use it as a namespace" ; - - "-as-ppx", set Js_config.as_ppx, - "*internal*As ppx for editor integration"; - "-as-pp", unit_call(fun _ -> Js_config.as_pp := true ; Js_config.syntax_only := true), - "*internal*As pp to interact with native tools"; - "-no-alias-deps", set Clflags.transparent_modules, - "*internal*Do not record dependencies for module aliases"; - - "-bs-gentype", set Clflags.bs_gentype, - "*internal* Pass gentype command"; - - (******************************************************************************) - - "-bs-super-errors", unit_call (fun _ -> ()), - "*deprecated* Better error message combined with other tools "; - - "-unboxed-types", set Clflags.unboxed_types, - "*internal* Unannotated unboxable types will be unboxed"; - - "-bs-ml-out", unit_call (fun _ -> Config.syntax_kind := `ml), - "*internal* Print compiler output in ML syntax"; - - "-bs-D", string_call define_variable, - "Define conditional variable e.g, -D DEBUG=true"; - - "-bs-unsafe-empty-array", set Config.unsafe_empty_array, - "*internal* Allow [||] to be polymorphic"; - - "-nostdlib", set Js_config.no_stdlib, - "*internal* Don't use stdlib"; - - "-color", string_call set_color_option, - "*internal* Enable or disable colors in compiler messages\n\ - The following settings are supported:\n\ - auto use heuristics to enable colors only if supported\n\ - always enable colors\n\ - never disable colors\n\ - The default setting is 'always'\n\ - The current heuristic for 'auto'\n\ - checks that the TERM environment variable exists and is\n\ - not empty or \"dumb\", and that isatty(stderr) holds."; - - "-bs-list-conditionals", unit_call (fun () -> Pp.list_variables Format.err_formatter), - "*internal* List existing conditional variables"; - - "-bs-eval", string_call (fun s -> eval s ~suffix:Literals.suffix_ml), - "*internal* (experimental) set the string to be evaluated in OCaml syntax"; - - "-e", string_call (fun s -> eval s ~suffix:Literals.suffix_res), - "(experimental) set the string to be evaluated in ReScript syntax"; - - "-bs-cmi-only", set Js_config.cmi_only, - "*internal* Stop after generating cmi file"; - - "-bs-cmi", set Js_config.force_cmi, - "*internal* Not using cached cmi, always generate cmi"; - - "-bs-cmj", set Js_config.force_cmj, - "*internal* Not using cached cmj, always generate cmj"; - - "-bs-no-version-header", set Js_config.no_version_header, - "*internal*Don't print version header"; - - "-bs-no-builtin-ppx", set Js_config.no_builtin_ppx, - "*internal* Disable built-in ppx"; - - "-bs-cross-module-opt", set Js_config.cross_module_inline, - "*internal* Enable cross module inlining(experimental), default(false)"; - - "-bs-no-cross-module-opt", clear Js_config.cross_module_inline, - "*internal* Disable cross module inlining(experimental)"; - - "-bs-diagnose", set Js_config.diagnose, - "*internal* More verbose output"; - - "-bs-no-check-div-by-zero", clear Js_config.check_div_by_zero, - "*internal* unsafe mode, don't check div by zero and mod by zero"; - - "-bs-noassertfalse", set Clflags.no_assert_false, - "*internal* no code for assert false"; - - "-noassert", set Clflags.noassert, - "*internal* Do not compile assertion checks"; - - "-bs-loc", set Clflags.dump_location, - "*internal* dont display location with -dtypedtree, -dparsetree"; - - "-impl", string_call impl, - "*internal* Compile as a .ml file"; - - "-intf", string_call intf, - "*internal* Compile as a .mli file"; - - "-dtypedtree", set Clflags.dump_typedtree, - "*internal* debug typedtree"; - - "-dparsetree", set Clflags.dump_parsetree, - "*internal* debug parsetree"; - - "-drawlambda", set Clflags.dump_rawlambda, - "*internal* debug raw lambda"; - - "-dsource", set Clflags.dump_source, - "*internal* print source"; - - "-reprint-source", string_call reprint_source_file, - "*internal* transform the target ReScript file using PPXes provided, and print the transformed ReScript code to stdout"; - - "-format", string_call format_file, - "*internal* Format as Res syntax"; - - "-only-parse", set Clflags.only_parse, - "*internal* stop after parsing"; - - "-ignore-parse-errors", set Clflags.ignore_parse_errors, - "*internal* continue after parse errors"; - - "-where", unit_call print_standard_library, - "*internal* Print location of standard library and exit"; - - "-verbose", set Clflags.verbose, - "*internal* Print calls to external commands"; - - "-keep-locs", set Clflags.keep_locs, - "*internal* Keep locations in .cmi files"; - - "-no-keep-locs", clear Clflags.keep_locs, - "*internal* Do not keep locations in .cmi files"; - - "-nopervasives", set Clflags.nopervasives, - "*internal*"; - "-uncurried", unit_call (fun () -> Config.uncurried := Uncurried), - "*internal* Set jsx module"; - "-v", unit_call print_version_string, - "Print compiler version and location of standard library and exit"; - - "-version", unit_call print_version_string, - "Print version and exit"; - - "-pp", string_optional_set Clflags.preprocessor, - "*internal* Pipe sources through preprocessor "; - - "-absname", set Location.absname, - "*internal* Show absolute filenames in error messages"; - (* Not used, the build system did the expansion *) - - "-bs-no-bin-annot", clear Clflags.binary_annotations, - "*internal* Disable binary annotations (by default on)"; - - "-modules", set Js_config.modules, - "*internal* serve similar to ocamldep"; - - "-short-paths", clear Clflags.real_paths, - "*internal* Shorten paths in types"; - - "-unsafe", set Clflags.fast, - "*internal* Do not compile bounds checking on array and string access"; - - "-warn-help", unit_call Warnings.help_warnings, - "Show description of warning numbers"; - "-warn-error", string_call (Warnings.parse_options true), - " Enable or disable error status for warnings according\n\ - to . See option -w for the syntax of .\n\ - Default setting is " ^ Bsc_warnings.defaults_warn_error; - "-runtime",string_call setup_runtime_path, - "*internal* Set the runtime directory"; - "-make-runtime", unit_call Js_packages_state.make_runtime, - "*internal* make runtime library"; - "-make-runtime-test", unit_call Js_packages_state.make_runtime_test, - "*internal* make runtime test library"; - - |] - - - -(** parse flags in bs.config *) -let file_level_flags_handler (e : Parsetree.expression option) = - match e with - | None -> () - | Some {pexp_desc = Pexp_array args ; pexp_loc} -> - let args = Array.of_list - ( Ext_list.map args (fun e -> - match e.pexp_desc with - | Pexp_constant (Pconst_string(name,_)) -> name - | _ -> Location.raise_errorf ~loc:e.pexp_loc "string literal expected" )) in - (try Bsc_args.parse_exn ~start:0 - ~argv:args buckle_script_flags (fun ~rev_args:_ -> ()) ~usage - with _ -> Location.prerr_warning pexp_loc (Preprocessor "invalid flags for bsc")) - | Some e -> - Location.raise_errorf ~loc:e.pexp_loc "string array expected" - -let _ : unit = - Bs_conditional_initial.setup_env (); - Clflags.color := Some Always; - - let flags = "flags" in - Ast_config.add_structure - flags file_level_flags_handler; - Ast_config.add_signature - flags file_level_flags_handler; - try - Bsc_args.parse_exn - ~argv:Sys.argv - buckle_script_flags anonymous ~usage; - with - | Bsc_args.Bad msg -> - Format.eprintf "%s@." msg ; - exit 2 - | x -> - begin -(* - Ext_obj.bt (); -*) - Location.report_exception ppf x; - exit 2 - end diff --git a/jscomp/bsc/rescript_compiler_main.mli b/jscomp/bsc/rescript_compiler_main.mli deleted file mode 100644 index 3999ce7..0000000 --- a/jscomp/bsc/rescript_compiler_main.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) diff --git a/jscomp/build_tests/build_warn_as_error/input.js b/jscomp/build_tests/build_warn_as_error/input.js deleted file mode 100644 index a7a3f79..0000000 --- a/jscomp/build_tests/build_warn_as_error/input.js +++ /dev/null @@ -1,53 +0,0 @@ -var p = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var o1 = p.spawnSync(rescript_exe, ["build"], { - encoding: "utf8", - cwd: __dirname, -}); - -var first_message = o1.stdout - .split("\n") - .map(s => s.trim()) - .find(s => s == "Warning number 110"); - -if (!first_message) { - assert.fail(o1.stdout); -} - -// Second build using -warn-error +110 -var o2 = p.spawnSync(rescript_exe, ["build", "-warn-error", "+110"], { - encoding: "utf8", - cwd: __dirname, -}); - -var second_message = o2.stdout - .split("\n") - .map(s => s.trim()) - .find(s => s == "Warning number 110 (configured as error)"); - -if (!second_message) { - assert.fail(o2.stdout); -} - -// Third build, without -warn-error +110 -// The result should not be a warning as error -var o3 = p.spawnSync(rescript_exe, ["build"], { - encoding: "utf8", - cwd: __dirname, -}); - -var third_message = o3.stdout - .split("\n") - .map(s => s.trim()) - .find(s => s == "Dependency Finished"); - -if (!third_message) { - assert.fail(o3.stdout); -} - -var cleanup = p.spawnSync(rescript_exe, ["clean"], { - encoding: "utf8", - cwd: __dirname, -}); diff --git a/jscomp/build_tests/build_warn_as_error/rescript.json b/jscomp/build_tests/build_warn_as_error/rescript.json deleted file mode 100644 index 0932ebe..0000000 --- a/jscomp/build_tests/build_warn_as_error/rescript.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "name": "build_warn_as_error", - "version": "0.1.0", - "sources": ["src"] -} diff --git a/jscomp/build_tests/build_warn_as_error/src/Demo.res b/jscomp/build_tests/build_warn_as_error/src/Demo.res deleted file mode 100644 index 1dabe73..0000000 --- a/jscomp/build_tests/build_warn_as_error/src/Demo.res +++ /dev/null @@ -1 +0,0 @@ -let todo = _ => %todo diff --git a/jscomp/build_tests/case/input.js b/jscomp/build_tests/case/input.js deleted file mode 100644 index 0c1f9b6..0000000 --- a/jscomp/build_tests/case/input.js +++ /dev/null @@ -1,14 +0,0 @@ -var p = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -var o = p.spawnSync(rescript_exe, { encoding: "utf8", cwd: __dirname }); - -if ( - ![ - `Error: Invalid bsconfig.json implementation and interface have different path names or different cases src/demo vs src/Demo\n`, - // On linux files are parsed in different order - `Error: Invalid bsconfig.json implementation and interface have different path names or different cases src/Demo vs src/demo\n`, - ].includes(o.stderr) -) { - assert.fail(o.stderr); -} diff --git a/jscomp/build_tests/case/rescript.json b/jscomp/build_tests/case/rescript.json deleted file mode 100644 index 0f5b875..0000000 --- a/jscomp/build_tests/case/rescript.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "case", - "version": "0.1.0", - "sources": ["src"], - "bs-dependencies": [ - // add your bs-dependencies here - ] -} diff --git a/jscomp/build_tests/case/src/Demo.resi b/jscomp/build_tests/case/src/Demo.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case/src/Demo.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case/src/demo.res b/jscomp/build_tests/case/src/demo.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/case/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/case2/input.js b/jscomp/build_tests/case2/input.js deleted file mode 100644 index 998c2d8..0000000 --- a/jscomp/build_tests/case2/input.js +++ /dev/null @@ -1,14 +0,0 @@ -var p = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -var o = p.spawnSync(rescript_exe, { encoding: "utf8", cwd: __dirname }); - -if ( - ![ - `Error: Invalid bsconfig.json implementation and interface have different path names or different cases src/X vs src/x\n`, - // On linux files are parsed in different order - `Error: Invalid bsconfig.json implementation and interface have different path names or different cases src/x vs src/X\n`, - ].includes(o.stderr) -) { - assert.fail(o.stderr); -} diff --git a/jscomp/build_tests/case2/rescript.json b/jscomp/build_tests/case2/rescript.json deleted file mode 100644 index db6b5e7..0000000 --- a/jscomp/build_tests/case2/rescript.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "case2", - "version": "0.1.0", - "sources": ["src"], - "bs-dependencies": [ - // add your bs-dependencies here - ] -} diff --git a/jscomp/build_tests/case2/src/X.res b/jscomp/build_tests/case2/src/X.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/case2/src/X.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/case2/src/x.resi b/jscomp/build_tests/case2/src/x.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case2/src/x.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/input.js b/jscomp/build_tests/case3/input.js deleted file mode 100644 index a6672a3..0000000 --- a/jscomp/build_tests/case3/input.js +++ /dev/null @@ -1,14 +0,0 @@ -//@ts-check - -var p = require("child_process"); -var fs = require("fs"); -var path = require("path"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -p.spawnSync(`${rescript_exe} clean && ${rescript_exe} build`, { - encoding: "utf8", - cwd: __dirname, -}); - -var o = fs.readFileSync(path.join(__dirname, "src", "hello.bs.js"), "ascii"); -assert.ok(/HelloGen\.f/.test(o)); diff --git a/jscomp/build_tests/case3/rescript.json b/jscomp/build_tests/case3/rescript.json deleted file mode 100644 index 267c827..0000000 --- a/jscomp/build_tests/case3/rescript.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "name": "case3", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [], - "warnings": { "error": "+101" } -} diff --git a/jscomp/build_tests/case3/src/B01.bs.js b/jscomp/build_tests/case3/src/B01.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/B01.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/B01.res b/jscomp/build_tests/case3/src/B01.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B01.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/B01.resi b/jscomp/build_tests/case3/src/B01.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B01.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/B02.bs.js b/jscomp/build_tests/case3/src/B02.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/B02.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/B02.res b/jscomp/build_tests/case3/src/B02.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B02.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/B03.bs.js b/jscomp/build_tests/case3/src/B03.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/B03.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/B03.res b/jscomp/build_tests/case3/src/B03.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B03.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/B04.bs.js b/jscomp/build_tests/case3/src/B04.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/B04.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/B04.res b/jscomp/build_tests/case3/src/B04.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B04.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/B04.resi b/jscomp/build_tests/case3/src/B04.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B04.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/B05.bs.js b/jscomp/build_tests/case3/src/B05.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/B05.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/B05.res b/jscomp/build_tests/case3/src/B05.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B05.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/B05.resi b/jscomp/build_tests/case3/src/B05.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/B05.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a01.bs.js b/jscomp/build_tests/case3/src/a01.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/a01.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/a01.res b/jscomp/build_tests/case3/src/a01.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a01.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a01.resi b/jscomp/build_tests/case3/src/a01.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a01.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a02.bs.js b/jscomp/build_tests/case3/src/a02.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/a02.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/a02.res b/jscomp/build_tests/case3/src/a02.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a02.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a03.bs.js b/jscomp/build_tests/case3/src/a03.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/a03.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/a03.res b/jscomp/build_tests/case3/src/a03.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a03.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a04.bs.js b/jscomp/build_tests/case3/src/a04.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/a04.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/a04.res b/jscomp/build_tests/case3/src/a04.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a04.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a04.resi b/jscomp/build_tests/case3/src/a04.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a04.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a05.bs.js b/jscomp/build_tests/case3/src/a05.bs.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/build_tests/case3/src/a05.bs.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/build_tests/case3/src/a05.res b/jscomp/build_tests/case3/src/a05.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a05.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/a05.resi b/jscomp/build_tests/case3/src/a05.resi deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/case3/src/a05.resi +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/case3/src/hello.bs.js b/jscomp/build_tests/case3/src/hello.bs.js deleted file mode 100644 index 08c02c6..0000000 --- a/jscomp/build_tests/case3/src/hello.bs.js +++ /dev/null @@ -1,11 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - -var HelloGen = require("./hello.gen"); - -function f(prim) { - return HelloGen.f(prim); -} - -exports.f = f; -/* ./hello.gen Not a pure module */ diff --git a/jscomp/build_tests/case3/src/hello.res b/jscomp/build_tests/case3/src/hello.res deleted file mode 100644 index 94cd6cd..0000000 --- a/jscomp/build_tests/case3/src/hello.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType.import("hh") -external f: int => int = "f" diff --git a/jscomp/build_tests/cli_compile_status/input.js b/jscomp/build_tests/cli_compile_status/input.js deleted file mode 100755 index be04df4..0000000 --- a/jscomp/build_tests/cli_compile_status/input.js +++ /dev/null @@ -1,43 +0,0 @@ -// @ts-check - -const assert = require("assert"); -const child_process = require("child_process"); - -// Shows compile time for `rescript build` command -let out = child_process.spawnSync(`../../../rescript`, ["build"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.match( - out.stdout, - new RegExp(`>>>> Start compiling -Dependency Finished ->>>> Finish compiling \\d+ mseconds`) -); - -// Shows compile time for `rescript` command -out = child_process.spawnSync(`../../../rescript`, { - encoding: "utf8", - cwd: __dirname, -}); -assert.match( - out.stdout, - new RegExp(`>>>> Start compiling -Dependency Finished ->>>> Finish compiling \\d+ mseconds`) -); - -// Doesn't show compile time for `rescript build -verbose` command -// Because we can't be sure that -verbose is a valid argument -// And bsb won't fail with a usage message. -// It works this way not only for -verbose, but any other arg, including -h/--help/-help -out = child_process.spawnSync(`../../../rescript`, ["build", "-verbose"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.match( - out.stdout, - new RegExp( - `Package stack: test \nDependency Finished\nninja.exe -C lib/bs \n` - ) -); diff --git a/jscomp/build_tests/cli_compile_status/rescript.json b/jscomp/build_tests/cli_compile_status/rescript.json deleted file mode 100644 index c7c9717..0000000 --- a/jscomp/build_tests/cli_compile_status/rescript.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "name": "test", - "version": "0.1.0", - "sources": [] -} diff --git a/jscomp/build_tests/cli_help/input.js b/jscomp/build_tests/cli_help/input.js deleted file mode 100755 index 18c4fc7..0000000 --- a/jscomp/build_tests/cli_help/input.js +++ /dev/null @@ -1,266 +0,0 @@ -// @ts-check - -const assert = require("assert"); -const child_process = require("child_process"); - -const cliHelp = - "Usage: rescript \n" + - "\n" + - "`rescript` is equivalent to `rescript build`\n" + - "\n" + - "Options:\n" + - " -v, -version display version number\n" + - " -h, -help display help\n" + - "\n" + - "Subcommands:\n" + - " build\n" + - " clean\n" + - " format\n" + - " convert\n" + - " dump\n" + - " help\n" + - "\n" + - "Run `rescript -h` for subcommand help. Examples:\n" + - " rescript build -h\n" + - " rescript format -h\n"; - -const buildHelp = - "Usage: rescript build -- \n" + - "\n" + - "`rescript build` builds the project with dependencies\n" + - "\n" + - "`rescript build -- -h` for Ninja options (internal usage only; unstable)\n" + - "\n" + - "Options:\n" + - " -w Watch mode\n" + - " -ws [host]:port set up host & port for WebSocket build notifications\n" + - " -verbose Set the output to be verbose\n" + - " -with-deps *deprecated* This is the default behavior now. This option will be removed in a future release\n" + - ' -warn-error Warning numbers and whether to turn them into errors, e.g., "+8+32-102"\n'; - -const cleanHelp = - "Usage: rescript clean \n" + - "\n" + - "`rescript clean` cleans build artifacts\n" + - "\n" + - "Options:\n" + - " -verbose Set the output to be verbose\n" + - " -with-deps *deprecated* This is the default behavior now. This option will be removed in a future release\n"; - -const formatHelp = - "Usage: rescript format [files]\n" + - "\n" + - "`rescript format` formats the current directory\n" + - "\n" + - "Options:\n" + - " -stdin [.res|.resi|.ml|.mli] Read the code from stdin and print\n" + - " the formatted code to stdout in ReScript syntax\n" + - " -all Format the whole project \n" + - " -check Check formatting for file or the whole project. Use `-all` to check the whole project\n"; - -const convertHelp = - "Usage: rescript convert [files]\n" + - "\n" + - "`rescript convert` converts the current directory\n" + - "\n" + - "**This command removes old OCaml files and creates new ReScript \n" + - "files. Make sure your work is saved first!**\n" + - "\n" + - "Options:\n" + - " -all Convert the whole project\n"; - -const dumpHelp = - "Usage: rescript dump [target]\n" + - "`rescript dump` dumps the information for the target\n"; - -// Shows build help with --help arg -let out = child_process.spawnSync(`../../../rescript`, ["build", "--help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, buildHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// FIXME: Help works incorrectly in watch mode -out = child_process.spawnSync(`../../../rescript`, ["build", "-w", "--help"], { - encoding: "utf8", - cwd: __dirname, -}); -// FIXME: Shouldn't have "Start compiling" for help -assert.equal(out.stdout, ">>>> Start compiling\n" + buildHelp); -// FIXME: Don't run the watcher when showing help -assert.match( - out.stderr, - new RegExp( - "Uncaught Exception Error: ENOENT: no such file or directory, watch 'bsconfig.json'\n" - ) -); -// FIXME: Should be 0 -assert.equal(out.status, 1); - -// FIXME: Has the same problem with `rescript -w` -out = child_process.spawnSync(`../../../rescript`, ["-w", "--help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, ">>>> Start compiling\n" + buildHelp); -assert.match( - out.stderr, - new RegExp( - "Uncaught Exception Error: ENOENT: no such file or directory, watch 'bsconfig.json'\n" - ) -); - -// Shows cli help with --help arg even if there are invalid arguments after it -out = child_process.spawnSync(`../../../rescript`, ["--help", "-w"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, cliHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows build help with -h arg -out = child_process.spawnSync(`../../../rescript`, ["build", "-h"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, buildHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Exits with build help with unknown arg -out = child_process.spawnSync(`../../../rescript`, ["build", "-foo"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, ""); -assert.equal(out.stderr, 'Error: Unknown option "-foo".\n' + buildHelp); -assert.equal(out.status, 2); - -// Shows cli help with --help arg -out = child_process.spawnSync(`../../../rescript`, ["--help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, cliHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows cli help with -h arg -out = child_process.spawnSync(`../../../rescript`, ["-h"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, cliHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows cli help with help command -out = child_process.spawnSync(`../../../rescript`, ["help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, cliHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Exits with cli help with unknown command -out = child_process.spawnSync(`../../../rescript`, ["built"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, ""); -assert.equal(out.stderr, `Error: Unknown command "built".\n` + cliHelp); -assert.equal(out.status, 2); - -// Exits with build help with unknown args -out = child_process.spawnSync(`../../../rescript`, ["-foo"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, ""); -assert.equal(out.stderr, 'Error: Unknown option "-foo".\n' + buildHelp); -assert.equal(out.status, 2); - -// Shows clean help with --help arg -out = child_process.spawnSync(`../../../rescript`, ["clean", "--help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, cleanHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows clean help with -h arg -out = child_process.spawnSync(`../../../rescript`, ["clean", "-h"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, cleanHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Exits with clean help with unknown arg -out = child_process.spawnSync(`../../../rescript`, ["clean", "-foo"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, ""); -assert.equal(out.stderr, 'Error: Unknown option "-foo".\n' + cleanHelp); -assert.equal(out.status, 2); - -// Shows format help with --help arg -out = child_process.spawnSync(`../../../rescript`, ["format", "--help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, formatHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows format help with -h arg -out = child_process.spawnSync(`../../../rescript`, ["format", "-h"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, formatHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows convert help with --help arg -out = child_process.spawnSync(`../../../rescript`, ["convert", "--help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, convertHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows convert help with -h arg -out = child_process.spawnSync(`../../../rescript`, ["convert", "-h"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, convertHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows dump help with --help arg -out = child_process.spawnSync(`../../../rescript`, ["dump", "--help"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, dumpHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); - -// Shows dump help with -h arg -out = child_process.spawnSync(`../../../rescript`, ["dump", "-h"], { - encoding: "utf8", - cwd: __dirname, -}); -assert.equal(out.stdout, dumpHelp); -assert.equal(out.stderr, ""); -assert.equal(out.status, 0); diff --git a/jscomp/build_tests/cmd/input.js b/jscomp/build_tests/cmd/input.js deleted file mode 100644 index e477ef3..0000000 --- a/jscomp/build_tests/cmd/input.js +++ /dev/null @@ -1,60 +0,0 @@ -var p = require("child_process"); - -var assert = require("assert"); - -var bsc_exe_path = require("../../../scripts/bin_path").bsc_exe; - -var react = ` -type u - -external a : u = "react" [@@bs.module] - -external b : unit -> int = "bool" [@@bs.module "react"] - -let v = a -let h = b () -`; - -var foo_react = ` -type bla - - -external foo : bla = "foo.react" [@@bs.module] - -external bar : unit -> bla = "bar" [@@bs.val] [@@bs.module "foo.react"] - -let c = foo - -let d = bar () -`; - -function evalCode(code) { - var bsc_exe = p.spawnSync( - `${bsc_exe_path} -bs-no-version-header -bs-cross-module-opt -w -40 -bs-eval '${code}'`, - { - encoding: "utf8", - shell: true, - cwd: __dirname, - } - ); - - return bsc_exe; -} - -function test(react) { - var x = evalCode(react); - console.log(x); - assert.ok(x.stdout.match(/require/g).length === 1, "react one"); -} - -test(react); - -assert.ok( - evalCode(react + foo_react).stdout.match(/require/g).length === 2, - "foo react twice " -); - -assert.ok( - evalCode(foo_react).stdout.match(/require/g).length === 1, - "foo react one" -); diff --git a/jscomp/build_tests/custom_namespace/input.js b/jscomp/build_tests/custom_namespace/input.js deleted file mode 100644 index 9c00338..0000000 --- a/jscomp/build_tests/custom_namespace/input.js +++ /dev/null @@ -1,10 +0,0 @@ -var child_process = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -child_process.execSync(`${rescript_exe} clean && ${rescript_exe} build`, { - cwd: __dirname, -}); - -var x = require("./src/demo.bs.js"); -assert.equal(x.v, 42); diff --git a/jscomp/build_tests/custom_namespace/rescript.json b/jscomp/build_tests/custom_namespace/rescript.json deleted file mode 100644 index 9677227..0000000 --- a/jscomp/build_tests/custom_namespace/rescript.json +++ /dev/null @@ -1,20 +0,0 @@ -{ - "name": "namespace", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "namespace": "Foo_bar", - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "bsc-flags": ["-bs-no-version-header"], - "bs-dependencies": [], - "warnings": { - "number": "-40+6+7", - "error": true - }, - "suffix": ".bs.js" -} diff --git a/jscomp/build_tests/custom_namespace/src/demo.bs.js b/jscomp/build_tests/custom_namespace/src/demo.bs.js deleted file mode 100644 index 5bcd6ef..0000000 --- a/jscomp/build_tests/custom_namespace/src/demo.bs.js +++ /dev/null @@ -1,7 +0,0 @@ -'use strict'; - - -var v = 42; - -exports.v = v; -/* No side effect */ diff --git a/jscomp/build_tests/custom_namespace/src/demo.res b/jscomp/build_tests/custom_namespace/src/demo.res deleted file mode 100644 index a65bbc1..0000000 --- a/jscomp/build_tests/custom_namespace/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let v = 42 diff --git a/jscomp/build_tests/cycle/input.js b/jscomp/build_tests/cycle/input.js deleted file mode 100644 index 956da90..0000000 --- a/jscomp/build_tests/cycle/input.js +++ /dev/null @@ -1,14 +0,0 @@ -//@ts-check -const cp = require("child_process"); -const assert = require("assert"); -const fs = require("fs"); -const path = require("path"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var output = cp.spawnSync(rescript_exe, { encoding: "utf8", shell: true }); - -assert(/dependency cycle/.test(output.stdout)); - -var compilerLogFile = path.join(__dirname, "lib", "bs", ".compiler.log"); -var compilerLog = fs.readFileSync(compilerLogFile, "utf8"); -assert(/dependency cycle/.test(compilerLog)); diff --git a/jscomp/build_tests/cycle/rescript.json b/jscomp/build_tests/cycle/rescript.json deleted file mode 100644 index f43ea2c..0000000 --- a/jscomp/build_tests/cycle/rescript.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "name": "cycle", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [], - "warnings": { "error": "+101" } -} diff --git a/jscomp/build_tests/cycle/src/a.res b/jscomp/build_tests/cycle/src/a.res deleted file mode 100644 index 3d03da1..0000000 --- a/jscomp/build_tests/cycle/src/a.res +++ /dev/null @@ -1 +0,0 @@ -let v = B.v diff --git a/jscomp/build_tests/cycle/src/b.res b/jscomp/build_tests/cycle/src/b.res deleted file mode 100644 index b9fdeba..0000000 --- a/jscomp/build_tests/cycle/src/b.res +++ /dev/null @@ -1 +0,0 @@ -let v = A.v diff --git a/jscomp/build_tests/cycle1/input.js b/jscomp/build_tests/cycle1/input.js deleted file mode 100644 index 3c5519e..0000000 --- a/jscomp/build_tests/cycle1/input.js +++ /dev/null @@ -1,16 +0,0 @@ -//@ts-check -const cp = require("child_process"); -const assert = require("assert"); -const fs = require("fs"); -const path = require("path"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -cp.execSync(`${rescript_exe} clean`, { cwd: __dirname }); - -var output = cp.spawnSync(rescript_exe, { encoding: "utf8", shell: true }); - -assert(/is dangling/.test(output.stdout)); - -var compilerLogFile = path.join(__dirname, "lib", "bs", ".compiler.log"); -var compilerLog = fs.readFileSync(compilerLogFile, "utf8"); -assert(/is dangling/.test(compilerLog)); diff --git a/jscomp/build_tests/cycle1/rescript.json b/jscomp/build_tests/cycle1/rescript.json deleted file mode 100644 index fdbf975..0000000 --- a/jscomp/build_tests/cycle1/rescript.json +++ /dev/null @@ -1,14 +0,0 @@ -{ - "name": "cycle1", - "namespace": true, - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "package-specs": { - "module": "esmodule", - "in-source": true - }, - "suffix": ".bs.js" -} diff --git a/jscomp/build_tests/cycle1/src/A.res b/jscomp/build_tests/cycle1/src/A.res deleted file mode 100644 index 237f168..0000000 --- a/jscomp/build_tests/cycle1/src/A.res +++ /dev/null @@ -1,3 +0,0 @@ -include A - -let x = 42 \ No newline at end of file diff --git a/jscomp/build_tests/cycle1/src/A.resi b/jscomp/build_tests/cycle1/src/A.resi deleted file mode 100644 index 86982fe..0000000 --- a/jscomp/build_tests/cycle1/src/A.resi +++ /dev/null @@ -1 +0,0 @@ -let x : int \ No newline at end of file diff --git a/jscomp/build_tests/deprecated-package-specs/input.js b/jscomp/build_tests/deprecated-package-specs/input.js deleted file mode 100644 index ed66ae0..0000000 --- a/jscomp/build_tests/deprecated-package-specs/input.js +++ /dev/null @@ -1,9 +0,0 @@ -const child_process = require("child_process"); -const assert = require("assert"); -const rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -const out = child_process.spawnSync(rescript_exe, { encoding: "utf8" }); -assert.match( - out.stderr, - /deprecated: Option "es6-global" is deprecated\. Use "esmodule" instead\./ -); diff --git a/jscomp/build_tests/deprecated-package-specs/rescript.json b/jscomp/build_tests/deprecated-package-specs/rescript.json deleted file mode 100644 index ada61da..0000000 --- a/jscomp/build_tests/deprecated-package-specs/rescript.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "deprecated-package-specs", - "version": "0.1.0", - "sources": "src", - "package-specs": { - "module": "es6-global" - } -} diff --git a/jscomp/build_tests/deprecated-package-specs/src/Index.res b/jscomp/build_tests/deprecated-package-specs/src/Index.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/deprecated-package-specs/src/Index.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/devonly/input.js b/jscomp/build_tests/devonly/input.js deleted file mode 100644 index c3a0d57..0000000 --- a/jscomp/build_tests/devonly/input.js +++ /dev/null @@ -1,5 +0,0 @@ -//@ts-check -var cp = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -cp.execSync(rescript_exe, { cwd: __dirname, encoding: "utf8" }); diff --git a/jscomp/build_tests/devonly/rescript.json b/jscomp/build_tests/devonly/rescript.json deleted file mode 100644 index e68f677..0000000 --- a/jscomp/build_tests/devonly/rescript.json +++ /dev/null @@ -1,22 +0,0 @@ -{ - "name": "devonly", - "version": "0.1.0", - "sources": [ - { - "dir": "src", - "subdirs": true, - "type": "dev" - }, - { - "dir": "src2", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [], - "warnings": { "error": "+101" } -} diff --git a/jscomp/build_tests/devonly/src/demo.bs.js b/jscomp/build_tests/devonly/src/demo.bs.js deleted file mode 100644 index 83cfc1a..0000000 --- a/jscomp/build_tests/devonly/src/demo.bs.js +++ /dev/null @@ -1,8 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - -var Depdemo = require("./depdemo.bs.js"); - -console.log(Depdemo.a); - -/* Not a pure module */ diff --git a/jscomp/build_tests/devonly/src/demo.res b/jscomp/build_tests/devonly/src/demo.res deleted file mode 100644 index dda4ba3..0000000 --- a/jscomp/build_tests/devonly/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log(Depdemo.a) diff --git a/jscomp/build_tests/devonly/src/depdemo.bs.js b/jscomp/build_tests/devonly/src/depdemo.bs.js deleted file mode 100644 index bd93031..0000000 --- a/jscomp/build_tests/devonly/src/depdemo.bs.js +++ /dev/null @@ -1,8 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - - -var a = 3; - -exports.a = a; -/* No side effect */ diff --git a/jscomp/build_tests/devonly/src/depdemo.res b/jscomp/build_tests/devonly/src/depdemo.res deleted file mode 100644 index 1bf62c4..0000000 --- a/jscomp/build_tests/devonly/src/depdemo.res +++ /dev/null @@ -1 +0,0 @@ -let a = 3 diff --git a/jscomp/build_tests/devonly/src2/hello.bs.js b/jscomp/build_tests/devonly/src2/hello.bs.js deleted file mode 100644 index fca2123..0000000 --- a/jscomp/build_tests/devonly/src2/hello.bs.js +++ /dev/null @@ -1,8 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - - -var v = 3; - -exports.v = v; -/* No side effect */ diff --git a/jscomp/build_tests/devonly/src2/hello.res b/jscomp/build_tests/devonly/src2/hello.res deleted file mode 100644 index 55f1eb2..0000000 --- a/jscomp/build_tests/devonly/src2/hello.res +++ /dev/null @@ -1 +0,0 @@ -let v = 3 diff --git a/jscomp/build_tests/devonly/src2/hellodep.bs.js b/jscomp/build_tests/devonly/src2/hellodep.bs.js deleted file mode 100644 index 7d140c5..0000000 --- a/jscomp/build_tests/devonly/src2/hellodep.bs.js +++ /dev/null @@ -1,8 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - -var Hello = require("./hello.bs.js"); - -console.log(Hello.v); - -/* Not a pure module */ diff --git a/jscomp/build_tests/devonly/src2/hellodep.res b/jscomp/build_tests/devonly/src2/hellodep.res deleted file mode 100644 index 382ad1a..0000000 --- a/jscomp/build_tests/devonly/src2/hellodep.res +++ /dev/null @@ -1 +0,0 @@ -Js.log(Hello.v) diff --git a/jscomp/build_tests/duplicated_symlinked_packages/.gitignore b/jscomp/build_tests/duplicated_symlinked_packages/.gitignore deleted file mode 100644 index 5abc616..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -.merlin -**/lib diff --git a/jscomp/build_tests/duplicated_symlinked_packages/README.md b/jscomp/build_tests/duplicated_symlinked_packages/README.md deleted file mode 100644 index 100d897..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/README.md +++ /dev/null @@ -1,36 +0,0 @@ -Special tests for duplicated symlink warnings - - -``` -. -├── a -│   ├── node_modules -│   │   ├── c -> ../../c -│   │   └── z -│   │   ├── lib -│   │   │   ├── bs -│   │   │   └── ocaml -│   │   └── src -│   └── src -├── b -│   ├── node_modules -│   │   └── c -> ../../c -│   └── src -├── c -│   └── src -├── node_modules -│   ├── a -> ../a -│   ├── b -> ../b -│   └── z -│   └── src -└── out.expected -└── src - -``` - -`c` is symlinked everywhere, while `z` is actually conflicting package. - -`out.expected` has exactly 1 warning for `z` conflict - -Run `node ./jscomp/build_tests/duplicated_symlinked_packages/input.js` to check the tests against previous snapshots. -Run `node ./jscomp/build_tests/duplicated_symlinked_packages/input.js update` to update the snapshots (assuming you've made some changes to duplicated) diff --git a/jscomp/build_tests/duplicated_symlinked_packages/a/bsconfig.json b/jscomp/build_tests/duplicated_symlinked_packages/a/bsconfig.json deleted file mode 100644 index 93ee22b..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/a/bsconfig.json +++ /dev/null @@ -1,19 +0,0 @@ -{ - "name": "a", - "version": "0.1.0", - "sources": { - "dir" : "src", - "subdirs" : true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [ - "c", - "z" - ], - "warnings": {"error" : "+101"}, - "namespace": true -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/c b/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/c deleted file mode 120000 index 2fcc511..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/c +++ /dev/null @@ -1 +0,0 @@ -../../c \ No newline at end of file diff --git a/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/bsconfig.json b/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/bsconfig.json deleted file mode 100644 index c99d72b..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/bsconfig.json +++ /dev/null @@ -1,21 +0,0 @@ -{ - "name": "z", - "version": "0.1.0", - "sources": { - "dir" : "src", - "subdirs" : true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [ - - ], - "warnings": { - "error" : "+101" - }, - "namespace": true, - "refmt": 3 -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/package.json b/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/package.json deleted file mode 100644 index 92b37ba..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/package.json +++ /dev/null @@ -1,18 +0,0 @@ -{ - "name": "z", - "version": "0.1.0", - "scripts": { - "build": "bsb -make-world", - "start": "bsb -make-world -w", - "clean": "bsb -clean-world" - }, - "keywords": [ - "BuckleScript" - ], - "author": "", - "license": "MIT", - "devDependencies": { - "bs-platform": "^7.0.1", - "gentype": "^3.7.1" - } -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/src/.git_keep b/jscomp/build_tests/duplicated_symlinked_packages/a/node_modules/z/src/.git_keep deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/build_tests/duplicated_symlinked_packages/a/package.json b/jscomp/build_tests/duplicated_symlinked_packages/a/package.json deleted file mode 100644 index f0cb45e..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/a/package.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "name": "a", - "version": "0.1.0", - "scripts": { - "build": "rescript build", - "start": "rescript build -w", - "clean": "rescript clean" - }, - "keywords": [ - "ReScript" - ], - "author": "", - "license": "MIT", - "devDependencies": {} -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/a/src/.git_keep b/jscomp/build_tests/duplicated_symlinked_packages/a/src/.git_keep deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/build_tests/duplicated_symlinked_packages/b/bsconfig.json b/jscomp/build_tests/duplicated_symlinked_packages/b/bsconfig.json deleted file mode 100644 index 77361fe..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/b/bsconfig.json +++ /dev/null @@ -1,18 +0,0 @@ -{ - "name": "b", - "version": "0.1.0", - "sources": { - "dir" : "src", - "subdirs" : true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [ - "c" - ], - "warnings": {"error" : "+101"}, - "namespace": true -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/b/node_modules/c b/jscomp/build_tests/duplicated_symlinked_packages/b/node_modules/c deleted file mode 120000 index 2fcc511..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/b/node_modules/c +++ /dev/null @@ -1 +0,0 @@ -../../c \ No newline at end of file diff --git a/jscomp/build_tests/duplicated_symlinked_packages/b/package.json b/jscomp/build_tests/duplicated_symlinked_packages/b/package.json deleted file mode 100644 index 6cba4e4..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/b/package.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "name": "b", - "version": "0.1.0", - "scripts": { - "build": "rescript build", - "start": "rescript build -w", - "clean": "rescript clean" - }, - "keywords": [ - "ReScript" - ], - "author": "", - "license": "MIT", - "devDependencies": {} -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/b/src/.git_keep b/jscomp/build_tests/duplicated_symlinked_packages/b/src/.git_keep deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/build_tests/duplicated_symlinked_packages/c/bsconfig.json b/jscomp/build_tests/duplicated_symlinked_packages/c/bsconfig.json deleted file mode 100644 index e95c884..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/c/bsconfig.json +++ /dev/null @@ -1,18 +0,0 @@ -{ - "name": "c", - "version": "0.1.0", - "sources": { - "dir" : "src", - "subdirs" : true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [ - - ], - "warnings": {"error" : "+101"}, - "namespace": true -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/c/package.json b/jscomp/build_tests/duplicated_symlinked_packages/c/package.json deleted file mode 100644 index 907967c..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/c/package.json +++ /dev/null @@ -1,18 +0,0 @@ -{ - "name": "z", - "version": "0.1.0", - "scripts": { - "build": "rescript build", - "start": "rescript build -w", - "clean": "rescript clean" - }, - "keywords": [ - "ReScript" - ], - "author": "", - "license": "MIT", - "devDependencies": { - "bs-platform": "^7.0.1", - "gentype": "^3.7.1" - } -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/c/src/.git_keep b/jscomp/build_tests/duplicated_symlinked_packages/c/src/.git_keep deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/build_tests/duplicated_symlinked_packages/input.js b/jscomp/build_tests/duplicated_symlinked_packages/input.js deleted file mode 100644 index bb2c7e8..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/input.js +++ /dev/null @@ -1,33 +0,0 @@ -const fs = require("fs"); -const path = require("path"); -const child_process = require("child_process"); -const rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -const expectedFilePath = path.join(__dirname, "out.expected"); - -const updateTests = process.argv[2] === "update"; - -function postProcessErrorOutput(output) { - output = output.trimRight(); - output = output.replace(new RegExp(__dirname, "gi"), "."); - return output; -} -child_process.execSync(`${rescript_exe} clean`, { cwd: __dirname }); -child_process.exec(rescript_exe, { cwd: __dirname }, (err, stdout, stderr) => { - const actualErrorOutput = postProcessErrorOutput(stderr.toString()); - if (updateTests) { - fs.writeFileSync(expectedFilePath, actualErrorOutput); - } else { - const expectedErrorOutput = postProcessErrorOutput( - fs.readFileSync(expectedFilePath, { encoding: "utf-8" }) - ); - if (expectedErrorOutput !== actualErrorOutput) { - console.error(`The old and new error output aren't the same`); - console.error("\n=== Old:"); - console.error(expectedErrorOutput); - console.error("\n=== New:"); - console.error(actualErrorOutput); - process.exit(1); - } - } -}); diff --git a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/a b/jscomp/build_tests/duplicated_symlinked_packages/node_modules/a deleted file mode 120000 index 82f488f..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/a +++ /dev/null @@ -1 +0,0 @@ -../a \ No newline at end of file diff --git a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/b b/jscomp/build_tests/duplicated_symlinked_packages/node_modules/b deleted file mode 120000 index 42532fe..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/b +++ /dev/null @@ -1 +0,0 @@ -../b \ No newline at end of file diff --git a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/bsconfig.json b/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/bsconfig.json deleted file mode 100644 index c99d72b..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/bsconfig.json +++ /dev/null @@ -1,21 +0,0 @@ -{ - "name": "z", - "version": "0.1.0", - "sources": { - "dir" : "src", - "subdirs" : true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [ - - ], - "warnings": { - "error" : "+101" - }, - "namespace": true, - "refmt": 3 -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/package.json b/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/package.json deleted file mode 100644 index 92b37ba..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/package.json +++ /dev/null @@ -1,18 +0,0 @@ -{ - "name": "z", - "version": "0.1.0", - "scripts": { - "build": "bsb -make-world", - "start": "bsb -make-world -w", - "clean": "bsb -clean-world" - }, - "keywords": [ - "BuckleScript" - ], - "author": "", - "license": "MIT", - "devDependencies": { - "bs-platform": "^7.0.1", - "gentype": "^3.7.1" - } -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/src/.git_keep b/jscomp/build_tests/duplicated_symlinked_packages/node_modules/z/src/.git_keep deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/build_tests/duplicated_symlinked_packages/out.expected b/jscomp/build_tests/duplicated_symlinked_packages/out.expected deleted file mode 100644 index 57e0a50..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/out.expected +++ /dev/null @@ -1,2 +0,0 @@ -Duplicated package: z ./node_modules/z (chosen) vs ./node_modules/a/node_modules/z in ./node_modules/a -Duplicated package: z ./node_modules/z (chosen) vs ./node_modules/a/node_modules/z in ./node_modules/a \ No newline at end of file diff --git a/jscomp/build_tests/duplicated_symlinked_packages/rescript.json b/jscomp/build_tests/duplicated_symlinked_packages/rescript.json deleted file mode 100644 index f789256..0000000 --- a/jscomp/build_tests/duplicated_symlinked_packages/rescript.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "name": "duplicated-symlinked-packages", - "version": "0.1.0", - "sources": ["src"], - "bs-dependencies": ["a", "b", "z"] -} diff --git a/jscomp/build_tests/duplicated_symlinked_packages/src/.git_keep b/jscomp/build_tests/duplicated_symlinked_packages/src/.git_keep deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/build_tests/exports/input.js b/jscomp/build_tests/exports/input.js deleted file mode 100644 index 73d0165..0000000 --- a/jscomp/build_tests/exports/input.js +++ /dev/null @@ -1,7 +0,0 @@ -var child_process = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -child_process.execSync(rescript_exe, { - cwd: __dirname, - encoding: "utf8", -}); diff --git a/jscomp/build_tests/exports/rescript.json b/jscomp/build_tests/exports/rescript.json deleted file mode 100644 index 2414b95..0000000 --- a/jscomp/build_tests/exports/rescript.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "exports", - "version": "0.1.0", - "sources": ["src"], - "bs-dependencies": [ - // add your bs-dependencies here - ] -} diff --git a/jscomp/build_tests/exports/src/demo.res b/jscomp/build_tests/exports/src/demo.res deleted file mode 100644 index 2237670..0000000 --- a/jscomp/build_tests/exports/src/demo.res +++ /dev/null @@ -1,12 +0,0 @@ -exception Stack_overflow -exception Sys_error(string) -let _ = (Js.Int.toString, Js.Float.isNaN) - -/* make sure exception runtime is there */ -let f = x => - switch x { - | Not_found => 0 - | Invalid_argument(_) - | Stack_overflow => 1 - | Sys_error(_) => 2 - } diff --git a/jscomp/build_tests/hyphen2/input.js b/jscomp/build_tests/hyphen2/input.js deleted file mode 100644 index f48b5a8..0000000 --- a/jscomp/build_tests/hyphen2/input.js +++ /dev/null @@ -1,4 +0,0 @@ -var p = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -p.execSync(rescript_exe, { cwd: __dirname }); diff --git a/jscomp/build_tests/hyphen2/rescript.json b/jscomp/build_tests/hyphen2/rescript.json deleted file mode 100644 index 253e05b..0000000 --- a/jscomp/build_tests/hyphen2/rescript.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "name": "hyphen2", - "version": "0.1.0", - "sources": ["y-src"], - "namespace": true -} diff --git a/jscomp/build_tests/hyphen2/y-src/demo.res b/jscomp/build_tests/hyphen2/y-src/demo.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/hyphen2/y-src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/in_source/input.js b/jscomp/build_tests/in_source/input.js deleted file mode 100644 index f3bbb0a..0000000 --- a/jscomp/build_tests/in_source/input.js +++ /dev/null @@ -1,24 +0,0 @@ -var child_process = require("child_process"); - -var assert = require("assert"); - -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -assert.throws( - () => { - var output = child_process.execSync(`${rescript_exe} build -regen`, { - cwd: __dirname, - encoding: "utf8", - }); - }, - function (err) { - if (err.message.match(/detected two module formats/)) { - return true; - } - return false; - } -); - -// assert.throws(()=>{ -// throw new Error('Wrong value') -// }, /x/) diff --git a/jscomp/build_tests/in_source/input.sh b/jscomp/build_tests/in_source/input.sh deleted file mode 100644 index a8e88ce..0000000 --- a/jscomp/build_tests/in_source/input.sh +++ /dev/null @@ -1 +0,0 @@ -rescript build -regen \ No newline at end of file diff --git a/jscomp/build_tests/in_source/rescript.json b/jscomp/build_tests/in_source/rescript.json deleted file mode 100644 index fc69fdc..0000000 --- a/jscomp/build_tests/in_source/rescript.json +++ /dev/null @@ -1,14 +0,0 @@ -{ - "name": "x", - "sources": ".", - "package-specs": [ - { - "module": "commonjs", - "in-source": true - }, - { - "module": "esmodule", - "in-source": true - } - ] -} diff --git a/jscomp/build_tests/install/input.js b/jscomp/build_tests/install/input.js deleted file mode 100644 index 91dda30..0000000 --- a/jscomp/build_tests/install/input.js +++ /dev/null @@ -1,29 +0,0 @@ -var p = require("child_process"); -var fs = require("fs"); -var path = require("path"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -p.spawnSync(rescript_exe, [`clean`], { - encoding: "utf8", - cwd: __dirname, -}); -p.spawnSync(rescript_exe, [`build`, `-install`], { - encoding: "utf8", - cwd: __dirname, -}); - -var fooExists = fs.existsSync(path.join(__dirname, "lib", "ocaml", "Foo.cmi")); -assert.ok(fooExists == false); - -p.spawnSync(rescript_exe, { - encoding: "utf8", - cwd: __dirname, -}); -p.spawnSync(rescript_exe, [`build`, `-install`], { - encoding: "utf8", - cwd: __dirname, -}); - -fooExists = fs.existsSync(path.join(__dirname, "lib", "ocaml", "Foo.cmi")); -assert.ok(fooExists); diff --git a/jscomp/build_tests/install/rescript.json b/jscomp/build_tests/install/rescript.json deleted file mode 100644 index c5e0d91..0000000 --- a/jscomp/build_tests/install/rescript.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "name": "install", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [], - "warnings": { "error": "+101" } -} diff --git a/jscomp/build_tests/install/src/Foo.bs.js b/jscomp/build_tests/install/src/Foo.bs.js deleted file mode 100644 index cf2ea83..0000000 --- a/jscomp/build_tests/install/src/Foo.bs.js +++ /dev/null @@ -1,10 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - - -function main() { - console.log("hello"); -} - -exports.main = main; -/* No side effect */ diff --git a/jscomp/build_tests/install/src/Foo.res b/jscomp/build_tests/install/src/Foo.res deleted file mode 100644 index 95d72e3..0000000 --- a/jscomp/build_tests/install/src/Foo.res +++ /dev/null @@ -1 +0,0 @@ -let main = () => Js.log("hello") diff --git a/jscomp/build_tests/nested/.gitignore b/jscomp/build_tests/nested/.gitignore deleted file mode 100644 index 6724ce3..0000000 --- a/jscomp/build_tests/nested/.gitignore +++ /dev/null @@ -1 +0,0 @@ -src/**/*.js \ No newline at end of file diff --git a/jscomp/build_tests/nested/input.js b/jscomp/build_tests/nested/input.js deleted file mode 100644 index b5c4be9..0000000 --- a/jscomp/build_tests/nested/input.js +++ /dev/null @@ -1,17 +0,0 @@ -var p = require("child_process"); -var assert = require("assert"); -var fs = require("fs"); -var path = require("path"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -p.execSync(rescript_exe, { cwd: __dirname }); - -var content = fs.readFileSync(path.join(__dirname, "src", "demo.js"), "utf8"); - -assert.ok(content.match(/A00_a1_main/g).length === 3); -assert.ok(content.match(/B00_b1_main/g).length === 3); -assert.ok(content.match(/A0_main/g).length === 2); -assert.ok(content.match(/a0_main/g).length === 1); -assert.ok(content.match(/B0_main/g).length === 2); -assert.ok(content.match(/b0_main/g).length === 1); - -assert.ok(require("./src/demo.js").v === 4, "nested"); diff --git a/jscomp/build_tests/nested/rescript.json b/jscomp/build_tests/nested/rescript.json deleted file mode 100644 index 745772f..0000000 --- a/jscomp/build_tests/nested/rescript.json +++ /dev/null @@ -1,13 +0,0 @@ -{ - "name": "nested", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "warnings": { "error": true } -} diff --git a/jscomp/build_tests/nested/src/a0/a0_main.res b/jscomp/build_tests/nested/src/a0/a0_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nested/src/a0/a0_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nested/src/a0/a1/A00_a1_main.res b/jscomp/build_tests/nested/src/a0/a1/A00_a1_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nested/src/a0/a1/A00_a1_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nested/src/b0/b0_main.res b/jscomp/build_tests/nested/src/b0/b0_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nested/src/b0/b0_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nested/src/b0/b1/B00_b1_main.res b/jscomp/build_tests/nested/src/b0/b1/B00_b1_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nested/src/b0/b1/B00_b1_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nested/src/demo.res b/jscomp/build_tests/nested/src/demo.res deleted file mode 100644 index 9854cb5..0000000 --- a/jscomp/build_tests/nested/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let v = A00_a1_main.v + A0_main.v + B0_main.v + B00_b1_main.v diff --git a/jscomp/build_tests/nested/src/demo.resi b/jscomp/build_tests/nested/src/demo.resi deleted file mode 100644 index 19b83dc..0000000 --- a/jscomp/build_tests/nested/src/demo.resi +++ /dev/null @@ -1 +0,0 @@ -let v: int diff --git a/jscomp/build_tests/nnest/.gitignore b/jscomp/build_tests/nnest/.gitignore deleted file mode 100644 index 6724ce3..0000000 --- a/jscomp/build_tests/nnest/.gitignore +++ /dev/null @@ -1 +0,0 @@ -src/**/*.js \ No newline at end of file diff --git a/jscomp/build_tests/nnest/input.js b/jscomp/build_tests/nnest/input.js deleted file mode 100644 index b14c3a9..0000000 --- a/jscomp/build_tests/nnest/input.js +++ /dev/null @@ -1,28 +0,0 @@ -// @ts-check - -var p = require("child_process"); -var assert = require("assert"); -var fs = require("fs"); -var path = require("path"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -p.execSync(rescript_exe, { cwd: __dirname }); - -var content = fs.readFileSync(path.join(__dirname, "src", "demo.js"), "utf8"); - -assert.ok(content.match(/A0_a1_main/g).length === 3); -assert.ok(content.match(/B0_b1_main/g).length === 3); -assert.ok(content.match(/A0_main/g).length === 2); -assert.ok(content.match(/a0_main/g).length === 1); -assert.ok(content.match(/B0_main/g).length === 2); -assert.ok(content.match(/b0_main/g).length === 1); - -assert.ok(require("./src/demo.js").v === 4, "nested"); - -// var testWarnError = /warnings\s*=\s*[^\r\n]*-warn-error/; - -// function hasWarnError(file) { -// var content = fs.readFileSync(file, "utf8"); -// return testWarnError.test(content); -// } - -// assert.ok(hasWarnError(path.join(__dirname,'lib','bs','build.ninja'))) diff --git a/jscomp/build_tests/nnest/rescript.json b/jscomp/build_tests/nnest/rescript.json deleted file mode 100644 index e1e67b2..0000000 --- a/jscomp/build_tests/nnest/rescript.json +++ /dev/null @@ -1,14 +0,0 @@ -{ - "name": "nested", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "namespace": true, - "warnings": { "error": true } -} diff --git a/jscomp/build_tests/nnest/src/a0/a0_main.res b/jscomp/build_tests/nnest/src/a0/a0_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nnest/src/a0/a0_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nnest/src/a0/a1/A0_a1_main.res b/jscomp/build_tests/nnest/src/a0/a1/A0_a1_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nnest/src/a0/a1/A0_a1_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nnest/src/b0/b0_main.res b/jscomp/build_tests/nnest/src/b0/b0_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nnest/src/b0/b0_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nnest/src/b0/b1/B0_b1_main.res b/jscomp/build_tests/nnest/src/b0/b1/B0_b1_main.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/nnest/src/b0/b1/B0_b1_main.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/nnest/src/demo.res b/jscomp/build_tests/nnest/src/demo.res deleted file mode 100644 index fc7ba35..0000000 --- a/jscomp/build_tests/nnest/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let v = A0_a1_main.v + A0_main.v + B0_main.v + B0_b1_main.v diff --git a/jscomp/build_tests/ns/input.js b/jscomp/build_tests/ns/input.js deleted file mode 100755 index 2cb4c61..0000000 --- a/jscomp/build_tests/ns/input.js +++ /dev/null @@ -1,4 +0,0 @@ -var child_process = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -child_process.execSync(rescript_exe, { cwd: __dirname }); diff --git a/jscomp/build_tests/ns/rescript.json b/jscomp/build_tests/ns/rescript.json deleted file mode 100644 index 058894d..0000000 --- a/jscomp/build_tests/ns/rescript.json +++ /dev/null @@ -1,10 +0,0 @@ -{ - "name": "ns", - "version": "0.1.0", - "sources": ["src"], - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "namespace": true -} diff --git a/jscomp/build_tests/ns/src/demo.js b/jscomp/build_tests/ns/src/demo.js deleted file mode 100644 index 18b4316..0000000 --- a/jscomp/build_tests/ns/src/demo.js +++ /dev/null @@ -1,8 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - -var Hello$Ns = require("./hello.js"); - -console.log(Hello$Ns.a + Hello$Ns.b | 0); - -/* Not a pure module */ diff --git a/jscomp/build_tests/ns/src/demo.res b/jscomp/build_tests/ns/src/demo.res deleted file mode 100644 index b4490c8..0000000 --- a/jscomp/build_tests/ns/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log(Hello.a + Hello.b) diff --git a/jscomp/build_tests/ns/src/hello.js b/jscomp/build_tests/ns/src/hello.js deleted file mode 100644 index 928177b..0000000 --- a/jscomp/build_tests/ns/src/hello.js +++ /dev/null @@ -1,11 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - - -var a = 4; - -var b = 2; - -exports.a = a; -exports.b = b; -/* No side effect */ diff --git a/jscomp/build_tests/ns/src/hello.res b/jscomp/build_tests/ns/src/hello.res deleted file mode 100644 index 36b7020..0000000 --- a/jscomp/build_tests/ns/src/hello.res +++ /dev/null @@ -1,3 +0,0 @@ -let a = 3 + 1 - -let b = 2 diff --git a/jscomp/build_tests/post-build/input.js b/jscomp/build_tests/post-build/input.js deleted file mode 100644 index a9bee83..0000000 --- a/jscomp/build_tests/post-build/input.js +++ /dev/null @@ -1,9 +0,0 @@ -var child_process = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var out = child_process.spawnSync(rescript_exe, { encoding: "utf8" }); - -if (out.status !== 0) { - assert.fail(out.stdout + out.stderr); -} diff --git a/jscomp/build_tests/post-build/rescript.json b/jscomp/build_tests/post-build/rescript.json deleted file mode 100644 index 8e11d4d..0000000 --- a/jscomp/build_tests/post-build/rescript.json +++ /dev/null @@ -1,12 +0,0 @@ -{ - "name": "post-build", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "js-post-build": { "cmd": "cat" }, - "warnings": { - "error": "+101" - } -} diff --git a/jscomp/build_tests/post-build/src/demo.res b/jscomp/build_tests/post-build/src/demo.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/post-build/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/post-build/src/hello.res b/jscomp/build_tests/post-build/src/hello.res deleted file mode 100644 index 1bf62c4..0000000 --- a/jscomp/build_tests/post-build/src/hello.res +++ /dev/null @@ -1 +0,0 @@ -let a = 3 diff --git a/jscomp/build_tests/react_ppx/input.js b/jscomp/build_tests/react_ppx/input.js deleted file mode 100644 index 060dd91..0000000 --- a/jscomp/build_tests/react_ppx/input.js +++ /dev/null @@ -1,5 +0,0 @@ -//@ts-check -var cp = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -cp.execSync(rescript_exe, { cwd: __dirname }); diff --git a/jscomp/build_tests/react_ppx/rescript.json b/jscomp/build_tests/react_ppx/rescript.json deleted file mode 100644 index 1b1e7ab..0000000 --- a/jscomp/build_tests/react_ppx/rescript.json +++ /dev/null @@ -1,18 +0,0 @@ -{ - "name": "react-ppx-tests", - "reason": { - "react-jsx": 3 - }, - "sources": { - "dir": "src", - "subdirs": true - }, - "package-specs": [ - { - "module": "commonjs", - "in-source": true - } - ], - "suffix": ".bs.js", - "namespace": true -} diff --git a/jscomp/build_tests/react_ppx/src/React.bs.js b/jscomp/build_tests/react_ppx/src/React.bs.js deleted file mode 100644 index 3f1bab6..0000000 --- a/jscomp/build_tests/react_ppx/src/React.bs.js +++ /dev/null @@ -1,20 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - - -var Ref = {}; - -var Children = {}; - -var Context = {}; - -var Fragment = {}; - -var Suspense = {}; - -exports.Ref = Ref; -exports.Children = Children; -exports.Context = Context; -exports.Fragment = Fragment; -exports.Suspense = Suspense; -/* No side effect */ diff --git a/jscomp/build_tests/react_ppx/src/React.res b/jscomp/build_tests/react_ppx/src/React.res deleted file mode 100644 index f1aa892..0000000 --- a/jscomp/build_tests/react_ppx/src/React.res +++ /dev/null @@ -1,295 +0,0 @@ -type element - -@val external null: element = "null" - -external string: string => element = "%identity" - -external array: array => element = "%identity" - -type componentLike<'props, 'return> = 'props => 'return - -type component<'props> = componentLike<'props, element> - -@module("react") -external createElement: (component<'props>, 'props) => element = "createElement" - -@module("react") -external cloneElement: (component<'props>, 'props) => element = "cloneElement" - -@variadic @module("react") -external createElementVariadic: (component<'props>, 'props, array) => element = - "createElement" - -module Ref = { - type t<'value> - - @get external current: t<'value> => 'value = "current" - @set external setCurrent: (t<'value>, 'value) => unit = "current" -} - -@module("react") -external createRef: unit => Ref.t> = "createRef" - -module Children = { - @module("react") @scope("Children") @val - external map: (element, element => element) => element = "map" - @module("react") @scope("Children") @val - external forEach: (element, element => unit) => unit = "forEach" - @module("react") @scope("Children") @val - external count: element => int = "count" - @module("react") @scope("Children") @val - external only: element => element = "only" - @module("react") @scope("Children") @val - external toArray: element => array = "toArray" -} - -module Context = { - type t<'props> - - @get - external provider: t<'props> => component<{"value": 'props, "children": element}> = "Provider" -} - -@module("react") -external createContext: 'a => Context.t<'a> = "createContext" - -@module("react") -external forwardRef: (@uncurry ('props, Js.Nullable.t>) => element) => component<'props> = - "forwardRef" - -@module("react") -external memo: component<'props> => component<'props> = "memo" - -@module("react") -external memoCustomCompareProps: ( - component<'props>, - @uncurry ('props, 'props) => bool, -) => component<'props> = "memo" - -module Fragment = { - @obj - external makeProps: (~children: element, ~key: 'key=?, unit) => {"children": element} = "" - @module("react") - external make: component<{ - "children": element, - }> = "Fragment" -} - -module Suspense = { - @obj - external makeProps: ( - ~children: element=?, - ~fallback: element=?, - ~maxDuration: int=?, - ~key: 'key=?, - unit, - ) => {"children": option, "fallback": option, "maxDuration": option} = "" - @module("react") - external make: component<{ - "children": option, - "fallback": option, - "maxDuration": option, - }> = "Suspense" -} - -/* HOOKS */ - -/* - * Yeah, we know this api isn't great. tl;dr: useReducer instead. - * It's because useState can take functions or non-function values and treats - * them differently. Lazy initializer + callback which returns state is the - * only way to safely have any type of state and be able to update it correctly. - */ -@module("react") -external useState: (@uncurry (unit => 'state)) => ('state, ('state => 'state) => unit) = "useState" - -@module("react") -external useReducer: (@uncurry ('state, 'action) => 'state, 'state) => ('state, 'action => unit) = - "useReducer" - -@module("react") -external useReducerWithMapState: ( - @uncurry ('state, 'action) => 'state, - 'initialState, - 'initialState => 'state, -) => ('state, 'action => unit) = "useReducer" - -@module("react") -external useEffect: (@uncurry (unit => option unit>)) => unit = "useEffect" -@module("react") -external useEffect0: (@uncurry (unit => option unit>), @as(json`[]`) _) => unit = - "useEffect" -@module("react") -external useEffect1: (@uncurry (unit => option unit>), array<'a>) => unit = "useEffect" -@module("react") -external useEffect2: (@uncurry (unit => option unit>), ('a, 'b)) => unit = "useEffect" -@module("react") -external useEffect3: (@uncurry (unit => option unit>), ('a, 'b, 'c)) => unit = "useEffect" -@module("react") -external useEffect4: (@uncurry (unit => option unit>), ('a, 'b, 'c, 'd)) => unit = - "useEffect" -@module("react") -external useEffect5: (@uncurry (unit => option unit>), ('a, 'b, 'c, 'd, 'e)) => unit = - "useEffect" -@module("react") -external useEffect6: (@uncurry (unit => option unit>), ('a, 'b, 'c, 'd, 'e, 'f)) => unit = - "useEffect" -@module("react") -external useEffect7: ( - @uncurry (unit => option unit>), - ('a, 'b, 'c, 'd, 'e, 'f, 'g), -) => unit = "useEffect" - -@module("react") -external useLayoutEffect: (@uncurry (unit => option unit>)) => unit = "useLayoutEffect" -@module("react") -external useLayoutEffect0: (@uncurry (unit => option unit>), @as(json`[]`) _) => unit = - "useLayoutEffect" -@module("react") -external useLayoutEffect1: (@uncurry (unit => option unit>), array<'a>) => unit = - "useLayoutEffect" -@module("react") -external useLayoutEffect2: (@uncurry (unit => option unit>), ('a, 'b)) => unit = - "useLayoutEffect" -@module("react") -external useLayoutEffect3: (@uncurry (unit => option unit>), ('a, 'b, 'c)) => unit = - "useLayoutEffect" -@module("react") -external useLayoutEffect4: (@uncurry (unit => option unit>), ('a, 'b, 'c, 'd)) => unit = - "useLayoutEffect" -@module("react") -external useLayoutEffect5: (@uncurry (unit => option unit>), ('a, 'b, 'c, 'd, 'e)) => unit = - "useLayoutEffect" -@module("react") -external useLayoutEffect6: ( - @uncurry (unit => option unit>), - ('a, 'b, 'c, 'd, 'e, 'f), -) => unit = "useLayoutEffect" -@module("react") -external useLayoutEffect7: ( - @uncurry (unit => option unit>), - ('a, 'b, 'c, 'd, 'e, 'f, 'g), -) => unit = "useLayoutEffect" - -@module("react") -external useMemo: (@uncurry (unit => 'any)) => 'any = "useMemo" -@module("react") -external useMemo0: (@uncurry (unit => 'any), @as(json`[]`) _) => 'any = "useMemo" -@module("react") -external useMemo1: (@uncurry (unit => 'any), array<'a>) => 'any = "useMemo" -@module("react") -external useMemo2: (@uncurry (unit => 'any), ('a, 'b)) => 'any = "useMemo" -@module("react") -external useMemo3: (@uncurry (unit => 'any), ('a, 'b, 'c)) => 'any = "useMemo" -@module("react") -external useMemo4: (@uncurry (unit => 'any), ('a, 'b, 'c, 'd)) => 'any = "useMemo" -@module("react") -external useMemo5: (@uncurry (unit => 'any), ('a, 'b, 'c, 'd, 'e)) => 'any = "useMemo" -@module("react") -external useMemo6: (@uncurry (unit => 'any), ('a, 'b, 'c, 'd, 'e, 'f)) => 'any = "useMemo" -@module("react") -external useMemo7: (@uncurry (unit => 'any), ('a, 'b, 'c, 'd, 'e, 'f, 'g)) => 'any = "useMemo" - -/* This is used as return values */ -type callback<'input, 'output> = 'input => 'output - -@module("react") -external useCallback: (@uncurry ('input => 'output)) => callback<'input, 'output> = "useCallback" -@module("react") -external useCallback0: ( - @uncurry ('input => 'output), - @as(json`[]`) _, -) => callback<'input, 'output> = "useCallback" -@module("react") -external useCallback1: (@uncurry ('input => 'output), array<'a>) => callback<'input, 'output> = - "useCallback" -@module("react") -external useCallback2: (@uncurry ('input => 'output), ('a, 'b)) => callback<'input, 'output> = - "useCallback" -@module("react") -external useCallback3: (@uncurry ('input => 'output), ('a, 'b, 'c)) => callback<'input, 'output> = - "useCallback" -@module("react") -external useCallback4: ( - @uncurry ('input => 'output), - ('a, 'b, 'c, 'd), -) => callback<'input, 'output> = "useCallback" -@module("react") -external useCallback5: ( - @uncurry ('input => 'output), - ('a, 'b, 'c, 'd, 'e), -) => callback<'input, 'output> = "useCallback" -@module("react") -external useCallback6: ( - @uncurry ('input => 'output), - ('a, 'b, 'c, 'd, 'e, 'f), -) => callback<'input, 'output> = "useCallback" -@module("react") -external useCallback7: ( - @uncurry ('input => 'output), - ('a, 'b, 'c, 'd, 'e, 'f, 'g), -) => callback<'input, 'output> = "useCallback" - -@module("react") -external useContext: Context.t<'any> => 'any = "useContext" - -@module("react") external useRef: 'value => Ref.t<'value> = "useRef" - -@module("react") -external useImperativeHandle0: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - @as(json`[]`) _, -) => unit = "useImperativeHandle" - -@module("react") -external useImperativeHandle1: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - array<'a>, -) => unit = "useImperativeHandle" - -@module("react") -external useImperativeHandle2: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - ('a, 'b), -) => unit = "useImperativeHandle" - -@module("react") -external useImperativeHandle3: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - ('a, 'b, 'c), -) => unit = "useImperativeHandle" - -@module("react") -external useImperativeHandle4: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - ('a, 'b, 'c, 'd), -) => unit = "useImperativeHandle" - -@module("react") -external useImperativeHandle5: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - ('a, 'b, 'c, 'd, 'e), -) => unit = "useImperativeHandle" - -@module("react") -external useImperativeHandle6: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - ('a, 'b, 'c, 'd, 'e, 'f), -) => unit = "useImperativeHandle" - -@module("react") -external useImperativeHandle7: ( - Js.Nullable.t>, - @uncurry (unit => 'value), - ('a, 'b, 'c, 'd, 'e, 'f, 'g), -) => unit = "useImperativeHandle" - -@set -external setDisplayName: (component<'props>, string) => unit = "displayName" diff --git a/jscomp/build_tests/react_ppx/src/gpr_3695_test.bs.js b/jscomp/build_tests/react_ppx/src/gpr_3695_test.bs.js deleted file mode 100644 index 7641805..0000000 --- a/jscomp/build_tests/react_ppx/src/gpr_3695_test.bs.js +++ /dev/null @@ -1,20 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - -var Foo = require("Foo"); -var Curry = require("rescript/lib/js/curry.js"); - -var React = {}; - -var Test = {}; - -function test(className) { - return Curry._1(Foo, { - className: className - }); -} - -exports.React = React; -exports.Test = Test; -exports.test = test; -/* Foo Not a pure module */ diff --git a/jscomp/build_tests/react_ppx/src/gpr_3695_test.res b/jscomp/build_tests/react_ppx/src/gpr_3695_test.res deleted file mode 100644 index 8549013..0000000 --- a/jscomp/build_tests/react_ppx/src/gpr_3695_test.res +++ /dev/null @@ -1,11 +0,0 @@ -module React = { - type element - type componentLike<'props, 'return> = 'props => 'return -} - -module Test = { - @module @react.component - external make: (~className: string=?) => React.element = "Foo" -} - -let test = (~className) => Test.make(Test.makeProps(~className, ())) diff --git a/jscomp/build_tests/react_ppx/src/gpr_3987_test.bs.js b/jscomp/build_tests/react_ppx/src/gpr_3987_test.bs.js deleted file mode 100644 index aee858b..0000000 --- a/jscomp/build_tests/react_ppx/src/gpr_3987_test.bs.js +++ /dev/null @@ -1,74 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - -var React = require("react"); - -function makeContainer(text) { - var container = document.createElement("div"); - container.className = "container"; - var title = document.createElement("div"); - title.className = "containerTitle"; - title.innerText = text; - var content = document.createElement("div"); - content.className = "containerContent"; - container.appendChild(title); - container.appendChild(content); - document.body.appendChild(container); - return content; -} - -function makeProps(value, onChange, param) { - return { - value: value, - onChange: onChange - }; -} - -function make(_props) { - return null; -} - -var Gpr3987ReproOk = { - makeProps: makeProps, - make: make -}; - -React.createElement(make, makeProps("test", (function (param, param$1) { - - }), undefined)); - -function Gpr_3987_test$Gpr3987ReproOk2(Props) { - return null; -} - -var Gpr3987ReproOk2 = { - make: Gpr_3987_test$Gpr3987ReproOk2 -}; - -React.createElement(Gpr_3987_test$Gpr3987ReproOk2, { - value: "test", - onChange: (function (param, param$1) { - - }) - }); - -function Gpr_3987_test$Gpr3987ReproError(Props) { - return null; -} - -var Gpr3987ReproError = { - make: Gpr_3987_test$Gpr3987ReproError -}; - -React.createElement(Gpr_3987_test$Gpr3987ReproError, { - value: "test", - onChange: (function (param, param$1) { - - }) - }); - -exports.makeContainer = makeContainer; -exports.Gpr3987ReproOk = Gpr3987ReproOk; -exports.Gpr3987ReproOk2 = Gpr3987ReproOk2; -exports.Gpr3987ReproError = Gpr3987ReproError; -/* Not a pure module */ diff --git a/jscomp/build_tests/react_ppx/src/gpr_3987_test.res b/jscomp/build_tests/react_ppx/src/gpr_3987_test.res deleted file mode 100644 index de195e3..0000000 --- a/jscomp/build_tests/react_ppx/src/gpr_3987_test.res +++ /dev/null @@ -1,51 +0,0 @@ -// Entry point -@val external document: {..} = "document" - -// We're using raw DOM manipulations here, to avoid making you read -// ReasonReact when you might precisely be trying to learn it for the first -// time through the examples later. -let makeContainer = text => { - let container = document["createElement"]("div") - container["className"] = "container" - - let title = document["createElement"]("div") - title["className"] = "containerTitle" - title["innerText"] = text - - let content = document["createElement"]("div") - content["className"] = "containerContent" - - let () = container["appendChild"](title) - let () = container["appendChild"](content) - let () = document["body"]["appendChild"](container) - - content -} - -/* This uncurried prop definition compiles */ -module Gpr3987ReproOk = { - let makeProps = (~value: string, ~onChange: (. string, int) => unit, ()) => - {"value": value, "onChange": onChange} - - let make = (_props: {"value": string, "onChange": (. string, int) => unit}) => React.null -} - -let _ = ()} /> - -/* Extracted type for the uncurried prop compiles as well */ -module Gpr3987ReproOk2 = { - type onChange = (. string, int) => unit - - @react.component - let make = (~value as _, ~onChange as _: onChange) => React.null -} - -let _ = ()} /> - -/* Inline uncurried prop type causes an error */ -module Gpr3987ReproError = { - @react.component - let make = (~value as _: string, ~onChange as _: (. string, int) => unit) => React.null -} - -let _ = ()} /> diff --git a/jscomp/build_tests/react_ppx/src/recursive_component_test.bs.js b/jscomp/build_tests/react_ppx/src/recursive_component_test.bs.js deleted file mode 100644 index 860ce62..0000000 --- a/jscomp/build_tests/react_ppx/src/recursive_component_test.bs.js +++ /dev/null @@ -1,32 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -'use strict'; - -var React = require("react"); - -function make(Props) { - var foo = Props.foo; - return React.createElement(make, { - foo: foo - }); -} - -function mm(x) { - return make$1({ - b: !x.b - }); -} - -function make$1(props) { - return mm({ - b: props.b - }); -} - -var Rec = { - make: make$1, - mm: mm -}; - -exports.make = make; -exports.Rec = Rec; -/* react Not a pure module */ diff --git a/jscomp/build_tests/react_ppx/src/recursive_component_test.res b/jscomp/build_tests/react_ppx/src/recursive_component_test.res deleted file mode 100644 index cdd39eb..0000000 --- a/jscomp/build_tests/react_ppx/src/recursive_component_test.res +++ /dev/null @@ -1,19 +0,0 @@ -@@warning("-39") -// https://github.com/rescript-lang/rescript-compiler/issues/4511 -/* -[@bs.config { - flags : [|"-dsource"|] -}]; -*/ -@react.component -let rec make = (~foo, ()) => React.createElement(make, makeProps(~foo, ())) - -@@jsxConfig({version:4}) - -module Rec = { - @react.component - let rec make = (~b) => { - mm({b:b}) - } - and mm = (x) => make({b: ! x.b}) -} diff --git a/jscomp/build_tests/rerror/input.js b/jscomp/build_tests/rerror/input.js deleted file mode 100644 index 54c50c0..0000000 --- a/jscomp/build_tests/rerror/input.js +++ /dev/null @@ -1,32 +0,0 @@ -var child_process = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -child_process.spawnSync(`${rescript_exe} clean`, { - cwd: __dirname, - encoding: "utf8", -}); -var o = child_process.spawnSync(rescript_exe, { - cwd: __dirname, - encoding: "utf8", - shell: true, -}); - -// verify the output is in reason syntax -var u = o.stdout.match(/=>/g); - -var lines = o.stdout - .split("\n") - .map(x => x.trim()) - .filter(Boolean); -// console.log(`lines: \n${lines}`) -// console.log(lines[4]) -var test = false; -for (var i = 0; i < lines.length; ++i) { - if (lines[i] === "We've found a bug for you!") { - console.log(`line ${i} found`); - assert.ok(/src\/demo.res:1:21-23/.test(lines[i + 1])); - test = true; - } -} -assert.ok(test); -assert.ok(u.length === 2); diff --git a/jscomp/build_tests/rerror/rescript.json b/jscomp/build_tests/rerror/rescript.json deleted file mode 100644 index cfbe852..0000000 --- a/jscomp/build_tests/rerror/rescript.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "name": "rerror", - "version": "0.1.0", - "sources": ["src"], - "bs-dependencies": [] -} diff --git a/jscomp/build_tests/rerror/src/demo.res b/jscomp/build_tests/rerror/src/demo.res deleted file mode 100644 index f0498cc..0000000 --- a/jscomp/build_tests/rerror/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let x: int => int = "x" diff --git a/jscomp/build_tests/rerror/tasks.json b/jscomp/build_tests/rerror/tasks.json deleted file mode 100644 index 2936762..0000000 --- a/jscomp/build_tests/rerror/tasks.json +++ /dev/null @@ -1,35 +0,0 @@ -{ - "version": "0.1.0", - "command": "npm", - "options": { - "cwd": "${workspaceRoot}" - }, - "isShellCommand": true, - "args": ["run", "watch"], - "showOutput": "always", - "isBackground": true, - "problemMatcher": { - "fileLocation": "absolute", - "owner": "ocaml", - "watching": { - "activeOnStart": false, - "beginsPattern": ">>>> Start compiling", - "endsPattern": ">>>> Finish compiling" - }, - "pattern": [ - { - "regexp": "^File \"(.*)\", line (\\d+)(?:, characters (\\d+)-(\\d+))?:$", - "file": 1, - "line": 2, - "column": 3, - "endColumn": 4 - }, - { - "regexp": "^(?:(?:Parse\\s+)?(Warning|[Ee]rror)(?:\\s+\\d+)?:)?\\s+(.*)$", - "severity": 1, - "message": 2, - "loop": true - } - ] - } -} diff --git a/jscomp/build_tests/scoped_ppx/.gitignore b/jscomp/build_tests/scoped_ppx/.gitignore deleted file mode 100644 index c476e05..0000000 --- a/jscomp/build_tests/scoped_ppx/.gitignore +++ /dev/null @@ -1 +0,0 @@ -.merlin \ No newline at end of file diff --git a/jscomp/build_tests/scoped_ppx/input.js b/jscomp/build_tests/scoped_ppx/input.js deleted file mode 100644 index 310fbfb..0000000 --- a/jscomp/build_tests/scoped_ppx/input.js +++ /dev/null @@ -1,14 +0,0 @@ -var cp = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -cp.execSync(rescript_exe, { cwd: __dirname, encoding: "utf8" }); - -var output = cp.execSync(`${rescript_exe} build -- -t commands src/hello.ast`, { - cwd: __dirname, - encoding: "utf8", -}); -assert( - /-ppx '.*\/test\.js -hello' -ppx '.*\/test\.js -heyy' -ppx .*test\.js/.test( - output - ) -); diff --git a/jscomp/build_tests/scoped_ppx/node_modules/@hongbo/ppx1/test.js b/jscomp/build_tests/scoped_ppx/node_modules/@hongbo/ppx1/test.js deleted file mode 100755 index 34ea829..0000000 --- a/jscomp/build_tests/scoped_ppx/node_modules/@hongbo/ppx1/test.js +++ /dev/null @@ -1,12 +0,0 @@ -#!/usr/bin/env node -//@ts-check -var fs = require('fs') - -// let [_node, _js, file_in, file_out] = process.argv -var file_in = process.argv[process.argv.length - 2] -var file_out = process.argv[process.argv.length - 1] -// console.log(process.argv) -// debugger; -fs.createReadStream(file_in) - .pipe(fs.createWriteStream(file_out)) - diff --git a/jscomp/build_tests/scoped_ppx/rescript.json b/jscomp/build_tests/scoped_ppx/rescript.json deleted file mode 100644 index 42483ad..0000000 --- a/jscomp/build_tests/scoped_ppx/rescript.json +++ /dev/null @@ -1,11 +0,0 @@ -{ - "ppx-flags": [ - ["@hongbo/ppx1/test.js", "-hello"], - ["@hongbo/ppx1/test.js", "-heyy"], - "@hongbo/ppx1/test.js" - ], - "sources": { - "dir": "src" - }, - "name": "hello" -} diff --git a/jscomp/build_tests/scoped_ppx/src/hello.res b/jscomp/build_tests/scoped_ppx/src/hello.res deleted file mode 100644 index ab49c63..0000000 --- a/jscomp/build_tests/scoped_ppx/src/hello.res +++ /dev/null @@ -1 +0,0 @@ -let v = 1 diff --git a/jscomp/build_tests/super_errors/.gitignore b/jscomp/build_tests/super_errors/.gitignore deleted file mode 100644 index e0473fd..0000000 --- a/jscomp/build_tests/super_errors/.gitignore +++ /dev/null @@ -1 +0,0 @@ -fixtures/*.js diff --git a/jscomp/build_tests/super_errors/README.md b/jscomp/build_tests/super_errors/README.md deleted file mode 100644 index b0c6191..0000000 --- a/jscomp/build_tests/super_errors/README.md +++ /dev/null @@ -1,5 +0,0 @@ -Special tests for super errors (the pretty error display). - -Follow CONTRIBUTING.md and build the project, then run `node ./jscomp/build_tests/super_errors/input.js` at the root of the project to check the tests against previous snapshots. - -Run `node ./jscomp/build_tests/super_errors/input.js update` to update the snapshots (assuming you've made some changes to super errors' display and/or messages). diff --git a/jscomp/build_tests/super_errors/expected/DerivingAccessorsRecordParam.res.expected b/jscomp/build_tests/super_errors/expected/DerivingAccessorsRecordParam.res.expected deleted file mode 100644 index 2ac313b..0000000 --- a/jscomp/build_tests/super_errors/expected/DerivingAccessorsRecordParam.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/DerivingAccessorsRecordParam.res:2:10-25 - - 1 │ @deriving(accessors) - 2 │ type t = Struct({a: int}) - 3 │ - - @deriving(accessors) from a variant record argument is unsupported. Either define the record type separately from the variant type or use a positional argument. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected b/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected deleted file mode 100644 index 7f3f6db..0000000 --- a/jscomp/build_tests/super_errors/expected/RecordInclusion.res.expected +++ /dev/null @@ -1,22 +0,0 @@ - - We've found a bug for you! - /.../fixtures/RecordInclusion.res:3:5-5:1 - - 1 │ module M : { - 2 │ type t<'a, 'b, 'c> = {x:int, y:list<('a, 'b)>, z:int} - 3 │ } = { - 4 │  type t<'a, 'b, 'c> = {x:int, y:list<('a, 'c)>, z:int} - 5 │ } - 6 │ - - Signature mismatch: - ... - Type declarations do not match: - type t<'a, 'b, 'c> = {x: int, y: list<('a, 'c)>, z: int} - is not included in - type t<'a, 'b, 'c> = {x: int, y: list<('a, 'b)>, z: int} - /.../fixtures/RecordInclusion.res:2:3-55: - Expected declaration - /.../fixtures/RecordInclusion.res:4:3-55: - Actual declaration - The types for field y are not equal. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UncurriedArgsNotApplied.res.expected b/jscomp/build_tests/super_errors/expected/UncurriedArgsNotApplied.res.expected deleted file mode 100644 index ed86996..0000000 --- a/jscomp/build_tests/super_errors/expected/UncurriedArgsNotApplied.res.expected +++ /dev/null @@ -1,15 +0,0 @@ - - We've found a bug for you! - /.../fixtures/UncurriedArgsNotApplied.res:3:15-21 - - 1 │ let apply = (fn: (. unit) => option) => fn(. ()) - 2 │ - 3 │ let _ = apply(Some(1)) - 4 │ - - This value might need to be wrapped in a function that takes an extra - parameter of type unit - - Here's the original error message - This has type: option<'a> - But it's expected to have type: (. unit) => option \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedImplIntf.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedImplIntf.res.expected deleted file mode 100644 index ffdcb97..0000000 --- a/jscomp/build_tests/super_errors/expected/UntaggedImplIntf.res.expected +++ /dev/null @@ -1,29 +0,0 @@ - - We've found a bug for you! - /.../fixtures/UntaggedImplIntf.res:3:5-5:1 - - 1 │ module M: { - 2 │ @unboxed type t = | @as(null) A - 3 │ } = { - 4 │  type t = | @as(null) A - 5 │ } - - Signature mismatch: - Modules do not match: - { - type t = @as(null) A -} - is not included in - { - @unboxed type t = @as(null) A -} - Type declarations do not match: - type t = @as(null) A - is not included in - @unboxed type t = @as(null) A - /.../fixtures/UntaggedImplIntf.res:2:12-33: - Expected declaration - /.../fixtures/UntaggedImplIntf.res:4:3-24: - Actual declaration - Their internal representations differ: - the second declaration uses unboxed representation. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected deleted file mode 100644 index fd11bbf..0000000 --- a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary1.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/UntaggedNonUnary1.res:2:1-27 - - 1 │ @unboxed - 2 │ type t = Tuple(int, string) - 3 │ - - This untagged variant definition is invalid: Constructor Tuple has more than one argument. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected deleted file mode 100644 index 220c6f6..0000000 --- a/jscomp/build_tests/super_errors/expected/UntaggedNonUnary2.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/UntaggedNonUnary2.res:2:1-42 - - 1 │ @unboxed - 2 │ type t = Tuple(int, string) | Float(float) - 3 │ - - This untagged variant definition is invalid: Constructor Tuple has more than one argument. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedTupleAndArray.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedTupleAndArray.res.expected deleted file mode 100644 index f472163..0000000 --- a/jscomp/build_tests/super_errors/expected/UntaggedTupleAndArray.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/UntaggedTupleAndArray.res:4:3-21 - - 2 │ type t = - 3 │ | Array(array) - 4 │ | Tuple((int, int)) - 5 │ - - This untagged variant definition is invalid: At most one case can be an array or tuple type. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected b/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected deleted file mode 100644 index 77ebe41..0000000 --- a/jscomp/build_tests/super_errors/expected/UntaggedUnknown.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/UntaggedUnknown.res:2:10-26 - - 1 │ @unboxed - 2 │ type t = List(list) | Float(float) - 3 │ - - This untagged variant definition is invalid: Case List has a payload that is not of one of the recognized shapes (object, array, etc). Then it must be the only case with payloads. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/arity_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/arity_mismatch.res.expected deleted file mode 100644 index 66063e7..0000000 --- a/jscomp/build_tests/super_errors/expected/arity_mismatch.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/arity_mismatch.res:2:21-27 - - 1 │ let makeVar = (. ~f, ()) => 34 - 2 │ let makeVariables = makeVar(.~f=f => f) - 3 │ - - This uncurried function has type (. ~f: 'a => 'a, unit) => int - It is applied with 1 arguments but it requires 2. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/arity_mismatch2.res.expected b/jscomp/build_tests/super_errors/expected/arity_mismatch2.res.expected deleted file mode 100644 index 0bd3bd9..0000000 --- a/jscomp/build_tests/super_errors/expected/arity_mismatch2.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/arity_mismatch2.res:2:21-27 - - 1 │ let makeVar = (. f, ()) => 34 - 2 │ let makeVariables = makeVar(. 1, 2, 3) - 3 │ - - This uncurried function has type (. 'a, unit) => int - It is applied with 3 arguments but it requires 2. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/arity_mismatch3.res.expected b/jscomp/build_tests/super_errors/expected/arity_mismatch3.res.expected deleted file mode 100644 index 1a54441..0000000 --- a/jscomp/build_tests/super_errors/expected/arity_mismatch3.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/arity_mismatch3.res:1:21-33 - - 1 │ Belt.Array.mapU([], (. a, b) => 1) - 2 │ - - This function expected 1 argument, but got 2 \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/array_item_type_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/array_item_type_mismatch.res.expected deleted file mode 100644 index 54c99ad..0000000 --- a/jscomp/build_tests/super_errors/expected/array_item_type_mismatch.res.expected +++ /dev/null @@ -1,17 +0,0 @@ - - We've found a bug for you! - /.../fixtures/array_item_type_mismatch.res:1:16-22 - - 1 │ let x = [1, 2, "hello"] - 2 │ - - This array item has type: string - But this array is expected to have items of type: int - - Arrays can only contain items of the same type. - - Possible solutions: - - Convert all values in the array to the same type. - - Use a tuple, if your array is of fixed length. Tuples can mix types freely, and compiles to a JavaScript array. Example of a tuple: `let myTuple = (10, "hello", 15.5, true) - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/await.res.expected b/jscomp/build_tests/super_errors/expected/await.res.expected deleted file mode 100644 index bbea40f..0000000 --- a/jscomp/build_tests/super_errors/expected/await.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/await.res:4:9-17 - - 2 │ let foo = async () => { - 3 │ let _ = () - 4 │ () => await a() - 5 │ } - 6 │ - - Await on expression not in an async context \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/bigint_match_literal.res.expected b/jscomp/build_tests/super_errors/expected/bigint_match_literal.res.expected deleted file mode 100644 index 2093c55..0000000 --- a/jscomp/build_tests/super_errors/expected/bigint_match_literal.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - Warning number 11 - /.../fixtures/bigint_match_literal.res:3:3-4 - - 1 │ let m1 = switch 1n { - 2 │ | 0001n => 1 - 3 │ | 1n => 1 - 4 │ | -0001n => -1 - 5 │ | _ => 0 - - this match case is unused. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/c_for_u_in_c_mode.res.expected b/jscomp/build_tests/super_errors/expected/c_for_u_in_c_mode.res.expected deleted file mode 100644 index a76943f..0000000 --- a/jscomp/build_tests/super_errors/expected/c_for_u_in_c_mode.res.expected +++ /dev/null @@ -1,28 +0,0 @@ - - We've found a bug for you! - /.../fixtures/c_for_u_in_c_mode.res:3:5-5:1 - - 1 │ module Foo: { - 2 │ let add: (. int, int) => int - 3 │ } = { - 4 │  let add = (a, b) => a + b - 5 │ } - 6 │ - - Signature mismatch: - Modules do not match: - { - let add: (int, int) => int -} - is not included in - { - let add: (. int, int) => int -} - Values do not match: - let add: (int, int) => int (curried) - is not included in - let add: (. int, int) => int (uncurried) - /.../fixtures/c_for_u_in_c_mode.res:2:3-30: - Expected declaration - /.../fixtures/c_for_u_in_c_mode.res:4:7-9: - Actual declaration \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/c_for_u_in_u_mode.res.expected b/jscomp/build_tests/super_errors/expected/c_for_u_in_u_mode.res.expected deleted file mode 100644 index 3b3462a..0000000 --- a/jscomp/build_tests/super_errors/expected/c_for_u_in_u_mode.res.expected +++ /dev/null @@ -1,29 +0,0 @@ - - We've found a bug for you! - /.../fixtures/c_for_u_in_u_mode.res:5:5-8:1 - - 3 │ module Foo: { - 4 │ let add: (int, int) => int - 5 │ } = { - 6 │  @@uncurried.swap - 7 │  let add = (. a, b) => a + b - 8 │ } - 9 │ - - Signature mismatch: - Modules do not match: - { - let add: (int, int) => int -} - is not included in - { - let add: (int, int) => int -} - Values do not match: - let add: (int, int) => int (curried) - is not included in - let add: (int, int) => int (uncurried) - /.../fixtures/c_for_u_in_u_mode.res:4:3-28: - Expected declaration - /.../fixtures/c_for_u_in_u_mode.res:7:7-9: - Actual declaration \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/collections.res.expected b/jscomp/build_tests/super_errors/expected/collections.res.expected deleted file mode 100644 index 41b190b..0000000 --- a/jscomp/build_tests/super_errors/expected/collections.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/collections.res:2:12-18 - - 1 │ /* wrong type in a list */ - 2 │ list{1, 2, "Hello"}->ignore - 3 │ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/comparison_operator.res.expected b/jscomp/build_tests/super_errors/expected/comparison_operator.res.expected deleted file mode 100644 index b2988d3..0000000 --- a/jscomp/build_tests/super_errors/expected/comparison_operator.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/comparison_operator.res:3:17 - - 1 │ let f = Some(0) - 2 │ - 3 │ let x = 100 === f - 4 │ - - This has type: option - But it's being compared to something of type: int - - You can only compare things of the same type. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/component_missing_prop.res.expected b/jscomp/build_tests/super_errors/expected/component_missing_prop.res.expected deleted file mode 100644 index 3df4b8f..0000000 --- a/jscomp/build_tests/super_errors/expected/component_missing_prop.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/component_missing_prop.res:5:34-35 - - 3 │ type props<'name> = {name: 'name} - 4 │ - 5 │ let make = (): props<'name> => {} - 6 │ } - 7 │ - - Some required record fields are missing: - name. If this is a component, add the missing props. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/component_missing_prop_test.res.expected b/jscomp/build_tests/super_errors/expected/component_missing_prop_test.res.expected deleted file mode 100644 index 2e6e0c8..0000000 --- a/jscomp/build_tests/super_errors/expected/component_missing_prop_test.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/component_missing_prop_test.res:5:35-39 - - 3 │ type props<'name> = {name: 'name} - 4 │ - 5 │ let make = (): props<'name> => {nname: "hello"} - 6 │ } - 7 │ - - The field nname does not belong to type props - - This record expression is expected to have type props<'name> -Hint: Did you mean name? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/curried_expected.res.expected b/jscomp/build_tests/super_errors/expected/curried_expected.res.expected deleted file mode 100644 index 5b789c5..0000000 --- a/jscomp/build_tests/super_errors/expected/curried_expected.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/curried_expected.res:3:24-38 - - 1 │ let expectCurried = f => f(1) + 2 - 2 │ - 3 │ let z1 = expectCurried((. x, y) => x+y) - 4 │ - - This function is an uncurried function where a curried function is expected \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/curry_in_uncurry.res.expected b/jscomp/build_tests/super_errors/expected/curry_in_uncurry.res.expected deleted file mode 100644 index dfd086b..0000000 --- a/jscomp/build_tests/super_errors/expected/curry_in_uncurry.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/curry_in_uncurry.res:3:1 - - 1 │ let f = (a, b) => a + b - 2 │ - 3 │ f(. 2, 2)->Js.log - 4 │ - - This function is a curried function where an uncurried function is expected \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/dict_inference.res.expected b/jscomp/build_tests/super_errors/expected/dict_inference.res.expected deleted file mode 100644 index 42f32b8..0000000 --- a/jscomp/build_tests/super_errors/expected/dict_inference.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/dict_inference.res:4:31-33 - - 2 │ dict->Js.Dict.set("someKey1", 1) - 3 │ dict->Js.Dict.set("someKey2", 2) - 4 │ dict->Js.Dict.set("someKey2", "2") - 5 │ - - This has type: string - But this function argument is expecting: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/directive_attr.res.expected b/jscomp/build_tests/super_errors/expected/directive_attr.res.expected deleted file mode 100644 index ee4b5d8..0000000 --- a/jscomp/build_tests/super_errors/expected/directive_attr.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/directive_attr.res:1:1-11 - - 1 │ @@directive - 2 │ - - expect string literal \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/duplicate_labels_error.res.expected b/jscomp/build_tests/super_errors/expected/duplicate_labels_error.res.expected deleted file mode 100644 index 6a63b49..0000000 --- a/jscomp/build_tests/super_errors/expected/duplicate_labels_error.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/duplicate_labels_error.res:3:3-6 - - 1 │ type rcrd = { - 2 │ name: string, - 3 │ name: int, - 4 │ } - 5 │ - - The field name is defined several times in the record rcrd. Fields can only be added once to a record. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/fieldNotOptional.res.expected b/jscomp/build_tests/super_errors/expected/fieldNotOptional.res.expected deleted file mode 100644 index c4069fb..0000000 --- a/jscomp/build_tests/super_errors/expected/fieldNotOptional.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/fieldNotOptional.res:3:19 - - 1 │ type r = {nonopt: int, opt?: string} - 2 │ - 3 │ let v = {nonopt: ?3, opt: ?None} - 4 │ - 5 │ let f = r => - - Field nonopt is not optional in type r. Use without ? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/function_argument_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/function_argument_mismatch.res.expected deleted file mode 100644 index 3905f12..0000000 --- a/jscomp/build_tests/super_errors/expected/function_argument_mismatch.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/function_argument_mismatch.res:3:28-30 - - 1 │ let makeName = (s, i) => s ++ i - 2 │ - 3 │ let name = makeName("123", 123) - 4 │ - - This has type: int - But this function argument is expecting: string - - You can convert int to string with Belt.Int.toString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/function_call_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/function_call_mismatch.res.expected deleted file mode 100644 index d3cee63..0000000 --- a/jscomp/build_tests/super_errors/expected/function_call_mismatch.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/function_call_mismatch.res:6:3-10 - - 4 │ - 5 │ let cloneInTemp = (temp: string): string => { - 6 │ cd(temp) - 7 │ exec("git clone git@github.com:myorg/myrepo.git") - 8 │ } - - This function call returns: string - But it's expected to return: unit \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/function_return_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/function_return_mismatch.res.expected deleted file mode 100644 index dc0dcc3..0000000 --- a/jscomp/build_tests/super_errors/expected/function_return_mismatch.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/function_return_mismatch.res:9:3-5 - - 7 │ - 8 │ let x = fnExpectingCleanup(() => { - 9 │ 123 - 10 │ }) - 11 │ - - This has type: int - But it's expected to have type: cleanup (defined as unit => unit) \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/highlighting1.res.expected b/jscomp/build_tests/super_errors/expected/highlighting1.res.expected deleted file mode 100644 index 3e79ccf..0000000 --- a/jscomp/build_tests/super_errors/expected/highlighting1.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/highlighting1.res:1:14-3:3 - - 1 │ let a: int = "hel - 2 │ - 3 │ lo" - 4 │ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/highlighting2.res.expected b/jscomp/build_tests/super_errors/expected/highlighting2.res.expected deleted file mode 100644 index ddce993..0000000 --- a/jscomp/build_tests/super_errors/expected/highlighting2.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/highlighting2.res:2:36-4:25 - - 1 ┆ - 2 ┆ let a: int = "hel - 3 ┆ - 4 ┆ lo" - 5 ┆ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/highlighting3.res.expected b/jscomp/build_tests/super_errors/expected/highlighting3.res.expected deleted file mode 100644 index ad49ca1..0000000 --- a/jscomp/build_tests/super_errors/expected/highlighting3.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/highlighting3.res:2:14-4:16 - - 1 │ - 2 │ let a: int = "helllllll - 3 │ - 4 │ loooooooooooooo" - 5 │ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/highlighting4.res.expected b/jscomp/build_tests/super_errors/expected/highlighting4.res.expected deleted file mode 100644 index 0b3ce13..0000000 --- a/jscomp/build_tests/super_errors/expected/highlighting4.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - Warning number 3 (configured as error) - /.../fixtures/highlighting4.res:5:10 - - 3 │ @deprecated - 4 │ type a = int - 5 │ type b = a - 6 │ - - deprecated: a \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/highlighting5.res.expected b/jscomp/build_tests/super_errors/expected/highlighting5.res.expected deleted file mode 100644 index 6e6ab03..0000000 --- a/jscomp/build_tests/super_errors/expected/highlighting5.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/highlighting5.res:2:14-100 - - 1 │ /* overflows in the terminal */ - 2 │ let a: int = "hellllllllllllllllllllllllllllllllllllllllllllllllllllllll - │ lllllllllllllllllllllllllll" - 3 │ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/highlighting6.res.expected b/jscomp/build_tests/super_errors/expected/highlighting6.res.expected deleted file mode 100644 index d57cd61..0000000 --- a/jscomp/build_tests/super_errors/expected/highlighting6.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/highlighting6.res:2:9-13 - - 1 │ let aaaaa = 10 - 2 │ let b = aaaab - 3 │ - - The value aaaab can't be found - - Hint: Did you mean aaaaa? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/if_branch_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/if_branch_mismatch.res.expected deleted file mode 100644 index 714a6f0..0000000 --- a/jscomp/build_tests/super_errors/expected/if_branch_mismatch.res.expected +++ /dev/null @@ -1,16 +0,0 @@ - - We've found a bug for you! - /.../fixtures/if_branch_mismatch.res:4:3-5 - - 2 │ "123" - 3 │ } else { - 4 │ 123 - 5 │ } - 6 │ - - This has type: int - But this if statement is expected to return: string - - if expressions must return the same type in all branches (if, else if, else). - - You can convert int to string with Belt.Int.toString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/if_condition_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/if_condition_mismatch.res.expected deleted file mode 100644 index f81ffca..0000000 --- a/jscomp/build_tests/super_errors/expected/if_condition_mismatch.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/if_condition_mismatch.res:1:12-18 - - 1 │ let x = if "horse" { - 2 │ () - 3 │ } - - This has type: string - But if conditions must always be of type: bool - - To fix this, change the highlighted code so it evaluates to a bool. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/intoverflow.res.expected b/jscomp/build_tests/super_errors/expected/intoverflow.res.expected deleted file mode 100644 index abf0e9f..0000000 --- a/jscomp/build_tests/super_errors/expected/intoverflow.res.expected +++ /dev/null @@ -1,57 +0,0 @@ - - Warning number 107 - /.../fixtures/intoverflow.res:2:15-27 - - 1 │ let v1: int = 2_147_483_647 // max int - 2 │ let v2: int = 2_147_483_648 // overflow - 3 │ let v3: int = 2_147_483_649 // overflow - 4 │ let v4: int = -2_147_483_647 - - Integer literal exceeds the range of representable integers of type int - - - Warning number 107 - /.../fixtures/intoverflow.res:3:15-27 - - 1 │ let v1: int = 2_147_483_647 // max int - 2 │ let v2: int = 2_147_483_648 // overflow - 3 │ let v3: int = 2_147_483_649 // overflow - 4 │ let v4: int = -2_147_483_647 - 5 │ let v5: int = -2_147_483_648 // min int - - Integer literal exceeds the range of representable integers of type int - - - Warning number 107 - /.../fixtures/intoverflow.res:6:16-28 - - 4 │ let v4: int = -2_147_483_647 - 5 │ let v5: int = -2_147_483_648 // min int - 6 │ let v6: int = -2_147_483_649 // underflow - 7 │ - 8 │ // hex - - Integer literal exceeds the range of representable integers of type int - - - Warning number 107 - /.../fixtures/intoverflow.res:11:14-26 - - 9 │ let v7: int = 0xFFFF_FFFF // -1 - 10 │ let v8: int = -0xFFFF_FFFF // 1 - 11 │ let v9:int = 0x1_0000_0000 // overflow - 12 │ let v10:int = -0x1_0000_0000 // underflow - 13 │ - - Integer literal exceeds the range of representable integers of type int - - - Warning number 107 - /.../fixtures/intoverflow.res:12:16-28 - - 10 │ let v8: int = -0xFFFF_FFFF // 1 - 11 │ let v9:int = 0x1_0000_0000 // overflow - 12 │ let v10:int = -0x1_0000_0000 // underflow - 13 │ - - Integer literal exceeds the range of representable integers of type int \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/jinterp.res.expected b/jscomp/build_tests/super_errors/expected/jinterp.res.expected deleted file mode 100644 index 7eb7ad3..0000000 --- a/jscomp/build_tests/super_errors/expected/jinterp.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - 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/expected/math_operator_constant.res.expected b/jscomp/build_tests/super_errors/expected/math_operator_constant.res.expected deleted file mode 100644 index f2251ee..0000000 --- a/jscomp/build_tests/super_errors/expected/math_operator_constant.res.expected +++ /dev/null @@ -1,20 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_constant.res:3:15-17 - - 1 │ let num = 0 - 2 │ - 3 │ let x = num + 12. - 4 │ - - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 12. an int by removing the dot or explicitly converting to int - - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/math_operator_float.res.expected b/jscomp/build_tests/super_errors/expected/math_operator_float.res.expected deleted file mode 100644 index cd0fffa..0000000 --- a/jscomp/build_tests/super_errors/expected/math_operator_float.res.expected +++ /dev/null @@ -1,20 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_float.res:3:9-11 - - 1 │ let num = 0 - 2 │ - 3 │ let x = num +. 12. - 4 │ - - This has type: int - But it's being used with the +. operator, which works on: float - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type float. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Change the operator to +, which works on int - - You can convert int to float with Belt.Int.toFloat. - If this is a literal, try a number with a trailing dot (e.g. 20.). \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/math_operator_int.res.expected b/jscomp/build_tests/super_errors/expected/math_operator_int.res.expected deleted file mode 100644 index ebccfbe..0000000 --- a/jscomp/build_tests/super_errors/expected/math_operator_int.res.expected +++ /dev/null @@ -1,20 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_int.res:3:9-11 - - 1 │ let num = 0. - 2 │ - 3 │ let x = num + 12. - 4 │ - - This has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Change the operator to +., which works on float - - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/math_operator_string.res.expected b/jscomp/build_tests/super_errors/expected/math_operator_string.res.expected deleted file mode 100644 index cb03dfa..0000000 --- a/jscomp/build_tests/super_errors/expected/math_operator_string.res.expected +++ /dev/null @@ -1,16 +0,0 @@ - - We've found a bug for you! - /.../fixtures/math_operator_string.res:1:9-15 - - 1 │ let x = "hello" + "what" - 2 │ - - This has type: string - But it's being used with the + operator, which works on: int - - Are you looking to concatenate strings? Use the operator ++, which concatenates strings. - - Possible solutions: - - Change the + operator to ++ to concatenate strings instead. - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/method_arity_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/method_arity_mismatch.res.expected deleted file mode 100644 index e57bb53..0000000 --- a/jscomp/build_tests/super_errors/expected/method_arity_mismatch.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/method_arity_mismatch.res:3:3-11 - - 1 │ let f = obj => { - 2 │ obj["hi"](.1, 2) - 3 │ obj["hi"](.1) - 4 │ } - 5 │ - - This uncurried function has type (. int, int) => unit - It is applied with 1 arguments but it requires 2. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/missing_label.res.expected b/jscomp/build_tests/super_errors/expected/missing_label.res.expected deleted file mode 100644 index cc693a3..0000000 --- a/jscomp/build_tests/super_errors/expected/missing_label.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/missing_label.res:3:9 - - 1 │ let f = (~a) => a ++ "" - 2 │ - 3 │ let _ = f("") - 4 │ - - Label ~a was omitted in the application of this labeled function. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/missing_labels.res.expected b/jscomp/build_tests/super_errors/expected/missing_labels.res.expected deleted file mode 100644 index 3783b11..0000000 --- a/jscomp/build_tests/super_errors/expected/missing_labels.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/missing_labels.res:3:9 - - 1 │ let f = (~a, ~b) => a ++ b - 2 │ - 3 │ let _ = f("", "") - 4 │ - - Labels ~a, ~b were omitted in the application of this labeled function. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/modules1.res.expected b/jscomp/build_tests/super_errors/expected/modules1.res.expected deleted file mode 100644 index 309f16a..0000000 --- a/jscomp/build_tests/super_errors/expected/modules1.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/modules1.res:1:9-13 - - 1 │ let b = Foo.b - 2 │ - - The module or file Foo can't be found. - - If it's a third-party dependency: - - Did you add it to the "bs-dependencies" or "bs-dev-dependencies" in bsconfig.json? - - Did you include the file's directory to the "sources" in bsconfig.json? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/modules2.res.expected b/jscomp/build_tests/super_errors/expected/modules2.res.expected deleted file mode 100644 index b1b5ad1..0000000 --- a/jscomp/build_tests/super_errors/expected/modules2.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/modules2.res:1:9-14 - - 1 │ let b = List.b - 2 │ - - The value b can't be found in List \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/modules3.res.expected b/jscomp/build_tests/super_errors/expected/modules3.res.expected deleted file mode 100644 index 3e6b3a1..0000000 --- a/jscomp/build_tests/super_errors/expected/modules3.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/modules3.res:11:11-21 - - 9 │ } - 10 │ - 11 │ let asd = A.B.C.D.aaa - 12 │ - 13 │ /* there's another, unrelated test, that we're just gonna paste here. W - │ e won't - - The value aaa can't be found in A.B.C.D - - Hint: Did you mean aaaa? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/moreArguments1.res.expected b/jscomp/build_tests/super_errors/expected/moreArguments1.res.expected deleted file mode 100644 index 3eb4dd6..0000000 --- a/jscomp/build_tests/super_errors/expected/moreArguments1.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/moreArguments1.res:2:9-15 - - 1 │ let x = (~a, ~b) => a + b - 2 │ let y = x(~a=2) + 2 - 3 │ - - This call is missing an argument of type (~b: int) \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/moreArguments2.res.expected b/jscomp/build_tests/super_errors/expected/moreArguments2.res.expected deleted file mode 100644 index 8c433b0..0000000 --- a/jscomp/build_tests/super_errors/expected/moreArguments2.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/moreArguments2.res:2:9-12 - - 1 │ let x = (a, b) => a + b - 2 │ let y = x(2) + 2 - 3 │ - - This call is missing an argument of type int \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/moreArguments3.res.expected b/jscomp/build_tests/super_errors/expected/moreArguments3.res.expected deleted file mode 100644 index cb3d0e4..0000000 --- a/jscomp/build_tests/super_errors/expected/moreArguments3.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/moreArguments3.res:2:9-12 - - 1 │ let x = (a, b, c, d) => a + b - 2 │ let y = x(2) + 2 - 3 │ - - This call is missing arguments of type: int, 'a, 'b \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/moreArguments4.res.expected b/jscomp/build_tests/super_errors/expected/moreArguments4.res.expected deleted file mode 100644 index 3d0e7f5..0000000 --- a/jscomp/build_tests/super_errors/expected/moreArguments4.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/moreArguments4.res:2:9-12 - - 1 │ let x = (a, ~b, ~c, ~d) => a + b - 2 │ let y = x(2) + 2 - 3 │ - - This call is missing arguments of type: (~b: int), (~c: 'a), (~d: 'b) \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/moreArguments5.res.expected b/jscomp/build_tests/super_errors/expected/moreArguments5.res.expected deleted file mode 100644 index b5be57a..0000000 --- a/jscomp/build_tests/super_errors/expected/moreArguments5.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/moreArguments5.res:5:9-12 - - 3 │ } - 4 │ let x = (a, b, c, d) => {Sub.a: 2} - 5 │ let y = x(2).Sub.a - 6 │ - - This call is missing arguments of type: 'a, 'b, 'c \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/non_function_uncurried_apply.res.expected b/jscomp/build_tests/super_errors/expected/non_function_uncurried_apply.res.expected deleted file mode 100644 index b44fdb3..0000000 --- a/jscomp/build_tests/super_errors/expected/non_function_uncurried_apply.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/non_function_uncurried_apply.res:2:9-14 - - 1 │ let nonfun = 2 - 2 │ let _ = nonfun(. 3) - 3 │ - - This expression has type int - It is not a function. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/partial_app.res.expected b/jscomp/build_tests/super_errors/expected/partial_app.res.expected deleted file mode 100644 index b2ece41..0000000 --- a/jscomp/build_tests/super_errors/expected/partial_app.res.expected +++ /dev/null @@ -1,16 +0,0 @@ - - Warning number 109 (configured as error) - /.../fixtures/partial_app.res:5:1-7 - - 3 │ } - 4 │ - 5 │ f(1, 2) - 6 │ - - This function call is at the top level and is expected to return `unit`. But it's returning `int => int`. - - In ReScript, anything at the top level must evaluate to `unit`. You can fix this by assigning the expression to a value, or piping it into the `ignore` function. - - Possible solutions: - - Assigning to a value that is then ignored: `let _ = yourFunctionCall()` - - Piping into the built-in ignore function to ignore the result: `yourFunctionCall()->ignore` \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/polyvariant_name_formatting.res.expected b/jscomp/build_tests/super_errors/expected/polyvariant_name_formatting.res.expected deleted file mode 100644 index 6cd099e..0000000 --- a/jscomp/build_tests/super_errors/expected/polyvariant_name_formatting.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/polyvariant_name_formatting.res:6:3-10 - - 4 │ - 5 │ switch f { - 6 │ | #Invalid => () - 7 │ } - 8 │ - - This pattern matches values of type [? #Invalid] - but a pattern was expected which matches values of type polyvariant - The second variant type does not allow tag(s) #Invalid \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives1.res.expected b/jscomp/build_tests/super_errors/expected/primitives1.res.expected deleted file mode 100644 index b1a303e..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives1.res.expected +++ /dev/null @@ -1,19 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives1.res:2:1-2 - - 1 │ /* got float, wanted int */ - 2 │ 2. + 2 - 3 │ - - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 2. an int by removing the dot or explicitly converting to int - - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives10.res.expected b/jscomp/build_tests/super_errors/expected/primitives10.res.expected deleted file mode 100644 index 4a2dd3b..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives10.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives10.res:2:9-13 - - 1 │ let aaaaa = 10 - 2 │ let b = aaaab - 3 │ - - The value aaaab can't be found - - Hint: Did you mean aaaaa? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives11.res.expected b/jscomp/build_tests/super_errors/expected/primitives11.res.expected deleted file mode 100644 index 6123d58..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives11.res.expected +++ /dev/null @@ -1,19 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives11.res:5:13-28 - - 3 │ type a = option - 4 │ type b = option - 5 │ let a: a = (Some(Some(5)): b) - 6 │ - - This has type: b (defined as option) - But it's expected to have type: a (defined as option) - - The incompatible parts: - bb (defined as option) vs aa (defined as option) - - Further expanded: - int vs string - - You can convert int to string with Belt.Int.toString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives2.res.expected b/jscomp/build_tests/super_errors/expected/primitives2.res.expected deleted file mode 100644 index 8677b18..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives2.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives2.res:2:1 - - 1 │ /* got int, wanted string */ - 2 │ 2 ++ " things" - 3 │ - - This has type: int - But this function argument is expecting: string - - You can convert int to string with Belt.Int.toString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives3.res.expected b/jscomp/build_tests/super_errors/expected/primitives3.res.expected deleted file mode 100644 index b028b40..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives3.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives3.res:3:1 - - 1 │ /* Too many arguments */ - 2 │ let x = a => a + 2 - 3 │ x(2, 4) - 4 │ - - This function has type int => int - It only accepts 1 argument; here, it's called with more. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives4.res.expected b/jscomp/build_tests/super_errors/expected/primitives4.res.expected deleted file mode 100644 index 09773d5..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives4.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives4.res:3:1 - - 1 │ /* Not a function */ - 2 │ let x = 10 - 3 │ x(10) - 4 │ - - This expression has type int - It is not a function. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives5.res.expected b/jscomp/build_tests/super_errors/expected/primitives5.res.expected deleted file mode 100644 index 31847d4..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives5.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives5.res:3:1-5 - - 1 │ /* Not enough arguments */ - 2 │ type x = X(int, float) - 3 │ X(10)->ignore - 4 │ - - This variant constructor, X, expects 2 arguments; here, we've only found 1. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives6.res.expected b/jscomp/build_tests/super_errors/expected/primitives6.res.expected deleted file mode 100644 index 6e46bb5..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives6.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives6.res:3:7-8 - - 1 │ /* Wrong constructor argument */ - 2 │ type x = X(int, float) - 3 │ X(10, 10)->ignore - 4 │ - - This has type: int - But it's expected to have type: float - - You can convert int to float with Belt.Int.toFloat. - If this is a literal, try a number with a trailing dot (e.g. 20.). \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives7.res.expected b/jscomp/build_tests/super_errors/expected/primitives7.res.expected deleted file mode 100644 index 0f7375f..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives7.res.expected +++ /dev/null @@ -1,17 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives7.res:3:24 - - 1 │ /* Wanted list(float), found list(int) */ - 2 │ let a = list{1, 2, 3} - 3 │ List.map(n => n +. 2., a) - 4 │ - - This has type: list - But this function argument is expecting: list - - The incompatible parts: - int vs float - - You can convert int to float with Belt.Int.toFloat. - If this is a literal, try a number with a trailing dot (e.g. 20.). \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives8.res.expected b/jscomp/build_tests/super_errors/expected/primitives8.res.expected deleted file mode 100644 index 0d4bd63..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives8.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives8.res:1:11-13 - - 1 │ let asd = aaa - 2 │ - - The value aaa can't be found \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/primitives9.res.expected b/jscomp/build_tests/super_errors/expected/primitives9.res.expected deleted file mode 100644 index b97f1b0..0000000 --- a/jscomp/build_tests/super_errors/expected/primitives9.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/primitives9.res:1:14-20 - - 1 │ let a: int = "hello" - 2 │ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/private_without_body.res.expected b/jscomp/build_tests/super_errors/expected/private_without_body.res.expected deleted file mode 100644 index e044450..0000000 --- a/jscomp/build_tests/super_errors/expected/private_without_body.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/private_without_body.res:1:1-9 - - 1 │ %%private - 2 │ let a = 2 - 3 │ - - %%private extension expects a definition as its argument. Example: %%private(let a = "Hello") \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/record_type_spreads.res.expected b/jscomp/build_tests/super_errors/expected/record_type_spreads.res.expected deleted file mode 100644 index 0f33de5..0000000 --- a/jscomp/build_tests/super_errors/expected/record_type_spreads.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/record_type_spreads.res:5:1-23 - - 3 │ type t2 = {x: string, y: float} - 4 │ - 5 │ type t3 = {...t, ...t2} - 6 │ - - The field x is defined several times in the record t3. Fields can only be added once to a record. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/record_type_spreads_deep_sub.res.expected b/jscomp/build_tests/super_errors/expected/record_type_spreads_deep_sub.res.expected deleted file mode 100644 index cdbe928..0000000 --- a/jscomp/build_tests/super_errors/expected/record_type_spreads_deep_sub.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/record_type_spreads_deep_sub.res:8:9-21 - - 6 │ - 7 │ let d: d = { - 8 │ x: Ok("this errors"), - 9 │ } - 10 │ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/recursive_type.res.expected b/jscomp/build_tests/super_errors/expected/recursive_type.res.expected deleted file mode 100644 index 3abe6f0..0000000 --- a/jscomp/build_tests/super_errors/expected/recursive_type.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/recursive_type.res:35:11-14 - - 33 │ /* parse atom */ - 34 │ and atom = (k, t) => { - 35 │ let _ = atom(k) - 36 │ assert(false) - 37 │ } - - This uncurried function has type - ((option<'a>, ([> #List(list<'b>)] as 'b)) => 'c, 'd) => 'c - It is applied with 1 arguments but it requires 2. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/repeated_def_extension_constr.res.expected b/jscomp/build_tests/super_errors/expected/repeated_def_extension_constr.res.expected deleted file mode 100644 index c62825d..0000000 --- a/jscomp/build_tests/super_errors/expected/repeated_def_extension_constr.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/repeated_def_extension_constr.res:3:6 - - 1 │ type a = .. - 2 │ - 3 │ type a - 4 │ - - Multiple definition of the type name a - at /.../fixtures/repeated_def_extension_constr.res:1:6 - Names must be unique in a given structure or signature. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/repeated_def_module_types.res.expected b/jscomp/build_tests/super_errors/expected/repeated_def_module_types.res.expected deleted file mode 100644 index 4fe5ea9..0000000 --- a/jscomp/build_tests/super_errors/expected/repeated_def_module_types.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/repeated_def_module_types.res:3:13 - - 1 │ module type M = {} - 2 │ - 3 │ module type M = {} - 4 │ - - Multiple definition of the module type name M - at /.../fixtures/repeated_def_module_types.res:1:13 - Names must be unique in a given structure or signature. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/repeated_def_modules.res.expected b/jscomp/build_tests/super_errors/expected/repeated_def_modules.res.expected deleted file mode 100644 index a381a9b..0000000 --- a/jscomp/build_tests/super_errors/expected/repeated_def_modules.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/repeated_def_modules.res:3:8 - - 1 │ module M = {} - 2 │ - 3 │ module M = {} - 4 │ - - Multiple definition of the module name M - at /.../fixtures/repeated_def_modules.res:1:8 - Names must be unique in a given structure or signature. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/repeated_def_types.res.expected b/jscomp/build_tests/super_errors/expected/repeated_def_types.res.expected deleted file mode 100644 index 5c06f37..0000000 --- a/jscomp/build_tests/super_errors/expected/repeated_def_types.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/repeated_def_types.res:3:6 - - 1 │ type a - 2 │ - 3 │ type a - 4 │ - - Multiple definition of the type name a - at /.../fixtures/repeated_def_types.res:1:6 - Names must be unique in a given structure or signature. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/set_record_field_type_match.res.expected b/jscomp/build_tests/super_errors/expected/set_record_field_type_match.res.expected deleted file mode 100644 index d45880d..0000000 --- a/jscomp/build_tests/super_errors/expected/set_record_field_type_match.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/set_record_field_type_match.res:11:13-14 - - 9 │ } - 10 │ - 11 │ user.name = 12 - 12 │ - - You're assigning something to this field that has type: int - But this record field is of type: string - - You can convert int to string with Belt.Int.toString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/switch_different_types.res.expected b/jscomp/build_tests/super_errors/expected/switch_different_types.res.expected deleted file mode 100644 index 14e96e8..0000000 --- a/jscomp/build_tests/super_errors/expected/switch_different_types.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/switch_different_types.res:7:10-23 - - 5 │ switch foo { - 6 │ | "world" => () - 7 │ | _ => someFunction() - 8 │ } - 9 │ } - - This has type: string - But this switch is expected to return: unit - - All branches in a switch must return the same type. To fix this, change your branch to return the expected type. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/switch_guard.res.expected b/jscomp/build_tests/super_errors/expected/switch_guard.res.expected deleted file mode 100644 index f04ff7d..0000000 --- a/jscomp/build_tests/super_errors/expected/switch_guard.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/switch_guard.res:6:16-22 - - 4 │ let bar = () => { - 5 │ switch foo { - 6 │ | "world" if "horse" => () - 7 │ | _ => someFunction() - 8 │ } - - This has type: string - But if conditions must always be of type: bool - - To fix this, change the highlighted code so it evaluates to a bool. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/syntaxErrors1.res.expected b/jscomp/build_tests/super_errors/expected/syntaxErrors1.res.expected deleted file mode 100644 index 9ea853e..0000000 --- a/jscomp/build_tests/super_errors/expected/syntaxErrors1.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - Syntax error! - /.../fixtures/syntaxErrors1.res:1:12 - - 1 │ let b = fo;;;;;;;;;;;;;;;; - 2 │ - - I'm not sure what to parse here when looking at ";". \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/syntaxErrors2.res.expected b/jscomp/build_tests/super_errors/expected/syntaxErrors2.res.expected deleted file mode 100644 index 8427692..0000000 --- a/jscomp/build_tests/super_errors/expected/syntaxErrors2.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - Syntax error! - /.../fixtures/syntaxErrors2.res:2:6-10 - - 1 │ let () = - 2 │ I'm glad you're looking at this file =) - 3 │ - - consecutive statements on a line must be separated by ';' or a newline \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/syntaxErrors3.res.expected b/jscomp/build_tests/super_errors/expected/syntaxErrors3.res.expected deleted file mode 100644 index ba5e6e6..0000000 --- a/jscomp/build_tests/super_errors/expected/syntaxErrors3.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - Syntax error! - /.../fixtures/syntaxErrors3.res:1:20 - - 1 │ let a = print_char('a) - 2 │ - - I'm not sure what to parse here when looking at "'". \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/syntaxErrors4.res.expected b/jscomp/build_tests/super_errors/expected/syntaxErrors4.res.expected deleted file mode 100644 index 5cf63f8..0000000 --- a/jscomp/build_tests/super_errors/expected/syntaxErrors4.res.expected +++ /dev/null @@ -1,18 +0,0 @@ - - We've found a bug for you! - /.../fixtures/syntaxErrors4.res:5:13-21:3 - - 3 │ /* */ - 4 │ /* */ - 5 │ let a:int = "asdaaaaaaaaaaaaaaaaaaaaa - 6 │ aa - . │ ... - 20 │ aa - 21 │ aa" - 22 │ /* */ - 23 │ /* */ - - This has type: string - But it's expected to have type: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/syntaxErrors5.res.expected b/jscomp/build_tests/super_errors/expected/syntaxErrors5.res.expected deleted file mode 100644 index c9d68c9..0000000 --- a/jscomp/build_tests/super_errors/expected/syntaxErrors5.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - Syntax error! - /.../fixtures/syntaxErrors5.res:1:14-2:0 - - 1 │ let a = (1, 2 - 2 │ - - Did you forget a `)` here? \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/todo_with_no_payload.res.expected b/jscomp/build_tests/super_errors/expected/todo_with_no_payload.res.expected deleted file mode 100644 index 3037b88..0000000 --- a/jscomp/build_tests/super_errors/expected/todo_with_no_payload.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - Warning number 110 - /.../fixtures/todo_with_no_payload.res:1:38-42 - - 1 │ let implementMeLater = (): string => %todo - 2 │ - 3 │ let x = implementMeLater() - - Todo found. - - This code is not implemented yet and will crash at runtime. Make sure you implement this before running the code. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/todo_with_payload.res.expected b/jscomp/build_tests/super_errors/expected/todo_with_payload.res.expected deleted file mode 100644 index 37335ae..0000000 --- a/jscomp/build_tests/super_errors/expected/todo_with_payload.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - Warning number 110 - /.../fixtures/todo_with_payload.res:1:38-85 - - 1 │ let implementMeLater = (): string => %todo("This should return a string  - │ eventually.") - 2 │ - 3 │ let x = implementMeLater() - - Todo found: This should return a string eventually. - - This code is not implemented yet and will crash at runtime. Make sure you implement this before running the code. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/top_level_fn_call_not_unit.res.expected b/jscomp/build_tests/super_errors/expected/top_level_fn_call_not_unit.res.expected deleted file mode 100644 index d2bf229..0000000 --- a/jscomp/build_tests/super_errors/expected/top_level_fn_call_not_unit.res.expected +++ /dev/null @@ -1,16 +0,0 @@ - - Warning number 109 (configured as error) - /.../fixtures/top_level_fn_call_not_unit.res:3:1-18 - - 1 │ let returnsSomething = () => 123 - 2 │ - 3 │ returnsSomething() - 4 │ - - This function call is at the top level and is expected to return `unit`. But it's returning `int`. - - In ReScript, anything at the top level must evaluate to `unit`. You can fix this by assigning the expression to a value, or piping it into the `ignore` function. - - Possible solutions: - - Assigning to a value that is then ignored: `let _ = yourFunctionCall()` - - Piping into the built-in ignore function to ignore the result: `yourFunctionCall()->ignore` \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/top_level_value_not_unit.res.expected b/jscomp/build_tests/super_errors/expected/top_level_value_not_unit.res.expected deleted file mode 100644 index 95afeb7..0000000 --- a/jscomp/build_tests/super_errors/expected/top_level_value_not_unit.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - Warning number 109 (configured as error) - /.../fixtures/top_level_value_not_unit.res:1:1-4 - - 1 │ 1234 - 2 │ - - This is at the top level and is expected to return `unit`. But it's returning `int`. - - In ReScript, anything at the top level must evaluate to `unit`. You can fix this by assigning the expression to a value, or piping it into the `ignore` function. - - Possible solutions: - - Assigning to a value that is then ignored: `let _ = yourExpression` - - Piping into the built-in ignore function to ignore the result: `yourExpression->ignore` \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/type1.res.expected b/jscomp/build_tests/super_errors/expected/type1.res.expected deleted file mode 100644 index 036daa2..0000000 --- a/jscomp/build_tests/super_errors/expected/type1.res.expected +++ /dev/null @@ -1,18 +0,0 @@ - - We've found a bug for you! - /.../fixtures/type1.res:1:9-10 - - 1 │ let x = 2. + 2 - 2 │ - - This value has type: float - But it's being used with the + operator, which works on: int - - Floats and ints have their own mathematical operators. This means you cannot add a float and an int without converting between the two. - - Possible solutions: - - Ensure all values in this calculation has the type int. You can convert between floats and ints via Belt.Float.toInt and Belt.Int.fromFloat. - - Make 2. an int by removing the dot or explicitly converting to int - - You can convert float to int with Belt.Float.toInt. - If this is a literal, try a number without a trailing dot (e.g. 20). \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/type2.res.expected b/jscomp/build_tests/super_errors/expected/type2.res.expected deleted file mode 100644 index 1b189ab..0000000 --- a/jscomp/build_tests/super_errors/expected/type2.res.expected +++ /dev/null @@ -1,14 +0,0 @@ - - We've found a bug for you! - /.../fixtures/type2.res:6:11-13 - - 4 │ let () = { - 5 │ push(a, 3)->ignore - 6 │ push(a, "3")->ignore - 7 │ } - 8 │ - - This has type: string - But this function argument is expecting: int - - You can convert string to int with Belt.Int.fromString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/type3.res.expected b/jscomp/build_tests/super_errors/expected/type3.res.expected deleted file mode 100644 index 57215c9..0000000 --- a/jscomp/build_tests/super_errors/expected/type3.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/type3.res:1:5 - - 1 │ let u = [] - 2 │ - - This expression's type contains type variables that cannot be generalized: - array<'_weak1> - - This happens when the type system senses there's a mutation/side-effect, - in combination with a polymorphic value. - Using or annotating that value usually solves it. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/u_for_c_in_c_mode.res.expected b/jscomp/build_tests/super_errors/expected/u_for_c_in_c_mode.res.expected deleted file mode 100644 index 64ccef5..0000000 --- a/jscomp/build_tests/super_errors/expected/u_for_c_in_c_mode.res.expected +++ /dev/null @@ -1,28 +0,0 @@ - - We've found a bug for you! - /.../fixtures/u_for_c_in_c_mode.res:3:5-5:1 - - 1 │ module Foo: { - 2 │ let add: (int, int) => int - 3 │ } = { - 4 │  let add = (. a, b) => a + b - 5 │ } - 6 │ - - Signature mismatch: - Modules do not match: - { - let add: (. int, int) => int -} - is not included in - { - let add: (int, int) => int -} - Values do not match: - let add: (. int, int) => int (uncurried) - is not included in - let add: (int, int) => int (curried) - /.../fixtures/u_for_c_in_c_mode.res:2:3-28: - Expected declaration - /.../fixtures/u_for_c_in_c_mode.res:4:7-9: - Actual declaration \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/u_for_c_in_u_mode.res.expected b/jscomp/build_tests/super_errors/expected/u_for_c_in_u_mode.res.expected deleted file mode 100644 index 823724e..0000000 --- a/jscomp/build_tests/super_errors/expected/u_for_c_in_u_mode.res.expected +++ /dev/null @@ -1,28 +0,0 @@ - - We've found a bug for you! - /.../fixtures/u_for_c_in_u_mode.res:6:5-8:1 - - 4 │ @@uncurried.swap - 5 │ let add: (. int, int) => int - 6 │ } = { - 7 │  let add = (a, b) => a + b - 8 │ } - 9 │ - - Signature mismatch: - Modules do not match: - { - let add: (int, int) => int -} - is not included in - { - let add: (int, int) => int -} - Values do not match: - let add: (int, int) => int (uncurried) - is not included in - let add: (int, int) => int (curried) - /.../fixtures/u_for_c_in_u_mode.res:5:3-30: - Expected declaration - /.../fixtures/u_for_c_in_u_mode.res:7:7-9: - Actual declaration \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/uncurried_expected.res.expected b/jscomp/build_tests/super_errors/expected/uncurried_expected.res.expected deleted file mode 100644 index cb4afd4..0000000 --- a/jscomp/build_tests/super_errors/expected/uncurried_expected.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/uncurried_expected.res:2:15-22 - - 1 │ let apply = (f) => f(. 1) - 2 │ let z = apply(x => x+1) - 3 │ - - This expression is expected to have an uncurried function \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/uncurried_wrong_label.res.expected b/jscomp/build_tests/super_errors/expected/uncurried_wrong_label.res.expected deleted file mode 100644 index 955e973..0000000 --- a/jscomp/build_tests/super_errors/expected/uncurried_wrong_label.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/uncurried_wrong_label.res:3:18 - - 1 │ let foo = (. ~x) => { let _ = (); (~y) => x+y } - 2 │ // This looks too far into the return type - 3 │ let d = foo(. ~y=3) - 4 │ - - The function applied to this argument has type (. ~x: int, ~y: int) => int -This argument cannot be applied with label ~y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/unicode_location.res.expected b/jscomp/build_tests/super_errors/expected/unicode_location.res.expected deleted file mode 100644 index a8e39cf..0000000 --- a/jscomp/build_tests/super_errors/expected/unicode_location.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/unicode_location.res:1:43 - - 1 │ let q = "💩💩💩💩💩💩💩💩����💩" ++ ("a" ++ 3 ++ "b") - 2 │ // ^ character position 33 + 10 - │ (unicode symbols of length 2) - - This has type: int - But this function argument is expecting: string - - You can convert int to string with Belt.Int.toString. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/unknown_tagged_template_function.res.expected b/jscomp/build_tests/super_errors/expected/unknown_tagged_template_function.res.expected deleted file mode 100644 index 5b5c2f8..0000000 --- a/jscomp/build_tests/super_errors/expected/unknown_tagged_template_function.res.expected +++ /dev/null @@ -1,7 +0,0 @@ - - We've found a bug for you! - /.../fixtures/unknown_tagged_template_function.res:1:11-14 - - 1 │ let res = tagg`| 5 × 10 = ${5} |` - - The value tagg can't be found \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/unused_warnings.res.expected b/jscomp/build_tests/super_errors/expected/unused_warnings.res.expected deleted file mode 100644 index 7068419..0000000 --- a/jscomp/build_tests/super_errors/expected/unused_warnings.res.expected +++ /dev/null @@ -1,20 +0,0 @@ - - Warning number 32 - /.../fixtures/unused_warnings.res:1:5 - - 1 │ let a = 3 - 2 │ let a = 33 + 3 - 3 │ let a = 33 + 3 + 3 - - unused value a. - - - Warning number 32 - /.../fixtures/unused_warnings.res:2:5 - - 1 │ let a = 3 - 2 │ let a = 33 + 3 - 3 │ let a = 33 + 3 + 3 - 4 │ - - unused value a. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_bigint.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_bigint.res.expected deleted file mode 100644 index c179d49..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_bigint.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_bigint.res:5:10-20 - - 3 │ let x = One(true) - 4 │ - 5 │ let y = (x :> bigint) - 6 │ - - Type x is not a subtype of bigint \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_bigint_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_bigint_as.res.expected deleted file mode 100644 index a055080..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_bigint_as.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_bigint_as.res:5:10-20 - - 3 │ let x = One - 4 │ - 5 │ let y = (x :> bigint) - 6 │ - - Type x is not a subtype of bigint \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_float.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_float.res.expected deleted file mode 100644 index b78b995..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_float.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_float.res:5:10-19 - - 3 │ let x = One(true) - 4 │ - 5 │ let y = (x :> float) - 6 │ - - Type x is not a subtype of float \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_float_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_float_as.res.expected deleted file mode 100644 index a837b2e..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_float_as.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_float_as.res:5:10-19 - - 3 │ let x = One - 4 │ - 5 │ let y = (x :> float) - 6 │ - - Type x is not a subtype of float \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_int.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_int.res.expected deleted file mode 100644 index c4344ee..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_int.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_int.res:5:10-17 - - 3 │ let x = One(true) - 4 │ - 5 │ let y = (x :> int) - 6 │ - - Type x is not a subtype of int \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_int_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_int_as.res.expected deleted file mode 100644 index 5a6f40e..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_int_as.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_int_as.res:5:10-17 - - 3 │ let x = One - 4 │ - 5 │ let y = (x :> int) - 6 │ - - Type x is not a subtype of int \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_string.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_string.res.expected deleted file mode 100644 index 73caae5..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_string.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_string.res:5:10-20 - - 3 │ let x = One(true) - 4 │ - 5 │ let y = (x :> string) - 6 │ - - Type x is not a subtype of string \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_string_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_string_as.res.expected deleted file mode 100644 index be12a2c..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_string_as.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_string_as.res:5:10-20 - - 3 │ let x = One - 4 │ - 5 │ let y = (x :> string) - 6 │ - - Type x is not a subtype of string \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_string_to_variant_no_payload.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_string_to_variant_no_payload.res.expected deleted file mode 100644 index 1b60c86..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_string_to_variant_no_payload.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_string_to_variant_no_payload.res:6:10-15 - - 4 │ let x = "one" - 5 │ - 6 │ let y = (x :> x) - 7 │ - - Type string is not a subtype of x \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_coercion_string_unboxed.res.expected b/jscomp/build_tests/super_errors/expected/variant_coercion_string_unboxed.res.expected deleted file mode 100644 index a152598..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_coercion_string_unboxed.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_coercion_string_unboxed.res:6:10-20 - - 4 │ let x = One - 5 │ - 6 │ let y = (x :> string) - 7 │ - - Type x is not a subtype of string \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_abstract_type.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_abstract_type.res.expected deleted file mode 100644 index 016fd1e..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_abstract_type.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_abstract_type.res:2:15 - - 1 │ type a - 2 │ type b = | ...a | Other - 3 │ - - This type is not a valid type to spread. It's only possible to spread other variants. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_duplicate_constructors.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_duplicate_constructors.res.expected deleted file mode 100644 index 0f19025..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_duplicate_constructors.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_duplicate_constructors.res:3:22 - - 1 │ type a = One | Two - 2 │ type b = Two | Three - 3 │ type c = | ...a | ...b | Four - 4 │ - - Variant b has a constructor named Two, but a constructor named Two already exists in the variant it's spread into. - You cannot spread variants with overlapping constructors. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_extensible_variant.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_extensible_variant.res.expected deleted file mode 100644 index 100f881..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_extensible_variant.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_extensible_variant.res:2:15 - - 1 │ type a = .. - 2 │ type b = | ...a | Other - 3 │ - - This type is not a valid type to spread. It's only possible to spread other variants. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_inline_records.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_inline_records.res.expected deleted file mode 100644 index f34a0fa..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_inline_records.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_inline_records.res:4:16-30 - - 2 │ type b = | ...a | Three - 3 │ - 4 │ let b: b = One({name: "hello"}) - - Some required record fields are missing: age. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_recursive.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_recursive.res.expected deleted file mode 100644 index 8c817c9..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_recursive.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_recursive.res:1:65 - - 1 │ type rec a = One | Two | Three and b = Four | Five and c = | ...a | ...b - 2 │ - - This type could not be found. It's only possible to spread variants that are known as the spread happens. This means for example that you can't spread variants in recursive definitions. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_tag_missing.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_tag_missing.res.expected deleted file mode 100644 index 74d2abe..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_tag_missing.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_tag_missing.res:2:15 - - 1 │ @tag("kind") type a = One(int) | Two(string) - 2 │ type b = | ...a | Three(bool) - 3 │ - - The @tag attribute does not match for this variant and the variant where this is spread. Both variants must have the same @tag attribute configuration, or no @tag attribute at all. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_tag_value_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_tag_value_mismatch.res.expected deleted file mode 100644 index 151b0b0..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_tag_value_mismatch.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_tag_value_mismatch.res:2:28 - - 1 │ @tag("kind") type a = One(int) | Two(string) - 2 │ @tag("name") type b = | ...a | Three(bool) - 3 │ - - The @tag attribute does not match for this variant and the variant where this is spread. Both variants must have the same @tag attribute configuration, or no @tag attribute at all. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_type_parameters.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_type_parameters.res.expected deleted file mode 100644 index 99738ba..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_type_parameters.res.expected +++ /dev/null @@ -1,8 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_type_parameters.res:2:15 - - 1 │ type a<'a> = One | Two('a) - 2 │ type b = | ...a | Three - - Type parameters are not supported in variant type spreads. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_spread_unboxed_mismatch.res.expected b/jscomp/build_tests/super_errors/expected/variant_spread_unboxed_mismatch.res.expected deleted file mode 100644 index aecd49d..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_spread_unboxed_mismatch.res.expected +++ /dev/null @@ -1,9 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_spread_unboxed_mismatch.res:2:15 - - 1 │ @unboxed type a = One(int) | Two(string) - 2 │ type b = | ...a | Three(bool) - 3 │ - - This variant is unboxed, but the variant where this is spread is not. Both variants unboxed configuration must match. \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected deleted file mode 100644 index 75a0fc3..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_to_variant_coercion.res:6:10-15 - - 4 │ let x: x = One(true) - 5 │ - 6 │ let y = (x :> y) - 7 │ - - Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected deleted file mode 100644 index 04a3f55..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_as.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_to_variant_coercion_as.res:6:10-15 - - 4 │ let x: x = One(true) - 5 │ - 6 │ let y = (x :> y) - 7 │ - - Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected deleted file mode 100644 index 33b2122..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_tag.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_to_variant_coercion_tag.res:6:10-15 - - 4 │ let x: x = One(true) - 5 │ - 6 │ let y = (x :> y) - 7 │ - - Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected b/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected deleted file mode 100644 index 6e4844a..0000000 --- a/jscomp/build_tests/super_errors/expected/variant_to_variant_coercion_unboxed.res.expected +++ /dev/null @@ -1,10 +0,0 @@ - - We've found a bug for you! - /.../fixtures/variant_to_variant_coercion_unboxed.res:6:10-15 - - 4 │ let x: x = One(true) - 5 │ - 6 │ let y = (x :> y) - 7 │ - - Type x is not a subtype of y \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/warnings1.res.expected b/jscomp/build_tests/super_errors/expected/warnings1.res.expected deleted file mode 100644 index 4d91138..0000000 --- a/jscomp/build_tests/super_errors/expected/warnings1.res.expected +++ /dev/null @@ -1,12 +0,0 @@ - - We've found a bug for you! - /.../fixtures/warnings1.res:3:3-7 - - 1 │ let x = (a, b) => a + b - 2 │ let z = () => { - 3 │ x(10) - 4 │ 10 - 5 │ } - - This function call returns: int => int - But it's expected to return: unit \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/warnings2.res.expected b/jscomp/build_tests/super_errors/expected/warnings2.res.expected deleted file mode 100644 index 324f794..0000000 --- a/jscomp/build_tests/super_errors/expected/warnings2.res.expected +++ /dev/null @@ -1,11 +0,0 @@ - - We've found a bug for you! - /.../fixtures/warnings2.res:2:3-4 - - 1 │ let z = () => { - 2 │ 10 - 3 │ 10 - 4 │ } - - This has type: int - But it's expected to have type: unit \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/warnings3.res.expected b/jscomp/build_tests/super_errors/expected/warnings3.res.expected deleted file mode 100644 index 11f5a87..0000000 --- a/jscomp/build_tests/super_errors/expected/warnings3.res.expected +++ /dev/null @@ -1,34 +0,0 @@ - - Warning number 3 - /.../fixtures/warnings3.res:1:9-23 - - 1 │ let _ = string_of_float(34.) - 2 │ let _ = string_of_float(34.) - 3 │ let _ = string_of_float(34.) - - deprecated: Pervasives.string_of_float - Please use Js.Float.toString instead, string_of_float generates unparseable floats - - - Warning number 3 - /.../fixtures/warnings3.res:2:9-23 - - 1 │ let _ = string_of_float(34.) - 2 │ let _ = string_of_float(34.) - 3 │ let _ = string_of_float(34.) - 4 │ - - deprecated: Pervasives.string_of_float - Please use Js.Float.toString instead, string_of_float generates unparseable floats - - - Warning number 3 - /.../fixtures/warnings3.res:3:9-23 - - 1 │ let _ = string_of_float(34.) - 2 │ let _ = string_of_float(34.) - 3 │ let _ = string_of_float(34.) - 4 │ - - deprecated: Pervasives.string_of_float - Please use Js.Float.toString instead, string_of_float generates unparseable floats \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/warnings4.res.expected b/jscomp/build_tests/super_errors/expected/warnings4.res.expected deleted file mode 100644 index f294e44..0000000 --- a/jscomp/build_tests/super_errors/expected/warnings4.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - Warning number 8 - /.../fixtures/warnings4.res:11:1-13:1 - - 9 │ @val external x: myType = "myVariable" - 10 │ - 11 │ switch x { - 12 │  | #first => Js.log("first") - 13 │ } - 14 │ - - You forgot to handle a possible case here, for example: - | #second(_) | #fourth | #third \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/warnings5.res.expected b/jscomp/build_tests/super_errors/expected/warnings5.res.expected deleted file mode 100644 index 204f9f1..0000000 --- a/jscomp/build_tests/super_errors/expected/warnings5.res.expected +++ /dev/null @@ -1,190 +0,0 @@ - - Warning number 9 - /.../fixtures/warnings5.res:12:3-21 - - 10 │ - 11 │ switch y { - 12 │ | {otherValue: false} => Js.log("first") - 13 │ } - 14 │ - - the following labels are not bound in this record pattern: someValue, typ -Either bind these labels explicitly or add ', _' to the pattern. - - - Warning number 8 - /.../fixtures/warnings5.res:11:1-13:1 - - 9 │ @val external y: someRecord = "otherVariable" - 10 │ - 11 │ switch y { - 12 │ | {otherValue: false} => Js.log("first") - 13 │ } - 14 │ - 15 │ switch y { - - You forgot to handle a possible case here, for example: - | {otherValue: true, _} - - - Warning number 9 - /.../fixtures/warnings5.res:16:3-26 - - 14 │ - 15 │ switch y { - 16 │ | {typ: WithPayload(true)} => Js.log("first") - 17 │ } - 18 │ - - the following labels are not bound in this record pattern: someValue, otherValue -Either bind these labels explicitly or add ', _' to the pattern. - - - Warning number 8 - /.../fixtures/warnings5.res:15:1-17:1 - - 13 │ } - 14 │ - 15 │ switch y { - 16 │ | {typ: WithPayload(true)} => Js.log("first") - 17 │ } - 18 │ - 19 │ let arr = [1] - - You forgot to handle a possible case here, for example: - | {typ: WithPayload(false), _} -| {typ: Variant | One | Two | Three | Four | Five | Six | Seven(_), _} - - - Warning number 8 - /.../fixtures/warnings5.res:21:1-23:1 - - 19 │ let arr = [1] - 20 │ - 21 │ switch arr { - 22 │ | [] => Js.log("") - 23 │ } - 24 │ - 25 │ switch arr { - - You forgot to handle a possible case here, for example: - | [_] - - - Warning number 8 - /.../fixtures/warnings5.res:25:1-27:1 - - 23 │ } - 24 │ - 25 │ switch arr { - 26 │ | [one] => Js.log(one) - 27 │ } - 28 │ - 29 │ switch arr { - - You forgot to handle a possible case here, for example: - | [] - - - Warning number 8 - /.../fixtures/warnings5.res:29:1-31:1 - - 27 │ } - 28 │ - 29 │ switch arr { - 30 │ | [1, 2] => () - 31 │ } - 32 │ - 33 │ let lst = list{} - - You forgot to handle a possible case here, for example: - | [1, 0] | [0, _] | [] - - - Warning number 8 - /.../fixtures/warnings5.res:35:1-37:1 - - 33 │ let lst = list{} - 34 │ - 35 │ switch lst { - 36 │ | list{} => () - 37 │ } - 38 │ - 39 │ switch lst { - - You forgot to handle a possible case here, for example: - | list{_, ..._} - - - Warning number 8 - /.../fixtures/warnings5.res:39:1-41:1 - - 37 │ } - 38 │ - 39 │ switch lst { - 40 │ | list{1, 2} => () - 41 │ } - 42 │ - 43 │ switch lst { - - You forgot to handle a possible case here, for example: - | list{1, 2, _, ..._} | list{1, 0, ..._} | list{1} | list{0, ..._} | list{} - - - Warning number 8 - /.../fixtures/warnings5.res:43:1-45:1 - - 41 │ } - 42 │ - 43 │ switch lst { - 44 │ | list{1} => () - 45 │ } - 46 │ - 47 │ switch "abc" { - - You forgot to handle a possible case here, for example: - | list{1, _, ..._} | list{0, ..._} | list{} - - - Warning number 8 - /.../fixtures/warnings5.res:47:1-49:1 - - 45 │ } - 46 │ - 47 │ switch "abc" { - 48 │ | "" => () - 49 │ } - 50 │ - 51 │ switch 0 { - - You forgot to handle a possible case here, for example: - | "*" - - - Warning number 8 - /.../fixtures/warnings5.res:51:1-53:1 - - 49 │ } - 50 │ - 51 │ switch 0 { - 52 │ | 1 => () - 53 │ } - 54 │ - 55 │ let tuple = (1, true) - - You forgot to handle a possible case here, for example: - | 0 - - - Warning number 8 - /.../fixtures/warnings5.res:57:1-59:1 - - 55 │ let tuple = (1, true) - 56 │ - 57 │ switch tuple { - 58 │ | (_, false) => () - 59 │ } - 60 │ - - You forgot to handle a possible case here, for example: - | (_, true) \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/wrong_name_component_prop.res.expected b/jscomp/build_tests/super_errors/expected/wrong_name_component_prop.res.expected deleted file mode 100644 index af78b82..0000000 --- a/jscomp/build_tests/super_errors/expected/wrong_name_component_prop.res.expected +++ /dev/null @@ -1,23 +0,0 @@ - - We've found a bug for you! - /.../fixtures/wrong_name_component_prop.res:32:28-38 - - 30 │ } - 31 │ - 32 │ let dddd = Component.make({nonExistant: "hello"}) - 33 │ - - The field nonExistant does not belong to type Component.props - - This record expression is expected to have type - Component.props< - string, - string, - string, - string, - string, - string, - string, - string, - string, -> \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/expected/wrong_name_record_field.res.expected b/jscomp/build_tests/super_errors/expected/wrong_name_record_field.res.expected deleted file mode 100644 index ab11b80..0000000 --- a/jscomp/build_tests/super_errors/expected/wrong_name_record_field.res.expected +++ /dev/null @@ -1,13 +0,0 @@ - - We've found a bug for you! - /.../fixtures/wrong_name_record_field.res:4:3-4 - - 2 │ - 3 │ let ff: d = { - 4 │ zz: 123, - 5 │ } - 6 │ - - The field zz does not belong to type d - - This record expression is expected to have type d \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/DerivingAccessorsRecordParam.res b/jscomp/build_tests/super_errors/fixtures/DerivingAccessorsRecordParam.res deleted file mode 100644 index c86aa30..0000000 --- a/jscomp/build_tests/super_errors/fixtures/DerivingAccessorsRecordParam.res +++ /dev/null @@ -1,2 +0,0 @@ -@deriving(accessors) -type t = Struct({a: int}) diff --git a/jscomp/build_tests/super_errors/fixtures/RecordInclusion.res b/jscomp/build_tests/super_errors/fixtures/RecordInclusion.res deleted file mode 100644 index c8d366c..0000000 --- a/jscomp/build_tests/super_errors/fixtures/RecordInclusion.res +++ /dev/null @@ -1,5 +0,0 @@ -module M : { - type t<'a, 'b, 'c> = {x:int, y:list<('a, 'b)>, z:int} -} = { - type t<'a, 'b, 'c> = {x:int, y:list<('a, 'c)>, z:int} -} diff --git a/jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res b/jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res deleted file mode 100644 index 0d8be72..0000000 --- a/jscomp/build_tests/super_errors/fixtures/UncurriedArgsNotApplied.res +++ /dev/null @@ -1,3 +0,0 @@ -let apply = (fn: (. unit) => option) => fn(. ()) - -let _ = apply(Some(1)) diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedImplIntf.res b/jscomp/build_tests/super_errors/fixtures/UntaggedImplIntf.res deleted file mode 100644 index 6d269fe..0000000 --- a/jscomp/build_tests/super_errors/fixtures/UntaggedImplIntf.res +++ /dev/null @@ -1,5 +0,0 @@ -module M: { - @unboxed type t = | @as(null) A -} = { - type t = | @as(null) A -} \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary1.res b/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary1.res deleted file mode 100644 index 5143c46..0000000 --- a/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary1.res +++ /dev/null @@ -1,2 +0,0 @@ -@unboxed -type t = Tuple(int, string) diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary2.res b/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary2.res deleted file mode 100644 index fde4ae2..0000000 --- a/jscomp/build_tests/super_errors/fixtures/UntaggedNonUnary2.res +++ /dev/null @@ -1,2 +0,0 @@ -@unboxed -type t = Tuple(int, string) | Float(float) diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedTupleAndArray.res b/jscomp/build_tests/super_errors/fixtures/UntaggedTupleAndArray.res deleted file mode 100644 index 266f62a..0000000 --- a/jscomp/build_tests/super_errors/fixtures/UntaggedTupleAndArray.res +++ /dev/null @@ -1,4 +0,0 @@ -@unboxed -type t = - | Array(array) - | Tuple((int, int)) diff --git a/jscomp/build_tests/super_errors/fixtures/UntaggedUnknown.res b/jscomp/build_tests/super_errors/fixtures/UntaggedUnknown.res deleted file mode 100644 index de0ae74..0000000 --- a/jscomp/build_tests/super_errors/fixtures/UntaggedUnknown.res +++ /dev/null @@ -1,2 +0,0 @@ -@unboxed -type t = List(list) | Float(float) diff --git a/jscomp/build_tests/super_errors/fixtures/arity_mismatch.res b/jscomp/build_tests/super_errors/fixtures/arity_mismatch.res deleted file mode 100644 index 7ca22b2..0000000 --- a/jscomp/build_tests/super_errors/fixtures/arity_mismatch.res +++ /dev/null @@ -1,2 +0,0 @@ -let makeVar = (. ~f, ()) => 34 -let makeVariables = makeVar(.~f=f => f) diff --git a/jscomp/build_tests/super_errors/fixtures/arity_mismatch2.res b/jscomp/build_tests/super_errors/fixtures/arity_mismatch2.res deleted file mode 100644 index 7f22a21..0000000 --- a/jscomp/build_tests/super_errors/fixtures/arity_mismatch2.res +++ /dev/null @@ -1,2 +0,0 @@ -let makeVar = (. f, ()) => 34 -let makeVariables = makeVar(. 1, 2, 3) diff --git a/jscomp/build_tests/super_errors/fixtures/arity_mismatch3.res b/jscomp/build_tests/super_errors/fixtures/arity_mismatch3.res deleted file mode 100644 index 58d94f8..0000000 --- a/jscomp/build_tests/super_errors/fixtures/arity_mismatch3.res +++ /dev/null @@ -1 +0,0 @@ -Belt.Array.mapU([], (. a, b) => 1) diff --git a/jscomp/build_tests/super_errors/fixtures/array_item_type_mismatch.res b/jscomp/build_tests/super_errors/fixtures/array_item_type_mismatch.res deleted file mode 100644 index 541be0e..0000000 --- a/jscomp/build_tests/super_errors/fixtures/array_item_type_mismatch.res +++ /dev/null @@ -1 +0,0 @@ -let x = [1, 2, "hello"] diff --git a/jscomp/build_tests/super_errors/fixtures/await.res b/jscomp/build_tests/super_errors/fixtures/await.res deleted file mode 100644 index 63e982c..0000000 --- a/jscomp/build_tests/super_errors/fixtures/await.res +++ /dev/null @@ -1,5 +0,0 @@ -let a = async () => 3 -let foo = async () => { - let _ = () - () => await a() -} diff --git a/jscomp/build_tests/super_errors/fixtures/bigint_match_literal.res b/jscomp/build_tests/super_errors/fixtures/bigint_match_literal.res deleted file mode 100644 index ee0e07f..0000000 --- a/jscomp/build_tests/super_errors/fixtures/bigint_match_literal.res +++ /dev/null @@ -1,6 +0,0 @@ -let m1 = switch 1n { -| 0001n => 1 -| 1n => 1 -| -0001n => -1 -| _ => 0 -} diff --git a/jscomp/build_tests/super_errors/fixtures/c_for_u_in_c_mode.res b/jscomp/build_tests/super_errors/fixtures/c_for_u_in_c_mode.res deleted file mode 100644 index ed0ff15..0000000 --- a/jscomp/build_tests/super_errors/fixtures/c_for_u_in_c_mode.res +++ /dev/null @@ -1,5 +0,0 @@ -module Foo: { - let add: (. int, int) => int -} = { - let add = (a, b) => a + b -} diff --git a/jscomp/build_tests/super_errors/fixtures/c_for_u_in_u_mode.res b/jscomp/build_tests/super_errors/fixtures/c_for_u_in_u_mode.res deleted file mode 100644 index 8444002..0000000 --- a/jscomp/build_tests/super_errors/fixtures/c_for_u_in_u_mode.res +++ /dev/null @@ -1,8 +0,0 @@ -@@uncurried - -module Foo: { - let add: (int, int) => int -} = { - @@uncurried.swap - let add = (. a, b) => a + b -} diff --git a/jscomp/build_tests/super_errors/fixtures/collections.res b/jscomp/build_tests/super_errors/fixtures/collections.res deleted file mode 100644 index d4e9e91..0000000 --- a/jscomp/build_tests/super_errors/fixtures/collections.res +++ /dev/null @@ -1,2 +0,0 @@ -/* wrong type in a list */ -list{1, 2, "Hello"}->ignore diff --git a/jscomp/build_tests/super_errors/fixtures/comparison_operator.res b/jscomp/build_tests/super_errors/fixtures/comparison_operator.res deleted file mode 100644 index c9c4270..0000000 --- a/jscomp/build_tests/super_errors/fixtures/comparison_operator.res +++ /dev/null @@ -1,3 +0,0 @@ -let f = Some(0) - -let x = 100 === f diff --git a/jscomp/build_tests/super_errors/fixtures/component_missing_prop.res b/jscomp/build_tests/super_errors/fixtures/component_missing_prop.res deleted file mode 100644 index 6dbe26b..0000000 --- a/jscomp/build_tests/super_errors/fixtures/component_missing_prop.res +++ /dev/null @@ -1,6 +0,0 @@ -// Since the React transform isn't active in the tests, mimic what the transform outputs. -module Component = { - type props<'name> = {name: 'name} - - let make = (): props<'name> => {} -} diff --git a/jscomp/build_tests/super_errors/fixtures/component_missing_prop_test.res b/jscomp/build_tests/super_errors/fixtures/component_missing_prop_test.res deleted file mode 100644 index 2f75f61..0000000 --- a/jscomp/build_tests/super_errors/fixtures/component_missing_prop_test.res +++ /dev/null @@ -1,6 +0,0 @@ -// Since the React transform isn't active in the tests, mimic what the transform outputs. -module Component = { - type props<'name> = {name: 'name} - - let make = (): props<'name> => {nname: "hello"} -} diff --git a/jscomp/build_tests/super_errors/fixtures/curried_expected.res b/jscomp/build_tests/super_errors/fixtures/curried_expected.res deleted file mode 100644 index 224d432..0000000 --- a/jscomp/build_tests/super_errors/fixtures/curried_expected.res +++ /dev/null @@ -1,3 +0,0 @@ -let expectCurried = f => f(1) + 2 - -let z1 = expectCurried((. x, y) => x+y) diff --git a/jscomp/build_tests/super_errors/fixtures/curry_in_uncurry.res b/jscomp/build_tests/super_errors/fixtures/curry_in_uncurry.res deleted file mode 100644 index 3a858b9..0000000 --- a/jscomp/build_tests/super_errors/fixtures/curry_in_uncurry.res +++ /dev/null @@ -1,3 +0,0 @@ -let f = (a, b) => a + b - -f(. 2, 2)->Js.log diff --git a/jscomp/build_tests/super_errors/fixtures/dict_inference.res b/jscomp/build_tests/super_errors/fixtures/dict_inference.res deleted file mode 100644 index 703f0c6..0000000 --- a/jscomp/build_tests/super_errors/fixtures/dict_inference.res +++ /dev/null @@ -1,4 +0,0 @@ -let dict = Js.Dict.empty() -dict->Js.Dict.set("someKey1", 1) -dict->Js.Dict.set("someKey2", 2) -dict->Js.Dict.set("someKey2", "2") diff --git a/jscomp/build_tests/super_errors/fixtures/directive_attr.res b/jscomp/build_tests/super_errors/fixtures/directive_attr.res deleted file mode 100644 index ec80ff9..0000000 --- a/jscomp/build_tests/super_errors/fixtures/directive_attr.res +++ /dev/null @@ -1 +0,0 @@ -@@directive diff --git a/jscomp/build_tests/super_errors/fixtures/duplicate_labels_error.res b/jscomp/build_tests/super_errors/fixtures/duplicate_labels_error.res deleted file mode 100644 index a8aa3fb..0000000 --- a/jscomp/build_tests/super_errors/fixtures/duplicate_labels_error.res +++ /dev/null @@ -1,4 +0,0 @@ -type rcrd = { - name: string, - name: int, -} diff --git a/jscomp/build_tests/super_errors/fixtures/fieldNotOptional.res b/jscomp/build_tests/super_errors/fixtures/fieldNotOptional.res deleted file mode 100644 index e653cbd..0000000 --- a/jscomp/build_tests/super_errors/fixtures/fieldNotOptional.res +++ /dev/null @@ -1,17 +0,0 @@ -type r = {nonopt: int, opt?: string} - -let v = {nonopt: ?3, opt: ?None} - -let f = r => - switch r { - | {nonopt: ?_, opt: ?_} => true - } - -type inline = A({nonopt: int, opt?: string}) - -let vi = A({nonopt: ?3, opt: ?None}) - -let fi = a => - switch a { - | A ({nonopt: ?_, opt: ?_}) => true - } \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/function_argument_mismatch.res b/jscomp/build_tests/super_errors/fixtures/function_argument_mismatch.res deleted file mode 100644 index 895aa91..0000000 --- a/jscomp/build_tests/super_errors/fixtures/function_argument_mismatch.res +++ /dev/null @@ -1,3 +0,0 @@ -let makeName = (s, i) => s ++ i - -let name = makeName("123", 123) diff --git a/jscomp/build_tests/super_errors/fixtures/function_call_mismatch.res b/jscomp/build_tests/super_errors/fixtures/function_call_mismatch.res deleted file mode 100644 index 1d3bafc..0000000 --- a/jscomp/build_tests/super_errors/fixtures/function_call_mismatch.res +++ /dev/null @@ -1,8 +0,0 @@ -@module("shelljs") -external cd: string => string = "cd" -external exec: string => string = "exec" - -let cloneInTemp = (temp: string): string => { - cd(temp) - exec("git clone git@github.com:myorg/myrepo.git") -} diff --git a/jscomp/build_tests/super_errors/fixtures/function_return_mismatch.res b/jscomp/build_tests/super_errors/fixtures/function_return_mismatch.res deleted file mode 100644 index 7907de2..0000000 --- a/jscomp/build_tests/super_errors/fixtures/function_return_mismatch.res +++ /dev/null @@ -1,10 +0,0 @@ -type cleanup = unit => unit - -let fnExpectingCleanup = (cb: unit => cleanup) => { - let cleanup = cb() - cleanup() -} - -let x = fnExpectingCleanup(() => { - 123 -}) diff --git a/jscomp/build_tests/super_errors/fixtures/highlighting1.res b/jscomp/build_tests/super_errors/fixtures/highlighting1.res deleted file mode 100644 index 9974a5f..0000000 --- a/jscomp/build_tests/super_errors/fixtures/highlighting1.res +++ /dev/null @@ -1,3 +0,0 @@ -let a: int = "hel - -lo" diff --git a/jscomp/build_tests/super_errors/fixtures/highlighting2.res b/jscomp/build_tests/super_errors/fixtures/highlighting2.res deleted file mode 100644 index 52dacee..0000000 --- a/jscomp/build_tests/super_errors/fixtures/highlighting2.res +++ /dev/null @@ -1,4 +0,0 @@ - - let a: int = "hel - - lo" diff --git a/jscomp/build_tests/super_errors/fixtures/highlighting3.res b/jscomp/build_tests/super_errors/fixtures/highlighting3.res deleted file mode 100644 index b781381..0000000 --- a/jscomp/build_tests/super_errors/fixtures/highlighting3.res +++ /dev/null @@ -1,4 +0,0 @@ - -let a: int = "helllllll - -loooooooooooooo" diff --git a/jscomp/build_tests/super_errors/fixtures/highlighting4.res b/jscomp/build_tests/super_errors/fixtures/highlighting4.res deleted file mode 100644 index e6d29d5..0000000 --- a/jscomp/build_tests/super_errors/fixtures/highlighting4.res +++ /dev/null @@ -1,5 +0,0 @@ -@@warnerror("A") -/* single char highlighted */ -@deprecated -type a = int -type b = a diff --git a/jscomp/build_tests/super_errors/fixtures/highlighting5.res b/jscomp/build_tests/super_errors/fixtures/highlighting5.res deleted file mode 100644 index 945a6be..0000000 --- a/jscomp/build_tests/super_errors/fixtures/highlighting5.res +++ /dev/null @@ -1,2 +0,0 @@ -/* overflows in the terminal */ -let a: int = "helllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllll" diff --git a/jscomp/build_tests/super_errors/fixtures/highlighting6.res b/jscomp/build_tests/super_errors/fixtures/highlighting6.res deleted file mode 100644 index dc60510..0000000 --- a/jscomp/build_tests/super_errors/fixtures/highlighting6.res +++ /dev/null @@ -1,2 +0,0 @@ -let aaaaa = 10 -let b = aaaab diff --git a/jscomp/build_tests/super_errors/fixtures/if_branch_mismatch.res b/jscomp/build_tests/super_errors/fixtures/if_branch_mismatch.res deleted file mode 100644 index 19112ea..0000000 --- a/jscomp/build_tests/super_errors/fixtures/if_branch_mismatch.res +++ /dev/null @@ -1,5 +0,0 @@ -let x = if true { - "123" -} else { - 123 -} diff --git a/jscomp/build_tests/super_errors/fixtures/if_condition_mismatch.res b/jscomp/build_tests/super_errors/fixtures/if_condition_mismatch.res deleted file mode 100644 index 221d18b..0000000 --- a/jscomp/build_tests/super_errors/fixtures/if_condition_mismatch.res +++ /dev/null @@ -1,3 +0,0 @@ -let x = if "horse" { - () -} diff --git a/jscomp/build_tests/super_errors/fixtures/intoverflow.res b/jscomp/build_tests/super_errors/fixtures/intoverflow.res deleted file mode 100644 index b1b3981..0000000 --- a/jscomp/build_tests/super_errors/fixtures/intoverflow.res +++ /dev/null @@ -1,12 +0,0 @@ -let v1: int = 2_147_483_647 // max int -let v2: int = 2_147_483_648 // overflow -let v3: int = 2_147_483_649 // overflow -let v4: int = -2_147_483_647 -let v5: int = -2_147_483_648 // min int -let v6: int = -2_147_483_649 // underflow - -// hex -let v7: int = 0xFFFF_FFFF // -1 -let v8: int = -0xFFFF_FFFF // 1 -let v9:int = 0x1_0000_0000 // overflow -let v10:int = -0x1_0000_0000 // underflow diff --git a/jscomp/build_tests/super_errors/fixtures/jinterp.res b/jscomp/build_tests/super_errors/fixtures/jinterp.res deleted file mode 100644 index cd6608f..0000000 --- a/jscomp/build_tests/super_errors/fixtures/jinterp.res +++ /dev/null @@ -1,3 +0,0 @@ - -let a = 11 -let b = j`number $(a)` \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/math_operator_constant.res b/jscomp/build_tests/super_errors/fixtures/math_operator_constant.res deleted file mode 100644 index 3934ae0..0000000 --- a/jscomp/build_tests/super_errors/fixtures/math_operator_constant.res +++ /dev/null @@ -1,3 +0,0 @@ -let num = 0 - -let x = num + 12. diff --git a/jscomp/build_tests/super_errors/fixtures/math_operator_float.res b/jscomp/build_tests/super_errors/fixtures/math_operator_float.res deleted file mode 100644 index 4e791f2..0000000 --- a/jscomp/build_tests/super_errors/fixtures/math_operator_float.res +++ /dev/null @@ -1,3 +0,0 @@ -let num = 0 - -let x = num +. 12. diff --git a/jscomp/build_tests/super_errors/fixtures/math_operator_int.res b/jscomp/build_tests/super_errors/fixtures/math_operator_int.res deleted file mode 100644 index cc57609..0000000 --- a/jscomp/build_tests/super_errors/fixtures/math_operator_int.res +++ /dev/null @@ -1,3 +0,0 @@ -let num = 0. - -let x = num + 12. diff --git a/jscomp/build_tests/super_errors/fixtures/math_operator_string.res b/jscomp/build_tests/super_errors/fixtures/math_operator_string.res deleted file mode 100644 index 9005135..0000000 --- a/jscomp/build_tests/super_errors/fixtures/math_operator_string.res +++ /dev/null @@ -1 +0,0 @@ -let x = "hello" + "what" diff --git a/jscomp/build_tests/super_errors/fixtures/method_arity_mismatch.res b/jscomp/build_tests/super_errors/fixtures/method_arity_mismatch.res deleted file mode 100644 index d50b393..0000000 --- a/jscomp/build_tests/super_errors/fixtures/method_arity_mismatch.res +++ /dev/null @@ -1,4 +0,0 @@ -let f = obj => { - obj["hi"](.1, 2) - obj["hi"](.1) -} diff --git a/jscomp/build_tests/super_errors/fixtures/missing_label.res b/jscomp/build_tests/super_errors/fixtures/missing_label.res deleted file mode 100644 index f67eb46..0000000 --- a/jscomp/build_tests/super_errors/fixtures/missing_label.res +++ /dev/null @@ -1,3 +0,0 @@ -let f = (~a) => a ++ "" - -let _ = f("") diff --git a/jscomp/build_tests/super_errors/fixtures/missing_labels.res b/jscomp/build_tests/super_errors/fixtures/missing_labels.res deleted file mode 100644 index 9953d57..0000000 --- a/jscomp/build_tests/super_errors/fixtures/missing_labels.res +++ /dev/null @@ -1,3 +0,0 @@ -let f = (~a, ~b) => a ++ b - -let _ = f("", "") diff --git a/jscomp/build_tests/super_errors/fixtures/modules1.res b/jscomp/build_tests/super_errors/fixtures/modules1.res deleted file mode 100644 index 766e39d..0000000 --- a/jscomp/build_tests/super_errors/fixtures/modules1.res +++ /dev/null @@ -1 +0,0 @@ -let b = Foo.b diff --git a/jscomp/build_tests/super_errors/fixtures/modules2.res b/jscomp/build_tests/super_errors/fixtures/modules2.res deleted file mode 100644 index 9f17e8b..0000000 --- a/jscomp/build_tests/super_errors/fixtures/modules2.res +++ /dev/null @@ -1 +0,0 @@ -let b = List.b diff --git a/jscomp/build_tests/super_errors/fixtures/modules3.res b/jscomp/build_tests/super_errors/fixtures/modules3.res deleted file mode 100644 index 50ce549..0000000 --- a/jscomp/build_tests/super_errors/fixtures/modules3.res +++ /dev/null @@ -1,17 +0,0 @@ -module A = { - module B = { - module C = { - module D = { - let aaaa = 1 - } - } - } -} - -let asd = A.B.C.D.aaa - -/* there's another, unrelated test, that we're just gonna paste here. We won't -run this, because CI and macOS give different results because of the way path -sensitivity is handled */ - -/* let asd = JS.toOption */ diff --git a/jscomp/build_tests/super_errors/fixtures/moreArguments1.res b/jscomp/build_tests/super_errors/fixtures/moreArguments1.res deleted file mode 100644 index f3f5c80..0000000 --- a/jscomp/build_tests/super_errors/fixtures/moreArguments1.res +++ /dev/null @@ -1,2 +0,0 @@ -let x = (~a, ~b) => a + b -let y = x(~a=2) + 2 diff --git a/jscomp/build_tests/super_errors/fixtures/moreArguments2.res b/jscomp/build_tests/super_errors/fixtures/moreArguments2.res deleted file mode 100644 index f9de2b7..0000000 --- a/jscomp/build_tests/super_errors/fixtures/moreArguments2.res +++ /dev/null @@ -1,2 +0,0 @@ -let x = (a, b) => a + b -let y = x(2) + 2 diff --git a/jscomp/build_tests/super_errors/fixtures/moreArguments3.res b/jscomp/build_tests/super_errors/fixtures/moreArguments3.res deleted file mode 100644 index d27f568..0000000 --- a/jscomp/build_tests/super_errors/fixtures/moreArguments3.res +++ /dev/null @@ -1,2 +0,0 @@ -let x = (a, b, c, d) => a + b -let y = x(2) + 2 diff --git a/jscomp/build_tests/super_errors/fixtures/moreArguments4.res b/jscomp/build_tests/super_errors/fixtures/moreArguments4.res deleted file mode 100644 index 4c652b3..0000000 --- a/jscomp/build_tests/super_errors/fixtures/moreArguments4.res +++ /dev/null @@ -1,2 +0,0 @@ -let x = (a, ~b, ~c, ~d) => a + b -let y = x(2) + 2 diff --git a/jscomp/build_tests/super_errors/fixtures/moreArguments5.res b/jscomp/build_tests/super_errors/fixtures/moreArguments5.res deleted file mode 100644 index 1bd2414..0000000 --- a/jscomp/build_tests/super_errors/fixtures/moreArguments5.res +++ /dev/null @@ -1,5 +0,0 @@ -module Sub = { - type a = {a: int} -} -let x = (a, b, c, d) => {Sub.a: 2} -let y = x(2).Sub.a diff --git a/jscomp/build_tests/super_errors/fixtures/non_function_uncurried_apply.res b/jscomp/build_tests/super_errors/fixtures/non_function_uncurried_apply.res deleted file mode 100644 index da97632..0000000 --- a/jscomp/build_tests/super_errors/fixtures/non_function_uncurried_apply.res +++ /dev/null @@ -1,2 +0,0 @@ -let nonfun = 2 -let _ = nonfun(. 3) diff --git a/jscomp/build_tests/super_errors/fixtures/partial_app.res b/jscomp/build_tests/super_errors/fixtures/partial_app.res deleted file mode 100644 index 19b3d75..0000000 --- a/jscomp/build_tests/super_errors/fixtures/partial_app.res +++ /dev/null @@ -1,5 +0,0 @@ -let f = (a, b, c) => { - a + b + c -} - -f(1, 2) diff --git a/jscomp/build_tests/super_errors/fixtures/polyvariant_name_formatting.res b/jscomp/build_tests/super_errors/fixtures/polyvariant_name_formatting.res deleted file mode 100644 index f28f200..0000000 --- a/jscomp/build_tests/super_errors/fixtures/polyvariant_name_formatting.res +++ /dev/null @@ -1,7 +0,0 @@ -type polyvariant = [#Error(string) | #Valid] - -let f: polyvariant = #Valid - -switch f { -| #Invalid => () -} diff --git a/jscomp/build_tests/super_errors/fixtures/primitives1.res b/jscomp/build_tests/super_errors/fixtures/primitives1.res deleted file mode 100644 index 431b534..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives1.res +++ /dev/null @@ -1,2 +0,0 @@ -/* got float, wanted int */ -2. + 2 diff --git a/jscomp/build_tests/super_errors/fixtures/primitives10.res b/jscomp/build_tests/super_errors/fixtures/primitives10.res deleted file mode 100644 index dc60510..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives10.res +++ /dev/null @@ -1,2 +0,0 @@ -let aaaaa = 10 -let b = aaaab diff --git a/jscomp/build_tests/super_errors/fixtures/primitives11.res b/jscomp/build_tests/super_errors/fixtures/primitives11.res deleted file mode 100644 index 086d926..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives11.res +++ /dev/null @@ -1,5 +0,0 @@ -type aa = option -type bb = option -type a = option -type b = option -let a: a = (Some(Some(5)): b) diff --git a/jscomp/build_tests/super_errors/fixtures/primitives2.res b/jscomp/build_tests/super_errors/fixtures/primitives2.res deleted file mode 100644 index d5d5467..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives2.res +++ /dev/null @@ -1,2 +0,0 @@ -/* got int, wanted string */ -2 ++ " things" diff --git a/jscomp/build_tests/super_errors/fixtures/primitives3.res b/jscomp/build_tests/super_errors/fixtures/primitives3.res deleted file mode 100644 index 824693e..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives3.res +++ /dev/null @@ -1,3 +0,0 @@ -/* Too many arguments */ -let x = a => a + 2 -x(2, 4) diff --git a/jscomp/build_tests/super_errors/fixtures/primitives4.res b/jscomp/build_tests/super_errors/fixtures/primitives4.res deleted file mode 100644 index 94b0c1e..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives4.res +++ /dev/null @@ -1,3 +0,0 @@ -/* Not a function */ -let x = 10 -x(10) diff --git a/jscomp/build_tests/super_errors/fixtures/primitives5.res b/jscomp/build_tests/super_errors/fixtures/primitives5.res deleted file mode 100644 index de2ab50..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives5.res +++ /dev/null @@ -1,3 +0,0 @@ -/* Not enough arguments */ -type x = X(int, float) -X(10)->ignore diff --git a/jscomp/build_tests/super_errors/fixtures/primitives6.res b/jscomp/build_tests/super_errors/fixtures/primitives6.res deleted file mode 100644 index 7f192c9..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives6.res +++ /dev/null @@ -1,3 +0,0 @@ -/* Wrong constructor argument */ -type x = X(int, float) -X(10, 10)->ignore diff --git a/jscomp/build_tests/super_errors/fixtures/primitives7.res b/jscomp/build_tests/super_errors/fixtures/primitives7.res deleted file mode 100644 index d456521..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives7.res +++ /dev/null @@ -1,3 +0,0 @@ -/* Wanted list(float), found list(int) */ -let a = list{1, 2, 3} -List.map(n => n +. 2., a) diff --git a/jscomp/build_tests/super_errors/fixtures/primitives8.res b/jscomp/build_tests/super_errors/fixtures/primitives8.res deleted file mode 100644 index 8cf2256..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives8.res +++ /dev/null @@ -1 +0,0 @@ -let asd = aaa diff --git a/jscomp/build_tests/super_errors/fixtures/primitives9.res b/jscomp/build_tests/super_errors/fixtures/primitives9.res deleted file mode 100644 index f6637bd..0000000 --- a/jscomp/build_tests/super_errors/fixtures/primitives9.res +++ /dev/null @@ -1 +0,0 @@ -let a: int = "hello" diff --git a/jscomp/build_tests/super_errors/fixtures/private_without_body.res b/jscomp/build_tests/super_errors/fixtures/private_without_body.res deleted file mode 100644 index cadfcfd..0000000 --- a/jscomp/build_tests/super_errors/fixtures/private_without_body.res +++ /dev/null @@ -1,2 +0,0 @@ -%%private -let a = 2 diff --git a/jscomp/build_tests/super_errors/fixtures/record_type_spreads.res b/jscomp/build_tests/super_errors/fixtures/record_type_spreads.res deleted file mode 100644 index 7f0a675..0000000 --- a/jscomp/build_tests/super_errors/fixtures/record_type_spreads.res +++ /dev/null @@ -1,5 +0,0 @@ -type t = {x: int, y: string} - -type t2 = {x: string, y: float} - -type t3 = {...t, ...t2} diff --git a/jscomp/build_tests/super_errors/fixtures/record_type_spreads_deep_sub.res b/jscomp/build_tests/super_errors/fixtures/record_type_spreads_deep_sub.res deleted file mode 100644 index 8268109..0000000 --- a/jscomp/build_tests/super_errors/fixtures/record_type_spreads_deep_sub.res +++ /dev/null @@ -1,9 +0,0 @@ -// Checks that deep subsitution works as intended -type t<'a, 'b> = {x: result<'a, 'b>} -type d = { - ...t, -} - -let d: d = { - x: Ok("this errors"), -} diff --git a/jscomp/build_tests/super_errors/fixtures/recursive_type.res b/jscomp/build_tests/super_errors/fixtures/recursive_type.res deleted file mode 100644 index b21eb02..0000000 --- a/jscomp/build_tests/super_errors/fixtures/recursive_type.res +++ /dev/null @@ -1,37 +0,0 @@ -@@uncurried - -// test.res -type rec tt = [ - | #List(list) -] -type sexp = tt - -/* {2 Serialization (encoding)} */ - - -let rec expr_starting_with = (c, k, t) => - switch c { - | '(' => expr_list(list{}, k, t) - | c => atom(k, t) - } - -/* parse list */ -and expr_list = (acc, k, t) => { - switch assert(false) { - | ')' => k(None, #List(acc)) - | c => - expr_starting_with( - c, - (last, e) => - switch last { - | _ => expr_list(list{e, ...acc}, k, t) - }, - t, - ) - } -} -/* parse atom */ -and atom = (k, t) => { - let _ = atom(k) - assert(false) -} \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/repeated_def_extension_constr.res b/jscomp/build_tests/super_errors/fixtures/repeated_def_extension_constr.res deleted file mode 100644 index 80f0641..0000000 --- a/jscomp/build_tests/super_errors/fixtures/repeated_def_extension_constr.res +++ /dev/null @@ -1,3 +0,0 @@ -type a = .. - -type a diff --git a/jscomp/build_tests/super_errors/fixtures/repeated_def_module_types.res b/jscomp/build_tests/super_errors/fixtures/repeated_def_module_types.res deleted file mode 100644 index e6a5796..0000000 --- a/jscomp/build_tests/super_errors/fixtures/repeated_def_module_types.res +++ /dev/null @@ -1,3 +0,0 @@ -module type M = {} - -module type M = {} diff --git a/jscomp/build_tests/super_errors/fixtures/repeated_def_modules.res b/jscomp/build_tests/super_errors/fixtures/repeated_def_modules.res deleted file mode 100644 index 9d9253c..0000000 --- a/jscomp/build_tests/super_errors/fixtures/repeated_def_modules.res +++ /dev/null @@ -1,3 +0,0 @@ -module M = {} - -module M = {} diff --git a/jscomp/build_tests/super_errors/fixtures/repeated_def_types.res b/jscomp/build_tests/super_errors/fixtures/repeated_def_types.res deleted file mode 100644 index 995e818..0000000 --- a/jscomp/build_tests/super_errors/fixtures/repeated_def_types.res +++ /dev/null @@ -1,3 +0,0 @@ -type a - -type a diff --git a/jscomp/build_tests/super_errors/fixtures/set_record_field_type_match.res b/jscomp/build_tests/super_errors/fixtures/set_record_field_type_match.res deleted file mode 100644 index f280f42..0000000 --- a/jscomp/build_tests/super_errors/fixtures/set_record_field_type_match.res +++ /dev/null @@ -1,11 +0,0 @@ -type record = { - mutable name: string, - age: int, -} - -let user = { - name: "Test", - age: 99, -} - -user.name = 12 diff --git a/jscomp/build_tests/super_errors/fixtures/switch_different_types.res b/jscomp/build_tests/super_errors/fixtures/switch_different_types.res deleted file mode 100644 index de9a693..0000000 --- a/jscomp/build_tests/super_errors/fixtures/switch_different_types.res +++ /dev/null @@ -1,9 +0,0 @@ -@val external foo: string = "foo" -external someFunction: unit => string = "someFunction" - -let bar = () => { - switch foo { - | "world" => () - | _ => someFunction() - } -} diff --git a/jscomp/build_tests/super_errors/fixtures/switch_guard.res b/jscomp/build_tests/super_errors/fixtures/switch_guard.res deleted file mode 100644 index 7c3786b..0000000 --- a/jscomp/build_tests/super_errors/fixtures/switch_guard.res +++ /dev/null @@ -1,9 +0,0 @@ -@val external foo: string = "foo" -external someFunction: unit => string = "someFunction" - -let bar = () => { - switch foo { - | "world" if "horse" => () - | _ => someFunction() - } -} diff --git a/jscomp/build_tests/super_errors/fixtures/syntaxErrors1.res b/jscomp/build_tests/super_errors/fixtures/syntaxErrors1.res deleted file mode 100644 index 6b74450..0000000 --- a/jscomp/build_tests/super_errors/fixtures/syntaxErrors1.res +++ /dev/null @@ -1 +0,0 @@ -let b = fo;;;;;;;;;;;;;;;; diff --git a/jscomp/build_tests/super_errors/fixtures/syntaxErrors2.res b/jscomp/build_tests/super_errors/fixtures/syntaxErrors2.res deleted file mode 100644 index 17cf272..0000000 --- a/jscomp/build_tests/super_errors/fixtures/syntaxErrors2.res +++ /dev/null @@ -1,2 +0,0 @@ -let () = - I'm glad you're looking at this file =) diff --git a/jscomp/build_tests/super_errors/fixtures/syntaxErrors3.res b/jscomp/build_tests/super_errors/fixtures/syntaxErrors3.res deleted file mode 100644 index ab3926e..0000000 --- a/jscomp/build_tests/super_errors/fixtures/syntaxErrors3.res +++ /dev/null @@ -1 +0,0 @@ -let a = print_char('a) diff --git a/jscomp/build_tests/super_errors/fixtures/syntaxErrors4.res b/jscomp/build_tests/super_errors/fixtures/syntaxErrors4.res deleted file mode 100644 index c411ea1..0000000 --- a/jscomp/build_tests/super_errors/fixtures/syntaxErrors4.res +++ /dev/null @@ -1,25 +0,0 @@ - -/* */ -/* */ -/* */ -let a:int = "asdaaaaaaaaaaaaaaaaaaaaa -aa -aa -aa -aa -aa -aa -aa -aa -aa -aa -aa -aa -aa -aa -aa -aa" -/* */ -/* */ -/* */ -/* */ diff --git a/jscomp/build_tests/super_errors/fixtures/syntaxErrors5.res b/jscomp/build_tests/super_errors/fixtures/syntaxErrors5.res deleted file mode 100644 index 9d9c5c3..0000000 --- a/jscomp/build_tests/super_errors/fixtures/syntaxErrors5.res +++ /dev/null @@ -1 +0,0 @@ -let a = (1, 2 diff --git a/jscomp/build_tests/super_errors/fixtures/todo_with_no_payload.res b/jscomp/build_tests/super_errors/fixtures/todo_with_no_payload.res deleted file mode 100644 index d7aa606..0000000 --- a/jscomp/build_tests/super_errors/fixtures/todo_with_no_payload.res +++ /dev/null @@ -1,5 +0,0 @@ -let implementMeLater = (): string => %todo - -let x = implementMeLater() - -Js.log(x->Js.String2.includes("x")) diff --git a/jscomp/build_tests/super_errors/fixtures/todo_with_payload.res b/jscomp/build_tests/super_errors/fixtures/todo_with_payload.res deleted file mode 100644 index a52d80d..0000000 --- a/jscomp/build_tests/super_errors/fixtures/todo_with_payload.res +++ /dev/null @@ -1,5 +0,0 @@ -let implementMeLater = (): string => %todo("This should return a string eventually.") - -let x = implementMeLater() - -Js.log(x->Js.String2.includes("x")) diff --git a/jscomp/build_tests/super_errors/fixtures/top_level_fn_call_not_unit.res b/jscomp/build_tests/super_errors/fixtures/top_level_fn_call_not_unit.res deleted file mode 100644 index 25fae76..0000000 --- a/jscomp/build_tests/super_errors/fixtures/top_level_fn_call_not_unit.res +++ /dev/null @@ -1,3 +0,0 @@ -let returnsSomething = () => 123 - -returnsSomething() diff --git a/jscomp/build_tests/super_errors/fixtures/top_level_value_not_unit.res b/jscomp/build_tests/super_errors/fixtures/top_level_value_not_unit.res deleted file mode 100644 index 81c545e..0000000 --- a/jscomp/build_tests/super_errors/fixtures/top_level_value_not_unit.res +++ /dev/null @@ -1 +0,0 @@ -1234 diff --git a/jscomp/build_tests/super_errors/fixtures/type1.res b/jscomp/build_tests/super_errors/fixtures/type1.res deleted file mode 100644 index f2b6996..0000000 --- a/jscomp/build_tests/super_errors/fixtures/type1.res +++ /dev/null @@ -1 +0,0 @@ -let x = 2. + 2 diff --git a/jscomp/build_tests/super_errors/fixtures/type2.res b/jscomp/build_tests/super_errors/fixtures/type2.res deleted file mode 100644 index 12f507a..0000000 --- a/jscomp/build_tests/super_errors/fixtures/type2.res +++ /dev/null @@ -1,7 +0,0 @@ -@send external push: (array<'a>, 'a) => unit = "push" - -let a = [] -let () = { - push(a, 3)->ignore - push(a, "3")->ignore -} diff --git a/jscomp/build_tests/super_errors/fixtures/type3.res b/jscomp/build_tests/super_errors/fixtures/type3.res deleted file mode 100644 index 8a672bd..0000000 --- a/jscomp/build_tests/super_errors/fixtures/type3.res +++ /dev/null @@ -1 +0,0 @@ -let u = [] diff --git a/jscomp/build_tests/super_errors/fixtures/u_for_c_in_c_mode.res b/jscomp/build_tests/super_errors/fixtures/u_for_c_in_c_mode.res deleted file mode 100644 index f1da111..0000000 --- a/jscomp/build_tests/super_errors/fixtures/u_for_c_in_c_mode.res +++ /dev/null @@ -1,5 +0,0 @@ -module Foo: { - let add: (int, int) => int -} = { - let add = (. a, b) => a + b -} diff --git a/jscomp/build_tests/super_errors/fixtures/u_for_c_in_u_mode.res b/jscomp/build_tests/super_errors/fixtures/u_for_c_in_u_mode.res deleted file mode 100644 index 85e59db..0000000 --- a/jscomp/build_tests/super_errors/fixtures/u_for_c_in_u_mode.res +++ /dev/null @@ -1,8 +0,0 @@ -@@uncurried - -module Foo: { - @@uncurried.swap - let add: (. int, int) => int -} = { - let add = (a, b) => a + b -} diff --git a/jscomp/build_tests/super_errors/fixtures/uncurried_expected.res b/jscomp/build_tests/super_errors/fixtures/uncurried_expected.res deleted file mode 100644 index 6fad3ef..0000000 --- a/jscomp/build_tests/super_errors/fixtures/uncurried_expected.res +++ /dev/null @@ -1,2 +0,0 @@ -let apply = (f) => f(. 1) -let z = apply(x => x+1) diff --git a/jscomp/build_tests/super_errors/fixtures/uncurried_wrong_label.res b/jscomp/build_tests/super_errors/fixtures/uncurried_wrong_label.res deleted file mode 100644 index aaa3746..0000000 --- a/jscomp/build_tests/super_errors/fixtures/uncurried_wrong_label.res +++ /dev/null @@ -1,3 +0,0 @@ -let foo = (. ~x) => { let _ = (); (~y) => x+y } -// This looks too far into the return type -let d = foo(. ~y=3) diff --git a/jscomp/build_tests/super_errors/fixtures/unicode_location.res b/jscomp/build_tests/super_errors/fixtures/unicode_location.res deleted file mode 100644 index e64643c..0000000 --- a/jscomp/build_tests/super_errors/fixtures/unicode_location.res +++ /dev/null @@ -1,2 +0,0 @@ -let q = "💩💩💩💩💩💩💩💩💩💩" ++ ("a" ++ 3 ++ "b") -// ^ character position 33 + 10 (unicode symbols of length 2) \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/unknown_tagged_template_function.res b/jscomp/build_tests/super_errors/fixtures/unknown_tagged_template_function.res deleted file mode 100644 index 40a9532..0000000 --- a/jscomp/build_tests/super_errors/fixtures/unknown_tagged_template_function.res +++ /dev/null @@ -1 +0,0 @@ -let res = tagg`| 5 × 10 = ${5} |` \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/unused_warnings.res b/jscomp/build_tests/super_errors/fixtures/unused_warnings.res deleted file mode 100644 index 5fe4358..0000000 --- a/jscomp/build_tests/super_errors/fixtures/unused_warnings.res +++ /dev/null @@ -1,3 +0,0 @@ -let a = 3 -let a = 33 + 3 -let a = 33 + 3 + 3 diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_bigint.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_bigint.res deleted file mode 100644 index 4f23f40..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_bigint.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = | @as(1n) One(bool) | @as(2n) Two - -let x = One(true) - -let y = (x :> bigint) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_bigint_as.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_bigint_as.res deleted file mode 100644 index d3a3cc1..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_bigint_as.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = | @as(1n) One | Two - -let x = One - -let y = (x :> bigint) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_float.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_float.res deleted file mode 100644 index 72958ef..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_float.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = | @as(1.1) One(bool) | @as(2.2) Two - -let x = One(true) - -let y = (x :> float) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_float_as.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_float_as.res deleted file mode 100644 index 8d4ed7e..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_float_as.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = | @as(1.1) One | Two - -let x = One - -let y = (x :> float) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_int.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_int.res deleted file mode 100644 index 6a4fcf8..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_int.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = | @as(1) One(bool) | @as(2) Two - -let x = One(true) - -let y = (x :> int) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_int_as.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_int_as.res deleted file mode 100644 index db4adc0..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_int_as.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = | @as(1) One | Two - -let x = One - -let y = (x :> int) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_string.res deleted file mode 100644 index 48e928a..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = One(bool) | Two - -let x = One(true) - -let y = (x :> string) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_as.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_as.res deleted file mode 100644 index 74af95f..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_as.res +++ /dev/null @@ -1,5 +0,0 @@ -type x = One | @as(2) Two - -let x = One - -let y = (x :> string) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_to_variant_no_payload.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_to_variant_no_payload.res deleted file mode 100644 index fd92df2..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_to_variant_no_payload.res +++ /dev/null @@ -1,6 +0,0 @@ -@unboxed -type x = One | Two - -let x = "one" - -let y = (x :> x) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_unboxed.res b/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_unboxed.res deleted file mode 100644 index bce8ba5..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_coercion_string_unboxed.res +++ /dev/null @@ -1,6 +0,0 @@ -@unboxed -type x = One | Two | Other(float) - -let x = One - -let y = (x :> string) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_abstract_type.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_abstract_type.res deleted file mode 100644 index ae52ca5..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_abstract_type.res +++ /dev/null @@ -1,2 +0,0 @@ -type a -type b = | ...a | Other diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_duplicate_constructors.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_duplicate_constructors.res deleted file mode 100644 index fdb83f0..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_duplicate_constructors.res +++ /dev/null @@ -1,3 +0,0 @@ -type a = One | Two -type b = Two | Three -type c = | ...a | ...b | Four diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_extensible_variant.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_extensible_variant.res deleted file mode 100644 index 344b0f6..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_extensible_variant.res +++ /dev/null @@ -1,2 +0,0 @@ -type a = .. -type b = | ...a | Other diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_inline_records.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_inline_records.res deleted file mode 100644 index 1d05797..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_inline_records.res +++ /dev/null @@ -1,4 +0,0 @@ -type a = One({name: string, age: int}) | Two -type b = | ...a | Three - -let b: b = One({name: "hello"}) \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_recursive.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_recursive.res deleted file mode 100644 index 2ae0cfe..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_recursive.res +++ /dev/null @@ -1 +0,0 @@ -type rec a = One | Two | Three and b = Four | Five and c = | ...a | ...b diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_tag_missing.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_tag_missing.res deleted file mode 100644 index a1958f2..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_tag_missing.res +++ /dev/null @@ -1,2 +0,0 @@ -@tag("kind") type a = One(int) | Two(string) -type b = | ...a | Three(bool) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_tag_value_mismatch.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_tag_value_mismatch.res deleted file mode 100644 index 1adcd09..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_tag_value_mismatch.res +++ /dev/null @@ -1,2 +0,0 @@ -@tag("kind") type a = One(int) | Two(string) -@tag("name") type b = | ...a | Three(bool) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_type_parameters.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_type_parameters.res deleted file mode 100644 index 118789f..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_type_parameters.res +++ /dev/null @@ -1,2 +0,0 @@ -type a<'a> = One | Two('a) -type b = | ...a | Three \ No newline at end of file diff --git a/jscomp/build_tests/super_errors/fixtures/variant_spread_unboxed_mismatch.res b/jscomp/build_tests/super_errors/fixtures/variant_spread_unboxed_mismatch.res deleted file mode 100644 index 425c4bb..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_spread_unboxed_mismatch.res +++ /dev/null @@ -1,2 +0,0 @@ -@unboxed type a = One(int) | Two(string) -type b = | ...a | Three(bool) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res deleted file mode 100644 index 6198fb6..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion.res +++ /dev/null @@ -1,6 +0,0 @@ -type x = One(bool) | Two -type y = One(string) | Two - -let x: x = One(true) - -let y = (x :> y) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res deleted file mode 100644 index 9a9394d..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_as.res +++ /dev/null @@ -1,6 +0,0 @@ -type x = | @as("one") One(bool) | Two(string) -type y = One(bool) | Two(string) - -let x: x = One(true) - -let y = (x :> y) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res deleted file mode 100644 index 7fb7808..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_tag.res +++ /dev/null @@ -1,6 +0,0 @@ -@tag("kind") type x = One(bool) | Two(string) -type y = One(bool) | Two(string) - -let x: x = One(true) - -let y = (x :> y) diff --git a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res b/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res deleted file mode 100644 index d0896f0..0000000 --- a/jscomp/build_tests/super_errors/fixtures/variant_to_variant_coercion_unboxed.res +++ /dev/null @@ -1,6 +0,0 @@ -@unboxed type x = One(bool) | Two -type y = One(bool) | Two - -let x: x = One(true) - -let y = (x :> y) diff --git a/jscomp/build_tests/super_errors/fixtures/warnings1.res b/jscomp/build_tests/super_errors/fixtures/warnings1.res deleted file mode 100644 index 7ba4a79..0000000 --- a/jscomp/build_tests/super_errors/fixtures/warnings1.res +++ /dev/null @@ -1,5 +0,0 @@ -let x = (a, b) => a + b -let z = () => { - x(10) - 10 -} diff --git a/jscomp/build_tests/super_errors/fixtures/warnings2.res b/jscomp/build_tests/super_errors/fixtures/warnings2.res deleted file mode 100644 index 16b2cff..0000000 --- a/jscomp/build_tests/super_errors/fixtures/warnings2.res +++ /dev/null @@ -1,4 +0,0 @@ -let z = () => { - 10 - 10 -} diff --git a/jscomp/build_tests/super_errors/fixtures/warnings3.res b/jscomp/build_tests/super_errors/fixtures/warnings3.res deleted file mode 100644 index 92498ef..0000000 --- a/jscomp/build_tests/super_errors/fixtures/warnings3.res +++ /dev/null @@ -1,3 +0,0 @@ -let _ = string_of_float(34.) -let _ = string_of_float(34.) -let _ = string_of_float(34.) diff --git a/jscomp/build_tests/super_errors/fixtures/warnings4.res b/jscomp/build_tests/super_errors/fixtures/warnings4.res deleted file mode 100644 index 326f2a1..0000000 --- a/jscomp/build_tests/super_errors/fixtures/warnings4.res +++ /dev/null @@ -1,13 +0,0 @@ -type myType = [ - | #first - | #second(string) - | #third - | #fourth -] - -// just a quick way to make the switch compile -@val external x: myType = "myVariable" - -switch x { - | #first => Js.log("first") -} diff --git a/jscomp/build_tests/super_errors/fixtures/warnings5.res b/jscomp/build_tests/super_errors/fixtures/warnings5.res deleted file mode 100644 index 9e69c50..0000000 --- a/jscomp/build_tests/super_errors/fixtures/warnings5.res +++ /dev/null @@ -1,59 +0,0 @@ -type someTyp = Variant | WithPayload(bool) | One | Two | Three | Four | Five | Six | Seven(int) - -type someRecord = { - someValue: string, - otherValue: bool, - typ: someTyp, -} - -@val external y: someRecord = "otherVariable" - -switch y { -| {otherValue: false} => Js.log("first") -} - -switch y { -| {typ: WithPayload(true)} => Js.log("first") -} - -let arr = [1] - -switch arr { -| [] => Js.log("") -} - -switch arr { -| [one] => Js.log(one) -} - -switch arr { -| [1, 2] => () -} - -let lst = list{} - -switch lst { -| list{} => () -} - -switch lst { -| list{1, 2} => () -} - -switch lst { -| list{1} => () -} - -switch "abc" { -| "" => () -} - -switch 0 { -| 1 => () -} - -let tuple = (1, true) - -switch tuple { -| (_, false) => () -} diff --git a/jscomp/build_tests/super_errors/fixtures/wrong_name_component_prop.res b/jscomp/build_tests/super_errors/fixtures/wrong_name_component_prop.res deleted file mode 100644 index 2028c2e..0000000 --- a/jscomp/build_tests/super_errors/fixtures/wrong_name_component_prop.res +++ /dev/null @@ -1,32 +0,0 @@ -module SomeComplicatedModuleStructure = { - module NestedModuleHere = { - type t = string - } -} - -module Component = { - type props<'name, 'second, 'third, 'fourth, 'fifth, 'sixth, 'seventh, 'eight, 'ninth> = { - name: 'name, - second: 'second, - third: 'third, - fourth: 'fourth, - fifth: 'fifth, - sixth: 'sixth, - seventh: 'seventh, - eight: 'eight, - ninth: 'ninth, - } - let make = props => { - props.name ++ - props.second ++ - props.third ++ - props.fourth ++ - props.fifth ++ - props.sixth ++ - props.seventh ++ - props.eight ++ - props.ninth - } -} - -let dddd = Component.make({nonExistant: "hello"}) diff --git a/jscomp/build_tests/super_errors/fixtures/wrong_name_record_field.res b/jscomp/build_tests/super_errors/fixtures/wrong_name_record_field.res deleted file mode 100644 index 7ebbbe2..0000000 --- a/jscomp/build_tests/super_errors/fixtures/wrong_name_record_field.res +++ /dev/null @@ -1,5 +0,0 @@ -type d = {z: int} - -let ff: d = { - zz: 123, -} diff --git a/jscomp/build_tests/super_errors/input.js b/jscomp/build_tests/super_errors/input.js deleted file mode 100644 index 7af2824..0000000 --- a/jscomp/build_tests/super_errors/input.js +++ /dev/null @@ -1,64 +0,0 @@ -const fs = require("fs"); -const path = require("path"); -const child_process = require("child_process"); - -var bsc = require("../../../scripts/bin_path").bsc_exe; - -const expectedDir = path.join(__dirname, "expected"); - -const fixtures = fs - .readdirSync(path.join(__dirname, "fixtures")) - .filter(fileName => path.extname(fileName) === ".res"); - -// const runtime = path.join(__dirname, '..', '..', 'runtime') -const prefix = `${bsc} -w +A`; - -const updateTests = process.argv[2] === "update"; - -function postProcessErrorOutput(output) { - output = output.trimRight(); - output = output.replace( - /\/[^ ]+?jscomp\/build_tests\/super_errors\//g, - "/.../" - ); - return output; -} - -let doneTasksCount = 0; -let atLeastOneTaskFailed = false; - -fixtures.forEach(fileName => { - const fullFilePath = path.join(__dirname, "fixtures", fileName); - const command = `${prefix} -color always ${fullFilePath}`; - console.log(`running ${command}`); - child_process.exec(command, (err, stdout, stderr) => { - doneTasksCount++; - // careful of: - // - warning test that actually succeeded in compiling (warning's still in stderr, so the code path is shared here) - // - accidentally succeeding tests (not likely in this context), - // actual, correctly erroring test case - const actualErrorOutput = postProcessErrorOutput(stderr.toString()); - const expectedFilePath = path.join(expectedDir, fileName + ".expected"); - if (updateTests) { - fs.writeFileSync(expectedFilePath, actualErrorOutput); - } else { - const expectedErrorOutput = postProcessErrorOutput( - fs.readFileSync(expectedFilePath, { encoding: "utf-8" }) - ); - if (expectedErrorOutput !== actualErrorOutput) { - console.error( - `The old and new error output for the test ${fullFilePath} aren't the same` - ); - console.error("\n=== Old:"); - console.error(expectedErrorOutput); - console.error("\n=== New:"); - console.error(actualErrorOutput); - atLeastOneTaskFailed = true; - } - - if (doneTasksCount === fixtures.length && atLeastOneTaskFailed) { - process.exit(1); - } - } - }); -}); diff --git a/jscomp/build_tests/transitive_pinned_dependency1/.gitignore b/jscomp/build_tests/transitive_pinned_dependency1/.gitignore deleted file mode 100644 index 7951405..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/.gitignore +++ /dev/null @@ -1 +0,0 @@ -lib \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/a/package.json b/jscomp/build_tests/transitive_pinned_dependency1/a/package.json deleted file mode 100644 index 9113c25..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/a/package.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "name": "a", - "version": "1.0.0" -} diff --git a/jscomp/build_tests/transitive_pinned_dependency1/a/rescript.json b/jscomp/build_tests/transitive_pinned_dependency1/a/rescript.json deleted file mode 100644 index 5a45106..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/a/rescript.json +++ /dev/null @@ -1,27 +0,0 @@ -{ - "name": "a", - "namespace": true, - "sources": [ - { - "dir": "src" - }, - { - "dir": "tests", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": false - }, - "warnings": { - "error": true - }, - "suffix": ".mjs", - "bs-dependencies": [ - "b" - ], - "pinned-dependencies": [ - "b" - ] -} \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/a/src/src.res b/jscomp/build_tests/transitive_pinned_dependency1/a/src/src.res deleted file mode 100644 index 487a974..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/a/src/src.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("src") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/a/tests/test.res b/jscomp/build_tests/transitive_pinned_dependency1/a/tests/test.res deleted file mode 100644 index fd01e9e..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/a/tests/test.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("test") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/input.js b/jscomp/build_tests/transitive_pinned_dependency1/input.js deleted file mode 100644 index 080b222..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/input.js +++ /dev/null @@ -1,14 +0,0 @@ -//@ts-check -var child_process = require("child_process"); -var assert = require("assert"); -var fs = require("fs"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -console.log( - child_process.execSync(rescript_exe, { encoding: "utf8", cwd: "./a" }) -); - -assert( - fs.existsSync("./node_modules/c/lib/js/tests/test.mjs"), - "dev files of module 'c' were not built by 'a' even though 'c' is a transitive pinned dependency of 'a' through 'b'" -); diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/bsconfig.json b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/bsconfig.json deleted file mode 100644 index 1bbb63d..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/bsconfig.json +++ /dev/null @@ -1,27 +0,0 @@ -{ - "name": "b", - "namespace": true, - "sources": [ - { - "dir": "src" - }, - { - "dir": "tests", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": false - }, - "warnings": { - "error": true - }, - "suffix": ".mjs", - "bs-dependencies": [ - "c" - ], - "pinned-dependencies": [ - "c" - ] -} \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/package.json b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/package.json deleted file mode 100644 index c2d84cc..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/package.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "name": "b", - "version": "1.0.0" -} diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/src/src.res b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/src/src.res deleted file mode 100644 index 487a974..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/src/src.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("src") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/tests/test.res b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/tests/test.res deleted file mode 100644 index fd01e9e..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/b/tests/test.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("test") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/bsconfig.json b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/bsconfig.json deleted file mode 100644 index c481bde..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/bsconfig.json +++ /dev/null @@ -1,21 +0,0 @@ -{ - "name": "c", - "namespace": true, - "sources": [ - { - "dir": "src" - }, - { - "dir": "tests", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": false - }, - "warnings": { - "error": true - }, - "suffix": ".mjs" -} \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/package.json b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/package.json deleted file mode 100644 index abd3384..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/package.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "name": "c", - "version": "1.0.0" -} diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/src/src.res b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/src/src.res deleted file mode 100644 index 487a974..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/src/src.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("src") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/tests/test.res b/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/tests/test.res deleted file mode 100644 index fd01e9e..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/node_modules/c/tests/test.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("test") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency1/package.json b/jscomp/build_tests/transitive_pinned_dependency1/package.json deleted file mode 100644 index cc49c26..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency1/package.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "top", - "workspaces": [ - "a", - "b", - "c" - ] -} diff --git a/jscomp/build_tests/transitive_pinned_dependency2/.gitignore b/jscomp/build_tests/transitive_pinned_dependency2/.gitignore deleted file mode 100644 index 7951405..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/.gitignore +++ /dev/null @@ -1 +0,0 @@ -lib \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/a/package.json b/jscomp/build_tests/transitive_pinned_dependency2/a/package.json deleted file mode 100644 index 9113c25..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/a/package.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "name": "a", - "version": "1.0.0" -} diff --git a/jscomp/build_tests/transitive_pinned_dependency2/a/rescript.json b/jscomp/build_tests/transitive_pinned_dependency2/a/rescript.json deleted file mode 100644 index ee6dff6..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/a/rescript.json +++ /dev/null @@ -1,24 +0,0 @@ -{ - "name": "a", - "namespace": true, - "sources": [ - { - "dir": "src" - }, - { - "dir": "tests", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": false - }, - "warnings": { - "error": true - }, - "suffix": ".mjs", - "bs-dependencies": [ - "b" - ] -} \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/a/src/src.res b/jscomp/build_tests/transitive_pinned_dependency2/a/src/src.res deleted file mode 100644 index 487a974..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/a/src/src.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("src") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/a/tests/test.res b/jscomp/build_tests/transitive_pinned_dependency2/a/tests/test.res deleted file mode 100644 index fd01e9e..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/a/tests/test.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("test") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/input.js b/jscomp/build_tests/transitive_pinned_dependency2/input.js deleted file mode 100644 index 2ec048a..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/input.js +++ /dev/null @@ -1,14 +0,0 @@ -//@ts-check -var child_process = require("child_process"); -var assert = require("assert"); -var fs = require("fs"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -console.log( - child_process.execSync(rescript_exe, { encoding: "utf8", cwd: "./a" }) -); - -assert( - !fs.existsSync("./node_modules/c/lib/js/tests/test.mjs"), - "dev files of module 'c' were built by 'a' even though 'c' is not a pinned dependency of 'a'" -); diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/bsconfig.json b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/bsconfig.json deleted file mode 100644 index 1bbb63d..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/bsconfig.json +++ /dev/null @@ -1,27 +0,0 @@ -{ - "name": "b", - "namespace": true, - "sources": [ - { - "dir": "src" - }, - { - "dir": "tests", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": false - }, - "warnings": { - "error": true - }, - "suffix": ".mjs", - "bs-dependencies": [ - "c" - ], - "pinned-dependencies": [ - "c" - ] -} \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/package.json b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/package.json deleted file mode 100644 index c2d84cc..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/package.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "name": "b", - "version": "1.0.0" -} diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/src/src.res b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/src/src.res deleted file mode 100644 index 487a974..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/src/src.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("src") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/tests/test.res b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/tests/test.res deleted file mode 100644 index fd01e9e..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/b/tests/test.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("test") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/bsconfig.json b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/bsconfig.json deleted file mode 100644 index c481bde..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/bsconfig.json +++ /dev/null @@ -1,21 +0,0 @@ -{ - "name": "c", - "namespace": true, - "sources": [ - { - "dir": "src" - }, - { - "dir": "tests", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": false - }, - "warnings": { - "error": true - }, - "suffix": ".mjs" -} \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/package.json b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/package.json deleted file mode 100644 index abd3384..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/package.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "name": "c", - "version": "1.0.0" -} diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/src/src.res b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/src/src.res deleted file mode 100644 index 487a974..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/src/src.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("src") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/tests/test.res b/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/tests/test.res deleted file mode 100644 index fd01e9e..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/node_modules/c/tests/test.res +++ /dev/null @@ -1 +0,0 @@ -Js.Console.log("test") \ No newline at end of file diff --git a/jscomp/build_tests/transitive_pinned_dependency2/package.json b/jscomp/build_tests/transitive_pinned_dependency2/package.json deleted file mode 100644 index cc49c26..0000000 --- a/jscomp/build_tests/transitive_pinned_dependency2/package.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "top", - "workspaces": [ - "a", - "b", - "c" - ] -} diff --git a/jscomp/build_tests/unboxed_bool_with_const/bsconfig.json b/jscomp/build_tests/unboxed_bool_with_const/bsconfig.json deleted file mode 100644 index 1cbcace..0000000 --- a/jscomp/build_tests/unboxed_bool_with_const/bsconfig.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "name": "unboxed_bool_with_const", - "version": "0.1.0", - "sources": [ - { - "dir": "src", - "subdirs": true - } - ], - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js" -} diff --git a/jscomp/build_tests/unboxed_bool_with_const/input.js b/jscomp/build_tests/unboxed_bool_with_const/input.js deleted file mode 100644 index 4591fda..0000000 --- a/jscomp/build_tests/unboxed_bool_with_const/input.js +++ /dev/null @@ -1,26 +0,0 @@ -//@ts-check - -var cp = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var out = cp.spawnSync(rescript_exe, { - cwd: __dirname, - encoding: "utf8", -}); - -assert.equal( - out.stdout.slice(out.stdout.indexOf("Main.res:3:3-14")), - `Main.res:3:3-14 - - 1 │ @unboxed - 2 │ type t<'a> = - 3 │ | Bool(bool) - 4 │ | @as(false) False - 5 │ | @as(true) True - - This untagged variant definition is invalid: At most one case can be a boolean type. - -FAILED: cannot make progress due to previous errors. -` -); diff --git a/jscomp/build_tests/unboxed_bool_with_const/src/Main.res b/jscomp/build_tests/unboxed_bool_with_const/src/Main.res deleted file mode 100644 index 6ed5758..0000000 --- a/jscomp/build_tests/unboxed_bool_with_const/src/Main.res +++ /dev/null @@ -1,5 +0,0 @@ -@unboxed -type t<'a> = - | Bool(bool) - | @as(false) False - | @as(true) True diff --git a/jscomp/build_tests/uncurried-always/input.js b/jscomp/build_tests/uncurried-always/input.js deleted file mode 100644 index 012c1f0..0000000 --- a/jscomp/build_tests/uncurried-always/input.js +++ /dev/null @@ -1,6 +0,0 @@ -//@ts-check -const cp = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -cp.execSync(`${rescript_exe} clean`, { cwd: __dirname }); -cp.execSync(`${rescript_exe}`, { cwd: __dirname }); diff --git a/jscomp/build_tests/uncurried-always/rescript.json b/jscomp/build_tests/uncurried-always/rescript.json deleted file mode 100644 index d3f1470..0000000 --- a/jscomp/build_tests/uncurried-always/rescript.json +++ /dev/null @@ -1,9 +0,0 @@ -{ - "name": "uncurried", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - }, - "uncurried": true -} diff --git a/jscomp/build_tests/uncurried-always/src/UncurriedAlways.res b/jscomp/build_tests/uncurried-always/src/UncurriedAlways.res deleted file mode 100644 index b6555b4..0000000 --- a/jscomp/build_tests/uncurried-always/src/UncurriedAlways.res +++ /dev/null @@ -1,15 +0,0 @@ -let foo = (x, y) => x + y - -let z = foo(. 3, 4) - -let bar = (. x, y) => x + y - -let b = bar(3, 4) - -let w = 3->foo(4) - -let a = 3->foo(. 4) - -Js.log(a) // Test automatic uncurried application - -let _ = Js.Array2.map([1], (. x) => x+1) diff --git a/jscomp/build_tests/uncurried_printer/input.js b/jscomp/build_tests/uncurried_printer/input.js deleted file mode 100755 index e5b78de..0000000 --- a/jscomp/build_tests/uncurried_printer/input.js +++ /dev/null @@ -1,15 +0,0 @@ -const assert = require("assert"); -const child_process = require("child_process"); -const fs = require("fs"); -const path = require("path"); - -const expectedContent = `let a = (. b) => b\n`; -const filePath = path.join(__dirname, "src", "a.res"); - -fs.writeFileSync(filePath, expectedContent, "utf-8"); - -child_process.execSync(`../../../rescript format -all`, { cwd: __dirname }); - -const content = fs.readFileSync(filePath, "utf-8"); - -assert.equal(content, expectedContent); diff --git a/jscomp/build_tests/uncurried_printer/rescript.json b/jscomp/build_tests/uncurried_printer/rescript.json deleted file mode 100644 index ded06e8..0000000 --- a/jscomp/build_tests/uncurried_printer/rescript.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "name": "uncurried_printer", - "version": "0.1.0", - "sources": ["src"], - "uncurried": false -} diff --git a/jscomp/build_tests/uncurried_printer/src/a.res b/jscomp/build_tests/uncurried_printer/src/a.res deleted file mode 100644 index 568bcab..0000000 --- a/jscomp/build_tests/uncurried_printer/src/a.res +++ /dev/null @@ -1 +0,0 @@ -let a = (. b) => b diff --git a/jscomp/build_tests/unicode/input.js b/jscomp/build_tests/unicode/input.js deleted file mode 100644 index 9a6b83a..0000000 --- a/jscomp/build_tests/unicode/input.js +++ /dev/null @@ -1,14 +0,0 @@ -//@ts-check -var child_process = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -console.log(child_process.execSync(rescript_exe, { encoding: "utf8" })); - -var fs = require("fs"); -var path = require("path"); -var content = - "" + fs.readFileSync(path.join(__dirname, "lib", "bs", ".sourcedirs.json")); - -var assert = require("assert"); - -assert(JSON.parse(content).dirs.some(x => x.includes("📕annotation"))); diff --git a/jscomp/build_tests/unicode/rescript.json b/jscomp/build_tests/unicode/rescript.json deleted file mode 100644 index a8065db..0000000 --- a/jscomp/build_tests/unicode/rescript.json +++ /dev/null @@ -1,7 +0,0 @@ -{ - "name": "unicode", - "sources": { - "dir": ".", - "subdirs": true - } -} diff --git "a/jscomp/build_tests/unicode/\360\237\223\225annotation/a.res" "b/jscomp/build_tests/unicode/\360\237\223\225annotation/a.res" deleted file mode 100644 index 8b13789..0000000 --- "a/jscomp/build_tests/unicode/\360\237\223\225annotation/a.res" +++ /dev/null @@ -1 +0,0 @@ - diff --git "a/jscomp/build_tests/unicode/\360\237\223\227block/b.res" "b/jscomp/build_tests/unicode/\360\237\223\227block/b.res" deleted file mode 100644 index 8b13789..0000000 --- "a/jscomp/build_tests/unicode/\360\237\223\227block/b.res" +++ /dev/null @@ -1 +0,0 @@ - diff --git "a/jscomp/build_tests/unicode/\360\237\223\231inline/c.res" "b/jscomp/build_tests/unicode/\360\237\223\231inline/c.res" deleted file mode 100644 index 8b13789..0000000 --- "a/jscomp/build_tests/unicode/\360\237\223\231inline/c.res" +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/warn_legacy_config/bsconfig.json b/jscomp/build_tests/warn_legacy_config/bsconfig.json deleted file mode 100644 index ff8aa6b..0000000 --- a/jscomp/build_tests/warn_legacy_config/bsconfig.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "warn_legacy_config", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - } -} diff --git a/jscomp/build_tests/warn_legacy_config/input.js b/jscomp/build_tests/warn_legacy_config/input.js deleted file mode 100644 index ad81e9e..0000000 --- a/jscomp/build_tests/warn_legacy_config/input.js +++ /dev/null @@ -1,10 +0,0 @@ -const { spawnSync } = require("child_process"); -const assert = require("assert"); -const rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -const output = spawnSync(rescript_exe, { encoding: "utf8" }); -assert( - /^Warning: bsconfig.json is deprecated. Migrate it to rescript.json/.test( - output.stdout - ) -); diff --git a/jscomp/build_tests/warn_legacy_config/src/demo.res b/jscomp/build_tests/warn_legacy_config/src/demo.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/warn_legacy_config/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/weird_deps/input.js b/jscomp/build_tests/weird_deps/input.js deleted file mode 100644 index 6e2a156..0000000 --- a/jscomp/build_tests/weird_deps/input.js +++ /dev/null @@ -1,24 +0,0 @@ -//@ts-check - -var cp = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var out = cp.spawnSync(rescript_exe, { - cwd: __dirname, - encoding: "utf8", -}); - -if (out.stdout !== "") { - assert.fail(out.stdout); -} else { - assert.equal( - out.stderr, - [ - 'File "bsconfig.json", line 1', - "Error: package weird not found or built ", - "- Did you install it?", - "", - ].join("\n") - ); -} diff --git a/jscomp/build_tests/weird_deps/rescript.json b/jscomp/build_tests/weird_deps/rescript.json deleted file mode 100644 index 4dc59a5..0000000 --- a/jscomp/build_tests/weird_deps/rescript.json +++ /dev/null @@ -1,21 +0,0 @@ -{ - "name": "weird_devdeps", - "version": "0.1.0", - "sources": [ - { - "dir": "src", - "subdirs": true - }, - { - "dir": "test", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": ["weird"], - "warnings": { "error": "+101" } -} diff --git a/jscomp/build_tests/weird_deps/src/demo.res b/jscomp/build_tests/weird_deps/src/demo.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/weird_deps/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/weird_deps/test/test.res b/jscomp/build_tests/weird_deps/test/test.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/weird_deps/test/test.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/weird_devdeps/input.js b/jscomp/build_tests/weird_devdeps/input.js deleted file mode 100644 index 6e2a156..0000000 --- a/jscomp/build_tests/weird_devdeps/input.js +++ /dev/null @@ -1,24 +0,0 @@ -//@ts-check - -var cp = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var out = cp.spawnSync(rescript_exe, { - cwd: __dirname, - encoding: "utf8", -}); - -if (out.stdout !== "") { - assert.fail(out.stdout); -} else { - assert.equal( - out.stderr, - [ - 'File "bsconfig.json", line 1', - "Error: package weird not found or built ", - "- Did you install it?", - "", - ].join("\n") - ); -} diff --git a/jscomp/build_tests/weird_devdeps/rescript.json b/jscomp/build_tests/weird_devdeps/rescript.json deleted file mode 100644 index 91696bc..0000000 --- a/jscomp/build_tests/weird_devdeps/rescript.json +++ /dev/null @@ -1,22 +0,0 @@ -{ - "name": "weird_devdeps", - "version": "0.1.0", - "sources": [ - { - "dir": "src", - "subdirs": true - }, - { - "dir": "test", - "type": "dev" - } - ], - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [], - "bs-dev-dependencies": ["weird"], - "warnings": { "error": "+101" } -} diff --git a/jscomp/build_tests/weird_devdeps/src/demo.res b/jscomp/build_tests/weird_devdeps/src/demo.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/weird_devdeps/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/weird_devdeps/test/test.res b/jscomp/build_tests/weird_devdeps/test/test.res deleted file mode 100644 index 8b13789..0000000 --- a/jscomp/build_tests/weird_devdeps/test/test.res +++ /dev/null @@ -1 +0,0 @@ - diff --git a/jscomp/build_tests/weird_names/input.js b/jscomp/build_tests/weird_names/input.js deleted file mode 100644 index f9643f7..0000000 --- a/jscomp/build_tests/weird_names/input.js +++ /dev/null @@ -1,26 +0,0 @@ -var cp = require("child_process"); -var assert = require("assert"); -var path = require("path"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var out = cp.spawnSync(rescript_exe, { encoding: "utf8" }); - -if (out.stderr !== "") { - assert.fail(out.stderr); -} - -let files = [ - "_app.res", - "[...params_max_3].res", - "[...params].res", - "[[...params]].res", - "[slug_or_ID].res", - "404.res", - "utils.test.res", -]; - -for (let f of files) { - let { name } = path.parse(f); - let m = `./lib/js/src/${name}.js`; - assert.deepEqual(require(m).a, 1); -} diff --git a/jscomp/build_tests/weird_names/rescript.json b/jscomp/build_tests/weird_names/rescript.json deleted file mode 100644 index 305524e..0000000 --- a/jscomp/build_tests/weird_names/rescript.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "weird_names", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - } -} diff --git a/jscomp/build_tests/weird_names/src/404.res b/jscomp/build_tests/weird_names/src/404.res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names/src/404.res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/weird_names/src/[...params].res b/jscomp/build_tests/weird_names/src/[...params].res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names/src/[...params].res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/weird_names/src/[...params_max_3].res b/jscomp/build_tests/weird_names/src/[...params_max_3].res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names/src/[...params_max_3].res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/weird_names/src/[[...params]].res b/jscomp/build_tests/weird_names/src/[[...params]].res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names/src/[[...params]].res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/weird_names/src/[slug_or_ID].res b/jscomp/build_tests/weird_names/src/[slug_or_ID].res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names/src/[slug_or_ID].res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/weird_names/src/_app.res b/jscomp/build_tests/weird_names/src/_app.res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names/src/_app.res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/weird_names/src/demo.res b/jscomp/build_tests/weird_names/src/demo.res deleted file mode 100644 index 67bbe3b..0000000 --- a/jscomp/build_tests/weird_names/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let a = 1 diff --git a/jscomp/build_tests/weird_names/src/utils.test.res b/jscomp/build_tests/weird_names/src/utils.test.res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names/src/utils.test.res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/weird_names_not_found_bug/input.js b/jscomp/build_tests/weird_names_not_found_bug/input.js deleted file mode 100644 index 1442695..0000000 --- a/jscomp/build_tests/weird_names_not_found_bug/input.js +++ /dev/null @@ -1,12 +0,0 @@ -var cp = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -var out = cp.spawnSync(rescript_exe, { encoding: "utf8" }); -if (out.stderr !== "") { - assert.fail(out.stderr); -} - -if (!out.stdout.includes(`The module or file Demo can't be found.`)) { - assert.fail(out.stdout); -} diff --git a/jscomp/build_tests/weird_names_not_found_bug/rescript.json b/jscomp/build_tests/weird_names_not_found_bug/rescript.json deleted file mode 100644 index 305524e..0000000 --- a/jscomp/build_tests/weird_names_not_found_bug/rescript.json +++ /dev/null @@ -1,8 +0,0 @@ -{ - "name": "weird_names", - "version": "0.1.0", - "sources": { - "dir": "src", - "subdirs": true - } -} diff --git a/jscomp/build_tests/weird_names_not_found_bug/src/demo.res b/jscomp/build_tests/weird_names_not_found_bug/src/demo.res deleted file mode 100644 index 67bbe3b..0000000 --- a/jscomp/build_tests/weird_names_not_found_bug/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let a = 1 diff --git a/jscomp/build_tests/weird_names_not_found_bug/src/demo.test.res b/jscomp/build_tests/weird_names_not_found_bug/src/demo.test.res deleted file mode 100644 index c311b2e..0000000 --- a/jscomp/build_tests/weird_names_not_found_bug/src/demo.test.res +++ /dev/null @@ -1,2 +0,0 @@ -module A = Demo -let a = 1 \ No newline at end of file diff --git a/jscomp/build_tests/x-y/input.js b/jscomp/build_tests/x-y/input.js deleted file mode 100644 index bb3fa84..0000000 --- a/jscomp/build_tests/x-y/input.js +++ /dev/null @@ -1,4 +0,0 @@ -var p = require("child_process"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; - -p.execSync(rescript_exe); diff --git a/jscomp/build_tests/x-y/rescript.json b/jscomp/build_tests/x-y/rescript.json deleted file mode 100644 index 104c36f..0000000 --- a/jscomp/build_tests/x-y/rescript.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "name": "x-y", - "version": "0.1.0", - "sources": ["x-src"] -} diff --git a/jscomp/build_tests/x-y/x-src/demo.res b/jscomp/build_tests/x-y/x-src/demo.res deleted file mode 100644 index 8d0b191..0000000 --- a/jscomp/build_tests/x-y/x-src/demo.res +++ /dev/null @@ -1 +0,0 @@ -let () = Js.log("Hello, ReScript") diff --git a/jscomp/build_tests/xpkg/input.js b/jscomp/build_tests/xpkg/input.js deleted file mode 100644 index 208a76a..0000000 --- a/jscomp/build_tests/xpkg/input.js +++ /dev/null @@ -1,12 +0,0 @@ -var p = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -try { - var output = p.spawnSync(`${rescript_exe} build -regen`, { - shell: true, - encoding: "utf8", - }); - - assert.ok(output.stderr.match(/reserved package name/)); -} finally { -} diff --git a/jscomp/build_tests/xpkg/rescript.json b/jscomp/build_tests/xpkg/rescript.json deleted file mode 100644 index 50b8ac6..0000000 --- a/jscomp/build_tests/xpkg/rescript.json +++ /dev/null @@ -1,4 +0,0 @@ -{ - "name": "_", - "sources": "." -} diff --git a/jscomp/build_tests/zerocycle/.gitignore b/jscomp/build_tests/zerocycle/.gitignore deleted file mode 100644 index 11ba296..0000000 --- a/jscomp/build_tests/zerocycle/.gitignore +++ /dev/null @@ -1 +0,0 @@ -*.bs.js \ No newline at end of file diff --git a/jscomp/build_tests/zerocycle/input.js b/jscomp/build_tests/zerocycle/input.js deleted file mode 100644 index cf8c0a2..0000000 --- a/jscomp/build_tests/zerocycle/input.js +++ /dev/null @@ -1,5 +0,0 @@ -var p = require("child_process"); -var assert = require("assert"); -var rescript_exe = require("../../../scripts/bin_path").rescript_exe; -var out = p.spawnSync(rescript_exe, { encoding: "utf8", cwd: __dirname }); -assert(out.status == 0); diff --git a/jscomp/build_tests/zerocycle/rescript.json b/jscomp/build_tests/zerocycle/rescript.json deleted file mode 100644 index 3cd7e90..0000000 --- a/jscomp/build_tests/zerocycle/rescript.json +++ /dev/null @@ -1,13 +0,0 @@ -{ - "name": "zerocycle", - "version": "0.1.0", - "sources": ["src"], - "package-specs": { - "module": "commonjs", - "in-source": true - }, - "suffix": ".bs.js", - "bs-dependencies": [ - // add your bs-dependencies here - ] -} diff --git a/jscomp/build_tests/zerocycle/src/bar.res b/jscomp/build_tests/zerocycle/src/bar.res deleted file mode 100644 index 1a8c37c..0000000 --- a/jscomp/build_tests/zerocycle/src/bar.res +++ /dev/null @@ -1,14 +0,0 @@ -// one-file false positive: https://github.com/rescript-lang/rescript-compiler/issues/5368 - -module Nested = { - module Bar = { - type t = private int - } -} - -open Nested - -module Bar = { - open Bar - let t : t = Obj.magic(42) -} \ No newline at end of file diff --git a/jscomp/build_tests/zerocycle/src/demo.res b/jscomp/build_tests/zerocycle/src/demo.res deleted file mode 100644 index 70d42c0..0000000 --- a/jscomp/build_tests/zerocycle/src/demo.res +++ /dev/null @@ -1 +0,0 @@ -module Foo = {} diff --git a/jscomp/build_tests/zerocycle/src/demo2.res b/jscomp/build_tests/zerocycle/src/demo2.res deleted file mode 100644 index dc74456..0000000 --- a/jscomp/build_tests/zerocycle/src/demo2.res +++ /dev/null @@ -1 +0,0 @@ -module Foo2 = {} \ No newline at end of file diff --git a/jscomp/build_tests/zerocycle/src/foo.res b/jscomp/build_tests/zerocycle/src/foo.res deleted file mode 100644 index 5449ab9..0000000 --- a/jscomp/build_tests/zerocycle/src/foo.res +++ /dev/null @@ -1,2 +0,0 @@ -open! Demo -include Foo diff --git a/jscomp/build_tests/zerocycle/src/foo2.res b/jscomp/build_tests/zerocycle/src/foo2.res deleted file mode 100644 index 24c75a3..0000000 --- a/jscomp/build_tests/zerocycle/src/foo2.res +++ /dev/null @@ -1,2 +0,0 @@ -open Demo2 -include Foo2 \ No newline at end of file diff --git a/jscomp/cmij/.ocamlformat b/jscomp/cmij/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/cmij/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/cmij/cmjdump_main.ml b/jscomp/cmij/cmjdump_main.ml deleted file mode 100644 index 49d7316..0000000 --- a/jscomp/cmij/cmjdump_main.ml +++ /dev/null @@ -1,71 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* start dumping *) - -let f fmt = Printf.fprintf stdout fmt - -let pp_cmj_case (case : Ext_js_file_kind.case) : unit = - f "%s\n" ("case : " ^ match case with Little -> "little" | Upper -> "upper") - -let pp_cmj - ({ values; pure; package_spec = npm_package_path; case } : Js_cmj_format.t) - = - f "package info: %s\n" - (Format.asprintf "%a" Js_packages_info.dump_packages_info npm_package_path); - pp_cmj_case case; - - f "effect: %s\n" (if pure then "pure" else "not pure"); - Ext_array.iter values (fun { name; arity; persistent_closed_lambda } -> - (match arity with - | Single arity -> ( - f "%s: %s\n" name (Format.asprintf "%a" Lam_arity.print arity); - match persistent_closed_lambda with - | None -> f "%s: not saved\n" name - | Some lam -> - f "%s: ======[start]\n" name; - f "%s\n" (Lam_print.lambda_to_string lam); - f "%s: ======[finish]\n" name) - | Submodule xs -> - (match persistent_closed_lambda with - | None -> f "%s: not saved\n" name - | Some lam -> - f "%s: ======[start]\n" name; - f "%s" (Lam_print.lambda_to_string lam); - f "%s: ======[finish]\n" name); - Array.iteri - (fun i arity -> - f "%s[%i] : %s \n" name i - (Format.asprintf "%a" Lam_arity.print arity)) - xs); - f "\n") - -let () = - match Sys.argv with - | [| _; file |] -> - let cmj, digest = Js_cmj_format.from_file_with_digest file in - Format.fprintf Format.std_formatter "@[Digest: %s@]@." - (Digest.to_hex digest); - pp_cmj cmj - | _ -> failwith "expect one argument" diff --git a/jscomp/cmij/cmjdump_main.mli b/jscomp/cmij/cmjdump_main.mli deleted file mode 100644 index 3999ce7..0000000 --- a/jscomp/cmij/cmjdump_main.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) diff --git a/jscomp/cmij/dune b/jscomp/cmij/dune deleted file mode 100644 index cb46d37..0000000 --- a/jscomp/cmij/dune +++ /dev/null @@ -1,11 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executables - (names cmjdump_main) - (public_names cmjdump) - (flags - (:standard -w -A)) - (libraries core)) diff --git a/jscomp/common/.ocamlformat b/jscomp/common/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/common/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/common/dune b/jscomp/common/dune deleted file mode 100644 index af510bf..0000000 --- a/jscomp/common/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name common) - (wrapped false) - (preprocess - (action - (run %{bin:cppo} %{env:CPPO_FLAGS=} %{input-file}))) - (flags - (:standard -w -A)) - (libraries syntax)) diff --git a/jscomp/common/ml_binary.ml b/jscomp/common/ml_binary.ml deleted file mode 100644 index 0d4d5cc..0000000 --- a/jscomp/common/ml_binary.ml +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind - -(** [read_ast kind ic] assume [ic] channel is - in the right position *) -let read_ast (type t) (kind : t kind) ic : t = - let magic = - match kind with - | Ml -> Config.ast_impl_magic_number - | Mli -> Config.ast_intf_magic_number - in - let buffer = really_input_string ic (String.length magic) in - assert (buffer = magic); - (* already checked by apply_rewriter *) - Location.set_input_name (input_value ic); - input_value ic - -let write_ast (type t) (kind : t kind) (fname : string) (pt : t) oc = - let magic = - match kind with - | Ml -> Config.ast_impl_magic_number - | Mli -> Config.ast_intf_magic_number - in - output_string oc magic; - output_value oc fname; - output_value oc pt - -let magic_of_kind : type a. a kind -> string = function - | Ml -> Config.ast_impl_magic_number - | Mli -> Config.ast_intf_magic_number diff --git a/jscomp/common/pattern_printer.ml b/jscomp/common/pattern_printer.ml deleted file mode 100644 index 8648f23..0000000 --- a/jscomp/common/pattern_printer.ml +++ /dev/null @@ -1,48 +0,0 @@ -open Types -open Typedtree -open Parsetree - -let mkpat desc = Ast_helper.Pat.mk desc - -let untype typed = - let rec loop pat = - match pat.pat_desc with - | Tpat_or (p1, { pat_desc = Tpat_or (p2, p3, rI) }, rO) -> - (* Turn A | (B | C) into (A | B) | C for pretty printing without parens *) - let newInner = { pat with pat_desc = Tpat_or (p1, p2, rI) } in - let newOuter = { pat with pat_desc = Tpat_or (newInner, p3, rO) } in - loop newOuter - | Tpat_or (pa, pb, _) -> mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_any | Tpat_var _ -> mkpat Ppat_any - | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c)) - | Tpat_alias (p, _, _) -> loop p - | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) - | Tpat_construct (cstr_lid, cstr, lst) -> - let lid = { cstr_lid with txt = Longident.Lident cstr.cstr_name } in - let arg = - match List.map loop lst with - | [] -> None - | [ p ] -> Some p - | lst -> Some (mkpat (Ppat_tuple lst)) - in - mkpat (Ppat_construct (lid, arg)) - | Tpat_variant (label, p_opt, _row_desc) -> - let arg = Option.map loop p_opt in - mkpat (Ppat_variant (label, arg)) - | Tpat_record (subpatterns, closed_flag) -> - let fields = - List.map - (fun (_, lbl, p) -> - (mknoloc (Longident.Lident lbl.lbl_name), loop p)) - subpatterns - in - mkpat (Ppat_record (fields, closed_flag)) - | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst)) - | Tpat_lazy p -> mkpat (Ppat_lazy (loop p)) - in - loop typed - -let print_pattern typed = - let pat = untype typed in - let doc = Res_printer.printPattern pat Res_comments_table.empty in - Res_doc.toString ~width:80 doc diff --git a/jscomp/core/.ocamlformat b/jscomp/core/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/core/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/core/FIXME.adoc b/jscomp/core/FIXME.adoc deleted file mode 100644 index ce60151..0000000 --- a/jscomp/core/FIXME.adoc +++ /dev/null @@ -1,79 +0,0 @@ - - -# alias table is not reliable - -mario_game.03flattern.lam - -[source] ------------------ - with (304 t1/1824 s1/1825 o1/1826 t2/1827 o2/1829) - (let (match/2332 =a t1/1824 match/2333 =a t2/1827) - (catch - (catch - (catch - (catch (if (>= match/2332 3) (exit 291) (exit 290)) - with (291) - (if (isint match/2333) - (if (!=[int] match/2333 1) (exit 290) (exit 288)) - (let (typ/2330 =a (field 0 match/2333)) - (exit 289 typ/2330)))) - with (290) - (seq - (apply (field 17 Object/1601) o1/1826 t1/1824 - s1/1825) - [0: 0a 0a])) - with (288) - (seq (apply (field 16 Object/1601) o2/1829) - (apply (field 18 Object/1601) o1/1826) [0: 0a 0a])) - with (289 typ/1867) - (let - (updated_block/1869 = - (apply (field 15 Object/1601) o2/1829 context/1786) - spawned_item/1870 = - (apply (field 20 Object/1601) (field 6 o1/1826) - o2/1829 typ/1867 context/1786)) - (seq - (apply (field 17 Object/1601) o1/1826 t1/1824 - s1/1825) - (makeblock 0 (makeblock 0 updated_block/1869) - (makeblock 0 spawned_item/1870))))))) ------------------ - -Here [match/2332] is aliased [t/1824] - -mario_game.04.simplify_exits.lam - -[source] ------------------- - (if (>= match/2379 2) - (let - (t1/2571 =a t1/1817 - s1/2572 =a s1/1818 - o1/2573 =a o1/1819 - t2/2574 =a t2/2349 - o2/2575 =a o2/2350 - match/2332 =a t1/2571 - match/2333 =a t2/2574) - (catch - (if (>= match/2332 3) - (if (isint match/2333) - (if (!=[int] match/2333 1) (exit 290) - (seq - (apply (field 16 Object/1601) - o2/2575) - (apply (field 18 Object/1601) - o1/2573) - [0: 0a 0a])) - (let - ------------------- - -Here [match/2332] is aliased [t/1824] - -Here the exit code is inlined, [t/1824] is renamed into [t1/2571] -(function inlining and renaming), [match/2332] now should be aliased -to [t1/2571], but since the alias table is not updated, it still point -to the old one which result in wrong optimizations. - -The reaon is that when we do the inlining we refresh the parameters, -but forgot update the alias table, so the aliases are stale diff --git a/jscomp/core/bs_cmi_load.ml b/jscomp/core/bs_cmi_load.ml deleted file mode 100644 index 72a5f28..0000000 --- a/jscomp/core/bs_cmi_load.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let load_cmi ~unit_name : Env.Persistent_signature.t option = - match Config_util.find_opt (unit_name ^".cmi") with - | Some filename -> Some {filename; cmi = Cmi_format.read_cmi filename} - | None -> None \ No newline at end of file diff --git a/jscomp/core/bs_conditional_initial.ml b/jscomp/core/bs_conditional_initial.ml deleted file mode 100644 index 52010a4..0000000 --- a/jscomp/core/bs_conditional_initial.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Clflags.keep_docs := false; *) -(* default to false -check later*) -(* Clflags.keep_locs := false; *) -let setup_env () = - Env.Persistent_signature.load := Bs_cmi_load.load_cmi; - Matching.make_test_sequence_variant_constant := Polyvar_pattern_match.make_test_sequence_variant_constant; - Matching.call_switcher_variant_constant := Polyvar_pattern_match.call_switcher_variant_constant; - Matching.call_switcher_variant_constr := Polyvar_pattern_match.call_switcher_variant_constr; - Ctype.variant_is_subtype := Matching_polyfill.variant_is_subtype; - Clflags.dump_location := false; - Config.syntax_kind := `rescript; - Parmatch.print_res_pat := Pattern_printer.print_pattern; - (* default true - otherwise [bsc -I sc src/hello.ml ] will include current directory to search path - *) - Clflags.debug := true; - Clflags.binary_annotations := true; - (* Turn on [-no-alias-deps] by default -- double check *) - Oprint.out_ident := Outcome_printer_ns.out_ident; - Builtin_attributes.check_bs_attributes_inclusion := Record_attributes_check.check_bs_attributes_inclusion; - Builtin_attributes.check_duplicated_labels := - Record_attributes_check.check_duplicated_labels; - Matching.names_from_construct_pattern := - Matching_polyfill.names_from_construct_pattern; - - Rescript_cpp.replace_directive_bool "BS" true; - Rescript_cpp.replace_directive_bool "JS" true; - Printtyp.print_res_poly_identifier := Res_printer.polyVarIdentToString; - Rescript_cpp.replace_directive_string "BS_VERSION" Bs_version.version - (*; Switch.cut := 100*) (* tweakable but not very useful *) - - -let () = - at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ()) diff --git a/jscomp/core/bs_conditional_initial.mli b/jscomp/core/bs_conditional_initial.mli deleted file mode 100644 index c0f8400..0000000 --- a/jscomp/core/bs_conditional_initial.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** This function set up built in compile time variables used in - conditional compilation so that - {[ - #if BS - #elif .. - #end - ]} - Is understood, also make sure the playground do the same initialization. -*) -val setup_env : unit -> unit - diff --git a/jscomp/core/cmd_ast_exception.ml b/jscomp/core/cmd_ast_exception.ml deleted file mode 100644 index 28b63d0..0000000 --- a/jscomp/core/cmd_ast_exception.ml +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2015 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error = CannotRun of string | WrongMagic of string - -exception Error of error - -let report_error ppf = function - | CannotRun cmd -> - Format.fprintf ppf - "Error while running external preprocessor@.Command line: %s@." cmd - | WrongMagic cmd -> - Format.fprintf ppf - "External preprocessor does not produce a valid file@.Command line: \ - %s@." - cmd - -let () = - Location.register_error_of_exn (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None) - -let cannot_run comm = raise (Error (CannotRun comm)) - -let wrong_magic magic = raise (Error (WrongMagic magic)) diff --git a/jscomp/core/cmd_ppx_apply.ml b/jscomp/core/cmd_ppx_apply.ml deleted file mode 100644 index 3729a4d..0000000 --- a/jscomp/core/cmd_ppx_apply.ml +++ /dev/null @@ -1,112 +0,0 @@ -(* Copyright (C) 2015 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Note: some of the functions here should go to Ast_mapper instead, - which would encapsulate the "binary AST" protocol. *) - -let write_ast (type a) (kind : a Ml_binary.kind) fn (ast : a) = - let oc = open_out_bin fn in - output_string oc (Ml_binary.magic_of_kind kind); - output_value oc (!Location.input_name : string); - output_value oc (ast : a); - close_out oc - -let temp_ppx_file () = - Filename.temp_file "ppx" (Filename.basename !Location.input_name) - -let apply_rewriter kind fn_in ppx = - let magic = Ml_binary.magic_of_kind kind in - let fn_out = temp_ppx_file () in - let comm = - Printf.sprintf "%s %s %s" ppx (Filename.quote fn_in) (Filename.quote fn_out) - in - let ok = Ccomp.command comm = 0 in - if not ok then Cmd_ast_exception.cannot_run comm; - if not (Sys.file_exists fn_out) then Cmd_ast_exception.cannot_run comm; - (* check magic before passing to the next ppx *) - let ic = open_in_bin fn_out in - let buffer = - try really_input_string ic (String.length magic) with End_of_file -> "" - in - close_in ic; - if buffer <> magic then Cmd_ast_exception.wrong_magic buffer; - fn_out - -(* This is a fatal error, no need to protect it *) -let read_ast (type a) (kind : a Ml_binary.kind) fn : a = - let ic = open_in_bin fn in - let magic = Ml_binary.magic_of_kind kind in - let buffer = really_input_string ic (String.length magic) in - assert (buffer = magic); - (* already checked by apply_rewriter *) - Location.set_input_name @@ (input_value ic : string); - let ast = (input_value ic : a) in - close_in ic; - - ast - -(** [ppxs] are a stack, - [-ppx1 -ppx2 -ppx3] - are stored as [-ppx3; -ppx2; -ppx1] - [fold_right] happens to process the first one *) -let rewrite kind ppxs ast = - let fn_in = temp_ppx_file () in - write_ast kind fn_in ast; - let temp_files = - List.fold_right - (fun ppx fns -> - match fns with - | [] -> assert false - | fn_in :: _ -> apply_rewriter kind fn_in ppx :: fns) - ppxs [ fn_in ] - in - match temp_files with - | last_fn :: _ -> - let out = read_ast kind last_fn in - Ext_list.iter temp_files Misc.remove_file; - out - | _ -> assert false - -let apply_rewriters_str ?(restore = true) ~tool_name ast = - match !Clflags.all_ppx with - | [] -> ast - | ppxs -> - ast - |> Ast_mapper.add_ppx_context_str ~tool_name - |> rewrite Ml ppxs - |> Ast_mapper.drop_ppx_context_str ~restore - -let apply_rewriters_sig ?(restore = true) ~tool_name ast = - match !Clflags.all_ppx with - | [] -> ast - | ppxs -> - ast - |> Ast_mapper.add_ppx_context_sig ~tool_name - |> rewrite Mli ppxs - |> Ast_mapper.drop_ppx_context_sig ~restore - -let apply_rewriters ?restore ~tool_name (type a) (kind : a Ml_binary.kind) - (ast : a) : a = - match kind with - | Ml_binary.Ml -> apply_rewriters_str ?restore ~tool_name ast - | Ml_binary.Mli -> apply_rewriters_sig ?restore ~tool_name ast diff --git a/jscomp/core/config_util.ml b/jscomp/core/config_util.ml deleted file mode 100644 index f65dee5..0000000 --- a/jscomp/core/config_util.ml +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let find_in_path_uncap path name = - let uname = Ext_string.uncapitalize_ascii name in - let rec try_dir = function - | [] -> None - | dir :: rem -> - let ufullname = Filename.concat dir uname in - if Sys.file_exists ufullname then Some ufullname - else - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then Some fullname else try_dir rem - in - try_dir path - -(* ATTENTION: lazy to wait [Config.load_path] populated *) -let find_opt file = find_in_path_uncap !Config.load_path file - -let output_prefix name = - match !Clflags.output_name with - | None -> - Ext_namespace_encode.make - (Filename.remove_extension name) - ?ns:!Clflags.dont_record_crc_unit - | Some oname -> Filename.remove_extension oname diff --git a/jscomp/core/config_util.mli b/jscomp/core/config_util.mli deleted file mode 100644 index f5623ae..0000000 --- a/jscomp/core/config_util.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A simple wrapper around [Config] module in compiler-libs, so that the search path - is the same -*) - -val find_opt : string -> string option -(** [find filename] Input is a file name, output is absolute path *) - -val output_prefix : string -> string -(** given the input, calculate the output prefix - - in: src/hello.ast - out: src/hello - - with namespace: - in: src/hello.ast - out: src/hello-Ns -*) diff --git a/jscomp/core/design.md b/jscomp/core/design.md deleted file mode 100644 index 0edd6a3..0000000 --- a/jscomp/core/design.md +++ /dev/null @@ -1,477 +0,0 @@ - -# Ideas aobut boolean support -## The cases when boolean representation is not transparent - -- printing - -```ocaml -Js.log true -``` - -- pattern match - -```ocaml -let f x y = - match x,y with - | true, false -> 0 -``` - -- comparison - -```ocaml -if v = true then -``` - -## Where JS boolean could be introduced - -JS operatons which could generate JS booleans -- `not` -- Equality comparison - -# `and`, `or` is fine -In JS, `and`, `or` is untyped, but it is a superset of OCaml semantics: - - -```js -x && y -/* equivalent to */ -x ? x : y -``` - - - -There is no coersion so `1&&0`, `1&&1`, `0&&1`, `0&&0` are all the same as JS version. -Same for `or` - -but `not` is not the same as `!`, `!` will do the conversion to enforce its result is JS boolean - -**ATT** if you want to support JS boolean better, think twice, it is -really hard to give two booleans first class support, and such bugs -are very hard to find (since in most cases they behave the same), so -what we can do is produce OCaml bool exclusively, only pass JS boolean -to JS ffi which requires it exclusively (very rare) -**NOTE** since OCaml boolean is everywhere, while JS boolean only happens in the FFI, we should by default produce OCaml boolean in the IR, and mark JS boolean explicitly instead. - -## It does not affect `if_then_else` compilation - -since JS if is more capable, there is no need do any coercion - - -# Arity handling - -The runtime support is in `Curry` module, we have several functions - -## `Curry.app` - -```ocaml -Curry.app f args -(** [f] is an curried function, [args] are supplied arguments - if matches then like normal function apply. - if over-supply, take the first [arity] arguments, - fully apply and continue [app f' rest] - if under-supply, - create a closure, wait until all arguments ready. - [Note, we don't necessary - need a closure here, we can have some - data structures like bytecode] - *) -``` - -```ocaml - -Curry.curry_N o a1 a2 .. arity -(** used by [Curry._N] *) - -Curry._N o a1 a2 .. aN -(** - A fast version of [app f [|a1; a2; ..; aN |]]. - Check the arity of [o]if it hits, just do the application -*) - -Curry.__N o -(** - Make sure the output of [o] is arity [N]. - This is used to convert a curried function [o] into - uncurried. for example - {[ - fun [@bs] x y -> f x y - ]} - Another use case: - {[ - external f : ('a -> 'b [@bs.uncurry]) -> unit - - f g (* The compiler will do such converison internally*) - ]} - Guess the arity of [o], if it hit, then return [o] - - Note when we want to target arity 0, in the first case - {[ - fun [@bs] () -> f () - ]} will be compiled as - {{ - fun () -> f (0) - }} - SO [Curry.__0] will not be triggered - - We also have - some special logic to when converted to arity 0 - in external settings -*) - -``` - -# Toplevel module exports - -Global exports identifiers are extracted from `Translmod.get_export_identifiers` -instead of inferred from lambda expression or cmi file. - -- We need be careful about externals. -- Reading from fresh generated cmi is expensive. - -# Variable usage - -Lalias-bound variables are never assigned, so it can only -appear in `Lvar`, then it is easy to eliminate it - - -# interaction between `bs.splice` and `|>` - -Note in general, it is fine whether we do beta reduction or not, it is just optimization. - -However, since we introduced `bs.splice` which does require the `spliced argument` to be captured - -```ocaml -spliced_external a0 a1 [|b0;b1|] -``` - -There are two cases where get things complicated, people don't think `|>` is a function - -```ocaml -x |> spliced_external a0 a1 [|b0;b1|] -``` -Even though `|>` is a function, and `spliced_external` is escaped here, but people would -expect it is equivalent to - -```ocaml -spliced_external a0 a1 [|b0;b1|] x -``` - -So our optimizer needs to handle this case to make sure `spliced_external` not escaped, -also becaues the interaction of `[@bs.splice]` and `[@bs.send]`, the spliced argument -is no longer in tail position, so that people can write such code - -```ocaml -spliced_external a0 a1 [|b0;b1|] -``` -Internally in lambda layer it would be - -```ocaml -(fun c0 c1 c2 c3-> spliced_external c0 c1 c2 c3) a0 a1 [|b0;b1|] -``` - -We can simply do inlining, it may have side efffect in `b0`, `b1`, our optimizer also need handle such case. - -Maybe in the future, we should lift the restriction about `bs.splice` (delegate to `slow` mode when we can not resolve it statically, my personal expereince is that people will complain about why it fails to compile more than why it is slow in some corner cases) - -Note this also interacts with `[@bs.uncurry]` - -for example - -```ocaml -external filter : 'a array -> ('a -> bool [@bs.uncurry]) -> 'a array = "filter" -[@@bs.send] - -let f xs = - xs |. filter (fun x -> x > 2) -``` - -Here whether the callback gets inlined to the call of `filter` will have an effect on how `Pjs_fn_make` gets cancelled. - -Note when we pattern match over the original lamba,`Levent` needs to be removed as early as possible. Due to the existence of `Levent`, we can not pattern match over nested original raw lambda. - -We turned off event generation temporarily - -# safe way to test undefined - -Note such logic is already wrong: - -```js -var x = undefined_value // thrown here -if (typeof x === "undefined"){ - ... -} -``` - - -# `#` primitive handling - -1. Some primitives introduced are for performance reasons, for example: - -`#String.fromCharCode` which is essentialy the same as - -```ocaml -external of_char : char -> string = "String.fromCharCode" -[@@bs.val] -``` - -We introduced `#` so that we can do some optimizations. - -2. Some of them are not expressible in OCaml FFI, for example -'#is_instance_array', -'#gt' - -3. Some of them require a runtime polyfill support - - -# runtime - -## anything to string -http://www.2ality.com/2012/03/converting-to-string.html -Note that `""+ Symbol()` does not work any more, we should favor `String` instead - - -# Name mangling - -## let bound identifier mangling - -### keyword -Note there are two issues, if it is keyword, the output may not be parsable if we don't do name mangling - - -```js -> var case = 3 -< SyntaxError: Cannot use the keyword 'case' as a variable name. -``` -### global variable -If it is global variable, it is parsable, it may trigger even subtle errors: - -```js -(function(){ 'use strict'; var document = 3; console.log(document)})() -VM1146:1 3 -3 -``` -This could be _problematic_ for bindings -```ocaml -let process = 3 -Process.env##OCAML -``` -In general global variables would be problematic for bindings - -## property name mangling - -Nowadays, JS engine support keywords as property name very well - -```js -var f = { true : true, false : false } -``` - -But it has problems when it is too simple for parsing -```js -var f = { true, false} // parsign rules ambiguity -``` - -If we don't do ES6, we should not go with name mangling, however, it is mostly due to we can -not express these keywords, such as `_open` as property in OCaml, so we did the name mangling - -# Curry/Tuple: two kinds of function - -OCaml indeed support two kind calling convention. - -```ocaml -(Lfunction (Tupled(a0,a1,a2))) [a0,a1,a2] -``` - -and - -```ocaml -(Lfunction Curried (a0,a1,a2)) a0 a1 a2 -``` - - -They also affect how beta reduction works, - -```ocaml -| Lapply(Lfunction(Curried, params, body), args, _) - when optimize && List.length params = List.length args -> - count bv (beta_reduce params body args) -| Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args,_)], _) - when optimize && List.length params = List.length args -> - count bv (beta_reduce params body args) -``` - -It is generated by the backend via an argument -`untuplify_fn` in `transl_function`. -Note if we want to take advantage of it in the future we need -translate ` f x` into (when `f` is `fun (a0,a1) -> a0 + a1 ` - -```ocaml -f (x[0],x[1]) -``` - -currently it is turned on only in native mode - -```ocaml -and transl_function loc untuplify_fn .. -``` - -two call sites - -```ocaml -transl_function exp.exp_loc false ... -transl_function e.exp_loc !Clflags.native_code ... -``` - -# JS exception wrap and unwrap - -### Pack and Unpack OCaml exceptions - -http://eli.thegreenplace.net/2013/10/22/classical-inheritance-in-javascript-es5 - -http://stackoverflow.com/questions/1382107/whats-a-good-way-to-extend-error-in-javascript - - -https://caml.inria.fr/mantis/print_bug_page.php?bug_id=7375 - -http://stackoverflow.com/questions/3734236/how-can-i-rethrow-an-exception-in-javascript-but-preserve-the-stack -```js -class OCamlError extends Error{ - constructor(payload){ - super("OCamlError") - this.payload = payload - } -} -``` - -We can see the output from typescript to get a sense of what it will be transpiled into. - -This works reasonably well (tested on Safari and Chrome) - -```js -function OCamlError(camlExnData){ - var self = Error.call(this, "OCamlError") - self.camlExnData = camlExnData - return self -} -``` - -```js -function unpackError(exn){ - if(exn.camlExnData !== undefined){ - return exn.camlExnData - } else { - return exn - } -} -``` -```js -function packError(exn){ - if (Obj.tag(exn) === 248){ - return new OCamlError(exn) - } else { - return exn - } -} -``` -So whenever we raise an OCaml exception, we always wrapped it as a JS error. -Now we unpack it, it could be OCaml exception or JS exception, so we did -a runtime dispatch. - -Some potential optimization - -```ocaml -try f x with -Not_found -> .. -JsError e -``` - -currently it would be transalted as - -```js -try { - f(x) - } -catch(e){ - var e = unpackError(e) - if (e === "Not_found"){ - ... - } else { - throw packError(e) // re-raise - } -} -``` - -need check `Praise of raise_kind` - -*Conclusion*: it is very hard to get it right when changig ocaml exception representation and js exception representation at the same time in the combination of *re-raiase* - - -# Several module components can have the same name #978 - -Note: ReScript compiler complains if exports have the same component name, this keeps its soundness. - -A funny thing is that open variants does not have record disambiguion so that for: - -```ocaml -type a = .. -type b = .. -type a += A -type b += A -``` - -The compiler will only expose the last `A`, which means, ReScript will not complain, the limitation -of the compiler preserves its soundness - -# Print import module names - -for `create_js_module`, we first create a mapping to make it a proper -module name, (also cached in a hashtbl). Note it is not a Js id, which -fails `Ext_ident.is_js` - -# compilation - -# static catches - -# Comparison semantics - -Cases when commparison are specialized (Note we need make sure the specialized version -is consistent with the generalized version): - -- caml_int_max/min -- caml_bool_max/min -- caml_float_max/min -- caml_string_max/min -- caml_nativeint_max/min -- caml_int32_max/min -- caml_int64_max/min - -- int_equal[null/undefined/nullable] [not] -- bool_equal[null/undefined/nullable] [not] -- float_equal[null/undefined/nullable] [not] -- string_equal[null/undefined/nullable] [not] -- nativeintequal[_null/unefined/nullable] [not] -- int32_equal[_null/undefined/nullable] [not] -- int64_equal[_null/undefined/nullable] [not] - -- int_lessthan[greaterthan] [lessequal] [greaterequal] -- bool_lessthan[greaterthan] [lessequal] [greaterequal] -- float_lessthan[greaterthan] [lessequal] [greaterequal] -- string_lessthan[greaterthan] [lessequal] [greaterequal] -- nativeint_lessthan[greaterthan] [lessequal] [greaterequal] -- int32_lessthan[greaterthan] [lessequal] [greaterequal] -- int64_lessthan[greaterthan] [lessequal] [greaterequal] - -- int_compare -- bool_compare -- float_compare -- string_compare -- nativeint_compare -- int32_comapre -- int64_compare - -So far we haven't specialized option comparison, but we need be careful when -we do the optimizer, e.g, `Js_exp_make.int_comp`, we need make sure the peepwhole is consistent - - - - - diff --git a/jscomp/core/destruct_exn.md b/jscomp/core/destruct_exn.md deleted file mode 100644 index 81e6667..0000000 --- a/jscomp/core/destruct_exn.md +++ /dev/null @@ -1,81 +0,0 @@ - - - -Its essential is - -```ocaml -external destruct : 'b -> (exn -> 'a) -``` - -However it does not prevent things like - -```ocaml -destruct v begin fun exn -> - Js.log exn ; - match exn with - | .. - | .. -``` - -Here it forces us to answer whether `v` is exception or not, - -while such syntax below does not need us answer `v` is exception -or not, it just asks us to answer it matches a branch of exception or not which can be done in a sound way. - -```ocaml -match%exn v with -| .. -| .. -``` - -However, we need make sure such cases not happen - -```ocaml -match%exn v with -| e -> ... - -``` -Or any vagous pattern which needs us to answer if -it is an exception or not - - -Another proposal is -```ocaml -match%exn computation with -| A .. -| B .. -| Js.NonCamlOpenVariant .. -| v -> .. -``` - -Here we pack the data `v` - -==> -``` - -match (Js_enx.internalTOOCamlException compuation) with -| A .. -| B -| exception .. ) -``` - -The same problem is - -``` -match (Js_enx.internalTOOCamlException compuation) with -| _ -> .. -``` - -What will happen if JS side `raises` an OCaml extensible variant, -we view it as OCaml exception.. -It is slightly differnt in OCaml, since it always start from `catch(id)..` -where `id` is defined by the compiler - -Another very similar proposal would be - -```ocaml -fun[@bs:exn] e -> - match e with - | Js.Exn.Error .. - | .. -``` \ No newline at end of file diff --git a/jscomp/core/dune b/jscomp/core/dune deleted file mode 100644 index 49d0d77..0000000 --- a/jscomp/core/dune +++ /dev/null @@ -1,9 +0,0 @@ -(library - (name core) - (wrapped false) - (preprocess - (action - (run %{bin:cppo} %{env:CPPO_FLAGS=} %{input-file}))) - (flags - (:standard -w -A)) - (libraries depends ext frontend gentype js_parser)) diff --git a/jscomp/core/j.ml b/jscomp/core/j.ml deleted file mode 100644 index acbdc06..0000000 --- a/jscomp/core/j.ml +++ /dev/null @@ -1,334 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Javascript IR - - It's a subset of Javascript AST specialized for OCaml lambda backend - - Note it's not exactly the same as Javascript, the AST itself follows lexical - convention and [Block] is just a sequence of statements, which means it does - not introduce new scope -*) - -type mutable_flag = Js_op.mutable_flag -type binop = Js_op.binop -type int_op = Js_op.int_op -type kind = Js_op.kind -type property = Js_op.property -type number = Js_op.number -type ident_info = Js_op.ident_info -type exports = Js_op.exports -type tag_info = Js_op.tag_info -type property_name = Js_op.property_name - -type label = string -and ident = Ident.t -(* we override `method ident` *) - -(** object literal, if key is ident, in this case, it might be renamed by - Google Closure optimizer, - currently we always use quote -*) - -and module_id = { id : ident; kind : Js_op.kind ; dynamic_import : bool } - -and required_modules = module_id list -and vident = Id of ident | Qualified of module_id * string option -(* Since camldot is only available for toplevel module accessors, - we don't need print `A.length$2` - just print `A.length` - it's guarateed to be unique - - when the third one is None, it means the whole module - - TODO: - invariant, when [kind] is [Runtime], then we can ignore [ident], - since all [runtime] functions are unique, when do the - pattern match we can ignore the first one for simplicity - for example - {[ - Qualified (_, Runtime, Some "caml_int_compare") - ]} -*) - -and exception_ident = ident -and for_ident = ident -and for_direction = Js_op.direction_flag -and property_map = (property_name * expression) list -and length_object = Js_op.length_object -and delim = External_arg_spec.delim = | DNone | DStarJ | DNoQuotes - -and expression_desc = - | Length of expression * length_object - | Is_null_or_undefined of expression (** where we use a trick [== null ] *) - | String_append of expression * expression - | Bool of bool (* js true/false*) - (* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence - [typeof] is an operator - *) - | Typeof of expression - | Js_not of expression (* !v *) - (* TODO: Add some primitives so that [js inliner] can do a better job *) - | Seq of expression * expression - | Cond of expression * expression * expression - | Bin of binop * expression * expression - (* [int_op] will guarantee return [int32] bits - https://developer.mozilla.org/en/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators *) - (* | Int32_bin of int_op * expression * expression *) - | FlatCall of expression * expression - (* f.apply(null,args) -- Fully applied guaranteed - TODO: once we know args's shape -- - if it's know at compile time, we can turn it into - f(args[0], args[1], ... ) - *) - | Call of expression * expression list * Js_call_info.t - (* Analysze over J expression is hard since, - some primitive call is translated - into a plain call, it's better to keep them - *) - | String_index of expression * expression - (* str.[i])*) - | Array_index of expression * expression - (* arr.(i) - Invariant: - The second argument has to be type of [int], - This can be constructed either in a static way [E.array_index_by_int] or a dynamic way - [E.array_index] - *) - | Tagged_template of expression * expression list * expression list - | Static_index of expression * string * int32 option - (* The third argument bool indicates whether we should - print it as - a["idd"] -- false - or - a.idd -- true - There are several kinds of properties - 1. OCaml module dot (need to be escaped or not) - All exported declarations have to be OCaml identifiers - 2. Javascript dot (need to be preserved/or using quote) - *) - | New of expression * expression list option (* TODO: option remove *) - | Var of vident - | Fun of { - is_method : bool; - params : ident list; - body : block; - env : Js_fun_env.t; - return_unit : bool; - async : bool; - } - | Str of { delim : delim; txt : string } - (* A string is UTF-8 encoded, and may contain - escape sequences. - *) - | Raw_js_code of Js_raw_info.t - (* literally raw JS code - *) - | Array of expression list * mutable_flag - | Optional_block of expression * bool - (* [true] means [identity] *) - | Caml_block of expression list * mutable_flag * expression * tag_info - (* The third argument is [tag] , forth is [tag_info] *) - (* | Caml_uninitialized_obj of expression * expression *) - (* [tag] and [size] tailed for [Obj.new_block] *) - - | Caml_block_tag of expression * string (* e.tag *) - (* | Caml_block_set_length of expression * expression *) - (* It will just fetch tag, to make it safe, when creating it, - we need apply "|0", we don't do it in the - last step since "|0" can potentially be optimized - *) - | Number of number - | Object of property_map - | Undefined of {isUnit: bool} - | Null - | Await of expression - -and for_ident_expression = expression -(* pure*) - -and finish_ident_expression = expression - -(* pure *) -(* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Statements/block - block can be nested, specified in ES3 -*) - -(* Delay some units like [primitive] into JS layer , - benefit: better cross module inlining, and smaller IR size? -*) - -(* - [closure] captured loop mutable values in the outer loop - - check if it contains loop mutable values, happens in nested loop - when closured, it's no longer loop mutable value. - which means the outer loop mutable value can not peek into the inner loop - {[ - var i = f (); - for(var finish = 32; i < finish; ++i){ - } - ]} - when [for_ident_expression] is [None], [var i] has to - be initialized outside, so - - {[ - var i = f () - (function (xxx){ - for(var finish = 32; i < finish; ++i) - }(..i)) - ]} - This happens rare it's okay - - this is because [i] has to be initialized outside, if [j] - contains a block side effect - TODO: create such example -*) - -(* Since in OCaml, - - [for i = 0 to k end do done ] - k is only evaluated once , to encode this invariant in JS IR, - make sure [ident] is defined in the first b - - TODO: currently we guarantee that [bound] was only - excecuted once, should encode this in AST level -*) - -(* Can be simplified to keep the semantics of OCaml - For (var i, e, ...){ - let j = ... - } - - if [i] or [j] is captured inside closure - - for (var i , e, ...){ - (function (){ - })(i) - } -*) - -(* Single return is good for ininling.. - However, when you do tail-call optmization - you loose the expression oriented semantics - Block is useful for implementing goto - {[ - xx:{ - break xx; - } - ]} -*) -and case_clause = { - switch_body : block; - should_break : bool; - (* true means break *) - comment : string option; -} - -and string_clause = Ast_untagged_variants.tag_type * case_clause -and int_clause = int * case_clause - -and statement_desc = - | Block of block - | Variable of variable_declaration - (* Function declaration and Variable declaration *) - | Exp of expression - | If of expression * block * block - | While of label option * expression * block * Js_closure.t - (* check if it contains loop mutable values, happens in nested loop *) - | ForRange of - for_ident_expression option - * finish_ident_expression - * for_ident - * for_direction - * block - * Js_closure.t - | Continue of label - | Break (* only used when inline a fucntion *) - | Return of expression - (* Here we need track back a bit ?, move Return to Function ... - Then we can only have one Return, which is not good *) - (* since in ocaml, it's expression oriented langauge, [return] in - general has no jumps, it only happens when we do - tailcall conversion, in that case there is a jump. - However, currently a single [break] is good to cover - our compilation strategy - Attention: we should not insert [break] arbitrarily, otherwise - it would break the semantics - A more robust signature would be - {[ goto : label option ; ]} - *) - | Int_switch of expression * int_clause list * block option - | String_switch of expression * string_clause list * block option - | Throw of expression - | Try of block * (exception_ident * block) option * block option - | Debugger - -and expression = { expression_desc : expression_desc; comment : string option } -and statement = { statement_desc : statement_desc; comment : string option } - -and variable_declaration = { - ident : ident; - value : expression option; - property : property; - ident_info : ident_info; -} - -(* TODO: For efficency: block should not be a list, it should be able to - be concatenated in both ways -*) -and block = statement list -and program = { block : block; exports : exports; export_set : Set_ident.t } - -and deps_program = { - program : program; - modules : required_modules; - side_effect : string option; (* None: no, Some reason *) -} -[@@deriving - { - excludes = - [| - deps_program; - int_clause; - string_clause; - for_direction; - (* exception_ident; *) - for_direction; - expression_desc; - statement_desc; - for_ident_expression; - label; - finish_ident_expression; - property_map; - length_object; - (* for_ident; *) - required_modules; - case_clause; - |]; - }] -(* -FIXME: customize for each code generator -for each code generator, we can provide a white-list -so that we can achieve the optimal -*) diff --git a/jscomp/core/js_analyzer.ml b/jscomp/core/js_analyzer.ml deleted file mode 100644 index 2ca6443..0000000 --- a/jscomp/core/js_analyzer.ml +++ /dev/null @@ -1,278 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type idents_stats = { - mutable used_idents : Set_ident.t; - mutable defined_idents : Set_ident.t; -} - -let add_defined_idents (x : idents_stats) ident = - x.defined_idents <- Set_ident.add x.defined_idents ident - -(* Assume that functions already calculated closure correctly - Maybe in the future, we should add a dirty flag, to mark the calcuated - closure is correct or not - - Note such shaking is done in the toplevel, so that it requires us to - flatten the statement first -*) -let super = Js_record_iter.super - -let free_variables (stats : idents_stats) = - { - super with - variable_declaration = - (fun self st -> - add_defined_idents stats st.ident; - match st.value with None -> () | Some v -> self.expression self v); - ident = - (fun _ id -> - if not (Set_ident.mem stats.defined_idents id) then - stats.used_idents <- Set_ident.add stats.used_idents id); - expression = - (fun self exp -> - match exp.expression_desc with - | Fun {env} - (* a optimization to avoid walking into function again - if it's already comuted - *) -> - stats.used_idents <- - Set_ident.union (Js_fun_env.get_unbounded env) stats.used_idents - | _ -> super.expression self exp); - } - -let init = { used_idents = Set_ident.empty; defined_idents = Set_ident.empty } - -let obj = free_variables init - -let clean_up init = - init.used_idents <- Set_ident.empty; - init.defined_idents <- Set_ident.empty - -let free_variables_of_statement st = - clean_up init; - obj.statement obj st; - Set_ident.diff init.used_idents init.defined_idents - -let free_variables_of_expression st = - clean_up init; - obj.expression obj st; - Set_ident.diff init.used_idents init.defined_idents - -let rec no_side_effect_expression_desc (x : J.expression_desc) = - match x with - | Undefined _ | Null | Bool _ | Var _ -> true - | Fun _ -> true - | Number _ -> true (* Can be refined later *) - | Static_index (obj, (_name : string), (_pos : int32 option)) -> - no_side_effect obj - | String_index (a, b) | Array_index (a, b) -> - no_side_effect a && no_side_effect b - | Is_null_or_undefined b -> no_side_effect b - | Str _ -> true - | Array (xs, _mutable_flag) | Caml_block (xs, _mutable_flag, _, _) -> - (* create [immutable] block, - does not really mean that this opreation itself is [pure]. - - the block is mutable does not mean this operation is non-pure - *) - Ext_list.for_all xs no_side_effect - | Optional_block (x, _) -> no_side_effect x - | Object kvs -> Ext_list.for_all_snd kvs no_side_effect - | String_append (a, b) | Seq (a, b) -> no_side_effect a && no_side_effect b - | Length (e, _) | Caml_block_tag (e, _) | Typeof e -> no_side_effect e - | Bin (op, a, b) -> op <> Eq && no_side_effect a && no_side_effect b - | Tagged_template (call_expr, strings, values) -> no_side_effect call_expr && - Ext_list.for_all strings no_side_effect && Ext_list.for_all values no_side_effect - | Js_not _ | Cond _ | FlatCall _ | Call _ | New _ | Raw_js_code _ - (* actually true? *) -> - false - | Await _ -> false - -and no_side_effect (x : J.expression) = - no_side_effect_expression_desc x.expression_desc - -let no_side_effect_expression (x : J.expression) = no_side_effect x - -let super = Js_record_iter.super - -let no_side_effect_obj = - { - super with - statement = - (fun self s -> - match s.statement_desc with - | Throw _ | Debugger | Break | Variable _ | Continue _ -> - raise_notrace Not_found - | Exp e -> self.expression self e - | Int_switch _ | String_switch _ | ForRange _ | If _ | While _ | Block _ - | Return _ | Try _ -> - super.statement self s); - expression = - (fun _ s -> - if not (no_side_effect_expression s) then raise_notrace Not_found); - } - -let no_side_effect_statement st = - try - no_side_effect_obj.statement no_side_effect_obj st; - true - with _ -> false - -(* TODO: generate [fold2] - This make sense, for example: - {[ - let string_of_formatting_gen : type a b c d e f . - (a, b, c, d, e, f) formatting_gen -> string = - fun formatting_gen -> match formatting_gen with - | Open_tag (Format (_, str)) -> str - | Open_box (Format (_, str)) -> str - - ]} -*) -let rec eq_expression ({ expression_desc = x0 } : J.expression) - ({ expression_desc = y0 } : J.expression) = - match x0 with - | Null -> y0 = Null - | Undefined x -> y0 = Undefined x - | Number (Int { i }) -> ( - match y0 with Number (Int { i = j }) -> i = j | _ -> false) - | Number (BigInt {positive = p0; value = v0}) -> ( - match y0 with Number (BigInt {positive = p1; value = v1}) -> p0 = p1 && v0 = v1 | _ -> false) - | Number (Float _) -> false - (* begin match y0 with - | Number (Float j) -> - false (* conservative *) - | _ -> false - end *) - | String_index (a0, a1) -> ( - match y0 with - | String_index (b0, b1) -> eq_expression a0 b0 && eq_expression a1 b1 - | _ -> false) - | Array_index (a0, a1) -> ( - match y0 with - | Array_index (b0, b1) -> eq_expression a0 b0 && eq_expression a1 b1 - | _ -> false) - | Call (a0, args00, _) -> ( - match y0 with - | Call (b0, args10, _) -> - eq_expression a0 b0 && eq_expression_list args00 args10 - | _ -> false) - | Var x -> ( match y0 with Var y -> Js_op_util.same_vident x y | _ -> false) - | Bin (op0, a0, b0) -> ( - match y0 with - | Bin (op1, a1, b1) -> - op0 = op1 && eq_expression a0 a1 && eq_expression b0 b1 - | _ -> false) - | Str {delim=a0; txt=b0} -> ( - match y0 with Str {delim=a1; txt=b1} -> a0 = a1 && b0 = b1 | _ -> false) - | Static_index (e0, p0, off0) -> ( - match y0 with - | Static_index (e1, p1, off1) -> - p0 = p1 && eq_expression e0 e1 && off0 = off1 (* could be relaxed *) - | _ -> false) - | Seq (a0, b0) -> ( - match y0 with - | Seq (a1, b1) -> eq_expression a0 a1 && eq_expression b0 b1 - | _ -> false) - | Bool a0 -> ( match y0 with Bool b0 -> a0 = b0 | _ -> false) - | Optional_block (a0, b0) -> ( - match y0 with - | Optional_block (a1, b1) -> b0 = b1 && eq_expression a0 a1 - | _ -> false) - | Caml_block (ls0, flag0, tag0, _) -> ( - match y0 with - | Caml_block (ls1, flag1, tag1, _) -> - eq_expression_list ls0 ls1 && flag0 = flag1 && eq_expression tag0 tag1 - | _ -> false) - | Length _ | Is_null_or_undefined _ | String_append _ | Typeof _ | Js_not _ - | Cond _ | FlatCall _ | New _ | Fun _ | Raw_js_code _ | Array _ - | Caml_block_tag _ | Object _ | Tagged_template _ - | Number (Uint _) -> - false - | Await _ -> false - -and eq_expression_list xs ys = Ext_list.for_all2_no_exn xs ys eq_expression - -and eq_block (xs : J.block) (ys : J.block) = - Ext_list.for_all2_no_exn xs ys eq_statement - -and eq_statement ({ statement_desc = x0 } : J.statement) - ({ statement_desc = y0 } : J.statement) = - match x0 with - | Exp a -> ( match y0 with Exp b -> eq_expression a b | _ -> false) - | Return a -> ( match y0 with Return b -> eq_expression a b | _ -> false) - | Debugger -> y0 = Debugger - | Break -> y0 = Break - | Block xs0 -> ( match y0 with Block ys0 -> eq_block xs0 ys0 | _ -> false) - | Variable _ | If _ | While _ | ForRange _ | Continue _ | Int_switch _ - | String_switch _ | Throw _ | Try _ -> - false - -let rev_flatten_seq (x : J.expression) = - let rec aux acc (x : J.expression) : J.block = - match x.expression_desc with - | Seq (a, b) -> aux (aux acc a) b - | _ -> { statement_desc = Exp x; comment = None } :: acc - in - aux [] x - -(* TODO: optimization, - counter the number to know if needed do a loop gain instead of doing a diff -*) - -let rev_toplevel_flatten block = - let rec aux acc (xs : J.block) : J.block = - match xs with - | [] -> acc - | { - statement_desc = - Variable - ( { ident_info = { used_stats = Dead_pure }; _ } - | { ident_info = { used_stats = Dead_non_pure }; value = None } ); - } - :: xs -> - aux acc xs - | { statement_desc = Block b; _ } :: xs -> aux (aux acc b) xs - | x :: xs -> aux (x :: acc) xs - in - aux [] block - -(* let rec is_constant (x : J.expression) = - match x.expression_desc with - | Array_index (a,b) -> is_constant a && is_constant b - | Str (b,_) -> b - | Number _ -> true (* Can be refined later *) - | Array (xs,_mutable_flag) -> Ext_list.for_all xs is_constant - | Caml_block(xs, Immutable, tag, _) - -> Ext_list.for_all xs is_constant && is_constant tag - | Bin (_op, a, b) -> - is_constant a && is_constant b - | _ -> false *) - -let rec is_okay_to_duplicate (e : J.expression) = - match e.expression_desc with - | Var _ | Bool _ | Str _ | Number _ -> true - | Static_index (e, _s, _off) -> is_okay_to_duplicate e - | _ -> false diff --git a/jscomp/core/js_analyzer.mli b/jscomp/core/js_analyzer.mli deleted file mode 100644 index 7a1f281..0000000 --- a/jscomp/core/js_analyzer.mli +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Analyzing utilities for [J] module *) - -(** for example, whether it has side effect or not. -*) - -val free_variables_of_statement : J.statement -> Set_ident.t - -val free_variables_of_expression : J.finish_ident_expression -> Set_ident.t - -(* val no_side_effect_expression_desc : - J.expression_desc -> bool *) - -val no_side_effect_expression : J.expression -> bool -(** [no_side_effect] means this expression has no side effect, - but it might *depend on value store*, so you can not just move it around, - - for example, - when you want to do a deep copy, the expression passed to you is pure - but you still have to call the function to make a copy, - since it maybe changed later -*) - -val no_side_effect_statement : J.statement -> bool -(** - here we say - {[ var x = no_side_effect_expression ]} - is [no side effect], but it is actually side effect, - since we are defining a variable, however, if it is not exported or used, - then it's fine, so we delay this check later -*) - -val eq_expression : J.expression -> J.expression -> bool - -val eq_statement : J.statement -> J.statement -> bool - -val eq_block : J.block -> J.block -> bool - -val rev_flatten_seq : J.expression -> J.block - -val rev_toplevel_flatten : J.block -> J.block -(** return the block in reverse order *) - -(* val is_constant : J.expression -> bool *) - -(** Simple expression, - no computation involved so that it is okay to be duplicated -*) - -val is_okay_to_duplicate : J.expression -> bool diff --git a/jscomp/core/js_arr.ml b/jscomp/core/js_arr.ml deleted file mode 100644 index 0c83e24..0000000 --- a/jscomp/core/js_arr.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -let set_array e e0 e1 = E.assign (E.array_index e e0) e1 - -let ref_array e e0 = E.array_index e e0 diff --git a/jscomp/core/js_arr.mli b/jscomp/core/js_arr.mli deleted file mode 100644 index 9c9dda8..0000000 --- a/jscomp/core/js_arr.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val set_array : J.expression -> J.expression -> J.expression -> J.expression - -val ref_array : J.expression -> J.expression -> J.expression diff --git a/jscomp/core/js_ast_util.ml b/jscomp/core/js_ast_util.ml deleted file mode 100644 index c761a06..0000000 --- a/jscomp/core/js_ast_util.ml +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* module E = Js_exp_make *) - -module S = Js_stmt_make - -let named_expression (e : J.expression) : (J.statement * Ident.t) option = - if Js_analyzer.is_okay_to_duplicate e then None - else - let obj = Ext_ident.create_tmp () in - let obj_code = S.define_variable ~kind:Strict obj e in - Some (obj_code, obj) diff --git a/jscomp/core/js_ast_util.mli b/jscomp/core/js_ast_util.mli deleted file mode 100644 index 3977f0e..0000000 --- a/jscomp/core/js_ast_util.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val named_expression : J.expression -> (J.statement * Ident.t) option diff --git a/jscomp/core/js_block_runtime.ml b/jscomp/core/js_block_runtime.ml deleted file mode 100644 index 8d80405..0000000 --- a/jscomp/core/js_block_runtime.ml +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2019- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let option_id = Ident.create_persistent Js_runtime_modules.option - -let curry_id = Ident.create_persistent Js_runtime_modules.curry - -let check_additional_id (x : J.expression) : Ident.t option = - match x.expression_desc with - | Optional_block (_, false) -> Some option_id - | Call (_, _, { arity = NA }) -> Some curry_id - | _ -> None diff --git a/jscomp/core/js_block_runtime.mli b/jscomp/core/js_block_runtime.mli deleted file mode 100644 index 0c46a8e..0000000 --- a/jscomp/core/js_block_runtime.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2019- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val check_additional_id : J.expression -> Ident.t option diff --git a/jscomp/core/js_call_info.ml b/jscomp/core/js_call_info.ml deleted file mode 100644 index e3f8cfa..0000000 --- a/jscomp/core/js_call_info.ml +++ /dev/null @@ -1,42 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type arity = Full | NA - -type call_info = - | Call_ml (* called by plain ocaml expression *) - | Call_builtin_runtime (* built-in externals *) - | Call_na -(* either from [@@val] or not available, - such calls does not follow such rules - {[ fun x y -> (f x y) === f ]} when [f] is an atom -*) - -type t = { call_info : call_info; arity : arity } - -let dummy = { arity = NA; call_info = Call_na } - -let builtin_runtime_call = { arity = Full; call_info = Call_builtin_runtime } - -let ml_full_call = { arity = Full; call_info = Call_ml } diff --git a/jscomp/core/js_call_info.mli b/jscomp/core/js_call_info.mli deleted file mode 100644 index 9e8a5f3..0000000 --- a/jscomp/core/js_call_info.mli +++ /dev/null @@ -1,44 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Type for collecting call site information, used in JS IR *) - -type arity = Full | NA - -type call_info = - | Call_ml (* called by plain ocaml expression *) - | Call_builtin_runtime (* built-in externals *) - | Call_na -(* either from [@@val] or not available, - such calls does not follow such rules - {[ fun x y -> f x y === f ]} when [f] is an atom -*) - -type t = { call_info : call_info; arity : arity } - -val dummy : t - -val builtin_runtime_call : t - -val ml_full_call : t diff --git a/jscomp/core/js_closure.ml b/jscomp/core/js_closure.ml deleted file mode 100644 index dc068bd..0000000 --- a/jscomp/core/js_closure.ml +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = { mutable outer_loop_mutable_values : Set_ident.t } - -let empty () = { outer_loop_mutable_values = Set_ident.empty } - -let set_lexical_scope t v = t.outer_loop_mutable_values <- v - -let get_lexical_scope t = t.outer_loop_mutable_values diff --git a/jscomp/core/js_closure.mli b/jscomp/core/js_closure.mli deleted file mode 100644 index 8ff3903..0000000 --- a/jscomp/core/js_closure.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Define a type used in JS IR to help convert lexical scope to JS [var] - based scope convention -*) - -type t = { mutable outer_loop_mutable_values : Set_ident.t } - -val empty : unit -> t - -val get_lexical_scope : t -> Set_ident.t - -val set_lexical_scope : t -> Set_ident.t -> unit diff --git a/jscomp/core/js_cmj_format.ml b/jscomp/core/js_cmj_format.ml deleted file mode 100644 index 9f33ebc..0000000 --- a/jscomp/core/js_cmj_format.ml +++ /dev/null @@ -1,169 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array - -(* TODO: add a magic number *) -type cmj_value = { - arity : arity; - persistent_closed_lambda : Lam.t option; - (** Either constant or closed functor *) -} - -type effect = string option - -let single_na = Single Lam_arity.na - -type keyed_cmj_value = { - name : string; - arity : arity; - persistent_closed_lambda : Lam.t option; -} - -type keyed_cmj_values = keyed_cmj_value array - -type t = { - values : keyed_cmj_values; - pure : bool; - package_spec : Js_packages_info.t; - case : Ext_js_file_kind.case; -} - -let make ~(values : cmj_value Map_string.t) ~effect ~package_spec ~case : t = - { - values = - Map_string.to_sorted_array_with_f values (fun k v -> - { - name = k; - arity = v.arity; - persistent_closed_lambda = v.persistent_closed_lambda; - }); - pure = effect = None; - package_spec; - case; - } - -(* Serialization .. *) -let from_file name : t = - let ic = open_in_bin name in - let _digest = Digest.input ic in - let v : t = input_value ic in - close_in ic; - v - -let from_file_with_digest name : t * Digest.t = - let ic = open_in_bin name in - let digest = Digest.input ic in - let v : t = input_value ic in - close_in ic; - (v, digest) - -let from_string s : t = Marshal.from_string s Ext_digest.length - -let for_sure_not_changed (name : string) (header : string) = - if Sys.file_exists name then ( - let ic = open_in_bin name in - let holder = really_input_string ic Ext_digest.length in - close_in ic; - holder = header) - else false - -(* This may cause some build system always rebuild - maybe should not be turned on by default -*) -let to_file name ~check_exists (v : t) = - let s = Marshal.to_string v [] in - let cur_digest = Digest.string s in - let header = cur_digest in - if not (check_exists && for_sure_not_changed name header) then ( - let oc = open_out_bin name in - output_string oc header; - output_string oc s; - close_out oc) - -let keyComp (a : string) b = Map_string.compare_key a b.name - -let not_found key = - { name = key; arity = single_na; persistent_closed_lambda = None } - -let get_result midVal = - match midVal.persistent_closed_lambda with - | Some - (Lconst - (Const_js_null | Const_js_undefined _ | Const_js_true | Const_js_false)) - | None -> - midVal - | Some _ -> - if !Js_config.cross_module_inline then midVal - else { midVal with persistent_closed_lambda = None } - -let rec binarySearchAux arr lo hi (key : string) = - let mid = (lo + hi) / 2 in - let midVal = Array.unsafe_get arr mid in - let c = keyComp key midVal in - if c = 0 then get_result midVal - else if c < 0 then - (* a[lo] =< key < a[mid] <= a[hi] *) - if hi = mid then - let loVal = Array.unsafe_get arr lo in - if loVal.name = key then get_result loVal else not_found key - else binarySearchAux arr lo mid key - else if (* a[lo] =< a[mid] < key <= a[hi] *) - lo = mid then - let hiVal = Array.unsafe_get arr hi in - if hiVal.name = key then get_result hiVal else not_found key - else binarySearchAux arr mid hi key - -let binarySearch (sorted : keyed_cmj_values) (key : string) : keyed_cmj_value = - let len = Array.length sorted in - if len = 0 then not_found key - else - let lo = Array.unsafe_get sorted 0 in - let c = keyComp key lo in - if c < 0 then not_found key - else - let hi = Array.unsafe_get sorted (len - 1) in - let c2 = keyComp key hi in - if c2 > 0 then not_found key else binarySearchAux sorted 0 (len - 1) key - -(* FIXME: better error message when ocamldep - get self-cycle -*) -let query_by_name (cmj_table : t) name : keyed_cmj_value = - let values = cmj_table.values in - binarySearch values name - -type path = string - -type cmj_load_info = { - cmj_table : t; - package_path : path; - (* - Note it is the package path we want - for ES6_global module spec - Maybe we can employ package map in the future - *) -} diff --git a/jscomp/core/js_cmj_format.mli b/jscomp/core/js_cmj_format.mli deleted file mode 100644 index 902ca04..0000000 --- a/jscomp/core/js_cmj_format.mli +++ /dev/null @@ -1,95 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Define intemediate format to be serialized for cross module optimization -*) - -(** In this module, - currently only arity information is exported, - - Short term: constant literals are also exported - - Long term: - Benefit? since Google Closure Compiler already did such huge amount of work - TODO: simple expression, literal small function can be stored, - but what would happen if small function captures other environment - for example - - {[ - let f = fun x -> g x - ]} - - {[ - let f = g - ]} -*) - -type arity = Single of Lam_arity.t | Submodule of Lam_arity.t array - -type cmj_value = { - arity : arity; - persistent_closed_lambda : Lam.t option; - (* Either constant or closed functor *) -} - -type effect = string option - -type keyed_cmj_value = { - name : string; - arity : arity; - persistent_closed_lambda : Lam.t option; -} - -type t = { - values : keyed_cmj_value array; - pure : bool; - package_spec : Js_packages_info.t; - case : Ext_js_file_kind.case; -} - -val make : - values:cmj_value Map_string.t -> - effect:effect -> - package_spec:Js_packages_info.t -> - case:Ext_js_file_kind.case -> - t - -val query_by_name : t -> string -> keyed_cmj_value - -val single_na : arity - -val from_file : string -> t - -val from_file_with_digest : string -> t * Digest.t - -val from_string : string -> t - -(* - Note writing the file if its content is not changed -*) -val to_file : string -> check_exists:bool -> t -> unit - -type path = string - -type cmj_load_info = { cmj_table : t; package_path : path } diff --git a/jscomp/core/js_cmj_load.ml b/jscomp/core/js_cmj_load.ml deleted file mode 100644 index ac94a1a..0000000 --- a/jscomp/core/js_cmj_load.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* Copyright (C) Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* strategy: - If not installed, use the distributed [cmj] files, - make sure that the distributed files are platform independent -*) - - - - -(* -let load_unit_no_file unit_name : Js_cmj_format.cmj_load_info = - let file = unit_name ^ Literals.suffix_cmj in - match Config_util.find_opt file with - | Some f - -> - {package_path = - (** hacking relying on the convention of pkg/lib/ocaml/xx.cmj*) - Filename.dirname (Filename.dirname (Filename.dirname f)); - cmj_table = Js_cmj_format.from_file f} - | None -> - Bs_exception.error (Cmj_not_found unit_name) *) - -let load_unit_with_file unit_name : Js_cmj_format.cmj_load_info = - let file = unit_name ^ Literals.suffix_cmj in - match Config_util.find_opt file with - | Some f - -> - {package_path = - (* hacking relying on the convention of pkg/lib/ocaml/xx.cmj*) - Filename.dirname (Filename.dirname (Filename.dirname f)); - cmj_table = Js_cmj_format.from_file f} - | None -> Bs_exception.error (Cmj_not_found unit_name) - -(* we can disable loading from file for troubleshooting - Note in dev mode we still allow loading from file is to - make the dev build still function correct -*) -let load_unit = ref load_unit_with_file \ No newline at end of file diff --git a/jscomp/core/js_cmj_load.mli b/jscomp/core/js_cmj_load.mli deleted file mode 100644 index 08da39f..0000000 --- a/jscomp/core/js_cmj_load.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** This module is platform dependent, on browser environment, - it depends on {!Js_cmj_datasets}, for non-browser environment, it fails -*) - -val load_unit : (string -> Js_cmj_format.cmj_load_info) ref diff --git a/jscomp/core/js_dump.ml b/jscomp/core/js_dump.ml deleted file mode 100644 index 454f46d..0000000 --- a/jscomp/core/js_dump.ml +++ /dev/null @@ -1,1339 +0,0 @@ -(* ReScript compiler - * Copyright (C) 2015-2016 Bloomberg Finance L.P. - * http://www.ocsigen.org/js_of_ocaml/ - * Copyright (C) 2010 Jérôme Vouillon - * Laboratoire PPS - CNRS Université Paris Diderot - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) -(* Authors: Jérôme Vouillon, Hongbo Zhang *) - -(* - http://stackoverflow.com/questions/2846283/what-are-the-rules-for-javascripts-automatic-semicolon-insertion-asi - ASI catch up - {[ - a=b - ++c - --- - a=b ++c - ==================== - a ++ - --- - a - ++ - ==================== - a -- - --- - a - -- - ==================== - (continue/break/return/throw) a - --- - (continue/break/return/throw) - a - ==================== - ]} - -*) - -let name_symbol = Js_op.Symbol_name - -module P = Ext_pp -module E = Js_exp_make -module S = Js_stmt_make -module L = Js_dump_lit - -(* There modules are dynamically inserted in the last stage - {Caml_curry} - {Caml_option} - - They can appear anywhere so even if you have a module - { - let module Caml_block = ... - - (* Later would insert the use of Caml_block here which should - point tto the runtime module - *) - } - There are no sane way to easy detect it ahead of time, we should be - conservative here. - (our call Js_fun_env.get_unbounded env) is not precise -*) - -module Curry_gen = struct - let pp_curry_dot f = - P.string f Js_runtime_modules.curry; - P.string f L.dot - - let pp_optimize_curry (f : P.t) (len : int) = - pp_curry_dot f; - P.string f "__"; - P.string f (Printf.sprintf "%d" len) - - let pp_app_any (f : P.t) = - pp_curry_dot f; - P.string f "app" - - let pp_app (f : P.t) (len : int) = - pp_curry_dot f; - P.string f "_"; - P.string f (Printf.sprintf "%d" len) -end - -let return_indent = String.length L.return / Ext_pp.indent_length -let throw_indent = String.length L.throw / Ext_pp.indent_length - -type cxt = Ext_pp_scope.t - -let semi f = P.string f L.semi -let comma f = P.string f L.comma - -let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info) - : J.expression_desc = - let field_name = - match ext with - | Blk_extension -> ( - fun i -> - match i with 0 -> Literals.exception_id | i -> "_" ^ string_of_int i) - | Blk_record_ext { fields = ss } -> ( - fun i -> match i with 0 -> Literals.exception_id | i -> ss.(i - 1)) - | _ -> assert false - in - Object - (if stack then - Ext_list.mapi_append el - (fun i e -> (Js_op.Lit (field_name i), e)) - [ (Js_op.Lit "Error", E.new_ (E.js_global "Error") []) ] - else Ext_list.mapi el (fun i e -> (Js_op.Lit (field_name i), e))) - -let rec iter_lst cxt (f : P.t) ls element inter = - match ls with - | [] -> cxt - | [ e ] -> element cxt f e - | e :: r -> - let acxt = element cxt f e in - inter f; - iter_lst acxt f r element inter - -let raw_snippet_exp_simple_enough (s : string) = - Ext_string.for_all s (fun c -> - match c with 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' -> true | _ -> false) -(* Parentheses are required when the expression - starts syntactically with "{" or "function" - TODO: be more conservative, since Google Closure will handle - the precedence correctly, we also need people read the code.. - Here we force parens for some alien operators - - If we move assign into a statement, will be less? - TODO: construct a test case that do need parenthesisze for expression - IIE does not apply (will be inlined?) -*) - -(* e = function(x){...}(x); is good -*) -let exp_need_paren (e : J.expression) = - match e.expression_desc with - (* | Caml_uninitialized_obj _ *) - | Call ({ expression_desc = Fun _ | Raw_js_code _ }, _, _) -> true - | Raw_js_code { code_info = Exp _ } - | Fun _ - | Caml_block - ( _, - _, - _, - ( Blk_record _ | Blk_module _ | Blk_poly_var _ | Blk_extension - | Blk_record_ext _ | Blk_record_inlined _ | Blk_constructor _ ) ) - | Object _ -> - true - | Raw_js_code { code_info = Stmt _ } - | Length _ | Call _ | Caml_block_tag _ | Seq _ | Static_index _ | Cond _ - | Bin _ | Is_null_or_undefined _ | String_index _ | Array_index _ - | String_append _ | Var _ | Undefined _ | Null | Str _ | Array _ - | Optional_block _ | Caml_block _ | FlatCall _ | Typeof _ | Number _ - | Js_not _ | Bool _ | New _ -> - false - | Await _ -> false - | Tagged_template _ -> false - -let comma_idents (cxt : cxt) f ls = iter_lst cxt f ls Ext_pp_scope.ident comma - -let pp_paren_params (inner_cxt : cxt) (f : Ext_pp.t) (lexical : Ident.t list) : - unit = - P.string f L.lparen; - let (_ : cxt) = comma_idents inner_cxt f lexical in - P.string f L.rparen - -(** Print as underscore for unused vars, may not be - needed in the future *) -(* let ipp_ident cxt f id (un_used : bool) = - Ext_pp_scope.ident cxt f ( - if un_used then - Ext_ident.make_unused () - else - id) *) - -let pp_var_assign cxt f id = - P.string f L.var; - P.space f; - let acxt = Ext_pp_scope.ident cxt f id in - P.space f; - P.string f L.eq; - P.space f; - acxt - -let pp_var_assign_this cxt f id = - let cxt = pp_var_assign cxt f id in - P.string f L.this; - P.space f; - semi f; - P.newline f; - cxt - -let pp_var_declare cxt f id = - P.string f L.var; - P.space f; - let acxt = Ext_pp_scope.ident cxt f id in - semi f; - acxt - -let pp_direction f (direction : J.for_direction) = - match direction with - | Up | Upto -> P.string f L.plus_plus - | Downto -> P.string f L.minus_minus - -let return_sp f = - P.string f L.return; - P.space f - -let bool f b = P.string f (if b then L.true_ else L.false_) - -let comma_sp f = - comma f; - P.space f - -let comma_nl f = - comma f; - P.newline f - -(* let drop_comment (x : J.expression) = - if x.comment = None then x - else {x with comment = None} *) - -let debugger_nl f = - P.newline f; - P.string f L.debugger; - semi f; - P.newline f - -let break_nl f = - P.string f L.break; - P.space f; - semi f; - P.newline f - -let continue f s = - P.string f L.continue; - P.space f; - P.string f s; - semi f - -let formal_parameter_list cxt f l = iter_lst cxt f l Ext_pp_scope.ident comma_sp - -(* IdentMap *) -(* -f/122 --> - f/122 is in the map - if in, use the old mapping - else - check f, - if in last bumped id - else - use "f", register it - - check "f" - if not , use "f", register stamp -> 0 - else - check stamp - if in use it - else check last bumped id, increase it and register -*) - -(** - Turn [function f (x,y) { return a (x,y)} ] into [Curry.__2(a)], - The idea is that [Curry.__2] will guess the arity of [a], if it does - hit, then there is no cost when passed -*) - -let is_var (b : J.expression) a = - match b.expression_desc with Var (Id i) -> Ident.same i a | _ -> false - -type fn_exp_state = - | Is_return (* for sure no name *) - | Name_top of Ident.t - | Name_non_top of Ident.t - | No_name of { single_arg : bool } -(* true means for sure, false -- not sure *) - -let default_fn_exp_state = No_name { single_arg = false } - -(* TODO: refactoring - Note that {!pp_function} could print both statement and expression when [No_name] is given -*) -let rec try_optimize_curry cxt f len function_id = - Curry_gen.pp_optimize_curry f len; - P.paren_group f 1 (fun _ -> expression ~level:1 cxt f function_id) - -and pp_function ~return_unit ~async ~is_method cxt (f : P.t) ~fn_state - (l : Ident.t list) (b : J.block) (env : Js_fun_env.t) : cxt = - match b with - | [ - { - statement_desc = - Return - { - expression_desc = - Call - ( ({ expression_desc = Var v; _ } as function_id), - ls, - { - arity = (Full | NA) as arity (* see #234*); - (* TODO: need a case to justify it*) - call_info = Call_builtin_runtime | Call_ml; - } ); - }; - }; - ] - when (* match such case: - {[ function(x,y){ return u(x,y) } ]} - it can be optimized in to either [u] or [Curry.__n(u)] - *) - (not is_method) - && Ext_list.for_all2_no_exn ls l is_var - && - match v with - (* This check is needed to avoid some edge cases - {[function(x){return x(x)}]} - here the function is also called `x` - *) - | Id id -> not (Ext_list.exists l (fun x -> Ident.same x id)) - | Qualified _ -> true -> ( - let optimize len ~p cxt f v = - if p then try_optimize_curry cxt f len function_id else vident cxt f v - in - let len = List.length l in - (* length *) - match fn_state with - | Name_top i | Name_non_top i -> - let cxt = pp_var_assign cxt f i in - let cxt = optimize len ~p:(arity = NA && len <= 8) cxt f v in - semi f; - cxt - | Is_return | No_name _ -> - if fn_state = Is_return then return_sp f; - optimize len ~p:(arity = NA && len <= 8) cxt f v) - | _ -> - let set_env : Set_ident.t = - (* identifiers will be printed following*) - match fn_state with - | Is_return | No_name _ -> Js_fun_env.get_unbounded env - | Name_top id | Name_non_top id -> - Set_ident.add (Js_fun_env.get_unbounded env) id - in - (* the context will be continued after this function *) - let outer_cxt = Ext_pp_scope.merge cxt set_env in - - (* the context used to be printed inside this function - - when printing a function, - only the enclosed variables and function name matters, - if the function does not capture any variable, then the context is empty - *) - let inner_cxt = Ext_pp_scope.sub_scope outer_cxt set_env in - let param_body () : unit = - if is_method then ( - match l with - | [] -> assert false - | this :: arguments -> - let cxt = - P.paren_group f 1 (fun _ -> - formal_parameter_list inner_cxt f arguments) - in - P.space f; - P.brace_vgroup f 1 (fun _ -> - let cxt = - if Js_fun_env.get_unused env 0 then cxt - else pp_var_assign_this cxt f this - in - function_body ~return_unit cxt f b)) - else - let cxt = - P.paren_group f 1 (fun _ -> formal_parameter_list inner_cxt f l) - in - P.space f; - P.brace_vgroup f 1 (fun _ -> function_body ~return_unit cxt f b) - in - let lexical : Set_ident.t = Js_fun_env.get_lexical_scope env in - let enclose lexical = - let handle lexical = - if Set_ident.is_empty lexical then ( - match fn_state with - | Is_return -> - return_sp f; - P.string f (L.function_async ~async); - P.space f; - param_body () - | No_name { single_arg } -> - (* see # 1692, add a paren for annoymous function for safety *) - P.cond_paren_group f (not single_arg) 1 (fun _ -> - P.string f (L.function_async ~async); - P.space f; - param_body ()) - | Name_non_top x -> - ignore (pp_var_assign inner_cxt f x : cxt); - P.string f (L.function_async ~async); - P.space f; - param_body (); - semi f - | Name_top x -> - P.string f (L.function_async ~async); - P.space f; - ignore (Ext_pp_scope.ident inner_cxt f x : cxt); - param_body ()) - else - (* print our closure as - {[(function(x,y){ return function(..){...}} (x,y))]} - Maybe changed to `let` in the future - *) - let lexical = Set_ident.elements lexical in - (match fn_state with - | Is_return -> return_sp f - | No_name _ -> () - | Name_non_top name | Name_top name -> - ignore (pp_var_assign inner_cxt f name : cxt)); - if async then P.string f L.await; - P.string f L.lparen; - P.string f (L.function_async ~async); - pp_paren_params inner_cxt f lexical; - P.brace_vgroup f 0 (fun _ -> - return_sp f; - P.string f (L.function_async ~async); - P.space f; - (match fn_state with - | Is_return | No_name _ -> () - | Name_non_top x | Name_top x -> - ignore (Ext_pp_scope.ident inner_cxt f x)); - param_body ()); - pp_paren_params inner_cxt f lexical; - P.string f L.rparen; - match fn_state with - | Is_return | No_name _ -> () (* expression *) - | _ -> semi f - (* has binding, a statement *) - in - handle - (match fn_state with - | (Name_top name | Name_non_top name) when Set_ident.mem lexical name - -> - (*TODO: when calculating lexical we should not include itself *) - Set_ident.remove lexical name - | _ -> lexical) - in - enclose lexical; - outer_cxt - -(* Assume the cond would not change the context, - since it can be either [int] or [string] -*) -and pp_one_case_clause : - 'a. _ -> P.t -> (P.t -> 'a -> unit) -> 'a * J.case_clause -> _ = - fun cxt f pp_cond - (switch_case, ({ switch_body; should_break; comment } : J.case_clause)) -> - let cxt = - P.group f 1 (fun _ -> - P.group f 1 (fun _ -> - P.string f L.case; - P.space f; - pp_comment_option f comment; - pp_cond f switch_case; - (* could be integer or string *) - P.space f; - P.string f L.colon); - P.group f 1 (fun _ -> - let cxt = - match switch_body with - | [] -> cxt - | _ -> - P.newline f; - statements false cxt f switch_body - in - if should_break then ( - P.newline f; - P.string f L.break; - semi f); - cxt)) - in - P.newline f; - cxt - -and loop_case_clauses : - 'a. cxt -> P.t -> (P.t -> 'a -> unit) -> ('a * J.case_clause) list -> cxt - = - fun cxt f pp_cond cases -> - Ext_list.fold_left cases cxt (fun acc x -> pp_one_case_clause acc f pp_cond x) - -and vident cxt f (v : J.vident) = - match v with - | Id v - | Qualified ({ id = v }, None) - | Qualified ({ id = v; kind = External { default = true } }, _) -> - Ext_pp_scope.ident cxt f v - | Qualified ({ id; kind = Ml | Runtime }, Some name) -> - let cxt = Ext_pp_scope.ident cxt f id in - P.string f L.dot; - P.string f - (if name = Js_dump_import_export.default_export then name - else Ext_ident.convert name); - cxt - | Qualified ({ id; kind = External _ }, Some name) -> - let cxt = Ext_pp_scope.ident cxt f id in - Js_dump_property.property_access f name; - cxt - -(* The higher the level, the more likely that inner has to add parens *) -and expression ~level:l cxt f (exp : J.expression) : cxt = - pp_comment_option f exp.comment; - expression_desc cxt ~level:l f exp.expression_desc - -and expression_desc cxt ~(level : int) f x : cxt = - match x with - | Null -> - P.string f L.null; - cxt - | Undefined _ -> - P.string f L.undefined; - cxt - | Var v -> vident cxt f v - | Bool b -> - bool f b; - cxt - | Seq (e1, e2) -> - P.cond_paren_group f (level > 0) 1 (fun () -> - let cxt = expression ~level:0 cxt f e1 in - comma_sp f; - expression ~level:0 cxt f e2) - | Fun { is_method; params; body; env; return_unit; async } -> - (* TODO: dump for comments *) - pp_function ~is_method cxt f ~fn_state:default_fn_exp_state params body - env ~return_unit ~async - (* TODO: - when [e] is [Js_raw_code] with arity - print it in a more precise way - It seems the optimizer already did work to make sure - {[ - Call (Raw_js_code (s, Exp i), el, {Full}) - when Ext_list.length_equal el i - ]} - *) - | Call (e, el, info) -> - P.cond_paren_group f (level > 15) 1 (fun _ -> - P.group f 1 (fun _ -> - match (info, el) with - | { arity = Full }, _ | _, [] -> - let cxt = expression ~level:15 cxt f e in - P.paren_group f 1 (fun _ -> - match el with - | [ - { - expression_desc = - Fun - { - is_method; - params; - body; - env; - return_unit; - async; - }; - }; - ] -> - pp_function ~is_method ~return_unit ~async cxt f - ~fn_state:(No_name { single_arg = true }) - params body env - | _ -> - let el = match el with - | [e] when e.expression_desc = Undefined {isUnit = true} -> - (* omit passing undefined when the call is f() *) - [] - | _ -> - el in - arguments cxt f el) - | _, _ -> - let len = List.length el in - if 1 <= len && len <= 8 then ( - Curry_gen.pp_app f len; - P.paren_group f 1 (fun _ -> arguments cxt f (e :: el))) - else ( - Curry_gen.pp_app_any f; - P.paren_group f 1 (fun _ -> - arguments cxt f [ e; E.array Mutable el ])))) - | FlatCall (e, el) -> - P.group f 1 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.string f L.dot; - P.string f L.apply; - P.paren_group f 1 (fun _ -> - P.string f L.null; - comma_sp f; - expression ~level:1 cxt f el)) - | Tagged_template (callExpr, stringArgs, valueArgs) -> - let cxt = expression cxt ~level f callExpr in - P.string f "`"; - let rec aux cxt xs ys = match xs, ys with - | [], [] -> () - | [{J.expression_desc = Str { txt; _ }}], [] -> - P.string f txt - | {J.expression_desc = Str { txt; _ }} :: x_rest, y :: y_rest -> - P.string f txt; - P.string f "${"; - let cxt = expression cxt ~level f y in - P.string f "}"; - aux cxt x_rest y_rest - | _ -> assert false - in - aux cxt stringArgs valueArgs; - P.string f "`"; - cxt - | String_index (a, b) -> - P.group f 1 (fun _ -> - let cxt = expression ~level:15 cxt f a in - P.string f L.dot; - P.string f L.codePointAt; - (* FIXME: use code_point_at *) - P.paren_group f 1 (fun _ -> expression ~level:0 cxt f b)) - | Str { delim; txt } -> - (*TODO -- - when utf8-> it will not escape '\\' which is definitely not we want - *) - let () = - match delim with - | DStarJ -> P.string f ("\"" ^ txt ^ "\"") - | DNoQuotes -> P.string f txt - | DNone -> Js_dump_string.pp_string f txt - in - cxt - | Raw_js_code { code = s; code_info = info } -> ( - match info with - | Exp exp_info -> - let raw_paren = - not - (match exp_info with - | Js_literal _ -> true - | Js_function _ | Js_exp_unknown -> - false || raw_snippet_exp_simple_enough s) - in - if raw_paren then P.string f L.lparen; - P.string f s; - if raw_paren then P.string f L.rparen; - cxt - | Stmt stmt_info -> - if stmt_info = Js_stmt_comment then P.string f s - else ( - P.newline f; - P.string f s; - P.newline f); - cxt) - | Number v -> - let s = - match v with - | Float { f } -> Js_number.caml_float_literal_to_js_string f - (* attach string here for float constant folding?*) - | Int { i; c = Some c } -> Format.asprintf "/* %s */%ld" (Ext_util.string_of_int_as_char c) i - | Int { i; c = None } -> - Int32.to_string i - (* check , js convention with ocaml lexical convention *) - | Uint i -> Format.asprintf "%lu" i - | BigInt {positive; value} -> Format.asprintf "%sn" (Bigint_utils.to_string positive value) - in - let need_paren = - if s.[0] = '-' then level > 13 - (* Negative numbers may need to be parenthesized. *) - else - level = 15 (* Parenthesize as well when followed by a dot. *) - && s.[0] <> 'I' (* Infinity *) - && s.[0] <> 'N' - (* NaN *) - in - let action _ = P.string f s in - if need_paren then P.paren f action else action (); - cxt - | Is_null_or_undefined e -> - P.cond_paren_group f (level > 0) 1 (fun _ -> - let cxt = expression ~level:1 cxt f e in - P.space f; - P.string f "=="; - P.space f; - P.string f L.null; - cxt) - | Js_not e -> - P.cond_paren_group f (level > 13) 1 (fun _ -> - P.string f "!"; - expression ~level:13 cxt f e) - | Typeof e -> - P.string f "typeof"; - P.space f; - expression ~level:13 cxt f e - | Bin - ( Minus, - { - expression_desc = - Number ((Int { i = 0l; _ } | Float { f = "0." }) as desc); - }, - e ) - (* TODO: - Handle multiple cases like - {[ 0. - x ]} - {[ 0.00 - x ]} - {[ 0.000 - x ]} - *) -> - P.cond_paren_group f (level > 13) 1 (fun _ -> - P.string f (match desc with Float _ -> "- " | _ -> "-"); - expression ~level:13 cxt f e) - | Bin (op, e1, e2) -> - let out, lft, rght = Js_op_util.op_prec op in - let need_paren = - level > out || match op with Lsl | Lsr | Asr -> true | _ -> false - in - (* We are more conservative here, to make the generated code more readable - to the user *) - P.cond_paren_group f need_paren 1 (fun _ -> - let cxt = expression ~level:lft cxt f e1 in - P.space f; - P.string f (Js_op_util.op_str op); - P.space f; - expression ~level:rght cxt f e2) - | String_append (e1, e2) -> - let op : Js_op.binop = Plus in - let out, lft, rght = Js_op_util.op_prec op in - let need_paren = - level > out || match op with Lsl | Lsr | Asr -> true | _ -> false - in - P.cond_paren_group f need_paren 1 (fun _ -> - let cxt = expression ~level:lft cxt f e1 in - P.space f; - P.string f "+"; - P.space f; - expression ~level:rght cxt f e2) - | Array (el, _) -> ( - (* TODO: simplify for singleton list *) - match el with - | [] | [ _ ] -> P.bracket_group f 1 (fun _ -> array_element_list cxt f el) - | _ -> P.bracket_vgroup f 1 (fun _ -> array_element_list cxt f el)) - | Optional_block (e, identity) -> - expression ~level cxt f - (if identity then e - else E.runtime_call Js_runtime_modules.option "some" [ e ]) - | Caml_block (el, _, _, Blk_module fields) -> - expression_desc cxt ~level f - (Object - (Ext_list.map_combine fields el (fun x -> - Js_op.Lit (Ext_ident.convert x)))) - (*name convention of Record is slight different from modules*) - | Caml_block (el, mutable_flag, _, Blk_record { fields; record_repr }) -> ( - if - Array.length fields <> 0 - && Ext_array.for_alli fields (fun i v -> string_of_int i = v) - then expression_desc cxt ~level f (Array (el, mutable_flag)) - else - match record_repr with - | Record_regular -> - expression_desc cxt ~level f - (Object (Ext_list.combine_array fields el (fun i -> Js_op.Lit i))) - | Record_optional -> - let fields = - Ext_list.array_list_filter_map fields el (fun f x -> - match x.expression_desc with - | Undefined _ -> None - | _ -> Some (Js_op.Lit f, x)) - in - expression_desc cxt ~level f (Object fields)) - | Caml_block (el, _, _, Blk_poly_var _) -> ( - match el with - | [ tag; value ] -> - expression_desc cxt ~level f - (Object - [ - (Js_op.Lit Literals.polyvar_hash, tag); - (Lit Literals.polyvar_value, value); - ]) - | _ -> assert false) - | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) -> - expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext) - | Caml_block (el, _, tag, Blk_record_inlined p) -> - let untagged = Ast_untagged_variants.process_untagged p.attrs in - let objs = - let tails = - Ext_list.combine_array_append p.fields el - (if !Js_config.debug then [ (name_symbol, E.str p.name) ] else []) - (fun i -> Js_op.Lit i) - in - let is_optional (pname: Js_op.property_name) = - match pname with - | Lit n -> Ext_list.mem_string p.optional_labels n - | Symbol_name -> false - in - let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with - | None -> L.tag - | Some s -> s in - let tails = - match p.optional_labels with - | [] -> tails - | _ -> - Ext_list.filter_map tails (fun (f, x) -> - match x.expression_desc with - | Undefined _ when is_optional f -> None - | _ -> Some (f, x)) - in - if untagged then - tails - else - (Js_op.Lit tag_name, (* TAG:xx for inline records *) - match Ast_untagged_variants.process_tag_type p.attrs with - | None -> E.str p.name - | Some t -> E.tag_type t ) - :: tails - in - expression_desc cxt ~level f (Object objs) - | Caml_block (el, _, tag, Blk_constructor p) -> - let not_is_cons = p.name <> Literals.cons in - let tag_type = Ast_untagged_variants.process_tag_type p.attrs in - let untagged = Ast_untagged_variants.process_untagged p.attrs in - let tag_name = match Ast_untagged_variants.process_tag_name p.attrs with - | None -> L.tag - | Some s -> s in - let objs = - let tails = - Ext_list.mapi_append el - (fun i e -> - ( (match (not_is_cons, i) with - | false, 0 -> Js_op.Lit Literals.hd - | false, 1 -> Js_op.Lit Literals.tl - | _ -> Js_op.Lit ("_" ^ string_of_int i)), - e )) - (if !Js_config.debug && not_is_cons then - [ (name_symbol, E.str p.name) ] - else []) - in - if untagged || (not_is_cons = false) && p.num_nonconst = 1 then tails - else - ( Js_op.Lit tag_name, (* TAG:xx *) - match tag_type with - | None -> E.str p.name - | Some t -> E.tag_type t ) - :: tails - in - let exp = match objs with - | [(_, e)] when untagged -> e.expression_desc - | _ when untagged -> assert false (* should not happen *) - (* TODO: put restriction on the variant definitions allowed, to make sure this never happens. *) - | _ -> J.Object objs in - expression_desc cxt ~level f exp - | Caml_block - ( _, - _, - _, - (Blk_module_export _ | Blk_some | Blk_some_not_nested | Blk_lazy_general) - ) -> - assert false - | Caml_block (el, mutable_flag, _tag, Blk_tuple) -> - expression_desc cxt ~level f (Array (el, mutable_flag)) - | Caml_block_tag (e, tag) -> - P.group f 1 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.string f L.dot; - P.string f tag; - cxt) - | Array_index (e, p) -> - P.cond_paren_group f (level > 15) 1 (fun _ -> - P.group f 1 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.bracket_group f 1 (fun _ -> expression ~level:0 cxt f p))) - | Static_index (e, s, _) -> - P.cond_paren_group f (level > 15) 1 (fun _ -> - let cxt = expression ~level:15 cxt f e in - Js_dump_property.property_access f s; - (* See [ .obj_of_exports] - maybe in the ast level we should have - refer and export - *) - cxt) - | Length (e, _) -> - (*Todo: check parens *) - P.cond_paren_group f (level > 15) 1 (fun _ -> - let cxt = expression ~level:15 cxt f e in - P.string f L.dot; - P.string f L.length; - cxt) - | New (e, el) -> - P.cond_paren_group f (level > 15) 1 (fun _ -> - P.group f 1 (fun _ -> - P.string f L.new_; - P.space f; - let cxt = expression ~level:16 cxt f e in - P.paren_group f 1 (fun _ -> - match el with Some el -> arguments cxt f el | None -> cxt))) - | Cond (e, e1, e2) -> - let action () = - let cxt = expression ~level:3 cxt f e in - P.space f; - P.string f L.question; - P.space f; - (* - [level 1] is correct, however - to make nice indentation , force nested conditional to be parenthesized - *) - let cxt = P.group f 1 (fun _ -> expression ~level:3 cxt f e1) in - - P.space f; - P.string f L.colon_space; - (* idem *) - P.group f 1 (fun _ -> expression ~level:3 cxt f e2) - in - if level > 2 then P.paren_vgroup f 1 action else action () - | Object lst -> - (* #1946 object literal is easy to be - interpreted as block statement - here we avoid parens in such case - {[ - var f = { x : 2 , y : 2} - ]} - *) - P.cond_paren_group f (level > 1) 1 (fun _ -> - if lst = [] then ( - P.string f "{}"; - cxt) - else - P.brace_vgroup f 1 (fun _ -> property_name_and_value_list cxt f lst)) - | Await e -> - P.cond_paren_group f (level > 13) 1 (fun _ -> - P.string f "await "; - expression ~level:13 cxt f e) - -and property_name_and_value_list cxt f (l : J.property_map) = - iter_lst cxt f l - (fun cxt f (pn, e) -> - match e.expression_desc with - | Var (Id v | Qualified ({ id = v; _ }, None)) -> - let key = Js_dump_property.property_key pn in - let str, cxt = Ext_pp_scope.str_of_ident cxt v in - let content = - (* if key = str then key - else *) - key ^ L.colon_space ^ str - in - P.string f content; - cxt - | _ -> - let key = Js_dump_property.property_key pn in - P.string f key; - P.string f L.colon_space; - expression ~level:1 cxt f e) - comma_nl - -and array_element_list cxt f (el : E.t list) : cxt = - iter_lst cxt f el (expression ~level:1) comma_nl - -and arguments cxt f (l : E.t list) : cxt = - iter_lst cxt f l (expression ~level:1) comma_sp - -and variable_declaration top cxt f (variable : J.variable_declaration) : cxt = - (* TODO: print [const/var] for different backends *) - match variable with - | { ident = i; value = None; ident_info; _ } -> - if ident_info.used_stats = Dead_pure then cxt else pp_var_declare cxt f i - | { ident = name; value = Some e; ident_info = { used_stats; _ } } -> ( - match used_stats with - | Dead_pure -> cxt - | Dead_non_pure -> - (* Make sure parens are added correctly *) - statement_desc top cxt f (J.Exp e) - | _ -> ( - match e.expression_desc with - | Fun { is_method; params; body; env; return_unit; async } -> - pp_function ~is_method cxt f ~return_unit ~async - ~fn_state:(if top then Name_top name else Name_non_top name) - params body env - | _ -> - let cxt = pp_var_assign cxt f name in - let cxt = expression ~level:1 cxt f e in - semi f; - cxt)) - -and ipp_comment : 'a. P.t -> 'a -> unit = fun _f _comment -> () - -(** don't print a new line -- ASI - FIXME: this still does not work in some cases... - {[ - return /* ... */ - [... ] - ]} -*) - -and pp_comment f comment = - if String.length comment > 0 then ( - P.string f "/* "; - P.string f comment; - P.string f " */") - -and pp_comment_option f comment = - match comment with None -> () | Some x -> pp_comment f x - -and statement top cxt f ({ statement_desc = s; comment; _ } : J.statement) : cxt - = - pp_comment_option f comment; - statement_desc top cxt f s - -and statement_desc top cxt f (s : J.statement_desc) : cxt = - match s with - | Block [] -> - ipp_comment f L.empty_block; - (* debugging*) - cxt - | Exp { expression_desc = Var _ } -> - (* Does it make sense to optimize here? *) - (* semi f; *) - cxt - | Exp e -> ( - match e.expression_desc with - | Raw_js_code { code; code_info = Stmt Js_stmt_comment } -> - P.string f code; - cxt - | Raw_js_code { code_info = Exp (Js_literal { comment }) } -> - (match comment with - (* The %raw is just a comment *) - | Some s -> P.string f s - | None -> ()); - cxt - | Str _ -> cxt - | _ -> - let cxt = - (if exp_need_paren e then P.paren_group f 1 else P.group f 0) - (fun _ -> expression ~level:0 cxt f e) - in - semi f; - cxt) - | Block b -> - (* No braces needed here *) - ipp_comment f L.start_block; - let cxt = statements top cxt f b in - ipp_comment f L.end_block; - cxt - | Variable l -> variable_declaration top cxt f l - | If (e, s1, s2) -> ( - (* TODO: always brace those statements *) - P.string f L.if_; - P.space f; - let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in - P.space f; - let cxt = brace_block cxt f s1 in - match s2 with - | [] | [ { statement_desc = Block [] | Exp { expression_desc = Var _ } } ] - -> - P.newline f; - cxt - | [ ({ statement_desc = If _ } as nest) ] - | [ - { - statement_desc = Block [ ({ statement_desc = If _; _ } as nest) ]; - _; - }; - ] -> - P.space f; - P.string f L.else_; - P.space f; - statement false cxt f nest - | _ :: _ as s2 -> - P.space f; - P.string f L.else_; - P.space f; - brace_block cxt f s2) - | While (label, e, s, _env) -> - (* FIXME: print scope as well *) - (match label with - | Some i -> - P.string f i; - P.string f L.colon; - P.newline f - | None -> ()); - let cxt = - match e.expression_desc with - | Number (Int { i = 1l }) -> - P.string f L.while_; - P.string f L.lparen; - P.string f L.true_; - P.string f L.rparen; - P.space f; - cxt - | _ -> - P.string f L.while_; - let cxt = - P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) - in - P.space f; - cxt - in - let cxt = brace_block cxt f s in - semi f; - cxt - | ForRange (for_ident_expression, finish, id, direction, s, env) -> - let action cxt = - P.vgroup f 0 (fun _ -> - let cxt = - P.group f 0 (fun _ -> - (* The only place that [semi] may have semantics here *) - P.string f L.for_; - P.paren_group f 1 (fun _ -> - let cxt, new_id = - match - (for_ident_expression, finish.expression_desc) - with - | Some ident_expression, (Number _ | Var _) -> - let cxt = pp_var_assign cxt f id in - (expression ~level:0 cxt f ident_expression, None) - | Some ident_expression, _ -> - let cxt = pp_var_assign cxt f id in - let cxt = - expression ~level:1 cxt f ident_expression - in - P.space f; - comma f; - let id = - Ext_ident.create (Ident.name id ^ "_finish") - in - let cxt = Ext_pp_scope.ident cxt f id in - P.space f; - P.string f L.eq; - P.space f; - (expression ~level:1 cxt f finish, Some id) - | None, (Number _ | Var _) -> (cxt, None) - | None, _ -> - let id = - Ext_ident.create (Ident.name id ^ "_finish") - in - let cxt = pp_var_assign cxt f id in - (expression ~level:15 cxt f finish, Some id) - in - semi f; - P.space f; - let cxt = Ext_pp_scope.ident cxt f id in - P.space f; - let right_prec = - match direction with - | Upto -> - let _, _, right = Js_op_util.op_prec Le in - P.string f L.le; - right - | Up -> - let _, _, right = Js_op_util.op_prec Lt in - P.string f L.lt; - right - | Downto -> - let _, _, right = Js_op_util.op_prec Ge in - P.string f L.ge; - right - in - P.space f; - let cxt = - expression ~level:right_prec cxt f - (match new_id with - | Some i -> E.var i - | None -> finish) - in - semi f; - P.space f; - pp_direction f direction; - Ext_pp_scope.ident cxt f id)) - in - brace_block cxt f s) - in - let lexical = Js_closure.get_lexical_scope env in - if Set_ident.is_empty lexical then action cxt - else - (* unlike function, - [print for loop] has side effect, - we should take it out - *) - let inner_cxt = Ext_pp_scope.merge cxt lexical in - let lexical = Set_ident.elements lexical in - P.vgroup f 0 (fun _ -> - P.string f L.lparen; - P.string f L.function_; - pp_paren_params inner_cxt f lexical; - let cxt = P.brace_vgroup f 0 (fun _ -> action inner_cxt) in - pp_paren_params inner_cxt f lexical; - P.string f L.rparen; - semi f; - cxt) - | Continue s -> - continue f s; - cxt - (* P.newline f; #2642 *) - | Debugger -> - debugger_nl f; - cxt - | Break -> - break_nl f; - cxt - | Return e -> ( - match e.expression_desc with - | Fun { is_method; params; body; env; return_unit; async } -> - let cxt = - pp_function ~return_unit ~is_method ~async cxt f ~fn_state:Is_return - params body env - in - semi f; - cxt - | Undefined _ -> - return_sp f; - semi f; - cxt - | _ -> - return_sp f; - (* P.string f "return ";(\* ASI -- when there is a comment*\) *) - P.group f return_indent (fun _ -> - let cxt = expression ~level:0 cxt f e in - semi f; - cxt) - (* There MUST be a space between the return and its - argument. A line return will not work *)) - | Int_switch (e, cc, def) -> - P.string f L.switch; - P.space f; - let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in - P.space f; - P.brace_vgroup f 1 (fun _ -> - let cxt = - loop_case_clauses cxt f (fun f i -> P.string f (string_of_int i)) cc - in - match def with - | None -> cxt - | Some def -> - P.group f 1 (fun _ -> - P.string f L.default; - P.string f L.colon; - P.newline f; - statements false cxt f def)) - | String_switch (e, cc, def) -> - P.string f L.switch; - P.space f; - let cxt = P.paren_group f 1 (fun _ -> expression ~level:0 cxt f e) in - P.space f; - P.brace_vgroup f 1 (fun _ -> - let pp_as_value f (tag_type: Ast_untagged_variants.tag_type) = - let e = E.tag_type tag_type in - ignore @@ expression_desc cxt ~level:0 f e.expression_desc in - let cxt = loop_case_clauses cxt f pp_as_value cc in - match def with - | None -> cxt - | Some def -> - P.group f 1 (fun _ -> - P.string f L.default; - P.string f L.colon; - P.newline f; - statements false cxt f def)) - | Throw e -> - let e = - match e.expression_desc with - | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) -> - { e with expression_desc = exn_block_as_obj ~stack:true el ext } - | _ -> e - in - P.string f L.throw; - P.space f; - P.group f throw_indent (fun _ -> - let cxt = expression ~level:0 cxt f e in - semi f; - cxt) - (* There must be a space between the return and its - argument. A line return would not work *) - | Try (b, ctch, fin) -> - P.vgroup f 0 (fun _ -> - P.string f L.try_; - P.space f; - let cxt = brace_block cxt f b in - let cxt = - match ctch with - | None -> cxt - | Some (i, b) -> - P.newline f; - P.string f "catch ("; - let cxt = Ext_pp_scope.ident cxt f i in - P.string f ")"; - brace_block cxt f b - in - match fin with - | None -> cxt - | Some b -> - P.group f 1 (fun _ -> - P.string f L.finally; - P.space f; - brace_block cxt f b)) - -and function_body (cxt : cxt) f ~return_unit (b : J.block) : unit = - match b with - | [] -> () - | [ s ] -> ( - match s.statement_desc with - | If - ( bool, - then_, - [ { statement_desc = Return { expression_desc = Undefined _ } } ] ) -> - ignore - (statement false cxt f - { s with statement_desc = If (bool, then_, []) } - : cxt) - | Return { expression_desc = Undefined _ } -> () - | Return exp when return_unit -> - ignore (statement false cxt f (S.exp exp) : cxt) - | _ -> ignore (statement false cxt f s : cxt)) - | [ s; { statement_desc = Return { expression_desc = Undefined _ } } ] -> - ignore (statement false cxt f s : cxt) - | s :: r -> - let cxt = statement false cxt f s in - P.newline f; - function_body cxt f r ~return_unit - -and brace_block cxt f b = - (* This one is for '{' *) - P.brace_vgroup f 1 (fun _ -> statements false cxt f b) - -(* main entry point *) -and statements top cxt f b = - iter_lst cxt f b - (fun cxt f s -> statement top cxt f s) - (if top then P.at_least_two_lines else P.newline) - -let string_of_block (block : J.block) = - let buffer = Buffer.create 50 in - let f = P.from_buffer buffer in - let (_ : cxt) = statements true Ext_pp_scope.empty f block in - P.flush f (); - Buffer.contents buffer - -let string_of_expression (e : J.expression) = - let buffer = Buffer.create 50 in - let f = P.from_buffer buffer in - let (_ : cxt) = expression ~level:0 Ext_pp_scope.empty f e in - P.flush f (); - Buffer.contents buffer diff --git a/jscomp/core/js_dump.mli b/jscomp/core/js_dump.mli deleted file mode 100644 index 469a79f..0000000 --- a/jscomp/core/js_dump.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* ReScript compiler - * Copyright (C) 2015-2016 Bloomberg Finance L.P. - * http://www.ocsigen.org/js_of_ocaml/ - * Copyright (C) 2010 Jérôme Vouillon - * Laboratoire PPS - CNRS Université Paris Diderot - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) -(* Authors: Jérôme Vouillon, Hongbo Zhang *) - -val statements : bool -> Ext_pp_scope.t -> Ext_pp.t -> J.block -> Ext_pp_scope.t -(** Print JS IR to vanilla Javascript code - Called by module {!Js_dump_program} -*) - -val string_of_block : J.block -> string -(** 2 functions Only used for debugging *) - -val string_of_expression : J.expression -> string diff --git a/jscomp/core/js_dump_import_export.ml b/jscomp/core/js_dump_import_export.ml deleted file mode 100644 index dcf23ef..0000000 --- a/jscomp/core/js_dump_import_export.ml +++ /dev/null @@ -1,180 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module P = Ext_pp -module L = Js_dump_lit - -let default_export = "default" - -let esModule = ("__esModule", "true") -(* Exports printer *) - -let rev_iter_inter lst f inter = - match lst with - | [] -> () - | [ a ] -> f a - | a :: rest -> - Ext_list.rev_iter rest (fun x -> - f x; - inter ()); - f a - -(* Print exports in Google module format, CommonJS format *) -let exports cxt f (idents : Ident.t list) = - let outer_cxt, reversed_list = - Ext_list.fold_left idents (cxt, []) (fun (cxt, acc) id -> - let id_name = id.name in - let s = Ext_ident.convert id_name in - let str, cxt = Ext_pp_scope.str_of_ident cxt id in - ( cxt, - if id_name = default_export then - (* TODO check how it will affect AMDJS*) - esModule :: (default_export, str) :: acc - else (s, str) :: acc )) - in - P.at_least_two_lines f; - rev_iter_inter reversed_list - (fun (s, export) -> - P.group f 0 (fun _ -> - P.string f L.exports; - P.string f L.dot; - P.string f s; - P.space f; - P.string f L.eq; - P.space f; - P.string f export; - P.string f L.semi)) - (fun _ -> P.newline f); - outer_cxt - -(** Print module in ES6 format, it is ES6, trailing comma is valid ES6 code *) -let es6_export cxt f (idents : Ident.t list) = - let outer_cxt, reversed_list = - Ext_list.fold_left idents (cxt, []) (fun (cxt, acc) id -> - let id_name = id.name in - let s = Ext_ident.convert id_name in - let str, cxt = Ext_pp_scope.str_of_ident cxt id in - ( cxt, - if id_name = default_export then - (default_export, str) :: acc - else (s, str) :: acc )) - in - P.at_least_two_lines f; - P.string f L.export; - P.space f; - P.brace_vgroup f 1 (fun _ -> - rev_iter_inter reversed_list - (fun (s, export) -> - P.group f 0 (fun _ -> - P.string f export; - P.space f; - if not @@ Ext_string.equal export s then ( - P.string f L.as_; - P.space f; - P.string f s); - P.string f L.comma)) - (fun _ -> P.newline f)); - outer_cxt - -(** Node or Google module style imports *) -let requires require_lit cxt f (modules : (Ident.t * string * bool) list) = - (* the context used to print the following program *) - let outer_cxt, reversed_list = - Ext_list.fold_left modules (cxt, []) (fun (cxt, acc) (id, s, b) -> - let str, cxt = Ext_pp_scope.str_of_ident cxt id in - (cxt, (str, s, b) :: acc)) - in - P.at_least_two_lines f; - Ext_list.rev_iter reversed_list (fun (s, file, default) -> - P.string f L.var; - P.space f; - P.string f s; - P.space f; - P.string f L.eq; - P.space f; - P.string f require_lit; - P.paren_group f 0 (fun _ -> Js_dump_string.pp_string f file); - if default then P.string f ".default"; - P.string f L.semi; - P.newline f); - outer_cxt - -let dumpImportAttributes f (importAttributes : External_ffi_types.import_attributes option) = - match importAttributes with - | None -> () - | Some importAttributes -> - P.space f; - P.string f "with"; - P.space f; - let total = Hashtbl.length importAttributes in - let idx = ref 1 in - P.brace_group f 0 ( - fun _ -> - importAttributes |> Hashtbl.iter(fun key value -> - Js_dump_string.pp_string f key; - P.string f L.colon_space; - Js_dump_string.pp_string f value; - let shouldAddComma = !idx < total in - if shouldAddComma then ( - P.string f L.comma; - P.space f - ); - idx := !idx + 1; - ) - ) - -(** ES6 module style imports *) -let imports cxt f (modules : (Ident.t * string * bool * External_ffi_types.import_attributes option) list) = - (* the context used to print the following program *) - let outer_cxt, reversed_list = - Ext_list.fold_left modules (cxt, []) (fun (cxt, acc) (id, s, b, i) -> - let str, cxt = Ext_pp_scope.str_of_ident cxt id in - (cxt, (str, s, b, i) :: acc)) - in - P.at_least_two_lines f; - Ext_list.rev_iter reversed_list (fun (s, file, default, import_attributes) -> - P.string f L.import; - P.space f; - if default then ( - P.string f s; - P.space f; - P.string f L.from; - P.space f; - Js_dump_string.pp_string f file; - dumpImportAttributes f import_attributes) - else ( - P.string f L.star; - P.space f; - (* import * as xx from 'xx'*) - P.string f L.as_; - P.space f; - P.string f s; - P.space f; - P.string f L.from; - P.space f; - Js_dump_string.pp_string f file; - dumpImportAttributes f import_attributes); - P.string f L.semi; - P.newline f); - outer_cxt diff --git a/jscomp/core/js_dump_import_export.mli b/jscomp/core/js_dump_import_export.mli deleted file mode 100644 index 4d03a46..0000000 --- a/jscomp/core/js_dump_import_export.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val default_export : string - -val exports : Ext_pp_scope.t -> Ext_pp.t -> Ident.t list -> Ext_pp_scope.t - -val es6_export : Ext_pp_scope.t -> Ext_pp.t -> Ident.t list -> Ext_pp_scope.t - -val requires : - string -> - Ext_pp_scope.t -> - Ext_pp.t -> - (Ident.t * string * bool) list -> - Ext_pp_scope.t - -val imports : - Ext_pp_scope.t -> Ext_pp.t -> (Ident.t * string * bool * External_ffi_types.import_attributes option) list -> Ext_pp_scope.t diff --git a/jscomp/core/js_dump_lit.ml b/jscomp/core/js_dump_lit.ml deleted file mode 100644 index fbbe643..0000000 --- a/jscomp/core/js_dump_lit.ml +++ /dev/null @@ -1,166 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - -let await = "await" - -let function_ = "function" - -let function_async ~async = if async then "async function" else "function" - -let var = "var" (* should be able to switch to [let] easily*) - -let return = "return" - -(* let eq = "=" *) -let require = "require" - -let import = "import" - -let from = "from" - -let as_ = "as" - -let export = "export" - -let star = "*" - -let lparen = "(" - -let rparen = ")" - -let exports = "exports" - -let dot = "." - -let comma = "," - -let colon = Ext_string.single_colon - -let colon_space = ": " - -let throw = "throw" - -let default = "default" - -let length = "length" - -let codePointAt = "codePointAt" - -let new_ = "new" - -let array = "Array" - -let question = "?" - -let plusplus = "++" - -let minusminus = "--" - -let semi = ";" - -let else_ = "else" - -let if_ = "if" - -let for_ = "for" - -let try_ = "try" - -let finally = "finally" - -let this = "this" - -let while_ = "while" - -let empty_block = "empty_block" - -let start_block = "start_block" - -let end_block = "end_block" - -let json = "JSON" - -let stringify = "stringify" - -let console = "console" - -let define = "define" - -let break = "break" - -let continue = "continue" - -let switch = "switch" - -let strict_directive = "'use strict';" - -let true_ = "true" - -let false_ = "false" - -let debugger = "debugger" - -let tag = "TAG" - -let bind = "bind" - -let math = "Math" - -let apply = "apply" - -let null = "null" - -let undefined = "undefined" - -let string_cap = "String" - -let fromCharcode = "fromCharCode" - -let eq = "=" - -let le = "<=" - -let lt = "<" - -let ge = ">=" - -let gt = ">" - -let plus_plus = "++" - -(* FIXME: use (i = i + 1 | 0) instead *) -let minus_minus = "--" - -let caml_block_create = "__" - -(** debug symbols *) - -let block_poly_var = "polyVar" - -let block_variant = "variant" - -let block_simple_variant = "simpleVariant" - -let case = "case" diff --git a/jscomp/core/js_dump_program.ml b/jscomp/core/js_dump_program.ml deleted file mode 100644 index ce80e21..0000000 --- a/jscomp/core/js_dump_program.ml +++ /dev/null @@ -1,143 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module P = Ext_pp -module L = Js_dump_lit - -let empty_explanation = - "/* This output is empty. Its source's type definitions, externals and/or \ - unused code got optimized away. */\n" - -let program_is_empty (x : J.program) = - match x with - | { block = []; exports = []; export_set = _ } -> true - | _ -> false - -let deps_program_is_empty (x : J.deps_program) = - match x with - | { modules = []; program; side_effect = None } -> program_is_empty program - | _ -> false - -let rec extract_block_comments acc (x : J.block) = - match x with - | { - statement_desc = - Exp - { - expression_desc = - Raw_js_code { code; code_info = Stmt Js_stmt_comment }; - }; - } - :: rest -> - extract_block_comments (code :: acc) rest - | _ -> (acc, x) - -let extract_file_comments (x : J.deps_program) = - let comments, new_block = extract_block_comments [] x.program.block in - (comments, { x with program = { x.program with block = new_block } }) - -let program f cxt (x : J.program) = - P.at_least_two_lines f; - let cxt = Js_dump.statements true cxt f x.block in - Js_dump_import_export.exports cxt f x.exports - -let dump_program (x : J.program) oc = - ignore (program (P.from_channel oc) Ext_pp_scope.empty x) - -let[@inline] is_default (x : Js_op.kind) = - match x with External { default } -> default | _ -> false - -let node_program ~output_dir f (x : J.deps_program) = - P.string f L.strict_directive; - P.newline f; - let cxt = - Js_dump_import_export.requires L.require Ext_pp_scope.empty f - (* Not be emitted in require statements *) - (Ext_list.filter_map x.modules (fun x -> - match x.dynamic_import with - | true -> None - | false -> - Some ( x.id, - Js_name_of_module_id.string_of_module_id x ~output_dir Commonjs, - is_default x.kind ))) - in - program f cxt x.program - -let es6_program ~output_dir fmt f (x : J.deps_program) = - let cxt = - Js_dump_import_export.imports Ext_pp_scope.empty f - (* Not be emitted in import statements *) - (Ext_list.filter_map x.modules (fun x -> - match x.dynamic_import with - | true -> None - | false -> - Some ( x.id, - Js_name_of_module_id.string_of_module_id x ~output_dir fmt, - is_default x.kind, - (match x.kind with | External {import_attributes} -> import_attributes | _ -> None) ))) - in - let () = P.at_least_two_lines f in - let cxt = Js_dump.statements true cxt f x.program.block in - Js_dump_import_export.es6_export cxt f x.program.exports - -(** Make sure github linguist happy - {[ - require('Linguist') - Linguist::FileBlob.new('jscomp/test/test_u.js').generated? - ]} -*) - -let pp_deps_program ~(output_prefix : string) - (kind : Js_packages_info.module_system) (program : J.deps_program) - (f : Ext_pp.t) = - - !Js_config.directives |> List.iter (fun prim -> - P.string f prim; - P.newline f); - if not !Js_config.no_version_header then ( - P.string f Bs_version.header; - P.newline f); - - if deps_program_is_empty program then P.string f empty_explanation - (* This is empty module, it won't be referred anywhere *) - else - let comments, program = extract_file_comments program in - Ext_list.rev_iter comments (fun comment -> - P.string f comment; - P.newline f); - let output_dir = Filename.dirname output_prefix in - ignore - (match kind with - | Esmodule | Es6_global -> es6_program ~output_dir kind f program - | Commonjs -> node_program ~output_dir f program); - P.newline f; - P.string f - (match program.side_effect with - | None -> "/* No side effect */" - | Some v -> Printf.sprintf "/* %s Not a pure module */" v); - P.newline f; - P.flush f () - -let dump_deps_program ~output_prefix kind x (oc : out_channel) = - pp_deps_program ~output_prefix kind x (P.from_channel oc) diff --git a/jscomp/core/js_dump_program.mli b/jscomp/core/js_dump_program.mli deleted file mode 100644 index c1723f0..0000000 --- a/jscomp/core/js_dump_program.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val dump_program : J.program -> out_channel -> unit -(** only used for debugging purpose *) - -val pp_deps_program : - output_prefix:string -> - Js_packages_info.module_system -> - J.deps_program -> - Ext_pp.t -> - unit - -val dump_deps_program : - output_prefix:string -> - Js_packages_info.module_system -> - J.deps_program -> - out_channel -> - unit diff --git a/jscomp/core/js_dump_property.ml b/jscomp/core/js_dump_property.ml deleted file mode 100644 index ea1d4bf..0000000 --- a/jscomp/core/js_dump_property.ml +++ /dev/null @@ -1,89 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module P = Ext_pp -module L = Js_dump_lit - -(** - https://stackoverflow.com/questions/9367572/rules-for-unquoted-javascript-object-literal-keys - https://mathiasbynens.be/notes/javascript-properties - https://mathiasbynens.be/notes/javascript-identifiers - - Let's not do smart things - {[ - { 003 : 1} - ]} - becomes - {[ - { 3 : 1} - ]} -*) - -(** used in printing keys - {[ - {"x" : x};; - {x : x } - {"50x" : 2 } GPR #1943 -]} - Note we can not treat it in the same way when printing - [x.id] vs [{id : xx}] - for example, id can be number in object literal -*) -let obj_property_no_need_quot s = - let len = String.length s in - if len > 0 then - match String.unsafe_get s 0 with - | '$' | '_' | 'a' .. 'z' | 'A' .. 'Z' -> - Ext_string.for_all_from s 1 (function - | 'a' .. 'z' | 'A' .. 'Z' | '$' | '_' | '0' .. '9' -> true - | _ -> false) - | _ -> false - else false - -(** used in property access - {[ - f.x ;; - f["x"];; - ]} -*) -let property_access f s = - if obj_property_no_need_quot s then ( - P.string f L.dot; - P.string f s) - else - P.bracket_group f 1 (fun _ -> - (* avoid cases like - "0123", "123_456" - *) - match string_of_int (int_of_string s) with - | s0 when s0 = s -> P.string f s - | _ -> Js_dump_string.pp_string f s - | exception _ -> Js_dump_string.pp_string f s) - -let property_key (s : J.property_name) : string = - match s with - | Lit s -> - if obj_property_no_need_quot s then s - else Js_dump_string.escape_to_string s - | Symbol_name -> {|[Symbol.for("name")]|} diff --git a/jscomp/core/js_dump_property.mli b/jscomp/core/js_dump_property.mli deleted file mode 100644 index 2e675b1..0000000 --- a/jscomp/core/js_dump_property.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val property_access : Ext_pp.t -> string -> unit - -val property_key : J.property_name -> string diff --git a/jscomp/core/js_dump_string.ml b/jscomp/core/js_dump_string.ml deleted file mode 100644 index 11b8d25..0000000 --- a/jscomp/core/js_dump_string.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module P = Ext_pp - -(** Avoid to allocate single char string too many times*) -let array_str1 = Array.init 256 (fun i -> String.make 1 (Char.chr i)) - -(** For conveting - -*) -let array_conv = - [| - "0"; - "1"; - "2"; - "3"; - "4"; - "5"; - "6"; - "7"; - "8"; - "9"; - "a"; - "b"; - "c"; - "d"; - "e"; - "f"; - |] - -(* https://mathiasbynens.be/notes/javascript-escapes *) -let ( +> ) = Ext_buffer.add_string - -let escape_to_buffer f (* ?(utf=false)*) s = - let pp_raw_string f (* ?(utf=false)*) s = - let l = String.length s in - for i = 0 to l - 1 do - let c = String.unsafe_get s i in - match c with - | '\b' -> f +> "\\b" - | '\012' -> f +> "\\f" - | '\n' -> f +> "\\n" - | '\r' -> f +> "\\r" - | '\t' -> f +> "\\t" - (* This escape sequence is not supported by IE < 9 - | '\011' -> "\\v" - IE < 9 treats '\v' as 'v' instead of a vertical tab ('\x0B'). - If cross-browser compatibility is a concern, use \x0B instead of \v. - - Another thing to note is that the \v and \0 escapes are not allowed in JSON strings. - *) - | '\000' - when i = l - 1 - || - let next = String.unsafe_get s (i + 1) in - next < '0' || next > '9' -> - f +> "\\0" - | '\\' (* when not utf*) -> f +> "\\\\" - | '\000' .. '\031' | '\127' -> - let c = Char.code c in - f +> "\\x"; - f +> Array.unsafe_get array_conv (c lsr 4); - f +> Array.unsafe_get array_conv (c land 0xf) - | '\128' .. '\255' (* when not utf*) -> - let c = Char.code c in - f +> "\\x"; - f +> Array.unsafe_get array_conv (c lsr 4); - f +> Array.unsafe_get array_conv (c land 0xf) - | '\"' -> f +> "\\\"" (* quote*) - | _ -> f +> Array.unsafe_get array_str1 (Char.code c) - done - in - f +> "\""; - pp_raw_string f (*~utf*) s; - f +> "\"" - -let escape_to_string s = - let buf = Ext_buffer.create (String.length s * 2) in - escape_to_buffer buf s; - Ext_buffer.contents buf - -let pp_string f s = P.string f (escape_to_string s) -(* let _best_string_quote s = - let simple = ref 0 in - let double = ref 0 in - for i = 0 to String.length s - 1 do - match s.[i] with - | '\'' -> incr simple - | '"' -> incr double - | _ -> () - done; - if !simple < !double - then '\'' - else '"' *) diff --git a/jscomp/core/js_dump_string.mli b/jscomp/core/js_dump_string.mli deleted file mode 100644 index ee85147..0000000 --- a/jscomp/core/js_dump_string.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Make sure the escaped string conforms to - JS lexing convention -*) -val escape_to_string : string -> string - -val pp_string : Ext_pp.t -> string -> unit diff --git a/jscomp/core/js_exp_make.ml b/jscomp/core/js_exp_make.ml deleted file mode 100644 index e462d6b..0000000 --- a/jscomp/core/js_exp_make.ml +++ /dev/null @@ -1,1354 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let no_side_effect = Js_analyzer.no_side_effect_expression - -type t = J.expression - -(* - [remove_pure_sub_exp x] - Remove pure part of the expression (minor optimization) - and keep the non-pure part while preserve the semantics - (modulo return value) - It will return None if [x] is pure - *) -let rec remove_pure_sub_exp (x : t) : t option = - match x.expression_desc with - | Var _ | Str _ | Number _ -> None (* Can be refined later *) - | Array_index (a, b) -> - if is_pure_sub_exp a && is_pure_sub_exp b then None else Some x - | Array (xs, _mutable_flag) -> - if Ext_list.for_all xs is_pure_sub_exp then None else Some x - | Seq (a, b) -> ( - match (remove_pure_sub_exp a, remove_pure_sub_exp b) with - | None, None -> None - | Some u, Some v -> Some { x with expression_desc = Seq (u, v) } - (* may still have some simplification*) - | None, (Some _ as v) -> v - | (Some _ as u), None -> u) - | _ -> Some x - -and is_pure_sub_exp (x : t) = remove_pure_sub_exp x = None - -(* let mk ?comment exp : t = - {expression_desc = exp ; comment } *) - -let var ?comment id : t = { expression_desc = Var (Id id); comment } - -(* only used in property access, - Invariant: it should not call an external module .. *) - -let js_global ?comment (v : string) = var ?comment (Ext_ident.create_js v) -let undefined : t = { expression_desc = Undefined {isUnit = false}; comment = None } -let nil : t = { expression_desc = Null; comment = None } - -let call ?comment ~info e0 args : t = - { expression_desc = Call (e0, args, info); comment } - -(* TODO: optimization when es is known at compile time - to be an array -*) -let flat_call ?comment e0 es : t = - { expression_desc = FlatCall (e0, es); comment } - -let tagged_template ?comment callExpr stringArgs valueArgs : t = - { expression_desc = Tagged_template (callExpr, stringArgs, valueArgs); comment } - -let runtime_var_dot ?comment (x : string) (e1 : string) : J.expression = - { - expression_desc = - Var - (Qualified ({ id = Ident.create_persistent x; kind = Runtime; dynamic_import = false }, Some e1)); - comment; - } - -let ml_var_dot ?comment ?(dynamic_import = false) (id : Ident.t) e : J.expression = - { expression_desc = Var (Qualified ({ id; kind = Ml; dynamic_import }, Some e)); comment } - -(** - module as a value - {[ - var http = require("http") - ]} -*) -let external_var_field ?import_attributes ?comment ~external_name:name (id : Ident.t) ~field - ~default : t = - { - expression_desc = - Var (Qualified ({ id; kind = External { name; default; import_attributes }; dynamic_import = false }, Some field)); - comment; - } - -let external_var ?import_attributes ?comment ~external_name (id : Ident.t) : t = - { - expression_desc = - Var - (Qualified - ( { id; kind = External { name = external_name; default = false; import_attributes }; dynamic_import = false }, - None )); - comment; - } - -let ml_module_as_var ?comment ?(dynamic_import = false) (id : Ident.t) : t = - { expression_desc = Var (Qualified ({ id; kind = Ml; dynamic_import }, None)); comment } - -(* Static_index .....................**) -let runtime_call module_name fn_name args = - call ~info:Js_call_info.builtin_runtime_call - (runtime_var_dot module_name fn_name) - args - -let pure_runtime_call module_name fn_name args = - call ~comment:Literals.pure ~info:Js_call_info.builtin_runtime_call - (runtime_var_dot module_name fn_name) - args - -let runtime_ref module_name fn_name = runtime_var_dot module_name fn_name - -let str ?(delim = J.DNone) ?comment txt : t = - { expression_desc = Str { txt; delim }; comment } - -let raw_js_code ?comment info s : t = - { - expression_desc = Raw_js_code { code = String.trim s; code_info = info }; - comment; - } - -let array ?comment mt es : t = { expression_desc = Array (es, mt); comment } -let some_comment = None - -let optional_block e : J.expression = - { expression_desc = Optional_block (e, false); comment = some_comment } - -let optional_not_nest_block e : J.expression = - { expression_desc = Optional_block (e, true); comment = None } - -(** used in normal property - like [e.length], no dependency introduced -*) -let dot ?comment (e0 : t) (e1 : string) : t = - { expression_desc = Static_index (e0, e1, None); comment } - -let module_access (e : t) (name : string) (pos : int32) = - let name = Ext_ident.convert name in - match e.expression_desc with - | Caml_block (l, _, _, _) when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - { expression_desc = Static_index (e, name, Some pos); comment = None } - ) - | _ -> { expression_desc = Static_index (e, name, Some pos); comment = None } - -let make_block ?comment (tag : t) (tag_info : J.tag_info) (es : t list) - (mutable_flag : J.mutable_flag) : t = - { expression_desc = Caml_block (es, mutable_flag, tag, tag_info); comment } - -module L = Literals - -(* ATTENTION: this is relevant to how we encode string, boolean *) -let typeof ?comment (e : t) : t = - match e.expression_desc with - | Number _ | Length _ -> str ?comment L.js_type_number - | Str _ -> str ?comment L.js_type_string - | Array _ -> str ?comment L.js_type_object - | Bool _ -> str ?comment L.js_type_boolean - | _ -> { expression_desc = Typeof e; comment } - -let instanceof ?comment (e0 : t) (e1: t) : t = - { expression_desc = Bin (InstanceOf, e0, e1); comment } - -let is_array (e0 : t) : t = - let f = str "Array.isArray" ~delim:DNoQuotes in - { expression_desc = Call (f, [e0], Js_call_info.ml_full_call); comment=None } - -let new_ ?comment e0 args : t = - { expression_desc = New (e0, Some args); comment } - -let unit : t = { expression_desc = Undefined {isUnit = true}; comment = None } - -(* let math ?comment v args : t = - {comment ; expression_desc = Math(v,args)} *) - -(* we can do constant folding here, but need to make sure the result is consistent - {[ - let f x = string_of_int x - ;; f 3 - ]} - {[ - string_of_int 3 - ]} - Used in [string_of_int] and format "%d" - TODO: optimize -*) - -(* Attention: Shared *mutable state* is evil, - [Js_fun_env.empty] is a mutable state .. -*) - -let ocaml_fun ?comment ?immutable_mask ~return_unit ~async ~oneUnitArg params body : t = - let params = if oneUnitArg then [] else params in - let len = List.length params in - { - expression_desc = - Fun - { - is_method = false; - params; - body; - env = Js_fun_env.make ?immutable_mask len; - return_unit; - async; - }; - comment; - } - -let method_ ?comment ?immutable_mask ~return_unit params body : t = - let len = List.length params in - { - expression_desc = - Fun - { - is_method = true; - params; - body; - env = Js_fun_env.make ?immutable_mask len; - return_unit; - async = false; - }; - comment; - } - -(** ATTENTION: This is coupuled with {!Caml_obj.caml_update_dummy} *) -let dummy_obj ?comment (info : Lam_tag_info.t) : t = - (* TODO: - for record it is [{}] - for other it is [[]] - *) - match info with - | Blk_record _ | Blk_module _ | Blk_constructor _ | Blk_record_inlined _ - | Blk_poly_var _ | Blk_extension | Blk_record_ext _ -> - { comment; expression_desc = Object [] } - | Blk_tuple | Blk_module_export _ -> - { comment; expression_desc = Array ([], Mutable) } - | Blk_some | Blk_some_not_nested | Blk_lazy_general -> assert false - -(* TODO: complete - pure ... -*) -let rec seq ?comment (e0 : t) (e1 : t) : t = - match (e0.expression_desc, e1.expression_desc) with - | ( ( Seq (a, { expression_desc = Number _ | Undefined _ }) - | Seq ({ expression_desc = Number _ | Undefined _ }, a) ), - _ ) -> - seq ?comment a e1 - | _, Seq ({ expression_desc = Number _ | Undefined _ }, a) -> - (* Return value could not be changed*) - seq ?comment e0 a - | _, Seq (a, ({ expression_desc = Number _ | Undefined _ } as v)) -> - (* Return value could not be changed*) - seq ?comment (seq e0 a) v - | (Number _ | Var _ | Undefined _), _ -> e1 - | _ -> { expression_desc = Seq (e0, e1); comment } - -let fuse_to_seq x xs = if xs = [] then x else Ext_list.fold_left xs x seq - -(* let empty_string_literal : t = - {expression_desc = Str (true,""); comment = None} *) - -let zero_int_literal : t = - { expression_desc = Number (Int { i = 0l; c = None }); comment = None } - -let one_int_literal : t = - { expression_desc = Number (Int { i = 1l; c = None }); comment = None } - -let two_int_literal : t = - { expression_desc = Number (Int { i = 2l; c = None }); comment = None } - -let three_int_literal : t = - { expression_desc = Number (Int { i = 3l; c = None }); comment = None } - -let four_int_literal : t = - { expression_desc = Number (Int { i = 4l; c = None }); comment = None } - -let five_int_literal : t = - { expression_desc = Number (Int { i = 5l; c = None }); comment = None } - -let six_int_literal : t = - { expression_desc = Number (Int { i = 6l; c = None }); comment = None } - -let seven_int_literal : t = - { expression_desc = Number (Int { i = 7l; c = None }); comment = None } - -let eight_int_literal : t = - { expression_desc = Number (Int { i = 8l; c = None }); comment = None } - -let nine_int_literal : t = - { expression_desc = Number (Int { i = 9l; c = None }); comment = None } - -let obj_int_tag_literal : t = - { expression_desc = Number (Int { i = 248l; c = None }); comment = None } - -let int ?comment ?c i : t = { expression_desc = Number (Int { i; c }); comment } - -let bigint ?comment sign i : t = { expression_desc = Number (BigInt {positive=sign; value=i}); comment} - -let zero_bigint_literal : t = {expression_desc = Number (BigInt {positive=true; value="0"}); comment = None} - -let small_int i : t = - match i with - | 0 -> zero_int_literal - | 1 -> one_int_literal - | 2 -> two_int_literal - | 3 -> three_int_literal - | 4 -> four_int_literal - | 5 -> five_int_literal - | 6 -> six_int_literal - | 7 -> seven_int_literal - | 8 -> eight_int_literal - | 9 -> nine_int_literal - | 248 -> obj_int_tag_literal - | i -> int (Int32.of_int i) - -let true_ : t = { comment = None; expression_desc = Bool true } -let false_ : t = { comment = None; expression_desc = Bool false } -let bool v = if v then true_ else false_ - -let float ?comment f : t = { expression_desc = Number (Float { f }); comment } - -let zero_float_lit : t = - { expression_desc = Number (Float { f = "0." }); comment = None } - -let float_mod ?comment e1 e2 : J.expression = - { comment; expression_desc = Bin (Mod, e1, e2) } - -let array_index ?comment (e0 : t) (e1 : t) : t = - match (e0.expression_desc, e1.expression_desc) with - | Array (l, _), Number (Int { i; _ }) - (* Float i -- should not appear here *) - when no_side_effect e0 -> ( - match Ext_list.nth_opt l (Int32.to_int i) with - | None -> { expression_desc = Array_index (e0, e1); comment } - | Some x -> x (* FIX #3084*)) - | _ -> { expression_desc = Array_index (e0, e1); comment } - -let array_index_by_int ?comment (e : t) (pos : int32) : t = - match e.expression_desc with - | Array (l, _) (* Float i -- should not appear here *) - | Caml_block (l, _, _, _) - when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - { - expression_desc = Array_index (e, int ?comment pos); - comment = None; - }) - | _ -> { expression_desc = Array_index (e, int ?comment pos); comment = None } - -let record_access (e : t) (name : string) (pos : int32) = - (* let name = Ext_ident.convert name in *) - match e.expression_desc with - | Array (l, _) (* Float i -- should not appear here *) - | Caml_block (l, _, _, _) - when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - { expression_desc = Static_index (e, name, Some pos); comment = None } - ) - | _ -> { expression_desc = Static_index (e, name, Some pos); comment = None } - -(* The same as {!record_access} except tag*) -let inline_record_access = record_access - -let variant_access (e : t) (pos : int32) = - inline_record_access e ("_" ^ Int32.to_string pos) pos - -let cons_access (e : t) (pos : int32) = - inline_record_access e - (match pos with - | 0l -> Literals.hd - | 1l -> Literals.tl - | _ -> "_" ^ Int32.to_string pos) - pos - -let poly_var_tag_access (e : t) = - match e.expression_desc with - | Caml_block (l, _, _, _) when no_side_effect e -> ( - match l with x :: _ -> x | [] -> assert false) - | _ -> - { - expression_desc = Static_index (e, Literals.polyvar_hash, Some 0l); - comment = None; - } - -let poly_var_value_access (e : t) = - match e.expression_desc with - | Caml_block (l, _, _, _) when no_side_effect e -> ( - match l with _ :: v :: _ -> v | _ -> assert false) - | _ -> - { - expression_desc = Static_index (e, Literals.polyvar_value, Some 1l); - comment = None; - } - -let extension_access (e : t) name (pos : int32) : t = - match e.expression_desc with - | Array (l, _) (* Float i -- should not appear here *) - | Caml_block (l, _, _, _) - when no_side_effect e -> ( - match Ext_list.nth_opt l (Int32.to_int pos) with - | Some x -> x - | None -> - let name = - match name with Some n -> n | None -> "_" ^ Int32.to_string pos - in - { expression_desc = Static_index (e, name, Some pos); comment = None } - ) - | _ -> - let name = - match name with Some n -> n | None -> "_" ^ Int32.to_string pos - in - { expression_desc = Static_index (e, name, Some pos); comment = None } - -let string_index ?comment (e0 : t) (e1 : t) : t = - match (e0.expression_desc, e1.expression_desc) with - | Str { txt }, Number (Int { i; _ }) -> - (* Don't optimize {j||j} *) - let i = Int32.to_int i in - if i >= 0 && i < String.length txt then - (* TODO: check exception when i is out of range.. - RangeError? - *) - str (String.make 1 txt.[i]) - else { expression_desc = String_index (e0, e1); comment } - | _ -> { expression_desc = String_index (e0, e1); comment } - -let assign ?comment e0 e1 : t = { expression_desc = Bin (Eq, e0, e1); comment } - -let assign_by_exp (e : t) index value : t = - match e.expression_desc with - | Array _ - (* - Temporary block -- address not held - Optimize cases like this which is really - rare {[ - (ref x) := 3 - ]} - *) - | Caml_block _ - when no_side_effect e && no_side_effect index -> - value - | _ -> - assign { expression_desc = Array_index (e, index); comment = None } value - -let assign_by_int ?comment e0 (index : int32) value = - assign_by_exp e0 (int ?comment index) value - -let record_assign (e : t) (pos : int32) (name : string) (value : t) = - match e.expression_desc with - | Array _ - (* - Temporary block -- address not held - Optimize cases like this which is really - rare {[ - (ref x) := 3 - ]} - *) - | Caml_block _ - when no_side_effect e -> - value - | _ -> - assign - { expression_desc = Static_index (e, name, Some pos); comment = None } - value - -let extension_assign (e : t) (pos : int32) name (value : t) = - match e.expression_desc with - | Array _ - (* - Temporary block -- address not held - Optimize cases like this which is really - rare {[ - (ref x) := 3 - ]} - *) - | Caml_block _ - when no_side_effect e -> - value - | _ -> - assign - { expression_desc = Static_index (e, name, Some pos); comment = None } - value - -(* This is a property access not external module *) - -let array_length ?comment (e : t) : t = - match e.expression_desc with - (* TODO: use array instead? *) - | (Array (l, _) | Caml_block (l, _, _, _)) when no_side_effect e -> - int ?comment (Int32.of_int (List.length l)) - | _ -> { expression_desc = Length (e, Array); comment } - -let string_length ?comment (e : t) : t = - match e.expression_desc with - | Str { txt; delim = DNone } -> int ?comment (Int32.of_int (String.length txt)) - (* No optimization for {j||j}*) - | _ -> { expression_desc = Length (e, String); comment } - -(* TODO: use [Buffer] instead? *) -let bytes_length ?comment (e : t) : t = - match e.expression_desc with - | Array (l, _) -> int ?comment (Int32.of_int (List.length l)) - | _ -> { expression_desc = Length (e, Bytes); comment } - -let function_length ?comment (e : t) : t = - match e.expression_desc with - | Fun { is_method; params } -> - let params_length = List.length params in - int ?comment - (Int32.of_int (if is_method then params_length - 1 else params_length)) - | _ -> { expression_desc = Length (e, Function); comment } - -(** no dependency introduced *) -(* let js_global_dot ?comment (x : string) (e1 : string) : t = - { expression_desc = Static_index (js_global x, e1,None); comment} -*) - -let rec string_append ?comment (e : t) (el : t) : t = - let concat a b ~delim = - { e with expression_desc = Str { txt = a ^ b; delim } } - in - match (e.expression_desc, el.expression_desc) with - | Str { txt = ""}, _ -> el - | _, Str { txt = ""} -> e - | ( Str { txt = a; delim }, - String_append ({ expression_desc = Str { txt = b; delim = delim_ } }, c) ) - when delim = delim_ -> - string_append ?comment (concat a b ~delim) c - | ( String_append (c, { expression_desc = Str { txt = b; delim } }), - Str { txt = a; delim = delim_ } ) - when delim = delim_ -> - string_append ?comment c (concat b a ~delim) - | ( String_append (a, { expression_desc = Str { txt = b; delim } }), - String_append ({ expression_desc = Str { txt = c; delim = delim_ } }, d) ) - when delim = delim_ -> - string_append ?comment (string_append a (concat b c ~delim)) d - | Str { txt = a; delim }, Str { txt = b; delim = delim_ } when delim = delim_ - -> - { (concat a b ~delim) with comment } - | _, _ -> { comment; expression_desc = String_append (e, el) } - -let obj ?comment properties : t = - { expression_desc = Object properties; comment } - -let str_equal (txt0:string) (delim0:External_arg_spec.delim) txt1 delim1 = - if delim0 = delim1 then - if Ext_string.equal txt0 txt1 then Some true - else if Ast_utf8_string.simple_comparison txt0 && Ast_utf8_string.simple_comparison txt1 - then Some false - else None - else None - -let rec triple_equal ?comment (e0 : t) (e1 : t) : t = - match (e0.expression_desc, e1.expression_desc) with - | ( (Null | Undefined _), - (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _) ) - when no_side_effect e1 -> - false_ - | ( (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _), - (Null | Undefined _) ) - when no_side_effect e0 -> - false_ - | Number (Int { i = i0; _ }), Number (Int { i = i1; _ }) -> bool (i0 = i1) - | Optional_block (a, _), Optional_block (b, _) -> triple_equal ?comment a b - | Undefined _, Optional_block _ - | Optional_block _, Undefined _ - | Null, Undefined _ - | Undefined _, Null -> - false_ - | Null, Null | Undefined _, Undefined _ -> true_ - | _ -> { expression_desc = Bin (EqEqEq, e0, e1); comment } - -let bin ?comment (op : J.binop) (e0 : t) (e1 : t) : t = - match (op, e0.expression_desc, e1.expression_desc) with - | EqEqEq, _, _ -> triple_equal ?comment e0 e1 - | Ge, Length (e, _), Number (Int { i = 0l }) when no_side_effect e -> - true_ (* x.length >=0 | [x] is pure -> true*) - | Gt, Length (_, _), Number (Int { i = 0l }) -> - (* [e] is kept so no side effect check needed *) - { expression_desc = Bin (NotEqEq, e0, e1); comment } - | _ -> { expression_desc = Bin (op, e0, e1); comment } - -(* TODO: Constant folding, Google Closure will do that?, - Even if Google Clsoure can do that, we will see how it interact with other - optimizations - We wrap all boolean functions here, since OCaml boolean is a - bit different from Javascript, so that we can change it in the future - - {[ a && (b && c) === (a && b ) && c ]} - is not used: benefit is not clear - | Int_of_boolean e10, Bin(And, {expression_desc = Int_of_boolean e20 }, e3) - -> - and_ ?comment - { e1 with expression_desc - = - J.Int_of_boolean { expression_desc = Bin (And, e10,e20); comment = None} - } - e3 - Note that - {[ "" && 3 ]} - return "" instead of false, so [e1] is indeed useful - optimization if [e1 = e2], then and_ e1 e2 -> e2 - be careful for side effect -*) - -let rec filter_bool (e: t) ~j ~b = match e.expression_desc with - | Bin (And, e1, e2) -> - (match (filter_bool e1 ~j ~b, filter_bool e2 ~j ~b) with - | None, None -> None - | Some e, None - | None, Some e -> Some e - | Some e1, Some e2 -> - Some {e with expression_desc = Bin (And, e1, e2)} ) - | Bin (Or, e1, e2) -> - (match (filter_bool e1 ~j ~b, filter_bool e2 ~j ~b) with - | None, _ | _, None -> - None - | Some e1, Some e2 -> - Some {e with expression_desc = Bin (Or, e1, e2)} ) - | Bin - ( NotEqEq, - {expression_desc = Typeof {expression_desc = Var i}}, - {expression_desc = Str {txt}}) when Js_op_util.same_vident i j -> - if txt <> "bool" - then None - else assert false - | Js_not {expression_desc = - Call ({expression_desc = Str {txt = "Array.isArray"}}, - [{expression_desc = Var i}], _)} when Js_op_util.same_vident i j -> - None - | _ -> Some e - -let and_ ?comment (e1 : t) (e2 : t) : t = - match (e1.expression_desc, e2.expression_desc) with - | Var i, Var j when Js_op_util.same_vident i j -> e1 - | Var i, Bin (And, { expression_desc = Var j; _ }, _) - when Js_op_util.same_vident i j -> - e2 - | Var i, Bin (And, l, ({ expression_desc = Var j; _ } as r)) - when Js_op_util.same_vident i j -> - { e2 with expression_desc = Bin (And, r, l) } - | ( Bin (NotEqEq, { expression_desc = Var i }, { expression_desc = Undefined _ }), - Bin - ( EqEqEq, - { expression_desc = Var j }, - { expression_desc = Str _ | Number _ } ) ) - when Js_op_util.same_vident i j -> - e2 - | ( _, - Bin - ( EqEqEq, - { expression_desc = Var j }, - { expression_desc = Bool b } ) - ) -> - (match filter_bool e1 ~j ~b with - | None -> e2 - | Some e1 -> { expression_desc = Bin (And, e1, e2); comment }) - | _, _ -> { expression_desc = Bin (And, e1, e2); comment } - -let or_ ?comment (e1 : t) (e2 : t) = - match (e1.expression_desc, e2.expression_desc) with - | Var i, Var j when Js_op_util.same_vident i j -> e1 - | Var i, Bin (Or, { expression_desc = Var j; _ }, _) - when Js_op_util.same_vident i j -> - e2 - | Var i, Bin (Or, l, ({ expression_desc = Var j; _ } as r)) - when Js_op_util.same_vident i j -> - { e2 with expression_desc = Bin (Or, r, l) } - | _, _ -> { expression_desc = Bin (Or, e1, e2); comment } - -(* return a value of type boolean *) -(* TODO: - when comparison with Int - it is right that !(x > 3 ) -> x <= 3 *) -let not (e : t) : t = - match e.expression_desc with - | Number (Int { i; _ }) -> bool (i = 0l) - | Js_not e -> e - | Bool b -> if b then false_ else true_ - | Bin (EqEqEq, e0, e1) -> { e with expression_desc = Bin (NotEqEq, e0, e1) } - | Bin (NotEqEq, e0, e1) -> { e with expression_desc = Bin (EqEqEq, e0, e1) } - | Bin (Lt, a, b) -> { e with expression_desc = Bin (Ge, a, b) } - | Bin (Ge, a, b) -> { e with expression_desc = Bin (Lt, a, b) } - | Bin (Le, a, b) -> { e with expression_desc = Bin (Gt, a, b) } - | Bin (Gt, a, b) -> { e with expression_desc = Bin (Le, a, b) } - | _ -> { expression_desc = Js_not e; comment = None } - -let not_empty_branch (x : t) = - match x.expression_desc with - | Number (Int { i = 0l }) | Undefined _ -> false - | _ -> true - -let rec econd ?comment (pred : t) (ifso : t) (ifnot : t) : t = - match (pred.expression_desc, ifso.expression_desc, ifnot.expression_desc) with - | Bool false, _, _ -> ifnot - | Number (Int { i = 0l; _ }), _, _ -> ifnot - | (Number _ | Array _ | Caml_block _), _, _ when no_side_effect pred -> - ifso (* a block can not be false in OCAML, CF - relies on flow inference*) - | Bool true, _, _ -> ifso - | _, Cond (pred1, ifso1, ifnot1), _ - when Js_analyzer.eq_expression ifnot1 ifnot -> - (* {[ - if b then (if p1 then branch_code0 else branch_code1) - else branch_code1 - ]} - is equivalent to - {[ - if b && p1 then branch_code0 else branch_code1 - ]} - *) - econd (and_ pred pred1) ifso1 ifnot - | _, Cond (pred1, ifso1, ifnot1), _ when Js_analyzer.eq_expression ifso1 ifnot - -> - econd (and_ pred (not pred1)) ifnot1 ifnot - | _, _, Cond (pred1, ifso1, ifnot1) when Js_analyzer.eq_expression ifso ifso1 - -> - econd (or_ pred pred1) ifso ifnot1 - | _, _, Cond (pred1, ifso1, ifnot1) when Js_analyzer.eq_expression ifso ifnot1 - -> - econd (or_ pred (not pred1)) ifso ifso1 - | Js_not e, _, _ when not_empty_branch ifnot -> econd ?comment e ifnot ifso - | ( _, - Seq (a, { expression_desc = Undefined _ }), - Seq (b, { expression_desc = Undefined _ }) ) -> - seq (econd ?comment pred a b) undefined - | _ -> - if Js_analyzer.eq_expression ifso ifnot then - if no_side_effect pred then ifso else seq ?comment pred ifso - else { expression_desc = Cond (pred, ifso, ifnot); comment } - -let rec float_equal ?comment (e0 : t) (e1 : t) : t = - match (e0.expression_desc, e1.expression_desc) with - | Number (Int { i = i0; _ }), Number (Int { i = i1 }) -> bool (i0 = i1) - | Undefined _, Undefined _ -> true_ - (* | (Bin(Bor, - {expression_desc = Number(Int {i = 0l; _})}, - ({expression_desc = Caml_block_tag _; _} as a )) - | - Bin(Bor, - ({expression_desc = Caml_block_tag _; _} as a), - {expression_desc = Number (Int {i = 0l; _})})), - Number (Int {i = 0l;}) when e1.comment = None - -> (** (x.tag | 0) === 0 *) - not a *) - | ( ( Bin - ( Bor, - { expression_desc = Number (Int { i = 0l; _ }) }, - ({ expression_desc = Caml_block_tag _; _ } as a) ) - | Bin - ( Bor, - ({ expression_desc = Caml_block_tag _; _ } as a), - { expression_desc = Number (Int { i = 0l; _ }) } ) ), - Number _ ) -> - (* for sure [i <> 0 ]*) - (* since a is integer, if we guarantee there is no overflow - of a - then [a | 0] is a nop unless a is undefined - (which is applicable when applied to tag), - obviously tag can not be overflowed. - if a is undefined, then [ a|0===0 ] is true - while [a === 0 ] is not true - [a|0 === non_zero] is false and [a===non_zero] is false - so we can not eliminate when the tag is zero - *) - float_equal ?comment a e1 - | Number (Float { f = f0; _ }), Number (Float { f = f1 }) when f0 = f1 -> - true_ - | _ -> { expression_desc = Bin (EqEqEq, e0, e1); comment } - -let int_equal = float_equal - -let string_equal ?comment (e0 : t) (e1 : t) : t = - let default () : t = { expression_desc = Bin (EqEqEq, e0, e1); comment } in - match (e0.expression_desc, e1.expression_desc) with - | Str { txt = a0; delim = d0 }, Str { txt = a1; delim = d1 } when d0 = d1 -> - (match str_equal a0 d0 a1 d1 with - | Some b -> bool b - | None -> default ()) - | _, _ -> default () - -let is_type_number ?comment (e : t) : t = - string_equal ?comment (typeof e) (str "number") - -let tag_type = function - | Ast_untagged_variants.String s -> str s ~delim:DStarJ - | Int i -> small_int i - | Float f -> float f - | BigInt i -> - let sign, i = Bigint_utils.parse_bigint i in - bigint sign i - | Bool b -> bool b - | Null -> nil - | Undefined -> undefined - | Untagged IntType -> str "number" - | Untagged FloatType -> str "number" - | Untagged BigintType -> str "bigint" - | Untagged BooleanType -> str "boolean" - | Untagged FunctionType -> str "function" - | Untagged StringType -> str "string" - | Untagged (InstanceType i) -> str (Ast_untagged_variants.Instance.to_string i) ~delim:DNoQuotes - | Untagged ObjectType -> str "object" - | Untagged UnknownType -> - (* TODO: this should not happen *) - assert false - -let rec emit_check (check : t Ast_untagged_variants.DynamicChecks.t) = match check with - | TagType t -> tag_type t - | BinOp(op, x, y) -> - let op = match op with - | EqEqEq -> Js_op.EqEqEq - | NotEqEq -> NotEqEq - | And -> And - | Or -> Or - in - bin op (emit_check x) (emit_check y) - | TypeOf x -> typeof (emit_check x) - | IsInstanceOf (Array, x) -> is_array (emit_check x) - | IsInstanceOf (instance, x) -> - let instance_name = Ast_untagged_variants.Instance.to_string instance in - instanceof (emit_check x) (str instance_name ~delim:DNoQuotes) - | Not x -> not (emit_check x) - | Expr x -> x - -let is_a_literal_case ~literal_cases ~block_cases (e:t) = - let check = Ast_untagged_variants.DynamicChecks.is_a_literal_case ~literal_cases ~block_cases (Expr e) in - emit_check check - -let is_int_tag ?has_null_undefined_other e = - let check = Ast_untagged_variants.DynamicChecks.is_int_tag ?has_null_undefined_other (Expr e) in - emit_check check - -let is_type_string ?comment (e : t) : t = - string_equal ?comment (typeof e) (str "string") - -let is_type_object (e : t) : t = string_equal (typeof e) (str "object") - -(* we are calling [Caml_primitive.primitive_name], since it's under our - control, we should make it follow the javascript name convention, and - call plain [dot] -*) - -let tag ?comment ?(name=Js_dump_lit.tag) e : t = - { expression_desc = Caml_block_tag (e, name); comment } - -(* according to the compiler, [Btype.hash_variant], - it's reduced to 31 bits for hash -*) - -(* TODO: handle arbitrary length of args .. - we can reduce part of the overhead by using - `__js` -- a easy ppx {{ x ##.hh }} - the downside is that no way to swap ocaml/js implementation - for object part, also need encode arity.. - how about x#|getElementById|2| -*) - -(* Note that [lsr] or [bor] are js semantics *) -let rec int32_bor ?comment (e1 : J.expression) (e2 : J.expression) : - J.expression = - match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i = i1 } | Uint i1), Number (Int { i = i2 }) -> - int ?comment (Int32.logor i1 i2) - | _, Bin (Lsr, e2, { expression_desc = Number (Int { i = 0l } | Uint 0l); _ }) - -> - int32_bor e1 e2 - | Bin (Lsr, e1, { expression_desc = Number (Int { i = 0l } | Uint 0l); _ }), _ - -> - int32_bor e1 e2 - | ( Bin (Lsr, _, { expression_desc = Number (Int { i } | Uint i); _ }), - Number (Int { i = 0l } | Uint 0l) ) - when i > 0l -> - (* a >>> 3 | 0 -> a >>> 3 *) - e1 - | ( Bin (Bor, e1, { expression_desc = Number (Int { i = 0l } | Uint 0l); _ }), - Number (Int { i = 0l } | Uint 0l) ) -> - int32_bor e1 e2 - | _ -> { comment; expression_desc = Bin (Bor, e1, e2) } - -(* Arithmatic operations - TODO: distinguish between int and float - TODO: Note that we have to use Int64 to avoid integer overflow, this is fine - since Js only have . - - like code below - {[ - MAX_INT_VALUE - (MAX_INT_VALUE - 100) + 20 - ]} - - {[ - MAX_INT_VALUE - x + 30 - ]} - - check: Re-association: avoid integer overflow -*) -let to_int32 ?comment (e : J.expression) : J.expression = - int32_bor ?comment e zero_int_literal -(* TODO: if we already know the input is int32, [x|0] can be reduced into [x] *) - -let uint32 ?comment n : J.expression = - { expression_desc = Number (Uint n); comment } - -let string_comp (cmp : J.binop) ?comment (e0 : t) (e1 : t) = - match (e0.expression_desc, e1.expression_desc) with - | Str { txt = a0; delim = d0 }, Str { txt = a1; delim = d1 } -> ( - match cmp, str_equal a0 d0 a1 d1 with - | EqEqEq, Some b -> bool b - | NotEqEq, Some b -> bool (b = false) - | _ -> - bin ?comment cmp e0 e1) - | _ -> bin ?comment cmp e0 e1 - -let obj_length ?comment e : t = - to_int32 { expression_desc = Length (e, Caml_block); comment } - -let compare_int_aux (cmp : Lam_compat.comparison) (l : int) r = - match cmp with - | Ceq -> l = r - | Cneq -> l <> r - | Clt -> l < r - | Cgt -> l > r - | Cle -> l <= r - | Cge -> l >= r - -let rec int_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = - match (cmp, e0.expression_desc, e1.expression_desc) with - | _, Number ((Int _ | Uint _) as l), Number ((Int _ | Uint _) as r) -> - let l = - match l with - | Uint l -> Ext_int.int32_unsigned_to_int l - | Int { i = l } -> Int32.to_int l - | _ -> assert false - in - let r = - match r with - | Uint l -> Ext_int.int32_unsigned_to_int l - | Int { i = l } -> Int32.to_int l - | _ -> assert false - in - bool (compare_int_aux cmp l r) - | ( _, - Call - ( { - expression_desc = - Var (Qualified ({ kind = Runtime }, Some "int_compare")); - _; - }, - [ l; r ], - _ ), - Number (Int { i = 0l }) ) -> - int_comp cmp l r (* = 0 > 0 < 0 *) - | ( Ceq, - Call - ( ({ - expression_desc = - Var - (Qualified - (({ id = _; kind = Runtime } as iid), Some "compare")); - _; - } as fn), - ([ _; _ ] as args), - call_info ), - Number (Int { i = 0l }) ) -> - (* This is now generalized for runtime modules - `RuntimeModule.compare x y = 0 ` --> - `RuntimeModule.equal x y` - *) - { - e0 with - expression_desc = - Call - ( { fn with expression_desc = Var (Qualified (iid, Some "equal")) }, - args, - call_info ); - } - | Ceq, Optional_block _, Undefined _ | Ceq, Undefined _, Optional_block _ -> - false_ - | Ceq, _, _ -> int_equal e0 e1 - | Cneq, Optional_block _, Undefined _ - | Cneq, Undefined _, Optional_block _ - | Cneq, Caml_block _, Number _ - | Cneq, Number _, Caml_block _ -> - true_ - | _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 - -let bool_comp (cmp : Lam_compat.comparison) ?comment (e0 : t) (e1 : t) = - match (e0, e1) with - | { expression_desc = Bool l }, { expression_desc = Bool r } -> - bool - (match cmp with - | Ceq -> l = r - | Cneq -> l <> r - | Clt -> l < r - | Cgt -> l > r - | Cle -> l <= r - | Cge -> l >= r) - | { expression_desc = Bool true }, rest - | rest, { expression_desc = Bool false } -> ( - match cmp with - | Clt -> seq rest false_ - | Cge -> seq rest true_ - | Cle | Cgt | Ceq | Cneq -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) - | rest, { expression_desc = Bool true } - | { expression_desc = Bool false }, rest -> ( - match cmp with - | Cle -> seq rest true_ - | Cgt -> seq rest false_ - | Clt | Cge | Ceq | Cneq -> - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1) - | _, _ -> bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 - -let float_comp cmp ?comment e0 e1 = - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 - -let js_comp cmp ?comment e0 e1 = - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 - -let rec int32_lsr ?comment (e1 : J.expression) (e2 : J.expression) : - J.expression = - let aux i1 i = uint32 (Int32.shift_right_logical i1 i) in - match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i = i1 } | Uint i1), Number (Int { i = i2 } | Uint i2) -> - aux i1 (Int32.to_int i2) - | Bin (Lsr, _, _), Number (Int { i = 0l } | Uint 0l) -> - e1 (* TODO: more opportunities here *) - | ( Bin - (Bor, e1, { expression_desc = Number (Int { i = 0l; _ } | Uint 0l); _ }), - Number (Int { i = 0l } | Uint 0l) ) -> - int32_lsr ?comment e1 e2 - | _, _ -> { comment; expression_desc = Bin (Lsr, e1, e2) (* uint32 *) } - -let to_uint32 ?comment (e : J.expression) : J.expression = - int32_lsr ?comment e zero_int_literal - -(* TODO: - we can apply a more general optimization here, - do some algebraic rewerite rules to rewrite [triple_equal] -*) -let rec is_out ?comment (e : t) (range : t) : t = - match (range.expression_desc, e.expression_desc) with - | Number (Int { i = 1l }), Var _ -> - not - (or_ (triple_equal e zero_int_literal) (triple_equal e one_int_literal)) - | ( Number (Int { i = 1l }), - ( Bin - ( Plus, - { expression_desc = Number (Int { i; _ }) }, - ({ expression_desc = Var _; _ } as x) ) - | Bin - ( Plus, - ({ expression_desc = Var _; _ } as x), - { expression_desc = Number (Int { i; _ }) } ) ) ) -> - not - (or_ - (triple_equal x (int (Int32.neg i))) - (triple_equal x (int (Int32.sub Int32.one i)))) - | ( Number (Int { i = 1l }), - Bin - ( Minus, - ({ expression_desc = Var _; _ } as x), - { expression_desc = Number (Int { i; _ }) } ) ) -> - not (or_ (triple_equal x (int (Int32.add i 1l))) (triple_equal x (int i))) - (* (x - i >>> 0 ) > k *) - | ( Number (Int { i = k }), - Bin - ( Minus, - ({ expression_desc = Var _; _ } as x), - { expression_desc = Number (Int { i; _ }) } ) ) -> - or_ (int_comp Cgt x (int (Int32.add i k))) (int_comp Clt x (int i)) - | Number (Int { i = k }), Var _ -> - (* Note that js support [ 1 < x < 3], - we can optimize it into [ not ( 0<= x <= k)] - *) - or_ (int_comp Cgt e (int k)) (int_comp Clt e zero_int_literal) - | ( _, - Bin - ( Bor, - ({ - expression_desc = - ( Bin - ( (Plus | Minus), - { expression_desc = Number (Int { i = _; _ }) }, - { expression_desc = Var _; _ } ) - | Bin - ( (Plus | Minus), - { expression_desc = Var _; _ }, - { expression_desc = Number (Int { i = _; _ }) } ) ); - } as e), - { expression_desc = Number (Int { i = 0l } | Uint 0l); _ } ) ) -> - (* TODO: check correctness *) - is_out ?comment e range - | _, _ -> int_comp ?comment Cgt (to_uint32 e) range - -let rec float_add ?comment (e1 : t) (e2 : t) = - match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i; _ }), Number (Int { i = j; _ }) -> - int ?comment (Int32.add i j) - | _, Number (Int { i = j; c }) when j < 0l -> - float_minus ?comment e1 - { e2 with expression_desc = Number (Int { i = Int32.neg j; c }) } - | ( Bin (Plus, a1, { expression_desc = Number (Int { i = k; _ }) }), - Number (Int { i = j; _ }) ) -> - { comment; expression_desc = Bin (Plus, a1, int (Int32.add k j)) } - (* bin ?comment Plus a1 (int (k + j)) *) - (* TODO remove commented code ?? *) - (* | Bin(Plus, a0 , ({expression_desc = Number (Int a1)} )), *) - (* Bin(Plus, b0 , ({expression_desc = Number (Int b1)} )) *) - (* -> *) - (* bin ?comment Plus a1 (int (a1 + b1)) *) - - (* | _, Bin(Plus, b0, ({expression_desc = Number _} as v)) *) - (* -> *) - (* bin ?comment Plus (bin ?comment Plus e1 b0) v *) - (* | Bin(Plus, a1 , ({expression_desc = Number _} as v)), _ *) - (* | Bin(Plus, ({expression_desc = Number _} as v),a1), _ *) - (* -> *) - (* bin ?comment Plus (bin ?comment Plus a1 e2 ) v *) - (* | Number _, _ *) - (* -> *) - (* bin ?comment Plus e2 e1 *) - | _ -> { comment; expression_desc = Bin (Plus, e1, e2) } - -(* bin ?comment Plus e1 e2 *) -(* associative is error prone due to overflow *) -and float_minus ?comment (e1 : t) (e2 : t) : t = - match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i; _ }), Number (Int { i = j; _ }) -> - int ?comment (Int32.sub i j) - | _ -> { comment; expression_desc = Bin (Minus, e1, e2) } -(* bin ?comment Minus e1 e2 *) - -let unchecked_int32_add ?comment e1 e2 = float_add ?comment e1 e2 -let int32_add ?comment e1 e2 = to_int32 (float_add ?comment e1 e2) - -let offset e1 (offset : int) = - if offset = 0 then e1 else int32_add e1 (small_int offset) - -let int32_minus ?comment e1 e2 : J.expression = - to_int32 (float_minus ?comment e1 e2) - -let unchecked_int32_minus ?comment e1 e2 : J.expression = - float_minus ?comment e1 e2 - -let float_div ?comment e1 e2 = bin ?comment Div e1 e2 -let float_notequal ?comment e1 e2 = bin ?comment NotEqEq e1 e2 - -let int32_asr ?comment e1 e2 : J.expression = - { comment; expression_desc = Bin (Asr, e1, e2) } - -(** Division by zero is undefined behavior*) -let int32_div ~checked ?comment (e1 : t) (e2 : t) : t = - match (e1.expression_desc, e2.expression_desc) with - | Length _, Number (Int { i = 2l } | Uint 2l) -> int32_asr e1 one_int_literal - | e1_desc, Number (Int { i = i1 }) when i1 <> 0l -> ( - match e1_desc with - | Number (Int { i = i0 }) -> int (Int32.div i0 i1) - | _ -> to_int32 (float_div ?comment e1 e2)) - | _, _ -> - if checked then runtime_call Js_runtime_modules.int32 "div" [ e1; e2 ] - else to_int32 (float_div ?comment e1 e2) - -let int32_mod ~checked ?comment e1 (e2 : t) : J.expression = - match e2.expression_desc with - | Number (Int { i }) when i <> 0l -> - { comment; expression_desc = Bin (Mod, e1, e2) } - | _ -> - if checked then runtime_call Js_runtime_modules.int32 "mod_" [ e1; e2 ] - else { comment; expression_desc = Bin (Mod, e1, e2) } - -let float_mul ?comment e1 e2 = bin ?comment Mul e1 e2 - -let int32_lsl ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = - match (e1, e2) with - | ( { expression_desc = Number (Int { i = i0 } | Uint i0) }, - { expression_desc = Number (Int { i = i1 } | Uint i1) } ) -> - int ?comment (Int32.shift_left i0 (Int32.to_int i1)) - | _ -> { comment; expression_desc = Bin (Lsl, e1, e2) } - -let is_pos_pow n = - let exception E in - let rec aux c (n : Int32.t) = - if n <= 0l then -2 - else if n = 1l then c - else if Int32.logand n 1l = 0l then aux (c + 1) (Int32.shift_right n 1) - else raise_notrace E - in - try aux 0 n with E -> -1 - -let int32_mul ?comment (e1 : J.expression) (e2 : J.expression) : J.expression = - match (e1, e2) with - | { expression_desc = Number (Int { i = 0l } | Uint 0l); _ }, x - when Js_analyzer.no_side_effect_expression x -> - zero_int_literal - | x, { expression_desc = Number (Int { i = 0l } | Uint 0l); _ } - when Js_analyzer.no_side_effect_expression x -> - zero_int_literal - | ( { expression_desc = Number (Int { i = i0 }); _ }, - { expression_desc = Number (Int { i = i1 }); _ } ) -> - int (Int32.mul i0 i1) - | e, { expression_desc = Number (Int { i = i0 } | Uint i0); _ } - | { expression_desc = Number (Int { i = i0 } | Uint i0); _ }, e -> - let i = is_pos_pow i0 in - if i >= 0 then int32_lsl e (small_int i) - else - call ?comment ~info:Js_call_info.builtin_runtime_call - (dot (js_global "Math") Literals.imul) - [ e1; e2 ] - | _ -> - call ?comment ~info:Js_call_info.builtin_runtime_call - (dot (js_global "Math") Literals.imul) - [ e1; e2 ] - -let unchecked_int32_mul ?comment e1 e2 : J.expression = - { comment; expression_desc = Bin (Mul, e1, e2) } - -let rec int32_bxor ?comment (e1 : t) (e2 : t) : J.expression = - match (e1.expression_desc, e2.expression_desc) with - | Number (Int { i = i1 }), Number (Int { i = i2 }) -> - int ?comment (Int32.logxor i1 i2) - | _, Bin (Lsr, e2, { expression_desc = Number (Int { i = 0l } | Uint 0l); _ }) - -> - int32_bxor e1 e2 - | Bin (Lsr, e1, { expression_desc = Number (Int { i = 0l } | Uint 0l); _ }), _ - -> - int32_bxor e1 e2 - | _ -> { comment; expression_desc = Bin (Bxor, e1, e2) } - -let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : - J.expression = - match e1.expression_desc with - | Bin (Bor, a, { expression_desc = Number (Int { i = 0l }) }) -> - (* Note that in JS - {[ -1 >>> 0 & 0xffffffff = -1]} is the same as - {[ (-1 >>> 0 | 0 ) & 0xffffff ]} - *) - int32_band a e2 - | _ -> { comment; expression_desc = Bin (Band, e1, e2) } - -(* let int32_bin ?comment op e1 e2 : J.expression = *) -(* {expression_desc = Int32_bin(op,e1, e2); comment} *) - -let bigint_op ?comment op (e1: t) (e2: t) = bin ?comment op e1 e2 - -let bigint_comp (cmp : Lam_compat.comparison) ?comment (e0: t) (e1: t) = - bin ?comment (Lam_compile_util.jsop_of_comp cmp) e0 e1 - -let bigint_div ~checked ?comment (e0: t) (e1: t) = - if checked then - runtime_call Js_runtime_modules.bigint "div" [e0; e1] - else - bigint_op ?comment Div e0 e1 - -let bigint_mod ~checked ?comment (e0: t) (e1: t) = - if checked then - runtime_call Js_runtime_modules.bigint "mod_" [e0; e1] - else - bigint_op ?comment Mod e0 e1 - -(* TODO -- alpha conversion - remember to add parens.. -*) -let of_block ?comment ?e block : t = - let return_unit = false in - (* This case is not hit that much*) - call ~info:Js_call_info.ml_full_call - { - comment; - expression_desc = - Fun - { - is_method = false; - params = []; - body = - (match e with - | None -> block - | Some e -> - Ext_list.append block - [ { J.statement_desc = Return e; comment } ]); - env = Js_fun_env.make 0; - return_unit; - async = false; - }; - } - [] - -let is_null ?comment (x : t) = triple_equal ?comment x nil -let is_undef ?comment x = triple_equal ?comment x undefined - -let for_sure_js_null_undefined (x : t) = - match x.expression_desc with Null | Undefined _ -> true | _ -> false - -let is_null_undefined ?comment (x : t) : t = - match x.expression_desc with - | Null | Undefined _ -> true_ - | Number _ | Array _ | Caml_block _ -> false_ - | _ -> { comment; expression_desc = Is_null_or_undefined x } - -let eq_null_undefined_boolean ?comment (a : t) (b : t) = - match (a.expression_desc, b.expression_desc) with - | ( (Null | Undefined _), - (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _) ) -> - false_ - | ( (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _), - (Null | Undefined _) ) -> - false_ - | Null, Undefined _ | Undefined _, Null -> false_ - | Null, Null | Undefined _, Undefined _ -> true_ - | _ -> { expression_desc = Bin (EqEqEq, a, b); comment } - -let neq_null_undefined_boolean ?comment (a : t) (b : t) = - match (a.expression_desc, b.expression_desc) with - | ( (Null | Undefined _), - (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _) ) -> - true_ - | ( (Bool _ | Number _ | Typeof _ | Fun _ | Array _ | Caml_block _), - (Null | Undefined _) ) -> - true_ - | Null, Null | Undefined _, Undefined _ -> false_ - | Null, Undefined _ | Undefined _, Null -> true_ - | _ -> { expression_desc = Bin (NotEqEq, a, b); comment } - -(** TODO: in the future add a flag - to set globalThis -*) -let resolve_and_apply (s : string) (args : t list) : t = - call ~info:Js_call_info.builtin_runtime_call - (runtime_call Js_runtime_modules.external_polyfill "resolve" - [ str (if s.[0] = '?' then String.sub s 1 (String.length s - 1) else s) ]) - args - -let make_exception (s : string) = - pure_runtime_call Js_runtime_modules.exceptions Literals.create [ str s ] diff --git a/jscomp/core/js_exp_make.mli b/jscomp/core/js_exp_make.mli deleted file mode 100644 index a1034bf..0000000 --- a/jscomp/core/js_exp_make.mli +++ /dev/null @@ -1,367 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Creator utilities for the [J] module *) - -type t = J.expression -(** check if a javascript ast is constant - - The better signature might be - {[ - J.expresssion -> Js_output.t - ]} - for exmaple - {[ - e ?print_int(3) : 0 - ---> - if(e){print_int(3)} - ]} -*) - -val remove_pure_sub_exp : t -> t option - -val var : ?comment:string -> J.ident -> t - -val js_global : ?comment:string -> string -> t - -val runtime_var_dot : ?comment:string -> string -> string -> t - -(* val runtime_var_vid : string -> string -> J.vident *) - -val ml_var_dot : ?comment:string -> ?dynamic_import:bool -> Ident.t -> string -> t -(** [ml_var_dot ocaml_module name] -*) - -val external_var_field : - ?import_attributes:External_ffi_types.import_attributes -> - ?comment:string -> - external_name:string -> - Ident.t -> - field:string -> - default:bool -> - t -(** [external_var_field ~external_name ~dot id] - Used in FFI -*) - -val external_var : ?import_attributes:External_ffi_types.import_attributes -> ?comment:string -> external_name:string -> Ident.t -> t - -val ml_module_as_var : ?comment:string -> ?dynamic_import:bool -> Ident.t -> t - -val runtime_call : - string -> (* module_name *) - string -> (* fn_name *) - t list -> (* args *) - t - -val pure_runtime_call : - string -> (* module_name *) - string -> (* fn_name *) - t list -> (* args *) - t - -val runtime_ref : string -> string -> t - -val str : ?delim: J.delim -> ?comment: string -> string -> t - -val ocaml_fun : - ?comment:string -> - ?immutable_mask:bool array -> - return_unit:bool -> - async:bool -> - oneUnitArg:bool -> - J.ident list -> - J.block -> - t - -val method_ : - ?comment:string -> - ?immutable_mask:bool array -> - return_unit:bool -> - J.ident list -> - J.block -> - t - -val econd : ?comment:string -> t -> t -> t -> t - -val int : ?comment:string -> ?c:int -> int32 -> t - -val uint32 : ?comment:string -> int32 -> t - -val small_int : int -> t - -val bigint : ?comment:string -> bool -> string -> t - -val float : ?comment:string -> string -> t - -(* val empty_string_literal : t *) -(* TODO: we can do hash consing for small integers *) -val zero_int_literal : t - -(* val one_int_literal : t *) -val zero_float_lit : t -(* val obj_int_tag_literal : t *) - -val zero_bigint_literal : t - -val is_out : ?comment:string -> t -> t -> t -(** [is_out e range] is equivalent to [e > range or e <0] - -*) - -val dot : ?comment:string -> t -> string -> t - -val module_access : t -> string -> int32 -> t - -val array_length : ?comment:string -> t -> t - -val string_length : ?comment:string -> t -> t - -val bytes_length : ?comment:string -> t -> t - -val function_length : ?comment:string -> t -> t - -val string_append : ?comment:string -> t -> t -> t -(** - When in ES6 mode, we can use Symbol to guarantee its uniquess, - we can not tag [js] object, since it can be frozen -*) - -(* val var_dot : ?comment:string -> Ident.t -> string -> t *) - -(* val bind_var_call : ?comment:string -> Ident.t -> string -> t list -> t *) - -(* val bind_call : ?comment:string -> J.expression -> string -> J.expression list -> t *) -(* val js_global_dot : ?comment:string -> string -> string -> t *) - -val string_index : ?comment:string -> t -> t -> t - -val array_index : ?comment:string -> t -> t -> t - -val array_index_by_int : ?comment:string -> t -> Int32.t -> t - -val record_access : t -> string -> Int32.t -> t - -val inline_record_access : t -> string -> Int32.t -> t - -val variant_access : t -> int32 -> t - -val cons_access : t -> int32 -> t - -val extension_access : t -> string option -> Int32.t -> t - -val record_assign : t -> int32 -> string -> t -> t - -val poly_var_tag_access : t -> t - -val poly_var_value_access : t -> t - -val extension_assign : t -> int32 -> string -> t -> t - -val assign_by_int : ?comment:string -> t -> int32 -> t -> t -(** - [assign_by_int e i v] - if the expression [e] is a temporay block - which has no side effect, - write to it does not really make sense, - optimize it away *) - -val assign_by_exp : t -> t -> t -> t - -val assign : ?comment:string -> t -> t -> t - -val tag_type : Ast_untagged_variants.tag_type -> t - -val emit_check : t Ast_untagged_variants.DynamicChecks.t -> t - -val triple_equal : ?comment:string -> t -> t -> t -(* TODO: reduce [triple_equal] use *) - -val float_equal : ?comment:string -> t -> t -> t - -val int_equal : ?comment:string -> t -> t -> t - -val string_equal : ?comment:string -> t -> t -> t - -val eq_null_undefined_boolean : ?comment:string -> t -> t -> t - -val neq_null_undefined_boolean : ?comment:string -> t -> t -> t - -val is_type_number : ?comment:string -> t -> t - -val is_int_tag : ?has_null_undefined_other:(bool * bool * bool) -> t -> t - -val is_a_literal_case : literal_cases:Ast_untagged_variants.tag_type list -> block_cases:Ast_untagged_variants.block_type list -> t -> t - -val is_type_string : ?comment:string -> t -> t - -val is_type_object : t -> t - -val typeof : ?comment:string -> t -> t -val instanceof : ?comment:string -> t -> t -> t -val is_array : t -> t - -val to_int32 : ?comment:string -> t -> t - -val to_uint32 : ?comment:string -> t -> t - -val unchecked_int32_add : ?comment:string -> t -> t -> t - -val int32_add : ?comment:string -> t -> t -> t - -val offset : t -> int -> t - -val unchecked_int32_minus : ?comment:string -> t -> t -> t - -val int32_minus : ?comment:string -> t -> t -> t - -val int32_mul : ?comment:string -> t -> t -> t - -val unchecked_int32_mul : ?comment:string -> t -> t -> t - -val int32_div : checked:bool -> ?comment:string -> t -> t -> t - -val int32_mod : checked:bool -> ?comment:string -> t -> t -> t - -val int32_lsl : ?comment:string -> t -> t -> t - -val int32_lsr : ?comment:string -> t -> t -> t - -val int32_asr : ?comment:string -> t -> t -> t - -val int32_bxor : ?comment:string -> t -> t -> t - -val int32_band : ?comment:string -> t -> t -> t - -val int32_bor : ?comment:string -> t -> t -> t - -val float_add : ?comment:string -> t -> t -> t - -val float_minus : ?comment:string -> t -> t -> t - -val float_mul : ?comment:string -> t -> t -> t - -val float_div : ?comment:string -> t -> t -> t - -val float_notequal : ?comment:string -> t -> t -> t - -val float_mod : ?comment:string -> t -> t -> t - -val int_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t - -val bool_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t - -val string_comp : Js_op.binop -> ?comment:string -> t -> t -> t - -val float_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t - -val bigint_op : ?comment: string -> Js_op.binop -> t -> t -> t - -val bigint_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t - -val bigint_div : checked:bool -> ?comment:string -> t -> t -> t - -val bigint_mod : checked:bool -> ?comment:string -> t -> t -> t - -val js_comp : Lam_compat.comparison -> ?comment:string -> t -> t -> t - -val not : t -> t - -val call : ?comment:string -> info:Js_call_info.t -> t -> t list -> t - -val flat_call : ?comment:string -> t -> t -> t - -val tagged_template : ?comment:string -> t -> t list -> t list -> t - -val new_ : ?comment:string -> J.expression -> J.expression list -> t - -val array : ?comment:string -> J.mutable_flag -> J.expression list -> t - -val optional_block : J.expression -> J.expression - -val optional_not_nest_block : J.expression -> J.expression - -val make_block : - ?comment:string -> - J.expression -> - (* tag *) - J.tag_info -> - (* tag_info *) - J.expression list -> - J.mutable_flag -> - t - -val seq : ?comment:string -> t -> t -> t - -val fuse_to_seq : t -> t list -> t - -val obj : ?comment:string -> J.property_map -> t - -val true_ : t - -val false_ : t - -val bool : bool -> t - -val unit : t -(** [unit] in ocaml will be compiled into [0] in js *) - -val undefined : t - -val tag : ?comment:string -> ?name:string -> J.expression -> t - -(** Note that this is coupled with how we encode block, if we use the - `Object.defineProperty(..)` since the array already hold the length, - this should be a nop -*) - -val obj_length : ?comment:string -> J.expression -> t - -val and_ : ?comment:string -> t -> t -> t - -val or_ : ?comment:string -> t -> t -> t - -(** we don't expose a general interface, since a general interface is generally not safe *) - -val dummy_obj : ?comment:string -> Lam_tag_info.t -> t -(** used combined with [caml_update_dummy]*) - -val of_block : ?comment:string -> ?e:J.expression -> J.statement list -> t -(** convert a block to expresion by using IIFE *) - -val raw_js_code : ?comment:string -> Js_raw_info.code_info -> string -> t - -val nil : t - -val is_null : ?comment:string -> t -> t - -val is_undef : ?comment:string -> t -> t - -val for_sure_js_null_undefined : J.expression -> bool - -val is_null_undefined : ?comment:string -> t -> t - -val resolve_and_apply : string -> t list -> t - -val make_exception : string -> t diff --git a/jscomp/core/js_fold.ml b/jscomp/core/js_fold.ml deleted file mode 100644 index 506b6d5..0000000 --- a/jscomp/core/js_fold.ml +++ /dev/null @@ -1,298 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open J - -let[@inline] unknown _self _ = _self - -let[@inline] option sub self v = - match v with None -> self | Some x -> sub self x - -let rec list (sub : 'self_type -> 'a -> 'self_type) self v = - match v with - | [] -> self - | x :: xs -> - let self = sub self x in - list sub self xs - -class fold = - object (_self : 'self_type) - method list : 'a. ('self_type -> 'a -> 'self_type) -> 'a list -> 'self_type - = - fun _f_a -> function - | [] -> _self - | _x :: _x_i1 -> - let _self = _f_a _self _x in - let _self = _self#list _f_a _x_i1 in - _self - - method label : label -> 'self_type = unknown _self - - method ident : ident -> 'self_type = unknown _self - - method module_id : module_id -> 'self_type = - fun { id = _x0; kind = _x1 } -> - let _self = _self#ident _x0 in - _self - - method required_modules : required_modules -> 'self_type = - list (fun _self -> _self#module_id) _self - - method vident : vident -> 'self_type = - function - | Id _x0 -> - let _self = _self#ident _x0 in - _self - | Qualified (_x0, _x1) -> - let _self = _self#module_id _x0 in - _self - - method exception_ident : exception_ident -> 'self_type = _self#ident - - method for_ident : for_ident -> 'self_type = _self#ident - - method for_direction : for_direction -> 'self_type = unknown _self - - method property_map : property_map -> 'self_type = - list - (fun _self (_x0, _x1) -> - let _self = _self#expression _x1 in - _self) - _self - - method length_object : length_object -> 'self_type = unknown _self - - method expression_desc : expression_desc -> 'self_type = - function - | Length (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#length_object _x1 in - _self - | Is_null_or_undefined _x0 -> - let _self = _self#expression _x0 in - _self - | String_append (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self - | Bool _ -> _self - | Typeof _x0 -> - let _self = _self#expression _x0 in - _self - | Js_not _x0 -> - let _self = _self#expression _x0 in - _self - | Seq (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self - | Cond (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - let _self = _self#expression _x2 in - _self - | Bin (_x0, _x1, _x2) -> - let _self = _self#expression _x1 in - let _self = _self#expression _x2 in - _self - | FlatCall (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self - | Call (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#expression) _self _x1 in - _self - | Tagged_template (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#expression) _self _x1 in - let _self = list (fun _self -> _self#expression) _self _x2 in - _self - | String_index (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self - | Array_index (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = _self#expression _x1 in - _self - | Static_index (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - _self - | New (_x0, _x1) -> - let _self = _self#expression _x0 in - let _self = - option - (fun _self -> list (fun _self -> _self#expression) _self) - _self _x1 - in - _self - | Var _x0 -> - let _self = _self#vident _x0 in - _self - | Fun {params=x1; body=x2} -> - let _self = list (fun _self -> _self#ident) _self x1 in - let _self = _self#block x2 in - _self - | Str _ -> _self - | Raw_js_code _ -> _self - | Array (_x0, _x1) -> - let _self = list (fun _self -> _self#expression) _self _x0 in - _self - | Optional_block (_x0, _x1) -> - let _self = _self#expression _x0 in - _self - | Caml_block (_x0, _x1, _x2, _x3) -> - let _self = list (fun _self -> _self#expression) _self _x0 in - let _self = _self#expression _x2 in - _self - | Caml_block_tag (_x0, _tag) -> - let _self = _self#expression _x0 in - _self - | Number _ -> _self - | Object _x0 -> - let _self = _self#property_map _x0 in - _self - | Undefined _ -> _self - | Null -> _self - | Await _x0 -> - let _self = _self#expression _x0 in - _self - - method for_ident_expression : for_ident_expression -> 'self_type = - _self#expression - - method finish_ident_expression : finish_ident_expression -> 'self_type = - _self#expression - - method case_clause : case_clause -> 'self_type = - fun { switch_body = _x0; should_break = _x1; comment = _x2 } -> - let _self = _self#block _x0 in - _self - - method string_clause : string_clause -> 'self_type = - fun (_x0, _x1) -> - let _self = _self#case_clause _x1 in - _self - - method int_clause : int_clause -> 'self_type = - fun (_x0, _x1) -> - let _self = _self#case_clause _x1 in - _self - - method statement_desc : statement_desc -> 'self_type = - function - | Block _x0 -> - let _self = _self#block _x0 in - _self - | Variable _x0 -> - let _self = _self#variable_declaration _x0 in - _self - | Exp _x0 -> - let _self = _self#expression _x0 in - _self - | If (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = _self#block _x1 in - let _self = _self#block _x2 in - _self - | While (_x0, _x1, _x2, _x3) -> - let _self = option (fun _self -> _self#label) _self _x0 in - let _self = _self#expression _x1 in - let _self = _self#block _x2 in - _self - | ForRange (_x0, _x1, _x2, _x3, _x4, _x5) -> - let _self = - option (fun _self -> _self#for_ident_expression) _self _x0 - in - let _self = _self#finish_ident_expression _x1 in - let _self = _self#for_ident _x2 in - let _self = _self#for_direction _x3 in - let _self = _self#block _x4 in - _self - | Continue _x0 -> - let _self = _self#label _x0 in - _self - | Break -> _self - | Return _x0 -> - let _self = _self#expression _x0 in - _self - | Int_switch (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#int_clause) _self _x1 in - let _self = option (fun _self -> _self#block) _self _x2 in - _self - | String_switch (_x0, _x1, _x2) -> - let _self = _self#expression _x0 in - let _self = list (fun _self -> _self#string_clause) _self _x1 in - let _self = option (fun _self -> _self#block) _self _x2 in - _self - | Throw _x0 -> - let _self = _self#expression _x0 in - _self - | Try (_x0, _x1, _x2) -> - let _self = _self#block _x0 in - let _self = - option - (fun _self (_x0, _x1) -> - let _self = _self#exception_ident _x0 in - let _self = _self#block _x1 in - _self) - _self _x1 - in - let _self = option (fun _self -> _self#block) _self _x2 in - _self - | Debugger -> _self - - method expression : expression -> 'self_type = - fun { expression_desc = _x0; comment = _x1 } -> - let _self = _self#expression_desc _x0 in - _self - - method statement : statement -> 'self_type = - fun { statement_desc = _x0; comment = _x1 } -> - let _self = _self#statement_desc _x0 in - _self - - method variable_declaration : variable_declaration -> 'self_type = - fun { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> - let _self = _self#ident _x0 in - let _self = option (fun _self -> _self#expression) _self _x1 in - _self - - method block : block -> 'self_type = - list (fun _self -> _self#statement) _self - - method program : program -> 'self_type = - fun { block = _x0; exports = _x1; export_set = _x2 } -> - let _self = _self#block _x0 in - _self - - method deps_program : deps_program -> 'self_type = - fun { program = _x0; modules = _x1; side_effect = _x2 } -> - let _self = _self#program _x0 in - let _self = _self#required_modules _x1 in - _self - end - \ No newline at end of file diff --git a/jscomp/core/js_fold_basic.ml b/jscomp/core/js_fold_basic.ml deleted file mode 100644 index e86029b..0000000 --- a/jscomp/core/js_fold_basic.ml +++ /dev/null @@ -1,66 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let add_lam_module_ident = Lam_module_ident.Hash_set.add - -let create = Lam_module_ident.Hash_set.create - -let super = Js_record_iter.super - -let count_hard_dependencies hard_dependencies = - { - super with - module_id = (fun _ vid -> add_lam_module_ident hard_dependencies vid); - expression = - (fun self x -> - (match Js_block_runtime.check_additional_id x with - | Some id -> - add_lam_module_ident hard_dependencies - (Lam_module_ident.of_runtime id) - | _ -> ()); - super.expression self x); - } - -let calculate_hard_dependencies block = - let hard_dependencies = create 17 in - let obj = count_hard_dependencies hard_dependencies in - obj.block obj block; - hard_dependencies - -(* - Given a set of [variables], count which variables [lam] will depend on - Invariant: - [variables] are parameters which means immutable so that [Call] - will not depend [variables] - -*) -(* let depends_j (lam : J.expression) (variables : Set_ident.t) = - let v = ref Set_ident.empty in - let add id = - if Set_ident.mem variables id then - v := Set_ident.add !v id - in - ignore @@ (new count_deps add ) # expression lam ; - !v -*) diff --git a/jscomp/core/js_fold_basic.mli b/jscomp/core/js_fold_basic.mli deleted file mode 100644 index 826fd32..0000000 --- a/jscomp/core/js_fold_basic.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A module to calculate hard dependency based on JS IR in module [J] *) - -(* val depends_j : J.expression -> Set_ident.t -> Set_ident.t *) - -val calculate_hard_dependencies : J.block -> Lam_module_ident.Hash_set.t -(** TODO: {!Ordered_hash_set} for better ordering *) diff --git a/jscomp/core/js_fun_env.ml b/jscomp/core/js_fun_env.ml deleted file mode 100644 index 6ed8101..0000000 --- a/jscomp/core/js_fun_env.ml +++ /dev/null @@ -1,104 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Make it mutable so that we can do - in-place change without constructing a new one - -- however, it's a design choice -- to be reviewed later -*) - -type immutable_mask = - | All_immutable_and_no_tail_call - (** iff not tailcalled - if tailcalled, in theory, it does not need change params, - for example - {[ - let rec f (n : int ref) = - if !n > 0 then decr n; print_endline "hi" - else f n - ]} - in this case, we still create [Immutable_mask], - since the inline behavior is slightly different - *) - | Immutable_mask of bool array - -type t = { - mutable unbounded : Set_ident.t; - mutable bound_loop_mutable_values : Set_ident.t; - used_mask : bool array; - immutable_mask : immutable_mask; -} -(** Invariant: unused param has to be immutable *) - -let make ?immutable_mask n = - { - unbounded = Set_ident.empty; - used_mask = Array.make n false; - immutable_mask = - (match immutable_mask with - | Some x -> Immutable_mask x - | None -> All_immutable_and_no_tail_call); - bound_loop_mutable_values = Set_ident.empty; - } - -let no_tailcall x = - match x.immutable_mask with - | All_immutable_and_no_tail_call -> [] - | Immutable_mask arr -> Array.to_list arr - -let mark_unused t i = t.used_mask.(i) <- true - -let get_unused t i = t.used_mask.(i) - -(* let get_length t = Array.length t.used_mask *) - -(* let to_string env = - String.concat "," - (Ext_list.map (Set_ident.elements env.unbounded ) - (fun id -> Printf.sprintf "%s/%d" id.name id.stamp) - ) *) - -let get_mutable_params (params : Ident.t list) (x : t) = - match x.immutable_mask with - | All_immutable_and_no_tail_call -> [] - | Immutable_mask xs -> - Ext_list.filter_mapi params (fun p i -> - if not xs.(i) then Some p else None) - -let get_unbounded t = t.unbounded - -let set_unbounded env v = - (* Ext_log.err "%s -- set @." (to_string env); *) - (* if Set_ident.is_empty env.bound then *) - env.unbounded <- v -(* else assert false *) - -let set_lexical_scope env bound_loop_mutable_values = - env.bound_loop_mutable_values <- bound_loop_mutable_values - -let get_lexical_scope env = env.bound_loop_mutable_values - -(* TODO: can be refined if it - only enclose toplevel variables -*) -(* let is_empty t = Set_ident.is_empty t.unbounded *) diff --git a/jscomp/core/js_fun_env.mli b/jscomp/core/js_fun_env.mli deleted file mode 100644 index 5cfa7f6..0000000 --- a/jscomp/core/js_fun_env.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Define type t used in JS IR to collect some meta data - for a function,like its closures, etc -*) - -type t - -val make : ?immutable_mask:bool array -> int -> t - -val no_tailcall : t -> bool list - -(* val is_empty : t -> bool *) - -val set_unbounded : t -> Set_ident.t -> unit - -val set_lexical_scope : t -> Set_ident.t -> unit - -val get_lexical_scope : t -> Set_ident.t - -(* val to_string : t -> string *) - -val mark_unused : t -> int -> unit - -val get_unused : t -> int -> bool - -val get_mutable_params : Ident.t list -> t -> Ident.t list - -val get_unbounded : t -> Set_ident.t - -(* val get_length : t -> int *) diff --git a/jscomp/core/js_implementation.ml b/jscomp/core/js_implementation.ml deleted file mode 100644 index 01b1229..0000000 --- a/jscomp/core/js_implementation.ml +++ /dev/null @@ -1,223 +0,0 @@ -(***********************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. All rights reserved. This file is distributed *) -(* under the terms of the Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -(* adapted by rescript from [driver/compile.ml] for convenience *) - -let module_of_filename outputprefix = - let basename = Filename.basename outputprefix in - let name = - try - let pos = String.index basename '.' in - String.sub basename 0 pos - with Not_found -> basename - in - String.capitalize_ascii name - -let fprintf = Format.fprintf - -let print_if_pipe ppf flag printer arg = - if !flag then fprintf ppf "%a@." printer arg; - arg - -let print_if ppf flag printer arg = if !flag then fprintf ppf "%a@." printer arg - -let output_deps_set name set = - output_string stdout name; - output_string stdout ": "; - Depend.StringSet.iter - (fun s -> - if s <> "" && s.[0] <> '*' then ( - output_string stdout s; - output_string stdout " ")) - set; - output_string stdout "\n" - -let process_with_gentype cmt_file = - if !Clflags.bs_gentype then GenTypeMain.processCmtFile cmt_file - -let after_parsing_sig ppf outputprefix ast = - if !Clflags.only_parse = false then ( - Ast_config.process_sig ast; - if !Js_config.modules then - output_deps_set !Location.input_name - (Ast_extract.read_parse_and_extract Mli ast); - (if !Js_config.binary_ast then - let sourcefile = !Location.input_name in - Binary_ast.write_ast Mli ~sourcefile - ~output:(outputprefix ^ Literals.suffix_iast) - (* to support relocate to another directory *) - ast); - if !Js_config.as_pp then ( - output_string stdout Config.ast_intf_magic_number; - output_value stdout (!Location.input_name : string); - output_value stdout ast); - if !Js_config.syntax_only then Warnings.check_fatal () - else - let modulename = module_of_filename outputprefix in - Lam_compile_env.reset (); - let initial_env = Res_compmisc.initial_env ~modulename () in - Env.set_unit_name modulename; - let tsg = Typemod.transl_signature initial_env ast in - if !Clflags.dump_typedtree then - fprintf ppf "%a@." Printtyped.interface tsg; - let sg = tsg.sig_type in - ignore (Includemod.signatures initial_env sg sg); - Delayed_checks.force_delayed_checks (); - Warnings.check_fatal (); - let deprecated = Builtin_attributes.deprecated_of_sig ast in - let sg = - Env.save_signature ~deprecated sg modulename (outputprefix ^ ".cmi") - in - Typemod.save_signature modulename tsg outputprefix !Location.input_name - initial_env sg; - process_with_gentype (outputprefix ^ ".cmti")) - -let interface ~parser ppf ?outputprefix fname = - let outputprefix = - match outputprefix with - | None -> Config_util.output_prefix fname - | Some x -> x - in - Res_compmisc.init_path (); - parser fname - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name - Mli - |> Ppx_entry.rewrite_signature - |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface - |> print_if_pipe ppf Clflags.dump_source Pprintast.signature - |> after_parsing_sig ppf outputprefix - -let interface_mliast ppf fname setup = - Res_compmisc.init_path (); - Binary_ast.read_ast_exn ~fname Mli setup - |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface - |> print_if_pipe ppf Clflags.dump_source Pprintast.signature - |> after_parsing_sig ppf (Config_util.output_prefix fname) - -let all_module_alias (ast : Parsetree.structure) = - Ext_list.for_all ast (fun { pstr_desc } -> - match pstr_desc with - | Pstr_module { pmb_expr = { pmod_desc = Pmod_ident _ } } -> true - | Pstr_attribute _ -> true - | Pstr_eval _ | Pstr_value _ | Pstr_primitive _ | Pstr_type _ - | Pstr_typext _ | Pstr_exception _ | Pstr_module _ | Pstr_recmodule _ - | Pstr_modtype _ | Pstr_open _ | Pstr_class _ | Pstr_class_type _ - | Pstr_include _ | Pstr_extension _ -> - false) - -let no_export (rest : Parsetree.structure) : Parsetree.structure = - match rest with - | head :: _ -> - let loc = head.pstr_loc in - Ast_helper. - [ - Str.include_ ~loc - (Incl.mk ~loc - (Mod.constraint_ ~loc (Mod.structure ~loc rest) - (Mty.signature ~loc []))); - ] - | _ -> rest - -let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = - if !Clflags.only_parse = false then ( - Js_config.all_module_aliases := - !Clflags.assume_no_mli = Mli_non_exists && all_module_alias ast; - Ast_config.process_str ast; - let ast = if !Js_config.no_export then no_export ast else ast in - if !Js_config.modules then - output_deps_set !Location.input_name - (Ast_extract.read_parse_and_extract Ml ast); - (if !Js_config.binary_ast then - let sourcefile = !Location.input_name in - Binary_ast.write_ast ~sourcefile Ml - ~output:(outputprefix ^ Literals.suffix_ast) - ast); - if !Js_config.as_pp then ( - output_string stdout Config.ast_impl_magic_number; - output_value stdout (!Location.input_name : string); - output_value stdout ast); - if !Js_config.syntax_only then Warnings.check_fatal () - else - let modulename = Ext_filename.module_name outputprefix in - Lam_compile_env.reset (); - let env = Res_compmisc.initial_env ~modulename () in - Env.set_unit_name modulename; - let typedtree, coercion, _, _ = - Typemod.type_implementation_more - ?check_exists:(if !Js_config.force_cmi then None else Some ()) - !Location.input_name outputprefix modulename env ast - in - let typedtree_coercion = (typedtree, coercion) in - print_if ppf Clflags.dump_typedtree - Printtyped.implementation_with_coercion typedtree_coercion; - (if !Js_config.cmi_only then Warnings.check_fatal () - else - let lambda, exports = - Translmod.transl_implementation modulename typedtree_coercion - in - let js_program = - print_if_pipe ppf Clflags.dump_rawlambda Printlambda.lambda lambda - |> Lam_compile_main.compile outputprefix exports - in - if not !Js_config.cmj_only then - Lam_compile_main.lambda_as_module js_program outputprefix); - process_with_gentype (outputprefix ^ ".cmt")) - -let implementation ~parser ppf ?outputprefix fname = - let outputprefix = - match outputprefix with - | None -> Config_util.output_prefix fname - | Some x -> x - in - Res_compmisc.init_path (); - parser fname - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name - Ml - |> Ppx_entry.rewrite_implementation - |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation - |> print_if_pipe ppf Clflags.dump_source Pprintast.structure - |> after_parsing_impl ppf outputprefix - -let implementation_mlast ppf fname setup = - Res_compmisc.init_path (); - Binary_ast.read_ast_exn ~fname Ml setup - |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation - |> print_if_pipe ppf Clflags.dump_source Pprintast.structure - |> after_parsing_impl ppf (Config_util.output_prefix fname) - -let make_structure_item ~ns cunit : Parsetree.structure_item = - let open Ast_helper in - let loc = Location.none in - Str.module_ - (Mb.mk { txt = cunit; loc } - (Mod.ident { txt = Lident (Ext_namespace_encode.make ~ns cunit); loc })) - -(** decoding [.mlmap] - keep in sync {!Bsb_namespace_map_gen.output} -*) -let implementation_map ppf sourcefile = - let () = Js_config.cmj_only := true in - let ichan = open_in_bin sourcefile in - seek_in ichan (Ext_digest.length + 1); - let list_of_modules = Ext_io.rev_lines_of_chann ichan in - close_in ichan; - let ns = Ext_filename.module_name sourcefile in - let ml_ast = - Ext_list.fold_left list_of_modules [] (fun acc line -> - if Ext_string.is_empty line then acc - else make_structure_item ~ns line :: acc) - in - Res_compmisc.init_path (); - ml_ast - |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation - |> print_if_pipe ppf Clflags.dump_source Pprintast.structure - |> after_parsing_impl ppf (Config_util.output_prefix sourcefile) diff --git a/jscomp/core/js_implementation.mli b/jscomp/core/js_implementation.mli deleted file mode 100644 index 7a6f3a9..0000000 --- a/jscomp/core/js_implementation.mli +++ /dev/null @@ -1,62 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** High level compilation module *) - -val interface : - parser:(string -> Parsetree.signature) -> - Format.formatter -> - ?outputprefix:string -> - string -> - unit -(** This module defines a function to compile the program directly into [js] - given [filename] and [outputprefix], - it will be useful if we don't care about bytecode output(generating js only). -*) - -val interface_mliast : - Format.formatter -> string -> ([ `ml | `rescript | `default ] -> unit) -> unit - -(* val after_parsing_impl : - Format.formatter -> - string -> - Parsetree.structure -> - unit *) -(** [after_parsing_impl ppf sourcefile outputprefix ast ] - Make sure you need run {!Res_compmisc.init_path} for set up - Used in eval -*) - -val implementation : - parser:(string -> Parsetree.structure) -> - Format.formatter -> - ?outputprefix:string -> - string -> - unit -(** [implementation ppf sourcefile outprefix] compiles to JS directly *) - -val implementation_mlast : - Format.formatter -> string -> ([ `ml | `rescript | `default ] -> unit) -> unit - -val implementation_map : Format.formatter -> string -> unit diff --git a/jscomp/core/js_long.ml b/jscomp/core/js_long.ml deleted file mode 100644 index 9e4e347..0000000 --- a/jscomp/core/js_long.ml +++ /dev/null @@ -1,160 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -type int64_call = J.expression list -> J.expression - -let int64_call (fn : string) args = - E.runtime_call Js_runtime_modules.int64 fn args - -(* below should not depend on layout *) - -let of_const (v : Int64.t) = - match v with - | 0L -> E.runtime_var_dot Js_runtime_modules.int64 "zero" - | 1L -> E.runtime_var_dot Js_runtime_modules.int64 "one" - | -1L -> E.runtime_var_dot Js_runtime_modules.int64 "neg_one" - | 9223372036854775807L -> E.runtime_var_dot Js_runtime_modules.int64 "max_int" - | -9223372036854775808L -> - E.runtime_var_dot Js_runtime_modules.int64 "min_int" - | _ -> - let unsigned_lo = E.uint32 (Int64.to_int32 v) in - let hi = E.int (Int64.to_int32 (Int64.shift_right v 32)) in - E.array Immutable [ hi; unsigned_lo ] -(* Assume the encoding of Int64 *) - -let to_int32 args = int64_call "to_int32" args - -(* let get_lo x = E.array_index_by_int x 1l *) -(* E.to_int32 @@ get_lo (Ext_list.singleton_exn args) *) - -let of_int32 (args : J.expression list) = - match args with - | [ { expression_desc = Number (Int { i }); _ } ] -> - of_const (Int64.of_int32 i) - | _ -> int64_call "of_int32" args - -let comp (cmp : Lam_compat.comparison) args = - E.runtime_call Js_runtime_modules.caml_primitive - (match cmp with - | Ceq -> "i64_eq" - | Cneq -> "i64_neq" - | Clt -> "i64_lt" - | Cgt -> "i64_gt" - | Cle -> "i64_le" - | Cge -> "i64_ge") - args - -let min args = E.runtime_call Js_runtime_modules.caml_primitive "i64_min" args - -let max args = E.runtime_call Js_runtime_modules.caml_primitive "i64_max" args - -let neg args = int64_call "neg" args - -let add args = int64_call "add" args - -let sub args = int64_call "sub" args - -let mul args = int64_call "mul" args - -let div args = int64_call "div" args - -(** Note if operands are not pure, we need hold shared value, - which is a statement [var x = ... ; x ], it does not fit - current pipe-line fall back to a function call -*) -let bit_op (* op : E.t -> E.t -> E.t*) runtime_call args = - int64_call runtime_call args - -(*disable optimizations relying on int64 representations - this maybe outdated when we switch to bigint -*) -(* match args with - | [l;r] -> - (* Int64 is a block in ocaml, a little more conservative in inlining *) - if Js_analyzer.is_okay_to_duplicate l && - Js_analyzer.is_okay_to_duplicate r then - make ~lo:(op (get_lo l) (get_lo r)) - ~hi:(op (get_hi l) (get_hi r)) - else - | _ -> assert false *) - -let xor = bit_op "xor" - -let or_ = bit_op "or_" - -let and_ = bit_op "and_" - -let lsl_ args = int64_call "lsl_" args - -let lsr_ args = int64_call "lsr_" args - -let asr_ args = int64_call "asr_" args - -let mod_ args = int64_call "mod_" args - -let swap args = int64_call "swap" args - -(* Safe constant propgation - {[ - Number.MAX_SAFE_INTEGER: - Math.pow(2,53) - 1 - ]} - {[ - Number.MIN_SAFE_INTEGER: - - (Math.pow(2,53) -1) - ]} - Note that [Number._SAFE_INTEGER] is in ES6, - we can hard code this number without bringing browser issue. -*) -let of_float (args : J.expression list) = int64_call "of_float" args - -let compare (args : J.expression list) = int64_call "compare" args - -(* let of_string (args : J.expression list) = - int64_call "of_string" args *) -(* let get64 = int64_call "get64" *) -let float_of_bits = int64_call "float_of_bits" - -let bits_of_float = int64_call "bits_of_float" - -let equal_null args = int64_call "equal_null" args - -let equal_undefined args = int64_call "equal_undefined" args - -let equal_nullable args = int64_call "equal_nullable" args - -let to_float (args : J.expression list) = - match args with - (* | [ {expression_desc *) - (* = Caml_block ( *) - (* [lo = *) - (* {expression_desc = Number (Int {i = lo; _}) }; *) - (* hi = *) - (* {expression_desc = Number (Int {i = hi; _}) }; *) - (* ], _, _, _); _ }] *) - (* -> *) - | [ _ ] -> int64_call "to_float" args - | _ -> assert false diff --git a/jscomp/core/js_long.mli b/jscomp/core/js_long.mli deleted file mode 100644 index 8b091a9..0000000 --- a/jscomp/core/js_long.mli +++ /dev/null @@ -1,83 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2016 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type int64_call = J.expression list -> J.expression - -(* val make_const : lo:Int32.t -> hi:Int32.t -> J.expression *) - -val of_const : int64 -> J.expression - -val to_int32 : int64_call - -val of_int32 : int64_call - -val comp : Lam_compat.comparison -> int64_call - -val neg : int64_call - -val add : int64_call - -val sub : int64_call - -val mul : int64_call - -val div : int64_call - -val xor : int64_call - -val mod_ : int64_call - -val lsl_ : int64_call - -val lsr_ : int64_call - -val asr_ : int64_call - -val and_ : int64_call - -val or_ : int64_call - -val swap : int64_call - -val min : int64_call - -val max : int64_call - -val equal_null : int64_call - -val equal_undefined : int64_call - -val equal_nullable : int64_call - -val to_float : int64_call - -val of_float : int64_call - -val compare : int64_call - -(* val of_string : int64_call *) -val float_of_bits : int64_call - -val bits_of_float : int64_call -(* val get64 : int64_call *) diff --git a/jscomp/core/js_name_of_module_id.ml b/jscomp/core/js_name_of_module_id.ml deleted file mode 100644 index 4cb6433..0000000 --- a/jscomp/core/js_name_of_module_id.ml +++ /dev/null @@ -1,203 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -(* -let (=) (x : int) (y:float) = assert false -*) - -#ifdef BROWSER - -let string_of_module_id_in_browser (x : Lam_module_ident.t) = - match x.kind with - | External {name} -> name - | Runtime | Ml -> - "./stdlib/" ^ Ext_string.uncapitalize_ascii x.id.name ^ ".js" - -let string_of_module_id - (id : Lam_module_ident.t) - ~output_dir:(_:string) - (_module_system : Js_packages_info.module_system) - = string_of_module_id_in_browser id - -#else - -let (//) = Filename.concat - - -let fix_path_for_windows : string -> string = - if Ext_sys.is_windows_or_cygwin then Ext_string.replace_backward_slash - else fun s -> s - - -(* dependency is runtime module *) -let get_runtime_module_path - (dep_module_id : Lam_module_ident.t) - (current_package_info : Js_packages_info.t) - (module_system : Js_packages_info.module_system) = - let current_info_query = - Js_packages_info.query_package_infos current_package_info - module_system in - let js_file = - Ext_namespace.js_name_of_modulename dep_module_id.id.name - Little Literals.suffix_js in - match current_info_query with - | Package_not_found -> assert false - | Package_script -> - Js_packages_info.runtime_package_path module_system js_file - | Package_found pkg -> - let dep_path = - "lib" // Js_packages_info.runtime_dir_of_module_system module_system in - if Js_packages_info.is_runtime_package current_package_info then - Ext_path.node_rebase_file - ~from:pkg.rel_path - ~to_:dep_path - js_file - (* TODO: we assume that both [x] and [path] could only be relative path - which is guaranteed by [-bs-package-output] - *) - else - match module_system with - | Commonjs | Esmodule -> - Js_packages_info.runtime_package_path module_system js_file - (* Note we did a post-processing when working on Windows *) - | Es6_global - -> - (* lib/ocaml/xx.cmj -- - HACKING: FIXME - maybe we can caching relative package path calculation or employ package map *) - (* assert false *) - Ext_path.rel_normalized_absolute_path - ~from:( - Js_packages_info.get_output_dir - current_package_info - ~package_dir:(Lazy.force Ext_path.package_dir) - module_system ) - (*Invariant: the package path to rescript, it is used to - calculate relative js path - *) - (match !Js_config.customize_runtime with - | None -> - ((Filename.dirname (Filename.dirname Sys.executable_name)) // dep_path // js_file) - | Some path -> - path //dep_path // js_file - ) - -(* [output_dir] is decided by the command line argument *) -let string_of_module_id - (dep_module_id : Lam_module_ident.t) - ~(output_dir : string ) - (module_system : Js_packages_info.module_system) - : string = - let current_package_info = Js_packages_state.get_packages_info () in - fix_path_for_windows ( - match dep_module_id.kind with - | External {name} -> name (* the literal string for external package *) - (* This may not be enough, - 1. For cross packages, we may need settle - down a single js package - 2. We may need es6 path for dead code elimination - But frankly, very few JS packages have no dependency, - so having plugin may sound not that bad - *) - | Runtime -> - get_runtime_module_path dep_module_id current_package_info module_system - | Ml -> - let current_info_query = - Js_packages_info.query_package_infos - current_package_info - module_system - in - match Lam_compile_env.get_package_path_from_cmj dep_module_id with - | (package_path, dep_package_info, case) -> - - - let dep_info_query = - Js_packages_info.query_package_infos dep_package_info module_system - in - match dep_info_query, current_info_query with - | Package_not_found , _ -> - Bs_exception.error (Missing_ml_dependency dep_module_id.id.name) - | Package_script , Package_found _ -> - Bs_exception.error (Dependency_script_module_dependent_not dep_module_id.id.name) - | (Package_script | Package_found _ ), Package_not_found -> assert false - - | Package_found ({suffix} as pkg), Package_script - -> - let js_file = - Ext_namespace.js_name_of_modulename dep_module_id.id.name case suffix in - pkg.pkg_rel_path // js_file - | Package_found ({suffix } as dep_pkg), - Package_found cur_pkg -> - let js_file = - Ext_namespace.js_name_of_modulename dep_module_id.id.name case suffix in - - if Js_packages_info.same_package_by_name current_package_info dep_package_info then - Ext_path.node_rebase_file - ~from:cur_pkg.rel_path - ~to_:dep_pkg.rel_path - js_file - (* TODO: we assume that both [x] and [path] could only be relative path - which is guaranteed by [-bs-package-output] - *) - else - if Js_packages_info.is_runtime_package dep_package_info then - get_runtime_module_path dep_module_id current_package_info module_system - else - begin match module_system with - | Commonjs | Esmodule -> - dep_pkg.pkg_rel_path // js_file - (* Note we did a post-processing when working on Windows *) - | Es6_global - -> - begin - Ext_path.rel_normalized_absolute_path - ~from:( - Js_packages_info.get_output_dir - current_package_info - ~package_dir:(Lazy.force Ext_path.package_dir) - module_system - ) - (package_path // dep_pkg.rel_path // js_file) - end - end - | Package_script, Package_script - -> - let js_file = - Ext_namespace.js_name_of_modulename dep_module_id.id.name case Literals.suffix_js in - match Config_util.find_opt js_file with - | Some file -> - let basename = Filename.basename file in - let dirname = Filename.dirname file in - Ext_path.node_rebase_file - ~from:( - Ext_path.absolute_cwd_path - output_dir) - ~to_:( - Ext_path.absolute_cwd_path - - dirname) - basename - | None -> - Bs_exception.error (Js_not_found js_file)) - -#endif diff --git a/jscomp/core/js_name_of_module_id.mli b/jscomp/core/js_name_of_module_id.mli deleted file mode 100644 index 2243b94..0000000 --- a/jscomp/core/js_name_of_module_id.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - generate the mdoule path so that it can be spliced here: - {[ - var Xx = require("package/path/to/xx.js") - ]} - Note that it has to be consistent to how it is generated -*) - -val string_of_module_id : - Lam_module_ident.t -> - output_dir:string -> - Js_packages_info.module_system -> - string diff --git a/jscomp/core/js_number.ml b/jscomp/core/js_number.ml deleted file mode 100644 index 55612c6..0000000 --- a/jscomp/core/js_number.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = float - -(* http://www.ecma-international.org/ecma-262/5.1/#sec-7.8.3 - http://caml.inria.fr/pub/docs/manual-ocaml/lex.html - {[ - float-literal ::= [-](0...9){0...9|_}[.{0...9|_}][(e|E)][(e|E)[+|-](0...9){0...9|_}] - ]} - In ocaml, the interpretation of floating-point literals that - fall outside the range of representable floating-point values is undefined. - Also, (_) are accepted - - see https://github.com/ocaml/ocaml/pull/268 that ocaml will have HEXADECIMAL notation - support in 4.3 - - The Hex part is quite different -*) - -let to_string (v : float) = - if v = infinity then "Infinity" - else if v = neg_infinity then "-Infinity" - else if v <> v then "NaN" - else - let vint = - int_of_float v - (* TODO: check if 32-bits will loose some precision *) - in - if float_of_int vint = v then string_of_int vint - else - let s1 = Printf.sprintf "%.12g" v in - if v = float_of_string s1 then s1 - else - let s2 = Printf.sprintf "%.15g" v in - if v = float_of_string s2 then s2 else Printf.sprintf "%.18g" v - -let rec is_hex_format_aux (v : string) cur = - if v.[cur] = '-' || v.[cur] = '+' then is_hex_format_ox v (cur + 1) - else is_hex_format_ox v cur - -and is_hex_format_ox v cur = - v.[cur] = '0' && (v.[cur + 1] = 'x' || v.[cur + 1] = 'X') - -let is_hex_format (v : string) = try is_hex_format_aux v 0 with _ -> false - -(* - call [to_string (float_of_string v)] - directly would loose some precision and lost some information - like '3.0' -> '3' - -*) -let rec aux (v : string) (buf : Buffer.t) i len = - if i >= len then () - else - let x = v.[i] in - if x = '_' then aux v buf (i + 1) len - else if x = '.' && i = len - 1 then () - else ( - Buffer.add_char buf x; - aux v buf (i + 1) len) - -let transform v len = - let buf = Buffer.create len in - let i = ref 0 in - while !i + 1 < len && v.[!i] = '0' && v.[!i + 1] <> '.' do - incr i - done; - aux v buf !i len; - Buffer.contents buf - -let caml_float_literal_to_js_string (float_str : string) : string = - let len = String.length float_str in - if len >= 2 && is_hex_format float_str then - to_string (float_of_string float_str) - else transform float_str len diff --git a/jscomp/core/js_number.mli b/jscomp/core/js_number.mli deleted file mode 100644 index 5c3873a..0000000 --- a/jscomp/core/js_number.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = float - -(* val to_string : t -> string *) - -val caml_float_literal_to_js_string : string -> string diff --git a/jscomp/core/js_of_lam_array.ml b/jscomp/core/js_of_lam_array.ml deleted file mode 100644 index c63d702..0000000 --- a/jscomp/core/js_of_lam_array.ml +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - construct array, - set array, - ref array, - - Also make sure, don't call any primitive array method, i.e [E.array_index_by_int] - - We also need check primitive [caml_make_vect], i.e, - [Caml_primitive['caml_make_vect']] see if it's correct - - [caml_make_vect] - [caml_array_sub] - [caml_array_append] - [caml_array_concat] - [caml_make_float_vect] - [caml_array_blit] - - research: https://developer.mozilla.org/en-US/docs/Web/JavaScript/Typed_arrays - - - *) - -module E = Js_exp_make - -(* Parrayref(u|s) *) -let make_array mt args = E.array mt args - -let set_array e e0 e1 = E.assign (E.array_index e e0) e1 - -let ref_array e e0 = E.array_index e e0 diff --git a/jscomp/core/js_of_lam_array.mli b/jscomp/core/js_of_lam_array.mli deleted file mode 100644 index 14aaba7..0000000 --- a/jscomp/core/js_of_lam_array.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Utilities for creating Array of JS IR *) - -val make_array : J.mutable_flag -> J.expression list -> J.expression -(** create an array *) - -val set_array : J.expression -> J.expression -> J.expression -> J.expression -(** Here we don't care about [array_kind], - In the future, we might used TypedArray for FloatArray -*) - -val ref_array : J.expression -> J.expression -> J.expression diff --git a/jscomp/core/js_of_lam_block.ml b/jscomp/core/js_of_lam_block.ml deleted file mode 100644 index b665462..0000000 --- a/jscomp/core/js_of_lam_block.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -(* TODO: it would be even better, if the [tag_info] contains more information - about immutablility -*) -let make_block mutable_flag (tag_info : Lam_tag_info.t) tag args = - match tag_info with _ -> E.make_block tag tag_info args mutable_flag - -let field (field_info : Lam_compat.field_dbg_info) e (i : int32) = - match field_info with - | Fld_tuple | Fld_array -> - E.array_index_by_int - ?comment:(Lam_compat.str_of_field_info field_info) - e i - | Fld_poly_var_content -> E.poly_var_value_access e - | Fld_poly_var_tag -> E.poly_var_tag_access e - | Fld_record_extension { name } -> E.extension_access e (Some name) i - | Fld_extension -> E.extension_access e None i - | Fld_variant -> E.variant_access e i - | Fld_cons -> E.cons_access e i - | Fld_record_inline { name } -> E.inline_record_access e name i - | Fld_record { name } -> E.record_access e name i - | Fld_module { name } -> E.module_access e name i - -let field_by_exp e i = E.array_index e i - -let set_field (field_info : Lam_compat.set_field_dbg_info) e i e0 = - match field_info with - | Fld_record_extension_set name -> E.extension_assign e i name e0 - | Fld_record_inline_set name | Fld_record_set name -> - E.record_assign e i name e0 - -(* This dynamism commes from oo compilaton, it should not happen in record *) -let set_field_by_exp self index value = E.assign_by_exp self index value diff --git a/jscomp/core/js_of_lam_block.mli b/jscomp/core/js_of_lam_block.mli deleted file mode 100644 index 903baa7..0000000 --- a/jscomp/core/js_of_lam_block.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Utilities for creating block of lambda expression in JS IR *) - -val make_block : - Js_op.mutable_flag -> - Lam_tag_info.t -> - J.expression -> - J.expression list -> - J.expression - -val field : Lam_compat.field_dbg_info -> J.expression -> int32 -> J.expression - -val field_by_exp : J.expression -> J.expression -> J.expression - -val set_field : - Lam_compat.set_field_dbg_info -> - J.expression -> - int32 -> - J.expression -> - J.expression - -val set_field_by_exp : - J.expression -> J.expression -> J.expression -> J.expression diff --git a/jscomp/core/js_of_lam_module.ml b/jscomp/core/js_of_lam_module.ml deleted file mode 100644 index ba59509..0000000 --- a/jscomp/core/js_of_lam_module.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -let make ?comment names (args : J.expression list) = - E.make_block ?comment E.zero_int_literal (Blk_module names) args Immutable diff --git a/jscomp/core/js_of_lam_module.mli b/jscomp/core/js_of_lam_module.mli deleted file mode 100644 index 9fabfad..0000000 --- a/jscomp/core/js_of_lam_module.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val make : ?comment:string -> string list -> J.expression list -> J.expression diff --git a/jscomp/core/js_of_lam_option.ml b/jscomp/core/js_of_lam_option.ml deleted file mode 100644 index 7c2edf1..0000000 --- a/jscomp/core/js_of_lam_option.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -type option_unwrap_time = Static_unwrapped | Runtime_maybe_unwrapped - -(** Another way: - {[ - | Var _ -> - can only bd detected at runtime thing - (E.triple_equal (E.typeof arg) - (E.str "number")) - ]} -*) -let none : J.expression = E.undefined - -let is_none_static (arg : J.expression_desc) = match arg with - | Undefined _ -> true - | _ -> false - -let is_not_none (e : J.expression) : J.expression = - let desc = e.expression_desc in - if is_none_static desc then E.false_ - else - match desc with - | Optional_block _ -> E.true_ - | _ -> E.not (E.triple_equal e none) - -(** - Invrariant: - - optional encoding - - None encoding - - when no argumet is supplied, [undefined] - if we detect that all rest arguments are [null], - we can remove them - - - - avoid duplicate evlauation of [arg] when it - is not a variable - {!Js_ast_util.named_expression} does not help - since we need an expression here, it might be a statement -*) -let val_from_option (arg : J.expression) = - match arg.expression_desc with - | Optional_block (x, _) -> x - | _ -> E.runtime_call Js_runtime_modules.option "valFromOption" [ arg ] - -let get_default_undefined_from_optional (arg : J.expression) : J.expression = - let desc = arg.expression_desc in - if is_none_static desc then E.undefined - else - match desc with - | Optional_block (x, _) -> x (* invariant: option encoding *) - | _ -> - if Js_analyzer.is_okay_to_duplicate arg then - (* FIXME: no need do such inlining*) - E.econd (is_not_none arg) (val_from_option arg) E.undefined - else E.runtime_call Js_runtime_modules.option "option_get" [ arg ] - -let option_unwrap (arg : J.expression) : J.expression = - let desc = arg.expression_desc in - if is_none_static desc then E.undefined - else - match desc with - | Optional_block (x, _) -> E.poly_var_value_access x - (* invariant: option encoding *) - | _ -> E.runtime_call Js_runtime_modules.option "option_unwrap" [ arg ] - -let destruct_optional ~for_sure_none ~for_sure_some ~not_sure - (arg : J.expression) = - let desc = arg.expression_desc in - if is_none_static desc then for_sure_none - else - match desc with - | Optional_block (x, _) -> for_sure_some x - | _ -> not_sure () - -let some = E.optional_block - -let null_to_opt e = E.econd (E.is_null e) none (some e) - -let undef_to_opt e = E.econd (E.is_undef e) none (some e) - -let null_undef_to_opt e = E.econd (E.is_null_undefined e) none (some e) diff --git a/jscomp/core/js_of_lam_option.mli b/jscomp/core/js_of_lam_option.mli deleted file mode 100644 index c09d0f5..0000000 --- a/jscomp/core/js_of_lam_option.mli +++ /dev/null @@ -1,52 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type option_unwrap_time = Static_unwrapped | Runtime_maybe_unwrapped - -val val_from_option : J.expression -> J.expression -(** Given [Some a ], return [a] *) - -val get_default_undefined_from_optional : J.expression -> J.expression -(** Given [Some x] or [None], return [x]*) - -val option_unwrap : J.expression -> J.expression -(** Given [Some (`a x)] or [None], - return [x] *) - -val destruct_optional : - for_sure_none:'a -> - for_sure_some:(J.expression -> 'a) -> - not_sure:(unit -> 'a) -> - J.expression -> - 'a - -val some : J.expression -> J.expression - -val is_not_none : J.expression -> J.expression - -val null_to_opt : J.expression -> J.expression - -val undef_to_opt : J.expression -> J.expression - -val null_undef_to_opt : J.expression -> J.expression diff --git a/jscomp/core/js_of_lam_string.ml b/jscomp/core/js_of_lam_string.ml deleted file mode 100644 index 1ec3f77..0000000 --- a/jscomp/core/js_of_lam_string.ml +++ /dev/null @@ -1,63 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -(* We use module B for string compilation, once the upstream can make changes to the - patten match of range patterns, we can use module [A] which means [char] is [string] in js, - currently, it follows the same patten of ocaml, [char] is [int] -*) - -let const_char (i : int) = E.int ~c:i (Int32.of_int @@ i) - -(* string [s[i]] expects to return a [ocaml_char] *) -let ref_string e e1 = E.string_index e e1 - -(* [s[i]] excepts to return a [ocaml_char] - We use normal array for [bytes] - TODO: we can use [Buffer] in the future -*) -let ref_byte e e0 = E.array_index e e0 - -(* {Bytes.set : bytes -> int -> char -> unit }*) -let set_byte e e0 e1 = E.assign (E.array_index e e0) e1 - -(** - Note that [String.fromCharCode] also works, but it only - work for small arrays, however, for {bytes_to_string} it is likely the bytes - will become big - {[ - String.fromCharCode.apply(null,[87,97]) - "Wa" - String.fromCharCode(87,97) - "Wa" - ]} - This does not work for large arrays - {[ - String.fromCharCode.apply(null, prim = Array[1048576]) - Maxiume call stack size exceeded - ]} -*) -let bytes_to_string e = - E.runtime_call Js_runtime_modules.bytes_ "to_string" [ e ] diff --git a/jscomp/core/js_of_lam_string.mli b/jscomp/core/js_of_lam_string.mli deleted file mode 100644 index eb6ca70..0000000 --- a/jscomp/core/js_of_lam_string.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Utilities to wrap [string] and [bytes] compilation, - - this is isolated, so that we can swap different representation in the future. - [string] is Immutable, so there is not [set_string] method -*) - -val ref_string : J.expression -> J.expression -> J.expression - -val ref_byte : J.expression -> J.expression -> J.expression - -val set_byte : J.expression -> J.expression -> J.expression -> J.expression - -val const_char : int -> J.expression - -val bytes_to_string : J.expression -> J.expression diff --git a/jscomp/core/js_of_lam_tuple.ml b/jscomp/core/js_of_lam_tuple.ml deleted file mode 100644 index fe56bcf..0000000 --- a/jscomp/core/js_of_lam_tuple.ml +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -let make (args : J.expression list) = - E.make_block E.zero_int_literal Blk_tuple args Immutable diff --git a/jscomp/core/js_of_lam_tuple.mli b/jscomp/core/js_of_lam_tuple.mli deleted file mode 100644 index e567a4e..0000000 --- a/jscomp/core/js_of_lam_tuple.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Utilities for compiling lambda tuple into JS IR *) - -val make : J.expression list -> J.expression diff --git a/jscomp/core/js_of_lam_variant.ml b/jscomp/core/js_of_lam_variant.ml deleted file mode 100644 index 89922b9..0000000 --- a/jscomp/core/js_of_lam_variant.ml +++ /dev/null @@ -1,125 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make -module S = Js_stmt_make - -type arg_expression = Splice0 | Splice1 of E.t | Splice2 of E.t * E.t - -(* we need destruct [undefined] when input is optional *) -let eval (arg : J.expression) (dispatches : (string * string) list) : E.t = - if arg == E.undefined then E.undefined - else - match arg.expression_desc with - | Str {txt} -> - let s = Ext_list.assoc_by_string dispatches txt None in - E.str s - | _ -> - E.of_block - [ - S.string_switch arg - (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, - J. - { - switch_body = [ S.return_stmt (E.str r) ]; - should_break = false; - (* FIXME: if true, still print break*) - comment = None; - } ))); - ] - -(* invariant: optional is not allowed in this case *) -(* arg is a polyvar *) - -(** FIXME: - 1. duplicated evaluation of expressions arg - Solution: calcuate the arg once in the beginning - 2. avoid block for branches < 3 - or always? - a === 444? "a" : a==222? "b" -*) -let eval_as_event (arg : J.expression) - (dispatches : (string * string) list option) = - match arg.expression_desc with - | Caml_block ([ { expression_desc = Str {txt} }; cb ], _, _, Blk_poly_var _) - when Js_analyzer.no_side_effect_expression cb -> - let v = - match dispatches with - | Some dispatches -> Ext_list.assoc_by_string dispatches txt None - | None -> txt - in - Splice2 (E.str v, cb) - | _ -> - Splice2 - ( (match dispatches with - | Some dispatches -> - E.of_block - [ - S.string_switch - (E.poly_var_tag_access arg) - (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, - J. - { - switch_body = [ S.return_stmt (E.str r) ]; - should_break = false; - (* FIXME: if true, still print break*) - comment = None; - } ))); - ] - | None -> E.poly_var_tag_access arg), - (* TODO: improve, one dispatch later, - the problem is that we can not create bindings - due to the - *) - E.poly_var_value_access arg ) - -(* we need destruct [undefined] when input is optional *) -let eval_as_int (arg : J.expression) (dispatches : (string * int) list) : E.t = - if arg == E.undefined then E.undefined - else - match arg.expression_desc with - | Str {txt} -> - E.int (Int32.of_int (Ext_list.assoc_by_string dispatches txt None)) - | _ -> - E.of_block - [ - S.string_switch arg - (Ext_list.map dispatches (fun (s, r) -> - ( Ast_untagged_variants.String s, - J. - { - switch_body = - [ S.return_stmt (E.int (Int32.of_int r)) ]; - should_break = false; - (* FIXME: if true, still print break*) - comment = None; - } ))); - ] - -let eval_as_unwrap (arg : J.expression) : E.t = - match arg.expression_desc with - | Caml_block ([ { expression_desc = Number _ }; cb ], _, _, _) -> cb - | _ -> E.poly_var_value_access arg diff --git a/jscomp/core/js_of_lam_variant.mli b/jscomp/core/js_of_lam_variant.mli deleted file mode 100644 index 61b122c..0000000 --- a/jscomp/core/js_of_lam_variant.mli +++ /dev/null @@ -1,39 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* module E = Js_exp_make *) - -type arg_expression = - | Splice0 - | Splice1 of J.expression - | Splice2 of J.expression * J.expression - -val eval : J.expression -> (string * string) list -> J.expression - -val eval_as_event : - J.expression -> (string * string) list option -> arg_expression - -val eval_as_int : J.expression -> (string * int) list -> J.expression - -val eval_as_unwrap : J.expression -> J.expression diff --git a/jscomp/core/js_op.ml b/jscomp/core/js_op.ml deleted file mode 100644 index 9315f73..0000000 --- a/jscomp/core/js_op.ml +++ /dev/null @@ -1,192 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Define some basic types used in JS IR *) - -type binop = - | Eq (* acutally assignment .. - TODO: move it into statement, so that all expressions - are side efffect free (except function calls) - *) - | Or - | And - | EqEqEq - | NotEqEq (* | InstanceOf *) - | Lt - | Le - | Gt - | Ge - | Bor - | Bxor - | Band - | Lsl - | Lsr - | Asr - | Plus - | Minus - | Mul - | Div - | Mod - | Pow - | InstanceOf - -(** - note that we don't need raise [Div_by_zero] in ReScript - - {[ - let add x y = x + y (* | 0 *) - let minus x y = x - y (* | 0 *) - let mul x y = x * y (* caml_mul | Math.imul *) - let div x y = x / y (* caml_div (x/y|0)*) - let imod x y = x mod y (* caml_mod (x%y) (zero_divide)*) - - let bor x y = x lor y (* x | y *) - let bxor x y = x lxor y (* x ^ y *) - let band x y = x land y (* x & y *) - let ilnot y = lnot y (* let lnot x = x lxor (-1) *) - let ilsl x y = x lsl y (* x << y*) - let ilsr x y = x lsr y (* x >>> y | 0 *) - let iasr x y = x asr y (* x >> y *) - ]} - - - Note that js treat unsigned shift 0 bits in a special way - Unsigned shifts convert their left-hand side to Uint32, - signed shifts convert it to Int32. - Shifting by 0 digits returns the converted value. - {[ - function ToUint32(x) { - return x >>> 0; - } - function ToInt32(x) { - return x >> 0; - } - ]} - So in Js, [-1 >>>0] will be the largest Uint32, while [-1>>0] will remain [-1] - and [-1 >>> 0 >> 0 ] will be [-1] -*) -type int_op = - | Bor - | Bxor - | Band - | Lsl - | Lsr - | Asr - | Plus - (* for [+], given two numbers - x + y | 0 - *) - | Minus - (* x - y | 0 *) - | Mul - (* *) - | Div - (* x / y | 0 *) - | Mod -(* x % y *) - -(* https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/Expressions_and_Operators#Bitwise_operators - {[ - ~ - ]} - ~0xff -> -256 - design; make sure each operation type is consistent -*) -type level = Log | Info | Warn | Error - -type kind = Ml | Runtime | External of { name : string; default : bool; import_attributes : External_ffi_types.import_attributes option } - -type property = Lam_compat.let_kind = Strict | Alias | StrictOpt | Variable - -type property_name = Lit of string | Symbol_name - -type 'a access = Getter | Setter - -(* literal char *) -type float_lit = { f : string } [@@unboxed] - -type bigint_lit = { positive: bool; value: string } - -type number = - | Float of float_lit - | Int of { i : int32; c : int option } - | Uint of int32 - | BigInt of bigint_lit - -(* becareful when constant folding +/-, - since we treat it as js nativeint, bitwise operators: - https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators - The operands of all bitwise operators are converted to signed 32-bit integers in two's complement format.' -*) - -type mutable_flag = Mutable | Immutable | NA - -type direction_flag = Upto | Downto | Up - -(* - {[ - let rec x = 1 :: y - and y = 1 :: x - ]} -*) -type recursive_info = SingleRecursive | NonRecursie | NA - -type used_stats = - | Dead_pure - (* only [Dead] should be taken serious, - other status can be converted during - inlining - -- all exported symbols can not be dead - -- once a symbole is called Dead_pure, - it can not be alive anymore, we should avoid iterating it - *) - | Dead_non_pure - (* we still need iterating it, - just its bindings does not make sense any more *) - | Exported (* Once it's exported, shall we change its status anymore? *) - (* In general, we should count in one pass, and eliminate code in another - pass, you can not do it in a single pass, however, some simple - dead code can be detected in a single pass - *) - | Once_pure (* used only once so that, if we do the inlining, it will be [Dead] *) - | Used (**) - | Scanning_pure - | Scanning_non_pure - | NA - -type ident_info = { - (* mutable recursive_info : recursive_info; *) - mutable used_stats : used_stats; -} - -type exports = Ident.t list - -type tag_info = Lam_tag_info.t - -type length_object = Array | String | Bytes | Function | Caml_block - -(** TODO: define constant - for better constant folding *) -(* type constant = *) -(* | Const_int of int *) -(* | Const_ *) diff --git a/jscomp/core/js_op_util.ml b/jscomp/core/js_op_util.ml deleted file mode 100644 index 87997f6..0000000 --- a/jscomp/core/js_op_util.ml +++ /dev/null @@ -1,132 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -(* Refer https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Operator_Precedence - for precedence -*) - -let op_prec (op : Js_op.binop) = - match op with - | Eq -> (1, 13, 1) - | Or -> (3, 3, 3) - | And -> (4, 4, 4) - | EqEqEq | NotEqEq -> (8, 8, 9) - | Gt | Ge | Lt | Le | InstanceOf -> (9, 9, 10) - | Bor -> (5, 5, 5) - | Bxor -> (6, 6, 6) - | Band -> (7, 7, 7) - | Lsl | Lsr | Asr -> (10, 10, 11) - | Plus | Minus -> (11, 11, 12) - | Mul | Div | Mod | Pow -> (12, 12, 13) - -let op_int_prec (op : Js_op.int_op) = - match op with - | Bor -> (5, 5, 5) - | Bxor -> (6, 6, 6) - | Band -> (7, 7, 7) - | Lsl | Lsr | Asr -> (10, 10, 11) - | Plus | Minus -> (11, 11, 12) - | Mul | Div | Mod -> (12, 12, 13) - -let op_str (op : Js_op.binop) = - match op with - | Bor -> "|" - | Bxor -> "^" - | Band -> "&" - | Lsl -> "<<" - | Lsr -> ">>>" - | Asr -> ">>" - | Plus -> "+" - | Minus -> "-" - | Mul -> "*" - | Div -> "/" - | Mod -> "%" - | Pow -> "**" - | Eq -> "=" - | Or -> "||" - | And -> "&&" - | EqEqEq -> "===" - | NotEqEq -> "!==" - | Lt -> "<" - | Le -> "<=" - | Gt -> ">" - | Ge -> ">=" - | InstanceOf -> "instanceof" - -let op_int_str (op : Js_op.int_op) = - match op with - | Bor -> "|" - | Bxor -> "^" - | Band -> "&" - | Lsl -> "<<" - | Lsr -> ">>>" - | Asr -> ">>" - | Plus -> "+" - | Minus -> "-" - | Mul -> "*" - | Div -> "/" - | Mod -> "%" - -let str_of_used_stats x = - match (x : Js_op.used_stats) with - | Js_op.Dead_pure -> "Dead_pure" - | Dead_non_pure -> "Dead_non_pure" - | Exported -> "Exported" - | Once_pure -> "Once_pure" - | Used -> "Used" - | Scanning_pure -> "Scanning_pure" - | Scanning_non_pure -> "Scanning_non_pure" - | NA -> "NA" - -let update_used_stats (ident_info : J.ident_info) used_stats = - match ident_info.used_stats with - | Dead_pure | Dead_non_pure | Exported -> () - | Scanning_pure | Scanning_non_pure | Used | Once_pure | NA -> - ident_info.used_stats <- used_stats - -let same_str_opt (x : string option) (y : string option) = - match (x, y) with - | None, None -> true - | Some x0, Some y0 -> x0 = y0 - | None, Some _ | Some _, None -> false - -let same_vident (x : J.vident) (y : J.vident) = - match (x, y) with - | Id x0, Id y0 -> Ident.same x0 y0 - | Qualified (x, str_opt0), Qualified (y, str_opt1) -> - let same_kind (x : Js_op.kind) (y : Js_op.kind) = - match (x, y) with - | Ml, Ml | Runtime, Runtime -> true - | External { name = u; _ }, External { name = v; _ } -> - u = v (* not comparing Default since we will do it later *) - | _, _ -> false - in - Ident.same x.id y.id && same_kind x.kind y.kind - && same_str_opt str_opt0 str_opt1 - | Id _, Qualified _ | Qualified _, Id _ -> false - -let of_lam_mutable_flag (x : Asttypes.mutable_flag) : Js_op.mutable_flag = - match x with Immutable -> Immutable | Mutable -> Mutable diff --git a/jscomp/core/js_op_util.mli b/jscomp/core/js_op_util.mli deleted file mode 100644 index db11b3e..0000000 --- a/jscomp/core/js_op_util.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Some basic utilties around {!Js_op} module *) - -val op_prec : Js_op.binop -> int * int * int - -val op_str : Js_op.binop -> string - -val op_int_prec : Js_op.int_op -> int * int * int - -val op_int_str : Js_op.int_op -> string - -val str_of_used_stats : Js_op.used_stats -> string - -val update_used_stats : J.ident_info -> Js_op.used_stats -> unit - -val same_vident : J.vident -> J.vident -> bool - -val of_lam_mutable_flag : Asttypes.mutable_flag -> Js_op.mutable_flag diff --git a/jscomp/core/js_output.ml b/jscomp/core/js_output.ml deleted file mode 100644 index b69f426..0000000 --- a/jscomp/core/js_output.ml +++ /dev/null @@ -1,145 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make -module S = Js_stmt_make - -type finished = True | False | Dummy -(* Have no idea, so that when [++] is applied, always use the other *) - -type t = { - block : J.block; - value : J.expression option; - output_finished : finished; -} - -type continuation = Lam_compile_context.continuation - -let make ?value ?(output_finished = False) block = - { block; value; output_finished } - -let dummy = { value = None; block = []; output_finished = Dummy } - -(** This can be merged with - {!output_of_block_and_expression} *) -let output_of_expression (continuation : continuation) (exp : J.expression) - ~(no_effects : bool Lazy.t) = - match continuation with - | EffectCall Not_tail -> - if Lazy.force no_effects then dummy - else { block = []; value = Some exp; output_finished = False } - | Declare (kind, n) -> make [ S.define_variable ~kind n exp ] - | Assign n -> make [ S.assign n exp ] - | EffectCall (Maybe_tail_is_return _) -> - make [ S.return_stmt exp ] ~output_finished:True - | NeedValue _ -> { block = []; value = Some exp; output_finished = False } - -let output_of_block_and_expression (continuation : continuation) - (block : J.block) exp : t = - match continuation with - | EffectCall Not_tail -> make block ~value:exp - | EffectCall (Maybe_tail_is_return _) -> - make (Ext_list.append_one block (S.return_stmt exp)) ~output_finished:True - | Declare (kind, n) -> - make (Ext_list.append_one block (S.define_variable ~kind n exp)) - | Assign n -> make (Ext_list.append_one block (S.assign n exp)) - | NeedValue _ -> make block ~value:exp - -let block_with_opt_expr block (x : J.expression option) : J.block = - match x with - | None -> block - | Some x when Js_analyzer.no_side_effect_expression x -> block - | Some x -> block @ [ S.exp x ] - -let opt_expr_with_block (x : J.expression option) block : J.block = - match x with - | None -> block - | Some x when Js_analyzer.no_side_effect_expression x -> block - | Some x -> S.exp x :: block - -let rec unnest_block (block : J.block) : J.block = - match block with - | [ { statement_desc = Block block } ] -> unnest_block block - | _ -> block - -let output_as_block (x : t) : J.block = - match x with - | { block; value = opt; output_finished } -> - let block = unnest_block block in - if output_finished = True then block else block_with_opt_expr block opt - -let to_break_block (x : t) : J.block * bool = - let block = unnest_block x.block in - match x with - | { output_finished = True; _ } -> (block, false) - (* value does not matter when [finished] is true - TODO: check if it has side efects - *) - | { value = None; output_finished } -> ( - (block, match output_finished with True -> false | False | Dummy -> true)) - | { value = Some _ as opt; _ } -> (block_with_opt_expr block opt, true) - -(** TODO: make everything expression make inlining hard, and code not readable? - 1. readability dpends on how we print the expression - 2. inlining needs generate symbols, which are statements, type mismatch - we need capture [Exp e] - - can we call them all [statement]? statement has no value -*) - -(* | {block = [{statement_desc = Exp e }]; value = None ; _}, _ *) -(* -> *) -(* append { x with block = []; value = Some e} y *) -(* | _ , {block = [{statement_desc = Exp e }]; value = None ; _} *) -(* -> *) -(* append x { y with block = []; value = Some e} *) - -let append_output (x : t) (y : t) : t = - match (x, y) with - (* ATTTENTION: should not optimize [opt_e2], it has to conform to [NeedValue]*) - | { output_finished = True; _ }, _ -> x - | _, { block = []; value = None; output_finished = Dummy } -> x - (* finished = true --> value = E.undefined otherwise would throw*) - | { block = []; value = None; _ }, y -> y - | { block = []; value = Some _; _ }, { block = []; value = None; _ } -> x - | ( { block = []; value = Some e1; _ }, - ({ block = []; value = Some e2; output_finished } as z) ) -> - if Js_analyzer.no_side_effect_expression e1 then z - (* It would optimize cases like [module aliases] - Bigarray, List - *) - else { block = []; value = Some (E.seq e1 e2); output_finished } - (* {block = [S.exp e1]; value = Some e2(\* (E.seq e1 e2) *\); finished} *) - | ( { block = block1; value = opt_e1; _ }, - { block = block2; value = opt_e2; output_finished } ) -> - let block1 = unnest_block block1 in - make - (block1 @ opt_expr_with_block opt_e1 @@ unnest_block block2) - ?value:opt_e2 ~output_finished - -(* Fold right is more efficient *) -let concat (xs : t list) : t = - Ext_list.fold_right xs dummy (fun x acc -> append_output x acc) - -let to_string x = Js_dump.string_of_block (output_as_block x) diff --git a/jscomp/core/js_output.mli b/jscomp/core/js_output.mli deleted file mode 100644 index 28e7641..0000000 --- a/jscomp/core/js_output.mli +++ /dev/null @@ -1,83 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** The intemediate output when compiling lambda into JS IR *) - -(* Hongbo Should we rename this module js_of_lambda since it looks like it's - containing that step -*) - -type finished = True | False | Dummy -(* Have no idea, so that when [++] is applied, always use the other *) - -type t = { - block : J.block; - value : J.expression option; - output_finished : finished; -} - -(** When [finished] is true the block is already terminated, - value does not make sense - [finished] default to false, which is conservative -*) - -val make : ?value:J.expression -> ?output_finished:finished -> J.block -> t - -val output_as_block : t -> J.block - -val to_break_block : t -> J.block * bool -(* the second argument is - [true] means [break] needed - - When we know the output is gonna finished true - we can reduce - {[ - return xx ; - break - ]} - into - {[ - return ; - ]} -*) - -val append_output : t -> t -> t - -val dummy : t - -val output_of_expression : - Lam_compile_context.continuation -> - J.expression -> - (* compiled expression *) - no_effects:bool Lazy.t -> - t - -val output_of_block_and_expression : - Lam_compile_context.continuation -> J.block -> J.expression -> t -(** - needed for instrument [return] statement properly -*) - -val concat : t list -> t - -val to_string : t -> string diff --git a/jscomp/core/js_packages_info.ml b/jscomp/core/js_packages_info.ml deleted file mode 100644 index 64a01e8..0000000 --- a/jscomp/core/js_packages_info.ml +++ /dev/null @@ -1,231 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -type module_system = Ext_module_system.t -(* ignore node_modules, just calcluating relative path *) - -(* ocamlopt could not optimize such simple case..*) -let compatible (dep : module_system) (query : module_system) = - match query with - | Commonjs -> dep = Commonjs - | Esmodule -> dep = Esmodule - | Es6_global -> dep = Es6_global || dep = Esmodule -(* As a dependency Leaf Node, it is the same either [global] or [not] *) - -type package_info = { - module_system : module_system; - path : string; - suffix : string; -} - -type package_name = Pkg_empty | Pkg_runtime | Pkg_normal of string - -let ( // ) = Filename.concat - -(* in runtime lib, [es6] and [es6] are treated the same wway *) -let runtime_dir_of_module_system (ms : module_system) = - match ms with Commonjs -> "js" | Esmodule | Es6_global -> "es6" - -let runtime_package_path (ms : module_system) js_file = - !Bs_version.package_name // "lib" - // runtime_dir_of_module_system ms - // js_file - -type t = { name : package_name; module_systems : package_info list } - -let runtime_package_specs : t = - { - name = Pkg_runtime; - module_systems = - [ - { module_system = Esmodule; path = "lib/es6"; suffix = Literals.suffix_js }; - { module_system = Commonjs; path = "lib/js"; suffix = Literals.suffix_js }; - ]; - } - -(** - populated by the command line -*) -let runtime_test_package_specs : t = { name = Pkg_runtime; module_systems = [] } - -let same_package_by_name (x : t) (y : t) = - match x.name with - | Pkg_empty -> y.name = Pkg_empty - | Pkg_runtime -> y.name = Pkg_runtime - | Pkg_normal s -> ( - match y.name with - | Pkg_normal y -> s = y - | Pkg_empty | Pkg_runtime -> false) - -let is_runtime_package (x : t) = x.name = Pkg_runtime - -let iter (x : t) cb = Ext_list.iter x.module_systems cb - -let map (x : t) cb = Ext_list.map x.module_systems cb - -(* let equal (x : t) ({name; module_systems}) = - x.name = name && - Ext_list.for_all2_no_exn - x.module_systems module_systems - (fun (a0,a1) (b0,b1) -> a0 = b0 && a1 = b1) *) - -(* we don't want force people to use package *) - -(** - TODO: not allowing user to provide such specific package name - For empty package, [-bs-package-output] does not make sense - it is only allowed to generate commonjs file in the same directory -*) -let empty : t = { name = Pkg_empty; module_systems = [] } - -let from_name (name : string) : t = - { name = Pkg_normal name; module_systems = [] } - -let is_empty (x : t) = x.name = Pkg_empty - -let string_of_module_system (ms : module_system) = - match ms with Commonjs -> "CommonJS" | Esmodule -> "ESModule" | Es6_global -> "Es6_global" - -let module_system_of_string package_name : module_system option = - match package_name with - | "commonjs" -> Some Commonjs - | "esmodule" | "es6" -> Some Esmodule - | "es6-global" -> Some Es6_global - | _ -> None - -let dump_package_info (fmt : Format.formatter) - ({ module_system = ms; path = name; suffix } : package_info) = - Format.fprintf fmt "@[%s@ %s@ %s@]" - (string_of_module_system ms) - name - suffix - -let dump_package_name fmt (x : package_name) = - match x with - | Pkg_empty -> Format.fprintf fmt "@empty_pkg@" - | Pkg_normal s -> Format.pp_print_string fmt s - | Pkg_runtime -> Format.pp_print_string fmt "@runtime" - -let dump_packages_info (fmt : Format.formatter) - ({ name; module_systems = ls } : t) = - Format.fprintf fmt "@[%a;@ @[%a@]@]" dump_package_name name - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.pp_print_space fmt ()) - dump_package_info) - ls - -type package_found_info = { - rel_path : string; - pkg_rel_path : string; - suffix : string; -} - -type info_query = - | Package_script - | Package_not_found - | Package_found of package_found_info - -(* Note that package-name has to be exactly the same as - npm package name, otherwise the path resolution will be wrong *) -let query_package_infos ({ name; module_systems } : t) - (module_system : module_system) : info_query = - match name with - | Pkg_empty -> Package_script - | Pkg_normal name -> ( - match - Ext_list.find_first module_systems (fun k -> - compatible k.module_system module_system) - with - | Some k -> - let rel_path = k.path in - let pkg_rel_path = name // rel_path in - Package_found { rel_path; pkg_rel_path; suffix = k.suffix } - | None -> Package_not_found) - | Pkg_runtime -> ( - (*FIXME: [compatible] seems not correct *) - match - Ext_list.find_first module_systems (fun k -> - compatible k.module_system module_system) - with - | Some k -> - let rel_path = k.path in - let pkg_rel_path = !Bs_version.package_name // rel_path in - Package_found { rel_path; pkg_rel_path; suffix = k.suffix } - | None -> Package_not_found) - -let get_js_path (x : t) (module_system : module_system) : string = - match - Ext_list.find_first x.module_systems (fun k -> - compatible k.module_system module_system) - with - | Some k -> k.path - | None -> assert false - -(* for a single pass compilation, [output_dir] - can be cached -*) -let get_output_dir (info : t) ~package_dir module_system = - Filename.concat package_dir (get_js_path info module_system) - -let add_npm_package_path (packages_info : t) (s : string) : t = - if is_empty packages_info then - Bsc_args.bad_arg "please set package name first using -bs-package-name " - else - let handle_module_system module_system = - match module_system_of_string module_system with - | Some x -> x - | None -> Bsc_args.bad_arg ("invalid module system " ^ module_system) - in - let m = - match Ext_string.split ~keep_empty:true s ':' with - | [ path ] -> { module_system = Esmodule; path; suffix = Literals.suffix_js } - | [ module_system; path ] -> - { - module_system = handle_module_system module_system; - path; - suffix = Literals.suffix_js; - } - | [ module_system; path; suffix ] -> - { - module_system = handle_module_system module_system; - path; - suffix; - } - | _ -> Bsc_args.bad_arg ("invalid npm package path: " ^ s) - in - { packages_info with module_systems = m :: packages_info.module_systems } - -(* support es6 modules instead - TODO: enrich ast to support import export - http://www.ecma-international.org/ecma-262/6.0/#sec-imports - For every module, we need [Ident.t] for accessing and [filename] for import, - they are not necessarily the same. - - Es6 modules is not the same with commonjs, we use commonjs currently - (play better with node) - - FIXME: the module order matters? -*) diff --git a/jscomp/core/js_packages_info.mli b/jscomp/core/js_packages_info.mli deleted file mode 100644 index 93beccd..0000000 --- a/jscomp/core/js_packages_info.mli +++ /dev/null @@ -1,80 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type module_system = Ext_module_system.t - -val runtime_dir_of_module_system : module_system -> string - -val runtime_package_path : module_system -> string -> string - -type package_info = { - module_system : module_system; - path : string; - suffix : string; -} - -type t - -val runtime_package_specs : t - -val runtime_test_package_specs : t - -val is_runtime_package : t -> bool - -val same_package_by_name : t -> t -> bool - -val iter : t -> (package_info -> unit) -> unit - -val map : t -> (package_info -> 'a) -> 'a list - -val empty : t - -val from_name : string -> t - -val is_empty : t -> bool - -val dump_packages_info : Format.formatter -> t -> unit - -val add_npm_package_path : t -> string -> t -(** used by command line option - e.g [-bs-package-output commonjs:xx/path] -*) - -type package_found_info = { - rel_path : string; - pkg_rel_path : string; - suffix : string; -} - -type info_query = - | Package_script - | Package_not_found - | Package_found of package_found_info - -val get_output_dir : t -> package_dir:string -> module_system -> string - -val query_package_infos : t -> module_system -> info_query -(** Note here we compare the package info by order - in theory, we can compare it by set semantics -*) diff --git a/jscomp/core/js_packages_state.ml b/jscomp/core/js_packages_state.ml deleted file mode 100644 index 67e8231..0000000 --- a/jscomp/core/js_packages_state.ml +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let packages_info = ref Js_packages_info.empty - -let set_package_name name = - if Js_packages_info.is_empty !packages_info then - packages_info := Js_packages_info.from_name name - else Bsc_args.bad_arg "duplicated flag for -bs-package-name" - -let make_runtime () : unit = - packages_info := Js_packages_info.runtime_package_specs - -let make_runtime_test () : unit = - packages_info := Js_packages_info.runtime_test_package_specs - -let set_package_map module_name = - (* set_package_name name ; - let module_name = Ext_namespace.namespace_of_package_name name in *) - Clflags.dont_record_crc_unit := Some module_name; - Clflags.open_modules := module_name :: !Clflags.open_modules - -let update_npm_package_path s = - packages_info := Js_packages_info.add_npm_package_path !packages_info s - -let get_packages_info () = !packages_info diff --git a/jscomp/core/js_packages_state.mli b/jscomp/core/js_packages_state.mli deleted file mode 100644 index 8062c7c..0000000 --- a/jscomp/core/js_packages_state.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) Hongbo Zhang, 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val set_package_name : string -> unit - -val make_runtime : unit -> unit - -val make_runtime_test : unit -> unit - -val set_package_map : string -> unit - -val get_packages_info : unit -> Js_packages_info.t - -val update_npm_package_path : string -> unit diff --git a/jscomp/core/js_pass_debug.ml b/jscomp/core/js_pass_debug.ml deleted file mode 100644 index 3970aa3..0000000 --- a/jscomp/core/js_pass_debug.ml +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - -#if (defined BROWSER || defined RELEASE) -let dump _ (prog : J.program) = - prog -#else -let log_counter = ref 0 - -let dump name (prog : J.program) = - begin - let () = - if !Js_config.diagnose - then - begin - incr log_counter ; - Ext_log.dwarn ~__POS__ "\n@[[TIME:]%s: %f@]@." name (Sys.time () *. 1000.); - Ext_pervasives.with_file_as_chan - (Ext_filename.new_extension !Location.input_name - (Printf.sprintf ".%02d.%s.jsx" !log_counter name) - ) (fun chan -> Js_dump_program.dump_program prog chan ) - end in - prog - end -#endif - diff --git a/jscomp/core/js_pass_debug.mli b/jscomp/core/js_pass_debug.mli deleted file mode 100644 index 1052769..0000000 --- a/jscomp/core/js_pass_debug.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val dump : string -> J.program -> J.program diff --git a/jscomp/core/js_pass_flatten.ml b/jscomp/core/js_pass_flatten.ml deleted file mode 100644 index 397d2dc..0000000 --- a/jscomp/core/js_pass_flatten.ml +++ /dev/null @@ -1,114 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* open recursion is hard - Take cond for example: - CHECK? Trick semantics difference - super#statement (S.if_ a ([ (\* self#statement *\) (S.exp b) ]) - ~else_:([self#statement (S.exp c)]) - ) -*) -module E = Js_exp_make -module S = Js_stmt_make - -let super = Js_record_map.super - -let flatten_map = - { - super with - statement = - (fun self x -> - match x.statement_desc with - | Exp ({ expression_desc = Seq _; _ } as v) -> - S.block - (List.rev_map - (fun x -> self.statement self x) - (Js_analyzer.rev_flatten_seq v)) - | Exp - { - expression_desc = Caml_block (args, _mutable_flag, _tag, _tag_info); - } -> - S.block - (Ext_list.map args (fun arg -> self.statement self (S.exp arg))) - | Exp { expression_desc = Cond (a, b, c); comment } -> - { - statement_desc = - If - ( a, - [ self.statement self (S.exp b) ], - [ self.statement self (S.exp c) ] ); - comment; - } - | Exp - { - expression_desc = - Bin (Eq, a, ({ expression_desc = Seq _; _ } as v)); - _; - } -> ( - let block = Js_analyzer.rev_flatten_seq v in - match block with - | { statement_desc = Exp last_one; _ } :: rest_rev -> - S.block - (Ext_list.rev_map_append rest_rev - [ self.statement self (S.exp (E.assign a last_one)) ] - (fun x -> self.statement self x)) - (* TODO: here we introduce a block, should avoid it *) - (* super#statement *) - (* (S.block (List.rev_append rest_rev [S.exp (E.assign a last_one)])) *) - | _ -> assert false) - | Return { expression_desc = Cond (a, b, c); comment } -> - { - statement_desc = - If - ( a, - [ self.statement self (S.return_stmt b) ], - [ self.statement self (S.return_stmt c) ] ); - comment; - } - | Return ({ expression_desc = Seq _; _ } as v) -> ( - let block = Js_analyzer.rev_flatten_seq v in - match block with - | { statement_desc = Exp last_one; _ } :: rest_rev -> - super.statement self - (S.block - (Ext_list.rev_map_append rest_rev - [ S.return_stmt last_one ] (fun x -> - self.statement self x))) - | _ -> assert false) - | Block [ x ] -> self.statement self x - | _ -> super.statement self x); - block = - (fun self b -> - match b with - | { statement_desc = Block bs } :: rest -> self.block self (bs @ rest) - | x :: rest -> ( - let st = self.statement self x in - let block = self.block self rest in - match st.statement_desc with - | Block bs -> bs @ block - | _ -> st :: block) - | [] -> []); - } - -let program (x : J.program) = flatten_map.program flatten_map x diff --git a/jscomp/core/js_pass_flatten.mli b/jscomp/core/js_pass_flatten.mli deleted file mode 100644 index e88edf6..0000000 --- a/jscomp/core/js_pass_flatten.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A pass converting nested js statement into a flatten visual appearance - - Note this module is used to convert some nested expressions to flat statements, - in general, it's more human readable, and since it generate flat statements, we can spot - some inline opportunities for the produced statemetns, - (inline) expressions inside a nested expression would generate ugly code. - - Since we are aiming to flatten expressions, we should avoid some smart constructors in {!Js_helper}, - it tries to spit out expression istead of statements if it can -*) - -val program : J.program -> J.program diff --git a/jscomp/core/js_pass_flatten_and_mark_dead.ml b/jscomp/core/js_pass_flatten_and_mark_dead.ml deleted file mode 100644 index 6ff6066..0000000 --- a/jscomp/core/js_pass_flatten_and_mark_dead.ml +++ /dev/null @@ -1,281 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make -module S = Js_stmt_make - -type meta_info = Info of J.ident_info | Recursive - -let super = Js_record_iter.super - -let mark_dead_code (js : J.program) : J.program = - let ident_use_stats : meta_info Hash_ident.t = Hash_ident.create 17 in - let mark_dead = - { - super with - ident = - (fun _ ident -> - match Hash_ident.find_opt ident_use_stats ident with - | None -> - (* First time *) - Hash_ident.add ident_use_stats ident Recursive - (* recursive identifiers *) - | Some Recursive -> () - | Some (Info x) -> Js_op_util.update_used_stats x Used); - variable_declaration = - (fun self vd -> - match vd.ident_info.used_stats with - | Dead_pure -> () - | Dead_non_pure -> ( - match vd.value with - | None -> () - | Some x -> self.expression self x) - | _ -> ( - let ({ ident; ident_info; value; _ } : J.variable_declaration) = - vd - in - let pure = - match value with - | None -> true - | Some x -> - self.expression self x; - Js_analyzer.no_side_effect_expression x - in - let () = - if Set_ident.mem js.export_set ident then - Js_op_util.update_used_stats ident_info Exported - in - match Hash_ident.find_opt ident_use_stats ident with - | Some Recursive -> - Js_op_util.update_used_stats ident_info Used; - Hash_ident.replace ident_use_stats ident (Info ident_info) - | Some (Info _) -> - (* check [camlinternlFormat,box_type] inlined twice - FIXME: seems we have redeclared identifiers - *) - () - (* assert false *) - | None -> - (* First time *) - Hash_ident.add ident_use_stats ident (Info ident_info); - Js_op_util.update_used_stats ident_info - (if pure then Scanning_pure else Scanning_non_pure))); - } - in - mark_dead.program mark_dead js; - Hash_ident.iter ident_use_stats (fun _id (info : meta_info) -> - match info with - | Info ({ used_stats = Scanning_pure } as info) -> - Js_op_util.update_used_stats info Dead_pure - | Info ({ used_stats = Scanning_non_pure } as info) -> - Js_op_util.update_used_stats info Dead_non_pure - | _ -> ()); - js - -(* - when we do optmizations, we might need track it will break invariant - of other optimizations, especially for [mutable] meta data, - for example, this pass will break [closure] information, - it should be done before closure pass (even it does not use closure information) - - Take away, it is really hard to change the code while collecting some information.. - we should always collect info in a single pass - - Note that, we should avoid reuse object, i.e, - {[ - let v = - object - end - ]} - Since user may use `bsc.exe -c xx.ml xy.ml xz.ml` and we need clean up state -*) - -(** we can do here, however, we should - be careful that it can only be done - when it's accessed once and the array is not escaped, - otherwise, we redo the computation, - or even better, we re-order - - {[ - var match = [/* tuple */0,Pervasives.string_of_int(f(1,2,3)),f3(2),arr]; - - var a = match[1]; - - var b = match[2]; - - ]} - - ---> - - {[ - var match$1 = Pervasives.string_of_int(f(1,2,3)); - var match$2 = f3(2); - var match = [/* tuple */0,match$1,match$2,arr]; - var a = match$1; - var b = match$2; - var arr = arr; - ]} - - --> - since match$1 (after match is eliminated) is only called once - {[ - var a = Pervasives.string_of_int(f(1,2,3)); - var b = f3(2); - var arr = arr; - ]} - -*) - -let super = Js_record_map.super - -let add_substitue substitution (ident : Ident.t) (e : J.expression) = - Hash_ident.replace substitution ident e - -let subst_map (substitution : J.expression Hash_ident.t) = - { - super with - statement = - (fun self v -> - match v.statement_desc with - | Variable { ident = _; ident_info = { used_stats = Dead_pure }; _ } -> - { v with statement_desc = Block [] } - | Variable - { - ident = _; - ident_info = { used_stats = Dead_non_pure }; - value = None; - } -> - { v with statement_desc = Block [] } - | Variable - { - ident = _; - ident_info = { used_stats = Dead_non_pure }; - value = Some x; - } -> - { v with statement_desc = Exp x } - | Variable - ({ - ident; - property = Strict | StrictOpt | Alias; - value = - Some - ({ - expression_desc = - Caml_block - ((_ :: _ :: _ as ls), Immutable, tag, tag_info); - } as block); - } as variable) -> ( - (* If we do this, we should prevent incorrect inlning to inline it into an array :) - do it only when block size is larger than one - *) - let _, e, bindings = - Ext_list.fold_left ls (0, [], []) (fun (i, e, acc) x -> - match x.expression_desc with - | Var _ | Number _ | Str _ | J.Bool _ | Undefined _ -> - (* TODO: check the optimization *) - (i + 1, x :: e, acc) - | _ -> - (* tradeoff, - when the block is small, it does not make - sense too much -- - bottomline, when the block size is one, no need to do - this - *) - let v' = self.expression self x in - let match_id = - Ext_ident.create - (ident.name ^ "_" - ^ - match tag_info with - | Blk_module fields -> ( - match Ext_list.nth_opt fields i with - | None -> Printf.sprintf "%d" i - | Some x -> x) - | Blk_record { fields } -> - Ext_array.get_or fields i (fun _ -> - Printf.sprintf "%d" i) - | _ -> Printf.sprintf "%d" i) - in - (i + 1, E.var match_id :: e, (match_id, v') :: acc)) - in - let e = - { - block with - expression_desc = - Caml_block (List.rev e, Immutable, tag, tag_info); - } - in - let () = add_substitue substitution ident e in - (* let bindings = !bindings in *) - let original_statement = - { - v with - statement_desc = Variable { variable with value = Some e }; - } - in - match bindings with - | [] -> original_statement - | _ -> - (* self#add_substitue ident e ; *) - S.block - @@ Ext_list.rev_map_append bindings [ original_statement ] - (fun (id, v) -> S.define_variable ~kind:Strict id v)) - | _ -> super.statement self v); - expression = - (fun self x -> - match x.expression_desc with - | Array_index - ( { expression_desc = Var (Id id) }, - { expression_desc = Number (Int { i; _ }) } ) - | Static_index ({ expression_desc = Var (Id id) }, _, Some i) -> ( - match Hash_ident.find_opt substitution id with - | Some { expression_desc = Caml_block (ls, Immutable, _, _) } -> ( - (* user program can be wrong, we should not - turn a runtime crash into compile time crash : ) - *) - match Ext_list.nth_opt ls (Int32.to_int i) with - | Some - ({ - expression_desc = J.Var _ | Number _ | Str _ | Undefined _; - } as x) -> - x - | None | Some _ -> super.expression self x) - | Some _ | None -> super.expression self x) - | _ -> super.expression self x); - } - -(* Top down or bottom up ?*) -(* A pass to support nullary argument in JS - Nullary information can be done in one pass, - there is no need to add another pass -*) - -let program (js : J.program) = - let obj = subst_map (Hash_ident.create 32) in - let js = obj.program obj js in - mark_dead_code js -(* |> mark_dead_code *) -(* mark dead code twice does have effect in some cases, however, we disabled it - since the benefit is not obvious -*) diff --git a/jscomp/core/js_pass_flatten_and_mark_dead.mli b/jscomp/core/js_pass_flatten_and_mark_dead.mli deleted file mode 100644 index b05a732..0000000 --- a/jscomp/core/js_pass_flatten_and_mark_dead.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A pass to mark some declarations in JS IR as dead code *) - -val program : J.program -> J.program diff --git a/jscomp/core/js_pass_get_used.ml b/jscomp/core/js_pass_get_used.ml deleted file mode 100644 index adb21dc..0000000 --- a/jscomp/core/js_pass_get_used.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let add_use stats id = Hash_ident.add_or_update stats id 1 ~update:succ - -let post_process_stats my_export_set - (defined_idents : J.variable_declaration Hash_ident.t) stats = - Hash_ident.iter defined_idents (fun ident v -> - if Set_ident.mem my_export_set ident then - Js_op_util.update_used_stats v.ident_info Exported - else - let pure = - match v.value with - | None -> false (* can not happen *) - | Some x -> Js_analyzer.no_side_effect_expression x - in - match Hash_ident.find_opt stats ident with - | None -> - Js_op_util.update_used_stats v.ident_info - (if pure then Dead_pure else Dead_non_pure) - | Some num -> - if num = 1 then - Js_op_util.update_used_stats v.ident_info - (if pure then Once_pure else Used)); - defined_idents - -(* Update ident info use cases, it is a non pure function, - it will annotate [program] with some meta data - TODO: Ident Hash could be improved, - since in this case it can not be global? -*) -let super = Js_record_iter.super - -let count_collects (* collect used status*) (stats : int Hash_ident.t) - (* collect all def sites *) - (defined_idents : J.variable_declaration Hash_ident.t) = - { - super with - variable_declaration = - (fun self ({ ident; value; property = _; ident_info = _ } as v) -> - Hash_ident.add defined_idents ident v; - match value with None -> () | Some x -> self.expression self x); - ident = (fun _ id -> add_use stats id); - } - -let get_stats (program : J.program) : J.variable_declaration Hash_ident.t = - let stats : int Hash_ident.t = Hash_ident.create 83 in - let defined_idents : J.variable_declaration Hash_ident.t = - Hash_ident.create 83 - in - let my_export_set = program.export_set in - let obj = count_collects stats defined_idents in - obj.program obj program; - post_process_stats my_export_set defined_idents stats diff --git a/jscomp/core/js_pass_get_used.mli b/jscomp/core/js_pass_get_used.mli deleted file mode 100644 index d58aa8f..0000000 --- a/jscomp/core/js_pass_get_used.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2020 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val get_stats : J.program -> J.variable_declaration Hash_ident.t diff --git a/jscomp/core/js_pass_scope.ml b/jscomp/core/js_pass_scope.ml deleted file mode 100644 index ebeb22c..0000000 --- a/jscomp/core/js_pass_scope.ml +++ /dev/null @@ -1,333 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - - Base line - {[ - for i = 1 to n do (function (i){...}(i)) - done - (* This is okay, since all ocaml follow the lexical scope, - for generrated code too (* TODO: check *) - *) - ]} - - For nested loops - {[ - for i = 0 to n do - for j = 0 to n do - arrr.(j)<- ()=>{ i} - done - done - ]} - Three kind of variables (defined in the loop scope) - 1. loop mutable variables - As long as variables change per iteration, defined in a loop (in the same loop) - and captured by a closure - the loop, iff be lexically scoped - Tailcall parameters are considered defined inside the loop - - unless it's defined - outside all the loops - note that for nested loops, if it's defined - in the outerloop and captured by the inner loop, - it still has to be lexically scoped. - - How do we detect whether it is loop invariant or not - - depend on loop variant - - depend on mutuable valuse - - non pure (function call) - - so we need collect mutable variables - 1. from lambda + loop (for/i) + tailcall params - 2. defined in the loop and can not determine it is invariant - in such cases we can determine it's immutable - 1. const - 2. only depend on immutable values and no function call? - - ## The following would take advantage of nested loops - 2. loop invariant observable varaibles - {[ - var x = (console.log(3), 32) - ]} - 3. loop invariant non-observable variables - - Invariant: - loop invariant (observable or not) variables can not depend on - loop mutable values so that once we detect loop Invariant variables - all its dependency are loop invariant as well, so we can do loop - Invariant code motion. - - TODO: - loop invariant can be layered, it will be loop invariant - in the inner layer while loop variant in the outer layer. - {[ - for i = 0 to 10 do - for j = 10 do - let k0 = param * 100 in (* loop invariant *) - let k1 = i * i in (* inner loop invariant, loop variant *) - let k2 = j * i in (* variant *) - .. - done - done - ]} -*) -type state = { - defined_idents : Set_ident.t; - used_idents : Set_ident.t; - loop_mutable_values : Set_ident.t; - mutable_values : Set_ident.t; - closured_idents : Set_ident.t; - in_loop : bool; -} - -let init_state = - { - defined_idents = Set_ident.empty; - used_idents = Set_ident.empty; - loop_mutable_values = Set_ident.empty; - mutable_values = Set_ident.empty; - closured_idents = Set_ident.empty; - in_loop = false; - } - -let with_in_loop (st : state) b = - if b = st.in_loop then st else { st with in_loop = b } - -let add_loop_mutable_variable (st : state) id = - { - st with - loop_mutable_values = Set_ident.add st.loop_mutable_values id; - mutable_values = Set_ident.add st.mutable_values id; - } - -let add_mutable_variable (st : state) id = - { st with mutable_values = Set_ident.add st.mutable_values id } - -let add_defined_ident (st : state) id = - { st with defined_idents = Set_ident.add st.defined_idents id } - -let add_used_ident (st : state) id = - { st with used_idents = Set_ident.add st.used_idents id } - -let super = Js_record_fold.super - -let record_scope_pass = - { - super with - expression = - (fun self state x -> - match x.expression_desc with - | Fun {params; body; env} -> - (* Function is the only place to introduce a new scope in - ES5 - TODO: check - {[ try .. catch(exn) {.. }]} - what's the scope of exn - *) - (* Note that [used_idents] is not complete - it ignores some locally defined idents *) - let param_set = Set_ident.of_list params in - let { defined_idents = defined_idents'; used_idents = used_idents' } - = - self.block self - { - init_state with - mutable_values = - Set_ident.of_list (Js_fun_env.get_mutable_params params env); - } - body - in - (* let defined_idents', used_idents' = - obj#get_defined_idents, obj#get_used_idents in *) - (* mark which param is used *) - params - |> List.iteri (fun i v -> - if not (Set_ident.mem used_idents' v) then - Js_fun_env.mark_unused env i); - let closured_idents' = - (* pass param_set down *) - Set_ident.(diff used_idents' (union defined_idents' param_set)) - in - - (* Noe that we don't know which variables are exactly mutable yet .. - due to the recursive thing - *) - Js_fun_env.set_unbounded env closured_idents'; - let lexical_scopes = - Set_ident.(inter closured_idents' state.loop_mutable_values) - in - Js_fun_env.set_lexical_scope env lexical_scopes; - (* tailcall , note that these varibles are used in another pass *) - { - state with - used_idents = Set_ident.union state.used_idents closured_idents'; - (* There is a bug in ocaml -dsource*) - closured_idents = - Set_ident.union state.closured_idents closured_idents'; - } - | _ -> ( - let obj = super.expression self state x in - match Js_block_runtime.check_additional_id x with - | None -> obj - | Some id -> add_used_ident obj id)); - variable_declaration = - (fun self state x -> - match x with - | { ident; value; property } -> ( - let obj = - add_defined_ident - (match (state.in_loop, property) with - | true, Variable -> add_loop_mutable_variable state ident - | true, (Strict | StrictOpt | Alias) - (* Not real true immutable in javascript - since it's in the loop - - TODO: we should also - *) -> ( - match value with - | None -> - add_loop_mutable_variable state ident - (* TODO: Check why assertion failure *) - (* self#add_loop_mutable_variable ident *) - (* assert false *) - | Some x -> ( - (* - when x is an immediate immutable value, - (like integer .. ) - not a reference, it should be Immutable - or string, - type system might help here - TODO: - *) - match x.expression_desc with - | Fun _ | Number _ | Str _ -> state - | _ -> - (* if Set_ident.(is_empty @@ *) - (* inter self#get_mutable_values *) - (* ( ({< *) - (* defined_idents = Set_ident.empty; *) - (* used_idents = Set_ident.empty; *) - (* >} # expression x) # get_used_idents)) then *) - (* (\* FIXME: still need to check expression is pure or not*\) *) - (* self *) - (* else *) - add_loop_mutable_variable state ident)) - | false, Variable -> add_mutable_variable state ident - | false, (Strict | StrictOpt | Alias) -> state) - ident - in - match value with - | None -> obj - | Some x -> self.expression self obj x)); - statement = - (fun self state x -> - match x.statement_desc with - | ForRange (_, _, loop_id, _, _, a_env) -> - (* TODO: simplify definition of For *) - let { - defined_idents = defined_idents'; - used_idents = used_idents'; - closured_idents = closured_idents'; - } = - super.statement self - { - in_loop = true; - loop_mutable_values = Set_ident.singleton loop_id; - used_idents = Set_ident.empty; - (* TODO: if unused, can we generate better code? *) - defined_idents = Set_ident.singleton loop_id; - closured_idents = Set_ident.empty; - (* Think about nested for blocks *) - (* Invariant: Finish id is never used *) - mutable_values = state.mutable_values; - } - x - in - - (* CHECK*) - - (* let defined_idents', used_idents', closured_idents' = - obj#get_defined_idents, obj#get_used_idents, obj#get_closured_idents in *) - let lexical_scope = - Set_ident.( - inter - (diff closured_idents' defined_idents') - state.loop_mutable_values) - in - let () = Js_closure.set_lexical_scope a_env lexical_scope in - (* set scope *) - { - state with - used_idents = Set_ident.union state.used_idents used_idents'; - (* walk around ocaml -dsource bug - {[ - Set_ident.(union used_idents used_idents) - ]} - *) - defined_idents = - Set_ident.union state.defined_idents defined_idents'; - (* TODO: if we our generated code also follow lexical scope, - this is not necessary ; - [varaibles] are mutable or not is known at definition - *) - closured_idents = - Set_ident.union state.closured_idents lexical_scope; - } - | While (_label, pred, body, _env) -> - with_in_loop - (self.block self - (with_in_loop (self.expression self state pred) true) - body) - state.in_loop - | _ -> super.statement self state x); - exception_ident = - (fun _ state x -> - (* we can not simply skip it, since it can be used - TODO: check loop exception - (loop { - excption(i){ - () => {i} - } - }) - *) - { - state with - used_idents = Set_ident.add state.used_idents x; - defined_idents = Set_ident.add state.defined_idents x; - }); - for_ident = - (fun _ state x -> - { - state with - loop_mutable_values = Set_ident.add state.loop_mutable_values x; - }); - ident = - (fun _ state x -> - if Set_ident.mem state.defined_idents x then state - else { state with used_idents = Set_ident.add state.used_idents x }); - } - -let program js = - (record_scope_pass.program record_scope_pass init_state js) - .loop_mutable_values -(* (scope_pass # program js ) # get_loop_mutable_values *) diff --git a/jscomp/core/js_pass_scope.mli b/jscomp/core/js_pass_scope.mli deleted file mode 100644 index b4c1aca..0000000 --- a/jscomp/core/js_pass_scope.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A module to do scope analysis over JS IR *) - -val program : J.program -> Set_ident.t diff --git a/jscomp/core/js_pass_tailcall_inline.ml b/jscomp/core/js_pass_tailcall_inline.ml deleted file mode 100644 index d3e003c..0000000 --- a/jscomp/core/js_pass_tailcall_inline.ml +++ /dev/null @@ -1,225 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* When we inline a function call, if we don't do a beta-reduction immediately, there is - a chance that it is ignored, (we can not assume that each pass is robust enough) - - After we do inlining, it makes sense to do another constant folding and propogation -*) - -(* Check: shall we inline functions with while loop? if it is used only once, - it makes sense to inline it -*) - -module S = Js_stmt_make -(* module E = Js_exp_make *) - -let super = Js_record_map.super - -let substitue_variables (map : Ident.t Map_ident.t) = - { super with ident = (fun _ id -> Map_ident.find_default map id id) } - -(* 1. recursive value ? let rec x = 1 :: x - non-terminating - 2. duplicative identifiers .. - remove it at the same time is a bit unsafe, - since we have to guarantee that the one use - case is substituted - we already have this? in [defined_idents] - - At this time, when tailcall happened, the parameter can be assigned - for example {[ - function (_x,y){ - _x = u - } - ]} - if it is substitued, the assignment will align the value which is incorrect -*) - -let inline_call (immutable_list : bool list) params (args : J.expression list) - processed_blocks = - let map, block = - if immutable_list = [] then - Ext_list.fold_right2 params args (Map_ident.empty, processed_blocks) - (fun param arg (map, acc) -> - match arg.expression_desc with - | Var (Id id) -> (Map_ident.add map param id, acc) - | _ -> (map, S.define_variable ~kind:Variable param arg :: acc)) - else - Ext_list.fold_right3 params args immutable_list - (Map_ident.empty, processed_blocks) (fun param arg mask (map, acc) -> - match (mask, arg.expression_desc) with - | true, Var (Id id) -> (Map_ident.add map param id, acc) - | _ -> (map, S.define_variable ~kind:Variable param arg :: acc)) - in - if Map_ident.is_empty map then block - else - let obj = substitue_variables map in - obj.block obj block - -(** There is a side effect when traversing dead code, since - we assume that substitue a node would mark a node as dead node, - - so if we traverse a dead node, this would get a wrong result. - it does happen in such scenario - {[ - let generic_basename is_dir_sep current_dir_name name = - let rec find_end n = - if n < 0 then String.sub name 0 1 - else if is_dir_sep name n then find_end (n - 1) - else find_beg n (n + 1) - and find_beg n p = - if n < 0 then String.sub name 0 p - else if is_dir_sep name n then String.sub name (n + 1) (p - n - 1) - else find_beg (n - 1) p - in - if name = "" - then current_dir_name - else find_end (String.length name - 1) - ]} - [find_beg] can potentially be expanded in [find_end] and in [find_end]'s expansion, - if the order is not correct, or even worse, only the wrong one [find_beg] in [find_end] get expanded - (when we forget to recursive apply), then some code non-dead [find_beg] will be marked as dead, - while it is still called -*) -let super = Js_record_map.super - -let subst (export_set : Set_ident.t) stats = - { - super with - statement = - (fun self st -> - match st.statement_desc with - | Variable { value = _; ident_info = { used_stats = Dead_pure } } -> - S.block [] - | Variable - { ident_info = { used_stats = Dead_non_pure }; value = Some v; _ } - -> - S.exp v - | _ -> super.statement self st); - variable_declaration = - (fun self ({ ident; value = _; property = _; ident_info = _ } as v) -> - (* TODO: replacement is a bit shaky, the problem is the lambda we stored is - not consistent after we did some subsititution, and the dead code removal - does rely on this (otherwise, when you do beta-reduction you have to regenerate names) - *) - let v = super.variable_declaration self v in - Hash_ident.add stats ident v; - (* see #278 before changes *) - v); - block = - (fun self bs -> - match bs with - | ({ - statement_desc = - Variable - ({ value = Some ({ expression_desc = Fun _; _ } as v) } as vd); - comment = _; - } as st) - :: rest -> ( - let is_export = Set_ident.mem export_set vd.ident in - if is_export then self.statement self st :: self.block self rest - else - match Hash_ident.find_opt stats vd.ident with - (* TODO: could be improved as [mem] *) - | None -> - if Js_analyzer.no_side_effect_expression v then - S.exp v :: self.block self rest - else self.block self rest - | Some _ -> self.statement self st :: self.block self rest) - | [ - ({ - statement_desc = - Return - { - expression_desc = - Call ({ expression_desc = Var (Id id) }, args, _info); - }; - } as st); - ] -> ( - match Hash_ident.find_opt stats id with - | Some - ({ - value = - Some - { - expression_desc = - Fun {is_method=false; params; body; env; async=false}; - comment = _; - }; - (*TODO: don't inline method tail call yet, - [this] semantics are weird - *) - property = Alias | StrictOpt | Strict; - ident_info = { used_stats = Once_pure }; - ident = _; - } as v) - when Ext_list.same_length params args -> - Js_op_util.update_used_stats v.ident_info Dead_pure; - let no_tailcall = Js_fun_env.no_tailcall env in - let processed_blocks = - self.block self body - (* see #278 before changes*) - in - inline_call no_tailcall params args processed_blocks - (* Ext_list.fold_right2 - params args processed_blocks - (fun param arg acc -> - S.define_variable ~kind:Variable param arg :: acc) *) - (* Mark a function as dead means it will never be scanned, - here we inline the function - *) - | None | Some _ -> [ self.statement self st ]) - | [ - { - statement_desc = - Return - { - expression_desc = - Call - ( { - expression_desc = - Fun {is_method=false; params; body; env; async=false}; - }, - args, - _info ); - }; - }; - ] - when Ext_list.same_length params args -> - let no_tailcall = Js_fun_env.no_tailcall env in - let processed_blocks = - self.block self body - (* see #278 before changes*) - in - inline_call no_tailcall params args processed_blocks - | x :: xs -> self.statement self x :: self.block self xs - | [] -> []); - } - -let tailcall_inline (program : J.program) = - let stats = Js_pass_get_used.get_stats program in - let export_set = program.export_set in - let obj = subst export_set stats in - obj.program obj program diff --git a/jscomp/core/js_pass_tailcall_inline.mli b/jscomp/core/js_pass_tailcall_inline.mli deleted file mode 100644 index 207a90e..0000000 --- a/jscomp/core/js_pass_tailcall_inline.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** This pass detect functions used once and if it is used in used - in the tail position, it will get inlined, this will help - remove some common use cases like This - {[ - let length x = - let rec aux n x = - match x with - | [] -> n - | _ :: rest -> aux (n + 1) rest in - aux 0 x - ]} -*) - -val tailcall_inline : J.program -> J.program diff --git a/jscomp/core/js_record_fold.ml b/jscomp/core/js_record_fold.ml deleted file mode 100644 index b92ca55..0000000 --- a/jscomp/core/js_record_fold.ml +++ /dev/null @@ -1,315 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open J - -let[@inline] unknown _ st _ = st - -let[@inline] option sub self st v = - match v with None -> st | Some v -> sub self st v - -let rec list sub self st x = - match x with - | [] -> st - | x :: xs -> - let st = sub self st x in - list sub self st xs - -type 'state iter = { - ident : ('state, ident) fn; - module_id : ('state, module_id) fn; - vident : ('state, vident) fn; - exception_ident : ('state, exception_ident) fn; - for_ident : ('state, for_ident) fn; - expression : ('state, expression) fn; - statement : ('state, statement) fn; - variable_declaration : ('state, variable_declaration) fn; - block : ('state, block) fn; - program : ('state, program) fn; -} - -and ('state, 'a) fn = 'state iter -> 'state -> 'a -> 'state - -let label : 'a. ('a, label) fn = unknown - -let ident : 'a. ('a, ident) fn = unknown - -let module_id : 'a. ('a, module_id) fn = - fun _self st { id = _x0; kind = _x1 } -> - let st = _self.ident _self st _x0 in - st - -let required_modules : 'a. ('a, required_modules) fn = - fun _self st arg -> list _self.module_id _self st arg - -let vident : 'a. ('a, vident) fn = - fun _self st -> function - | Id _x0 -> - let st = _self.ident _self st _x0 in - st - | Qualified (_x0, _x1) -> - let st = _self.module_id _self st _x0 in - st - -let exception_ident : 'a. ('a, exception_ident) fn = - fun _self arg -> _self.ident _self arg - -let for_ident : 'a. ('a, for_ident) fn = fun _self arg -> _self.ident _self arg - -let for_direction : 'a. ('a, for_direction) fn = unknown - -let property_map : 'a. ('a, property_map) fn = - fun _self st arg -> - list - (fun _self st (_x0, _x1) -> - let st = _self.expression _self st _x1 in - st) - _self st arg - -let length_object : 'a. ('a, length_object) fn = unknown - -let expression_desc : 'a. ('a, expression_desc) fn = - fun _self st -> function - | Length (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = length_object _self st _x1 in - st - | Is_null_or_undefined _x0 -> - let st = _self.expression _self st _x0 in - st - | String_append (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st - | Bool _ -> st - | Typeof _x0 -> - let st = _self.expression _self st _x0 in - st - | Js_not _x0 -> - let st = _self.expression _self st _x0 in - st - | Seq (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st - | Cond (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - let st = _self.expression _self st _x2 in - st - | Bin (_x0, _x1, _x2) -> - let st = _self.expression _self st _x1 in - let st = _self.expression _self st _x2 in - st - | FlatCall (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st - | Call (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = list _self.expression _self st _x1 in - st - | Tagged_template (_xo, _x1, _x2) -> - let st = _self.expression _self st _xo in - let st = list _self.expression _self st _x1 in - let st = list _self.expression _self st _x2 in - st - | String_index (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st - | Array_index (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = _self.expression _self st _x1 in - st - | Static_index (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - st - | New (_x0, _x1) -> - let st = _self.expression _self st _x0 in - let st = - option - (fun _self st arg -> list _self.expression _self st arg) - _self st _x1 - in - st - | Var _x0 -> - let st = _self.vident _self st _x0 in - st - | Fun {params; body} -> - let st = list _self.ident _self st params in - let st = _self.block _self st body in - st - | Str _ -> st - | Raw_js_code _ -> st - | Array (_x0, _x1) -> - let st = list _self.expression _self st _x0 in - st - | Optional_block (_x0, _x1) -> - let st = _self.expression _self st _x0 in - st - | Caml_block (_x0, _x1, _x2, _x3) -> - let st = list _self.expression _self st _x0 in - let st = _self.expression _self st _x2 in - st - | Caml_block_tag (_x0, _tag) -> - let st = _self.expression _self st _x0 in - st - | Number _ -> st - | Object _x0 -> - let st = property_map _self st _x0 in - st - | Undefined _ -> st - | Null -> st - | Await _x0 -> - let st = _self.expression _self st _x0 in - st - -let for_ident_expression : 'a. ('a, for_ident_expression) fn = - fun _self arg -> _self.expression _self arg - -let finish_ident_expression : 'a. ('a, finish_ident_expression) fn = - fun _self arg -> _self.expression _self arg - -let case_clause : 'a. ('a, case_clause) fn = - fun _self st { switch_body = _x0; should_break = _x1; comment = _x2 } -> - let st = _self.block _self st _x0 in - st - -let string_clause : 'a. ('a, string_clause) fn = - fun _self st (_x0, _x1) -> - let st = case_clause _self st _x1 in - st - -let int_clause : 'a. ('a, int_clause) fn = - fun _self st (_x0, _x1) -> - let st = case_clause _self st _x1 in - st - -let statement_desc : 'a. ('a, statement_desc) fn = - fun _self st -> function - | Block _x0 -> - let st = _self.block _self st _x0 in - st - | Variable _x0 -> - let st = _self.variable_declaration _self st _x0 in - st - | Exp _x0 -> - let st = _self.expression _self st _x0 in - st - | If (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = _self.block _self st _x1 in - let st = _self.block _self st _x2 in - st - | While (_x0, _x1, _x2, _x3) -> - let st = option label _self st _x0 in - let st = _self.expression _self st _x1 in - let st = _self.block _self st _x2 in - st - | ForRange (_x0, _x1, _x2, _x3, _x4, _x5) -> - let st = option for_ident_expression _self st _x0 in - let st = finish_ident_expression _self st _x1 in - let st = _self.for_ident _self st _x2 in - let st = for_direction _self st _x3 in - let st = _self.block _self st _x4 in - st - | Continue _x0 -> - let st = label _self st _x0 in - st - | Break -> st - | Return _x0 -> - let st = _self.expression _self st _x0 in - st - | Int_switch (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = list int_clause _self st _x1 in - let st = option _self.block _self st _x2 in - st - | String_switch (_x0, _x1, _x2) -> - let st = _self.expression _self st _x0 in - let st = list string_clause _self st _x1 in - let st = option _self.block _self st _x2 in - st - | Throw _x0 -> - let st = _self.expression _self st _x0 in - st - | Try (_x0, _x1, _x2) -> - let st = _self.block _self st _x0 in - let st = - option - (fun _self st (_x0, _x1) -> - let st = _self.exception_ident _self st _x0 in - let st = _self.block _self st _x1 in - st) - _self st _x1 - in - let st = option _self.block _self st _x2 in - st - | Debugger -> st - -let expression : 'a. ('a, expression) fn = - fun _self st { expression_desc = _x0; comment = _x1 } -> - let st = expression_desc _self st _x0 in - st - -let statement : 'a. ('a, statement) fn = - fun _self st { statement_desc = _x0; comment = _x1 } -> - let st = statement_desc _self st _x0 in - st - -let variable_declaration : 'a. ('a, variable_declaration) fn = - fun _self st { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> - let st = _self.ident _self st _x0 in - let st = option _self.expression _self st _x1 in - st - -let block : 'a. ('a, block) fn = - fun _self st arg -> list _self.statement _self st arg - -let program : 'a. ('a, program) fn = - fun _self st { block = _x0; exports = _x1; export_set = _x2 } -> - let st = _self.block _self st _x0 in - st - -let deps_program : 'a. ('a, deps_program) fn = - fun _self st { program = _x0; modules = _x1; side_effect = _x2 } -> - let st = _self.program _self st _x0 in - let st = required_modules _self st _x1 in - st - -let super : 'state iter = - { - ident; - module_id; - vident; - exception_ident; - for_ident; - expression; - statement; - variable_declaration; - block; - program; - } - \ No newline at end of file diff --git a/jscomp/core/js_record_iter.ml b/jscomp/core/js_record_iter.ml deleted file mode 100644 index cbbc9f4..0000000 --- a/jscomp/core/js_record_iter.ml +++ /dev/null @@ -1,233 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open J - -let unknown _ _ = () - -let[@inline] option sub self v = - match v with None -> () | Some v -> sub self v - -let rec list sub self x = - match x with - | [] -> () - | x :: xs -> - sub self x; - list sub self xs - -type iter = { - ident : ident fn; - module_id : module_id fn; - vident : vident fn; - exception_ident : exception_ident fn; - for_ident : for_ident fn; - expression : expression fn; - statement : statement fn; - variable_declaration : variable_declaration fn; - block : block fn; - program : program fn; -} - -and 'a fn = iter -> 'a -> unit - -let label : label fn = unknown - -let ident : ident fn = unknown - -let module_id : module_id fn = - fun _self { id = _x0; kind = _x1 } -> _self.ident _self _x0 - -let required_modules : required_modules fn = - fun _self arg -> list _self.module_id _self arg - -let vident : vident fn = - fun _self -> function - | Id _x0 -> _self.ident _self _x0 - | Qualified (_x0, _x1) -> _self.module_id _self _x0 - -let exception_ident : exception_ident fn = - fun _self arg -> _self.ident _self arg - -let for_ident : for_ident fn = fun _self arg -> _self.ident _self arg - -let for_direction : for_direction fn = unknown - -let property_map : property_map fn = - fun _self arg -> - list (fun _self (_x0, _x1) -> _self.expression _self _x1) _self arg - -let length_object : length_object fn = unknown - -let expression_desc : expression_desc fn = - fun _self -> function - | Length (_x0, _x1) -> - _self.expression _self _x0; - length_object _self _x1 - | Is_null_or_undefined _x0 -> _self.expression _self _x0 - | String_append (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 - | Bool _ -> () - | Typeof _x0 -> _self.expression _self _x0 - | Js_not _x0 -> _self.expression _self _x0 - | Seq (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 - | Cond (_x0, _x1, _x2) -> - _self.expression _self _x0; - _self.expression _self _x1; - _self.expression _self _x2 - | Bin (_x0, _x1, _x2) -> - _self.expression _self _x1; - _self.expression _self _x2 - | FlatCall (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 - | Call (_x0, _x1, _x2) -> - _self.expression _self _x0; - list _self.expression _self _x1 - | Tagged_template (_x0, _x1, _x2) -> - _self.expression _self _x0; - list _self.expression _self _x1; - list _self.expression _self _x2 - | String_index (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 - | Array_index (_x0, _x1) -> - _self.expression _self _x0; - _self.expression _self _x1 - | Static_index (_x0, _x1, _x2) -> _self.expression _self _x0 - | New (_x0, _x1) -> - _self.expression _self _x0; - option (fun _self arg -> list _self.expression _self arg) _self _x1 - | Var _x0 -> _self.vident _self _x0 - | Fun {params; body} -> - list _self.ident _self params; - _self.block _self body - | Str _ -> () - | Raw_js_code _ -> () - | Array (_x0, _x1) -> list _self.expression _self _x0 - | Optional_block (_x0, _x1) -> _self.expression _self _x0 - | Caml_block (_x0, _x1, _x2, _x3) -> - list _self.expression _self _x0; - _self.expression _self _x2 - | Caml_block_tag (_x0, _tag) -> _self.expression _self _x0 - | Number _ -> () - | Object _x0 -> property_map _self _x0 - | Undefined _ -> () - | Null -> () - | Await _x0 -> _self.expression _self _x0 - -let for_ident_expression : for_ident_expression fn = - fun _self arg -> _self.expression _self arg - -let finish_ident_expression : finish_ident_expression fn = - fun _self arg -> _self.expression _self arg - -let case_clause : case_clause fn = - fun _self { switch_body = _x0; should_break = _x1; comment = _x2 } -> - _self.block _self _x0 - -let string_clause : string_clause fn = - fun _self (_x0, _x1) -> case_clause _self _x1 - -let int_clause : int_clause fn = fun _self (_x0, _x1) -> case_clause _self _x1 - -let statement_desc : statement_desc fn = - fun _self -> function - | Block _x0 -> _self.block _self _x0 - | Variable _x0 -> _self.variable_declaration _self _x0 - | Exp _x0 -> _self.expression _self _x0 - | If (_x0, _x1, _x2) -> - _self.expression _self _x0; - _self.block _self _x1; - _self.block _self _x2 - | While (_x0, _x1, _x2, _x3) -> - option label _self _x0; - _self.expression _self _x1; - _self.block _self _x2 - | ForRange (_x0, _x1, _x2, _x3, _x4, _x5) -> - option for_ident_expression _self _x0; - finish_ident_expression _self _x1; - _self.for_ident _self _x2; - for_direction _self _x3; - _self.block _self _x4 - | Continue _x0 -> label _self _x0 - | Break -> () - | Return _x0 -> _self.expression _self _x0 - | Int_switch (_x0, _x1, _x2) -> - _self.expression _self _x0; - list int_clause _self _x1; - option _self.block _self _x2 - | String_switch (_x0, _x1, _x2) -> - _self.expression _self _x0; - list string_clause _self _x1; - option _self.block _self _x2 - | Throw _x0 -> _self.expression _self _x0 - | Try (_x0, _x1, _x2) -> - _self.block _self _x0; - option - (fun _self (_x0, _x1) -> - _self.exception_ident _self _x0; - _self.block _self _x1) - _self _x1; - option _self.block _self _x2 - | Debugger -> () - -let expression : expression fn = - fun _self { expression_desc = _x0; comment = _x1 } -> expression_desc _self _x0 - -let statement : statement fn = - fun _self { statement_desc = _x0; comment = _x1 } -> statement_desc _self _x0 - -let variable_declaration : variable_declaration fn = - fun _self { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> - _self.ident _self _x0; - option _self.expression _self _x1 - -let block : block fn = fun _self arg -> list _self.statement _self arg - -let program : program fn = - fun _self { block = _x0; exports = _x1; export_set = _x2 } -> - _self.block _self _x0 - -let deps_program : deps_program fn = - fun _self { program = _x0; modules = _x1; side_effect = _x2 } -> - _self.program _self _x0; - required_modules _self _x1 - -let super : iter = - { - ident; - module_id; - vident; - exception_ident; - for_ident; - expression; - statement; - variable_declaration; - block; - program; - } - \ No newline at end of file diff --git a/jscomp/core/js_record_map.ml b/jscomp/core/js_record_map.ml deleted file mode 100644 index c7d0cdf..0000000 --- a/jscomp/core/js_record_map.ml +++ /dev/null @@ -1,312 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open J - -let[@inline] unknown _ x = x - -let[@inline] option sub self v = - match v with None -> None | Some v -> Some (sub self v) - -let rec list sub self x = - match x with - | [] -> [] - | x :: xs -> - let v = sub self x in - v :: list sub self xs - -type iter = { - ident : ident fn; - module_id : module_id fn; - vident : vident fn; - exception_ident : exception_ident fn; - for_ident : for_ident fn; - expression : expression fn; - statement : statement fn; - variable_declaration : variable_declaration fn; - block : block fn; - program : program fn; -} - -and 'a fn = iter -> 'a -> 'a - -let label : label fn = unknown - -let ident : ident fn = unknown - -let module_id : module_id fn = - fun _self { id = _x0; kind = _x1; dynamic_import = _x2 } -> - let _x0 = _self.ident _self _x0 in - { id = _x0; kind = _x1; dynamic_import = _x2 } - -let required_modules : required_modules fn = - fun _self arg -> list _self.module_id _self arg - -let vident : vident fn = - fun _self -> function - | Id _x0 -> - let _x0 = _self.ident _self _x0 in - Id _x0 - | Qualified (_x0, _x1) -> - let _x0 = _self.module_id _self _x0 in - Qualified (_x0, _x1) - -let exception_ident : exception_ident fn = - fun _self arg -> _self.ident _self arg - -let for_ident : for_ident fn = fun _self arg -> _self.ident _self arg - -let for_direction : for_direction fn = unknown - -let property_map : property_map fn = - fun _self arg -> - list - (fun _self (_x0, _x1) -> - let _x1 = _self.expression _self _x1 in - (_x0, _x1)) - _self arg - -let length_object : length_object fn = unknown - -let expression_desc : expression_desc fn = - fun _self -> function - | Length (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = length_object _self _x1 in - Length (_x0, _x1) - | Is_null_or_undefined _x0 -> - let _x0 = _self.expression _self _x0 in - Is_null_or_undefined _x0 - | String_append (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - String_append (_x0, _x1) - | Bool _ as v -> v - | Typeof _x0 -> - let _x0 = _self.expression _self _x0 in - Typeof _x0 - | Js_not _x0 -> - let _x0 = _self.expression _self _x0 in - Js_not _x0 - | Seq (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - Seq (_x0, _x1) - | Cond (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - let _x2 = _self.expression _self _x2 in - Cond (_x0, _x1, _x2) - | Bin (_x0, _x1, _x2) -> - let _x1 = _self.expression _self _x1 in - let _x2 = _self.expression _self _x2 in - Bin (_x0, _x1, _x2) - | FlatCall (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - FlatCall (_x0, _x1) - | Call (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list _self.expression _self _x1 in - Call (_x0, _x1, _x2) - | Tagged_template (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list _self.expression _self _x1 in - let _x2 = list _self.expression _self _x2 in - Tagged_template (_x0, _x1, _x2) - | String_index (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - String_index (_x0, _x1) - | Array_index (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.expression _self _x1 in - Array_index (_x0, _x1) - | Static_index (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - Static_index (_x0, _x1, _x2) - | New (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - let _x1 = - option (fun _self arg -> list _self.expression _self arg) _self _x1 - in - New (_x0, _x1) - | Var _x0 -> - let _x0 = _self.vident _self _x0 in - Var _x0 - | Fun ({params; body} as fun_) -> - let params = list _self.ident _self params in - let body = _self.block _self body in - Fun {fun_ with params; body} - | Str _ as v -> v - | Raw_js_code _ as v -> v - | Array (_x0, _x1) -> - let _x0 = list _self.expression _self _x0 in - Array (_x0, _x1) - | Optional_block (_x0, _x1) -> - let _x0 = _self.expression _self _x0 in - Optional_block (_x0, _x1) - | Caml_block (_x0, _x1, _x2, _x3) -> - let _x0 = list _self.expression _self _x0 in - let _x2 = _self.expression _self _x2 in - Caml_block (_x0, _x1, _x2, _x3) - | Caml_block_tag (_x0, tag) -> - let _x0 = _self.expression _self _x0 in - Caml_block_tag (_x0, tag) - | Number _ as v -> v - | Object _x0 -> - let _x0 = property_map _self _x0 in - Object _x0 - | Undefined _ as v -> v - | Null as v -> v - | Await _x0 -> - let _x0 = _self.expression _self _x0 in - Await _x0 - -let for_ident_expression : for_ident_expression fn = - fun _self arg -> _self.expression _self arg - -let finish_ident_expression : finish_ident_expression fn = - fun _self arg -> _self.expression _self arg - -let case_clause : case_clause fn = - fun _self { switch_body = _x0; should_break = _x1; comment = _x2 } -> - let _x0 = _self.block _self _x0 in - { switch_body = _x0; should_break = _x1; comment = _x2 } - -let string_clause : string_clause fn = - fun _self (_x0, _x1) -> - let _x1 = case_clause _self _x1 in - (_x0, _x1) - -let int_clause : int_clause fn = - fun _self (_x0, _x1) -> - let _x1 = case_clause _self _x1 in - (_x0, _x1) - -let statement_desc : statement_desc fn = - fun _self -> function - | Block _x0 -> - let _x0 = _self.block _self _x0 in - Block _x0 - | Variable _x0 -> - let _x0 = _self.variable_declaration _self _x0 in - Variable _x0 - | Exp _x0 -> - let _x0 = _self.expression _self _x0 in - Exp _x0 - | If (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = _self.block _self _x1 in - let _x2 = _self.block _self _x2 in - If (_x0, _x1, _x2) - | While (_x0, _x1, _x2, _x3) -> - let _x0 = option label _self _x0 in - let _x1 = _self.expression _self _x1 in - let _x2 = _self.block _self _x2 in - While (_x0, _x1, _x2, _x3) - | ForRange (_x0, _x1, _x2, _x3, _x4, _x5) -> - let _x0 = option for_ident_expression _self _x0 in - let _x1 = finish_ident_expression _self _x1 in - let _x2 = _self.for_ident _self _x2 in - let _x3 = for_direction _self _x3 in - let _x4 = _self.block _self _x4 in - ForRange (_x0, _x1, _x2, _x3, _x4, _x5) - | Continue _x0 -> - let _x0 = label _self _x0 in - Continue _x0 - | Break as v -> v - | Return _x0 -> - let _x0 = _self.expression _self _x0 in - Return _x0 - | Int_switch (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list int_clause _self _x1 in - let _x2 = option _self.block _self _x2 in - Int_switch (_x0, _x1, _x2) - | String_switch (_x0, _x1, _x2) -> - let _x0 = _self.expression _self _x0 in - let _x1 = list string_clause _self _x1 in - let _x2 = option _self.block _self _x2 in - String_switch (_x0, _x1, _x2) - | Throw _x0 -> - let _x0 = _self.expression _self _x0 in - Throw _x0 - | Try (_x0, _x1, _x2) -> - let _x0 = _self.block _self _x0 in - let _x1 = - option - (fun _self (_x0, _x1) -> - let _x0 = _self.exception_ident _self _x0 in - let _x1 = _self.block _self _x1 in - (_x0, _x1)) - _self _x1 - in - let _x2 = option _self.block _self _x2 in - Try (_x0, _x1, _x2) - | Debugger as v -> v - -let expression : expression fn = - fun _self { expression_desc = _x0; comment = _x1 } -> - let _x0 = expression_desc _self _x0 in - { expression_desc = _x0; comment = _x1 } - -let statement : statement fn = - fun _self { statement_desc = _x0; comment = _x1 } -> - let _x0 = statement_desc _self _x0 in - { statement_desc = _x0; comment = _x1 } - -let variable_declaration : variable_declaration fn = - fun _self { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } -> - let _x0 = _self.ident _self _x0 in - let _x1 = option _self.expression _self _x1 in - { ident = _x0; value = _x1; property = _x2; ident_info = _x3 } - -let block : block fn = fun _self arg -> list _self.statement _self arg - -let program : program fn = - fun _self { block = _x0; exports = _x1; export_set = _x2 } -> - let _x0 = _self.block _self _x0 in - { block = _x0; exports = _x1; export_set = _x2 } - -let deps_program : deps_program fn = - fun _self { program = _x0; modules = _x1; side_effect = _x2 } -> - let _x0 = _self.program _self _x0 in - let _x1 = required_modules _self _x1 in - { program = _x0; modules = _x1; side_effect = _x2 } - -let super : iter = - { - ident; - module_id; - vident; - exception_ident; - for_ident; - expression; - statement; - variable_declaration; - block; - program; - } - \ No newline at end of file diff --git a/jscomp/core/js_shake.ml b/jscomp/core/js_shake.ml deleted file mode 100644 index ab8819c..0000000 --- a/jscomp/core/js_shake.ml +++ /dev/null @@ -1,108 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** we also need make it complete -*) -let get_initial_exports count_non_variable_declaration_statement - (export_set : Set_ident.t) (block : J.block) = - let result = - Ext_list.fold_left block export_set (fun acc st -> - match st.statement_desc with - | Variable { ident; value; _ } -> ( - if Set_ident.mem acc ident then - match value with - | None -> acc - | Some x -> - (* If not a function, we have to calcuate again and again - TODO: add hashtbl for a cache - *) - Set_ident.( - union (Js_analyzer.free_variables_of_expression x) acc) - else - match value with - | None -> acc - | Some x -> - if Js_analyzer.no_side_effect_expression x then acc - else - Set_ident.( - union - (Js_analyzer.free_variables_of_expression x) - (add acc ident))) - | _ -> - (* recalcuate again and again ... *) - if - Js_analyzer.no_side_effect_statement st - || not count_non_variable_declaration_statement - then acc - else - Set_ident.(union (Js_analyzer.free_variables_of_statement st) acc)) - in - (result, Set_ident.(diff result export_set)) - -let shake_program (program : J.program) = - let shake_block block export_set = - let block = List.rev @@ Js_analyzer.rev_toplevel_flatten block in - let loop block export_set : Set_ident.t = - let rec aux acc block = - let result, diff = get_initial_exports false acc block in - (* let _d () = *) - (* if Ext_string.ends_with program.name debug_file then *) - (* begin *) - (* Ext_log.err "@[%a@]@." Set_ident.print result ; *) - (* end *) - (* in *) - if Set_ident.is_empty diff then result else aux result block - in - let first_iteration, delta = get_initial_exports true export_set block in - - (* let _d () = *) - (* if Ext_string.ends_with program.name debug_file then *) - (* begin *) - (* Ext_log.err "@[%a@ %a@]@." *) - (* Set_ident.print first_iteration *) - (* Set_ident.print delta (\* TODO: optimization, don't add persistent variables *\) *) - (* ; *) - (* Ext_log.err "init ---- @." *) - (* end *) - (* in *) - if not @@ Set_ident.is_empty delta then aux first_iteration block - else first_iteration - in - - let really_set = loop block export_set in - Ext_list.fold_right block [] (fun (st : J.statement) acc -> - match st.statement_desc with - | Variable { ident; value; _ } -> ( - if Set_ident.mem really_set ident then st :: acc - else - match value with - | None -> acc - | Some x -> - if Js_analyzer.no_side_effect_expression x then acc - else st :: acc) - | _ -> - if Js_analyzer.no_side_effect_statement st then acc else st :: acc) - in - - { program with block = shake_block program.block program.export_set } diff --git a/jscomp/core/js_shake.mli b/jscomp/core/js_shake.mli deleted file mode 100644 index bcbc76f..0000000 --- a/jscomp/core/js_shake.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A module to shake JS IR - - Tree shaking is not going to change the closure -*) - -val shake_program : J.program -> J.program diff --git a/jscomp/core/js_stmt_make.ml b/jscomp/core/js_stmt_make.ml deleted file mode 100644 index b2550bf..0000000 --- a/jscomp/core/js_stmt_make.ml +++ /dev/null @@ -1,349 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -type t = J.statement - -let return_stmt ?comment e : t = { statement_desc = Return e; comment } - -let empty_stmt : t = { statement_desc = Block []; comment = None } - -(* let empty_block : J.block = [] *) -let throw_stmt ?comment v : t = { statement_desc = Throw v; comment } - -(* avoid nested block *) -let rec block ?comment (b : J.block) : t = - match b with - | [ { statement_desc = Block bs } ] -> block bs - | [ b ] -> b - | [] -> empty_stmt - | _ -> { statement_desc = Block b; comment } - -(* It's a statement, we can discard some values *) -let rec exp ?comment (e : E.t) : t = - match e.expression_desc with - | Seq ({ expression_desc = Number _ | Undefined _ }, b) - | Seq (b, { expression_desc = Number _ | Undefined _ }) -> - exp ?comment b - | Number _ | Undefined _ -> block [] - (* TODO: we can do more *) - (* | _ when is_pure e -> block [] *) - | _ -> { statement_desc = Exp e; comment } - -let declare_variable ?comment ?ident_info ~kind (ident : Ident.t) : t = - let property : J.property = kind in - let ident_info : J.ident_info = - match ident_info with None -> { used_stats = NA } | Some x -> x - in - { - statement_desc = Variable { ident; value = None; property; ident_info }; - comment; - } - -let define_variable ?comment ?ident_info ~kind (v : Ident.t) - (exp : J.expression) : t = match exp.expression_desc with - | Undefined _ -> - declare_variable ?comment ?ident_info ~kind v - | _ -> - let property : J.property = kind in - let ident_info : J.ident_info = - match ident_info with None -> { used_stats = NA } | Some x -> x - in - { - statement_desc = - Variable { ident = v; value = Some exp; property; ident_info }; - comment; - } - -(* let alias_variable ?comment ~exp (v:Ident.t) : t= - {statement_desc = - Variable { - ident = v; value = Some exp; property = Alias; - ident_info = {used_stats = NA } }; - comment} *) - -let int_switch ?(comment : string option) - ?(declaration : (J.property * Ident.t) option) ?(default : J.block option) - (e : J.expression) (clauses : (int * J.case_clause) list) : t = - match e.expression_desc with - | Number (Int { i; _ }) -> ( - let continuation = - match - Ext_list.find_opt clauses (fun (switch_case, x) -> - if switch_case = Int32.to_int i then Some x.switch_body else None) - with - | Some case -> case - | None -> ( match default with Some x -> x | None -> assert false) - in - match (declaration, continuation) with - | ( Some (kind, did), - [ - { - statement_desc = - Exp - { - expression_desc = - Bin (Eq, { expression_desc = Var (Id id); _ }, e0); - _; - }; - _; - }; - ] ) - when Ident.same did id -> - define_variable ?comment ~kind id e0 - | Some (kind, did), _ -> - block (declare_variable ?comment ~kind did :: continuation) - | None, _ -> block continuation) - | _ -> ( - match declaration with - | Some (kind, did) -> - block - [ - declare_variable ?comment ~kind did; - { statement_desc = J.Int_switch (e, clauses, default); comment }; - ] - | None -> { statement_desc = J.Int_switch (e, clauses, default); comment } - ) - -let string_switch ?(comment : string option) - ?(declaration : (J.property * Ident.t) option) ?(default : J.block option) - (e : J.expression) (clauses : (Ast_untagged_variants.tag_type * J.case_clause) list) : t = - match e.expression_desc with - | Str {txt} -> ( - let continuation = - match - Ext_list.find_opt clauses (fun (switch_case, x) -> - match switch_case with - | String s -> - if s = txt then Some x.switch_body else None - | Int _ | Float _ | BigInt _ | Bool _ | Null | Undefined | Untagged _ -> - None) - with - | Some case -> case - | None -> ( match default with Some x -> x | None -> assert false) - in - match (declaration, continuation) with - | ( Some (kind, did), - [ - { - statement_desc = - Exp - { - expression_desc = - Bin (Eq, { expression_desc = Var (Id id); _ }, e0); - _; - }; - _; - }; - ] ) - when Ident.same did id -> - define_variable ?comment ~kind id e0 - | Some (kind, did), _ -> - block @@ (declare_variable ?comment ~kind did :: continuation) - | None, _ -> block continuation) - | _ -> ( - match declaration with - | Some (kind, did) -> - block - [ - declare_variable ?comment ~kind did; - { statement_desc = String_switch (e, clauses, default); comment }; - ] - | None -> - { statement_desc = String_switch (e, clauses, default); comment }) - -let rec block_last_is_return_throw_or_continue (x : J.block) = - match x with - | [] -> false - | [ x ] -> ( - match x.statement_desc with - | Return _ | Throw _ | Continue _ -> true - | _ -> false) - | _ :: rest -> block_last_is_return_throw_or_continue rest - -(* TODO: it also make sense to extract some common statements - between those two branches, it does happen since in OCaml you - have to write some duplicated code due to the types system restriction - example: - {[ - | Format_subst (pad_opt, fmtty, rest) -> - buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; - bprint_pad_opt buf pad_opt; buffer_add_char buf '('; - bprint_fmtty buf fmtty; buffer_add_char buf '%'; buffer_add_char buf ')'; - fmtiter rest false; - - | Scan_char_set (width_opt, char_set, rest) -> - buffer_add_char buf '%'; bprint_ignored_flag buf ign_flag; - bprint_pad_opt buf width_opt; bprint_char_set buf char_set; - fmtiter rest false; - ]} - - To hit this branch, we also need [declaration] passed down - TODO: check how we compile [Lifthenelse] - The declaration argument is introduced to merge assignment in both branches - - Note we can transfer code as below: - {[ - if (x){ - return /throw e; - } else { - blabla - } - ]} - into - {[ - if (x){ - return /throw e; - } - blabla - ]} - Not clear the benefit -*) -let if_ ?comment ?declaration ?else_ (e : J.expression) (then_ : J.block) : t = - let declared = ref false in - let common_prefix_blocks = ref [] in - let add_prefix b = common_prefix_blocks := b :: !common_prefix_blocks in - let rec aux ?comment (e : J.expression) (ifso : J.block) (ifnot : J.block) : t - = - match (e.expression_desc, ifnot) with - | Bool boolean, _ -> block (if boolean then ifso else ifnot) - | Js_not pred_not, _ :: _ -> aux ?comment pred_not ifnot ifso - | _ -> ( - match (ifso, ifnot) with - | [], [] -> exp e - | [], _ -> - aux ?comment (E.not e) ifnot [] (*Make sure no infinite loop*) - | ( [ { statement_desc = Return ret_ifso; _ } ], - [ { statement_desc = Return ret_ifnot; _ } ] ) -> - return_stmt (E.econd e ret_ifso ret_ifnot) - | _, [ { statement_desc = Return _ } ] -> - block ({ statement_desc = If (E.not e, ifnot, []); comment } :: ifso) - | _, _ when block_last_is_return_throw_or_continue ifso -> - block ({ statement_desc = If (e, ifso, []); comment } :: ifnot) - | ( [ - { - statement_desc = - Exp - { - expression_desc = - Bin - ( Eq, - ({ expression_desc = Var (Id var_ifso); _ } as - lhs_ifso), - rhs_ifso ); - _; - }; - _; - }; - ], - [ - { - statement_desc = - Exp - { - expression_desc = - Bin - ( Eq, - { expression_desc = Var (Id var_ifnot); _ }, - lhs_ifnot ); - _; - }; - _; - }; - ] ) - when Ident.same var_ifso var_ifnot -> ( - match declaration with - | Some (kind, id) when Ident.same id var_ifso -> - declared := true; - define_variable ~kind var_ifso (E.econd e rhs_ifso lhs_ifnot) - | _ -> exp (E.assign lhs_ifso (E.econd e rhs_ifso lhs_ifnot))) - | ( [ { statement_desc = Exp exp_ifso; _ } ], - [ { statement_desc = Exp exp_ifnot; _ } ] ) -> - exp (E.econd e exp_ifso exp_ifnot) - | [ { statement_desc = If (pred1, ifso1, ifnot1) } ], _ - when Js_analyzer.eq_block ifnot1 ifnot -> - aux ?comment (E.and_ e pred1) ifso1 ifnot1 - | [ { statement_desc = If (pred1, ifso1, ifnot1) } ], _ - when Js_analyzer.eq_block ifso1 ifnot -> - aux ?comment (E.and_ e (E.not pred1)) ifnot1 ifso1 - | _, [ { statement_desc = If (pred1, ifso1, else_) } ] - when Js_analyzer.eq_block ifso ifso1 -> - aux ?comment (E.or_ e pred1) ifso else_ - | _, [ { statement_desc = If (pred1, ifso1, ifnot1) } ] - when Js_analyzer.eq_block ifso ifnot1 -> - aux ?comment (E.or_ e (E.not pred1)) ifso ifso1 - | ifso1 :: ifso_rest, ifnot1 :: ifnot_rest - when Js_analyzer.eq_statement ifnot1 ifso1 - && Js_analyzer.no_side_effect_expression e -> - (* here we do agressive optimization, because it can help optimization later, - move code outside of branch is generally helpful later - *) - add_prefix ifso1; - aux ?comment e ifso_rest ifnot_rest - | _ -> { statement_desc = If (e, ifso, ifnot); comment }) - in - let if_block = - aux ?comment e then_ (match else_ with None -> [] | Some v -> v) - in - let prefix = !common_prefix_blocks in - match (!declared, declaration) with - | true, _ | _, None -> - if prefix = [] then if_block - else block (List.rev_append prefix [ if_block ]) - | false, Some (kind, id) -> - block (declare_variable ~kind id :: List.rev_append prefix [ if_block ]) - -let assign ?comment id e : t = - { statement_desc = J.Exp (E.assign (E.var id) e); comment } - -let while_ ?comment ?label ?env (e : E.t) (st : J.block) : t = - let env = match env with None -> Js_closure.empty () | Some x -> x in - { statement_desc = While (label, e, st, env); comment } - -let for_ ?comment ?env for_ident_expression finish_ident_expression id direction - (b : J.block) : t = - let env = match env with None -> Js_closure.empty () | Some x -> x in - { - statement_desc = - ForRange - (for_ident_expression, finish_ident_expression, id, direction, b, env); - comment; - } - -let try_ ?comment ?with_ ?finally body : t = - { statement_desc = Try (body, with_, finally); comment } - -(* TODO: - actually, only loops can be labelled -*) -(* let continue_stmt ?comment ?(label="") () : t = - { - statement_desc = J.Continue label; - comment; - } *) - -let continue_ : t = { statement_desc = Continue ""; comment = None } - -let debugger_block : t list = [ { statement_desc = Debugger; comment = None } ] diff --git a/jscomp/core/js_stmt_make.mli b/jscomp/core/js_stmt_make.mli deleted file mode 100644 index 2aca68a..0000000 --- a/jscomp/core/js_stmt_make.mli +++ /dev/null @@ -1,175 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Creator utilities for the [J] module *) - -type t = J.statement - -(** empty statement, block of length 0 *) -(* val empty_stmt : - t *) - -val throw_stmt : ?comment:string -> J.expression -> t - -val if_ : - ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> - (* when it's not None, we also need make a variable declaration in the - begininnig, however, we can optmize such case - *) - ?else_:J.block -> - J.expression -> - J.block -> - t - -val block : ?comment:string -> J.block -> t -(** - turn a block into a single statement, - avoid nested block -*) - -val int_switch : - ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> - ?default:J.block -> - J.expression -> - (int * J.case_clause) list -> - t -(** [int_switch ~declaration e clauses] - - The [declaration] is attached to peepwhole - such pattern - - {[ - var x ; - x = yy - ]} - - into - {[ - var x = yy; - ]} -*) - -val string_switch : - ?comment:string -> - ?declaration:Lam_compat.let_kind * Ident.t -> - ?default:J.block -> - J.expression -> - (Ast_untagged_variants.tag_type * J.case_clause) list -> - t - -val declare_variable : - ?comment:string -> - ?ident_info:J.ident_info -> - kind:Lam_compat.let_kind -> - Ident.t -> - t -(** Just declaration without initialization *) - -(*** Declaration with initialization *) -val define_variable : - ?comment:string -> - ?ident_info:J.ident_info -> - kind:Lam_compat.let_kind -> - Ident.t -> - J.expression -> - t - -(** created an alias expression *) -(* val alias_variable : - ?comment:string -> - exp:J.expression -> - Ident.t -> - t *) - -val assign : ?comment:string -> J.ident -> J.expression -> t - -(** Used in cases like - {[ - let x = while true do - ... - done in .. - ]} -*) -(* val assign_unit : - ?comment:string -> - J.ident -> - t *) - -(** used in cases like - {[ - let x = while true do - ... - done in .. - ]} -*) -(* val declare_unit : - ?comment:string -> - J.ident -> - t *) - -val while_ : - ?comment:string -> - ?label:J.label -> - ?env:Js_closure.t -> - J.expression -> - J.block -> - t - -val for_ : - ?comment:string -> - ?env:Js_closure.t -> - J.for_ident_expression option -> - J.finish_ident_expression -> - J.for_ident -> - J.for_direction -> - J.block -> - t - -val try_ : - ?comment:string -> - ?with_:J.ident * J.block -> - ?finally:J.block -> - J.block -> - t - -val exp : ?comment:string -> J.expression -> t - -val return_stmt : ?comment:string -> J.expression -> t - -(* val return_unit : t list *) -(** for ocaml function which returns unit - it will be compiled into [return 0] in js *) - -(** if [label] is not set, it will default to empty *) -(* val continue_stmt : - ?comment:string -> - ?label:J.label -> - unit -> - t *) - -val continue_ : t - -val debugger_block : t list diff --git a/jscomp/core/lam.ml b/jscomp/core/lam.ml deleted file mode 100644 index 3838171..0000000 --- a/jscomp/core/lam.ml +++ /dev/null @@ -1,801 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type ident = Ident.t -type apply_status = App_na | App_infer_full | App_uncurry - -type ap_info = { - ap_loc : Location.t; - ap_inlined : Lambda.inline_attribute; - ap_status : apply_status; -} - -module Types = struct - type lambda_switch = { - sw_consts_full : bool; - (* TODO: refine its representation *) - sw_consts : (int * t) list; - sw_blocks_full : bool; - sw_blocks : (int * t) list; - sw_failaction : t option; - sw_names : Ast_untagged_variants.switch_names option; - } - - and lfunction = { - arity : int; - params : ident list; - body : t; - attr : Lambda.function_attribute; - } - - (* - Invariant: - length (sw_consts) <= sw_consts_full - when length (sw_consts) >= sw_consts_full -> true - Note that failaction would appear in both - {[ - match x with - | .. - | .. - | _ -> 2 - ]} - since compiler would first test [x] is a const pointer - or not then the [default] applies to each branch. - - In most cases: {[ - let sw = - {sw_consts_full = cstr.cstr_consts; sw_consts = consts; - sw_blocks_full = cstr.cstr_nonconsts; sw_blocks = nonconsts; - sw_failaction = None} in - ]} - - but there are some edge cases (see https://caml.inria.fr/mantis/view.php?id=6033) - one predicate used is - {[ - (sw.sw_consts_full - List.length sw.sw_consts) + - (sw.sw_blocks_full - List.length sw.sw_blocks) > 1 - ]} - if [= 1] with [some fail] -- called once - if [= 0] could not have [some fail] - *) - and prim_info = { - primitive : Lam_primitive.t; - args : t list; - loc : Location.t; - } - - and apply = { ap_func : t; ap_args : t list; ap_info : ap_info } - - and t = - | Lvar of ident - | Lglobal_module of ident * bool - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lassign of ident * t - (* | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t *) -end - -module X = struct - type lambda_switch = Types.lambda_switch = { - sw_consts_full : bool; - sw_consts : (int * t) list; - sw_blocks_full : bool; - sw_blocks : (int * t) list; - sw_failaction : t option; - sw_names : Ast_untagged_variants.switch_names option; - } - - and prim_info = Types.prim_info = { - primitive : Lam_primitive.t; - args : t list; - loc : Location.t; - } - - and apply = Types.apply = { ap_func : t; ap_args : t list; ap_info : ap_info } - - and lfunction = Types.lfunction = { - arity : int; - params : ident list; - body : t; - attr : Lambda.function_attribute; - } - - and t = Types.t = - | Lvar of ident - | Lglobal_module of ident * bool - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lassign of ident * t - (* | Lsend of Lam_compat.meth_kind * t * t * t list * Location.t *) -end - -include Types - -(** apply [f] to direct successor which has type [Lam.t] *) - -let inner_map (l : t) (f : t -> X.t) : X.t = - match l with - | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> ((* Obj.magic *) l : X.t) - | Lapply { ap_func; ap_args; ap_info } -> - let ap_func = f ap_func in - let ap_args = Ext_list.map ap_args f in - Lapply { ap_func; ap_args; ap_info } - | Lfunction { body; arity; params; attr } -> - let body = f body in - Lfunction { body; arity; params; attr } - | Llet (str, id, arg, body) -> - let arg = f arg in - let body = f body in - Llet (str, id, arg, body) - | Lletrec (decl, body) -> - let body = f body in - let decl = Ext_list.map_snd decl f in - Lletrec (decl, body) - | Lglobal_module _ -> (l : X.t) - | Lprim { args; primitive; loc } -> - let args = Ext_list.map args f in - Lprim { args; primitive; loc } - | Lswitch - ( arg, - { - sw_consts; - sw_consts_full; - sw_blocks; - sw_blocks_full; - sw_failaction; - sw_names; - } ) -> - let arg = f arg in - let sw_consts = Ext_list.map_snd sw_consts f in - let sw_blocks = Ext_list.map_snd sw_blocks f in - let sw_failaction = Ext_option.map sw_failaction f in - Lswitch - ( arg, - { - sw_consts; - sw_blocks; - sw_failaction; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) - | Lstringswitch (arg, cases, default) -> - let arg = f arg in - let cases = Ext_list.map_snd cases f in - let default = Ext_option.map default f in - Lstringswitch (arg, cases, default) - | Lstaticraise (id, args) -> - let args = Ext_list.map args f in - Lstaticraise (id, args) - | Lstaticcatch (e1, vars, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lstaticcatch (e1, vars, e2) - | Ltrywith (e1, exn, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Ltrywith (e1, exn, e2) - | Lifthenelse (e1, e2, e3) -> - let e1 = f e1 in - let e2 = f e2 in - let e3 = f e3 in - Lifthenelse (e1, e2, e3) - | Lsequence (e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lsequence (e1, e2) - | Lwhile (e1, e2) -> - let e1 = f e1 in - let e2 = f e2 in - Lwhile (e1, e2) - | Lfor (v, e1, e2, dir, e3) -> - let e1 = f e1 in - let e2 = f e2 in - let e3 = f e3 in - Lfor (v, e1, e2, dir, e3) - | Lassign (id, e) -> - let e = f e in - Lassign (id, e) -(* | Lsend (k, met, obj, args, loc) -> - let met = f met in - let obj = f obj in - let args = Ext_list.map args f in - Lsend(k,met,obj,args,loc) *) - -exception Not_simple_form - -(** - - - [is_eta_conversion_exn params inner_args outer_args] - case 1: - {{ - (fun params -> wrap (primitive (inner_args)) args - }} - when [inner_args] are the same as [params], it can be simplified as - [wrap (primitive args)] - - where [wrap] used to be simple instructions - Note that [external] functions are forced to do eta-conversion - when combined with [|>] operator, we need to make sure beta-reduction - is applied though since `[@variadic]` needs such guarantee. - Since `[@variadic] is the tail position -*) -let rec is_eta_conversion_exn params inner_args outer_args : t list = - match (params, inner_args, outer_args) with - | x :: xs, Lvar y :: ys, r :: rest when Ident.same x y -> - r :: is_eta_conversion_exn xs ys rest - | ( x :: xs, - Lprim ({ primitive = Pjs_fn_make _ | Pjs_fn_make_unit; args = [ Lvar y ] } as p) :: ys, - r :: rest ) - when Ident.same x y -> - Lprim { p with args = [ r ] } :: is_eta_conversion_exn xs ys rest - | [], [], [] -> [] - | _, _, _ -> raise_notrace Not_simple_form - -(** FIXME: more robust inlining check later, we should inline it before we add stub code*) -let rec apply fn args (ap_info : ap_info) : t = - match fn with - | Lfunction - { - params; - body = - Lprim - { - primitive = - ( Pundefined_to_opt | Pnull_to_opt | Pnull_undefined_to_opt - | Pis_null | Pis_null_undefined | Pjs_typeof ) as wrap; - args = - [ - Lprim ({ primitive = _; args = inner_args } as primitive_call); - ]; - }; - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - let loc = ap_info.ap_loc in - Lprim - { - primitive = wrap; - args = [ Lprim { primitive_call with args; loc } ]; - loc; - } - | exception Not_simple_form -> - Lapply { ap_func = fn; ap_args = args; ap_info }) - | Lfunction - { - params; - body = Lprim ({ primitive = _; args = inner_args } as primitive_call); - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> Lprim { primitive_call with args; loc = ap_info.ap_loc } - | exception _ -> Lapply { ap_func = fn; ap_args = args; ap_info }) - | Lfunction - { - params; - body = - Lsequence - ( Lprim ({ primitive = _; args = inner_args } as primitive_call), - (Lconst _ as const) ); - } -> ( - match is_eta_conversion_exn params inner_args args with - | args -> - Lsequence - (Lprim { primitive_call with args; loc = ap_info.ap_loc }, const) - | exception _ -> - Lapply { ap_func = fn; ap_args = args; ap_info } - (* | Lfunction {params;body} when Ext_list.same_length params args -> - Ext_list.fold_right2 (fun p arg acc -> - Llet(Strict,p,arg,acc) - ) params args body *) - (* TODO: more rigirous analysis on [let_kind] *)) - | Llet (kind, id, e, (Lfunction _ as fn)) -> - Llet (kind, id, e, apply fn args ap_info) - (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> - Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) - | _ -> Lapply { ap_func = fn; ap_args = args; ap_info } - -let rec eq_approx (l1 : t) (l2 : t) = - match l1 with - | Lglobal_module (i1, b1) -> ( - match l2 with Lglobal_module (i2, b2) -> Ident.same i1 i2 && b1 = b2 | _ -> false) - | Lvar i1 -> ( match l2 with Lvar i2 -> Ident.same i1 i2 | _ -> false) - | Lconst c1 -> ( - match l2 with Lconst c2 -> Lam_constant.eq_approx c1 c2 | _ -> false) - | Lapply app1 -> ( - match l2 with - | Lapply app2 -> - eq_approx app1.ap_func app2.ap_func - && eq_approx_list app1.ap_args app2.ap_args - | _ -> false) - | Lifthenelse (a, b, c) -> ( - match l2 with - | Lifthenelse (a0, b0, c0) -> - eq_approx a a0 && eq_approx b b0 && eq_approx c c0 - | _ -> false) - | Lsequence (a, b) -> ( - match l2 with - | Lsequence (a0, b0) -> eq_approx a a0 && eq_approx b b0 - | _ -> false) - | Lwhile (p, b) -> ( - match l2 with - | Lwhile (p0, b0) -> eq_approx p p0 && eq_approx b b0 - | _ -> false) - | Lassign (v0, l0) -> ( - match l2 with - | Lassign (v1, l1) -> Ident.same v0 v1 && eq_approx l0 l1 - | _ -> false) - | Lstaticraise (id, ls) -> ( - match l2 with - | Lstaticraise (id1, ls1) -> id = id1 && eq_approx_list ls ls1 - | _ -> false) - | Lprim info1 -> ( - match l2 with - | Lprim info2 -> - Lam_primitive.eq_primitive_approx info1.primitive info2.primitive - && eq_approx_list info1.args info2.args - | _ -> false) - | Lstringswitch (arg, patterns, default) -> ( - match l2 with - | Lstringswitch (arg2, patterns2, default2) -> - eq_approx arg arg2 && eq_option default default2 - && Ext_list.for_all2_no_exn patterns patterns2 - (fun ((k : string), v) (k2, v2) -> k = k2 && eq_approx v v2) - | _ -> false) - | Lfunction _ - | Llet (_, _, _, _) - | Lletrec _ | Lswitch _ | Lstaticcatch _ | Ltrywith _ - | Lfor (_, _, _, _, _) -> - false - -and eq_option l1 l2 = - match l1 with - | None -> l2 = None - | Some l1 -> ( match l2 with Some l2 -> eq_approx l1 l2 | None -> false) - -and eq_approx_list ls ls1 = Ext_list.for_all2_no_exn ls ls1 eq_approx - -let switch lam (lam_switch : lambda_switch) : t = - match lam with - | Lconst (Const_int { i }) -> - (* Because of inlining and dead code, we might be looking at a value of unexpected type - e.g. an integer, so the const case might not be found *) - (try - Ext_list.assoc_by_int lam_switch.sw_consts (Int32.to_int i) lam_switch.sw_failaction - with _ -> Lswitch(lam, lam_switch)) - | Lconst (Const_block (i, _, _)) -> - (try Ext_list.assoc_by_int lam_switch.sw_blocks i lam_switch.sw_failaction - with _ -> Lswitch(lam, lam_switch)) - | _ -> Lswitch (lam, lam_switch) - -let stringswitch (lam : t) cases default : t = - match lam with - | Lconst (Const_string { s; unicode = false }) -> - Ext_list.assoc_by_string cases s default - | _ -> Lstringswitch (lam, cases, default) - -let true_ : t = Lconst Const_js_true -let false_ : t = Lconst Const_js_false -let unit : t = Lconst (Const_js_undefined {isUnit = true}) - -let rec seq (a : t) b : t = - match a with - | Lprim { primitive = Pmakeblock _; args = x :: xs } -> - seq (Ext_list.fold_left xs x seq) b - | Lprim - { - primitive = Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt; - args = [ a ]; - } -> - seq a b - | _ -> Lsequence (a, b) - -let var id : t = Lvar id -let global_module ?(dynamic_import = false) id = Lglobal_module (id, dynamic_import) -let const ct : t = Lconst ct - -let function_ ~attr ~arity ~params ~body : t = - Lfunction { arity; params; body; attr } - -let let_ kind id e body : t = Llet (kind, id, e, body) -let letrec bindings body : t = Lletrec (bindings, body) -let while_ a b : t = Lwhile (a, b) -let try_ body id handler : t = Ltrywith (body, id, handler) -let for_ v e1 e2 dir e3 : t = Lfor (v, e1, e2, dir, e3) -let assign v l : t = Lassign (v, l) -let staticcatch a b c : t = Lstaticcatch (a, b, c) -let staticraise a b : t = Lstaticraise (a, b) - -module Lift = struct - let int i : t = Lconst (Const_int { i; comment = None }) - - (* let int32 i : t = - Lconst ((Const_int32 i)) *) - - let bool b = if b then true_ else false_ - - (* ATTENTION: [float, nativeint] constant propogaton is not done - yet , due to cross platform problem - *) - (* let float b : t = - Lconst ((Const_float b)) *) - - (* let nativeint b : t = - Lconst ((Const_nativeint b)) *) - - let int64 b : t = Lconst (Const_int64 b) - let string s : t = Lconst (Const_string { s; unicode = false }) - let char b : t = Lconst (Const_char b) -end - -let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t = - let default () : t = Lprim { primitive = prim; args; loc } in - match args with - | [ Lconst a ] -> ( - match (prim, a) with - | Pnegint, Const_int { i } -> Lift.int (Int32.neg i) - (* | Pfloatofint, ( (Const_int a)) *) - (* -> Lift.float (float_of_int a) *) - | Pintoffloat, Const_float a -> - Lift.int (Int32.of_float (float_of_string a)) - (* | Pnegfloat -> Lift.float (-. a) *) - (* | Pabsfloat -> Lift.float (abs_float a) *) - | Pstringlength, Const_string { s; unicode = false } -> - Lift.int (Int32.of_int (String.length s)) - (* | Pnegbint Pnativeint, ( (Const_nativeint i)) *) - (* -> *) - (* Lift.nativeint (Nativeint.neg i) *) - | Pnegint64, Const_int64 a -> Lift.int64 (Int64.neg a) - | Pnot, Const_js_true -> false_ - | Pnot, Const_js_false -> true_ - | _ -> default ()) - | [ Lconst a; Lconst b ] -> ( - match (prim, a, b) with - | Pint64comp cmp, Const_int64 a, Const_int64 b -> - Lift.bool (Lam_compat.cmp_int64 cmp a b) - | Pintcomp cmp, Const_int a, Const_int b -> - Lift.bool (Lam_compat.cmp_int32 cmp a.i b.i) - | Pfloatcomp cmp, Const_float a, Const_float b -> - (* FIXME: could raise? *) - Lift.bool - (Lam_compat.cmp_float cmp (float_of_string a) (float_of_string b)) - | Pbigintcomp cmp, Const_bigint _, Const_bigint _ -> default () - | Pintcomp ((Ceq | Cneq) as op), Const_pointer a, Const_pointer b -> - Lift.bool - (match op with - | Ceq -> a = (b : string) - | Cneq -> a <> b - | _ -> assert false) - | ( ( Paddint | Psubint | Pmulint | Pdivint | Pmodint | Pandint | Porint - | Pxorint | Plslint | Plsrint | Pasrint ), - Const_int { i = aa }, - Const_int { i = bb } ) -> ( - (* WE SHOULD keep it as [int], to preserve types *) - let int_ = Lift.int in - match prim with - | Paddint -> int_ (Int32.add aa bb) - | Psubint -> int_ (Int32.sub aa bb) - | Pmulint -> int_ (Int32.mul aa bb) - | Pdivint -> if bb = 0l then default () else int_ (Int32.div aa bb) - | Pmodint -> if bb = 0l then default () else int_ (Int32.rem aa bb) - | Pandint -> int_ (Int32.logand aa bb) - | Porint -> int_ (Int32.logor aa bb) - | Pxorint -> int_ (Int32.logxor aa bb) - | Plslint -> int_ (Int32.shift_left aa (Int32.to_int bb)) - | Plsrint -> int_ (Int32.shift_right_logical aa (Int32.to_int bb)) - | Pasrint -> int_ (Int32.shift_right aa (Int32.to_int bb)) - | _ -> default ()) - | ( ( Paddint64 | Psubint64 | Pmulint64 | Pdivint64 | Pmodint64 - | Pandint64 | Porint64 | Pxorint64 ), - Const_int64 aa, - Const_int64 bb ) -> ( - match prim with - | Paddint64 -> Lift.int64 (Int64.add aa bb) - | Psubint64 -> Lift.int64 (Int64.sub aa bb) - | Pmulint64 -> Lift.int64 (Int64.mul aa bb) - | Pdivint64 -> ( - try Lift.int64 (Int64.div aa bb) with _ -> default ()) - | Pmodint64 -> ( - try Lift.int64 (Int64.rem aa bb) with _ -> default ()) - | Pandint64 -> Lift.int64 (Int64.logand aa bb) - | Porint64 -> Lift.int64 (Int64.logor aa bb) - | Pxorint64 -> Lift.int64 (Int64.logxor aa bb) - | _ -> default ()) - | Plslint64, Const_int64 aa, Const_int { i = b } -> - Lift.int64 (Int64.shift_left aa (Int32.to_int b)) - | Plsrint64, Const_int64 aa, Const_int { i = b } -> - Lift.int64 (Int64.shift_right_logical aa (Int32.to_int b)) - | Pasrint64, Const_int64 aa, Const_int { i = b } -> - Lift.int64 (Int64.shift_right aa (Int32.to_int b)) - | Psequand, Const_js_false, (Const_js_true | Const_js_false) -> false_ - | Psequand, Const_js_true, Const_js_true -> true_ - | Psequand, Const_js_true, Const_js_false -> false_ - | Psequor, Const_js_true, (Const_js_true | Const_js_false) -> true_ - | Psequor, Const_js_false, Const_js_true -> true_ - | Psequor, Const_js_false, Const_js_false -> false_ - | ( Pstringadd, - Const_string { s = a; unicode = false }, - Const_string { s = b; unicode = false } ) -> - Lift.string (a ^ b) - | ( (Pstringrefs | Pstringrefu), - Const_string { s = a; unicode = false }, - Const_int { i = b } ) -> ( - try Lift.char (Char.code (String.get a (Int32.to_int b))) with _ -> default ()) - | _ -> default ()) - | _ -> ( - match prim with - | Pmakeblock (_size, Blk_module fields, _) -> ( - let rec aux fields args (var : Ident.t) i = - match (fields, args) with - | [], [] -> true - | ( f :: fields, - Lprim - { - primitive = Pfield (pos, Fld_module { name = f1 }); - args = [ (Lglobal_module (v1, _) | Lvar v1) ]; - } - :: args ) -> - pos = i && f = f1 && Ident.same var v1 - && aux fields args var (i + 1) - | _, _ -> false - in - match (fields, args) with - | ( field1 :: rest, - Lprim - { - primitive = Pfield (pos, Fld_module { name = f1 }); - args = [ ((Lglobal_module (v1, _) | Lvar v1) as lam) ]; - } - :: args1 ) -> - if pos = 0 && field1 = f1 && aux rest args1 v1 1 then lam - else default () - | _ -> default ()) - (* In this level, include is already expanded, so that - {[ - { x0 : y0 ; x1 : y1 } - ]} - such module x can indeed be replaced by module y - *) - | _ -> default ()) - -let not_ loc x : t = - match x with - | Lprim ({ primitive = Pintcomp Cneq } as prim) -> - Lprim { prim with primitive = Pintcomp Ceq } - | _ -> prim ~primitive:Pnot ~args:[ x ] loc - -let has_boolean_type (x : t) = - match x with - | Lprim - { - primitive = - ( Pnot | Psequand | Psequor | Pisout _ | Pintcomp _ | Pis_not_none - | Pfloatcomp _ - | Pccall { prim_name = "caml_string_equal" | "caml_string_notequal" } - ); - loc; - } -> - Some loc - | _ -> None - -(** [complete_range sw_consts 0 7] - is complete with [0,1,.. 7] -*) -let rec complete_range (sw_consts : (int * _) list) ~(start : int) ~finish = - match sw_consts with - | [] -> finish < start - | (i, _) :: rest -> - start <= finish && i = start - && complete_range rest ~start:(start + 1) ~finish - -let rec eval_const_as_bool (v : Lam_constant.t) : bool = - match v with - | Const_int { i = x } -> x <> 0l - | Const_char x -> x <> 0 - | Const_int64 x -> x <> 0L - | Const_js_false | Const_js_null | Const_module_alias | Const_js_undefined _ -> - false - | Const_js_true | Const_string _ | Const_pointer _ | Const_float _ | Const_bigint _ - | Const_block _ | Const_float_array _ -> - true - | Const_some b -> eval_const_as_bool b - -let if_ (a : t) (b : t) (c : t) : t = - match a with - | Lconst v -> if eval_const_as_bool v then b else c - | _ -> ( - match (b, c) with - | _, Lconst (Const_int { comment = Pt_assertfalse }) -> - seq a b (* TODO: we could customize more cases *) - | Lconst (Const_int { comment = Pt_assertfalse }), _ -> seq a c - | Lconst Const_js_true, Lconst Const_js_false -> - if has_boolean_type a != None then a else Lifthenelse (a, b, c) - | Lconst Const_js_false, Lconst Const_js_true -> ( - match has_boolean_type a with - | Some loc -> not_ loc a - | None -> Lifthenelse (a, b, c)) - | Lprim { primitive = Praise }, _ -> ( - match c with - | Lconst _ -> Lifthenelse (a, b, c) - | _ -> seq (Lifthenelse (a, b, unit)) c) - | _ -> ( - match a with - | Lprim - { - primitive = Pisout off; - args = [ Lconst (Const_int { i = range }); Lvar xx ]; - } -> ( - let range = Int32.to_int range in - match c with - | Lswitch - ( (Lvar yy as switch_arg), - ({ - sw_blocks = []; - sw_blocks_full = true; - sw_consts; - sw_consts_full = _; - sw_failaction = None; - } as body) ) - when Ident.same xx yy - && complete_range sw_consts ~start:(-off) - ~finish:(range - off) -> - Lswitch - ( switch_arg, - { - body with - sw_failaction = Some b; - sw_consts_full = false; - } ) - | _ -> Lifthenelse (a, b, c)) - | Lprim { primitive = Pisint; args = [ Lvar i ]; _ } -> ( - match b with - | Lifthenelse - ( Lprim - { primitive = Pintcomp Ceq; args = [ Lvar j; Lconst _ ] }, - _, - b_f ) - when Ident.same i j && eq_approx b_f c -> - b - | Lprim { primitive = Pintcomp Ceq; args = [ Lvar j; Lconst _ ] } - when Ident.same i j && eq_approx false_ c -> - b - | Lifthenelse - ( Lprim - ({ - primitive = Pintcomp Cneq; - args = [ Lvar j; Lconst _ ]; - } as b_pred), - b_t, - b_f ) - when Ident.same i j && eq_approx b_t c -> - Lifthenelse - (Lprim { b_pred with primitive = Pintcomp Ceq }, b_f, b_t) - | Lprim - { - primitive = Pintcomp Cneq; - args = [ Lvar j; Lconst _ ] as args; - loc; - } - | Lprim - { - primitive = Pnot; - args = - [ - Lprim - { - primitive = Pintcomp Ceq; - args = [ Lvar j; Lconst _ ] as args; - loc; - }; - ]; - } - when Ident.same i j && eq_approx true_ c -> - Lprim { primitive = Pintcomp Cneq; args; loc } - | _ -> Lifthenelse (a, b, c)) - | _ -> Lifthenelse (a, b, c))) - -(* TODO: the smart constructor is not exploited yet*) -(* [l || r ] *) -let sequor l r = if_ l true_ r - -(** [l && r ] *) -let sequand l r = if_ l r false_ - -(******************************************************************) -(* only [handle_bs_non_obj_ffi] will be used outside *) -(* - [no_auto_uncurried_arg_types xs] - check if the FFI have @uncurry attribute. - if it does not we wrap it in a nomral way otherwise -*) -let rec no_auto_uncurried_arg_types (xs : External_arg_spec.params) = - match xs with - | [] -> true - | { arg_type = Fn_uncurry_arity _ } :: _ -> false - | _ :: xs -> no_auto_uncurried_arg_types xs - -let result_wrap loc (result_type : External_ffi_types.return_wrapper) result = - match result_type with - | Return_replaced_with_unit -> seq result unit - | Return_null_to_opt -> prim ~primitive:Pnull_to_opt ~args:[ result ] loc - | Return_null_undefined_to_opt -> - prim ~primitive:Pnull_undefined_to_opt ~args:[ result ] loc - | Return_undefined_to_opt -> - prim ~primitive:Pundefined_to_opt ~args:[ result ] loc - | Return_unset | Return_identity -> result - -let rec transform_uncurried_arg_type loc (arg_types : External_arg_spec.params) - (args : t list) = - match (arg_types, args) with - | { arg_type = Fn_uncurry_arity n; arg_label } :: xs, y :: ys -> - let o_arg_types, o_args = transform_uncurried_arg_type loc xs ys in - ( { External_arg_spec.arg_type = Nothing; arg_label } :: o_arg_types, - prim ~primitive:(Pjs_fn_make n) ~args:[ y ] loc :: o_args ) - | x :: xs, y :: ys -> ( - match x with - | { arg_type = Arg_cst _ } -> - let o_arg_types, o_args = transform_uncurried_arg_type loc xs args in - (x :: o_arg_types, o_args) - | _ -> - let o_arg_types, o_args = transform_uncurried_arg_type loc xs ys in - (x :: o_arg_types, y :: o_args)) - | ([], [] | _ :: _, [] | [], _ :: _) as ok -> ok - -let handle_bs_non_obj_ffi (arg_types : External_arg_spec.params) - (result_type : External_ffi_types.return_wrapper) ffi args loc prim_name ~dynamic_import = - if no_auto_uncurried_arg_types arg_types then - result_wrap loc result_type - (prim ~primitive:(Pjs_call { prim_name; arg_types; ffi; dynamic_import }) ~args loc) - else - let n_arg_types, n_args = transform_uncurried_arg_type loc arg_types args in - result_wrap loc result_type - (prim - ~primitive:(Pjs_call { prim_name; arg_types = n_arg_types; ffi; dynamic_import }) - ~args:n_args loc) diff --git a/jscomp/core/lam.mli b/jscomp/core/lam.mli deleted file mode 100644 index cc76e5b..0000000 --- a/jscomp/core/lam.mli +++ /dev/null @@ -1,163 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type apply_status = App_na | App_infer_full | App_uncurry - -type ap_info = { - ap_loc : Location.t; - ap_inlined : Lambda.inline_attribute; - ap_status : apply_status; -} - -type ident = Ident.t - -type lambda_switch = { - sw_consts_full : bool; - sw_consts : (int * t) list; - sw_blocks_full : bool; - sw_blocks : (int * t) list; - sw_failaction : t option; - sw_names : Ast_untagged_variants.switch_names option; -} - -and apply = private { ap_func : t; ap_args : t list; ap_info : ap_info } - -and lfunction = { - arity : int; - params : ident list; - body : t; - attr : Lambda.function_attribute; -} - -and prim_info = private { - primitive : Lam_primitive.t; - args : t list; - loc : Location.t; -} - -and t = private - | Lvar of ident - | Lglobal_module of ident * bool - | Lconst of Lam_constant.t - | Lapply of apply - | Lfunction of lfunction - | Llet of Lam_compat.let_kind * ident * t * t - | Lletrec of (ident * t) list * t - | Lprim of prim_info - | Lswitch of t * lambda_switch - | Lstringswitch of t * (string * t) list * t option - | Lstaticraise of int * t list - | Lstaticcatch of t * (int * ident list) * t - | Ltrywith of t * ident * t - | Lifthenelse of t * t * t - | Lsequence of t * t - | Lwhile of t * t - | Lfor of ident * t * t * Asttypes.direction_flag * t - | Lassign of ident * t - -(* | Lsend of Lambda.meth_kind * t * t * t list * Location.t *) -(* | Levent of t * Lambda.lambda_event - [Levent] in the branch hurt pattern match, - we should use record for trivial debugger info -*) - -val inner_map : t -> (t -> t) -> t - -val handle_bs_non_obj_ffi : - External_arg_spec.params -> - External_ffi_types.return_wrapper -> - External_ffi_types.external_spec -> - t list -> - Location.t -> - string -> - dynamic_import: bool -> - t - -(**************************************************************) - -val var : ident -> t -(** Smart constructors *) - -val global_module : ?dynamic_import:bool -> ident -> t - -val const : Lam_constant.t -> t - -val apply : t -> t list -> ap_info -> t - -val function_ : - attr:Lambda.function_attribute -> - arity:int -> - params:ident list -> - body:t -> - t - -val let_ : Lam_compat.let_kind -> ident -> t -> t -> t - -val letrec : (ident * t) list -> t -> t - -val if_ : t -> t -> t -> t -(** constant folding *) - -val switch : t -> lambda_switch -> t -(** constant folding*) - -val stringswitch : t -> (string * t) list -> t option -> t -(** constant folding*) - -(* val true_ : t *) -val false_ : t - -val unit : t - -val sequor : t -> t -> t -(** convert [l || r] to [if l then true else r]*) - -val sequand : t -> t -> t -(** convert [l && r] to [if l then r else false *) - -val not_ : Location.t -> t -> t -(** constant folding *) - -val seq : t -> t -> t -(** drop unused block *) - -val while_ : t -> t -> t - -(* val event : t -> Lambda.lambda_event -> t *) -val try_ : t -> ident -> t -> t - -val assign : ident -> t -> t - -val prim : primitive:Lam_primitive.t -> args:t list -> Location.t -> t -(** constant folding *) - -val staticcatch : t -> int * ident list -> t -> t - -val staticraise : int -> t list -> t - -val for_ : ident -> t -> t -> Asttypes.direction_flag -> t -> t - -(**************************************************************) - -val eq_approx : t -> t -> bool diff --git a/jscomp/core/lam_analysis.ml b/jscomp/core/lam_analysis.ml deleted file mode 100644 index 329352a..0000000 --- a/jscomp/core/lam_analysis.ml +++ /dev/null @@ -1,279 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(**used in effect analysis, it is sound but not-complete *) -let not_zero_constant (x : Lam_constant.t) = - match x with - | Const_int { i } -> i <> 0l - | Const_int64 i -> i <> 0L - | Const_bigint (_, i) -> i <> "0" - | _ -> false - -let rec no_side_effects (lam : Lam.t) : bool = - match lam with - | Lvar _ | Lconst _ | Lfunction _ -> true - | Lglobal_module _ -> true - (* we record side effect in the global level, - this expression itself is side effect free - *) - | Lprim { primitive; args; _ } -> ( - Ext_list.for_all args no_side_effects - && - match primitive with - | Pccall { prim_name } -> ( - match (prim_name, args) with - | ( (* register to c runtime does not make sense in ocaml *) - ( "?int64_float_of_bits" - (* more safe to check if arguments are constant *) - (* non-observable side effect *) - | "?sys_get_argv" (* should be fine *) - | "?string_repeat" | "?make_vect" | "?create_bytes" | "?obj_dup" - | "caml_array_dup" | "?nativeint_add" | "?nativeint_div" - | "?nativeint_mod" | "?nativeint_lsr" | "?nativeint_mul" ), - _ ) -> - true - | _, _ -> false) - | Pmodint | Pdivint | Pdivint64 | Pmodint64 | Pdivbigint | Pmodbigint -> ( - match args with - | [ _; Lconst cst ] -> not_zero_constant cst - | _ -> false) - | Pcreate_extension _ | Pjs_typeof | Pis_null | Pis_not_none | Psome - | Psome_not_nest | Pis_undefined | Pis_null_undefined | Pnull_to_opt - | Pundefined_to_opt | Pnull_undefined_to_opt | Pjs_fn_make _ | Pjs_fn_make_unit - | Pjs_object_create _ | Pimport - (* TODO: check *) - | Pbytes_to_string | Pmakeblock _ - (* whether it's mutable or not *) - | Pfield _ | Pval_from_option | Pval_from_option_not_nest - (* NOP The compiler already [t option] is the same as t *) - | Pduprecord - (* Boolean operations *) - | Psequand | Psequor | Pnot - (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint | Pintcomp _ - (* Float operations *) - | Pintoffloat | Pfloatofint | Pnegfloat - (* | Pabsfloat *) - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat | Pfloatcomp _ | Pjscomp _ - | Pnegbigint | Paddbigint | Psubbigint | Pmulbigint | Ppowbigint - | Pandbigint | Porbigint | Pxorbigint | Plslbigint | Pasrbigint - | Pbigintcomp _ - (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs | Pbyteslength | Pbytesrefu - | Pbytesrefs | Pmakearray | Parraylength | Parrayrefu | Parrayrefs - (* Test if the argument is a block or an immediate integer *) - | Pisint | Pis_poly_var_block - (* Test if the (integer) argument is outside an interval *) - | Pisout _ | Pint64ofint | Pintofint64 | Pnegint64 | Paddint64 | Psubint64 - | Pmulint64 | Pandint64 | Porint64 | Pxorint64 | Plslint64 | Plsrint64 - | Pasrint64 | Pint64comp _ - (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *) - (* Compile time constants *) - | Pctconst _ (* Integer to external pointer *) - | Poffsetint _ | Pstringadd | Pjs_function_length | Pcaml_obj_length - | Pwrap_exn - | Praw_js_code - { - code_info = - Exp (Js_function _ | Js_literal _) | Stmt Js_stmt_comment; - } -> - true - | Pjs_apply | Pjs_runtime_apply | Pjs_call _ | Pinit_mod | Pupdate_mod - | Pjs_unsafe_downgrade _ | Pdebugger | Pvoid_run | Pfull_apply - | Pjs_fn_method - (* TODO *) - | Praw_js_code _ | Pbytessetu | Pbytessets - (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) - | Parraysets - (* byte swap *) - | Parraysetu | Poffsetref _ | Praise | Plazyforce | Psetfield _ -> - false) - | Llet (_, _, arg, body) -> no_side_effects arg && no_side_effects body - | Lswitch (_, _) -> false - | Lstringswitch (_, _, _) -> false - | Lstaticraise _ -> false - | Lstaticcatch _ -> false - (* It would be nice that we can also analysis some small functions - for example [String.contains], - [Format.make_queue_elem] - *) - | Ltrywith (body, _exn, handler) -> - no_side_effects body && no_side_effects handler - | Lifthenelse (a, b, c) -> - no_side_effects a && no_side_effects b && no_side_effects c - | Lsequence (a, b) -> no_side_effects a && no_side_effects b - | Lletrec (bindings, body) -> - Ext_list.for_all_snd bindings no_side_effects && no_side_effects body - | Lwhile _ -> - false (* conservative here, non-terminating loop does have side effect *) - | Lfor _ -> false - | Lassign _ -> false (* actually it depends ... *) - (* | Lsend _ -> false *) - | Lapply - { - ap_func = - Lprim { primitive = Pfield (_, Fld_module { name = "from_fun" }) }; - ap_args = [ arg ]; - } -> - no_side_effects arg - | Lapply _ -> false -(* we need purity analysis .. *) - -(* - Estimate the size of lambda for better inlining - threshold is 1000 - so that we -*) -exception Too_big_to_inline - -let really_big () = raise_notrace Too_big_to_inline - -(* let big_lambda = 1000 *) - -let rec size (lam : Lam.t) = - try - match lam with - | Lvar _ -> 1 - | Lconst c -> size_constant c - | Llet (_, _, l1, l2) -> 1 + size l1 + size l2 - | Lletrec _ -> really_big () - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - 1 - | Lprim { primitive = Praise | Pis_not_none; args = [ l ]; _ } -> size l - | Lglobal_module _ -> 1 - | Lprim { primitive = Praw_js_code _ } -> really_big () - | Lprim { args = ll; _ } -> size_lams 1 ll - (* complicated - 1. inline this function - 2. ... - exports.Make= - function(funarg) - {var $$let=Make(funarg); - return [0, $$let[5],... $$let[16]]} - *) - | Lapply { ap_func; ap_args; _ } -> size_lams (size ap_func) ap_args - (* | Lfunction(_, params, l) -> really_big () *) - | Lfunction { body } -> size body - | Lswitch _ -> really_big () - | Lstringswitch (_, _, _) -> really_big () - | Lstaticraise (_i, ls) -> - Ext_list.fold_left ls 1 (fun acc x -> size x + acc) - | Lstaticcatch _ -> really_big () - | Ltrywith _ -> really_big () - | Lifthenelse (l1, l2, l3) -> 1 + size l1 + size l2 + size l3 - | Lsequence (l1, l2) -> size l1 + size l2 - | Lwhile _ -> really_big () - | Lfor _ -> really_big () - | Lassign (_, v) -> 1 + size v - (* This is side effectful, be careful *) - (* | Lsend _ -> really_big () *) - with Too_big_to_inline -> 1000 - -and size_constant x = - match x with - | Const_int _ | Const_char _ | Const_float _ | Const_int64 _ | Const_bigint _ | Const_pointer _ - | Const_js_null | Const_js_undefined _ | Const_module_alias | Const_js_true - | Const_js_false -> - 1 - | Const_string _ -> - 1 - | Const_some s -> size_constant s - | Const_block (_, _, str) -> - Ext_list.fold_left str 0 (fun acc x -> acc + size_constant x) - | Const_float_array xs -> List.length xs - -and size_lams acc (lams : Lam.t list) = - Ext_list.fold_left lams acc (fun acc l -> acc + size l) - -let args_all_const (args : Lam.t list) = - Ext_list.for_all args (fun x -> match x with Lconst _ -> true | _ -> false) - -let exit_inline_size = 7 - -let small_inline_size = 5 - -(** destruct pattern will work better - if it is closed lambda, otherwise - you can not do full evaluation - - We still should avoid inline too big code, - - ideally we should also evaluate its size after inlining, - since after partial evaluation, it might still be *very big* -*) -let destruct_pattern (body : Lam.t) params args = - let rec aux v params args = - match (params, args) with - | x :: xs, b :: bs -> if Ident.same x v then Some b else aux v xs bs - | [], _ -> None - | _ :: _, [] -> assert false - in - match body with - | Lswitch (Lvar v, switch) -> ( - match aux v params args with - | Some (Lam.Lconst _ as lam) -> - size (Lam.switch lam switch) < small_inline_size - | Some _ | None -> false) - | Lifthenelse (Lvar v, then_, else_) -> ( - (* -FIXME *) - match aux v params args with - | Some (Lconst _ as lam) -> - size (Lam.if_ lam then_ else_) < small_inline_size - | Some _ | None -> false) - | _ -> false - -(* Async functions cannot be beta reduced *) -let lfunction_can_be_beta_reduced (lfunction : Lam.lfunction) = - not lfunction.attr.async - -(** Hints to inlining *) -let ok_to_inline_fun_when_app (m : Lam.lfunction) (args : Lam.t list) = - match m.attr.inline with - | Always_inline -> true - | Never_inline -> false - | Default_inline -> ( - match m with - | { body; params } -> - let s = size body in - s < small_inline_size - || destruct_pattern body params args - || (args_all_const args && s < 10 && no_side_effects body)) - -(* TODO: We can relax this a bit later, - but decide whether to inline it later in the call site -*) -let safe_to_inline (lam : Lam.t) = - match lam with - | Lfunction _ -> true - | Lconst - ( Const_pointer _ - | Const_int { comment = Pt_constructor _ } - | Const_js_true | Const_js_false | Const_js_undefined _ ) -> - true - | _ -> false diff --git a/jscomp/core/lam_analysis.mli b/jscomp/core/lam_analysis.mli deleted file mode 100644 index a6105b8..0000000 --- a/jscomp/core/lam_analysis.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A module which provides some basic analysis over lambda expression *) - -val no_side_effects : Lam.t -> bool -(** No side effect, but it might depend on data store *) - -val size : Lam.t -> int - -val lfunction_can_be_beta_reduced : Lam.lfunction -> bool - -val ok_to_inline_fun_when_app : Lam.lfunction -> Lam.t list -> bool - -val small_inline_size : int - -val exit_inline_size : int - -val safe_to_inline : Lam.t -> bool diff --git a/jscomp/core/lam_arity.ml b/jscomp/core/lam_arity.ml deleted file mode 100644 index 147e063..0000000 --- a/jscomp/core/lam_arity.ml +++ /dev/null @@ -1,100 +0,0 @@ -(* Copyright (C) Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Arity_info of int list * bool - (** - the last one means it can take any params later, - for an exception: it is (Determin (true,[], true)) - 1. approximation sound but not complete - - *) - | Arity_na - -let equal (x : t) y = - match x with - | Arity_na -> y = Arity_na - | Arity_info (xs, a) -> ( - match y with - | Arity_info (ys, b) -> - a = b && Ext_list.for_all2_no_exn xs ys (fun x y -> x = y) - | Arity_na -> false) - -let pp = Format.fprintf - -let print (fmt : Format.formatter) (x : t) = - match x with - | Arity_na -> pp fmt "?" - | Arity_info (ls, tail) -> - pp fmt "@["; - pp fmt "["; - Format.pp_print_list - ~pp_sep:(fun fmt () -> pp fmt ",") - (fun fmt x -> Format.pp_print_int fmt x) - fmt ls; - if tail then pp fmt "@ *"; - pp fmt "]@]" - -let print_arities_tbl (fmt : Format.formatter) - (arities_tbl : (Ident.t, t ref) Hashtbl.t) = - Hashtbl.fold - (fun (i : Ident.t) (v : t ref) _ -> pp fmt "@[%s -> %a@]@." i.name print !v) - arities_tbl () - -let merge (n : int) (x : t) : t = - match x with - | Arity_na -> Arity_info ([ n ], false) - | Arity_info (xs, tail) -> Arity_info (n :: xs, tail) - -let non_function_arity_info = Arity_info ([], false) - -let raise_arity_info = Arity_info ([], true) - -let na = Arity_na - -let info args b1 = Arity_info (args, b1) - -let first_arity_na (x : t) = - match x with Arity_na | Arity_info ([], _) -> true | _ -> false - -let get_first_arity (x : t) = - match x with - | Arity_na | Arity_info ([], _) -> None - | Arity_info (x :: _, _) -> Some x - -let extract_arity (x : t) = - match x with Arity_na -> [] | Arity_info (xs, _) -> xs - -(* let update_arity (x : t) xs = *) - -let rec merge_arities_aux (acc : int list) (xs : int list) (ys : int list) - (tail : bool) (tail2 : bool) = - match (xs, ys) with - | [], [] -> info (List.rev acc) (tail && tail2) - | [], y :: ys when tail -> merge_arities_aux (y :: acc) [] ys tail tail2 - | x :: xs, [] when tail2 -> merge_arities_aux (x :: acc) [] xs tail tail2 - | x :: xs, y :: ys when x = y -> merge_arities_aux (y :: acc) xs ys tail tail2 - | _, _ -> info (List.rev acc) false - -let merge_arities xs ys t t2 = merge_arities_aux [] xs ys t t2 diff --git a/jscomp/core/lam_arity.mli b/jscomp/core/lam_arity.mli deleted file mode 100644 index 29772c0..0000000 --- a/jscomp/core/lam_arity.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* Copyright (C) Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = private - | Arity_info of int list * bool - (** - when the first argument is true, it is for sure - the last one means it can take any params later, - for an exception: it is (Arity_info([], true)) - approximation sound but not complete - *) - | Arity_na - -val equal : t -> t -> bool - -val print : Format.formatter -> t -> unit - -val print_arities_tbl : Format.formatter -> (Ident.t, t ref) Hashtbl.t -> unit - -val merge : int -> t -> t - -val non_function_arity_info : t - -val raise_arity_info : t - -val na : t - -val info : int list -> bool -> t - -val first_arity_na : t -> bool - -val get_first_arity : t -> int option - -val extract_arity : t -> int list -(** when [NA] return empty list*) - -val merge_arities : int list -> int list -> bool -> bool -> t diff --git a/jscomp/core/lam_arity_analysis.ml b/jscomp/core/lam_arity_analysis.ml deleted file mode 100644 index d77477d..0000000 --- a/jscomp/core/lam_arity_analysis.ml +++ /dev/null @@ -1,150 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let arity_of_var (meta : Lam_stats.t) (v : Ident.t) = - (* for functional parameter, if it is a high order function, - if it's not from function parameter, we should warn - *) - match Hash_ident.find_opt meta.ident_tbl v with - | Some (FunctionId { arity; _ }) -> arity - | Some _ | None -> Lam_arity.na - -(* we need record all aliases -- since not all aliases are eliminated, - mostly are toplevel bindings - We will keep iterating such environment - If not found, we will return [NA] -*) -let rec get_arity (meta : Lam_stats.t) (lam : Lam.t) : Lam_arity.t = - match lam with - | Lvar v -> arity_of_var meta v - | Lconst _ -> Lam_arity.non_function_arity_info - | Llet (_, _, _, l) -> get_arity meta l - | Lprim - { - primitive = Pfield (_, Fld_module { name }); - args = [ Lglobal_module (id, dynamic_import) ]; - _; - } -> ( - match (Lam_compile_env.query_external_id_info ~dynamic_import id name).arity with - | Single x -> x - | Submodule _ -> Lam_arity.na) - | Lprim - { - primitive = Pfield (m, _); - args = - [ - Lprim - { - primitive = Pfield (_, Fld_module { name }); - args = [ Lglobal_module (id, dynamic_import) ]; - }; - ]; - _; - } -> ( - match (Lam_compile_env.query_external_id_info ~dynamic_import id name).arity with - | Submodule subs -> subs.(m) (* TODO: shall we store it as array?*) - | Single _ -> Lam_arity.na) - (* TODO: all information except Pccall is complete, we could - get more arity information - *) - | Lprim - { primitive = Praw_js_code { code_info = Exp (Js_function { arity }) } } - -> - Lam_arity.info [ arity ] false - | Lprim { primitive = Praise; _ } -> Lam_arity.raise_arity_info - | Lglobal_module _ (* TODO: fix me never going to happen *) | Lprim _ -> - Lam_arity.na (* CHECK*) - (* shall we handle primitive in a direct way, - since we know all the information - Invariant: all primitive application is fully applied, - since this information is already available - - -- Check external c functions ? - -- it's not true for primitives - like caml_set_oo_id or Lprim (Pmakeblock , []) - - it seems true that primitive is always fully applied, however, - it can return a function - *) - | Lletrec (_, body) -> get_arity meta body - | Lapply { ap_func = app; ap_args = args; _ } -> ( - (* detect functor application *) - let fn = get_arity meta app in - match fn with - | Arity_na -> Lam_arity.na - | Arity_info (xs, tail) -> - let rec take (arities : _ list) arg_length = - match arities with - | x :: yys -> - if arg_length = x then Lam_arity.info yys tail - else if arg_length > x then take yys (arg_length - x) - else Lam_arity.info ((x - arg_length) :: yys) tail - | [] -> if tail then Lam_arity.raise_arity_info else Lam_arity.na - (* Actually, you can not have truly deministic arities - for example [fun x -> x ] - *) - in - take xs (List.length args)) - | Lfunction { arity; body } -> Lam_arity.merge arity (get_arity meta body) - | Lswitch - ( _, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full = _; - sw_consts_full = _; - } ) -> - all_lambdas meta - (let rest = - Ext_list.map_append sw_consts (Ext_list.map sw_blocks snd) snd - in - match sw_failaction with None -> rest | Some x -> x :: rest) - | Lstringswitch (_, sw, d) -> ( - match d with - | None -> all_lambdas meta (Ext_list.map sw snd) - | Some v -> all_lambdas meta (v :: Ext_list.map sw snd)) - | Lstaticcatch (_, _, handler) -> get_arity meta handler - | Ltrywith (l1, _, l2) -> all_lambdas meta [ l1; l2 ] - | Lifthenelse (_, l2, l3) -> all_lambdas meta [ l2; l3 ] - | Lsequence (_, l2) -> get_arity meta l2 - | Lstaticraise _ (* since it will not be in tail position *) -> Lam_arity.na - | Lwhile _ | Lfor _ | Lassign _ -> Lam_arity.non_function_arity_info - -and all_lambdas meta (xs : Lam.t list) = - match xs with - | y :: ys -> - let arity = get_arity meta y in - let rec aux (acc : Lam_arity.t) xs = - match (acc, xs) with - | Arity_na, _ -> acc - | _, [] -> acc - | Arity_info (xxxs, tail), y :: ys -> ( - match get_arity meta y with - | Arity_na -> Lam_arity.na - | Arity_info (yyys, tail2) -> - aux (Lam_arity.merge_arities xxxs yyys tail tail2) ys) - in - aux arity ys - | [] -> Lam_arity.na diff --git a/jscomp/core/lam_arity_analysis.mli b/jscomp/core/lam_arity_analysis.mli deleted file mode 100644 index ee14897..0000000 --- a/jscomp/core/lam_arity_analysis.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Utilities for lambda analysis *) - -val get_arity : Lam_stats.t -> Lam.t -> Lam_arity.t diff --git a/jscomp/core/lam_beta_reduce.ml b/jscomp/core/lam_beta_reduce.ml deleted file mode 100644 index 30d3977..0000000 --- a/jscomp/core/lam_beta_reduce.ml +++ /dev/null @@ -1,123 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - A naive beta reduce would break the invariants of the optmization. - - - The sane but slowest way: - when we do a beta reduction, we need rename all variables inlcuding - let-bound ones - - A conservative one: - - for internal one - rename params and let bound variables - - for external one (seriaized) - if it's enclosed environment should be good enough - so far, we only inline enclosed lambdas - TODO: rename - - Optimizations: - {[ - (fun x y -> ... ) 100 3 - ]} - we can bound [x] to [100] in a single step -*) -let propagate_beta_reduce (meta : Lam_stats.t) (params : Ident.t list) - (body : Lam.t) (args : Lam.t list) = - match Lam_beta_reduce_util.simple_beta_reduce params body args with - | Some x -> x - | None -> - let rest_bindings, rev_new_params = - Ext_list.fold_left2 params args ([], []) - (fun old_param arg (rest_bindings, acc) -> - match arg with - | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) - | _ -> - let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) - in - let new_body = - Lam_bounded_vars.rewrite - (Hash_ident.of_list2 (List.rev params) rev_new_params) - body - in - Ext_list.fold_right rest_bindings new_body (fun (param, arg) l -> - (match arg with - | Lprim { primitive = Pmakeblock (_, _, Immutable); args; _ } -> - Hash_ident.replace meta.ident_tbl param - (Lam_util.kind_of_lambda_block args) - | Lprim { primitive = Psome | Psome_not_nest; args = [ v ]; _ } -> - Hash_ident.replace meta.ident_tbl param (Normal_optional v) - | _ -> ()); - Lam_util.refine_let ~kind:Strict param arg l) - -let propagate_beta_reduce_with_map (meta : Lam_stats.t) - (map : Lam_var_stats.stats Map_ident.t) params body args = - match Lam_beta_reduce_util.simple_beta_reduce params body args with - | Some x -> x - | None -> - let rest_bindings, rev_new_params = - Ext_list.fold_left2 params args ([], []) - (fun old_param arg (rest_bindings, acc) -> - match arg with - | Lconst _ | Lvar _ -> (rest_bindings, arg :: acc) - | Lglobal_module _ -> - let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) - | _ -> - if Lam_analysis.no_side_effects arg then - match Map_ident.find_exn map old_param with - | stat -> - if Lam_var_stats.top_and_used_zero_or_one stat then - (rest_bindings, arg :: acc) - else - let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc) - else - let p = Ident.rename old_param in - ((p, arg) :: rest_bindings, Lam.var p :: acc)) - in - let new_body = - Lam_bounded_vars.rewrite - (Hash_ident.of_list2 (List.rev params) rev_new_params) - body - in - Ext_list.fold_right rest_bindings new_body - (fun (param, (arg : Lam.t)) l -> - (match arg with - | Lprim { primitive = Pmakeblock (_, _, Immutable); args } -> - Hash_ident.replace meta.ident_tbl param - (Lam_util.kind_of_lambda_block args) - | Lprim { primitive = Psome | Psome_not_nest; args = [ v ] } -> - Hash_ident.replace meta.ident_tbl param (Normal_optional v) - | _ -> ()); - Lam_util.refine_let ~kind:Strict param arg l) - -let no_names_beta_reduce params body args = - match Lam_beta_reduce_util.simple_beta_reduce params body args with - | Some x -> x - | None -> - Ext_list.fold_left2 params args body (fun param arg l -> - Lam_util.refine_let ~kind:Strict param arg l) diff --git a/jscomp/core/lam_beta_reduce.mli b/jscomp/core/lam_beta_reduce.mli deleted file mode 100644 index 8be5e2d..0000000 --- a/jscomp/core/lam_beta_reduce.mli +++ /dev/null @@ -1,74 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Beta reduction of lambda IR *) - -val no_names_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t -(* Compile-time beta-reduction of functions immediately applied: - Lapply(Lfunction(Curried, params, body), args, loc) -> - let paramN = argN in ... let param1 = arg1 in body - Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> - let paramN = argN in ... let param1 = arg1 in body - Assumes |args| = |params|. - - This function is used while counting used vars, no new names - are generated to make this more complex -*) - -(* - Refresh all the identifiers, - otherwise the identifier property can not be preserved, - the obvious example is parameter - *) - -val propagate_beta_reduce : - Lam_stats.t -> Ident.t list -> Lam.t -> Lam.t list -> Lam.t - -val propagate_beta_reduce_with_map : - Lam_stats.t -> - Lam_var_stats.stats Map_ident.t -> - Ident.t list -> - Lam.t -> - Lam.t list -> - Lam.t -(** - {[ Lam_beta_reduce.propogate_beta_reduce_with_map - meta param_map - params body args]} - - [param_map] collect the usage of parameters, it's readonly - it can be produced by - - {[!Lam_analysis.free_variables meta.export_idents - (Lam_analysis.param_map_of_list params) body]} - - TODO: - replace [propogate_beta_reduce] with such implementation - {[ - let propogate_beta_reduce meta params body args = - let (_, param_map) = - Lam_analysis.is_closed_with_map Set_ident.empty params body in - propogate_beta_reduce_with_map meta param_map params body args - ]} -*) diff --git a/jscomp/core/lam_beta_reduce_util.ml b/jscomp/core/lam_beta_reduce_util.ml deleted file mode 100644 index eadbed9..0000000 --- a/jscomp/core/lam_beta_reduce_util.ml +++ /dev/null @@ -1,124 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - Principle: since in ocaml, the apply order is not specified - rules: - 1. each argument it is only used once, (avoid eval duplication) - 2. it's actually used, if not (Lsequence) - 3. no nested compuation, - other wise the evaluation order is tricky (make sure eval order is correct) -*) - -type value = { mutable used : bool; lambda : Lam.t } - -let param_hash : _ Hash_ident.t = Hash_ident.create 20 - -(* optimize cases like - (fun f (a,b){ g (a,b,1)} (e0, e1)) - cases like - (fun f (a,b){ g (a,b,a)} (e0, e1)) needs avoids double eval - - Note in a very special case we can avoid any allocation - {[ - when Ext_list.for_all2_no_exn - (fun p a -> - match (a : Lam.t) with - | Lvar a -> Ident.same p a - | _ -> false ) params args' - ]} -*) -let simple_beta_reduce params body args = - let exception Not_simple_apply in - let find_param_exn v opt = - match Hash_ident.find_opt param_hash v with - | Some exp -> - if exp.used then raise_notrace Not_simple_apply else exp.used <- true; - exp.lambda - | None -> opt - in - let rec aux_exn acc (us : Lam.t list) = - match us with - | [] -> List.rev acc - | (Lvar x as a) :: rest -> aux_exn (find_param_exn x a :: acc) rest - | (Lconst _ as u) :: rest -> aux_exn (u :: acc) rest - | _ :: _ -> raise_notrace Not_simple_apply - in - match (body : Lam.t) with - | Lprim { primitive; args = ap_args; loc = ap_loc } - (* There is no lambda in primitive *) -> ( - (* catch a special case of primitives *) - let () = - List.iter2 - (fun p a -> Hash_ident.add param_hash p { lambda = a; used = false }) - params args - in - try - let new_args = aux_exn [] ap_args in - let result = - Hash_ident.fold param_hash (Lam.prim ~primitive ~args:new_args ap_loc) - (fun _param stats acc -> - let { lambda; used } = stats in - if not used then Lam.seq lambda acc else acc) - in - Hash_ident.clear param_hash; - Some result - with Not_simple_apply -> - Hash_ident.clear param_hash; - None) - | Lapply - { - ap_func = - (Lvar _ | Lprim { primitive = Pfield _; args = [ Lglobal_module _ ] }) - as f; - ap_args; - ap_info; - } -> ( - let () = - List.iter2 - (fun p a -> Hash_ident.add param_hash p { lambda = a; used = false }) - params args - in - (*since we adde each param only once, - iff it is removed once, no exception, - if it is removed twice there will be exception. - if it is never removed, we have it as rest keys - *) - try - let new_args = aux_exn [] ap_args in - let f = - match f with Lvar fn_name -> find_param_exn fn_name f | _ -> f - in - let result = - Hash_ident.fold param_hash (Lam.apply f new_args ap_info) - (fun _param stat acc -> - let { lambda; used } = stat in - if not used then Lam.seq lambda acc else acc) - in - Hash_ident.clear param_hash; - Some result - with Not_simple_apply -> - Hash_ident.clear param_hash; - None) - | _ -> None diff --git a/jscomp/core/lam_beta_reduce_util.mli b/jscomp/core/lam_beta_reduce_util.mli deleted file mode 100644 index 585611b..0000000 --- a/jscomp/core/lam_beta_reduce_util.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val simple_beta_reduce : Ident.t list -> Lam.t -> Lam.t list -> Lam.t option diff --git a/jscomp/core/lam_bounded_vars.ml b/jscomp/core/lam_bounded_vars.ml deleted file mode 100644 index 59dfab8..0000000 --- a/jscomp/core/lam_bounded_vars.ml +++ /dev/null @@ -1,158 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - Given an [map], rewrite all let bound variables into new variables, - note that the [map] is changed - example - {[ - let a/112 = 3 in a/112 - ]} - would be converted into - {[ - let a/113 = 3 in a/113 - ]} - - ATTENTION: [let] bound idents have to be renamed, - Note we rely on an invariant that parameter could not be rebound -*) - -(* - Small function inline heuristics: - Even if a function is small, it does not mean it is good for inlining, - for example, in list.ml - {[ - let rec length_aux len = function - [] -> len - | a::l -> length_aux (len + 1) l - - let length l = length_aux 0 l - ]} - if we inline [length], it will expose [length_aux] to the user, first, it make - the code not very friendly, also since [length_aux] is used everywhere now, it - may affect that we will not do the inlining of [length_aux] in [length] - - Criteior for sure to inline - 1. small size, does not introduce extra symbols, non-exported and non-recursive - non-recursive is required if we re-apply the strategy - - Other Factors: - 2. number of invoked times - 3. arguments are const or not -*) -let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = - let rebind i = - let i' = Ident.rename i in - Hash_ident.add map i (Lam.var i'); - i' - in - (* order matters, especially for let bindings *) - let rec option_map op = match op with None -> None | Some x -> Some (aux x) - and aux (lam : Lam.t) : Lam.t = - match lam with - | Lvar v -> Hash_ident.find_default map v lam - | Llet (str, v, l1, l2) -> - let v = rebind v in - let l1 = aux l1 in - let l2 = aux l2 in - Lam.let_ str v l1 l2 - | Lletrec (bindings, body) -> - (*order matters see GPR #405*) - let vars = Ext_list.map bindings (fun (k, _) -> rebind k) in - let bindings = - Ext_list.map2 vars bindings (fun var (_, l) -> (var, aux l)) - in - let body = aux body in - Lam.letrec bindings body - | Lfunction { arity; params; body; attr } -> - let params = Ext_list.map params rebind in - let body = aux body in - Lam.function_ ~arity ~params ~body ~attr - | Lstaticcatch (l1, (i, xs), l2) -> - let l1 = aux l1 in - let xs = Ext_list.map xs rebind in - let l2 = aux l2 in - Lam.staticcatch l1 (i, xs) l2 - | Lfor (ident, l1, l2, dir, l3) -> - let ident = rebind ident in - let l1 = aux l1 in - let l2 = aux l2 in - let l3 = aux l3 in - Lam.for_ ident (aux l1) l2 dir l3 - | Lconst _ -> lam - | Lprim { primitive; args; loc } -> - (* here it makes sure that global vars are not rebound *) - Lam.prim ~primitive ~args:(Ext_list.map args aux) loc - | Lglobal_module _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - let fn = aux ap_func in - let args = Ext_list.map ap_args aux in - Lam.apply fn args ap_info - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) -> - let l = aux l in - Lam.switch l - { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; - sw_consts_full; - sw_blocks_full; - sw_failaction = option_map sw_failaction; - sw_names; - } - | Lstringswitch (l, sw, d) -> - let l = aux l in - Lam.stringswitch l (Ext_list.map_snd sw aux) (option_map d) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) - | Ltrywith (l1, v, l2) -> - let l1 = aux l1 in - let v = rebind v in - let l2 = aux l2 in - Lam.try_ l1 v l2 - | Lifthenelse (l1, l2, l3) -> - let l1 = aux l1 in - let l2 = aux l2 in - let l3 = aux l3 in - Lam.if_ l1 l2 l3 - | Lsequence (l1, l2) -> - let l1 = aux l1 in - let l2 = aux l2 in - Lam.seq l1 l2 - | Lwhile (l1, l2) -> - let l1 = aux l1 in - let l2 = aux l2 in - Lam.while_ l1 l2 - | Lassign (v, l) -> Lam.assign v (aux l) - in - aux lam - -(* let refresh lam = rewrite (Hash_ident.create 17 : Lam.t Hash_ident.t ) lam *) diff --git a/jscomp/core/lam_bounded_vars.mli b/jscomp/core/lam_bounded_vars.mli deleted file mode 100644 index 7969aaf..0000000 --- a/jscomp/core/lam_bounded_vars.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val rewrite : Lam.t Hash_ident.t -> Lam.t -> Lam.t -(** [rewrite tbl lam] - Given a [tbl] to rewrite all bounded variables in [lam] -*) - -(** refresh lambda to replace all bounded vars for new ones *) -(* val refresh : - Lam.t -> - Lam.t *) diff --git a/jscomp/core/lam_check.ml b/jscomp/core/lam_check.ml deleted file mode 100644 index 1da197c..0000000 --- a/jscomp/core/lam_check.ml +++ /dev/null @@ -1,157 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - checks - 1. variables are not bound twice - 2. all variables are of right scope -*) -let check file lam = - let defined_variables = Hash_set_ident.create 1000 in - let success = ref true in - let use (id : Ident.t) = - if not @@ Hash_set_ident.mem defined_variables id then ( - Format.fprintf Format.err_formatter - "\n[SANITY]:%s/%d used before defined in %s@." id.name id.stamp file; - success := false) - in - let def (id : Ident.t) = - if Hash_set_ident.mem defined_variables id then ( - Format.fprintf Format.err_formatter "\n[SANITY]:%s/%d bound twice in %s@." - id.name id.stamp file; - success := false) - else Hash_set_ident.add defined_variables id - in - (* TODO: replaced by a slow version of {!Lam_iter.inner_iter} *) - let rec check_list xs (cxt : Set_int.t) = - Ext_list.iter xs (fun x -> check_staticfails x cxt) - and check_list_snd : 'a. ('a * Lam.t) list -> _ -> unit = - fun xs cxt -> Ext_list.iter_snd xs (fun x -> check_staticfails x cxt) - and check_staticfails (l : Lam.t) (cxt : Set_int.t) = - match l with - | Lvar _ | Lconst _ | Lglobal_module _ -> () - | Lprim { args; _ } -> check_list args cxt - | Lapply { ap_func; ap_args; _ } -> check_list (ap_func :: ap_args) cxt - (* check invariant that staticfaill does not cross function/while/for loop*) - | Lfunction { body; params = _ } -> check_staticfails body Set_int.empty - | Lwhile (e1, e2) -> - check_staticfails e1 cxt; - check_staticfails e2 Set_int.empty - | Lfor (_v, e1, e2, _dir, e3) -> - check_staticfails e1 cxt; - check_staticfails e2 cxt; - check_staticfails e3 Set_int.empty - | Llet (_str, _id, arg, body) -> check_list [ arg; body ] cxt - | Lletrec (decl, body) -> - check_list_snd decl cxt; - check_staticfails body cxt - | Lswitch (arg, sw) -> - check_staticfails arg cxt; - check_list_snd sw.sw_consts cxt; - check_list_snd sw.sw_blocks cxt; - Ext_option.iter sw.sw_failaction (fun x -> check_staticfails x cxt) - | Lstringswitch (arg, cases, default) -> - check_staticfails arg cxt; - check_list_snd cases cxt; - Ext_option.iter default (fun x -> check_staticfails x cxt) - | Lstaticraise (i, args) -> - if Set_int.mem cxt i then check_list args cxt - else failwith ("exit " ^ string_of_int i ^ " unbound") - | Lstaticcatch (e1, (j, _vars), e2) -> - check_staticfails e1 (Set_int.add cxt j); - check_staticfails e2 cxt - | Ltrywith (e1, _exn, e2) -> - check_staticfails e1 cxt; - check_staticfails e2 cxt - | Lifthenelse (e1, e2, e3) -> check_list [ e1; e2; e3 ] cxt - | Lsequence (e1, e2) -> check_list [ e1; e2 ] cxt - | Lassign (_id, e) -> check_staticfails e cxt - in - let rec iter_list xs = Ext_list.iter xs iter - and iter_list_snd : 'a. ('a * Lam.t) list -> unit = - fun xs -> Ext_list.iter_snd xs iter - and iter (l : Lam.t) = - match l with - | Lvar id -> use id - | Lglobal_module _ -> () - | Lprim { args; _ } -> iter_list args - | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - iter ap_func; - iter_list ap_args - | Lfunction { body; params } -> - List.iter def params; - iter body - | Llet (_str, id, arg, body) -> - iter arg; - def id; - iter body - | Lletrec (decl, body) -> - Ext_list.iter_fst decl def; - iter_list_snd decl; - iter body - | Lswitch (arg, sw) -> - iter arg; - iter_list_snd sw.sw_consts; - iter_list_snd sw.sw_blocks; - Ext_option.iter sw.sw_failaction iter; - assert ( - not - (sw.sw_failaction <> None && sw.sw_consts_full && sw.sw_blocks_full)) - | Lstringswitch (arg, cases, default) -> - iter arg; - iter_list_snd cases; - Ext_option.iter default iter - | Lstaticraise (_i, args) -> iter_list args - | Lstaticcatch (e1, (_, vars), e2) -> - iter e1; - List.iter def vars; - iter e2 - | Ltrywith (e1, exn, e2) -> - iter e1; - def exn; - iter e2 - | Lifthenelse (e1, e2, e3) -> - iter e1; - iter e2; - iter e3 - | Lsequence (e1, e2) -> - iter e1; - iter e2 - | Lwhile (e1, e2) -> - iter e1; - iter e2 - | Lfor (v, e1, e2, _dir, e3) -> - iter e1; - iter e2; - def v; - iter e3 - | Lassign (id, e) -> - use id; - iter e - in - check_staticfails lam Set_int.empty; - iter lam; - assert !success; - lam diff --git a/jscomp/core/lam_check.mli b/jscomp/core/lam_check.mli deleted file mode 100644 index 5522308..0000000 --- a/jscomp/core/lam_check.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val check : string -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_closure.ml b/jscomp/core/lam_closure.ml deleted file mode 100644 index 8b72bfa..0000000 --- a/jscomp/core/lam_closure.ml +++ /dev/null @@ -1,158 +0,0 @@ -(* Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type position = Lam_var_stats.position - -type stats = Lam_var_stats.stats - -let adjust (fv : stats Map_ident.t) (pos : position) (v : Ident.t) : - stats Map_ident.t = - Map_ident.adjust fv v (fun v -> - let stat = - match v with None -> Lam_var_stats.fresh_stats | Some v -> v - in - Lam_var_stats.update stat pos) - -let param_map_of_list lst : stats Map_ident.t = - Ext_list.fold_left lst Map_ident.empty (fun acc l -> - Map_ident.add acc l Lam_var_stats.fresh_stats) - -(** Sanity check, remove all varaibles in [local_set] in the last pass *) -let sink_pos = Lam_var_stats.sink - -(** - [param_stats = free_variables exports param_stats lam] - This function tries to do more than detect free variable of [lam], - given [param_stats] it tries to return a new stats with updated usage of - recorded params and unbound parameters - - An enriched version of [free_varaibles] in {!Lam_free_variables} -*) -let free_variables (export_idents : Set_ident.t) (params : stats Map_ident.t) - (lam : Lam.t) : stats Map_ident.t = - let fv = ref params in - let local_set = ref export_idents in - let local_add k = local_set := Set_ident.add !local_set k in - let local_add_list ks = - local_set := Ext_list.fold_left ks !local_set Set_ident.add - in - (* base don the envrionmet, recoring the use cases of arguments - relies on [identifier] uniquely bound *) - let used (cur_pos : position) (v : Ident.t) = - if not (Set_ident.mem !local_set v) then fv := adjust !fv cur_pos v - in - - let rec iter (top : position) (lam : Lam.t) = - match lam with - | Lvar v -> used top v - | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - iter top ap_func; - let top = Lam_var_stats.new_position_after_lam ap_func top in - Ext_list.iter ap_args (fun lam -> iter top lam) - | Lprim { args; _ } -> - (* Check: can top be propoaged for all primitives *) - Ext_list.iter args (iter top) - | Lglobal_module _ -> () - | Lfunction { params; body } -> - local_add_list params; - iter sink_pos body (* Do we need continue *) - | Llet (_, id, arg, body) -> - iter top arg; - local_add id; - iter sink_pos body - | Lletrec (decl, body) -> - local_set := - Ext_list.fold_left decl !local_set (fun acc (id, _) -> - Set_ident.add acc id); - Ext_list.iter decl (fun (_, exp) -> iter sink_pos exp); - iter sink_pos body - | Lswitch - ( arg, - { - sw_consts; - sw_blocks; - sw_failaction; - sw_consts_full; - sw_blocks_full; - } ) -> ( - iter top arg; - let top = Lam_var_stats.new_position_after_lam arg top in - List.iter (fun (_, case) -> iter top case) sw_consts; - List.iter (fun (_, case) -> iter top case) sw_blocks; - match sw_failaction with - | None -> () - | Some x -> - if sw_consts_full || sw_blocks_full then iter top x - else iter sink_pos x) - | Lstringswitch (arg, cases, default) -> ( - iter top arg; - let top = Lam_var_stats.new_position_after_lam arg top in - List.iter (fun (_, act) -> iter top act) cases; - match default with None -> () | Some x -> iter top x) - | Lstaticraise (_, args) -> List.iter (iter sink_pos) args - | Lstaticcatch (e1, (_, vars), e2) -> - iter sink_pos e1; - local_add_list vars; - iter sink_pos e2 - | Ltrywith (e1, _exn, e2) -> - iter top e1; - iter sink_pos e2 - | Lifthenelse (e1, e2, e3) -> - iter top e1; - let top = Lam_var_stats.new_position_after_lam e1 top in - iter top e2; - iter top e3 - | Lsequence (e1, e2) -> - iter top e1; - iter sink_pos e2 - | Lwhile (e1, e2) -> - iter sink_pos e1; - iter sink_pos e2 (* in the loop, no substitution any way *) - | Lfor (v, e1, e2, _dir, e3) -> - local_add v; - iter sink_pos e1; - iter sink_pos e2; - iter sink_pos e3 - | Lassign (id, e) -> - used top id; - iter top e - in - iter Lam_var_stats.fresh_env lam; - !fv - -(* let is_closed_by (set : Set_ident.t) (lam : Lam.t) : bool = - Map_ident.is_empty (free_variables set (Map_ident.empty ) lam ) *) - -(** A bit consverative , it should be empty *) -let is_closed lam = - Map_ident.for_all (free_variables Set_ident.empty Map_ident.empty lam) - (fun k _ -> Ident.global k) - -let is_closed_with_map (exports : Set_ident.t) (params : Ident.t list) - (body : Lam.t) : bool * stats Map_ident.t = - let param_map = free_variables exports (param_map_of_list params) body in - let old_count = List.length params in - let new_count = Map_ident.cardinal param_map in - (old_count = new_count, param_map) diff --git a/jscomp/core/lam_closure.mli b/jscomp/core/lam_closure.mli deleted file mode 100644 index 392cb5c..0000000 --- a/jscomp/core/lam_closure.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** [is_closed_by map lam] - return [true] if all unbound variables - belongs to the given [map] *) -(* val is_closed_by : Set_ident.t -> Lam.t -> bool *) - -val is_closed : Lam.t -> bool - -val is_closed_with_map : - Set_ident.t -> Ident.t list -> Lam.t -> bool * Lam_var_stats.stats Map_ident.t -(** The output is mostly used in betat reduction *) - -val free_variables : - Set_ident.t -> - Lam_var_stats.stats Map_ident.t -> - Lam.t -> - Lam_var_stats.stats Map_ident.t diff --git a/jscomp/core/lam_coercion.ml b/jscomp/core/lam_coercion.ml deleted file mode 100644 index 84d7f7a..0000000 --- a/jscomp/core/lam_coercion.ml +++ /dev/null @@ -1,221 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - Invariant: The last one is always [exports] - Compile definitions - Compile exports - Assume Pmakeblock(_,_), - lambda_exports are pure - compile each binding with a return value - - Such invariant might be wrong in toplevel (since it is all bindings) - - We should add this check as early as possible -*) - -(* -- {[ Ident.same id eid]} is more correct, - however, it will introduce a coercion, which is not necessary, - as long as its name is the same, we want to avoid - another coercion - In most common cases, it will be - {[ - let export/100 =a fun .. - export/100 - ]} - This comes from we have lambda as below - {[ - (* let export/100 =a export/99 *) - (* above is probably the cause but does not have to be *) - (export/99) - ]} - [export/100] was not eliminated due to that it is export id, - if we rename export/99 to be export id, then we don't need - the coercion any more, and export/100 will be dced later - - avoid rebound - check [map.ml] here coercion, we introduced - rebound which is not corrrect - {[ - let Make/identifier = function (funarg){ - var $$let = Make/identifier(funarg); - return [0, ..... ] - } - ]} - Possible fix ? - change export identifier, we should do this in the very - beginning since lots of optimizations depend on this - however -*) - -type t = { - export_list : Ident.t list; - export_set : Set_ident.t; - export_map : Lam.t Map_ident.t; - (** not used in code generation, mostly used - for store some information in cmj files *) - groups : Lam_group.t list; - (* all code to be compiled later = original code + rebound coercions *) -} - -let handle_exports (meta : Lam_stats.t) (lambda_exports : Lam.t list) - (reverse_input : Lam_group.t list) = - let (original_exports : Ident.t list) = meta.exports in - let (original_export_set : Set_ident.t) = meta.export_idents in - let len = List.length original_exports in - let tbl = Hash_set_string.create len in - let ({ export_list; export_set } as result) = - Ext_list.fold_right2 original_exports lambda_exports - { - export_list = []; - export_set = original_export_set; - export_map = Map_ident.empty; - groups = []; - } (fun (original_export_id : Ident.t) (lam : Lam.t) (acc : t) -> - let original_name = original_export_id.name in - if not @@ Hash_set_string.check_add tbl original_name then - Bs_exception.error (Bs_duplicate_exports original_name); - match lam with - | Lvar id -> - if Ident.name id = original_name then - { - acc with - export_list = id :: acc.export_list; - export_set = - (if id.stamp = original_export_id.stamp then acc.export_set - else - Set_ident.add - (Set_ident.remove acc.export_set original_export_id) - id); - } - else - let newid = Ident.rename original_export_id in - let kind : Lam_compat.let_kind = Alias in - Lam_util.alias_ident_or_global meta newid id NA; - { - acc with - export_list = newid :: acc.export_list; - export_map = Map_ident.add acc.export_map newid lam; - groups = Single (kind, newid, lam) :: acc.groups; - } - | _ -> - (* - Example: - {[ - let N = [a0,a1,a2,a3] - in [[ N[0], N[2]]] - - ]} - After optimization - {[ - [ [ a0, a2] ] - ]} - Here [N] is elminated while N is still exported identifier - Invariant: [eid] can not be bound before - FIX: this invariant is not guaranteed. - Bug manifested: when querying arity info about N, it returns an array - of size 4 instead of 2 - *) - let newid = Ident.rename original_export_id in - (let arity = Lam_arity_analysis.get_arity meta lam in - if not (Lam_arity.first_arity_na arity) then - Hash_ident.add meta.ident_tbl newid - (FunctionId - { - arity; - lambda = - (match lam with - | Lfunction _ -> Some (lam, Lam_non_rec) - | _ -> None); - })); - { - acc with - export_list = newid :: acc.export_list; - export_map = Map_ident.add acc.export_map newid lam; - groups = Single (Strict, newid, lam) :: acc.groups; - }) - in - - let export_map, coerced_input = - Ext_list.fold_left reverse_input (result.export_map, result.groups) - (fun (export_map, acc) x -> - ( (match x with - | Single (_, id, lam) when Set_ident.mem export_set id -> - Map_ident.add export_map id lam - (* relies on the Invariant that [eoid] can not be bound before - FIX: such invariant may not hold - *) - | _ -> export_map), - x :: acc )) - in - { result with export_map; groups = Lam_dce.remove export_list coerced_input } - -(* TODO: more flattening, - - also for function compilation, flattening should be done first - - [compile_group] and [compile] become mutually recursive function -*) - -let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : - Lam.t * Lam_group.t list = - match lam with - | Llet (str, id, arg, body) -> - let res, l = flatten acc arg in - flatten (Single (str, id, res) :: l) body - | Lletrec (bind_args, body) -> flatten (Recursive bind_args :: acc) body - | Lsequence (l, r) -> - let res, l = flatten acc l in - flatten (Lam_group.nop_cons res l) r - | x -> (x, acc) - -(** Invarinat to hold: - [export_map] is sound, for every rebinded export id, its key is indeed in - [export_map] since we know its old bindings are no longer valid, i.e - Lam_stats.t is not valid -*) -let coerce_and_group_big_lambda (meta : Lam_stats.t) lam : t * Lam_stats.t = - match flatten [] lam with - | Lprim { primitive = Pmakeblock _; args = lambda_exports }, reverse_input -> - let coerced_input = handle_exports meta lambda_exports reverse_input in - ( coerced_input, - { - meta with - export_idents = coerced_input.export_set; - exports = coerced_input.export_list; - } ) - | _ -> - (* This could happen see #2474*) - (* #3595 - TODO: FIXME later - *) - assert false -(* { - export_list = meta.exports; - export_set = meta.export_idents; - export_map = Map_ident.empty ; - (** not used in code generation, mostly used - for store some information in cmj files *) - groups = [Nop lam] ; - (* all code to be compiled later = original code + rebound coercions *) - } - , meta *) diff --git a/jscomp/core/lam_coercion.mli b/jscomp/core/lam_coercion.mli deleted file mode 100644 index 0acb9ba..0000000 --- a/jscomp/core/lam_coercion.mli +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = { - export_list : Ident.t list; - export_set : Set_ident.t; - export_map : Lam.t Map_ident.t; - groups : Lam_group.t list; -} - -val coerce_and_group_big_lambda : Lam_stats.t -> Lam.t -> t * Lam_stats.t diff --git a/jscomp/core/lam_compat.ml b/jscomp/core/lam_compat.ml deleted file mode 100644 index 3fb76f4..0000000 --- a/jscomp/core/lam_compat.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type boxed_integer = Lambda.boxed_integer = Pbigint | Pint32 | Pint64 - -let eq_boxed_integer (p : boxed_integer) (p1 : boxed_integer) = - match p with - | Pbigint -> p1 = Pbigint - | Pint32 -> p1 = Pint32 - | Pint64 -> p1 = Pint64 - -type comparison = Lambda.comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge - -let eq_comparison (p : comparison) (p1 : comparison) = - match p with - | Cge -> p1 = Cge - | Cgt -> p1 = Cgt - | Cle -> p1 = Cle - | Clt -> p1 = Clt - | Ceq -> p1 = Ceq - | Cneq -> p1 = Cneq - -let cmp_int32 (cmp : comparison) (a : int32) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - -let cmp_int64 (cmp : comparison) (a : int64) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - -let cmp_float (cmp : comparison) (a : float) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - -let cmp_int (cmp : comparison) (a : int) b : bool = - match cmp with - | Ceq -> a = b - | Cneq -> a <> b - | Cgt -> a > b - | Cle -> a <= b - | Clt -> a < b - | Cge -> a >= b - -type compile_time_constant = - | Big_endian - | Ostype_unix - | Ostype_win32 - | Ostype - | Backend_type - -(** relies on the fact that [compile_time_constant] is enum type *) -let eq_compile_time_constant (p : compile_time_constant) - (p1 : compile_time_constant) = - p = p1 - -type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable - -type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of { name : string; mutable_flag : Asttypes.mutable_flag } - | Fld_module of { name : string } - | Fld_record_inline of { name : string } - | Fld_record_extension of { name : string } - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - | Fld_array - -let str_of_field_info (x : field_dbg_info) : string option = - match x with - | Fld_array | Fld_extension | Fld_variant | Fld_cons | Fld_poly_var_tag - | Fld_poly_var_content | Fld_tuple -> - None - | Fld_record { name; _ } - | Fld_module { name; _ } - | Fld_record_inline { name } - | Fld_record_extension { name } -> - Some name - -type set_field_dbg_info = Lambda.set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string diff --git a/jscomp/core/lam_compat.mli b/jscomp/core/lam_compat.mli deleted file mode 100644 index de02254..0000000 --- a/jscomp/core/lam_compat.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type boxed_integer = Lambda.boxed_integer = Pbigint | Pint32 | Pint64 - -type comparison = Lambda.comparison = Ceq | Cneq | Clt | Cgt | Cle | Cge - -type compile_time_constant = - | Big_endian - | Ostype_unix - | Ostype_win32 - | Ostype - | Backend_type - -type let_kind = Lambda.let_kind = Strict | Alias | StrictOpt | Variable - -type field_dbg_info = Lambda.field_dbg_info = - | Fld_record of { name : string; mutable_flag : Asttypes.mutable_flag } - | Fld_module of { name : string } - | Fld_record_inline of { name : string } - | Fld_record_extension of { name : string } - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - | Fld_array - -val str_of_field_info : field_dbg_info -> string option - -type set_field_dbg_info = Lambda.set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string - -val cmp_int32 : comparison -> int32 -> int32 -> bool - -val cmp_int64 : comparison -> int64 -> int64 -> bool - -val cmp_float : comparison -> float -> float -> bool - -val cmp_int : comparison -> int -> int -> bool - -val eq_comparison : comparison -> comparison -> bool - -val eq_boxed_integer : boxed_integer -> boxed_integer -> bool - -val eq_compile_time_constant : - compile_time_constant -> compile_time_constant -> bool diff --git a/jscomp/core/lam_compile.ml b/jscomp/core/lam_compile.ml deleted file mode 100644 index 9f7ced7..0000000 --- a/jscomp/core/lam_compile.ml +++ /dev/null @@ -1,1775 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make -module S = Js_stmt_make - -let args_either_function_or_const (args : Lam.t list) = - Ext_list.for_all args (fun x -> - match x with Lfunction _ | Lconst _ -> true | _ -> false) - -let call_info_of_ap_status (ap_status : Lam.apply_status) : Js_call_info.t = - (* XXX *) - match ap_status with - | App_infer_full -> { arity = Full; call_info = Call_ml } - | App_uncurry -> { arity = Full; call_info = Call_na } - | App_na -> { arity = NA; call_info = Call_ml } - -let rec apply_with_arity_aux (fn : J.expression) (arity : int list) - (args : E.t list) (len : int) : E.t = - if len = 0 then fn (* All arguments consumed so far *) - else - match arity with - | x :: rest -> - let x = if x = 0 then 1 else x in - (* Relax when x = 0 *) - if len >= x then - let first_part, continue = Ext_list.split_at args x in - apply_with_arity_aux - (E.call ~info:{ arity = Full; call_info = Call_ml } fn first_part) - rest continue (len - x) - else if - (* GPR #1423 *) - Ext_list.for_all args Js_analyzer.is_okay_to_duplicate - then - let params = - Ext_list.init (x - len) (fun _ -> Ext_ident.create "param") - in - E.ocaml_fun params ~return_unit:false (* unknown info *) ~async:false ~oneUnitArg:false - [ - S.return_stmt - (E.call - ~info:{ arity = Full; call_info = Call_ml } - fn - (Ext_list.append args @@ Ext_list.map params E.var)); - ] - else E.call ~info:Js_call_info.dummy fn args - (* alpha conversion now? -- - Since we did an alpha conversion before so it is not here - *) - | [] -> - (* can not happen, unless it's an exception ? *) - E.call ~info:Js_call_info.dummy fn args - -let apply_with_arity ~arity fn args = - apply_with_arity_aux fn arity args (List.length args) - -let change_tail_type_in_try (x : Lam_compile_context.tail_type) : - Lam_compile_context.tail_type = - match x with - | Maybe_tail_is_return (Tail_with_name _) -> Maybe_tail_is_return Tail_in_try - | Not_tail | Maybe_tail_is_return Tail_in_try -> x - -let in_staticcatch (x : Lam_compile_context.tail_type) : - Lam_compile_context.tail_type = - match x with - | Maybe_tail_is_return (Tail_with_name ({ in_staticcatch = false } as x)) -> - Maybe_tail_is_return (Tail_with_name { x with in_staticcatch = true }) - | _ -> x - -(* let change_tail_type_in_static - (x : Lam_compile_context.tail_type) - : Lam_compile_context.tail_type = - match x with - | Maybe_tail_is_return (Tail_with_name ({in_staticcatch=false} as z) ) -> - Maybe_tail_is_return (Tail_with_name {z with in_staticcatch=true}) - | Maybe_tail_is_return (Tail_with_name {in_staticcatch=true} ) - | Not_tail | Maybe_tail_is_return Tail_in_try - -> x *) - -(* assume outer is [Lstaticcatch] *) -let rec flat_catches (acc : Lam_compile_context.handler list) (x : Lam.t) : - Lam_compile_context.handler list * Lam.t = - match x with - | Lstaticcatch (l, (label, bindings), handler) - when acc = [] - || not - (Lam_exit_code.has_exit_code handler (fun exit -> - Ext_list.exists acc (fun x -> x.label = exit))) -> - (* #1698 should not crush exit code here without checking *) - flat_catches ({ label; handler; bindings } :: acc) l - | _ -> (acc, x) - -let flatten_nested_caches (x : Lam.t) : Lam_compile_context.handler list * Lam.t - = - flat_catches [] x - -let morph_declare_to_assign (cxt : Lam_compile_context.t) k = - match cxt.continuation with - | Declare (kind, did) -> - k { cxt with continuation = Assign did } (Some (kind, did)) - | _ -> k cxt None - -let group_apply ~merge_cases cases callback = - Ext_list.flat_map - (Ext_list.stable_group cases (fun (tag1, lam) (tag2, lam1) -> - merge_cases tag1 tag2 && Lam.eq_approx lam lam1)) - (fun group -> Ext_list.map_last group callback) -(* TODO: - for expression generation, - name, should_return is not needed, - only jmp_table and env needed -*) - -type default_case = Default of Lam.t | Complete | NonComplete - -let default_action ~saturated failaction = - match failaction with - | None -> Complete - | Some x -> if saturated then Complete else Default x - -let get_const_tag i (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with None -> None | Some { consts } -> Some consts.(i) - -let get_block i (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with None -> None | Some { blocks } -> Some blocks.(i) - -let get_tag_name (sw_names : Ast_untagged_variants.switch_names option) = - match sw_names with - | None -> Js_dump_lit.tag - | Some { blocks } -> - (match Array.find_opt (fun {Ast_untagged_variants.tag_name} -> tag_name <> None) blocks with - | Some {tag_name = Some s} -> s - | _ -> Js_dump_lit.tag - ) - -let get_block_cases (sw_names : Ast_untagged_variants.switch_names option) = - let res = ref [] in - (match sw_names with - | None -> res := [] - | Some { blocks } -> - Ext_array.iter blocks (function - | {block_type = Some block_type} -> res := block_type :: !res - | {block_type = None} -> () - ) - ); - !res - -let get_literal_cases (sw_names : Ast_untagged_variants.switch_names option) = - let res = ref [] in - (match sw_names with - | None -> res := [] - | Some { consts } -> - Ext_array.iter consts (function - | {tag_type = Some t} -> res := t :: !res - | {name; tag_type = None} -> res := String name :: !res - ) - ); - !res - - -let has_null_undefined_other (sw_names : Ast_untagged_variants.switch_names option) = - let (null, undefined, other) = (ref false, ref false, ref false) in - (match sw_names with - | None -> () - | Some { consts; blocks } -> - Ext_array.iter consts (fun x -> match x.tag_type with - | Some Undefined -> undefined := true - | Some Null -> null := true - | _ -> other := true); - ); - (!null, !undefined, !other) - -let no_effects_const = lazy true -(* let has_effects_const = lazy false *) - -(* We drop the ability of cross-compiling - the compiler has to be the same running -*) - -type initialization = J.block - -(* since it's only for alias, there is no arguments, - we should not inline function definition here, even though - it is very small - TODO: add comment here, we should try to add comment for - cross module inlining - - if we do too agressive inlining here: - - if we inline {!List.length} which will call {!A_list.length}, - then we if we try inline {!A_list.length}, this means if {!A_list} - is rebuilt, this module should also be rebuilt, - - But if the build system is content-based, suppose {!A_list} - is changed, cmj files in {!List} is unchnaged, however, - {!List.length} call {!A_list.length} which is changed, since - [ocamldep] only detect that we depend on {!List}, it will not - get re-built, then we are screwed. - - This is okay for stamp based build system. - - Another solution is that we add dependencies in the compiler - - -: we should not do functor application inlining in a - non-toplevel, it will explode code very quickly -*) - -let compile output_prefix = - -let rec compile_external_field (* Like [List.empty]*) - ?(dynamic_import = false) (lamba_cxt : Lam_compile_context.t) (id : Ident.t) name : Js_output.t = - match Lam_compile_env.query_external_id_info ~dynamic_import id name with - | { persistent_closed_lambda = Some lam } when Lam_util.not_function lam -> - compile_lambda lamba_cxt lam - | _ -> - Js_output.output_of_expression lamba_cxt.continuation - ~no_effects:no_effects_const (E.ml_var_dot ~dynamic_import id name) -(* TODO: how nested module call would behave, - In the future, we should keep in track of if - it is fully applied from [Lapply] - Seems that the module dependency is tricky.. - should we depend on [Pervasives] or not? - - we can not do this correctly for the return value, - however we can inline the definition in Pervasives - TODO: - [Pervasives.print_endline] - [Pervasives.prerr_endline] - @param id external module id - @param number the index of the external function - @param env typing environment - @param args arguments -*) - -(* This can not happen since this id should be already consulted by type checker - Worst case - {[ - E.array_index_by_int m pos - ]} -*) - -(* when module is passed as an argument - unpack to an array - for the function, generative module or functor can be a function, - however it can not be global -- global can only module -*) -and compile_external_field_apply ?(dynamic_import = false) (appinfo : Lam.apply) (module_id : Ident.t) - (field_name : string) (lambda_cxt : Lam_compile_context.t) : Js_output.t = - let ident_info = - Lam_compile_env.query_external_id_info ~dynamic_import module_id field_name - in - let ap_args = appinfo.ap_args in - match ident_info.persistent_closed_lambda with - | Some (Lfunction ({ params; body; _ } as lfunction)) - when Ext_list.same_length params ap_args && Lam_analysis.lfunction_can_be_beta_reduced lfunction -> - (* TODO: serialize it when exporting to save compile time *) - let _, param_map = - Lam_closure.is_closed_with_map Set_ident.empty params body - in - compile_lambda lambda_cxt - (Lam_beta_reduce.propagate_beta_reduce_with_map lambda_cxt.meta - param_map params body ap_args) - | _ -> - let args_code, args = - let dummy = ([], []) in - if ap_args = [] then dummy - else - let arg_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - Ext_list.fold_right ap_args dummy (fun arg_lambda (args_code, args) -> - match compile_lambda arg_cxt arg_lambda with - | { block; value = Some b } -> - (Ext_list.append block args_code, b :: args) - | _ -> assert false) - in - - let fn = E.ml_var_dot ~dynamic_import module_id ident_info.name in - let expression = - match appinfo.ap_info.ap_status with - | (App_infer_full | App_uncurry) as ap_status -> - E.call ~info:(call_info_of_ap_status ap_status) fn args - | App_na -> ( - match ident_info.arity with - | Submodule _ | Single Arity_na -> - E.call ~info:Js_call_info.dummy fn args - | Single x -> - apply_with_arity fn ~arity:(Lam_arity.extract_arity x) args) - in - Js_output.output_of_block_and_expression lambda_cxt.continuation args_code - expression - -(* - The second return values are values which need to be wrapped using - [update_dummy] - - Invariant: jmp_table can not across function boundary, - here we share env - -*) -and compile_recursive_let ~all_bindings (cxt : Lam_compile_context.t) - (id : Ident.t) (arg : Lam.t) : Js_output.t * initialization = - match arg with - | Lfunction { params; body; attr = { return_unit; async; oneUnitArg } } -> - let continue_label = Lam_util.generate_label ~name:id.name () in - (* TODO: Think about recursive value - {[ - let rec v = ref (fun _ ... - ) - ]} - [Alias] may not be exact - *) - let params = if oneUnitArg then [] else params in - let ret : Lam_compile_context.return_label = - { - id; - label = continue_label; - params; - immutable_mask = Array.make (List.length params) true; - new_params = Map_ident.empty; - triggered = false; - } - in - let output = - compile_lambda - { - cxt with - continuation = - EffectCall - (Maybe_tail_is_return - (Tail_with_name { label = Some ret; in_staticcatch = false })); - jmp_table = Lam_compile_context.empty_handler_map; - } - body - in - let result = - if ret.triggered then - let body_block = Js_output.output_as_block output in - E.ocaml_fun - (* TODO: save computation of length several times - Here we always create [ocaml_fun], - it will be renamed into [method] - when it is detected by a primitive - *) - ~return_unit ~async ~oneUnitArg ~immutable_mask:ret.immutable_mask - (Ext_list.map params (fun x -> - Map_ident.find_default ret.new_params x x)) - [ - S.while_ (* ~label:continue_label *) E.true_ - (Map_ident.fold ret.new_params body_block - (fun old new_param acc -> - S.define_variable ~kind:Alias old (E.var new_param) :: acc)); - ] - else - (* TODO: save computation of length several times *) - E.ocaml_fun params (Js_output.output_as_block output) ~return_unit ~async ~oneUnitArg - in - ( Js_output.output_of_expression - (Declare (Alias, id)) - result - ~no_effects:(lazy (Lam_analysis.no_side_effects arg)), - [] ) - | Lprim { primitive = Pmakeblock (_, _, _); args } - when args_either_function_or_const args -> - (compile_lambda { cxt with continuation = Declare (Alias, id) } arg, []) - (* case of lazy blocks, treat it as usual *) - | Lprim - { - primitive = - Pmakeblock - ( _, - (( Blk_record _ - | Blk_constructor { num_nonconst = 1 } - | Blk_record_inlined { num_nonconst = 1 } ) as tag_info), - _ ); - args = ls; - } - when Ext_list.for_all ls (fun x -> - match x with - | Lvar pid -> - Ident.same pid id - || not - @@ Ext_list.exists all_bindings (fun (other, _) -> - Ident.same other pid) - | Lconst _ -> true - | _ -> false) -> - (* capture cases like for {!Queue} - {[let rec cell = { content = x; next = cell} ]} - #1716: be careful not to optimize such cases: - {[ let rec a = { b} and b = { a} ]} they are indeed captured - and need to be declared first - TODO: this should be inlined based on tag info - *) - ( Js_output.make - (S.define_variable ~kind:Variable id (E.dummy_obj tag_info) - :: Ext_list.mapi ls (fun i x -> - S.exp - (Js_of_lam_block.set_field - (match tag_info with - | Blk_record { fields = xs } -> Fld_record_set xs.(i) - | Blk_record_inlined xs -> - Fld_record_inline_set xs.fields.(i) - | Blk_constructor p -> ( - let is_cons = p.name = Literals.cons in - match (is_cons, i) with - | true, 0 -> Fld_record_inline_set Literals.hd - | true, 1 -> Fld_record_inline_set Literals.tl - | _, _ -> Fld_record_inline_set ("_" ^ string_of_int i) - ) - | _ -> assert false) - (E.var id) (Int32.of_int i) - (match x with - | Lvar lid -> E.var lid - | Lconst x -> Lam_compile_const.translate x - | _ -> assert false)))), - [] ) - | Lprim { primitive = Pmakeblock (_, tag_info, _) } -> ( - (* Lconst should not appear here if we do [scc] - optimization, since it's faked recursive value, - however it would affect scope issues, we have to declare it first - *) - match - compile_lambda { cxt with continuation = NeedValue Not_tail } arg - with - | { block = b; value = Some v } -> - (* TODO: check recursive value .. - could be improved for simple cases - *) - ( Js_output.make - (Ext_list.append b - [ - S.exp - (E.runtime_call Js_runtime_modules.obj_runtime - "update_dummy" [ E.var id; v ]); - ]), - [ S.define_variable ~kind:Variable id (E.dummy_obj tag_info) ] ) - | _ -> assert false) - | _ -> - (* pathological case: - fail to capture taill call? - {[ let rec a = - if g > 30 then .. fun () -> a () - ]} - - Neither below is not allowed in ocaml: - {[ - let rec v = - if sum 0 10 > 20 then - 1::v - else 2:: v - ]} - {[ - let rec v = - if sum 0 10 > 20 then - fun _ -> print_endline "hi"; v () - else - fun _-> print_endline "hey"; v () - ]} - *) - (compile_lambda { cxt with continuation = Declare (Alias, id) } arg, []) - -and compile_recursive_lets_aux cxt (id_args : Lam_scc.bindings) : Js_output.t = - (* #1716 *) - let output_code, ids = - Ext_list.fold_right id_args (Js_output.dummy, []) - (fun (ident, arg) (acc, ids) -> - let code, declare_ids = - compile_recursive_let ~all_bindings:id_args cxt ident arg - in - (Js_output.append_output code acc, Ext_list.append declare_ids ids)) - in - match ids with - | [] -> output_code - | _ -> Js_output.append_output (Js_output.make ids) output_code - -and compile_recursive_lets cxt id_args : Js_output.t = - match id_args with - | [] -> Js_output.dummy - | _ -> ( - let id_args_group = Lam_scc.scc_bindings id_args in - match id_args_group with - | [] -> assert false - | first :: rest -> - let acc = compile_recursive_lets_aux cxt first in - Ext_list.fold_left rest acc (fun acc x -> - Js_output.append_output acc (compile_recursive_lets_aux cxt x))) - -and compile_general_cases : - 'a . - make_exp: ('a -> J.expression) -> - eq_exp: ('a option -> J.expression -> 'a option -> J.expression -> J.expression) -> - cxt: Lam_compile_context.t -> - switch: (?default:J.block -> ?declaration:Lam_compat.let_kind * Ident.t -> - _ -> ('a * J.case_clause) list -> J.statement) -> - switch_exp: J.expression -> - default: default_case -> - ?merge_cases: ('a -> 'a -> bool) -> - ('a * Lam.t) list -> - J.block = - fun (type a) - ~(make_exp : a -> J.expression) - ~(eq_exp : a option -> J.expression -> a option -> J.expression -> J.expression) - ~(cxt : Lam_compile_context.t) - ~(switch : - ?default:J.block -> - ?declaration:Lam_compat.let_kind * Ident.t -> - _ -> (a * J.case_clause) list -> J.statement - ) - ~(switch_exp : J.expression) - ~(default : default_case) - ?(merge_cases = fun _ _ -> true) - (cases : (a * Lam.t) list) -> - match (cases, default) with - | [], Default lam -> Js_output.output_as_block (compile_lambda cxt lam) - | [], (Complete | NonComplete) -> [] - | [ (_, lam) ], Complete -> - (* To take advantage of such optimizations, - when we generate code using switch, - we should always have a default, - otherwise the compiler engine would think that - it's also complete - *) - Js_output.output_as_block (compile_lambda cxt lam) - | [ (id, lam) ], NonComplete -> - morph_declare_to_assign cxt (fun cxt define -> - [ - S.if_ ?declaration:define - - (eq_exp None switch_exp (Some id) (make_exp id)) - (Js_output.output_as_block (compile_lambda cxt lam)); - ]) - | [ (id, lam) ], Default x | [ (id, lam); (_, x) ], Complete -> - morph_declare_to_assign cxt (fun cxt define -> - let else_block = Js_output.output_as_block (compile_lambda cxt x) in - let then_block = Js_output.output_as_block (compile_lambda cxt lam) in - [ - S.if_ ?declaration:define - (eq_exp None switch_exp (Some id) (make_exp id)) - then_block ~else_:else_block; - ]) - | _, _ -> - (* TODO: this is not relevant to switch case - however, in a subset of switch-case if we can analysis - its branch are the same, we can propogate which - might encourage better inlining strategey - --- - TODO: grouping can be delayed untile JS IR - - see #2413 - In general, we know it is last call, - there is no need to print [break]; - But we need make sure the last call lambda does not - have `(exit ..)` due to we pass should_return from Lstaticcath downwards - Since this is a rough approximation, some `(exit ..)` does not destroy - last call property, we use exiting should_break to improve preciseness - (and it indeed help catch - - tailcall or not does not matter, if it is the tailcall - break still should not be printed (it will be continuned) - TOOD: disabled temporarily since it's not perfect yet *) - morph_declare_to_assign cxt (fun cxt declaration -> - (* Exclude cases that are the same as the default if the default is defined *) - let cases = match default with - | Default lam -> List.filter (fun (_, lam1) -> not (Lam.eq_approx lam lam1)) cases - | _ -> cases - in - let default = - match default with - | Complete -> None - | NonComplete -> None - | Default lam -> - Some (Js_output.output_as_block (compile_lambda cxt lam)) - in - let body = - group_apply ~merge_cases cases (fun last (switch_case, lam) -> - if last then - (* merge and shared *) - let switch_body, should_break = - Js_output.to_break_block (compile_lambda cxt lam) - in - let should_break = - if - not - @@ Lam_compile_context.continuation_is_return - cxt.continuation - then should_break - else should_break && Lam_exit_code.has_exit lam - in - ( switch_case, - J. - { - switch_body; - should_break; - comment = None; - } ) - else - ( switch_case, - { - switch_body = []; - should_break = false; - comment = None; - } )) - (* TODO: we should also group default *) - (* The last clause does not need [break] - common break through, *) - in - - [ switch ?default ?declaration switch_exp body ]) - -and use_compile_literal_cases table ~(get_tag : _ -> Ast_untagged_variants.tag option) = - List.fold_right (fun (i, lam) acc -> - match get_tag i, acc with - | Some {Ast_untagged_variants.tag_type = Some t}, Some string_table -> - Some ((t, lam) :: string_table) - | Some {name; tag_type = None}, Some string_table -> Some ((String name, lam) :: string_table) - | _, _ -> None - ) table (Some []) -and compile_cases - ?(untagged=false) ~cxt ~(switch_exp : E.t) ?(default = NonComplete) - ?(get_tag = fun _ -> None) ?(block_cases=[]) cases : initialization = - match use_compile_literal_cases cases ~get_tag with - | Some string_cases -> - if untagged - then compile_untagged_cases ~cxt ~switch_exp ~block_cases ~default string_cases - else compile_string_cases ~cxt ~switch_exp ~default string_cases - | None -> - cases |> compile_general_cases - ~make_exp:(fun i -> match get_tag i with - | None -> E.small_int i - | Some {tag_type = Some(String s)} -> E.str s - | Some {name} -> E.str name) - ~eq_exp: (fun _ x _ y -> E.int_equal x y) - ~cxt - ~switch: (fun ?default ?declaration e clauses -> - S.int_switch ?default ?declaration e clauses) - ~switch_exp - ~default - -and compile_switch (switch_arg : Lam.t) (sw : Lam.lambda_switch) - (lambda_cxt : Lam_compile_context.t) = - (* TODO: if default is None, we can do some optimizations - Use switch vs if/then/else - - TODO: switch based optimiztion - hash, group, or using array, - also if last statement is throw -- should we drop remaining - statement? - *) - let ({ - sw_consts_full; - sw_consts; - sw_blocks_full; - sw_blocks; - sw_failaction; - sw_names; - } - : Lam.lambda_switch) = - sw - in - let sw_num_default = default_action ~saturated:sw_consts_full sw_failaction in - let sw_blocks_default = - default_action ~saturated:sw_blocks_full sw_failaction - in - let get_const_tag i = get_const_tag i sw_names in - let get_block i = get_block i sw_names in - let block_cases = get_block_cases sw_names in - let get_block_tag i : Ast_untagged_variants.tag option = match get_block i with - | None -> None - | Some ({tag = {name}; block_type = Some block_type}) -> - Some {name; tag_type = Some (Untagged block_type)} (* untagged block *) - | Some ({block_type = None; tag}) -> (* tagged block *) - Some tag in - let tag_name = get_tag_name sw_names in - let untagged = block_cases <> [] in - let compile_whole (cxt : Lam_compile_context.t) = - match - compile_lambda { cxt with continuation = NeedValue Not_tail } switch_arg - with - | { value = None; _ } -> assert false - | { block; value = Some e } -> ( - block - @ - if sw_consts_full && sw_consts = [] then - compile_cases ~block_cases - ~untagged ~cxt - ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~default:sw_blocks_default - ~get_tag:get_block_tag sw_blocks - else if sw_blocks_full && sw_blocks = [] then - compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default ~get_tag:get_const_tag sw_consts - else - (* [e] will be used twice *) - let dispatch e = - - let is_a_literal_case = - if block_cases <> [] - then - E.is_a_literal_case ~literal_cases:(get_literal_cases sw_names) ~block_cases e - else - E.is_int_tag ~has_null_undefined_other:(has_null_undefined_other sw_names) e in - S.if_ is_a_literal_case - (compile_cases ~cxt ~switch_exp:e ~block_cases ~default:sw_num_default ~get_tag:get_const_tag sw_consts) - ~else_: - (compile_cases - ~untagged ~cxt - ~switch_exp:(if untagged then e else E.tag ~name:tag_name e) - ~block_cases - ~default:sw_blocks_default - ~get_tag:get_block_tag sw_blocks) - in - match e.expression_desc with - | J.Var _ -> [ dispatch e ] - | _ -> - let v = Ext_ident.create_tmp () in - (* Necessary avoid duplicated computation*) - [ S.define_variable ~kind:Variable v e; dispatch (E.var v) ]) - in - match lambda_cxt.continuation with - (* Needs declare first *) - | NeedValue _ -> - (* Necessary since switch is a statement, we need they return - the same value for different branches -- can be optmized - when branches are minimial (less than 2) - *) - let v = Ext_ident.create_tmp () in - Js_output.make - (S.declare_variable ~kind:Variable v - :: compile_whole { lambda_cxt with continuation = Assign v }) - ~value:(E.var v) - | Declare (kind, id) -> - Js_output.make - (S.declare_variable ~kind id - :: compile_whole { lambda_cxt with continuation = Assign id }) - | EffectCall _ | Assign _ -> Js_output.make (compile_whole lambda_cxt) - - -and compile_string_cases ~cxt ~switch_exp ~default cases: initialization = - cases |> compile_general_cases - ~make_exp:E.tag_type - ~eq_exp: (fun _ x _ y -> E.string_equal x y) - ~cxt - ~switch: (fun ?default ?declaration e clauses -> - S.string_switch ?default ?declaration e clauses) - ~switch_exp - ~default -and compile_untagged_cases ~cxt ~switch_exp ~default ~block_cases cases = - let mk_eq (i : Ast_untagged_variants.tag_type option) x j y = - let check = match i, j with - | Some tag_type, _ -> - Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type ~block_cases (Expr x) (Expr y) - | _, Some tag_type -> - Ast_untagged_variants.DynamicChecks.add_runtime_type_check ~tag_type ~block_cases (Expr y) (Expr x) - | _ -> - Ast_untagged_variants.DynamicChecks.(==) (Expr x) (Expr y) - in - E.emit_check check - in - let tag_is_not_typeof = function - | Ast_untagged_variants.Untagged (InstanceType _) -> true - | _ -> false in - let clause_is_not_typeof (tag, _) = tag_is_not_typeof tag in - let switch ?default ?declaration e clauses = - let (not_typeof_clauses, typeof_clauses) = List.partition clause_is_not_typeof clauses in - let rec build_if_chain remaining_clauses = (match remaining_clauses with - | (Ast_untagged_variants.Untagged (InstanceType instanceType), {J.switch_body}) :: rest -> - S.if_ (E.emit_check (IsInstanceOf (instanceType, Expr e))) - (switch_body) - ~else_:([build_if_chain rest]) - | _ -> S.string_switch ?default ?declaration (E.typeof e) typeof_clauses) in - build_if_chain not_typeof_clauses in - let merge_cases tag1 tag2 = (* only merge typeof cases, as instanceof cases are pulled out into if-then-else *) - not (tag_is_not_typeof tag1 || tag_is_not_typeof tag2) in - cases |> compile_general_cases - ~make_exp: E.tag_type - ~eq_exp: mk_eq - ~cxt - ~switch - ~switch_exp - ~default - ~merge_cases - -and compile_stringswitch l cases default (lambda_cxt : Lam_compile_context.t) = - (* TODO might better optimization according to the number of cases - Be careful: we should avoid multiple evaluation of l, - The [gen] can be elimiated when number of [cases] is less than 3 - *) - let cases = cases |> List.map (fun (s,l) -> Ast_untagged_variants.String s, l) in - match - compile_lambda { lambda_cxt with continuation = NeedValue Not_tail } l - with - | { value = None } -> assert false - | { block; value = Some e } -> ( - (* when should_return is true -- it's passed down - otherwise it's ok *) - let default = - match default with Some x -> Default x | None -> Complete - in - match lambda_cxt.continuation with - (* TODO: can be avoided when cases are less than 3 *) - | NeedValue _ -> - let v = Ext_ident.create_tmp () in - Js_output.make - (Ext_list.append block - (compile_string_cases - ~cxt: { lambda_cxt with continuation = Declare (Variable, v) } - ~switch_exp:e ~default cases)) - ~value:(E.var v) - | _ -> - Js_output.make - (Ext_list.append block - (compile_string_cases ~cxt:lambda_cxt ~switch_exp:e ~default cases ))) - -(* - This should be optimized in lambda layer - (let (match/1038 = (apply g/1027 x/1028)) - (catch - (stringswitch match/1038 - case "aabb": 0 - case "bbc": 1 - default: (exit 1)) - with (1) 2)) - *) -and compile_staticraise i (largs : Lam.t list) - (lambda_cxt : Lam_compile_context.t) = - (* [i] is the jump table, [largs] is the arguments passed to [Lstaticcatch]*) - match Lam_compile_context.find_exn lambda_cxt i with - | { exit_id; bindings; order_id } -> - Ext_list.fold_right2 largs bindings - (Js_output.make - (if order_id >= 0 then [ S.assign exit_id (E.small_int order_id) ] - else [])) - (fun larg bind acc -> - let new_output = - match larg with - | Lvar id -> Js_output.make [ S.assign bind (E.var id) ] - | _ -> - (* TODO: should be Assign -- Assign is an optimization *) - compile_lambda - { lambda_cxt with continuation = Assign bind } - larg - in - Js_output.append_output new_output acc) - -(* Invariant: exit_code can not be reused - (catch l with (32) - (handler)) - 32 should not be used in another catch - Invariant: - This is true in current ocaml compiler - currently exit only appears in should_return position relative to staticcatch - if not we should use ``javascript break`` or ``continue`` - if exit_code_id == code - handler -- ids are not useful, since - when compiling `largs` we will do the binding there - - when exit_code is undefined internally, - it should PRESERVE ``tail`` property - - if it uses `staticraise` only once - or handler is minimal, we can inline - - always inline also seems to be ok, but it might bloat the code - - another common scenario is that we have nested catch - (catch (catch (catch ..)) - checkout example {!Digest.file}, you can not inline handler there, - we can spot such patten and use finally there? - {[ - let file filename = - let ic = open_in_bin filename in - match channel ic (-1) with - | d -> close_in ic; d - | exception e -> close_in ic; raise e - - ]} -*) -and compile_staticcatch (lam : Lam.t) (lambda_cxt : Lam_compile_context.t) = - let code_table, body = flatten_nested_caches lam in - let exit_id = Ext_ident.create_tmp ~name:"exit" () in - match (lambda_cxt.continuation, code_table) with - | ( EffectCall - (Maybe_tail_is_return (Tail_with_name { in_staticcatch = false }) as - tail_type), - [ code_table ] ) - (* tail position and only one exit code *) - when Lam_compile_context.no_static_raise_in_handler code_table -> - let jmp_table, handler = - Lam_compile_context.add_pseudo_jmp lambda_cxt.jmp_table exit_id - code_table - in - let new_cxt = - { - lambda_cxt with - jmp_table; - continuation = EffectCall (in_staticcatch tail_type); - } - in - - let lbody = compile_lambda new_cxt body in - let declares = - Ext_list.map code_table.bindings (fun x -> - S.declare_variable ~kind:Variable x) - in - Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody (compile_lambda lambda_cxt handler)) - | _ -> ( - let exit_expr = E.var exit_id in - let jmp_table, handlers = - Lam_compile_context.add_jmps lambda_cxt.jmp_table exit_id code_table - in - - (* Declaration First, body and handler have the same value *) - let declares = - S.define_variable ~kind:Variable exit_id E.zero_int_literal - :: (* we should always make it zero here, since [zero] is reserved in our mapping*) - Ext_list.flat_map code_table (fun { bindings } -> - Ext_list.map bindings (fun x -> - S.declare_variable ~kind:Variable x)) - in - match lambda_cxt.continuation with - (* could be optimized when cases are less than 3 *) - | NeedValue _ -> - let v = Ext_ident.create_tmp () in - let new_cxt = - { lambda_cxt with jmp_table; continuation = Assign v } - in - let lbody = compile_lambda new_cxt body in - Js_output.append_output - (Js_output.make (S.declare_variable ~kind:Variable v :: declares)) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers) - ~value:(E.var v))) - | Declare (kind, id) (* declare first this we will do branching*) -> - let declares = S.declare_variable ~kind id :: declares in - let new_cxt = - { lambda_cxt with jmp_table; continuation = Assign id } - in - let lbody = compile_lambda new_cxt body in - Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers))) - (* place holder -- tell the compiler that - we don't know if it's complete - *) - | EffectCall tail_type as cont -> - let continuation = - let new_tail_type = in_staticcatch tail_type in - if new_tail_type == tail_type then cont - else EffectCall new_tail_type - in - let new_cxt = { lambda_cxt with jmp_table; continuation } in - let lbody = compile_lambda new_cxt body in - Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers))) - | Assign _ -> - let new_cxt = { lambda_cxt with jmp_table } in - let lbody = compile_lambda new_cxt body in - Js_output.append_output (Js_output.make declares) - (Js_output.append_output lbody - (Js_output.make - (compile_cases ~cxt:new_cxt ~switch_exp:exit_expr handlers)))) - -and compile_sequand (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) - = - if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequand l r) - else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - match compile_lambda new_cxt l with - | { value = None } -> assert false - | { block = l_block; value = Some l_expr } -> ( - match compile_lambda new_cxt r with - | { value = None } -> assert false - | { block = []; value = Some r_expr } -> - Js_output.output_of_block_and_expression lambda_cxt.continuation - l_block (E.and_ l_expr r_expr) - | { block = r_block; value = Some r_expr } -> ( - match lambda_cxt.continuation with - | Assign v -> - (* Refernece Js_output.output_of_block_and_expression *) - Js_output.make - (l_block - @ [ - S.if_ l_expr - (r_block @ [ S.assign v r_expr ]) - ~else_:[ S.assign v E.false_ ]; - ]) - | Declare (_kind, v) -> - (* Refernece Js_output.output_of_block_and_expression *) - Js_output.make - (l_block - @ [ - S.define_variable ~kind:Variable v E.false_; - S.if_ l_expr (r_block @ [ S.assign v r_expr ]); - ]) - | EffectCall _ | NeedValue _ -> - let v = Ext_ident.create_tmp () in - Js_output.make - ((S.define_variable ~kind:Variable v E.false_ :: l_block) - @ [ S.if_ l_expr (r_block @ [ S.assign v r_expr ]) ]) - ~value:(E.var v))) - -and compile_sequor (l : Lam.t) (r : Lam.t) (lambda_cxt : Lam_compile_context.t) - = - if Lam_compile_context.continuation_is_return lambda_cxt.continuation then - compile_lambda lambda_cxt (Lam.sequor l r) - else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - match compile_lambda new_cxt l with - | { value = None } -> assert false - | { block = l_block; value = Some l_expr } -> ( - match compile_lambda new_cxt r with - | { value = None } -> assert false - | { block = []; value = Some r_expr } -> - let exp = E.or_ l_expr r_expr in - Js_output.output_of_block_and_expression lambda_cxt.continuation - l_block exp - | { block = r_block; value = Some r_expr } -> ( - match lambda_cxt.continuation with - | Assign v -> - (* Reference Js_output.output_of_block_and_expression *) - Js_output.make - (l_block - @ [ - S.if_ (E.not l_expr) - (r_block @ [ S.assign v r_expr ]) - ~else_:[ S.assign v E.true_ ]; - ]) - | Declare (_kind, v) -> - Js_output.make - (l_block - @ [ - S.define_variable ~kind:Variable v E.true_; - S.if_ (E.not l_expr) (r_block @ [ S.assign v r_expr ]); - ]) - | EffectCall _ | NeedValue _ -> - let v = Ext_ident.create_tmp () in - Js_output.make - (l_block - @ [ - S.define_variable ~kind:Variable v E.true_; - S.if_ (E.not l_expr) (r_block @ [ S.assign v r_expr ]); - ]) - ~value:(E.var v))) - -(* Note that ``J.While(expression * statement )`` - idealy if ocaml expression does not need fresh variables, we can generate - while expression, here we generate for statement, leave optimization later. - (Sine OCaml expression can be really complex..) -*) -and compile_while (predicate : Lam.t) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = - match - compile_lambda - { lambda_cxt with continuation = NeedValue Not_tail } - predicate - with - | { value = None } -> assert false - | { block; value = Some e } -> - (* st = NeedValue -- this should be optimized and never happen *) - let e = match block with [] -> e | _ -> E.of_block block ~e in - let block = - [ - S.while_ e - (Js_output.output_as_block - @@ compile_lambda - { lambda_cxt with continuation = EffectCall Not_tail } - body); - ] - in - Js_output.output_of_block_and_expression lambda_cxt.continuation block - E.unit - -(* all non-tail - TODO: check semantics should start, finish be executed each time in both - ocaml and js?, also check evaluation order.. - in ocaml id is not in the scope of finish, so it should be safe here - - for i = 0 to (print_int 3; 10) do print_int i done;; - 3012345678910- : unit = () - - for(var i = 0 ; i < (console.log(i),10); ++i){console.log('hi')} - print i each time, so they are different semantics... -*) - -and compile_for (id : J.for_ident) (start : Lam.t) (finish : Lam.t) - (direction : Js_op.direction_flag) (body : Lam.t) - (lambda_cxt : Lam_compile_context.t) = - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - let block = - match (compile_lambda new_cxt start, compile_lambda new_cxt finish) with - | { value = None }, _ | _, { value = None } -> assert false - | { block = b1; value = Some e1 }, { block = b2; value = Some e2 } -> ( - (* order b1 -- (e1 -- b2 -- e2) - in most cases we can shift it into such scenarios - b1, b2, [e1, e2] - - b2 is Empty - - e1 is pure - we can guarantee e1 is pure, if it literally contains a side effect call, - put it in the beginning - *) - let block_body = - Js_output.output_as_block - (compile_lambda - { lambda_cxt with continuation = EffectCall Not_tail } - body) - in - match (b1, b2) with - | _, [] -> - Ext_list.append_one b1 (S.for_ (Some e1) e2 id direction block_body) - | _, _ - when Js_analyzer.no_side_effect_expression e1 - (* - e1 > b2 > e2 - re-order - b2 > e1 > e2 - *) - -> - Ext_list.append b1 - (Ext_list.append_one b2 - (S.for_ (Some e1) e2 id direction block_body)) - | _, _ -> - Ext_list.append b1 - (S.define_variable ~kind:Variable id e1 - :: Ext_list.append_one b2 (S.for_ None e2 id direction block_body) - )) - in - Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - -and compile_assign id (lambda : Lam.t) (lambda_cxt : Lam_compile_context.t) = - let block = - match lambda with - | Lprim { primitive = Poffsetint v; args = [ Lvar bid ] } - when Ident.same id bid -> - [ S.exp (E.assign (E.var id) (E.int32_add (E.var id) (E.small_int v))) ] - | _ -> ( - match - compile_lambda - { lambda_cxt with continuation = NeedValue Not_tail } - lambda - with - | { value = None } -> assert false - | { block; value = Some v } -> Ext_list.append_one block (S.assign id v) - ) - in - Js_output.output_of_block_and_expression lambda_cxt.continuation block E.unit - -(* - tail --> should be renamed to `shouldReturn` - in most cases ``shouldReturn`` == ``tail``, however, here is not, - should return, but it is not a tail call in js - (* could be optimized using javascript style exceptions *) - {[ - {try - {var $js=g(x);} - catch(exn){if(exn=Not_found){var $js=0;}else{throw exn;}} - return h($js); - } - ]} -*) -and compile_trywith lam id catch (lambda_cxt : Lam_compile_context.t) = - let aux (with_context : Lam_compile_context.t) - (body_context : Lam_compile_context.t) = - (* should_return is passed down - #1701, try should prevent tailcall *) - [ - S.try_ - (Js_output.output_as_block (compile_lambda body_context lam)) - ~with_: - (id, Js_output.output_as_block (compile_lambda with_context catch)); - ] - in - match lambda_cxt.continuation with - | Declare (kind, id) -> - let context = { lambda_cxt with continuation = Assign id } in - Js_output.make (S.declare_variable ~kind id :: aux context context) - | Assign _ -> Js_output.make (aux lambda_cxt lambda_cxt) - | NeedValue _ -> - let v = Ext_ident.create_tmp () in - let context = { lambda_cxt with continuation = Assign v } in - Js_output.make - (S.declare_variable ~kind:Variable v :: aux context context) - ~value:(E.var v) - | EffectCall return_type -> - let new_return_type = change_tail_type_in_try return_type in - if new_return_type == return_type then - Js_output.make (aux lambda_cxt lambda_cxt) - else - Js_output.make - (aux lambda_cxt - { lambda_cxt with continuation = EffectCall new_return_type }) - -(* Note that in [Texp_apply] for [%sendcache] the cache might not be used - see {!CamlinternalOO.send_meth} and {!Translcore.transl_exp0} the branch - [Texp_apply] when [public_send ], args are simply dropped - - reference - [js_of_ocaml] - 1. GETPUBMET - 2. GETDYNMET - 3. GETMETHOD - [ocaml] - Lsend (bytegen.ml) - For the object layout refer to [camlinternalOO/create_object] - {[ - let create_object table = - (* XXX Appel de [obj_block] *) - let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in - (* XXX Appel de [caml_modify] *) - Obj.set_field obj 0 (Obj.repr table.methods); - Obj.obj (set_id obj) - - let create_object_opt obj_0 table = - if (Obj.magic obj_0 : bool) then obj_0 else begin - (* XXX Appel de [obj_block] *) - let obj = mark_ocaml_object @@ Obj.new_block Obj.object_tag table.size in - (* XXX Appel de [caml_modify] *) - Obj.set_field obj 0 (Obj.repr table.methods); - Obj.obj (set_id obj) - end - ]} - it's a block with tag [248], the first field is [table.methods] which is an array - {[ - type table = - { mutable size: int; - mutable methods: closure array; - mutable methods_by_name: meths; - mutable methods_by_label: labs; - mutable previous_states: - (meths * labs * (label * item) list * vars * - label list * string list) list; - mutable hidden_meths: (label * item) list; - mutable vars: vars; - mutable initializers: (obj -> unit) list } - ]} -*) -and compile_ifthenelse (predicate : Lam.t) (t_branch : Lam.t) (f_branch : Lam.t) - (lambda_cxt : Lam_compile_context.t) = - match - compile_lambda - { lambda_cxt with continuation = NeedValue Not_tail } - predicate - with - | { value = None } -> assert false - | { block = b; value = Some e } -> ( - match lambda_cxt.continuation with - | NeedValue _ -> ( - match - ( compile_lambda lambda_cxt t_branch, - compile_lambda lambda_cxt f_branch ) - with - | { block = []; value = Some out1 }, { block = []; value = Some out2 } - -> - (* speical optimization *) - Js_output.make b ~value:(E.econd e out1 out2) - | _, _ -> ( - (* we can not reuse -- here we need they have the same name, - TODO: could be optimized by inspecting assigment statement *) - let id = Ext_ident.create_tmp () in - let assign_cxt = { lambda_cxt with continuation = Assign id } in - match - ( compile_lambda assign_cxt t_branch, - compile_lambda assign_cxt f_branch ) - with - | out1, out2 -> - Js_output.make - (Ext_list.append - (S.declare_variable ~kind:Variable id :: b) - [ - S.if_ e - (Js_output.output_as_block out1) - ~else_:(Js_output.output_as_block out2); - ]) - ~value:(E.var id))) - | Declare (kind, id) -> ( - let declare_cxt = - { lambda_cxt with continuation = NeedValue Not_tail } - in - match - ( compile_lambda declare_cxt t_branch, - compile_lambda declare_cxt f_branch ) - with - | { block = []; value = Some out1 }, { block = []; value = Some out2 } - -> - (* Invariant: should_return is false*) - Js_output.make - (Ext_list.append_one b - (S.define_variable ~kind id (E.econd e out1 out2))) - | _, _ -> - Js_output.make - (Ext_list.append_one b - (S.if_ ~declaration:(kind, id) e - (Js_output.output_as_block - @@ compile_lambda - { lambda_cxt with continuation = Assign id } - t_branch) - ~else_: - (Js_output.output_as_block - @@ compile_lambda - { lambda_cxt with continuation = Assign id } - f_branch)))) - | Assign _ -> - let then_output = - Js_output.output_as_block (compile_lambda lambda_cxt t_branch) - in - let else_output = - Js_output.output_as_block (compile_lambda lambda_cxt f_branch) - in - Js_output.make - (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)) - | EffectCall should_return -> ( - let context1 = - { lambda_cxt with continuation = NeedValue should_return } - in - match - ( should_return, - compile_lambda context1 t_branch, - compile_lambda context1 f_branch ) - with - (* see PR#83 *) - | ( Not_tail, - { block = []; value = Some out1 }, - { block = []; value = Some out2 } ) -> ( - match - ( Js_exp_make.remove_pure_sub_exp out1, - Js_exp_make.remove_pure_sub_exp out2 ) - with - | None, None -> Js_output.make (Ext_list.append_one b (S.exp e)) - (* FIX #1762 *) - | Some out1, Some out2 -> - Js_output.make b ~value:(E.econd e out1 out2) - | Some out1, None -> - Js_output.make - (Ext_list.append_one b (S.if_ e [ S.exp out1 ])) - | None, Some out2 -> - Js_output.make - (Ext_list.append_one b (S.if_ (E.not e) [ S.exp out2 ]))) - | Not_tail, { block = []; value = Some out1 }, _ -> - (* assert branch - TODO: here we re-compile two branches since - its context is different -- could be improved - *) - if Js_analyzer.no_side_effect_expression out1 then - Js_output.make - (Ext_list.append b - [ - S.if_ (E.not e) - (Js_output.output_as_block - @@ compile_lambda lambda_cxt f_branch); - ]) - else - Js_output.make - (Ext_list.append b - [ - S.if_ e - (Js_output.output_as_block - @@ compile_lambda lambda_cxt t_branch) - ~else_: - (Js_output.output_as_block - @@ compile_lambda lambda_cxt f_branch); - ]) - | Not_tail, _, { block = []; value = Some out2 } -> - let else_ = - if Js_analyzer.no_side_effect_expression out2 then None - else - Some - (Js_output.output_as_block - (compile_lambda lambda_cxt f_branch)) - in - Js_output.make - (Ext_list.append_one b - (S.if_ e - (Js_output.output_as_block - (compile_lambda lambda_cxt t_branch)) - ?else_)) - | ( Maybe_tail_is_return _, - { block = []; value = Some out1 }, - { block = []; value = Some out2 } ) -> - Js_output.make - (Ext_list.append_one b (S.return_stmt (E.econd e out1 out2))) - ~output_finished:True - | _, _, _ -> - let then_output = - Js_output.output_as_block (compile_lambda lambda_cxt t_branch) - in - let else_output = - Js_output.output_as_block (compile_lambda lambda_cxt f_branch) - in - Js_output.make - (Ext_list.append_one b (S.if_ e then_output ~else_:else_output)) - )) - -and compile_apply (appinfo : Lam.apply) (lambda_cxt : Lam_compile_context.t) = - match appinfo with - | { - ap_func = - Lapply { ap_func; ap_args; ap_info = { ap_status = App_na; ap_inlined } }; - ap_info = { ap_status = App_na } as outer_ap_info; - } -> - (* After inlining, we can generate such code, see {!Ari_regress_test}*) - let ap_info = - if outer_ap_info.ap_inlined = ap_inlined then outer_ap_info - else { outer_ap_info with ap_inlined } - in - compile_lambda lambda_cxt - (Lam.apply ap_func (Ext_list.append ap_args appinfo.ap_args) ap_info) - (* External function call: it can not be tailcall in this case*) - | { - ap_func = - Lprim { primitive = Pfield (_, fld_info); args = [ Lglobal_module (id, dynamic_import) ]; _ }; - } -> ( - match fld_info with - | Fld_module { name } -> - compile_external_field_apply ~dynamic_import appinfo id name lambda_cxt - | _ -> assert false) - | _ -> ( - (* TODO: --- - 1. check arity, can be simplified for pure expression - 2. no need create names - *) - let ap_func = appinfo.ap_func in - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - let[@warning "-8" (* non-exhaustive pattern*)] args_code, fn_code :: args - = - Ext_list.fold_right (ap_func :: appinfo.ap_args) ([], []) - (fun x (args_code, fn_code) -> - match compile_lambda new_cxt x with - | { block; value = Some b } -> - (Ext_list.append block args_code, b :: fn_code) - | { value = None } -> assert false) - in - match (ap_func, lambda_cxt.continuation) with - | ( Lvar fn_id, - ( EffectCall - (Maybe_tail_is_return (Tail_with_name { label = Some ret })) - | NeedValue - (Maybe_tail_is_return (Tail_with_name { label = Some ret })) ) ) - when Ident.same ret.id fn_id -> - ret.triggered <- true; - (* Here we mark [finished] true, since the continuation - does not make sense any more (due to that we have [continue]) - TODO: [finished] is not a meaningful name, we should use [truncate] - to mean the following statement should be truncated - *) - (* - actually, there is no easy way to determin - if the argument depends on an expresion, since - it can be a function, then it may depend on anything - http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/5727b4ecaaef6a7a350c9d98f5f68432.en.html - http://caml.inria.fr/pub/ml-archives/caml-list/2005/02/fe9bc4e23e6dc8c932c8ab34240ff195.en.html - - *) - (* TODO: use [fold]*) - let _, assigned_params, new_params = - let args = if ret.params = [] then [] else args in - Ext_list.fold_left2 ret.params args (0, [], Map_ident.empty) - (fun param arg (i, assigns, new_params) -> - match arg with - | { expression_desc = Var (Id x); _ } when Ident.same x param -> - (i + 1, assigns, new_params) - | _ -> - let new_param, m = - match Map_ident.find_opt ret.new_params param with - | None -> - ret.immutable_mask.(i) <- false; - let v = Ext_ident.create ("_" ^ param.name) in - (v, Map_ident.add new_params param v) - | Some v -> (v, new_params) - in - (i + 1, (new_param, arg) :: assigns, m)) - in - ret.new_params <- - Map_ident.disjoint_merge_exn new_params ret.new_params (fun _ _ _ -> - assert false); - let block = - Ext_list.map_append assigned_params [ S.continue_ ] - (fun (param, arg) -> S.assign param arg) - in - (* Note true and continue needed to be handled together*) - Js_output.make ~output_finished:True (Ext_list.append args_code block) - | _ -> - Js_output.output_of_block_and_expression lambda_cxt.continuation - args_code - (E.call - ~info:(call_info_of_ap_status appinfo.ap_info.ap_status) - fn_code args)) - -and compile_prim (prim_info : Lam.prim_info) - (lambda_cxt : Lam_compile_context.t) = - match prim_info with - | { primitive = Pfield (_, fld_info); args = [ Lglobal_module (id, dynamic_import) ]; _ } -> ( - (* should be before Lglobal_global *) - match fld_info with - | Fld_module { name = field } -> - compile_external_field ~dynamic_import lambda_cxt id field - | _ -> assert false) - | { primitive = Praise; args = [ e ]; _ } -> ( - match - compile_lambda { lambda_cxt with continuation = NeedValue Not_tail } e - with - | { block; value = Some v } -> - Js_output.make - (Ext_list.append_one block (S.throw_stmt v)) - ~value:E.undefined ~output_finished:True - (* FIXME -- breaks invariant when NeedValue, reason is that js [throw] is statement - while ocaml it's an expression, we should remove such things in lambda optimizations - *) - | { value = None } -> assert false) - | { primitive = Psequand; args = [ l; r ]; _ } -> - compile_sequand l r lambda_cxt - | { primitive = Psequor; args = [ l; r ] } -> compile_sequor l r lambda_cxt - | { primitive = Pdebugger; _ } -> - (* [%bs.debugger] guarantees that the expression does not matter - TODO: make it even safer *) - Js_output.output_of_block_and_expression lambda_cxt.continuation - S.debugger_block E.unit - (* TODO: - check the arity of fn before wrapping it - we need mark something that such eta-conversion can not be simplified in some cases - *) - | { - primitive = Pjs_unsafe_downgrade { name = property; setter }; - args = [ obj ]; - } -> ( - (* - either a getter {[ x #. height ]} or {[ x ## method_call ]} - *) - assert (not setter); - - match - compile_lambda { lambda_cxt with continuation = NeedValue Not_tail } obj - with - | { value = None } -> assert false - | { block; value = Some b } -> - let blocks, ret = - if block = [] then ([], E.dot b property) - else - match Js_ast_util.named_expression b with - | None -> (block, E.dot b property) - | Some (x, b) -> - (Ext_list.append_one block x, E.dot (E.var b) property) - in - Js_output.output_of_block_and_expression lambda_cxt.continuation - blocks ret) - | { - primitive = Pfull_apply; - args = - [ - Lprim - { - primitive = Pjs_unsafe_downgrade { name = property; setter = true }; - args = [ obj ]; - }; - setter_val; - ]; - } -> ( - let need_value_no_return_cxt = - { lambda_cxt with continuation = NeedValue Not_tail } - in - let obj_output = compile_lambda need_value_no_return_cxt obj in - let arg_output = compile_lambda need_value_no_return_cxt setter_val in - let cont obj_block arg_block obj_code = - Js_output.output_of_block_and_expression lambda_cxt.continuation - (match obj_code with - | None -> Ext_list.append obj_block arg_block - | Some obj_code -> Ext_list.append obj_block (obj_code :: arg_block)) - in - match (obj_output, arg_output) with - | { value = None }, _ | _, { value = None } -> assert false - | ( { block = obj_block; value = Some obj }, - { block = arg_block; value = Some value } ) -> ( - match Js_ast_util.named_expression obj with - | None -> - cont obj_block arg_block None - (E.seq (E.assign (E.dot obj property) value) E.unit) - | Some (obj_code, obj) -> - cont obj_block arg_block (Some obj_code) - (E.seq (E.assign (E.dot (E.var obj) property) value) E.unit))) - | { - primitive = Pfull_apply; - args = Lprim { primitive = Pjs_unsafe_downgrade { setter = true } } :: _; - } -> - assert false - | { primitive = Pfull_apply | Pvoid_run; args; loc } -> ( - (* 1. uncurried call should not do eta-conversion - since `fn.length` will broken - 2. invariant: `external` declaration will guarantee - the function application is saturated - 3. we need a location for Pccall in the call site - *) - match args with - | fn :: rest -> - compile_lambda lambda_cxt - (Lam.apply fn rest - { - ap_loc = loc; - ap_inlined = Default_inline; - ap_status = App_uncurry; - }) - (*FIXME: should pass info down: `f a [@bs][@inlined]`*) - | [] -> assert false) - | { primitive = Pjs_fn_method; args = args_lambda } -> ( - match args_lambda with - | [ Lfunction { params; body; attr = { return_unit } } ] -> - Js_output.output_of_block_and_expression lambda_cxt.continuation [] - (E.method_ params ~return_unit - (* Invariant: jmp_table can not across function boundary, - here we share env - *) - (Js_output.output_as_block - (compile_lambda - { - lambda_cxt with - continuation = - EffectCall - (Maybe_tail_is_return - (Tail_with_name - { label = None; in_staticcatch = false })); - jmp_table = Lam_compile_context.empty_handler_map; - } - body))) - | _ -> assert false) - | { primitive = Pjs_fn_make arity; args = [ fn ]; loc } -> - compile_lambda lambda_cxt - (Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:arity ?from:None fn) - | { primitive = Pjs_fn_make_unit; args = [ fn ]; loc } -> - compile_lambda lambda_cxt fn - | { primitive = Pjs_fn_make _; args = [] | _ :: _ :: _ } -> assert false - | { primitive = Pjs_object_create labels; args } -> - let args_block, args_expr = - if args = [] then ([], []) - else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - Ext_list.split_map args (fun x -> - match compile_lambda new_cxt x with - | { block; value = Some b } -> (block, b) - | { value = None } -> assert false) - in - let block, exp = - Lam_compile_external_obj.assemble_obj_args labels args_expr - in - Js_output.output_of_block_and_expression lambda_cxt.continuation - (Ext_list.concat_append args_block block) - exp - | { primitive; args; loc } -> - let args_block, args_expr = - if args = [] then ([], []) - else - let new_cxt = { lambda_cxt with continuation = NeedValue Not_tail } in - Ext_list.split_map args (fun x -> - match compile_lambda new_cxt x with - | { block; value = Some b } -> (block, b) - | { value = None } -> assert false) - in - let args_code : J.block = List.concat args_block in - let exp = - (* TODO: all can be done in [compile_primitive] *) - Lam_compile_primitive.translate output_prefix loc lambda_cxt primitive args_expr - in - Js_output.output_of_block_and_expression lambda_cxt.continuation args_code - exp - -and compile_lambda (lambda_cxt : Lam_compile_context.t) (cur_lam : Lam.t) : - Js_output.t = - match cur_lam with - | Lfunction { params; body; attr = { return_unit; async; oneUnitArg } } -> - Js_output.output_of_expression lambda_cxt.continuation - ~no_effects:no_effects_const - (E.ocaml_fun params ~return_unit ~async ~oneUnitArg - (* Invariant: jmp_table can not across function boundary, - here we share env - *) - (Js_output.output_as_block - (compile_lambda - { - lambda_cxt with - continuation = - EffectCall - (Maybe_tail_is_return - (Tail_with_name - { label = None; in_staticcatch = false })); - jmp_table = Lam_compile_context.empty_handler_map; - } - body))) - | Lapply appinfo -> compile_apply appinfo lambda_cxt - | Llet (let_kind, id, arg, body) -> - (* Order matters.. see comment below in [Lletrec] *) - let args_code = - compile_lambda - { lambda_cxt with continuation = Declare (let_kind, id) } - arg - in - Js_output.append_output args_code (compile_lambda lambda_cxt body) - | Lletrec (id_args, body) -> - (* There is a bug in our current design, - it requires compile args first (register that some objects are jsidentifiers) - and compile body wiht such effect. - So here we should compile [id_args] first, then [body] later. - Note it has some side effect over cache number as well, mostly the value of - [Caml_primitive["caml_get_public_method"](x,hash_tab, number)] - - To fix this, - 1. scan the lambda layer first, register js identifier before proceeding - 2. delay the method call into javascript ast - *) - let v = compile_recursive_lets lambda_cxt id_args in - Js_output.append_output v (compile_lambda lambda_cxt body) - | Lvar id -> - Js_output.output_of_expression lambda_cxt.continuation - ~no_effects:no_effects_const (E.var id) - | Lconst c -> - Js_output.output_of_expression lambda_cxt.continuation - ~no_effects:no_effects_const - (Lam_compile_const.translate c) - | Lglobal_module (i, dynamic_import) -> - (* introduced by - 1. {[ include Array --> let include = Array ]} - 2. inline functor application - *) - Js_output.output_of_block_and_expression lambda_cxt.continuation [] - (E.ml_module_as_var ~dynamic_import i) - | Lprim prim_info -> compile_prim prim_info lambda_cxt - | Lsequence (l1, l2) -> - let output_l1 = - compile_lambda { lambda_cxt with continuation = EffectCall Not_tail } l1 - in - let output_l2 = compile_lambda lambda_cxt l2 in - Js_output.append_output output_l1 output_l2 - | Lifthenelse (predicate, t_branch, f_branch) -> - compile_ifthenelse predicate t_branch f_branch lambda_cxt - | Lstringswitch (l, cases, default) -> - compile_stringswitch l cases default lambda_cxt - | Lswitch (switch_arg, sw) -> compile_switch switch_arg sw lambda_cxt - | Lstaticraise (i, largs) -> compile_staticraise i largs lambda_cxt - | Lstaticcatch _ -> compile_staticcatch cur_lam lambda_cxt - | Lwhile (p, body) -> compile_while p body lambda_cxt - | Lfor (id, start, finish, direction, body) -> ( - match (direction, finish) with - | ( Upto, - ( Lprim - { - primitive = Psubint; - args = [ new_finish; Lconst (Const_int { i = 1l }) ]; - } - | Lprim { primitive = Poffsetint -1; args = [ new_finish ] } ) ) -> - compile_for id start new_finish Up body lambda_cxt - | _ -> - compile_for id start finish - (if direction = Upto then Upto else Downto) - body lambda_cxt) - | Lassign (id, lambda) -> compile_assign id lambda lambda_cxt - | Ltrywith (lam, id, catch) -> - (* generate documentation *) - compile_trywith lam id catch lambda_cxt - -in compile_recursive_lets, compile_lambda - -let compile_recursive_lets ~output_prefix = fst (compile output_prefix) -let compile_lambda ~output_prefix = snd (compile output_prefix) diff --git a/jscomp/core/lam_compile.mli b/jscomp/core/lam_compile.mli deleted file mode 100644 index f3d00c6..0000000 --- a/jscomp/core/lam_compile.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Compile single lambda IR to JS IR *) - -val compile_recursive_lets : - output_prefix:string -> Lam_compile_context.t -> (Ident.t * Lam.t) list -> Js_output.t - -val compile_lambda : output_prefix:string -> Lam_compile_context.t -> Lam.t -> Js_output.t diff --git a/jscomp/core/lam_compile_const.ml b/jscomp/core/lam_compile_const.ml deleted file mode 100644 index 7c56808..0000000 --- a/jscomp/core/lam_compile_const.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -(** return [val < 0] if not nested [Some (Some (Some None))]*) -let rec is_some_none_aux (x : Lam_constant.t) acc = - match x with - | Const_some v -> is_some_none_aux v (acc + 1) - | Const_module_alias | Const_js_undefined _ -> acc - | _ -> -1 - -let rec nested_some_none n none = - if n = 0 then none else nested_some_none (n - 1) (E.optional_block none) - -let rec translate_some (x : Lam_constant.t) : J.expression = - let depth = is_some_none_aux x 0 in - if depth < 0 then E.optional_not_nest_block (translate x) - else nested_some_none depth (E.optional_block (translate (Const_js_undefined {isUnit = false}))) - -and translate (x : Lam_constant.t) : J.expression = - match x with - | Const_module_alias -> E.undefined (* TODO *) - | Const_some s -> translate_some s - | Const_js_true -> E.bool true - | Const_js_false -> E.bool false - | Const_js_null -> E.nil - | Const_js_undefined {isUnit = true} -> E.unit - | Const_js_undefined {isUnit = false} -> E.undefined - | Const_int { i; comment = Pt_constructor {cstr_name={name; tag_type=None}}} when name <> "[]" -> - E.str name - | Const_int { i; comment = Pt_constructor {cstr_name={tag_type = Some t}}} -> - E.tag_type t - | Const_int { i; comment } -> - E.int i ?comment:(Lam_constant.string_of_pointer_info comment) - | Const_char i -> Js_of_lam_string.const_char i - (* E.float (Int32.to_string i) *) - | Const_int64 i -> - (* - TODO: - {[ - Int64.to_string 0x7FFFFFFFFFFFFFFFL;; - - : string = "9223372036854775807" - ]} - {[ - Int64.(to_float max_int);; - - : float = 9.22337203685477581e+18 - ]} - Note we should compile it to Int64 as JS's - speical representation -- - it is not representatble in JS number - *) - (* E.float (Int64.to_string i) *) - Js_long.of_const i - (* https://github.com/google/closure-library/blob/master/closure%2Fgoog%2Fmath%2Flong.js *) - | Const_bigint (sign, i) -> E.bigint sign i - | Const_float f -> E.float f (* TODO: preserve float *) - | Const_string { s; unicode = false } -> E.str s - | Const_string { s; unicode = true } -> E.str ~delim:DStarJ s - | Const_pointer name -> E.str name - | Const_block (tag, tag_info, xs) -> - Js_of_lam_block.make_block NA tag_info (E.small_int tag) - (Ext_list.map xs translate) - | Const_float_array ars -> - (* according to the compiler - const_float_array is immutable - {[ Lprim(Pccall prim_obj_dup, [master]) ]}, - however, we can not translate - {[ prim_obj_dup(x) => x' ]} - since x' is now mutable, prim_obj_dup does a copy, - - the compiler does this is mainly to extract common data into data section, - we deoptimized this in js backend? so it is actually mutable - *) - (* TODO-- *) - Js_of_lam_array.make_array Mutable (Ext_list.map ars E.float) - -(* E.arr Mutable ~comment:"float array" *) -(* (Ext_list.map (fun x -> E.float x ) ars) *) - -(* and translate_optional s = - let b = - match s with - | Const_js_undefined -> E.optional_block (translate s) *) - -let translate_arg_cst (cst : External_arg_spec.cst) = - match cst with - | Arg_int_lit i -> E.int (Int32.of_int i) - | Arg_string_lit (s, delim) -> E.str s ~delim diff --git a/jscomp/core/lam_compile_const.mli b/jscomp/core/lam_compile_const.mli deleted file mode 100644 index 2a97874..0000000 --- a/jscomp/core/lam_compile_const.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Compile lambda constant to JS *) - -val translate : Lam_constant.t -> J.expression - -val translate_arg_cst : External_arg_spec.cst -> J.expression diff --git a/jscomp/core/lam_compile_context.ml b/jscomp/core/lam_compile_context.ml deleted file mode 100644 index 0ed48d6..0000000 --- a/jscomp/core/lam_compile_context.ml +++ /dev/null @@ -1,112 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type jbl_label = int - -module HandlerMap = Map_int - -type value = { exit_id : Ident.t; bindings : Ident.t list; order_id : int } - -(* delegate to the callee to generate expression - Invariant: [output] should return a trailing expression -*) -type return_label = { - id : Ident.t; - label : J.label; - params : Ident.t list; - immutable_mask : bool array; - mutable new_params : Ident.t Map_ident.t; - mutable triggered : bool; -} - -type tail = { label : return_label option; in_staticcatch : bool } - -type maybe_tail = Tail_in_try | Tail_with_name of tail - -type tail_type = Not_tail | Maybe_tail_is_return of maybe_tail - -(* Note [return] does indicate it is a tail position in most cases - however, in an exception handler, return may not be in tail position - to fix #1701 we play a trick that (Maybe_tail_is_return None) - would never trigger tailcall, however, it preserves [return] - semantics -*) -(* have a mutable field to notifiy it's actually triggered *) -(* anonoymous function does not have identifier *) - -type let_kind = Lam_compat.let_kind - -type continuation = - | EffectCall of tail_type - | NeedValue of tail_type - | Declare of let_kind * J.ident (* bound value *) - | Assign of J.ident -(* when use [Assign], var is not needed, since it's already declared *) - -type jmp_table = value HandlerMap.t - -let continuation_is_return (x : continuation) = - match x with - | EffectCall (Maybe_tail_is_return _) | NeedValue (Maybe_tail_is_return _) -> - true - | EffectCall Not_tail | NeedValue Not_tail | Declare _ | Assign _ -> false - -type t = { - continuation : continuation; - jmp_table : jmp_table; - meta : Lam_stats.t; -} - -let empty_handler_map = HandlerMap.empty - -type handler = { label : jbl_label; handler : Lam.t; bindings : Ident.t list } - -let no_static_raise_in_handler (x : handler) : bool = - not (Lam_exit_code.has_exit_code x.handler (fun _code -> true)) - -(* always keep key id positive, specifically no [0] generated - return a tuple - [tbl, handlers] - [tbl] is used for compiling [staticraise] - [handlers] is used for compiling [staticcatch] -*) -let add_jmps (m : jmp_table) (exit_id : Ident.t) (code_table : handler list) : - jmp_table * (int * Lam.t) list = - let map, handlers = - Ext_list.fold_left_with_offset code_table (m, []) - (HandlerMap.cardinal m + 1) - (fun { label; handler; bindings } (acc, handlers) order_id -> - ( HandlerMap.add acc label { exit_id; bindings; order_id }, - (order_id, handler) :: handlers )) - in - (map, List.rev handlers) - -let add_pseudo_jmp (m : jmp_table) - (exit_id : Ident.t) (* TODO not needed, remove it later *) - (code_table : handler) : jmp_table * Lam.t = - ( HandlerMap.add m code_table.label - { exit_id; bindings = code_table.bindings; order_id = -1 }, - code_table.handler ) - -let find_exn cxt i = Map_int.find_exn cxt.jmp_table i diff --git a/jscomp/core/lam_compile_context.mli b/jscomp/core/lam_compile_context.mli deleted file mode 100644 index da6ca41..0000000 --- a/jscomp/core/lam_compile_context.mli +++ /dev/null @@ -1,88 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Type definition to keep track of compilation state -*) - -(** Some types are defined in this module to help avoiding generating unnecessary symbols - (generating too many symbols will make the output code unreadable) -*) - -type jbl_label = int - -type return_label = { - id : Ident.t; - label : J.label; - params : Ident.t list; - immutable_mask : bool array; - mutable new_params : Ident.t Map_ident.t; - mutable triggered : bool; -} - -type value = { exit_id : Ident.t; bindings : Ident.t list; order_id : int } - -type let_kind = Lam_compat.let_kind - -type tail = { label : return_label option; in_staticcatch : bool } - -type maybe_tail = Tail_in_try | Tail_with_name of tail - -type tail_type = Not_tail | Maybe_tail_is_return of maybe_tail -(* anonoymous function does not have identifier *) - -(* delegate to the callee to generate expression - Invariant: [output] should return a trailing expression -*) - -type continuation = - | EffectCall of tail_type - | NeedValue of tail_type - | Declare of let_kind * J.ident (* bound value *) - | Assign of J.ident - (** when use [Assign], var is not needed, since it's already declared - make sure all [Assign] are declared first, otherwise you are creating global variables - *) - -type jmp_table = value Map_int.t - -val continuation_is_return : continuation -> bool - -type t = { - continuation : continuation; - jmp_table : jmp_table; - meta : Lam_stats.t; -} - -val empty_handler_map : jmp_table - -type handler = { label : jbl_label; handler : Lam.t; bindings : Ident.t list } - -val no_static_raise_in_handler : handler -> bool - -val add_jmps : - jmp_table -> Ident.t -> handler list -> jmp_table * (jbl_label * Lam.t) list - -val add_pseudo_jmp : jmp_table -> Ident.t -> handler -> jmp_table * Lam.t - -val find_exn : t -> jbl_label -> value diff --git a/jscomp/core/lam_compile_env.ml b/jscomp/core/lam_compile_env.ml deleted file mode 100644 index ff1dadb..0000000 --- a/jscomp/core/lam_compile_env.ml +++ /dev/null @@ -1,141 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type env_value = - | Ml of Js_cmj_format.cmj_load_info - | External - (** Also a js file, but this belong to third party - we never load runtime/*.cmj - *) - -type ident_info = Js_cmj_format.keyed_cmj_value = { - name : string; - arity : Js_cmj_format.arity; - persistent_closed_lambda : Lam.t option; -} - -(* - refer: [Env.find_pers_struct] - [ find_in_path_uncap !load_path (name ^ ".cmi")] -*) - -(** It stores module => env_value mapping -*) -let cached_tbl : env_value Lam_module_ident.Hash.t = - Lam_module_ident.Hash.create 31 - -let ( +> ) = Lam_module_ident.Hash.add cached_tbl - -(* For each compilation we need reset to make it re-entrant *) -let reset () = - Js_config.no_export := false; - (* This is needed in the playground since one no_export can make it true - In the payground, it seems we need reset more states - *) - Lam_module_ident.Hash.clear cached_tbl - -(** We should not provide "#moduleid" as output - since when we print it in the end, it will - be escaped quite ugly -*) -let add_js_module ?import_attributes (hint_name : External_ffi_types.module_bind_name) - (module_name : string) default ~dynamic_import : Ident.t = - let id = - Ident.create - (match hint_name with - | Phint_name hint_name -> Ext_string.capitalize_ascii hint_name - (* make sure the module name is capitalized - TODO: maybe a warning if the user hint is not good - *) - | Phint_nothing -> Ext_modulename.js_id_name_of_hint_name module_name) - in - let lam_module_ident : J.module_id = - { id; kind = External { name = module_name; default; import_attributes }; dynamic_import } - in - match Lam_module_ident.Hash.find_key_opt cached_tbl lam_module_ident with - | None -> - lam_module_ident +> External; - id - | Some old_key -> old_key.id - -let query_external_id_info ?(dynamic_import = false) (module_id : Ident.t) (name : string) : ident_info = - let oid = Lam_module_ident.of_ml ~dynamic_import module_id in - let cmj_table = - match Lam_module_ident.Hash.find_opt cached_tbl oid with - | None -> - let cmj_load_info = !Js_cmj_load.load_unit module_id.name in - oid +> Ml cmj_load_info; - cmj_load_info.cmj_table - | Some (Ml { cmj_table }) -> cmj_table - | Some External -> assert false - in - Js_cmj_format.query_by_name cmj_table name - -let get_package_path_from_cmj (id : Lam_module_ident.t) : - string * Js_packages_info.t * Ext_js_file_kind.case = - let cmj_load_info = - match Lam_module_ident.Hash.find_opt cached_tbl id with - | Some (Ml cmj_load_info) -> cmj_load_info - | Some External -> assert false - (* called by {!Js_name_of_module_id.string_of_module_id} - can not be External - *) - | None -> ( - match id.kind with - | Runtime | External _ -> assert false - | Ml -> - let cmj_load_info = - !Js_cmj_load.load_unit (Lam_module_ident.name id) - in - id +> Ml cmj_load_info; - cmj_load_info) - in - let cmj_table = cmj_load_info.cmj_table in - (cmj_load_info.package_path, cmj_table.package_spec, cmj_table.case) - -let add = Lam_module_ident.Hash_set.add - -(* Conservative interface *) -let is_pure_module (oid : Lam_module_ident.t) = - match oid.kind with - | Runtime -> true - | External _ -> false - | Ml -> ( - match Lam_module_ident.Hash.find_opt cached_tbl oid with - | None -> ( - match !Js_cmj_load.load_unit (Lam_module_ident.name oid) with - | cmj_load_info -> - oid +> Ml cmj_load_info; - cmj_load_info.cmj_table.pure - | exception _ -> false) - | Some (Ml { cmj_table }) -> cmj_table.pure - | Some External -> false) - -let populate_required_modules extras - (hard_dependencies : Lam_module_ident.Hash_set.t) = - Lam_module_ident.Hash.iter cached_tbl (fun id _ -> - if not (is_pure_module id) then add hard_dependencies id); - Lam_module_ident.Hash_set.iter extras (fun id : unit -> - if not (is_pure_module id) then add hard_dependencies id) -(* Lam_module_ident.Hash_set.elements hard_dependencies *) diff --git a/jscomp/core/lam_compile_env.mli b/jscomp/core/lam_compile_env.mli deleted file mode 100644 index c9cfd37..0000000 --- a/jscomp/core/lam_compile_env.mli +++ /dev/null @@ -1,79 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Helper for global Ocaml module index into meaningful names *) - -val reset : unit -> unit - -val add_js_module : - ?import_attributes:External_ffi_types.import_attributes -> External_ffi_types.module_bind_name -> string -> bool -> dynamic_import:bool -> Ident.t -(** - [add_js_module hint_name module_name] - Given a js module name and hint name, assign an id to it - we also bookkeep it as [External] dependency. - - Note the complexity lies in that we should consolidate all - same external dependencies into a single dependency. - - The strategy is that we first create a [Lam_module_ident.t] - and query it if already exists in [cache_tbl], if it already - exists, we discard the freshly made one, and use the cached one, - otherwise, use the freshly made one instead - - Invariant: - any [id] as long as put in the [cached_tbl] should be always valid, -*) - -(* The other dependencies are captured by querying - either when [access] or when expansion, - however such dependency can be removed after inlining etc. - - When we register such compile time dependency we classified - it as - Visit (ml), Builtin(built in js), External() - - For external, we never remove, we only consider - remove dependency for Runtime and Visit, so - when compile OCaml to Javascript, we only need - pay attention to for those modules are actually used or not -*) - -val query_external_id_info : ?dynamic_import:bool -> Ident.t -> string -> Js_cmj_format.keyed_cmj_value -(** - [query_external_id_info id pos env found] - will raise if not found -*) - -val is_pure_module : Lam_module_ident.t -> bool - -val get_package_path_from_cmj : - Lam_module_ident.t -> string * Js_packages_info.t * Ext_js_file_kind.case - -(* The second argument is mostly from [runtime] modules - will change the input [hard_dependencies] - [populate_required_modules extra hard_dependencies] - [extra] maybe removed if it is pure and not in [hard_dependencies] -*) -val populate_required_modules : - Lam_module_ident.Hash_set.t -> Lam_module_ident.Hash_set.t -> unit diff --git a/jscomp/core/lam_compile_external_call.ml b/jscomp/core/lam_compile_external_call.ml deleted file mode 100644 index 77a982c..0000000 --- a/jscomp/core/lam_compile_external_call.ml +++ /dev/null @@ -1,414 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -module E = Js_exp_make - -let splice_apply fn args = - E.runtime_call Js_runtime_modules.caml_splice_call "spliceApply" - [ fn; E.array Immutable args ] - -let splice_new_apply fn args = - E.runtime_call Js_runtime_modules.caml_splice_call "spliceNewApply" - [ fn; E.array Immutable args ] - -let splice_obj_apply obj name args = - E.runtime_call Js_runtime_modules.caml_splice_call "spliceObjApply" - [ obj; E.str name; E.array Immutable args ] - -(** - [bind_name] is a hint to the compiler to generate - better names for external module -*) -(* let handle_external - ({bundle ; module_bind_name} : External_ffi_types.external_module_name) - : Ident.t * string - = - Lam_compile_env.add_js_module module_bind_name bundle , - bundle *) - -let external_var - ({ bundle; module_bind_name; import_attributes } : External_ffi_types.external_module_name) ~dynamic_import = - let id = Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle false ~dynamic_import in - E.external_var ?import_attributes ~external_name:bundle id - -(* let handle_external_opt - (module_name : External_ffi_types.external_module_name option) - : (Ident.t * string) option = - match module_name with - | Some module_name -> Some (handle_external module_name) - | None -> None -*) - -type arg_expression = Js_of_lam_variant.arg_expression = - | Splice0 - | Splice1 of E.t - | Splice2 of E.t * E.t - -let append_list x xs = - match x with - | Splice0 -> xs - | Splice1 a -> a :: xs - | Splice2 (a, b) -> a :: b :: xs - -(* The first return value is value, the second argument is side effect expressions - Only the [unit] with no label will be ignored - When we are passing a boxed value to external(optional), we need - unbox it in the first place. - - Note when optional value is not passed, the unboxed value would be - [undefined], with the combination of `[@int]` it would be still be - [undefined], this by default is still correct.. - {[ - (function () { - switch (undefined) { - case 97 : - return "a"; - case 98 : - return "b"; - - } - }()) === undefined - ]} - - This would not work with [NonNullString] -*) -let ocaml_to_js_eff ~(arg_label : External_arg_spec.label_noname) - ~(arg_type : External_arg_spec.attr) (raw_arg : E.t) : - arg_expression * E.t list = - let arg = - match arg_label with - | Arg_optional -> - Js_of_lam_option.get_default_undefined_from_optional raw_arg - | Arg_label | Arg_empty -> raw_arg - in - match arg_type with - | Arg_cst _ -> assert false - | Fn_uncurry_arity _ -> assert false - (* has to be preprocessed by {!Lam} module first *) - | Extern_unit -> - ( (if arg_label = Arg_empty then Splice0 else Splice1 E.unit), - if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] ) - (* leave up later to decide *) - | Ignore -> - ( Splice0, - if Js_analyzer.no_side_effect_expression arg then [] else [ arg ] ) - | Poly_var_string { descr } -> (Splice1 (Js_of_lam_variant.eval arg descr), []) - | Poly_var { descr } -> (Js_of_lam_variant.eval_as_event arg descr, []) - (* FIXME: encode invariant below in the signature*) - (* length of 2 - - the poly var tag - - the value - *) - | Int dispatches -> - (Splice1 (Js_of_lam_variant.eval_as_int arg dispatches), []) - | Unwrap -> - let single_arg = - match arg_label with - | Arg_optional -> - (* - If this is an optional arg (like `?arg`), we have to potentially do - 2 levels of unwrapping: - - if ocaml arg is `None`, let js arg be `undefined` (no unwrapping) - - if ocaml arg is `Some x`, unwrap the arg to get the `x`, then - unwrap the `x` itself - - Here `Some x` is `x` due to the current encoding - Lets inline here since it depends on the runtime encoding - *) - Js_of_lam_option.option_unwrap raw_arg - | _ -> Js_of_lam_variant.eval_as_unwrap raw_arg - in - (Splice1 single_arg, []) - | Nothing -> (Splice1 arg, []) - -let empty_pair = ([], []) - -let add_eff eff e = match eff with None -> e | Some v -> E.seq v e - -type specs = External_arg_spec.params - -type exprs = E.t list - -let keep_non_undefined_args (arg_types : specs) (args : exprs) = - let rec has_undefined_trailing_args arg_types args = - match (arg_types, args) with - | ( [{External_arg_spec.arg_label = Arg_optional; _}], - [{J.expression_desc = Undefined {isUnit = false}; _}] ) -> - true - | ( _ :: arg_types_rest, _ :: args_rest ) -> - has_undefined_trailing_args arg_types_rest args_rest - | _ -> false - in - let rec aux arg_types args = - match (arg_types, args) with - | ( {External_arg_spec.arg_label = Arg_optional; _} :: arg_types_rest, - {J.expression_desc = Undefined {isUnit = false}; _} :: args_rest ) -> - aux arg_types_rest args_rest - | _ -> args - in - if (has_undefined_trailing_args arg_types args) then - aux (List.rev arg_types) (List.rev args) |> List.rev - else args - -(* TODO: fix splice, - we need a static guarantee that it is static array construct - otherwise, we should provide a good error message here, - no compiler failure here - Invariant : Array encoding - @return arguments and effect -*) -let assemble_args_no_splice (arg_types : specs) (args : exprs) : - exprs * E.t option = - let rec aux (labels : specs) (args : exprs) : exprs * exprs = - match (labels, args) with - | [], _ -> - assert (args = []); - empty_pair - | { arg_type = Arg_cst cst; _ } :: labels, args -> - (* can not be Optional *) - let accs, eff = aux labels args in - (Lam_compile_const.translate_arg_cst cst :: accs, eff) - | { arg_label; arg_type } :: labels, arg :: args -> - let accs, eff = aux labels args in - let acc, new_eff = ocaml_to_js_eff ~arg_label ~arg_type arg in - (append_list acc accs, Ext_list.append new_eff eff) - | _ :: _, [] -> assert false - in - let args, eff = aux arg_types args in - ( keep_non_undefined_args arg_types args, - match eff with - | [] -> None - | x :: xs -> - (* FIXME: the order of effects? *) - Some (E.fuse_to_seq x xs) ) - -let assemble_args_has_splice (arg_types : specs) (args : exprs) : - exprs * E.t option * bool = - let dynamic = ref false in - let rec aux (labels : specs) (args : exprs) = - match (labels, args) with - | [], _ -> - assert (args = []); - empty_pair - | { arg_type = Arg_cst cst; _ } :: labels, args -> - let accs, eff = aux labels args in - (Lam_compile_const.translate_arg_cst cst :: accs, eff) - | { arg_label; arg_type } :: labels, arg :: args -> ( - let accs, eff = aux labels args in - match (args, (arg : E.t)) with - | [], { expression_desc = Array (ls, _mutable_flag); _ } -> - (Ext_list.append ls accs, eff) - | _ -> - if args = [] then dynamic := true; - let acc, new_eff = ocaml_to_js_eff ~arg_type ~arg_label arg in - (append_list acc accs, Ext_list.append new_eff eff)) - | _ :: _, [] -> assert false - in - let args, eff = aux arg_types args in - ( args, - (match eff with - | [] -> None - | x :: xs -> - (* FIXME: the order of effects? *) - Some (E.fuse_to_seq x xs)), - !dynamic ) - -let translate_scoped_module_val - (module_name : External_ffi_types.external_module_name option) (fn : string) - (scopes : string list) - ~dynamic_import = - match module_name with - | Some { bundle; module_bind_name; import_attributes } -> ( - match scopes with - | [] -> - let default = fn = "default" in - let id = - Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle default ~dynamic_import - in - E.external_var_field ?import_attributes ~external_name:bundle ~field:fn ~default id - | x :: rest -> - (* TODO: what happens when scope contains "default" ?*) - let default = false in - let id = - Lam_compile_env.add_js_module ?import_attributes module_bind_name bundle default ~dynamic_import - in - let start = - E.external_var_field ?import_attributes ~external_name:bundle ~field:x ~default id - in - Ext_list.fold_left (Ext_list.append rest [ fn ]) start E.dot) - | None -> ( - (* no [@@module], assume it's global *) - match scopes with - | [] -> E.js_global fn - | x :: rest -> - let start = E.js_global x in - Ext_list.fold_left (Ext_list.append_one rest fn) start E.dot) - -let translate_scoped_access scopes obj = - match scopes with - | [] -> obj - | x :: xs -> Ext_list.fold_left xs (E.dot obj x) E.dot - -let translate_ffi (cxt : Lam_compile_context.t) arg_types - (ffi : External_ffi_types.external_spec) (args : J.expression list) ~dynamic_import = - match ffi with - | Js_call { external_module_name; name; splice: _; scopes; tagged_template = true } -> - let fn = translate_scoped_module_val external_module_name name scopes ~dynamic_import in - (match args with - | [ {expression_desc = Array (strings, _); _}; {expression_desc = Array (values, _); _} ] -> - E.tagged_template fn strings values - | _ -> let args, eff, dynamic = assemble_args_has_splice arg_types args in - add_eff eff - (if dynamic then splice_apply fn args - else E.call ~info:{ arity = Full; call_info = Call_na } fn args)) - | Js_call { external_module_name = module_name; name = fn; splice; scopes; tagged_template = false } -> - let fn = translate_scoped_module_val module_name fn scopes ~dynamic_import in - if splice then - let args, eff, dynamic = assemble_args_has_splice arg_types args in - add_eff eff - (if dynamic then splice_apply fn args - else E.call ~info:{ arity = Full; call_info = Call_na } fn args) - else - let args, eff = assemble_args_no_splice arg_types args in - add_eff eff - @@ E.call ~info:{ arity = Full; call_info = Call_na } fn args - | Js_module_as_fn { external_module_name; splice } -> - let fn = external_var external_module_name ~dynamic_import in - if splice then - let args, eff, dynamic = assemble_args_has_splice arg_types args in - (* TODO: fix in rest calling convention *) - add_eff eff - (if dynamic then splice_apply fn args - else E.call ~info:{ arity = Full; call_info = Call_na } fn args) - else - let args, eff = assemble_args_no_splice arg_types args in - (* TODO: fix in rest calling convention *) - add_eff eff (E.call ~info:{ arity = Full; call_info = Call_na } fn args) - | Js_new { external_module_name = module_name; name = fn; splice; scopes } -> - (* handle [@@new]*) - (* This has some side effect, it will - mark its identifier (If it has) as an object, - ATTENTION: - order also matters here, since we mark its jsobject property, - it will affect the code gen later - TODO: we should propagate this property - as much as we can(in alias table) - *) - let mark () = - match cxt.continuation with - | Declare (_, id) | Assign id -> - (* Format.fprintf Format.err_formatter "%a@."Ident.print id; *) - Ext_ident.make_js_object id - | EffectCall _ | NeedValue _ -> () - in - if splice then - let args, eff, dynamic = assemble_args_has_splice arg_types args in - let fn = translate_scoped_module_val module_name fn scopes ~dynamic_import in - add_eff eff - (mark (); - if dynamic then splice_new_apply fn args - else E.new_ fn args) - else - let args, eff = assemble_args_no_splice arg_types args in - let fn = translate_scoped_module_val module_name fn scopes ~dynamic_import in - add_eff eff - (mark (); E.new_ fn args) - | Js_send { splice; name; js_send_scopes } -> ( - match args with - | self :: args -> - (* PR2162 [self_type] more checks in syntax: - - should not be [@as] *) - let[@warning "-8"] (_self_type :: arg_types) = arg_types in - if splice then - let args, eff, dynamic = assemble_args_has_splice arg_types args in - add_eff eff - (let self = translate_scoped_access js_send_scopes self in - if dynamic then splice_obj_apply self name args - else - E.call - ~info:{ arity = Full; call_info = Call_na } - (E.dot self name) args) - else - let args, eff = assemble_args_no_splice arg_types args in - add_eff eff - (let self = translate_scoped_access js_send_scopes self in - E.call - ~info:{ arity = Full; call_info = Call_na } - (E.dot self name) args) - | _ -> assert false) - | Js_module_as_var module_name -> external_var module_name ~dynamic_import - | Js_var { name; external_module_name; scopes } -> - (* TODO #11 - 1. check args -- error checking - 2. support [@@scope "window"] - we need know whether we should call [add_js_module] or not - *) - translate_scoped_module_val external_module_name name scopes ~dynamic_import - | Js_module_as_class module_name -> - let fn = external_var module_name ~dynamic_import in - let args, eff = assemble_args_no_splice arg_types args in - (* TODO: fix in rest calling convention *) - add_eff eff - ((match cxt.continuation with - | Declare (_, id) | Assign id -> - (* Format.fprintf Format.err_formatter "%a@."Ident.print id; *) - Ext_ident.make_js_object id - | EffectCall _ | NeedValue _ -> ()); - E.new_ fn args) - | Js_get { js_get_name = name; js_get_scopes = scopes } -> ( - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match args with - | [ obj ] -> - let obj = translate_scoped_access scopes obj in - E.dot obj name - | _ -> assert false - (* Note these assertion happens in call site *)) - | Js_set { js_set_name = name; js_set_scopes = scopes } -> ( - (* assert (js_splice = false) ; *) - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match (args, arg_types) with - | [ obj; v ], _ -> - let obj = translate_scoped_access scopes obj in - E.assign (E.dot obj name) v - | _ -> assert false) - | Js_get_index { js_get_index_scopes = scopes } -> ( - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match args with - | [ obj; v ] -> Js_arr.ref_array (translate_scoped_access scopes obj) v - | _ -> assert false) - | Js_set_index { js_set_index_scopes = scopes } -> ( - let args, cur_eff = assemble_args_no_splice arg_types args in - add_eff cur_eff - @@ - match args with - | [ obj; v; value ] -> - Js_arr.set_array (translate_scoped_access scopes obj) v value - | _ -> assert false) diff --git a/jscomp/core/lam_compile_external_call.mli b/jscomp/core/lam_compile_external_call.mli deleted file mode 100644 index e8c974f..0000000 --- a/jscomp/core/lam_compile_external_call.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val ocaml_to_js_eff : - arg_label:External_arg_spec.label_noname -> - arg_type:External_arg_spec.attr -> - J.expression -> - Js_of_lam_variant.arg_expression * J.expression list -(** Compile ocaml external function call to JS IR. *) - -val translate_ffi : - Lam_compile_context.t -> - External_arg_spec.params -> - External_ffi_types.external_spec -> - J.expression list -> - dynamic_import:bool -> - J.expression - -(** TODO: document supported attributes - Attributes starting with `js` are reserved - examples: "variadic" -*) diff --git a/jscomp/core/lam_compile_external_obj.ml b/jscomp/core/lam_compile_external_obj.ml deleted file mode 100644 index 8638e08..0000000 --- a/jscomp/core/lam_compile_external_obj.ml +++ /dev/null @@ -1,168 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make -module S = Js_stmt_make - -(* Note: can potentially be inconsistent, sometimes - {[ - { x : 3 , y : undefined} - ]} - and - {[ - {x : 3 } - ]} - But the default to be undefined seems reasonable -*) - -(* TODO: check stackoverflow *) -let assemble_obj_args (labels : External_arg_spec.obj_params) - (args : J.expression list) : J.block * J.expression = - let rec aux (labels : External_arg_spec.obj_params) args : - (Js_op.property_name * E.t) list * J.expression list * _ = - match (labels, args) with - | [], [] -> ([], [], []) - | ( { - obj_arg_label = Obj_label { name = label }; - obj_arg_type = Arg_cst cst; - } - :: labels, - args ) -> - let accs, eff, assign = aux labels args in - ( (Js_op.Lit label, Lam_compile_const.translate_arg_cst cst) :: accs, - eff, - assign ) - (* | {obj_arg_label = EmptyCst _ } :: rest , args -> assert false *) - | { obj_arg_label = Obj_empty } :: labels, arg :: args -> - (* unit type*) - let ((accs, eff, assign) as r) = aux labels args in - if Js_analyzer.no_side_effect_expression arg then r - else (accs, arg :: eff, assign) - | ( ({ obj_arg_label = Obj_label { name = label } } as arg_kind) :: labels, - arg :: args ) -> ( - let accs, eff, assign = aux labels args in - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label - ~arg_type:arg_kind.obj_arg_type arg - in - match acc with - | Splice2 _ | Splice0 -> assert false - | Splice1 x -> - ((Js_op.Lit label, x) :: accs, Ext_list.append new_eff eff, assign) - (* evaluation order is undefined *)) - | ( ({ obj_arg_label = Obj_optional { name = label }; obj_arg_type } as - arg_kind) - :: labels, - arg :: args ) -> - let ((accs, eff, assign) as r) = aux labels args in - Js_of_lam_option.destruct_optional arg ~for_sure_none:r - ~for_sure_some:(fun x -> - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff ~arg_label:Arg_label - ~arg_type:obj_arg_type x - in - match acc with - | Splice2 _ | Splice0 -> assert false - | Splice1 x -> - ( (Js_op.Lit label, x) :: accs, - Ext_list.append new_eff eff, - assign )) - ~not_sure:(fun _ -> (accs, eff, (arg_kind, arg) :: assign)) - | { obj_arg_label = Obj_empty | Obj_label _ | Obj_optional _ } :: _, [] -> - assert false - | [], _ :: _ -> assert false - in - let map, eff, assignment = aux labels args in - match assignment with - | [] -> ( - ( [], - match eff with - | [] -> E.obj map - | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map) )) - | _ -> - let v = Ext_ident.create_tmp () in - let var_v = E.var v in - ( S.define_variable ~kind:Variable v - (match eff with - | [] -> E.obj map - | x :: xs -> E.seq (E.fuse_to_seq x xs) (E.obj map)) - :: Ext_list.flat_map assignment - (fun ((xlabel : External_arg_spec.obj_param), (arg : J.expression)) - -> - match xlabel with - | { - obj_arg_label = - Obj_optional { name = label; for_sure_no_nested_option }; - } -> ( - (* Need make sure whether assignment is effectful or not - to avoid code duplication - *) - match Js_ast_util.named_expression arg with - | None -> ( - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff - ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type - (if for_sure_no_nested_option then arg - else Js_of_lam_option.val_from_option arg) - in - match acc with - | Splice1 v -> - [ - S.if_ - (Js_of_lam_option.is_not_none arg) - [ - S.exp - (E.assign (E.dot var_v label) - (match new_eff with - | [] -> v - | x :: xs -> E.seq (E.fuse_to_seq x xs) v)); - ]; - ] - | Splice0 | Splice2 _ -> assert false) - | Some (st, id) -> ( - (* FIXME: see #2503 *) - let arg = E.var id in - let acc, new_eff = - Lam_compile_external_call.ocaml_to_js_eff - ~arg_label:Arg_empty ~arg_type:xlabel.obj_arg_type - (if for_sure_no_nested_option then arg - else Js_of_lam_option.val_from_option arg) - in - match acc with - | Splice1 v -> - [ - st; - S.if_ - (Js_of_lam_option.is_not_none arg) - [ - S.exp - (E.assign (E.dot var_v label) - (match new_eff with - | [] -> v - | x :: xs -> E.seq (E.fuse_to_seq x xs) v)); - ]; - ] - | Splice0 | Splice2 _ -> assert false)) - | _ -> assert false), - var_v ) diff --git a/jscomp/core/lam_compile_external_obj.mli b/jscomp/core/lam_compile_external_obj.mli deleted file mode 100644 index 2c91410..0000000 --- a/jscomp/core/lam_compile_external_obj.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Compile ocaml external function call to JS IR. *) - -(** - This module define how the FFI (via `external`) works with attributes. - Note it will route to {!Lam_compile_global} - for compiling normal functions without attributes. -*) - -val assemble_obj_args : - External_arg_spec.obj_params -> J.expression list -> J.block * J.expression -(* It returns a block in cases we need set the property dynamically: we need - create a place holder assignment first and then set it accordingly -*) diff --git a/jscomp/core/lam_compile_main.ml b/jscomp/core/lam_compile_main.ml deleted file mode 100644 index 2cc59ca..0000000 --- a/jscomp/core/lam_compile_main.ml +++ /dev/null @@ -1,338 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - - -(* module E = Js_exp_make *) -(* module S = Js_stmt_make *) - - -let compile_group output_prefix (meta : Lam_stats.t) - (x : Lam_group.t) : Js_output.t = - match x with - (* - We need - - 2. [E.builtin_dot] for javascript builtin - 3. [E.mldot] - *) - (* ATTENTION: check {!Lam_compile_global} for consistency *) - (* Special handling for values in [Pervasives] *) - (* - we delegate [stdout, stderr, and stdin] into [caml_io] module, - the motivation is to help dead code eliminatiion, it's helpful - to make those parts pure (not a function call), then it can be removed - if unused - *) - - (* QUICK hack to make hello world example nicer, - Note the arity of [print_endline] is already analyzed before, - so it should be safe - *) - - | Single (kind, id, lam) -> - (* let lam = Optimizer.simplify_lets [] lam in *) - (* can not apply again, it's wrong USE it with care*) - (* ([Js_stmt_make.comment (Gen_of_env.query_type id env )], None) ++ *) - Lam_compile.compile_lambda ~output_prefix { continuation = Declare (kind, id); - jmp_table = Lam_compile_context.empty_handler_map; - meta - } lam - - | Recursive id_lams -> - Lam_compile.compile_recursive_lets ~output_prefix - { continuation = EffectCall Not_tail; - jmp_table = Lam_compile_context.empty_handler_map; - meta - } - id_lams - | Nop lam -> (* TODO: Side effect callls, log and see statistics *) - Lam_compile.compile_lambda ~output_prefix {continuation = EffectCall Not_tail; - jmp_table = Lam_compile_context.empty_handler_map; - meta - } lam - -;; - -(** Also need analyze its depenency is pure or not *) -let no_side_effects (rest : Lam_group.t list) : string option = - Ext_list.find_opt rest (fun x -> - match x with - | Single(kind,id,body) -> - begin - match kind with - | Strict | Variable -> - if not @@ Lam_analysis.no_side_effects body - then Some (Printf.sprintf "%s" id.name) - else None - | _ -> None - end - | Recursive bindings -> - Ext_list.find_opt bindings (fun (id,lam) -> - if not @@ Lam_analysis.no_side_effects lam - then Some (Printf.sprintf "%s" id.Ident.name ) - else None - ) - | Nop lam -> - if not @@ Lam_analysis.no_side_effects lam - then - (* (Lam_util.string_of_lambda lam) *) - Some "" - else None (* TODO :*)) - - -let _d = fun s lam -> -#ifndef RELEASE - Lam_util.dump s lam ; - Ext_log.dwarn ~__POS__ "START CHECKING PASS %s@." s; - ignore @@ Lam_check.check !Location.input_name lam; - Ext_log.dwarn ~__POS__ "FINISH CHECKING PASS %s@." s; -#endif - lam - -let _j = Js_pass_debug.dump - -(** Actually simplify_lets is kind of global optimization since it requires you to know whether - it's used or not -*) -let compile - (output_prefix : string) - export_idents - (lam : Lambda.lambda) = - let export_ident_sets = Set_ident.of_list export_idents in - (* To make toplevel happy - reentrant for js-demo *) - let () = -#ifndef RELEASE - Ext_list.iter export_idents - (fun id -> Ext_log.dwarn ~__POS__ "export idents: %s/%d" id.name id.stamp) ; -#endif - Lam_compile_env.reset () ; - in - let lam, may_required_modules = Lam_convert.convert export_ident_sets lam in - - - let lam = _d "initial" lam in - let lam = Lam_pass_deep_flatten.deep_flatten lam in - let lam = _d "flatten0" lam in - let meta : Lam_stats.t = - Lam_stats.make - ~export_idents - ~export_ident_sets in - let () = Lam_pass_collect.collect_info meta lam in - let lam = - let lam = - lam - |> _d "flattern1" - |> Lam_pass_exits.simplify_exits - |> _d "simplyf_exits" - |> (fun lam -> Lam_pass_collect.collect_info meta lam; -#ifndef RELEASE - let () = - Ext_log.dwarn ~__POS__ "Before simplify_alias: %a@." Lam_stats.print meta in -#endif - lam) - |> Lam_pass_remove_alias.simplify_alias meta - |> _d "simplify_alias" - |> Lam_pass_deep_flatten.deep_flatten - |> _d "flatten2" - in (* Inling happens*) - - let () = Lam_pass_collect.collect_info meta lam in - let lam = Lam_pass_remove_alias.simplify_alias meta lam in - let lam = Lam_pass_deep_flatten.deep_flatten lam in - let () = Lam_pass_collect.collect_info meta lam in - let lam = - lam - |> _d "alpha_before" - |> Lam_pass_alpha_conversion.alpha_conversion meta - |> _d "alpha_after" - |> Lam_pass_exits.simplify_exits in - let () = Lam_pass_collect.collect_info meta lam in - - - lam - |> _d "simplify_alias_before" - |> Lam_pass_remove_alias.simplify_alias meta - |> _d "alpha_conversion" - |> Lam_pass_alpha_conversion.alpha_conversion meta - |> _d "before-simplify_lets" - (* we should investigate a better way to put different passes : )*) - |> Lam_pass_lets_dce.simplify_lets - - |> _d "before-simplify-exits" - (* |> (fun lam -> Lam_pass_collect.collect_info meta lam - ; Lam_pass_remove_alias.simplify_alias meta lam) *) - (* |> Lam_group_pass.scc_pass - |> _d "scc" *) - |> Lam_pass_exits.simplify_exits - |> _d "simplify_lets" -#ifndef RELEASE - |> (fun lam -> - let () = - Ext_log.dwarn ~__POS__ "Before coercion: %a@." Lam_stats.print meta in - Lam_check.check !Location.input_name lam - ) -#endif - in - - let ({Lam_coercion.groups = groups } as coerced_input , meta) = - Lam_coercion.coerce_and_group_big_lambda meta lam - in - -#ifndef RELEASE -let () = - Ext_log.dwarn ~__POS__ "After coercion: %a@." Lam_stats.print meta ; - if !Js_config.diagnose then - let f = - Ext_filename.new_extension !Location.input_name ".lambda" in - Ext_fmt.with_file_as_pp f begin fun fmt -> - Format.pp_print_list ~pp_sep:Format.pp_print_newline - Lam_group.pp_group fmt (coerced_input.groups) - end; -in -#endif -let maybe_pure = no_side_effects groups in -#ifndef RELEASE -let () = Ext_log.dwarn ~__POS__ "\n@[[TIME:]Pre-compile: %f@]@." (Sys.time () *. 1000.) in -#endif -let body = - Ext_list.map groups (fun group -> compile_group output_prefix meta group) - |> Js_output.concat - |> Js_output.output_as_block -in -#ifndef RELEASE -let () = Ext_log.dwarn ~__POS__ "\n@[[TIME:]Post-compile: %f@]@." (Sys.time () *. 1000.) in -#endif -(* The file is not big at all compared with [cmo] *) -(* Ext_marshal.to_file (Ext_path.chop_extension filename ^ ".mj") js; *) -let meta_exports = meta.exports in -let export_set = Set_ident.of_list meta_exports in -let js : J.program = - { - exports = meta_exports ; - export_set; - block = body} -in -js -|> _j "initial" -|> Js_pass_flatten.program -|> _j "flattern" -|> Js_pass_tailcall_inline.tailcall_inline -|> _j "inline_and_shake" -|> Js_pass_flatten_and_mark_dead.program -|> _j "flatten_and_mark_dead" -(* |> Js_inline_and_eliminate.inline_and_shake *) -(* |> _j "inline_and_shake" *) -|> (fun js -> ignore @@ Js_pass_scope.program js ; js ) -|> Js_shake.shake_program -|> _j "shake" -|> ( fun (program: J.program) -> - let external_module_ids : Lam_module_ident.t list = - if !Js_config.all_module_aliases then [] - else - let hard_deps = - Js_fold_basic.calculate_hard_dependencies program.block in - Lam_compile_env.populate_required_modules - may_required_modules hard_deps ; - Ext_list.sort_via_array (Lam_module_ident.Hash_set.to_list hard_deps) - (fun id1 id2 -> - Ext_string.compare (Lam_module_ident.name id1) (Lam_module_ident.name id2) - ) - in - Warnings.check_fatal(); - let effect = - Lam_stats_export.get_dependent_module_effect - maybe_pure external_module_ids in - let v : Js_cmj_format.t = - Lam_stats_export.export_to_cmj - meta - effect - coerced_input.export_map - (if Ext_char.is_lower_case (Filename.basename output_prefix).[0] then Little else Upper) - in - (if not !Clflags.dont_write_files then - Js_cmj_format.to_file - ~check_exists:(not !Js_config.force_cmj) - (output_prefix ^ Literals.suffix_cmj) v); - {J.program = program ; side_effect = effect ; modules = external_module_ids } - ) -;; - -let (//) = Filename.concat - -let lambda_as_module - (lambda_output : J.deps_program) - (output_prefix : string) - : unit = - let package_info = Js_packages_state.get_packages_info () in - if Js_packages_info.is_empty package_info && !Js_config.js_stdout then begin - Js_dump_program.dump_deps_program ~output_prefix Commonjs (lambda_output) stdout - end else - Js_packages_info.iter package_info (fun {module_system; path; suffix} -> - let output_chan chan = - Js_dump_program.dump_deps_program ~output_prefix - module_system - (lambda_output) - chan in - let basename = - Ext_namespace.change_ext_ns_suffix (Filename.basename output_prefix) suffix - in - let target_file = - (Lazy.force Ext_path.package_dir // - path // - basename - (* #913 only generate little-case js file *) - ) in - (if not !Clflags.dont_write_files then - Ext_pervasives.with_file_as_chan - target_file output_chan ); - if !Warnings.has_warnings then begin - Warnings.has_warnings := false ; -#ifndef BROWSER - (* 5206: When there were warnings found during the compilation, we want the file - to be rebuilt on the next "rescript build" so that the warnings keep being shown. - Set the timestamp of the ast file to 1970-01-01 to make this rebuild happen. - (Do *not* set the timestamp of the JS output file instead - as that does not play well with every bundler.) *) - let ast_file = output_prefix ^ Literals.suffix_ast in - if Sys.file_exists ast_file then begin - Bs_hash_stubs.set_as_old_file ast_file - end -#endif - end - ) - - - -(* We can use {!Env.current_unit = "Pervasives"} to tell if it is some specific module, - We need handle some definitions in standard libraries in a special way, most are io specific, - includes {!Pervasives.stdin, Pervasives.stdout, Pervasives.stderr} - - However, use filename instead of {!Env.current_unit} is more honest, since node-js module system is coupled with the file name -*) diff --git a/jscomp/core/lam_compile_main.mli b/jscomp/core/lam_compile_main.mli deleted file mode 100644 index fcd298c..0000000 --- a/jscomp/core/lam_compile_main.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** ReScript entry point in the OCaml compiler *) - -(** Compile and register the hook of function to compile a lambda to JS IR -*) - -val compile : string -> Ident.t list -> Lambda.lambda -> J.deps_program -(** For toplevel, [filename] is [""] which is the same as - {!Env.get_unit_name ()} -*) - -val lambda_as_module : J.deps_program -> string -> unit diff --git a/jscomp/core/lam_compile_primitive.ml b/jscomp/core/lam_compile_primitive.ml deleted file mode 100644 index f78c5de..0000000 --- a/jscomp/core/lam_compile_primitive.ml +++ /dev/null @@ -1,406 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make - -(* If it is the return value, since it is a side-effect call, - we return unit, otherwise just return it -*) -let ensure_value_unit (st : Lam_compile_context.continuation) e : E.t = - match st with - | EffectCall (Maybe_tail_is_return _) - | NeedValue (Maybe_tail_is_return _) - | Assign _ | Declare _ | NeedValue _ -> - E.seq e E.unit - | EffectCall Not_tail -> e -(* NeedValue should return a meaningful expression*) - -let module_of_expression = function - | J.Var (J.Qualified (module_id, value)) -> [ (module_id, value) ] - | _ -> [] - -let get_module_system () = - let package_info = Js_packages_state.get_packages_info () in - let module_system = - if Js_packages_info.is_empty package_info && !Js_config.js_stdout then - [Ext_module_system.Commonjs] - else Js_packages_info.map package_info (fun {module_system} -> module_system) - in - match module_system with - | [module_system] -> module_system - | _ -> Commonjs - -let import_of_path path = - E.call - ~info:{ arity = Full; call_info = Call_na } - (E.js_global "import") - [ E.str path ] - -let wrap_then import value = - let arg = Ident.create "m" in - E.call - ~info:{ arity = Full; call_info = Call_na } - (E.dot import "then") - [ - E.ocaml_fun ~return_unit:false ~async:false ~oneUnitArg:false [ arg ] - [ - { - statement_desc = J.Return (E.dot (E.var arg) value); - comment = None; - }; - ]; - ] - -let translate output_prefix loc (cxt : Lam_compile_context.t) - (prim : Lam_primitive.t) (args : J.expression list) : J.expression = - match prim with - | Pis_not_none -> Js_of_lam_option.is_not_none (Ext_list.singleton_exn args) - | Pcreate_extension s -> E.make_exception s - | Pwrap_exn -> - E.runtime_call Js_runtime_modules.caml_js_exceptions - "internalToOCamlException" args - | Praw_js_code { code; code_info } -> E.raw_js_code code_info code - (* FIXME: save one allocation - trim can not be done before syntax checking - otherwise location is incorrect - *) - | Pjs_runtime_apply -> ( - match args with [ f; args ] -> E.flat_call f args | _ -> assert false) - | Pjs_apply -> ( - match args with - | fn :: rest -> E.call ~info:{ arity = Full; call_info = Call_na } fn rest - | _ -> assert false) - | Pnull_to_opt -> ( - match args with - | [ e ] -> ( - match e.expression_desc with - | Var _ | Undefined _ | Null -> Js_of_lam_option.null_to_opt e - | _ -> E.runtime_call Js_runtime_modules.option "null_to_opt" args) - | _ -> assert false) - | Pundefined_to_opt -> ( - match args with - | [ e ] -> ( - match e.expression_desc with - | Var _ | Undefined _ | Null -> Js_of_lam_option.undef_to_opt e - | _ -> - E.runtime_call Js_runtime_modules.option "undefined_to_opt" args) - | _ -> assert false) - | Pnull_undefined_to_opt -> ( - match args with - | [ e ] -> ( - match e.expression_desc with - | Var _ | Undefined _ | Null -> Js_of_lam_option.null_undef_to_opt e - | _ -> E.runtime_call Js_runtime_modules.option "nullable_to_opt" args - ) - | _ -> assert false) - (* Compile #import: The module argument for dynamic import is represented as a path, - and the module value is expressed through wrapping it with promise.then *) - | Pimport -> ( - match args with - | [ e ] -> ( - let output_dir = Filename.dirname output_prefix in - - let module_id, module_value = - match module_of_expression e.expression_desc with - | [ module_ ] -> module_ - | _ -> Location.raise_errorf ~loc - "Invalid argument: Dynamic import requires a module or module value that is a file as argument. Passing a value or local module is not allowed." - in - - let path = - let module_system = get_module_system () in - Js_name_of_module_id.string_of_module_id {module_id with dynamic_import = true} ~output_dir module_system - in - - match module_value with - | Some value -> wrap_then (import_of_path path) value - | None -> import_of_path path) - | [] | _ -> - Location.raise_errorf ~loc - "Invalid argument: Dynamic import must take a single module or module value as its argument.") - | Pjs_function_length -> E.function_length (Ext_list.singleton_exn args) - | Pcaml_obj_length -> E.obj_length (Ext_list.singleton_exn args) - | Pis_null -> E.is_null (Ext_list.singleton_exn args) - | Pis_undefined -> E.is_undef (Ext_list.singleton_exn args) - | Pis_null_undefined -> E.is_null_undefined (Ext_list.singleton_exn args) - | Pjs_typeof -> E.typeof (Ext_list.singleton_exn args) - | Pjs_unsafe_downgrade _ | Pdebugger | Pvoid_run | Pfull_apply | Pjs_fn_make _ | Pjs_fn_make_unit - -> - assert false (* already handled by {!Lam_compile} *) - | Pjs_fn_method -> assert false - | Pstringadd -> ( - match args with [ a; b ] -> E.string_append a b | _ -> assert false) - | Pinit_mod -> E.runtime_call Js_runtime_modules.module_ "init_mod" args - | Pupdate_mod -> E.runtime_call Js_runtime_modules.module_ "update_mod" args - | Psome -> ( - let arg = Ext_list.singleton_exn args in - match arg.expression_desc with - | Null | Object _ | Number _ | Caml_block _ | Array _ | Str _ -> - (* This makes sense when type info - is not available at the definition - site, and inline recovered it - *) - E.optional_not_nest_block arg - | _ -> E.optional_block arg) - | Psome_not_nest -> E.optional_not_nest_block (Ext_list.singleton_exn args) - | Pmakeblock (tag, tag_info, mutable_flag) -> - (* RUNTIME *) - Js_of_lam_block.make_block - (Js_op_util.of_lam_mutable_flag mutable_flag) - tag_info (E.small_int tag) args - | Pval_from_option -> - Js_of_lam_option.val_from_option (Ext_list.singleton_exn args) - | Pval_from_option_not_nest -> Ext_list.singleton_exn args - | Pfield (i, fld_info) -> - Js_of_lam_block.field fld_info - (Ext_list.singleton_exn args) - (Int32.of_int i) - (* Invariant depends on runtime *) - (* Negate boxed int *) - | Pnegint -> - (* #977 *) - E.int32_minus E.zero_int_literal (Ext_list.singleton_exn args) - | Pnegint64 -> Js_long.neg args - | Pnegfloat -> E.float_minus E.zero_float_lit (Ext_list.singleton_exn args) - | Pnegbigint -> E.bigint_op Minus E.zero_bigint_literal (Ext_list.singleton_exn args) - (* Negate boxed int end*) - (* Int addition and subtraction *) - | Paddint -> ( - match args with [ e1; e2 ] -> E.int32_add e1 e2 | _ -> assert false) - | Paddint64 -> Js_long.add args - | Paddfloat -> ( - match args with [ e1; e2 ] -> E.float_add e1 e2 | _ -> assert false) - | Paddbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Plus e1 e2 | _ -> assert false) - | Psubint -> ( - match args with [ e1; e2 ] -> E.int32_minus e1 e2 | _ -> assert false) - | Psubint64 -> Js_long.sub args - | Psubfloat -> ( - match args with [ e1; e2 ] -> E.float_minus e1 e2 | _ -> assert false) - | Psubbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Minus e1 e2 | _ -> assert false) - | Pmulint -> ( - match args with [ e1; e2 ] -> E.int32_mul e1 e2 | _ -> assert false) - | Pmulint64 -> Js_long.mul args - | Pmulfloat -> ( - match args with [ e1; e2 ] -> E.float_mul e1 e2 | _ -> assert false) - | Pmulbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Mul e1 e2 | _ -> assert false) - | Pdivfloat -> ( - match args with [ e1; e2 ] -> E.float_div e1 e2 | _ -> assert false) - | Pdivint -> ( - match args with - | [ e1; e2 ] -> E.int32_div ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) - | Pdivint64 -> Js_long.div args - | Pdivbigint -> ( - match args with - | [ e1; e2 ] -> E.bigint_div ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) - | Pmodint -> ( - match args with - | [ e1; e2 ] -> E.int32_mod ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) - | Pmodint64 -> Js_long.mod_ args - | Pmodbigint -> ( - match args with - | [ e1; e2 ] -> E.bigint_mod ~checked:!Js_config.check_div_by_zero e1 e2 - | _ -> assert false) - | Ppowbigint -> (match args with [ e1; e2 ] -> E.bigint_op Pow e1 e2 | _ -> assert false) - | Plslint -> ( - match args with [ e1; e2 ] -> E.int32_lsl e1 e2 | _ -> assert false) - | Plslint64 -> Js_long.lsl_ args - | Plslbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Lsl e1 e2 | _ -> assert false) - | Plsrint -> ( - match args with - | [ e1; { J.expression_desc = Number (Int { i = 0l; _ } | Uint 0l); _ } ] - -> - e1 - | [ e1; e2 ] -> E.to_int32 @@ E.int32_lsr e1 e2 - | _ -> assert false) - | Plsrint64 -> Js_long.lsr_ args - | Pasrint -> ( - match args with [ e1; e2 ] -> E.int32_asr e1 e2 | _ -> assert false) - | Pasrint64 -> Js_long.asr_ args - | Pasrbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Asr e1 e2 | _ -> assert false) - | Pandint -> ( - match args with [ e1; e2 ] -> E.int32_band e1 e2 | _ -> assert false) - | Pandint64 -> Js_long.and_ args - | Pandbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Band e1 e2 | _ -> assert false) - | Porint -> ( - match args with [ e1; e2 ] -> E.int32_bor e1 e2 | _ -> assert false) - | Porint64 -> Js_long.or_ args - | Porbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Bor e1 e2 | _ -> assert false) - | Pxorint -> ( - match args with [ e1; e2 ] -> E.int32_bxor e1 e2 | _ -> assert false) - | Pxorint64 -> Js_long.xor args - | Pxorbigint -> ( - match args with [ e1; e2 ] -> E.bigint_op Bxor e1 e2 | _ -> assert false) - | Pjscomp cmp -> ( - match args with [ l; r ] -> E.js_comp cmp l r | _ -> assert false) - | Pfloatcomp cmp | Pintcomp cmp -> ( - (* Global Builtin Exception is an int, like - [Not_found] or [Invalid_argument] ? - *) - match args with [ e1; e2 ] -> E.int_comp cmp e1 e2 | _ -> assert false) - | Pbigintcomp cmp -> ( - match args with [ e1; e2 ] -> E.bigint_comp cmp e1 e2 | _ -> assert false) - (* List --> stamp = 0 - Assert_false --> stamp = 26 - *) - | Pint64comp cmp -> Js_long.comp cmp args - | Pintoffloat -> ( - match args with [ e ] -> E.to_int32 e | _ -> assert false) - | Pint64ofint -> Js_long.of_int32 args - | Pfloatofint -> Ext_list.singleton_exn args - | Pintofint64 -> Js_long.to_int32 args - | Pnot -> E.not (Ext_list.singleton_exn args) - | Poffsetint n -> E.offset (Ext_list.singleton_exn args) n - | Poffsetref n -> - let v = - Js_of_lam_block.field Lambda.ref_field_info - (Ext_list.singleton_exn args) - 0l - in - E.seq (E.assign v (E.offset v n)) E.unit - | Psequand -> ( - (* TODO: rhs is possibly a tail call *) - match args with [ e1; e2 ] -> E.and_ e1 e2 | _ -> assert false) - | Psequor -> ( - (* TODO: rhs is possibly a tail call *) - match args with [ e1; e2 ] -> E.or_ e1 e2 | _ -> assert false) - | Pisout off -> ( - match args with - (* predicate: [x > range or x < 0 ] - can be simplified if x is positive , x > range - if x is negative, fine, its uint is for sure larger than range, - the output is not readable, we might change it back. - - Note that if range is small like [1], then the negative of - it can be more precise (given integer) - a normal case of the compiler is that it will do a shift - in the first step [ (x - 1) > 1 or ( x - 1 ) < 0 ] - *) - | [ range; e ] -> E.is_out (E.offset e off) range - | _ -> assert false) - | Pbytes_to_string -> - Js_of_lam_string.bytes_to_string (Ext_list.singleton_exn args) - | Pstringlength -> E.string_length (Ext_list.singleton_exn args) - | Pbyteslength -> E.bytes_length (Ext_list.singleton_exn args) - (* This should only be Pbyteset(u|s), which in js, is an int array - Bytes is an int array in javascript - *) - | Pbytessetu -> ( - match args with - | [ e; e0; e1 ] -> - ensure_value_unit cxt.continuation (Js_of_lam_string.set_byte e e0 e1) - | _ -> assert false) - | Pbytessets -> E.runtime_call Js_runtime_modules.bytes "set" args - | Pbytesrefu -> ( - match args with - | [ e; e1 ] -> Js_of_lam_string.ref_byte e e1 - | _ -> assert false) - | Pbytesrefs -> E.runtime_call Js_runtime_modules.bytes "get" args - | Pstringrefs -> E.runtime_call Js_runtime_modules.string "get" args - (* For bytes and string, they both return [int] in ocaml - we need tell Pbyteref from Pstringref - 1. Pbyteref -> a[i] - 2. Pstringref -> a.charCodeAt (a[i] is wrong) - *) - | Pstringrefu -> ( - match args with - | [ e; e1 ] -> Js_of_lam_string.ref_string e e1 - | _ -> assert false) - (* only when Lapply -> expand = true*) - | Praise -> assert false (* handled before here *) - (* Runtime encoding relevant *) - | Parraylength -> E.array_length (Ext_list.singleton_exn args) - | Psetfield (i, field_info) -> ( - match args with - | [ e0; e1 ] -> - (* RUNTIME *) - ensure_value_unit cxt.continuation - (Js_of_lam_block.set_field field_info e0 (Int32.of_int i) e1) - (*TODO: get rid of [E.unit ()]*) - | _ -> assert false) - | Parrayrefu -> ( - match args with - | [ e; e1 ] -> Js_of_lam_array.ref_array e e1 (* Todo: Constant Folding *) - | _ -> assert false) - | Parrayrefs -> E.runtime_call Js_runtime_modules.array "get" args - | Parraysets -> E.runtime_call Js_runtime_modules.array "set" args - | Pmakearray -> Js_of_lam_array.make_array Mutable args - | Parraysetu -> ( - match args with - (* wrong*) - | [ e; e0; e1 ] -> - ensure_value_unit cxt.continuation (Js_of_lam_array.set_array e e0 e1) - | _ -> assert false) - | Pccall prim -> Lam_dispatch_primitive.translate loc prim.prim_name args - (* Lam_compile_external_call.translate loc cxt prim args *) - (* Test if the argument is a block or an immediate integer *) - | Pjs_object_create _ -> assert false - | Pjs_call { arg_types; ffi; dynamic_import } -> - Lam_compile_external_call.translate_ffi cxt arg_types ffi args ~dynamic_import - (* FIXME, this can be removed later *) - | Pisint -> E.is_type_number (Ext_list.singleton_exn args) - | Pis_poly_var_block -> E.is_type_object (Ext_list.singleton_exn args) - | Pctconst ct -> ( - match ct with - | Big_endian -> E.bool Sys.big_endian - | Ostype -> E.runtime_call Js_runtime_modules.sys "os_type" args - | Ostype_unix -> - E.string_equal - (E.runtime_call Js_runtime_modules.sys "os_type" args) - (E.str "Unix") - | Ostype_win32 -> - E.string_equal - (E.runtime_call Js_runtime_modules.sys "os_type" args) - (E.str "Win32") - (* | Max_wosize -> - (* max_array_length*) - E.int 2147483647l (* 2 ^ 31 - 1 *) *) - (* 4_294_967_295l not representable*) - (* 2 ^ 32 - 1*) - | Backend_type -> - E.make_block E.zero_int_literal - (Blk_constructor { name = "Other"; num_nonconst = 1; tag = 0; attrs = [] }) - [ E.str "BS" ] Immutable) - | Pduprecord -> Lam_dispatch_primitive.translate loc "?obj_dup" args - | Plazyforce - (* FIXME: we don't inline lazy force or at least - let buckle handle it - *) - (* let parm = Ident.create "prim" in - Lfunction(Curried, [parm], - Matching.inline_lazy_force (Lvar parm) Location.none) - It is inlined, this should not appear here *) -> - (*we dont use [throw] here, since [throw] is an statement *) - let s = Lam_print.primitive_to_string prim in - Bs_warnings.warn_missing_primitive loc s; - E.resolve_and_apply s args diff --git a/jscomp/core/lam_compile_primitive.mli b/jscomp/core/lam_compile_primitive.mli deleted file mode 100644 index b507f63..0000000 --- a/jscomp/core/lam_compile_primitive.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Primitive compilation *) - -(* The entry point of compile primitives - Note it will call {!Lam_compile_external_call.translate} for c stubs compilation -*) - -val translate : - string -> - Location.t -> - Lam_compile_context.t -> - Lam_primitive.t -> - J.expression list -> - J.expression diff --git a/jscomp/core/lam_compile_util.ml b/jscomp/core/lam_compile_util.ml deleted file mode 100644 index e86e3f5..0000000 --- a/jscomp/core/lam_compile_util.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let jsop_of_comp (cmp : Lam_compat.comparison) : Js_op.binop = - match cmp with - | Ceq -> EqEqEq (* comparison*) - | Cneq -> NotEqEq - | Clt -> Lt - | Cgt -> Gt - | Cle -> Le - | Cge -> Ge diff --git a/jscomp/core/lam_compile_util.mli b/jscomp/core/lam_compile_util.mli deleted file mode 100644 index 2d1f091..0000000 --- a/jscomp/core/lam_compile_util.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Some utilities for lambda compilation*) - -val jsop_of_comp : Lam_compat.comparison -> Js_op.binop diff --git a/jscomp/core/lam_constant_convert.ml b/jscomp/core/lam_constant_convert.ml deleted file mode 100644 index 360eb55..0000000 --- a/jscomp/core/lam_constant_convert.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let rec convert_constant (const : Lambda.structured_constant) : Lam_constant.t = - match const with - | Const_base (Const_int i) -> Const_int { i = Int32.of_int i; comment = None } - | Const_base (Const_char i) -> Const_char i - | Const_base (Const_string (s, opt)) -> - let unicode = - match opt with - | Some opt -> Ast_utf8_string_interp.is_unicode_string opt - | _ -> false - in - Const_string { s; unicode } - | Const_base (Const_float i) -> Const_float i - | Const_base (Const_int32 i) -> Const_int { i; comment = None } - | Const_base (Const_int64 i) -> Const_int64 i - | Const_base (Const_bigint (sign, i)) -> Const_bigint (sign, i) - | Const_pointer (0, Pt_constructor { name = "()"; const = 1; non_const = 0 }) - -> - Const_js_undefined {isUnit = true} - | Const_false -> Const_js_false - | Const_true -> Const_js_true - | Const_pointer (i, p) -> ( - match p with - | Pt_module_alias -> Const_module_alias - | Pt_shape_none -> Lam_constant.lam_none - | Pt_assertfalse -> - Const_int { i = Int32.of_int i; comment = Pt_assertfalse } - | Pt_constructor { name; const; non_const; attrs } -> - let tag_type = Ast_untagged_variants.process_tag_type attrs in - Const_int - { - i = Int32.of_int i; - comment = Pt_constructor { cstr_name={name; tag_type}; const; non_const }; - } - | Pt_variant { name } -> - if Ext_string.is_valid_hash_number name then - Const_int - { i = Ext_string.hash_number_as_i32_exn name; comment = None } - else Const_pointer name) - | Const_float_array s -> Const_float_array s - | Const_immstring s -> Const_string { s; unicode = false } - | Const_block (t, xs) -> ( - let tag = Lambda.tag_of_tag_info t in - match t with - | Blk_some_not_nested -> - Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_some -> Const_some (convert_constant (Ext_list.singleton_exn xs)) - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_module _ - | Blk_module_export _ | Blk_extension | Blk_record_inlined _ - | Blk_record_ext _ -> - Const_block (tag, t, Ext_list.map xs convert_constant) - | Blk_poly_var s -> ( - match xs with - | [ _; value ] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - Const_int - { i = Ext_string.hash_number_as_i32_exn s; comment = None } - else Const_string { s; unicode = false } - in - Const_block (tag, t, [ tag_val; convert_constant value ]) - | _ -> assert false) - | Blk_lazy_general -> assert false) diff --git a/jscomp/core/lam_constant_convert.mli b/jscomp/core/lam_constant_convert.mli deleted file mode 100644 index d0bf020..0000000 --- a/jscomp/core/lam_constant_convert.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val convert_constant : Lambda.structured_constant -> Lam_constant.t diff --git a/jscomp/core/lam_convert.ml b/jscomp/core/lam_convert.ml deleted file mode 100644 index 8264a60..0000000 --- a/jscomp/core/lam_convert.ml +++ /dev/null @@ -1,836 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let caml_id_field_info : Lambda.field_dbg_info = - Fld_record { name = Literals.exception_id; mutable_flag = Immutable } - -let lam_caml_id : Lam_primitive.t = Pfield (0, caml_id_field_info) -let prim = Lam.prim - -let lam_extension_id loc (head : Lam.t) = - prim ~primitive:lam_caml_id ~args:[ head ] loc - -let lazy_block_info : Lam_tag_info.t = - Blk_record - { - fields = [| Literals.lazy_done; Literals.lazy_val |]; - mutable_flag = Mutable; - record_repr = Record_regular; - } - -(** A conservative approach to avoid packing exceptions - for lambda expression like {[ - try { ... }catch(id){body} - ]} - we approximate that if [id] is destructed or not. - If it is destructed, we need pack it in case it is JS exception. - The packing is called Js.Exn.internalTOOCamlException, which is a nop for OCaml exception, - but will wrap as (Error e) when it is an JS exception. - - {[ - try .. with - | A (x,y) -> - | Js.Error .. - ]} - - Without such wrapping, the code above would raise - - Note it is not guaranteed that exception raised(or re-raised) is a structured - ocaml exception but it is guaranteed that if such exception is processed it would - still be an ocaml exception. - for example {[ - match x with - | exception e -> raise e - ]} - it will re-raise an exception as it is (we are not packing it anywhere) - - It is hard to judge an exception is destructed or escaped, any potential - alias(or if it is passed as an argument) would cause it to be leaked -*) -let exception_id_destructed (l : Lam.t) (fv : Ident.t) : bool = - let rec hit_opt (x : _ option) = - match x with None -> false | Some a -> hit a - and hit_list_snd : 'a. ('a * _) list -> bool = - fun x -> Ext_list.exists_snd x hit - and hit_list xs = Ext_list.exists xs hit - and hit (l : Lam.t) = - match l with - (* | Lprim {primitive = Pintcomp _ ; - args = ([x;y ]) } -> - begin match x,y with - | Lvar _, Lvar _ -> false - | Lvar _, _ -> hit y - | _, Lvar _ -> hit x - | _, _ -> hit x || hit y - end *) - (* FIXME: this can be uncovered after we do the unboxing *) - | Lprim { primitive = Praise; args = [ Lvar _ ] } -> false - | Lprim { primitive = _; args; _ } -> hit_list args - | Lvar id -> Ident.same id fv - | Lassign (id, e) -> Ident.same id fv || hit e - | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body - | Lletrec (decl, body) -> hit body || hit_list_snd decl - | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 - | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args - | Lglobal_module _ (* global persistent module, play safe *) -> false - | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default - | Lstaticraise (_, args) -> hit_list args - | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 - | Lsequence (e1, e2) -> hit e1 || hit e2 - | Lwhile (e1, e2) -> hit e1 || hit e2 - in - hit l - -let abs_int x = if x < 0 then -x else x -let no_over_flow x = abs_int x < 0x1fff_ffff - -let lam_is_var (x : Lam.t) (y : Ident.t) = - match x with Lvar y2 -> Ident.same y2 y | _ -> false - -(** Make sure no int range overflow happens - also we only check [int] -*) -let happens_to_be_diff (sw_consts : (int * Lambda.lambda) list) sw_names : int option = - match sw_consts with - | ( a, - Lconst (Const_base (Const_int a0)) - ) - :: ( b, - Lconst - (Const_base (Const_int b0)) ) - :: rest - when sw_names = None && no_over_flow a && no_over_flow a0 && no_over_flow b && no_over_flow b0 - -> - let diff = a0 - a in - if b0 - b = diff then - if - Ext_list.for_all rest (fun (x, lam) -> - match lam with - | Lconst - ( Const_base (Const_int x0) ) - when no_over_flow x0 && no_over_flow x -> - x0 - x = diff - | _ -> false) - then Some diff - else None - else None - | _ -> None - -(* type required_modules = Lam_module_ident.Hash_set.t *) - -(** drop Lseq (List! ) etc - see #3852, we drop all these required global modules - but added it back based on our own module analysis -*) -let seq = Lam.seq - -let unit = Lam.unit - -let lam_prim ~primitive:(p : Lambda.primitive) ~args loc : Lam.t = - match p with - | Pidentity -> Ext_list.singleton_exn args - | Puncurried_apply | Pccall _ -> assert false - | Prevapply -> assert false - | Pdirapply -> assert false - | Ploc _ -> assert false (* already compiled away here*) - | Pbytes_to_string (* handled very early *) -> - prim ~primitive:Pbytes_to_string ~args loc - | Pcreate_extension s -> prim ~primitive:(Pcreate_extension s) ~args loc - | Pignore -> - (* Pignore means return unit, it is not an nop *) - seq (Ext_list.singleton_exn args) unit - | Pgetglobal _ -> assert false - | Pmakeblock info -> ( - let tag = Lambda.tag_of_tag_info info in - let mutable_flag = Lambda.mutable_flag_of_tag_info info in - match info with - | Blk_some_not_nested -> prim ~primitive:Psome_not_nest ~args loc - | Blk_some -> prim ~primitive:Psome ~args loc - | Blk_constructor _ | Blk_tuple | Blk_record _ | Blk_record_inlined _ - | Blk_module _ | Blk_module_export _ | Blk_extension | Blk_record_ext _ -> - prim ~primitive:(Pmakeblock (tag, info, mutable_flag)) ~args loc - | Blk_poly_var s -> ( - match args with - | [ _; value ] -> - let tag_val : Lam_constant.t = - if Ext_string.is_valid_hash_number s then - Const_int - { i = Ext_string.hash_number_as_i32_exn s; comment = None } - else Const_string { s; unicode = false } - in - prim - ~primitive:(Pmakeblock (tag, info, mutable_flag)) - ~args:[ Lam.const tag_val; value ] - loc - | _ -> assert false) - | Blk_lazy_general -> ( - match args with - | [ ((Lvar _ | Lconst _ | Lfunction _) as result) ] -> - let args = [ Lam.const Const_js_true; result ] in - prim - ~primitive:(Pmakeblock (tag, lazy_block_info, Mutable)) - ~args loc - | [ computation ] -> - let args = - [ - Lam.const Const_js_false; - (* FIXME: arity 0 does not get proper supported*) - Lam.function_ ~arity:0 ~params:[] ~body:computation - ~attr:Lambda.default_function_attribute; - ] - in - prim - ~primitive:(Pmakeblock (tag, lazy_block_info, Mutable)) - ~args loc - | _ -> assert false)) - | Pfield (id, info) -> prim ~primitive:(Pfield (id, info)) ~args loc - | Psetfield (id, info) -> prim ~primitive:(Psetfield (id, info)) ~args loc - | Pduprecord -> prim ~primitive:Pduprecord ~args loc - | Plazyforce -> prim ~primitive:Plazyforce ~args loc - | Praise _ -> prim ~primitive:Praise ~args loc - | Psequand -> prim ~primitive:Psequand ~args loc - | Psequor -> prim ~primitive:Psequor ~args loc - | Pnot -> prim ~primitive:Pnot ~args loc - | Pnegint -> prim ~primitive:Pnegint ~args loc - | Paddint -> prim ~primitive:Paddint ~args loc - | Psubint -> prim ~primitive:Psubint ~args loc - | Pmulint -> prim ~primitive:Pmulint ~args loc - | Pdivint _is_safe (*FIXME*) -> prim ~primitive:Pdivint ~args loc - | Pmodint _is_safe (*FIXME*) -> prim ~primitive:Pmodint ~args loc - | Pandint -> prim ~primitive:Pandint ~args loc - | Porint -> prim ~primitive:Porint ~args loc - | Pxorint -> prim ~primitive:Pxorint ~args loc - | Plslint -> prim ~primitive:Plslint ~args loc - | Plsrint -> prim ~primitive:Plsrint ~args loc - | Pasrint -> prim ~primitive:Pasrint ~args loc - | Pstringlength -> prim ~primitive:Pstringlength ~args loc - | Pstringrefu -> prim ~primitive:Pstringrefu ~args loc - | Pabsfloat -> assert false - | Pstringrefs -> prim ~primitive:Pstringrefs ~args loc - | Pbyteslength -> prim ~primitive:Pbyteslength ~args loc - | Pbytesrefu -> prim ~primitive:Pbytesrefu ~args loc - | Pbytessetu -> prim ~primitive:Pbytessetu ~args loc - | Pbytesrefs -> prim ~primitive:Pbytesrefs ~args loc - | Pbytessets -> prim ~primitive:Pbytessets ~args loc - | Pisint -> prim ~primitive:Pisint ~args loc - | Pisout -> ( - match args with - | [ range; Lprim { primitive = Poffsetint i; args = [ x ] } ] -> - prim ~primitive:(Pisout i) ~args:[ range; x ] loc - | _ -> prim ~primitive:(Pisout 0) ~args loc) - | Pintoffloat -> prim ~primitive:Pintoffloat ~args loc - | Pfloatofint -> prim ~primitive:Pfloatofint ~args loc - | Pnegfloat -> prim ~primitive:Pnegfloat ~args loc - | Paddfloat -> prim ~primitive:Paddfloat ~args loc - | Psubfloat -> prim ~primitive:Psubfloat ~args loc - | Pmulfloat -> prim ~primitive:Pmulfloat ~args loc - | Pdivfloat -> prim ~primitive:Pdivfloat ~args loc - | Pnegbigint -> prim ~primitive:Pnegbigint ~args loc - | Paddbigint -> prim ~primitive:Paddbigint ~args loc - | Psubbigint -> prim ~primitive:Psubbigint ~args loc - | Pmulbigint -> prim ~primitive:Pmulbigint ~args loc - | Pdivbigint -> prim ~primitive:Pdivbigint ~args loc - | Pmodbigint -> prim ~primitive:Pmodbigint ~args loc - | Ppowbigint -> prim ~primitive:Ppowbigint ~args loc - | Pandbigint -> prim ~primitive:Pandbigint ~args loc - | Porbigint -> prim ~primitive:Porbigint ~args loc - | Pxorbigint -> prim ~primitive:Pxorbigint ~args loc - | Plslbigint -> prim ~primitive:Plslbigint ~args loc - | Pasrbigint -> prim ~primitive:Pasrbigint ~args loc - | Pbigintcomp x -> prim ~primitive:(Pbigintcomp x) ~args loc - | Pintcomp x -> prim ~primitive:(Pintcomp x) ~args loc - | Poffsetint x -> prim ~primitive:(Poffsetint x) ~args loc - | Poffsetref x -> prim ~primitive:(Poffsetref x) ~args loc - | Pfloatcomp x -> prim ~primitive:(Pfloatcomp x) ~args loc - | Pmakearray _mutable_flag (*FIXME*) -> prim ~primitive:Pmakearray ~args loc - | Parraylength -> prim ~primitive:Parraylength ~args loc - | Parrayrefu -> prim ~primitive:Parrayrefu ~args loc - | Parraysetu -> prim ~primitive:Parraysetu ~args loc - | Parrayrefs -> prim ~primitive:Parrayrefs ~args loc - | Parraysets -> prim ~primitive:Parraysets ~args loc - | Pbintofint x -> ( - match x with - | Pint32 | Pbigint -> Ext_list.singleton_exn args - | Pint64 -> prim ~primitive:Pint64ofint ~args loc) - | Pintofbint x -> ( - match x with - | Pint32 | Pbigint -> Ext_list.singleton_exn args - | Pint64 -> prim ~primitive:Pintofint64 ~args loc) - | Pnegbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Pnegint ~args loc - | Pint64 -> prim ~primitive:Pnegint64 ~args loc) - | Paddbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Paddint ~args loc - | Pint64 -> prim ~primitive:Paddint64 ~args loc) - | Psubbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Psubint ~args loc - | Pint64 -> prim ~primitive:Psubint64 ~args loc) - | Pmulbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Pmulint ~args loc - | Pint64 -> prim ~primitive:Pmulint64 ~args loc) - | Pdivbint { size = x; is_safe = _ } (*FIXME*) -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Pdivint ~args loc - | Pint64 -> prim ~primitive:Pdivint64 ~args loc) - | Pmodbint { size = x; is_safe = _ } (*FIXME*) -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Pmodint ~args loc - | Pint64 -> prim ~primitive:Pmodint64 ~args loc) - | Pandbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Pandint ~args loc - | Pint64 -> prim ~primitive:Pandint64 ~args loc) - | Porbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Porint ~args loc - | Pint64 -> prim ~primitive:Porint64 ~args loc) - | Pxorbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Pxorint ~args loc - | Pint64 -> prim ~primitive:Pxorint64 ~args loc) - | Plslbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Plslint ~args loc - | Pint64 -> prim ~primitive:Plslint64 ~args loc) - | Plsrbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Plsrint ~args loc - | Pint64 -> prim ~primitive:Plsrint64 ~args loc) - | Pasrbint x -> ( - match x with - | Pbigint | Pint32 -> prim ~primitive:Pasrint ~args loc - | Pint64 -> prim ~primitive:Pasrint64 ~args loc) - | Pctconst x -> ( - match x with - | Word_size | Int_size -> - Lam.const (Const_int { i = 32l; comment = None }) - | Max_wosize -> - Lam.const (Const_int { i = 2147483647l; comment = Some "Max_wosize" }) - | Big_endian -> prim ~primitive:(Pctconst Big_endian) ~args loc - | Ostype_unix -> prim ~primitive:(Pctconst Ostype_unix) ~args loc - | Ostype_win32 -> prim ~primitive:(Pctconst Ostype_win32) ~args loc - | Ostype_cygwin -> Lam.false_ - | Backend_type -> prim ~primitive:(Pctconst Backend_type) ~args loc) - | Pcvtbint (a, b) -> ( - match (a, b) with - | (Pbigint | Pint32), (Pbigint | Pint32) | Pint64, Pint64 -> - Ext_list.singleton_exn args - | Pint64, (Pbigint | Pint32) -> prim ~primitive:Pintofint64 ~args loc - | (Pbigint | Pint32), Pint64 -> prim ~primitive:Pint64ofint ~args loc) - | Pbintcomp (a, b) -> ( - match a with - | Pbigint | Pint32 -> prim ~primitive:(Pintcomp b) ~args loc - | Pint64 -> prim ~primitive:(Pint64comp b) ~args loc) - | Popaque -> Ext_list.singleton_exn args - -(* Does not exist since we compile array in js backend unlike native backend *) - -let may_depend = Lam_module_ident.Hash_set.add - -let rec rename_optional_parameters map params (body : Lambda.lambda) = - match body with - | Llet - ( k, - value_kind, - id, - Lifthenelse - ( Lprim (p, [ Lvar ({ name = "*opt*" } as opt) ], p_loc), - Lprim (p1, [ Lvar ({ name = "*opt*" } as opt2) ], x_loc), - f ), - rest ) - when Ident.same opt opt2 && List.mem opt params -> - let map, rest = rename_optional_parameters map params rest in - let new_id = Ident.create (id.name ^ "Opt") in - ( Map_ident.add map opt new_id, - Lambda.Llet - ( k, - value_kind, - id, - Lifthenelse - ( Lprim (p, [ Lvar new_id ], p_loc), - Lprim (p1, [ Lvar new_id ], x_loc), - f ), - rest ) ) - | _ -> (map, body) - -let convert (exports : Set_ident.t) (lam : Lambda.lambda) : - Lam.t * Lam_module_ident.Hash_set.t = - let alias_tbl = Hash_ident.create 64 in - let exit_map = Hash_int.create 0 in - let may_depends = Lam_module_ident.Hash_set.create 0 in - - let rec convert_ccall (a_prim : Primitive.description) - (args : Lambda.lambda list) loc ~dynamic_import : Lam.t = - let prim_name = a_prim.prim_name in - let prim_name_len = String.length prim_name in - match External_ffi_types.from_string a_prim.prim_native_name with - | Ffi_normal -> - if prim_name_len > 0 && String.unsafe_get prim_name 0 = '#' then - convert_js_primitive a_prim args loc - else - let args = Ext_list.map args convert_aux in - prim ~primitive:(Pccall { prim_name }) ~args loc - | Ffi_obj_create labels -> - let args = Ext_list.map args convert_aux in - prim ~primitive:(Pjs_object_create labels) ~args loc - | Ffi_bs (arg_types, result_type, ffi) -> - let arg_types = - match arg_types with - | Params ls -> ls - | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) - in - let args = Ext_list.map args convert_aux in - Lam.handle_bs_non_obj_ffi arg_types result_type ffi args loc prim_name ~dynamic_import - | Ffi_inline_const i -> Lam.const i - and convert_js_primitive (p : Primitive.description) - (args : Lambda.lambda list) loc : Lam.t = - let s = p.prim_name in - match () with - | _ when s = "#is_not_none" -> - prim ~primitive:Pis_not_none ~args:(Ext_list.map args convert_aux) loc - | _ when s = "#val_from_unnest_option" -> - let v = convert_aux (Ext_list.singleton_exn args) in - prim ~primitive:Pval_from_option_not_nest ~args:[ v ] loc - | _ when s = "#val_from_option" -> - prim ~primitive:Pval_from_option - ~args:(Ext_list.map args convert_aux) - loc - | _ when s = "#is_poly_var_block" -> - prim ~primitive:Pis_poly_var_block - ~args:(Ext_list.map args convert_aux) - loc - | _ when s = "#raw_expr" -> ( - match args with - | [ Lconst (Const_base (Const_string (code, _))) ] -> - (* js parsing here *) - let kind = Classify_function.classify code in - prim - ~primitive:(Praw_js_code { code; code_info = Exp kind }) - ~args:[] loc - | _ -> assert false) - | _ when s = "#raw_stmt" -> ( - match args with - | [ Lconst (Const_base (Const_string (code, _))) ] -> - let kind = Classify_function.classify_stmt code in - prim - ~primitive:(Praw_js_code { code; code_info = Stmt kind }) - ~args:[] loc - | _ -> assert false) - | _ when s = "#debugger" -> - (* ATT: Currently, the arity is one due to PPX *) - prim ~primitive:Pdebugger ~args:[] loc - | _ when s = "#null" -> Lam.const Const_js_null - | _ when s = "#os_type" -> - prim ~primitive:(Pctconst Ostype) ~args:[ unit ] loc - | _ when s = "#undefined" -> Lam.const (Const_js_undefined {isUnit = false}) - | _ when s = "#init_mod" -> ( - let args = Ext_list.map args convert_aux in - match args with - | [ _loc; Lconst (Const_block (0, _, [ Const_block (0, _, []) ])) ] -> - Lam.unit - | _ -> prim ~primitive:Pinit_mod ~args loc) - | _ when s = "#update_mod" -> ( - let args = Ext_list.map args convert_aux in - match args with - | [ Lconst (Const_block (0, _, [ Const_block (0, _, []) ])); _; _ ] -> - Lam.unit - | _ -> prim ~primitive:Pupdate_mod ~args loc) - | _ when s = "#extension_slot_eq" -> ( - match Ext_list.map args convert_aux with - | [ lhs; rhs ] -> - prim - ~primitive:(Pccall { prim_name = "caml_string_equal" }) - ~args:[ lam_extension_id loc lhs; rhs ] - loc - | _ -> assert false) - | _ -> - let primitive : Lam_primitive.t = - match s with - | "#apply" -> Pjs_runtime_apply - | "#apply1" | "#apply2" | "#apply3" | "#apply4" | "#apply5" - | "#apply6" | "#apply7" | "#apply8" -> - Pjs_apply - | "#makemutablelist" -> - Pmakeblock - ( 0, - Blk_constructor { name = "::"; num_nonconst = 1; tag = 0; attrs = [] }, - Mutable ) - | "#undefined_to_opt" -> Pundefined_to_opt - | "#nullable_to_opt" -> Pnull_undefined_to_opt - | "#null_to_opt" -> Pnull_to_opt - | "#is_nullable" -> Pis_null_undefined - | "#import" ->Pimport - | "#string_append" -> Pstringadd - | "#wrap_exn" -> Pwrap_exn - | "#obj_length" -> Pcaml_obj_length - | "#function_length" -> Pjs_function_length - | "#unsafe_lt" -> Pjscomp Clt - | "#unsafe_gt" -> Pjscomp Cgt - | "#unsafe_le" -> Pjscomp Cle - | "#unsafe_ge" -> Pjscomp Cge - | "#unsafe_eq" -> Pjscomp Ceq - | "#unsafe_neq" -> Pjscomp Cneq - | "#typeof" -> Pjs_typeof - | "#run" -> Pvoid_run - | "#fn_mk" -> - Pjs_fn_make (Ext_pervasives.nat_of_string_exn p.prim_native_name) - | "#fn_mk_unit" -> - Pjs_fn_make_unit - | "#fn_method" -> Pjs_fn_method - | "#unsafe_downgrade" -> - Pjs_unsafe_downgrade { name = Ext_string.empty; setter = false } - | _ -> - Location.raise_errorf ~loc - "@{Error:@} internal error, using unrecognized \ - primitive %s" - s - in - let dynamic_import = primitive = Pimport in - let args = Ext_list.map args (convert_aux ~dynamic_import) in - prim ~primitive ~args loc - and convert_aux ?(dynamic_import = false) (lam : Lambda.lambda) : Lam.t = - match lam with - | Lvar x -> Lam.var (Hash_ident.find_default alias_tbl x x) - | Lconst x -> Lam.const (Lam_constant_convert.convert_constant x) - | Lapply { ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined } -> - (* we need do this eargly in case [aux fn] add some wrapper *) - Lam.apply (convert_aux fn) - (Ext_list.map args convert_aux) - { ap_loc = loc; ap_inlined; ap_status = App_na } - | Lfunction { params; body; attr } -> - let new_map, body = - rename_optional_parameters Map_ident.empty params body - in - if Map_ident.is_empty new_map then - Lam.function_ ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) - else - let params = - Ext_list.map params (fun x -> Map_ident.find_default new_map x x) - in - Lam.function_ ~attr ~arity:(List.length params) ~params - ~body:(convert_aux body) - | Llet (kind, Pgenval, id, e, body) (*FIXME*) -> convert_let kind id e body - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings convert_aux in - let body = convert_aux body in - let lam = Lam.letrec bindings body in - Lam_scc.scc bindings lam body - (* inlining will affect how mututal recursive behave *) - | Lprim (Prevapply, [ x; f ], outer_loc) - | Lprim (Pdirapply, [ f; x ], outer_loc) -> - convert_pipe f x outer_loc - | Lprim (Prevapply, _, _) -> assert false - | Lprim (Pdirapply, _, _) -> assert false - | Lprim (Pccall a, args, loc) -> convert_ccall a args loc ~dynamic_import - | Lprim (Pgetglobal id, args, _) -> - let args = Ext_list.map args convert_aux in - if Ident.is_predef_exn id then - Lam.const (Const_string { s = id.name; unicode = false }) - else ( - may_depend may_depends (Lam_module_ident.of_ml ~dynamic_import id); - assert (args = []); - Lam.global_module ~dynamic_import id) - | Lprim - ( Puncurried_apply, - [ Lapply { ap_func = Lprim (Popaque, [ ap_func ], _); ap_args } ], - loc ) -> - let ap_func = convert_aux ap_func in - let ap_args = Ext_list.map ap_args convert_aux in - prim ~primitive:Pfull_apply ~args:(ap_func :: ap_args) loc - (* There may be some optimization opportunities here - for cases like `(fun [@bs] a b -> a + b ) 1 2 [@bs]` *) - | Lprim (Puncurried_apply, _, _) -> assert false - | Lprim (primitive, args, loc) -> - let args = Ext_list.map args (convert_aux ~dynamic_import) in - lam_prim ~primitive ~args loc - | Lswitch (e, s, _loc) -> convert_switch e s - | Lstringswitch (e, cases, default, _) -> - Lam.stringswitch (convert_aux e) - (Ext_list.map_snd cases convert_aux) - (Ext_option.map default convert_aux) - | Lstaticraise (id, []) -> - Lam.staticraise (Hash_int.find_default exit_map id id) [] - | Lstaticraise (id, args) -> - Lam.staticraise id (Ext_list.map args convert_aux) - | Lstaticcatch (b, (i, []), Lstaticraise (j, [])) -> - (* peep-hole [i] aliased to [j] *) - Hash_int.add exit_map i (Hash_int.find_default exit_map j j); - convert_aux b - | Lstaticcatch (b, (i, ids), handler) -> - Lam.staticcatch (convert_aux b) (i, ids) (convert_aux handler) - | Ltrywith (b, id, handler) -> - let body = convert_aux b in - let handler = convert_aux handler in - if exception_id_destructed handler id then - let newId = Ident.create ("raw_" ^ id.name) in - Lam.try_ body newId - (Lam.let_ StrictOpt id - (prim ~primitive:Pwrap_exn ~args:[ Lam.var newId ] Location.none) - handler) - else Lam.try_ body id handler - | Lifthenelse (b, then_, else_) -> - Lam.if_ (convert_aux b) (convert_aux then_) (convert_aux else_) - | Lsequence (a, b) -> Lam.seq (convert_aux a) (convert_aux b) - | Lwhile (b, body) -> Lam.while_ (convert_aux b) (convert_aux body) - | Lfor (id, from_, to_, dir, loop) -> - Lam.for_ id (convert_aux from_) (convert_aux to_) dir (convert_aux loop) - | Lassign (id, body) -> Lam.assign id (convert_aux body) - | Lsend (name, obj, loc) -> - let obj = convert_aux obj in - let args = [ obj ] in - let setter = Ext_string.ends_with name Literals.setter_suffix in - let property = - if setter then - (String.sub name 0 - (String.length name - Literals.setter_suffix_len)) - else name - in - prim - ~primitive:(Pjs_unsafe_downgrade { name = property; setter }) - ~args loc - and convert_let (kind : Lam_compat.let_kind) id (e : Lambda.lambda) body : - Lam.t = - match (kind, e) with - | Alias, Lvar u -> - let new_u = Hash_ident.find_default alias_tbl u u in - Hash_ident.add alias_tbl id new_u; - if Set_ident.mem exports id then - Lam.let_ kind id (Lam.var new_u) (convert_aux body) - else convert_aux body - | _, _ -> ( - let new_e = convert_aux e in - let new_body = convert_aux body in - (* - reverse engineering cases as {[ - (let (switcher/1013 =a (-1+ match/1012)) - (if (isout 2 switcher/1013) (exit 1) - (switch* switcher/1013 - case int 0: 'a' - case int 1: 'b' - case int 2: 'c'))) - ]} - To elemininate the id [switcher], we need ensure it appears only - in two places. - - To advance this case, when [sw_failaction] is None - *) - match (kind, new_e, new_body) with - | ( Alias, - Lprim - { primitive = Poffsetint offset; args = [ (Lvar _ as matcher) ] }, - Lswitch - ( Lvar switcher3, - ({ - sw_consts_full = false; - sw_consts; - sw_blocks = []; - sw_blocks_full = true; - sw_failaction = Some ifso; - } as px) ) ) - when Ident.same switcher3 id - && (not (Lam_hit.hit_variable id ifso)) - && not (Ext_list.exists_snd sw_consts (Lam_hit.hit_variable id)) - -> - Lam.switch matcher - { - px with - sw_consts = - Ext_list.map sw_consts (fun (i, act) -> (i - offset, act)); - } - | _ -> Lam.let_ kind id new_e new_body) - and convert_pipe (f : Lambda.lambda) (x : Lambda.lambda) outer_loc = - let x = convert_aux x in - let f = convert_aux f in - match f with - | Lfunction - { - params = [ param ]; - body = Lprim { primitive; args = [ Lvar inner_arg ] }; - } - when Ident.same param inner_arg -> - Lam.prim ~primitive ~args:[ x ] outer_loc - | Lapply - { - ap_func = - Lfunction { params; body = Lprim { primitive; args = inner_args } }; - ap_args = args; - } - when Ext_list.for_all2_no_exn inner_args params lam_is_var - && Ext_list.length_larger_than_n inner_args args 1 -> - Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply ap_func - (Ext_list.append_one ap_args x) - { - ap_loc = outer_loc; - ap_inlined = ap_info.ap_inlined; - ap_status = App_na; - } - | _ -> - Lam.apply f [ x ] - { - ap_loc = outer_loc; - ap_inlined = Default_inline; - ap_status = App_na; - } - and convert_switch (e : Lambda.lambda) (s : Lambda.lambda_switch) = - let e = convert_aux e in - match s with - | { - sw_failaction = None; - sw_blocks = []; - sw_numblocks = 0; - sw_consts; - sw_numconsts; - sw_names; - } -> ( - match happens_to_be_diff sw_consts sw_names with - | Some 0 -> e - | Some i -> - prim ~primitive:Paddint - ~args: - [ - e; - Lam.const (Const_int { i = Int32.of_int i; comment = None }); - ] - Location.none - | _ -> - Lam.switch e - { - sw_failaction = None; - sw_blocks = []; - sw_blocks_full = true; - sw_consts = Ext_list.map_snd sw_consts convert_aux; - sw_consts_full = Ext_list.length_ge sw_consts sw_numconsts; - sw_names = s.sw_names; - }) - | _ -> - Lam.switch e - { - sw_consts_full = Ext_list.length_ge s.sw_consts s.sw_numconsts; - sw_consts = Ext_list.map_snd s.sw_consts convert_aux; - sw_blocks_full = Ext_list.length_ge s.sw_blocks s.sw_numblocks; - sw_blocks = Ext_list.map_snd s.sw_blocks convert_aux; - sw_failaction = Ext_option.map s.sw_failaction convert_aux; - sw_names = s.sw_names; - } - in - (convert_aux lam, may_depends) - -(** FIXME: more precise analysis of [id], if it is not - used, we can remove it - only two places emit [Lifused], - {[ - lsequence (Lifused(id, set_inst_var obj id expr)) rem - Lifused (env2, Lprim(Parrayset Paddrarray, [Lvar self; Lvar env2; Lvar env1'])) - ]} - - Note the variable, [id], or [env2] is already defined, it can be removed if it is not - used. This optimization seems useful, but doesnt really matter since it only hit translclass - - more details, see [translclass] and [if_used_test] - seems to be an optimization trick for [translclass] - - | Lifused(v, l) -> - if count_var v > 0 then simplif l else lambda_unit -*) - -(* - | Lfunction(kind,params,Lprim(prim,inner_args,inner_loc)) - when List.for_all2_no_exn (fun x y -> - match y with - | Lambda.Lvar y when Ident.same x y -> true - | _ -> false - ) params inner_args - -> - let rec aux outer_args params = - match outer_args, params with - | x::xs , _::ys -> - x :: aux xs ys - | [], [] -> [] - | x::xs, [] -> - | [], y::ys - if Ext_list.same_length inner_args args then - aux (Lprim(prim,args,inner_loc)) - else - - {[ - (fun x y -> f x y) (computation;e) --> - (fun y -> f (computation;e) y) - ]} - is wrong - - or - {[ - (fun x y -> f x y ) ([|1;2;3|]) --> - (fun y -> f [|1;2;3|] y) - ]} - is also wrong. - - It seems, we need handle [@variadic] earlier - - or - {[ - (fun x y -> f x y) ([|1;2;3|]) --> - let x0, x1, x2 =1,2,3 in - (fun y -> f [|x0;x1;x2|] y) - ]} - But this still need us to know [@variadic] in advance - - - we should not remove it immediately, since we have to be careful - where it is used, it can be [exported], [Lvar] or [Lassign] etc - The other common mistake is that - {[ - let x = y (* elimiated x/y*) - let u = x (* eliminated u/x *) - ]} - - however, [x] is already eliminated - To improve the algorithm - {[ - let x = y (* x/y *) - let u = x (* u/y *) - ]} - This looks more correct, but lets be conservative here - - global module inclusion {[ include List ]} - will cause code like {[ let include =a Lglobal_module (list)]} - - when [u] is global, it can not be bound again, - it should always be the leaf -*) diff --git a/jscomp/core/lam_convert.mli b/jscomp/core/lam_convert.mli deleted file mode 100644 index 2ff227f..0000000 --- a/jscomp/core/lam_convert.mli +++ /dev/null @@ -1,50 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* val happens_to_be_diff: - (int * Lambda.lambda) list -> int option *) - -val convert : - Set_ident.t -> Lambda.lambda -> Lam.t * Lam_module_ident.Hash_set.t -(** - [convert exports lam] - it also collect [exit_map] and a collection of potential depended modules [may_depends] - In this pass we also synchronized aliases so that - {[ - let a1 = a0 in - let a2 = a1 in - let a3 = a2 in - let a4 = a3 in - ]} - converted to - {[ - let a1 = a0 in - let a2 = a0 in - let a3 = a0 in - let a4 = a0 in - ]} - we dont eliminate unused let bindings to leave it for {!Lam_pass_lets_dce} - we should remove all those let aliases, otherwise, it will be - pushed into alias table again -*) diff --git a/jscomp/core/lam_dce.ml b/jscomp/core/lam_dce.ml deleted file mode 100644 index a51cabb..0000000 --- a/jscomp/core/lam_dce.ml +++ /dev/null @@ -1,78 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let transitive_closure (initial_idents : Ident.t list) - (ident_freevars : Set_ident.t Hash_ident.t) = - let visited = Hash_set_ident.create 31 in - let rec dfs (id : Ident.t) : unit = - if not (Hash_set_ident.mem visited id || Ext_ident.is_js_or_global id) then ( - Hash_set_ident.add visited id; - match Hash_ident.find_opt ident_freevars id with - | None -> - Ext_fmt.failwithf ~loc:__LOC__ "%s/%d not found" (Ident.name id) - id.stamp - | Some e -> Set_ident.iter e dfs) - in - Ext_list.iter initial_idents dfs; - visited - -let remove export_idents (rest : Lam_group.t list) : Lam_group.t list = - let ident_free_vars : _ Hash_ident.t = Hash_ident.create 17 in - (* calculate initial required idents, - at the same time, populate dependency set [ident_free_vars] - *) - let initial_idents = - Ext_list.fold_left rest export_idents (fun acc x -> - match x with - | Single (kind, id, lam) -> ( - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); - match kind with - | Alias | StrictOpt -> acc - | Strict | Variable -> id :: acc) - | Recursive bindings -> - Ext_list.fold_left bindings acc (fun acc (id, lam) -> - Hash_ident.add ident_free_vars id - (Lam_free_variables.pass_free_variables lam); - match lam with Lfunction _ -> acc | _ -> id :: acc) - | Nop lam -> - if Lam_analysis.no_side_effects lam then acc - else - (* its free varaibles here will be defined above *) - Set_ident.fold (Lam_free_variables.pass_free_variables lam) acc - (fun x acc -> x :: acc)) - in - let visited = transitive_closure initial_idents ident_free_vars in - Ext_list.fold_left rest [] (fun acc x -> - match x with - | Single (_, id, _) -> - if Hash_set_ident.mem visited id then x :: acc else acc - | Nop _ -> x :: acc - | Recursive bindings -> ( - let b = - Ext_list.fold_right bindings [] (fun ((id, _) as v) acc -> - if Hash_set_ident.mem visited id then v :: acc else acc) - in - match b with [] -> acc | _ -> Recursive b :: acc)) - |> List.rev diff --git a/jscomp/core/lam_dce.mli b/jscomp/core/lam_dce.mli deleted file mode 100644 index 864a3d8..0000000 --- a/jscomp/core/lam_dce.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Dead code eliminatiion on the lambda layer -*) - -val remove : Ident.t list -> Lam_group.t list -> Lam_group.t list diff --git a/jscomp/core/lam_dispatch_primitive.ml b/jscomp/core/lam_dispatch_primitive.ml deleted file mode 100644 index 8f78237..0000000 --- a/jscomp/core/lam_dispatch_primitive.ml +++ /dev/null @@ -1,275 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module E = Js_exp_make -(* module S = Js_stmt_make *) - -(** - There are two things we need consider: - 1. For some primitives we can replace caml-primitive with js primitives directly - 2. For some standard library functions, we prefer to replace with javascript primitives - For example [Pervasives["^"] -> ^] - We can collect all mli files in OCaml and replace it with an efficient javascript runtime - - TODO: return type to be expression is ugly, - we should allow return block -*) -let translate loc (prim_name : string) (args : J.expression list) : J.expression - = - let[@inline] call ?name m = - let name = - match name with - | None -> - if prim_name.[0] = '?' then - String.sub prim_name 1 (String.length prim_name - 1) - else if Ext_string.starts_with prim_name "caml_" then - String.sub prim_name 5 (String.length prim_name - 5) - else assert false (* prim_name *) - | Some x -> x - in - E.runtime_call m name args - in - match prim_name with - | "caml_notequal" -> ( - match args with - | [ a1; b1 ] - when E.for_sure_js_null_undefined a1 || E.for_sure_js_null_undefined b1 - -> - E.neq_null_undefined_boolean a1 b1 - (* FIXME address_equal *) - | _ -> - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; - call Js_runtime_modules.obj_runtime) - | "caml_equal" -> ( - match args with - | [ a1; b1 ] - when E.for_sure_js_null_undefined a1 || E.for_sure_js_null_undefined b1 - -> - E.eq_null_undefined_boolean a1 b1 - (* FIXME address_equal *) - | _ -> - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; - call Js_runtime_modules.obj_runtime) - | "caml_min" | "caml_max" | "caml_compare" | "caml_greaterequal" - | "caml_greaterthan" | "caml_lessequal" | "caml_lessthan" | "caml_equal_null" - | "caml_equal_undefined" | "caml_equal_nullable" -> - Location.prerr_warning loc Warnings.Bs_polymorphic_comparison; - call Js_runtime_modules.obj_runtime - (* generated by the compiler, not user facing *) - | "caml_bytes_greaterthan" | "caml_bytes_greaterequal" | "caml_bytes_lessthan" - | "caml_bytes_lessequal" | "caml_bytes_compare" | "caml_bytes_equal" -> - call Js_runtime_modules.bytes - | "caml_string_equal" -> ( - match args with [ e0; e1 ] -> E.string_equal e0 e1 | _ -> assert false) - | "caml_string_notequal" -> ( - match args with - | [ e0; e1 ] -> E.string_comp NotEqEq e0 e1 - (* TODO: convert to ocaml ones*) - | _ -> assert false) - | "caml_string_lessequal" -> ( - match args with [ e0; e1 ] -> E.string_comp Le e0 e1 | _ -> assert false) - | "caml_string_lessthan" -> ( - match args with [ e0; e1 ] -> E.string_comp Lt e0 e1 | _ -> assert false) - | "caml_string_greaterequal" -> ( - match args with [ e0; e1 ] -> E.string_comp Ge e0 e1 | _ -> assert false) - | "caml_int64_equal_null" -> Js_long.equal_null args - | "caml_int64_equal_undefined" -> Js_long.equal_undefined args - | "caml_int64_equal_nullable" -> Js_long.equal_nullable args - | "caml_int64_min" -> Js_long.min args - | "caml_int64_max" -> Js_long.max args - | "caml_int64_compare" -> Js_long.compare args - | "caml_string_greaterthan" -> ( - match args with [ e0; e1 ] -> E.string_comp Gt e0 e1 | _ -> assert false) - | "caml_bool_notequal" -> ( - match args with - | [ e0; e1 ] -> E.bool_comp Cneq e0 e1 - (* TODO: specialized in OCaml ones*) - | _ -> assert false) - | "caml_bool_lessequal" -> ( - match args with [ e0; e1 ] -> E.bool_comp Cle e0 e1 | _ -> assert false) - | "caml_bool_lessthan" -> ( - match args with [ e0; e1 ] -> E.bool_comp Clt e0 e1 | _ -> assert false) - | "caml_bool_greaterequal" -> ( - match args with [ e0; e1 ] -> E.bool_comp Cge e0 e1 | _ -> assert false) - | "caml_bool_greaterthan" -> ( - match args with [ e0; e1 ] -> E.bool_comp Cgt e0 e1 | _ -> assert false) - | "caml_bool_equal" | "caml_bool_equal_null" | "caml_bool_equal_nullable" - | "caml_bool_equal_undefined" -> ( - match args with [ e0; e1 ] -> E.bool_comp Ceq e0 e1 | _ -> assert false) - | "caml_int_equal_null" | "caml_int_equal_nullable" - | "caml_int_equal_undefined" -> ( - match args with [ e0; e1 ] -> E.int_comp Ceq e0 e1 | _ -> assert false) - | "caml_float_equal_null" | "caml_float_equal_nullable" - | "caml_float_equal_undefined" -> ( - match args with [ e0; e1 ] -> E.float_comp Ceq e0 e1 | _ -> assert false) - | "caml_bigint_equal_null" | "caml_bigint_equal_nullable" - | "caml_bigint_equal_undefined" -> ( - match args with [ e0; e1 ] -> E.bigint_comp Ceq e0 e1 | _ -> assert false) - | "caml_string_equal_null" | "caml_string_equal_nullable" - | "caml_string_equal_undefined" -> ( - match args with - | [ e0; e1 ] -> E.string_comp EqEqEq e0 e1 - | _ -> assert false) - | "caml_bool_compare" -> ( - match args with - | [ { expression_desc = Bool a }; { expression_desc = Bool b } ] -> - let c = compare (a : bool) b in - E.int (if c = 0 then 0l else if c > 0 then 1l else -1l) - | _ -> call Js_runtime_modules.caml_primitive) - | "caml_int_compare" -> - E.runtime_call Js_runtime_modules.caml_primitive "int_compare" args - | "caml_float_compare" -> call Js_runtime_modules.caml_primitive - | "caml_bigint_compare" -> call Js_runtime_modules.caml_primitive - | "caml_string_compare" -> call Js_runtime_modules.caml_primitive - | "caml_bool_min" | "caml_int_min" | "caml_float_min" | "caml_bigint_min" | "caml_string_min" -> ( - match args with - | [ a; b ] -> - if - Js_analyzer.is_okay_to_duplicate a - && Js_analyzer.is_okay_to_duplicate b - then E.econd (E.js_comp Clt a b) a b - else call Js_runtime_modules.caml_primitive - | _ -> assert false) - | "caml_bool_max" | "caml_int_max" | "caml_float_max" | "caml_bigint_max" | "caml_string_max" -> ( - match args with - | [ a; b ] -> - if - Js_analyzer.is_okay_to_duplicate a - && Js_analyzer.is_okay_to_duplicate b - then E.econd (E.js_comp Cgt a b) a b - else call Js_runtime_modules.caml_primitive - | _ -> assert false) - (******************************************************************************) - (************************* customized primitives ******************************) - (******************************************************************************) - | "?int_of_float" -> ( - match args with [ e ] -> E.to_int32 e | _ -> assert false) - | "?int64_succ" -> E.runtime_call Js_runtime_modules.int64 "succ" args - | "?int64_to_string" -> - E.runtime_call Js_runtime_modules.int64 "to_string" args - | "?int64_to_float" -> Js_long.to_float args - | "?int64_of_float" -> Js_long.of_float args - | "?int64_bits_of_float" -> Js_long.bits_of_float args - | "?int64_float_of_bits" -> Js_long.float_of_bits args - | "?int_float_of_bits" | "?int_bits_of_float" | "?modf_float" | "?ldexp_float" - | "?frexp_float" | "?copysign_float" | "?expm1_float" | "?hypot_float" -> - call Js_runtime_modules.float - | "?fmod_float" (* float module like js number module *) -> ( - match args with [ e0; e1 ] -> E.float_mod e0 e1 | _ -> assert false) - | "?string_repeat" -> ( - match args with - | [ n; { expression_desc = Number (Int { i }) } ] -> ( - let str = String.make 1 (Char.chr (Int32.to_int i)) in - match n.expression_desc with - | Number (Int { i = 1l }) -> E.str str - | _ -> - E.call - (E.dot (E.str str) "repeat") - [ n ] ~info:Js_call_info.builtin_runtime_call) - | _ -> E.runtime_call Js_runtime_modules.string "make" args) - | "?create_bytes" -> ( - (* Bytes.create *) - (* Note that for invalid range, JS raise an Exception RangeError, - here in OCaml it's [Invalid_argument], we have to preserve this semantics. - Also, it's creating a [bytes] which is a js array actually. - *) - match args with - | [ { expression_desc = Number (Int { i; _ }); _ } ] when i < 8l -> - (*Invariants: assuming bytes are [int array]*) - E.array NA - (if i = 0l then [] - else Ext_list.init (Int32.to_int i) (fun _ -> E.zero_int_literal)) - | _ -> E.runtime_call Js_runtime_modules.bytes "create" args) - (* Note we captured [exception/extension] creation in the early pass, this primitive is - like normal one to set the identifier *) - | "?exn_slot_name" | "?is_extension" -> call Js_runtime_modules.exceptions - | "?as_js_exn" -> call Js_runtime_modules.caml_js_exceptions - | "?sys_get_argv" | "?sys_file_exists" | "?sys_time" | "?sys_getenv" - | "?sys_getcwd" (* check browser or nodejs *) - | "?sys_is_directory" | "?sys_exit" -> - call Js_runtime_modules.sys - | "?lex_engine" | "?new_lex_engine" -> call Js_runtime_modules.lexer - | "?parse_engine" | "?set_parser_trace" -> call Js_runtime_modules.parser - | "?make_float_vect" - | "?floatarray_create" (* TODO: compile float array into TypedArray*) -> - E.runtime_call Js_runtime_modules.array "make_float" args - | "?array_sub" -> E.runtime_call Js_runtime_modules.array "sub" args - | "?array_concat" -> E.runtime_call Js_runtime_modules.array "concat" args - (*external concat: 'a array list -> 'a array - Not good for inline *) - | "?array_blit" -> E.runtime_call Js_runtime_modules.array "blit" args - | "?make_vect" -> E.runtime_call Js_runtime_modules.array "make" args - | "?format_float" | "?hexstring_of_float" | "?float_of_string" - | "?int_of_string" (* what is the semantics?*) - | "?int64_format" | "?int64_of_string" | "?format_int" -> - call Js_runtime_modules.format - | "?obj_dup" -> call Js_runtime_modules.obj_runtime - | "?obj_tag" -> ( - (* Note that in ocaml, [int] has tag [1000] and [string] has tag [252] - also now we need do nullary check - *) - match args with [ e ] -> E.tag e | _ -> assert false) - | "?md5_string" -> call Js_runtime_modules.md5 - | "?hash_mix_string" | "?hash_mix_int" | "?hash_final_mix" -> - call Js_runtime_modules.hash_primitive - | "?hash" -> call Js_runtime_modules.hash - | "?nativeint_add" -> ( - match args with - | [ e1; e2 ] -> E.unchecked_int32_add e1 e2 - | _ -> assert false) - | "?nativeint_div" -> ( - match args with - | [ e1; e2 ] -> E.int32_div e1 e2 ~checked:false - | _ -> assert false) - | "?nativeint_mod" -> ( - match args with - | [ e1; e2 ] -> E.int32_mod e1 e2 ~checked:false - | _ -> assert false) - | "?nativeint_lsr" -> ( - match args with [ e1; e2 ] -> E.int32_lsr e1 e2 | _ -> assert false) - | "?nativeint_mul" -> ( - match args with - | [ e1; e2 ] -> E.unchecked_int32_mul e1 e2 - | _ -> assert false) - | "?bigint_div" -> ( - match args with - | [ e1; e2 ] -> E.bigint_div e1 e2 ~checked:false - | _ -> assert false) - | "?bigint_mod" -> ( - match args with - | [ e1; e2 ] -> E.bigint_mod e1 e2 ~checked:false - | _ -> assert false) - | "?await" -> ( - match args with - | [e] -> {e with expression_desc = Await e} - | _ -> assert false - ) - | _ -> - Bs_warnings.warn_missing_primitive loc prim_name; - E.resolve_and_apply prim_name args -(*we dont use [throw] here, since [throw] is an statement - so we wrap in IIFE - TODO: we might provoide a hook for user to provide polyfill. - For example `Bs_global.xxx` -*) diff --git a/jscomp/core/lam_dispatch_primitive.mli b/jscomp/core/lam_dispatch_primitive.mli deleted file mode 100644 index 0908494..0000000 --- a/jscomp/core/lam_dispatch_primitive.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Compile lambda primitives (note this is different external c calls) *) - -val translate : Location.t -> string -> J.expression list -> J.expression -(** - @return None when the primitives are not handled in pre-processing -*) diff --git a/jscomp/core/lam_eta_conversion.ml b/jscomp/core/lam_eta_conversion.ml deleted file mode 100644 index 8f977b3..0000000 --- a/jscomp/core/lam_eta_conversion.ml +++ /dev/null @@ -1,304 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* - let f x y = x + y - Invariant: there is no currying - here since f's arity is 2, no side effect - f 3 --> function(y) -> f 3 y -*) - -(** - [transform n loc status fn args] - n is the number of missing arguments required for [fn]. - Return a function of airty [n] -*) -let transform_under_supply n ap_info fn args = - let extra_args = Ext_list.init n (fun _ -> Ident.create Literals.param) in - let extra_lambdas = Ext_list.map extra_args Lam.var in - match - Ext_list.fold_right (fn :: args) ([], []) (fun (lam : Lam.t) (acc, bind) -> - match lam with - | Lvar _ - | Lconst - ( Const_int _ | Const_char _ | Const_string _ | Const_float _ | Const_bigint _ - | Const_int64 _ | Const_pointer _ | Const_js_true | Const_js_false - | Const_js_undefined _ ) - | Lprim { primitive = Pfield (_, Fld_module _); _ } - | Lfunction _ -> - (lam :: acc, bind) - | _ -> - let v = Ident.create Literals.partial_arg in - (Lam.var v :: acc, (v, lam) :: bind)) - with - | fn :: args, [] -> - (* More than no side effect in the [args], - we try to avoid computation, so even if - [x + y] is side effect free, we need eval it only once - *) - (* TODO: Note we could adjust [fn] if [fn] is already a function - But it is dangerous to change the arity - of an existing function which may cause inconsistency - *) - Lam.function_ ~arity:n ~params:extra_args - ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - | fn :: args, bindings -> - let rest : Lam.t = - Lam.function_ ~arity:n ~params:extra_args - ~attr:Lambda.default_function_attribute - ~body:(Lam.apply fn (Ext_list.append args extra_lambdas) ap_info) - in - Ext_list.fold_left bindings rest (fun lam (id, x) -> - Lam.let_ Strict id x lam) - | _, _ -> assert false - -(* Invariant: mk0 : (unit -> 'a0) -> 'a0 t - TODO: this case should be optimized, - we need check where we handle [arity=0] - as a special case -- - if we do an optimization before compiling - into lambda - - {[Fn.mk0]} is not intended for use by normal users - - so we assume [Fn.mk0] is only used in such cases - {[ - Fn.mk0 (fun _ -> .. ) - ]} - when it is passed as a function directly -*) -(*TODO: can be optimized ? - {[\ x y -> (\u -> body x) x y]} - {[\u x -> body x]} - rewrite rules - {[ - \x -> body - -- - \y (\x -> body ) y - ]} - {[\ x y -> (\a b c -> g a b c) x y]} - {[ \a b -> \c -> g a b c ]} -*) - -(** Unsafe function, we are changing arity here, it should be applied - cautiously, since - [let u = f] and we are chaning the arity of [f] it will affect - the collection of [u] - A typical use case is to pass an OCaml function to JS side as a callback (i.e, [@uncurry]) -*) -let unsafe_adjust_to_arity loc ~(to_ : int) ?(from : int option) (fn : Lam.t) : - Lam.t = - let ap_info : Lam.ap_info = - { ap_loc = loc; ap_inlined = Default_inline; ap_status = App_na } - in - let is_async_fn = match fn with - | Lfunction { attr = {async}} -> async - | _ -> false in - match (from, fn) with - | Some from, _ | None, Lfunction { arity = from } -> ( - if from = to_ || is_async_fn then fn - else if to_ = 0 then - match fn with - | Lfunction { params = [ param ]; body } -> - Lam.function_ ~arity:0 ~attr:Lambda.default_function_attribute - ~params:[] - ~body:(Lam.let_ Alias param Lam.unit body) - (* could be only introduced by - {[ Pjs_fn_make 0 ]} <- - {[ fun [@bs] () -> .. ]} - *) - | _ -> ( - let wrapper, new_fn = - match fn with - | Lvar _ - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - (None, fn) - | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) - in - - let cont = - Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 - ~params:[] - ~body:(Lam.apply new_fn [ Lam.unit ] ap_info) - in - - match wrapper with - | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) - else if to_ > from then - match fn with - | Lfunction { params; body } -> - (* {[fun x -> f]} -> - {[ fun x y -> f y ]} - *) - let extra_args = - Ext_list.init (to_ - from) (fun _ -> Ident.create Literals.param) - in - let rec mk_apply body vars = match vars with - | [] -> body - | var :: vars -> - mk_apply (Lam.apply body [var] ap_info) vars in - Lam.function_ ~attr:Lambda.default_function_attribute ~arity:to_ - ~params:(Ext_list.append params extra_args) - ~body:(mk_apply body (Ext_list.map extra_args Lam.var)) - | _ -> ( - let arity = to_ in - let extra_args = - Ext_list.init to_ (fun _ -> Ident.create Literals.param) - in - let wrapper, new_fn = - match fn with - | Lvar _ - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - (None, fn) - | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) - in - let cont = - Lam.function_ ~arity ~attr:Lambda.default_function_attribute - ~params:extra_args - ~body: - (let first_args, rest_args = - Ext_list.split_at extra_args from - in - Lam.apply - (Lam.apply new_fn - (Ext_list.map first_args Lam.var) - { ap_info with ap_status = App_infer_full }) - (Ext_list.map rest_args Lam.var) - ap_info) - in - match wrapper with - | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont) - else - (* add3 --adjust to arity 1 -> - fun x -> (fun y z -> add3 x y z ) - - [fun x y z -> f x y z ] - [fun x -> [fun y z -> f x y z ]] - This is okay if the function is not held by other.. - *) - match fn with - | Lfunction { params; body } - (* TODO check arity = List.length params in debug mode *) -> - let arity = to_ in - let extra_outer_args, extra_inner_args = - Ext_list.split_at params arity - in - Lam.function_ ~arity ~attr:Lambda.default_function_attribute - ~params:extra_outer_args - ~body: - (Lam.function_ ~arity:(from - to_) - ~attr:Lambda.default_function_attribute - ~params:extra_inner_args ~body) - | _ -> ( - let extra_outer_args = - Ext_list.init to_ (fun _ -> Ident.create Literals.param) - in - let wrapper, new_fn = - match fn with - | Lvar _ - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - (None, fn) - | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) - in - let cont = - Lam.function_ ~arity:to_ ~params:extra_outer_args - ~attr:Lambda.default_function_attribute - ~body: - (let arity = from - to_ in - let extra_inner_args = - Ext_list.init arity (fun _ -> Ident.create Literals.param) - in - Lam.function_ ~arity ~params:extra_inner_args - ~attr:Lambda.default_function_attribute - ~body: - (Lam.apply new_fn - (Ext_list.map_append extra_outer_args - (Ext_list.map extra_inner_args Lam.var) - Lam.var) - { ap_info with ap_status = App_infer_full })) - in - match wrapper with - | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont)) - | None, _ -> - (* In this case [fn] is not [Lfunction], otherwise we would get [arity] *) - if to_ = 0 then - let wrapper, new_fn = - match fn with - | Lvar _ - | Lprim - { - primitive = Pfield (_, Fld_module _); - args = [ (Lglobal_module _ | Lvar _) ]; - _; - } -> - (None, fn) - | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - (Some partial_arg, Lam.var partial_arg) - in - - let cont = - Lam.function_ ~attr:Lambda.default_function_attribute ~arity:0 - ~params:[] - ~body:(Lam.apply new_fn [ Lam.unit ] ap_info) - in - - match wrapper with - | None -> cont - | Some partial_arg -> Lam.let_ Strict partial_arg fn cont - else transform_under_supply to_ ap_info fn [] - -(* | _ -> - let partial_arg = Ext_ident.create Literals.partial_arg in - Lam.let_ Strict partial_arg fn - (let arity = to_ in - let extra_args = Ext_list.init arity (fun _ -> Ident.create Literals.param) in - Lam.function_ ~arity ~kind:Curried ~params:extra_args - ~body:(Lam.apply fn (Ext_list.map Lam.var extra_args ) loc Lam.App_na ) - ) *) diff --git a/jscomp/core/lam_eta_conversion.mli b/jscomp/core/lam_eta_conversion.mli deleted file mode 100644 index 2b8da1e..0000000 --- a/jscomp/core/lam_eta_conversion.mli +++ /dev/null @@ -1,34 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - [transform n loc status fn args] - n is the number of missing arguments required for [fn]. - Return a function of airty [n] -*) - -val transform_under_supply : int -> Lam.ap_info -> Lam.t -> Lam.t list -> Lam.t - -val unsafe_adjust_to_arity : - Location.t -> to_:int -> ?from:int -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_exit_code.ml b/jscomp/core/lam_exit_code.ml deleted file mode 100644 index 3f42e34..0000000 --- a/jscomp/core/lam_exit_code.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let has_exit_code lam exits = - let rec aux (lam : Lam.t) = - match lam with - | Lfunction _ -> false - (* static exit can not cross function boundary *) - | Lstaticraise (p, _) when exits p -> true - | _ -> Lam_iter.inner_exists lam aux - in - aux lam - -let rec has_exit (lam : Lam.t) = - match lam with - | Lfunction _ -> false - | Lstaticraise (_, _) -> true - | _ -> Lam_iter.inner_exists lam has_exit diff --git a/jscomp/core/lam_exit_code.mli b/jscomp/core/lam_exit_code.mli deleted file mode 100644 index bd89d41..0000000 --- a/jscomp/core/lam_exit_code.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val has_exit_code : Lam.t -> (int -> bool) -> bool - -val has_exit : Lam.t -> bool diff --git a/jscomp/core/lam_exit_count.ml b/jscomp/core/lam_exit_count.ml deleted file mode 100644 index 10bee18..0000000 --- a/jscomp/core/lam_exit_count.ml +++ /dev/null @@ -1,110 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type collection = int Hash_int.t - -(* Count occurrences of (exit n ...) statements *) -let count_exit (exits : collection) i = Hash_int.find_default exits i 0 - -let incr_exit (exits : collection) i = - Hash_int.add_or_update exits i 1 ~update:succ - -(** - This funcition counts how each [exit] is used, it will affect how the following optimizations performed. - - Some smart cases (this requires the following optimizations follow it): - - {[ - Lstaticcatch(l1, (i,_), l2) - ]} - If [l1] does not contain [(exit i)], - [l2] will be removed, so don't count it. - - About Switch default branch handling, it maybe backend-specific - See https://github.com/ocaml/ocaml/commit/fcf3571123e2c914768e34f1bd17e4cbaaa7d212#diff-704f66c0fa0fc9339230b39ce7d90919 - For Lstringswitch ^ - - For Lswitch, if it is not exhuastive pattern match, default will be counted twice. - Since for pattern match, we will test whether it is an integer or block, both have default cases predicate: [sw_consts_full] vs nconsts -*) -let count_helper (lam : Lam.t) : collection = - let exits : collection = Hash_int.create 17 in - let rec count (lam : Lam.t) = - match lam with - | Lstaticraise (i, ls) -> - incr_exit exits i; - Ext_list.iter ls count - | Lstaticcatch (l1, (i, _), l2) -> - count l1; - if count_exit exits i > 0 then count l2 - | Lstringswitch (l, sw, d) -> - count l; - Ext_list.iter_snd sw count; - Ext_option.iter d count - | Lglobal_module _ | Lvar _ | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - count ap_func; - Ext_list.iter ap_args count - | Lfunction { body } -> count body - | Llet (_, _, l1, l2) -> - count l2; - count l1 - | Lletrec (bindings, body) -> - Ext_list.iter_snd bindings count; - count body - | Lprim { args; _ } -> List.iter count args - | Lswitch (l, sw) -> - count_default sw; - count l; - Ext_list.iter_snd sw.sw_consts count; - Ext_list.iter_snd sw.sw_blocks count - | Ltrywith (l1, _v, l2) -> - count l1; - count l2 - | Lifthenelse (l1, l2, l3) -> - count l1; - count l2; - count l3 - | Lsequence (l1, l2) -> - count l1; - count l2 - | Lwhile (l1, l2) -> - count l1; - count l2 - | Lfor (_, l1, l2, _dir, l3) -> - count l1; - count l2; - count l3 - | Lassign (_, l) -> count l - and count_default sw = - match sw.sw_failaction with - | None -> () - | Some al -> - if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( - count al; - count al) - else count al - in - count lam; - exits diff --git a/jscomp/core/lam_exit_count.mli b/jscomp/core/lam_exit_count.mli deleted file mode 100644 index 9a621cf..0000000 --- a/jscomp/core/lam_exit_count.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type collection - -val count_helper : Lam.t -> collection - -val count_exit : collection -> int -> int diff --git a/jscomp/core/lam_free_variables.ml b/jscomp/core/lam_free_variables.ml deleted file mode 100644 index f832848..0000000 --- a/jscomp/core/lam_free_variables.ml +++ /dev/null @@ -1,102 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let pass_free_variables (l : Lam.t) : Set_ident.t = - let fv = ref Set_ident.empty in - let rec free_list xs = List.iter free xs - and free_list_snd : 'a. ('a * Lam.t) list -> unit = - fun xs -> Ext_list.iter_snd xs free - and free (l : Lam.t) = - match l with - | Lvar id -> fv := Set_ident.add !fv id - | Lassign (id, e) -> - free e; - fv := Set_ident.add !fv id - | Lstaticcatch (e1, (_, vars), e2) -> - free e1; - free e2; - Ext_list.iter vars (fun id -> fv := Set_ident.remove !fv id) - | Ltrywith (e1, exn, e2) -> - free e1; - free e2; - fv := Set_ident.remove !fv exn - | Lfunction { body; params } -> - free body; - Ext_list.iter params (fun param -> fv := Set_ident.remove !fv param) - | Llet (_str, id, arg, body) -> - free arg; - free body; - fv := Set_ident.remove !fv id - | Lletrec (decl, body) -> - free body; - free_list_snd decl; - Ext_list.iter decl (fun (id, _exp) -> fv := Set_ident.remove !fv id) - | Lfor (v, e1, e2, _dir, e3) -> - free e1; - free e2; - free e3; - fv := Set_ident.remove !fv v - | Lconst _ -> () - | Lapply { ap_func; ap_args; _ } -> - free ap_func; - free_list ap_args - | Lglobal_module _ -> () - (* according to the existing semantics: - [primitive] is not counted - *) - | Lprim { args; _ } -> free_list args - | Lswitch (arg, sw) -> - free arg; - free_list_snd sw.sw_consts; - free_list_snd sw.sw_blocks; - Ext_option.iter sw.sw_failaction free - | Lstringswitch (arg, cases, default) -> - free arg; - free_list_snd cases; - Ext_option.iter default free - | Lstaticraise (_, args) -> free_list args - | Lifthenelse (e1, e2, e3) -> - free e1; - free e2; - free e3 - | Lsequence (e1, e2) -> - free e1; - free e2 - | Lwhile (e1, e2) -> - free e1; - free e2 - in - free l; - !fv - -(** - [hit_any_variables fv l] - check the lambda expression [l] if has some free - variables captured by [fv]. - Note it does not do any checking like below - [Llet(str,id,arg,body)] - it only check [arg] or [body] is hit or not, there - is a case that [id] is hit in [arg] but also exists - in [fv], this is ignored. -*) diff --git a/jscomp/core/lam_free_variables.mli b/jscomp/core/lam_free_variables.mli deleted file mode 100644 index 4126b4b..0000000 --- a/jscomp/core/lam_free_variables.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val pass_free_variables : Lam.t -> Set_ident.t diff --git a/jscomp/core/lam_group.ml b/jscomp/core/lam_group.ml deleted file mode 100644 index 58b24f9..0000000 --- a/jscomp/core/lam_group.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** This is not a recursive type definition *) -type t = - | Single of Lam_compat.let_kind * Ident.t * Lam.t - | Recursive of (Ident.t * Lam.t) list - | Nop of Lam.t - -let single (kind : Lam_compat.let_kind) id (body : Lam.t) = - match (kind, body) with - | (Strict | StrictOpt), (Lvar _ | Lconst _) -> Single (Alias, id, body) - | _ -> Single (kind, id, body) - -let nop_cons (x : Lam.t) acc = - match x with Lvar _ | Lconst _ | Lfunction _ -> acc | _ -> Nop x :: acc - -(* let pp = Format.fprintf *) - -let str_of_kind (kind : Lam_compat.let_kind) = - match kind with - | Alias -> "a" - | Strict -> "" - | StrictOpt -> "o" - | Variable -> "v" - -let pp_group fmt (x : t) = - match x with - | Single (kind, id, lam) -> - Format.fprintf fmt "@[let@ %a@ =%s@ @[%a@]@ @]" Ident.print id - (str_of_kind kind) Lam_print.lambda lam - | Recursive lst -> - List.iter - (fun (id, lam) -> - Format.fprintf fmt "@[let %a@ =r@ %a@ @]" Ident.print id - Lam_print.lambda lam) - lst - | Nop lam -> Lam_print.lambda fmt lam diff --git a/jscomp/core/lam_group.mli b/jscomp/core/lam_group.mli deleted file mode 100644 index c6325ac..0000000 --- a/jscomp/core/lam_group.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = - | Single of Lam_compat.let_kind * Ident.t * Lam.t - | Recursive of (Ident.t * Lam.t) list - | Nop of Lam.t - -(** Tricky to be complete *) - -val pp_group : Format.formatter -> t -> unit - -val single : Lam_compat.let_kind -> Ident.t -> Lam.t -> t - -val nop_cons : Lam.t -> t list -> t list diff --git a/jscomp/core/lam_group_pass.ml b/jscomp/core/lam_group_pass.ml deleted file mode 100644 index e4fbf62..0000000 --- a/jscomp/core/lam_group_pass.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(*type bindings = (Ident.t * Lam.t) list - let scc (groups : bindings) - (lam : Lam.t) - (body : Lam.t) - (cont : bindings -> Lam.t-> Lam.t) = - let domain = Ordered_hash_map.create 3 in - List.iter (fun (x,lam) -> Ordered_hash_map.add domain x lam) groups ; - let int_mapping = Ordered_hash_map.to_sorted_array domain in - let node_vec = Array.make (Array.length int_mapping) (Vec_int.empty ()) in - Ordered_hash_map.iter ( fun id lam key_index -> - let base_key = node_vec.(key_index) in - let free_vars = Lam_util.free_variables lam in - Set_ident.iter (fun x -> - let key = Ordered_hash_map.find domain x in - if key >= 0 then - Vec_int.push key base_key - ) free_vars - ) domain; - let clusters = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then lam - else - Int_vec_vec.fold_right (fun (v : Vec_int.t) acc -> - cont (Vec_int.map_into_list (fun i -> - let id = int_mapping.(i) in - let lam = Ordered_hash_map.find_value domain id in - (id,lam) - ) v ) acc - ) clusters body -*) - -let rec scc_pass (lam : Lam.t) = - let lam = Lam.inner_map lam scc_pass in - match lam with - | Lletrec (bindings, body) -> Lam_scc.scc bindings lam body - | _ -> lam diff --git a/jscomp/core/lam_hit.ml b/jscomp/core/lam_hit.ml deleted file mode 100644 index 032fb32..0000000 --- a/jscomp/core/lam_hit.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* Copyright (C) 2015 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Lam.t - -let hit_variables (fv : Set_ident.t) (l : t) : bool = - let rec hit_opt (x : t option) = - match x with None -> false | Some a -> hit a - and hit_var (id : Ident.t) = Set_ident.mem fv id - and hit_list_snd : 'a. ('a * t) list -> bool = - fun x -> Ext_list.exists_snd x hit - and hit_list xs = Ext_list.exists xs hit - and hit (l : t) = - match (l : t) with - | Lvar id -> hit_var id - | Lassign (id, e) -> hit_var id || hit e - | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body - | Lletrec (decl, body) -> hit body || hit_list_snd decl - | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 - | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args - | Lglobal_module _ (* global persistent module, play safe *) -> false - | Lprim { args; _ } -> hit_list args - | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default - | Lstaticraise (_, args) -> hit_list args - | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 - | Lsequence (e1, e2) -> hit e1 || hit e2 - | Lwhile (e1, e2) -> hit e1 || hit e2 - in - hit l - -let hit_variable (fv : Ident.t) (l : t) : bool = - let rec hit_opt (x : t option) = - match x with None -> false | Some a -> hit a - and hit_var (id : Ident.t) = Ident.same id fv - and hit_list_snd : 'a. ('a * t) list -> bool = - fun x -> Ext_list.exists_snd x hit - and hit_list xs = Ext_list.exists xs hit - and hit (l : t) = - match (l : t) with - | Lvar id -> hit_var id - | Lassign (id, e) -> hit_var id || hit e - | Lstaticcatch (e1, (_, _vars), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body - | Lletrec (decl, body) -> hit body || hit_list_snd decl - | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 - | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args - | Lglobal_module _ (* global persistent module, play safe *) -> false - | Lprim { args; _ } -> hit_list args - | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default - | Lstaticraise (_, args) -> hit_list args - | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 - | Lsequence (e1, e2) -> hit e1 || hit e2 - | Lwhile (e1, e2) -> hit e1 || hit e2 - in - hit l diff --git a/jscomp/core/lam_hit.mli b/jscomp/core/lam_hit.mli deleted file mode 100644 index be3199e..0000000 --- a/jscomp/core/lam_hit.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val hit_variables : Set_ident.t -> Lam.t -> bool - -val hit_variable : Ident.t -> Lam.t -> bool diff --git a/jscomp/core/lam_id_kind.ml b/jscomp/core/lam_id_kind.ml deleted file mode 100644 index 4a74ffb..0000000 --- a/jscomp/core/lam_id_kind.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* Copyright (C) Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Keep track of which identifiers are aliased -*) - -type rec_flag = Lam_rec | Lam_non_rec | Lam_self_rec -(* only a - single mutual - recursive function -*) - -type element = NA | SimpleForm of Lam.t - -type boxed_nullable = Undefined | Null | Null_undefined - -type t = - | Normal_optional of Lam.t (* Some [x] *) - | OptionalBlock of Lam.t * boxed_nullable - | ImmutableBlock of element array - | MutableBlock of element array - | Constant of Lam_constant.t - | Module of Ident.t (** TODO: static module vs first class module *) - | FunctionId of { - mutable arity : Lam_arity.t; - (* TODO: This may contain some closure environment, - check how it will interact with dead code elimination - *) - lambda : (Lam.t * rec_flag) option; - } - | Exception - | Parameter - (** For this case, it can help us determine whether it should be inlined or not *) - | NA - (** Not such information is associated with an identifier, it is immutable, - if you only associate a property to an identifier - we should consider [Lassign] - *) - -let pp = Format.fprintf - -let print fmt (kind : t) = - match kind with - | ImmutableBlock arr -> pp fmt "Imm(%d)" (Array.length arr) - | Normal_optional _ -> pp fmt "Some" - | OptionalBlock (_, Null) -> pp fmt "?Null" - | OptionalBlock (_, Undefined) -> pp fmt "?Undefined" - | OptionalBlock (_, Null_undefined) -> pp fmt "?Nullable" - | MutableBlock arr -> pp fmt "Mutable(%d)" (Array.length arr) - | Constant _ -> pp fmt "Constant" - | Module id -> pp fmt "%s/%d" id.name id.stamp - | FunctionId _ -> pp fmt "FunctionID" - | Exception -> pp fmt "Exception" - | Parameter -> pp fmt "Parameter" - | NA -> pp fmt "NA" diff --git a/jscomp/core/lam_id_kind.mli b/jscomp/core/lam_id_kind.mli deleted file mode 100644 index 0709a53..0000000 --- a/jscomp/core/lam_id_kind.mli +++ /dev/null @@ -1,70 +0,0 @@ -(* Copyright (C) Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type rec_flag = - | Lam_rec - | Lam_non_rec - (* TODO: This may contain some closure environment, - check how it will interact with dead code elimination - *) - | Lam_self_rec -(* not inlining in this case *) - -type element = NA | SimpleForm of Lam.t - -type boxed_nullable = Undefined | Null | Null_undefined - -(** - {[ let v/2 = Pnull_to_opt u]} - - {[ let v/2 = Pnull_to_opt exp]} - can be translated into - {[ - let v/1 = exp in - let v/2 =a Pnull_to_opt exp - ]} - so that [Pfield v/2 0] will be replaced by [v/1], - [Lif(v/1)] will be translated into [Lif (v/2 === undefined )] -*) -type t = - | Normal_optional of Lam.t - | OptionalBlock of Lam.t * boxed_nullable - | ImmutableBlock of element array - | MutableBlock of element array - | Constant of Lam_constant.t - | Module of Ident.t (** TODO: static module vs first class module *) - | FunctionId of { - mutable arity : Lam_arity.t; - lambda : (Lam.t * rec_flag) option; - } - | Exception - | Parameter - (** For this case, it can help us determine whether it should be inlined or not *) - | NA - (** Not such information is associated with an identifier, it is immutable, - if you only associate a property to an identifier - we should consider [Lassign] - *) - -val print : Format.formatter -> t -> unit diff --git a/jscomp/core/lam_iter.ml b/jscomp/core/lam_iter.ml deleted file mode 100644 index 56632a1..0000000 --- a/jscomp/core/lam_iter.ml +++ /dev/null @@ -1,115 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Lam.t - -type ident = Ident.t - -let inner_iter (l : t) (f : t -> unit) : unit = - match l with - | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> () - | Lapply { ap_func; ap_args; ap_info = _ } -> - f ap_func; - List.iter f ap_args - | Lfunction { body; arity = _; params = _ } -> f body - | Llet (_str, _id, arg, body) -> - f arg; - f body - | Lletrec (decl, body) -> - f body; - Ext_list.iter_snd decl f - | Lswitch - ( arg, - { - sw_consts; - sw_consts_full = _; - sw_blocks; - sw_blocks_full = _; - sw_failaction; - } ) -> - f arg; - Ext_list.iter_snd sw_consts f; - Ext_list.iter_snd sw_blocks f; - Ext_option.iter sw_failaction f - | Lstringswitch (arg, cases, default) -> - f arg; - Ext_list.iter_snd cases f; - Ext_option.iter default f - | Lglobal_module _ -> () - | Lprim { args; primitive = _; loc = _ } -> List.iter f args - | Lstaticraise (_id, args) -> List.iter f args - | Lstaticcatch (e1, _vars, e2) -> - f e1; - f e2 - | Ltrywith (e1, _exn, e2) -> - f e1; - f e2 - | Lifthenelse (e1, e2, e3) -> - f e1; - f e2; - f e3 - | Lsequence (e1, e2) -> - f e1; - f e2 - | Lwhile (e1, e2) -> - f e1; - f e2 - | Lfor (_v, e1, e2, _dir, e3) -> - f e1; - f e2; - f e3 - | Lassign (_id, e) -> f e - -let inner_exists (l : t) (f : t -> bool) : bool = - match l with - | Lvar (_ : ident) | Lglobal_module _ | Lconst (_ : Lam_constant.t) -> false - | Lapply { ap_func; ap_args; ap_info = _ } -> - f ap_func || Ext_list.exists ap_args f - | Lfunction { body; arity = _; params = _ } -> f body - | Llet (_str, _id, arg, body) -> f arg || f body - | Lletrec (decl, body) -> f body || Ext_list.exists_snd decl f - | Lswitch - ( arg, - { - sw_consts; - sw_consts_full = _; - sw_blocks; - sw_blocks_full = _; - sw_failaction; - } ) -> - f arg - || Ext_list.exists_snd sw_consts f - || Ext_list.exists_snd sw_blocks f - || Ext_option.exists sw_failaction f - | Lstringswitch (arg, cases, default) -> - f arg || Ext_list.exists_snd cases f || Ext_option.exists default f - | Lprim { args; primitive = _; loc = _ } -> Ext_list.exists args f - | Lstaticraise (_id, args) -> Ext_list.exists args f - | Lstaticcatch (e1, _vars, e2) -> f e1 || f e2 - | Ltrywith (e1, _exn, e2) -> f e1 || f e2 - | Lifthenelse (e1, e2, e3) -> f e1 || f e2 || f e3 - | Lsequence (e1, e2) -> f e1 || f e2 - | Lwhile (e1, e2) -> f e1 || f e2 - | Lfor (_v, e1, e2, _dir, e3) -> f e1 || f e2 || f e3 - | Lassign (_id, e) -> f e diff --git a/jscomp/core/lam_iter.mli b/jscomp/core/lam_iter.mli deleted file mode 100644 index fd52fcf..0000000 --- a/jscomp/core/lam_iter.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val inner_iter : Lam.t -> (Lam.t -> unit) -> unit - -val inner_exists : Lam.t -> (Lam.t -> bool) -> bool diff --git a/jscomp/core/lam_module_ident.ml b/jscomp/core/lam_module_ident.ml deleted file mode 100644 index 797258d..0000000 --- a/jscomp/core/lam_module_ident.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - - - -type t = J.module_id = - { id : Ident.t ; kind : Js_op.kind ; dynamic_import : bool } - - - -let id x = x.id - -let of_ml ?(dynamic_import = false) id = { id ; kind = Ml ; dynamic_import } - - -let of_runtime id = { id ; kind = Runtime ; dynamic_import = false } - -let name (x : t) : string = - match x.kind with - | Ml | Runtime -> x.id.name - | External {name = v} -> v - -module Cmp = struct - [@@@warning "+9"] - type nonrec t = t - let equal (x : t) y = - match x.kind with - | External {name = x_kind; default = x_default; _} -> - begin match y.kind with - | External {name = y_kind; default = y_default; _} -> - x_kind = (y_kind : string) && x_default = y_default - | _ -> false - end - | Ml - | Runtime -> Ext_ident.equal x.id y.id - (* #1556 - Note the main difference between [Ml] and [Runtime] is - that we have more assumptions about [Runtime] module, - like its purity etc, and its name uniqueues, in the pattern match - {[ - {Runtime, "caml_int_compare"} - ]} - and we could do more optimziations. - However, here if it is [hit] - (an Ml module = an Runtime module), which means both exists, - so adding either does not matter - if it is not hit, fine - *) - let hash (x : t) = - match x.kind with - | External {name = x_kind ; _} -> - (* The hash collision is rare? *) - Bs_hash_stubs.hash_string x_kind - | Ml - | Runtime -> - let x_id = x.id in - Bs_hash_stubs.hash_stamp_and_name x_id.stamp x_id.name -end - -module Hash = Hash.Make (Cmp) - -module Hash_set = Hash_set.Make (Cmp) - - diff --git a/jscomp/core/lam_module_ident.mli b/jscomp/core/lam_module_ident.mli deleted file mode 100644 index 24e117e..0000000 --- a/jscomp/core/lam_module_ident.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - - - - - -(** A type for qualified identifiers in Lambda IR -*) - - -type t = J.module_id = - (*private*) { - id : Ident.t ; - kind : Js_op.kind ; - dynamic_import : bool ; -} - - -val id : t -> Ident.t - -val name : t -> string - - - -val of_ml : ?dynamic_import:bool -> Ident.t -> t - - - -val of_runtime : Ident.t -> t - -module Hash : Hash_gen.S with type key = t -module Hash_set : Hash_set_gen.S with type key = t diff --git a/jscomp/core/lam_pass_alpha_conversion.ml b/jscomp/core/lam_pass_alpha_conversion.ml deleted file mode 100644 index aa1fd1b..0000000 --- a/jscomp/core/lam_pass_alpha_conversion.ml +++ /dev/null @@ -1,120 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populateApplyInfo (args_arity : int list) (len : int) (fn : Lam.t) - (args : Lam.t list) ap_info : Lam.t = - match args_arity with - | 0 :: _ | [] -> Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info - | x :: _ -> - if x = len then - Lam.apply (simpl fn) (Ext_list.map args simpl) - { ap_info with ap_status = App_infer_full } - else if x > len then - let fn = simpl fn in - let args = Ext_list.map args simpl in - Lam_eta_conversion.transform_under_supply (x - len) - { ap_info with ap_status = App_infer_full } - fn args - else - let first, rest = Ext_list.split_at args x in - Lam.apply - (Lam.apply (simpl fn) (Ext_list.map first simpl) - { ap_info with ap_status = App_infer_full }) - (Ext_list.map rest simpl) ap_info - (* TODO refien *) - and simpl (lam : Lam.t) = - match lam with - | Lconst _ -> lam - | Lvar _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - (* detect functor application *) - let args_arity = - Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) - in - let len = List.length ap_args in - populateApplyInfo args_arity len ap_func ap_args ap_info - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) - | Lglobal_module _ -> lam - | Lprim { primitive = Pjs_fn_make len as primitive; args = [ arg ]; loc } - -> ( - match - Lam_arity.get_first_arity (Lam_arity_analysis.get_arity meta arg) - with - | Some x -> - let arg = simpl arg in - Lam_eta_conversion.unsafe_adjust_to_arity loc ~to_:len ~from:x arg - | None -> Lam.prim ~primitive ~args:[ simpl arg ] loc) - | Lprim { primitive = Pjs_fn_make_unit; args = [ arg ]; loc } -> - let arg = match arg with - | Lfunction ({arity=1; params=[x]; attr; body}) when Ident.name x = "param" (* "()" *) -> - Lam.function_ ~params:[x] ~attr:{attr with oneUnitArg=true} ~body ~arity:1 - | _ -> arg in - simpl arg - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lfunction { arity; params; body; attr } -> - (* Lam_mk.lfunction kind params (simpl l) *) - Lam.function_ ~arity ~params ~body:(simpl body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) -> - Lam.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_names; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simpl l) - (Ext_list.map_snd sw simpl) - (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simpl l1) (simpl l2) (simpl l3) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) - in - - simpl lam diff --git a/jscomp/core/lam_pass_alpha_conversion.mli b/jscomp/core/lam_pass_alpha_conversion.mli deleted file mode 100644 index d32e343..0000000 --- a/jscomp/core/lam_pass_alpha_conversion.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** alpha conversion based on arity *) - -val alpha_conversion : Lam_stats.t -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_pass_collect.ml b/jscomp/core/lam_pass_collect.ml deleted file mode 100644 index b65825e..0000000 --- a/jscomp/core/lam_pass_collect.ml +++ /dev/null @@ -1,162 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Check, it is shared across ident_tbl, - Only [Lassign] will break such invariant, - how about guarantee that [Lassign] only check the local ref - and we track which ids are [Lassign]ed -*) -(** - might not be the same due to refinement - assert (old.arity = v) -*) -let annotate (meta : Lam_stats.t) rec_flag (k : Ident.t) (arity : Lam_arity.t) - lambda = - Hash_ident.add meta.ident_tbl k - (FunctionId { arity; lambda = Some (lambda, rec_flag) }) -(* see #3609 - we have to update since bounded function lambda - may contain stale unbounded varaibles -*) -(* match Hash_ident.find_opt meta.ident_tbl k with - | None -> (** FIXME: need do a sanity check of arity is NA or Determin(_,[],_) *) - - | Some (FunctionId old) -> - Hash_ident.add meta.ident_tbl k - (FunctionId {arity; lambda = Some (lambda, rec_flag) }) - (* old.arity <- arity *) - (* due to we keep refining arity analysis after each round*) - | _ -> assert false *) -(* TODO -- avoid exception *) - -(** it only make senses recording arities for - function definition, - alias propgation - and toplevel identifiers, this needs to be exported -*) -let collect_info (meta : Lam_stats.t) (lam : Lam.t) = - let rec collect_bind rec_flag (ident : Ident.t) (lam : Lam.t) = - match lam with - | Lconst v -> Hash_ident.replace meta.ident_tbl ident (Constant v) - | Lprim { primitive = Pmakeblock (_, _, Immutable); args = ls } -> - Hash_ident.replace meta.ident_tbl ident - (Lam_util.kind_of_lambda_block ls); - List.iter collect ls - | Lprim { primitive = Psome | Psome_not_nest; args = [ v ] } -> - Hash_ident.replace meta.ident_tbl ident (Normal_optional v); - collect v - | Lprim - { - primitive = Praw_js_code { code_info = Exp (Js_function { arity }) }; - args = _; - } -> - Hash_ident.replace meta.ident_tbl ident - (FunctionId { arity = Lam_arity.info [ arity ] false; lambda = None }) - | Lprim { primitive = Pnull_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Null)) - | Lprim { primitive = Pundefined_to_opt; args = [ (Lvar _ as l) ]; _ } -> - Hash_ident.replace meta.ident_tbl ident (OptionalBlock (l, Undefined)) - | Lprim { primitive = Pnull_undefined_to_opt; args = [ (Lvar _ as l) ] } -> - Hash_ident.replace meta.ident_tbl ident - (OptionalBlock (l, Null_undefined)) - | Lglobal_module (v, _) -> Lam_util.alias_ident_or_global meta ident v (Module v) - | Lvar v -> - (* if Ident.global v then *) - Lam_util.alias_ident_or_global meta ident v NA - (* enven for not subsitution, it still propogate some properties *) - (* else () *) - | Lfunction { params; body } - (* TODO record parameters ident ?, but it will be broken after inlining *) - -> - (* TODO could be optimized in one pass? - -- since collect would iter everywhere, - so -- it would still iterate internally - *) - Ext_list.iter params (fun p -> - Hash_ident.add meta.ident_tbl p Parameter); - let arity = Lam_arity_analysis.get_arity meta lam in - annotate meta rec_flag ident arity lam; - collect body - | x -> - collect x; - if Set_ident.mem meta.export_idents ident then - annotate meta rec_flag ident (Lam_arity_analysis.get_arity meta x) lam - and collect (lam : Lam.t) = - match lam with - | Lconst _ -> () - | Lvar _ -> () - | Lapply { ap_func = l1; ap_args = ll; _ } -> - collect l1; - List.iter collect ll - | Lfunction { params; body = l } -> - (* functor ? *) - List.iter (fun p -> Hash_ident.add meta.ident_tbl p Parameter) params; - collect l - | Llet (_kind, ident, arg, body) -> - collect_bind Lam_non_rec ident arg; - collect body - | Lletrec (bindings, body) -> - (match bindings with - | [ (ident, arg) ] -> collect_bind Lam_self_rec ident arg - | _ -> - Ext_list.iter bindings (fun (ident, arg) -> - collect_bind Lam_rec ident arg)); - collect body - | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter collect args - | Lswitch (l, { sw_failaction; sw_consts; sw_blocks }) -> - collect l; - Ext_list.iter_snd sw_consts collect; - Ext_list.iter_snd sw_blocks collect; - Ext_option.iter sw_failaction collect - | Lstringswitch (l, sw, d) -> - collect l; - Ext_list.iter_snd sw collect; - Ext_option.iter d collect - | Lstaticraise (_code, ls) -> List.iter collect ls - | Lstaticcatch (l1, (_, _), l2) -> - collect l1; - collect l2 - | Ltrywith (l1, _, l2) -> - collect l1; - collect l2 - | Lifthenelse (l1, l2, l3) -> - collect l1; - collect l2; - collect l3 - | Lsequence (l1, l2) -> - collect l1; - collect l2 - | Lwhile (l1, l2) -> - collect l1; - collect l2 - | Lfor (_, l1, l2, _dir, l3) -> - collect l1; - collect l2; - collect l3 - | Lassign (_v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refcollect *) - collect l - in - collect lam diff --git a/jscomp/core/lam_pass_collect.mli b/jscomp/core/lam_pass_collect.mli deleted file mode 100644 index 4f7c45c..0000000 --- a/jscomp/core/lam_pass_collect.mli +++ /dev/null @@ -1,72 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** This pass is used to collect meta data information. - - It includes: - alias table, arity for identifiers and might more information, - - ATTENTION: - For later pass to keep its information complete and up to date, - we need update its table accordingly - - - Alias inference is not for substitution, it is for analyze which module is - actually a global module or an exception, so it can be relaxed a bit - (without relying on strict analysis) - - - Js object (local) analysis - - Design choice: - - Side effectful operations: - - Lassign - - Psetfield - - 1. What information should be collected: - - 2. What's the key - If it's identifier, - - Information that is always sound, not subject to change - - - shall we collect that if an identifier is passed as a parameter, (useful for escape analysis), - however, since it's going to change after inlning (for local function) - - - function arity, subject to change when you make it a mutable ref and change it later - - - Immutable blocks of identifiers - - if identifier itself is function/non block then the access can be inlined - if identifier itself is immutable block can be inlined - if identifier is mutable block can be inlined (without Lassign) since - - - When collect some information, shall we propogate this information to - all alias table immeidately - - - annotation identifiers (at first time) - - -*) - -val collect_info : Lam_stats.t -> Lam.t -> unit -(** Modify existing [meta] *) diff --git a/jscomp/core/lam_pass_count.ml b/jscomp/core/lam_pass_count.ml deleted file mode 100644 index b7ee7a8..0000000 --- a/jscomp/core/lam_pass_count.ml +++ /dev/null @@ -1,199 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - -(*A naive dead code elimination *) -type used_info = { - mutable times : int; - mutable captured : bool; - (* captured in functon or loop, - inline in such cases should be careful - 1. can not inline mutable values - 2. avoid re-computation - *) -} - -type occ_tbl = used_info Hash_ident.t -(* First pass: count the occurrences of all let-bound identifiers *) - -type local_tbl = used_info Map_ident.t - -let dummy_info () = { times = 0; captured = false } -(* y is untouched *) - -let absorb_info (x : used_info) (y : used_info) = - match (x, y) with - | { times = x0 }, { times = y0; captured } -> - x.times <- x0 + y0; - if captured then x.captured <- true - -let pp_info fmt (x : used_info) = - Format.fprintf fmt "(:%d)" x.captured x.times - -let pp_occ_tbl fmt tbl = - Hash_ident.iter tbl (fun k v -> - Format.fprintf fmt "@[%a@ %a@]@." Ident.print k pp_info v) - -(* The global table [occ] associates to each let-bound identifier - the number of its uses (as a reference): - - 0 if never used - - 1 if used exactly once in and not under a lambda or within a loop - - when under a lambda, - - it's probably a closure - - within a loop - - update reference, - niether is good for inlining - - > 1 if used several times or under a lambda or within a loop. - The local table [bv] associates to each locally-let-bound variable - its reference count, as above. [bv] is enriched at let bindings - but emptied when crossing lambdas and loops. *) -let collect_occurs lam : occ_tbl = - let occ : occ_tbl = Hash_ident.create 83 in - - (* Current use count of a variable. *) - let used v = - match Hash_ident.find_opt occ v with - | None -> false - | Some { times; _ } -> times > 0 - in - - (* Entering a [let]. Returns updated [bv]. *) - let bind_var bv ident = - let r = dummy_info () in - Hash_ident.add occ ident r; - Map_ident.add bv ident r - in - - (* Record a use of a variable *) - let add_one_use bv ident = - match Map_ident.find_opt bv ident with - | Some r -> r.times <- r.times + 1 - | None -> ( - (* ident is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with - | Some r -> absorb_info r { times = 1; captured = true } - | None -> - (* Not a let-bound variable, ignore *) - ()) - in - - let inherit_use bv ident bid = - let n = - match Hash_ident.find_opt occ bid with - | None -> dummy_info () - | Some v -> v - in - match Map_ident.find_opt bv ident with - | Some r -> absorb_info r n - | None -> ( - (* ident is not locally bound, therefore this is a use under a lambda - or within a loop. Increase use count by 2 -- enough so - that single-use optimizations will not apply. *) - match Hash_ident.find_opt occ ident with - | Some r -> absorb_info r { n with captured = true } - | None -> - (* Not a let-bound variable, ignore *) - ()) - in - - let rec count (bv : local_tbl) (lam : Lam.t) = - match lam with - | Lfunction { body = l } -> count Map_ident.empty l - (* when entering a function local [bv] - is cleaned up, so that all closure variables will not be - carried over, since the parameters are never rebound, - so it is fine to kep it empty - *) - | Lfor (_, l1, l2, _dir, l3) -> - count bv l1; - count bv l2; - count Map_ident.empty l3 - | Lwhile (l1, l2) -> - count Map_ident.empty l1; - count Map_ident.empty l2 - | Lvar v -> add_one_use bv v - | Llet (_, v, Lvar w, l2) -> - (* v will be replaced by w in l2, so each occurrence of v in l2 - increases w's refcount *) - count (bind_var bv v) l2; - inherit_use bv w v - | Llet (kind, v, l1, l2) -> - count (bind_var bv v) l2; - (* count [l2] first, - If v is unused, l1 will be removed, so don't count its variables *) - if kind = Strict || used v then count bv l1 - | Lassign (_, l) -> - (* Lalias-bound variables are never assigned, so don't increase - this ident's refcount *) - count bv l - | Lglobal_module _ -> () - | Lprim { args; _ } -> List.iter (count bv) args - | Lletrec (bindings, body) -> - List.iter (fun (_v, l) -> count bv l) bindings; - count bv body - (* Note there is a difference here when do beta reduction for *) - | Lapply { ap_func = Lfunction ({ params; body } as lfunction); ap_args = args; _ } - when Ext_list.same_length params args && Lam_analysis.lfunction_can_be_beta_reduced lfunction -> - count bv (Lam_beta_reduce.no_names_beta_reduce params body args) - (* | Lapply{fn = Lfunction{function_kind = Tupled; params; body}; *) - (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* when Ext_list.same_length params args -> *) - (* count bv (Lam_beta_reduce.beta_reduce params body args) *) - | Lapply { ap_func = l1; ap_args = ll; _ } -> - count bv l1; - List.iter (count bv) ll - | Lconst _cst -> () - | Lswitch (l, sw) -> - count_default bv sw; - count bv l; - List.iter (fun (_, l) -> count bv l) sw.sw_consts; - List.iter (fun (_, l) -> count bv l) sw.sw_blocks - | Lstringswitch (l, sw, d) -> ( - count bv l; - List.iter (fun (_, l) -> count bv l) sw; - match d with Some d -> count bv d | None -> ()) - (* x2 for native backend *) - (* begin match sw with *) - (* | []|[_] -> count bv d *) - (* | _ -> count bv d ; count bv d *) - (* end *) - | Lstaticraise (_i, ls) -> List.iter (count bv) ls - | Lstaticcatch (l1, (_i, _), l2) -> - count bv l1; - count bv l2 - | Ltrywith (l1, _v, l2) -> - count bv l1; - count bv l2 - | Lifthenelse (l1, l2, l3) -> - count bv l1; - count bv l2; - count bv l3 - | Lsequence (l1, l2) -> - count bv l1; - count bv l2 - and count_default bv sw = - match sw.sw_failaction with - | None -> () - | Some al -> - if (not sw.sw_consts_full) && not sw.sw_blocks_full then ( - (* default action will occur twice in native code *) - count bv al; - count bv al) - else ( - (* default action will occur once *) - assert ((not sw.sw_consts_full) || not sw.sw_blocks_full); - count bv al) - in - count Map_ident.empty lam; - occ diff --git a/jscomp/core/lam_pass_count.mli b/jscomp/core/lam_pass_count.mli deleted file mode 100644 index c8cc1f8..0000000 --- a/jscomp/core/lam_pass_count.mli +++ /dev/null @@ -1,30 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - -type used_info = { - mutable times : int; - mutable captured : bool; - (* captured in functon or loop, - inline in such cases should be careful - 1. can not inline mutable values - 2. avoid re-computation - *) -} - -type occ_tbl = used_info Hash_ident.t - -val dummy_info : unit -> used_info - -val collect_occurs : Lam.t -> occ_tbl - -val pp_occ_tbl : Format.formatter -> occ_tbl -> unit diff --git a/jscomp/core/lam_pass_deep_flatten.ml b/jscomp/core/lam_pass_deep_flatten.ml deleted file mode 100644 index 73d8814..0000000 --- a/jscomp/core/lam_pass_deep_flatten.ml +++ /dev/null @@ -1,272 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* type eliminate = - | Not_eliminatable - | *) - -let rec eliminate_tuple (id : Ident.t) (lam : Lam.t) acc = - match lam with - | Llet - (Alias, v, Lprim { primitive = Pfield (i, _); args = [ Lvar tuple ] }, e2) - when Ident.same tuple id -> - eliminate_tuple id e2 (Map_int.add acc i v) - (* it is okay to have duplicates*) - | _ -> if Lam_hit.hit_variable id lam then None else Some (acc, lam) -(* [groups] are in reverse order *) - -(* be careful to flatten letrec - like below : - {[ - let rec even = - let odd n = if n ==1 then true else even (n - 1) in - fun n -> if n ==0 then true else odd (n - 1) - ]} - odd and even are recursive values, since all definitions inside - e.g, [odd] can see [even] now, however, it should be fine - in our case? since ocaml's recursive value does not allow immediate - access its value direclty?, seems no - {[ - let rec even2 = - let odd = even2 in - fun n -> if n ==0 then true else odd (n - 1) - ]} -*) -(* FIXME: - here we try to move inner definitions of [recurisve value] upwards - for example: - {[ - let rec x = - let y = 32 in - y :: x - and z = .. - --- - le ty = 32 in - let rec x = y::x - and z = .. - ]} - however, the inner definitions can see [z] and [x], so we - can not blindly move it in the beginning, however, for - recursive value, ocaml does not allow immediate access to - recursive value, so what's the best strategy? - --- - the motivation is to capture real tail call -*) -(* | Single ((Alias | Strict | StrictOpt), id, ( Lfunction _ )) -> - (** FIXME: - It should be alias and alias will be optimized away - in later optmizations, however, - this means if we don't optimize - {[ let u/a = v in ..]} - the output would be wrong, we should *optimize - this away right now* instead of delaying it to the - later passes - *) - (acc, set, g :: wrap, stop) -*) -(* could also be from nested [let rec] - like - {[ - let rec x = - let rec y = 1 :: y in - 2:: List.hd y:: x - ]} - TODO: seems like we should update depenency graph, -*) - -(* Printlambda.lambda Format.err_formatter lam ; assert false *) - -(** TODO: more flattening, - - also for function compilation, flattening should be done first - - [compile_group] and [compile] become mutually recursive function - *) -let lambda_of_groups ~(rev_bindings : Lam_group.t list) (result : Lam.t) : Lam.t - = - Ext_list.fold_left rev_bindings result (fun acc x -> - match x with - | Nop l -> Lam.seq l acc - | Single (kind, ident, lam) -> Lam_util.refine_let ~kind ident lam acc - | Recursive bindings -> Lam.letrec bindings acc) - -(* TODO: - refine effectful [ket_kind] to be pure or not - Be careful of how [Lifused(v,l)] work - since its semantics depend on whether v is used or not - return value are in reverse order, but handled by [lambda_of_groups] -*) -let deep_flatten (lam : Lam.t) : Lam.t = - let rec flatten (acc : Lam_group.t list) (lam : Lam.t) : - Lam.t * Lam_group.t list = - match lam with - | Llet - ( str, - id, - (Lprim - { - primitive = - Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt; - args = [ Lvar _ ]; - } as arg), - body ) -> - flatten (Single (str, id, aux arg) :: acc) body - | Llet - ( str, - id, - Lprim - { - primitive = - (Pnull_to_opt | Pundefined_to_opt | Pnull_undefined_to_opt) as - primitive; - args = [ arg ]; - }, - body ) -> - let newId = Ident.rename id in - flatten acc - (Lam.let_ str newId arg - (Lam.let_ Alias id - (Lam.prim ~primitive ~args:[ Lam.var newId ] - Location.none (* FIXME*)) - body)) - | Llet (str, id, arg, body) -> ( - (* - {[ let match = (a,b,c) - let d = (match/1) - let e = (match/2) - .. - ]} - *) - let res, accux = flatten acc arg in - match (id.name, str, res) with - | ( ("match" | "include" | "param"), - (Alias | Strict | StrictOpt), - Lprim { primitive = Pmakeblock (_, _, Immutable); args } ) -> ( - match eliminate_tuple id body Map_int.empty with - | Some (tuple_mapping, body) -> - flatten - (Ext_list.fold_left_with_offset args accux 0 (fun arg acc i -> - match Map_int.find_opt tuple_mapping i with - | None -> Lam_group.nop_cons arg acc - | Some key -> Lam_group.single str key arg :: acc)) - body - | None -> flatten (Single (str, id, res) :: accux) body) - | _ -> flatten (Single (str, id, res) :: accux) body) - | Lletrec (bind_args, body) -> - flatten (Recursive (Ext_list.map_snd bind_args aux) :: acc) body - | Lsequence (l, r) -> - let res, l = flatten acc l in - flatten (Lam_group.nop_cons res l) r - | x -> (aux x, acc) - and aux (lam : Lam.t) : Lam.t = - match lam with - | Llet _ -> - let res, groups = flatten [] lam in - lambda_of_groups res ~rev_bindings:groups - | Lletrec (bind_args, body) -> - (* Attention: don't mess up with internal {let rec} *) - let rec iter bind_args groups set = - match bind_args with - | [] -> (List.rev groups, set) - | (id, arg) :: rest -> - iter rest ((id, aux arg) :: groups) (Set_ident.add set id) - in - let groups, collections = iter bind_args [] Set_ident.empty in - (* Try to extract some value definitions from recursive values as [wrap], - it will stop whenever it find it could not move forward - {[ - let rec x = - let y = 1 in - let z = 2 in - ... - ]} - *) - let rev_bindings, rev_wrap, _ = - Ext_list.fold_left groups ([], [], false) - (fun (inner_recursive_bindings, wrap, stop) (id, lam) -> - if stop || Lam_hit.hit_variables collections lam then - ((id, lam) :: inner_recursive_bindings, wrap, true) - else - ( inner_recursive_bindings, - Lam_group.Single (Strict, id, lam) :: wrap, - false )) - in - lambda_of_groups - ~rev_bindings: - rev_wrap (* These bindings are extracted from [letrec] *) - (Lam.letrec (List.rev rev_bindings) (aux body)) - | Lsequence (l, r) -> Lam.seq (aux l) (aux r) - | Lconst _ -> lam - | Lvar _ -> lam - (* | Lapply(Lfunction(Curried, params, body), args, _) *) - (* when List.length params = List.length args -> *) - (* aux (beta_reduce params body args) *) - (* | Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock _, args)], _) *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *\) *) - (* when List.length params = List.length args -> *) - (* aux (beta_reduce params body args) *) - | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info - (* This kind of simple optimizations should be done each time - and as early as possible *) - | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - let args = Ext_list.map args aux in - Lam.prim ~primitive ~args loc - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(aux body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) -> - Lam.switch (aux l) - { - sw_consts = Ext_list.map_snd sw_consts aux; - sw_blocks = Ext_list.map_snd sw_blocks aux; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction aux; - sw_names; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (aux l) (Ext_list.map_snd sw aux) - (Ext_option.map d aux) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls aux) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (aux l1) ids (aux l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (aux l1) v (aux l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (aux l1) (aux l2) (aux l3) - | Lwhile (l1, l2) -> Lam.while_ (aux l1) (aux l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (aux l1) (aux l2) dir (aux l3) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refaux *) - Lam.assign v (aux l) - in - aux lam diff --git a/jscomp/core/lam_pass_deep_flatten.mli b/jscomp/core/lam_pass_deep_flatten.mli deleted file mode 100644 index 74e195f..0000000 --- a/jscomp/core/lam_pass_deep_flatten.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val deep_flatten : Lam.t -> Lam.t diff --git a/jscomp/core/lam_pass_eliminate_ref.ml b/jscomp/core/lam_pass_eliminate_ref.ml deleted file mode 100644 index c5325c1..0000000 --- a/jscomp/core/lam_pass_eliminate_ref.ml +++ /dev/null @@ -1,103 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - -exception Real_reference - -let rec eliminate_ref id (lam : Lam.t) = - match lam with - (* we can do better escape analysis in Javascript backend *) - | Lvar v -> if Ident.same v id then raise_notrace Real_reference else lam - | Lprim { primitive = Pfield (0, _); args = [ Lvar v ] } when Ident.same v id - -> - Lam.var id - | Lfunction _ -> - if Lam_hit.hit_variable id lam then raise_notrace Real_reference else lam - (* In Javascript backend, its okay, we can reify it later - a failed case - {[ - for i = .. - let v = ref 0 - for j = .. - incr v - a[j] = ()=>{!v} - - ]} - here v is captured by a block, and it's a loop mutable value, - we have to generate - {[ - for i = .. - let v = ref 0 - (function (v){for j = .. - a[j] = ()=>{!v}}(v) - - ]} - now, v is a real reference - TODO: we can refine analysis in later - *) - (* Lfunction(kind, params, eliminate_ref id body) *) - | Lprim { primitive = Psetfield (0, _); args = [ Lvar v; e ] } - when Ident.same v id -> - Lam.assign id (eliminate_ref id e) - | Lprim { primitive = Poffsetref delta; args = [ Lvar v ]; loc } - when Ident.same v id -> - Lam.assign id - (Lam.prim ~primitive:(Poffsetint delta) ~args:[ Lam.var id ] loc) - | Lconst _ -> lam - | Lapply { ap_func = e1; ap_args = el; ap_info } -> - Lam.apply (eliminate_ref id e1) - (Ext_list.map el (eliminate_ref id)) - ap_info - | Llet (str, v, e1, e2) -> - Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) - | Lletrec (idel, e2) -> - Lam.letrec - (Ext_list.map idel (fun (v, e) -> (v, eliminate_ref id e))) - (eliminate_ref id e2) - | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args (eliminate_ref id)) loc - | Lswitch (e, sw) -> - Lam.switch (eliminate_ref id e) - { - sw_consts_full = sw.sw_consts_full; - sw_consts = - Ext_list.map sw.sw_consts (fun (n, e) -> (n, eliminate_ref id e)); - sw_blocks_full = sw.sw_blocks_full; - sw_blocks = - Ext_list.map sw.sw_blocks (fun (n, e) -> (n, eliminate_ref id e)); - sw_failaction = - (match sw.sw_failaction with - | None -> None - | Some x -> Some (eliminate_ref id x)); - sw_names = sw.sw_names; - } - | Lstringswitch (e, sw, default) -> - Lam.stringswitch (eliminate_ref id e) - (Ext_list.map sw (fun (s, e) -> (s, eliminate_ref id e))) - (match default with - | None -> None - | Some x -> Some (eliminate_ref id x)) - | Lstaticraise (i, args) -> - Lam.staticraise i (Ext_list.map args (eliminate_ref id)) - | Lstaticcatch (e1, i, e2) -> - Lam.staticcatch (eliminate_ref id e1) i (eliminate_ref id e2) - | Ltrywith (e1, v, e2) -> - Lam.try_ (eliminate_ref id e1) v (eliminate_ref id e2) - | Lifthenelse (e1, e2, e3) -> - Lam.if_ (eliminate_ref id e1) (eliminate_ref id e2) (eliminate_ref id e3) - | Lsequence (e1, e2) -> Lam.seq (eliminate_ref id e1) (eliminate_ref id e2) - | Lwhile (e1, e2) -> Lam.while_ (eliminate_ref id e1) (eliminate_ref id e2) - | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (eliminate_ref id e1) (eliminate_ref id e2) dir - (eliminate_ref id e3) - | Lassign (v, e) -> Lam.assign v (eliminate_ref id e) diff --git a/jscomp/core/lam_pass_eliminate_ref.mli b/jscomp/core/lam_pass_eliminate_ref.mli deleted file mode 100644 index e63428a..0000000 --- a/jscomp/core/lam_pass_eliminate_ref.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -exception Real_reference - -val eliminate_ref : Ident.t -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_pass_exits.ml b/jscomp/core/lam_pass_exits.ml deleted file mode 100644 index e890327..0000000 --- a/jscomp/core/lam_pass_exits.ml +++ /dev/null @@ -1,244 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend: Hongbo Zhang *) - -(** - [no_bounded_varaibles lambda] - checks if [lambda] contains bounded variable, for - example [Llet (str,id,arg,body) ] will fail such check. - This is used to indicate such lambda expression if it is okay - to inline directly since if it contains bounded variables it - must be rebounded before inlining -*) -let rec no_list args = Ext_list.for_all args no_bounded_variables - -and no_list_snd : 'a. ('a * Lam.t) list -> bool = - fun args -> Ext_list.for_all_snd args no_bounded_variables - -and no_opt x = match x with None -> true | Some a -> no_bounded_variables a - -and no_bounded_variables (l : Lam.t) = - match l with - | Lvar _ -> true - | Lconst _ -> true - | Lassign (_id, e) -> no_bounded_variables e - | Lapply { ap_func; ap_args; _ } -> - no_bounded_variables ap_func && no_list ap_args - | Lglobal_module _ -> true - | Lprim { args; primitive = _ } -> no_list args - | Lswitch (arg, sw) -> - no_bounded_variables arg && no_list_snd sw.sw_consts - && no_list_snd sw.sw_blocks && no_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - no_bounded_variables arg && no_list_snd cases && no_opt default - | Lstaticraise (_, args) -> no_list args - | Lifthenelse (e1, e2, e3) -> - no_bounded_variables e1 && no_bounded_variables e2 - && no_bounded_variables e3 - | Lsequence (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 - | Lwhile (e1, e2) -> no_bounded_variables e1 && no_bounded_variables e2 - | Lstaticcatch (e1, (_, vars), e2) -> - vars = [] && no_bounded_variables e1 && no_bounded_variables e2 - | Lfunction { body; params } -> params = [] && no_bounded_variables body - | Lfor _ -> false - | Ltrywith _ -> false - | Llet _ -> false - | Lletrec (decl, body) -> decl = [] && no_bounded_variables body - -(* - TODO: - we should have a pass called, always inlinable - as long as its length is smaller than [exit=exit_id], for example - - {[ - switch(box_name) - {case "":exit=178;break; - case "b":exit=178;break; - case "h":box_type=/* Pp_hbox */0;break; - case "hov":box_type=/* Pp_hovbox */3;break; - case "hv":box_type=/* Pp_hvbox */2;break; - case "v":box_type=/* Pp_vbox */1;break; - default:box_type=invalid_box(/* () */0);} - - switch(exit){case 178:box_type=/* Pp_box */4;break} - ]} -*) - -(** The third argument is its occurrence, - when do the substitution, if its occurence is > 1, - we should refresh -*) -type lam_subst = Id of Lam.t [@@unboxed] -(* | Refresh of Lam.t *) - -type subst_tbl = (Ident.t list * lam_subst) Hash_int.t - -let to_lam x = match x with Id x -> x -(* | Refresh x -> Lam_bounded_vars.refresh x *) - -(** - Simplify ``catch body with (i ...) handler'' - - if (exit i ...) does not occur in body, suppress catch - - if (exit i ...) occurs exactly once in body, - substitute it with handler - - If handler is a single variable, replace (exit i ..) with it - - - Note: - In ``catch body with (i x1 .. xn) handler'' - Substituted expression is - let y1 = x1 and ... yn = xn in - handler[x1 <- y1 ; ... ; xn <- yn] - For the sake of preserving the uniqueness of bound variables. - ASKS: This documentation seems outdated - (No alpha conversion of ``handler'' is presently needed, since - substitution of several ``(exit i ...)'' - occurs only when ``handler'' is a variable.) - Note that - for [query] result = 2, - the non-inline cost is - {[ - var exit ; - - exit = 11; - exit = 11; - - switch(exit){ - case exit = 11 : body ; break - } - - ]} - the inline cost is - - {[ - body; - body; - ]} - - when [i] is negative, we can not inline in general, - since the outer is a traditional [try .. catch] body, - if it is guaranteed to be non throw, then we can inline -*) - -(** TODO: better heuristics, also if we can group same exit code [j] - in a very early stage -- maybe we can define our enhanced [Lambda] - representation and counter can be more precise, for example [apply] - does not need patch from the compiler - - FIXME: when inlining, need refresh local bound identifiers - #1438 when the action containes bounded variable - to keep the invariant, everytime, we do an inlining, - we need refresh, just refreshing once is not enough - We need to decide whether inline or not based on post-simplification - code, since when we do the substitution - we use the post-simplified expression, it is more consistent - TODO: when we do the case merging on the js side, - the j is not very indicative -*) - -let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t - = - let rec simplif (lam : Lam.t) = - match lam with - | Lstaticcatch (l1, (i, xs), l2) -> ( - let i_occur = query i in - match (i_occur, l2) with - | 0, _ -> simplif l1 - | _, Lvar _ | _, Lconst _ (* when i >= 0 # 2316 *) -> - Hash_int.add subst i (xs, Id (simplif l2)); - simplif l1 (* l1 will inline *) - | 1, _ when i >= 0 -> - (* Ask: Note that we have predicate i >=0 *) - Hash_int.add subst i (xs, Id (simplif l2)); - simplif l1 (* l1 will inline *) - | _ -> - let l2 = simplif l2 in - (* we only inline when [l2] does not contain bound variables - no need to refresh - *) - let ok_to_inline = - i >= 0 && no_bounded_variables l2 - && - let lam_size = Lam_analysis.size l2 in - (i_occur <= 2 && lam_size < Lam_analysis.exit_inline_size) - || lam_size < 5 - in - if ok_to_inline then ( - Hash_int.add subst i (xs, Id l2); - simplif l1) - else Lam.staticcatch (simplif l1) (i, xs) l2) - | Lstaticraise (i, []) -> ( - match Hash_int.find_opt subst i with - | Some (_, handler) -> to_lam handler - | None -> lam) - | Lstaticraise (i, ls) -> ( - let ls = Ext_list.map ls simplif in - match Hash_int.find_opt subst i with - | Some (xs, handler) -> - let handler = to_lam handler in - let ys = Ext_list.map xs Ident.rename in - let env = - Ext_list.fold_right2 xs ys Map_ident.empty (fun x y t -> - Map_ident.add t x (Lam.var y)) - in - Ext_list.fold_right2 ys ls (Lam_subst.subst env handler) - (fun y l r -> Lam.let_ Strict y l r) - | None -> Lam.staticraise i ls) - | Lvar _ | Lconst _ -> lam - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(simplif body) ~attr - | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) - | Lletrec (bindings, body) -> - Lam.letrec (Ext_list.map_snd bindings simplif) (simplif body) - | Lglobal_module _ -> lam - | Lprim { primitive; args; loc } -> - let args = Ext_list.map args simplif in - Lam.prim ~primitive ~args loc - | Lswitch (l, sw) -> - let new_l = simplif l in - let new_consts = Ext_list.map_snd sw.sw_consts simplif in - let new_blocks = Ext_list.map_snd sw.sw_blocks simplif in - let new_fail = Ext_option.map sw.sw_failaction simplif in - Lam.switch new_l - { - sw with - sw_consts = new_consts; - sw_blocks = new_blocks; - sw_failaction = new_fail; - } - | Lstringswitch (l, sw, d) -> - Lam.stringswitch (simplif l) - (Ext_list.map_snd sw simplif) - (Ext_option.map d simplif) - | Ltrywith (l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse (l1, l2, l3) -> Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lsequence (l1, l2) -> Lam.seq (simplif l1) (simplif l2) - | Lwhile (l1, l2) -> Lam.while_ (simplif l1) (simplif l2) - | Lfor (v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lassign (v, l) -> Lam.assign v (simplif l) - in - simplif lam - -let simplify_exits (lam : Lam.t) = - let exits = Lam_exit_count.count_helper lam in - subst_helper (Hash_int.create 17) (Lam_exit_count.count_exit exits) lam - -(* Compile-time beta-reduction of functions immediately applied: - Lapply(Lfunction(Curried, params, body), args, loc) -> - let paramN = argN in ... let param1 = arg1 in body - Lapply(Lfunction(Tupled, params, body), [Lprim(Pmakeblock(args))], loc) -> - let paramN = argN in ... let param1 = arg1 in body - Assumes |args| = |params|. -*) diff --git a/jscomp/core/lam_pass_exits.mli b/jscomp/core/lam_pass_exits.mli deleted file mode 100644 index a48c54d..0000000 --- a/jscomp/core/lam_pass_exits.mli +++ /dev/null @@ -1,18 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend: Hongbo Zhang, *) - -(** A pass used to optimize the exit code compilation, adaped from the compiler's - [simplif] module -*) - -val simplify_exits : Lam.t -> Lam.t diff --git a/jscomp/core/lam_pass_lets_dce.ml b/jscomp/core/lam_pass_lets_dce.ml deleted file mode 100644 index dad1786..0000000 --- a/jscomp/core/lam_pass_lets_dce.ml +++ /dev/null @@ -1,263 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend : Hongbo Zhang, *) - - -let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = - let subst : Lam.t Hash_ident.t = Hash_ident.create 32 in - let string_table : string Hash_ident.t = Hash_ident.create 32 in - let used v = (count_var v ).times > 0 in - let rec simplif (lam : Lam.t) = - match lam with - | Lvar v -> Hash_ident.find_default subst v lam - | Llet( (Strict | Alias | StrictOpt) , v, Lvar w, l2) - -> - Hash_ident.add subst v (simplif (Lam.var w)); - simplif l2 - | Llet(Strict as kind, - v, (Lprim {primitive = (Pmakeblock(0, _, Mutable) - as primitive); - args = [linit] ; loc}), lbody) - -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin - try (* TODO: record all references variables *) - Lam_util.refine_let - ~kind:Variable v slinit - (Lam_pass_eliminate_ref.eliminate_ref v slbody) - with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let - ~kind v (Lam.prim ~primitive ~args:[slinit] loc) - slbody - end - | Llet(Alias, v, l1, l2) -> - (* For alias, [l1] is pure, we can always inline, - when captured, we should avoid recomputation - *) - begin - match count_var v, l1 with - | {times = 0; _}, _ -> simplif l2 - | {times = 1; captured = false }, _ - | {times = 1; captured = true }, (Lconst _ | Lvar _) - | _, (Lconst - (( - Const_int _ | Const_char _ | Const_float _ | Const_bigint _ - ) - | Const_pointer _ |Const_js_true | Const_js_false | Const_js_undefined _) (* could be poly-variant [`A] -> [65a]*) - | Lprim {primitive = Pfield (_); - args = [ - Lglobal_module _ - ]} - ) - (* Const_int64 is no longer primitive - Note for some constant which is not - inlined, we can still record it and - do constant folding independently - *) - -> - Hash_ident.add subst v (simplif l1); simplif l2 - | _, Lconst (Const_string {s; unicode = false} ) -> - (* only "" added for later inlining *) - Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) - (* we need move [simplif l2] later, since adding Hash does have side effect *) - | _ -> Lam.let_ Alias v (simplif l1) (simplif l2) - (* for Alias, in most cases [l1] is already simplified *) - end - | Llet(StrictOpt as kind, v, l1, lbody) -> - (* can not be inlined since [l1] depend on the store - {[ - let v = [|1;2;3|] - ]} - get [StrictOpt] here, we can not inline v, - since the value of [v] can be changed - - GPR #1476 - Note to pass the sanitizer, we do need remove dead code (not just best effort) - This logic is tied to {!Lam_pass_count.count} - {[ - if kind = Strict || used v then count bv l1 - ]} - If the code which should be removed is not removed, it will hold references - to other variables which is already removed. - *) - if not (used v) - then simplif lbody (* GPR #1476 *) - else - begin match l1 with - | (Lprim {primitive = (Pmakeblock(0, _, Mutable) - as primitive); - args = [linit] ; loc}) - -> - let slinit = simplif linit in - let slbody = simplif lbody in - begin - try (* TODO: record all references variables *) - Lam_util.refine_let - ~kind:Variable v slinit - (Lam_pass_eliminate_ref.eliminate_ref v slbody) - with Lam_pass_eliminate_ref.Real_reference -> - Lam_util.refine_let - ~kind v (Lam.prim ~primitive ~args:[slinit] loc) - slbody - end - - | _ -> - let l1 = simplif l1 in - begin match l1 with - | Lconst(Const_string { s; unicode = false }) -> - Hash_ident.add string_table v s; - (* we need move [simplif lbody] later, since adding Hash does have side effect *) - Lam.let_ Alias v l1 (simplif lbody) - | _ -> - Lam_util.refine_let ~kind v l1 (simplif lbody) - end - end - (* TODO: check if it is correct rollback to [StrictOpt]? *) - - | Llet((Strict | Variable as kind), v, l1, l2) -> - if not (used v) - then - let l1 = simplif l1 in - let l2 = simplif l2 in - if Lam_analysis.no_side_effects l1 - then l2 - else Lam.seq l1 l2 - else - let l1 = (simplif l1) in - - begin match kind, l1 with - | Strict, Lconst((Const_string { s; unicode = false })) - -> - Hash_ident.add string_table v s; - Lam.let_ Alias v l1 (simplif l2) - | _ -> - Lam_util.refine_let ~kind v l1 (simplif l2) - end - | Lsequence(l1, l2) -> Lam.seq (simplif l1) (simplif l2) - - | Lapply{ap_func = Lfunction ({params; body} as lfunction); ap_args = args; _} - when Ext_list.same_length params args && Lam_analysis.lfunction_can_be_beta_reduced lfunction -> - simplif (Lam_beta_reduce.no_names_beta_reduce params body args) - (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) - (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *) - (* *\) *) - (* when Ext_list.same_length params args -> *) - (* simplif (Lam_beta_reduce.beta_reduce params body args) *) - - | Lapply{ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info - | Lfunction{arity; params; body; attr} -> - Lam.function_ ~arity ~params ~body:(simplif body) ~attr - | Lconst _ -> lam - | Lletrec(bindings, body) -> - Lam.letrec - (Ext_list.map_snd bindings simplif) - (simplif body) - | Lprim {primitive=Pstringadd; args = [l;r]; loc } -> - begin - let l' = simplif l in - let r' = simplif r in - let opt_l = - match l' with - | Lconst(Const_string { s = ls; unicode = false }) -> Some ls - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - match opt_l with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc - | Some l_s -> - let opt_r = - match r' with - | Lconst (Const_string {s = rs; unicode = false}) -> Some rs - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - begin match opt_r with - | None -> Lam.prim ~primitive:Pstringadd ~args:[l';r'] loc - | Some r_s -> - Lam.const (Const_string { s = l_s^r_s; unicode = false }) - end - end - - | Lprim {primitive = (Pstringrefu|Pstringrefs) as primitive ; - args = [l;r] ; loc - } -> (* TODO: introudce new constant *) - let l' = simplif l in - let r' = simplif r in - let opt_l = - match l' with - | Lconst (Const_string { s = ls; unicode = false }) -> - Some ls - | Lvar i -> Hash_ident.find_opt string_table i - | _ -> None in - begin match opt_l with - | None -> Lam.prim ~primitive ~args:[l';r'] loc - | Some l_s -> - match r with - |Lconst((Const_int {i})) -> - let i = Int32.to_int i in - if i < String.length l_s && i >= 0 then - Lam.const ((Const_char (Char.code l_s.[i]))) - else - Lam.prim ~primitive ~args:[l';r'] loc - | _ -> - Lam.prim ~primitive ~args:[l';r'] loc - end - | Lglobal_module _ -> lam - | Lprim {primitive; args; loc} - -> Lam.prim ~primitive ~args:(Ext_list.map args simplif) loc - | Lswitch(l, sw) -> - let new_l = simplif l - and new_consts = Ext_list.map_snd sw.sw_consts simplif - and new_blocks = Ext_list.map_snd sw.sw_blocks simplif - and new_fail = Ext_option.map sw.sw_failaction simplif - in - Lam.switch - new_l - {sw with sw_consts = new_consts ; sw_blocks = new_blocks; - sw_failaction = new_fail} - | Lstringswitch (l,sw,d) -> - Lam.stringswitch - (simplif l) (Ext_list.map_snd sw simplif) - (Ext_option.map d simplif) - | Lstaticraise (i,ls) -> - Lam.staticraise i (Ext_list.map ls simplif) - | Lstaticcatch(l1, (i,args), l2) -> - Lam.staticcatch (simplif l1) (i,args) (simplif l2) - | Ltrywith(l1, v, l2) -> Lam.try_ (simplif l1) v (simplif l2) - | Lifthenelse(l1, l2, l3) -> - Lam.if_ (simplif l1) (simplif l2) (simplif l3) - | Lwhile(l1, l2) - -> - Lam.while_ (simplif l1) (simplif l2) - | Lfor(v, l1, l2, dir, l3) -> - Lam.for_ v (simplif l1) (simplif l2) dir (simplif l3) - | Lassign(v, l) -> Lam.assign v (simplif l) - in simplif lam - - -(* To transform let-bound references into variables *) -let apply_lets occ lambda = - let count_var v = - match - Hash_ident.find_opt occ v - with - | None -> Lam_pass_count.dummy_info () - | Some v -> v in - lets_helper count_var lambda - -let simplify_lets (lam : Lam.t) : Lam.t = - let occ = Lam_pass_count.collect_occurs lam in - (* Ext_log.dwarn ~__POS__ "@[%a@]@." Lam_pass_count.pp_occ_tbl occ ; *) - apply_lets occ lam diff --git a/jscomp/core/lam_pass_lets_dce.mli b/jscomp/core/lam_pass_lets_dce.mli deleted file mode 100644 index bad2bf9..0000000 --- a/jscomp/core/lam_pass_lets_dce.mli +++ /dev/null @@ -1,35 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) -(* Adapted for Javascript backend: Hongbo Zhang *) - -val simplify_lets : Lam.t -> Lam.t -(** - This pass would do beta reduction, and dead code elimination (adapted from compiler's built-in [Simplif] module ) - - 1. beta reduction -> Llet (Strict ) - - 2. The global table [occ] associates to each let-bound identifier - the number of its uses (as a reference): - - 0 if never used - - 1 if used exactly once in and *not under a lambda or within a loop - - > 1 if used several times or under a lambda or within a loop. - - The local table [bv] associates to each locally-let-bound variable - its reference count, as above. [bv] is enriched at let bindings - but emptied when crossing lambdas and loops. - - For this pass, when it' used under a lambda or within a loop, we don't do anything, - in theory, we can still do something if it's pure but we are conservative here. - - [bv] is used to help caculate [occ] it is not useful outside - -*) diff --git a/jscomp/core/lam_pass_remove_alias.ml b/jscomp/core/lam_pass_remove_alias.ml deleted file mode 100644 index 4889d1c..0000000 --- a/jscomp/core/lam_pass_remove_alias.ml +++ /dev/null @@ -1,323 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type outcome = Eval_false | Eval_true | Eval_unknown - -let id_is_for_sure_true_in_boolean (tbl : Lam_stats.ident_tbl) id = - match Hash_ident.find_opt tbl id with - | Some (ImmutableBlock _) - | Some (Normal_optional _) - | Some (MutableBlock _) - | Some (Constant (Const_block _ | Const_js_true)) -> - Eval_true - | Some (Constant (Const_int { i })) -> - if i = 0l then Eval_false else Eval_true - | Some (Constant (Const_js_false | Const_js_null | Const_js_undefined _)) -> - Eval_false - | Some - ( Constant _ | Module _ | FunctionId _ | Exception | Parameter | NA - | OptionalBlock (_, (Undefined | Null | Null_undefined)) ) - | None -> - Eval_unknown - -let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec simpl (lam : Lam.t) : Lam.t = - match lam with - | Lvar _ -> lam - | Lprim { primitive = Pfield (i, info) as primitive; args = [ arg ]; loc } - -> ( - (* ATTENTION: - Main use case, we should detect inline all immutable block .. *) - match simpl arg with - | Lvar v as l -> - Lam_util.field_flatten_get - (fun _ -> Lam.prim ~primitive ~args:[ l ] loc) - v i info meta.ident_tbl - | l -> Lam.prim ~primitive ~args:[ l ] loc) - | Lprim - { - primitive = (Pval_from_option | Pval_from_option_not_nest) as p; - args = [ (Lvar v as lvar) ]; - } as x -> ( - match Hash_ident.find_opt meta.ident_tbl v with - | Some (OptionalBlock (l, _)) -> l - | _ -> if p = Pval_from_option_not_nest then lvar else x) - | Lglobal_module _ -> lam - | Lprim { primitive = Pfull_apply; args = Lvar v :: ap_args as args; loc } - -> ( - (* Inline uncurried application when safe *) - let normal () = - Lam.prim ~primitive:Pfull_apply ~args:(Ext_list.map args simpl) loc - in - let ap_args = Ext_list.map ap_args simpl in - match Hash_ident.find_opt meta.ident_tbl v with - | Some - (FunctionId - { - lambda = - Some - ( Lfunction - ({ params; body; attr = { is_a_functor = false } } as m), - rec_flag ); - }) - when Ext_list.same_length ap_args params - && Lam_analysis.lfunction_can_be_beta_reduced m - && Lam_analysis.ok_to_inline_fun_when_app m ap_args -> ( - let param_map = - Lam_closure.is_closed_with_map meta.export_idents params body - in - let is_export_id = Set_ident.mem meta.export_idents v in - match (is_export_id, param_map) with - | false, (_, param_map) | true, (true, param_map) -> ( - match rec_flag with - | Lam_rec -> - Lam_beta_reduce.propagate_beta_reduce_with_map meta - param_map params body ap_args - | Lam_self_rec -> normal () - | Lam_non_rec -> - if - Ext_list.exists ap_args (fun lam -> - Lam_hit.hit_variable v lam) - (*avoid nontermination, e.g, `g(g)`*) - then normal () - else - simpl - (Lam_beta_reduce.propagate_beta_reduce_with_map meta - param_map params body ap_args)) - | _ -> normal ()) - | _ -> normal ()) - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args simpl) loc - | Lifthenelse - ((Lprim { primitive = Pis_not_none; args = [ Lvar id ] } as l1), l2, l3) - -> ( - match Hash_ident.find_opt meta.ident_tbl id with - | Some (ImmutableBlock _ | MutableBlock _ | Normal_optional _) -> - simpl l2 - | Some (OptionalBlock (l, Null)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null ~args:[ l ] Location.none)) - (simpl l2) (simpl l3) - | Some (OptionalBlock (l, Undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_undefined ~args:[ l ] Location.none)) - (simpl l2) (simpl l3) - | Some (OptionalBlock (l, Null_undefined)) -> - Lam.if_ - (Lam.not_ Location.none - (Lam.prim ~primitive:Pis_null_undefined ~args:[ l ] - Location.none)) - (simpl l2) (simpl l3) - | Some _ | None -> Lam.if_ l1 (simpl l2) (simpl l3)) - (* could be the code path - {[ match x with - | h::hs -> - ]} - *) - | Lifthenelse (l1, l2, l3) -> ( - match l1 with - | Lvar id -> ( - match id_is_for_sure_true_in_boolean meta.ident_tbl id with - | Eval_true -> simpl l2 - | Eval_false -> simpl l3 - | Eval_unknown -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) - | _ -> Lam.if_ (simpl l1) (simpl l2) (simpl l3)) - | Lconst _ -> lam - | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) - | Lletrec (bindings, body) -> - let bindings = Ext_list.map_snd bindings simpl in - Lam.letrec bindings (simpl body) - (* complicated - 1. inline this function - 2. ... - exports.Make= - function(funarg) - {var $$let=Make(funarg); - return [0, $$let[5],... $$let[16]]} - *) - | Lapply - { - ap_func = - Lprim - { - primitive = Pfield (_, Fld_module { name = fld_name }); - args = [ Lglobal_module (ident, dynamic_import) ]; - _; - } as l1; - ap_args = args; - ap_info; - } -> ( - match Lam_compile_env.query_external_id_info ~dynamic_import ident fld_name with - | { - persistent_closed_lambda = - Some (Lfunction ({ params; body } as lfunction)); - } - (* be more cautious when do cross module inlining *) - when Ext_list.same_length params args - && Ext_list.for_all args (fun arg -> - match arg with - | Lvar p -> ( - match Hash_ident.find_opt meta.ident_tbl p with - | Some v -> v <> Parameter - | None -> true) - | _ -> true) - && Lam_analysis.lfunction_can_be_beta_reduced lfunction -> - simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) - | _ -> Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info) - (* Function inlining interact with other optimizations... - - - parameter attributes - - scope issues - - code bloat - *) - | Lapply { ap_func = Lvar v as fn; ap_args; ap_info } -> ( - (* Check info for always inlining *) - - (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) - let ap_args = Ext_list.map ap_args simpl in - let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in - match Hash_ident.find_opt meta.ident_tbl v with - | Some - (FunctionId - { - lambda = - Some - ( Lfunction ({ params; body; attr = { is_a_functor } } as m), - rec_flag ); - }) - when Lam_analysis.lfunction_can_be_beta_reduced m -> - if Ext_list.same_length ap_args params then - if - is_a_functor - (* && (Set_ident.mem v meta.export_idents) && false *) - then - (* TODO: check l1 if it is exported, - if so, maybe not since in that case, - we are going to have two copy? - *) - - (* Check: recursive applying may result in non-termination *) - (* Ext_log.dwarn __LOC__ "beta .. %s/%d" v.name v.stamp ; *) - simpl - (Lam_beta_reduce.propagate_beta_reduce meta params body - ap_args) - else if - (* Lam_analysis.size body < Lam_analysis.small_inline_size *) - (* ap_inlined = Always_inline || *) - Lam_analysis.ok_to_inline_fun_when_app m ap_args - then - (* let param_map = *) - (* Lam_analysis.free_variables meta.export_idents *) - (* (Lam_analysis.param_map_of_list params) body in *) - (* let old_count = List.length params in *) - (* let new_count = Map_ident.cardinal param_map in *) - let param_map = - Lam_closure.is_closed_with_map meta.export_idents params body - in - let is_export_id = Set_ident.mem meta.export_idents v in - match (is_export_id, param_map) with - | false, (_, param_map) | true, (true, param_map) -> ( - match rec_flag with - | Lam_rec -> - Lam_beta_reduce.propagate_beta_reduce_with_map meta - param_map params body ap_args - | Lam_self_rec -> normal () - | Lam_non_rec -> - if - Ext_list.exists ap_args (fun lam -> - Lam_hit.hit_variable v lam) - (*avoid nontermination, e.g, `g(g)`*) - then normal () - else - simpl - (Lam_beta_reduce.propagate_beta_reduce_with_map meta - param_map params body ap_args)) - | _ -> normal () - else normal () - else normal () - | Some _ | None -> normal ()) - | Lapply - { - ap_func = Lfunction ({ params; body } as lfunction); - ap_args = args; - _; - } - when Ext_list.same_length params args - && Lam_analysis.lfunction_can_be_beta_reduced lfunction -> - simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) - (* | Lapply{ fn = Lfunction{function_kind = Tupled; params; body}; *) - (* args = [Lprim {primitive = Pmakeblock _; args; _}]; _} *) - (* (\** TODO: keep track of this parameter in ocaml trunk, *) - (* can we switch to the tupled backend? *) - (* *\) *) - (* when Ext_list.same_length params args -> *) - (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) - | Lapply { ap_func = l1; ap_args = ll; ap_info } -> - Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(simpl body) ~attr - | Lswitch - ( l, - { - sw_failaction; - sw_consts; - sw_blocks; - sw_blocks_full; - sw_consts_full; - sw_names; - } ) -> - Lam.switch (simpl l) - { - sw_consts = Ext_list.map_snd sw_consts simpl; - sw_blocks = Ext_list.map_snd sw_blocks simpl; - sw_consts_full; - sw_blocks_full; - sw_failaction = Ext_option.map sw_failaction simpl; - sw_names; - } - | Lstringswitch (l, sw, d) -> - let l = - match l with - | Lvar s -> ( - match Hash_ident.find_opt meta.ident_tbl s with - | Some (Constant s) -> Lam.const s - | Some _ | None -> simpl l) - | _ -> simpl l - in - Lam.stringswitch l (Ext_list.map_snd sw simpl) (Ext_option.map d simpl) - | Lstaticraise (i, ls) -> Lam.staticraise i (Ext_list.map ls simpl) - | Lstaticcatch (l1, ids, l2) -> Lam.staticcatch (simpl l1) ids (simpl l2) - | Ltrywith (l1, v, l2) -> Lam.try_ (simpl l1) v (simpl l2) - | Lsequence (l1, l2) -> Lam.seq (simpl l1) (simpl l2) - | Lwhile (l1, l2) -> Lam.while_ (simpl l1) (simpl l2) - | Lfor (flag, l1, l2, dir, l3) -> - Lam.for_ flag (simpl l1) (simpl l2) dir (simpl l3) - | Lassign (v, l) -> - (* Lalias-bound variables are never assigned, so don't increase - v's refsimpl *) - Lam.assign v (simpl l) - in - simpl lam diff --git a/jscomp/core/lam_pass_remove_alias.mli b/jscomp/core/lam_pass_remove_alias.mli deleted file mode 100644 index 3d6b915..0000000 --- a/jscomp/core/lam_pass_remove_alias.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Keep track of the global module Aliases *) - -(** - One way: guarantee that all global aliases *would be removed* , - it will not be aliased - - So the only remaining place for globals is either - just Pgetglobal in functor application or - `Lprim (Pfield( i ), [Pgetglobal])` - - This pass does not change meta data -*) - -val simplify_alias : Lam_stats.t -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_primitive.ml b/jscomp/core/lam_primitive.ml deleted file mode 100644 index 3280a09..0000000 --- a/jscomp/core/lam_primitive.ml +++ /dev/null @@ -1,350 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] - -type ident = Ident.t - -type record_representation = - | Record_regular - | Record_inlined of { tag : int; name : string; num_nonconsts : int } (* Inlined record *) - | Record_extension -(* Inlined record under extension *) - -type t = - | Pbytes_to_string - (* Operations on heap blocks *) - | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag - | Pfield of int * Lam_compat.field_dbg_info - | Psetfield of int * Lam_compat.set_field_dbg_info - (* could have field info at least for record *) - | Pduprecord - (* Force lazy values *) - | Plazyforce - (* External call *) - | Pccall of { prim_name : string } - | Pjs_call of { - prim_name : string; - arg_types : External_arg_spec.params; - ffi : External_ffi_types.external_spec; - dynamic_import: bool; - } - | Pjs_object_create of External_arg_spec.obj_params - (* Exceptions *) - | Praise - (* Boolean operations *) - | Psequand - | Psequor - | Pnot - (* Integer operations *) - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pdivint - | Pmodint - | Pandint - | Porint - | Pxorint - | Plslint - | Plsrint - | Pasrint - | Poffsetint of int - | Poffsetref of int - (* Float operations *) - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - (* BigInt operations *) - | Pnegbigint - | Paddbigint - | Psubbigint - | Pmulbigint - | Pdivbigint - | Pmodbigint - | Ppowbigint - | Pandbigint - | Porbigint - | Pxorbigint - | Plslbigint - | Pasrbigint - | Pintcomp of Lam_compat.comparison - | Pfloatcomp of Lam_compat.comparison - | Pjscomp of Lam_compat.comparison - | Pint64comp of Lam_compat.comparison - | Pbigintcomp of Lam_compat.comparison - | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pjs_runtime_apply (* [f; [...]] *) - (* String operations *) - | Pstringlength - | Pstringrefu - | Pstringrefs - | Pstringadd - | Pbyteslength - | Pbytesrefu - | Pbytessetu - | Pbytesrefs - | Pbytessets - (* Array operations *) - | Pmakearray - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* Test if the argument is a block or an immediate integer *) - | Pisint - | Pis_poly_var_block - (* Test if the (integer) argument is outside an interval *) - | Pisout of int - | Pint64ofint - | Pintofint64 - | Pnegint64 - | Paddint64 - | Psubint64 - | Pmulint64 - | Pdivint64 - | Pmodint64 - | Pandint64 - | Porint64 - | Pxorint64 - | Plslint64 - | Plsrint64 - | Pasrint64 - (* Compile time constants *) - | Pctconst of Lam_compat.compile_time_constant (* Integer to external pointer *) - | Pdebugger - | Pjs_unsafe_downgrade of { name : string; setter : bool } - | Pinit_mod - | Pupdate_mod - | Praw_js_code of Js_raw_info.t - | Pjs_fn_make of int - | Pjs_fn_make_unit - | Pvoid_run - | Pfull_apply - (* we wrap it when do the conversion to prevent - accendential optimization - play safe first - *) - | Pjs_fn_method - | Pundefined_to_opt - | Pnull_to_opt - | Pnull_undefined_to_opt - | Pis_null - | Pis_undefined - | Pis_null_undefined - | Pimport - | Pjs_typeof - | Pjs_function_length - | Pcaml_obj_length - | Pwrap_exn (* convert either JS exception or OCaml exception into OCaml format *) - | Pcreate_extension of string - | Pis_not_none (* no info about its type *) - | Pval_from_option - | Pval_from_option_not_nest - | Psome - | Psome_not_nest - -let eq_field_dbg_info (x : Lam_compat.field_dbg_info) - (y : Lam_compat.field_dbg_info) = - x = y -(* save it to avoid conditional compilation, fix it later *) - -let eq_set_field_dbg_info (x : Lam_compat.set_field_dbg_info) - (y : Lam_compat.set_field_dbg_info) = - x = y -(* save it to avoid conditional compilation, fix it later *) - -let eq_tag_info (x : Lam_tag_info.t) y = x = y - -let eq_primitive_approx (lhs : t) (rhs : t) = - match lhs with - | Pcreate_extension a -> ( - match rhs with Pcreate_extension b -> a = (b : string) | _ -> false) - | Pwrap_exn -> rhs = Pwrap_exn - | Pbytes_to_string -> rhs = Pbytes_to_string - | Praise -> rhs = Praise - | Psequand -> rhs = Psequand - | Psequor -> rhs = Psequor - | Pnot -> rhs = Pnot - | Pnegint -> rhs = Pnegint - | Paddint -> rhs = Paddint - | Psubint -> rhs = Psubint - | Pmulint -> rhs = Pmulint - | Pdivint -> rhs = Pdivint - | Pmodint -> rhs = Pmodint - | Pandint -> rhs = Pandint - | Porint -> rhs = Porint - | Pxorint -> rhs = Pxorint - | Plslint -> rhs = Plslint - | Plsrint -> rhs = Plsrint - | Pasrint -> rhs = Pasrint - | Pval_from_option -> rhs = Pval_from_option - | Pval_from_option_not_nest -> rhs = Pval_from_option_not_nest - | Plazyforce -> rhs = Plazyforce - | Pintoffloat -> rhs = Pintoffloat - | Pfloatofint -> rhs = Pfloatofint - | Pnegfloat -> rhs = Pnegfloat - (* | Pabsfloat -> rhs = Pabsfloat *) - | Paddfloat -> rhs = Paddfloat - | Psubfloat -> rhs = Psubfloat - | Pmulfloat -> rhs = Pmulfloat - | Pdivfloat -> rhs = Pdivfloat - | Pnegbigint -> rhs = Pnegbigint - | Paddbigint -> rhs = Paddbigint - | Psubbigint -> rhs = Psubbigint - | Pmulbigint -> rhs = Pmulbigint - | Pdivbigint -> rhs = Pdivbigint - | Pmodbigint -> rhs = Pmodbigint - | Ppowbigint -> rhs = Ppowbigint - | Pandbigint -> rhs = Pandbigint - | Porbigint -> rhs = Porbigint - | Pxorbigint -> rhs = Pxorbigint - | Plslbigint -> rhs = Plslbigint - | Pasrbigint -> rhs = Pasrbigint - | Pjs_apply -> rhs = Pjs_apply - | Pjs_runtime_apply -> rhs = Pjs_runtime_apply - | Pstringlength -> rhs = Pstringlength - | Pstringrefu -> rhs = Pstringrefu - | Pstringrefs -> rhs = Pstringrefs - | Pstringadd -> rhs = Pstringadd - | Pbyteslength -> rhs = Pbyteslength - | Pbytesrefu -> rhs = Pbytesrefu - | Pbytessetu -> rhs = Pbytessetu - | Pbytesrefs -> rhs = Pbytesrefs - | Pbytessets -> rhs = Pbytessets - | Pundefined_to_opt -> rhs = Pundefined_to_opt - | Pnull_to_opt -> rhs = Pnull_to_opt - | Pnull_undefined_to_opt -> rhs = Pnull_undefined_to_opt - | Pis_null -> rhs = Pis_null - | Pis_not_none -> rhs = Pis_not_none - | Psome -> rhs = Psome - | Psome_not_nest -> rhs = Psome_not_nest - | Pis_undefined -> rhs = Pis_undefined - | Pis_null_undefined -> rhs = Pis_null_undefined - | Pimport -> rhs = Pimport - | Pjs_typeof -> rhs = Pjs_typeof - | Pisint -> rhs = Pisint - | Pis_poly_var_block -> rhs = Pis_poly_var_block - | Pisout l -> ( match rhs with Pisout r -> l = r | _ -> false) - | Pdebugger -> rhs = Pdebugger - | Pinit_mod -> rhs = Pinit_mod - | Pupdate_mod -> rhs = Pupdate_mod - | Pjs_function_length -> rhs = Pjs_function_length - (* | Pjs_string_of_small_array -> rhs = Pjs_string_of_small_array *) - (* | Pjs_is_instance_array -> rhs = Pjs_is_instance_array *) - | Pcaml_obj_length -> rhs = Pcaml_obj_length - (* | Pcaml_obj_set_length -> rhs = Pcaml_obj_set_length *) - | Pccall { prim_name = n0 } -> ( - match rhs with Pccall { prim_name = n1 } -> n0 = n1 | _ -> false) - | Pfield (n0, info0) -> ( - match rhs with - | Pfield (n1, info1) -> n0 = n1 && eq_field_dbg_info info0 info1 - | _ -> false) - | Psetfield (i0, info0) -> ( - match rhs with - | Psetfield (i1, info1) -> i0 = i1 && eq_set_field_dbg_info info0 info1 - | _ -> false) - | Pmakeblock (i0, info0, flag0) -> ( - match rhs with - | Pmakeblock (i1, info1, flag1) -> - i0 = i1 && flag0 = flag1 && eq_tag_info info0 info1 - | _ -> false) - | Pduprecord -> rhs = Pduprecord - | Pjs_call { prim_name; arg_types; ffi; dynamic_import } -> ( - match rhs with - | Pjs_call rhs -> - prim_name = rhs.prim_name && arg_types = rhs.arg_types - && ffi = rhs.ffi && dynamic_import = rhs.dynamic_import - | _ -> false) - | Pjs_object_create obj_create -> ( - match rhs with - | Pjs_object_create obj_create1 -> obj_create = obj_create1 - | _ -> false) - | Pintcomp comparison -> ( - match rhs with - | Pintcomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pfloatcomp comparison -> ( - match rhs with - | Pfloatcomp comparison1 -> - Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pbigintcomp comparison -> ( - match rhs with - | Pbigintcomp comparison1 -> - Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pjscomp comparison -> ( - match rhs with - | Pjscomp comparison1 -> Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Poffsetint i0 -> ( match rhs with Poffsetint i1 -> i0 = i1 | _ -> false) - | Poffsetref i0 -> ( match rhs with Poffsetref i1 -> i0 = i1 | _ -> false) - | Pmakearray -> rhs = Pmakearray - | Parraylength -> rhs = Parraylength - | Parrayrefu -> rhs = Parrayrefu - | Parraysetu -> rhs = Parraysetu - | Parrayrefs -> rhs = Parrayrefs - | Parraysets -> rhs = Parraysets - | Pint64ofint -> rhs = Pint64ofint - | Pintofint64 -> rhs = Pintofint64 - | Pnegint64 -> rhs = Pnegint64 - | Paddint64 -> rhs = Paddint64 - | Psubint64 -> rhs = Psubint64 - | Pmulint64 -> rhs = Pmulint64 - | Pdivint64 -> rhs = Pdivint64 - | Pmodint64 -> rhs = Pmodint64 - | Pandint64 -> rhs = Pandint64 - | Porint64 -> rhs = Porint64 - | Pxorint64 -> rhs = Pxorint64 - | Plslint64 -> rhs = Plslint64 - | Plsrint64 -> rhs = Plsrint64 - | Pasrint64 -> rhs = Pasrint64 - | Pint64comp comparison -> ( - match rhs with - | Pint64comp comparison1 -> - Lam_compat.eq_comparison comparison comparison1 - | _ -> false) - | Pctconst compile_time_constant -> ( - match rhs with - | Pctconst compile_time_constant1 -> - Lam_compat.eq_compile_time_constant compile_time_constant - compile_time_constant1 - | _ -> false) - | Pjs_unsafe_downgrade { name; setter } -> ( - match rhs with - | Pjs_unsafe_downgrade rhs -> name = rhs.name && setter = rhs.setter - | _ -> false) - | Pjs_fn_make i -> ( match rhs with Pjs_fn_make i1 -> i = i1 | _ -> false) - | Pjs_fn_make_unit -> rhs = Pjs_fn_make_unit - | Pvoid_run -> rhs = Pvoid_run - | Pfull_apply -> rhs = Pfull_apply - | Pjs_fn_method -> rhs = Pjs_fn_method - | Praw_js_code _ -> false -(* TOO lazy, here comparison is only approximation*) diff --git a/jscomp/core/lam_primitive.mli b/jscomp/core/lam_primitive.mli deleted file mode 100644 index 31ba475..0000000 --- a/jscomp/core/lam_primitive.mli +++ /dev/null @@ -1,160 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type ident = Ident.t - -type record_representation = - | Record_regular - | Record_inlined of { tag : int; name : string; num_nonconsts : int } (* Inlined record *) - | Record_extension -(* Inlined record under extension *) - -type t = - | Pbytes_to_string - | Pmakeblock of int * Lam_tag_info.t * Asttypes.mutable_flag - | Pfield of int * Lambda.field_dbg_info - | Psetfield of int * Lambda.set_field_dbg_info - | Pduprecord - | Plazyforce - | Pccall of { prim_name : string } - | Pjs_call of { - (* Location.t * [loc] is passed down *) - prim_name : string; - arg_types : External_arg_spec.params; - ffi : External_ffi_types.external_spec; - dynamic_import: bool; - } - | Pjs_object_create of External_arg_spec.obj_params - | Praise - | Psequand - | Psequor - | Pnot - | Pnegint - | Paddint - | Psubint - | Pmulint - | Pdivint - | Pmodint - | Pandint - | Porint - | Pxorint - | Plslint - | Plsrint - | Pasrint - | Poffsetint of int - | Poffsetref of int - | Pintoffloat - | Pfloatofint - | Pnegfloat - | Paddfloat - | Psubfloat - | Pmulfloat - | Pdivfloat - | Pnegbigint - | Paddbigint - | Psubbigint - | Pmulbigint - | Pdivbigint - | Pmodbigint - | Ppowbigint - | Pandbigint - | Porbigint - | Pxorbigint - | Plslbigint - | Pasrbigint - | Pintcomp of Lam_compat.comparison - | Pfloatcomp of Lam_compat.comparison - | Pjscomp of Lam_compat.comparison - | Pint64comp of Lam_compat.comparison - | Pbigintcomp of Lam_compat.comparison - | Pjs_apply (*[f;arg0;arg1; arg2; ... argN]*) - | Pjs_runtime_apply (* [f; [...]] *) - | Pstringlength - | Pstringrefu - | Pstringrefs - | Pstringadd - | Pbyteslength - | Pbytesrefu - | Pbytessetu - | Pbytesrefs - | Pbytessets - (* Array operations *) - | Pmakearray - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* Test if the argument is a block or an immediate integer *) - | Pisint - | Pis_poly_var_block - (* Test if the (integer) argument is outside an interval *) - | Pisout of int - (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) - | Pint64ofint - | Pintofint64 - | Pnegint64 - | Paddint64 - | Psubint64 - | Pmulint64 - | Pdivint64 - | Pmodint64 - | Pandint64 - | Porint64 - | Pxorint64 - | Plslint64 - | Plsrint64 - | Pasrint64 - (* Compile time constants *) - | Pctconst of Lam_compat.compile_time_constant - (* Integer to external pointer *) - | Pdebugger - | Pjs_unsafe_downgrade of { name : string; setter : bool } - | Pinit_mod - | Pupdate_mod - | Praw_js_code of Js_raw_info.t - | Pjs_fn_make of int - | Pjs_fn_make_unit - | Pvoid_run - | Pfull_apply - | Pjs_fn_method - | Pundefined_to_opt - | Pnull_to_opt - | Pnull_undefined_to_opt - | Pis_null - | Pis_undefined - | Pis_null_undefined - | Pimport - | Pjs_typeof - | Pjs_function_length - | Pcaml_obj_length - | Pwrap_exn (* convert either JS exception or OCaml exception into OCaml format *) - | Pcreate_extension of string - | Pis_not_none - | Pval_from_option - | Pval_from_option_not_nest - | Psome - | Psome_not_nest - -val eq_primitive_approx : t -> t -> bool diff --git a/jscomp/core/lam_print.ml b/jscomp/core/lam_print.ml deleted file mode 100644 index 47496d0..0000000 --- a/jscomp/core/lam_print.ml +++ /dev/null @@ -1,471 +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 Q Public License version 1.0. *) -(* *) -(***********************************************************************) - -open Format -open Asttypes - -let rec struct_const ppf (cst : Lam_constant.t) = - match cst with - | Const_js_true -> fprintf ppf "#true" - | Const_js_false -> fprintf ppf "#false" - | Const_js_null -> fprintf ppf "#null" - | Const_module_alias -> fprintf ppf "#alias" - | Const_js_undefined _ -> fprintf ppf "#undefined" - | Const_int { i } -> fprintf ppf "%ld" i - | Const_char i -> fprintf ppf "%s" (Ext_util.string_of_int_as_char i) - | Const_string { s } -> fprintf ppf "%S" s - | Const_float f -> fprintf ppf "%s" f - | Const_int64 n -> fprintf ppf "%LiL" n - | Const_bigint (sign, i) -> fprintf ppf "%sn" (Bigint_utils.to_string sign i) - | Const_pointer name -> fprintf ppf "`%s" name - | Const_some n -> fprintf ppf "[some-c]%a" struct_const n - | Const_block (tag, _, []) -> fprintf ppf "[%i]" tag - | Const_block (tag, _, sc1 :: scl) -> - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl - in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl - | Const_float_array [] -> fprintf ppf "[| |]" - | Const_float_array (f1 :: fl) -> - let floats ppf fl = List.iter (fun f -> fprintf ppf "@ %s" f) fl in - fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl - -(* let string_of_loc_kind (loc : Lambda.loc_kind) = - match loc with - | Loc_FILE -> "loc_FILE" - | Loc_LINE -> "loc_LINE" - | Loc_MODULE -> "loc_MODULE" - | Loc_POS -> "loc_POS" - | Loc_LOC -> "loc_LOC" *) - -let primitive ppf (prim : Lam_primitive.t) = - match prim with - (* | Pcreate_exception s -> fprintf ppf "[exn-create]%S" s *) - | Pcreate_extension s -> fprintf ppf "[ext-create]%S" s - | Pwrap_exn -> fprintf ppf "#exn" - | Pcaml_obj_length -> fprintf ppf "#obj_length" - | Pinit_mod -> fprintf ppf "init_mod!" - | Pupdate_mod -> fprintf ppf "update_mod!" - | Pbytes_to_string -> fprintf ppf "bytes_to_string" - | Pjs_apply -> fprintf ppf "#apply" - | Pjs_runtime_apply -> fprintf ppf "#runtime_apply" - | Pjs_unsafe_downgrade { name; setter } -> - if setter then fprintf ppf "##%s#=" name else fprintf ppf "##%s" name - | Pjs_function_length -> fprintf ppf "#function_length" - | Pvoid_run -> fprintf ppf "#run" - | Pfull_apply -> fprintf ppf "#full_apply" - | Pjs_fn_make i -> fprintf ppf "js_fn_make_%i" i - | Pjs_fn_make_unit -> fprintf ppf "js_fn_make_unit" - | Pjs_fn_method -> fprintf ppf "js_fn_method" - | Pdebugger -> fprintf ppf "debugger" - | Praw_js_code _ -> fprintf ppf "[raw]" - | Pjs_typeof -> fprintf ppf "[typeof]" - | Pnull_to_opt -> fprintf ppf "[null->opt]" - | Pundefined_to_opt -> fprintf ppf "[undefined->opt]" - | Pnull_undefined_to_opt -> fprintf ppf "[null/undefined->opt]" - | Pis_null -> fprintf ppf "[?null]" - | Pis_not_none -> fprintf ppf "[?is-not-none]" - | Psome -> fprintf ppf "[some]" - | Psome_not_nest -> fprintf ppf "[some-not-nest]" - | Pval_from_option -> fprintf ppf "[?unbox]" - | Pval_from_option_not_nest -> fprintf ppf "[?unbox-not-nest]" - | Pis_undefined -> fprintf ppf "[?undefined]" - | Pis_null_undefined -> fprintf ppf "[?null?undefined]" - | Pimport -> fprintf ppf "[import]" - | Pmakeblock (tag, _, Immutable) -> fprintf ppf "makeblock %i" tag - | Pmakeblock (tag, _, Mutable) -> fprintf ppf "makemutable %i" tag - | Pfield (n, field_info) -> ( - match Lam_compat.str_of_field_info field_info with - | None -> fprintf ppf "field %i" n - | Some s -> fprintf ppf "field %s/%i" s n) - | Psetfield (n, _) -> - let instr = "setfield " in - fprintf ppf "%s%i" instr n - | Pduprecord -> fprintf ppf "duprecord" - | Plazyforce -> fprintf ppf "force" - | Pccall p -> fprintf ppf "%s" p.prim_name - | Pjs_call { prim_name } -> fprintf ppf "%s[js]" prim_name - | Pjs_object_create _ -> fprintf ppf "[js.obj]" - | Praise -> fprintf ppf "raise" - | Psequand -> fprintf ppf "&&" - | Psequor -> fprintf ppf "||" - | Pnot -> fprintf ppf "not" - | Pnegint -> fprintf ppf "~" - | Paddint -> fprintf ppf "+" - | Pstringadd -> fprintf ppf "+*" - | Psubint -> fprintf ppf "-" - | Pmulint -> fprintf ppf "*" - | Pdivint -> fprintf ppf "/" - | Pmodint -> fprintf ppf "mod" - | Pandint -> fprintf ppf "and" - | Porint -> fprintf ppf "or" - | Pxorint -> fprintf ppf "xor" - | Plslint -> fprintf ppf "lsl" - | Plsrint -> fprintf ppf "lsr" - | Pasrint -> fprintf ppf "asr" - | Pintcomp Ceq -> fprintf ppf "==[int]" - | Pintcomp Cneq -> fprintf ppf "!=[int]" - | Pintcomp Clt -> fprintf ppf "<" - | Pintcomp Cle -> fprintf ppf "<=" - | Pintcomp Cgt -> fprintf ppf ">" - | Pintcomp Cge -> fprintf ppf ">=" - | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i" n - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint -> fprintf ppf "float_of_int" - | Pnegfloat -> fprintf ppf "~." - (* | Pabsfloat -> fprintf ppf "abs." *) - | Paddfloat -> fprintf ppf "+." - | Psubfloat -> fprintf ppf "-." - | Pmulfloat -> fprintf ppf "*." - | Pdivfloat -> fprintf ppf "/." - | Pfloatcomp Ceq -> fprintf ppf "==." - | Pfloatcomp Cneq -> fprintf ppf "!=." - | Pfloatcomp Clt -> fprintf ppf "<." - | Pfloatcomp Cle -> fprintf ppf "<=." - | Pfloatcomp Cgt -> fprintf ppf ">." - | Pfloatcomp Cge -> fprintf ppf ">=." - | Pnegbigint -> fprintf ppf "~" - | Paddbigint -> fprintf ppf "+" - | Psubbigint -> fprintf ppf "-" - | Pmulbigint -> fprintf ppf "*" - | Pdivbigint -> fprintf ppf "/" - | Pmodbigint -> fprintf ppf "mod" - | Ppowbigint -> fprintf ppf "**" - | Pandbigint -> fprintf ppf "and" - | Porbigint -> fprintf ppf "or" - | Pxorbigint -> fprintf ppf "xor" - | Plslbigint -> fprintf ppf "lsl" - | Pasrbigint -> fprintf ppf "asr" - | Pbigintcomp Ceq -> fprintf ppf "==" - | Pbigintcomp Cneq -> fprintf ppf "!=" - | Pbigintcomp Clt -> fprintf ppf "<" - | Pbigintcomp Cle -> fprintf ppf "<=" - | Pbigintcomp Cgt -> fprintf ppf ">" - | Pbigintcomp Cge -> fprintf ppf ">=" - | Pjscomp Ceq -> fprintf ppf "#==" - | Pjscomp Cneq -> fprintf ppf "#!=" - | Pjscomp Clt -> fprintf ppf "#<" - | Pjscomp Cle -> fprintf ppf "#<=" - | Pjscomp Cgt -> fprintf ppf "#>" - | Pjscomp Cge -> fprintf ppf "#>=" - | Pstringlength -> fprintf ppf "string.length" - | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringrefs -> fprintf ppf "string.get" - | Pbyteslength -> fprintf ppf "bytes.length" - | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" - | Pbytessetu -> fprintf ppf "bytes.unsafe_set" - | Pbytesrefs -> fprintf ppf "bytes.get" - | Pbytessets -> fprintf ppf "bytes.set" - | Parraylength -> fprintf ppf "array.length" - | Pmakearray -> fprintf ppf "makearray" - | Parrayrefu -> fprintf ppf "array.unsafe_get" - | Parraysetu -> fprintf ppf "array.unsafe_set" - | Parrayrefs -> fprintf ppf "array.get" - | Parraysets -> fprintf ppf "array.set" - | Pctconst c -> - let const_name = - match c with - | Big_endian -> "big_endian" - | Ostype_unix -> "ostype_unix" - | Ostype_win32 -> "ostype_win32" - | Ostype -> "ostype" - | Backend_type -> "backend_type" - in - fprintf ppf "sys.constant_%s" const_name - | Pisint -> fprintf ppf "isint" - | Pis_poly_var_block -> fprintf ppf "#is_poly_var_block" - | Pisout i -> fprintf ppf "isout %d" i - | Pint64ofint -> fprintf ppf "of_int" - | Pintofint64 -> fprintf ppf "to_int" - | Pnegint64 -> fprintf ppf "neg64" - | Paddint64 -> fprintf ppf "add64" - | Psubint64 -> fprintf ppf "sub64" - | Pmulint64 -> fprintf ppf "mul64" - | Pdivint64 -> fprintf ppf "div64" - | Pmodint64 -> fprintf ppf "mod64" - | Pandint64 -> fprintf ppf "and64" - | Porint64 -> fprintf ppf "or64" - | Pxorint64 -> fprintf ppf "xor64" - | Plslint64 -> fprintf ppf "lsl64" - | Plsrint64 -> fprintf ppf "lsr64" - | Pasrint64 -> fprintf ppf "asr64" - | Pint64comp Ceq -> fprintf ppf "==" - | Pint64comp Cneq -> fprintf ppf "!=" - | Pint64comp Clt -> fprintf ppf "<" - | Pint64comp Cgt -> fprintf ppf ">" - | Pint64comp Cle -> fprintf ppf "<=" - | Pint64comp Cge -> fprintf ppf ">=" - -type print_kind = Alias | Strict | StrictOpt | Variable | Recursive - -let kind = function - | Alias -> "a" - | Strict -> "" - | StrictOpt -> "o" - | Variable -> "v" - | Recursive -> "r" - -let to_print_kind (k : Lam_compat.let_kind) : print_kind = - match k with - | Alias -> Alias - | Strict -> Strict - | StrictOpt -> StrictOpt - | Variable -> Variable - -let rec aux (acc : (print_kind * Ident.t * Lam.t) list) (lam : Lam.t) = - match lam with - | Llet (str3, id3, arg3, body3) -> - aux ((to_print_kind str3, id3, arg3) :: acc) body3 - | Lletrec (bind_args, body) -> - aux - (Ext_list.map_append bind_args acc (fun (id, l) -> (Recursive, id, l))) - body - | e -> (acc, e) - -(* type left_var = - { - kind : print_kind ; - id : Ident.t - } *) - -(* type left = - | Id of left_var *) -(* | Nop *) - -let flatten (lam : Lam.t) : (print_kind * Ident.t * Lam.t) list * Lam.t = - match lam with - | Llet (str, id, arg, body) -> aux [ (to_print_kind str, id, arg) ] body - | Lletrec (bind_args, body) -> - aux (Ext_list.map bind_args (fun (id, l) -> (Recursive, id, l))) body - | _ -> assert false - -(* let get_string ((id : Ident.t), (pos : int)) (env : Env.t) : string = - match Env.find_module (Pident id) env with - | {md_type = Mty_signature signature ; _ } -> - (* Env.prefix_idents, could be cached *) - let serializable_sigs = - Ext_list.filter (fun x -> - match x with - | Sig_typext _ - | Sig_module _ - | Sig_class _ -> true - | Sig_value(_, {val_kind = Val_prim _}) -> false - | Sig_value _ -> true - | _ -> false - ) signature in - (begin match Ext_list.nth_opt serializable_sigs pos with - | Some (Sig_value (i,_) - | Sig_module (i,_,_) - | Sig_typext (i,_,_) - | Sig_modtype(i,_) - | Sig_class (i,_,_) - | Sig_class_type(i,_,_) - | Sig_type(i,_,_)) -> i - | None -> assert false - end).name - | _ -> assert false -*) - -let lambda ppf v = - let rec lam ppf (l : Lam.t) = - match l with - | Lvar id -> Ident.print ppf id - | Lglobal_module (id, dynamic_import) -> fprintf ppf (if dynamic_import then "dynamic global %a" else "global %a") Ident.print id - | Lconst cst -> struct_const ppf cst - | Lapply { ap_func; ap_args; ap_info = { ap_inlined } } -> - let lams ppf args = - List.iter (fun l -> fprintf ppf "@ %a" lam l) args - in - fprintf ppf "@[<2>(apply%s@ %a%a)@]" - (match ap_inlined with Always_inline -> "%inlned" | _ -> "") - lam ap_func lams ap_args - | Lfunction { params; body; _ } -> - let pr_params ppf params = - List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params - (* | Tupled -> *) - (* fprintf ppf " ("; *) - (* let first = ref true in *) - (* List.iter *) - (* (fun param -> *) - (* if !first then first := false else fprintf ppf ",@ "; *) - (* Ident.print ppf param) *) - (* params; *) - (* fprintf ppf ")" *) - in - fprintf ppf "@[<2>(function%a@ %a)@]" pr_params params lam body - | (Llet _ | Lletrec _) as x -> - let args, body = flatten x in - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (k, id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a =%s@ %a@]" Ident.print id (kind k) lam l) - id_arg_list - in - fprintf ppf "@[<2>(let@ (@[%a@]" bindings (List.rev args); - fprintf ppf ")@ %a)@]" lam body - | Lprim - { - primitive = Pfield (n, Fld_module { name = s }); - args = [ Lglobal_module (id, dynamic_import) ]; - _; - } -> - fprintf ppf (if dynamic_import then "dynamic %s.%s/%d" else "%s.%s/%d") id.name s n - | Lprim { primitive = prim; args = largs; _ } -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch (larg, sw) -> - let switch ppf (sw : Lam.lambda_switch) = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i %S:@ %a@]" n - (match sw.sw_names with None -> "" | Some x -> x.consts.(n).name) - lam l) - sw.sw_consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i %S:@ %a@]" n - (match sw.sw_names with None -> "" | Some x -> x.blocks.(n).tag.name) - lam l) - sw.sw_blocks; - match sw.sw_failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - in - fprintf ppf "@[<1>(%s %a@ @[%a@])@]" - (match sw.sw_failaction with None -> "switch*" | _ -> "switch") - lam larg switch sw - | Lstringswitch (arg, cases, default) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - in - fprintf ppf "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases - | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs - in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls - | Lstaticcatch (lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" lam lbody i - (fun ppf vars -> - match vars with - | [] -> () - | _ -> List.iter (fun x -> fprintf ppf " %a" Ident.print x) vars) - vars lam lhandler - | Ltrywith (lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" lam lbody Ident.print - param lam lhandler - | Lifthenelse (lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Lsequence (l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Lwhile (lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Lfor (param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" Ident.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body - | Lassign (id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - and sequence ppf = function - | Lsequence (l1, l2) -> fprintf ppf "%a@ %a" sequence l1 sequence l2 - | l -> lam ppf l - in - lam ppf v - -(* let structured_constant = struct_const *) - -(* let rec flatten_seq acc (lam : Lam.t) = - match lam with - | Lsequence(l1,l2) -> - flatten_seq (flatten_seq acc l1) l2 - | x -> x :: acc *) - -(* exception Not_a_module *) - -(* let rec flat (acc : (left * Lam.t) list ) (lam : Lam.t) = - match lam with - | Llet (str,id,arg,body) -> - flat ( (Id {kind = to_print_kind str; id}, arg) :: acc) body - | Lletrec (bind_args, body) -> - flat - (Ext_list.map_append bind_args acc - (fun (id, arg ) -> (Id {kind = Recursive; id}, arg)) ) - body - | Lsequence (l,r) -> - flat (flat acc l) r - | x -> (Nop, x) :: acc *) - -(* let lambda_as_module env ppf (lam : Lam.t) = - try - (* match lam with *) - (* | Lprim {primitive = Psetglobal id ; args = [biglambda]; _} *) - (* might be wrong in toplevel *) - (* -> *) - - begin match flat [] lam with - | (Nop, Lprim {primitive = Pmakeblock (_, _, _); args = toplevels; _}) - :: rest -> - (* let spc = ref false in *) - List.iter - (fun (left, l) -> - match left with - | Id { kind = k; id } -> - fprintf ppf "@[<2>%a =%s@ %a@]@." Ident.print id (kind k) lambda l - | Nop -> - - fprintf ppf "@[<2>%a@]@." lambda l - ) - - @@ List.rev rest - - - | _ -> raise Not_a_module - end - (* | _ -> raise Not_a_module *) - with _ -> - lambda ppf lam; - fprintf ppf "; lambda-failure" *) - -let serialize (filename : string) (lam : Lam.t) : unit = - let ou = open_out filename in - let old = Format.get_margin () in - let () = Format.set_margin 10000 in - let fmt = Format.formatter_of_out_channel ou in - (* lambda_as_module env fmt lambda; *) - lambda fmt lam; - Format.pp_print_flush fmt (); - close_out ou; - Format.set_margin old - -let lambda_to_string = Format.asprintf "%a" lambda - -let primitive_to_string = Format.asprintf "%a" primitive diff --git a/jscomp/core/lam_print.mli b/jscomp/core/lam_print.mli deleted file mode 100644 index 3830133..0000000 --- a/jscomp/core/lam_print.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val lambda : Format.formatter -> Lam.t -> unit - -val primitive : Format.formatter -> Lam_primitive.t -> unit - -val serialize : string -> Lam.t -> unit - -val lambda_to_string : Lam.t -> string - -val primitive_to_string : Lam_primitive.t -> string diff --git a/jscomp/core/lam_scc.ml b/jscomp/core/lam_scc.ml deleted file mode 100644 index f1efa4d..0000000 --- a/jscomp/core/lam_scc.ml +++ /dev/null @@ -1,154 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - [hit_mask mask lambda] iters through the lambda - set the bit of corresponding [id] if [id] is hit. - As an optimization step if [mask_and_check_all_hit], - there is no need to iter such lambda any more -*) -let hit_mask (mask : Hash_set_ident_mask.t) (l : Lam.t) : bool = - let rec hit_opt (x : Lam.t option) = - match x with None -> false | Some a -> hit a - and hit_var (id : Ident.t) = - Hash_set_ident_mask.mask_and_check_all_hit mask id - and hit_list_snd : 'a. ('a * Lam.t) list -> bool = - fun x -> Ext_list.exists_snd x hit - and hit_list xs = Ext_list.exists xs hit - and hit (l : Lam.t) = - match l with - | Lvar id -> hit_var id - | Lassign (id, e) -> hit_var id || hit e - | Lstaticcatch (e1, (_, _), e2) -> hit e1 || hit e2 - | Ltrywith (e1, _exn, e2) -> hit e1 || hit e2 - | Lfunction { body; params = _ } -> hit body - | Llet (_str, _id, arg, body) -> hit arg || hit body - | Lletrec (decl, body) -> hit body || hit_list_snd decl - | Lfor (_v, e1, e2, _dir, e3) -> hit e1 || hit e2 || hit e3 - | Lconst _ -> false - | Lapply { ap_func; ap_args; _ } -> hit ap_func || hit_list ap_args - | Lglobal_module _ (* playsafe *) -> false - | Lprim { args; _ } -> hit_list args - | Lswitch (arg, sw) -> - hit arg || hit_list_snd sw.sw_consts || hit_list_snd sw.sw_blocks - || hit_opt sw.sw_failaction - | Lstringswitch (arg, cases, default) -> - hit arg || hit_list_snd cases || hit_opt default - | Lstaticraise (_, args) -> hit_list args - | Lifthenelse (e1, e2, e3) -> hit e1 || hit e2 || hit e3 - | Lsequence (e1, e2) -> hit e1 || hit e2 - | Lwhile (e1, e2) -> hit e1 || hit e2 - in - hit l - -type bindings = (Ident.t * Lam.t) list - -let preprocess_deps (groups : bindings) : _ * Ident.t array * Vec_int.t array = - let len = List.length groups in - let domain : _ Ordered_hash_map_local_ident.t = - Ordered_hash_map_local_ident.create len - in - let mask = Hash_set_ident_mask.create len in - Ext_list.iter groups (fun (x, lam) -> - Ordered_hash_map_local_ident.add domain x lam; - Hash_set_ident_mask.add_unmask mask x); - let int_mapping = Ordered_hash_map_local_ident.to_sorted_array domain in - let node_vec = Array.make (Array.length int_mapping) (Vec_int.empty ()) in - Ordered_hash_map_local_ident.iter domain (fun _id lam key_index -> - let base_key = node_vec.(key_index) in - ignore (hit_mask mask lam); - Hash_set_ident_mask.iter_and_unmask mask (fun ident hit -> - if hit then - let key = Ordered_hash_map_local_ident.rank domain ident in - Vec_int.push base_key key)); - (domain, int_mapping, node_vec) - -let is_function_bind (_, (x : Lam.t)) = - match x with Lfunction _ -> true | _ -> false - -let sort_single_binding_group (group : bindings) = - if Ext_list.for_all group is_function_bind then group - else - List.sort - (fun (_, lama) (_, lamb) -> - match ((lama : Lam.t), (lamb : Lam.t)) with - | Lfunction _, Lfunction _ -> 0 - | Lfunction _, _ -> -1 - | _, Lfunction _ -> 1 - | _, _ -> 0) - group - -(** TODO: even for a singleton recursive function, tell whehter it is recursive or not ? *) -let scc_bindings (groups : bindings) : bindings list = - match groups with - | [ _ ] -> [ sort_single_binding_group groups ] - | _ -> - let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters : Int_vec_vec.t = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then - [ sort_single_binding_group groups ] - else - Int_vec_vec.fold_right - (fun (v : Vec_int.t) acc -> - let bindings = - Vec_int.map_into_list - (fun i -> - let id = int_mapping.(i) in - let lam = Ordered_hash_map_local_ident.find_value domain id in - (id, lam)) - v - in - sort_single_binding_group bindings :: acc) - clusters [] - -(* single binding, it does not make sense to do scc, - we can eliminate {[ let rec f x = x + x ]}, but it happens rarely in real world -*) -let scc (groups : bindings) (lam : Lam.t) (body : Lam.t) = - match groups with - | [ (id, bind) ] -> - if Lam_hit.hit_variable id bind then lam else Lam.let_ Strict id bind body - | _ -> - let domain, int_mapping, node_vec = preprocess_deps groups in - let clusters = Ext_scc.graph node_vec in - if Int_vec_vec.length clusters <= 1 then lam - else - Int_vec_vec.fold_right - (fun (v : Vec_int.t) acc -> - let bindings = - Vec_int.map_into_list - (fun i -> - let id = int_mapping.(i) in - let lam = Ordered_hash_map_local_ident.find_value domain id in - (id, lam)) - v - in - match bindings with - | [ (id, lam) ] -> - let base_key = Ordered_hash_map_local_ident.rank domain id in - if Int_vec_util.mem base_key node_vec.(base_key) then - Lam.letrec bindings acc - else Lam.let_ Strict id lam acc - | _ -> Lam.letrec bindings acc) - clusters body diff --git a/jscomp/core/lam_scc.mli b/jscomp/core/lam_scc.mli deleted file mode 100644 index 46cf481..0000000 --- a/jscomp/core/lam_scc.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type bindings = (Ident.t * Lam.t) list - -val scc_bindings : bindings -> bindings list - -val scc : bindings -> Lam.t -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_stats.ml b/jscomp/core/lam_stats.ml deleted file mode 100644 index 8ca1b05..0000000 --- a/jscomp/core/lam_stats.ml +++ /dev/null @@ -1,73 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* It can be useful for common sub expression elimination ? - if two lambdas are not equal, it should return false, other wise, - it might return true , this is only used as a way of optimizaton - - Use case : - 1. switch case -- common fall through -*) - -(* lambda pass for alpha conversion - and alias - we need think about the order of the pass, might be the alias pass can be done - in the beginning, when we do alpha conversion, we can instrument the table -*) - -(* type alias_tbl = Ident.t Hash_ident.t *) - -type ident_tbl = Lam_id_kind.t Hash_ident.t - -type t = { - export_idents : Set_ident.t; - exports : Ident.t list; - (*It is kept since order matters? *) - ident_tbl : ident_tbl; - (** we don't need count arities for all identifiers, for identifiers - for sure it's not a function, there is no need to count them - *) -} - -let pp = Format.fprintf - -(* let pp_alias_tbl fmt (tbl : alias_tbl) = - Hash_ident.iter tbl (fun k v -> pp fmt "@[%a -> %a@]@." Ident.print k Ident.print v) *) - -let pp_ident_tbl fmt (ident_tbl : ident_tbl) = - Hash_ident.iter ident_tbl (fun k v -> - pp fmt "@[%a -> %a@]@." Ident.print k Lam_id_kind.print v) - -let print fmt (v : t) = - pp fmt "@[Ident table:@ @[%a@]@]" pp_ident_tbl v.ident_tbl; - pp fmt "@[exports:@ @[%a@]@]" - (Format.pp_print_list ~pp_sep:(fun fmt () -> pp fmt "@ ;") Ident.print) - v.exports - -let make ~export_idents ~export_ident_sets : t = - { - ident_tbl = Hash_ident.create 31; - exports = export_idents; - export_idents = export_ident_sets; - } diff --git a/jscomp/core/lam_stats.mli b/jscomp/core/lam_stats.mli deleted file mode 100644 index d8a3d34..0000000 --- a/jscomp/core/lam_stats.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Types defined for lambda analysis *) - -(** Keep track of which identifiers are aliased -*) - -type ident_tbl = Lam_id_kind.t Hash_ident.t - -type t = { - export_idents : Set_ident.t; - exports : Ident.t list; - ident_tbl : ident_tbl; - (** we don't need count arities for all identifiers, for identifiers - for sure it's not a function, there is no need to count them - *) -} - -val print : Format.formatter -> t -> unit - -val make : export_idents:Ident.t list -> export_ident_sets:Set_ident.t -> t diff --git a/jscomp/core/lam_stats_export.ml b/jscomp/core/lam_stats_export.ml deleted file mode 100644 index c4b98bb..0000000 --- a/jscomp/core/lam_stats_export.ml +++ /dev/null @@ -1,140 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* let pp = Format.fprintf *) -(* we should exclude meaninglist names and do the convert as well *) - -(* let meaningless_names = ["*opt*"; "param";] *) - -let single_na = Js_cmj_format.single_na - -let values_of_export (meta : Lam_stats.t) (export_map : Lam.t Map_ident.t) : - Js_cmj_format.cmj_value Map_string.t = - Ext_list.fold_left meta.exports Map_string.empty (fun acc x -> - let arity : Js_cmj_format.arity = - match Hash_ident.find_opt meta.ident_tbl x with - | Some (FunctionId { arity; _ }) -> Single arity - | Some (ImmutableBlock elems) -> - (* FIXME: field name for dumping*) - Submodule - (Ext_array.map elems (fun x -> - match x with - | NA -> Lam_arity.na - | SimpleForm lam -> Lam_arity_analysis.get_arity meta lam)) - | Some _ | None -> ( - match Map_ident.find_opt export_map x with - | Some (Lprim { primitive = Pmakeblock (_, _, Immutable); args }) -> - Submodule - (Ext_array.of_list_map args (fun lam -> - Lam_arity_analysis.get_arity meta lam)) - | Some _ | None -> single_na) - in - let persistent_closed_lambda = - let optlam = Map_ident.find_opt export_map x in - match optlam with - | Some - (Lconst - ( Const_js_null | Const_js_undefined _ | Const_js_true - | Const_js_false )) - | None -> - optlam - | Some lambda -> - if not !Js_config.cross_module_inline then None - else if - Lam_analysis.safe_to_inline lambda - (* when inlning a non function, we have to be very careful, - only truly immutable values can be inlined - *) - then - match lambda with - | Lfunction { attr = { inline = Always_inline } } - (* FIXME: is_closed lambda is too restrictive - It precludes ues cases - - inline forEach but not forEachU - *) - | Lfunction { attr = { is_a_functor = true } } -> - if Lam_closure.is_closed lambda (* TODO: seriealize more*) - then optlam - else None - | _ -> - let lam_size = Lam_analysis.size lambda in - (* TODO: - 1. global need re-assocate when do the beta reduction - 2. [lambda_exports] is not precise - *) - let free_variables = - Lam_closure.free_variables Set_ident.empty Map_ident.empty - lambda - in - if - lam_size < Lam_analysis.small_inline_size - && Map_ident.is_empty free_variables - then ( - Ext_log.dwarn ~__POS__ "%s recorded for inlining @." x.name; - optlam) - else None - else None - in - match (arity, persistent_closed_lambda) with - | Single Arity_na, (None | Some (Lconst Const_module_alias)) -> acc - | Submodule [||], None -> acc - | _ -> - let cmj_value : Js_cmj_format.cmj_value = - { arity; persistent_closed_lambda } - in - Map_string.add acc x.name cmj_value) - -(* ATTENTION: all runtime modules, if it is not hard required, - it should be okay to not reference it -*) -let get_dependent_module_effect (maybe_pure : string option) - (external_ids : Lam_module_ident.t list) = - if maybe_pure = None then - let non_pure_module = - Ext_list.find_first_not external_ids Lam_compile_env.is_pure_module - in - Ext_option.map non_pure_module (fun x -> Lam_module_ident.name x) - else maybe_pure - -(* Note that - [lambda_exports] is - lambda expression to be exported - for the js backend, we compile to js - for the inliner, we try to serialize it -- - relies on other optimizations to make this happen - {[ - exports.Make = function () {.....} - ]} - TODO: check that we don't do this in browser environment -*) -let export_to_cmj (meta : Lam_stats.t) effect export_map case : Js_cmj_format.t - = - let values = values_of_export meta export_map in - - Js_cmj_format.make ~values ~effect - ~package_spec:(Js_packages_state.get_packages_info ()) - ~case -(* FIXME: make sure [-o] would not change its case - add test for ns/non-ns -*) diff --git a/jscomp/core/lam_stats_export.mli b/jscomp/core/lam_stats_export.mli deleted file mode 100644 index 717fbd5..0000000 --- a/jscomp/core/lam_stats_export.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val get_dependent_module_effect : - string option -> Lam_module_ident.t list -> string option - -val export_to_cmj : - Lam_stats.t -> - Js_cmj_format.effect -> - Lam.t Map_ident.t -> - Ext_js_file_kind.case -> - Js_cmj_format.t diff --git a/jscomp/core/lam_subst.ml b/jscomp/core/lam_subst.ml deleted file mode 100644 index 0d189ed..0000000 --- a/jscomp/core/lam_subst.ml +++ /dev/null @@ -1,74 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -let subst (s : Lam.t Map_ident.t) lam = - let rec subst_aux (x : Lam.t) : Lam.t = - match x with - | Lvar id -> Map_ident.find_default s id x - | Lconst _ -> x - | Lapply { ap_func; ap_args; ap_info } -> - Lam.apply (subst_aux ap_func) (Ext_list.map ap_args subst_aux) ap_info - | Lfunction { arity; params; body; attr } -> - Lam.function_ ~arity ~params ~body:(subst_aux body) ~attr - | Llet (str, id, arg, body) -> - Lam.let_ str id (subst_aux arg) (subst_aux body) - | Lletrec (decl, body) -> - Lam.letrec (Ext_list.map decl subst_decl) (subst_aux body) - | Lprim { primitive; args; loc } -> - Lam.prim ~primitive ~args:(Ext_list.map args subst_aux) loc - | Lglobal_module _ -> x - | Lswitch (arg, sw) -> - Lam.switch (subst_aux arg) - { - sw with - sw_consts = Ext_list.map sw.sw_consts subst_case; - sw_blocks = Ext_list.map sw.sw_blocks subst_case; - sw_failaction = subst_opt sw.sw_failaction; - } - | Lstringswitch (arg, cases, default) -> - Lam.stringswitch (subst_aux arg) - (Ext_list.map cases subst_strcase) - (subst_opt default) - | Lstaticraise (i, args) -> Lam.staticraise i (Ext_list.map args subst_aux) - | Lstaticcatch (e1, io, e2) -> - Lam.staticcatch (subst_aux e1) io (subst_aux e2) - | Ltrywith (e1, exn, e2) -> Lam.try_ (subst_aux e1) exn (subst_aux e2) - | Lifthenelse (e1, e2, e3) -> - Lam.if_ (subst_aux e1) (subst_aux e2) (subst_aux e3) - | Lsequence (e1, e2) -> Lam.seq (subst_aux e1) (subst_aux e2) - | Lwhile (e1, e2) -> Lam.while_ (subst_aux e1) (subst_aux e2) - | Lfor (v, e1, e2, dir, e3) -> - Lam.for_ v (subst_aux e1) (subst_aux e2) dir (subst_aux e3) - | Lassign (id, e) -> Lam.assign id (subst_aux e) - and subst_decl (id, exp) = (id, subst_aux exp) - and subst_case (key, case) = (key, subst_aux case) - and subst_strcase (key, case) = (key, subst_aux case) - and subst_opt = function None -> None | Some e -> Some (subst_aux e) in - subst_aux lam diff --git a/jscomp/core/lam_subst.mli b/jscomp/core/lam_subst.mli deleted file mode 100644 index 00836dc..0000000 --- a/jscomp/core/lam_subst.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -val subst : Lam.t Map_ident.t -> Lam.t -> Lam.t diff --git a/jscomp/core/lam_tag_info.ml b/jscomp/core/lam_tag_info.ml deleted file mode 100644 index dddd3d9..0000000 --- a/jscomp/core/lam_tag_info.ml +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2018-Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Similiar to {!Lambda.tag_info} - In particular, - it reduces some branches e.g, - [Blk_some], [Blk_some_not_nested] -*) -type t = Lambda.tag_info diff --git a/jscomp/core/lam_util.ml b/jscomp/core/lam_util.ml deleted file mode 100644 index 36fc31b..0000000 --- a/jscomp/core/lam_util.ml +++ /dev/null @@ -1,279 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - - - - -(* -let add_required_modules ( x : Ident.t list) (meta : Lam_stats.t) = - let meta_require_modules = meta.required_modules in - List.iter (fun x -> add meta_require_modules (Lam_module_ident.of_ml x)) x -*) - - -(* - It's impossible to have a case like below: - {[ - (let export_f = ... in export_f) - ]} - Even so, it's still correct -*) -let refine_let - ~kind param - (arg : Lam.t) (l : Lam.t) : Lam.t = - - match (kind : Lam_compat.let_kind ), arg, l with - | _, _, Lvar w when Ident.same w param - (* let k = xx in k - there is no [rec] so [k] would not appear in [xx] - *) - -> arg (* TODO: optimize here -- it's safe to do substitution here *) - | _, _, Lprim {primitive ; args = [Lvar w]; loc ; _} when Ident.same w param - && (function | Lam_primitive.Pmakeblock _ -> false | _ -> true) primitive - (* don't inline inside a block *) - -> Lam.prim ~primitive ~args:[arg] loc - (* we can not do this substitution when capttured *) - (* | _, Lvar _, _ -> (\** let u = h in xxx*\) *) - (* (\* assert false *\) *) - (* Ext_log.err "@[substitution >> @]@."; *) - (* let v= subst_lambda (Map_ident.singleton param arg ) l in *) - (* Ext_log.err "@[substitution << @]@."; *) - (* v *) - | _, _, Lapply {ap_func=fn; ap_args = [Lvar w]; ap_info} when - Ident.same w param && - (not (Lam_hit.hit_variable param fn )) - -> - (* does not work for multiple args since - evaluation order unspecified, does not apply - for [js] in general, since the scope of js ir is loosen - - here we remove the definition of [param] - {[ let k = v in (body) k - ]} - #1667 make sure body does not hit k - *) - Lam.apply fn [arg] ap_info - | (Strict | StrictOpt ), - ( Lvar _ | Lconst _ | - Lprim {primitive = Pfield (_ , Fld_module _) ; - args = [ Lglobal_module _ | Lvar _ ]; _}) , _ -> - (* (match arg with *) - (* | Lconst _ -> *) - (* Ext_log.err "@[%a %s@]@." *) - (* Ident.print param (string_of_lambda arg) *) - (* | _ -> ()); *) - (* No side effect and does not depend on store, - since function evaluation is always delayed - *) - Lam.let_ Alias param arg l - | ( (Strict | StrictOpt ) ), (Lfunction _ ), _ -> - (*It can be promoted to [Alias], however, - we don't want to do this, since we don't want the - function to be inlined to a block, for example - {[ - let f = fun _ -> 1 in - [0, f] - ]} - TODO: punish inliner to inline functions - into a block - *) - Lam.let_ StrictOpt param arg l - (* Not the case, the block itself can have side effects - we can apply [no_side_effects] pass - | Some Strict, Lprim(Pmakeblock (_,_,Immutable),_) -> - Llet(StrictOpt, param, arg, l) - *) - | Strict, _ ,_ when Lam_analysis.no_side_effects arg -> - Lam.let_ StrictOpt param arg l - | Variable, _, _ -> - Lam.let_ Variable param arg l - | kind, _, _ -> - Lam.let_ kind param arg l -(* | None , _, _ -> - Lam.let_ Strict param arg l *) - -let alias_ident_or_global (meta : Lam_stats.t) (k:Ident.t) (v:Ident.t) - (v_kind : Lam_id_kind.t) = - (* treat rec as Strict, k is assigned to v - {[ let k = v ]} - *) - match v_kind with - | NA -> - begin - match Hash_ident.find_opt meta.ident_tbl v with - | None -> () - | Some ident_info -> Hash_ident.add meta.ident_tbl k ident_info - end - | ident_info -> Hash_ident.add meta.ident_tbl k ident_info - -(* share -- it is safe to share most properties, - for arity, we might be careful, only [Alias] can share, - since two values have same type, can have different arities - TODO: check with reference pass, it might break - since it will create new identifier, we can avoid such issue?? - - actually arity is a dynamic property, for a reference, it can - be changed across - we should treat - reference specially. or maybe we should track any - mutable reference -*) - - - - - -(* How we destruct the immutable block - depend on the block name itself, - good hints to do aggressive destructing - 1. the variable is not exported - like [matched] -- these are blocks constructed temporary - 2. how the variable is used - if it is guarateed to be - - non export - - and non escaped (there is no place it is used as a whole) - then we can always destruct it - if some fields are used in multiple places, we can create - a temporary field - - 3. It would be nice that when the block is mutable, its - mutable fields are explicit, since wen can not inline an mutable block access -*) - -let element_of_lambda (lam : Lam.t) : Lam_id_kind.element = - match lam with - | Lvar _ - | Lconst _ - | Lprim {primitive = Pfield (_, Fld_module _) ; - args = [ Lglobal_module _ | Lvar _ ]; - _} -> SimpleForm lam - (* | Lfunction _ *) - | _ -> NA - -let kind_of_lambda_block (xs : Lam.t list) : Lam_id_kind.t = - ImmutableBlock( Ext_array.of_list_map xs (fun x -> - element_of_lambda x )) - -let field_flatten_get - lam v i info (tbl : Lam_id_kind.t Hash_ident.t) : Lam.t = - match Hash_ident.find_opt tbl v with - | Some (Module g) -> - Lam.prim ~primitive:(Pfield (i, info)) - ~args:[ Lam.global_module g ] Location.none - | Some (ImmutableBlock (arr)) -> - begin match arr.(i) with - | NA -> lam () - | SimpleForm l -> l - | exception _ -> lam () - end - | Some (Constant (Const_block (_, Blk_record {fields}, ls))) -> - (match info with - | Fld_record {name} -> - let found = ref None in - for i = 0 to Array.length fields - 1 do - if fields.(i) = name then found := Ext_list.nth_opt ls i done; - (match !found with - | Some c -> Lam.const c - | None -> lam()) - | _ -> lam () - ) - | Some (Constant (Const_block (_,_,ls))) -> - begin match Ext_list.nth_opt ls i with - | None -> lam () - | Some x -> Lam.const x - end - | Some _ - | None -> lam () - - -(* TODO: check that if label belongs to a different - namesape -*) -let count = ref 0 - -let generate_label ?(name="") () = - incr count; - Printf.sprintf "%s_tailcall_%04d" name !count - -#if (defined BROWSER || defined RELEASE) -let dump ext lam = - () -#else -let log_counter = ref 0 -let dump ext lam = - if !Js_config.diagnose - then - (* ATTENTION: easy to introduce a bug during refactoring when forgeting `begin` `end`*) - begin - incr log_counter; - Ext_log.dwarn ~__POS__ "\n@[[TIME:]%s: %f@]@." ext (Sys.time () *. 1000.); - Lam_print.serialize - (Ext_filename.new_extension - !Location.input_name - (Printf.sprintf ".%02d%s.lam" !log_counter ext) - ) lam; - end -#endif - - - - - -let is_function (lam : Lam.t) = - match lam with - | Lfunction _ -> true | _ -> false - -let not_function (lam : Lam.t) = - match lam with - | Lfunction _ -> false | _ -> true -(* -let is_var (lam : Lam.t) id = - match lam with - | Lvar id0 -> Ident.same id0 id - | _ -> false *) - - -(* TODO: we need create - 1. a smart [let] combinator, reusable beta-reduction - 2. [lapply fn args info] - here [fn] should get the last tail - for example - {[ - lapply (let a = 3 in let b = 4 in fun x y -> x + y) 2 3 - ]} -*) - - - - - - - - diff --git a/jscomp/core/lam_util.mli b/jscomp/core/lam_util.mli deleted file mode 100644 index fc0b642..0000000 --- a/jscomp/core/lam_util.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val kind_of_lambda_block : Lam.t list -> Lam_id_kind.t - -val field_flatten_get : - (unit -> Lam.t) -> - Ident.t -> - int -> - Lambda.field_dbg_info -> - Lam_stats.ident_tbl -> - Lam.t -(** [field_flattern_get cb v i tbl] - try to remove the indirection of [v.(i)] by inlining when [v] - is a known block, - if not, it will call [cb ()]. - - Note due to different control flow, a constant block - may result in out-of bound access, in that case, we should - just ignore it. This does not mean our - optimization is wrong, it means we hit an unreachable branch. - for example - {{ - let myShape = A 10 in - match myShape with - | A x -> x (* only access field [0]*) - | B (x,y) -> x + y (* Here it will try to access field [1] *) - }} -*) - -val alias_ident_or_global : - Lam_stats.t -> Ident.t -> Ident.t -> Lam_id_kind.t -> unit - -val refine_let : kind:Lam_compat.let_kind -> Ident.t -> Lam.t -> Lam.t -> Lam.t - -val generate_label : ?name:string -> unit -> J.label - -val dump : string -> Lam.t -> unit -(** [dump] when {!Js_config.is_same_file}*) - -val not_function : Lam.t -> bool - -val is_function : Lam.t -> bool diff --git a/jscomp/core/lam_var_stats.ml b/jscomp/core/lam_var_stats.ml deleted file mode 100644 index db39605..0000000 --- a/jscomp/core/lam_var_stats.ml +++ /dev/null @@ -1,69 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Used in loop, huge punishment *) -let loop_use = 100 - -type stats = { - top : bool; - (* all appearances are in the top, substitution is fine - whether it is pure or not - {[ - (fun x y - -> x + y + (f x )) (32) (console.log('hi'), 33) - ]} - since in ocaml, the application order is intentionally undefined, - note if [times] is not one, this field does not make sense - *) - times : int; -} - -let fresh_stats : stats = { top = true; times = 0 } - -let sink_stats : stats = { top = false; times = loop_use } - -(* let stats top times = {top; times} *) -let top_and_used_zero_or_one x = - match x with { top = true; times = 0 | 1 } -> true | _ -> false - -type position = - | Begin (* top = true ; loop = false *) - | Not_begin (* top = false; loop = false *) - | Sink -(* loop = true *) - -let update (v : stats) (pos : position) : stats = - match pos with - | Begin -> { v with times = v.times + 1 } - | Not_begin -> { top = false; times = v.times + 1 } - | Sink -> sink_stats - -let sink : position = Sink - -let fresh_env : position = Begin - -(* no side effect, if argument has no side effect and used only once we can simply do the replacement *) -let new_position_after_lam lam (env : position) : position = - if (not (env = Begin)) || Lam_analysis.no_side_effects lam then env - else Not_begin diff --git a/jscomp/core/lam_var_stats.mli b/jscomp/core/lam_var_stats.mli deleted file mode 100644 index f4c5b80..0000000 --- a/jscomp/core/lam_var_stats.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type stats - -val fresh_stats : stats - -val top_and_used_zero_or_one : stats -> bool - -type position - -val sink : position - -val fresh_env : position - -val new_position_after_lam : Lam.t -> position -> position - -val update : stats -> position -> stats -(** The variable used stats update depend - on the position of the variable*) diff --git a/jscomp/core/matching_polyfill.ml b/jscomp/core/matching_polyfill.ml deleted file mode 100644 index 8955813..0000000 --- a/jscomp/core/matching_polyfill.ml +++ /dev/null @@ -1,69 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let () = Ast_untagged_variants.extract_concrete_typedecl := Ctype.extract_concrete_typedecl -let () = Ast_untagged_variants.expand_head := Ctype.expand_head - -let names_from_construct_pattern (pat : Typedtree.pattern) = - let rec resolve_path n (path : Path.t) = - match Env.find_type path pat.pat_env with - | { type_kind = Type_variant cstrs; _ } -> Ast_untagged_variants.names_from_type_variant ~env:pat.pat_env cstrs - | { type_kind = Type_abstract; type_manifest = Some t; _ } -> ( - match (Ctype.unalias t).desc with - | Tconstr (pathn, _, _) -> - resolve_path (n + 1) pathn - | _ -> None) - | { type_kind = Type_abstract; type_manifest = None; _ } -> None - | { type_kind = Type_record _ | Type_open (* Exceptions *); _ } -> None - in - - match (Btype.repr pat.pat_type).desc with - | Tconstr (path, _, _) -> resolve_path 0 path - | _ -> assert false - -(** - Note it is a bit tricky when there is unbound var, - its type will be Tvar which is too complicated to support subtyping -*) -let variant_is_subtype (env : Env.t) (row_desc : Types.row_desc) - (ty : Types.type_expr) : bool = - match row_desc with - | { - row_closed = true; - row_fixed = _; - row_fields = (name, (Rabsent | Rpresent None)) :: rest; - } -> - if Ext_string.is_valid_hash_number name then - Ext_list.for_all rest (function - | name, (Rabsent | Rpresent None) -> - Ext_string.is_valid_hash_number name - | _ -> false) - && Typeopt.is_base_type env ty Predef.path_int - else - Ext_list.for_all rest (function - | name, (Rabsent | Rpresent None) -> - not (Ext_string.is_valid_hash_number name) - | _ -> false) - && Typeopt.is_base_type env ty Predef.path_string - | _ -> false diff --git a/jscomp/core/matching_polyfill.mli b/jscomp/core/matching_polyfill.mli deleted file mode 100644 index 5764981..0000000 --- a/jscomp/core/matching_polyfill.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2020 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val names_from_construct_pattern : - Typedtree.pattern -> Ast_untagged_variants.switch_names option - -val variant_is_subtype : Env.t -> Types.row_desc -> Types.type_expr -> bool diff --git a/jscomp/core/outcome_printer_ns.ml b/jscomp/core/outcome_printer_ns.ml deleted file mode 100644 index 2e0c1c5..0000000 --- a/jscomp/core/outcome_printer_ns.ml +++ /dev/null @@ -1,85 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let ps = Format.pp_print_string - -let out_ident ppf s = - ps ppf - (match s with - | "Js_null" -> "Js.Null" - | "Js_undefined" -> "Js.Undefined" - | "Js_null_undefined" -> "Js.Nullable" - | "Js_exn" -> "Js.Exn" - | "Js_array" -> "Js.Array" - | "Js_string" -> "Js.String" - | "Js_re" -> "Js.Re" - | "Js_promise" -> "Js.Promise" - | "Js_date" -> "Js.Date" - | "Js_dict" -> "Js.Dict" - | "Js_global" -> "Js.Global" - | "Js_json" -> "Js.Json" - | "Js_math" -> "Js.Math" - | "Js_obj" -> "Js.Obj" - | "Js_typed_array" -> "Js.Typed_array" - | "Js_types" -> "Js.Types" - | "Js_float" -> "Js.Float" - | "Js_int" -> "Js.Int" - | "Js_option" -> "Js.Option" - | "Js_result" -> "Js.Result" - | "Js_list" -> "Js.List" - | "Js_vector" -> "Js.Vector" - (* Belt_libs *) - | "Belt_Id" -> "Belt.Id" - | "Belt_Array" -> "Belt.Array" - | "Belt_SortArray" -> "Belt.SortArray" - | "Belt_SortArrayInt" -> "Belt.SortArray.Int" - | "Belt_SortArrayString" -> "Belt.SortArray.String" - | "Belt_MutableQueue" -> "Belt.MutableQueue" - | "Belt_MutableStack" -> "Belt.MutableStack" - | "Belt_List" -> "Belt.List" - | "Belt_Range" -> "Belt.Range" - | "Belt_Set" -> "Belt.Set" - | "Belt_SetInt" -> "Belt.Set.Int" - | "Belt_SetString" -> "Belt.Set.String" - | "Belt_Map" -> "Belt.Map" - | "Belt_MapInt" -> "Belt.Map.Int" - | "Belt_MapString" -> "Belt.Map.String" - | "Belt_Option" -> "Belt.Option" - | "Belt_MutableSet" -> "Belt.MutableSet" - | "Belt_MutableSetInt" -> "Belt.MutableSet.Int" - | "Belt_MutableSetString" -> "Belt.MutableSet.String" - | "Belt_MutableMap" -> "Belt.MutableMap" - | "Belt_MutableMapInt" -> "Belt.MutableMap.Int" - | "Belt_MutableMapString" -> "Belt.MutableMap.String" - | "Belt_HashSet" -> "Belt.HashSet" - | "Belt_HashSetInt" -> "Belt.HashSet.Int" - | "Belt_HashSetString" -> "Belt.HashSet.String" - | "Belt_HashMap" -> "Belt.HashMap" - | "Belt_HashMapString" -> "Belt.HashMap.String" - | "Belt_HashMapInt" -> "Belt.HashMap.Int" - | "Belt_Debug" -> "Belt.Debug" - | s -> ( - match Ext_namespace.try_split_module_name s with - | None -> s - | Some (ns, m) -> ns ^ "." ^ m)) diff --git a/jscomp/core/outcome_printer_ns.mli b/jscomp/core/outcome_printer_ns.mli deleted file mode 100644 index 5d2a04b..0000000 --- a/jscomp/core/outcome_printer_ns.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val out_ident : Format.formatter -> string -> unit -(** This function is used to - reverse namespace printing to - avoid namespace leaking -*) diff --git a/jscomp/core/polyvar_pattern_match.ml b/jscomp/core/polyvar_pattern_match.ml deleted file mode 100644 index ff785d8..0000000 --- a/jscomp/core/polyvar_pattern_match.ml +++ /dev/null @@ -1,115 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type lam = Lambda.lambda - -type hash_names = (int * string) list - -type input = (int * (string * lam)) list - -type output = (hash_names * lam) list - -module Coll = Hash.Make (struct - type t = lam - - let equal = Stdlib.( = ) - - let hash = Hashtbl.hash -end) - -type value = { stamp : int; hash_names_act : hash_names * lam } - -let convert (xs : input) : output = - let coll = Coll.create 63 in - let os : value list ref = ref [] in - xs - |> List.iteri (fun i (hash, (name, act)) -> - match Lambda.make_key act with - | None -> - os := - { stamp = i; hash_names_act = ([ (hash, name) ], act) } :: !os - | Some key -> - Coll.add_or_update coll key - ~update:(fun ({ hash_names_act = hash_names, act } as acc) -> - { acc with hash_names_act = ((hash, name) :: hash_names, act) }) - { hash_names_act = ([ (hash, name) ], act); stamp = i }); - let result = Coll.to_list coll (fun _ value -> value) @ !os in - Ext_list.sort_via_arrayf result - (fun x y -> compare x.stamp y.stamp) - (fun x -> x.hash_names_act) - -let or_list (arg : lam) (hash_names : (int * string) list) = - match hash_names with - | (hash, name) :: rest -> - let init : lam = - Lprim - ( Pintcomp Ceq, - [ arg; Lconst (Const_pointer (hash, Pt_variant { name })) ], - Location.none ) - in - Ext_list.fold_left rest init (fun acc (hash, name) -> - Lambda.Lprim - ( Psequor, - [ - acc; - Lprim - ( Pintcomp Ceq, - [ arg; Lconst (Const_pointer (hash, Pt_variant { name })) ], - Location.none ); - ], - Location.none )) - | _ -> assert false - -let make_test_sequence_variant_constant (fail : lam option) (arg : lam) - (int_lambda_list : (int * (string * lam)) list) : lam = - let int_lambda_list : ((int * string) list * lam) list = - convert int_lambda_list - in - match (int_lambda_list, fail) with - | (_, act) :: rest, None | rest, Some act -> - Ext_list.fold_right rest act (fun (hash_names, act1) acc -> - let predicate : lam = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) - | [], None -> assert false - -let call_switcher_variant_constant (_loc : Location.t) (fail : lam option) - (arg : lam) (int_lambda_list : (int * (string * lam)) list) - (_names : Ast_untagged_variants.switch_names option) = - let int_lambda_list = convert int_lambda_list in - match (int_lambda_list, fail) with - | (_, act) :: rest, None | rest, Some act -> - Ext_list.fold_right rest act (fun (hash_names, act1) acc -> - let predicate = or_list arg hash_names in - Lifthenelse (predicate, act1, acc)) - | [], None -> assert false - -let call_switcher_variant_constr (loc : Location.t) (fail : lam option) - (arg : lam) int_lambda_list (names : Ast_untagged_variants.switch_names option) : lam = - let v = Ident.create "variant" in - Llet - ( Alias, - Pgenval, - v, - Lprim (Pfield (0, Fld_poly_var_tag), [ arg ], loc), - call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) diff --git a/jscomp/core/pparse_driver.ml b/jscomp/core/pparse_driver.ml deleted file mode 100644 index 601a4fe..0000000 --- a/jscomp/core/pparse_driver.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* Optionally preprocess a source file *) - -let call_external_preprocessor sourcefile pp = - let tmpfile = Filename.temp_file "ocamlpp" "" in - let comm = - Printf.sprintf "%s %s > %s" pp (Filename.quote sourcefile) tmpfile - in - if Ccomp.command comm <> 0 then ( - Misc.remove_file tmpfile; - Cmd_ast_exception.cannot_run comm); - tmpfile - -let preprocess sourcefile = - match !Clflags.preprocessor with - | None -> sourcefile - | Some pp -> call_external_preprocessor sourcefile pp - -let remove_preprocessed inputfile = - if !Clflags.preprocessor <> None then Misc.remove_file inputfile - -(* Parse a file or get a dumped syntax tree from it *) - -let parse (type a) (kind : a Ml_binary.kind) : _ -> a = - match kind with - | Ml_binary.Ml -> Parse.implementation - | Ml_binary.Mli -> Parse.interface - -let file_aux inputfile (type a) (parse_fun : _ -> a) (kind : a Ml_binary.kind) : - a = - let ast_magic = Ml_binary.magic_of_kind kind in - let ic = open_in_bin inputfile in - let is_ast_file = - match really_input_string ic (String.length ast_magic) with - | exception _ -> false - | buffer -> - if buffer = ast_magic then true - else if Ext_string.starts_with buffer "Caml1999" then - Cmd_ast_exception.wrong_magic buffer - else false - in - let ast = - try - if is_ast_file then ( - Location.set_input_name (input_value ic : string); - (input_value ic : a)) - else ( - seek_in ic 0; - let lexbuf = Lexing.from_channel ic in - Location.init lexbuf inputfile; - parse_fun lexbuf) - with x -> - close_in ic; - raise x - in - close_in ic; - ast - -let parse_file (type a) (kind : a Ml_binary.kind) (sourcefile : string) : a = - Location.set_input_name sourcefile; - let inputfile = preprocess sourcefile in - let ast = - try file_aux inputfile (parse kind) kind - with exn -> - remove_preprocessed inputfile; - raise exn - in - remove_preprocessed inputfile; - ast - -let parse_implementation sourcefile = parse_file Ml sourcefile - -let parse_interface sourcefile = parse_file Mli sourcefile diff --git a/jscomp/core/pparse_driver.mli b/jscomp/core/pparse_driver.mli deleted file mode 100644 index b87dcd0..0000000 --- a/jscomp/core/pparse_driver.mli +++ /dev/null @@ -1,3 +0,0 @@ -val parse_implementation : string -> Parsetree.structure - -val parse_interface : string -> Parsetree.signature diff --git a/jscomp/core/record_attributes_check.ml b/jscomp/core/record_attributes_check.ml deleted file mode 100644 index c4bf854..0000000 --- a/jscomp/core/record_attributes_check.ml +++ /dev/null @@ -1,70 +0,0 @@ -(* Copyright (C) 2019- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type label = Types.label_description - -let find_name = Lambda.find_name - -let find_name_with_loc (attr : Parsetree.attribute) : string Asttypes.loc option - = - match attr with - | ( { txt = "bs.as" | "as"; loc }, - PStr - [ - { - pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _)) }, _); - }; - ] ) -> - Some { txt = s; loc } - | _ -> None - -let check_bs_attributes_inclusion (attrs1 : Parsetree.attributes) - (attrs2 : Parsetree.attributes) lbl_name = - let a = Ext_list.find_def attrs1 find_name lbl_name in - let b = Ext_list.find_def attrs2 find_name lbl_name in - if a = b then None else Some (a, b) - -let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list) - (coll : Set_string.t) = - match lbls with - | [] -> None - | { pld_name = { txt } as pld_name; pld_attributes } :: rest -> ( - if Set_string.mem coll txt && txt <> "..." then Some pld_name - else - let coll_with_lbl = Set_string.add coll txt in - match Ext_list.find_opt pld_attributes find_name_with_loc with - | None -> check_duplicated_labels_aux rest coll_with_lbl - | Some ({ txt = s } as l) -> - if - Set_string.mem coll s - (*use coll to make check a bit looser - allow cases like [ x : int [@as "x"]] - *) - then Some l - else - check_duplicated_labels_aux rest (Set_string.add coll_with_lbl s)) - -let check_duplicated_labels lbls = - check_duplicated_labels_aux lbls Set_string.empty diff --git a/jscomp/core/res_compmisc.ml b/jscomp/core/res_compmisc.ml deleted file mode 100644 index 6213e2e..0000000 --- a/jscomp/core/res_compmisc.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let init_path () = - let dirs = !Clflags.include_dirs in - let exp_dirs = - List.map (Misc.expand_directory Config.standard_library) dirs - in - Config.load_path := - if !Js_config.no_stdlib then exp_dirs - else (List.rev_append exp_dirs [Config.standard_library]); - Env.reset_cache () - -(* Return the initial environment in which compilation proceeds. *) - -(* Note: do not do init_path() in initial_env, this breaks - toplevel initialization (PR#1775) *) - -let open_implicit_module m env = - let lid = - { Asttypes.loc = Location.in_file "command line"; txt = Longident.parse m } - in - snd (Typemod.type_open_ Override env lid.loc lid) - -let initial_env ?(modulename) () = - Ident.reinit (); - let open_modules = (match modulename with - | None -> !Clflags.open_modules - | Some modulename -> - !Clflags.open_modules |> List.filter(fun m -> m <> modulename) - ) in - let initial = Env.initial_safe_string in - let env = - if !Clflags.nopervasives then initial - else open_implicit_module (if !Config.uncurried = Uncurried then "PervasivesU" else "Pervasives") initial - in - List.fold_left - (fun env m -> open_implicit_module m env) - env - (List.rev open_modules) diff --git a/jscomp/core/res_compmisc.mli b/jscomp/core/res_compmisc.mli deleted file mode 100644 index 0f17e43..0000000 --- a/jscomp/core/res_compmisc.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val init_path : unit -> unit - -val initial_env : ?modulename : string -> unit -> Env.t diff --git a/jscomp/depends/.ocamlformat b/jscomp/depends/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/depends/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/depends/ast_extract.ml b/jscomp/depends/ast_extract.ml deleted file mode 100644 index 0516fb1..0000000 --- a/jscomp/depends/ast_extract.ml +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* type module_name = private string *) - -module Set_string = Depend.StringSet - -(* FIXME: [Clflags.open_modules] seems not to be properly used *) -module SMap = Depend.StringMap - -let bound_vars = SMap.empty - -type 'a kind = 'a Ml_binary.kind - -let read_parse_and_extract (type t) (k : t kind) (ast : t) : Set_string.t = - Depend.free_structure_names := Set_string.empty; - Ext_ref.protect Clflags.transparent_modules false (fun _ -> - List.iter (* check *) - (fun modname -> - ignore @@ Depend.open_module bound_vars (Longident.Lident modname)) - !Clflags.open_modules; - (match k with - | Ml_binary.Ml -> Depend.add_implementation bound_vars ast - | Ml_binary.Mli -> Depend.add_signature bound_vars ast); - !Depend.free_structure_names) diff --git a/jscomp/depends/ast_extract.mli b/jscomp/depends/ast_extract.mli deleted file mode 100644 index 9e53b4c..0000000 --- a/jscomp/depends/ast_extract.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module Set_string = Depend.StringSet - -val read_parse_and_extract : 'a Ml_binary.kind -> 'a -> Set_string.t diff --git a/jscomp/depends/astdump_main.md b/jscomp/depends/astdump_main.md deleted file mode 100644 index f2f7c1e..0000000 --- a/jscomp/depends/astdump_main.md +++ /dev/null @@ -1,13 +0,0 @@ -current Ast format (10/10/2020) - --- input_binary_int ic (size) -module, -module, -... ---- seek_in ic (pos_in ic + size) -fname -marshalled ast - - - - diff --git a/jscomp/depends/binary_ast.ml b/jscomp/depends/binary_ast.ml deleted file mode 100644 index 645b639..0000000 --- a/jscomp/depends/binary_ast.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -module Set_string = Ast_extract.Set_string -(** Synced up with module {!Bsb_helper_depfile_gen} *) - -type 'a kind = 'a Ml_binary.kind = - | Ml : Parsetree.structure kind - | Mli : Parsetree.signature kind - -let read_ast_exn (type t) ~fname (_ : t kind) setup : t = - let ic = open_in_bin fname in - let dep_size = input_binary_int ic in - seek_in ic (pos_in ic + dep_size); - let sourcefile = input_line ic in - Location.set_input_name sourcefile; - let ast = input_value ic in - close_in ic; - (match - Ext_file_extensions.classify_input - (Ext_filename.get_extension_maybe sourcefile) - with - | Res | Resi -> setup `rescript - | _ -> ()); - ast - -let magic_sep_char = '\n' - -(* - Reasons that we don't [output_value] the set: - 1. for performance , easy skipping and calcuate the length - 2. cut dependency, otherwise its type is {!Ast_extract.Set_string.t} -*) -let write_ast (type t) ~(sourcefile : string) ~output (kind : t kind) (pt : t) : - unit = - let output_set = Ast_extract.read_parse_and_extract kind pt in - let buf = Ext_buffer.create 1000 in - Ext_buffer.add_char buf magic_sep_char; - Set_string.iter - (fun s -> - if s <> "" && s.[0] <> '*' then - (* filter *predef* *) - Ext_buffer.add_string_char buf s magic_sep_char) - output_set; - let oc = open_out_bin output in - output_binary_int oc (Ext_buffer.length buf); - Ext_buffer.output_buffer oc buf; - output_string oc sourcefile; - output_char oc '\n'; - output_value oc pt; - close_out oc diff --git a/jscomp/depends/binary_ast.mli b/jscomp/depends/binary_ast.mli deleted file mode 100644 index 48c58fc..0000000 --- a/jscomp/depends/binary_ast.mli +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type _ kind = Ml : Parsetree.structure kind | Mli : Parsetree.signature kind - -val read_ast_exn : - fname:string -> 'a kind -> ([ `ml | `rescript | `default ] -> unit) -> 'a - -val magic_sep_char : char - -val write_ast : sourcefile:string -> output:string -> 'a kind -> 'a -> unit -(** - Check out {!Bsb_depfile_gen} for set decoding - The [.ml] file can be recognized as an ast directly, the format - is - { - magic number; - filename; - ast - } - when [fname] is "-" it means the file is from an standard input or pipe. - An empty name would marshallized. - - Use case cat - | fan -printer -impl - - redirect the standard input to fan -*) diff --git a/jscomp/depends/bs_exception.ml b/jscomp/depends/bs_exception.ml deleted file mode 100644 index 43deedf..0000000 --- a/jscomp/depends/bs_exception.ml +++ /dev/null @@ -1,77 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error = - | Cmj_not_found of string - | Js_not_found of string - | Bs_cyclic_depends of string list - | Bs_duplicated_module of string * string - | Bs_duplicate_exports of string (* gpr_974 *) - | Bs_package_not_found of string - | Bs_main_not_exist of string - | Bs_invalid_path of string - | Missing_ml_dependency of string - | Dependency_script_module_dependent_not of string - (** TODO: we need add location handling *) - -exception Error of error - -let error err = raise (Error err) - -let report_error ppf = function - | Dependency_script_module_dependent_not s -> - Format.fprintf ppf - "%s is compiled in script mode while its dependent is not" s - | Missing_ml_dependency s -> - Format.fprintf ppf "Missing dependency %s in search path" s - | Cmj_not_found s -> - Format.fprintf ppf - "%s not found, it means either the module does not exist or it is a \ - namespace" - s - | Js_not_found s -> - Format.fprintf ppf "%s not found, needed in script mode " s - | Bs_cyclic_depends str -> - Format.fprintf ppf "Cyclic depends : @[%a@]" - (Format.pp_print_list ~pp_sep:Format.pp_print_space - Format.pp_print_string) - str - | Bs_duplicate_exports str -> - Format.fprintf ppf "%s are exported as twice" str - | Bs_duplicated_module (a, b) -> - Format.fprintf ppf - "The build system does not support two files with same names yet %s, %s" - a b - | Bs_main_not_exist main -> Format.fprintf ppf "File %s not found " main - | Bs_package_not_found package -> - Format.fprintf ppf - "Package %s not found or %s/lib/ocaml does not exist or please set \ - npm_config_prefix correctly" - package package - | Bs_invalid_path path -> Format.pp_print_string ppf ("Invalid path: " ^ path) - -let () = - Location.register_error_of_exn (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None) diff --git a/jscomp/depends/bs_exception.mli b/jscomp/depends/bs_exception.mli deleted file mode 100644 index 53efde0..0000000 --- a/jscomp/depends/bs_exception.mli +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error = - | Cmj_not_found of string - | Js_not_found of string - | Bs_cyclic_depends of string list - | Bs_duplicated_module of string * string - | Bs_duplicate_exports of string (* gpr_974 *) - | Bs_package_not_found of string - | Bs_main_not_exist of string - | Bs_invalid_path of string - | Missing_ml_dependency of string - | Dependency_script_module_dependent_not of string -(* -TODO: In the futrue, we should refine dependency [bsb] -should not rely on such exception, it should have its own exception handling -*) - -(* exception Error of error *) - -(* val report_error : Format.formatter -> error -> unit *) - -val error : error -> 'a diff --git a/jscomp/depends/dune b/jscomp/depends/dune deleted file mode 100644 index 7dad054..0000000 --- a/jscomp/depends/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name depends) - (wrapped false) - (flags - (:standard -w -A)) - (libraries common)) diff --git a/jscomp/dune b/jscomp/dune deleted file mode 100644 index f330e25..0000000 --- a/jscomp/dune +++ /dev/null @@ -1,45 +0,0 @@ -(dirs - bsb - bsb_exe - bsb_helper - bsb_helper_exe - bsc - cmij - common - core - depends - ext - frontend - gentype - jsoo - js_parser - ml - napkin - ounit_tests - syntax) - -(library - (name rescript_compiler) - (flags - (:standard -w -A)) - (libraries unix ext ml syntax)) - -(env - (dev - (env-vars - (CPPO_FLAGS -U=RELEASE))) - (release - (env-vars - (CPPO_FLAGS -D=RELEASE)) - (ocamlopt_flags - (:standard -O3 -unbox-closures))) - (static - (env-vars - (CPPO_FLAGS -D=RELEASE)) - (ocamlopt_flags - (:standard -O3 -unbox-closures))) - (browser - (env-vars - (CPPO_FLAGS -D=BROWSER)) - (ocamlopt_flags - (:standard -O3 -unbox-closures)))) diff --git a/jscomp/ext/.ocamlformat b/jscomp/ext/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/ext/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/ext/bsc_args.ml b/jscomp/ext/bsc_args.ml deleted file mode 100644 index 5f1fd2e..0000000 --- a/jscomp/ext/bsc_args.ml +++ /dev/null @@ -1,131 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type anon_fun = rev_args:string list -> unit - -type string_action = - | String_call of (string -> unit) - | String_set of string ref - | String_optional_set of string option ref - | String_list_add of string list ref - -type unit_action = - | Unit_call of (unit -> unit) - | Unit_lazy of unit lazy_t - | Unit_set of bool ref - | Unit_clear of bool ref - -type spec = Unit_dummy | Unit of unit_action | String of string_action - -exception Bad = Arg.Bad - -let bad_arg s = raise_notrace (Bad s) - -type error = Unknown of string | Missing of string - -type t = spec Ext_spec.t - -let ( +> ) = Ext_buffer.add_string - -let usage_b (buf : Ext_buffer.t) ~usage (speclist : t) = - buf +> usage; - buf +> "\nOptions:\n"; - let max_col = ref 0 in - Ext_array.iter speclist (fun (key, _, _) -> - if String.length key > !max_col then max_col := String.length key); - Ext_array.iter speclist (fun (key, _, doc) -> - if not (Ext_string.starts_with doc "*internal*") then ( - buf +> " "; - buf +> key; - buf +> String.make (!max_col - String.length key + 2) ' '; - let cur = ref 0 in - let doc_length = String.length doc in - while !cur < doc_length do - match String.index_from_opt doc !cur '\n' with - | None -> - if !cur <> 0 then ( - buf +> "\n"; - buf +> String.make (!max_col + 4) ' '); - buf +> String.sub doc !cur (String.length doc - !cur); - cur := doc_length - | Some new_line_pos -> - if !cur <> 0 then ( - buf +> "\n"; - buf +> String.make (!max_col + 4) ' '); - buf +> String.sub doc !cur (new_line_pos - !cur); - cur := new_line_pos + 1 - done; - buf +> "\n")) - -let stop_raise ~usage ~(error : error) (speclist : t) = - let b = Ext_buffer.create 200 in - (match error with - | Unknown ("-help" | "--help" | "-h") -> - usage_b b ~usage speclist; - Ext_buffer.output_buffer stdout b; - exit 0 - | Unknown s -> - b +> "Unknown option \""; - b +> s; - b +> "\".\n" - | Missing s -> - b +> "Option \""; - b +> s; - b +> "\" needs an argument.\n"); - usage_b b ~usage speclist; - bad_arg (Ext_buffer.contents b) - -let parse_exn ~usage ~argv ?(start = 1) ?(finish = Array.length argv) - (speclist : t) (anonfun : rev_args:string list -> unit) = - let current = ref start in - let rev_list = ref [] in - while !current < finish do - let s = argv.(!current) in - incr current; - if s <> "" && s.[0] = '-' then - match Ext_spec.assoc3 speclist s with - | Some action -> ( - match action with - | Unit_dummy -> () - | Unit r -> ( - match r with - | Unit_set r -> r := true - | Unit_clear r -> r := false - | Unit_call f -> f () - | Unit_lazy f -> Lazy.force f) - | String f -> ( - if !current >= finish then - stop_raise ~usage ~error:(Missing s) speclist - else - let arg = argv.(!current) in - incr current; - match f with - | String_call f -> f arg - | String_set u -> u := arg - | String_optional_set s -> s := Some arg - | String_list_add s -> s := arg :: !s)) - | None -> stop_raise ~usage ~error:(Unknown s) speclist - else rev_list := s :: !rev_list - done; - anonfun ~rev_args:!rev_list diff --git a/jscomp/ext/bsc_warnings.ml b/jscomp/ext/bsc_warnings.ml deleted file mode 100644 index 9769142..0000000 --- a/jscomp/ext/bsc_warnings.ml +++ /dev/null @@ -1,76 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** - See the meanings of the warning codes here: https://caml.inria.fr/pub/docs/manual-ocaml/comp.html#sec281 - - - 30 Two labels or constructors of the same name are defined in two mutually recursive types. - - 40 Constructor or label name used out of scope. - - - 6 Label omitted in function application. - - 7 Method overridden. - - 9 Missing fields in a record pattern. (*Not always desired, in some cases need [@@@warning "+9"] *) - - 27 Innocuous unused variable: unused variable that is not bound with let nor as, and doesn’t start with an underscore (_) character. - - 29 Unescaped end-of-line in a string constant (non-portable code). - - 32 .. 39 Unused blabla - - 44 Open statement shadows an already defined identifier. - - 45 Open statement shadows an already defined label or constructor. - - 48 Implicit elimination of optional arguments. https://caml.inria.fr/mantis/view.php?id=6352 - - 101 (bsb-specific) unsafe polymorphic comparison. -*) - -(* - The purpose of default warning set is to make it strict while - not annoy user too much - - -4 Fragile pattern matching: matching that will remain complete even if additional con- structors are added to one of the variant types matched. - We turn it off since common pattern - {[ - match x with | A -> .. | _ -> false - ]} - - -9 Missing fields in a record pattern. - only in some special cases that we need all fields being listed - - We encourage people to write code based on type based disambigution - 40,41,42 are enabled for compatiblity reasons - -40 Constructor or label name used out of scope - This is intentional, we should never warn it - - 41 Ambiguous constructor or label name. - It is turned off since it prevents such cases below: - {[ - type a = A |B - type b = A | B | C - ]} - - 42 Disambiguated constructor or label name (compatibility warning). - - - 50 Unexpected documentation comment. - - - 102 Bs_polymorphic_comparison -*) -(* If you change this, don't forget to adapt docs/docson/build-schema.json as well. *) -let defaults_w = "+a-4-9-20-40-41-42-50-61-102" - -let defaults_warn_error = "-a+5+6+101+109" -(*TODO: add +10*) diff --git a/jscomp/ext/config.ml b/jscomp/ext/config.ml deleted file mode 100644 index 35040ea..0000000 --- a/jscomp/ext/config.ml +++ /dev/null @@ -1,46 +0,0 @@ -let version = "4.06.1+BS" - -let standard_library = - let ( // ) = Filename.concat in - Filename.dirname Sys.executable_name - // Filename.parent_dir_name // "lib" // "ocaml" - -let standard_library_default = standard_library - -let syntax_kind = ref `ml - -let bs_only = ref true - -let unsafe_empty_array = ref false - -type uncurried = Legacy | Uncurried | Swap -let uncurried = ref Legacy - -and cmi_magic_number = "Caml1999I022" - -and ast_impl_magic_number = "Caml1999M022" - -and ast_intf_magic_number = "Caml1999N022" - -and cmt_magic_number = "Caml1999T022" - -let load_path = ref ([] : string list) - -let interface_suffix = ref ".mli" - -(* This is normally the same as in obj.ml, but we have to define it - separately because it can differ when we're in the middle of a - bootstrapping phase. *) - -let print_config oc = - let p name valu = Printf.fprintf oc "%s: %s\n" name valu in - p "version" version; - p "standard_library_default" standard_library_default; - p "standard_library" standard_library; - - (* print the magic number *) - p "cmi_magic_number" cmi_magic_number; - p "ast_impl_magic_number" ast_impl_magic_number; - p "ast_intf_magic_number" ast_intf_magic_number; - p "cmt_magic_number" cmt_magic_number; - flush oc diff --git a/jscomp/ext/dune b/jscomp/ext/dune deleted file mode 100644 index 7302d38..0000000 --- a/jscomp/ext/dune +++ /dev/null @@ -1,121 +0,0 @@ -(library - (name ext) - (wrapped false) - (preprocess - (action - (run %{bin:cppo} %{env:CPPO_FLAGS=} %{input-file}))) - (flags - (:standard -w -A)) - (foreign_stubs - (language c) - (names ext_basic_hash_stubs))) - -(ocamllex ext_json_parse) - -(rule - (targets hash_set_string.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets hash_set_int.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets hash_set_ident.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets hash_set.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) - -(rule - (targets hash_set_poly.ml) - (deps hash_set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_POLY %{deps} -o %{targets}))) - -(rule - (targets vec_int.ml) - (deps vec.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets vec.ml) - (deps vec.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) - -(rule - (targets set_string.ml) - (deps set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets set_int.ml) - (deps set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets set_ident.ml) - (deps set.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets map_string.ml) - (deps map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets map_int.ml) - (deps map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets map_ident.ml) - (deps map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets ordered_hash_map_local_ident.ml) - (deps ordered_hash_map.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_LOCAL_IDENT %{deps} -o %{targets}))) - -(rule - (targets hash_string.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_STRING %{deps} -o %{targets}))) - -(rule - (targets hash_int.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_INT %{deps} -o %{targets}))) - -(rule - (targets hash_ident.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_IDENT %{deps} -o %{targets}))) - -(rule - (targets hash.ml) - (deps hash.cppo.ml) - (action - (run %{bin:cppo} -D TYPE_FUNCTOR %{deps} -o %{targets}))) diff --git a/jscomp/ext/ext_cmp.ml b/jscomp/ext/ext_cmp.ml deleted file mode 100644 index e14746c..0000000 --- a/jscomp/ext/ext_cmp.ml +++ /dev/null @@ -1,37 +0,0 @@ -type 'a compare = 'a -> 'a -> int - -type ('a, 'id) cmp = 'a compare - -external getCmp : ('a, 'id) cmp -> 'a compare = "%identity" - -module type S = sig - type id - - type t - - val cmp : (t, id) cmp -end - -type ('key, 'id) t = (module S with type t = 'key and type id = 'id) - -module Make (M : sig - type t - - val cmp : (t -> t -> int[@bs]) -end) = -struct - type id - - type t = M.t - - let cmp = M.cmp -end - -let make (type key) (cmp : (key -> key -> int[@bs])) = - let module M = struct - type t = key - - let cmp = cmp - end in - let module N = Make (M) in - (module N : S with type t = key) diff --git a/jscomp/ext/ext_cmp.mli b/jscomp/ext/ext_cmp.mli deleted file mode 100644 index 8588d12..0000000 --- a/jscomp/ext/ext_cmp.mli +++ /dev/null @@ -1,24 +0,0 @@ -type 'a compare = 'a -> 'a -> int - -type ('a, 'id) cmp - -external getCmp : ('a, 'id) cmp -> 'a compare = "%identity" -(** only used for data structures, not exported for client usage *) - -module type S = sig - type id - - type t - - val cmp : (t, id) cmp -end - -type ('key, 'id) t = (module S with type t = 'key and type id = 'id) - -module Make (M : sig - type t - - val cmp : t compare -end) : S with type t = M.t - -val make : ('a -> 'a -> int) -> (module S with type t = 'a) diff --git a/jscomp/ext/ext_file_extensions.ml b/jscomp/ext/ext_file_extensions.ml deleted file mode 100644 index 5449c41..0000000 --- a/jscomp/ext/ext_file_extensions.ml +++ /dev/null @@ -1,27 +0,0 @@ -type valid_input = - | Ml - | Mli - | Res - | Resi - | Intf_ast - | Impl_ast - | Mlmap - | Cmi - | Unknown - -(** This is per-file based, - when [ocamlc] [-c -o another_dir/xx.cmi] - it will return (another_dir/xx) -*) - -let classify_input ext = - match () with - | _ when ext = Literals.suffix_ml -> Ml - | _ when ext = !Config.interface_suffix -> Mli - | _ when ext = Literals.suffix_ast -> Impl_ast - | _ when ext = Literals.suffix_iast -> Intf_ast - | _ when ext = Literals.suffix_mlmap -> Mlmap - | _ when ext = Literals.suffix_cmi -> Cmi - | _ when ext = Literals.suffix_res -> Res - | _ when ext = Literals.suffix_resi -> Resi - | _ -> Unknown diff --git a/jscomp/ext/ext_format.ml b/jscomp/ext/ext_format.ml deleted file mode 100644 index c6924a2..0000000 --- a/jscomp/ext/ext_format.ml +++ /dev/null @@ -1,103 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Format - -type t = formatter - -(* let string = pp_print_string *) - -(* let break = fun fmt -> pp_print_break fmt 0 0 - - let break1 = - fun fmt -> pp_print_break fmt 0 1 - - let space fmt = - pp_print_break fmt 1 0 -*) -(* let vgroup fmt indent u = - pp_open_vbox fmt indent; - let v = u () in - pp_close_box fmt (); - v - - let group fmt indent u = - pp_open_hovbox fmt indent; - let v = u () in - pp_close_box fmt (); - v - - let paren fmt u = - string fmt "("; - let v = u () in - string fmt ")"; - v - - let brace fmt u = - string fmt "{"; - (* break1 fmt ; *) - let v = u () in - string fmt "}"; - v - - let bracket fmt u = - string fmt "["; - let v = u () in - string fmt "]"; - v *) - -(* let paren_group st n action = - group st n (fun _ -> paren st action) - - let brace_group st n action = - group st n (fun _ -> brace st action ) - - let brace_vgroup st n action = - vgroup st n (fun _ -> - string st "{"; - pp_print_break st 0 2; - let v = vgroup st 0 action in - pp_print_break st 0 0; - string st "}"; - v - ) - let bracket_group st n action = - group st n (fun _ -> bracket st action) - - let newline fmt = pp_print_newline fmt () - - let to_out_channel = formatter_of_out_channel - - (* let non_breaking_space fmt = string fmt " " *) - (* let set_needed_space_function _ _ = () *) - let flush = pp_print_flush -*) -(* let list = pp_print_list *) - -let pp_print_queue ?(pp_sep = pp_print_cut) pp_v ppf q = - Queue.iter - (fun q -> - pp_v ppf q; - pp_sep ppf ()) - q diff --git a/jscomp/ext/ext_format.mli b/jscomp/ext/ext_format.mli deleted file mode 100644 index f921110..0000000 --- a/jscomp/ext/ext_format.mli +++ /dev/null @@ -1,66 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Simplified wrapper module for the standard library [Format] module. -*) - -type t = private Format.formatter - -(* val string : t -> string -> unit - - val break : t -> unit - - val break1 : t -> unit - - val space : t -> unit - - val group : t -> int -> (unit -> 'a) -> 'a - (** [group] will record current indentation - and indent futher - *) - - val vgroup : t -> int -> (unit -> 'a) -> 'a - - val paren : t -> (unit -> 'a) -> 'a - - val paren_group : t -> int -> (unit -> 'a) -> 'a - - val brace_group : t -> int -> (unit -> 'a) -> 'a - - val brace_vgroup : t -> int -> (unit -> 'a) -> 'a - - val bracket_group : t -> int -> (unit -> 'a) -> 'a - - val newline : t -> unit - - val to_out_channel : out_channel -> t - - val flush : t -> unit -> unit *) - -val pp_print_queue : - ?pp_sep:(Format.formatter -> unit -> unit) -> - (Format.formatter -> 'a -> unit) -> - Format.formatter -> - 'a Queue.t -> - unit diff --git a/jscomp/ext/ext_ident.ml b/jscomp/ext/ext_ident.ml deleted file mode 100644 index f04e018..0000000 --- a/jscomp/ext/ext_ident.ml +++ /dev/null @@ -1,195 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - - -let js_flag = 0b1_000 (* check with ocaml compiler *) - -(* let js_module_flag = 0b10_000 (\* javascript external modules *\) *) -(* TODO: - check name conflicts with javascript conventions - {[ - Ext_ident.convert "^";; - - : string = "$caret" - ]} -*) -let js_object_flag = 0b100_000 (* javascript object flags *) - -let is_js (i : Ident.t) = - i.flags land js_flag <> 0 - -let is_js_or_global (i : Ident.t) = - i.flags land (8 lor 1) <> 0 - - -let is_js_object (i : Ident.t) = - i.flags land js_object_flag <> 0 - -let make_js_object (i : Ident.t) = - i.flags <- i.flags lor js_object_flag - -(* It's a js function hard coded by js api, so when printing, - it should preserve the name -*) -let create_js (name : string) : Ident.t = - { name = name; flags = js_flag ; stamp = 0} - -let create = Ident.create - -(* FIXME: no need for `$' operator *) -let create_tmp ?(name=Literals.tmp) () = create name - - -let js_module_table : Ident.t Hash_string.t = Hash_string.create 31 - -(* This is for a js exeternal module, we can change it when printing - for example - {[ - var React$1 = require('react'); - React$1.render(..) - ]} - - Given a name, if duplicated, they should have the same id -*) -(* let create_js_module (name : string) : Ident.t = - let name = - String.concat "" @@ Ext_list.map - (Ext_string.split name '-') Ext_string.capitalize_ascii in - (* TODO: if we do such transformation, we should avoid collision for example: - react-dom - react--dom - check collision later - *) - match Hash_string.find_exn js_module_table name with - | exception Not_found -> - let ans = Ident.create name in - (* let ans = { v with flags = js_module_flag} in *) - Hash_string.add js_module_table name ans; - ans - | v -> (* v *) Ident.rename v - - -*) - -let [@inline] convert ?(op=false) (c : char) : string = - (match c with - | '*' -> "$star" - | '\'' -> "$p" - | '!' -> "$bang" - | '>' -> "$great" - | '<' -> "$less" - | '=' -> "$eq" - | '+' -> "$plus" - | '-' -> if op then "$neg" else "$" - | '@' -> "$at" - | '^' -> "$caret" - | '/' -> "$slash" - | '|' -> "$pipe" - | '.' -> "$dot" - | '%' -> "$percent" - | '~' -> "$tilde" - | '#' -> "$hash" - | ':' -> "$colon" - | '?' -> "$question" - | '&' -> "$amp" - | '(' -> "$lpar" - | ')' -> "$rpar" - | '{' -> "$lbrace" - | '}' -> "$lbrace" - | '[' -> "$lbrack" - | ']' -> "$rbrack" - - | _ -> "$unknown") -let [@inline] no_escape (c : char) = - match c with - | 'a' .. 'z' | 'A' .. 'Z' - | '0' .. '9' | '_' | '$' -> true - | _ -> false - -exception Not_normal_letter of int -let name_mangle name = - let len = String.length name in - try - for i = 0 to len - 1 do - if not (no_escape (String.unsafe_get name i)) then - raise_notrace (Not_normal_letter i) - done; - name (* Normal letter *) - with - | Not_normal_letter i -> - let buffer = Ext_buffer.create len in - for j = 0 to len - 1 do - let c = String.unsafe_get name j in - if no_escape c then Ext_buffer.add_char buffer c - else - Ext_buffer.add_string buffer (convert ~op:(i=0) c) - done; Ext_buffer.contents buffer - -(* TODO: - check name conflicts with javascript conventions - {[ - Ext_ident.convert "^";; - - : string = "$caret" - ]} - [convert name] if [name] is a js keyword,add "$$" - otherwise do the name mangling to make sure ocaml identifier it is - a valid js identifier -*) -let convert (name : string) = - if Js_reserved_map.is_reserved name then - "$$" ^ name - else name_mangle name - -(** keyword could be used in property *) - -(* It is currently made a persistent ident to avoid fresh ids - which would result in different signature files - - other solution: use lazy values -*) -let make_unused () = create "_" - - - -let reset () = - Hash_string.clear js_module_table - - -(* Has to be total order, [x < y] - and [x > y] should be consistent - flags are not relevant here -*) -let compare (x : Ident.t ) ( y : Ident.t) = - let u = x.stamp - y.stamp in - if u = 0 then - Ext_string.compare x.name y.name - else u - -let equal ( x : Ident.t) ( y : Ident.t) = - if x.stamp <> 0 then x.stamp = y.stamp - else y.stamp = 0 && x.name = y.name diff --git a/jscomp/ext/ext_js_regex.ml b/jscomp/ext/ext_js_regex.ml deleted file mode 100644 index 83a881f..0000000 --- a/jscomp/ext/ext_js_regex.ml +++ /dev/null @@ -1,47 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let check_from_end al = - let rec aux l seen = - match l with - | [] -> false - | e :: r -> - if e < 0 || e > 255 then false - else - let c = Char.chr e in - if c = '/' then true - else if Ext_list.exists seen (fun x -> x = c) then false - (* flag should not be repeated *) - else if c = 'i' || c = 'g' || c = 'm' || c = 'y' || c = 'u' then - aux r (c :: seen) - else false - in - aux al [] - -let js_regex_checker s = - match Ext_utf8.decode_utf8_string s with - | [] -> false - | 47 (* [Char.code '/' = 47 ]*) :: tail -> check_from_end (List.rev tail) - | _ :: _ -> false - | exception Ext_utf8.Invalid_utf8 _ -> false diff --git a/jscomp/ext/ext_js_regex.mli b/jscomp/ext/ext_js_regex.mli deleted file mode 100644 index a627d7b..0000000 --- a/jscomp/ext/ext_js_regex.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* This is a module that checks if js regex is valid or not *) - -val js_regex_checker : string -> bool diff --git a/jscomp/ext/ext_json_noloc.ml b/jscomp/ext/ext_json_noloc.ml deleted file mode 100644 index 9ce2733..0000000 --- a/jscomp/ext/ext_json_noloc.ml +++ /dev/null @@ -1,148 +0,0 @@ -(* Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* This file is only used in bsb watcher searlization *) -type t = - | True - | False - | Null - | Flo of string - | Str of string - | Arr of t array - | Obj of t Map_string.t - -(** poor man's serialization *) -let naive_escaped (unmodified_input : string) : string = - let n = ref 0 in - let len = String.length unmodified_input in - for i = 0 to len - 1 do - n := - !n - + - match String.unsafe_get unmodified_input i with - | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 - | _ -> 1 - done; - if !n = len then unmodified_input - else - let result = Bytes.create !n in - n := 0; - for i = 0 to len - 1 do - let open Bytes in - (match String.unsafe_get unmodified_input i with - | ('\"' | '\\') as c -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n c - | '\n' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 'n' - | '\t' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 't' - | '\r' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 'r' - | '\b' -> - unsafe_set result !n '\\'; - incr n; - unsafe_set result !n 'b' - | c -> unsafe_set result !n c); - incr n - done; - Bytes.unsafe_to_string result - -let quot x = "\"" ^ naive_escaped x ^ "\"" - -let true_ = True - -let false_ = False - -let null = Null - -let str s = Str s - -let flo s = Flo s - -let arr s = Arr s - -let obj s = Obj s - -let kvs s = Obj (Map_string.of_list s) - -let rec encode_buf (x : t) (buf : Buffer.t) : unit = - let a str = Buffer.add_string buf str in - match x with - | Null -> a "null" - | Str s -> a (quot s) - | Flo s -> - a s - (* - since our parsing keep the original float representation, we just dump it as is, there is no cases like [nan] *) - | Arr content -> ( - match content with - | [||] -> a "[]" - | _ -> - a "[ "; - encode_buf (Array.unsafe_get content 0) buf; - for i = 1 to Array.length content - 1 do - a " , "; - encode_buf (Array.unsafe_get content i) buf - done; - a " ]") - | True -> a "true" - | False -> a "false" - | Obj map -> - if Map_string.is_empty map then a "{}" - else ( - (*prerr_endline "WEIRD"; - prerr_endline (string_of_int @@ Map_string.cardinal map ); *) - a "{ "; - let (_ : int) = - Map_string.fold map 0 (fun k v i -> - if i <> 0 then a " , "; - a (quot k); - a " : "; - encode_buf v buf; - i + 1) - in - a " }") - -let to_string x = - let buf = Buffer.create 1024 in - encode_buf x buf; - Buffer.contents buf - -let to_channel (oc : out_channel) x = - let buf = Buffer.create 1024 in - encode_buf x buf; - Buffer.output_buffer oc buf - -let to_file name v = - let ochan = open_out_bin name in - to_channel ochan v; - close_out ochan diff --git a/jscomp/ext/ext_json_write.ml b/jscomp/ext/ext_json_write.ml deleted file mode 100644 index 965fe98..0000000 --- a/jscomp/ext/ext_json_write.ml +++ /dev/null @@ -1,86 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** poor man's serialization *) -(* - let quot x = - "\"" ^ String.escaped x ^ "\"" *) - -(* let rec encode_aux (x : Ext_json_types.t ) - (buf : Buffer.t) : unit = - let a str = Buffer.add_string buf str in - match x with - | Null _ -> a "null" - | Str {str = s } -> a (quot s) - | Flo {flo = s} -> - a s (* - since our parsing keep the original float representation, we just dump it as is, there is no cases like [nan] *) - | Arr {content} -> - begin match content with - | [||] -> a "[]" - | _ -> - a "[ "; - encode_aux - (Array.unsafe_get content 0) - buf ; - for i = 1 to Array.length content - 1 do - a " , "; - encode_aux - (Array.unsafe_get content i) - buf - done; - a " ]" - end - | True _ -> a "true" - | False _ -> a "false" - | Obj {map} -> - if Map_string.is_empty map then - a "{}" - else - begin - (*prerr_endline "WEIRD"; - prerr_endline (string_of_int @@ Map_string.cardinal map ); *) - a "{ "; - let _ : int = Map_string.fold map 0 (fun k v i -> - if i <> 0 then begin - a " , " - end; - a (quot k); - a " : "; - encode_aux v buf ; - i + 1 - ) in - a " }" - end -*) - -(* let to_string (x : Ext_json_types.t) = - let buf = Buffer.create 1024 in - encode_aux x buf ; - Buffer.contents buf - - let to_channel (oc : out_channel) x = - let buf = Buffer.create 1024 in - encode_aux x buf ; - Buffer.output_buffer oc buf *) diff --git a/jscomp/ext/ext_json_write.mli b/jscomp/ext/ext_json_write.mli deleted file mode 100644 index 5ccfab7..0000000 --- a/jscomp/ext/ext_json_write.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(*val to_string : Ext_json_types.t -> string - - - val to_channel : out_channel -> Ext_json_types.t -> unit*) diff --git a/jscomp/ext/ext_list.ml b/jscomp/ext/ext_list.ml deleted file mode 100644 index be7f30b..0000000 --- a/jscomp/ext/ext_list.ml +++ /dev/null @@ -1,724 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -external ( .!() ) : 'a array -> int -> 'a = "%array_unsafe_get" - -let rec map l f = - match l with - | [] -> [] - | [ x1 ] -> - let y1 = f x1 in - [ y1 ] - | [ x1; x2 ] -> - let y1 = f x1 in - let y2 = f x2 in - [ y1; y2 ] - | [ x1; x2; x3 ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - [ y1; y2; y3 ] - | [ x1; x2; x3; x4 ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - [ y1; y2; y3; y4 ] - | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - let y5 = f x5 in - y1 :: y2 :: y3 :: y4 :: y5 :: map tail f - -let rec has_string l f = - match l with - | [] -> false - | [ x1 ] -> x1 = f - | [ x1; x2 ] -> x1 = f || x2 = f - | [ x1; x2; x3 ] -> x1 = f || x2 = f || x3 = f - | x1 :: x2 :: x3 :: x4 -> x1 = f || x2 = f || x3 = f || has_string x4 f - -let rec map_combine l1 l2 f = - match (l1, l2) with - | [], [] -> [] - | a1 :: l1, a2 :: l2 -> (f a1, a2) :: map_combine l1 l2 f - | _, _ -> invalid_arg "Ext_list.map_combine" - -let rec arr_list_combine_unsafe arr l i j acc f = - if i = j then acc - else - match l with - | [] -> invalid_arg "Ext_list.combine" - | h :: tl -> - (f arr.!(i), h) :: arr_list_combine_unsafe arr tl (i + 1) j acc f - -let combine_array_append arr l acc f = - let len = Array.length arr in - arr_list_combine_unsafe arr l 0 len acc f - -let combine_array arr l f = - let len = Array.length arr in - arr_list_combine_unsafe arr l 0 len [] f - -let rec arr_list_filter_map_unasfe arr l i j acc f = - if i = j then acc - else - match l with - | [] -> invalid_arg "Ext_list.arr_list_filter_map_unsafe" - | h :: tl -> ( - match f arr.!(i) h with - | None -> arr_list_filter_map_unasfe arr tl (i + 1) j acc f - | Some v -> v :: arr_list_filter_map_unasfe arr tl (i + 1) j acc f) - -let array_list_filter_map arr l f = - let len = Array.length arr in - arr_list_filter_map_unasfe arr l 0 len [] f - -let rec map_split_opt (xs : 'a list) (f : 'a -> 'b option * 'c option) : - 'b list * 'c list = - match xs with - | [] -> ([], []) - | x :: xs -> ( - let c, d = f x in - let cs, ds = map_split_opt xs f in - ( (match c with Some c -> c :: cs | None -> cs), - match d with Some d -> d :: ds | None -> ds )) - -let rec map_snd l f = - match l with - | [] -> [] - | [ (v1, x1) ] -> - let y1 = f x1 in - [ (v1, y1) ] - | [ (v1, x1); (v2, x2) ] -> - let y1 = f x1 in - let y2 = f x2 in - [ (v1, y1); (v2, y2) ] - | [ (v1, x1); (v2, x2); (v3, x3) ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - [ (v1, y1); (v2, y2); (v3, y3) ] - | [ (v1, x1); (v2, x2); (v3, x3); (v4, x4) ] -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - [ (v1, y1); (v2, y2); (v3, y3); (v4, y4) ] - | (v1, x1) :: (v2, x2) :: (v3, x3) :: (v4, x4) :: (v5, x5) :: tail -> - let y1 = f x1 in - let y2 = f x2 in - let y3 = f x3 in - let y4 = f x4 in - let y5 = f x5 in - (v1, y1) :: (v2, y2) :: (v3, y3) :: (v4, y4) :: (v5, y5) :: map_snd tail f - -let rec map_last l f = - match l with - | [] -> [] - | [ x1 ] -> - let y1 = f true x1 in - [ y1 ] - | [ x1; x2 ] -> - let y1 = f false x1 in - let y2 = f true x2 in - [ y1; y2 ] - | [ x1; x2; x3 ] -> - let y1 = f false x1 in - let y2 = f false x2 in - let y3 = f true x3 in - [ y1; y2; y3 ] - | [ x1; x2; x3; x4 ] -> - let y1 = f false x1 in - let y2 = f false x2 in - let y3 = f false x3 in - let y4 = f true x4 in - [ y1; y2; y3; y4 ] - | x1 :: x2 :: x3 :: x4 :: tail -> - (* make sure that tail is not empty *) - let y1 = f false x1 in - let y2 = f false x2 in - let y3 = f false x3 in - let y4 = f false x4 in - y1 :: y2 :: y3 :: y4 :: map_last tail f - -let rec mapi_aux lst i f tail = - match lst with - | [] -> tail - | a :: l -> - let r = f i a in - r :: mapi_aux l (i + 1) f tail - -let mapi lst f = mapi_aux lst 0 f [] - -let mapi_append lst f tail = mapi_aux lst 0 f tail - -let rec last xs = - match xs with - | [ x ] -> x - | _ :: tl -> last tl - | [] -> invalid_arg "Ext_list.last" - -let rec append_aux l1 l2 = - match l1 with - | [] -> l2 - | [ a0 ] -> a0 :: l2 - | [ a0; a1 ] -> a0 :: a1 :: l2 - | [ a0; a1; a2 ] -> a0 :: a1 :: a2 :: l2 - | [ a0; a1; a2; a3 ] -> a0 :: a1 :: a2 :: a3 :: l2 - | [ a0; a1; a2; a3; a4 ] -> a0 :: a1 :: a2 :: a3 :: a4 :: l2 - | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - a0 :: a1 :: a2 :: a3 :: a4 :: append_aux rest l2 - -let append l1 l2 = match l2 with [] -> l1 | _ -> append_aux l1 l2 - -let append_one l1 x = append_aux l1 [ x ] - -let rec map_append l1 l2 f = - match l1 with - | [] -> l2 - | [ a0 ] -> f a0 :: l2 - | [ a0; a1 ] -> - let b0 = f a0 in - let b1 = f a1 in - b0 :: b1 :: l2 - | [ a0; a1; a2 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - b0 :: b1 :: b2 :: l2 - | [ a0; a1; a2; a3 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - b0 :: b1 :: b2 :: b3 :: l2 - | [ a0; a1; a2; a3; a4 ] -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - b0 :: b1 :: b2 :: b3 :: b4 :: l2 - | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - let b0 = f a0 in - let b1 = f a1 in - let b2 = f a2 in - let b3 = f a3 in - let b4 = f a4 in - b0 :: b1 :: b2 :: b3 :: b4 :: map_append rest l2 f - -let rec fold_right l acc f = - match l with - | [] -> acc - | [ a0 ] -> f a0 acc - | [ a0; a1 ] -> f a0 (f a1 acc) - | [ a0; a1; a2 ] -> f a0 (f a1 (f a2 acc)) - | [ a0; a1; a2; a3 ] -> f a0 (f a1 (f a2 (f a3 acc))) - | [ a0; a1; a2; a3; a4 ] -> f a0 (f a1 (f a2 (f a3 (f a4 acc)))) - | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - f a0 (f a1 (f a2 (f a3 (f a4 (fold_right rest acc f))))) - -let rec fold_right2 l r acc f = - match (l, r) with - | [], [] -> acc - | [ a0 ], [ b0 ] -> f a0 b0 acc - | [ a0; a1 ], [ b0; b1 ] -> f a0 b0 (f a1 b1 acc) - | [ a0; a1; a2 ], [ b0; b1; b2 ] -> f a0 b0 (f a1 b1 (f a2 b2 acc)) - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ] -> - f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 acc))) - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ] -> - f a0 b0 (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 acc)))) - | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> - f a0 b0 - (f a1 b1 (f a2 b2 (f a3 b3 (f a4 b4 (fold_right2 arest brest acc f))))) - | _, _ -> invalid_arg "Ext_list.fold_right2" - -let rec fold_right3 l r last acc f = - match (l, r, last) with - | [], [], [] -> acc - | [ a0 ], [ b0 ], [ c0 ] -> f a0 b0 c0 acc - | [ a0; a1 ], [ b0; b1 ], [ c0; c1 ] -> f a0 b0 c0 (f a1 b1 c1 acc) - | [ a0; a1; a2 ], [ b0; b1; b2 ], [ c0; c1; c2 ] -> - f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 acc)) - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ], [ c0; c1; c2; c3 ] -> - f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 acc))) - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ], [ c0; c1; c2; c3; c4 ] -> - f a0 b0 c0 (f a1 b1 c1 (f a2 b2 c2 (f a3 b3 c3 (f a4 b4 c4 acc)))) - | ( a0 :: a1 :: a2 :: a3 :: a4 :: arest, - b0 :: b1 :: b2 :: b3 :: b4 :: brest, - c0 :: c1 :: c2 :: c3 :: c4 :: crest ) -> - f a0 b0 c0 - (f a1 b1 c1 - (f a2 b2 c2 - (f a3 b3 c3 (f a4 b4 c4 (fold_right3 arest brest crest acc f))))) - | _, _, _ -> invalid_arg "Ext_list.fold_right2" - -let rec map2i l r f = - match (l, r) with - | [], [] -> [] - | [ a0 ], [ b0 ] -> [ f 0 a0 b0 ] - | [ a0; a1 ], [ b0; b1 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - [ c0; c1 ] - | [ a0; a1; a2 ], [ b0; b1; b2 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - [ c0; c1; c2 ] - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - [ c0; c1; c2; c3 ] - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ] -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - let c4 = f 4 a4 b4 in - [ c0; c1; c2; c3; c4 ] - | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> - let c0 = f 0 a0 b0 in - let c1 = f 1 a1 b1 in - let c2 = f 2 a2 b2 in - let c3 = f 3 a3 b3 in - let c4 = f 4 a4 b4 in - c0 :: c1 :: c2 :: c3 :: c4 :: map2i arest brest f - | _, _ -> invalid_arg "Ext_list.map2" - -let rec map2 l r f = - match (l, r) with - | [], [] -> [] - | [ a0 ], [ b0 ] -> [ f a0 b0 ] - | [ a0; a1 ], [ b0; b1 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - [ c0; c1 ] - | [ a0; a1; a2 ], [ b0; b1; b2 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - [ c0; c1; c2 ] - | [ a0; a1; a2; a3 ], [ b0; b1; b2; b3 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - let c3 = f a3 b3 in - [ c0; c1; c2; c3 ] - | [ a0; a1; a2; a3; a4 ], [ b0; b1; b2; b3; b4 ] -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - let c3 = f a3 b3 in - let c4 = f a4 b4 in - [ c0; c1; c2; c3; c4 ] - | a0 :: a1 :: a2 :: a3 :: a4 :: arest, b0 :: b1 :: b2 :: b3 :: b4 :: brest -> - let c0 = f a0 b0 in - let c1 = f a1 b1 in - let c2 = f a2 b2 in - let c3 = f a3 b3 in - let c4 = f a4 b4 in - c0 :: c1 :: c2 :: c3 :: c4 :: map2 arest brest f - | _, _ -> invalid_arg "Ext_list.map2" - -let rec fold_left_with_offset l accu i f = - match l with - | [] -> accu - | a :: l -> fold_left_with_offset l (f a accu i) (i + 1) f - -let rec filter_map xs (f : 'a -> 'b option) = - match xs with - | [] -> [] - | y :: ys -> ( - match f y with None -> filter_map ys f | Some z -> z :: filter_map ys f) - -let rec exclude (xs : 'a list) (p : 'a -> bool) : 'a list = - match xs with - | [] -> [] - | x :: xs -> if p x then exclude xs p else x :: exclude xs p - -let rec exclude_with_val l p = - match l with - | [] -> None - | a0 :: xs -> ( - if p a0 then Some (exclude xs p) - else - match xs with - | [] -> None - | a1 :: rest -> ( - if p a1 then Some (a0 :: exclude rest p) - else - match exclude_with_val rest p with - | None -> None - | Some rest -> Some (a0 :: a1 :: rest))) - -let rec same_length xs ys = - match (xs, ys) with - | [], [] -> true - | _ :: xs, _ :: ys -> same_length xs ys - | _, _ -> false - -let init n f = - match n with - | 0 -> [] - | 1 -> - let a0 = f 0 in - [ a0 ] - | 2 -> - let a0 = f 0 in - let a1 = f 1 in - [ a0; a1 ] - | 3 -> - let a0 = f 0 in - let a1 = f 1 in - let a2 = f 2 in - [ a0; a1; a2 ] - | 4 -> - let a0 = f 0 in - let a1 = f 1 in - let a2 = f 2 in - let a3 = f 3 in - [ a0; a1; a2; a3 ] - | 5 -> - let a0 = f 0 in - let a1 = f 1 in - let a2 = f 2 in - let a3 = f 3 in - let a4 = f 4 in - [ a0; a1; a2; a3; a4 ] - | _ -> Array.to_list (Array.init n f) - -let rec rev_append l1 l2 = - match l1 with - | [] -> l2 - | [ a0 ] -> a0 :: l2 (* single element is common *) - | [ a0; a1 ] -> a1 :: a0 :: l2 - | a0 :: a1 :: a2 :: rest -> rev_append rest (a2 :: a1 :: a0 :: l2) - -let rev l = rev_append l [] - -let rec small_split_at n acc l = - if n <= 0 then (rev acc, l) - else - match l with - | x :: xs -> small_split_at (n - 1) (x :: acc) xs - | _ -> invalid_arg "Ext_list.split_at" - -let split_at l n = small_split_at n [] l - -let rec split_at_last_aux acc x = - match x with - | [] -> invalid_arg "Ext_list.split_at_last" - | [ x ] -> (rev acc, x) - | y0 :: ys -> split_at_last_aux (y0 :: acc) ys - -let split_at_last (x : 'a list) = - match x with - | [] -> invalid_arg "Ext_list.split_at_last" - | [ a0 ] -> ([], a0) - | [ a0; a1 ] -> ([ a0 ], a1) - | [ a0; a1; a2 ] -> ([ a0; a1 ], a2) - | [ a0; a1; a2; a3 ] -> ([ a0; a1; a2 ], a3) - | [ a0; a1; a2; a3; a4 ] -> ([ a0; a1; a2; a3 ], a4) - | a0 :: a1 :: a2 :: a3 :: a4 :: rest -> - let rev, last = split_at_last_aux [] rest in - (a0 :: a1 :: a2 :: a3 :: a4 :: rev, last) - -(** - can not do loop unroll due to state combination -*) -let filter_mapi xs f = - let rec aux i xs = - match xs with - | [] -> [] - | y :: ys -> ( - match f y i with - | None -> aux (i + 1) ys - | Some z -> z :: aux (i + 1) ys) - in - aux 0 xs - -let rec filter_map2 xs ys (f : 'a -> 'b -> 'c option) = - match (xs, ys) with - | [], [] -> [] - | u :: us, v :: vs -> ( - match f u v with - | None -> filter_map2 us vs f (* idea: rec f us vs instead? *) - | Some z -> z :: filter_map2 us vs f) - | _ -> invalid_arg "Ext_list.filter_map2" - -let rec rev_map_append l1 l2 f = - match l1 with [] -> l2 | a :: l -> rev_map_append l (f a :: l2) f - -(** It is not worth loop unrolling, - it is already tail-call, and we need to be careful - about evaluation order when unroll -*) -let rec flat_map_aux f acc append lx = - match lx with - | [] -> rev_append acc append - | a0 :: rest -> - let new_acc = - match f a0 with - | [] -> acc - | [ a0 ] -> a0 :: acc - | [ a0; a1 ] -> a1 :: a0 :: acc - | a0 :: a1 :: a2 :: rest -> rev_append rest (a2 :: a1 :: a0 :: acc) - in - flat_map_aux f new_acc append rest - -let flat_map lx f = flat_map_aux f [] [] lx - -let flat_map_append lx append f = flat_map_aux f [] append lx - -let rec length_compare l n = - if n < 0 then `Gt - else - match l with - | _ :: xs -> length_compare xs (n - 1) - | [] -> if n = 0 then `Eq else `Lt - -let rec length_ge l n = - if n > 0 then match l with _ :: tl -> length_ge tl (n - 1) | [] -> false - else true - -(** - {[length xs = length ys + n ]} -*) -let rec length_larger_than_n xs ys n = - match (xs, ys) with - | _, [] -> length_compare xs n = `Eq - | _ :: xs, _ :: ys -> length_larger_than_n xs ys n - | [], _ -> false - -let rec group (eq : 'a -> 'a -> bool) lst = - match lst with [] -> [] | x :: xs -> aux eq x (group eq xs) - -and aux eq (x : 'a) (xss : 'a list list) : 'a list list = - match xss with - | [] -> [ [ x ] ] - | (y0 :: _ as y) :: ys -> - (* cannot be empty *) - if eq x y0 then (x :: y) :: ys else y :: aux eq x ys - | _ :: _ -> assert false - -let stable_group lst eq = group eq lst |> rev - -let rec drop h n = - if n < 0 then invalid_arg "Ext_list.drop" - else if n = 0 then h - else - match h with [] -> invalid_arg "Ext_list.drop" | _ :: tl -> drop tl (n - 1) - -let rec find_first x p = - match x with [] -> None | x :: l -> if p x then Some x else find_first l p - -let rec find_first_not xs p = - match xs with - | [] -> None - | a :: l -> if p a then find_first_not l p else Some a - -let rec rev_iter l f = - match l with - | [] -> () - | [ x1 ] -> f x1 - | [ x1; x2 ] -> - f x2; - f x1 - | [ x1; x2; x3 ] -> - f x3; - f x2; - f x1 - | [ x1; x2; x3; x4 ] -> - f x4; - f x3; - f x2; - f x1 - | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - rev_iter tail f; - f x5; - f x4; - f x3; - f x2; - f x1 - -let rec iter l f = - match l with - | [] -> () - | [ x1 ] -> f x1 - | [ x1; x2 ] -> - f x1; - f x2 - | [ x1; x2; x3 ] -> - f x1; - f x2; - f x3 - | [ x1; x2; x3; x4 ] -> - f x1; - f x2; - f x3; - f x4 - | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - f x1; - f x2; - f x3; - f x4; - f x5; - iter tail f - -let rec for_all lst p = - match lst with [] -> true | a :: l -> p a && for_all l p - -let rec for_all_snd lst p = - match lst with [] -> true | (_, a) :: l -> p a && for_all_snd l p - -let rec for_all2_no_exn l1 l2 p = - match (l1, l2) with - | [], [] -> true - | a1 :: l1, a2 :: l2 -> p a1 a2 && for_all2_no_exn l1 l2 p - | _, _ -> false - -let rec find_opt xs p = - match xs with - | [] -> None - | x :: l -> ( match p x with Some _ as v -> v | None -> find_opt l p) - -let rec find_def xs p def = - match xs with - | [] -> def - | x :: l -> ( match p x with Some v -> v | None -> find_def l p def) - -let rec split_map l f = - match l with - | [] -> ([], []) - | [ x1 ] -> - let a0, b0 = f x1 in - ([ a0 ], [ b0 ]) - | [ x1; x2 ] -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - ([ a1; a2 ], [ b1; b2 ]) - | [ x1; x2; x3 ] -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - let a3, b3 = f x3 in - ([ a1; a2; a3 ], [ b1; b2; b3 ]) - | [ x1; x2; x3; x4 ] -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - let a3, b3 = f x3 in - let a4, b4 = f x4 in - ([ a1; a2; a3; a4 ], [ b1; b2; b3; b4 ]) - | x1 :: x2 :: x3 :: x4 :: x5 :: tail -> - let a1, b1 = f x1 in - let a2, b2 = f x2 in - let a3, b3 = f x3 in - let a4, b4 = f x4 in - let a5, b5 = f x5 in - let ass, bss = split_map tail f in - (a1 :: a2 :: a3 :: a4 :: a5 :: ass, b1 :: b2 :: b3 :: b4 :: b5 :: bss) - -let sort_via_array lst cmp = - let arr = Array.of_list lst in - Array.sort cmp arr; - Array.to_list arr - -let sort_via_arrayf lst cmp f = - let arr = Array.of_list lst in - Array.sort cmp arr; - Ext_array.to_list_f arr f - -let rec assoc_by_string lst (k : string) def = - match lst with - | [] -> ( match def with None -> assert false | Some x -> x) - | (k1, v1) :: rest -> if k1 = k then v1 else assoc_by_string rest k def - -let rec assoc_by_int lst (k : int) def = - match lst with - | [] -> ( match def with None -> assert false | Some x -> x) - | (k1, v1) :: rest -> if k1 = k then v1 else assoc_by_int rest k def - -let rec nth_aux l n = - match l with - | [] -> None - | a :: l -> if n = 0 then Some a else nth_aux l (n - 1) - -let nth_opt l n = if n < 0 then None else nth_aux l n - -let rec iter_snd lst f = - match lst with - | [] -> () - | (_, x) :: xs -> - f x; - iter_snd xs f - -let rec iter_fst lst f = - match lst with - | [] -> () - | (x, _) :: xs -> - f x; - iter_fst xs f - -let rec exists l p = match l with [] -> false | x :: xs -> p x || exists xs p - -let rec exists_fst l p = - match l with [] -> false | (a, _) :: l -> p a || exists_fst l p - -let rec exists_snd l p = - match l with [] -> false | (_, a) :: l -> p a || exists_snd l p - -let rec concat_append (xss : 'a list list) (xs : 'a list) : 'a list = - match xss with [] -> xs | l :: r -> append l (concat_append r xs) - -let rec fold_left l accu f = - match l with [] -> accu | a :: l -> fold_left l (f accu a) f - -let reduce_from_left lst fn = - match lst with - | first :: rest -> fold_left rest first fn - | _ -> invalid_arg "Ext_list.reduce_from_left" - -let rec fold_left2 l1 l2 accu f = - match (l1, l2) with - | [], [] -> accu - | a1 :: l1, a2 :: l2 -> fold_left2 l1 l2 (f a1 a2 accu) f - | _, _ -> invalid_arg "Ext_list.fold_left2" - -let singleton_exn xs = match xs with [ x ] -> x | _ -> assert false - -let rec mem_string (xs : string list) (x : string) = - match xs with [] -> false | a :: l -> a = x || mem_string l x - -let filter lst p = - let rec find ~p accu lst = - match lst with - | [] -> rev accu - | x :: l -> if p x then find (x :: accu) l ~p else find accu l ~p - in - find [] lst ~p diff --git a/jscomp/ext/ext_module_system.ml b/jscomp/ext/ext_module_system.ml deleted file mode 100644 index 9b06848..0000000 --- a/jscomp/ext/ext_module_system.ml +++ /dev/null @@ -1 +0,0 @@ -type t = Commonjs | Esmodule | Es6_global diff --git a/jscomp/ext/ext_obj.ml b/jscomp/ext/ext_obj.ml deleted file mode 100644 index f57d9f6..0000000 --- a/jscomp/ext/ext_obj.ml +++ /dev/null @@ -1,124 +0,0 @@ -(* Copyright (C) 2019-Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let rec dump r = - if Obj.is_int r then string_of_int (Obj.magic r : int) - else - (* Block. *) - let rec get_fields acc = function - | 0 -> acc - | n -> - let n = n - 1 in - get_fields (Obj.field r n :: acc) n - in - let rec is_list r = - if Obj.is_int r then r = Obj.repr 0 (* [] *) - else - let s = Obj.size r and t = Obj.tag r in - t = 0 && s = 2 && is_list (Obj.field r 1) - (* h :: t *) - in - let rec get_list r = - if Obj.is_int r then [] - else - let h = Obj.field r 0 and t = get_list (Obj.field r 1) in - h :: t - in - let opaque name = - (* XXX In future, print the address of value 'r'. Not possible - * in pure OCaml at the moment. *) - "<" ^ name ^ ">" - in - let s = Obj.size r and t = Obj.tag r in - (* From the tag, determine the type of block. *) - match t with - | _ when is_list r -> - let fields = get_list r in - "[" ^ String.concat "; " (Ext_list.map fields dump) ^ "]" - | 0 -> - let fields = get_fields [] s in - "(" ^ String.concat ", " (Ext_list.map fields dump) ^ ")" - | x when x = Obj.lazy_tag -> - (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not - * clear if very large constructed values could have the same - * tag. XXX *) - opaque "lazy" - | x when x = Obj.closure_tag -> opaque "closure" - | x when x = Obj.object_tag -> - let fields = get_fields [] s in - let _clasz, id, slots = - match fields with h :: h' :: t -> (h, h', t) | _ -> assert false - in - (* No information on decoding the class (first field). So just print - * out the ID and the slots. *) - "Object #" ^ dump id ^ " (" - ^ String.concat ", " (Ext_list.map slots dump) - ^ ")" - | x when x = Obj.infix_tag -> opaque "infix" - | x when x = Obj.forward_tag -> opaque "forward" - | x when x < Obj.no_scan_tag -> - let fields = get_fields [] s in - "Tag" ^ string_of_int t ^ " (" - ^ String.concat ", " (Ext_list.map fields dump) - ^ ")" - | x when x = Obj.string_tag -> - "\"" ^ String.escaped (Obj.magic r : string) ^ "\"" - | x when x = Obj.double_tag -> string_of_float (Obj.magic r : float) - | x when x = Obj.abstract_tag -> opaque "abstract" - | x when x = Obj.custom_tag -> opaque "custom" - | x when x = Obj.custom_tag -> opaque "final" - | x when x = Obj.double_array_tag -> - "[|" - ^ String.concat ";" - (Array.to_list - (Array.map string_of_float (Obj.magic r : float array))) - ^ "|]" - | _ -> opaque (Printf.sprintf "unknown: tag %d size %d" t s) - -let dump v = dump (Obj.repr v) - -let dump_endline ?(__LOC__ = "") v = - print_endline __LOC__; - print_endline (dump v) - -let pp_any fmt v = Format.fprintf fmt "@[%s@]" (dump v) - -let bt () = - let raw_bt = Printexc.backtrace_slots (Printexc.get_raw_backtrace ()) in - match raw_bt with - | None -> () - | Some raw_bt -> - let acc = ref [] in - for i = Array.length raw_bt - 1 downto 0 do - let slot = raw_bt.(i) in - match Printexc.Slot.location slot with - | None -> () - | Some bt -> ( - match !acc with - | [] -> acc := [ bt ] - | hd :: _ -> if hd <> bt then acc := bt :: !acc) - done; - Ext_list.iter !acc (fun bt -> - Printf.eprintf "File \"%s\", line %d, characters %d-%d\n" bt.filename - bt.line_number bt.start_char bt.end_char) diff --git a/jscomp/ext/ext_stack.ml b/jscomp/ext/ext_stack.ml deleted file mode 100644 index 0ecebca..0000000 --- a/jscomp/ext/ext_stack.ml +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type 'a t = 'a list ref - -let create_ref_empty () = ref [] - -let ref_top x = - match !x with y :: _ -> y | _ -> invalid_arg "Ext_list.ref_top" - -let ref_empty x = match !x with [] -> true | _ -> false - -let ref_push x refs = refs := x :: !refs - -let ref_pop refs = - match !refs with - | [] -> invalid_arg "Ext_list.ref_pop" - | x :: rest -> - refs := rest; - x diff --git a/jscomp/ext/ext_stack.mli b/jscomp/ext/ext_stack.mli deleted file mode 100644 index 2d85a31..0000000 --- a/jscomp/ext/ext_stack.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type 'a t = 'a list ref - -val create_ref_empty : unit -> 'a t - -val ref_top : 'a t -> 'a - -val ref_empty : 'a t -> bool - -val ref_push : 'a -> 'a t -> unit - -val ref_pop : 'a t -> 'a diff --git a/jscomp/ext/ext_string_array.ml b/jscomp/ext/ext_string_array.ml deleted file mode 100644 index 27b8c18..0000000 --- a/jscomp/ext/ext_string_array.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* Copyright (C) 2020 - Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Invariant: the same as encoding Map_string.compare_key *) -let cmp = Ext_string.compare - -let rec binarySearchAux (arr : string array) (lo : int) (hi : int) - (key : string) : _ option = - let mid = (lo + hi) / 2 in - let midVal = Array.unsafe_get arr mid in - let c = cmp key midVal in - if c = 0 then Some mid - else if c < 0 then - (* a[lo] =< key < a[mid] <= a[hi] *) - if hi = mid then - let loVal = Array.unsafe_get arr lo in - if loVal = key then Some lo else None - else binarySearchAux arr lo mid key - else if (* a[lo] =< a[mid] < key <= a[hi] *) - lo = mid then - let hiVal = Array.unsafe_get arr hi in - if hiVal = key then Some hi else None - else binarySearchAux arr mid hi key - -let find_sorted sorted key : int option = - let len = Array.length sorted in - if len = 0 then None - else - let lo = Array.unsafe_get sorted 0 in - let c = cmp key lo in - if c < 0 then None - else - let hi = Array.unsafe_get sorted (len - 1) in - let c2 = cmp key hi in - if c2 > 0 then None else binarySearchAux sorted 0 (len - 1) key - -let rec binarySearchAssoc (arr : (string * _) array) (lo : int) (hi : int) - (key : string) : _ option = - let mid = (lo + hi) / 2 in - let midVal = Array.unsafe_get arr mid in - let c = cmp key (fst midVal) in - if c = 0 then Some (snd midVal) - else if c < 0 then - (* a[lo] =< key < a[mid] <= a[hi] *) - if hi = mid then - let loVal = Array.unsafe_get arr lo in - if fst loVal = key then Some (snd loVal) else None - else binarySearchAssoc arr lo mid key - else if (* a[lo] =< a[mid] < key <= a[hi] *) - lo = mid then - let hiVal = Array.unsafe_get arr hi in - if fst hiVal = key then Some (snd hiVal) else None - else binarySearchAssoc arr mid hi key - -let find_sorted_assoc (type a) (sorted : (string * a) array) (key : string) : - a option = - let len = Array.length sorted in - if len = 0 then None - else - let lo = Array.unsafe_get sorted 0 in - let c = cmp key (fst lo) in - if c < 0 then None - else - let hi = Array.unsafe_get sorted (len - 1) in - let c2 = cmp key (fst hi) in - if c2 > 0 then None else binarySearchAssoc sorted 0 (len - 1) key diff --git a/jscomp/ext/ext_topsort.ml b/jscomp/ext/ext_topsort.ml deleted file mode 100644 index fc44e71..0000000 --- a/jscomp/ext/ext_topsort.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type edges = { id : int; deps : Vec_int.t } - -module Edge_vec = Vec.Make (struct - type t = edges - - let null = { id = 0; deps = Vec_int.empty () } -end) - -type t = Edge_vec.t - -(** - This graph is different the graph used in [scc] graph, since - we need dynamic shrink the graph, so for each vector the first node is it self , - it will also change the input. - - TODO: error handling (cycle handling) and defensive bad input (missing edges etc) -*) - -let layered_dfs (g : t) = - let queue = Queue.create () in - let rec aux g = - let new_entries = - Edge_vec.inplace_filter_with - (fun (x : edges) -> not (Vec_int.is_empty x.deps)) - ~cb_no:(fun x acc -> Set_int.add acc x.id) - Set_int.empty g - in - if not (Set_int.is_empty new_entries) then ( - Queue.push new_entries queue; - Edge_vec.iter g (fun edges -> - Vec_int.inplace_filter - (fun x -> not (Set_int.mem new_entries x)) - edges.deps); - aux g) - in - aux g; - queue diff --git a/jscomp/ext/ext_topsort.mli b/jscomp/ext/ext_topsort.mli deleted file mode 100644 index 673f8d1..0000000 --- a/jscomp/ext/ext_topsort.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type edges = { id : int; deps : Vec_int.t } - -module Edge_vec : Vec_gen.S with type elt = edges - -type t = Edge_vec.t - -val layered_dfs : t -> Set_int.t Queue.t -(** the input will be modified , -*) diff --git a/jscomp/ext/hash_gen.ml b/jscomp/ext/hash_gen.ml deleted file mode 100644 index 01b6498..0000000 --- a/jscomp/ext/hash_gen.ml +++ /dev/null @@ -1,241 +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 Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -(* Hash tables *) - -(* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. *) - -type ('a, 'b) bucket = - | Empty - | Cons of { - mutable key : 'a; - mutable data : 'b; - mutable next : ('a, 'b) bucket; - } - -type ('a, 'b) t = { - mutable size : int; - (* number of entries *) - mutable data : ('a, 'b) bucket array; - (* the buckets *) - initial_size : int; (* initial array size *) -} - -let create initial_size = - let s = Ext_util.power_2_above 16 initial_size in - { initial_size = s; size = 0; data = Array.make s Empty } - -let clear h = - h.size <- 0; - let len = Array.length h.data in - for i = 0 to len - 1 do - Array.unsafe_set h.data i Empty - done - -let reset h = - h.size <- 0; - h.data <- Array.make h.initial_size Empty - -let length h = h.size - -let resize indexfun h = - let odata = h.data in - let osize = Array.length odata in - let nsize = osize * 2 in - if nsize < Sys.max_array_length then ( - let ndata = Array.make nsize Empty in - let ndata_tail = Array.make nsize Empty in - h.data <- ndata; - (* so that indexfun sees the new bucket count *) - let rec insert_bucket = function - | Empty -> () - | Cons { key; next } as cell -> - let nidx = indexfun h key in - (match Array.unsafe_get ndata_tail nidx with - | Empty -> Array.unsafe_set ndata nidx cell - | Cons tail -> tail.next <- cell); - Array.unsafe_set ndata_tail nidx cell; - insert_bucket next - in - for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) - done; - for i = 0 to nsize - 1 do - match Array.unsafe_get ndata_tail i with - | Empty -> () - | Cons tail -> tail.next <- Empty - done) - -let iter h f = - let rec do_bucket = function - | Empty -> () - | Cons l -> - f l.key l.data; - do_bucket l.next - in - let d = h.data in - for i = 0 to Array.length d - 1 do - do_bucket (Array.unsafe_get d i) - done - -let fold h init f = - let rec do_bucket b accu = - match b with - | Empty -> accu - | Cons l -> do_bucket l.next (f l.key l.data accu) - in - let d = h.data in - let accu = ref init in - for i = 0 to Array.length d - 1 do - accu := do_bucket (Array.unsafe_get d i) !accu - done; - !accu - -let to_list h f = fold h [] (fun k data acc -> f k data :: acc) - -let rec small_bucket_mem (lst : _ bucket) eq key = - match lst with - | Empty -> false - | Cons lst -> ( - eq key lst.key - || - match lst.next with - | Empty -> false - | Cons lst -> ( - eq key lst.key - || - match lst.next with - | Empty -> false - | Cons lst -> eq key lst.key || small_bucket_mem lst.next eq key)) - -let rec small_bucket_opt eq key (lst : _ bucket) : _ option = - match lst with - | Empty -> None - | Cons lst -> ( - if eq key lst.key then Some lst.data - else - match lst.next with - | Empty -> None - | Cons lst -> ( - if eq key lst.key then Some lst.data - else - match lst.next with - | Empty -> None - | Cons lst -> - if eq key lst.key then Some lst.data - else small_bucket_opt eq key lst.next)) - -let rec small_bucket_key_opt eq key (lst : _ bucket) : _ option = - match lst with - | Empty -> None - | Cons { key = k; next } -> ( - if eq key k then Some k - else - match next with - | Empty -> None - | Cons { key = k; next } -> ( - if eq key k then Some k - else - match next with - | Empty -> None - | Cons { key = k; next } -> - if eq key k then Some k else small_bucket_key_opt eq key next) - ) - -let rec small_bucket_default eq key default (lst : _ bucket) = - match lst with - | Empty -> default - | Cons lst -> ( - if eq key lst.key then lst.data - else - match lst.next with - | Empty -> default - | Cons lst -> ( - if eq key lst.key then lst.data - else - match lst.next with - | Empty -> default - | Cons lst -> - if eq key lst.key then lst.data - else small_bucket_default eq key default lst.next)) - -let rec remove_bucket h (i : int) key ~(prec : _ bucket) (buck : _ bucket) - eq_key = - match buck with - | Empty -> () - | Cons { key = k; next } -> - if eq_key k key then ( - h.size <- h.size - 1; - match prec with - | Empty -> Array.unsafe_set h.data i next - | Cons c -> c.next <- next) - else remove_bucket h i key ~prec:buck next eq_key - -let rec replace_bucket key data (buck : _ bucket) eq_key = - match buck with - | Empty -> true - | Cons slot -> - if eq_key slot.key key then ( - slot.key <- key; - slot.data <- data; - false) - else replace_bucket key data slot.next eq_key - -module type S = sig - type key - - type 'a t - - val create : int -> 'a t - - val clear : 'a t -> unit - - val reset : 'a t -> unit - - val add : 'a t -> key -> 'a -> unit - - val add_or_update : 'a t -> key -> update:('a -> 'a) -> 'a -> unit - - val remove : 'a t -> key -> unit - - val find_exn : 'a t -> key -> 'a - - val find_all : 'a t -> key -> 'a list - - val find_opt : 'a t -> key -> 'a option - - val find_key_opt : 'a t -> key -> key option - (** return the key found in the hashtbl. - Use case: when you find the key existed in hashtbl, - you want to use the one stored in the hashtbl. - (they are semantically equivlanent, but may have other information different) - *) - - val find_default : 'a t -> key -> 'a -> 'a - - val replace : 'a t -> key -> 'a -> unit - - val mem : 'a t -> key -> bool - - val iter : 'a t -> (key -> 'a -> unit) -> unit - - val fold : 'a t -> 'b -> (key -> 'a -> 'b -> 'b) -> 'b - - val length : 'a t -> int - - (* val stats: 'a t -> Hashtbl.statistics *) - val to_list : 'a t -> (key -> 'a -> 'c) -> 'c list - - val of_list2 : key list -> 'a list -> 'a t -end diff --git a/jscomp/ext/hash_ident.mli b/jscomp/ext/hash_ident.mli deleted file mode 100644 index 0a299ad..0000000 --- a/jscomp/ext/hash_ident.mli +++ /dev/null @@ -1,5 +0,0 @@ - - -include Hash_gen.S with type key = Ident.t - - diff --git a/jscomp/ext/hash_set_ident_mask.ml b/jscomp/ext/hash_set_ident_mask.ml deleted file mode 100644 index 8cdc76b..0000000 --- a/jscomp/ext/hash_set_ident_mask.ml +++ /dev/null @@ -1,163 +0,0 @@ - -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** A speicalized datastructure for scc algorithm *) - -type ident = Ident.t - -type bucket = - | Empty - | Cons of { - ident : ident; - mutable mask : bool; - rest : bucket - } - -type t = { - mutable size : int ; - mutable data : bucket array; - mutable mask_size : int (* mark how many idents are marked *) -} - - - -let key_index_by_ident (h : t) (key : Ident.t) = - (Bs_hash_stubs.hash_string_int key.name key.stamp) land (Array.length h.data - 1) - - - - -let create initial_size = - let s = Ext_util.power_2_above 8 initial_size in - { size = 0; data = Array.make s Empty ; mask_size = 0} - -let iter_and_unmask h f = - let rec iter_bucket buckets = - match buckets with - | Empty -> - () - | Cons k -> - let k_mask = k.mask in - f k.ident k_mask ; - if k_mask then - begin - k.mask <- false ; - (* we can set [h.mask_size] to zero, - however, it would result inconsistent state - once [f] throw - *) - h.mask_size <- h.mask_size - 1 - end; - iter_bucket k.rest - in - let d = h.data in - for i = 0 to Array.length d - 1 do - iter_bucket (Array.unsafe_get d i) - done - - -let rec small_bucket_mem key lst = - match lst with - | Empty -> false - | Cons rst -> - Ext_ident.equal key rst.ident || - match rst.rest with - | Empty -> false - | Cons rst -> - Ext_ident.equal key rst.ident || - match rst.rest with - | Empty -> false - | Cons rst -> - Ext_ident.equal key rst.ident || - small_bucket_mem key rst.rest - -let resize indexfun h = - let odata = h.data in - let osize = Array.length odata in - let nsize = osize * 2 in - if nsize < Sys.max_array_length then begin - let ndata = Array.make nsize Empty in - h.data <- ndata; (* so that indexfun sees the new bucket count *) - let rec insert_bucket = function - Empty -> () - | Cons {ident = key; mask; rest} -> - let nidx = indexfun h key in - Array.unsafe_set - ndata (nidx) - (Cons {ident = key; mask; rest = Array.unsafe_get ndata (nidx)}); - insert_bucket rest - in - for i = 0 to osize - 1 do - insert_bucket (Array.unsafe_get odata i) - done - end - -let add_unmask (h : t) (key : Ident.t) = - let i = key_index_by_ident h key in - let h_data = h.data in - let old_bucket = Array.unsafe_get h_data i in - if not (small_bucket_mem key old_bucket) then - begin - Array.unsafe_set h_data i - (Cons {ident = key; mask = false; rest = old_bucket}); - h.size <- h.size + 1 ; - if h.size > Array.length h_data lsl 1 then resize key_index_by_ident h - end - - - - -let rec small_bucket_mask key lst = - match lst with - | Empty -> false - | Cons rst -> - if Ext_ident.equal key rst.ident then - if rst.mask then false else (rst.mask <- true ; true) - else - match rst.rest with - | Empty -> false - | Cons rst -> - if Ext_ident.equal key rst.ident then - if rst.mask then false else (rst.mask <- true ; true) - else - match rst.rest with - | Empty -> false - | Cons rst -> - if Ext_ident.equal key rst.ident then - if rst.mask then false else (rst.mask <- true ; true) - else - small_bucket_mask key rst.rest - -let mask_and_check_all_hit (h : t) (key : Ident.t) = - if - small_bucket_mask key - (Array.unsafe_get h.data (key_index_by_ident h key )) then - begin - h.mask_size <- h.mask_size + 1 - end; - h.size = h.mask_size - - - diff --git a/jscomp/ext/hash_set_ident_mask.mli b/jscomp/ext/hash_set_ident_mask.mli deleted file mode 100644 index 19c60a0..0000000 --- a/jscomp/ext/hash_set_ident_mask.mli +++ /dev/null @@ -1,38 +0,0 @@ - - -(** Based on [hash_set] specialized for mask operations *) -type ident = Ident.t - - -type t - -val create: int -> t - - -(* add one ident - ident is unmaksed by default -*) -val add_unmask : t -> ident -> unit - - -(** [check_mask h key] if [key] exists mask it otherwise nothing - return true if all keys are masked otherwise false -*) -val mask_and_check_all_hit : - t -> - ident -> - bool - -(** [iter_and_unmask f h] iterating the collection and mask all idents, - dont consul the collection in function [f] - TODO: what happens if an exception raised in the callback, - would the hashtbl still be in consistent state? -*) -val iter_and_unmask: - t -> - (ident -> bool -> unit) -> - unit - - - - diff --git a/jscomp/ext/ident.ml b/jscomp/ext/ident.ml deleted file mode 100644 index ca46973..0000000 --- a/jscomp/ext/ident.ml +++ /dev/null @@ -1,249 +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. *) -(* *) -(**************************************************************************) - -open Format - -type t = { stamp: int; name: string; mutable flags: int } - -let [@inlnie] max (x:int) y = if x >= y then x else y -let global_flag = 1 -let predef_exn_flag = 2 - -(* A stamp of 0 denotes a persistent identifier *) - -let currentstamp = ref 0 - -let create s = - incr currentstamp; - { name = s; stamp = !currentstamp; flags = 0 } - -let create_predef_exn s = - incr currentstamp; - { name = s; stamp = !currentstamp; flags = predef_exn_flag } - -let create_persistent s = - { name = s; stamp = 0; flags = global_flag } - -let rename i = - incr currentstamp; - { i with stamp = !currentstamp } - -let name i = i.name - -let unique_name i = i.name ^ "_" ^ string_of_int i.stamp - -let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp - -let persistent i = (i.stamp = 0) - -let equal i1 i2 = i1.name = i2.name - -let same ({stamp; name } : t) i2 = - if stamp <> 0 - then stamp = i2.stamp - else i2.stamp = 0 && name = i2.name - - - -let binding_time i = i.stamp - -let current_time() = !currentstamp -let set_current_time t = currentstamp := max !currentstamp t - -let reinit_level = ref (-1) - -let reinit () = - if !reinit_level < 0 - then reinit_level := !currentstamp - else currentstamp := !reinit_level - -let hide i = - { i with stamp = -1 } - -let make_global i = - i.flags <- i.flags lor global_flag - -let global i = - (i.flags land global_flag) <> 0 - -let is_predef_exn i = - (i.flags land predef_exn_flag) <> 0 - -let print ppf i = - match i.stamp with - | 0 -> fprintf ppf "%s!" i.name - | -1 -> fprintf ppf "%s#" i.name - | n -> fprintf ppf "%s/%i%s" i.name n (if global i then "g" else "") - -type 'a tbl = - Empty - | Node of 'a tbl * 'a data * 'a tbl * int - -and 'a data = - { ident: t; - data: 'a; - previous: 'a data option } - -let empty = Empty - -(* Inline expansion of height for better speed - * let height = function - * Empty -> 0 - * | Node(_,_,_,h) -> h - *) - -let mknode l d r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h - and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - Node(l, d, r, (if hl >= hr then hl + 1 else hr + 1)) - -let balance l d r = - let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h - and hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in - if hl > hr + 1 then - match l with - | Node (ll, ld, lr, _) - when (match ll with Empty -> 0 | Node(_,_,_,h) -> h) >= - (match lr with Empty -> 0 | Node(_,_,_,h) -> h) -> - mknode ll ld (mknode lr d r) - | Node (ll, ld, Node(lrl, lrd, lrr, _), _) -> - mknode (mknode ll ld lrl) lrd (mknode lrr d r) - | _ -> assert false - else if hr > hl + 1 then - match r with - | Node (rl, rd, rr, _) - when (match rr with Empty -> 0 | Node(_,_,_,h) -> h) >= - (match rl with Empty -> 0 | Node(_,_,_,h) -> h) -> - mknode (mknode l d rl) rd rr - | Node (Node (rll, rld, rlr, _), rd, rr, _) -> - mknode (mknode l d rll) rld (mknode rlr rd rr) - | _ -> assert false - else - mknode l d r - -let rec add id data = function - Empty -> - Node(Empty, {ident = id; data = data; previous = None}, Empty, 1) - | Node(l, k, r, h) -> - let c = compare id.name k.ident.name in - if c = 0 then - Node(l, {ident = id; data = data; previous = Some k}, r, h) - else if c < 0 then - balance (add id data l) k r - else - balance l k (add id data r) - -let rec find_stamp s = function - None -> - raise Not_found - | Some k -> - if k.ident.stamp = s then k.data else find_stamp s k.previous - -let rec find_same id = function - Empty -> - raise Not_found - | Node(l, k, r, _) -> - let c = compare id.name k.ident.name in - if c = 0 then - if id.stamp = k.ident.stamp - then k.data - else find_stamp id.stamp k.previous - else - find_same id (if c < 0 then l else r) - -let rec find_name name = function - Empty -> - raise Not_found - | Node(l, k, r, _) -> - let c = compare name k.ident.name in - if c = 0 then - k.ident, k.data - else - find_name name (if c < 0 then l else r) - -let rec get_all = function - | None -> [] - | Some k -> (k.ident, k.data) :: get_all k.previous - -let rec find_all name = function - Empty -> - [] - | Node(l, k, r, _) -> - let c = compare name k.ident.name in - if c = 0 then - (k.ident, k.data) :: get_all k.previous - else - find_all name (if c < 0 then l else r) - -let rec fold_aux f stack accu = function - Empty -> - begin match stack with - [] -> accu - | a :: l -> fold_aux f l accu a - end - | Node(l, k, r, _) -> - fold_aux f (l :: stack) (f k accu) r - -let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl - -let rec fold_data f d accu = - match d with - None -> accu - | Some k -> f k.ident k.data (fold_data f k.previous accu) - -let fold_all f tbl accu = - fold_aux (fun k -> fold_data f (Some k)) [] accu tbl - -(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *) - -let rec iter f = function - Empty -> () - | Node(l, k, r, _) -> - iter f l; f k.ident k.data; iter f r - -(* Idents for sharing keys *) - -(* They should be 'totally fresh' -> neg numbers *) -let key_name = "" - -let make_key_generator () = - let c = ref 1 in - fun id -> - let stamp = !c in - decr c ; - { id with name = key_name; stamp = stamp; } - -let compare x y = - let c = x.stamp - y.stamp in - if c <> 0 then c - else - let c = compare x.name y.name in - if c <> 0 then c - else - compare x.flags y.flags - -let output oc id = output_string oc (unique_name id) -let hash i = (Char.code i.name.[0]) lxor i.stamp - -let original_equal = equal -include Identifiable.Make (struct - type nonrec t = t - let compare = compare - let output = output - let print = print - let hash = hash - let equal = same -end) -let equal = original_equal diff --git a/jscomp/ext/ident.mli b/jscomp/ext/ident.mli deleted file mode 100644 index c2983ed..0000000 --- a/jscomp/ext/ident.mli +++ /dev/null @@ -1,73 +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. *) -(* *) -(**************************************************************************) - -(* Identifiers (unique names) *) - -type t = { stamp: int; name: string; mutable flags: int } - -include Identifiable.S with type t := t -(* Notes: - - [equal] compares identifiers by name - - [compare x y] is 0 if [same x y] is true. - - [compare] compares identifiers by binding location -*) - - -val create: string -> t -val create_persistent: string -> t -val create_predef_exn: string -> t -val rename: t -> t -val name: t -> string -val unique_name: t -> string -val unique_toplevel_name: t -> string -val persistent: t -> bool -val same: t -> t -> bool - (* Compare identifiers by binding location. - Two identifiers are the same either if they are both - non-persistent and have been created by the same call to - [new], or if they are both persistent and have the same - name. *) -val compare: t -> t -> int -val hide: t -> t - (* Return an identifier with same name as the given identifier, - but stamp different from any stamp returned by new. - When put in a 'a tbl, this identifier can only be looked - up by name. *) - -val make_global: t -> unit -val global: t -> bool -val is_predef_exn: t -> bool - -val binding_time: t -> int -val current_time: unit -> int -val set_current_time: int -> unit -val reinit: unit -> unit - -type 'a tbl - (* Association tables from identifiers to type 'a. *) - -val empty: 'a tbl -val add: t -> 'a -> 'a tbl -> 'a tbl -val find_same: t -> 'a tbl -> 'a -val find_name: string -> 'a tbl -> t * 'a -val find_all: string -> 'a tbl -> (t * 'a) list -val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b -val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b -val iter: (t -> 'a -> unit) -> 'a tbl -> unit - - -(* Idents for sharing keys *) - -val make_key_generator : unit -> (t -> t) diff --git a/jscomp/ext/js_reserved_map.ml b/jscomp/ext/js_reserved_map.ml deleted file mode 100644 index c60bea0..0000000 --- a/jscomp/ext/js_reserved_map.ml +++ /dev/null @@ -1,820 +0,0 @@ - -(* Copyright (C) 2019-Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let sorted_keywords = [| - "AbortController"; - "AbortSignal"; - "AbstractRange"; - "ActiveXObject"; - "AggregateError"; - "AnalyserNode"; - "Animation"; - "AnimationEffect"; - "AnimationEvent"; - "AnimationPlaybackEvent"; - "AnimationTimeline"; - "Array"; - "ArrayBuffer"; - "Atomics"; - "Attr"; - "Audio"; - "AudioBuffer"; - "AudioBufferSourceNode"; - "AudioContext"; - "AudioData"; - "AudioDestinationNode"; - "AudioListener"; - "AudioNode"; - "AudioParam"; - "AudioParamMap"; - "AudioProcessingEvent"; - "AudioScheduledSourceNode"; - "AudioSinkInfo"; - "AudioWorkletNode"; - "BackgroundFetchManager"; - "BackgroundFetchRecord"; - "BackgroundFetchRegistration"; - "BarProp"; - "BaseAudioContext"; - "BeforeInstallPromptEvent"; - "BeforeUnloadEvent"; - "BigInt"; - "BigInt64Array"; - "BigUint64Array"; - "BiquadFilterNode"; - "Blob"; - "BlobEvent"; - "BluetoothUUID"; - "Boolean"; - "BroadcastChannel"; - "BrowserCaptureMediaStreamTrack"; - "Buffer"; - "Bun"; - "ByteLengthQueuingStrategy"; - "CDATASection"; - "CSS"; - "CSSAnimation"; - "CSSConditionRule"; - "CSSContainerRule"; - "CSSCounterStyleRule"; - "CSSFontFaceRule"; - "CSSFontPaletteValuesRule"; - "CSSGroupingRule"; - "CSSImageValue"; - "CSSImportRule"; - "CSSKeyframeRule"; - "CSSKeyframesRule"; - "CSSKeywordValue"; - "CSSLayerBlockRule"; - "CSSLayerStatementRule"; - "CSSMathClamp"; - "CSSMathInvert"; - "CSSMathMax"; - "CSSMathMin"; - "CSSMathNegate"; - "CSSMathProduct"; - "CSSMathSum"; - "CSSMathValue"; - "CSSMatrixComponent"; - "CSSMediaRule"; - "CSSNamespaceRule"; - "CSSNumericArray"; - "CSSNumericValue"; - "CSSPageRule"; - "CSSPerspective"; - "CSSPositionValue"; - "CSSPropertyRule"; - "CSSRotate"; - "CSSRule"; - "CSSRuleList"; - "CSSScale"; - "CSSSkew"; - "CSSSkewX"; - "CSSSkewY"; - "CSSStyleDeclaration"; - "CSSStyleRule"; - "CSSStyleSheet"; - "CSSStyleValue"; - "CSSSupportsRule"; - "CSSTransformComponent"; - "CSSTransformValue"; - "CSSTransition"; - "CSSTranslate"; - "CSSUnitValue"; - "CSSUnparsedValue"; - "CSSVariableReferenceValue"; - "CanvasCaptureMediaStreamTrack"; - "CanvasGradient"; - "CanvasPattern"; - "CanvasRenderingContext2D"; - "ChannelMergerNode"; - "ChannelSplitterNode"; - "CharacterData"; - "ClipboardEvent"; - "CloseEvent"; - "Comment"; - "CompositionEvent"; - "CompressionStream"; - "ConstantSourceNode"; - "ContentVisibilityAutoStateChangeEvent"; - "ConvolverNode"; - "CountQueuingStrategy"; - "CropTarget"; - "Crypto"; - "CustomElementRegistry"; - "CustomEvent"; - "CustomStateSet"; - "DOMError"; - "DOMException"; - "DOMImplementation"; - "DOMMatrix"; - "DOMMatrixReadOnly"; - "DOMParser"; - "DOMPoint"; - "DOMPointReadOnly"; - "DOMQuad"; - "DOMRect"; - "DOMRectList"; - "DOMRectReadOnly"; - "DOMStringList"; - "DOMStringMap"; - "DOMTokenList"; - "DataTransfer"; - "DataTransferItem"; - "DataTransferItemList"; - "DataView"; - "Date"; - "DecompressionStream"; - "DelayNode"; - "DelegatedInkTrailPresenter"; - "Deno"; - "Document"; - "DocumentFragment"; - "DocumentPictureInPictureEvent"; - "DocumentTimeline"; - "DocumentType"; - "DragEvent"; - "DynamicsCompressorNode"; - "Element"; - "ElementInternals"; - "EncodedAudioChunk"; - "EncodedVideoChunk"; - "Error"; - "ErrorEvent"; - "EvalError"; - "Event"; - "EventCounts"; - "EventSource"; - "EventTarget"; - "External"; - "FeaturePolicy"; - "File"; - "FileList"; - "FileReader"; - "FinalizationRegistry"; - "Float32Array"; - "Float64Array"; - "FocusEvent"; - "FontFace"; - "FontFaceSetLoadEvent"; - "FormData"; - "FormDataEvent"; - "FragmentDirective"; - "Function"; - "GainNode"; - "Gamepad"; - "GamepadButton"; - "GamepadEvent"; - "GamepadHapticActuator"; - "Geolocation"; - "GeolocationCoordinates"; - "GeolocationPosition"; - "GeolocationPositionError"; - "HTMLAllCollection"; - "HTMLAnchorElement"; - "HTMLAreaElement"; - "HTMLAudioElement"; - "HTMLBRElement"; - "HTMLBaseElement"; - "HTMLBodyElement"; - "HTMLButtonElement"; - "HTMLCanvasElement"; - "HTMLCollection"; - "HTMLDListElement"; - "HTMLDataElement"; - "HTMLDataListElement"; - "HTMLDetailsElement"; - "HTMLDialogElement"; - "HTMLDirectoryElement"; - "HTMLDivElement"; - "HTMLDocument"; - "HTMLElement"; - "HTMLEmbedElement"; - "HTMLFieldSetElement"; - "HTMLFontElement"; - "HTMLFormControlsCollection"; - "HTMLFormElement"; - "HTMLFrameElement"; - "HTMLFrameSetElement"; - "HTMLHRElement"; - "HTMLHeadElement"; - "HTMLHeadingElement"; - "HTMLHtmlElement"; - "HTMLIFrameElement"; - "HTMLImageElement"; - "HTMLInputElement"; - "HTMLLIElement"; - "HTMLLabelElement"; - "HTMLLegendElement"; - "HTMLLinkElement"; - "HTMLMapElement"; - "HTMLMarqueeElement"; - "HTMLMediaElement"; - "HTMLMenuElement"; - "HTMLMetaElement"; - "HTMLMeterElement"; - "HTMLModElement"; - "HTMLOListElement"; - "HTMLObjectElement"; - "HTMLOptGroupElement"; - "HTMLOptionElement"; - "HTMLOptionsCollection"; - "HTMLOutputElement"; - "HTMLParagraphElement"; - "HTMLParamElement"; - "HTMLPictureElement"; - "HTMLPreElement"; - "HTMLProgressElement"; - "HTMLQuoteElement"; - "HTMLScriptElement"; - "HTMLSelectElement"; - "HTMLSlotElement"; - "HTMLSourceElement"; - "HTMLSpanElement"; - "HTMLStyleElement"; - "HTMLTableCaptionElement"; - "HTMLTableCellElement"; - "HTMLTableColElement"; - "HTMLTableElement"; - "HTMLTableRowElement"; - "HTMLTableSectionElement"; - "HTMLTemplateElement"; - "HTMLTextAreaElement"; - "HTMLTimeElement"; - "HTMLTitleElement"; - "HTMLTrackElement"; - "HTMLUListElement"; - "HTMLUnknownElement"; - "HTMLVideoElement"; - "HashChangeEvent"; - "Headers"; - "Highlight"; - "HighlightRegistry"; - "History"; - "IDBCursor"; - "IDBCursorWithValue"; - "IDBDatabase"; - "IDBFactory"; - "IDBIndex"; - "IDBKeyRange"; - "IDBObjectStore"; - "IDBOpenDBRequest"; - "IDBRequest"; - "IDBTransaction"; - "IDBVersionChangeEvent"; - "IIRFilterNode"; - "IdleDeadline"; - "Image"; - "ImageBitmap"; - "ImageBitmapRenderingContext"; - "ImageCapture"; - "ImageData"; - "ImageTrack"; - "ImageTrackList"; - "Infinity"; - "Ink"; - "InputDeviceCapabilities"; - "InputDeviceInfo"; - "InputEvent"; - "Int16Array"; - "Int32Array"; - "Int8Array"; - "IntersectionObserver"; - "IntersectionObserverEntry"; - "Intl"; - "JSON"; - "KeyboardEvent"; - "KeyframeEffect"; - "LargestContentfulPaint"; - "LaunchParams"; - "LaunchQueue"; - "LayoutShift"; - "LayoutShiftAttribution"; - "Location"; - "Map"; - "Math"; - "MathMLElement"; - "MediaCapabilities"; - "MediaElementAudioSourceNode"; - "MediaEncryptedEvent"; - "MediaError"; - "MediaList"; - "MediaMetadata"; - "MediaQueryList"; - "MediaQueryListEvent"; - "MediaRecorder"; - "MediaSession"; - "MediaSource"; - "MediaSourceHandle"; - "MediaStream"; - "MediaStreamAudioDestinationNode"; - "MediaStreamAudioSourceNode"; - "MediaStreamEvent"; - "MediaStreamTrack"; - "MediaStreamTrackEvent"; - "MediaStreamTrackGenerator"; - "MediaStreamTrackProcessor"; - "MessageChannel"; - "MessageEvent"; - "MessagePort"; - "MimeType"; - "MimeTypeArray"; - "MouseEvent"; - "MutationEvent"; - "MutationObserver"; - "MutationRecord"; - "NaN"; - "NamedNodeMap"; - "NavigateEvent"; - "Navigation"; - "NavigationCurrentEntryChangeEvent"; - "NavigationDestination"; - "NavigationHistoryEntry"; - "NavigationTransition"; - "Navigator"; - "NavigatorUAData"; - "NetworkInformation"; - "Node"; - "NodeFilter"; - "NodeIterator"; - "NodeList"; - "Notification"; - "Number"; - "Object"; - "OfflineAudioCompletionEvent"; - "OfflineAudioContext"; - "OffscreenCanvas"; - "OffscreenCanvasRenderingContext2D"; - "Option"; - "OscillatorNode"; - "OverconstrainedError"; - "PageTransitionEvent"; - "PannerNode"; - "Path2D"; - "PaymentManager"; - "PaymentRequestUpdateEvent"; - "Performance"; - "PerformanceElementTiming"; - "PerformanceEntry"; - "PerformanceEventTiming"; - "PerformanceLongTaskTiming"; - "PerformanceMark"; - "PerformanceMeasure"; - "PerformanceNavigation"; - "PerformanceNavigationTiming"; - "PerformanceObserver"; - "PerformanceObserverEntryList"; - "PerformancePaintTiming"; - "PerformanceResourceTiming"; - "PerformanceServerTiming"; - "PerformanceTiming"; - "PeriodicSyncManager"; - "PeriodicWave"; - "PermissionStatus"; - "Permissions"; - "PictureInPictureEvent"; - "PictureInPictureWindow"; - "Plugin"; - "PluginArray"; - "PointerEvent"; - "PopStateEvent"; - "ProcessingInstruction"; - "Profiler"; - "ProgressEvent"; - "Promise"; - "PromiseRejectionEvent"; - "Proxy"; - "PushManager"; - "PushSubscription"; - "PushSubscriptionOptions"; - "RTCCertificate"; - "RTCDTMFSender"; - "RTCDTMFToneChangeEvent"; - "RTCDataChannel"; - "RTCDataChannelEvent"; - "RTCDtlsTransport"; - "RTCEncodedAudioFrame"; - "RTCEncodedVideoFrame"; - "RTCError"; - "RTCErrorEvent"; - "RTCIceCandidate"; - "RTCIceTransport"; - "RTCPeerConnection"; - "RTCPeerConnectionIceErrorEvent"; - "RTCPeerConnectionIceEvent"; - "RTCRtpReceiver"; - "RTCRtpSender"; - "RTCRtpTransceiver"; - "RTCSctpTransport"; - "RTCSessionDescription"; - "RTCStatsReport"; - "RTCTrackEvent"; - "RadioNodeList"; - "Range"; - "RangeError"; - "ReadableByteStreamController"; - "ReadableStream"; - "ReadableStreamBYOBReader"; - "ReadableStreamBYOBRequest"; - "ReadableStreamDefaultController"; - "ReadableStreamDefaultReader"; - "ReferenceError"; - "Reflect"; - "RegExp"; - "RemotePlayback"; - "ReportingObserver"; - "Request"; - "ResizeObserver"; - "ResizeObserverEntry"; - "ResizeObserverSize"; - "Response"; - "SVGAElement"; - "SVGAngle"; - "SVGAnimateElement"; - "SVGAnimateMotionElement"; - "SVGAnimateTransformElement"; - "SVGAnimatedAngle"; - "SVGAnimatedBoolean"; - "SVGAnimatedEnumeration"; - "SVGAnimatedInteger"; - "SVGAnimatedLength"; - "SVGAnimatedLengthList"; - "SVGAnimatedNumber"; - "SVGAnimatedNumberList"; - "SVGAnimatedPreserveAspectRatio"; - "SVGAnimatedRect"; - "SVGAnimatedString"; - "SVGAnimatedTransformList"; - "SVGAnimationElement"; - "SVGCircleElement"; - "SVGClipPathElement"; - "SVGComponentTransferFunctionElement"; - "SVGDefsElement"; - "SVGDescElement"; - "SVGElement"; - "SVGEllipseElement"; - "SVGFEBlendElement"; - "SVGFEColorMatrixElement"; - "SVGFEComponentTransferElement"; - "SVGFECompositeElement"; - "SVGFEConvolveMatrixElement"; - "SVGFEDiffuseLightingElement"; - "SVGFEDisplacementMapElement"; - "SVGFEDistantLightElement"; - "SVGFEDropShadowElement"; - "SVGFEFloodElement"; - "SVGFEFuncAElement"; - "SVGFEFuncBElement"; - "SVGFEFuncGElement"; - "SVGFEFuncRElement"; - "SVGFEGaussianBlurElement"; - "SVGFEImageElement"; - "SVGFEMergeElement"; - "SVGFEMergeNodeElement"; - "SVGFEMorphologyElement"; - "SVGFEOffsetElement"; - "SVGFEPointLightElement"; - "SVGFESpecularLightingElement"; - "SVGFESpotLightElement"; - "SVGFETileElement"; - "SVGFETurbulenceElement"; - "SVGFilterElement"; - "SVGForeignObjectElement"; - "SVGGElement"; - "SVGGeometryElement"; - "SVGGradientElement"; - "SVGGraphicsElement"; - "SVGImageElement"; - "SVGLength"; - "SVGLengthList"; - "SVGLineElement"; - "SVGLinearGradientElement"; - "SVGMPathElement"; - "SVGMarkerElement"; - "SVGMaskElement"; - "SVGMatrix"; - "SVGMetadataElement"; - "SVGNumber"; - "SVGNumberList"; - "SVGPathElement"; - "SVGPatternElement"; - "SVGPoint"; - "SVGPointList"; - "SVGPolygonElement"; - "SVGPolylineElement"; - "SVGPreserveAspectRatio"; - "SVGRadialGradientElement"; - "SVGRect"; - "SVGRectElement"; - "SVGSVGElement"; - "SVGScriptElement"; - "SVGSetElement"; - "SVGStopElement"; - "SVGStringList"; - "SVGStyleElement"; - "SVGSwitchElement"; - "SVGSymbolElement"; - "SVGTSpanElement"; - "SVGTextContentElement"; - "SVGTextElement"; - "SVGTextPathElement"; - "SVGTextPositioningElement"; - "SVGTitleElement"; - "SVGTransform"; - "SVGTransformList"; - "SVGUnitTypes"; - "SVGUseElement"; - "SVGViewElement"; - "Scheduler"; - "Scheduling"; - "Screen"; - "ScreenOrientation"; - "ScriptProcessorNode"; - "ScrollTimeline"; - "SecurityPolicyViolationEvent"; - "Selection"; - "Set"; - "ShadowRoot"; - "SharedWorker"; - "SourceBuffer"; - "SourceBufferList"; - "SpeechSynthesisErrorEvent"; - "SpeechSynthesisEvent"; - "SpeechSynthesisUtterance"; - "StaticRange"; - "StereoPannerNode"; - "Storage"; - "StorageEvent"; - "String"; - "StylePropertyMap"; - "StylePropertyMapReadOnly"; - "StyleSheet"; - "StyleSheetList"; - "SubmitEvent"; - "Symbol"; - "SyncManager"; - "SyntaxError"; - "TaskAttributionTiming"; - "TaskController"; - "TaskPriorityChangeEvent"; - "TaskSignal"; - "Text"; - "TextDecoder"; - "TextDecoderStream"; - "TextEncoder"; - "TextEncoderStream"; - "TextEvent"; - "TextMetrics"; - "TextTrack"; - "TextTrackCue"; - "TextTrackCueList"; - "TextTrackList"; - "TimeRanges"; - "ToggleEvent"; - "Touch"; - "TouchEvent"; - "TouchList"; - "TrackEvent"; - "TransformStream"; - "TransformStreamDefaultController"; - "TransitionEvent"; - "TreeWalker"; - "TrustedHTML"; - "TrustedScript"; - "TrustedScriptURL"; - "TrustedTypePolicy"; - "TrustedTypePolicyFactory"; - "TypeError"; - "UIEvent"; - "URIError"; - "URL"; - "URLPattern"; - "URLSearchParams"; - "Uint16Array"; - "Uint32Array"; - "Uint8Array"; - "Uint8ClampedArray"; - "UserActivation"; - "VTTCue"; - "ValidityState"; - "VideoColorSpace"; - "VideoFrame"; - "VideoPlaybackQuality"; - "ViewTimeline"; - "ViewTransition"; - "VirtualKeyboardGeometryChangeEvent"; - "VisibilityStateEntry"; - "VisualViewport"; - "WaveShaperNode"; - "WeakMap"; - "WeakRef"; - "WeakSet"; - "WebAssembly"; - "WebGL2RenderingContext"; - "WebGLActiveInfo"; - "WebGLBuffer"; - "WebGLContextEvent"; - "WebGLFramebuffer"; - "WebGLProgram"; - "WebGLQuery"; - "WebGLRenderbuffer"; - "WebGLRenderingContext"; - "WebGLSampler"; - "WebGLShader"; - "WebGLShaderPrecisionFormat"; - "WebGLSync"; - "WebGLTexture"; - "WebGLTransformFeedback"; - "WebGLUniformLocation"; - "WebGLVertexArrayObject"; - "WebKitCSSMatrix"; - "WebKitMutationObserver"; - "WebSocket"; - "WheelEvent"; - "Window"; - "WindowControlsOverlay"; - "WindowControlsOverlayGeometryChangeEvent"; - "Worker"; - "WritableStream"; - "WritableStreamDefaultController"; - "WritableStreamDefaultWriter"; - "XDomainRequest"; - "XMLDocument"; - "XMLHttpRequest"; - "XMLHttpRequestEventTarget"; - "XMLHttpRequestUpload"; - "XMLSerializer"; - "XPathEvaluator"; - "XPathExpression"; - "XPathResult"; - "XSLTProcessor"; - "__dirname"; - "__esModule"; - "__filename"; - "abstract"; - "arguments"; - "await"; - "boolean"; - "break"; - "byte"; - "case"; - "catch"; - "char"; - "class"; - "clearImmediate"; - "clearInterval"; - "clearTimeout"; - "console"; - "const"; - "continue"; - "debugger"; - "decodeURI"; - "decodeURIComponent"; - "default"; - "delete"; - "do"; - "document"; - "double"; - "else"; - "encodeURI"; - "encodeURIComponent"; - "enum"; - "escape"; - "eval"; - "event"; - "export"; - "exports"; - "extends"; - "false"; - "fetch"; - "final"; - "finally"; - "float"; - "for"; - "function"; - "global"; - "goto"; - "if"; - "implements"; - "import"; - "in"; - "instanceof"; - "int"; - "interface"; - "isFinite"; - "isNaN"; - "let"; - "location"; - "long"; - "module"; - "native"; - "navigator"; - "new"; - "null"; - "package"; - "parseFloat"; - "parseInt"; - "private"; - "process"; - "protected"; - "public"; - "require"; - "return"; - "setImmediate"; - "setInterval"; - "setTimeout"; - "short"; - "static"; - "super"; - "switch"; - "synchronized"; - "this"; - "throw"; - "transient"; - "true"; - "try"; - "typeof"; - "undefined"; - "unescape"; - "var"; - "void"; - "volatile"; - "while"; - "window"; - "with"; - "yield"; - |] - - -type element = string - -let rec binarySearchAux (arr : element array) (lo : int) (hi : int) key : bool = - let mid = (lo + hi)/2 in - let midVal = Array.unsafe_get arr mid in - (* let c = cmp key midVal [@bs] in *) - if key = midVal then true - else if key < midVal then (* a[lo] =< key < a[mid] <= a[hi] *) - if hi = mid then - (Array.unsafe_get arr lo) = key - else binarySearchAux arr lo mid key - else (* a[lo] =< a[mid] < key <= a[hi] *) - if lo = mid then - (Array.unsafe_get arr hi) = key - else binarySearchAux arr mid hi key - -let binarySearch (sorted : element array) (key : element) : bool = - let len = Array.length sorted in - if len = 0 then false - else - let lo = Array.unsafe_get sorted 0 in - (* let c = cmp key lo [@bs] in *) - if key < lo then false - else - let hi = Array.unsafe_get sorted (len - 1) in - (* let c2 = cmp key hi [@bs]in *) - if key > hi then false - else binarySearchAux sorted 0 (len - 1) key - -let is_reserved s = binarySearch sorted_keywords s diff --git a/jscomp/ext/js_runtime_modules.ml b/jscomp/ext/js_runtime_modules.ml deleted file mode 100644 index 9c2b3b9..0000000 --- a/jscomp/ext/js_runtime_modules.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let exceptions = "Caml_exceptions" - -let io = "Caml_io" - -let sys = "Caml_sys" - -let lexer = "Caml_lexer" - -let parser = "Caml_parser" - -let obj_runtime = "Caml_obj" - -let array = "Caml_array" - -let format = "Caml_format" - -let string = "Caml_string" - -let bytes = "Caml_bytes" -let bytes_ = "Bytes" - -let float = "Caml_float" - -let hash_primitive = "Caml_hash_primitive" - -let hash = "Caml_hash" - -let curry = "Curry" - -let caml_primitive = "Caml" - -let int64 = "Caml_int64" - -let md5 = "Caml_md5" - -let int32 = "Caml_int32" - -let bigint = "Caml_bigint" - -let option = "Caml_option" - -let module_ = "Caml_module" - -let external_polyfill = "Caml_external_polyfill" - -let caml_js_exceptions = "Caml_js_exceptions" - -let caml_splice_call = "Caml_splice_call" diff --git a/jscomp/ext/map_gen.ml b/jscomp/ext/map_gen.ml deleted file mode 100644 index ecd0aa3..0000000 --- a/jscomp/ext/map_gen.ml +++ /dev/null @@ -1,403 +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 Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) - -[@@@warnerror "+55"] -(* adapted from stdlib *) - -type ('key, 'a) t0 = - | Empty - | Leaf of { k : 'key; v : 'a } - | Node of { l : ('key, 'a) t0; k : 'key; v : 'a; r : ('key, 'a) t0; h : int } - -type ('key, 'a) parital_node = { - l : ('key, 'a) t0; - k : 'key; - v : 'a; - r : ('key, 'a) t0; - h : int; -} - -external ( ~! ) : ('key, 'a) t0 -> ('key, 'a) parital_node = "%identity" - -let empty = Empty - -let rec map x f = - match x with - | Empty -> Empty - | Leaf { k; v } -> Leaf { k; v = f v } - | Node ({ l; v; r } as x) -> - let l' = map l f in - let d' = f v in - let r' = map r f in - Node { x with l = l'; v = d'; r = r' } - -let rec mapi x f = - match x with - | Empty -> Empty - | Leaf { k; v } -> Leaf { k; v = f k v } - | Node ({ l; k; v; r } as x) -> - let l' = mapi l f in - let v' = f k v in - let r' = mapi r f in - Node { x with l = l'; v = v'; r = r' } - -let[@inline] calc_height a b = (if a >= b then a else b) + 1 - -let[@inline] singleton k v = Leaf { k; v } - -let[@inline] height = function Empty -> 0 | Leaf _ -> 1 | Node { h } -> h - -let[@inline] unsafe_node k v l r h = Node { l; k; v; r; h } - -let[@inline] unsafe_two_elements k1 v1 k2 v2 = - unsafe_node k2 v2 (singleton k1 v1) empty 2 - -let[@inline] unsafe_node_maybe_leaf k v l r h = - if h = 1 then Leaf { k; v } else Node { l; k; v; r; h } - -type ('key, +'a) t = ('key, 'a) t0 = private - | Empty - | Leaf of { k : 'key; v : 'a } - | Node of { l : ('key, 'a) t; k : 'key; v : 'a; r : ('key, 'a) t; h : int } - -let rec cardinal_aux acc = function - | Empty -> acc - | Leaf _ -> acc + 1 - | Node { l; r } -> cardinal_aux (cardinal_aux (acc + 1) r) l - -let cardinal s = cardinal_aux 0 s - -let rec bindings_aux accu = function - | Empty -> accu - | Leaf { k; v } -> (k, v) :: accu - | Node { l; k; v; r } -> bindings_aux ((k, v) :: bindings_aux accu r) l - -let bindings s = bindings_aux [] s - -let rec fill_array_with_f (s : _ t) i arr f : int = - match s with - | Empty -> i - | Leaf { k; v } -> - Array.unsafe_set arr i (f k v); - i + 1 - | Node { l; k; v; r } -> - let inext = fill_array_with_f l i arr f in - Array.unsafe_set arr inext (f k v); - fill_array_with_f r (inext + 1) arr f - -let rec fill_array_aux (s : _ t) i arr : int = - match s with - | Empty -> i - | Leaf { k; v } -> - Array.unsafe_set arr i (k, v); - i + 1 - | Node { l; k; v; r } -> - let inext = fill_array_aux l i arr in - Array.unsafe_set arr inext (k, v); - fill_array_aux r (inext + 1) arr - -let to_sorted_array (s : ('key, 'a) t) : ('key * 'a) array = - match s with - | Empty -> [||] - | Leaf { k; v } -> [| (k, v) |] - | Node { l; k; v; r } -> - let len = cardinal_aux (cardinal_aux 1 r) l in - let arr = Array.make len (k, v) in - ignore (fill_array_aux s 0 arr : int); - arr - -let to_sorted_array_with_f (type key a b) (s : (key, a) t) (f : key -> a -> b) : - b array = - match s with - | Empty -> [||] - | Leaf { k; v } -> [| f k v |] - | Node { l; k; v; r } -> - let len = cardinal_aux (cardinal_aux 1 r) l in - let arr = Array.make len (f k v) in - ignore (fill_array_with_f s 0 arr f : int); - arr - -let rec keys_aux accu = function - | Empty -> accu - | Leaf { k } -> k :: accu - | Node { l; k; r } -> keys_aux (k :: keys_aux accu r) l - -let keys s = keys_aux [] s - -let bal l x d r = - let hl = height l in - let hr = height r in - if hl > hr + 2 then - let { l = ll; r = lr; v = lv; k = lk; h = _ } = ~!l in - let hll = height ll in - let hlr = height lr in - if hll >= hlr then - let hnode = calc_height hlr hr in - unsafe_node lk lv ll - (unsafe_node_maybe_leaf x d lr r hnode) - (calc_height hll hnode) - else - let { l = lrl; r = lrr; k = lrk; v = lrv } = ~!lr in - let hlrl = height lrl in - let hlrr = height lrr in - let hlnode = calc_height hll hlrl in - let hrnode = calc_height hlrr hr in - unsafe_node lrk lrv - (unsafe_node_maybe_leaf lk lv ll lrl hlnode) - (unsafe_node_maybe_leaf x d lrr r hrnode) - (calc_height hlnode hrnode) - else if hr > hl + 2 then - let { l = rl; r = rr; k = rk; v = rv } = ~!r in - let hrr = height rr in - let hrl = height rl in - if hrr >= hrl then - let hnode = calc_height hl hrl in - unsafe_node rk rv - (unsafe_node_maybe_leaf x d l rl hnode) - rr (calc_height hnode hrr) - else - let { l = rll; r = rlr; k = rlk; v = rlv } = ~!rl in - let hrll = height rll in - let hrlr = height rlr in - let hlnode = calc_height hl hrll in - let hrnode = calc_height hrlr hrr in - unsafe_node rlk rlv - (unsafe_node_maybe_leaf x d l rll hlnode) - (unsafe_node_maybe_leaf rk rv rlr rr hrnode) - (calc_height hlnode hrnode) - else unsafe_node_maybe_leaf x d l r (calc_height hl hr) - -let[@inline] is_empty = function Empty -> true | _ -> false - -let rec min_binding_exn = function - | Empty -> raise Not_found - | Leaf { k; v } -> (k, v) - | Node { l; k; v } -> ( - match l with Empty -> (k, v) | Leaf _ | Node _ -> min_binding_exn l) - -let rec remove_min_binding = function - | Empty -> invalid_arg "Map.remove_min_elt" - | Leaf _ -> empty - | Node { l = Empty; r } -> r - | Node { l; k; v; r } -> bal (remove_min_binding l) k v r - -let merge t1 t2 = - match (t1, t2) with - | Empty, t -> t - | t, Empty -> t - | _, _ -> - let x, d = min_binding_exn t2 in - bal t1 x d (remove_min_binding t2) - -let rec iter x f = - match x with - | Empty -> () - | Leaf { k; v } -> (f k v : unit) - | Node { l; k; v; r } -> - iter l f; - f k v; - iter r f - -let rec fold m accu f = - match m with - | Empty -> accu - | Leaf { k; v } -> f k v accu - | Node { l; k; v; r } -> fold r (f k v (fold l accu f)) f - -let rec for_all x p = - match x with - | Empty -> true - | Leaf { k; v } -> p k v - | Node { l; k; v; r } -> p k v && for_all l p && for_all r p - -let rec exists x p = - match x with - | Empty -> false - | Leaf { k; v } -> p k v - | Node { l; k; v; r } -> p k v || exists l p || exists r p - -(* Beware: those two functions assume that the added k is *strictly* - smaller (or bigger) than all the present keys in the tree; it - does not test for equality with the current min (or max) key. - - Indeed, they are only used during the "join" operation which - respects this precondition. -*) - -let rec add_min k v = function - | Empty -> singleton k v - | Leaf l -> unsafe_two_elements k v l.k l.v - | Node tree -> bal (add_min k v tree.l) tree.k tree.v tree.r - -let rec add_max k v = function - | Empty -> singleton k v - | Leaf l -> unsafe_two_elements l.k l.v k v - | Node tree -> bal tree.l tree.k tree.v (add_max k v tree.r) - -(* Same as create and bal, but no assumptions are made on the - relative heights of l and r. *) - -let rec join l v d r = - match l with - | Empty -> add_min v d r - | Leaf leaf -> add_min leaf.k leaf.v (add_min v d r) - | Node xl -> ( - match r with - | Empty -> add_max v d l - | Leaf leaf -> add_max leaf.k leaf.v (add_max v d l) - | Node xr -> - let lh = xl.h in - let rh = xr.h in - if lh > rh + 2 then bal xl.l xl.k xl.v (join xl.r v d r) - else if rh > lh + 2 then bal (join l v d xr.l) xr.k xr.v xr.r - else unsafe_node v d l r (calc_height lh rh)) - -(* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. *) - -let concat t1 t2 = - match (t1, t2) with - | Empty, t -> t - | t, Empty -> t - | _, _ -> - let x, d = min_binding_exn t2 in - join t1 x d (remove_min_binding t2) - -let concat_or_join t1 v d t2 = - match d with Some d -> join t1 v d t2 | None -> concat t1 t2 - -module type S = sig - type key - - type +'a t - - val empty : 'a t - - val compare_key : key -> key -> int - - val is_empty : 'a t -> bool - - val mem : 'a t -> key -> bool - - val to_sorted_array : 'a t -> (key * 'a) array - - val to_sorted_array_with_f : 'a t -> (key -> 'a -> 'b) -> 'b array - - val add : 'a t -> key -> 'a -> 'a t - (** [add x y m] - If [x] was already bound in [m], its previous binding disappears. *) - - val adjust : 'a t -> key -> ('a option -> 'a) -> 'a t - (** [adjust acc k replace ] if not exist [add (replace None ], otherwise - [add k v (replace (Some old))] - *) - - val singleton : key -> 'a -> 'a t - - val remove : 'a t -> key -> 'a t - (** [remove x m] returns a map containing the same bindings as - [m], except for [x] which is unbound in the returned map. *) - - (* val merge: - 'a t -> 'b t -> - (key -> 'a option -> 'b option -> 'c option) -> 'c t *) - (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] - and of [m2]. The presence of each such binding, and the corresponding - value, is determined with the function [f]. - @since 3.12.0 - *) - - val disjoint_merge_exn : 'a t -> 'a t -> (key -> 'a -> 'a -> exn) -> 'a t - (* merge two maps, will raise if they have the same key *) - - val iter : 'a t -> (key -> 'a -> unit) -> unit - (** [iter f m] applies [f] to all bindings in map [m]. - The bindings are passed to [f] in increasing order. *) - - val fold : 'a t -> 'b -> (key -> 'a -> 'b -> 'b) -> 'b - (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1 ... kN] are the keys of all bindings in [m] - (in increasing order) *) - - val for_all : 'a t -> (key -> 'a -> bool) -> bool - (** [for_all p m] checks if all the bindings of the map. - order unspecified - *) - - val exists : 'a t -> (key -> 'a -> bool) -> bool - (** [exists p m] checks if at least one binding of the map - satisfy the predicate [p]. - order unspecified - *) - - (* val filter: 'a t -> (key -> 'a -> bool) -> 'a t *) - (** [filter p m] returns the map with all the bindings in [m] - that satisfy predicate [p]. - order unspecified - *) - - (* val partition: 'a t -> (key -> 'a -> bool) -> 'a t * 'a t *) - (** [partition p m] returns a pair of maps [(m1, m2)], where - [m1] contains all the bindings of [s] that satisfy the - predicate [p], and [m2] is the map with all the bindings of - [s] that do not satisfy [p]. - *) - - val cardinal : 'a t -> int - (** Return the number of bindings of a map. *) - - val bindings : 'a t -> (key * 'a) list - (** Return the list of all bindings of the given map. - The returned list is sorted in increasing order with respect - to the ordering *) - - val keys : 'a t -> key list - (* Increasing order *) - - (* val split: 'a t -> key -> 'a t * 'a option * 'a t *) - (** [split x m] returns a triple [(l, data, r)], where - [l] is the map with all the bindings of [m] whose key - is strictly less than [x]; - [r] is the map with all the bindings of [m] whose key - is strictly greater than [x]; - [data] is [None] if [m] contains no binding for [x], - or [Some v] if [m] binds [v] to [x]. - @since 3.12.0 - *) - - val find_exn : 'a t -> key -> 'a - (** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. *) - - val find_opt : 'a t -> key -> 'a option - - val find_default : 'a t -> key -> 'a -> 'a - - val map : 'a t -> ('a -> 'b) -> 'b t - (** [map f m] returns a map with same domain as [m], where the - associated value [a] of all bindings of [m] has been - replaced by the result of the application of [f] to [a]. - The bindings are passed to [f] in increasing order - with respect to the ordering over the type of the keys. *) - - val mapi : 'a t -> (key -> 'a -> 'b) -> 'b t - (** Same as {!Map.S.map}, but the function receives as arguments both the - key and the associated value for each binding of the map. *) - - val of_list : (key * 'a) list -> 'a t - - val of_array : (key * 'a) array -> 'a t - - val add_list : (key * 'b) list -> 'b t -> 'b t -end diff --git a/jscomp/ext/misc.ml b/jscomp/ext/misc.ml deleted file mode 100644 index 33ca3ee..0000000 --- a/jscomp/ext/misc.ml +++ /dev/null @@ -1,746 +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. *) -(* *) -(**************************************************************************) - -(* Errors *) - -exception Fatal_error - - - -let fatal_error msg = - prerr_string ">> Fatal error: "; prerr_endline msg; raise Fatal_error - -let fatal_errorf fmt = Format.kasprintf fatal_error fmt - -(* Exceptions *) - -let try_finally work cleanup = - let result = (try work () with e -> cleanup (); raise e) in - cleanup (); - result -;; - -type ref_and_value = R : 'a ref * 'a -> ref_and_value - -let protect_refs = - let set_refs l = List.iter (fun (R (r, v)) -> r := v) l in - fun refs f -> - let backup = List.map (fun (R (r, _)) -> R (r, !r)) refs in - set_refs refs; - match f () with - | x -> set_refs backup; x - | exception e -> set_refs backup; raise e - -(* List functions *) - -let rec map_end f l1 l2 = - match l1 with - [] -> l2 - | hd::tl -> f hd :: map_end f tl l2 - -let rec map_left_right f = function - [] -> [] - | hd::tl -> let res = f hd in res :: map_left_right f tl - -let rec for_all2 pred l1 l2 = - match (l1, l2) with - ([], []) -> true - | (hd1::tl1, hd2::tl2) -> pred hd1 hd2 && for_all2 pred tl1 tl2 - | (_, _) -> false - -let rec replicate_list elem n = - if n <= 0 then [] else elem :: replicate_list elem (n-1) - -let rec list_remove x = function - [] -> [] - | hd :: tl -> - if hd = x then tl else hd :: list_remove x tl - -let rec split_last = function - [] -> assert false - | [x] -> ([], x) - | hd :: tl -> - let (lst, last) = split_last tl in - (hd :: lst, last) - -module Stdlib = struct - module List = struct - type 'a t = 'a list - - let rec compare cmp l1 l2 = - match l1, l2 with - | [], [] -> 0 - | [], _::_ -> -1 - | _::_, [] -> 1 - | h1::t1, h2::t2 -> - let c = cmp h1 h2 in - if c <> 0 then c - else compare cmp t1 t2 - - let rec equal eq l1 l2 = - match l1, l2 with - | ([], []) -> true - | (hd1 :: tl1, hd2 :: tl2) -> eq hd1 hd2 && equal eq tl1 tl2 - | (_, _) -> false - - let filter_map f l = - let rec aux acc l = - match l with - | [] -> List.rev acc - | h :: t -> - match f h with - | None -> aux acc t - | Some v -> aux (v :: acc) t - in - aux [] l - - let map2_prefix f l1 l2 = - let rec aux acc l1 l2 = - match l1, l2 with - | [], _ -> (List.rev acc, l2) - | _ :: _, [] -> raise (Invalid_argument "map2_prefix") - | h1::t1, h2::t2 -> - let h = f h1 h2 in - aux (h :: acc) t1 t2 - in - aux [] l1 l2 - - let some_if_all_elements_are_some l = - let rec aux acc l = - match l with - | [] -> Some (List.rev acc) - | None :: _ -> None - | Some h :: t -> aux (h :: acc) t - in - aux [] l - - let split_at n l = - let rec aux n acc l = - if n = 0 - then List.rev acc, l - else - match l with - | [] -> raise (Invalid_argument "split_at") - | t::q -> aux (n-1) (t::acc) q - in - aux n [] l - end - - module Option = struct - type 'a t = 'a option - - let equal eq o1 o2 = - match o1, o2 with - | None, None -> true - | Some e1, Some e2 -> eq e1 e2 - | _, _ -> false - - let iter f = function - | Some x -> f x - | None -> () - - let map f = function - | Some x -> Some (f x) - | None -> None - - let fold f a b = - match a with - | None -> b - | Some a -> f a b - - let value_default f ~default a = - match a with - | None -> default - | Some a -> f a - end - - module Array = struct - let exists2 p a1 a2 = - let n = Array.length a1 in - if Array.length a2 <> n then invalid_arg "Misc.Stdlib.Array.exists2"; - let rec loop i = - if i = n then false - else if p (Array.unsafe_get a1 i) (Array.unsafe_get a2 i) then true - else loop (succ i) in - loop 0 - end -end - -let may = Stdlib.Option.iter -let may_map = Stdlib.Option.map - -(* File functions *) - -let find_in_path path name = - if not (Filename.is_implicit name) then - if Sys.file_exists name then name else raise Not_found - else begin - let rec try_dir = function - [] -> raise Not_found - | dir::rem -> - let fullname = Filename.concat dir name in - if Sys.file_exists fullname then fullname else try_dir rem - in try_dir path - end - -let find_in_path_rel path name = - let rec simplify s = - let open Filename in - let base = basename s in - let dir = dirname s in - if dir = s then dir - else if base = current_dir_name then simplify dir - else concat (simplify dir) base - in - let rec try_dir = function - [] -> raise Not_found - | dir::rem -> - let fullname = simplify (Filename.concat dir name) in - if Sys.file_exists fullname then fullname else try_dir rem - in try_dir path - -let find_in_path_uncap path name = - let uname = String.uncapitalize_ascii name in - let rec try_dir = function - [] -> raise Not_found - | dir::rem -> - let fullname = Filename.concat dir name - and ufullname = Filename.concat dir uname in - if Sys.file_exists ufullname then ufullname - else if Sys.file_exists fullname then fullname - else try_dir rem - in try_dir path - -let remove_file filename = - try - if Sys.file_exists filename - then Sys.remove filename - with Sys_error _msg -> - () - -(* Expand a -I option: if it starts with +, make it relative to the standard - library directory *) - -let expand_directory alt s = - if String.length s > 0 && s.[0] = '+' - then Filename.concat alt - (String.sub s 1 (String.length s - 1)) - else s - -(* Hashtable functions *) - -let create_hashtable size init = - let tbl = Hashtbl.create size in - List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; - tbl - -(* File copy *) - -let copy_file ic oc = - let buff = Bytes.create 0x1000 in - let rec copy () = - let n = input ic buff 0 0x1000 in - if n = 0 then () else (output oc buff 0 n; copy()) - in copy() - -let copy_file_chunk ic oc len = - let buff = Bytes.create 0x1000 in - let rec copy n = - if n <= 0 then () else begin - let r = input ic buff 0 (min n 0x1000) in - if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r)) - end - in copy len - -let string_of_file ic = - let b = Buffer.create 0x10000 in - let buff = Bytes.create 0x1000 in - let rec copy () = - let n = input ic buff 0 0x1000 in - if n = 0 then Buffer.contents b else - (Buffer.add_subbytes b buff 0 n; copy()) - in copy() - -let output_to_bin_file_directly filename fn = - let oc = open_out_bin filename in - match fn filename oc with - | v -> close_out oc ; v - | exception e -> close_out oc ; raise e - -let output_to_file_via_temporary ?(mode = [Open_text]) filename fn = - let (temp_filename, oc) = - Filename.open_temp_file - ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename) - (Filename.basename filename) ".tmp" in - (* The 0o666 permissions will be modified by the umask. It's just - like what [open_out] and [open_out_bin] do. - With temp_dir = dirname filename, we ensure that the returned - temp file is in the same directory as filename itself, making - it safe to rename temp_filename to filename later. - With prefix = basename filename, we are almost certain that - the first generated name will be unique. A fixed prefix - would work too but might generate more collisions if many - files are being produced simultaneously in the same directory. *) - match fn temp_filename oc with - | res -> - close_out oc; - begin try - Sys.rename temp_filename filename; res - with exn -> - remove_file temp_filename; raise exn - end - | exception exn -> - close_out oc; remove_file temp_filename; raise exn - -(* Integer operations *) - -let rec log2 n = - if n <= 1 then 0 else 1 + log2(n asr 1) - -let align n a = - if n >= 0 then (n + a - 1) land (-a) else n land (-a) - -let no_overflow_add a b = (a lxor b) lor (a lxor (lnot (a+b))) < 0 - -let no_overflow_sub a b = (a lxor (lnot b)) lor (b lxor (a-b)) < 0 - -let no_overflow_mul a b = b <> 0 && (a * b) / b = a - -let no_overflow_lsl a k = - 0 <= k && k < Sys.word_size && min_int asr k <= a && a <= max_int asr k - -module Int_literal_converter = struct - (* To convert integer literals, allowing max_int + 1 (PR#4210) *) - let cvt_int_aux str neg of_string = - if String.length str = 0 || str.[0]= '-' - then of_string str - else neg (of_string ("-" ^ str)) - let int s = cvt_int_aux s (~-) int_of_string - let int32 s = cvt_int_aux s Int32.neg Int32.of_string - let int64 s = cvt_int_aux s Int64.neg Int64.of_string -end - -(* String operations *) - -let chop_extensions file = - let dirname = Filename.dirname file and basename = Filename.basename file in - try - let pos = String.index basename '.' in - let basename = String.sub basename 0 pos in - if Filename.is_implicit file && dirname = Filename.current_dir_name then - basename - else - Filename.concat dirname basename - with Not_found -> file - -let search_substring pat str start = - let rec search i j = - if j >= String.length pat then i - else if i + j >= String.length str then raise Not_found - else if str.[i + j] = pat.[j] then search i (j+1) - else search (i+1) 0 - in search start 0 - -let replace_substring ~before ~after str = - let rec search acc curr = - match search_substring before str curr with - | next -> - let prefix = String.sub str curr (next - curr) in - search (prefix :: acc) (next + String.length before) - | exception Not_found -> - let suffix = String.sub str curr (String.length str - curr) in - List.rev (suffix :: acc) - in String.concat after (search [] 0) - -let rev_split_words s = - let rec split1 res i = - if i >= String.length s then res else begin - match s.[i] with - ' ' | '\t' | '\r' | '\n' -> split1 res (i+1) - | _ -> split2 res i (i+1) - end - and split2 res i j = - if j >= String.length s then String.sub s i (j-i) :: res else begin - match s.[j] with - ' ' | '\t' | '\r' | '\n' -> split1 (String.sub s i (j-i) :: res) (j+1) - | _ -> split2 res i (j+1) - end - in split1 [] 0 - -let get_ref r = - let v = !r in - r := []; v - -let fst3 (x, _, _) = x -let snd3 (_,x,_) = x -let thd3 (_,_,x) = x - -let fst4 (x, _, _, _) = x -let snd4 (_,x,_, _) = x -let thd4 (_,_,x,_) = x -let for4 (_,_,_,x) = x - - -module LongString = struct - type t = bytes array - - let create str_size = - let tbl_size = str_size / Sys.max_string_length + 1 in - let tbl = Array.make tbl_size Bytes.empty in - for i = 0 to tbl_size - 2 do - tbl.(i) <- Bytes.create Sys.max_string_length; - done; - tbl.(tbl_size - 1) <- Bytes.create (str_size mod Sys.max_string_length); - tbl - - let length tbl = - let tbl_size = Array.length tbl in - Sys.max_string_length * (tbl_size - 1) + Bytes.length tbl.(tbl_size - 1) - - let get tbl ind = - Bytes.get tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) - - let set tbl ind c = - Bytes.set tbl.(ind / Sys.max_string_length) (ind mod Sys.max_string_length) - c - - let blit src srcoff dst dstoff len = - for i = 0 to len - 1 do - set dst (dstoff + i) (get src (srcoff + i)) - done - - let output oc tbl pos len = - for i = pos to pos + len - 1 do - output_char oc (get tbl i) - done - - let unsafe_blit_to_bytes src srcoff dst dstoff len = - for i = 0 to len - 1 do - Bytes.unsafe_set dst (dstoff + i) (get src (srcoff + i)) - done - - let input_bytes ic len = - let tbl = create len in - Array.iter (fun str -> really_input ic str 0 (Bytes.length str)) tbl; - tbl -end - - -let edit_distance a b cutoff = - let la, lb = String.length a, String.length b in - let cutoff = - (* using max_int for cutoff would cause overflows in (i + cutoff + 1); - we bring it back to the (max la lb) worstcase *) - min (max la lb) cutoff in - if abs (la - lb) > cutoff then None - else begin - (* initialize with 'cutoff + 1' so that not-yet-written-to cases have - the worst possible cost; this is useful when computing the cost of - a case just at the boundary of the cutoff diagonal. *) - let m = Array.make_matrix (la + 1) (lb + 1) (cutoff + 1) in - m.(0).(0) <- 0; - for i = 1 to la do - m.(i).(0) <- i; - done; - for j = 1 to lb do - m.(0).(j) <- j; - done; - for i = 1 to la do - for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do - let cost = if a.[i-1] = b.[j-1] then 0 else 1 in - let best = - (* insert, delete or substitute *) - min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost) - in - let best = - (* swap two adjacent letters; we use "cost" again in case of - a swap between two identical letters; this is slightly - redundant as this is a double-substitution case, but it - was done this way in most online implementations and - imitation has its virtues *) - if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1]) - then best - else min best (m.(i-2).(j-2) + cost) - in - m.(i).(j) <- best - done; - done; - let result = m.(la).(lb) in - if result > cutoff - then None - else Some result - end - -let spellcheck env name = - let cutoff = - match String.length name with - | 1 | 2 -> 0 - | 3 | 4 -> 1 - | 5 | 6 -> 2 - | _ -> 3 - in - let compare target acc head = - match edit_distance target head cutoff with - | None -> acc - | Some dist -> - let (best_choice, best_dist) = acc in - if dist < best_dist then ([head], dist) - else if dist = best_dist then (head :: best_choice, dist) - else acc - in - fst (List.fold_left (compare name) ([], max_int) env) - -let did_you_mean ppf get_choices = - (* flush now to get the error report early, in the (unheard of) case - where the search in the get_choices function would take a bit of - time; in the worst case, the user has seen the error, she can - interrupt the process before the spell-checking terminates. *) - Format.fprintf ppf "@?"; - match get_choices () with - | [] -> () - | choices -> - let rest, last = split_last choices in - Format.fprintf ppf "@\nHint: Did you mean %s%s%s?@?" - (String.concat ", " rest) - (if rest = [] then "" else " or ") - last - -let cut_at s c = - let pos = String.index s c in - String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1) - - -module StringSet = Set.Make(struct type t = string let compare = compare end) -module StringMap = Map.Make(struct type t = string let compare = compare end) - -(* Color handling *) -module Color = struct - (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) - type color = - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - ;; - - type style = - | FG of color (* foreground *) - | BG of color (* background *) - | Bold - | Reset - | Dim - - - let ansi_of_color = function - | Black -> "0" - | Red -> "1" - | Green -> "2" - | Yellow -> "3" - | Blue -> "4" - | Magenta -> "5" - | Cyan -> "6" - | White -> "7" - - let code_of_style = function - | FG c -> "3" ^ ansi_of_color c - | BG c -> "4" ^ ansi_of_color c - | Bold -> "1" - | Reset -> "0" - | Dim -> "2" - - - let ansi_of_style_l l = - let s = match l with - | [] -> code_of_style Reset - | [s] -> code_of_style s - | _ -> String.concat ";" (List.map code_of_style l) - in - "\x1b[" ^ s ^ "m" - - type styles = { - error: style list; - warning: style list; - loc: style list; - } - - let default_styles = { - warning = [Bold; FG Magenta]; - error = [Bold; FG Red]; - loc = [Bold]; - } - - let cur_styles = ref default_styles - let get_styles () = !cur_styles - let set_styles s = cur_styles := s - - (* map a tag to a style, if the tag is known. - @raise Not_found otherwise *) - let style_of_tag s = match s with - | Format.String_tag "error" -> (!cur_styles).error - | Format.String_tag "warning" -> (!cur_styles).warning - | Format.String_tag "loc" -> (!cur_styles).loc - | Format.String_tag "info" -> [Bold; FG Yellow] - | Format.String_tag "dim" -> [Dim] - | Format.String_tag "filename" -> [FG Cyan] - | _ -> raise Not_found - - let color_enabled = ref true - - (* either prints the tag of [s] or delegates to [or_else] *) - let mark_open_tag ~or_else s = - try - let style = style_of_tag s in - if !color_enabled then ansi_of_style_l style else "" - with Not_found -> or_else s - - let mark_close_tag ~or_else s = - try - let _ = style_of_tag s in - if !color_enabled then ansi_of_style_l [Reset] else "" - with Not_found -> or_else s - - (* add color handling to formatter [ppf] *) - let set_color_tag_handling ppf = - let open Format in - let functions = pp_get_formatter_stag_functions ppf () in - let functions' = {functions with - mark_open_stag=(mark_open_tag ~or_else:functions.mark_open_stag); - mark_close_stag=(mark_close_tag ~or_else:functions.mark_close_stag); - } in - pp_set_mark_tags ppf true; (* enable tags *) - pp_set_formatter_stag_functions ppf functions'; - (* also setup margins *) - pp_set_margin ppf (pp_get_margin std_formatter()); - () - - external isatty : out_channel -> bool = "caml_sys_isatty" - - (* reasonable heuristic on whether colors should be enabled *) - let should_enable_color () = - let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" - && term <> "" - && isatty stderr - - type setting = Auto | Always | Never - - let setup = - let first = ref true in (* initialize only once *) - let formatter_l = - [Format.std_formatter; Format.err_formatter; Format.str_formatter] - in - fun o -> - if !first then ( - first := false; - Format.set_mark_tags true; - List.iter set_color_tag_handling formatter_l; - color_enabled := (match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()) - ); - () -end - -let normalise_eol s = - let b = Buffer.create 80 in - for i = 0 to String.length s - 1 do - if s.[i] <> '\r' then Buffer.add_char b s.[i] - done; - Buffer.contents b - -let delete_eol_spaces src = - let len_src = String.length src in - let dst = Bytes.create len_src in - let rec loop i_src i_dst = - if i_src = len_src then - i_dst - else - match src.[i_src] with - | ' ' | '\t' -> - loop_spaces 1 (i_src + 1) i_dst - | c -> - Bytes.set dst i_dst c; - loop (i_src + 1) (i_dst + 1) - and loop_spaces spaces i_src i_dst = - if i_src = len_src then - i_dst - else - match src.[i_src] with - | ' ' | '\t' -> - loop_spaces (spaces + 1) (i_src + 1) i_dst - | '\n' -> - Bytes.set dst i_dst '\n'; - loop (i_src + 1) (i_dst + 1) - | _ -> - for n = 0 to spaces do - Bytes.set dst (i_dst + n) src.[i_src - spaces + n] - done; - loop (i_src + 1) (i_dst + spaces + 1) - in - let stop = loop 0 0 in - Bytes.sub_string dst 0 stop - -type hook_info = { - sourcefile : string; -} - -exception HookExnWrapper of - { - error: exn; - hook_name: string; - hook_info: hook_info; - } - -exception HookExn of exn - -let raise_direct_hook_exn e = raise (HookExn e) - -let fold_hooks list hook_info ast = - List.fold_left (fun ast (hook_name,f) -> - try - f hook_info ast - with - | HookExn e -> raise e - | error -> raise (HookExnWrapper {error; hook_name; hook_info}) - (* when explicit reraise with backtrace will be available, - it should be used here *) - - ) ast (List.sort compare list) - -module type HookSig = sig - type t - - val add_hook : string -> (hook_info -> t -> t) -> unit - val apply_hooks : hook_info -> t -> t -end - -module MakeHooks(M: sig - type t - end) : HookSig with type t = M.t -= struct - - type t = M.t - - let hooks = ref [] - let add_hook name f = hooks := (name, f) :: !hooks - let apply_hooks sourcefile intf = - fold_hooks !hooks sourcefile intf -end diff --git a/jscomp/ext/misc.mli b/jscomp/ext/misc.mli deleted file mode 100644 index 33878bb..0000000 --- a/jscomp/ext/misc.mli +++ /dev/null @@ -1,354 +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. *) -(* *) -(**************************************************************************) - -(* Miscellaneous useful types and functions *) - - -val fatal_error: string -> 'a -val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a -exception Fatal_error - -val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;; - -val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list - (* [map_end f l t] is [map f l @ t], just more efficient. *) -val map_left_right: ('a -> 'b) -> 'a list -> 'b list - (* Like [List.map], with guaranteed left-to-right evaluation order *) -val for_all2: ('a -> 'b -> bool) -> 'a list -> 'b list -> bool - (* Same as [List.for_all] but for a binary predicate. - In addition, this [for_all2] never fails: given two lists - with different lengths, it returns false. *) -val replicate_list: 'a -> int -> 'a list - (* [replicate_list elem n] is the list with [n] elements - all identical to [elem]. *) -val list_remove: 'a -> 'a list -> 'a list - (* [list_remove x l] returns a copy of [l] with the first - element equal to [x] removed. *) -val split_last: 'a list -> 'a list * 'a - (* Return the last element and the other elements of the given list. *) -val may: ('a -> unit) -> 'a option -> unit -val may_map: ('a -> 'b) -> 'a option -> 'b option - -type ref_and_value = R : 'a ref * 'a -> ref_and_value - -val protect_refs : ref_and_value list -> (unit -> 'a) -> 'a -(** [protect_refs l f] temporarily sets [r] to [v] for each [R (r, v)] in [l] - while executing [f]. The previous contents of the references is restored - even if [f] raises an exception. *) - -module Stdlib : sig - module List : sig - type 'a t = 'a list - - val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int - (** The lexicographic order supported by the provided order. - There is no constraint on the relative lengths of the lists. *) - - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - (** Returns [true] iff the given lists have the same length and content - with respect to the given equality function. *) - - val filter_map : ('a -> 'b option) -> 'a t -> 'b t - (** [filter_map f l] applies [f] to every element of [l], filters - out the [None] elements and returns the list of the arguments of - the [Some] elements. *) - - val some_if_all_elements_are_some : 'a option t -> 'a t option - (** If all elements of the given list are [Some _] then [Some xs] - is returned with the [xs] being the contents of those [Some]s, with - order preserved. Otherwise return [None]. *) - - val map2_prefix : ('a -> 'b -> 'c) -> 'a t -> 'b t -> ('c t * 'b t) - (** [let r1, r2 = map2_prefix f l1 l2] - If [l1] is of length n and [l2 = h2 @ t2] with h2 of length n, - r1 is [List.map2 f l1 h1] and r2 is t2. *) - - val split_at : int -> 'a t -> 'a t * 'a t - (** [split_at n l] returns the pair [before, after] where [before] is - the [n] first elements of [l] and [after] the remaining ones. - If [l] has less than [n] elements, raises Invalid_argument. *) - end - - module Option : sig - type 'a t = 'a option - - val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool - - val iter : ('a -> unit) -> 'a t -> unit - val map : ('a -> 'b) -> 'a t -> 'b t - val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b - val value_default : ('a -> 'b) -> default:'b -> 'a t -> 'b - end - - module Array : sig - val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool - (* Same as [Array.exists], but for a two-argument predicate. Raise - Invalid_argument if the two arrays are determined to have - different lengths. *) - end -end - -val find_in_path: string list -> string -> string - (* Search a file in a list of directories. *) -val find_in_path_rel: string list -> string -> string - (* Search a relative file in a list of directories. *) -val find_in_path_uncap: string list -> string -> string - (* Same, but search also for uncapitalized name, i.e. - if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml - to match. *) -val remove_file: string -> unit - (* Delete the given file if it exists. Never raise an error. *) -val expand_directory: string -> string -> string - (* [expand_directory alt file] eventually expands a [+] at the - beginning of file into [alt] (an alternate root directory) *) - -val create_hashtable: int -> ('a * 'b) list -> ('a, 'b) Hashtbl.t - (* Create a hashtable of the given size and fills it with the - given bindings. *) - -val copy_file: in_channel -> out_channel -> unit - (* [copy_file ic oc] reads the contents of file [ic] and copies - them to [oc]. It stops when encountering EOF on [ic]. *) -val copy_file_chunk: in_channel -> out_channel -> int -> unit - (* [copy_file_chunk ic oc n] reads [n] bytes from [ic] and copies - them to [oc]. It raises [End_of_file] when encountering - EOF on [ic]. *) -val string_of_file: in_channel -> string - (* [string_of_file ic] reads the contents of file [ic] and copies - them to a string. It stops when encountering EOF on [ic]. *) - -val output_to_bin_file_directly: string -> (string -> out_channel -> 'a) -> 'a - -val output_to_file_via_temporary: - ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a - (* Produce output in temporary file, then rename it - (as atomically as possible) to the desired output file name. - [output_to_file_via_temporary filename fn] opens a temporary file - which is passed to [fn] (name + output channel). When [fn] returns, - the channel is closed and the temporary file is renamed to - [filename]. *) - -val log2: int -> int - (* [log2 n] returns [s] such that [n = 1 lsl s] - if [n] is a power of 2*) -val align: int -> int -> int - (* [align n a] rounds [n] upwards to a multiple of [a] - (a power of 2). *) -val no_overflow_add: int -> int -> bool - (* [no_overflow_add n1 n2] returns [true] if the computation of - [n1 + n2] does not overflow. *) -val no_overflow_sub: int -> int -> bool - (* [no_overflow_sub n1 n2] returns [true] if the computation of - [n1 - n2] does not overflow. *) -val no_overflow_mul: int -> int -> bool - (* [no_overflow_mul n1 n2] returns [true] if the computation of - [n1 * n2] does not overflow. *) -val no_overflow_lsl: int -> int -> bool - (* [no_overflow_lsl n k] returns [true] if the computation of - [n lsl k] does not overflow. *) - -module Int_literal_converter : sig - val int : string -> int - val int32 : string -> int32 - val int64 : string -> int64 -end - -val chop_extensions: string -> string - (* Return the given file name without its extensions. The extensions - is the longest suffix starting with a period and not including - a directory separator, [.xyz.uvw] for instance. - - Return the given name if it does not contain an extension. *) - -val search_substring: string -> string -> int -> int - (* [search_substring pat str start] returns the position of the first - occurrence of string [pat] in string [str]. Search starts - at offset [start] in [str]. Raise [Not_found] if [pat] - does not occur. *) - -val replace_substring: before:string -> after:string -> string -> string - (* [replace_substring ~before ~after str] replaces all - occurrences of [before] with [after] in [str] and returns - the resulting string. *) - -val rev_split_words: string -> string list - (* [rev_split_words s] splits [s] in blank-separated words, and returns - the list of words in reverse order. *) - -val get_ref: 'a list ref -> 'a list - (* [get_ref lr] returns the content of the list reference [lr] and reset - its content to the empty list. *) - - -val fst3: 'a * 'b * 'c -> 'a -val snd3: 'a * 'b * 'c -> 'b -val thd3: 'a * 'b * 'c -> 'c - -val fst4: 'a * 'b * 'c * 'd -> 'a -val snd4: 'a * 'b * 'c * 'd -> 'b -val thd4: 'a * 'b * 'c * 'd -> 'c -val for4: 'a * 'b * 'c * 'd -> 'd - -module LongString : - sig - type t = bytes array - val create : int -> t - val length : t -> int - val get : t -> int -> char - val set : t -> int -> char -> unit - val blit : t -> int -> t -> int -> int -> unit - val output : out_channel -> t -> int -> int -> unit - val unsafe_blit_to_bytes : t -> int -> bytes -> int -> int -> unit - val input_bytes : in_channel -> int -> t - end - -val edit_distance : string -> string -> int -> int option -(** [edit_distance a b cutoff] computes the edit distance between - strings [a] and [b]. To help efficiency, it uses a cutoff: if the - distance [d] is smaller than [cutoff], it returns [Some d], else - [None]. - - The distance algorithm currently used is Damerau-Levenshtein: it - computes the number of insertion, deletion, substitution of - letters, or swapping of adjacent letters to go from one word to the - other. The particular algorithm may change in the future. -*) - -val spellcheck : string list -> string -> string list -(** [spellcheck env name] takes a list of names [env] that exist in - the current environment and an erroneous [name], and returns a - list of suggestions taken from [env], that are close enough to - [name] that it may be a typo for one of them. *) - -val did_you_mean : Format.formatter -> (unit -> string list) -> unit -(** [did_you_mean ppf get_choices] hints that the user may have meant - one of the option returned by calling [get_choices]. It does nothing - if the returned list is empty. - - The [unit -> ...] thunking is meant to delay any potentially-slow - computation (typically computing edit-distance with many things - from the current environment) to when the hint message is to be - printed. You should print an understandable error message before - calling [did_you_mean], so that users get a clear notification of - the failure even if producing the hint is slow. -*) - -val cut_at : string -> char -> string * string -(** [String.cut_at s c] returns a pair containing the sub-string before - the first occurrence of [c] in [s], and the sub-string after the - first occurrence of [c] in [s]. - [let (before, after) = String.cut_at s c in - before ^ String.make 1 c ^ after] is the identity if [s] contains [c]. - - Raise [Not_found] if the character does not appear in the string - @since 4.01 -*) - - -module StringSet: Set.S with type elt = string -module StringMap: Map.S with type key = string -(* TODO: replace all custom instantiations of StringSet/StringMap in various - compiler modules with this one. *) - -(* Color handling *) -module Color : sig - type color = - | Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - ;; - - type style = - | FG of color (* foreground *) - | BG of color (* background *) - | Bold - | Reset - | Dim - - - val ansi_of_style_l : style list -> string - (* ANSI escape sequence for the given style *) - - type styles = { - error: style list; - warning: style list; - loc: style list; - } - - val default_styles: styles - val get_styles: unit -> styles - val set_styles: styles -> unit - - type setting = Auto | Always | Never - - val setup : setting option -> unit - (* [setup opt] will enable or disable color handling on standard formatters - according to the value of color setting [opt]. - Only the first call to this function has an effect. *) - - val set_color_tag_handling : Format.formatter -> unit - (* adds functions to support color tags to the given formatter. *) -end - -val normalise_eol : string -> string -(** [normalise_eol s] returns a fresh copy of [s] with any '\r' characters - removed. Intended for pre-processing text which will subsequently be printed - on a channel which performs EOL transformations (i.e. Windows) *) - -val delete_eol_spaces : string -> string -(** [delete_eol_spaces s] returns a fresh copy of [s] with any end of - line spaces removed. Intended to normalize the output of the - toplevel for tests. *) - - - -(** {1 Hook machinery} - - Hooks machinery: - [add_hook name f] will register a function that will be called on the - argument of a later call to [apply_hooks]. Hooks are applied in the - lexicographical order of their names. -*) - -type hook_info = { - sourcefile : string; -} - -exception HookExnWrapper of - { - error: exn; - hook_name: string; - hook_info: hook_info; - } - (** An exception raised by a hook will be wrapped into a - [HookExnWrapper] constructor by the hook machinery. *) - - -val raise_direct_hook_exn: exn -> 'a - (** A hook can use [raise_unwrapped_hook_exn] to raise an exception that will - not be wrapped into a {!HookExnWrapper}. *) - -module type HookSig = sig - type t - val add_hook : string -> (hook_info -> t -> t) -> unit - val apply_hooks : hook_info -> t -> t -end - -module MakeHooks : functor (M : sig type t end) -> HookSig with type t = M.t diff --git a/jscomp/ext/set_gen.ml b/jscomp/ext/set_gen.ml deleted file mode 100644 index 34eb1e0..0000000 --- a/jscomp/ext/set_gen.ml +++ /dev/null @@ -1,357 +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 Library General Public License, with *) -(* the special exception on linking described in file ../LICENSE. *) -(* *) -(***********************************************************************) -[@@@warnerror "+55"] - -(* balanced tree based on stdlib distribution *) - -type 'a t0 = - | Empty - | Leaf of 'a - | Node of { l : 'a t0; v : 'a; r : 'a t0; h : int } - -type 'a partial_node = { l : 'a t0; v : 'a; r : 'a t0; h : int } - -external ( ~! ) : 'a t0 -> 'a partial_node = "%identity" - -let empty = Empty - -let[@inline] height = function Empty -> 0 | Leaf _ -> 1 | Node { h } -> h - -let[@inline] calc_height a b = (if a >= b then a else b) + 1 - -(* - Invariants: - 1. {[ l < v < r]} - 2. l and r balanced - 3. [height l] - [height r] <= 2 -*) -let[@inline] unsafe_node v l r h = Node { l; v; r; h } - -let[@inline] unsafe_node_maybe_leaf v l r h = - if h = 1 then Leaf v else Node { l; v; r; h } - -let[@inline] singleton x = Leaf x - -let[@inline] unsafe_two_elements x v = unsafe_node v (singleton x) empty 2 - -type 'a t = 'a t0 = private - | Empty - | Leaf of 'a - | Node of { l : 'a t0; v : 'a; r : 'a t0; h : int } - -(* Smallest and greatest element of a set *) - -let rec min_exn = function - | Empty -> raise Not_found - | Leaf v -> v - | Node { l; v } -> ( match l with Empty -> v | Leaf _ | Node _ -> min_exn l) - -let[@inline] is_empty = function Empty -> true | _ -> false - -let rec cardinal_aux acc = function - | Empty -> acc - | Leaf _ -> acc + 1 - | Node { l; r } -> cardinal_aux (cardinal_aux (acc + 1) r) l - -let cardinal s = cardinal_aux 0 s - -let rec elements_aux accu = function - | Empty -> accu - | Leaf v -> v :: accu - | Node { l; v; r } -> elements_aux (v :: elements_aux accu r) l - -let elements s = elements_aux [] s - -let choose = min_exn - -let rec iter x f = - match x with - | Empty -> () - | Leaf v -> f v - | Node { l; v; r } -> - iter l f; - f v; - iter r f - -let rec fold s accu f = - match s with - | Empty -> accu - | Leaf v -> f v accu - | Node { l; v; r } -> fold r (f v (fold l accu f)) f - -let rec for_all x p = - match x with - | Empty -> true - | Leaf v -> p v - | Node { l; v; r } -> p v && for_all l p && for_all r p - -let rec exists x p = - match x with - | Empty -> false - | Leaf v -> p v - | Node { l; v; r } -> p v || exists l p || exists r p - -exception Height_invariant_broken - -exception Height_diff_borken - -let rec check_height_and_diff = function - | Empty -> 0 - | Leaf _ -> 1 - | Node { l; r; h } -> - let hl = check_height_and_diff l in - let hr = check_height_and_diff r in - if h <> calc_height hl hr then raise Height_invariant_broken - else - let diff = abs (hl - hr) in - if diff > 2 then raise Height_diff_borken else h - -let check tree = ignore (check_height_and_diff tree) - -(* Same as create, but performs one step of rebalancing if necessary. - Invariants: - 1. {[ l < v < r ]} - 2. l and r balanced - 3. | height l - height r | <= 3. - - Proof by indunction - - Lemma: the height of [bal l v r] will bounded by [max l r] + 1 -*) -let bal l v r : _ t = - let hl = height l in - let hr = height r in - if hl > hr + 2 then - let { l = ll; r = lr; v = lv; h = _ } = ~!l in - let hll = height ll in - let hlr = height lr in - if hll >= hlr then - let hnode = calc_height hlr hr in - unsafe_node lv ll - (unsafe_node_maybe_leaf v lr r hnode) - (calc_height hll hnode) - else - let { l = lrl; r = lrr; v = lrv } = ~!lr in - let hlrl = height lrl in - let hlrr = height lrr in - let hlnode = calc_height hll hlrl in - let hrnode = calc_height hlrr hr in - unsafe_node lrv - (unsafe_node_maybe_leaf lv ll lrl hlnode) - (unsafe_node_maybe_leaf v lrr r hrnode) - (calc_height hlnode hrnode) - else if hr > hl + 2 then - let { l = rl; r = rr; v = rv } = ~!r in - let hrr = height rr in - let hrl = height rl in - if hrr >= hrl then - let hnode = calc_height hl hrl in - unsafe_node rv - (unsafe_node_maybe_leaf v l rl hnode) - rr (calc_height hnode hrr) - else - let { l = rll; r = rlr; v = rlv } = ~!rl in - let hrll = height rll in - let hrlr = height rlr in - let hlnode = calc_height hl hrll in - let hrnode = calc_height hrlr hrr in - unsafe_node rlv - (unsafe_node_maybe_leaf v l rll hlnode) - (unsafe_node_maybe_leaf rv rlr rr hrnode) - (calc_height hlnode hrnode) - else unsafe_node_maybe_leaf v l r (calc_height hl hr) - -let rec remove_min_elt = function - | Empty -> invalid_arg "Set.remove_min_elt" - | Leaf _ -> empty - | Node { l = Empty; r } -> r - | Node { l; v; r } -> bal (remove_min_elt l) v r - -(* - All elements of l must precede the elements of r. - Assume | height l - height r | <= 2. - weak form of [concat] -*) - -let internal_merge l r = - match (l, r) with - | Empty, t -> t - | t, Empty -> t - | _, _ -> bal l (min_exn r) (remove_min_elt r) - -(* Beware: those two functions assume that the added v is *strictly* - smaller (or bigger) than all the present elements in the tree; it - does not test for equality with the current min (or max) element. - Indeed, they are only used during the "join" operation which - respects this precondition. -*) - -let rec add_min v = function - | Empty -> singleton v - | Leaf x -> unsafe_two_elements v x - | Node n -> bal (add_min v n.l) n.v n.r - -let rec add_max v = function - | Empty -> singleton v - | Leaf x -> unsafe_two_elements x v - | Node n -> bal n.l n.v (add_max v n.r) - -(** - Invariants: - 1. l < v < r - 2. l and r are balanced - - Proof by induction - The height of output will be ~~ (max (height l) (height r) + 2) - Also use the lemma from [bal] -*) -let rec internal_join l v r = - match (l, r) with - | Empty, _ -> add_min v r - | _, Empty -> add_max v l - | Leaf lv, Node { h = rh } -> - if rh > 3 then add_min lv (add_min v r) (* FIXME: could inlined *) - else unsafe_node v l r (rh + 1) - | Leaf _, Leaf _ -> unsafe_node v l r 2 - | Node { h = lh }, Leaf rv -> - if lh > 3 then add_max rv (add_max v l) else unsafe_node v l r (lh + 1) - | ( Node { l = ll; v = lv; r = lr; h = lh }, - Node { l = rl; v = rv; r = rr; h = rh } ) -> - if lh > rh + 2 then - (* proof by induction: - now [height of ll] is [lh - 1] - *) - bal ll lv (internal_join lr v r) - else if rh > lh + 2 then bal (internal_join l v rl) rv rr - else unsafe_node v l r (calc_height lh rh) - -(* - Required Invariants: - [t1] < [t2] -*) -let internal_concat t1 t2 = - match (t1, t2) with - | Empty, t -> t - | t, Empty -> t - | _, _ -> internal_join t1 (min_exn t2) (remove_min_elt t2) - -let rec partition x p = - match x with - | Empty -> (empty, empty) - | Leaf v -> - let pv = p v in - if pv then (x, empty) else (empty, x) - | Node { l; v; r } -> - (* call [p] in the expected left-to-right order *) - let lt, lf = partition l p in - let pv = p v in - let rt, rf = partition r p in - if pv then (internal_join lt v rt, internal_concat lf rf) - else (internal_concat lt rt, internal_join lf v rf) - -let of_sorted_array l = - let rec sub start n l = - if n = 0 then empty - else if n = 1 then - let x0 = Array.unsafe_get l start in - singleton x0 - else if n = 2 then - let x0 = Array.unsafe_get l start in - let x1 = Array.unsafe_get l (start + 1) in - unsafe_node x1 (singleton x0) empty 2 - else if n = 3 then - let x0 = Array.unsafe_get l start in - let x1 = Array.unsafe_get l (start + 1) in - let x2 = Array.unsafe_get l (start + 2) in - unsafe_node x1 (singleton x0) (singleton x2) 2 - else - let nl = n / 2 in - let left = sub start nl l in - let mid = start + nl in - let v = Array.unsafe_get l mid in - let right = sub (mid + 1) (n - nl - 1) l in - unsafe_node v left right (calc_height (height left) (height right)) - in - sub 0 (Array.length l) l - -let is_ordered ~cmp tree = - let rec is_ordered_min_max tree = - match tree with - | Empty -> `Empty - | Leaf v -> `V (v, v) - | Node { l; v; r } -> ( - match is_ordered_min_max l with - | `No -> `No - | `Empty -> ( - match is_ordered_min_max r with - | `No -> `No - | `Empty -> `V (v, v) - | `V (l, r) -> if cmp v l < 0 then `V (v, r) else `No) - | `V (min_v, max_v) -> ( - match is_ordered_min_max r with - | `No -> `No - | `Empty -> if cmp max_v v < 0 then `V (min_v, v) else `No - | `V (min_v_r, max_v_r) -> - if cmp max_v min_v_r < 0 then `V (min_v, max_v_r) else `No)) - in - is_ordered_min_max tree <> `No - -let invariant ~cmp t = - check t; - is_ordered ~cmp t - -module type S = sig - type elt - - type t - - val empty : t - - val is_empty : t -> bool - - val iter : t -> (elt -> unit) -> unit - - val fold : t -> 'a -> (elt -> 'a -> 'a) -> 'a - - val for_all : t -> (elt -> bool) -> bool - - val exists : t -> (elt -> bool) -> bool - - val singleton : elt -> t - - val cardinal : t -> int - - val elements : t -> elt list - - val choose : t -> elt - - val mem : t -> elt -> bool - - val add : t -> elt -> t - - val remove : t -> elt -> t - - val union : t -> t -> t - - val inter : t -> t -> t - - val diff : t -> t -> t - - val of_list : elt list -> t - - val of_sorted_array : elt array -> t - - val invariant : t -> bool - - val print : Format.formatter -> t -> unit -end diff --git a/jscomp/ext/string_vec.ml b/jscomp/ext/string_vec.ml deleted file mode 100644 index 833ee8e..0000000 --- a/jscomp/ext/string_vec.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -include Vec.Make (struct - type t = string - - let null = "" -end) diff --git a/jscomp/ext/string_vec.mli b/jscomp/ext/string_vec.mli deleted file mode 100644 index c1b9411..0000000 --- a/jscomp/ext/string_vec.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -include Vec_gen.S with type elt = string diff --git a/jscomp/ext/union_find.ml b/jscomp/ext/union_find.ml deleted file mode 100644 index a06b49c..0000000 --- a/jscomp/ext/union_find.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = { id : int array; sz : int array; mutable components : int } - -let init n = - let id = Array.make n 0 in - for i = 0 to n - 1 do - Array.unsafe_set id i i - done; - { id; sz = Array.make n 1; components = n } - -let rec find_aux id_store p = - let parent = Array.unsafe_get id_store p in - if p <> parent then find_aux id_store parent else p - -let find store p = find_aux store.id p - -let union store p q = - let id_store = store.id in - let p_root = find_aux id_store p in - let q_root = find_aux id_store q in - if p_root <> q_root then - let () = store.components <- store.components - 1 in - let sz_store = store.sz in - let sz_p_root = Array.unsafe_get sz_store p_root in - let sz_q_root = Array.unsafe_get sz_store q_root in - let bigger = sz_p_root + sz_q_root in - (* Smaller root point to larger to make - it more balanced - it will introduce a cost for small root find, - but major will not be impacted - *) - if sz_p_root < sz_q_root then ( - Array.unsafe_set id_store p q_root; - Array.unsafe_set id_store p_root q_root; - Array.unsafe_set sz_store q_root bigger (* little optimization *)) - else ( - Array.unsafe_set id_store q p_root; - Array.unsafe_set id_store q_root p_root; - Array.unsafe_set sz_store p_root bigger (* little optimization *)) - -let count store = store.components diff --git a/jscomp/ext/union_find.mli b/jscomp/ext/union_find.mli deleted file mode 100644 index 5638b49..0000000 --- a/jscomp/ext/union_find.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t - -val init : int -> t - -val find : t -> int -> int - -val union : t -> int -> int -> unit - -val count : t -> int diff --git a/jscomp/ext/warnings.ml b/jscomp/ext/warnings.ml deleted file mode 100644 index b1a74bf..0000000 --- a/jscomp/ext/warnings.ml +++ /dev/null @@ -1,666 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Weis && Damien Doligez, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 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. *) -(* *) -(**************************************************************************) - -(* When you change this, you need to update the documentation: - - man/ocamlc.m - - man/ocamlopt.m - - manual/manual/cmds/comp.etex - - manual/manual/cmds/native.etex -*) - -type loc = { - loc_start : Lexing.position; - loc_end : Lexing.position; - loc_ghost : bool; -} - -type topLevelUnitHelp = FunctionCall | Other - -type t = - | Comment_start (* 1 *) - | Comment_not_end (* 2 *) - | Deprecated of string * loc * loc (* 3 *) - | Fragile_match of string (* 4 *) - | Partial_application (* 5 *) - | Method_override of string list (* 7 *) - | Partial_match of string (* 8 *) - | Non_closed_record_pattern of string (* 9 *) - | Statement_type (* 10 *) - | Unused_match (* 11 *) - | Unused_pat (* 12 *) - | Instance_variable_override of string list (* 13 *) - | Illegal_backslash (* 14 *) - | Implicit_public_methods of string list (* 15 *) - | Unerasable_optional_argument (* 16 *) - | Unused_argument (* 20 *) - | Nonreturning_statement (* 21 *) - | Preprocessor of string (* 22 *) - | Useless_record_with (* 23 *) - | Bad_module_name of string (* 24 *) - | All_clauses_guarded (* 8, used to be 25 *) - | Unused_var of string (* 26 *) - | Unused_var_strict of string (* 27 *) - | Wildcard_arg_to_constant_constr (* 28 *) - | Eol_in_string (* 29 *) - | Duplicate_definitions of string * string * string * string (*30 *) - | Unused_value_declaration of string (* 32 *) - | Unused_open of string (* 33 *) - | Unused_type_declaration of string (* 34 *) - | Unused_for_index of string (* 35 *) - | Unused_constructor of string * bool * bool (* 37 *) - | Unused_extension of string * bool * bool * bool (* 38 *) - | Unused_rec_flag (* 39 *) - | Ambiguous_name of string list * string list * bool (* 41 *) - | Nonoptional_label of string (* 43 *) - | Open_shadow_identifier of string * string (* 44 *) - | Open_shadow_label_constructor of string * string (* 45 *) - | Attribute_payload of string * string (* 47 *) - | Eliminated_optional_arguments of string list (* 48 *) - | No_cmi_file of string * string option (* 49 *) - | Bad_docstring of bool (* 50 *) - | Fragile_literal_pattern (* 52 *) - | Misplaced_attribute of string (* 53 *) - | Duplicated_attribute of string (* 54 *) - | Unreachable_case (* 56 *) - | Ambiguous_pattern of string list (* 57 *) - | Unused_module of string (* 60 *) - | Constraint_on_gadt (* 62 *) - | Bs_unused_attribute of string (* 101 *) - | Bs_polymorphic_comparison (* 102 *) - | Bs_ffi_warning of string (* 103 *) - | Bs_derive_warning of string (* 104 *) - | Bs_fragile_external of string (* 105 *) - | Bs_unimplemented_primitive of string (* 106 *) - | Bs_integer_literal_overflow (* 107 *) - | Bs_uninterpreted_delimiters of string (* 108 *) - | Bs_toplevel_expression_unit of (string * topLevelUnitHelp) option (* 109 *) - | Bs_todo of string option (* 110 *) - -(* If you remove a warning, leave a hole in the numbering. NEVER change - the numbers of existing warnings. - If you add a new warning, add it at the end with a new number; - do NOT reuse one of the holes. -*) - -let number = function - | Comment_start -> 1 - | Comment_not_end -> 2 - | Deprecated _ -> 3 - | Fragile_match _ -> 4 - | Partial_application -> 5 - | Method_override _ -> 7 - | Partial_match _ -> 8 - | Non_closed_record_pattern _ -> 9 - | Statement_type -> 10 - | Unused_match -> 11 - | Unused_pat -> 12 - | Instance_variable_override _ -> 13 - | Illegal_backslash -> 14 - | Implicit_public_methods _ -> 15 - | Unerasable_optional_argument -> 16 - | Unused_argument -> 20 - | Nonreturning_statement -> 21 - | Preprocessor _ -> 22 - | Useless_record_with -> 23 - | Bad_module_name _ -> 24 - | All_clauses_guarded -> 8 (* used to be 25 *) - | Unused_var _ -> 26 - | Unused_var_strict _ -> 27 - | Wildcard_arg_to_constant_constr -> 28 - | Eol_in_string -> 29 - | Duplicate_definitions _ -> 30 - | Unused_value_declaration _ -> 32 - | Unused_open _ -> 33 - | Unused_type_declaration _ -> 34 - | Unused_for_index _ -> 35 - | Unused_constructor _ -> 37 - | Unused_extension _ -> 38 - | Unused_rec_flag -> 39 - | Ambiguous_name _ -> 41 - | Nonoptional_label _ -> 43 - | Open_shadow_identifier _ -> 44 - | Open_shadow_label_constructor _ -> 45 - | Attribute_payload _ -> 47 - | Eliminated_optional_arguments _ -> 48 - | No_cmi_file _ -> 49 - | Bad_docstring _ -> 50 - | Fragile_literal_pattern -> 52 - | Misplaced_attribute _ -> 53 - | Duplicated_attribute _ -> 54 - | Unreachable_case -> 56 - | Ambiguous_pattern _ -> 57 - | Unused_module _ -> 60 - | Constraint_on_gadt -> 62 - | Bs_unused_attribute _ -> 101 - | Bs_polymorphic_comparison -> 102 - | Bs_ffi_warning _ -> 103 - | Bs_derive_warning _ -> 104 - | Bs_fragile_external _ -> 105 - | Bs_unimplemented_primitive _ -> 106 - | Bs_integer_literal_overflow -> 107 - | Bs_uninterpreted_delimiters _ -> 108 - | Bs_toplevel_expression_unit _ -> 109 - | Bs_todo _ -> 110 - -let last_warning_number = 110 - -let letter_all = - let rec loop i = if i = 0 then [] else i :: loop (i - 1) in - loop last_warning_number - -(* Must be the max number returned by the [number] function. *) - -let letter = function - | 'a' -> letter_all - | 'b' -> [] - | 'c' -> [ 1; 2 ] - | 'd' -> [ 3 ] - | 'e' -> [ 4 ] - | 'f' -> [ 5 ] - | 'g' -> [] - | 'h' -> [] - | 'i' -> [] - | 'j' -> [] - | 'k' -> [ 32; 33; 34; 35; 36; 37; 38; 39 ] - | 'l' -> [ 6 ] - | 'm' -> [ 7 ] - | 'n' -> [] - | 'o' -> [] - | 'p' -> [ 8 ] - | 'q' -> [] - | 'r' -> [ 9 ] - | 's' -> [ 10 ] - | 't' -> [] - | 'u' -> [ 11; 12 ] - | 'v' -> [ 13 ] - | 'w' -> [] - | 'x' -> [ 14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30 ] - | 'y' -> [ 26 ] - | 'z' -> [ 27 ] - | _ -> assert false - -type state = { active : bool array; error : bool array } - -let current = - ref - { - active = Array.make (last_warning_number + 1) true; - error = Array.make (last_warning_number + 1) false; - } - -let disabled = ref false - -let without_warnings f = Misc.protect_refs [ Misc.R (disabled, true) ] f - -let backup () = !current - -let restore x = current := x - -let is_active x = (not !disabled) && !current.active.(number x) - -let is_error x = (not !disabled) && !current.error.(number x) - -let mk_lazy f = - let state = backup () in - lazy - (let prev = backup () in - restore state; - try - let r = f () in - restore prev; - r - with exn -> - restore prev; - raise exn) - -let parse_opt error active flags s = - let set i = flags.(i) <- true in - let clear i = flags.(i) <- false in - let set_all i = - active.(i) <- true; - error.(i) <- true - in - let error () = raise (Arg.Bad "Ill-formed list of warnings") in - let rec get_num n i = - if i >= String.length s then (i, n) - else - match s.[i] with - | '0' .. '9' -> - get_num ((10 * n) + Char.code s.[i] - Char.code '0') (i + 1) - | _ -> (i, n) - in - let get_range i = - let i, n1 = get_num 0 i in - if i + 2 < String.length s && s.[i] = '.' && s.[i + 1] = '.' then ( - let i, n2 = get_num 0 (i + 2) in - if n2 < n1 then error (); - (i, n1, n2)) - else (i, n1, n1) - in - let rec loop i = - if i >= String.length s then () - else - match s.[i] with - | 'A' .. 'Z' -> - List.iter set (letter (Char.lowercase_ascii s.[i])); - loop (i + 1) - | 'a' .. 'z' -> - List.iter clear (letter s.[i]); - loop (i + 1) - | '+' -> loop_letter_num set (i + 1) - | '-' -> loop_letter_num clear (i + 1) - | '@' -> loop_letter_num set_all (i + 1) - | _ -> error () - and loop_letter_num myset i = - if i >= String.length s then error () - else - match s.[i] with - | '0' .. '9' -> - let i, n1, n2 = get_range i in - for n = n1 to Ext_pervasives.min_int n2 last_warning_number do - myset n - done; - loop i - | 'A' .. 'Z' -> - List.iter myset (letter (Char.lowercase_ascii s.[i])); - loop (i + 1) - | 'a' .. 'z' -> - List.iter myset (letter s.[i]); - loop (i + 1) - | _ -> error () - in - loop 0 - -let parse_options errflag s = - let error = Array.copy !current.error in - let active = Array.copy !current.active in - parse_opt error active (if errflag then error else active) s; - current := { error; active } - -let reset () = - parse_options false Bsc_warnings.defaults_w; - parse_options true Bsc_warnings.defaults_warn_error - -let () = reset () - -let message = function - | Comment_start -> "this is the start of a comment." - | Comment_not_end -> "this is not the end of a comment." - | Deprecated (s, _, _) -> - (* Reduce \r\n to \n: - - Prevents any \r characters being printed on Unix when processing - Windows sources - - Prevents \r\r\n being generated on Windows, which affects the - testsuite - *) - "deprecated: " ^ Misc.normalise_eol s - | Fragile_match "" -> "this pattern-matching is fragile." - | Fragile_match s -> - "this pattern-matching is fragile.\n\ - It will remain exhaustive when constructors are added to type " ^ s ^ "." - | Partial_application -> - "this function application is partial,\nmaybe some arguments are missing." - | Method_override [ lab ] -> "the method " ^ lab ^ " is overridden." - | Method_override (cname :: slist) -> - String.concat " " - ("the following methods are overridden by the class" :: cname :: ":\n " - :: slist) - | Method_override [] -> assert false - | Partial_match "" -> - "You forgot to handle a possible case here, though we don't have more \ - information on the value." - | Partial_match s -> - "You forgot to handle a possible case here, for example: \n " ^ s - | Non_closed_record_pattern s -> - "the following labels are not bound in this record pattern: " ^ s - ^ "\nEither bind these labels explicitly or add ', _' to the pattern." - | Statement_type -> - "This expression returns a value, but you're not doing anything with it. \ - If this is on purpose, wrap it with `ignore`." - | Unused_match -> "this match case is unused." - | Unused_pat -> "this sub-pattern is unused." - | Instance_variable_override [ lab ] -> - "the instance variable " ^ lab ^ " is overridden.\n" - ^ "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" - | Instance_variable_override (cname :: slist) -> - String.concat " " - ("the following instance variables are overridden by the class" :: cname - :: ":\n " :: slist) - ^ "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" - | Instance_variable_override [] -> assert false - | Illegal_backslash -> "illegal backslash escape in string." - | Implicit_public_methods l -> - "the following private methods were made public implicitly:\n " - ^ String.concat " " l ^ "." - | Unerasable_optional_argument -> - String.concat "" - [ - "This optional parameter in final position will, in practice, not be \ - optional.\n"; - " Reorder the parameters so that at least one non-optional one is \ - in final position or, if all parameters are optional, insert a \ - final ().\n\n"; - " Explanation: If the final parameter is optional, it'd be unclear \ - whether a function application that omits it should be considered \ - fully applied, or partially applied. Imagine writing `let title = \ - display(\"hello!\")`, only to realize `title` isn't your desired \ - result, but a curried call that takes a final optional argument, \ - e.g. `~showDate`.\n\n"; - " Formal rule: an optional argument is considered intentionally \ - omitted when the 1st positional (i.e. neither labeled nor optional) \ - argument defined after it is passed in."; - ] - | Unused_argument -> "this argument will not be used by the function." - | Nonreturning_statement -> - "this statement never returns (or has an unsound type.)" - | Preprocessor s -> s - | Useless_record_with -> ( - match !Config.syntax_kind with - | `ml -> - "all the fields are explicitly listed in this record:\n\ - the 'with' clause is useless." - | `rescript -> - "All the fields are already explicitly listed in this record. You \ - can remove the `...` spread.") - | Bad_module_name modname -> - "This file's name is potentially invalid. The build systems \ - conventionally turn a file name into a module name by upper-casing the \ - first letter. " ^ modname ^ " isn't a valid module name.\n" - ^ "Note: some build systems might e.g. turn kebab-case into CamelCase \ - module, which is why this isn't a hard error." - | All_clauses_guarded -> - "this pattern-matching is not exhaustive.\n\ - All clauses in this pattern-matching are guarded." - | Unused_var v | Unused_var_strict v -> "unused variable " ^ v ^ "." - | Wildcard_arg_to_constant_constr -> - "wildcard pattern given as argument to a constant constructor" - | Eol_in_string -> - "unescaped end-of-line in a string constant (non-portable code)" - | Duplicate_definitions (kind, cname, tc1, tc2) -> - Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname - tc1 tc2 - | Unused_value_declaration v -> "unused value " ^ v ^ "." - | Unused_open s -> "unused open " ^ s ^ "." - | Unused_type_declaration s -> "unused type " ^ s ^ "." - | Unused_for_index s -> "unused for-loop index " ^ s ^ "." - | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "." - | Unused_constructor (s, true, _) -> - "constructor " ^ s - ^ " is never used to build values.\n\ - (However, this constructor appears in patterns.)" - | Unused_constructor (s, false, true) -> - "constructor " ^ s - ^ " is never used to build values.\n\ - Its type is exported as a private type." - | Unused_extension (s, is_exception, cu_pattern, cu_privatize) -> ( - let kind = - if is_exception then "exception" else "extension constructor" - in - let name = kind ^ " " ^ s in - match (cu_pattern, cu_privatize) with - | false, false -> "unused " ^ name - | true, _ -> - name - ^ " is never used to build values.\n\ - (However, this constructor appears in patterns.)" - | false, true -> - name - ^ " is never used to build values.\n\ - It is exported or rebound as a private extension.") - | Unused_rec_flag -> "unused rec flag." - | Ambiguous_name ([ s ], tl, false) -> - s ^ " belongs to several types: " ^ String.concat " " tl - ^ "\nThe first one was selected. Please disambiguate if this is wrong." - | Ambiguous_name (_, _, false) -> assert false - | Ambiguous_name (_slist, tl, true) -> - "these field labels belong to several types: " ^ String.concat " " tl - ^ "\nThe first one was selected. Please disambiguate if this is wrong." - | Nonoptional_label s -> "the label " ^ s ^ " is not optional." - | Open_shadow_identifier (kind, s) -> - Printf.sprintf - "this open statement shadows the %s identifier %s (which is later used)" - kind s - | Open_shadow_label_constructor (kind, s) -> - Printf.sprintf - "this open statement shadows the %s %s (which is later used)" kind s - | Attribute_payload (a, s) -> - Printf.sprintf "illegal payload for attribute '%s'.\n%s" a s - | Eliminated_optional_arguments sl -> - Printf.sprintf "implicit elimination of optional argument%s %s" - (if List.length sl = 1 then "" else "s") - (String.concat ", " sl) - | No_cmi_file (name, None) -> - "no cmi file was found in path for module " ^ name - | No_cmi_file (name, Some msg) -> - Printf.sprintf "no valid cmi file was found in path for module %s. %s" - name msg - | Bad_docstring unattached -> - if unattached then "unattached documentation comment (ignored)" - else "ambiguous documentation comment" - | Fragile_literal_pattern -> - Printf.sprintf - "Code should not depend on the actual values of\n\ - this constructor's arguments. They are only for information\n\ - and may change in future versions. (See manual section 8.5)" - | Unreachable_case -> - "this match case is unreachable.\n\ - Consider replacing it with a refutation case ' -> .'" - | Misplaced_attribute attr_name -> - Printf.sprintf "the %S attribute cannot appear in this context" attr_name - | Duplicated_attribute attr_name -> - Printf.sprintf - "the %S attribute is used more than once on this expression" attr_name - | Ambiguous_pattern vars -> - let msg = - let vars = List.sort String.compare vars in - match vars with - | [] -> assert false - | [ x ] -> "variable " ^ x - | _ :: _ -> "variables " ^ String.concat "," vars - in - Printf.sprintf - "Ambiguous or-pattern variables under guard;\n\ - %s may match different arguments. (See manual section 8.5)" msg - | Unused_module s -> "unused module " ^ s ^ "." - | Constraint_on_gadt -> - "Type constraints do not apply to GADT cases of variant types." - | Bs_unused_attribute s -> - "Unused attribute: " ^ s - ^ "\n\ - This means such annotation is not annotated properly. \n\ - for example, some annotations is only meaningful in externals \n" - | Bs_polymorphic_comparison -> - "Polymorphic comparison introduced (maybe unsafe)" - | Bs_ffi_warning s -> "FFI warning: " ^ s - | Bs_derive_warning s -> "@deriving warning: " ^ s - | Bs_fragile_external s -> - s - ^ " : using an empty string as a shorthand to infer the external's name \ - from the value's name is dangerous when refactoring, and therefore \ - deprecated" - | Bs_unimplemented_primitive s -> "Unimplemented primitive used:" ^ s - | Bs_integer_literal_overflow -> - "Integer literal exceeds the range of representable integers of type int" - | Bs_uninterpreted_delimiters s -> "Uninterpreted delimiters " ^ s - | Bs_toplevel_expression_unit help -> - Printf.sprintf "This%sis at the top level and is expected to return `unit`. But it's returning %s.\n\n In ReScript, anything at the top level must evaluate to `unit`. You can fix this by assigning the expression to a value, or piping it into the `ignore` function.%s" - (match help with - | Some (_, FunctionCall) -> " function call " - | _ -> " ") - - (match help with - | Some (returnType, _) -> Printf.sprintf "`%s`" returnType - | None -> "something that is not `unit`") - - (match help with - | Some (_, helpTyp) -> - let helpText = (match helpTyp with - | FunctionCall -> "yourFunctionCall()" - | Other -> "yourExpression") in - Printf.sprintf "\n\n Possible solutions:\n - Assigning to a value that is then ignored: `let _ = %s`\n - Piping into the built-in ignore function to ignore the result: `%s->ignore`" helpText helpText - | _ -> "") - | Bs_todo maybe_text -> ( - match maybe_text with - | None -> "Todo found." - | Some todo -> "Todo found: " ^ todo - ) ^ "\n\n This code is not implemented yet and will crash at runtime. Make sure you implement this before running the code." - -let sub_locs = function - | Deprecated (_, def, use) -> - [ (def, "Definition"); (use, "Expected signature") ] - | _ -> [] - -let has_warnings = ref false - -let nerrors = ref 0 - -type reporting_information = { - number : int; - message : string; - is_error : bool; - sub_locs : (loc * string) list; -} - -let report w = - match is_active w with - | false -> `Inactive - | true -> - has_warnings := true; - if is_error w then incr nerrors; - `Active - { - number = number w; - message = message w; - is_error = is_error w; - sub_locs = sub_locs w; - } - -exception Errors - -let reset_fatal () = nerrors := 0 - -let check_fatal () = - if !nerrors > 0 then ( - nerrors := 0; - raise Errors) - -let descriptions = - [ - (1, "Suspicious-looking start-of-comment mark."); - (2, "Suspicious-looking end-of-comment mark."); - (3, "Deprecated feature."); - ( 4, - "Fragile pattern matching: matching that will remain complete even\n\ - \ if additional constructors are added to one of the variant types\n\ - \ matched." ); - ( 5, - "Partially applied function: expression whose result has function\n\ - \ type and is ignored." ); - (6, "Label omitted in function application."); - (7, "Method overridden."); - (8, "Partial match: missing cases in pattern-matching."); - (9, "Missing fields in a record pattern."); - ( 10, - "Expression on the left-hand side of a sequence that doesn't have type\n\ - \ \"unit\" (and that is not a function, see warning number 5)." ); - (11, "Redundant case in a pattern matching (unused match case)."); - (12, "Redundant sub-pattern in a pattern-matching."); - (13, "Instance variable overridden."); - (14, "Illegal backslash escape in a string constant."); - (15, "Private method made public implicitly."); - (16, "Unerasable optional argument."); - (17, "Undeclared virtual method."); - (18, "Non-principal type."); - (19, "Type without principality."); - (20, "Unused function argument."); - (21, "Non-returning statement."); - (22, "Preprocessor warning."); - (23, "Useless record \"with\" clause."); - ( 24, - "Bad module name: the source file name is not a valid OCaml module name." - ); - (25, "Deprecated: now part of warning 8."); - ( 26, - "Suspicious unused variable: unused variable that is bound\n\ - \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." ); - ( 27, - "Innocuous unused variable: unused variable that is not bound with\n\ - \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character." ); - (28, "Wildcard pattern given as argument to a constant constructor."); - (29, "Unescaped end-of-line in a string constant (non-portable code)."); - ( 30, - "Two labels or constructors of the same name are defined in two\n\ - \ mutually recursive types." ); - (31, "A module is linked twice in the same executable."); - (32, "Unused value declaration."); - (33, "Unused open statement."); - (34, "Unused type declaration."); - (35, "Unused for-loop index."); - (36, "Unused ancestor variable."); - (37, "Unused constructor."); - (38, "Unused extension constructor."); - (39, "Unused rec flag."); - (41, "Ambiguous constructor or label name."); - (43, "Nonoptional label applied as optional."); - (44, "Open statement shadows an already defined identifier."); - (45, "Open statement shadows an already defined label or constructor."); - (46, "Error in environment variable."); - (47, "Illegal attribute payload."); - (48, "Implicit elimination of optional arguments."); - (49, "Absent cmi file when looking up module alias."); - (50, "Unexpected documentation comment."); - (51, "Warning on non-tail calls if @tailcall present."); - (52, "Fragile constant pattern."); - (53, "Attribute cannot appear in this context"); - (54, "Attribute used more than once on an expression"); - (55, "Inlining impossible"); - (56, "Unreachable case in a pattern-matching (based on type information)."); - (57, "Ambiguous or-pattern variables under guard"); - (59, "Assignment to non-mutable value"); - (60, "Unused module declaration"); - (61, "Unboxable type in primitive declaration"); - (62, "Type constraint on GADT type declaration"); - (101, "Unused bs attributes"); - (102, "Polymorphic comparison introduced (maybe unsafe)"); - (103, "Fragile FFI definitions"); - (104, "bs.deriving warning with customized message "); - ( 105, - "External name is inferred from val name is unsafe from refactoring when \ - changing value name" ); - (106, "Unimplemented primitive used:"); - ( 107, - "Integer literal exceeds the range of representable integers of type int" - ); - (108, "Uninterpreted delimiters (for unicode)"); - (109, "Toplevel expression has unit type"); - (110, "Todo found"); - ] - -let help_warnings () = - List.iter (fun (i, s) -> Printf.printf "%3i %s\n" i s) descriptions; - print_endline " A all warnings"; - for i = Char.code 'b' to Char.code 'z' do - let c = Char.chr i in - match letter c with - | [] -> () - | [ n ] -> - Printf.printf " %c Alias for warning %i.\n" (Char.uppercase_ascii c) n - | l -> - Printf.printf " %c warnings %s.\n" (Char.uppercase_ascii c) - (String.concat ", " (List.map string_of_int l)) - done; - exit 0 diff --git a/jscomp/frontend/ast_attributes.ml b/jscomp/frontend/ast_attributes.ml deleted file mode 100644 index 8e10958..0000000 --- a/jscomp/frontend/ast_attributes.ml +++ /dev/null @@ -1,384 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type attr = Parsetree.attribute -type t = attr list -type ('a, 'b) st = {get: 'a option; set: 'b option} - -let process_method_attributes_rev (attrs : t) = - Ext_list.fold_left attrs - ({get = None; set = None}, []) - (fun (st, acc) (({txt; loc}, payload) as attr) -> - match txt with - | "bs.get" | "get" (* @bs.get{null; undefined}*) -> - let result = - Ext_list.fold_left (Ast_payload.ident_or_record_as_config loc payload) - (false, false) (fun (null, undefined) ({txt; loc}, opt_expr) -> - match txt with - | "null" -> - ( (match opt_expr with - | None -> true - | Some e -> Ast_payload.assert_bool_lit e), - undefined ) - | "undefined" -> - ( null, - match opt_expr with - | None -> true - | Some e -> Ast_payload.assert_bool_lit e ) - | "nullable" -> ( - match opt_expr with - | None -> (true, true) - | Some e -> - let v = Ast_payload.assert_bool_lit e in - (v, v)) - | _ -> Bs_syntaxerr.err loc Unsupported_predicates) - in - - ({st with get = Some result}, acc) - | "bs.set" | "set" -> - let result = - Ext_list.fold_left (Ast_payload.ident_or_record_as_config loc payload) - `Get (fun _st ({txt; loc}, opt_expr) -> - (*FIXME*) - if txt = "no_get" then - match opt_expr with - | None -> `No_get - | Some e -> - if Ast_payload.assert_bool_lit e then `No_get else `Get - else Bs_syntaxerr.err loc Unsupported_predicates) - in - (* properties -- void - [@@set{only}] - *) - ({st with set = Some result}, acc) - | _ -> (st, attr :: acc)) - -type attr_kind = - | Nothing - | Meth_callback of attr - | Uncurry of attr - | Method of attr - -let process_attributes_rev (attrs : t) : attr_kind * t = - Ext_list.fold_left attrs (Nothing, []) - (fun (st, acc) (({txt; loc}, _) as attr) -> - match (txt, st) with - | "bs", (Nothing | Uncurry _) -> - (Uncurry attr, acc) (* TODO: warn unused/duplicated attribute *) - | ("bs.this" | "this"), (Nothing | Meth_callback _) -> - (Meth_callback attr, acc) - | ("bs.meth" | "meth"), (Nothing | Method _) -> (Method attr, acc) - | ("bs" | "bs.this" | "this"), _ -> - Bs_syntaxerr.err loc Conflict_bs_bs_this_bs_meth - | _, _ -> (st, attr :: acc)) - -let process_pexp_fun_attributes_rev (attrs : t) = - Ext_list.fold_left attrs (false, []) - (fun (st, acc) (({txt; loc = _}, _) as attr) -> - match txt with - | "bs.open" -> (true, acc) - | _ -> (st, attr :: acc)) - -let process_bs (attrs : t) = - Ext_list.fold_left attrs (false, []) - (fun (st, acc) (({txt; loc = _}, _) as attr) -> - match (txt, st) with - | "bs", _ -> (true, acc) - | _, _ -> (st, attr :: acc)) - -let external_attrs = - [| - "get"; - "set"; - "get_index"; - "return"; - "obj"; - "val"; - "module"; - "scope"; - "variadic"; - "send"; - "new"; - "set_index"; - Literals.gentype_import1; - Literals.gentype_import2; - |] - -let first_char_special (x : string) = - match String.unsafe_get x 0 with - | '#' | '?' | '%' -> true - | _ -> false - -let prims_to_be_encoded (attrs : string list) = - match attrs with - | [] -> assert false (* normal val declaration *) - | x :: _ when first_char_special x -> false - | _ :: x :: _ when Ext_string.first_marshal_char x -> false - | _ -> true - -(** - - [@@inline] - let a = 3 - - [@@inline] - let a : 3 - - They are not considered externals, they are part of the language -*) - -let rs_externals (attrs : t) pval_prim = - match (attrs, pval_prim) with - | _, [] -> false - (* This is val *) - | [], _ -> - (* Not any attribute found *) - prims_to_be_encoded pval_prim - | _, _ -> - Ext_list.exists_fst attrs (fun ({txt} : string Asttypes.loc) -> - Ext_string.starts_with txt "bs." - || Ext_array.exists external_attrs (fun (x : string) -> txt = x)) - || prims_to_be_encoded pval_prim - -let is_inline : attr -> bool = - fun ({txt}, _) -> txt = "bs.inline" || txt = "inline" - -let has_inline_payload (attrs : t) = Ext_list.find_first attrs is_inline - -let has_await_payload (attrs : t) = Ext_list.find_first attrs Ast_await.is_await -let has_async_payload (attrs : t) = Ext_list.find_first attrs Ast_async.is_async - -type derive_attr = {bs_deriving: Ast_payload.action list option} [@@unboxed] - -let process_derive_type (attrs : t) : derive_attr * t = - Ext_list.fold_left attrs - ({bs_deriving = None}, []) - (fun (st, acc) (({txt; loc}, payload) as attr) -> - match txt with - | "bs.deriving" | "deriving" -> ( - match st.bs_deriving with - | None -> - ( { - bs_deriving = - Some (Ast_payload.ident_or_record_as_config loc payload); - }, - acc ) - | Some _ -> Bs_syntaxerr.err loc Duplicated_bs_deriving) - | _ -> (st, attr :: acc)) - -let process_send_pipe (attrs : t) : (Parsetree.core_type * t) option = - match attrs with - | [] -> None - | _ -> ( - if not (Ext_list.exists_fst attrs (fun {txt} -> txt = "bs.send.pipe")) then - (* fast path *) - None - else - let ty = ref None in - let attrs = - Ext_list.fold_left attrs [] (fun acc (({txt; loc}, payload) as attr) -> - match txt with - | "bs.send.pipe" -> ( - match !ty with - | None -> - Location.prerr_warning loc - (Warnings.Bs_ffi_warning - "This attribute is deprecated, use @send instead."); - - ty := Some (Ast_payload.as_core_type loc payload); - ({Asttypes.txt = "bs.send"; loc}, Parsetree.PStr []) :: acc - | Some _ -> Location.raise_errorf ~loc "Duplicated bs.send.pipe") - | _ -> attr :: acc) - in - match !ty with - | None -> assert false - | Some ty -> Some (ty, attrs)) - -(* duplicated @uncurry @string not allowed, - it is worse in @uncurry since it will introduce - inconsistency in arity -*) -let iter_process_bs_string_int_unwrap_uncurry (attrs : t) = - let st = ref `Nothing in - let assign v (({loc; _}, _) as attr : attr) = - if !st = `Nothing then ( - Bs_ast_invariant.mark_used_bs_attribute attr; - st := v) - else Bs_syntaxerr.err loc Conflict_attributes - in - Ext_list.iter attrs (fun (({txt; loc = _}, (payload : _)) as attr) -> - match txt with - | "bs.string" | "string" -> assign `String attr - | "bs.int" | "int" -> assign `Int attr - | "bs.ignore" | "ignore" -> assign `Ignore attr - | "bs.unwrap" | "unwrap" -> assign `Unwrap attr - | "bs.uncurry" | "uncurry" -> - if !Config.uncurried = Uncurried then - Bs_ast_invariant.mark_used_bs_attribute attr - else assign (`Uncurry (Ast_payload.is_single_int payload)) attr - | _ -> ()); - !st - -let iter_process_bs_string_as (attrs : t) : string option = - let st = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> - match txt with - | "bs.as" | "as" -> - if !st = None then ( - match Ast_payload.is_single_string payload with - | None -> Bs_syntaxerr.err loc Expect_string_literal - | Some (v, _dec) -> - Bs_ast_invariant.mark_used_bs_attribute attr; - st := Some v) - else raise (Ast_untagged_variants.Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st -let has_bs_optional (attrs : t) : bool = - Ext_list.exists attrs (fun (({txt}, _) as attr) -> - match txt with - | "bs.optional" | "optional" -> - Bs_ast_invariant.mark_used_bs_attribute attr; - true - | _ -> false) - -let iter_process_bs_int_as (attrs : t) = - let st = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> - match txt with - | "bs.as" | "as" -> - if !st = None then ( - match Ast_payload.is_single_int payload with - | None -> Bs_syntaxerr.err loc Expect_int_literal - | Some _ as v -> - Bs_ast_invariant.mark_used_bs_attribute attr; - st := v) - else raise (Ast_untagged_variants.Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st - -type as_const_payload = Int of int | Str of string * External_arg_spec.delim - -let iter_process_bs_string_or_int_as (attrs : Parsetree.attributes) = - let st = ref None in - Ext_list.iter attrs (fun (({txt; loc}, payload) as attr) -> - match txt with - | "bs.as" | "as" -> - if !st = None then ( - Bs_ast_invariant.mark_used_bs_attribute attr; - match Ast_payload.is_single_int payload with - | None -> ( - match payload with - | PStr - [ - { - pstr_desc = - Pstr_eval - ( { - pexp_desc = Pexp_constant (Pconst_string (s, delim_)); - pexp_loc; - _; - }, - _ ); - _; - }; - ] - when Ast_utf8_string_interp.parse_processed_delim delim_ <> None - -> ( - let delim = - match Ast_utf8_string_interp.parse_processed_delim delim_ with - | None -> assert false - | Some delim -> delim - in - st := Some (Str (s, delim)); - if delim = DNoQuotes then - (* check that it is a valid object literal *) - match - Classify_function.classify - ~check:(pexp_loc, Bs_flow_ast_utils.flow_deli_offset delim_) - s - with - | Js_literal _ -> () - | _ -> - Location.raise_errorf ~loc:pexp_loc - "an object literal expected") - | _ -> Bs_syntaxerr.err loc Expect_int_or_string_or_json_literal) - | Some v -> st := Some (Int v)) - else raise (Ast_untagged_variants.Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st - -let locg = Location.none -(* let bs : attr - = {txt = "bs" ; loc = locg}, Ast_payload.empty *) - -let is_bs (attr : attr) = - match attr with - | {Location.txt = "bs"; _}, _ -> true - | _ -> false - -let res_uapp : attr = ({txt = "res.uapp"; loc = locg}, Ast_payload.empty) - -let bs_get : attr = ({txt = "bs.get"; loc = locg}, Ast_payload.empty) - -let bs_get_index : attr = ({txt = "bs.get_index"; loc = locg}, Ast_payload.empty) - -let bs_get_arity : attr = - ( {txt = "internal.arity"; loc = locg}, - PStr - [ - { - pstr_desc = Pstr_eval (Ast_compatible.const_exp_int ~loc:locg 1, []); - pstr_loc = locg; - }; - ] ) - -let bs_set : attr = ({txt = "bs.set"; loc = locg}, Ast_payload.empty) - -let internal_expansive : attr = - ({txt = "internal.expansive"; loc = locg}, Ast_payload.empty) - -let bs_return_undefined : attr = - ( {txt = "bs.return"; loc = locg}, - PStr - [ - { - pstr_desc = - Pstr_eval - ( { - pexp_desc = - Pexp_ident {txt = Lident "undefined_to_opt"; loc = locg}; - pexp_loc = locg; - pexp_attributes = []; - }, - [] ); - pstr_loc = locg; - }; - ] ) - -let is_gentype (attr : attr) = - match attr with - | {Location.txt = "genType" | "gentype"; _}, _ -> true - | _ -> false - -let gentype : attr = ({txt = "genType"; loc = locg}, Ast_payload.empty) diff --git a/jscomp/frontend/ast_attributes.mli b/jscomp/frontend/ast_attributes.mli deleted file mode 100644 index ec31ccb..0000000 --- a/jscomp/frontend/ast_attributes.mli +++ /dev/null @@ -1,96 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type attr = Parsetree.attribute - -type t = attr list - -type ('a, 'b) st = {get: 'a option; set: 'b option} - -val process_method_attributes_rev : t -> (bool * bool, [`Get | `No_get]) st * t - -type attr_kind = - | Nothing - | Meth_callback of attr - | Uncurry of attr - | Method of attr - -val process_attributes_rev : t -> attr_kind * t - -val process_pexp_fun_attributes_rev : t -> bool * t - -val process_bs : t -> bool * t - -val has_inline_payload : t -> attr option - -val has_await_payload : t -> attr option -val has_async_payload : t -> attr option - -type derive_attr = {bs_deriving: Ast_payload.action list option} [@@unboxed] - -val iter_process_bs_string_int_unwrap_uncurry : - t -> [`Nothing | `String | `Int | `Ignore | `Unwrap | `Uncurry of int option] - -val iter_process_bs_string_as : t -> string option - -val has_bs_optional : t -> bool - -val iter_process_bs_int_as : t -> int option - -type as_const_payload = Int of int | Str of string * External_arg_spec.delim -val iter_process_bs_string_or_int_as : t -> as_const_payload option - -val process_derive_type : t -> derive_attr * t - -(* val iter_process_derive_type : - t -> derive_attr - - - val bs : attr *) -val is_bs : attr -> bool -(* val is_optional : attr -> bool - val is_bs_as : attr -> bool *) - -(* Attribute for uncurried application coming from the ReScript parser *) -val res_uapp : attr - -val bs_get : attr - -val bs_get_index : attr - -val bs_get_arity : attr - -val bs_set : attr - -val bs_return_undefined : attr - -val internal_expansive : attr -(* val deprecated : string -> attr *) - -val rs_externals : t -> string list -> bool - -val process_send_pipe : t -> (Parsetree.core_type * t) option - -val is_gentype : attr -> bool - -val gentype : attr diff --git a/jscomp/frontend/ast_bs_open.ml b/jscomp/frontend/ast_bs_open.ml deleted file mode 100644 index b398970..0000000 --- a/jscomp/frontend/ast_bs_open.ml +++ /dev/null @@ -1,75 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let isCamlExceptionOrOpenVariant : Longident.t = - Ldot (Ldot (Lident "Js", "Exn"), "isCamlExceptionOrOpenVariant") - -let obj_magic : Longident.t = Lident "__unsafe_cast" - -let rec checkCases (cases : Parsetree.case list) = List.iter check_case cases - -and check_case case = check_pat case.pc_lhs - -and check_pat (pat : Parsetree.pattern) = - match pat.ppat_desc with - | Ppat_construct _ -> () - | Ppat_or (l, r) -> - check_pat l; - check_pat r - | _ -> - Location.raise_errorf ~loc:pat.ppat_loc "Unsupported pattern in `bs.open`" - -let convertBsErrorFunction loc (self : Bs_ast_mapper.mapper) attrs - (cases : Parsetree.case list) = - let open Ast_helper in - let txt = "match" in - let txt_expr = Exp.ident ~loc {txt = Lident txt; loc} in - let none = Exp.construct ~loc {txt = Ast_literal.predef_none; loc} None in - let () = checkCases cases in - let cases = self.cases self cases in - Ast_compatible.fun_ ~attrs ~loc - (Pat.var ~loc {txt; loc}) - (Exp.ifthenelse ~loc - (Ast_compatible.app1 ~loc - (Exp.ident ~loc {txt = isCamlExceptionOrOpenVariant; loc}) - txt_expr) - (Exp.match_ ~loc - (Exp.constraint_ ~loc - (Ast_compatible.app1 ~loc - (Exp.ident ~loc {txt = obj_magic; loc}) - txt_expr) - (Ast_literal.type_exn ~loc ())) - (Ext_list.map_append cases - [Exp.case (Pat.any ~loc ()) none] - (fun x -> - let pc_rhs = x.pc_rhs in - let loc = pc_rhs.pexp_loc in - { - x with - pc_rhs = - Exp.construct ~loc - {txt = Ast_literal.predef_some; loc} - (Some pc_rhs); - }))) - (Some none)) diff --git a/jscomp/frontend/ast_bs_open.mli b/jscomp/frontend/ast_bs_open.mli deleted file mode 100644 index ce1cf04..0000000 --- a/jscomp/frontend/ast_bs_open.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2019- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val convertBsErrorFunction : - Location.t -> - Bs_ast_mapper.mapper -> - Ast_helper.attrs -> - Parsetree.case list -> - Parsetree.expression diff --git a/jscomp/frontend/ast_comb.ml b/jscomp/frontend/ast_comb.ml deleted file mode 100644 index 0462a79..0000000 --- a/jscomp/frontend/ast_comb.ml +++ /dev/null @@ -1,68 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper - -(* let fun_no_label ?loc ?attrs pat body = - Ast_compatible.fun_ ?loc ?attrs pat body *) - -(* let discard_exp_as_unit loc e = - Ast_compatible.apply_simple ~loc - (Exp.ident ~loc {txt = Ast_literal.Lid.ignore_id; loc}) - [Exp.constraint_ ~loc e - (Ast_literal.type_unit ~loc ())] *) - -let tuple_type_pair ?loc kind arity = - let prefix = "a" in - if arity = 0 then - let ty = Typ.var ?loc (prefix ^ "0") in - match kind with - | `Run -> (ty, [], ty) - | `Make -> - (Ast_compatible.arrow ?loc (Ast_literal.type_unit ?loc ()) ty, [], ty) - else - let number = arity + 1 in - let tys = - Ext_list.init number (fun i -> - Typ.var ?loc (prefix ^ string_of_int (number - i - 1))) - in - match tys with - | result :: rest -> - ( Ext_list.reduce_from_left tys (fun r arg -> - Ast_compatible.arrow ?loc arg r), - List.rev rest, - result ) - | [] -> assert false - -let re_id = Ast_literal.Lid.js_re_id - -let to_js_re_type loc = Typ.constr ~loc {txt = re_id; loc} [] - -let to_undefined_type loc x = - Typ.constr ~loc {txt = Ast_literal.Lid.js_undefined; loc} [x] - -let single_non_rec_value ?(attrs = []) name exp = - Str.value Nonrecursive [Vb.mk ~attrs (Pat.var name) exp] - -let single_non_rec_val ?(attrs = []) name ty = Sig.value (Val.mk ~attrs name ty) diff --git a/jscomp/frontend/ast_comb.mli b/jscomp/frontend/ast_comb.mli deleted file mode 100644 index 21dbfa9..0000000 --- a/jscomp/frontend/ast_comb.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* note we first declare its type is [unit], - then [ignore] it, [ignore] is necessary since - the js value maybe not be of type [unit] and - we can use [unit] value (though very little chance) - sometimes -*) -(* val discard_exp_as_unit : - Location.t -> Parsetree.expression -> Parsetree.expression *) - -val tuple_type_pair : - ?loc:Ast_helper.loc -> - [< `Make | `Run] -> - int -> - Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type - -val to_undefined_type : Location.t -> Parsetree.core_type -> Parsetree.core_type - -val to_js_re_type : Location.t -> Parsetree.core_type - -val single_non_rec_value : - ?attrs:Parsetree.attributes -> - Ast_helper.str -> - Parsetree.expression -> - Parsetree.structure_item - -val single_non_rec_val : - ?attrs:Parsetree.attributes -> - Ast_helper.str -> - Parsetree.core_type -> - Parsetree.signature_item diff --git a/jscomp/frontend/ast_compatible.ml b/jscomp/frontend/ast_compatible.ml deleted file mode 100644 index 338a66a..0000000 --- a/jscomp/frontend/ast_compatible.ml +++ /dev/null @@ -1,137 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type loc = Location.t - -type attrs = Parsetree.attribute list - -open Parsetree - -let default_loc = Location.none - -let arrow ?loc ?attrs a b = Ast_helper.Typ.arrow ?loc ?attrs Nolabel a b - -let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) - (args : expression list) : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = - Pexp_apply (fn, Ext_list.map args (fun x -> (Asttypes.Nolabel, x))); - } - -let app1 ?(loc = default_loc) ?(attrs = []) fn arg1 : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_apply (fn, [(Nolabel, arg1)]); - } - -let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_apply (fn, [(Nolabel, arg1); (Nolabel, arg2)]); - } - -let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = - Pexp_apply (fn, [(Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3)]); - } - -let fun_ ?(loc = default_loc) ?(attrs = []) pat exp = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_fun (Nolabel, None, pat, exp); - } - -let const_exp_string ?(loc = default_loc) ?(attrs = []) ?delimiter (s : string) - : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_constant (Pconst_string (s, delimiter)); - } - -let const_exp_int ?(loc = default_loc) ?(attrs = []) (s : int) : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = Pexp_constant (Pconst_integer (string_of_int s, None)); - } - -let apply_labels ?(loc = default_loc) ?(attrs = []) fn - (args : (string * expression) list) : expression = - { - pexp_loc = loc; - pexp_attributes = attrs; - pexp_desc = - Pexp_apply (fn, Ext_list.map args (fun (l, a) -> (Asttypes.Labelled l, a))); - } - -let label_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = - { - ptyp_desc = Ptyp_arrow (Asttypes.Labelled s, a, b); - ptyp_loc = loc; - ptyp_attributes = attrs; - } - -let opt_arrow ?(loc = default_loc) ?(attrs = []) s a b : core_type = - { - ptyp_desc = Ptyp_arrow (Asttypes.Optional s, a, b); - ptyp_loc = loc; - ptyp_attributes = attrs; - } - -let rec_type_str ?(loc = default_loc) rf tds : structure_item = - {pstr_loc = loc; pstr_desc = Pstr_type (rf, tds)} - -let rec_type_sig ?(loc = default_loc) rf tds : signature_item = - {psig_loc = loc; psig_desc = Psig_type (rf, tds)} - -(* FIXME: need address migration of `[@nonrec]` attributes in older ocaml *) -(* let nonrec_type_sig ?(loc=default_loc) tds : signature_item = - { - psig_loc = loc; - psig_desc = Psig_type ( - Nonrecursive, - tds) - } *) - -let const_exp_int_list_as_array xs = - Ast_helper.Exp.array (Ext_list.map xs (fun x -> const_exp_int x)) - -(* let const_exp_string_list_as_array xs = - Ast_helper.Exp.array - (Ext_list.map xs (fun x -> const_exp_string x ) ) *) - -type object_field = Parsetree.object_field - -let object_field l attrs ty = Parsetree.Otag (l, attrs, ty) - -type args = (Asttypes.arg_label * Parsetree.expression) list diff --git a/jscomp/frontend/ast_compatible.mli b/jscomp/frontend/ast_compatible.mli deleted file mode 100644 index 8bda0e0..0000000 --- a/jscomp/frontend/ast_compatible.mli +++ /dev/null @@ -1,127 +0,0 @@ -(* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type loc = Location.t - -type attrs = Parsetree.attribute list - -open Parsetree - -val const_exp_string : - ?loc:Location.t -> ?attrs:attrs -> ?delimiter:string -> string -> expression - -val const_exp_int : ?loc:Location.t -> ?attrs:attrs -> int -> expression - -val const_exp_int_list_as_array : int list -> expression - -val apply_simple : - ?loc:Location.t -> ?attrs:attrs -> expression -> expression list -> expression - -val app1 : - ?loc:Location.t -> ?attrs:attrs -> expression -> expression -> expression - -val app2 : - ?loc:Location.t -> - ?attrs:attrs -> - expression -> - expression -> - expression -> - expression - -val app3 : - ?loc:Location.t -> - ?attrs:attrs -> - expression -> - expression -> - expression -> - expression -> - expression - -val apply_labels : - ?loc:Location.t -> - ?attrs:attrs -> - expression -> - (string * expression) list -> - (* [(label,e)] [label] is strictly interpreted as label *) - expression -(** Note this function would slightly - change its semantics depending on compiler versions - for newer version: it means always label - for older version: it could be optional (which we should avoid) -*) - -val fun_ : - ?loc:Location.t -> ?attrs:attrs -> pattern -> expression -> expression - -(* val opt_label : string -> Asttypes.arg_label *) - -(* val label_fun : - ?loc:Location.t -> - ?attrs:attrs -> - label:Asttypes.arg_label -> - pattern -> - expression -> - expression *) - -val arrow : - ?loc:Location.t -> ?attrs:attrs -> core_type -> core_type -> core_type - -val label_arrow : - ?loc:Location.t -> - ?attrs:attrs -> - string -> - core_type -> - core_type -> - core_type - -val opt_arrow : - ?loc:Location.t -> - ?attrs:attrs -> - string -> - core_type -> - core_type -> - core_type - -(* val nonrec_type_str: - ?loc:loc -> - type_declaration list -> - structure_item *) - -val rec_type_str : - ?loc:loc -> Asttypes.rec_flag -> type_declaration list -> structure_item - -(* val nonrec_type_sig: - ?loc:loc -> - type_declaration list -> - signature_item *) - -val rec_type_sig : - ?loc:loc -> Asttypes.rec_flag -> type_declaration list -> signature_item - -type object_field = Parsetree.object_field - -val object_field : - Asttypes.label Asttypes.loc -> attributes -> core_type -> object_field - -type args = (Asttypes.arg_label * Parsetree.expression) list diff --git a/jscomp/frontend/ast_config.ml b/jscomp/frontend/ast_config.ml deleted file mode 100644 index 9f7eb7e..0000000 --- a/jscomp/frontend/ast_config.ml +++ /dev/null @@ -1,91 +0,0 @@ -(* Copyright (C) 2020 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type action_table = (Parsetree.expression option -> unit) Map_string.t - -let structural_config_table : action_table ref = - ref - (Map_string.singleton "no_export" (fun x -> - Js_config.no_export := - match x with - | Some e -> Ast_payload.assert_bool_lit e - | None -> true)) - -let add_structure k v = - structural_config_table := Map_string.add !structural_config_table k v - -let signature_config_table : action_table ref = ref Map_string.empty - -let add_signature k v = - signature_config_table := Map_string.add !signature_config_table k v - -let process_directives str = - Js_config.directives := []; - (* Reset: multiple calls possible e.g. with bsc from the command-line *) - str - |> List.iter (fun (item : Parsetree.structure_item) -> - match item.pstr_desc with - | Pstr_attribute ({txt = "directive"}, payload) -> ( - match Ast_payload.is_single_string payload with - | Some (d, _) -> Js_config.directives := !Js_config.directives @ [d] - | None -> Bs_syntaxerr.err item.pstr_loc Expect_string_literal) - | Pstr_attribute ({txt = "uncurried"}, _) -> - Config.uncurried := Uncurried - | _ -> ()) - -let rec iter_on_bs_config_str (x : Parsetree.structure) = - match x with - | [] -> () - | { - pstr_desc = - Pstr_attribute (({txt = "bs.config" | "config"; loc}, payload) as attr); - } - :: _ -> - Bs_ast_invariant.mark_used_bs_attribute attr; - Ext_list.iter - (Ast_payload.ident_or_record_as_config loc payload) - (Ast_payload.table_dispatch !structural_config_table) - | {pstr_desc = Pstr_attribute _} :: rest -> iter_on_bs_config_str rest - | _ :: _ -> () - -let process_str str = - iter_on_bs_config_str str; - process_directives str - -let rec iter_on_bs_config_sig (x : Parsetree.signature) = - match x with - | [] -> () - | { - psig_desc = - Psig_attribute (({txt = "bs.config" | "config"; loc}, payload) as attr); - } - :: _ -> - Bs_ast_invariant.mark_used_bs_attribute attr; - Ext_list.iter - (Ast_payload.ident_or_record_as_config loc payload) - (Ast_payload.table_dispatch !signature_config_table) - | {psig_desc = Psig_attribute _} :: rest -> iter_on_bs_config_sig rest - | _ :: _ -> () - -let process_sig s = iter_on_bs_config_sig s diff --git a/jscomp/frontend/ast_config.mli b/jscomp/frontend/ast_config.mli deleted file mode 100644 index ab0e533..0000000 --- a/jscomp/frontend/ast_config.mli +++ /dev/null @@ -1,31 +0,0 @@ -(* Copyright (C) 2020 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val add_structure : string -> (Parsetree.expression option -> unit) -> unit - -val add_signature : string -> (Parsetree.expression option -> unit) -> unit - -val process_str : Parsetree.structure -> unit - -val process_sig : Parsetree.signature -> unit diff --git a/jscomp/frontend/ast_core_type.ml b/jscomp/frontend/ast_core_type.ml deleted file mode 100644 index e7b57b9..0000000 --- a/jscomp/frontend/ast_core_type.ml +++ /dev/null @@ -1,176 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Parsetree.core_type - -let lift_option_type ({ptyp_loc} as ty : t) : t = - { - ptyp_desc = - Ptyp_constr ({txt = Ast_literal.predef_option; loc = ptyp_loc}, [ty]); - ptyp_loc; - ptyp_attributes = []; - } - -open Ast_helper - -(* let replace_result (ty : t) (result : t) : t = - let rec aux (ty : Parsetree.core_type) = - match ty with - | { ptyp_desc = - Ptyp_arrow (label,t1,t2) - } -> { ty with ptyp_desc = Ptyp_arrow(label,t1, aux t2)} - | {ptyp_desc = Ptyp_poly(fs,ty)} - -> {ty with ptyp_desc = Ptyp_poly(fs, aux ty)} - | _ -> result in - aux ty *) - -let is_builtin_rank0_type txt = - match txt with - | "int" | "char" | "bytes" | "float" | "bool" | "unit" | "exn" | "int64" - | "string" -> - true - | _ -> false - -let is_unit (ty : t) = - match ty.ptyp_desc with - | Ptyp_constr ({txt = Lident "unit"}, []) -> true - | _ -> false - -(* let is_array (ty : t) = - match ty.ptyp_desc with - | Ptyp_constr({txt =Lident "array"}, [_]) -> true - | _ -> false *) - -let is_user_option (ty : t) = - match ty.ptyp_desc with - | Ptyp_constr - ({txt = Lident "option" | Ldot (Lident "*predef*", "option")}, [_]) -> - true - | _ -> false - -(* let is_user_bool (ty : t) = - match ty.ptyp_desc with - | Ptyp_constr({txt = Lident "bool"},[]) -> true - | _ -> false *) - -(* let is_user_int (ty : t) = - match ty.ptyp_desc with - | Ptyp_constr({txt = Lident "int"},[]) -> true - | _ -> false *) - -(* Note that OCaml type checker will not allow arbitrary - name as type variables, for example: - {[ - '_x'_ - ]} - will be recognized as a invalid program -*) -let from_labels ~loc arity labels : t = - let tyvars = - Ext_list.init arity (fun i -> Typ.var ~loc ("a" ^ string_of_int i)) - in - let result_type = - Typ.object_ ~loc - (Ext_list.map2 labels tyvars (fun x y -> Parsetree.Otag (x, [], y))) - Closed - in - Ext_list.fold_right2 labels tyvars result_type - (fun label (* {loc ; txt = label }*) tyvar acc -> - Ast_compatible.label_arrow ~loc:label.loc label.txt tyvar acc) - -let make_obj ~loc xs = Typ.object_ ~loc xs Closed - -(** - - {[ 'a . 'a -> 'b ]} - OCaml does not support such syntax yet - {[ 'a -> ('a. 'a -> 'b) ]} - -*) -let rec get_uncurry_arity_aux (ty : t) acc = - match ty.ptyp_desc with - | Ptyp_arrow (_, _, new_ty) -> get_uncurry_arity_aux new_ty (succ acc) - | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc - | _ -> acc - -(** - {[ unit -> 'b ]} return arity 1 - {[ unit -> 'a1 -> a2']} arity 2 - {[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N -*) -let get_uncurry_arity (ty : t) = - match ty.ptyp_desc with - | Ptyp_arrow (_, _, rest) -> Some (get_uncurry_arity_aux rest 1) - | _ -> None - -let get_curry_arity (ty : t) = - if Ast_uncurried.coreTypeIsUncurriedFun ty then - let arity, _ = Ast_uncurried.coreTypeExtractUncurriedFun ty in - arity - else get_uncurry_arity_aux ty 0 - -(* add hoc for bs.send.pipe *) -let rec get_curry_labels (ty : t) acc = - match ty.ptyp_desc with - | Ptyp_arrow (label, _, rest) -> get_curry_labels rest (label :: acc) - | _ -> acc - -let get_curry_labels ty = List.rev (get_curry_labels ty []) -let is_arity_one ty = get_curry_arity ty = 1 - -type param_type = { - label: Asttypes.arg_label; - ty: Parsetree.core_type; - attr: Parsetree.attributes; - loc: loc; -} - -let mk_fn_type (new_arg_types_ty : param_type list) (result : t) : t = - Ext_list.fold_right new_arg_types_ty result (fun {label; ty; attr; loc} acc -> - { - ptyp_desc = Ptyp_arrow (label, ty, acc); - ptyp_loc = loc; - ptyp_attributes = attr; - }) - -let list_of_arrow (ty : t) : t * param_type list = - let rec aux (ty : t) acc = - match ty.ptyp_desc with - | Ptyp_arrow (label, t1, t2) -> - aux t2 - (({label; ty = t1; attr = ty.ptyp_attributes; loc = ty.ptyp_loc} - : param_type) - :: acc) - | Ptyp_poly (_, ty) -> - (* should not happen? *) - Bs_syntaxerr.err ty.ptyp_loc Unhandled_poly_type - | _ -> (ty, List.rev acc) - in - aux ty [] - -let add_last_obj (ty : t) (obj : t) = - let result, params = list_of_arrow ty in - mk_fn_type - (params @ [{label = Nolabel; ty = obj; attr = []; loc = obj.ptyp_loc}]) - result diff --git a/jscomp/frontend/ast_core_type.mli b/jscomp/frontend/ast_core_type.mli deleted file mode 100644 index 5cdbecb..0000000 --- a/jscomp/frontend/ast_core_type.mli +++ /dev/null @@ -1,66 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Parsetree.core_type - -val lift_option_type : t -> t - -val is_unit : t -> bool - -val is_builtin_rank0_type : string -> bool - -val from_labels : loc:Location.t -> int -> string Asttypes.loc list -> t -(** return a function type - [from_labels ~loc tyvars labels] - example output: - {[x:'a0 -> y:'a1 -> < x :'a0 ;y :'a1 > Js.t]} -*) - -val make_obj : loc:Location.t -> Parsetree.object_field list -> t - -val is_user_option : t -> bool - -val get_uncurry_arity : t -> int option -(** - returns 0 when it can not tell arity from the syntax - None -- means not a function -*) - -val get_curry_labels : t -> Asttypes.arg_label list - -type param_type = { - label: Asttypes.arg_label; - ty: t; - attr: Parsetree.attributes; - loc: Location.t; -} - -val mk_fn_type : param_type list -> t -> t - -val list_of_arrow : t -> t * param_type list -(** fails when Ptyp_poly *) - -val add_last_obj : t -> t -> t - -val is_arity_one : t -> bool diff --git a/jscomp/frontend/ast_core_type_class_type.ml b/jscomp/frontend/ast_core_type_class_type.ml deleted file mode 100644 index 40e8784..0000000 --- a/jscomp/frontend/ast_core_type_class_type.ml +++ /dev/null @@ -1,137 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ast_helper - -let process_getter_setter ~not_getter_setter - ~(get : Parsetree.core_type -> _ -> Parsetree.attributes -> _) ~set loc name - (attrs : Ast_attributes.t) (ty : Parsetree.core_type) (acc : _ list) = - match Ast_attributes.process_method_attributes_rev attrs with - | {get = None; set = None}, _ -> not_getter_setter ty :: acc - | st, pctf_attributes -> - let get_acc = - match st.set with - | Some `No_get -> acc - | None | Some `Get -> - let lift txt = Typ.constr ~loc {txt; loc} [ty] in - let null, undefined = - match st with - | {get = Some (null, undefined)} -> (null, undefined) - | {get = None} -> (false, false) - in - let ty = - match (null, undefined) with - | false, false -> ty - | true, false -> lift Ast_literal.Lid.js_null - | false, true -> lift Ast_literal.Lid.js_undefined - | true, true -> lift Ast_literal.Lid.js_null_undefined - in - get ty name pctf_attributes :: acc - in - if st.set = None then get_acc - else - set ty - ({name with txt = name.Asttypes.txt ^ Literals.setter_suffix} - : _ Asttypes.loc) - pctf_attributes - :: get_acc - -let default_typ_mapper = Bs_ast_mapper.default_mapper.typ -(* - Attributes are very hard to attribute - (since ptyp_attributes could happen in so many places), - and write ppx extensions correctly, - we can only use it locally -*) - -let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = - match ty with - | { - ptyp_attributes; - ptyp_desc = - ( Ptyp_arrow (label, args, body) - | Ptyp_constr - (* function$<...> is re-wrapped around only in case Nothing below *) - ( {txt = Lident "function$"}, - [{ptyp_desc = Ptyp_arrow (label, args, body)}; _] ) ); - (* let it go without regard label names, - it will report error later when the label is not empty - *) - ptyp_loc = loc; - } -> ( - match fst (Ast_attributes.process_attributes_rev ptyp_attributes) with - | Uncurry _ -> Ast_typ_uncurry.to_uncurry_type loc self label args body - | Meth_callback _ -> - Ast_typ_uncurry.to_method_callback_type loc self label args body - | Method _ -> - (* Treat @meth as making the type uncurried, for backwards compatibility *) - Ast_typ_uncurry.to_uncurry_type loc self label args body - | Nothing -> Bs_ast_mapper.default_mapper.typ self ty) - | {ptyp_desc = Ptyp_object (methods, closed_flag); ptyp_loc = loc} -> - let ( +> ) attr (typ : Parsetree.core_type) = - {typ with ptyp_attributes = attr :: typ.ptyp_attributes} - in - let new_methods = - Ext_list.fold_right methods [] (fun meth_ acc -> - match meth_ with - | Parsetree.Oinherit _ -> meth_ :: acc - | Parsetree.Otag (label, ptyp_attrs, core_type) -> - let get ty name attrs = - let attrs, core_type = - match Ast_attributes.process_attributes_rev attrs with - | Nothing, attrs -> (attrs, ty) (* #1678 *) - | Uncurry attr, attrs -> (attrs, attr +> ty) - | Method _, _ -> - Location.raise_errorf ~loc "%@get/set conflicts with %@meth" - | Meth_callback attr, attrs -> (attrs, attr +> ty) - in - Ast_compatible.object_field name attrs (self.typ self core_type) - in - let set ty name attrs = - let attrs, core_type = - match Ast_attributes.process_attributes_rev attrs with - | Nothing, attrs -> (attrs, ty) - | Uncurry attr, attrs -> (attrs, attr +> ty) - | Method _, _ -> - Location.raise_errorf ~loc "%@get/set conflicts with %@meth" - | Meth_callback attr, attrs -> (attrs, attr +> ty) - in - Ast_compatible.object_field name attrs - (Ast_typ_uncurry.to_uncurry_type loc self Nolabel core_type - (Ast_literal.type_unit ~loc ())) - in - let not_getter_setter ty = - let attrs, core_type = - match Ast_attributes.process_attributes_rev ptyp_attrs with - | Nothing, attrs -> (attrs, ty) - | Uncurry attr, attrs -> (attrs, attr +> ty) - | Method attr, attrs -> (attrs, attr +> ty) - | Meth_callback attr, attrs -> (attrs, attr +> ty) - in - Ast_compatible.object_field label attrs (self.typ self core_type) - in - process_getter_setter ~not_getter_setter ~get ~set loc label - ptyp_attrs core_type acc) - in - {ty with ptyp_desc = Ptyp_object (new_methods, closed_flag)} - | _ -> default_typ_mapper self ty diff --git a/jscomp/frontend/ast_core_type_class_type.mli b/jscomp/frontend/ast_core_type_class_type.mli deleted file mode 100644 index 088d300..0000000 --- a/jscomp/frontend/ast_core_type_class_type.mli +++ /dev/null @@ -1,26 +0,0 @@ -(* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val typ_mapper : - Bs_ast_mapper.mapper -> Parsetree.core_type -> Parsetree.core_type diff --git a/jscomp/frontend/ast_derive.ml b/jscomp/frontend/ast_derive.ml deleted file mode 100644 index e6b3c14..0000000 --- a/jscomp/frontend/ast_derive.ml +++ /dev/null @@ -1,71 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type tdcls = Parsetree.type_declaration list - -type gen = { - structure_gen: tdcls -> Asttypes.rec_flag -> Ast_structure.t; - signature_gen: tdcls -> Asttypes.rec_flag -> Ast_signature.t; - expression_gen: (Parsetree.core_type -> Parsetree.expression) option; -} - -(* the first argument is [config] payload - {[ - { x = {uu} } - ]} -*) -type derive_table = (Parsetree.expression option -> gen) Map_string.t - -let derive_table : derive_table ref = ref Map_string.empty - -let register key value = derive_table := Map_string.add !derive_table key value - -(* let gen_structure - (tdcls : tdcls) - (actions : Ast_payload.action list ) - (explict_nonrec : bool ) - : Ast_structure.t = - Ext_list.flat_map - (fun action -> - (Ast_payload.table_dispatch !derive_table action).structure_gen - tdcls explict_nonrec) actions *) - -let gen_signature tdcls (actions : Ast_payload.action list) - (explict_nonrec : Asttypes.rec_flag) : Ast_signature.t = - Ext_list.flat_map actions (fun action -> - (Ast_payload.table_dispatch !derive_table action).signature_gen tdcls - explict_nonrec) - -open Ast_helper - -let gen_structure_signature loc (tdcls : tdcls) (action : Ast_payload.action) - (explicit_nonrec : Asttypes.rec_flag) = - let derive_table = !derive_table in - let u = Ast_payload.table_dispatch derive_table action in - - let a = u.structure_gen tdcls explicit_nonrec in - let b = u.signature_gen tdcls explicit_nonrec in - Str.include_ ~loc - (Incl.mk ~loc - (Mod.constraint_ ~loc (Mod.structure ~loc a) (Mty.signature ~loc b))) diff --git a/jscomp/frontend/ast_derive.mli b/jscomp/frontend/ast_derive.mli deleted file mode 100644 index 4355525..0000000 --- a/jscomp/frontend/ast_derive.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type tdcls = Parsetree.type_declaration list - -type gen = { - structure_gen: tdcls -> Asttypes.rec_flag -> Ast_structure.t; - signature_gen: tdcls -> Asttypes.rec_flag -> Ast_signature.t; - expression_gen: (Parsetree.core_type -> Parsetree.expression) option; -} - -val register : string -> (Parsetree.expression option -> gen) -> unit -(** - [register name cb] - example: [register "accessors" cb] -*) - -(* val gen_structure: - tdcls -> - Ast_payload.action list -> - bool -> - Ast_structure.t *) - -val gen_signature : - tdcls -> Ast_payload.action list -> Asttypes.rec_flag -> Ast_signature.t - -val gen_structure_signature : - Location.t -> - Parsetree.type_declaration list -> - Ast_payload.action -> - Asttypes.rec_flag -> - Parsetree.structure_item diff --git a/jscomp/frontend/ast_derive_abstract.ml b/jscomp/frontend/ast_derive_abstract.ml deleted file mode 100644 index 7963307..0000000 --- a/jscomp/frontend/ast_derive_abstract.ml +++ /dev/null @@ -1,182 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* let derivingName = "abstract" *) -module U = Ast_derive_util -open Ast_helper -(* type tdcls = Parsetree.type_declaration list *) - -type abstractKind = Not_abstract | Light_abstract | Complex_abstract - -let isAbstract (xs : Ast_payload.action list) = - match xs with - | [({txt = "abstract"}, None)] -> Complex_abstract - | [({txt = "abstract"}, Some {pexp_desc = Pexp_ident {txt = Lident "light"}})] - -> - Light_abstract - | [({loc; txt = "abstract"}, Some _)] -> - Location.raise_errorf ~loc "invalid config for abstract" - | xs -> - Ext_list.iter xs (function {loc; txt}, _ -> - (match txt with - | "abstract" -> - Location.raise_errorf ~loc - "deriving abstract does not work with any other deriving" - | _ -> ())); - Not_abstract -(* let handle_config (config : Parsetree.expression option) = - match config with - | Some config -> - U.invalid_config config - | None -> () *) - -(** For this attributes, its type was wrapped as an option, - so we can still reuse existing frame work -*) -let get_optional_attrs = - [Ast_attributes.bs_get; Ast_attributes.bs_return_undefined] - -let get_attrs = [Ast_attributes.bs_get_arity] - -let set_attrs = [Ast_attributes.bs_set] - -let handleTdcl light (tdcl : Parsetree.type_declaration) : - Parsetree.type_declaration * Parsetree.value_description list = - let core_type = U.core_type_of_type_declaration tdcl in - let loc = tdcl.ptype_loc in - let type_name = tdcl.ptype_name.txt in - let newTdcl = - { - tdcl with - ptype_kind = Ptype_abstract; - ptype_attributes = [] (* avoid non-terminating*); - } - in - match tdcl.ptype_kind with - | Ptype_record label_declarations -> - let is_private = tdcl.ptype_private = Private in - let has_optional_field = - Ext_list.exists label_declarations (fun x -> - Ast_attributes.has_bs_optional x.pld_attributes) - in - let setter_accessor, makeType, labels = - Ext_list.fold_right label_declarations - ( [], - (if has_optional_field then - Ast_compatible.arrow ~loc (Ast_literal.type_unit ()) core_type - else core_type), - [] ) - (fun ({ - pld_name = {txt = label_name; loc = label_loc} as pld_name; - pld_type; - pld_mutable; - pld_attributes; - pld_loc; - } : - Parsetree.label_declaration) (acc, maker, labels) -> - let prim_as_name, newLabel = - match Ast_attributes.iter_process_bs_string_as pld_attributes with - | None -> (label_name, pld_name) - | Some new_name -> (new_name, {pld_name with txt = new_name}) - in - let prim = [prim_as_name] in - let is_optional = Ast_attributes.has_bs_optional pld_attributes in - - let maker, acc = - if is_optional then - let optional_type = Ast_core_type.lift_option_type pld_type in - ( Ast_compatible.opt_arrow ~loc:pld_loc label_name pld_type maker, - Val.mk ~loc:pld_loc - (if light then pld_name - else {pld_name with txt = pld_name.txt ^ "Get"}) - ~attrs:get_optional_attrs ~prim - (Ast_compatible.arrow ~loc core_type optional_type) - :: acc ) - else - ( Ast_compatible.label_arrow ~loc:pld_loc label_name pld_type maker, - Val.mk ~loc:pld_loc - (if light then pld_name - else {pld_name with txt = pld_name.txt ^ "Get"}) - ~attrs:get_attrs - ~prim: - ((* Not needed actually*) - External_ffi_types.ffi_bs_as_prims - [External_arg_spec.dummy] Return_identity - (Js_get {js_get_name = prim_as_name; js_get_scopes = []})) - (Ast_compatible.arrow ~loc core_type pld_type) - :: acc ) - in - let is_current_field_mutable = pld_mutable = Mutable in - let acc = - if is_current_field_mutable then - let setter_type = - Ast_compatible.arrow core_type - (Ast_compatible.arrow pld_type (* setter *) - (Ast_literal.type_unit ())) - in - Val.mk ~loc:pld_loc - {loc = label_loc; txt = label_name ^ "Set"} (* setter *) - ~attrs:set_attrs ~prim setter_type - :: acc - else acc - in - (acc, maker, (is_optional, newLabel) :: labels)) - in - ( newTdcl, - if is_private then setter_accessor - else - let myPrims = - Ast_external_process.pval_prim_of_option_labels labels - has_optional_field - in - let myMaker = - Val.mk ~loc {loc; txt = type_name} ~prim:myPrims makeType - in - myMaker :: setter_accessor ) - | Ptype_abstract | Ptype_variant _ | Ptype_open -> - (* Looks obvious that it does not make sense to warn *) - (* U.notApplicable tdcl.ptype_loc derivingName; *) - (tdcl, []) - -let handleTdclsInStr ~light rf tdcls = - let tdcls, code = - Ext_list.fold_right tdcls ([], []) (fun tdcl (tdcls, sts) -> - match handleTdcl light tdcl with - | ntdcl, value_descriptions -> - ( ntdcl :: tdcls, - Ext_list.map_append value_descriptions sts (fun x -> - Str.primitive x) )) - in - Ast_compatible.rec_type_str rf tdcls :: code -(* still need perform transformation for non-abstract type*) - -let handleTdclsInSig ~light rf tdcls = - let tdcls, code = - Ext_list.fold_right tdcls ([], []) (fun tdcl (tdcls, sts) -> - match handleTdcl light tdcl with - | ntdcl, value_descriptions -> - ( ntdcl :: tdcls, - Ext_list.map_append value_descriptions sts (fun x -> Sig.value x) )) - in - Ast_compatible.rec_type_sig rf tdcls :: code diff --git a/jscomp/frontend/ast_derive_abstract.mli b/jscomp/frontend/ast_derive_abstract.mli deleted file mode 100644 index 5e23f9d..0000000 --- a/jscomp/frontend/ast_derive_abstract.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type abstractKind = Not_abstract | Light_abstract | Complex_abstract - -val isAbstract : Ast_payload.action list -> abstractKind -(** if only [abstract] happens [true] - if [abstract] does not appear [false] - if [abstract] happens with other, raise exception -*) - -val handleTdclsInStr : - light:bool -> - Asttypes.rec_flag -> - Parsetree.type_declaration list -> - Parsetree.structure - -val handleTdclsInSig : - light:bool -> - Asttypes.rec_flag -> - Parsetree.type_declaration list -> - Parsetree.signature diff --git a/jscomp/frontend/ast_derive_js_mapper.ml b/jscomp/frontend/ast_derive_js_mapper.ml deleted file mode 100644 index 496a7fa..0000000 --- a/jscomp/frontend/ast_derive_js_mapper.ml +++ /dev/null @@ -1,338 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper -module U = Ast_derive_util - -type tdcls = Parsetree.type_declaration list - -let js_field (o : Parsetree.expression) m = - Ast_compatible.app2 - (Exp.ident {txt = Lident "##"; loc = o.pexp_loc}) - o (Exp.ident m) - -let handle_config (config : Parsetree.expression option) = - match config with - | Some config -> ( - match config.pexp_desc with - | Pexp_record - ( [ - ( {txt = Lident "newType"}, - { - pexp_desc = - ( Pexp_construct - ({txt = Lident (("true" | "false") as x)}, None) - | Pexp_ident {txt = Lident ("newType" as x)} ); - } ); - ], - None ) -> - not (x = "false") - | Pexp_ident {txt = Lident "newType"} -> true - | _ -> U.invalid_config config) - | None -> false - -let noloc = Location.none - -(* [eraseType] will be instrumented, be careful about the name conflict*) -let eraseTypeLit = "_eraseType" - -let eraseTypeExp = Exp.ident {loc = noloc; txt = Lident eraseTypeLit} - -let eraseType x = Ast_compatible.app1 eraseTypeExp x - -let eraseTypeStr = - let any = Typ.any () in - Str.primitive - (Val.mk ~prim:["%identity"] - {loc = noloc; txt = eraseTypeLit} - (Ast_compatible.arrow any any)) - -let unsafeIndex = "_index" - -let unsafeIndexGet = - let any = Typ.any () in - Str.primitive - (Val.mk ~prim:[""] - {loc = noloc; txt = unsafeIndex} - ~attrs:[Ast_attributes.bs_get_index] - (Ast_compatible.arrow any (Ast_compatible.arrow any any))) - -let unsafeIndexGetExp = Exp.ident {loc = noloc; txt = Lident unsafeIndex} - -(* JavaScript has allowed trailing commas in array literals since the beginning, - and later added them to object literals (ECMAScript 5) and most recently (ECMAScript 2017) - to function parameters. *) -let add_key_value buf key value last = - Ext_buffer.add_char_string buf '"' key; - Ext_buffer.add_string buf "\":\""; - Ext_buffer.add_string buf value; - if last then Ext_buffer.add_string buf "\"" - else Ext_buffer.add_string buf "\"," - -let buildMap (row_fields : Parsetree.row_field list) = - let has_bs_as = ref false in - let data, revData = - let buf = Ext_buffer.create 50 in - let revBuf = Ext_buffer.create 50 in - Ext_buffer.add_string buf "{"; - Ext_buffer.add_string revBuf "{"; - let rec aux (row_fields : Parsetree.row_field list) = - match row_fields with - | [] -> () - | tag :: rest -> - (match tag with - | Rtag ({txt}, attrs, _, []) -> - let name : string = - match Ast_attributes.iter_process_bs_string_as attrs with - | Some name -> - has_bs_as := true; - name - | None -> txt - in - let last = rest = [] in - add_key_value buf txt name last; - add_key_value revBuf name txt last - | _ -> assert false (* checked by [is_enum_polyvar] *)); - aux rest - in - aux row_fields; - Ext_buffer.add_string buf "}"; - Ext_buffer.add_string revBuf "}"; - (Ext_buffer.contents buf, Ext_buffer.contents revBuf) - in - (data, revData, !has_bs_as) - -let app1 = Ast_compatible.app1 - -let app2 = Ast_compatible.app2 - -let ( ->~ ) a b = Ast_compatible.arrow a b - -let jsMapperRt = Longident.Ldot (Lident "Js", "MapperRt") - -let raiseWhenNotFound x = - app1 - (Exp.ident - {loc = noloc; txt = Longident.Ldot (jsMapperRt, "raiseWhenNotFound")}) - x -let derivingName = "jsConverter" - -let init () = - Ast_derive.register derivingName (fun (x : Parsetree.expression option) -> - let createType = handle_config x in - - { - structure_gen = - (fun (tdcls : tdcls) _ -> - let handle_tdcl (tdcl : Parsetree.type_declaration) = - let core_type = U.core_type_of_type_declaration tdcl in - let name = tdcl.ptype_name.txt in - let toJs = name ^ "ToJs" in - let fromJs = name ^ "FromJs" in - let loc = tdcl.ptype_loc in - let patToJs = {Asttypes.loc; txt = toJs} in - let patFromJs = {Asttypes.loc; txt = fromJs} in - let param = "param" in - - let ident_param = {Asttypes.txt = Longident.Lident param; loc} in - let pat_param = {Asttypes.loc; txt = param} in - let exp_param = Exp.ident ident_param in - let newType, newTdcl = - U.new_type_of_type_declaration tdcl ("abs_" ^ name) - in - let newTypeStr = - (* Abstract type *) - Ast_compatible.rec_type_str Nonrecursive [newTdcl] - in - let toJsBody body = - Ast_comb.single_non_rec_value patToJs - (Ast_compatible.fun_ - (Pat.constraint_ (Pat.var pat_param) core_type) - body) - in - let ( +> ) a ty = Exp.constraint_ (eraseType a) ty in - let ( +: ) a ty = eraseType (Exp.constraint_ a ty) in - let coerceResultToNewType e = - if createType then e +> newType else e - in - match tdcl.ptype_kind with - | Ptype_record label_declarations -> - let exp = - coerceResultToNewType - (Exp.extension - ( {Asttypes.loc; txt = "bs.obj"}, - PStr - [ - Str.eval - (Exp.record - (Ext_list.map label_declarations - (fun {pld_name = {loc; txt}} -> - let label = - { - Asttypes.loc; - txt = Longident.Lident txt; - } - in - (label, Exp.field exp_param label))) - None); - ] )) - in - let toJs = toJsBody exp in - let obj_exp = - Exp.record - (Ext_list.map label_declarations - (fun {pld_name = {loc; txt}} -> - let label = - {Asttypes.loc; txt = Longident.Lident txt} - in - (label, js_field exp_param label))) - None - in - let fromJs = - Ast_comb.single_non_rec_value patFromJs - (Ast_compatible.fun_ (Pat.var pat_param) - (if createType then - Exp.let_ Nonrecursive - [Vb.mk (Pat.var pat_param) (exp_param +: newType)] - (Exp.constraint_ obj_exp core_type) - else Exp.constraint_ obj_exp core_type)) - in - let rest = [toJs; fromJs] in - if createType then eraseTypeStr :: newTypeStr :: rest else rest - | Ptype_abstract -> ( - match Ast_polyvar.is_enum_polyvar tdcl with - | Some row_fields -> - let map, revMap = ("_map", "_revMap") in - let expMap = Exp.ident {loc; txt = Lident map} in - let revExpMap = Exp.ident {loc; txt = Lident revMap} in - let data, revData, has_bs_as = buildMap row_fields in - - let v = - [ - eraseTypeStr; - unsafeIndexGet; - Ast_comb.single_non_rec_value {loc; txt = map} - (Exp.extension - ( {txt = "raw"; loc}, - PStr [Str.eval (Exp.constant (Const.string data))] - )); - Ast_comb.single_non_rec_value {loc; txt = revMap} - (if has_bs_as then - Exp.extension - ( {txt = "raw"; loc}, - PStr - [ - Str.eval (Exp.constant (Const.string revData)); - ] ) - else expMap); - toJsBody - (if has_bs_as then - app2 unsafeIndexGetExp expMap exp_param - else app1 eraseTypeExp exp_param); - Ast_comb.single_non_rec_value patFromJs - (Ast_compatible.fun_ (Pat.var pat_param) - (let result = - app2 unsafeIndexGetExp revExpMap exp_param - in - if createType then raiseWhenNotFound result - else result)); - ] - in - if createType then newTypeStr :: v else v - | None -> - U.notApplicable tdcl.Parsetree.ptype_loc derivingName; - []) - | Ptype_variant _ -> - U.notApplicable tdcl.Parsetree.ptype_loc derivingName; - [] - | Ptype_open -> - U.notApplicable tdcl.Parsetree.ptype_loc derivingName; - [] - in - Ext_list.flat_map tdcls handle_tdcl); - signature_gen = - (fun (tdcls : tdcls) _ -> - let handle_tdcl tdcl = - let core_type = U.core_type_of_type_declaration tdcl in - let name = tdcl.ptype_name.txt in - let toJs = name ^ "ToJs" in - let fromJs = name ^ "FromJs" in - let loc = tdcl.ptype_loc in - let patToJs = {Asttypes.loc; txt = toJs} in - let patFromJs = {Asttypes.loc; txt = fromJs} in - let toJsType result = - Ast_comb.single_non_rec_val patToJs - (Ast_compatible.arrow core_type result) - in - let newType, newTdcl = - U.new_type_of_type_declaration tdcl ("abs_" ^ name) - in - let newTypeStr = - Ast_compatible.rec_type_sig Nonrecursive [newTdcl] - in - let ( +? ) v rest = if createType then v :: rest else rest in - match tdcl.ptype_kind with - | Ptype_record label_declarations -> - let objType flag = - Typ.object_ - (Ext_list.map label_declarations - (fun {pld_name; pld_type} -> - Parsetree.Otag (pld_name, [], pld_type))) - flag - in - newTypeStr - +? [ - toJsType (if createType then newType else objType Closed); - Ast_comb.single_non_rec_val patFromJs - ((if createType then newType else objType Open) - ->~ core_type); - ] - | Ptype_abstract -> ( - match Ast_polyvar.is_enum_polyvar tdcl with - | Some _ -> - let ty1 = - if createType then newType else Ast_literal.type_string () - in - let ty2 = - if createType then core_type - else Ast_core_type.lift_option_type core_type - in - newTypeStr - +? [ - toJsType ty1; - Ast_comb.single_non_rec_val patFromJs (ty1 ->~ ty2); - ] - | None -> - U.notApplicable tdcl.Parsetree.ptype_loc derivingName; - []) - | Ptype_variant _ -> - U.notApplicable tdcl.Parsetree.ptype_loc derivingName; - [] - | Ptype_open -> - U.notApplicable tdcl.Parsetree.ptype_loc derivingName; - [] - in - Ext_list.flat_map tdcls handle_tdcl); - expression_gen = None; - }) diff --git a/jscomp/frontend/ast_derive_js_mapper.mli b/jscomp/frontend/ast_derive_js_mapper.mli deleted file mode 100644 index cb5a914..0000000 --- a/jscomp/frontend/ast_derive_js_mapper.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val init : unit -> unit diff --git a/jscomp/frontend/ast_derive_projector.ml b/jscomp/frontend/ast_derive_projector.ml deleted file mode 100644 index 48ff7d6..0000000 --- a/jscomp/frontend/ast_derive_projector.ml +++ /dev/null @@ -1,183 +0,0 @@ -open Ast_helper - -let invalid_config (config : Parsetree.expression) = - Location.raise_errorf ~loc:config.pexp_loc - "such configuration is not supported" - -let raise_unsupported_vaiant_record_arg loc = - Location.raise_errorf ~loc - "@deriving(accessors) from a variant record argument is unsupported. \ - Either define the record type separately from the variant type or use a \ - positional argument." - -type tdcls = Parsetree.type_declaration list - -let derivingName = "accessors" - -let init () = - Ast_derive.register derivingName (fun (x : Parsetree.expression option) -> - Ext_option.iter x invalid_config; - { - structure_gen = - (fun (tdcls : tdcls) _explict_nonrec -> - let handle_uncurried_accessor_tranform ~loc ~arity accessor = - (* Accessors with no params (arity of 0) are simply values and not functions *) - match Config.uncurried.contents with - | Uncurried when arity > 0 -> - Ast_uncurried.uncurriedFun ~loc ~arity accessor - | _ -> accessor - in - let handle_tdcl tdcl = - let core_type = - Ast_derive_util.core_type_of_type_declaration tdcl - in - let gentype_attrs = - match - Ext_list.exists core_type.ptyp_attributes - Ast_attributes.is_gentype - with - | true -> Some [Ast_attributes.gentype] - | false -> None - in - match tdcl.ptype_kind with - | Ptype_record label_declarations -> - Ext_list.map label_declarations - (fun - ({pld_name = {loc; txt = pld_label} as pld_name} : - Parsetree.label_declaration) - -> - let txt = "param" in - Ast_comb.single_non_rec_value ?attrs:gentype_attrs pld_name - (Ast_compatible.fun_ - (Pat.constraint_ (Pat.var {txt; loc}) core_type) - (Exp.field - (Exp.ident {txt = Lident txt; loc}) - {txt = Longident.Lident pld_label; loc}) - (*arity will alwys be 1 since these are single param functions*) - |> handle_uncurried_accessor_tranform ~arity:1 ~loc)) - | Ptype_variant constructor_declarations -> - Ext_list.map constructor_declarations - (fun - { - pcd_name = {loc; txt = con_name}; - pcd_args; - pcd_loc; - pcd_res; - } - -> - (* TODO: add type annotations *) - let pcd_args = - match pcd_args with - | Pcstr_tuple pcd_args -> pcd_args - | Pcstr_record _ -> - raise_unsupported_vaiant_record_arg pcd_loc - in - let little_con_name = - Ext_string.uncapitalize_ascii con_name - in - let arity = List.length pcd_args in - let annotate_type = - match pcd_res with - | None -> core_type - | Some x -> x - in - Ast_comb.single_non_rec_value ?attrs:gentype_attrs - {loc; txt = little_con_name} - (if arity = 0 then - (*TODO: add a prefix, better inter-op with FFI *) - Exp.constraint_ - (Exp.construct - {loc; txt = Longident.Lident con_name} - None) - annotate_type - else - let vars = - Ext_list.init arity (fun x -> - "param_" ^ string_of_int x) - in - let exp = - Exp.constraint_ - (Exp.construct - {loc; txt = Longident.Lident con_name} - @@ Some - (if arity = 1 then - Exp.ident - {loc; txt = Lident (List.hd vars)} - else - Exp.tuple - (Ext_list.map vars (fun x -> - Exp.ident {loc; txt = Lident x})))) - annotate_type - in - Ext_list.fold_right vars exp (fun var b -> - Ast_compatible.fun_ (Pat.var {loc; txt = var}) b) - |> handle_uncurried_accessor_tranform ~loc ~arity)) - | Ptype_abstract | Ptype_open -> - Ast_derive_util.notApplicable tdcl.ptype_loc derivingName; - [] - (* Location.raise_errorf "projector only works with record" *) - in - Ext_list.flat_map tdcls handle_tdcl); - signature_gen = - (fun (tdcls : Parsetree.type_declaration list) _explict_nonrec -> - let handle_uncurried_type_tranform ~loc ~arity t = - match Config.uncurried.contents with - (* Accessors with no params (arity of 0) are simply values and not functions *) - | Uncurried when arity > 0 -> - Ast_uncurried.uncurriedType ~loc ~arity t - | _ -> t - in - let handle_tdcl tdcl = - let core_type = - Ast_derive_util.core_type_of_type_declaration tdcl - in - let gentype_attrs = - match - Ext_list.exists core_type.ptyp_attributes - Ast_attributes.is_gentype - with - | true -> Some [Ast_attributes.gentype] - | false -> None - in - match tdcl.ptype_kind with - | Ptype_record label_declarations -> - Ext_list.map label_declarations (fun {pld_name; pld_type} -> - Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name - (Ast_compatible.arrow core_type pld_type - (*arity will alwys be 1 since these are single param functions*) - |> handle_uncurried_type_tranform ~arity:1 - ~loc:pld_name.loc)) - | Ptype_variant constructor_declarations -> - Ext_list.map constructor_declarations - (fun - { - pcd_name = {loc; txt = con_name}; - pcd_args; - pcd_loc; - pcd_res; - } - -> - let pcd_args = - match pcd_args with - | Pcstr_tuple pcd_args -> pcd_args - | Pcstr_record _ -> - raise_unsupported_vaiant_record_arg pcd_loc - in - let arity = pcd_args |> List.length in - let annotate_type = - match pcd_res with - | Some x -> x - | None -> core_type - in - Ast_comb.single_non_rec_val ?attrs:gentype_attrs - {loc; txt = Ext_string.uncapitalize_ascii con_name} - (Ext_list.fold_right pcd_args annotate_type (fun x acc -> - Ast_compatible.arrow x acc) - |> handle_uncurried_type_tranform ~arity ~loc)) - | Ptype_open | Ptype_abstract -> - Ast_derive_util.notApplicable tdcl.ptype_loc derivingName; - [] - in - Ext_list.flat_map tdcls handle_tdcl); - expression_gen = None; - }) diff --git a/jscomp/frontend/ast_derive_projector.mli b/jscomp/frontend/ast_derive_projector.mli deleted file mode 100644 index cb5a914..0000000 --- a/jscomp/frontend/ast_derive_projector.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val init : unit -> unit diff --git a/jscomp/frontend/ast_derive_util.ml b/jscomp/frontend/ast_derive_util.ml deleted file mode 100644 index 782c055..0000000 --- a/jscomp/frontend/ast_derive_util.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper - -let core_type_of_type_declaration (tdcl : Parsetree.type_declaration) = - match tdcl with - | {ptype_name = {txt; loc}; ptype_params; ptype_attributes = attrs} -> - Typ.constr ~attrs {txt = Lident txt; loc} (Ext_list.map ptype_params fst) - -let new_type_of_type_declaration (tdcl : Parsetree.type_declaration) newName = - match tdcl with - | {ptype_name = {loc}; ptype_params} -> - ( Typ.constr {txt = Lident newName; loc} (Ext_list.map ptype_params fst), - { - Parsetree.ptype_params = tdcl.ptype_params; - ptype_name = {txt = newName; loc}; - ptype_kind = Ptype_abstract; - ptype_attributes = []; - ptype_loc = tdcl.ptype_loc; - ptype_cstrs = []; - ptype_private = Public; - ptype_manifest = None; - } ) -let notApplicable loc derivingName = - Location.prerr_warning loc - (Warnings.Bs_derive_warning (derivingName ^ " not applicable to this type")) - -let invalid_config (config : Parsetree.expression) = - Location.raise_errorf ~loc:config.pexp_loc - "such configuration is not supported" diff --git a/jscomp/frontend/ast_derive_util.mli b/jscomp/frontend/ast_derive_util.mli deleted file mode 100644 index 1cc656e..0000000 --- a/jscomp/frontend/ast_derive_util.mli +++ /dev/null @@ -1,48 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val core_type_of_type_declaration : - Parsetree.type_declaration -> Parsetree.core_type -(** Given a type declaration, extaract the type expression, mostly - used in code gen later -*) - -val new_type_of_type_declaration : - Parsetree.type_declaration -> - string -> - Parsetree.core_type * Parsetree.type_declaration - -(* val mk_fun : - loc:Location.t -> - Parsetree.core_type -> - string -> Parsetree.expression -> Parsetree.expression - val destruct_label_declarations : - loc:Location.t -> - string -> - Parsetree.label_declaration list -> - (Parsetree.core_type * Parsetree.expression) list * string list *) - -val notApplicable : Location.t -> string -> unit - -val invalid_config : Parsetree.expression -> 'a diff --git a/jscomp/frontend/ast_exp.ml b/jscomp/frontend/ast_exp.ml deleted file mode 100644 index e51ab5d..0000000 --- a/jscomp/frontend/ast_exp.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Parsetree.expression diff --git a/jscomp/frontend/ast_exp.mli b/jscomp/frontend/ast_exp.mli deleted file mode 100644 index e51ab5d..0000000 --- a/jscomp/frontend/ast_exp.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Parsetree.expression diff --git a/jscomp/frontend/ast_exp_apply.ml b/jscomp/frontend/ast_exp_apply.ml deleted file mode 100644 index 4c0ad3a..0000000 --- a/jscomp/frontend/ast_exp_apply.ml +++ /dev/null @@ -1,222 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper - -type exp = Parsetree.expression - -let rec no_need_bound (exp : exp) = - match exp.pexp_desc with - | Pexp_ident {txt = Lident _} -> true - | Pexp_constraint (e, _) -> no_need_bound e - | _ -> false - -let ocaml_obj_id = "__ocaml_internal_obj" - -let bound (e : exp) (cb : exp -> _) = - if no_need_bound e then cb e - else - let loc = e.pexp_loc in - Exp.let_ ~loc Nonrecursive - [Vb.mk ~loc (Pat.var ~loc {txt = ocaml_obj_id; loc}) e] - (cb (Exp.ident ~loc {txt = Lident ocaml_obj_id; loc})) - -let default_expr_mapper = Bs_ast_mapper.default_mapper.expr - -let check_and_discard (args : Ast_compatible.args) = - Ext_list.map args (fun (label, x) -> - Bs_syntaxerr.err_if_label x.pexp_loc label; - x) - -type app_pattern = { - op: string; - loc: Location.t; - (* locatoin is the location of whole expression #4451 *) - args: Parsetree.expression list; -} - -let sane_property_name_check loc s = - if String.contains s '#' then - Location.raise_errorf ~loc - "property name (%s) can not contain speical character #" s - -(* match fn as *) -let view_as_app (fn : exp) (s : string list) : app_pattern option = - match fn.pexp_desc with - | Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident op; _}}, args) - when Ext_list.has_string s op -> - Some {op; loc = fn.pexp_loc; args = check_and_discard args} - | _ -> None - -let infix_ops = ["|."; "|.u"; "#="; "##"] - -let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) (fn : exp) - (args : Ast_compatible.args) : exp = - match view_as_app e infix_ops with - | Some {op = ("|." | "|.u") as op; args = [a_; f_]; loc} -> ( - (* - a |. f - a |. f b c [@bs] --> f a b c [@bs] - a |. (g |. b) - a |. `Variant - a |. (b |. f c [@bs]) - *) - let a = self.expr self a_ in - let f = self.expr self f_ in - match f.pexp_desc with - | Pexp_variant (label, None) -> - {f with pexp_desc = Pexp_variant (label, Some a); pexp_loc = e.pexp_loc} - | Pexp_construct (ctor, None) -> - {f with pexp_desc = Pexp_construct (ctor, Some a); pexp_loc = e.pexp_loc} - | Pexp_apply (fn1, args) -> - Bs_ast_invariant.warn_discarded_unused_attributes fn1.pexp_attributes; - { - pexp_desc = Pexp_apply (fn1, (Nolabel, a) :: args); - pexp_loc = e.pexp_loc; - pexp_attributes = e.pexp_attributes @ f.pexp_attributes; - } - | Pexp_tuple xs -> - bound a (fun bounded_obj_arg -> - { - pexp_desc = - Pexp_tuple - (Ext_list.map xs (fun fn -> - match fn.pexp_desc with - | Pexp_construct (ctor, None) -> - { - fn with - pexp_desc = Pexp_construct (ctor, Some bounded_obj_arg); - } - | Pexp_apply (fn, args) -> - Bs_ast_invariant.warn_discarded_unused_attributes - fn.pexp_attributes; - { - Parsetree.pexp_desc = - Pexp_apply (fn, (Nolabel, bounded_obj_arg) :: args); - pexp_attributes = []; - pexp_loc = fn.pexp_loc; - } - | _ -> - Ast_compatible.app1 ~loc:fn.pexp_loc fn bounded_obj_arg)); - pexp_attributes = f.pexp_attributes; - pexp_loc = f.pexp_loc; - }) - | _ -> - if op = "|.u" then - (* a |.u f - Uncurried unary application *) - Ast_compatible.app1 ~loc - ~attrs:(Ast_attributes.res_uapp :: e.pexp_attributes) - f a - else Ast_compatible.app1 ~loc ~attrs:e.pexp_attributes f a) - | Some {op = "##"; loc; args = [obj; rest]} -> ( - (* - obj##property - - obj#(method a b ) - we should warn when we discard attributes - gpr#1063 foo##(bar##baz) we should rewrite (bar##baz) - first before pattern match. - currently the pattern match is written in a top down style. - Another corner case: f##(g a b [@bs]) - *) - match rest with - | { - pexp_desc = - ( Pexp_ident {txt = Lident name; _} - | Pexp_constant (Pconst_string (name, None)) ); - pexp_loc; - } - (* f##paint - TODO: this is not relevant: remove it later - *) -> - sane_property_name_check pexp_loc name; - {e with pexp_desc = Ast_util.js_property loc (self.expr self obj) name} - | _ -> Location.raise_errorf ~loc "invalid ## syntax") - (* we can not use [:=] for precedece cases - like {[i @@ x##length := 3 ]} - is parsed as {[ (i @@ x##length) := 3]} - since we allow user to create Js objects in OCaml, it can be of - ref type - {[ - let u = object (self) - val x = ref 3 - method setX x = self##x := 32 - method getX () = !self##x - end - ]} - *) - | Some {op = "#="; loc; args = [obj; arg]} -> ( - let gen_assignment obj name name_loc = - sane_property_name_check name_loc name; - let obj = self.expr self obj in - let arg = self.expr self arg in - let fn = Exp.send ~loc obj {txt = name ^ Literals.setter_suffix; loc} in - Exp.constraint_ ~loc - (Exp.apply ~loc ~attrs:[Ast_attributes.res_uapp] fn [(Nolabel, arg)]) - (Ast_literal.type_unit ~loc ()) - in - match obj.pexp_desc with - | Pexp_send (obj, {txt = name; loc = name_loc}) -> - gen_assignment obj name name_loc - | _ -> ( - match view_as_app obj ["##"] with - | Some - { - args = - [ - obj; - { - pexp_desc = - ( Pexp_ident {txt = Lident name} - | Pexp_constant (Pconst_string (name, None)) ); - pexp_loc = name_loc; - }; - ]; - } -> - gen_assignment obj name name_loc - | _ -> Location.raise_errorf ~loc "invalid #= assignment")) - | Some {op = "|."; loc} -> - Location.raise_errorf ~loc - "invalid |. syntax, it can only be used as binary operator" - | Some {op = "##"; loc} -> - Location.raise_errorf ~loc - "Js object ## expect syntax like obj##(paint (a,b)) " - | Some {op} -> Location.raise_errorf "invalid %s syntax" op - | None -> ( - match Ext_list.exclude_with_val e.pexp_attributes Ast_attributes.is_bs with - | Some pexp_attributes -> ( - (* syntax: {[f arg0 arg1 [@bs]]} only for legacy .ml files *) - let fn = self.expr self fn in - let args = Ext_list.map args (fun (lbl, e) -> (lbl, self.expr self e)) in - let jsInternal = Ast_literal.Lid.js_internal in - let loc = e.pexp_loc in - match args with - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - Exp.apply ~loc ~attrs:pexp_attributes - (Exp.ident {txt = Ldot (jsInternal, "run"); loc}) - [(Nolabel, fn)] - | _ -> - Exp.apply ~loc - ~attrs:(Ast_attributes.res_uapp :: pexp_attributes) - fn args) - | None -> default_expr_mapper self e) diff --git a/jscomp/frontend/ast_exp_apply.mli b/jscomp/frontend/ast_exp_apply.mli deleted file mode 100644 index 12cc881..0000000 --- a/jscomp/frontend/ast_exp_apply.mli +++ /dev/null @@ -1,30 +0,0 @@ -(* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val app_exp_mapper : - Parsetree.expression -> - Bs_ast_mapper.mapper -> - Parsetree.expression -> - Ast_compatible.args -> - Parsetree.expression diff --git a/jscomp/frontend/ast_exp_extension.ml b/jscomp/frontend/ast_exp_extension.ml deleted file mode 100644 index 2d9054a..0000000 --- a/jscomp/frontend/ast_exp_extension.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -open Ast_helper - -let handle_extension e (self : Bs_ast_mapper.mapper) - (({txt; loc}, payload) : Parsetree.extension) = - match txt with - | "todo" -> - let todo_message = - match Ast_payload.is_single_string payload with - | Some (s, _) -> Some s - | None -> None - in - Location.prerr_warning e.Parsetree.pexp_loc (Bs_todo todo_message); - let pretext = - loc.loc_start.pos_fname ^ ":" - ^ string_of_int loc.loc_start.pos_lnum - ^ ":" - ^ string_of_int loc.loc_start.pos_cnum - ^ "-" - ^ string_of_int loc.loc_end.pos_cnum - in - - Exp.apply ~loc - (Exp.ident ~loc {txt = Longident.parse "Js.Exn.raiseError"; loc}) - [ - ( Nolabel, - Exp.constant ~loc - (Pconst_string - ( (pretext - ^ - match todo_message with - | None -> " - Todo" - | Some msg -> " - Todo: " ^ msg), - None )) ); - ] - | "ffi" -> Ast_exp_handle_external.handle_ffi ~loc ~payload - | "bs.raw" | "raw" -> - Ast_exp_handle_external.handle_raw ~kind:Raw_exp loc payload - | "bs.re" | "re" -> - Exp.constraint_ ~loc - (Ast_exp_handle_external.handle_raw ~kind:Raw_re loc payload) - (Ast_comb.to_js_re_type loc) - | "bs.external" | "external" -> ( - match Ast_payload.as_ident payload with - | Some {txt = Lident x} -> - Ast_exp_handle_external.handle_external loc x - (* do we need support [%external gg.xx ] - - {[ Js.Undefined.to_opt (if Js.typeof x == "undefined" then x else Js.Undefined.empty ) ]} - *) - | None | Some _ -> - Location.raise_errorf ~loc "external expects a single identifier") - | "bs.time" | "time" -> ( - match payload with - | PStr [{pstr_desc = Pstr_eval (e, _)}] -> - let locString = - if loc.loc_ghost then "GHOST LOC" - else - let loc_start = loc.loc_start in - let file, lnum, __ = Location.get_pos_info loc_start in - Printf.sprintf "%s %d" (Filename.basename file) lnum - in - let e = self.expr self e in - Exp.sequence ~loc - (Ast_compatible.app1 ~loc - (Exp.ident ~loc - {loc; txt = Ldot (Ldot (Lident "Js", "Console"), "timeStart")}) - (Ast_compatible.const_exp_string ~loc locString)) - (Exp.let_ ~loc Nonrecursive - [Vb.mk ~loc (Pat.var ~loc {loc; txt = "timed"}) e] - (Exp.sequence ~loc - (Ast_compatible.app1 ~loc - (Exp.ident ~loc - {loc; txt = Ldot (Ldot (Lident "Js", "Console"), "timeEnd")}) - (Ast_compatible.const_exp_string ~loc locString)) - (Exp.ident ~loc {loc; txt = Lident "timed"}))) - | _ -> - Location.raise_errorf ~loc "expect a boolean expression in the payload") - | "bs.debugger" | "debugger" -> - {e with pexp_desc = Ast_exp_handle_external.handle_debugger loc payload} - | "bs.obj" | "obj" -> ( - match payload with - | PStr - [ - { - pstr_desc = - Pstr_eval (({pexp_desc = Pexp_record (label_exprs, None)} as e), _); - }; - ] -> - { - e with - pexp_desc = Ast_util.record_as_js_object e.pexp_loc self label_exprs; - } - | _ -> Location.raise_errorf ~loc "Expect a record expression here") - | _ -> e -(* For an unknown extension, we don't really need to process further*) -(* Exp.extension ~loc ~attrs:e.pexp_attributes ( - self.extension self extension) *) -(* Bs_ast_mapper.default_mapper.expr self e *) diff --git a/jscomp/frontend/ast_exp_extension.mli b/jscomp/frontend/ast_exp_extension.mli deleted file mode 100644 index fbb449d..0000000 --- a/jscomp/frontend/ast_exp_extension.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val handle_extension : - Parsetree.expression -> - Bs_ast_mapper.mapper -> - Parsetree.extension -> - Parsetree.expression diff --git a/jscomp/frontend/ast_exp_handle_external.ml b/jscomp/frontend/ast_exp_handle_external.ml deleted file mode 100644 index 63cddf0..0000000 --- a/jscomp/frontend/ast_exp_handle_external.ml +++ /dev/null @@ -1,160 +0,0 @@ -(* Copyright (C) 2020 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper - -(* - {[ - Js.undefinedToOption - (if Js.typeof x = "undefined" then undefined - else x ) - - ]} -*) -let handle_external loc (x : string) : Parsetree.expression = - let raw_exp : Ast_exp.t = - let str_exp = - Ast_compatible.const_exp_string ~loc x ~delimiter:Ext_string.empty - in - { - str_exp with - pexp_desc = - Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) - [str_exp]; - } - in - let empty = - (* FIXME: the empty delimiter does not make sense*) - Exp.ident ~loc {txt = Ldot (Ldot (Lident "Js", "Undefined"), "empty"); loc} - in - let undefined_typeof = - Exp.ident {loc; txt = Ldot (Lident "Js", "undefinedToOption")} - in - let typeof = Exp.ident {loc; txt = Ldot (Lident "Js", "typeof")} in - - Ast_compatible.app1 ~loc undefined_typeof - (Exp.ifthenelse ~loc - (Ast_compatible.app2 ~loc - (Exp.ident ~loc {loc; txt = Ldot (Lident "Pervasives", "=")}) - (Ast_compatible.app1 ~loc typeof raw_exp) - (Ast_compatible.const_exp_string ~loc "undefined")) - empty (Some raw_exp)) - -let handle_debugger loc (payload : Ast_payload.t) = - match payload with - | PStr [] -> - Ast_external_mk.local_external_apply loc ~pval_prim:["#debugger"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Ast_literal.type_unit ())) - [Ast_literal.val_unit ~loc ()] - | _ -> - Location.raise_errorf ~loc "%%debugger extension doesn't accept arguments" - -let handle_raw ~kind loc payload = - let is_function = ref None in - match Ast_payload.raw_as_string_exp_exn ~kind ~is_function payload with - | None -> ( - match kind with - | Raw_re -> - Location.raise_errorf ~loc - "%%re extension can only be applied to a string" - | Raw_exp -> - Location.raise_errorf ~loc - "%%raw extension can only be applied to a string" - | Raw_program -> - Location.raise_errorf ~loc - "%%%%raw extension can only be applied to a string") - | Some exp -> - { - exp with - pexp_desc = - Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) - [exp]; - pexp_attributes = - (match !is_function with - | None -> exp.pexp_attributes - | Some _ -> Ast_attributes.internal_expansive :: exp.pexp_attributes); - } - -let handle_ffi ~loc ~payload = - let is_function = ref None in - let err () = - Location.raise_errorf ~loc - "%%ffi extension can only be applied to a string containing a JavaScript \ - function such as \"(x) => ...\"" - in - match - Ast_payload.raw_as_string_exp_exn ~kind:Raw_exp ~is_function payload - with - | None -> err () - | Some exp -> - (* Wrap a type constraint based on arity. - E.g. for arity 2 constrain to type (_, _) => _ *) - let wrapTypeConstraint (e : Parsetree.expression) = - let loc = e.pexp_loc in - let any = Ast_helper.Typ.any ~loc:e.pexp_loc () in - let unit = Ast_literal.type_unit ~loc () in - let rec arrow ~arity = - if arity = 0 then Ast_helper.Typ.arrow ~loc Nolabel unit any - else if arity = 1 then Ast_helper.Typ.arrow ~loc Nolabel any any - else Ast_helper.Typ.arrow ~loc Nolabel any (arrow ~arity:(arity - 1)) - in - match !is_function with - | Some arity -> - let type_ = - Ast_uncurried.uncurriedType ~loc - ~arity:(if arity = 0 then 1 else arity) - (arrow ~arity) - in - Ast_helper.Exp.constraint_ ~loc e type_ - | _ -> err () - in - wrapTypeConstraint - { - exp with - pexp_desc = - Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) - [exp]; - pexp_attributes = - (match !is_function with - | None -> exp.pexp_attributes - | Some _ -> Ast_attributes.internal_expansive :: exp.pexp_attributes); - } - -let handle_raw_structure loc payload = - match Ast_payload.raw_as_string_exp_exn ~kind:Raw_program payload with - | Some exp -> - Ast_helper.Str.eval - { - exp with - pexp_desc = - Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"] - ~pval_type:(Typ.arrow Nolabel (Typ.any ()) (Typ.any ())) - [exp]; - } - | None -> - Location.raise_errorf ~loc - "%%%%raw extension can only be applied to a string" diff --git a/jscomp/frontend/ast_exp_handle_external.mli b/jscomp/frontend/ast_exp_handle_external.mli deleted file mode 100644 index c3ff047..0000000 --- a/jscomp/frontend/ast_exp_handle_external.mli +++ /dev/null @@ -1,38 +0,0 @@ -(* Copyright (C) 2020 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val handle_external : Location.t -> string -> Parsetree.expression - -val handle_debugger : Location.t -> Ast_payload.t -> Parsetree.expression_desc - -val handle_ffi : loc:Location.t -> payload:Ast_payload.t -> Parsetree.expression - -val handle_raw : - kind:Js_raw_info.raw_kind -> - Location.t -> - Ast_payload.t -> - Parsetree.expression - -val handle_raw_structure : - Location.t -> Ast_payload.t -> Parsetree.structure_item diff --git a/jscomp/frontend/ast_external.ml b/jscomp/frontend/ast_external.ml deleted file mode 100644 index c028305..0000000 --- a/jscomp/frontend/ast_external.ml +++ /dev/null @@ -1,183 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let handleExternalInSig (self : Bs_ast_mapper.mapper) - (prim : Parsetree.value_description) (sigi : Parsetree.signature_item) : - Parsetree.signature_item = - let loc = prim.pval_loc in - let pval_type = self.typ self prim.pval_type in - let pval_attributes = self.attributes self prim.pval_attributes in - match Ast_attributes.process_send_pipe pval_attributes with - | Some (obj, _) -> - (*has bs.send.pipe: best effort *) - { - sigi with - psig_desc = - Psig_value - { - prim with - pval_type = Ast_core_type.add_last_obj pval_type obj; - pval_prim = []; - pval_attributes = []; - }; - } - | None -> ( - match prim.pval_prim with - | [] -> Location.raise_errorf ~loc "empty primitive string" - | a :: b :: _ -> - Location.raise_errorf ~loc - "only a single string is allowed in bs external %S %S" a b - | [v] -> ( - match - Ast_external_process.encode_attributes_as_string loc pval_type - pval_attributes v - with - | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} -> - { - sigi with - psig_desc = - Psig_value - { - prim with - pval_type; - pval_prim = (if no_inline_cross_module then [] else pval_prim); - pval_attributes; - }; - })) - -let handleExternalInStru (self : Bs_ast_mapper.mapper) - (prim : Parsetree.value_description) (str : Parsetree.structure_item) : - Parsetree.structure_item = - let loc = prim.pval_loc in - let pval_type = self.typ self prim.pval_type in - let pval_attributes = self.attributes self prim.pval_attributes in - let send_pipe = ref false in - let pval_type, pval_attributes = - match Ast_attributes.process_send_pipe pval_attributes with - | Some (obj, attrs) -> - send_pipe := true; - (Ast_helper.Typ.arrow ~loc Nolabel obj pval_type, attrs) - | None -> (pval_type, pval_attributes) - in - match prim.pval_prim with - | [] -> Location.raise_errorf ~loc "empty primitive string" - | a :: b :: _ -> - Location.raise_errorf ~loc - "only a single string is allowed in bs external %S : %S" a b - | [v] -> ( - match - Ast_external_process.encode_attributes_as_string loc pval_type - pval_attributes v - with - | {pval_type; pval_prim; pval_attributes; no_inline_cross_module} -> - let external_result = - { - str with - pstr_desc = - Pstr_primitive {prim with pval_type; pval_prim; pval_attributes}; - } - in - let normal () = - if not no_inline_cross_module then external_result - else - let open Ast_helper in - Str.include_ ~loc - (Incl.mk ~loc - (Mod.constraint_ ~loc - (Mod.structure ~loc [external_result]) - (Mty.signature ~loc - [ - { - psig_desc = - Psig_value - { - prim with - pval_type; - pval_prim = []; - pval_attributes; - }; - psig_loc = loc; - }; - ]))) - in - if !send_pipe then - let[@warning "-8"] (_ :: params as args) = - Ast_core_type.get_curry_labels pval_type - in - let arity = List.length args in - if arity = 1 then normal () - else - let open Ast_helper in - Str.include_ ~loc - (Incl.mk ~loc - (Mod.structure ~loc - [ - external_result; - Str.value ~loc Nonrecursive - [ - Vb.mk ~loc - (Pat.var ~loc prim.pval_name) - (let body = - Exp.apply ~loc - (Exp.ident ~loc - {txt = Lident prim.pval_name.txt; loc}) - (( Asttypes.Nolabel, - Exp.ident ~loc {txt = Lident "obj"; loc} ) - :: Ext_list.mapi params (fun i x -> - ( x, - match x with - | Asttypes.Nolabel -> - Exp.ident - { - txt = - Lident - ("arg" ^ string_of_int (i + 1)); - loc; - } - | Labelled s | Optional s -> - Exp.ident {txt = Lident s; loc} ))) - in - snd - @@ Ext_list.fold_right params - ( 0, - Exp.fun_ Nolabel None - (Pat.var ~loc {txt = "obj"; loc}) - body ) - (fun arg (i, obj) -> - ( i + 1, - Exp.fun_ arg None - (Pat.var ~loc - { - txt = - (match arg with - | Labelled s | Optional s -> s - | Nolabel -> - "arg" - ^ string_of_int (arity - i - 1)); - loc; - }) - obj ))); - ]; - ])) - else normal ()) diff --git a/jscomp/frontend/ast_external.mli b/jscomp/frontend/ast_external.mli deleted file mode 100644 index 21f832f..0000000 --- a/jscomp/frontend/ast_external.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val handleExternalInSig : - Bs_ast_mapper.mapper -> - Parsetree.value_description -> - Parsetree.signature_item -> - Parsetree.signature_item - -val handleExternalInStru : - Bs_ast_mapper.mapper -> - Parsetree.value_description -> - Parsetree.structure_item -> - Parsetree.structure_item diff --git a/jscomp/frontend/ast_external_mk.ml b/jscomp/frontend/ast_external_mk.ml deleted file mode 100644 index 3ec65e1..0000000 --- a/jscomp/frontend/ast_external_mk.ml +++ /dev/null @@ -1,130 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let local_external_apply loc ?(pval_attributes = []) ~(pval_prim : string list) - ~(pval_type : Parsetree.core_type) ?(local_module_name = "J") - ?(local_fun_name = "unsafe_expr") (args : Parsetree.expression list) : - Parsetree.expression_desc = - Pexp_letmodule - ( {txt = local_module_name; loc}, - { - pmod_desc = - Pmod_structure - [ - { - pstr_desc = - Pstr_primitive - { - pval_name = {txt = local_fun_name; loc}; - pval_type; - pval_loc = loc; - pval_prim; - pval_attributes; - }; - pstr_loc = loc; - }; - ]; - pmod_loc = loc; - pmod_attributes = []; - }, - Ast_compatible.apply_simple - ({ - pexp_desc = - Pexp_ident - {txt = Ldot (Lident local_module_name, local_fun_name); loc}; - pexp_attributes = []; - pexp_loc = loc; - } - : Parsetree.expression) - args ~loc ) - -let local_external_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type - ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr") args : - Parsetree.expression_desc = - Pexp_letmodule - ( {txt = local_module_name; loc}, - { - pmod_desc = - Pmod_structure - [ - { - pstr_desc = - Pstr_primitive - { - pval_name = {txt = local_fun_name; loc}; - pval_type; - pval_loc = loc; - pval_prim; - pval_attributes; - }; - pstr_loc = loc; - }; - ]; - pmod_loc = loc; - pmod_attributes = []; - }, - Ast_compatible.apply_labels - ({ - pexp_desc = - Pexp_ident - {txt = Ldot (Lident local_module_name, local_fun_name); loc}; - pexp_attributes = []; - pexp_loc = loc; - } - : Parsetree.expression) - args ~loc ) - -let local_extern_cont_to_obj loc ?(pval_attributes = []) ~pval_prim ~pval_type - ?(local_module_name = "J") ?(local_fun_name = "unsafe_expr") - (cb : Parsetree.expression -> 'a) : Parsetree.expression_desc = - Pexp_letmodule - ( {txt = local_module_name; loc}, - { - pmod_desc = - Pmod_structure - [ - { - pstr_desc = - Pstr_primitive - { - pval_name = {txt = local_fun_name; loc}; - pval_type; - pval_loc = loc; - pval_prim; - pval_attributes; - }; - pstr_loc = loc; - }; - ]; - pmod_loc = loc; - pmod_attributes = []; - }, - cb - { - pexp_desc = - Pexp_ident - {txt = Ldot (Lident local_module_name, local_fun_name); loc}; - pexp_attributes = []; - pexp_loc = loc; - } ) diff --git a/jscomp/frontend/ast_external_mk.mli b/jscomp/frontend/ast_external_mk.mli deleted file mode 100644 index 550bb3a..0000000 --- a/jscomp/frontend/ast_external_mk.mli +++ /dev/null @@ -1,64 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val local_external_apply : - Location.t -> - ?pval_attributes:Parsetree.attributes -> - pval_prim:string list -> - pval_type:Parsetree.core_type -> - ?local_module_name:string -> - ?local_fun_name:string -> - Parsetree.expression list -> - Parsetree.expression_desc -(** - [local_module loc ~pval_prim ~pval_type args] - generate such code - {[ - let module J = struct - external unsafe_expr : pval_type = pval_prim - end in - J.unssafe_expr args - ]} -*) - -val local_external_obj : - Location.t -> - ?pval_attributes:Parsetree.attributes -> - pval_prim:string list -> - pval_type:Parsetree.core_type -> - ?local_module_name:string -> - ?local_fun_name:string -> - (string * Parsetree.expression) list -> - (* [ (label, exp )]*) - Parsetree.expression_desc - -val local_extern_cont_to_obj : - Location.t -> - ?pval_attributes:Parsetree.attributes -> - pval_prim:string list -> - pval_type:Parsetree.core_type -> - ?local_module_name:string -> - ?local_fun_name:string -> - (Parsetree.expression -> Parsetree.expression) -> - Parsetree.expression_desc diff --git a/jscomp/frontend/ast_external_process.ml b/jscomp/frontend/ast_external_process.ml deleted file mode 100644 index c00596b..0000000 --- a/jscomp/frontend/ast_external_process.ml +++ /dev/null @@ -1,1107 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@warning "+9"] -(* record pattern match complete checker*) - -let rec variant_can_unwrap_aux (row_fields : Parsetree.row_field list) : bool = - match row_fields with - | [] -> true - | Rtag (_, _, false, [_]) :: rest -> variant_can_unwrap_aux rest - | _ :: _ -> false - -let variant_unwrap (row_fields : Parsetree.row_field list) : bool = - match row_fields with - | [] -> false (* impossible syntax *) - | xs -> variant_can_unwrap_aux xs - -(* - TODO: [nolabel] is only used once turn Nothing into Unit, refactor later -*) -let spec_of_ptyp (nolabel : bool) (ptyp : Parsetree.core_type) : - External_arg_spec.attr = - let ptyp_desc = ptyp.ptyp_desc in - match - Ast_attributes.iter_process_bs_string_int_unwrap_uncurry - ptyp.ptyp_attributes - with - | `String -> ( - match ptyp_desc with - | Ptyp_variant (row_fields, Closed, None) -> - Ast_polyvar.map_row_fields_into_strings ptyp.ptyp_loc row_fields - | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_string_type) - | `Ignore -> Ignore - | `Int -> ( - match ptyp_desc with - | Ptyp_variant (row_fields, Closed, None) -> - let int_lists = - Ast_polyvar.map_row_fields_into_ints ptyp.ptyp_loc row_fields - in - Int int_lists - | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_int_type) - | `Unwrap -> ( - match ptyp_desc with - | Ptyp_variant (row_fields, Closed, _) when variant_unwrap row_fields -> - Unwrap - (* Unwrap attribute can only be attached to things like `[a of a0 | b of b0]` *) - | _ -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_bs_unwrap_type) - | `Uncurry opt_arity -> ( - let real_arity = - if Ast_uncurried.coreTypeIsUncurriedFun ptyp then - let arity, _ = Ast_uncurried.coreTypeExtractUncurriedFun ptyp in - Some arity - else Ast_core_type.get_uncurry_arity ptyp - in - match (opt_arity, real_arity) with - | Some arity, None -> Fn_uncurry_arity arity - | None, None -> Bs_syntaxerr.err ptyp.ptyp_loc Canot_infer_arity_by_syntax - | None, Some arity -> Fn_uncurry_arity arity - | Some arity, Some n -> - if n <> arity then - Bs_syntaxerr.err ptyp.ptyp_loc (Inconsistent_arity (arity, n)) - else Fn_uncurry_arity arity) - | `Nothing -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "unit"; _}, []) -> - if nolabel then Extern_unit else Nothing - | _ -> Nothing) - -(* is_optional = false -*) -let refine_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) : - External_arg_spec.attr = - if ptyp.ptyp_desc = Ptyp_any then - let ptyp_attrs = ptyp.ptyp_attributes in - let payload = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in - match payload with - | None -> spec_of_ptyp nolabel ptyp - | Some cst -> ( - (* (_[@as ])*) - (* when ppx start dropping attributes - we should warn, there is a trade off whether - we should warn dropped non bs attribute or not - *) - Bs_ast_invariant.warn_discarded_unused_attributes ptyp_attrs; - match cst with - | Int i -> - (* This type is used in obj only to construct obj type*) - Arg_cst (External_arg_spec.cst_int i) - | Str (i, delim) -> Arg_cst (External_arg_spec.cst_string i delim)) - else (* ([`a|`b] [@string]) *) - spec_of_ptyp nolabel ptyp - -let refine_obj_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) : - External_arg_spec.attr = - if ptyp.ptyp_desc = Ptyp_any then ( - let ptyp_attrs = ptyp.ptyp_attributes in - let payload = Ast_attributes.iter_process_bs_string_or_int_as ptyp_attrs in - (* when ppx start dropping attributes - we should warn, there is a trade off whether - we should warn dropped non bs attribute or not - *) - Bs_ast_invariant.warn_discarded_unused_attributes ptyp_attrs; - match payload with - | None -> Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external - | Some (Int i) -> - (* @as(24) *) - (* This type is used in obj only to construct obj type *) - Arg_cst (External_arg_spec.cst_int i) - | Some (Str (s, delim)) -> - (* @as("foo") *) - Arg_cst (External_arg_spec.cst_string s delim)) - else (* ([`a|`b] [@string]) *) - spec_of_ptyp nolabel ptyp - -(** Given the type of argument, process its [bs.] attribute and new type, - The new type is currently used to reconstruct the external type - and result type in [@@obj] - They are not the same though, for example - {[ - external f : hi:([ `hi | `lo ] [@string]) -> unit -> _ = "" [@@obj] - ]} - The result type would be [ hi:string ] -*) -let get_opt_arg_type ~(nolabel : bool) (ptyp : Ast_core_type.t) : - External_arg_spec.attr = - if ptyp.ptyp_desc = Ptyp_any then - (* (_[@as ])*) - (* extenral f : ?x:_ -> y:int -> _ = "" [@@obj] is not allowed *) - Bs_syntaxerr.err ptyp.ptyp_loc Invalid_underscore_type_in_external; - (* ([`a|`b] [@@string]) *) - spec_of_ptyp nolabel ptyp - -(** - [@@module "react"] - [@@module "react"] - --- - [@@module "@" "react"] - [@@module "@" "react"] - - They should have the same module name - - TODO: we should emit an warning if we bind - two external files to the same module name -*) -type source = Payload | External - -type bundle_source = {name: string; source: source} - -type external_desc = { - val_name: bundle_source option; - external_module_name: External_ffi_types.external_module_name option; - module_as_val: External_ffi_types.external_module_name option; - val_send: bundle_source option; - splice: bool; - (* mutable *) - scopes: string list; - set_index: bool; - (* mutable *) - get_index: bool; - new_name: bundle_source option; - call_name: bundle_source option; - set_name: bundle_source option; - get_name: bundle_source option; - mk_obj: bool; - return_wrapper: External_ffi_types.return_wrapper; - tagged_template: bool; -} - -let init_st = - { - val_name = None; - external_module_name = None; - module_as_val = None; - val_send = None; - splice = false; - scopes = []; - set_index = false; - get_index = false; - new_name = None; - call_name = None; - set_name = None; - get_name = None; - mk_obj = false; - return_wrapper = Return_unset; - tagged_template = false; - } - -let return_wrapper loc (txt : string) : External_ffi_types.return_wrapper = - match txt with - | "undefined_to_opt" -> Return_undefined_to_opt - | "null_to_opt" -> Return_null_to_opt - | "nullable" | "null_undefined_to_opt" -> Return_null_undefined_to_opt - | "identity" -> Return_identity - | _ -> Bs_syntaxerr.err loc Not_supported_directive_in_bs_return - -exception Not_handled_external_attribute - -(* The processed attributes will be dropped *) -let parse_external_attributes (no_arguments : bool) (prim_name_check : string) - (prim_name_or_pval_prim : bundle_source) - (prim_attributes : Ast_attributes.t) : Ast_attributes.t * external_desc = - (* shared by `[@@val]`, `[@@send]`, - `[@@set]`, `[@@get]` , `[@@new]` - `[@@bs.send.pipe]` does not use it - *) - let name_from_payload_or_prim ~loc (payload : Parsetree.payload) : - bundle_source = - match payload with - | PStr [] -> prim_name_or_pval_prim - (* It is okay to have [@@val] without payload *) - | _ -> ( - match Ast_payload.is_single_string payload with - | Some (val_name, _) -> {name = val_name; source = Payload} - | None -> Location.raise_errorf ~loc "Invalid payload") - in - - Ext_list.fold_left prim_attributes ([], init_st) - (fun (attrs, st) (({txt; loc}, payload) as attr) -> - if txt = Literals.gentype_import1 || txt = Literals.gentype_import2 then - let bundle = - "./" - ^ Ext_filename.new_extension - (Filename.basename !Location.input_name) - ".gen" - in - ( attr :: attrs, - { - st with - external_module_name = - Some - { - bundle; - module_bind_name = Phint_nothing; - import_attributes = None; - }; - } ) - else - let action () = - match txt with - | "bs.val" | "val" -> - if no_arguments then - {st with val_name = Some (name_from_payload_or_prim ~loc payload)} - else - { - st with - call_name = Some (name_from_payload_or_prim ~loc payload); - } - | "bs.module" | "module" -> ( - match payload with - | PStr - [ - { - pstr_desc = - Pstr_eval - ({pexp_loc; pexp_desc = Pexp_record (fields, _); _}, _); - _; - }; - ] -> ( - let fromName = ref None in - let with_ = ref None in - fields - |> List.iter - (fun - ((l, exp) : - Longident.t Location.loc * Parsetree.expression) - -> - match (l, exp.pexp_desc) with - | ( {txt = Lident "from"; _}, - Pexp_constant (Pconst_string (s, _)) ) -> - fromName := Some s - | {txt = Lident "with"; _}, Pexp_record (fields, _) -> - with_ := Some fields - | _ -> ()); - match (!fromName, !with_) with - | None, _ -> - Location.raise_errorf ~loc:pexp_loc - "@module annotations with import attributes must have a \ - \"from\" field. This \"from\" field should point to the JS \ - module to import, just like the string payload to @module \ - normally does." - | Some _, None -> - Location.raise_errorf ~loc:pexp_loc - "@module annotations with import attributes must have a \ - \"with\" field. This \"with\" field should hold a record of \ - the import attributes you want applied to the import." - | Some fromName, Some withFields -> - let importAttributesFromRecord = - withFields - |> List.filter_map - (fun - ((l, exp) : - Longident.t Location.loc * Parsetree.expression) - -> - match exp.pexp_desc with - | Pexp_constant (Pconst_string (s, _)) -> ( - match l.txt with - | Longident.Lident "type_" -> Some ("type", s) - | Longident.Lident txt -> Some (txt, s) - | _ -> - Location.raise_errorf ~loc:exp.pexp_loc - "Field must be a regular key.") - | _ -> - Location.raise_errorf ~loc:exp.pexp_loc - "Only string values are allowed here.") - in - let import_attributes = - Hashtbl.create (List.length importAttributesFromRecord) - in - importAttributesFromRecord - |> List.iter (fun (key, value) -> - Hashtbl.replace import_attributes key value); - { - st with - external_module_name = - Some - { - bundle = fromName; - module_bind_name = Phint_nothing; - import_attributes = Some import_attributes; - }; - }) - | _ -> ( - match Ast_payload.assert_strings loc payload with - | [bundle] -> - { - st with - external_module_name = - Some - { - bundle; - module_bind_name = Phint_nothing; - import_attributes = None; - }; - } - | [bundle; bind_name] -> - { - st with - external_module_name = - Some - { - bundle; - module_bind_name = Phint_name bind_name; - import_attributes = None; - }; - } - | [] -> - { - st with - module_as_val = - Some - { - bundle = prim_name_or_pval_prim.name; - module_bind_name = Phint_nothing; - import_attributes = None; - }; - } - | _ -> Bs_syntaxerr.err loc Illegal_attribute)) - | "bs.scope" | "scope" -> ( - match Ast_payload.assert_strings loc payload with - | [] -> Bs_syntaxerr.err loc Illegal_attribute - (* We need err on empty scope, so we can tell the difference - between unset/set - *) - | scopes -> {st with scopes}) - | "taggedTemplate" -> {st with splice = true; tagged_template = true} - | "bs.splice" | "bs.variadic" | "variadic" -> {st with splice = true} - | "bs.send" | "send" -> - {st with val_send = Some (name_from_payload_or_prim ~loc payload)} - | "bs.set" | "set" -> - {st with set_name = Some (name_from_payload_or_prim ~loc payload)} - | "bs.get" | "get" -> - {st with get_name = Some (name_from_payload_or_prim ~loc payload)} - | "bs.new" | "new" -> - {st with new_name = Some (name_from_payload_or_prim ~loc payload)} - | "bs.set_index" | "set_index" -> - if String.length prim_name_check <> 0 then - Location.raise_errorf ~loc - "%@set_index this particular external's name needs to be a \ - placeholder empty string"; - {st with set_index = true} - | "bs.get_index" | "get_index" -> - if String.length prim_name_check <> 0 then - Location.raise_errorf ~loc - "%@get_index this particular external's name needs to be a \ - placeholder empty string"; - {st with get_index = true} - | "bs.obj" | "obj" -> {st with mk_obj = true} - | "bs.return" | "return" -> ( - let actions = Ast_payload.ident_or_record_as_config loc payload in - match actions with - | [({txt; _}, None)] -> - {st with return_wrapper = return_wrapper loc txt} - | _ -> Bs_syntaxerr.err loc Not_supported_directive_in_bs_return) - | _ -> raise_notrace Not_handled_external_attribute - in - try (attrs, action ()) - with Not_handled_external_attribute -> (attr :: attrs, st)) - -let has_bs_uncurry (attrs : Ast_attributes.t) = - Ext_list.exists_fst attrs (fun {txt; loc = _} -> - txt = "bs.uncurry" || txt = "uncurry") - -let check_return_wrapper loc (wrapper : External_ffi_types.return_wrapper) - result_type = - match wrapper with - | Return_identity -> wrapper - | Return_unset -> - if Ast_core_type.is_unit result_type then Return_replaced_with_unit - else wrapper - | Return_undefined_to_opt | Return_null_to_opt | Return_null_undefined_to_opt - -> - if Ast_core_type.is_user_option result_type then wrapper - else Bs_syntaxerr.err loc Expect_opt_in_bs_return_to_opt - | Return_replaced_with_unit -> assert false -(* Not going to happen from user input*) - -type response = { - pval_type: Parsetree.core_type; - pval_prim: string list; - pval_attributes: Parsetree.attributes; - no_inline_cross_module: bool; -} - -let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) - (arg_types_ty : Ast_core_type.param_type list) - (result_type : Ast_core_type.t) : Parsetree.core_type * External_ffi_types.t - = - match st with - | { - val_name = None; - external_module_name = None; - module_as_val = None; - val_send = None; - splice = false; - new_name = None; - call_name = None; - set_name = None; - get_name = None; - get_index = false; - return_wrapper = Return_unset; - tagged_template = _; - set_index = false; - mk_obj = _; - scopes = - [] - (* wrapper does not work with @obj - TODO: better error message *); - } -> - if String.length prim_name <> 0 then - Location.raise_errorf ~loc - "%@obj expect external names to be empty string"; - let ( arg_kinds, - new_arg_types_ty, - (result_types : Parsetree.object_field list) ) = - Ext_list.fold_right arg_types_ty ([], [], []) - (fun - param_type - (arg_labels, (arg_types : Ast_core_type.param_type list), result_types) - -> - let arg_label = param_type.label in - let loc = param_type.loc in - let ty = param_type.ty in - let new_arg_label, new_arg_types, output_tys = - match arg_label with - | Nolabel -> ( - match ty.ptyp_desc with - | Ptyp_constr ({txt = Lident "unit"; _}, []) -> - ( External_arg_spec.empty_kind Extern_unit, - param_type :: arg_types, - result_types ) - | _ -> - Location.raise_errorf ~loc - "expect label, optional, or unit here") - | Labelled label -> ( - let fieldName = - match - Ast_attributes.iter_process_bs_string_as param_type.attr - with - | Some alias -> alias - | None -> label - in - let obj_arg_type = refine_obj_arg_type ~nolabel:false ty in - match obj_arg_type with - | Ignore -> - ( External_arg_spec.empty_kind obj_arg_type, - param_type :: arg_types, - result_types ) - | Arg_cst _ -> - ( { - obj_arg_label = External_arg_spec.obj_label fieldName; - obj_arg_type; - }, - arg_types, - (* ignored in [arg_types], reserved in [result_types] *) - result_types ) - | Nothing -> - ( { - obj_arg_label = External_arg_spec.obj_label fieldName; - obj_arg_type; - }, - param_type :: arg_types, - Parsetree.Otag ({Asttypes.txt = fieldName; loc}, [], ty) - :: result_types ) - | Int _ -> - ( { - obj_arg_label = External_arg_spec.obj_label fieldName; - obj_arg_type; - }, - param_type :: arg_types, - Otag - ( {Asttypes.txt = fieldName; loc}, - [], - Ast_literal.type_int ~loc () ) - :: result_types ) - | Poly_var_string _ -> - ( { - obj_arg_label = External_arg_spec.obj_label fieldName; - obj_arg_type; - }, - param_type :: arg_types, - Otag - ( {Asttypes.txt = fieldName; loc}, - [], - Ast_literal.type_string ~loc () ) - :: result_types ) - | Fn_uncurry_arity _ -> - Location.raise_errorf ~loc - "The combination of %@obj, %@uncurry is not supported yet" - | Extern_unit -> assert false - | Poly_var _ -> - Location.raise_errorf ~loc - "%@obj label %s does not support such arg type" label - | Unwrap -> - Location.raise_errorf ~loc - "%@obj label %s does not support %@unwrap arguments" label) - | Optional label -> ( - let fieldName = - match - Ast_attributes.iter_process_bs_string_as param_type.attr - with - | Some alias -> alias - | None -> label - in - let obj_arg_type = get_opt_arg_type ~nolabel:false ty in - match obj_arg_type with - | Ignore -> - ( External_arg_spec.empty_kind obj_arg_type, - param_type :: arg_types, - result_types ) - | Nothing -> - let for_sure_not_nested = - match ty.ptyp_desc with - | Ptyp_constr ({txt = Lident txt; _}, []) -> - Ast_core_type.is_builtin_rank0_type txt - | _ -> false - in - ( { - obj_arg_label = - External_arg_spec.optional for_sure_not_nested fieldName; - obj_arg_type; - }, - param_type :: arg_types, - Parsetree.Otag - ( {Asttypes.txt = fieldName; loc}, - [], - Ast_comb.to_undefined_type loc ty ) - :: result_types ) - | Int _ -> - ( { - obj_arg_label = External_arg_spec.optional true fieldName; - obj_arg_type; - }, - param_type :: arg_types, - Otag - ( {Asttypes.txt = fieldName; loc}, - [], - Ast_comb.to_undefined_type loc - @@ Ast_literal.type_int ~loc () ) - :: result_types ) - | Poly_var_string _ -> - ( { - obj_arg_label = External_arg_spec.optional true fieldName; - obj_arg_type; - }, - param_type :: arg_types, - Otag - ( {Asttypes.txt = fieldName; loc}, - [], - Ast_comb.to_undefined_type loc - @@ Ast_literal.type_string ~loc () ) - :: result_types ) - | Arg_cst _ -> - Location.raise_errorf ~loc - "%@as is not supported with optional yet" - | Fn_uncurry_arity _ -> - Location.raise_errorf ~loc - "The combination of %@obj, %@uncurry is not supported yet" - | Extern_unit -> assert false - | Poly_var _ -> - Location.raise_errorf ~loc - "%@obj label %s does not support such arg type" label - | Unwrap -> - Location.raise_errorf ~loc - "%@obj label %s does not support %@unwrap arguments" label) - in - (new_arg_label :: arg_labels, new_arg_types, output_tys)) - in - - let result = - if result_type.ptyp_desc = Ptyp_any then - Ast_core_type.make_obj ~loc result_types - else result_type - (* TODO: do we need do some error checking here *) - (* result type can not be labeled *) - in - ( Ast_core_type.mk_fn_type new_arg_types_ty result, - External_ffi_types.ffi_obj_create arg_kinds ) - | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with %@obj" - -let external_desc_of_non_obj (loc : Location.t) (st : external_desc) - (prim_name_or_pval_prim : bundle_source) (arg_type_specs_length : int) - arg_types_ty (arg_type_specs : External_arg_spec.params) : - External_ffi_types.external_spec = - match st with - | { - set_index = true; - val_name = None; - external_module_name = None; - module_as_val = None; - val_send = None; - splice = false; - scopes; - get_index = false; - new_name = None; - call_name = None; - set_name = None; - get_name = None; - return_wrapper = _; - mk_obj = _; - tagged_template = _; - } -> - if arg_type_specs_length = 3 then - Js_set_index {js_set_index_scopes = scopes} - else - Location.raise_errorf ~loc - "Ill defined attribute %@set_index (arity of 3)" - | {set_index = true; _} -> - Bs_syntaxerr.err loc - (Conflict_ffi_attribute "Attribute found that conflicts with %@set_index") - | { - get_index = true; - val_name = None; - external_module_name = None; - module_as_val = None; - val_send = None; - splice = false; - scopes; - new_name = None; - call_name = None; - set_name = None; - get_name = None; - set_index = false; - mk_obj = _; - return_wrapper = _; - tagged_template = _; - } -> - if arg_type_specs_length = 2 then - Js_get_index {js_get_index_scopes = scopes} - else - Location.raise_errorf ~loc - "Ill defined attribute %@get_index (arity expected 2 : while %d)" - arg_type_specs_length - | {get_index = true; _} -> - Bs_syntaxerr.err loc - (Conflict_ffi_attribute "Attribute found that conflicts with %@get_index") - | { - module_as_val = Some external_module_name; - get_index = false; - val_name; - new_name; - external_module_name = None; - val_send = None; - scopes = []; - (* module as var does not need scopes *) - splice; - call_name = None; - set_name = None; - get_name = None; - set_index = false; - return_wrapper = _; - mk_obj = _; - tagged_template = _; - } -> ( - match (arg_types_ty, new_name, val_name) with - | [], None, _ -> Js_module_as_var external_module_name - | _, None, _ -> Js_module_as_fn {splice; external_module_name} - | _, Some _, Some _ -> - Bs_syntaxerr.err loc - (Conflict_ffi_attribute "Attribute found that conflicts with @module.") - | _, Some {source = External; name = _}, None -> - Js_module_as_class external_module_name - | _, Some {source = Payload; name = _}, None -> - Location.raise_errorf ~loc - "Incorrect FFI attribute found: (%@new should not carry a payload here)" - ) - | {module_as_val = Some _; get_index; val_send; _} -> - let reason = - match (get_index, val_send) with - | true, _ -> - "@module is for imports from a module, @get_index does not need import \ - a module " - | _, Some _ -> - "@module is for imports from a module, @send does not need import a \ - module " - | _ -> "Attribute found that conflicts with @module." - in - Bs_syntaxerr.err loc (Conflict_ffi_attribute reason) - | { - get_name = None; - val_name = None; - call_name = None; - module_as_val = None; - set_index = false; - get_index = false; - val_send = None; - new_name = None; - set_name = None; - external_module_name = None; - splice; - scopes; - mk_obj = _; - (* mk_obj is always false *) - return_wrapper = _; - tagged_template; - } -> - let name = prim_name_or_pval_prim.name in - if arg_type_specs_length = 0 then - (* - {[ - external ff : int -> int [@bs] = "" [@@module "xx"] - ]} - FIXME: splice is not supported here - *) - Js_var {name; external_module_name = None; scopes} - else - Js_call - {splice; name; external_module_name = None; scopes; tagged_template} - | { - call_name = Some {name; source = _}; - splice; - scopes; - external_module_name; - val_name = None; - module_as_val = None; - val_send = None; - set_index = false; - get_index = false; - new_name = None; - set_name = None; - get_name = None; - mk_obj = _; - return_wrapper = _; - tagged_template; - } -> - if arg_type_specs_length = 0 then - (* - {[ - external ff : int -> int = "" [@@module "xx"] - ]} - *) - Js_var {name; external_module_name; scopes} - (*FIXME: splice is not supported here *) - else Js_call {splice; name; external_module_name; scopes; tagged_template} - | {call_name = Some _; _} -> - Bs_syntaxerr.err loc - (Conflict_ffi_attribute "Attribute found that conflicts with %@val") - | { - val_name = Some {name; source = _}; - external_module_name; - call_name = None; - module_as_val = None; - val_send = None; - set_index = false; - get_index = false; - new_name = None; - set_name = None; - get_name = None; - mk_obj = _; - return_wrapper = _; - splice = false; - scopes; - tagged_template = _; - } -> - (* - if no_arguments --> - {[ - external ff : int = "" [@@val] - ]} - *) - Js_var {name; external_module_name; scopes} - | {val_name = Some _; _} -> - Bs_syntaxerr.err loc - (Conflict_ffi_attribute "Attribute found that conflicts with %@val") - | { - splice; - scopes; - external_module_name = Some _ as external_module_name; - val_name = None; - call_name = None; - module_as_val = None; - val_send = None; - set_index = false; - get_index = false; - new_name = None; - set_name = None; - get_name = None; - mk_obj = _; - return_wrapper = _; - tagged_template; - } -> - let name = prim_name_or_pval_prim.name in - if arg_type_specs_length = 0 then - (* - {[ - external ff : int = "" [@@module "xx"] - ]} - *) - Js_var {name; external_module_name; scopes} - else Js_call {splice; name; external_module_name; scopes; tagged_template} - | { - val_send = Some {name; source = _}; - splice; - scopes; - val_name = None; - call_name = None; - module_as_val = None; - set_index = false; - get_index = false; - new_name = None; - set_name = None; - get_name = None; - external_module_name = None; - mk_obj = _; - return_wrapper = _; - tagged_template = _; - } -> ( - (* PR #2162 - since when we assemble arguments the first argument in - [@@send] is ignored - *) - match arg_type_specs with - | [] -> - Location.raise_errorf ~loc - "Ill defined attribute %@send(the external needs to be a regular \ - function call with at least one argument)" - | {arg_type = Arg_cst _; arg_label = _} :: _ -> - Location.raise_errorf ~loc - "Ill defined attribute %@send(first argument can't be const)" - | _ :: _ -> Js_send {splice; name; js_send_scopes = scopes}) - | {val_send = Some _; _} -> - Location.raise_errorf ~loc - "You used a FFI attribute that can't be used with %@send" - | { - new_name = Some {name; source = _}; - external_module_name; - val_name = None; - call_name = None; - module_as_val = None; - set_index = false; - get_index = false; - val_send = None; - set_name = None; - get_name = None; - splice; - scopes; - mk_obj = _; - return_wrapper = _; - tagged_template = _; - } -> - Js_new {name; external_module_name; splice; scopes} - | {new_name = Some _; _} -> - Bs_syntaxerr.err loc - (Conflict_ffi_attribute "Attribute found that conflicts with %@new") - | { - set_name = Some {name; source = _}; - val_name = None; - call_name = None; - module_as_val = None; - set_index = false; - get_index = false; - val_send = None; - new_name = None; - get_name = None; - external_module_name = None; - splice = false; - mk_obj = _; - return_wrapper = _; - scopes; - tagged_template = _; - } -> - if arg_type_specs_length = 2 then - Js_set {js_set_scopes = scopes; js_set_name = name} - else - Location.raise_errorf ~loc - "Ill defined attribute %@set (two args required)" - | {set_name = Some _; _} -> - Location.raise_errorf ~loc "conflict attributes found with %@set" - | { - get_name = Some {name; source = _}; - val_name = None; - call_name = None; - module_as_val = None; - set_index = false; - get_index = false; - val_send = None; - new_name = None; - set_name = None; - external_module_name = None; - splice = false; - mk_obj = _; - return_wrapper = _; - scopes; - tagged_template = _; - } -> - if arg_type_specs_length = 1 then - Js_get {js_get_name = name; js_get_scopes = scopes} - else - Location.raise_errorf ~loc - "Ill defined attribute %@bs.get (only one argument)" - | {get_name = Some _; _} -> - Location.raise_errorf ~loc "Attribute found that conflicts with %@bs.get" - -(** Note that the passed [type_annotation] is already processed by visitor pattern before*) -let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) - (prim_attributes : Ast_attributes.t) (prim_name : string) : - Parsetree.core_type * External_ffi_types.t * Parsetree.attributes * bool = - (* sanity check here - {[ int -> int -> (int -> int -> int [@uncurry])]} - It does not make sense - *) - if has_bs_uncurry type_annotation.ptyp_attributes then - Location.raise_errorf ~loc - "%@uncurry can not be applied to the whole definition"; - let prim_name_with_source = {name = prim_name; source = External} in - let type_annotation, build_uncurried_type = - match type_annotation.ptyp_desc with - | Ptyp_constr (({txt = Lident "function$"; _} as lid), [t; arity_]) -> - ( t, - fun ~arity x -> - let tArity = - match arity with - | Some arity -> Ast_uncurried.arityType ~loc arity - | None -> arity_ - in - {x with Parsetree.ptyp_desc = Ptyp_constr (lid, [x; tArity])} ) - | _ -> (type_annotation, fun ~arity:_ x -> x) - in - let result_type, arg_types_ty = - (* Note this assumes external type is syntatic (no abstraction)*) - Ast_core_type.list_of_arrow type_annotation - in - if has_bs_uncurry result_type.ptyp_attributes then - Location.raise_errorf ~loc:result_type.ptyp_loc - "%@uncurry can not be applied to tailed position"; - let no_arguments = arg_types_ty = [] in - let unused_attrs, external_desc = - parse_external_attributes no_arguments prim_name prim_name_with_source - prim_attributes - in - if external_desc.mk_obj then - (* warn unused attributes here ? *) - let new_type, spec = - process_obj loc external_desc prim_name arg_types_ty result_type - in - (build_uncurried_type ~arity:None new_type, spec, unused_attrs, false) - else - let splice = external_desc.splice in - let arg_type_specs, new_arg_types_ty, arg_type_specs_length = - Ext_list.fold_right arg_types_ty - (([], [], 0) - : External_arg_spec.params * Ast_core_type.param_type list * int) - (fun param_type (arg_type_specs, arg_types, i) -> - let arg_label = param_type.label in - let ty = param_type.ty in - (if i = 0 && splice then - match arg_label with - | Optional _ -> - Location.raise_errorf ~loc - "%@variadic expect the last type to be a non optional" - | Labelled _ | Nolabel -> ( - if ty.ptyp_desc = Ptyp_any then - Location.raise_errorf ~loc - "%@variadic expect the last type to be an array"; - if spec_of_ptyp true ty <> Nothing then - Location.raise_errorf ~loc - "%@variadic expect the last type to be an array"; - match ty.ptyp_desc with - | Ptyp_constr ({txt = Lident "array"; _}, [_]) -> () - | _ -> - Location.raise_errorf ~loc - "%@variadic expect the last type to be an array")); - let ( (arg_label : External_arg_spec.label_noname), - arg_type, - new_arg_types ) = - match arg_label with - | Optional s -> ( - let arg_type = get_opt_arg_type ~nolabel:false ty in - match arg_type with - | Poly_var _ -> - (* ?x:([`x of int ] [@string]) does not make sense *) - Location.raise_errorf ~loc - "%@string does not work with optional when it has arities in \ - label %s" - s - | _ -> (Arg_optional, arg_type, param_type :: arg_types)) - | Labelled _ -> ( - let arg_type = refine_arg_type ~nolabel:false ty in - ( Arg_label, - arg_type, - match arg_type with - | Arg_cst _ -> arg_types - | _ -> param_type :: arg_types )) - | Nolabel -> ( - let arg_type = refine_arg_type ~nolabel:true ty in - ( Arg_empty, - arg_type, - match arg_type with - | Arg_cst _ -> arg_types - | _ -> param_type :: arg_types )) - in - ( {arg_label; arg_type} :: arg_type_specs, - new_arg_types, - if arg_type = Ignore then i else i + 1 )) - in - let ffi : External_ffi_types.external_spec = - external_desc_of_non_obj loc external_desc prim_name_with_source - arg_type_specs_length arg_types_ty arg_type_specs - in - let relative = External_ffi_types.check_ffi ~loc ffi in - (* result type can not be labeled *) - (* currently we don't process attributes of - return type, in the future we may *) - let return_wrapper = - check_return_wrapper loc external_desc.return_wrapper result_type - in - let fn_type = Ast_core_type.mk_fn_type new_arg_types_ty result_type in - ( build_uncurried_type ~arity:(Some (List.length new_arg_types_ty)) fn_type, - External_ffi_types.ffi_bs arg_type_specs return_wrapper ffi, - unused_attrs, - relative ) - -let encode_attributes_as_string (pval_loc : Location.t) (typ : Ast_core_type.t) - (attrs : Ast_attributes.t) (prim_name : string) : response = - let pval_type, ffi, pval_attributes, no_inline_cross_module = - handle_attributes pval_loc typ attrs prim_name - in - { - pval_type; - pval_prim = [prim_name; External_ffi_types.to_string ffi]; - pval_attributes; - no_inline_cross_module; - } - -let pval_prim_of_labels (labels : string Asttypes.loc list) = - let arg_kinds = - Ext_list.fold_right labels - ([] : External_arg_spec.obj_params) - (fun p arg_kinds -> - let obj_arg_label = External_arg_spec.obj_label p.txt in - {obj_arg_type = Nothing; obj_arg_label} :: arg_kinds) - in - External_ffi_types.ffi_obj_as_prims arg_kinds - -let pval_prim_of_option_labels (labels : (bool * string Asttypes.loc) list) - (ends_with_unit : bool) = - let arg_kinds = - Ext_list.fold_right labels - (if ends_with_unit then [External_arg_spec.empty_kind Extern_unit] else []) - (fun (is_option, p) arg_kinds -> - let label_name = p.txt in - let obj_arg_label = - if is_option then External_arg_spec.optional false label_name - else External_arg_spec.obj_label label_name - in - {obj_arg_type = Nothing; obj_arg_label} :: arg_kinds) - in - External_ffi_types.ffi_obj_as_prims arg_kinds diff --git a/jscomp/frontend/ast_external_process.mli b/jscomp/frontend/ast_external_process.mli deleted file mode 100644 index 33c85f8..0000000 --- a/jscomp/frontend/ast_external_process.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type response = { - pval_type: Parsetree.core_type; - pval_prim: string list; - pval_attributes: Parsetree.attributes; - no_inline_cross_module: bool; -} - -val encode_attributes_as_string : - Bs_loc.t -> Ast_core_type.t -> Ast_attributes.t -> string -> response -(** - [encode_attributes_as_string - loc pval_name.txt pval_type pval_attributes pval_prim] - [pval_name.txt] is the name of identifier - [pval_prim] is the name of string literal - - return value is of [pval_type, pval_prims, new_attrs] -*) - -val pval_prim_of_labels : string Asttypes.loc list -> string list -(** [pval_prim_of_labels labels] - return [pval_prims] for FFI, it is specialized for - external object which is used in - {[ [%obj { x = 2; y = 1} ] ]} -*) - -val pval_prim_of_option_labels : - (bool * string Asttypes.loc) list -> bool -> string list diff --git a/jscomp/frontend/ast_literal.ml b/jscomp/frontend/ast_literal.ml deleted file mode 100644 index 41a641e..0000000 --- a/jscomp/frontend/ast_literal.ml +++ /dev/null @@ -1,169 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper - -let predef_prefix_ident : Longident.t = Lident "*predef*" - -let predef_option : Longident.t = Ldot (predef_prefix_ident, "option") - -let predef_some : Longident.t = Ldot (predef_prefix_ident, "Some") - -let predef_none : Longident.t = Ldot (predef_prefix_ident, "None") - -module Lid = struct - type t = Longident.t - - let val_unit : t = Lident "()" - - let type_unit : t = Lident "unit" - - let type_string : t = Lident "string" - - let type_int : t = Lident "int" (* use *predef* *) - - let type_bigint : t = Lident "bigint" (* use *predef* *) - - let type_exn : t = Lident "exn" (* use *predef* *) - - let type_bool : t = Lident "bool" (* use *predef* *) - - (* TODO should be renamed in to {!Js.fn} *) - (* TODO should be moved into {!Js.t} Later *) - let js_internal : t = Ldot (Lident "Js", "Internal") - - let js_internal_full_apply : t = Ldot (js_internal, "opaqueFullApply") - - let opaque : t = Ldot (js_internal, "opaque") - - let js_oo : t = Lident "Js_OO" - - let js_meth_callback : t = Ldot (js_oo, "Callback") - - let ignore_id : t = Ldot (Lident "Pervasives", "ignore") - - let hidden_field n : t = Lident ("I" ^ n) - - let js_null : t = Ldot (Lident "Js", "null") - - let js_undefined : t = Ldot (Lident "Js", "undefined") - - let js_null_undefined : t = Ldot (Lident "Js", "null_undefined") - - let js_re_id : t = Ldot (Ldot (Lident "Js", "Re"), "t") -end - -module No_loc = struct - let loc = Location.none - - let val_unit = Ast_helper.Exp.construct {txt = Lid.val_unit; loc} None - - let type_unit = - Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) - - let type_exn = - Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) - - let type_int = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_int; loc}, [])) - - let type_bigint = - Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_bigint; loc}, [])) - - let type_string = - Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_string; loc}, [])) - - let type_bool = - Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_bool; loc}, [])) - - let type_any = Ast_helper.Typ.any () - - let pat_unit = Pat.construct {txt = Lid.val_unit; loc} None -end - -type 'a lit = ?loc:Location.t -> unit -> 'a - -type expression_lit = Parsetree.expression lit - -type core_type_lit = Parsetree.core_type lit - -type pattern_lit = Parsetree.pattern lit - -let val_unit ?loc () = - match loc with - | None -> No_loc.val_unit - | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc} None - -let type_unit ?loc () = - match loc with - | None -> No_loc.type_unit - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) - -let type_exn ?loc () = - match loc with - | None -> No_loc.type_exn - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_exn; loc}, [])) - -let type_string ?loc () = - match loc with - | None -> No_loc.type_string - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_string; loc}, [])) - -let type_bool ?loc () = - match loc with - | None -> No_loc.type_bool - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_bool; loc}, [])) - -let type_int ?loc () = - match loc with - | None -> No_loc.type_int - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_int; loc}, [])) - -let type_int64 = - Ast_helper.Typ.mk - (Ptyp_constr ({txt = Lident "int64"; loc = Location.none}, [])) - -let type_float = - Ast_helper.Typ.mk - (Ptyp_constr ({txt = Lident "float"; loc = Location.none}, [])) - -let type_bigint ?loc () = - match loc with - | None -> No_loc.type_bigint - | Some loc -> - Ast_helper.Typ.mk ~loc (Ptyp_constr ({txt = Lid.type_bigint; loc}, [])) - -let type_any ?loc () = - match loc with - | None -> No_loc.type_any - | Some loc -> Ast_helper.Typ.any ~loc () - -let pat_unit ?loc () = - match loc with - | None -> No_loc.pat_unit - | Some loc -> Pat.construct ~loc {txt = Lid.val_unit; loc} None diff --git a/jscomp/frontend/ast_literal.mli b/jscomp/frontend/ast_literal.mli deleted file mode 100644 index e77b025..0000000 --- a/jscomp/frontend/ast_literal.mli +++ /dev/null @@ -1,93 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type 'a lit = ?loc:Location.t -> unit -> 'a - -val predef_option : Longident.t - -val predef_some : Longident.t - -val predef_none : Longident.t - -module Lid : sig - type t = Longident.t - - val val_unit : t - - val type_unit : t - - val type_int : t - - val type_bigint : t - - val js_internal_full_apply : t - - val opaque : t - - val js_oo : t - - val js_meth_callback : t - - val hidden_field : string -> t - - val ignore_id : t - - val js_null : t - - val js_undefined : t - - val js_null_undefined : t - - val js_re_id : t - - val js_internal : t -end - -type expression_lit = Parsetree.expression lit - -type core_type_lit = Parsetree.core_type lit - -type pattern_lit = Parsetree.pattern lit - -val val_unit : expression_lit - -val type_unit : core_type_lit - -val type_exn : core_type_lit - -val type_string : core_type_lit - -val type_bool : core_type_lit - -val type_int : core_type_lit - -val type_int64 : Parsetree.core_type - -val type_float : Parsetree.core_type - -val type_bigint : core_type_lit - -val type_any : core_type_lit - -val pat_unit : pattern_lit diff --git a/jscomp/frontend/ast_open_cxt.ml b/jscomp/frontend/ast_open_cxt.ml deleted file mode 100644 index e9ebd77..0000000 --- a/jscomp/frontend/ast_open_cxt.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* Copyright (C) 2019 - Present Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type loc = Location.t - -type whole = - | Let_open of - (Asttypes.override_flag - * Longident.t Asttypes.loc - * loc - * Parsetree.attributes) - -type t = whole list -type exp = Parsetree.expression -type destruct_output = exp list - -(** - destruct such pattern - {[ A.B.let open C in (a,b)]} -*) -let rec destruct_open_tuple (e : Parsetree.expression) (acc : t) : - (t * destruct_output * _) option = - match e.pexp_desc with - | Pexp_open (flag, lid, cont) -> - destruct_open_tuple cont - (Let_open (flag, lid, e.pexp_loc, e.pexp_attributes) :: acc) - | Pexp_tuple es -> Some (acc, es, e.pexp_attributes) - | _ -> None - -let restore_exp (xs : Parsetree.expression) (qualifiers : t) : - Parsetree.expression = - Ext_list.fold_left qualifiers xs (fun x hole -> - match hole with - | Let_open (flag, lid, loc, attrs) -> - ({ - pexp_desc = Pexp_open (flag, lid, x); - pexp_attributes = attrs; - pexp_loc = loc; - } - : Parsetree.expression)) diff --git a/jscomp/frontend/ast_open_cxt.mli b/jscomp/frontend/ast_open_cxt.mli deleted file mode 100644 index a50ceda..0000000 --- a/jscomp/frontend/ast_open_cxt.mli +++ /dev/null @@ -1,36 +0,0 @@ -(* Copyright (C) 2019 - Present Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type loc = Location.t - -type whole - -type t = whole list - -val restore_exp : Parsetree.expression -> t -> Parsetree.expression - -val destruct_open_tuple : - Parsetree.expression -> - t -> - (t * Parsetree.expression list * Parsetree.attributes) option diff --git a/jscomp/frontend/ast_pat.ml b/jscomp/frontend/ast_pat.ml deleted file mode 100644 index b3789d8..0000000 --- a/jscomp/frontend/ast_pat.ml +++ /dev/null @@ -1,61 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Parsetree.pattern - -let is_unit_cont ~yes ~no (p : t) = - match p with - | {ppat_desc = Ppat_construct ({txt = Lident "()"}, None)} -> yes - | _ -> no - -(** [arity_of_fun pat e] tells the arity of - expression [fun pat -> e] -*) -let arity_of_fun (pat : Parsetree.pattern) (e : Parsetree.expression) = - let rec aux (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_fun (_, _, _, e) -> 1 + aux e (*FIXME error on optional*) - (* | Pexp_fun _ - -> Location.raise_errorf - ~loc:e.pexp_loc "Label is not allowed in JS object" *) - | _ -> 0 - in - is_unit_cont ~yes:0 ~no:1 pat + aux e - -let rec labels_of_fun (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_fun (l, _, _, e) -> l :: labels_of_fun e - | _ -> [] - -let rec is_single_variable_pattern_conservative (p : t) = - match p.ppat_desc with - | Parsetree.Ppat_any -> Some "" - | Parsetree.Ppat_var s -> Some s.txt - | Parsetree.Ppat_alias (p, s) -> - (* Check more complex patterns is needed or not*) - if is_single_variable_pattern_conservative p <> None then Some s.txt - else None - | Parsetree.Ppat_constraint (p, _) -> - is_single_variable_pattern_conservative p - | _ -> None diff --git a/jscomp/frontend/ast_pat.mli b/jscomp/frontend/ast_pat.mli deleted file mode 100644 index 3689c09..0000000 --- a/jscomp/frontend/ast_pat.mli +++ /dev/null @@ -1,35 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type t = Parsetree.pattern - -val is_unit_cont : yes:'a -> no:'a -> t -> 'a - -val arity_of_fun : t -> Parsetree.expression -> int -(** [arity_of_fun pat e] tells the arity of - expression [fun pat -> e]*) - -val labels_of_fun : Parsetree.expression -> Asttypes.arg_label list - -val is_single_variable_pattern_conservative : t -> string option diff --git a/jscomp/frontend/ast_polyvar.ml b/jscomp/frontend/ast_polyvar.ml deleted file mode 100644 index 5d04a5b..0000000 --- a/jscomp/frontend/ast_polyvar.ml +++ /dev/null @@ -1,116 +0,0 @@ -(* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let map_row_fields_into_ints ptyp_loc (row_fields : Parsetree.row_field list) = - let _, acc = - Ext_list.fold_left row_fields (0, []) (fun (i, acc) rtag -> - match rtag with - | Rtag ({txt}, attrs, true, []) -> - let i = - match Ast_attributes.iter_process_bs_int_as attrs with - | Some i -> i - | None -> i - in - (i + 1, (txt, i) :: acc) - | _ -> Bs_syntaxerr.err ptyp_loc Invalid_bs_int_type) - in - List.rev acc - -(** Note this is okay with enums, for variants, - the underlying representation may change due to - unbox -*) -let map_constructor_declarations_into_ints - (row_fields : Parsetree.constructor_declaration list) = - let mark = ref `nothing in - let _, acc = - Ext_list.fold_left row_fields (0, []) (fun (i, acc) rtag -> - let attrs = rtag.pcd_attributes in - match Ast_attributes.iter_process_bs_int_as attrs with - | Some j -> - if j <> i then if i = 0 then mark := `offset j else mark := `complex; - (j + 1, j :: acc) - | None -> (i + 1, i :: acc)) - in - match !mark with - | `nothing -> `Offset 0 - | `offset j -> `Offset j - | `complex -> `New (List.rev acc) - -(** It also check in-consistency of cases like - {[ [`a | `c of int ] ]} -*) -let map_row_fields_into_strings ptyp_loc (row_fields : Parsetree.row_field list) - : External_arg_spec.attr = - let has_bs_as = ref false in - let case, result = - Ext_list.fold_right row_fields (`Nothing, []) (fun tag (nullary, acc) -> - match (nullary, tag) with - | (`Nothing | `Null), Rtag ({txt}, attrs, true, []) -> - let name = - match Ast_attributes.iter_process_bs_string_as attrs with - | Some name -> - has_bs_as := true; - name - | None -> txt - in - (`Null, (txt, name) :: acc) - | (`Nothing | `NonNull), Rtag ({txt}, attrs, false, [_]) -> - let name = - match Ast_attributes.iter_process_bs_string_as attrs with - | Some name -> - has_bs_as := true; - name - | None -> txt - in - (`NonNull, (txt, name) :: acc) - | _ -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type) - in - match case with - | `Nothing -> Bs_syntaxerr.err ptyp_loc Invalid_bs_string_type - | `Null | `NonNull -> ( - let has_payload = case = `NonNull in - let descr = if !has_bs_as then Some result else None in - match (has_payload, descr) with - | false, None -> - Location.prerr_warning ptyp_loc - (Bs_ffi_warning "@string is redundant here, you can safely remove it"); - Nothing - | false, Some descr -> External_arg_spec.Poly_var_string {descr} - | true, _ -> External_arg_spec.Poly_var {descr}) - -let is_enum row_fields = - List.for_all - (fun (x : Parsetree.row_field) -> - match x with - | Rtag (_label, _attrs, true, []) -> true - | _ -> false) - row_fields - -let is_enum_polyvar (ty : Parsetree.type_declaration) = - match ty.ptype_manifest with - | Some {ptyp_desc = Ptyp_variant (row_fields, Closed, None)} - when is_enum row_fields -> - Some row_fields - | _ -> None diff --git a/jscomp/frontend/ast_polyvar.mli b/jscomp/frontend/ast_polyvar.mli deleted file mode 100644 index 4c83bcb..0000000 --- a/jscomp/frontend/ast_polyvar.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val map_row_fields_into_ints : - Location.t -> Parsetree.row_field list -> (string * int) list -(** side effect: it will mark used attributes `bs.as` *) - -val map_constructor_declarations_into_ints : - Parsetree.constructor_declaration list -> [`Offset of int | `New of int list] - -val map_row_fields_into_strings : - Location.t -> Parsetree.row_field list -> External_arg_spec.attr - -(* val is_enum : - Parsetree.row_field list -> - bool *) - -val is_enum_polyvar : - Parsetree.type_declaration -> Parsetree.row_field list option diff --git a/jscomp/frontend/ast_signature.ml b/jscomp/frontend/ast_signature.ml deleted file mode 100644 index b733780..0000000 --- a/jscomp/frontend/ast_signature.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type item = Parsetree.signature_item - -type t = item list - -open Ast_helper - -let fuseAll ?(loc = Location.none) (t : t) : item = - Sig.include_ ~loc (Incl.mk ~loc (Mty.signature ~loc t)) diff --git a/jscomp/frontend/ast_signature.mli b/jscomp/frontend/ast_signature.mli deleted file mode 100644 index b382420..0000000 --- a/jscomp/frontend/ast_signature.mli +++ /dev/null @@ -1,29 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type item = Parsetree.signature_item - -type t = item list - -val fuseAll : ?loc:Ast_helper.loc -> t -> item diff --git a/jscomp/frontend/ast_structure.ml b/jscomp/frontend/ast_structure.ml deleted file mode 100644 index 2143f09..0000000 --- a/jscomp/frontend/ast_structure.ml +++ /dev/null @@ -1,53 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type item = Parsetree.structure_item - -type t = item list - -open Ast_helper - -let fuseAll ?(loc = Location.none) (t : t) : item = - Str.include_ ~loc (Incl.mk ~loc (Mod.structure ~loc t)) - -(* let fuse_with_constraint - ?(loc=Location.none) - (item : Parsetree.type_declaration list ) (t : t) (coercion) = - Str.include_ ~loc - (Incl.mk ~loc - (Mod.constraint_ - (Mod.structure ~loc - ({pstr_loc = loc; pstr_desc = Pstr_type item} :: t) ) - ( - Mty.signature ~loc - ({psig_loc = loc; psig_desc = Psig_type item} :: coercion) - ) - ) - ) *) -let constraint_ ?(loc = Location.none) (stru : t) (sign : Ast_signature.t) = - Str.include_ ~loc - (Incl.mk ~loc - (Mod.constraint_ ~loc (Mod.structure ~loc stru) (Mty.signature ~loc sign))) - -let dummy_item loc : item = Str.eval ~loc (Ast_literal.val_unit ~loc ()) diff --git a/jscomp/frontend/ast_structure.mli b/jscomp/frontend/ast_structure.mli deleted file mode 100644 index 77608b4..0000000 --- a/jscomp/frontend/ast_structure.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type item = Parsetree.structure_item - -type t = item list - -val fuseAll : ?loc:Ast_helper.loc -> t -> item - -(* val fuse_with_constraint: - ?loc:Ast_helper.loc -> - Parsetree.type_declaration list -> - t -> - Ast_signature.t -> - item *) - -val constraint_ : ?loc:Ast_helper.loc -> t -> Ast_signature.t -> item - -val dummy_item : Location.t -> item diff --git a/jscomp/frontend/ast_tdcls.ml b/jscomp/frontend/ast_tdcls.ml deleted file mode 100644 index 09c3487..0000000 --- a/jscomp/frontend/ast_tdcls.ml +++ /dev/null @@ -1,107 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper - -(** - [newTdcls tdcls newAttrs] - functional update attributes of last declaration *) -let newTdcls (tdcls : Parsetree.type_declaration list) - (newAttrs : Parsetree.attributes) : Parsetree.type_declaration list = - match tdcls with - | [x] -> [{x with Parsetree.ptype_attributes = newAttrs}] - | _ -> - Ext_list.map_last tdcls (fun last x -> - if last then {x with Parsetree.ptype_attributes = newAttrs} else x) - -let handleTdclsInSigi (self : Bs_ast_mapper.mapper) - (sigi : Parsetree.signature_item) rf - (tdcls : Parsetree.type_declaration list) : Ast_signature.item = - match - Ast_attributes.process_derive_type (Ext_list.last tdcls).ptype_attributes - with - | {bs_deriving = Some actions}, newAttrs -> - let loc = sigi.psig_loc in - let originalTdclsNewAttrs = newTdcls tdcls newAttrs in - (* remove the processed attr*) - let newTdclsNewAttrs = - self.type_declaration_list self originalTdclsNewAttrs - in - let kind = Ast_derive_abstract.isAbstract actions in - if kind <> Not_abstract then - let codes = - Ast_derive_abstract.handleTdclsInSig ~light:(kind = Light_abstract) rf - originalTdclsNewAttrs - in - Ast_signature.fuseAll ~loc - (Sig.include_ ~loc - (Incl.mk ~loc - (Mty.typeof_ ~loc - (Mod.constraint_ ~loc - (Mod.structure ~loc - [Ast_compatible.rec_type_str ~loc rf newTdclsNewAttrs]) - (Mty.signature ~loc [])))) - :: (* include module type of struct [processed_code for checking like invariance ]end *) - self.signature self codes) - else - Ast_signature.fuseAll ~loc - (Ast_compatible.rec_type_sig ~loc rf newTdclsNewAttrs - :: self.signature self (Ast_derive.gen_signature tdcls actions rf)) - | {bs_deriving = None}, _ -> - Bs_ast_mapper.default_mapper.signature_item self sigi - -let handleTdclsInStru (self : Bs_ast_mapper.mapper) - (str : Parsetree.structure_item) rf - (tdcls : Parsetree.type_declaration list) : Ast_structure.item = - match - Ast_attributes.process_derive_type (Ext_list.last tdcls).ptype_attributes - with - | {bs_deriving = Some actions}, newAttrs -> - let loc = str.pstr_loc in - let originalTdclsNewAttrs = newTdcls tdcls newAttrs in - let newStr : Parsetree.structure_item = - Ast_compatible.rec_type_str ~loc rf - (self.type_declaration_list self originalTdclsNewAttrs) - in - let kind = Ast_derive_abstract.isAbstract actions in - if kind <> Not_abstract then - let codes = - Ast_derive_abstract.handleTdclsInStr ~light:(kind = Light_abstract) rf - originalTdclsNewAttrs - in - (* use [tdcls2] avoid nonterminating *) - Ast_structure.fuseAll ~loc - (Ast_structure.constraint_ ~loc [newStr] [] - :: (* [include struct end : sig end] for error checking *) - self.structure self codes) - else - Ast_structure.fuseAll ~loc - (newStr - :: self.structure self - (List.map - (fun action -> - Ast_derive.gen_structure_signature loc tdcls action rf) - actions)) - | {bs_deriving = None}, _ -> - Bs_ast_mapper.default_mapper.structure_item self str diff --git a/jscomp/frontend/ast_tdcls.mli b/jscomp/frontend/ast_tdcls.mli deleted file mode 100644 index 1f8e62a..0000000 --- a/jscomp/frontend/ast_tdcls.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val handleTdclsInSigi : - Bs_ast_mapper.mapper -> - Parsetree.signature_item -> - Asttypes.rec_flag -> - Parsetree.type_declaration list -> - Ast_signature.item - -val handleTdclsInStru : - Bs_ast_mapper.mapper -> - Parsetree.structure_item -> - Asttypes.rec_flag -> - Parsetree.type_declaration list -> - Ast_structure.item diff --git a/jscomp/frontend/ast_tuple_pattern_flatten.ml b/jscomp/frontend/ast_tuple_pattern_flatten.ml deleted file mode 100644 index 8958e3e..0000000 --- a/jscomp/frontend/ast_tuple_pattern_flatten.ml +++ /dev/null @@ -1,88 +0,0 @@ -(* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* type loc = Location.t - - type exp = Parsetree.expression - - type pat = Parsetree.pattern *) - -let rec is_simple_pattern (p : Parsetree.pattern) = - match p.ppat_desc with - | Ppat_any -> true - | Ppat_var _ -> true - | Ppat_constraint (p, _) -> is_simple_pattern p - | _ -> false - -(* - [let (a,b) = M.N.(c,d) ] - => - [ let a = M.N.c - and b = M.N.d ] -*) -let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) - (vb : Parsetree.value_binding) (acc : Parsetree.value_binding list) : - Parsetree.value_binding list = - let pvb_pat = self.pat self vb.pvb_pat in - let pvb_expr = self.expr self vb.pvb_expr in - let pvb_attributes = self.attributes self vb.pvb_attributes in - match (pvb_pat.ppat_desc, pvb_expr.pexp_desc) with - | Ppat_tuple xs, _ when List.for_all is_simple_pattern xs -> ( - match Ast_open_cxt.destruct_open_tuple pvb_expr [] with - | Some (wholes, es, tuple_attributes) - when Ext_list.for_all xs is_simple_pattern && Ext_list.same_length es xs - -> - Bs_ast_invariant.warn_discarded_unused_attributes tuple_attributes; - (* will be dropped*) - Ext_list.fold_right2 xs es acc (fun pat exp acc -> - { - pvb_pat = pat; - pvb_expr = Ast_open_cxt.restore_exp exp wholes; - pvb_attributes; - pvb_loc = vb.pvb_loc; - } - :: acc) - | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc) - | Ppat_record (lid_pats, _), Pexp_pack {pmod_desc = Pmod_ident id} -> - Ext_list.map_append lid_pats acc (fun (lid, pat) -> - match lid.txt with - | Lident s -> - { - pvb_pat = pat; - pvb_expr = - Ast_helper.Exp.ident ~loc:lid.loc - {lid with txt = Ldot (id.txt, s)}; - pvb_attributes = []; - pvb_loc = pat.ppat_loc; - } - | _ -> - Location.raise_errorf ~loc:lid.loc - "Not supported pattern match on modules") - | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc - -let value_bindings_mapper (self : Bs_ast_mapper.mapper) - (vbs : Parsetree.value_binding list) = - (* Bs_ast_mapper.default_mapper.value_bindings self vbs *) - Ext_list.fold_right vbs [] (fun vb acc -> - flattern_tuple_pattern_vb self vb acc) diff --git a/jscomp/frontend/ast_tuple_pattern_flatten.mli b/jscomp/frontend/ast_tuple_pattern_flatten.mli deleted file mode 100644 index 3718b5d..0000000 --- a/jscomp/frontend/ast_tuple_pattern_flatten.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val value_bindings_mapper : - Bs_ast_mapper.mapper -> - Parsetree.value_binding list -> - Parsetree.value_binding list diff --git a/jscomp/frontend/ast_typ_uncurry.ml b/jscomp/frontend/ast_typ_uncurry.ml deleted file mode 100644 index 36861ea..0000000 --- a/jscomp/frontend/ast_typ_uncurry.ml +++ /dev/null @@ -1,64 +0,0 @@ -(* Copyright (C) 2020 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type typ = Parsetree.core_type -type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a -type uncurry_type_gen = (Asttypes.arg_label -> typ -> typ -> typ) cxt - -module Typ = Ast_helper.Typ - -let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper) - (label : Asttypes.arg_label) (first_arg : Parsetree.core_type) - (typ : Parsetree.core_type) = - let first_arg = mapper.typ mapper first_arg in - let typ = mapper.typ mapper typ in - let meth_type = Typ.arrow ~loc label first_arg typ in - let arity = Ast_core_type.get_uncurry_arity meth_type in - match arity with - | Some n -> - Typ.constr - { - txt = Ldot (Ast_literal.Lid.js_meth_callback, "arity" ^ string_of_int n); - loc; - } - [meth_type] - | None -> assert false - -let to_uncurry_type loc (mapper : Bs_ast_mapper.mapper) - (label : Asttypes.arg_label) (first_arg : Parsetree.core_type) - (typ : Parsetree.core_type) = - (* no need to error for optional here, - since we can not make it - TODO: still error out for external? - Maybe no need to error on optional at all - it just does not make sense - *) - let first_arg = mapper.typ mapper first_arg in - let typ = mapper.typ mapper typ in - - let fn_type = Typ.arrow ~loc label first_arg typ in - let arity = Ast_core_type.get_uncurry_arity fn_type in - match arity with - | Some arity -> Ast_uncurried.uncurriedType ~loc ~arity fn_type - | None -> assert false diff --git a/jscomp/frontend/ast_typ_uncurry.mli b/jscomp/frontend/ast_typ_uncurry.mli deleted file mode 100644 index afb1bc5..0000000 --- a/jscomp/frontend/ast_typ_uncurry.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* Copyright (C) 2020 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* Note that currently there is no way to consume [Js.meth_callback] - so it is fine to encode it with a freedom, - but we need make it better for error message. - - all are encoded as - {[ - type fn = (`Args_n of _ , 'result ) Js.fn - type method = (`Args_n of _, 'result) Js.method - type method_callback = (`Args_n of _, 'result) Js.method_callback - ]} - For [method_callback], the arity is never zero, so both [method] - and [fn] requires (unit -> 'a) to encode arity zero -*) - -type typ = Parsetree.core_type - -type 'a cxt = Ast_helper.loc -> Bs_ast_mapper.mapper -> 'a - -type uncurry_type_gen = - (Asttypes.arg_label -> - (* label for error checking *) - typ -> - (* First arg *) - typ -> - (* Tail *) - typ) - cxt - -val to_uncurry_type : uncurry_type_gen -(** syntax : - {[ int -> int -> int [@bs]]} -*) - -val to_method_callback_type : uncurry_type_gen -(** syntax: - {[ 'obj -> int -> int [@bs.this] ]} -*) diff --git a/jscomp/frontend/ast_uncurry_gen.ml b/jscomp/frontend/ast_uncurry_gen.ml deleted file mode 100644 index ec69cda..0000000 --- a/jscomp/frontend/ast_uncurry_gen.ml +++ /dev/null @@ -1,101 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -open Ast_helper - -(* Handling `fun [@this]` used in `object [@bs] end` *) -let to_method_callback loc (self : Bs_ast_mapper.mapper) label - (self_pat : Parsetree.pattern) body : Parsetree.expression_desc = - let self_pat = self.pat self self_pat in - (match Ast_pat.is_single_variable_pattern_conservative self_pat with - | None -> Bs_syntaxerr.err self_pat.ppat_loc Bs_this_simple_pattern - | Some self -> Stack.push self Js_config.self_stack); - Bs_syntaxerr.optional_err loc label; - let rec aux acc (body : Parsetree.expression) = - match Ast_attributes.process_attributes_rev body.pexp_attributes with - | Nothing, attrs -> ( - match body.pexp_desc with - | Pexp_fun (arg_label, _, arg, body) -> - Bs_syntaxerr.optional_err loc arg_label; - aux ((arg_label, self.pat self arg, attrs) :: acc) body - | _ -> (self.expr self body, acc)) - | _, _ -> (self.expr self body, acc) - in - let result, rev_extra_args = aux [(label, self_pat, [])] body in - let body = - Ext_list.fold_left rev_extra_args result (fun e (label, p, attrs) -> - Ast_helper.Exp.fun_ ~loc ~attrs label None p e) - in - let arity = List.length rev_extra_args in - let arity_s = string_of_int arity in - Stack.pop Js_config.self_stack |> ignore; - Parsetree.Pexp_apply - ( Exp.ident ~loc - {loc; txt = Ldot (Ast_literal.Lid.js_oo, "unsafe_to_method")}, - [ - ( Nolabel, - Exp.constraint_ ~loc - (Exp.record ~loc - [({loc; txt = Ast_literal.Lid.hidden_field arity_s}, body)] - None) - (Typ.constr ~loc - { - loc; - txt = Ldot (Ast_literal.Lid.js_meth_callback, "arity" ^ arity_s); - } - [Typ.any ~loc ()]) ); - ] ) - -let to_uncurry_fn (e : Parsetree.expression) (self : Bs_ast_mapper.mapper) - (label : Asttypes.arg_label) pat body async : Parsetree.expression = - let loc = e.pexp_loc in - Bs_syntaxerr.optional_err loc label; - let rec aux acc (body : Parsetree.expression) = - match Ast_attributes.process_attributes_rev body.pexp_attributes with - | Nothing, _ -> ( - match body.pexp_desc with - | Pexp_fun (arg_label, _, arg, body) -> - Bs_syntaxerr.optional_err loc arg_label; - aux ((arg_label, self.pat self arg) :: acc) body - | _ -> (self.expr self body, acc)) - | _, _ -> (self.expr self body, acc) - in - let first_arg = self.pat self pat in - - let result, rev_extra_args = aux [(label, first_arg)] body in - let result = Ast_async.add_promise_type ~async result in - let body = - Ext_list.fold_left rev_extra_args result (fun e (label, p) -> - Ast_helper.Exp.fun_ ~loc label None p e) - in - let body = Ast_async.add_async_attribute ~async body in - - let arity = List.length rev_extra_args in - Bs_syntaxerr.err_large_arity loc arity; - let fun_exp = Ast_uncurried.uncurriedFun ~loc ~arity body in - { - e with - pexp_desc = fun_exp.pexp_desc; - pexp_attributes = fun_exp.pexp_attributes @ e.pexp_attributes; - } diff --git a/jscomp/frontend/ast_uncurry_gen.mli b/jscomp/frontend/ast_uncurry_gen.mli deleted file mode 100644 index 047c2b1..0000000 --- a/jscomp/frontend/ast_uncurry_gen.mli +++ /dev/null @@ -1,51 +0,0 @@ -(* Copyright (C) 2020- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val to_uncurry_fn : - Parsetree.expression -> - Bs_ast_mapper.mapper -> - Asttypes.arg_label -> - Parsetree.pattern -> - Parsetree.expression -> - bool -> - (* async *) - Parsetree.expression -(** - [function] can only take one argument, that is the reason we did not adopt it - syntax: - {[ fun [@bs] pat pat1-> body ]} - [to_uncurry_fn (fun pat -> (fun pat1 -> ... body))] - -*) - -val to_method_callback : - Location.t -> - Bs_ast_mapper.mapper -> - Asttypes.arg_label -> - Parsetree.pattern -> - Parsetree.expression -> - Parsetree.expression_desc -(** syntax: - {[fun [@bs.this] obj pat pat1 -> body]} -*) diff --git a/jscomp/frontend/ast_utf8_string.ml b/jscomp/frontend/ast_utf8_string.ml deleted file mode 100644 index 75b1702..0000000 --- a/jscomp/frontend/ast_utf8_string.ml +++ /dev/null @@ -1,209 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error = - | Invalid_code_point - | Unterminated_backslash - | Invalid_hex_escape - | Invalid_unicode_escape - | Invalid_unicode_codepoint_escape - -let pp_error fmt err = - Format.pp_print_string fmt - @@ - match err with - | Invalid_code_point -> "Invalid code point" - | Unterminated_backslash -> "\\ ended unexpectedly" - | Invalid_hex_escape -> "Invalid \\x escape" - | Invalid_unicode_escape -> "Invalid \\u escape" - | Invalid_unicode_codepoint_escape -> - "Invalid \\u{…} codepoint escape sequence" - -type exn += Error of int (* offset *) * error - -let error ~loc error = raise (Error (loc, error)) - -(** Note the [loc] really should be the utf8-offset, it has nothing to do with our - escaping mechanism -*) -(* we can not just print new line in ES5 - seems we don't need - escape "\b" "\f" - we need escape "\n" "\r" since - ocaml multiple-line allows [\n] - visual input while es5 string - does not*) - -let rec check_and_transform (loc : int) (buf : Buffer.t) (s : string) - (byte_offset : int) (s_len : int) = - if byte_offset = s_len then () - else - let current_char = s.[byte_offset] in - match Ext_utf8.classify current_char with - | Single 92 (* '\\' *) -> - escape_code (loc + 1) buf s (byte_offset + 1) s_len - | Single 34 -> - Buffer.add_string buf "\\\""; - check_and_transform (loc + 1) buf s (byte_offset + 1) s_len - | Single 10 -> - Buffer.add_string buf "\\n"; - check_and_transform (loc + 1) buf s (byte_offset + 1) s_len - | Single 13 -> - Buffer.add_string buf "\\r"; - check_and_transform (loc + 1) buf s (byte_offset + 1) s_len - | Single _ -> - Buffer.add_char buf current_char; - check_and_transform (loc + 1) buf s (byte_offset + 1) s_len - | Invalid | Cont _ -> error ~loc Invalid_code_point - | Leading (n, _) -> - let i' = Ext_utf8.next s ~remaining:n byte_offset in - if i' < 0 then error ~loc Invalid_code_point - else ( - for k = byte_offset to i' do - Buffer.add_char buf s.[k] - done; - check_and_transform (loc + 1) buf s (i' + 1) s_len) - -(* we share the same escape sequence with js *) -and escape_code loc buf s offset s_len = - if offset >= s_len then error ~loc Unterminated_backslash - else Buffer.add_char buf '\\'; - let cur_char = s.[offset] in - match cur_char with - | '\\' | 'b' | 't' | 'n' | 'v' | 'f' | 'r' | '0' | '$' -> - Buffer.add_char buf cur_char; - check_and_transform (loc + 1) buf s (offset + 1) s_len - | 'u' -> - if offset + 1 >= s_len then error ~loc Invalid_unicode_escape - else ( - Buffer.add_char buf cur_char; - let next_char = s.[offset + 1] in - match next_char with - | '{' -> - Buffer.add_char buf next_char; - unicode_codepoint_escape (loc + 2) buf s (offset + 2) s_len - | _ -> unicode (loc + 1) buf s (offset + 1) s_len) - | 'x' -> - Buffer.add_char buf cur_char; - two_hex (loc + 1) buf s (offset + 1) s_len - | _ -> - (* Regular characters, like `a` in `\a`, - * are valid escape sequences *) - Buffer.add_char buf cur_char; - check_and_transform (loc + 1) buf s (offset + 1) s_len - -and two_hex loc buf s offset s_len = - if offset + 1 >= s_len then error ~loc Invalid_hex_escape; - (*Location.raise_errorf ~loc "\\x need at least two chars";*) - let a, b = (s.[offset], s.[offset + 1]) in - if Ext_char.valid_hex a && Ext_char.valid_hex b then ( - Buffer.add_char buf a; - Buffer.add_char buf b; - check_and_transform (loc + 2) buf s (offset + 2) s_len) - else error ~loc Invalid_hex_escape -(*Location.raise_errorf ~loc "%c%c is not a valid hex code" a b*) - -and unicode loc buf s offset s_len = - if offset + 3 >= s_len then error ~loc Invalid_unicode_escape - (*Location.raise_errorf ~loc "\\u need at least four chars"*); - let a0, a1, a2, a3 = - (s.[offset], s.[offset + 1], s.[offset + 2], s.[offset + 3]) - in - if - Ext_char.valid_hex a0 && Ext_char.valid_hex a1 && Ext_char.valid_hex a2 - && Ext_char.valid_hex a3 - then ( - Buffer.add_char buf a0; - Buffer.add_char buf a1; - Buffer.add_char buf a2; - Buffer.add_char buf a3; - check_and_transform (loc + 4) buf s (offset + 4) s_len) - else error ~loc Invalid_unicode_escape - -(*Location.raise_errorf ~loc "%c%c%c%c is not a valid unicode point" - a0 a1 a2 a3 *) -(* http://www.2ality.com/2015/01/es6-strings.html - console.log('\uD83D\uDE80'); (* ES6*) - console.log('\u{1F680}'); -*) - -(* ES6 unicode codepoint escape sequences: \u{…} - https://262.ecma-international.org/6.0/#sec-literals-string-literals *) -and unicode_codepoint_escape loc buf s offset s_len = - if offset >= s_len then error ~loc Invalid_unicode_codepoint_escape - else - let cur_char = s.[offset] in - match cur_char with - | '}' -> - Buffer.add_char buf cur_char; - let x = ref 0 in - for ix = loc to offset - 1 do - let c = s.[ix] in - let value = - match c with - | '0' .. '9' -> Char.code c - 48 - | 'a' .. 'f' -> Char.code c - Char.code 'a' + 10 - | 'A' .. 'F' -> Char.code c + 32 - Char.code 'a' + 10 - | _ -> 16 - (* larger than any legal value, unicode_codepoint_escape only makes progress if we have valid hex symbols *) - in - (* too long escape sequence will result in an overflow, perform an upperbound check *) - if !x > 0x10FFFF then error ~loc Invalid_unicode_codepoint_escape - else x := (!x * 16) + value - done; - if Uchar.is_valid !x then - check_and_transform (offset + 1) buf s (offset + 1) s_len - else error ~loc Invalid_unicode_codepoint_escape - | _ -> - if Ext_char.valid_hex cur_char then ( - Buffer.add_char buf cur_char; - unicode_codepoint_escape loc buf s (offset + 1) s_len) - else error ~loc Invalid_unicode_codepoint_escape - -let transform_test s = - let s_len = String.length s in - let buf = Buffer.create (s_len * 2) in - check_and_transform 0 buf s 0 s_len; - Buffer.contents buf - -let transform loc s = - let s_len = String.length s in - let buf = Buffer.create (s_len * 2) in - try - check_and_transform 0 buf s 0 s_len; - Buffer.contents buf - with Error (offset, error) -> - Location.raise_errorf ~loc "Offset: %d, %a" offset pp_error error - -let rec check_no_escapes_or_unicode (s : string) (byte_offset : int) - (s_len : int) = - if byte_offset = s_len then true - else - let current_char = s.[byte_offset] in - match Ext_utf8.classify current_char with - | Single 92 (* '\\' *) -> false - | Single _ -> check_no_escapes_or_unicode s (byte_offset + 1) s_len - | Invalid | Cont _ | Leading _ -> false - -let simple_comparison s = check_no_escapes_or_unicode s 0 (String.length s) diff --git a/jscomp/frontend/ast_utf8_string.mli b/jscomp/frontend/ast_utf8_string.mli deleted file mode 100644 index 588125f..0000000 --- a/jscomp/frontend/ast_utf8_string.mli +++ /dev/null @@ -1,40 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error - -type exn += Error of int (* offset *) * error - -val pp_error : Format.formatter -> error -> unit - -(* module Interp : sig *) -(* val check_and_transform : int -> string -> int -> cxt -> unit *) -(* val transform_test : string -> segments *) -(* end *) -val transform_test : string -> string - -val transform : Location.t -> string -> string - -(* Check if the string is only == to itself (no unicode or escape tricks) *) -val simple_comparison : string -> bool diff --git a/jscomp/frontend/ast_utf8_string_interp.ml b/jscomp/frontend/ast_utf8_string_interp.ml deleted file mode 100644 index a66d7ee..0000000 --- a/jscomp/frontend/ast_utf8_string_interp.ml +++ /dev/null @@ -1,314 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type error = - | Invalid_code_point - | Unterminated_backslash - | Invalid_escape_code of char - | Invalid_hex_escape - | Invalid_unicode_escape - | Unterminated_variable - | Unmatched_paren - | Invalid_syntax_of_var of string - -type kind = String | Var of int * int -(* [Var (loffset, roffset)] - For parens it used to be (2,-1) - for non-parens it used to be (1,0) -*) - -type pos = { - lnum: int; - offset: int; - byte_bol: int; - (* Note it actually needs to be in sync with OCaml's lexing semantics *) -} -(** Note the position is about code point *) - -type segment = {start: pos; finish: pos; kind: kind; content: string} -type segments = segment list - -type cxt = { - mutable segment_start: pos; - buf: Buffer.t; - s_len: int; - mutable segments: segments; - mutable pos_bol: int; - (* record the abs position of current beginning line *) - mutable byte_bol: int; - mutable pos_lnum: int; (* record the line number *) -} - -type exn += Error of pos * pos * error - -let valid_lead_identifier_char x = - match x with - | 'a' .. 'z' | '_' -> true - | _ -> false - -(** Invariant: [valid_lead_identifier] has to be [valid_identifier] *) -let valid_identifier_char x = - match x with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'' -> true - | _ -> false - -let valid_identifier s = - let s_len = String.length s in - if s_len = 0 then false - else - valid_lead_identifier_char s.[0] - && Ext_string.for_all_from s 1 valid_identifier_char - -(* let is_space x = - match x with - | ' ' | '\n' | '\t' -> true - | _ -> false *) - -(** Note [Var] kind can not be mpty *) -let empty_segment {content} = Ext_string.is_empty content - -let update_newline ~byte_bol loc cxt = - cxt.pos_lnum <- cxt.pos_lnum + 1; - cxt.pos_bol <- loc; - cxt.byte_bol <- byte_bol - -let pos_error cxt ~loc error = - raise - (Error - ( cxt.segment_start, - { - lnum = cxt.pos_lnum; - offset = loc - cxt.pos_bol; - byte_bol = cxt.byte_bol; - }, - error )) - -let add_var_segment cxt loc loffset roffset = - let content = Buffer.contents cxt.buf in - Buffer.clear cxt.buf; - let next_loc = - {lnum = cxt.pos_lnum; offset = loc - cxt.pos_bol; byte_bol = cxt.byte_bol} - in - if valid_identifier content then ( - cxt.segments <- - { - start = cxt.segment_start; - finish = next_loc; - kind = Var (loffset, roffset); - content; - } - :: cxt.segments; - cxt.segment_start <- next_loc) - else pos_error cxt ~loc (Invalid_syntax_of_var content) - -let add_str_segment cxt loc = - let content = Buffer.contents cxt.buf in - Buffer.clear cxt.buf; - let next_loc = - {lnum = cxt.pos_lnum; offset = loc - cxt.pos_bol; byte_bol = cxt.byte_bol} - in - cxt.segments <- - {start = cxt.segment_start; finish = next_loc; kind = String; content} - :: cxt.segments; - cxt.segment_start <- next_loc - -let rec check_and_transform (loc : int) s byte_offset - ({s_len; buf} as cxt : cxt) = - if byte_offset = s_len then add_str_segment cxt loc - else - let current_char = s.[byte_offset] in - match Ext_utf8.classify current_char with - | Single 92 (* '\\' *) -> escape_code (loc + 1) s (byte_offset + 1) cxt - | Single 34 -> - Buffer.add_string buf "\\\""; - check_and_transform (loc + 1) s (byte_offset + 1) cxt - | Single 10 -> - Buffer.add_string buf "\\n"; - let loc = loc + 1 in - let byte_offset = byte_offset + 1 in - update_newline ~byte_bol:byte_offset loc cxt; - (* Note variable could not have new-line *) - check_and_transform loc s byte_offset cxt - | Single 13 -> - Buffer.add_string buf "\\r"; - check_and_transform (loc + 1) s (byte_offset + 1) cxt - | Single 36 -> - (* $ *) - add_str_segment cxt loc; - let offset = byte_offset + 1 in - if offset >= s_len then pos_error ~loc cxt Unterminated_variable - else - let cur_char = s.[offset] in - if cur_char = '(' then expect_var_paren (loc + 2) s (offset + 1) cxt - else expect_simple_var (loc + 1) s offset cxt - | Single _ -> - Buffer.add_char buf current_char; - check_and_transform (loc + 1) s (byte_offset + 1) cxt - | Invalid | Cont _ -> pos_error ~loc cxt Invalid_code_point - | Leading (n, _) -> - let i' = Ext_utf8.next s ~remaining:n byte_offset in - if i' < 0 then pos_error cxt ~loc Invalid_code_point - else ( - for k = byte_offset to i' do - Buffer.add_char buf s.[k] - done; - check_and_transform (loc + 1) s (i' + 1) cxt) - -(* Lets keep identifier simple, so that we could generating a function easier in the future - for example - let f = [%fn{| $x + $y = $x_add_y |}] -*) -and expect_simple_var loc s offset ({buf; s_len} as cxt) = - let v = ref offset in - (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *) - if not (offset < s_len && valid_lead_identifier_char s.[offset]) then - pos_error cxt ~loc (Invalid_syntax_of_var Ext_string.empty) - else ( - while !v < s_len && valid_identifier_char s.[!v] do - (* TODO*) - let cur_char = s.[!v] in - Buffer.add_char buf cur_char; - incr v - done; - let added_length = !v - offset in - let loc = added_length + loc in - add_var_segment cxt loc 1 0; - check_and_transform loc s (added_length + offset) cxt) - -and expect_var_paren loc s offset ({buf; s_len} as cxt) = - let v = ref offset in - (* prerr_endline @@ Ext_pervasives.dump (s, has_paren, (is_space s.[!v]), !v); *) - while !v < s_len && s.[!v] <> ')' do - let cur_char = s.[!v] in - Buffer.add_char buf cur_char; - incr v - done; - let added_length = !v - offset in - let loc = added_length + 1 + loc in - if !v < s_len && s.[!v] = ')' then ( - add_var_segment cxt loc 2 (-1); - check_and_transform loc s (added_length + 1 + offset) cxt) - else pos_error cxt ~loc Unmatched_paren - -(* we share the same escape sequence with js *) -and escape_code loc s offset ({buf; s_len} as cxt) = - if offset >= s_len then pos_error cxt ~loc Unterminated_backslash - else Buffer.add_char buf '\\'; - let cur_char = s.[offset] in - match cur_char with - | '\\' | 'b' | 't' | 'n' | 'v' | 'f' | 'r' | '0' | '$' -> - Buffer.add_char buf cur_char; - check_and_transform (loc + 1) s (offset + 1) cxt - | 'u' -> - Buffer.add_char buf cur_char; - unicode (loc + 1) s (offset + 1) cxt - | 'x' -> - Buffer.add_char buf cur_char; - two_hex (loc + 1) s (offset + 1) cxt - | _ -> pos_error cxt ~loc (Invalid_escape_code cur_char) - -and two_hex loc s offset ({buf; s_len} as cxt) = - if offset + 1 >= s_len then pos_error cxt ~loc Invalid_hex_escape; - let a, b = (s.[offset], s.[offset + 1]) in - if Ext_char.valid_hex a && Ext_char.valid_hex b then ( - Buffer.add_char buf a; - Buffer.add_char buf b; - check_and_transform (loc + 2) s (offset + 2) cxt) - else pos_error cxt ~loc Invalid_hex_escape - -and unicode loc s offset ({buf; s_len} as cxt) = - if offset + 3 >= s_len then pos_error cxt ~loc Invalid_unicode_escape; - let a0, a1, a2, a3 = - (s.[offset], s.[offset + 1], s.[offset + 2], s.[offset + 3]) - in - if - Ext_char.valid_hex a0 && Ext_char.valid_hex a1 && Ext_char.valid_hex a2 - && Ext_char.valid_hex a3 - then ( - Buffer.add_char buf a0; - Buffer.add_char buf a1; - Buffer.add_char buf a2; - Buffer.add_char buf a3; - check_and_transform (loc + 4) s (offset + 4) cxt) - else pos_error cxt ~loc Invalid_unicode_escape - -let transform_test s = - let s_len = String.length s in - let buf = Buffer.create (s_len * 2) in - let 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; - List.rev cxt.segments - -module Delim = struct - let parse_processed = function - | None -> Some External_arg_spec.DNone - | Some "json" -> Some DNoQuotes - | Some "*j" -> Some DStarJ - | _ -> None - - type interpolation = - | Js (* string interpolation *) - | Unrecognized (* no interpolation: delimiter not recognized *) - let parse_unprocessed loc = function - | "js" -> Js - | "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_js_delimiter = "js" - let escaped = Some escaped_j_delimiter -end - -let transform_exp (e : Parsetree.expression) s delim : Parsetree.expression = - 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))} - | Unrecognized -> e - -let transform_pat (p : Parsetree.pattern) s delim : Parsetree.pattern = - 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))} - | 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_js_delimiter - -let parse_processed_delim = Delim.parse_processed diff --git a/jscomp/frontend/ast_utf8_string_interp.mli b/jscomp/frontend/ast_utf8_string_interp.mli deleted file mode 100644 index 5e8ec9c..0000000 --- a/jscomp/frontend/ast_utf8_string_interp.mli +++ /dev/null @@ -1,63 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type kind = String | Var of int * int (* int records its border length *) - -type error = private - | Invalid_code_point - | Unterminated_backslash - | Invalid_escape_code of char - | Invalid_hex_escape - | Invalid_unicode_escape - | Unterminated_variable - | Unmatched_paren - | Invalid_syntax_of_var of string - -type pos = {lnum: int; offset: int; byte_bol: int} -(** Note the position is about code point *) - -type segment = {start: pos; finish: pos; kind: kind; content: string} -type segments = segment list - -type cxt = { - mutable segment_start: pos; - buf: Buffer.t; - s_len: int; - mutable segments: segments; - mutable pos_bol: int; - (* record the abs position of current beginning line *) - mutable byte_bol: int; - mutable pos_lnum: int; (* record the line number *) -} - -type exn += Error of pos * pos * error - -val empty_segment : segment -> bool -val transform_test : string -> segment list -val transform_exp : - Parsetree.expression -> string -> string -> Parsetree.expression -val transform_pat : Parsetree.pattern -> string -> string -> Parsetree.pattern -val is_unicode_string : string -> bool -val is_unescaped : string -> bool -val parse_processed_delim : string option -> External_arg_spec.delim option diff --git a/jscomp/frontend/ast_util.ml b/jscomp/frontend/ast_util.ml deleted file mode 100644 index 8053c71..0000000 --- a/jscomp/frontend/ast_util.ml +++ /dev/null @@ -1,45 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list - -let js_property loc obj (name : string) = - Parsetree.Pexp_send (obj, {loc; txt = name}) - -let record_as_js_object loc (self : Bs_ast_mapper.mapper) - (label_exprs : label_exprs) : Parsetree.expression_desc = - let labels, args, arity = - Ext_list.fold_right label_exprs ([], [], 0) - (fun ({txt; loc}, e) (labels, args, i) -> - match txt with - | Lident x -> - ( {Asttypes.loc; txt = x} :: labels, - (x, self.expr self e) :: args, - i + 1 ) - | Ldot _ | Lapply _ -> Location.raise_errorf ~loc "invalid js label ") - in - Ast_external_mk.local_external_obj loc - ~pval_prim:(Ast_external_process.pval_prim_of_labels labels) - ~pval_type:(Ast_core_type.from_labels ~loc arity labels) - args diff --git a/jscomp/frontend/ast_util.mli b/jscomp/frontend/ast_util.mli deleted file mode 100644 index 93c29f9..0000000 --- a/jscomp/frontend/ast_util.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** In general three kinds of ast generation. - - convert a curried to type to uncurried - - convert a curried fun to uncurried fun - - convert a uncuried application to normal -*) - -type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list - -val record_as_js_object : - Location.t -> Bs_ast_mapper.mapper -> label_exprs -> Parsetree.expression_desc - -val js_property : - Location.t -> Parsetree.expression -> string -> Parsetree.expression_desc diff --git a/jscomp/frontend/bs_ast_invariant.ml b/jscomp/frontend/bs_ast_invariant.ml deleted file mode 100644 index b7abb88..0000000 --- a/jscomp/frontend/bs_ast_invariant.ml +++ /dev/null @@ -1,194 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * Copyright (C) 2017- Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** Warning unused bs attributes - Note if we warn `deriving` too, - it may fail third party ppxes -*) -let is_bs_attribute txt = - let len = String.length txt in - len >= 2 - (*TODO: check the stringing padding rule, this preciate may not be needed *) - && String.unsafe_get txt 0 = 'b' - && String.unsafe_get txt 1 = 's' - && (len = 2 || String.unsafe_get txt 2 = '.') - -let used_attributes : string Asttypes.loc Hash_set_poly.t = - Hash_set_poly.create 16 - -(* - let dump_attribute fmt = (fun ( (sloc : string Asttypes.loc),payload) -> - Format.fprintf fmt "@[%s %a@]" sloc.txt (Printast.payload 0 ) payload - ) - -let dump_used_attributes fmt = - Format.fprintf fmt "Used attributes Listing Start:@."; - Hash_set_poly.iter used_attributes (fun attr -> dump_attribute fmt attr) ; - Format.fprintf fmt "Used attributes Listing End:@." - *) - -(* only mark non-ghost used bs attribute *) -let mark_used_bs_attribute ((x, _) : Parsetree.attribute) = - if not x.loc.loc_ghost then Hash_set_poly.add used_attributes x - -let warn_unused_attribute ((({txt; loc} as sloc), _) : Parsetree.attribute) = - if - is_bs_attribute txt && (not loc.loc_ghost) - && not (Hash_set_poly.mem used_attributes sloc) - then - (* - dump_used_attributes Format.err_formatter; - dump_attribute Format.err_formatter attr ; - *) - Location.prerr_warning loc (Bs_unused_attribute txt) - -let warn_discarded_unused_attributes (attrs : Parsetree.attributes) = - if attrs <> [] then Ext_list.iter attrs warn_unused_attribute - -type iterator = Ast_iterator.iterator - -let super = Ast_iterator.default_iterator - -let check_constant loc (const : Parsetree.constant) = - match const with - | Pconst_string (_, Some s) -> - if Ast_utf8_string_interp.is_unescaped s then - Bs_warnings.error_unescaped_delimiter loc s - | Pconst_integer (s, None) -> ( - (* range check using int32 - It is better to give a warning instead of error to avoid make people unhappy. - It also has restrictions in which platform bsc is running on since it will - affect int ranges - *) - try ignore @@ Int32.of_string s - with _ -> Bs_warnings.warn_literal_overflow loc) - | _ -> () - -(* Note we only used Bs_ast_iterator here, we can reuse compiler-libs instead of - rolling our own*) -let emit_external_warnings : iterator = - { - super with - type_declaration = - (fun self ptyp -> - let txt = ptyp.ptype_name.txt in - if Ast_core_type.is_builtin_rank0_type txt then - Location.raise_errorf ~loc:ptyp.ptype_loc - "built-in type `%s` can not be redefined " txt; - super.type_declaration self ptyp); - attribute = (fun _ attr -> warn_unused_attribute attr); - structure_item = - (fun self str_item -> - match str_item.pstr_desc with - | Pstr_type - ( Nonrecursive, - [{ptype_kind = Ptype_variant ({pcd_res = Some _} :: _)}] ) - when !Config.syntax_kind = `rescript -> - Location.raise_errorf ~loc:str_item.pstr_loc - "GADT has to be recursive types, please try `type rec'" - | Pstr_class _ -> - Location.raise_errorf ~loc:str_item.pstr_loc - "OCaml style classes are not supported" - | _ -> super.structure_item self str_item); - expr = - (fun self ({pexp_loc = loc} as a) -> - match a.pexp_desc with - | Pexp_constant const -> check_constant loc const - | Pexp_object _ | Pexp_new _ -> - Location.raise_errorf ~loc "OCaml style objects are not supported" - | Pexp_variant (s, None) when Ext_string.is_valid_hash_number s -> ( - try ignore (Ext_string.hash_number_as_i32_exn s : int32) - with _ -> - Location.raise_errorf ~loc - "This number is too large to cause int overlow") - | _ -> super.expr self a); - label_declaration = - (fun self lbl -> - Ext_list.iter lbl.pld_attributes (fun attr -> - match attr with - | {txt = "bs.as" | "as"}, _ -> mark_used_bs_attribute attr - | _ -> ()); - super.label_declaration self lbl); - constructor_declaration = - (fun self ({pcd_name = {txt; loc}} as ctr) -> - (match txt with - | "false" | "true" | "()" -> - Location.raise_errorf ~loc "%s can not be redefined " txt - | _ -> ()); - super.constructor_declaration self ctr); - value_description = - (fun self v -> - match v with - | ({pval_loc; pval_prim = [byte_name]; pval_type} : - Parsetree.value_description) -> ( - match byte_name with - | "%identity" when not (Ast_core_type.is_arity_one pval_type) -> - Location.raise_errorf ~loc:pval_loc - "%%identity expects a function type of the form 'a => 'b (arity \ - 1)" - | _ -> - if byte_name <> "" then - let c = String.unsafe_get byte_name 0 in - if not (c = '%' || c = '#' || c = '?') then - Location.prerr_warning pval_loc - (Warnings.Bs_ffi_warning - (byte_name ^ " such externals are unsafe")) - else super.value_description self v - else - Location.prerr_warning pval_loc - (Warnings.Bs_ffi_warning - (byte_name ^ " such externals are unsafe"))) - | _ -> super.value_description self v); - pat = - (fun self (pat : Parsetree.pattern) -> - match pat.ppat_desc with - | Ppat_constant constant -> check_constant pat.ppat_loc constant - | _ -> super.pat self pat); - } - -let rec iter_warnings_on_stru (stru : Parsetree.structure) = - match stru with - | [] -> () - | head :: rest -> ( - match head.pstr_desc with - | Pstr_attribute attr -> - Builtin_attributes.warning_attribute attr; - iter_warnings_on_stru rest - | _ -> ()) - -let rec iter_warnings_on_sigi (stru : Parsetree.signature) = - match stru with - | [] -> () - | head :: rest -> ( - match head.psig_desc with - | Psig_attribute attr -> - Builtin_attributes.warning_attribute attr; - iter_warnings_on_sigi rest - | _ -> ()) - -let emit_external_warnings_on_structure (stru : Parsetree.structure) = - emit_external_warnings.structure emit_external_warnings stru - -let emit_external_warnings_on_signature (sigi : Parsetree.signature) = - emit_external_warnings.signature emit_external_warnings sigi diff --git a/jscomp/frontend/bs_ast_invariant.mli b/jscomp/frontend/bs_ast_invariant.mli deleted file mode 100644 index dcff1c3..0000000 --- a/jscomp/frontend/bs_ast_invariant.mli +++ /dev/null @@ -1,41 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type iterator = Ast_iterator.iterator - -val mark_used_bs_attribute : Parsetree.attribute -> unit - -(** [warn_discarded_unused_attributes discarded] - warn if [discarded] has unused bs attribute -*) -val warn_discarded_unused_attributes : Parsetree.attributes -> unit -(** Ast invariant checking for detecting errors *) - -val iter_warnings_on_stru : Parsetree.structure -> unit - -val iter_warnings_on_sigi : Parsetree.signature -> unit - -val emit_external_warnings_on_structure : Parsetree.structure -> unit - -val emit_external_warnings_on_signature : Parsetree.signature -> unit diff --git a/jscomp/frontend/bs_ast_mapper.ml b/jscomp/frontend/bs_ast_mapper.ml deleted file mode 100644 index 265d194..0000000 --- a/jscomp/frontend/bs_ast_mapper.ml +++ /dev/null @@ -1,655 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(* A generic Parsetree mapping class *) - -(* -[@@@warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - -open! Parsetree -open Ast_helper -open Location - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: - mapper -> class_type_declaration -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: - mapper -> constructor_declaration -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: - mapper -> extension_constructor -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: - mapper -> module_type_declaration -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - (* #if true then *) - type_declaration_list: - mapper -> type_declaration list -> type_declaration list; - (* #end *) - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - (* #if true then *) - value_bindings_rec: mapper -> value_binding list -> value_binding list; - value_bindings: mapper -> value_binding list -> value_binding list; - (* #end *) - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} - -let map_fst f (x, y) = (f x, y) -let map_snd f (x, y) = (x, f y) -let map_tuple f1 f2 (x, y) = (f1 x, f2 y) -let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let map_opt f = function - | None -> None - | Some x -> Some (f x) - -let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - -module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag - (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let object_field sub = function - | Otag (l, attrs, t) -> - Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> - poly ~loc ~attrs (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - { - ptype_name; - ptype_params; - ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc; - } = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs: - (List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - (* #if true then *) - let map_type_declaration_list sub l = List.map (sub.type_declaration sub) l - - (* #end *) - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - { - ptyext_path; - ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes; - } = - Te.mk (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - | Pext_decl (ctl, cto) -> - Pext_decl (map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; pext_kind; pext_loc; pext_attributes} = - Te.constructor (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) -end - -module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (ovf, lid, ct) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) -end - -module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Misc.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> - (* #if false then - type_ ~loc rf (List.map (sub.type_declaration sub) l) - #else *) - type_ ~loc rf (sub.type_declaration_list sub l) - (* #end *) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class () -> assert false - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) -end - -module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Misc.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> - (* #if false then - value ~loc r (List.map (sub.value_binding sub) vbs) - #else *) - value ~loc r - ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings) - sub vbs) - (* #end *) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> - (* #if false then - type_ ~loc rf (List.map (sub.type_declaration sub) l) - #else *) - type_ ~loc rf (sub.type_declaration_list sub l) - (* #end *) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class () -> {pstr_loc = loc; pstr_desc = Pstr_class ()} - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) -end - -module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - (* #if false then - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - #else *) - let_ ~loc ~attrs r - ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings) - sub vbs) - (sub.expr sub e) - (* #end *) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) def) - (sub.pat sub p) (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) - (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () -end - -module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) - cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid, p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) -end - -module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - (* #if false then - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - #else *) - let_ ~loc ~attrs r - ((if r = Recursive then sub.value_bindings_rec else sub.value_bindings) - sub vbs) - (sub.class_expr sub ce) - (* #end *) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (ovf, lid, ce) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit () -> {pcf_loc = loc; pcf_attributes = attrs; pcf_desc = desc} - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f - {pci_virt; pci_params = pl; pci_name; pci_expr; pci_loc; pci_attributes} = - Ci.mk ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) (f pci_expr) ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - (* #if true then *) - type_declaration_list = T.map_type_declaration_list; - (* #end *) - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} -> - Val.mk (map_loc this pval_name) (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim); - pat = P.map; - expr = E.map; - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc)); - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc)); - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) - (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc)); - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes)); - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk - (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes)); - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk - (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes)); - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes)); - (* #if true then *) - value_bindings = - (fun this vbs -> - match vbs with - | [vb] -> [this.value_binding this vb] - | _ -> List.map (this.value_binding this) vbs); - value_bindings_rec = - (fun this vbs -> - match vbs with - | [vb] -> [this.value_binding this vb] - | _ -> List.map (this.value_binding this) vbs); - (* #end *) - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes)); - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field (map_loc this pld_name) (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes)); - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - }); - location = (fun _this l -> l); - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g)); - } diff --git a/jscomp/frontend/bs_ast_mapper.mli b/jscomp/frontend/bs_ast_mapper.mli deleted file mode 100644 index 869a20f..0000000 --- a/jscomp/frontend/bs_ast_mapper.mli +++ /dev/null @@ -1,109 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} allows to implement AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ - open Asttypes - open Parsetree - open Ast_mapper - - let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - - let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - -*) - -open! Parsetree - -(** {1 A generic Parsetree mapper} *) - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: - mapper -> class_type_declaration -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: - mapper -> constructor_declaration -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: - mapper -> extension_constructor -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: - mapper -> module_type_declaration -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_declaration_list: - mapper -> type_declaration list -> type_declaration list; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_bindings_rec: mapper -> value_binding list -> value_binding list; - value_bindings: mapper -> value_binding list -> value_binding list; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} -(** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - -val default_mapper : mapper -(** A default mapper, which implements a "deep identity" mapping. *) diff --git a/jscomp/frontend/bs_builtin_ppx.ml b/jscomp/frontend/bs_builtin_ppx.ml deleted file mode 100644 index bc0afb0..0000000 --- a/jscomp/frontend/bs_builtin_ppx.ml +++ /dev/null @@ -1,679 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(* When we design a ppx, we should keep it simple, and also think about - how it would work with other tools like merlin and ocamldep *) - -(** - 1. extension point - {[ - [%bs.raw{| blabla |}] - ]} - will be desugared into - {[ - let module Js = - struct unsafe_js : string -> 'a end - in Js.unsafe_js {| blabla |} - ]} - The major benefit is to better error reporting (with locations). - Otherwise - - {[ - - let f u = Js.unsafe_js u - let _ = f (1 + 2) - ]} - And if it is inlined some where -*) - -let () = - Ast_derive_projector.init (); - Ast_derive_js_mapper.init () - -let succeed attr attrs = - match attrs with - | [_] -> () - | _ -> - Bs_ast_invariant.mark_used_bs_attribute attr; - Bs_ast_invariant.warn_discarded_unused_attributes attrs - -type mapper = Bs_ast_mapper.mapper - -let default_mapper = Bs_ast_mapper.default_mapper -let default_expr_mapper = Bs_ast_mapper.default_mapper.expr -let default_pat_mapper = Bs_ast_mapper.default_mapper.pat - -let pat_mapper (self : mapper) (p : Parsetree.pattern) = - match p.ppat_desc with - | Ppat_constant (Pconst_integer (s, Some 'l')) -> - {p with ppat_desc = Ppat_constant (Pconst_integer (s, None))} - | Ppat_constant (Pconst_string (s, Some delim)) -> - Ast_utf8_string_interp.transform_pat p s delim - | _ -> default_pat_mapper self p - -(* Unpack requires core_type package for type inference: - Generate a module type name eg. __Belt_List__*) -let local_module_type_name txt = - "_" - ^ (Longident.flatten txt |> List.fold_left (fun ll l -> ll ^ "_" ^ l) "") - ^ "__" - -let expr_mapper ~async_context ~in_function_def (self : mapper) - (e : Parsetree.expression) = - let old_in_function_def = !in_function_def in - in_function_def := false; - match e.pexp_desc with - (* Its output should not be rewritten anymore *) - | Pexp_extension extension -> - Ast_exp_extension.handle_extension e self extension - | Pexp_setinstvar ({txt; loc}, expr) -> - if Stack.is_empty Js_config.self_stack then - Location.raise_errorf ~loc:e.pexp_loc - "This assignment can only happen in object context"; - let name = Stack.top Js_config.self_stack in - if name = "" then - Location.raise_errorf ~loc:e.pexp_loc - "The current object does not assign a name"; - let open Ast_helper in - self.expr self - (Exp.apply ~loc:e.pexp_loc - (Exp.ident ~loc {loc; txt = Lident "#="}) - [ - ( Nolabel, - Exp.send ~loc (Exp.ident ~loc {loc; txt = Lident name}) {loc; txt} - ); - (Nolabel, expr); - ]) - | Pexp_constant (Pconst_string (s, Some delim)) -> - Ast_utf8_string_interp.transform_exp e s delim - | Pexp_constant (Pconst_integer (s, Some 'l')) -> - {e with pexp_desc = Pexp_constant (Pconst_integer (s, None))} - (* End rewriting *) - | Pexp_function cases -> ( - (* {[ function [@bs.exn] - | Not_found -> 0 - | Invalid_argument -> 1 - ]}*) - async_context := false; - match Ast_attributes.process_pexp_fun_attributes_rev e.pexp_attributes with - | false, _ -> default_expr_mapper self e - | true, pexp_attributes -> - Ast_bs_open.convertBsErrorFunction e.pexp_loc self pexp_attributes cases) - | _ - when Ast_uncurried.exprIsUncurriedFun e - && - match - Ast_attributes.process_attributes_rev - (Ast_uncurried.exprExtractUncurriedFun e).pexp_attributes - with - | Meth_callback _, _ -> true - | _ -> false -> - (* Treat @this (. x, y, z) => ... just like @this (x, y, z) => ... *) - let fun_expr = Ast_uncurried.exprExtractUncurriedFun e in - self.expr self fun_expr - | Pexp_newtype (s, body) -> - let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in - let body = Ast_async.add_async_attribute ~async body in - let res = self.expr self body in - {e with pexp_desc = Pexp_newtype (s, res)} - | Pexp_fun (label, _, pat, body) -> ( - let async = Ast_attributes.has_async_payload e.pexp_attributes <> None in - match Ast_attributes.process_attributes_rev e.pexp_attributes with - | Nothing, _ -> - (* Handle @async x => y => ... is in async context *) - async_context := (old_in_function_def && !async_context) || async; - in_function_def := true; - Ast_async.make_function_async ~async (default_expr_mapper self e) - | Uncurry _, pexp_attributes -> - async_context := async; - Ast_uncurry_gen.to_uncurry_fn {e with pexp_attributes} self label pat body - async - | Method _, _ -> - Location.raise_errorf ~loc:e.pexp_loc - "%@meth is not supported in function expression" - | Meth_callback _, pexp_attributes -> - (* FIXME: does it make sense to have a label for [this] ? *) - async_context := false; - { - e with - pexp_desc = - Ast_uncurry_gen.to_method_callback e.pexp_loc self label pat body; - pexp_attributes; - }) - | Pexp_apply (fn, args) -> Ast_exp_apply.app_exp_mapper e self fn args - | Pexp_match - ( b, - [ - { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, None)}; - pc_guard = None; - pc_rhs = t_exp; - }; - { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, None)}; - pc_guard = None; - pc_rhs = f_exp; - }; - ] ) - | Pexp_match - ( b, - [ - { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, None)}; - pc_guard = None; - pc_rhs = f_exp; - }; - { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, None)}; - pc_guard = None; - pc_rhs = t_exp; - }; - ] ) -> - default_expr_mapper self - {e with pexp_desc = Pexp_ifthenelse (b, t_exp, Some f_exp)} - | Pexp_let - ( Nonrecursive, - [ - { - pvb_pat = - ( {ppat_desc = Ppat_record _} - | {ppat_desc = Ppat_alias ({ppat_desc = Ppat_record _}, _)} ) as p; - pvb_expr; - pvb_attributes; - pvb_loc = _; - }; - ], - body ) -> ( - match pvb_expr.pexp_desc with - | Pexp_pack _ -> default_expr_mapper self e - | _ -> - default_expr_mapper self - { - e with - pexp_desc = - Pexp_match (pvb_expr, [{pc_lhs = p; pc_guard = None; pc_rhs = body}]); - pexp_attributes = e.pexp_attributes @ pvb_attributes; - }) - (* let [@warning "a"] {a;b} = c in body - The attribute is attached to value binding, - after the transformation value binding does not exist so we attach - the attribute to the whole expression, in general, when shuffuling the ast - it is very hard to place attributes correctly - *) - (* module M = await Belt.List *) - | Pexp_letmodule - (lid, ({pmod_desc = Pmod_ident {txt}; pmod_attributes} as me), expr) - when Res_parsetree_viewer.hasAwaitAttribute pmod_attributes -> - let safe_module_type_lid : Ast_helper.lid = - {txt = Lident (local_module_type_name txt); loc = me.pmod_loc} - in - { - e with - pexp_desc = - Pexp_letmodule - ( lid, - Ast_await.create_await_module_expression - ~module_type_lid:safe_module_type_lid me, - self.expr self expr ); - } - (* module M = await (Belt.List: BeltList) *) - | Pexp_letmodule - ( lid, - ({ - pmod_desc = - Pmod_constraint - ({pmod_desc = Pmod_ident _}, {pmty_desc = Pmty_ident mtyp_lid}); - pmod_attributes; - } as me), - expr ) - when Res_parsetree_viewer.hasAwaitAttribute pmod_attributes -> - { - e with - pexp_desc = - Pexp_letmodule - ( lid, - Ast_await.create_await_module_expression ~module_type_lid:mtyp_lid - me, - self.expr self expr ); - } - | _ -> default_expr_mapper self e - -let expr_mapper ~async_context ~in_function_def (self : mapper) - (e : Parsetree.expression) = - let async_saved = !async_context in - let result = expr_mapper ~async_context ~in_function_def self e in - async_context := async_saved; - let is_module, has_await = - match e.pexp_desc with - | Pexp_letmodule (_, {pmod_desc = Pmod_ident _; pmod_attributes}, _) - | Pexp_letmodule - ( _, - { - pmod_desc = - Pmod_constraint - ({pmod_desc = Pmod_ident _}, {pmty_desc = Pmty_ident _}); - pmod_attributes; - }, - _ ) -> - (true, Ast_attributes.has_await_payload pmod_attributes) - | _ -> (false, Ast_attributes.has_await_payload e.pexp_attributes) - in - match has_await with - | None -> result - | Some _ -> - if !async_context = false then - Location.raise_errorf ~loc:e.pexp_loc - "Await on expression not in an async context"; - if is_module = false then Ast_await.create_await_expression result - else result - -let typ_mapper (self : mapper) (typ : Parsetree.core_type) = - Ast_core_type_class_type.typ_mapper self typ - -let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) : - Parsetree.signature_item = - match sigi.psig_desc with - | Psig_type (rf, tdcls) -> Ast_tdcls.handleTdclsInSigi self sigi rf tdcls - | Psig_value ({pval_attributes; pval_prim} as value_desc) -> ( - let pval_attributes = self.attributes self pval_attributes in - if Ast_attributes.rs_externals pval_attributes pval_prim then - Ast_external.handleExternalInSig self value_desc sigi - else - match Ast_attributes.has_inline_payload pval_attributes with - | Some ((_, PStr [{pstr_desc = Pstr_eval ({pexp_desc}, _)}]) as attr) -> ( - match pexp_desc with - | Pexp_constant (Pconst_string (s, dec)) -> - succeed attr pval_attributes; - { - sigi with - psig_desc = - Psig_value - { - value_desc with - pval_prim = External_ffi_types.inline_string_primitive s dec; - pval_attributes = []; - }; - } - | Pexp_constant (Pconst_integer (s, None)) -> - succeed attr pval_attributes; - let s = Int32.of_string s in - { - sigi with - psig_desc = - Psig_value - { - value_desc with - pval_prim = External_ffi_types.inline_int_primitive s; - pval_attributes = []; - }; - } - | Pexp_constant (Pconst_integer (s, Some 'L')) -> - let s = Int64.of_string s in - succeed attr pval_attributes; - { - sigi with - psig_desc = - Psig_value - { - value_desc with - pval_prim = External_ffi_types.inline_int64_primitive s; - pval_attributes = []; - }; - } - | Pexp_constant (Pconst_integer (s, Some 'n')) -> - succeed attr pval_attributes; - { - sigi with - psig_desc = - Psig_value - { - value_desc with - pval_prim = External_ffi_types.inline_bigint_primitive s; - pval_attributes = []; - }; - } - | Pexp_constant (Pconst_float (s, None)) -> - succeed attr pval_attributes; - { - sigi with - psig_desc = - Psig_value - { - value_desc with - pval_prim = External_ffi_types.inline_float_primitive s; - pval_attributes = []; - }; - } - | Pexp_construct ({txt = Lident (("true" | "false") as txt)}, None) -> - succeed attr pval_attributes; - { - sigi with - psig_desc = - Psig_value - { - value_desc with - pval_prim = - External_ffi_types.inline_bool_primitive (txt = "true"); - pval_attributes = []; - }; - } - | _ -> default_mapper.signature_item self sigi) - | Some _ | None -> default_mapper.signature_item self sigi) - | _ -> default_mapper.signature_item self sigi - -let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : - Parsetree.structure_item = - match str.pstr_desc with - | Pstr_type (rf, tdcls) (* [ {ptype_attributes} as tdcl ] *) -> - Ast_tdcls.handleTdclsInStru self str rf tdcls - | Pstr_primitive prim - when Ast_attributes.rs_externals prim.pval_attributes prim.pval_prim -> - Ast_external.handleExternalInStru self prim str - | Pstr_value - ( Nonrecursive, - [ - { - pvb_pat = {ppat_desc = Ppat_var pval_name} as pvb_pat; - pvb_expr; - pvb_attributes; - pvb_loc; - }; - ] ) -> ( - let pvb_expr = self.expr self pvb_expr in - let pvb_attributes = self.attributes self pvb_attributes in - let has_inline_property = - Ast_attributes.has_inline_payload pvb_attributes - in - match (has_inline_property, pvb_expr.pexp_desc) with - | Some attr, Pexp_constant (Pconst_string (s, dec)) -> - succeed attr pvb_attributes; - { - str with - pstr_desc = - Pstr_primitive - { - pval_name; - pval_type = Ast_literal.type_string (); - pval_loc = pvb_loc; - pval_attributes = []; - pval_prim = External_ffi_types.inline_string_primitive s dec; - }; - } - | Some attr, Pexp_constant (Pconst_integer (s, None)) -> - let s = Int32.of_string s in - succeed attr pvb_attributes; - { - str with - pstr_desc = - Pstr_primitive - { - pval_name; - pval_type = Ast_literal.type_int (); - pval_loc = pvb_loc; - pval_attributes = []; - pval_prim = External_ffi_types.inline_int_primitive s; - }; - } - | Some attr, Pexp_constant (Pconst_integer (s, Some 'L')) -> - let s = Int64.of_string s in - succeed attr pvb_attributes; - { - str with - pstr_desc = - Pstr_primitive - { - pval_name; - pval_type = Ast_literal.type_int64; - pval_loc = pvb_loc; - pval_attributes = []; - pval_prim = External_ffi_types.inline_int64_primitive s; - }; - } - | Some attr, Pexp_constant (Pconst_float (s, None)) -> - succeed attr pvb_attributes; - { - str with - pstr_desc = - Pstr_primitive - { - pval_name; - pval_type = Ast_literal.type_float; - pval_loc = pvb_loc; - pval_attributes = []; - pval_prim = External_ffi_types.inline_float_primitive s; - }; - } - | ( Some attr, - Pexp_construct ({txt = Lident (("true" | "false") as txt)}, None) ) -> - succeed attr pvb_attributes; - { - str with - pstr_desc = - Pstr_primitive - { - pval_name; - pval_type = Ast_literal.type_bool (); - pval_loc = pvb_loc; - pval_attributes = []; - pval_prim = External_ffi_types.inline_bool_primitive (txt = "true"); - }; - } - | _ -> - { - str with - pstr_desc = - Pstr_value - (Nonrecursive, [{pvb_pat; pvb_expr; pvb_attributes; pvb_loc}]); - }) - | Pstr_attribute ({txt = "bs.config" | "config"}, _) -> str - | _ -> default_mapper.structure_item self str - -let local_module_name = - let v = ref 0 in - fun () -> - incr v; - "local_" ^ string_of_int !v - -let expand_reverse (stru : Ast_structure.t) (acc : Ast_structure.t) : - Ast_structure.t = - if stru = [] then acc - else ( - Typemod_hide.check stru; - let local_module_name = local_module_name () in - let last_loc = (List.hd stru).pstr_loc in - let stru = List.rev stru in - let first_loc = (List.hd stru).pstr_loc in - let loc = {first_loc with loc_end = last_loc.loc_end} in - let open Ast_helper in - Str.module_ ~loc - { - pmb_name = {txt = local_module_name; loc}; - pmb_expr = - { - pmod_desc = Pmod_structure stru; - pmod_loc = loc; - pmod_attributes = []; - }; - pmb_attributes = Typemod_hide.attrs; - pmb_loc = loc; - } - :: Str.open_ ~loc - { - popen_lid = {txt = Lident local_module_name; loc}; - popen_override = Override; - popen_loc = loc; - popen_attributes = []; - } - :: acc) - -let rec structure_mapper ~await_context (self : mapper) (stru : Ast_structure.t) - = - match stru with - | [] -> [] - | item :: rest -> ( - match item.pstr_desc with - | Pstr_extension (({txt = "bs.raw" | "raw"; loc}, payload), _attrs) -> - Ast_exp_handle_external.handle_raw_structure loc payload - :: structure_mapper ~await_context self rest - (* | Pstr_extension (({txt = "i"}, _),_) - -> - structure_mapper self rest *) - | Pstr_extension (({txt = "private"}, _), _) -> - let rec aux acc (rest : Ast_structure.t) = - match rest with - | {pstr_desc = Pstr_extension (({txt = "private"; loc}, payload), _)} - :: next -> ( - match payload with - | PStr work -> - if List.length work = 0 then - Location.raise_errorf ~loc - {|%%%%private extension expects a definition as its argument. Example: %%%%private(let a = "Hello")|}; - aux - (Ext_list.rev_map_append work acc (fun x -> - self.structure_item self x)) - next - | PSig _ | PTyp _ | PPat _ -> - Location.raise_errorf ~loc "private extension is not support") - | _ -> expand_reverse acc (structure_mapper ~await_context self rest) - in - aux [] stru - (* Dynamic import of module transformation: module M = @res.await Belt.List *) - | Pstr_module - ({pmb_expr = {pmod_desc = Pmod_ident {txt; loc}; pmod_attributes} as me} - as mb) - when Res_parsetree_viewer.hasAwaitAttribute pmod_attributes -> - let item = self.structure_item self item in - let safe_module_type_name = local_module_type_name txt in - let has_local_module_name = - Hashtbl.find_opt !await_context safe_module_type_name - in - (* module __Belt_List__ = module type of Belt.List *) - let module_type_decl = - match has_local_module_name with - | Some _ -> [] - | None -> - Hashtbl.add !await_context safe_module_type_name safe_module_type_name; - [ - Ast_helper.( - Str.modtype ~loc - (Mtd.mk ~loc - {txt = safe_module_type_name; loc} - ~typ:(Mty.typeof_ ~loc me))); - ] - in - let safe_module_type_lid : Ast_helper.lid = - {txt = Lident safe_module_type_name; loc = mb.pmb_expr.pmod_loc} - in - module_type_decl - @ (* module M = @res.await Belt.List *) - { - item with - pstr_desc = - Pstr_module - { - mb with - pmb_expr = - Ast_await.create_await_module_expression - ~module_type_lid:safe_module_type_lid mb.pmb_expr; - }; - } - :: structure_mapper ~await_context self rest - | Pstr_value (_, vbs) -> - let item = self.structure_item self item in - (* [ module __Belt_List__ = module type of Belt.List ] *) - let rec spelunk_vbs acc vbs = - match vbs with - | [] -> acc - | ({pvb_expr} : Parsetree.value_binding) :: tl -> - let rec aux (expr : Parsetree.expression) = - match expr.pexp_desc with - | Pexp_letmodule - ( _, - ({pmod_desc = Pmod_ident {txt; loc}; pmod_attributes} as me), - expr ) - when Res_parsetree_viewer.hasAwaitAttribute pmod_attributes -> ( - let safe_module_type_name = local_module_type_name txt in - let has_local_module_name = - Hashtbl.find_opt !await_context safe_module_type_name - in - - match has_local_module_name with - | Some _ -> aux expr - | None -> - Hashtbl.add !await_context safe_module_type_name - safe_module_type_name; - Ast_helper.( - Str.modtype ~loc - (Mtd.mk ~loc - {txt = safe_module_type_name; loc} - ~typ:(Mty.typeof_ ~loc me))) - :: aux expr) - | Pexp_let (_, vbs, expr) -> aux expr @ spelunk_vbs acc vbs - | Pexp_ifthenelse (_, then_expr, Some else_expr) -> - aux then_expr @ aux else_expr - | Pexp_construct (_, Some expr) -> aux expr - | Pexp_fun (_, _, _, expr) | Pexp_newtype (_, expr) -> aux expr - | _ -> acc - in - aux pvb_expr @ spelunk_vbs acc tl - in - let module_type_decls = spelunk_vbs [] vbs in - - module_type_decls @ (item :: structure_mapper ~await_context self rest) - | _ -> - self.structure_item self item :: structure_mapper ~await_context self rest - ) - -let structure_mapper ~await_context (self : mapper) (stru : Ast_structure.t) = - let await_saved = !await_context in - let result = - structure_mapper ~await_context:(ref (Hashtbl.create 10)) self stru - in - await_context := await_saved; - result - -let mapper : mapper = - { - default_mapper with - expr = expr_mapper ~async_context:(ref true) ~in_function_def:(ref false); - pat = pat_mapper; - typ = typ_mapper; - signature_item = signature_item_mapper; - value_bindings = Ast_tuple_pattern_flatten.value_bindings_mapper; - structure_item = structure_item_mapper; - structure = structure_mapper ~await_context:(ref (Hashtbl.create 10)); - (* Ad-hoc way to internalize stuff *) - label_declaration = - (fun self lbl -> - let lbl = default_mapper.label_declaration self lbl in - match lbl.pld_attributes with - | [({txt = "internal"}, _)] -> - { - lbl with - pld_name = - {lbl.pld_name with txt = String.capitalize_ascii lbl.pld_name.txt}; - pld_attributes = []; - } - | _ -> lbl); - } diff --git a/jscomp/frontend/bs_builtin_ppx.mli b/jscomp/frontend/bs_builtin_ppx.mli deleted file mode 100644 index 0508221..0000000 --- a/jscomp/frontend/bs_builtin_ppx.mli +++ /dev/null @@ -1,57 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val mapper : Bs_ast_mapper.mapper - -(* object - for setter : we can push more into [Lsend] and enclose it with a unit type - - for getter : - - (* Invariant: we expect the typechecker & lambda emitter - will not do agressive inlining - Worst things could happen - {[ - let x = y## case 3 in - x 2 - ]} - in normal case, it should be compiled into Lambda - {[ - let x = Lsend(y,case, [3]) in - Lapp(x,2) - ]} - - worst: - {[ Lsend(y, case, [3,2]) - ]} - for setter(include case setter), this could - be prevented by type system, for getter. - - solution: we can prevent this by rewrite into - {[ - Fn.run1 (!x# case) v -]} - *) - - *) diff --git a/jscomp/frontend/bs_syntaxerr.ml b/jscomp/frontend/bs_syntaxerr.ml deleted file mode 100644 index c143ea6..0000000 --- a/jscomp/frontend/bs_syntaxerr.ml +++ /dev/null @@ -1,119 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type untaggedVariant = OnlyOneUnknown | AtMostOneObject | AtMostOneArray - -type error = - | Unsupported_predicates - | Conflict_bs_bs_this_bs_meth - | Duplicated_bs_deriving - | Conflict_attributes - | Expect_int_literal - | Expect_string_literal - | Expect_int_or_string_or_json_literal - | Unhandled_poly_type - | Unregistered of string - | Invalid_underscore_type_in_external - | Invalid_bs_string_type - | Invalid_bs_int_type - | Invalid_bs_unwrap_type - | Conflict_ffi_attribute of string - | Not_supported_in_bs_deriving - | Canot_infer_arity_by_syntax - | Illegal_attribute - | Inconsistent_arity of int * int - (* we still rqeuire users to have explicit annotation to avoid - {[ (((int -> int) -> int) -> int )]} - *) - | Not_supported_directive_in_bs_return - | Expect_opt_in_bs_return_to_opt - | Misplaced_label_syntax - | Optional_in_uncurried_bs_attribute - | Bs_this_simple_pattern - | Bs_uncurried_arity_too_large - -let pp_error fmt err = - Format.pp_print_string fmt - (match err with - | Bs_uncurried_arity_too_large -> - "Uncurried function supports only up to arity 22" - | Misplaced_label_syntax -> "Label syntax is not support in this position" - (* - let fn x = ((##) x ~hi) ~lo:1 ~hi:2 - *) - | Optional_in_uncurried_bs_attribute -> - "Uncurried function doesn't support optional arguments yet" - | Expect_opt_in_bs_return_to_opt -> - "%@return directive *_to_opt expect return type to be \n\ - syntax wise `_ option` for safety" - | Not_supported_directive_in_bs_return -> "Not supported return directive" - | Illegal_attribute -> "Illegal attributes" - | Canot_infer_arity_by_syntax -> - "Cannot infer the arity through the syntax, either [%@uncurry n] or \n\ - write it in arrow syntax " - | Inconsistent_arity (arity, n) -> - Printf.sprintf "Inconsistent arity %d vs %d" arity n - | Not_supported_in_bs_deriving -> "not supported in deriving" - | Unsupported_predicates -> "unsupported predicates" - | Conflict_bs_bs_this_bs_meth -> - "%@this, %@bs, %@meth can not be applied at the same time" - | Duplicated_bs_deriving -> "duplicate bs.deriving attribute" - | Conflict_attributes -> "conflicting attributes " - | Expect_string_literal -> "expect string literal " - | Expect_int_literal -> "expect int literal " - | Expect_int_or_string_or_json_literal -> - "expect int, string literal or json literal {json|text here|json} " - | Unhandled_poly_type -> "Unhandled poly type" - | Unregistered str -> "Unregistered " ^ str - | Invalid_underscore_type_in_external -> - "_ is not allowed in combination with external optional type" - | Invalid_bs_string_type -> "Not a valid type for %@string" - | Invalid_bs_int_type -> "Not a valid type for %@int" - | Invalid_bs_unwrap_type -> - "Not a valid type for %@unwrap. Type must be an inline variant (closed), \ - and\n\ - each constructor must have an argument." - | Conflict_ffi_attribute str -> "Conflicting attributes: " ^ str - | Bs_this_simple_pattern -> - "%@this expect its pattern variable to be simple form") - -type exn += Error of Location.t * error - -let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (Location.error_of_printer loc pp_error err) - | _ -> None) - -let err loc error = raise (Error (loc, error)) - -let optional_err loc (lbl : Asttypes.arg_label) = - match lbl with - | Optional _ -> raise (Error (loc, Optional_in_uncurried_bs_attribute)) - | _ -> () - -let err_if_label loc (lbl : Asttypes.arg_label) = - if lbl <> Nolabel then raise (Error (loc, Misplaced_label_syntax)) - -let err_large_arity loc arity = - if arity > 22 then raise (Error (loc, Bs_uncurried_arity_too_large)) diff --git a/jscomp/frontend/bs_syntaxerr.mli b/jscomp/frontend/bs_syntaxerr.mli deleted file mode 100644 index bf19891..0000000 --- a/jscomp/frontend/bs_syntaxerr.mli +++ /dev/null @@ -1,62 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type untaggedVariant = OnlyOneUnknown | AtMostOneObject | AtMostOneArray - -type error = - | Unsupported_predicates - | Conflict_bs_bs_this_bs_meth - | Duplicated_bs_deriving - | Conflict_attributes - | Expect_int_literal - | Expect_string_literal - | Expect_int_or_string_or_json_literal - | Unhandled_poly_type - | Unregistered of string - | Invalid_underscore_type_in_external - | Invalid_bs_string_type - | Invalid_bs_int_type - | Invalid_bs_unwrap_type - | Conflict_ffi_attribute of string - | Not_supported_in_bs_deriving - | Canot_infer_arity_by_syntax - | Illegal_attribute - | Inconsistent_arity of int * int - (* we still rqeuire users to have explicit annotation to avoid - {[ (((int -> int) -> int) -> int )]} - *) - | Not_supported_directive_in_bs_return - | Expect_opt_in_bs_return_to_opt - | Misplaced_label_syntax - | Optional_in_uncurried_bs_attribute - | Bs_this_simple_pattern - | Bs_uncurried_arity_too_large - -val err : Location.t -> error -> 'a - -val optional_err : Location.t -> Asttypes.arg_label -> unit - -val err_if_label : Location.t -> Asttypes.arg_label -> unit - -val err_large_arity : Location.t -> int -> unit diff --git a/jscomp/frontend/dune b/jscomp/frontend/dune deleted file mode 100644 index 3b5b5b1..0000000 --- a/jscomp/frontend/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name frontend) - (wrapped false) - (flags - (:standard -w -A)) - (libraries common ml)) diff --git a/jscomp/frontend/external_arg_spec.ml b/jscomp/frontend/external_arg_spec.ml deleted file mode 100644 index 4f3051a..0000000 --- a/jscomp/frontend/external_arg_spec.ml +++ /dev/null @@ -1,85 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** type definitions for arguments to a function declared external *) - -type delim = DNone | DStarJ | DNoQuotes - -type cst = Arg_int_lit of int | Arg_string_lit of string * delim - -type label_noname = Arg_label | Arg_empty | Arg_optional - -type label = - | Obj_empty - | Obj_label of {name: string} - | Obj_optional of {name: string; for_sure_no_nested_option: bool} - -(* it will be ignored , side effect will be recorded *) - -(* This type is used to give some meta info on each argument *) -type attr = - | Poly_var_string of { - descr: (string * string) list; - (* introduced by attributes @string - and @as - *) - } - | Poly_var of { - descr: (string * string) list option; - (* introduced by attributes @string - and @as - *) - } - (* `a does not have any value*) - | Int of (string * int) list (* ([`a | `b ] [@int])*) - | Arg_cst of cst - | Fn_uncurry_arity of int (* annotated with [@uncurry ] or [@uncurry 2]*) - (* maybe we can improve it as a combination of {!Asttypes.constant} and tuple *) - | Extern_unit - | Nothing - | Ignore - | Unwrap - -type param = {arg_type: attr; arg_label: label_noname} - -type obj_param = {obj_arg_type: attr; obj_arg_label: label} - -type obj_params = obj_param list - -type params = param list - -let cst_int i = Arg_int_lit i - -let cst_string s delim = Arg_string_lit (s, delim) - -let empty_label = Obj_empty - -let obj_label name = Obj_label {name} - -let optional for_sure_no_nested_option name = - Obj_optional {name; for_sure_no_nested_option} - -let empty_kind obj_arg_type = {obj_arg_label = empty_label; obj_arg_type} - -let dummy = {arg_type = Nothing; arg_label = Arg_empty} diff --git a/jscomp/frontend/external_arg_spec.mli b/jscomp/frontend/external_arg_spec.mli deleted file mode 100644 index 85ba36e..0000000 --- a/jscomp/frontend/external_arg_spec.mli +++ /dev/null @@ -1,71 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type delim = DNone | DStarJ | DNoQuotes - -type cst = private Arg_int_lit of int | Arg_string_lit of string * delim - -type attr = - | Poly_var_string of {descr: (string * string) list} - | Poly_var of {descr: (string * string) list option} - | Int of (string * int) list (* ([`a | `b ] [@bs.int])*) - | Arg_cst of cst - | Fn_uncurry_arity of - int (* annotated with [@bs.uncurry ] or [@bs.uncurry 2]*) - (* maybe we can improve it as a combination of {!Asttypes.constant} and tuple *) - | Extern_unit - | Nothing - | Ignore - | Unwrap - -type label_noname = Arg_label | Arg_empty | Arg_optional - -type label = private - | Obj_empty - | Obj_label of {name: string} - | Obj_optional of {name: string; for_sure_no_nested_option: bool} -(* it will be ignored , side effect will be recorded *) - -type obj_param = {obj_arg_type: attr; obj_arg_label: label} - -type param = {arg_type: attr; arg_label: label_noname} - -type obj_params = obj_param list - -type params = param list - -val cst_int : int -> cst - -val cst_string : string -> delim -> cst - -val empty_label : label - -(* val empty_lit : cst -> label *) -val obj_label : string -> label - -val optional : bool -> string -> label - -val empty_kind : attr -> obj_param - -val dummy : param diff --git a/jscomp/frontend/external_ffi_types.ml b/jscomp/frontend/external_ffi_types.ml deleted file mode 100644 index 1acc82d..0000000 --- a/jscomp/frontend/external_ffi_types.ml +++ /dev/null @@ -1,328 +0,0 @@ -(* Copyright (C) 2015 - 2016 Bloomberg Finance L.P. - * Copyright (C) 2017 - Hongbo Zhang, Authors of ReScript - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -[@@@warning "+9"] -type module_bind_name = - | Phint_name of string - (* explicit hint name *) - | Phint_nothing - -type import_attributes = (string, string) Hashtbl.t - -type external_module_name = { - bundle: string; - module_bind_name: module_bind_name; - import_attributes: import_attributes option; -} - -type arg_type = External_arg_spec.attr -(** TODO: information between [arg_type] and [arg_label] are duplicated, - design a more compact representation so that it is also easy to seralize by hand -*) - -type arg_label = External_arg_spec.label - -type external_spec = - | Js_var of { - name: string; - external_module_name: external_module_name option; - scopes: string list; - } - | Js_module_as_var of external_module_name - | Js_module_as_fn of { - external_module_name: external_module_name; - splice: bool; - } - | Js_module_as_class of external_module_name - | Js_call of { - name: string; - external_module_name: external_module_name option; - splice: bool; - scopes: string list; - tagged_template: bool; - } - | Js_send of {name: string; splice: bool; js_send_scopes: string list} - (* we know it is a js send, but what will happen if you pass an ocaml objct *) - | Js_new of { - name: string; - external_module_name: external_module_name option; - splice: bool; - scopes: string list; - } - | Js_set of {js_set_name: string; js_set_scopes: string list} - | Js_get of {js_get_name: string; js_get_scopes: string list} - | Js_get_index of {js_get_index_scopes: string list} - | Js_set_index of {js_set_index_scopes: string list} - -(* let not_inlineable (x : external_spec) = *) - -(* let name_of_ffi ffi = - match ffi with - | Js_get_index _scope -> "@get_index .." - | Js_set_index _scope -> "@set_index .." - | Js_get { js_get_name = s} -> Printf.sprintf "[@@get %S]" s - | Js_set { js_set_name = s} -> Printf.sprintf "[@@set %S]" s - | Js_call v -> Printf.sprintf "[@@val %S]" v.name - | Js_send v -> Printf.sprintf "[@@send %S]" v.name - | Js_module_as_fn v -> Printf.sprintf "[@@val %S]" v.external_module_name.bundle - | Js_new v -> Printf.sprintf "[@@new %S]" v.name - | Js_module_as_class v - -> Printf.sprintf "[@@module] %S " v.bundle - | Js_module_as_var v - -> - Printf.sprintf "[@@module] %S " v.bundle - | Js_var v (* FIXME: could be [@@module "xx"] as well *) - -> - Printf.sprintf "[@@val] %S " v.name *) - -type return_wrapper = - | Return_unset - | Return_identity - | Return_undefined_to_opt - | Return_null_to_opt - | Return_null_undefined_to_opt - | Return_replaced_with_unit - -type params = Params of External_arg_spec.params | Param_number of int - -type t = - | Ffi_bs of params * return_wrapper * external_spec - (** [Ffi_bs(args,return,attr) ] - [return] means return value is unit or not, - [true] means is [unit] - *) - | Ffi_obj_create of External_arg_spec.obj_params - | Ffi_inline_const of Lam_constant.t - | Ffi_normal -(* When it's normal, it is handled as normal c functional ffi call *) - -let valid_js_char = - let a = - Array.init 256 (fun i -> - let c = Char.chr i in - (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || (c >= '0' && c <= '9') - || c = '_' || c = '$') - in - fun c -> Array.unsafe_get a (Char.code c) - -let valid_first_js_char = - let a = - Array.init 256 (fun i -> - let c = Char.chr i in - (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || c = '_' || c = '$') - in - fun c -> Array.unsafe_get a (Char.code c) - -(** Approximation could be improved *) -let valid_ident (s : string) = - let len = String.length s in - len > 0 - && valid_js_char s.[0] - && valid_first_js_char s.[0] - && - let exception E in - try - for i = 1 to len - 1 do - if not (valid_js_char (String.unsafe_get s i)) then raise_notrace E - done; - true - with E -> false - -let is_package_relative_path (x : string) = - Ext_string.starts_with x "./" || Ext_string.starts_with x "../" - -let valid_global_name ?loc txt = - if not (valid_ident txt) then - let v = Ext_string.split_by ~keep_empty:true (fun x -> x = '.') txt in - Ext_list.iter v (fun s -> - if not (valid_ident s) then - Location.raise_errorf ?loc "Not a valid global name %s" txt) - -(* - We loose such check (see #2583), - it also helps with the implementation deriving abstract [@as] -*) - -let valid_method_name ?loc:_ _txt = () -(* if not (valid_ident txt) then - Location.raise_errorf ?loc "Not a valid method name %s" txt *) - -let check_external_module_name ?loc x = - match x with - | {bundle = ""; _} | {module_bind_name = Phint_name ""; bundle = _; _} -> - Location.raise_errorf ?loc "empty name encountered" - | _ -> () - -let check_ffi ?loc ffi : bool = - let xrelative = ref false in - let upgrade bool = if not !xrelative then xrelative := bool in - (match ffi with - | Js_var {name; external_module_name; scopes = _} -> - upgrade (is_package_relative_path name); - Ext_option.iter external_module_name (fun name -> - upgrade (is_package_relative_path name.bundle)); - valid_global_name ?loc name - | Js_send {name; splice = _; js_send_scopes = _} - | Js_set {js_set_name = name; js_set_scopes = _} - | Js_get {js_get_name = name; js_get_scopes = _} -> - valid_method_name ?loc name - | Js_get_index _ (* TODO: check scopes *) | Js_set_index _ -> () - | Js_module_as_var external_module_name - | Js_module_as_fn {external_module_name; splice = _} - | Js_module_as_class external_module_name -> - upgrade (is_package_relative_path external_module_name.bundle); - check_external_module_name external_module_name - | Js_new {external_module_name; name; splice = _; scopes = _} - | Js_call - {external_module_name; name; splice = _; scopes = _; tagged_template = _} - -> - Ext_option.iter external_module_name (fun external_module_name -> - upgrade (is_package_relative_path external_module_name.bundle)); - Ext_option.iter external_module_name (fun name -> - check_external_module_name ?loc name); - - valid_global_name ?loc name); - !xrelative - -(* let bs_prefix = "BS:" - let bs_prefix_length = String.length bs_prefix -*) - -(** TODO: Make sure each version is not prefix of each other - Solution: - 1. fixed length - 2. non-prefix approach -*) -(* let bs_external = bs_prefix *) - -(* let bs_external_length = String.length bs_external *) - -let to_string (t : t) = Marshal.to_string t [] - -(* \132\149\166\190 - 0x84 95 A6 BE Intext_magic_small intext.h - https://github.com/ocaml/merlin/commit/b094c937c3a360eb61054f7652081b88e4f3612f -*) -let is_bs_primitive s = - String.length s >= 20 - (* Marshal.header_size*) && String.unsafe_get s 0 = '\132' - && String.unsafe_get s 1 = '\149' - -let () = - Oprint.map_primitive_name := - fun s -> if is_bs_primitive s then "BS:external" else s - -(* TODO: better error message when version mismatch *) -let from_string s : t = - if is_bs_primitive s then Ext_marshal.from_string s else Ffi_normal - -let () = - Primitive.coerce := - fun ({ - prim_name; - prim_arity; - prim_native_name; - prim_alloc = _; - prim_native_repr_args = _; - prim_native_repr_res = _; - } : - Primitive.description) (p2 : Primitive.description) -> - let p2_native = p2.prim_native_name in - prim_name = p2.prim_name && prim_arity = p2.prim_arity - && prim_native_name = p2_native - || - match (from_string prim_native_name, from_string p2_native) with - | Ffi_obj_create obj_parms, Ffi_obj_create obj_parms2 -> - Ext_list.for_all2_no_exn obj_parms obj_parms2 - (fun {obj_arg_type; obj_arg_label} b -> - let b_obj_arg_label = b.obj_arg_label in - obj_arg_type = b.obj_arg_type - && (obj_arg_label = b_obj_arg_label - || - match (obj_arg_label, b_obj_arg_label) with - | Obj_optional {name; for_sure_no_nested_option}, Obj_optional p - -> - name = p.name - && (Obj.magic for_sure_no_nested_option : int) - <= Obj.magic p.for_sure_no_nested_option - | _ -> false)) - | Ffi_bs _, Ffi_bs _ -> false - | _ -> false -let inline_string_primitive (s : string) (op : string option) : string list = - let lam : Lam_constant.t = - let unicode = - match op with - | Some op -> Ast_utf8_string_interp.is_unicode_string op - | None -> false - in - Const_string {s; unicode} - in - [""; to_string (Ffi_inline_const lam)] - -(* Let's only do it for string ATM - for boolean, and ints, a good optimizer should - do it by default? - But it may not work after layers of indirection - e.g, submodule -*) -let inline_bool_primitive b : string list = - let lam : Lam_constant.t = - if b then Lam_constant.Const_js_true else Lam_constant.Const_js_false - in - [""; to_string (Ffi_inline_const lam)] - -(* FIXME: check overflow ?*) -let inline_int_primitive (i : int32) : string list = - [""; to_string (Ffi_inline_const (Const_int {i; comment = None}))] - -let inline_int64_primitive (i : int64) : string list = - [""; to_string (Ffi_inline_const (Const_int64 i))] - -let inline_bigint_primitive (i : string) : string list = - let sign, i = Bigint_utils.parse_bigint i in - [""; to_string (Ffi_inline_const (Const_bigint (sign, i)))] - -let inline_float_primitive (i : string) : string list = - [""; to_string (Ffi_inline_const (Const_float i))] -let rec ffi_bs_aux acc (params : External_arg_spec.params) = - match params with - | {arg_type = Nothing; arg_label = Arg_empty} - (* same as External_arg_spec.dummy*) - :: rest -> - ffi_bs_aux (acc + 1) rest - | _ :: _ -> -1 - | [] -> acc - -let ffi_bs (params : External_arg_spec.params) return attr = - let n = ffi_bs_aux 0 params in - if n < 0 then Ffi_bs (Params params, return, attr) - else Ffi_bs (Param_number n, return, attr) - -let ffi_bs_as_prims params return attr = - [""; to_string (ffi_bs params return attr)] - -let ffi_obj_create obj_params = Ffi_obj_create obj_params - -let ffi_obj_as_prims obj_params = [""; to_string (Ffi_obj_create obj_params)] diff --git a/jscomp/frontend/external_ffi_types.mli b/jscomp/frontend/external_ffi_types.mli deleted file mode 100644 index a96c06c..0000000 --- a/jscomp/frontend/external_ffi_types.mli +++ /dev/null @@ -1,119 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type module_bind_name = - | Phint_name of string - (* explicit hint name *) - | Phint_nothing - -type import_attributes = (string, string) Hashtbl.t - -type external_module_name = { - bundle: string; - module_bind_name: module_bind_name; - import_attributes: import_attributes option; -} - -type arg_type = External_arg_spec.attr - -type arg_label = External_arg_spec.label - -type external_spec = - | Js_var of { - name: string; - external_module_name: external_module_name option; - scopes: string list; - } - | Js_module_as_var of external_module_name - | Js_module_as_fn of { - external_module_name: external_module_name; - splice: bool; - } - | Js_module_as_class of external_module_name - | Js_call of { - name: string; - external_module_name: external_module_name option; - splice: bool; - scopes: string list; - tagged_template: bool; - } - | Js_send of {name: string; splice: bool; js_send_scopes: string list} - (* we know it is a js send, but what will happen if you pass an ocaml objct *) - | Js_new of { - name: string; - external_module_name: external_module_name option; - splice: bool; - scopes: string list; - } - | Js_set of {js_set_name: string; js_set_scopes: string list} - | Js_get of {js_get_name: string; js_get_scopes: string list} - | Js_get_index of {js_get_index_scopes: string list} - | Js_set_index of {js_set_index_scopes: string list} - -type return_wrapper = - | Return_unset - | Return_identity - | Return_undefined_to_opt - | Return_null_to_opt - | Return_null_undefined_to_opt - | Return_replaced_with_unit - -type params = Params of External_arg_spec.params | Param_number of int - -type t = private - | Ffi_bs of params * return_wrapper * external_spec - | Ffi_obj_create of External_arg_spec.obj_params - | Ffi_inline_const of Lam_constant.t - | Ffi_normal -(* When it's normal, it is handled as normal c functional ffi call *) - -(* val name_of_ffi : external_spec -> string *) - -val check_ffi : ?loc:Location.t -> external_spec -> bool - -val to_string : t -> string - -val from_string : string -> t -(** Note *) - -val inline_string_primitive : string -> string option -> string list - -val inline_bool_primitive : bool -> string list - -val inline_int_primitive : int32 -> string list - -val inline_int64_primitive : int64 -> string list - -val inline_float_primitive : string -> string list - -val inline_bigint_primitive : string -> string list - -val ffi_bs : External_arg_spec.params -> return_wrapper -> external_spec -> t - -val ffi_bs_as_prims : - External_arg_spec.params -> return_wrapper -> external_spec -> string list - -val ffi_obj_create : External_arg_spec.obj_params -> t - -val ffi_obj_as_prims : External_arg_spec.obj_params -> string list diff --git a/jscomp/frontend/lam_constant.ml b/jscomp/frontend/lam_constant.ml deleted file mode 100644 index 7985af2..0000000 --- a/jscomp/frontend/lam_constant.ml +++ /dev/null @@ -1,112 +0,0 @@ -(* Copyright (C) 2018- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type constructor_tag = { - cstr_name: Ast_untagged_variants.tag; - const: int; - non_const: int; -} - -type pointer_info = - | None - | Pt_constructor of constructor_tag - | Pt_assertfalse - | Some of string - -let string_of_pointer_info (x : pointer_info) : string option = - match x with - | Some name | Pt_constructor {cstr_name = {name}; _} -> Some name - | Pt_assertfalse -> Some "assert_false" - | None -> None - -type t = - | Const_js_null - | Const_js_undefined of {isUnit: bool} - | Const_js_true - | Const_js_false - | Const_int of {i: int32; comment: pointer_info} - | Const_char of int - | Const_string of {s: string; unicode: bool} - | Const_float of string - | Const_int64 of int64 - | Const_bigint of bool * string - | Const_pointer of string - | Const_block of int * Lambda.tag_info * t list - | Const_float_array of string list - | Const_some of t - | Const_module_alias -(* eventually we can remove it, since we know - [constant] is [undefined] or not -*) - -let rec eq_approx (x : t) (y : t) = - match x with - | Const_module_alias -> y = Const_module_alias - | Const_js_null -> y = Const_js_null - | Const_js_undefined b -> y = Const_js_undefined b - | Const_js_true -> y = Const_js_true - | Const_js_false -> y = Const_js_false - | Const_int ix -> ( - match y with - | Const_int iy -> ix.i = iy.i - | _ -> false) - | Const_char ix -> ( - match y with - | Const_char iy -> ix = iy - | _ -> false) - | Const_string {s = sx; unicode = ux} -> ( - match y with - | Const_string {s = sy; unicode = uy} -> sx = sy && ux = uy - | _ -> false) - | Const_float ix -> ( - match y with - | Const_float iy -> ix = iy - | _ -> false) - | Const_int64 ix -> ( - match y with - | Const_int64 iy -> ix = iy - | _ -> false) - | Const_bigint (sx, ix) -> ( - match y with - | Const_bigint (sy, iy) -> sx = sy && ix = iy - | _ -> false) - | Const_pointer ix -> ( - match y with - | Const_pointer iy -> ix = iy - | _ -> false) - | Const_block (ix, _, ixs) -> ( - match y with - | Const_block (iy, _, iys) -> - ix = iy && Ext_list.for_all2_no_exn ixs iys eq_approx - | _ -> false) - | Const_float_array ixs -> ( - match y with - | Const_float_array iys -> Ext_list.for_all2_no_exn ixs iys Ext_string.equal - | _ -> false) - | Const_some ix -> ( - match y with - | Const_some iy -> eq_approx ix iy - | _ -> false) - -let lam_none : t = Const_js_undefined {isUnit = false} diff --git a/jscomp/frontend/lam_constant.mli b/jscomp/frontend/lam_constant.mli deleted file mode 100644 index 2514b1d..0000000 --- a/jscomp/frontend/lam_constant.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* Copyright (C) 2018 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type constructor_tag = { - cstr_name: Ast_untagged_variants.tag; - const: int; - non_const: int; -} - -type pointer_info = - | None - | Pt_constructor of constructor_tag - | Pt_assertfalse - | Some of string - -val string_of_pointer_info : pointer_info -> string option - -type t = - | Const_js_null - | Const_js_undefined of {isUnit: bool} - | Const_js_true - | Const_js_false - | Const_int of {i: int32; comment: pointer_info} - | Const_char of int - | Const_string of {s: string; unicode: bool} - | Const_float of string - | Const_int64 of int64 - | Const_bigint of bool * string - | Const_pointer of string - | Const_block of int * Lambda.tag_info * t list - | Const_float_array of string list - | Const_some of t - (* eventually we can remove it, since we know - [constant] is [undefined] or not - *) - | Const_module_alias - -val eq_approx : t -> t -> bool - -val lam_none : t diff --git a/jscomp/frontend/ppx_apply.ml b/jscomp/frontend/ppx_apply.ml deleted file mode 100644 index 4a3570f..0000000 --- a/jscomp/frontend/ppx_apply.ml +++ /dev/null @@ -1,49 +0,0 @@ -(* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let apply_lazy ~source ~target - (impl : Parsetree.structure -> Parsetree.structure) - (iface : Parsetree.signature -> Parsetree.signature) = - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - if - magic <> Config.ast_impl_magic_number - && magic <> Config.ast_intf_magic_number - then failwith "Bs_ast_mapper: OCaml version mismatch or malformed input"; - Location.set_input_name @@ input_value ic; - let ast = input_value ic in - close_in ic; - - let ast = - if magic = Config.ast_impl_magic_number then - Obj.magic (impl (Obj.magic ast)) - else Obj.magic (iface (Obj.magic ast)) - in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc diff --git a/jscomp/frontend/ppx_driver.ml b/jscomp/frontend/ppx_driver.ml deleted file mode 100644 index cb47900..0000000 --- a/jscomp/frontend/ppx_driver.ml +++ /dev/null @@ -1,56 +0,0 @@ -(* Copyright (C) 2019- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let usage = "Usage: [prog] [extra_args] \n%!" - -let main impl intf = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then ( - Arg.parse_argv - (Array.sub Sys.argv 0 (n - 2)) - [ - ( "-bs-jsx", - Arg.Int - (fun i -> Js_config.jsx_version := Js_config.jsx_version_of_int i), - " Set jsx version" ); - ( "-bs-jsx-module", - Arg.String - (fun i -> - Js_config.jsx_module := Js_config.jsx_module_of_string i), - " Set jsx module" ); - ( "-bs-jsx-mode", - Arg.String - (fun i -> Js_config.jsx_mode := Js_config.jsx_mode_of_string i), - " Set jsx mode" ); - ] - ignore usage; - Ppx_apply.apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) impl intf) - else ( - Printf.eprintf "%s" usage; - exit 2) - with exn -> - Location.report_exception Format.err_formatter exn; - exit 2 diff --git a/jscomp/frontend/ppx_driver.mli b/jscomp/frontend/ppx_driver.mli deleted file mode 100644 index 03930a4..0000000 --- a/jscomp/frontend/ppx_driver.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* Copyright (C) 2019- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val main : - (Parsetree.structure -> Parsetree.structure) -> - (Parsetree.signature -> Parsetree.signature) -> - unit diff --git a/jscomp/frontend/ppx_entry.ml b/jscomp/frontend/ppx_entry.ml deleted file mode 100644 index 67d50bb..0000000 --- a/jscomp/frontend/ppx_entry.ml +++ /dev/null @@ -1,65 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let unsafe_mapper = Bs_builtin_ppx.mapper - -let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature = - Bs_ast_invariant.iter_warnings_on_sigi ast; - Ast_config.process_sig ast; - let ast = - match !Js_config.jsx_version with - | None -> ast - | Some jsxVersion -> - let open Js_config in - let jsxVersion = int_of_jsx_version jsxVersion in - let jsxModule = string_of_jsx_module !jsx_module in - let jsxMode = string_of_jsx_mode !jsx_mode in - Jsx_ppx.rewrite_signature ~jsxVersion ~jsxModule ~jsxMode ast - in - if !Js_config.no_builtin_ppx then ast - else - let result = unsafe_mapper.signature unsafe_mapper ast in - (* Keep this check, since the check is not inexpensive*) - Bs_ast_invariant.emit_external_warnings_on_signature result; - result - -let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure = - Bs_ast_invariant.iter_warnings_on_stru ast; - Ast_config.process_str ast; - let ast = - match !Js_config.jsx_version with - | None -> ast - | Some jsxVersion -> - let open Js_config in - let jsxVersion = int_of_jsx_version jsxVersion in - let jsxModule = string_of_jsx_module !jsx_module in - let jsxMode = string_of_jsx_mode !jsx_mode in - Jsx_ppx.rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode ast - in - if !Js_config.no_builtin_ppx then ast - else - let result = unsafe_mapper.structure unsafe_mapper ast in - (* Keep this check since it is not inexpensive*) - Bs_ast_invariant.emit_external_warnings_on_structure result; - result diff --git a/jscomp/frontend/typemod_hide.ml b/jscomp/frontend/typemod_hide.ml deleted file mode 100644 index 0dccdaa..0000000 --- a/jscomp/frontend/typemod_hide.ml +++ /dev/null @@ -1,58 +0,0 @@ -(* Copyright (C) 2020 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -let attrs : Parsetree.attributes = - [({txt = "internal.local"; loc = Location.none}, PStr [])] - -let no_type_defined (x : Parsetree.structure_item) = - match x.pstr_desc with - | Pstr_eval _ | Pstr_value _ | Pstr_primitive _ | Pstr_typext _ - | Pstr_exception _ - (* | Pstr_module {pmb_expr = {pmod_desc = Pmod_ident _} } *) -> - true - | Pstr_include - { - pincl_mod = - { - pmod_desc = - Pmod_constraint - ( {pmod_desc = Pmod_structure [{pstr_desc = Pstr_primitive _}]}, - _ ); - }; - } -> - true - (* FIX #4881 - generated code from: - {[ - external %private x : int -> int = "x" - [@@bs.module "./x"] - ]} - *) - | _ -> false - -let check (x : Parsetree.structure) = - Ext_list.iter x (fun x -> - if not (no_type_defined x) then - Location.raise_errorf ~loc:x.pstr_loc - "the structure is not supported in local extension") diff --git a/jscomp/gentype/Annotation.ml b/jscomp/gentype/Annotation.ml deleted file mode 100644 index 0bcb24e..0000000 --- a/jscomp/gentype/Annotation.ml +++ /dev/null @@ -1,298 +0,0 @@ -type import = {importPath: ImportPath.t} - -type attributePayload = - | BoolPayload of bool - | FloatPayload of string - | IdentPayload of Longident.t - | IntPayload of string - | StringPayload of string - | TuplePayload of attributePayload list - | UnrecognizedPayload - -type t = GenType | GenTypeOpaque | NoGenType - -let toString annotation = - match annotation with - | GenType -> "GenType" - | GenTypeOpaque -> "GenTypeOpaque" - | NoGenType -> "NoGenType" - -let tagIsGenType s = s = "genType" || s = "gentype" -let tagIsGenTypeAs s = s = "genType.as" || s = "gentype.as" -let tagIsAs s = s = "bs.as" || s = "as" -let tagIsInt s = s = "bs.int" || s = "int" -let tagIsString s = s = "bs.string" || s = "string" - -let tagIsTag s = s = "tag" - -let tagIsUnboxed s = s = "unboxed" || s = "ocaml.unboxed" -let tagIsGenTypeImport s = s = "genType.import" || s = "gentype.import" -let tagIsGenTypeOpaque s = s = "genType.opaque" || s = "gentype.opaque" - -let tagIsOneOfTheGenTypeAnnotations s = - tagIsGenType s || tagIsGenTypeAs s || tagIsGenTypeImport s - || tagIsGenTypeOpaque s - -let tagIsGenTypeIgnoreInterface s = - s = "genType.ignoreInterface" || s = "gentype.ignoreInterface" - -let tagIsDoc s = - match s with - | "ocaml.doc" | "res.doc" -> true - | _ -> false -let tagIsInternLocal s = s = "internal.local" - -let rec getAttributePayload checkText (attributes : Typedtree.attributes) = - let rec fromExpr (expr : Parsetree.expression) = - match expr with - | {pexp_desc = Pexp_constant (Pconst_string (s, _))} -> - Some (StringPayload s) - | {pexp_desc = Pexp_constant (Pconst_integer (n, _))} -> Some (IntPayload n) - | {pexp_desc = Pexp_constant (Pconst_float (s, _))} -> Some (FloatPayload s) - | { - pexp_desc = Pexp_construct ({txt = Lident (("true" | "false") as s)}, _); - _; - } -> - Some (BoolPayload (s = "true")) - | {pexp_desc = Pexp_tuple exprs} -> - let payloads = - exprs |> List.rev - |> List.fold_left - (fun payloads expr -> - match expr |> fromExpr with - | Some payload -> payload :: payloads - | None -> payloads) - [] - in - Some (TuplePayload payloads) - | {pexp_desc = Pexp_ident {txt}} -> Some (IdentPayload txt) - | _ -> None - in - match attributes with - | [] -> None - | ({txt; loc}, payload) :: _tl when checkText txt -> ( - let payload = - match payload with - | PStr [] -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_eval (expr, _)} :: _) -> expr |> fromExpr - | PStr ({pstr_desc = Pstr_extension _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_value _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_primitive _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_type _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_typext _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_exception _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_module _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_recmodule _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_modtype _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_open _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_class _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_class_type _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_include _} :: _) -> Some UnrecognizedPayload - | PStr ({pstr_desc = Pstr_attribute _} :: _) -> Some UnrecognizedPayload - | PPat _ -> Some UnrecognizedPayload - | PSig _ -> Some UnrecognizedPayload - | PTyp _ -> Some UnrecognizedPayload - in - match payload with - | None -> None - | Some payload -> Some (loc, payload)) - | _hd :: tl -> getAttributePayload checkText tl - -let getGenTypeAsRenaming attributes = - match attributes |> getAttributePayload tagIsGenTypeAs with - | Some (_, StringPayload s) -> Some s - | None -> ( - match attributes |> getAttributePayload tagIsGenType with - | Some (_, StringPayload s) -> Some s - | _ -> None) - | _ -> None - -(* This is not supported anymore: only use to give a warning *) -let checkUnsupportedGenTypeAsRenaming attributes = - let error ~loc = - Log_.Color.setup (); - Log_.info ~loc ~name:"Warning genType" (fun ppf () -> - Format.fprintf ppf - "@\n\ - @genType.as is not supported anymore in type definitions. Use @as \ - from the language.") - in - match attributes |> getAttributePayload tagIsGenTypeAs with - | Some (loc, _) -> error ~loc - | None -> ( - match attributes |> getAttributePayload tagIsGenType with - | Some (loc, _) -> error ~loc - | None -> ()) - -let getAsString attributes = - match attributes |> getAttributePayload tagIsAs with - | Some (_, StringPayload s) -> Some s - | _ -> None - -let getAsInt attributes = - match attributes |> getAttributePayload tagIsAs with - | Some (_, IntPayload s) -> ( - try Some (int_of_string s) with Failure _ -> None) - | _ -> None - -let getAttributeImportRenaming attributes = - let attributeImport = attributes |> getAttributePayload tagIsGenTypeImport in - let genTypeAsRenaming = attributes |> getGenTypeAsRenaming in - match (attributeImport, genTypeAsRenaming) with - | Some (_, StringPayload importString), _ -> - (Some importString, genTypeAsRenaming) - | ( Some - ( _, - TuplePayload [StringPayload importString; StringPayload renameString] - ), - _ ) -> - (Some importString, Some renameString) - | _ -> (None, genTypeAsRenaming) - -let getTag attributes = - match attributes |> getAttributePayload tagIsTag with - | Some (_, StringPayload s) -> Some s - | _ -> None - -let getDocPayload attributes = - let docPayload = attributes |> getAttributePayload tagIsDoc in - match docPayload with - | Some (_, StringPayload docString) when docString <> "" -> Some docString - | _ -> None - -let docStringFromAttrs attributes = attributes |> getDocPayload - -let hasAttribute checkText (attributes : Typedtree.attributes) = - getAttributePayload checkText attributes <> None - -let fromAttributes ~(config : GenTypeConfig.t) ~loc - (attributes : Typedtree.attributes) = - let default = if config.everything then GenType else NoGenType in - if hasAttribute tagIsGenTypeOpaque attributes then GenTypeOpaque - else if hasAttribute (fun s -> tagIsGenType s || tagIsGenTypeAs s) attributes - then ( - (match attributes |> getAttributePayload tagIsGenType with - | Some (_, UnrecognizedPayload) -> () - | Some _ -> - Log_.Color.setup (); - Log_.info ~loc ~name:"Warning genType" (fun ppf () -> - Format.fprintf ppf "Annotation payload is ignored") - | _ -> ()); - GenType) - else default - -let rec moduleTypeCheckAnnotation ~checkAnnotation - ({mty_desc} : Typedtree.module_type) = - match mty_desc with - | Tmty_signature signature -> - signature |> signatureCheckAnnotation ~checkAnnotation - | Tmty_ident _ | Tmty_functor _ | Tmty_with _ | Tmty_typeof _ | Tmty_alias _ - -> - false - -and moduleTypeDeclarationCheckAnnotation ~checkAnnotation - ({mtd_type; mtd_attributes; mtd_loc = loc} : - Typedtree.module_type_declaration) = - mtd_attributes |> checkAnnotation ~loc - || - match mtd_type with - | None -> false - | Some module_type -> - module_type |> moduleTypeCheckAnnotation ~checkAnnotation - -and moduleDeclarationCheckAnnotation ~checkAnnotation - ({md_attributes; md_type; md_loc = loc} : Typedtree.module_declaration) = - md_attributes |> checkAnnotation ~loc - || md_type |> moduleTypeCheckAnnotation ~checkAnnotation - -and signatureItemCheckAnnotation ~checkAnnotation - (signatureItem : Typedtree.signature_item) = - match signatureItem.sig_desc with - | Tsig_type (_, typeDeclarations) -> - typeDeclarations - |> List.exists - (fun ({typ_attributes; typ_loc = loc} : Typedtree.type_declaration) -> - typ_attributes |> checkAnnotation ~loc) - | Tsig_value {val_attributes; val_loc = loc} -> - val_attributes |> checkAnnotation ~loc - | Tsig_module moduleDeclaration -> - moduleDeclaration |> moduleDeclarationCheckAnnotation ~checkAnnotation - | Tsig_attribute attribute -> - [attribute] |> checkAnnotation ~loc:signatureItem.sig_loc - | Tsig_modtype moduleTypeDeclaration -> - moduleTypeDeclaration - |> moduleTypeDeclarationCheckAnnotation ~checkAnnotation - | Tsig_typext _ | Tsig_exception _ | Tsig_recmodule _ | Tsig_open _ - | Tsig_include _ | Tsig_class _ | Tsig_class_type _ -> - false - -and signatureCheckAnnotation ~checkAnnotation (signature : Typedtree.signature) - = - signature.sig_items - |> List.exists (signatureItemCheckAnnotation ~checkAnnotation) - -let rec structureItemCheckAnnotation ~checkAnnotation - (structureItem : Typedtree.structure_item) = - match structureItem.str_desc with - | Tstr_type (_, typeDeclarations) -> - typeDeclarations - |> List.exists - (fun ({typ_attributes; typ_loc = loc} : Typedtree.type_declaration) -> - typ_attributes |> checkAnnotation ~loc) - | Tstr_value (_loc, valueBindings) -> - valueBindings - |> List.exists - (fun ({vb_attributes; vb_loc = loc} : Typedtree.value_binding) -> - vb_attributes |> checkAnnotation ~loc) - | Tstr_primitive {val_attributes; val_loc = loc} -> - val_attributes |> checkAnnotation ~loc - | Tstr_module moduleBinding -> - moduleBinding |> moduleBindingCheckAnnotation ~checkAnnotation - | Tstr_recmodule moduleBindings -> - moduleBindings - |> List.exists (moduleBindingCheckAnnotation ~checkAnnotation) - | Tstr_include {incl_attributes; incl_mod; incl_loc = loc} -> - incl_attributes |> checkAnnotation ~loc - || incl_mod |> moduleExprCheckAnnotation ~checkAnnotation - | Tstr_modtype moduleTypeDeclaration -> - moduleTypeDeclaration - |> moduleTypeDeclarationCheckAnnotation ~checkAnnotation - | Tstr_attribute attribute -> - [attribute] |> checkAnnotation ~loc:structureItem.str_loc - | Tstr_eval _ | Tstr_typext _ | Tstr_exception _ | Tstr_open _ | Tstr_class _ - | Tstr_class_type _ -> - false - -and moduleExprCheckAnnotation ~checkAnnotation - (moduleExpr : Typedtree.module_expr) = - match moduleExpr.mod_desc with - | Tmod_structure structure -> - structure |> structureCheckAnnotation ~checkAnnotation - | Tmod_constraint - (moduleExpr, _moduleType, moduleTypeConstraint, _moduleCoercion) -> ( - moduleExpr |> moduleExprCheckAnnotation ~checkAnnotation - || - match moduleTypeConstraint with - | Tmodtype_explicit moduleType -> - moduleType |> moduleTypeCheckAnnotation ~checkAnnotation - | Tmodtype_implicit -> false) - | Tmod_ident _ | Tmod_functor _ | Tmod_apply _ | Tmod_unpack _ -> false - -and moduleBindingCheckAnnotation ~checkAnnotation - ({mb_expr; mb_attributes; mb_loc = loc} : Typedtree.module_binding) = - mb_attributes |> checkAnnotation ~loc - || mb_expr |> moduleExprCheckAnnotation ~checkAnnotation - -and structureCheckAnnotation ~checkAnnotation (structure : Typedtree.structure) - = - structure.str_items - |> List.exists (structureItemCheckAnnotation ~checkAnnotation) - -let importFromString importString : import = - let importPath = ImportPath.fromStringUnsafe importString in - {importPath} - -let updateConfigForModule ~(config : GenTypeConfig.t) attributes = - if attributes |> hasAttribute tagIsGenType then - {config with everything = true} - else config diff --git a/jscomp/gentype/CodeItem.ml b/jscomp/gentype/CodeItem.ml deleted file mode 100644 index 176fa03..0000000 --- a/jscomp/gentype/CodeItem.ml +++ /dev/null @@ -1,58 +0,0 @@ -open GenTypeCommon - -type exportType = { - loc: Location.t; - nameAs: string option; - opaque: bool option; - type_: type_; - typeVars: string list; - resolvedTypeName: ResolvedName.t; - docString: DocString.t; -} - -type importValue = { - asPath: string; - importAnnotation: Annotation.import; - type_: type_; - valueName: string; -} - -type exportValue = { - docString: DocString.t; - moduleAccessPath: Runtime.moduleAccessPath; - originalName: string; - resolvedName: ResolvedName.t; - type_: type_; -} - -type exportFromTypeDeclaration = { - exportType: exportType; - annotation: Annotation.t; -} - -type importType = { - typeName: string; - asTypeName: string option; - importPath: ImportPath.t; -} - -type exportTypeItem = { - typeVars: string list; - type_: type_; - annotation: Annotation.t; -} - -type exportTypeMap = exportTypeItem StringMap.t - -type typeDeclaration = { - exportFromTypeDeclaration: exportFromTypeDeclaration; - importTypes: importType list; -} - -type t = ExportValue of exportValue | ImportValue of importValue - -type translation = { - importTypes: importType list; - codeItems: t list; - typeDeclarations: typeDeclaration list; -} diff --git a/jscomp/gentype/Converter.ml b/jscomp/gentype/Converter.ml deleted file mode 100644 index 297da01..0000000 --- a/jscomp/gentype/Converter.ml +++ /dev/null @@ -1,84 +0,0 @@ -open GenTypeCommon - -let typeGetInlined ~config ~lookupId ~typeNameIsInterface type0 = - let circular = ref "" in - let rec visit ~(visited : StringSet.t) type_ = - let normalized_ = type_ in - match type_ with - | Array (t, mutable_) -> - let tNormalized = t |> visit ~visited in - Array (tNormalized, mutable_) - | Dict _ -> normalized_ - | Function ({argTypes; retType} as function_) -> - let argConverted = argTypes |> List.map (argTypeToGroupedArg ~visited) in - let retNormalized = retType |> visit ~visited in - Function {function_ with argTypes = argConverted; retType = retNormalized} - | Ident {builtin = true} -> normalized_ - | Ident {builtin = false; name; typeArgs} -> ( - if visited |> StringSet.mem name then ( - circular := name; - normalized_) - else - let visited = visited |> StringSet.add name in - match name |> lookupId with - | {CodeItem.annotation = GenTypeOpaque} -> normalized_ - | {annotation = NoGenType} -> normalized_ - | {typeVars; type_} -> - let pairs = - try List.combine typeVars typeArgs with Invalid_argument _ -> [] - in - let f typeVar = - match - pairs |> List.find (fun (typeVar1, _) -> typeVar = typeVar1) - with - | _, typeArgument -> Some typeArgument - | exception Not_found -> None - in - let inlined = type_ |> TypeVars.substitute ~f |> visit ~visited in - inlined - | exception Not_found -> - let typeArgs = typeArgs |> List.map (fun t -> t |> visit ~visited) in - Ident {builtin = false; name; typeArgs}) - | Null t -> - let tNormalized = t |> visit ~visited in - Null tNormalized - | Nullable t -> - let tNormalized = t |> visit ~visited in - Nullable tNormalized - | Object _ -> normalized_ - | Option t -> - let tNormalized = t |> visit ~visited in - Option tNormalized - | Promise t -> - let tNormalized = t |> visit ~visited in - Promise tNormalized - | Tuple innerTypes -> - let normalizedList = innerTypes |> List.map (visit ~visited) in - Tuple normalizedList - | TypeVar _ -> normalized_ - | Variant variant -> - let ordinaryVariant = not variant.polymorphic in - let withPayloadConverted = - variant.payloads - |> List.map (fun (payload : payload) -> - {payload with t = payload.t |> visit ~visited}) - in - let normalized = - match withPayloadConverted with - | [] when ordinaryVariant -> normalized_ - | [payload] when ordinaryVariant -> - let normalized = Variant {variant with payloads = [payload]} in - normalized - | withPayloadConverted -> - Variant {variant with payloads = withPayloadConverted} - in - normalized - and argTypeToGroupedArg ~visited {aName; aType} = - let tNormalized = aType |> visit ~visited in - {aName; aType = tNormalized} - in - let normalized = type0 |> visit ~visited:StringSet.empty in - if !Debug.converter then - Log_.item "type0:%s \n" - (type0 |> EmitType.typeToString ~config ~typeNameIsInterface); - normalized diff --git a/jscomp/gentype/Debug.ml b/jscomp/gentype/Debug.ml deleted file mode 100644 index b29c257..0000000 --- a/jscomp/gentype/Debug.ml +++ /dev/null @@ -1,42 +0,0 @@ -let basic = ref false -let codeItems = ref false -let config = ref false -let converter = ref false -let dependencies = ref false -let moduleResolution = ref false -let notImplemented = ref false -let translation = ref false -let typeEnv = ref false -let typeResolution = ref false - -let setAll () = - basic := true; - codeItems := true; - config := true; - converter := true; - dependencies := true; - moduleResolution := true; - notImplemented := true; - translation := true; - typeEnv := true; - typeResolution := true - -let setItem debugItem debugValue = - let isOn = - match debugValue with - | Ext_json_types.True _ -> true - | _ -> false - in - match debugItem with - | "all" when isOn -> setAll () - | "basic" -> basic := isOn - | "codeItems" -> codeItems := isOn - | "config" -> config := isOn - | "converter" -> converter := isOn - | "dependencies" -> dependencies := isOn - | "moduleResolution" -> moduleResolution := isOn - | "notImplemented" -> notImplemented := isOn - | "translation" -> translation := isOn - | "typeEnv" -> typeEnv := isOn - | "typeResolution" -> typeResolution := isOn - | _ -> () diff --git a/jscomp/gentype/Dependencies.ml b/jscomp/gentype/Dependencies.ml deleted file mode 100644 index 889d0f4..0000000 --- a/jscomp/gentype/Dependencies.ml +++ /dev/null @@ -1,69 +0,0 @@ -open GenTypeCommon - -let rec handleNamespace ~name dep = - match dep with - | External _ | Internal _ -> dep - | Dot (External s, moduleName) when s = name -> External moduleName - | Dot (dep1, s) -> Dot (dep1 |> handleNamespace ~name, s) - -let rec fromPath1 ~config ~typeEnv (path : Path.t) = - match path with - | Pident id -> ( - let name = id |> Ident.name in - match typeEnv |> TypeEnv.lookup ~name with - | None -> (typeEnv, External name) - | Some typeEnv1 -> ( - let typeEnv2 = - match typeEnv |> TypeEnv.getModule ~name with - | Some typeEnv2 -> typeEnv2 - | None -> typeEnv1 - in - match typeEnv1 |> TypeEnv.expandAliasToExternalModule ~name with - | Some dep -> (typeEnv2, dep) - | None -> - let resolvedName = name |> TypeEnv.addModulePath ~typeEnv:typeEnv1 in - (typeEnv2, Internal resolvedName))) - | Pdot (Pident id, s, _pos) when id |> ScopedPackage.isGeneratedModule ~config - -> - ( typeEnv, - External (s |> ScopedPackage.addGeneratedModule ~generatedModule:id) ) - | Pdot (p, s, _pos) -> ( - let typeEnvFromP, dep = p |> fromPath1 ~config ~typeEnv in - match typeEnvFromP |> TypeEnv.expandAliasToExternalModule ~name:s with - | Some dep -> (typeEnvFromP, dep) - | None -> (typeEnvFromP, Dot (dep, s))) - | Papply _ -> - ( typeEnv, - Internal ("__Papply_unsupported_genType__" |> ResolvedName.fromString) ) - -let rec isInternal dep = - match dep with - | External _ -> false - | Internal _ -> true - | Dot (d, _) -> d |> isInternal - -let fromPath ~config ~typeEnv path = - let _, dep = path |> fromPath1 ~config ~typeEnv in - if !Debug.typeResolution then - Log_.item "fromPath path:%s typeEnv:%s %s resolved:%s\n" (path |> Path.name) - (typeEnv |> TypeEnv.toString) - (match dep |> isInternal with - | true -> "Internal" - | false -> "External") - (dep |> depToString); - match config.namespace with - | None -> dep - | Some name -> dep |> handleNamespace ~name - -let rec getOuterModuleName dep = - match dep with - | External name -> name |> ModuleName.fromStringUnsafe - | Internal resolvedName -> - resolvedName |> ResolvedName.toString |> ModuleName.fromStringUnsafe - | Dot (dep1, _) -> dep1 |> getOuterModuleName - -let rec removeExternalOuterModule dep = - match dep with - | External _ | Internal _ -> dep - | Dot (External _, s) -> External s - | Dot (dep1, s) -> Dot (dep1 |> removeExternalOuterModule, s) diff --git a/jscomp/gentype/EmitJs.ml b/jscomp/gentype/EmitJs.ml deleted file mode 100644 index ec289ba..0000000 --- a/jscomp/gentype/EmitJs.ml +++ /dev/null @@ -1,680 +0,0 @@ -open GenTypeCommon - -type env = { - requiresEarly: ImportPath.t Config.ModuleNameMap.t; - requires: ImportPath.t Config.ModuleNameMap.t; - (** For each .cmt we import types from, keep the map of exported types *) - cmtToExportTypeMap: CodeItem.exportTypeMap StringMap.t; - (** Map of types imported from other files *) - exportTypeMapFromOtherFiles: CodeItem.exportTypeMap; - importedValueOrComponent: bool; -} - -let requireModule ~import ~env ~importPath moduleName = - let requires = - match import with - | true -> env.requiresEarly - | false -> env.requires - in - let requiresNew = - requires |> Config.ModuleNameMap.add moduleName importPath - in - match import with - | true -> {env with requiresEarly = requiresNew} - | false -> {env with requires = requiresNew} - -let createExportTypeMap ~config ~file ~fromCmtReadRecursively - (typeDeclarations : CodeItem.typeDeclaration list) : CodeItem.exportTypeMap - = - if !Debug.codeItems then Log_.item "Create Type Map for %s\n" file; - let updateExportTypeMap (exportTypeMap : CodeItem.exportTypeMap) - (typeDeclaration : CodeItem.typeDeclaration) : CodeItem.exportTypeMap = - let addExportType ~annotation - ({resolvedTypeName; type_; typeVars} : CodeItem.exportType) = - let annotation = - match annotation with - | Annotation.NoGenType when fromCmtReadRecursively -> Annotation.GenType - | _ -> annotation - in - if !Debug.codeItems then - Log_.item "Type Map: %s%s%s\n" - (resolvedTypeName |> ResolvedName.toString) - (match typeVars = [] with - | true -> "" - | false -> "(" ^ (typeVars |> String.concat ",") ^ ")") - (" " - ^ (annotation |> Annotation.toString |> EmitText.comment) - ^ " = " - ^ (type_ - |> EmitType.typeToString ~config ~typeNameIsInterface:(fun _ -> - false))); - exportTypeMap - |> StringMap.add - (resolvedTypeName |> ResolvedName.toString) - {CodeItem.typeVars; type_; annotation} - in - match typeDeclaration.exportFromTypeDeclaration with - | {exportType; annotation} -> exportType |> addExportType ~annotation - in - typeDeclarations |> List.fold_left updateExportTypeMap StringMap.empty - -let codeItemToString ~config ~typeNameIsInterface (codeItem : CodeItem.t) = - match codeItem with - | ExportValue {resolvedName; type_} -> - "ExportValue" ^ " resolvedName:" - ^ ResolvedName.toString resolvedName - ^ " type:" - ^ EmitType.typeToString ~config ~typeNameIsInterface type_ - | ImportValue {importAnnotation} -> - "ImportValue " ^ (importAnnotation.importPath |> ImportPath.dump) - -let emitExportType ~emitters ~config ~typeNameIsInterface - {CodeItem.loc; nameAs; opaque; type_; typeVars; resolvedTypeName; docString} - = - let freeTypeVars = TypeVars.free type_ in - let isGADT = - freeTypeVars |> List.exists (fun s -> not (List.mem s typeVars)) - in - let opaque = - match opaque with - | Some true -> opaque - | _ when isGADT -> - Log_.Color.setup (); - Log_.info ~loc ~name:"Warning genType" (fun ppf () -> - Format.fprintf ppf - "GADT types are not supported: exporting %s as opaque type" - (resolvedTypeName |> ResolvedName.toString)); - Some true - | _ -> opaque - in - let opaque = - match opaque with - | Some opaque -> opaque - | None -> false - in - resolvedTypeName |> ResolvedName.toString - |> EmitType.emitExportType ~config ~emitters ~nameAs ~opaque ~type_ - ~typeNameIsInterface ~typeVars ~docString - -let typeNameIsInterface ~(exportTypeMap : CodeItem.exportTypeMap) - ~(exportTypeMapFromOtherFiles : CodeItem.exportTypeMap) typeName = - let typeIsInterface type_ = - match type_ with - | Object _ -> true - | _ -> false - in - match exportTypeMap |> StringMap.find typeName with - | {type_} -> type_ |> typeIsInterface - | exception Not_found -> ( - match exportTypeMapFromOtherFiles |> StringMap.find typeName with - | {type_} -> type_ |> typeIsInterface - | exception Not_found -> false) - -let emitExportFromTypeDeclaration ~config ~emitters ~env ~typeNameIsInterface - (exportFromTypeDeclaration : CodeItem.exportFromTypeDeclaration) = - ( env, - exportFromTypeDeclaration.exportType - |> emitExportType ~emitters ~config ~typeNameIsInterface ) - -let emitExportFromTypeDeclarations ~config ~emitters ~env ~typeNameIsInterface - exportFromTypeDeclarations = - exportFromTypeDeclarations - |> List.fold_left - (fun (env, emitters) -> - emitExportFromTypeDeclaration ~config ~emitters ~env - ~typeNameIsInterface) - (env, emitters) - -let emitCodeItem ~config ~emitters ~moduleItemsEmitter ~env ~fileName - ~outputFileRelative ~resolver ~inlineOneLevel ~typeNameIsInterface codeItem - = - if !Debug.codeItems then - Log_.item "Code Item: %s\n" - (codeItem |> codeItemToString ~config ~typeNameIsInterface); - match codeItem with - | ImportValue {asPath; importAnnotation; type_; valueName} -> - let importPath = importAnnotation.importPath in - let firstNameInPath, restOfPath = - match valueName = asPath with - | true -> (valueName, "") - | false -> ( - match asPath |> String.split_on_char '.' with - | x :: y -> (x, "" :: y |> String.concat ".") - | _ -> (asPath, "")) - in - let emitters, importedAsName, env = - (* emit an import {... as ...} immediately *) - let valueNameNotChecked = valueName ^ "NotChecked" in - let emitters = - importPath - |> EmitType.emitImportValueAsEarly ~emitters ~name:firstNameInPath - ~nameAs:(Some valueNameNotChecked) - in - (emitters, valueNameNotChecked, env) - in - let type_ = - match type_ with - | Function - ({argTypes = [{aType = Object (closedFlag, fields); aName}]; retType} - as function_) - when retType |> EmitType.isTypeFunctionComponent ~fields -> - (* JSX V3 *) - let fields = - fields - |> List.map (fun (field : field) -> - match - field.nameJS = "children" - && field.type_ |> EmitType.isTypeReactElement - with - | true -> {field with type_ = EmitType.typeReactChild} - | false -> field) - in - let function_ = - { - function_ with - argTypes = [{aType = Object (closedFlag, fields); aName}]; - } - in - Function function_ - | Function - ({argTypes = [{aType = Ident {name} as propsType; aName}]; retType} as - function_) - when Filename.check_suffix name "props" - && retType |> EmitType.isTypeFunctionComponent ~fields:[] -> ( - match inlineOneLevel propsType with - | Object (closedFlags, fields) -> - (* JSX V3 *) - let fields = - Ext_list.filter_map fields (fun (field : field) -> - match field.nameJS with - | "children" when field.type_ |> EmitType.isTypeReactElement -> - Some {field with type_ = EmitType.typeReactChild} - | "key" -> - (* Filter out key, which is added to the props type definition in V4 *) - None - | _ -> Some field) - in - let function_ = - { - function_ with - argTypes = [{aType = Object (closedFlags, fields); aName}]; - } - in - Function function_ - | _ -> type_) - | _ -> type_ - in - let valueNameTypeChecked = valueName ^ "TypeChecked" in - let emitters = - importedAsName ^ restOfPath - |> EmitType.emitExportConst ~config - ~comment: - ("In case of type error, check the type of '" ^ valueName - ^ "' in '" - ^ (fileName |> ModuleName.toString) - ^ ".res'" ^ " and '" - ^ (importPath |> ImportPath.emit) - ^ "'.") - ~early:true ~emitters ~name:valueNameTypeChecked ~type_ - ~typeNameIsInterface - in - let valueNameNotDefault = - match valueName = "default" with - | true -> Runtime.default - | false -> valueName - in - let emitters = - valueNameTypeChecked - |> EmitType.emitTypeCast ~config ~type_ ~typeNameIsInterface - |> EmitType.emitExportConst - ~comment: - ("Export '" ^ valueNameNotDefault - ^ "' early to allow circular import from the '.bs.js' file.") - ~config ~early:true ~emitters ~name:valueNameNotDefault - ~type_:unknown ~typeNameIsInterface - in - let emitters = - match valueName = "default" with - | true -> EmitType.emitExportDefault ~emitters valueNameNotDefault - | false -> emitters - in - ({env with importedValueOrComponent = true}, emitters) - | ExportValue {docString; moduleAccessPath; originalName; resolvedName; type_} - -> - let resolvedNameStr = ResolvedName.toString resolvedName in - let importPath = - fileName - |> ModuleResolver.resolveModule ~config ~importExtension:config.suffix - ~outputFileRelative ~resolver ~useBsDependencies:false - in - let fileNameJs = fileName |> ModuleName.forJsFile in - let envWithRequires = - fileNameJs |> requireModule ~import:false ~env ~importPath - in - let default = "default" in - let make = "make" in - let name = - match originalName = default with - | true -> Runtime.default - | false -> resolvedNameStr - in - let module HookType = struct - type t = { - propsType: type_; - resolvedTypeName: ResolvedName.t; - typeVars: string list; - } - end in - let type_, hookType = - match type_ with - | Function - ({ - argTypes = [{aType = Object (closedFlags, fields)}]; - retType; - typeVars; - } as function_) - when retType |> EmitType.isTypeFunctionComponent ~fields -> - (* JSX V3 *) - let propsType = - let fields = - fields - |> List.map (fun (field : field) -> - match - field.nameJS = "children" - && field.type_ |> EmitType.isTypeReactElement - with - | true -> {field with type_ = EmitType.typeReactChild} - | false -> field) - in - Object (closedFlags, fields) - in - let function_ = - {function_ with argTypes = [{aName = ""; aType = propsType}]} - in - let resolvedTypeName = - if - (not config.emitTypePropDone) - && (originalName = default || originalName = make) - then ( - config.emitTypePropDone <- true; - ResolvedName.fromString "Props") - else ResolvedName.fromString name |> ResolvedName.dot "Props" - in - ( Function function_, - Some {HookType.propsType; resolvedTypeName; typeVars} ) - | Function - ({argTypes = [{aType = Ident {name} as propsType}]; retType} as - function_) - when Filename.check_suffix name "props" - && retType |> EmitType.isTypeFunctionComponent ~fields:[] -> - let compType = - match inlineOneLevel propsType with - | Object (closedFlags, fields) -> - (* JSX V4 *) - let propsType = - let fields = - Ext_list.filter_map fields (fun (field : field) -> - match field.nameJS with - | "children" when field.type_ |> EmitType.isTypeReactElement - -> - Some {field with type_ = EmitType.typeReactChild} - | "key" -> - (* Filter out key, which is added to the props type definition in V4 *) - None - | _ -> Some field) - in - Object (closedFlags, fields) - in - let function_ = - {function_ with argTypes = [{aName = ""; aType = propsType}]} - in - Function function_ - | _ -> type_ - in - (compType, None) - | _ -> (type_, None) - in - - resolvedName - |> ExportModule.extendExportModules ~docString ~moduleItemsEmitter ~type_; - let emitters = - match hookType with - | Some {propsType; resolvedTypeName; typeVars} -> - let exportType = - ({ - loc = Location.none; - nameAs = None; - opaque = Some false; - type_ = propsType; - typeVars; - resolvedTypeName; - docString; - } - : CodeItem.exportType) - in - (* For doc gen (https://github.com/cristianoc/genType/issues/342) *) - config.emitImportReact <- true; - emitExportType ~emitters ~config ~typeNameIsInterface exportType - | _ -> emitters - in - let emitters = - (fileNameJs |> ModuleName.toString) - ^ "." - ^ (moduleAccessPath |> Runtime.emitModuleAccessPath ~config) - |> EmitType.emitExportConst ~config ~docString ~early:false ~emitters - ~name ~type_ ~typeNameIsInterface - in - let emitters = - match originalName = default with - | true -> EmitType.emitExportDefault ~emitters Runtime.default - | false -> emitters - in - (envWithRequires, emitters) - -let emitCodeItems ~config ~outputFileRelative ~emitters ~moduleItemsEmitter ~env - ~fileName ~resolver ~typeNameIsInterface ~inlineOneLevel codeItems = - codeItems - |> List.fold_left - (fun (env, emitters) -> - emitCodeItem ~config ~emitters ~moduleItemsEmitter ~env ~fileName - ~outputFileRelative ~resolver ~inlineOneLevel ~typeNameIsInterface) - (env, emitters) - -let emitRequires ~importedValueOrComponent ~early ~config ~requires emitters = - Config.ModuleNameMap.fold - (fun moduleName importPath emitters -> - importPath - |> EmitType.emitRequire ~importedValueOrComponent ~early ~emitters ~config - ~moduleName) - requires emitters - -let typeGetInlined ~config ~exportTypeMap type_ = - type_ - |> Converter.typeGetInlined ~config - ~lookupId:(fun s -> exportTypeMap |> StringMap.find s) - ~typeNameIsInterface:(fun _ -> false) - -(** Read the cmt file referenced in an import type, - and recursively for the import types obtained from reading the cmt file. *) -let rec readCmtFilesRecursively ~config ~env ~inputCmtTranslateTypeDeclarations - ~outputFileRelative ~resolver {CodeItem.typeName; asTypeName; importPath} = - let updateTypeMapFromOtherFiles ~asType ~exportTypeMapFromCmt env = - match exportTypeMapFromCmt |> StringMap.find typeName with - | (exportTypeItem : CodeItem.exportTypeItem) -> - let type_ = - exportTypeItem.type_ - |> typeGetInlined ~config ~exportTypeMap:exportTypeMapFromCmt - in - { - env with - exportTypeMapFromOtherFiles = - env.exportTypeMapFromOtherFiles - |> StringMap.add asType {exportTypeItem with type_}; - } - | exception Not_found -> env - in - let cmtFile = - importPath - |> ImportPath.toCmt ~config ~outputFileRelative - |> Paths.getCmtFile - in - match asTypeName with - | Some asType when cmtFile <> "" -> ( - match env.cmtToExportTypeMap |> StringMap.find cmtFile with - | exportTypeMapFromCmt -> - env |> updateTypeMapFromOtherFiles ~asType ~exportTypeMapFromCmt - | exception Not_found -> - (* cmt file not read before: this ensures termination *) - let typeDeclarations = - Cmt_format.read_cmt cmtFile - |> inputCmtTranslateTypeDeclarations ~config ~outputFileRelative - ~resolver - |> fun (x : CodeItem.translation) -> x.typeDeclarations - in - let exportTypeMapFromCmt = - typeDeclarations - |> createExportTypeMap ~config ~fromCmtReadRecursively:true - ~file: - (cmtFile |> Filename.basename - |> (Filename.chop_extension [@doesNotRaise])) - in - let cmtToExportTypeMap = - env.cmtToExportTypeMap |> StringMap.add cmtFile exportTypeMapFromCmt - in - let env = - {env with cmtToExportTypeMap} - |> updateTypeMapFromOtherFiles ~asType ~exportTypeMapFromCmt - in - let newImportTypes = - typeDeclarations - |> List.map (fun (typeDeclaration : CodeItem.typeDeclaration) -> - typeDeclaration.importTypes) - |> List.concat - in - newImportTypes - |> List.fold_left - (fun env newImportType -> - newImportType - |> readCmtFilesRecursively ~config ~env - ~inputCmtTranslateTypeDeclarations ~outputFileRelative - ~resolver) - env) - | _ -> env - -let emitImportType ~config ~emitters ~env ~inputCmtTranslateTypeDeclarations - ~outputFileRelative ~resolver ~typeNameIsInterface - ({CodeItem.typeName; asTypeName; importPath} as importType) = - let env = - importType - |> readCmtFilesRecursively ~config ~env ~inputCmtTranslateTypeDeclarations - ~outputFileRelative ~resolver - in - let emitters = - EmitType.emitImportTypeAs ~emitters ~config ~typeName ~asTypeName - ~typeNameIsInterface:(typeNameIsInterface ~env) ~importPath - in - (env, emitters) - -let emitImportTypes ~config ~emitters ~env ~inputCmtTranslateTypeDeclarations - ~outputFileRelative ~resolver ~typeNameIsInterface importTypes = - importTypes - |> List.fold_left - (fun (env, emitters) -> - emitImportType ~config ~emitters ~env - ~inputCmtTranslateTypeDeclarations ~outputFileRelative ~resolver - ~typeNameIsInterface) - (env, emitters) - -let getAnnotatedTypedDeclarations ~annotatedSet typeDeclarations = - typeDeclarations - |> List.map (fun typeDeclaration -> - let nameInAnnotatedSet = - annotatedSet - |> StringSet.mem - (typeDeclaration.CodeItem.exportFromTypeDeclaration.exportType - .resolvedTypeName |> ResolvedName.toString) - in - if nameInAnnotatedSet then - { - typeDeclaration with - exportFromTypeDeclaration = - { - typeDeclaration.exportFromTypeDeclaration with - annotation = GenType; - }; - } - else typeDeclaration) - |> List.filter - (fun - ({exportFromTypeDeclaration = {annotation}} : CodeItem.typeDeclaration) - -> annotation <> NoGenType) - -let propagateAnnotationToSubTypes ~codeItems (typeMap : CodeItem.exportTypeMap) - = - let annotatedSet = ref StringSet.empty in - let initialAnnotatedTypes = - typeMap |> StringMap.bindings - |> List.filter (fun (_, {CodeItem.annotation}) -> - annotation = Annotation.GenType) - |> List.map (fun (_, {CodeItem.type_}) -> type_) - in - let typesOfExportedValue (codeItem : CodeItem.t) = - match codeItem with - | ExportValue {type_} | ImportValue {type_} -> [type_] - in - let typesOfExportedValues = - codeItems |> List.map typesOfExportedValue |> List.concat - in - let visitTypAndUpdateMarked type0 = - let visited = ref StringSet.empty in - let rec visit type_ = - match type_ with - | Ident {name = typeName; typeArgs} -> - if !visited |> StringSet.mem typeName then () - else ( - visited := !visited |> StringSet.add typeName; - typeArgs |> List.iter visit; - match typeMap |> StringMap.find typeName with - | {annotation = GenType | GenTypeOpaque} -> () - | {type_ = type1; annotation = NoGenType} -> - if !Debug.translation then - Log_.item "Marking Type As Annotated %s\n" typeName; - annotatedSet := !annotatedSet |> StringSet.add typeName; - type1 |> visit - | exception Not_found -> - annotatedSet := !annotatedSet |> StringSet.add typeName) - | Array (t, _) | Dict t -> t |> visit - | Function {argTypes; retType} -> - argTypes |> List.iter (fun {aType} -> visit aType); - retType |> visit - | Object (_, fields) -> - fields |> List.iter (fun {type_} -> type_ |> visit) - | Option t | Null t | Nullable t | Promise t -> t |> visit - | Tuple innerTypes -> innerTypes |> List.iter visit - | TypeVar _ -> () - | Variant {inherits; payloads} -> - inherits |> List.iter visit; - payloads |> List.iter (fun {t} -> t |> visit) - in - type0 |> visit - in - initialAnnotatedTypes @ typesOfExportedValues - |> List.iter visitTypAndUpdateMarked; - let newTypeMap = - typeMap - |> StringMap.mapi - (fun typeName (exportTypeItem : CodeItem.exportTypeItem) -> - { - exportTypeItem with - annotation = - (match !annotatedSet |> StringSet.mem typeName with - | true -> Annotation.GenType - | false -> exportTypeItem.annotation); - }) - in - (newTypeMap, !annotatedSet) - -let emitTranslationAsString ~config ~fileName ~inputCmtTranslateTypeDeclarations - ~outputFileRelative ~resolver (translation : Translation.t) = - let initialEnv = - { - requires = Config.ModuleNameMap.empty; - requiresEarly = Config.ModuleNameMap.empty; - cmtToExportTypeMap = StringMap.empty; - exportTypeMapFromOtherFiles = StringMap.empty; - importedValueOrComponent = false; - } - in - let exportTypeMap, annotatedSet = - translation.typeDeclarations - |> createExportTypeMap ~config - ~file:(fileName |> ModuleName.toString) - ~fromCmtReadRecursively:false - |> propagateAnnotationToSubTypes ~codeItems:translation.codeItems - in - let annotatedTypeDeclarations = - translation.typeDeclarations |> getAnnotatedTypedDeclarations ~annotatedSet - in - let importTypesFromTypeDeclarations = - annotatedTypeDeclarations - |> List.map (fun (typeDeclaration : CodeItem.typeDeclaration) -> - typeDeclaration.importTypes) - |> List.concat - in - let exportFromTypeDeclarations = - annotatedTypeDeclarations - |> List.map (fun (typeDeclaration : CodeItem.typeDeclaration) -> - typeDeclaration.exportFromTypeDeclaration) - in - let typeNameIsInterface ~env = - typeNameIsInterface ~exportTypeMap - ~exportTypeMapFromOtherFiles:env.exportTypeMapFromOtherFiles - in - let lookupId_ ~env s = - try exportTypeMap |> StringMap.find s - with Not_found -> env.exportTypeMapFromOtherFiles |> StringMap.find s - in - let emitters = Emitters.initial - and moduleItemsEmitter = ExportModule.createModuleItemsEmitter () - and env = initialEnv in - let env, emitters = - (* imports from type declarations go first to build up type tables *) - importTypesFromTypeDeclarations @ translation.importTypes - |> List.sort_uniq Translation.importTypeCompare - |> emitImportTypes ~config ~emitters ~env ~inputCmtTranslateTypeDeclarations - ~outputFileRelative ~resolver ~typeNameIsInterface - in - let env, emitters = - exportFromTypeDeclarations - |> emitExportFromTypeDeclarations ~config ~emitters ~env - ~typeNameIsInterface:(typeNameIsInterface ~env) - in - let inlineOneLevel type_ = - match type_ with - | Ident {builtin = false; name; typeArgs} -> ( - match name |> lookupId_ ~env with - | {type_; typeVars} -> - let pairs = - try List.combine typeVars typeArgs with Invalid_argument _ -> [] - in - let f typeVar = - match - pairs |> List.find (fun (typeVar1, _) -> typeVar = typeVar1) - with - | _, typeArgument -> Some typeArgument - | exception Not_found -> None - in - type_ |> TypeVars.substitute ~f - | exception Not_found -> type_) - | _ -> type_ - in - let env, emitters = - translation.codeItems - |> emitCodeItems ~config ~emitters ~moduleItemsEmitter ~env ~fileName - ~outputFileRelative ~resolver ~inlineOneLevel - ~typeNameIsInterface:(typeNameIsInterface ~env) - in - let emitters = - match config.emitImportReact with - | true -> EmitType.emitImportReact ~emitters - | false -> emitters - in - let env = - match config.emitImportCurry with - | true -> - ModuleName.curry - |> requireModule ~import:true ~env - ~importPath:(ImportPath.bsCurryPath ~config) - | false -> env - in - let finalEnv = env in - let emitters = - moduleItemsEmitter - |> ExportModule.emitAllModuleItems ~config ~emitters ~fileName - in - emitters - |> emitRequires ~importedValueOrComponent:false ~early:true ~config - ~requires:finalEnv.requiresEarly - |> emitRequires ~importedValueOrComponent:finalEnv.importedValueOrComponent - ~early:false ~config ~requires:finalEnv.requires - |> Emitters.toString ~separator:"\n\n" diff --git a/jscomp/gentype/EmitText.ml b/jscomp/gentype/EmitText.ml deleted file mode 100644 index 9ec5c1e..0000000 --- a/jscomp/gentype/EmitText.ml +++ /dev/null @@ -1,13 +0,0 @@ -type nameGen = (string, int) Hashtbl.t - -let parens xs = "(" ^ (xs |> String.concat ", ") ^ ")" -let comment x = "/* " ^ x ^ " */" - -let genericsString ~typeVars = - match typeVars == [] with - | true -> "" - | false -> "<" ^ String.concat "," typeVars ^ ">" - -let quotes x = "\"" ^ x ^ "\"" - -let fieldAccess ~label value = value ^ "." ^ label diff --git a/jscomp/gentype/EmitType.ml b/jscomp/gentype/EmitType.ml deleted file mode 100644 index 9a55a77..0000000 --- a/jscomp/gentype/EmitType.ml +++ /dev/null @@ -1,432 +0,0 @@ -open GenTypeCommon - -let fileHeader ~sourceFile = - let makeHeader ~lines = - match lines with - | [line] -> "/* " ^ line ^ " */\n\n" - | _ -> - "/** \n" - ^ (lines |> List.map (fun line -> " * " ^ line) |> String.concat "\n") - ^ "\n */\n\n" - in - makeHeader - ~lines:["TypeScript file generated from " ^ sourceFile ^ " by genType."] - ^ "/* eslint-disable */\n" ^ "/* tslint:disable */\n" - -let interfaceName ~(config : Config.t) name = - match config.exportInterfaces with - | true -> "I" ^ name - | false -> name - -let typeAny = ident ~builtin:true "any" - -let typeReactComponent ~propsType = - "React.ComponentType" |> ident ~builtin:true ~typeArgs:[propsType] - -let typeReactContext ~type_ = - "React.Context" |> ident ~builtin:true ~typeArgs:[type_] - -let typeReactElementTypeScript = ident ~builtin:true "JSX.Element" -let typeReactChildTypeScript = ident ~builtin:true "React.ReactNode" -let typeReactElement = typeReactElementTypeScript -let typeReactChild = typeReactChildTypeScript -let isTypeReactElement type_ = type_ == typeReactElement - -let typeReactDOMReDomRef = - "React.Ref" |> ident ~builtin:true ~typeArgs:[unknown] - -let typeReactEventMouseT = "MouseEvent" |> ident ~builtin:true -let reactRefCurrent = "current" - -let typeReactRef ~type_ = - Object - ( Open, - [ - { - mutable_ = Mutable; - nameJS = reactRefCurrent; - optional = Mandatory; - type_ = Null type_; - docString = DocString.empty; - }; - ] ) - -let isTypeReactRef ~fields = - match fields with - | [{mutable_ = Mutable; nameJS; optional = Mandatory}] -> - nameJS == reactRefCurrent - | _ -> false - -let isTypeFunctionComponent ~fields type_ = - type_ |> isTypeReactElement && not (isTypeReactRef ~fields) - -let rec renderType ~(config : Config.t) ?(indent = None) ~typeNameIsInterface - ~inFunType type0 = - match type0 with - | Array (t, arrayKind) -> - let typeIsSimple = - match t with - | Ident _ | TypeVar _ -> true - | _ -> false - in - if typeIsSimple && arrayKind = Mutable then - (t |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) ^ "[]" - else - let arrayName = - match arrayKind = Mutable with - | true -> "Array" - | false -> "ReadonlyArray" - in - arrayName ^ "<" - ^ (t |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - ^ ">" - | Dict type_ -> - "{[id: string]: " - ^ (type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - ^ "}" - | Function - {argTypes = [{aType = Object (closedFlag, fields)}]; retType; typeVars} - when retType |> isTypeFunctionComponent ~fields -> - let fields = - fields - |> List.map (fun field -> - { - field with - type_ = - field.type_ - |> TypeVars.substitute ~f:(fun s -> - if typeVars |> List.mem s then Some typeAny else None); - }) - in - let componentType = - typeReactComponent ~propsType:(Object (closedFlag, fields)) - in - componentType |> renderType ~config ~indent ~typeNameIsInterface ~inFunType - | Function {argTypes; retType; typeVars} -> - renderFunType ~config ~indent ~inFunType ~typeNameIsInterface ~typeVars - argTypes retType - | Object (_, fields) -> - let indent1 = fields |> Indent.heuristicFields ~indent in - fields - |> renderFields ~config ~indent:indent1 ~inFunType ~typeNameIsInterface - | Ident {builtin; name; typeArgs} -> - let name = name |> sanitizeTypeName in - (match - (not builtin) && config.exportInterfaces && name |> typeNameIsInterface - with - | true -> name |> interfaceName ~config - | false -> name) - ^ EmitText.genericsString - ~typeVars: - (typeArgs - |> List.map - (renderType ~config ~indent ~typeNameIsInterface ~inFunType)) - | Null type_ -> - "(null | " - ^ (type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - ^ ")" - | Nullable type_ -> - let useParens x = - match type_ with - | Function _ | Variant _ -> EmitText.parens [x] - | _ -> x - in - "(null | undefined | " - ^ useParens - (type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - ^ ")" - | Option type_ -> - let useParens x = - match type_ with - | Function _ | Variant _ -> EmitText.parens [x] - | _ -> x - in - "(undefined | " - ^ useParens - (type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - ^ ")" - | Promise type_ -> - "Promise" ^ "<" - ^ (type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - ^ ">" - | Tuple innerTypes -> - "[" - ^ (innerTypes - |> List.map (renderType ~config ~indent ~typeNameIsInterface ~inFunType) - |> String.concat ", ") - ^ "]" - | TypeVar s -> s - | Variant {inherits; noPayloads; payloads; polymorphic; tag; unboxed} -> - let inheritsRendered = - inherits - |> List.map (fun type_ -> - type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - in - let noPayloadsRendered = noPayloads |> List.map labelJSToString in - let field ~name value = - { - mutable_ = Mutable; - nameJS = name; - optional = Mandatory; - type_ = TypeVar value; - docString = DocString.empty; - } - in - let fields fields = - fields |> renderFields ~config ~indent ~inFunType ~typeNameIsInterface - in - let payloadsRendered = - payloads - |> List.map (fun {case; t = type_} -> - let render t = - t |> renderType ~config ~indent ~typeNameIsInterface ~inFunType - in - let tagField = - case |> labelJSToString - |> field ~name:(Runtime.jsVariantTag ~polymorphic:false ~tag) - in - match (unboxed, type_) with - | true, type_ -> - let needParens = - match type_ with - | Function _ -> true - | _ -> false - in - let t = type_ |> render in - if needParens then EmitText.parens [t] else t - | false, type_ when polymorphic -> - (* poly variant *) - [ - case |> labelJSToString - |> field ~name:(Runtime.jsVariantTag ~polymorphic ~tag); - type_ |> render - |> field ~name:(Runtime.jsVariantValue ~polymorphic); - ] - |> fields - | false, Object (Inline, flds) -> - (* inlined record *) - tagField :: flds |> fields - | false, type_ -> - (* ordinary variant *) - let payloads = - match type_ with - | Tuple ts -> ts - | _ -> [type_] - in - let flds = - tagField - :: Ext_list.mapi payloads (fun n t -> - t |> render - |> field ~name:(Runtime.jsVariantPayloadTag ~n)) - in - flds |> fields) - in - let rendered = inheritsRendered @ noPayloadsRendered @ payloadsRendered in - let indent1 = rendered |> Indent.heuristicVariants ~indent in - (match indent1 = None with - | true -> "" - | false -> Indent.break ~indent:indent1 ^ " ") - ^ (rendered - |> String.concat - ((match indent1 = None with - | true -> " " - | false -> Indent.break ~indent:indent1) - ^ "| ")) - -and renderField ~config ~indent ~typeNameIsInterface ~inFunType - {mutable_; nameJS = lbl; optional; type_; docString} = - let optMarker = - match optional == Optional with - | true -> "?" - | false -> "" - in - let mutMarker = - match mutable_ = Immutable with - | true -> "readonly " - | false -> "" - in - let lbl = - match isJSSafePropertyName lbl with - | true -> lbl - | false -> EmitText.quotes lbl - in - - let defStr = - mutMarker ^ lbl ^ optMarker ^ ": " - ^ (type_ |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - in - if DocString.hasContent docString then - (* Always print comments on newline before definition. *) - let indentStr = indent |> Option.value ~default:"" in - "\n" ^ indentStr ^ DocString.render docString ^ indentStr ^ defStr - else Indent.break ~indent ^ defStr - -and renderFields ~config ~indent ~inFunType ~typeNameIsInterface fields = - let indent1 = indent |> Indent.more in - let space = - match indent = None && fields <> [] with - | true -> " " - | false -> "" - in - let renderedFields = - fields - |> List.map - (renderField ~config ~indent:indent1 ~typeNameIsInterface ~inFunType) - in - ("{" ^ space) - ^ String.concat "; " renderedFields - ^ Indent.break ~indent ^ space ^ "}" - -and renderFunType ~config ~indent ~inFunType ~typeNameIsInterface ~typeVars - argTypes retType = - (match inFunType with - | true -> "(" - | false -> "") - ^ EmitText.genericsString ~typeVars - ^ "(" - ^ String.concat ", " - (List.mapi - (fun i {aName; aType} -> - let parameterName = - (match aName = "" with - | true -> "_" ^ string_of_int (i + 1) - | false -> aName) - ^ ":" - in - parameterName - ^ (aType - |> renderType ~config ~indent ~typeNameIsInterface ~inFunType:true - )) - argTypes) - ^ ") => " - ^ (retType |> renderType ~config ~indent ~typeNameIsInterface ~inFunType) - ^ - match inFunType with - | true -> ")" - | false -> "" - -let typeToString ~config ~typeNameIsInterface type_ = - type_ |> renderType ~config ~typeNameIsInterface ~inFunType:false - -let emitExportConst ~early ?(comment = "") ~config - ?(docString = DocString.empty) ~emitters ~name ~type_ ~typeNameIsInterface - line = - let typeString = type_ |> typeToString ~config ~typeNameIsInterface in - (match comment = "" with - | true -> comment - | false -> "// " ^ comment ^ "\n") - ^ DocString.render docString ^ "export const " ^ name ^ ": " ^ typeString - ^ " = " ^ line ^ " as any;" - |> (match early with - | true -> Emitters.exportEarly - | false -> Emitters.export) - ~emitters - -let emitExportDefault ~emitters name = - "export default " ^ name ^ ";" |> Emitters.export ~emitters - -let emitExportType ~(config : Config.t) ~emitters ~nameAs ~opaque ~type_ - ~typeNameIsInterface ~typeVars ~docString resolvedTypeName = - let docString = DocString.render docString in - let typeParamsString = EmitText.genericsString ~typeVars in - let isInterface = resolvedTypeName |> typeNameIsInterface in - let resolvedTypeName = - match config.exportInterfaces && isInterface with - | true -> resolvedTypeName |> interfaceName ~config - | false -> resolvedTypeName - in - let exportNameAs = - match nameAs with - | None -> "" - | Some s -> - "\nexport type " ^ s ^ typeParamsString ^ " = " ^ resolvedTypeName - ^ typeParamsString ^ ";" - in - if opaque then - (* Represent an opaque type as an absract class with a field called 'opaque'. - Any type parameters must occur in the type of opaque, so that different - instantiations are considered different types. *) - let typeOfOpaqueField = - match typeVars = [] with - | true -> "any" - | false -> typeVars |> String.concat " | " - in - docString ^ "export abstract class " ^ resolvedTypeName ^ typeParamsString - ^ " { protected opaque!: " ^ typeOfOpaqueField - ^ " }; /* simulate opaque types */" ^ exportNameAs - |> Emitters.export ~emitters - else - (if isInterface && config.exportInterfaces then - docString ^ "export interface " ^ resolvedTypeName ^ typeParamsString - ^ " " - else - docString ^ "export type " ^ resolvedTypeName ^ typeParamsString ^ " = ") - ^ (match type_ with - | _ -> type_ |> typeToString ~config ~typeNameIsInterface) - ^ ";" ^ exportNameAs - |> Emitters.export ~emitters - -let emitImportValueAsEarly ~emitters ~name ~nameAs importPath = - "import " - ^ (match nameAs with - | Some nameAs -> "{" ^ name ^ " as " ^ nameAs ^ "}" - | None -> name) - ^ " from " ^ "'" - ^ (importPath |> ImportPath.emit) - ^ "';" - |> Emitters.requireEarly ~emitters - -let emitRequire ~importedValueOrComponent ~early ~emitters ~(config : Config.t) - ~moduleName importPath = - let moduleNameString = ModuleName.toString moduleName in - let importPathString = ImportPath.emit importPath in - let output = - match config.module_ with - | ESModule when not importedValueOrComponent -> - "import * as " ^ moduleNameString ^ " from '" ^ importPathString ^ "';" - | _ -> - "const " ^ moduleNameString ^ " = require('" ^ importPathString ^ "');" - in - output - |> (match early with - | true -> Emitters.requireEarly - | false -> Emitters.require) - ~emitters - -let require ~early = - match early with - | true -> Emitters.requireEarly - | false -> Emitters.require - -let emitImportReact ~emitters = - "import * as React from 'react';" |> require ~early:true ~emitters - -let emitImportTypeAs ~emitters ~config ~typeName ~asTypeName - ~typeNameIsInterface ~importPath = - let typeName = sanitizeTypeName typeName in - let asTypeName = - match asTypeName with - | None -> asTypeName - | Some s -> Some (sanitizeTypeName s) - in - let typeName, asTypeName = - match asTypeName with - | Some asName -> ( - match asName |> typeNameIsInterface with - | true -> - ( typeName |> interfaceName ~config, - Some (asName |> interfaceName ~config) ) - | false -> (typeName, asTypeName)) - | None -> (typeName, asTypeName) - in - let importPathString = importPath |> ImportPath.emit in - let importPrefix = "import type" in - importPrefix ^ " " ^ "{" ^ typeName - ^ (match asTypeName with - | Some asT -> " as " ^ asT - | None -> "") - ^ "} from '" ^ importPathString ^ "';" - |> Emitters.import ~emitters - -let emitTypeCast ~config ~type_ ~typeNameIsInterface s = - s ^ " as " ^ (type_ |> typeToString ~config ~typeNameIsInterface) diff --git a/jscomp/gentype/Emitters.ml b/jscomp/gentype/Emitters.ml deleted file mode 100644 index c40317e..0000000 --- a/jscomp/gentype/Emitters.ml +++ /dev/null @@ -1,49 +0,0 @@ -type t = { - requireEmitterEarly: string list; - exportEmitterEarly: string list; - requireEmitter: string list; - importEmitter: string list; - exportEmitter: string list; -} - -let initial = - { - requireEmitterEarly = []; - exportEmitterEarly = []; - requireEmitter = []; - importEmitter = []; - exportEmitter = []; - } - -let string ~emitter s = s :: emitter - -let requireEarly ~emitters s = - { - emitters with - requireEmitterEarly = s |> string ~emitter:emitters.requireEmitterEarly; - } - -let exportEarly ~emitters s = - { - emitters with - exportEmitterEarly = s |> string ~emitter:emitters.exportEmitterEarly; - } - -let require ~emitters s = - {emitters with requireEmitter = s |> string ~emitter:emitters.requireEmitter} - -let import ~emitters s = - {emitters with importEmitter = s |> string ~emitter:emitters.importEmitter} - -let export ~emitters s = - {emitters with exportEmitter = s |> string ~emitter:emitters.exportEmitter} - -let toString ~separator emitters = - [ - emitters.requireEmitterEarly |> List.rev; - emitters.exportEmitterEarly |> List.rev; - emitters.requireEmitter |> List.rev; - emitters.importEmitter |> List.rev; - emitters.exportEmitter |> List.rev; - ] - |> List.concat |> String.concat separator diff --git a/jscomp/gentype/Emitters.mli b/jscomp/gentype/Emitters.mli deleted file mode 100644 index 7d661f6..0000000 --- a/jscomp/gentype/Emitters.mli +++ /dev/null @@ -1,9 +0,0 @@ -type t - -val initial : t -val exportEarly : emitters:t -> string -> t -val requireEarly : emitters:t -> string -> t -val export : emitters:t -> string -> t -val import : emitters:t -> string -> t -val require : emitters:t -> string -> t -val toString : separator:string -> t -> string diff --git a/jscomp/gentype/ExportModule.ml b/jscomp/gentype/ExportModule.ml deleted file mode 100644 index b4798f5..0000000 --- a/jscomp/gentype/ExportModule.ml +++ /dev/null @@ -1,124 +0,0 @@ -open GenTypeCommon - -type exportModuleItem = (string, exportModuleValue) Hashtbl.t - -and exportModuleValue = - | S of {name: string; type_: type_; docString: DocString.t} - | M of {exportModuleItem: exportModuleItem} - -type exportModuleItems = (string, exportModuleItem) Hashtbl.t - -type types = {typeForValue: type_; typeForType: type_; docString: DocString.t} - -type fieldInfo = {fieldForValue: field; fieldForType: field} - -let rec exportModuleValueToType ~config exportModuleValue = - match exportModuleValue with - | S {name; type_; docString} -> - {typeForValue = ident name; typeForType = type_; docString} - | M {exportModuleItem} -> - let fieldsInfo = exportModuleItem |> exportModuleItemToFields ~config in - let fieldsForValue = - fieldsInfo |> List.map (fun {fieldForValue} -> fieldForValue) - in - let fieldsForType = - fieldsInfo |> List.map (fun {fieldForType} -> fieldForType) - in - { - typeForValue = Object (Open, fieldsForValue); - typeForType = Object (Open, fieldsForType); - docString = DocString.empty; - } - -and exportModuleItemToFields = - (fun ~config exportModuleItem -> - Hashtbl.fold - (fun fieldName exportModuleValue fields -> - let {typeForValue; typeForType; docString} = - exportModuleValue |> exportModuleValueToType ~config - in - let fieldForType = - { - mutable_ = Mutable; - nameJS = fieldName; - optional = Mandatory; - type_ = typeForType; - docString; - } - in - let fieldForValue = {fieldForType with type_ = typeForValue} in - {fieldForValue; fieldForType} :: fields) - exportModuleItem [] - : config:Config.t -> exportModuleItem -> fieldInfo list) - -let rec extendExportModuleItem ~docString x - ~(exportModuleItem : exportModuleItem) ~type_ ~valueName = - match x with - | [] -> () - | [fieldName] -> - Hashtbl.replace exportModuleItem fieldName - (S {name = valueName; type_; docString}) - | fieldName :: rest -> - let innerExportModuleItem = - match Hashtbl.find exportModuleItem fieldName with - | M {exportModuleItem = innerExportModuleItem} -> innerExportModuleItem - | S _ -> assert false - | exception Not_found -> - let innerExportModuleItem = Hashtbl.create 1 in - Hashtbl.replace exportModuleItem fieldName - (M {exportModuleItem = innerExportModuleItem}); - innerExportModuleItem - in - rest - |> extendExportModuleItem ~docString ~exportModuleItem:innerExportModuleItem - ~valueName ~type_ - -let extendExportModuleItems x ~docString - ~(exportModuleItems : exportModuleItems) ~type_ ~valueName = - match x with - | [] -> assert false - | [_valueName] -> () - | moduleName :: rest -> - let exportModuleItem = - match Hashtbl.find exportModuleItems moduleName with - | exportModuleItem -> exportModuleItem - | exception Not_found -> - let exportModuleItem = Hashtbl.create 1 in - Hashtbl.replace exportModuleItems moduleName exportModuleItem; - exportModuleItem - in - rest - |> extendExportModuleItem ~docString ~exportModuleItem ~type_ ~valueName - -let createModuleItemsEmitter = - (fun () -> Hashtbl.create 1 : unit -> exportModuleItems) - -let rev_fold f tbl base = - let list = Hashtbl.fold (fun k v l -> (k, v) :: l) tbl [] in - List.fold_left (fun x (k, v) -> f k v x) base list - -let emitAllModuleItems ~config ~emitters ~fileName - (exportModuleItems : exportModuleItems) = - emitters - |> rev_fold - (fun moduleName exportModuleItem emitters -> - let {typeForType; docString} = - M {exportModuleItem} |> exportModuleValueToType ~config - in - if !Debug.codeItems then Log_.item "EmitModule %s @." moduleName; - let emittedModuleItem = - ModuleName.forInnerModule ~fileName ~innerModuleName:moduleName - |> ModuleName.toString - in - emittedModuleItem - |> EmitType.emitExportConst ~docString ~early:false ~config ~emitters - ~name:moduleName ~type_:typeForType ~typeNameIsInterface:(fun _ -> - false)) - exportModuleItems - -let extendExportModules ~(moduleItemsEmitter : exportModuleItems) ~docString - ~type_ resolvedName = - resolvedName |> ResolvedName.toList - |> extendExportModuleItems ~exportModuleItems:moduleItemsEmitter ~type_ - ~docString - ~valueName:(resolvedName |> ResolvedName.toString) diff --git a/jscomp/gentype/FindSourceFile.ml b/jscomp/gentype/FindSourceFile.ml deleted file mode 100644 index b935a5e..0000000 --- a/jscomp/gentype/FindSourceFile.ml +++ /dev/null @@ -1,21 +0,0 @@ -let rec interface items = - match items with - | {Typedtree.sig_loc} :: rest -> ( - match not (Sys.file_exists sig_loc.loc_start.pos_fname) with - | true -> interface rest - | false -> Some sig_loc.loc_start.pos_fname) - | [] -> None - -let rec implementation items = - match items with - | {Typedtree.str_loc} :: rest -> ( - match not (Sys.file_exists str_loc.loc_start.pos_fname) with - | true -> implementation rest - | false -> Some str_loc.loc_start.pos_fname) - | [] -> None - -let cmt cmt_annots = - match cmt_annots with - | Cmt_format.Interface signature -> interface signature.sig_items - | Implementation structure -> implementation structure.str_items - | _ -> None diff --git a/jscomp/gentype/GenIdent.ml b/jscomp/gentype/GenIdent.ml deleted file mode 100644 index fcf9b7f..0000000 --- a/jscomp/gentype/GenIdent.ml +++ /dev/null @@ -1,21 +0,0 @@ -module IntMap = Map.Make (struct - type t = int - - let compare (x : int) (y : int) = compare x y -end) - -type typeVarsGen = { - (* Generate fresh identifiers *) - mutable typeNameMap: string IntMap.t; - mutable typeNameCounter: int; -} - -let createTypeVarsGen () = {typeNameMap = IntMap.empty; typeNameCounter = 0} - -let jsTypeNameForAnonymousTypeID ~typeVarsGen id = - try typeVarsGen.typeNameMap |> IntMap.find id - with Not_found -> - typeVarsGen.typeNameCounter <- typeVarsGen.typeNameCounter + 1; - let name = "T" ^ string_of_int typeVarsGen.typeNameCounter in - typeVarsGen.typeNameMap <- typeVarsGen.typeNameMap |> IntMap.add id name; - name diff --git a/jscomp/gentype/GenTypeCommon.ml b/jscomp/gentype/GenTypeCommon.ml deleted file mode 100644 index 4581323..0000000 --- a/jscomp/gentype/GenTypeCommon.ml +++ /dev/null @@ -1,232 +0,0 @@ -module StringMap = Map.Make (String) -module StringSet = Set.Make (String) -module Config = GenTypeConfig - -module DocString = struct - type t = string option - let render t = - match t with - | None | Some "" -> "" - | Some docString -> "/** " ^ String.trim docString ^ " */\n" - let empty = None - let hasContent docString = Option.is_some docString -end - -let logNotImplemented x = - if !Debug.notImplemented then Log_.item "Not Implemented: %s\n" x - -type optional = Mandatory | Optional -type mutable_ = Immutable | Mutable - -type labelJS = - | NullLabel - | UndefinedLabel - | BoolLabel of bool - | FloatLabel of string - | IntLabel of string - | StringLabel of string - -type case = {labelJS: labelJS} - -let isJSSafePropertyName name = - name = "" - || (match name.[0] [@doesNotRaise] with - | 'A' .. 'z' -> true - | _ -> false) - && name - |> String.for_all (function - | 'A' .. 'z' | '0' .. '9' -> true - | _ -> false) - -let isNumber s = - let len = String.length s in - len > 0 - && (match len > 1 with - | true -> (s.[0] [@doesNotRaise]) > '0' - | false -> true) - && - let res = ref true in - for i = 0 to len - 1 do - match s.[i] [@doesNotRaise] with - | '0' .. '9' -> () - | _ -> res := false - done; - res.contents - -let labelJSToString case = - match case.labelJS with - | NullLabel -> "null" - | UndefinedLabel -> "undefined" - | BoolLabel b -> b |> string_of_bool - | FloatLabel s -> s - | IntLabel i -> i - | StringLabel s -> s |> EmitText.quotes - -type closedFlag = Open | Closed | Inline - -type type_ = - | Array of type_ * mutable_ - | Dict of type_ - | Function of function_ - | Ident of ident - | Null of type_ - | Nullable of type_ - | Object of closedFlag * fields - | Option of type_ - | Promise of type_ - | Tuple of type_ list - | TypeVar of string - | Variant of variant (* ordinary and polymorphic variants *) - -and fields = field list -and argType = {aName: string; aType: type_} - -and field = { - mutable_: mutable_; - nameJS: string; - optional: optional; - type_: type_; - docString: DocString.t; -} - -and function_ = {argTypes: argType list; retType: type_; typeVars: string list} - -and ident = {builtin: bool; name: string; typeArgs: type_ list} - -and variant = { - inherits: type_ list; - noPayloads: case list; - payloads: payload list; - polymorphic: bool; (* If true, this is a polymorphic variant *) - tag: string option; (* The name of the tag field at runtime *) - unboxed: bool; -} - -and payload = {case: case; t: type_} - -type label = Nolabel | Label of string | OptLabel of string - -type dep = - | External of string - | Internal of ResolvedName.t - | Dot of dep * string - -module ScopedPackage = (* Taken from ext_namespace.ml in bukclescript *) -struct - let namespace_of_package_name (s : string) : string = - let len = String.length s in - let buf = Buffer.create len in - let add capital ch = - Buffer.add_char buf (if capital then Char.uppercase_ascii ch else ch) - in - let rec aux capital off len = - if off >= len then () - else - let ch = String.unsafe_get s off in - match ch with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> - add capital ch; - aux false (off + 1) len - | '/' | '-' -> aux true (off + 1) len - | _ -> aux capital (off + 1) len - in - aux true 0 len; - Buffer.contents buf - - (** @demo/some-library -> DemoSomelibrary *) - let packageNameToGeneratedModuleName packageName = - if String.contains packageName '/' then - Some (packageName |> namespace_of_package_name) - else None - - let isGeneratedModule id ~(config : Config.t) = - config.bsDependencies - |> List.exists (fun packageName -> - packageName |> packageNameToGeneratedModuleName - = Some (id |> Ident.name)) - - (** (Common, DemoSomelibrary) -> Common-DemoSomelibrary *) - let addGeneratedModule s ~generatedModule = - s ^ "-" ^ Ident.name generatedModule - - (** Common-DemoSomelibrary -> Common *) - let removeGeneratedModule s = - match s |> String.split_on_char '-' with - | [name; _scope] -> name - | _ -> s -end - -let rec depToString dep = - match dep with - | External name -> name |> ScopedPackage.removeGeneratedModule - | Internal resolvedName -> resolvedName |> ResolvedName.toString - | Dot (d, s) -> depToString d ^ "_" ^ s - -let rec depToResolvedName (dep : dep) = - match dep with - | External name -> name |> ResolvedName.fromString - | Internal resolvedName -> resolvedName - | Dot (p, s) -> ResolvedName.dot s (p |> depToResolvedName) - -let createVariant ~inherits ~noPayloads ~payloads ~polymorphic ~tag ~unboxed = - Variant {inherits; noPayloads; payloads; polymorphic; tag; unboxed} - -let ident ?(builtin = true) ?(typeArgs = []) name = - Ident {builtin; name; typeArgs} - -let sanitizeTypeName name = - name - |> String.map (function - | '\'' -> '_' - | c -> c) -let unknown = ident "unknown" -let bigintT = ident "BigInt" -let booleanT = ident "boolean" -let dateT = ident "Date" -let mapT (x, y) = ident ~typeArgs:[x; y] "Map" -let numberT = ident "number" -let regexpT = ident "RegExp" -let setT x = ident ~typeArgs:[x] "Set" -let stringT = ident "string" -let unitT = ident "void" -let weakmapT (x, y) = ident ~typeArgs:[x; y] "WeakMap" -let weaksetT x = ident ~typeArgs:[x] "WeakSet" -let int64T = Tuple [numberT; numberT] - -module NodeFilename = struct - include Filename - - (* Force "/" separator. *) - let dirSep = "/" - - module Path : sig - type t - - val normalize : string -> t - val concat : t -> string -> t - val toString : t -> string - end = struct - type t = string - - let normalize path : t = - match Sys.os_type with - | "Win32" -> path |> String.split_on_char '\\' |> String.concat dirSep - | _ -> path - - let toString path = path - let length path = String.length path - - let concat dirname filename = - let isDirSep s i = - let c = (s.[i] [@doesNotRaise]) in - c = '/' || c = '\\' || c = ':' - in - let l = length dirname in - if l = 0 || isDirSep dirname (l - 1) then dirname ^ filename - else dirname ^ dirSep ^ filename - end - - let concat (dirname : string) filename = - let open Path in - Path.concat (normalize dirname) filename |> toString -end diff --git a/jscomp/gentype/GenTypeConfig.ml b/jscomp/gentype/GenTypeConfig.ml deleted file mode 100644 index 9e5ec19..0000000 --- a/jscomp/gentype/GenTypeConfig.ml +++ /dev/null @@ -1,248 +0,0 @@ -module ModuleNameMap = Map.Make (ModuleName) - -type module_ = CommonJS | ESModule - -(** Compatibility for `compilerOptions.moduleResolution` in TypeScript projects. *) -type moduleResolution = - | Node (** should drop extension on import statements *) - | Node16 - (** should use TS output's extension (e.g. `.gen.js`) on import statements *) - | Bundler - (** should use TS input's extension (e.g. `.gen.tsx`) on import statements *) - -type bsVersion = int * int * int - -type t = { - mutable bsbProjectRoot: string; - bsDependencies: string list; - mutable emitImportCurry: bool; - mutable emitImportReact: bool; - mutable emitTypePropDone: bool; - mutable everything: bool; - exportInterfaces: bool; - generatedFileExtension: string option; - module_: module_; - moduleResolution: moduleResolution; - namespace: string option; - platformLib: string; - mutable projectRoot: string; - shimsMap: ModuleName.t ModuleNameMap.t; - sources: Ext_json_types.t option; - suffix: string; -} - -let default = - { - bsbProjectRoot = ""; - bsDependencies = []; - emitImportCurry = false; - emitImportReact = false; - emitTypePropDone = false; - everything = false; - exportInterfaces = false; - generatedFileExtension = None; - module_ = ESModule; - moduleResolution = Node; - namespace = None; - platformLib = ""; - projectRoot = ""; - shimsMap = ModuleNameMap.empty; - sources = None; - suffix = ".bs.js"; - } - -let bsPlatformLib ~config = - match config.module_ with - | ESModule -> config.platformLib ^ "/lib/es6" - | CommonJS -> config.platformLib ^ "/lib/js" - -let getBsCurryPath ~config = Filename.concat (bsPlatformLib ~config) "curry.js" - -type map = Ext_json_types.t Map_string.t - -let getOpt s (map : map) = Map_string.find_opt map s - -let getBool s map = - match map |> getOpt s with - | Some (True _) -> Some true - | Some (False _) -> Some false - | _ -> None - -let getStringOption s map = - match map |> getOpt s with - | Some (Str {str}) -> Some str - | _ -> None - -let getShims map = - let shims = ref [] in - (match map |> getOpt "shims" with - | Some (Obj {map = shimsMap}) -> - Map_string.iter shimsMap (fun fromModule toModule -> - match toModule with - | Ext_json_types.Str {str} -> shims := (fromModule, str) :: !shims - | _ -> ()) - | Some (Arr {content}) -> - (* To be deprecated: array of strings *) - content - |> Array.iter (fun x -> - match x with - | Ext_json_types.Str {str} -> - let fromTo = str |> String.split_on_char '=' |> Array.of_list in - assert (Array.length fromTo == 2); - shims := - ((fromTo.(0) [@doesNotRaise]), (fromTo.(1) [@doesNotRaise])) - :: !shims - | _ -> ()) - | _ -> ()); - !shims - -let setDebug ~gtconf = - match gtconf |> getOpt "debug" with - | Some (Obj {map}) -> Map_string.iter map Debug.setItem - | _ -> () - -let compilerConfigFile = "rescript.json" -let legacyCompilerConfigFile = "bsconfig.json" - -let rec findProjectRoot ~dir = - if - Sys.file_exists (Filename.concat dir compilerConfigFile) - || Sys.file_exists (Filename.concat dir legacyCompilerConfigFile) - then dir - else - let parent = dir |> Filename.dirname in - if parent = dir then ( - prerr_endline - ("Error: cannot find project root containing " ^ compilerConfigFile - ^ "."); - assert false) - else findProjectRoot ~dir:parent - -let readConfig ~getConfigFile ~namespace = - let projectRoot = findProjectRoot ~dir:(Sys.getcwd ()) in - let bsbProjectRoot = - match Sys.getenv_opt "BSB_PROJECT_ROOT" with - | None -> projectRoot - | Some s -> s - in - let parseConfig ~bsconf ~gtconf = - let moduleString = gtconf |> getStringOption "module" in - let moduleResolutionString = gtconf |> getStringOption "moduleResolution" in - let exportInterfacesBool = gtconf |> getBool "exportInterfaces" in - let generatedFileExtensionStringOption = - gtconf |> getStringOption "generatedFileExtension" - in - let shimsMap = - gtconf |> getShims - |> List.fold_left - (fun map (fromModule, toModule) -> - let moduleName = - (fromModule |> ModuleName.fromStringUnsafe : ModuleName.t) - in - let shimModuleName = toModule |> ModuleName.fromStringUnsafe in - ModuleNameMap.add moduleName shimModuleName map) - ModuleNameMap.empty - in - setDebug ~gtconf; - let module_ = - let packageSpecsModuleString = - match bsconf |> getOpt "package-specs" with - | Some (Obj {map = packageSpecs}) -> - packageSpecs |> getStringOption "module" - | _ -> None - in - (* Give priority to gentypeconfig, followed by package-specs *) - match (moduleString, packageSpecsModuleString) with - | Some "commonjs", _ -> CommonJS - | Some ("esmodule" | "es6"), _ -> ESModule - | None, Some "commonjs" -> CommonJS - | None, Some ("esmodule" | "es6" | "es6-global") -> ESModule - | _ -> default.module_ - in - let moduleResolution = - match moduleResolutionString with - | Some "node" -> Node - | Some "node16" -> Node16 - | Some "bundler" -> Bundler - | _ -> default.moduleResolution - in - let exportInterfaces = - match exportInterfacesBool with - | None -> default.exportInterfaces - | Some b -> b - in - let generatedFileExtension = generatedFileExtensionStringOption in - let externalStdlib = bsconf |> getStringOption "external-stdlib" in - let platformLib = - match externalStdlib with - | None -> "rescript" - | Some externalStdlib -> externalStdlib - in - if !Debug.config then ( - Log_.item "Project roLiterals.bsconfig_jsonot: %s\n" projectRoot; - if bsbProjectRoot <> projectRoot then - Log_.item "bsb project root: %s\n" bsbProjectRoot; - Log_.item "Config module:%s shims:%d entries \n" - (match moduleString with - | None -> "" - | Some s -> s) - (shimsMap |> ModuleNameMap.cardinal)); - let namespace = - match bsconf |> getOpt "namespace" with - | Some (True _) -> namespace - | _ -> default.namespace - in - let suffix = - match bsconf |> getStringOption "suffix" with - | Some s -> s - | _ -> default.suffix - in - let bsDependencies = - match bsconf |> getOpt "bs-dependencies" with - | Some (Arr {content}) -> - let strings = ref [] in - content - |> Array.iter (fun x -> - match x with - | Ext_json_types.Str {str} -> strings := str :: !strings - | _ -> ()); - !strings - | _ -> default.bsDependencies - in - let sources = - match bsconf |> getOpt "sources" with - | Some sourceItem -> Some sourceItem - | _ -> default.sources - in - let everything = false in - { - bsbProjectRoot; - bsDependencies; - suffix; - emitImportCurry = false; - emitImportReact = false; - emitTypePropDone = false; - everything; - exportInterfaces; - generatedFileExtension; - module_; - moduleResolution; - namespace; - platformLib; - projectRoot; - shimsMap; - sources; - } - in - match getConfigFile ~projectRoot with - | Some bsConfigFile -> ( - try - let json = bsConfigFile |> Ext_json_parse.parse_json_from_file in - match json with - | Obj {map = bsconf} -> ( - match bsconf |> getOpt "gentypeconfig" with - | Some (Obj {map = gtconf}) -> parseConfig ~bsconf ~gtconf - | _ -> default) - | _ -> default - with _ -> default) - | None -> default diff --git a/jscomp/gentype/GenTypeMain.ml b/jscomp/gentype/GenTypeMain.ml deleted file mode 100644 index 5b733f1..0000000 --- a/jscomp/gentype/GenTypeMain.ml +++ /dev/null @@ -1,170 +0,0 @@ -module StringSet = Set.Make (String) - -let cmtCheckAnnotations ~checkAnnotation inputCMT = - match inputCMT.Cmt_format.cmt_annots with - | Implementation structure -> - structure |> Annotation.structureCheckAnnotation ~checkAnnotation - | Interface signature -> - signature |> Annotation.signatureCheckAnnotation ~checkAnnotation - | _ -> false - -let cmtHasTypeErrors inputCMT = - match inputCMT.Cmt_format.cmt_annots with - | Partial_implementation _ | Partial_interface _ -> true - | _ -> false - -let structureItemIsDeclaration structItem = - match structItem.Typedtree.str_desc with - | Typedtree.Tstr_type _ | Tstr_modtype _ | Tstr_module _ -> true - | _ -> false - -let signatureItemIsDeclaration signatureItem = - match signatureItem.Typedtree.sig_desc with - | Typedtree.Tsig_type _ | Tsig_modtype _ -> true - | _ -> false - -let inputCmtTranslateTypeDeclarations ~config ~outputFileRelative ~resolver - inputCMT : CodeItem.translation = - let {Cmt_format.cmt_annots} = inputCMT in - let typeEnv = TypeEnv.root () in - let translations = - match cmt_annots with - | Implementation structure -> - { - structure with - str_items = - structure.str_items |> List.filter structureItemIsDeclaration; - } - |> TranslateStructure.translateStructure ~config ~outputFileRelative - ~resolver ~typeEnv - | Interface signature -> - { - signature with - sig_items = - signature.sig_items |> List.filter signatureItemIsDeclaration; - } - |> TranslateSignature.translateSignature ~config ~outputFileRelative - ~resolver ~typeEnv - | Packed _ | Partial_implementation _ | Partial_interface _ -> [] - in - translations |> Translation.combine - |> Translation.addTypeDeclarationsFromModuleEquations ~typeEnv - -let translateCMT ~config ~outputFileRelative ~resolver inputCMT : Translation.t - = - let {Cmt_format.cmt_annots} = inputCMT in - let typeEnv = TypeEnv.root () in - let translations = - match cmt_annots with - | Implementation structure -> - structure - |> TranslateStructure.translateStructure ~config ~outputFileRelative - ~resolver ~typeEnv - | Interface signature -> - signature - |> TranslateSignature.translateSignature ~config ~outputFileRelative - ~resolver ~typeEnv - | _ -> [] - in - translations |> Translation.combine - |> Translation.addTypeDeclarationsFromModuleEquations ~typeEnv - -let emitTranslation ~config ~fileName ~outputFile ~outputFileRelative ~resolver - ~sourceFile translation = - let codeText = - translation - |> EmitJs.emitTranslationAsString ~config ~fileName ~outputFileRelative - ~resolver ~inputCmtTranslateTypeDeclarations - in - let fileContents = - EmitType.fileHeader ~sourceFile:(Filename.basename sourceFile) - ^ "\n" ^ codeText ^ "\n" - in - GeneratedFiles.writeFileIfRequired ~outputFile ~fileContents - -let readCmt cmtFile = - try Cmt_format.read_cmt cmtFile - with Cmi_format.Error _ -> - Log_.item "Error loading %s\n\n" cmtFile; - Log_.item "It looks like you might have stale compilation artifacts.\n"; - Log_.item "Try to clean and rebuild.\n\n"; - assert false - -let processCmtFile cmt = - let config = Paths.readConfig ~namespace:(cmt |> Paths.findNameSpace) in - if !Debug.basic then Log_.item "Cmt %s\n" cmt; - let cmtFile = cmt |> Paths.getCmtFile in - if cmtFile <> "" then - let outputFile = cmt |> Paths.getOutputFile ~config in - let outputFileRelative = cmt |> Paths.getOutputFileRelative ~config in - let fileName = cmt |> Paths.getModuleName in - let isInterface = Filename.check_suffix cmtFile ".cmti" in - let resolver = - ModuleResolver.createLazyResolver ~config ~extensions:[".res"; ".shim.ts"] - ~excludeFile:(fun fname -> - fname = "React.res" || fname = "ReasonReact.res") - in - let inputCMT, hasGenTypeAnnotations = - let inputCMT = readCmt cmtFile in - let ignoreInterface = ref false in - let checkAnnotation ~loc:_ attributes = - if - attributes - |> Annotation.getAttributePayload - Annotation.tagIsGenTypeIgnoreInterface - <> None - then ignoreInterface := true; - attributes - |> Annotation.getAttributePayload - Annotation.tagIsOneOfTheGenTypeAnnotations - <> None - in - let hasGenTypeAnnotations = - inputCMT |> cmtCheckAnnotations ~checkAnnotation - in - if isInterface then - let cmtFileImpl = - (cmtFile |> (Filename.chop_extension [@doesNotRaise])) ^ ".cmt" - in - let inputCMTImpl = readCmt cmtFileImpl in - let hasGenTypeAnnotationsImpl = - inputCMTImpl - |> cmtCheckAnnotations ~checkAnnotation:(fun ~loc attributes -> - if attributes |> checkAnnotation ~loc then ( - if not !ignoreInterface then ( - Log_.Color.setup (); - Log_.info ~loc ~name:"Warning genType" (fun ppf () -> - Format.fprintf ppf - "Annotation is ignored as there's a .rei file")); - true) - else false) - in - ( (match !ignoreInterface with - | true -> inputCMTImpl - | false -> inputCMT), - match !ignoreInterface with - | true -> hasGenTypeAnnotationsImpl - | false -> hasGenTypeAnnotations ) - else (inputCMT, hasGenTypeAnnotations) - in - if hasGenTypeAnnotations then - let sourceFile = - match inputCMT.cmt_annots |> FindSourceFile.cmt with - | Some sourceFile -> sourceFile - | None -> ( - (fileName |> ModuleName.toString) - ^ - match isInterface with - | true -> ".resi" - | false -> ".res") - in - inputCMT - |> translateCMT ~config ~outputFileRelative ~resolver - |> emitTranslation ~config ~fileName ~outputFile ~outputFileRelative - ~resolver ~sourceFile - else if inputCMT |> cmtHasTypeErrors then - outputFile |> GeneratedFiles.logFileAction TypeError - else ( - outputFile |> GeneratedFiles.logFileAction NoMatch; - if Sys.file_exists outputFile then Sys.remove outputFile) -[@@live] diff --git a/jscomp/gentype/GeneratedFiles.ml b/jscomp/gentype/GeneratedFiles.ml deleted file mode 100644 index 5b22a99..0000000 --- a/jscomp/gentype/GeneratedFiles.ml +++ /dev/null @@ -1,52 +0,0 @@ -type fileAction = - | NoMatch (* No @genType annotation found. *) - | Replace (* Replace existing file on disk with new contents. *) - | Identical (* File already on disk with identical contents. Skip. *) - | TypeError - (* The cmt file was produced after a type error -- don't delete generated files. *) - | Write (* File not present on disk. *) - -let logFileAction fileAction fileName = - if !Debug.basic then - Log_.item "%s %s\n" - (match fileAction with - | NoMatch -> "NoMatch" - | Replace -> "Replace" - | Identical -> "Identical" - | TypeError -> "TypeError" - | Write -> "Write") - fileName - -let readLines (file : string) : string list = - let lines = ref [] in - let chan = open_in file in - let finished_lines = - try - while true do - lines := input_line chan :: !lines - done; - [] - with End_of_file -> - close_in chan [@doesNotRaise]; - !lines |> List.rev - in - finished_lines - -let readFile (file : string) : string = String.concat "\n" (readLines file) - -let writeFile (filePath : string) (contents : string) = - let outFile = open_out filePath in - output_string outFile contents; - close_out outFile [@doesNotRaise] - -let writeFileIfRequired ~outputFile ~fileContents = - if Sys.file_exists outputFile then - let oldContents = readFile outputFile in - let identical = oldContents = fileContents in - if identical then outputFile |> logFileAction Identical - else ( - outputFile |> logFileAction Replace; - writeFile outputFile fileContents) - else ( - outputFile |> logFileAction Write; - writeFile outputFile fileContents) diff --git a/jscomp/gentype/ImportPath.ml b/jscomp/gentype/ImportPath.ml deleted file mode 100644 index a1c1114..0000000 --- a/jscomp/gentype/ImportPath.ml +++ /dev/null @@ -1,29 +0,0 @@ -open GenTypeCommon - -type t = string * string - -let bsCurryPath ~config = ("", Config.getBsCurryPath ~config) - -let fromModule ~dir ~importExtension moduleName = - let withNoPath = - (moduleName |> ModuleName.toString |> ScopedPackage.removeGeneratedModule) - ^ importExtension - in - (dir, withNoPath) - -let fromStringUnsafe s = ("", s) - -let chopExtensionSafe (dir, s) = - try (dir, s |> Filename.chop_extension) with Invalid_argument _ -> (dir, s) - -let dump (dir, s) = NodeFilename.concat dir s - -let toCmt ~(config : Config.t) ~outputFileRelative (dir, s) = - let open Filename in - concat (outputFileRelative |> dirname) ((dir, s) |> chopExtensionSafe |> dump) - ^ (match config.namespace with - | None -> "" - | Some name -> "-" ^ name) - ^ ".cmt" - -let emit (dir, s) = (dir, s) |> dump diff --git a/jscomp/gentype/ImportPath.mli b/jscomp/gentype/ImportPath.mli deleted file mode 100644 index 740e629..0000000 --- a/jscomp/gentype/ImportPath.mli +++ /dev/null @@ -1,11 +0,0 @@ -open GenTypeCommon - -type t - -val bsCurryPath : config:Config.t -> t -val chopExtensionSafe : t -> t [@@live] -val dump : t -> string -val emit : t -> string -val fromModule : dir:string -> importExtension:string -> ModuleName.t -> t -val fromStringUnsafe : string -> t -val toCmt : config:Config.t -> outputFileRelative:string -> t -> string diff --git a/jscomp/gentype/Indent.ml b/jscomp/gentype/Indent.ml deleted file mode 100644 index f0282b3..0000000 --- a/jscomp/gentype/Indent.ml +++ /dev/null @@ -1,23 +0,0 @@ -type t = string option - -let break ~indent = - match indent with - | None -> "" - | Some s -> "\n" ^ s -let more indent = - match indent with - | None -> None - | Some s -> Some (" " ^ s) - -let heuristicFields ~indent fields = - let threshold = 2 in - match fields |> List.length > threshold && indent = None with - | true -> Some "" - | false -> indent - -let heuristicVariants ~indent rendered = - let threshold = 40 in - let break = rendered |> String.concat " " |> String.length > threshold in - match break && indent = None with - | true -> Some " " - | false -> indent diff --git a/jscomp/gentype/Log_.ml b/jscomp/gentype/Log_.ml deleted file mode 100644 index 377821f..0000000 --- a/jscomp/gentype/Log_.ml +++ /dev/null @@ -1,101 +0,0 @@ -module Color = struct - type color = Red | Yellow | Magenta | Cyan - type style = FG of color | Bold | Dim - - let code_of_style = function - | FG Red -> "31" - | FG Yellow -> "33" - | FG Magenta -> "35" - | FG Cyan -> "36" - | Bold -> "1" - | Dim -> "2" - - let style_of_stag s = - match s with - | Format.String_tag "error" -> [Bold; FG Red] - | Format.String_tag "warning" -> [Bold; FG Magenta] - | Format.String_tag "info" -> [Bold; FG Yellow] - | Format.String_tag "dim" -> [Dim] - | Format.String_tag "filename" -> [FG Cyan] - | _ -> [] - - let ansi_of_stag s = - let l = style_of_stag s in - let s = String.concat ";" (List.map code_of_style l) in - "\027[" ^ s ^ "m" - - let reset_lit = "\027[0m" - - let color_functions = - (({ - mark_open_stag = (fun s -> ansi_of_stag s); - mark_close_stag = (fun _ -> reset_lit); - print_open_stag = (fun _ -> ()); - print_close_stag = (fun _ -> ()); - } - : Format.formatter_stag_functions) - : Format.formatter_stag_functions) - - let setup () = - Format.pp_set_mark_tags Format.std_formatter true; - Format.pp_set_formatter_stag_functions Format.std_formatter color_functions - - let error ppf s = Format.fprintf ppf "@{%s@}" s [@@dead "Color.error"] - let info ppf s = Format.fprintf ppf "@{%s@}" s -end - -module Loc = struct - let print_filename ppf file = - match file with - (* modified *) - | "_none_" | "" -> Format.fprintf ppf "(No file name)" - | real_file -> Format.fprintf ppf "%s" (Location.show_filename real_file) - - let print_loc ~normalizedRange ppf (loc : Location.t) = - let file, _, _ = Location.get_pos_info loc.loc_start in - if file = "//toplevel//" then - Format.fprintf ppf "Characters %i-%i" loc.loc_start.pos_cnum - loc.loc_end.pos_cnum - else - let dim_loc ppf = function - | None -> () - | Some - ((start_line, start_line_start_char), (end_line, end_line_end_char)) - -> - if start_line = end_line then - if start_line_start_char = end_line_end_char then - Format.fprintf ppf ":@{%i:%i@}" start_line - start_line_start_char - else - Format.fprintf ppf ":@{%i:%i-%i@}" start_line - start_line_start_char end_line_end_char - else - Format.fprintf ppf ":@{%i:%i-%i:%i@}" start_line - start_line_start_char end_line end_line_end_char - in - Format.fprintf ppf "@{%a@}%a" print_filename file dim_loc - normalizedRange - - let print ppf (loc : Location.t) = - let _file, start_line, start_char = Location.get_pos_info loc.loc_start in - let _, end_line, end_char = Location.get_pos_info loc.loc_end in - let normalizedRange = - if start_char == -1 || end_char == -1 then None - else if start_line = end_line && start_char >= end_char then - let same_char = start_char + 1 in - Some ((start_line, same_char), (end_line, same_char)) - else Some ((start_line, start_char + 1), (end_line, end_char)) - in - - Format.fprintf ppf "@[%a@]" (print_loc ~normalizedRange) loc -end - -let item x = - Format.fprintf Format.std_formatter " "; - Format.fprintf Format.std_formatter x - -let logKind body ~color ~loc ~name = - Format.fprintf Format.std_formatter "@[@,%a@,%a@,%a@]@." color name - Loc.print loc body () - -let info body ~loc ~name = logKind body ~color:Color.info ~loc ~name diff --git a/jscomp/gentype/ModuleExtension.ml b/jscomp/gentype/ModuleExtension.ml deleted file mode 100644 index c983f4e..0000000 --- a/jscomp/gentype/ModuleExtension.ml +++ /dev/null @@ -1,28 +0,0 @@ -open GenTypeCommon - -let shimTsOutputFileExtension ~(config : Config.t) = - match config.moduleResolution with - | Node -> ".shim" - | Node16 -> ".shim.js" - | Bundler -> ".shim.ts" - -let generatedFilesExtension ~(config : Config.t) = - match config.generatedFileExtension with - | Some s -> - (* from .foo.bar to .foo *) - Filename.remove_extension s - | None -> ".gen" - -let tsInputFileSuffix ~(config : Config.t) = - match config.generatedFileExtension with - | Some s when Filename.extension s <> "" (* double extension *) -> s - | _ -> generatedFilesExtension ~config ^ ".tsx" - -let tsOutputFileSuffix ~(config : Config.t) = - generatedFilesExtension ~config ^ ".js" - -let generatedModuleExtension ~(config : Config.t) = - match config.moduleResolution with - | Node -> generatedFilesExtension ~config - | Node16 -> tsOutputFileSuffix ~config - | Bundler -> tsInputFileSuffix ~config diff --git a/jscomp/gentype/ModuleName.ml b/jscomp/gentype/ModuleName.ml deleted file mode 100644 index 549942e..0000000 --- a/jscomp/gentype/ModuleName.ml +++ /dev/null @@ -1,28 +0,0 @@ -type t = string - -let curry = "Curry" -let rescriptPervasives = "RescriptPervasives" - -let sanitizeId s = - let s = - if String.contains s '.' || String.contains s '[' || String.contains s ']' - then - s - |> String.map (function - | '.' | '[' | ']' -> '_' - | c -> c) - else s - in - if s <> "" && (s.[0] [@doesNotRaise]) >= 'A' && (s.[0] [@doesNotRaise]) <= 'z' - then s - else "_" ^ s - -let forJsFile s = sanitizeId s ^ "JS" - -let forInnerModule ~fileName ~innerModuleName = - (fileName |> forJsFile) ^ "." ^ innerModuleName - -let fromStringUnsafe s = s -let toString s = s -let compare (s1 : string) s2 = compare s1 s2 -let uncapitalize = String.uncapitalize_ascii diff --git a/jscomp/gentype/ModuleName.mli b/jscomp/gentype/ModuleName.mli deleted file mode 100644 index bf1fa3d..0000000 --- a/jscomp/gentype/ModuleName.mli +++ /dev/null @@ -1,13 +0,0 @@ -type t - -val compare : t -> t -> int -val curry : t -val forJsFile : t -> t -val forInnerModule : fileName:t -> innerModuleName:string -> t - -val fromStringUnsafe : string -> t -(** Used to turn strings read from external files into module names. *) - -val rescriptPervasives : t -val toString : t -> string -val uncapitalize : t -> t diff --git a/jscomp/gentype/ModuleResolver.ml b/jscomp/gentype/ModuleResolver.ml deleted file mode 100644 index 838ecca..0000000 --- a/jscomp/gentype/ModuleResolver.ml +++ /dev/null @@ -1,284 +0,0 @@ -open GenTypeCommon -module ModuleNameMap = Map.Make (ModuleName) - -let ( +++ ) = Filename.concat - -(** Read all the dirs from a library in node_modules *) -let readBsDependenciesDirs ~root = - let dirs = ref [] in - let rec findSubDirs dir = - let absDir = - match dir = "" with - | true -> root - | false -> root +++ dir - in - if Sys.file_exists absDir && Sys.is_directory absDir then ( - dirs := dir :: !dirs; - absDir |> Sys.readdir |> Array.iter (fun d -> findSubDirs (dir +++ d))) - in - findSubDirs ""; - !dirs - -type pkgs = {dirs: string list; pkgs: (string, string) Hashtbl.t} - -let readDirsFromConfig ~(config : Config.t) = - let dirs = ref [] in - let root = config.projectRoot in - let ( +++ ) = Filename.concat in - let rec processDir ~subdirs dir = - let absDir = - match dir = "" with - | true -> root - | false -> root +++ dir - in - if Sys.file_exists absDir && Sys.is_directory absDir then ( - dirs := dir :: !dirs; - if subdirs then - absDir |> Sys.readdir - |> Array.iter (fun d -> processDir ~subdirs (dir +++ d))) - in - let rec processSourceItem (sourceItem : Ext_json_types.t) = - match sourceItem with - | Str {str} -> str |> processDir ~subdirs:false - | Obj {map} -> ( - match Map_string.find_opt map "dir" with - | Some (Str {str}) -> - let subdirs = - match Map_string.find_opt map "subdirs" with - | Some (True _) -> true - | Some (False _) -> false - | _ -> false - in - str |> processDir ~subdirs - | _ -> ()) - | Arr {content} -> Array.iter processSourceItem content - | _ -> () - in - (match config.sources with - | Some sourceItem -> processSourceItem sourceItem - | None -> ()); - !dirs - -let readSourceDirs ~(config : Config.t) = - let sourceDirs = - ["lib"; "bs"; ".sourcedirs.json"] - |> List.fold_left ( +++ ) config.bsbProjectRoot - in - let dirs = ref [] in - let pkgs = Hashtbl.create 1 in - let readDirs json = - match json with - | Ext_json_types.Obj {map} -> ( - match Map_string.find_opt map "dirs" with - | Some (Arr {content}) -> - content - |> Array.iter (fun x -> - match x with - | Ext_json_types.Str {str} -> dirs := str :: !dirs - | _ -> ()); - () - | _ -> ()) - | _ -> () - in - let readPkgs json = - match json with - | Ext_json_types.Obj {map} -> ( - match Map_string.find_opt map "pkgs" with - | Some (Arr {content}) -> - content - |> Array.iter (fun x -> - match x with - | Ext_json_types.Arr - {content = [|Str {str = name}; Str {str = path}|]} -> - Hashtbl.add pkgs name path - | _ -> ()); - () - | _ -> ()) - | _ -> () - in - if sourceDirs |> Sys.file_exists then - try - let json = sourceDirs |> Ext_json_parse.parse_json_from_file in - if config.bsbProjectRoot <> config.projectRoot then - dirs := readDirsFromConfig ~config - else readDirs json; - readPkgs json - with _ -> () - else ( - Log_.item "Warning: can't find source dirs: %s\n" sourceDirs; - Log_.item "Types for cross-references will not be found by genType.\n"; - dirs := readDirsFromConfig ~config); - {dirs = !dirs; pkgs} - -(** Read the project's .sourcedirs.json file if it exists - and build a map of the files with the given extension - back to the directory where they belong. *) -let sourcedirsJsonToMap ~config ~extensions ~excludeFile = - let rec chopExtensions fname = - match fname |> Filename.chop_extension with - | fnameChopped -> fnameChopped |> chopExtensions - | exception _ -> fname - in - let fileMap = ref ModuleNameMap.empty in - let bsDependenciesFileMap = ref ModuleNameMap.empty in - let filterGivenExtension fileName = - extensions |> List.exists (fun ext -> Filename.check_suffix fileName ext) - && not (excludeFile fileName) - in - let addDir ~dirOnDisk ~dirEmitted ~filter ~map = - dirOnDisk |> Sys.readdir - |> Array.iter (fun fname -> - if fname |> filter then - map := - !map - |> ModuleNameMap.add - (fname |> chopExtensions |> ModuleName.fromStringUnsafe) - dirEmitted) - in - let {dirs; pkgs} = readSourceDirs ~config in - dirs - |> List.iter (fun dir -> - addDir ~dirEmitted:dir - ~dirOnDisk:(config.projectRoot +++ dir) - ~filter:filterGivenExtension ~map:fileMap); - config.bsDependencies - |> List.iter (fun packageName -> - match Hashtbl.find pkgs packageName with - | path -> - let root = ["lib"; "bs"] |> List.fold_left ( +++ ) path in - let filter fileName = - [".cmt"; ".cmti"] - |> List.exists (fun ext -> Filename.check_suffix fileName ext) - in - readBsDependenciesDirs ~root - |> List.iter (fun dir -> - let dirOnDisk = root +++ dir in - let dirEmitted = packageName +++ dir in - addDir ~dirEmitted ~dirOnDisk ~filter - ~map:bsDependenciesFileMap) - | exception Not_found -> ()); - (!fileMap, !bsDependenciesFileMap) - -type case = Lowercase | Uppercase - -type resolver = { - lazyFind: - (useBsDependencies:bool -> ModuleName.t -> (string * case * bool) option) - Lazy.t; -} - -let createLazyResolver ~config ~extensions ~excludeFile = - { - lazyFind = - lazy - (let moduleNameMap, bsDependenciesFileMap = - sourcedirsJsonToMap ~config ~extensions ~excludeFile - in - let find ~bsDependencies ~map moduleName = - match map |> ModuleNameMap.find moduleName with - | resolvedModuleDir -> - Some (resolvedModuleDir, Uppercase, bsDependencies) - | exception Not_found -> ( - match - map |> ModuleNameMap.find (moduleName |> ModuleName.uncapitalize) - with - | resolvedModuleDir -> - Some (resolvedModuleDir, Lowercase, bsDependencies) - | exception Not_found -> None) - in - fun ~useBsDependencies moduleName -> - match - moduleName |> find ~bsDependencies:false ~map:moduleNameMap - with - | None when useBsDependencies -> - moduleName |> find ~bsDependencies:true ~map:bsDependenciesFileMap - | res -> res); - } - -let apply ~resolver ~useBsDependencies moduleName = - moduleName |> Lazy.force resolver.lazyFind ~useBsDependencies - -(** Resolve a reference to ModuleName, and produce a path suitable for require. - E.g. require "../foo/bar/ModuleName.ext" where ext is ".res" or ".js". *) -let resolveModule ~(config : Config.t) ~importExtension ~outputFileRelative - ~resolver ~useBsDependencies moduleName = - let outputFileRelativeDir = - (* e.g. src if we're generating src/File.bs.js *) - Filename.dirname outputFileRelative - in - let outputFileAbsoluteDir = config.projectRoot +++ outputFileRelativeDir in - let moduleNameResFile = - (* Check if the module is in the same directory as the file being generated. - So if e.g. project_root/src/ModuleName.res exists. *) - outputFileAbsoluteDir +++ (ModuleName.toString moduleName ^ ".res") - in - let candidate = - (* e.g. import "./Modulename.ext" *) - moduleName - |> ImportPath.fromModule ~dir:Filename.current_dir_name ~importExtension - in - if Sys.file_exists moduleNameResFile then candidate - else - let rec pathToList path = - let isRoot = path |> Filename.basename = path in - match isRoot with - | true -> [path] - | false -> - (path |> Filename.basename) :: (path |> Filename.dirname |> pathToList) - in - match moduleName |> apply ~resolver ~useBsDependencies with - | None -> candidate - | Some (resolvedModuleDir, case, bsDependencies) -> - (* e.g. "dst" in case of dst/ModuleName.res *) - let walkUpOutputDir = - outputFileRelativeDir |> pathToList - |> List.map (fun _ -> Filename.parent_dir_name) - |> fun l -> - match l with - | [] -> "" - | _ :: rest -> rest |> List.fold_left ( +++ ) Filename.parent_dir_name - in - let fromOutputDirToModuleDir = - (* e.g. "../dst" *) - match bsDependencies with - | true -> resolvedModuleDir - | false -> walkUpOutputDir +++ resolvedModuleDir - in - (* e.g. import "../dst/ModuleName.ext" *) - (match case = Uppercase with - | true -> moduleName - | false -> moduleName |> ModuleName.uncapitalize) - |> ImportPath.fromModule ~dir:fromOutputDirToModuleDir ~importExtension - -let resolveGeneratedModule ~config ~outputFileRelative ~resolver moduleName = - if !Debug.moduleResolution then - Log_.item "Resolve Generated Module: %s\n" - (moduleName |> ModuleName.toString); - let importPath = - resolveModule ~config - ~importExtension:(ModuleExtension.generatedModuleExtension ~config) - ~outputFileRelative ~resolver ~useBsDependencies:true moduleName - in - if !Debug.moduleResolution then - Log_.item "Import Path: %s\n" (importPath |> ImportPath.dump); - importPath - -(** Returns the path to import a given Reason module name. *) -let importPathForReasonModuleName ~(config : Config.t) ~outputFileRelative - ~resolver moduleName = - if !Debug.moduleResolution then - Log_.item "Resolve Reason Module: %s\n" (moduleName |> ModuleName.toString); - match config.shimsMap |> ModuleNameMap.find moduleName with - | shimModuleName -> - if !Debug.moduleResolution then - Log_.item "ShimModuleName: %s\n" (shimModuleName |> ModuleName.toString); - let importExtension = ModuleExtension.shimTsOutputFileExtension ~config in - let importPath = - resolveModule ~config ~importExtension ~outputFileRelative ~resolver - ~useBsDependencies:false shimModuleName - in - if !Debug.moduleResolution then - Log_.item "Import Path: %s\n" (importPath |> ImportPath.dump); - importPath - | exception Not_found -> - moduleName |> resolveGeneratedModule ~config ~outputFileRelative ~resolver diff --git a/jscomp/gentype/NamedArgs.ml b/jscomp/gentype/NamedArgs.ml deleted file mode 100644 index a5c0d06..0000000 --- a/jscomp/gentype/NamedArgs.ml +++ /dev/null @@ -1,14 +0,0 @@ -open GenTypeCommon - -let group labeledTypes = - let types = - Ext_list.map labeledTypes (fun (lbl, aType) -> - match lbl with - | Nolabel -> {aName = ""; aType} - | Label lbl -> {aName = lbl; aType} - | OptLabel lbl -> {aName = lbl; aType = Option aType}) - in - match types with - | [{aType}] when aType = unitT -> - [] (* treat a single argument of type unit as no argument *) - | _ -> types diff --git a/jscomp/gentype/Paths.ml b/jscomp/gentype/Paths.ml deleted file mode 100644 index ed95905..0000000 --- a/jscomp/gentype/Paths.ml +++ /dev/null @@ -1,74 +0,0 @@ -open GenTypeCommon - -let concat = Filename.concat - -let handleNamespace cmt = - let cutAfterDash s = - match String.index s '-' with - | n -> String.sub s 0 n [@doesNotRaise] - | exception Not_found -> s - in - let noDir = Filename.basename cmt = cmt in - if noDir then cmt |> (Filename.chop_extension [@doesNotRaise]) |> cutAfterDash - else - let dir = cmt |> Filename.dirname in - let base = - cmt |> Filename.basename |> (Filename.chop_extension [@doesNotRaise]) - |> cutAfterDash - in - Filename.concat dir base - -let findNameSpace cmt = - let keepAfterDash s = - match String.index s '-' with - | n -> - Some ((String.sub s (n + 1) [@doesNotRaise]) (String.length s - n - 1)) - | exception Not_found -> None - in - cmt |> Filename.basename |> (Filename.chop_extension [@doesNotRaise]) - |> keepAfterDash - -let getOutputFileRelative ~config cmt = - (cmt |> handleNamespace) ^ ModuleExtension.tsInputFileSuffix ~config - -let getOutputFile ~(config : Config.t) cmt = - Filename.concat config.projectRoot (getOutputFileRelative ~config cmt) - -let getModuleName cmt = - cmt |> handleNamespace |> Filename.basename |> ModuleName.fromStringUnsafe - -let getCmtFile cmt = - let pathCmt = Filename.concat (Sys.getcwd ()) cmt in - let cmtFile = - if Filename.check_suffix pathCmt ".cmt" then - let pathCmtLowerCase = - let dirName = pathCmt |> Filename.dirname in - let baseName = pathCmt |> Filename.basename in - Filename.concat dirName (baseName |> String.uncapitalize_ascii) - in - let pathCmti = - (Filename.chop_extension pathCmt [@doesNotRaise]) ^ ".cmti" - in - let pathCmtiLowerCase = - (Filename.chop_extension pathCmtLowerCase [@doesNotRaise]) ^ ".cmti" - in - if Sys.file_exists pathCmtiLowerCase then pathCmtiLowerCase - else if Sys.file_exists pathCmti then pathCmti - else if Sys.file_exists pathCmtLowerCase then pathCmtLowerCase - else if Sys.file_exists pathCmt then pathCmt - else "" - else "" - in - cmtFile - -let getConfigFile ~projectRoot = - let config = concat projectRoot Config.compilerConfigFile in - match config |> Sys.file_exists with - | true -> Some config - | false -> ( - let config = concat projectRoot Config.legacyCompilerConfigFile in - match config |> Sys.file_exists with - | true -> Some config - | false -> None) - -let readConfig ~namespace = Config.readConfig ~getConfigFile ~namespace diff --git a/jscomp/gentype/ResolvedName.ml b/jscomp/gentype/ResolvedName.ml deleted file mode 100644 index 0c41d23..0000000 --- a/jscomp/gentype/ResolvedName.ml +++ /dev/null @@ -1,58 +0,0 @@ -type t = string list - -let dot s x = x @ [s] -let fromString x = [x] -let toList x = x -let toString x = x |> String.concat "_" - -type eq = t * t - -module NameSet = Set.Make (struct - type nonrec t = t - - let rec compare (x : t) (y : t) = - match (x, y) with - | [], [] -> 0 - | [], _ :: _ -> -1 - | _ :: _, [] -> -1 - | s1 :: rest1, s2 :: rest2 -> ( - let n = String.compare s1 s2 in - match n <> 0 with - | true -> n - | false -> compare rest1 rest2) -end) - -let rec applyEquation ~(el : t) (eq : eq) : t list = - match (eq, el) with - | ([], rhs), _ -> [rhs @ el] - | (s1 :: rest1, rhs), s2 :: rest2 -> ( - match s1 = s2 with - | true -> (rest1, rhs) |> applyEquation ~el:rest2 - | false -> []) - | (_ :: _, _), [] -> [] - -let rec applyEquationsToElements ~(eqs : eq list) ~seen (elements : t list) : - eq list = - let applyEqs el = - let freshElements = - eqs - |> List.map (applyEquation ~el) - |> List.concat - |> List.filter (fun y -> not (NameSet.mem y seen)) - in - freshElements |> List.map (fun elFresh -> (elFresh, el)) - in - let newEquations = elements |> List.map applyEqs |> List.concat in - let newElements = newEquations |> List.map fst in - let newSeen = NameSet.union seen (newElements |> NameSet.of_list) in - match newEquations = [] with - | true -> newEquations - | false -> - newEquations @ (newElements |> applyEquationsToElements ~eqs ~seen:newSeen) - -(* Apply equations of the form e.g. X.Y = A from the alias: module A = X.Y. - Return a list of equations on types. - E.g. if the element is X.Y.t, return equation A.t = X.Y.t *) - -let applyEquations ~(eqs : eq list) (el : t) : eq list = - [el] |> applyEquationsToElements ~eqs ~seen:NameSet.empty diff --git a/jscomp/gentype/ResolvedName.mli b/jscomp/gentype/ResolvedName.mli deleted file mode 100644 index 00a7804..0000000 --- a/jscomp/gentype/ResolvedName.mli +++ /dev/null @@ -1,8 +0,0 @@ -type t -type eq = t * t - -val applyEquations : eqs:eq list -> t -> eq list -val dot : string -> t -> t -val fromString : string -> t -val toList : t -> string list -val toString : t -> string diff --git a/jscomp/gentype/Runtime.ml b/jscomp/gentype/Runtime.ml deleted file mode 100644 index 2238fa7..0000000 --- a/jscomp/gentype/Runtime.ml +++ /dev/null @@ -1,36 +0,0 @@ -type moduleItem = string -type moduleAccessPath = Root of string | Dot of moduleAccessPath * moduleItem - -let newModuleItem ~name = name - -let rec emitModuleAccessPath ~config moduleAccessPath = - match moduleAccessPath with - | Root s -> s - | Dot (p, moduleItem) -> - p |> emitModuleAccessPath ~config |> EmitText.fieldAccess ~label:moduleItem - -let jsVariantTag ~polymorphic ~tag = - match polymorphic with - | true -> "NAME" - | false -> ( - match tag with - | Some tag -> tag - | None -> "TAG") - -let jsVariantPayloadTag ~n = "_" ^ string_of_int n - -let jsVariantValue ~polymorphic = - match polymorphic with - | true -> "VAL" - | false -> "value" - -let isMutableObjectField name = - String.length name >= 2 - && (String.sub name (String.length name - 2) 2 [@doesNotRaise]) = "#=" - -(** Mutable fields, i.e. fields annotated "[@bs.set]" - are represented as extra fields called "fieldName#=" - preceding the normal field. *) -let checkMutableObjectField ~previousName ~name = previousName = name ^ "#=" - -let default = "$$default" diff --git a/jscomp/gentype/Runtime.mli b/jscomp/gentype/Runtime.mli deleted file mode 100644 index a7d16b4..0000000 --- a/jscomp/gentype/Runtime.mli +++ /dev/null @@ -1,14 +0,0 @@ -open GenTypeCommon - -type moduleItem -type moduleAccessPath = Root of string | Dot of moduleAccessPath * moduleItem - -val checkMutableObjectField : previousName:string -> name:string -> bool -val default : string -val emitModuleAccessPath : config:Config.t -> moduleAccessPath -> string - -val isMutableObjectField : string -> bool -val newModuleItem : name:string -> moduleItem -val jsVariantTag : polymorphic:bool -> tag:string option -> string -val jsVariantPayloadTag : n:int -> string -val jsVariantValue : polymorphic:bool -> string diff --git a/jscomp/gentype/TranslateCoreType.ml b/jscomp/gentype/TranslateCoreType.ml deleted file mode 100644 index 0325f04..0000000 --- a/jscomp/gentype/TranslateCoreType.ml +++ /dev/null @@ -1,277 +0,0 @@ -open GenTypeCommon -open! TranslateTypeExprFromTypes - -let removeOption ~(label : Asttypes.arg_label) (coreType : Typedtree.core_type) - = - match (coreType.ctyp_desc, label) with - | Ttyp_constr (Path.Pident id, _, [t]), Optional lbl - when Ident.name id = "option" -> - Some (lbl, t) - | Ttyp_constr (Pdot (Path.Pident nameSpace, id, _), _, [t]), Optional lbl - when (* This has a different representation in 4.03+ *) - Ident.name nameSpace = "FB" && id = "option" -> - Some (lbl, t) - | _ -> None - -type processVariant = { - noPayloads: (string * Typedtree.attributes) list; - payloads: (string * Typedtree.attributes * Typedtree.core_type) list; - inherits: Typedtree.core_type list; -} - -let processVariant rowFields = - let rec loop ~noPayloads ~payloads ~inherits fields = - match fields with - | Typedtree.Ttag - ({txt = label}, attributes, _, (* only variants with no payload *) []) - :: otherFields -> - otherFields - |> loop - ~noPayloads:((label, attributes) :: noPayloads) - ~payloads ~inherits - | Ttag ({txt = label}, attributes, _, [payload]) :: otherFields -> - otherFields - |> loop ~noPayloads - ~payloads:((label, attributes, payload) :: payloads) - ~inherits - | Ttag (_, _, _, _ :: _ :: _) :: otherFields -> - (* Unknown: skipping *) - otherFields |> loop ~noPayloads ~payloads ~inherits - | Tinherit t :: otherFields -> - otherFields |> loop ~noPayloads ~payloads ~inherits:(t :: inherits) - | [] -> - { - noPayloads = noPayloads |> List.rev; - payloads = payloads |> List.rev; - inherits = inherits |> List.rev; - } - in - rowFields |> loop ~noPayloads:[] ~payloads:[] ~inherits:[] - -let rec translateArrowType ~config ~typeVarsGen ~noFunctionReturnDependencies - ~typeEnv ~revArgDeps ~revArgs (coreType : Typedtree.core_type) = - match coreType.ctyp_desc with - | Ttyp_arrow (Nolabel, coreType1, coreType2) -> - let {dependencies; type_} = - coreType1 |> fun __x -> - translateCoreType_ ~config ~typeVarsGen ~typeEnv __x - in - let nextRevDeps = List.rev_append dependencies revArgDeps in - coreType2 - |> translateArrowType ~config ~typeVarsGen ~noFunctionReturnDependencies - ~typeEnv ~revArgDeps:nextRevDeps - ~revArgs:((Nolabel, type_) :: revArgs) - | Ttyp_arrow (((Labelled lbl | Optional lbl) as label), coreType1, coreType2) - -> ( - let asLabel = - match coreType.ctyp_attributes |> Annotation.getGenTypeAsRenaming with - | Some s -> s - | None -> "" - in - match coreType1 |> removeOption ~label with - | None -> - let {dependencies; type_ = type1} = - coreType1 |> translateCoreType_ ~config ~typeVarsGen ~typeEnv - in - let nextRevDeps = List.rev_append dependencies revArgDeps in - coreType2 - |> translateArrowType ~config ~typeVarsGen ~noFunctionReturnDependencies - ~typeEnv ~revArgDeps:nextRevDeps - ~revArgs: - (( Label - (match asLabel = "" with - | true -> lbl - | false -> asLabel), - type1 ) - :: revArgs) - | Some (lbl, t1) -> - let {dependencies; type_ = type1} = - t1 |> translateCoreType_ ~config ~typeVarsGen ~typeEnv - in - let nextRevDeps = List.rev_append dependencies revArgDeps in - coreType2 - |> translateArrowType ~config ~typeVarsGen ~noFunctionReturnDependencies - ~typeEnv ~revArgDeps:nextRevDeps - ~revArgs:((OptLabel lbl, type1) :: revArgs)) - | _ -> - let {dependencies; type_ = retType} = - coreType |> translateCoreType_ ~config ~typeVarsGen ~typeEnv - in - let allDeps = - List.rev_append revArgDeps - (match noFunctionReturnDependencies with - | true -> [] - | false -> dependencies) - in - let labeledConvertableTypes = revArgs |> List.rev in - let argTypes = labeledConvertableTypes |> NamedArgs.group in - let functionType = Function {argTypes; retType; typeVars = []} in - {dependencies = allDeps; type_ = functionType} - -and translateCoreType_ ~config ~typeVarsGen - ?(noFunctionReturnDependencies = false) ~typeEnv - (coreType : Typedtree.core_type) = - match coreType.ctyp_desc with - | Ttyp_alias (ct, _) -> - ct - |> translateCoreType_ ~config ~typeVarsGen - ~noFunctionReturnDependencies:false ~typeEnv - | Ttyp_object (tObj, closedFlag) -> - let getFieldType objectField = - match objectField with - | Typedtree.OTtag ({txt = name}, _, t) -> - ( name, - match name |> Runtime.isMutableObjectField with - | true -> {dependencies = []; type_ = ident ""} - | false -> t |> translateCoreType_ ~config ~typeVarsGen ~typeEnv ) - | OTinherit t -> - ("Inherit", t |> translateCoreType_ ~config ~typeVarsGen ~typeEnv) - in - let fieldsTranslations = tObj |> List.map getFieldType in - translateObjType - (match closedFlag = Closed with - | true -> Closed - | false -> Open) - fieldsTranslations - | Ttyp_constr (path, _, typeParams) -> - let paramsTranslation = - typeParams |> translateCoreTypes_ ~config ~typeVarsGen ~typeEnv - in - TranslateTypeExprFromTypes.translateConstr ~config ~paramsTranslation ~path - ~typeEnv - | Ttyp_poly (_, t) -> - t - |> translateCoreType_ ~config ~typeVarsGen ~noFunctionReturnDependencies - ~typeEnv - | Ttyp_arrow _ -> - coreType - |> translateArrowType ~config ~typeVarsGen ~noFunctionReturnDependencies - ~typeEnv ~revArgDeps:[] ~revArgs:[] - | Ttyp_tuple listExp -> - let innerTypesTranslation = - listExp |> translateCoreTypes_ ~config ~typeVarsGen ~typeEnv - in - let innerTypes = innerTypesTranslation |> List.map (fun {type_} -> type_) in - let innerTypesDeps = - innerTypesTranslation - |> List.map (fun {dependencies} -> dependencies) - |> List.concat - in - let tupleType = Tuple innerTypes in - {dependencies = innerTypesDeps; type_ = tupleType} - | Ttyp_var s -> {dependencies = []; type_ = TypeVar s} - | Ttyp_variant (rowFields, _, _) -> ( - match rowFields |> processVariant with - | {noPayloads; payloads; inherits} -> - let asString = - coreType.ctyp_attributes - |> Annotation.hasAttribute Annotation.tagIsString - in - let asInt = - coreType.ctyp_attributes |> Annotation.hasAttribute Annotation.tagIsInt - in - let lastBsInt = ref (-1) in - let noPayloads = - noPayloads - |> List.map (fun (label, attributes) -> - let labelJS = - if asString then - match attributes |> Annotation.getAsString with - | Some labelRenamed -> StringLabel labelRenamed - | None -> - if isNumber label then IntLabel label - else StringLabel label - else if asInt then ( - match attributes |> Annotation.getAsInt with - | Some n -> - lastBsInt := n; - IntLabel (string_of_int n) - | None -> - lastBsInt := !lastBsInt + 1; - IntLabel (string_of_int !lastBsInt)) - else if isNumber label then IntLabel label - else StringLabel label - in - {labelJS}) - in - let payloadsTranslations = - payloads - |> List.map (fun (label, attributes, payload) -> - ( label, - attributes, - payload |> translateCoreType_ ~config ~typeVarsGen ~typeEnv )) - in - let payloads = - payloadsTranslations - |> List.map (fun (label, _attributes, translation) -> - { - case = - { - labelJS = - (if isNumber label then IntLabel label - else StringLabel label); - }; - t = translation.type_; - }) - in - let inheritsTranslations = - inherits |> translateCoreTypes_ ~config ~typeVarsGen ~typeEnv - in - let inherits = inheritsTranslations |> List.map (fun {type_} -> type_) in - let type_ = - createVariant ~noPayloads ~payloads ~inherits ~polymorphic:true - ~tag:None ~unboxed:false - in - let dependencies = - (inheritsTranslations - |> List.map (fun {dependencies} -> dependencies) - |> List.concat) - @ (payloadsTranslations - |> List.map (fun (_, _, {dependencies}) -> dependencies) - |> List.concat) - in - {dependencies; type_}) - | Ttyp_package {pack_path; pack_fields} -> ( - match typeEnv |> TypeEnv.lookupModuleTypeSignature ~path:pack_path with - | Some (signature, typeEnv) -> - let typeEquationsTranslation = - pack_fields - |> List.map (fun (x, t) -> - ( x.Asttypes.txt, - t |> translateCoreType_ ~config ~typeVarsGen ~typeEnv )) - in - let typeEquations = - typeEquationsTranslation - |> List.map (fun (x, translation) -> (x, translation.type_)) - in - let dependenciesFromTypeEquations = - typeEquationsTranslation - |> List.map (fun (_, translation) -> translation.dependencies) - |> List.flatten - in - let typeEnv1 = typeEnv |> TypeEnv.addTypeEquations ~typeEquations in - let dependenciesFromRecordType, type_ = - signature.sig_type - |> signatureToModuleRuntimeRepresentation ~config ~typeVarsGen - ~typeEnv:typeEnv1 - in - { - dependencies = dependenciesFromTypeEquations @ dependenciesFromRecordType; - type_; - } - | None -> {dependencies = []; type_ = unknown}) - | Ttyp_any | Ttyp_class _ -> {dependencies = []; type_ = unknown} - -and translateCoreTypes_ ~config ~typeVarsGen ~typeEnv typeExprs : - translation list = - typeExprs |> List.map (translateCoreType_ ~config ~typeVarsGen ~typeEnv) - -let translateCoreType ~config ~typeEnv coreType = - let typeVarsGen = GenIdent.createTypeVarsGen () in - let translation = - coreType |> translateCoreType_ ~config ~typeVarsGen ~typeEnv - in - if !Debug.dependencies then - translation.dependencies - |> List.iter (fun dep -> Log_.item "Dependency: %s\n" (dep |> depToString)); - translation diff --git a/jscomp/gentype/TranslateSignature.ml b/jscomp/gentype/TranslateSignature.ml deleted file mode 100644 index a38890a..0000000 --- a/jscomp/gentype/TranslateSignature.ml +++ /dev/null @@ -1,171 +0,0 @@ -open GenTypeCommon - -let translateSignatureValue ~config ~outputFileRelative ~resolver ~typeEnv - (valueDescription : Typedtree.value_description) : Translation.t = - let {Typedtree.val_attributes; val_desc; val_id; val_loc} = - valueDescription - in - if !Debug.translation then - Log_.item "Translate Signature Value %s\n" (val_id |> Ident.name); - let typeExpr = val_desc.ctyp_type in - let addAnnotationsToFunction type_ = type_ in - match - (val_id, val_attributes |> Annotation.fromAttributes ~config ~loc:val_loc) - with - | id, GenType -> - id |> Ident.name - |> Translation.translateValue ~attributes:val_attributes ~config - ~docString:(Annotation.docStringFromAttrs val_attributes) - ~outputFileRelative ~resolver ~typeEnv ~typeExpr - ~addAnnotationsToFunction - | _ -> Translation.empty - -let rec translateModuleDeclaration ~config ~outputFileRelative ~resolver - ~typeEnv ({md_id; md_type} : Typedtree.module_declaration) = - let name = md_id |> Ident.name in - if !Debug.translation then Log_.item "Translate Module Declaration %s\n" name; - let typeEnv = typeEnv |> TypeEnv.newModule ~name in - match md_type.mty_desc with - | Tmty_signature signature -> - signature - |> translateSignature ~config ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Tmty_ident (path, _) -> ( - match typeEnv |> TypeEnv.lookupModuleTypeSignature ~path with - | None -> Translation.empty - | Some (signature, _) -> - signature - |> translateSignature ~config ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine) - | Tmty_functor _ -> - logNotImplemented ("Tmty_functor " ^ __LOC__); - Translation.empty - | Tmty_with _ -> - logNotImplemented ("Tmty_with " ^ __LOC__); - Translation.empty - | Tmty_typeof _ -> - logNotImplemented ("Tmty_typeof " ^ __LOC__); - Translation.empty - | Tmty_alias _ -> - logNotImplemented ("Tmty_alias " ^ __LOC__); - Translation.empty - -and translateModuleTypeDeclaration ~config ~outputFileRelative ~resolver - ~typeEnv (moduleTypeDeclaration : Typedtree.module_type_declaration) = - if !Debug.translation then - Log_.item "Translate Module Type Declaration %s\n" - (moduleTypeDeclaration.mtd_id |> Ident.name); - match moduleTypeDeclaration with - | {mtd_type = None} -> Translation.empty - | {mtd_id; mtd_type = Some mtd_type} -> ( - match mtd_type.mty_desc with - | Tmty_signature signature -> - let name = mtd_id |> Ident.name in - (* Only translate types *) - let signature_without_values = - { - signature with - sig_items = - Ext_list.filter signature.sig_items (function - | {sig_desc = Tsig_value _} -> false - | _ -> true); - } - in - let translation = - signature_without_values - |> translateSignature ~config ~outputFileRelative ~resolver - ~typeEnv:(typeEnv |> TypeEnv.newModuleType ~name ~signature) - |> Translation.combine - in - translation - | Tmty_ident _ -> - logNotImplemented ("Tmty_ident " ^ __LOC__); - Translation.empty - | Tmty_functor _ -> - logNotImplemented ("Tmty_functor " ^ __LOC__); - Translation.empty - | Tmty_with _ -> - logNotImplemented ("Tmty_with " ^ __LOC__); - Translation.empty - | Tmty_typeof _ -> - logNotImplemented ("Tmty_typeof " ^ __LOC__); - Translation.empty - | Tmty_alias _ -> - logNotImplemented ("Tmty_alias " ^ __LOC__); - Translation.empty) - -and translateSignatureItem ~config ~outputFileRelative ~resolver ~typeEnv - signatureItem : Translation.t = - match signatureItem with - | {Typedtree.sig_desc = Typedtree.Tsig_type (recFlag, typeDeclarations)} -> - { - importTypes = []; - codeItems = []; - typeDeclarations = - typeDeclarations - |> TranslateTypeDeclarations.translateTypeDeclarations ~config - ~outputFileRelative ~recursive:(recFlag = Recursive) ~resolver - ~typeEnv; - } - | {Typedtree.sig_desc = Tsig_value valueDescription} -> - let isImport = - valueDescription.val_attributes - |> Annotation.hasAttribute Annotation.tagIsGenTypeImport - in - if valueDescription.val_prim <> [] || isImport then - valueDescription - |> Translation.translatePrimitive ~config ~outputFileRelative ~resolver - ~typeEnv - else - let moduleItem = - Runtime.newModuleItem ~name:(valueDescription.val_id |> Ident.name) - in - typeEnv |> TypeEnv.updateModuleItem ~moduleItem; - valueDescription - |> translateSignatureValue ~config ~outputFileRelative ~resolver ~typeEnv - | {Typedtree.sig_desc = Typedtree.Tsig_module moduleDeclaration} -> - moduleDeclaration - |> translateModuleDeclaration ~config ~outputFileRelative ~resolver ~typeEnv - | {Typedtree.sig_desc = Typedtree.Tsig_modtype moduleTypeDeclaration} -> - let moduleItem = - Runtime.newModuleItem ~name:(moduleTypeDeclaration.mtd_id |> Ident.name) - in - let config = - moduleTypeDeclaration.mtd_attributes - |> Annotation.updateConfigForModule ~config - in - typeEnv |> TypeEnv.updateModuleItem ~moduleItem; - moduleTypeDeclaration - |> translateModuleTypeDeclaration ~config ~outputFileRelative ~resolver - ~typeEnv - | {Typedtree.sig_desc = Typedtree.Tsig_typext _} -> - logNotImplemented ("Tsig_typext " ^ __LOC__); - Translation.empty - | {Typedtree.sig_desc = Typedtree.Tsig_exception _} -> - logNotImplemented ("Tsig_exception " ^ __LOC__); - Translation.empty - | {Typedtree.sig_desc = Typedtree.Tsig_recmodule _} -> - logNotImplemented ("Tsig_recmodule " ^ __LOC__); - Translation.empty - | {Typedtree.sig_desc = Typedtree.Tsig_open _} -> - logNotImplemented ("Tsig_open " ^ __LOC__); - Translation.empty - | {Typedtree.sig_desc = Typedtree.Tsig_include _} -> - logNotImplemented ("Tsig_include " ^ __LOC__); - Translation.empty - | {Typedtree.sig_desc = Typedtree.Tsig_class _} -> - logNotImplemented ("Tsig_class " ^ __LOC__); - Translation.empty - | {Typedtree.sig_desc = Typedtree.Tsig_class_type _} -> - logNotImplemented ("Tsig_class_type " ^ __LOC__); - Translation.empty - | {Typedtree.sig_desc = Typedtree.Tsig_attribute _} -> - logNotImplemented ("Tsig_attribute " ^ __LOC__); - Translation.empty - -and translateSignature ~config ~outputFileRelative ~resolver ~typeEnv signature - : Translation.t list = - if !Debug.translation then Log_.item "Translate Signature\n"; - signature.Typedtree.sig_items - |> List.map - (translateSignatureItem ~config ~outputFileRelative ~resolver ~typeEnv) diff --git a/jscomp/gentype/TranslateSignatureFromTypes.ml b/jscomp/gentype/TranslateSignatureFromTypes.ml deleted file mode 100644 index 27c9d63..0000000 --- a/jscomp/gentype/TranslateSignatureFromTypes.ml +++ /dev/null @@ -1,109 +0,0 @@ -open GenTypeCommon - -(** Like translateTypeDeclaration but from Types not Typedtree *) -let translateTypeDeclarationFromTypes ~config ~outputFileRelative ~resolver - ~typeEnv ~id - ({type_attributes; type_kind; type_loc; type_manifest; type_params} : - Types.type_declaration) : CodeItem.typeDeclaration list = - typeEnv |> TypeEnv.newType ~name:(id |> Ident.name); - let typeName = Ident.name id in - let typeVars = type_params |> TypeVars.extractFromTypeExpr in - if !Debug.translation then - Log_.item "Translate Types.type_declaration %s\n" typeName; - let declarationKind = - match type_kind with - | Type_record (labelDeclarations, recordRepresentation) -> - TranslateTypeDeclarations.RecordDeclarationFromTypes - (labelDeclarations, recordRepresentation) - | Type_variant constructorDeclarations - when not - (TranslateTypeDeclarations.hasSomeGADTLeaf constructorDeclarations) - -> - VariantDeclarationFromTypes constructorDeclarations - | Type_abstract -> GeneralDeclarationFromTypes type_manifest - | _ -> NoDeclaration - in - declarationKind - |> TranslateTypeDeclarations.traslateDeclarationKind ~config ~loc:type_loc - ~outputFileRelative ~resolver ~typeAttributes:type_attributes ~typeEnv - ~typeName ~typeVars - -(** Like translateModuleDeclaration but from Types not Typedtree *) -let rec translateModuleDeclarationFromTypes ~config ~outputFileRelative - ~resolver ~typeEnv ~id (moduleDeclaration : Types.module_declaration) : - Translation.t = - match moduleDeclaration.md_type with - | Mty_signature signature -> - let name = id |> Ident.name in - signature - |> translateSignatureFromTypes ~config ~outputFileRelative ~resolver - ~typeEnv:(typeEnv |> TypeEnv.newModule ~name) - |> Translation.combine - | Mty_ident _ -> - logNotImplemented ("Mty_ident " ^ __LOC__); - Translation.empty - | Mty_functor _ -> - logNotImplemented ("Mty_functor " ^ __LOC__); - Translation.empty - | Mty_alias _ -> - logNotImplemented ("Mty_alias " ^ __LOC__); - Translation.empty - -(** Like translateSignatureItem but from Types not Typedtree *) -and translateSignatureItemFromTypes ~config ~outputFileRelative ~resolver - ~typeEnv (signatureItem : Types.signature_item) : Translation.t = - match signatureItem with - | Types.Sig_type (id, typeDeclaration, _) -> - { - importTypes = []; - codeItems = []; - typeDeclarations = - typeDeclaration - |> translateTypeDeclarationFromTypes ~config ~outputFileRelative - ~resolver ~typeEnv ~id; - } - | Types.Sig_module (id, moduleDeclaration, _) -> - let moduleItem = Runtime.newModuleItem ~name:(id |> Ident.name) in - let config = - moduleDeclaration.md_attributes - |> Annotation.updateConfigForModule ~config - in - typeEnv |> TypeEnv.updateModuleItem ~moduleItem; - moduleDeclaration - |> translateModuleDeclarationFromTypes ~config ~outputFileRelative ~resolver - ~typeEnv ~id - | Types.Sig_value (id, {val_attributes; val_loc; val_type}) -> - let name = id |> Ident.name in - if !Debug.translation then Log_.item "Translate Sig Value %s\n" name; - let moduleItem = Runtime.newModuleItem ~name in - typeEnv |> TypeEnv.updateModuleItem ~moduleItem; - if - val_attributes |> Annotation.fromAttributes ~config ~loc:val_loc = GenType - then - name - |> Translation.translateValue ~attributes:val_attributes ~config - ~docString:(Annotation.docStringFromAttrs val_attributes) - ~outputFileRelative ~resolver ~typeEnv ~typeExpr:val_type - ~addAnnotationsToFunction:(fun t -> t) - else Translation.empty - | Types.Sig_typext _ -> - logNotImplemented ("Sig_typext " ^ __LOC__); - Translation.empty - | Types.Sig_modtype _ -> - logNotImplemented ("Sig_modtype " ^ __LOC__); - Translation.empty - | Types.Sig_class _ -> - logNotImplemented ("Sig_class " ^ __LOC__); - Translation.empty - | Types.Sig_class_type _ -> - logNotImplemented ("Sig_class_type " ^ __LOC__); - Translation.empty - -(** Like translateSignature but from Types not Typedtree *) -and translateSignatureFromTypes ~config ~outputFileRelative ~resolver ~typeEnv - (signature : Types.signature_item list) : Translation.t list = - if !Debug.translation then Log_.item "Translate Types.signature\n"; - signature - |> List.map - (translateSignatureItemFromTypes ~config ~outputFileRelative ~resolver - ~typeEnv) diff --git a/jscomp/gentype/TranslateStructure.ml b/jscomp/gentype/TranslateStructure.ml deleted file mode 100644 index 1fd23b0..0000000 --- a/jscomp/gentype/TranslateStructure.ml +++ /dev/null @@ -1,355 +0,0 @@ -open GenTypeCommon - -let rec addAnnotationsToTypes_ ~config ~(expr : Typedtree.expression) - (argTypes : argType list) = - match (expr.exp_desc, expr.exp_type.desc, argTypes) with - | Texp_function {arg_label; param; cases = [{c_rhs}]}, _, {aType} :: nextTypes - -> - let nextTypes1 = nextTypes |> addAnnotationsToTypes_ ~config ~expr:c_rhs in - let aName = Ident.name param in - let _ = Printtyped.implementation in - let aName = - if aName = "*opt*" then - match arg_label with - | Optional l -> l - | _ -> "" (* should not happen *) - else aName - in - {aName; aType} :: nextTypes1 - | Texp_construct ({txt = Lident "Function$"}, _, [funExpr]), _, _ -> - (* let uncurried1: function$<_, _> = Function$(x => x |> string_of_int, [`Has_arity1]) *) - addAnnotationsToTypes_ ~config ~expr:funExpr argTypes - | Texp_apply ({exp_desc = Texp_ident (path, _, _)}, [(_, Some expr1)]), _, _ - -> ( - match path |> TranslateTypeExprFromTypes.pathToList |> List.rev with - | ["Js"; "Internal"; fn_mk] - when (* Uncurried function definition uses Js.Internal.fn_mkX(...) *) - String.length fn_mk >= 5 - && (String.sub fn_mk 0 5 [@doesNotRaise]) = "fn_mk" -> - argTypes |> addAnnotationsToTypes_ ~config ~expr:expr1 - | _ -> argTypes) - | _ -> argTypes - -and addAnnotationsToTypes ~config ~(expr : Typedtree.expression) - (argTypes : argType list) = - let argTypes = addAnnotationsToTypes_ ~config ~expr argTypes in - if argTypes |> List.filter (fun {aName} -> aName = "param") |> List.length > 1 - then - (* Underscore "_" appears as "param", can occur more than once *) - argTypes - |> List.mapi (fun i {aName; aType} -> - {aName = aName ^ "_" ^ string_of_int i; aType}) - else argTypes - -and addAnnotationsToFields ~config (expr : Typedtree.expression) - (fields : fields) (argTypes : argType list) = - match (expr.exp_desc, fields, argTypes) with - | _, [], _ -> ([], argTypes |> addAnnotationsToTypes ~config ~expr) - | Texp_function {cases = [{c_rhs}]}, field :: nextFields, _ -> - let nextFields1, types1 = - addAnnotationsToFields ~config c_rhs nextFields argTypes - in - let name = - TranslateTypeDeclarations.renameRecordField - ~attributes:expr.exp_attributes ~name:field.nameJS - in - ({field with nameJS = name} :: nextFields1, types1) - | _ -> (fields, argTypes) -[@@live] - -(** Recover from expr the renaming annotations on named arguments. *) -let addAnnotationsToFunctionType ~config (expr : Typedtree.expression) - (type_ : type_) = - match type_ with - | Function function_ -> - let argTypes = function_.argTypes |> addAnnotationsToTypes ~config ~expr in - Function {function_ with argTypes} - | _ -> type_ - -let removeValueBindingDuplicates structureItems = - let rec processBindings (bindings : Typedtree.value_binding list) ~seen = - match bindings with - | ({vb_pat = {pat_desc = Tpat_var (id, _)}} as binding) :: otherBindings -> - let name = Ident.name id in - if !seen |> StringSet.mem name then otherBindings |> processBindings ~seen - else ( - seen := !seen |> StringSet.add name; - binding :: (otherBindings |> processBindings ~seen)) - | binding :: otherBindings -> - binding :: (otherBindings |> processBindings ~seen) - | [] -> [] - in - let rec processItems (items : Typedtree.structure_item list) ~acc ~seen = - match items with - | ({Typedtree.str_desc = Tstr_value (loc, valueBindings)} as item) - :: otherItems -> - let bindings = valueBindings |> processBindings ~seen in - let item = {item with str_desc = Tstr_value (loc, bindings)} in - otherItems |> processItems ~acc:(item :: acc) ~seen - | item :: otherItems -> otherItems |> processItems ~acc:(item :: acc) ~seen - | [] -> acc - in - structureItems |> List.rev |> processItems ~acc:[] ~seen:(ref StringSet.empty) - -let translateValueBinding ~config ~outputFileRelative ~resolver ~typeEnv - {Typedtree.vb_attributes; vb_expr; vb_pat} : Translation.t = - match vb_pat.pat_desc with - | Tpat_var (id, _) | Tpat_alias ({pat_desc = Tpat_any}, id, _) -> - let name = id |> Ident.name in - if !Debug.translation then Log_.item "Translate Value Binding %s\n" name; - let moduleItem = Runtime.newModuleItem ~name in - typeEnv |> TypeEnv.updateModuleItem ~moduleItem; - if - vb_attributes - |> Annotation.fromAttributes ~config ~loc:vb_pat.pat_loc - = GenType - then - id |> Ident.name - |> Translation.translateValue ~attributes:vb_attributes ~config - ~docString:(Annotation.docStringFromAttrs vb_attributes) - ~outputFileRelative ~resolver ~typeEnv ~typeExpr:vb_pat.pat_type - ~addAnnotationsToFunction: - (addAnnotationsToFunctionType ~config vb_expr) - else Translation.empty - | _ -> Translation.empty - -let rec removeDuplicateValueBindings - (structureItems : Typedtree.structure_item list) = - match structureItems with - | ({Typedtree.str_desc = Tstr_value (loc, valueBindings)} as structureItem) - :: rest -> - let boundInRest, filteredRest = rest |> removeDuplicateValueBindings in - let valueBindingsFiltered = - valueBindings - |> List.filter (fun valueBinding -> - match valueBinding with - | {Typedtree.vb_pat = {pat_desc = Tpat_var (id, _)}} -> - not (boundInRest |> StringSet.mem (id |> Ident.name)) - | _ -> true) - in - let bound = - valueBindings - |> List.fold_left - (fun bound (valueBinding : Typedtree.value_binding) -> - match valueBinding with - | {vb_pat = {pat_desc = Tpat_var (id, _)}} -> - bound |> StringSet.add (id |> Ident.name) - | _ -> bound) - boundInRest - in - ( bound, - {structureItem with str_desc = Tstr_value (loc, valueBindingsFiltered)} - :: filteredRest ) - | structureItem :: rest -> - let boundInRest, filteredRest = rest |> removeDuplicateValueBindings in - (boundInRest, structureItem :: filteredRest) - | [] -> (StringSet.empty, []) - -let rec translateModuleBinding ~(config : GenTypeConfig.t) ~outputFileRelative - ~resolver ~typeEnv - ({mb_id; mb_expr; mb_attributes} : Typedtree.module_binding) : Translation.t - = - let name = mb_id |> Ident.name in - if !Debug.translation then Log_.item "Translate Module Binding %s\n" name; - let moduleItem = Runtime.newModuleItem ~name in - let config = mb_attributes |> Annotation.updateConfigForModule ~config in - typeEnv |> TypeEnv.updateModuleItem ~moduleItem; - let typeEnv = typeEnv |> TypeEnv.newModule ~name in - match mb_expr.mod_desc with - | Tmod_ident (path, _) -> ( - let dep = path |> Dependencies.fromPath ~config ~typeEnv in - let internal = dep |> Dependencies.isInternal in - typeEnv |> TypeEnv.addModuleEquation ~dep ~internal; - match Env.scrape_alias mb_expr.mod_env mb_expr.mod_type with - | Mty_signature signature -> - (* Treat module M = N as include N *) - signature - |> TranslateSignatureFromTypes.translateSignatureFromTypes ~config - ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Mty_alias _ | Mty_ident _ | Mty_functor _ -> Translation.empty) - | Tmod_structure structure -> - let isLetPrivate = - mb_attributes |> Annotation.hasAttribute Annotation.tagIsInternLocal - in - if isLetPrivate then Translation.empty - else - structure - |> translateStructure ~config ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Tmod_apply _ -> ( - (* Only look at the resulting type of the module *) - match mb_expr.mod_type with - | Mty_signature signature -> - signature - |> TranslateSignatureFromTypes.translateSignatureFromTypes ~config - ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Mty_ident _ -> - logNotImplemented ("Mty_ident " ^ __LOC__); - Translation.empty - | Mty_functor _ -> - logNotImplemented ("Mty_functor " ^ __LOC__); - Translation.empty - | Mty_alias _ -> - logNotImplemented ("Mty_alias " ^ __LOC__); - Translation.empty) - | Tmod_unpack (_, moduleType) -> ( - match moduleType with - | Mty_signature signature -> - signature - |> TranslateSignatureFromTypes.translateSignatureFromTypes ~config - ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Mty_ident path -> ( - match typeEnv |> TypeEnv.lookupModuleTypeSignature ~path with - | None -> Translation.empty - | Some (signature, _) -> - signature - |> TranslateSignature.translateSignature ~config ~outputFileRelative - ~resolver ~typeEnv - |> Translation.combine) - | Mty_functor _ -> - logNotImplemented ("Mty_functor " ^ __LOC__); - Translation.empty - | Mty_alias _ -> - logNotImplemented ("Mty_alias " ^ __LOC__); - Translation.empty) - | Tmod_functor _ -> - logNotImplemented ("Tmod_functor " ^ __LOC__); - Translation.empty - | Tmod_constraint (_, Mty_ident path, Tmodtype_explicit _, Tcoerce_none) -> ( - match typeEnv |> TypeEnv.lookupModuleTypeSignature ~path with - | None -> Translation.empty - | Some (signature, _) -> - signature - |> TranslateSignature.translateSignature ~config ~outputFileRelative - ~resolver ~typeEnv - |> Translation.combine) - | Tmod_constraint - (_, Mty_signature signature, Tmodtype_explicit _, Tcoerce_none) -> - signature - |> TranslateSignatureFromTypes.translateSignatureFromTypes ~config - ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Tmod_constraint - ( {mod_desc = Tmod_structure structure}, - _, - Tmodtype_implicit, - Tcoerce_structure _ ) -> - { - structure with - str_items = structure.str_items |> removeDuplicateValueBindings |> snd; - } - |> translateStructure ~config ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Tmod_constraint - ( _, - _, - Tmodtype_explicit {mty_desc = Tmty_signature {sig_type = signature}}, - _ ) -> - signature - |> TranslateSignatureFromTypes.translateSignatureFromTypes ~config - ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | Tmod_constraint _ -> - logNotImplemented ("Tmod_constraint " ^ __LOC__); - Translation.empty - -and translateStructureItem ~config ~outputFileRelative ~resolver ~typeEnv - (structItem : Typedtree.structure_item) : Translation.t = - match structItem with - | {str_desc = Tstr_type (recFlag, typeDeclarations)} -> - { - importTypes = []; - codeItems = []; - typeDeclarations = - typeDeclarations - |> TranslateTypeDeclarations.translateTypeDeclarations ~config - ~outputFileRelative ~recursive:(recFlag = Recursive) ~resolver - ~typeEnv; - } - | {str_desc = Tstr_value (_loc, valueBindings)} -> - valueBindings - |> List.map - (translateValueBinding ~config ~outputFileRelative ~resolver ~typeEnv) - |> Translation.combine - | {str_desc = Tstr_primitive valueDescription} -> - (* external declaration *) - valueDescription - |> Translation.translatePrimitive ~config ~outputFileRelative ~resolver - ~typeEnv - | {str_desc = Tstr_module moduleBinding} -> - moduleBinding - |> translateModuleBinding ~config ~outputFileRelative ~resolver ~typeEnv - | {str_desc = Tstr_modtype moduleTypeDeclaration} -> - moduleTypeDeclaration - |> TranslateSignature.translateModuleTypeDeclaration ~config - ~outputFileRelative ~resolver ~typeEnv - | {str_desc = Tstr_recmodule moduleBindings} -> - moduleBindings - |> List.map - (translateModuleBinding ~config ~outputFileRelative ~resolver ~typeEnv) - |> Translation.combine - | { - str_desc = - (* ReScript's encoding of bs.module: include with constraint. *) - Tstr_include - { - incl_mod = - { - mod_desc = - Tmod_constraint - ( { - mod_desc = - Tmod_structure - { - str_items = - [({str_desc = Tstr_primitive _} as structItem1)]; - }; - }, - _, - _, - _ ); - }; - _; - }; - _; - } -> - structItem1 - |> translateStructureItem ~config ~outputFileRelative ~resolver ~typeEnv - | {str_desc = Tstr_include {incl_type = signature}} -> - signature - |> TranslateSignatureFromTypes.translateSignatureFromTypes ~config - ~outputFileRelative ~resolver ~typeEnv - |> Translation.combine - | {str_desc = Tstr_eval _} -> - logNotImplemented ("Tstr_eval " ^ __LOC__); - Translation.empty - | {str_desc = Tstr_typext _} -> - logNotImplemented ("Tstr_typext " ^ __LOC__); - Translation.empty - | {str_desc = Tstr_exception _} -> - logNotImplemented ("Tstr_exception " ^ __LOC__); - Translation.empty - | {str_desc = Tstr_open _} -> - logNotImplemented ("Tstr_open " ^ __LOC__); - Translation.empty - | {str_desc = Tstr_class _} -> - logNotImplemented ("Tstr_class " ^ __LOC__); - Translation.empty - | {str_desc = Tstr_class_type _} -> - logNotImplemented ("Tstr_class_type " ^ __LOC__); - Translation.empty - | {str_desc = Tstr_attribute _} -> - logNotImplemented ("Tstr_attribute " ^ __LOC__); - Translation.empty - -and translateStructure ~config ~outputFileRelative ~resolver ~typeEnv structure - : Translation.t list = - if !Debug.translation then Log_.item "Translate Structure\n"; - structure.Typedtree.str_items |> removeValueBindingDuplicates - |> List.map (fun structItem -> - structItem - |> translateStructureItem ~config ~outputFileRelative ~resolver - ~typeEnv) diff --git a/jscomp/gentype/TranslateTypeDeclarations.ml b/jscomp/gentype/TranslateTypeDeclarations.ml deleted file mode 100644 index 07905ea..0000000 --- a/jscomp/gentype/TranslateTypeDeclarations.ml +++ /dev/null @@ -1,361 +0,0 @@ -open GenTypeCommon - -type declarationKind = - | RecordDeclarationFromTypes of - Types.label_declaration list * Types.record_representation - | GeneralDeclaration of Typedtree.core_type option - | GeneralDeclarationFromTypes of Types.type_expr option - (** As the above, but from Types not Typedtree *) - | VariantDeclarationFromTypes of Types.constructor_declaration list - | NoDeclaration - -let createExportTypeFromTypeDeclaration ~annotation ~loc ~nameAs ~opaque ~type_ - ~typeEnv ~docString typeName ~typeVars : CodeItem.exportFromTypeDeclaration - = - let resolvedTypeName = - typeName |> sanitizeTypeName |> TypeEnv.addModulePath ~typeEnv - in - { - exportType = - {loc; nameAs; opaque; type_; typeVars; resolvedTypeName; docString}; - annotation; - } - -let createCase (label, attributes) ~poly = - { - labelJS = - (match - attributes |> Annotation.getAttributePayload Annotation.tagIsAs - with - | Some (_, IdentPayload (Lident "null")) -> NullLabel - | Some (_, IdentPayload (Lident "undefined")) -> UndefinedLabel - | Some (_, BoolPayload b) -> BoolLabel b - | Some (_, FloatPayload s) -> FloatLabel s - | Some (_, IntPayload i) -> IntLabel i - | Some (_, StringPayload asLabel) -> StringLabel asLabel - | _ -> - if poly && isNumber label then IntLabel label else StringLabel label); - } - -(** - * Rename record fields. - * If @genType.as is used, perform renaming conversion. - * If @bs.as is used (with records-as-objects active), escape and quote if - * the identifier contains characters which are invalid as JS property names. -*) -let renameRecordField ~attributes ~name = - attributes |> Annotation.checkUnsupportedGenTypeAsRenaming; - match attributes |> Annotation.getAsString with - | Some s -> s |> String.escaped - | None -> name - -let traslateDeclarationKind ~config ~loc ~outputFileRelative ~resolver - ~typeAttributes ~typeEnv ~typeName ~typeVars declarationKind : - CodeItem.typeDeclaration list = - let docString = typeAttributes |> Annotation.docStringFromAttrs in - let annotation = typeAttributes |> Annotation.fromAttributes ~config ~loc in - let opaque = - match annotation = Annotation.GenTypeOpaque with - | true -> Some true - | false -> None - (* one means don't know *) - in - let importStringOpt, nameAs = - typeAttributes |> Annotation.getAttributeImportRenaming - in - let unboxedAnnotation = - typeAttributes |> Annotation.hasAttribute Annotation.tagIsUnboxed - in - let tagAnnotation = typeAttributes |> Annotation.getTag in - let returnTypeDeclaration (typeDeclaration : CodeItem.typeDeclaration) = - match opaque = Some true with - | true -> [{typeDeclaration with importTypes = []}] - | false -> [typeDeclaration] - in - let handleGeneralDeclaration - (translation : TranslateTypeExprFromTypes.translation) = - let exportFromTypeDeclaration = - typeName - |> createExportTypeFromTypeDeclaration ~annotation ~loc ~nameAs ~opaque - ~type_:translation.type_ ~typeEnv ~docString ~typeVars - in - let importTypes = - translation.dependencies - |> Translation.translateDependencies ~config ~outputFileRelative ~resolver - in - {CodeItem.importTypes; exportFromTypeDeclaration} - in - let translateLabelDeclarations ?(inline = false) ~recordRepresentation - labelDeclarations = - let isOptional l = - match recordRepresentation with - | Types.Record_optional_labels lbls -> List.mem l lbls - | _ -> false - in - let fieldTranslations = - labelDeclarations - |> List.map (fun {Types.ld_id; ld_mutable; ld_type; ld_attributes} -> - let name = - renameRecordField ~attributes:ld_attributes - ~name:(ld_id |> Ident.name) - in - let mutability = - match ld_mutable = Mutable with - | true -> Mutable - | false -> Immutable - in - ( name, - mutability, - ld_type - |> TranslateTypeExprFromTypes.translateTypeExprFromTypes ~config - ~typeEnv, - Annotation.docStringFromAttrs ld_attributes )) - in - let dependencies = - fieldTranslations - |> List.map (fun (_, _, {TranslateTypeExprFromTypes.dependencies}, _) -> - dependencies) - |> List.concat - in - let fields = - fieldTranslations - |> List.map - (fun - (name, mutable_, {TranslateTypeExprFromTypes.type_}, docString) -> - let optional, type1 = - match type_ with - | Option type1 when isOptional name -> (Optional, type1) - | _ -> (Mandatory, type_) - in - {mutable_; nameJS = name; optional; type_ = type1; docString}) - in - let type_ = - match fields with - | [field] when unboxedAnnotation -> field.type_ - | _ -> Object ((if inline then Inline else Closed), fields) - in - {TranslateTypeExprFromTypes.dependencies; type_} - in - match (declarationKind, importStringOpt) with - | _, Some importString -> - (* import type *) - let typeName_ = typeName in - let nameWithModulePath = - typeName_ |> TypeEnv.addModulePath ~typeEnv |> ResolvedName.toString - in - let typeName, asTypeName = - match nameAs with - | Some asString -> (asString, "$$" ^ nameWithModulePath) - | None -> (nameWithModulePath, "$$" ^ nameWithModulePath) - in - let importTypes = - [ - { - CodeItem.typeName; - asTypeName = Some asTypeName; - importPath = importString |> ImportPath.fromStringUnsafe; - }; - ] - in - let exportFromTypeDeclaration = - (* Make the imported type usable from other modules by exporting it too. *) - typeName_ - |> createExportTypeFromTypeDeclaration ~docString ~annotation:GenType ~loc - ~nameAs:None ~opaque:(Some false) - ~type_: - (asTypeName - |> ident ~typeArgs:(typeVars |> List.map (fun s -> TypeVar s))) - ~typeEnv ~typeVars - in - [{CodeItem.importTypes; exportFromTypeDeclaration}] - | (GeneralDeclarationFromTypes None | GeneralDeclaration None), None -> - { - CodeItem.importTypes = []; - exportFromTypeDeclaration = - typeName - |> createExportTypeFromTypeDeclaration ~docString ~annotation ~loc - ~nameAs ~opaque:(Some true) ~type_:unknown ~typeEnv ~typeVars; - } - |> returnTypeDeclaration - | GeneralDeclarationFromTypes (Some typeExpr), None -> - let translation = - typeExpr - |> TranslateTypeExprFromTypes.translateTypeExprFromTypes ~config ~typeEnv - in - translation |> handleGeneralDeclaration |> returnTypeDeclaration - | GeneralDeclaration (Some coreType), None -> - let translation = - coreType |> TranslateCoreType.translateCoreType ~config ~typeEnv - in - let type_ = - match (coreType, translation.type_) with - | {ctyp_desc = Ttyp_variant (rowFields, _, _)}, Variant variant -> - let rowFieldsVariants = rowFields |> TranslateCoreType.processVariant in - let noPayloads = - rowFieldsVariants.noPayloads |> List.map (createCase ~poly:true) - in - let payloads = - if - variant.payloads |> List.length - = (rowFieldsVariants.payloads |> List.length) - then - (List.combine variant.payloads rowFieldsVariants.payloads - [@doesNotRaise]) - |> List.map (fun (payload, (label, attributes, _)) -> - let case = (label, attributes) |> createCase ~poly:true in - {payload with case}) - else variant.payloads - in - createVariant ~inherits:variant.inherits ~noPayloads ~payloads - ~polymorphic:true ~tag:None ~unboxed:false - | _ -> translation.type_ - in - {translation with type_} |> handleGeneralDeclaration - |> returnTypeDeclaration - | RecordDeclarationFromTypes (labelDeclarations, recordRepresentation), None - -> - let {TranslateTypeExprFromTypes.dependencies; type_} = - labelDeclarations |> translateLabelDeclarations ~recordRepresentation - in - let importTypes = - dependencies - |> Translation.translateDependencies ~config ~outputFileRelative ~resolver - in - { - CodeItem.importTypes; - exportFromTypeDeclaration = - typeName - |> createExportTypeFromTypeDeclaration ~docString ~annotation ~loc - ~nameAs ~opaque ~type_ ~typeEnv ~typeVars; - } - |> returnTypeDeclaration - | VariantDeclarationFromTypes constructorDeclarations, None -> - let variants = - constructorDeclarations - |> List.map (fun constructorDeclaration -> - let constructorArgs = constructorDeclaration.Types.cd_args in - let attributes = constructorDeclaration.cd_attributes in - let name = constructorDeclaration.cd_id |> Ident.name in - let argsTranslation = - match constructorArgs with - | Cstr_tuple typeExprs -> - typeExprs - |> TranslateTypeExprFromTypes.translateTypeExprsFromTypes - ~config ~typeEnv - | Cstr_record labelDeclarations -> - [ - labelDeclarations - |> translateLabelDeclarations ~inline:true - ~recordRepresentation:Types.Record_regular; - ] - in - let argTypes = - argsTranslation - |> List.map (fun {TranslateTypeExprFromTypes.type_} -> type_) - in - let importTypes = - argsTranslation - |> List.map (fun {TranslateTypeExprFromTypes.dependencies} -> - dependencies) - |> List.concat - |> Translation.translateDependencies ~config ~outputFileRelative - ~resolver - in - (name, attributes, argTypes, importTypes)) - in - let variantsNoPayload, variantsWithPayload = - variants |> List.partition (fun (_, _, argTypes, _) -> argTypes = []) - in - let noPayloads = - variantsNoPayload - |> List.map (fun (name, attributes, _argTypes, _importTypes) -> - (name, attributes) |> createCase ~poly:false) - in - let payloads = - variantsWithPayload - |> List.map (fun (name, attributes, argTypes, _importTypes) -> - let type_ = - match argTypes with - | [type_] -> type_ - | _ -> Tuple argTypes - in - {case = (name, attributes) |> createCase ~poly:false; t = type_}) - in - let variantTyp = - createVariant ~inherits:[] ~noPayloads ~payloads ~polymorphic:false - ~tag:tagAnnotation ~unboxed:unboxedAnnotation - in - let resolvedTypeName = typeName |> TypeEnv.addModulePath ~typeEnv in - let exportFromTypeDeclaration = - { - CodeItem.exportType = - { - loc; - nameAs; - opaque; - type_ = variantTyp; - typeVars; - resolvedTypeName; - docString; - }; - annotation; - } - in - let importTypes = - variants - |> List.map (fun (_, _, _, importTypes) -> importTypes) - |> List.concat - in - {CodeItem.exportFromTypeDeclaration; importTypes} |> returnTypeDeclaration - | NoDeclaration, None -> [] - -let hasSomeGADTLeaf constructorDeclarations = - List.exists - (fun declaration -> declaration.Types.cd_res != None) - constructorDeclarations - -let translateTypeDeclaration ~config ~outputFileRelative ~resolver ~typeEnv - ({typ_attributes; typ_id; typ_loc; typ_manifest; typ_params; typ_type} : - Typedtree.type_declaration) : CodeItem.typeDeclaration list = - if !Debug.translation then - Log_.item "Translate Type Declaration %s\n" (typ_id |> Ident.name); - - let typeName = Ident.name typ_id in - let typeVars = - typ_params - |> List.map (fun (coreType, _) -> coreType) - |> TypeVars.extractFromCoreType - in - let declarationKind = - match typ_type.type_kind with - | Type_record (labelDeclarations, recordRepresentation) -> - RecordDeclarationFromTypes (labelDeclarations, recordRepresentation) - | Type_variant constructorDeclarations -> - VariantDeclarationFromTypes constructorDeclarations - | Type_abstract -> GeneralDeclaration typ_manifest - | _ -> NoDeclaration - in - declarationKind - |> traslateDeclarationKind ~config ~loc:typ_loc ~outputFileRelative ~resolver - ~typeAttributes:typ_attributes ~typeEnv ~typeName ~typeVars - -let addTypeDeclarationIdToTypeEnv ~typeEnv - ({typ_id} : Typedtree.type_declaration) = - typeEnv |> TypeEnv.newType ~name:(typ_id |> Ident.name) - -let translateTypeDeclarations ~config ~outputFileRelative ~recursive ~resolver - ~typeEnv (typeDeclarations : Typedtree.type_declaration list) : - CodeItem.typeDeclaration list = - if recursive then - typeDeclarations |> List.iter (addTypeDeclarationIdToTypeEnv ~typeEnv); - typeDeclarations - |> List.map (fun typeDeclaration -> - let res = - typeDeclaration - |> translateTypeDeclaration ~config ~outputFileRelative ~resolver - ~typeEnv - in - if not recursive then - typeDeclaration |> addTypeDeclarationIdToTypeEnv ~typeEnv; - res) - |> List.concat diff --git a/jscomp/gentype/TranslateTypeExprFromTypes.ml b/jscomp/gentype/TranslateTypeExprFromTypes.ml deleted file mode 100644 index 9c61bfe..0000000 --- a/jscomp/gentype/TranslateTypeExprFromTypes.ml +++ /dev/null @@ -1,542 +0,0 @@ -open GenTypeCommon - -type translation = {dependencies: dep list; type_: type_} - -let rec removeOption ~(label : Asttypes.arg_label) (typeExpr : Types.type_expr) - = - match (typeExpr.desc, label) with - | Tconstr (Path.Pident id, [t], _), Optional lbl when Ident.name id = "option" - -> - Some (lbl, t) - | Tconstr (Pdot (Path.Pident nameSpace, id, _), [t], _), Optional lbl - when Ident.name nameSpace = "FB" && id = "option" -> - Some (lbl, t) - | Tlink t, _ -> t |> removeOption ~label - | _ -> None - -let rec pathToList path = - match path with - | Path.Pident id -> [id |> Ident.name] - | Path.Pdot (p, s, _) -> s :: (p |> pathToList) - | Path.Papply _ -> [] - -let translateObjType closedFlag fieldsTranslations = - let dependencies = - fieldsTranslations - |> List.map (fun (_, {dependencies}) -> dependencies) - |> List.concat - in - let rec checkMutableField ?(acc = []) fields = - match fields with - | (previousName, {type_ = _}) :: (name, {type_}) :: rest - when Runtime.checkMutableObjectField ~previousName ~name -> - (* The field was annotated "@bs.set" *) - rest |> checkMutableField ~acc:((name, type_, Mutable) :: acc) - | (name, {type_}) :: rest -> - rest |> checkMutableField ~acc:((name, type_, Immutable) :: acc) - | [] -> acc |> List.rev - in - let fields = - fieldsTranslations |> checkMutableField - |> List.map (fun (name, t, mutable_) -> - let optional, type_ = - match t with - | Option t -> (Optional, t) - | _ -> (Mandatory, t) - in - { - mutable_; - nameJS = name; - optional; - type_; - docString = DocString.empty; - }) - in - let type_ = Object (closedFlag, fields) in - {dependencies; type_} - -let translateConstr ~config ~paramsTranslation ~(path : Path.t) ~typeEnv = - let defaultCase () = - let typeArgs = - paramsTranslation |> List.map (fun ({type_} : translation) -> type_) - in - let typeParamDeps = - paramsTranslation - |> List.map (fun {dependencies} -> dependencies) - |> List.concat - in - match typeEnv |> TypeEnv.applyTypeEquations ~config ~path with - | Some type_ -> {dependencies = typeParamDeps; type_} - | None -> - let dep = path |> Dependencies.fromPath ~config ~typeEnv in - { - dependencies = dep :: typeParamDeps; - type_ = Ident {builtin = false; name = dep |> depToString; typeArgs}; - } - in - match (path |> pathToList |> List.rev, paramsTranslation) with - | (["FB"; "bool"] | ["bool"]), [] -> {dependencies = []; type_ = booleanT} - | (["FB"; "int"] | ["int"]), [] -> {dependencies = []; type_ = numberT} - | (["Int64"; "t"] | ["int64"]), [] -> {dependencies = []; type_ = int64T} - | (["FB"; "float"] | ["float"]), [] -> {dependencies = []; type_ = numberT} - | ( ( ["FB"; "string"] - | ["string"] - | ["String"; "t"] - | ["Js"; ("String" | "String2"); "t"] ), - [] ) -> - {dependencies = []; type_ = stringT} - | (["Js"; "Types"; "bigint_val"] | ["BigInt"; "t"]), [] -> - {dependencies = []; type_ = bigintT} - | (["Js"; "Date"; "t"] | ["Date"; "t"]), [] -> - {dependencies = []; type_ = dateT} - | ["Map"; "t"], [paramTranslation1; paramTranslation2] -> - { - dependencies = - paramTranslation1.dependencies @ paramTranslation2.dependencies; - type_ = mapT (paramTranslation1.type_, paramTranslation2.type_); - } - | ["WeakMap"; "t"], [paramTranslation1; paramTranslation2] -> - { - dependencies = - paramTranslation1.dependencies @ paramTranslation2.dependencies; - type_ = weakmapT (paramTranslation1.type_, paramTranslation2.type_); - } - | ["Set"; "t"], [paramTranslation] -> - { - dependencies = paramTranslation.dependencies; - type_ = setT paramTranslation.type_; - } - | ["WeakSet"; "t"], [paramTranslation] -> - { - dependencies = paramTranslation.dependencies; - type_ = weaksetT paramTranslation.type_; - } - | (["Js"; "Re"; "t"] | ["RegExp"; "t"]), [] -> - {dependencies = []; type_ = regexpT} - | (["FB"; "unit"] | ["unit"]), [] -> {dependencies = []; type_ = unitT} - | ( (["FB"; "array"] | ["array"] | ["Js"; ("Array" | "Array2"); "t"]), - [paramTranslation] ) -> - {paramTranslation with type_ = Array (paramTranslation.type_, Mutable)} - | ["ImmutableArray"; "t"], [paramTranslation] -> - {paramTranslation with type_ = Array (paramTranslation.type_, Immutable)} - | ["Pervasives"; "ref"], [paramTranslation] -> - { - dependencies = paramTranslation.dependencies; - type_ = - Object - ( Closed, - [ - { - mutable_ = Mutable; - nameJS = "contents"; - optional = Mandatory; - type_ = paramTranslation.type_; - docString = DocString.empty; - }; - ] ); - } - | ( (["Pervasives"; "result"] | ["Belt"; "Result"; "t"] | ["result"]), - [paramTranslation1; paramTranslation2] ) -> - let case name type_ = {case = {labelJS = StringLabel name}; t = type_} in - let variant = - createVariant ~inherits:[] ~noPayloads:[] - ~payloads: - [ - case "Ok" paramTranslation1.type_; - case "Error" paramTranslation2.type_; - ] - ~polymorphic:false ~tag:None ~unboxed:false - in - { - dependencies = - paramTranslation1.dependencies @ paramTranslation2.dependencies; - type_ = variant; - } - | ( (["React"; "callback"] | ["ReactV3"; "React"; "callback"]), - [fromTranslation; toTranslation] ) -> - { - dependencies = fromTranslation.dependencies @ toTranslation.dependencies; - type_ = - Function - { - argTypes = [{aName = ""; aType = fromTranslation.type_}]; - retType = toTranslation.type_; - typeVars = []; - }; - } - | ( (["React"; "componentLike"] | ["ReactV3"; "React"; "componentLike"]), - [propsTranslation; retTranslation] ) -> - { - dependencies = propsTranslation.dependencies @ retTranslation.dependencies; - type_ = - Function - { - argTypes = [{aName = ""; aType = propsTranslation.type_}]; - retType = retTranslation.type_; - typeVars = []; - }; - } - | ( (["React"; "component"] | ["ReactV3"; "React"; "component"]), - [propsTranslation] ) -> - { - dependencies = propsTranslation.dependencies; - type_ = - Function - { - argTypes = [{aName = ""; aType = propsTranslation.type_}]; - retType = EmitType.typeReactElement; - typeVars = []; - }; - } - | ( (["React"; "Context"; "t"] | ["ReactV3"; "React"; "Context"; "t"]), - [paramTranslation] ) -> - { - dependencies = paramTranslation.dependencies; - type_ = EmitType.typeReactContext ~type_:paramTranslation.type_; - } - | ( ( ["React"; "Ref"; "t"] - | ["React"; "ref"] - | ["ReactV3"; "React"; "Ref"; "t"] - | ["ReactV3"; "React"; "ref"] ), - [paramTranslation] ) -> - { - dependencies = paramTranslation.dependencies; - type_ = EmitType.typeReactRef ~type_:paramTranslation.type_; - } - | (["ReactDOM"; "domRef"] | ["ReactDOM"; "Ref"; "t"]), [] -> - {dependencies = []; type_ = EmitType.typeReactDOMReDomRef} - | ["ReactDOM"; "Ref"; "currentDomRef"], [] -> - {dependencies = []; type_ = EmitType.typeAny} - | ["ReactDOMRe"; "domRef"], [] -> - {dependencies = []; type_ = EmitType.typeReactDOMReDomRef} - | ["ReactDOMRe"; "Ref"; "currentDomRef"], [] -> - {dependencies = []; type_ = EmitType.typeAny} - | ["ReactEvent"; "Mouse"; "t"], [] -> - {dependencies = []; type_ = EmitType.typeReactEventMouseT} - | ( ( ["React"; "element"] - | ["ReactV3"; "React"; "element"] - | ["ReasonReact"; "reactElement"] - | [("Pervasives" | "PervasivesU"); "Jsx"; "element"] ), - [] ) -> - {dependencies = []; type_ = EmitType.typeReactElement} - | (["FB"; "option"] | ["option"]), [paramTranslation] -> - {paramTranslation with type_ = Option paramTranslation.type_} - | ( (["Js"; "Undefined"; "t"] | ["Undefined"; "t"] | ["Js"; "undefined"]), - [paramTranslation] ) -> - {paramTranslation with type_ = Option paramTranslation.type_} - | (["Js"; "Null"; "t"] | ["Null"; "t"] | ["Js"; "null"]), [paramTranslation] - -> - {paramTranslation with type_ = Null paramTranslation.type_} - | ( ( ["Js"; "Nullable"; "t"] - | ["Nullable"; "t"] - | ["Js"; "nullable"] - | ["Js"; "Null_undefined"; "t"] - | ["Js"; "null_undefined"] ), - [paramTranslation] ) -> - {paramTranslation with type_ = Nullable paramTranslation.type_} - | ( (["Js"; "Promise"; "t"] | ["Promise"; "t"] | ["promise"]), - [paramTranslation] ) -> - {paramTranslation with type_ = Promise paramTranslation.type_} - | (["Js"; "Dict"; "t"] | ["Dict"; "t"] | ["dict"]), [paramTranslation] -> - {paramTranslation with type_ = Dict paramTranslation.type_} - | ["function$"], [arg; _arity] -> - {dependencies = arg.dependencies; type_ = arg.type_} - | _ -> defaultCase () - -type processVariant = { - noPayloads: string list; - payloads: (string * Types.type_expr) list; - unknowns: string list; -} - -let processVariant rowFields = - let rec loop ~noPayloads ~payloads ~unknowns fields = - match fields with - | ( label, - ( Types.Rpresent (* no payload *) None - | Reither ((* constant constructor *) true, _, _, _) ) ) - :: otherFields -> - otherFields |> loop ~noPayloads:(label :: noPayloads) ~payloads ~unknowns - | (label, Rpresent (Some payload)) :: otherFields -> - otherFields - |> loop ~noPayloads ~payloads:((label, payload) :: payloads) ~unknowns - | (label, (Rabsent | Reither (false, _, _, _))) :: otherFields -> - otherFields |> loop ~noPayloads ~payloads ~unknowns:(label :: unknowns) - | [] -> - { - noPayloads = noPayloads |> List.rev; - payloads = payloads |> List.rev; - unknowns = unknowns |> List.rev; - } - in - rowFields |> loop ~noPayloads:[] ~payloads:[] ~unknowns:[] - -let rec translateArrowType ~config ~typeVarsGen ~typeEnv ~revArgDeps ~revArgs - (typeExpr : Types.type_expr) = - match typeExpr.desc with - | Tlink t -> - translateArrowType ~config ~typeVarsGen ~typeEnv ~revArgDeps ~revArgs t - | Tarrow (Nolabel, typeExpr1, typeExpr2, _) -> - let {dependencies; type_} = - typeExpr1 |> fun __x -> - translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv __x - in - let nextRevDeps = List.rev_append dependencies revArgDeps in - typeExpr2 - |> translateArrowType ~config ~typeVarsGen ~typeEnv ~revArgDeps:nextRevDeps - ~revArgs:((Nolabel, type_) :: revArgs) - | Tarrow (((Labelled lbl | Optional lbl) as label), typeExpr1, typeExpr2, _) - -> ( - match typeExpr1 |> removeOption ~label with - | None -> - let {dependencies; type_ = type1} = - typeExpr1 |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - in - let nextRevDeps = List.rev_append dependencies revArgDeps in - typeExpr2 - |> translateArrowType ~config ~typeVarsGen ~typeEnv - ~revArgDeps:nextRevDeps - ~revArgs:((Label lbl, type1) :: revArgs) - | Some (lbl, t1) -> - let {dependencies; type_ = type1} = - t1 |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - in - let nextRevDeps = List.rev_append dependencies revArgDeps in - typeExpr2 - |> translateArrowType ~config ~typeVarsGen ~typeEnv - ~revArgDeps:nextRevDeps - ~revArgs:((OptLabel lbl, type1) :: revArgs)) - | _ -> - let {dependencies; type_ = retType} = - typeExpr |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - in - let allDeps = List.rev_append revArgDeps dependencies in - let labeledConvertableTypes = revArgs |> List.rev in - let argTypes = labeledConvertableTypes |> NamedArgs.group in - let functionType = Function {argTypes; retType; typeVars = []} in - {dependencies = allDeps; type_ = functionType} - -and translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - (typeExpr : Types.type_expr) = - match typeExpr.desc with - | Tvar None -> - let typeName = - GenIdent.jsTypeNameForAnonymousTypeID ~typeVarsGen typeExpr.id - in - {dependencies = []; type_ = TypeVar typeName} - | Tvar (Some s) -> {dependencies = []; type_ = TypeVar s} - | Tconstr - (Pdot (Pident {name = "Js"}, "t", _), [{desc = Tvar _ | Tconstr _}], _) -> - (* Preserve some existing uses of Js.t(Obj.t) and Js.t('a). *) - translateObjType Closed [] - | Tconstr (Pdot (Pident {name = "Js"}, "t", _), [t], _) -> - t |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - | Tobject (tObj, _) -> - let rec getFieldTypes (texp : Types.type_expr) = - match texp.desc with - | Tfield (name, _, t1, t2) -> - let closedFlafg, fields = t2 |> getFieldTypes in - ( closedFlafg, - ( name, - match name |> Runtime.isMutableObjectField with - | true -> {dependencies = []; type_ = ident ""} - | false -> - t1 |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv ) - :: fields ) - | Tlink te -> te |> getFieldTypes - | Tvar None -> (Open, []) - | _ -> (Closed, []) - in - let closedFlag, fieldsTranslations = tObj |> getFieldTypes in - translateObjType closedFlag fieldsTranslations - | Tconstr (path, [{desc = Tlink te}], r) -> - {typeExpr with desc = Types.Tconstr (path, [te], r)} - |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - | Tconstr (path, typeParams, _) -> - let paramsTranslation = - typeParams |> translateTypeExprsFromTypes_ ~config ~typeVarsGen ~typeEnv - in - translateConstr ~config ~paramsTranslation ~path ~typeEnv - | Tpoly (t, []) -> - t |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - | Tarrow _ -> - typeExpr - |> translateArrowType ~config ~typeVarsGen ~typeEnv ~revArgDeps:[] - ~revArgs:[] - | Ttuple listExp -> - let innerTypesTranslation = - listExp |> translateTypeExprsFromTypes_ ~config ~typeVarsGen ~typeEnv - in - let innerTypes = innerTypesTranslation |> List.map (fun {type_} -> type_) in - let innerTypesDeps = - innerTypesTranslation - |> List.map (fun {dependencies} -> dependencies) - |> List.concat - in - let tupleType = Tuple innerTypes in - {dependencies = innerTypesDeps; type_ = tupleType} - | Tlink t -> t |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - | Tvariant rowDesc -> ( - match rowDesc.row_fields |> processVariant with - | {noPayloads; payloads = []; unknowns = []} -> - let noPayloads = - noPayloads - |> List.map (fun label -> - { - labelJS = - (if isNumber label then IntLabel label else StringLabel label); - }) - in - let type_ = - createVariant ~inherits:[] ~noPayloads ~payloads:[] ~polymorphic:true - ~tag:None ~unboxed:false - in - {dependencies = []; type_} - | {noPayloads = []; payloads = [(_label, t)]; unknowns = []} -> - (* Handle ReScript's "Arity_" encoding in first argument of Js.Internal.fn(_,_) for uncurried functions. - Return the argument tuple. *) - t |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - | {noPayloads; payloads; unknowns = []} -> - let noPayloads = - noPayloads |> List.map (fun label -> {labelJS = StringLabel label}) - in - let payloadTranslations = - payloads - |> List.map (fun (label, payload) -> - ( label, - payload - |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv )) - in - let payloads = - payloadTranslations - |> List.map (fun (label, translation) -> - {case = {labelJS = StringLabel label}; t = translation.type_}) - in - let type_ = - createVariant ~inherits:[] ~noPayloads ~payloads ~polymorphic:true - ~tag:None ~unboxed:false - in - let dependencies = - payloadTranslations - |> List.map (fun (_, {dependencies}) -> dependencies) - |> List.concat - in - {dependencies; type_} - | {unknowns = _ :: _} -> {dependencies = []; type_ = unknown}) - | Tpackage (path, ids, types) -> ( - match typeEnv |> TypeEnv.lookupModuleTypeSignature ~path with - | Some (signature, typeEnv) -> - let typeEquationsTranslation = - (List.combine ids types [@doesNotRaise]) - |> List.map (fun (x, t) -> - ( x, - t |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - )) - in - let typeEquations = - typeEquationsTranslation - |> List.map (fun (x, translation) -> (x, translation.type_)) - in - let dependenciesFromTypeEquations = - typeEquationsTranslation - |> List.map (fun (_, translation) -> translation.dependencies) - |> List.flatten - in - let typeEnv1 = typeEnv |> TypeEnv.addTypeEquations ~typeEquations in - let dependenciesFromRecordType, type_ = - signature.sig_type - |> signatureToModuleRuntimeRepresentation ~config ~typeVarsGen - ~typeEnv:typeEnv1 - in - { - dependencies = dependenciesFromTypeEquations @ dependenciesFromRecordType; - type_; - } - | None -> {dependencies = []; type_ = unknown}) - | Tfield _ | Tnil | Tpoly _ | Tsubst _ | Tunivar _ -> - {dependencies = []; type_ = unknown} - -and translateTypeExprsFromTypes_ ~config ~typeVarsGen ~typeEnv typeExprs : - translation list = - typeExprs - |> List.map (translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv) - -and signatureToModuleRuntimeRepresentation ~config ~typeVarsGen ~typeEnv - signature = - let dependenciesAndFields = - signature - |> List.map (fun signatureItem -> - match signatureItem with - | Types.Sig_value (_id, {val_kind = Val_prim _}) -> ([], []) - | Types.Sig_value (id, {val_type = typeExpr; val_attributes}) -> - let {dependencies; type_} = - typeExpr - |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - in - let field = - { - mutable_ = Immutable; - nameJS = id |> Ident.name; - optional = Mandatory; - type_; - docString = Annotation.docStringFromAttrs val_attributes; - } - in - (dependencies, [field]) - | Types.Sig_module (id, moduleDeclaration, _recStatus) -> - let typeEnv1 = - match typeEnv |> TypeEnv.getModule ~name:(id |> Ident.name) with - | Some typeEnv1 -> typeEnv1 - | None -> typeEnv - in - let dependencies, type_ = - match moduleDeclaration.md_type with - | Mty_signature signature -> - signature - |> signatureToModuleRuntimeRepresentation ~config ~typeVarsGen - ~typeEnv:typeEnv1 - | Mty_ident _ | Mty_functor _ | Mty_alias _ -> ([], unknown) - in - let field = - { - mutable_ = Immutable; - nameJS = id |> Ident.name; - optional = Mandatory; - type_; - docString = - Annotation.docStringFromAttrs moduleDeclaration.md_attributes; - } - in - (dependencies, [field]) - | Types.Sig_type _ | Types.Sig_typext _ | Types.Sig_modtype _ - | Types.Sig_class _ | Types.Sig_class_type _ -> - ([], [])) - in - let dependencies, fields = - let dl, fl = dependenciesAndFields |> List.split in - (dl |> List.concat, fl |> List.concat) - in - (dependencies, Object (Closed, fields)) - -let translateTypeExprFromTypes ~config ~typeEnv typeExpr = - let typeVarsGen = GenIdent.createTypeVarsGen () in - let translation = - typeExpr |> translateTypeExprFromTypes_ ~config ~typeVarsGen ~typeEnv - in - if !Debug.dependencies then - translation.dependencies - |> List.iter (fun dep -> Log_.item "Dependency: %s\n" (dep |> depToString)); - translation - -let translateTypeExprsFromTypes ~config ~typeEnv typeExprs = - let typeVarsGen = GenIdent.createTypeVarsGen () in - let translations = - typeExprs |> translateTypeExprsFromTypes_ ~config ~typeVarsGen ~typeEnv - in - if !Debug.dependencies then - translations - |> List.iter (fun translation -> - translation.dependencies - |> List.iter (fun dep -> - Log_.item "Dependency: %s\n" (dep |> depToString))); - translations diff --git a/jscomp/gentype/Translation.ml b/jscomp/gentype/Translation.ml deleted file mode 100644 index bd787ea..0000000 --- a/jscomp/gentype/Translation.ml +++ /dev/null @@ -1,207 +0,0 @@ -open GenTypeCommon - -type t = CodeItem.translation - -let empty = ({importTypes = []; codeItems = []; typeDeclarations = []} : t) - -let getImportTypeUniqueName ({typeName; asTypeName} : CodeItem.importType) = - typeName - ^ - match asTypeName with - | None -> "" - | Some s -> "_as_" ^ s - -let importTypeCompare i1 i2 = - compare (i1 |> getImportTypeUniqueName) (i2 |> getImportTypeUniqueName) - -let combine (translations : t list) : t = - ( translations - |> List.map (fun {CodeItem.importTypes; codeItems; typeDeclarations} -> - ((importTypes, codeItems), typeDeclarations)) - |> List.split - |> fun (x, y) -> (x |> List.split, y) ) - |> fun ((importTypes, codeItems), typeDeclarations) -> - { - CodeItem.importTypes = importTypes |> List.concat; - codeItems = codeItems |> List.concat; - typeDeclarations = typeDeclarations |> List.concat; - } - -(** Applies type parameters to types (for all) *) -let abstractTheTypeParameters ~typeVars type_ = - match type_ with - | Function function_ -> Function {function_ with typeVars} - | _ -> type_ - -let depToImportType ~config ~outputFileRelative ~resolver (dep : dep) = - match dep with - | _ when dep |> Dependencies.isInternal -> [] - | External name when name = "list" -> - [ - { - CodeItem.typeName = "list"; - asTypeName = None; - importPath = - ModuleName.rescriptPervasives - |> ModuleResolver.importPathForReasonModuleName ~config - ~outputFileRelative ~resolver; - }; - ] - | External _ -> [] - | Internal _ -> [] - | Dot _ -> - let moduleName = dep |> Dependencies.getOuterModuleName in - let typeName = - dep |> Dependencies.removeExternalOuterModule |> depToString - in - let asTypeName = - match dep |> Dependencies.isInternal with - | true -> None - | false -> Some (dep |> depToString) - in - let importPath = - moduleName - |> ModuleResolver.importPathForReasonModuleName ~config - ~outputFileRelative ~resolver - in - [{typeName; asTypeName; importPath}] - -let translateDependencies ~config ~outputFileRelative ~resolver dependencies : - CodeItem.importType list = - dependencies - |> List.map (depToImportType ~config ~outputFileRelative ~resolver) - |> List.concat - -let translateValue ~attributes ~config ~docString ~outputFileRelative ~resolver - ~typeEnv ~typeExpr ~(addAnnotationsToFunction : type_ -> type_) name : t = - let nameAs = - match Annotation.getGenTypeAsRenaming attributes with - | Some s -> s - | _ -> name - in - let typeExprTranslation = - typeExpr - |> TranslateTypeExprFromTypes.translateTypeExprFromTypes ~config ~typeEnv - in - let typeVars = typeExprTranslation.type_ |> TypeVars.free in - let type_ = - typeExprTranslation.type_ - |> abstractTheTypeParameters ~typeVars - |> addAnnotationsToFunction - in - let resolvedNameOriginal = - name |> TypeEnv.addModulePath ~typeEnv |> ResolvedName.toString - in - let resolvedName = nameAs |> TypeEnv.addModulePath ~typeEnv in - let moduleAccessPath = - typeEnv |> TypeEnv.getModuleAccessPath ~name:resolvedNameOriginal - in - let codeItems = - [ - CodeItem.ExportValue - {docString; moduleAccessPath; originalName = name; resolvedName; type_}; - ] - in - { - importTypes = - typeExprTranslation.dependencies - |> translateDependencies ~config ~outputFileRelative ~resolver; - codeItems; - typeDeclarations = []; - } - -(** - [@genType] - [@bs.module] external myBanner : ReasonReact.reactClass = "./MyBanner"; -*) -let translatePrimitive ~config ~outputFileRelative ~resolver ~typeEnv - (valueDescription : Typedtree.value_description) : t = - if !Debug.translation then Log_.item "Translate Primitive\n"; - let valueName = - match valueDescription.val_prim with - | "" :: _ | [] -> valueDescription.val_id |> Ident.name - | nameOfExtern :: _ -> - (* extern foo : someType = "abc" - The first element of val_prim is "abc" *) - nameOfExtern - in - let typeExprTranslation = - valueDescription.val_desc - |> TranslateCoreType.translateCoreType ~config ~typeEnv - in - let attributeImport, attributeRenaming = - valueDescription.val_attributes |> Annotation.getAttributeImportRenaming - in - match (typeExprTranslation.type_, attributeImport) with - | _, Some importString -> - let asPath = - match attributeRenaming with - | Some asPath -> asPath - | None -> valueName - in - let typeVars = typeExprTranslation.type_ |> TypeVars.free in - let type_ = - typeExprTranslation.type_ |> abstractTheTypeParameters ~typeVars - in - { - importTypes = - typeExprTranslation.dependencies - |> translateDependencies ~config ~outputFileRelative ~resolver; - codeItems = - [ - ImportValue - { - asPath; - importAnnotation = importString |> Annotation.importFromString; - type_; - valueName; - }; - ]; - typeDeclarations = []; - } - | _ -> {importTypes = []; codeItems = []; typeDeclarations = []} - -let addTypeDeclarationsFromModuleEquations ~typeEnv (translation : t) = - let eqs = typeEnv |> TypeEnv.getModuleEquations in - let newTypeDeclarations = - translation.typeDeclarations - |> List.map (fun (typeDeclaration : CodeItem.typeDeclaration) -> - let exportType = - typeDeclaration.exportFromTypeDeclaration.exportType - in - let equations = - exportType.resolvedTypeName |> ResolvedName.applyEquations ~eqs - in - equations - |> List.map (fun (x, y) -> - let newExportType = - { - exportType with - nameAs = None; - type_ = - y |> ResolvedName.toString - |> ident ~builtin:false - ~typeArgs: - (exportType.typeVars - |> List.map (fun s -> TypeVar s)); - resolvedTypeName = x; - } - in - { - CodeItem.exportFromTypeDeclaration = - { - CodeItem.exportType = newExportType; - annotation = - typeDeclaration.exportFromTypeDeclaration.annotation; - }; - importTypes = []; - })) - |> List.concat - in - match newTypeDeclarations = [] with - | true -> translation - | false -> - { - translation with - typeDeclarations = translation.typeDeclarations @ newTypeDeclarations; - } diff --git a/jscomp/gentype/TypeEnv.ml b/jscomp/gentype/TypeEnv.ml deleted file mode 100644 index 693d154..0000000 --- a/jscomp/gentype/TypeEnv.ml +++ /dev/null @@ -1,198 +0,0 @@ -open GenTypeCommon - -type moduleEquation = {internal: bool; dep: dep} - -type t = { - mutable map: entry StringMap.t; - mutable mapModuleTypes: (Typedtree.signature * t) StringMap.t; - mutable moduleEquation: moduleEquation option; - mutable moduleItem: Runtime.moduleItem; - name: string; - parent: t option; - typeEquations: type_ StringMap.t; -} - -and entry = Module of t | Type of string - -let createTypeEnv ~name parent = - let moduleItem = Runtime.newModuleItem ~name in - { - map = StringMap.empty; - mapModuleTypes = StringMap.empty; - moduleEquation = None; - moduleItem; - name; - parent; - typeEquations = StringMap.empty; - } - -let root () = None |> createTypeEnv ~name:"__root__" -let toString typeEnv = typeEnv.name - -let newModule ~name typeEnv = - if !Debug.typeEnv then - Log_.item "TypeEnv.newModule %s %s\n" (typeEnv |> toString) name; - let newTypeEnv = Some typeEnv |> createTypeEnv ~name in - typeEnv.map <- typeEnv.map |> StringMap.add name (Module newTypeEnv); - newTypeEnv - -let newModuleType ~name ~signature typeEnv = - if !Debug.typeEnv then - Log_.item "TypeEnv.newModuleType %s %s\n" (typeEnv |> toString) name; - let newTypeEnv = Some typeEnv |> createTypeEnv ~name in - typeEnv.mapModuleTypes <- - typeEnv.mapModuleTypes |> StringMap.add name (signature, newTypeEnv); - newTypeEnv - -let newType ~name typeEnv = - if !Debug.typeEnv then - Log_.item "TypeEnv.newType %s %s\n" (typeEnv |> toString) name; - typeEnv.map <- typeEnv.map |> StringMap.add name (Type name) - -let getModule ~name typeEnv = - match typeEnv.map |> StringMap.find name with - | Module typeEnv1 -> Some typeEnv1 - | Type _ -> None - | exception Not_found -> None - -let expandAliasToExternalModule ~name typeEnv = - match typeEnv |> getModule ~name with - | Some {moduleEquation = Some {internal = false; dep}} -> - if !Debug.typeEnv then - Log_.item "TypeEnv.expandAliasToExternalModule %s %s aliased to %s\n" - (typeEnv |> toString) name (dep |> depToString); - Some dep - | _ -> None - -let addModuleEquation ~dep ~internal typeEnv = - if !Debug.typeEnv then - Log_.item "Typenv.addModuleEquation %s %s dep:%s\n" (typeEnv |> toString) - (match internal with - | true -> "Internal" - | false -> "External") - (dep |> depToString); - typeEnv.moduleEquation <- Some {internal; dep} - -let rec addTypeEquation ~flattened ~type_ typeEnv = - match flattened with - | [name] -> - { - typeEnv with - typeEquations = typeEnv.typeEquations |> StringMap.add name type_; - } - | moduleName :: rest -> ( - match typeEnv |> getModule ~name:moduleName with - | Some typeEnv1 -> - { - typeEnv with - map = - typeEnv.map - |> StringMap.add moduleName - (Module (typeEnv1 |> addTypeEquation ~flattened:rest ~type_)); - } - | None -> typeEnv) - | [] -> typeEnv - -let addTypeEquations ~typeEquations typeEnv = - typeEquations - |> List.fold_left - (fun te (longIdent, type_) -> - te - |> addTypeEquation ~flattened:(longIdent |> Longident.flatten) ~type_) - typeEnv - -let applyTypeEquations ~config ~path typeEnv = - match path with - | Path.Pident id -> ( - match typeEnv.typeEquations |> StringMap.find (id |> Ident.name) with - | type_ -> - if !Debug.typeResolution then - Log_.item "Typenv.applyTypeEquations %s name:%s type_:%s\n" - (typeEnv |> toString) (id |> Ident.name) - (type_ - |> EmitType.typeToString ~config ~typeNameIsInterface:(fun _ -> false) - ); - Some type_ - | exception Not_found -> None) - | _ -> None - -let rec lookup ~name typeEnv = - match typeEnv.map |> StringMap.find name with - | _ -> Some typeEnv - | exception Not_found -> ( - match typeEnv.parent with - | None -> None - | Some parent -> parent |> lookup ~name) - -let rec lookupModuleType ~path typeEnv = - match path with - | [moduleTypeName] -> ( - if !Debug.typeEnv then - Log_.item "Typenv.lookupModuleType %s moduleTypeName:%s\n" - (typeEnv |> toString) moduleTypeName; - match typeEnv.mapModuleTypes |> StringMap.find moduleTypeName with - | x -> Some x - | exception Not_found -> ( - match typeEnv.parent with - | None -> None - | Some parent -> parent |> lookupModuleType ~path)) - | moduleName :: path1 -> ( - if !Debug.typeEnv then - Log_.item "Typenv.lookupModuleType %s moduleName:%s\n" - (typeEnv |> toString) moduleName; - match typeEnv.map |> StringMap.find moduleName with - | Module typeEnv1 -> typeEnv1 |> lookupModuleType ~path:path1 - | Type _ -> None - | exception Not_found -> ( - match typeEnv.parent with - | None -> None - | Some parent -> parent |> lookupModuleType ~path)) - | [] -> None - -let rec pathToList path = - match path with - | Path.Pident id -> [id |> Ident.name] - | Path.Pdot (p, s, _) -> s :: (p |> pathToList) - | Path.Papply _ -> [] - -let lookupModuleTypeSignature ~path typeEnv = - if !Debug.typeEnv then - Log_.item "TypeEnv.lookupModuleTypeSignature %s %s\n" (typeEnv |> toString) - (path |> Path.name); - typeEnv |> lookupModuleType ~path:(path |> pathToList |> List.rev) - -let updateModuleItem ~moduleItem typeEnv = typeEnv.moduleItem <- moduleItem - -let rec addModulePath ~typeEnv name = - match typeEnv.parent with - | None -> name |> ResolvedName.fromString - | Some parent -> - typeEnv.name |> addModulePath ~typeEnv:parent |> ResolvedName.dot name - -let rec getModuleEquations typeEnv : ResolvedName.eq list = - let subEquations = - typeEnv.map |> StringMap.bindings - |> List.map (fun (_, entry) -> - match entry with - | Module te -> te |> getModuleEquations - | Type _ -> []) - |> List.concat - in - match (typeEnv.moduleEquation, typeEnv.parent) with - | None, _ | _, None -> subEquations - | Some {dep}, Some parent -> - [(dep |> depToResolvedName, typeEnv.name |> addModulePath ~typeEnv:parent)] - -let getModuleAccessPath ~name typeEnv = - let rec accessPath typeEnv = - match typeEnv.parent with - | None -> Runtime.Root name (* not nested *) - | Some parent -> - Dot - ( (match parent.parent = None with - | true -> Root typeEnv.name - | false -> parent |> accessPath), - typeEnv.moduleItem ) - in - - typeEnv |> accessPath diff --git a/jscomp/gentype/TypeEnv.mli b/jscomp/gentype/TypeEnv.mli deleted file mode 100644 index c56558e..0000000 --- a/jscomp/gentype/TypeEnv.mli +++ /dev/null @@ -1,23 +0,0 @@ -open GenTypeCommon - -type t - -val addModuleEquation : dep:dep -> internal:bool -> t -> unit -val addModulePath : typeEnv:t -> string -> ResolvedName.t -val addTypeEquations : typeEquations:(Longident.t * type_) list -> t -> t -val applyTypeEquations : config:Config.t -> path:Path.t -> t -> type_ option -val expandAliasToExternalModule : name:string -> t -> dep option -val getModuleEquations : t -> ResolvedName.eq list -val getModuleAccessPath : name:string -> t -> Runtime.moduleAccessPath -val getModule : name:string -> t -> t option -val lookup : name:string -> t -> t option - -val lookupModuleTypeSignature : - path:Path.t -> t -> (Typedtree.signature * t) option - -val newModule : name:string -> t -> t -val newModuleType : name:string -> signature:Typedtree.signature -> t -> t -val newType : name:string -> t -> unit -val root : unit -> t -val toString : t -> string -val updateModuleItem : moduleItem:Runtime.moduleItem -> t -> unit diff --git a/jscomp/gentype/TypeVars.ml b/jscomp/gentype/TypeVars.ml deleted file mode 100644 index 3957362..0000000 --- a/jscomp/gentype/TypeVars.ml +++ /dev/null @@ -1,108 +0,0 @@ -open GenTypeCommon - -let extractFromTypeExpr typeParams = - typeParams - |> List.fold_left - (fun soFar typeExpr -> - match typeExpr with - | {Types.desc = Tvar (Some s)} -> - let typeName = s in - typeName :: soFar - | {Types.desc = Tlink _} -> - (* see if we need to collect more type vars here: t as 'a *) - soFar - | _ -> assert false) - [] - |> List.rev - -let extractFromCoreType typeParams = - typeParams - |> List.fold_left - (fun soFar typeExpr -> - match typeExpr.Typedtree.ctyp_desc with - | Ttyp_var s -> - let typeName = s in - typeName :: soFar - | _ -> soFar) - [] - |> List.rev - -let rec substitute ~f type0 = - match type0 with - | Array (t, arrayKind) -> Array (t |> substitute ~f, arrayKind) - | Dict type_ -> Dict (type_ |> substitute ~f) - | Function function_ -> - Function - { - function_ with - argTypes = - function_.argTypes - |> List.map (fun {aName; aType = t} -> - {aName; aType = t |> substitute ~f}); - } - | Ident {typeArgs = []} -> type0 - | Ident ({typeArgs} as ident) -> - Ident {ident with typeArgs = typeArgs |> List.map (substitute ~f)} - | Null type_ -> Null (type_ |> substitute ~f) - | Nullable type_ -> Nullable (type_ |> substitute ~f) - | Object (closedFlag, fields) -> - Object - ( closedFlag, - fields - |> List.map (fun field -> - {field with type_ = field.type_ |> substitute ~f}) ) - | Option type_ -> Option (type_ |> substitute ~f) - | Promise type_ -> Promise (type_ |> substitute ~f) - | Tuple innerTypes -> Tuple (innerTypes |> List.map (substitute ~f)) - | TypeVar s -> ( - match f s with - | None -> type0 - | Some type1 -> type1) - | Variant variant -> - Variant - { - variant with - payloads = - variant.payloads - |> List.map (fun payload -> - {payload with t = payload.t |> substitute ~f}); - } - -let rec free_ type0 : StringSet.t = - match type0 with - | Array (t, _) -> t |> free_ - | Function {argTypes; retType; typeVars} -> - StringSet.diff - ((argTypes |> freeOfList_) +++ (retType |> free_)) - (typeVars |> StringSet.of_list) - | Object (_, fields) -> - fields - |> List.fold_left - (fun s {type_} -> StringSet.union s (type_ |> free_)) - StringSet.empty - | Ident {typeArgs} -> - typeArgs - |> List.fold_left - (fun s typeArg -> StringSet.union s (typeArg |> free_)) - StringSet.empty - | Dict type_ | Null type_ | Nullable type_ -> type_ |> free_ - | Option type_ | Promise type_ -> type_ |> free_ - | Tuple innerTypes -> - innerTypes - |> List.fold_left - (fun s typeArg -> StringSet.union s (typeArg |> free_)) - StringSet.empty - | TypeVar s -> s |> StringSet.singleton - | Variant {payloads} -> - payloads - |> List.fold_left - (fun s {t} -> StringSet.union s (t |> free_)) - StringSet.empty - -and freeOfList_ types = - types - |> List.fold_left (fun s {aType} -> s +++ (aType |> free_)) StringSet.empty - -and ( +++ ) = StringSet.union - -let free type_ = type_ |> free_ |> StringSet.elements diff --git a/jscomp/gentype/dune b/jscomp/gentype/dune deleted file mode 100644 index bda6c4e..0000000 --- a/jscomp/gentype/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name gentype) - (wrapped false) - (flags - (:standard -w -A)) - (libraries ml)) diff --git a/jscomp/gentype_tests/typescript-react-example/.eslintrc.json b/jscomp/gentype_tests/typescript-react-example/.eslintrc.json deleted file mode 100644 index 0eba27d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/.eslintrc.json +++ /dev/null @@ -1,10 +0,0 @@ -{ - "extends": [ - "eslint:recommended", - "plugin:@typescript-eslint/recommended" - ], - "parser": "@typescript-eslint/parser", - "plugins": ["@typescript-eslint"], - "ignorePatterns": ["src/**/*.res.js"], - "root": true -} diff --git a/jscomp/gentype_tests/typescript-react-example/.gitignore b/jscomp/gentype_tests/typescript-react-example/.gitignore deleted file mode 100644 index 3099aa9..0000000 --- a/jscomp/gentype_tests/typescript-react-example/.gitignore +++ /dev/null @@ -1,17 +0,0 @@ -# See https://help.github.com/ignore-files/ for more about ignoring files. - -# dependencies -/node_modules - - -# misc -/lib -.DS_Store -.env.local -.env.development.local -.env.test.local -.env.production.local - -npm-debug.log* -yarn-debug.log* -yarn-error.log* diff --git a/jscomp/gentype_tests/typescript-react-example/.watchmanconfig b/jscomp/gentype_tests/typescript-react-example/.watchmanconfig deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/gentype_tests/typescript-react-example/Makefile b/jscomp/gentype_tests/typescript-react-example/Makefile deleted file mode 100644 index e1f64bc..0000000 --- a/jscomp/gentype_tests/typescript-react-example/Makefile +++ /dev/null @@ -1,14 +0,0 @@ -SHELL = /bin/bash - -test: - npm install - npm run build - npm run tsc - npm run lint - -clean: - rm -rf node_modules lib src/*.res.js src/*.gen.tsx - -.DEFAULT_GOAL := test - -.PHONY: clean test diff --git a/jscomp/gentype_tests/typescript-react-example/README.md b/jscomp/gentype_tests/typescript-react-example/README.md deleted file mode 100644 index dcc8f9e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/README.md +++ /dev/null @@ -1,18 +0,0 @@ -# typescript-react-example - -This project was created with [Create React App](https://github.com/facebookincubator/create-react-app). - -For the setup, run `npm install`. -Make sure to build gentype.native, as stated in the project root README. - -## Running the Project - -```sh -# Start the Reason watcher. -npm run start - -# In another tab: start the TypeScript watcher. -npm run ts:watch -``` - - diff --git a/jscomp/gentype_tests/typescript-react-example/package-lock.json b/jscomp/gentype_tests/typescript-react-example/package-lock.json deleted file mode 100644 index 5fdd739..0000000 --- a/jscomp/gentype_tests/typescript-react-example/package-lock.json +++ /dev/null @@ -1,1687 +0,0 @@ -{ - "name": "typescript-react-example", - "version": "0.1.0", - "lockfileVersion": 3, - "requires": true, - "packages": { - "": { - "name": "typescript-react-example", - "version": "0.1.0", - "dependencies": { - "@rescript/react": "^0.12.0", - "react": "^18.2.0", - "react-dom": "^18.2.0" - }, - "devDependencies": { - "@types/node": "^18.15.12", - "@types/react-dom": "^18.0.11", - "@typescript-eslint/eslint-plugin": "^6.8.0", - "@typescript-eslint/parser": "^6.8.0", - "eslint": "^8.51.0", - "rescript": "file:../../..", - "typescript": "^5.2.2" - } - }, - "../../..": { - "name": "rescript", - "version": "11.1.0", - "dev": true, - "hasInstallScript": true, - "license": "SEE LICENSE IN LICENSE", - "bin": { - "bsc": "bsc", - "bstracing": "lib/bstracing", - "rescript": "rescript" - }, - "devDependencies": { - "mocha": "10.1.0", - "nyc": "15.0.0", - "prettier": "2.7.1" - }, - "engines": { - "node": ">=10" - } - }, - "node_modules/@aashutoshrathi/word-wrap": { - "version": "1.2.6", - "resolved": "https://registry.npmjs.org/@aashutoshrathi/word-wrap/-/word-wrap-1.2.6.tgz", - "integrity": "sha512-1Yjs2SvM8TflER/OD3cOjhWWOZb58A2t7wpE2S9XfBYTiIl+XFhQG2bjy4Pu1I+EAlCNUzRDYDdFwFYUKvXcIA==", - "dev": true, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/@eslint-community/eslint-utils": { - "version": "4.4.0", - "resolved": "https://registry.npmjs.org/@eslint-community/eslint-utils/-/eslint-utils-4.4.0.tgz", - "integrity": "sha512-1/sA4dwrzBAyeUoQ6oxahHKmrZvsnLCg4RfxW3ZFGGmQkSNQPFNLV9CUEFQP1x9EYXHTo5p6xdhZM1Ne9p/AfA==", - "dev": true, - "dependencies": { - "eslint-visitor-keys": "^3.3.0" - }, - "engines": { - "node": "^12.22.0 || ^14.17.0 || >=16.0.0" - }, - "peerDependencies": { - "eslint": "^6.0.0 || ^7.0.0 || >=8.0.0" - } - }, - "node_modules/@eslint-community/regexpp": { - "version": "4.9.1", - "resolved": "https://registry.npmjs.org/@eslint-community/regexpp/-/regexpp-4.9.1.tgz", - "integrity": "sha512-Y27x+MBLjXa+0JWDhykM3+JE+il3kHKAEqabfEWq3SDhZjLYb6/BHL/JKFnH3fe207JaXkyDo685Oc2Glt6ifA==", - "dev": true, - "engines": { - "node": "^12.0.0 || ^14.0.0 || >=16.0.0" - } - }, - "node_modules/@eslint/eslintrc": { - "version": "2.1.2", - "resolved": "https://registry.npmjs.org/@eslint/eslintrc/-/eslintrc-2.1.2.tgz", - "integrity": "sha512-+wvgpDsrB1YqAMdEUCcnTlpfVBH7Vqn6A/NT3D8WVXFIaKMlErPIZT3oCIAVCOtarRpMtelZLqJeU3t7WY6X6g==", - "dev": true, - "dependencies": { - "ajv": "^6.12.4", - "debug": "^4.3.2", - "espree": "^9.6.0", - "globals": "^13.19.0", - "ignore": "^5.2.0", - "import-fresh": "^3.2.1", - "js-yaml": "^4.1.0", - "minimatch": "^3.1.2", - "strip-json-comments": "^3.1.1" - }, - "engines": { - "node": "^12.22.0 || ^14.17.0 || >=16.0.0" - }, - "funding": { - "url": "https://opencollective.com/eslint" - } - }, - "node_modules/@eslint/js": { - "version": "8.51.0", - "resolved": "https://registry.npmjs.org/@eslint/js/-/js-8.51.0.tgz", - "integrity": "sha512-HxjQ8Qn+4SI3/AFv6sOrDB+g6PpUTDwSJiQqOrnneEk8L71161srI9gjzzZvYVbzHiVg/BvcH95+cK/zfIt4pg==", - "dev": true, - "engines": { - "node": "^12.22.0 || ^14.17.0 || >=16.0.0" - } - }, - "node_modules/@humanwhocodes/config-array": { - "version": "0.11.11", - "resolved": "https://registry.npmjs.org/@humanwhocodes/config-array/-/config-array-0.11.11.tgz", - "integrity": "sha512-N2brEuAadi0CcdeMXUkhbZB84eskAc8MEX1By6qEchoVywSgXPIjou4rYsl0V3Hj0ZnuGycGCjdNgockbzeWNA==", - "dev": true, - "dependencies": { - "@humanwhocodes/object-schema": "^1.2.1", - "debug": "^4.1.1", - "minimatch": "^3.0.5" - }, - "engines": { - "node": ">=10.10.0" - } - }, - "node_modules/@humanwhocodes/module-importer": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/@humanwhocodes/module-importer/-/module-importer-1.0.1.tgz", - "integrity": "sha512-bxveV4V8v5Yb4ncFTT3rPSgZBOpCkjfK0y4oVVVJwIuDVBRMDXrPyXRL988i5ap9m9bnyEEjWfm5WkBmtffLfA==", - "dev": true, - "engines": { - "node": ">=12.22" - }, - "funding": { - "type": "github", - "url": "https://github.com/sponsors/nzakas" - } - }, - "node_modules/@humanwhocodes/object-schema": { - "version": "1.2.1", - "resolved": "https://registry.npmjs.org/@humanwhocodes/object-schema/-/object-schema-1.2.1.tgz", - "integrity": "sha512-ZnQMnLV4e7hDlUvw8H+U8ASL02SS2Gn6+9Ac3wGGLIe7+je2AeAOxPY+izIPJDfFDb7eDjev0Us8MO1iFRN8hA==", - "dev": true - }, - "node_modules/@nodelib/fs.scandir": { - "version": "2.1.5", - "resolved": "https://registry.npmjs.org/@nodelib/fs.scandir/-/fs.scandir-2.1.5.tgz", - "integrity": "sha512-vq24Bq3ym5HEQm2NKCr3yXDwjc7vTsEThRDnkp2DK9p1uqLR+DHurm/NOTo0KG7HYHU7eppKZj3MyqYuMBf62g==", - "dev": true, - "dependencies": { - "@nodelib/fs.stat": "2.0.5", - "run-parallel": "^1.1.9" - }, - "engines": { - "node": ">= 8" - } - }, - "node_modules/@nodelib/fs.stat": { - "version": "2.0.5", - "resolved": "https://registry.npmjs.org/@nodelib/fs.stat/-/fs.stat-2.0.5.tgz", - "integrity": "sha512-RkhPPp2zrqDAQA/2jNhnztcPAlv64XdhIp7a7454A5ovI7Bukxgt7MX7udwAu3zg1DcpPU0rz3VV1SeaqvY4+A==", - "dev": true, - "engines": { - "node": ">= 8" - } - }, - "node_modules/@nodelib/fs.walk": { - "version": "1.2.8", - "resolved": "https://registry.npmjs.org/@nodelib/fs.walk/-/fs.walk-1.2.8.tgz", - "integrity": "sha512-oGB+UxlgWcgQkgwo8GcEGwemoTFt3FIO9ababBmaGwXIoBKZ+GTy0pP185beGg7Llih/NSHSV2XAs1lnznocSg==", - "dev": true, - "dependencies": { - "@nodelib/fs.scandir": "2.1.5", - "fastq": "^1.6.0" - }, - "engines": { - "node": ">= 8" - } - }, - "node_modules/@rescript/react": { - "version": "0.12.0", - "resolved": "https://registry.npmjs.org/@rescript/react/-/react-0.12.0.tgz", - "integrity": "sha512-EBLsf5rD7sJOjgfLLGwuLw/hONszc3UtYnIVgv7OdTyUNR41/m4deVm62PI0agvr3kWakXz4KchKRSd+19/bRA==", - "peerDependencies": { - "react": ">=18.0.0", - "react-dom": ">=18.0.0" - } - }, - "node_modules/@types/json-schema": { - "version": "7.0.14", - "resolved": "https://registry.npmjs.org/@types/json-schema/-/json-schema-7.0.14.tgz", - "integrity": "sha512-U3PUjAudAdJBeC2pgN8uTIKgxrb4nlDF3SF0++EldXQvQBGkpFZMSnwQiIoDU77tv45VgNkl/L4ouD+rEomujw==", - "dev": true - }, - "node_modules/@types/node": { - "version": "18.18.6", - "resolved": "https://registry.npmjs.org/@types/node/-/node-18.18.6.tgz", - "integrity": "sha512-wf3Vz+jCmOQ2HV1YUJuCWdL64adYxumkrxtc+H1VUQlnQI04+5HtH+qZCOE21lBE7gIrt+CwX2Wv8Acrw5Ak6w==", - "dev": true - }, - "node_modules/@types/prop-types": { - "version": "15.7.9", - "resolved": "https://registry.npmjs.org/@types/prop-types/-/prop-types-15.7.9.tgz", - "integrity": "sha512-n1yyPsugYNSmHgxDFjicaI2+gCNjsBck8UX9kuofAKlc0h1bL+20oSF72KeNaW2DUlesbEVCFgyV2dPGTiY42g==", - "dev": true - }, - "node_modules/@types/react": { - "version": "18.2.29", - "resolved": "https://registry.npmjs.org/@types/react/-/react-18.2.29.tgz", - "integrity": "sha512-Z+ZrIRocWtdD70j45izShRwDuiB4JZqDegqMFW/I8aG5DxxLKOzVNoq62UIO82v9bdgi+DO1jvsb9sTEZUSm+Q==", - "dev": true, - "dependencies": { - "@types/prop-types": "*", - "@types/scheduler": "*", - "csstype": "^3.0.2" - } - }, - "node_modules/@types/react-dom": { - "version": "18.2.14", - "resolved": "https://registry.npmjs.org/@types/react-dom/-/react-dom-18.2.14.tgz", - "integrity": "sha512-V835xgdSVmyQmI1KLV2BEIUgqEuinxp9O4G6g3FqO/SqLac049E53aysv0oEFD2kHfejeKU+ZqL2bcFWj9gLAQ==", - "dev": true, - "dependencies": { - "@types/react": "*" - } - }, - "node_modules/@types/scheduler": { - "version": "0.16.5", - "resolved": "https://registry.npmjs.org/@types/scheduler/-/scheduler-0.16.5.tgz", - "integrity": "sha512-s/FPdYRmZR8SjLWGMCuax7r3qCWQw9QKHzXVukAuuIJkXkDRwp+Pu5LMIVFi0Fxbav35WURicYr8u1QsoybnQw==", - "dev": true - }, - "node_modules/@types/semver": { - "version": "7.5.4", - "resolved": "https://registry.npmjs.org/@types/semver/-/semver-7.5.4.tgz", - "integrity": "sha512-MMzuxN3GdFwskAnb6fz0orFvhfqi752yjaXylr0Rp4oDg5H0Zn1IuyRhDVvYOwAXoJirx2xuS16I3WjxnAIHiQ==", - "dev": true - }, - "node_modules/@typescript-eslint/eslint-plugin": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/eslint-plugin/-/eslint-plugin-6.8.0.tgz", - "integrity": "sha512-GosF4238Tkes2SHPQ1i8f6rMtG6zlKwMEB0abqSJ3Npvos+doIlc/ATG+vX1G9coDF3Ex78zM3heXHLyWEwLUw==", - "dev": true, - "dependencies": { - "@eslint-community/regexpp": "^4.5.1", - "@typescript-eslint/scope-manager": "6.8.0", - "@typescript-eslint/type-utils": "6.8.0", - "@typescript-eslint/utils": "6.8.0", - "@typescript-eslint/visitor-keys": "6.8.0", - "debug": "^4.3.4", - "graphemer": "^1.4.0", - "ignore": "^5.2.4", - "natural-compare": "^1.4.0", - "semver": "^7.5.4", - "ts-api-utils": "^1.0.1" - }, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - }, - "peerDependencies": { - "@typescript-eslint/parser": "^6.0.0 || ^6.0.0-alpha", - "eslint": "^7.0.0 || ^8.0.0" - }, - "peerDependenciesMeta": { - "typescript": { - "optional": true - } - } - }, - "node_modules/@typescript-eslint/parser": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/parser/-/parser-6.8.0.tgz", - "integrity": "sha512-5tNs6Bw0j6BdWuP8Fx+VH4G9fEPDxnVI7yH1IAPkQH5RUtvKwRoqdecAPdQXv4rSOADAaz1LFBZvZG7VbXivSg==", - "dev": true, - "dependencies": { - "@typescript-eslint/scope-manager": "6.8.0", - "@typescript-eslint/types": "6.8.0", - "@typescript-eslint/typescript-estree": "6.8.0", - "@typescript-eslint/visitor-keys": "6.8.0", - "debug": "^4.3.4" - }, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - }, - "peerDependencies": { - "eslint": "^7.0.0 || ^8.0.0" - }, - "peerDependenciesMeta": { - "typescript": { - "optional": true - } - } - }, - "node_modules/@typescript-eslint/scope-manager": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/scope-manager/-/scope-manager-6.8.0.tgz", - "integrity": "sha512-xe0HNBVwCph7rak+ZHcFD6A+q50SMsFwcmfdjs9Kz4qDh5hWhaPhFjRs/SODEhroBI5Ruyvyz9LfwUJ624O40g==", - "dev": true, - "dependencies": { - "@typescript-eslint/types": "6.8.0", - "@typescript-eslint/visitor-keys": "6.8.0" - }, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - } - }, - "node_modules/@typescript-eslint/type-utils": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/type-utils/-/type-utils-6.8.0.tgz", - "integrity": "sha512-RYOJdlkTJIXW7GSldUIHqc/Hkto8E+fZN96dMIFhuTJcQwdRoGN2rEWA8U6oXbLo0qufH7NPElUb+MceHtz54g==", - "dev": true, - "dependencies": { - "@typescript-eslint/typescript-estree": "6.8.0", - "@typescript-eslint/utils": "6.8.0", - "debug": "^4.3.4", - "ts-api-utils": "^1.0.1" - }, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - }, - "peerDependencies": { - "eslint": "^7.0.0 || ^8.0.0" - }, - "peerDependenciesMeta": { - "typescript": { - "optional": true - } - } - }, - "node_modules/@typescript-eslint/types": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/types/-/types-6.8.0.tgz", - "integrity": "sha512-p5qOxSum7W3k+llc7owEStXlGmSl8FcGvhYt8Vjy7FqEnmkCVlM3P57XQEGj58oqaBWDQXbJDZxwUWMS/EAPNQ==", - "dev": true, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - } - }, - "node_modules/@typescript-eslint/typescript-estree": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/typescript-estree/-/typescript-estree-6.8.0.tgz", - "integrity": "sha512-ISgV0lQ8XgW+mvv5My/+iTUdRmGspducmQcDw5JxznasXNnZn3SKNrTRuMsEXv+V/O+Lw9AGcQCfVaOPCAk/Zg==", - "dev": true, - "dependencies": { - "@typescript-eslint/types": "6.8.0", - "@typescript-eslint/visitor-keys": "6.8.0", - "debug": "^4.3.4", - "globby": "^11.1.0", - "is-glob": "^4.0.3", - "semver": "^7.5.4", - "ts-api-utils": "^1.0.1" - }, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - }, - "peerDependenciesMeta": { - "typescript": { - "optional": true - } - } - }, - "node_modules/@typescript-eslint/utils": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/utils/-/utils-6.8.0.tgz", - "integrity": "sha512-dKs1itdE2qFG4jr0dlYLQVppqTE+Itt7GmIf/vX6CSvsW+3ov8PbWauVKyyfNngokhIO9sKZeRGCUo1+N7U98Q==", - "dev": true, - "dependencies": { - "@eslint-community/eslint-utils": "^4.4.0", - "@types/json-schema": "^7.0.12", - "@types/semver": "^7.5.0", - "@typescript-eslint/scope-manager": "6.8.0", - "@typescript-eslint/types": "6.8.0", - "@typescript-eslint/typescript-estree": "6.8.0", - "semver": "^7.5.4" - }, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - }, - "peerDependencies": { - "eslint": "^7.0.0 || ^8.0.0" - } - }, - "node_modules/@typescript-eslint/visitor-keys": { - "version": "6.8.0", - "resolved": "https://registry.npmjs.org/@typescript-eslint/visitor-keys/-/visitor-keys-6.8.0.tgz", - "integrity": "sha512-oqAnbA7c+pgOhW2OhGvxm0t1BULX5peQI/rLsNDpGM78EebV3C9IGbX5HNZabuZ6UQrYveCLjKo8Iy/lLlBkkg==", - "dev": true, - "dependencies": { - "@typescript-eslint/types": "6.8.0", - "eslint-visitor-keys": "^3.4.1" - }, - "engines": { - "node": "^16.0.0 || >=18.0.0" - }, - "funding": { - "type": "opencollective", - "url": "https://opencollective.com/typescript-eslint" - } - }, - "node_modules/acorn": { - "version": "8.10.0", - "resolved": "https://registry.npmjs.org/acorn/-/acorn-8.10.0.tgz", - "integrity": "sha512-F0SAmZ8iUtS//m8DmCTA0jlh6TDKkHQyK6xc6V4KDTyZKA9dnvX9/3sRTVQrWm79glUAZbnmmNcdYwUIHWVybw==", - "dev": true, - "bin": { - "acorn": "bin/acorn" - }, - "engines": { - "node": ">=0.4.0" - } - }, - "node_modules/acorn-jsx": { - "version": "5.3.2", - "resolved": "https://registry.npmjs.org/acorn-jsx/-/acorn-jsx-5.3.2.tgz", - "integrity": "sha512-rq9s+JNhf0IChjtDXxllJ7g41oZk5SlXtp0LHwyA5cejwn7vKmKp4pPri6YEePv2PU65sAsegbXtIinmDFDXgQ==", - "dev": true, - "peerDependencies": { - "acorn": "^6.0.0 || ^7.0.0 || ^8.0.0" - } - }, - "node_modules/ajv": { - "version": "6.12.6", - "resolved": "https://registry.npmjs.org/ajv/-/ajv-6.12.6.tgz", - "integrity": "sha512-j3fVLgvTo527anyYyJOGTYJbG+vnnQYvE0m5mmkc1TK+nxAppkCLMIL0aZ4dblVCNoGShhm+kzE4ZUykBoMg4g==", - "dev": true, - "dependencies": { - "fast-deep-equal": "^3.1.1", - "fast-json-stable-stringify": "^2.0.0", - "json-schema-traverse": "^0.4.1", - "uri-js": "^4.2.2" - }, - "funding": { - "type": "github", - "url": "https://github.com/sponsors/epoberezkin" - } - }, - "node_modules/ansi-regex": { - "version": "5.0.1", - "resolved": "https://registry.npmjs.org/ansi-regex/-/ansi-regex-5.0.1.tgz", - "integrity": "sha512-quJQXlTSUGL2LH9SUXo8VwsY4soanhgo6LNSm84E1LBcE8s3O0wpdiRzyR9z/ZZJMlMWv37qOOb9pdJlMUEKFQ==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/ansi-styles": { - "version": "4.3.0", - "resolved": "https://registry.npmjs.org/ansi-styles/-/ansi-styles-4.3.0.tgz", - "integrity": "sha512-zbB9rCJAT1rbjiVDb2hqKFHNYLxgtk8NURxZ3IZwD3F6NtxbXZQCnnSi1Lkx+IDohdPlFp222wVALIheZJQSEg==", - "dev": true, - "dependencies": { - "color-convert": "^2.0.1" - }, - "engines": { - "node": ">=8" - }, - "funding": { - "url": "https://github.com/chalk/ansi-styles?sponsor=1" - } - }, - "node_modules/argparse": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/argparse/-/argparse-2.0.1.tgz", - "integrity": "sha512-8+9WqebbFzpX9OR+Wa6O29asIogeRMzcGtAINdpMHHyAg10f05aSFVBbcEqGf/PXw1EjAZ+q2/bEBg3DvurK3Q==", - "dev": true - }, - "node_modules/array-union": { - "version": "2.1.0", - "resolved": "https://registry.npmjs.org/array-union/-/array-union-2.1.0.tgz", - "integrity": "sha512-HGyxoOTYUyCM6stUe6EJgnd4EoewAI7zMdfqO+kGjnlZmBDz/cR5pf8r/cR4Wq60sL/p0IkcjUEEPwS3GFrIyw==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/balanced-match": { - "version": "1.0.2", - "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.2.tgz", - "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw==", - "dev": true - }, - "node_modules/brace-expansion": { - "version": "1.1.11", - "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-1.1.11.tgz", - "integrity": "sha512-iCuPHDFgrHX7H2vEI/5xpz07zSHB00TpugqhmYtVmMO6518mCuRMoOYFldEBl0g187ufozdaHgWKcYFb61qGiA==", - "dev": true, - "dependencies": { - "balanced-match": "^1.0.0", - "concat-map": "0.0.1" - } - }, - "node_modules/braces": { - "version": "3.0.2", - "resolved": "https://registry.npmjs.org/braces/-/braces-3.0.2.tgz", - "integrity": "sha512-b8um+L1RzM3WDSzvhm6gIz1yfTbBt6YTlcEKAvsmqCZZFw46z626lVj9j1yEPW33H5H+lBQpZMP1k8l+78Ha0A==", - "dev": true, - "dependencies": { - "fill-range": "^7.0.1" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/callsites": { - "version": "3.1.0", - "resolved": "https://registry.npmjs.org/callsites/-/callsites-3.1.0.tgz", - "integrity": "sha512-P8BjAsXvZS+VIDUI11hHCQEv74YT67YUi5JJFNWIqL235sBmjX4+qx9Muvls5ivyNENctx46xQLQ3aTuE7ssaQ==", - "dev": true, - "engines": { - "node": ">=6" - } - }, - "node_modules/chalk": { - "version": "4.1.2", - "resolved": "https://registry.npmjs.org/chalk/-/chalk-4.1.2.tgz", - "integrity": "sha512-oKnbhFyRIXpUuez8iBMmyEa4nbj4IOQyuhc/wy9kY7/WVPcwIO9VA668Pu8RkO7+0G76SLROeyw9CpQ061i4mA==", - "dev": true, - "dependencies": { - "ansi-styles": "^4.1.0", - "supports-color": "^7.1.0" - }, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/chalk/chalk?sponsor=1" - } - }, - "node_modules/color-convert": { - "version": "2.0.1", - "resolved": "https://registry.npmjs.org/color-convert/-/color-convert-2.0.1.tgz", - "integrity": "sha512-RRECPsj7iu/xb5oKYcsFHSppFNnsj/52OVTRKb4zP5onXwVF3zVmmToNcOfGC+CRDpfK/U584fMg38ZHCaElKQ==", - "dev": true, - "dependencies": { - "color-name": "~1.1.4" - }, - "engines": { - "node": ">=7.0.0" - } - }, - "node_modules/color-name": { - "version": "1.1.4", - "resolved": "https://registry.npmjs.org/color-name/-/color-name-1.1.4.tgz", - "integrity": "sha512-dOy+3AuW3a2wNbZHIuMZpTcgjGuLU/uBL/ubcZF9OXbDo8ff4O8yVp5Bf0efS8uEoYo5q4Fx7dY9OgQGXgAsQA==", - "dev": true - }, - "node_modules/concat-map": { - "version": "0.0.1", - "resolved": "https://registry.npmjs.org/concat-map/-/concat-map-0.0.1.tgz", - "integrity": "sha512-/Srv4dswyQNBfohGpz9o6Yb3Gz3SrUDqBH5rTuhGR7ahtlbYKnVxw2bCFMRljaA7EXHaXZ8wsHdodFvbkhKmqg==", - "dev": true - }, - "node_modules/cross-spawn": { - "version": "7.0.3", - "resolved": "https://registry.npmjs.org/cross-spawn/-/cross-spawn-7.0.3.tgz", - "integrity": "sha512-iRDPJKUPVEND7dHPO8rkbOnPpyDygcDFtWjpeWNCgy8WP2rXcxXL8TskReQl6OrB2G7+UJrags1q15Fudc7G6w==", - "dev": true, - "dependencies": { - "path-key": "^3.1.0", - "shebang-command": "^2.0.0", - "which": "^2.0.1" - }, - "engines": { - "node": ">= 8" - } - }, - "node_modules/csstype": { - "version": "3.1.2", - "resolved": "https://registry.npmjs.org/csstype/-/csstype-3.1.2.tgz", - "integrity": "sha512-I7K1Uu0MBPzaFKg4nI5Q7Vs2t+3gWWW648spaF+Rg7pI9ds18Ugn+lvg4SHczUdKlHI5LWBXyqfS8+DufyBsgQ==", - "dev": true - }, - "node_modules/debug": { - "version": "4.3.4", - "resolved": "https://registry.npmjs.org/debug/-/debug-4.3.4.tgz", - "integrity": "sha512-PRWFHuSU3eDtQJPvnNY7Jcket1j0t5OuOsFzPPzsekD52Zl8qUfFIPEiswXqIvHWGVHOgX+7G/vCNNhehwxfkQ==", - "dev": true, - "dependencies": { - "ms": "2.1.2" - }, - "engines": { - "node": ">=6.0" - }, - "peerDependenciesMeta": { - "supports-color": { - "optional": true - } - } - }, - "node_modules/deep-is": { - "version": "0.1.4", - "resolved": "https://registry.npmjs.org/deep-is/-/deep-is-0.1.4.tgz", - "integrity": "sha512-oIPzksmTg4/MriiaYGO+okXDT7ztn/w3Eptv/+gSIdMdKsJo0u4CfYNFJPy+4SKMuCqGw2wxnA+URMg3t8a/bQ==", - "dev": true - }, - "node_modules/dir-glob": { - "version": "3.0.1", - "resolved": "https://registry.npmjs.org/dir-glob/-/dir-glob-3.0.1.tgz", - "integrity": "sha512-WkrWp9GR4KXfKGYzOLmTuGVi1UWFfws377n9cc55/tb6DuqyF6pcQ5AbiHEshaDpY9v6oaSr2XCDidGmMwdzIA==", - "dev": true, - "dependencies": { - "path-type": "^4.0.0" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/doctrine": { - "version": "3.0.0", - "resolved": "https://registry.npmjs.org/doctrine/-/doctrine-3.0.0.tgz", - "integrity": "sha512-yS+Q5i3hBf7GBkd4KG8a7eBNNWNGLTaEwwYWUijIYM7zrlYDM0BFXHjjPWlWZ1Rg7UaddZeIDmi9jF3HmqiQ2w==", - "dev": true, - "dependencies": { - "esutils": "^2.0.2" - }, - "engines": { - "node": ">=6.0.0" - } - }, - "node_modules/escape-string-regexp": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/escape-string-regexp/-/escape-string-regexp-4.0.0.tgz", - "integrity": "sha512-TtpcNJ3XAzx3Gq8sWRzJaVajRs0uVxA2YAkdb1jm2YkPz4G6egUFAyA3n5vtEIZefPk5Wa4UXbKuS5fKkJWdgA==", - "dev": true, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/eslint": { - "version": "8.51.0", - "resolved": "https://registry.npmjs.org/eslint/-/eslint-8.51.0.tgz", - "integrity": "sha512-2WuxRZBrlwnXi+/vFSJyjMqrNjtJqiasMzehF0shoLaW7DzS3/9Yvrmq5JiT66+pNjiX4UBnLDiKHcWAr/OInA==", - "dev": true, - "dependencies": { - "@eslint-community/eslint-utils": "^4.2.0", - "@eslint-community/regexpp": "^4.6.1", - "@eslint/eslintrc": "^2.1.2", - "@eslint/js": "8.51.0", - "@humanwhocodes/config-array": "^0.11.11", - "@humanwhocodes/module-importer": "^1.0.1", - "@nodelib/fs.walk": "^1.2.8", - "ajv": "^6.12.4", - "chalk": "^4.0.0", - "cross-spawn": "^7.0.2", - "debug": "^4.3.2", - "doctrine": "^3.0.0", - "escape-string-regexp": "^4.0.0", - "eslint-scope": "^7.2.2", - "eslint-visitor-keys": "^3.4.3", - "espree": "^9.6.1", - "esquery": "^1.4.2", - "esutils": "^2.0.2", - "fast-deep-equal": "^3.1.3", - "file-entry-cache": "^6.0.1", - "find-up": "^5.0.0", - "glob-parent": "^6.0.2", - "globals": "^13.19.0", - "graphemer": "^1.4.0", - "ignore": "^5.2.0", - "imurmurhash": "^0.1.4", - "is-glob": "^4.0.0", - "is-path-inside": "^3.0.3", - "js-yaml": "^4.1.0", - "json-stable-stringify-without-jsonify": "^1.0.1", - "levn": "^0.4.1", - "lodash.merge": "^4.6.2", - "minimatch": "^3.1.2", - "natural-compare": "^1.4.0", - "optionator": "^0.9.3", - "strip-ansi": "^6.0.1", - "text-table": "^0.2.0" - }, - "bin": { - "eslint": "bin/eslint.js" - }, - "engines": { - "node": "^12.22.0 || ^14.17.0 || >=16.0.0" - }, - "funding": { - "url": "https://opencollective.com/eslint" - } - }, - "node_modules/eslint-scope": { - "version": "7.2.2", - "resolved": "https://registry.npmjs.org/eslint-scope/-/eslint-scope-7.2.2.tgz", - "integrity": "sha512-dOt21O7lTMhDM+X9mB4GX+DZrZtCUJPL/wlcTqxyrx5IvO0IYtILdtrQGQp+8n5S0gwSVmOf9NQrjMOgfQZlIg==", - "dev": true, - "dependencies": { - "esrecurse": "^4.3.0", - "estraverse": "^5.2.0" - }, - "engines": { - "node": "^12.22.0 || ^14.17.0 || >=16.0.0" - }, - "funding": { - "url": "https://opencollective.com/eslint" - } - }, - "node_modules/eslint-visitor-keys": { - "version": "3.4.3", - "resolved": "https://registry.npmjs.org/eslint-visitor-keys/-/eslint-visitor-keys-3.4.3.tgz", - "integrity": "sha512-wpc+LXeiyiisxPlEkUzU6svyS1frIO3Mgxj1fdy7Pm8Ygzguax2N3Fa/D/ag1WqbOprdI+uY6wMUl8/a2G+iag==", - "dev": true, - "engines": { - "node": "^12.22.0 || ^14.17.0 || >=16.0.0" - }, - "funding": { - "url": "https://opencollective.com/eslint" - } - }, - "node_modules/espree": { - "version": "9.6.1", - "resolved": "https://registry.npmjs.org/espree/-/espree-9.6.1.tgz", - "integrity": "sha512-oruZaFkjorTpF32kDSI5/75ViwGeZginGGy2NoOSg3Q9bnwlnmDm4HLnkl0RE3n+njDXR037aY1+x58Z/zFdwQ==", - "dev": true, - "dependencies": { - "acorn": "^8.9.0", - "acorn-jsx": "^5.3.2", - "eslint-visitor-keys": "^3.4.1" - }, - "engines": { - "node": "^12.22.0 || ^14.17.0 || >=16.0.0" - }, - "funding": { - "url": "https://opencollective.com/eslint" - } - }, - "node_modules/esquery": { - "version": "1.5.0", - "resolved": "https://registry.npmjs.org/esquery/-/esquery-1.5.0.tgz", - "integrity": "sha512-YQLXUplAwJgCydQ78IMJywZCceoqk1oH01OERdSAJc/7U2AylwjhSCLDEtqwg811idIS/9fIU5GjG73IgjKMVg==", - "dev": true, - "dependencies": { - "estraverse": "^5.1.0" - }, - "engines": { - "node": ">=0.10" - } - }, - "node_modules/esrecurse": { - "version": "4.3.0", - "resolved": "https://registry.npmjs.org/esrecurse/-/esrecurse-4.3.0.tgz", - "integrity": "sha512-KmfKL3b6G+RXvP8N1vr3Tq1kL/oCFgn2NYXEtqP8/L3pKapUA4G8cFVaoF3SU323CD4XypR/ffioHmkti6/Tag==", - "dev": true, - "dependencies": { - "estraverse": "^5.2.0" - }, - "engines": { - "node": ">=4.0" - } - }, - "node_modules/estraverse": { - "version": "5.3.0", - "resolved": "https://registry.npmjs.org/estraverse/-/estraverse-5.3.0.tgz", - "integrity": "sha512-MMdARuVEQziNTeJD8DgMqmhwR11BRQ/cBP+pLtYdSTnf3MIO8fFeiINEbX36ZdNlfU/7A9f3gUw49B3oQsvwBA==", - "dev": true, - "engines": { - "node": ">=4.0" - } - }, - "node_modules/esutils": { - "version": "2.0.3", - "resolved": "https://registry.npmjs.org/esutils/-/esutils-2.0.3.tgz", - "integrity": "sha512-kVscqXk4OCp68SZ0dkgEKVi6/8ij300KBWTJq32P/dYeWTSwK41WyTxalN1eRmA5Z9UU/LX9D7FWSmV9SAYx6g==", - "dev": true, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/fast-deep-equal": { - "version": "3.1.3", - "resolved": "https://registry.npmjs.org/fast-deep-equal/-/fast-deep-equal-3.1.3.tgz", - "integrity": "sha512-f3qQ9oQy9j2AhBe/H9VC91wLmKBCCU/gDOnKNAYG5hswO7BLKj09Hc5HYNz9cGI++xlpDCIgDaitVs03ATR84Q==", - "dev": true - }, - "node_modules/fast-glob": { - "version": "3.3.1", - "resolved": "https://registry.npmjs.org/fast-glob/-/fast-glob-3.3.1.tgz", - "integrity": "sha512-kNFPyjhh5cKjrUltxs+wFx+ZkbRaxxmZ+X0ZU31SOsxCEtP9VPgtq2teZw1DebupL5GmDaNQ6yKMMVcM41iqDg==", - "dev": true, - "dependencies": { - "@nodelib/fs.stat": "^2.0.2", - "@nodelib/fs.walk": "^1.2.3", - "glob-parent": "^5.1.2", - "merge2": "^1.3.0", - "micromatch": "^4.0.4" - }, - "engines": { - "node": ">=8.6.0" - } - }, - "node_modules/fast-glob/node_modules/glob-parent": { - "version": "5.1.2", - "resolved": "https://registry.npmjs.org/glob-parent/-/glob-parent-5.1.2.tgz", - "integrity": "sha512-AOIgSQCepiJYwP3ARnGx+5VnTu2HBYdzbGP45eLw1vr3zB3vZLeyed1sC9hnbcOc9/SrMyM5RPQrkGz4aS9Zow==", - "dev": true, - "dependencies": { - "is-glob": "^4.0.1" - }, - "engines": { - "node": ">= 6" - } - }, - "node_modules/fast-json-stable-stringify": { - "version": "2.1.0", - "resolved": "https://registry.npmjs.org/fast-json-stable-stringify/-/fast-json-stable-stringify-2.1.0.tgz", - "integrity": "sha512-lhd/wF+Lk98HZoTCtlVraHtfh5XYijIjalXck7saUtuanSDyLMxnHhSXEDJqHxD7msR8D0uCmqlkwjCV8xvwHw==", - "dev": true - }, - "node_modules/fast-levenshtein": { - "version": "2.0.6", - "resolved": "https://registry.npmjs.org/fast-levenshtein/-/fast-levenshtein-2.0.6.tgz", - "integrity": "sha512-DCXu6Ifhqcks7TZKY3Hxp3y6qphY5SJZmrWMDrKcERSOXWQdMhU9Ig/PYrzyw/ul9jOIyh0N4M0tbC5hodg8dw==", - "dev": true - }, - "node_modules/fastq": { - "version": "1.15.0", - "resolved": "https://registry.npmjs.org/fastq/-/fastq-1.15.0.tgz", - "integrity": "sha512-wBrocU2LCXXa+lWBt8RoIRD89Fi8OdABODa/kEnyeyjS5aZO5/GNvI5sEINADqP/h8M29UHTHUb53sUu5Ihqdw==", - "dev": true, - "dependencies": { - "reusify": "^1.0.4" - } - }, - "node_modules/file-entry-cache": { - "version": "6.0.1", - "resolved": "https://registry.npmjs.org/file-entry-cache/-/file-entry-cache-6.0.1.tgz", - "integrity": "sha512-7Gps/XWymbLk2QLYK4NzpMOrYjMhdIxXuIvy2QBsLE6ljuodKvdkWs/cpyJJ3CVIVpH0Oi1Hvg1ovbMzLdFBBg==", - "dev": true, - "dependencies": { - "flat-cache": "^3.0.4" - }, - "engines": { - "node": "^10.12.0 || >=12.0.0" - } - }, - "node_modules/fill-range": { - "version": "7.0.1", - "resolved": "https://registry.npmjs.org/fill-range/-/fill-range-7.0.1.tgz", - "integrity": "sha512-qOo9F+dMUmC2Lcb4BbVvnKJxTPjCm+RRpe4gDuGrzkL7mEVl/djYSu2OdQ2Pa302N4oqkSg9ir6jaLWJ2USVpQ==", - "dev": true, - "dependencies": { - "to-regex-range": "^5.0.1" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/find-up": { - "version": "5.0.0", - "resolved": "https://registry.npmjs.org/find-up/-/find-up-5.0.0.tgz", - "integrity": "sha512-78/PXT1wlLLDgTzDs7sjq9hzz0vXD+zn+7wypEe4fXQxCmdmqfGsEPQxmiCSQI3ajFV91bVSsvNtrJRiW6nGng==", - "dev": true, - "dependencies": { - "locate-path": "^6.0.0", - "path-exists": "^4.0.0" - }, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/flat-cache": { - "version": "3.1.1", - "resolved": "https://registry.npmjs.org/flat-cache/-/flat-cache-3.1.1.tgz", - "integrity": "sha512-/qM2b3LUIaIgviBQovTLvijfyOQXPtSRnRK26ksj2J7rzPIecePUIpJsZ4T02Qg+xiAEKIs5K8dsHEd+VaKa/Q==", - "dev": true, - "dependencies": { - "flatted": "^3.2.9", - "keyv": "^4.5.3", - "rimraf": "^3.0.2" - }, - "engines": { - "node": ">=12.0.0" - } - }, - "node_modules/flatted": { - "version": "3.2.9", - "resolved": "https://registry.npmjs.org/flatted/-/flatted-3.2.9.tgz", - "integrity": "sha512-36yxDn5H7OFZQla0/jFJmbIKTdZAQHngCedGxiMmpNfEZM0sdEeT+WczLQrjK6D7o2aiyLYDnkw0R3JK0Qv1RQ==", - "dev": true - }, - "node_modules/fs.realpath": { - "version": "1.0.0", - "resolved": "https://registry.npmjs.org/fs.realpath/-/fs.realpath-1.0.0.tgz", - "integrity": "sha512-OO0pH2lK6a0hZnAdau5ItzHPI6pUlvI7jMVnxUQRtw4owF2wk8lOSabtGDCTP4Ggrg2MbGnWO9X8K1t4+fGMDw==", - "dev": true - }, - "node_modules/glob": { - "version": "7.2.3", - "resolved": "https://registry.npmjs.org/glob/-/glob-7.2.3.tgz", - "integrity": "sha512-nFR0zLpU2YCaRxwoCJvL6UvCH2JFyFVIvwTLsIf21AuHlMskA1hhTdk+LlYJtOlYt9v6dvszD2BGRqBL+iQK9Q==", - "dev": true, - "dependencies": { - "fs.realpath": "^1.0.0", - "inflight": "^1.0.4", - "inherits": "2", - "minimatch": "^3.1.1", - "once": "^1.3.0", - "path-is-absolute": "^1.0.0" - }, - "engines": { - "node": "*" - }, - "funding": { - "url": "https://github.com/sponsors/isaacs" - } - }, - "node_modules/glob-parent": { - "version": "6.0.2", - "resolved": "https://registry.npmjs.org/glob-parent/-/glob-parent-6.0.2.tgz", - "integrity": "sha512-XxwI8EOhVQgWp6iDL+3b0r86f4d6AX6zSU55HfB4ydCEuXLXc5FcYeOu+nnGftS4TEju/11rt4KJPTMgbfmv4A==", - "dev": true, - "dependencies": { - "is-glob": "^4.0.3" - }, - "engines": { - "node": ">=10.13.0" - } - }, - "node_modules/globals": { - "version": "13.23.0", - "resolved": "https://registry.npmjs.org/globals/-/globals-13.23.0.tgz", - "integrity": "sha512-XAmF0RjlrjY23MA51q3HltdlGxUpXPvg0GioKiD9X6HD28iMjo2dKC8Vqwm7lne4GNr78+RHTfliktR6ZH09wA==", - "dev": true, - "dependencies": { - "type-fest": "^0.20.2" - }, - "engines": { - "node": ">=8" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/globby": { - "version": "11.1.0", - "resolved": "https://registry.npmjs.org/globby/-/globby-11.1.0.tgz", - "integrity": "sha512-jhIXaOzy1sb8IyocaruWSn1TjmnBVs8Ayhcy83rmxNJ8q2uWKCAj3CnJY+KpGSXCueAPc0i05kVvVKtP1t9S3g==", - "dev": true, - "dependencies": { - "array-union": "^2.1.0", - "dir-glob": "^3.0.1", - "fast-glob": "^3.2.9", - "ignore": "^5.2.0", - "merge2": "^1.4.1", - "slash": "^3.0.0" - }, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/graphemer": { - "version": "1.4.0", - "resolved": "https://registry.npmjs.org/graphemer/-/graphemer-1.4.0.tgz", - "integrity": "sha512-EtKwoO6kxCL9WO5xipiHTZlSzBm7WLT627TqC/uVRd0HKmq8NXyebnNYxDoBi7wt8eTWrUrKXCOVaFq9x1kgag==", - "dev": true - }, - "node_modules/has-flag": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/has-flag/-/has-flag-4.0.0.tgz", - "integrity": "sha512-EykJT/Q1KjTWctppgIAgfSO0tKVuZUjhgMr17kqTumMl6Afv3EISleU7qZUzoXDFTAHTDC4NOoG/ZxU3EvlMPQ==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/ignore": { - "version": "5.2.4", - "resolved": "https://registry.npmjs.org/ignore/-/ignore-5.2.4.tgz", - "integrity": "sha512-MAb38BcSbH0eHNBxn7ql2NH/kX33OkB3lZ1BNdh7ENeRChHTYsTvWrMubiIAMNS2llXEEgZ1MUOBtXChP3kaFQ==", - "dev": true, - "engines": { - "node": ">= 4" - } - }, - "node_modules/import-fresh": { - "version": "3.3.0", - "resolved": "https://registry.npmjs.org/import-fresh/-/import-fresh-3.3.0.tgz", - "integrity": "sha512-veYYhQa+D1QBKznvhUHxb8faxlrwUnxseDAbAp457E0wLNio2bOSKnjYDhMj+YiAq61xrMGhQk9iXVk5FzgQMw==", - "dev": true, - "dependencies": { - "parent-module": "^1.0.0", - "resolve-from": "^4.0.0" - }, - "engines": { - "node": ">=6" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/imurmurhash": { - "version": "0.1.4", - "resolved": "https://registry.npmjs.org/imurmurhash/-/imurmurhash-0.1.4.tgz", - "integrity": "sha512-JmXMZ6wuvDmLiHEml9ykzqO6lwFbof0GG4IkcGaENdCRDDmMVnny7s5HsIgHCbaq0w2MyPhDqkhTUgS2LU2PHA==", - "dev": true, - "engines": { - "node": ">=0.8.19" - } - }, - "node_modules/inflight": { - "version": "1.0.6", - "resolved": "https://registry.npmjs.org/inflight/-/inflight-1.0.6.tgz", - "integrity": "sha512-k92I/b08q4wvFscXCLvqfsHCrjrF7yiXsQuIVvVE7N82W3+aqpzuUdBbfhWcy/FZR3/4IgflMgKLOsvPDrGCJA==", - "dev": true, - "dependencies": { - "once": "^1.3.0", - "wrappy": "1" - } - }, - "node_modules/inherits": { - "version": "2.0.4", - "resolved": "https://registry.npmjs.org/inherits/-/inherits-2.0.4.tgz", - "integrity": "sha512-k/vGaX4/Yla3WzyMCvTQOXYeIHvqOKtnqBduzTHpzpQZzAskKMhZ2K+EnBiSM9zGSoIFeMpXKxa4dYeZIQqewQ==", - "dev": true - }, - "node_modules/is-extglob": { - "version": "2.1.1", - "resolved": "https://registry.npmjs.org/is-extglob/-/is-extglob-2.1.1.tgz", - "integrity": "sha512-SbKbANkN603Vi4jEZv49LeVJMn4yGwsbzZworEoyEiutsN3nJYdbO36zfhGJ6QEDpOZIFkDtnq5JRxmvl3jsoQ==", - "dev": true, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/is-glob": { - "version": "4.0.3", - "resolved": "https://registry.npmjs.org/is-glob/-/is-glob-4.0.3.tgz", - "integrity": "sha512-xelSayHH36ZgE7ZWhli7pW34hNbNl8Ojv5KVmkJD4hBdD3th8Tfk9vYasLM+mXWOZhFkgZfxhLSnrwRr4elSSg==", - "dev": true, - "dependencies": { - "is-extglob": "^2.1.1" - }, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/is-number": { - "version": "7.0.0", - "resolved": "https://registry.npmjs.org/is-number/-/is-number-7.0.0.tgz", - "integrity": "sha512-41Cifkg6e8TylSpdtTpeLVMqvSBEVzTttHvERD741+pnZ8ANv0004MRL43QKPDlK9cGvNp6NZWZUBlbGXYxxng==", - "dev": true, - "engines": { - "node": ">=0.12.0" - } - }, - "node_modules/is-path-inside": { - "version": "3.0.3", - "resolved": "https://registry.npmjs.org/is-path-inside/-/is-path-inside-3.0.3.tgz", - "integrity": "sha512-Fd4gABb+ycGAmKou8eMftCupSir5lRxqf4aD/vd0cD2qc4HL07OjCeuHMr8Ro4CoMaeCKDB0/ECBOVWjTwUvPQ==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/isexe": { - "version": "2.0.0", - "resolved": "https://registry.npmjs.org/isexe/-/isexe-2.0.0.tgz", - "integrity": "sha512-RHxMLp9lnKHGHRng9QFhRCMbYAcVpn69smSGcq3f36xjgVVWThj4qqLbTLlq7Ssj8B+fIQ1EuCEGI2lKsyQeIw==", - "dev": true - }, - "node_modules/js-tokens": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/js-tokens/-/js-tokens-4.0.0.tgz", - "integrity": "sha512-RdJUflcE3cUzKiMqQgsCu06FPu9UdIJO0beYbPhHN4k6apgJtifcoCtT9bcxOpYBtpD2kCM6Sbzg4CausW/PKQ==" - }, - "node_modules/js-yaml": { - "version": "4.1.0", - "resolved": "https://registry.npmjs.org/js-yaml/-/js-yaml-4.1.0.tgz", - "integrity": "sha512-wpxZs9NoxZaJESJGIZTyDEaYpl0FKSA+FB9aJiyemKhMwkxQg63h4T1KJgUGHpTqPDNRcmmYLugrRjJlBtWvRA==", - "dev": true, - "dependencies": { - "argparse": "^2.0.1" - }, - "bin": { - "js-yaml": "bin/js-yaml.js" - } - }, - "node_modules/json-buffer": { - "version": "3.0.1", - "resolved": "https://registry.npmjs.org/json-buffer/-/json-buffer-3.0.1.tgz", - "integrity": "sha512-4bV5BfR2mqfQTJm+V5tPPdf+ZpuhiIvTuAB5g8kcrXOZpTT/QwwVRWBywX1ozr6lEuPdbHxwaJlm9G6mI2sfSQ==", - "dev": true - }, - "node_modules/json-schema-traverse": { - "version": "0.4.1", - "resolved": "https://registry.npmjs.org/json-schema-traverse/-/json-schema-traverse-0.4.1.tgz", - "integrity": "sha512-xbbCH5dCYU5T8LcEhhuh7HJ88HXuW3qsI3Y0zOZFKfZEHcpWiHU/Jxzk629Brsab/mMiHQti9wMP+845RPe3Vg==", - "dev": true - }, - "node_modules/json-stable-stringify-without-jsonify": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/json-stable-stringify-without-jsonify/-/json-stable-stringify-without-jsonify-1.0.1.tgz", - "integrity": "sha512-Bdboy+l7tA3OGW6FjyFHWkP5LuByj1Tk33Ljyq0axyzdk9//JSi2u3fP1QSmd1KNwq6VOKYGlAu87CisVir6Pw==", - "dev": true - }, - "node_modules/keyv": { - "version": "4.5.4", - "resolved": "https://registry.npmjs.org/keyv/-/keyv-4.5.4.tgz", - "integrity": "sha512-oxVHkHR/EJf2CNXnWxRLW6mg7JyCCUcG0DtEGmL2ctUo1PNTin1PUil+r/+4r5MpVgC/fn1kjsx7mjSujKqIpw==", - "dev": true, - "dependencies": { - "json-buffer": "3.0.1" - } - }, - "node_modules/levn": { - "version": "0.4.1", - "resolved": "https://registry.npmjs.org/levn/-/levn-0.4.1.tgz", - "integrity": "sha512-+bT2uH4E5LGE7h/n3evcS/sQlJXCpIp6ym8OWJ5eV6+67Dsql/LaaT7qJBAt2rzfoa/5QBGBhxDix1dMt2kQKQ==", - "dev": true, - "dependencies": { - "prelude-ls": "^1.2.1", - "type-check": "~0.4.0" - }, - "engines": { - "node": ">= 0.8.0" - } - }, - "node_modules/locate-path": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/locate-path/-/locate-path-6.0.0.tgz", - "integrity": "sha512-iPZK6eYjbxRu3uB4/WZ3EsEIMJFMqAoopl3R+zuq0UjcAm/MO6KCweDgPfP3elTztoKP3KtnVHxTn2NHBSDVUw==", - "dev": true, - "dependencies": { - "p-locate": "^5.0.0" - }, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/lodash.merge": { - "version": "4.6.2", - "resolved": "https://registry.npmjs.org/lodash.merge/-/lodash.merge-4.6.2.tgz", - "integrity": "sha512-0KpjqXRVvrYyCsX1swR/XTK0va6VQkQM6MNo7PqW77ByjAhoARA8EfrP1N4+KlKj8YS0ZUCtRT/YUuhyYDujIQ==", - "dev": true - }, - "node_modules/loose-envify": { - "version": "1.4.0", - "resolved": "https://registry.npmjs.org/loose-envify/-/loose-envify-1.4.0.tgz", - "integrity": "sha512-lyuxPGr/Wfhrlem2CL/UcnUc1zcqKAImBDzukY7Y5F/yQiNdko6+fRLevlw1HgMySw7f611UIY408EtxRSoK3Q==", - "dependencies": { - "js-tokens": "^3.0.0 || ^4.0.0" - }, - "bin": { - "loose-envify": "cli.js" - } - }, - "node_modules/lru-cache": { - "version": "6.0.0", - "resolved": "https://registry.npmjs.org/lru-cache/-/lru-cache-6.0.0.tgz", - "integrity": "sha512-Jo6dJ04CmSjuznwJSS3pUeWmd/H0ffTlkXXgwZi+eq1UCmqQwCh+eLsYOYCwY991i2Fah4h1BEMCx4qThGbsiA==", - "dev": true, - "dependencies": { - "yallist": "^4.0.0" - }, - "engines": { - "node": ">=10" - } - }, - "node_modules/merge2": { - "version": "1.4.1", - "resolved": "https://registry.npmjs.org/merge2/-/merge2-1.4.1.tgz", - "integrity": "sha512-8q7VEgMJW4J8tcfVPy8g09NcQwZdbwFEqhe/WZkoIzjn/3TGDwtOCYtXGxA3O8tPzpczCCDgv+P2P5y00ZJOOg==", - "dev": true, - "engines": { - "node": ">= 8" - } - }, - "node_modules/micromatch": { - "version": "4.0.5", - "resolved": "https://registry.npmjs.org/micromatch/-/micromatch-4.0.5.tgz", - "integrity": "sha512-DMy+ERcEW2q8Z2Po+WNXuw3c5YaUSFjAO5GsJqfEl7UjvtIuFKO6ZrKvcItdy98dwFI2N1tg3zNIdKaQT+aNdA==", - "dev": true, - "dependencies": { - "braces": "^3.0.2", - "picomatch": "^2.3.1" - }, - "engines": { - "node": ">=8.6" - } - }, - "node_modules/minimatch": { - "version": "3.1.2", - "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-3.1.2.tgz", - "integrity": "sha512-J7p63hRiAjw1NDEww1W7i37+ByIrOWO5XQQAzZ3VOcL0PNybwpfmV/N05zFAzwQ9USyEcX6t3UO+K5aqBQOIHw==", - "dev": true, - "dependencies": { - "brace-expansion": "^1.1.7" - }, - "engines": { - "node": "*" - } - }, - "node_modules/ms": { - "version": "2.1.2", - "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.2.tgz", - "integrity": "sha512-sGkPx+VjMtmA6MX27oA4FBFELFCZZ4S4XqeGOXCv68tT+jb3vk/RyaKWP0PTKyWtmLSM0b+adUTEvbs1PEaH2w==", - "dev": true - }, - "node_modules/natural-compare": { - "version": "1.4.0", - "resolved": "https://registry.npmjs.org/natural-compare/-/natural-compare-1.4.0.tgz", - "integrity": "sha512-OWND8ei3VtNC9h7V60qff3SVobHr996CTwgxubgyQYEpg290h9J0buyECNNJexkFm5sOajh5G116RYA1c8ZMSw==", - "dev": true - }, - "node_modules/once": { - "version": "1.4.0", - "resolved": "https://registry.npmjs.org/once/-/once-1.4.0.tgz", - "integrity": "sha512-lNaJgI+2Q5URQBkccEKHTQOPaXdUxnZZElQTZY0MFUAuaEqe1E+Nyvgdz/aIyNi6Z9MzO5dv1H8n58/GELp3+w==", - "dev": true, - "dependencies": { - "wrappy": "1" - } - }, - "node_modules/optionator": { - "version": "0.9.3", - "resolved": "https://registry.npmjs.org/optionator/-/optionator-0.9.3.tgz", - "integrity": "sha512-JjCoypp+jKn1ttEFExxhetCKeJt9zhAgAve5FXHixTvFDW/5aEktX9bufBKLRRMdU7bNtpLfcGu94B3cdEJgjg==", - "dev": true, - "dependencies": { - "@aashutoshrathi/word-wrap": "^1.2.3", - "deep-is": "^0.1.3", - "fast-levenshtein": "^2.0.6", - "levn": "^0.4.1", - "prelude-ls": "^1.2.1", - "type-check": "^0.4.0" - }, - "engines": { - "node": ">= 0.8.0" - } - }, - "node_modules/p-limit": { - "version": "3.1.0", - "resolved": "https://registry.npmjs.org/p-limit/-/p-limit-3.1.0.tgz", - "integrity": "sha512-TYOanM3wGwNGsZN2cVTYPArw454xnXj5qmWF1bEoAc4+cU/ol7GVh7odevjp1FNHduHc3KZMcFduxU5Xc6uJRQ==", - "dev": true, - "dependencies": { - "yocto-queue": "^0.1.0" - }, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/p-locate": { - "version": "5.0.0", - "resolved": "https://registry.npmjs.org/p-locate/-/p-locate-5.0.0.tgz", - "integrity": "sha512-LaNjtRWUBY++zB5nE/NwcaoMylSPk+S+ZHNB1TzdbMJMny6dynpAGt7X/tl/QYq3TIeE6nxHppbo2LGymrG5Pw==", - "dev": true, - "dependencies": { - "p-limit": "^3.0.2" - }, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/parent-module": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/parent-module/-/parent-module-1.0.1.tgz", - "integrity": "sha512-GQ2EWRpQV8/o+Aw8YqtfZZPfNRWZYkbidE9k5rpl/hC3vtHHBfGm2Ifi6qWV+coDGkrUKZAxE3Lot5kcsRlh+g==", - "dev": true, - "dependencies": { - "callsites": "^3.0.0" - }, - "engines": { - "node": ">=6" - } - }, - "node_modules/path-exists": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/path-exists/-/path-exists-4.0.0.tgz", - "integrity": "sha512-ak9Qy5Q7jYb2Wwcey5Fpvg2KoAc/ZIhLSLOSBmRmygPsGwkVVt0fZa0qrtMz+m6tJTAHfZQ8FnmB4MG4LWy7/w==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/path-is-absolute": { - "version": "1.0.1", - "resolved": "https://registry.npmjs.org/path-is-absolute/-/path-is-absolute-1.0.1.tgz", - "integrity": "sha512-AVbw3UJ2e9bq64vSaS9Am0fje1Pa8pbGqTTsmXfaIiMpnr5DlDhfJOuLj9Sf95ZPVDAUerDfEk88MPmPe7UCQg==", - "dev": true, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/path-key": { - "version": "3.1.1", - "resolved": "https://registry.npmjs.org/path-key/-/path-key-3.1.1.tgz", - "integrity": "sha512-ojmeN0qd+y0jszEtoY48r0Peq5dwMEkIlCOu6Q5f41lfkswXuKtYrhgoTpLnyIcHm24Uhqx+5Tqm2InSwLhE6Q==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/path-type": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/path-type/-/path-type-4.0.0.tgz", - "integrity": "sha512-gDKb8aZMDeD/tZWs9P6+q0J9Mwkdl6xMV8TjnGP3qJVJ06bdMgkbBlLU8IdfOsIsFz2BW1rNVT3XuNEl8zPAvw==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/picomatch": { - "version": "2.3.1", - "resolved": "https://registry.npmjs.org/picomatch/-/picomatch-2.3.1.tgz", - "integrity": "sha512-JU3teHTNjmE2VCGFzuY8EXzCDVwEqB2a8fsIvwaStHhAWJEeVd1o1QD80CU6+ZdEXXSLbSsuLwJjkCBWqRQUVA==", - "dev": true, - "engines": { - "node": ">=8.6" - }, - "funding": { - "url": "https://github.com/sponsors/jonschlinkert" - } - }, - "node_modules/prelude-ls": { - "version": "1.2.1", - "resolved": "https://registry.npmjs.org/prelude-ls/-/prelude-ls-1.2.1.tgz", - "integrity": "sha512-vkcDPrRZo1QZLbn5RLGPpg/WmIQ65qoWWhcGKf/b5eplkkarX0m9z8ppCat4mlOqUsWpyNuYgO3VRyrYHSzX5g==", - "dev": true, - "engines": { - "node": ">= 0.8.0" - } - }, - "node_modules/punycode": { - "version": "2.3.0", - "resolved": "https://registry.npmjs.org/punycode/-/punycode-2.3.0.tgz", - "integrity": "sha512-rRV+zQD8tVFys26lAGR9WUuS4iUAngJScM+ZRSKtvl5tKeZ2t5bvdNFdNHBW9FWR4guGHlgmsZ1G7BSm2wTbuA==", - "dev": true, - "engines": { - "node": ">=6" - } - }, - "node_modules/queue-microtask": { - "version": "1.2.3", - "resolved": "https://registry.npmjs.org/queue-microtask/-/queue-microtask-1.2.3.tgz", - "integrity": "sha512-NuaNSa6flKT5JaSYQzJok04JzTL1CA6aGhv5rfLW3PgqA+M2ChpZQnAC8h8i4ZFkBS8X5RqkDBHA7r4hej3K9A==", - "dev": true, - "funding": [ - { - "type": "github", - "url": "https://github.com/sponsors/feross" - }, - { - "type": "patreon", - "url": "https://www.patreon.com/feross" - }, - { - "type": "consulting", - "url": "https://feross.org/support" - } - ] - }, - "node_modules/react": { - "version": "18.2.0", - "resolved": "https://registry.npmjs.org/react/-/react-18.2.0.tgz", - "integrity": "sha512-/3IjMdb2L9QbBdWiW5e3P2/npwMBaU9mHCSCUzNln0ZCYbcfTsGbTJrU/kGemdH2IWmB2ioZ+zkxtmq6g09fGQ==", - "dependencies": { - "loose-envify": "^1.1.0" - }, - "engines": { - "node": ">=0.10.0" - } - }, - "node_modules/react-dom": { - "version": "18.2.0", - "resolved": "https://registry.npmjs.org/react-dom/-/react-dom-18.2.0.tgz", - "integrity": "sha512-6IMTriUmvsjHUjNtEDudZfuDQUoWXVxKHhlEGSk81n4YFS+r/Kl99wXiwlVXtPBtJenozv2P+hxDsw9eA7Xo6g==", - "dependencies": { - "loose-envify": "^1.1.0", - "scheduler": "^0.23.0" - }, - "peerDependencies": { - "react": "^18.2.0" - } - }, - "node_modules/rescript": { - "resolved": "../../..", - "link": true - }, - "node_modules/resolve-from": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/resolve-from/-/resolve-from-4.0.0.tgz", - "integrity": "sha512-pb/MYmXstAkysRFx8piNI1tGFNQIFA3vkE3Gq4EuA1dF6gHp/+vgZqsCGJapvy8N3Q+4o7FwvquPJcnZ7RYy4g==", - "dev": true, - "engines": { - "node": ">=4" - } - }, - "node_modules/reusify": { - "version": "1.0.4", - "resolved": "https://registry.npmjs.org/reusify/-/reusify-1.0.4.tgz", - "integrity": "sha512-U9nH88a3fc/ekCF1l0/UP1IosiuIjyTh7hBvXVMHYgVcfGvt897Xguj2UOLDeI5BG2m7/uwyaLVT6fbtCwTyzw==", - "dev": true, - "engines": { - "iojs": ">=1.0.0", - "node": ">=0.10.0" - } - }, - "node_modules/rimraf": { - "version": "3.0.2", - "resolved": "https://registry.npmjs.org/rimraf/-/rimraf-3.0.2.tgz", - "integrity": "sha512-JZkJMZkAGFFPP2YqXZXPbMlMBgsxzE8ILs4lMIX/2o0L9UBw9O/Y3o6wFw/i9YLapcUJWwqbi3kdxIPdC62TIA==", - "dev": true, - "dependencies": { - "glob": "^7.1.3" - }, - "bin": { - "rimraf": "bin.js" - }, - "funding": { - "url": "https://github.com/sponsors/isaacs" - } - }, - "node_modules/run-parallel": { - "version": "1.2.0", - "resolved": "https://registry.npmjs.org/run-parallel/-/run-parallel-1.2.0.tgz", - "integrity": "sha512-5l4VyZR86LZ/lDxZTR6jqL8AFE2S0IFLMP26AbjsLVADxHdhB/c0GUsH+y39UfCi3dzz8OlQuPmnaJOMoDHQBA==", - "dev": true, - "funding": [ - { - "type": "github", - "url": "https://github.com/sponsors/feross" - }, - { - "type": "patreon", - "url": "https://www.patreon.com/feross" - }, - { - "type": "consulting", - "url": "https://feross.org/support" - } - ], - "dependencies": { - "queue-microtask": "^1.2.2" - } - }, - "node_modules/scheduler": { - "version": "0.23.0", - "resolved": "https://registry.npmjs.org/scheduler/-/scheduler-0.23.0.tgz", - "integrity": "sha512-CtuThmgHNg7zIZWAXi3AsyIzA3n4xx7aNyjwC2VJldO2LMVDhFK+63xGqq6CsJH4rTAt6/M+N4GhZiDYPx9eUw==", - "dependencies": { - "loose-envify": "^1.1.0" - } - }, - "node_modules/semver": { - "version": "7.5.4", - "resolved": "https://registry.npmjs.org/semver/-/semver-7.5.4.tgz", - "integrity": "sha512-1bCSESV6Pv+i21Hvpxp3Dx+pSD8lIPt8uVjRrxAUt/nbswYc+tK6Y2btiULjd4+fnq15PX+nqQDC7Oft7WkwcA==", - "dev": true, - "dependencies": { - "lru-cache": "^6.0.0" - }, - "bin": { - "semver": "bin/semver.js" - }, - "engines": { - "node": ">=10" - } - }, - "node_modules/shebang-command": { - "version": "2.0.0", - "resolved": "https://registry.npmjs.org/shebang-command/-/shebang-command-2.0.0.tgz", - "integrity": "sha512-kHxr2zZpYtdmrN1qDjrrX/Z1rR1kG8Dx+gkpK1G4eXmvXswmcE1hTWBWYUzlraYw1/yZp6YuDY77YtvbN0dmDA==", - "dev": true, - "dependencies": { - "shebang-regex": "^3.0.0" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/shebang-regex": { - "version": "3.0.0", - "resolved": "https://registry.npmjs.org/shebang-regex/-/shebang-regex-3.0.0.tgz", - "integrity": "sha512-7++dFhtcx3353uBaq8DDR4NuxBetBzC7ZQOhmTQInHEd6bSrXdiEyzCvG07Z44UYdLShWUyXt5M/yhz8ekcb1A==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/slash": { - "version": "3.0.0", - "resolved": "https://registry.npmjs.org/slash/-/slash-3.0.0.tgz", - "integrity": "sha512-g9Q1haeby36OSStwb4ntCGGGaKsaVSjQ68fBxoQcutl5fS1vuY18H3wSt3jFyFtrkx+Kz0V1G85A4MyAdDMi2Q==", - "dev": true, - "engines": { - "node": ">=8" - } - }, - "node_modules/strip-ansi": { - "version": "6.0.1", - "resolved": "https://registry.npmjs.org/strip-ansi/-/strip-ansi-6.0.1.tgz", - "integrity": "sha512-Y38VPSHcqkFrCpFnQ9vuSXmquuv5oXOKpGeT6aGrr3o3Gc9AlVa6JBfUSOCnbxGGZF+/0ooI7KrPuUSztUdU5A==", - "dev": true, - "dependencies": { - "ansi-regex": "^5.0.1" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/strip-json-comments": { - "version": "3.1.1", - "resolved": "https://registry.npmjs.org/strip-json-comments/-/strip-json-comments-3.1.1.tgz", - "integrity": "sha512-6fPc+R4ihwqP6N/aIv2f1gMH8lOVtWQHoqC4yK6oSDVVocumAsfCqjkXnqiYMhmMwS/mEHLp7Vehlt3ql6lEig==", - "dev": true, - "engines": { - "node": ">=8" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/supports-color": { - "version": "7.2.0", - "resolved": "https://registry.npmjs.org/supports-color/-/supports-color-7.2.0.tgz", - "integrity": "sha512-qpCAvRl9stuOHveKsn7HncJRvv501qIacKzQlO/+Lwxc9+0q2wLyv4Dfvt80/DPn2pqOBsJdDiogXGR9+OvwRw==", - "dev": true, - "dependencies": { - "has-flag": "^4.0.0" - }, - "engines": { - "node": ">=8" - } - }, - "node_modules/text-table": { - "version": "0.2.0", - "resolved": "https://registry.npmjs.org/text-table/-/text-table-0.2.0.tgz", - "integrity": "sha512-N+8UisAXDGk8PFXP4HAzVR9nbfmVJ3zYLAWiTIoqC5v5isinhr+r5uaO8+7r3BMfuNIufIsA7RdpVgacC2cSpw==", - "dev": true - }, - "node_modules/to-regex-range": { - "version": "5.0.1", - "resolved": "https://registry.npmjs.org/to-regex-range/-/to-regex-range-5.0.1.tgz", - "integrity": "sha512-65P7iz6X5yEr1cwcgvQxbbIw7Uk3gOy5dIdtZ4rDveLqhrdJP+Li/Hx6tyK0NEb+2GCyneCMJiGqrADCSNk8sQ==", - "dev": true, - "dependencies": { - "is-number": "^7.0.0" - }, - "engines": { - "node": ">=8.0" - } - }, - "node_modules/ts-api-utils": { - "version": "1.0.3", - "resolved": "https://registry.npmjs.org/ts-api-utils/-/ts-api-utils-1.0.3.tgz", - "integrity": "sha512-wNMeqtMz5NtwpT/UZGY5alT+VoKdSsOOP/kqHFcUW1P/VRhH2wJ48+DN2WwUliNbQ976ETwDL0Ifd2VVvgonvg==", - "dev": true, - "engines": { - "node": ">=16.13.0" - }, - "peerDependencies": { - "typescript": ">=4.2.0" - } - }, - "node_modules/type-check": { - "version": "0.4.0", - "resolved": "https://registry.npmjs.org/type-check/-/type-check-0.4.0.tgz", - "integrity": "sha512-XleUoc9uwGXqjWwXaUTZAmzMcFZ5858QA2vvx1Ur5xIcixXIP+8LnFDgRplU30us6teqdlskFfu+ae4K79Ooew==", - "dev": true, - "dependencies": { - "prelude-ls": "^1.2.1" - }, - "engines": { - "node": ">= 0.8.0" - } - }, - "node_modules/type-fest": { - "version": "0.20.2", - "resolved": "https://registry.npmjs.org/type-fest/-/type-fest-0.20.2.tgz", - "integrity": "sha512-Ne+eE4r0/iWnpAxD852z3A+N0Bt5RN//NjJwRd2VFHEmrywxf5vsZlh4R6lixl6B+wz/8d+maTSAkN1FIkI3LQ==", - "dev": true, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - }, - "node_modules/typescript": { - "version": "5.2.2", - "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.2.2.tgz", - "integrity": "sha512-mI4WrpHsbCIcwT9cF4FZvr80QUeKvsUsUvKDoR+X/7XHQH98xYD8YHZg7ANtz2GtZt/CBq2QJ0thkGJMHfqc1w==", - "dev": true, - "bin": { - "tsc": "bin/tsc", - "tsserver": "bin/tsserver" - }, - "engines": { - "node": ">=14.17" - } - }, - "node_modules/uri-js": { - "version": "4.4.1", - "resolved": "https://registry.npmjs.org/uri-js/-/uri-js-4.4.1.tgz", - "integrity": "sha512-7rKUyy33Q1yc98pQ1DAmLtwX109F7TIfWlW1Ydo8Wl1ii1SeHieeh0HHfPeL2fMXK6z0s8ecKs9frCuLJvndBg==", - "dev": true, - "dependencies": { - "punycode": "^2.1.0" - } - }, - "node_modules/which": { - "version": "2.0.2", - "resolved": "https://registry.npmjs.org/which/-/which-2.0.2.tgz", - "integrity": "sha512-BLI3Tl1TW3Pvl70l3yq3Y64i+awpwXqsGBYWkkqMtnbXgrMD+yj7rhW0kuEDxzJaYXGjEW5ogapKNMEKNMjibA==", - "dev": true, - "dependencies": { - "isexe": "^2.0.0" - }, - "bin": { - "node-which": "bin/node-which" - }, - "engines": { - "node": ">= 8" - } - }, - "node_modules/wrappy": { - "version": "1.0.2", - "resolved": "https://registry.npmjs.org/wrappy/-/wrappy-1.0.2.tgz", - "integrity": "sha512-l4Sp/DRseor9wL6EvV2+TuQn63dMkPjZ/sp9XkghTEbV9KlPS1xUsZ3u7/IQO4wxtcFB4bgpQPRcR3QCvezPcQ==", - "dev": true - }, - "node_modules/yallist": { - "version": "4.0.0", - "resolved": "https://registry.npmjs.org/yallist/-/yallist-4.0.0.tgz", - "integrity": "sha512-3wdGidZyq5PB084XLES5TpOSRA3wjXAlIWMhum2kRcv/41Sn2emQ0dycQW4uZXLejwKvg6EsvbdlVL+FYEct7A==", - "dev": true - }, - "node_modules/yocto-queue": { - "version": "0.1.0", - "resolved": "https://registry.npmjs.org/yocto-queue/-/yocto-queue-0.1.0.tgz", - "integrity": "sha512-rVksvsnNCdJ/ohGc6xgPwyN8eheCxsiLM8mxuE/t/mOVqJewPuO1miLpTHQiRgTKCLexL4MeAFVagts7HmNZ2Q==", - "dev": true, - "engines": { - "node": ">=10" - }, - "funding": { - "url": "https://github.com/sponsors/sindresorhus" - } - } - } -} diff --git a/jscomp/gentype_tests/typescript-react-example/package.json b/jscomp/gentype_tests/typescript-react-example/package.json deleted file mode 100644 index 172eb2a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/package.json +++ /dev/null @@ -1,26 +0,0 @@ -{ - "name": "typescript-react-example", - "version": "0.1.0", - "private": true, - "scripts": { - "start": "rescript build -w", - "build": "rescript", - "clean": "rescript clean", - "tsc": "tsc -p tsconfig.json", - "lint": "eslint src" - }, - "dependencies": { - "@rescript/react": "^0.12.0", - "react": "^18.2.0", - "react-dom": "^18.2.0" - }, - "devDependencies": { - "@types/node": "^18.15.12", - "@types/react-dom": "^18.0.11", - "@typescript-eslint/eslint-plugin": "^6.8.0", - "@typescript-eslint/parser": "^6.8.0", - "eslint": "^8.51.0", - "rescript": "file:../../..", - "typescript": "^5.2.2" - } -} diff --git a/jscomp/gentype_tests/typescript-react-example/public/favicon.ico b/jscomp/gentype_tests/typescript-react-example/public/favicon.ico deleted file mode 100644 index a11777c..0000000 Binary files a/jscomp/gentype_tests/typescript-react-example/public/favicon.ico and /dev/null differ diff --git a/jscomp/gentype_tests/typescript-react-example/public/index.html b/jscomp/gentype_tests/typescript-react-example/public/index.html deleted file mode 100644 index ed0ebaf..0000000 --- a/jscomp/gentype_tests/typescript-react-example/public/index.html +++ /dev/null @@ -1,40 +0,0 @@ - - - - - - - - - - - React App - - - -
- - - diff --git a/jscomp/gentype_tests/typescript-react-example/public/manifest.json b/jscomp/gentype_tests/typescript-react-example/public/manifest.json deleted file mode 100644 index ef19ec2..0000000 --- a/jscomp/gentype_tests/typescript-react-example/public/manifest.json +++ /dev/null @@ -1,15 +0,0 @@ -{ - "short_name": "React App", - "name": "Create React App Sample", - "icons": [ - { - "src": "favicon.ico", - "sizes": "64x64 32x32 24x24 16x16", - "type": "image/x-icon" - } - ], - "start_url": "./index.html", - "display": "standalone", - "theme_color": "#000000", - "background_color": "#ffffff" -} diff --git a/jscomp/gentype_tests/typescript-react-example/rescript.json b/jscomp/gentype_tests/typescript-react-example/rescript.json deleted file mode 100644 index 1fbab8a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/rescript.json +++ /dev/null @@ -1,33 +0,0 @@ -{ - "gentypeconfig": { - "language": "typescript", - "module": "esmodule", - "importPath": "relative", - "shims": { - "Js": "Js", - "ReactEvent": "ReactEvent", - "RescriptPervasives": "RescriptPervasives", - "ReasonReact": "ReactShim" - }, - "debug": { - "all": false - }, - "exportInterfaces": false - }, - "name": "sample-typescript-app", - "bsc-flags": [], - "jsx": { "version": 3 }, - "bs-dependencies": ["@rescript/react"], - "sources": [ - { - "dir": "src", - "subdirs": true - } - ], - "uncurried": false, - "package-specs": { - "module": "esmodule", - "in-source": true - }, - "suffix": ".res.js" -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/App.css b/jscomp/gentype_tests/typescript-react-example/src/App.css deleted file mode 100644 index c5c6e8a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/App.css +++ /dev/null @@ -1,28 +0,0 @@ -.App { - text-align: center; -} - -.App-logo { - animation: App-logo-spin infinite 20s linear; - height: 80px; -} - -.App-header { - background-color: #222; - height: 150px; - padding: 20px; - color: white; -} - -.App-title { - font-size: 1.5em; -} - -.App-intro { - font-size: large; -} - -@keyframes App-logo-spin { - from { transform: rotate(0deg); } - to { transform: rotate(360deg); } -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/App.tsx b/jscomp/gentype_tests/typescript-react-example/src/App.tsx deleted file mode 100644 index 3169d1d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/App.tsx +++ /dev/null @@ -1,17 +0,0 @@ -import * as React from "react"; -import "./App.css"; - -export interface Props { - name: string; - count?: number; -} - -class App extends React.PureComponent { - public render() { - return ( -
- ); - } -} - -export default App; diff --git a/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.gen.tsx deleted file mode 100644 index 5566070..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.gen.tsx +++ /dev/null @@ -1,18 +0,0 @@ -/* TypeScript file generated from AutoAnnotate.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type variant = { TAG: "R"; _0: number }; - -export type record = { readonly variant: variant }; - -export type r2 = { readonly r2: number }; - -export type r3 = { readonly r3: number }; - -export type r4 = { readonly r4: number }; - -export type annotatedVariant = - { TAG: "R2"; _0: r2; _1: r3 } - | { TAG: "R4"; _0: r4 }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.res b/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.res deleted file mode 100644 index aec794e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.res +++ /dev/null @@ -1,14 +0,0 @@ -type variant = R(int) - -@genType type record = {variant: variant} - -type r2 = {r2: int} - -type r3 = {r3: int} - -type r4 = {r4: int} - -@genType -type annotatedVariant = - | R2(r2, r3) - | R4(r4) diff --git a/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.res.js b/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/AutoAnnotate.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/BigInt.res b/jscomp/gentype_tests/typescript-react-example/src/BigInt.res deleted file mode 100644 index 2a3956d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/BigInt.res +++ /dev/null @@ -1 +0,0 @@ -type t = Js.Types.bigint_val \ No newline at end of file diff --git a/jscomp/gentype_tests/typescript-react-example/src/BigInt.res.js b/jscomp/gentype_tests/typescript-react-example/src/BigInt.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/BigInt.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/BootloaderResource.res b/jscomp/gentype_tests/typescript-react-example/src/BootloaderResource.res deleted file mode 100644 index ec07f53..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/BootloaderResource.res +++ /dev/null @@ -1,3 +0,0 @@ -/* NOTE: This is a spooky interface that provides no type safety. It should be - * improved. Use with caution. */ -@module("BootloaderResource") external read: JSResource.t<'a> => 'a = "read" diff --git a/jscomp/gentype_tests/typescript-react-example/src/BootloaderResource.res.js b/jscomp/gentype_tests/typescript-react-example/src/BootloaderResource.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/BootloaderResource.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.gen.tsx deleted file mode 100644 index 3a73449..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.gen.tsx +++ /dev/null @@ -1,18 +0,0 @@ -/* TypeScript file generated from BucklescriptAnnotations.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type someMutableFields = { - mutable0: string; - readonly immutable: number; - mutable1: string; - mutable2: string -}; - -export type someMethods = { - readonly send: (_1:string) => void; - readonly on: (_1:string, _2:((_1:number) => void)) => void; - readonly threeargs: (_1:number, _2:string, _3:number) => string; - readonly twoArgs: (_1:number, _2:string) => number -}; diff --git a/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.res b/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.res deleted file mode 100644 index 053bca6..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.res +++ /dev/null @@ -1,28 +0,0 @@ -@genType -type someMutableFields = { - @set - "mutable0": string, - "immutable": int, - @set - "mutable1": string, - @set - "mutable2": string, -} - -@genType -type someMethods = { - @meth - "send": string => unit, - @meth - "on": (string, (. int) => unit) => unit, - @meth - "threeargs": (int, string, int) => string, - "twoArgs": (. int, string) => int, -} - -// let foo = (x: someMethods) => x["threeargs"](3, "a", 4) - -let bar = (x: someMethods) => { - let f = x["twoArgs"] - f(. 3, "a") -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.res.js b/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.res.js deleted file mode 100644 index 7f66df8..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/BucklescriptAnnotations.res.js +++ /dev/null @@ -1,12 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function bar(x) { - var f = x.twoArgs; - return f(3, "a"); -} - -export { - bar , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Comments.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Comments.gen.tsx deleted file mode 100644 index 584da01..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Comments.gen.tsx +++ /dev/null @@ -1,30 +0,0 @@ -/* TypeScript file generated from Comments.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as CommentsJS from './Comments.res.js'; - -export type DecideSubject_payload = { -/** A hint to use as a guide when thinking of your poem. */ -readonly hint: string }; - -/** The input used to generate the prompt and system prompt. */ -export abstract class DecideSubject_input { protected opaque!: any }; /* simulate opaque types */ - -/** The output from evaluating the llm prompt */ -export type DecideSubject_output = { - /** The text of the poem. */ - readonly text: string; - /** The prompt used to generate the poem. */ - readonly prompt: string; - /** The system prompt used to generate the poem. */ - readonly systemPrompt: string -}; - -/** Decide on a subject matter for a poem. */ -export const DecideSubject__placeholder: (run:string, times:number) => void = CommentsJS.DecideSubject._placeholder as any; - -export const DecideSubject: { -/** Decide on a subject matter for a poem. */ -_placeholder: (run:string, times:number) => void } = CommentsJS.DecideSubject as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Comments.res b/jscomp/gentype_tests/typescript-react-example/src/Comments.res deleted file mode 100644 index e70c756..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Comments.res +++ /dev/null @@ -1,24 +0,0 @@ -@genType /** A module for deciding on a subject matter for a poem.*/ -module DecideSubject = { - type payload = { - /** A hint to use as a guide when thinking of your poem.*/ - hint: string, - } - /** The input used to generate the prompt and system prompt.*/ - type input - /** The output from evaluating the llm prompt*/ - type output = { - /** The text of the poem.*/ - text: string, - /** The prompt used to generate the poem.*/ - prompt: string, - /** The system prompt used to generate the poem.*/ - systemPrompt: string, - } - - @genType /** Decide on a subject matter for a poem.*/ - let _placeholder = ( - @ocaml.doc("The runner specification") run: string, - @ocaml.doc("The number of times to cycle through the runner") times: int, - ) => (run, times)->ignore -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/Comments.res.js b/jscomp/gentype_tests/typescript-react-example/src/Comments.res.js deleted file mode 100644 index 2575585..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Comments.res.js +++ /dev/null @@ -1,15 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function _placeholder(run, times) { - -} - -var DecideSubject = { - _placeholder: _placeholder -}; - -export { - DecideSubject , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Core.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Core.gen.tsx deleted file mode 100644 index 08e7240..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Core.gen.tsx +++ /dev/null @@ -1,72 +0,0 @@ -/* TypeScript file generated from Core.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import {someFunWithNullThenOptionalArgs as someFunWithNullThenOptionalArgsNotChecked} from './CoreTS'; - -import {someFunWithNullUndefinedArg as someFunWithNullUndefinedArgNotChecked} from './CoreTS'; - -// In case of type error, check the type of 'someFunWithNullThenOptionalArgs' in 'Core.res' and './CoreTS'. -export const someFunWithNullThenOptionalArgsTypeChecked: (_1:(null | string), _2:(undefined | string)) => string = someFunWithNullThenOptionalArgsNotChecked as any; - -// Export 'someFunWithNullThenOptionalArgs' early to allow circular import from the '.bs.js' file. -export const someFunWithNullThenOptionalArgs: unknown = someFunWithNullThenOptionalArgsTypeChecked as (_1:(null | string), _2:(undefined | string)) => string as any; - -// In case of type error, check the type of 'someFunWithNullUndefinedArg' in 'Core.res' and './CoreTS'. -export const someFunWithNullUndefinedArgTypeChecked: (_1:(null | undefined | string), _2:number) => string = someFunWithNullUndefinedArgNotChecked as any; - -// Export 'someFunWithNullUndefinedArg' early to allow circular import from the '.bs.js' file. -export const someFunWithNullUndefinedArg: unknown = someFunWithNullUndefinedArgTypeChecked as (_1:(null | undefined | string), _2:number) => string as any; - -const CoreJS = require('./Core.res.js'); - -export type variant = "A" | { TAG: "B"; _0: string }; - -export type t1 = { readonly x?: string }; - -export type t2 = { readonly x: (undefined | string) }; - -export const null0: (x:(null | number)) => (null | number) = CoreJS.null0 as any; - -export const null1: (x:(null | number)) => (null | number) = CoreJS.null1 as any; - -export const nullable0: (x:(null | undefined | number)) => (null | undefined | number) = CoreJS.nullable0 as any; - -export const nullable1: (x:(null | undefined | number)) => (null | undefined | number) = CoreJS.nullable1 as any; - -export const undefined0: (x:(undefined | number)) => (undefined | number) = CoreJS.undefined0 as any; - -export const undefined1: (x:(undefined | number)) => (undefined | number) = CoreJS.undefined1 as any; - -export const dict0: (x:{[id: string]: string}) => {[id: string]: string} = CoreJS.dict0 as any; - -export const dict1: (x:{[id: string]: string}) => {[id: string]: string} = CoreJS.dict1 as any; - -export const promise0: (x:Promise) => Promise = CoreJS.promise0 as any; - -export const promise1: (x:Promise) => Promise = CoreJS.promise1 as any; - -export const date0: (x:Date) => Date = CoreJS.date0 as any; - -export const date1: (x:Date) => Date = CoreJS.date1 as any; - -export const bigint0: (x:BigInt) => BigInt = CoreJS.bigint0 as any; - -export const bigint1: (x:BigInt) => BigInt = CoreJS.bigint1 as any; - -export const regexp0: (x:RegExp) => RegExp = CoreJS.regexp0 as any; - -export const regexp1: (x:RegExp) => RegExp = CoreJS.regexp1 as any; - -export const map1: (x:Map) => Map = CoreJS.map1 as any; - -export const weakmap1: (x:WeakMap) => WeakMap = CoreJS.weakmap1 as any; - -export const set1: (x:Set) => Set = CoreJS.set1 as any; - -export const weakset1: (x:WeakSet) => WeakSet = CoreJS.weakset1 as any; - -export const option0: (x:(undefined | string)) => (undefined | string) = CoreJS.option0 as any; - -export const option1: (x:(undefined | variant)) => (undefined | variant) = CoreJS.option1 as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Core.res b/jscomp/gentype_tests/typescript-react-example/src/Core.res deleted file mode 100644 index 75fc44f..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Core.res +++ /dev/null @@ -1,88 +0,0 @@ -@genType -let null0 = (x: Js.null) => x - -@genType -let null1 = (x: Null.t) => x - -@genType -let nullable0 = (x: Js.nullable) => x - -@genType -let nullable1 = (x: Nullable.t) => x - -@genType -let undefined0 = (x: Js.undefined) => x - -@genType -let undefined1 = (x: Undefined.t) => x - -@genType -let dict0 = (x: Js.Dict.t) => x - -@genType -let dict1 = (x: Dict.t) => x - -@genType -let promise0 = (x: promise) => x - -@genType -let promise1 = (x: Promise.t) => x - -@genType -let date0 = (x: Js.Date.t) => x - -@genType -let date1 = (x: Date.t) => x - -@genType -let bigint0 = (x: Js.Types.bigint_val) => x - -@genType -let bigint1 = (x: BigInt.t) => x - -@genType -let regexp0 = (x: Js.Re.t) => x - -@genType -let regexp1 = (x: RegExp.t) => x - -module Map = Map_ -module Set = Set_ - -@genType -let map1 = (x: Map.t) => x - -@genType -let weakmap1 = (x: WeakMap.t, int>) => x - -@genType -let set1 = (x: Set.t) => x - -@genType -let weakset1 = (x: WeakSet.t>) => x - -type variant = A | B(string) - -@genType -let option0 = (x: option) => x - -@genType -let option1 = (x: option) => x - -@genType -type t1 = {x?: string} - -@genType -type t2 = {x: Js.undefined} - -@genType.import("./CoreTS") -external someFunWithNullThenOptionalArgs: ( - Null.t /* Cannot be Nullable.t or option */, - option /* Cannot be Null.t or Nullable.t */, -) => string = "someFunWithNullThenOptionalArgs" - -@genType.import("./CoreTS") -external someFunWithNullUndefinedArg: ( - Nullable.t /* Can also be Null.t or option as they are subtypes */, - int, -) => string = "someFunWithNullUndefinedArg" diff --git a/jscomp/gentype_tests/typescript-react-example/src/Core.res.js b/jscomp/gentype_tests/typescript-react-example/src/Core.res.js deleted file mode 100644 index 0864298..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Core.res.js +++ /dev/null @@ -1,133 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as CoreGen from "./Core.gen"; - -function null0(x) { - return x; -} - -function null1(x) { - return x; -} - -function nullable0(x) { - return x; -} - -function nullable1(x) { - return x; -} - -function undefined0(x) { - return x; -} - -function undefined1(x) { - return x; -} - -function dict0(x) { - return x; -} - -function dict1(x) { - return x; -} - -function promise0(x) { - return x; -} - -function promise1(x) { - return x; -} - -function date0(x) { - return x; -} - -function date1(x) { - return x; -} - -function bigint0(x) { - return x; -} - -function bigint1(x) { - return x; -} - -function regexp0(x) { - return x; -} - -function regexp1(x) { - return x; -} - -function map1(x) { - return x; -} - -function weakmap1(x) { - return x; -} - -function set1(x) { - return x; -} - -function weakset1(x) { - return x; -} - -function option0(x) { - return x; -} - -function option1(x) { - return x; -} - -function someFunWithNullThenOptionalArgs(prim0, prim1) { - return CoreGen.someFunWithNullThenOptionalArgs(prim0, prim1); -} - -function someFunWithNullUndefinedArg(prim0, prim1) { - return CoreGen.someFunWithNullUndefinedArg(prim0, prim1); -} - -var $$Map; - -var $$Set; - -export { - null0 , - null1 , - nullable0 , - nullable1 , - undefined0 , - undefined1 , - dict0 , - dict1 , - promise0 , - promise1 , - date0 , - date1 , - bigint0 , - bigint1 , - regexp0 , - regexp1 , - $$Map , - $$Set , - map1 , - weakmap1 , - set1 , - weakset1 , - option0 , - option1 , - someFunWithNullThenOptionalArgs , - someFunWithNullUndefinedArg , -} -/* ./Core.gen Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/CoreTS.ts b/jscomp/gentype_tests/typescript-react-example/src/CoreTS.ts deleted file mode 100644 index ef25fa7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/CoreTS.ts +++ /dev/null @@ -1,9 +0,0 @@ -export declare function someFunWithNullThenOptionalArgs( - nullable: null | string, - app?: string -): string; - -export declare function someFunWithNullUndefinedArg( - nullUndefined: null | undefined | string, - other: number -): string; diff --git a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler1.res b/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler1.res deleted file mode 100644 index 94a4159..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler1.res +++ /dev/null @@ -1,8 +0,0 @@ -module Error1 = { - type t = string - let notification = s => (s, s) -} - -module MyErrorHandler = ErrorHandler.Make(Error1) - -MyErrorHandler.notify("abc")->ignore diff --git a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler1.res.js b/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler1.res.js deleted file mode 100644 index 8582791..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler1.res.js +++ /dev/null @@ -1,25 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Curry from "rescript/lib/es6/curry.js"; -import * as ErrorHandler from "./ErrorHandler.res.js"; - -function notification(s) { - return [ - s, - s - ]; -} - -var Error1 = { - notification: notification -}; - -var MyErrorHandler = ErrorHandler.Make(Error1); - -Curry._1(MyErrorHandler.notify, "abc"); - -export { - Error1 , - MyErrorHandler , -} -/* MyErrorHandler Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler2.res b/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler2.res deleted file mode 100644 index 3949075..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler2.res +++ /dev/null @@ -1,6 +0,0 @@ -module Error2 = { - type t = int - let notification = n => (string_of_int(n), "") -} - -module MyErrorHandler = ErrorHandler.Make(Error2) /* MyErrorHandler.notify(42) */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler2.res.js b/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler2.res.js deleted file mode 100644 index ef8547f..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/CreateErrorHandler2.res.js +++ /dev/null @@ -1,22 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as ErrorHandler from "./ErrorHandler.res.js"; - -function notification(n) { - return [ - String(n), - "" - ]; -} - -var Error2 = { - notification: notification -}; - -var MyErrorHandler = ErrorHandler.Make(Error2); - -export { - Error2 , - MyErrorHandler , -} -/* MyErrorHandler Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Date.res b/jscomp/gentype_tests/typescript-react-example/src/Date.res deleted file mode 100644 index 87cfe1b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Date.res +++ /dev/null @@ -1 +0,0 @@ -type t = Js.Date.t \ No newline at end of file diff --git a/jscomp/gentype_tests/typescript-react-example/src/Date.res.js b/jscomp/gentype_tests/typescript-react-example/src/Date.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Date.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Derivings.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Derivings.gen.tsx deleted file mode 100644 index 5a23227..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Derivings.gen.tsx +++ /dev/null @@ -1,17 +0,0 @@ -/* TypeScript file generated from Derivings.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as DerivingsJS from './Derivings.res.js'; - -export type action = - "Click" - | "Cancel" - | { TAG: "Submit"; _0: string }; - -export const click: action = DerivingsJS.click as any; - -export const submit: (_1:string) => action = DerivingsJS.submit as any; - -export const cancel: action = DerivingsJS.cancel as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Derivings.res b/jscomp/gentype_tests/typescript-react-example/src/Derivings.res deleted file mode 100644 index d55c189..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Derivings.res +++ /dev/null @@ -1,5 +0,0 @@ -@genType @deriving(accessors) -type action = - | Click - | Submit(string) - | Cancel diff --git a/jscomp/gentype_tests/typescript-react-example/src/Derivings.res.js b/jscomp/gentype_tests/typescript-react-example/src/Derivings.res.js deleted file mode 100644 index 5165501..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Derivings.res.js +++ /dev/null @@ -1,20 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function submit(param_0) { - return { - TAG: "Submit", - _0: param_0 - }; -} - -var click = "Click"; - -var cancel = "Cancel"; - -export { - click , - submit , - cancel , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Dict.res b/jscomp/gentype_tests/typescript-react-example/src/Dict.res deleted file mode 100644 index 444e46d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Dict.res +++ /dev/null @@ -1 +0,0 @@ -type t<'a> = Js.Dict.t<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/Dict.res.js b/jscomp/gentype_tests/typescript-react-example/src/Dict.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Dict.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Docstrings.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Docstrings.gen.tsx deleted file mode 100644 index d6bbe20..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Docstrings.gen.tsx +++ /dev/null @@ -1,48 +0,0 @@ -/* TypeScript file generated from Docstrings.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as DocstringsJS from './Docstrings.res.js'; - -export type t = "A" | "B"; - -/** hello */ -export const flat: number = DocstringsJS.flat as any; - -/** \n * Sign a message with a key.\n *\n * @param message - A message to be signed\n * @param key - The key with which to sign the message\n * @returns A signed message\n */ -export const signMessage: (message:string, key:number) => string = DocstringsJS.signMessage as any; - -export const one: (a:number) => number = DocstringsJS.one as any; - -export const two: (a:number, b:number) => number = DocstringsJS.two as any; - -export const tree: (a:number, b:number, c:number) => number = DocstringsJS.tree as any; - -export const oneU: (a:number) => number = DocstringsJS.oneU as any; - -export const twoU: (a:number, b:number) => number = DocstringsJS.twoU as any; - -export const treeU: (a:number, b:number, c:number) => number = DocstringsJS.treeU as any; - -export const useParam: (param:number) => number = DocstringsJS.useParam as any; - -export const useParamU: (param:number) => number = DocstringsJS.useParamU as any; - -export const unnamed1: (param:number) => number = DocstringsJS.unnamed1 as any; - -export const unnamed1U: (param:number) => number = DocstringsJS.unnamed1U as any; - -export const unnamed2: (param_0:number, param_1:number) => number = DocstringsJS.unnamed2 as any; - -export const unnamed2U: (param_0:number, param_1:number) => number = DocstringsJS.unnamed2U as any; - -export const grouped: (x:number, y:number, a:number, b:number, c:number, z:number) => number = DocstringsJS.grouped as any; - -export const unitArgWithoutConversion: () => string = DocstringsJS.unitArgWithoutConversion as any; - -export const unitArgWithoutConversionU: () => string = DocstringsJS.unitArgWithoutConversionU as any; - -export const unitArgWithConversion: () => t = DocstringsJS.unitArgWithConversion as any; - -export const unitArgWithConversionU: () => t = DocstringsJS.unitArgWithConversionU as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Docstrings.res b/jscomp/gentype_tests/typescript-react-example/src/Docstrings.res deleted file mode 100644 index 962b406..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Docstrings.res +++ /dev/null @@ -1,50 +0,0 @@ -@ocaml.doc(" hello ") @genType -let flat = 34 - -@ocaml.doc(" - * Sign a message with a key. - * - * @param message - A message to be signed - * @param key - The key with which to sign the message - * @returns A signed message - ") -@genType -let signMessage = (. message, key) => message ++ string_of_int(key) - -@genType let one = a => a + 0 - -@genType let two = (a, b) => a + b + 0 - -@genType let tree = (a, b, c) => a + b + c + 0 - -@genType let oneU = (. a) => a + 0 - -@genType let twoU = (. a, b) => a + b + 0 - -@genType let treeU = (. a, b, c) => a + b + c + 0 - -@genType let useParam = param => param + 34 - -@genType let useParamU = (. param) => param + 34 - -@genType let unnamed1 = (_: int) => 34 - -@genType let unnamed1U = (. _: int) => 34 - -@genType let unnamed2 = (_: int, _: int) => 34 - -@genType let unnamed2U = (. _: int, _: int) => 34 - -@genType let grouped = (~x, ~y, a, b, c, ~z) => x + y + a + b + c + z - -@genType let unitArgWithoutConversion = () => "abc" - -@genType let unitArgWithoutConversionU = (. ()) => "abc" - -type t = - | A - | B - -@genType let unitArgWithConversion = () => A - -@genType let unitArgWithConversionU = (. ()) => A diff --git a/jscomp/gentype_tests/typescript-react-example/src/Docstrings.res.js b/jscomp/gentype_tests/typescript-react-example/src/Docstrings.res.js deleted file mode 100644 index 2ab5a33..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Docstrings.res.js +++ /dev/null @@ -1,99 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function signMessage(message, key) { - return message + String(key); -} - -function one(a) { - return a + 0 | 0; -} - -function two(a, b) { - return (a + b | 0) + 0 | 0; -} - -function tree(a, b, c) { - return ((a + b | 0) + c | 0) + 0 | 0; -} - -function oneU(a) { - return a + 0 | 0; -} - -function twoU(a, b) { - return (a + b | 0) + 0 | 0; -} - -function treeU(a, b, c) { - return ((a + b | 0) + c | 0) + 0 | 0; -} - -function useParam(param) { - return param + 34 | 0; -} - -function useParamU(param) { - return param + 34 | 0; -} - -function unnamed1(param) { - return 34; -} - -function unnamed1U(param) { - return 34; -} - -function unnamed2(param, param$1) { - return 34; -} - -function unnamed2U(param, param$1) { - return 34; -} - -function grouped(x, y, a, b, c, z) { - return ((((x + y | 0) + a | 0) + b | 0) + c | 0) + z | 0; -} - -function unitArgWithoutConversion(param) { - return "abc"; -} - -function unitArgWithoutConversionU() { - return "abc"; -} - -function unitArgWithConversion(param) { - return "A"; -} - -function unitArgWithConversionU() { - return "A"; -} - -var flat = 34; - -export { - flat , - signMessage , - one , - two , - tree , - oneU , - twoU , - treeU , - useParam , - useParamU , - unnamed1 , - unnamed1U , - unnamed2 , - unnamed2U , - grouped , - unitArgWithoutConversion , - unitArgWithoutConversionU , - unitArgWithConversion , - unitArgWithConversionU , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/DynamicallyLoadedComponent.res b/jscomp/gentype_tests/typescript-react-example/src/DynamicallyLoadedComponent.res deleted file mode 100644 index b7b93b5..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/DynamicallyLoadedComponent.res +++ /dev/null @@ -1,2 +0,0 @@ -@react.component -let make = (~s) => React.string(s) diff --git a/jscomp/gentype_tests/typescript-react-example/src/DynamicallyLoadedComponent.res.js b/jscomp/gentype_tests/typescript-react-example/src/DynamicallyLoadedComponent.res.js deleted file mode 100644 index 9eb45ee..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/DynamicallyLoadedComponent.res.js +++ /dev/null @@ -1,13 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function DynamicallyLoadedComponent(Props) { - return Props.s; -} - -var make = DynamicallyLoadedComponent; - -export { - make , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.gen.tsx deleted file mode 100644 index 0bfa420..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.gen.tsx +++ /dev/null @@ -1,18 +0,0 @@ -/* TypeScript file generated from EmitModuleIfNoConversion.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as EmitModuleIfNoConversionJS from './EmitModuleIfNoConversion.res.js'; - -export type t = "A" | { TAG: "B"; readonly name: string }; - -export const X_foo: (t:t) => void = EmitModuleIfNoConversionJS.X.foo as any; - -export const X_x: number = EmitModuleIfNoConversionJS.X.x as any; - -export const Y_x: string = EmitModuleIfNoConversionJS.Y.x as any; - -export const Y: { x: string } = EmitModuleIfNoConversionJS.Y as any; - -export const X: { x: number; foo: (t:t) => void } = EmitModuleIfNoConversionJS.X as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.res b/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.res deleted file mode 100644 index 7d74a6e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.res +++ /dev/null @@ -1,21 +0,0 @@ -@genType -type t = - | A - | B({name: string}) - -// foo requires converion: don't emit module X -module X = { - @genType - let foo = (t: t) => - switch t { - | A => Js.log("A") - | B({name}) => Js.log("B" ++ name) - } - - @genType let x = 42 -} - -// No field requires converion: emit module Y -module Y = { - @genType let x = "" -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.res.js b/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.res.js deleted file mode 100644 index f73e0e7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/EmitModuleIfNoConversion.res.js +++ /dev/null @@ -1,25 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function foo(t) { - if (typeof t !== "object") { - console.log("A"); - return ; - } - console.log("B" + t.name); -} - -var X = { - foo: foo, - x: 42 -}; - -var Y = { - x: "" -}; - -export { - X , - Y , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.res b/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.res deleted file mode 100644 index de3b351..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.res +++ /dev/null @@ -1,11 +0,0 @@ -module type Error = { - type t - let notification: t => (string, string) -} - -module Make = (Error: Error) => { - let notify = x => Error.notification(x) -} - -// This is ignored as there's an interface file -@genType let x = 42 diff --git a/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.res.js b/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.res.js deleted file mode 100644 index 27dcce4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.res.js +++ /dev/null @@ -1,20 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Curry from "rescript/lib/es6/curry.js"; - -function Make($$Error) { - var notify = function (x) { - return Curry._1($$Error.notification, x); - }; - return { - notify: notify - }; -} - -var x = 42; - -export { - Make , - x , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.resi b/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.resi deleted file mode 100644 index fac11f7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ErrorHandler.resi +++ /dev/null @@ -1,10 +0,0 @@ -module type Error = { - type t - let notification: t => (string, string) -} -module Make: (Error: Error) => -{ - let notify: Error.t => (string, string) -} - -let x: int diff --git a/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.gen.tsx deleted file mode 100644 index 78737da..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.gen.tsx +++ /dev/null @@ -1,12 +0,0 @@ -/* TypeScript file generated from ExportWithRename.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as React from 'react'; - -import * as ExportWithRenameJS from './ExportWithRename.res.js'; - -export type Props = { readonly s: string }; - -export const Renamed: React.ComponentType<{ readonly s: string }> = ExportWithRenameJS.make as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.res b/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.res deleted file mode 100644 index fa6b2fa..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType.as("Renamed") @react.component -let make = (~s) => React.string(s) diff --git a/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.res.js b/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.res.js deleted file mode 100644 index 41537fe..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ExportWithRename.res.js +++ /dev/null @@ -1,13 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function ExportWithRename(Props) { - return Props.s; -} - -var make = ExportWithRename; - -export { - make , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.gen.tsx deleted file mode 100644 index 3b0d202..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.gen.tsx +++ /dev/null @@ -1,66 +0,0 @@ -/* TypeScript file generated from FirstClassModules.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as FirstClassModulesJS from './FirstClassModules.res.js'; - -export type MT_t = number; - -export type MT_InnerModule3_inner = number; - -export type firstClassModule = { - readonly x: number; - readonly EmptyInnerModule: { - }; - readonly InnerModule2: { - readonly k: MT_t - }; - readonly InnerModule3: { - readonly k3: (_1:MT_InnerModule3_inner) => MT_InnerModule3_inner - }; - readonly Z: unknown; - readonly y: string -}; - -export const firstClassModule: firstClassModule = FirstClassModulesJS.firstClassModule as any; - -export const testConvert: (m:{ - readonly x: number; - readonly EmptyInnerModule: { - }; - readonly InnerModule2: { - readonly k: MT_t - }; - readonly InnerModule3: { - readonly k3: ((_1:MT_InnerModule3_inner) => MT_InnerModule3_inner) - }; - readonly Z: unknown; - readonly y: string -}) => { - readonly x: number; - readonly EmptyInnerModule: { - }; - readonly InnerModule2: { - readonly k: MT_t - }; - readonly InnerModule3: { - readonly k3: (_1:MT_InnerModule3_inner) => MT_InnerModule3_inner - }; - readonly Z: unknown; - readonly y: string -} = FirstClassModulesJS.testConvert as any; - -export const someFunctorAsFunction: (x:{ - readonly x: number; - readonly EmptyInnerModule: { - }; - readonly InnerModule2: { - readonly k: MT_t - }; - readonly InnerModule3: { - readonly k3: ((_1:MT_InnerModule3_inner) => MT_InnerModule3_inner) - }; - readonly Z: unknown; - readonly y: string -}) => { readonly ww: string } = FirstClassModulesJS.someFunctorAsFunction as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.res b/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.res deleted file mode 100644 index 86ef6af..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.res +++ /dev/null @@ -1,65 +0,0 @@ -module type MT = { - let x: int - type t = int - @module("foo") external f: int => int = "f" - module type XXX = { - type tt = string - } - module EmptyInnerModule: { - - } - module InnerModule2: { - let k: t - } - module InnerModule3: { - type inner = int - let k3: inner => inner - } - module type TT = { - let u: (int, int) - } - module Z: TT - let y: string -} -module M = { - let y = "abc" - module type XXX = { - type tt = string - } - module EmptyInnerModule = { - - } - module InnerModule2 = { - let k = 4242 - } - module InnerModule3 = { - type inner = int - let k3 = x => x + 1 - } - - module type TT = { - let u: (int, int) - } - module Z = { - let u = (0, 0) - } - type t = int - @module("foo") external f: int => int = "f" - let x = 42 -} - -@genType type firstClassModule = module(MT) - -@genType let firstClassModule: firstClassModule = module(M) - -@genType let testConvert = (m: module(MT)) => m - -module type ResT = { - let ww: string -} - -module SomeFunctor = (X: MT): ResT => { - let ww = X.y -} - -@genType let someFunctorAsFunction = (x: module(MT)): module(ResT) => module(SomeFunctor(unpack(x))) diff --git a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.res.js b/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.res.js deleted file mode 100644 index f5e1e86..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModules.res.js +++ /dev/null @@ -1,68 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var y = "abc"; - -var EmptyInnerModule = {}; - -var InnerModule2 = { - k: 4242 -}; - -function k3(x) { - return x + 1 | 0; -} - -var InnerModule3 = { - k3: k3 -}; - -var Z = { - u: [ - 0, - 0 - ] -}; - -var M = { - y: y, - EmptyInnerModule: EmptyInnerModule, - InnerModule2: InnerModule2, - InnerModule3: InnerModule3, - Z: Z, - x: 42 -}; - -var firstClassModule = { - x: 42, - EmptyInnerModule: EmptyInnerModule, - InnerModule2: InnerModule2, - InnerModule3: InnerModule3, - Z: Z, - y: y -}; - -function testConvert(m) { - return m; -} - -function SomeFunctor(X) { - return { - ww: X.y - }; -} - -function someFunctorAsFunction(x) { - return { - ww: x.y - }; -} - -export { - M , - firstClassModule , - testConvert , - SomeFunctor , - someFunctorAsFunction , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.gen.tsx deleted file mode 100644 index 6da111a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from FirstClassModulesInterface.resi by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type record = { readonly x: number; readonly y: string }; - -export type firstClassModule = { readonly x: number }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.res b/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.res deleted file mode 100644 index 9dd75a9..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.res +++ /dev/null @@ -1,12 +0,0 @@ -type record = { - x: int, - y: string, -} - -let r = {x: 3, y: "hello"} - -module type MT = { - let x: int -} - -type firstClassModule = module(MT) diff --git a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.res.js b/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.res.js deleted file mode 100644 index 6d7febd..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.res.js +++ /dev/null @@ -1,12 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var r = { - x: 3, - y: "hello" -}; - -export { - r , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.resi b/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.resi deleted file mode 100644 index 8b5354a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/FirstClassModulesInterface.resi +++ /dev/null @@ -1,14 +0,0 @@ -@genType -type record = { - x: int, - y: string, -} - -let r: record - -@genType -module type MT = { - let x: int -} - -@genType type firstClassModule = module(MT) diff --git a/jscomp/gentype_tests/typescript-react-example/src/GADT.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/GADT.gen.tsx deleted file mode 100644 index b6e29a5..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/GADT.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from GADT.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export abstract class t { protected opaque!: any }; /* simulate opaque types */ - -export abstract class tt { protected opaque!: any }; /* simulate opaque types */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/GADT.res b/jscomp/gentype_tests/typescript-react-example/src/GADT.res deleted file mode 100644 index ab5d939..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/GADT.res +++ /dev/null @@ -1,7 +0,0 @@ -// Warning here: GADT exported as opaque -@gentype -type rec t = Any('a): t | Anytwo('b, 'c): t - -// No warning here -@gentype.opaque -type rec tt = Any('a): tt | Anytwo('b, 'c): tt diff --git a/jscomp/gentype_tests/typescript-react-example/src/GADT.res.js b/jscomp/gentype_tests/typescript-react-example/src/GADT.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/GADT.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Hooks.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Hooks.gen.tsx deleted file mode 100644 index 39f83f9..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Hooks.gen.tsx +++ /dev/null @@ -1,145 +0,0 @@ -/* TypeScript file generated from Hooks.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as React from 'react'; - -import * as HooksJS from './Hooks.res.js'; - -import type {TypedArray2_Uint8Array_t as Js_TypedArray2_Uint8Array_t} from '../src/shims/Js.shim'; - -export type vehicle = { readonly name: string }; - -export type cb = (_to:vehicle) => void; - -export type r = { readonly x: string }; - -export type callback = (_1:input) => output; - -export type testReactContext = React.Context; - -export type testReactRef = { current: (null | number) }; - -export type testDomRef = React.Ref; - -export type testDomRef2 = React.Ref; - -export type Props = { readonly vehicle: vehicle }; - -export const $$default: React.ComponentType<{ readonly vehicle: vehicle }> = HooksJS.default as any; - -export default $$default; - -export type Another_anotherComponent_Props = { readonly callback: () => void; readonly vehicle: vehicle }; - -export const Another_anotherComponent: React.ComponentType<{ readonly callback: () => void; readonly vehicle: vehicle }> = HooksJS.Another.anotherComponent as any; - -export type Inner_make_Props = { readonly vehicle: vehicle }; - -export const Inner_make: React.ComponentType<{ readonly vehicle: vehicle }> = HooksJS.Inner.make as any; - -export type Inner_Another_anotherComponent_Props = { readonly vehicle: vehicle }; - -export const Inner_Another_anotherComponent: React.ComponentType<{ readonly vehicle: vehicle }> = HooksJS.Inner.Another.anotherComponent as any; - -export type Inner_Inner2_make_Props = { readonly vehicle: vehicle }; - -export const Inner_Inner2_make: React.ComponentType<{ readonly vehicle: vehicle }> = HooksJS.Inner.Inner2.make as any; - -export type Inner_Inner2_Another_anotherComponent_Props = { readonly vehicle: vehicle }; - -export const Inner_Inner2_Another_anotherComponent: React.ComponentType<{ readonly vehicle: vehicle }> = HooksJS.Inner.Inner2.Another.anotherComponent as any; - -export type NoProps_make_Props = {}; - -export const NoProps_make: React.ComponentType<{}> = HooksJS.NoProps.make as any; - -export const functionWithRenamedArgs: (_to:vehicle, _Type:vehicle, cb:cb) => string = HooksJS.functionWithRenamedArgs as any; - -export type WithRename_componentWithRenamedArgs_Props = { - readonly _Type: vehicle; - readonly _to: vehicle; - readonly cb: cb -}; - -export const WithRename_componentWithRenamedArgs: React.ComponentType<{ - readonly _Type: vehicle; - readonly _to: vehicle; - readonly cb: cb -}> = HooksJS.WithRename.componentWithRenamedArgs as any; - -export const WithRef_makeWithRef: (_1:{ readonly vehicle: vehicle }, _2:(null | undefined | any)) => JSX.Element = HooksJS.WithRef.makeWithRef as any; - -export type testForwardRef_Props = { readonly vehicle: vehicle }; - -export const testForwardRef: React.ComponentType<{ readonly vehicle: vehicle }> = HooksJS.testForwardRef as any; - -export type ForwardRef_input_Props = { readonly r: r }; - -export const ForwardRef_input: React.ComponentType<{ readonly r: r }> = HooksJS.ForwardRef.input as any; - -export type Poly_polymorphicComponent_Props = { readonly p: [vehicle, T1] }; - -export const Poly_polymorphicComponent: React.ComponentType<{ readonly p: [vehicle, any] }> = HooksJS.Poly.polymorphicComponent as any; - -export type Fun_functionReturningReactElement_Props = { readonly name: string }; - -export const Fun_functionReturningReactElement: React.ComponentType<{ readonly name: string }> = HooksJS.Fun.functionReturningReactElement as any; - -export type RenderPropRequiresConversion_make_Props = { readonly renderVehicle: React.ComponentType<{ readonly number: number; readonly vehicle: vehicle }> }; - -export const RenderPropRequiresConversion_make: React.ComponentType<{ readonly renderVehicle: React.ComponentType<{ readonly number: number; readonly vehicle: vehicle }> }> = HooksJS.RenderPropRequiresConversion.make as any; - -export type WithChildren_aComponentWithChildren_Props = { readonly children: React.ReactNode; readonly vehicle: vehicle }; - -export const WithChildren_aComponentWithChildren: React.ComponentType<{ readonly children: React.ReactNode; readonly vehicle: vehicle }> = HooksJS.WithChildren.aComponentWithChildren as any; - -export type DD_make_Props = { readonly array: Js_TypedArray2_Uint8Array_t; readonly name: string }; - -export const DD_make: React.ComponentType<{ readonly array: Js_TypedArray2_Uint8Array_t; readonly name: string }> = HooksJS.DD.make as any; - -export const NoProps: { make: React.ComponentType<{}> } = HooksJS.NoProps as any; - -export const Inner: { - Inner2: { - Another: { - anotherComponent: React.ComponentType<{ - readonly vehicle: vehicle - }> - }; - make: React.ComponentType<{ - readonly vehicle: vehicle - }> - }; - Another: { - anotherComponent: React.ComponentType<{ - readonly vehicle: vehicle - }> - }; - make: React.ComponentType<{ - readonly vehicle: vehicle - }> -} = HooksJS.Inner as any; - -export const RenderPropRequiresConversion: { make: React.ComponentType<{ readonly renderVehicle: React.ComponentType<{ readonly number: number; readonly vehicle: vehicle }> }> } = HooksJS.RenderPropRequiresConversion as any; - -export const WithRename: { componentWithRenamedArgs: React.ComponentType<{ - readonly _Type: vehicle; - readonly _to: vehicle; - readonly cb: cb -}> } = HooksJS.WithRename as any; - -export const ForwardRef: { input: React.ComponentType<{ readonly r: r }> } = HooksJS.ForwardRef as any; - -export const Fun: { functionReturningReactElement: React.ComponentType<{ readonly name: string }> } = HooksJS.Fun as any; - -export const WithRef: { makeWithRef: (_1:{ readonly vehicle: vehicle }, _2:(null | undefined | any)) => JSX.Element } = HooksJS.WithRef as any; - -export const WithChildren: { aComponentWithChildren: React.ComponentType<{ readonly children: React.ReactNode; readonly vehicle: vehicle }> } = HooksJS.WithChildren as any; - -export const DD: { make: React.ComponentType<{ readonly array: Js_TypedArray2_Uint8Array_t; readonly name: string }> } = HooksJS.DD as any; - -export const Another: { anotherComponent: React.ComponentType<{ readonly callback: () => void; readonly vehicle: vehicle }> } = HooksJS.Another as any; - -export const Poly: { polymorphicComponent: React.ComponentType<{ readonly p: [vehicle, any] }> } = HooksJS.Poly as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Hooks.res b/jscomp/gentype_tests/typescript-react-example/src/Hooks.res deleted file mode 100644 index bce9f6c..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Hooks.res +++ /dev/null @@ -1,142 +0,0 @@ -@@warning("-3") - -type vehicle = {name: string} - -@react.component -let make = (~vehicle) => { - let (count, setCount) = React.useState(() => 0) - -
-

- {React.string( - "Hooks example " ++ (vehicle.name ++ (" clicked " ++ (string_of_int(count) ++ " times"))), - )} -

- - React.string(x["randomString"])}> - {React.string("child1")} - {React.string("child2")} - - React.string(x["randomString"])}> - {React.string("child1")} - {React.string("child2")} - -
-} - -@genType -let default = make - -module Another = { - @genType @react.component - let anotherComponent = (~vehicle, ~callback: unit => unit) => { - callback() -
{React.string("Another Hook " ++ vehicle.name)}
- } -} - -module Inner = { - @genType @react.component - let make = (~vehicle) =>
{React.string("Another Hook " ++ vehicle.name)}
- module Another = { - @genType @react.component - let anotherComponent = (~vehicle) => -
{React.string("Another Hook " ++ vehicle.name)}
- } - module Inner2 = { - @genType @react.component - let make = (~vehicle) =>
{React.string("Another Hook " ++ vehicle.name)}
- module Another = { - @genType @react.component - let anotherComponent = (~vehicle) => -
{React.string("Another Hook " ++ vehicle.name)}
- } - } -} - -module NoProps = { - @genType @react.component - let make = () =>
React.null
-} - -type cb = (~_to: vehicle) => unit - -@genType -let functionWithRenamedArgs = (~_to, ~_Type, ~cb: cb) => { - cb(~_to) - _to.name ++ _Type.name -} - -module WithRename = { - @genType @react.component - let componentWithRenamedArgs = (~_to, ~_Type, ~cb: cb) => { - cb(~_to) - React.string(_to.name ++ _Type.name) - } -} - -module WithRef = { - @genType @react.component - let makeWithRef = (~vehicle) => { - let _ = 34 - ref => - switch ref->Js.Nullable.toOption { - | Some(ref) => - | None => React.null - } - } -} - -@genType let testForwardRef = React.forwardRef(WithRef.makeWithRef) - -type r = {x: string} - -module ForwardRef = { - @genType @react.component - let input = React.forwardRef((~r, (), ref) => -
{React.string(r.x)}
- ) -} - -@genType type callback<'input, 'output> = 'input => 'output - -@genType type testReactContext = React.Context.t - -@genType type testReactRef = React.Ref.t - -@genType type testDomRef = ReactDOM.domRef - -@genType type testDomRef2 = ReactDOM.Ref.t - -module Poly = { - @genType @react.component - let polymorphicComponent = (~p as (x, _)) => React.string(x.name) -} - -module Fun = { - @genType @react.component - let functionReturningReactElement = (~name) => React.string(name) -} - -module RenderPropRequiresConversion = { - @genType @react.component - let make = (~renderVehicle: {"vehicle": vehicle, "number": int} => React.element) => { - let car = {name: "Car"} - renderVehicle({"vehicle": car, "number": 42}) - } -} - -module WithChildren = { - @genType @react.component - let aComponentWithChildren = (~vehicle, ~children) => -
- {React.string("Another Hook " ++ vehicle.name)} -
children
-
-} - -module DD = { - @genType @react.component - let make = (~array as _: Js.TypedArray2.Uint8Array.t, ~name: string) => React.string(name) -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/Hooks.res.js b/jscomp/gentype_tests/typescript-react-example/src/Hooks.res.js deleted file mode 100644 index cd15d84..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Hooks.res.js +++ /dev/null @@ -1,223 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Curry from "rescript/lib/es6/curry.js"; -import * as React from "react"; -import * as ImportHooks from "./ImportHooks.res.js"; -import * as ImportHookDefault from "./ImportHookDefault.res.js"; - -function Hooks(Props) { - var vehicle = Props.vehicle; - var match = React.useState(function (param) { - return 0; - }); - var setCount = match[1]; - var count = match[0]; - return React.createElement("div", undefined, React.createElement("p", undefined, "Hooks example " + (vehicle.name + (" clicked " + (String(count) + " times")))), React.createElement("button", { - onClick: (function (param) { - Curry._1(setCount, (function (param) { - return count + 1 | 0; - })); - }) - }, "Click me"), React.createElement(ImportHooks.make, { - person: { - name: "Mary", - age: 71 - }, - children: null, - renderMe: (function (x) { - return x.randomString; - }) - }, "child1", "child2"), React.createElement(ImportHookDefault.make, { - person: { - name: "DefaultImport", - age: 42 - }, - children: null, - renderMe: (function (x) { - return x.randomString; - }) - }, "child1", "child2")); -} - -function Hooks$Another$anotherComponent(Props) { - var vehicle = Props.vehicle; - var callback = Props.callback; - Curry._1(callback, undefined); - return React.createElement("div", undefined, "Another Hook " + vehicle.name); -} - -var Another = { - anotherComponent: Hooks$Another$anotherComponent -}; - -function Hooks$Inner(Props) { - var vehicle = Props.vehicle; - return React.createElement("div", undefined, "Another Hook " + vehicle.name); -} - -function Hooks$Inner$Another$anotherComponent(Props) { - var vehicle = Props.vehicle; - return React.createElement("div", undefined, "Another Hook " + vehicle.name); -} - -var Another$1 = { - anotherComponent: Hooks$Inner$Another$anotherComponent -}; - -function Hooks$Inner$Inner2(Props) { - var vehicle = Props.vehicle; - return React.createElement("div", undefined, "Another Hook " + vehicle.name); -} - -function Hooks$Inner$Inner2$Another$anotherComponent(Props) { - var vehicle = Props.vehicle; - return React.createElement("div", undefined, "Another Hook " + vehicle.name); -} - -var Another$2 = { - anotherComponent: Hooks$Inner$Inner2$Another$anotherComponent -}; - -var Inner2 = { - make: Hooks$Inner$Inner2, - Another: Another$2 -}; - -var Inner = { - make: Hooks$Inner, - Another: Another$1, - Inner2: Inner2 -}; - -function Hooks$NoProps(Props) { - return React.createElement("div", undefined, null); -} - -var NoProps = { - make: Hooks$NoProps -}; - -function functionWithRenamedArgs(_to, _Type, cb) { - Curry._1(cb, _to); - return _to.name + _Type.name; -} - -function Hooks$WithRename$componentWithRenamedArgs(Props) { - var _to = Props._to; - var _Type = Props._Type; - var cb = Props.cb; - Curry._1(cb, _to); - return _to.name + _Type.name; -} - -var WithRename = { - componentWithRenamedArgs: Hooks$WithRename$componentWithRenamedArgs -}; - -function makeWithRef(vehicle) { - return function (ref) { - if (ref == null) { - return null; - } else { - return React.createElement("button", { - ref: ref - }, vehicle.name); - } - }; -} - -function Hooks$WithRef$makeWithRef(Props) { - return makeWithRef(Props.vehicle); -} - -var WithRef = { - makeWithRef: Hooks$WithRef$makeWithRef -}; - -var testForwardRef = React.forwardRef(function (param, param$1) { - return makeWithRef(param.vehicle)(param$1); - }); - -var input = React.forwardRef(function (Props, param) { - var partial_arg = Props.r; - return React.createElement("div", { - ref: param - }, partial_arg.x); - }); - -var ForwardRef = { - input: input -}; - -function Hooks$Poly$polymorphicComponent(Props) { - var param = Props.p; - return param[0].name; -} - -var Poly = { - polymorphicComponent: Hooks$Poly$polymorphicComponent -}; - -function Hooks$Fun$functionReturningReactElement(Props) { - return Props.name; -} - -var Fun = { - functionReturningReactElement: Hooks$Fun$functionReturningReactElement -}; - -function Hooks$RenderPropRequiresConversion(Props) { - var renderVehicle = Props.renderVehicle; - return Curry._1(renderVehicle, { - vehicle: { - name: "Car" - }, - number: 42 - }); -} - -var RenderPropRequiresConversion = { - make: Hooks$RenderPropRequiresConversion -}; - -function Hooks$WithChildren$aComponentWithChildren(Props) { - var vehicle = Props.vehicle; - var children = Props.children; - return React.createElement("div", undefined, "Another Hook " + vehicle.name, React.createElement("div", undefined, children)); -} - -var WithChildren = { - aComponentWithChildren: Hooks$WithChildren$aComponentWithChildren -}; - -function Hooks$DD(Props) { - var name = Props.name; - return name; -} - -var DD = { - make: Hooks$DD -}; - -var make = Hooks; - -var $$default = Hooks; - -export { - make , - $$default as default, - Another , - Inner , - NoProps , - functionWithRenamedArgs , - WithRename , - WithRef , - testForwardRef , - ForwardRef , - Poly , - Fun , - RenderPropRequiresConversion , - WithChildren , - DD , -} -/* testForwardRef Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.gen.tsx deleted file mode 100644 index e1da44f..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.gen.tsx +++ /dev/null @@ -1,6 +0,0 @@ -/* TypeScript file generated from IgnoreInterface.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type t = number; diff --git a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.res b/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.res deleted file mode 100644 index d381c3d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.res +++ /dev/null @@ -1,2 +0,0 @@ -@gentype -type t = int diff --git a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.res.js b/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.resi b/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.resi deleted file mode 100644 index 7a7cf64..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/IgnoreInterface.resi +++ /dev/null @@ -1,4 +0,0 @@ -// Use the annotations, and definitions, from the .res file -@@genType.ignoreInterface - -@genType type t diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.res b/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.res deleted file mode 100644 index a7f0432..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.res +++ /dev/null @@ -1,118 +0,0 @@ -type t<+'a> -module Array = { - open Belt - type array2<'a> = (array<'a>, array<'a>) - external fromT: t<'a> => array<'a> = "%identity" - external fromTp: t<('a, 'b)> => array<('a, 'b)> = "%identity" - external fromTT: t> => array> = "%identity" - external toT: array<'a> => t<'a> = "%identity" - external toTp: array<('a, 'b)> => t<('a, 'b)> = "%identity" - external toT2: array2<'a> => (t<'a>, t<'a>) = "%identity" - - /* Conversions involve a copy */ - - let fromArray = a => Array.copy(a)->toT - - let toArray = a => Array.copy(a->fromT) - - /* Type-cast immutable functions from Belt.Array. */ - - let length = a => Array.length(a->fromT) - - let size = a => Array.size(a->fromT) - - let get = (a, x) => (a->fromT)[x] - - let getExn = (a, x) => Array.getExn(a->fromT, x) - - let getUnsafe = (a, x) => Array.getUnsafe(a->fromT, x) - - let getUndefined = (a, x) => Array.getUndefined(a->fromT, x) - - let shuffle = x => Array.shuffle(x->fromT)->toT - - let reverse = x => Array.reverse(x->fromT)->toT - - let makeUninitialized = x => Array.makeUninitialized(x)->toT - - let makeUninitializedUnsafe = x => Array.makeUninitializedUnsafe(x)->toT - - let make = (x, y) => Array.make(x, y)->toT - - let range = (x, y) => Array.range(x, y)->toT - - let rangeBy = (x, y, ~step) => Array.rangeBy(x, y, ~step)->toT - - let makeByU = (c, f) => Array.makeByU(c, f)->toT - let makeBy = (c, f) => Array.makeBy(c, f)->toT - - let makeByAndShuffleU = (c, f) => Array.makeByAndShuffleU(c, f)->toT - let makeByAndShuffle = (c, f) => Array.makeByAndShuffle(c, f)->toT - - let zip = (a1, a2) => Array.zip(fromT(a1), fromT(a2))->toTp - - let zipByU = (a1, a2, f) => Array.zipByU(fromT(a1), fromT(a2), f)->toT - let zipBy = (a1, a2, f) => Array.zipBy(fromT(a1), fromT(a2), f)->toT - - let unzip = a => Array.unzip(a->fromTp)->toT2 - - let concat = (a1, a2) => Array.concat(a1->fromT, a2->fromT)->toT - - let concatMany = (a: t>) => Array.concatMany(a->fromTT)->toT - - let slice = (a, ~offset, ~len) => Array.slice(a->fromT, ~offset, ~len)->toT - - let sliceToEnd = (a, b) => Array.sliceToEnd(a->fromT, b)->toT - - let copy = a => Array.copy(a->fromT)->toT - - let forEachU = (a, f) => Array.forEachU(a->fromT, f) - let forEach = (a, f) => Array.forEach(a->fromT, f) - - let mapU = (a, f) => Array.mapU(a->fromT, f)->toT - let map = (a, f) => Array.map(a->fromT, f)->toT - - let keepWithIndexU = (a, f) => Array.keepWithIndexU(a->fromT, f)->toT - let keepWithIndex = (a, f) => Array.keepWithIndex(a->fromT, f)->toT - - let keepMapU = (a, f) => Array.keepMapU(a->fromT, f)->toT - let keepMap = (a, f) => Array.keepMap(a->fromT, f)->toT - - let forEachWithIndexU = (a, f) => Array.forEachWithIndexU(a->fromT, f) - let forEachWithIndex = (a, f) => Array.forEachWithIndex(a->fromT, f) - - let mapWithIndexU = (a, f) => Array.mapWithIndexU(a->fromT, f)->toT - let mapWithIndex = (a, f) => Array.mapWithIndex(a->fromT, f)->toT - - let partitionU = (a, f) => Array.partitionU(a->fromT, f)->toT2 - let partition = (a, f) => Array.partition(a->fromT, f)->toT2 - - let reduceU = (a, b, f) => Array.reduceU(a->fromT, b, f) - let reduce = (a, b, f) => Array.reduce(a->fromT, b, f) - - let reduceReverseU = (a, b, f) => Array.reduceReverseU(a->fromT, b, f) - let reduceReverse = (a, b, f) => Array.reduceReverse(a->fromT, b, f) - - let reduceReverse2U = (a1, a2, c, f) => Array.reduceReverse2U(fromT(a1), fromT(a2), c, f) - let reduceReverse2 = (a1, a2, c, f) => Array.reduceReverse2(fromT(a1), fromT(a2), c, f) - - let someU = (a, f) => Array.someU(a->fromT, f) - let some = (a, f) => Array.some(a->fromT, f) - - let everyU = (a, f) => Array.everyU(a->fromT, f) - let every = (a, f) => Array.every(a->fromT, f) - - let every2U = (a1, a2, f) => Array.every2U(fromT(a1), fromT(a2), f) - let every2 = (a1, a2, f) => Array.every2(fromT(a1), fromT(a2), f) - - let some2U = (a1, a2, f) => Array.some2U(fromT(a1), fromT(a2), f) - let some2 = (a1, a2, f) => Array.some2(fromT(a1), fromT(a2), f) - - let cmpU = (a1, a2, f) => Array.cmpU(fromT(a1), fromT(a2), f) - let cmp = (a1, a2, f) => Array.cmp(fromT(a1), fromT(a2), f) - - let eqU = (a1, a2, f) => Array.eqU(fromT(a1), fromT(a2), f) - let eq = (a1, a2, f) => Array.eq(fromT(a1), fromT(a2), f) -} - -include Array diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.res.js b/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.res.js deleted file mode 100644 index e443f7f..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.res.js +++ /dev/null @@ -1,210 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Belt_Array from "rescript/lib/es6/belt_Array.js"; - -function fromArray(a) { - return a.slice(0); -} - -function toArray(a) { - return a.slice(0); -} - -function length(a) { - return a.length; -} - -function size(a) { - return a.length; -} - -var get = Belt_Array.get; - -var getExn = Belt_Array.getExn; - -function getUnsafe(a, x) { - return a[x]; -} - -function getUndefined(a, x) { - return a[x]; -} - -var shuffle = Belt_Array.shuffle; - -var reverse = Belt_Array.reverse; - -function makeUninitialized(x) { - return new Array(x); -} - -function makeUninitializedUnsafe(x) { - return new Array(x); -} - -var make = Belt_Array.make; - -var range = Belt_Array.range; - -var rangeBy = Belt_Array.rangeBy; - -var makeByU = Belt_Array.makeByU; - -var makeBy = Belt_Array.makeBy; - -var makeByAndShuffleU = Belt_Array.makeByAndShuffleU; - -var makeByAndShuffle = Belt_Array.makeByAndShuffle; - -var zip = Belt_Array.zip; - -var zipByU = Belt_Array.zipByU; - -var zipBy = Belt_Array.zipBy; - -var unzip = Belt_Array.unzip; - -var concat = Belt_Array.concat; - -var concatMany = Belt_Array.concatMany; - -var slice = Belt_Array.slice; - -var sliceToEnd = Belt_Array.sliceToEnd; - -function copy(a) { - return a.slice(0); -} - -var forEachU = Belt_Array.forEachU; - -var forEach = Belt_Array.forEach; - -var mapU = Belt_Array.mapU; - -var map = Belt_Array.map; - -var keepWithIndexU = Belt_Array.keepWithIndexU; - -var keepWithIndex = Belt_Array.keepWithIndex; - -var keepMapU = Belt_Array.keepMapU; - -var keepMap = Belt_Array.keepMap; - -var forEachWithIndexU = Belt_Array.forEachWithIndexU; - -var forEachWithIndex = Belt_Array.forEachWithIndex; - -var mapWithIndexU = Belt_Array.mapWithIndexU; - -var mapWithIndex = Belt_Array.mapWithIndex; - -var partitionU = Belt_Array.partitionU; - -var partition = Belt_Array.partition; - -var reduceU = Belt_Array.reduceU; - -var reduce = Belt_Array.reduce; - -var reduceReverseU = Belt_Array.reduceReverseU; - -var reduceReverse = Belt_Array.reduceReverse; - -var reduceReverse2U = Belt_Array.reduceReverse2U; - -var reduceReverse2 = Belt_Array.reduceReverse2; - -var someU = Belt_Array.someU; - -var some = Belt_Array.some; - -var everyU = Belt_Array.everyU; - -var every = Belt_Array.every; - -var every2U = Belt_Array.every2U; - -var every2 = Belt_Array.every2; - -var some2U = Belt_Array.some2U; - -var some2 = Belt_Array.some2; - -var cmpU = Belt_Array.cmpU; - -var cmp = Belt_Array.cmp; - -var eqU = Belt_Array.eqU; - -var eq = Belt_Array.eq; - -var $$Array$1 = { - get: get -}; - -export { - $$Array$1 as $$Array, - fromArray , - toArray , - length , - size , - get , - getExn , - getUnsafe , - getUndefined , - shuffle , - reverse , - makeUninitialized , - makeUninitializedUnsafe , - make , - range , - rangeBy , - makeByU , - makeBy , - makeByAndShuffleU , - makeByAndShuffle , - zip , - zipByU , - zipBy , - unzip , - concat , - concatMany , - slice , - sliceToEnd , - copy , - forEachU , - forEach , - mapU , - map , - keepWithIndexU , - keepWithIndex , - keepMapU , - keepMap , - forEachWithIndexU , - forEachWithIndex , - mapWithIndexU , - mapWithIndex , - partitionU , - partition , - reduceU , - reduce , - reduceReverseU , - reduceReverse , - reduceReverse2U , - reduceReverse2 , - someU , - some , - everyU , - every , - every2U , - every2 , - some2U , - some2 , - cmpU , - cmp , - eqU , - eq , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.resi b/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.resi deleted file mode 100644 index 89d599a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImmutableArray.resi +++ /dev/null @@ -1,110 +0,0 @@ -@ocaml.doc(" Immutable arrays are covariant. ") -type t<+'a> - -@ocaml.doc(" Redefine the [_] syntax, and disable the assignment [_] = _. ") -module Array: { - let get: (t<'a>, int) => option<'a> -} - -@ocaml.doc(" Converting from/to normal arrays involves making a copy. ") -let fromArray: array<'a> => t<'a> - -let toArray: t<'a> => array<'a> - -@ocaml.doc(" Subset of the Belt.Array oprerations that do not mutate the array. ") -let length: t<'a> => int - -let size: t<'a> => int - -let get: (t<'a>, int) => option<'a> - -let getExn: (t<'a>, int) => 'a - -let getUnsafe: (t<'a>, int) => 'a - -let getUndefined: (t<'a>, int) => Js.undefined<'a> - -let shuffle: t<'a> => t<'a> - -let reverse: t<'a> => t<'a> - -let makeUninitialized: int => t> - -let makeUninitializedUnsafe: int => t<'a> - -let make: (int, 'a) => t<'a> - -let range: (int, int) => t - -let rangeBy: (int, int, ~step: int) => t - -let makeByU: (int, (. int) => 'a) => t<'a> -let makeBy: (int, int => 'a) => t<'a> - -let makeByAndShuffleU: (int, (. int) => 'a) => t<'a> -let makeByAndShuffle: (int, int => 'a) => t<'a> - -let zip: (t<'a>, t<'b>) => t<('a, 'b)> - -let zipByU: (t<'a>, t<'b>, (. 'a, 'b) => 'c) => t<'c> -let zipBy: (t<'a>, t<'b>, ('a, 'b) => 'c) => t<'c> - -let unzip: t<('a, 'a)> => (t<'a>, t<'a>) - -let concat: (t<'a>, t<'a>) => t<'a> - -let concatMany: t> => t<'a> - -let slice: (t<'a>, ~offset: int, ~len: int) => t<'a> - -let sliceToEnd: (t<'a>, int) => t<'a> - -let copy: t<'a> => t<'a> - -let forEachU: (t<'a>, (. 'a) => unit) => unit -let forEach: (t<'a>, 'a => unit) => unit - -let mapU: (t<'a>, (. 'a) => 'b) => t<'b> -let map: (t<'a>, 'a => 'b) => t<'b> - -let keepWithIndexU: (t<'a>, (. 'a, int) => bool) => t<'a> -let keepWithIndex: (t<'a>, ('a, int) => bool) => t<'a> - -let keepMapU: (t<'a>, (. 'a) => option<'b>) => t<'b> -let keepMap: (t<'a>, 'a => option<'b>) => t<'b> - -let forEachWithIndexU: (t<'a>, (. int, 'a) => unit) => unit -let forEachWithIndex: (t<'a>, (int, 'a) => unit) => unit - -let mapWithIndexU: (t<'a>, (. int, 'a) => 'b) => t<'b> -let mapWithIndex: (t<'a>, (int, 'a) => 'b) => t<'b> - -let partitionU: (t<'a>, (. 'a) => bool) => (t<'a>, t<'a>) -let partition: (t<'a>, 'a => bool) => (t<'a>, t<'a>) - -let reduceU: (t<'a>, 'b, (. 'b, 'a) => 'b) => 'b -let reduce: (t<'a>, 'b, ('b, 'a) => 'b) => 'b - -let reduceReverseU: (t<'a>, 'b, (. 'b, 'a) => 'b) => 'b -let reduceReverse: (t<'a>, 'b, ('b, 'a) => 'b) => 'b - -let reduceReverse2U: (t<'a>, t<'b>, 'c, (. 'c, 'a, 'b) => 'c) => 'c -let reduceReverse2: (t<'a>, t<'b>, 'c, ('c, 'a, 'b) => 'c) => 'c - -let someU: (t<'a>, (. 'a) => bool) => bool -let some: (t<'a>, 'a => bool) => bool - -let everyU: (t<'a>, (. 'a) => bool) => bool -let every: (t<'a>, 'a => bool) => bool - -let every2U: (t<'a>, t<'b>, (. 'a, 'b) => bool) => bool -let every2: (t<'a>, t<'b>, ('a, 'b) => bool) => bool - -let some2U: (t<'a>, t<'b>, (. 'a, 'b) => bool) => bool -let some2: (t<'a>, t<'b>, ('a, 'b) => bool) => bool - -let cmpU: (t<'a>, t<'a>, (. 'a, 'a) => int) => int -let cmp: (t<'a>, t<'a>, ('a, 'a) => int) => int - -let eqU: (t<'a>, t<'a>, (. 'a, 'a) => bool) => bool -let eq: (t<'a>, t<'a>, ('a, 'a) => bool) => bool diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.gen.tsx deleted file mode 100644 index e478b2f..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.gen.tsx +++ /dev/null @@ -1,42 +0,0 @@ -/* TypeScript file generated from ImportHookDefault.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import {default as makeNotChecked} from './hookExample'; - -import {default as defaultNotChecked} from './hookExample'; - -// In case of type error, check the type of 'make' in 'ImportHookDefault.res' and './hookExample'. -export const makeTypeChecked: React.ComponentType<{ - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: ImportHooks_renderMe -}> = makeNotChecked as any; - -// Export 'make' early to allow circular import from the '.bs.js' file. -export const make: unknown = makeTypeChecked as React.ComponentType<{ - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: ImportHooks_renderMe -}> as any; - -// In case of type error, check the type of 'default' in 'ImportHookDefault.res' and './hookExample'. -export const defaultTypeChecked: React.ComponentType<{ - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: ImportHooks_renderMe -}> = defaultNotChecked as any; - -// Export '$$default' early to allow circular import from the '.bs.js' file. -export const $$default: unknown = defaultTypeChecked as React.ComponentType<{ - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: ImportHooks_renderMe -}> as any; - -import type {renderMe as ImportHooks_renderMe} from './ImportHooks.gen'; - -export type person = { readonly name: string; readonly age: number }; - -export default $$default; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.res b/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.res deleted file mode 100644 index 2a345d8..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.res +++ /dev/null @@ -1,21 +0,0 @@ -type person = { - name: string, - age: int, -} - -@genType.import(("./hookExample", "default")) @react.component -external make: ( - ~person: person, - ~children: React.element, - ~renderMe: ImportHooks.renderMe, -) => React.element = "make" - -module MM = { -@genType.import("./hookExample") @react.component -external make2: ( - ~person: person, - ~children: React.element, - ~renderMe: ImportHooks.renderMe, -) => React.element = "default" -} - diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.res.js b/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.res.js deleted file mode 100644 index 6356fbd..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportHookDefault.res.js +++ /dev/null @@ -1,18 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import ImportHookDefaultGen from "./ImportHookDefault.gen"; -import * as ImportHookDefaultGen$1 from "./ImportHookDefault.gen"; - -var make = ImportHookDefaultGen$1.make; - -var make2 = ImportHookDefaultGen; - -var MM = { - make2: make2 -}; - -export { - make , - MM , -} -/* make Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.gen.tsx deleted file mode 100644 index f05bfbb..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.gen.tsx +++ /dev/null @@ -1,34 +0,0 @@ -/* TypeScript file generated from ImportHooks.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import {makeRenamed as makeRenamedNotChecked} from './hookExample'; - -import {foo as fooNotChecked} from './hookExample'; - -// In case of type error, check the type of 'makeRenamed' in 'ImportHooks.res' and './hookExample'. -export const makeRenamedTypeChecked: React.ComponentType<{ - readonly actions?: JSX.Element; - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: renderMe -}> = makeRenamedNotChecked as any; - -// Export 'makeRenamed' early to allow circular import from the '.bs.js' file. -export const makeRenamed: unknown = makeRenamedTypeChecked as React.ComponentType<{ - readonly actions?: JSX.Element; - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: renderMe -}> as any; - -// In case of type error, check the type of 'foo' in 'ImportHooks.res' and './hookExample'. -export const fooTypeChecked: (person:person) => string = fooNotChecked as any; - -// Export 'foo' early to allow circular import from the '.bs.js' file. -export const foo: unknown = fooTypeChecked as (person:person) => string as any; - -export type person = { readonly name: string; readonly age: number }; - -export type renderMe = React.ComponentType<{ readonly randomString: string; readonly poly: a }>; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.res b/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.res deleted file mode 100644 index 8fd29cf..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.res +++ /dev/null @@ -1,17 +0,0 @@ -@genType -type person = { - name: string, - age: int, -} - -@genType type renderMe<'a> = React.component<{"randomString": string, "poly": 'a}> - -@genType.import("./hookExample") @react.component -external make: ( - ~actions: React.element=?, - ~person: person, - ~children: React.element, - ~renderMe: renderMe<'a>, -) => React.element = "makeRenamed" - -@genType.import("./hookExample") external foo: (~person: person) => string = "foo" diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.res.js b/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.res.js deleted file mode 100644 index 0a3f6aa..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportHooks.res.js +++ /dev/null @@ -1,15 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as ImportHooksGen from "./ImportHooks.gen"; - -var make = ImportHooksGen.makeRenamed; - -function foo(prim) { - return ImportHooksGen.foo(prim); -} - -export { - make , - foo , -} -/* make Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.gen.tsx deleted file mode 100644 index d55ef23..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.gen.tsx +++ /dev/null @@ -1,14 +0,0 @@ -/* TypeScript file generated from ImportIndex.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import {default as defaultNotChecked} from './'; - -// In case of type error, check the type of 'default' in 'ImportIndex.res' and './'. -export const defaultTypeChecked: React.ComponentType<{ readonly method?: "push" | "replace" }> = defaultNotChecked as any; - -// Export '$$default' early to allow circular import from the '.bs.js' file. -export const $$default: unknown = defaultTypeChecked as React.ComponentType<{ readonly method?: "push" | "replace" }> as any; - -export default $$default; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.res b/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.res deleted file mode 100644 index eee22d3..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.res +++ /dev/null @@ -1,3 +0,0 @@ -// TODO: rename metodd back once remmt bug is fixed -@genType.import("./") @react.component -external make: (~method: [#push | #replace]=?) => React.element = "default" diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.res.js b/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.res.js deleted file mode 100644 index f8da735..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportIndex.res.js +++ /dev/null @@ -1,10 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import ImportIndexGen from "./ImportIndex.gen"; - -var make = ImportIndexGen; - -export { - make , -} -/* make Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.gen.tsx deleted file mode 100644 index 96acb5a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.gen.tsx +++ /dev/null @@ -1,122 +0,0 @@ -/* TypeScript file generated from ImportJsValue.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import {round as roundNotChecked} from './MyMath'; - -import {round2 as round2NotChecked} from './MyMath'; - -import {area as areaNotChecked} from './MyMath'; - -import {returnMixedArray as returnMixedArrayNotChecked} from './MyMath'; - -import {useColor as useColorNotChecked} from './MyMath'; - -import {higherOrder as higherOrderNotChecked} from './MyMath'; - -import {convertVariant as convertVariantNotChecked} from './MyMath'; - -import {polymorphic as polymorphicNotChecked} from './MyMath'; - -import {default as defaultNotChecked} from './MyMath'; - -// In case of type error, check the type of 'round' in 'ImportJsValue.res' and './MyMath'. -export const roundTypeChecked: (_1:number) => number = roundNotChecked as any; - -// Export 'round' early to allow circular import from the '.bs.js' file. -export const round: unknown = roundTypeChecked as (_1:number) => number as any; - -// In case of type error, check the type of 'round2' in 'ImportJsValue.res' and './MyMath'. -export const round2TypeChecked: (_1:number) => number = round2NotChecked as any; - -// Export 'round2' early to allow circular import from the '.bs.js' file. -export const round2: unknown = round2TypeChecked as (_1:number) => number as any; - -// In case of type error, check the type of 'area' in 'ImportJsValue.res' and './MyMath'. -export const areaTypeChecked: (_1:point) => number = areaNotChecked as any; - -// Export 'area' early to allow circular import from the '.bs.js' file. -export const area: unknown = areaTypeChecked as (_1:point) => number as any; - -// In case of type error, check the type of 'returnMixedArray' in 'ImportJsValue.res' and './MyMath'. -export const returnMixedArrayTypeChecked: () => numberOrString[] = returnMixedArrayNotChecked as any; - -// Export 'returnMixedArray' early to allow circular import from the '.bs.js' file. -export const returnMixedArray: unknown = returnMixedArrayTypeChecked as () => numberOrString[] as any; - -// In case of type error, check the type of 'useColor' in 'ImportJsValue.res' and './MyMath'. -export const useColorTypeChecked: (_1:color) => number = useColorNotChecked as any; - -// Export 'useColor' early to allow circular import from the '.bs.js' file. -export const useColor: unknown = useColorTypeChecked as (_1:color) => number as any; - -// In case of type error, check the type of 'higherOrder' in 'ImportJsValue.res' and './MyMath'. -export const higherOrderTypeChecked: (_1:((_1:number, _2:number) => number)) => number = higherOrderNotChecked as any; - -// Export 'higherOrder' early to allow circular import from the '.bs.js' file. -export const higherOrder: unknown = higherOrderTypeChecked as (_1:((_1:number, _2:number) => number)) => number as any; - -// In case of type error, check the type of 'convertVariant' in 'ImportJsValue.res' and './MyMath'. -export const convertVariantTypeChecked: (_1:variant) => variant = convertVariantNotChecked as any; - -// Export 'convertVariant' early to allow circular import from the '.bs.js' file. -export const convertVariant: unknown = convertVariantTypeChecked as (_1:variant) => variant as any; - -// In case of type error, check the type of 'polymorphic' in 'ImportJsValue.res' and './MyMath'. -export const polymorphicTypeChecked: (_1:a) => a = polymorphicNotChecked as any; - -// Export 'polymorphic' early to allow circular import from the '.bs.js' file. -export const polymorphic: unknown = polymorphicTypeChecked as (_1:a) => a as any; - -// In case of type error, check the type of 'default' in 'ImportJsValue.res' and './MyMath'. -export const defaultTypeChecked: number = defaultNotChecked as any; - -// Export '$$default' early to allow circular import from the '.bs.js' file. -export const $$default: unknown = defaultTypeChecked as number as any; - -const ImportJsValueJS = require('./ImportJsValue.res.js'); - -import type {AbsoluteValue as $$AbsoluteValue_t} from './MyMath'; - -import type {num as $$myNum} from './MyMath'; - -import type {num as $$num} from './MyMath'; - -import type {numberOrString as $$numberOrString} from './MyMath'; - -import type {polyType as $$polyType} from './MyMath'; - -import type {stringFunction as $$stringFunction} from './MyMath'; - -export type point = { readonly x: number; readonly y: (undefined | number) }; - -export type numberOrString = $$numberOrString; - -export type AbsoluteValue_t = $$AbsoluteValue_t; - -export type stringFunction = $$stringFunction; - -export type color = "tomato" | "gray"; - -export type variant = - { TAG: "I"; _0: number } - | { TAG: "S"; _0: string }; - -export type num = $$num; - -export type myNum = $$myNum; - -export type polyType = $$polyType; - -export const roundedNumber: number = ImportJsValueJS.roundedNumber as any; - -export const areaValue: number = ImportJsValueJS.areaValue as any; - -export const useGetProp: (x:AbsoluteValue_t) => number = ImportJsValueJS.useGetProp as any; - -export const useGetAbs: (x:AbsoluteValue_t) => number = ImportJsValueJS.useGetAbs as any; - -export const returnedFromHigherOrder: number = ImportJsValueJS.returnedFromHigherOrder as any; - -export default $$default; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.res b/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.res deleted file mode 100644 index 91dd176..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.res +++ /dev/null @@ -1,81 +0,0 @@ -@ocaml.doc(" - * Wrap JS values to be used from Reason - ") -@genType.import("./MyMath") -external /* This is the module to import from. */ -/* Name and type of the JS value to bind to. */ -round: float => float = "round" - -@gentype.import("./MyMath") -external round2: float => float = "round2" - -let _ = round2 - -@genType -type point = { - x: int, - y: option, -} - -@genType.import("./MyMath") -external /* This is the module to import from. */ -/* Name and type of the JS value to bind to. */ -area: point => int = "area" - -@genType.import("./MyMath") -type numberOrString - -@genType.import("./MyMath") -external returnMixedArray: unit => array = "returnMixedArray" - -@genType let roundedNumber = round(1.8) - -@genType let areaValue = area({x: 3, y: None}) - -module AbsoluteValue = { - @genType.import(("./MyMath", "AbsoluteValue")) - type t = {"getAbs": (. unit) => int} - - /* This is untyped */ - @send external getProp: t => int = "getProp" - - /* This is also untyped, as we "trust" the type declaration in absoluteVaue */ - let getAbs = (x: t) => { - let getAbs = x["getAbs"] - getAbs(.) - } -} - -@genType let useGetProp = (x: AbsoluteValue.t) => x->AbsoluteValue.getProp + 1 - -@genType let useGetAbs = (x: AbsoluteValue.t) => x->AbsoluteValue.getAbs + 1 - -@genType.import("./MyMath") -type stringFunction - -@genType type color = [#tomato | #gray] - -@genType.import("./MyMath") external useColor: color => int = "useColor" - -@genType.import("./MyMath") external higherOrder: ((int, int) => int) => int = "higherOrder" - -@genType let returnedFromHigherOrder = higherOrder(\"+") - -type variant = - | I(int) - | S(string) - -@genType.import("./MyMath") external convertVariant: variant => variant = "convertVariant" - -@genType.import("./MyMath") external polymorphic: 'a => 'a = "polymorphic" - -@genType.import("./MyMath") external default: int = "default" - -@genType.import(("./MyMath", "num")) -type num - -@genType.import(("./MyMath", "num")) -type myNum - -@genType.import("./MyMath") -type polyType<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.res.js b/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.res.js deleted file mode 100644 index 69f8ca3..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ImportJsValue.res.js +++ /dev/null @@ -1,85 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import ImportJsValueGen from "./ImportJsValue.gen"; -import * as ImportJsValueGen$1 from "./ImportJsValue.gen"; - -function round(prim) { - return ImportJsValueGen$1.round(prim); -} - -function round2(prim) { - return ImportJsValueGen$1.round2(prim); -} - -function area(prim) { - return ImportJsValueGen$1.area(prim); -} - -function returnMixedArray(prim) { - return ImportJsValueGen$1.returnMixedArray(); -} - -var roundedNumber = ImportJsValueGen$1.round(1.8); - -var areaValue = ImportJsValueGen$1.area({ - x: 3, - y: undefined - }); - -function getAbs(x) { - var getAbs$1 = x.getAbs; - return getAbs$1(); -} - -var AbsoluteValue = { - getAbs: getAbs -}; - -function useGetProp(x) { - return x.getProp() + 1 | 0; -} - -function useGetAbs(x) { - return getAbs(x) + 1 | 0; -} - -function useColor(prim) { - return ImportJsValueGen$1.useColor(prim); -} - -function higherOrder(prim) { - return ImportJsValueGen$1.higherOrder(prim); -} - -var returnedFromHigherOrder = ImportJsValueGen$1.higherOrder(function (prim0, prim1) { - return prim0 + prim1 | 0; - }); - -function convertVariant(prim) { - return ImportJsValueGen$1.convertVariant(prim); -} - -function polymorphic(prim) { - return ImportJsValueGen$1.polymorphic(prim); -} - -var $$default = ImportJsValueGen; - -export { - round , - round2 , - area , - returnMixedArray , - roundedNumber , - areaValue , - AbsoluteValue , - useGetProp , - useGetAbs , - useColor , - higherOrder , - returnedFromHigherOrder , - convertVariant , - polymorphic , - $$default as default, -} -/* roundedNumber Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Inherits.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Inherits.gen.tsx deleted file mode 100644 index 29faeb7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Inherits.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from Inherits.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type red = "Ruby" | "Redwood" | "Rust"; - -export type blue = "Sapphire" | "Neon" | "Navy"; - -export type color = red | blue; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Inherits.res b/jscomp/gentype_tests/typescript-react-example/src/Inherits.res deleted file mode 100644 index 6ad8fee..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Inherits.res +++ /dev/null @@ -1,5 +0,0 @@ -type red = [#Ruby | #Redwood | #Rust] -type blue = [#Sapphire | #Neon | #Navy] - -@genType -type color = [red | blue] diff --git a/jscomp/gentype_tests/typescript-react-example/src/Inherits.res.js b/jscomp/gentype_tests/typescript-react-example/src/Inherits.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Inherits.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.gen.tsx deleted file mode 100644 index f5e9015..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.gen.tsx +++ /dev/null @@ -1,12 +0,0 @@ -/* TypeScript file generated from InnerModuleSignature.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as InnerModuleSignatureJS from './InnerModuleSignature.res.js'; - -export type InnerModule_t = string; - -export const InnerModule_make: (_1:InnerModule_t) => string = InnerModuleSignatureJS.InnerModule.make as any; - -export const InnerModule: { make: (_1:InnerModule_t) => string } = InnerModuleSignatureJS.InnerModule as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.res b/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.res deleted file mode 100644 index fd77fe8..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.res +++ /dev/null @@ -1,9 +0,0 @@ -module InnerModule: { - type t = private string - @genType - let make: t => string -} = { - type t = string - let make = t => t ++ "..." -} - diff --git a/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.res.js b/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.res.js deleted file mode 100644 index db7df46..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/InnerModuleSignature.res.js +++ /dev/null @@ -1,15 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function make(t) { - return t + "..."; -} - -var InnerModule = { - make: make -}; - -export { - InnerModule , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/JSResource.res b/jscomp/gentype_tests/typescript-react-example/src/JSResource.res deleted file mode 100644 index 432c4a4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/JSResource.res +++ /dev/null @@ -1,3 +0,0 @@ -type t<'a> - -@module external jSResource: string => t<'a> = "JSResource" diff --git a/jscomp/gentype_tests/typescript-react-example/src/JSResource.res.js b/jscomp/gentype_tests/typescript-react-example/src/JSResource.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/JSResource.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/JSXV4.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/JSXV4.gen.tsx deleted file mode 100644 index 1d627f9..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/JSXV4.gen.tsx +++ /dev/null @@ -1,49 +0,0 @@ -/* TypeScript file generated from JSXV4.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import {make as makeNotChecked} from './hookExample'; - -import * as React from 'react'; - -// In case of type error, check the type of 'make' in 'JSXV4.res' and './hookExample'. -export const makeTypeChecked: React.ComponentType<{ - readonly actions?: JSX.Element; - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: renderMe -}> = makeNotChecked as any; - -// Export 'make' early to allow circular import from the '.bs.js' file. -export const make: unknown = makeTypeChecked as React.ComponentType<{ - readonly actions?: JSX.Element; - readonly person: person; - readonly children: React.ReactNode; - readonly renderMe: renderMe -}> as any; - -const JSXV4JS = require('./JSXV4.res.js'); - -export type CompV4_props = { readonly x: x; readonly y: y }; - -export type person = { readonly name: string; readonly age: number }; - -export type renderMe = React.ComponentType<{ readonly randomString: string; readonly poly: a }>; - -export type props = { - readonly actions?: actions; - readonly person: person; - readonly children: children; - readonly renderMe: renderMe -}; - -export const CompV4_make: React.ComponentType<{ readonly x: string; readonly y: string }> = JSXV4JS.CompV4.make as any; - -export type Props = { readonly x: string; readonly y: string }; - -export const CompV3_make: React.ComponentType<{ readonly x: string; readonly y: string }> = JSXV4JS.CompV3.make as any; - -export const CompV3: { make: React.ComponentType<{ readonly x: string; readonly y: string }> } = JSXV4JS.CompV3 as any; - -export const CompV4: { make: React.ComponentType<{ readonly x: string; readonly y: string }> } = JSXV4JS.CompV4 as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/JSXV4.res b/jscomp/gentype_tests/typescript-react-example/src/JSXV4.res deleted file mode 100644 index fc4ed11..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/JSXV4.res +++ /dev/null @@ -1,33 +0,0 @@ -@@jsxConfig({version: 4}) - -@genType -module CompV4 = { - @react.component - let make = (~x, ~y) => React.string(x ++ y) -} - -@@jsxConfig({version: 3}) - -@genType -module CompV3 = { - @react.component - let make = (~x, ~y) => React.string(x ++ y) -} - -@genType -type person = { - name: string, - age: int, -} - -@genType type renderMe<'a> = React.component<{"randomString": string, "poly": 'a}> - -@@jsxConfig({version: 4}) - -@genType.import("./hookExample") @react.component -external make: ( - ~actions: React.element=?, - ~person: person, - ~children: React.element, - ~renderMe: renderMe<'a>, -) => React.element = "make" diff --git a/jscomp/gentype_tests/typescript-react-example/src/JSXV4.res.js b/jscomp/gentype_tests/typescript-react-example/src/JSXV4.res.js deleted file mode 100644 index 7fec159..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/JSXV4.res.js +++ /dev/null @@ -1,28 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as JSXV4Gen from "./JSXV4.gen"; - -function JSXV4$CompV4(props) { - return props.x + props.y; -} - -var CompV4 = { - make: JSXV4$CompV4 -}; - -function JSXV4$CompV3(Props) { - return Props.x + Props.y; -} - -var CompV3 = { - make: JSXV4$CompV3 -}; - -var make = JSXV4Gen.make; - -export { - CompV4 , - CompV3 , - make , -} -/* make Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.gen.tsx deleted file mode 100644 index dad8e55..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from LabeledFun.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as LabeledFunJS from './LabeledFun.res.js'; - -export const labelled: (a:number, b:(undefined | number), c:number, _4:number, e:number, f:number) => number = LabeledFunJS.labelled as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.res b/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.res deleted file mode 100644 index 42956e6..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let labelled = (a, ~b=3, ~c, d, ~e, ~f) => a + b + c + d + e + f diff --git a/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.res.js b/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.res.js deleted file mode 100644 index 2be82a1..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/LabeledFun.res.js +++ /dev/null @@ -1,12 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function labelled(a, bOpt, c, d, e, f) { - var b = bOpt !== undefined ? bOpt : 3; - return ((((a + b | 0) + c | 0) + d | 0) + e | 0) + f | 0; -} - -export { - labelled , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.gen.tsx deleted file mode 100644 index 4e8a975..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from LetPrivate.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as LetPrivateJS from './LetPrivate.res.js'; - -export const y: number = LetPrivateJS.y as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.res b/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.res deleted file mode 100644 index b48e7d4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.res +++ /dev/null @@ -1,3 +0,0 @@ -%%private(@genType let x = 34) - -@genType let y = x diff --git a/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.res.js b/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.res.js deleted file mode 100644 index d872769..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/LetPrivate.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var y = 34; - -export { - y , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Lib.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Lib.gen.tsx deleted file mode 100644 index 83b8e67..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Lib.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from Lib.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type action = - { action: "A"; _0: string } - | { action: "B"; _0: string }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Lib.res b/jscomp/gentype_tests/typescript-react-example/src/Lib.res deleted file mode 100644 index 9676ebe..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Lib.res +++ /dev/null @@ -1,6 +0,0 @@ -@gentype -@tag("action") -type action = | A(string) | B(string) - -let a = A("a") -let b = B("b") diff --git a/jscomp/gentype_tests/typescript-react-example/src/Lib.res.js b/jscomp/gentype_tests/typescript-react-example/src/Lib.res.js deleted file mode 100644 index 744468f..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Lib.res.js +++ /dev/null @@ -1,18 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var a = { - action: "A", - _0: "a" -}; - -var b = { - action: "B", - _0: "b" -}; - -export { - a , - b , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Machine.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Machine.gen.tsx deleted file mode 100644 index 9f96470..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Machine.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from Machine.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as MachineJS from './Machine.res.js'; - -export type aa = { TAG: "A"; _0: number }; - -export const a: aa = MachineJS.a as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Machine.res b/jscomp/gentype_tests/typescript-react-example/src/Machine.res deleted file mode 100644 index 57d0823..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Machine.res +++ /dev/null @@ -1,4 +0,0 @@ -type aa = A(int) - -@genType -let a = A(3) diff --git a/jscomp/gentype_tests/typescript-react-example/src/Machine.res.js b/jscomp/gentype_tests/typescript-react-example/src/Machine.res.js deleted file mode 100644 index 6ec8981..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Machine.res.js +++ /dev/null @@ -1,12 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var a = { - TAG: "A", - _0: 3 -}; - -export { - a , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Map_.res b/jscomp/gentype_tests/typescript-react-example/src/Map_.res deleted file mode 100644 index 9f77470..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Map_.res +++ /dev/null @@ -1 +0,0 @@ -type t<'k, 'v> diff --git a/jscomp/gentype_tests/typescript-react-example/src/Map_.res.js b/jscomp/gentype_tests/typescript-react-example/src/Map_.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Map_.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.gen.tsx deleted file mode 100644 index 6f6a95e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.gen.tsx +++ /dev/null @@ -1,26 +0,0 @@ -/* TypeScript file generated from ModuleAliases.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as ModuleAliasesJS from './ModuleAliases.res.js'; - -export type Outer_Inner_innerT = { readonly inner: string }; - -export type Outer2_Inner2_InnerNested_t = { readonly nested: number }; - -export type Outer2_OuterInnerAlias_innerT = Outer_Inner_innerT; - -export type Outer2_Inner2_OuterInnerAlias2_innerT = Outer2_OuterInnerAlias_innerT; - -export type Outer2Alias_OuterInnerAlias_innerT = Outer2_OuterInnerAlias_innerT; - -export type Outer2Alias_Inner2_OuterInnerAlias2_innerT = Outer2_Inner2_OuterInnerAlias2_innerT; - -export type InnerNestedAlias_t = Outer2_Inner2_InnerNested_t; - -export const testNested: (x:InnerNestedAlias_t) => InnerNestedAlias_t = ModuleAliasesJS.testNested as any; - -export const testInner: (x:Outer2Alias_OuterInnerAlias_innerT) => Outer2Alias_OuterInnerAlias_innerT = ModuleAliasesJS.testInner as any; - -export const testInner2: (x:Outer2Alias_Inner2_OuterInnerAlias2_innerT) => Outer2Alias_Inner2_OuterInnerAlias2_innerT = ModuleAliasesJS.testInner2 as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.res b/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.res deleted file mode 100644 index fb1a2ed..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.res +++ /dev/null @@ -1,25 +0,0 @@ -module Outer = { - module Inner = { - type innerT = {inner: string} - } -} - -module Outer2 = { - module OuterInnerAlias = Outer.Inner - module Inner2 = { - module InnerNested = { - type t = {nested: int} - } - module OuterInnerAlias2 = OuterInnerAlias - } -} - -module Outer2Alias = Outer2 - -module InnerNestedAlias = Outer2.Inner2.InnerNested - -@genType let testNested = (x: InnerNestedAlias.t) => x - -@genType let testInner = (x: Outer2Alias.OuterInnerAlias.innerT) => x - -@genType let testInner2 = (x: Outer2Alias.Inner2.OuterInnerAlias2.innerT) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.res.js b/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.res.js deleted file mode 100644 index 0ff799c..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases.res.js +++ /dev/null @@ -1,47 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var Inner = {}; - -var Outer = { - Inner: Inner -}; - -var InnerNested = {}; - -var Inner2 = { - InnerNested: InnerNested, - OuterInnerAlias2: undefined -}; - -var Outer2 = { - OuterInnerAlias: undefined, - Inner2: Inner2 -}; - -function testNested(x) { - return x; -} - -function testInner(x) { - return x; -} - -function testInner2(x) { - return x; -} - -var Outer2Alias; - -var InnerNestedAlias; - -export { - Outer , - Outer2 , - Outer2Alias , - InnerNestedAlias , - testNested , - testInner , - testInner2 , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.gen.tsx deleted file mode 100644 index e5cf11b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.gen.tsx +++ /dev/null @@ -1,16 +0,0 @@ -/* TypeScript file generated from ModuleAliases2.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type record = { readonly x: number; readonly y: string }; - -export type Outer_outer = { readonly outer: string }; - -export type Outer_Inner_inner = { readonly inner: string }; - -export type OuterAlias_outer = Outer_outer; - -export type OuterAlias_Inner_inner = Outer_Inner_inner; - -export type InnerAlias_inner = OuterAlias_Inner_inner; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.res b/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.res deleted file mode 100644 index 53b28c6..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.res +++ /dev/null @@ -1,19 +0,0 @@ -@genType -type record = { - x: int, - y: string, -} - -module Outer = { - @genType type outer = {outer: string} - - module Inner = { - @genType type inner = {inner: string} - } -} - -module OuterAlias = Outer - -module InnerAlias = OuterAlias.Inner - -let q = 42 diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.res.js b/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.res.js deleted file mode 100644 index 4be3b83..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleAliases2.res.js +++ /dev/null @@ -1,22 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var Inner = {}; - -var Outer = { - Inner: Inner -}; - -var OuterAlias; - -var InnerAlias; - -var q = 42; - -export { - Outer , - OuterAlias , - InnerAlias , - q , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.gen.tsx deleted file mode 100644 index 3fe5123..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.gen.tsx +++ /dev/null @@ -1,6 +0,0 @@ -/* TypeScript file generated from ModuleResolution1.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type t1 = { readonly foo: string; readonly bar: number }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.res b/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.res deleted file mode 100644 index 8bfad4e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.res +++ /dev/null @@ -1,5 +0,0 @@ -@genType -type t1 = { - foo: string, - bar: int, -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.res.js b/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution1.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.gen.tsx deleted file mode 100644 index d9e793e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from ModuleResolution2.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import type {t1 as ModuleResolution1_t1} from './ModuleResolution1.gen'; - -export type t2 = { readonly dependency: ModuleResolution1_t1 }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.res b/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.res deleted file mode 100644 index 5b29992..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -type t2 = {dependency: ModuleResolution1.t1} diff --git a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.res.js b/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/ModuleResolution2.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.gen.tsx deleted file mode 100644 index 9da0296..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.gen.tsx +++ /dev/null @@ -1,14 +0,0 @@ -/* TypeScript file generated from MoreVariants.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as MoreVariantsJS from './MoreVariants.res.js'; - -export type withRenaming = "type_" | "b"; - -export type withoutRenaming = "type_" | "b"; - -export const testWithRenaming: (x:withRenaming) => withRenaming = MoreVariantsJS.testWithRenaming as any; - -export const testWithoutRenaming: (x:withoutRenaming) => withoutRenaming = MoreVariantsJS.testWithoutRenaming as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.res b/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.res deleted file mode 100644 index 1862b7a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.res +++ /dev/null @@ -1,12 +0,0 @@ -@genType -type withRenaming = [@genType.as("type") #type_ | #b] - -@genType -let testWithRenaming = (x: withRenaming) => x - -@genType -type withoutRenaming = [#type_ | #b] - -@genType -let testWithoutRenaming = (x: withoutRenaming) => x - diff --git a/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.res.js b/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.res.js deleted file mode 100644 index 833cc29..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MoreVariants.res.js +++ /dev/null @@ -1,16 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function testWithRenaming(x) { - return x; -} - -function testWithoutRenaming(x) { - return x; -} - -export { - testWithRenaming , - testWithoutRenaming , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyInput.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/MyInput.gen.tsx deleted file mode 100644 index ad85bb4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyInput.gen.tsx +++ /dev/null @@ -1,18 +0,0 @@ -/* TypeScript file generated from MyInput.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import {default as defaultNotChecked} from './MyInput'; - -// In case of type error, check the type of 'default' in 'MyInput.res' and './MyInput'. -export const defaultTypeChecked: React.ComponentType<{ readonly onFocus?: (_1:inputFocusEvent) => void }> = defaultNotChecked as any; - -// Export '$$default' early to allow circular import from the '.bs.js' file. -export const $$default: unknown = defaultTypeChecked as React.ComponentType<{ readonly onFocus?: (_1:inputFocusEvent) => void }> as any; - -import type {inputFocusEvent as $$inputFocusEvent} from './shims/ReactEvent.shim'; - -export type inputFocusEvent = $$inputFocusEvent; - -export default $$default; diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyInput.res b/jscomp/gentype_tests/typescript-react-example/src/MyInput.res deleted file mode 100644 index 6415dc1..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyInput.res +++ /dev/null @@ -1,5 +0,0 @@ -@genType.import("./shims/ReactEvent.shim") -type inputFocusEvent = ReactEvent.Focus.t - -@genType.import("./MyInput") @react.component -external make: (~onFocus: inputFocusEvent => unit=?) => React.element = "default" diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyInput.res.js b/jscomp/gentype_tests/typescript-react-example/src/MyInput.res.js deleted file mode 100644 index 3aa6ca7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyInput.res.js +++ /dev/null @@ -1,10 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import MyInputGen from "./MyInput.gen"; - -var make = MyInputGen; - -export { - make , -} -/* make Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyInput.tsx b/jscomp/gentype_tests/typescript-react-example/src/MyInput.tsx deleted file mode 100644 index 3f275ef..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyInput.tsx +++ /dev/null @@ -1,7 +0,0 @@ -import * as React from "react"; - -type Props = React.InputHTMLAttributes; - -const MyInput: React.FC = (props) => - -export default MyInput; diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyMath.ts b/jscomp/gentype_tests/typescript-react-example/src/MyMath.ts deleted file mode 100644 index 55ea301..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyMath.ts +++ /dev/null @@ -1,46 +0,0 @@ -/* @flow strict */ - -export const round: (_: number) => number = Math.round; - -export const round2 = round; - -export const area = function(point: { x: number; y?: number }): number { - return point.x * (point.y === undefined ? 1 : point.y); -}; - -export type numberOrString = number | string; - -export const returnMixedArray = function() : Array { - return [1,2]; -}; - -export class AbsoluteValue { - public prop!: number; - public getProp(): number { - return this.prop; - } - public getAbs(): number { - return this.prop < 0 ? -this.prop : this.prop; - } -} - -export type stringFunction = (_: string) => string; - -// eslint-disable-next-line @typescript-eslint/no-unused-vars -export const useColor = function(x: "tomato" | "gray"): number { - return 0; -}; - -export const higherOrder = (foo: (_1: number, _2: number) => number) => - foo(3, 4); - -// eslint-disable-next-line @typescript-eslint/no-explicit-any -export const convertVariant = (x: any) => x; - -export const polymorphic = (x: T): T => x; - -export type num = number; - -export type polyType = { x: T }; - -export default 34; diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyModule.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/MyModule.gen.tsx deleted file mode 100644 index 37a3a3b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyModule.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from MyModule.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as MyModuleJS from './MyModule.res.js'; - -export type t = number; - -export const add: (a:t, b:t) => t = MyModuleJS.add as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyModule.res b/jscomp/gentype_tests/typescript-react-example/src/MyModule.res deleted file mode 100644 index 07d4f77..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyModule.res +++ /dev/null @@ -1,5 +0,0 @@ -@genType -type t = int - -@genType -let add = (a: t, b: t): t => a + b diff --git a/jscomp/gentype_tests/typescript-react-example/src/MyModule.res.js b/jscomp/gentype_tests/typescript-react-example/src/MyModule.res.js deleted file mode 100644 index 3377033..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/MyModule.res.js +++ /dev/null @@ -1,11 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function add(a, b) { - return a + b | 0; -} - -export { - add , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedModules.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/NestedModules.gen.tsx deleted file mode 100644 index ad6d2fa..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedModules.gen.tsx +++ /dev/null @@ -1,41 +0,0 @@ -/* TypeScript file generated from NestedModules.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as NestedModulesJS from './NestedModules.res.js'; - -export type Universe_nestedType = string[]; - -export type Universe_Nested2_nested2Type = Array; - -export type Universe_Nested2_Nested3_nested3Type = Array>; - -export type Universe_variant = "A" | { TAG: "B"; _0: string }; - -export const notNested: number = NestedModulesJS.notNested as any; - -export const Universe_theAnswer: number = NestedModulesJS.Universe.theAnswer as any; - -export const Universe_Nested2_nested2Value: number = NestedModulesJS.Universe.Nested2.nested2Value as any; - -export const Universe_Nested2_Nested3_nested3Value: string = NestedModulesJS.Universe.Nested2.Nested3.nested3Value as any; - -export const Universe_Nested2_Nested3_nested3Function: (x:Universe_Nested2_nested2Type) => Universe_Nested2_nested2Type = NestedModulesJS.Universe.Nested2.Nested3.nested3Function as any; - -export const Universe_Nested2_nested2Function: (x:Universe_Nested2_Nested3_nested3Type) => Universe_Nested2_Nested3_nested3Type = NestedModulesJS.Universe.Nested2.nested2Function as any; - -export const Universe_someString: string = NestedModulesJS.Universe.someString as any; - -export const Universe: { - theAnswer: number; - Nested2: { - nested2Function: (x:Universe_Nested2_Nested3_nested3Type) => Universe_Nested2_Nested3_nested3Type; - nested2Value: number; - Nested3: { - nested3Value: string; - nested3Function: (x:Universe_Nested2_nested2Type) => Universe_Nested2_nested2Type - } - }; - someString: string -} = NestedModulesJS.Universe as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedModules.res b/jscomp/gentype_tests/typescript-react-example/src/NestedModules.res deleted file mode 100644 index 7c66bc0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedModules.res +++ /dev/null @@ -1,41 +0,0 @@ -@genType let notNested = 1 - -module Universe = { - @genType let theAnswer = 42 - - let notExported = 33 - - @genType type nestedType = array - - module Nested2 = { - let x = 0 - - @genType let nested2Value = 1 - - let y = 2 - - @genType type nested2Type = array> - - module Nested3 = { - let x = 0 - let y = 1 - let z = 2 - let w = 3 - - @genType type nested3Type = array>> - - @genType let nested3Value = "nested3Value" - - @genType let nested3Function = (x: nested2Type) => x - } - - @genType let nested2Function = (x: Nested3.nested3Type) => x - } - - @genType - type variant = - | A - | B(string) - - @genType let someString = "some exported string" -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedModules.res.js b/jscomp/gentype_tests/typescript-react-example/src/NestedModules.res.js deleted file mode 100644 index 654fd2e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedModules.res.js +++ /dev/null @@ -1,42 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function nested3Function(x) { - return x; -} - -var Nested3 = { - x: 0, - y: 1, - z: 2, - w: 3, - nested3Value: "nested3Value", - nested3Function: nested3Function -}; - -function nested2Function(x) { - return x; -} - -var Nested2 = { - x: 0, - nested2Value: 1, - y: 2, - Nested3: Nested3, - nested2Function: nested2Function -}; - -var Universe = { - theAnswer: 42, - notExported: 33, - Nested2: Nested2, - someString: "some exported string" -}; - -var notNested = 1; - -export { - notNested , - Universe , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.gen.tsx deleted file mode 100644 index 2e4577b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from NestedModulesInSignature.resi by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as NestedModulesInSignatureJS from './NestedModulesInSignature.res.js'; - -export const Universe_theAnswer: number = NestedModulesInSignatureJS.Universe.theAnswer as any; - -export const Universe: { theAnswer: number } = NestedModulesInSignatureJS.Universe as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.res b/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.res deleted file mode 100644 index 85f454d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.res +++ /dev/null @@ -1,3 +0,0 @@ -module Universe = { - let theAnswer = 42 -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.res.js b/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.res.js deleted file mode 100644 index 394291d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.res.js +++ /dev/null @@ -1,11 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var Universe = { - theAnswer: 42 -}; - -export { - Universe , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.resi b/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.resi deleted file mode 100644 index 68bf5db..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedModulesInSignature.resi +++ /dev/null @@ -1,3 +0,0 @@ -module Universe: { - @genType let theAnswer: int -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.gen.tsx deleted file mode 100644 index 529c7e7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.gen.tsx +++ /dev/null @@ -1,71 +0,0 @@ -/* TypeScript file generated from NestedVariants.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as NestedVariantsJS from './NestedVariants.res.js'; - -export type typeL = - { TAG: "NonUnary"; _0: number; _1: number }; - -export type typeC = - { TAG: "C"; _0: string } - | { TAG: "D"; _0: string }; - -export type typeB = { readonly c: typeC }; - -export type typeD = { TAG: "Int"; _0: number }; - -export type typeE = number; - -export type typeA = - { TAG: "A"; _0: a; _1: number } - | { TAG: "B"; _0: a; _1: number }; - -export type typeF = { TAG: "F"; _0: a } | { TAG: "G"; _0: a }; - -export type typeH = - { TAG: "H"; _0: typeD; _1: number } - | { TAG: "I"; _0: typeD; _1: number }; - -export type typeJ = { TAG: "J"; _0: typeD; _1: typeD }; - -export type typeK = { TAG: "K"; _0: typeD; _1: typeD }; - -export type boxedBinary = - { TAG: "BB"; _0: typeD; _1: number } - | { TAG: "Z"; _0: number }; - -export type unboxedBinary = { TAG: "UB"; _0: typeD; _1: number }; - -export type inline = - { TAG: "I"; readonly i: number; readonly j: number } - | { TAG: "J"; readonly i: number; readonly j: number } - | { TAG: "K"; _0: number; _1: number } - | { TAG: "L"; _0: { readonly j: number; readonly i: number } }; - -export const makeVariant: () => typeL = NestedVariantsJS.makeVariant as any; - -export const makeABC: () => typeA = NestedVariantsJS.makeABC as any; - -export const makeBC: () => typeB = NestedVariantsJS.makeBC as any; - -export const makeAC: () => typeA = NestedVariantsJS.makeAC as any; - -export const makeAD: () => typeA = NestedVariantsJS.makeAD as any; - -export const makeAE: () => typeA = NestedVariantsJS.makeAE as any; - -export const makeFD: () => typeF = NestedVariantsJS.makeFD as any; - -export const makeHD: () => typeH = NestedVariantsJS.makeHD as any; - -export const makeJ: () => typeJ = NestedVariantsJS.makeJ as any; - -export const makeK: () => typeK = NestedVariantsJS.makeK as any; - -export const testBoxedBinary: (param:boxedBinary) => number = NestedVariantsJS.testBoxedBinary as any; - -export const testUnboxedBinary: (param:unboxedBinary) => number = NestedVariantsJS.testUnboxedBinary as any; - -export const testInline: (x:inline) => inline = NestedVariantsJS.testInline as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.res b/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.res deleted file mode 100644 index cb32d31..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.res +++ /dev/null @@ -1,80 +0,0 @@ -@genType -type typeL = NonUnary(int, int) - -@genType -let makeVariant = () => NonUnary(5, 3) - -type typeC = - | C(string) - | D(string) -type typeB = {c: typeC} -type typeD = Int(int) -type typeE = int -type typeA<'a> = - | A('a, int) - | B('a, int) - -type typeF<'a> = - | F('a) - | G('a) -type typeH = - | H(typeD, int) - | I(typeD, int) -type typeJ = J(typeD, typeD) -type typeK = K((typeD, typeD)) - -@genType -let makeABC = (): typeA => A({c: C("a string")}, 5) - -@genType -let makeBC = (): typeB => {c: C("a string")} - -@genType -let makeAC = (): typeA => A(C("a string"), 5) - -@genType -let makeAD = (): typeA => A(Int(3), 5) - -@genType -let makeAE = (): typeA => A(3, 5) - -@genType -let makeFD = (): typeF => F(Int(3)) - -@genType -let makeHD = (): typeH => H(Int(5), 5) - -@genType -let makeJ = (): typeJ => J(Int(5), Int(3)) - -@genType -let makeK = (): typeK => K((Int(5), Int(3))) - -@genType -type boxedBinary = - | BB(typeD, int) - | Z(int) -@genType -type unboxedBinary = UB(typeD, int) -@genType -type inline = - | I({i: int, j: int}) - | J({i: int, j: int}) - | K(int, int) - | L({"i": int, "j": int}) - -@genType -let testBoxedBinary = (_: boxedBinary) => 34 - -@genType -let testUnboxedBinary = (_: unboxedBinary) => 34 - -@genType -let testInline = x => - switch x { - | I(q) => I({...q, i: q.i}) - | J(q) => J(q) - | K(a, b) => K(b, a) - | L(q) => L(q) - } - diff --git a/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.res.js b/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.res.js deleted file mode 100644 index 81711cb..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NestedVariants.res.js +++ /dev/null @@ -1,163 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function makeVariant(param) { - return { - TAG: "NonUnary", - _0: 5, - _1: 3 - }; -} - -function makeABC(param) { - return { - TAG: "A", - _0: { - c: { - TAG: "C", - _0: "a string" - } - }, - _1: 5 - }; -} - -function makeBC(param) { - return { - c: { - TAG: "C", - _0: "a string" - } - }; -} - -function makeAC(param) { - return { - TAG: "A", - _0: { - TAG: "C", - _0: "a string" - }, - _1: 5 - }; -} - -function makeAD(param) { - return { - TAG: "A", - _0: { - TAG: "Int", - _0: 3 - }, - _1: 5 - }; -} - -function makeAE(param) { - return { - TAG: "A", - _0: 3, - _1: 5 - }; -} - -function makeFD(param) { - return { - TAG: "F", - _0: { - TAG: "Int", - _0: 3 - } - }; -} - -function makeHD(param) { - return { - TAG: "H", - _0: { - TAG: "Int", - _0: 5 - }, - _1: 5 - }; -} - -function makeJ(param) { - return { - TAG: "J", - _0: { - TAG: "Int", - _0: 5 - }, - _1: { - TAG: "Int", - _0: 3 - } - }; -} - -function makeK(param) { - return { - TAG: "K", - _0: [ - { - TAG: "Int", - _0: 5 - }, - { - TAG: "Int", - _0: 3 - } - ] - }; -} - -function testBoxedBinary(param) { - return 34; -} - -function testUnboxedBinary(param) { - return 34; -} - -function testInline(x) { - switch (x.TAG) { - case "I" : - return { - TAG: "I", - i: x.i, - j: x.j - }; - case "J" : - return x; - case "K" : - return { - TAG: "K", - _0: x._1, - _1: x._0 - }; - case "L" : - return { - TAG: "L", - _0: x._0 - }; - - } -} - -export { - makeVariant , - makeABC , - makeBC , - makeAC , - makeAD , - makeAE , - makeFD , - makeHD , - makeJ , - makeK , - testBoxedBinary , - testUnboxedBinary , - testInline , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.gen.tsx deleted file mode 100644 index 9842501..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.gen.tsx +++ /dev/null @@ -1,14 +0,0 @@ -/* TypeScript file generated from NonrecursiveTypes.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type notRecursive = number; - -export type M_notRecursive = notRecursive[]; - -export type M_recursive = { readonly self: M_recursive }; - -export type M_mutualRecursive = { readonly a: M_a }; - -export type M_a = { readonly self: M_mutualRecursive }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.res b/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.res deleted file mode 100644 index 9c76dc2..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.res +++ /dev/null @@ -1,14 +0,0 @@ -@genType -type notRecursive = int - -module M = { - @genType - type notRecursive = array - - @genType - type rec recursive = {self: recursive} - - @genType - type rec mutualRecursive = {a: a} - and a = {self: mutualRecursive} -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.res.js b/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.res.js deleted file mode 100644 index 44a5721..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NonrecursiveTypes.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var M = {}; - -export { - M , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Null.res b/jscomp/gentype_tests/typescript-react-example/src/Null.res deleted file mode 100644 index fff00a9..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Null.res +++ /dev/null @@ -1 +0,0 @@ -type t<'a> = Js.null<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/Null.res.js b/jscomp/gentype_tests/typescript-react-example/src/Null.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Null.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Nullable.res b/jscomp/gentype_tests/typescript-react-example/src/Nullable.res deleted file mode 100644 index 56a1921..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Nullable.res +++ /dev/null @@ -1 +0,0 @@ -type t<'a> = Js.nullable<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/Nullable.res.js b/jscomp/gentype_tests/typescript-react-example/src/Nullable.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Nullable.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.gen.tsx deleted file mode 100644 index aa422e0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.gen.tsx +++ /dev/null @@ -1,6 +0,0 @@ -/* TypeScript file generated from NumericPolyVar.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type t = 12 | 0 | "b"; diff --git a/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.res b/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.res deleted file mode 100644 index 0611a29..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -type t = [#12 | #0 | #b] diff --git a/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.res.js b/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/NumericPolyVar.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Object.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Object.gen.tsx deleted file mode 100644 index c8e3a51..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Object.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from Object.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type someType = { readonly crop?: string; readonly "fp-z"?: string }; - -export type someType2 = { readonly crop: (undefined | string); readonly "fp-z": (undefined | string) }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Object.res b/jscomp/gentype_tests/typescript-react-example/src/Object.res deleted file mode 100644 index e560af3..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Object.res +++ /dev/null @@ -1,13 +0,0 @@ -@genType -type someType = {"crop": option, "fp-z": option} - -@genType -type someType2 = { - crop: option, - @as("fp-z") - fpz: option, -} - -let st: someType = {"crop": None, "fp-z": None} - -let st2: someType2 = {crop: None, fpz: None} diff --git a/jscomp/gentype_tests/typescript-react-example/src/Object.res.js b/jscomp/gentype_tests/typescript-react-example/src/Object.res.js deleted file mode 100644 index e4b301d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Object.res.js +++ /dev/null @@ -1,18 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var st = { - crop: undefined, - "fp-z": undefined -}; - -var st2 = { - crop: undefined, - "fp-z": undefined -}; - -export { - st , - st2 , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/OnClick2.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/OnClick2.gen.tsx deleted file mode 100644 index 16b6cf3..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/OnClick2.gen.tsx +++ /dev/null @@ -1,12 +0,0 @@ -/* TypeScript file generated from OnClick2.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as React from 'react'; - -import * as OnClick2JS from './OnClick2.res.js'; - -export type Props = { readonly onClick: (_1:MouseEvent) => void }; - -export const make: React.ComponentType<{ readonly onClick: (_1:MouseEvent) => void }> = OnClick2JS.make as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/OnClick2.res b/jscomp/gentype_tests/typescript-react-example/src/OnClick2.res deleted file mode 100644 index 7094f37..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/OnClick2.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType @react.component -let make = (~onClick) =>
diff --git a/jscomp/gentype_tests/typescript-react-example/src/OnClick2.res.js b/jscomp/gentype_tests/typescript-react-example/src/OnClick2.res.js deleted file mode 100644 index 61e88f2..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/OnClick2.res.js +++ /dev/null @@ -1,17 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as React from "react"; - -function OnClick2(Props) { - var onClick = Props.onClick; - return React.createElement("div", { - onClick: onClick - }); -} - -var make = OnClick2; - -export { - make , -} -/* react Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Opaque.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Opaque.gen.tsx deleted file mode 100644 index 5b30072..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Opaque.gen.tsx +++ /dev/null @@ -1,16 +0,0 @@ -/* TypeScript file generated from Opaque.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as OpaqueJS from './Opaque.res.js'; - -import type {business as Records_business} from './Records.gen'; - -export abstract class opaqueFromRecords { protected opaque!: any }; /* simulate opaque types */ - -export type pair = [opaqueFromRecords, opaqueFromRecords]; - -export const noConversion: (x:opaqueFromRecords) => opaqueFromRecords = OpaqueJS.noConversion as any; - -export const testConvertNestedRecordFromOtherFile: (x:Records_business) => Records_business = OpaqueJS.testConvertNestedRecordFromOtherFile as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Opaque.res b/jscomp/gentype_tests/typescript-react-example/src/Opaque.res deleted file mode 100644 index bd41c97..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Opaque.res +++ /dev/null @@ -1,8 +0,0 @@ -@genType.opaque -type opaqueFromRecords = A(Records.coord) - -@genType let noConversion = (x: opaqueFromRecords) => x - -@genType type pair = (opaqueFromRecords, opaqueFromRecords) - -@genType let testConvertNestedRecordFromOtherFile = (x: Records.business) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/Opaque.res.js b/jscomp/gentype_tests/typescript-react-example/src/Opaque.res.js deleted file mode 100644 index 7639ea3..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Opaque.res.js +++ /dev/null @@ -1,16 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function noConversion(x) { - return x; -} - -function testConvertNestedRecordFromOtherFile(x) { - return x; -} - -export { - noConversion , - testConvertNestedRecordFromOtherFile , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Promise.res b/jscomp/gentype_tests/typescript-react-example/src/Promise.res deleted file mode 100644 index 4e149cf..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Promise.res +++ /dev/null @@ -1 +0,0 @@ -type t<'a> = promise<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/Promise.res.js b/jscomp/gentype_tests/typescript-react-example/src/Promise.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Promise.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Records.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Records.gen.tsx deleted file mode 100644 index f605dc6..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Records.gen.tsx +++ /dev/null @@ -1,108 +0,0 @@ -/* TypeScript file generated from Records.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as RecordsJS from './Records.res.js'; - -import type {list} from '../src/shims/RescriptPervasives.shim'; - -export type coord = { - readonly x: number; - readonly y: number; - readonly z: (undefined | number) -}; - -export type person = { - readonly name: string; - readonly age: number; - readonly address: (undefined | string) -}; - -export type business = { - readonly name: string; - readonly owner: (undefined | person); - readonly address: (undefined | string) -}; - -export type payload = { readonly num: number; readonly payload: a }; - -export type record = { readonly v: number; readonly w: number }; - -export type business2 = { - readonly name: string; - readonly owner: (null | undefined | person); - readonly address2: (null | undefined | string) -}; - -export type mix = { - readonly a: number; - readonly b: number; - readonly c?: { - readonly name: string; - readonly surname: string - } -}; - -export type myRec = { readonly type: string }; - -export type myObj = { readonly type_: string }; - -export type myRecBsAs = { - readonly jsValid0: string; - readonly type: string; - readonly "the-key": string; - readonly "with\\\"dquote": string; - readonly "with'squote": string; - readonly "1number": string -}; - -export const origin: coord = RecordsJS.origin as any; - -export const computeArea: (param:coord) => number = RecordsJS.computeArea as any; - -export const coord2d: (x:number, y:number) => coord = RecordsJS.coord2d as any; - -export const findAddress: (business:business) => list = RecordsJS.findAddress as any; - -export const someBusiness: business = RecordsJS.someBusiness as any; - -export const findAllAddresses: (businesses:business[]) => string[] = RecordsJS.findAllAddresses as any; - -export const getPayload: (param:payload) => T1 = RecordsJS.getPayload as any; - -export const getPayloadRecord: (param:payload) => record = RecordsJS.getPayloadRecord as any; - -export const recordValue: record = RecordsJS.recordValue as any; - -export const payloadValue: payload = RecordsJS.payloadValue as any; - -export const getPayloadRecordPlusOne: (param:payload) => record = RecordsJS.getPayloadRecordPlusOne as any; - -export const findAddress2: (business:business2) => list = RecordsJS.findAddress2 as any; - -export const someBusiness2: business2 = RecordsJS.someBusiness2 as any; - -export const computeArea3: (o:{ - readonly x: number; - readonly y: number; - readonly z: (null | undefined | number) -}) => number = RecordsJS.computeArea3 as any; - -export const computeArea4: (o:{ - readonly x: number; - readonly y: number; - readonly z?: number -}) => number = RecordsJS.computeArea4 as any; - -export const testMyRec: (x:myRec) => string = RecordsJS.testMyRec as any; - -export const testMyRec2: (x:myRec) => myRec = RecordsJS.testMyRec2 as any; - -export const testMyObj: (x:myObj) => string = RecordsJS.testMyObj as any; - -export const testMyObj2: (x:myObj) => myObj = RecordsJS.testMyObj2 as any; - -export const testMyRecBsAs: (x:myRecBsAs) => string[] = RecordsJS.testMyRecBsAs as any; - -export const testMyRecBsAs2: (x:myRecBsAs) => myRecBsAs = RecordsJS.testMyRecBsAs2 as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Records.res b/jscomp/gentype_tests/typescript-react-example/src/Records.res deleted file mode 100644 index c8485e0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Records.res +++ /dev/null @@ -1,151 +0,0 @@ -open Belt - -@genType -type coord = { - x: int, - y: int, - z: option, -} - -@genType let origin = {x: 0, y: 0, z: Some(0)} - -@genType -let computeArea = ({x, y, z}) => { - open Option - x * y * z->mapWithDefault(1, n => n) -} - -@genType let coord2d = (x, y) => {x, y, z: None} - -@genType -type person = { - name: string, - age: int, - address: option, -} - -@genType -type business = { - name: string, - owner: option, - address: option, -} - -let getOpt = (opt, default, foo) => opt->Option.mapWithDefault(default, foo) - -@genType -let findAddress = (business: business): list => - business.address->getOpt(list{}, a => list{a}) - -@genType let someBusiness = {name: "SomeBusiness", owner: None, address: None} - -@genType -let findAllAddresses = (businesses: array): array => - businesses - ->Array.map(business => - Belt.List.concat( - business.address->getOpt(list{}, a => list{a}), - business.owner->getOpt(list{}, p => p.address->getOpt(list{}, a => list{a})), - ) - ) - ->List.fromArray - ->List.flatten - ->List.toArray - -@genType -type payload<'a> = { - num: int, - payload: 'a, -} - -@genType let getPayload = ({payload}) => payload - -@genType -type record = { - v: int, - w: int, -} - -@genType let getPayloadRecord = ({payload}): record => payload - -@genType let recordValue = {v: 1, w: 1} - -@genType let payloadValue = {num: 1, payload: recordValue} - -@genType -let getPayloadRecordPlusOne = ({payload}): record => { - ...payload, - v: payload.v + 1, -} - -@genType -type business2 = { - name: string, - owner: Js.Nullable.t, - address2: Js.Nullable.t, -} - -@genType -let findAddress2 = (business: business2): list => - business.address2->Js.Nullable.toOption->getOpt(list{}, a => list{a}) - -@genType -let someBusiness2 = { - name: "SomeBusiness", - owner: Js.Nullable.null, - address2: Js.Nullable.null, -} - -@genType -let computeArea3 = (o: {"x": int, "y": int, "z": Js.Nullable.t}) => - o["x"] * o["y"] * o["z"]->Js.Nullable.toOption->Option.mapWithDefault(1, n => n) - -@genType -let computeArea4 = (o: {"x": int, "y": int, "z": option}) => - o["x"] * o["y"] * o["z"]->Option.mapWithDefault(1, n => n) - -@genType type mix = {"a": int, "b": int, "c": option<{"name": string, "surname": string}>} - -@genType -type myRec = { - @as("type") - type_: string, -} - -@genType type myObj = {"type_": string} - -@genType let testMyRec = (x: myRec) => x.type_ - -@genType let testMyRec2 = (x: myRec) => x - -@genType let testMyObj = (x: myObj) => x["type_"] - -@genType let testMyObj2 = (x: myObj) => x - -@genType -type myRecBsAs = { - @as("jsValid0") - valid: string, - @as("type") - type_: string, - @as("the-key") - theKey: string, - @as("with\"dquote") - withDQuote: string, - @as("with'squote") - withSQuote: string, - @as("1number") - number1: string, -} - -@genType -let testMyRecBsAs = (x: myRecBsAs) => [ - x.valid, - x.type_, - x.theKey, - x.withDQuote, - x.withSQuote, - x.number1, -] - -@genType let testMyRecBsAs2 = (x: myRecBsAs) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/Records.res.js b/jscomp/gentype_tests/typescript-react-example/src/Records.res.js deleted file mode 100644 index f727404..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Records.res.js +++ /dev/null @@ -1,175 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Belt_List from "rescript/lib/es6/belt_List.js"; -import * as Belt_Array from "rescript/lib/es6/belt_Array.js"; -import * as Belt_Option from "rescript/lib/es6/belt_Option.js"; -import * as Caml_option from "rescript/lib/es6/caml_option.js"; - -function computeArea(param) { - return Math.imul(Math.imul(param.x, param.y), Belt_Option.mapWithDefault(param.z, 1, (function (n) { - return n; - }))); -} - -function coord2d(x, y) { - return { - x: x, - y: y, - z: undefined - }; -} - -var getOpt = Belt_Option.mapWithDefault; - -function findAddress(business) { - return Belt_Option.mapWithDefault(business.address, /* [] */0, (function (a) { - return { - hd: a, - tl: /* [] */0 - }; - })); -} - -function findAllAddresses(businesses) { - return Belt_List.toArray(Belt_List.flatten(Belt_List.fromArray(Belt_Array.map(businesses, (function (business) { - return Belt_List.concat(Belt_Option.mapWithDefault(business.address, /* [] */0, (function (a) { - return { - hd: a, - tl: /* [] */0 - }; - })), Belt_Option.mapWithDefault(business.owner, /* [] */0, (function (p) { - return Belt_Option.mapWithDefault(p.address, /* [] */0, (function (a) { - return { - hd: a, - tl: /* [] */0 - }; - })); - }))); - }))))); -} - -function getPayload(param) { - return param.payload; -} - -function getPayloadRecord(param) { - return param.payload; -} - -var recordValue = { - v: 1, - w: 1 -}; - -var payloadValue = { - num: 1, - payload: recordValue -}; - -function getPayloadRecordPlusOne(param) { - var payload = param.payload; - return { - v: payload.v + 1 | 0, - w: payload.w - }; -} - -function findAddress2(business) { - return Belt_Option.mapWithDefault(Caml_option.nullable_to_opt(business.address2), /* [] */0, (function (a) { - return { - hd: a, - tl: /* [] */0 - }; - })); -} - -var someBusiness2_owner = null; - -var someBusiness2_address2 = null; - -var someBusiness2 = { - name: "SomeBusiness", - owner: someBusiness2_owner, - address2: someBusiness2_address2 -}; - -function computeArea3(o) { - return Math.imul(Math.imul(o.x, o.y), Belt_Option.mapWithDefault(Caml_option.nullable_to_opt(o.z), 1, (function (n) { - return n; - }))); -} - -function computeArea4(o) { - return Math.imul(Math.imul(o.x, o.y), Belt_Option.mapWithDefault(o.z, 1, (function (n) { - return n; - }))); -} - -function testMyRec(x) { - return x.type; -} - -function testMyRec2(x) { - return x; -} - -function testMyObj(x) { - return x.type_; -} - -function testMyObj2(x) { - return x; -} - -function testMyRecBsAs(x) { - return [ - x.jsValid0, - x.type, - x["the-key"], - x["with\\\"dquote"], - x["with'squote"], - x["1number"] - ]; -} - -function testMyRecBsAs2(x) { - return x; -} - -var origin = { - x: 0, - y: 0, - z: 0 -}; - -var someBusiness = { - name: "SomeBusiness", - owner: undefined, - address: undefined -}; - -export { - origin , - computeArea , - coord2d , - getOpt , - findAddress , - someBusiness , - findAllAddresses , - getPayload , - getPayloadRecord , - recordValue , - payloadValue , - getPayloadRecordPlusOne , - findAddress2 , - someBusiness2 , - computeArea3 , - computeArea4 , - testMyRec , - testMyRec2 , - testMyObj , - testMyObj2 , - testMyRecBsAs , - testMyRecBsAs2 , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/References.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/References.gen.tsx deleted file mode 100644 index ff722ab..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/References.gen.tsx +++ /dev/null @@ -1,28 +0,0 @@ -/* TypeScript file generated from References.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as ReferencesJS from './References.res.js'; - -export abstract class R_t { protected opaque!: a }; /* simulate opaque types */ - -export type t = R_t; - -export type requiresConversion = { readonly x: number }; - -export const create: (x:number) => { contents: number } = ReferencesJS.create as any; - -export const access: (r:{ contents: number }) => number = ReferencesJS.access as any; - -export const update: (r:{ contents: number }) => void = ReferencesJS.update as any; - -export const get: (_1:R_t) => T1 = ReferencesJS.get as any; - -export const make: (_1:T1) => R_t = ReferencesJS.make as any; - -export const set: (_1:R_t, _2:T1) => void = ReferencesJS.set as any; - -export const destroysRefIdentity: (x:{ contents: requiresConversion }) => { contents: requiresConversion } = ReferencesJS.destroysRefIdentity as any; - -export const preserveRefIdentity: (x:R_t) => R_t = ReferencesJS.preserveRefIdentity as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/References.res b/jscomp/gentype_tests/typescript-react-example/src/References.res deleted file mode 100644 index b00c8da..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/References.res +++ /dev/null @@ -1,38 +0,0 @@ -// Test pervasive references - -@genType let create = (x: int) => ref(x) - -@genType let access = r => r.contents + 1 - -@genType let update = r => r.contents = r.contents + 1 - -// Abstract version of references: works when conversion is required. - -module R: { - @genType type t<'a> - let get: t<'a> => 'a - let make: 'a => t<'a> - let set: (t<'a>, 'a) => unit -} = { - type t<'a> = ref<'a> - let get = r => r.contents - let make = ref - let set = (r, v) => r.contents = v -} - -@genType type t<'a> = R.t<'a> - -@genType let get = R.get - -@gentype -let make = R.make - -@genType let set = R.set - -type requiresConversion = {x: int} - -// Careful: conversion makes a copy and destroys the reference identity. -@genType let destroysRefIdentity = (x: ref) => x - -// Using abstract references preserves the identity. -@genType let preserveRefIdentity = (x: R.t) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/References.res.js b/jscomp/gentype_tests/typescript-react-example/src/References.res.js deleted file mode 100644 index b0b4088..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/References.res.js +++ /dev/null @@ -1,57 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function create(x) { - return { - contents: x - }; -} - -function access(r) { - return r.contents + 1 | 0; -} - -function update(r) { - r.contents = r.contents + 1 | 0; -} - -function get(r) { - return r.contents; -} - -function make(prim) { - return { - contents: prim - }; -} - -function set(r, v) { - r.contents = v; -} - -var R = { - get: get, - make: make, - set: set -}; - -function destroysRefIdentity(x) { - return x; -} - -function preserveRefIdentity(x) { - return x; -} - -export { - create , - access , - update , - R , - get , - make , - set , - destroysRefIdentity , - preserveRefIdentity , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/RegExp.res b/jscomp/gentype_tests/typescript-react-example/src/RegExp.res deleted file mode 100644 index afd4e13..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/RegExp.res +++ /dev/null @@ -1 +0,0 @@ -type t = Js.Re.t diff --git a/jscomp/gentype_tests/typescript-react-example/src/RegExp.res.js b/jscomp/gentype_tests/typescript-react-example/src/RegExp.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/RegExp.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/RequireCond.res b/jscomp/gentype_tests/typescript-react-example/src/RequireCond.res deleted file mode 100644 index b7fdd67..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/RequireCond.res +++ /dev/null @@ -1,19 +0,0 @@ -@module -@deprecated( - "Please use this syntax to guarantee safe usage: [%requireCond(`gk, \"gk_name\", ConditionalModule)]" -) -external make: ( - @string [@as("qe.bool") #qeBool | @as("gk") #gk], - string, - string, -) => Js.Nullable.t<'a> = "requireCond" - -@module -@deprecated( - "Please use this syntax to guarantee safe usage: [%requireCond(`gk, \"gk_name\", {\"true\": ModuleA, \"false\": ModuleB})]" -) -external either: ( - @string [@as("qe.bool") #qeBool | @as("gk") #gk], - string, - {"true": string, "false": string}, -) => 'b = "requireCond" diff --git a/jscomp/gentype_tests/typescript-react-example/src/RequireCond.res.js b/jscomp/gentype_tests/typescript-react-example/src/RequireCond.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/RequireCond.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Set_.res b/jscomp/gentype_tests/typescript-react-example/src/Set_.res deleted file mode 100644 index cfacdaa..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Set_.res +++ /dev/null @@ -1 +0,0 @@ -type t<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/Set_.res.js b/jscomp/gentype_tests/typescript-react-example/src/Set_.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Set_.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Shadow.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Shadow.gen.tsx deleted file mode 100644 index 4684ffd..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Shadow.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from Shadow.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as ShadowJS from './Shadow.res.js'; - -export const test: () => string = ShadowJS.test as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Shadow.res b/jscomp/gentype_tests/typescript-react-example/src/Shadow.res deleted file mode 100644 index f1fb444..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Shadow.res +++ /dev/null @@ -1,11 +0,0 @@ -@@warning("-32") - -@genType let test = () => 3 - -@genType let test = () => "a" - -module M = { - @genType let test = () => 3 - - let test = () => "a" -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/Shadow.res.js b/jscomp/gentype_tests/typescript-react-example/src/Shadow.res.js deleted file mode 100644 index 87be066..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Shadow.res.js +++ /dev/null @@ -1,20 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function test(param) { - return "a"; -} - -function test$1(param) { - return "a"; -} - -var M = { - test: test$1 -}; - -export { - test , - M , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.gen.tsx deleted file mode 100644 index c90395c..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.gen.tsx +++ /dev/null @@ -1,16 +0,0 @@ -/* TypeScript file generated from TestEmitInnerModules.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TestEmitInnerModulesJS from './TestEmitInnerModules.res.js'; - -export const Inner_x: number = TestEmitInnerModulesJS.Inner.x as any; - -export const Inner_y: string = TestEmitInnerModulesJS.Inner.y as any; - -export const Outer_Medium_Inner_y: number = TestEmitInnerModulesJS.Outer.Medium.Inner.y as any; - -export const Inner: { x: number; y: string } = TestEmitInnerModulesJS.Inner as any; - -export const Outer: { Medium: { Inner: { y: number } } } = TestEmitInnerModulesJS.Outer as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.res b/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.res deleted file mode 100644 index b36176e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.res +++ /dev/null @@ -1,12 +0,0 @@ -module Inner = { - @genType let x = 34 - @genType let y = "hello" -} - -module Outer = { - module Medium = { - module Inner = { - @genType let y = 44 - } - } -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.res.js b/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.res.js deleted file mode 100644 index 995314b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestEmitInnerModules.res.js +++ /dev/null @@ -1,25 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var Inner = { - x: 34, - y: "hello" -}; - -var Inner$1 = { - y: 44 -}; - -var Medium = { - Inner: Inner$1 -}; - -var Outer = { - Medium: Medium -}; - -export { - Inner , - Outer , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.gen.tsx deleted file mode 100644 index ee7c318..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.gen.tsx +++ /dev/null @@ -1,22 +0,0 @@ -/* TypeScript file generated from TestFirstClassModules.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TestFirstClassModulesJS from './TestFirstClassModules.res.js'; - -import type {firstClassModule as FirstClassModulesInterface_firstClassModule} from './FirstClassModulesInterface.gen'; - -import type {firstClassModule as FirstClassModules_firstClassModule} from './FirstClassModules.gen'; - -import type {record as FirstClassModulesInterface_record} from './FirstClassModulesInterface.gen'; - -export type firstClassModuleWithTypeEquations = { readonly out: (_1:o) => o; readonly Inner: { readonly inn: (_1:i) => i } }; - -export const convert: (x:FirstClassModules_firstClassModule) => FirstClassModules_firstClassModule = TestFirstClassModulesJS.convert as any; - -export const convertInterface: (x:FirstClassModulesInterface_firstClassModule) => FirstClassModulesInterface_firstClassModule = TestFirstClassModulesJS.convertInterface as any; - -export const convertRecord: (x:FirstClassModulesInterface_record) => FirstClassModulesInterface_record = TestFirstClassModulesJS.convertRecord as any; - -export const convertFirstClassModuleWithTypeEquations: (x:{ readonly out: ((_1:T1) => T1); readonly Inner: { readonly inn: ((_1:T2) => T2) } }) => { readonly out: (_1:T1) => T1; readonly Inner: { readonly inn: (_1:T2) => T2 } } = TestFirstClassModulesJS.convertFirstClassModuleWithTypeEquations as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.res b/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.res deleted file mode 100644 index 8246e5b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.res +++ /dev/null @@ -1,27 +0,0 @@ -@genType let convert = (x: FirstClassModules.firstClassModule) => x - -@genType let convertInterface = (x: FirstClassModulesInterface.firstClassModule) => x - -@genType let convertRecord = (x: FirstClassModulesInterface.record) => x - -module type MT = { - type outer - let out: outer => outer - - module Inner: { - type inner - let inn: inner => inner - } -} - -@genType -type firstClassModuleWithTypeEquations<'i, 'o> = module(MT with - type Inner.inner = 'i - and type outer = 'o -) - -@genType -let convertFirstClassModuleWithTypeEquations = ( - type o i, - x: module(MT with type Inner.inner = i and type outer = o), -) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.res.js b/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.res.js deleted file mode 100644 index bef4b0e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestFirstClassModules.res.js +++ /dev/null @@ -1,26 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function convert(x) { - return x; -} - -function convertInterface(x) { - return x; -} - -function convertRecord(x) { - return x; -} - -function convertFirstClassModuleWithTypeEquations(x) { - return x; -} - -export { - convert , - convertInterface , - convertRecord , - convertFirstClassModuleWithTypeEquations , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.gen.tsx deleted file mode 100644 index 9037ddb..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from TestImmutableArray.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TestImmutableArrayJS from './TestImmutableArray.res.js'; - -export const testImmutableArrayGet: (arr:ReadonlyArray) => (undefined | T1) = TestImmutableArrayJS.testImmutableArrayGet as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.res b/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.res deleted file mode 100644 index d4b49b7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.res +++ /dev/null @@ -1,20 +0,0 @@ -@genType -let testImmutableArrayGet = arr => { - open ImmutableArray - arr[3] -} - -/* - type error - let testImmutableArraySet = arr => ImmutableArray.(arr[3] = 4); - */ - -let testBeltArrayGet = arr => { - open Belt - arr[3] -} - -let testBeltArraySet = arr => { - open Belt - arr[3] = 4 -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.res.js b/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.res.js deleted file mode 100644 index 4cba8d8..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestImmutableArray.res.js +++ /dev/null @@ -1,23 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Belt_Array from "rescript/lib/es6/belt_Array.js"; -import * as ImmutableArray from "./ImmutableArray.res.js"; - -function testImmutableArrayGet(arr) { - return ImmutableArray.$$Array.get(arr, 3); -} - -function testBeltArrayGet(arr) { - return Belt_Array.get(arr, 3); -} - -function testBeltArraySet(arr) { - return Belt_Array.set(arr, 3, 4); -} - -export { - testImmutableArrayGet , - testBeltArrayGet , - testBeltArraySet , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.gen.tsx deleted file mode 100644 index fa6bcf0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.gen.tsx +++ /dev/null @@ -1,38 +0,0 @@ -/* TypeScript file generated from TestModuleAliases.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TestModuleAliasesJS from './TestModuleAliases.res.js'; - -import type {InnerAlias_inner as ModuleAliases2_InnerAlias_inner} from './ModuleAliases2.gen'; - -import type {Outer_Inner_inner as ModuleAliases2_Outer_Inner_inner} from './ModuleAliases2.gen'; - -import type {Outer_outer as ModuleAliases2_Outer_outer} from './ModuleAliases2.gen'; - -import type {record as ModuleAliases2_record} from './ModuleAliases2.gen'; - -export type OtherFile_record = { readonly x: number; readonly y: string }; - -export type record = ModuleAliases2_record; - -export type record2 = ModuleAliases2_record; - -export type outer = ModuleAliases2_Outer_outer; - -export type outer2 = ModuleAliases2_Outer_outer; - -export type my2 = ModuleAliases2_Outer_Inner_inner; - -export type inner1 = ModuleAliases2_InnerAlias_inner; - -export type inner2 = ModuleAliases2_Outer_Inner_inner; - -export const testInner1: (x:inner1) => inner1 = TestModuleAliasesJS.testInner1 as any; - -export const testInner1Expanded: (x:ModuleAliases2_InnerAlias_inner) => ModuleAliases2_InnerAlias_inner = TestModuleAliasesJS.testInner1Expanded as any; - -export const testInner2: (x:inner2) => inner2 = TestModuleAliasesJS.testInner2 as any; - -export const testInner2Expanded: (x:ModuleAliases2_Outer_Inner_inner) => ModuleAliases2_Outer_Inner_inner = TestModuleAliasesJS.testInner2Expanded as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.res b/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.res deleted file mode 100644 index 849b5e4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.res +++ /dev/null @@ -1,30 +0,0 @@ -module OtherFile = ModuleAliases2 -module OtherFileAlias = OtherFile - -@genType type record = OtherFile.record - -@genType type record2 = OtherFileAlias.record - -module OuterAlias = OtherFile.Outer - -@genType type outer = OtherFileAlias.Outer.outer - -@genType type outer2 = OuterAlias.outer - -module OtherFile1 = OtherFile -module Outer2 = OtherFile1.Outer -module Inner2 = Outer2.Inner - -@genType type my2 = Inner2.inner - -@genType type inner1 = OtherFile.InnerAlias.inner - -@genType type inner2 = OtherFile.Outer.Inner.inner - -@genType let testInner1 = (x: inner1) => x - -@genType let testInner1Expanded = (x: OtherFile.InnerAlias.inner) => x - -@genType let testInner2 = (x: inner2) => x - -@genType let testInner2Expanded = (x: OtherFile.Outer.Inner.inner) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.res.js b/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.res.js deleted file mode 100644 index cde0007..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestModuleAliases.res.js +++ /dev/null @@ -1,44 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function testInner1(x) { - return x; -} - -function testInner1Expanded(x) { - return x; -} - -function testInner2(x) { - return x; -} - -function testInner2Expanded(x) { - return x; -} - -var OtherFile; - -var OtherFileAlias; - -var OuterAlias; - -var OtherFile1; - -var Outer2; - -var Inner2; - -export { - OtherFile , - OtherFileAlias , - OuterAlias , - OtherFile1 , - Outer2 , - Inner2 , - testInner1 , - testInner1Expanded , - testInner2 , - testInner2Expanded , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TestPromise.gen.tsx deleted file mode 100644 index 04f5f47..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.gen.tsx +++ /dev/null @@ -1,16 +0,0 @@ -/* TypeScript file generated from TestPromise.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TestPromiseJS from './TestPromise.res.js'; - -export type promise = Promise; - -export type fromPayload = { readonly x: number; readonly s: string }; - -export type toPayload = { readonly result: string }; - -export const convert: (_1:Promise) => Promise = TestPromiseJS.convert as any; - -export const barx: (x:(undefined | Promise<(undefined | string)>), _2:void) => boolean = TestPromiseJS.barx as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.res b/jscomp/gentype_tests/typescript-react-example/src/TestPromise.res deleted file mode 100644 index 6c05a60..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.res +++ /dev/null @@ -1,13 +0,0 @@ -@genType type promise<'a> = Js.Promise.t<'a> - -@genType -type fromPayload = { - x: int, - s: string, -} - -@genType type toPayload = {result: string} - -@genType let convert = Js.Promise.then_(({s}) => Js.Promise.resolve({result: s})) - -@genType let barx = (~x=Js.Promise.resolve(Some("a")), ()) => x == x diff --git a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.res.js b/jscomp/gentype_tests/typescript-react-example/src/TestPromise.res.js deleted file mode 100644 index 69f21a7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TestPromise.res.js +++ /dev/null @@ -1,24 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Caml_obj from "rescript/lib/es6/caml_obj.js"; -import * as Js_promise from "rescript/lib/es6/js_promise.js"; -import * as Caml_option from "rescript/lib/es6/caml_option.js"; - -function convert(param) { - return Js_promise.then_((function (param) { - return Promise.resolve({ - result: param.s - }); - }), param); -} - -function barx(xOpt, param) { - var x = xOpt !== undefined ? Caml_option.valFromOption(xOpt) : Promise.resolve("a"); - return Caml_obj.equal(x, x); -} - -export { - convert , - barx , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.gen.tsx deleted file mode 100644 index 71698f9..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.gen.tsx +++ /dev/null @@ -1,14 +0,0 @@ -/* TypeScript file generated from TransitiveType1.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TransitiveType1JS from './TransitiveType1.res.js'; - -import type {t2Alias as TransitiveType2_t2Alias} from './TransitiveType2.gen'; - -import type {t2 as TransitiveType2_t2} from './TransitiveType2.gen'; - -export const convert: (x:TransitiveType2_t2) => TransitiveType2_t2 = TransitiveType1JS.convert as any; - -export const convertAlias: (x:TransitiveType2_t2Alias) => TransitiveType2_t2Alias = TransitiveType1JS.convertAlias as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.res b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.res deleted file mode 100644 index 212ac86..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.res +++ /dev/null @@ -1,3 +0,0 @@ -@genType let convert = (x: TransitiveType2.t2) => x - -@genType let convertAlias = (x: TransitiveType2.t2Alias) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.res.js b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.res.js deleted file mode 100644 index 5fda66b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType1.res.js +++ /dev/null @@ -1,16 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function convert(x) { - return x; -} - -function convertAlias(x) { - return x; -} - -export { - convert , - convertAlias , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.gen.tsx deleted file mode 100644 index 02c9548..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from TransitiveType2.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import type {t3 as TransitiveType3_t3} from './TransitiveType3.gen'; - -export type t2 = (undefined | TransitiveType3_t3); - -export type t2Alias = t2; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.res b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.res deleted file mode 100644 index e7f002e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.res +++ /dev/null @@ -1,5 +0,0 @@ -@genType type t2 = option - -@genType type t2Alias = t2 - -let convertT2 = (x: t2) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.res.js b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.res.js deleted file mode 100644 index cf62be6..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType2.res.js +++ /dev/null @@ -1,11 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function convertT2(x) { - return x; -} - -export { - convertT2 , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.gen.tsx deleted file mode 100644 index 9fa08f9..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from TransitiveType3.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TransitiveType3JS from './TransitiveType3.res.js'; - -export type t3 = { readonly i: number; readonly s: string }; - -export const convertT3: (x:t3) => t3 = TransitiveType3JS.convertT3 as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.res b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.res deleted file mode 100644 index 2fb7024..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.res +++ /dev/null @@ -1,7 +0,0 @@ -@genType -type t3 = { - i: int, - s: string, -} - -@genType let convertT3 = (x: t3) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.res.js b/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.res.js deleted file mode 100644 index 77e8c2a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TransitiveType3.res.js +++ /dev/null @@ -1,11 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function convertT3(x) { - return x; -} - -export { - convertT3 , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.gen.tsx deleted file mode 100644 index 1d8672b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from TypeNameSanitize.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type t_ = number; - -export type M_t__ = number; - -export type pair = [t_, M_t__]; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.res b/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.res deleted file mode 100644 index 9286b60..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.res +++ /dev/null @@ -1,10 +0,0 @@ -@genType -type t' = int - -module M = { - @genType - type t'' = int -} - -@genType -type pair = (t', M.t'') diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.res.js b/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.res.js deleted file mode 100644 index 44a5721..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeNameSanitize.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var M = {}; - -export { - M , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.gen.tsx deleted file mode 100644 index 9ec2bad..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.gen.tsx +++ /dev/null @@ -1,6 +0,0 @@ -/* TypeScript file generated from TypeParams1.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type ocaml_array = a[]; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.res b/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.res deleted file mode 100644 index 2e51def..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.res +++ /dev/null @@ -1,4 +0,0 @@ -@gentype -type ocaml_array<'a> = array<'a> - -let exportSomething = 10 diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.res.js b/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.res.js deleted file mode 100644 index 99313ed..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams1.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var exportSomething = 10; - -export { - exportSomething , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.gen.tsx deleted file mode 100644 index bef46e0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.gen.tsx +++ /dev/null @@ -1,12 +0,0 @@ -/* TypeScript file generated from TypeParams2.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import type {ocaml_array as TypeParams1_ocaml_array} from './TypeParams1.gen'; - -export type item = { readonly id: number }; - -export type items = TypeParams1_ocaml_array; - -export type items2 = item[]; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.res b/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.res deleted file mode 100644 index 62210b7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.res +++ /dev/null @@ -1,7 +0,0 @@ -@genType type item = {id: int} - -@genType type items = TypeParams1.ocaml_array - -@genType type items2 = array - -let exportSomething = 10 diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.res.js b/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.res.js deleted file mode 100644 index 99313ed..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams2.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var exportSomething = 10; - -export { - exportSomething , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.gen.tsx deleted file mode 100644 index 25d8ac0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.gen.tsx +++ /dev/null @@ -1,14 +0,0 @@ -/* TypeScript file generated from TypeParams3.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TypeParams3JS from './TypeParams3.res.js'; - -import type {items2 as TypeParams2_items2} from './TypeParams2.gen'; - -import type {items as TypeParams2_items} from './TypeParams2.gen'; - -export const test: (x:TypeParams2_items) => TypeParams2_items = TypeParams3JS.test as any; - -export const test2: (x:TypeParams2_items2) => TypeParams2_items2 = TypeParams3JS.test2 as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.res b/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.res deleted file mode 100644 index 9d75162..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.res +++ /dev/null @@ -1,3 +0,0 @@ -@genType let test = (x: TypeParams2.items) => x - -@genType let test2 = (x: TypeParams2.items2) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.res.js b/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.res.js deleted file mode 100644 index 26ba896..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/TypeParams3.res.js +++ /dev/null @@ -1,16 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function test(x) { - return x; -} - -function test2(x) { - return x; -} - -export { - test , - test2 , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Unboxed.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Unboxed.gen.tsx deleted file mode 100644 index 43d5469..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Unboxed.gen.tsx +++ /dev/null @@ -1,28 +0,0 @@ -/* TypeScript file generated from Unboxed.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as UnboxedJS from './Unboxed.res.js'; - -export type v1 = number; - -export type v2 = number; - -export type r1 = number; - -export type r2 = string; - -export type t = number[] | number | ((_1:number) => number); - -export type tabIndex = "0" | "1" | 0; - -export const testV1: (x:v1) => v1 = UnboxedJS.testV1 as any; - -export const r2Test: (x:r2) => r2 = UnboxedJS.r2Test as any; - -export const a: tabIndex = UnboxedJS.a as any; - -export const b: tabIndex = UnboxedJS.b as any; - -export const zero: 0 = UnboxedJS.zero as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Unboxed.res b/jscomp/gentype_tests/typescript-react-example/src/Unboxed.res deleted file mode 100644 index ee98bc1..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Unboxed.res +++ /dev/null @@ -1,30 +0,0 @@ -@genType @ocaml.unboxed -type v1 = A(int) - -@genType @unboxed -type v2 = A(int) - -@genType let testV1 = (x: v1) => x - -@genType @unboxed -type r1 = {x: int} - -@genType @ocaml.unboxed -type r2 = B({g: string}) - -@genType let r2Test = (x: r2) => x - -@genType @unboxed -type t = Array(array) | Record({x: int}) | Function((. int) => int) - -@genType -type tabIndex = | @as("0") Activity | @as("1") UserKeyword | @as(0) NumZero - -@genType -let a = Activity - -@genType -let b = UserKeyword - -@genType -let zero = #0 diff --git a/jscomp/gentype_tests/typescript-react-example/src/Unboxed.res.js b/jscomp/gentype_tests/typescript-react-example/src/Unboxed.res.js deleted file mode 100644 index 7c02bf0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Unboxed.res.js +++ /dev/null @@ -1,25 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function testV1(x) { - return x; -} - -function r2Test(x) { - return x; -} - -var a = "0"; - -var b = "1"; - -var zero = 0; - -export { - testV1 , - r2Test , - a , - b , - zero , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Uncurried.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Uncurried.gen.tsx deleted file mode 100644 index c9df733..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Uncurried.gen.tsx +++ /dev/null @@ -1,42 +0,0 @@ -/* TypeScript file generated from Uncurried.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as UncurriedJS from './Uncurried.res.js'; - -export type u0 = () => string; - -export type u1 = (_1:number) => string; - -export type u2 = (_1:number, _2:string) => string; - -export type u3 = (_1:number, _2:string, _3:number) => string; - -export type auth = { readonly login: () => string }; - -export type authU = { readonly loginU: () => string }; - -export const uncurried0: () => string = UncurriedJS.uncurried0 as any; - -export const uncurried1: (x:number) => string = UncurriedJS.uncurried1 as any; - -export const uncurried2: (x:number, y:string) => string = UncurriedJS.uncurried2 as any; - -export const uncurried3: (x:number, y:string, z:number) => string = UncurriedJS.uncurried3 as any; - -export const curried3: (x:number, y:string, z:number) => string = UncurriedJS.curried3 as any; - -export const callback: (cb:(() => number)) => string = UncurriedJS.callback as any; - -export const callback2: (auth:auth) => string = UncurriedJS.callback2 as any; - -export const callback2U: (auth:authU) => string = UncurriedJS.callback2U as any; - -export const sumU: (n:number, m:number) => void = UncurriedJS.sumU as any; - -export const sumU2: (n:number) => (_1:number) => void = UncurriedJS.sumU2 as any; - -export const sumCurried: (n:number, _2:number) => void = UncurriedJS.sumCurried as any; - -export const sumLblCurried: (s:string, n:number, m:number) => void = UncurriedJS.sumLblCurried as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Uncurried.res b/jscomp/gentype_tests/typescript-react-example/src/Uncurried.res deleted file mode 100644 index 99b78fb..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Uncurried.res +++ /dev/null @@ -1,42 +0,0 @@ -@genType type u0 = (. unit) => string - -@genType type u1 = (. int) => string - -@genType type u2 = (. int, string) => string - -@genType type u3 = (. int, string, int) => string - -@genType let uncurried0 = (. ()) => "" - -@genType let uncurried1 = (. x) => x |> string_of_int - -@genType let uncurried2 = (. x, y) => (x |> string_of_int) ++ y - -@genType let uncurried3 = (. x, y, z) => (x |> string_of_int) ++ (y ++ (z |> string_of_int)) - -@genType let curried3 = (x, y, z) => (x |> string_of_int) ++ (y ++ (z |> string_of_int)) - -@genType let callback = cb => cb() |> string_of_int - -type auth = {login: unit => string} -type authU = {loginU: (. unit) => string} - -@genType let callback2 = auth => auth.login() - -@genType let callback2U = auth => auth.loginU(.) - -@genType let sumU = (. n, m) => Js.log4("sumU 2nd arg", m, "result", n + m) - -@genType let sumU2 = (. n, . m) => Js.log4("sumU2 2nd arg", m, "result", n + m) - -@genType -let sumCurried = n => { - Js.log2("sumCurried 1st arg", n) - m => Js.log4("sumCurried 2nd arg", m, "result", n + m) -} - -@genType -let sumLblCurried = (s: string, ~n) => { - Js.log3(s, "sumLblCurried 1st arg", n) - (~m) => Js.log4("sumLblCurried 2nd arg", m, "result", n + m) -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/Uncurried.res.js b/jscomp/gentype_tests/typescript-react-example/src/Uncurried.res.js deleted file mode 100644 index 5878196..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Uncurried.res.js +++ /dev/null @@ -1,75 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Curry from "rescript/lib/es6/curry.js"; - -function uncurried0() { - return ""; -} - -function uncurried1(x) { - return String(x); -} - -function uncurried2(x, y) { - return String(x) + y; -} - -function uncurried3(x, y, z) { - return String(x) + (y + String(z)); -} - -function curried3(x, y, z) { - return String(x) + (y + String(z)); -} - -function callback(cb) { - return String(Curry._1(cb, undefined)); -} - -function callback2(auth) { - return Curry._1(auth.login, undefined); -} - -function callback2U(auth) { - return auth.loginU(); -} - -function sumU(n, m) { - console.log("sumU 2nd arg", m, "result", n + m | 0); -} - -function sumU2(n) { - return function (m) { - console.log("sumU2 2nd arg", m, "result", n + m | 0); - }; -} - -function sumCurried(n) { - console.log("sumCurried 1st arg", n); - return function (m) { - console.log("sumCurried 2nd arg", m, "result", n + m | 0); - }; -} - -function sumLblCurried(s, n) { - console.log(s, "sumLblCurried 1st arg", n); - return function (m) { - console.log("sumLblCurried 2nd arg", m, "result", n + m | 0); - }; -} - -export { - uncurried0 , - uncurried1 , - uncurried2 , - uncurried3 , - curried3 , - callback , - callback2 , - callback2U , - sumU , - sumU2 , - sumCurried , - sumLblCurried , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Undefined.res b/jscomp/gentype_tests/typescript-react-example/src/Undefined.res deleted file mode 100644 index 5c2e5dc..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Undefined.res +++ /dev/null @@ -1 +0,0 @@ -type t<'a> = Js.undefined<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/Undefined.res.js b/jscomp/gentype_tests/typescript-react-example/src/Undefined.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Undefined.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Usage.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Usage.gen.tsx deleted file mode 100644 index 551e6df..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Usage.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from Usage.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as UsageJS from './Usage.res.js'; - -import type {MyModuleAlias_t as Wrapper_MyModuleAlias_t} from './Wrapper.gen'; - -export const b: Wrapper_MyModuleAlias_t = UsageJS.b as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Usage.res b/jscomp/gentype_tests/typescript-react-example/src/Usage.res deleted file mode 100644 index 12d383e..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Usage.res +++ /dev/null @@ -1,3 +0,0 @@ -let a = 5 -@genType -let b = Wrapper.MyModuleAlias.add(a, 3) diff --git a/jscomp/gentype_tests/typescript-react-example/src/Usage.res.js b/jscomp/gentype_tests/typescript-react-example/src/Usage.res.js deleted file mode 100644 index 602ee55..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Usage.res.js +++ /dev/null @@ -1,13 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as MyModule from "./MyModule.res.js"; - -var b = MyModule.add(5, 3); - -var a = 5; - -export { - a , - b , -} -/* b Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.gen.tsx deleted file mode 100644 index 0fad6f2..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.gen.tsx +++ /dev/null @@ -1,14 +0,0 @@ -/* TypeScript file generated from UseImportJsValue.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as UseImportJsValueJS from './UseImportJsValue.res.js'; - -import type {AbsoluteValue_t as ImportJsValue_AbsoluteValue_t} from './ImportJsValue.gen'; - -import type {stringFunction as ImportJsValue_stringFunction} from './ImportJsValue.gen'; - -export const useGetProp: (x:ImportJsValue_AbsoluteValue_t) => number = UseImportJsValueJS.useGetProp as any; - -export const useTypeImportedInOtherModule: (x:ImportJsValue_stringFunction) => ImportJsValue_stringFunction = UseImportJsValueJS.useTypeImportedInOtherModule as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.res b/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.res deleted file mode 100644 index 824ce97..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.res +++ /dev/null @@ -1,4 +0,0 @@ -@genType -let useGetProp = (x: ImportJsValue.AbsoluteValue.t) => x->ImportJsValue.AbsoluteValue.getProp + 1 - -@genType let useTypeImportedInOtherModule = (x: ImportJsValue.stringFunction) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.res.js b/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.res.js deleted file mode 100644 index c954b15..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/UseImportJsValue.res.js +++ /dev/null @@ -1,16 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function useGetProp(x) { - return x.getProp() + 1 | 0; -} - -function useTypeImportedInOtherModule(x) { - return x; -} - -export { - useGetProp , - useTypeImportedInOtherModule , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.gen.tsx deleted file mode 100644 index 2b55a93..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.gen.tsx +++ /dev/null @@ -1,6 +0,0 @@ -/* TypeScript file generated from V3Compatibility.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type cb = (_1:number) => string; diff --git a/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.res b/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.res deleted file mode 100644 index c706483..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.res +++ /dev/null @@ -1,4 +0,0 @@ -open ReactV3 - -@genType -type cb = int => string diff --git a/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.res.js b/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/V3Compatibility.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Variants.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Variants.gen.tsx deleted file mode 100644 index 3b2b65d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Variants.gen.tsx +++ /dev/null @@ -1,84 +0,0 @@ -/* TypeScript file generated from Variants.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as VariantsJS from './Variants.res.js'; - -import type {list} from '../src/shims/RescriptPervasives.shim'; - -export type weekday = - "monday" - | "tuesday" - | "wednesday" - | "thursday" - | "friday" - | "saturday" - | "sunday"; - -export type testGenTypeAs = "type_" | "module_" | "fortytwo"; - -export type testGenTypeAs2 = "type_" | "module" | 42; - -export type testGenTypeAs3 = "type_" | "module" | 42; - -export type x1 = "x" | "x1"; - -export type x2 = "x" | "x2"; - -export type type_ = "Type"; -export type type = type_; - -export type myList = "E" | { TAG: "C"; _0: number; _1: myList }; - -export type builtinList = list; - -export type result1 = - { TAG: "Ok"; _0: a } - | { TAG: "Error"; _0: b }; - -export type result2 = - { TAG: "Ok"; _0: a } - | { TAG: "Error"; _0: b }; - -export type result3 = - { TAG: "Ok"; _0: a } - | { TAG: "Error"; _0: b }; - -export const isWeekend: (x:weekday) => boolean = VariantsJS.isWeekend as any; - -export const monday: "monday" = VariantsJS.monday as any; - -export const saturday: "saturday" = VariantsJS.saturday as any; - -export const sunday: "sunday" = VariantsJS.sunday as any; - -export const onlySunday: (param:"sunday") => void = VariantsJS.onlySunday as any; - -export const swap: (x:"saturday" | "sunday") => "saturday" | "sunday" = VariantsJS.swap as any; - -export const testConvert: (x:testGenTypeAs) => testGenTypeAs = VariantsJS.testConvert as any; - -export const fortytwoOK: testGenTypeAs = VariantsJS.fortytwoOK as any; - -export const fortytwoBAD: "fortytwo" = VariantsJS.fortytwoBAD as any; - -export const testConvert2: (x:testGenTypeAs2) => testGenTypeAs2 = VariantsJS.testConvert2 as any; - -export const testConvert3: (x:testGenTypeAs3) => testGenTypeAs3 = VariantsJS.testConvert3 as any; - -export const testConvert2to3: (x:testGenTypeAs2) => testGenTypeAs3 = VariantsJS.testConvert2to3 as any; - -export const id1: (x:x1) => x1 = VariantsJS.id1 as any; - -export const id2: (x:x2) => x2 = VariantsJS.id2 as any; - -export const polyWithOpt: (foo:string) => (undefined | ( - { NAME: "One"; VAL: string } - | { NAME: "Two"; VAL: number })) = VariantsJS.polyWithOpt as any; - -export const restResult1: (x:result1) => result1 = VariantsJS.restResult1 as any; - -export const restResult2: (x:result2) => result2 = VariantsJS.restResult2 as any; - -export const restResult3: (x:result3) => result3 = VariantsJS.restResult3 as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Variants.res b/jscomp/gentype_tests/typescript-react-example/src/Variants.res deleted file mode 100644 index 4dcde43..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Variants.res +++ /dev/null @@ -1,110 +0,0 @@ -@genType -type weekday = [ - | #monday - | #tuesday - | #wednesday - | #thursday - | #friday - | #saturday - | #sunday -] - -@genType -let isWeekend = (x: weekday) => - switch x { - | #saturday | #sunday => true - | _ => false - } - -@genType let monday = #monday -@genType let saturday = #saturday -@genType let sunday = #sunday - -@genType let onlySunday = (_: [#sunday]) => () - -@genType -let swap = x => - switch x { - | #sunday => #saturday - | #saturday => #sunday - } - -@genType -type testGenTypeAs = [ - | #type_ - | #module_ - | #fortytwo -] - -@genType let testConvert = (x: testGenTypeAs) => x - -@genType let fortytwoOK: testGenTypeAs = #fortytwo - -/* Exporting this is BAD: type inference means it's not mapped to "42" */ -@genType let fortytwoBAD = #fortytwo - -@genType -type testGenTypeAs2 = [ - | #type_ - | #\"module" - | #42 -] - -/* Since testGenTypeAs2 is the same type as testGenTypeAs1, - share the conversion map. */ -@genType let testConvert2 = (x: testGenTypeAs2) => x - -@genType -type testGenTypeAs3 = [ - | #type_ - | #\"module" - | #42 -] - -/* Since testGenTypeAs3 has a different representation: - use a new conversion map. */ -@genType let testConvert3 = (x: testGenTypeAs3) => x - -/* This converts between testGenTypeAs2 and testGenTypeAs3 */ -@genType let testConvert2to3 = (x: testGenTypeAs2): testGenTypeAs3 => x - -@genType type x1 = [#x | @genType.as("same") #x1] - -@genType type x2 = [#x | @genType.as("same") #x2] - -@genType let id1 = (x: x1) => x - -@genType let id2 = (x: x2) => x - -@genType @genType.as("type") -type type_ = | @genType.as("type") Type - -@genType -type rec myList = E | C(int, myList) - -@genType -type builtinList = list - -@genType -let polyWithOpt = foo => - foo === "bar" - ? None - : switch foo !== "baz" { - | true => Some(#One(foo)) - | false => Some(#Two(1)) - } - -@genType -type result1<'a, 'b> = - | Ok('a) - | Error('b) - -@genType type result2<'a, 'b> = result<'a, 'b> - -@genType type result3<'a, 'b> = Belt.Result.t<'a, 'b> - -@genType let restResult1 = (x: result1) => x - -@genType let restResult2 = (x: result2) => x - -@genType let restResult3 = (x: result3) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/Variants.res.js b/jscomp/gentype_tests/typescript-react-example/src/Variants.res.js deleted file mode 100644 index 9f7f047..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Variants.res.js +++ /dev/null @@ -1,106 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function isWeekend(x) { - if (x === "sunday") { - return true; - } else { - return x === "saturday"; - } -} - -function onlySunday(param) { - -} - -function swap(x) { - if (x === "sunday") { - return "saturday"; - } else { - return "sunday"; - } -} - -function testConvert(x) { - return x; -} - -function testConvert2(x) { - return x; -} - -function testConvert3(x) { - return x; -} - -function testConvert2to3(x) { - return x; -} - -function id1(x) { - return x; -} - -function id2(x) { - return x; -} - -function polyWithOpt(foo) { - if (foo === "bar") { - return ; - } else if (foo !== "baz") { - return { - NAME: "One", - VAL: foo - }; - } else { - return { - NAME: "Two", - VAL: 1 - }; - } -} - -function restResult1(x) { - return x; -} - -function restResult2(x) { - return x; -} - -function restResult3(x) { - return x; -} - -var monday = "monday"; - -var saturday = "saturday"; - -var sunday = "sunday"; - -var fortytwoOK = "fortytwo"; - -var fortytwoBAD = "fortytwo"; - -export { - isWeekend , - monday , - saturday , - sunday , - onlySunday , - swap , - testConvert , - fortytwoOK , - fortytwoBAD , - testConvert2 , - testConvert3 , - testConvert2to3 , - id1 , - id2 , - polyWithOpt , - restResult1 , - restResult2 , - restResult3 , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.gen.tsx deleted file mode 100644 index 4cb3a20..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.gen.tsx +++ /dev/null @@ -1,52 +0,0 @@ -/* TypeScript file generated from VariantsWithPayload.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as VariantsWithPayloadJS from './VariantsWithPayload.res.js'; - -export type payload = { readonly x: number; readonly y?: string }; - -export type withPayload = - "a" - | "b" - | "True" - | "Twenty" - | "Half" - | { NAME: "c"; VAL: payload }; - -export type manyPayloads = - { NAME: "one"; VAL: number } - | { NAME: "two"; VAL: [string, string] } - | { NAME: "three"; VAL: payload }; - -export type simpleVariant = "A" | "B" | "C"; - -export type variantWithPayloads = - "A" - | { TAG: "B"; _0: number } - | { TAG: "C"; _0: number; _1: number } - | { TAG: "D"; _0: number; _1: number } - | { TAG: "E"; _0: number; _1: string; _2: number }; - -export type variant1Int = { TAG: "R"; _0: number }; - -export type variant1Object = { TAG: "R"; _0: payload }; - -export const testWithPayload: (x:withPayload) => withPayload = VariantsWithPayloadJS.testWithPayload as any; - -export const printVariantWithPayload: (x:withPayload) => void = VariantsWithPayloadJS.printVariantWithPayload as any; - -export const testManyPayloads: (x:manyPayloads) => manyPayloads = VariantsWithPayloadJS.testManyPayloads as any; - -export const printManyPayloads: (x:manyPayloads) => void = VariantsWithPayloadJS.printManyPayloads as any; - -export const testSimpleVariant: (x:simpleVariant) => simpleVariant = VariantsWithPayloadJS.testSimpleVariant as any; - -export const testVariantWithPayloads: (x:variantWithPayloads) => variantWithPayloads = VariantsWithPayloadJS.testVariantWithPayloads as any; - -export const printVariantWithPayloads: (x:variantWithPayloads) => void = VariantsWithPayloadJS.printVariantWithPayloads as any; - -export const testVariant1Int: (x:variant1Int) => variant1Int = VariantsWithPayloadJS.testVariant1Int as any; - -export const testVariant1Object: (x:variant1Object) => variant1Object = VariantsWithPayloadJS.testVariant1Object as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.res b/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.res deleted file mode 100644 index 0fc87dc..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.res +++ /dev/null @@ -1,91 +0,0 @@ -type payload = { - x: int, - y?: string, -} - -type withPayload = [ - | #a - | #b - | #True - | #Twenty - | #Half - | #c(payload) -] - -@genType let testWithPayload = (x: withPayload) => x - -@genType -let printVariantWithPayload = (x: withPayload) => - switch x { - | #a => Js.log("printVariantWithPayload: a") - | #b => Js.log("printVariantWithPayload: b") - | #True => Js.log("printVariantWithPayload: True") - | #Twenty => Js.log("printVariantWithPayload: Twenty") - | #Half => Js.log("printVariantWithPayload: Half") - | #c(payload) => Js.log4("printVariantWithPayload x:", payload.x, "y:", payload.y) - } - -@genType -type manyPayloads = [ - | #one(int) - | #two(string, string) - | #three(payload) -] - -@genType let testManyPayloads = (x: manyPayloads) => x - -@genType -let printManyPayloads = (x: manyPayloads) => - switch x { - | #one(n) => Js.log2("printManyPayloads one:", n) - | #two(s1, s2) => Js.log3("printManyPayloads two:", s1, s2) - | #three(payload) => Js.log4("printManyPayloads x:", payload.x, "y:", payload.y) - } - -@genType -type simpleVariant = - | A - | B - | C - -@genType let testSimpleVariant = (x: simpleVariant) => x - -@genType -type variantWithPayloads = - | A - | B(int) - | C(int, int) - | D((int, int)) - | E(int, string, int) - -@genType let testVariantWithPayloads = (x: variantWithPayloads) => x - -@genType -let printVariantWithPayloads = x => - switch x { - | A => Js.log2("printVariantWithPayloads", "A") - | B(x) => Js.log2("printVariantWithPayloads", "B(" ++ (string_of_int(x) ++ ")")) - | C(x, y) => - Js.log2( - "printVariantWithPayloads", - "C(" ++ (string_of_int(x) ++ (", " ++ (string_of_int(y) ++ ")"))), - ) - | D((x, y)) => - Js.log2( - "printVariantWithPayloads", - "D((" ++ (string_of_int(x) ++ (", " ++ (string_of_int(y) ++ "))"))), - ) - | E(x, s, y) => - Js.log2( - "printVariantWithPayloads", - "E(" ++ (string_of_int(x) ++ (", " ++ (s ++ (", " ++ (string_of_int(y) ++ ")"))))), - ) - } - -@genType type variant1Int = R(int) - -@genType let testVariant1Int = (x: variant1Int) => x - -@genType type variant1Object = R(payload) - -@genType let testVariant1Object = (x: variant1Object) => x diff --git a/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.res.js b/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.res.js deleted file mode 100644 index b1bd101..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/VariantsWithPayload.res.js +++ /dev/null @@ -1,96 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -function testWithPayload(x) { - return x; -} - -function printVariantWithPayload(x) { - if (typeof x !== "object") { - if (x === "a") { - console.log("printVariantWithPayload: a"); - } else if (x === "b") { - console.log("printVariantWithPayload: b"); - } else if (x === "Half") { - console.log("printVariantWithPayload: Half"); - } else if (x === "True") { - console.log("printVariantWithPayload: True"); - } else { - console.log("printVariantWithPayload: Twenty"); - } - return ; - } - var payload = x.VAL; - console.log("printVariantWithPayload x:", payload.x, "y:", payload.y); -} - -function testManyPayloads(x) { - return x; -} - -function printManyPayloads(x) { - var variant = x.NAME; - if (variant === "two") { - var match = x.VAL; - console.log("printManyPayloads two:", match[0], match[1]); - return ; - } - if (variant === "three") { - var payload = x.VAL; - console.log("printManyPayloads x:", payload.x, "y:", payload.y); - return ; - } - console.log("printManyPayloads one:", x.VAL); -} - -function testSimpleVariant(x) { - return x; -} - -function testVariantWithPayloads(x) { - return x; -} - -function printVariantWithPayloads(x) { - if (typeof x !== "object") { - console.log("printVariantWithPayloads", "A"); - return ; - } - switch (x.TAG) { - case "B" : - console.log("printVariantWithPayloads", "B(" + (String(x._0) + ")")); - return ; - case "C" : - console.log("printVariantWithPayloads", "C(" + (String(x._0) + (", " + (String(x._1) + ")")))); - return ; - case "D" : - var match = x._0; - console.log("printVariantWithPayloads", "D((" + (String(match[0]) + (", " + (String(match[1]) + "))")))); - return ; - case "E" : - console.log("printVariantWithPayloads", "E(" + (String(x._0) + (", " + (x._1 + (", " + (String(x._2) + ")")))))); - return ; - - } -} - -function testVariant1Int(x) { - return x; -} - -function testVariant1Object(x) { - return x; -} - -export { - testWithPayload , - printVariantWithPayload , - testManyPayloads , - printManyPayloads , - testSimpleVariant , - testVariantWithPayloads , - printVariantWithPayloads , - testVariant1Int , - testVariant1Object , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Warnings.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Warnings.gen.tsx deleted file mode 100644 index 9fd5e1d..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Warnings.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from Warnings.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as WarningsJS from './Warnings.res.js'; - -export const ddd: number = WarningsJS.x as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Warnings.res b/jscomp/gentype_tests/typescript-react-example/src/Warnings.res deleted file mode 100644 index 920eee4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Warnings.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType("ddd") -let x = 42 diff --git a/jscomp/gentype_tests/typescript-react-example/src/Warnings.res.js b/jscomp/gentype_tests/typescript-react-example/src/Warnings.res.js deleted file mode 100644 index 85e08c2..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Warnings.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var x = 42; - -export { - x , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/WeakMap.res b/jscomp/gentype_tests/typescript-react-example/src/WeakMap.res deleted file mode 100644 index 9f77470..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/WeakMap.res +++ /dev/null @@ -1 +0,0 @@ -type t<'k, 'v> diff --git a/jscomp/gentype_tests/typescript-react-example/src/WeakMap.res.js b/jscomp/gentype_tests/typescript-react-example/src/WeakMap.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/WeakMap.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/WeakSet.res b/jscomp/gentype_tests/typescript-react-example/src/WeakSet.res deleted file mode 100644 index cfacdaa..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/WeakSet.res +++ /dev/null @@ -1 +0,0 @@ -type t<'a> diff --git a/jscomp/gentype_tests/typescript-react-example/src/WeakSet.res.js b/jscomp/gentype_tests/typescript-react-example/src/WeakSet.res.js deleted file mode 100644 index d856702..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/WeakSet.res.js +++ /dev/null @@ -1,2 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE -/* This output is empty. Its source's type definitions, externals and/or unused code got optimized away. */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/Wrapper.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/Wrapper.gen.tsx deleted file mode 100644 index d2baeb4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Wrapper.gen.tsx +++ /dev/null @@ -1,12 +0,0 @@ -/* TypeScript file generated from Wrapper.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as WrapperJS from './Wrapper.res.js'; - -export type MyModuleAlias_t = number; - -export const MyModuleAlias_add: (_1:MyModuleAlias_t, _2:MyModuleAlias_t) => MyModuleAlias_t = WrapperJS.MyModuleAlias.add as any; - -export const MyModuleAlias: { add: (_1:MyModuleAlias_t, _2:MyModuleAlias_t) => MyModuleAlias_t } = WrapperJS.MyModuleAlias as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/Wrapper.res b/jscomp/gentype_tests/typescript-react-example/src/Wrapper.res deleted file mode 100644 index e874c46..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Wrapper.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -module MyModuleAlias = MyModule diff --git a/jscomp/gentype_tests/typescript-react-example/src/Wrapper.res.js b/jscomp/gentype_tests/typescript-react-example/src/Wrapper.res.js deleted file mode 100644 index 29f77ba..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/Wrapper.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var MyModuleAlias; - -export { - MyModuleAlias , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/counter.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/counter.gen.tsx deleted file mode 100644 index 835e5cb..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/counter.gen.tsx +++ /dev/null @@ -1,10 +0,0 @@ -/* TypeScript file generated from counter.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as counterJS from './counter.res.js'; - -import type {aa as Machine_aa} from './Machine.gen'; - -export const b: Machine_aa = counterJS.b as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/counter.res b/jscomp/gentype_tests/typescript-react-example/src/counter.res deleted file mode 100644 index 4307cc0..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/counter.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let b = Machine.A(12) diff --git a/jscomp/gentype_tests/typescript-react-example/src/counter.res.js b/jscomp/gentype_tests/typescript-react-example/src/counter.res.js deleted file mode 100644 index 10458c1..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/counter.res.js +++ /dev/null @@ -1,12 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var b = { - TAG: "A", - _0: 12 -}; - -export { - b , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/exportNestedValues.js b/jscomp/gentype_tests/typescript-react-example/src/exportNestedValues.js deleted file mode 100644 index 4c1f469..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/exportNestedValues.js +++ /dev/null @@ -1,17 +0,0 @@ -/* @flow strict */ - -class InnerClass { - static InnerStuff = { - innerStuffContents: { x: 34 } - }; -} - -export class TopLevelClass { - static MiddleLevelElements = { - stuff: InnerClass - }; -} - -export const ValueStartingWithUpperCaseLetter = "ValueStartingWithUpperCaseLetter"; - -export default 42; \ No newline at end of file diff --git a/jscomp/gentype_tests/typescript-react-example/src/hookExample.tsx b/jscomp/gentype_tests/typescript-react-example/src/hookExample.tsx deleted file mode 100644 index ac51a9f..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/hookExample.tsx +++ /dev/null @@ -1,40 +0,0 @@ -import * as React from "react"; - -export const foo = (person: { readonly name: string; readonly age: number }) => person.name; - -type Props = { - readonly person: { readonly name: string; readonly age: number }; - readonly children: React.ReactNode; - readonly renderMe: React.ComponentType<{ - randomString: string; - readonly poly: string; - }>; -}; - -export const make: React.FC = (x: Props) => { - const RenderMe = x.renderMe; - return ( -
- {" "} - {x.person.name} {x.children}{" "} - -
- ); -}; - -class AsClassComponent extends React.PureComponent { - public render() { - const RenderMe = this.props.renderMe; - return ( -
- {" "} - {this.props.person.name} {this.props.children}{" "} - -
- ); - } -} - -export const makeRenamed = AsClassComponent; - -export default make; diff --git a/jscomp/gentype_tests/typescript-react-example/src/index.css b/jscomp/gentype_tests/typescript-react-example/src/index.css deleted file mode 100644 index b4cc725..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/index.css +++ /dev/null @@ -1,5 +0,0 @@ -body { - margin: 0; - padding: 0; - font-family: sans-serif; -} diff --git a/jscomp/gentype_tests/typescript-react-example/src/index.tsx b/jscomp/gentype_tests/typescript-react-example/src/index.tsx deleted file mode 100644 index c9c9a2b..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/index.tsx +++ /dev/null @@ -1,139 +0,0 @@ -import * as React from "react"; -import * as ReactDOM from "react-dom"; -import App from "./App"; -import * as ImportJsValue from "./ImportJsValue.gen"; -import * as Uncurried from "./Uncurried.gen"; -import "./index.css"; -import * as MyMath from "./MyMath"; -import * as Types from "./nested/Types.gen"; -import { Universe_Nested2_Nested3_nested3Value } from "./NestedModules.gen"; -import * as Records from "./Records.gen"; -import * as Variants from "./Variants.gen"; -import Hooks from "./Hooks.gen"; -import * as DocStrings from "./Docstrings.gen"; -import { - printManyPayloads, - printVariantWithPayload, - printVariantWithPayloads, - testManyPayloads, - testVariantWithPayloads, - testWithPayload, -} from "./VariantsWithPayload.gen"; -import * as TestPromise from "./TestPromise.gen"; - -const consoleLog = console.log; - -const intList = Types.map((x) => x + 1, Types.someIntList); - -const businesses = [ - { - address: "Poison road", - name: "AcmeLTD", - owner: { name: "John", age: 12, address: "garage" }, - }, -]; - -const addresses = Records.findAllAddresses(businesses); - -consoleLog("indList", intList); -consoleLog("addresses", addresses); - -consoleLog("index.tsx roundedNumber:", ImportJsValue.roundedNumber); -consoleLog("index.tsx areaValue:", ImportJsValue.areaValue); -consoleLog( - "index.tsx returnedFromHigherOrder:", - ImportJsValue.returnedFromHigherOrder -); - -consoleLog( - "index.tsx callback:", - Uncurried.callback(() => 3) -); -consoleLog( - "index.tsx callback2:", - Uncurried.callback2({ login: () => "hello" }) -); -consoleLog( - "index.tsx callback2U:", - Uncurried.callback2U({ loginU: () => "hello" }) -); -Uncurried.sumU(3, 4); -Uncurried.sumU2(3)(4); -Uncurried.sumCurried(3, 4); -Uncurried.sumLblCurried("hello", 3, 4); - -ReactDOM.render( -
- - -
, - document.getElementById("root") as HTMLElement -); - -const x1 = Records.getPayload(Records.payloadValue).v; -const x2 = Records.getPayloadRecord(Records.payloadValue).v; -const x3 = Records.payloadValue.payload.v; -const x4 = Records.getPayloadRecordPlusOne(Records.payloadValue).v; -consoleLog("x1,x2,x3,x4 are", x1, x2, x3, x4); - -consoleLog( - "Universe_Nested2_Nested3_nested3Value: ", - Universe_Nested2_Nested3_nested3Value -); - -consoleLog("Enums: swap(sunday) =", Variants.swap("sunday")); -consoleLog("Enums: fortytwoOK is", Variants.fortytwoOK); -consoleLog("Enums: fortytwoBAD is", Variants.fortytwoBAD); -consoleLog( - "Variants: testConvert3to2('module') =", - Variants.testConvert2to3('module') -); -consoleLog( - "Variants: testConvert3to2(42) =", - Variants.testConvert2to3(42) -); - -const absoluteValueInstance = new MyMath.AbsoluteValue(); -absoluteValueInstance.prop = -3; -consoleLog("absoluteValueInstance", absoluteValueInstance); - -const propValue = ImportJsValue.useGetProp(absoluteValueInstance); -const absValue = ImportJsValue.useGetAbs(absoluteValueInstance); -consoleLog("ImportJsValue: getProp() =", propValue); -consoleLog("ImportJsValue: getAbs() =", absValue); - -printVariantWithPayload("a"); -printVariantWithPayload("b"); -printVariantWithPayload("True"); -printVariantWithPayload("Twenty"); -printVariantWithPayload("Half"); -printVariantWithPayload(testWithPayload({ NAME: "c", VAL: { x: 15 } })); - -printManyPayloads({ NAME: "one", VAL: 34 }); -printManyPayloads({ NAME: "two", VAL: ["hello", "world"] }); -printManyPayloads(testManyPayloads({ NAME: "three", VAL: { x: 15 } })); - -printVariantWithPayloads(testVariantWithPayloads("A")); -printVariantWithPayloads(testVariantWithPayloads({ TAG: "B", _0: 4 })); -printVariantWithPayloads(testVariantWithPayloads({ TAG: "C", _0:1, _1:2 })); -printVariantWithPayloads(testVariantWithPayloads({ TAG: "D", _0:1, _1:2 })); -printVariantWithPayloads( - testVariantWithPayloads({ TAG: "E", _0:1, _1:"hello", _2:2 }) -); - -TestPromise.convert(Promise.resolve({ x: 3, s: "hello" })).then((x) => - consoleLog("TestPromise result:", x.result) -); - -type Props = { - readonly method?: "push" | "replace"; -}; -// eslint-disable-next-line @typescript-eslint/no-unused-vars -export const make: React.FC = (x: Props) => { - return
; -}; - -const signedMessage = DocStrings.signMessage("hello", 42); -consoleLog("signedMessage:", signedMessage); - -export default make; diff --git a/jscomp/gentype_tests/typescript-react-example/src/location/location.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/location/location.gen.tsx deleted file mode 100644 index d5a66cf..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/location/location.gen.tsx +++ /dev/null @@ -1,6 +0,0 @@ -/* TypeScript file generated from location.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -export type t = { readonly id: string; readonly name: string }; diff --git a/jscomp/gentype_tests/typescript-react-example/src/location/location.res b/jscomp/gentype_tests/typescript-react-example/src/location/location.res deleted file mode 100644 index 403a2d2..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/location/location.res +++ /dev/null @@ -1,9 +0,0 @@ -/* Test file starting with lower case letter. */ - -@genType -type t = { - id: string, - name: string, -} - -let x = 42 diff --git a/jscomp/gentype_tests/typescript-react-example/src/location/location.res.js b/jscomp/gentype_tests/typescript-react-example/src/location/location.res.js deleted file mode 100644 index 85e08c2..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/location/location.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var x = 42; - -export { - x , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/logo.svg b/jscomp/gentype_tests/typescript-react-example/src/logo.svg deleted file mode 100644 index 6b60c10..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/logo.svg +++ /dev/null @@ -1,7 +0,0 @@ - - - - - - - diff --git a/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.gen.tsx deleted file mode 100644 index 186aa8a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.gen.tsx +++ /dev/null @@ -1,32 +0,0 @@ -/* TypeScript file generated from Tuples.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TuplesJS from './Tuples.res.js'; - -export type coord = [number, number, (undefined | number)]; - -export type coord2 = [number, number, (null | undefined | number)]; - -export type person = { readonly name: string; readonly age: number }; - -export type couple = [person, person]; - -export const testTuple: (param:[number, number]) => number = TuplesJS.testTuple as any; - -export const origin: [number, number, (undefined | number)] = TuplesJS.origin as any; - -export const computeArea: (param:[number, number, (undefined | number)]) => number = TuplesJS.computeArea as any; - -export const computeAreaWithIdent: (param:coord) => number = TuplesJS.computeAreaWithIdent as any; - -export const computeAreaNoConverters: (param:[number, number]) => number = TuplesJS.computeAreaNoConverters as any; - -export const coord2d: (x:T1, y:T2) => [T1, T2, (undefined | T3)] = TuplesJS.coord2d as any; - -export const getFirstName: (param:couple) => string = TuplesJS.getFirstName as any; - -export const marry: (first:person, second:person) => couple = TuplesJS.marry as any; - -export const changeSecondAge: (param:couple) => couple = TuplesJS.changeSecondAge as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.res b/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.res deleted file mode 100644 index ed13440..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.res +++ /dev/null @@ -1,40 +0,0 @@ -open Belt - -@genType let testTuple = ((a, b)) => a + b - -@genType type coord = (int, int, option) - -@genType let origin = (0, 0, Some(0)) - -@genType -let computeArea = ((x, y, z)) => { - open Option - x * y * z->mapWithDefault(1, n => n) -} - -@genType -let computeAreaWithIdent = ((x, y, z): coord) => { - open Option - x * y * z->mapWithDefault(1, n => n) -} - -@genType let computeAreaNoConverters = ((x: int, y: int)) => x * y - -@genType let coord2d = (x, y) => (x, y, None) - -@genType type coord2 = (int, int, Js.Nullable.t) - -@genType -type person = { - name: string, - age: int, -} - -@genType type couple = (person, person) - -@genType let getFirstName = ((first, _second): couple) => first.name - -@genType let marry = (first, second): couple => (first, second) - -@genType -let changeSecondAge = ((first, second): couple): couple => (first, {...second, age: second.age + 1}) diff --git a/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.res.js b/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.res.js deleted file mode 100644 index 6aaff47..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/nested/Tuples.res.js +++ /dev/null @@ -1,72 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as Belt_Option from "rescript/lib/es6/belt_Option.js"; - -function testTuple(param) { - return param[0] + param[1] | 0; -} - -function computeArea(param) { - return Math.imul(Math.imul(param[0], param[1]), Belt_Option.mapWithDefault(param[2], 1, (function (n) { - return n; - }))); -} - -function computeAreaWithIdent(param) { - return Math.imul(Math.imul(param[0], param[1]), Belt_Option.mapWithDefault(param[2], 1, (function (n) { - return n; - }))); -} - -function computeAreaNoConverters(param) { - return Math.imul(param[0], param[1]); -} - -function coord2d(x, y) { - return [ - x, - y, - undefined - ]; -} - -function getFirstName(param) { - return param[0].name; -} - -function marry(first, second) { - return [ - first, - second - ]; -} - -function changeSecondAge(param) { - var second = param[1]; - return [ - param[0], - { - name: second.name, - age: second.age + 1 | 0 - } - ]; -} - -var origin = [ - 0, - 0, - 0 -]; - -export { - testTuple , - origin , - computeArea , - computeAreaWithIdent , - computeAreaNoConverters , - coord2d , - getFirstName , - marry , - changeSecondAge , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/nested/Types.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/nested/Types.gen.tsx deleted file mode 100644 index f31439c..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/nested/Types.gen.tsx +++ /dev/null @@ -1,119 +0,0 @@ -/* TypeScript file generated from Types.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as TypesJS from './Types.res.js'; - -import type {Json_t as Js_Json_t} from '../../src/shims/Js.shim'; - -import type {M_t__ as TypeNameSanitize_M_t__} from '../../src/TypeNameSanitize.gen'; - -import type {list} from '../../src/shims/RescriptPervasives.shim'; - -import type {t_ as TypeNameSanitize_t_} from '../../src/TypeNameSanitize.gen'; - -import type {t as Location_t} from '../../src/location/location.gen'; - -export type t = number; - -export type typeWithVars = - { TAG: "A"; _0: x; _1: y } - | { TAG: "B"; _0: z }; - -export type tree = { - readonly label: string; - readonly left?: tree; - readonly right?: tree -}; - -export type selfRecursive = { readonly self: selfRecursive }; - -export type mutuallyRecursiveA = { readonly b: mutuallyRecursiveB }; - -export type mutuallyRecursiveB = { readonly a: mutuallyRecursiveA }; - -export abstract class opaqueVariant { protected opaque!: any }; /* simulate opaque types */ - -export type twice
= [a, a]; - -export type genTypeMispelled = number; - -export type dictString = {[id: string]: string}; - -export type nullOrString = (null | string); - -export type nullOrString2 = (null | string); - -export type record = { readonly i: number; readonly s: string }; - -export type decorator = (_1:a) => b; - -export type marshalFields = { - readonly _rec: string; - readonly _switch: string; - readonly switch: string; - readonly __: string; - readonly ___: string; - readonly foo__: string; - readonly _foo__: string; - readonly _Uppercase: string; - readonly _Uppercase__: string -}; - -export type marshalMutableField = { _match: number }; - -export type ocaml_array = a[]; - -export type someRecord = { readonly id: number }; - -export type instantiateTypeParameter = ocaml_array; - -export type vector = [a, a]; -export type Vector = vector; - -export type date = Date; - -export type i64A = [number, number]; - -export type i64B = [number, number]; - -export type ObjectId_t = number; - -export type tPrimed = [TypeNameSanitize_t_, TypeNameSanitize_M_t__]; - -export const someIntList: list = TypesJS.someIntList as any; - -export const map: (_1:((_1:T1) => T2), _2:list) => list = TypesJS.map as any; - -export const swap: (tree:tree) => tree = TypesJS.swap as any; - -export const selfRecursiveConverter: (param:selfRecursive) => selfRecursive = TypesJS.selfRecursiveConverter as any; - -export const mutuallyRecursiveConverter: (param:mutuallyRecursiveA) => mutuallyRecursiveB = TypesJS.mutuallyRecursiveConverter as any; - -export const testFunctionOnOptionsAsArgument: (a:(undefined | a), foo:((_1:(undefined | a)) => T1)) => T1 = TypesJS.testFunctionOnOptionsAsArgument as any; - -export const stringT: string = TypesJS.stringT as any; - -export const jsStringT: string = TypesJS.jsStringT as any; - -export const jsString2T: string = TypesJS.jsString2T as any; - -export const jsonStringify: (_1:Js_Json_t) => string = TypesJS.jsonStringify as any; - -export const testConvertNull: (x:(null | record)) => (null | record) = TypesJS.testConvertNull as any; - -export const testConvertLocation: (x:Location_t) => Location_t = TypesJS.testConvertLocation as any; - -export const testMarshalFields: marshalFields = TypesJS.testMarshalFields as any; - -export const setMatch: (x:marshalMutableField) => void = TypesJS.setMatch as any; - -export const testInstantiateTypeParameter: (x:instantiateTypeParameter) => instantiateTypeParameter = TypesJS.testInstantiateTypeParameter as any; - -export const currentTime: Date = TypesJS.currentTime as any; - -export const i64Const: i64B = TypesJS.i64Const as any; - -export const optFunction: (undefined | (() => number)) = TypesJS.optFunction as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/nested/Types.res b/jscomp/gentype_tests/typescript-react-example/src/nested/Types.res deleted file mode 100644 index 189f406..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/nested/Types.res +++ /dev/null @@ -1,144 +0,0 @@ -@@warning("-32") - -@genType type t = int - -@genType let someIntList = list{1, 2, 3} - -@genType let map = List.map - -@genType -type typeWithVars<'x, 'y, 'z> = - | A('x, 'y) - | B('z) - -@genType type rec tree = {"label": string, "left": option, "right": option} - -/* - * A tree is a recursive type which does not require any conversion (JS object). - * All is well. - */ -@genType -let rec swap = (tree: tree): tree => - { - "label": tree["label"], - "left": tree["right"]->Belt.Option.map(swap), - "right": tree["left"]->Belt.Option.map(swap), - } - -@genType type rec selfRecursive = {self: selfRecursive} - -@genType type rec mutuallyRecursiveA = {b: mutuallyRecursiveB} -and mutuallyRecursiveB = {a: mutuallyRecursiveA} - -/* - * This is a recursive type which requires conversion (a record). - * Only a shallow conversion of the top-level element is performed. - */ -@genType let selfRecursiveConverter = ({self}) => self - -/* - * This is a mutually recursive type which requires conversion (a record). - * Only a shallow conversion of the two top-level elements is performed. - */ -@genType let mutuallyRecursiveConverter = ({b}) => b - -@genType let testFunctionOnOptionsAsArgument = (a: option<'a>, foo) => foo(a) - -@genType.opaque -type opaqueVariant = - | A - | B - -@genType let stringT: String.t = "a" - -@genType let jsStringT: Js.String.t = "a" - -@genType let jsString2T: Js.String2.t = "a" - -@genType type twice<'a> = ('a, 'a) - -@gentype -type genTypeMispelled = int - -@genType type dictString = Js.Dict.t - -@genType let jsonStringify = Js.Json.stringify - -@genType type nullOrString = Js.Null.t - -@genType type nullOrString2 = Js.null - -type record = { - i: int, - s: string, -} - -@genType let testConvertNull = (x: Js.Null.t) => x - -@genType type decorator<'a, 'b> = 'a => 'b constraint 'a = int constraint 'b = _ => _ - -@genType let testConvertLocation = (x: Location.t) => x - -/* ReScript's marshaling rules. */ -@genType -type marshalFields = { - "_rec": string, - "_switch": string, - "switch": string, - "__": string, - "___": string, - "foo__": string, - "_foo__": string, - "_Uppercase": string, - "_Uppercase__": string, -} - -@genType -let testMarshalFields: marshalFields = { - "_rec": "rec", - "_switch" /* reason keywords are not recognized */: "_switch", - "switch": "switch", - "__": "__", - "___": "_", - "foo__": "foo", - "_foo__": "_foo", - "_Uppercase": "Uppercase", - "_Uppercase__": "_Uppercase", -} - -@genType type marshalMutableField = {@set "_match": int} - -@genType let setMatch = (x: marshalMutableField) => x["_match"] = 34 - -type ocaml_array<'a> = array<'a> - -// This should be considered annotated automatically. -type someRecord = {id: int} - -type instantiateTypeParameter = ocaml_array - -@genType let testInstantiateTypeParameter = (x: instantiateTypeParameter) => x - -@genType @genType.as("Vector") -type vector<'a> = ('a, 'a) - -@genType type date = Js.Date.t - -@genType let currentTime = Js.Date.make() - -@genType type i64A = Int64.t - -@genType type i64B = int64 - -@genType let i64Const: i64B = 34L - -@genType let optFunction = Some(() => 3) - -module ObjectId: { - @genType type t = int -} = { - type t = int - let x = 1 -} - -@genType type tPrimed = (TypeNameSanitize.t', TypeNameSanitize.M.t'') diff --git a/jscomp/gentype_tests/typescript-react-example/src/nested/Types.res.js b/jscomp/gentype_tests/typescript-react-example/src/nested/Types.res.js deleted file mode 100644 index ef7c09c..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/nested/Types.res.js +++ /dev/null @@ -1,112 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - -import * as List from "rescript/lib/es6/list.js"; -import * as Curry from "rescript/lib/es6/curry.js"; -import * as Belt_Option from "rescript/lib/es6/belt_Option.js"; - -function swap(tree) { - return { - label: tree.label, - left: Belt_Option.map(tree.right, swap), - right: Belt_Option.map(tree.left, swap) - }; -} - -function selfRecursiveConverter(param) { - return param.self; -} - -function mutuallyRecursiveConverter(param) { - return param.b; -} - -function testFunctionOnOptionsAsArgument(a, foo) { - return Curry._1(foo, a); -} - -function jsonStringify(prim) { - return JSON.stringify(prim); -} - -function testConvertNull(x) { - return x; -} - -function testConvertLocation(x) { - return x; -} - -var testMarshalFields = { - _rec: "rec", - _switch: "_switch", - switch: "switch", - __: "__", - ___: "_", - foo__: "foo", - _foo__: "_foo", - _Uppercase: "Uppercase", - _Uppercase__: "_Uppercase" -}; - -function setMatch(x) { - x._match = 34; -} - -function testInstantiateTypeParameter(x) { - return x; -} - -var currentTime = new Date(); - -var optFunction = (function (param) { - return 3; - }); - -var ObjectId = {}; - -var someIntList = { - hd: 1, - tl: { - hd: 2, - tl: { - hd: 3, - tl: /* [] */0 - } - } -}; - -var map = List.map; - -var stringT = "a"; - -var jsStringT = "a"; - -var jsString2T = "a"; - -var i64Const = [ - 0, - 34 -]; - -export { - someIntList , - map , - swap , - selfRecursiveConverter , - mutuallyRecursiveConverter , - testFunctionOnOptionsAsArgument , - stringT , - jsStringT , - jsString2T , - jsonStringify , - testConvertNull , - testConvertLocation , - testMarshalFields , - setMatch , - testInstantiateTypeParameter , - currentTime , - i64Const , - optFunction , - ObjectId , -} -/* currentTime Not a pure module */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/react-app-env.d.ts b/jscomp/gentype_tests/typescript-react-example/src/react-app-env.d.ts deleted file mode 100644 index 6431bc5..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/react-app-env.d.ts +++ /dev/null @@ -1 +0,0 @@ -/// diff --git a/jscomp/gentype_tests/typescript-react-example/src/shims/Js.shim.ts b/jscomp/gentype_tests/typescript-react-example/src/shims/Js.shim.ts deleted file mode 100644 index 7c73511..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/shims/Js.shim.ts +++ /dev/null @@ -1,5 +0,0 @@ -export type Json_t = unknown; - -export type t = unknown; - -export type TypedArray2_Uint8Array_t = Uint8Array; diff --git a/jscomp/gentype_tests/typescript-react-example/src/shims/ReactEvent.shim.ts b/jscomp/gentype_tests/typescript-react-example/src/shims/ReactEvent.shim.ts deleted file mode 100644 index 4ad7494..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/shims/ReactEvent.shim.ts +++ /dev/null @@ -1,71 +0,0 @@ -// eslint-disable-next-line max-classes-per-file -export abstract class Animation_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Clipboard_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Composition_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Focus_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Form_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Keyboard_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Image_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Media_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Selection_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Synthetic_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Touch_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Transition_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class UI_t { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Wheel_t { - protected opaque: unknown; -} - -export type inputFocusEvent = React.FocusEvent; diff --git a/jscomp/gentype_tests/typescript-react-example/src/shims/RescriptPervasives.shim.ts b/jscomp/gentype_tests/typescript-react-example/src/shims/RescriptPervasives.shim.ts deleted file mode 100644 index d83f49c..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/shims/RescriptPervasives.shim.ts +++ /dev/null @@ -1,24 +0,0 @@ -// eslint-disable-next-line @typescript-eslint/no-var-requires -const $$Array = require("bs-platform/lib/js/array"); - -// eslint-disable-next-line max-classes-per-file -export abstract class EmptyList { - protected opaque: unknown; -} - -// eslint-disable-next-line max-classes-per-file -export abstract class Cons { - protected opaque!: T; -} - -export type list = Cons | EmptyList; - -export function cons(itm: T, lst: list) : list { - // eslint-disable-next-line @typescript-eslint/no-explicit-any - return /* :: */ [itm, lst] as any; -} - -// eslint-disable-next-line @typescript-eslint/no-explicit-any -export const emptyList : EmptyList = /* [] */ 0 as any; - -export const fromArray = $$Array.to_list; diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.gen.tsx deleted file mode 100644 index 71445c1..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from 404.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as _404JS from './404.res.js'; - -export const x: number = _404JS.x as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.res b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.res deleted file mode 100644 index 981389a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let x = 123 diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.res.js b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.res.js deleted file mode 100644 index b48a2a7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/404.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var x = 123; - -export { - x , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.gen.tsx deleted file mode 100644 index 2da19d8..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from AppModal.web.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as AppModal_webJS from './AppModal.web.res.js'; - -export const x: number = AppModal_webJS.x as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.res b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.res deleted file mode 100644 index 981389a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let x = 123 diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.res.js b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.res.js deleted file mode 100644 index b48a2a7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/AppModal.web.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var x = 123; - -export { - x , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.gen.tsx deleted file mode 100644 index 334ed85..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from _under.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as _underJS from './_under.res.js'; - -export const x: number = _underJS.x as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.res b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.res deleted file mode 100644 index 981389a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let x = 123 diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.res.js b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.res.js deleted file mode 100644 index b48a2a7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/_under.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var x = 123; - -export { - x , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.gen.tsx b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.gen.tsx deleted file mode 100644 index f56f140..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.gen.tsx +++ /dev/null @@ -1,8 +0,0 @@ -/* TypeScript file generated from with_underscore.res by genType. */ - -/* eslint-disable */ -/* tslint:disable */ - -import * as with_underscoreJS from './with_underscore.res.js'; - -export const x: number = with_underscoreJS.x as any; diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.res b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.res deleted file mode 100644 index 981389a..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.res +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let x = 123 diff --git a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.res.js b/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.res.js deleted file mode 100644 index b48a2a7..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/strange_file_names/with_underscore.res.js +++ /dev/null @@ -1,9 +0,0 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - - -var x = 123; - -export { - x , -} -/* No side effect */ diff --git a/jscomp/gentype_tests/typescript-react-example/src/testReferences.ts b/jscomp/gentype_tests/typescript-react-example/src/testReferences.ts deleted file mode 100644 index 1d0efa3..0000000 --- a/jscomp/gentype_tests/typescript-react-example/src/testReferences.ts +++ /dev/null @@ -1,15 +0,0 @@ -/* @flow strict */ - -import * as References from "./References.gen"; - -const r: { contents: number } = { contents: 34 }; - -r.contents = 42; - -export const n: number = References.access(r); - -const ar: References.t = References.make(34); - -References.set(ar, 42); - -export const an: number = References.get(ar); diff --git a/jscomp/gentype_tests/typescript-react-example/tsconfig.json b/jscomp/gentype_tests/typescript-react-example/tsconfig.json deleted file mode 100644 index 1992ba5..0000000 --- a/jscomp/gentype_tests/typescript-react-example/tsconfig.json +++ /dev/null @@ -1,45 +0,0 @@ -{ - "compilerOptions": { - "outDir": "build/dist", - "module": "esnext", - "target": "es5", - "lib": [ - "dom", - "dom.iterable", - "esnext" - ], - "sourceMap": true, - "allowJs": true, - "jsx": "react", - "skipLibCheck": true, - "moduleResolution": "node", - "rootDir": ".", - "forceConsistentCasingInFileNames": true, - "noImplicitReturns": true, - "noImplicitThis": true, - "noImplicitAny": true, - "strictNullChecks": true, - "noUnusedLocals": true, - "strictPropertyInitialization": true, - "esModuleInterop": true, - "allowSyntheticDefaultImports": true, - "strict": true, - "resolveJsonModule": true, - "isolatedModules": true, - "noEmit": true, - "noFallthroughCasesInSwitch": true - }, - "include": [ - "src" - ], - "exclude": [ - "node_modules", - "build", - "scripts", - "acceptance-tests", - "webpack", - "jest", - "src/setupTests.ts", - "src/AutoAnnotate.bs.js" - ] -} diff --git a/jscomp/gentype_tests/typescript-react-example/tsconfig.prod.json b/jscomp/gentype_tests/typescript-react-example/tsconfig.prod.json deleted file mode 100644 index 4144216..0000000 --- a/jscomp/gentype_tests/typescript-react-example/tsconfig.prod.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "extends": "./tsconfig.json" -} \ No newline at end of file diff --git a/jscomp/gentype_tests/typescript-react-example/tsconfig.test.json b/jscomp/gentype_tests/typescript-react-example/tsconfig.test.json deleted file mode 100644 index 65ffdd4..0000000 --- a/jscomp/gentype_tests/typescript-react-example/tsconfig.test.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "extends": "./tsconfig.json", - "compilerOptions": { - "module": "commonjs" - } -} \ No newline at end of file diff --git a/jscomp/js_parser/.ocamlformat b/jscomp/js_parser/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/js_parser/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/js_parser/comment_attachment.ml b/jscomp/js_parser/comment_attachment.ml deleted file mode 100644 index 4866a47..0000000 --- a/jscomp/js_parser/comment_attachment.ml +++ /dev/null @@ -1,779 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Flow_ast -open Parser_env - -let id = Flow_ast_mapper.id - -let map_loc = Flow_ast_mapper.map_loc - -let map_opt = Flow_ast_mapper.map_opt - -let id_list_last (map : 'a -> 'a) (lst : 'a list) : 'a list = - match List.rev lst with - | [] -> lst - | hd :: tl -> - let hd' = map hd in - if hd == hd' then - lst - else - List.rev (hd' :: tl) - -(* Mapper that removes all trailing comments that appear after a given position in an AST node *) -class ['loc] trailing_comments_remover ~after_pos = - object (this) - inherit ['loc] Flow_ast_mapper.mapper - - method! syntax comments = - let open Syntax in - let { trailing; _ } = comments in - let trailing' = - List.filter (fun (loc, _) -> Loc.(pos_cmp loc.start after_pos < 0)) trailing - in - if List.length trailing = List.length trailing' then - comments - else - { comments with trailing = trailing' } - - method! array _loc expr = - let open Ast.Expression.Array in - let { comments; _ } = expr in - id this#syntax_opt comments expr (fun comments' -> { expr with comments = comments' }) - - method! array_type t = - let open Ast.Type.Array in - let { comments; _ } = t in - id this#syntax_opt comments t (fun comments' -> { t with comments = comments' }) - - method! assignment _loc expr = - let open Ast.Expression.Assignment in - let { right; comments; _ } = expr in - let right' = this#expression right in - let comments' = this#syntax_opt comments in - if right == right' && comments == comments' then - expr - else - { expr with right = right'; comments = comments' } - - method! binary _loc expr = - let open Ast.Expression.Binary in - let { right; comments; _ } = expr in - let right' = this#expression right in - let comments' = this#syntax_opt comments in - if right == right' && comments == comments' then - expr - else - { expr with right = right'; comments = comments' } - - method! block _loc stmt = - let open Ast.Statement.Block in - let { comments; _ } = stmt in - id this#syntax_opt comments stmt (fun comments' -> { stmt with comments = comments' }) - - method! call _annot expr = - let open Ast.Expression.Call in - let { arguments; comments; _ } = expr in - let arguments' = this#call_arguments arguments in - let comments' = this#syntax_opt comments in - if arguments == arguments' && comments == comments' then - expr - else - { expr with arguments = arguments'; comments = comments' } - - method! call_arguments arg_list = - let open Ast.Expression.ArgList in - let (loc, { arguments; comments }) = arg_list in - id this#syntax_opt comments arg_list (fun comments' -> - (loc, { arguments; comments = comments' }) - ) - - method! call_type_args targs = - let open Ast.Expression.CallTypeArgs in - let (loc, { arguments; comments }) = targs in - id this#syntax_opt comments targs (fun comments' -> (loc, { arguments; comments = comments' })) - - method! class_ _loc cls = - let open Ast.Class in - let { body; comments; _ } = cls in - let body' = this#class_body body in - let comments' = this#syntax_opt comments in - if body == body' && comments == comments' then - cls - else - { cls with body = body'; comments = comments' } - - method! class_body body = - let open Ast.Class.Body in - let (loc, { body = _body; comments }) = body in - id this#syntax_opt comments body (fun comments' -> - (loc, { body = _body; comments = comments' }) - ) - - method! class_extends _loc extends = - let open Ast.Class.Extends in - let { expr; targs; _ } = extends in - if targs = None then - id this#expression expr extends (fun expr' -> { extends with expr = expr' }) - else - id (map_opt this#type_args) targs extends (fun targs' -> { extends with targs = targs' }) - - method! class_implements implements = - let open Ast.Class.Implements in - let (loc, { interfaces; comments }) = implements in - id (id_list_last this#class_implements_interface) interfaces implements (fun interfaces' -> - (loc, { interfaces = interfaces'; comments }) - ) - - method! class_implements_interface interface = - let open Ast.Class.Implements.Interface in - let (loc, { id = id_; targs }) = interface in - if targs = None then - id this#identifier id_ interface (fun id' -> (loc, { id = id'; targs })) - else - id (map_opt this#type_args) targs interface (fun targs' -> - (loc, { id = id_; targs = targs' }) - ) - - method! computed_key key = - let open Ast.ComputedKey in - let (loc, { expression; comments }) = key in - id this#syntax_opt comments key (fun comments' -> (loc, { expression; comments = comments' })) - - method! conditional _loc expr = - let open Ast.Expression.Conditional in - let { alternate; comments; _ } = expr in - let alternate' = this#expression alternate in - let comments' = this#syntax_opt comments in - if alternate == alternate' && comments == comments' then - expr - else - { expr with alternate = alternate'; comments = comments' } - - method! function_ _loc func = - let open Ast.Function in - let { body; comments; _ } = func in - let body' = this#function_body_any body in - let comments' = this#syntax_opt comments in - if body == body' && comments == comments' then - func - else - { func with body = body'; comments = comments' } - - method! function_params (loc, params) = - let open Ast.Function.Params in - let { comments; _ } = params in - id this#syntax_opt comments (loc, params) (fun comments' -> - (loc, { params with comments = comments' }) - ) - - method! function_type _loc func = - let open Ast.Type.Function in - let { return; comments; _ } = func in - let return' = this#type_ return in - let comments' = this#syntax_opt comments in - if return == return' && comments == comments' then - func - else - { func with return = return'; comments = comments' } - - method! generic_identifier_type git = - let open Ast.Type.Generic.Identifier in - match git with - | Unqualified i -> id this#identifier i git (fun i -> Unqualified i) - | Qualified (loc, ({ id; _ } as qualified)) -> - let id' = this#identifier id in - if id == id' then - git - else - Qualified (loc, { qualified with id = id' }) - - method! import _loc expr = - let open Ast.Expression.Import in - let { comments; _ } = expr in - id this#syntax_opt comments expr (fun comments' -> { expr with comments = comments' }) - - method! interface_type _loc t = - let open Ast.Type.Interface in - let { body; comments; _ } = t in - let body' = map_loc this#object_type body in - let comments' = this#syntax_opt comments in - if body == body' && comments == comments' then - t - else - { t with body = body'; comments = comments' } - - method! intersection_type _loc t = - let { Ast.Type.Intersection.types = (t0, t1, ts); comments } = t in - let (t1', ts') = - match ts with - | [] -> (this#type_ t1, []) - | _ -> (t1, id_list_last this#type_ ts) - in - let comments' = this#syntax_opt comments in - if t1 == t1' && ts == ts' && comments == comments' then - t - else - { Ast.Type.Intersection.types = (t0, t1', ts'); comments = comments' } - - method! jsx_element _loc elem = - let open Ast.JSX in - let { comments; _ } = elem in - id this#syntax_opt comments elem (fun comments' -> { elem with comments = comments' }) - - method! jsx_fragment _loc frag = - let open Ast.JSX in - let { frag_comments = comments; _ } = frag in - id this#syntax_opt comments frag (fun comments' -> { frag with frag_comments = comments' }) - - method! logical _loc expr = - let open Ast.Expression.Logical in - let { right; comments; _ } = expr in - let right' = this#expression right in - let comments' = this#syntax_opt comments in - if right == right' && comments == comments' then - expr - else - { expr with right = right'; comments = comments' } - - method! new_ _loc expr = - let open Ast.Expression.New in - let { callee; targs; arguments; comments } = expr in - let comments' = this#syntax_opt comments in - match (targs, arguments) with - (* new Callee() *) - | (_, Some _) -> - let arguments' = map_opt this#call_arguments arguments in - if arguments == arguments' && comments == comments' then - expr - else - { expr with arguments = arguments'; comments = comments' } - (* new Callee *) - | (Some _, _) -> - let targs' = map_opt this#call_type_args targs in - if targs == targs' && comments == comments' then - expr - else - { expr with targs = targs'; comments = comments' } - (* new Callee *) - | (None, None) -> - let callee' = this#expression callee in - if callee == callee' && comments == comments' then - expr - else - { expr with callee = callee'; comments = comments' } - - method! member _loc expr = - let open Ast.Expression.Member in - let { property; comments; _ } = expr in - let property' = this#member_property property in - let comments' = this#syntax_opt comments in - if property == property' && comments == comments' then - expr - else - { expr with property = property'; comments = comments' } - - method! object_ _loc expr = - let open Ast.Expression.Object in - let { comments; _ } = expr in - id this#syntax_opt comments expr (fun comments' -> { expr with comments = comments' }) - - method! object_type _loc obj = - let open Ast.Type.Object in - let { comments; _ } = obj in - id this#syntax_opt comments obj (fun comments' -> { obj with comments = comments' }) - - method! predicate pred = - let open Ast.Type.Predicate in - let (loc, { kind; comments }) = pred in - id this#syntax_opt comments pred (fun comments' -> (loc, { kind; comments = comments' })) - - method! sequence _loc expr = - let open Ast.Expression.Sequence in - let { expressions; comments } = expr in - let expressions' = id_list_last this#expression expressions in - let comments' = this#syntax_opt comments in - if expressions == expressions' && comments == comments' then - expr - else - { expressions = expressions'; comments = comments' } - - method! template_literal _loc expr = - let open Ast.Expression.TemplateLiteral in - let { comments; _ } = expr in - id this#syntax_opt comments expr (fun comments' -> { expr with comments = comments' }) - - method! tuple_type t = - let open Ast.Type.Tuple in - let { comments; _ } = t in - id this#syntax_opt comments t (fun comments' -> { t with comments = comments' }) - - method! type_cast _loc expr = - let open Ast.Expression.TypeCast in - let { comments; _ } = expr in - id this#syntax_opt comments expr (fun comments' -> { expr with comments = comments' }) - - method! type_params tparams = - let open Ast.Type.TypeParams in - let (loc, { params; comments }) = tparams in - id this#syntax_opt comments tparams (fun comments' -> (loc, { params; comments = comments' })) - - method! union_type _loc t = - let { Ast.Type.Union.types = (t0, t1, ts); comments } = t in - let (t1', ts') = - match ts with - | [] -> (this#type_ t1, []) - | _ -> (t1, id_list_last this#type_ ts) - in - let comments' = this#syntax_opt comments in - if t1 == t1' && ts == ts' && comments == comments' then - t - else - { Ast.Type.Union.types = (t0, t1', ts'); comments = comments' } - - method! variable_declarator ~kind decl = - let open Ast.Statement.VariableDeclaration.Declarator in - let (loc, { id = ident; init }) = decl in - match init with - | None -> - id (this#variable_declarator_pattern ~kind) ident decl (fun ident' -> - (loc, { id = ident'; init }) - ) - | Some init -> - id this#expression init decl (fun init' -> (loc, { id = ident; init = Some init' })) - end - -type trailing_and_remover_result = { - trailing: Loc.t Comment.t list; - remove_trailing: 'a. 'a -> (Loc.t trailing_comments_remover -> 'a -> 'a) -> 'a; -} - -(* Returns a remover function which removes comments beginning after the previous token. - No trailing comments are returned, since all comments since the last loc should be removed. *) -let trailing_and_remover_after_last_loc : Parser_env.env -> trailing_and_remover_result = - fun env -> - let open Loc in - let remover = - match Parser_env.last_loc env with - | None -> None - | Some _ when not (Peek.has_eaten_comments env) -> None - | Some last_loc -> - Parser_env.consume_comments_until env last_loc._end; - let remover = new trailing_comments_remover ~after_pos:last_loc._end in - Some remover - in - { - trailing = []; - remove_trailing = - (fun node f -> - match remover with - | None -> node - | Some remover -> f remover node); - } - -(* Consumes and returns comments on the same line as the previous token. Also returns a remover - function which can be used to remove comments beginning after the previous token's line. *) -let trailing_and_remover_after_last_line : Parser_env.env -> trailing_and_remover_result = - fun env -> - let open Loc in - let (trailing, remover) = - match Parser_env.last_loc env with - | None -> ([], None) - | Some _ when not (Peek.has_eaten_comments env) -> (Eat.comments_until_next_line env, None) - | Some last_loc -> - Parser_env.consume_comments_until env last_loc._end; - let trailing = Eat.comments_until_next_line env in - let next_line_start = { line = last_loc._end.line + 1; column = 0 } in - let remover = new trailing_comments_remover ~after_pos:next_line_start in - (trailing, Some remover) - in - { - trailing; - remove_trailing = - (fun node f -> - match remover with - | None -> node - | Some remover -> f remover node); - } - -let trailing_and_remover : Parser_env.env -> trailing_and_remover_result = - fun env -> - if Peek.is_line_terminator env then - trailing_and_remover_after_last_line env - else - trailing_and_remover_after_last_loc env - -let id_remove_trailing env id = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing id (fun remover id -> remover#identifier id) - -let expression_remove_trailing env expr = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing expr (fun remover expr -> remover#expression expr) - -let block_remove_trailing env block = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing block (fun remover (loc, str) -> (loc, remover#block loc str)) - -let type_params_remove_trailing env tparams = - match tparams with - | None -> None - | Some tparams -> - let { remove_trailing; _ } = trailing_and_remover env in - Some (remove_trailing tparams (fun remover tparams -> remover#type_params tparams)) - -let type_remove_trailing env ty = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing ty (fun remover ty -> remover#type_ ty) - -let type_annotation_hint_remove_trailing env annot = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing annot (fun remover annot -> remover#type_annotation_hint annot) - -let function_params_remove_trailing env params = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing params (fun remover params -> remover#function_params params) - -let predicate_remove_trailing env pred = - match pred with - | None -> None - | Some pred -> - let { remove_trailing; _ } = trailing_and_remover env in - Some (remove_trailing pred (fun remover pred -> remover#predicate pred)) - -let object_key_remove_trailing env key = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing key (fun remover key -> remover#object_key key) - -let generic_type_remove_trailing env ty = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing ty (fun remover ty -> map_loc remover#generic_type ty) - -let generic_type_list_remove_trailing env extends = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing extends (fun remover extends -> - id_list_last (map_loc remover#generic_type) extends - ) - -let class_implements_remove_trailing env implements = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing implements (fun remover impl -> remover#class_implements impl) - -let string_literal_remove_trailing env str = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing str (fun remover (loc, str) -> (loc, remover#string_literal_type loc str)) - -let statement_add_comments - ((loc, stmt) : (Loc.t, Loc.t) Statement.t) (comments : (Loc.t, unit) Syntax.t option) : - (Loc.t, Loc.t) Statement.t = - let open Statement in - let merge_comments inner = Flow_ast_utils.merge_comments ~inner ~outer:comments in - let merge_comments_with_internal inner = - Flow_ast_utils.merge_comments_with_internal ~inner ~outer:comments - in - ( loc, - match stmt with - | Block ({ Block.comments; _ } as s) -> - Block { s with Block.comments = merge_comments_with_internal comments } - | Break ({ Break.comments; _ } as s) -> - Break { s with Break.comments = merge_comments comments } - | ClassDeclaration ({ Class.comments; _ } as s) -> - ClassDeclaration { s with Class.comments = merge_comments comments } - | Continue ({ Continue.comments; _ } as s) -> - Continue { s with Continue.comments = merge_comments comments } - | Debugger { Debugger.comments } -> Debugger { Debugger.comments = merge_comments comments } - | DeclareClass ({ DeclareClass.comments; _ } as s) -> - DeclareClass { s with DeclareClass.comments = merge_comments comments } - | DeclareExportDeclaration ({ DeclareExportDeclaration.comments; _ } as s) -> - DeclareExportDeclaration - { s with DeclareExportDeclaration.comments = merge_comments comments } - | DeclareFunction ({ DeclareFunction.comments; _ } as s) -> - DeclareFunction { s with DeclareFunction.comments = merge_comments comments } - | DeclareInterface ({ Interface.comments; _ } as s) -> - DeclareInterface { s with Interface.comments = merge_comments comments } - | DeclareModule ({ DeclareModule.comments; _ } as s) -> - DeclareModule { s with DeclareModule.comments = merge_comments comments } - | DeclareModuleExports ({ DeclareModuleExports.comments; _ } as s) -> - DeclareModuleExports { s with DeclareModuleExports.comments = merge_comments comments } - | DeclareTypeAlias ({ TypeAlias.comments; _ } as s) -> - DeclareTypeAlias { s with TypeAlias.comments = merge_comments comments } - | DeclareOpaqueType ({ OpaqueType.comments; _ } as s) -> - DeclareOpaqueType { s with OpaqueType.comments = merge_comments comments } - | DeclareVariable ({ DeclareVariable.comments; _ } as s) -> - DeclareVariable { s with DeclareVariable.comments = merge_comments comments } - | DoWhile ({ DoWhile.comments; _ } as s) -> - DoWhile { s with DoWhile.comments = merge_comments comments } - | Empty { Empty.comments } -> Empty { Empty.comments = merge_comments comments } - | EnumDeclaration ({ EnumDeclaration.comments; _ } as s) -> - EnumDeclaration { s with EnumDeclaration.comments = merge_comments comments } - | ExportDefaultDeclaration ({ ExportDefaultDeclaration.comments; _ } as s) -> - ExportDefaultDeclaration - { s with ExportDefaultDeclaration.comments = merge_comments comments } - | ExportNamedDeclaration ({ ExportNamedDeclaration.comments; _ } as s) -> - ExportNamedDeclaration { s with ExportNamedDeclaration.comments = merge_comments comments } - | Expression ({ Expression.comments; _ } as s) -> - Expression { s with Expression.comments = merge_comments comments } - | For ({ For.comments; _ } as s) -> For { s with For.comments = merge_comments comments } - | ForIn ({ ForIn.comments; _ } as s) -> - ForIn { s with ForIn.comments = merge_comments comments } - | ForOf ({ ForOf.comments; _ } as s) -> - ForOf { s with ForOf.comments = merge_comments comments } - | FunctionDeclaration ({ Function.comments; _ } as s) -> - FunctionDeclaration { s with Function.comments = merge_comments comments } - | If ({ If.comments; _ } as s) -> If { s with If.comments = merge_comments comments } - | ImportDeclaration ({ ImportDeclaration.comments; _ } as s) -> - ImportDeclaration { s with ImportDeclaration.comments = merge_comments comments } - | InterfaceDeclaration ({ Interface.comments; _ } as s) -> - InterfaceDeclaration { s with Interface.comments = merge_comments comments } - | Labeled ({ Labeled.comments; _ } as s) -> - Labeled { s with Labeled.comments = merge_comments comments } - | Return ({ Return.comments; _ } as s) -> - Return { s with Return.comments = merge_comments comments } - | Switch ({ Switch.comments; _ } as s) -> - Switch { s with Switch.comments = merge_comments comments } - | Throw ({ Throw.comments; _ } as s) -> - Throw { s with Throw.comments = merge_comments comments } - | Try ({ Try.comments; _ } as s) -> Try { s with Try.comments = merge_comments comments } - | TypeAlias ({ TypeAlias.comments; _ } as s) -> - TypeAlias { s with TypeAlias.comments = merge_comments comments } - | OpaqueType ({ OpaqueType.comments; _ } as s) -> - OpaqueType { s with OpaqueType.comments = merge_comments comments } - | VariableDeclaration ({ VariableDeclaration.comments; _ } as s) -> - VariableDeclaration { s with VariableDeclaration.comments = merge_comments comments } - | While ({ While.comments; _ } as s) -> - While { s with While.comments = merge_comments comments } - | With ({ With.comments; _ } as s) -> With { s with With.comments = merge_comments comments } - ) - -(* Collects the first leading and last trailing comment on an AST node or its children. - The first leading comment is the first attached comment that begins before the given node's loc, - and the last trailing comment is the last attached comment that begins after the given node's loc. *) -class ['loc] comment_bounds_collector ~loc = - object (this) - inherit ['loc] Flow_ast_mapper.mapper - - val mutable first_leading = None - - val mutable last_trailing = None - - method comment_bounds = (first_leading, last_trailing) - - method collect_comments : 'internal. ('loc, 'internal) Syntax.t -> unit = - function - | { Syntax.leading; trailing; _ } -> - List.iter this#visit_leading_comment leading; - List.iter this#visit_trailing_comment trailing - - method collect_comments_opt = - function - | None -> () - | Some comments -> this#collect_comments comments - - method visit_leading_comment ((comment_loc, _) as comment) = - let open Loc in - match first_leading with - | None -> if pos_cmp comment_loc.start loc.start < 0 then first_leading <- Some comment - | Some (current_first_loc, _) -> - if pos_cmp comment_loc.start current_first_loc.start < 0 then first_leading <- Some comment - - method visit_trailing_comment ((comment_loc, _) as comment) = - let open Loc in - match last_trailing with - | None -> if pos_cmp comment_loc.start loc._end >= 0 then last_trailing <- Some comment - | Some (current_last_loc, _) -> - if pos_cmp current_last_loc.start comment_loc.start < 0 then last_trailing <- Some comment - - method! syntax comments = - this#collect_comments comments; - comments - - method! block _loc block = - let { Statement.Block.comments; _ } = block in - this#collect_comments_opt comments; - block - end - -(* Given an AST node and a function to collect all its comments, return the first leading - and last trailing comment on the node. *) -let comment_bounds loc node f = - let collector = new comment_bounds_collector ~loc in - ignore (f collector node); - collector#comment_bounds - -(* Expand node's loc to include its attached comments *) -let expand_loc_with_comment_bounds loc (first_leading, last_trailing) = - let open Loc in - let start = - match first_leading with - | None -> loc - | Some (first_leading_loc, _) -> first_leading_loc - in - let _end = - match last_trailing with - | None -> loc - | Some (last_trailing_loc, _) -> last_trailing_loc - in - btwn start _end - -(* Remove the trailing comment bound if it is a line comment *) -let comment_bounds_without_trailing_line_comment (leading, trailing) = - match trailing with - | Some (_, { Ast.Comment.kind = Ast.Comment.Line; _ }) -> (leading, None) - | _ -> (leading, trailing) - -let collect_without_trailing_line_comment collector = - comment_bounds_without_trailing_line_comment collector#comment_bounds - -(* Return the first leading and last trailing comment of a statement *) -let statement_comment_bounds ((loc, _) as stmt : (Loc.t, Loc.t) Statement.t) : - Loc.t Comment.t option * Loc.t Comment.t option = - let collector = new comment_bounds_collector ~loc in - ignore (collector#statement stmt); - collector#comment_bounds - -let expression_comment_bounds ((loc, _) as expr) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#expression expr); - collector#comment_bounds - -let type_comment_bounds ((loc, _) as ty) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#type_ ty); - collector#comment_bounds - -let block_comment_bounds (loc, block) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#block loc block); - collector#comment_bounds - -let object_property_comment_bounds property = - let open Ast.Expression.Object in - let collector = - match property with - | Property ((loc, _) as p) -> - let collector = new comment_bounds_collector ~loc in - ignore (collector#object_property p); - collector - | SpreadProperty ((loc, _) as p) -> - let collector = new comment_bounds_collector ~loc in - ignore (collector#spread_property p); - collector - in - collect_without_trailing_line_comment collector - -let object_type_property_comment_bounds property = - let open Ast.Type.Object in - let collector = - match property with - | Property ((loc, _) as p) -> - let collector = new comment_bounds_collector ~loc in - ignore (collector#object_property_type p); - collector - | SpreadProperty ((loc, _) as p) -> - let collector = new comment_bounds_collector ~loc in - ignore (collector#object_spread_property_type p); - collector - | Indexer ((loc, _) as p) -> - let collector = new comment_bounds_collector ~loc in - ignore (collector#object_indexer_property_type p); - collector - | InternalSlot ((loc, _) as p) -> - let collector = new comment_bounds_collector ~loc in - ignore (collector#object_internal_slot_property_type p); - collector - | CallProperty ((loc, _) as p) -> - let collector = new comment_bounds_collector ~loc in - ignore (collector#object_call_property_type p); - collector - in - collect_without_trailing_line_comment collector - -let object_pattern_property_comment_bounds loc property = - let collector = new comment_bounds_collector ~loc in - ignore (collector#pattern_object_p property); - collect_without_trailing_line_comment collector - -let switch_case_comment_bounds (loc, case) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#switch_case (loc, case)); - collector#comment_bounds - -let function_param_comment_bounds (loc, param) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#function_param (loc, param)); - collect_without_trailing_line_comment collector - -let function_rest_param_comment_bounds (loc, param) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#function_rest_param (loc, param)); - collect_without_trailing_line_comment collector - -let function_this_param_comment_bounds (loc, param) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#function_this_param (loc, param)); - collect_without_trailing_line_comment collector - -let function_type_param_comment_bounds (loc, param) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#function_param_type (loc, param)); - collect_without_trailing_line_comment collector - -let function_type_rest_param_comment_bounds (loc, param) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#function_rest_param_type (loc, param)); - collect_without_trailing_line_comment collector - -let function_type_this_param_comment_bounds (loc, param) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#function_this_param_type (loc, param)); - collect_without_trailing_line_comment collector - -let array_element_comment_bounds loc element = - let collector = new comment_bounds_collector ~loc in - ignore (collector#array_element element); - collect_without_trailing_line_comment collector - -let array_pattern_element_comment_bounds loc element = - let collector = new comment_bounds_collector ~loc in - ignore (collector#pattern_array_e element); - collect_without_trailing_line_comment collector - -let expression_or_spread_comment_bounds loc expr_or_spread = - let collector = new comment_bounds_collector ~loc in - ignore (collector#expression_or_spread expr_or_spread); - collect_without_trailing_line_comment collector - -let call_type_arg_comment_bounds loc arg = - let collector = new comment_bounds_collector ~loc in - ignore (collector#call_type_arg arg); - collect_without_trailing_line_comment collector - -let type_param_comment_bounds (loc, param) = - let collector = new comment_bounds_collector ~loc in - ignore (collector#type_param (loc, param)); - collect_without_trailing_line_comment collector - -let function_body_comment_bounds body = - let loc = - match body with - | Ast.Function.BodyBlock (loc, _) -> loc - | Ast.Function.BodyExpression (loc, _) -> loc - in - let collector = new comment_bounds_collector ~loc in - ignore (collector#function_body_any body); - collector#comment_bounds - -let if_alternate_statement_comment_bounds loc alternate = - let collector = new comment_bounds_collector ~loc in - ignore (collector#if_alternate_statement loc alternate); - collector#comment_bounds - -let member_property_comment_bounds loc property = - let collector = new comment_bounds_collector ~loc in - ignore (collector#member_property property); - collector#comment_bounds diff --git a/jscomp/js_parser/declaration_parser.ml b/jscomp/js_parser/declaration_parser.ml deleted file mode 100644 index ef9f983..0000000 --- a/jscomp/js_parser/declaration_parser.ml +++ /dev/null @@ -1,432 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Token -open Parser_common -open Parser_env -open Flow_ast -open Comment_attachment - -module type DECLARATION = sig - val async : env -> bool * Loc.t Comment.t list - - val generator : env -> bool * Loc.t Comment.t list - - val variance : env -> bool -> bool -> Loc.t Variance.t option - - val function_params : await:bool -> yield:bool -> env -> (Loc.t, Loc.t) Ast.Function.Params.t - - val function_body : - env -> - async:bool -> - generator:bool -> - expression:bool -> - simple_params:bool -> - (Loc.t, Loc.t) Function.body * bool - - val strict_post_check : - env -> - contains_use_strict:bool -> - (Loc.t, Loc.t) Identifier.t option -> - (Loc.t, Loc.t) Ast.Function.Params.t -> - unit - - val let_ : - env -> - (Loc.t, Loc.t) Statement.VariableDeclaration.Declarator.t list - * Loc.t Ast.Comment.t list - * (Loc.t * Parse_error.t) list - - val const : - env -> - (Loc.t, Loc.t) Statement.VariableDeclaration.Declarator.t list - * Loc.t Ast.Comment.t list - * (Loc.t * Parse_error.t) list - - val var : - env -> - (Loc.t, Loc.t) Statement.VariableDeclaration.Declarator.t list - * Loc.t Ast.Comment.t list - * (Loc.t * Parse_error.t) list - - val _function : env -> (Loc.t, Loc.t) Statement.t - - val enum_declaration : env -> (Loc.t, Loc.t) Statement.t -end - -module Declaration (Parse : Parser_common.PARSER) (Type : Type_parser.TYPE) : DECLARATION = struct - module Enum = Enum_parser.Enum (Parse) - - let check_param = - let rec pattern ((env, _) as check_env) (loc, p) = - Pattern.( - match p with - | Object o -> _object check_env o - | Array arr -> _array check_env arr - | Identifier id -> identifier_pattern check_env id - | Expression _ -> - error_at env (loc, Parse_error.ExpectedPatternFoundExpression); - check_env - ) - and _object check_env o = List.fold_left object_property check_env o.Pattern.Object.properties - and object_property check_env = - let open Pattern.Object in - function - | Property (_, property) -> - Property.( - let check_env = - match property.key with - | Identifier id -> identifier_no_dupe_check check_env id - | _ -> check_env - in - pattern check_env property.pattern - ) - | RestElement (_, { Pattern.RestElement.argument; comments = _ }) -> - pattern check_env argument - and _array check_env arr = List.fold_left array_element check_env arr.Pattern.Array.elements - and array_element check_env = - let open Pattern.Array in - function - | Hole _ -> check_env - | Element (_, { Element.argument; default = _ }) -> pattern check_env argument - | RestElement (_, { Pattern.RestElement.argument; comments = _ }) -> - pattern check_env argument - and identifier_pattern check_env { Pattern.Identifier.name = id; _ } = identifier check_env id - and identifier (env, param_names) ((loc, { Identifier.name; comments = _ }) as id) = - if SSet.mem name param_names then error_at env (loc, Parse_error.StrictParamDupe); - let (env, param_names) = identifier_no_dupe_check (env, param_names) id in - (env, SSet.add name param_names) - and identifier_no_dupe_check (env, param_names) (loc, { Identifier.name; comments = _ }) = - if is_restricted name then strict_error_at env (loc, Parse_error.StrictParamName); - if is_future_reserved name || is_strict_reserved name then - strict_error_at env (loc, Parse_error.StrictReservedWord); - (env, param_names) - in - pattern - - let strict_post_check env ~contains_use_strict id params = - let strict_mode = Parser_env.in_strict_mode env in - let simple = is_simple_parameter_list params in - let (_, { Ast.Function.Params.params; rest; this_ = _; comments = _ }) = params in - (* If we were already in strict mode and therefore already threw strict - errors, we want to do these checks outside of strict mode. If we - were in non-strict mode but the function contains "use strict", then - we want to do these checks in strict mode *) - let env = - if strict_mode then - with_strict false env - else - with_strict contains_use_strict env - in - if contains_use_strict || strict_mode || not simple then ( - (match id with - | Some (loc, { Identifier.name; comments = _ }) -> - if is_restricted name then strict_error_at env (loc, Parse_error.StrictFunctionName); - if is_future_reserved name || is_strict_reserved name then - strict_error_at env (loc, Parse_error.StrictReservedWord) - | None -> ()); - let acc = - List.fold_left - (fun acc (_, { Function.Param.argument; default = _ }) -> check_param acc argument) - (env, SSet.empty) - params - in - match rest with - | Some (_, { Function.RestParam.argument; comments = _ }) -> ignore (check_param acc argument) - | None -> () - ) - - let function_params = - let rec param = - with_loc (fun env -> - if Peek.token env = T_THIS then error env Parse_error.ThisParamMustBeFirst; - let argument = Parse.pattern env Parse_error.StrictParamName in - let default = - if Peek.token env = T_ASSIGN then ( - Expect.token env T_ASSIGN; - Some (Parse.assignment env) - ) else - None - in - { Function.Param.argument; default } - ) - and param_list env acc = - match Peek.token env with - | (T_EOF | T_RPAREN | T_ELLIPSIS) as t -> - let rest = - if t = T_ELLIPSIS then - let leading = Peek.comments env in - let (loc, id) = - with_loc - (fun env -> - Expect.token env T_ELLIPSIS; - Parse.pattern env Parse_error.StrictParamName) - env - in - Some - ( loc, - { - Function.RestParam.argument = id; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - else - None - in - if Peek.token env <> T_RPAREN then error env Parse_error.ParameterAfterRestParameter; - (List.rev acc, rest) - | _ -> - let the_param = param env in - if Peek.token env <> T_RPAREN then Expect.token env T_COMMA; - param_list env (the_param :: acc) - in - let this_param_annotation env = - if should_parse_types env && Peek.token env = T_THIS then ( - let leading = Peek.comments env in - let (this_loc, this_param) = - with_loc - (fun env -> - Expect.token env T_THIS; - if Peek.token env <> T_COLON then begin - error env Parse_error.ThisParamAnnotationRequired; - None - end else - Some (Type.annotation env)) - env - in - match this_param with - | None -> None - | Some annot -> - if Peek.token env = T_COMMA then Eat.token env; - Some - ( this_loc, - { - Ast.Function.ThisParam.annot; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - ) else - None - in - fun ~await ~yield -> - with_loc (fun env -> - let env = - env - |> with_allow_await await - |> with_allow_yield yield - |> with_in_formal_parameters true - in - let leading = Peek.comments env in - Expect.token env T_LPAREN; - let this_ = this_param_annotation env in - let (params, rest) = param_list env [] in - let internal = Peek.comments env in - Expect.token env T_RPAREN; - let trailing = Eat.trailing_comments env in - { - Ast.Function.Params.params; - rest; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - this_; - } - ) - - let function_body env ~async ~generator ~expression ~simple_params = - let env = enter_function env ~async ~generator ~simple_params in - let (body_block, contains_use_strict) = Parse.function_block_body env ~expression in - (Function.BodyBlock body_block, contains_use_strict) - - let variance env is_async is_generator = - let loc = Peek.loc env in - let variance = - match Peek.token env with - | T_PLUS -> - let leading = Peek.comments env in - Eat.token env; - Some - ( loc, - { Variance.kind = Variance.Plus; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - | T_MINUS -> - let leading = Peek.comments env in - Eat.token env; - Some - ( loc, - { - Variance.kind = Variance.Minus; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - | _ -> None - in - match variance with - | Some (loc, _) when is_async || is_generator -> - error_at env (loc, Parse_error.UnexpectedVariance); - None - | _ -> variance - - let generator env = - if Peek.token env = T_MULT then ( - let leading = Peek.comments env in - Eat.token env; - (true, leading) - ) else - (false, []) - - (* Returns true and consumes a token if the token is `async` and the token after it is on - the same line (see https://tc39.github.io/ecma262/#sec-async-function-definitions) *) - let async env = - if Peek.token env = T_ASYNC && not (Peek.ith_is_line_terminator ~i:1 env) then - let leading = Peek.comments env in - let () = Eat.token env in - (true, leading) - else - (false, []) - - let _function = - with_loc (fun env -> - let (async, leading_async) = async env in - let (sig_loc, (generator, tparams, id, params, return, predicate, leading)) = - with_loc - (fun env -> - let leading_function = Peek.comments env in - Expect.token env T_FUNCTION; - let (generator, leading_generator) = generator env in - let leading = List.concat [leading_async; leading_function; leading_generator] in - let (tparams, id) = - match (in_export_default env, Peek.token env) with - | (true, T_LPAREN) -> (None, None) - | (true, T_LESS_THAN) -> - let tparams = type_params_remove_trailing env (Type.type_params env) in - let id = - if Peek.token env = T_LPAREN then - None - else - let id = - id_remove_trailing - env - (Parse.identifier ~restricted_error:Parse_error.StrictFunctionName env) - in - Some id - in - (tparams, id) - | _ -> - let id = - if Peek.is_identifier env then - id_remove_trailing - env - (Parse.identifier ~restricted_error:Parse_error.StrictFunctionName env) - else ( - (* don't consume the identifier here like Parse.identifier does. *) - error_nameless_declaration env "function"; - (Peek.loc env, { Identifier.name = ""; comments = None }) - ) - in - let tparams = type_params_remove_trailing env (Type.type_params env) in - (tparams, Some id) - in - let params = - let params = function_params ~await:async ~yield:generator env in - if Peek.token env = T_COLON then - params - else - function_params_remove_trailing env params - in - let (return, predicate) = Type.annotation_and_predicate_opt env in - let (return, predicate) = - match predicate with - | None -> (type_annotation_hint_remove_trailing env return, predicate) - | Some _ -> (return, predicate_remove_trailing env predicate) - in - (generator, tparams, id, params, return, predicate, leading)) - env - in - let simple_params = is_simple_parameter_list params in - let (body, contains_use_strict) = - function_body env ~async ~generator ~expression:false ~simple_params - in - strict_post_check env ~contains_use_strict id params; - Statement.FunctionDeclaration - { - Function.id; - params; - body; - generator; - async; - predicate; - return; - tparams; - sig_loc; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - - let variable_declaration_list = - let variable_declaration env = - let (loc, (decl, err)) = - with_loc - (fun env -> - let id = Parse.pattern env Parse_error.StrictVarName in - let (init, err) = - if Eat.maybe env T_ASSIGN then - (Some (Parse.assignment env), None) - else - match id with - | (_, Ast.Pattern.Identifier _) -> (None, None) - | (loc, _) -> (None, Some (loc, Parse_error.NoUninitializedDestructuring)) - in - (Ast.Statement.VariableDeclaration.Declarator.{ id; init }, err)) - env - in - ((loc, decl), err) - in - let rec helper env decls errs = - let (decl, err) = variable_declaration env in - let decls = decl :: decls in - let errs = - match err with - | Some x -> x :: errs - | None -> errs - in - if Eat.maybe env T_COMMA then - helper env decls errs - else - (List.rev decls, List.rev errs) - in - (fun env -> helper env [] []) - - let declarations token env = - let leading = Peek.comments env in - Expect.token env token; - let (declarations, errs) = variable_declaration_list env in - (declarations, leading, errs) - - let var = declarations T_VAR - - let const env = - let env = env |> with_no_let true in - let (declarations, leading_comments, errs) = declarations T_CONST env in - (* Make sure all consts defined are initialized *) - let errs = - List.fold_left - (fun errs decl -> - match decl with - | (loc, { Statement.VariableDeclaration.Declarator.init = None; _ }) -> - (loc, Parse_error.NoUninitializedConst) :: errs - | _ -> errs) - errs - declarations - in - (declarations, leading_comments, List.rev errs) - - let let_ env = - let env = env |> with_no_let true in - declarations T_LET env - - let enum_declaration = Enum.declaration -end diff --git a/jscomp/js_parser/dune b/jscomp/js_parser/dune deleted file mode 100644 index 6e59d21..0000000 --- a/jscomp/js_parser/dune +++ /dev/null @@ -1,5 +0,0 @@ -(library - (name js_parser) - (wrapped false) - (flags - (:standard -w -A))) diff --git a/jscomp/js_parser/enum_common.ml b/jscomp/js_parser/enum_common.ml deleted file mode 100644 index 45b52ee..0000000 --- a/jscomp/js_parser/enum_common.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) -open Primitive_deriving -type explicit_type = - | Boolean - | Number - | String - | Symbol -[@@deriving_inline compare] -let _ = fun (_ : explicit_type) -> () -let compare_explicit_type = - (Ppx_compare_lib.polymorphic_compare : explicit_type -> - explicit_type -> int) -let _ = compare_explicit_type -[@@@end] -let string_of_explicit_type = function - | Boolean -> "boolean" - | Number -> "number" - | String -> "string" - | Symbol -> "symbol" diff --git a/jscomp/js_parser/enum_parser.ml b/jscomp/js_parser/enum_parser.ml deleted file mode 100644 index e5eb027..0000000 --- a/jscomp/js_parser/enum_parser.ml +++ /dev/null @@ -1,435 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -open Flow_ast -open Parser_common -open Parser_env -open Token - -module Enum (Parse : Parser_common.PARSER) : sig - val declaration : env -> (Loc.t, Loc.t) Statement.t -end = struct - open Flow_ast.Statement.EnumDeclaration - - type members = { - boolean_members: (Loc.t BooleanLiteral.t, Loc.t) InitializedMember.t list; - number_members: (Loc.t NumberLiteral.t, Loc.t) InitializedMember.t list; - string_members: (Loc.t StringLiteral.t, Loc.t) InitializedMember.t list; - defaulted_members: Loc.t DefaultedMember.t list; - } - - type acc = { - members: members; - seen_names: SSet.t; - has_unknown_members: bool; - internal_comments: Loc.t Comment.t list; - } - - type init = - | NoInit - | InvalidInit of Loc.t - | BooleanInit of Loc.t * Loc.t BooleanLiteral.t - | NumberInit of Loc.t * Loc.t NumberLiteral.t - | StringInit of Loc.t * Loc.t StringLiteral.t - - let empty_members = - { boolean_members = []; number_members = []; string_members = []; defaulted_members = [] } - - let empty_acc = - { - members = empty_members; - seen_names = SSet.empty; - has_unknown_members = false; - internal_comments = []; - } - - let end_of_member_init env = - match Peek.token env with - | T_SEMICOLON - | T_COMMA - | T_RCURLY -> - true - | _ -> false - - let member_init env = - let loc = Peek.loc env in - let leading = Peek.comments env in - match Peek.token env with - | T_NUMBER { kind; raw } -> - let value = Parse.number env kind raw in - let trailing = Eat.trailing_comments env in - if end_of_member_init env then - NumberInit - ( loc, - { - NumberLiteral.value; - raw; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - else - InvalidInit loc - | T_STRING (loc, value, raw, octal) -> - if octal then strict_error env Parse_error.StrictOctalLiteral; - Eat.token env; - let trailing = Eat.trailing_comments env in - if end_of_member_init env then - StringInit - ( loc, - { - StringLiteral.value; - raw; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - else - InvalidInit loc - | (T_TRUE | T_FALSE) as token -> - Eat.token env; - let trailing = Eat.trailing_comments env in - if end_of_member_init env then - BooleanInit - ( loc, - { - BooleanLiteral.value = token = T_TRUE; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - else - InvalidInit loc - | _ -> - Eat.token env; - InvalidInit loc - - let member_raw = - with_loc (fun env -> - let id = identifier_name env in - let init = - match Peek.token env with - | T_ASSIGN -> - Expect.token env T_ASSIGN; - member_init env - | T_COLON -> - let (_, { Identifier.name = member_name; _ }) = id in - error env (Parse_error.EnumInvalidInitializerSeparator { member_name }); - Expect.token env T_COLON; - member_init env - | _ -> NoInit - in - (id, init) - ) - - let check_explicit_type_mismatch env ~enum_name ~explicit_type ~member_name literal_type loc = - match explicit_type with - | Some enum_type when enum_type <> literal_type -> - error_at - env - (loc, Parse_error.EnumInvalidMemberInitializer { enum_name; explicit_type; member_name }) - | _ -> () - - let is_a_to_z c = c >= 'a' && c <= 'z' - - let enum_member ~enum_name ~explicit_type acc env = - let { members; seen_names; _ } = acc in - let (member_loc, (id, init)) = member_raw env in - let (id_loc, { Identifier.name = member_name; _ }) = id in - (* if we parsed an empty name, something has gone wrong and we should abort analysis *) - if member_name = "" then - acc - else ( - if is_a_to_z @@ member_name.[0] then - error_at env (id_loc, Parse_error.EnumInvalidMemberName { enum_name; member_name }); - if SSet.mem member_name seen_names then - error_at env (id_loc, Parse_error.EnumDuplicateMemberName { enum_name; member_name }); - let acc = { acc with seen_names = SSet.add member_name seen_names } in - let check_explicit_type_mismatch = - check_explicit_type_mismatch env ~enum_name ~explicit_type ~member_name - in - match init with - | BooleanInit (loc, value) -> - check_explicit_type_mismatch Enum_common.Boolean loc; - let member = (member_loc, { InitializedMember.id; init = (loc, value) }) in - { acc with members = { members with boolean_members = member :: members.boolean_members } } - | NumberInit (loc, value) -> - check_explicit_type_mismatch Enum_common.Number loc; - let member = (member_loc, { InitializedMember.id; init = (loc, value) }) in - { acc with members = { members with number_members = member :: members.number_members } } - | StringInit (loc, value) -> - check_explicit_type_mismatch Enum_common.String loc; - let member = (member_loc, { InitializedMember.id; init = (loc, value) }) in - { acc with members = { members with string_members = member :: members.string_members } } - | InvalidInit loc -> - error_at - env - (loc, Parse_error.EnumInvalidMemberInitializer { enum_name; explicit_type; member_name }); - acc - | NoInit -> - begin - match explicit_type with - | Some Enum_common.Boolean -> - error_at - env - (member_loc, Parse_error.EnumBooleanMemberNotInitialized { enum_name; member_name }); - acc - | Some Enum_common.Number -> - error_at - env - (member_loc, Parse_error.EnumNumberMemberNotInitialized { enum_name; member_name }); - acc - | Some Enum_common.String - | Some Enum_common.Symbol - | None -> - let member = (member_loc, { DefaultedMember.id }) in - { - acc with - members = { members with defaulted_members = member :: members.defaulted_members }; - } - end - ) - - let rec enum_members ~enum_name ~explicit_type acc env = - match Peek.token env with - | T_RCURLY - | T_EOF -> - ( { - boolean_members = List.rev acc.members.boolean_members; - number_members = List.rev acc.members.number_members; - string_members = List.rev acc.members.string_members; - defaulted_members = List.rev acc.members.defaulted_members; - }, - acc.has_unknown_members, - acc.internal_comments - ) - | T_ELLIPSIS -> - let loc = Peek.loc env in - (* Internal comments may appear before the ellipsis *) - let internal_comments = Peek.comments env in - Eat.token env; - (match Peek.token env with - | T_RCURLY - | T_EOF -> - () - | T_COMMA -> - Expect.token env T_COMMA; - let trailing_comma = - match Peek.token env with - | T_RCURLY - | T_EOF -> - true - | _ -> false - in - error_at env (loc, Parse_error.EnumInvalidEllipsis { trailing_comma }) - | _ -> error_at env (loc, Parse_error.EnumInvalidEllipsis { trailing_comma = false })); - enum_members - ~enum_name - ~explicit_type - { acc with has_unknown_members = true; internal_comments } - env - | _ -> - let acc = enum_member ~enum_name ~explicit_type acc env in - (match Peek.token env with - | T_RCURLY - | T_EOF -> - () - | T_SEMICOLON -> - error env Parse_error.EnumInvalidMemberSeparator; - Expect.token env T_SEMICOLON - | _ -> Expect.token env T_COMMA); - enum_members ~enum_name ~explicit_type acc env - - let string_body - ~env ~enum_name ~is_explicit ~has_unknown_members string_members defaulted_members comments = - let initialized_len = List.length string_members in - let defaulted_len = List.length defaulted_members in - let defaulted_body () = - StringBody - { - StringBody.members = StringBody.Defaulted defaulted_members; - explicit_type = is_explicit; - has_unknown_members; - comments; - } - in - let initialized_body () = - StringBody - { - StringBody.members = StringBody.Initialized string_members; - explicit_type = is_explicit; - has_unknown_members; - comments; - } - in - match (initialized_len, defaulted_len) with - | (0, 0) - | (0, _) -> - defaulted_body () - | (_, 0) -> initialized_body () - | _ when defaulted_len > initialized_len -> - List.iter - (fun (loc, _) -> - error_at env (loc, Parse_error.EnumStringMemberInconsistentlyInitailized { enum_name })) - string_members; - defaulted_body () - | _ -> - List.iter - (fun (loc, _) -> - error_at env (loc, Parse_error.EnumStringMemberInconsistentlyInitailized { enum_name })) - defaulted_members; - initialized_body () - - let parse_explicit_type ~enum_name env = - if Eat.maybe env T_OF then ( - Eat.push_lex_mode env Lex_mode.TYPE; - let result = - match Peek.token env with - | T_BOOLEAN_TYPE BOOLEAN -> Some Enum_common.Boolean - | T_NUMBER_TYPE -> Some Enum_common.Number - | T_STRING_TYPE -> Some Enum_common.String - | T_SYMBOL_TYPE -> Some Enum_common.Symbol - | T_IDENTIFIER { value; _ } -> - let supplied_type = Some value in - error env (Parse_error.EnumInvalidExplicitType { enum_name; supplied_type }); - None - | _ -> - error env (Parse_error.EnumInvalidExplicitType { enum_name; supplied_type = None }); - None - in - Eat.token env; - Eat.pop_lex_mode env; - result - ) else - None - - let enum_body ~enum_name ~name_loc = - with_loc (fun env -> - let explicit_type = parse_explicit_type ~enum_name env in - let leading = - if explicit_type <> None then - Peek.comments env - else - [] - in - Expect.token env T_LCURLY; - let (members, has_unknown_members, internal) = - enum_members ~enum_name ~explicit_type empty_acc env - in - let internal = internal @ Peek.comments env in - Expect.token env T_RCURLY; - let trailing = - match Peek.token env with - | T_EOF - | T_RCURLY -> - Eat.trailing_comments env - | _ when Peek.is_line_terminator env -> Eat.comments_until_next_line env - | _ -> [] - in - let comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal () - in - let body = - match explicit_type with - | Some Enum_common.Boolean -> - BooleanBody - { - BooleanBody.members = members.boolean_members; - explicit_type = true; - has_unknown_members; - comments; - } - | Some Enum_common.Number -> - NumberBody - { - NumberBody.members = members.number_members; - explicit_type = true; - has_unknown_members; - comments; - } - | Some Enum_common.String -> - string_body - ~env - ~enum_name - ~is_explicit:true - ~has_unknown_members - members.string_members - members.defaulted_members - comments - | Some Enum_common.Symbol -> - SymbolBody - { SymbolBody.members = members.defaulted_members; has_unknown_members; comments } - | None -> - let bools_len = List.length members.boolean_members in - let nums_len = List.length members.number_members in - let strs_len = List.length members.string_members in - let defaulted_len = List.length members.defaulted_members in - let empty () = - StringBody - { - StringBody.members = StringBody.Defaulted []; - explicit_type = false; - has_unknown_members; - comments; - } - in - begin - match (bools_len, nums_len, strs_len, defaulted_len) with - | (0, 0, 0, 0) -> empty () - | (0, 0, _, _) -> - string_body - ~env - ~enum_name - ~is_explicit:false - ~has_unknown_members - members.string_members - members.defaulted_members - comments - | (_, 0, 0, _) when bools_len >= defaulted_len -> - List.iter - (fun (loc, { DefaultedMember.id = (_, { Identifier.name = member_name; _ }) }) -> - error_at - env - (loc, Parse_error.EnumBooleanMemberNotInitialized { enum_name; member_name })) - members.defaulted_members; - BooleanBody - { - BooleanBody.members = members.boolean_members; - explicit_type = false; - has_unknown_members; - comments; - } - | (0, _, 0, _) when nums_len >= defaulted_len -> - List.iter - (fun (loc, { DefaultedMember.id = (_, { Identifier.name = member_name; _ }) }) -> - error_at - env - (loc, Parse_error.EnumNumberMemberNotInitialized { enum_name; member_name })) - members.defaulted_members; - NumberBody - { - NumberBody.members = members.number_members; - explicit_type = false; - has_unknown_members; - comments; - } - | _ -> - error_at env (name_loc, Parse_error.EnumInconsistentMemberValues { enum_name }); - empty () - end - in - body - ) - - let declaration = - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_ENUM; - let id = Parse.identifier env in - let (name_loc, { Identifier.name = enum_name; _ }) = id in - let body = enum_body ~enum_name ~name_loc env in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Statement.EnumDeclaration { id; body; comments } - ) -end diff --git a/jscomp/js_parser/expression_parser.ml b/jscomp/js_parser/expression_parser.ml deleted file mode 100644 index f35eda7..0000000 --- a/jscomp/js_parser/expression_parser.ml +++ /dev/null @@ -1,1734 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Token -open Parser_env -open Flow_ast -open Parser_common -open Comment_attachment - -module type EXPRESSION = sig - val assignment : env -> (Loc.t, Loc.t) Expression.t - - val assignment_cover : env -> pattern_cover - - val conditional : env -> (Loc.t, Loc.t) Expression.t - - val is_assignable_lhs : (Loc.t, Loc.t) Expression.t -> bool - - val left_hand_side : env -> (Loc.t, Loc.t) Expression.t - - val number : env -> number_type -> string -> float - - val sequence : - env -> start_loc:Loc.t -> (Loc.t, Loc.t) Expression.t list -> (Loc.t, Loc.t) Expression.t -end - -module Expression - (Parse : PARSER) - (Type : Type_parser.TYPE) - (Declaration : Declaration_parser.DECLARATION) - (Pattern_cover : Pattern_cover.COVER) : EXPRESSION = struct - type op_precedence = - | Left_assoc of int - | Right_assoc of int - - type group_cover = - | Group_expr of (Loc.t, Loc.t) Expression.t - | Group_typecast of (Loc.t, Loc.t) Expression.TypeCast.t - - let is_tighter a b = - let a_prec = - match a with - | Left_assoc x -> x - | Right_assoc x -> x - 1 - in - let b_prec = - match b with - | Left_assoc x -> x - | Right_assoc x -> x - in - a_prec >= b_prec - - let is_assignable_lhs = - let open Expression in - function - | ( _, - MetaProperty - { - MetaProperty.meta = (_, { Identifier.name = "new"; comments = _ }); - property = (_, { Identifier.name = "target"; comments = _ }); - comments = _; - } - ) -> - false - | ( _, - MetaProperty - { - MetaProperty.meta = (_, { Identifier.name = "import"; comments = _ }); - property = (_, { Identifier.name = "meta"; comments = _ }); - comments = _; - } - ) -> - false - (* #sec-static-semantics-static-semantics-isvalidsimpleassignmenttarget *) - | (_, Array _) - | (_, Identifier _) - | (_, Member _) - | (_, MetaProperty _) - | (_, Object _) -> - true - | (_, ArrowFunction _) - | (_, Assignment _) - | (_, Binary _) - | (_, Call _) - | (_, Class _) - | (_, Comprehension _) - | (_, Conditional _) - | (_, Function _) - | (_, Generator _) - | (_, Import _) - | (_, JSXElement _) - | (_, JSXFragment _) - | (_, Literal _) - | (_, Logical _) - | (_, New _) - | (_, OptionalCall _) - | (_, OptionalMember _) - | (_, Sequence _) - | (_, Super _) - | (_, TaggedTemplate _) - | (_, TemplateLiteral _) - | (_, This _) - | (_, TypeCast _) - | (_, Unary _) - | (_, Update _) - | (_, Yield _) -> - false - - let as_expression = Pattern_cover.as_expression - - let as_pattern = Pattern_cover.as_pattern - - (* AssignmentExpression : - * [+Yield] YieldExpression - * ConditionalExpression - * LeftHandSideExpression = AssignmentExpression - * LeftHandSideExpression AssignmentOperator AssignmentExpression - * ArrowFunctionFunction - * - * Originally we were parsing this without backtracking, but - * ArrowFunctionExpression got too tricky. Oh well. - *) - let rec assignment_cover = - let assignment_but_not_arrow_function_cover env = - let start_loc = Peek.loc env in - let expr_or_pattern = conditional_cover env in - match assignment_op env with - | Some operator -> - let expr = - with_loc - ~start_loc - (fun env -> - let left = as_pattern env expr_or_pattern in - let right = assignment env in - Expression.(Assignment { Assignment.operator; left; right; comments = None })) - env - in - Cover_expr expr - | _ -> expr_or_pattern - in - let error_callback _ = function - (* Don't rollback on these errors. *) - | Parse_error.StrictReservedWord -> () - (* Everything else causes a rollback *) - | _ -> raise Try.Rollback - (* So we may or may not be parsing the first part of an arrow function - * (the part before the =>). We might end up parsing that whole thing or - * we might end up parsing only part of it and thinking we're done. We - * need to look at the next token to figure out if we really parsed an - * assignment expression or if this is just the beginning of an arrow - * function *) - in - let try_assignment_but_not_arrow_function env = - let env = env |> with_error_callback error_callback in - let ret = assignment_but_not_arrow_function_cover env in - match Peek.token env with - | T_ARROW -> - (* x => 123 *) - raise Try.Rollback - | T_COLON - when match last_token env with - | Some T_RPAREN -> true - | _ -> false -> - (* (x): number => 123 *) - raise Try.Rollback - (* async x => 123 -- and we've already parsed async as an identifier - * expression *) - | _ when Peek.is_identifier env -> - begin - match ret with - | Cover_expr (_, Expression.Identifier (_, { Identifier.name = "async"; comments = _ })) - when not (Peek.is_line_terminator env) -> - raise Try.Rollback - | _ -> ret - end - | _ -> ret - in - fun env -> - match (Peek.token env, Peek.is_identifier env) with - | (T_YIELD, _) when allow_yield env -> Cover_expr (yield env) - | ((T_LPAREN as t), _) - | ((T_LESS_THAN as t), _) - | ((T_THIS as t), _) - | (t, true) -> - (* Ok, we don't know if this is going to be an arrow function or a - * regular assignment expression. Let's first try to parse it as an - * assignment expression. If that fails we'll try an arrow function. - * Unless it begins with `async <` in which case we first try parsing - * it as an arrow function, and then an assignment expression. - *) - let (initial, secondary) = - if t = T_ASYNC && should_parse_types env && Peek.ith_token ~i:1 env = T_LESS_THAN then - (try_arrow_function, try_assignment_but_not_arrow_function) - else - (try_assignment_but_not_arrow_function, try_arrow_function) - in - (match Try.to_parse env initial with - | Try.ParsedSuccessfully expr -> expr - | Try.FailedToParse -> - (match Try.to_parse env secondary with - | Try.ParsedSuccessfully expr -> expr - | Try.FailedToParse -> - (* Well shoot. It doesn't parse cleanly as a normal - * expression or as an arrow_function. Let's treat it as a - * normal assignment expression gone wrong *) - assignment_but_not_arrow_function_cover env)) - | _ -> assignment_but_not_arrow_function_cover env - - and assignment env = as_expression env (assignment_cover env) - - and yield env = - with_loc - (fun env -> - if in_formal_parameters env then error env Parse_error.YieldInFormalParameters; - let leading = Peek.comments env in - let start_loc = Peek.loc env in - Expect.token env T_YIELD; - let end_loc = Peek.loc env in - let (argument, delegate) = - if Peek.is_implicit_semicolon env then - (None, false) - else - let delegate = Eat.maybe env T_MULT in - let has_argument = - match Peek.token env with - | T_SEMICOLON - | T_RBRACKET - | T_RCURLY - | T_RPAREN - | T_COLON - | T_COMMA -> - false - | _ -> true - in - let argument = - if delegate || has_argument then - Some (assignment env) - else - None - in - (argument, delegate) - in - let trailing = - match argument with - | None -> Eat.trailing_comments env - | Some _ -> [] - in - let open Expression in - Yield - Yield. - { - argument; - delegate; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - result_out = Loc.btwn start_loc end_loc; - } - ) - env - - and is_lhs = - let open Expression in - function - | ( _, - MetaProperty - { - MetaProperty.meta = (_, { Identifier.name = "new"; comments = _ }); - property = (_, { Identifier.name = "target"; comments = _ }); - comments = _; - } - ) -> - false - | ( _, - MetaProperty - { - MetaProperty.meta = (_, { Identifier.name = "import"; comments = _ }); - property = (_, { Identifier.name = "meta"; comments = _ }); - comments = _; - } - ) -> - false - (* #sec-static-semantics-static-semantics-isvalidsimpleassignmenttarget *) - | (_, Identifier _) - | (_, Member _) - | (_, MetaProperty _) -> - true - | (_, Array _) - | (_, ArrowFunction _) - | (_, Assignment _) - | (_, Binary _) - | (_, Call _) - | (_, Class _) - | (_, Comprehension _) - | (_, Conditional _) - | (_, Function _) - | (_, Generator _) - | (_, Import _) - | (_, JSXElement _) - | (_, JSXFragment _) - | (_, Literal _) - | (_, Logical _) - | (_, New _) - | (_, Object _) - | (_, OptionalCall _) - | (_, OptionalMember _) - | (_, Sequence _) - | (_, Super _) - | (_, TaggedTemplate _) - | (_, TemplateLiteral _) - | (_, This _) - | (_, TypeCast _) - | (_, Unary _) - | (_, Update _) - | (_, Yield _) -> - false - - and assignment_op env = - let op = - let open Expression.Assignment in - match Peek.token env with - | T_RSHIFT3_ASSIGN -> Some (Some RShift3Assign) - | T_RSHIFT_ASSIGN -> Some (Some RShiftAssign) - | T_LSHIFT_ASSIGN -> Some (Some LShiftAssign) - | T_BIT_XOR_ASSIGN -> Some (Some BitXorAssign) - | T_BIT_OR_ASSIGN -> Some (Some BitOrAssign) - | T_BIT_AND_ASSIGN -> Some (Some BitAndAssign) - | T_MOD_ASSIGN -> Some (Some ModAssign) - | T_DIV_ASSIGN -> Some (Some DivAssign) - | T_MULT_ASSIGN -> Some (Some MultAssign) - | T_EXP_ASSIGN -> Some (Some ExpAssign) - | T_MINUS_ASSIGN -> Some (Some MinusAssign) - | T_PLUS_ASSIGN -> Some (Some PlusAssign) - | T_NULLISH_ASSIGN -> Some (Some NullishAssign) - | T_AND_ASSIGN -> Some (Some AndAssign) - | T_OR_ASSIGN -> Some (Some OrAssign) - | T_ASSIGN -> Some None - | _ -> None - in - if op <> None then Eat.token env; - op - - (* ConditionalExpression : - * LogicalExpression - * LogicalExpression ? AssignmentExpression : AssignmentExpression - *) - and conditional_cover env = - let start_loc = Peek.loc env in - let expr = logical_cover env in - if Peek.token env = T_PLING then ( - Eat.token env; - - (* no_in is ignored for the consequent *) - let env' = env |> with_no_in false in - let consequent = assignment env' in - Expect.token env T_COLON; - let (loc, alternate) = with_loc ~start_loc assignment env in - Cover_expr - ( loc, - let open Expression in - Conditional - { Conditional.test = as_expression env expr; consequent; alternate; comments = None } - ) - ) else - expr - - and conditional env = as_expression env (conditional_cover env) - - (* - * LogicalANDExpression : - * BinaryExpression - * LogicalANDExpression && BitwiseORExpression - * - * LogicalORExpression : - * LogicalANDExpression - * LogicalORExpression || LogicalANDExpression - * LogicalORExpression ?? LogicalANDExpression - * - * LogicalExpression : - * LogicalORExpression - *) - and logical_cover = - let open Expression in - let make_logical env left right operator loc = - let left = as_expression env left in - let right = as_expression env right in - Cover_expr (loc, Logical { Logical.operator; left; right; comments = None }) - in - let rec logical_and env left lloc = - match Peek.token env with - | T_AND -> - Eat.token env; - let (rloc, right) = with_loc binary_cover env in - let loc = Loc.btwn lloc rloc in - let left = make_logical env left right Logical.And loc in - (* `a && b ?? c` is an error, but to recover, try to parse it like `(a && b) ?? c`. *) - let (loc, left) = coalesce ~allowed:false env left loc in - logical_and env left loc - | _ -> (lloc, left) - and logical_or env left lloc = - match Peek.token env with - | T_OR -> - Eat.token env; - let (rloc, right) = with_loc binary_cover env in - let (rloc, right) = logical_and env right rloc in - let loc = Loc.btwn lloc rloc in - let left = make_logical env left right Logical.Or loc in - (* `a || b ?? c` is an error, but to recover, try to parse it like `(a || b) ?? c`. *) - let (loc, left) = coalesce ~allowed:false env left loc in - logical_or env left loc - | _ -> (lloc, left) - and coalesce ~allowed env left lloc = - match Peek.token env with - | T_PLING_PLING -> - if not allowed then error env (Parse_error.NullishCoalescingUnexpectedLogical "??"); - - Expect.token env T_PLING_PLING; - let (rloc, right) = with_loc binary_cover env in - let (rloc, right) = - match Peek.token env with - | (T_AND | T_OR) as t -> - (* `a ?? b || c` is an error. To recover, treat it like `a ?? (b || c)`. *) - error env (Parse_error.NullishCoalescingUnexpectedLogical (Token.value_of_token t)); - let (rloc, right) = logical_and env right rloc in - logical_or env right rloc - | _ -> (rloc, right) - in - let loc = Loc.btwn lloc rloc in - coalesce ~allowed:true env (make_logical env left right Logical.NullishCoalesce loc) loc - | _ -> (lloc, left) - in - fun env -> - let (loc, left) = with_loc binary_cover env in - let (_, left) = - match Peek.token env with - | T_PLING_PLING -> coalesce ~allowed:true env left loc - | _ -> - let (loc, left) = logical_and env left loc in - logical_or env left loc - in - left - - and binary_cover = - let binary_op env = - let ret = - let open Expression.Binary in - match Peek.token env with - (* Most BinaryExpression operators are left associative *) - (* Lowest pri *) - | T_BIT_OR -> Some (BitOr, Left_assoc 2) - | T_BIT_XOR -> Some (Xor, Left_assoc 3) - | T_BIT_AND -> Some (BitAnd, Left_assoc 4) - | T_EQUAL -> Some (Equal, Left_assoc 5) - | T_STRICT_EQUAL -> Some (StrictEqual, Left_assoc 5) - | T_NOT_EQUAL -> Some (NotEqual, Left_assoc 5) - | T_STRICT_NOT_EQUAL -> Some (StrictNotEqual, Left_assoc 5) - | T_LESS_THAN -> Some (LessThan, Left_assoc 6) - | T_LESS_THAN_EQUAL -> Some (LessThanEqual, Left_assoc 6) - | T_GREATER_THAN -> Some (GreaterThan, Left_assoc 6) - | T_GREATER_THAN_EQUAL -> Some (GreaterThanEqual, Left_assoc 6) - | T_IN -> - if no_in env then - None - else - Some (In, Left_assoc 6) - | T_INSTANCEOF -> Some (Instanceof, Left_assoc 6) - | T_LSHIFT -> Some (LShift, Left_assoc 7) - | T_RSHIFT -> Some (RShift, Left_assoc 7) - | T_RSHIFT3 -> Some (RShift3, Left_assoc 7) - | T_PLUS -> Some (Plus, Left_assoc 8) - | T_MINUS -> Some (Minus, Left_assoc 8) - | T_MULT -> Some (Mult, Left_assoc 9) - | T_DIV -> Some (Div, Left_assoc 9) - | T_MOD -> Some (Mod, Left_assoc 9) - | T_EXP -> Some (Exp, Right_assoc 10) - (* Highest priority *) - | _ -> None - in - if ret <> None then Eat.token env; - ret - in - let make_binary left right operator loc = - (loc, Expression.(Binary Binary.{ operator; left; right; comments = None })) - in - let rec add_to_stack right (rop, rpri) rloc = function - | (left, (lop, lpri), lloc) :: rest when is_tighter lpri rpri -> - let loc = Loc.btwn lloc rloc in - let right = make_binary left right lop loc in - add_to_stack right (rop, rpri) loc rest - | stack -> (right, (rop, rpri), rloc) :: stack - in - let rec collapse_stack right rloc = function - | [] -> right - | (left, (lop, _), lloc) :: rest -> - let loc = Loc.btwn lloc rloc in - collapse_stack (make_binary left right lop loc) loc rest - in - let rec helper env stack = - let (right_loc, (is_unary, right)) = - with_loc - (fun env -> - let is_unary = peek_unary_op env <> None in - let right = unary_cover (env |> with_no_in false) in - (is_unary, right)) - env - in - ( if Peek.token env = T_LESS_THAN then - match right with - | Cover_expr (_, Expression.JSXElement _) -> error env Parse_error.AdjacentJSXElements - | _ -> () - ); - match (stack, binary_op env) with - | ([], None) -> right - | (_, None) -> - let right = as_expression env right in - Cover_expr (collapse_stack right right_loc stack) - | (_, Some (rop, rpri)) -> - if is_unary && rop = Expression.Binary.Exp then - error_at env (right_loc, Parse_error.InvalidLHSInExponentiation); - let right = as_expression env right in - helper env (add_to_stack right (rop, rpri) right_loc stack) - in - (fun env -> helper env []) - - and peek_unary_op env = - let open Expression.Unary in - match Peek.token env with - | T_NOT -> Some Not - | T_BIT_NOT -> Some BitNot - | T_PLUS -> Some Plus - | T_MINUS -> Some Minus - | T_TYPEOF -> Some Typeof - | T_VOID -> Some Void - | T_DELETE -> Some Delete - (* If we are in a unary expression context, and within an async function, - * assume that a use of "await" is intended as a keyword, not an ordinary - * identifier. This is a little bit inconsistent, since it can be used as - * an identifier in other contexts (such as a variable name), but it's how - * Babel does it. *) - | T_AWAIT when allow_await env -> Some Await - | _ -> None - - and unary_cover env = - let start_loc = Peek.loc env in - let leading = Peek.comments env in - let op = peek_unary_op env in - match op with - | None -> - let op = - let open Expression.Update in - match Peek.token env with - | T_INCR -> Some Increment - | T_DECR -> Some Decrement - | _ -> None - in - (match op with - | None -> postfix_cover env - | Some operator -> - Eat.token env; - let (loc, argument) = with_loc ~start_loc unary env in - if not (is_lhs argument) then error_at env (fst argument, Parse_error.InvalidLHSInAssignment); - (match argument with - | (_, Expression.Identifier (_, { Identifier.name; comments = _ })) when is_restricted name - -> - strict_error env Parse_error.StrictLHSPrefix - | _ -> ()); - Cover_expr - ( loc, - Expression.( - Update - { - Update.operator; - prefix = true; - argument; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - )) - | Some operator -> - Eat.token env; - let (loc, argument) = with_loc ~start_loc unary env in - let open Expression in - (match (operator, argument) with - | (Unary.Delete, (_, Identifier _)) -> strict_error_at env (loc, Parse_error.StrictDelete) - | (Unary.Delete, (_, Member member)) -> - begin - match member.Ast.Expression.Member.property with - | Ast.Expression.Member.PropertyPrivateName _ -> - error_at env (loc, Parse_error.PrivateDelete) - | _ -> () - end - | _ -> ()); - Cover_expr - ( loc, - let open Expression in - Unary { Unary.operator; argument; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - - and unary env = as_expression env (unary_cover env) - - and postfix_cover env = - let argument = left_hand_side_cover env in - (* No line terminator allowed before operator *) - if Peek.is_line_terminator env then - argument - else - let op = - let open Expression.Update in - match Peek.token env with - | T_INCR -> Some Increment - | T_DECR -> Some Decrement - | _ -> None - in - match op with - | None -> argument - | Some operator -> - let argument = as_expression env argument in - if not (is_lhs argument) then error_at env (fst argument, Parse_error.InvalidLHSInAssignment); - (match argument with - | (_, Expression.Identifier (_, { Identifier.name; comments = _ })) when is_restricted name - -> - strict_error env Parse_error.StrictLHSPostfix - | _ -> ()); - let end_loc = Peek.loc env in - Eat.token env; - let trailing = Eat.trailing_comments env in - let loc = Loc.btwn (fst argument) end_loc in - Cover_expr - ( loc, - Expression.( - Update - { - Update.operator; - prefix = false; - argument; - comments = Flow_ast_utils.mk_comments_opt ~trailing (); - } - ) - ) - - and left_hand_side_cover env = - let start_loc = Peek.loc env in - let allow_new = not (no_new env) in - let env = with_no_new false env in - let expr = - match Peek.token env with - | T_NEW when allow_new -> Cover_expr (new_expression env) - | T_IMPORT -> Cover_expr (import env) - | T_SUPER -> Cover_expr (super env) - | _ when Peek.is_function env -> Cover_expr (_function env) - | _ -> primary_cover env - in - call_cover env start_loc expr - - and left_hand_side env = as_expression env (left_hand_side_cover env) - - and super env = - let (allowed, call_allowed) = - match allow_super env with - | No_super -> (false, false) - | Super_prop -> (true, false) - | Super_prop_or_call -> (true, true) - in - let loc = Peek.loc env in - let leading = Peek.comments env in - Expect.token env T_SUPER; - let trailing = Eat.trailing_comments env in - let super = - ( loc, - Expression.Super - { Expression.Super.comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - in - match Peek.token env with - | T_PERIOD - | T_LBRACKET -> - let super = - if not allowed then ( - error_at env (loc, Parse_error.UnexpectedSuper); - (loc, Expression.Identifier (Flow_ast_utils.ident_of_source (loc, "super"))) - ) else - super - in - call ~allow_optional_chain:false env loc super - | T_LPAREN -> - let super = - if not call_allowed then ( - error_at env (loc, Parse_error.UnexpectedSuperCall); - (loc, Expression.Identifier (Flow_ast_utils.ident_of_source (loc, "super"))) - ) else - super - in - call ~allow_optional_chain:false env loc super - | _ -> - if not allowed then - error_at env (loc, Parse_error.UnexpectedSuper) - else - error_unexpected ~expected:"either a call or access of `super`" env; - super - - and import env = - with_loc - (fun env -> - let leading = Peek.comments env in - let start_loc = Peek.loc env in - Expect.token env T_IMPORT; - if Eat.maybe env T_PERIOD then ( - (* import.meta *) - let import_ident = Flow_ast_utils.ident_of_source (start_loc, "import") in - let meta_loc = Peek.loc env in - Expect.identifier env "meta"; - let meta_ident = Flow_ast_utils.ident_of_source (meta_loc, "meta") in - let trailing = Eat.trailing_comments env in - Expression.MetaProperty - { - Expression.MetaProperty.meta = import_ident; - property = meta_ident; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) else - let leading_arg = Peek.comments env in - Expect.token env T_LPAREN; - let argument = add_comments (assignment (with_no_in false env)) ~leading:leading_arg in - Expect.token env T_RPAREN; - let trailing = Eat.trailing_comments env in - Expression.Import - { - Expression.Import.argument; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - - and call_cover ?(allow_optional_chain = true) ?(in_optional_chain = false) env start_loc left = - let left = member_cover ~allow_optional_chain ~in_optional_chain env start_loc left in - let optional = - match last_token env with - | Some T_PLING_PERIOD -> true - | _ -> false - in - let left_to_callee env = - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing (as_expression env left) (fun remover left -> remover#expression left) - in - let arguments ?targs env callee = - let (args_loc, arguments) = arguments env in - let loc = Loc.btwn start_loc args_loc in - let call = - { Expression.Call.callee; targs; arguments = (args_loc, arguments); comments = None } - in - let call = - if optional || in_optional_chain then - let open Expression in - OptionalCall { OptionalCall.call; optional; filtered_out = loc } - else - Expression.Call call - in - let in_optional_chain = in_optional_chain || optional in - call_cover ~allow_optional_chain ~in_optional_chain env start_loc (Cover_expr (loc, call)) - in - if no_call env then - left - else - match Peek.token env with - | T_LPAREN -> arguments env (left_to_callee env) - | T_LSHIFT - | T_LESS_THAN - when should_parse_types env -> - (* If we are parsing types, then f(e) is a function call with a - type application. If we aren't, it's a nested binary expression. *) - let error_callback _ _ = raise Try.Rollback in - let env = env |> with_error_callback error_callback in - (* Parameterized call syntax is ambiguous, so we fall back to - standard parsing if it fails. *) - Try.or_else env ~fallback:left (fun env -> - let callee = left_to_callee env in - let targs = call_type_args env in - arguments ?targs env callee - ) - | _ -> left - - and call ?(allow_optional_chain = true) env start_loc left = - as_expression env (call_cover ~allow_optional_chain env start_loc (Cover_expr left)) - - and new_expression env = - with_loc - (fun env -> - let start_loc = Peek.loc env in - let leading = Peek.comments env in - Expect.token env T_NEW; - - if in_function env && Peek.token env = T_PERIOD then ( - let trailing = Eat.trailing_comments env in - Eat.token env; - let meta = - Flow_ast_utils.ident_of_source - (start_loc, "new") - ?comments:(Flow_ast_utils.mk_comments_opt ~leading ~trailing ()) - in - match Peek.token env with - | T_IDENTIFIER { raw = "target"; _ } -> - let property = Parse.identifier env in - Expression.(MetaProperty MetaProperty.{ meta; property; comments = None }) - | _ -> - error_unexpected ~expected:"the identifier `target`" env; - Eat.token env; - - (* skip unknown identifier *) - Expression.Identifier meta - (* return `new` identifier *) - ) else - let callee_loc = Peek.loc env in - let expr = - match Peek.token env with - | T_NEW -> new_expression env - | T_SUPER -> super (env |> with_no_call true) - | _ when Peek.is_function env -> _function env - | _ -> primary env - in - let callee = - member ~allow_optional_chain:false (env |> with_no_call true) callee_loc expr - in - (* You can do something like - * new raw`42` - *) - let callee = - let callee = - match Peek.token env with - | T_TEMPLATE_PART part -> tagged_template env callee_loc callee part - | _ -> callee - in - (* Remove trailing comments if the callee is followed by args or type args *) - if Peek.token env = T_LPAREN || (should_parse_types env && Peek.token env = T_LESS_THAN) - then - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing callee (fun remover callee -> remover#expression callee) - else - callee - in - let targs = - (* If we are parsing types, then new C(e) is a constructor with a - type application. If we aren't, it's a nested binary expression. *) - if should_parse_types env then - (* Parameterized call syntax is ambiguous, so we fall back to - standard parsing if it fails. *) - let error_callback _ _ = raise Try.Rollback in - let env = env |> with_error_callback error_callback in - Try.or_else env ~fallback:None call_type_args - else - None - in - let arguments = - match Peek.token env with - | T_LPAREN -> Some (arguments env) - | _ -> None - in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Expression.(New New.{ callee; targs; arguments; comments })) - env - - and call_type_args = - let args = - let rec args_helper env acc = - match Peek.token env with - | T_EOF - | T_GREATER_THAN -> - List.rev acc - | _ -> - let t = - match Peek.token env with - | T_IDENTIFIER { value = "_"; _ } -> - let loc = Peek.loc env in - let leading = Peek.comments env in - Expect.identifier env "_"; - let trailing = Eat.trailing_comments env in - Expression.CallTypeArg.Implicit - ( loc, - { - Expression.CallTypeArg.Implicit.comments = - Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - | _ -> Expression.CallTypeArg.Explicit (Type._type env) - in - let acc = t :: acc in - if Peek.token env <> T_GREATER_THAN then Expect.token env T_COMMA; - args_helper env acc - in - fun env -> - let leading = Peek.comments env in - Expect.token env T_LESS_THAN; - let arguments = args_helper env [] in - let internal = Peek.comments env in - Expect.token env T_GREATER_THAN; - let trailing = - if Peek.token env = T_LPAREN then - let { trailing; _ } = trailing_and_remover env in - trailing - else - Eat.trailing_comments env - in - { - Expression.CallTypeArgs.arguments; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - } - in - fun env -> - Eat.push_lex_mode env Lex_mode.TYPE; - let node = - if Peek.token env = T_LESS_THAN then - Some (with_loc args env) - else - None - in - Eat.pop_lex_mode env; - node - - and arguments = - let spread_element env = - let leading = Peek.comments env in - Expect.token env T_ELLIPSIS; - let argument = assignment env in - Expression.SpreadElement.{ argument; comments = Flow_ast_utils.mk_comments_opt ~leading () } - in - let argument env = - match Peek.token env with - | T_ELLIPSIS -> Expression.Spread (with_loc spread_element env) - | _ -> Expression.Expression (assignment env) - in - let rec arguments' env acc = - match Peek.token env with - | T_EOF - | T_RPAREN -> - List.rev acc - | _ -> - let acc = argument env :: acc in - if Peek.token env <> T_RPAREN then Expect.token env T_COMMA; - arguments' env acc - in - fun env -> - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LPAREN; - let args = arguments' env [] in - let internal = Peek.comments env in - Expect.token env T_RPAREN; - let trailing = Eat.trailing_comments env in - { - Expression.ArgList.arguments = args; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - }) - env - - and member_cover = - let dynamic - ?(allow_optional_chain = true) - ?(in_optional_chain = false) - ?(optional = false) - env - start_loc - left = - let expr = Parse.expression (env |> with_no_call false) in - let last_loc = Peek.loc env in - Expect.token env T_RBRACKET; - let trailing = Eat.trailing_comments env in - let loc = Loc.btwn start_loc last_loc in - let member = - { - Expression.Member._object = as_expression env left; - property = Expression.Member.PropertyExpression expr; - comments = Flow_ast_utils.mk_comments_opt ~trailing (); - } - in - - let member = - if in_optional_chain then - let open Expression in - OptionalMember { OptionalMember.member; optional; filtered_out = loc } - else - Expression.Member member - in - call_cover ~allow_optional_chain ~in_optional_chain env start_loc (Cover_expr (loc, member)) - in - let static - ?(allow_optional_chain = true) - ?(in_optional_chain = false) - ?(optional = false) - env - start_loc - left = - let open Expression.Member in - let (id_loc, property) = - match Peek.token env with - | T_POUND -> - let ((id_loc, { Ast.PrivateName.name; _ }) as id) = private_identifier env in - add_used_private env name id_loc; - (id_loc, PropertyPrivateName id) - | _ -> - let ((id_loc, _) as id) = identifier_name env in - (id_loc, PropertyIdentifier id) - in - let loc = Loc.btwn start_loc id_loc in - (* super.PrivateName is a syntax error *) - begin - match (left, property) with - | (Cover_expr (_, Ast.Expression.Super _), PropertyPrivateName _) -> - error_at env (loc, Parse_error.SuperPrivate) - | _ -> () - end; - let member = - Expression.Member.{ _object = as_expression env left; property; comments = None } - in - let member = - if in_optional_chain then - let open Expression in - OptionalMember { OptionalMember.member; optional; filtered_out = loc } - else - Expression.Member member - in - call_cover ~allow_optional_chain ~in_optional_chain env start_loc (Cover_expr (loc, member)) - in - fun ?(allow_optional_chain = true) ?(in_optional_chain = false) env start_loc left -> - match Peek.token env with - | T_PLING_PERIOD -> - if not allow_optional_chain then error env Parse_error.OptionalChainNew; - - Expect.token env T_PLING_PERIOD; - begin - match Peek.token env with - | T_TEMPLATE_PART _ -> - error env Parse_error.OptionalChainTemplate; - left - | T_LPAREN -> left - | T_LESS_THAN when should_parse_types env -> left - | T_LBRACKET -> - Eat.token env; - dynamic ~allow_optional_chain ~in_optional_chain:true ~optional:true env start_loc left - | _ -> - static ~allow_optional_chain ~in_optional_chain:true ~optional:true env start_loc left - end - | T_LBRACKET -> - Eat.token env; - dynamic ~allow_optional_chain ~in_optional_chain env start_loc left - | T_PERIOD -> - Eat.token env; - static ~allow_optional_chain ~in_optional_chain env start_loc left - | T_TEMPLATE_PART part -> - if in_optional_chain then error env Parse_error.OptionalChainTemplate; - - let expr = tagged_template env start_loc (as_expression env left) part in - call_cover ~allow_optional_chain:false env start_loc (Cover_expr expr) - | _ -> left - - and member ?(allow_optional_chain = true) env start_loc left = - as_expression env (member_cover ~allow_optional_chain env start_loc (Cover_expr left)) - - and _function env = - with_loc - (fun env -> - let (async, leading_async) = Declaration.async env in - let (sig_loc, (id, params, generator, predicate, return, tparams, leading)) = - with_loc - (fun env -> - let leading_function = Peek.comments env in - Expect.token env T_FUNCTION; - let (generator, leading_generator) = Declaration.generator env in - let leading = List.concat [leading_async; leading_function; leading_generator] in - (* `await` is a keyword in async functions: - - proposal-async-iteration/#prod-AsyncGeneratorExpression - - #prod-AsyncFunctionExpression *) - let await = async in - (* `yield` is a keyword in generator functions: - - proposal-async-iteration/#prod-AsyncGeneratorExpression - - #prod-GeneratorExpression *) - let yield = generator in - let (id, tparams) = - if Peek.token env = T_LPAREN then - (None, None) - else - let id = - match Peek.token env with - | T_LESS_THAN -> None - | _ -> - let env = env |> with_allow_await await |> with_allow_yield yield in - let id = - id_remove_trailing - env - (Parse.identifier ~restricted_error:Parse_error.StrictFunctionName env) - in - Some id - in - let tparams = type_params_remove_trailing env (Type.type_params env) in - (id, tparams) - in - (* #sec-function-definitions-static-semantics-early-errors *) - let env = env |> with_allow_super No_super in - let params = - let params = Declaration.function_params ~await ~yield env in - if Peek.token env = T_COLON then - params - else - function_params_remove_trailing env params - in - let (return, predicate) = Type.annotation_and_predicate_opt env in - let (return, predicate) = - match predicate with - | None -> (type_annotation_hint_remove_trailing env return, predicate) - | Some _ -> (return, predicate_remove_trailing env predicate) - in - (id, params, generator, predicate, return, tparams, leading)) - env - in - let simple_params = is_simple_parameter_list params in - let (body, contains_use_strict) = - Declaration.function_body env ~async ~generator ~expression:true ~simple_params - in - Declaration.strict_post_check env ~contains_use_strict id params; - Expression.Function - { - Function.id; - params; - body; - generator; - async; - predicate; - return; - tparams; - sig_loc; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - - and number env kind raw = - let value = - match kind with - | LEGACY_OCTAL -> - strict_error env Parse_error.StrictOctalLiteral; - begin - try Int64.to_float (Int64.of_string ("0o" ^ raw)) with - | Failure _ -> failwith ("Invalid legacy octal " ^ raw) - end - | LEGACY_NON_OCTAL -> - strict_error env Parse_error.StrictNonOctalLiteral; - begin - try float_of_string raw with - | Failure _ -> failwith ("Invalid number " ^ raw) - end - | BINARY - | OCTAL -> - begin - try Int64.to_float (Int64.of_string raw) with - | Failure _ -> failwith ("Invalid binary/octal " ^ raw) - end - | NORMAL -> - begin - try float_of_string raw with - | Failure _ -> failwith ("Invalid number " ^ raw) - end - in - Expect.token env (T_NUMBER { kind; raw }); - value - - and bigint_strip_n raw = - let size = String.length raw in - let str = - if size != 0 && raw.[size - 1] == 'n' then - String.sub raw 0 (size - 1) - else - raw - in - str - - and bigint env kind raw = - let postraw = bigint_strip_n raw in - let value = Int64.of_string_opt postraw in - Expect.token env (T_BIGINT { kind; raw }); - value - - and primary_cover env = - let loc = Peek.loc env in - let leading = Peek.comments env in - match Peek.token env with - | T_THIS -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Cover_expr - ( loc, - Expression.This - { Expression.This.comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - | T_NUMBER { kind; raw } -> - let value = Literal.Number (number env kind raw) in - let trailing = Eat.trailing_comments env in - Cover_expr - ( loc, - let open Expression in - Literal - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - | T_BIGINT { kind; raw } -> - let value = Literal.BigInt (bigint env kind raw) in - let trailing = Eat.trailing_comments env in - Cover_expr - ( loc, - let open Expression in - Literal - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - | T_STRING (loc, value, raw, octal) -> - if octal then strict_error env Parse_error.StrictOctalLiteral; - Eat.token env; - let value = Literal.String value in - let trailing = Eat.trailing_comments env in - Cover_expr - ( loc, - Expression.Literal - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - | (T_TRUE | T_FALSE) as token -> - Eat.token env; - let truthy = token = T_TRUE in - let raw = - if truthy then - "true" - else - "false" - in - let value = Literal.Boolean truthy in - let trailing = Eat.trailing_comments env in - Cover_expr - ( loc, - Expression.Literal - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - | T_NULL -> - Eat.token env; - let raw = "null" in - let value = Literal.Null in - let trailing = Eat.trailing_comments env in - Cover_expr - ( loc, - Expression.Literal - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - | T_LPAREN -> Cover_expr (group env) - | T_LCURLY -> - let (loc, obj, errs) = Parse.object_initializer env in - Cover_patt ((loc, Expression.Object obj), errs) - | T_LBRACKET -> - let (loc, (arr, errs)) = with_loc array_initializer env in - Cover_patt ((loc, Expression.Array arr), errs) - | T_DIV - | T_DIV_ASSIGN -> - Cover_expr (regexp env) - | T_LESS_THAN -> - let (loc, expression) = - match Parse.jsx_element_or_fragment env with - | (loc, `Element e) -> (loc, Expression.JSXElement e) - | (loc, `Fragment f) -> (loc, Expression.JSXFragment f) - in - Cover_expr (loc, expression) - | T_TEMPLATE_PART part -> - let (loc, template) = template_literal env part in - Cover_expr (loc, Expression.TemplateLiteral template) - | T_CLASS -> Cover_expr (Parse.class_expression env) - | _ when Peek.is_identifier env -> - let id = Parse.identifier env in - Cover_expr (fst id, Expression.Identifier id) - | t -> - error_unexpected env; - - (* Let's get rid of the bad token *) - begin - match t with - | T_ERROR _ -> Eat.token env - | _ -> () - end; - - (* Really no idea how to recover from this. I suppose a null - * expression is as good as anything *) - let value = Literal.Null in - let raw = "null" in - let trailing = [] in - Cover_expr - ( loc, - let open Expression in - Literal - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - - and primary env = as_expression env (primary_cover env) - - and template_literal = - let rec template_parts env quasis expressions = - let expr = Parse.expression env in - let expressions = expr :: expressions in - match Peek.token env with - | T_RCURLY -> - Eat.push_lex_mode env Lex_mode.TEMPLATE; - let (loc, part, is_tail) = - match Peek.token env with - | T_TEMPLATE_PART (loc, { cooked; raw; _ }, tail) -> - let open Ast.Expression.TemplateLiteral in - Eat.token env; - (loc, { Element.value = { Element.cooked; raw }; tail }, tail) - | _ -> assert false - in - Eat.pop_lex_mode env; - let quasis = (loc, part) :: quasis in - if is_tail then - (loc, List.rev quasis, List.rev expressions) - else - template_parts env quasis expressions - | _ -> - (* Malformed template *) - error_unexpected ~expected:"a template literal part" env; - let imaginary_quasi = - ( fst expr, - { - Expression.TemplateLiteral.Element.value = - { Expression.TemplateLiteral.Element.raw = ""; cooked = "" }; - tail = true; - } - ) - in - (fst expr, List.rev (imaginary_quasi :: quasis), List.rev expressions) - in - fun env ((start_loc, { cooked; raw; _ }, is_tail) as part) -> - let leading = Peek.comments env in - Expect.token env (T_TEMPLATE_PART part); - let (end_loc, quasis, expressions) = - let head = - ( start_loc, - { - Ast.Expression.TemplateLiteral.Element.value = - { Ast.Expression.TemplateLiteral.Element.cooked; raw }; - tail = is_tail; - } - ) - in - - if is_tail then - (start_loc, [head], []) - else - template_parts env [head] [] - in - let trailing = Eat.trailing_comments env in - let loc = Loc.btwn start_loc end_loc in - ( loc, - { - Expression.TemplateLiteral.quasis; - expressions; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - and tagged_template env start_loc tag part = - let tag = expression_remove_trailing env tag in - let quasi = template_literal env part in - ( Loc.btwn start_loc (fst quasi), - Expression.(TaggedTemplate TaggedTemplate.{ tag; quasi; comments = None }) - ) - - and group env = - let leading = Peek.comments env in - let (loc, cover) = - with_loc - (fun env -> - Expect.token env T_LPAREN; - let expr_start_loc = Peek.loc env in - let expression = assignment env in - let ret = - match Peek.token env with - | T_COLON -> - let annot = Type.annotation env in - Group_typecast Expression.TypeCast.{ expression; annot; comments = None } - | T_COMMA -> Group_expr (sequence env ~start_loc:expr_start_loc [expression]) - | _ -> Group_expr expression - in - Expect.token env T_RPAREN; - ret) - env - in - let trailing = Eat.trailing_comments env in - let ret = - match cover with - | Group_expr expr -> expr - | Group_typecast cast -> (loc, Expression.TypeCast cast) - in - add_comments ret ~leading ~trailing - - and add_comments ?(leading = []) ?(trailing = []) (loc, expression) = - let merge_comments inner = - Flow_ast_utils.merge_comments - ~inner - ~outer:(Flow_ast_utils.mk_comments_opt ~leading ~trailing ()) - in - let merge_comments_with_internal inner = - Flow_ast_utils.merge_comments_with_internal - ~inner - ~outer:(Flow_ast_utils.mk_comments_opt ~leading ~trailing ()) - in - let open Expression in - ( loc, - match expression with - | Array ({ Array.comments; _ } as e) -> - Array { e with Array.comments = merge_comments_with_internal comments } - | ArrowFunction ({ Function.comments; _ } as e) -> - ArrowFunction { e with Function.comments = merge_comments comments } - | Assignment ({ Assignment.comments; _ } as e) -> - Assignment { e with Assignment.comments = merge_comments comments } - | Binary ({ Binary.comments; _ } as e) -> - Binary { e with Binary.comments = merge_comments comments } - | Call ({ Call.comments; _ } as e) -> Call { e with Call.comments = merge_comments comments } - | Class ({ Class.comments; _ } as e) -> - Class { e with Class.comments = merge_comments comments } - | Conditional ({ Conditional.comments; _ } as e) -> - Conditional { e with Conditional.comments = merge_comments comments } - | Function ({ Function.comments; _ } as e) -> - Function { e with Function.comments = merge_comments comments } - | Identifier (loc, ({ Identifier.comments; _ } as e)) -> - Identifier (loc, { e with Identifier.comments = merge_comments comments }) - | Import ({ Import.comments; _ } as e) -> - Import { e with Import.comments = merge_comments comments } - | JSXElement ({ JSX.comments; _ } as e) -> - JSXElement { e with JSX.comments = merge_comments comments } - | JSXFragment ({ JSX.frag_comments; _ } as e) -> - JSXFragment { e with JSX.frag_comments = merge_comments frag_comments } - | Literal ({ Literal.comments; _ } as e) -> - Literal { e with Literal.comments = merge_comments comments } - | Logical ({ Logical.comments; _ } as e) -> - Logical { e with Logical.comments = merge_comments comments } - | Member ({ Member.comments; _ } as e) -> - Member { e with Member.comments = merge_comments comments } - | MetaProperty ({ MetaProperty.comments; _ } as e) -> - MetaProperty { e with MetaProperty.comments = merge_comments comments } - | New ({ New.comments; _ } as e) -> New { e with New.comments = merge_comments comments } - | Object ({ Object.comments; _ } as e) -> - Object { e with Object.comments = merge_comments_with_internal comments } - | OptionalCall ({ OptionalCall.call = { Call.comments; _ } as call; _ } as optional_call) -> - OptionalCall - { - optional_call with - OptionalCall.call = { call with Call.comments = merge_comments comments }; - } - | OptionalMember - ({ OptionalMember.member = { Member.comments; _ } as member; _ } as optional_member) -> - OptionalMember - { - optional_member with - OptionalMember.member = { member with Member.comments = merge_comments comments }; - } - | Sequence ({ Sequence.comments; _ } as e) -> - Sequence { e with Sequence.comments = merge_comments comments } - | Super { Super.comments; _ } -> Super { Super.comments = merge_comments comments } - | TaggedTemplate ({ TaggedTemplate.comments; _ } as e) -> - TaggedTemplate { e with TaggedTemplate.comments = merge_comments comments } - | TemplateLiteral ({ TemplateLiteral.comments; _ } as e) -> - TemplateLiteral { e with TemplateLiteral.comments = merge_comments comments } - | This { This.comments; _ } -> This { This.comments = merge_comments comments } - | TypeCast ({ TypeCast.comments; _ } as e) -> - TypeCast { e with TypeCast.comments = merge_comments comments } - | Unary ({ Unary.comments; _ } as e) -> - Unary { e with Unary.comments = merge_comments comments } - | Update ({ Update.comments; _ } as e) -> - Update { e with Update.comments = merge_comments comments } - | Yield ({ Yield.comments; _ } as e) -> - Yield { e with Yield.comments = merge_comments comments } - (* TODO: Delete once all expressions support comment attachment *) - | _ -> expression - ) - - and array_initializer = - let rec elements env (acc, errs) = - match Peek.token env with - | T_EOF - | T_RBRACKET -> - (List.rev acc, Pattern_cover.rev_errors errs) - | T_COMMA -> - let loc = Peek.loc env in - Eat.token env; - elements env (Expression.Array.Hole loc :: acc, errs) - | T_ELLIPSIS -> - let leading = Peek.comments env in - let (loc, (argument, new_errs)) = - with_loc - (fun env -> - Eat.token env; - match assignment_cover env with - | Cover_expr argument -> (argument, Pattern_cover.empty_errors) - | Cover_patt (argument, new_errs) -> (argument, new_errs)) - env - in - let elem = - Expression.( - Array.Spread - ( loc, - SpreadElement.{ argument; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - ) - in - let is_last = Peek.token env = T_RBRACKET in - (* if this array is interpreted as a pattern, the spread becomes an AssignmentRestElement - which must be the last element. We can easily error about additional elements since - they will be in the element list, but a trailing elision, like `[...x,]`, is not part - of the AST. so, keep track of the error so we can raise it if this is a pattern. *) - let new_errs = - if (not is_last) && Peek.ith_token ~i:1 env = T_RBRACKET then - let if_patt = (loc, Parse_error.ElementAfterRestElement) :: new_errs.if_patt in - { new_errs with if_patt } - else - new_errs - in - if not is_last then Expect.token env T_COMMA; - let acc = elem :: acc in - let errs = Pattern_cover.rev_append_errors new_errs errs in - elements env (acc, errs) - | _ -> - let (elem, new_errs) = - match assignment_cover env with - | Cover_expr elem -> (elem, Pattern_cover.empty_errors) - | Cover_patt (elem, new_errs) -> (elem, new_errs) - in - if Peek.token env <> T_RBRACKET then Expect.token env T_COMMA; - let acc = Expression.Array.Expression elem :: acc in - let errs = Pattern_cover.rev_append_errors new_errs errs in - elements env (acc, errs) - in - fun env -> - let leading = Peek.comments env in - Expect.token env T_LBRACKET; - let (elems, errs) = elements env ([], Pattern_cover.empty_errors) in - let internal = Peek.comments env in - Expect.token env T_RBRACKET; - let trailing = Eat.trailing_comments env in - ( { - Ast.Expression.Array.elements = elems; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - }, - errs - ) - - and regexp env = - Eat.push_lex_mode env Lex_mode.REGEXP; - let loc = Peek.loc env in - let leading = Peek.comments env in - let tkn = Peek.token env in - let (raw, pattern, raw_flags, trailing) = - match tkn with - | T_REGEXP (_, pattern, flags) -> - Eat.token env; - let trailing = Eat.trailing_comments env in - let raw = "/" ^ pattern ^ "/" ^ flags in - (raw, pattern, flags, trailing) - | _ -> - error_unexpected ~expected:"a regular expression" env; - ("", "", "", []) - in - Eat.pop_lex_mode env; - let filtered_flags = Buffer.create (String.length raw_flags) in - String.iter - (function - | ('d' | 'g' | 'i' | 'm' | 's' | 'u' | 'y') as c -> Buffer.add_char filtered_flags c - | _ -> ()) - raw_flags; - let flags = Buffer.contents filtered_flags in - if flags <> raw_flags then error env (Parse_error.InvalidRegExpFlags raw_flags); - let value = Literal.(RegExp { RegExp.pattern; flags }) in - ( loc, - let open Expression in - Literal - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - - and try_arrow_function = - (* Certain errors (almost all errors) cause a rollback *) - let error_callback _ = - Parse_error.( - function - (* Don't rollback on these errors. *) - | StrictParamName - | StrictReservedWord - | ParameterAfterRestParameter - | NewlineBeforeArrow - | YieldInFormalParameters - | ThisParamBannedInArrowFunctions -> - () - (* Everything else causes a rollback *) - | _ -> raise Try.Rollback - ) - in - let concise_function_body env = - match Peek.token env with - | T_LCURLY -> - let (body_block, contains_use_strict) = Parse.function_block_body env ~expression:true in - (Function.BodyBlock body_block, contains_use_strict) - | _ -> - let expr = Parse.assignment env in - (Function.BodyExpression expr, false) - in - fun env -> - let env = env |> with_error_callback error_callback in - let start_loc = Peek.loc env in - (* a T_ASYNC could either be a parameter name or it could be indicating - * that it's an async function *) - let (async, leading) = - if Peek.ith_token ~i:1 env <> T_ARROW then - Declaration.async env - else - (false, []) - in - let (sig_loc, (tparams, params, return, predicate)) = - with_loc - (fun env -> - let tparams = type_params_remove_trailing env (Type.type_params env) in - (* Disallow all fancy features for identifier => body *) - if Peek.is_identifier env && tparams = None then - let ((loc, _) as name) = - Parse.identifier ~restricted_error:Parse_error.StrictParamName env - in - let param = - ( loc, - { - Ast.Function.Param.argument = - ( loc, - Pattern.Identifier - { - Pattern.Identifier.name; - annot = Ast.Type.Missing (Peek.loc_skip_lookahead env); - optional = false; - } - ); - default = None; - } - ) - in - ( tparams, - ( loc, - { - Ast.Function.Params.params = [param]; - rest = None; - comments = None; - this_ = None; - } - ), - Ast.Type.Missing Loc.{ loc with start = loc._end }, - None - ) - else - let params = - let yield = allow_yield env in - let await = allow_await env in - Declaration.function_params ~await ~yield env - in - (* There's an ambiguity if you use a function type as the return - * type for an arrow function. So we disallow anonymous function - * types in arrow function return types unless the function type is - * enclosed in parens *) - let (return, predicate) = - env |> with_no_anon_function_type true |> Type.annotation_and_predicate_opt - in - (tparams, params, return, predicate)) - env - in - (* It's hard to tell if an invalid expression was intended to be an - * arrow function before we see the =>. If there are no params, that - * implies "()" which is only ever found in arrow params. Similarly, - * rest params indicate arrow functions. Therefore, if we see a rest - * param or an empty param list then we can disable the rollback and - * instead generate errors as if we were parsing an arrow function *) - let env = - match params with - | (_, { Ast.Function.Params.params = _; rest = Some _; this_ = None; comments = _ }) - | (_, { Ast.Function.Params.params = []; rest = _; this_ = None; comments = _ }) -> - without_error_callback env - | _ -> env - in - - (* Disallow this param annotations in arrow functions *) - let params = - match params with - | (loc, ({ Ast.Function.Params.this_ = Some (this_loc, _); _ } as params)) -> - error_at env (this_loc, Parse_error.ThisParamBannedInArrowFunctions); - (loc, { params with Ast.Function.Params.this_ = None }) - | _ -> params - in - let simple_params = is_simple_parameter_list params in - - if Peek.is_line_terminator env && Peek.token env = T_ARROW then - error env Parse_error.NewlineBeforeArrow; - Expect.token env T_ARROW; - - (* Now we know for sure this is an arrow function *) - let env = without_error_callback env in - (* arrow functions can't be generators *) - let env = enter_function env ~async ~generator:false ~simple_params in - let (end_loc, (body, contains_use_strict)) = with_loc concise_function_body env in - Declaration.strict_post_check env ~contains_use_strict None params; - let loc = Loc.btwn start_loc end_loc in - Cover_expr - ( loc, - let open Expression in - ArrowFunction - { - Function.id = None; - params; - body; - async; - generator = false; - (* arrow functions cannot be generators *) - predicate; - return; - tparams; - sig_loc; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - - and sequence = - let rec helper acc env = - match Peek.token env with - | T_COMMA -> - Eat.token env; - let expr = assignment env in - helper (expr :: acc) env - | _ -> - let expressions = List.rev acc in - Expression.(Sequence Sequence.{ expressions; comments = None }) - in - (fun env ~start_loc acc -> with_loc ~start_loc (helper acc) env) -end diff --git a/jscomp/js_parser/file_key.ml b/jscomp/js_parser/file_key.ml deleted file mode 100644 index 2ee9176..0000000 --- a/jscomp/js_parser/file_key.ml +++ /dev/null @@ -1,100 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) -open Primitive_deriving - -type t = - | LibFile of string - | SourceFile of string - | JsonFile of string - (* A resource that might get required, like .css, .jpg, etc. We don't parse - these, just check that they exist *) - | ResourceFile of string -[@@deriving_inline equal] -let _ = fun (_ : t) -> () -let equal = - (fun a__001_ -> - fun b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ - then true - else - (match (a__001_, b__002_) with - | (LibFile _a__003_, LibFile _b__004_) -> - equal_string _a__003_ _b__004_ - | (LibFile _, _) -> false - | (_, LibFile _) -> false - | (SourceFile _a__005_, SourceFile _b__006_) -> - equal_string _a__005_ _b__006_ - | (SourceFile _, _) -> false - | (_, SourceFile _) -> false - | (JsonFile _a__007_, JsonFile _b__008_) -> - equal_string _a__007_ _b__008_ - | (JsonFile _, _) -> false - | (_, JsonFile _) -> false - | (ResourceFile _a__009_, ResourceFile _b__010_) -> - equal_string _a__009_ _b__010_) : t -> t -> bool) -let _ = equal -[@@@end] -let to_string = function - | LibFile x - | SourceFile x - | JsonFile x - | ResourceFile x -> - x - -let to_path = function - | LibFile x - | SourceFile x - | JsonFile x - | ResourceFile x -> - Ok x - -let compare = - (* libs, then source and json files at the same priority since JSON files are - * basically source files. We don't actually read resource files so they come - * last *) - let order_of_filename = function - | LibFile _ -> 1 - | SourceFile _ -> 2 - | JsonFile _ -> 2 - | ResourceFile _ -> 3 - in - fun a b -> - let k = order_of_filename a - order_of_filename b in - if k <> 0 then - k - else - String.compare (to_string a) (to_string b) - -let compare_opt a b = - match (a, b) with - | (Some _, None) -> -1 - | (None, Some _) -> 1 - | (None, None) -> 0 - | (Some a, Some b) -> compare a b - -let is_lib_file = function - | LibFile _ -> true - | SourceFile _ -> false - | JsonFile _ -> false - | ResourceFile _ -> false - -let map f = function - | LibFile filename -> LibFile (f filename) - | SourceFile filename -> SourceFile (f filename) - | JsonFile filename -> JsonFile (f filename) - | ResourceFile filename -> ResourceFile (f filename) - -let exists f = function - | LibFile filename - | SourceFile filename - | JsonFile filename - | ResourceFile filename -> - f filename - -let check_suffix filename suffix = exists (fun fn -> Filename.check_suffix fn suffix) filename -let chop_suffix filename suffix = map (fun fn -> Filename.chop_suffix fn suffix) filename -let with_suffix filename suffix = map (fun fn -> fn ^ suffix) filename diff --git a/jscomp/js_parser/flow_LICENSE b/jscomp/js_parser/flow_LICENSE deleted file mode 100644 index 188fb2b..0000000 --- a/jscomp/js_parser/flow_LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -MIT License - -Copyright (c) 2013-present, Facebook, Inc. - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in all -copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -SOFTWARE. diff --git a/jscomp/js_parser/flow_ast.ml b/jscomp/js_parser/flow_ast.ml deleted file mode 100644 index 628b21c..0000000 --- a/jscomp/js_parser/flow_ast.ml +++ /dev/null @@ -1,1754 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module rec Syntax : sig - type ('M, 'internal) t = { - leading: 'M Comment.t list; - trailing: 'M Comment.t list; - internal: 'internal; - } -end = - Syntax - -and Identifier : sig - type ('M, 'T) t = 'T * 'M t' - - and 'M t' = { - name: string; - comments: ('M, unit) Syntax.t option; - } -end = - Identifier - -and PrivateName : sig - type 'M t = 'M * 'M t' - - and 'M t' = { - name: string; - comments: ('M, unit) Syntax.t option; - } -end = - PrivateName - -and Literal : sig - module RegExp : sig - type t = { - pattern: string; - flags: string; - } - end - - (* Literals also carry along their raw value *) - type 'M t = { - value: value; - raw: string; - comments: ('M, unit) Syntax.t option; - } - - and value = - | String of string - | Boolean of bool - | Null - | Number of float - | BigInt of int64 option - | RegExp of RegExp.t -end = - Literal - -and StringLiteral : sig - type 'M t = { - value: string; - raw: string; - comments: ('M, unit) Syntax.t option; - } -end = - StringLiteral - -and NumberLiteral : sig - type 'M t = { - value: float; - raw: string; - comments: ('M, unit) Syntax.t option; - } -end = - NumberLiteral - -and BigIntLiteral : sig - type 'M t = { - (* This will be None if we couldn't parse `raw`. That could be if the number is out of range or invalid (like a float) *) - value: int64 option; - raw: string; - comments: ('M, unit) Syntax.t option; - } -end = - BigIntLiteral - -and BooleanLiteral : sig - type 'M t = { - value: bool; - comments: ('M, unit) Syntax.t option; - } -end = - BooleanLiteral - -and Variance : sig - type 'M t = 'M * 'M t' - - and kind = - | Plus - | Minus - - and 'M t' = { - kind: kind; - comments: ('M, unit) Syntax.t option; - } -end = - Variance - -and ComputedKey : sig - type ('M, 'T) t = 'M * ('M, 'T) ComputedKey.t' - - and ('M, 'T) t' = { - expression: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } -end = - ComputedKey - -and Type : sig - module Function : sig - module Param : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - name: ('M, 'T) Identifier.t option; - annot: ('M, 'T) Type.t; - optional: bool; - } - end - - module RestParam : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Param.t; - comments: ('M, unit) Syntax.t option; - } - end - - module ThisParam : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - annot: ('M, 'T) Type.annotation; - comments: ('M, unit) Syntax.t option; - } - end - - module Params : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - this_: ('M, 'T) ThisParam.t option; - params: ('M, 'T) Param.t list; - rest: ('M, 'T) RestParam.t option; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - type ('M, 'T) t = { - tparams: ('M, 'T) Type.TypeParams.t option; - params: ('M, 'T) Params.t; - return: ('M, 'T) Type.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Generic : sig - module Identifier : sig - type ('M, 'T) t = - | Unqualified of ('M, 'T) Identifier.t - | Qualified of ('M, 'T) qualified - - and ('M, 'T) qualified = 'M * ('M, 'T) qualified' - - and ('M, 'T) qualified' = { - qualification: ('M, 'T) t; - id: ('M, 'T) Identifier.t; - } - end - - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - targs: ('M, 'T) Type.TypeArgs.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module IndexedAccess : sig - type ('M, 'T) t = { - _object: ('M, 'T) Type.t; - index: ('M, 'T) Type.t; - comments: ('M, unit) Syntax.t option; - } - end - - module OptionalIndexedAccess : sig - type ('M, 'T) t = { - indexed_access: ('M, 'T) IndexedAccess.t; - optional: bool; - } - end - - module Object : sig - module Property : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - key: ('M, 'T) Expression.Object.Property.key; - value: ('M, 'T) value; - optional: bool; - static: bool; - proto: bool; - _method: bool; - variance: 'M Variance.t option; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) value = - | Init of ('M, 'T) Type.t - | Get of ('M * ('M, 'T) Function.t) - | Set of ('M * ('M, 'T) Function.t) - end - - module SpreadProperty : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Type.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Indexer : sig - type ('M, 'T) t' = { - id: ('M, 'M) Identifier.t option; - key: ('M, 'T) Type.t; - value: ('M, 'T) Type.t; - static: bool; - variance: 'M Variance.t option; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) t = 'M * ('M, 'T) t' - end - - module CallProperty : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - value: 'M * ('M, 'T) Function.t; - static: bool; - comments: ('M, unit) Syntax.t option; - } - end - - module InternalSlot : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - id: ('M, 'M) Identifier.t; - value: ('M, 'T) Type.t; - optional: bool; - static: bool; - _method: bool; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) t = { - exact: bool; - (* Inexact indicates the presence of ... in the object. It is more - * easily understood if exact is read as "explicitly exact" and "inexact" - * is read as "explicitly inexact". - * - * This confusion will go away when we get rid of the exact flag in favor - * of inexact as part of the work to make object types exact by default. - * *) - inexact: bool; - properties: ('M, 'T) property list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - - and ('M, 'T) property = - | Property of ('M, 'T) Property.t - | SpreadProperty of ('M, 'T) SpreadProperty.t - | Indexer of ('M, 'T) Indexer.t - | CallProperty of ('M, 'T) CallProperty.t - | InternalSlot of ('M, 'T) InternalSlot.t - end - - module Interface : sig - type ('M, 'T) t = { - body: 'M * ('M, 'T) Object.t; - extends: ('M * ('M, 'T) Generic.t) list; - comments: ('M, unit) Syntax.t option; - } - end - - module Nullable : sig - type ('M, 'T) t = { - argument: ('M, 'T) Type.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Typeof : sig - module Target : sig - type ('M, 'T) t = - | Unqualified of ('M, 'T) Identifier.t - | Qualified of ('M, 'T) qualified - - and ('M, 'T) qualified' = { - qualification: ('M, 'T) t; - id: ('M, 'T) Identifier.t; - } - - and ('M, 'T) qualified = 'T * ('M, 'T) qualified' - end - - type ('M, 'T) t = { - argument: ('M, 'T) Target.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Tuple : sig - type ('M, 'T) t = { - types: ('M, 'T) Type.t list; - comments: ('M, unit) Syntax.t option; - } - end - - module Array : sig - type ('M, 'T) t = { - argument: ('M, 'T) Type.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Union : sig - type ('M, 'T) t = { - types: ('M, 'T) Type.t * ('M, 'T) Type.t * ('M, 'T) Type.t list; - comments: ('M, unit) Syntax.t option; - } - end - - module Intersection : sig - type ('M, 'T) t = { - types: ('M, 'T) Type.t * ('M, 'T) Type.t * ('M, 'T) Type.t list; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) t = 'T * ('M, 'T) t' - - (* Yes, we could add a little complexity here to show that Any and Void - * should never be declared nullable, but that check can happen later *) - and ('M, 'T) t' = - | Any of ('M, unit) Syntax.t option - | Mixed of ('M, unit) Syntax.t option - | Empty of ('M, unit) Syntax.t option - | Void of ('M, unit) Syntax.t option - | Null of ('M, unit) Syntax.t option - | Number of ('M, unit) Syntax.t option - | BigInt of ('M, unit) Syntax.t option - | String of ('M, unit) Syntax.t option - | Boolean of ('M, unit) Syntax.t option - | Symbol of ('M, unit) Syntax.t option - | Exists of ('M, unit) Syntax.t option - | Nullable of ('M, 'T) Nullable.t - | Function of ('M, 'T) Function.t - | Object of ('M, 'T) Object.t - | Interface of ('M, 'T) Interface.t - | Array of ('M, 'T) Array.t - | Generic of ('M, 'T) Generic.t - | IndexedAccess of ('M, 'T) IndexedAccess.t - | OptionalIndexedAccess of ('M, 'T) OptionalIndexedAccess.t - | Union of ('M, 'T) Union.t - | Intersection of ('M, 'T) Intersection.t - | Typeof of ('M, 'T) Typeof.t - | Tuple of ('M, 'T) Tuple.t - | StringLiteral of 'M StringLiteral.t - | NumberLiteral of 'M NumberLiteral.t - | BigIntLiteral of 'M BigIntLiteral.t - | BooleanLiteral of 'M BooleanLiteral.t - - (* Type.annotation is a concrete syntax node with a location that starts at - * the colon and ends after the type. For example, "var a: number", the - * identifier a would have a property annot which contains a - * Type.annotation with a location from column 6-14 *) - and ('M, 'T) annotation = 'M * ('M, 'T) t - - and ('M, 'T) annotation_or_hint = - | Missing of 'T - | Available of ('M, 'T) Type.annotation - - module TypeParam : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - name: ('M, 'M) Identifier.t; - bound: ('M, 'T) Type.annotation_or_hint; - variance: 'M Variance.t option; - default: ('M, 'T) Type.t option; - } - end - - module TypeParams : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - params: ('M, 'T) TypeParam.t list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module TypeArgs : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - arguments: ('M, 'T) Type.t list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module Predicate : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - kind: ('M, 'T) kind; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) kind = - | Declared of ('M, 'T) Expression.t - | Inferred - end -end = - Type - -and Statement : sig - module Block : sig - type ('M, 'T) t = { - body: ('M, 'T) Statement.t list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module If : sig - module Alternate : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - body: ('M, 'T) Statement.t; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) t = { - test: ('M, 'T) Expression.t; - consequent: ('M, 'T) Statement.t; - alternate: ('M, 'T) Alternate.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module Labeled : sig - type ('M, 'T) t = { - label: ('M, 'M) Identifier.t; - body: ('M, 'T) Statement.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Break : sig - type 'M t = { - label: ('M, 'M) Identifier.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module Continue : sig - type 'M t = { - label: ('M, 'M) Identifier.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module Debugger : sig - type 'M t = { comments: ('M, unit) Syntax.t option } - end - - module With : sig - type ('M, 'T) t = { - _object: ('M, 'T) Expression.t; - body: ('M, 'T) Statement.t; - comments: ('M, unit) Syntax.t option; - } - end - - module TypeAlias : sig - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - tparams: ('M, 'T) Type.TypeParams.t option; - right: ('M, 'T) Type.t; - comments: ('M, unit) Syntax.t option; - } - end - - module OpaqueType : sig - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - tparams: ('M, 'T) Type.TypeParams.t option; - impltype: ('M, 'T) Type.t option; - supertype: ('M, 'T) Type.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module Switch : sig - module Case : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - test: ('M, 'T) Expression.t option; - consequent: ('M, 'T) Statement.t list; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) t = { - discriminant: ('M, 'T) Expression.t; - cases: ('M, 'T) Case.t list; - comments: ('M, unit) Syntax.t option; - exhaustive_out: 'T; - } - end - - module Return : sig - type ('M, 'T) t = { - argument: ('M, 'T) Expression.t option; - comments: ('M, unit) Syntax.t option; - return_out: 'T; - } - end - - module Throw : sig - type ('M, 'T) t = { - argument: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Try : sig - module CatchClause : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - param: ('M, 'T) Pattern.t option; - body: 'M * ('M, 'T) Block.t; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) t = { - block: 'M * ('M, 'T) Block.t; - handler: ('M, 'T) CatchClause.t option; - finalizer: ('M * ('M, 'T) Block.t) option; - comments: ('M, unit) Syntax.t option; - } - end - - module VariableDeclaration : sig - module Declarator : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - id: ('M, 'T) Pattern.t; - init: ('M, 'T) Expression.t option; - } - end - - type ('M, 'T) t = { - declarations: ('M, 'T) Declarator.t list; - kind: kind; - comments: ('M, unit) Syntax.t option; - } - - and kind = - | Var - | Let - | Const - end - - module While : sig - type ('M, 'T) t = { - test: ('M, 'T) Expression.t; - body: ('M, 'T) Statement.t; - comments: ('M, unit) Syntax.t option; - } - end - - module DoWhile : sig - type ('M, 'T) t = { - body: ('M, 'T) Statement.t; - test: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module For : sig - type ('M, 'T) t = { - init: ('M, 'T) init option; - test: ('M, 'T) Expression.t option; - update: ('M, 'T) Expression.t option; - body: ('M, 'T) Statement.t; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) init = - | InitDeclaration of ('M * ('M, 'T) VariableDeclaration.t) - | InitExpression of ('M, 'T) Expression.t - end - - module ForIn : sig - type ('M, 'T) t = { - left: ('M, 'T) left; - right: ('M, 'T) Expression.t; - body: ('M, 'T) Statement.t; - each: bool; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) left = - | LeftDeclaration of ('M * ('M, 'T) VariableDeclaration.t) - | LeftPattern of ('M, 'T) Pattern.t - end - - module ForOf : sig - type ('M, 'T) t = { - left: ('M, 'T) left; - right: ('M, 'T) Expression.t; - body: ('M, 'T) Statement.t; - await: bool; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) left = - | LeftDeclaration of ('M * ('M, 'T) VariableDeclaration.t) - | LeftPattern of ('M, 'T) Pattern.t - end - - module EnumDeclaration : sig - module DefaultedMember : sig - type 'M t = 'M * 'M t' - and 'M t' = { id: ('M, 'M) Identifier.t } - end - - module InitializedMember : sig - type ('I, 'M) t = 'M * ('I, 'M) t' - - and ('I, 'M) t' = { - id: ('M, 'M) Identifier.t; - init: 'M * 'I; - } - end - - module BooleanBody : sig - type 'M t = { - members: ('M BooleanLiteral.t, 'M) InitializedMember.t list; - explicit_type: bool; - has_unknown_members: bool; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module NumberBody : sig - type 'M t = { - members: ('M NumberLiteral.t, 'M) InitializedMember.t list; - explicit_type: bool; - has_unknown_members: bool; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module StringBody : sig - type 'M t = { - members: ('M StringLiteral.t, 'M) members; - explicit_type: bool; - has_unknown_members: bool; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - - and ('I, 'M) members = - | Defaulted of 'M DefaultedMember.t list - | Initialized of ('I, 'M) InitializedMember.t list - end - - module SymbolBody : sig - type 'M t = { - members: 'M DefaultedMember.t list; - has_unknown_members: bool; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - body: 'M body; - comments: ('M, unit) Syntax.t option; - } - - and 'M body = 'M * 'M body' - - and 'M body' = - | BooleanBody of 'M BooleanBody.t - | NumberBody of 'M NumberBody.t - | StringBody of 'M StringBody.t - | SymbolBody of 'M SymbolBody.t - end - - module Interface : sig - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - tparams: ('M, 'T) Type.TypeParams.t option; - extends: ('M * ('M, 'T) Type.Generic.t) list; - body: 'M * ('M, 'T) Type.Object.t; - comments: ('M, unit) Syntax.t option; - } - end - - module DeclareClass : sig - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - tparams: ('M, 'T) Type.TypeParams.t option; - body: 'M * ('M, 'T) Type.Object.t; - extends: ('M * ('M, 'T) Type.Generic.t) option; - mixins: ('M * ('M, 'T) Type.Generic.t) list; - implements: ('M, 'T) Class.Implements.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module DeclareVariable : sig - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - annot: ('M, 'T) Type.annotation; - comments: ('M, unit) Syntax.t option; - } - end - - module DeclareFunction : sig - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t; - annot: ('M, 'T) Type.annotation; - predicate: ('M, 'T) Type.Predicate.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module DeclareModule : sig - type ('M, 'T) id = - | Identifier of ('M, 'T) Identifier.t - | Literal of ('T * 'M StringLiteral.t) - - and module_kind = - | CommonJS - | ES - - and ('M, 'T) t = { - id: ('M, 'T) id; - body: 'M * ('M, 'T) Block.t; - kind: module_kind; - comments: ('M, unit) Syntax.t option; - } - end - - module DeclareModuleExports : sig - type ('M, 'T) t = { - annot: ('M, 'T) Type.annotation; - comments: ('M, unit) Syntax.t option; - } - end - - module ExportNamedDeclaration : sig - module ExportSpecifier : sig - type 'M t = 'M * 'M t' - - and 'M t' = { - local: ('M, 'M) Identifier.t; - exported: ('M, 'M) Identifier.t option; - } - end - - module ExportBatchSpecifier : sig - type 'M t = 'M * ('M, 'M) Identifier.t option - end - - type ('M, 'T) t = { - declaration: ('M, 'T) Statement.t option; - specifiers: 'M specifier option; - source: ('M * 'M StringLiteral.t) option; - export_kind: Statement.export_kind; - comments: ('M, unit) Syntax.t option; - } - - and 'M specifier = - | ExportSpecifiers of 'M ExportSpecifier.t list - | ExportBatchSpecifier of 'M ExportBatchSpecifier.t - end - - module ExportDefaultDeclaration : sig - type ('M, 'T) t = { - default: 'M; - declaration: ('M, 'T) declaration; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) declaration = - | Declaration of ('M, 'T) Statement.t - | Expression of ('M, 'T) Expression.t - end - - module DeclareExportDeclaration : sig - type ('M, 'T) declaration = - (* declare export var *) - | Variable of ('M * ('M, 'T) DeclareVariable.t) - (* declare export function *) - | Function of ('M * ('M, 'T) DeclareFunction.t) - (* declare export class *) - | Class of ('M * ('M, 'T) DeclareClass.t) - (* declare export default [type] - * this corresponds to things like - * export default 1+1; *) - | DefaultType of ('M, 'T) Type.t - (* declare export type *) - | NamedType of ('M * ('M, 'T) TypeAlias.t) - (* declare export opaque type *) - | NamedOpaqueType of ('M * ('M, 'T) OpaqueType.t) - (* declare export interface *) - | Interface of ('M * ('M, 'T) Interface.t) - - and ('M, 'T) t = { - default: 'M option; - declaration: ('M, 'T) declaration option; - specifiers: 'M ExportNamedDeclaration.specifier option; - source: ('M * 'M StringLiteral.t) option; - comments: ('M, unit) Syntax.t option; - } - end - - module ImportDeclaration : sig - type import_kind = - | ImportType - | ImportTypeof - | ImportValue - - and ('M, 'T) specifier = - | ImportNamedSpecifiers of ('M, 'T) named_specifier list - | ImportNamespaceSpecifier of ('M * ('M, 'T) Identifier.t) - - and ('M, 'T) named_specifier = { - kind: import_kind option; - local: ('M, 'T) Identifier.t option; - remote: ('M, 'T) Identifier.t; - } - - and ('M, 'T) t = { - import_kind: import_kind; - source: 'T * 'M StringLiteral.t; - default: ('M, 'T) Identifier.t option; - specifiers: ('M, 'T) specifier option; - comments: ('M, unit) Syntax.t option; - } - end - - module Expression : sig - type ('M, 'T) t = { - expression: ('M, 'T) Expression.t; - directive: string option; - comments: ('M, unit) Syntax.t option; - } - end - - module Empty : sig - type 'M t = { comments: ('M, unit) Syntax.t option } - end - - type export_kind = - | ExportType - | ExportValue - - and ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = - | Block of ('M, 'T) Block.t - | Break of 'M Break.t - | ClassDeclaration of ('M, 'T) Class.t - | Continue of 'M Continue.t - | Debugger of 'M Debugger.t - | DeclareClass of ('M, 'T) DeclareClass.t - | DeclareExportDeclaration of ('M, 'T) DeclareExportDeclaration.t - | DeclareFunction of ('M, 'T) DeclareFunction.t - | DeclareInterface of ('M, 'T) Interface.t - | DeclareModule of ('M, 'T) DeclareModule.t - | DeclareModuleExports of ('M, 'T) DeclareModuleExports.t - | DeclareTypeAlias of ('M, 'T) TypeAlias.t - | DeclareOpaqueType of ('M, 'T) OpaqueType.t - | DeclareVariable of ('M, 'T) DeclareVariable.t - | DoWhile of ('M, 'T) DoWhile.t - | Empty of 'M Empty.t - | EnumDeclaration of ('M, 'T) EnumDeclaration.t - | ExportDefaultDeclaration of ('M, 'T) ExportDefaultDeclaration.t - | ExportNamedDeclaration of ('M, 'T) ExportNamedDeclaration.t - | Expression of ('M, 'T) Expression.t - | For of ('M, 'T) For.t - | ForIn of ('M, 'T) ForIn.t - | ForOf of ('M, 'T) ForOf.t - | FunctionDeclaration of ('M, 'T) Function.t - | If of ('M, 'T) If.t - | ImportDeclaration of ('M, 'T) ImportDeclaration.t - | InterfaceDeclaration of ('M, 'T) Interface.t - | Labeled of ('M, 'T) Labeled.t - | Return of ('M, 'T) Return.t - | Switch of ('M, 'T) Switch.t - | Throw of ('M, 'T) Throw.t - | Try of ('M, 'T) Try.t - | TypeAlias of ('M, 'T) TypeAlias.t - | OpaqueType of ('M, 'T) OpaqueType.t - | VariableDeclaration of ('M, 'T) VariableDeclaration.t - | While of ('M, 'T) While.t - | With of ('M, 'T) With.t -end = - Statement - -and Expression : sig - module CallTypeArg : sig - module Implicit : sig - type ('M, 'T) t = 'T * 'M t' - and 'M t' = { comments: ('M, unit) Syntax.t option } - end - - type ('M, 'T) t = - | Explicit of ('M, 'T) Type.t - | Implicit of ('M, 'T) Implicit.t - end - - module CallTypeArgs : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - arguments: ('M, 'T) CallTypeArg.t list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module SpreadElement : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Array : sig - type ('M, 'T) element = - | Expression of ('M, 'T) Expression.t - | Spread of ('M, 'T) SpreadElement.t - | Hole of 'M - - type ('M, 'T) t = { - elements: ('M, 'T) element list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module TemplateLiteral : sig - module Element : sig - type value = { - raw: string; - cooked: string; - } - - and 'M t = 'M * t' - - and t' = { - value: value; - tail: bool; - } - end - - type ('M, 'T) t = { - quasis: 'M Element.t list; - expressions: ('M, 'T) Expression.t list; - comments: ('M, unit) Syntax.t option; - } - end - - module TaggedTemplate : sig - type ('M, 'T) t = { - tag: ('M, 'T) Expression.t; - quasi: 'M * ('M, 'T) TemplateLiteral.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Object : sig - module Property : sig - type ('M, 'T) key = - | Literal of ('T * 'M Literal.t) - | Identifier of ('M, 'T) Identifier.t - | PrivateName of 'M PrivateName.t - | Computed of ('M, 'T) ComputedKey.t - - and ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = - | Init of { - key: ('M, 'T) key; - value: ('M, 'T) Expression.t; - shorthand: bool; - } - | Method of { - key: ('M, 'T) key; - value: 'M * ('M, 'T) Function.t; - } - | Get of { - key: ('M, 'T) key; - value: 'M * ('M, 'T) Function.t; - comments: ('M, unit) Syntax.t option; - } - | Set of { - key: ('M, 'T) key; - value: 'M * ('M, 'T) Function.t; - comments: ('M, unit) Syntax.t option; - } - end - - module SpreadProperty : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) property = - | Property of ('M, 'T) Property.t - | SpreadProperty of ('M, 'T) SpreadProperty.t - - and ('M, 'T) t = { - properties: ('M, 'T) property list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module Sequence : sig - type ('M, 'T) t = { - expressions: ('M, 'T) Expression.t list; - comments: ('M, unit) Syntax.t option; - } - end - - module Unary : sig - type operator = - | Minus - | Plus - | Not - | BitNot - | Typeof - | Void - | Delete - | Await - - and ('M, 'T) t = { - operator: operator; - argument: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Binary : sig - type operator = - | Equal - | NotEqual - | StrictEqual - | StrictNotEqual - | LessThan - | LessThanEqual - | GreaterThan - | GreaterThanEqual - | LShift - | RShift - | RShift3 - | Plus - | Minus - | Mult - | Exp - | Div - | Mod - | BitOr - | Xor - | BitAnd - | In - | Instanceof - - and ('M, 'T) t = { - operator: operator; - left: ('M, 'T) Expression.t; - right: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Assignment : sig - type operator = - | PlusAssign - | MinusAssign - | MultAssign - | ExpAssign - | DivAssign - | ModAssign - | LShiftAssign - | RShiftAssign - | RShift3Assign - | BitOrAssign - | BitXorAssign - | BitAndAssign - | NullishAssign - | AndAssign - | OrAssign - - and ('M, 'T) t = { - operator: operator option; - left: ('M, 'T) Pattern.t; - right: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Update : sig - type operator = - | Increment - | Decrement - - and ('M, 'T) t = { - operator: operator; - argument: ('M, 'T) Expression.t; - prefix: bool; - comments: ('M, unit) Syntax.t option; - } - end - - module Logical : sig - type operator = - | Or - | And - | NullishCoalesce - - and ('M, 'T) t = { - operator: operator; - left: ('M, 'T) Expression.t; - right: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Conditional : sig - type ('M, 'T) t = { - test: ('M, 'T) Expression.t; - consequent: ('M, 'T) Expression.t; - alternate: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) expression_or_spread = - | Expression of ('M, 'T) Expression.t - | Spread of ('M, 'T) SpreadElement.t - - module ArgList : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - arguments: ('M, 'T) expression_or_spread list; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module New : sig - type ('M, 'T) t = { - callee: ('M, 'T) Expression.t; - targs: ('M, 'T) Expression.CallTypeArgs.t option; - arguments: ('M, 'T) ArgList.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module Call : sig - type ('M, 'T) t = { - callee: ('M, 'T) Expression.t; - targs: ('M, 'T) Expression.CallTypeArgs.t option; - arguments: ('M, 'T) ArgList.t; - comments: ('M, unit) Syntax.t option; - } - end - - module OptionalCall : sig - type ('M, 'T) t = { - call: ('M, 'T) Call.t; - filtered_out: 'T; - optional: bool; - } - end - - module Member : sig - type ('M, 'T) property = - | PropertyIdentifier of ('M, 'T) Identifier.t - | PropertyPrivateName of 'M PrivateName.t - | PropertyExpression of ('M, 'T) Expression.t - - and ('M, 'T) t = { - _object: ('M, 'T) Expression.t; - property: ('M, 'T) property; - comments: ('M, unit) Syntax.t option; - } - end - - module OptionalMember : sig - type ('M, 'T) t = { - member: ('M, 'T) Member.t; - filtered_out: 'T; - optional: bool; - } - end - - module Yield : sig - type ('M, 'T) t = { - argument: ('M, 'T) Expression.t option; - comments: ('M, unit) Syntax.t option; - delegate: bool; - result_out: 'T; - } - end - - module Comprehension : sig - module Block : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - left: ('M, 'T) Pattern.t; - right: ('M, 'T) Expression.t; - each: bool; - } - end - - type ('M, 'T) t = { - blocks: ('M, 'T) Block.t list; - filter: ('M, 'T) Expression.t option; - } - end - - module Generator : sig - type ('M, 'T) t = { - blocks: ('M, 'T) Comprehension.Block.t list; - filter: ('M, 'T) Expression.t option; - } - end - - module TypeCast : sig - type ('M, 'T) t = { - expression: ('M, 'T) Expression.t; - annot: ('M, 'T) Type.annotation; - comments: ('M, unit) Syntax.t option; - } - end - - module MetaProperty : sig - type 'M t = { - meta: ('M, 'M) Identifier.t; - property: ('M, 'M) Identifier.t; - comments: ('M, unit) Syntax.t option; - } - end - - module This : sig - type 'M t = { comments: ('M, unit) Syntax.t option } - end - - module Super : sig - type 'M t = { comments: ('M, unit) Syntax.t option } - end - - module Import : sig - type ('M, 'T) t = { - argument: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) t = 'T * ('M, 'T) t' - - and ('M, 'T) t' = - | Array of ('M, 'T) Array.t - | ArrowFunction of ('M, 'T) Function.t - | Assignment of ('M, 'T) Assignment.t - | Binary of ('M, 'T) Binary.t - | Call of ('M, 'T) Call.t - | Class of ('M, 'T) Class.t - | Comprehension of ('M, 'T) Comprehension.t - | Conditional of ('M, 'T) Conditional.t - | Function of ('M, 'T) Function.t - | Generator of ('M, 'T) Generator.t - | Identifier of ('M, 'T) Identifier.t - | Import of ('M, 'T) Import.t - | JSXElement of ('M, 'T) JSX.element - | JSXFragment of ('M, 'T) JSX.fragment - | Literal of 'M Literal.t - | Logical of ('M, 'T) Logical.t - | Member of ('M, 'T) Member.t - | MetaProperty of 'M MetaProperty.t - | New of ('M, 'T) New.t - | Object of ('M, 'T) Object.t - | OptionalCall of ('M, 'T) OptionalCall.t - | OptionalMember of ('M, 'T) OptionalMember.t - | Sequence of ('M, 'T) Sequence.t - | Super of 'M Super.t - | TaggedTemplate of ('M, 'T) TaggedTemplate.t - | TemplateLiteral of ('M, 'T) TemplateLiteral.t - | This of 'M This.t - | TypeCast of ('M, 'T) TypeCast.t - | Unary of ('M, 'T) Unary.t - | Update of ('M, 'T) Update.t - | Yield of ('M, 'T) Yield.t -end = - Expression - -and JSX : sig - module Identifier : sig - type ('M, 'T) t = 'T * 'M t' - - and 'M t' = { - name: string; - comments: ('M, unit) Syntax.t option; - } - end - - module NamespacedName : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - namespace: ('M, 'T) Identifier.t; - name: ('M, 'T) Identifier.t; - } - end - - module ExpressionContainer : sig - type ('M, 'T) t = { - expression: ('M, 'T) expression; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - - and ('M, 'T) expression = - | Expression of ('M, 'T) Expression.t - | EmptyExpression - end - - module Text : sig - type t = { - value: string; - raw: string; - } - end - - module Attribute : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) name = - | Identifier of ('M, 'T) Identifier.t - | NamespacedName of ('M, 'T) NamespacedName.t - - and ('M, 'T) value = - | Literal of 'T * 'M Literal.t - | ExpressionContainer of 'T * ('M, 'T) ExpressionContainer.t - - and ('M, 'T) t' = { - name: ('M, 'T) name; - value: ('M, 'T) value option; - } - end - - module SpreadAttribute : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - module MemberExpression : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) _object = - | Identifier of ('M, 'T) Identifier.t - | MemberExpression of ('M, 'T) t - - and ('M, 'T) t' = { - _object: ('M, 'T) _object; - property: ('M, 'T) Identifier.t; - } - end - - type ('M, 'T) name = - | Identifier of ('M, 'T) Identifier.t - | NamespacedName of ('M, 'T) NamespacedName.t - | MemberExpression of ('M, 'T) MemberExpression.t - - module Opening : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) attribute = - | Attribute of ('M, 'T) Attribute.t - | SpreadAttribute of ('M, 'T) SpreadAttribute.t - - and ('M, 'T) t' = { - name: ('M, 'T) name; - self_closing: bool; - attributes: ('M, 'T) attribute list; - } - end - - module Closing : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - and ('M, 'T) t' = { name: ('M, 'T) name } - end - - module SpreadChild : sig - type ('M, 'T) t = { - expression: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) child = 'M * ('M, 'T) child' - - and ('M, 'T) child' = - | Element of ('M, 'T) element - | Fragment of ('M, 'T) fragment - | ExpressionContainer of ('M, 'T) ExpressionContainer.t - | SpreadChild of ('M, 'T) SpreadChild.t - | Text of Text.t - - and ('M, 'T) element = { - opening_element: ('M, 'T) Opening.t; - closing_element: ('M, 'T) Closing.t option; - children: 'M * ('M, 'T) child list; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) fragment = { - frag_opening_element: 'M; - frag_closing_element: 'M; - frag_children: 'M * ('M, 'T) child list; - frag_comments: ('M, unit) Syntax.t option; - } -end = - JSX - -and Pattern : sig - module RestElement : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Pattern.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Object : sig - module Property : sig - type ('M, 'T) key = - | Literal of ('M * 'M Literal.t) - | Identifier of ('M, 'T) Identifier.t - | Computed of ('M, 'T) ComputedKey.t - - and ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - key: ('M, 'T) key; - pattern: ('M, 'T) Pattern.t; - default: ('M, 'T) Expression.t option; - shorthand: bool; - } - end - - type ('M, 'T) property = - | Property of ('M, 'T) Property.t - | RestElement of ('M, 'T) RestElement.t - - and ('M, 'T) t = { - properties: ('M, 'T) property list; - annot: ('M, 'T) Type.annotation_or_hint; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module Array : sig - module Element : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Pattern.t; - default: ('M, 'T) Expression.t option; - } - end - - type ('M, 'T) element = - | Element of ('M, 'T) Element.t - | RestElement of ('M, 'T) RestElement.t - | Hole of 'M - - and ('M, 'T) t = { - elements: ('M, 'T) element list; - annot: ('M, 'T) Type.annotation_or_hint; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - module Identifier : sig - type ('M, 'T) t = { - name: ('M, 'T) Identifier.t; - annot: ('M, 'T) Type.annotation_or_hint; - optional: bool; - } - end - - type ('M, 'T) t = 'T * ('M, 'T) t' - - and ('M, 'T) t' = - | Object of ('M, 'T) Object.t - | Array of ('M, 'T) Array.t - | Identifier of ('M, 'T) Identifier.t - | Expression of ('M, 'T) Expression.t -end = - Pattern - -and Comment : sig - type 'M t = 'M * t' - - and kind = - | Block - | Line - - and t' = { - kind: kind; - text: string; - on_newline: bool; - } -end = - Comment - -and Class : sig - module Method : sig - type ('M, 'T) t = 'T * ('M, 'T) t' - - and kind = - | Constructor - | Method - | Get - | Set - - and ('M, 'T) t' = { - kind: kind; - key: ('M, 'T) Expression.Object.Property.key; - value: 'M * ('M, 'T) Function.t; - static: bool; - decorators: ('M, 'T) Class.Decorator.t list; - comments: ('M, unit) Syntax.t option; - } - end - - module Property : sig - type ('M, 'T) t = 'T * ('M, 'T) t' - - and ('M, 'T) t' = { - key: ('M, 'T) Expression.Object.Property.key; - value: ('M, 'T) value; - annot: ('M, 'T) Type.annotation_or_hint; - static: bool; - variance: 'M Variance.t option; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) value = - | Declared - | Uninitialized - | Initialized of ('M, 'T) Expression.t - end - - module PrivateField : sig - type ('M, 'T) t = 'T * ('M, 'T) t' - - and ('M, 'T) t' = { - key: 'M PrivateName.t; - value: ('M, 'T) Class.Property.value; - annot: ('M, 'T) Type.annotation_or_hint; - static: bool; - variance: 'M Variance.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module Extends : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - expr: ('M, 'T) Expression.t; - targs: ('M, 'T) Type.TypeArgs.t option; - comments: ('M, unit) Syntax.t option; - } - end - - module Implements : sig - module Interface : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - id: ('M, 'T) Identifier.t; - targs: ('M, 'T) Type.TypeArgs.t option; - } - end - - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - interfaces: ('M, 'T) Interface.t list; - comments: ('M, unit) Syntax.t option; - } - end - - module Body : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - body: ('M, 'T) element list; - comments: ('M, unit) Syntax.t option; - } - - and ('M, 'T) element = - | Method of ('M, 'T) Method.t - | Property of ('M, 'T) Property.t - | PrivateField of ('M, 'T) PrivateField.t - end - - module Decorator : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - expression: ('M, 'T) Expression.t; - comments: ('M, unit) Syntax.t option; - } - end - - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t option; - body: ('M, 'T) Class.Body.t; - tparams: ('M, 'T) Type.TypeParams.t option; - extends: ('M, 'T) Extends.t option; - implements: ('M, 'T) Implements.t option; - class_decorators: ('M, 'T) Decorator.t list; - comments: ('M, unit) Syntax.t option; - } -end = - Class - -and Function : sig - module RestParam : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Pattern.t; - comments: ('M, unit) Syntax.t option; - } - end - - module Param : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - argument: ('M, 'T) Pattern.t; - default: ('M, 'T) Expression.t option; - } - end - - module ThisParam : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - annot: ('M, 'T) Type.annotation; - comments: ('M, unit) Syntax.t option; - } - end - - module Params : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - this_: ('M, 'T) ThisParam.t option; - params: ('M, 'T) Param.t list; - rest: ('M, 'T) RestParam.t option; - comments: ('M, 'M Comment.t list) Syntax.t option; - } - end - - type ('M, 'T) t = { - id: ('M, 'T) Identifier.t option; - params: ('M, 'T) Params.t; - body: ('M, 'T) body; - async: bool; - generator: bool; - predicate: ('M, 'T) Type.Predicate.t option; - return: ('M, 'T) Type.annotation_or_hint; - tparams: ('M, 'T) Type.TypeParams.t option; - comments: ('M, unit) Syntax.t option; - (* Location of the signature portion of a function, e.g. - * function foo(): void {} - * ^^^^^^^^^^^^^^^^^^^^ - *) - sig_loc: 'M; - } - - and ('M, 'T) body = - | BodyBlock of ('M * ('M, 'T) Statement.Block.t) - | BodyExpression of ('M, 'T) Expression.t -end = - Function - -and Program : sig - type ('M, 'T) t = 'M * ('M, 'T) t' - - and ('M, 'T) t' = { - statements: ('M, 'T) Statement.t list; - comments: ('M, unit) Syntax.t option; - all_comments: 'M Comment.t list; - } -end = - Program diff --git a/jscomp/js_parser/flow_ast_mapper.ml b/jscomp/js_parser/flow_ast_mapper.ml deleted file mode 100644 index 60050c7..0000000 --- a/jscomp/js_parser/flow_ast_mapper.ml +++ /dev/null @@ -1,2681 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast - -let map_opt : 'node. ('node -> 'node) -> 'node option -> 'node option = - fun map opt -> - match opt with - | Some item -> - let item' = map item in - if item == item' then - opt - else - Some item' - | None -> opt - -let id_loc : 'node 'a. ('loc -> 'node -> 'node) -> 'loc -> 'node -> 'a -> ('node -> 'a) -> 'a = - fun map loc item same diff -> - let item' = map loc item in - if item == item' then - same - else - diff item' - -let id : 'node 'a. ('node -> 'node) -> 'node -> 'a -> ('node -> 'a) -> 'a = - fun map item same diff -> - let item' = map item in - if item == item' then - same - else - diff item' - -let map_loc : 'node. ('loc -> 'node -> 'node) -> 'loc * 'node -> 'loc * 'node = - fun map same -> - let (loc, item) = same in - id_loc map loc item same (fun diff -> (loc, diff)) - -let map_loc_opt : 'node. ('loc -> 'node -> 'node) -> ('loc * 'node) option -> ('loc * 'node) option - = - fun map same -> - map_opt - (fun same -> - let (loc, item) = same in - id_loc map loc item same (fun diff -> (loc, diff))) - same - -let map_list map lst = - let (rev_lst, changed) = - List.fold_left - (fun (lst', changed) item -> - let item' = map item in - (item' :: lst', changed || item' != item)) - ([], false) - lst - in - if changed then - List.rev rev_lst - else - lst - -let map_list_multiple map lst = - let (rev_lst, changed) = - List.fold_left - (fun (lst', changed) item -> - match map item with - | [] -> (lst', true) - | [item'] -> (item' :: lst', changed || item != item') - | items' -> (List.rev_append items' lst', true)) - ([], false) - lst - in - if changed then - List.rev rev_lst - else - lst - -class ['loc] mapper = - object (this) - method program (program : ('loc, 'loc) Ast.Program.t) = - let open Ast.Program in - let (loc, { statements; comments; all_comments }) = program in - let statements' = this#toplevel_statement_list statements in - let comments' = this#syntax_opt comments in - let all_comments' = map_list this#comment all_comments in - if statements == statements' && comments == comments' && all_comments == all_comments' then - program - else - (loc, { statements = statements'; comments = comments'; all_comments = all_comments' }) - - method statement (stmt : ('loc, 'loc) Ast.Statement.t) = - let open Ast.Statement in - match stmt with - | (loc, Block block) -> id_loc this#block loc block stmt (fun block -> (loc, Block block)) - | (loc, Break break) -> id_loc this#break loc break stmt (fun break -> (loc, Break break)) - | (loc, ClassDeclaration cls) -> - id_loc this#class_declaration loc cls stmt (fun cls -> (loc, ClassDeclaration cls)) - | (loc, Continue cont) -> id_loc this#continue loc cont stmt (fun cont -> (loc, Continue cont)) - | (loc, Debugger dbg) -> id_loc this#debugger loc dbg stmt (fun dbg -> (loc, Debugger dbg)) - | (loc, DeclareClass stuff) -> - id_loc this#declare_class loc stuff stmt (fun stuff -> (loc, DeclareClass stuff)) - | (loc, DeclareExportDeclaration decl) -> - id_loc this#declare_export_declaration loc decl stmt (fun decl -> - (loc, DeclareExportDeclaration decl) - ) - | (loc, DeclareFunction stuff) -> - id_loc this#declare_function loc stuff stmt (fun stuff -> (loc, DeclareFunction stuff)) - | (loc, DeclareInterface stuff) -> - id_loc this#declare_interface loc stuff stmt (fun stuff -> (loc, DeclareInterface stuff)) - | (loc, DeclareModule m) -> - id_loc this#declare_module loc m stmt (fun m -> (loc, DeclareModule m)) - | (loc, DeclareTypeAlias stuff) -> - id_loc this#declare_type_alias loc stuff stmt (fun stuff -> (loc, DeclareTypeAlias stuff)) - | (loc, DeclareVariable stuff) -> - id_loc this#declare_variable loc stuff stmt (fun stuff -> (loc, DeclareVariable stuff)) - | (loc, DeclareModuleExports annot) -> - id_loc this#declare_module_exports loc annot stmt (fun annot -> - (loc, DeclareModuleExports annot) - ) - | (loc, DoWhile stuff) -> - id_loc this#do_while loc stuff stmt (fun stuff -> (loc, DoWhile stuff)) - | (loc, Empty empty) -> id_loc this#empty loc empty stmt (fun empty -> (loc, Empty empty)) - | (loc, EnumDeclaration enum) -> - id_loc this#enum_declaration loc enum stmt (fun enum -> (loc, EnumDeclaration enum)) - | (loc, ExportDefaultDeclaration decl) -> - id_loc this#export_default_declaration loc decl stmt (fun decl -> - (loc, ExportDefaultDeclaration decl) - ) - | (loc, ExportNamedDeclaration decl) -> - id_loc this#export_named_declaration loc decl stmt (fun decl -> - (loc, ExportNamedDeclaration decl) - ) - | (loc, Expression expr) -> - id_loc this#expression_statement loc expr stmt (fun expr -> (loc, Expression expr)) - | (loc, For for_stmt) -> - id_loc this#for_statement loc for_stmt stmt (fun for_stmt -> (loc, For for_stmt)) - | (loc, ForIn stuff) -> - id_loc this#for_in_statement loc stuff stmt (fun stuff -> (loc, ForIn stuff)) - | (loc, ForOf stuff) -> - id_loc this#for_of_statement loc stuff stmt (fun stuff -> (loc, ForOf stuff)) - | (loc, FunctionDeclaration func) -> - id_loc this#function_declaration loc func stmt (fun func -> (loc, FunctionDeclaration func)) - | (loc, If if_stmt) -> - id_loc this#if_statement loc if_stmt stmt (fun if_stmt -> (loc, If if_stmt)) - | (loc, ImportDeclaration decl) -> - id_loc this#import_declaration loc decl stmt (fun decl -> (loc, ImportDeclaration decl)) - | (loc, InterfaceDeclaration stuff) -> - id_loc this#interface_declaration loc stuff stmt (fun stuff -> - (loc, InterfaceDeclaration stuff) - ) - | (loc, Labeled label) -> - id_loc this#labeled_statement loc label stmt (fun label -> (loc, Labeled label)) - | (loc, OpaqueType otype) -> - id_loc this#opaque_type loc otype stmt (fun otype -> (loc, OpaqueType otype)) - | (loc, Return ret) -> id_loc this#return loc ret stmt (fun ret -> (loc, Return ret)) - | (loc, Switch switch) -> - id_loc this#switch loc switch stmt (fun switch -> (loc, Switch switch)) - | (loc, Throw throw) -> id_loc this#throw loc throw stmt (fun throw -> (loc, Throw throw)) - | (loc, Try try_stmt) -> - id_loc this#try_catch loc try_stmt stmt (fun try_stmt -> (loc, Try try_stmt)) - | (loc, VariableDeclaration decl) -> - id_loc this#variable_declaration loc decl stmt (fun decl -> (loc, VariableDeclaration decl)) - | (loc, While stuff) -> id_loc this#while_ loc stuff stmt (fun stuff -> (loc, While stuff)) - | (loc, With stuff) -> id_loc this#with_ loc stuff stmt (fun stuff -> (loc, With stuff)) - | (loc, TypeAlias stuff) -> - id_loc this#type_alias loc stuff stmt (fun stuff -> (loc, TypeAlias stuff)) - | (loc, DeclareOpaqueType otype) -> - id_loc this#opaque_type loc otype stmt (fun otype -> (loc, OpaqueType otype)) - - method comment (c : 'loc Ast.Comment.t) = c - - method syntax_opt - : 'internal. ('loc, 'internal) Ast.Syntax.t option -> ('loc, 'internal) Ast.Syntax.t option - = - map_opt this#syntax - - method syntax : 'internal. ('loc, 'internal) Ast.Syntax.t -> ('loc, 'internal) Ast.Syntax.t = - fun attached -> - let open Ast.Syntax in - let { leading; trailing; internal } = attached in - let leading' = map_list this#comment leading in - let trailing' = map_list this#comment trailing in - if leading == leading' && trailing == trailing' then - attached - else - { leading = leading'; trailing = trailing'; internal } - - method expression (expr : ('loc, 'loc) Ast.Expression.t) = - let open Ast.Expression in - match expr with - | (loc, Array x) -> id_loc this#array loc x expr (fun x -> (loc, Array x)) - | (loc, ArrowFunction x) -> - id_loc this#arrow_function loc x expr (fun x -> (loc, ArrowFunction x)) - | (loc, Assignment x) -> id_loc this#assignment loc x expr (fun x -> (loc, Assignment x)) - | (loc, Binary x) -> id_loc this#binary loc x expr (fun x -> (loc, Binary x)) - | (loc, Call x) -> id_loc this#call loc x expr (fun x -> (loc, Call x)) - | (loc, Class x) -> id_loc this#class_expression loc x expr (fun x -> (loc, Class x)) - | (loc, Comprehension x) -> - id_loc this#comprehension loc x expr (fun x -> (loc, Comprehension x)) - | (loc, Conditional x) -> id_loc this#conditional loc x expr (fun x -> (loc, Conditional x)) - | (loc, Function x) -> id_loc this#function_expression loc x expr (fun x -> (loc, Function x)) - | (loc, Generator x) -> id_loc this#generator loc x expr (fun x -> (loc, Generator x)) - | (loc, Identifier x) -> id this#identifier x expr (fun x -> (loc, Identifier x)) - | (loc, Import x) -> id (this#import loc) x expr (fun x -> (loc, Import x)) - | (loc, JSXElement x) -> id_loc this#jsx_element loc x expr (fun x -> (loc, JSXElement x)) - | (loc, JSXFragment x) -> id_loc this#jsx_fragment loc x expr (fun x -> (loc, JSXFragment x)) - | (loc, Literal x) -> id_loc this#literal loc x expr (fun x -> (loc, Literal x)) - | (loc, Logical x) -> id_loc this#logical loc x expr (fun x -> (loc, Logical x)) - | (loc, Member x) -> id_loc this#member loc x expr (fun x -> (loc, Member x)) - | (loc, MetaProperty x) -> - id_loc this#meta_property loc x expr (fun x -> (loc, MetaProperty x)) - | (loc, New x) -> id_loc this#new_ loc x expr (fun x -> (loc, New x)) - | (loc, Object x) -> id_loc this#object_ loc x expr (fun x -> (loc, Object x)) - | (loc, OptionalCall x) -> id (this#optional_call loc) x expr (fun x -> (loc, OptionalCall x)) - | (loc, OptionalMember x) -> - id_loc this#optional_member loc x expr (fun x -> (loc, OptionalMember x)) - | (loc, Sequence x) -> id_loc this#sequence loc x expr (fun x -> (loc, Sequence x)) - | (loc, Super x) -> id_loc this#super_expression loc x expr (fun x -> (loc, Super x)) - | (loc, TaggedTemplate x) -> - id_loc this#tagged_template loc x expr (fun x -> (loc, TaggedTemplate x)) - | (loc, TemplateLiteral x) -> - id_loc this#template_literal loc x expr (fun x -> (loc, TemplateLiteral x)) - | (loc, This x) -> id_loc this#this_expression loc x expr (fun x -> (loc, This x)) - | (loc, TypeCast x) -> id_loc this#type_cast loc x expr (fun x -> (loc, TypeCast x)) - | (loc, Unary x) -> id_loc this#unary_expression loc x expr (fun x -> (loc, Unary x)) - | (loc, Update x) -> id_loc this#update_expression loc x expr (fun x -> (loc, Update x)) - | (loc, Yield x) -> id_loc this#yield loc x expr (fun x -> (loc, Yield x)) - - method array _loc (expr : ('loc, 'loc) Ast.Expression.Array.t) = - let open Ast.Expression in - let { Array.elements; comments } = expr in - let elements' = map_list this#array_element elements in - let comments' = this#syntax_opt comments in - if elements == elements' && comments == comments' then - expr - else - { Array.elements = elements'; comments = comments' } - - method array_element element = - let open Ast.Expression.Array in - match element with - | Expression expr -> id this#expression expr element (fun expr -> Expression expr) - | Spread spread -> id this#spread_element spread element (fun spread -> Spread spread) - | Hole _ -> element - - method arrow_function loc (expr : ('loc, 'loc) Ast.Function.t) = this#function_ loc expr - - method assignment _loc (expr : ('loc, 'loc) Ast.Expression.Assignment.t) = - let open Ast.Expression.Assignment in - let { operator = _; left; right; comments } = expr in - let left' = this#assignment_pattern left in - let right' = this#expression right in - let comments' = this#syntax_opt comments in - if left == left' && right == right' && comments == comments' then - expr - else - { expr with left = left'; right = right'; comments = comments' } - - method binary _loc (expr : ('loc, 'loc) Ast.Expression.Binary.t) = - let open Ast.Expression.Binary in - let { operator = _; left; right; comments } = expr in - let left' = this#expression left in - let right' = this#expression right in - let comments' = this#syntax_opt comments in - if left == left' && right == right' && comments == comments' then - expr - else - { expr with left = left'; right = right'; comments = comments' } - - method block _loc (stmt : ('loc, 'loc) Ast.Statement.Block.t) = - let open Ast.Statement.Block in - let { body; comments } = stmt in - let body' = this#statement_list body in - let comments' = this#syntax_opt comments in - if body == body' && comments == comments' then - stmt - else - { body = body'; comments = comments' } - - method break _loc (break : 'loc Ast.Statement.Break.t) = - let open Ast.Statement.Break in - let { label; comments } = break in - let label' = map_opt this#label_identifier label in - let comments' = this#syntax_opt comments in - if label == label' && comments == comments' then - break - else - { label = label'; comments = comments' } - - method call _loc (expr : ('loc, 'loc) Ast.Expression.Call.t) = - let open Ast.Expression.Call in - let { callee; targs; arguments; comments } = expr in - let callee' = this#expression callee in - let targs' = map_opt this#call_type_args targs in - let arguments' = this#call_arguments arguments in - let comments' = this#syntax_opt comments in - if callee == callee' && targs == targs' && arguments == arguments' && comments == comments' - then - expr - else - { callee = callee'; targs = targs'; arguments = arguments'; comments = comments' } - - method call_arguments (arg_list : ('loc, 'loc) Ast.Expression.ArgList.t) = - let open Ast.Expression.ArgList in - let (loc, { arguments; comments }) = arg_list in - let arguments' = map_list this#expression_or_spread arguments in - let comments' = this#syntax_opt comments in - if arguments == arguments' && comments == comments' then - arg_list - else - (loc, { arguments = arguments'; comments = comments' }) - - method optional_call loc (expr : ('loc, 'loc) Ast.Expression.OptionalCall.t) = - let open Ast.Expression.OptionalCall in - let { call; optional = _; filtered_out = _ } = expr in - let call' = this#call loc call in - if call == call' then - expr - else - { expr with call = call' } - - method call_type_args (targs : ('loc, 'loc) Ast.Expression.CallTypeArgs.t) = - let open Ast.Expression.CallTypeArgs in - let (loc, { arguments; comments }) = targs in - let arguments' = map_list this#call_type_arg arguments in - let comments' = this#syntax_opt comments in - if arguments == arguments' && comments == comments' then - targs - else - (loc, { arguments = arguments'; comments = comments' }) - - method call_type_arg t = - let open Ast.Expression.CallTypeArg in - match t with - | Explicit x -> - let x' = this#type_ x in - if x' == x then - t - else - Explicit x' - | Implicit (loc, { Implicit.comments }) -> - let comments' = this#syntax_opt comments in - if comments == comments' then - t - else - Implicit (loc, { Implicit.comments = comments' }) - - method catch_body (body : 'loc * ('loc, 'loc) Ast.Statement.Block.t) = map_loc this#block body - - method catch_clause _loc (clause : ('loc, 'loc) Ast.Statement.Try.CatchClause.t') = - let open Ast.Statement.Try.CatchClause in - let { param; body; comments } = clause in - let param' = map_opt this#catch_clause_pattern param in - let body' = this#catch_body body in - let comments' = this#syntax_opt comments in - if param == param' && body == body' && comments == comments' then - clause - else - { param = param'; body = body'; comments = comments' } - - method class_declaration loc (cls : ('loc, 'loc) Ast.Class.t) = this#class_ loc cls - - method class_expression loc (cls : ('loc, 'loc) Ast.Class.t) = this#class_ loc cls - - method class_ _loc (cls : ('loc, 'loc) Ast.Class.t) = - let open Ast.Class in - let { id; body; tparams; extends; implements; class_decorators; comments } = cls in - let id' = map_opt this#class_identifier id in - let tparams' = map_opt this#type_params tparams in - let body' = this#class_body body in - let extends' = map_opt (map_loc this#class_extends) extends in - let implements' = map_opt this#class_implements implements in - let class_decorators' = map_list this#class_decorator class_decorators in - let comments' = this#syntax_opt comments in - if - id == id' - && body == body' - && extends == extends' - && implements == implements' - && class_decorators == class_decorators' - && comments == comments' - && tparams == tparams' - then - cls - else - { - id = id'; - body = body'; - extends = extends'; - implements = implements'; - class_decorators = class_decorators'; - comments = comments'; - tparams = tparams'; - } - - method class_extends _loc (extends : ('loc, 'loc) Ast.Class.Extends.t') = - let open Ast.Class.Extends in - let { expr; targs; comments } = extends in - let expr' = this#expression expr in - let targs' = map_opt this#type_args targs in - let comments' = this#syntax_opt comments in - if expr == expr' && targs == targs' && comments == comments' then - extends - else - { expr = expr'; targs = targs'; comments = comments' } - - method class_identifier (ident : ('loc, 'loc) Ast.Identifier.t) = - this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Let ident - - method class_body (cls_body : ('loc, 'loc) Ast.Class.Body.t) = - let open Ast.Class.Body in - let (loc, { body; comments }) = cls_body in - let body' = map_list this#class_element body in - let comments' = this#syntax_opt comments in - if body == body' && comments == comments' then - cls_body - else - (loc, { body = body'; comments = comments' }) - - method class_decorator (dec : ('loc, 'loc) Ast.Class.Decorator.t) = - let open Ast.Class.Decorator in - let (loc, { expression; comments }) = dec in - let expression' = this#expression expression in - let comments' = this#syntax_opt comments in - if expression == expression' && comments == comments' then - dec - else - (loc, { expression = expression'; comments = comments' }) - - method class_element (elem : ('loc, 'loc) Ast.Class.Body.element) = - let open Ast.Class.Body in - match elem with - | Method (loc, meth) -> id_loc this#class_method loc meth elem (fun meth -> Method (loc, meth)) - | Property (loc, prop) -> - id_loc this#class_property loc prop elem (fun prop -> Property (loc, prop)) - | PrivateField (loc, field) -> - id_loc this#class_private_field loc field elem (fun field -> PrivateField (loc, field)) - - method class_implements (implements : ('loc, 'loc) Ast.Class.Implements.t) = - let open Ast.Class.Implements in - let (loc, { interfaces; comments }) = implements in - let interfaces' = map_list this#class_implements_interface interfaces in - let comments' = this#syntax_opt comments in - if interfaces == interfaces' && comments == comments' then - implements - else - (loc, { interfaces = interfaces'; comments = comments' }) - - method class_implements_interface (interface : ('loc, 'loc) Ast.Class.Implements.Interface.t) = - let open Ast.Class.Implements.Interface in - let (loc, { id; targs }) = interface in - let id' = this#type_identifier_reference id in - let targs' = map_opt this#type_args targs in - if id == id' && targs == targs' then - interface - else - (loc, { id = id'; targs = targs' }) - - method class_method _loc (meth : ('loc, 'loc) Ast.Class.Method.t') = - let open Ast.Class.Method in - let { kind = _; key; value; static = _; decorators; comments } = meth in - let key' = this#object_key key in - let value' = map_loc this#function_expression_or_method value in - let decorators' = map_list this#class_decorator decorators in - let comments' = this#syntax_opt comments in - if key == key' && value == value' && decorators == decorators' && comments == comments' then - meth - else - { meth with key = key'; value = value'; decorators = decorators'; comments = comments' } - - method class_property _loc (prop : ('loc, 'loc) Ast.Class.Property.t') = - let open Ast.Class.Property in - let { key; value; annot; static = _; variance; comments } = prop in - let key' = this#object_key key in - let value' = this#class_property_value value in - let annot' = this#type_annotation_hint annot in - let variance' = this#variance_opt variance in - let comments' = this#syntax_opt comments in - if - key == key' - && value == value' - && annot' == annot - && variance' == variance - && comments' == comments - then - prop - else - { - prop with - key = key'; - value = value'; - annot = annot'; - variance = variance'; - comments = comments'; - } - - method class_property_value (value : ('loc, 'loc) Ast.Class.Property.value) = - let open Ast.Class.Property in - match value with - | Declared -> value - | Uninitialized -> value - | Initialized x -> - let x' = this#expression x in - if x == x' then - value - else - Initialized x' - - method class_private_field _loc (prop : ('loc, 'loc) Ast.Class.PrivateField.t') = - let open Ast.Class.PrivateField in - let { key; value; annot; static = _; variance; comments } = prop in - let key' = this#private_name key in - let value' = this#class_property_value value in - let annot' = this#type_annotation_hint annot in - let variance' = this#variance_opt variance in - let comments' = this#syntax_opt comments in - if - key == key' - && value == value' - && annot' == annot - && variance' == variance - && comments' == comments - then - prop - else - { - prop with - key = key'; - value = value'; - annot = annot'; - variance = variance'; - comments = comments'; - } - - (* TODO *) - method comprehension _loc (expr : ('loc, 'loc) Ast.Expression.Comprehension.t) = expr - - method conditional _loc (expr : ('loc, 'loc) Ast.Expression.Conditional.t) = - let open Ast.Expression.Conditional in - let { test; consequent; alternate; comments } = expr in - let test' = this#predicate_expression test in - let consequent' = this#expression consequent in - let alternate' = this#expression alternate in - let comments' = this#syntax_opt comments in - if - test == test' - && consequent == consequent' - && alternate == alternate' - && comments == comments' - then - expr - else - { test = test'; consequent = consequent'; alternate = alternate'; comments = comments' } - - method continue _loc (cont : 'loc Ast.Statement.Continue.t) = - let open Ast.Statement.Continue in - let { label; comments } = cont in - let label' = map_opt this#label_identifier label in - let comments' = this#syntax_opt comments in - if label == label' && comments == comments' then - cont - else - { label = label'; comments = comments' } - - method debugger _loc (dbg : 'loc Ast.Statement.Debugger.t) = - let open Ast.Statement.Debugger in - let { comments } = dbg in - let comments' = this#syntax_opt comments in - if comments == comments' then - dbg - else - { comments = comments' } - - method declare_class _loc (decl : ('loc, 'loc) Ast.Statement.DeclareClass.t) = - let open Ast.Statement.DeclareClass in - let { id = ident; tparams; body; extends; mixins; implements; comments } = decl in - let id' = this#class_identifier ident in - let tparams' = map_opt this#type_params tparams in - let body' = map_loc this#object_type body in - let extends' = map_opt (map_loc this#generic_type) extends in - let mixins' = map_list (map_loc this#generic_type) mixins in - let implements' = map_opt this#class_implements implements in - let comments' = this#syntax_opt comments in - if - id' == ident - && tparams' == tparams - && body' == body - && extends' == extends - && mixins' == mixins - && implements' == implements - && comments' == comments - then - decl - else - { - id = id'; - tparams = tparams'; - body = body'; - extends = extends'; - mixins = mixins'; - implements = implements'; - comments = comments'; - } - - method declare_export_declaration - _loc (decl : ('loc, 'loc) Ast.Statement.DeclareExportDeclaration.t) = - let open Ast.Statement.DeclareExportDeclaration in - let { default; source; specifiers; declaration; comments } = decl in - let source' = map_loc_opt this#export_source source in - let specifiers' = map_opt this#export_named_specifier specifiers in - let declaration' = map_opt this#declare_export_declaration_decl declaration in - let comments' = this#syntax_opt comments in - if - source == source' - && specifiers == specifiers' - && declaration == declaration' - && comments == comments' - then - decl - else - { - default; - source = source'; - specifiers = specifiers'; - declaration = declaration'; - comments = comments'; - } - - method declare_export_declaration_decl - (decl : ('loc, 'loc) Ast.Statement.DeclareExportDeclaration.declaration) = - let open Ast.Statement.DeclareExportDeclaration in - match decl with - | Variable (loc, dv) -> - let dv' = this#declare_variable loc dv in - if dv' == dv then - decl - else - Variable (loc, dv') - | Function (loc, df) -> - let df' = this#declare_function loc df in - if df' == df then - decl - else - Function (loc, df') - | Class (loc, dc) -> - let dc' = this#declare_class loc dc in - if dc' == dc then - decl - else - Class (loc, dc') - | DefaultType t -> - let t' = this#type_ t in - if t' == t then - decl - else - DefaultType t' - | NamedType (loc, ta) -> - let ta' = this#type_alias loc ta in - if ta' == ta then - decl - else - NamedType (loc, ta') - | NamedOpaqueType (loc, ot) -> - let ot' = this#opaque_type loc ot in - if ot' == ot then - decl - else - NamedOpaqueType (loc, ot') - | Interface (loc, i) -> - let i' = this#interface loc i in - if i' == i then - decl - else - Interface (loc, i') - - method declare_function _loc (decl : ('loc, 'loc) Ast.Statement.DeclareFunction.t) = - let open Ast.Statement.DeclareFunction in - let { id = ident; annot; predicate; comments } = decl in - let id' = this#function_identifier ident in - let annot' = this#type_annotation annot in - let predicate' = map_opt this#predicate predicate in - let comments' = this#syntax_opt comments in - if id' == ident && annot' == annot && predicate' == predicate && comments' == comments then - decl - else - { id = id'; annot = annot'; predicate = predicate'; comments = comments' } - - method declare_interface loc (decl : ('loc, 'loc) Ast.Statement.Interface.t) = - this#interface loc decl - - method declare_module _loc (m : ('loc, 'loc) Ast.Statement.DeclareModule.t) = - let open Ast.Statement.DeclareModule in - let { id; body; kind; comments } = m in - let body' = map_loc this#block body in - let comments' = this#syntax_opt comments in - if body' == body && comments == comments' then - m - else - { id; body = body'; kind; comments = comments' } - - method declare_module_exports _loc (exports : ('loc, 'loc) Ast.Statement.DeclareModuleExports.t) - = - let open Ast.Statement.DeclareModuleExports in - let { annot; comments } = exports in - let annot' = this#type_annotation annot in - let comments' = this#syntax_opt comments in - if annot == annot' && comments == comments' then - exports - else - { annot = annot'; comments = comments' } - - method declare_type_alias loc (decl : ('loc, 'loc) Ast.Statement.TypeAlias.t) = - this#type_alias loc decl - - method declare_variable _loc (decl : ('loc, 'loc) Ast.Statement.DeclareVariable.t) = - let open Ast.Statement.DeclareVariable in - let { id = ident; annot; comments } = decl in - let id' = this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Var ident in - let annot' = this#type_annotation annot in - let comments' = this#syntax_opt comments in - if id' == ident && annot' == annot && comments' == comments then - decl - else - { id = id'; annot = annot'; comments = comments' } - - method do_while _loc (stuff : ('loc, 'loc) Ast.Statement.DoWhile.t) = - let open Ast.Statement.DoWhile in - let { body; test; comments } = stuff in - let body' = this#statement body in - let test' = this#predicate_expression test in - let comments' = this#syntax_opt comments in - if body == body' && test == test' && comments == comments' then - stuff - else - { body = body'; test = test'; comments = comments' } - - method empty _loc empty = - let open Ast.Statement.Empty in - let { comments } = empty in - let comments' = this#syntax_opt comments in - if comments == comments' then - empty - else - { comments = comments' } - - method enum_declaration _loc (enum : ('loc, 'loc) Ast.Statement.EnumDeclaration.t) = - let open Ast.Statement.EnumDeclaration in - let { id = ident; body; comments } = enum in - let id' = this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Const ident in - let body' = this#enum_body body in - let comments' = this#syntax_opt comments in - if ident == id' && body == body' && comments == comments' then - enum - else - { id = id'; body = body'; comments = comments' } - - method enum_body (body : 'loc Ast.Statement.EnumDeclaration.body) = - let open Ast.Statement.EnumDeclaration in - match body with - | (loc, BooleanBody boolean_body) -> - id this#enum_boolean_body boolean_body body (fun body -> (loc, BooleanBody body)) - | (loc, NumberBody number_body) -> - id this#enum_number_body number_body body (fun body -> (loc, NumberBody body)) - | (loc, StringBody string_body) -> - id this#enum_string_body string_body body (fun body -> (loc, StringBody body)) - | (loc, SymbolBody symbol_body) -> - id this#enum_symbol_body symbol_body body (fun body -> (loc, SymbolBody body)) - - method enum_boolean_body (body : 'loc Ast.Statement.EnumDeclaration.BooleanBody.t) = - let open Ast.Statement.EnumDeclaration.BooleanBody in - let { members; explicit_type = _; has_unknown_members = _; comments } = body in - let members' = map_list this#enum_boolean_member members in - let comments' = this#syntax_opt comments in - if members == members' && comments == comments' then - body - else - { body with members = members'; comments = comments' } - - method enum_number_body (body : 'loc Ast.Statement.EnumDeclaration.NumberBody.t) = - let open Ast.Statement.EnumDeclaration.NumberBody in - let { members; explicit_type = _; has_unknown_members = _; comments } = body in - let members' = map_list this#enum_number_member members in - let comments' = this#syntax_opt comments in - if members == members' && comments == comments' then - body - else - { body with members = members'; comments = comments' } - - method enum_string_body (body : 'loc Ast.Statement.EnumDeclaration.StringBody.t) = - let open Ast.Statement.EnumDeclaration.StringBody in - let { members; explicit_type = _; has_unknown_members = _; comments } = body in - let members' = - match members with - | Defaulted m -> id (map_list this#enum_defaulted_member) m members (fun m -> Defaulted m) - | Initialized m -> id (map_list this#enum_string_member) m members (fun m -> Initialized m) - in - let comments' = this#syntax_opt comments in - if members == members' && comments == comments' then - body - else - { body with members = members'; comments = comments' } - - method enum_symbol_body (body : 'loc Ast.Statement.EnumDeclaration.SymbolBody.t) = - let open Ast.Statement.EnumDeclaration.SymbolBody in - let { members; has_unknown_members = _; comments } = body in - let members' = map_list this#enum_defaulted_member members in - let comments' = this#syntax_opt comments in - if members == members' && comments == comments' then - body - else - { body with members = members'; comments = comments' } - - method enum_defaulted_member (member : 'loc Ast.Statement.EnumDeclaration.DefaultedMember.t) = - let open Ast.Statement.EnumDeclaration.DefaultedMember in - let (loc, { id = ident }) = member in - let id' = this#enum_member_identifier ident in - if ident == id' then - member - else - (loc, { id = id' }) - - method enum_boolean_member - (member : - ('loc Ast.BooleanLiteral.t, 'loc) Ast.Statement.EnumDeclaration.InitializedMember.t - ) = - let open Ast.Statement.EnumDeclaration.InitializedMember in - let (loc, { id = ident; init }) = member in - let id' = this#enum_member_identifier ident in - if ident == id' then - member - else - (loc, { id = id'; init }) - - method enum_number_member - (member : ('loc Ast.NumberLiteral.t, 'loc) Ast.Statement.EnumDeclaration.InitializedMember.t) - = - let open Ast.Statement.EnumDeclaration.InitializedMember in - let (loc, { id = ident; init }) = member in - let id' = this#enum_member_identifier ident in - if ident == id' then - member - else - (loc, { id = id'; init }) - - method enum_string_member - (member : ('loc Ast.StringLiteral.t, 'loc) Ast.Statement.EnumDeclaration.InitializedMember.t) - = - let open Ast.Statement.EnumDeclaration.InitializedMember in - let (loc, { id = ident; init }) = member in - let id' = this#enum_member_identifier ident in - if ident == id' then - member - else - (loc, { id = id'; init }) - - method enum_member_identifier (id : ('loc, 'loc) Ast.Identifier.t) = this#identifier id - - method export_default_declaration - _loc (decl : ('loc, 'loc) Ast.Statement.ExportDefaultDeclaration.t) = - let open Ast.Statement.ExportDefaultDeclaration in - let { default; declaration; comments } = decl in - let declaration' = this#export_default_declaration_decl declaration in - let comments' = this#syntax_opt comments in - if declaration' == declaration && comments' == comments then - decl - else - { default; declaration = declaration'; comments = comments' } - - method export_default_declaration_decl - (decl : ('loc, 'loc) Ast.Statement.ExportDefaultDeclaration.declaration) = - let open Ast.Statement.ExportDefaultDeclaration in - match decl with - | Declaration stmt -> id this#statement stmt decl (fun stmt -> Declaration stmt) - | Expression expr -> id this#expression expr decl (fun expr -> Expression expr) - - method export_named_declaration _loc (decl : ('loc, 'loc) Ast.Statement.ExportNamedDeclaration.t) - = - let open Ast.Statement.ExportNamedDeclaration in - let { export_kind; source; specifiers; declaration; comments } = decl in - let source' = map_loc_opt this#export_source source in - let specifiers' = map_opt this#export_named_specifier specifiers in - let declaration' = map_opt this#statement declaration in - let comments' = this#syntax_opt comments in - if - source == source' - && specifiers == specifiers' - && declaration == declaration' - && comments == comments' - then - decl - else - { - export_kind; - source = source'; - specifiers = specifiers'; - declaration = declaration'; - comments = comments'; - } - - method export_named_declaration_specifier - (spec : 'loc Ast.Statement.ExportNamedDeclaration.ExportSpecifier.t) = - let open Ast.Statement.ExportNamedDeclaration.ExportSpecifier in - let (loc, { local; exported }) = spec in - let local' = this#identifier local in - let exported' = map_opt this#identifier exported in - if local == local' && exported == exported' then - spec - else - (loc, { local = local'; exported = exported' }) - - method export_batch_specifier - (spec : 'loc Ast.Statement.ExportNamedDeclaration.ExportBatchSpecifier.t) = - let (loc, id_opt) = spec in - let id_opt' = map_opt this#identifier id_opt in - if id_opt == id_opt' then - spec - else - (loc, id_opt') - - method export_named_specifier (spec : 'loc Ast.Statement.ExportNamedDeclaration.specifier) = - let open Ast.Statement.ExportNamedDeclaration in - match spec with - | ExportSpecifiers spec_list -> - let spec_list' = map_list this#export_named_declaration_specifier spec_list in - if spec_list == spec_list' then - spec - else - ExportSpecifiers spec_list' - | ExportBatchSpecifier batch -> - let batch' = this#export_batch_specifier batch in - if batch == batch' then - spec - else - ExportBatchSpecifier batch' - - method export_source _loc (source : 'loc Ast.StringLiteral.t) = - let open Ast.StringLiteral in - let { value; raw; comments } = source in - let comments' = this#syntax_opt comments in - if comments == comments' then - source - else - { value; raw; comments = comments' } - - method expression_statement _loc (stmt : ('loc, 'loc) Ast.Statement.Expression.t) = - let open Ast.Statement.Expression in - let { expression = expr; directive; comments } = stmt in - let expr' = this#expression expr in - let comments' = this#syntax_opt comments in - if expr == expr' && comments == comments' then - stmt - else - { expression = expr'; directive; comments = comments' } - - method expression_or_spread expr_or_spread = - let open Ast.Expression in - match expr_or_spread with - | Expression expr -> id this#expression expr expr_or_spread (fun expr -> Expression expr) - | Spread spread -> id this#spread_element spread expr_or_spread (fun spread -> Spread spread) - - method for_in_statement _loc (stmt : ('loc, 'loc) Ast.Statement.ForIn.t) = - let open Ast.Statement.ForIn in - let { left; right; body; each; comments } = stmt in - let left' = this#for_in_statement_lhs left in - let right' = this#expression right in - let body' = this#statement body in - let comments' = this#syntax_opt comments in - if left == left' && right == right' && body == body' && comments == comments' then - stmt - else - { left = left'; right = right'; body = body'; each; comments = comments' } - - method for_in_statement_lhs (left : ('loc, 'loc) Ast.Statement.ForIn.left) = - let open Ast.Statement.ForIn in - match left with - | LeftDeclaration decl -> - id this#for_in_left_declaration decl left (fun decl -> LeftDeclaration decl) - | LeftPattern patt -> - id this#for_in_assignment_pattern patt left (fun patt -> LeftPattern patt) - - method for_in_left_declaration left = - let (loc, decl) = left in - id_loc this#variable_declaration loc decl left (fun decl -> (loc, decl)) - - method for_of_statement _loc (stuff : ('loc, 'loc) Ast.Statement.ForOf.t) = - let open Ast.Statement.ForOf in - let { left; right; body; await; comments } = stuff in - let left' = this#for_of_statement_lhs left in - let right' = this#expression right in - let body' = this#statement body in - let comments' = this#syntax_opt comments in - if left == left' && right == right' && body == body' && comments == comments' then - stuff - else - { left = left'; right = right'; body = body'; await; comments = comments' } - - method for_of_statement_lhs (left : ('loc, 'loc) Ast.Statement.ForOf.left) = - let open Ast.Statement.ForOf in - match left with - | LeftDeclaration decl -> - id this#for_of_left_declaration decl left (fun decl -> LeftDeclaration decl) - | LeftPattern patt -> - id this#for_of_assignment_pattern patt left (fun patt -> LeftPattern patt) - - method for_of_left_declaration left = - let (loc, decl) = left in - id_loc this#variable_declaration loc decl left (fun decl -> (loc, decl)) - - method for_statement _loc (stmt : ('loc, 'loc) Ast.Statement.For.t) = - let open Ast.Statement.For in - let { init; test; update; body; comments } = stmt in - let init' = map_opt this#for_statement_init init in - let test' = map_opt this#predicate_expression test in - let update' = map_opt this#expression update in - let body' = this#statement body in - let comments' = this#syntax_opt comments in - if - init == init' - && test == test' - && update == update' - && body == body' - && comments == comments' - then - stmt - else - { init = init'; test = test'; update = update'; body = body'; comments = comments' } - - method for_statement_init (init : ('loc, 'loc) Ast.Statement.For.init) = - let open Ast.Statement.For in - match init with - | InitDeclaration decl -> - id this#for_init_declaration decl init (fun decl -> InitDeclaration decl) - | InitExpression expr -> id this#expression expr init (fun expr -> InitExpression expr) - - method for_init_declaration init = - let (loc, decl) = init in - id_loc this#variable_declaration loc decl init (fun decl -> (loc, decl)) - - method function_param_type (fpt : ('loc, 'loc) Ast.Type.Function.Param.t) = - let open Ast.Type.Function.Param in - let (loc, { annot; name; optional }) = fpt in - let annot' = this#type_ annot in - let name' = map_opt this#identifier name in - if annot' == annot && name' == name then - fpt - else - (loc, { annot = annot'; name = name'; optional }) - - method function_rest_param_type (frpt : ('loc, 'loc) Ast.Type.Function.RestParam.t) = - let open Ast.Type.Function.RestParam in - let (loc, { argument; comments }) = frpt in - let argument' = this#function_param_type argument in - let comments' = this#syntax_opt comments in - if argument' == argument && comments' == comments then - frpt - else - (loc, { argument = argument'; comments = comments' }) - - method function_this_param_type (this_param : ('loc, 'loc) Ast.Type.Function.ThisParam.t) = - let open Ast.Type.Function.ThisParam in - let (loc, { annot; comments }) = this_param in - let annot' = this#type_annotation annot in - let comments' = this#syntax_opt comments in - if annot' == annot && comments' == comments then - this_param - else - (loc, { annot = annot'; comments = comments' }) - - method function_type _loc (ft : ('loc, 'loc) Ast.Type.Function.t) = - let open Ast.Type.Function in - let { - params = (params_loc, { Params.this_; params = ps; rest = rpo; comments = params_comments }); - return; - tparams; - comments = func_comments; - } = - ft - in - let tparams' = map_opt this#type_params tparams in - let this_' = map_opt this#function_this_param_type this_ in - let ps' = map_list this#function_param_type ps in - let rpo' = map_opt this#function_rest_param_type rpo in - let return' = this#type_ return in - let func_comments' = this#syntax_opt func_comments in - let params_comments' = this#syntax_opt params_comments in - if - ps' == ps - && rpo' == rpo - && return' == return - && tparams' == tparams - && func_comments' == func_comments - && params_comments' == params_comments - && this_' == this_ - then - ft - else - { - params = - ( params_loc, - { Params.this_ = this_'; params = ps'; rest = rpo'; comments = params_comments' } - ); - return = return'; - tparams = tparams'; - comments = func_comments'; - } - - method label_identifier (ident : ('loc, 'loc) Ast.Identifier.t) = this#identifier ident - - method object_property_value_type (opvt : ('loc, 'loc) Ast.Type.Object.Property.value) = - let open Ast.Type.Object.Property in - match opvt with - | Init t -> id this#type_ t opvt (fun t -> Init t) - | Get t -> id this#object_type_property_getter t opvt (fun t -> Get t) - | Set t -> id this#object_type_property_setter t opvt (fun t -> Set t) - - method object_type_property_getter getter = - let (loc, ft) = getter in - id_loc this#function_type loc ft getter (fun ft -> (loc, ft)) - - method object_type_property_setter setter = - let (loc, ft) = setter in - id_loc this#function_type loc ft setter (fun ft -> (loc, ft)) - - method object_property_type (opt : ('loc, 'loc) Ast.Type.Object.Property.t) = - let open Ast.Type.Object.Property in - let (loc, { key; value; optional; static; proto; _method; variance; comments }) = opt in - let key' = this#object_key key in - let value' = this#object_property_value_type value in - let variance' = this#variance_opt variance in - let comments' = this#syntax_opt comments in - if key' == key && value' == value && variance' == variance && comments' == comments then - opt - else - ( loc, - { - key = key'; - value = value'; - optional; - static; - proto; - _method; - variance = variance'; - comments = comments'; - } - ) - - method object_spread_property_type (opt : ('loc, 'loc) Ast.Type.Object.SpreadProperty.t) = - let open Ast.Type.Object.SpreadProperty in - let (loc, { argument; comments }) = opt in - let argument' = this#type_ argument in - let comments' = this#syntax_opt comments in - if argument' == argument && comments == comments' then - opt - else - (loc, { argument = argument'; comments = comments' }) - - method object_indexer_property_type (opt : ('loc, 'loc) Ast.Type.Object.Indexer.t) = - let open Ast.Type.Object.Indexer in - let (loc, { id; key; value; static; variance; comments }) = opt in - let key' = this#type_ key in - let value' = this#type_ value in - let variance' = this#variance_opt variance in - let comments' = this#syntax_opt comments in - if key' == key && value' == value && variance' == variance && comments' == comments then - opt - else - (loc, { id; key = key'; value = value'; static; variance = variance'; comments = comments' }) - - method object_internal_slot_property_type (slot : ('loc, 'loc) Ast.Type.Object.InternalSlot.t) = - let open Ast.Type.Object.InternalSlot in - let (loc, { id; value; optional; static; _method; comments }) = slot in - let id' = this#identifier id in - let value' = this#type_ value in - let comments' = this#syntax_opt comments in - if id == id' && value == value' && comments == comments' then - slot - else - (loc, { id = id'; value = value'; optional; static; _method; comments = comments' }) - - method object_call_property_type (call : ('loc, 'loc) Ast.Type.Object.CallProperty.t) = - let open Ast.Type.Object.CallProperty in - let (loc, { value = (value_loc, value); static; comments }) = call in - let value' = this#function_type value_loc value in - let comments' = this#syntax_opt comments in - if value == value' && comments == comments' then - call - else - (loc, { value = (value_loc, value'); static; comments = comments' }) - - method object_type _loc (ot : ('loc, 'loc) Ast.Type.Object.t) = - let open Ast.Type.Object in - let { properties; exact; inexact; comments } = ot in - let properties' = - map_list - (fun p -> - match p with - | Property p' -> id this#object_property_type p' p (fun p' -> Property p') - | SpreadProperty p' -> - id this#object_spread_property_type p' p (fun p' -> SpreadProperty p') - | Indexer p' -> id this#object_indexer_property_type p' p (fun p' -> Indexer p') - | InternalSlot p' -> - id this#object_internal_slot_property_type p' p (fun p' -> InternalSlot p') - | CallProperty p' -> id this#object_call_property_type p' p (fun p' -> CallProperty p')) - properties - in - let comments' = this#syntax_opt comments in - if properties' == properties && comments == comments' then - ot - else - { properties = properties'; exact; inexact; comments = comments' } - - method interface_type _loc (i : ('loc, 'loc) Ast.Type.Interface.t) = - let open Ast.Type.Interface in - let { extends; body; comments } = i in - let extends' = map_list (map_loc this#generic_type) extends in - let body' = map_loc this#object_type body in - let comments' = this#syntax_opt comments in - if extends' == extends && body' == body && comments == comments' then - i - else - { extends = extends'; body = body'; comments = comments' } - - method generic_identifier_type (git : ('loc, 'loc) Ast.Type.Generic.Identifier.t) = - let open Ast.Type.Generic.Identifier in - match git with - | Unqualified i -> id this#type_identifier_reference i git (fun i -> Unqualified i) - | Qualified i -> id this#generic_qualified_identifier_type i git (fun i -> Qualified i) - - method generic_qualified_identifier_type qual = - let open Ast.Type.Generic.Identifier in - let (loc, { qualification; id }) = qual in - let qualification' = this#generic_identifier_type qualification in - let id' = this#member_type_identifier id in - if qualification' == qualification && id' == id then - qual - else - (loc, { qualification = qualification'; id = id' }) - - method member_type_identifier id = this#identifier id - - method variance (variance : 'loc Ast.Variance.t) = - let (loc, { Ast.Variance.kind; comments }) = variance in - let comments' = this#syntax_opt comments in - if comments == comments' then - variance - else - (loc, { Ast.Variance.kind; comments = comments' }) - - method variance_opt (opt : 'loc Ast.Variance.t option) = map_opt this#variance opt - - method type_args (targs : ('loc, 'loc) Ast.Type.TypeArgs.t) = - let open Ast.Type.TypeArgs in - let (loc, { arguments; comments }) = targs in - let arguments' = map_list this#type_ arguments in - let comments' = this#syntax_opt comments in - if arguments == arguments' && comments == comments' then - targs - else - (loc, { arguments = arguments'; comments = comments' }) - - method type_params (tparams : ('loc, 'loc) Ast.Type.TypeParams.t) = - let open Ast.Type.TypeParams in - let (loc, { params = tps; comments }) = tparams in - let tps' = map_list this#type_param tps in - let comments' = this#syntax_opt comments in - if tps' == tps && comments' == comments then - tparams - else - (loc, { params = tps'; comments = comments' }) - - method type_param (tparam : ('loc, 'loc) Ast.Type.TypeParam.t) = - let open Ast.Type.TypeParam in - let (loc, { name; bound; variance; default }) = tparam in - let bound' = this#type_annotation_hint bound in - let variance' = this#variance_opt variance in - let default' = map_opt this#type_ default in - let name' = this#binding_type_identifier name in - if name' == name && bound' == bound && variance' == variance && default' == default then - tparam - else - (loc, { name = name'; bound = bound'; variance = variance'; default = default' }) - - method generic_type _loc (gt : ('loc, 'loc) Ast.Type.Generic.t) = - let open Ast.Type.Generic in - let { id; targs; comments } = gt in - let id' = this#generic_identifier_type id in - let targs' = map_opt this#type_args targs in - let comments' = this#syntax_opt comments in - if id' == id && targs' == targs && comments' == comments then - gt - else - { id = id'; targs = targs'; comments = comments' } - - method indexed_access _loc (ia : ('loc, 'loc) Ast.Type.IndexedAccess.t) = - let open Ast.Type.IndexedAccess in - let { _object; index; comments } = ia in - let _object' = this#type_ _object in - let index' = this#type_ index in - let comments' = this#syntax_opt comments in - if _object' == _object && index' == index && comments' == comments then - ia - else - { _object = _object'; index = index'; comments = comments' } - - method optional_indexed_access loc (ia : ('loc, 'loc) Ast.Type.OptionalIndexedAccess.t) = - let open Ast.Type.OptionalIndexedAccess in - let { indexed_access; optional } = ia in - let indexed_access' = this#indexed_access loc indexed_access in - if indexed_access' == indexed_access then - ia - else - { indexed_access = indexed_access'; optional } - - method string_literal_type _loc (lit : 'loc Ast.StringLiteral.t) = - let open Ast.StringLiteral in - let { value; raw; comments } = lit in - let comments' = this#syntax_opt comments in - if comments == comments' then - lit - else - { value; raw; comments = comments' } - - method number_literal_type _loc (lit : 'loc Ast.NumberLiteral.t) = - let open Ast.NumberLiteral in - let { value; raw; comments } = lit in - let comments' = this#syntax_opt comments in - if comments == comments' then - lit - else - { value; raw; comments = comments' } - - method bigint_literal_type _loc (lit : 'loc Ast.BigIntLiteral.t) = - let open Ast.BigIntLiteral in - let { value; raw; comments } = lit in - let comments' = this#syntax_opt comments in - if comments == comments' then - lit - else - { value; raw; comments = comments' } - - method boolean_literal_type _loc (lit : 'loc Ast.BooleanLiteral.t) = - let open Ast.BooleanLiteral in - let { value; comments } = lit in - let comments' = this#syntax_opt comments in - if comments == comments' then - lit - else - { value; comments = comments' } - - method nullable_type (t : ('loc, 'loc) Ast.Type.Nullable.t) = - let open Ast.Type.Nullable in - let { argument; comments } = t in - let argument' = this#type_ argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - t - else - { argument = argument'; comments = comments' } - - method typeof_type (t : ('loc, 'loc) Ast.Type.Typeof.t) = - let open Ast.Type.Typeof in - let { argument; comments } = t in - let argument' = this#typeof_expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - t - else - { argument = argument'; comments = comments' } - - method typeof_expression (git : ('loc, 'loc) Ast.Type.Typeof.Target.t) = - let open Ast.Type.Typeof.Target in - match git with - | Unqualified i -> id this#typeof_identifier i git (fun i -> Unqualified i) - | Qualified i -> id this#typeof_qualified_identifier i git (fun i -> Qualified i) - - method typeof_identifier id = this#identifier id - - method typeof_member_identifier id = this#identifier id - - method typeof_qualified_identifier qual = - let open Ast.Type.Typeof.Target in - let (loc, { qualification; id }) = qual in - let qualification' = this#typeof_expression qualification in - let id' = this#typeof_member_identifier id in - if qualification' == qualification && id' == id then - qual - else - (loc, { qualification = qualification'; id = id' }) - - method tuple_type (t : ('loc, 'loc) Ast.Type.Tuple.t) = - let open Ast.Type.Tuple in - let { types; comments } = t in - let types' = map_list this#type_ types in - let comments' = this#syntax_opt comments in - if types == types' && comments == comments' then - t - else - { types = types'; comments = comments' } - - method array_type (t : ('loc, 'loc) Ast.Type.Array.t) = - let open Ast.Type.Array in - let { argument; comments } = t in - let argument' = this#type_ argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - t - else - { argument = argument'; comments = comments' } - - method union_type _loc (t : ('loc, 'loc) Ast.Type.Union.t) = - let open Ast.Type.Union in - let { types = (t0, t1, ts); comments } = t in - let t0' = this#type_ t0 in - let t1' = this#type_ t1 in - let ts' = map_list this#type_ ts in - let comments' = this#syntax_opt comments in - if t0' == t0 && t1' == t1 && ts' == ts && comments' == comments then - t - else - { types = (t0', t1', ts'); comments = comments' } - - method intersection_type _loc (t : ('loc, 'loc) Ast.Type.Intersection.t) = - let open Ast.Type.Intersection in - let { types = (t0, t1, ts); comments } = t in - let t0' = this#type_ t0 in - let t1' = this#type_ t1 in - let ts' = map_list this#type_ ts in - let comments' = this#syntax_opt comments in - if t0' == t0 && t1' == t1 && ts' == ts && comments' == comments then - t - else - { types = (t0', t1', ts'); comments = comments' } - - method type_ (t : ('loc, 'loc) Ast.Type.t) = - let open Ast.Type in - match t with - | (loc, Any comments) -> id this#syntax_opt comments t (fun comments -> (loc, Any comments)) - | (loc, Mixed comments) -> - id this#syntax_opt comments t (fun comments -> (loc, Mixed comments)) - | (loc, Empty comments) -> - id this#syntax_opt comments t (fun comments -> (loc, Empty comments)) - | (loc, Void comments) -> id this#syntax_opt comments t (fun comments -> (loc, Void comments)) - | (loc, Null comments) -> id this#syntax_opt comments t (fun comments -> (loc, Null comments)) - | (loc, Symbol comments) -> - id this#syntax_opt comments t (fun comments -> (loc, Symbol comments)) - | (loc, Number comments) -> - id this#syntax_opt comments t (fun comments -> (loc, Number comments)) - | (loc, BigInt comments) -> - id this#syntax_opt comments t (fun comments -> (loc, BigInt comments)) - | (loc, String comments) -> - id this#syntax_opt comments t (fun comments -> (loc, String comments)) - | (loc, Boolean comments) -> - id this#syntax_opt comments t (fun comments -> (loc, Boolean comments)) - | (loc, Exists comments) -> - id this#syntax_opt comments t (fun comments -> (loc, Exists comments)) - | (loc, Nullable t') -> id this#nullable_type t' t (fun t' -> (loc, Nullable t')) - | (loc, Array t') -> id this#array_type t' t (fun t' -> (loc, Array t')) - | (loc, Typeof t') -> id this#typeof_type t' t (fun t' -> (loc, Typeof t')) - | (loc, Function ft) -> id_loc this#function_type loc ft t (fun ft -> (loc, Function ft)) - | (loc, Object ot) -> id_loc this#object_type loc ot t (fun ot -> (loc, Object ot)) - | (loc, Interface i) -> id_loc this#interface_type loc i t (fun i -> (loc, Interface i)) - | (loc, Generic gt) -> id_loc this#generic_type loc gt t (fun gt -> (loc, Generic gt)) - | (loc, IndexedAccess ia) -> - id_loc this#indexed_access loc ia t (fun ia -> (loc, IndexedAccess ia)) - | (loc, OptionalIndexedAccess ia) -> - id_loc this#optional_indexed_access loc ia t (fun ia -> (loc, OptionalIndexedAccess ia)) - | (loc, StringLiteral lit) -> - id_loc this#string_literal_type loc lit t (fun lit -> (loc, StringLiteral lit)) - | (loc, NumberLiteral lit) -> - id_loc this#number_literal_type loc lit t (fun lit -> (loc, NumberLiteral lit)) - | (loc, BigIntLiteral lit) -> - id_loc this#bigint_literal_type loc lit t (fun lit -> (loc, BigIntLiteral lit)) - | (loc, BooleanLiteral lit) -> - id_loc this#boolean_literal_type loc lit t (fun lit -> (loc, BooleanLiteral lit)) - | (loc, Union t') -> id_loc this#union_type loc t' t (fun t' -> (loc, Union t')) - | (loc, Intersection t') -> - id_loc this#intersection_type loc t' t (fun t' -> (loc, Intersection t')) - | (loc, Tuple t') -> id this#tuple_type t' t (fun t' -> (loc, Tuple t')) - - method type_annotation (annot : ('loc, 'loc) Ast.Type.annotation) = - let (loc, a) = annot in - id this#type_ a annot (fun a -> (loc, a)) - - method type_annotation_hint (return : ('M, 'T) Ast.Type.annotation_or_hint) = - let open Ast.Type in - match return with - | Available annot -> - let annot' = this#type_annotation annot in - if annot' == annot then - return - else - Available annot' - | Missing _loc -> return - - method function_declaration loc (stmt : ('loc, 'loc) Ast.Function.t) = this#function_ loc stmt - - method function_expression loc (stmt : ('loc, 'loc) Ast.Function.t) = - this#function_expression_or_method loc stmt - - (** previously, we conflated [function_expression] and [class_method]. callers should be - updated to override those individually. *) - method function_expression_or_method loc (stmt : ('loc, 'loc) Ast.Function.t) = - this#function_ loc stmt - [@@alert deprecated "Use either function_expression or class_method"] - - (* Internal helper for function declarations, function expressions and arrow functions *) - method function_ _loc (expr : ('loc, 'loc) Ast.Function.t) = - let open Ast.Function in - let { - id = ident; - params; - body; - async; - generator; - predicate; - return; - tparams; - sig_loc; - comments; - } = - expr - in - let ident' = map_opt this#function_identifier ident in - let tparams' = map_opt this#type_params tparams in - let params' = this#function_params params in - let return' = this#type_annotation_hint return in - let body' = this#function_body_any body in - let predicate' = map_opt this#predicate predicate in - let comments' = this#syntax_opt comments in - if - ident == ident' - && params == params' - && body == body' - && predicate == predicate' - && return == return' - && tparams == tparams' - && comments == comments' - then - expr - else - { - id = ident'; - params = params'; - return = return'; - body = body'; - async; - generator; - predicate = predicate'; - tparams = tparams'; - sig_loc; - comments = comments'; - } - - method function_params (params : ('loc, 'loc) Ast.Function.Params.t) = - let open Ast.Function in - let (loc, { Params.params = params_list; rest; comments; this_ }) = params in - let params_list' = map_list this#function_param params_list in - let rest' = map_opt this#function_rest_param rest in - let this_' = map_opt this#function_this_param this_ in - let comments' = this#syntax_opt comments in - if params_list == params_list' && rest == rest' && comments == comments' && this_ == this_' - then - params - else - (loc, { Params.params = params_list'; rest = rest'; comments = comments'; this_ = this_' }) - - method function_this_param (this_param : ('loc, 'loc) Ast.Function.ThisParam.t) = - let open Ast.Function.ThisParam in - let (loc, { annot; comments }) = this_param in - let annot' = this#type_annotation annot in - let comments' = this#syntax_opt comments in - if annot' == annot && comments' == comments then - this_param - else - (loc, { annot = annot'; comments = comments' }) - - method function_param (param : ('loc, 'loc) Ast.Function.Param.t) = - let open Ast.Function.Param in - let (loc, { argument; default }) = param in - let argument' = this#function_param_pattern argument in - let default' = map_opt this#expression default in - if argument == argument' && default == default' then - param - else - (loc, { argument = argument'; default = default' }) - - method function_body_any (body : ('loc, 'loc) Ast.Function.body) = - match body with - | Ast.Function.BodyBlock block -> - id this#function_body block body (fun block -> Ast.Function.BodyBlock block) - | Ast.Function.BodyExpression expr -> - id this#expression expr body (fun expr -> Ast.Function.BodyExpression expr) - - method function_body (body : 'loc * ('loc, 'loc) Ast.Statement.Block.t) = - let (loc, block) = body in - id_loc this#block loc block body (fun block -> (loc, block)) - - method function_identifier (ident : ('loc, 'loc) Ast.Identifier.t) = - this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Var ident - - (* TODO *) - method generator _loc (expr : ('loc, 'loc) Ast.Expression.Generator.t) = expr - - method identifier (id : ('loc, 'loc) Ast.Identifier.t) = - let open Ast.Identifier in - let (loc, { name; comments }) = id in - let comments' = this#syntax_opt comments in - if comments == comments' then - id - else - (loc, { name; comments = comments' }) - - method type_identifier (id : ('loc, 'loc) Ast.Identifier.t) = this#identifier id - - method type_identifier_reference (id : ('loc, 'loc) Ast.Identifier.t) = this#type_identifier id - - method binding_type_identifier (id : ('loc, 'loc) Ast.Identifier.t) = this#type_identifier id - - method interface _loc (interface : ('loc, 'loc) Ast.Statement.Interface.t) = - let open Ast.Statement.Interface in - let { id = ident; tparams; extends; body; comments } = interface in - let id' = this#binding_type_identifier ident in - let tparams' = map_opt this#type_params tparams in - let extends' = map_list (map_loc this#generic_type) extends in - let body' = map_loc this#object_type body in - let comments' = this#syntax_opt comments in - if - id' == ident - && tparams' == tparams - && extends' == extends - && body' == body - && comments' == comments - then - interface - else - { id = id'; tparams = tparams'; extends = extends'; body = body'; comments = comments' } - - method interface_declaration loc (decl : ('loc, 'loc) Ast.Statement.Interface.t) = - this#interface loc decl - - method private_name (id : 'loc Ast.PrivateName.t) = - let open Ast.PrivateName in - let (loc, { name; comments }) = id in - let comments' = this#syntax_opt comments in - if comments == comments' then - id - else - (loc, { name; comments = comments' }) - - method computed_key (key : ('loc, 'loc) Ast.ComputedKey.t) = - let open Ast.ComputedKey in - let (loc, { expression; comments }) = key in - let expression' = this#expression expression in - let comments' = this#syntax_opt comments in - if expression == expression' && comments == comments' then - key - else - (loc, { expression = expression'; comments = comments' }) - - method import _loc (expr : ('loc, 'loc) Ast.Expression.Import.t) = - let open Ast.Expression.Import in - let { argument; comments } = expr in - let argument' = this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - expr - else - { argument = argument'; comments = comments' } - - method if_consequent_statement ~has_else (stmt : ('loc, 'loc) Ast.Statement.t) = - ignore has_else; - this#statement stmt - - method if_alternate_statement _loc (altern : ('loc, 'loc) Ast.Statement.If.Alternate.t') = - let open Ast.Statement.If.Alternate in - let { body; comments } = altern in - let body' = this#statement body in - let comments' = this#syntax_opt comments in - if body == body' && comments == comments' then - altern - else - { body = body'; comments = comments' } - - method if_statement _loc (stmt : ('loc, 'loc) Ast.Statement.If.t) = - let open Ast.Statement.If in - let { test; consequent; alternate; comments } = stmt in - let test' = this#predicate_expression test in - let consequent' = this#if_consequent_statement ~has_else:(alternate <> None) consequent in - let alternate' = map_opt (map_loc this#if_alternate_statement) alternate in - let comments' = this#syntax_opt comments in - if - test == test' - && consequent == consequent' - && alternate == alternate' - && comments == comments' - then - stmt - else - { test = test'; consequent = consequent'; alternate = alternate'; comments = comments' } - - method import_declaration _loc (decl : ('loc, 'loc) Ast.Statement.ImportDeclaration.t) = - let open Ast.Statement.ImportDeclaration in - let { import_kind; source; specifiers; default; comments } = decl in - let source' = map_loc this#import_source source in - let specifiers' = map_opt (this#import_specifier ~import_kind) specifiers in - let default' = map_opt (this#import_default_specifier ~import_kind) default in - let comments' = this#syntax_opt comments in - if - source == source' - && specifiers == specifiers' - && default == default' - && comments == comments' - then - decl - else - { - import_kind; - source = source'; - specifiers = specifiers'; - default = default'; - comments = comments'; - } - - method import_source _loc (source : 'loc Ast.StringLiteral.t) = - let open Ast.StringLiteral in - let { value; raw; comments } = source in - let comments' = this#syntax_opt comments in - if comments == comments' then - source - else - { value; raw; comments = comments' } - - method import_specifier - ~import_kind (specifier : ('loc, 'loc) Ast.Statement.ImportDeclaration.specifier) = - let open Ast.Statement.ImportDeclaration in - match specifier with - | ImportNamedSpecifiers named_specifiers -> - let named_specifiers' = - map_list (this#import_named_specifier ~import_kind) named_specifiers - in - if named_specifiers == named_specifiers' then - specifier - else - ImportNamedSpecifiers named_specifiers' - | ImportNamespaceSpecifier (loc, ident) -> - id_loc (this#import_namespace_specifier ~import_kind) loc ident specifier (fun ident -> - ImportNamespaceSpecifier (loc, ident) - ) - - method remote_identifier id = this#identifier id - - method import_named_specifier - ~(import_kind : Ast.Statement.ImportDeclaration.import_kind) - (specifier : ('loc, 'loc) Ast.Statement.ImportDeclaration.named_specifier) = - let open Ast.Statement.ImportDeclaration in - let { kind; local; remote } = specifier in - let (is_type_remote, is_type_local) = - match (import_kind, kind) with - | (ImportType, _) - | (_, Some ImportType) -> - (true, true) - | (ImportTypeof, _) - | (_, Some ImportTypeof) -> - (false, true) - | _ -> (false, false) - in - let remote' = - match local with - | None -> - if is_type_remote then - this#binding_type_identifier remote - else - this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Let remote - | Some _ -> this#remote_identifier remote - in - let local' = - match local with - | None -> None - | Some ident -> - let local_visitor = - if is_type_local then - this#binding_type_identifier - else - this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Let - in - id local_visitor ident local (fun ident -> Some ident) - in - if local == local' && remote == remote' then - specifier - else - { kind; local = local'; remote = remote' } - - method import_default_specifier ~import_kind (id : ('loc, 'loc) Ast.Identifier.t) = - let open Ast.Statement.ImportDeclaration in - let local_visitor = - match import_kind with - | ImportType - | ImportTypeof -> - this#binding_type_identifier - | _ -> this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Let - in - local_visitor id - - method import_namespace_specifier ~import_kind _loc (id : ('loc, 'loc) Ast.Identifier.t) = - let open Ast.Statement.ImportDeclaration in - let local_visitor = - match import_kind with - | ImportType - | ImportTypeof -> - this#binding_type_identifier - | _ -> this#pattern_identifier ~kind:Ast.Statement.VariableDeclaration.Let - in - local_visitor id - - method jsx_element _loc (expr : ('loc, 'loc) Ast.JSX.element) = - let open Ast.JSX in - let { opening_element; closing_element; children; comments } = expr in - let opening_element' = this#jsx_opening_element opening_element in - let closing_element' = map_opt this#jsx_closing_element closing_element in - let children' = this#jsx_children children in - let comments' = this#syntax_opt comments in - if - opening_element == opening_element' - && closing_element == closing_element' - && children == children' - && comments == comments' - then - expr - else - { - opening_element = opening_element'; - closing_element = closing_element'; - children = children'; - comments = comments'; - } - - method jsx_fragment _loc (expr : ('loc, 'loc) Ast.JSX.fragment) = - let open Ast.JSX in - let { frag_children; frag_comments; _ } = expr in - let children' = this#jsx_children frag_children in - let frag_comments' = this#syntax_opt frag_comments in - if frag_children == children' && frag_comments == frag_comments' then - expr - else - { expr with frag_children = children'; frag_comments = frag_comments' } - - method jsx_opening_element (elem : ('loc, 'loc) Ast.JSX.Opening.t) = - let open Ast.JSX.Opening in - let (loc, { name; self_closing; attributes }) = elem in - let name' = this#jsx_element_name name in - let attributes' = map_list this#jsx_opening_attribute attributes in - if name == name' && attributes == attributes' then - elem - else - (loc, { name = name'; self_closing; attributes = attributes' }) - - method jsx_closing_element (elem : ('loc, 'loc) Ast.JSX.Closing.t) = - let open Ast.JSX.Closing in - let (loc, { name }) = elem in - let name' = this#jsx_element_name name in - if name == name' then - elem - else - (loc, { name = name' }) - - method jsx_opening_attribute (jsx_attr : ('loc, 'loc) Ast.JSX.Opening.attribute) = - let open Ast.JSX.Opening in - match jsx_attr with - | Attribute attr -> id this#jsx_attribute attr jsx_attr (fun attr -> Attribute attr) - | SpreadAttribute (loc, attr) -> - id_loc this#jsx_spread_attribute loc attr jsx_attr (fun attr -> SpreadAttribute (loc, attr)) - - method jsx_spread_attribute _loc (attr : ('loc, 'loc) Ast.JSX.SpreadAttribute.t') = - let open Ast.JSX.SpreadAttribute in - let { argument; comments } = attr in - let argument' = this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - attr - else - { argument = argument'; comments = comments' } - - method jsx_attribute (attr : ('loc, 'loc) Ast.JSX.Attribute.t) = - let open Ast.JSX.Attribute in - let (loc, { name; value }) = attr in - let name' = this#jsx_attribute_name name in - let value' = map_opt this#jsx_attribute_value value in - if name == name' && value == value' then - attr - else - (loc, { name = name'; value = value' }) - - method jsx_attribute_name (name : ('loc, 'loc) Ast.JSX.Attribute.name) = - let open Ast.JSX.Attribute in - match name with - | Identifier ident -> - id this#jsx_attribute_name_identifier ident name (fun ident -> Identifier ident) - | NamespacedName ns -> - id this#jsx_attribute_name_namespaced ns name (fun ns -> NamespacedName ns) - - method jsx_attribute_name_identifier ident = this#jsx_identifier ident - - method jsx_attribute_name_namespaced ns = this#jsx_namespaced_name ns - - method jsx_attribute_value (value : ('loc, 'loc) Ast.JSX.Attribute.value) = - let open Ast.JSX.Attribute in - match value with - | Literal (loc, lit) -> - id_loc this#jsx_attribute_value_literal loc lit value (fun lit -> Literal (loc, lit)) - | ExpressionContainer (loc, expr) -> - id_loc this#jsx_attribute_value_expression loc expr value (fun expr -> - ExpressionContainer (loc, expr) - ) - - method jsx_attribute_value_expression loc (jsx_expr : ('loc, 'loc) Ast.JSX.ExpressionContainer.t) - = - this#jsx_expression loc jsx_expr - - method jsx_attribute_value_literal loc (lit : 'loc Ast.Literal.t) = this#literal loc lit - - method jsx_children ((loc, children) as orig : 'loc * ('loc, 'loc) Ast.JSX.child list) = - let children' = map_list this#jsx_child children in - if children == children' then - orig - else - (loc, children') - - method jsx_child (child : ('loc, 'loc) Ast.JSX.child) = - let open Ast.JSX in - match child with - | (loc, Element elem) -> - id_loc this#jsx_element loc elem child (fun elem -> (loc, Element elem)) - | (loc, Fragment frag) -> - id_loc this#jsx_fragment loc frag child (fun frag -> (loc, Fragment frag)) - | (loc, ExpressionContainer expr) -> - id_loc this#jsx_expression loc expr child (fun expr -> (loc, ExpressionContainer expr)) - | (loc, SpreadChild spread) -> - id this#jsx_spread_child spread child (fun spread -> (loc, SpreadChild spread)) - | (_loc, Text _) -> child - - method jsx_expression _loc (jsx_expr : ('loc, 'loc) Ast.JSX.ExpressionContainer.t) = - let open Ast.JSX.ExpressionContainer in - let { expression; comments } = jsx_expr in - let comments' = this#syntax_opt comments in - match expression with - | Expression expr -> - let expr' = this#expression expr in - if expr == expr' && comments == comments' then - jsx_expr - else - { expression = Expression expr'; comments = comments' } - | EmptyExpression -> - if comments == comments' then - jsx_expr - else - { expression = EmptyExpression; comments = comments' } - - method jsx_spread_child (jsx_spread_child : ('loc, 'loc) Ast.JSX.SpreadChild.t) = - let open Ast.JSX.SpreadChild in - let { expression; comments } = jsx_spread_child in - let expression' = this#expression expression in - let comments' = this#syntax_opt comments in - if expression == expression' && comments == comments' then - jsx_spread_child - else - { expression = expression'; comments = comments' } - - method jsx_element_name (name : ('loc, 'loc) Ast.JSX.name) = - let open Ast.JSX in - match name with - | Identifier ident -> - id this#jsx_element_name_identifier ident name (fun ident -> Identifier ident) - | NamespacedName ns -> - id this#jsx_element_name_namespaced ns name (fun ns -> NamespacedName ns) - | MemberExpression expr -> - id this#jsx_element_name_member_expression expr name (fun expr -> MemberExpression expr) - - method jsx_element_name_identifier ident = this#jsx_identifier ident - - method jsx_element_name_namespaced ns = this#jsx_namespaced_name ns - - method jsx_element_name_member_expression expr = this#jsx_member_expression expr - - method jsx_namespaced_name (namespaced_name : ('loc, 'loc) Ast.JSX.NamespacedName.t) = - let open Ast.JSX in - NamespacedName.( - let (loc, { namespace; name }) = namespaced_name in - let namespace' = this#jsx_identifier namespace in - let name' = this#jsx_identifier name in - if namespace == namespace' && name == name' then - namespaced_name - else - (loc, { namespace = namespace'; name = name' }) - ) - - method jsx_member_expression (member_exp : ('loc, 'loc) Ast.JSX.MemberExpression.t) = - let open Ast.JSX in - let (loc, { MemberExpression._object; MemberExpression.property }) = member_exp in - let _object' = this#jsx_member_expression_object _object in - let property' = this#jsx_identifier property in - if _object == _object' && property == property' then - member_exp - else - (loc, MemberExpression.{ _object = _object'; property = property' }) - - method jsx_member_expression_object (_object : ('loc, 'loc) Ast.JSX.MemberExpression._object) = - let open Ast.JSX.MemberExpression in - match _object with - | Identifier ident -> - id this#jsx_member_expression_identifier ident _object (fun ident -> Identifier ident) - | MemberExpression nested_exp -> - id this#jsx_member_expression nested_exp _object (fun exp -> MemberExpression exp) - - method jsx_member_expression_identifier ident = this#jsx_element_name_identifier ident - - method jsx_identifier (id : ('loc, 'loc) Ast.JSX.Identifier.t) = - let open Ast.JSX.Identifier in - let (loc, { name; comments }) = id in - let comments' = this#syntax_opt comments in - if comments == comments' then - id - else - (loc, { name; comments = comments' }) - - method labeled_statement _loc (stmt : ('loc, 'loc) Ast.Statement.Labeled.t) = - let open Ast.Statement.Labeled in - let { label; body; comments } = stmt in - let label' = this#label_identifier label in - let body' = this#statement body in - let comments' = this#syntax_opt comments in - if label == label' && body == body' && comments == comments' then - stmt - else - { label = label'; body = body'; comments = comments' } - - method literal _loc (expr : 'loc Ast.Literal.t) = - let open Ast.Literal in - let { value; raw; comments } = expr in - let comments' = this#syntax_opt comments in - if comments == comments' then - expr - else - { value; raw; comments = comments' } - - method logical _loc (expr : ('loc, 'loc) Ast.Expression.Logical.t) = - let open Ast.Expression.Logical in - let { operator = _; left; right; comments } = expr in - let left' = this#expression left in - let right' = this#expression right in - let comments' = this#syntax_opt comments in - if left == left' && right == right' && comments == comments' then - expr - else - { expr with left = left'; right = right'; comments = comments' } - - method member _loc (expr : ('loc, 'loc) Ast.Expression.Member.t) = - let open Ast.Expression.Member in - let { _object; property; comments } = expr in - let _object' = this#expression _object in - let property' = this#member_property property in - let comments' = this#syntax_opt comments in - if _object == _object' && property == property' && comments == comments' then - expr - else - { _object = _object'; property = property'; comments = comments' } - - method optional_member loc (expr : ('loc, 'loc) Ast.Expression.OptionalMember.t) = - let open Ast.Expression.OptionalMember in - let { member; optional = _; filtered_out = _ } = expr in - let member' = this#member loc member in - if member == member' then - expr - else - { expr with member = member' } - - method member_property (expr : ('loc, 'loc) Ast.Expression.Member.property) = - let open Ast.Expression.Member in - match expr with - | PropertyIdentifier ident -> - id this#member_property_identifier ident expr (fun ident -> PropertyIdentifier ident) - | PropertyPrivateName ident -> - id this#member_private_name ident expr (fun ident -> PropertyPrivateName ident) - | PropertyExpression e -> - id this#member_property_expression e expr (fun e -> PropertyExpression e) - - method member_property_identifier (ident : ('loc, 'loc) Ast.Identifier.t) = - this#identifier ident - - method member_private_name (name : 'loc Ast.PrivateName.t) = this#private_name name - - method member_property_expression (expr : ('loc, 'loc) Ast.Expression.t) = this#expression expr - - method meta_property _loc (expr : 'loc Ast.Expression.MetaProperty.t) = - let open Ast.Expression.MetaProperty in - let { meta; property; comments } = expr in - let meta' = this#identifier meta in - let property' = this#identifier property in - let comments' = this#syntax_opt comments in - if meta == meta' && property == property' && comments == comments' then - expr - else - { meta = meta'; property = property'; comments = comments' } - - method new_ _loc (expr : ('loc, 'loc) Ast.Expression.New.t) = - let open Ast.Expression.New in - let { callee; targs; arguments; comments } = expr in - let callee' = this#expression callee in - let targs' = map_opt this#call_type_args targs in - let arguments' = map_opt this#call_arguments arguments in - let comments' = this#syntax_opt comments in - if callee == callee' && targs == targs' && arguments == arguments' && comments == comments' - then - expr - else - { callee = callee'; targs = targs'; arguments = arguments'; comments = comments' } - - method object_ _loc (expr : ('loc, 'loc) Ast.Expression.Object.t) = - let open Ast.Expression.Object in - let { properties; comments } = expr in - let properties' = - map_list - (fun prop -> - match prop with - | Property p -> - let p' = this#object_property p in - if p == p' then - prop - else - Property p' - | SpreadProperty s -> - let s' = this#spread_property s in - if s == s' then - prop - else - SpreadProperty s') - properties - in - let comments' = this#syntax_opt comments in - if properties == properties' && comments == comments' then - expr - else - { properties = properties'; comments = comments' } - - method object_property (prop : ('loc, 'loc) Ast.Expression.Object.Property.t) = - let open Ast.Expression.Object.Property in - match prop with - | (loc, Init { key; value; shorthand }) -> - let key' = this#object_key key in - let value' = this#expression value in - let shorthand' = - (* Try to figure out if shorthand should still be true--if - key and value change differently, it should become false *) - shorthand - && - match (key', value') with - | ( Identifier (_, { Ast.Identifier.name = key_name; _ }), - (_, Ast.Expression.Identifier (_, { Ast.Identifier.name = value_name; _ })) - ) -> - String.equal key_name value_name - | _ -> key == key' && value == value' - in - if key == key' && value == value' && shorthand == shorthand' then - prop - else - (loc, Init { key = key'; value = value'; shorthand = shorthand' }) - | (loc, Method { key; value = fn }) -> - let key' = this#object_key key in - let fn' = map_loc this#function_expression_or_method fn in - if key == key' && fn == fn' then - prop - else - (loc, Method { key = key'; value = fn' }) - | (loc, Get { key; value = fn; comments }) -> - let key' = this#object_key key in - let fn' = map_loc this#function_expression_or_method fn in - let comments' = this#syntax_opt comments in - if key == key' && fn == fn' && comments == comments' then - prop - else - (loc, Get { key = key'; value = fn'; comments = comments' }) - | (loc, Set { key; value = fn; comments }) -> - let key' = this#object_key key in - let fn' = map_loc this#function_expression_or_method fn in - let comments' = this#syntax_opt comments in - if key == key' && fn == fn' && comments == comments' then - prop - else - (loc, Set { key = key'; value = fn'; comments = comments' }) - - method object_key (key : ('loc, 'loc) Ast.Expression.Object.Property.key) = - let open Ast.Expression.Object.Property in - match key with - | Literal literal -> id this#object_key_literal literal key (fun lit -> Literal lit) - | Identifier ident -> id this#object_key_identifier ident key (fun ident -> Identifier ident) - | PrivateName ident -> id this#private_name ident key (fun ident -> PrivateName ident) - | Computed computed -> id this#object_key_computed computed key (fun expr -> Computed expr) - - method object_key_literal (literal : 'loc * 'loc Ast.Literal.t) = - let (loc, lit) = literal in - id_loc this#literal loc lit literal (fun lit -> (loc, lit)) - - method object_key_identifier (ident : ('loc, 'loc) Ast.Identifier.t) = this#identifier ident - - method object_key_computed (key : ('loc, 'loc) Ast.ComputedKey.t) = this#computed_key key - - method opaque_type _loc (otype : ('loc, 'loc) Ast.Statement.OpaqueType.t) = - let open Ast.Statement.OpaqueType in - let { id; tparams; impltype; supertype; comments } = otype in - let id' = this#binding_type_identifier id in - let tparams' = map_opt this#type_params tparams in - let impltype' = map_opt this#type_ impltype in - let supertype' = map_opt this#type_ supertype in - let comments' = this#syntax_opt comments in - if - id == id' - && impltype == impltype' - && tparams == tparams' - && impltype == impltype' - && supertype == supertype' - && comments == comments' - then - otype - else - { - id = id'; - tparams = tparams'; - impltype = impltype'; - supertype = supertype'; - comments = comments'; - } - - method function_param_pattern (expr : ('loc, 'loc) Ast.Pattern.t) = - this#binding_pattern ~kind:Ast.Statement.VariableDeclaration.Let expr - - method variable_declarator_pattern ~kind (expr : ('loc, 'loc) Ast.Pattern.t) = - this#binding_pattern ~kind expr - - method catch_clause_pattern (expr : ('loc, 'loc) Ast.Pattern.t) = - this#binding_pattern ~kind:Ast.Statement.VariableDeclaration.Let expr - - method for_in_assignment_pattern (expr : ('loc, 'loc) Ast.Pattern.t) = - this#assignment_pattern expr - - method for_of_assignment_pattern (expr : ('loc, 'loc) Ast.Pattern.t) = - this#assignment_pattern expr - - method binding_pattern - ?(kind = Ast.Statement.VariableDeclaration.Var) (expr : ('loc, 'loc) Ast.Pattern.t) = - this#pattern ~kind expr - - method assignment_pattern (expr : ('loc, 'loc) Ast.Pattern.t) = this#pattern expr - - (* NOTE: Patterns are highly overloaded. A pattern can be a binding pattern, - which has a kind (Var/Let/Const, with Var being the default for all pre-ES5 - bindings), or an assignment pattern, which has no kind. Subterms that are - patterns inherit the kind (or lack thereof). *) - method pattern ?kind (expr : ('loc, 'loc) Ast.Pattern.t) = - let open Ast.Pattern in - let (loc, patt) = expr in - let patt' = - match patt with - | Object { Object.properties; annot; comments } -> - let properties' = map_list (this#pattern_object_p ?kind) properties in - let annot' = this#type_annotation_hint annot in - let comments' = this#syntax_opt comments in - if properties' == properties && annot' == annot && comments' == comments then - patt - else - Object { Object.properties = properties'; annot = annot'; comments = comments' } - | Array { Array.elements; annot; comments } -> - let elements' = map_list (this#pattern_array_e ?kind) elements in - let annot' = this#type_annotation_hint annot in - let comments' = this#syntax_opt comments in - if comments == comments' && elements' == elements && annot' == annot then - patt - else - Array { Array.elements = elements'; annot = annot'; comments = comments' } - | Identifier { Identifier.name; annot; optional } -> - let name' = this#pattern_identifier ?kind name in - let annot' = this#type_annotation_hint annot in - if name == name' && annot == annot' then - patt - else - Identifier { Identifier.name = name'; annot = annot'; optional } - | Expression e -> id this#pattern_expression e patt (fun e -> Expression e) - in - if patt == patt' then - expr - else - (loc, patt') - - method pattern_identifier ?kind (ident : ('loc, 'loc) Ast.Identifier.t) = - ignore kind; - this#identifier ident - - method pattern_literal ?kind loc (expr : 'loc Ast.Literal.t) = - ignore kind; - this#literal loc expr - - method pattern_object_p ?kind (p : ('loc, 'loc) Ast.Pattern.Object.property) = - let open Ast.Pattern.Object in - match p with - | Property prop -> id (this#pattern_object_property ?kind) prop p (fun prop -> Property prop) - | RestElement prop -> - id (this#pattern_object_rest_property ?kind) prop p (fun prop -> RestElement prop) - - method pattern_object_property ?kind (prop : ('loc, 'loc) Ast.Pattern.Object.Property.t) = - let open Ast.Pattern.Object.Property in - let (loc, { key; pattern; default; shorthand }) = prop in - let key' = this#pattern_object_property_key ?kind key in - let pattern' = this#pattern_object_property_pattern ?kind pattern in - let default' = map_opt this#expression default in - let shorthand' = - (* Try to figure out if shorthand should still be true--if - key and value change differently, it should become false *) - shorthand - && - match (key', pattern') with - | ( Identifier (_, { Ast.Identifier.name = key_name; _ }), - ( _, - Ast.Pattern.Identifier - { Ast.Pattern.Identifier.name = (_, { Ast.Identifier.name = value_name; _ }); _ } - ) - ) -> - String.equal key_name value_name - | _ -> key == key' && pattern == pattern' - in - if key' == key && pattern' == pattern && default' == default && shorthand == shorthand' then - prop - else - (loc, { key = key'; pattern = pattern'; default = default'; shorthand = shorthand' }) - - method pattern_object_property_key ?kind (key : ('loc, 'loc) Ast.Pattern.Object.Property.key) = - let open Ast.Pattern.Object.Property in - match key with - | Literal lit -> - id (this#pattern_object_property_literal_key ?kind) lit key (fun lit' -> Literal lit') - | Identifier identifier -> - id (this#pattern_object_property_identifier_key ?kind) identifier key (fun id' -> - Identifier id' - ) - | Computed expr -> - id (this#pattern_object_property_computed_key ?kind) expr key (fun expr' -> Computed expr') - - method pattern_object_property_literal_key ?kind (literal : 'loc * 'loc Ast.Literal.t) = - let (loc, key) = literal in - id_loc (this#pattern_literal ?kind) loc key literal (fun key' -> (loc, key')) - - method pattern_object_property_identifier_key ?kind (key : ('loc, 'loc) Ast.Identifier.t) = - this#pattern_identifier ?kind key - - method pattern_object_property_computed_key ?kind (key : ('loc, 'loc) Ast.ComputedKey.t) = - ignore kind; - this#computed_key key - - method pattern_object_rest_property ?kind (prop : ('loc, 'loc) Ast.Pattern.RestElement.t) = - let open Ast.Pattern.RestElement in - let (loc, { argument; comments }) = prop in - let argument' = this#pattern_object_rest_property_pattern ?kind argument in - let comments' = this#syntax_opt comments in - if argument' == argument && comments == comments' then - prop - else - (loc, { argument = argument'; comments = comments' }) - - method pattern_object_property_pattern ?kind (expr : ('loc, 'loc) Ast.Pattern.t) = - this#pattern ?kind expr - - method pattern_object_rest_property_pattern ?kind (expr : ('loc, 'loc) Ast.Pattern.t) = - this#pattern ?kind expr - - method pattern_array_e ?kind (e : ('loc, 'loc) Ast.Pattern.Array.element) = - let open Ast.Pattern.Array in - match e with - | Hole _ -> e - | Element elem -> id (this#pattern_array_element ?kind) elem e (fun elem -> Element elem) - | RestElement elem -> - id (this#pattern_array_rest_element ?kind) elem e (fun elem -> RestElement elem) - - method pattern_array_element ?kind (elem : ('loc, 'loc) Ast.Pattern.Array.Element.t) = - let open Ast.Pattern.Array.Element in - let (loc, { argument; default }) = elem in - let argument' = this#pattern_array_element_pattern ?kind argument in - let default' = map_opt this#expression default in - if argument == argument' && default == default' then - elem - else - (loc, { argument = argument'; default = default' }) - - method pattern_array_element_pattern ?kind (patt : ('loc, 'loc) Ast.Pattern.t) = - this#pattern ?kind patt - - method pattern_array_rest_element ?kind (elem : ('loc, 'loc) Ast.Pattern.RestElement.t) = - let open Ast.Pattern.RestElement in - let (loc, { argument; comments }) = elem in - let argument' = this#pattern_array_rest_element_pattern ?kind argument in - let comments' = this#syntax_opt comments in - if argument' == argument && comments == comments' then - elem - else - (loc, { argument = argument'; comments = comments' }) - - method pattern_array_rest_element_pattern ?kind (expr : ('loc, 'loc) Ast.Pattern.t) = - this#pattern ?kind expr - - method pattern_expression (expr : ('loc, 'loc) Ast.Expression.t) = this#expression expr - - method predicate (pred : ('loc, 'loc) Ast.Type.Predicate.t) = - let open Ast.Type.Predicate in - let (loc, { kind; comments }) = pred in - let kind' = - match kind with - | Inferred -> kind - | Declared expr -> id this#expression expr kind (fun expr' -> Declared expr') - in - let comments' = this#syntax_opt comments in - if kind == kind' && comments == comments' then - pred - else - (loc, { kind = kind'; comments = comments' }) - - method predicate_expression (expr : ('loc, 'loc) Ast.Expression.t) = this#expression expr - - method function_rest_param (expr : ('loc, 'loc) Ast.Function.RestParam.t) = - let open Ast.Function.RestParam in - let (loc, { argument; comments }) = expr in - let argument' = this#function_param_pattern argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - expr - else - (loc, { argument = argument'; comments = comments' }) - - method return _loc (stmt : ('loc, 'loc) Ast.Statement.Return.t) = - let open Ast.Statement.Return in - let { argument; comments; return_out } = stmt in - let argument' = map_opt this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - stmt - else - { argument = argument'; comments = comments'; return_out } - - method sequence _loc (expr : ('loc, 'loc) Ast.Expression.Sequence.t) = - let open Ast.Expression.Sequence in - let { expressions; comments } = expr in - let expressions' = map_list this#expression expressions in - let comments' = this#syntax_opt comments in - if expressions == expressions' && comments == comments' then - expr - else - { expressions = expressions'; comments = comments' } - - method toplevel_statement_list (stmts : ('loc, 'loc) Ast.Statement.t list) = - this#statement_list stmts - - method statement_list (stmts : ('loc, 'loc) Ast.Statement.t list) = - map_list_multiple this#statement_fork_point stmts - - method statement_fork_point (stmt : ('loc, 'loc) Ast.Statement.t) = [this#statement stmt] - - method spread_element (expr : ('loc, 'loc) Ast.Expression.SpreadElement.t) = - let open Ast.Expression.SpreadElement in - let (loc, { argument; comments }) = expr in - let argument' = this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - expr - else - (loc, { argument = argument'; comments = comments' }) - - method spread_property (expr : ('loc, 'loc) Ast.Expression.Object.SpreadProperty.t) = - let open Ast.Expression.Object.SpreadProperty in - let (loc, { argument; comments }) = expr in - let argument' = this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - expr - else - (loc, { argument = argument'; comments = comments' }) - - method super_expression _loc (expr : 'loc Ast.Expression.Super.t) = - let open Ast.Expression.Super in - let { comments } = expr in - let comments' = this#syntax_opt comments in - if comments == comments' then - expr - else - { comments = comments' } - - method switch _loc (switch : ('loc, 'loc) Ast.Statement.Switch.t) = - let open Ast.Statement.Switch in - let { discriminant; cases; comments; exhaustive_out } = switch in - let discriminant' = this#expression discriminant in - let cases' = map_list this#switch_case cases in - let comments' = this#syntax_opt comments in - if discriminant == discriminant' && cases == cases' && comments == comments' then - switch - else - { discriminant = discriminant'; cases = cases'; comments = comments'; exhaustive_out } - - method switch_case (case : ('loc, 'loc) Ast.Statement.Switch.Case.t) = - let open Ast.Statement.Switch.Case in - let (loc, { test; consequent; comments }) = case in - let test' = map_opt this#expression test in - let consequent' = this#statement_list consequent in - let comments' = this#syntax_opt comments in - if test == test' && consequent == consequent' && comments == comments' then - case - else - (loc, { test = test'; consequent = consequent'; comments = comments' }) - - method tagged_template _loc (expr : ('loc, 'loc) Ast.Expression.TaggedTemplate.t) = - let open Ast.Expression.TaggedTemplate in - let { tag; quasi; comments } = expr in - let tag' = this#expression tag in - let quasi' = map_loc this#template_literal quasi in - let comments' = this#syntax_opt comments in - if tag == tag' && quasi == quasi' && comments == comments' then - expr - else - { tag = tag'; quasi = quasi'; comments = comments' } - - method template_literal _loc (expr : ('loc, 'loc) Ast.Expression.TemplateLiteral.t) = - let open Ast.Expression.TemplateLiteral in - let { quasis; expressions; comments } = expr in - let quasis' = map_list this#template_literal_element quasis in - let expressions' = map_list this#expression expressions in - let comments' = this#syntax_opt comments in - if quasis == quasis' && expressions == expressions' && comments == comments' then - expr - else - { quasis = quasis'; expressions = expressions'; comments = comments' } - - (* TODO *) - method template_literal_element (elem : 'loc Ast.Expression.TemplateLiteral.Element.t) = elem - - method this_expression _loc (expr : 'loc Ast.Expression.This.t) = - let open Ast.Expression.This in - let { comments } = expr in - let comments' = this#syntax_opt comments in - if comments == comments' then - expr - else - { comments = comments' } - - method throw _loc (stmt : ('loc, 'loc) Ast.Statement.Throw.t) = - let open Ast.Statement.Throw in - let { argument; comments } = stmt in - let argument' = this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - stmt - else - { argument = argument'; comments = comments' } - - method try_catch _loc (stmt : ('loc, 'loc) Ast.Statement.Try.t) = - let open Ast.Statement.Try in - let { block; handler; finalizer; comments } = stmt in - let block' = map_loc this#block block in - let handler' = - match handler with - | Some (loc, clause) -> - id_loc this#catch_clause loc clause handler (fun clause -> Some (loc, clause)) - | None -> handler - in - let finalizer' = - match finalizer with - | Some (finalizer_loc, block) -> - id_loc this#block finalizer_loc block finalizer (fun block -> Some (finalizer_loc, block)) - | None -> finalizer - in - let comments' = this#syntax_opt comments in - if block == block' && handler == handler' && finalizer == finalizer' && comments == comments' - then - stmt - else - { block = block'; handler = handler'; finalizer = finalizer'; comments = comments' } - - method type_cast _loc (expr : ('loc, 'loc) Ast.Expression.TypeCast.t) = - let open Ast.Expression.TypeCast in - let { expression; annot; comments } = expr in - let expression' = this#expression expression in - let annot' = this#type_annotation annot in - let comments' = this#syntax_opt comments in - if expression' == expression && annot' == annot && comments' == comments then - expr - else - { expression = expression'; annot = annot'; comments = comments' } - - method unary_expression _loc (expr : ('loc, 'loc) Flow_ast.Expression.Unary.t) = - let open Flow_ast.Expression.Unary in - let { argument; operator = _; comments } = expr in - let argument' = this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - expr - else - { expr with argument = argument'; comments = comments' } - - method update_expression _loc (expr : ('loc, 'loc) Ast.Expression.Update.t) = - let open Ast.Expression.Update in - let { argument; operator = _; prefix = _; comments } = expr in - let argument' = this#expression argument in - let comments' = this#syntax_opt comments in - if argument == argument' && comments == comments' then - expr - else - { expr with argument = argument'; comments = comments' } - - method variable_declaration _loc (decl : ('loc, 'loc) Ast.Statement.VariableDeclaration.t) = - let open Ast.Statement.VariableDeclaration in - let { declarations; kind; comments } = decl in - let decls' = map_list (this#variable_declarator ~kind) declarations in - let comments' = this#syntax_opt comments in - if declarations == decls' && comments == comments' then - decl - else - { declarations = decls'; kind; comments = comments' } - - method variable_declarator - ~kind (decl : ('loc, 'loc) Ast.Statement.VariableDeclaration.Declarator.t) = - let open Ast.Statement.VariableDeclaration.Declarator in - let (loc, { id; init }) = decl in - let id' = this#variable_declarator_pattern ~kind id in - let init' = map_opt this#expression init in - if id == id' && init == init' then - decl - else - (loc, { id = id'; init = init' }) - - method while_ _loc (stuff : ('loc, 'loc) Ast.Statement.While.t) = - let open Ast.Statement.While in - let { test; body; comments } = stuff in - let test' = this#predicate_expression test in - let body' = this#statement body in - let comments' = this#syntax_opt comments in - if test == test' && body == body' && comments == comments' then - stuff - else - { test = test'; body = body'; comments = comments' } - - method with_ _loc (stuff : ('loc, 'loc) Ast.Statement.With.t) = - let open Ast.Statement.With in - let { _object; body; comments } = stuff in - let _object' = this#expression _object in - let body' = this#statement body in - let comments' = this#syntax_opt comments in - if _object == _object' && body == body' && comments == comments' then - stuff - else - { _object = _object'; body = body'; comments = comments' } - - method type_alias _loc (stuff : ('loc, 'loc) Ast.Statement.TypeAlias.t) = - let open Ast.Statement.TypeAlias in - let { id; tparams; right; comments } = stuff in - let id' = this#binding_type_identifier id in - let tparams' = map_opt this#type_params tparams in - let right' = this#type_ right in - let comments' = this#syntax_opt comments in - if id == id' && right == right' && tparams == tparams' && comments == comments' then - stuff - else - { id = id'; tparams = tparams'; right = right'; comments = comments' } - - method yield _loc (expr : ('loc, 'loc) Ast.Expression.Yield.t) = - let open Ast.Expression.Yield in - let { argument; delegate; comments; result_out } = expr in - let argument' = map_opt this#expression argument in - let comments' = this#syntax_opt comments in - if comments == comments' && argument == argument' then - expr - else - { argument = argument'; delegate; comments = comments'; result_out } - end - -let fold_program (mappers : 'a mapper list) ast = - List.fold_left (fun ast (m : 'a mapper) -> m#program ast) ast mappers diff --git a/jscomp/js_parser/flow_ast_utils.ml b/jscomp/js_parser/flow_ast_utils.ml deleted file mode 100644 index cdaee7b..0000000 --- a/jscomp/js_parser/flow_ast_utils.ml +++ /dev/null @@ -1,339 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -open Flow_ast - -type 'loc binding = 'loc * string -type 'loc ident = 'loc * string -type 'loc source = 'loc * string - -let rec fold_bindings_of_pattern = - Pattern.( - let property f acc = - Object.( - function - | Property (_, { Property.pattern = p; _ }) - | RestElement (_, { RestElement.argument = p; comments = _ }) -> - fold_bindings_of_pattern f acc p - ) - in - let element f acc = - Array.( - function - | Hole _ -> acc - | Element (_, { Element.argument = p; default = _ }) - | RestElement (_, { RestElement.argument = p; comments = _ }) -> - fold_bindings_of_pattern f acc p - ) - in - fun f acc -> function - | (_, Identifier { Identifier.name; _ }) -> f acc name - | (_, Object { Object.properties; _ }) -> List.fold_left (property f) acc properties - | (_, Array { Array.elements; _ }) -> List.fold_left (element f) acc elements - (* This is for assignment and default param destructuring `[a.b=1]=c`, ignore these for now. *) - | (_, Expression _) -> acc - ) - -let fold_bindings_of_variable_declarations f acc declarations = - let open Flow_ast.Statement.VariableDeclaration in - List.fold_left - (fun acc -> function - | (_, { Declarator.id = pattern; _ }) -> - let has_anno = - (* Only the toplevel annotation in a pattern is meaningful *) - let open Flow_ast.Pattern in - match pattern with - | (_, Array { Array.annot = Flow_ast.Type.Available _; _ }) - | (_, Object { Object.annot = Flow_ast.Type.Available _; _ }) - | (_, Identifier { Identifier.annot = Flow_ast.Type.Available _; _ }) -> - true - | _ -> false - in - fold_bindings_of_pattern (f has_anno) acc pattern) - acc - declarations - -let partition_directives statements = - let open Flow_ast.Statement in - let rec helper directives = function - | ((_, Expression { Expression.directive = Some _; _ }) as directive) :: rest -> - helper (directive :: directives) rest - | rest -> (List.rev directives, rest) - in - helper [] statements - -let hoist_function_declarations stmts = - let open Flow_ast.Statement in - let (func_decs, other_stmts) = - List.partition - (function - (* function f() {} *) - | (_, FunctionDeclaration { Flow_ast.Function.id = Some _; _ }) - (* export function f() {} *) - | ( _, - ExportNamedDeclaration - { - ExportNamedDeclaration.declaration = - Some (_, FunctionDeclaration { Flow_ast.Function.id = Some _; _ }); - _; - } - ) - (* export default function f() {} *) - | ( _, - ExportDefaultDeclaration - { - ExportDefaultDeclaration.declaration = - ExportDefaultDeclaration.Declaration - (_, FunctionDeclaration { Flow_ast.Function.id = Some _; _ }); - _; - } - ) - (* declare function f(): void; *) - | (_, DeclareFunction _) - (* declare export function f(): void; *) - | ( _, - DeclareExportDeclaration DeclareExportDeclaration.{ declaration = Some (Function _); _ } - ) -> - true - | _ -> false) - stmts - in - func_decs @ other_stmts - -let negate_number_literal (value, raw) = - let raw_len = String.length raw in - let raw = - if raw_len > 0 && raw.[0] = '-' then - String.sub raw 1 (raw_len - 1) - else - "-" ^ raw - in - (~-.value, raw) - -let is_call_to_invariant callee = - match callee with - | (_, Expression.Identifier (_, { Identifier.name = "invariant"; _ })) -> true - | _ -> false - -let is_call_to_is_array callee = - match callee with - | ( _, - Flow_ast.Expression.Member - { - Flow_ast.Expression.Member._object = - ( _, - Flow_ast.Expression.Identifier - (_, { Flow_ast.Identifier.name = "Array"; comments = _ }) - ); - property = - Flow_ast.Expression.Member.PropertyIdentifier - (_, { Flow_ast.Identifier.name = "isArray"; comments = _ }); - comments = _; - } - ) -> - true - | _ -> false - -let is_call_to_object_dot_freeze callee = - match callee with - | ( _, - Flow_ast.Expression.Member - { - Flow_ast.Expression.Member._object = - ( _, - Flow_ast.Expression.Identifier - (_, { Flow_ast.Identifier.name = "Object"; comments = _ }) - ); - property = - Flow_ast.Expression.Member.PropertyIdentifier - (_, { Flow_ast.Identifier.name = "freeze"; comments = _ }); - comments = _; - } - ) -> - true - | _ -> false - -let is_call_to_object_static_method callee = - match callee with - | ( _, - Flow_ast.Expression.Member - { - Flow_ast.Expression.Member._object = - ( _, - Flow_ast.Expression.Identifier - (_, { Flow_ast.Identifier.name = "Object"; comments = _ }) - ); - property = Flow_ast.Expression.Member.PropertyIdentifier _; - comments = _; - } - ) -> - true - | _ -> false - -let loc_of_statement = fst -let loc_of_expression = fst -let loc_of_pattern = fst -let loc_of_ident = fst -let name_of_ident (_, { Identifier.name; comments = _ }) = name -let source_of_ident (loc, { Identifier.name; comments = _ }) = (loc, name) -let ident_of_source ?comments (loc, name) = (loc, { Identifier.name; comments }) -let mk_comments ?(leading = []) ?(trailing = []) a = { Syntax.leading; trailing; internal = a } - -let mk_comments_opt ?(leading = []) ?(trailing = []) () = - match (leading, trailing) with - | ([], []) -> None - | (_, _) -> Some (mk_comments ~leading ~trailing ()) - -let mk_comments_with_internal_opt ?(leading = []) ?(trailing = []) ~internal () = - match (leading, trailing, internal) with - | ([], [], []) -> None - | _ -> Some (mk_comments ~leading ~trailing internal) - -let merge_comments ~inner ~outer = - let open Syntax in - match (inner, outer) with - | (None, c) - | (c, None) -> - c - | (Some inner, Some outer) -> - mk_comments_opt - ~leading:(outer.leading @ inner.leading) - ~trailing:(inner.trailing @ outer.trailing) - () - -let merge_comments_with_internal ~inner ~outer = - match (inner, outer) with - | (inner, None) -> inner - | (None, Some { Syntax.leading; trailing; _ }) -> - mk_comments_with_internal_opt ~leading ~trailing ~internal:[] () - | ( Some { Syntax.leading = inner_leading; trailing = inner_trailing; internal }, - Some { Syntax.leading = outer_leading; trailing = outer_trailing; _ } - ) -> - mk_comments_with_internal_opt - ~leading:(outer_leading @ inner_leading) - ~trailing:(inner_trailing @ outer_trailing) - ~internal - () - -let split_comments comments = - match comments with - | None -> (None, None) - | Some { Syntax.leading; trailing; _ } -> - (mk_comments_opt ~leading (), mk_comments_opt ~trailing ()) - -let string_of_assignment_operator op = - let open Flow_ast.Expression.Assignment in - match op with - | PlusAssign -> "+=" - | MinusAssign -> "-=" - | MultAssign -> "*=" - | ExpAssign -> "**=" - | DivAssign -> "/=" - | ModAssign -> "%=" - | LShiftAssign -> "<<=" - | RShiftAssign -> ">>=" - | RShift3Assign -> ">>>=" - | BitOrAssign -> "|=" - | BitXorAssign -> "^=" - | BitAndAssign -> "&=" - | NullishAssign -> "??=" - | AndAssign -> "&&=" - | OrAssign -> "||=" - -let string_of_binary_operator op = - let open Flow_ast.Expression.Binary in - match op with - | Equal -> "==" - | NotEqual -> "!=" - | StrictEqual -> "===" - | StrictNotEqual -> "!==" - | LessThan -> "<" - | LessThanEqual -> "<=" - | GreaterThan -> ">" - | GreaterThanEqual -> ">=" - | LShift -> "<<" - | RShift -> ">>" - | RShift3 -> ">>>" - | Plus -> "+" - | Minus -> "-" - | Mult -> "*" - | Exp -> "**" - | Div -> "/" - | Mod -> "%" - | BitOr -> "|" - | Xor -> "^" - | BitAnd -> "&" - | In -> "in" - | Instanceof -> "instanceof" - -module ExpressionSort = struct - type t = - | Array - | ArrowFunction - | Assignment - | Binary - | Call - | Class - | Comprehension - | Conditional - | Function - | Generator - | Identifier - | Import - | JSXElement - | JSXFragment - | Literal - | Logical - | Member - | MetaProperty - | New - | Object - | OptionalCall - | OptionalMember - | Sequence - | Super - | TaggedTemplate - | TemplateLiteral - | This - | TypeCast - | Unary - | Update - | Yield - - let to_string = function - | Array -> "array" - | ArrowFunction -> "arrow function" - | Assignment -> "assignment expression" - | Binary -> "binary expression" - | Call -> "call expression" - | Class -> "class" - | Comprehension -> "comprehension expression" - | Conditional -> "conditional expression" - | Function -> "function" - | Generator -> "generator" - | Identifier -> "identifier" - | Import -> "import expression" - | JSXElement -> "JSX element" - | JSXFragment -> "JSX fragment" - | Literal -> "literal" - | Logical -> "logical expression" - | Member -> "member expression" - | MetaProperty -> "metaproperty expression" - | New -> "new expression" - | Object -> "object" - | OptionalCall -> "optional call expression" - | OptionalMember -> "optional member expression" - | Sequence -> "sequence" - | Super -> "`super` reference" - | TaggedTemplate -> "tagged template expression" - | TemplateLiteral -> "template literal" - | This -> "`this` reference" - | TypeCast -> "type cast" - | Unary -> "unary expression" - | Update -> "update expression" - | Yield -> "yield expression" -end diff --git a/jscomp/js_parser/flow_ast_utils.mli b/jscomp/js_parser/flow_ast_utils.mli deleted file mode 100644 index 2155346..0000000 --- a/jscomp/js_parser/flow_ast_utils.mli +++ /dev/null @@ -1,128 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -type 'loc binding = 'loc * string - -type 'loc ident = 'loc * string - -type 'loc source = 'loc * string - -val fold_bindings_of_pattern : - ('a -> ('m, 't) Flow_ast.Identifier.t -> 'a) -> 'a -> ('m, 't) Flow_ast.Pattern.t -> 'a - -val fold_bindings_of_variable_declarations : - (bool -> 'a -> ('m, 't) Flow_ast.Identifier.t -> 'a) -> - 'a -> - ('m, 't) Flow_ast.Statement.VariableDeclaration.Declarator.t list -> - 'a - -val partition_directives : - (Loc.t, Loc.t) Flow_ast.Statement.t list -> - (Loc.t, Loc.t) Flow_ast.Statement.t list * (Loc.t, Loc.t) Flow_ast.Statement.t list - -val hoist_function_declarations : - ('a, 'b) Flow_ast.Statement.t list -> ('a, 'b) Flow_ast.Statement.t list - -val is_call_to_invariant : ('a, 'b) Flow_ast.Expression.t -> bool - -val is_call_to_is_array : ('a, 'b) Flow_ast.Expression.t -> bool - -val is_call_to_object_dot_freeze : ('a, 'b) Flow_ast.Expression.t -> bool - -val is_call_to_object_static_method : ('a, 'b) Flow_ast.Expression.t -> bool - -val negate_number_literal : float * string -> float * string - -val loc_of_expression : ('a, 'a) Flow_ast.Expression.t -> 'a - -val loc_of_statement : ('a, 'a) Flow_ast.Statement.t -> 'a - -val loc_of_pattern : ('a, 'a) Flow_ast.Pattern.t -> 'a - -val loc_of_ident : ('a, 'a) Flow_ast.Identifier.t -> 'a - -val name_of_ident : ('loc, 'a) Flow_ast.Identifier.t -> string - -val source_of_ident : ('a, 'a) Flow_ast.Identifier.t -> 'a source - -val ident_of_source : - ?comments:('a, unit) Flow_ast.Syntax.t -> 'a source -> ('a, 'a) Flow_ast.Identifier.t - -val mk_comments : - ?leading:'loc Flow_ast.Comment.t list -> - ?trailing:'loc Flow_ast.Comment.t list -> - 'a -> - ('loc, 'a) Flow_ast.Syntax.t - -val mk_comments_opt : - ?leading:'loc Flow_ast.Comment.t list -> - ?trailing:'loc Flow_ast.Comment.t list -> - unit -> - ('loc, unit) Flow_ast.Syntax.t option - -val mk_comments_with_internal_opt : - ?leading:'loc Flow_ast.Comment.t list -> - ?trailing:'loc Flow_ast.Comment.t list -> - internal:'loc Flow_ast.Comment.t list -> - unit -> - ('loc, 'loc Flow_ast.Comment.t list) Flow_ast.Syntax.t option - -val merge_comments : - inner:('M, unit) Flow_ast.Syntax.t option -> - outer:('M, unit) Flow_ast.Syntax.t option -> - ('M, unit) Flow_ast.Syntax.t option - -val merge_comments_with_internal : - inner:('M, 'loc Flow_ast.Comment.t list) Flow_ast.Syntax.t option -> - outer:('M, 'a) Flow_ast.Syntax.t option -> - ('M, 'loc Flow_ast.Comment.t list) Flow_ast.Syntax.t option - -val split_comments : - ('loc, unit) Flow_ast.Syntax.t option -> - ('loc, unit) Flow_ast.Syntax.t option * ('loc, unit) Flow_ast.Syntax.t option - -module ExpressionSort : sig - type t = - | Array - | ArrowFunction - | Assignment - | Binary - | Call - | Class - | Comprehension - | Conditional - | Function - | Generator - | Identifier - | Import - | JSXElement - | JSXFragment - | Literal - | Logical - | Member - | MetaProperty - | New - | Object - | OptionalCall - | OptionalMember - | Sequence - | Super - | TaggedTemplate - | TemplateLiteral - | This - | TypeCast - | Unary - | Update - | Yield - - - val to_string : t -> string -end - -val string_of_assignment_operator : Flow_ast.Expression.Assignment.operator -> string - -val string_of_binary_operator : Flow_ast.Expression.Binary.operator -> string diff --git a/jscomp/js_parser/flow_lexer.ml b/jscomp/js_parser/flow_lexer.ml deleted file mode 100644 index bf4c9f4..0000000 --- a/jscomp/js_parser/flow_lexer.ml +++ /dev/null @@ -1,13521 +0,0 @@ - -let __sedlex_table_58 = - "\001\001\001\001\001\001\001\001\001\001\000\001\001" -let __sedlex_table_2 = - "\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" -let __sedlex_table_17 = - "\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" -let __sedlex_table_28 = - "\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" -let __sedlex_table_41 = - "\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\003\004\004\004\004\004\004\004\004\004\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" -let __sedlex_table_52 = - "\001\000\000\002\003\003\003\003\003\003\003\003\003" -let __sedlex_table_70 = - "\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\003\003\003\003\003\003\003\003\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" -let __sedlex_table_47 = - "\001\001\001\001\001\001\001\001\001\001\002\001\001\003\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\004" -let __sedlex_table_57 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_29 = - "\001\002\000\003\004\004\004\004\004\004\004\004\004" -let __sedlex_table_30 = - "\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_42 = - "\001\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003" -let __sedlex_table_5 = "\001\002" -let __sedlex_table_3 = - "\001\001\001\001\001\001\001\001\001\001\000\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001" -let __sedlex_table_21 = - "\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_60 = - "\001\001\001\001\001\001\001\001\001\001\000\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_83 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\004\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\002\002\002\006\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\002\007" -let __sedlex_table_18 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_23 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_43 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\004\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\006\006\006\006\006\006\006\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\b\002\002\002\t\002\002\002\002\002\002\002\n\002\002\002\011\002\012\r\014\002\015" -let __sedlex_table_76 = - "\001\001\001\001\001\001\001\001\001\002\003\002\002\004\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\002\001\001\001\001\001\001\001\001\001\001\001\001\001\001\005\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\006\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\002\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\002\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_82 = - "\001\000\001\000\000\002\003\003\003\003\003\003\003\003\003" -let __sedlex_table_10 = "\001\001\001\001\001\001\001\001\001\001\000\002" -let __sedlex_table_12 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001" -let __sedlex_table_33 = - "\001\001\001\001\001\001\001\001\001\001\000\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_45 = - "\001\001\001\001\001\001\001\001\001\001\002\001\001\003" -let __sedlex_table_78 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\004\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\006" -let __sedlex_table_88 = - "\001\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003" -let __sedlex_table_11 = - "\001\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\000\002\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_14 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\002\002\002\002\002\002\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\002\002\002\002\002\002\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_16 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\003\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_22 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_27 = - "\001\000\000\000\000\000\000\000\000\000\002\000\003\003\003\003\003\003\003\003\003\003\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\004\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_32 = - "\001\000\000\000\000\000\000\000\000\000\002\000\003\003\003\003\003\003\003\003\003\003\000\000\000\000\000\000\000\001\001\001\001\004\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\005\000\001\001\001\001\004\001\001\001\001\001\001\001\001\006\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_38 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_46 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\001\001\001\001\003\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\003\001\001\001\001\001\001\001\001\004\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_49 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\001\001\001\001\003\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\004\000\001\001\001\001\003\001\001\001\001\001\001\001\001\005\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_55 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_59 = - "\001\000\000\000\000\000\000\000\000\000\002\000\003\003\003\003\003\003\003\003\004\004\000\000\000\000\000\000\000\001\005\001\001\006\001\001\001\001\001\001\001\001\001\007\001\001\001\001\001\001\001\001\b\001\001\000\000\000\000\000\000\001\005\001\001\006\001\001\001\001\001\001\001\001\t\007\001\001\001\001\001\001\001\001\b\001\001" -let __sedlex_table_62 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_63 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\003\000\001\001\001\001\001\001\001\001\001\001\001\001\001\004\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_65 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\003\000\001\001\001\001\001\001\001\001\001\001\001\001\001\004\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_68 = - "\001\000\000\000\000\000\000\000\000\000\002\000\003\003\003\003\003\003\003\003\003\003\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\004\000\001\001\001\001\001\001\001\001\001\001\001\001\001\005\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_73 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\003\000\001\001\001\001\001\001\001\001\001\001\001\001\001\004\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_75 = - "\001\000\000\000\000\000\000\000\000\000\002\000\003\003\003\003\003\003\003\003\004\004\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\005\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_77 = - "\001\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\002\002\002\002\002\002\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\003\000\002\002\002\002\002\002\001\001\001\001\001\001\001\004\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_89 = - "\001\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_1 = - "\001\002\002\002\002\002\002\002\002\002\003\004\003\003\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\006\007\b\t\n\011\007\012\r\014\015\016\017\018\019\020\021\021\021\021\021\021\021\021\021\022\023\024\025\026\027\028\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\029\030\031 \t!\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\"#$%\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\t\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\002\002\002\002\002\002\002\t\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\002\t\t\002\002\t\t\t\t\002\t\002\002\002\002\002\002\t\002\t\t\t\002\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\002\002\002\002\002\002\t\t\002\002\002\002\002\002\002\002\002\002\t\t\t\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\t\t\002\002\002\002\t\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\t\002\002\002\002\002\002\002\002\002\t\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\t\t\t\t\t\t\t\t\002\002\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\002\t\002\002\002\t\t\t\t\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\t\t\t\t\t\t\002\002\002\002\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\002\t\t\002\t\t\002\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\002\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\002\t\t\002\t\t\t\t\t\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\002\002\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\002\t\t\002\t\t\t\t\t\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\t\t\t\t\t\t\002\002\002\t\t\t\002\t\t\t\t\002\002\002\t\t\002\t\002\t\t\002\002\002\t\t\002\002\002\t\t\t\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\002\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\002\002\t\002\002\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\t\t\t\t\t\t\t\t\002\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\002\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\t\t\t\002\002\002\002\002\002\002\002\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\002\t\002\002\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\t\002\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\002\t\t\t\t\t\t\t\t\t\t\002\t\t\002\002\002\002\002\002\002\002\002\t\002\002\t\t\t\t\t\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\002\002\002\002\t\t\t\t\002\002\002\t\002\002\002\t\t\002\002\002\002\002\002\002\t\t\t\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\002\002\002\002\002\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\002\002\t\t\t\t\t\t\t\002\t\002\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\002\002\t\t\t\t\t\t\t\002\t\002\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\t\t\t\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\003\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\002\t\t\t\t\t\t\002\t\t\002\002\002\t\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\t\t\t\002\002\t\t\t\t\t\t\t\t\002\t\002\t\002\t\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\t\002\t\t\t\t\t\t\t\002\t\002\002\002\t\t\t\002\t\t\t\t\t\t\t\002\002\002\t\t\t\t\002\002\t\t\t\t\t\t\002\002\002\002\t\t\t\t\t\t\t\t\t\t\t\t\t\002\002\002\002\002\t\t\t\002\t\t\t\t\t\t\t\002\002\002" -let __sedlex_table_61 = - "\001\002\002\002\002\002\002\002\002\002\003\004\003\003\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\002\002\002\002\002\006\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002" -let __sedlex_table_66 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\004" -let __sedlex_table_72 = "\001\000\000\000\000\002" -let __sedlex_table_74 = - "\001\002\002\002\002\002\002\002\002\002\003\004\003\003\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\006\002\007\b\t\006\n\011\012\r\014\015\016\017\018\019\019\019\019\019\019\019\019\019\020\021\022\023\024\025\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\026\027\028\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\029\030\031\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\002\002\002\002\002\002\002\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\002\007\007\002\002\007\007\007\007\002\007\002\002\002\002\002\002\007\002\007\007\007\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\002\002\002\002\002\002\002\002\002\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\002\002\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\002\002\002\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\007\007\007\007\007\007\002\002\002\002\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\007\002\007\007\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\007\002\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\002\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\007\002\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\007\007\007\007\007\007\002\002\002\007\007\007\002\007\007\007\007\002\002\002\007\007\002\007\002\007\007\002\002\002\007\007\002\002\002\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\007\002\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\002\007\002\002\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\002\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\007\007\007\007\007\007\007\007\007\007\002\007\007\002\002\002\002\002\002\002\002\002\007\002\002\007\007\007\007\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\002\002\002\002\007\007\007\007\002\002\002\007\002\002\002\007\007\002\002\002\002\002\002\002\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\002\002\002\002\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\002\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\002\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\003\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\002\007\007\007\007\007\007\002\007\007\002\002\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\002\007\002\007\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\002\002\002\007\007\007\002\007\007\007\007\007\007\007\002\002\002\007\007\007\007\002\002\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\007\007\007\002\007\007\007\007\007\007\007\002\002\002" -let __sedlex_table_91 = - "\001\002\002\002\002\002\002\002\002\002\003\004\003\003\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\006\002\007\002\002\006\002\002\002\002\002\002\b\t\002\002\002\002\002\002\002\002\002\002\n\002\011\012\r\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\014\002\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\015\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\002\002\002\002\002\002\002\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\002\007\007\002\002\007\007\007\007\002\007\002\002\002\002\002\002\007\002\007\007\007\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\002\002\002\002\002\002\002\002\002\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\002\002\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\002\002\002\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\007\007\007\007\007\007\002\002\002\002\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\007\002\007\007\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\007\002\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\002\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\007\002\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\007\007\007\007\007\007\002\002\002\007\007\007\002\007\007\007\007\002\002\002\007\007\002\007\002\007\007\002\002\002\007\007\002\002\002\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\007\002\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\002\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\002\007\002\002\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\007\002\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\007\007\007\007\007\007\007\007\007\007\002\007\007\002\002\002\002\002\002\002\002\002\007\002\002\007\007\007\007\007\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\002\002\002\002\007\007\007\007\002\002\002\007\002\002\002\007\007\002\002\002\002\002\002\002\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\002\002\002\002\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\002\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\002\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\003\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\002\007\007\007\007\007\007\002\007\007\002\002\002\007\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\002\007\002\007\002\007\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\007\002\007\007\007\007\007\007\007\002\007\002\002\002\007\007\007\002\007\007\007\007\007\007\007\002\002\002\007\007\007\007\002\002\007\007\007\007\007\007\002\002\002\002\007\007\007\007\007\007\007\007\007\007\007\007\007\002\002\002\002\002\007\007\007\002\007\007\007\007\007\007\007\002\002\002" -let __sedlex_table_51 = "\001\000\000\002" -let __sedlex_table_8 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\004\002\002\002\002\004\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005" -let __sedlex_table_20 = - "\001\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003" -let __sedlex_table_69 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\004\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\006\007" -let __sedlex_table_15 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_48 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_81 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003\000\000\000\000\000\002" -let __sedlex_table_9 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003" -let __sedlex_table_26 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\001\001\001\001\001\001\000\000\000\000\000\000\000\003" -let __sedlex_table_35 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_67 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_36 = "\001\000\000\000\000\000\000\000\002" -let __sedlex_table_39 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\004\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\006\002\002\002\007" -let __sedlex_table_50 = - "\001\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\003" -let __sedlex_table_90 = - "\001\002\000\000\000\000\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\000\000\000\000\000\000\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002" -let __sedlex_table_37 = - "\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003" -let __sedlex_table_7 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001" -let __sedlex_table_13 = "\001\000\002\003\003\003\003\003\003\003\003\003" -let __sedlex_table_53 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\001\001\001\001\001\001" -let __sedlex_table_87 = - "\001\001\001\001\001\001\001\001\001\001\000\002\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001" -let __sedlex_table_34 = - "\001\001\001\001\001\001\001\001\001\001\000\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_54 = "\001\000\002\002\002\002\002\002\002\002\002\002" -let __sedlex_table_71 = - "\001\000\000\000\000\000\000\002\000\002\000\000\003\004\004\004\004\004\004\004\004\004\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_80 = "\001\001\001\001\001\001\001\001\002\002" -let __sedlex_table_4 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_79 = - "\001\002\002\002\002\002\002\002\002\002\002\003\002\002\004\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\005\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\006" -let __sedlex_table_84 = - "\001\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\002\002\002\003\003\003\003\003\003\003\003\003\003\002\002\002\002\002\002\002\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\002\004\002\002\003\002\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003" -let __sedlex_table_85 = - "\001\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\002\003\002\002\002\002\002\002\002\002\003\002\002\003\003\003\003\003\003\003\003\003\003\002\002\002\002\002\002\002\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\002\004\002\002\003\002\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003\003" -let __sedlex_table_64 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\002\000\000\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\001\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\000\000\000\000\000\000\000\001\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\000\001\001\000\000\001\001\001\001\000\001\000\000\000\000\000\000\001\000\001\001\001\000\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\001\001\001\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\001\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\001\000\000\000\000\000\000\000\000\000\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\001\001\001\001\001\001\001\001\000\000\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\000\001\000\000\000\001\001\001\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\000\001\001\000\001\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\000\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\000\001\001\000\001\001\001\001\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\000\000\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\000\001\001\000\001\001\001\001\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\001\001\001\001\001\001\000\000\000\001\001\001\000\001\001\001\001\000\000\000\001\001\000\001\000\001\001\000\000\000\001\001\000\000\000\001\001\001\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\000\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\000\000\001\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\001\001\001\001\001\001\001\001\000\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\000\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\001\001\001\000\000\000\000\000\000\000\000\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\000\001\000\000\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\001\000\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\000\001\001\001\001\001\001\001\001\001\001\000\001\001\000\000\000\000\000\000\000\000\000\001\000\000\001\001\001\001\001\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\001\001\001\001\000\000\000\001\000\000\000\001\001\000\000\000\000\000\000\000\001\001\001\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\000\000\000\000\000\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\000\000\001\001\001\001\001\001\001\000\001\000\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\000\000\001\001\001\001\001\001\001\000\001\000\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\001\001\001\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\000\001\001\001\001\001\001\000\001\001\000\000\000\001\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\001\001\001\000\000\001\001\001\001\001\001\001\001\000\001\000\001\000\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\000\001\000\000\000\001\001\001\000\001\001\001\001\001\001\001\000\000\000\001\001\001\001\000\000\001\001\001\001\001\001\000\000\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\001\001\001\000\001\001\001\001\001\001\001" -let __sedlex_table_86 = "\001\000\002" -let __sedlex_table_6 = - "\001\001\001\001\001\001\001\001\001\001\000\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001" -let __sedlex_table_24 = - "\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_31 = "\001\002\002\002\002\002\002\002\002\002" -let __sedlex_table_25 = - "\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\003" -let __sedlex_table_56 = - "\001\001\001\001\001\001\001\001\001\001\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\001\001\001\001\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_44 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_19 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_table_40 = - "\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\002" -let __sedlex_partition_94 c = - if c <= 120 then (-1) else if c <= 121 then 0 else (-1) -let __sedlex_partition_50 c = - if c <= 8191 - then (Char.code (String.unsafe_get __sedlex_table_1 (c - (-1)))) - 1 - else - if c <= 194559 - then - (if c <= 69599 - then - (if c <= 43711 - then - (if c <= 12703 - then - (if c <= 11519 - then - (if c <= 8489 - then - (if c <= 8454 - then - (if c <= 8304 - then - (if c <= 8238 - then - (if c <= 8231 - then (if c <= 8202 then 2 else 1) - else if c <= 8233 then 3 else 1) - else - if c <= 8286 - then (if c <= 8239 then 2 else 1) - else if c <= 8287 then 2 else 1) - else - if c <= 8335 - then - (if c <= 8318 - then (if c <= 8305 then 8 else 1) - else if c <= 8319 then 8 else 1) - else - if c <= 8449 - then (if c <= 8348 then 8 else 1) - else if c <= 8450 then 8 else 1) - else - if c <= 8477 - then - (if c <= 8468 - then - (if c <= 8457 - then (if c <= 8455 then 8 else 1) - else if c <= 8467 then 8 else 1) - else - if c <= 8471 - then (if c <= 8469 then 8 else 1) - else 8) - else - if c <= 8485 - then - (if c <= 8483 - then 1 - else if c <= 8484 then 8 else 1) - else - if c <= 8487 - then (if c <= 8486 then 8 else 1) - else if c <= 8488 then 8 else 1) - else - if c <= 8543 - then - (if c <= 8505 - then 8 - else - if c <= 8516 - then - (if c <= 8507 - then 1 - else if c <= 8511 then 8 else 1) - else - if c <= 8525 - then (if c <= 8521 then 8 else 1) - else if c <= 8526 then 8 else 1) - else - if c <= 11389 - then - (if c <= 8584 - then 8 - else if c <= 11263 then 1 else 8) - else - if c <= 11498 - then (if c <= 11492 then 8 else 1) - else - if c <= 11505 - then (if c <= 11502 then 8 else 1) - else if c <= 11507 then 8 else 1) - else - if c <= 12294 - then - (if c <= 11695 - then - (if c <= 11630 - then - (if c <= 11564 - then - (if c <= 11558 - then (if c <= 11557 then 8 else 1) - else if c <= 11559 then 8 else 1) - else - if c <= 11567 - then (if c <= 11565 then 8 else 1) - else if c <= 11623 then 8 else 1) - else - if c <= 11679 - then - (if c <= 11647 - then (if c <= 11631 then 8 else 1) - else if c <= 11670 then 8 else 1) - else - if c <= 11687 - then (if c <= 11686 then 8 else 1) - else if c <= 11694 then 8 else 1) - else - if c <= 11727 - then - (if c <= 11711 - then - (if c <= 11703 - then (if c <= 11702 then 8 else 1) - else if c <= 11710 then 8 else 1) - else - if c <= 11719 - then (if c <= 11718 then 8 else 1) - else if c <= 11726 then 8 else 1) - else - if c <= 12287 - then - (if c <= 11735 - then (if c <= 11734 then 8 else 1) - else if c <= 11742 then 8 else 1) - else - if c <= 12292 - then (if c <= 12288 then 2 else 1) - else 8) - else - if c <= 12442 - then - (if c <= 12343 - then - (if c <= 12320 - then (if c <= 12295 then 8 else 1) - else - if c <= 12336 - then (if c <= 12329 then 8 else 1) - else if c <= 12341 then 8 else 1) - else - if c <= 12348 - then 8 - else - if c <= 12352 - then 1 - else if c <= 12438 then 8 else 1) - else - if c <= 12539 - then - (if c <= 12447 - then 8 - else - if c <= 12448 - then 1 - else if c <= 12538 then 8 else 1) - else - if c <= 12548 - then (if c <= 12543 then 8 else 1) - else - if c <= 12592 - then (if c <= 12591 then 8 else 1) - else if c <= 12686 then 8 else 1) - else - if c <= 42999 - then - (if c <= 42653 - then - (if c <= 42239 - then - (if c <= 40981 - then - (if c <= 13311 - then - (if c <= 12783 - then (if c <= 12735 then 8 else 1) - else if c <= 12799 then 8 else 1) - else - if c <= 19967 - then (if c <= 19903 then 8 else 1) - else 8) - else - if c <= 42191 - then (if c <= 42124 then 8 else 1) - else if c <= 42237 then 8 else 1) - else - if c <= 42559 - then - (if c <= 42511 - then (if c <= 42508 then 8 else 1) - else - if c <= 42537 - then (if c <= 42527 then 8 else 1) - else if c <= 42539 then 8 else 1) - else - if c <= 42622 - then (if c <= 42606 then 8 else 1) - else 8) - else - if c <= 42890 - then - (if c <= 42785 - then - (if c <= 42735 - then (if c <= 42655 then 1 else 8) - else - if c <= 42774 - then 1 - else if c <= 42783 then 8 else 1) - else - if c <= 42887 - then 8 - else if c <= 42888 then 8 else 1) - else - if c <= 42962 - then - (if c <= 42954 - then 8 - else - if c <= 42959 - then 1 - else if c <= 42961 then 8 else 1) - else - if c <= 42993 - then - (if c <= 42964 - then (if c <= 42963 then 8 else 1) - else if c <= 42969 then 8 else 1) - else 8) - else - if c <= 43470 - then - (if c <= 43137 - then - (if c <= 43010 - then - (if c <= 43002 - then 8 - else if c <= 43009 then 8 else 1) - else - if c <= 43019 - then - (if c <= 43014 - then (if c <= 43013 then 8 else 1) - else if c <= 43018 then 8 else 1) - else - if c <= 43071 - then (if c <= 43042 then 8 else 1) - else if c <= 43123 then 8 else 1) - else - if c <= 43273 - then - (if c <= 43258 - then - (if c <= 43249 - then (if c <= 43187 then 8 else 1) - else if c <= 43255 then 8 else 1) - else - if c <= 43260 - then (if c <= 43259 then 8 else 1) - else if c <= 43262 then 8 else 1) - else - if c <= 43359 - then - (if c <= 43311 - then (if c <= 43301 then 8 else 1) - else if c <= 43334 then 8 else 1) - else - if c <= 43395 - then (if c <= 43388 then 8 else 1) - else if c <= 43442 then 8 else 1) - else - if c <= 43615 - then - (if c <= 43513 - then - (if c <= 43493 - then - (if c <= 43487 - then (if c <= 43471 then 8 else 1) - else if c <= 43492 then 8 else 1) - else if c <= 43503 then 8 else 1) - else - if c <= 43583 - then - (if c <= 43519 - then (if c <= 43518 then 8 else 1) - else if c <= 43560 then 8 else 1) - else - if c <= 43587 - then (if c <= 43586 then 8 else 1) - else if c <= 43595 then 8 else 1) - else - if c <= 43645 - then - (if c <= 43638 - then 8 - else - if c <= 43641 - then 1 - else if c <= 43642 then 8 else 1) - else - if c <= 43700 - then - (if c <= 43696 - then (if c <= 43695 then 8 else 1) - else if c <= 43697 then 8 else 1) - else - if c <= 43704 - then (if c <= 43702 then 8 else 1) - else if c <= 43709 then 8 else 1) - else - if c <= 66377 - then - (if c <= 64325 - then - (if c <= 43887 - then - (if c <= 43784 - then - (if c <= 43743 - then - (if c <= 43738 - then - (if c <= 43713 - then (if c <= 43712 then 8 else 1) - else if c <= 43714 then 8 else 1) - else if c <= 43741 then 8 else 1) - else - if c <= 43764 - then - (if c <= 43761 - then (if c <= 43754 then 8 else 1) - else 8) - else - if c <= 43776 - then 1 - else if c <= 43782 then 8 else 1) - else - if c <= 43823 - then - (if c <= 43807 - then - (if c <= 43792 - then (if c <= 43790 then 8 else 1) - else if c <= 43798 then 8 else 1) - else - if c <= 43815 - then (if c <= 43814 then 8 else 1) - else if c <= 43822 then 8 else 1) - else - if c <= 43880 - then - (if c <= 43867 - then (if c <= 43866 then 8 else 1) - else 8) - else if c <= 43881 then 8 else 1) - else - if c <= 64274 - then - (if c <= 55242 - then - (if c <= 44031 - then (if c <= 44002 then 8 else 1) - else - if c <= 55215 - then (if c <= 55203 then 8 else 1) - else if c <= 55238 then 8 else 1) - else - if c <= 64111 - then - (if c <= 63743 - then (if c <= 55291 then 8 else 1) - else if c <= 64109 then 8 else 1) - else - if c <= 64255 - then (if c <= 64217 then 8 else 1) - else if c <= 64262 then 8 else 1) - else - if c <= 64311 - then - (if c <= 64286 - then - (if c <= 64284 - then (if c <= 64279 then 8 else 1) - else if c <= 64285 then 8 else 1) - else - if c <= 64297 - then (if c <= 64296 then 8 else 1) - else if c <= 64310 then 8 else 1) - else - if c <= 64319 - then - (if c <= 64317 - then (if c <= 64316 then 8 else 1) - else if c <= 64318 then 8 else 1) - else - if c <= 64322 - then (if c <= 64321 then 8 else 1) - else if c <= 64324 then 8 else 1) - else - if c <= 65481 - then - (if c <= 65312 - then - (if c <= 65007 - then - (if c <= 64847 - then - (if c <= 64466 - then (if c <= 64433 then 8 else 1) - else if c <= 64829 then 8 else 1) - else - if c <= 64913 - then (if c <= 64911 then 8 else 1) - else if c <= 64967 then 8 else 1) - else - if c <= 65141 - then - (if c <= 65135 - then (if c <= 65019 then 8 else 1) - else if c <= 65140 then 8 else 1) - else - if c <= 65278 - then (if c <= 65276 then 8 else 1) - else if c <= 65279 then 2 else 1) - else - if c <= 65437 - then - (if c <= 65381 - then - (if c <= 65344 - then (if c <= 65338 then 8 else 1) - else if c <= 65370 then 8 else 1) - else 8) - else - if c <= 65470 - then 8 - else - if c <= 65473 - then 1 - else if c <= 65479 then 8 else 1) - else - if c <= 65615 - then - (if c <= 65548 - then - (if c <= 65497 - then - (if c <= 65489 - then (if c <= 65487 then 8 else 1) - else if c <= 65495 then 8 else 1) - else - if c <= 65535 - then (if c <= 65500 then 8 else 1) - else if c <= 65547 then 8 else 1) - else - if c <= 65595 - then - (if c <= 65575 - then (if c <= 65574 then 8 else 1) - else if c <= 65594 then 8 else 1) - else - if c <= 65598 - then (if c <= 65597 then 8 else 1) - else if c <= 65613 then 8 else 1) - else - if c <= 66207 - then - (if c <= 65855 - then - (if c <= 65663 - then (if c <= 65629 then 8 else 1) - else if c <= 65786 then 8 else 1) - else - if c <= 66175 - then (if c <= 65908 then 8 else 1) - else if c <= 66204 then 8 else 1) - else - if c <= 66348 - then - (if c <= 66303 - then (if c <= 66256 then 8 else 1) - else if c <= 66335 then 8 else 1) - else 8) - else - if c <= 67646 - then - (if c <= 66963 - then - (if c <= 66717 - then - (if c <= 66463 - then - (if c <= 66383 - then (if c <= 66378 then 8 else 1) - else - if c <= 66431 - then (if c <= 66421 then 8 else 1) - else if c <= 66461 then 8 else 1) - else - if c <= 66512 - then - (if c <= 66503 - then (if c <= 66499 then 8 else 1) - else if c <= 66511 then 8 else 1) - else - if c <= 66559 - then (if c <= 66517 then 8 else 1) - else 8) - else - if c <= 66863 - then - (if c <= 66775 - then - (if c <= 66735 - then 1 - else if c <= 66771 then 8 else 1) - else - if c <= 66815 - then (if c <= 66811 then 8 else 1) - else if c <= 66855 then 8 else 1) - else - if c <= 66939 - then - (if c <= 66927 - then (if c <= 66915 then 8 else 1) - else if c <= 66938 then 8 else 1) - else - if c <= 66955 - then (if c <= 66954 then 8 else 1) - else if c <= 66962 then 8 else 1) - else - if c <= 67455 - then - (if c <= 67002 - then - (if c <= 66978 - then - (if c <= 66966 - then (if c <= 66965 then 8 else 1) - else if c <= 66977 then 8 else 1) - else - if c <= 66994 - then (if c <= 66993 then 8 else 1) - else if c <= 67001 then 8 else 1) - else - if c <= 67391 - then - (if c <= 67071 - then (if c <= 67004 then 8 else 1) - else if c <= 67382 then 8 else 1) - else - if c <= 67423 - then (if c <= 67413 then 8 else 1) - else if c <= 67431 then 8 else 1) - else - if c <= 67591 - then - (if c <= 67505 - then - (if c <= 67462 - then (if c <= 67461 then 8 else 1) - else if c <= 67504 then 8 else 1) - else - if c <= 67583 - then (if c <= 67514 then 8 else 1) - else if c <= 67589 then 8 else 1) - else - if c <= 67638 - then - (if c <= 67593 - then (if c <= 67592 then 8 else 1) - else if c <= 67637 then 8 else 1) - else - if c <= 67643 - then (if c <= 67640 then 8 else 1) - else if c <= 67644 then 8 else 1) - else - if c <= 68296 - then - (if c <= 68029 - then - (if c <= 67827 - then - (if c <= 67711 - then - (if c <= 67679 - then (if c <= 67669 then 8 else 1) - else if c <= 67702 then 8 else 1) - else - if c <= 67807 - then (if c <= 67742 then 8 else 1) - else if c <= 67826 then 8 else 1) - else - if c <= 67871 - then - (if c <= 67839 - then (if c <= 67829 then 8 else 1) - else if c <= 67861 then 8 else 1) - else - if c <= 67967 - then (if c <= 67897 then 8 else 1) - else if c <= 68023 then 8 else 1) - else - if c <= 68120 - then - (if c <= 68111 - then - (if c <= 68095 - then (if c <= 68031 then 8 else 1) - else if c <= 68096 then 8 else 1) - else - if c <= 68116 - then (if c <= 68115 then 8 else 1) - else if c <= 68119 then 8 else 1) - else - if c <= 68223 - then - (if c <= 68191 - then (if c <= 68149 then 8 else 1) - else if c <= 68220 then 8 else 1) - else - if c <= 68287 - then (if c <= 68252 then 8 else 1) - else if c <= 68295 then 8 else 1) - else - if c <= 68863 - then - (if c <= 68479 - then - (if c <= 68415 - then - (if c <= 68351 - then (if c <= 68324 then 8 else 1) - else if c <= 68405 then 8 else 1) - else - if c <= 68447 - then (if c <= 68437 then 8 else 1) - else if c <= 68466 then 8 else 1) - else - if c <= 68735 - then - (if c <= 68607 - then (if c <= 68497 then 8 else 1) - else if c <= 68680 then 8 else 1) - else - if c <= 68799 - then (if c <= 68786 then 8 else 1) - else if c <= 68850 then 8 else 1) - else - if c <= 69414 - then - (if c <= 69295 - then - (if c <= 69247 - then (if c <= 68899 then 8 else 1) - else if c <= 69289 then 8 else 1) - else - if c <= 69375 - then (if c <= 69297 then 8 else 1) - else if c <= 69404 then 8 else 1) - else - if c <= 69487 - then - (if c <= 69423 - then (if c <= 69415 then 8 else 1) - else if c <= 69445 then 8 else 1) - else - if c <= 69551 - then (if c <= 69505 then 8 else 1) - else if c <= 69572 then 8 else 1) - else - if c <= 120122 - then - (if c <= 72348 - then - (if c <= 70655 - then - (if c <= 70162 - then - (if c <= 69958 - then - (if c <= 69762 - then - (if c <= 69744 - then - (if c <= 69634 - then (if c <= 69622 then 8 else 1) - else if c <= 69687 then 8 else 1) - else - if c <= 69748 - then (if c <= 69746 then 8 else 1) - else if c <= 69749 then 8 else 1) - else - if c <= 69890 - then - (if c <= 69839 - then (if c <= 69807 then 8 else 1) - else if c <= 69864 then 8 else 1) - else - if c <= 69955 - then (if c <= 69926 then 8 else 1) - else if c <= 69956 then 8 else 1) - else - if c <= 70080 - then - (if c <= 70005 - then - (if c <= 69967 - then (if c <= 69959 then 8 else 1) - else if c <= 70002 then 8 else 1) - else - if c <= 70018 - then (if c <= 70006 then 8 else 1) - else if c <= 70066 then 8 else 1) - else - if c <= 70107 - then - (if c <= 70105 - then (if c <= 70084 then 8 else 1) - else if c <= 70106 then 8 else 1) - else - if c <= 70143 - then (if c <= 70108 then 8 else 1) - else if c <= 70161 then 8 else 1) - else - if c <= 70414 - then - (if c <= 70286 - then - (if c <= 70279 - then - (if c <= 70271 - then (if c <= 70187 then 8 else 1) - else if c <= 70278 then 8 else 1) - else - if c <= 70281 - then (if c <= 70280 then 8 else 1) - else if c <= 70285 then 8 else 1) - else - if c <= 70319 - then - (if c <= 70302 - then (if c <= 70301 then 8 else 1) - else if c <= 70312 then 8 else 1) - else - if c <= 70404 - then (if c <= 70366 then 8 else 1) - else if c <= 70412 then 8 else 1) - else - if c <= 70452 - then - (if c <= 70441 - then - (if c <= 70418 - then (if c <= 70416 then 8 else 1) - else if c <= 70440 then 8 else 1) - else - if c <= 70449 - then (if c <= 70448 then 8 else 1) - else if c <= 70451 then 8 else 1) - else - if c <= 70479 - then - (if c <= 70460 - then (if c <= 70457 then 8 else 1) - else if c <= 70461 then 8 else 1) - else - if c <= 70492 - then (if c <= 70480 then 8 else 1) - else if c <= 70497 then 8 else 1) - else - if c <= 71934 - then - (if c <= 71167 - then - (if c <= 70851 - then - (if c <= 70750 - then - (if c <= 70726 - then (if c <= 70708 then 8 else 1) - else if c <= 70730 then 8 else 1) - else - if c <= 70783 - then (if c <= 70753 then 8 else 1) - else if c <= 70831 then 8 else 1) - else - if c <= 71039 - then - (if c <= 70854 - then (if c <= 70853 then 8 else 1) - else if c <= 70855 then 8 else 1) - else - if c <= 71127 - then (if c <= 71086 then 8 else 1) - else if c <= 71131 then 8 else 1) - else - if c <= 71423 - then - (if c <= 71295 - then - (if c <= 71235 - then (if c <= 71215 then 8 else 1) - else if c <= 71236 then 8 else 1) - else - if c <= 71351 - then (if c <= 71338 then 8 else 1) - else if c <= 71352 then 8 else 1) - else - if c <= 71679 - then - (if c <= 71487 - then (if c <= 71450 then 8 else 1) - else if c <= 71494 then 8 else 1) - else - if c <= 71839 - then (if c <= 71723 then 8 else 1) - else if c <= 71903 then 8 else 1) - else - if c <= 72105 - then - (if c <= 71959 - then - (if c <= 71947 - then - (if c <= 71944 - then (if c <= 71942 then 8 else 1) - else if c <= 71945 then 8 else 1) - else - if c <= 71956 - then (if c <= 71955 then 8 else 1) - else if c <= 71958 then 8 else 1) - else - if c <= 72000 - then - (if c <= 71998 - then (if c <= 71983 then 8 else 1) - else if c <= 71999 then 8 else 1) - else - if c <= 72095 - then (if c <= 72001 then 8 else 1) - else if c <= 72103 then 8 else 1) - else - if c <= 72202 - then - (if c <= 72162 - then - (if c <= 72160 - then (if c <= 72144 then 8 else 1) - else if c <= 72161 then 8 else 1) - else - if c <= 72191 - then (if c <= 72163 then 8 else 1) - else if c <= 72192 then 8 else 1) - else - if c <= 72271 - then - (if c <= 72249 - then (if c <= 72242 then 8 else 1) - else if c <= 72250 then 8 else 1) - else - if c <= 72283 - then (if c <= 72272 then 8 else 1) - else if c <= 72329 then 8 else 1) - else - if c <= 94031 - then - (if c <= 73727 - then - (if c <= 72970 - then - (if c <= 72767 - then - (if c <= 72703 - then - (if c <= 72367 - then (if c <= 72349 then 8 else 1) - else if c <= 72440 then 8 else 1) - else - if c <= 72713 - then (if c <= 72712 then 8 else 1) - else if c <= 72750 then 8 else 1) - else - if c <= 72959 - then - (if c <= 72817 - then (if c <= 72768 then 8 else 1) - else if c <= 72847 then 8 else 1) - else - if c <= 72967 - then (if c <= 72966 then 8 else 1) - else if c <= 72969 then 8 else 1) - else - if c <= 73065 - then - (if c <= 73055 - then - (if c <= 73029 - then (if c <= 73008 then 8 else 1) - else if c <= 73030 then 8 else 1) - else - if c <= 73062 - then (if c <= 73061 then 8 else 1) - else if c <= 73064 then 8 else 1) - else - if c <= 73439 - then - (if c <= 73111 - then (if c <= 73097 then 8 else 1) - else if c <= 73112 then 8 else 1) - else - if c <= 73647 - then (if c <= 73458 then 8 else 1) - else if c <= 73648 then 8 else 1) - else - if c <= 92783 - then - (if c <= 77823 - then - (if c <= 74879 - then - (if c <= 74751 - then (if c <= 74649 then 8 else 1) - else if c <= 74862 then 8 else 1) - else - if c <= 77711 - then (if c <= 75075 then 8 else 1) - else if c <= 77808 then 8 else 1) - else - if c <= 92159 - then - (if c <= 82943 - then (if c <= 78894 then 8 else 1) - else if c <= 83526 then 8 else 1) - else - if c <= 92735 - then (if c <= 92728 then 8 else 1) - else if c <= 92766 then 8 else 1) - else - if c <= 93026 - then - (if c <= 92927 - then - (if c <= 92879 - then (if c <= 92862 then 8 else 1) - else if c <= 92909 then 8 else 1) - else - if c <= 92991 - then (if c <= 92975 then 8 else 1) - else if c <= 92995 then 8 else 1) - else - if c <= 93759 - then - (if c <= 93052 - then (if c <= 93047 then 8 else 1) - else if c <= 93071 then 8 else 1) - else - if c <= 93951 - then (if c <= 93823 then 8 else 1) - else if c <= 94026 then 8 else 1) - else - if c <= 113791 - then - (if c <= 110580 - then - (if c <= 94207 - then - (if c <= 94175 - then - (if c <= 94098 - then (if c <= 94032 then 8 else 1) - else if c <= 94111 then 8 else 1) - else - if c <= 94178 - then (if c <= 94177 then 8 else 1) - else if c <= 94179 then 8 else 1) - else - if c <= 101631 - then - (if c <= 100351 - then (if c <= 100343 then 8 else 1) - else if c <= 101589 then 8 else 1) - else - if c <= 110575 - then (if c <= 101640 then 8 else 1) - else if c <= 110579 then 8 else 1) - else - if c <= 110947 - then - (if c <= 110591 - then - (if c <= 110588 - then (if c <= 110587 then 8 else 1) - else if c <= 110590 then 8 else 1) - else - if c <= 110927 - then (if c <= 110882 then 8 else 1) - else if c <= 110930 then 8 else 1) - else - if c <= 113663 - then - (if c <= 110959 - then (if c <= 110951 then 8 else 1) - else if c <= 111355 then 8 else 1) - else - if c <= 113775 - then (if c <= 113770 then 8 else 1) - else if c <= 113788 then 8 else 1) - else - if c <= 119981 - then - (if c <= 119965 - then - (if c <= 119807 - then - (if c <= 113807 - then (if c <= 113800 then 8 else 1) - else if c <= 113817 then 8 else 1) - else - if c <= 119893 - then (if c <= 119892 then 8 else 1) - else if c <= 119964 then 8 else 1) - else - if c <= 119972 - then - (if c <= 119969 - then (if c <= 119967 then 8 else 1) - else if c <= 119970 then 8 else 1) - else - if c <= 119976 - then (if c <= 119974 then 8 else 1) - else if c <= 119980 then 8 else 1) - else - if c <= 120070 - then - (if c <= 119996 - then - (if c <= 119994 - then (if c <= 119993 then 8 else 1) - else if c <= 119995 then 8 else 1) - else - if c <= 120004 - then (if c <= 120003 then 8 else 1) - else if c <= 120069 then 8 else 1) - else - if c <= 120085 - then - (if c <= 120076 - then (if c <= 120074 then 8 else 1) - else if c <= 120084 then 8 else 1) - else - if c <= 120093 - then (if c <= 120092 then 8 else 1) - else if c <= 120121 then 8 else 1) - else - if c <= 131071 - then - (if c <= 126468 - then - (if c <= 122623 - then - (if c <= 120571 - then - (if c <= 120145 - then - (if c <= 120133 - then - (if c <= 120127 - then (if c <= 120126 then 8 else 1) - else if c <= 120132 then 8 else 1) - else - if c <= 120137 - then (if c <= 120134 then 8 else 1) - else if c <= 120144 then 8 else 1) - else - if c <= 120513 - then - (if c <= 120487 - then (if c <= 120485 then 8 else 1) - else if c <= 120512 then 8 else 1) - else - if c <= 120539 - then (if c <= 120538 then 8 else 1) - else if c <= 120570 then 8 else 1) - else - if c <= 120687 - then - (if c <= 120629 - then - (if c <= 120597 - then (if c <= 120596 then 8 else 1) - else if c <= 120628 then 8 else 1) - else - if c <= 120655 - then (if c <= 120654 then 8 else 1) - else if c <= 120686 then 8 else 1) - else - if c <= 120745 - then - (if c <= 120713 - then (if c <= 120712 then 8 else 1) - else if c <= 120744 then 8 else 1) - else - if c <= 120771 - then (if c <= 120770 then 8 else 1) - else if c <= 120779 then 8 else 1) - else - if c <= 124895 - then - (if c <= 123190 - then - (if c <= 122654 - then 8 - else - if c <= 123135 - then 1 - else if c <= 123180 then 8 else 1) - else - if c <= 123535 - then - (if c <= 123213 - then (if c <= 123197 then 8 else 1) - else if c <= 123214 then 8 else 1) - else - if c <= 123583 - then (if c <= 123565 then 8 else 1) - else if c <= 123627 then 8 else 1) - else - if c <= 124927 - then - (if c <= 124908 - then - (if c <= 124903 - then (if c <= 124902 then 8 else 1) - else if c <= 124907 then 8 else 1) - else - if c <= 124911 - then (if c <= 124910 then 8 else 1) - else if c <= 124926 then 8 else 1) - else - if c <= 125258 - then - (if c <= 125183 - then (if c <= 125124 then 8 else 1) - else if c <= 125251 then 8 else 1) - else - if c <= 126463 - then (if c <= 125259 then 8 else 1) - else if c <= 126467 then 8 else 1) - else - if c <= 126552 - then - (if c <= 126529 - then - (if c <= 126504 - then - (if c <= 126499 - then - (if c <= 126496 - then (if c <= 126495 then 8 else 1) - else if c <= 126498 then 8 else 1) - else - if c <= 126502 - then (if c <= 126500 then 8 else 1) - else if c <= 126503 then 8 else 1) - else - if c <= 126520 - then - (if c <= 126515 - then (if c <= 126514 then 8 else 1) - else if c <= 126519 then 8 else 1) - else - if c <= 126522 - then (if c <= 126521 then 8 else 1) - else if c <= 126523 then 8 else 1) - else - if c <= 126540 - then - (if c <= 126536 - then - (if c <= 126534 - then (if c <= 126530 then 8 else 1) - else if c <= 126535 then 8 else 1) - else - if c <= 126538 - then (if c <= 126537 then 8 else 1) - else if c <= 126539 then 8 else 1) - else - if c <= 126547 - then - (if c <= 126544 - then (if c <= 126543 then 8 else 1) - else if c <= 126546 then 8 else 1) - else - if c <= 126550 - then (if c <= 126548 then 8 else 1) - else if c <= 126551 then 8 else 1) - else - if c <= 126579 - then - (if c <= 126560 - then - (if c <= 126556 - then - (if c <= 126554 - then (if c <= 126553 then 8 else 1) - else if c <= 126555 then 8 else 1) - else - if c <= 126558 - then (if c <= 126557 then 8 else 1) - else if c <= 126559 then 8 else 1) - else - if c <= 126566 - then - (if c <= 126563 - then (if c <= 126562 then 8 else 1) - else if c <= 126564 then 8 else 1) - else - if c <= 126571 - then (if c <= 126570 then 8 else 1) - else if c <= 126578 then 8 else 1) - else - if c <= 126602 - then - (if c <= 126589 - then - (if c <= 126584 - then (if c <= 126583 then 8 else 1) - else if c <= 126588 then 8 else 1) - else - if c <= 126591 - then (if c <= 126590 then 8 else 1) - else if c <= 126601 then 8 else 1) - else - if c <= 126628 - then - (if c <= 126624 - then (if c <= 126619 then 8 else 1) - else if c <= 126627 then 8 else 1) - else - if c <= 126634 - then (if c <= 126633 then 8 else 1) - else if c <= 126651 then 8 else 1) - else - if c <= 183983 - then - (if c <= 177983 - then - (if c <= 173823 - then (if c <= 173791 then 8 else 1) - else if c <= 177976 then 8 else 1) - else - if c <= 178207 - then (if c <= 178205 then 8 else 1) - else if c <= 183969 then 8 else 1) - else if c <= 191456 then 8 else 1) - else (-1) -let __sedlex_partition_58 c = - if c <= 45 then (-1) else if c <= 46 then 0 else (-1) -let __sedlex_partition_51 c = - if c <= 8 - then (-1) - else - if c <= 5760 - then (Char.code (String.unsafe_get __sedlex_table_2 (c - 9))) - 1 - else - if c <= 8191 - then (-1) - else - if c <= 65279 - then - (if c <= 12288 - then - (if c <= 8239 - then (if c <= 8202 then 0 else if c <= 8238 then (-1) else 0) - else - if c <= 8286 - then (-1) - else if c <= 8287 then 0 else if c <= 12287 then (-1) else 0) - else if c <= 65278 then (-1) else 0) - else (-1) -let __sedlex_partition_21 c = - if c <= (-1) - then (-1) - else - if c <= 95 - then (Char.code (String.unsafe_get __sedlex_table_3 c)) - 1 - else if c <= 96 then (-1) else 0 -let __sedlex_partition_91 c = - if c <= 63 then (-1) else if c <= 64 then 0 else (-1) -let __sedlex_partition_112 c = - if c <= 47 - then (-1) - else - if c <= 120 - then (Char.code (String.unsafe_get __sedlex_table_4 (c - 48))) - 1 - else (-1) -let __sedlex_partition_33 c = - if c <= 47 then (-1) else if c <= 57 then 0 else (-1) -let __sedlex_partition_102 c = - if c <= 91 - then (-1) - else - if c <= 93 - then (Char.code (String.unsafe_get __sedlex_table_5 (c - 92))) - 1 - else (-1) -let __sedlex_partition_104 c = - if c <= (-1) - then (-1) - else - if c <= 90 - then (Char.code (String.unsafe_get __sedlex_table_6 c)) - 1 - else - if c <= 92 - then (-1) - else if c <= 8231 then 0 else if c <= 8233 then (-1) else 0 -let __sedlex_partition_4 c = - if c <= 47 - then (-1) - else - if c <= 102 - then (Char.code (String.unsafe_get __sedlex_table_7 (c - 48))) - 1 - else (-1) -let __sedlex_partition_18 c = - if c <= 92 - then (Char.code (String.unsafe_get __sedlex_table_8 (c - (-1)))) - 1 - else 1 -let __sedlex_partition_42 c = - if c <= 47 - then (-1) - else - if c <= 110 - then (Char.code (String.unsafe_get __sedlex_table_9 (c - 48))) - 1 - else (-1) -let __sedlex_partition_129 c = - if c <= 61 then (-1) else if c <= 62 then 0 else (-1) -let __sedlex_partition_130 c = - if c <= 123 then (-1) else if c <= 124 then 0 else (-1) -let __sedlex_partition_113 c = - if c <= 47 - then (-1) - else - if c <= 59 - then (Char.code (String.unsafe_get __sedlex_table_10 (c - 48))) - 1 - else (-1) -let __sedlex_partition_115 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_11 (c - 36))) - 1 - else (-1) -let __sedlex_partition_34 c = - if c <= 87 - then (-1) - else - if c <= 120 - then (Char.code (String.unsafe_get __sedlex_table_12 (c - 88))) - 1 - else (-1) -let __sedlex_partition_37 c = - if c <= 45 - then (-1) - else - if c <= 57 - then (Char.code (String.unsafe_get __sedlex_table_13 (c - 46))) - 1 - else (-1) -let __sedlex_partition_84 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_14 (c - 36))) - 1 - else (-1) -let __sedlex_partition_5 c = - if c <= 47 - then (-1) - else - if c <= 125 - then (Char.code (String.unsafe_get __sedlex_table_15 (c - 48))) - 1 - else (-1) -let __sedlex_partition_62 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_16 (c - 36))) - 1 - else (-1) -let __sedlex_partition_121 c = - if c <= 8 - then (-1) - else - if c <= 5760 - then (Char.code (String.unsafe_get __sedlex_table_17 (c - 9))) - 1 - else - if c <= 8191 - then (-1) - else - if c <= 65279 - then - (if c <= 12288 - then - (if c <= 8239 - then (if c <= 8202 then 0 else if c <= 8238 then (-1) else 0) - else - if c <= 8286 - then (-1) - else if c <= 8287 then 0 else if c <= 12287 then (-1) else 0) - else if c <= 65278 then (-1) else 0) - else (-1) -let __sedlex_partition_131 c = - if c <= 124 then (-1) else if c <= 125 then 0 else (-1) -let __sedlex_partition_43 c = - if c <= 45 - then (-1) - else - if c <= 101 - then (Char.code (String.unsafe_get __sedlex_table_18 (c - 46))) - 1 - else (-1) -let __sedlex_partition_56 c = - if c <= 42 - then (-1) - else - if c <= 61 - then (Char.code (String.unsafe_get __sedlex_table_19 (c - 43))) - 1 - else (-1) -let __sedlex_partition_7 c = - if c <= 92 - then (Char.code (String.unsafe_get __sedlex_table_20 (c - (-1)))) - 1 - else 1 -let __sedlex_partition_19 c = - if c <= (-1) - then (-1) - else - if c <= 91 - then (Char.code (String.unsafe_get __sedlex_table_21 c)) - 1 - else if c <= 92 then (-1) else 0 -let __sedlex_partition_105 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_22 (c - 36))) - 1 - else (-1) -let __sedlex_partition_57 c = - if c <= 44 - then (-1) - else - if c <= 61 - then (Char.code (String.unsafe_get __sedlex_table_23 (c - 45))) - 1 - else (-1) -let __sedlex_partition_127 c = - if c <= 103 then (-1) else if c <= 104 then 0 else (-1) -let __sedlex_partition_28 c = - if c <= 47 - then (-1) - else - if c <= 95 - then (Char.code (String.unsafe_get __sedlex_table_24 (c - 48))) - 1 - else (-1) -let __sedlex_partition_27 c = - if c <= 47 - then (-1) - else - if c <= 110 - then (Char.code (String.unsafe_get __sedlex_table_25 (c - 48))) - 1 - else (-1) -let __sedlex_partition_35 c = - if c <= 47 - then (-1) - else - if c <= 110 - then (Char.code (String.unsafe_get __sedlex_table_26 (c - 48))) - 1 - else (-1) -let __sedlex_partition_79 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_27 (c - 36))) - 1 - else (-1) -let __sedlex_partition_65 c = - if c <= 8 - then (-1) - else - if c <= 5760 - then (Char.code (String.unsafe_get __sedlex_table_28 (c - 9))) - 1 - else - if c <= 8191 - then (-1) - else - if c <= 65279 - then - (if c <= 12288 - then - (if c <= 8239 - then (if c <= 8202 then 0 else if c <= 8238 then (-1) else 0) - else - if c <= 8286 - then (-1) - else if c <= 8287 then 0 else if c <= 12287 then (-1) else 0) - else if c <= 65278 then (-1) else 0) - else (-1) -let __sedlex_partition_122 c = - if c <= 44 - then (-1) - else - if c <= 57 - then (Char.code (String.unsafe_get __sedlex_table_29 (c - 45))) - 1 - else (-1) -let __sedlex_partition_26 c = - if c <= 47 then (-1) else if c <= 49 then 0 else (-1) -let __sedlex_partition_31 c = - if c <= 47 - then (-1) - else - if c <= 95 - then (Char.code (String.unsafe_get __sedlex_table_30 (c - 48))) - 1 - else (-1) -let __sedlex_partition_40 c = - if c <= 47 - then (-1) - else - if c <= 57 - then (Char.code (String.unsafe_get __sedlex_table_31 (c - 48))) - 1 - else (-1) -let __sedlex_partition_86 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_32 (c - 36))) - 1 - else (-1) -let __sedlex_partition_93 c = - if c <= 114 then (-1) else if c <= 115 then 0 else (-1) -let __sedlex_partition_52 c = - if c <= 60 then (-1) else if c <= 61 then 0 else (-1) -let __sedlex_partition_110 c = - if c <= (-1) - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_33 c)) - 1 - else - if c <= 123 - then (-1) - else if c <= 8231 then 0 else if c <= 8233 then (-1) else 0 -let __sedlex_partition_10 c = - if c <= (-1) - then (-1) - else - if c <= 41 - then (Char.code (String.unsafe_get __sedlex_table_34 c)) - 1 - else - if c <= 42 - then (-1) - else if c <= 8231 then 0 else if c <= 8233 then (-1) else 0 -let __sedlex_partition_88 c = - if c <= 59 - then (-1) - else - if c <= 61 - then (Char.code (String.unsafe_get __sedlex_table_5 (c - 60))) - 1 - else (-1) -let __sedlex_partition_41 c = - if c <= 47 - then (-1) - else - if c <= 110 - then (Char.code (String.unsafe_get __sedlex_table_35 (c - 48))) - 1 - else (-1) -let __sedlex_partition_92 c = - if c <= 96 - then (-1) - else - if c <= 105 - then (Char.code (String.unsafe_get __sedlex_table_36 (c - 97))) - 1 - else (-1) -let __sedlex_partition_30 c = - if c <= 47 - then (-1) - else - if c <= 110 - then (Char.code (String.unsafe_get __sedlex_table_37 (c - 48))) - 1 - else (-1) -let __sedlex_partition_89 c = - if c <= 60 - then (-1) - else - if c <= 62 - then (Char.code (String.unsafe_get __sedlex_table_5 (c - 61))) - 1 - else (-1) -let __sedlex_partition_22 c = - if c <= 122 then (-1) else if c <= 123 then 0 else (-1) -let __sedlex_partition_25 c = - if c <= 65 - then (-1) - else - if c <= 98 - then (Char.code (String.unsafe_get __sedlex_table_12 (c - 66))) - 1 - else (-1) -let __sedlex_partition_63 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_38 (c - 36))) - 1 - else (-1) -let __sedlex_partition_20 c = - if c <= 96 - then (Char.code (String.unsafe_get __sedlex_table_39 (c - (-1)))) - 1 - else 1 -let __sedlex_partition_96 c = - if c <= 115 then (-1) else if c <= 116 then 0 else (-1) -let __sedlex_partition_17 c = - if c <= 47 then (-1) else if c <= 55 then 0 else (-1) -let __sedlex_partition_72 c = - if c <= 109 then (-1) else if c <= 110 then 0 else (-1) -let __sedlex_partition_99 c = - if c <= 60 - then (-1) - else - if c <= 124 - then (Char.code (String.unsafe_get __sedlex_table_40 (c - 61))) - 1 - else (-1) -let __sedlex_partition_68 c = - if c <= 110 then (-1) else if c <= 111 then 0 else (-1) -let __sedlex_partition_73 c = - if c <= 98 then (-1) else if c <= 99 then 0 else (-1) -let __sedlex_partition_24 c = - if c <= 47 then (-1) else if c <= 48 then 0 else (-1) -let __sedlex_partition_123 c = - if c <= 8 - then (-1) - else - if c <= 5760 - then (Char.code (String.unsafe_get __sedlex_table_41 (c - 9))) - 1 - else - if c <= 8191 - then (-1) - else - if c <= 65279 - then - (if c <= 12288 - then - (if c <= 8239 - then (if c <= 8202 then 0 else if c <= 8238 then (-1) else 0) - else - if c <= 8286 - then (-1) - else if c <= 8287 then 0 else if c <= 12287 then (-1) else 0) - else if c <= 65278 then (-1) else 0) - else (-1) -let __sedlex_partition_45 c = - if c <= 45 - then (-1) - else - if c <= 101 - then (Char.code (String.unsafe_get __sedlex_table_42 (c - 46))) - 1 - else (-1) -let __sedlex_partition_29 c = - if c <= 78 - then (-1) - else - if c <= 111 - then (Char.code (String.unsafe_get __sedlex_table_12 (c - 79))) - 1 - else (-1) -let __sedlex_partition_23 c = - if c <= 41 then (-1) else if c <= 42 then 0 else (-1) -let __sedlex_partition_16 c = - if c <= 120 - then (Char.code (String.unsafe_get __sedlex_table_43 (c - (-1)))) - 1 - else if c <= 8233 then (if c <= 8231 then 1 else 2) else 1 -let __sedlex_partition_53 c = - if c <= 32 then (-1) else if c <= 33 then 0 else (-1) -let __sedlex_partition_54 c = - if c <= 37 - then (-1) - else - if c <= 61 - then (Char.code (String.unsafe_get __sedlex_table_44 (c - 38))) - 1 - else (-1) -let __sedlex_partition_106 c = - if c <= (-1) - then (-1) - else - if c <= 13 - then (Char.code (String.unsafe_get __sedlex_table_45 c)) - 1 - else if c <= 8233 then (if c <= 8231 then 0 else 1) else 0 -let __sedlex_partition_77 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_46 (c - 36))) - 1 - else (-1) -let __sedlex_partition_9 c = - if c <= (-1) - then (-1) - else - if c <= 42 - then (Char.code (String.unsafe_get __sedlex_table_47 c)) - 1 - else if c <= 8233 then (if c <= 8231 then 0 else 1) else 0 -let __sedlex_partition_44 c = - if c <= 47 - then (-1) - else - if c <= 101 - then (Char.code (String.unsafe_get __sedlex_table_48 (c - 48))) - 1 - else (-1) -let __sedlex_partition_59 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_49 (c - 36))) - 1 - else (-1) -let __sedlex_partition_55 c = - if c <= 41 - then (-1) - else - if c <= 61 - then (Char.code (String.unsafe_get __sedlex_table_50 (c - 42))) - 1 - else (-1) -let __sedlex_partition_95 c = - if c <= 72 then (-1) else if c <= 73 then 0 else (-1) -let __sedlex_partition_120 c = - if c <= 44 - then (-1) - else - if c <= 48 - then (Char.code (String.unsafe_get __sedlex_table_51 (c - 45))) - 1 - else (-1) -let __sedlex_partition_124 c = - if c <= 44 - then (-1) - else - if c <= 57 - then (Char.code (String.unsafe_get __sedlex_table_52 (c - 45))) - 1 - else (-1) -let __sedlex_partition_70 c = - if c <= 44 then (-1) else if c <= 45 then 0 else (-1) -let __sedlex_partition_71 c = - if c <= 104 then (-1) else if c <= 105 then 0 else (-1) -let __sedlex_partition_67 c = - if c <= 107 then (-1) else if c <= 108 then 0 else (-1) -let __sedlex_partition_74 c = - if c <= 99 then (-1) else if c <= 100 then 0 else (-1) -let __sedlex_partition_36 c = - if c <= 47 - then (-1) - else - if c <= 102 - then (Char.code (String.unsafe_get __sedlex_table_53 (c - 48))) - 1 - else (-1) -let __sedlex_partition_97 c = - if c <= 113 then (-1) else if c <= 114 then 0 else (-1) -let __sedlex_partition_47 c = - if c <= 45 - then (-1) - else - if c <= 57 - then (Char.code (String.unsafe_get __sedlex_table_54 (c - 46))) - 1 - else (-1) -let __sedlex_partition_80 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_55 (c - 36))) - 1 - else (-1) -let __sedlex_partition_3 c = - if c <= 47 - then (-1) - else - if c <= 123 - then (Char.code (String.unsafe_get __sedlex_table_56 (c - 48))) - 1 - else (-1) -let __sedlex_partition_90 c = - if c <= 45 - then (-1) - else - if c <= 63 - then (Char.code (String.unsafe_get __sedlex_table_57 (c - 46))) - 1 - else (-1) -let __sedlex_partition_8 c = - if c <= (-1) - then (-1) - else if c <= 91 then 0 else if c <= 92 then (-1) else 0 -let __sedlex_partition_15 c = - if c <= (-1) - then (-1) - else - if c <= 12 - then (Char.code (String.unsafe_get __sedlex_table_58 c)) - 1 - else - if c <= 13 - then (-1) - else if c <= 8231 then 0 else if c <= 8233 then (-1) else 0 -let __sedlex_partition_76 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_59 (c - 36))) - 1 - else (-1) -let __sedlex_partition_101 c = - if c <= (-1) - then (-1) - else - if c <= 91 - then (Char.code (String.unsafe_get __sedlex_table_60 c)) - 1 - else - if c <= 93 - then (-1) - else if c <= 8231 then 0 else if c <= 8233 then (-1) else 0 -let __sedlex_partition_107 c = - if c <= 8191 - then (Char.code (String.unsafe_get __sedlex_table_61 (c - (-1)))) - 1 - else - if c <= 12287 - then - (if c <= 8238 - then - (if c <= 8231 - then (if c <= 8202 then 2 else 1) - else if c <= 8233 then 3 else 1) - else - if c <= 8286 - then (if c <= 8239 then 2 else 1) - else if c <= 8287 then 2 else 1) - else - if c <= 65278 - then (if c <= 12288 then 2 else 1) - else if c <= 65279 then 2 else 1 -let __sedlex_partition_11 c = - if c <= 9 then (-1) else if c <= 10 then 0 else (-1) -let __sedlex_partition_82 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_62 (c - 36))) - 1 - else (-1) -let __sedlex_partition_98 c = - if c <= 96 then (-1) else if c <= 97 then 0 else (-1) -let __sedlex_partition_64 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_63 (c - 36))) - 1 - else (-1) -let __sedlex_partition_132 c = - if c <= 35 - then (-1) - else - if c <= 8188 - then (Char.code (String.unsafe_get __sedlex_table_64 (c - 36))) - 1 - else - if c <= 8304 - then (-1) - else - if c <= 201546 - then - (if c <= 69864 - then - (if c <= 43754 - then - (if c <= 40981 - then - (if c <= 11623 - then - (if c <= 8504 - then - (if c <= 8472 - then - (if c <= 8450 - then - (if c <= 8319 - then - (if c <= 8305 - then 0 - else if c <= 8318 then (-1) else 0) - else - if c <= 8335 - then (-1) - else - if c <= 8348 - then 0 - else if c <= 8449 then (-1) else 0) - else - if c <= 8454 - then (-1) - else - if c <= 8467 - then - (if c <= 8455 - then 0 - else if c <= 8457 then (-1) else 0) - else - if c <= 8468 - then (-1) - else - if c <= 8469 - then 0 - else if c <= 8471 then (-1) else 0) - else - if c <= 8488 - then - (if c <= 8484 - then - (if c <= 8477 - then 0 - else if c <= 8483 then (-1) else 0) - else - if c <= 8485 - then (-1) - else - if c <= 8486 - then 0 - else if c <= 8487 then (-1) else 0) - else if c <= 8489 then (-1) else 0) - else - if c <= 11387 - then - (if c <= 8526 - then - (if c <= 8511 - then - (if c <= 8505 - then 0 - else if c <= 8507 then (-1) else 0) - else - if c <= 8516 - then (-1) - else - if c <= 8521 - then 0 - else if c <= 8525 then (-1) else 0) - else - if c <= 8543 - then (-1) - else - if c <= 8580 - then 0 - else - if c <= 8584 - then 0 - else if c <= 11263 then (-1) else 0) - else - if c <= 11507 - then - (if c <= 11492 - then 0 - else - if c <= 11498 - then (-1) - else - if c <= 11502 - then 0 - else if c <= 11505 then (-1) else 0) - else - if c <= 11519 - then (-1) - else - if c <= 11559 - then - (if c <= 11557 - then 0 - else if c <= 11558 then (-1) else 0) - else - if c <= 11564 - then (-1) - else - if c <= 11565 - then 0 - else if c <= 11567 then (-1) else 0) - else - if c <= 11630 - then (-1) - else - if c <= 12346 - then - (if c <= 11726 - then - (if c <= 11694 - then - (if c <= 11670 - then - (if c <= 11631 - then 0 - else if c <= 11647 then (-1) else 0) - else - if c <= 11679 - then (-1) - else - if c <= 11686 - then 0 - else if c <= 11687 then (-1) else 0) - else - if c <= 11695 - then (-1) - else - if c <= 11710 - then - (if c <= 11702 - then 0 - else if c <= 11703 then (-1) else 0) - else - if c <= 11711 - then (-1) - else - if c <= 11718 - then 0 - else if c <= 11719 then (-1) else 0) - else - if c <= 11727 - then (-1) - else - if c <= 12294 - then - (if c <= 11742 - then - (if c <= 11734 - then 0 - else if c <= 11735 then (-1) else 0) - else if c <= 12292 then (-1) else 0) - else - if c <= 12329 - then - (if c <= 12295 - then 0 - else if c <= 12320 then (-1) else 0) - else - if c <= 12336 - then (-1) - else - if c <= 12341 - then 0 - else if c <= 12343 then (-1) else 0) - else - if c <= 12542 - then - (if c <= 12444 - then - (if c <= 12348 - then 0 - else - if c <= 12352 - then (-1) - else - if c <= 12438 - then 0 - else if c <= 12442 then (-1) else 0) - else - if c <= 12447 - then 0 - else - if c <= 12448 - then (-1) - else - if c <= 12538 - then 0 - else if c <= 12539 then (-1) else 0) - else - if c <= 12735 - then - (if c <= 12591 - then - (if c <= 12543 - then 0 - else if c <= 12548 then (-1) else 0) - else - if c <= 12592 - then (-1) - else - if c <= 12686 - then 0 - else if c <= 12703 then (-1) else 0) - else - if c <= 12783 - then (-1) - else - if c <= 19903 - then - (if c <= 12799 - then 0 - else if c <= 13311 then (-1) else 0) - else if c <= 19967 then (-1) else 0) - else - if c <= 43013 - then - (if c <= 42863 - then - (if c <= 42605 - then - (if c <= 42507 - then - (if c <= 42231 - then - (if c <= 42124 - then 0 - else if c <= 42191 then (-1) else 0) - else - if c <= 42237 - then 0 - else if c <= 42239 then (-1) else 0) - else - if c <= 42527 - then - (if c <= 42508 - then 0 - else if c <= 42511 then (-1) else 0) - else - if c <= 42537 - then (-1) - else - if c <= 42539 - then 0 - else if c <= 42559 then (-1) else 0) - else - if c <= 42653 - then - (if c <= 42623 - then - (if c <= 42606 - then 0 - else if c <= 42622 then (-1) else 0) - else 0) - else - if c <= 42655 - then (-1) - else - if c <= 42735 - then 0 - else - if c <= 42774 - then (-1) - else - if c <= 42783 - then 0 - else if c <= 42785 then (-1) else 0) - else - if c <= 42963 - then - (if c <= 42894 - then - (if c <= 42887 - then 0 - else - if c <= 42888 - then 0 - else if c <= 42890 then (-1) else 0) - else - if c <= 42954 - then 0 - else - if c <= 42959 - then (-1) - else - if c <= 42961 - then 0 - else if c <= 42962 then (-1) else 0) - else - if c <= 42964 - then (-1) - else - if c <= 42999 - then - (if c <= 42996 - then - (if c <= 42969 - then 0 - else if c <= 42993 then (-1) else 0) - else 0) - else - if c <= 43002 - then 0 - else - if c <= 43009 - then 0 - else if c <= 43010 then (-1) else 0) - else - if c <= 43014 - then (-1) - else - if c <= 43518 - then - (if c <= 43301 - then - (if c <= 43187 - then - (if c <= 43042 - then - (if c <= 43018 - then 0 - else if c <= 43019 then (-1) else 0) - else - if c <= 43071 - then (-1) - else - if c <= 43123 - then 0 - else if c <= 43137 then (-1) else 0) - else - if c <= 43249 - then (-1) - else - if c <= 43259 - then - (if c <= 43255 - then 0 - else if c <= 43258 then (-1) else 0) - else - if c <= 43260 - then (-1) - else - if c <= 43262 - then 0 - else if c <= 43273 then (-1) else 0) - else - if c <= 43311 - then (-1) - else - if c <= 43471 - then - (if c <= 43388 - then - (if c <= 43334 - then 0 - else if c <= 43359 then (-1) else 0) - else - if c <= 43395 - then (-1) - else - if c <= 43442 - then 0 - else if c <= 43470 then (-1) else 0) - else - if c <= 43487 - then (-1) - else - if c <= 43494 - then - (if c <= 43492 - then 0 - else if c <= 43493 then (-1) else 0) - else - if c <= 43503 - then 0 - else if c <= 43513 then (-1) else 0) - else - if c <= 43519 - then (-1) - else - if c <= 43695 - then - (if c <= 43631 - then - (if c <= 43586 - then - (if c <= 43560 - then 0 - else if c <= 43583 then (-1) else 0) - else - if c <= 43587 - then (-1) - else - if c <= 43595 - then 0 - else if c <= 43615 then (-1) else 0) - else - if c <= 43638 - then 0 - else - if c <= 43641 - then (-1) - else - if c <= 43642 - then 0 - else if c <= 43645 then (-1) else 0) - else - if c <= 43696 - then (-1) - else - if c <= 43712 - then - (if c <= 43702 - then - (if c <= 43697 - then 0 - else if c <= 43700 then (-1) else 0) - else - if c <= 43704 - then (-1) - else - if c <= 43709 - then 0 - else if c <= 43711 then (-1) else 0) - else - if c <= 43713 - then (-1) - else - if c <= 43740 - then - (if c <= 43714 - then 0 - else if c <= 43738 then (-1) else 0) - else - if c <= 43741 - then 0 - else if c <= 43743 then (-1) else 0) - else - if c <= 43761 - then (-1) - else - if c <= 66511 - then - (if c <= 65019 - then - (if c <= 55291 - then - (if c <= 43866 - then - (if c <= 43790 - then - (if c <= 43764 - then 0 - else - if c <= 43776 - then (-1) - else - if c <= 43782 - then 0 - else if c <= 43784 then (-1) else 0) - else - if c <= 43792 - then (-1) - else - if c <= 43814 - then - (if c <= 43798 - then 0 - else if c <= 43807 then (-1) else 0) - else - if c <= 43815 - then (-1) - else - if c <= 43822 - then 0 - else if c <= 43823 then (-1) else 0) - else - if c <= 43867 - then (-1) - else - if c <= 43967 - then - (if c <= 43880 - then 0 - else - if c <= 43881 - then 0 - else if c <= 43887 then (-1) else 0) - else - if c <= 55203 - then - (if c <= 44002 - then 0 - else if c <= 44031 then (-1) else 0) - else - if c <= 55215 - then (-1) - else - if c <= 55238 - then 0 - else if c <= 55242 then (-1) else 0) - else - if c <= 63743 - then (-1) - else - if c <= 64316 - then - (if c <= 64279 - then - (if c <= 64217 - then - (if c <= 64109 - then 0 - else if c <= 64111 then (-1) else 0) - else - if c <= 64255 - then (-1) - else - if c <= 64262 - then 0 - else if c <= 64274 then (-1) else 0) - else - if c <= 64284 - then (-1) - else - if c <= 64296 - then - (if c <= 64285 - then 0 - else if c <= 64286 then (-1) else 0) - else - if c <= 64297 - then (-1) - else - if c <= 64310 - then 0 - else if c <= 64311 then (-1) else 0) - else - if c <= 64317 - then (-1) - else - if c <= 64433 - then - (if c <= 64321 - then - (if c <= 64318 - then 0 - else if c <= 64319 then (-1) else 0) - else - if c <= 64322 - then (-1) - else - if c <= 64324 - then 0 - else if c <= 64325 then (-1) else 0) - else - if c <= 64466 - then (-1) - else - if c <= 64911 - then - (if c <= 64829 - then 0 - else if c <= 64847 then (-1) else 0) - else - if c <= 64913 - then (-1) - else - if c <= 64967 - then 0 - else if c <= 65007 then (-1) else 0) - else - if c <= 65135 - then (-1) - else - if c <= 65594 - then - (if c <= 65439 - then - (if c <= 65370 - then - (if c <= 65276 - then - (if c <= 65140 - then 0 - else if c <= 65141 then (-1) else 0) - else - if c <= 65312 - then (-1) - else - if c <= 65338 - then 0 - else if c <= 65344 then (-1) else 0) - else if c <= 65381 then (-1) else 0) - else - if c <= 65495 - then - (if c <= 65479 - then - (if c <= 65470 - then 0 - else if c <= 65473 then (-1) else 0) - else - if c <= 65481 - then (-1) - else - if c <= 65487 - then 0 - else if c <= 65489 then (-1) else 0) - else - if c <= 65497 - then (-1) - else - if c <= 65547 - then - (if c <= 65500 - then 0 - else if c <= 65535 then (-1) else 0) - else - if c <= 65548 - then (-1) - else - if c <= 65574 - then 0 - else if c <= 65575 then (-1) else 0) - else - if c <= 65595 - then (-1) - else - if c <= 66335 - then - (if c <= 65786 - then - (if c <= 65613 - then - (if c <= 65597 - then 0 - else if c <= 65598 then (-1) else 0) - else - if c <= 65615 - then (-1) - else - if c <= 65629 - then 0 - else if c <= 65663 then (-1) else 0) - else - if c <= 65855 - then (-1) - else - if c <= 66204 - then - (if c <= 65908 - then 0 - else if c <= 66175 then (-1) else 0) - else - if c <= 66207 - then (-1) - else - if c <= 66256 - then 0 - else if c <= 66303 then (-1) else 0) - else - if c <= 66348 - then (-1) - else - if c <= 66378 - then 0 - else - if c <= 66383 - then (-1) - else - if c <= 66461 - then - (if c <= 66421 - then 0 - else if c <= 66431 then (-1) else 0) - else - if c <= 66463 - then (-1) - else - if c <= 66499 - then 0 - else if c <= 66503 then (-1) else 0) - else - if c <= 66512 - then (-1) - else - if c <= 67861 - then - (if c <= 67382 - then - (if c <= 66938 - then - (if c <= 66771 - then - (if c <= 66639 - then - (if c <= 66517 - then 0 - else if c <= 66559 then (-1) else 0) - else - if c <= 66717 - then 0 - else if c <= 66735 then (-1) else 0) - else - if c <= 66775 - then (-1) - else - if c <= 66855 - then - (if c <= 66811 - then 0 - else if c <= 66815 then (-1) else 0) - else - if c <= 66863 - then (-1) - else - if c <= 66915 - then 0 - else if c <= 66927 then (-1) else 0) - else - if c <= 66939 - then (-1) - else - if c <= 66977 - then - (if c <= 66962 - then - (if c <= 66954 - then 0 - else if c <= 66955 then (-1) else 0) - else - if c <= 66963 - then (-1) - else - if c <= 66965 - then 0 - else if c <= 66966 then (-1) else 0) - else - if c <= 66978 - then (-1) - else - if c <= 67001 - then - (if c <= 66993 - then 0 - else if c <= 66994 then (-1) else 0) - else - if c <= 67002 - then (-1) - else - if c <= 67004 - then 0 - else if c <= 67071 then (-1) else 0) - else - if c <= 67391 - then (-1) - else - if c <= 67637 - then - (if c <= 67504 - then - (if c <= 67431 - then - (if c <= 67413 - then 0 - else if c <= 67423 then (-1) else 0) - else - if c <= 67455 - then (-1) - else - if c <= 67461 - then 0 - else if c <= 67462 then (-1) else 0) - else - if c <= 67505 - then (-1) - else - if c <= 67589 - then - (if c <= 67514 - then 0 - else if c <= 67583 then (-1) else 0) - else - if c <= 67591 - then (-1) - else - if c <= 67592 - then 0 - else if c <= 67593 then (-1) else 0) - else - if c <= 67638 - then (-1) - else - if c <= 67702 - then - (if c <= 67644 - then - (if c <= 67640 - then 0 - else if c <= 67643 then (-1) else 0) - else - if c <= 67646 - then (-1) - else - if c <= 67669 - then 0 - else if c <= 67679 then (-1) else 0) - else - if c <= 67711 - then (-1) - else - if c <= 67826 - then - (if c <= 67742 - then 0 - else if c <= 67807 then (-1) else 0) - else - if c <= 67827 - then (-1) - else - if c <= 67829 - then 0 - else if c <= 67839 then (-1) else 0) - else - if c <= 67871 - then (-1) - else - if c <= 68680 - then - (if c <= 68220 - then - (if c <= 68096 - then - (if c <= 68023 - then - (if c <= 67897 - then 0 - else if c <= 67967 then (-1) else 0) - else - if c <= 68029 - then (-1) - else - if c <= 68031 - then 0 - else if c <= 68095 then (-1) else 0) - else - if c <= 68111 - then (-1) - else - if c <= 68119 - then - (if c <= 68115 - then 0 - else if c <= 68116 then (-1) else 0) - else - if c <= 68120 - then (-1) - else - if c <= 68149 - then 0 - else if c <= 68191 then (-1) else 0) - else - if c <= 68223 - then (-1) - else - if c <= 68405 - then - (if c <= 68295 - then - (if c <= 68252 - then 0 - else if c <= 68287 then (-1) else 0) - else - if c <= 68296 - then (-1) - else - if c <= 68324 - then 0 - else if c <= 68351 then (-1) else 0) - else - if c <= 68415 - then (-1) - else - if c <= 68466 - then - (if c <= 68437 - then 0 - else if c <= 68447 then (-1) else 0) - else - if c <= 68479 - then (-1) - else - if c <= 68497 - then 0 - else if c <= 68607 then (-1) else 0) - else - if c <= 68735 - then (-1) - else - if c <= 69445 - then - (if c <= 69289 - then - (if c <= 68850 - then - (if c <= 68786 - then 0 - else if c <= 68799 then (-1) else 0) - else - if c <= 68863 - then (-1) - else - if c <= 68899 - then 0 - else if c <= 69247 then (-1) else 0) - else - if c <= 69295 - then (-1) - else - if c <= 69404 - then - (if c <= 69297 - then 0 - else if c <= 69375 then (-1) else 0) - else - if c <= 69414 - then (-1) - else - if c <= 69415 - then 0 - else if c <= 69423 then (-1) else 0) - else - if c <= 69487 - then (-1) - else - if c <= 69687 - then - (if c <= 69572 - then - (if c <= 69505 - then 0 - else if c <= 69551 then (-1) else 0) - else - if c <= 69599 - then (-1) - else - if c <= 69622 - then 0 - else if c <= 69634 then (-1) else 0) - else - if c <= 69744 - then (-1) - else - if c <= 69749 - then - (if c <= 69746 - then 0 - else if c <= 69748 then (-1) else 0) - else - if c <= 69762 - then (-1) - else - if c <= 69807 - then 0 - else if c <= 69839 then (-1) else 0) - else - if c <= 69890 - then (-1) - else - if c <= 120512 - then - (if c <= 72847 - then - (if c <= 70855 - then - (if c <= 70312 - then - (if c <= 70106 - then - (if c <= 70002 - then - (if c <= 69956 - then - (if c <= 69926 - then 0 - else if c <= 69955 then (-1) else 0) - else - if c <= 69958 - then (-1) - else - if c <= 69959 - then 0 - else if c <= 69967 then (-1) else 0) - else - if c <= 70005 - then (-1) - else - if c <= 70066 - then - (if c <= 70006 - then 0 - else if c <= 70018 then (-1) else 0) - else - if c <= 70080 - then (-1) - else - if c <= 70084 - then 0 - else if c <= 70105 then (-1) else 0) - else - if c <= 70107 - then (-1) - else - if c <= 70278 - then - (if c <= 70161 - then - (if c <= 70108 - then 0 - else if c <= 70143 then (-1) else 0) - else - if c <= 70162 - then (-1) - else - if c <= 70187 - then 0 - else if c <= 70271 then (-1) else 0) - else - if c <= 70279 - then (-1) - else - if c <= 70285 - then - (if c <= 70280 - then 0 - else if c <= 70281 then (-1) else 0) - else - if c <= 70286 - then (-1) - else - if c <= 70301 - then 0 - else if c <= 70302 then (-1) else 0) - else - if c <= 70319 - then (-1) - else - if c <= 70461 - then - (if c <= 70440 - then - (if c <= 70412 - then - (if c <= 70366 - then 0 - else if c <= 70404 then (-1) else 0) - else - if c <= 70414 - then (-1) - else - if c <= 70416 - then 0 - else if c <= 70418 then (-1) else 0) - else - if c <= 70441 - then (-1) - else - if c <= 70451 - then - (if c <= 70448 - then 0 - else if c <= 70449 then (-1) else 0) - else - if c <= 70452 - then (-1) - else - if c <= 70457 - then 0 - else if c <= 70460 then (-1) else 0) - else - if c <= 70479 - then (-1) - else - if c <= 70730 - then - (if c <= 70497 - then - (if c <= 70480 - then 0 - else if c <= 70492 then (-1) else 0) - else - if c <= 70655 - then (-1) - else - if c <= 70708 - then 0 - else if c <= 70726 then (-1) else 0) - else - if c <= 70750 - then (-1) - else - if c <= 70831 - then - (if c <= 70753 - then 0 - else if c <= 70783 then (-1) else 0) - else - if c <= 70851 - then (-1) - else - if c <= 70853 - then 0 - else if c <= 70854 then (-1) else 0) - else - if c <= 71039 - then (-1) - else - if c <= 71999 - then - (if c <= 71494 - then - (if c <= 71236 - then - (if c <= 71131 - then - (if c <= 71086 - then 0 - else if c <= 71127 then (-1) else 0) - else - if c <= 71167 - then (-1) - else - if c <= 71215 - then 0 - else if c <= 71235 then (-1) else 0) - else - if c <= 71295 - then (-1) - else - if c <= 71352 - then - (if c <= 71338 - then 0 - else if c <= 71351 then (-1) else 0) - else - if c <= 71423 - then (-1) - else - if c <= 71450 - then 0 - else if c <= 71487 then (-1) else 0) - else - if c <= 71679 - then (-1) - else - if c <= 71945 - then - (if c <= 71903 - then - (if c <= 71723 - then 0 - else if c <= 71839 then (-1) else 0) - else - if c <= 71934 - then (-1) - else - if c <= 71942 - then 0 - else if c <= 71944 then (-1) else 0) - else - if c <= 71947 - then (-1) - else - if c <= 71958 - then - (if c <= 71955 - then 0 - else if c <= 71956 then (-1) else 0) - else - if c <= 71959 - then (-1) - else - if c <= 71983 - then 0 - else if c <= 71998 then (-1) else 0) - else - if c <= 72000 - then (-1) - else - if c <= 72250 - then - (if c <= 72161 - then - (if c <= 72103 - then - (if c <= 72001 - then 0 - else if c <= 72095 then (-1) else 0) - else - if c <= 72105 - then (-1) - else - if c <= 72144 - then 0 - else if c <= 72160 then (-1) else 0) - else - if c <= 72162 - then (-1) - else - if c <= 72192 - then - (if c <= 72163 - then 0 - else if c <= 72191 then (-1) else 0) - else - if c <= 72202 - then (-1) - else - if c <= 72242 - then 0 - else if c <= 72249 then (-1) else 0) - else - if c <= 72271 - then (-1) - else - if c <= 72440 - then - (if c <= 72329 - then - (if c <= 72272 - then 0 - else if c <= 72283 then (-1) else 0) - else - if c <= 72348 - then (-1) - else - if c <= 72349 - then 0 - else if c <= 72367 then (-1) else 0) - else - if c <= 72703 - then (-1) - else - if c <= 72750 - then - (if c <= 72712 - then 0 - else if c <= 72713 then (-1) else 0) - else - if c <= 72767 - then (-1) - else - if c <= 72768 - then 0 - else if c <= 72817 then (-1) else 0) - else - if c <= 72959 - then (-1) - else - if c <= 101589 - then - (if c <= 83526 - then - (if c <= 73112 - then - (if c <= 73030 - then - (if c <= 72969 - then - (if c <= 72966 - then 0 - else if c <= 72967 then (-1) else 0) - else - if c <= 72970 - then (-1) - else - if c <= 73008 - then 0 - else if c <= 73029 then (-1) else 0) - else - if c <= 73055 - then (-1) - else - if c <= 73064 - then - (if c <= 73061 - then 0 - else if c <= 73062 then (-1) else 0) - else - if c <= 73065 - then (-1) - else - if c <= 73097 - then 0 - else if c <= 73111 then (-1) else 0) - else - if c <= 73439 - then (-1) - else - if c <= 74862 - then - (if c <= 73648 - then - (if c <= 73458 - then 0 - else if c <= 73647 then (-1) else 0) - else - if c <= 73727 - then (-1) - else - if c <= 74649 - then 0 - else if c <= 74751 then (-1) else 0) - else - if c <= 74879 - then (-1) - else - if c <= 77808 - then - (if c <= 75075 - then 0 - else if c <= 77711 then (-1) else 0) - else - if c <= 77823 - then (-1) - else - if c <= 78894 - then 0 - else if c <= 82943 then (-1) else 0) - else - if c <= 92159 - then (-1) - else - if c <= 93071 - then - (if c <= 92909 - then - (if c <= 92766 - then - (if c <= 92728 - then 0 - else if c <= 92735 then (-1) else 0) - else - if c <= 92783 - then (-1) - else - if c <= 92862 - then 0 - else if c <= 92879 then (-1) else 0) - else - if c <= 92927 - then (-1) - else - if c <= 92995 - then - (if c <= 92975 - then 0 - else if c <= 92991 then (-1) else 0) - else - if c <= 93026 - then (-1) - else - if c <= 93047 - then 0 - else if c <= 93052 then (-1) else 0) - else - if c <= 93759 - then (-1) - else - if c <= 94111 - then - (if c <= 94026 - then - (if c <= 93823 - then 0 - else if c <= 93951 then (-1) else 0) - else - if c <= 94031 - then (-1) - else - if c <= 94032 - then 0 - else if c <= 94098 then (-1) else 0) - else - if c <= 94175 - then (-1) - else - if c <= 94179 - then - (if c <= 94177 - then 0 - else if c <= 94178 then (-1) else 0) - else - if c <= 94207 - then (-1) - else - if c <= 100343 - then 0 - else if c <= 100351 then (-1) else 0) - else - if c <= 101631 - then (-1) - else - if c <= 119970 - then - (if c <= 111355 - then - (if c <= 110590 - then - (if c <= 110579 - then - (if c <= 101640 - then 0 - else if c <= 110575 then (-1) else 0) - else - if c <= 110580 - then (-1) - else - if c <= 110587 - then 0 - else if c <= 110588 then (-1) else 0) - else - if c <= 110591 - then (-1) - else - if c <= 110930 - then - (if c <= 110882 - then 0 - else if c <= 110927 then (-1) else 0) - else - if c <= 110947 - then (-1) - else - if c <= 110951 - then 0 - else if c <= 110959 then (-1) else 0) - else - if c <= 113663 - then (-1) - else - if c <= 113817 - then - (if c <= 113788 - then - (if c <= 113770 - then 0 - else if c <= 113775 then (-1) else 0) - else - if c <= 113791 - then (-1) - else - if c <= 113800 - then 0 - else if c <= 113807 then (-1) else 0) - else - if c <= 119807 - then (-1) - else - if c <= 119964 - then - (if c <= 119892 - then 0 - else if c <= 119893 then (-1) else 0) - else - if c <= 119965 - then (-1) - else - if c <= 119967 - then 0 - else if c <= 119969 then (-1) else 0) - else - if c <= 119972 - then (-1) - else - if c <= 120084 - then - (if c <= 119995 - then - (if c <= 119980 - then - (if c <= 119974 - then 0 - else if c <= 119976 then (-1) else 0) - else - if c <= 119981 - then (-1) - else - if c <= 119993 - then 0 - else if c <= 119994 then (-1) else 0) - else - if c <= 119996 - then (-1) - else - if c <= 120069 - then - (if c <= 120003 - then 0 - else if c <= 120004 then (-1) else 0) - else - if c <= 120070 - then (-1) - else - if c <= 120074 - then 0 - else if c <= 120076 then (-1) else 0) - else - if c <= 120085 - then (-1) - else - if c <= 120132 - then - (if c <= 120121 - then - (if c <= 120092 - then 0 - else if c <= 120093 then (-1) else 0) - else - if c <= 120122 - then (-1) - else - if c <= 120126 - then 0 - else if c <= 120127 then (-1) else 0) - else - if c <= 120133 - then (-1) - else - if c <= 120144 - then - (if c <= 120134 - then 0 - else if c <= 120137 then (-1) else 0) - else - if c <= 120145 - then (-1) - else - if c <= 120485 - then 0 - else - if c <= 120487 then (-1) else 0) - else - if c <= 120513 - then (-1) - else - if c <= 195101 - then - (if c <= 126519 - then - (if c <= 123214 - then - (if c <= 120744 - then - (if c <= 120628 - then - (if c <= 120570 - then - (if c <= 120538 - then 0 - else if c <= 120539 then (-1) else 0) - else - if c <= 120571 - then (-1) - else - if c <= 120596 - then 0 - else if c <= 120597 then (-1) else 0) - else - if c <= 120629 - then (-1) - else - if c <= 120686 - then - (if c <= 120654 - then 0 - else if c <= 120655 then (-1) else 0) - else - if c <= 120687 - then (-1) - else - if c <= 120712 - then 0 - else if c <= 120713 then (-1) else 0) - else - if c <= 120745 - then (-1) - else - if c <= 122634 - then - (if c <= 120779 - then - (if c <= 120770 - then 0 - else if c <= 120771 then (-1) else 0) - else if c <= 122623 then (-1) else 0) - else - if c <= 123180 - then - (if c <= 122654 - then 0 - else if c <= 123135 then (-1) else 0) - else - if c <= 123190 - then (-1) - else - if c <= 123197 - then 0 - else if c <= 123213 then (-1) else 0) - else - if c <= 123535 - then (-1) - else - if c <= 125251 - then - (if c <= 124907 - then - (if c <= 123627 - then - (if c <= 123565 - then 0 - else if c <= 123583 then (-1) else 0) - else - if c <= 124895 - then (-1) - else - if c <= 124902 - then 0 - else if c <= 124903 then (-1) else 0) - else - if c <= 124908 - then (-1) - else - if c <= 124926 - then - (if c <= 124910 - then 0 - else if c <= 124911 then (-1) else 0) - else - if c <= 124927 - then (-1) - else - if c <= 125124 - then 0 - else if c <= 125183 then (-1) else 0) - else - if c <= 125258 - then (-1) - else - if c <= 126498 - then - (if c <= 126467 - then - (if c <= 125259 - then 0 - else if c <= 126463 then (-1) else 0) - else - if c <= 126468 - then (-1) - else - if c <= 126495 - then 0 - else if c <= 126496 then (-1) else 0) - else - if c <= 126499 - then (-1) - else - if c <= 126503 - then - (if c <= 126500 - then 0 - else if c <= 126502 then (-1) else 0) - else - if c <= 126504 - then (-1) - else - if c <= 126514 - then 0 - else if c <= 126515 then (-1) else 0) - else - if c <= 126520 - then (-1) - else - if c <= 126564 - then - (if c <= 126546 - then - (if c <= 126535 - then - (if c <= 126523 - then - (if c <= 126521 - then 0 - else if c <= 126522 then (-1) else 0) - else - if c <= 126529 - then (-1) - else - if c <= 126530 - then 0 - else if c <= 126534 then (-1) else 0) - else - if c <= 126536 - then (-1) - else - if c <= 126539 - then - (if c <= 126537 - then 0 - else if c <= 126538 then (-1) else 0) - else - if c <= 126540 - then (-1) - else - if c <= 126543 - then 0 - else if c <= 126544 then (-1) else 0) - else - if c <= 126547 - then (-1) - else - if c <= 126555 - then - (if c <= 126551 - then - (if c <= 126548 - then 0 - else if c <= 126550 then (-1) else 0) - else - if c <= 126552 - then (-1) - else - if c <= 126553 - then 0 - else if c <= 126554 then (-1) else 0) - else - if c <= 126556 - then (-1) - else - if c <= 126559 - then - (if c <= 126557 - then 0 - else if c <= 126558 then (-1) else 0) - else - if c <= 126560 - then (-1) - else - if c <= 126562 - then 0 - else if c <= 126563 then (-1) else 0) - else - if c <= 126566 - then (-1) - else - if c <= 126627 - then - (if c <= 126588 - then - (if c <= 126578 - then - (if c <= 126570 - then 0 - else if c <= 126571 then (-1) else 0) - else - if c <= 126579 - then (-1) - else - if c <= 126583 - then 0 - else if c <= 126584 then (-1) else 0) - else - if c <= 126589 - then (-1) - else - if c <= 126601 - then - (if c <= 126590 - then 0 - else if c <= 126591 then (-1) else 0) - else - if c <= 126602 - then (-1) - else - if c <= 126619 - then 0 - else if c <= 126624 then (-1) else 0) - else - if c <= 126628 - then (-1) - else - if c <= 177976 - then - (if c <= 126651 - then - (if c <= 126633 - then 0 - else if c <= 126634 then (-1) else 0) - else - if c <= 131071 - then (-1) - else - if c <= 173791 - then 0 - else if c <= 173823 then (-1) else 0) - else - if c <= 177983 - then (-1) - else - if c <= 183969 - then - (if c <= 178205 - then 0 - else if c <= 178207 then (-1) else 0) - else - if c <= 183983 - then (-1) - else - if c <= 191456 - then 0 - else - if c <= 194559 then (-1) else 0) - else if c <= 196607 then (-1) else 0) - else (-1) -let __sedlex_partition_83 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_65 (c - 36))) - 1 - else (-1) -let __sedlex_partition_128 c = - if c <= 106 then (-1) else if c <= 107 then 0 else (-1) -let __sedlex_partition_14 c = - if c <= 13 - then (Char.code (String.unsafe_get __sedlex_table_66 (c - (-1)))) - 1 - else if c <= 8233 then (if c <= 8231 then 1 else 2) else 1 -let __sedlex_partition_46 c = - if c <= 47 - then (-1) - else - if c <= 95 - then (Char.code (String.unsafe_get __sedlex_table_67 (c - 48))) - 1 - else (-1) -let __sedlex_partition_87 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_68 (c - 36))) - 1 - else (-1) -let __sedlex_partition_103 c = - if c <= 92 - then (Char.code (String.unsafe_get __sedlex_table_69 (c - (-1)))) - 1 - else if c <= 8233 then (if c <= 8231 then 1 else 2) else 1 -let __sedlex_partition_75 c = - if c <= 100 then (-1) else if c <= 101 then 0 else (-1) -let __sedlex_partition_116 c = - if c <= 58 then (-1) else if c <= 59 then 0 else (-1) -let __sedlex_partition_125 c = - if c <= 8 - then (-1) - else - if c <= 5760 - then (Char.code (String.unsafe_get __sedlex_table_70 (c - 9))) - 1 - else - if c <= 8191 - then (-1) - else - if c <= 65279 - then - (if c <= 12288 - then - (if c <= 8239 - then (if c <= 8202 then 0 else if c <= 8238 then (-1) else 0) - else - if c <= 8286 - then (-1) - else if c <= 8287 then 0 else if c <= 12287 then (-1) else 0) - else if c <= 65278 then (-1) else 0) - else (-1) -let __sedlex_partition_61 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_71 (c - 36))) - 1 - else (-1) -let __sedlex_partition_108 c = - if c <= 41 - then (-1) - else - if c <= 47 - then (Char.code (String.unsafe_get __sedlex_table_72 (c - 42))) - 1 - else (-1) -let __sedlex_partition_81 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_73 (c - 36))) - 1 - else (-1) -let __sedlex_partition_126 c = - if c <= 8191 - then (Char.code (String.unsafe_get __sedlex_table_74 (c - (-1)))) - 1 - else - if c <= 194559 - then - (if c <= 69599 - then - (if c <= 43711 - then - (if c <= 12703 - then - (if c <= 11519 - then - (if c <= 8489 - then - (if c <= 8454 - then - (if c <= 8304 - then - (if c <= 8238 - then - (if c <= 8231 - then (if c <= 8202 then 2 else 1) - else if c <= 8233 then 3 else 1) - else - if c <= 8286 - then (if c <= 8239 then 2 else 1) - else if c <= 8287 then 2 else 1) - else - if c <= 8335 - then - (if c <= 8318 - then (if c <= 8305 then 6 else 1) - else if c <= 8319 then 6 else 1) - else - if c <= 8449 - then (if c <= 8348 then 6 else 1) - else if c <= 8450 then 6 else 1) - else - if c <= 8477 - then - (if c <= 8468 - then - (if c <= 8457 - then (if c <= 8455 then 6 else 1) - else if c <= 8467 then 6 else 1) - else - if c <= 8471 - then (if c <= 8469 then 6 else 1) - else 6) - else - if c <= 8485 - then - (if c <= 8483 - then 1 - else if c <= 8484 then 6 else 1) - else - if c <= 8487 - then (if c <= 8486 then 6 else 1) - else if c <= 8488 then 6 else 1) - else - if c <= 8543 - then - (if c <= 8505 - then 6 - else - if c <= 8516 - then - (if c <= 8507 - then 1 - else if c <= 8511 then 6 else 1) - else - if c <= 8525 - then (if c <= 8521 then 6 else 1) - else if c <= 8526 then 6 else 1) - else - if c <= 11389 - then - (if c <= 8584 - then 6 - else if c <= 11263 then 1 else 6) - else - if c <= 11498 - then (if c <= 11492 then 6 else 1) - else - if c <= 11505 - then (if c <= 11502 then 6 else 1) - else if c <= 11507 then 6 else 1) - else - if c <= 12294 - then - (if c <= 11695 - then - (if c <= 11630 - then - (if c <= 11564 - then - (if c <= 11558 - then (if c <= 11557 then 6 else 1) - else if c <= 11559 then 6 else 1) - else - if c <= 11567 - then (if c <= 11565 then 6 else 1) - else if c <= 11623 then 6 else 1) - else - if c <= 11679 - then - (if c <= 11647 - then (if c <= 11631 then 6 else 1) - else if c <= 11670 then 6 else 1) - else - if c <= 11687 - then (if c <= 11686 then 6 else 1) - else if c <= 11694 then 6 else 1) - else - if c <= 11727 - then - (if c <= 11711 - then - (if c <= 11703 - then (if c <= 11702 then 6 else 1) - else if c <= 11710 then 6 else 1) - else - if c <= 11719 - then (if c <= 11718 then 6 else 1) - else if c <= 11726 then 6 else 1) - else - if c <= 12287 - then - (if c <= 11735 - then (if c <= 11734 then 6 else 1) - else if c <= 11742 then 6 else 1) - else - if c <= 12292 - then (if c <= 12288 then 2 else 1) - else 6) - else - if c <= 12442 - then - (if c <= 12343 - then - (if c <= 12320 - then (if c <= 12295 then 6 else 1) - else - if c <= 12336 - then (if c <= 12329 then 6 else 1) - else if c <= 12341 then 6 else 1) - else - if c <= 12348 - then 6 - else - if c <= 12352 - then 1 - else if c <= 12438 then 6 else 1) - else - if c <= 12539 - then - (if c <= 12447 - then 6 - else - if c <= 12448 - then 1 - else if c <= 12538 then 6 else 1) - else - if c <= 12548 - then (if c <= 12543 then 6 else 1) - else - if c <= 12592 - then (if c <= 12591 then 6 else 1) - else if c <= 12686 then 6 else 1) - else - if c <= 42999 - then - (if c <= 42653 - then - (if c <= 42239 - then - (if c <= 40981 - then - (if c <= 13311 - then - (if c <= 12783 - then (if c <= 12735 then 6 else 1) - else if c <= 12799 then 6 else 1) - else - if c <= 19967 - then (if c <= 19903 then 6 else 1) - else 6) - else - if c <= 42191 - then (if c <= 42124 then 6 else 1) - else if c <= 42237 then 6 else 1) - else - if c <= 42559 - then - (if c <= 42511 - then (if c <= 42508 then 6 else 1) - else - if c <= 42537 - then (if c <= 42527 then 6 else 1) - else if c <= 42539 then 6 else 1) - else - if c <= 42622 - then (if c <= 42606 then 6 else 1) - else 6) - else - if c <= 42890 - then - (if c <= 42785 - then - (if c <= 42735 - then (if c <= 42655 then 1 else 6) - else - if c <= 42774 - then 1 - else if c <= 42783 then 6 else 1) - else - if c <= 42887 - then 6 - else if c <= 42888 then 6 else 1) - else - if c <= 42962 - then - (if c <= 42954 - then 6 - else - if c <= 42959 - then 1 - else if c <= 42961 then 6 else 1) - else - if c <= 42993 - then - (if c <= 42964 - then (if c <= 42963 then 6 else 1) - else if c <= 42969 then 6 else 1) - else 6) - else - if c <= 43470 - then - (if c <= 43137 - then - (if c <= 43010 - then - (if c <= 43002 - then 6 - else if c <= 43009 then 6 else 1) - else - if c <= 43019 - then - (if c <= 43014 - then (if c <= 43013 then 6 else 1) - else if c <= 43018 then 6 else 1) - else - if c <= 43071 - then (if c <= 43042 then 6 else 1) - else if c <= 43123 then 6 else 1) - else - if c <= 43273 - then - (if c <= 43258 - then - (if c <= 43249 - then (if c <= 43187 then 6 else 1) - else if c <= 43255 then 6 else 1) - else - if c <= 43260 - then (if c <= 43259 then 6 else 1) - else if c <= 43262 then 6 else 1) - else - if c <= 43359 - then - (if c <= 43311 - then (if c <= 43301 then 6 else 1) - else if c <= 43334 then 6 else 1) - else - if c <= 43395 - then (if c <= 43388 then 6 else 1) - else if c <= 43442 then 6 else 1) - else - if c <= 43615 - then - (if c <= 43513 - then - (if c <= 43493 - then - (if c <= 43487 - then (if c <= 43471 then 6 else 1) - else if c <= 43492 then 6 else 1) - else if c <= 43503 then 6 else 1) - else - if c <= 43583 - then - (if c <= 43519 - then (if c <= 43518 then 6 else 1) - else if c <= 43560 then 6 else 1) - else - if c <= 43587 - then (if c <= 43586 then 6 else 1) - else if c <= 43595 then 6 else 1) - else - if c <= 43645 - then - (if c <= 43638 - then 6 - else - if c <= 43641 - then 1 - else if c <= 43642 then 6 else 1) - else - if c <= 43700 - then - (if c <= 43696 - then (if c <= 43695 then 6 else 1) - else if c <= 43697 then 6 else 1) - else - if c <= 43704 - then (if c <= 43702 then 6 else 1) - else if c <= 43709 then 6 else 1) - else - if c <= 66377 - then - (if c <= 64325 - then - (if c <= 43887 - then - (if c <= 43784 - then - (if c <= 43743 - then - (if c <= 43738 - then - (if c <= 43713 - then (if c <= 43712 then 6 else 1) - else if c <= 43714 then 6 else 1) - else if c <= 43741 then 6 else 1) - else - if c <= 43764 - then - (if c <= 43761 - then (if c <= 43754 then 6 else 1) - else 6) - else - if c <= 43776 - then 1 - else if c <= 43782 then 6 else 1) - else - if c <= 43823 - then - (if c <= 43807 - then - (if c <= 43792 - then (if c <= 43790 then 6 else 1) - else if c <= 43798 then 6 else 1) - else - if c <= 43815 - then (if c <= 43814 then 6 else 1) - else if c <= 43822 then 6 else 1) - else - if c <= 43880 - then - (if c <= 43867 - then (if c <= 43866 then 6 else 1) - else 6) - else if c <= 43881 then 6 else 1) - else - if c <= 64274 - then - (if c <= 55242 - then - (if c <= 44031 - then (if c <= 44002 then 6 else 1) - else - if c <= 55215 - then (if c <= 55203 then 6 else 1) - else if c <= 55238 then 6 else 1) - else - if c <= 64111 - then - (if c <= 63743 - then (if c <= 55291 then 6 else 1) - else if c <= 64109 then 6 else 1) - else - if c <= 64255 - then (if c <= 64217 then 6 else 1) - else if c <= 64262 then 6 else 1) - else - if c <= 64311 - then - (if c <= 64286 - then - (if c <= 64284 - then (if c <= 64279 then 6 else 1) - else if c <= 64285 then 6 else 1) - else - if c <= 64297 - then (if c <= 64296 then 6 else 1) - else if c <= 64310 then 6 else 1) - else - if c <= 64319 - then - (if c <= 64317 - then (if c <= 64316 then 6 else 1) - else if c <= 64318 then 6 else 1) - else - if c <= 64322 - then (if c <= 64321 then 6 else 1) - else if c <= 64324 then 6 else 1) - else - if c <= 65481 - then - (if c <= 65312 - then - (if c <= 65007 - then - (if c <= 64847 - then - (if c <= 64466 - then (if c <= 64433 then 6 else 1) - else if c <= 64829 then 6 else 1) - else - if c <= 64913 - then (if c <= 64911 then 6 else 1) - else if c <= 64967 then 6 else 1) - else - if c <= 65141 - then - (if c <= 65135 - then (if c <= 65019 then 6 else 1) - else if c <= 65140 then 6 else 1) - else - if c <= 65278 - then (if c <= 65276 then 6 else 1) - else if c <= 65279 then 2 else 1) - else - if c <= 65437 - then - (if c <= 65381 - then - (if c <= 65344 - then (if c <= 65338 then 6 else 1) - else if c <= 65370 then 6 else 1) - else 6) - else - if c <= 65470 - then 6 - else - if c <= 65473 - then 1 - else if c <= 65479 then 6 else 1) - else - if c <= 65615 - then - (if c <= 65548 - then - (if c <= 65497 - then - (if c <= 65489 - then (if c <= 65487 then 6 else 1) - else if c <= 65495 then 6 else 1) - else - if c <= 65535 - then (if c <= 65500 then 6 else 1) - else if c <= 65547 then 6 else 1) - else - if c <= 65595 - then - (if c <= 65575 - then (if c <= 65574 then 6 else 1) - else if c <= 65594 then 6 else 1) - else - if c <= 65598 - then (if c <= 65597 then 6 else 1) - else if c <= 65613 then 6 else 1) - else - if c <= 66207 - then - (if c <= 65855 - then - (if c <= 65663 - then (if c <= 65629 then 6 else 1) - else if c <= 65786 then 6 else 1) - else - if c <= 66175 - then (if c <= 65908 then 6 else 1) - else if c <= 66204 then 6 else 1) - else - if c <= 66348 - then - (if c <= 66303 - then (if c <= 66256 then 6 else 1) - else if c <= 66335 then 6 else 1) - else 6) - else - if c <= 67646 - then - (if c <= 66963 - then - (if c <= 66717 - then - (if c <= 66463 - then - (if c <= 66383 - then (if c <= 66378 then 6 else 1) - else - if c <= 66431 - then (if c <= 66421 then 6 else 1) - else if c <= 66461 then 6 else 1) - else - if c <= 66512 - then - (if c <= 66503 - then (if c <= 66499 then 6 else 1) - else if c <= 66511 then 6 else 1) - else - if c <= 66559 - then (if c <= 66517 then 6 else 1) - else 6) - else - if c <= 66863 - then - (if c <= 66775 - then - (if c <= 66735 - then 1 - else if c <= 66771 then 6 else 1) - else - if c <= 66815 - then (if c <= 66811 then 6 else 1) - else if c <= 66855 then 6 else 1) - else - if c <= 66939 - then - (if c <= 66927 - then (if c <= 66915 then 6 else 1) - else if c <= 66938 then 6 else 1) - else - if c <= 66955 - then (if c <= 66954 then 6 else 1) - else if c <= 66962 then 6 else 1) - else - if c <= 67455 - then - (if c <= 67002 - then - (if c <= 66978 - then - (if c <= 66966 - then (if c <= 66965 then 6 else 1) - else if c <= 66977 then 6 else 1) - else - if c <= 66994 - then (if c <= 66993 then 6 else 1) - else if c <= 67001 then 6 else 1) - else - if c <= 67391 - then - (if c <= 67071 - then (if c <= 67004 then 6 else 1) - else if c <= 67382 then 6 else 1) - else - if c <= 67423 - then (if c <= 67413 then 6 else 1) - else if c <= 67431 then 6 else 1) - else - if c <= 67591 - then - (if c <= 67505 - then - (if c <= 67462 - then (if c <= 67461 then 6 else 1) - else if c <= 67504 then 6 else 1) - else - if c <= 67583 - then (if c <= 67514 then 6 else 1) - else if c <= 67589 then 6 else 1) - else - if c <= 67638 - then - (if c <= 67593 - then (if c <= 67592 then 6 else 1) - else if c <= 67637 then 6 else 1) - else - if c <= 67643 - then (if c <= 67640 then 6 else 1) - else if c <= 67644 then 6 else 1) - else - if c <= 68296 - then - (if c <= 68029 - then - (if c <= 67827 - then - (if c <= 67711 - then - (if c <= 67679 - then (if c <= 67669 then 6 else 1) - else if c <= 67702 then 6 else 1) - else - if c <= 67807 - then (if c <= 67742 then 6 else 1) - else if c <= 67826 then 6 else 1) - else - if c <= 67871 - then - (if c <= 67839 - then (if c <= 67829 then 6 else 1) - else if c <= 67861 then 6 else 1) - else - if c <= 67967 - then (if c <= 67897 then 6 else 1) - else if c <= 68023 then 6 else 1) - else - if c <= 68120 - then - (if c <= 68111 - then - (if c <= 68095 - then (if c <= 68031 then 6 else 1) - else if c <= 68096 then 6 else 1) - else - if c <= 68116 - then (if c <= 68115 then 6 else 1) - else if c <= 68119 then 6 else 1) - else - if c <= 68223 - then - (if c <= 68191 - then (if c <= 68149 then 6 else 1) - else if c <= 68220 then 6 else 1) - else - if c <= 68287 - then (if c <= 68252 then 6 else 1) - else if c <= 68295 then 6 else 1) - else - if c <= 68863 - then - (if c <= 68479 - then - (if c <= 68415 - then - (if c <= 68351 - then (if c <= 68324 then 6 else 1) - else if c <= 68405 then 6 else 1) - else - if c <= 68447 - then (if c <= 68437 then 6 else 1) - else if c <= 68466 then 6 else 1) - else - if c <= 68735 - then - (if c <= 68607 - then (if c <= 68497 then 6 else 1) - else if c <= 68680 then 6 else 1) - else - if c <= 68799 - then (if c <= 68786 then 6 else 1) - else if c <= 68850 then 6 else 1) - else - if c <= 69414 - then - (if c <= 69295 - then - (if c <= 69247 - then (if c <= 68899 then 6 else 1) - else if c <= 69289 then 6 else 1) - else - if c <= 69375 - then (if c <= 69297 then 6 else 1) - else if c <= 69404 then 6 else 1) - else - if c <= 69487 - then - (if c <= 69423 - then (if c <= 69415 then 6 else 1) - else if c <= 69445 then 6 else 1) - else - if c <= 69551 - then (if c <= 69505 then 6 else 1) - else if c <= 69572 then 6 else 1) - else - if c <= 120122 - then - (if c <= 72348 - then - (if c <= 70655 - then - (if c <= 70162 - then - (if c <= 69958 - then - (if c <= 69762 - then - (if c <= 69744 - then - (if c <= 69634 - then (if c <= 69622 then 6 else 1) - else if c <= 69687 then 6 else 1) - else - if c <= 69748 - then (if c <= 69746 then 6 else 1) - else if c <= 69749 then 6 else 1) - else - if c <= 69890 - then - (if c <= 69839 - then (if c <= 69807 then 6 else 1) - else if c <= 69864 then 6 else 1) - else - if c <= 69955 - then (if c <= 69926 then 6 else 1) - else if c <= 69956 then 6 else 1) - else - if c <= 70080 - then - (if c <= 70005 - then - (if c <= 69967 - then (if c <= 69959 then 6 else 1) - else if c <= 70002 then 6 else 1) - else - if c <= 70018 - then (if c <= 70006 then 6 else 1) - else if c <= 70066 then 6 else 1) - else - if c <= 70107 - then - (if c <= 70105 - then (if c <= 70084 then 6 else 1) - else if c <= 70106 then 6 else 1) - else - if c <= 70143 - then (if c <= 70108 then 6 else 1) - else if c <= 70161 then 6 else 1) - else - if c <= 70414 - then - (if c <= 70286 - then - (if c <= 70279 - then - (if c <= 70271 - then (if c <= 70187 then 6 else 1) - else if c <= 70278 then 6 else 1) - else - if c <= 70281 - then (if c <= 70280 then 6 else 1) - else if c <= 70285 then 6 else 1) - else - if c <= 70319 - then - (if c <= 70302 - then (if c <= 70301 then 6 else 1) - else if c <= 70312 then 6 else 1) - else - if c <= 70404 - then (if c <= 70366 then 6 else 1) - else if c <= 70412 then 6 else 1) - else - if c <= 70452 - then - (if c <= 70441 - then - (if c <= 70418 - then (if c <= 70416 then 6 else 1) - else if c <= 70440 then 6 else 1) - else - if c <= 70449 - then (if c <= 70448 then 6 else 1) - else if c <= 70451 then 6 else 1) - else - if c <= 70479 - then - (if c <= 70460 - then (if c <= 70457 then 6 else 1) - else if c <= 70461 then 6 else 1) - else - if c <= 70492 - then (if c <= 70480 then 6 else 1) - else if c <= 70497 then 6 else 1) - else - if c <= 71934 - then - (if c <= 71167 - then - (if c <= 70851 - then - (if c <= 70750 - then - (if c <= 70726 - then (if c <= 70708 then 6 else 1) - else if c <= 70730 then 6 else 1) - else - if c <= 70783 - then (if c <= 70753 then 6 else 1) - else if c <= 70831 then 6 else 1) - else - if c <= 71039 - then - (if c <= 70854 - then (if c <= 70853 then 6 else 1) - else if c <= 70855 then 6 else 1) - else - if c <= 71127 - then (if c <= 71086 then 6 else 1) - else if c <= 71131 then 6 else 1) - else - if c <= 71423 - then - (if c <= 71295 - then - (if c <= 71235 - then (if c <= 71215 then 6 else 1) - else if c <= 71236 then 6 else 1) - else - if c <= 71351 - then (if c <= 71338 then 6 else 1) - else if c <= 71352 then 6 else 1) - else - if c <= 71679 - then - (if c <= 71487 - then (if c <= 71450 then 6 else 1) - else if c <= 71494 then 6 else 1) - else - if c <= 71839 - then (if c <= 71723 then 6 else 1) - else if c <= 71903 then 6 else 1) - else - if c <= 72105 - then - (if c <= 71959 - then - (if c <= 71947 - then - (if c <= 71944 - then (if c <= 71942 then 6 else 1) - else if c <= 71945 then 6 else 1) - else - if c <= 71956 - then (if c <= 71955 then 6 else 1) - else if c <= 71958 then 6 else 1) - else - if c <= 72000 - then - (if c <= 71998 - then (if c <= 71983 then 6 else 1) - else if c <= 71999 then 6 else 1) - else - if c <= 72095 - then (if c <= 72001 then 6 else 1) - else if c <= 72103 then 6 else 1) - else - if c <= 72202 - then - (if c <= 72162 - then - (if c <= 72160 - then (if c <= 72144 then 6 else 1) - else if c <= 72161 then 6 else 1) - else - if c <= 72191 - then (if c <= 72163 then 6 else 1) - else if c <= 72192 then 6 else 1) - else - if c <= 72271 - then - (if c <= 72249 - then (if c <= 72242 then 6 else 1) - else if c <= 72250 then 6 else 1) - else - if c <= 72283 - then (if c <= 72272 then 6 else 1) - else if c <= 72329 then 6 else 1) - else - if c <= 94031 - then - (if c <= 73727 - then - (if c <= 72970 - then - (if c <= 72767 - then - (if c <= 72703 - then - (if c <= 72367 - then (if c <= 72349 then 6 else 1) - else if c <= 72440 then 6 else 1) - else - if c <= 72713 - then (if c <= 72712 then 6 else 1) - else if c <= 72750 then 6 else 1) - else - if c <= 72959 - then - (if c <= 72817 - then (if c <= 72768 then 6 else 1) - else if c <= 72847 then 6 else 1) - else - if c <= 72967 - then (if c <= 72966 then 6 else 1) - else if c <= 72969 then 6 else 1) - else - if c <= 73065 - then - (if c <= 73055 - then - (if c <= 73029 - then (if c <= 73008 then 6 else 1) - else if c <= 73030 then 6 else 1) - else - if c <= 73062 - then (if c <= 73061 then 6 else 1) - else if c <= 73064 then 6 else 1) - else - if c <= 73439 - then - (if c <= 73111 - then (if c <= 73097 then 6 else 1) - else if c <= 73112 then 6 else 1) - else - if c <= 73647 - then (if c <= 73458 then 6 else 1) - else if c <= 73648 then 6 else 1) - else - if c <= 92783 - then - (if c <= 77823 - then - (if c <= 74879 - then - (if c <= 74751 - then (if c <= 74649 then 6 else 1) - else if c <= 74862 then 6 else 1) - else - if c <= 77711 - then (if c <= 75075 then 6 else 1) - else if c <= 77808 then 6 else 1) - else - if c <= 92159 - then - (if c <= 82943 - then (if c <= 78894 then 6 else 1) - else if c <= 83526 then 6 else 1) - else - if c <= 92735 - then (if c <= 92728 then 6 else 1) - else if c <= 92766 then 6 else 1) - else - if c <= 93026 - then - (if c <= 92927 - then - (if c <= 92879 - then (if c <= 92862 then 6 else 1) - else if c <= 92909 then 6 else 1) - else - if c <= 92991 - then (if c <= 92975 then 6 else 1) - else if c <= 92995 then 6 else 1) - else - if c <= 93759 - then - (if c <= 93052 - then (if c <= 93047 then 6 else 1) - else if c <= 93071 then 6 else 1) - else - if c <= 93951 - then (if c <= 93823 then 6 else 1) - else if c <= 94026 then 6 else 1) - else - if c <= 113791 - then - (if c <= 110580 - then - (if c <= 94207 - then - (if c <= 94175 - then - (if c <= 94098 - then (if c <= 94032 then 6 else 1) - else if c <= 94111 then 6 else 1) - else - if c <= 94178 - then (if c <= 94177 then 6 else 1) - else if c <= 94179 then 6 else 1) - else - if c <= 101631 - then - (if c <= 100351 - then (if c <= 100343 then 6 else 1) - else if c <= 101589 then 6 else 1) - else - if c <= 110575 - then (if c <= 101640 then 6 else 1) - else if c <= 110579 then 6 else 1) - else - if c <= 110947 - then - (if c <= 110591 - then - (if c <= 110588 - then (if c <= 110587 then 6 else 1) - else if c <= 110590 then 6 else 1) - else - if c <= 110927 - then (if c <= 110882 then 6 else 1) - else if c <= 110930 then 6 else 1) - else - if c <= 113663 - then - (if c <= 110959 - then (if c <= 110951 then 6 else 1) - else if c <= 111355 then 6 else 1) - else - if c <= 113775 - then (if c <= 113770 then 6 else 1) - else if c <= 113788 then 6 else 1) - else - if c <= 119981 - then - (if c <= 119965 - then - (if c <= 119807 - then - (if c <= 113807 - then (if c <= 113800 then 6 else 1) - else if c <= 113817 then 6 else 1) - else - if c <= 119893 - then (if c <= 119892 then 6 else 1) - else if c <= 119964 then 6 else 1) - else - if c <= 119972 - then - (if c <= 119969 - then (if c <= 119967 then 6 else 1) - else if c <= 119970 then 6 else 1) - else - if c <= 119976 - then (if c <= 119974 then 6 else 1) - else if c <= 119980 then 6 else 1) - else - if c <= 120070 - then - (if c <= 119996 - then - (if c <= 119994 - then (if c <= 119993 then 6 else 1) - else if c <= 119995 then 6 else 1) - else - if c <= 120004 - then (if c <= 120003 then 6 else 1) - else if c <= 120069 then 6 else 1) - else - if c <= 120085 - then - (if c <= 120076 - then (if c <= 120074 then 6 else 1) - else if c <= 120084 then 6 else 1) - else - if c <= 120093 - then (if c <= 120092 then 6 else 1) - else if c <= 120121 then 6 else 1) - else - if c <= 131071 - then - (if c <= 126468 - then - (if c <= 122623 - then - (if c <= 120571 - then - (if c <= 120145 - then - (if c <= 120133 - then - (if c <= 120127 - then (if c <= 120126 then 6 else 1) - else if c <= 120132 then 6 else 1) - else - if c <= 120137 - then (if c <= 120134 then 6 else 1) - else if c <= 120144 then 6 else 1) - else - if c <= 120513 - then - (if c <= 120487 - then (if c <= 120485 then 6 else 1) - else if c <= 120512 then 6 else 1) - else - if c <= 120539 - then (if c <= 120538 then 6 else 1) - else if c <= 120570 then 6 else 1) - else - if c <= 120687 - then - (if c <= 120629 - then - (if c <= 120597 - then (if c <= 120596 then 6 else 1) - else if c <= 120628 then 6 else 1) - else - if c <= 120655 - then (if c <= 120654 then 6 else 1) - else if c <= 120686 then 6 else 1) - else - if c <= 120745 - then - (if c <= 120713 - then (if c <= 120712 then 6 else 1) - else if c <= 120744 then 6 else 1) - else - if c <= 120771 - then (if c <= 120770 then 6 else 1) - else if c <= 120779 then 6 else 1) - else - if c <= 124895 - then - (if c <= 123190 - then - (if c <= 122654 - then 6 - else - if c <= 123135 - then 1 - else if c <= 123180 then 6 else 1) - else - if c <= 123535 - then - (if c <= 123213 - then (if c <= 123197 then 6 else 1) - else if c <= 123214 then 6 else 1) - else - if c <= 123583 - then (if c <= 123565 then 6 else 1) - else if c <= 123627 then 6 else 1) - else - if c <= 124927 - then - (if c <= 124908 - then - (if c <= 124903 - then (if c <= 124902 then 6 else 1) - else if c <= 124907 then 6 else 1) - else - if c <= 124911 - then (if c <= 124910 then 6 else 1) - else if c <= 124926 then 6 else 1) - else - if c <= 125258 - then - (if c <= 125183 - then (if c <= 125124 then 6 else 1) - else if c <= 125251 then 6 else 1) - else - if c <= 126463 - then (if c <= 125259 then 6 else 1) - else if c <= 126467 then 6 else 1) - else - if c <= 126552 - then - (if c <= 126529 - then - (if c <= 126504 - then - (if c <= 126499 - then - (if c <= 126496 - then (if c <= 126495 then 6 else 1) - else if c <= 126498 then 6 else 1) - else - if c <= 126502 - then (if c <= 126500 then 6 else 1) - else if c <= 126503 then 6 else 1) - else - if c <= 126520 - then - (if c <= 126515 - then (if c <= 126514 then 6 else 1) - else if c <= 126519 then 6 else 1) - else - if c <= 126522 - then (if c <= 126521 then 6 else 1) - else if c <= 126523 then 6 else 1) - else - if c <= 126540 - then - (if c <= 126536 - then - (if c <= 126534 - then (if c <= 126530 then 6 else 1) - else if c <= 126535 then 6 else 1) - else - if c <= 126538 - then (if c <= 126537 then 6 else 1) - else if c <= 126539 then 6 else 1) - else - if c <= 126547 - then - (if c <= 126544 - then (if c <= 126543 then 6 else 1) - else if c <= 126546 then 6 else 1) - else - if c <= 126550 - then (if c <= 126548 then 6 else 1) - else if c <= 126551 then 6 else 1) - else - if c <= 126579 - then - (if c <= 126560 - then - (if c <= 126556 - then - (if c <= 126554 - then (if c <= 126553 then 6 else 1) - else if c <= 126555 then 6 else 1) - else - if c <= 126558 - then (if c <= 126557 then 6 else 1) - else if c <= 126559 then 6 else 1) - else - if c <= 126566 - then - (if c <= 126563 - then (if c <= 126562 then 6 else 1) - else if c <= 126564 then 6 else 1) - else - if c <= 126571 - then (if c <= 126570 then 6 else 1) - else if c <= 126578 then 6 else 1) - else - if c <= 126602 - then - (if c <= 126589 - then - (if c <= 126584 - then (if c <= 126583 then 6 else 1) - else if c <= 126588 then 6 else 1) - else - if c <= 126591 - then (if c <= 126590 then 6 else 1) - else if c <= 126601 then 6 else 1) - else - if c <= 126628 - then - (if c <= 126624 - then (if c <= 126619 then 6 else 1) - else if c <= 126627 then 6 else 1) - else - if c <= 126634 - then (if c <= 126633 then 6 else 1) - else if c <= 126651 then 6 else 1) - else - if c <= 183983 - then - (if c <= 177983 - then - (if c <= 173823 - then (if c <= 173791 then 6 else 1) - else if c <= 177976 then 6 else 1) - else - if c <= 178207 - then (if c <= 178205 then 6 else 1) - else if c <= 183969 then 6 else 1) - else if c <= 191456 then 6 else 1) - else (-1) -let __sedlex_partition_78 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_75 (c - 36))) - 1 - else (-1) -let __sedlex_partition_119 c = - if c <= (-1) - then (-1) - else - if c <= 8191 - then (Char.code (String.unsafe_get __sedlex_table_76 c)) - 1 - else - if c <= 12287 - then - (if c <= 8238 - then - (if c <= 8231 - then (if c <= 8202 then 1 else 0) - else if c <= 8233 then 2 else 0) - else - if c <= 8286 - then (if c <= 8239 then 1 else 0) - else if c <= 8287 then 1 else 0) - else - if c <= 65278 - then (if c <= 12288 then 1 else 0) - else if c <= 65279 then 1 else 0 -let __sedlex_partition_69 c = - if c <= 118 then (-1) else if c <= 119 then 0 else (-1) -let __sedlex_partition_85 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_77 (c - 36))) - 1 - else (-1) -let __sedlex_partition_100 c = - if c <= 93 - then (Char.code (String.unsafe_get __sedlex_table_78 (c - (-1)))) - 1 - else if c <= 8233 then (if c <= 8231 then 1 else 2) else 1 -let __sedlex_partition_118 c = - if c <= 123 - then (Char.code (String.unsafe_get __sedlex_table_79 (c - (-1)))) - 1 - else if c <= 8233 then (if c <= 8231 then 1 else 2) else 1 -let __sedlex_partition_32 c = - if c <= 47 - then (-1) - else - if c <= 57 - then (Char.code (String.unsafe_get __sedlex_table_80 (c - 48))) - 1 - else (-1) -let __sedlex_partition_38 c = - if c <= 47 - then (-1) - else - if c <= 101 - then (Char.code (String.unsafe_get __sedlex_table_81 (c - 48))) - 1 - else (-1) -let __sedlex_partition_39 c = - if c <= 42 - then (-1) - else - if c <= 57 - then (Char.code (String.unsafe_get __sedlex_table_82 (c - 43))) - 1 - else (-1) -let __sedlex_partition_109 c = - if c <= 125 - then (Char.code (String.unsafe_get __sedlex_table_83 (c - (-1)))) - 1 - else if c <= 8233 then (if c <= 8231 then 1 else 2) else 1 -let __sedlex_partition_1 c = - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_84 (c - (-1)))) - 1 - else 1 -let __sedlex_partition_6 c = - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_85 (c - (-1)))) - 1 - else 1 -let __sedlex_partition_12 c = - if c <= 44 - then (-1) - else - if c <= 47 - then (Char.code (String.unsafe_get __sedlex_table_86 (c - 45))) - 1 - else (-1) -let __sedlex_partition_114 c = - if c <= 47 - then (-1) - else - if c <= 102 - then (Char.code (String.unsafe_get __sedlex_table_87 (c - 48))) - 1 - else (-1) -let __sedlex_partition_49 c = - if c <= 62 then (-1) else if c <= 63 then 0 else (-1) -let __sedlex_partition_48 c = - if c <= 45 - then (-1) - else - if c <= 95 - then (Char.code (String.unsafe_get __sedlex_table_88 (c - 46))) - 1 - else (-1) -let __sedlex_partition_2 c = - if c <= 116 then (-1) else if c <= 117 then 0 else (-1) -let __sedlex_partition_13 c = - if c <= 46 then (-1) else if c <= 47 then 0 else (-1) -let __sedlex_partition_66 c = - if c <= 57 then (-1) else if c <= 58 then 0 else (-1) -let __sedlex_partition_60 c = - if c <= 35 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_89 (c - 36))) - 1 - else (-1) -let __sedlex_partition_111 c = - if c <= 34 - then (-1) - else - if c <= 122 - then (Char.code (String.unsafe_get __sedlex_table_90 (c - 35))) - 1 - else (-1) -let __sedlex_partition_117 c = - if c <= 8191 - then (Char.code (String.unsafe_get __sedlex_table_91 (c - (-1)))) - 1 - else - if c <= 194559 - then - (if c <= 69599 - then - (if c <= 43711 - then - (if c <= 12703 - then - (if c <= 11519 - then - (if c <= 8489 - then - (if c <= 8454 - then - (if c <= 8304 - then - (if c <= 8238 - then - (if c <= 8231 - then (if c <= 8202 then 2 else 1) - else if c <= 8233 then 3 else 1) - else - if c <= 8286 - then (if c <= 8239 then 2 else 1) - else if c <= 8287 then 2 else 1) - else - if c <= 8335 - then - (if c <= 8318 - then (if c <= 8305 then 6 else 1) - else if c <= 8319 then 6 else 1) - else - if c <= 8449 - then (if c <= 8348 then 6 else 1) - else if c <= 8450 then 6 else 1) - else - if c <= 8477 - then - (if c <= 8468 - then - (if c <= 8457 - then (if c <= 8455 then 6 else 1) - else if c <= 8467 then 6 else 1) - else - if c <= 8471 - then (if c <= 8469 then 6 else 1) - else 6) - else - if c <= 8485 - then - (if c <= 8483 - then 1 - else if c <= 8484 then 6 else 1) - else - if c <= 8487 - then (if c <= 8486 then 6 else 1) - else if c <= 8488 then 6 else 1) - else - if c <= 8543 - then - (if c <= 8505 - then 6 - else - if c <= 8516 - then - (if c <= 8507 - then 1 - else if c <= 8511 then 6 else 1) - else - if c <= 8525 - then (if c <= 8521 then 6 else 1) - else if c <= 8526 then 6 else 1) - else - if c <= 11389 - then - (if c <= 8584 - then 6 - else if c <= 11263 then 1 else 6) - else - if c <= 11498 - then (if c <= 11492 then 6 else 1) - else - if c <= 11505 - then (if c <= 11502 then 6 else 1) - else if c <= 11507 then 6 else 1) - else - if c <= 12294 - then - (if c <= 11695 - then - (if c <= 11630 - then - (if c <= 11564 - then - (if c <= 11558 - then (if c <= 11557 then 6 else 1) - else if c <= 11559 then 6 else 1) - else - if c <= 11567 - then (if c <= 11565 then 6 else 1) - else if c <= 11623 then 6 else 1) - else - if c <= 11679 - then - (if c <= 11647 - then (if c <= 11631 then 6 else 1) - else if c <= 11670 then 6 else 1) - else - if c <= 11687 - then (if c <= 11686 then 6 else 1) - else if c <= 11694 then 6 else 1) - else - if c <= 11727 - then - (if c <= 11711 - then - (if c <= 11703 - then (if c <= 11702 then 6 else 1) - else if c <= 11710 then 6 else 1) - else - if c <= 11719 - then (if c <= 11718 then 6 else 1) - else if c <= 11726 then 6 else 1) - else - if c <= 12287 - then - (if c <= 11735 - then (if c <= 11734 then 6 else 1) - else if c <= 11742 then 6 else 1) - else - if c <= 12292 - then (if c <= 12288 then 2 else 1) - else 6) - else - if c <= 12442 - then - (if c <= 12343 - then - (if c <= 12320 - then (if c <= 12295 then 6 else 1) - else - if c <= 12336 - then (if c <= 12329 then 6 else 1) - else if c <= 12341 then 6 else 1) - else - if c <= 12348 - then 6 - else - if c <= 12352 - then 1 - else if c <= 12438 then 6 else 1) - else - if c <= 12539 - then - (if c <= 12447 - then 6 - else - if c <= 12448 - then 1 - else if c <= 12538 then 6 else 1) - else - if c <= 12548 - then (if c <= 12543 then 6 else 1) - else - if c <= 12592 - then (if c <= 12591 then 6 else 1) - else if c <= 12686 then 6 else 1) - else - if c <= 42999 - then - (if c <= 42653 - then - (if c <= 42239 - then - (if c <= 40981 - then - (if c <= 13311 - then - (if c <= 12783 - then (if c <= 12735 then 6 else 1) - else if c <= 12799 then 6 else 1) - else - if c <= 19967 - then (if c <= 19903 then 6 else 1) - else 6) - else - if c <= 42191 - then (if c <= 42124 then 6 else 1) - else if c <= 42237 then 6 else 1) - else - if c <= 42559 - then - (if c <= 42511 - then (if c <= 42508 then 6 else 1) - else - if c <= 42537 - then (if c <= 42527 then 6 else 1) - else if c <= 42539 then 6 else 1) - else - if c <= 42622 - then (if c <= 42606 then 6 else 1) - else 6) - else - if c <= 42890 - then - (if c <= 42785 - then - (if c <= 42735 - then (if c <= 42655 then 1 else 6) - else - if c <= 42774 - then 1 - else if c <= 42783 then 6 else 1) - else - if c <= 42887 - then 6 - else if c <= 42888 then 6 else 1) - else - if c <= 42962 - then - (if c <= 42954 - then 6 - else - if c <= 42959 - then 1 - else if c <= 42961 then 6 else 1) - else - if c <= 42993 - then - (if c <= 42964 - then (if c <= 42963 then 6 else 1) - else if c <= 42969 then 6 else 1) - else 6) - else - if c <= 43470 - then - (if c <= 43137 - then - (if c <= 43010 - then - (if c <= 43002 - then 6 - else if c <= 43009 then 6 else 1) - else - if c <= 43019 - then - (if c <= 43014 - then (if c <= 43013 then 6 else 1) - else if c <= 43018 then 6 else 1) - else - if c <= 43071 - then (if c <= 43042 then 6 else 1) - else if c <= 43123 then 6 else 1) - else - if c <= 43273 - then - (if c <= 43258 - then - (if c <= 43249 - then (if c <= 43187 then 6 else 1) - else if c <= 43255 then 6 else 1) - else - if c <= 43260 - then (if c <= 43259 then 6 else 1) - else if c <= 43262 then 6 else 1) - else - if c <= 43359 - then - (if c <= 43311 - then (if c <= 43301 then 6 else 1) - else if c <= 43334 then 6 else 1) - else - if c <= 43395 - then (if c <= 43388 then 6 else 1) - else if c <= 43442 then 6 else 1) - else - if c <= 43615 - then - (if c <= 43513 - then - (if c <= 43493 - then - (if c <= 43487 - then (if c <= 43471 then 6 else 1) - else if c <= 43492 then 6 else 1) - else if c <= 43503 then 6 else 1) - else - if c <= 43583 - then - (if c <= 43519 - then (if c <= 43518 then 6 else 1) - else if c <= 43560 then 6 else 1) - else - if c <= 43587 - then (if c <= 43586 then 6 else 1) - else if c <= 43595 then 6 else 1) - else - if c <= 43645 - then - (if c <= 43638 - then 6 - else - if c <= 43641 - then 1 - else if c <= 43642 then 6 else 1) - else - if c <= 43700 - then - (if c <= 43696 - then (if c <= 43695 then 6 else 1) - else if c <= 43697 then 6 else 1) - else - if c <= 43704 - then (if c <= 43702 then 6 else 1) - else if c <= 43709 then 6 else 1) - else - if c <= 66377 - then - (if c <= 64325 - then - (if c <= 43887 - then - (if c <= 43784 - then - (if c <= 43743 - then - (if c <= 43738 - then - (if c <= 43713 - then (if c <= 43712 then 6 else 1) - else if c <= 43714 then 6 else 1) - else if c <= 43741 then 6 else 1) - else - if c <= 43764 - then - (if c <= 43761 - then (if c <= 43754 then 6 else 1) - else 6) - else - if c <= 43776 - then 1 - else if c <= 43782 then 6 else 1) - else - if c <= 43823 - then - (if c <= 43807 - then - (if c <= 43792 - then (if c <= 43790 then 6 else 1) - else if c <= 43798 then 6 else 1) - else - if c <= 43815 - then (if c <= 43814 then 6 else 1) - else if c <= 43822 then 6 else 1) - else - if c <= 43880 - then - (if c <= 43867 - then (if c <= 43866 then 6 else 1) - else 6) - else if c <= 43881 then 6 else 1) - else - if c <= 64274 - then - (if c <= 55242 - then - (if c <= 44031 - then (if c <= 44002 then 6 else 1) - else - if c <= 55215 - then (if c <= 55203 then 6 else 1) - else if c <= 55238 then 6 else 1) - else - if c <= 64111 - then - (if c <= 63743 - then (if c <= 55291 then 6 else 1) - else if c <= 64109 then 6 else 1) - else - if c <= 64255 - then (if c <= 64217 then 6 else 1) - else if c <= 64262 then 6 else 1) - else - if c <= 64311 - then - (if c <= 64286 - then - (if c <= 64284 - then (if c <= 64279 then 6 else 1) - else if c <= 64285 then 6 else 1) - else - if c <= 64297 - then (if c <= 64296 then 6 else 1) - else if c <= 64310 then 6 else 1) - else - if c <= 64319 - then - (if c <= 64317 - then (if c <= 64316 then 6 else 1) - else if c <= 64318 then 6 else 1) - else - if c <= 64322 - then (if c <= 64321 then 6 else 1) - else if c <= 64324 then 6 else 1) - else - if c <= 65481 - then - (if c <= 65312 - then - (if c <= 65007 - then - (if c <= 64847 - then - (if c <= 64466 - then (if c <= 64433 then 6 else 1) - else if c <= 64829 then 6 else 1) - else - if c <= 64913 - then (if c <= 64911 then 6 else 1) - else if c <= 64967 then 6 else 1) - else - if c <= 65141 - then - (if c <= 65135 - then (if c <= 65019 then 6 else 1) - else if c <= 65140 then 6 else 1) - else - if c <= 65278 - then (if c <= 65276 then 6 else 1) - else if c <= 65279 then 2 else 1) - else - if c <= 65437 - then - (if c <= 65381 - then - (if c <= 65344 - then (if c <= 65338 then 6 else 1) - else if c <= 65370 then 6 else 1) - else 6) - else - if c <= 65470 - then 6 - else - if c <= 65473 - then 1 - else if c <= 65479 then 6 else 1) - else - if c <= 65615 - then - (if c <= 65548 - then - (if c <= 65497 - then - (if c <= 65489 - then (if c <= 65487 then 6 else 1) - else if c <= 65495 then 6 else 1) - else - if c <= 65535 - then (if c <= 65500 then 6 else 1) - else if c <= 65547 then 6 else 1) - else - if c <= 65595 - then - (if c <= 65575 - then (if c <= 65574 then 6 else 1) - else if c <= 65594 then 6 else 1) - else - if c <= 65598 - then (if c <= 65597 then 6 else 1) - else if c <= 65613 then 6 else 1) - else - if c <= 66207 - then - (if c <= 65855 - then - (if c <= 65663 - then (if c <= 65629 then 6 else 1) - else if c <= 65786 then 6 else 1) - else - if c <= 66175 - then (if c <= 65908 then 6 else 1) - else if c <= 66204 then 6 else 1) - else - if c <= 66348 - then - (if c <= 66303 - then (if c <= 66256 then 6 else 1) - else if c <= 66335 then 6 else 1) - else 6) - else - if c <= 67646 - then - (if c <= 66963 - then - (if c <= 66717 - then - (if c <= 66463 - then - (if c <= 66383 - then (if c <= 66378 then 6 else 1) - else - if c <= 66431 - then (if c <= 66421 then 6 else 1) - else if c <= 66461 then 6 else 1) - else - if c <= 66512 - then - (if c <= 66503 - then (if c <= 66499 then 6 else 1) - else if c <= 66511 then 6 else 1) - else - if c <= 66559 - then (if c <= 66517 then 6 else 1) - else 6) - else - if c <= 66863 - then - (if c <= 66775 - then - (if c <= 66735 - then 1 - else if c <= 66771 then 6 else 1) - else - if c <= 66815 - then (if c <= 66811 then 6 else 1) - else if c <= 66855 then 6 else 1) - else - if c <= 66939 - then - (if c <= 66927 - then (if c <= 66915 then 6 else 1) - else if c <= 66938 then 6 else 1) - else - if c <= 66955 - then (if c <= 66954 then 6 else 1) - else if c <= 66962 then 6 else 1) - else - if c <= 67455 - then - (if c <= 67002 - then - (if c <= 66978 - then - (if c <= 66966 - then (if c <= 66965 then 6 else 1) - else if c <= 66977 then 6 else 1) - else - if c <= 66994 - then (if c <= 66993 then 6 else 1) - else if c <= 67001 then 6 else 1) - else - if c <= 67391 - then - (if c <= 67071 - then (if c <= 67004 then 6 else 1) - else if c <= 67382 then 6 else 1) - else - if c <= 67423 - then (if c <= 67413 then 6 else 1) - else if c <= 67431 then 6 else 1) - else - if c <= 67591 - then - (if c <= 67505 - then - (if c <= 67462 - then (if c <= 67461 then 6 else 1) - else if c <= 67504 then 6 else 1) - else - if c <= 67583 - then (if c <= 67514 then 6 else 1) - else if c <= 67589 then 6 else 1) - else - if c <= 67638 - then - (if c <= 67593 - then (if c <= 67592 then 6 else 1) - else if c <= 67637 then 6 else 1) - else - if c <= 67643 - then (if c <= 67640 then 6 else 1) - else if c <= 67644 then 6 else 1) - else - if c <= 68296 - then - (if c <= 68029 - then - (if c <= 67827 - then - (if c <= 67711 - then - (if c <= 67679 - then (if c <= 67669 then 6 else 1) - else if c <= 67702 then 6 else 1) - else - if c <= 67807 - then (if c <= 67742 then 6 else 1) - else if c <= 67826 then 6 else 1) - else - if c <= 67871 - then - (if c <= 67839 - then (if c <= 67829 then 6 else 1) - else if c <= 67861 then 6 else 1) - else - if c <= 67967 - then (if c <= 67897 then 6 else 1) - else if c <= 68023 then 6 else 1) - else - if c <= 68120 - then - (if c <= 68111 - then - (if c <= 68095 - then (if c <= 68031 then 6 else 1) - else if c <= 68096 then 6 else 1) - else - if c <= 68116 - then (if c <= 68115 then 6 else 1) - else if c <= 68119 then 6 else 1) - else - if c <= 68223 - then - (if c <= 68191 - then (if c <= 68149 then 6 else 1) - else if c <= 68220 then 6 else 1) - else - if c <= 68287 - then (if c <= 68252 then 6 else 1) - else if c <= 68295 then 6 else 1) - else - if c <= 68863 - then - (if c <= 68479 - then - (if c <= 68415 - then - (if c <= 68351 - then (if c <= 68324 then 6 else 1) - else if c <= 68405 then 6 else 1) - else - if c <= 68447 - then (if c <= 68437 then 6 else 1) - else if c <= 68466 then 6 else 1) - else - if c <= 68735 - then - (if c <= 68607 - then (if c <= 68497 then 6 else 1) - else if c <= 68680 then 6 else 1) - else - if c <= 68799 - then (if c <= 68786 then 6 else 1) - else if c <= 68850 then 6 else 1) - else - if c <= 69414 - then - (if c <= 69295 - then - (if c <= 69247 - then (if c <= 68899 then 6 else 1) - else if c <= 69289 then 6 else 1) - else - if c <= 69375 - then (if c <= 69297 then 6 else 1) - else if c <= 69404 then 6 else 1) - else - if c <= 69487 - then - (if c <= 69423 - then (if c <= 69415 then 6 else 1) - else if c <= 69445 then 6 else 1) - else - if c <= 69551 - then (if c <= 69505 then 6 else 1) - else if c <= 69572 then 6 else 1) - else - if c <= 120122 - then - (if c <= 72348 - then - (if c <= 70655 - then - (if c <= 70162 - then - (if c <= 69958 - then - (if c <= 69762 - then - (if c <= 69744 - then - (if c <= 69634 - then (if c <= 69622 then 6 else 1) - else if c <= 69687 then 6 else 1) - else - if c <= 69748 - then (if c <= 69746 then 6 else 1) - else if c <= 69749 then 6 else 1) - else - if c <= 69890 - then - (if c <= 69839 - then (if c <= 69807 then 6 else 1) - else if c <= 69864 then 6 else 1) - else - if c <= 69955 - then (if c <= 69926 then 6 else 1) - else if c <= 69956 then 6 else 1) - else - if c <= 70080 - then - (if c <= 70005 - then - (if c <= 69967 - then (if c <= 69959 then 6 else 1) - else if c <= 70002 then 6 else 1) - else - if c <= 70018 - then (if c <= 70006 then 6 else 1) - else if c <= 70066 then 6 else 1) - else - if c <= 70107 - then - (if c <= 70105 - then (if c <= 70084 then 6 else 1) - else if c <= 70106 then 6 else 1) - else - if c <= 70143 - then (if c <= 70108 then 6 else 1) - else if c <= 70161 then 6 else 1) - else - if c <= 70414 - then - (if c <= 70286 - then - (if c <= 70279 - then - (if c <= 70271 - then (if c <= 70187 then 6 else 1) - else if c <= 70278 then 6 else 1) - else - if c <= 70281 - then (if c <= 70280 then 6 else 1) - else if c <= 70285 then 6 else 1) - else - if c <= 70319 - then - (if c <= 70302 - then (if c <= 70301 then 6 else 1) - else if c <= 70312 then 6 else 1) - else - if c <= 70404 - then (if c <= 70366 then 6 else 1) - else if c <= 70412 then 6 else 1) - else - if c <= 70452 - then - (if c <= 70441 - then - (if c <= 70418 - then (if c <= 70416 then 6 else 1) - else if c <= 70440 then 6 else 1) - else - if c <= 70449 - then (if c <= 70448 then 6 else 1) - else if c <= 70451 then 6 else 1) - else - if c <= 70479 - then - (if c <= 70460 - then (if c <= 70457 then 6 else 1) - else if c <= 70461 then 6 else 1) - else - if c <= 70492 - then (if c <= 70480 then 6 else 1) - else if c <= 70497 then 6 else 1) - else - if c <= 71934 - then - (if c <= 71167 - then - (if c <= 70851 - then - (if c <= 70750 - then - (if c <= 70726 - then (if c <= 70708 then 6 else 1) - else if c <= 70730 then 6 else 1) - else - if c <= 70783 - then (if c <= 70753 then 6 else 1) - else if c <= 70831 then 6 else 1) - else - if c <= 71039 - then - (if c <= 70854 - then (if c <= 70853 then 6 else 1) - else if c <= 70855 then 6 else 1) - else - if c <= 71127 - then (if c <= 71086 then 6 else 1) - else if c <= 71131 then 6 else 1) - else - if c <= 71423 - then - (if c <= 71295 - then - (if c <= 71235 - then (if c <= 71215 then 6 else 1) - else if c <= 71236 then 6 else 1) - else - if c <= 71351 - then (if c <= 71338 then 6 else 1) - else if c <= 71352 then 6 else 1) - else - if c <= 71679 - then - (if c <= 71487 - then (if c <= 71450 then 6 else 1) - else if c <= 71494 then 6 else 1) - else - if c <= 71839 - then (if c <= 71723 then 6 else 1) - else if c <= 71903 then 6 else 1) - else - if c <= 72105 - then - (if c <= 71959 - then - (if c <= 71947 - then - (if c <= 71944 - then (if c <= 71942 then 6 else 1) - else if c <= 71945 then 6 else 1) - else - if c <= 71956 - then (if c <= 71955 then 6 else 1) - else if c <= 71958 then 6 else 1) - else - if c <= 72000 - then - (if c <= 71998 - then (if c <= 71983 then 6 else 1) - else if c <= 71999 then 6 else 1) - else - if c <= 72095 - then (if c <= 72001 then 6 else 1) - else if c <= 72103 then 6 else 1) - else - if c <= 72202 - then - (if c <= 72162 - then - (if c <= 72160 - then (if c <= 72144 then 6 else 1) - else if c <= 72161 then 6 else 1) - else - if c <= 72191 - then (if c <= 72163 then 6 else 1) - else if c <= 72192 then 6 else 1) - else - if c <= 72271 - then - (if c <= 72249 - then (if c <= 72242 then 6 else 1) - else if c <= 72250 then 6 else 1) - else - if c <= 72283 - then (if c <= 72272 then 6 else 1) - else if c <= 72329 then 6 else 1) - else - if c <= 94031 - then - (if c <= 73727 - then - (if c <= 72970 - then - (if c <= 72767 - then - (if c <= 72703 - then - (if c <= 72367 - then (if c <= 72349 then 6 else 1) - else if c <= 72440 then 6 else 1) - else - if c <= 72713 - then (if c <= 72712 then 6 else 1) - else if c <= 72750 then 6 else 1) - else - if c <= 72959 - then - (if c <= 72817 - then (if c <= 72768 then 6 else 1) - else if c <= 72847 then 6 else 1) - else - if c <= 72967 - then (if c <= 72966 then 6 else 1) - else if c <= 72969 then 6 else 1) - else - if c <= 73065 - then - (if c <= 73055 - then - (if c <= 73029 - then (if c <= 73008 then 6 else 1) - else if c <= 73030 then 6 else 1) - else - if c <= 73062 - then (if c <= 73061 then 6 else 1) - else if c <= 73064 then 6 else 1) - else - if c <= 73439 - then - (if c <= 73111 - then (if c <= 73097 then 6 else 1) - else if c <= 73112 then 6 else 1) - else - if c <= 73647 - then (if c <= 73458 then 6 else 1) - else if c <= 73648 then 6 else 1) - else - if c <= 92783 - then - (if c <= 77823 - then - (if c <= 74879 - then - (if c <= 74751 - then (if c <= 74649 then 6 else 1) - else if c <= 74862 then 6 else 1) - else - if c <= 77711 - then (if c <= 75075 then 6 else 1) - else if c <= 77808 then 6 else 1) - else - if c <= 92159 - then - (if c <= 82943 - then (if c <= 78894 then 6 else 1) - else if c <= 83526 then 6 else 1) - else - if c <= 92735 - then (if c <= 92728 then 6 else 1) - else if c <= 92766 then 6 else 1) - else - if c <= 93026 - then - (if c <= 92927 - then - (if c <= 92879 - then (if c <= 92862 then 6 else 1) - else if c <= 92909 then 6 else 1) - else - if c <= 92991 - then (if c <= 92975 then 6 else 1) - else if c <= 92995 then 6 else 1) - else - if c <= 93759 - then - (if c <= 93052 - then (if c <= 93047 then 6 else 1) - else if c <= 93071 then 6 else 1) - else - if c <= 93951 - then (if c <= 93823 then 6 else 1) - else if c <= 94026 then 6 else 1) - else - if c <= 113791 - then - (if c <= 110580 - then - (if c <= 94207 - then - (if c <= 94175 - then - (if c <= 94098 - then (if c <= 94032 then 6 else 1) - else if c <= 94111 then 6 else 1) - else - if c <= 94178 - then (if c <= 94177 then 6 else 1) - else if c <= 94179 then 6 else 1) - else - if c <= 101631 - then - (if c <= 100351 - then (if c <= 100343 then 6 else 1) - else if c <= 101589 then 6 else 1) - else - if c <= 110575 - then (if c <= 101640 then 6 else 1) - else if c <= 110579 then 6 else 1) - else - if c <= 110947 - then - (if c <= 110591 - then - (if c <= 110588 - then (if c <= 110587 then 6 else 1) - else if c <= 110590 then 6 else 1) - else - if c <= 110927 - then (if c <= 110882 then 6 else 1) - else if c <= 110930 then 6 else 1) - else - if c <= 113663 - then - (if c <= 110959 - then (if c <= 110951 then 6 else 1) - else if c <= 111355 then 6 else 1) - else - if c <= 113775 - then (if c <= 113770 then 6 else 1) - else if c <= 113788 then 6 else 1) - else - if c <= 119981 - then - (if c <= 119965 - then - (if c <= 119807 - then - (if c <= 113807 - then (if c <= 113800 then 6 else 1) - else if c <= 113817 then 6 else 1) - else - if c <= 119893 - then (if c <= 119892 then 6 else 1) - else if c <= 119964 then 6 else 1) - else - if c <= 119972 - then - (if c <= 119969 - then (if c <= 119967 then 6 else 1) - else if c <= 119970 then 6 else 1) - else - if c <= 119976 - then (if c <= 119974 then 6 else 1) - else if c <= 119980 then 6 else 1) - else - if c <= 120070 - then - (if c <= 119996 - then - (if c <= 119994 - then (if c <= 119993 then 6 else 1) - else if c <= 119995 then 6 else 1) - else - if c <= 120004 - then (if c <= 120003 then 6 else 1) - else if c <= 120069 then 6 else 1) - else - if c <= 120085 - then - (if c <= 120076 - then (if c <= 120074 then 6 else 1) - else if c <= 120084 then 6 else 1) - else - if c <= 120093 - then (if c <= 120092 then 6 else 1) - else if c <= 120121 then 6 else 1) - else - if c <= 131071 - then - (if c <= 126468 - then - (if c <= 122623 - then - (if c <= 120571 - then - (if c <= 120145 - then - (if c <= 120133 - then - (if c <= 120127 - then (if c <= 120126 then 6 else 1) - else if c <= 120132 then 6 else 1) - else - if c <= 120137 - then (if c <= 120134 then 6 else 1) - else if c <= 120144 then 6 else 1) - else - if c <= 120513 - then - (if c <= 120487 - then (if c <= 120485 then 6 else 1) - else if c <= 120512 then 6 else 1) - else - if c <= 120539 - then (if c <= 120538 then 6 else 1) - else if c <= 120570 then 6 else 1) - else - if c <= 120687 - then - (if c <= 120629 - then - (if c <= 120597 - then (if c <= 120596 then 6 else 1) - else if c <= 120628 then 6 else 1) - else - if c <= 120655 - then (if c <= 120654 then 6 else 1) - else if c <= 120686 then 6 else 1) - else - if c <= 120745 - then - (if c <= 120713 - then (if c <= 120712 then 6 else 1) - else if c <= 120744 then 6 else 1) - else - if c <= 120771 - then (if c <= 120770 then 6 else 1) - else if c <= 120779 then 6 else 1) - else - if c <= 124895 - then - (if c <= 123190 - then - (if c <= 122654 - then 6 - else - if c <= 123135 - then 1 - else if c <= 123180 then 6 else 1) - else - if c <= 123535 - then - (if c <= 123213 - then (if c <= 123197 then 6 else 1) - else if c <= 123214 then 6 else 1) - else - if c <= 123583 - then (if c <= 123565 then 6 else 1) - else if c <= 123627 then 6 else 1) - else - if c <= 124927 - then - (if c <= 124908 - then - (if c <= 124903 - then (if c <= 124902 then 6 else 1) - else if c <= 124907 then 6 else 1) - else - if c <= 124911 - then (if c <= 124910 then 6 else 1) - else if c <= 124926 then 6 else 1) - else - if c <= 125258 - then - (if c <= 125183 - then (if c <= 125124 then 6 else 1) - else if c <= 125251 then 6 else 1) - else - if c <= 126463 - then (if c <= 125259 then 6 else 1) - else if c <= 126467 then 6 else 1) - else - if c <= 126552 - then - (if c <= 126529 - then - (if c <= 126504 - then - (if c <= 126499 - then - (if c <= 126496 - then (if c <= 126495 then 6 else 1) - else if c <= 126498 then 6 else 1) - else - if c <= 126502 - then (if c <= 126500 then 6 else 1) - else if c <= 126503 then 6 else 1) - else - if c <= 126520 - then - (if c <= 126515 - then (if c <= 126514 then 6 else 1) - else if c <= 126519 then 6 else 1) - else - if c <= 126522 - then (if c <= 126521 then 6 else 1) - else if c <= 126523 then 6 else 1) - else - if c <= 126540 - then - (if c <= 126536 - then - (if c <= 126534 - then (if c <= 126530 then 6 else 1) - else if c <= 126535 then 6 else 1) - else - if c <= 126538 - then (if c <= 126537 then 6 else 1) - else if c <= 126539 then 6 else 1) - else - if c <= 126547 - then - (if c <= 126544 - then (if c <= 126543 then 6 else 1) - else if c <= 126546 then 6 else 1) - else - if c <= 126550 - then (if c <= 126548 then 6 else 1) - else if c <= 126551 then 6 else 1) - else - if c <= 126579 - then - (if c <= 126560 - then - (if c <= 126556 - then - (if c <= 126554 - then (if c <= 126553 then 6 else 1) - else if c <= 126555 then 6 else 1) - else - if c <= 126558 - then (if c <= 126557 then 6 else 1) - else if c <= 126559 then 6 else 1) - else - if c <= 126566 - then - (if c <= 126563 - then (if c <= 126562 then 6 else 1) - else if c <= 126564 then 6 else 1) - else - if c <= 126571 - then (if c <= 126570 then 6 else 1) - else if c <= 126578 then 6 else 1) - else - if c <= 126602 - then - (if c <= 126589 - then - (if c <= 126584 - then (if c <= 126583 then 6 else 1) - else if c <= 126588 then 6 else 1) - else - if c <= 126591 - then (if c <= 126590 then 6 else 1) - else if c <= 126601 then 6 else 1) - else - if c <= 126628 - then - (if c <= 126624 - then (if c <= 126619 then 6 else 1) - else if c <= 126627 then 6 else 1) - else - if c <= 126634 - then (if c <= 126633 then 6 else 1) - else if c <= 126651 then 6 else 1) - else - if c <= 183983 - then - (if c <= 177983 - then - (if c <= 173823 - then (if c <= 173791 then 6 else 1) - else if c <= 177976 then 6 else 1) - else - if c <= 178207 - then (if c <= 178205 then 6 else 1) - else if c <= 183969 then 6 else 1) - else if c <= 191456 then 6 else 1) - else (-1) -[@@@warning "-39"] -open Token -open Lex_env -module Sedlexing = Flow_sedlexing -let lexeme = Sedlexing.Utf8.lexeme -let lexeme_to_buffer = Sedlexing.Utf8.lexeme_to_buffer -let lexeme_to_buffer2 = Sedlexing.Utf8.lexeme_to_buffer2 -let sub_lexeme = Sedlexing.Utf8.sub_lexeme -let is_whitespace = - function - | 0x0009 | 0x000B | 0x000C | 0x0020 | 0x00A0 | 0xfeff | 0x1680 | 0x2000 - | 0x2001 | 0x2002 | 0x2003 | 0x2004 | 0x2005 | 0x2006 | 0x2007 | 0x2008 - | 0x2009 | 0x200a | 0x202f | 0x205f | 0x3000 -> true - | _ -> false -let rec loop_id_continues lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_1 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | 1 -> 2 - | 2 -> 0 - | 3 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> loop_id_continues lexbuf - | 1 -> true - | 2 -> - let s = Sedlexing.current_code_point lexbuf in - if Js_id.is_valid_unicode_id s - then loop_id_continues lexbuf - else (Sedlexing.backoff lexbuf 1; false) - | _ -> assert false) -let rec loop_jsx_id_continues lexbuf = - (let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_6 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | 1 -> 2 - | 2 -> 0 - | 3 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> loop_jsx_id_continues lexbuf - | 1 -> () - | 2 -> - let s = Sedlexing.current_code_point lexbuf in - if Js_id.is_valid_unicode_id s - then loop_jsx_id_continues lexbuf - else Sedlexing.backoff lexbuf 1 - | _ -> assert false) : unit) -let pos_at_offset env offset = - { - Loc.line = (Lex_env.line env); - column = (offset - (Lex_env.bol_offset env)) - } -let loc_of_offsets env start_offset end_offset = - { - Loc.source = (Lex_env.source env); - start = (pos_at_offset env start_offset); - _end = (pos_at_offset env end_offset) - } -let start_pos_of_lexbuf env (lexbuf : Sedlexing.lexbuf) = - let start_offset = Sedlexing.lexeme_start lexbuf in - pos_at_offset env start_offset -let end_pos_of_lexbuf env (lexbuf : Sedlexing.lexbuf) = - let end_offset = Sedlexing.lexeme_end lexbuf in - pos_at_offset env end_offset -let loc_of_lexbuf env (lexbuf : Sedlexing.lexbuf) = - let start_offset = Sedlexing.lexeme_start lexbuf in - let end_offset = Sedlexing.lexeme_end lexbuf in - loc_of_offsets env start_offset end_offset -let loc_of_token env lex_token = - match lex_token with - | T_IDENTIFIER { loc;_} | T_JSX_IDENTIFIER { loc;_} | T_STRING - (loc, _, _, _) -> loc - | T_JSX_TEXT (loc, _, _) -> loc - | T_TEMPLATE_PART (loc, _, _) -> loc - | T_REGEXP (loc, _, _) -> loc - | _ -> loc_of_lexbuf env env.lex_lb -let lex_error (env : Lex_env.t) loc err = - (let lex_errors_acc = (loc, err) :: ((env.lex_state).lex_errors_acc) in - { env with lex_state = { lex_errors_acc } } : Lex_env.t) -let unexpected_error (env : Lex_env.t) (loc : Loc.t) value = - lex_error env loc (Parse_error.Unexpected (quote_token_value value)) -let unexpected_error_w_suggest (env : Lex_env.t) (loc : Loc.t) value suggest - = - lex_error env loc - (Parse_error.UnexpectedTokenWithSuggestion (value, suggest)) -let illegal (env : Lex_env.t) (loc : Loc.t) = - lex_error env loc (Parse_error.Unexpected "token ILLEGAL") -let new_line env lexbuf = - let offset = Sedlexing.lexeme_end lexbuf in - let lex_bol = { line = ((Lex_env.line env) + 1); offset } in - { env with Lex_env.lex_bol = lex_bol } -let bigint_strip_n raw = - let size = String.length raw in - let str = - if (size != 0) && ((raw.[size - 1]) == 'n') - then String.sub raw 0 (size - 1) - else raw in - str -let mk_comment (env : Lex_env.t) (start : Loc.position) (_end : Loc.position) - (buf : Buffer.t) (multiline : bool) = - (let open Flow_ast.Comment in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - let text = Buffer.contents buf in - let kind = if multiline then Block else Line in - let on_newline = - let open Loc in - ((env.lex_last_loc)._end).Loc.line < (loc.start).Loc.line in - let c = { kind; text; on_newline } in (loc, c) : Loc.t - Flow_ast.Comment.t) -let split_number_type = - let rec strip_whitespace i len lexeme = - if is_whitespace (lexeme.(i)) - then ((strip_whitespace)[@tailcall ]) (i + 1) len lexeme - else Sedlexing.string_of_utf8 (Array.sub lexeme i (len - i)) in - fun (lexeme : int array) -> - if (lexeme.(0)) = (Char.code '-') - then - let num = strip_whitespace 1 (Array.length lexeme) lexeme in - let raw = Sedlexing.string_of_utf8 lexeme in (true, num, raw) - else (let raw = Sedlexing.string_of_utf8 lexeme in (false, raw, raw)) -let mk_num_singleton number_type (lexeme : int array) = - let (neg, num, raw) = split_number_type lexeme in - let value = - match number_type with - | LEGACY_OCTAL -> - (try Int64.to_float (Int64.of_string ("0o" ^ num)) - with | Failure _ -> failwith ("Invalid legacy octal " ^ num)) - | BINARY | OCTAL -> - (try Int64.to_float (Int64.of_string num) - with | Failure _ -> failwith ("Invalid binary/octal " ^ num)) - | LEGACY_NON_OCTAL | NORMAL -> - (try float_of_string num - with | Failure _ -> failwith ("Invalid number " ^ num)) in - let value = if neg then -. value else value in - T_NUMBER_SINGLETON_TYPE { kind = number_type; value; raw } -let mk_bignum_singleton kind lexeme = - let (neg, num, raw) = split_number_type lexeme in - let postraw = bigint_strip_n num in - let value = - (Int64.of_string_opt postraw) |> - (Option.map (fun value -> if neg then Int64.neg value else value)) in - T_BIGINT_SINGLETON_TYPE { kind; value; raw } -let assert_valid_unicode_in_identifier env loc code = - if Js_id.is_valid_unicode_id code - then env - else lex_error env loc Parse_error.IllegalUnicodeEscape -let decode_identifier = - let loc_and_sub_lexeme env offset lexbuf trim_start trim_end = - let start_offset = offset + (Sedlexing.lexeme_start lexbuf) in - let end_offset = offset + (Sedlexing.lexeme_end lexbuf) in - let loc = loc_of_offsets env start_offset end_offset in - (loc, - (sub_lexeme lexbuf trim_start - (((Sedlexing.lexeme_length lexbuf) - trim_start) - trim_end))) in - let rec id_char env offset buf lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_7 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 2 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_8 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | 1 -> 1 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let (loc, hex) = loc_and_sub_lexeme env offset lexbuf 2 0 in - let code = int_of_string ("0x" ^ hex) in - let env = - if not (Uchar.is_valid code) - then lex_error env loc Parse_error.IllegalUnicodeEscape - else assert_valid_unicode_in_identifier env loc code in - (Wtf8.add_wtf_8 buf code; id_char env offset buf lexbuf) - | 1 -> - let (loc, hex) = loc_and_sub_lexeme env offset lexbuf 3 1 in - let code = int_of_string ("0x" ^ hex) in - let env = assert_valid_unicode_in_identifier env loc code in - (Wtf8.add_wtf_8 buf code; id_char env offset buf lexbuf) - | 2 -> (env, (Buffer.contents buf)) - | 3 -> (lexeme_to_buffer lexbuf buf; id_char env offset buf lexbuf) - | _ -> failwith "unreachable id_char") in - fun env -> - fun raw -> - let offset = Sedlexing.lexeme_start env.lex_lb in - let lexbuf = Sedlexing.from_int_array raw in - let buf = Buffer.create (Array.length raw) in - id_char env offset buf lexbuf -let recover env lexbuf ~f = - let env = illegal env (loc_of_lexbuf env lexbuf) in - Sedlexing.rollback lexbuf; f env lexbuf -type jsx_text_mode = - | JSX_SINGLE_QUOTED_TEXT - | JSX_DOUBLE_QUOTED_TEXT - | JSX_CHILD_TEXT -type result = - | Token of Lex_env.t * Token.t - | Comment of Lex_env.t * Loc.t Flow_ast.Comment.t - | Continue of Lex_env.t -let rec comment env buf lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_9 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> 0 - | 2 -> __sedlex_state_3 lexbuf - | 3 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_10 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_12 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> 1 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_13 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 2 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let env = new_line env lexbuf in - (lexeme_to_buffer lexbuf buf; comment env buf lexbuf) - | 1 -> - let env = - if is_in_comment_syntax env - then - let loc = loc_of_lexbuf env lexbuf in - unexpected_error_w_suggest env loc "*/" "*-/" - else env in - (env, (end_pos_of_lexbuf env lexbuf)) - | 2 -> - if is_in_comment_syntax env - then (env, (end_pos_of_lexbuf env lexbuf)) - else (Buffer.add_string buf "*-/"; comment env buf lexbuf) - | 3 -> (lexeme_to_buffer lexbuf buf; comment env buf lexbuf) - | _ -> - let env = illegal env (loc_of_lexbuf env lexbuf) in - (env, (end_pos_of_lexbuf env lexbuf))) -let rec line_comment env buf lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_14 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> 1 - | 3 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_15 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> (env, (end_pos_of_lexbuf env lexbuf)) - | 1 -> - let { Loc.line = line; column } = end_pos_of_lexbuf env lexbuf in - let env = new_line env lexbuf in - let len = Sedlexing.lexeme_length lexbuf in - let end_pos = { Loc.line = line; column = (column - len) } in - (env, end_pos) - | 2 -> (lexeme_to_buffer lexbuf buf; line_comment env buf lexbuf) - | _ -> failwith "unreachable line_comment") -let string_escape env lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_16 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> 16 - | 2 -> 15 - | 3 -> __sedlex_state_4 lexbuf - | 4 -> __sedlex_state_6 lexbuf - | 5 -> __sedlex_state_9 lexbuf - | 6 -> 0 - | 7 -> 5 - | 8 -> 6 - | 9 -> 7 - | 10 -> 8 - | 11 -> 9 - | 12 -> __sedlex_state_16 lexbuf - | 13 -> 10 - | 14 -> __sedlex_state_25 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 15; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 15 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 4; - (match __sedlex_partition_17 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_17 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 2 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_9 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 11; - (match __sedlex_partition_17 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_16 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 14; - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_17 lexbuf - | 1 -> __sedlex_state_21 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_17 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_18 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_18 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_19 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_19 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 12 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_21 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_22 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_22 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_22 lexbuf - | 1 -> 13 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_25 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 14; - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_26 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_26 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let str = lexeme lexbuf in - let codes = Sedlexing.lexeme lexbuf in (env, str, codes, false) - | 1 -> - let str = lexeme lexbuf in - let code = int_of_string ("0" ^ str) in (env, str, [|code|], false) - | 2 -> - let str = lexeme lexbuf in - let code = int_of_string ("0o" ^ str) in - if code < 256 - then (env, str, [|code|], true) - else - (let remainder = code land 7 in - let code = code lsr 3 in - (env, str, [|code;((Char.code '0') + remainder)|], true)) - | 3 -> - let str = lexeme lexbuf in - let code = int_of_string ("0o" ^ str) in (env, str, [|code|], true) - | 4 -> (env, "0", [|0x0|], false) - | 5 -> (env, "b", [|0x8|], false) - | 6 -> (env, "f", [|0xC|], false) - | 7 -> (env, "n", [|0xA|], false) - | 8 -> (env, "r", [|0xD|], false) - | 9 -> (env, "t", [|0x9|], false) - | 10 -> (env, "v", [|0xB|], false) - | 11 -> - let str = lexeme lexbuf in - let code = int_of_string ("0o" ^ str) in (env, str, [|code|], true) - | 12 -> - let str = lexeme lexbuf in - let hex = String.sub str 1 ((String.length str) - 1) in - let code = int_of_string ("0x" ^ hex) in (env, str, [|code|], false) - | 13 -> - let str = lexeme lexbuf in - let hex = String.sub str 2 ((String.length str) - 3) in - let code = int_of_string ("0x" ^ hex) in - let env = - if code > 0x10FFFF - then illegal env (loc_of_lexbuf env lexbuf) - else env in - (env, str, [|code|], false) - | 14 -> - let str = lexeme lexbuf in - let codes = Sedlexing.lexeme lexbuf in - let env = illegal env (loc_of_lexbuf env lexbuf) in - (env, str, codes, false) - | 15 -> - let str = lexeme lexbuf in - let env = new_line env lexbuf in (env, str, [||], false) - | 16 -> - let str = lexeme lexbuf in - let codes = Sedlexing.lexeme lexbuf in (env, str, codes, false) - | _ -> failwith "unreachable string_escape") -let rec string_quote env q buf raw octal lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_18 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 3 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> 2 - | 3 -> 0 - | 4 -> 1 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 4; - (match __sedlex_partition_19 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let q' = lexeme lexbuf in - (Buffer.add_string raw q'; - if q = q' - then (env, (end_pos_of_lexbuf env lexbuf), octal) - else - (Buffer.add_string buf q'; string_quote env q buf raw octal lexbuf)) - | 1 -> - (Buffer.add_string raw "\\"; - (let (env, str, codes, octal') = string_escape env lexbuf in - let octal = octal' || octal in - Buffer.add_string raw str; - Array.iter (Wtf8.add_wtf_8 buf) codes; - string_quote env q buf raw octal lexbuf)) - | 2 -> - let x = lexeme lexbuf in - (Buffer.add_string raw x; - (let env = illegal env (loc_of_lexbuf env lexbuf) in - let env = new_line env lexbuf in - Buffer.add_string buf x; - (env, (end_pos_of_lexbuf env lexbuf), octal))) - | 3 -> - let x = lexeme lexbuf in - (Buffer.add_string raw x; - (let env = illegal env (loc_of_lexbuf env lexbuf) in - Buffer.add_string buf x; - (env, (end_pos_of_lexbuf env lexbuf), octal))) - | 4 -> - (lexeme_to_buffer2 lexbuf raw buf; - string_quote env q buf raw octal lexbuf) - | _ -> failwith "unreachable string_quote") -let rec template_part env cooked raw literal lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_20 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> 5 - | 3 -> __sedlex_state_4 lexbuf - | 4 -> __sedlex_state_6 lexbuf - | 5 -> 3 - | 6 -> 1 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 6; - (match __sedlex_partition_21 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 5; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 4 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 6; - (match __sedlex_partition_22 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 2 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> let env = illegal env (loc_of_lexbuf env lexbuf) in (env, true) - | 1 -> (Buffer.add_char literal '`'; (env, true)) - | 2 -> (Buffer.add_string literal "${"; (env, false)) - | 3 -> - (Buffer.add_char raw '\\'; - Buffer.add_char literal '\\'; - (let (env, str, codes, _) = string_escape env lexbuf in - Buffer.add_string raw str; - Buffer.add_string literal str; - Array.iter (Wtf8.add_wtf_8 cooked) codes; - template_part env cooked raw literal lexbuf)) - | 4 -> - (Buffer.add_string raw "\r\n"; - Buffer.add_string literal "\r\n"; - Buffer.add_string cooked "\n"; - (let env = new_line env lexbuf in - template_part env cooked raw literal lexbuf)) - | 5 -> - let lf = lexeme lexbuf in - (Buffer.add_string raw lf; - Buffer.add_string literal lf; - Buffer.add_char cooked '\n'; - (let env = new_line env lexbuf in - template_part env cooked raw literal lexbuf)) - | 6 -> - let c = lexeme lexbuf in - (Buffer.add_string raw c; - Buffer.add_string literal c; - Buffer.add_string cooked c; - template_part env cooked raw literal lexbuf) - | _ -> failwith "unreachable template_part") -let token (env : Lex_env.t) lexbuf = - (let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_50 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 98 - | 1 -> 99 - | 2 -> __sedlex_state_3 lexbuf - | 3 -> 0 - | 4 -> __sedlex_state_6 lexbuf - | 5 -> __sedlex_state_8 lexbuf - | 6 -> 7 - | 7 -> __sedlex_state_12 lexbuf - | 8 -> 97 - | 9 -> __sedlex_state_15 lexbuf - | 10 -> __sedlex_state_17 lexbuf - | 11 -> 38 - | 12 -> 39 - | 13 -> __sedlex_state_23 lexbuf - | 14 -> __sedlex_state_28 lexbuf - | 15 -> 45 - | 16 -> __sedlex_state_32 lexbuf - | 17 -> __sedlex_state_35 lexbuf - | 18 -> __sedlex_state_58 lexbuf - | 19 -> __sedlex_state_76 lexbuf - | 20 -> __sedlex_state_129 lexbuf - | 21 -> 46 - | 22 -> 44 - | 23 -> __sedlex_state_135 lexbuf - | 24 -> __sedlex_state_139 lexbuf - | 25 -> __sedlex_state_143 lexbuf - | 26 -> __sedlex_state_149 lexbuf - | 27 -> __sedlex_state_154 lexbuf - | 28 -> 40 - | 29 -> __sedlex_state_177 lexbuf - | 30 -> 41 - | 31 -> __sedlex_state_186 lexbuf - | 32 -> 8 - | 33 -> 36 - | 34 -> __sedlex_state_190 lexbuf - | 35 -> 37 - | 36 -> 89 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_8 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 88; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_9 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 58; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 54 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_12 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 95; - (match __sedlex_partition_53 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 6 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_15 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 84; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 71 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_17 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 86; - (match __sedlex_partition_54 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_18 lexbuf - | 1 -> 72 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_18 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 51; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 76 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_23 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 82; - (match __sedlex_partition_55 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_24 lexbuf - | 1 -> 4 - | 2 -> 69 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_24 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 83; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 70 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_28 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 80; - (match __sedlex_partition_56 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 59 - | 1 -> 67 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_32 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 81; - (match __sedlex_partition_57 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 60 - | 1 -> 68 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_35 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 43; - (match __sedlex_partition_47 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_36 lexbuf - | 1 -> __sedlex_state_38 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_36 = - function - | lexbuf -> - (match __sedlex_partition_58 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 42 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_38 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_38 lexbuf - | 2 -> __sedlex_state_40 lexbuf - | 3 -> __sedlex_state_54 lexbuf - | 4 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_39 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 33; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_40 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 33; - (match __sedlex_partition_61 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_41 lexbuf - | 2 -> __sedlex_state_49 lexbuf - | 3 -> __sedlex_state_53 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_41 = - function - | lexbuf -> - (match __sedlex_partition_40 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_42 lexbuf - | 1 -> __sedlex_state_46 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_42 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 28; - (match __sedlex_partition_62 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_43 lexbuf - | 1 -> __sedlex_state_42 lexbuf - | 2 -> __sedlex_state_44 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_43 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 27; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_43 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_44 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 26; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_45 lexbuf - | 1 -> __sedlex_state_43 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_45 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 25; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_46 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 28; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_43 lexbuf - | 1 -> __sedlex_state_46 lexbuf - | 2 -> __sedlex_state_47 lexbuf - | 3 -> __sedlex_state_44 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_47 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_48 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_48 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 28; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_43 lexbuf - | 1 -> __sedlex_state_48 lexbuf - | 2 -> __sedlex_state_47 lexbuf - | 3 -> __sedlex_state_44 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_49 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 28; - (match __sedlex_partition_62 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_50 lexbuf - | 1 -> __sedlex_state_49 lexbuf - | 2 -> __sedlex_state_51 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_50 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 27; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_50 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_51 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 26; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_52 lexbuf - | 1 -> __sedlex_state_50 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_52 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 25; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_52 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_53 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 28; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_50 lexbuf - | 1 -> __sedlex_state_53 lexbuf - | 2 -> __sedlex_state_47 lexbuf - | 3 -> __sedlex_state_51 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_54 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_55 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_55 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_55 lexbuf - | 2 -> __sedlex_state_40 lexbuf - | 3 -> __sedlex_state_54 lexbuf - | 4 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_56 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 31; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_57 lexbuf - | 1 -> __sedlex_state_39 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_57 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 29; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_57 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_58 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 93; - (match __sedlex_partition_55 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_59 lexbuf - | 1 -> 5 - | 2 -> 92 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_59 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_65 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_60 lexbuf - | 1 -> __sedlex_state_61 lexbuf - | 2 -> __sedlex_state_63 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_60 = - function - | lexbuf -> - (match __sedlex_partition_65 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_60 lexbuf - | 1 -> __sedlex_state_61 lexbuf - | 2 -> __sedlex_state_63 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_61 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_66 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 3 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_63 = - function - | lexbuf -> - (match __sedlex_partition_67 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_64 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_64 = - function - | lexbuf -> - (match __sedlex_partition_68 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_65 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_65 = - function - | lexbuf -> - (match __sedlex_partition_69 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_66 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_66 = - function - | lexbuf -> - (match __sedlex_partition_70 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_67 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_67 = - function - | lexbuf -> - (match __sedlex_partition_71 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_68 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_68 = - function - | lexbuf -> - (match __sedlex_partition_72 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_69 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_69 = - function - | lexbuf -> - (match __sedlex_partition_73 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_70 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_70 = - function - | lexbuf -> - (match __sedlex_partition_67 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_71 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_71 = - function - | lexbuf -> - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_72 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_72 = - function - | lexbuf -> - (match __sedlex_partition_74 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_73 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_73 = - function - | lexbuf -> - (match __sedlex_partition_75 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 3 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_76 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_76 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_77 lexbuf - | 2 -> __sedlex_state_81 lexbuf - | 3 -> __sedlex_state_93 lexbuf - | 4 -> __sedlex_state_97 lexbuf - | 5 -> __sedlex_state_40 lexbuf - | 6 -> __sedlex_state_107 lexbuf - | 7 -> __sedlex_state_117 lexbuf - | 8 -> __sedlex_state_127 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_77 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_77 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_78 lexbuf - | 2 -> __sedlex_state_40 lexbuf - | 3 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_78 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_78 lexbuf - | 2 -> __sedlex_state_40 lexbuf - | 3 -> __sedlex_state_79 lexbuf - | 4 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_79 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_80 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_80 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_80 lexbuf - | 2 -> __sedlex_state_40 lexbuf - | 3 -> __sedlex_state_79 lexbuf - | 4 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_81 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 20; - (match __sedlex_partition_78 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_82 lexbuf - | 1 -> __sedlex_state_83 lexbuf - | 2 -> __sedlex_state_81 lexbuf - | 3 -> __sedlex_state_87 lexbuf - | 4 -> __sedlex_state_91 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_82 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 19; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_82 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_83 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_62 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_84 lexbuf - | 2 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_84 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_84 lexbuf - | 2 -> __sedlex_state_85 lexbuf - | 3 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_85 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_86 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_86 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_86 lexbuf - | 2 -> __sedlex_state_85 lexbuf - | 3 -> __sedlex_state_56 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_87 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 18; - (match __sedlex_partition_79 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_88 lexbuf - | 1 -> __sedlex_state_83 lexbuf - | 2 -> __sedlex_state_87 lexbuf - | 3 -> __sedlex_state_89 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_88 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_88 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_89 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_90 lexbuf - | 1 -> __sedlex_state_88 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_90 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_90 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_91 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 19; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_92 lexbuf - | 1 -> __sedlex_state_82 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_92 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 19; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_92 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_93 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 18; - (match __sedlex_partition_79 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_94 lexbuf - | 1 -> __sedlex_state_83 lexbuf - | 2 -> __sedlex_state_93 lexbuf - | 3 -> __sedlex_state_95 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_94 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_94 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_95 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_96 lexbuf - | 1 -> __sedlex_state_94 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_96 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_96 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_97 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 33; - (match __sedlex_partition_80 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_98 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_98 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 12; - (match __sedlex_partition_81 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_99 lexbuf - | 1 -> __sedlex_state_98 lexbuf - | 2 -> __sedlex_state_100 lexbuf - | 3 -> __sedlex_state_105 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_99 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 11; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_99 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_100 = - function - | lexbuf -> - (match __sedlex_partition_26 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_101 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_101 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 12; - (match __sedlex_partition_81 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_102 lexbuf - | 1 -> __sedlex_state_101 lexbuf - | 2 -> __sedlex_state_100 lexbuf - | 3 -> __sedlex_state_103 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_102 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 11; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_102 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_103 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 10; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_104 lexbuf - | 1 -> __sedlex_state_102 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_104 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 9; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_104 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_105 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 10; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_106 lexbuf - | 1 -> __sedlex_state_99 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_106 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 9; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_106 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_107 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 33; - (match __sedlex_partition_82 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_108 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_108 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 16; - (match __sedlex_partition_83 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_109 lexbuf - | 1 -> __sedlex_state_108 lexbuf - | 2 -> __sedlex_state_110 lexbuf - | 3 -> __sedlex_state_115 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_109 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 15; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_109 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_110 = - function - | lexbuf -> - (match __sedlex_partition_17 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_111 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_111 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 16; - (match __sedlex_partition_83 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_112 lexbuf - | 1 -> __sedlex_state_111 lexbuf - | 2 -> __sedlex_state_110 lexbuf - | 3 -> __sedlex_state_113 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_112 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 15; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_112 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_113 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 14; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_114 lexbuf - | 1 -> __sedlex_state_112 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_114 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 13; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_114 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_115 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 14; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_116 lexbuf - | 1 -> __sedlex_state_109 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_116 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 13; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_116 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_117 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 33; - (match __sedlex_partition_84 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_118 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_118 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 24; - (match __sedlex_partition_85 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_119 lexbuf - | 1 -> __sedlex_state_118 lexbuf - | 2 -> __sedlex_state_120 lexbuf - | 3 -> __sedlex_state_125 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_119 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 23; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_119 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_120 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_121 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_121 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 24; - (match __sedlex_partition_85 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_122 lexbuf - | 1 -> __sedlex_state_121 lexbuf - | 2 -> __sedlex_state_120 lexbuf - | 3 -> __sedlex_state_123 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_122 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 23; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_122 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_123 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 22; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_124 lexbuf - | 1 -> __sedlex_state_122 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_124 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 21; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_124 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_125 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 22; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_126 lexbuf - | 1 -> __sedlex_state_119 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_126 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 21; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_126 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_127 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 32; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_128 lexbuf - | 1 -> __sedlex_state_39 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_128 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_128 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_129 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_86 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_77 lexbuf - | 2 -> __sedlex_state_130 lexbuf - | 3 -> __sedlex_state_40 lexbuf - | 4 -> __sedlex_state_131 lexbuf - | 5 -> __sedlex_state_127 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_130 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_86 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_77 lexbuf - | 2 -> __sedlex_state_130 lexbuf - | 3 -> __sedlex_state_40 lexbuf - | 4 -> __sedlex_state_131 lexbuf - | 5 -> __sedlex_state_127 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_131 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_132 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_132 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_87 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_83 lexbuf - | 2 -> __sedlex_state_132 lexbuf - | 3 -> __sedlex_state_131 lexbuf - | 4 -> __sedlex_state_127 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_135 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 78; - (match __sedlex_partition_88 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_136 lexbuf - | 1 -> 55 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_136 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 62; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 61 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_139 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 90; - (match __sedlex_partition_89 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_140 lexbuf - | 1 -> 91 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_140 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 57; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 53 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_143 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 79; - (match __sedlex_partition_89 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 56 - | 1 -> __sedlex_state_145 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_145 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 66; - (match __sedlex_partition_89 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 63 - | 1 -> __sedlex_state_147 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_147 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 65; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 64 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_149 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 50; - (match __sedlex_partition_90 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_150 lexbuf - | 1 -> __sedlex_state_152 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_150 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 48; - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 47 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_152 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 49; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 75 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_154 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 94; - (match __sedlex_partition_91 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_155 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_155 = - function - | lexbuf -> - (match __sedlex_partition_92 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_156 lexbuf - | 1 -> __sedlex_state_169 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_156 = - function - | lexbuf -> - (match __sedlex_partition_93 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_157 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_157 = - function - | lexbuf -> - (match __sedlex_partition_94 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_158 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_158 = - function - | lexbuf -> - (match __sedlex_partition_72 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_159 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_159 = - function - | lexbuf -> - (match __sedlex_partition_73 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_160 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_160 = - function - | lexbuf -> - (match __sedlex_partition_95 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_161 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_161 = - function - | lexbuf -> - (match __sedlex_partition_96 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_162 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_162 = - function - | lexbuf -> - (match __sedlex_partition_75 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_163 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_163 = - function - | lexbuf -> - (match __sedlex_partition_97 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_164 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_164 = - function - | lexbuf -> - (match __sedlex_partition_98 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_165 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_165 = - function - | lexbuf -> - (match __sedlex_partition_96 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_166 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_166 = - function - | lexbuf -> - (match __sedlex_partition_68 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_167 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_167 = - function - | lexbuf -> - (match __sedlex_partition_97 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 35 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_169 = - function - | lexbuf -> - (match __sedlex_partition_96 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_170 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_170 = - function - | lexbuf -> - (match __sedlex_partition_75 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_171 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_171 = - function - | lexbuf -> - (match __sedlex_partition_97 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_172 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_172 = - function - | lexbuf -> - (match __sedlex_partition_98 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_173 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_173 = - function - | lexbuf -> - (match __sedlex_partition_96 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_174 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_174 = - function - | lexbuf -> - (match __sedlex_partition_68 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_175 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_175 = - function - | lexbuf -> - (match __sedlex_partition_97 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 35 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_177 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 96; - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_178 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_178 = - function - | lexbuf -> - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_179 lexbuf - | 1 -> __sedlex_state_183 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_179 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_180 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_180 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_181 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_181 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 97 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_183 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_184 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_184 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_184 lexbuf - | 1 -> 97 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_186 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 87; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 74 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_190 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 85; - (match __sedlex_partition_99 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 73 - | 1 -> __sedlex_state_192 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_192 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 52; - (match __sedlex_partition_52 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 77 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> let env = new_line env lexbuf in Continue env - | 1 -> Continue env - | 2 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf true)) - | 3 -> - let pattern = lexeme lexbuf in - if not (is_comment_syntax_enabled env) - then - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - (Buffer.add_string buf - (String.sub pattern 2 ((String.length pattern) - 2)); - (let (env, end_pos) = comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf true)))) - else - (let env = - if is_in_comment_syntax env - then - let loc = loc_of_lexbuf env lexbuf in - unexpected_error env loc pattern - else env in - let env = in_comment_syntax true env in - let len = Sedlexing.lexeme_length lexbuf in - if - ((Sedlexing.Utf8.sub_lexeme lexbuf (len - 1) 1) = ":") && - ((Sedlexing.Utf8.sub_lexeme lexbuf (len - 2) 1) <> ":") - then Token (env, T_COLON) - else Continue env) - | 4 -> - if is_in_comment_syntax env - then let env = in_comment_syntax false env in Continue env - else - (Sedlexing.rollback lexbuf; - (let __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_23 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> Token (env, T_MULT) - | _ -> failwith "expected *"))) - | 5 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = line_comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf false)) - | 6 -> - if (Sedlexing.lexeme_start lexbuf) = 0 - then - let (env, _) = line_comment env (Buffer.create 127) lexbuf in - Continue env - else Token (env, (T_ERROR "#!")) - | 7 -> - let quote = lexeme lexbuf in - let start = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let raw = Buffer.create 127 in - (Buffer.add_string raw quote; - (let octal = false in - let (env, _end, octal) = - string_quote env quote buf raw octal lexbuf in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - Token - (env, - (T_STRING - (loc, (Buffer.contents buf), (Buffer.contents raw), octal))))) - | 8 -> - let cooked = Buffer.create 127 in - let raw = Buffer.create 127 in - let literal = Buffer.create 127 in - (lexeme_to_buffer lexbuf literal; - (let start = start_pos_of_lexbuf env lexbuf in - let (env, is_tail) = template_part env cooked raw literal lexbuf in - let _end = end_pos_of_lexbuf env lexbuf in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - Token - (env, - (T_TEMPLATE_PART - (loc, - { - cooked = (Buffer.contents cooked); - raw = (Buffer.contents raw); - literal = (Buffer.contents literal) - }, is_tail))))) - | 9 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_25 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_27 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_27 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_BIGINT - { kind = BIG_BINARY; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token bigint")) - | 10 -> - Token (env, (T_BIGINT { kind = BIG_BINARY; raw = (lexeme lexbuf) })) - | 11 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_25 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_28 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_28 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_NUMBER { kind = BINARY; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token bignumber")) - | 12 -> Token (env, (T_NUMBER { kind = BINARY; raw = (lexeme lexbuf) })) - | 13 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_29 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_30 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_30 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_BIGINT - { kind = BIG_OCTAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token octbigint")) - | 14 -> - Token (env, (T_BIGINT { kind = BIG_OCTAL; raw = (lexeme lexbuf) })) - | 15 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_29 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_31 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_31 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_NUMBER { kind = OCTAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token octnumber")) - | 16 -> Token (env, (T_NUMBER { kind = OCTAL; raw = (lexeme lexbuf) })) - | 17 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_32 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_NUMBER - { - kind = LEGACY_NON_OCTAL; - raw = (lexeme lexbuf) - })) - | _ -> failwith "unreachable token legacynonoctnumber")) - | 18 -> - Token - (env, - (T_NUMBER { kind = LEGACY_NON_OCTAL; raw = (lexeme lexbuf) })) - | 19 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_NUMBER - { kind = LEGACY_OCTAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token legacyoctnumber")) - | 20 -> - Token - (env, (T_NUMBER { kind = LEGACY_OCTAL; raw = (lexeme lexbuf) })) - | 21 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_34 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_35 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_35 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_BIGINT - { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token hexbigint")) - | 22 -> - Token (env, (T_BIGINT { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | 23 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_24 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_34 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_36 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_36 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_NUMBER { kind = NORMAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token hexnumber")) - | 24 -> Token (env, (T_NUMBER { kind = NORMAL; raw = (lexeme lexbuf) })) - | 25 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_37 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_12 lexbuf - | 2 -> __sedlex_state_17 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_39 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_40 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_41 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | 1 -> __sedlex_state_8 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | 1 -> __sedlex_state_8 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_12 = - function - | lexbuf -> - (match __sedlex_partition_43 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_13 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_13 = - function - | lexbuf -> - (match __sedlex_partition_44 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_14 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_14 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_14 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_15 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_16 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_16 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_16 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_17 = - function - | lexbuf -> - (match __sedlex_partition_45 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_13 lexbuf - | 1 -> __sedlex_state_17 lexbuf - | 2 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let loc = loc_of_lexbuf env lexbuf in - let env = - lex_error env loc Parse_error.InvalidSciBigInt in - Token - (env, - (T_BIGINT - { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token scibigint")) - | 26 -> - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.InvalidSciBigInt in - Token (env, (T_BIGINT { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | 27 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_37 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_11 lexbuf - | 2 -> __sedlex_state_16 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_39 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_40 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_43 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_12 = - function - | lexbuf -> - (match __sedlex_partition_44 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_13 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_13 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_13 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_14 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_14 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_15 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_15 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> __sedlex_state_14 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_16 = - function - | lexbuf -> - (match __sedlex_partition_45 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | 1 -> __sedlex_state_16 lexbuf - | 2 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_NUMBER { kind = NORMAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token scinumber")) - | 28 -> Token (env, (T_NUMBER { kind = NORMAL; raw = (lexeme lexbuf) })) - | 29 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_37 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_6 lexbuf - | 2 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_47 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | 1 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_41 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | 1 -> __sedlex_state_8 lexbuf - | 2 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | 1 -> __sedlex_state_10 lexbuf - | 2 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let loc = loc_of_lexbuf env lexbuf in - let env = - lex_error env loc Parse_error.InvalidFloatBigInt in - Token - (env, - (T_BIGINT - { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token floatbigint")) - | 30 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_40 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_41 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_BIGINT - { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token wholebigint")) - | 31 -> - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.InvalidFloatBigInt in - Token (env, (T_BIGINT { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | 32 -> - Token (env, (T_BIGINT { kind = BIG_NORMAL; raw = (lexeme lexbuf) })) - | 33 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_37 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_47 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | 2 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_9 lexbuf - | 2 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - Token - (env, - (T_NUMBER { kind = NORMAL; raw = (lexeme lexbuf) })) - | _ -> failwith "unreachable token wholenumber")) - | 34 -> Token (env, (T_NUMBER { kind = NORMAL; raw = (lexeme lexbuf) })) - | 35 -> - let loc = loc_of_lexbuf env lexbuf in - let raw = lexeme lexbuf in - Token (env, (T_IDENTIFIER { loc; value = raw; raw })) - | 36 -> Token (env, T_LCURLY) - | 37 -> Token (env, T_RCURLY) - | 38 -> Token (env, T_LPAREN) - | 39 -> Token (env, T_RPAREN) - | 40 -> Token (env, T_LBRACKET) - | 41 -> Token (env, T_RBRACKET) - | 42 -> Token (env, T_ELLIPSIS) - | 43 -> Token (env, T_PERIOD) - | 44 -> Token (env, T_SEMICOLON) - | 45 -> Token (env, T_COMMA) - | 46 -> Token (env, T_COLON) - | 47 -> - (Sedlexing.rollback lexbuf; - (let __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_49 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> Token (env, T_PLING) - | _ -> failwith "expected ?"))) - | 48 -> Token (env, T_PLING_PERIOD) - | 49 -> Token (env, T_PLING_PLING) - | 50 -> Token (env, T_PLING) - | 51 -> Token (env, T_AND) - | 52 -> Token (env, T_OR) - | 53 -> Token (env, T_STRICT_EQUAL) - | 54 -> Token (env, T_STRICT_NOT_EQUAL) - | 55 -> Token (env, T_LESS_THAN_EQUAL) - | 56 -> Token (env, T_GREATER_THAN_EQUAL) - | 57 -> Token (env, T_EQUAL) - | 58 -> Token (env, T_NOT_EQUAL) - | 59 -> Token (env, T_INCR) - | 60 -> Token (env, T_DECR) - | 61 -> Token (env, T_LSHIFT_ASSIGN) - | 62 -> Token (env, T_LSHIFT) - | 63 -> Token (env, T_RSHIFT_ASSIGN) - | 64 -> Token (env, T_RSHIFT3_ASSIGN) - | 65 -> Token (env, T_RSHIFT3) - | 66 -> Token (env, T_RSHIFT) - | 67 -> Token (env, T_PLUS_ASSIGN) - | 68 -> Token (env, T_MINUS_ASSIGN) - | 69 -> Token (env, T_MULT_ASSIGN) - | 70 -> Token (env, T_EXP_ASSIGN) - | 71 -> Token (env, T_MOD_ASSIGN) - | 72 -> Token (env, T_BIT_AND_ASSIGN) - | 73 -> Token (env, T_BIT_OR_ASSIGN) - | 74 -> Token (env, T_BIT_XOR_ASSIGN) - | 75 -> Token (env, T_NULLISH_ASSIGN) - | 76 -> Token (env, T_AND_ASSIGN) - | 77 -> Token (env, T_OR_ASSIGN) - | 78 -> Token (env, T_LESS_THAN) - | 79 -> Token (env, T_GREATER_THAN) - | 80 -> Token (env, T_PLUS) - | 81 -> Token (env, T_MINUS) - | 82 -> Token (env, T_MULT) - | 83 -> Token (env, T_EXP) - | 84 -> Token (env, T_MOD) - | 85 -> Token (env, T_BIT_OR) - | 86 -> Token (env, T_BIT_AND) - | 87 -> Token (env, T_BIT_XOR) - | 88 -> Token (env, T_NOT) - | 89 -> Token (env, T_BIT_NOT) - | 90 -> Token (env, T_ASSIGN) - | 91 -> Token (env, T_ARROW) - | 92 -> Token (env, T_DIV_ASSIGN) - | 93 -> Token (env, T_DIV) - | 94 -> Token (env, T_AT) - | 95 -> Token (env, T_POUND) - | 96 -> let env = illegal env (loc_of_lexbuf env lexbuf) in Continue env - | 97 -> - let start_offset = Sedlexing.lexeme_start lexbuf in - ((loop_id_continues lexbuf) |> ignore; - (let end_offset = Sedlexing.lexeme_end lexbuf in - let loc = loc_of_offsets env start_offset end_offset in - Sedlexing.set_lexeme_start lexbuf start_offset; - (let raw = Sedlexing.lexeme lexbuf in - let (nenv, value) = decode_identifier env raw in - match value with - | "async" -> Token (env, T_ASYNC) - | "await" -> Token (env, T_AWAIT) - | "break" -> Token (env, T_BREAK) - | "case" -> Token (env, T_CASE) - | "catch" -> Token (env, T_CATCH) - | "class" -> Token (env, T_CLASS) - | "const" -> Token (env, T_CONST) - | "continue" -> Token (env, T_CONTINUE) - | "debugger" -> Token (env, T_DEBUGGER) - | "declare" -> Token (env, T_DECLARE) - | "default" -> Token (env, T_DEFAULT) - | "delete" -> Token (env, T_DELETE) - | "do" -> Token (env, T_DO) - | "else" -> Token (env, T_ELSE) - | "enum" -> Token (env, T_ENUM) - | "export" -> Token (env, T_EXPORT) - | "extends" -> Token (env, T_EXTENDS) - | "false" -> Token (env, T_FALSE) - | "finally" -> Token (env, T_FINALLY) - | "for" -> Token (env, T_FOR) - | "function" -> Token (env, T_FUNCTION) - | "if" -> Token (env, T_IF) - | "implements" -> Token (env, T_IMPLEMENTS) - | "import" -> Token (env, T_IMPORT) - | "in" -> Token (env, T_IN) - | "instanceof" -> Token (env, T_INSTANCEOF) - | "interface" -> Token (env, T_INTERFACE) - | "let" -> Token (env, T_LET) - | "new" -> Token (env, T_NEW) - | "null" -> Token (env, T_NULL) - | "of" -> Token (env, T_OF) - | "opaque" -> Token (env, T_OPAQUE) - | "package" -> Token (env, T_PACKAGE) - | "private" -> Token (env, T_PRIVATE) - | "protected" -> Token (env, T_PROTECTED) - | "public" -> Token (env, T_PUBLIC) - | "return" -> Token (env, T_RETURN) - | "static" -> Token (env, T_STATIC) - | "super" -> Token (env, T_SUPER) - | "switch" -> Token (env, T_SWITCH) - | "this" -> Token (env, T_THIS) - | "throw" -> Token (env, T_THROW) - | "true" -> Token (env, T_TRUE) - | "try" -> Token (env, T_TRY) - | "type" -> Token (env, T_TYPE) - | "typeof" -> Token (env, T_TYPEOF) - | "var" -> Token (env, T_VAR) - | "void" -> Token (env, T_VOID) - | "while" -> Token (env, T_WHILE) - | "with" -> Token (env, T_WITH) - | "yield" -> Token (env, T_YIELD) - | _ -> - Token - (nenv, - (T_IDENTIFIER - { loc; value; raw = (Sedlexing.string_of_utf8 raw) }))))) - | 98 -> - let env = - if is_in_comment_syntax env - then - let loc = loc_of_lexbuf env lexbuf in - lex_error env loc Parse_error.UnexpectedEOS - else env in - Token (env, T_EOF) - | 99 -> - let env = illegal env (loc_of_lexbuf env lexbuf) in - Token (env, (T_ERROR (lexeme lexbuf))) - | _ -> failwith "unreachable token") : result) -let rec regexp_class env buf lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_100 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> 4 - | 3 -> __sedlex_state_4 lexbuf - | 4 -> __sedlex_state_6 lexbuf - | 5 -> 3 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 5; - (match __sedlex_partition_101 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 4; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 4 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 5; - (match __sedlex_partition_102 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | 1 -> 2 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> env - | 1 -> (Buffer.add_string buf "\\\\"; regexp_class env buf lexbuf) - | 2 -> - (Buffer.add_char buf '\\'; - Buffer.add_char buf ']'; - regexp_class env buf lexbuf) - | 3 -> (Buffer.add_char buf ']'; env) - | 4 -> - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.UnterminatedRegExp in - let env = new_line env lexbuf in env - | 5 -> - let str = lexeme lexbuf in - (Buffer.add_string buf str; regexp_class env buf lexbuf) - | _ -> failwith "unreachable regexp_class") -let rec regexp_body env buf lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_103 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> 6 - | 3 -> __sedlex_state_4 lexbuf - | 4 -> __sedlex_state_6 lexbuf - | 5 -> 5 - | 6 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 7; - (match __sedlex_partition_104 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 6; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 6 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 4; - (match __sedlex_partition_105 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_105 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_9 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 7; - (match __sedlex_partition_106 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 2 - | 1 -> 1 - | 2 -> __sedlex_state_12 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_12 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.UnterminatedRegExp in - (env, "") - | 1 -> - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.UnterminatedRegExp in - let env = new_line env lexbuf in (env, "") - | 2 -> - let s = lexeme lexbuf in - (Buffer.add_string buf s; regexp_body env buf lexbuf) - | 3 -> - let flags = - let str = lexeme lexbuf in - String.sub str 1 ((String.length str) - 1) in - (env, flags) - | 4 -> (env, "") - | 5 -> - (Buffer.add_char buf '['; - (let env = regexp_class env buf lexbuf in regexp_body env buf lexbuf)) - | 6 -> - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.UnterminatedRegExp in - let env = new_line env lexbuf in (env, "") - | 7 -> - let str = lexeme lexbuf in - (Buffer.add_string buf str; regexp_body env buf lexbuf) - | _ -> failwith "unreachable regexp_body") -let regexp env lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_107 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> 6 - | 2 -> __sedlex_state_3 lexbuf - | 3 -> 1 - | 4 -> __sedlex_state_6 lexbuf - | 5 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_8 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 5; - (match __sedlex_partition_108 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 4 - | 1 -> 3 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> Token (env, T_EOF) - | 1 -> let env = new_line env lexbuf in Continue env - | 2 -> Continue env - | 3 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = line_comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf false)) - | 4 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf true)) - | 5 -> - let start = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, flags) = regexp_body env buf lexbuf in - let _end = end_pos_of_lexbuf env lexbuf in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - Token (env, (T_REGEXP (loc, (Buffer.contents buf), flags))) - | 6 -> - let env = illegal env (loc_of_lexbuf env lexbuf) in - Token (env, (T_ERROR (lexeme lexbuf))) - | _ -> failwith "unreachable regexp") -let rec jsx_text env mode buf raw lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_109 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> 2 - | 3 -> __sedlex_state_4 lexbuf - | 4 -> 0 - | 5 -> __sedlex_state_7 lexbuf - | 6 -> __sedlex_state_23 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 6; - (match __sedlex_partition_110 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 2 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 6; - (match __sedlex_partition_111 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> __sedlex_state_14 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_112 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | 1 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_113 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | 1 -> 4 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_12 = - function - | lexbuf -> - (match __sedlex_partition_114 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | 1 -> 3 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_14 = - function - | lexbuf -> - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_15 = - function - | lexbuf -> - (match __sedlex_partition_115 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_16 lexbuf - | 1 -> 5 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_16 = - function - | lexbuf -> - (match __sedlex_partition_115 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_17 lexbuf - | 1 -> 5 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_17 = - function - | lexbuf -> - (match __sedlex_partition_115 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_18 lexbuf - | 1 -> 5 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_18 = - function - | lexbuf -> - (match __sedlex_partition_115 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_19 lexbuf - | 1 -> 5 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_19 = - function - | lexbuf -> - (match __sedlex_partition_115 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_20 lexbuf - | 1 -> 5 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_20 = - function - | lexbuf -> - (match __sedlex_partition_115 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_21 lexbuf - | 1 -> 5 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_21 = - function - | lexbuf -> - (match __sedlex_partition_116 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 5 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_23 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_110 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let c = lexeme lexbuf in - (match (mode, c) with - | (JSX_SINGLE_QUOTED_TEXT, "'") | (JSX_DOUBLE_QUOTED_TEXT, "\"") -> - env - | (JSX_CHILD_TEXT, ("<" | "{")) -> (Sedlexing.rollback lexbuf; env) - | (JSX_CHILD_TEXT, ">") -> - unexpected_error_w_suggest env (loc_of_lexbuf env lexbuf) ">" - "{'>'}" - | (JSX_CHILD_TEXT, "}") -> - unexpected_error_w_suggest env (loc_of_lexbuf env lexbuf) "}" - "{'}'}" - | _ -> - (Buffer.add_string raw c; - Buffer.add_string buf c; - jsx_text env mode buf raw lexbuf)) - | 1 -> let env = illegal env (loc_of_lexbuf env lexbuf) in env - | 2 -> - let lt = lexeme lexbuf in - (Buffer.add_string raw lt; - Buffer.add_string buf lt; - (let env = new_line env lexbuf in jsx_text env mode buf raw lexbuf)) - | 3 -> - let s = lexeme lexbuf in - let n = String.sub s 3 ((String.length s) - 4) in - (Buffer.add_string raw s; - (let code = int_of_string ("0x" ^ n) in - Wtf8.add_wtf_8 buf code; jsx_text env mode buf raw lexbuf)) - | 4 -> - let s = lexeme lexbuf in - let n = String.sub s 2 ((String.length s) - 3) in - (Buffer.add_string raw s; - (let code = int_of_string n in - Wtf8.add_wtf_8 buf code; jsx_text env mode buf raw lexbuf)) - | 5 -> - let s = lexeme lexbuf in - let entity = String.sub s 1 ((String.length s) - 2) in - (Buffer.add_string raw s; - (let code = - match entity with - | "quot" -> Some 0x0022 - | "amp" -> Some 0x0026 - | "apos" -> Some 0x0027 - | "lt" -> Some 0x003C - | "gt" -> Some 0x003E - | "nbsp" -> Some 0x00A0 - | "iexcl" -> Some 0x00A1 - | "cent" -> Some 0x00A2 - | "pound" -> Some 0x00A3 - | "curren" -> Some 0x00A4 - | "yen" -> Some 0x00A5 - | "brvbar" -> Some 0x00A6 - | "sect" -> Some 0x00A7 - | "uml" -> Some 0x00A8 - | "copy" -> Some 0x00A9 - | "ordf" -> Some 0x00AA - | "laquo" -> Some 0x00AB - | "not" -> Some 0x00AC - | "shy" -> Some 0x00AD - | "reg" -> Some 0x00AE - | "macr" -> Some 0x00AF - | "deg" -> Some 0x00B0 - | "plusmn" -> Some 0x00B1 - | "sup2" -> Some 0x00B2 - | "sup3" -> Some 0x00B3 - | "acute" -> Some 0x00B4 - | "micro" -> Some 0x00B5 - | "para" -> Some 0x00B6 - | "middot" -> Some 0x00B7 - | "cedil" -> Some 0x00B8 - | "sup1" -> Some 0x00B9 - | "ordm" -> Some 0x00BA - | "raquo" -> Some 0x00BB - | "frac14" -> Some 0x00BC - | "frac12" -> Some 0x00BD - | "frac34" -> Some 0x00BE - | "iquest" -> Some 0x00BF - | "Agrave" -> Some 0x00C0 - | "Aacute" -> Some 0x00C1 - | "Acirc" -> Some 0x00C2 - | "Atilde" -> Some 0x00C3 - | "Auml" -> Some 0x00C4 - | "Aring" -> Some 0x00C5 - | "AElig" -> Some 0x00C6 - | "Ccedil" -> Some 0x00C7 - | "Egrave" -> Some 0x00C8 - | "Eacute" -> Some 0x00C9 - | "Ecirc" -> Some 0x00CA - | "Euml" -> Some 0x00CB - | "Igrave" -> Some 0x00CC - | "Iacute" -> Some 0x00CD - | "Icirc" -> Some 0x00CE - | "Iuml" -> Some 0x00CF - | "ETH" -> Some 0x00D0 - | "Ntilde" -> Some 0x00D1 - | "Ograve" -> Some 0x00D2 - | "Oacute" -> Some 0x00D3 - | "Ocirc" -> Some 0x00D4 - | "Otilde" -> Some 0x00D5 - | "Ouml" -> Some 0x00D6 - | "times" -> Some 0x00D7 - | "Oslash" -> Some 0x00D8 - | "Ugrave" -> Some 0x00D9 - | "Uacute" -> Some 0x00DA - | "Ucirc" -> Some 0x00DB - | "Uuml" -> Some 0x00DC - | "Yacute" -> Some 0x00DD - | "THORN" -> Some 0x00DE - | "szlig" -> Some 0x00DF - | "agrave" -> Some 0x00E0 - | "aacute" -> Some 0x00E1 - | "acirc" -> Some 0x00E2 - | "atilde" -> Some 0x00E3 - | "auml" -> Some 0x00E4 - | "aring" -> Some 0x00E5 - | "aelig" -> Some 0x00E6 - | "ccedil" -> Some 0x00E7 - | "egrave" -> Some 0x00E8 - | "eacute" -> Some 0x00E9 - | "ecirc" -> Some 0x00EA - | "euml" -> Some 0x00EB - | "igrave" -> Some 0x00EC - | "iacute" -> Some 0x00ED - | "icirc" -> Some 0x00EE - | "iuml" -> Some 0x00EF - | "eth" -> Some 0x00F0 - | "ntilde" -> Some 0x00F1 - | "ograve" -> Some 0x00F2 - | "oacute" -> Some 0x00F3 - | "ocirc" -> Some 0x00F4 - | "otilde" -> Some 0x00F5 - | "ouml" -> Some 0x00F6 - | "divide" -> Some 0x00F7 - | "oslash" -> Some 0x00F8 - | "ugrave" -> Some 0x00F9 - | "uacute" -> Some 0x00FA - | "ucirc" -> Some 0x00FB - | "uuml" -> Some 0x00FC - | "yacute" -> Some 0x00FD - | "thorn" -> Some 0x00FE - | "yuml" -> Some 0x00FF - | "OElig" -> Some 0x0152 - | "oelig" -> Some 0x0153 - | "Scaron" -> Some 0x0160 - | "scaron" -> Some 0x0161 - | "Yuml" -> Some 0x0178 - | "fnof" -> Some 0x0192 - | "circ" -> Some 0x02C6 - | "tilde" -> Some 0x02DC - | "Alpha" -> Some 0x0391 - | "Beta" -> Some 0x0392 - | "Gamma" -> Some 0x0393 - | "Delta" -> Some 0x0394 - | "Epsilon" -> Some 0x0395 - | "Zeta" -> Some 0x0396 - | "Eta" -> Some 0x0397 - | "Theta" -> Some 0x0398 - | "Iota" -> Some 0x0399 - | "Kappa" -> Some 0x039A - | "Lambda" -> Some 0x039B - | "Mu" -> Some 0x039C - | "Nu" -> Some 0x039D - | "Xi" -> Some 0x039E - | "Omicron" -> Some 0x039F - | "Pi" -> Some 0x03A0 - | "Rho" -> Some 0x03A1 - | "Sigma" -> Some 0x03A3 - | "Tau" -> Some 0x03A4 - | "Upsilon" -> Some 0x03A5 - | "Phi" -> Some 0x03A6 - | "Chi" -> Some 0x03A7 - | "Psi" -> Some 0x03A8 - | "Omega" -> Some 0x03A9 - | "alpha" -> Some 0x03B1 - | "beta" -> Some 0x03B2 - | "gamma" -> Some 0x03B3 - | "delta" -> Some 0x03B4 - | "epsilon" -> Some 0x03B5 - | "zeta" -> Some 0x03B6 - | "eta" -> Some 0x03B7 - | "theta" -> Some 0x03B8 - | "iota" -> Some 0x03B9 - | "kappa" -> Some 0x03BA - | "lambda" -> Some 0x03BB - | "mu" -> Some 0x03BC - | "nu" -> Some 0x03BD - | "xi" -> Some 0x03BE - | "omicron" -> Some 0x03BF - | "pi" -> Some 0x03C0 - | "rho" -> Some 0x03C1 - | "sigmaf" -> Some 0x03C2 - | "sigma" -> Some 0x03C3 - | "tau" -> Some 0x03C4 - | "upsilon" -> Some 0x03C5 - | "phi" -> Some 0x03C6 - | "chi" -> Some 0x03C7 - | "psi" -> Some 0x03C8 - | "omega" -> Some 0x03C9 - | "thetasym" -> Some 0x03D1 - | "upsih" -> Some 0x03D2 - | "piv" -> Some 0x03D6 - | "ensp" -> Some 0x2002 - | "emsp" -> Some 0x2003 - | "thinsp" -> Some 0x2009 - | "zwnj" -> Some 0x200C - | "zwj" -> Some 0x200D - | "lrm" -> Some 0x200E - | "rlm" -> Some 0x200F - | "ndash" -> Some 0x2013 - | "mdash" -> Some 0x2014 - | "lsquo" -> Some 0x2018 - | "rsquo" -> Some 0x2019 - | "sbquo" -> Some 0x201A - | "ldquo" -> Some 0x201C - | "rdquo" -> Some 0x201D - | "bdquo" -> Some 0x201E - | "dagger" -> Some 0x2020 - | "Dagger" -> Some 0x2021 - | "bull" -> Some 0x2022 - | "hellip" -> Some 0x2026 - | "permil" -> Some 0x2030 - | "prime" -> Some 0x2032 - | "Prime" -> Some 0x2033 - | "lsaquo" -> Some 0x2039 - | "rsaquo" -> Some 0x203A - | "oline" -> Some 0x203E - | "frasl" -> Some 0x2044 - | "euro" -> Some 0x20AC - | "image" -> Some 0x2111 - | "weierp" -> Some 0x2118 - | "real" -> Some 0x211C - | "trade" -> Some 0x2122 - | "alefsym" -> Some 0x2135 - | "larr" -> Some 0x2190 - | "uarr" -> Some 0x2191 - | "rarr" -> Some 0x2192 - | "darr" -> Some 0x2193 - | "harr" -> Some 0x2194 - | "crarr" -> Some 0x21B5 - | "lArr" -> Some 0x21D0 - | "uArr" -> Some 0x21D1 - | "rArr" -> Some 0x21D2 - | "dArr" -> Some 0x21D3 - | "hArr" -> Some 0x21D4 - | "forall" -> Some 0x2200 - | "part" -> Some 0x2202 - | "exist" -> Some 0x2203 - | "empty" -> Some 0x2205 - | "nabla" -> Some 0x2207 - | "isin" -> Some 0x2208 - | "notin" -> Some 0x2209 - | "ni" -> Some 0x220B - | "prod" -> Some 0x220F - | "sum" -> Some 0x2211 - | "minus" -> Some 0x2212 - | "lowast" -> Some 0x2217 - | "radic" -> Some 0x221A - | "prop" -> Some 0x221D - | "infin" -> Some 0x221E - | "ang" -> Some 0x2220 - | "and" -> Some 0x2227 - | "or" -> Some 0x2228 - | "cap" -> Some 0x2229 - | "cup" -> Some 0x222A - | "'int'" -> Some 0x222B - | "there4" -> Some 0x2234 - | "sim" -> Some 0x223C - | "cong" -> Some 0x2245 - | "asymp" -> Some 0x2248 - | "ne" -> Some 0x2260 - | "equiv" -> Some 0x2261 - | "le" -> Some 0x2264 - | "ge" -> Some 0x2265 - | "sub" -> Some 0x2282 - | "sup" -> Some 0x2283 - | "nsub" -> Some 0x2284 - | "sube" -> Some 0x2286 - | "supe" -> Some 0x2287 - | "oplus" -> Some 0x2295 - | "otimes" -> Some 0x2297 - | "perp" -> Some 0x22A5 - | "sdot" -> Some 0x22C5 - | "lceil" -> Some 0x2308 - | "rceil" -> Some 0x2309 - | "lfloor" -> Some 0x230A - | "rfloor" -> Some 0x230B - | "lang" -> Some 0x27E8 - | "rang" -> Some 0x27E9 - | "loz" -> Some 0x25CA - | "spades" -> Some 0x2660 - | "clubs" -> Some 0x2663 - | "hearts" -> Some 0x2665 - | "diams" -> Some 0x2666 - | _ -> None in - (match code with - | Some code -> Wtf8.add_wtf_8 buf code - | None -> Buffer.add_string buf ("&" ^ (entity ^ ";"))); - jsx_text env mode buf raw lexbuf)) - | 6 -> - let c = lexeme lexbuf in - (Buffer.add_string raw c; - Buffer.add_string buf c; - jsx_text env mode buf raw lexbuf) - | _ -> failwith "unreachable jsxtext") -let jsx_tag env lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_117 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> 14 - | 2 -> __sedlex_state_3 lexbuf - | 3 -> 1 - | 4 -> __sedlex_state_6 lexbuf - | 5 -> 12 - | 6 -> 13 - | 7 -> 10 - | 8 -> __sedlex_state_11 lexbuf - | 9 -> 9 - | 10 -> 5 - | 11 -> 11 - | 12 -> 7 - | 13 -> __sedlex_state_18 lexbuf - | 14 -> 8 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_11 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 6; - (match __sedlex_partition_108 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 4 - | 1 -> 3 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_18 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 14; - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_19 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_19 = - function - | lexbuf -> - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_20 lexbuf - | 1 -> __sedlex_state_24 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_20 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_21 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_21 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_22 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_22 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 13 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_24 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_25 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_25 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_25 lexbuf - | 1 -> 13 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> Token (env, T_EOF) - | 1 -> let env = new_line env lexbuf in Continue env - | 2 -> Continue env - | 3 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = line_comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf false)) - | 4 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf true)) - | 5 -> Token (env, T_LESS_THAN) - | 6 -> Token (env, T_DIV) - | 7 -> Token (env, T_GREATER_THAN) - | 8 -> Token (env, T_LCURLY) - | 9 -> Token (env, T_COLON) - | 10 -> Token (env, T_PERIOD) - | 11 -> Token (env, T_ASSIGN) - | 12 -> - let quote = lexeme lexbuf in - let start = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let raw = Buffer.create 127 in - (Buffer.add_string raw quote; - (let mode = - if quote = "'" - then JSX_SINGLE_QUOTED_TEXT - else JSX_DOUBLE_QUOTED_TEXT in - let env = jsx_text env mode buf raw lexbuf in - let _end = end_pos_of_lexbuf env lexbuf in - Buffer.add_string raw quote; - (let value = Buffer.contents buf in - let raw = Buffer.contents raw in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - Token (env, (T_JSX_TEXT (loc, value, raw)))))) - | 13 -> - let start_offset = Sedlexing.lexeme_start lexbuf in - (loop_jsx_id_continues lexbuf; - (let end_offset = Sedlexing.lexeme_end lexbuf in - Sedlexing.set_lexeme_start lexbuf start_offset; - (let raw = Sedlexing.lexeme lexbuf in - let loc = loc_of_offsets env start_offset end_offset in - Token - (env, - (T_JSX_IDENTIFIER { raw = (Sedlexing.string_of_utf8 raw); loc }))))) - | 14 -> Token (env, (T_ERROR (lexeme lexbuf))) - | _ -> failwith "unreachable jsx_tag") -let jsx_child env start buf raw lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_118 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 1 - | 1 -> 4 - | 2 -> 0 - | 3 -> __sedlex_state_4 lexbuf - | 4 -> 2 - | 5 -> 3 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let lt = lexeme lexbuf in - (Buffer.add_string raw lt; - Buffer.add_string buf lt; - (let env = new_line env lexbuf in - let env = jsx_text env JSX_CHILD_TEXT buf raw lexbuf in - let _end = end_pos_of_lexbuf env lexbuf in - let value = Buffer.contents buf in - let raw = Buffer.contents raw in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - (env, (T_JSX_TEXT (loc, value, raw))))) - | 1 -> (env, T_EOF) - | 2 -> (env, T_LESS_THAN) - | 3 -> (env, T_LCURLY) - | 4 -> - (Sedlexing.rollback lexbuf; - (let env = jsx_text env JSX_CHILD_TEXT buf raw lexbuf in - let _end = end_pos_of_lexbuf env lexbuf in - let value = Buffer.contents buf in - let raw = Buffer.contents raw in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - (env, (T_JSX_TEXT (loc, value, raw))))) - | _ -> failwith "unreachable jsx_child") -let template_tail env lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_119 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 5 - | 1 -> __sedlex_state_2 lexbuf - | 2 -> 0 - | 3 -> __sedlex_state_5 lexbuf - | 4 -> __sedlex_state_7 lexbuf - | 5 -> 4 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 5; - (match __sedlex_partition_108 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 3 - | 1 -> 2 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> let env = new_line env lexbuf in Continue env - | 1 -> Continue env - | 2 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = line_comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf false)) - | 3 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf true)) - | 4 -> - let start = start_pos_of_lexbuf env lexbuf in - let cooked = Buffer.create 127 in - let raw = Buffer.create 127 in - let literal = Buffer.create 127 in - (Buffer.add_string literal "}"; - (let (env, is_tail) = template_part env cooked raw literal lexbuf in - let _end = end_pos_of_lexbuf env lexbuf in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - Token - (env, - (T_TEMPLATE_PART - (loc, - { - cooked = (Buffer.contents cooked); - raw = (Buffer.contents raw); - literal = (Buffer.contents literal) - }, is_tail))))) - | 5 -> - let env = illegal env (loc_of_lexbuf env lexbuf) in - Token - (env, - (T_TEMPLATE_PART - ((loc_of_lexbuf env lexbuf), - { cooked = ""; raw = ""; literal = "" }, true))) - | _ -> failwith "unreachable template_tail") -let type_token env lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_126 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 62 - | 1 -> 63 - | 2 -> __sedlex_state_3 lexbuf - | 3 -> 0 - | 4 -> __sedlex_state_6 lexbuf - | 5 -> 6 - | 6 -> 61 - | 7 -> __sedlex_state_10 lexbuf - | 8 -> 56 - | 9 -> 38 - | 10 -> 39 - | 11 -> __sedlex_state_20 lexbuf - | 12 -> 59 - | 13 -> 43 - | 14 -> __sedlex_state_24 lexbuf - | 15 -> __sedlex_state_97 lexbuf - | 16 -> __sedlex_state_100 lexbuf - | 17 -> __sedlex_state_117 lexbuf - | 18 -> __sedlex_state_118 lexbuf - | 19 -> 44 - | 20 -> 42 - | 21 -> 49 - | 22 -> __sedlex_state_122 lexbuf - | 23 -> 50 - | 24 -> __sedlex_state_125 lexbuf - | 25 -> 32 - | 26 -> __sedlex_state_128 lexbuf - | 27 -> 33 - | 28 -> __sedlex_state_137 lexbuf - | 29 -> __sedlex_state_139 lexbuf - | 30 -> 35 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 1; - (match __sedlex_partition_51 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_11 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_10 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 63; - (match __sedlex_partition_73 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_127 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_12 = - function - | lexbuf -> - (match __sedlex_partition_75 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_13 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_13 = - function - | lexbuf -> - (match __sedlex_partition_73 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_14 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_14 = - function - | lexbuf -> - (match __sedlex_partition_128 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_15 = - function - | lexbuf -> - (match __sedlex_partition_93 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 31 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_20 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 53; - (match __sedlex_partition_13 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 4 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_24 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 60; - (match __sedlex_partition_123 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_25 lexbuf - | 1 -> __sedlex_state_26 lexbuf - | 2 -> __sedlex_state_47 lexbuf - | 3 -> __sedlex_state_94 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_25 = - function - | lexbuf -> - (match __sedlex_partition_123 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_25 lexbuf - | 1 -> __sedlex_state_26 lexbuf - | 2 -> __sedlex_state_47 lexbuf - | 3 -> __sedlex_state_94 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_26 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_27 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_27 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_27 lexbuf - | 2 -> __sedlex_state_29 lexbuf - | 3 -> __sedlex_state_43 lexbuf - | 4 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_28 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 29; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_29 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 29; - (match __sedlex_partition_61 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_30 lexbuf - | 2 -> __sedlex_state_38 lexbuf - | 3 -> __sedlex_state_42 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_30 = - function - | lexbuf -> - (match __sedlex_partition_40 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_31 lexbuf - | 1 -> __sedlex_state_35 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_31 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 24; - (match __sedlex_partition_62 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_32 lexbuf - | 1 -> __sedlex_state_31 lexbuf - | 2 -> __sedlex_state_33 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_32 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 23; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_32 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_33 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 22; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_34 lexbuf - | 1 -> __sedlex_state_32 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_34 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 21; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_34 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_35 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 24; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_32 lexbuf - | 1 -> __sedlex_state_35 lexbuf - | 2 -> __sedlex_state_36 lexbuf - | 3 -> __sedlex_state_33 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_36 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_37 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_37 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 24; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_32 lexbuf - | 1 -> __sedlex_state_37 lexbuf - | 2 -> __sedlex_state_36 lexbuf - | 3 -> __sedlex_state_33 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_38 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 24; - (match __sedlex_partition_62 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_38 lexbuf - | 2 -> __sedlex_state_40 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_39 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 23; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_40 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 22; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_41 lexbuf - | 1 -> __sedlex_state_39 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_41 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 21; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_41 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_42 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 24; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_39 lexbuf - | 1 -> __sedlex_state_42 lexbuf - | 2 -> __sedlex_state_36 lexbuf - | 3 -> __sedlex_state_40 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_43 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_44 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_44 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_44 lexbuf - | 2 -> __sedlex_state_29 lexbuf - | 3 -> __sedlex_state_43 lexbuf - | 4 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_45 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 27; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_46 lexbuf - | 1 -> __sedlex_state_28 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_46 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 25; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_46 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_47 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_76 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_48 lexbuf - | 2 -> __sedlex_state_52 lexbuf - | 3 -> __sedlex_state_61 lexbuf - | 4 -> __sedlex_state_64 lexbuf - | 5 -> __sedlex_state_29 lexbuf - | 6 -> __sedlex_state_74 lexbuf - | 7 -> __sedlex_state_84 lexbuf - | 8 -> __sedlex_state_62 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_48 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_77 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_49 lexbuf - | 2 -> __sedlex_state_29 lexbuf - | 3 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_49 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_49 lexbuf - | 2 -> __sedlex_state_29 lexbuf - | 3 -> __sedlex_state_50 lexbuf - | 4 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_50 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_51 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_51 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_59 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_51 lexbuf - | 2 -> __sedlex_state_29 lexbuf - | 3 -> __sedlex_state_50 lexbuf - | 4 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_52 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 16; - (match __sedlex_partition_78 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_53 lexbuf - | 1 -> __sedlex_state_54 lexbuf - | 2 -> __sedlex_state_52 lexbuf - | 3 -> __sedlex_state_58 lexbuf - | 4 -> __sedlex_state_59 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_53 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 15; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_53 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_54 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_62 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_55 lexbuf - | 2 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_55 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_55 lexbuf - | 2 -> __sedlex_state_56 lexbuf - | 3 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_56 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_57 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_57 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_64 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_57 lexbuf - | 2 -> __sedlex_state_56 lexbuf - | 3 -> __sedlex_state_45 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_58 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 15; - (match __sedlex_partition_79 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_53 lexbuf - | 1 -> __sedlex_state_54 lexbuf - | 2 -> __sedlex_state_58 lexbuf - | 3 -> __sedlex_state_59 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_59 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 15; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_60 lexbuf - | 1 -> __sedlex_state_53 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_60 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 15; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_60 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_61 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_79 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_54 lexbuf - | 2 -> __sedlex_state_61 lexbuf - | 3 -> __sedlex_state_62 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_62 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 28; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_63 lexbuf - | 1 -> __sedlex_state_28 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_63 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 26; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_63 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_64 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 29; - (match __sedlex_partition_80 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_65 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_65 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 10; - (match __sedlex_partition_81 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_66 lexbuf - | 1 -> __sedlex_state_65 lexbuf - | 2 -> __sedlex_state_67 lexbuf - | 3 -> __sedlex_state_72 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_66 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 9; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_66 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_67 = - function - | lexbuf -> - (match __sedlex_partition_26 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_68 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_68 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 10; - (match __sedlex_partition_81 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_69 lexbuf - | 1 -> __sedlex_state_68 lexbuf - | 2 -> __sedlex_state_67 lexbuf - | 3 -> __sedlex_state_70 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_69 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 9; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_69 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_70 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 8; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_71 lexbuf - | 1 -> __sedlex_state_69 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_71 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 7; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_71 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_72 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 8; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_73 lexbuf - | 1 -> __sedlex_state_66 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_73 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 7; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_73 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_74 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 29; - (match __sedlex_partition_82 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_75 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_75 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 14; - (match __sedlex_partition_83 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_76 lexbuf - | 1 -> __sedlex_state_75 lexbuf - | 2 -> __sedlex_state_77 lexbuf - | 3 -> __sedlex_state_82 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_76 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 13; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_76 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_77 = - function - | lexbuf -> - (match __sedlex_partition_17 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_78 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_78 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 14; - (match __sedlex_partition_83 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_79 lexbuf - | 1 -> __sedlex_state_78 lexbuf - | 2 -> __sedlex_state_77 lexbuf - | 3 -> __sedlex_state_80 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_79 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 13; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_79 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_80 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 12; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_81 lexbuf - | 1 -> __sedlex_state_79 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_81 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 11; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_81 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_82 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 12; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_83 lexbuf - | 1 -> __sedlex_state_76 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_83 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 11; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_83 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_84 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 29; - (match __sedlex_partition_84 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_85 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_85 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 20; - (match __sedlex_partition_85 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_86 lexbuf - | 1 -> __sedlex_state_85 lexbuf - | 2 -> __sedlex_state_87 lexbuf - | 3 -> __sedlex_state_92 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_86 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 19; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_86 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_87 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_88 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_88 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 20; - (match __sedlex_partition_85 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_89 lexbuf - | 1 -> __sedlex_state_88 lexbuf - | 2 -> __sedlex_state_87 lexbuf - | 3 -> __sedlex_state_90 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_89 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 19; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_89 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_90 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 18; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_91 lexbuf - | 1 -> __sedlex_state_89 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_91 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_91 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_92 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 18; - (match __sedlex_partition_63 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_93 lexbuf - | 1 -> __sedlex_state_86 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_93 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 17; - (match __sedlex_partition_60 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_93 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_94 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_86 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_48 lexbuf - | 2 -> __sedlex_state_94 lexbuf - | 3 -> __sedlex_state_29 lexbuf - | 4 -> __sedlex_state_95 lexbuf - | 5 -> __sedlex_state_62 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_95 = - function - | lexbuf -> - (match __sedlex_partition_33 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_96 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_96 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_87 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_54 lexbuf - | 2 -> __sedlex_state_96 lexbuf - | 3 -> __sedlex_state_95 lexbuf - | 4 -> __sedlex_state_62 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_97 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 41; - (match __sedlex_partition_47 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_98 lexbuf - | 1 -> __sedlex_state_27 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_98 = - function - | lexbuf -> - (match __sedlex_partition_58 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 40 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_100 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 63; - (match __sedlex_partition_108 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_101 lexbuf - | 1 -> 5 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_101 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 2; - (match __sedlex_partition_65 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_102 lexbuf - | 1 -> __sedlex_state_103 lexbuf - | 2 -> __sedlex_state_105 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_102 = - function - | lexbuf -> - (match __sedlex_partition_65 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_102 lexbuf - | 1 -> __sedlex_state_103 lexbuf - | 2 -> __sedlex_state_105 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_103 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 3; - (match __sedlex_partition_66 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 3 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_105 = - function - | lexbuf -> - (match __sedlex_partition_67 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_106 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_106 = - function - | lexbuf -> - (match __sedlex_partition_68 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_107 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_107 = - function - | lexbuf -> - (match __sedlex_partition_69 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_108 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_108 = - function - | lexbuf -> - (match __sedlex_partition_70 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_109 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_109 = - function - | lexbuf -> - (match __sedlex_partition_71 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_110 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_110 = - function - | lexbuf -> - (match __sedlex_partition_72 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_111 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_111 = - function - | lexbuf -> - (match __sedlex_partition_73 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_112 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_112 = - function - | lexbuf -> - (match __sedlex_partition_67 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_113 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_113 = - function - | lexbuf -> - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_114 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_114 = - function - | lexbuf -> - (match __sedlex_partition_74 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_115 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_115 = - function - | lexbuf -> - (match __sedlex_partition_75 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 3 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_117 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_76 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_48 lexbuf - | 2 -> __sedlex_state_52 lexbuf - | 3 -> __sedlex_state_61 lexbuf - | 4 -> __sedlex_state_64 lexbuf - | 5 -> __sedlex_state_29 lexbuf - | 6 -> __sedlex_state_74 lexbuf - | 7 -> __sedlex_state_84 lexbuf - | 8 -> __sedlex_state_62 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_118 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 30; - (match __sedlex_partition_86 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_28 lexbuf - | 1 -> __sedlex_state_48 lexbuf - | 2 -> __sedlex_state_94 lexbuf - | 3 -> __sedlex_state_29 lexbuf - | 4 -> __sedlex_state_95 lexbuf - | 5 -> __sedlex_state_62 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_122 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 51; - (match __sedlex_partition_129 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 57 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_125 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 46; - (match __sedlex_partition_58 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 45 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_128 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 63; - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_129 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_129 = - function - | lexbuf -> - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_130 lexbuf - | 1 -> __sedlex_state_134 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_130 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_131 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_131 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_132 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_132 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 61 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_134 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_135 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_135 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_135 lexbuf - | 1 -> 61 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_137 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 34; - (match __sedlex_partition_130 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 36 - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_139 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 55; - (match __sedlex_partition_131 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 37 - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> let env = new_line env lexbuf in Continue env - | 1 -> Continue env - | 2 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf true)) - | 3 -> - let pattern = lexeme lexbuf in - if not (is_comment_syntax_enabled env) - then - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - (Buffer.add_string buf pattern; - (let (env, end_pos) = comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf true)))) - else - (let env = - if is_in_comment_syntax env - then - let loc = loc_of_lexbuf env lexbuf in - unexpected_error env loc pattern - else env in - let env = in_comment_syntax true env in - let len = Sedlexing.lexeme_length lexbuf in - if - ((Sedlexing.Utf8.sub_lexeme lexbuf (len - 1) 1) = ":") && - ((Sedlexing.Utf8.sub_lexeme lexbuf (len - 2) 1) <> ":") - then Token (env, T_COLON) - else Continue env) - | 4 -> - if is_in_comment_syntax env - then let env = in_comment_syntax false env in Continue env - else - (Sedlexing.rollback lexbuf; - (let __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_23 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> Token (env, T_MULT) - | _ -> failwith "expected *"))) - | 5 -> - let start_pos = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let (env, end_pos) = line_comment env buf lexbuf in - Comment (env, (mk_comment env start_pos end_pos buf false)) - | 6 -> - let quote = lexeme lexbuf in - let start = start_pos_of_lexbuf env lexbuf in - let buf = Buffer.create 127 in - let raw = Buffer.create 127 in - (Buffer.add_string raw quote; - (let octal = false in - let (env, _end, octal) = string_quote env quote buf raw octal lexbuf in - let loc = { Loc.source = (Lex_env.source env); start; _end } in - Token - (env, - (T_STRING - (loc, (Buffer.contents buf), (Buffer.contents raw), octal))))) - | 7 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_120 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_121 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_25 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_27 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_27 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_BINARY num)) - | _ -> failwith "unreachable type_token bigbigint")) - | 8 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_BINARY num)) - | 9 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_120 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_121 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_25 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_28 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_26 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_28 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton BINARY num)) - | _ -> failwith "unreachable type_token binnumber")) - | 10 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton BINARY num)) - | 11 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_120 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_121 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_29 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_30 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_30 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_OCTAL num)) - | _ -> failwith "unreachable type_token octbigint")) - | 12 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_OCTAL num)) - | 13 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_120 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_121 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_29 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_31 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_31 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton OCTAL num)) - | _ -> failwith "unreachable type_token octnumber")) - | 14 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton OCTAL num)) - | 15 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_120 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_121 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_17 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton LEGACY_OCTAL num)) - | _ -> failwith "unreachable type_token legacyoctnumber")) - | 16 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton LEGACY_OCTAL num)) - | 17 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_120 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_121 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_34 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_35 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_35 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | _ -> failwith "unreachable type_token hexbigint")) - | 18 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | 19 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_120 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_121 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_34 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_36 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_4 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_36 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton NORMAL num)) - | _ -> failwith "unreachable type_token hexnumber")) - | 20 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton NORMAL num)) - | 21 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_122 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_13 lexbuf - | 3 -> __sedlex_state_18 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_123 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_13 lexbuf - | 3 -> __sedlex_state_18 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_39 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_6 lexbuf - | 2 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_40 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_41 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> __sedlex_state_9 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | 1 -> __sedlex_state_9 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_12 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_13 = - function - | lexbuf -> - (match __sedlex_partition_43 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_14 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_14 = - function - | lexbuf -> - (match __sedlex_partition_44 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_15 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_15 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_15 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_16 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_16 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_17 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_17 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_17 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_16 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_18 = - function - | lexbuf -> - (match __sedlex_partition_45 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_14 lexbuf - | 1 -> __sedlex_state_18 lexbuf - | 2 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - let loc = loc_of_lexbuf env lexbuf in - let env = - lex_error env loc Parse_error.InvalidSciBigInt in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | _ -> failwith "unreachable type_token scibigint")) - | 22 -> - let num = Sedlexing.lexeme lexbuf in - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.InvalidSciBigInt in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | 23 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_122 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_12 lexbuf - | 3 -> __sedlex_state_17 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_123 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_12 lexbuf - | 3 -> __sedlex_state_17 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_39 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_6 lexbuf - | 2 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_40 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_7 lexbuf - | 1 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_9 lexbuf - | 1 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_12 = - function - | lexbuf -> - (match __sedlex_partition_43 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_13 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_13 = - function - | lexbuf -> - (match __sedlex_partition_44 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_14 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_14 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_14 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_15 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_16 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_16 = - function - | lexbuf -> - (match __sedlex_partition_38 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_16 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_17 = - function - | lexbuf -> - (match __sedlex_partition_45 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_13 lexbuf - | 1 -> __sedlex_state_17 lexbuf - | 2 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton NORMAL num)) - | _ -> failwith "unreachable type_token scinumber")) - | 24 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton NORMAL num)) - | 25 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_122 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_7 lexbuf - | 3 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_123 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_7 lexbuf - | 3 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | 1 -> __sedlex_state_4 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_47 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_41 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> __sedlex_state_9 lexbuf - | 2 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_11 = - function - | lexbuf -> - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> __sedlex_state_11 lexbuf - | 2 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - let loc = loc_of_lexbuf env lexbuf in - let env = - lex_error env loc Parse_error.InvalidFloatBigInt in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | _ -> failwith "unreachable type_token floatbigint")) - | 26 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_124 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_125 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_41 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_2 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_42 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | 1 -> __sedlex_state_5 lexbuf - | 2 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | _ -> failwith "unreachable type_token wholebigint")) - | 27 -> - let num = Sedlexing.lexeme lexbuf in - let loc = loc_of_lexbuf env lexbuf in - let env = lex_error env loc Parse_error.InvalidFloatBigInt in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | 28 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_bignum_singleton BIG_NORMAL num)) - | 29 -> - recover env lexbuf - ~f:(fun env -> - fun lexbuf -> - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_122 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | 2 -> __sedlex_state_11 lexbuf - | 3 -> __sedlex_state_13 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_1 = - function - | lexbuf -> - (match __sedlex_partition_125 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_1 lexbuf - | 1 -> __sedlex_state_2 lexbuf - | 2 -> __sedlex_state_4 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_47 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_4 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_4 lexbuf - | 2 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_6 lexbuf - | 2 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_9 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_10 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_46 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_10 lexbuf - | 1 -> __sedlex_state_9 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_11 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_47 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | 1 -> __sedlex_state_11 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_12 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_13 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | 1 -> __sedlex_state_13 lexbuf - | 2 -> __sedlex_state_14 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) - and __sedlex_state_14 = - function - | lexbuf -> - (match __sedlex_partition_33 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_15 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_15 = - function - | lexbuf -> - (Sedlexing.mark lexbuf 0; - (match __sedlex_partition_48 - (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_12 lexbuf - | 1 -> __sedlex_state_15 lexbuf - | 2 -> __sedlex_state_14 lexbuf - | _ -> Sedlexing.backtrack lexbuf)) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton NORMAL num)) - | _ -> failwith "unreachable type_token wholenumber")) - | 30 -> - let num = Sedlexing.lexeme lexbuf in - Token (env, (mk_num_singleton NORMAL num)) - | 31 -> Token (env, T_CHECKS) - | 32 -> Token (env, T_LBRACKET) - | 33 -> Token (env, T_RBRACKET) - | 34 -> Token (env, T_LCURLY) - | 35 -> Token (env, T_RCURLY) - | 36 -> Token (env, T_LCURLYBAR) - | 37 -> Token (env, T_RCURLYBAR) - | 38 -> Token (env, T_LPAREN) - | 39 -> Token (env, T_RPAREN) - | 40 -> Token (env, T_ELLIPSIS) - | 41 -> Token (env, T_PERIOD) - | 42 -> Token (env, T_SEMICOLON) - | 43 -> Token (env, T_COMMA) - | 44 -> Token (env, T_COLON) - | 45 -> Token (env, T_PLING_PERIOD) - | 46 -> Token (env, T_PLING) - | 47 -> Token (env, T_LBRACKET) - | 48 -> Token (env, T_RBRACKET) - | 49 -> Token (env, T_LESS_THAN) - | 50 -> Token (env, T_GREATER_THAN) - | 51 -> Token (env, T_ASSIGN) - | 52 -> Token (env, T_PLING) - | 53 -> Token (env, T_MULT) - | 54 -> Token (env, T_COLON) - | 55 -> Token (env, T_BIT_OR) - | 56 -> Token (env, T_BIT_AND) - | 57 -> Token (env, T_ARROW) - | 58 -> Token (env, T_ASSIGN) - | 59 -> Token (env, T_PLUS) - | 60 -> Token (env, T_MINUS) - | 61 -> - let start_offset = Sedlexing.lexeme_start lexbuf in - ((loop_id_continues lexbuf) |> ignore; - (let end_offset = Sedlexing.lexeme_end lexbuf in - let loc = loc_of_offsets env start_offset end_offset in - Sedlexing.set_lexeme_start lexbuf start_offset; - (let raw = Sedlexing.lexeme lexbuf in - let (env, value) = decode_identifier env raw in - match value with - | "any" -> Token (env, T_ANY_TYPE) - | "bool" -> Token (env, (T_BOOLEAN_TYPE BOOL)) - | "boolean" -> Token (env, (T_BOOLEAN_TYPE BOOLEAN)) - | "empty" -> Token (env, T_EMPTY_TYPE) - | "extends" -> Token (env, T_EXTENDS) - | "false" -> Token (env, T_FALSE) - | "interface" -> Token (env, T_INTERFACE) - | "mixed" -> Token (env, T_MIXED_TYPE) - | "null" -> Token (env, T_NULL) - | "number" -> Token (env, T_NUMBER_TYPE) - | "bigint" -> Token (env, T_BIGINT_TYPE) - | "static" -> Token (env, T_STATIC) - | "string" -> Token (env, T_STRING_TYPE) - | "true" -> Token (env, T_TRUE) - | "typeof" -> Token (env, T_TYPEOF) - | "void" -> Token (env, T_VOID_TYPE) - | "symbol" -> Token (env, T_SYMBOL_TYPE) - | _ -> - Token - (env, - (T_IDENTIFIER - { loc; value; raw = (Sedlexing.string_of_utf8 raw) }))))) - | 62 -> - let env = - if is_in_comment_syntax env - then - let loc = loc_of_lexbuf env lexbuf in - lex_error env loc Parse_error.UnexpectedEOS - else env in - Token (env, T_EOF) - | 63 -> Token (env, (T_ERROR (lexeme lexbuf))) - | _ -> failwith "unreachable type_token") -let jsx_child env = - let start = end_pos_of_lexbuf env env.lex_lb in - let buf = Buffer.create 127 in - let raw = Buffer.create 127 in - let (env, child) = jsx_child env start buf raw env.lex_lb in - let loc = loc_of_token env child in - let lex_errors_acc = (env.lex_state).lex_errors_acc in - if lex_errors_acc = [] - then - (env, - { - Lex_result.lex_token = child; - lex_loc = loc; - lex_comments = []; - lex_errors = [] - }) - else - ({ env with lex_state = { lex_errors_acc = [] } }, - { - Lex_result.lex_token = child; - lex_loc = loc; - lex_comments = []; - lex_errors = (List.rev lex_errors_acc) - }) -let wrap f = - let rec helper comments env = - match f env env.lex_lb with - | Token (env, t) -> - let loc = loc_of_token env t in - let lex_comments = if comments = [] then [] else List.rev comments in - let lex_token = t in - let lex_errors_acc = (env.lex_state).lex_errors_acc in - if lex_errors_acc = [] - then - ({ env with lex_last_loc = loc }, - { - Lex_result.lex_token = lex_token; - lex_loc = loc; - lex_comments; - lex_errors = [] - }) - else - ({ env with lex_last_loc = loc; lex_state = Lex_env.empty_lex_state - }, - { - Lex_result.lex_token = lex_token; - lex_loc = loc; - lex_comments; - lex_errors = (List.rev lex_errors_acc) - }) - | Comment (env, ((loc, _) as comment)) -> - let env = { env with lex_last_loc = loc } in - helper (comment :: comments) env - | Continue env -> helper comments env in - fun env -> helper [] env -let regexp = wrap regexp -let jsx_tag = wrap jsx_tag -let template_tail = wrap template_tail -let type_token = wrap type_token -let token = wrap token -let is_valid_identifier_name lexbuf = - let rec __sedlex_state_0 = - function - | lexbuf -> - (match __sedlex_partition_132 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | 1 -> __sedlex_state_2 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_2 = - function - | lexbuf -> - (match __sedlex_partition_2 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_3 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_3 = - function - | lexbuf -> - (match __sedlex_partition_3 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_4 lexbuf - | 1 -> __sedlex_state_7 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_4 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_5 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_5 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_6 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_6 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> 0 - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_7 = - function - | lexbuf -> - (match __sedlex_partition_4 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | _ -> Sedlexing.backtrack lexbuf) - and __sedlex_state_8 = - function - | lexbuf -> - (match __sedlex_partition_5 (Sedlexing.__private__next_int lexbuf) - with - | 0 -> __sedlex_state_8 lexbuf - | 1 -> 0 - | _ -> Sedlexing.backtrack lexbuf) in - Sedlexing.start lexbuf; - (match __sedlex_state_0 lexbuf with - | 0 -> loop_id_continues lexbuf - | _ -> false) \ No newline at end of file diff --git a/jscomp/js_parser/flow_lexer.mli b/jscomp/js_parser/flow_lexer.mli deleted file mode 100644 index 8609d22..0000000 --- a/jscomp/js_parser/flow_lexer.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -val jsx_child : Lex_env.t -> Lex_env.t * Lex_result.t - -val regexp : Lex_env.t -> Lex_env.t * Lex_result.t - -val jsx_tag : Lex_env.t -> Lex_env.t * Lex_result.t - -val template_tail : Lex_env.t -> Lex_env.t * Lex_result.t - -val type_token : Lex_env.t -> Lex_env.t * Lex_result.t - -val token : Lex_env.t -> Lex_env.t * Lex_result.t - -val is_valid_identifier_name : Flow_sedlexing.lexbuf -> bool diff --git a/jscomp/js_parser/flow_sedlexing.ml b/jscomp/js_parser/flow_sedlexing.ml deleted file mode 100644 index 1aec0e2..0000000 --- a/jscomp/js_parser/flow_sedlexing.ml +++ /dev/null @@ -1,287 +0,0 @@ -(* The package sedlex is released under the terms of an MIT-like license. *) -(* See the attached LICENSE file. *) -(* Copyright 2005, 2013 by Alain Frisch and LexiFi. *) -external ( .!()<- ) : int array -> int -> int -> unit = "%array_unsafe_set" -external ( .!() ) : int array -> int -> int = "%array_unsafe_get" -external ( .![] ) : string -> int -> char = "%string_unsafe_get" -external ( .![]<- ) : bytes -> int -> char -> unit = "%bytes_unsafe_set" - -exception InvalidCodepoint of int - -exception MalFormed - -(* Absolute position from the beginning of the stream *) -type apos = int - -(* critical states: - [pos] [curr_bol] [curr_line] - The state of [curr_bol] and [curr_line] only changes when we hit a newline - [marked_pos] [marked_bol] [marked_line] - [start_pos] [start_bol] [start_line] - get reset whenever we get a new token -*) -type lexbuf = { - buf: int array; - (* Number of meaningful char in buffer *) - len: int; - (* pos is the index in the buffer *) - mutable pos: int; - (* bol is the index in the input stream but not buffer *) - mutable curr_bol: int; - (* start from 1, if it is 0, we would not track postion info for you *) - mutable curr_line: int; - (* First char we need to keep visible *) - mutable start_pos: int; - mutable start_bol: int; - mutable start_line: int; - mutable marked_pos: int; - mutable marked_bol: int; - mutable marked_line: int; - mutable marked_val: int; -} - - -let lexbuf_clone (x : lexbuf) : lexbuf = - { - buf = x.buf; - len = x.len; - pos = x.pos; - curr_bol = x.curr_bol; - curr_line = x.curr_line; - start_pos = x.start_pos; - start_bol = x.start_bol; - start_line = x.start_line; - marked_pos = x.marked_pos; - marked_bol = x.marked_bol; - marked_line = x.marked_line; - marked_val = x.marked_val; - } - -let empty_lexbuf = - { - buf = [||]; - len = 0; - pos = 0; - curr_bol = 0; - curr_line = 0; - start_pos = 0; - start_bol = 0; - start_line = 0; - marked_pos = 0; - marked_bol = 0; - marked_line = 0; - marked_val = 0; - } - -let from_int_array a = - let len = Array.length a in - { empty_lexbuf with buf = a; len } - -let from_int_sub_array a len = - { empty_lexbuf with buf = a; len } - -let new_line lexbuf = - if lexbuf.curr_line != 0 then lexbuf.curr_line <- lexbuf.curr_line + 1; - lexbuf.curr_bol <- lexbuf.pos - -let next lexbuf : Stdlib.Uchar.t option = - if lexbuf.pos = lexbuf.len then - None - else - let ret = lexbuf.buf.!(lexbuf.pos) in - lexbuf.pos <- lexbuf.pos + 1; - if ret = 10 then new_line lexbuf; - Some (Stdlib.Uchar.unsafe_of_int ret) - -let __private__next_int lexbuf : int = - if lexbuf.pos = lexbuf.len then - -1 - else - let ret = lexbuf.buf.!(lexbuf.pos) in - lexbuf.pos <- lexbuf.pos + 1; - if ret = 10 then new_line lexbuf; - ret - -let mark lexbuf i = - lexbuf.marked_pos <- lexbuf.pos; - lexbuf.marked_bol <- lexbuf.curr_bol; - lexbuf.marked_line <- lexbuf.curr_line; - lexbuf.marked_val <- i - -let start lexbuf = - lexbuf.start_pos <- lexbuf.pos; - lexbuf.start_bol <- lexbuf.curr_bol; - lexbuf.start_line <- lexbuf.curr_line; - mark lexbuf (-1) - -let backtrack lexbuf = - lexbuf.pos <- lexbuf.marked_pos; - lexbuf.curr_bol <- lexbuf.marked_bol; - lexbuf.curr_line <- lexbuf.marked_line; - lexbuf.marked_val - -let rollback lexbuf = - lexbuf.pos <- lexbuf.start_pos; - lexbuf.curr_bol <- lexbuf.start_bol; - lexbuf.curr_line <- lexbuf.start_line - -let lexeme_start lexbuf = lexbuf.start_pos -let set_lexeme_start lexbuf pos = lexbuf.start_pos <- pos -let lexeme_end lexbuf = lexbuf.pos - -let loc lexbuf = (lexbuf.start_pos , lexbuf.pos ) - -let lexeme_length lexbuf = lexbuf.pos - lexbuf.start_pos - -let sub_lexeme lexbuf pos len = Array.sub lexbuf.buf (lexbuf.start_pos + pos) len - -let lexeme lexbuf = Array.sub lexbuf.buf lexbuf.start_pos (lexbuf.pos - lexbuf.start_pos) - -let current_code_point lexbuf = lexbuf.buf.(lexbuf.start_pos) -(* Decode UTF-8 encoded [s] into codepoints in [a], returning the length of the - * decoded string. - * - * To call this function safely: - * - ensure that [slen] is not greater than the length of [s] - * - ensure that [a] has enough capacity to hold the decoded value - *) -let unsafe_utf8_of_string (s : string) slen (a : int array) : int = - let spos = ref 0 in - let apos = ref 0 in - while !spos < slen do - let spos_code = s.![!spos] in - (match spos_code with - | '\000' .. '\127' as c -> - (* U+0000 - U+007F: 0xxxxxxx *) - a.!(!apos) <- Char.code c; - incr spos - | '\192' .. '\223' as c -> - (* U+0080 - U+07FF: 110xxxxx 10xxxxxx *) - let n1 = Char.code c in - let n2 = Char.code s.![!spos + 1] in - if n2 lsr 6 != 0b10 then raise MalFormed; - a.!(!apos) <- ((n1 land 0x1f) lsl 6) lor (n2 land 0x3f); - spos := !spos + 2 - | '\224' .. '\239' as c -> - (* U+0800 - U+FFFF: 1110xxxx 10xxxxxx 10xxxxxx - U+D800 - U+DFFF are reserved for surrogate halves (RFC 3629) *) - let n1 = Char.code c in - let n2 = Char.code s.![!spos + 1] in - let n3 = Char.code s.![!spos + 2] in - let p = ((n1 land 0x0f) lsl 12) lor ((n2 land 0x3f) lsl 6) lor (n3 land 0x3f) in - if (n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10) || (p >= 0xd800 && p <= 0xdfff) then raise MalFormed; - a.!(!apos) <- p; - spos := !spos + 3 - | '\240' .. '\247' as c -> - (* U+10000 - U+1FFFFF: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - > U+10FFFF are invalid (RFC 3629) *) - let n1 = Char.code c in - let n2 = Char.code s.![!spos + 1] in - let n3 = Char.code s.![!spos + 2] in - let n4 = Char.code s.![!spos + 3] in - if n2 lsr 6 != 0b10 || n3 lsr 6 != 0b10 || n4 lsr 6 != 0b10 then raise MalFormed; - let p = - ((n1 land 0x07) lsl 18) - lor ((n2 land 0x3f) lsl 12) - lor ((n3 land 0x3f) lsl 6) - lor (n4 land 0x3f) - in - if p > 0x10ffff then raise MalFormed; - a.!(!apos) <- p; - spos := !spos + 4 - | _ -> raise MalFormed); - incr apos - done; - !apos - -(* Encode the decoded codepoints in [a] as UTF-8 into [b], returning the length - * of the encoded string. - * - * To call this function safely: - * - ensure that [offset + len] is not greater than the length of [a] - * - ensure that [b] has sufficient capacity to hold the encoded value - *) -let unsafe_string_of_utf8 (a : int array) ~(offset : int) ~(len : int) (b : bytes) : int = - let apos = ref offset in - let len = ref len in - let i = ref 0 in - while !len > 0 do - let u = a.!(!apos) in - if u < 0 then - raise MalFormed - else if u <= 0x007F then begin - b.![!i] <- Char.unsafe_chr u; - incr i - end else if u <= 0x07FF then ( - b.![!i] <- Char.unsafe_chr (0xC0 lor (u lsr 6)); - b.![!i + 1] <- Char.unsafe_chr (0x80 lor (u land 0x3F)); - i := !i + 2 - ) else if u <= 0xFFFF then ( - b.![!i] <- Char.unsafe_chr (0xE0 lor (u lsr 12)); - b.![!i + 1] <- Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)); - b.![!i + 2] <- Char.unsafe_chr (0x80 lor (u land 0x3F)); - i := !i + 3 - ) else if u <= 0x10FFFF then ( - b.![!i] <- Char.unsafe_chr (0xF0 lor (u lsr 18)); - b.![!i + 1] <- Char.unsafe_chr (0x80 lor ((u lsr 12) land 0x3F)); - b.![!i + 2] <- Char.unsafe_chr (0x80 lor ((u lsr 6) land 0x3F)); - b.![!i + 3] <- Char.unsafe_chr (0x80 lor (u land 0x3F)); - i := !i + 4 - ) else - raise MalFormed; - incr apos; - decr len - done; - !i - -module Utf8 = struct - let from_string s = - let slen = String.length s in - let a = Array.make slen 0 in - let len = unsafe_utf8_of_string s slen a in - from_int_sub_array a len - - let sub_lexeme lexbuf pos len : string = - let offset = lexbuf.start_pos + pos in - let b = Bytes.create (len * 4) in - let buf = lexbuf.buf in - (* Assertion needed, since we make use of unsafe API below *) - assert (offset + len <= Array.length buf); - let i = unsafe_string_of_utf8 buf ~offset ~len b in - Bytes.sub_string b 0 i - - let lexeme lexbuf : string = - let offset = lexbuf.start_pos in - let len = lexbuf.pos - offset in - let b = Bytes.create (len * 4) in - let buf = lexbuf.buf in - let i = unsafe_string_of_utf8 buf ~offset ~len b in - Bytes.sub_string b 0 i - - let lexeme_to_buffer lexbuf buffer : unit = - let offset = lexbuf.start_pos in - let len = lexbuf.pos - offset in - let b = Bytes.create (len * 4) in - let buf = lexbuf.buf in - let i = unsafe_string_of_utf8 buf ~offset ~len b in - Buffer.add_subbytes buffer b 0 i - - let lexeme_to_buffer2 lexbuf buf1 buf2 : unit = - let offset = lexbuf.start_pos in - let len = lexbuf.pos - offset in - let b = Bytes.create (len * 4) in - let buf = lexbuf.buf in - let i = unsafe_string_of_utf8 buf ~offset ~len b in - Buffer.add_subbytes buf1 b 0 i; - Buffer.add_subbytes buf2 b 0 i -end - -let string_of_utf8 (lexbuf : int array) : string = - let offset = 0 in - let len = Array.length lexbuf in - let b = Bytes.create (len * 4) in - let i = unsafe_string_of_utf8 lexbuf ~offset ~len b in - Bytes.sub_string b 0 i - -let backoff lexbuf npos = - lexbuf.pos <- lexbuf.pos - npos diff --git a/jscomp/js_parser/flow_sedlexing.mli b/jscomp/js_parser/flow_sedlexing.mli deleted file mode 100644 index c0d82db..0000000 --- a/jscomp/js_parser/flow_sedlexing.mli +++ /dev/null @@ -1,47 +0,0 @@ - -(** This is a module provides the minimal Sedlexing suppport - It is mostly a subset of Sedlexing with two functions for performance reasons: - - Utf8.lexeme_to_buffer - - Utf8.lexeme_to_buffer2 -*) -exception InvalidCodepoint of int -exception MalFormed -type apos = int -type lexbuf -val lexbuf_clone : lexbuf -> lexbuf - -val from_int_array : int array -> lexbuf -val new_line : lexbuf -> unit -val next : lexbuf -> Uchar.t option - -(**/**) -val __private__next_int : lexbuf -> int -(**/**) - -val mark : lexbuf -> int -> unit -val start : lexbuf -> unit -val backtrack : lexbuf -> int -val rollback : lexbuf -> unit -val lexeme_start : lexbuf -> int -val lexeme_end : lexbuf -> int -val loc : lexbuf -> int * int -val lexeme_length : lexbuf -> int -val sub_lexeme : lexbuf -> int -> int -> int array -val lexeme : lexbuf -> int array -module Utf8 : sig - val from_string : string -> lexbuf - val sub_lexeme : lexbuf -> int -> int -> string - val lexeme : lexbuf -> string - (** This API avoids another allocation *) - val lexeme_to_buffer : lexbuf -> Buffer.t -> unit - val lexeme_to_buffer2 : lexbuf -> Buffer.t -> Buffer.t -> unit -end - -val string_of_utf8 : int array -> string - -(** Two APIs used when we want to do customize lexing - instead of using the regex based engine -*) -val current_code_point : lexbuf -> int -val backoff : lexbuf -> int -> unit -val set_lexeme_start : lexbuf -> int -> unit diff --git a/jscomp/js_parser/js_id.ml b/jscomp/js_parser/js_id.ml deleted file mode 100644 index c5da8d8..0000000 --- a/jscomp/js_parser/js_id.ml +++ /dev/null @@ -1,24 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -external ( .!() ) : (int * int) array -> int -> int * int = "%array_unsafe_get" - -let rec search (arr : _ array) (start : int) (finish : int) target = - if start > finish then - false - else - let mid = start + ((finish - start) / 2) in - let (a, b) = arr.!(mid) in - if target < a then - search arr start (mid - 1) target - else if target >= b then - search arr (mid + 1) finish target - else - true - -let is_valid_unicode_id (i : int) = - search Js_id_unicode.id_continue 0 (Array.length Js_id_unicode.id_continue - 1) i diff --git a/jscomp/js_parser/js_id.mli b/jscomp/js_parser/js_id.mli deleted file mode 100644 index 8bcea4e..0000000 --- a/jscomp/js_parser/js_id.mli +++ /dev/null @@ -1,9 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -(* This test is applied to non-start unicode points *) -val is_valid_unicode_id : int -> bool diff --git a/jscomp/js_parser/js_id_unicode.ml b/jscomp/js_parser/js_id_unicode.ml deleted file mode 100644 index 0c99043..0000000 --- a/jscomp/js_parser/js_id_unicode.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -(* This lists two valid unicode point ranges in tuple format. - see more details in https://mathiasbynens.be/notes/javascript-identifiers-es6 - TODO: store it in a flat array - add more docs -*) -[@@@ocamlformat "disable"] - -(* JS has stricter rules with start id *) -let id_start = [|36,37;65,91;95,96;97,123;170,171;181,182;186,187;192,215;216,247;248,706;710,722;736,741;748,749;750,751;880,885;886,888;890,894;895,896;902,903;904,907;908,909;910,930;931,1014;1015,1154;1162,1328;1329,1367;1369,1370;1376,1417;1488,1515;1519,1523;1568,1611;1646,1648;1649,1748;1749,1750;1765,1767;1774,1776;1786,1789;1791,1792;1808,1809;1810,1840;1869,1958;1969,1970;1994,2027;2036,2038;2042,2043;2048,2070;2074,2075;2084,2085;2088,2089;2112,2137;2144,2155;2208,2229;2230,2238;2308,2362;2365,2366;2384,2385;2392,2402;2417,2433;2437,2445;2447,2449;2451,2473;2474,2481;2482,2483;2486,2490;2493,2494;2510,2511;2524,2526;2527,2530;2544,2546;2556,2557;2565,2571;2575,2577;2579,2601;2602,2609;2610,2612;2613,2615;2616,2618;2649,2653;2654,2655;2674,2677;2693,2702;2703,2706;2707,2729;2730,2737;2738,2740;2741,2746;2749,2750;2768,2769;2784,2786;2809,2810;2821,2829;2831,2833;2835,2857;2858,2865;2866,2868;2869,2874;2877,2878;2908,2910;2911,2914;2929,2930;2947,2948;2949,2955;2958,2961;2962,2966;2969,2971;2972,2973;2974,2976;2979,2981;2984,2987;2990,3002;3024,3025;3077,3085;3086,3089;3090,3113;3114,3130;3133,3134;3160,3163;3168,3170;3200,3201;3205,3213;3214,3217;3218,3241;3242,3252;3253,3258;3261,3262;3294,3295;3296,3298;3313,3315;3333,3341;3342,3345;3346,3387;3389,3390;3406,3407;3412,3415;3423,3426;3450,3456;3461,3479;3482,3506;3507,3516;3517,3518;3520,3527;3585,3633;3634,3636;3648,3655;3713,3715;3716,3717;3718,3723;3724,3748;3749,3750;3751,3761;3762,3764;3773,3774;3776,3781;3782,3783;3804,3808;3840,3841;3904,3912;3913,3949;3976,3981;4096,4139;4159,4160;4176,4182;4186,4190;4193,4194;4197,4199;4206,4209;4213,4226;4238,4239;4256,4294;4295,4296;4301,4302;4304,4347;4348,4681;4682,4686;4688,4695;4696,4697;4698,4702;4704,4745;4746,4750;4752,4785;4786,4790;4792,4799;4800,4801;4802,4806;4808,4823;4824,4881;4882,4886;4888,4955;4992,5008;5024,5110;5112,5118;5121,5741;5743,5760;5761,5787;5792,5867;5870,5881;5888,5901;5902,5906;5920,5938;5952,5970;5984,5997;5998,6001;6016,6068;6103,6104;6108,6109;6176,6265;6272,6313;6314,6315;6320,6390;6400,6431;6480,6510;6512,6517;6528,6572;6576,6602;6656,6679;6688,6741;6823,6824;6917,6964;6981,6988;7043,7073;7086,7088;7098,7142;7168,7204;7245,7248;7258,7294;7296,7305;7312,7355;7357,7360;7401,7405;7406,7412;7413,7415;7418,7419;7424,7616;7680,7958;7960,7966;7968,8006;8008,8014;8016,8024;8025,8026;8027,8028;8029,8030;8031,8062;8064,8117;8118,8125;8126,8127;8130,8133;8134,8141;8144,8148;8150,8156;8160,8173;8178,8181;8182,8189;8305,8306;8319,8320;8336,8349;8450,8451;8455,8456;8458,8468;8469,8470;8472,8478;8484,8485;8486,8487;8488,8489;8490,8506;8508,8512;8517,8522;8526,8527;8544,8585;11264,11311;11312,11359;11360,11493;11499,11503;11506,11508;11520,11558;11559,11560;11565,11566;11568,11624;11631,11632;11648,11671;11680,11687;11688,11695;11696,11703;11704,11711;11712,11719;11720,11727;11728,11735;11736,11743;12293,12296;12321,12330;12337,12342;12344,12349;12353,12439;12443,12448;12449,12539;12540,12544;12549,12592;12593,12687;12704,12731;12784,12800;13312,19894;19968,40944;40960,42125;42192,42238;42240,42509;42512,42528;42538,42540;42560,42607;42623,42654;42656,42736;42775,42784;42786,42889;42891,42944;42946,42951;42999,43010;43011,43014;43015,43019;43020,43043;43072,43124;43138,43188;43250,43256;43259,43260;43261,43263;43274,43302;43312,43335;43360,43389;43396,43443;43471,43472;43488,43493;43494,43504;43514,43519;43520,43561;43584,43587;43588,43596;43616,43639;43642,43643;43646,43696;43697,43698;43701,43703;43705,43710;43712,43713;43714,43715;43739,43742;43744,43755;43762,43765;43777,43783;43785,43791;43793,43799;43808,43815;43816,43823;43824,43867;43868,43880;43888,44003;44032,55204;55216,55239;55243,55292;63744,64110;64112,64218;64256,64263;64275,64280;64285,64286;64287,64297;64298,64311;64312,64317;64318,64319;64320,64322;64323,64325;64326,64434;64467,64830;64848,64912;64914,64968;65008,65020;65136,65141;65142,65277;65313,65339;65345,65371;65382,65471;65474,65480;65482,65488;65490,65496;65498,65501;65536,65548;65549,65575;65576,65595;65596,65598;65599,65614;65616,65630;65664,65787;65856,65909;66176,66205;66208,66257;66304,66336;66349,66379;66384,66422;66432,66462;66464,66500;66504,66512;66513,66518;66560,66718;66736,66772;66776,66812;66816,66856;66864,66916;67072,67383;67392,67414;67424,67432;67584,67590;67592,67593;67594,67638;67639,67641;67644,67645;67647,67670;67680,67703;67712,67743;67808,67827;67828,67830;67840,67862;67872,67898;67968,68024;68030,68032;68096,68097;68112,68116;68117,68120;68121,68150;68192,68221;68224,68253;68288,68296;68297,68325;68352,68406;68416,68438;68448,68467;68480,68498;68608,68681;68736,68787;68800,68851;68864,68900;69376,69405;69415,69416;69424,69446;69600,69623;69635,69688;69763,69808;69840,69865;69891,69927;69956,69957;69968,70003;70006,70007;70019,70067;70081,70085;70106,70107;70108,70109;70144,70162;70163,70188;70272,70279;70280,70281;70282,70286;70287,70302;70303,70313;70320,70367;70405,70413;70415,70417;70419,70441;70442,70449;70450,70452;70453,70458;70461,70462;70480,70481;70493,70498;70656,70709;70727,70731;70751,70752;70784,70832;70852,70854;70855,70856;71040,71087;71128,71132;71168,71216;71236,71237;71296,71339;71352,71353;71424,71451;71680,71724;71840,71904;71935,71936;72096,72104;72106,72145;72161,72162;72163,72164;72192,72193;72203,72243;72250,72251;72272,72273;72284,72330;72349,72350;72384,72441;72704,72713;72714,72751;72768,72769;72818,72848;72960,72967;72968,72970;72971,73009;73030,73031;73056,73062;73063,73065;73066,73098;73112,73113;73440,73459;73728,74650;74752,74863;74880,75076;77824,78895;82944,83527;92160,92729;92736,92767;92880,92910;92928,92976;92992,92996;93027,93048;93053,93072;93760,93824;93952,94027;94032,94033;94099,94112;94176,94178;94179,94180;94208,100344;100352,101107;110592,110879;110928,110931;110948,110952;110960,111356;113664,113771;113776,113789;113792,113801;113808,113818;119808,119893;119894,119965;119966,119968;119970,119971;119973,119975;119977,119981;119982,119994;119995,119996;119997,120004;120005,120070;120071,120075;120077,120085;120086,120093;120094,120122;120123,120127;120128,120133;120134,120135;120138,120145;120146,120486;120488,120513;120514,120539;120540,120571;120572,120597;120598,120629;120630,120655;120656,120687;120688,120713;120714,120745;120746,120771;120772,120780;123136,123181;123191,123198;123214,123215;123584,123628;124928,125125;125184,125252;125259,125260;126464,126468;126469,126496;126497,126499;126500,126501;126503,126504;126505,126515;126516,126520;126521,126522;126523,126524;126530,126531;126535,126536;126537,126538;126539,126540;126541,126544;126545,126547;126548,126549;126551,126552;126553,126554;126555,126556;126557,126558;126559,126560;126561,126563;126564,126565;126567,126571;126572,126579;126580,126584;126585,126589;126590,126591;126592,126602;126603,126620;126625,126628;126629,126634;126635,126652;131072,173783;173824,177973;177984,178206;178208,183970;183984,191457;194560,195102|] - -(* The followed ID restriction is relaxed, this one - is used in our customized unicode lexing. - *) -let id_continue = [|36,37;48,58;65,91;95,96;97,123;170,171;181,182;183,184;186,187;192,215;216,247;248,706;710,722;736,741;748,749;750,751;768,885;886,888;890,894;895,896;902,907;908,909;910,930;931,1014;1015,1154;1155,1160;1162,1328;1329,1367;1369,1370;1376,1417;1425,1470;1471,1472;1473,1475;1476,1478;1479,1480;1488,1515;1519,1523;1552,1563;1568,1642;1646,1748;1749,1757;1759,1769;1770,1789;1791,1792;1808,1867;1869,1970;1984,2038;2042,2043;2045,2046;2048,2094;2112,2140;2144,2155;2208,2229;2230,2238;2259,2274;2275,2404;2406,2416;2417,2436;2437,2445;2447,2449;2451,2473;2474,2481;2482,2483;2486,2490;2492,2501;2503,2505;2507,2511;2519,2520;2524,2526;2527,2532;2534,2546;2556,2557;2558,2559;2561,2564;2565,2571;2575,2577;2579,2601;2602,2609;2610,2612;2613,2615;2616,2618;2620,2621;2622,2627;2631,2633;2635,2638;2641,2642;2649,2653;2654,2655;2662,2678;2689,2692;2693,2702;2703,2706;2707,2729;2730,2737;2738,2740;2741,2746;2748,2758;2759,2762;2763,2766;2768,2769;2784,2788;2790,2800;2809,2816;2817,2820;2821,2829;2831,2833;2835,2857;2858,2865;2866,2868;2869,2874;2876,2885;2887,2889;2891,2894;2902,2904;2908,2910;2911,2916;2918,2928;2929,2930;2946,2948;2949,2955;2958,2961;2962,2966;2969,2971;2972,2973;2974,2976;2979,2981;2984,2987;2990,3002;3006,3011;3014,3017;3018,3022;3024,3025;3031,3032;3046,3056;3072,3085;3086,3089;3090,3113;3114,3130;3133,3141;3142,3145;3146,3150;3157,3159;3160,3163;3168,3172;3174,3184;3200,3204;3205,3213;3214,3217;3218,3241;3242,3252;3253,3258;3260,3269;3270,3273;3274,3278;3285,3287;3294,3295;3296,3300;3302,3312;3313,3315;3328,3332;3333,3341;3342,3345;3346,3397;3398,3401;3402,3407;3412,3416;3423,3428;3430,3440;3450,3456;3458,3460;3461,3479;3482,3506;3507,3516;3517,3518;3520,3527;3530,3531;3535,3541;3542,3543;3544,3552;3558,3568;3570,3572;3585,3643;3648,3663;3664,3674;3713,3715;3716,3717;3718,3723;3724,3748;3749,3750;3751,3774;3776,3781;3782,3783;3784,3790;3792,3802;3804,3808;3840,3841;3864,3866;3872,3882;3893,3894;3895,3896;3897,3898;3902,3912;3913,3949;3953,3973;3974,3992;3993,4029;4038,4039;4096,4170;4176,4254;4256,4294;4295,4296;4301,4302;4304,4347;4348,4681;4682,4686;4688,4695;4696,4697;4698,4702;4704,4745;4746,4750;4752,4785;4786,4790;4792,4799;4800,4801;4802,4806;4808,4823;4824,4881;4882,4886;4888,4955;4957,4960;4969,4978;4992,5008;5024,5110;5112,5118;5121,5741;5743,5760;5761,5787;5792,5867;5870,5881;5888,5901;5902,5909;5920,5941;5952,5972;5984,5997;5998,6001;6002,6004;6016,6100;6103,6104;6108,6110;6112,6122;6155,6158;6160,6170;6176,6265;6272,6315;6320,6390;6400,6431;6432,6444;6448,6460;6470,6510;6512,6517;6528,6572;6576,6602;6608,6619;6656,6684;6688,6751;6752,6781;6783,6794;6800,6810;6823,6824;6832,6846;6912,6988;6992,7002;7019,7028;7040,7156;7168,7224;7232,7242;7245,7294;7296,7305;7312,7355;7357,7360;7376,7379;7380,7419;7424,7674;7675,7958;7960,7966;7968,8006;8008,8014;8016,8024;8025,8026;8027,8028;8029,8030;8031,8062;8064,8117;8118,8125;8126,8127;8130,8133;8134,8141;8144,8148;8150,8156;8160,8173;8178,8181;8182,8189;8204,8206;8255,8257;8276,8277;8305,8306;8319,8320;8336,8349;8400,8413;8417,8418;8421,8433;8450,8451;8455,8456;8458,8468;8469,8470;8472,8478;8484,8485;8486,8487;8488,8489;8490,8506;8508,8512;8517,8522;8526,8527;8544,8585;11264,11311;11312,11359;11360,11493;11499,11508;11520,11558;11559,11560;11565,11566;11568,11624;11631,11632;11647,11671;11680,11687;11688,11695;11696,11703;11704,11711;11712,11719;11720,11727;11728,11735;11736,11743;11744,11776;12293,12296;12321,12336;12337,12342;12344,12349;12353,12439;12441,12448;12449,12539;12540,12544;12549,12592;12593,12687;12704,12731;12784,12800;13312,19894;19968,40944;40960,42125;42192,42238;42240,42509;42512,42540;42560,42608;42612,42622;42623,42738;42775,42784;42786,42889;42891,42944;42946,42951;42999,43048;43072,43124;43136,43206;43216,43226;43232,43256;43259,43260;43261,43310;43312,43348;43360,43389;43392,43457;43471,43482;43488,43519;43520,43575;43584,43598;43600,43610;43616,43639;43642,43715;43739,43742;43744,43760;43762,43767;43777,43783;43785,43791;43793,43799;43808,43815;43816,43823;43824,43867;43868,43880;43888,44011;44012,44014;44016,44026;44032,55204;55216,55239;55243,55292;63744,64110;64112,64218;64256,64263;64275,64280;64285,64297;64298,64311;64312,64317;64318,64319;64320,64322;64323,64325;64326,64434;64467,64830;64848,64912;64914,64968;65008,65020;65024,65040;65056,65072;65075,65077;65101,65104;65136,65141;65142,65277;65296,65306;65313,65339;65343,65344;65345,65371;65382,65471;65474,65480;65482,65488;65490,65496;65498,65501;65536,65548;65549,65575;65576,65595;65596,65598;65599,65614;65616,65630;65664,65787;65856,65909;66045,66046;66176,66205;66208,66257;66272,66273;66304,66336;66349,66379;66384,66427;66432,66462;66464,66500;66504,66512;66513,66518;66560,66718;66720,66730;66736,66772;66776,66812;66816,66856;66864,66916;67072,67383;67392,67414;67424,67432;67584,67590;67592,67593;67594,67638;67639,67641;67644,67645;67647,67670;67680,67703;67712,67743;67808,67827;67828,67830;67840,67862;67872,67898;67968,68024;68030,68032;68096,68100;68101,68103;68108,68116;68117,68120;68121,68150;68152,68155;68159,68160;68192,68221;68224,68253;68288,68296;68297,68327;68352,68406;68416,68438;68448,68467;68480,68498;68608,68681;68736,68787;68800,68851;68864,68904;68912,68922;69376,69405;69415,69416;69424,69457;69600,69623;69632,69703;69734,69744;69759,69819;69840,69865;69872,69882;69888,69941;69942,69952;69956,69959;69968,70004;70006,70007;70016,70085;70089,70093;70096,70107;70108,70109;70144,70162;70163,70200;70206,70207;70272,70279;70280,70281;70282,70286;70287,70302;70303,70313;70320,70379;70384,70394;70400,70404;70405,70413;70415,70417;70419,70441;70442,70449;70450,70452;70453,70458;70459,70469;70471,70473;70475,70478;70480,70481;70487,70488;70493,70500;70502,70509;70512,70517;70656,70731;70736,70746;70750,70752;70784,70854;70855,70856;70864,70874;71040,71094;71096,71105;71128,71134;71168,71233;71236,71237;71248,71258;71296,71353;71360,71370;71424,71451;71453,71468;71472,71482;71680,71739;71840,71914;71935,71936;72096,72104;72106,72152;72154,72162;72163,72165;72192,72255;72263,72264;72272,72346;72349,72350;72384,72441;72704,72713;72714,72759;72760,72769;72784,72794;72818,72848;72850,72872;72873,72887;72960,72967;72968,72970;72971,73015;73018,73019;73020,73022;73023,73032;73040,73050;73056,73062;73063,73065;73066,73103;73104,73106;73107,73113;73120,73130;73440,73463;73728,74650;74752,74863;74880,75076;77824,78895;82944,83527;92160,92729;92736,92767;92768,92778;92880,92910;92912,92917;92928,92983;92992,92996;93008,93018;93027,93048;93053,93072;93760,93824;93952,94027;94031,94088;94095,94112;94176,94178;94179,94180;94208,100344;100352,101107;110592,110879;110928,110931;110948,110952;110960,111356;113664,113771;113776,113789;113792,113801;113808,113818;113821,113823;119141,119146;119149,119155;119163,119171;119173,119180;119210,119214;119362,119365;119808,119893;119894,119965;119966,119968;119970,119971;119973,119975;119977,119981;119982,119994;119995,119996;119997,120004;120005,120070;120071,120075;120077,120085;120086,120093;120094,120122;120123,120127;120128,120133;120134,120135;120138,120145;120146,120486;120488,120513;120514,120539;120540,120571;120572,120597;120598,120629;120630,120655;120656,120687;120688,120713;120714,120745;120746,120771;120772,120780;120782,120832;121344,121399;121403,121453;121461,121462;121476,121477;121499,121504;121505,121520;122880,122887;122888,122905;122907,122914;122915,122917;122918,122923;123136,123181;123184,123198;123200,123210;123214,123215;123584,123642;124928,125125;125136,125143;125184,125260;125264,125274;126464,126468;126469,126496;126497,126499;126500,126501;126503,126504;126505,126515;126516,126520;126521,126522;126523,126524;126530,126531;126535,126536;126537,126538;126539,126540;126541,126544;126545,126547;126548,126549;126551,126552;126553,126554;126555,126556;126557,126558;126559,126560;126561,126563;126564,126565;126567,126571;126572,126579;126580,126584;126585,126589;126590,126591;126592,126602;126603,126620;126625,126628;126629,126634;126635,126652;131072,173783;173824,177973;177984,178206;178208,183970;183984,191457;194560,195102;917760,918000|] diff --git a/jscomp/js_parser/jsx_parser.ml b/jscomp/js_parser/jsx_parser.ml deleted file mode 100644 index f2e2fef..0000000 --- a/jscomp/js_parser/jsx_parser.ml +++ /dev/null @@ -1,457 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Token -open Parser_common -open Parser_env -open Flow_ast - -module JSX (Parse : Parser_common.PARSER) = struct - (* Consumes and returns the trailing comments after the end of a JSX tag name, - attribute, or spread attribute. - - If the component is followed by the end of the JSX tag, then all trailing - comments are returned. If the component is instead followed by another tag - component on another line, only trailing comments on the same line are - returned. If the component is followed by another tag component on the same - line, all trailing comments will instead be leading the next component. *) - let tag_component_trailing_comments env = - match Peek.token env with - | T_EOF - | T_DIV - | T_GREATER_THAN -> - Eat.trailing_comments env - | _ when Peek.is_line_terminator env -> Eat.comments_until_next_line env - | _ -> [] - - let spread_attribute env = - let leading = Peek.comments env in - Eat.push_lex_mode env Lex_mode.NORMAL; - let (loc, argument) = - with_loc - (fun env -> - Expect.token env T_LCURLY; - Expect.token env T_ELLIPSIS; - let argument = Parse.assignment env in - Expect.token env T_RCURLY; - argument) - env - in - Eat.pop_lex_mode env; - let trailing = tag_component_trailing_comments env in - ( loc, - { - JSX.SpreadAttribute.argument; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - let expression_container_contents env = - if Peek.token env = T_RCURLY then - JSX.ExpressionContainer.EmptyExpression - else - JSX.ExpressionContainer.Expression (Parse.expression env) - - let expression_container env = - let leading = Peek.comments env in - Eat.push_lex_mode env Lex_mode.NORMAL; - let (loc, expression) = - with_loc - (fun env -> - Expect.token env T_LCURLY; - let expression = expression_container_contents env in - Expect.token env T_RCURLY; - expression) - env - in - Eat.pop_lex_mode env; - let trailing = tag_component_trailing_comments env in - ( loc, - { - JSX.ExpressionContainer.expression; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal:[] (); - } - ) - - let expression_container_or_spread_child env = - Eat.push_lex_mode env Lex_mode.NORMAL; - let (loc, result) = - with_loc - (fun env -> - Expect.token env T_LCURLY; - let result = - match Peek.token env with - | T_ELLIPSIS -> - let leading = Peek.comments env in - Expect.token env T_ELLIPSIS; - let expression = Parse.assignment env in - JSX.SpreadChild - { - JSX.SpreadChild.expression; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - | _ -> - let expression = expression_container_contents env in - let internal = - match expression with - | JSX.ExpressionContainer.EmptyExpression -> Peek.comments env - | _ -> [] - in - JSX.ExpressionContainer - { - JSX.ExpressionContainer.expression; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~internal (); - } - in - Expect.token env T_RCURLY; - result) - env - in - Eat.pop_lex_mode env; - (loc, result) - - let identifier env = - let loc = Peek.loc env in - let name = - match Peek.token env with - | T_JSX_IDENTIFIER { raw; _ } -> raw - | _ -> - error_unexpected ~expected:"an identifier" env; - "" - in - let leading = Peek.comments env in - Eat.token env; - (* Unless this identifier is the first part of a namespaced name, member - expression, or attribute name, it is the end of a tag component. *) - let trailing = - match Peek.token env with - (* Namespaced name *) - | T_COLON - (* Member expression *) - | T_PERIOD - (* Attribute name *) - | T_ASSIGN -> - Eat.trailing_comments env - | _ -> tag_component_trailing_comments env - in - (loc, JSX.Identifier.{ name; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () }) - - let name = - let rec member_expression env member = - match Peek.token env with - | T_PERIOD -> - let (start_loc, _) = member in - let member = - with_loc - ~start_loc - (fun env -> - Expect.token env T_PERIOD; - let property = identifier env in - { - JSX.MemberExpression._object = JSX.MemberExpression.MemberExpression member; - property; - }) - env - in - member_expression env member - | _ -> member - in - fun env -> - match Peek.ith_token ~i:1 env with - | T_COLON -> - let namespaced_name = - with_loc - (fun env -> - let namespace = identifier env in - Expect.token env T_COLON; - let name = identifier env in - { JSX.NamespacedName.namespace; name }) - env - in - JSX.NamespacedName namespaced_name - | T_PERIOD -> - let member = - with_loc - (fun env -> - let _object = JSX.MemberExpression.Identifier (identifier env) in - Expect.token env T_PERIOD; - let property = identifier env in - { JSX.MemberExpression._object; property }) - env - in - JSX.MemberExpression (member_expression env member) - | _ -> - let name = identifier env in - JSX.Identifier name - - let attribute env = - with_loc - (fun env -> - let name = - match Peek.ith_token ~i:1 env with - | T_COLON -> - let namespaced_name = - with_loc - (fun env -> - let namespace = identifier env in - Expect.token env T_COLON; - let name = identifier env in - { JSX.NamespacedName.namespace; name }) - env - in - JSX.Attribute.NamespacedName namespaced_name - | _ -> - let name = identifier env in - JSX.Attribute.Identifier name - in - let value = - match Peek.token env with - | T_ASSIGN -> - Expect.token env T_ASSIGN; - let leading = Peek.comments env in - let tkn = Peek.token env in - begin - match tkn with - | T_LCURLY -> - let (loc, expression_container) = expression_container env in - JSX.ExpressionContainer.( - match expression_container.expression with - | EmptyExpression -> - error_at env (loc, Parse_error.JSXAttributeValueEmptyExpression) - | _ -> () - ); - Some (JSX.Attribute.ExpressionContainer (loc, expression_container)) - | T_JSX_TEXT (loc, value, raw) as token -> - Expect.token env token; - let value = Ast.Literal.String value in - let trailing = tag_component_trailing_comments env in - Some - (JSX.Attribute.Literal - ( loc, - { - Ast.Literal.value; - raw; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - ) - | _ -> - error env Parse_error.InvalidJSXAttributeValue; - let loc = Peek.loc env in - let raw = "" in - let value = Ast.Literal.String "" in - Some (JSX.Attribute.Literal (loc, { Ast.Literal.value; raw; comments = None })) - end - | _ -> None - in - { JSX.Attribute.name; value }) - env - - let opening_element = - let rec attributes env acc = - match Peek.token env with - | T_JSX_IDENTIFIER _ -> - let attribute = JSX.Opening.Attribute (attribute env) in - attributes env (attribute :: acc) - | T_LCURLY -> - let attribute = JSX.Opening.SpreadAttribute (spread_attribute env) in - attributes env (attribute :: acc) - | _ -> List.rev acc - in - fun env -> - with_loc - (fun env -> - Expect.token env T_LESS_THAN; - match Peek.token env with - | T_GREATER_THAN -> - Eat.token env; - Ok `Fragment - | T_JSX_IDENTIFIER _ -> - let name = name env in - let attributes = attributes env [] in - let self_closing = Eat.maybe env T_DIV in - let element = `Element { JSX.Opening.name; self_closing; attributes } in - if Eat.maybe env T_GREATER_THAN then - Ok element - else ( - Expect.error env T_GREATER_THAN; - Error element - ) - | _ -> - (* TODO: also say that we could expect an identifier, or if we're in a JSX child - then suggest escaping the < as `{'<'}` *) - Expect.error env T_GREATER_THAN; - Error `Fragment) - env - - let closing_element env = - with_loc - (fun env -> - Expect.token env T_LESS_THAN; - Expect.token env T_DIV; - match Peek.token env with - | T_GREATER_THAN -> - Eat.token env; - `Fragment - | T_JSX_IDENTIFIER _ -> - let name = name env in - Expect.token_opt env T_GREATER_THAN; - `Element { JSX.Closing.name } - | _ -> - Expect.error env T_GREATER_THAN; - `Fragment) - env - - let rec child env = - match Peek.token env with - | T_LCURLY -> expression_container_or_spread_child env - | T_JSX_TEXT (loc, value, raw) as token -> - Expect.token env token; - (loc, JSX.Text { JSX.Text.value; raw }) - | _ -> - (match element_or_fragment env with - | (loc, `Element element) -> (loc, JSX.Element element) - | (loc, `Fragment fragment) -> (loc, JSX.Fragment fragment)) - - and element = - let children_and_closing = - let rec children_and_closing env acc = - let previous_loc = last_loc env in - match Peek.token env with - | T_LESS_THAN -> - Eat.push_lex_mode env Lex_mode.JSX_TAG; - begin - match (Peek.token env, Peek.ith_token ~i:1 env) with - | (T_LESS_THAN, T_EOF) - | (T_LESS_THAN, T_DIV) -> - let closing = - match closing_element env with - | (loc, `Element ec) -> `Element (loc, ec) - | (loc, `Fragment) -> `Fragment loc - in - (* We double pop to avoid going back to childmode and re-lexing the - * lookahead *) - Eat.double_pop_lex_mode env; - (List.rev acc, previous_loc, closing) - | _ -> - let child = - match element env with - | (loc, `Element e) -> (loc, JSX.Element e) - | (loc, `Fragment f) -> (loc, JSX.Fragment f) - in - children_and_closing env (child :: acc) - end - | T_EOF -> - error_unexpected env; - (List.rev acc, previous_loc, `None) - | _ -> children_and_closing env (child env :: acc) - in - fun env -> - let start_loc = Peek.loc env in - let (children, last_child_loc, closing) = children_and_closing env [] in - let last_child_loc = - match last_child_loc with - | Some x -> x - | None -> start_loc - in - (* It's a little bit tricky to untangle the parsing of the child elements from the parsing - * of the closing element, so we can't easily use `with_loc` here. Instead, we'll use the - * same logic that `with_loc` uses, but manipulate the locations explicitly. *) - let children_loc = Loc.btwn start_loc last_child_loc in - ((children_loc, children), closing) - in - let rec normalize name = - JSX.( - match name with - | Identifier (_, { Identifier.name; comments = _ }) -> name - | NamespacedName (_, { NamespacedName.namespace; name }) -> - (snd namespace).Identifier.name ^ ":" ^ (snd name).Identifier.name - | MemberExpression (_, { MemberExpression._object; property }) -> - let _object = - match _object with - | MemberExpression.Identifier (_, { Identifier.name = id; _ }) -> id - | MemberExpression.MemberExpression e -> normalize (JSX.MemberExpression e) - in - _object ^ "." ^ (snd property).Identifier.name - ) - in - let is_self_closing = function - | (_, Ok (`Element e)) -> e.JSX.Opening.self_closing - | (_, Ok `Fragment) -> false - | (_, Error _) -> true - in - fun env -> - let leading = Peek.comments env in - let opening_element = opening_element env in - Eat.pop_lex_mode env; - let (children, closing_element) = - if is_self_closing opening_element then - (with_loc (fun _ -> []) env, `None) - else ( - Eat.push_lex_mode env Lex_mode.JSX_CHILD; - children_and_closing env - ) - in - let trailing = Eat.trailing_comments env in - let end_loc = - match closing_element with - | `Element (loc, { JSX.Closing.name }) -> - (match snd opening_element with - | Ok (`Element { JSX.Opening.name = opening_name; _ }) -> - let opening_name = normalize opening_name in - if normalize name <> opening_name then - error env (Parse_error.ExpectedJSXClosingTag opening_name) - | Ok `Fragment -> error env (Parse_error.ExpectedJSXClosingTag "JSX fragment") - | Error _ -> ()); - loc - | `Fragment loc -> - (match snd opening_element with - | Ok (`Element { JSX.Opening.name = opening_name; _ }) -> - error env (Parse_error.ExpectedJSXClosingTag (normalize opening_name)) - | Ok `Fragment -> () - | Error _ -> ()); - loc - | _ -> fst opening_element - in - let result = - match opening_element with - | (start_loc, Ok (`Element e)) - | (start_loc, Error (`Element e)) -> - `Element - JSX. - { - opening_element = (start_loc, e); - closing_element = - (match closing_element with - | `Element e -> Some e - | _ -> None); - children; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - | (start_loc, Ok `Fragment) - | (start_loc, Error `Fragment) -> - `Fragment - { - JSX.frag_opening_element = start_loc; - frag_closing_element = - (match closing_element with - | `Fragment loc -> loc - (* the following are parse erros *) - | `Element (loc, _) -> loc - | _ -> end_loc); - frag_children = children; - frag_comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - in - - (Loc.btwn (fst opening_element) end_loc, result) - - and element_or_fragment env = - Eat.push_lex_mode env Lex_mode.JSX_TAG; - element env -end diff --git a/jscomp/js_parser/lex_env.ml b/jscomp/js_parser/lex_env.ml deleted file mode 100644 index 00c36c4..0000000 --- a/jscomp/js_parser/lex_env.ml +++ /dev/null @@ -1,87 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Sedlexing = Flow_sedlexing - -(* bol = Beginning Of Line *) -type bol = { - line: int; - offset: int; -} - -type lex_state = { lex_errors_acc: (Loc.t * Parse_error.t) list } [@@ocaml.unboxed] - -type t = { - lex_source: File_key.t option; - lex_lb: Sedlexing.lexbuf; - lex_bol: bol; - lex_in_comment_syntax: bool; - lex_enable_comment_syntax: bool; - lex_state: lex_state; - lex_last_loc: Loc.t; -} - -let empty_lex_state = { lex_errors_acc = [] } - -(* The lex_last_loc should initially be set to the beginning of the first line, so that - comments on the first line are reported as not being on a new line. *) -let initial_last_loc = - { Loc.source = None; start = { Loc.line = 1; column = 0 }; _end = { Loc.line = 1; column = 0 } } - -let new_lex_env lex_source lex_lb ~enable_types_in_comments = - { - lex_source; - lex_lb; - lex_bol = { line = 1; offset = 0 }; - lex_in_comment_syntax = false; - lex_enable_comment_syntax = enable_types_in_comments; - lex_state = empty_lex_state; - lex_last_loc = initial_last_loc; - } - -(* copy all the mutable things so that we have a distinct lexing environment - that does not interfere with ordinary lexer operations *) -let clone env = - let lex_lb = Sedlexing.lexbuf_clone env.lex_lb in - { env with lex_lb } - -let lexbuf env = env.lex_lb - -let source env = env.lex_source - -let state env = env.lex_state - -let line env = env.lex_bol.line - -let bol_offset env = env.lex_bol.offset - -let is_in_comment_syntax env = env.lex_in_comment_syntax - -let is_comment_syntax_enabled env = env.lex_enable_comment_syntax - -let in_comment_syntax is_in env = - if is_in <> env.lex_in_comment_syntax then - { env with lex_in_comment_syntax = is_in } - else - env - -(* TODO *) -let debug_string_of_lexbuf _lb = "" - -let debug_string_of_lex_env (env : t) = - let source = - match source env with - | None -> "None" - | Some x -> Printf.sprintf "Some %S" (File_key.to_string x) - in - Printf.sprintf - "{\n lex_source = %s\n lex_lb = %s\n lex_in_comment_syntax = %b\n lex_enable_comment_syntax = %b\n lex_state = {errors = (count = %d)}\n}" - source - (debug_string_of_lexbuf env.lex_lb) - (is_in_comment_syntax env) - (is_comment_syntax_enabled env) - (List.length (state env).lex_errors_acc) diff --git a/jscomp/js_parser/lex_result.ml b/jscomp/js_parser/lex_result.ml deleted file mode 100644 index 06ca899..0000000 --- a/jscomp/js_parser/lex_result.ml +++ /dev/null @@ -1,29 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -type t = { - lex_token: Token.t; - lex_loc: Loc.t; - lex_errors: (Loc.t * Parse_error.t) list; - lex_comments: Loc.t Flow_ast.Comment.t list; -} - -let token result = result.lex_token - -let loc result = result.lex_loc - -let comments result = result.lex_comments - -let errors result = result.lex_errors - -let debug_string_of_lex_result lex_result = - Printf.sprintf - "{\n lex_token = %s\n lex_value = %S\n lex_errors = (length = %d)\n lex_comments = (length = %d)\n}" - (Token.token_to_string lex_result.lex_token) - (Token.value_of_token lex_result.lex_token) - (List.length lex_result.lex_errors) - (List.length lex_result.lex_comments) diff --git a/jscomp/js_parser/loc.ml b/jscomp/js_parser/loc.ml deleted file mode 100644 index 143f067..0000000 --- a/jscomp/js_parser/loc.ml +++ /dev/null @@ -1,187 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) -open Primitive_deriving - -(* line numbers are 1-indexed; column numbers are 0-indexed *) -type position = { - line: int; - column: int; -} -[@@deriving_inline equal] -let _ = fun (_ : position) -> () -let equal_position = - (fun a__001_ -> - fun b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ - then true - else - Ppx_compare_lib.(&&) (equal_int a__001_.line b__002_.line) - (equal_int a__001_.column b__002_.column) : position -> - position -> bool) -let _ = equal_position -[@@@end] -(* start is inclusive; end is exclusive *) -(* If you are modifying this record, go look at ALoc.ml and make sure you understand the - * representation there. *) -type t = { - source: File_key.t option; - start: position; - _end: position; -} - -let none = { source = None; start = { line = 0; column = 0 }; _end = { line = 0; column = 0 } } - -let is_none (x : t) = - x == none - || - match x with - | { source = None; start = { line = 0; column = 0 }; _end = { line = 0; column = 0 } } -> true - | _ -> false - -let is_none_ignore_source (x : t) = - x == none - || - match x with - | { source = _; start = { line = 0; column = 0 }; _end = { line = 0; column = 0 } } -> true - | _ -> false - -let btwn loc1 loc2 = { source = loc1.source; start = loc1.start; _end = loc2._end } - -(* Returns the position immediately before the start of the given loc. If the - given loc is at the beginning of a line, return the position of the first - char on the same line. *) -let char_before loc = - let start = - let { line; column } = loc.start in - let column = - if column > 0 then - column - 1 - else - column - in - { line; column } - in - let _end = loc.start in - { loc with start; _end } - -(* Returns the location of the first character in the given loc. Not accurate if the - * first line is a newline character, but is still consistent with loc orderings. *) -let first_char loc = - let start = loc.start in - let _end = { start with column = start.column + 1 } in - { loc with _end } - -let pos_cmp a b = - let k = a.line - b.line in - if k = 0 then - a.column - b.column - else - k - -(** - * If `a` spans (completely contains) `b`, then returns 0. - * If `b` starts before `a` (even if it ends inside), returns < 0. - * If `b` ends after `a` (even if it starts inside), returns > 0. - *) -let span_compare a b = - let k = File_key.compare_opt a.source b.source in - if k = 0 then - let k = pos_cmp a.start b.start in - if k <= 0 then - let k = pos_cmp a._end b._end in - if k >= 0 then - 0 - else - -1 - else - 1 - else - k - -(** [contains loc1 loc2] returns true if [loc1] entirely overlaps [loc2] *) -let contains loc1 loc2 = span_compare loc1 loc2 = 0 - -(** [intersects loc1 loc2] returns true if [loc1] intersects [loc2] at all *) -let intersects loc1 loc2 = - File_key.compare_opt loc1.source loc2.source = 0 - && not (pos_cmp loc1._end loc2.start < 0 || pos_cmp loc1.start loc2._end > 0) - -(** [lines_intersect loc1 loc2] returns true if [loc1] and [loc2] cover any part of - the same line, even if they don't actually intersect. - - For example, if [loc1] ends and then [loc2] begins later on the same line, - [intersects loc1 loc2] is false, but [lines_intersect loc1 loc2] is true. *) -let lines_intersect loc1 loc2 = - File_key.compare_opt loc1.source loc2.source = 0 - && not (loc1._end.line < loc2.start.line || loc1.start.line > loc2._end.line) - -let compare_ignore_source loc1 loc2 = - match pos_cmp loc1.start loc2.start with - | 0 -> pos_cmp loc1._end loc2._end - | k -> k - -let compare loc1 loc2 = - let k = File_key.compare_opt loc1.source loc2.source in - if k = 0 then - compare_ignore_source loc1 loc2 - else - k - -let equal loc1 loc2 = compare loc1 loc2 = 0 - -(** - * This is mostly useful for debugging purposes. - * Please don't dead-code delete this! - *) -let debug_to_string ?(include_source = false) loc = - let source = - if include_source then - Printf.sprintf - "%S: " - (match loc.source with - | Some src -> File_key.to_string src - | None -> "") - else - "" - in - let pos = - Printf.sprintf - "(%d, %d) to (%d, %d)" - loc.start.line - loc.start.column - loc._end.line - loc._end.column - in - source ^ pos - -let to_string_no_source loc = - let line = loc.start.line in - let start = loc.start.column + 1 in - let end_ = loc._end.column in - if line <= 0 then - "0:0" - else if line = loc._end.line && start = end_ then - Printf.sprintf "%d:%d" line start - else if line != loc._end.line then - Printf.sprintf "%d:%d,%d:%d" line start loc._end.line end_ - else - Printf.sprintf "%d:%d-%d" line start end_ - -let mk_loc ?source (start_line, start_column) (end_line, end_column) = - { - source; - start = { line = start_line; column = start_column }; - _end = { line = end_line; column = end_column }; - } - -let source loc = loc.source - -(** Produces a zero-width Loc.t, where start = end *) -let cursor source line column = { source; start = { line; column }; _end = { line; column } } - -let start_loc loc = { loc with _end = loc.start } -let end_loc loc = { loc with start = loc._end } diff --git a/jscomp/js_parser/loc.mli b/jscomp/js_parser/loc.mli deleted file mode 100644 index 4102338..0000000 --- a/jscomp/js_parser/loc.mli +++ /dev/null @@ -1,77 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -type position = { - line: int; - column: int; -} -[@@deriving_inline equal] -include - sig - [@@@warning "-32"] - val equal_position : position -> position -> bool - end[@@ocaml.doc "@inline"] -[@@@end] -type t = { - source: File_key.t option; - start: position; - _end: position; -} - - -val none : t - -val is_none : t -> bool - -val is_none_ignore_source : t -> bool - -val btwn : t -> t -> t - -val char_before : t -> t - -val first_char : t -> t - -(** [contains loc1 loc2] returns true if [loc1] entirely overlaps [loc2] *) -val contains : t -> t -> bool - -(** [intersects loc1 loc2] returns true if [loc1] intersects [loc2] at all *) -val intersects : t -> t -> bool - -(** [lines_intersect loc1 loc2] returns true if [loc1] and [loc2] cover any part of - the same line, even if they don't actually intersect. - - For example, if [loc1] ends and then [loc2] begins later on the same line, - [intersects loc1 loc2] is false, but [lines_intersect loc1 loc2] is true. *) -val lines_intersect : t -> t -> bool - -val pos_cmp : position -> position -> int - -val span_compare : t -> t -> int - -val compare_ignore_source : t -> t -> int - -val compare : t -> t -> int - -val equal : t -> t -> bool - -val debug_to_string : ?include_source:bool -> t -> string - -(* Relatively compact; suitable for use as a unique string identifier *) -val to_string_no_source : t -> string - -val mk_loc : ?source:File_key.t -> int * int -> int * int -> t - -val source : t -> File_key.t option - -(** Produces a zero-width Loc.t, where start = end *) -val cursor : File_key.t option -> int -> int -> t - -(* Produces a location at the start of the input location *) -val start_loc : t -> t - -(* Produces a location at the end of the input location *) -val end_loc : t -> t diff --git a/jscomp/js_parser/object_parser.ml b/jscomp/js_parser/object_parser.ml deleted file mode 100644 index b5ece9e..0000000 --- a/jscomp/js_parser/object_parser.ml +++ /dev/null @@ -1,1087 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Token -open Parser_env -open Flow_ast -module SMap = Map.Make (String) -open Parser_common -open Comment_attachment - -(* A module for parsing various object related things, like object literals - * and classes *) - -module type OBJECT = sig - val key : ?class_body:bool -> env -> Loc.t * (Loc.t, Loc.t) Ast.Expression.Object.Property.key - val _initializer : env -> Loc.t * (Loc.t, Loc.t) Ast.Expression.Object.t * pattern_errors - - val class_declaration : - env -> (Loc.t, Loc.t) Ast.Class.Decorator.t list -> (Loc.t, Loc.t) Ast.Statement.t - - val class_expression : env -> (Loc.t, Loc.t) Ast.Expression.t - val class_implements : env -> attach_leading:bool -> (Loc.t, Loc.t) Ast.Class.Implements.t - val decorator_list : env -> (Loc.t, Loc.t) Ast.Class.Decorator.t list -end - -module Object - (Parse : Parser_common.PARSER) - (Type : Type_parser.TYPE) - (Declaration : Declaration_parser.DECLARATION) - (Expression : Expression_parser.EXPRESSION) - (Pattern_cover : Pattern_cover.COVER) : OBJECT = struct - let decorator_list = - let expression env = - let expression = Expression.left_hand_side env in - let { remove_trailing; _ } = - if Peek.is_line_terminator env then - trailing_and_remover_after_last_line env - else - trailing_and_remover_after_last_loc env - in - remove_trailing expression (fun remover expression -> remover#expression expression) - in - let decorator env = - let leading = Peek.comments env in - Eat.token env; - { - Ast.Class.Decorator.expression = expression env; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - in - let rec decorator_list_helper env decorators = - match Peek.token env with - | T_AT -> decorator_list_helper env (with_loc decorator env :: decorators) - | _ -> decorators - in - fun env -> - if (parse_options env).esproposal_decorators then - List.rev (decorator_list_helper env []) - else - [] - - let key ?(class_body = false) env = - let open Ast.Expression.Object.Property in - let leading = Peek.comments env in - let tkn = Peek.token env in - match tkn with - | T_STRING (loc, value, raw, octal) -> - if octal then strict_error env Parse_error.StrictOctalLiteral; - Expect.token env (T_STRING (loc, value, raw, octal)); - let value = Literal.String value in - let trailing = Eat.trailing_comments env in - ( loc, - Literal - ( loc, - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - ) - | T_NUMBER { kind; raw } -> - let loc = Peek.loc env in - let value = Expression.number env kind raw in - let value = Literal.Number value in - let trailing = Eat.trailing_comments env in - ( loc, - Literal - ( loc, - { Literal.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - ) - | T_LBRACKET -> - let (loc, key) = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LBRACKET; - let expr = Parse.assignment (env |> with_no_in false) in - Expect.token env T_RBRACKET; - let trailing = Eat.trailing_comments env in - { - ComputedKey.expression = expr; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - in - (loc, Ast.Expression.Object.Property.Computed (loc, key)) - | T_POUND when class_body -> - let ((loc, { PrivateName.name; _ }) as id) = private_identifier env in - add_declared_private env name; - (loc, PrivateName id) - | T_POUND -> - let (loc, id) = - with_loc - (fun env -> - Eat.token env; - Identifier (identifier_name env)) - env - in - error_at env (loc, Parse_error.PrivateNotInClass); - (loc, id) - | _ -> - let ((loc, _) as id) = identifier_name env in - (loc, Identifier id) - - let getter_or_setter env ~in_class_body is_getter = - (* this is a getter or setter, it cannot be async *) - let async = false in - let (generator, leading) = Declaration.generator env in - let (key_loc, key) = key ~class_body:in_class_body env in - let key = object_key_remove_trailing env key in - let value = - with_loc - (fun env -> - (* #sec-function-definitions-static-semantics-early-errors *) - let env = env |> with_allow_super Super_prop in - let (sig_loc, (tparams, params, return)) = - with_loc - (fun env -> - (* It's not clear how type params on getters & setters would make sense - * in Flow's type system. Since this is a Flow syntax extension, we might - * as well disallow it until we need it *) - let tparams = None in - let params = - let params = Declaration.function_params ~await:false ~yield:false env in - if Peek.token env = T_COLON then - params - else - function_params_remove_trailing env params - in - begin - match (is_getter, params) with - | (true, (_, { Ast.Function.Params.this_ = Some _; _ })) -> - error_at env (key_loc, Parse_error.GetterMayNotHaveThisParam) - | (false, (_, { Ast.Function.Params.this_ = Some _; _ })) -> - error_at env (key_loc, Parse_error.SetterMayNotHaveThisParam) - | ( true, - ( _, - { Ast.Function.Params.params = []; rest = None; this_ = None; comments = _ } - ) - ) -> - () - | (false, (_, { Ast.Function.Params.rest = Some _; _ })) -> - (* rest params don't make sense on a setter *) - error_at env (key_loc, Parse_error.SetterArity) - | ( false, - ( _, - { - Ast.Function.Params.params = [_]; - rest = None; - this_ = None; - comments = _; - } - ) - ) -> - () - | (true, _) -> error_at env (key_loc, Parse_error.GetterArity) - | (false, _) -> error_at env (key_loc, Parse_error.SetterArity) - end; - let return = type_annotation_hint_remove_trailing env (Type.annotation_opt env) in - (tparams, params, return)) - env - in - let simple_params = is_simple_parameter_list params in - let (body, contains_use_strict) = - Declaration.function_body env ~async ~generator ~expression:false ~simple_params - in - Declaration.strict_post_check env ~contains_use_strict None params; - { - Function.id = None; - params; - body; - generator; - async; - predicate = None; - (* setters/getter are not predicates *) - return; - tparams; - sig_loc; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - in - (key, value) - - let _initializer = - let parse_assignment_cover env = - match Expression.assignment_cover env with - | Cover_expr expr -> (expr, Pattern_cover.empty_errors) - | Cover_patt (expr, errs) -> (expr, errs) - in - let get env start_loc leading = - let (loc, (key, value)) = - with_loc ~start_loc (fun env -> getter_or_setter env ~in_class_body:false true) env - in - let open Ast.Expression.Object in - Property - (loc, Property.Get { key; value; comments = Flow_ast_utils.mk_comments_opt ~leading () }) - in - let set env start_loc leading = - let (loc, (key, value)) = - with_loc ~start_loc (fun env -> getter_or_setter env ~in_class_body:false false) env - in - let open Ast.Expression.Object in - Property - (loc, Property.Set { key; value; comments = Flow_ast_utils.mk_comments_opt ~leading () }) - in - (* #prod-PropertyDefinition *) - let init = - let open Ast.Expression.Object.Property in - (* #prod-IdentifierReference *) - let parse_shorthand env key = - match key with - | Literal (loc, lit) -> - error_at env (loc, Parse_error.LiteralShorthandProperty); - (loc, Ast.Expression.Literal lit) - | Identifier ((loc, { Identifier.name; comments = _ }) as id) -> - (* #sec-identifiers-static-semantics-early-errors *) - if is_reserved name && name <> "yield" && name <> "await" then - (* it is a syntax error if `name` is a reserved word other than await or yield *) - error_at env (loc, Parse_error.UnexpectedReserved) - else if is_strict_reserved name then - (* it is a syntax error if `name` is a strict reserved word, in strict mode *) - strict_error_at env (loc, Parse_error.StrictReservedWord); - (loc, Ast.Expression.Identifier id) - | PrivateName _ -> failwith "Internal Error: private name found in object props" - | Computed (_, { ComputedKey.expression = expr; comments = _ }) -> - error_at env (fst expr, Parse_error.ComputedShorthandProperty); - expr - in - (* #prod-MethodDefinition *) - let parse_method ~async ~generator ~leading = - with_loc (fun env -> - (* #sec-function-definitions-static-semantics-early-errors *) - let env = env |> with_allow_super Super_prop in - let (sig_loc, (tparams, params, return)) = - with_loc - (fun env -> - let tparams = type_params_remove_trailing env (Type.type_params env) in - let params = - let (yield, await) = - match (async, generator) with - | (true, true) -> - (true, true) (* proposal-async-iteration/#prod-AsyncGeneratorMethod *) - | (true, false) -> (false, allow_await env) (* #prod-AsyncMethod *) - | (false, true) -> (true, false) (* #prod-GeneratorMethod *) - | (false, false) -> (false, false) - (* #prod-MethodDefinition *) - in - let params = Declaration.function_params ~await ~yield env in - if Peek.token env = T_COLON then - params - else - function_params_remove_trailing env params - in - let return = type_annotation_hint_remove_trailing env (Type.annotation_opt env) in - (tparams, params, return)) - env - in - let simple_params = is_simple_parameter_list params in - let (body, contains_use_strict) = - Declaration.function_body env ~async ~generator ~expression:false ~simple_params - in - Declaration.strict_post_check env ~contains_use_strict None params; - { - Function.id = None; - params; - body; - generator; - async; - (* TODO: add support for object method predicates *) - predicate = None; - return; - tparams; - sig_loc; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - in - (* PropertyName `:` AssignmentExpression *) - let parse_value env = - Expect.token env T_COLON; - parse_assignment_cover env - in - (* #prod-CoverInitializedName *) - let parse_assignment_pattern ~key env = - let open Ast.Expression.Object in - match key with - | Property.Identifier id -> - let assignment_loc = Peek.loc env in - let ast = - with_loc - ~start_loc:(fst id) - (fun env -> - let leading = Peek.comments env in - Expect.token env T_ASSIGN; - let trailing = Eat.trailing_comments env in - let left = Parse.pattern_from_expr env (fst id, Ast.Expression.Identifier id) in - let right = Parse.assignment env in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - Ast.Expression.Assignment - { Ast.Expression.Assignment.operator = None; left; right; comments }) - env - in - let errs = - { - if_expr = [(assignment_loc, Parse_error.Unexpected (Token.quote_token_value "="))]; - if_patt = []; - } - in - (ast, errs) - | Property.Literal _ - | Property.PrivateName _ - | Property.Computed _ -> - parse_value env - in - let parse_init ~key ~async ~generator ~leading env = - if async || generator then - let key = object_key_remove_trailing env key in - (* the `async` and `*` modifiers are only valid on methods *) - let value = parse_method env ~async ~generator ~leading in - let prop = Method { key; value } in - (prop, Pattern_cover.empty_errors) - else - match Peek.token env with - | T_RCURLY - | T_COMMA -> - let value = parse_shorthand env key in - let prop = Init { key; value; shorthand = true } in - (prop, Pattern_cover.empty_errors) - | T_LESS_THAN - | T_LPAREN -> - let key = object_key_remove_trailing env key in - let value = parse_method env ~async ~generator ~leading in - let prop = Method { key; value } in - (prop, Pattern_cover.empty_errors) - | T_ASSIGN -> - let (value, errs) = parse_assignment_pattern ~key env in - let prop = Init { key; value; shorthand = true } in - (prop, errs) - | T_COLON -> - let (value, errs) = parse_value env in - let prop = Init { key; value; shorthand = false } in - (prop, errs) - | _ -> - (* error. we recover by treating it as a shorthand property so as to not - consume any more tokens and make the error worse. we don't error here - because we'll expect a comma before the next token. *) - let value = parse_shorthand env key in - let prop = Init { key; value; shorthand = true } in - (prop, Pattern_cover.empty_errors) - in - fun env start_loc key async generator leading -> - let (loc, (prop, errs)) = - with_loc ~start_loc (parse_init ~key ~async ~generator ~leading) env - in - (Ast.Expression.Object.Property (loc, prop), errs) - in - let property env = - let open Ast.Expression.Object in - if Peek.token env = T_ELLIPSIS then - (* Spread property *) - let leading = Peek.comments env in - let (loc, (argument, errs)) = - with_loc - (fun env -> - Expect.token env T_ELLIPSIS; - parse_assignment_cover env) - env - in - ( SpreadProperty - (loc, { SpreadProperty.argument; comments = Flow_ast_utils.mk_comments_opt ~leading () }), - errs - ) - else - let start_loc = Peek.loc env in - let (async, leading_async) = - match Peek.ith_token ~i:1 env with - | T_ASSIGN - (* { async = true } (destructuring) *) - | T_COLON - (* { async: true } *) - | T_LESS_THAN - (* { async() {} } *) - | T_LPAREN - (* { async() {} } *) - | T_COMMA - (* { async, other, shorthand } *) - | T_RCURLY (* { async } *) -> - (false, []) - | _ -> Declaration.async env - in - let (generator, leading_generator) = Declaration.generator env in - let leading = leading_async @ leading_generator in - match (async, generator, Peek.token env) with - | (false, false, T_IDENTIFIER { raw = "get"; _ }) -> - let leading = Peek.comments env in - let (_, key) = key env in - begin - match Peek.token env with - | T_ASSIGN - | T_COLON - | T_LESS_THAN - | T_LPAREN - | T_COMMA - | T_RCURLY -> - init env start_loc key false false [] - | _ -> - ignore (Comment_attachment.object_key_remove_trailing env key); - (get env start_loc leading, Pattern_cover.empty_errors) - end - | (false, false, T_IDENTIFIER { raw = "set"; _ }) -> - let leading = Peek.comments env in - let (_, key) = key env in - begin - match Peek.token env with - | T_ASSIGN - | T_COLON - | T_LESS_THAN - | T_LPAREN - | T_COMMA - | T_RCURLY -> - init env start_loc key false false [] - | _ -> - ignore (Comment_attachment.object_key_remove_trailing env key); - (set env start_loc leading, Pattern_cover.empty_errors) - end - | (async, generator, _) -> - let (_, key) = key env in - init env start_loc key async generator leading - in - let rec properties env ~rest_trailing_comma (props, errs) = - match Peek.token env with - | T_EOF - | T_RCURLY -> - let errs = - match rest_trailing_comma with - | Some loc -> - { errs with if_patt = (loc, Parse_error.TrailingCommaAfterRestElement) :: errs.if_patt } - | None -> errs - in - (List.rev props, Pattern_cover.rev_errors errs) - | _ -> - let (prop, new_errs) = property env in - let rest_trailing_comma = - match prop with - | Ast.Expression.Object.SpreadProperty _ when Peek.token env = T_COMMA -> - Some (Peek.loc env) - | _ -> None - in - let errs = Pattern_cover.rev_append_errors new_errs errs in - let errs = - match Peek.token env with - | T_RCURLY - | T_EOF -> - errs - | T_COMMA -> - Eat.token env; - errs - | _ -> - (* we could use [Expect.error env T_COMMA], but we're in a weird - cover grammar situation where we're storing errors in - [Pattern_cover]. if we used [Expect.error], the errors would - end up out of order. *) - let err = Expect.get_error env T_COMMA in - (* if the unexpected token is a semicolon, consume it to aid - recovery. using a semicolon instead of a comma is a common - mistake. *) - let _ = Eat.maybe env T_SEMICOLON in - Pattern_cover.cons_error err errs - in - properties env ~rest_trailing_comma (prop :: props, errs) - in - fun env -> - let (loc, (expr, errs)) = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LCURLY; - let (props, errs) = - properties env ~rest_trailing_comma:None ([], Pattern_cover.empty_errors) - in - let internal = Peek.comments env in - Expect.token env T_RCURLY; - let trailing = Eat.trailing_comments env in - ( { - Ast.Expression.Object.properties = props; - comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - }, - errs - )) - env - in - (loc, expr, errs) - - let check_property_name env loc name static = - if String.equal name "constructor" || (String.equal name "prototype" && static) then - error_at - env - (loc, Parse_error.InvalidClassMemberName { name; static; method_ = false; private_ = false }) - - let check_private_names - env seen_names private_name (kind : [ `Method | `Field | `Getter | `Setter ]) = - let (loc, { PrivateName.name; comments = _ }) = private_name in - if String.equal name "constructor" then - let () = - error_at - env - ( loc, - Parse_error.InvalidClassMemberName - { name; static = false; method_ = kind = `Method; private_ = true } - ) - in - seen_names - else - match SMap.find_opt name seen_names with - | Some seen -> - begin - match (kind, seen) with - | (`Getter, `Setter) - | (`Setter, `Getter) -> - (* one getter and one setter are allowed as long as it's not used as a field *) - () - | _ -> error_at env (loc, Parse_error.DuplicatePrivateFields name) - end; - SMap.add name `Field seen_names - | None -> SMap.add name kind seen_names - - let class_implements env ~attach_leading = - let rec interfaces env acc = - let interface = - with_loc - (fun env -> - let id = - let id = Type.type_identifier env in - if Peek.token env <> T_LESS_THAN then - id - else - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing id (fun remover id -> remover#identifier id) - in - let targs = Type.type_args env in - { Ast.Class.Implements.Interface.id; targs }) - env - in - let acc = interface :: acc in - match Peek.token env with - | T_COMMA -> - Expect.token env T_COMMA; - interfaces env acc - | _ -> List.rev acc - in - with_loc - (fun env -> - let leading = - if attach_leading then - Peek.comments env - else - [] - in - Expect.token env T_IMPLEMENTS; - let interfaces = interfaces env [] in - { Ast.Class.Implements.interfaces; comments = Flow_ast_utils.mk_comments_opt ~leading () }) - env - - let class_extends ~leading = - with_loc (fun env -> - let expr = - let expr = Expression.left_hand_side (env |> with_allow_yield false) in - if Peek.token env <> T_LESS_THAN then - expr - else - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing expr (fun remover expr -> remover#expression expr) - in - let targs = Type.type_args env in - { Class.Extends.expr; targs; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - - (* https://tc39.es/ecma262/#prod-ClassHeritage *) - let class_heritage env = - let extends = - let leading = Peek.comments env in - if Eat.maybe env T_EXTENDS then - let (loc, extends) = class_extends ~leading env in - let { remove_trailing; _ } = trailing_and_remover env in - Some - (loc, remove_trailing extends (fun remover extends -> remover#class_extends loc extends)) - else - None - in - let implements = - if Peek.token env = T_IMPLEMENTS then ( - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeInterface; - Some (class_implements_remove_trailing env (class_implements env ~attach_leading:true)) - ) else - None - in - (extends, implements) - - (* In the ES6 draft, all elements are methods. No properties (though there - * are getter and setters allowed *) - let class_element = - let get env start_loc decorators static leading = - let (loc, (key, value)) = - with_loc ~start_loc (fun env -> getter_or_setter env ~in_class_body:true true) env - in - let open Ast.Class in - Body.Method - ( loc, - { - Method.key; - value; - kind = Method.Get; - static; - decorators; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - in - let set env start_loc decorators static leading = - let (loc, (key, value)) = - with_loc ~start_loc (fun env -> getter_or_setter env ~in_class_body:true false) env - in - let open Ast.Class in - Body.Method - ( loc, - { - Method.key; - value; - kind = Method.Set; - static; - decorators; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - in - let error_unsupported_variance env = function - | Some (loc, _) -> error_at env (loc, Parse_error.UnexpectedVariance) - | None -> () - (* Class property with annotation *) - in - let error_unsupported_declare env = function - | Some loc -> error_at env (loc, Parse_error.DeclareClassElement) - | None -> () - in - let property_end_and_semicolon env key annot value = - match Peek.token env with - | T_LBRACKET - | T_LPAREN -> - error_unexpected env; - (key, annot, value, []) - | T_SEMICOLON -> - Eat.token env; - let trailing = - match Peek.token env with - | T_EOF - | T_RCURLY -> - Eat.trailing_comments env - | _ when Peek.is_line_terminator env -> Eat.comments_until_next_line env - | _ -> [] - in - (key, annot, value, trailing) - | _ -> - let remover = - match Peek.token env with - | T_EOF - | T_RCURLY -> - { trailing = []; remove_trailing = (fun x _ -> x) } - | _ when Peek.is_line_terminator env -> - Comment_attachment.trailing_and_remover_after_last_line env - | _ -> Comment_attachment.trailing_and_remover_after_last_loc env - in - (* Remove trailing comments from the last node in this property *) - let (key, annot, value) = - match (annot, value) with - (* prop = init *) - | (_, Class.Property.Initialized expr) -> - ( key, - annot, - Class.Property.Initialized - (remover.remove_trailing expr (fun remover expr -> remover#expression expr)) - ) - (* prop: annot *) - | (Ast.Type.Available annot, _) -> - ( key, - Ast.Type.Available - (remover.remove_trailing annot (fun remover annot -> remover#type_annotation annot)), - value - ) - (* prop *) - | _ -> - (remover.remove_trailing key (fun remover key -> remover#object_key key), annot, value) - in - (key, annot, value, []) - in - let property env start_loc key static declare variance leading = - let (loc, (key, annot, value, comments)) = - with_loc - ~start_loc - (fun env -> - let annot = Type.annotation_opt env in - let value = - match (declare, Peek.token env) with - | (None, T_ASSIGN) -> - Eat.token env; - Ast.Class.Property.Initialized - (Parse.expression (env |> with_allow_super Super_prop)) - | (Some _, T_ASSIGN) -> - error env Parse_error.DeclareClassFieldInitializer; - Eat.token env; - Ast.Class.Property.Declared - | (None, _) -> Ast.Class.Property.Uninitialized - | (Some _, _) -> Ast.Class.Property.Declared - in - let (key, annot, value, trailing) = property_end_and_semicolon env key annot value in - (key, annot, value, Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - env - in - match key with - | Ast.Expression.Object.Property.PrivateName private_name -> - let open Ast.Class in - Body.PrivateField - (loc, { PrivateField.key = private_name; value; annot; static; variance; comments }) - | _ -> - Ast.Class.(Body.Property (loc, { Property.key; value; annot; static; variance; comments })) - in - let is_asi env = - match Peek.token env with - | T_LESS_THAN -> false - | T_LPAREN -> false - | _ when Peek.is_implicit_semicolon env -> true - | _ -> false - in - let rec init env start_loc decorators key ~async ~generator ~static ~declare variance leading = - match Peek.token env with - | T_COLON - | T_ASSIGN - | T_SEMICOLON - | T_RCURLY - when (not async) && not generator -> - property env start_loc key static declare variance leading - | T_PLING -> - (* TODO: add support for optional class properties *) - error_unexpected env; - Eat.token env; - init env start_loc decorators key ~async ~generator ~static ~declare variance leading - | _ when is_asi env -> - (* an uninitialized, unannotated property *) - property env start_loc key static declare variance leading - | _ -> - error_unsupported_declare env declare; - error_unsupported_variance env variance; - let (kind, env) = - match (static, key) with - | ( false, - Ast.Expression.Object.Property.Identifier - (_, { Identifier.name = "constructor"; comments = _ }) - ) - | ( false, - Ast.Expression.Object.Property.Literal - (_, { Literal.value = Literal.String "constructor"; _ }) - ) -> - (Ast.Class.Method.Constructor, env |> with_allow_super Super_prop_or_call) - | _ -> (Ast.Class.Method.Method, env |> with_allow_super Super_prop) - in - let key = object_key_remove_trailing env key in - let value = - with_loc - (fun env -> - let (sig_loc, (tparams, params, return)) = - with_loc - (fun env -> - let tparams = type_params_remove_trailing env (Type.type_params env) in - let params = - let (yield, await) = - match (async, generator) with - | (true, true) -> - (true, true) (* proposal-async-iteration/#prod-AsyncGeneratorMethod *) - | (true, false) -> (false, allow_await env) (* #prod-AsyncMethod *) - | (false, true) -> (true, false) (* #prod-GeneratorMethod *) - | (false, false) -> (false, false) - (* #prod-MethodDefinition *) - in - let params = Declaration.function_params ~await ~yield env in - let params = - if Peek.token env = T_COLON then - params - else - function_params_remove_trailing env params - in - Ast.Function.Params.( - match params with - | (loc, ({ this_ = Some (this_loc, _); _ } as params)) - when kind = Ast.Class.Method.Constructor -> - (* Disallow this param annotations for constructors *) - error_at env (this_loc, Parse_error.ThisParamBannedInConstructor); - (loc, { params with this_ = None }) - | params -> params - ) - in - let return = - type_annotation_hint_remove_trailing env (Type.annotation_opt env) - in - (tparams, params, return)) - env - in - let simple_params = is_simple_parameter_list params in - let (body, contains_use_strict) = - Declaration.function_body env ~async ~generator ~expression:false ~simple_params - in - Declaration.strict_post_check env ~contains_use_strict None params; - { - Function.id = None; - params; - body; - generator; - async; - (* TODO: add support for method predicates *) - predicate = None; - return; - tparams; - sig_loc; - comments = None; - }) - env - in - let open Ast.Class in - Body.Method - ( Loc.btwn start_loc (fst value), - { - Method.key; - value; - kind; - static; - decorators; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - in - let ith_implies_identifier ~i env = - match Peek.ith_token ~i env with - | T_LESS_THAN - | T_COLON - | T_ASSIGN - | T_SEMICOLON - | T_LPAREN - | T_RCURLY -> - true - | _ -> false - in - let implies_identifier = ith_implies_identifier ~i:0 in - fun env -> - let start_loc = Peek.loc env in - let decorators = decorator_list env in - let (declare, leading_declare) = - match Peek.token env with - | T_DECLARE when not (ith_implies_identifier ~i:1 env) -> - let ret = Some (Peek.loc env) in - let leading = Peek.comments env in - Eat.token env; - (ret, leading) - | _ -> (None, []) - in - let static = - Peek.ith_token ~i:1 env <> T_LPAREN - && Peek.ith_token ~i:1 env <> T_LESS_THAN - && Peek.token env = T_STATIC - in - let leading_static = - if static then ( - let leading = Peek.comments env in - Eat.token env; - leading - ) else - [] - in - let async = - Peek.token env = T_ASYNC - && (not (ith_implies_identifier ~i:1 env)) - && not (Peek.ith_is_line_terminator ~i:1 env) - in - (* consume `async` *) - let leading_async = - if async then ( - let leading = Peek.comments env in - Eat.token env; - leading - ) else - [] - in - let (generator, leading_generator) = Declaration.generator env in - let variance = Declaration.variance env async generator in - let (generator, leading_generator) = - match (generator, variance) with - | (false, Some _) -> Declaration.generator env - | _ -> (generator, leading_generator) - in - let leading = - List.concat [leading_declare; leading_static; leading_async; leading_generator] - in - match (async, generator, Peek.token env) with - | (false, false, T_IDENTIFIER { raw = "get"; _ }) -> - let leading_get = Peek.comments env in - let (_, key) = key ~class_body:true env in - if implies_identifier env then - init env start_loc decorators key ~async ~generator ~static ~declare variance leading - else ( - error_unsupported_declare env declare; - error_unsupported_variance env variance; - ignore (object_key_remove_trailing env key); - get env start_loc decorators static (leading @ leading_get) - ) - | (false, false, T_IDENTIFIER { raw = "set"; _ }) -> - let leading_set = Peek.comments env in - let (_, key) = key ~class_body:true env in - if implies_identifier env then - init env start_loc decorators key ~async ~generator ~static ~declare variance leading - else ( - error_unsupported_declare env declare; - error_unsupported_variance env variance; - ignore (object_key_remove_trailing env key); - set env start_loc decorators static (leading @ leading_set) - ) - | (_, _, _) -> - let (_, key) = key ~class_body:true env in - init env start_loc decorators key ~async ~generator ~static ~declare variance leading - - let class_body = - let rec elements env seen_constructor private_names acc = - match Peek.token env with - | T_EOF - | T_RCURLY -> - List.rev acc - | T_SEMICOLON -> - (* Skip empty elements *) - Expect.token env T_SEMICOLON; - elements env seen_constructor private_names acc - | _ -> - let element = class_element env in - let (seen_constructor', private_names') = - match element with - | Ast.Class.Body.Method (loc, m) -> - let open Ast.Class.Method in - (match m.kind with - | Constructor -> - if m.static then - (seen_constructor, private_names) - else ( - if seen_constructor then error_at env (loc, Parse_error.DuplicateConstructor); - (true, private_names) - ) - | Method -> - let private_names = - match m.key with - | Ast.Expression.Object.Property.PrivateName name -> - check_private_names env private_names name `Method - | _ -> private_names - in - (seen_constructor, private_names) - | Get -> - let open Ast.Expression.Object.Property in - let private_names = - match m.key with - | PrivateName name -> check_private_names env private_names name `Getter - | _ -> private_names - in - (seen_constructor, private_names) - | Set -> - let open Ast.Expression.Object.Property in - let private_names = - match m.key with - | PrivateName name -> check_private_names env private_names name `Setter - | _ -> private_names - in - (seen_constructor, private_names)) - | Ast.Class.Body.Property (_, { Ast.Class.Property.key; static; _ }) -> - let open Ast.Expression.Object.Property in - begin - match key with - | Identifier (loc, { Identifier.name; comments = _ }) - | Literal (loc, { Literal.value = Literal.String name; _ }) -> - check_property_name env loc name static - | Literal _ - | Computed _ -> - () - | PrivateName _ -> - failwith "unexpected PrivateName in Property, expected a PrivateField" - end; - (seen_constructor, private_names) - | Ast.Class.Body.PrivateField (_, { Ast.Class.PrivateField.key; _ }) -> - let private_names = check_private_names env private_names key `Field in - (seen_constructor, private_names) - in - elements env seen_constructor' private_names' (element :: acc) - in - fun ~expression env -> - with_loc - (fun env -> - let leading = Peek.comments env in - if Eat.maybe env T_LCURLY then ( - enter_class env; - let body = elements env false SMap.empty [] in - exit_class env; - Expect.token env T_RCURLY; - let trailing = - match (expression, Peek.token env) with - | (true, _) - | (_, (T_RCURLY | T_EOF)) -> - Eat.trailing_comments env - | _ when Peek.is_line_terminator env -> Eat.comments_until_next_line env - | _ -> [] - in - { Ast.Class.Body.body; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) else ( - Expect.error env T_LCURLY; - { Ast.Class.Body.body = []; comments = None } - )) - env - - let _class ?(decorators = []) env ~optional_id ~expression = - (* 10.2.1 says all parts of a class definition are strict *) - let env = env |> with_strict true in - let decorators = decorators @ decorator_list env in - let leading = Peek.comments env in - Expect.token env T_CLASS; - let id = - let tmp_env = env |> with_no_let true in - match (optional_id, Peek.token tmp_env) with - | (true, (T_EXTENDS | T_IMPLEMENTS | T_LESS_THAN | T_LCURLY)) -> None - | _ when Peek.is_identifier env -> - let id = Parse.identifier tmp_env in - let { remove_trailing; _ } = trailing_and_remover env in - let id = remove_trailing id (fun remover id -> remover#identifier id) in - Some id - | _ -> - (* error, but don't consume a token like Parse.identifier does. this helps - with recovery, and the parser won't get stuck because we consumed the - `class` token above. *) - error_nameless_declaration env "class"; - Some (Peek.loc env, { Identifier.name = ""; comments = None }) - in - let tparams = - match Type.type_params env with - | None -> None - | Some tparams -> - let { remove_trailing; _ } = trailing_and_remover env in - Some (remove_trailing tparams (fun remover tparams -> remover#type_params tparams)) - in - let (extends, implements) = class_heritage env in - let body = class_body env ~expression in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - { Class.id; body; tparams; extends; implements; class_decorators = decorators; comments } - - let class_declaration env decorators = - with_loc - (fun env -> - let optional_id = in_export_default env in - Ast.Statement.ClassDeclaration (_class env ~decorators ~optional_id ~expression:false)) - env - - let class_expression = - with_loc (fun env -> Ast.Expression.Class (_class env ~optional_id:true ~expression:true)) -end diff --git a/jscomp/js_parser/parse_error.ml b/jscomp/js_parser/parse_error.ml deleted file mode 100644 index 9338148..0000000 --- a/jscomp/js_parser/parse_error.ml +++ /dev/null @@ -1,941 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) -open Primitive_deriving - -type t = - | EnumBooleanMemberNotInitialized of { - enum_name: string; - member_name: string; - } - | EnumDuplicateMemberName of { - enum_name: string; - member_name: string; - } - | EnumInconsistentMemberValues of { enum_name: string } - | EnumInvalidExplicitType of { - enum_name: string; - supplied_type: string option; - } - | EnumInvalidExport - | EnumInvalidInitializerSeparator of { member_name: string } - | EnumInvalidMemberInitializer of { - enum_name: string; - explicit_type: Enum_common.explicit_type option; - member_name: string; - } - | EnumInvalidMemberName of { - enum_name: string; - member_name: string; - } - | EnumInvalidMemberSeparator - | EnumInvalidEllipsis of { trailing_comma: bool } - | EnumNumberMemberNotInitialized of { - enum_name: string; - member_name: string; - } - | EnumStringMemberInconsistentlyInitailized of { enum_name: string } - | Unexpected of string - | UnexpectedWithExpected of string * string - | UnexpectedTokenWithSuggestion of string * string - | UnexpectedReserved - | UnexpectedReservedType - | UnexpectedSuper - | UnexpectedSuperCall - | UnexpectedEOS - | UnexpectedVariance - | UnexpectedStatic - | UnexpectedProto - | UnexpectedTypeAlias - | UnexpectedOpaqueTypeAlias - | UnexpectedTypeAnnotation - | UnexpectedTypeDeclaration - | UnexpectedTypeImport - | UnexpectedTypeExport - | UnexpectedTypeInterface - | UnexpectedSpreadType - | UnexpectedExplicitInexactInObject - | InexactInsideExact - | InexactInsideNonObject - | NewlineAfterThrow - | InvalidFloatBigInt - | InvalidSciBigInt - | InvalidRegExp - | InvalidRegExpFlags of string - | UnterminatedRegExp - | InvalidLHSInAssignment - | InvalidLHSInExponentiation - | InvalidLHSInForIn - | InvalidLHSInForOf - | InvalidIndexedAccess of { has_bracket: bool } - | InvalidOptionalIndexedAccess - | ExpectedPatternFoundExpression - | MultipleDefaultsInSwitch - | NoCatchOrFinally - | UnknownLabel of string - | Redeclaration of string * string - | IllegalContinue - | IllegalBreak - | IllegalReturn - | IllegalUnicodeEscape - | StrictModeWith - | StrictCatchVariable - | StrictVarName - | StrictParamName - | StrictParamDupe - | StrictParamNotSimple - | StrictFunctionName - | StrictOctalLiteral - | StrictNonOctalLiteral - | StrictDelete - | StrictDuplicateProperty - | AccessorDataProperty - | AccessorGetSet - | InvalidTypeof - | StrictLHSAssignment - | StrictLHSPostfix - | StrictLHSPrefix - | StrictReservedWord - | JSXAttributeValueEmptyExpression - | InvalidJSXAttributeValue - | ExpectedJSXClosingTag of string - | NoUninitializedConst - | NoUninitializedDestructuring - | NewlineBeforeArrow - | FunctionAsStatement of { in_strict_mode: bool } - | AsyncFunctionAsStatement - | GeneratorFunctionAsStatement - | AdjacentJSXElements - | ParameterAfterRestParameter - | ElementAfterRestElement - | PropertyAfterRestElement - | DeclareAsync - | DeclareClassElement - | DeclareClassFieldInitializer - | DeclareOpaqueTypeInitializer - | DeclareExportLet - | DeclareExportConst - | DeclareExportType - | DeclareExportInterface - | DuplicateExport of string - | UnsupportedDecorator - | MissingTypeParamDefault - | DuplicateDeclareModuleExports - | AmbiguousDeclareModuleKind - | GetterArity - | SetterArity - | InvalidNonTypeImportInDeclareModule - | ImportTypeShorthandOnlyInPureImport - | ImportSpecifierMissingComma - | ExportSpecifierMissingComma - | MalformedUnicode - | DuplicateConstructor - | DuplicatePrivateFields of string - | InvalidClassMemberName of { - name: string; - static: bool; - method_: bool; - private_: bool; - } - | PrivateDelete - | UnboundPrivate of string - | PrivateNotInClass - | SuperPrivate - | YieldInFormalParameters - | AwaitAsIdentifierReference - | YieldAsIdentifierReference - | AmbiguousLetBracket - | LiteralShorthandProperty - | ComputedShorthandProperty - | MethodInDestructuring - | TrailingCommaAfterRestElement - | OptionalChainNew - | OptionalChainTemplate - | NullishCoalescingUnexpectedLogical of string - | WhitespaceInPrivateName - | ThisParamAnnotationRequired - | ThisParamMustBeFirst - | ThisParamMayNotBeOptional - | GetterMayNotHaveThisParam - | SetterMayNotHaveThisParam - | ThisParamBannedInArrowFunctions - | ThisParamBannedInConstructor -[@@deriving_inline compare] -let _ = fun (_ : t) -> () -let compare = - (fun a__001_ -> - fun b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ - then 0 - else - (match (a__001_, b__002_) with - | (EnumBooleanMemberNotInitialized _a__003_, - EnumBooleanMemberNotInitialized _b__004_) -> - (match compare_string _a__003_.enum_name _b__004_.enum_name - with - | 0 -> - compare_string _a__003_.member_name _b__004_.member_name - | n -> n) - | (EnumBooleanMemberNotInitialized _, _) -> (-1) - | (_, EnumBooleanMemberNotInitialized _) -> 1 - | (EnumDuplicateMemberName _a__005_, EnumDuplicateMemberName - _b__006_) -> - (match compare_string _a__005_.enum_name _b__006_.enum_name - with - | 0 -> - compare_string _a__005_.member_name _b__006_.member_name - | n -> n) - | (EnumDuplicateMemberName _, _) -> (-1) - | (_, EnumDuplicateMemberName _) -> 1 - | (EnumInconsistentMemberValues _a__007_, - EnumInconsistentMemberValues _b__008_) -> - compare_string _a__007_.enum_name _b__008_.enum_name - | (EnumInconsistentMemberValues _, _) -> (-1) - | (_, EnumInconsistentMemberValues _) -> 1 - | (EnumInvalidExplicitType _a__009_, EnumInvalidExplicitType - _b__010_) -> - (match compare_string _a__009_.enum_name _b__010_.enum_name - with - | 0 -> - compare_option compare_string _a__009_.supplied_type - _b__010_.supplied_type - | n -> n) - | (EnumInvalidExplicitType _, _) -> (-1) - | (_, EnumInvalidExplicitType _) -> 1 - | (EnumInvalidExport, EnumInvalidExport) -> 0 - | (EnumInvalidExport, _) -> (-1) - | (_, EnumInvalidExport) -> 1 - | (EnumInvalidInitializerSeparator _a__013_, - EnumInvalidInitializerSeparator _b__014_) -> - compare_string _a__013_.member_name _b__014_.member_name - | (EnumInvalidInitializerSeparator _, _) -> (-1) - | (_, EnumInvalidInitializerSeparator _) -> 1 - | (EnumInvalidMemberInitializer _a__015_, - EnumInvalidMemberInitializer _b__016_) -> - (match compare_string _a__015_.enum_name _b__016_.enum_name - with - | 0 -> - (match compare_option Enum_common.compare_explicit_type - _a__015_.explicit_type _b__016_.explicit_type - with - | 0 -> - compare_string _a__015_.member_name - _b__016_.member_name - | n -> n) - | n -> n) - | (EnumInvalidMemberInitializer _, _) -> (-1) - | (_, EnumInvalidMemberInitializer _) -> 1 - | (EnumInvalidMemberName _a__019_, EnumInvalidMemberName _b__020_) - -> - (match compare_string _a__019_.enum_name _b__020_.enum_name - with - | 0 -> - compare_string _a__019_.member_name _b__020_.member_name - | n -> n) - | (EnumInvalidMemberName _, _) -> (-1) - | (_, EnumInvalidMemberName _) -> 1 - | (EnumInvalidMemberSeparator, EnumInvalidMemberSeparator) -> 0 - | (EnumInvalidMemberSeparator, _) -> (-1) - | (_, EnumInvalidMemberSeparator) -> 1 - | (EnumInvalidEllipsis _a__021_, EnumInvalidEllipsis _b__022_) -> - compare_bool _a__021_.trailing_comma _b__022_.trailing_comma - | (EnumInvalidEllipsis _, _) -> (-1) - | (_, EnumInvalidEllipsis _) -> 1 - | (EnumNumberMemberNotInitialized _a__023_, - EnumNumberMemberNotInitialized _b__024_) -> - (match compare_string _a__023_.enum_name _b__024_.enum_name - with - | 0 -> - compare_string _a__023_.member_name _b__024_.member_name - | n -> n) - | (EnumNumberMemberNotInitialized _, _) -> (-1) - | (_, EnumNumberMemberNotInitialized _) -> 1 - | (EnumStringMemberInconsistentlyInitailized _a__025_, - EnumStringMemberInconsistentlyInitailized _b__026_) -> - compare_string _a__025_.enum_name _b__026_.enum_name - | (EnumStringMemberInconsistentlyInitailized _, _) -> (-1) - | (_, EnumStringMemberInconsistentlyInitailized _) -> 1 - | (Unexpected _a__027_, Unexpected _b__028_) -> - compare_string _a__027_ _b__028_ - | (Unexpected _, _) -> (-1) - | (_, Unexpected _) -> 1 - | (UnexpectedWithExpected (_a__029_, _a__031_), - UnexpectedWithExpected (_b__030_, _b__032_)) -> - (match compare_string _a__029_ _b__030_ with - | 0 -> compare_string _a__031_ _b__032_ - | n -> n) - | (UnexpectedWithExpected _, _) -> (-1) - | (_, UnexpectedWithExpected _) -> 1 - | (UnexpectedTokenWithSuggestion (_a__033_, _a__035_), - UnexpectedTokenWithSuggestion (_b__034_, _b__036_)) -> - (match compare_string _a__033_ _b__034_ with - | 0 -> compare_string _a__035_ _b__036_ - | n -> n) - | (UnexpectedTokenWithSuggestion _, _) -> (-1) - | (_, UnexpectedTokenWithSuggestion _) -> 1 - | (UnexpectedReserved, UnexpectedReserved) -> 0 - | (UnexpectedReserved, _) -> (-1) - | (_, UnexpectedReserved) -> 1 - | (UnexpectedReservedType, UnexpectedReservedType) -> 0 - | (UnexpectedReservedType, _) -> (-1) - | (_, UnexpectedReservedType) -> 1 - | (UnexpectedSuper, UnexpectedSuper) -> 0 - | (UnexpectedSuper, _) -> (-1) - | (_, UnexpectedSuper) -> 1 - | (UnexpectedSuperCall, UnexpectedSuperCall) -> 0 - | (UnexpectedSuperCall, _) -> (-1) - | (_, UnexpectedSuperCall) -> 1 - | (UnexpectedEOS, UnexpectedEOS) -> 0 - | (UnexpectedEOS, _) -> (-1) - | (_, UnexpectedEOS) -> 1 - | (UnexpectedVariance, UnexpectedVariance) -> 0 - | (UnexpectedVariance, _) -> (-1) - | (_, UnexpectedVariance) -> 1 - | (UnexpectedStatic, UnexpectedStatic) -> 0 - | (UnexpectedStatic, _) -> (-1) - | (_, UnexpectedStatic) -> 1 - | (UnexpectedProto, UnexpectedProto) -> 0 - | (UnexpectedProto, _) -> (-1) - | (_, UnexpectedProto) -> 1 - | (UnexpectedTypeAlias, UnexpectedTypeAlias) -> 0 - | (UnexpectedTypeAlias, _) -> (-1) - | (_, UnexpectedTypeAlias) -> 1 - | (UnexpectedOpaqueTypeAlias, UnexpectedOpaqueTypeAlias) -> 0 - | (UnexpectedOpaqueTypeAlias, _) -> (-1) - | (_, UnexpectedOpaqueTypeAlias) -> 1 - | (UnexpectedTypeAnnotation, UnexpectedTypeAnnotation) -> 0 - | (UnexpectedTypeAnnotation, _) -> (-1) - | (_, UnexpectedTypeAnnotation) -> 1 - | (UnexpectedTypeDeclaration, UnexpectedTypeDeclaration) -> 0 - | (UnexpectedTypeDeclaration, _) -> (-1) - | (_, UnexpectedTypeDeclaration) -> 1 - | (UnexpectedTypeImport, UnexpectedTypeImport) -> 0 - | (UnexpectedTypeImport, _) -> (-1) - | (_, UnexpectedTypeImport) -> 1 - | (UnexpectedTypeExport, UnexpectedTypeExport) -> 0 - | (UnexpectedTypeExport, _) -> (-1) - | (_, UnexpectedTypeExport) -> 1 - | (UnexpectedTypeInterface, UnexpectedTypeInterface) -> 0 - | (UnexpectedTypeInterface, _) -> (-1) - | (_, UnexpectedTypeInterface) -> 1 - | (UnexpectedSpreadType, UnexpectedSpreadType) -> 0 - | (UnexpectedSpreadType, _) -> (-1) - | (_, UnexpectedSpreadType) -> 1 - | (UnexpectedExplicitInexactInObject, - UnexpectedExplicitInexactInObject) -> 0 - | (UnexpectedExplicitInexactInObject, _) -> (-1) - | (_, UnexpectedExplicitInexactInObject) -> 1 - | (InexactInsideExact, InexactInsideExact) -> 0 - | (InexactInsideExact, _) -> (-1) - | (_, InexactInsideExact) -> 1 - | (InexactInsideNonObject, InexactInsideNonObject) -> 0 - | (InexactInsideNonObject, _) -> (-1) - | (_, InexactInsideNonObject) -> 1 - | (NewlineAfterThrow, NewlineAfterThrow) -> 0 - | (NewlineAfterThrow, _) -> (-1) - | (_, NewlineAfterThrow) -> 1 - | (InvalidFloatBigInt, InvalidFloatBigInt) -> 0 - | (InvalidFloatBigInt, _) -> (-1) - | (_, InvalidFloatBigInt) -> 1 - | (InvalidSciBigInt, InvalidSciBigInt) -> 0 - | (InvalidSciBigInt, _) -> (-1) - | (_, InvalidSciBigInt) -> 1 - | (InvalidRegExp, InvalidRegExp) -> 0 - | (InvalidRegExp, _) -> (-1) - | (_, InvalidRegExp) -> 1 - | (InvalidRegExpFlags _a__037_, InvalidRegExpFlags _b__038_) -> - compare_string _a__037_ _b__038_ - | (InvalidRegExpFlags _, _) -> (-1) - | (_, InvalidRegExpFlags _) -> 1 - | (UnterminatedRegExp, UnterminatedRegExp) -> 0 - | (UnterminatedRegExp, _) -> (-1) - | (_, UnterminatedRegExp) -> 1 - | (InvalidLHSInAssignment, InvalidLHSInAssignment) -> 0 - | (InvalidLHSInAssignment, _) -> (-1) - | (_, InvalidLHSInAssignment) -> 1 - | (InvalidLHSInExponentiation, InvalidLHSInExponentiation) -> 0 - | (InvalidLHSInExponentiation, _) -> (-1) - | (_, InvalidLHSInExponentiation) -> 1 - | (InvalidLHSInForIn, InvalidLHSInForIn) -> 0 - | (InvalidLHSInForIn, _) -> (-1) - | (_, InvalidLHSInForIn) -> 1 - | (InvalidLHSInForOf, InvalidLHSInForOf) -> 0 - | (InvalidLHSInForOf, _) -> (-1) - | (_, InvalidLHSInForOf) -> 1 - | (InvalidIndexedAccess _a__039_, InvalidIndexedAccess _b__040_) -> - compare_bool _a__039_.has_bracket _b__040_.has_bracket - | (InvalidIndexedAccess _, _) -> (-1) - | (_, InvalidIndexedAccess _) -> 1 - | (InvalidOptionalIndexedAccess, InvalidOptionalIndexedAccess) -> 0 - | (InvalidOptionalIndexedAccess, _) -> (-1) - | (_, InvalidOptionalIndexedAccess) -> 1 - | (ExpectedPatternFoundExpression, ExpectedPatternFoundExpression) - -> 0 - | (ExpectedPatternFoundExpression, _) -> (-1) - | (_, ExpectedPatternFoundExpression) -> 1 - | (MultipleDefaultsInSwitch, MultipleDefaultsInSwitch) -> 0 - | (MultipleDefaultsInSwitch, _) -> (-1) - | (_, MultipleDefaultsInSwitch) -> 1 - | (NoCatchOrFinally, NoCatchOrFinally) -> 0 - | (NoCatchOrFinally, _) -> (-1) - | (_, NoCatchOrFinally) -> 1 - | (UnknownLabel _a__041_, UnknownLabel _b__042_) -> - compare_string _a__041_ _b__042_ - | (UnknownLabel _, _) -> (-1) - | (_, UnknownLabel _) -> 1 - | (Redeclaration (_a__043_, _a__045_), Redeclaration - (_b__044_, _b__046_)) -> - (match compare_string _a__043_ _b__044_ with - | 0 -> compare_string _a__045_ _b__046_ - | n -> n) - | (Redeclaration _, _) -> (-1) - | (_, Redeclaration _) -> 1 - | (IllegalContinue, IllegalContinue) -> 0 - | (IllegalContinue, _) -> (-1) - | (_, IllegalContinue) -> 1 - | (IllegalBreak, IllegalBreak) -> 0 - | (IllegalBreak, _) -> (-1) - | (_, IllegalBreak) -> 1 - | (IllegalReturn, IllegalReturn) -> 0 - | (IllegalReturn, _) -> (-1) - | (_, IllegalReturn) -> 1 - | (IllegalUnicodeEscape, IllegalUnicodeEscape) -> 0 - | (IllegalUnicodeEscape, _) -> (-1) - | (_, IllegalUnicodeEscape) -> 1 - | (StrictModeWith, StrictModeWith) -> 0 - | (StrictModeWith, _) -> (-1) - | (_, StrictModeWith) -> 1 - | (StrictCatchVariable, StrictCatchVariable) -> 0 - | (StrictCatchVariable, _) -> (-1) - | (_, StrictCatchVariable) -> 1 - | (StrictVarName, StrictVarName) -> 0 - | (StrictVarName, _) -> (-1) - | (_, StrictVarName) -> 1 - | (StrictParamName, StrictParamName) -> 0 - | (StrictParamName, _) -> (-1) - | (_, StrictParamName) -> 1 - | (StrictParamDupe, StrictParamDupe) -> 0 - | (StrictParamDupe, _) -> (-1) - | (_, StrictParamDupe) -> 1 - | (StrictParamNotSimple, StrictParamNotSimple) -> 0 - | (StrictParamNotSimple, _) -> (-1) - | (_, StrictParamNotSimple) -> 1 - | (StrictFunctionName, StrictFunctionName) -> 0 - | (StrictFunctionName, _) -> (-1) - | (_, StrictFunctionName) -> 1 - | (StrictOctalLiteral, StrictOctalLiteral) -> 0 - | (StrictOctalLiteral, _) -> (-1) - | (_, StrictOctalLiteral) -> 1 - | (StrictNonOctalLiteral, StrictNonOctalLiteral) -> 0 - | (StrictNonOctalLiteral, _) -> (-1) - | (_, StrictNonOctalLiteral) -> 1 - | (StrictDelete, StrictDelete) -> 0 - | (StrictDelete, _) -> (-1) - | (_, StrictDelete) -> 1 - | (StrictDuplicateProperty, StrictDuplicateProperty) -> 0 - | (StrictDuplicateProperty, _) -> (-1) - | (_, StrictDuplicateProperty) -> 1 - | (AccessorDataProperty, AccessorDataProperty) -> 0 - | (AccessorDataProperty, _) -> (-1) - | (_, AccessorDataProperty) -> 1 - | (AccessorGetSet, AccessorGetSet) -> 0 - | (AccessorGetSet, _) -> (-1) - | (_, AccessorGetSet) -> 1 - | (InvalidTypeof, InvalidTypeof) -> 0 - | (InvalidTypeof, _) -> (-1) - | (_, InvalidTypeof) -> 1 - | (StrictLHSAssignment, StrictLHSAssignment) -> 0 - | (StrictLHSAssignment, _) -> (-1) - | (_, StrictLHSAssignment) -> 1 - | (StrictLHSPostfix, StrictLHSPostfix) -> 0 - | (StrictLHSPostfix, _) -> (-1) - | (_, StrictLHSPostfix) -> 1 - | (StrictLHSPrefix, StrictLHSPrefix) -> 0 - | (StrictLHSPrefix, _) -> (-1) - | (_, StrictLHSPrefix) -> 1 - | (StrictReservedWord, StrictReservedWord) -> 0 - | (StrictReservedWord, _) -> (-1) - | (_, StrictReservedWord) -> 1 - | (JSXAttributeValueEmptyExpression, - JSXAttributeValueEmptyExpression) -> 0 - | (JSXAttributeValueEmptyExpression, _) -> (-1) - | (_, JSXAttributeValueEmptyExpression) -> 1 - | (InvalidJSXAttributeValue, InvalidJSXAttributeValue) -> 0 - | (InvalidJSXAttributeValue, _) -> (-1) - | (_, InvalidJSXAttributeValue) -> 1 - | (ExpectedJSXClosingTag _a__047_, ExpectedJSXClosingTag _b__048_) - -> compare_string _a__047_ _b__048_ - | (ExpectedJSXClosingTag _, _) -> (-1) - | (_, ExpectedJSXClosingTag _) -> 1 - | (NoUninitializedConst, NoUninitializedConst) -> 0 - | (NoUninitializedConst, _) -> (-1) - | (_, NoUninitializedConst) -> 1 - | (NoUninitializedDestructuring, NoUninitializedDestructuring) -> 0 - | (NoUninitializedDestructuring, _) -> (-1) - | (_, NoUninitializedDestructuring) -> 1 - | (NewlineBeforeArrow, NewlineBeforeArrow) -> 0 - | (NewlineBeforeArrow, _) -> (-1) - | (_, NewlineBeforeArrow) -> 1 - | (FunctionAsStatement _a__049_, FunctionAsStatement _b__050_) -> - compare_bool _a__049_.in_strict_mode _b__050_.in_strict_mode - | (FunctionAsStatement _, _) -> (-1) - | (_, FunctionAsStatement _) -> 1 - | (AsyncFunctionAsStatement, AsyncFunctionAsStatement) -> 0 - | (AsyncFunctionAsStatement, _) -> (-1) - | (_, AsyncFunctionAsStatement) -> 1 - | (GeneratorFunctionAsStatement, GeneratorFunctionAsStatement) -> 0 - | (GeneratorFunctionAsStatement, _) -> (-1) - | (_, GeneratorFunctionAsStatement) -> 1 - | (AdjacentJSXElements, AdjacentJSXElements) -> 0 - | (AdjacentJSXElements, _) -> (-1) - | (_, AdjacentJSXElements) -> 1 - | (ParameterAfterRestParameter, ParameterAfterRestParameter) -> 0 - | (ParameterAfterRestParameter, _) -> (-1) - | (_, ParameterAfterRestParameter) -> 1 - | (ElementAfterRestElement, ElementAfterRestElement) -> 0 - | (ElementAfterRestElement, _) -> (-1) - | (_, ElementAfterRestElement) -> 1 - | (PropertyAfterRestElement, PropertyAfterRestElement) -> 0 - | (PropertyAfterRestElement, _) -> (-1) - | (_, PropertyAfterRestElement) -> 1 - | (DeclareAsync, DeclareAsync) -> 0 - | (DeclareAsync, _) -> (-1) - | (_, DeclareAsync) -> 1 - | (DeclareClassElement, DeclareClassElement) -> 0 - | (DeclareClassElement, _) -> (-1) - | (_, DeclareClassElement) -> 1 - | (DeclareClassFieldInitializer, DeclareClassFieldInitializer) -> 0 - | (DeclareClassFieldInitializer, _) -> (-1) - | (_, DeclareClassFieldInitializer) -> 1 - | (DeclareOpaqueTypeInitializer, DeclareOpaqueTypeInitializer) -> 0 - | (DeclareOpaqueTypeInitializer, _) -> (-1) - | (_, DeclareOpaqueTypeInitializer) -> 1 - | (DeclareExportLet, DeclareExportLet) -> 0 - | (DeclareExportLet, _) -> (-1) - | (_, DeclareExportLet) -> 1 - | (DeclareExportConst, DeclareExportConst) -> 0 - | (DeclareExportConst, _) -> (-1) - | (_, DeclareExportConst) -> 1 - | (DeclareExportType, DeclareExportType) -> 0 - | (DeclareExportType, _) -> (-1) - | (_, DeclareExportType) -> 1 - | (DeclareExportInterface, DeclareExportInterface) -> 0 - | (DeclareExportInterface, _) -> (-1) - | (_, DeclareExportInterface) -> 1 - | (DuplicateExport _a__051_, DuplicateExport _b__052_) -> - compare_string _a__051_ _b__052_ - | (DuplicateExport _, _) -> (-1) - | (_, DuplicateExport _) -> 1 - | (UnsupportedDecorator, UnsupportedDecorator) -> 0 - | (UnsupportedDecorator, _) -> (-1) - | (_, UnsupportedDecorator) -> 1 - | (MissingTypeParamDefault, MissingTypeParamDefault) -> 0 - | (MissingTypeParamDefault, _) -> (-1) - | (_, MissingTypeParamDefault) -> 1 - | (DuplicateDeclareModuleExports, DuplicateDeclareModuleExports) -> - 0 - | (DuplicateDeclareModuleExports, _) -> (-1) - | (_, DuplicateDeclareModuleExports) -> 1 - | (AmbiguousDeclareModuleKind, AmbiguousDeclareModuleKind) -> 0 - | (AmbiguousDeclareModuleKind, _) -> (-1) - | (_, AmbiguousDeclareModuleKind) -> 1 - | (GetterArity, GetterArity) -> 0 - | (GetterArity, _) -> (-1) - | (_, GetterArity) -> 1 - | (SetterArity, SetterArity) -> 0 - | (SetterArity, _) -> (-1) - | (_, SetterArity) -> 1 - | (InvalidNonTypeImportInDeclareModule, - InvalidNonTypeImportInDeclareModule) -> 0 - | (InvalidNonTypeImportInDeclareModule, _) -> (-1) - | (_, InvalidNonTypeImportInDeclareModule) -> 1 - | (ImportTypeShorthandOnlyInPureImport, - ImportTypeShorthandOnlyInPureImport) -> 0 - | (ImportTypeShorthandOnlyInPureImport, _) -> (-1) - | (_, ImportTypeShorthandOnlyInPureImport) -> 1 - | (ImportSpecifierMissingComma, ImportSpecifierMissingComma) -> 0 - | (ImportSpecifierMissingComma, _) -> (-1) - | (_, ImportSpecifierMissingComma) -> 1 - | (ExportSpecifierMissingComma, ExportSpecifierMissingComma) -> 0 - | (ExportSpecifierMissingComma, _) -> (-1) - | (_, ExportSpecifierMissingComma) -> 1 - | (MalformedUnicode, MalformedUnicode) -> 0 - | (MalformedUnicode, _) -> (-1) - | (_, MalformedUnicode) -> 1 - | (DuplicateConstructor, DuplicateConstructor) -> 0 - | (DuplicateConstructor, _) -> (-1) - | (_, DuplicateConstructor) -> 1 - | (DuplicatePrivateFields _a__053_, DuplicatePrivateFields - _b__054_) -> compare_string _a__053_ _b__054_ - | (DuplicatePrivateFields _, _) -> (-1) - | (_, DuplicatePrivateFields _) -> 1 - | (InvalidClassMemberName _a__055_, InvalidClassMemberName - _b__056_) -> - (match compare_string _a__055_.name _b__056_.name with - | 0 -> - (match compare_bool _a__055_.static _b__056_.static with - | 0 -> - (match compare_bool _a__055_.method_ _b__056_.method_ - with - | 0 -> - compare_bool _a__055_.private_ _b__056_.private_ - | n -> n) - | n -> n) - | n -> n) - | (InvalidClassMemberName _, _) -> (-1) - | (_, InvalidClassMemberName _) -> 1 - | (PrivateDelete, PrivateDelete) -> 0 - | (PrivateDelete, _) -> (-1) - | (_, PrivateDelete) -> 1 - | (UnboundPrivate _a__057_, UnboundPrivate _b__058_) -> - compare_string _a__057_ _b__058_ - | (UnboundPrivate _, _) -> (-1) - | (_, UnboundPrivate _) -> 1 - | (PrivateNotInClass, PrivateNotInClass) -> 0 - | (PrivateNotInClass, _) -> (-1) - | (_, PrivateNotInClass) -> 1 - | (SuperPrivate, SuperPrivate) -> 0 - | (SuperPrivate, _) -> (-1) - | (_, SuperPrivate) -> 1 - | (YieldInFormalParameters, YieldInFormalParameters) -> 0 - | (YieldInFormalParameters, _) -> (-1) - | (_, YieldInFormalParameters) -> 1 - | (AwaitAsIdentifierReference, AwaitAsIdentifierReference) -> 0 - | (AwaitAsIdentifierReference, _) -> (-1) - | (_, AwaitAsIdentifierReference) -> 1 - | (YieldAsIdentifierReference, YieldAsIdentifierReference) -> 0 - | (YieldAsIdentifierReference, _) -> (-1) - | (_, YieldAsIdentifierReference) -> 1 - | (AmbiguousLetBracket, AmbiguousLetBracket) -> 0 - | (AmbiguousLetBracket, _) -> (-1) - | (_, AmbiguousLetBracket) -> 1 - | (LiteralShorthandProperty, LiteralShorthandProperty) -> 0 - | (LiteralShorthandProperty, _) -> (-1) - | (_, LiteralShorthandProperty) -> 1 - | (ComputedShorthandProperty, ComputedShorthandProperty) -> 0 - | (ComputedShorthandProperty, _) -> (-1) - | (_, ComputedShorthandProperty) -> 1 - | (MethodInDestructuring, MethodInDestructuring) -> 0 - | (MethodInDestructuring, _) -> (-1) - | (_, MethodInDestructuring) -> 1 - | (TrailingCommaAfterRestElement, TrailingCommaAfterRestElement) -> - 0 - | (TrailingCommaAfterRestElement, _) -> (-1) - | (_, TrailingCommaAfterRestElement) -> 1 - | (OptionalChainNew, OptionalChainNew) -> 0 - | (OptionalChainNew, _) -> (-1) - | (_, OptionalChainNew) -> 1 - | (OptionalChainTemplate, OptionalChainTemplate) -> 0 - | (OptionalChainTemplate, _) -> (-1) - | (_, OptionalChainTemplate) -> 1 - | (NullishCoalescingUnexpectedLogical _a__059_, - NullishCoalescingUnexpectedLogical _b__060_) -> - compare_string _a__059_ _b__060_ - | (NullishCoalescingUnexpectedLogical _, _) -> (-1) - | (_, NullishCoalescingUnexpectedLogical _) -> 1 - | (WhitespaceInPrivateName, WhitespaceInPrivateName) -> 0 - | (WhitespaceInPrivateName, _) -> (-1) - | (_, WhitespaceInPrivateName) -> 1 - | (ThisParamAnnotationRequired, ThisParamAnnotationRequired) -> 0 - | (ThisParamAnnotationRequired, _) -> (-1) - | (_, ThisParamAnnotationRequired) -> 1 - | (ThisParamMustBeFirst, ThisParamMustBeFirst) -> 0 - | (ThisParamMustBeFirst, _) -> (-1) - | (_, ThisParamMustBeFirst) -> 1 - | (ThisParamMayNotBeOptional, ThisParamMayNotBeOptional) -> 0 - | (ThisParamMayNotBeOptional, _) -> (-1) - | (_, ThisParamMayNotBeOptional) -> 1 - | (GetterMayNotHaveThisParam, GetterMayNotHaveThisParam) -> 0 - | (GetterMayNotHaveThisParam, _) -> (-1) - | (_, GetterMayNotHaveThisParam) -> 1 - | (SetterMayNotHaveThisParam, SetterMayNotHaveThisParam) -> 0 - | (SetterMayNotHaveThisParam, _) -> (-1) - | (_, SetterMayNotHaveThisParam) -> 1 - | (ThisParamBannedInArrowFunctions, - ThisParamBannedInArrowFunctions) -> 0 - | (ThisParamBannedInArrowFunctions, _) -> (-1) - | (_, ThisParamBannedInArrowFunctions) -> 1 - | (ThisParamBannedInConstructor, ThisParamBannedInConstructor) -> 0) : - t -> t -> int) -let _ = compare -[@@@end] -exception Error of (Loc.t * t) * (Loc.t * t) list - -let error loc e = raise (Error ((loc, e), [])) - -module PP = struct - let error = function - | EnumBooleanMemberNotInitialized { enum_name; member_name } -> - Printf.sprintf - "Boolean enum members need to be initialized. Use either `%s = true,` or `%s = false,` in enum `%s`." - member_name - member_name - enum_name - | EnumDuplicateMemberName { enum_name; member_name } -> - Printf.sprintf - "Enum member names need to be unique, but the name `%s` has already been used before in enum `%s`." - member_name - enum_name - | EnumInconsistentMemberValues { enum_name } -> - Printf.sprintf - "Enum `%s` has inconsistent member initializers. Either use no initializers, or consistently use literals (either booleans, numbers, or strings) for all member initializers." - enum_name - | EnumInvalidExplicitType { enum_name; supplied_type } -> - let suggestion = - Printf.sprintf - "Use one of `boolean`, `number`, `string`, or `symbol` in enum `%s`." - enum_name - in - begin - match supplied_type with - | Some supplied_type -> - Printf.sprintf "Enum type `%s` is not valid. %s" supplied_type suggestion - | None -> Printf.sprintf "Supplied enum type is not valid. %s" suggestion - end - | EnumInvalidExport -> - "Cannot export an enum with `export type`, try `export enum E {}` or `module.exports = E;` instead." - | EnumInvalidInitializerSeparator { member_name } -> - Printf.sprintf - "Enum member names and initializers are separated with `=`. Replace `%s:` with `%s =`." - member_name - member_name - | EnumInvalidMemberInitializer { enum_name; explicit_type; member_name } -> begin - match explicit_type with - | Some (Enum_common.Boolean as explicit_type) - | Some (Enum_common.Number as explicit_type) - | Some (Enum_common.String as explicit_type) -> - let explicit_type_str = Enum_common.string_of_explicit_type explicit_type in - Printf.sprintf - "Enum `%s` has type `%s`, so the initializer of `%s` needs to be a %s literal." - enum_name - explicit_type_str - member_name - explicit_type_str - | Some Enum_common.Symbol -> - Printf.sprintf - "Symbol enum members cannot be initialized. Use `%s,` in enum `%s`." - member_name - enum_name - | None -> - Printf.sprintf - "The enum member initializer for `%s` needs to be a literal (either a boolean, number, or string) in enum `%s`." - member_name - enum_name - end - | EnumInvalidMemberName { enum_name; member_name } -> - (* Based on the error condition, we will only receive member names starting with [a-z] *) - let suggestion = String.capitalize_ascii member_name in - Printf.sprintf - "Enum member names cannot start with lowercase 'a' through 'z'. Instead of using `%s`, consider using `%s`, in enum `%s`." - member_name - suggestion - enum_name - | EnumInvalidMemberSeparator -> "Enum members are separated with `,`. Replace `;` with `,`." - | EnumInvalidEllipsis { trailing_comma } -> - if trailing_comma then - "The `...` must come at the end of the enum body. Remove the trailing comma." - else - "The `...` must come after all enum members. Move it to the end of the enum body." - | EnumNumberMemberNotInitialized { enum_name; member_name } -> - Printf.sprintf - "Number enum members need to be initialized, e.g. `%s = 1,` in enum `%s`." - member_name - enum_name - | EnumStringMemberInconsistentlyInitailized { enum_name } -> - Printf.sprintf - "String enum members need to consistently either all use initializers, or use no initializers, in enum %s." - enum_name - | Unexpected unexpected -> Printf.sprintf "Unexpected %s" unexpected - | UnexpectedWithExpected (unexpected, expected) -> - Printf.sprintf "Unexpected %s, expected %s" unexpected expected - | UnexpectedTokenWithSuggestion (token, suggestion) -> - Printf.sprintf "Unexpected token `%s`. Did you mean `%s`?" token suggestion - | UnexpectedReserved -> "Unexpected reserved word" - | UnexpectedReservedType -> "Unexpected reserved type" - | UnexpectedSuper -> "Unexpected `super` outside of a class method" - | UnexpectedSuperCall -> "`super()` is only valid in a class constructor" - | UnexpectedEOS -> "Unexpected end of input" - | UnexpectedVariance -> "Unexpected variance sigil" - | UnexpectedStatic -> "Unexpected static modifier" - | UnexpectedProto -> "Unexpected proto modifier" - | UnexpectedTypeAlias -> "Type aliases are not allowed in untyped mode" - | UnexpectedOpaqueTypeAlias -> "Opaque type aliases are not allowed in untyped mode" - | UnexpectedTypeAnnotation -> "Type annotations are not allowed in untyped mode" - | UnexpectedTypeDeclaration -> "Type declarations are not allowed in untyped mode" - | UnexpectedTypeImport -> "Type imports are not allowed in untyped mode" - | UnexpectedTypeExport -> "Type exports are not allowed in untyped mode" - | UnexpectedTypeInterface -> "Interfaces are not allowed in untyped mode" - | UnexpectedSpreadType -> "Spreading a type is only allowed inside an object type" - | UnexpectedExplicitInexactInObject -> - "Explicit inexact syntax must come at the end of an object type" - | InexactInsideExact -> - "Explicit inexact syntax cannot appear inside an explicit exact object type" - | InexactInsideNonObject -> "Explicit inexact syntax can only appear inside an object type" - | NewlineAfterThrow -> "Illegal newline after throw" - | InvalidFloatBigInt -> "A bigint literal must be an integer" - | InvalidSciBigInt -> "A bigint literal cannot use exponential notation" - | InvalidRegExp -> "Invalid regular expression" - | InvalidRegExpFlags flags -> "Invalid flags supplied to RegExp constructor '" ^ flags ^ "'" - | UnterminatedRegExp -> "Invalid regular expression: missing /" - | InvalidLHSInAssignment -> "Invalid left-hand side in assignment" - | InvalidLHSInExponentiation -> "Invalid left-hand side in exponentiation expression" - | InvalidLHSInForIn -> "Invalid left-hand side in for-in" - | InvalidLHSInForOf -> "Invalid left-hand side in for-of" - | InvalidIndexedAccess { has_bracket } -> - let msg = - if has_bracket then - "Remove the period." - else - "Indexed access uses bracket notation." - in - Printf.sprintf "Invalid indexed access. %s Use the format `T[K]`." msg - | InvalidOptionalIndexedAccess -> - "Invalid optional indexed access. Indexed access uses bracket notation. Use the format `T?.[K]`." - | ExpectedPatternFoundExpression -> - "Expected an object pattern, array pattern, or an identifier but " - ^ "found an expression instead" - | MultipleDefaultsInSwitch -> "More than one default clause in switch statement" - | NoCatchOrFinally -> "Missing catch or finally after try" - | UnknownLabel label -> "Undefined label '" ^ label ^ "'" - | Redeclaration (what, name) -> what ^ " '" ^ name ^ "' has already been declared" - | IllegalContinue -> "Illegal continue statement" - | IllegalBreak -> "Illegal break statement" - | IllegalReturn -> "Illegal return statement" - | IllegalUnicodeEscape -> "Illegal Unicode escape" - | StrictModeWith -> "Strict mode code may not include a with statement" - | StrictCatchVariable -> "Catch variable may not be eval or arguments in strict mode" - | StrictVarName -> "Variable name may not be eval or arguments in strict mode" - | StrictParamName -> "Parameter name eval or arguments is not allowed in strict mode" - | StrictParamDupe -> "Strict mode function may not have duplicate parameter names" - | StrictParamNotSimple -> - "Illegal \"use strict\" directive in function with non-simple parameter list" - | StrictFunctionName -> "Function name may not be eval or arguments in strict mode" - | StrictOctalLiteral -> "Octal literals are not allowed in strict mode." - | StrictNonOctalLiteral -> "Number literals with leading zeros are not allowed in strict mode." - | StrictDelete -> "Delete of an unqualified identifier in strict mode." - | StrictDuplicateProperty -> - "Duplicate data property in object literal not allowed in strict mode" - | AccessorDataProperty -> - "Object literal may not have data and accessor property with the same name" - | AccessorGetSet -> "Object literal may not have multiple get/set accessors with the same name" - | StrictLHSAssignment -> "Assignment to eval or arguments is not allowed in strict mode" - | StrictLHSPostfix -> - "Postfix increment/decrement may not have eval or arguments operand in strict mode" - | StrictLHSPrefix -> - "Prefix increment/decrement may not have eval or arguments operand in strict mode" - | StrictReservedWord -> "Use of future reserved word in strict mode" - | JSXAttributeValueEmptyExpression -> - "JSX attributes must only be assigned a non-empty expression" - | InvalidJSXAttributeValue -> "JSX value should be either an expression or a quoted JSX text" - | ExpectedJSXClosingTag name -> "Expected corresponding JSX closing tag for " ^ name - | NoUninitializedConst -> "Const must be initialized" - | NoUninitializedDestructuring -> "Destructuring assignment must be initialized" - | NewlineBeforeArrow -> "Illegal newline before arrow" - | FunctionAsStatement { in_strict_mode } -> - if in_strict_mode then - "In strict mode code, functions can only be declared at top level or " - ^ "immediately within another function." - else - "In non-strict mode code, functions can only be declared at top level, " - ^ "inside a block, or as the body of an if statement." - | AsyncFunctionAsStatement -> - "Async functions can only be declared at top level or " - ^ "immediately within another function." - | GeneratorFunctionAsStatement -> - "Generators can only be declared at top level or " ^ "immediately within another function." - | AdjacentJSXElements -> - "Unexpected token <. Remember, adjacent JSX " - ^ "elements must be wrapped in an enclosing parent tag" - | ParameterAfterRestParameter -> "Rest parameter must be final parameter of an argument list" - | ElementAfterRestElement -> "Rest element must be final element of an array pattern" - | PropertyAfterRestElement -> "Rest property must be final property of an object pattern" - | DeclareAsync -> - "async is an implementation detail and isn't necessary for your declare function statement. It is sufficient for your declare function to just have a Promise return type." - | DeclareClassElement -> "`declare` modifier can only appear on class fields." - | DeclareClassFieldInitializer -> - "Unexpected token `=`. Initializers are not allowed in a `declare`." - | DeclareOpaqueTypeInitializer -> - "Unexpected token `=`. Initializers are not allowed in a `declare opaque type`." - | DeclareExportLet -> "`declare export let` is not supported. Use `declare export var` instead." - | DeclareExportConst -> - "`declare export const` is not supported. Use `declare export var` instead." - | DeclareExportType -> "`declare export type` is not supported. Use `export type` instead." - | DeclareExportInterface -> - "`declare export interface` is not supported. Use `export interface` instead." - | DuplicateExport export -> Printf.sprintf "Duplicate export for `%s`" export - | UnsupportedDecorator -> "Found a decorator in an unsupported position." - | MissingTypeParamDefault -> - "Type parameter declaration needs a default, since a preceding type parameter declaration has a default." - | DuplicateDeclareModuleExports -> "Duplicate `declare module.exports` statement!" - | AmbiguousDeclareModuleKind -> - "Found both `declare module.exports` and `declare export` in the same module. Modules can only have 1 since they are either an ES module xor they are a CommonJS module." - | GetterArity -> "Getter should have zero parameters" - | SetterArity -> "Setter should have exactly one parameter" - | InvalidNonTypeImportInDeclareModule -> - "Imports within a `declare module` body must always be " ^ "`import type` or `import typeof`!" - | ImportTypeShorthandOnlyInPureImport -> - "The `type` and `typeof` keywords on named imports can only be used on regular `import` statements. It cannot be used with `import type` or `import typeof` statements" - | ImportSpecifierMissingComma -> "Missing comma between import specifiers" - | ExportSpecifierMissingComma -> "Missing comma between export specifiers" - | MalformedUnicode -> "Malformed unicode" - | DuplicateConstructor -> "Classes may only have one constructor" - | DuplicatePrivateFields name -> - "Private fields may only be declared once. `#" ^ name ^ "` is declared more than once." - | InvalidClassMemberName { name; static; method_; private_ } -> - let static_modifier = - if static then - "static " - else - "" - in - let name = - if private_ then - "#" ^ name - else - name - in - let category = - if method_ then - "methods" - else - "fields" - in - "Classes may not have " ^ static_modifier ^ category ^ " named `" ^ name ^ "`." - | PrivateDelete -> "Private fields may not be deleted." - | UnboundPrivate name -> - "Private fields must be declared before they can be referenced. `#" - ^ name - ^ "` has not been declared." - | PrivateNotInClass -> "Private fields can only be referenced from within a class." - | SuperPrivate -> "You may not access a private field through the `super` keyword." - | YieldInFormalParameters -> "Yield expression not allowed in formal parameter" - | AwaitAsIdentifierReference -> "`await` is an invalid identifier in async functions" - | YieldAsIdentifierReference -> "`yield` is an invalid identifier in generators" - | AmbiguousLetBracket -> - "`let [` is ambiguous in this position because it is " - ^ "either a `let` binding pattern, or a member expression." - | LiteralShorthandProperty -> "Literals cannot be used as shorthand properties." - | ComputedShorthandProperty -> "Computed properties must have a value." - | MethodInDestructuring -> "Object pattern can't contain methods" - | TrailingCommaAfterRestElement -> "A trailing comma is not permitted after the rest element" - | OptionalChainNew -> "An optional chain may not be used in a `new` expression." - | OptionalChainTemplate -> "Template literals may not be used in an optional chain." - | NullishCoalescingUnexpectedLogical operator -> - Printf.sprintf - "Unexpected token `%s`. Parentheses are required to combine `??` with `&&` or `||` expressions." - operator - | WhitespaceInPrivateName -> "Unexpected whitespace between `#` and identifier" - | ThisParamAnnotationRequired -> "A type annotation is required for the `this` parameter." - | ThisParamMustBeFirst -> "The `this` parameter must be the first function parameter." - | ThisParamMayNotBeOptional -> "The `this` parameter cannot be optional." - | GetterMayNotHaveThisParam -> "A getter cannot have a `this` parameter." - | SetterMayNotHaveThisParam -> "A setter cannot have a `this` parameter." - | ThisParamBannedInArrowFunctions -> - "Arrow functions cannot have a `this` parameter; arrow functions automatically bind `this` when declared." - | ThisParamBannedInConstructor -> - "Constructors cannot have a `this` parameter; constructors don't bind `this` like other functions." - | InvalidTypeof -> "`typeof` can only be used to get the type of variables." -end diff --git a/jscomp/js_parser/parser_common.ml b/jscomp/js_parser/parser_common.ml deleted file mode 100644 index 8da6dae..0000000 --- a/jscomp/js_parser/parser_common.ml +++ /dev/null @@ -1,232 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -open Parser_env -open Flow_ast - -type pattern_errors = { - if_expr: (Loc.t * Parse_error.t) list; - if_patt: (Loc.t * Parse_error.t) list; -} - -type pattern_cover = - | Cover_expr of (Loc.t, Loc.t) Expression.t - | Cover_patt of (Loc.t, Loc.t) Expression.t * pattern_errors - -module type PARSER = sig - val program : env -> (Loc.t, Loc.t) Program.t - - val statement : env -> (Loc.t, Loc.t) Statement.t - - val statement_list_item : - ?decorators:(Loc.t, Loc.t) Class.Decorator.t list -> env -> (Loc.t, Loc.t) Statement.t - - val statement_list : term_fn:(Token.t -> bool) -> env -> (Loc.t, Loc.t) Statement.t list - - val statement_list_with_directives : - term_fn:(Token.t -> bool) -> env -> (Loc.t, Loc.t) Statement.t list * bool - - val module_body : term_fn:(Token.t -> bool) -> env -> (Loc.t, Loc.t) Statement.t list - - val expression : env -> (Loc.t, Loc.t) Expression.t - - val expression_or_pattern : env -> pattern_cover - - val conditional : env -> (Loc.t, Loc.t) Expression.t - - val assignment : env -> (Loc.t, Loc.t) Expression.t - - val left_hand_side : env -> (Loc.t, Loc.t) Expression.t - - val object_initializer : env -> Loc.t * (Loc.t, Loc.t) Expression.Object.t * pattern_errors - - val identifier : ?restricted_error:Parse_error.t -> env -> (Loc.t, Loc.t) Identifier.t - - val identifier_with_type : - env -> ?no_optional:bool -> Parse_error.t -> Loc.t * (Loc.t, Loc.t) Pattern.Identifier.t - - val block_body : env -> Loc.t * (Loc.t, Loc.t) Statement.Block.t - - val function_block_body : - expression:bool -> env -> (Loc.t * (Loc.t, Loc.t) Statement.Block.t) * bool - - val jsx_element_or_fragment : - env -> - Loc.t * [ `Element of (Loc.t, Loc.t) JSX.element | `Fragment of (Loc.t, Loc.t) JSX.fragment ] - - val pattern : env -> Parse_error.t -> (Loc.t, Loc.t) Pattern.t - - val pattern_from_expr : env -> (Loc.t, Loc.t) Expression.t -> (Loc.t, Loc.t) Pattern.t - - val object_key : ?class_body:bool -> env -> Loc.t * (Loc.t, Loc.t) Expression.Object.Property.key - - val class_declaration : env -> (Loc.t, Loc.t) Class.Decorator.t list -> (Loc.t, Loc.t) Statement.t - - val class_expression : env -> (Loc.t, Loc.t) Expression.t - - val is_assignable_lhs : (Loc.t, Loc.t) Expression.t -> bool - - val number : env -> Token.number_type -> string -> float - - val annot : env -> (Loc.t, Loc.t) Type.annotation -end - -let identifier_name_raw env = - let open Token in - let name = - match Peek.token env with - (* obviously, Identifier is a valid IdentifierName *) - | T_IDENTIFIER { value; _ } -> value - (* keywords are also IdentifierNames *) - | T_AWAIT -> "await" - | T_BREAK -> "break" - | T_CASE -> "case" - | T_CATCH -> "catch" - | T_CLASS -> "class" - | T_CONST -> "const" - | T_CONTINUE -> "continue" - | T_DEBUGGER -> "debugger" - | T_DEFAULT -> "default" - | T_DELETE -> "delete" - | T_DO -> "do" - | T_ELSE -> "else" - | T_EXPORT -> "export" - | T_EXTENDS -> "extends" - | T_FINALLY -> "finally" - | T_FOR -> "for" - | T_FUNCTION -> "function" - | T_IF -> "if" - | T_IMPORT -> "import" - | T_IN -> "in" - | T_INSTANCEOF -> "instanceof" - | T_NEW -> "new" - | T_RETURN -> "return" - | T_SUPER -> "super" - | T_SWITCH -> "switch" - | T_THIS -> "this" - | T_THROW -> "throw" - | T_TRY -> "try" - | T_TYPEOF -> "typeof" - | T_VAR -> "var" - | T_VOID -> "void" - | T_WHILE -> "while" - | T_WITH -> "with" - | T_YIELD -> "yield" - (* FutureReservedWord *) - | T_ENUM -> "enum" - | T_LET -> "let" - | T_STATIC -> "static" - | T_INTERFACE -> "interface" - | T_IMPLEMENTS -> "implements" - | T_PACKAGE -> "package" - | T_PRIVATE -> "private" - | T_PROTECTED -> "protected" - | T_PUBLIC -> "public" - (* NullLiteral *) - | T_NULL -> "null" - (* BooleanLiteral *) - | T_TRUE -> "true" - | T_FALSE -> "false" - (* Flow-specific stuff *) - | T_DECLARE -> "declare" - | T_TYPE -> "type" - | T_OPAQUE -> "opaque" - | T_ANY_TYPE -> "any" - | T_MIXED_TYPE -> "mixed" - | T_EMPTY_TYPE -> "empty" - | T_BOOLEAN_TYPE BOOL -> "bool" - | T_BOOLEAN_TYPE BOOLEAN -> "boolean" - | T_NUMBER_TYPE -> "number" - | T_BIGINT_TYPE -> "bigint" - | T_STRING_TYPE -> "string" - | T_VOID_TYPE -> "void" - | T_SYMBOL_TYPE -> "symbol" - (* Contextual stuff *) - | T_OF -> "of" - | T_ASYNC -> "async" - (* punctuators, types, literals, etc are not identifiers *) - | _ -> - error_unexpected ~expected:"an identifier" env; - "" - in - Eat.token env; - name - -(* IdentifierName - https://tc39.github.io/ecma262/#prod-IdentifierName *) -let identifier_name env = - let loc = Peek.loc env in - let leading = Peek.comments env in - let name = identifier_name_raw env in - let trailing = Eat.trailing_comments env in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - (loc, { Identifier.name; comments }) - -(** PrivateIdentifier - https://tc39.es/ecma262/#prod-PrivateIdentifier - - N.B.: whitespace, line terminators, and comments are not allowed - between the # and IdentifierName because PrivateIdentifier is a - CommonToken which is considered a single token. See also - https://tc39.es/ecma262/#prod-InputElementDiv *) -let private_identifier env = - let start_loc = Peek.loc env in - let leading = Peek.comments env in - Expect.token env Token.T_POUND; - let name_loc = Peek.loc env in - let name = identifier_name_raw env in - let trailing = Eat.trailing_comments env in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - let loc = Loc.btwn start_loc name_loc in - if not (Loc.equal_position start_loc.Loc._end name_loc.Loc.start) then - error_at env (loc, Parse_error.WhitespaceInPrivateName); - (loc, { PrivateName.name; comments }) - -(** The operation IsSimpleParamterList - https://tc39.es/ecma262/#sec-static-semantics-issimpleparameterlist *) -let is_simple_parameter_list = - let is_simple_param = function - | (_, { Flow_ast.Function.Param.argument = (_, Pattern.Identifier _); default = None }) -> true - | _ -> false - in - fun (_, { Flow_ast.Function.Params.params; rest; comments = _; this_ = _ }) -> - rest = None && List.for_all is_simple_param params - -(** - * The abstract operation IsLabelledFunction - * - * https://tc39.github.io/ecma262/#sec-islabelledfunction - *) -let rec is_labelled_function = function - | (_, Flow_ast.Statement.Labeled { Flow_ast.Statement.Labeled.body; _ }) -> - begin - match body with - | (_, Flow_ast.Statement.FunctionDeclaration _) -> true - | _ -> is_labelled_function body - end - | _ -> false - -let with_loc ?start_loc fn env = - let start_loc = - match start_loc with - | Some x -> x - | None -> Peek.loc env - in - let result = fn env in - let loc = - match last_loc env with - | Some end_loc -> Loc.btwn start_loc end_loc - | None -> start_loc - in - (loc, result) - -let with_loc_opt ?start_loc fn env = - match with_loc ?start_loc fn env with - | (loc, Some x) -> Some (loc, x) - | (_, None) -> None - -let with_loc_extra ?start_loc fn env = - let (loc, (x, extra)) = with_loc ?start_loc fn env in - ((loc, x), extra) diff --git a/jscomp/js_parser/parser_env.ml b/jscomp/js_parser/parser_env.ml deleted file mode 100644 index 939761d..0000000 --- a/jscomp/js_parser/parser_env.ml +++ /dev/null @@ -1,1184 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Sedlexing = Flow_sedlexing -open Flow_ast -module SSet = Set.Make (String) - -module Lex_mode = struct - type t = - | NORMAL - | TYPE - | JSX_TAG - | JSX_CHILD - | TEMPLATE - | REGEXP - - let debug_string_of_lex_mode (mode : t) = - match mode with - | NORMAL -> "NORMAL" - | TYPE -> "TYPE" - | JSX_TAG -> "JSX_TAG" - | JSX_CHILD -> "JSX_CHILD" - | TEMPLATE -> "TEMPLATE" - | REGEXP -> "REGEXP" -end - -(* READ THIS BEFORE YOU MODIFY: - * - * The current implementation for lookahead beyond a single token is - * inefficient. If you believe you need to increase this constant, do one of the - * following: - * - Find another way - * - Benchmark your change and provide convincing evidence that it doesn't - * actually have a significant perf impact. - * - Refactor this to memoize all requested lookahead, so we aren't lexing the - * same token multiple times. - *) - -module Lookahead : sig - type t - - val create : Lex_env.t -> Lex_mode.t -> t - val peek_0 : t -> Lex_result.t - val peek_1 : t -> Lex_result.t - val lex_env_0 : t -> Lex_env.t - val junk : t -> unit -end = struct - type la_result = (Lex_env.t * Lex_result.t) option - - type t = { - mutable la_results_0: la_result; - mutable la_results_1: la_result; - la_lex_mode: Lex_mode.t; - mutable la_lex_env: Lex_env.t; - } - - let create lex_env mode = - let lex_env = Lex_env.clone lex_env in - { la_results_0 = None; la_results_1 = None; la_lex_mode = mode; la_lex_env = lex_env } - - (* precondition: there is enough room in t.la_results for the result *) - let lex t = - let lex_env = t.la_lex_env in - let (lex_env, lex_result) = - match t.la_lex_mode with - | Lex_mode.NORMAL -> Flow_lexer.token lex_env - | Lex_mode.TYPE -> Flow_lexer.type_token lex_env - | Lex_mode.JSX_TAG -> Flow_lexer.jsx_tag lex_env - | Lex_mode.JSX_CHILD -> Flow_lexer.jsx_child lex_env - | Lex_mode.TEMPLATE -> Flow_lexer.template_tail lex_env - | Lex_mode.REGEXP -> Flow_lexer.regexp lex_env - in - let cloned_env = Lex_env.clone lex_env in - let result = (cloned_env, lex_result) in - t.la_lex_env <- lex_env; - begin - match t.la_results_0 with - | None -> t.la_results_0 <- Some result - | Some _ -> t.la_results_1 <- Some result - end; - result - - let peek_0 t = - match t.la_results_0 with - | Some (_, result) -> result - | None -> snd (lex t) - - let peek_1 t = - (match t.la_results_0 with - | None -> ignore (lex t) - | Some _ -> ()); - match t.la_results_1 with - | None -> snd (lex t) - | Some (_, result) -> result - - let lex_env_0 t = - match t.la_results_0 with - | Some (lex_env, _) -> lex_env - | None -> fst (lex t) - - (* Throws away the first peeked-at token, shifting any subsequent tokens up *) - let junk t = - match t.la_results_1 with - | None -> - ignore (peek_0 t); - t.la_results_0 <- None - | Some _ -> - t.la_results_0 <- t.la_results_1; - t.la_results_1 <- None -end - -type token_sink_result = { - token_loc: Loc.t; - token: Token.t; - token_context: Lex_mode.t; -} - -type parse_options = { - enums: bool; (** enable parsing of Flow enums *) - esproposal_decorators: bool; (** enable parsing of decorators *) - types: bool; (** enable parsing of Flow types *) - use_strict: bool; (** treat the file as strict, without needing a "use strict" directive *) -} - -let default_parse_options = - { enums = false; esproposal_decorators = false; types = true; use_strict = false } - -type allowed_super = - | No_super - | Super_prop - | Super_prop_or_call - -type env = { - errors: (Loc.t * Parse_error.t) list ref; - comments: Loc.t Comment.t list ref; - labels: SSet.t; - last_lex_result: Lex_result.t option ref; - in_strict_mode: bool; - in_export: bool; - in_export_default: bool; - in_loop: bool; - in_switch: bool; - in_formal_parameters: bool; - in_function: bool; - no_in: bool; - no_call: bool; - no_let: bool; - no_anon_function_type: bool; - no_new: bool; - allow_yield: bool; - allow_await: bool; - allow_directive: bool; - has_simple_parameters: bool; - allow_super: allowed_super; - error_callback: (env -> Parse_error.t -> unit) option; - lex_mode_stack: Lex_mode.t list ref; - (* lex_env is the lex_env after the single lookahead has been lexed *) - lex_env: Lex_env.t ref; - (* This needs to be cleared whenever we advance. *) - lookahead: Lookahead.t ref; - token_sink: (token_sink_result -> unit) option ref; - parse_options: parse_options; - source: File_key.t option; - (* It is a syntax error to reference private fields not in scope. In order to enforce this, - * we keep track of the privates we've seen declared and used. *) - privates: (SSet.t * (string * Loc.t) list) list ref; - (* The position up to which comments have been consumed, exclusive. *) - consumed_comments_pos: Loc.position ref; -} - -(* constructor *) -let init_env ?(token_sink = None) ?(parse_options = None) source content = - (* let lb = Sedlexing.Utf16.from_string - content (Some Sedlexing.Utf16.Little_endian) in *) - let (lb, errors) = - try (Sedlexing.Utf8.from_string content, []) with - | Sedlexing.MalFormed -> - (Sedlexing.Utf8.from_string "", [({ Loc.none with Loc.source }, Parse_error.MalformedUnicode)]) - in - let parse_options = - match parse_options with - | Some opts -> opts - | None -> default_parse_options - in - let enable_types_in_comments = parse_options.types in - let lex_env = Lex_env.new_lex_env source lb ~enable_types_in_comments in - { - errors = ref errors; - comments = ref []; - labels = SSet.empty; - last_lex_result = ref None; - has_simple_parameters = true; - in_strict_mode = parse_options.use_strict; - in_export = false; - in_export_default = false; - in_loop = false; - in_switch = false; - in_formal_parameters = false; - in_function = false; - no_in = false; - no_call = false; - no_let = false; - no_anon_function_type = false; - no_new = false; - allow_yield = false; - allow_await = false; - allow_directive = false; - allow_super = No_super; - error_callback = None; - lex_mode_stack = ref [Lex_mode.NORMAL]; - lex_env = ref lex_env; - lookahead = ref (Lookahead.create lex_env Lex_mode.NORMAL); - token_sink = ref token_sink; - parse_options; - source; - privates = ref []; - consumed_comments_pos = ref { Loc.line = 0; column = 0 }; - } - -(* getters: *) -let in_strict_mode env = env.in_strict_mode -let lex_mode env = List.hd !(env.lex_mode_stack) -let in_export env = env.in_export -let in_export_default env = env.in_export_default -let comments env = !(env.comments) -let labels env = env.labels -let in_loop env = env.in_loop -let in_switch env = env.in_switch -let in_formal_parameters env = env.in_formal_parameters -let in_function env = env.in_function -let allow_yield env = env.allow_yield -let allow_await env = env.allow_await -let allow_directive env = env.allow_directive -let allow_super env = env.allow_super -let has_simple_parameters env = env.has_simple_parameters -let no_in env = env.no_in -let no_call env = env.no_call -let no_let env = env.no_let -let no_anon_function_type env = env.no_anon_function_type -let no_new env = env.no_new -let errors env = !(env.errors) -let parse_options env = env.parse_options -let source env = env.source -let should_parse_types env = env.parse_options.types - -(* mutators: *) -let error_at env (loc, e) = - env.errors := (loc, e) :: !(env.errors); - match env.error_callback with - | None -> () - | Some callback -> callback env e - -(* Since private fields out of scope are a parse error, we keep track of the declared and used - * private fields. - * - * Whenever we enter a class, we push new empty lists of declared and used privates. - * When we encounter a new declared private, we add it to the top of the declared_privates list - * via add_declared_private. We do the same with used_privates via add_used_private. - * - * When we exit a class, we look for all the unbound private variables. Since class fields - * are hoisted to the scope of the class, we may need to look further before we conclude that - * a field is out of scope. To do that, we add all of the unbound private fields to the - * next used_private list. Once we run out of declared private lists, any leftover used_privates - * are unbound private variables. *) -let enter_class env = env.privates := (SSet.empty, []) :: !(env.privates) - -let exit_class env = - let get_unbound_privates declared_privates used_privates = - List.filter (fun x -> not (SSet.mem (fst x) declared_privates)) used_privates - in - match !(env.privates) with - | [(declared_privates, used_privates)] -> - let unbound_privates = get_unbound_privates declared_privates used_privates in - List.iter - (fun (name, loc) -> error_at env (loc, Parse_error.UnboundPrivate name)) - unbound_privates; - env.privates := [] - | (loc_declared_privates, loc_used_privates) :: privates -> - let unbound_privates = get_unbound_privates loc_declared_privates loc_used_privates in - let (decl_head, used_head) = List.hd privates in - env.privates := (decl_head, used_head @ unbound_privates) :: List.tl privates - | _ -> failwith "Internal Error: `exit_class` called before a matching `enter_class`" - -let add_declared_private env name = - match !(env.privates) with - | [] -> failwith "Internal Error: Tried to add_declared_private with outside of class scope." - | (declared, used) :: xs -> env.privates := (SSet.add name declared, used) :: xs - -let add_used_private env name loc = - match !(env.privates) with - | [] -> error_at env (loc, Parse_error.PrivateNotInClass) - | (declared, used) :: xs -> env.privates := (declared, (name, loc) :: used) :: xs - -let consume_comments_until env pos = env.consumed_comments_pos := pos - -(* lookahead: *) -let lookahead_0 env = Lookahead.peek_0 !(env.lookahead) -let lookahead_1 env = Lookahead.peek_1 !(env.lookahead) - -let lookahead ~i env = - match i with - | 0 -> lookahead_0 env - | 1 -> lookahead_1 env - | _ -> assert false - -(* functional operations: *) -let with_strict in_strict_mode env = - if in_strict_mode = env.in_strict_mode then - env - else - { env with in_strict_mode } - -let with_in_formal_parameters in_formal_parameters env = - if in_formal_parameters = env.in_formal_parameters then - env - else - { env with in_formal_parameters } - -let with_in_function in_function env = - if in_function = env.in_function then - env - else - { env with in_function } - -let with_allow_yield allow_yield env = - if allow_yield = env.allow_yield then - env - else - { env with allow_yield } - -let with_allow_await allow_await env = - if allow_await = env.allow_await then - env - else - { env with allow_await } - -let with_allow_directive allow_directive env = - if allow_directive = env.allow_directive then - env - else - { env with allow_directive } - -let with_allow_super allow_super env = - if allow_super = env.allow_super then - env - else - { env with allow_super } - -let with_no_let no_let env = - if no_let = env.no_let then - env - else - { env with no_let } - -let with_in_loop in_loop env = - if in_loop = env.in_loop then - env - else - { env with in_loop } - -let with_no_in no_in env = - if no_in = env.no_in then - env - else - { env with no_in } - -let with_no_anon_function_type no_anon_function_type env = - if no_anon_function_type = env.no_anon_function_type then - env - else - { env with no_anon_function_type } - -let with_no_new no_new env = - if no_new = env.no_new then - env - else - { env with no_new } - -let with_in_switch in_switch env = - if in_switch = env.in_switch then - env - else - { env with in_switch } - -let with_in_export in_export env = - if in_export = env.in_export then - env - else - { env with in_export } - -let with_in_export_default in_export_default env = - if in_export_default = env.in_export_default then - env - else - { env with in_export_default } - -let with_no_call no_call env = - if no_call = env.no_call then - env - else - { env with no_call } - -let with_error_callback error_callback env = { env with error_callback = Some error_callback } - -(* other helper functions: *) -let error_list env = List.iter (error_at env) - -let last_loc env = - match !(env.last_lex_result) with - | Some lex_result -> Some (Lex_result.loc lex_result) - | None -> None - -let last_token env = - match !(env.last_lex_result) with - | Some lex_result -> Some (Lex_result.token lex_result) - | None -> None - -let without_error_callback env = { env with error_callback = None } -let add_label env label = { env with labels = SSet.add label env.labels } - -let enter_function env ~async ~generator ~simple_params = - { - env with - in_formal_parameters = false; - has_simple_parameters = simple_params; - in_function = true; - in_loop = false; - in_switch = false; - in_export = false; - in_export_default = false; - labels = SSet.empty; - allow_await = async; - allow_yield = generator; - } - -(* #sec-keywords *) -let is_keyword = function - | "await" - | "break" - | "case" - | "catch" - | "class" - | "const" - | "continue" - | "debugger" - | "default" - | "delete" - | "do" - | "else" - | "export" - | "extends" - | "finally" - | "for" - | "function" - | "if" - | "import" - | "in" - | "instanceof" - | "new" - | "return" - | "super" - | "switch" - | "this" - | "throw" - | "try" - | "typeof" - | "var" - | "void" - | "while" - | "with" - | "yield" -> - true - | _ -> false - -let token_is_keyword = - Token.( - function - | T_IDENTIFIER { raw; _ } when is_keyword raw -> true - | T_AWAIT - | T_BREAK - | T_CASE - | T_CATCH - | T_CLASS - | T_CONST - | T_CONTINUE - | T_DEBUGGER - | T_DEFAULT - | T_DELETE - | T_DO - | T_ELSE - | T_EXPORT - | T_EXTENDS - | T_FINALLY - | T_FOR - | T_FUNCTION - | T_IF - | T_IMPORT - | T_IN - | T_INSTANCEOF - | T_NEW - | T_RETURN - | T_SUPER - | T_SWITCH - | T_THIS - | T_THROW - | T_TRY - | T_TYPEOF - | T_VAR - | T_VOID - | T_WHILE - | T_WITH - | T_YIELD -> - true - | _ -> false - ) - -(* #sec-future-reserved-words *) -let is_future_reserved = function - | "enum" -> true - | _ -> false - -let token_is_future_reserved = - Token.( - function - | T_IDENTIFIER { raw; _ } when is_future_reserved raw -> true - | T_ENUM -> true - | _ -> false - ) - -(* #sec-strict-mode-of-ecmascript *) -let is_strict_reserved = function - | "interface" - | "implements" - | "package" - | "private" - | "protected" - | "public" - | "static" - | "yield" -> - true - | _ -> false - -let token_is_strict_reserved = - Token.( - function - | T_IDENTIFIER { raw; _ } when is_strict_reserved raw -> true - | T_INTERFACE - | T_IMPLEMENTS - | T_PACKAGE - | T_PRIVATE - | T_PROTECTED - | T_PUBLIC - | T_STATIC - | T_YIELD -> - true - | _ -> false - ) - -(* #sec-strict-mode-of-ecmascript *) -let is_restricted = function - | "eval" - | "arguments" -> - true - | _ -> false - -let token_is_restricted = - Token.( - function - | T_IDENTIFIER { raw; _ } when is_restricted raw -> true - | _ -> false - ) - -(* #sec-reserved-words *) -let is_reserved str_val = - is_keyword str_val - || is_future_reserved str_val - || - match str_val with - | "null" - | "true" - | "false" -> - true - | _ -> false - -let token_is_reserved t = - token_is_keyword t - || token_is_future_reserved t - || - match t with - | Token.T_IDENTIFIER { raw = "null" | "true" | "false"; _ } - | Token.T_NULL - | Token.T_TRUE - | Token.T_FALSE -> - true - | _ -> false - -let is_reserved_type str_val = - match str_val with - | "any" - | "bool" - | "boolean" - | "empty" - | "false" - | "mixed" - | "null" - | "number" - | "bigint" - | "static" - | "string" - | "true" - | "typeof" - | "void" - | "interface" - | "extends" - | "_" -> - true - | _ -> false - -(* Answer questions about what comes next *) -module Peek = struct - open Loc - open Token - - let ith_token ~i env = Lex_result.token (lookahead ~i env) - let ith_loc ~i env = Lex_result.loc (lookahead ~i env) - let ith_errors ~i env = Lex_result.errors (lookahead ~i env) - - let ith_comments ~i env = - let comments = Lex_result.comments (lookahead ~i env) in - match comments with - | [] -> [] - | _ -> - List.filter - (fun ({ Loc.start; _ }, _) -> Loc.pos_cmp !(env.consumed_comments_pos) start <= 0) - comments - - let token env = ith_token ~i:0 env - let loc env = ith_loc ~i:0 env - - (* loc_skip_lookahead is used to give a loc hint to optional tokens such as type annotations *) - let loc_skip_lookahead env = - let loc = - match last_loc env with - | Some loc -> loc - | None -> failwith "Peeking current location when not available" - in - Loc.{ loc with start = loc._end } - - let errors env = ith_errors ~i:0 env - let comments env = ith_comments ~i:0 env - - let has_eaten_comments env = - let comments = Lex_result.comments (lookahead ~i:0 env) in - List.exists - (fun ({ Loc.start; _ }, _) -> Loc.pos_cmp start !(env.consumed_comments_pos) < 0) - comments - - let lex_env env = Lookahead.lex_env_0 !(env.lookahead) - - (* True if there is a line terminator before the next token *) - let ith_is_line_terminator ~i env = - let loc = - if i > 0 then - Some (ith_loc ~i:(i - 1) env) - else - last_loc env - in - match loc with - | None -> false - | Some loc' -> (ith_loc ~i env).start.line > loc'.start.line - - let is_line_terminator env = ith_is_line_terminator ~i:0 env - - let ith_is_implicit_semicolon ~i env = - match ith_token ~i env with - | T_EOF - | T_RCURLY -> - true - | T_SEMICOLON -> false - | _ -> ith_is_line_terminator ~i env - - let is_implicit_semicolon env = ith_is_implicit_semicolon ~i:0 env - - let ith_is_identifier ~i env = - match ith_token ~i env with - | t when token_is_strict_reserved t -> true - | t when token_is_future_reserved t -> true - | t when token_is_restricted t -> true - | T_LET - | T_TYPE - | T_OPAQUE - | T_OF - | T_DECLARE - | T_ASYNC - | T_AWAIT - | T_POUND - | T_IDENTIFIER _ -> - true - | _ -> false - - let ith_is_type_identifier ~i env = - match lex_mode env with - | Lex_mode.TYPE -> begin - match ith_token ~i env with - | T_IDENTIFIER _ -> true - | _ -> false - end - | Lex_mode.NORMAL -> begin - (* Sometimes we peek at type identifiers while in normal lex mode. For - example, when deciding whether a `type` token is an identifier or the - start of a type declaration, based on whether the following token - `is_type_identifier`. *) - match ith_token ~i env with - | T_IDENTIFIER { raw; _ } when is_reserved_type raw -> false - (* reserved type identifiers, but these don't appear in NORMAL mode *) - | T_ANY_TYPE - | T_MIXED_TYPE - | T_EMPTY_TYPE - | T_NUMBER_TYPE - | T_BIGINT_TYPE - | T_STRING_TYPE - | T_VOID_TYPE - | T_SYMBOL_TYPE - | T_BOOLEAN_TYPE _ - | T_NUMBER_SINGLETON_TYPE _ - | T_BIGINT_SINGLETON_TYPE _ - (* identifier-ish *) - | T_ASYNC - | T_AWAIT - | T_BREAK - | T_CASE - | T_CATCH - | T_CLASS - | T_CONST - | T_CONTINUE - | T_DEBUGGER - | T_DECLARE - | T_DEFAULT - | T_DELETE - | T_DO - | T_ELSE - | T_ENUM - | T_EXPORT - | T_EXTENDS - | T_FALSE - | T_FINALLY - | T_FOR - | T_FUNCTION - | T_IDENTIFIER _ - | T_IF - | T_IMPLEMENTS - | T_IMPORT - | T_IN - | T_INSTANCEOF - | T_INTERFACE - | T_LET - | T_NEW - | T_NULL - | T_OF - | T_OPAQUE - | T_PACKAGE - | T_PRIVATE - | T_PROTECTED - | T_PUBLIC - | T_RETURN - | T_SUPER - | T_SWITCH - | T_THIS - | T_THROW - | T_TRUE - | T_TRY - | T_TYPE - | T_VAR - | T_WHILE - | T_WITH - | T_YIELD -> - true - (* identifier-ish, but not valid types *) - | T_STATIC - | T_TYPEOF - | T_VOID -> - false - (* syntax *) - | T_LCURLY - | T_RCURLY - | T_LCURLYBAR - | T_RCURLYBAR - | T_LPAREN - | T_RPAREN - | T_LBRACKET - | T_RBRACKET - | T_SEMICOLON - | T_COMMA - | T_PERIOD - | T_ARROW - | T_ELLIPSIS - | T_AT - | T_POUND - | T_CHECKS - | T_RSHIFT3_ASSIGN - | T_RSHIFT_ASSIGN - | T_LSHIFT_ASSIGN - | T_BIT_XOR_ASSIGN - | T_BIT_OR_ASSIGN - | T_BIT_AND_ASSIGN - | T_MOD_ASSIGN - | T_DIV_ASSIGN - | T_MULT_ASSIGN - | T_EXP_ASSIGN - | T_MINUS_ASSIGN - | T_PLUS_ASSIGN - | T_NULLISH_ASSIGN - | T_AND_ASSIGN - | T_OR_ASSIGN - | T_ASSIGN - | T_PLING_PERIOD - | T_PLING_PLING - | T_PLING - | T_COLON - | T_OR - | T_AND - | T_BIT_OR - | T_BIT_XOR - | T_BIT_AND - | T_EQUAL - | T_NOT_EQUAL - | T_STRICT_EQUAL - | T_STRICT_NOT_EQUAL - | T_LESS_THAN_EQUAL - | T_GREATER_THAN_EQUAL - | T_LESS_THAN - | T_GREATER_THAN - | T_LSHIFT - | T_RSHIFT - | T_RSHIFT3 - | T_PLUS - | T_MINUS - | T_DIV - | T_MULT - | T_EXP - | T_MOD - | T_NOT - | T_BIT_NOT - | T_INCR - | T_DECR - | T_EOF -> - false - (* literals *) - | T_NUMBER _ - | T_BIGINT _ - | T_STRING _ - | T_TEMPLATE_PART _ - | T_REGEXP _ - (* misc that shouldn't appear in NORMAL mode *) - | T_JSX_IDENTIFIER _ - | T_JSX_TEXT _ - | T_ERROR _ -> - false - end - | Lex_mode.JSX_TAG - | Lex_mode.JSX_CHILD - | Lex_mode.TEMPLATE - | Lex_mode.REGEXP -> - false - - let ith_is_identifier_name ~i env = ith_is_identifier ~i env || ith_is_type_identifier ~i env - - (* This returns true if the next token is identifier-ish (even if it is an - error) *) - let is_identifier env = ith_is_identifier ~i:0 env - let is_identifier_name env = ith_is_identifier_name ~i:0 env - let is_type_identifier env = ith_is_type_identifier ~i:0 env - - let is_function env = - token env = T_FUNCTION - || token env = T_ASYNC - && ith_token ~i:1 env = T_FUNCTION - && (loc env)._end.line = (ith_loc ~i:1 env).start.line - - let is_class env = - match token env with - | T_CLASS - | T_AT -> - true - | _ -> false -end - -(*****************************************************************************) -(* Errors *) -(*****************************************************************************) - -(* Complains about an error at the location of the lookahead *) -let error env e = - let loc = Peek.loc env in - error_at env (loc, e) - -let get_unexpected_error ?expected token = - if token_is_future_reserved token then - Parse_error.UnexpectedReserved - else if token_is_strict_reserved token then - Parse_error.StrictReservedWord - else - let unexpected = Token.explanation_of_token token in - match expected with - | Some expected_msg -> Parse_error.UnexpectedWithExpected (unexpected, expected_msg) - | None -> Parse_error.Unexpected unexpected - -let error_unexpected ?expected env = - (* So normally we consume the lookahead lex result when Eat.token calls - * Parser_env.advance, which will add any lexing errors to our list of errors. - * However, raising an unexpected error for a lookahead is kind of like - * consuming that token, so we should process any lexing errors before - * complaining about the unexpected token *) - error_list env (Peek.errors env); - error env (get_unexpected_error ?expected (Peek.token env)) - -let error_on_decorators env = - List.iter (fun decorator -> error_at env (fst decorator, Parse_error.UnsupportedDecorator)) - -let error_nameless_declaration env kind = - let expected = - if in_export env then - Printf.sprintf - "an identifier. When exporting a %s as a named export, you must specify a %s name. Did you mean `export default %s ...`?" - kind - kind - kind - else - "an identifier" - in - error_unexpected ~expected env - -let strict_error env e = if in_strict_mode env then error env e -let strict_error_at env (loc, e) = if in_strict_mode env then error_at env (loc, e) - -let function_as_statement_error_at env loc = - error_at env (loc, Parse_error.FunctionAsStatement { in_strict_mode = in_strict_mode env }) - -(* Consume zero or more tokens *) -module Eat = struct - (* Consume a single token *) - let token env = - (* If there's a token_sink, emit the lexed token before moving forward *) - (match !(env.token_sink) with - | None -> () - | Some token_sink -> - token_sink - { - token_loc = Peek.loc env; - token = Peek.token env; - (* - * The lex mode is useful because it gives context to some - * context-sensitive tokens. - * - * Some examples of such tokens include: - * - * `=>` - Part of an arrow function? or part of a type annotation? - * `<` - A less-than? Or an opening to a JSX element? - * ...etc... - *) - token_context = lex_mode env; - }); - - env.lex_env := Peek.lex_env env; - - error_list env (Peek.errors env); - env.comments := List.rev_append (Lex_result.comments (lookahead ~i:0 env)) !(env.comments); - env.last_lex_result := Some (lookahead ~i:0 env); - - Lookahead.junk !(env.lookahead) - - (** [maybe env t] eats the next token and returns [true] if it is [t], else return [false] *) - let maybe env t = - let is_t = Token.equal (Peek.token env) t in - if is_t then token env; - is_t - - let push_lex_mode env mode = - env.lex_mode_stack := mode :: !(env.lex_mode_stack); - env.lookahead := Lookahead.create !(env.lex_env) (lex_mode env) - - let pop_lex_mode env = - let new_stack = - match !(env.lex_mode_stack) with - | _mode :: stack -> stack - | _ -> failwith "Popping lex mode from empty stack" - in - env.lex_mode_stack := new_stack; - env.lookahead := Lookahead.create !(env.lex_env) (lex_mode env) - - let double_pop_lex_mode env = - let new_stack = - match !(env.lex_mode_stack) with - | _ :: _ :: stack -> stack - | _ -> failwith "Popping lex mode from empty stack" - in - env.lex_mode_stack := new_stack; - env.lookahead := Lookahead.create !(env.lex_env) (lex_mode env) - - let trailing_comments env = - let open Loc in - let loc = Peek.loc env in - if Peek.token env = Token.T_COMMA && Peek.ith_is_line_terminator ~i:1 env then ( - let trailing_before_comma = Peek.comments env in - let trailing_after_comma = - List.filter - (fun (comment_loc, _) -> comment_loc.start.line <= loc._end.line) - (Lex_result.comments (lookahead ~i:1 env)) - in - let trailing = trailing_before_comma @ trailing_after_comma in - consume_comments_until env { Loc.line = loc._end.line + 1; column = 0 }; - trailing - ) else - let trailing = Peek.comments env in - consume_comments_until env loc._end; - trailing - - let comments_until_next_line env = - let open Loc in - match !(env.last_lex_result) with - | None -> [] - | Some { Lex_result.lex_loc = last_loc; _ } -> - let comments = Peek.comments env in - let comments = List.filter (fun (loc, _) -> loc.start.line <= last_loc._end.line) comments in - consume_comments_until env { line = last_loc._end.line + 1; column = 0 }; - comments - - let program_comments env = - let open Flow_ast.Comment in - let comments = Peek.comments env in - let flow_directive = "@flow" in - let flow_directive_length = String.length flow_directive in - let contains_flow_directive { text; _ } = - let text_length = String.length text in - let rec contains_flow_directive_after_offset off = - if off + flow_directive_length > text_length then - false - else - String.sub text off flow_directive_length = flow_directive - || contains_flow_directive_after_offset (off + 1) - in - contains_flow_directive_after_offset 0 - in - (* Comments up through the last comment with an @flow directive are considered program comments *) - let rec flow_directive_comments comments = - match comments with - | [] -> [] - | (loc, comment) :: rest -> - if contains_flow_directive comment then ( - (env.consumed_comments_pos := Loc.(loc._end)); - List.rev ((loc, comment) :: rest) - ) else - flow_directive_comments rest - in - let program_comments = flow_directive_comments (List.rev comments) in - let program_comments = - if program_comments <> [] then - program_comments - else - (* If there is no @flow directive, consider the first block comment a program comment if - it starts with "/**" *) - match comments with - | ((loc, { kind = Block; text; _ }) as first_comment) :: _ - when String.length text >= 1 && text.[0] = '*' -> - (env.consumed_comments_pos := Loc.(loc._end)); - [first_comment] - | _ -> [] - in - program_comments -end - -module Expect = struct - let get_error env t = - let expected = Token.explanation_of_token ~use_article:true t in - (Peek.loc env, get_unexpected_error ~expected (Peek.token env)) - - let error env t = - let expected = Token.explanation_of_token ~use_article:true t in - error_unexpected ~expected env - - let token env t = - if not (Token.equal (Peek.token env) t) then error env t; - Eat.token env - - (** [token_maybe env T_FOO] eats a token if it is [T_FOO], and errors without consuming if - not. Returns whether it consumed a token, like [Eat.maybe]. *) - let token_maybe env t = - let ate = Eat.maybe env t in - if not ate then error env t; - ate - - (** [token_opt env T_FOO] eats a token if it is [T_FOO], and errors without consuming if not. - This differs from [token], which always consumes. Only use [token_opt] when it's ok for - the parser to not advance, like if you are guaranteed that something else has eaten a - token. *) - let token_opt env t = ignore (token_maybe env t) - - let identifier env name = - let t = Peek.token env in - begin - match t with - | Token.T_IDENTIFIER { raw; _ } when raw = name -> () - | _ -> - let expected = Printf.sprintf "the identifier `%s`" name in - error_unexpected ~expected env - end; - Eat.token env -end - -(* This module allows you to try parsing and rollback if you need. This is not - * cheap and its usage is strongly discouraged *) -module Try = struct - type 'a parse_result = - | ParsedSuccessfully of 'a - | FailedToParse - - exception Rollback - - type saved_state = { - saved_errors: (Loc.t * Parse_error.t) list; - saved_comments: Loc.t Flow_ast.Comment.t list; - saved_last_lex_result: Lex_result.t option; - saved_lex_mode_stack: Lex_mode.t list; - saved_lex_env: Lex_env.t; - saved_consumed_comments_pos: Loc.position; - token_buffer: ((token_sink_result -> unit) * token_sink_result Queue.t) option; - } - - let save_state env = - let token_buffer = - match !(env.token_sink) with - | None -> None - | Some orig_token_sink -> - let buffer = Queue.create () in - env.token_sink := Some (fun token_data -> Queue.add token_data buffer); - Some (orig_token_sink, buffer) - in - { - saved_errors = !(env.errors); - saved_comments = !(env.comments); - saved_last_lex_result = !(env.last_lex_result); - saved_lex_mode_stack = !(env.lex_mode_stack); - saved_lex_env = !(env.lex_env); - saved_consumed_comments_pos = !(env.consumed_comments_pos); - token_buffer; - } - - let reset_token_sink ~flush env token_buffer_info = - match token_buffer_info with - | None -> () - | Some (orig_token_sink, token_buffer) -> - env.token_sink := Some orig_token_sink; - if flush then Queue.iter orig_token_sink token_buffer - - let rollback_state env saved_state = - reset_token_sink ~flush:false env saved_state.token_buffer; - env.errors := saved_state.saved_errors; - env.comments := saved_state.saved_comments; - env.last_lex_result := saved_state.saved_last_lex_result; - env.lex_mode_stack := saved_state.saved_lex_mode_stack; - env.lex_env := saved_state.saved_lex_env; - env.consumed_comments_pos := saved_state.saved_consumed_comments_pos; - env.lookahead := Lookahead.create !(env.lex_env) (lex_mode env); - - FailedToParse - - let success env saved_state result = - reset_token_sink ~flush:true env saved_state.token_buffer; - ParsedSuccessfully result - - let to_parse env parse = - let saved_state = save_state env in - try success env saved_state (parse env) with - | Rollback -> rollback_state env saved_state - - let or_else env ~fallback parse = - match to_parse env parse with - | ParsedSuccessfully result -> result - | FailedToParse -> fallback -end diff --git a/jscomp/js_parser/parser_env.mli b/jscomp/js_parser/parser_env.mli deleted file mode 100644 index 7cc424e..0000000 --- a/jscomp/js_parser/parser_env.mli +++ /dev/null @@ -1,283 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -(* This module provides a layer between the lexer and the parser which includes - * some parser state and some lexer state *) - -module SSet : Set.S with type elt = string - -module Lex_mode : sig - type t = - | NORMAL - | TYPE - | JSX_TAG - | JSX_CHILD - | TEMPLATE - | REGEXP - - val debug_string_of_lex_mode : t -> string -end - -type token_sink_result = { - token_loc: Loc.t; - token: Token.t; - token_context: Lex_mode.t; -} - -type parse_options = { - enums: bool; (** enable parsing of Flow enums *) - esproposal_decorators: bool; (** enable parsing of decorators *) - types: bool; (** enable parsing of Flow types *) - use_strict: bool; (** treat the file as strict, without needing a "use strict" directive *) -} - -val default_parse_options : parse_options - -type env - -type allowed_super = - | No_super - | Super_prop - | Super_prop_or_call - -(* constructor: *) -val init_env : - ?token_sink:(token_sink_result -> unit) option -> - ?parse_options:parse_options option -> - File_key.t option -> - string -> - env - -(* getters: *) -val in_strict_mode : env -> bool - -val last_loc : env -> Loc.t option - -val last_token : env -> Token.t option - -val in_export : env -> bool - -val in_export_default : env -> bool - -val labels : env -> SSet.t - -val comments : env -> Loc.t Flow_ast.Comment.t list - -val in_loop : env -> bool - -val in_switch : env -> bool - -val in_formal_parameters : env -> bool - -val in_function : env -> bool - -val allow_yield : env -> bool - -val allow_await : env -> bool - -val allow_directive : env -> bool - -val allow_super : env -> allowed_super - -val has_simple_parameters : env -> bool - -val no_in : env -> bool - -val no_call : env -> bool - -val no_let : env -> bool - -val no_anon_function_type : env -> bool - -val no_new : env -> bool - -val errors : env -> (Loc.t * Parse_error.t) list - -val parse_options : env -> parse_options - -val source : env -> File_key.t option - -val should_parse_types : env -> bool - -val get_unexpected_error : ?expected:string -> Token.t -> Parse_error.t - -(* mutators: *) -val error_at : env -> Loc.t * Parse_error.t -> unit - -val error : env -> Parse_error.t -> unit - -val error_unexpected : ?expected:string -> env -> unit - -val error_on_decorators : env -> (Loc.t * 'a) list -> unit - -val error_nameless_declaration : env -> string -> unit - -val strict_error : env -> Parse_error.t -> unit - -val strict_error_at : env -> Loc.t * Parse_error.t -> unit - -val function_as_statement_error_at : env -> Loc.t -> unit - -val error_list : env -> (Loc.t * Parse_error.t) list -> unit - -val enter_class : env -> unit - -val exit_class : env -> unit - -val add_declared_private : env -> string -> unit - -val add_used_private : env -> string -> Loc.t -> unit - -val consume_comments_until : env -> Loc.position -> unit - -(* functional operations -- these return shallow copies, so future mutations to - * the returned env will also affect the original: *) -val with_strict : bool -> env -> env - -val with_in_formal_parameters : bool -> env -> env - -val with_in_function : bool -> env -> env - -val with_allow_yield : bool -> env -> env - -val with_allow_await : bool -> env -> env - -val with_allow_directive : bool -> env -> env - -val with_allow_super : allowed_super -> env -> env - -val with_no_let : bool -> env -> env - -val with_in_loop : bool -> env -> env - -val with_no_in : bool -> env -> env - -val with_no_anon_function_type : bool -> env -> env - -val with_no_new : bool -> env -> env - -val with_in_switch : bool -> env -> env - -val with_in_export : bool -> env -> env - -val with_in_export_default : bool -> env -> env - -val with_no_call : bool -> env -> env - -val with_error_callback : (env -> Parse_error.t -> unit) -> env -> env - -val without_error_callback : env -> env - -val add_label : env -> string -> env - -val enter_function : env -> async:bool -> generator:bool -> simple_params:bool -> env - -val is_reserved : string -> bool - -val token_is_reserved : Token.t -> bool - -val is_future_reserved : string -> bool - -val is_strict_reserved : string -> bool - -val token_is_strict_reserved : Token.t -> bool - -val is_restricted : string -> bool - -val is_reserved_type : string -> bool - -val token_is_restricted : Token.t -> bool - -module Peek : sig - val token : env -> Token.t - - val loc : env -> Loc.t - - val loc_skip_lookahead : env -> Loc.t - - val errors : env -> (Loc.t * Parse_error.t) list - - val comments : env -> Loc.t Flow_ast.Comment.t list - - val has_eaten_comments : env -> bool - - val is_line_terminator : env -> bool - - val is_implicit_semicolon : env -> bool - - val is_identifier : env -> bool - - val is_type_identifier : env -> bool - - val is_identifier_name : env -> bool - - val is_function : env -> bool - - val is_class : env -> bool - - val ith_token : i:int -> env -> Token.t - - val ith_loc : i:int -> env -> Loc.t - - val ith_errors : i:int -> env -> (Loc.t * Parse_error.t) list - - val ith_comments : i:int -> env -> Loc.t Flow_ast.Comment.t list - - val ith_is_line_terminator : i:int -> env -> bool - - val ith_is_implicit_semicolon : i:int -> env -> bool - - val ith_is_identifier : i:int -> env -> bool - - val ith_is_identifier_name : i:int -> env -> bool - - val ith_is_type_identifier : i:int -> env -> bool -end - -module Eat : sig - val token : env -> unit - - val maybe : env -> Token.t -> bool - - val push_lex_mode : env -> Lex_mode.t -> unit - - val pop_lex_mode : env -> unit - - val double_pop_lex_mode : env -> unit - - val trailing_comments : env -> Loc.t Flow_ast.Comment.t list - - val comments_until_next_line : env -> Loc.t Flow_ast.Comment.t list - - val program_comments : env -> Loc.t Flow_ast.Comment.t list -end - -module Expect : sig - val get_error : env -> Token.t -> Loc.t * Parse_error.t - - val error : env -> Token.t -> unit - - val token : env -> Token.t -> unit - - val token_opt : env -> Token.t -> unit - - val token_maybe : env -> Token.t -> bool - - val identifier : env -> string -> unit -end - -module Try : sig - type 'a parse_result = - | ParsedSuccessfully of 'a - | FailedToParse - - exception Rollback - - val to_parse : env -> (env -> 'a) -> 'a parse_result - - val or_else : env -> fallback:'a -> (env -> 'a) -> 'a -end diff --git a/jscomp/js_parser/parser_flow.ml b/jscomp/js_parser/parser_flow.ml deleted file mode 100644 index f31f7c7..0000000 --- a/jscomp/js_parser/parser_flow.ml +++ /dev/null @@ -1,588 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Sedlexing = Flow_sedlexing -module Ast = Flow_ast -open Token -open Parser_env -open Parser_common - -(* Sometimes we add the same error for multiple different reasons. This is hard - to avoid, so instead we just filter the duplicates out. This function takes - a reversed list of errors and returns the list in forward order with dupes - removed. This differs from a set because the original order is preserved. *) -let filter_duplicate_errors = - let module PrintableErrorSet = Set.Make (struct - type t = Loc.t * Parse_error.t - - let compare (a_loc, a_error) (b_loc, b_error) = - let loc = Loc.compare a_loc b_loc in - if loc = 0 then - Parse_error.compare a_error b_error - else - loc - end) in - fun errs -> - let errs = List.rev errs in - let (_, deduped) = - List.fold_left - (fun (set, deduped) err -> - if PrintableErrorSet.mem err set then - (set, deduped) - else - (PrintableErrorSet.add err set, err :: deduped)) - (PrintableErrorSet.empty, []) - errs - in - List.rev deduped - -let check_for_duplicate_exports = - let open Ast in - let record_export env seen (loc, { Identifier.name = export_name; comments = _ }) = - if export_name = "" then - (* empty identifiers signify an error, don't export it *) - seen - else if SSet.mem export_name seen then ( - error_at env (loc, Parse_error.DuplicateExport export_name); - seen - ) else - SSet.add export_name seen - in - let extract_pattern_binding_names = - let rec fold acc = - let open Pattern in - function - | (_, Object { Object.properties; _ }) -> - List.fold_left - (fun acc prop -> - match prop with - | Object.Property (_, { Object.Property.pattern; _ }) - | Object.RestElement (_, { RestElement.argument = pattern; comments = _ }) -> - fold acc pattern) - acc - properties - | (_, Array { Array.elements; _ }) -> - List.fold_left - (fun acc elem -> - match elem with - | Array.Element (_, { Array.Element.argument = pattern; default = _ }) - | Array.RestElement (_, { RestElement.argument = pattern; comments = _ }) -> - fold acc pattern - | Array.Hole _ -> acc) - acc - elements - | (_, Identifier { Pattern.Identifier.name; _ }) -> name :: acc - | (_, Expression _) -> failwith "Parser error: No such thing as an expression pattern!" - in - List.fold_left fold - in - let record_export_of_statement env seen decl = - match decl with - | (_, Statement.ExportDefaultDeclaration { Statement.ExportDefaultDeclaration.default; _ }) -> - record_export env seen (Flow_ast_utils.ident_of_source (default, "default")) - | ( _, - Statement.ExportNamedDeclaration - { Statement.ExportNamedDeclaration.specifiers = Some specifiers; declaration = None; _ } - ) -> - let open Statement.ExportNamedDeclaration in - (match specifiers with - | ExportSpecifiers specifiers -> - List.fold_left - (fun seen (_, { Statement.ExportNamedDeclaration.ExportSpecifier.local; exported }) -> - match exported with - | Some exported -> record_export env seen exported - | None -> record_export env seen local) - seen - specifiers - | ExportBatchSpecifier _ -> - (* doesn't export specific names *) - seen) - | ( _, - Statement.ExportNamedDeclaration - { Statement.ExportNamedDeclaration.specifiers = None; declaration = Some declaration; _ } - ) -> - (match declaration with - | ( loc, - ( Statement.TypeAlias { Statement.TypeAlias.id; _ } - | Statement.OpaqueType { Statement.OpaqueType.id; _ } - | Statement.InterfaceDeclaration { Statement.Interface.id; _ } - | Statement.ClassDeclaration { Class.id = Some id; _ } - | Statement.FunctionDeclaration { Function.id = Some id; _ } - | Statement.EnumDeclaration { Statement.EnumDeclaration.id; _ } ) - ) -> - record_export - env - seen - (Flow_ast_utils.ident_of_source (loc, Flow_ast_utils.name_of_ident id)) - | (_, Statement.VariableDeclaration { Statement.VariableDeclaration.declarations; _ }) -> - declarations - |> List.fold_left - (fun names (_, { Statement.VariableDeclaration.Declarator.id; _ }) -> - extract_pattern_binding_names names [id]) - [] - |> List.fold_left (record_export env) seen - | ( _, - Statement.( - ( Block _ | Break _ - | ClassDeclaration { Class.id = None; _ } - | Continue _ | Debugger _ | DeclareClass _ | DeclareExportDeclaration _ - | DeclareFunction _ | DeclareInterface _ | DeclareModule _ | DeclareModuleExports _ - | DeclareTypeAlias _ | DeclareOpaqueType _ | DeclareVariable _ | DoWhile _ | Empty _ - | ExportDefaultDeclaration _ | ExportNamedDeclaration _ | Expression _ | For _ | ForIn _ - | ForOf _ - | FunctionDeclaration { Function.id = None; _ } - | If _ | ImportDeclaration _ | Labeled _ | Return _ | Switch _ | Throw _ | Try _ - | While _ | With _ )) - ) -> - (* these don't export names -- some are invalid, but the AST allows them *) - seen) - | ( _, - Statement.ExportNamedDeclaration - { Statement.ExportNamedDeclaration.declaration = None; specifiers = None; _ } - ) - | ( _, - Statement.ExportNamedDeclaration - { Statement.ExportNamedDeclaration.declaration = Some _; specifiers = Some _; _ } - ) -> - (* impossible *) - seen - | ( _, - Statement.( - ( Block _ | Break _ | ClassDeclaration _ | Continue _ | Debugger _ | DeclareClass _ - | DeclareExportDeclaration _ | DeclareFunction _ | DeclareInterface _ | DeclareModule _ - | DeclareModuleExports _ | DeclareTypeAlias _ | DeclareOpaqueType _ | DeclareVariable _ - | DoWhile _ | Empty _ | EnumDeclaration _ | Expression _ | For _ | ForIn _ | ForOf _ - | FunctionDeclaration _ | If _ | ImportDeclaration _ | InterfaceDeclaration _ | Labeled _ - | Return _ | Switch _ | Throw _ | Try _ | TypeAlias _ | OpaqueType _ - | VariableDeclaration _ | While _ | With _ )) - ) -> - seen - in - (fun env stmts -> ignore (List.fold_left (record_export_of_statement env) SSet.empty stmts)) - -module rec Parse : PARSER = struct - module Type = Type_parser.Type (Parse) - module Declaration = Declaration_parser.Declaration (Parse) (Type) - module Pattern_cover = Pattern_cover.Cover (Parse) - module Expression = Expression_parser.Expression (Parse) (Type) (Declaration) (Pattern_cover) - module Object = Object_parser.Object (Parse) (Type) (Declaration) (Expression) (Pattern_cover) - - module Statement = - Statement_parser.Statement (Parse) (Type) (Declaration) (Object) (Pattern_cover) - - module Pattern = Pattern_parser.Pattern (Parse) (Type) - module JSX = Jsx_parser.JSX (Parse) - - let annot = Type.annotation - - let identifier ?restricted_error env = - (match Peek.token env with - (* "let" is disallowed as an identifier in a few situations. 11.6.2.1 - lists them out. It is always disallowed in strict mode *) - | T_LET when in_strict_mode env -> error env Parse_error.StrictReservedWord - | T_LET when no_let env -> error_unexpected env - | T_LET -> () - (* `allow_await` means that `await` is allowed to be a keyword, - which makes it illegal to use as an identifier. - https://tc39.github.io/ecma262/#sec-identifiers-static-semantics-early-errors *) - | T_AWAIT when allow_await env -> error env Parse_error.UnexpectedReserved - | T_AWAIT -> () - (* `allow_yield` means that `yield` is allowed to be a keyword, - which makes it illegal to use as an identifier. - https://tc39.github.io/ecma262/#sec-identifiers-static-semantics-early-errors *) - | T_YIELD when allow_yield env -> error env Parse_error.UnexpectedReserved - | T_YIELD when in_strict_mode env -> error env Parse_error.StrictReservedWord - | T_YIELD -> () - | t when token_is_strict_reserved t -> strict_error env Parse_error.StrictReservedWord - | t when token_is_reserved t -> error_unexpected env - | t -> - (match restricted_error with - | Some err when token_is_restricted t -> strict_error env err - | _ -> ())); - identifier_name env - - let rec program env = - let leading = Eat.program_comments env in - let stmts = module_body_with_directives env (fun _ -> false) in - let end_loc = Peek.loc env in - Expect.token env T_EOF; - check_for_duplicate_exports env stmts; - let loc = - match stmts with - | [] -> end_loc - | _ -> Loc.btwn (fst (List.hd stmts)) (fst (List.hd (List.rev stmts))) - in - let all_comments = List.rev (comments env) in - ( loc, - { - Ast.Program.statements = stmts; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - all_comments; - } - ) - - and directives = - let check env token = - match token with - | T_STRING (loc, _, _, octal) -> - if octal then strict_error_at env (loc, Parse_error.StrictOctalLiteral) - | _ -> failwith ("Nooo: " ^ token_to_string token ^ "\n") - in - let rec statement_list env term_fn item_fn (string_tokens, stmts, contains_use_strict) = - match Peek.token env with - | T_EOF -> (env, string_tokens, stmts, contains_use_strict) - | t when term_fn t -> (env, string_tokens, stmts, contains_use_strict) - | T_STRING _ as string_token -> - let possible_directive = item_fn env in - let stmts = possible_directive :: stmts in - (match possible_directive with - | (loc, Ast.Statement.Expression { Ast.Statement.Expression.directive = Some raw; _ }) -> - (* 14.1.1 says that it has to be "use strict" without any - escapes, so "use\x20strict" is disallowed. *) - let strict = raw = "use strict" in - if strict && not (has_simple_parameters env) then - error_at env (loc, Parse_error.StrictParamNotSimple); - let env = - if strict then - with_strict true env - else - env - in - let string_tokens = string_token :: string_tokens in - statement_list env term_fn item_fn (string_tokens, stmts, contains_use_strict || strict) - | _ -> (env, string_tokens, stmts, contains_use_strict)) - | _ -> (env, string_tokens, stmts, contains_use_strict) - in - fun env term_fn item_fn -> - let env = with_allow_directive true env in - let (env, string_tokens, stmts, contains_use_strict) = - statement_list env term_fn item_fn ([], [], false) - in - let env = with_allow_directive false env in - List.iter (check env) (List.rev string_tokens); - (env, stmts, contains_use_strict) - - (* 15.2 *) - and module_item env = - let decorators = Object.decorator_list env in - match Peek.token env with - | T_EXPORT -> Statement.export_declaration ~decorators env - | T_IMPORT -> - error_on_decorators env decorators; - let statement = - match Peek.ith_token ~i:1 env with - | T_LPAREN (* import(...) *) - | T_PERIOD (* import.meta *) -> - Statement.expression env - | _ -> Statement.import_declaration env - in - statement - | T_DECLARE when Peek.ith_token ~i:1 env = T_EXPORT -> - error_on_decorators env decorators; - Statement.declare_export_declaration env - | _ -> statement_list_item env ~decorators - - and module_body_with_directives env term_fn = - let (env, directives, _contains_use_strict) = directives env term_fn module_item in - let stmts = module_body ~term_fn env in - (* Prepend the directives *) - List.fold_left (fun acc stmt -> stmt :: acc) stmts directives - - and module_body = - let rec module_item_list env term_fn acc = - match Peek.token env with - | T_EOF -> List.rev acc - | t when term_fn t -> List.rev acc - | _ -> module_item_list env term_fn (module_item env :: acc) - in - (fun ~term_fn env -> module_item_list env term_fn []) - - and statement_list_with_directives ~term_fn env = - let (env, directives, contains_use_strict) = directives env term_fn statement_list_item in - let stmts = statement_list ~term_fn env in - (* Prepend the directives *) - let stmts = List.fold_left (fun acc stmt -> stmt :: acc) stmts directives in - (stmts, contains_use_strict) - - and statement_list = - let rec statements env term_fn acc = - match Peek.token env with - | T_EOF -> List.rev acc - | t when term_fn t -> List.rev acc - | _ -> statements env term_fn (statement_list_item env :: acc) - in - (fun ~term_fn env -> statements env term_fn []) - - and statement_list_item ?(decorators = []) env = - if not (Peek.is_class env) then error_on_decorators env decorators; - let open Statement in - match Peek.token env with - (* Remember kids, these look like statements but they're not - * statements... (see section 13) *) - | T_LET -> let_ env - | T_CONST -> const env - | _ when Peek.is_function env -> Declaration._function env - | _ when Peek.is_class env -> class_declaration env decorators - | T_INTERFACE -> interface env - | T_DECLARE -> declare env - | T_TYPE -> type_alias env - | T_OPAQUE -> opaque_type env - | T_ENUM when (parse_options env).enums -> Declaration.enum_declaration env - | _ -> statement env - - and statement env = - let open Statement in - match Peek.token env with - | T_EOF -> - error_unexpected ~expected:"the start of a statement" env; - (Peek.loc env, Ast.Statement.Empty { Ast.Statement.Empty.comments = None }) - | T_SEMICOLON -> empty env - | T_LCURLY -> block env - | T_VAR -> var env - | T_BREAK -> break env - | T_CONTINUE -> continue env - | T_DEBUGGER -> debugger env - | T_DO -> do_while env - | T_FOR -> for_ env - | T_IF -> if_ env - | T_RETURN -> return env - | T_SWITCH -> switch env - | T_THROW -> throw env - | T_TRY -> try_ env - | T_WHILE -> while_ env - | T_WITH -> with_ env - (* If we see an else then it's definitely an error, but we can probably - * assume that this is a malformed if statement that is missing the if *) - | T_ELSE -> if_ env - (* There are a bunch of tokens that aren't the start of any valid - * statement. We list them here in order to skip over them, rather than - * getting stuck *) - | T_COLON - | T_RPAREN - | T_RCURLY - | T_RBRACKET - | T_COMMA - | T_PERIOD - | T_PLING_PERIOD - | T_ARROW - | T_IN - | T_INSTANCEOF - | T_CATCH - | T_FINALLY - | T_CASE - | T_DEFAULT - | T_EXTENDS - | T_STATIC - | T_EXPORT - (* TODO *) - | T_ELLIPSIS -> - error_unexpected ~expected:"the start of a statement" env; - Eat.token env; - statement env - (* The rest of these patterns handle ExpressionStatement and its negative - lookaheads, which prevent ambiguities. - See https://tc39.github.io/ecma262/#sec-expression-statement *) - | _ when Peek.is_function env -> - let func = Declaration._function env in - function_as_statement_error_at env (fst func); - func - | T_LET when Peek.ith_token ~i:1 env = T_LBRACKET -> - (* `let [foo]` is ambiguous: either a let binding pattern, or a - member expression, so it is banned. *) - let loc = Loc.btwn (Peek.loc env) (Peek.ith_loc ~i:1 env) in - error_at env (loc, Parse_error.AmbiguousLetBracket); - Statement.expression env - (* recover as a member expression *) - | _ when Peek.is_identifier env -> maybe_labeled env - | _ when Peek.is_class env -> - error_unexpected env; - Eat.token env; - Statement.expression env - | _ -> Statement.expression env - - and expression env = - let start_loc = Peek.loc env in - let expr = Expression.assignment env in - match Peek.token env with - | T_COMMA -> Expression.sequence env ~start_loc [expr] - | _ -> expr - - and expression_or_pattern env = - let start_loc = Peek.loc env in - let expr_or_pattern = Expression.assignment_cover env in - match Peek.token env with - | T_COMMA -> - let expr = Pattern_cover.as_expression env expr_or_pattern in - let seq = Expression.sequence env ~start_loc [expr] in - Cover_expr seq - | _ -> expr_or_pattern - - and conditional = Expression.conditional - and assignment = Expression.assignment - and left_hand_side = Expression.left_hand_side - and object_initializer = Object._initializer - and object_key = Object.key - and class_declaration = Object.class_declaration - and class_expression = Object.class_expression - and is_assignable_lhs = Expression.is_assignable_lhs - and number = Expression.number - - and identifier_with_type = - let with_loc_helper no_optional restricted_error env = - let name = identifier ~restricted_error env in - let optional = (not no_optional) && Peek.token env = T_PLING in - if optional then ( - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeAnnotation; - Expect.token env T_PLING - ); - let annot = Type.annotation_opt env in - Ast.Pattern.Identifier.{ name; optional; annot } - in - fun env ?(no_optional = false) restricted_error -> - with_loc (with_loc_helper no_optional restricted_error) env - - and block_body env = - let start_loc = Peek.loc env in - let leading = Peek.comments env in - Expect.token env T_LCURLY; - let term_fn t = t = T_RCURLY in - let body = statement_list ~term_fn env in - let end_loc = Peek.loc env in - let internal = - if body = [] then - Peek.comments env - else - [] - in - Expect.token env T_RCURLY; - let trailing = Eat.trailing_comments env in - ( Loc.btwn start_loc end_loc, - { - Ast.Statement.Block.body; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - } - ) - - and function_block_body ~expression = - with_loc_extra (fun env -> - let leading = Peek.comments env in - Expect.token env T_LCURLY; - let term_fn t = t = T_RCURLY in - let (body, contains_use_strict) = statement_list_with_directives ~term_fn env in - let internal = - if body = [] then - Peek.comments env - else - [] - in - Expect.token env T_RCURLY; - let trailing = - match (expression, Peek.token env) with - | (true, _) - | (_, (T_RCURLY | T_EOF)) -> - Eat.trailing_comments env - | _ when Peek.is_line_terminator env -> Eat.comments_until_next_line env - | _ -> [] - in - let comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal () - in - ({ Ast.Statement.Block.body; comments }, contains_use_strict) - ) - - and jsx_element_or_fragment = JSX.element_or_fragment - and pattern = Pattern.pattern - and pattern_from_expr = Pattern.from_expr -end - -(*****************************************************************************) -(* Entry points *) -(*****************************************************************************) -let do_parse env parser fail = - let ast = parser env in - let error_list = filter_duplicate_errors (errors env) in - match error_list with - | e :: es when fail -> raise (Parse_error.Error (e, es)) - | _ -> (ast, error_list) - -(* Makes the input parser expect EOF at the end. Use this to error on trailing - * junk when parsing non-Program nodes. *) -let with_eof parser env = - let ast = parser env in - Expect.token env T_EOF; - ast - -let parse_statement env fail = do_parse env (with_eof Parse.statement_list_item) fail -let parse_expression env fail = do_parse env (with_eof Parse.expression) fail - -let parse_program fail ?(token_sink = None) ?(parse_options = None) filename content = - let env = init_env ~token_sink ~parse_options filename content in - do_parse env Parse.program fail - -let program ?(fail = true) ?(token_sink = None) ?(parse_options = None) content = - parse_program fail ~token_sink ~parse_options None content - -let program_file ?(fail = true) ?(token_sink = None) ?(parse_options = None) content filename = - parse_program fail ~token_sink ~parse_options filename content - -let parse_annot ?(parse_options = None) filename content = - let env = init_env ~token_sink:None ~parse_options filename content in - do_parse env Parse.annot false - -let package_json_file = - let parser env = - let (loc, obj, { if_expr; _ }) = Parse.object_initializer env in - List.iter (error_at env) if_expr; - (loc, obj) - in - fun ?(fail = true) ?(token_sink = None) ?(parse_options = None) content filename -> - let env = init_env ~token_sink ~parse_options filename content in - do_parse env parser fail - -(* even if fail=false, still raises an error on a totally invalid token, since - there's no legitimate fallback. *) -let json_file = - let null_fallback _env = - Ast.Expression.Literal { Ast.Literal.value = Ast.Literal.Null; raw = "null"; comments = None } - in - let parser env = - match Peek.token env with - | T_LBRACKET - | T_LCURLY - | T_STRING _ - | T_NUMBER _ - | T_TRUE - | T_FALSE - | T_NULL -> - Parse.expression env - | T_MINUS -> - (match Peek.ith_token ~i:1 env with - | T_NUMBER _ -> Parse.expression env - | _ -> - error_unexpected ~expected:"a number" env; - with_loc null_fallback env) - | _ -> - error_unexpected ~expected:"a valid JSON value" env; - with_loc null_fallback env - in - fun ?(fail = true) ?(token_sink = None) ?(parse_options = None) content filename -> - let env = init_env ~token_sink ~parse_options filename content in - do_parse env parser fail - -let jsx_pragma_expression = - let left_hand_side env = - let ast = Parse.left_hand_side (with_no_new true env) in - Expect.token env T_EOF; - ast - in - fun content filename -> - let env = init_env ~token_sink:None ~parse_options:None filename content in - do_parse env left_hand_side true - -let string_is_valid_identifier_name str = - let lexbuf = Sedlexing.Utf8.from_string str in - Flow_lexer.is_valid_identifier_name lexbuf diff --git a/jscomp/js_parser/pattern_cover.ml b/jscomp/js_parser/pattern_cover.ml deleted file mode 100644 index bf307e4..0000000 --- a/jscomp/js_parser/pattern_cover.ml +++ /dev/null @@ -1,59 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -open Flow_ast -open Parser_common -open Parser_env - -module type COVER = sig - val as_expression : env -> pattern_cover -> (Loc.t, Loc.t) Expression.t - - val as_pattern : ?err:Parse_error.t -> env -> pattern_cover -> (Loc.t, Loc.t) Pattern.t - - val empty_errors : pattern_errors - - val cons_error : Loc.t * Parse_error.t -> pattern_errors -> pattern_errors - - val rev_append_errors : pattern_errors -> pattern_errors -> pattern_errors - - val rev_errors : pattern_errors -> pattern_errors -end - -module Cover (Parse : PARSER) : COVER = struct - let as_expression env = function - | Cover_expr expr -> expr - | Cover_patt (expr, { if_expr; if_patt = _ }) -> - List.iter (error_at env) if_expr; - expr - - let as_pattern ?(err = Parse_error.InvalidLHSInAssignment) env cover = - let expr = - match cover with - | Cover_expr expr -> expr - | Cover_patt (expr, { if_expr = _; if_patt }) -> - List.iter (error_at env) if_patt; - expr - in - if not (Parse.is_assignable_lhs expr) then error_at env (fst expr, err); - - (match expr with - | (loc, Flow_ast.Expression.Identifier (_, { Flow_ast.Identifier.name; comments = _ })) - when is_restricted name -> - strict_error_at env (loc, Parse_error.StrictLHSAssignment) - | _ -> ()); - - Parse.pattern_from_expr env expr - - let empty_errors = { if_patt = []; if_expr = [] } - - let cons_error err { if_patt; if_expr } = { if_patt = err :: if_patt; if_expr = err :: if_expr } - - let rev_append_errors a b = - { if_patt = List.rev_append a.if_patt b.if_patt; if_expr = List.rev_append a.if_expr b.if_expr } - - let rev_errors a = { if_patt = List.rev a.if_patt; if_expr = List.rev a.if_expr } -end diff --git a/jscomp/js_parser/pattern_parser.ml b/jscomp/js_parser/pattern_parser.ml deleted file mode 100644 index 74a4aba..0000000 --- a/jscomp/js_parser/pattern_parser.ml +++ /dev/null @@ -1,397 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Token -open Parser_common -open Parser_env -open Flow_ast - -let missing_annot env = Ast.Type.Missing (Peek.loc_skip_lookahead env) - -module Pattern (Parse : Parser_common.PARSER) (Type : Type_parser.TYPE) = struct - (* Reinterpret various expressions as patterns. - * This is not the correct thing to do and is only used for assignment - * expressions. This should be removed and replaced ASAP. - *) - let rec object_from_expr = - let rec properties env acc = - let open Ast.Expression.Object in - function - | [] -> List.rev acc - | Property (loc, prop) :: remaining -> - let acc = - match prop with - | Property.Init { key; value; shorthand } -> - let open Ast.Expression in - let key = - match key with - | Property.Literal lit -> Pattern.Object.Property.Literal lit - | Property.Identifier id -> Pattern.Object.Property.Identifier id - | Property.PrivateName _ -> failwith "Internal Error: Found object private prop" - | Property.Computed key -> Pattern.Object.Property.Computed key - in - let (pattern, default) = - match value with - | (_loc, Assignment { Assignment.operator = None; left; right; comments = _ }) -> - (left, Some right) - | _ -> (from_expr env value, None) - in - Pattern.Object.Property - (loc, { Pattern.Object.Property.key; pattern; default; shorthand }) - :: acc - | Property.Method { key = _; value = (loc, _) } -> - error_at env (loc, Parse_error.MethodInDestructuring); - acc - | Property.Get { key = _; value = (loc, _); comments = _ } - | Property.Set { key = _; value = (loc, _); comments = _ } -> - (* these should never happen *) - error_at env (loc, Parse_error.Unexpected "identifier"); - acc - in - properties env acc remaining - | [SpreadProperty (loc, { SpreadProperty.argument; comments })] -> - let acc = - Pattern.Object.RestElement - (loc, { Pattern.RestElement.argument = from_expr env argument; comments }) - :: acc - in - properties env acc [] - | SpreadProperty (loc, _) :: remaining -> - error_at env (loc, Parse_error.PropertyAfterRestElement); - properties env acc remaining - in - fun env (loc, { Ast.Expression.Object.properties = props; comments }) -> - ( loc, - Pattern.( - Object - { Object.properties = properties env [] props; annot = missing_annot env; comments } - ) - ) - - and array_from_expr = - (* Convert an Expression to a Pattern if it is a valid - DestructuringAssignmentTarget, which must be an Object, Array or - IsValidSimpleAssignmentTarget. - #sec-destructuring-assignment-static-semantics-early-errors *) - let assignment_target env ((loc, _) as expr) = - if Parse.is_assignable_lhs expr then - Some (from_expr env expr) - else ( - error_at env (loc, Parse_error.InvalidLHSInAssignment); - None - ) - in - let rec elements env acc = - let open Ast.Expression in - function - | [] -> List.rev acc - | [Array.Spread (loc, { SpreadElement.argument; comments })] -> - (* AssignmentRestElement is a DestructuringAssignmentTarget, see - #prod-AssignmentRestElement *) - let acc = - match assignment_target env argument with - | Some argument -> - Pattern.Array.RestElement (loc, { Pattern.RestElement.argument; comments }) :: acc - | None -> acc - in - elements env acc [] - | Array.Spread (loc, _) :: remaining -> - error_at env (loc, Parse_error.ElementAfterRestElement); - elements env acc remaining - | Array.Expression (loc, Assignment { Assignment.operator = None; left; right; comments = _ }) - :: remaining -> - (* AssignmentElement is a `DestructuringAssignmentTarget Initializer`, see - #prod-AssignmentElement *) - let acc = - Pattern.Array.Element - (loc, { Pattern.Array.Element.argument = left; default = Some right }) - :: acc - in - elements env acc remaining - | Array.Expression expr :: remaining -> - (* AssignmentElement is a DestructuringAssignmentTarget, see - #prod-AssignmentElement *) - let acc = - match assignment_target env expr with - | Some ((loc, _) as expr) -> - let element = - Pattern.Array.Element (loc, { Pattern.Array.Element.argument = expr; default = None }) - in - element :: acc - | None -> acc - in - elements env acc remaining - | Array.Hole loc :: remaining -> elements env (Pattern.Array.Hole loc :: acc) remaining - in - fun env (loc, { Ast.Expression.Array.elements = elems; comments }) -> - ( loc, - Pattern.Array - { Pattern.Array.elements = elements env [] elems; annot = missing_annot env; comments } - ) - - and from_expr env (loc, expr) = - let open Ast.Expression in - match expr with - | Object obj -> object_from_expr env (loc, obj) - | Array arr -> array_from_expr env (loc, arr) - | Identifier ((id_loc, { Identifier.name = string_val; comments = _ }) as name) -> - (* per #sec-destructuring-assignment-static-semantics-early-errors, - it is a syntax error if IsValidSimpleAssignmentTarget of this - IdentifierReference is false. That happens when `string_val` is - "eval" or "arguments" in strict mode. *) - if in_strict_mode env && is_restricted string_val then - error_at env (id_loc, Parse_error.StrictLHSAssignment) - (* per #prod-IdentifierReference, yield is only a valid - IdentifierReference when [~Yield], and await is only valid - when [~Await]. but per #sec-identifiers-static-semantics-early-errors, - they are already invalid in strict mode, which we should have - already errored about when parsing the expression that we're now - converting into a pattern. *) - else if not (in_strict_mode env) then - if allow_yield env && string_val = "yield" then - error_at env (id_loc, Parse_error.YieldAsIdentifierReference) - else if allow_await env && string_val = "await" then - error_at env (id_loc, Parse_error.AwaitAsIdentifierReference); - ( loc, - Pattern.Identifier { Pattern.Identifier.name; annot = missing_annot env; optional = false } - ) - | expr -> (loc, Pattern.Expression (loc, expr)) - - (* Parse object destructuring pattern *) - let rec object_ restricted_error = - let rest_property env = - let leading = Peek.comments env in - let (loc, argument) = - with_loc - (fun env -> - Expect.token env T_ELLIPSIS; - pattern env restricted_error) - env - in - Pattern.Object.RestElement - ( loc, - { Pattern.RestElement.argument; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - in - let property_default env = - match Peek.token env with - | T_ASSIGN -> - Expect.token env T_ASSIGN; - Some (Parse.assignment env) - | _ -> None - in - let rec property env = - if Peek.token env = T_ELLIPSIS then - Some (rest_property env) - else - let start_loc = Peek.loc env in - let raw_key = Parse.object_key env in - match Peek.token env with - | T_COLON -> - Expect.token env T_COLON; - let (loc, (pattern, default)) = - with_loc - ~start_loc - (fun env -> - let pattern = pattern env restricted_error in - let default = property_default env in - (pattern, default)) - env - in - let key = - let open Ast.Expression.Object.Property in - match raw_key with - | (_, Literal lit) -> Pattern.Object.Property.Literal lit - | (_, Identifier id) -> Pattern.Object.Property.Identifier id - | (_, PrivateName _) -> failwith "Internal Error: Found object private prop" - | (_, Computed key) -> Pattern.Object.Property.Computed key - in - Some - Pattern.Object.(Property (loc, Property.{ key; pattern; default; shorthand = false })) - | _ -> - (match raw_key with - | ( _, - Ast.Expression.Object.Property.Identifier - ((id_loc, { Identifier.name = string_val; comments = _ }) as name) - ) -> - (* #sec-identifiers-static-semantics-early-errors *) - if is_reserved string_val && string_val <> "yield" && string_val <> "await" then - (* it is a syntax error if `name` is a reserved word other than await or yield *) - error_at env (id_loc, Parse_error.UnexpectedReserved) - else if is_strict_reserved string_val then - (* it is a syntax error if `name` is a strict reserved word, in strict mode *) - strict_error_at env (id_loc, Parse_error.StrictReservedWord); - let (loc, (pattern, default)) = - with_loc - ~start_loc - (fun env -> - let pattern = - ( id_loc, - Pattern.Identifier - { Pattern.Identifier.name; annot = missing_annot env; optional = false } - ) - in - let default = property_default env in - (pattern, default)) - env - in - Some - Pattern.Object.( - Property - ( loc, - { Property.key = Property.Identifier name; pattern; default; shorthand = true } - ) - ) - | _ -> - error_unexpected ~expected:"an identifier" env; - - (* invalid shorthand destructuring *) - None) - (* seen_rest is true when we've seen a rest element. rest_trailing_comma is the location of - * the rest element's trailing command - * Trailing comma: `let { ...rest, } = obj` - * Still invalid, but not a trailing comma: `let { ...rest, x } = obj` *) - and properties env ~seen_rest ~rest_trailing_comma acc = - match Peek.token env with - | T_EOF - | T_RCURLY -> - begin - match rest_trailing_comma with - | Some loc -> error_at env (loc, Parse_error.TrailingCommaAfterRestElement) - | None -> () - end; - List.rev acc - | _ -> - (match property env with - | Some ((Pattern.Object.Property (loc, _) | Pattern.Object.RestElement (loc, _)) as prop) -> - let rest_trailing_comma = - if seen_rest then ( - error_at env (loc, Parse_error.PropertyAfterRestElement); - None - ) else - rest_trailing_comma - in - let (seen_rest, rest_trailing_comma) = - match prop with - | Pattern.Object.RestElement _ -> - ( true, - if Peek.token env = T_COMMA then - Some (Peek.loc env) - else - None - ) - | _ -> (seen_rest, rest_trailing_comma) - in - if Peek.token env <> T_RCURLY then Expect.token env T_COMMA; - properties env ~seen_rest ~rest_trailing_comma (prop :: acc) - | None -> properties env ~seen_rest ~rest_trailing_comma acc) - in - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_LCURLY; - let properties = properties env ~seen_rest:false ~rest_trailing_comma:None [] in - let internal = Peek.comments env in - Expect.token env T_RCURLY; - let trailing = Eat.trailing_comments env in - let annot = - if Peek.token env = T_COLON then - Ast.Type.Available (Type.annotation env) - else - missing_annot env - in - Pattern.Object - { - Pattern.Object.properties; - annot; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - } - ) - - (* Parse array destructuring pattern *) - and array_ restricted_error = - let rec elements env acc = - match Peek.token env with - | T_EOF - | T_RBRACKET -> - List.rev acc - | T_COMMA -> - let loc = Peek.loc env in - Expect.token env T_COMMA; - elements env (Pattern.Array.Hole loc :: acc) - | T_ELLIPSIS -> - let leading = Peek.comments env in - let (loc, argument) = - with_loc - (fun env -> - Expect.token env T_ELLIPSIS; - pattern env restricted_error) - env - in - let element = - Pattern.Array.RestElement - ( loc, - { - Pattern.RestElement.argument; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - in - (* rest elements are always last, the closing ] should be next. but if not, - error and keep going so we recover gracefully by parsing the rest of the - elements. *) - if Peek.token env <> T_RBRACKET then ( - error_at env (loc, Parse_error.ElementAfterRestElement); - if Peek.token env = T_COMMA then Eat.token env - ); - elements env (element :: acc) - | _ -> - let (loc, (pattern, default)) = - with_loc - (fun env -> - let pattern = pattern env restricted_error in - let default = - match Peek.token env with - | T_ASSIGN -> - Expect.token env T_ASSIGN; - Some (Parse.assignment env) - | _ -> None - in - (pattern, default)) - env - in - let element = Pattern.Array.(Element (loc, { Element.argument = pattern; default })) in - if Peek.token env <> T_RBRACKET then Expect.token env T_COMMA; - elements env (element :: acc) - in - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_LBRACKET; - let elements = elements env [] in - let internal = Peek.comments env in - Expect.token env T_RBRACKET; - let annot = - if Peek.token env = T_COLON then - Ast.Type.Available (Type.annotation env) - else - missing_annot env - in - let trailing = Eat.trailing_comments env in - let comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal () - in - Pattern.Array { Pattern.Array.elements; annot; comments } - ) - - and pattern env restricted_error = - match Peek.token env with - | T_LCURLY -> object_ restricted_error env - | T_LBRACKET -> array_ restricted_error env - | _ -> - let (loc, id) = Parse.identifier_with_type env restricted_error in - (loc, Pattern.Identifier id) -end diff --git a/jscomp/js_parser/primitive_deriving.ml b/jscomp/js_parser/primitive_deriving.ml deleted file mode 100644 index db77258..0000000 --- a/jscomp/js_parser/primitive_deriving.ml +++ /dev/null @@ -1,39 +0,0 @@ -let equal_int (x : int) y = x = y -let equal_string (x : string) y = x = y -let equal_bool (x : bool) y = x = y -let equal_float (x : float) y = x = y -let equal_int64 (x : int64) y = x = y - -let equal_option f x y = - match x with - | None -> y = None - | Some x -> begin - match y with - | None -> false - | Some y -> f x y - end - -let compare_string (x : string) y = compare x y - -let compare_option cmp x y = - match x with - | None -> - (match y with - | None -> 0 - | Some _ -> -1) - | Some x -> - (match y with - | None -> 1 - | Some y -> cmp x y) - -let compare_bool (x : bool) (y : bool) = compare x y -(* TODO : turn it into externals *) -module Ppx_compare_lib = struct - external polymorphic_compare : 'a -> 'a -> int = "%compare" - external phys_equal : 'a -> 'a -> bool = "%eq" - - external ( && ) : bool -> bool -> bool = "%sequand" - - external polymorphic_equal : 'a -> 'a -> bool = "%equal" -end - diff --git a/jscomp/js_parser/sedlex_LICENSE b/jscomp/js_parser/sedlex_LICENSE deleted file mode 100644 index 630eb99..0000000 --- a/jscomp/js_parser/sedlex_LICENSE +++ /dev/null @@ -1,22 +0,0 @@ -The MIT License (MIT) - -Copyright 2005, 2014 by Alain Frisch and LexiFi. - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/jscomp/js_parser/statement_parser.ml b/jscomp/js_parser/statement_parser.ml deleted file mode 100644 index d9d41be..0000000 --- a/jscomp/js_parser/statement_parser.ml +++ /dev/null @@ -1,2189 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Token -open Parser_env -open Flow_ast -open Parser_common -open Comment_attachment - -module type STATEMENT = sig - val for_ : env -> (Loc.t, Loc.t) Statement.t - - val if_ : env -> (Loc.t, Loc.t) Statement.t - - val let_ : env -> (Loc.t, Loc.t) Statement.t - - val try_ : env -> (Loc.t, Loc.t) Statement.t - - val while_ : env -> (Loc.t, Loc.t) Statement.t - - val with_ : env -> (Loc.t, Loc.t) Statement.t - - val block : env -> (Loc.t, Loc.t) Statement.t - - val break : env -> (Loc.t, Loc.t) Statement.t - - val continue : env -> (Loc.t, Loc.t) Statement.t - - val debugger : env -> (Loc.t, Loc.t) Statement.t - - val declare : ?in_module:bool -> env -> (Loc.t, Loc.t) Statement.t - - val declare_export_declaration : ?allow_export_type:bool -> env -> (Loc.t, Loc.t) Statement.t - - val declare_opaque_type : env -> (Loc.t, Loc.t) Statement.t - - val do_while : env -> (Loc.t, Loc.t) Statement.t - - val empty : env -> (Loc.t, Loc.t) Statement.t - - val export_declaration : - decorators:(Loc.t, Loc.t) Class.Decorator.t list -> env -> (Loc.t, Loc.t) Statement.t - - val expression : env -> (Loc.t, Loc.t) Statement.t - - val import_declaration : env -> (Loc.t, Loc.t) Statement.t - - val interface : env -> (Loc.t, Loc.t) Statement.t - - val maybe_labeled : env -> (Loc.t, Loc.t) Statement.t - - val opaque_type : env -> (Loc.t, Loc.t) Statement.t - - val return : env -> (Loc.t, Loc.t) Statement.t - - val switch : env -> (Loc.t, Loc.t) Statement.t - - val throw : env -> (Loc.t, Loc.t) Statement.t - - val type_alias : env -> (Loc.t, Loc.t) Statement.t - - val var : env -> (Loc.t, Loc.t) Statement.t - - val const : env -> (Loc.t, Loc.t) Statement.t -end - -module Statement - (Parse : PARSER) - (Type : Type_parser.TYPE) - (Declaration : Declaration_parser.DECLARATION) - (Object : Object_parser.OBJECT) - (Pattern_cover : Pattern_cover.COVER) : STATEMENT = struct - type for_lhs = - | For_expression of pattern_cover - | For_declaration of (Loc.t * (Loc.t, Loc.t) Ast.Statement.VariableDeclaration.t) - - type semicolon_type = - | Explicit of Loc.t Comment.t list - | Implicit of Comment_attachment.trailing_and_remover_result - - (* FunctionDeclaration is not a valid Statement, but Annex B sometimes allows it. - However, AsyncFunctionDeclaration and GeneratorFunctionDeclaration are never - allowed as statements. We still parse them as statements (and raise an error) to - recover gracefully. *) - let function_as_statement env = - let func = Declaration._function env in - ( if in_strict_mode env then - function_as_statement_error_at env (fst func) - else - let open Ast.Statement in - match func with - | (loc, FunctionDeclaration { Ast.Function.async = true; _ }) -> - error_at env (loc, Parse_error.AsyncFunctionAsStatement) - | (loc, FunctionDeclaration { Ast.Function.generator = true; _ }) -> - error_at env (loc, Parse_error.GeneratorFunctionAsStatement) - | _ -> () - ); - func - - (* https://tc39.es/ecma262/#sec-exports-static-semantics-early-errors *) - let assert_identifier_name_is_identifier - ?restricted_error env (loc, { Ast.Identifier.name; comments = _ }) = - match name with - | "let" -> - (* "let" is disallowed as an identifier in a few situations. 11.6.2.1 - lists them out. It is always disallowed in strict mode *) - if in_strict_mode env then - strict_error_at env (loc, Parse_error.StrictReservedWord) - else if no_let env then - error_at env (loc, Parse_error.Unexpected (Token.quote_token_value name)) - | "await" -> - (* `allow_await` means that `await` is allowed to be a keyword, - which makes it illegal to use as an identifier. - https://tc39.github.io/ecma262/#sec-identifiers-static-semantics-early-errors *) - if allow_await env then error_at env (loc, Parse_error.UnexpectedReserved) - | "yield" -> - (* `allow_yield` means that `yield` is allowed to be a keyword, - which makes it illegal to use as an identifier. - https://tc39.github.io/ecma262/#sec-identifiers-static-semantics-early-errors *) - if allow_yield env then - error_at env (loc, Parse_error.UnexpectedReserved) - else - strict_error_at env (loc, Parse_error.StrictReservedWord) - | _ when is_strict_reserved name -> strict_error_at env (loc, Parse_error.StrictReservedWord) - | _ when is_reserved name -> - error_at env (loc, Parse_error.Unexpected (Token.quote_token_value name)) - | _ -> - begin - match restricted_error with - | Some err when is_restricted name -> strict_error_at env (loc, err) - | _ -> () - end - - let string_literal env (loc, value, raw, octal) = - if octal then strict_error env Parse_error.StrictOctalLiteral; - let leading = Peek.comments env in - Expect.token env (T_STRING (loc, value, raw, octal)); - let trailing = Eat.trailing_comments env in - ( loc, - { StringLiteral.value; raw; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - - (* Semicolon insertion is handled here :(. There seem to be 2 cases where - * semicolons are inserted. First, if we reach the EOF. Second, if the next - * token is } or is separated by a LineTerminator. - *) - let semicolon ?(expected = "the token `;`") ?(required = true) env = - match Peek.token env with - | T_EOF - | T_RCURLY -> - Implicit { trailing = Eat.trailing_comments env; remove_trailing = (fun x _ -> x) } - | T_SEMICOLON -> - Eat.token env; - (match Peek.token env with - | T_EOF - | T_RCURLY -> - Explicit (Eat.trailing_comments env) - | _ when Peek.is_line_terminator env -> Explicit (Eat.comments_until_next_line env) - | _ -> Explicit []) - | _ when Peek.is_line_terminator env -> - Implicit (Comment_attachment.trailing_and_remover_after_last_line env) - | _ -> - if required then error_unexpected ~expected env; - Explicit [] - - (* Consumes and returns the trailing comments after the end of a statement. Also returns - a remover that can remove all comments that are not trailing the previous token. - - If a statement is the end of a block or file, all comments are trailing. - Otherwise, if a statement is followed by a new line, only comments on the current - line are trailing. If a statement is not followed by a new line, it does not have - trailing comments as they are instead leading comments for the next statement. *) - let statement_end_trailing_comments env = - match Peek.token env with - | T_EOF - | T_RCURLY -> - { trailing = Eat.trailing_comments env; remove_trailing = (fun x _ -> x) } - | _ when Peek.is_line_terminator env -> - Comment_attachment.trailing_and_remover_after_last_line env - | _ -> Comment_attachment.trailing_and_remover_after_last_loc env - - let variable_declaration_end ~kind env declarations = - match semicolon env with - | Explicit comments -> (comments, declarations) - | Implicit { remove_trailing; _ } -> - (* Remove trailing comments from the last declarator *) - let declarations = - match List.rev declarations with - | [] -> [] - | decl :: decls -> - let decl' = - remove_trailing decl (fun remover decl -> remover#variable_declarator ~kind decl) - in - List.rev (decl' :: decls) - in - ([], declarations) - - let rec empty env = - let loc = Peek.loc env in - let leading = Peek.comments env in - Expect.token env T_SEMICOLON; - let { trailing; _ } = statement_end_trailing_comments env in - ( loc, - Statement.Empty - { Statement.Empty.comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - - and break env = - let leading = Peek.comments env in - let (loc, (label, trailing)) = - with_loc - (fun env -> - Expect.token env T_BREAK; - let label = - if Peek.token env = T_SEMICOLON || Peek.is_implicit_semicolon env then - None - else - let ((_, { Identifier.name; comments = _ }) as label) = Parse.identifier env in - if not (SSet.mem name (labels env)) then error env (Parse_error.UnknownLabel name); - Some label - in - let (trailing, label) = - match (semicolon env, label) with - | (Explicit trailing, _) - | (Implicit { trailing; _ }, None) -> - (trailing, label) - | (Implicit { remove_trailing; _ }, Some label) -> - ([], Some (remove_trailing label (fun remover label -> remover#identifier label))) - in - (label, trailing)) - env - in - if label = None && not (in_loop env || in_switch env) then - error_at env (loc, Parse_error.IllegalBreak); - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - (loc, Statement.Break { Statement.Break.label; comments }) - - and continue env = - let leading = Peek.comments env in - let (loc, (label, trailing)) = - with_loc - (fun env -> - Expect.token env T_CONTINUE; - let label = - if Peek.token env = T_SEMICOLON || Peek.is_implicit_semicolon env then - None - else - let ((_, { Identifier.name; comments = _ }) as label) = Parse.identifier env in - if not (SSet.mem name (labels env)) then error env (Parse_error.UnknownLabel name); - Some label - in - let (trailing, label) = - match (semicolon env, label) with - | (Explicit trailing, _) - | (Implicit { trailing; _ }, None) -> - (trailing, label) - | (Implicit { remove_trailing; _ }, Some label) -> - ([], Some (remove_trailing label (fun remover label -> remover#identifier label))) - in - (label, trailing)) - env - in - if not (in_loop env) then error_at env (loc, Parse_error.IllegalContinue); - ( loc, - Statement.Continue - { - Statement.Continue.label; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - and debugger = - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_DEBUGGER; - let pre_semicolon_trailing = - if Peek.token env = T_SEMICOLON then - Eat.trailing_comments env - else - [] - in - let trailing = - match semicolon env with - | Explicit trailing - | Implicit { trailing; _ } -> - pre_semicolon_trailing @ trailing - in - Statement.Debugger - { Statement.Debugger.comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - - and do_while = - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_DO; - let body = Parse.statement (env |> with_in_loop true) in - (* Annex B allows labelled FunctionDeclarations (see - sec-labelled-function-declarations), but not in IterationStatement - (see sec-semantics-static-semantics-early-errors). *) - if (not (in_strict_mode env)) && is_labelled_function body then - function_as_statement_error_at env (fst body); - let pre_keyword_trailing = Eat.trailing_comments env in - Expect.token env T_WHILE; - let pre_cond_trailing = Eat.trailing_comments env in - Expect.token env T_LPAREN; - let test = Parse.expression env in - Expect.token env T_RPAREN; - let past_cond_trailing = - if Peek.token env = T_SEMICOLON then - Eat.trailing_comments env - else - [] - in - (* The rules of automatic semicolon insertion in ES5 don't mention this, - * but the semicolon after a do-while loop is optional. This is properly - * specified in ES6 *) - let past_cond_trailing = - match semicolon ~required:false env with - | Explicit trailing -> past_cond_trailing @ trailing - | Implicit { trailing; _ } -> trailing - in - let trailing = pre_keyword_trailing @ pre_cond_trailing @ past_cond_trailing in - Statement.DoWhile - { - Statement.DoWhile.body; - test; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - and for_ = - let assert_can_be_forin_or_forof env err = function - | (loc, { Statement.VariableDeclaration.declarations; _ }) -> - (* Only a single declarator is allowed, without an init. So - * something like - * - * for (var x in y) {} - * - * is allowed, but we disallow - * - * for (var x, y in z) {} - * for (var x = 42 in y) {} - *) - (match declarations with - | [(_, { Statement.VariableDeclaration.Declarator.init = None; _ })] -> () - | _ -> error_at env (loc, err)) - in - (* Annex B allows labelled FunctionDeclarations (see - sec-labelled-function-declarations), but not in IterationStatement - (see sec-semantics-static-semantics-early-errors). *) - let assert_not_labelled_function env body = - if (not (in_strict_mode env)) && is_labelled_function body then - function_as_statement_error_at env (fst body) - else - () - in - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_FOR; - let async = allow_await env && Eat.maybe env T_AWAIT in - let leading = leading @ Peek.comments env in - Expect.token env T_LPAREN; - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - let (init, errs) = - let env = env |> with_no_in true in - match Peek.token env with - | T_SEMICOLON -> (None, []) - | T_LET -> - let (loc, (declarations, leading, errs)) = with_loc Declaration.let_ env in - ( Some - (For_declaration - ( loc, - { - Statement.VariableDeclaration.kind = Statement.VariableDeclaration.Let; - declarations; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - ), - errs - ) - | T_CONST -> - let (loc, (declarations, leading, errs)) = with_loc Declaration.const env in - ( Some - (For_declaration - ( loc, - { - Statement.VariableDeclaration.kind = Statement.VariableDeclaration.Const; - declarations; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - ), - errs - ) - | T_VAR -> - let (loc, (declarations, leading, errs)) = with_loc Declaration.var env in - ( Some - (For_declaration - ( loc, - { - Statement.VariableDeclaration.kind = Statement.VariableDeclaration.Var; - declarations; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - ), - errs - ) - | _ -> - let expr = Parse.expression_or_pattern (env |> with_no_let true) in - (Some (For_expression expr), []) - in - match Peek.token env with - | T_OF -> - (* This is a for of loop *) - let left = - match init with - | Some (For_declaration decl) -> - assert_can_be_forin_or_forof env Parse_error.InvalidLHSInForOf decl; - Statement.ForOf.LeftDeclaration decl - | Some (For_expression expr) -> - (* #sec-for-in-and-for-of-statements-static-semantics-early-errors *) - let patt = Pattern_cover.as_pattern ~err:Parse_error.InvalidLHSInForOf env expr in - Statement.ForOf.LeftPattern patt - | None -> assert false - in - Expect.token env T_OF; - let right = Parse.assignment env in - Expect.token env T_RPAREN; - let body = Parse.statement (env |> with_in_loop true) in - assert_not_labelled_function env body; - Statement.ForOf { Statement.ForOf.left; right; body; await = async; comments } - | T_IN -> - (* This is a for in loop *) - let left = - match init with - | Some (For_declaration decl) -> - assert_can_be_forin_or_forof env Parse_error.InvalidLHSInForIn decl; - Statement.ForIn.LeftDeclaration decl - | Some (For_expression expr) -> - (* #sec-for-in-and-for-of-statements-static-semantics-early-errors *) - let patt = Pattern_cover.as_pattern ~err:Parse_error.InvalidLHSInForIn env expr in - Statement.ForIn.LeftPattern patt - | None -> assert false - in - if async then - (* If `async` is true, this should have been a for-await-of loop, but we - recover by trying to parse like a for-in loop. *) - Expect.token env T_OF - else - Expect.token env T_IN; - let right = Parse.expression env in - Expect.token env T_RPAREN; - let body = Parse.statement (env |> with_in_loop true) in - assert_not_labelled_function env body; - Statement.ForIn { Statement.ForIn.left; right; body; each = false; comments } - | _ -> - (* This is a for loop *) - errs |> List.iter (error_at env); - if async then - (* If `async` is true, this should have been a for-await-of loop, but we - recover by trying to parse like a normal loop. *) - Expect.token env T_OF - else - Expect.token env T_SEMICOLON; - let init = - match init with - | Some (For_declaration decl) -> Some (Statement.For.InitDeclaration decl) - | Some (For_expression expr) -> - Some (Statement.For.InitExpression (Pattern_cover.as_expression env expr)) - | None -> None - in - let test = - match Peek.token env with - | T_SEMICOLON -> None - | _ -> Some (Parse.expression env) - in - Expect.token env T_SEMICOLON; - let update = - match Peek.token env with - | T_RPAREN -> None - | _ -> Some (Parse.expression env) - in - Expect.token env T_RPAREN; - let body = Parse.statement (env |> with_in_loop true) in - assert_not_labelled_function env body; - Statement.For { Statement.For.init; test; update; body; comments } - ) - - and if_ = - (* - * Either the consequent or alternate of an if statement - *) - let if_branch env = - (* Normally this would just be a Statement, but Annex B allows - FunctionDeclarations in non-strict mode. See - sec-functiondeclarations-in-ifstatement-statement-clauses *) - let stmt = - if Peek.is_function env then - function_as_statement env - else - Parse.statement env - in - (* Annex B allows labelled FunctionDeclarations in non-strict mode - (see sec-labelled-function-declarations), but not in IfStatement - (see sec-if-statement-static-semantics-early-errors). *) - if (not (in_strict_mode env)) && is_labelled_function stmt then - function_as_statement_error_at env (fst stmt); - - stmt - in - let alternate env = - let leading = Peek.comments env in - Expect.token env T_ELSE; - let body = if_branch env in - { Statement.If.Alternate.body; comments = Flow_ast_utils.mk_comments_opt ~leading () } - in - with_loc (fun env -> - let pre_if_leading = Peek.comments env in - Expect.token env T_IF; - let pre_cond_leading = Peek.comments env in - let leading = pre_if_leading @ pre_cond_leading in - Expect.token env T_LPAREN; - let test = Parse.expression env in - Expect.token env T_RPAREN; - let consequent = if_branch env in - let alternate = - if Peek.token env = T_ELSE then - Some (with_loc alternate env) - else - None - in - Statement.If - { - Statement.If.test; - consequent; - alternate; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - - and return = - with_loc (fun env -> - if not (in_function env) then error env Parse_error.IllegalReturn; - let leading = Peek.comments env in - let start_loc = Peek.loc env in - Expect.token env T_RETURN; - let trailing = - if Peek.token env = T_SEMICOLON then - Eat.trailing_comments env - else - [] - in - let argument = - if Peek.token env = T_SEMICOLON || Peek.is_implicit_semicolon env then - None - else - Some (Parse.expression env) - in - let return_out = Loc.btwn start_loc (Peek.loc env) in - let (trailing, argument) = - match (semicolon env, argument) with - | (Explicit comments, _) - | (Implicit { trailing = comments; _ }, None) -> - (trailing @ comments, argument) - | (Implicit { remove_trailing; _ }, Some arg) -> - (trailing, Some (remove_trailing arg (fun remover arg -> remover#expression arg))) - in - Statement.Return - { - Statement.Return.argument; - return_out; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - and switch = - let case ~seen_default env = - let leading = Peek.comments env in - let (test, trailing) = - match Peek.token env with - | T_DEFAULT -> - if seen_default then error env Parse_error.MultipleDefaultsInSwitch; - Expect.token env T_DEFAULT; - (None, Eat.trailing_comments env) - | _ -> - Expect.token env T_CASE; - (Some (Parse.expression env), []) - in - let seen_default = seen_default || test = None in - Expect.token env T_COLON; - let { trailing = line_end_trailing; _ } = statement_end_trailing_comments env in - let trailing = trailing @ line_end_trailing in - let term_fn = function - | T_RCURLY - | T_DEFAULT - | T_CASE -> - true - | _ -> false - in - let consequent = Parse.statement_list ~term_fn (env |> with_in_switch true) in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - let case = { Statement.Switch.Case.test; consequent; comments } in - (case, seen_default) - in - let rec case_list env (seen_default, acc) = - match Peek.token env with - | T_EOF - | T_RCURLY -> - List.rev acc - | _ -> - let (case_, seen_default) = with_loc_extra (case ~seen_default) env in - let acc = case_ :: acc in - case_list env (seen_default, acc) - in - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_SWITCH; - Expect.token env T_LPAREN; - let discriminant = Parse.expression env in - Expect.token env T_RPAREN; - Expect.token env T_LCURLY; - let cases = case_list env (false, []) in - Expect.token env T_RCURLY; - let { trailing; _ } = statement_end_trailing_comments env in - Statement.Switch - { - Statement.Switch.discriminant; - cases; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - exhaustive_out = fst discriminant; - } - ) - - and throw = - with_loc (fun env -> - let leading = Peek.comments env in - let start_loc = Peek.loc env in - Expect.token env T_THROW; - if Peek.is_line_terminator env then error_at env (start_loc, Parse_error.NewlineAfterThrow); - let argument = Parse.expression env in - let (trailing, argument) = - match semicolon env with - | Explicit trailing -> (trailing, argument) - | Implicit { remove_trailing; _ } -> - ([], remove_trailing argument (fun remover arg -> remover#expression arg)) - in - let open Statement in - Throw { Throw.argument; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - - and try_ = - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_TRY; - let block = - let block = Parse.block_body env in - if Peek.token env = T_CATCH then - block_remove_trailing env block - else - block - in - let handler = - match Peek.token env with - | T_CATCH -> - let catch = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_CATCH; - let trailing = Eat.trailing_comments env in - let param = - if Peek.token env = T_LPAREN then ( - Expect.token env T_LPAREN; - let p = Some (Parse.pattern env Parse_error.StrictCatchVariable) in - Expect.token env T_RPAREN; - p - ) else - None - in - let body = Parse.block_body env in - (* Fix trailing comment attachment if catch block is end of statement *) - let body = - if Peek.token env <> T_FINALLY then - let { remove_trailing; _ } = statement_end_trailing_comments env in - remove_trailing body (fun remover (loc, body) -> (loc, remover#block loc body)) - else - body - in - { - Ast.Statement.Try.CatchClause.param; - body; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - in - Some catch - | _ -> None - in - let finalizer = - match Peek.token env with - | T_FINALLY -> - Expect.token env T_FINALLY; - let (loc, body) = Parse.block_body env in - let { remove_trailing; _ } = statement_end_trailing_comments env in - let body = remove_trailing body (fun remover body -> remover#block loc body) in - Some (loc, body) - | _ -> None - in - (* No catch or finally? That's an error! *) - if handler = None && finalizer = None then - error_at env (fst block, Parse_error.NoCatchOrFinally); - - Statement.Try - { - Statement.Try.block; - handler; - finalizer; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - - and var = - with_loc (fun env -> - let kind = Statement.VariableDeclaration.Var in - let (declarations, leading, errs) = Declaration.var env in - let (trailing, declarations) = variable_declaration_end ~kind env declarations in - errs |> List.iter (error_at env); - Statement.VariableDeclaration - { - Statement.VariableDeclaration.kind; - declarations; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - and const = - with_loc (fun env -> - let kind = Statement.VariableDeclaration.Const in - let (declarations, leading, errs) = Declaration.const env in - let (trailing, declarations) = variable_declaration_end ~kind env declarations in - errs |> List.iter (error_at env); - Statement.VariableDeclaration - { - Statement.VariableDeclaration.kind; - declarations; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - and let_ = - with_loc (fun env -> - let kind = Statement.VariableDeclaration.Let in - let (declarations, leading, errs) = Declaration.let_ env in - let (trailing, declarations) = variable_declaration_end ~kind env declarations in - errs |> List.iter (error_at env); - Statement.VariableDeclaration - { - Statement.VariableDeclaration.kind; - declarations; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - and while_ = - with_loc (fun env -> - let leading = Peek.comments env in - Expect.token env T_WHILE; - let leading = leading @ Peek.comments env in - Expect.token env T_LPAREN; - let test = Parse.expression env in - Expect.token env T_RPAREN; - let body = Parse.statement (env |> with_in_loop true) in - (* Annex B allows labelled FunctionDeclarations in non-strict mode - (see sec-labelled-function-declarations), but not in IterationStatement - (see sec-semantics-static-semantics-early-errors). *) - if (not (in_strict_mode env)) && is_labelled_function body then - function_as_statement_error_at env (fst body); - Statement.While - { Statement.While.test; body; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - - and with_ env = - let (loc, stmt) = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_WITH; - let leading = leading @ Peek.comments env in - Expect.token env T_LPAREN; - let _object = Parse.expression env in - Expect.token env T_RPAREN; - let body = Parse.statement env in - (* Annex B allows labelled FunctionDeclarations in non-strict mode - (see sec-labelled-function-declarations), but not in WithStatement - (see sec-with-statement-static-semantics-early-errors). *) - if (not (in_strict_mode env)) && is_labelled_function body then - function_as_statement_error_at env (fst body); - Statement.With - { Statement.With._object; body; comments = Flow_ast_utils.mk_comments_opt ~leading () }) - env - in - strict_error_at env (loc, Parse_error.StrictModeWith); - (loc, stmt) - - and block env = - let (loc, block) = Parse.block_body env in - let { remove_trailing; _ } = statement_end_trailing_comments env in - let block = remove_trailing block (fun remover block -> remover#block loc block) in - (loc, Statement.Block block) - - and maybe_labeled = - with_loc (fun env -> - let leading = Peek.comments env in - match (Parse.expression env, Peek.token env) with - | ((loc, Ast.Expression.Identifier label), T_COLON) -> - let (_, { Identifier.name; comments = _ }) = label in - Expect.token env T_COLON; - if SSet.mem name (labels env) then - error_at env (loc, Parse_error.Redeclaration ("Label", name)); - let env = add_label env name in - let body = - (* labelled FunctionDeclarations are allowed in non-strict mode - (see #sec-labelled-function-declarations) *) - if Peek.is_function env then - function_as_statement env - else - Parse.statement env - in - Statement.Labeled - { Statement.Labeled.label; body; comments = Flow_ast_utils.mk_comments_opt ~leading () } - | (expression, _) -> - let (trailing, expression) = - match semicolon ~expected:"the end of an expression statement (`;`)" env with - | Explicit comments -> (comments, expression) - | Implicit { remove_trailing; _ } -> - ([], remove_trailing expression (fun remover expr -> remover#expression expr)) - in - let open Statement in - Expression - { - Expression.expression; - directive = None; - comments = Flow_ast_utils.mk_comments_opt ~trailing (); - } - ) - - and expression = - with_loc (fun env -> - let expression = Parse.expression env in - let (trailing, expression) = - match semicolon ~expected:"the end of an expression statement (`;`)" env with - | Explicit comments -> (comments, expression) - | Implicit { remove_trailing; _ } -> - ([], remove_trailing expression (fun remover expr -> remover#expression expr)) - in - let directive = - if allow_directive env then - match expression with - | (_, Ast.Expression.Literal { Ast.Literal.value = Ast.Literal.String _; raw; _ }) -> - (* the parser may recover from errors and generate unclosed strings, where - the opening quote should be reliable but the closing one might not exist. - be defensive. *) - if String.length raw > 1 && raw.[0] = raw.[String.length raw - 1] then - Some (String.sub raw 1 (String.length raw - 2)) - else - None - | _ -> None - else - None - in - Statement.Expression - { - Statement.Expression.expression; - directive; - comments = Flow_ast_utils.mk_comments_opt ~trailing (); - } - ) - - and type_alias_helper ~leading env = - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeAlias; - let leading = leading @ Peek.comments env in - Expect.token env T_TYPE; - Eat.push_lex_mode env Lex_mode.TYPE; - let id = - let id = Type.type_identifier env in - if Peek.token env = T_LESS_THAN then - id_remove_trailing env id - else - id - in - let tparams = Type.type_params env in - Expect.token env T_ASSIGN; - let right = Type._type env in - Eat.pop_lex_mode env; - let (trailing, right) = - match semicolon env with - | Explicit comments -> (comments, right) - | Implicit { remove_trailing; _ } -> - ([], remove_trailing right (fun remover right -> remover#type_ right)) - in - - { - Statement.TypeAlias.id; - tparams; - right; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - - and declare_type_alias env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_DECLARE; - let type_alias = type_alias_helper ~leading env in - Statement.DeclareTypeAlias type_alias) - env - - (** Type aliases squeeze into an unambiguous unused portion of the grammar: `type` is not a - reserved word, so `type T` is otherwise two identifiers in a row and that's never valid JS. - However, if there's a line separator between the two, ASI makes it valid JS, so line - separators are disallowed. *) - and type_alias env = - if Peek.ith_is_identifier ~i:1 env && not (Peek.ith_is_implicit_semicolon ~i:1 env) then - let (loc, type_alias) = with_loc (type_alias_helper ~leading:[]) env in - (loc, Statement.TypeAlias type_alias) - else - Parse.statement env - - and opaque_type_helper ?(declare = false) ~leading env = - if not (should_parse_types env) then error env Parse_error.UnexpectedOpaqueTypeAlias; - let leading_opaque = leading @ Peek.comments env in - Expect.token env T_OPAQUE; - let leading_type = Peek.comments env in - Expect.token env T_TYPE; - let leading = leading_opaque @ leading_type in - Eat.push_lex_mode env Lex_mode.TYPE; - let id = - let id = Type.type_identifier env in - if Peek.token env = T_LESS_THAN then - id_remove_trailing env id - else - id - in - let tparams = Type.type_params env in - let supertype = - match Peek.token env with - | T_COLON -> - Expect.token env T_COLON; - Some (Type._type env) - | _ -> None - in - let impltype = - if declare then - match Peek.token env with - | T_ASSIGN -> - error env Parse_error.DeclareOpaqueTypeInitializer; - Eat.token env; - if Peek.token env = T_SEMICOLON || Peek.is_implicit_semicolon env then - None - else - Some (Type._type env) - | _ -> None - else ( - Expect.token env T_ASSIGN; - Some (Type._type env) - ) - in - Eat.pop_lex_mode env; - let (trailing, id, tparams, supertype, impltype) = - match (semicolon env, tparams, supertype, impltype) with - (* opaque type Foo = Bar; *) - | (Explicit comments, _, _, _) -> (comments, id, tparams, supertype, impltype) - (* opaque type Foo = Bar *) - | (Implicit { remove_trailing; _ }, _, _, Some impl) -> - ( [], - id, - tparams, - supertype, - Some (remove_trailing impl (fun remover impl -> remover#type_ impl)) - ) - (* opaque type Foo: Super *) - | (Implicit { remove_trailing; _ }, _, Some super, None) -> - ( [], - id, - tparams, - Some (remove_trailing super (fun remover super -> remover#type_ super)), - None - ) - (* opaque type Foo *) - | (Implicit { remove_trailing; _ }, Some tparams, None, None) -> - ( [], - id, - Some (remove_trailing tparams (fun remover tparams -> remover#type_params tparams)), - None, - None - ) - (* declare opaque type Foo *) - | (Implicit { remove_trailing; _ }, None, None, None) -> - ([], remove_trailing id (fun remover id -> remover#identifier id), None, None, None) - in - - { - Statement.OpaqueType.id; - tparams; - impltype; - supertype; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - - and declare_opaque_type env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_DECLARE; - let opaque_t = opaque_type_helper ~declare:true ~leading env in - Statement.DeclareOpaqueType opaque_t) - env - - and opaque_type env = - match Peek.ith_token ~i:1 env with - | T_TYPE -> - let (loc, opaque_t) = with_loc (opaque_type_helper ~declare:false ~leading:[]) env in - (loc, Statement.OpaqueType opaque_t) - | _ -> Parse.statement env - - and interface_helper ~leading env = - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeInterface; - let leading = leading @ Peek.comments env in - Expect.token env T_INTERFACE; - let id = - let id = Type.type_identifier env in - if Peek.token env = T_EXTENDS then - id - else - id_remove_trailing env id - in - let tparams = - let tparams = Type.type_params env in - if Peek.token env = T_EXTENDS then - tparams - else - type_params_remove_trailing env tparams - in - let (extends, body) = Type.interface_helper env in - let { remove_trailing; _ } = statement_end_trailing_comments env in - let body = - remove_trailing body (fun remover (loc, body) -> (loc, remover#object_type loc body)) - in - - { - Statement.Interface.id; - tparams; - body; - extends; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - - and declare_interface env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_DECLARE; - let iface = interface_helper ~leading env in - Statement.DeclareInterface iface) - env - - and interface env = - (* disambiguate between a value named `interface`, like `var interface = 1; interface++`, - and an interface declaration like `interface Foo {}`.` *) - if Peek.ith_is_identifier_name ~i:1 env then - let (loc, iface) = with_loc (interface_helper ~leading:[]) env in - (loc, Statement.InterfaceDeclaration iface) - else - expression env - - and declare_class = - let rec mixins env acc = - let super = Type.generic env in - let acc = super :: acc in - match Peek.token env with - | T_COMMA -> - Expect.token env T_COMMA; - mixins env acc - | _ -> List.rev acc - (* This is identical to `interface`, except that mixins are allowed *) - in - fun ~leading env -> - let env = env |> with_strict true in - let leading = leading @ Peek.comments env in - Expect.token env T_CLASS; - let id = - let id = Parse.identifier env in - match Peek.token env with - | T_LESS_THAN - | T_LCURLY -> - id_remove_trailing env id - | _ -> id - in - let tparams = - let tparams = Type.type_params env in - match Peek.token env with - | T_LCURLY -> type_params_remove_trailing env tparams - | _ -> tparams - in - let extends = - if Eat.maybe env T_EXTENDS then - let extends = Type.generic env in - match Peek.token env with - | T_LCURLY -> Some (generic_type_remove_trailing env extends) - | _ -> Some extends - else - None - in - let mixins = - match Peek.token env with - | T_IDENTIFIER { raw = "mixins"; _ } -> - Eat.token env; - let mixins = mixins env [] in - (match Peek.token env with - | T_LCURLY -> generic_type_list_remove_trailing env mixins - | _ -> mixins) - | _ -> [] - in - let implements = - match Peek.token env with - | T_IMPLEMENTS -> - let implements = Object.class_implements env ~attach_leading:false in - (match Peek.token env with - | T_LCURLY -> Some (class_implements_remove_trailing env implements) - | _ -> Some implements) - | _ -> None - in - let body = Type._object ~is_class:true env in - let { remove_trailing; _ } = statement_end_trailing_comments env in - let body = - remove_trailing body (fun remover (loc, body) -> (loc, remover#object_type loc body)) - in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Statement.DeclareClass.{ id; tparams; body; extends; mixins; implements; comments } - - and declare_class_statement env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_DECLARE; - let fn = declare_class ~leading env in - Statement.DeclareClass fn) - env - - and declare_function ?(leading = []) env = - let leading = leading @ Peek.comments env in - Expect.token env T_FUNCTION; - let id = id_remove_trailing env (Parse.identifier env) in - let annot = - with_loc - (fun env -> - let tparams = type_params_remove_trailing env (Type.type_params env) in - let params = Type.function_param_list env in - Expect.token env T_COLON; - let return = - let return = Type._type env in - let has_predicate = - Eat.push_lex_mode env Lex_mode.TYPE; - let type_token = Peek.token env in - Eat.pop_lex_mode env; - type_token = T_CHECKS - in - if has_predicate then - type_remove_trailing env return - else - return - in - Ast.Type.(Function { Function.params; return; tparams; comments = None })) - env - in - let predicate = Type.predicate_opt env in - let (trailing, annot, predicate) = - match (semicolon env, predicate) with - | (Explicit comments, _) -> (comments, annot, predicate) - | (Implicit { remove_trailing; _ }, None) -> - ([], remove_trailing annot (fun remover annot -> remover#type_ annot), None) - | (Implicit { remove_trailing; _ }, Some pred) -> - ([], annot, Some (remove_trailing pred (fun remover pred -> remover#predicate pred))) - in - let annot = (fst annot, annot) in - - { - Statement.DeclareFunction.id; - annot; - predicate; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - - and declare_function_statement env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_DECLARE; - begin - match Peek.token env with - | T_ASYNC -> - error env Parse_error.DeclareAsync; - Expect.token env T_ASYNC - | _ -> () - end; - let fn = declare_function ~leading env in - Statement.DeclareFunction fn) - env - - and declare_var env leading = - let leading = leading @ Peek.comments env in - Expect.token env T_VAR; - let name = Parse.identifier ~restricted_error:Parse_error.StrictVarName env in - let annot = Type.annotation env in - let (trailing, name, annot) = - match semicolon env with - (* declare var x; *) - | Explicit trailing -> (trailing, name, annot) - (* declare var x *) - | Implicit { remove_trailing; _ } -> - ([], name, remove_trailing annot (fun remover annot -> remover#type_annotation annot)) - in - - { - Statement.DeclareVariable.id = name; - annot; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - - and declare_var_statement env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_DECLARE; - let var = declare_var env leading in - Statement.DeclareVariable var) - env - - and declare_module = - let rec module_items env ~module_kind acc = - match Peek.token env with - | T_EOF - | T_RCURLY -> - (module_kind, List.rev acc) - | _ -> - let stmt = declare ~in_module:true env in - (* TODO: This is a semantic analysis and shouldn't be in the parser *) - let module_kind = - let open Statement in - let (_loc, stmt) = stmt in - match (module_kind, stmt) with - (* - * The first time we see either a `declare export` or a - * `declare module.exports`, we lock in the kind of the module. - * - * `declare export type` and `declare export interface` are the two - * exceptions to this rule because they are valid in both CommonJS - * and ES modules (and thus do not indicate an intent for either). - *) - | (None, DeclareModuleExports _) -> Some DeclareModule.CommonJS - | (None, DeclareExportDeclaration { DeclareExportDeclaration.declaration; _ }) -> - (match declaration with - | Some (DeclareExportDeclaration.NamedType _) - | Some (DeclareExportDeclaration.Interface _) -> - module_kind - | _ -> Some DeclareModule.ES) - (* - * There should never be more than one `declare module.exports` - * statement *) - | (Some DeclareModule.CommonJS, DeclareModuleExports _) -> - error env Parse_error.DuplicateDeclareModuleExports; - module_kind - (* - * It's never ok to mix and match `declare export` and - * `declare module.exports` in the same module because it leaves the - * kind of the module (CommonJS vs ES) ambiguous. - * - * The 1 exception to this rule is that `export type/interface` are - * both ok in CommonJS modules. - *) - | (Some DeclareModule.ES, DeclareModuleExports _) -> - error env Parse_error.AmbiguousDeclareModuleKind; - module_kind - | ( Some DeclareModule.CommonJS, - DeclareExportDeclaration { DeclareExportDeclaration.declaration; _ } - ) -> - (match declaration with - | Some (DeclareExportDeclaration.NamedType _) - | Some (DeclareExportDeclaration.Interface _) -> - () - | _ -> error env Parse_error.AmbiguousDeclareModuleKind); - module_kind - | _ -> module_kind - in - module_items env ~module_kind (stmt :: acc) - in - let declare_module_ ~leading env = - let id = - match Peek.token env with - | T_STRING str -> - Statement.DeclareModule.Literal - (string_literal_remove_trailing env (string_literal env str)) - | _ -> Statement.DeclareModule.Identifier (id_remove_trailing env (Parse.identifier env)) - in - let (body, module_kind) = - with_loc_extra - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LCURLY; - let (module_kind, body) = module_items env ~module_kind:None [] in - let internal = - if body = [] then - Peek.comments env - else - [] - in - Expect.token env T_RCURLY; - let { trailing; _ } = statement_end_trailing_comments env in - let comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal () - in - let body = { Statement.Block.body; comments } in - (body, module_kind)) - env - in - let kind = - match module_kind with - | Some k -> k - | None -> Statement.DeclareModule.CommonJS - in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Statement.(DeclareModule DeclareModule.{ id; body; kind; comments }) - in - fun ~in_module env -> - let start_loc = Peek.loc env in - let leading = Peek.comments env in - Expect.token env T_DECLARE; - let leading = leading @ Peek.comments env in - Expect.identifier env "module"; - if in_module || Peek.token env = T_PERIOD then - with_loc ~start_loc (declare_module_exports ~leading) env - else - with_loc ~start_loc (declare_module_ ~leading) env - - and declare_module_exports ~leading env = - let leading_period = Peek.comments env in - Expect.token env T_PERIOD; - let leading_exports = Peek.comments env in - Expect.identifier env "exports"; - let leading_annot = Peek.comments env in - let leading = List.concat [leading; leading_period; leading_exports; leading_annot] in - let annot = Type.annotation env in - let (annot, trailing) = - match semicolon env with - | Explicit trailing -> (annot, trailing) - | Implicit { remove_trailing; _ } -> - (remove_trailing annot (fun remover annot -> remover#type_annotation annot), []) - in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - Statement.DeclareModuleExports { Statement.DeclareModuleExports.annot; comments } - - and declare ?(in_module = false) env = - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeDeclaration; - - (* eventually, just emit a wrapper AST node *) - match Peek.ith_token ~i:1 env with - | T_CLASS -> declare_class_statement env - | T_INTERFACE -> declare_interface env - | T_TYPE -> - (match Peek.token env with - | T_IMPORT when in_module -> import_declaration env - | _ -> declare_type_alias env) - | T_OPAQUE -> declare_opaque_type env - | T_TYPEOF when Peek.token env = T_IMPORT -> import_declaration env - | T_FUNCTION - | T_ASYNC -> - declare_function_statement env - | T_VAR -> declare_var_statement env - | T_EXPORT when in_module -> declare_export_declaration ~allow_export_type:in_module env - | T_IDENTIFIER { raw = "module"; _ } -> declare_module ~in_module env - | _ when in_module -> - (match Peek.token env with - | T_IMPORT -> - error env Parse_error.InvalidNonTypeImportInDeclareModule; - Parse.statement env - | _ -> - (* Oh boy, found some bad stuff in a declare module. Let's just - * pretend it's a declare var (arbitrary choice) *) - declare_var_statement env) - | _ -> Parse.statement env - - and export_source env = - Expect.identifier env "from"; - match Peek.token env with - | T_STRING str -> string_literal env str - | _ -> - (* Just make up a string for the error case *) - let ret = (Peek.loc env, { StringLiteral.value = ""; raw = ""; comments = None }) in - error_unexpected ~expected:"a string" env; - ret - - and export_source_and_semicolon env = - let (source_loc, source) = export_source env in - match semicolon env with - | Explicit trailing -> ((source_loc, source), trailing) - | Implicit { remove_trailing; _ } -> - ( ( source_loc, - remove_trailing source (fun remover source -> - remover#string_literal_type source_loc source - ) - ), - [] - ) - - and export_specifiers ?(preceding_comma = true) env specifiers = - match Peek.token env with - | T_EOF - | T_RCURLY -> - List.rev specifiers - | _ -> - if not preceding_comma then error env Parse_error.ExportSpecifierMissingComma; - let specifier = - with_loc - (fun env -> - let local = identifier_name env in - let exported = - match Peek.token env with - | T_IDENTIFIER { raw = "as"; _ } -> - Eat.token env; - Some (identifier_name env) - | _ -> None - in - { Statement.ExportNamedDeclaration.ExportSpecifier.local; exported }) - env - in - let preceding_comma = Eat.maybe env T_COMMA in - export_specifiers ~preceding_comma env (specifier :: specifiers) - - and assert_export_specifier_identifiers env specifiers = - Statement.ExportNamedDeclaration.ExportSpecifier.( - List.iter - (function - | (_, { local = id; exported = None }) -> - assert_identifier_name_is_identifier ~restricted_error:Parse_error.StrictVarName env id - | _ -> ()) - specifiers - ) - - and export_declaration ~decorators env = - let env = env |> with_strict true |> with_in_export true in - let leading = Peek.comments env in - let start_loc = Peek.loc env in - Expect.token env T_EXPORT; - match Peek.token env with - | T_DEFAULT -> - (* export default ... *) - with_loc - ~start_loc - (fun env -> - let open Statement.ExportDefaultDeclaration in - let leading = leading @ Peek.comments env in - let (default, ()) = with_loc (fun env -> Expect.token env T_DEFAULT) env in - let env = with_in_export_default true env in - let (declaration, trailing) = - if Peek.is_function env then - (* export default [async] function [foo] (...) { ... } *) - let fn = Declaration._function env in - (Declaration fn, []) - else if Peek.is_class env then - (* export default class foo { ... } *) - let _class = Object.class_declaration env decorators in - (Declaration _class, []) - else if Peek.token env = T_ENUM then - (* export default enum foo { ... } *) - (Declaration (Declaration.enum_declaration env), []) - else - (* export default [assignment expression]; *) - let expr = Parse.assignment env in - let (expr, trailing) = - match semicolon env with - | Explicit trailing -> (expr, trailing) - | Implicit { remove_trailing; _ } -> - (remove_trailing expr (fun remover expr -> remover#expression expr), []) - in - (Expression expr, trailing) - in - Statement.ExportDefaultDeclaration - { - default; - declaration; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - | T_TYPE when Peek.ith_token ~i:1 env <> T_LCURLY -> - (* export type ... *) - with_loc - ~start_loc - (fun env -> - let open Statement.ExportNamedDeclaration in - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeExport; - match Peek.ith_token ~i:1 env with - | T_MULT -> - Expect.token env T_TYPE; - let specifier_loc = Peek.loc env in - Expect.token env T_MULT; - let (source, trailing) = export_source_and_semicolon env in - Statement.ExportNamedDeclaration - { - declaration = None; - specifiers = Some (ExportBatchSpecifier (specifier_loc, None)); - source = Some source; - export_kind = Statement.ExportType; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - | T_ENUM -> - error env Parse_error.EnumInvalidExport; - Expect.token env T_TYPE; - Statement.ExportNamedDeclaration - { - declaration = None; - specifiers = None; - source = None; - export_kind = Statement.ExportType; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - | _ -> - let (loc, type_alias) = with_loc (type_alias_helper ~leading:[]) env in - let type_alias = (loc, Statement.TypeAlias type_alias) in - Statement.ExportNamedDeclaration - { - declaration = Some type_alias; - specifiers = None; - source = None; - export_kind = Statement.ExportType; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | T_OPAQUE -> - (* export opaque type ... *) - with_loc - ~start_loc - (fun env -> - let open Statement.ExportNamedDeclaration in - let (loc, opaque_t) = with_loc (opaque_type_helper ~leading:[]) env in - let opaque_t = (loc, Statement.OpaqueType opaque_t) in - Statement.ExportNamedDeclaration - { - declaration = Some opaque_t; - specifiers = None; - source = None; - export_kind = Statement.ExportType; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | T_INTERFACE -> - (* export interface I { ... } *) - with_loc - ~start_loc - (fun env -> - let open Statement.ExportNamedDeclaration in - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeExport; - let interface = - let (loc, iface) = with_loc (interface_helper ~leading:[]) env in - (loc, Statement.InterfaceDeclaration iface) - in - Statement.ExportNamedDeclaration - { - declaration = Some interface; - specifiers = None; - source = None; - export_kind = Statement.ExportType; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | _ when Peek.is_class env -> - with_loc - ~start_loc - (fun env -> - let stmt = Object.class_declaration env decorators in - Statement.ExportNamedDeclaration - { - Statement.ExportNamedDeclaration.declaration = Some stmt; - specifiers = None; - source = None; - export_kind = Statement.ExportValue; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | _ when Peek.is_function env -> - with_loc - ~start_loc - (fun env -> - error_on_decorators env decorators; - let stmt = Declaration._function env in - Statement.ExportNamedDeclaration - { - Statement.ExportNamedDeclaration.declaration = Some stmt; - specifiers = None; - source = None; - export_kind = Statement.ExportValue; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | T_LET - | T_CONST - | T_VAR -> - with_loc - ~start_loc - (fun env -> - let stmt = Parse.statement_list_item env ~decorators in - Statement.ExportNamedDeclaration - { - Statement.ExportNamedDeclaration.declaration = Some stmt; - specifiers = None; - source = None; - export_kind = Statement.ExportValue; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | T_ENUM when (parse_options env).enums -> - with_loc - ~start_loc - (fun env -> - let stmt = Parse.statement_list_item env ~decorators in - Statement.ExportNamedDeclaration - { - Statement.ExportNamedDeclaration.declaration = Some stmt; - specifiers = None; - source = None; - export_kind = Statement.ExportValue; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | T_MULT -> - with_loc - ~start_loc - (fun env -> - let open Statement.ExportNamedDeclaration in - let loc = Peek.loc env in - Expect.token env T_MULT; - let local_name = - match Peek.token env with - | T_IDENTIFIER { raw = "as"; _ } -> - Eat.token env; - Some (Parse.identifier env) - | _ -> None - in - let specifiers = Some (ExportBatchSpecifier (loc, local_name)) in - let (source, trailing) = export_source_and_semicolon env in - Statement.ExportNamedDeclaration - { - declaration = None; - specifiers; - source = Some source; - export_kind = Statement.ExportValue; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - | _ -> - let open Statement.ExportNamedDeclaration in - let export_kind = - if Eat.maybe env T_TYPE then - Statement.ExportType - else - Statement.ExportValue - in - if Eat.maybe env T_LCURLY then - with_loc - ~start_loc - (fun env -> - let specifiers = export_specifiers env [] in - Expect.token env T_RCURLY; - let (source, trailing) = - match Peek.token env with - | T_IDENTIFIER { raw = "from"; _ } -> - let (source, trailing) = export_source_and_semicolon env in - (Some source, trailing) - | _ -> - assert_export_specifier_identifiers env specifiers; - let trailing = - match semicolon env with - | Explicit trailing -> trailing - | Implicit { trailing; _ } -> trailing - in - (None, trailing) - in - Statement.ExportNamedDeclaration - { - declaration = None; - specifiers = Some (ExportSpecifiers specifiers); - source; - export_kind; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - else ( - (* error. recover by ignoring the `export` *) - error_unexpected ~expected:"a declaration, statement or export specifiers" env; - Parse.statement_list_item env ~decorators - ) - - and declare_export_declaration ?(allow_export_type = false) = - with_loc (fun env -> - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeDeclaration; - let leading = Peek.comments env in - Expect.token env T_DECLARE; - let env = env |> with_strict true |> with_in_export true in - let leading = leading @ Peek.comments env in - Expect.token env T_EXPORT; - Statement.DeclareExportDeclaration.( - match Peek.token env with - | T_DEFAULT -> - (* declare export default ... *) - let leading = leading @ Peek.comments env in - let (default, ()) = with_loc (fun env -> Expect.token env T_DEFAULT) env in - let env = with_in_export_default true env in - let (declaration, trailing) = - match Peek.token env with - | T_FUNCTION -> - (* declare export default function foo (...): ... *) - let fn = with_loc declare_function env in - (Some (Function fn), []) - | T_CLASS -> - (* declare export default class foo { ... } *) - let class_ = with_loc (declare_class ~leading:[]) env in - (Some (Class class_), []) - | _ -> - (* declare export default [type]; *) - let type_ = Type._type env in - let (type_, trailing) = - match semicolon env with - | Explicit trailing -> (type_, trailing) - | Implicit { remove_trailing; _ } -> - (remove_trailing type_ (fun remover type_ -> remover#type_ type_), []) - in - (Some (DefaultType type_), trailing) - in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - Statement.DeclareExportDeclaration - { default = Some default; declaration; specifiers = None; source = None; comments } - | T_LET - | T_CONST - | T_VAR - | T_CLASS - | T_FUNCTION -> - let declaration = - match Peek.token env with - | T_FUNCTION -> - (* declare export function foo (...): ... *) - let fn = with_loc declare_function env in - Some (Function fn) - | T_CLASS -> - (* declare export class foo { ... } *) - let class_ = with_loc (declare_class ~leading:[]) env in - Some (Class class_) - | (T_LET | T_CONST | T_VAR) as token -> - (match token with - | T_LET -> error env Parse_error.DeclareExportLet - | T_CONST -> error env Parse_error.DeclareExportConst - | _ -> ()); - - (* declare export var foo: ... *) - let var = with_loc (fun env -> declare_var env []) env in - Some (Variable var) - | _ -> assert false - in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Statement.DeclareExportDeclaration - { default = None; declaration; specifiers = None; source = None; comments } - | T_MULT -> - (* declare export * from 'foo' *) - let loc = Peek.loc env in - Expect.token env T_MULT; - let local_name = - match Peek.token env with - | T_IDENTIFIER { raw = "as"; _ } -> - Eat.token env; - Some (Parse.identifier env) - | _ -> None - in - let specifiers = - Statement.ExportNamedDeclaration.(Some (ExportBatchSpecifier (loc, local_name))) - in - let (source, trailing) = export_source_and_semicolon env in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - Statement.DeclareExportDeclaration - { default = None; declaration = None; specifiers; source = Some source; comments } - | T_TYPE when allow_export_type -> - (* declare export type = ... *) - let alias = with_loc (type_alias_helper ~leading:[]) env in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Statement.DeclareExportDeclaration - { - default = None; - declaration = Some (NamedType alias); - specifiers = None; - source = None; - comments; - } - | T_OPAQUE -> - (* declare export opaque type = ... *) - let opaque = with_loc (opaque_type_helper ~declare:true ~leading:[]) env in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Statement.DeclareExportDeclaration - { - default = None; - declaration = Some (NamedOpaqueType opaque); - specifiers = None; - source = None; - comments; - } - | T_INTERFACE when allow_export_type -> - (* declare export interface ... *) - let iface = with_loc (interface_helper ~leading:[]) env in - let comments = Flow_ast_utils.mk_comments_opt ~leading () in - Statement.DeclareExportDeclaration - { - default = None; - declaration = Some (Interface iface); - specifiers = None; - source = None; - comments; - } - | _ -> - (match Peek.token env with - | T_TYPE -> error env Parse_error.DeclareExportType - | T_INTERFACE -> error env Parse_error.DeclareExportInterface - | _ -> ()); - Expect.token env T_LCURLY; - let specifiers = export_specifiers env [] in - Expect.token env T_RCURLY; - let (source, trailing) = - match Peek.token env with - | T_IDENTIFIER { raw = "from"; _ } -> - let (source, trailing) = export_source_and_semicolon env in - (Some source, trailing) - | _ -> - assert_export_specifier_identifiers env specifiers; - let trailing = - match semicolon env with - | Explicit trailing -> trailing - | Implicit { trailing; _ } -> trailing - in - (None, trailing) - in - let comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () in - Statement.DeclareExportDeclaration - { - default = None; - declaration = None; - specifiers = Some (Statement.ExportNamedDeclaration.ExportSpecifiers specifiers); - source; - comments; - } - ) - ) - - and import_declaration = - Statement.ImportDeclaration.( - let missing_source env = - (* Just make up a string for the error case *) - let loc = Peek.loc_skip_lookahead env in - (loc, { StringLiteral.value = ""; raw = ""; comments = None }) - in - let source env = - match Peek.token env with - | T_IDENTIFIER { raw = "from"; _ } -> - Eat.token env; - (match Peek.token env with - | T_STRING str -> string_literal env str - | _ -> - error_unexpected ~expected:"a string" env; - missing_source env) - | _ -> - error_unexpected ~expected:"the keyword `from`" env; - missing_source env - in - let is_type_import = function - | T_TYPE - | T_TYPEOF -> - true - | _ -> false - (* `x` or `x as y` in a specifier *) - in - let with_maybe_as ~for_type ?error_if_type env = - let identifier env = - if for_type then - Type.type_identifier env - else - Parse.identifier env - in - match Peek.ith_token ~i:1 env with - | T_IDENTIFIER { raw = "as"; _ } -> - let remote = identifier_name env in - Eat.token env; - - (* as *) - let local = Some (identifier env) in - (remote, local) - | T_EOF - | T_COMMA - | T_RCURLY -> - (identifier env, None) - | _ -> - begin - match (error_if_type, Peek.token env) with - | (Some error_if_type, T_TYPE) - | (Some error_if_type, T_TYPEOF) -> - error env error_if_type; - Eat.token env; - - (* consume `type` or `typeof` *) - (Type.type_identifier env, None) - | _ -> (identifier env, None) - end - (* - ImportSpecifier[Type]: - [~Type] ImportedBinding - [~Type] IdentifierName ImportedTypeBinding - [~Type] IdentifierName IdentifierName ImportedBinding - [~Type] IdentifierName IdentifierName IdentifierName ImportedTypeBinding - [+Type] ImportedTypeBinding - [+Type] IdentifierName IdentifierName ImportedTypeBinding - - Static Semantics: - - `IdentifierName ImportedTypeBinding`: - - It is a Syntax Error if IdentifierName's StringValue is not "type" or "typeof" - - `IdentifierName IdentifierName ImportedBinding`: - - It is a Syntax Error if the second IdentifierName's StringValue is not "as" - - `IdentifierName IdentifierName IdentifierName ImportedTypeBinding`: - - It is a Syntax Error if the first IdentifierName's StringValue is not "type" - or "typeof", and the third IdentifierName's StringValue is not "as" - *) - in - - let specifier env = - let kind = - match Peek.token env with - | T_TYPE -> Some ImportType - | T_TYPEOF -> Some ImportTypeof - | _ -> None - in - if is_type_import (Peek.token env) then - (* consume `type`, but we don't know yet whether this is `type foo` or - `type as foo`. *) - let type_keyword_or_remote = identifier_name env in - match Peek.token env with - (* `type` (a value) *) - | T_EOF - | T_RCURLY - | T_COMMA -> - let remote = type_keyword_or_remote in - (* `type` becomes a value *) - assert_identifier_name_is_identifier env remote; - { remote; local = None; kind = None } - (* `type as foo` (value named `type`) or `type as,` (type named `as`) *) - | T_IDENTIFIER { raw = "as"; _ } -> - begin - match Peek.ith_token ~i:1 env with - | T_EOF - | T_RCURLY - | T_COMMA -> - (* `type as` *) - { remote = Type.type_identifier env; local = None; kind } - | T_IDENTIFIER { raw = "as"; _ } -> - (* `type as as foo` *) - let remote = identifier_name env in - (* first `as` *) - Eat.token env; - - (* second `as` *) - let local = Some (Type.type_identifier env) in - (* `foo` *) - { remote; local; kind } - | _ -> - (* `type as foo` *) - let remote = type_keyword_or_remote in - (* `type` becomes a value *) - assert_identifier_name_is_identifier env remote; - Eat.token env; - - (* `as` *) - let local = Some (Parse.identifier env) in - { remote; local; kind = None } - end - (* `type x`, or `type x as y` *) - | _ -> - let (remote, local) = with_maybe_as ~for_type:true env in - { remote; local; kind } - else - (* standard `x` or `x as y` *) - let (remote, local) = with_maybe_as ~for_type:false env in - { remote; local; kind = None } - (* specifier in an `import type { ... }` *) - in - let type_specifier env = - let (remote, local) = - with_maybe_as - env - ~for_type:true - ~error_if_type:Parse_error.ImportTypeShorthandOnlyInPureImport - in - { remote; local; kind = None } - (* specifier in an `import typeof { ... }` *) - in - let typeof_specifier env = - let (remote, local) = - with_maybe_as - env - ~for_type:true - ~error_if_type:Parse_error.ImportTypeShorthandOnlyInPureImport - in - { remote; local; kind = None } - in - let rec specifier_list ?(preceding_comma = true) env statement_kind acc = - match Peek.token env with - | T_EOF - | T_RCURLY -> - List.rev acc - | _ -> - if not preceding_comma then error env Parse_error.ImportSpecifierMissingComma; - let specifier = - match statement_kind with - | ImportType -> type_specifier env - | ImportTypeof -> typeof_specifier env - | ImportValue -> specifier env - in - let preceding_comma = Eat.maybe env T_COMMA in - specifier_list ~preceding_comma env statement_kind (specifier :: acc) - in - let named_or_namespace_specifier env import_kind = - match Peek.token env with - | T_MULT -> - let id = - with_loc_opt - (fun env -> - (* consume T_MULT *) - Eat.token env; - match Peek.token env with - | T_IDENTIFIER { raw = "as"; _ } -> - (* consume "as" *) - Eat.token env; - (match import_kind with - | ImportType - | ImportTypeof -> - Some (Type.type_identifier env) - | ImportValue -> Some (Parse.identifier env)) - | _ -> - error_unexpected ~expected:"the keyword `as`" env; - None) - env - in - (match id with - | Some id -> Some (ImportNamespaceSpecifier id) - | None -> None) - | _ -> - Expect.token env T_LCURLY; - let specifiers = specifier_list env import_kind [] in - Expect.token env T_RCURLY; - Some (ImportNamedSpecifiers specifiers) - in - let semicolon_and_trailing env source = - match semicolon env with - | Explicit trailing -> (trailing, source) - | Implicit { remove_trailing; _ } -> - ( [], - remove_trailing source (fun remover (loc, source) -> - (loc, remover#string_literal_type loc source) - ) - ) - in - let with_specifiers import_kind env leading = - let specifiers = named_or_namespace_specifier env import_kind in - let source = source env in - let (trailing, source) = semicolon_and_trailing env source in - Statement.ImportDeclaration - { - import_kind; - source; - specifiers; - default = None; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - in - let with_default import_kind env leading = - let default_specifier = - match import_kind with - | ImportType - | ImportTypeof -> - Type.type_identifier env - | ImportValue -> Parse.identifier env - in - let additional_specifiers = - match Peek.token env with - | T_COMMA -> - (* `import Foo, ...` *) - Expect.token env T_COMMA; - named_or_namespace_specifier env import_kind - | _ -> None - in - let source = source env in - let (trailing, source) = semicolon_and_trailing env source in - Statement.ImportDeclaration - { - import_kind; - source; - specifiers = additional_specifiers; - default = Some default_specifier; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - in - with_loc (fun env -> - let env = env |> with_strict true in - let leading = Peek.comments env in - Expect.token env T_IMPORT; - - match Peek.token env with - (* `import * as ns from "ModuleName";` *) - | T_MULT -> with_specifiers ImportValue env leading - (* `import { ... } from "ModuleName";` *) - | T_LCURLY -> with_specifiers ImportValue env leading - (* `import "ModuleName";` *) - | T_STRING str -> - let source = string_literal env str in - let (trailing, source) = semicolon_and_trailing env source in - Statement.ImportDeclaration - { - import_kind = ImportValue; - source; - specifiers = None; - default = None; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - (* `import type [...] from "ModuleName";` - note that if [...] is missing, we're importing a value named `type`! *) - | T_TYPE when should_parse_types env -> - begin - match Peek.ith_token ~i:1 env with - (* `import type, { other, names } from "ModuleName";` *) - | T_COMMA - (* `import type from "ModuleName";` *) - | T_IDENTIFIER { raw = "from"; _ } -> - (* Importing the exported value named "type". This is not a type-import.*) - with_default ImportValue env leading - (* `import type *` is invalid, since the namespace can't be a type *) - | T_MULT -> - (* consume `type` *) - Eat.token env; - - (* unexpected `*` *) - error_unexpected env; - - with_specifiers ImportType env leading - | T_LCURLY -> - (* consume `type` *) - Eat.token env; - - with_specifiers ImportType env leading - | _ -> - (* consume `type` *) - Eat.token env; - - with_default ImportType env leading - end - (* `import typeof ... from "ModuleName";` *) - | T_TYPEOF when should_parse_types env -> - Expect.token env T_TYPEOF; - begin - match Peek.token env with - | T_MULT - | T_LCURLY -> - with_specifiers ImportTypeof env leading - | _ -> with_default ImportTypeof env leading - end - (* import Foo from "ModuleName"; *) - | _ -> with_default ImportValue env leading - ) - ) -end diff --git a/jscomp/js_parser/token.ml b/jscomp/js_parser/token.ml deleted file mode 100644 index fe5c667..0000000 --- a/jscomp/js_parser/token.ml +++ /dev/null @@ -1,996 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) -open Primitive_deriving - -type t = - | T_NUMBER of { - kind: number_type; - raw: string; - } - | T_BIGINT of { - kind: bigint_type; - raw: string; - } - | T_STRING of (Loc.t * string * string * bool) (* loc, value, raw, octal *) - | T_TEMPLATE_PART of (Loc.t * template_part * bool) (* loc, value, is_tail *) - | T_IDENTIFIER of { - loc: Loc.t; - value: string; - raw: string; - } - | T_REGEXP of Loc.t * string * string (* /pattern/flags *) - (* Syntax *) - | T_LCURLY - | T_RCURLY - | T_LCURLYBAR - | T_RCURLYBAR - | T_LPAREN - | T_RPAREN - | T_LBRACKET - | T_RBRACKET - | T_SEMICOLON - | T_COMMA - | T_PERIOD - | T_ARROW - | T_ELLIPSIS - | T_AT - | T_POUND - (* Keywords *) - | T_FUNCTION - | T_IF - | T_IN - | T_INSTANCEOF - | T_RETURN - | T_SWITCH - | T_THIS - | T_THROW - | T_TRY - | T_VAR - | T_WHILE - | T_WITH - | T_CONST - | T_LET - | T_NULL - | T_FALSE - | T_TRUE - | T_BREAK - | T_CASE - | T_CATCH - | T_CONTINUE - | T_DEFAULT - | T_DO - | T_FINALLY - | T_FOR - | T_CLASS - | T_EXTENDS - | T_STATIC - | T_ELSE - | T_NEW - | T_DELETE - | T_TYPEOF - | T_VOID - | T_ENUM - | T_EXPORT - | T_IMPORT - | T_SUPER - | T_IMPLEMENTS - | T_INTERFACE - | T_PACKAGE - | T_PRIVATE - | T_PROTECTED - | T_PUBLIC - | T_YIELD - | T_DEBUGGER - | T_DECLARE - | T_TYPE - | T_OPAQUE - | T_OF - | T_ASYNC - | T_AWAIT - | T_CHECKS - (* Operators *) - | T_RSHIFT3_ASSIGN - | T_RSHIFT_ASSIGN - | T_LSHIFT_ASSIGN - | T_BIT_XOR_ASSIGN - | T_BIT_OR_ASSIGN - | T_BIT_AND_ASSIGN - | T_MOD_ASSIGN - | T_DIV_ASSIGN - | T_MULT_ASSIGN - | T_EXP_ASSIGN - | T_MINUS_ASSIGN - | T_PLUS_ASSIGN - | T_NULLISH_ASSIGN - | T_AND_ASSIGN - | T_OR_ASSIGN - | T_ASSIGN - | T_PLING_PERIOD - | T_PLING_PLING - | T_PLING - | T_COLON - | T_OR - | T_AND - | T_BIT_OR - | T_BIT_XOR - | T_BIT_AND - | T_EQUAL - | T_NOT_EQUAL - | T_STRICT_EQUAL - | T_STRICT_NOT_EQUAL - | T_LESS_THAN_EQUAL - | T_GREATER_THAN_EQUAL - | T_LESS_THAN - | T_GREATER_THAN - | T_LSHIFT - | T_RSHIFT - | T_RSHIFT3 - | T_PLUS - | T_MINUS - | T_DIV - | T_MULT - | T_EXP - | T_MOD - | T_NOT - | T_BIT_NOT - | T_INCR - | T_DECR - (* Extra tokens *) - | T_ERROR of string - | T_EOF - (* JSX *) - | T_JSX_IDENTIFIER of { - raw: string; - loc: Loc.t; - } - | T_JSX_TEXT of Loc.t * string * string (* loc, value, raw *) - (* Type primitives *) - | T_ANY_TYPE - | T_MIXED_TYPE - | T_EMPTY_TYPE - | T_BOOLEAN_TYPE of bool_or_boolean - | T_NUMBER_TYPE - | T_BIGINT_TYPE - | T_NUMBER_SINGLETON_TYPE of { - kind: number_type; - value: float; - raw: string; - } - | T_BIGINT_SINGLETON_TYPE of { - kind: bigint_type; - value: int64 option; - raw: string; - } - | T_STRING_TYPE - | T_VOID_TYPE - | T_SYMBOL_TYPE - -(* `bool` and `boolean` are equivalent annotations, but we need to track - which one was used for when it might be an identifier, as in - `(bool: boolean) => void`. It's lexed as two T_BOOLEAN_TYPEs, then the - first one is converted into an identifier. *) -and bool_or_boolean = - | BOOL - | BOOLEAN - -and number_type = - | BINARY - | LEGACY_OCTAL - | LEGACY_NON_OCTAL (* NonOctalDecimalIntegerLiteral in Annex B *) - | OCTAL - | NORMAL - -and bigint_type = - | BIG_BINARY - | BIG_OCTAL - | BIG_NORMAL - -and template_part = { - cooked: string; - (* string after processing special chars *) - raw: string; - (* string as specified in source *) - literal: string; (* same as raw, plus characters like ` and ${ *) -} -[@@deriving_inline equal] -let _ = fun (_ : t) -> () -let _ = fun (_ : bool_or_boolean) -> () -let _ = fun (_ : number_type) -> () -let _ = fun (_ : bigint_type) -> () -let _ = fun (_ : template_part) -> () -let rec equal = - (fun a__001_ -> - fun b__002_ -> - if Ppx_compare_lib.phys_equal a__001_ b__002_ - then true - else - (match (a__001_, b__002_) with - | (T_NUMBER _a__003_, T_NUMBER _b__004_) -> - Ppx_compare_lib.(&&) - (equal_number_type _a__003_.kind _b__004_.kind) - (equal_string _a__003_.raw _b__004_.raw) - | (T_NUMBER _, _) -> false - | (_, T_NUMBER _) -> false - | (T_BIGINT _a__005_, T_BIGINT _b__006_) -> - Ppx_compare_lib.(&&) - (equal_bigint_type _a__005_.kind _b__006_.kind) - (equal_string _a__005_.raw _b__006_.raw) - | (T_BIGINT _, _) -> false - | (_, T_BIGINT _) -> false - | (T_STRING _a__007_, T_STRING _b__008_) -> - let (t__009_, t__010_, t__011_, t__012_) = _a__007_ in - let (t__013_, t__014_, t__015_, t__016_) = _b__008_ in - Ppx_compare_lib.(&&) (Loc.equal t__009_ t__013_) - (Ppx_compare_lib.(&&) (equal_string t__010_ t__014_) - (Ppx_compare_lib.(&&) (equal_string t__011_ t__015_) - (equal_bool t__012_ t__016_))) - | (T_STRING _, _) -> false - | (_, T_STRING _) -> false - | (T_TEMPLATE_PART _a__017_, T_TEMPLATE_PART _b__018_) -> - let (t__019_, t__020_, t__021_) = _a__017_ in - let (t__022_, t__023_, t__024_) = _b__018_ in - Ppx_compare_lib.(&&) (Loc.equal t__019_ t__022_) - (Ppx_compare_lib.(&&) (equal_template_part t__020_ t__023_) - (equal_bool t__021_ t__024_)) - | (T_TEMPLATE_PART _, _) -> false - | (_, T_TEMPLATE_PART _) -> false - | (T_IDENTIFIER _a__025_, T_IDENTIFIER _b__026_) -> - Ppx_compare_lib.(&&) (Loc.equal _a__025_.loc _b__026_.loc) - (Ppx_compare_lib.(&&) - (equal_string _a__025_.value _b__026_.value) - (equal_string _a__025_.raw _b__026_.raw)) - | (T_IDENTIFIER _, _) -> false - | (_, T_IDENTIFIER _) -> false - | (T_REGEXP (_a__027_, _a__029_, _a__031_), T_REGEXP - (_b__028_, _b__030_, _b__032_)) -> - Ppx_compare_lib.(&&) (Loc.equal _a__027_ _b__028_) - (Ppx_compare_lib.(&&) (equal_string _a__029_ _b__030_) - (equal_string _a__031_ _b__032_)) - | (T_REGEXP _, _) -> false - | (_, T_REGEXP _) -> false - | (T_LCURLY, T_LCURLY) -> true - | (T_LCURLY, _) -> false - | (_, T_LCURLY) -> false - | (T_RCURLY, T_RCURLY) -> true - | (T_RCURLY, _) -> false - | (_, T_RCURLY) -> false - | (T_LCURLYBAR, T_LCURLYBAR) -> true - | (T_LCURLYBAR, _) -> false - | (_, T_LCURLYBAR) -> false - | (T_RCURLYBAR, T_RCURLYBAR) -> true - | (T_RCURLYBAR, _) -> false - | (_, T_RCURLYBAR) -> false - | (T_LPAREN, T_LPAREN) -> true - | (T_LPAREN, _) -> false - | (_, T_LPAREN) -> false - | (T_RPAREN, T_RPAREN) -> true - | (T_RPAREN, _) -> false - | (_, T_RPAREN) -> false - | (T_LBRACKET, T_LBRACKET) -> true - | (T_LBRACKET, _) -> false - | (_, T_LBRACKET) -> false - | (T_RBRACKET, T_RBRACKET) -> true - | (T_RBRACKET, _) -> false - | (_, T_RBRACKET) -> false - | (T_SEMICOLON, T_SEMICOLON) -> true - | (T_SEMICOLON, _) -> false - | (_, T_SEMICOLON) -> false - | (T_COMMA, T_COMMA) -> true - | (T_COMMA, _) -> false - | (_, T_COMMA) -> false - | (T_PERIOD, T_PERIOD) -> true - | (T_PERIOD, _) -> false - | (_, T_PERIOD) -> false - | (T_ARROW, T_ARROW) -> true - | (T_ARROW, _) -> false - | (_, T_ARROW) -> false - | (T_ELLIPSIS, T_ELLIPSIS) -> true - | (T_ELLIPSIS, _) -> false - | (_, T_ELLIPSIS) -> false - | (T_AT, T_AT) -> true - | (T_AT, _) -> false - | (_, T_AT) -> false - | (T_POUND, T_POUND) -> true - | (T_POUND, _) -> false - | (_, T_POUND) -> false - | (T_FUNCTION, T_FUNCTION) -> true - | (T_FUNCTION, _) -> false - | (_, T_FUNCTION) -> false - | (T_IF, T_IF) -> true - | (T_IF, _) -> false - | (_, T_IF) -> false - | (T_IN, T_IN) -> true - | (T_IN, _) -> false - | (_, T_IN) -> false - | (T_INSTANCEOF, T_INSTANCEOF) -> true - | (T_INSTANCEOF, _) -> false - | (_, T_INSTANCEOF) -> false - | (T_RETURN, T_RETURN) -> true - | (T_RETURN, _) -> false - | (_, T_RETURN) -> false - | (T_SWITCH, T_SWITCH) -> true - | (T_SWITCH, _) -> false - | (_, T_SWITCH) -> false - | (T_THIS, T_THIS) -> true - | (T_THIS, _) -> false - | (_, T_THIS) -> false - | (T_THROW, T_THROW) -> true - | (T_THROW, _) -> false - | (_, T_THROW) -> false - | (T_TRY, T_TRY) -> true - | (T_TRY, _) -> false - | (_, T_TRY) -> false - | (T_VAR, T_VAR) -> true - | (T_VAR, _) -> false - | (_, T_VAR) -> false - | (T_WHILE, T_WHILE) -> true - | (T_WHILE, _) -> false - | (_, T_WHILE) -> false - | (T_WITH, T_WITH) -> true - | (T_WITH, _) -> false - | (_, T_WITH) -> false - | (T_CONST, T_CONST) -> true - | (T_CONST, _) -> false - | (_, T_CONST) -> false - | (T_LET, T_LET) -> true - | (T_LET, _) -> false - | (_, T_LET) -> false - | (T_NULL, T_NULL) -> true - | (T_NULL, _) -> false - | (_, T_NULL) -> false - | (T_FALSE, T_FALSE) -> true - | (T_FALSE, _) -> false - | (_, T_FALSE) -> false - | (T_TRUE, T_TRUE) -> true - | (T_TRUE, _) -> false - | (_, T_TRUE) -> false - | (T_BREAK, T_BREAK) -> true - | (T_BREAK, _) -> false - | (_, T_BREAK) -> false - | (T_CASE, T_CASE) -> true - | (T_CASE, _) -> false - | (_, T_CASE) -> false - | (T_CATCH, T_CATCH) -> true - | (T_CATCH, _) -> false - | (_, T_CATCH) -> false - | (T_CONTINUE, T_CONTINUE) -> true - | (T_CONTINUE, _) -> false - | (_, T_CONTINUE) -> false - | (T_DEFAULT, T_DEFAULT) -> true - | (T_DEFAULT, _) -> false - | (_, T_DEFAULT) -> false - | (T_DO, T_DO) -> true - | (T_DO, _) -> false - | (_, T_DO) -> false - | (T_FINALLY, T_FINALLY) -> true - | (T_FINALLY, _) -> false - | (_, T_FINALLY) -> false - | (T_FOR, T_FOR) -> true - | (T_FOR, _) -> false - | (_, T_FOR) -> false - | (T_CLASS, T_CLASS) -> true - | (T_CLASS, _) -> false - | (_, T_CLASS) -> false - | (T_EXTENDS, T_EXTENDS) -> true - | (T_EXTENDS, _) -> false - | (_, T_EXTENDS) -> false - | (T_STATIC, T_STATIC) -> true - | (T_STATIC, _) -> false - | (_, T_STATIC) -> false - | (T_ELSE, T_ELSE) -> true - | (T_ELSE, _) -> false - | (_, T_ELSE) -> false - | (T_NEW, T_NEW) -> true - | (T_NEW, _) -> false - | (_, T_NEW) -> false - | (T_DELETE, T_DELETE) -> true - | (T_DELETE, _) -> false - | (_, T_DELETE) -> false - | (T_TYPEOF, T_TYPEOF) -> true - | (T_TYPEOF, _) -> false - | (_, T_TYPEOF) -> false - | (T_VOID, T_VOID) -> true - | (T_VOID, _) -> false - | (_, T_VOID) -> false - | (T_ENUM, T_ENUM) -> true - | (T_ENUM, _) -> false - | (_, T_ENUM) -> false - | (T_EXPORT, T_EXPORT) -> true - | (T_EXPORT, _) -> false - | (_, T_EXPORT) -> false - | (T_IMPORT, T_IMPORT) -> true - | (T_IMPORT, _) -> false - | (_, T_IMPORT) -> false - | (T_SUPER, T_SUPER) -> true - | (T_SUPER, _) -> false - | (_, T_SUPER) -> false - | (T_IMPLEMENTS, T_IMPLEMENTS) -> true - | (T_IMPLEMENTS, _) -> false - | (_, T_IMPLEMENTS) -> false - | (T_INTERFACE, T_INTERFACE) -> true - | (T_INTERFACE, _) -> false - | (_, T_INTERFACE) -> false - | (T_PACKAGE, T_PACKAGE) -> true - | (T_PACKAGE, _) -> false - | (_, T_PACKAGE) -> false - | (T_PRIVATE, T_PRIVATE) -> true - | (T_PRIVATE, _) -> false - | (_, T_PRIVATE) -> false - | (T_PROTECTED, T_PROTECTED) -> true - | (T_PROTECTED, _) -> false - | (_, T_PROTECTED) -> false - | (T_PUBLIC, T_PUBLIC) -> true - | (T_PUBLIC, _) -> false - | (_, T_PUBLIC) -> false - | (T_YIELD, T_YIELD) -> true - | (T_YIELD, _) -> false - | (_, T_YIELD) -> false - | (T_DEBUGGER, T_DEBUGGER) -> true - | (T_DEBUGGER, _) -> false - | (_, T_DEBUGGER) -> false - | (T_DECLARE, T_DECLARE) -> true - | (T_DECLARE, _) -> false - | (_, T_DECLARE) -> false - | (T_TYPE, T_TYPE) -> true - | (T_TYPE, _) -> false - | (_, T_TYPE) -> false - | (T_OPAQUE, T_OPAQUE) -> true - | (T_OPAQUE, _) -> false - | (_, T_OPAQUE) -> false - | (T_OF, T_OF) -> true - | (T_OF, _) -> false - | (_, T_OF) -> false - | (T_ASYNC, T_ASYNC) -> true - | (T_ASYNC, _) -> false - | (_, T_ASYNC) -> false - | (T_AWAIT, T_AWAIT) -> true - | (T_AWAIT, _) -> false - | (_, T_AWAIT) -> false - | (T_CHECKS, T_CHECKS) -> true - | (T_CHECKS, _) -> false - | (_, T_CHECKS) -> false - | (T_RSHIFT3_ASSIGN, T_RSHIFT3_ASSIGN) -> true - | (T_RSHIFT3_ASSIGN, _) -> false - | (_, T_RSHIFT3_ASSIGN) -> false - | (T_RSHIFT_ASSIGN, T_RSHIFT_ASSIGN) -> true - | (T_RSHIFT_ASSIGN, _) -> false - | (_, T_RSHIFT_ASSIGN) -> false - | (T_LSHIFT_ASSIGN, T_LSHIFT_ASSIGN) -> true - | (T_LSHIFT_ASSIGN, _) -> false - | (_, T_LSHIFT_ASSIGN) -> false - | (T_BIT_XOR_ASSIGN, T_BIT_XOR_ASSIGN) -> true - | (T_BIT_XOR_ASSIGN, _) -> false - | (_, T_BIT_XOR_ASSIGN) -> false - | (T_BIT_OR_ASSIGN, T_BIT_OR_ASSIGN) -> true - | (T_BIT_OR_ASSIGN, _) -> false - | (_, T_BIT_OR_ASSIGN) -> false - | (T_BIT_AND_ASSIGN, T_BIT_AND_ASSIGN) -> true - | (T_BIT_AND_ASSIGN, _) -> false - | (_, T_BIT_AND_ASSIGN) -> false - | (T_MOD_ASSIGN, T_MOD_ASSIGN) -> true - | (T_MOD_ASSIGN, _) -> false - | (_, T_MOD_ASSIGN) -> false - | (T_DIV_ASSIGN, T_DIV_ASSIGN) -> true - | (T_DIV_ASSIGN, _) -> false - | (_, T_DIV_ASSIGN) -> false - | (T_MULT_ASSIGN, T_MULT_ASSIGN) -> true - | (T_MULT_ASSIGN, _) -> false - | (_, T_MULT_ASSIGN) -> false - | (T_EXP_ASSIGN, T_EXP_ASSIGN) -> true - | (T_EXP_ASSIGN, _) -> false - | (_, T_EXP_ASSIGN) -> false - | (T_MINUS_ASSIGN, T_MINUS_ASSIGN) -> true - | (T_MINUS_ASSIGN, _) -> false - | (_, T_MINUS_ASSIGN) -> false - | (T_PLUS_ASSIGN, T_PLUS_ASSIGN) -> true - | (T_PLUS_ASSIGN, _) -> false - | (_, T_PLUS_ASSIGN) -> false - | (T_NULLISH_ASSIGN, T_NULLISH_ASSIGN) -> true - | (T_NULLISH_ASSIGN, _) -> false - | (_, T_NULLISH_ASSIGN) -> false - | (T_AND_ASSIGN, T_AND_ASSIGN) -> true - | (T_AND_ASSIGN, _) -> false - | (_, T_AND_ASSIGN) -> false - | (T_OR_ASSIGN, T_OR_ASSIGN) -> true - | (T_OR_ASSIGN, _) -> false - | (_, T_OR_ASSIGN) -> false - | (T_ASSIGN, T_ASSIGN) -> true - | (T_ASSIGN, _) -> false - | (_, T_ASSIGN) -> false - | (T_PLING_PERIOD, T_PLING_PERIOD) -> true - | (T_PLING_PERIOD, _) -> false - | (_, T_PLING_PERIOD) -> false - | (T_PLING_PLING, T_PLING_PLING) -> true - | (T_PLING_PLING, _) -> false - | (_, T_PLING_PLING) -> false - | (T_PLING, T_PLING) -> true - | (T_PLING, _) -> false - | (_, T_PLING) -> false - | (T_COLON, T_COLON) -> true - | (T_COLON, _) -> false - | (_, T_COLON) -> false - | (T_OR, T_OR) -> true - | (T_OR, _) -> false - | (_, T_OR) -> false - | (T_AND, T_AND) -> true - | (T_AND, _) -> false - | (_, T_AND) -> false - | (T_BIT_OR, T_BIT_OR) -> true - | (T_BIT_OR, _) -> false - | (_, T_BIT_OR) -> false - | (T_BIT_XOR, T_BIT_XOR) -> true - | (T_BIT_XOR, _) -> false - | (_, T_BIT_XOR) -> false - | (T_BIT_AND, T_BIT_AND) -> true - | (T_BIT_AND, _) -> false - | (_, T_BIT_AND) -> false - | (T_EQUAL, T_EQUAL) -> true - | (T_EQUAL, _) -> false - | (_, T_EQUAL) -> false - | (T_NOT_EQUAL, T_NOT_EQUAL) -> true - | (T_NOT_EQUAL, _) -> false - | (_, T_NOT_EQUAL) -> false - | (T_STRICT_EQUAL, T_STRICT_EQUAL) -> true - | (T_STRICT_EQUAL, _) -> false - | (_, T_STRICT_EQUAL) -> false - | (T_STRICT_NOT_EQUAL, T_STRICT_NOT_EQUAL) -> true - | (T_STRICT_NOT_EQUAL, _) -> false - | (_, T_STRICT_NOT_EQUAL) -> false - | (T_LESS_THAN_EQUAL, T_LESS_THAN_EQUAL) -> true - | (T_LESS_THAN_EQUAL, _) -> false - | (_, T_LESS_THAN_EQUAL) -> false - | (T_GREATER_THAN_EQUAL, T_GREATER_THAN_EQUAL) -> true - | (T_GREATER_THAN_EQUAL, _) -> false - | (_, T_GREATER_THAN_EQUAL) -> false - | (T_LESS_THAN, T_LESS_THAN) -> true - | (T_LESS_THAN, _) -> false - | (_, T_LESS_THAN) -> false - | (T_GREATER_THAN, T_GREATER_THAN) -> true - | (T_GREATER_THAN, _) -> false - | (_, T_GREATER_THAN) -> false - | (T_LSHIFT, T_LSHIFT) -> true - | (T_LSHIFT, _) -> false - | (_, T_LSHIFT) -> false - | (T_RSHIFT, T_RSHIFT) -> true - | (T_RSHIFT, _) -> false - | (_, T_RSHIFT) -> false - | (T_RSHIFT3, T_RSHIFT3) -> true - | (T_RSHIFT3, _) -> false - | (_, T_RSHIFT3) -> false - | (T_PLUS, T_PLUS) -> true - | (T_PLUS, _) -> false - | (_, T_PLUS) -> false - | (T_MINUS, T_MINUS) -> true - | (T_MINUS, _) -> false - | (_, T_MINUS) -> false - | (T_DIV, T_DIV) -> true - | (T_DIV, _) -> false - | (_, T_DIV) -> false - | (T_MULT, T_MULT) -> true - | (T_MULT, _) -> false - | (_, T_MULT) -> false - | (T_EXP, T_EXP) -> true - | (T_EXP, _) -> false - | (_, T_EXP) -> false - | (T_MOD, T_MOD) -> true - | (T_MOD, _) -> false - | (_, T_MOD) -> false - | (T_NOT, T_NOT) -> true - | (T_NOT, _) -> false - | (_, T_NOT) -> false - | (T_BIT_NOT, T_BIT_NOT) -> true - | (T_BIT_NOT, _) -> false - | (_, T_BIT_NOT) -> false - | (T_INCR, T_INCR) -> true - | (T_INCR, _) -> false - | (_, T_INCR) -> false - | (T_DECR, T_DECR) -> true - | (T_DECR, _) -> false - | (_, T_DECR) -> false - | (T_ERROR _a__033_, T_ERROR _b__034_) -> - equal_string _a__033_ _b__034_ - | (T_ERROR _, _) -> false - | (_, T_ERROR _) -> false - | (T_EOF, T_EOF) -> true - | (T_EOF, _) -> false - | (_, T_EOF) -> false - | (T_JSX_IDENTIFIER _a__035_, T_JSX_IDENTIFIER _b__036_) -> - Ppx_compare_lib.(&&) (equal_string _a__035_.raw _b__036_.raw) - (Loc.equal _a__035_.loc _b__036_.loc) - | (T_JSX_IDENTIFIER _, _) -> false - | (_, T_JSX_IDENTIFIER _) -> false - | (T_JSX_TEXT (_a__037_, _a__039_, _a__041_), T_JSX_TEXT - (_b__038_, _b__040_, _b__042_)) -> - Ppx_compare_lib.(&&) (Loc.equal _a__037_ _b__038_) - (Ppx_compare_lib.(&&) (equal_string _a__039_ _b__040_) - (equal_string _a__041_ _b__042_)) - | (T_JSX_TEXT _, _) -> false - | (_, T_JSX_TEXT _) -> false - | (T_ANY_TYPE, T_ANY_TYPE) -> true - | (T_ANY_TYPE, _) -> false - | (_, T_ANY_TYPE) -> false - | (T_MIXED_TYPE, T_MIXED_TYPE) -> true - | (T_MIXED_TYPE, _) -> false - | (_, T_MIXED_TYPE) -> false - | (T_EMPTY_TYPE, T_EMPTY_TYPE) -> true - | (T_EMPTY_TYPE, _) -> false - | (_, T_EMPTY_TYPE) -> false - | (T_BOOLEAN_TYPE _a__043_, T_BOOLEAN_TYPE _b__044_) -> - equal_bool_or_boolean _a__043_ _b__044_ - | (T_BOOLEAN_TYPE _, _) -> false - | (_, T_BOOLEAN_TYPE _) -> false - | (T_NUMBER_TYPE, T_NUMBER_TYPE) -> true - | (T_NUMBER_TYPE, _) -> false - | (_, T_NUMBER_TYPE) -> false - | (T_BIGINT_TYPE, T_BIGINT_TYPE) -> true - | (T_BIGINT_TYPE, _) -> false - | (_, T_BIGINT_TYPE) -> false - | (T_NUMBER_SINGLETON_TYPE _a__045_, T_NUMBER_SINGLETON_TYPE - _b__046_) -> - Ppx_compare_lib.(&&) - (equal_number_type _a__045_.kind _b__046_.kind) - (Ppx_compare_lib.(&&) - (equal_float _a__045_.value _b__046_.value) - (equal_string _a__045_.raw _b__046_.raw)) - | (T_NUMBER_SINGLETON_TYPE _, _) -> false - | (_, T_NUMBER_SINGLETON_TYPE _) -> false - | (T_BIGINT_SINGLETON_TYPE _a__047_, T_BIGINT_SINGLETON_TYPE - _b__048_) -> - Ppx_compare_lib.(&&) - (equal_bigint_type _a__047_.kind _b__048_.kind) - (Ppx_compare_lib.(&&) - (equal_option equal_int64 _a__047_.value _b__048_.value) - (equal_string _a__047_.raw _b__048_.raw)) - | (T_BIGINT_SINGLETON_TYPE _, _) -> false - | (_, T_BIGINT_SINGLETON_TYPE _) -> false - | (T_STRING_TYPE, T_STRING_TYPE) -> true - | (T_STRING_TYPE, _) -> false - | (_, T_STRING_TYPE) -> false - | (T_VOID_TYPE, T_VOID_TYPE) -> true - | (T_VOID_TYPE, _) -> false - | (_, T_VOID_TYPE) -> false - | (T_SYMBOL_TYPE, T_SYMBOL_TYPE) -> true) : t -> t -> bool) -and equal_bool_or_boolean = - (fun a__051_ -> - fun b__052_ -> Ppx_compare_lib.polymorphic_equal a__051_ b__052_ : - bool_or_boolean -> bool_or_boolean -> bool) -and equal_number_type = - (fun a__053_ -> - fun b__054_ -> Ppx_compare_lib.polymorphic_equal a__053_ b__054_ : - number_type -> number_type -> bool) -and equal_bigint_type = - (fun a__055_ -> - fun b__056_ -> Ppx_compare_lib.polymorphic_equal a__055_ b__056_ : - bigint_type -> bigint_type -> bool) -and equal_template_part = - (fun a__057_ -> - fun b__058_ -> - if Ppx_compare_lib.phys_equal a__057_ b__058_ - then true - else - Ppx_compare_lib.(&&) (equal_string a__057_.cooked b__058_.cooked) - (Ppx_compare_lib.(&&) (equal_string a__057_.raw b__058_.raw) - (equal_string a__057_.literal b__058_.literal)) : template_part - -> - template_part - -> - bool) -let _ = equal -and _ = equal_bool_or_boolean -and _ = equal_number_type -and _ = equal_bigint_type -and _ = equal_template_part -[@@@end] -(*****************************************************************************) -(* Pretty printer (pretty?) *) -(*****************************************************************************) -let token_to_string = function - | T_NUMBER _ -> "T_NUMBER" - | T_BIGINT _ -> "T_BIGINT" - | T_STRING _ -> "T_STRING" - | T_TEMPLATE_PART _ -> "T_TEMPLATE_PART" - | T_IDENTIFIER _ -> "T_IDENTIFIER" - | T_REGEXP _ -> "T_REGEXP" - | T_FUNCTION -> "T_FUNCTION" - | T_IF -> "T_IF" - | T_IN -> "T_IN" - | T_INSTANCEOF -> "T_INSTANCEOF" - | T_RETURN -> "T_RETURN" - | T_SWITCH -> "T_SWITCH" - | T_THIS -> "T_THIS" - | T_THROW -> "T_THROW" - | T_TRY -> "T_TRY" - | T_VAR -> "T_VAR" - | T_WHILE -> "T_WHILE" - | T_WITH -> "T_WITH" - | T_CONST -> "T_CONST" - | T_LET -> "T_LET" - | T_NULL -> "T_NULL" - | T_FALSE -> "T_FALSE" - | T_TRUE -> "T_TRUE" - | T_BREAK -> "T_BREAK" - | T_CASE -> "T_CASE" - | T_CATCH -> "T_CATCH" - | T_CONTINUE -> "T_CONTINUE" - | T_DEFAULT -> "T_DEFAULT" - | T_DO -> "T_DO" - | T_FINALLY -> "T_FINALLY" - | T_FOR -> "T_FOR" - | T_CLASS -> "T_CLASS" - | T_EXTENDS -> "T_EXTENDS" - | T_STATIC -> "T_STATIC" - | T_ELSE -> "T_ELSE" - | T_NEW -> "T_NEW" - | T_DELETE -> "T_DELETE" - | T_TYPEOF -> "T_TYPEOF" - | T_VOID -> "T_VOID" - | T_ENUM -> "T_ENUM" - | T_EXPORT -> "T_EXPORT" - | T_IMPORT -> "T_IMPORT" - | T_SUPER -> "T_SUPER" - | T_IMPLEMENTS -> "T_IMPLEMENTS" - | T_INTERFACE -> "T_INTERFACE" - | T_PACKAGE -> "T_PACKAGE" - | T_PRIVATE -> "T_PRIVATE" - | T_PROTECTED -> "T_PROTECTED" - | T_PUBLIC -> "T_PUBLIC" - | T_YIELD -> "T_YIELD" - | T_DEBUGGER -> "T_DEBUGGER" - | T_DECLARE -> "T_DECLARE" - | T_TYPE -> "T_TYPE" - | T_OPAQUE -> "T_OPAQUE" - | T_OF -> "T_OF" - | T_ASYNC -> "T_ASYNC" - | T_AWAIT -> "T_AWAIT" - | T_CHECKS -> "T_CHECKS" - | T_LCURLY -> "T_LCURLY" - | T_RCURLY -> "T_RCURLY" - | T_LCURLYBAR -> "T_LCURLYBAR" - | T_RCURLYBAR -> "T_RCURLYBAR" - | T_LPAREN -> "T_LPAREN" - | T_RPAREN -> "T_RPAREN" - | T_LBRACKET -> "T_LBRACKET" - | T_RBRACKET -> "T_RBRACKET" - | T_SEMICOLON -> "T_SEMICOLON" - | T_COMMA -> "T_COMMA" - | T_PERIOD -> "T_PERIOD" - | T_ARROW -> "T_ARROW" - | T_ELLIPSIS -> "T_ELLIPSIS" - | T_AT -> "T_AT" - | T_POUND -> "T_POUND" - | T_RSHIFT3_ASSIGN -> "T_RSHIFT3_ASSIGN" - | T_RSHIFT_ASSIGN -> "T_RSHIFT_ASSIGN" - | T_LSHIFT_ASSIGN -> "T_LSHIFT_ASSIGN" - | T_BIT_XOR_ASSIGN -> "T_BIT_XOR_ASSIGN" - | T_BIT_OR_ASSIGN -> "T_BIT_OR_ASSIGN" - | T_BIT_AND_ASSIGN -> "T_BIT_AND_ASSIGN" - | T_MOD_ASSIGN -> "T_MOD_ASSIGN" - | T_DIV_ASSIGN -> "T_DIV_ASSIGN" - | T_MULT_ASSIGN -> "T_MULT_ASSIGN" - | T_EXP_ASSIGN -> "T_EXP_ASSIGN" - | T_MINUS_ASSIGN -> "T_MINUS_ASSIGN" - | T_PLUS_ASSIGN -> "T_PLUS_ASSIGN" - | T_NULLISH_ASSIGN -> "T_NULLISH_ASSIGN" - | T_AND_ASSIGN -> "T_AND_ASSIGN" - | T_OR_ASSIGN -> "T_OR_ASSIGN" - | T_ASSIGN -> "T_ASSIGN" - | T_PLING_PERIOD -> "T_PLING_PERIOD" - | T_PLING_PLING -> "T_PLING_PLING" - | T_PLING -> "T_PLING" - | T_COLON -> "T_COLON" - | T_OR -> "T_OR" - | T_AND -> "T_AND" - | T_BIT_OR -> "T_BIT_OR" - | T_BIT_XOR -> "T_BIT_XOR" - | T_BIT_AND -> "T_BIT_AND" - | T_EQUAL -> "T_EQUAL" - | T_NOT_EQUAL -> "T_NOT_EQUAL" - | T_STRICT_EQUAL -> "T_STRICT_EQUAL" - | T_STRICT_NOT_EQUAL -> "T_STRICT_NOT_EQUAL" - | T_LESS_THAN_EQUAL -> "T_LESS_THAN_EQUAL" - | T_GREATER_THAN_EQUAL -> "T_GREATER_THAN_EQUAL" - | T_LESS_THAN -> "T_LESS_THAN" - | T_GREATER_THAN -> "T_GREATER_THAN" - | T_LSHIFT -> "T_LSHIFT" - | T_RSHIFT -> "T_RSHIFT" - | T_RSHIFT3 -> "T_RSHIFT3" - | T_PLUS -> "T_PLUS" - | T_MINUS -> "T_MINUS" - | T_DIV -> "T_DIV" - | T_MULT -> "T_MULT" - | T_EXP -> "T_EXP" - | T_MOD -> "T_MOD" - | T_NOT -> "T_NOT" - | T_BIT_NOT -> "T_BIT_NOT" - | T_INCR -> "T_INCR" - | T_DECR -> "T_DECR" - (* Extra tokens *) - | T_ERROR _ -> "T_ERROR" - | T_EOF -> "T_EOF" - | T_JSX_IDENTIFIER _ -> "T_JSX_IDENTIFIER" - | T_JSX_TEXT _ -> "T_JSX_TEXT" - (* Type primitives *) - | T_ANY_TYPE -> "T_ANY_TYPE" - | T_MIXED_TYPE -> "T_MIXED_TYPE" - | T_EMPTY_TYPE -> "T_EMPTY_TYPE" - | T_BOOLEAN_TYPE _ -> "T_BOOLEAN_TYPE" - | T_NUMBER_TYPE -> "T_NUMBER_TYPE" - | T_BIGINT_TYPE -> "T_BIGINT_TYPE" - | T_NUMBER_SINGLETON_TYPE _ -> "T_NUMBER_SINGLETON_TYPE" - | T_BIGINT_SINGLETON_TYPE _ -> "T_BIGINT_SINGLETON_TYPE" - | T_STRING_TYPE -> "T_STRING_TYPE" - | T_VOID_TYPE -> "T_VOID_TYPE" - | T_SYMBOL_TYPE -> "T_SYMBOL_TYPE" - -let value_of_token = function - | T_NUMBER { raw; _ } -> raw - | T_BIGINT { raw; _ } -> raw - | T_STRING (_, _, raw, _) -> raw - | T_TEMPLATE_PART (_, { literal; _ }, _) -> literal - | T_IDENTIFIER { raw; _ } -> raw - | T_REGEXP (_, pattern, flags) -> "/" ^ pattern ^ "/" ^ flags - | T_LCURLY -> "{" - | T_RCURLY -> "}" - | T_LCURLYBAR -> "{|" - | T_RCURLYBAR -> "|}" - | T_LPAREN -> "(" - | T_RPAREN -> ")" - | T_LBRACKET -> "[" - | T_RBRACKET -> "]" - | T_SEMICOLON -> ";" - | T_COMMA -> "," - | T_PERIOD -> "." - | T_ARROW -> "=>" - | T_ELLIPSIS -> "..." - | T_AT -> "@" - | T_POUND -> "#" - | T_FUNCTION -> "function" - | T_IF -> "if" - | T_IN -> "in" - | T_INSTANCEOF -> "instanceof" - | T_RETURN -> "return" - | T_SWITCH -> "switch" - | T_THIS -> "this" - | T_THROW -> "throw" - | T_TRY -> "try" - | T_VAR -> "var" - | T_WHILE -> "while" - | T_WITH -> "with" - | T_CONST -> "const" - | T_LET -> "let" - | T_NULL -> "null" - | T_FALSE -> "false" - | T_TRUE -> "true" - | T_BREAK -> "break" - | T_CASE -> "case" - | T_CATCH -> "catch" - | T_CONTINUE -> "continue" - | T_DEFAULT -> "default" - | T_DO -> "do" - | T_FINALLY -> "finally" - | T_FOR -> "for" - | T_CLASS -> "class" - | T_EXTENDS -> "extends" - | T_STATIC -> "static" - | T_ELSE -> "else" - | T_NEW -> "new" - | T_DELETE -> "delete" - | T_TYPEOF -> "typeof" - | T_VOID -> "void" - | T_ENUM -> "enum" - | T_EXPORT -> "export" - | T_IMPORT -> "import" - | T_SUPER -> "super" - | T_IMPLEMENTS -> "implements" - | T_INTERFACE -> "interface" - | T_PACKAGE -> "package" - | T_PRIVATE -> "private" - | T_PROTECTED -> "protected" - | T_PUBLIC -> "public" - | T_YIELD -> "yield" - | T_DEBUGGER -> "debugger" - | T_DECLARE -> "declare" - | T_TYPE -> "type" - | T_OPAQUE -> "opaque" - | T_OF -> "of" - | T_ASYNC -> "async" - | T_AWAIT -> "await" - | T_CHECKS -> "%checks" - | T_RSHIFT3_ASSIGN -> ">>>=" - | T_RSHIFT_ASSIGN -> ">>=" - | T_LSHIFT_ASSIGN -> "<<=" - | T_BIT_XOR_ASSIGN -> "^=" - | T_BIT_OR_ASSIGN -> "|=" - | T_BIT_AND_ASSIGN -> "&=" - | T_MOD_ASSIGN -> "%=" - | T_DIV_ASSIGN -> "/=" - | T_MULT_ASSIGN -> "*=" - | T_EXP_ASSIGN -> "**=" - | T_MINUS_ASSIGN -> "-=" - | T_PLUS_ASSIGN -> "+=" - | T_NULLISH_ASSIGN -> "??=" - | T_AND_ASSIGN -> "&&=" - | T_OR_ASSIGN -> "||=" - | T_ASSIGN -> "=" - | T_PLING_PERIOD -> "?." - | T_PLING_PLING -> "??" - | T_PLING -> "?" - | T_COLON -> ":" - | T_OR -> "||" - | T_AND -> "&&" - | T_BIT_OR -> "|" - | T_BIT_XOR -> "^" - | T_BIT_AND -> "&" - | T_EQUAL -> "==" - | T_NOT_EQUAL -> "!=" - | T_STRICT_EQUAL -> "===" - | T_STRICT_NOT_EQUAL -> "!==" - | T_LESS_THAN_EQUAL -> "<=" - | T_GREATER_THAN_EQUAL -> ">=" - | T_LESS_THAN -> "<" - | T_GREATER_THAN -> ">" - | T_LSHIFT -> "<<" - | T_RSHIFT -> ">>" - | T_RSHIFT3 -> ">>>" - | T_PLUS -> "+" - | T_MINUS -> "-" - | T_DIV -> "/" - | T_MULT -> "*" - | T_EXP -> "**" - | T_MOD -> "%" - | T_NOT -> "!" - | T_BIT_NOT -> "~" - | T_INCR -> "++" - | T_DECR -> "--" - (* Extra tokens *) - | T_ERROR raw -> raw - | T_EOF -> "" - | T_JSX_IDENTIFIER { raw; _ } -> raw - | T_JSX_TEXT (_, _, raw) -> raw - (* Type primitives *) - | T_ANY_TYPE -> "any" - | T_MIXED_TYPE -> "mixed" - | T_EMPTY_TYPE -> "empty" - | T_BOOLEAN_TYPE kind -> begin - match kind with - | BOOL -> "bool" - | BOOLEAN -> "boolean" - end - | T_NUMBER_TYPE -> "number" - | T_BIGINT_TYPE -> "bigint" - | T_NUMBER_SINGLETON_TYPE { raw; _ } -> raw - | T_BIGINT_SINGLETON_TYPE { raw; _ } -> raw - | T_STRING_TYPE -> "string" - | T_VOID_TYPE -> "void" - | T_SYMBOL_TYPE -> "symbol" - -let quote_token_value value = Printf.sprintf "token `%s`" value - -let explanation_of_token ?(use_article = false) token = - let (value, article) = - match token with - | T_NUMBER_SINGLETON_TYPE _ - | T_NUMBER _ -> - ("number", "a") - | T_BIGINT_SINGLETON_TYPE _ - | T_BIGINT _ -> - ("bigint", "a") - | T_JSX_TEXT _ - | T_STRING _ -> - ("string", "a") - | T_TEMPLATE_PART _ -> ("template literal part", "a") - | T_JSX_IDENTIFIER _ - | T_IDENTIFIER _ -> - ("identifier", "an") - | T_REGEXP _ -> ("regexp", "a") - | T_EOF -> ("end of input", "the") - | _ -> (quote_token_value (value_of_token token), "the") - in - if use_article then - article ^ " " ^ value - else - value diff --git a/jscomp/js_parser/type_parser.ml b/jscomp/js_parser/type_parser.ml deleted file mode 100644 index ba898a1..0000000 --- a/jscomp/js_parser/type_parser.ml +++ /dev/null @@ -1,1487 +0,0 @@ -(* - * Copyright (c) Meta Platforms, Inc. and affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -module Ast = Flow_ast -open Token -open Parser_env -open Flow_ast -open Parser_common -open Comment_attachment - -module type TYPE = sig - val _type : env -> (Loc.t, Loc.t) Ast.Type.t - - val type_identifier : env -> (Loc.t, Loc.t) Ast.Identifier.t - - val type_params : env -> (Loc.t, Loc.t) Ast.Type.TypeParams.t option - - val type_args : env -> (Loc.t, Loc.t) Ast.Type.TypeArgs.t option - - val generic : env -> Loc.t * (Loc.t, Loc.t) Ast.Type.Generic.t - - val _object : is_class:bool -> env -> Loc.t * (Loc.t, Loc.t) Type.Object.t - - val interface_helper : - env -> - (Loc.t * (Loc.t, Loc.t) Ast.Type.Generic.t) list * (Loc.t * (Loc.t, Loc.t) Ast.Type.Object.t) - - val function_param_list : env -> (Loc.t, Loc.t) Type.Function.Params.t - - val annotation : env -> (Loc.t, Loc.t) Ast.Type.annotation - - val annotation_opt : env -> (Loc.t, Loc.t) Ast.Type.annotation_or_hint - - val predicate_opt : env -> (Loc.t, Loc.t) Ast.Type.Predicate.t option - - val annotation_and_predicate_opt : - env -> (Loc.t, Loc.t) Ast.Type.annotation_or_hint * (Loc.t, Loc.t) Ast.Type.Predicate.t option -end - -module Type (Parse : Parser_common.PARSER) : TYPE = struct - type param_list_or_type = - | ParamList of (Loc.t, Loc.t) Type.Function.Params.t' - | Type of (Loc.t, Loc.t) Type.t - - let maybe_variance env = - let loc = Peek.loc env in - match Peek.token env with - | T_PLUS -> - let leading = Peek.comments env in - Eat.token env; - Some - ( loc, - { Variance.kind = Variance.Plus; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - | T_MINUS -> - let leading = Peek.comments env in - Eat.token env; - Some - ( loc, - { Variance.kind = Variance.Minus; comments = Flow_ast_utils.mk_comments_opt ~leading () } - ) - | _ -> None - - let rec _type env = union env - - and annotation env = - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeAnnotation; - with_loc - (fun env -> - Expect.token env T_COLON; - _type env) - env - - and union env = - let leading = - if Peek.token env = T_BIT_OR then ( - let leading = Peek.comments env in - Eat.token env; - leading - ) else - [] - in - let left = intersection env in - union_with env ~leading left - - and union_with = - let rec unions leading acc env = - match Peek.token env with - | T_BIT_OR -> - Expect.token env T_BIT_OR; - unions leading (intersection env :: acc) env - | _ -> - (match List.rev acc with - | t0 :: t1 :: ts -> - Type.Union - { - Type.Union.types = (t0, t1, ts); - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - | _ -> assert false) - in - fun env ?(leading = []) left -> - if Peek.token env = T_BIT_OR then - with_loc ~start_loc:(fst left) (unions leading [left]) env - else - left - - and intersection env = - let leading = - if Peek.token env = T_BIT_AND then ( - let leading = Peek.comments env in - Eat.token env; - leading - ) else - [] - in - let left = anon_function_without_parens env in - intersection_with env ~leading left - - and intersection_with = - let rec intersections leading acc env = - match Peek.token env with - | T_BIT_AND -> - Expect.token env T_BIT_AND; - intersections leading (anon_function_without_parens env :: acc) env - | _ -> - (match List.rev acc with - | t0 :: t1 :: ts -> - Type.Intersection - { - Type.Intersection.types = (t0, t1, ts); - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - | _ -> assert false) - in - fun env ?(leading = []) left -> - if Peek.token env = T_BIT_AND then - with_loc ~start_loc:(fst left) (intersections leading [left]) env - else - left - - and anon_function_without_parens env = - let param = prefix env in - anon_function_without_parens_with env param - - and anon_function_without_parens_with env param = - match Peek.token env with - | T_ARROW when not (no_anon_function_type env) -> - let (start_loc, tparams, params) = - let param = anonymous_function_param env param in - ( fst param, - None, - ( fst param, - { - Ast.Type.Function.Params.params = [param]; - this_ = None; - rest = None; - comments = None; - } - ) - ) - in - function_with_params env start_loc tparams params - | _ -> param - - and prefix env = - match Peek.token env with - | T_PLING -> - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_PLING; - Type.Nullable - { - Type.Nullable.argument = prefix env; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - | _ -> postfix env - - and postfix env = - let t = primary env in - postfix_with env t - - and postfix_with ?(in_optional_indexed_access = false) env t = - if Peek.is_line_terminator env then - t - else - match Peek.token env with - | T_PLING_PERIOD -> - Eat.token env; - if Peek.token env <> T_LBRACKET then error env Parse_error.InvalidOptionalIndexedAccess; - Expect.token env T_LBRACKET; - postfix_brackets ~in_optional_indexed_access:true ~optional_indexed_access:true env t - | T_LBRACKET -> - Eat.token env; - postfix_brackets ~in_optional_indexed_access ~optional_indexed_access:false env t - | T_PERIOD -> - (match Peek.ith_token ~i:1 env with - | T_LBRACKET -> - error env (Parse_error.InvalidIndexedAccess { has_bracket = true }); - Expect.token env T_PERIOD; - Expect.token env T_LBRACKET; - postfix_brackets ~in_optional_indexed_access ~optional_indexed_access:false env t - | _ -> - error env (Parse_error.InvalidIndexedAccess { has_bracket = false }); - t) - | _ -> t - - and postfix_brackets ~in_optional_indexed_access ~optional_indexed_access env t = - let t = - with_loc - ~start_loc:(fst t) - (fun env -> - (* Legacy Array syntax `Foo[]` *) - if (not optional_indexed_access) && Eat.maybe env T_RBRACKET then - let trailing = Eat.trailing_comments env in - Type.Array - { Type.Array.argument = t; comments = Flow_ast_utils.mk_comments_opt ~trailing () } - else - let index = _type env in - Expect.token env T_RBRACKET; - let trailing = Eat.trailing_comments env in - let indexed_access = - { - Type.IndexedAccess._object = t; - index; - comments = Flow_ast_utils.mk_comments_opt ~trailing (); - } - in - if in_optional_indexed_access then - Type.OptionalIndexedAccess - { Type.OptionalIndexedAccess.indexed_access; optional = optional_indexed_access } - else - Type.IndexedAccess indexed_access) - env - in - postfix_with env ~in_optional_indexed_access t - - and typeof_expr env = raw_typeof_expr_with_identifier env (Parse.identifier env) - - and raw_typeof_expr_with_identifier = - let rec identifier env (q_loc, qualification) = - if Peek.token env = T_PERIOD && Peek.ith_is_identifier ~i:1 env then - let (loc, q) = - with_loc - ~start_loc:q_loc - (fun env -> - Expect.token env T_PERIOD; - let id = identifier_name env in - { Type.Typeof.Target.qualification; id }) - env - in - let qualification = Type.Typeof.Target.Qualified (loc, q) in - identifier env (loc, qualification) - else - qualification - in - fun env ((loc, _) as id) -> - let id = Type.Typeof.Target.Unqualified id in - identifier env (loc, id) - - and typeof_arg env = - match Peek.token env with - | T_LPAREN -> - Eat.token env; - let typeof = typeof_arg env in - Expect.token env T_RPAREN; - typeof - | T_IDENTIFIER _ (* `static` is reserved in strict mode, but still an identifier *) -> - Some (typeof_expr env) - | _ -> - error env Parse_error.InvalidTypeof; - None - - and typeof env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_TYPEOF; - match typeof_arg env with - | None -> Type.Any None - | Some argument -> - Type.Typeof - { Type.Typeof.argument; comments = Flow_ast_utils.mk_comments_opt ~leading () }) - env - - and primary env = - let loc = Peek.loc env in - match Peek.token env with - | T_MULT -> - let leading = Peek.comments env in - Expect.token env T_MULT; - let trailing = Eat.trailing_comments env in - (loc, Type.Exists (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_LESS_THAN -> _function env - | T_LPAREN -> function_or_group env - | T_LCURLY - | T_LCURLYBAR -> - let (loc, o) = _object env ~is_class:false ~allow_exact:true ~allow_spread:true in - (loc, Type.Object o) - | T_INTERFACE -> - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_INTERFACE; - let (extends, body) = interface_helper env in - Type.Interface - { Type.Interface.extends; body; comments = Flow_ast_utils.mk_comments_opt ~leading () }) - env - | T_TYPEOF -> typeof env - | T_LBRACKET -> tuple env - | T_IDENTIFIER _ - | T_STATIC (* `static` is reserved in strict mode, but still an identifier *) -> - let (loc, g) = generic env in - (loc, Type.Generic g) - | T_STRING (loc, value, raw, octal) -> - if octal then strict_error env Parse_error.StrictOctalLiteral; - let leading = Peek.comments env in - Expect.token env (T_STRING (loc, value, raw, octal)); - let trailing = Eat.trailing_comments env in - ( loc, - Type.StringLiteral - { - Ast.StringLiteral.value; - raw; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - | T_NUMBER_SINGLETON_TYPE { kind; value; raw } -> - if kind = LEGACY_OCTAL then strict_error env Parse_error.StrictOctalLiteral; - let leading = Peek.comments env in - Expect.token env (T_NUMBER_SINGLETON_TYPE { kind; value; raw }); - let trailing = Eat.trailing_comments env in - ( loc, - Type.NumberLiteral - { - Ast.NumberLiteral.value; - raw; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - | T_BIGINT_SINGLETON_TYPE { kind; value; raw } -> - let leading = Peek.comments env in - Expect.token env (T_BIGINT_SINGLETON_TYPE { kind; value; raw }); - let trailing = Eat.trailing_comments env in - ( loc, - Type.BigIntLiteral - { - Ast.BigIntLiteral.value; - raw; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - | (T_TRUE | T_FALSE) as token -> - let leading = Peek.comments env in - Expect.token env token; - let trailing = Eat.trailing_comments env in - let value = token = T_TRUE in - ( loc, - Type.BooleanLiteral - { BooleanLiteral.value; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) - | _ -> - (match primitive env with - | Some t -> (loc, t) - | None -> - error_unexpected ~expected:"a type" env; - (loc, Type.Any None)) - - and is_primitive = function - | T_ANY_TYPE - | T_MIXED_TYPE - | T_EMPTY_TYPE - | T_BOOLEAN_TYPE _ - | T_NUMBER_TYPE - | T_BIGINT_TYPE - | T_STRING_TYPE - | T_SYMBOL_TYPE - | T_VOID_TYPE - | T_NULL -> - true - | _ -> false - - and primitive env = - let leading = Peek.comments env in - let token = Peek.token env in - match token with - | T_ANY_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Any (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_MIXED_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Mixed (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_EMPTY_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Empty (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_BOOLEAN_TYPE _ -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Boolean (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_NUMBER_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Number (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_BIGINT_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.BigInt (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_STRING_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.String (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_SYMBOL_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Symbol (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_VOID_TYPE -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Void (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | T_NULL -> - Eat.token env; - let trailing = Eat.trailing_comments env in - Some (Type.Null (Flow_ast_utils.mk_comments_opt ~leading ~trailing ())) - | _ -> None - - and tuple = - let rec types env acc = - match Peek.token env with - | T_EOF - | T_RBRACKET -> - List.rev acc - | _ -> - let acc = _type env :: acc in - (* Trailing comma support (like [number, string,]) *) - if Peek.token env <> T_RBRACKET then Expect.token env T_COMMA; - types env acc - in - fun env -> - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LBRACKET; - let tl = types (with_no_anon_function_type false env) [] in - Expect.token env T_RBRACKET; - let trailing = Eat.trailing_comments env in - Type.Tuple - { - Type.Tuple.types = tl; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - - and anonymous_function_param _env annot = - (fst annot, Type.Function.Param.{ name = None; annot; optional = false }) - - and function_param_with_id env = - with_loc - (fun env -> - Eat.push_lex_mode env Lex_mode.NORMAL; - let name = Parse.identifier env in - Eat.pop_lex_mode env; - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeAnnotation; - let optional = Eat.maybe env T_PLING in - Expect.token env T_COLON; - let annot = _type env in - { Type.Function.Param.name = Some name; annot; optional }) - env - - and function_param_list_without_parens = - let param env = - match Peek.ith_token ~i:1 env with - | T_COLON - | T_PLING -> - function_param_with_id env - | _ -> - let annot = _type env in - anonymous_function_param env annot - in - let rec param_list env this_ acc = - match Peek.token env with - | (T_EOF | T_ELLIPSIS | T_RPAREN) as t -> - let rest = - if t = T_ELLIPSIS then - let rest = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_ELLIPSIS; - { - Type.Function.RestParam.argument = param env; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - in - Some rest - else - None - in - { Ast.Type.Function.Params.params = List.rev acc; rest; this_; comments = None } - | T_IDENTIFIER { raw = "this"; _ } - when Peek.ith_token ~i:1 env == T_COLON || Peek.ith_token ~i:1 env == T_PLING -> - if this_ <> None || acc <> [] then error env Parse_error.ThisParamMustBeFirst; - let this_ = - with_loc - (fun env -> - let leading = Peek.comments env in - Eat.token env; - if Peek.token env == T_PLING then error env Parse_error.ThisParamMayNotBeOptional; - { - Type.Function.ThisParam.annot = annotation env; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - in - if Peek.token env <> T_RPAREN then Expect.token env T_COMMA; - param_list env (Some this_) acc - | _ -> - let acc = param env :: acc in - if Peek.token env <> T_RPAREN then Expect.token env T_COMMA; - param_list env this_ acc - in - (fun env -> param_list env None) - - and function_param_list env = - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LPAREN; - let params = function_param_list_without_parens env [] in - let internal = Peek.comments env in - Expect.token env T_RPAREN; - let trailing = Eat.trailing_comments env in - { - params with - Ast.Type.Function.Params.comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - }) - env - - and param_list_or_type env = - let leading = Peek.comments env in - Expect.token env T_LPAREN; - let ret = - let env = with_no_anon_function_type false env in - match Peek.token env with - | T_EOF - | T_ELLIPSIS -> - (* (... is definitely the beginning of a param list *) - ParamList (function_param_list_without_parens env []) - | T_RPAREN -> - (* () or is definitely a param list *) - ParamList - { Ast.Type.Function.Params.this_ = None; params = []; rest = None; comments = None } - | T_IDENTIFIER _ - | T_STATIC (* `static` is reserved in strict mode, but still an identifier *) -> - (* This could be a function parameter or a generic type *) - function_param_or_generic_type env - | token when is_primitive token -> - (* Don't know if this is (number) or (number: number). The first - * is a type, the second is a param. *) - (match Peek.ith_token ~i:1 env with - | T_PLING - | T_COLON -> - (* Ok this is definitely a parameter *) - ParamList (function_param_list_without_parens env []) - | _ -> Type (_type env)) - | _ -> - (* All params start with an identifier or `...` *) - Type (_type env) - in - (* Now that we allow anonymous parameters in function types, we need to - * disambiguate a little bit more *) - let ret = - match ret with - | ParamList _ -> ret - | Type _ when no_anon_function_type env -> ret - | Type t -> - (match Peek.token env with - | T_RPAREN -> - (* Reinterpret `(type) =>` as a ParamList *) - if Peek.ith_token ~i:1 env = T_ARROW then - let param = anonymous_function_param env t in - ParamList (function_param_list_without_parens env [param]) - else - Type t - | T_COMMA -> - (* Reinterpret `(type,` as a ParamList *) - Expect.token env T_COMMA; - let param = anonymous_function_param env t in - ParamList (function_param_list_without_parens env [param]) - | _ -> ret) - in - let internal = Peek.comments env in - Expect.token env T_RPAREN; - let trailing = Eat.trailing_comments env in - let ret = - match ret with - | ParamList params -> - ParamList - { - params with - Ast.Type.Function.Params.comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - } - | Type t -> Type (add_comments t leading trailing) - in - ret - - and function_param_or_generic_type env = - match Peek.ith_token ~i:1 env with - | T_PLING - (* optional param *) - | T_COLON -> - ParamList (function_param_list_without_parens env []) - | _ -> - let id = type_identifier env in - Type - (generic_type_with_identifier env id - |> postfix_with env - |> anon_function_without_parens_with env - |> intersection_with env - |> union_with env - ) - - and function_or_group env = - let start_loc = Peek.loc env in - match with_loc param_list_or_type env with - | (loc, ParamList params) -> function_with_params env start_loc None (loc, params) - | (_, Type _type) -> _type - - and _function env = - let start_loc = Peek.loc env in - let tparams = type_params_remove_trailing env (type_params env) in - let params = function_param_list env in - function_with_params env start_loc tparams params - - and function_with_params env start_loc tparams (params : (Loc.t, Loc.t) Ast.Type.Function.Params.t) - = - with_loc - ~start_loc - (fun env -> - Expect.token env T_ARROW; - let return = _type env in - Type.(Function { Function.params; return; tparams; comments = None })) - env - - and _object = - let methodish env start_loc tparams = - with_loc - ~start_loc - (fun env -> - let params = function_param_list env in - Expect.token env T_COLON; - let return = _type env in - { Type.Function.params; return; tparams; comments = None }) - env - in - let method_property env start_loc static key ~leading = - let key = object_key_remove_trailing env key in - let tparams = type_params_remove_trailing env (type_params env) in - let value = methodish env start_loc tparams in - let value = (fst value, Type.Function (snd value)) in - Type.Object.( - Property - ( fst value, - { - Property.key; - value = Property.Init value; - optional = false; - static = static <> None; - proto = false; - _method = true; - variance = None; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - ) - in - let call_property env start_loc static ~leading = - let prop = - with_loc - ~start_loc - (fun env -> - let start_loc = Peek.loc env in - let tparams = type_params_remove_trailing env (type_params env) in - let value = methodish env start_loc tparams in - Type.Object.CallProperty. - { - value; - static = static <> None; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - env - in - Type.Object.CallProperty prop - in - let init_property env start_loc ~variance ~static ~proto ~leading (key_loc, key) = - ignore proto; - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeAnnotation; - let prop = - with_loc - ~start_loc - (fun env -> - let optional = Eat.maybe env T_PLING in - let value = - if Expect.token_maybe env T_COLON then - _type env - else - (key_loc, Type.Any None) - in - Type.Object.Property. - { - key; - value = Init value; - optional; - static = static <> None; - proto = proto <> None; - _method = false; - variance; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - env - in - Type.Object.Property prop - in - let getter_or_setter ~is_getter ~leading env start_loc static key = - let prop = - with_loc - ~start_loc - (fun env -> - let (key_loc, key) = key in - let key = object_key_remove_trailing env key in - let value = methodish env start_loc None in - let (_, { Type.Function.params; _ }) = value in - begin - match (is_getter, params) with - | (true, (_, { Type.Function.Params.this_ = Some _; _ })) -> - error_at env (key_loc, Parse_error.GetterMayNotHaveThisParam) - | (false, (_, { Type.Function.Params.this_ = Some _; _ })) -> - error_at env (key_loc, Parse_error.SetterMayNotHaveThisParam) - | ( true, - (_, { Type.Function.Params.params = []; rest = None; this_ = None; comments = _ }) - ) -> - () - | (false, (_, { Type.Function.Params.rest = Some _; _ })) -> - (* rest params don't make sense on a setter *) - error_at env (key_loc, Parse_error.SetterArity) - | (false, (_, { Type.Function.Params.params = [_]; _ })) -> () - | (true, _) -> error_at env (key_loc, Parse_error.GetterArity) - | (false, _) -> error_at env (key_loc, Parse_error.SetterArity) - end; - Type.Object.Property. - { - key; - value = - ( if is_getter then - Get value - else - Set value - ); - optional = false; - static = static <> None; - proto = false; - _method = false; - variance = None; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - } - ) - env - in - Type.Object.Property prop - in - let indexer_property env start_loc static variance ~leading = - let indexer = - with_loc - ~start_loc - (fun env -> - let leading = leading @ Peek.comments env in - Expect.token env T_LBRACKET; - let id = - if Peek.ith_token ~i:1 env = T_COLON then ( - let id = identifier_name env in - Expect.token env T_COLON; - Some id - ) else - None - in - let key = _type env in - Expect.token env T_RBRACKET; - let trailing = Eat.trailing_comments env in - Expect.token env T_COLON; - let value = _type env in - { - Type.Object.Indexer.id; - key; - value; - static = static <> None; - variance; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - in - Type.Object.Indexer indexer - in - let internal_slot env start_loc static ~leading = - let islot = - with_loc - ~start_loc - (fun env -> - let leading = leading @ Peek.comments env in - Expect.token env T_LBRACKET; - Expect.token env T_LBRACKET; - let id = identifier_name env in - Expect.token env T_RBRACKET; - Expect.token env T_RBRACKET; - let (optional, _method, value, trailing) = - match Peek.token env with - | T_LESS_THAN - | T_LPAREN -> - let tparams = type_params_remove_trailing env (type_params env) in - let value = - let (fn_loc, fn) = methodish env start_loc tparams in - (fn_loc, Type.Function fn) - in - (false, true, value, []) - | _ -> - let optional = Eat.maybe env T_PLING in - let trailing = Eat.trailing_comments env in - Expect.token env T_COLON; - let value = _type env in - (optional, false, value, trailing) - in - { - Type.Object.InternalSlot.id; - value; - optional; - static = static <> None; - _method; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - }) - env - in - Type.Object.InternalSlot islot - (* Expects the T_ELLIPSIS has already been eaten *) - in - let spread_property env start_loc ~leading = - let spread = - with_loc - ~start_loc - (fun env -> - { - Type.Object.SpreadProperty.argument = _type env; - comments = Flow_ast_utils.mk_comments_opt ~leading (); - }) - env - in - Type.Object.SpreadProperty spread - in - let semicolon exact env = - match Peek.token env with - | T_COMMA - | T_SEMICOLON -> - Eat.token env - | T_RCURLYBAR when exact -> () - | T_RCURLY when not exact -> () - | _ -> Expect.error env T_COMMA - in - let error_unexpected_variance env = function - | Some (loc, _) -> error_at env (loc, Parse_error.UnexpectedVariance) - | None -> () - in - let error_unexpected_proto env = function - | Some loc -> error_at env (loc, Parse_error.UnexpectedProto) - | None -> () - in - let error_invalid_property_name env is_class static key = - let is_static = static <> None in - let is_constructor = String.equal "constructor" in - let is_prototype = String.equal "prototype" in - match key with - | Expression.Object.Property.Identifier (loc, { Identifier.name; comments = _ }) - when is_class && (is_constructor name || (is_static && is_prototype name)) -> - error_at - env - ( loc, - Parse_error.InvalidClassMemberName - { name; static = is_static; method_ = false; private_ = false } - ) - | _ -> () - in - let rec properties - ~is_class ~allow_inexact ~allow_spread ~exact env ((props, inexact, internal) as acc) = - (* no `static ...A` *) - assert (not (is_class && allow_spread)); - - (* allow_inexact implies allow_spread *) - assert ((not allow_inexact) || allow_spread); - - let start_loc = Peek.loc env in - match Peek.token env with - | T_EOF -> (List.rev props, inexact, internal) - | T_RCURLYBAR when exact -> (List.rev props, inexact, internal) - | T_RCURLY when not exact -> (List.rev props, inexact, internal) - | T_ELLIPSIS when allow_spread -> - let leading = Peek.comments env in - Eat.token env; - begin - match Peek.token env with - | T_COMMA - | T_SEMICOLON - | T_RCURLY - | T_RCURLYBAR -> - semicolon exact env; - begin - match Peek.token env with - | T_RCURLY when allow_inexact -> (List.rev props, true, leading) - | T_RCURLYBAR -> - error_at env (start_loc, Parse_error.InexactInsideExact); - (List.rev props, inexact, internal) - | _ -> - error_at env (start_loc, Parse_error.UnexpectedExplicitInexactInObject); - properties ~is_class ~allow_inexact ~allow_spread ~exact env acc - end - | _ -> - let prop = spread_property env start_loc ~leading in - semicolon exact env; - properties - ~is_class - ~allow_inexact - ~allow_spread - ~exact - env - (prop :: props, inexact, internal) - end - (* In this case, allow_spread is false, so we may assume allow_inexact is false based on our - * assertion at the top of this function. Thus, any T_ELLIPSIS here is not allowed. - *) - | T_ELLIPSIS -> - Eat.token env; - begin - match Peek.token env with - | T_COMMA - | T_SEMICOLON - | T_RCURLY - | T_RCURLYBAR -> - error_at env (start_loc, Parse_error.InexactInsideNonObject); - semicolon exact env; - properties ~is_class ~allow_inexact ~allow_spread ~exact env acc - | _ -> - error_list env (Peek.errors env); - error_at env (start_loc, Parse_error.UnexpectedSpreadType); - - (* It's likely the user is trying to spread something here, so we can - * eat what they try to spread to try to continue parsing the remaining - * properties. - *) - Eat.token env; - semicolon exact env; - properties ~is_class ~allow_inexact ~allow_spread ~exact env acc - end - | _ -> - let prop = - property - env - start_loc - ~is_class - ~allow_static:is_class - ~allow_proto:is_class - ~variance:None - ~static:None - ~proto:None - ~leading:[] - in - semicolon exact env; - properties - ~is_class - ~allow_inexact - ~allow_spread - ~exact - env - (prop :: props, inexact, internal) - and property - env ~is_class ~allow_static ~allow_proto ~variance ~static ~proto ~leading start_loc = - match Peek.token env with - | T_PLUS - | T_MINUS - when variance = None -> - let variance = maybe_variance env in - property - env - ~is_class - ~allow_static:false - ~allow_proto:false - ~variance - ~static - ~proto - ~leading - start_loc - | T_STATIC when allow_static -> - assert (variance = None); - - (* if we parsed variance, allow_static = false *) - let static = Some (Peek.loc env) in - let leading = leading @ Peek.comments env in - Eat.token env; - property - env - ~is_class - ~allow_static:false - ~allow_proto:false - ~variance - ~static - ~proto - ~leading - start_loc - | T_IDENTIFIER { raw = "proto"; _ } when allow_proto -> - assert (variance = None); - - (* if we parsed variance, allow_proto = false *) - let proto = Some (Peek.loc env) in - let leading = leading @ Peek.comments env in - Eat.token env; - property - env - ~is_class - ~allow_static:false - ~allow_proto:false - ~variance - ~static - ~proto - ~leading - start_loc - | T_LBRACKET -> - error_unexpected_proto env proto; - (match Peek.ith_token ~i:1 env with - | T_LBRACKET -> - error_unexpected_variance env variance; - internal_slot env start_loc static ~leading - | _ -> indexer_property env start_loc static variance ~leading) - | T_LESS_THAN - | T_LPAREN -> - (* Note that `static(): void` is a static callable property if we - successfully parsed the static modifier above. *) - error_unexpected_proto env proto; - error_unexpected_variance env variance; - call_property env start_loc static ~leading - | token -> - (match (static, proto, token) with - | (Some _, Some _, _) -> failwith "Can not have both `static` and `proto`" - | (Some static_loc, None, (T_PLING | T_COLON)) -> - (* We speculatively parsed `static` as a static modifier, but now - that we've parsed the next token, we changed our minds and want - to parse `static` as the key of a named property. *) - let key = - Expression.Object.Property.Identifier - (Flow_ast_utils.ident_of_source - (static_loc, "static") - ?comments:(Flow_ast_utils.mk_comments_opt ~leading ()) - ) - in - let static = None in - init_property env start_loc ~variance ~static ~proto ~leading:[] (static_loc, key) - | (None, Some proto_loc, (T_PLING | T_COLON)) -> - (* We speculatively parsed `proto` as a proto modifier, but now - that we've parsed the next token, we changed our minds and want - to parse `proto` as the key of a named property. *) - let key = - Expression.Object.Property.Identifier - (Flow_ast_utils.ident_of_source - (proto_loc, "proto") - ?comments:(Flow_ast_utils.mk_comments_opt ~leading ()) - ) - in - let proto = None in - init_property env start_loc ~variance ~static ~proto ~leading:[] (proto_loc, key) - | _ -> - let object_key env = - Eat.push_lex_mode env Lex_mode.NORMAL; - let result = Parse.object_key env in - Eat.pop_lex_mode env; - result - in - let leading_key = Peek.comments env in - (match object_key env with - | ( key_loc, - ( Expression.Object.Property.Identifier - (_, { Identifier.name = ("get" | "set") as name; comments = _ }) as key - ) - ) -> - begin - match Peek.token env with - | T_LESS_THAN - | T_LPAREN -> - error_unexpected_proto env proto; - error_unexpected_variance env variance; - method_property env start_loc static key ~leading - | T_COLON - | T_PLING -> - init_property env start_loc ~variance ~static ~proto ~leading (key_loc, key) - | _ -> - ignore (object_key_remove_trailing env key); - let key = object_key env in - let is_getter = name = "get" in - let leading = leading @ leading_key in - error_unexpected_proto env proto; - error_unexpected_variance env variance; - getter_or_setter ~is_getter ~leading env start_loc static key - end - | (key_loc, key) -> - begin - match Peek.token env with - | T_LESS_THAN - | T_LPAREN -> - error_unexpected_proto env proto; - error_unexpected_variance env variance; - method_property env start_loc static key ~leading - | _ -> - error_invalid_property_name env is_class static key; - init_property env start_loc ~variance ~static ~proto ~leading (key_loc, key) - end)) - in - fun ~is_class ~allow_exact ~allow_spread env -> - let exact = allow_exact && Peek.token env = T_LCURLYBAR in - let allow_inexact = allow_exact && not exact in - with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token - env - ( if exact then - T_LCURLYBAR - else - T_LCURLY - ); - let (properties, inexact, internal) = - let env = with_no_anon_function_type false env in - properties ~is_class ~allow_inexact ~exact ~allow_spread env ([], false, []) - in - let internal = internal @ Peek.comments env in - Expect.token - env - ( if exact then - T_RCURLYBAR - else - T_RCURLY - ); - let trailing = Eat.trailing_comments env in - - (* inexact = true iff `...` was used to indicate inexactnes *) - { - Type.Object.exact; - properties; - inexact; - comments = Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - }) - env - - and interface_helper = - let rec supers env acc = - let super = generic env in - let acc = super :: acc in - match Peek.token env with - | T_COMMA -> - Expect.token env T_COMMA; - supers env acc - | _ -> List.rev acc - in - fun env -> - let extends = - if Peek.token env = T_EXTENDS then ( - Expect.token env T_EXTENDS; - let extends = supers env [] in - generic_type_list_remove_trailing env extends - ) else - [] - in - let body = _object env ~allow_exact:false ~allow_spread:false ~is_class:false in - (extends, body) - - and type_identifier env = - let (loc, { Identifier.name; comments }) = identifier_name env in - if is_reserved_type name then error_at env (loc, Parse_error.UnexpectedReservedType); - (loc, { Identifier.name; comments }) - - and bounded_type env = - with_loc - (fun env -> - let name = type_identifier env in - let bound = - if Peek.token env = T_COLON then - Ast.Type.Available (annotation env) - else - Ast.Type.Missing (Peek.loc_skip_lookahead env) - in - (name, bound)) - env - - and type_params = - let rec params env ~require_default acc = - Type.TypeParam.( - let (loc, (variance, name, bound, default, require_default)) = - with_loc - (fun env -> - let variance = maybe_variance env in - let (loc, (name, bound)) = bounded_type env in - let (default, require_default) = - match Peek.token env with - | T_ASSIGN -> - Eat.token env; - (Some (_type env), true) - | _ -> - if require_default then error_at env (loc, Parse_error.MissingTypeParamDefault); - (None, require_default) - in - (variance, name, bound, default, require_default)) - env - in - let param = (loc, { name; bound; variance; default }) in - let acc = param :: acc in - match Peek.token env with - | T_EOF - | T_GREATER_THAN -> - List.rev acc - | _ -> - Expect.token env T_COMMA; - if Peek.token env = T_GREATER_THAN then - List.rev acc - else - params env ~require_default acc - ) - in - fun env -> - if Peek.token env = T_LESS_THAN then ( - if not (should_parse_types env) then error env Parse_error.UnexpectedTypeAnnotation; - Some - (with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LESS_THAN; - let params = params env ~require_default:false [] in - let internal = Peek.comments env in - Expect.token env T_GREATER_THAN; - let trailing = Eat.trailing_comments env in - { - Type.TypeParams.params; - comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - }) - env - ) - ) else - None - - and type_args = - let rec args env acc = - match Peek.token env with - | T_EOF - | T_GREATER_THAN -> - List.rev acc - | _ -> - let acc = _type env :: acc in - if Peek.token env <> T_GREATER_THAN then Expect.token env T_COMMA; - args env acc - in - fun env -> - if Peek.token env = T_LESS_THAN then - Some - (with_loc - (fun env -> - let leading = Peek.comments env in - Expect.token env T_LESS_THAN; - let env = with_no_anon_function_type false env in - let arguments = args env [] in - let internal = Peek.comments env in - Expect.token env T_GREATER_THAN; - let trailing = Eat.trailing_comments env in - { - Type.TypeArgs.arguments; - comments = - Flow_ast_utils.mk_comments_with_internal_opt ~leading ~trailing ~internal (); - }) - env - ) - else - None - - and generic env = raw_generic_with_identifier env (type_identifier env) - - and raw_generic_with_identifier = - let rec identifier env (q_loc, qualification) = - if Peek.token env = T_PERIOD && Peek.ith_is_type_identifier ~i:1 env then - let (loc, q) = - with_loc - ~start_loc:q_loc - (fun env -> - Expect.token env T_PERIOD; - let id = type_identifier env in - { Type.Generic.Identifier.qualification; id }) - env - in - let qualification = Type.Generic.Identifier.Qualified (loc, q) in - identifier env (loc, qualification) - else - (q_loc, qualification) - in - fun env id -> - with_loc - ~start_loc:(fst id) - (fun env -> - let id = (fst id, Type.Generic.Identifier.Unqualified id) in - let id = - let (_id_loc, id) = identifier env id in - if Peek.token env <> T_LESS_THAN then - id - else - let { remove_trailing; _ } = trailing_and_remover env in - remove_trailing id (fun remover id -> remover#generic_identifier_type id) - in - let targs = type_args env in - { Type.Generic.id; targs; comments = None }) - env - - and generic_type_with_identifier env id = - let (loc, generic) = raw_generic_with_identifier env id in - (loc, Type.Generic generic) - - and annotation_opt env = - match Peek.token env with - | T_COLON -> Type.Available (annotation env) - | _ -> Type.Missing (Peek.loc_skip_lookahead env) - - and add_comments (loc, t) leading trailing = - let merge_comments inner = - Flow_ast_utils.merge_comments - ~inner - ~outer:(Flow_ast_utils.mk_comments_opt ~leading ~trailing ()) - in - let merge_comments_with_internal inner = - Flow_ast_utils.merge_comments_with_internal - ~inner - ~outer:(Flow_ast_utils.mk_comments_opt ~leading ~trailing ()) - in - let open Ast.Type in - ( loc, - match t with - | Any comments -> Any (merge_comments comments) - | Mixed comments -> Mixed (merge_comments comments) - | Empty comments -> Empty (merge_comments comments) - | Void comments -> Void (merge_comments comments) - | Null comments -> Null (merge_comments comments) - | Number comments -> Number (merge_comments comments) - | BigInt comments -> BigInt (merge_comments comments) - | String comments -> String (merge_comments comments) - | Boolean comments -> Boolean (merge_comments comments) - | Symbol comments -> Symbol (merge_comments comments) - | Exists comments -> Exists (merge_comments comments) - | Nullable ({ Nullable.comments; _ } as t) -> - Nullable { t with Nullable.comments = merge_comments comments } - | Function ({ Function.comments; _ } as t) -> - Function { t with Function.comments = merge_comments comments } - | Object ({ Object.comments; _ } as t) -> - Object { t with Object.comments = merge_comments_with_internal comments } - | Interface ({ Interface.comments; _ } as t) -> - Interface { t with Interface.comments = merge_comments comments } - | Array ({ Array.comments; _ } as t) -> - Array { t with Array.comments = merge_comments comments } - | Generic ({ Generic.comments; _ } as t) -> - Generic { t with Generic.comments = merge_comments comments } - | IndexedAccess ({ IndexedAccess.comments; _ } as t) -> - IndexedAccess { t with IndexedAccess.comments = merge_comments comments } - | OptionalIndexedAccess - { - OptionalIndexedAccess.indexed_access = { IndexedAccess.comments; _ } as indexed_access; - optional; - } -> - OptionalIndexedAccess - { - OptionalIndexedAccess.indexed_access = - { indexed_access with IndexedAccess.comments = merge_comments comments }; - optional; - } - | Union ({ Union.comments; _ } as t) -> - Union { t with Union.comments = merge_comments comments } - | Intersection ({ Intersection.comments; _ } as t) -> - Intersection { t with Intersection.comments = merge_comments comments } - | Typeof ({ Typeof.comments; _ } as t) -> - Typeof { t with Typeof.comments = merge_comments comments } - | Tuple ({ Tuple.comments; _ } as t) -> - Tuple { t with Tuple.comments = merge_comments comments } - | StringLiteral ({ StringLiteral.comments; _ } as t) -> - StringLiteral { t with StringLiteral.comments = merge_comments comments } - | NumberLiteral ({ NumberLiteral.comments; _ } as t) -> - NumberLiteral { t with NumberLiteral.comments = merge_comments comments } - | BigIntLiteral ({ BigIntLiteral.comments; _ } as t) -> - BigIntLiteral { t with BigIntLiteral.comments = merge_comments comments } - | BooleanLiteral ({ BooleanLiteral.comments; _ } as t) -> - BooleanLiteral { t with BooleanLiteral.comments = merge_comments comments } - ) - - let predicate = - with_loc (fun env -> - let open Ast.Type.Predicate in - let leading = Peek.comments env in - Expect.token env T_CHECKS; - if Peek.token env = T_LPAREN then ( - let leading = leading @ Peek.comments env in - Expect.token env T_LPAREN; - Eat.push_lex_mode env Lex_mode.NORMAL; - let exp = Parse.conditional env in - Eat.pop_lex_mode env; - Expect.token env T_RPAREN; - let trailing = Eat.trailing_comments env in - { kind = Declared exp; comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing () } - ) else - let trailing = Eat.trailing_comments env in - { - kind = Ast.Type.Predicate.Inferred; - comments = Flow_ast_utils.mk_comments_opt ~leading ~trailing (); - } - ) - - let predicate_opt env = - let env = with_no_anon_function_type false env in - match Peek.token env with - | T_CHECKS -> Some (predicate env) - | _ -> None - - let annotation_and_predicate_opt env = - let open Ast.Type in - match (Peek.token env, Peek.ith_token ~i:1 env) with - | (T_COLON, T_CHECKS) -> - Expect.token env T_COLON; - (Missing (Peek.loc_skip_lookahead env), predicate_opt env) - | (T_COLON, _) -> - let annotation = - let annotation = annotation_opt env in - if Peek.token env = T_CHECKS then - type_annotation_hint_remove_trailing env annotation - else - annotation - in - let predicate = predicate_opt env in - (annotation, predicate) - | _ -> (Missing (Peek.loc_skip_lookahead env), None) - - let wrap f env = - let env = env |> with_strict true in - Eat.push_lex_mode env Lex_mode.TYPE; - let ret = f env in - Eat.pop_lex_mode env; - ret - - let _type = wrap _type - - let type_identifier = wrap type_identifier - - let type_params = wrap type_params - - let type_args = wrap type_args - - let _object ~is_class env = wrap (_object ~is_class ~allow_exact:false ~allow_spread:false) env - - let interface_helper = wrap interface_helper - - let function_param_list = wrap function_param_list - - let annotation = wrap annotation - - let annotation_opt = wrap annotation_opt - - let predicate_opt = wrap predicate_opt - - let annotation_and_predicate_opt = wrap annotation_and_predicate_opt - - let generic = wrap generic -end diff --git a/jscomp/js_parser/wtf8.ml b/jscomp/js_parser/wtf8.ml deleted file mode 100644 index be7d371..0000000 --- a/jscomp/js_parser/wtf8.ml +++ /dev/null @@ -1,103 +0,0 @@ -(** - * Copyright (c) 2017-present, Facebook, Inc. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -(* - * WTF-8 is a superset of UTF-8 that allows unpaired surrogates. - * - * From ES6 6.1.4, "The String Type": - * - * Where ECMAScript operations interpret String values, each element is - * interpreted as a single UTF-16 code unit. However, ECMAScript does not - * place any restrictions or requirements on the sequence of code units in - * a String value, so they may be ill-formed when interpreted as UTF-16 code - * unit sequences. Operations that do not interpret String contents treat - * them as sequences of undifferentiated 16-bit unsigned integers. - * - * If we try to encode these ill-formed code units into UTF-8, we similarly - * get ill-formed UTF-8. WTF-8 is a fun name for that encoding. - * - * https://simonsapin.github.io/wtf-8/ - *) - -type codepoint = - | Point of int - | Malformed - -type 'a folder = 'a -> int -> codepoint -> 'a - -(* WTF-8 is a variable length encoding. The first byte in each codepoint - determines how many other bytes follow. *) -let needed_bytes c = - if 0x00 <= c && c <= 0x7F then 1 else - if 0xC2 <= c && c <= 0xDF then 2 else - if 0xE0 <= c && c <= 0xEF then 3 else - if 0xF0 <= c && c <= 0xF4 then 4 else - 0 - -let unsafe_char s i = Char.code (Bytes.unsafe_get s i) - -let codepoint s i = function - | 1 -> unsafe_char s i - | 2 -> - let b0 = unsafe_char s i in - let b1 = unsafe_char s (i + 1) in - ((b0 land 0x1F) lsl 6) lor (b1 land 0x3F) - | 3 -> - let b0 = unsafe_char s (i) in - let b1 = unsafe_char s (i + 1) in - let b2 = unsafe_char s (i + 2) in - ((b0 land 0x0F) lsl 12) lor - ((b1 land 0x3F) lsl 6) lor - (b2 land 0x3F) - | 4 -> - let b0 = unsafe_char s (i) in - let b1 = unsafe_char s (i + 1) in - let b2 = unsafe_char s (i + 2) in - let b3 = unsafe_char s (i + 3) in - ((b0 land 0x07) lsl 18) lor - ((b1 land 0x3F) lsl 12) lor - ((b2 land 0x3F) lsl 6) lor - (b3 land 0x3F) - | _ -> assert false - -(* Fold over the WTF-8 code units in a string *) -let fold_wtf_8 ?(pos = 0) ?len f acc s = - let rec loop acc f s i l = - if i = l then acc else - let need = needed_bytes (unsafe_char s i) in - if need = 0 then (loop [@tailcall]) (f acc i Malformed) f s (i + 1) l else - let rem = l - i in - if rem < need then f acc i Malformed else - (loop [@tailcall]) (f acc i (Point (codepoint s i need))) f s (i + need) l - in - let len = match len with - | None -> String.length s - pos - | Some l -> l - in - loop acc f (Bytes.unsafe_of_string s) pos len - -(* Add a UTF-16 code unit to a buffer, encoded in WTF-8. *) -let add_wtf_8 buf code = - let[@inline] w byte = Buffer.add_char buf (Char.unsafe_chr byte) in - if code >= 0x10000 then begin - (* 4 bytes *) - w (0xf0 lor (code lsr 18)); - w (0x80 lor ((code lsr 12) land 0x3F)); - w (0x80 lor ((code lsr 6) land 0x3F)); - w (0x80 lor (code land 0x3F)) - end else if code >= 0x800 then begin - (* 3 bytes *) - w (0xe0 lor (code lsr 12)); - w (0x80 lor ((code lsr 6) land 0x3F)); - w (0x80 lor (code land 0x3F)) - end else if code >= 0x80 then begin - (* 2 bytes *) - w (0xc0 lor (code lsr 6)); - w (0x80 lor (code land 0x3F)) - end else - (* 1 byte *) - w code diff --git a/jscomp/js_parser/wtf8.mli b/jscomp/js_parser/wtf8.mli deleted file mode 100644 index 8aac2e9..0000000 --- a/jscomp/js_parser/wtf8.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* - * Copyright (c) Facebook, Inc. and its affiliates. - * - * This source code is licensed under the MIT license found in the - * LICENSE file in the root directory of this source tree. - *) - -[@@@ocaml.text -"\n * Copyright (c) 2017-present, Facebook, Inc.\n *\n * This source code is licensed under the MIT license found in the\n * LICENSE file in the root directory of this source tree.\n "] - -type codepoint = - | Point of int - | Malformed - -type 'a folder = 'a -> int -> codepoint -> 'a - -val fold_wtf_8 : ?pos:int -> ?len:int -> 'a folder -> 'a -> string -> 'a - -val add_wtf_8 : Buffer.t -> int -> unit diff --git a/jscomp/jsoo/.ocamlformat b/jscomp/jsoo/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/jsoo/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/jsoo/dune b/jscomp/jsoo/dune deleted file mode 100644 index 89169e6..0000000 --- a/jscomp/jsoo/dune +++ /dev/null @@ -1,10 +0,0 @@ -; Don't build the JS compiler by default as it slows down CI considerably. - -(executables - (names jsoo_playground_main) - (modes js) - (enabled_if - (= %{profile} browser)) - (flags - (:standard -w -A)) - (libraries core syntax ml js_of_ocaml)) diff --git a/jscomp/jsoo/jsoo_playground_main.ml b/jscomp/jsoo/jsoo_playground_main.ml deleted file mode 100644 index 0bc73da..0000000 --- a/jscomp/jsoo/jsoo_playground_main.ml +++ /dev/null @@ -1,709 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - -(* - * The API version is giving information about the feature set - * of the resulting ReScript JS bundle API. - * - * It follows the semver format {major.minor} which means: - * - Whenever there is a breaking change, raise the major version - * - Whenever there is a feature addition, raise the minor version - * - * Whenever you are changing functionality in here, please double check - * if you are breaking any APIs. If yes, make sure to update this apiVersion - * value accordingly. - * - * Rationale: - * We ship ReScript bindings that bind to this API. To be able to handle - * different bundles with different API versions, we need a way to tell the - * consumer on what interface the bundle provides. - * - * This will allow the frontend to have different sets of the same bindings, - * and use the proper interfaces as stated by the apiVersion. - * - * ----------------------------- - * Version History: * v2: Remove refmt support (removes compiler.reason apis) - * v3: Switched to Uncurried mode by default (requires third party packages - to be built with uncurried: true in bsconfig.json). Also added - `config.uncurried` to the BundleConfig. - * v4: Added `config.open_modules` to the BundleConfig to enable implicitly opened - * modules in the playground. - * *) -let apiVersion = "4" - -module Js = Js_of_ocaml.Js - -let export (field : string) v = - Js.Unsafe.set (Js.Unsafe.global) field v -;; - -module Lang = struct - type t = OCaml | Res - - let fromString t = match t with - | "ocaml" | "ml" -> Some OCaml - | "res" -> Some Res - | _ -> None - - let toString t = match t with - | OCaml -> "ml" - | Res -> "res" -end - -module BundleConfig = struct - type t = { - mutable module_system: Ext_module_system.t; - mutable filename: string option; - mutable warn_flags: string; - mutable open_modules: string list; - - (* This one can't be mutated since we only provide - third-party packages that were compiled for uncurried - mode *) - uncurried: bool; - } - - let make () = { - module_system=Ext_module_system.Commonjs; - filename=None; - warn_flags=Bsc_warnings.defaults_w; - open_modules=[]; - uncurried=(!Config.uncurried = Uncurried); - } - - - let default_filename (lang: Lang.t) = "playground." ^ (Lang.toString lang) - - let string_of_module_system m = (match m with - | Ext_module_system.Commonjs -> "nodejs" - | Esmodule -> "es6" - | Es6_global -> "es6_global") -end - -type locErrInfo = { - fullMsg: string; (* Full report string with all context *) - shortMsg: string; (* simple explain message without any extra context *) - loc: Location.t; -} - -module LocWarnInfo = struct - type t = { - fullMsg: string; (* Full super_error related warn string *) - shortMsg: string; (* Plain warn message without any context *) - warnNumber: int; - isError: bool; - loc: Location.t; - } -end - - -exception RescriptParsingErrors of locErrInfo list - -module ErrorRet = struct - let locErrorAttributes ~(type_: string) ~(fullMsg: string) ~(shortMsg: string) (loc: Location.t) = - let (_file,line,startchar) = Location.get_pos_info loc.Location.loc_start in - let (_file,endline,endchar) = Location.get_pos_info loc.Location.loc_end in - Js.Unsafe.([| - "fullMsg", inject @@ Js.string fullMsg; - "row" , inject line; - "column" , inject startchar; - "endRow" , inject endline; - "endColumn" , inject endchar; - "shortMsg" , inject @@ Js.string shortMsg; - "type" , inject @@ Js.string type_; - |]) - - let makeWarning (e: LocWarnInfo.t) = - let locAttrs = locErrorAttributes - ~type_:"warning" - ~fullMsg: e.fullMsg - ~shortMsg: e.shortMsg - e.loc in - let warnAttrs = Js.Unsafe.([| - "warnNumber", inject @@ (e.warnNumber |> float_of_int |> Js.number_of_float); - "isError", inject @@ Js.bool e.isError; - |]) in - let attrs = Array.append locAttrs warnAttrs in - Js.Unsafe.obj attrs - - let fromLocErrors ?(warnings: LocWarnInfo.t array option) ~(type_: string) (errors: locErrInfo array) = - let jsErrors = Array.map - (fun (e: locErrInfo) -> - Js.Unsafe.(obj - (locErrorAttributes - ~type_ - ~fullMsg: e.fullMsg - ~shortMsg: e.shortMsg - e.loc))) errors - in - let locErrAttrs = Js.Unsafe.([| - "errors" , inject @@ Js.array jsErrors; - "type" , inject @@ Js.string type_ - |]) - in - let warningAttr = match warnings with - | Some warnings -> Js.Unsafe.([| - "warnings", - inject @@ Js.array (Array.map makeWarning warnings) - |]) - | None -> [||] - in - let attrs = Array.append locErrAttrs warningAttr in - Js.Unsafe.(obj attrs) - - let fromSyntaxErrors (errors: locErrInfo array) = - fromLocErrors ~type_:"syntax_error" errors - - (* for raised errors caused by malformed warning / warning_error flags *) - let makeWarningFlagError ~(warn_flags: string) (msg: string) = - Js.Unsafe.(obj [| - "msg" , inject @@ Js.string msg; - "warn_flags", inject @@ Js.string warn_flags; - "type" , inject @@ Js.string "warning_flag_error" - |]) - - let makeWarningError (errors: LocWarnInfo.t array) = - let type_ = "warning_error" in - let jsErrors = Array.map makeWarning errors in - Js.Unsafe.(obj [| - "errors" , inject @@ Js.array jsErrors; - "type" , inject @@ Js.string type_ - |]) - - let makeUnexpectedError msg = - Js.Unsafe.(obj [| - "msg" , inject @@ Js.string msg; - "type" , inject @@ Js.string "unexpected_error" - |]) - -end - -(* One time setup for all relevant modules *) -let () = - Bs_conditional_initial.setup_env (); - (* From now on the default setting will be uncurried mode *) - Config.uncurried := Uncurried; - Clflags.binary_annotations := false; - Clflags.color := Some Always; - Lazy.force Res_outcome_printer.setup - -let error_of_exn e = - (match Location.error_of_exn e with - | Some (`Ok e) -> Some e - | Some `Already_displayed - | None -> None) - -(* Returns a default filename in case given value opt is not set *) -let get_filename ~(lang: Lang.t) opt = - match opt with - | Some fname -> fname - | None -> BundleConfig.default_filename lang - -let lexbuf_from_string ~filename str = - let lexbuf = Lexing.from_string str in - lexbuf.lex_start_p <- { lexbuf.lex_start_p with pos_fname = filename }; - lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = filename }; - lexbuf - -let ocaml_parse ~filename str = - lexbuf_from_string ~filename str |> Parse.implementation - -module ResDriver = struct - (* For now we are basically overriding functionality from Res_driver *) - open Res_driver - - (* adds ~src parameter *) - let setup ~src ~filename ~forPrinter () = - let mode = if forPrinter - then Res_parser.Default - else ParseForTypeChecker - in - Res_parser.make ~mode src filename - - (* get full super error message *) - let diagnosticToString ~(src: string) (d: Res_diagnostics.t) = - let startPos = Res_diagnostics.getStartPos(d) in - let endPos = Res_diagnostics.getEndPos(d) in - let msg = Res_diagnostics.explain(d) in - let loc = {loc_start = startPos; Location.loc_end=endPos; loc_ghost=false} in - let err = { Location.loc; msg; sub=[]; if_highlight=""} in - Location.default_error_reporter - ~src:(Some src) - Format.str_formatter - err; - Format.flush_str_formatter () - - let parse_implementation ~sourcefile ~forPrinter ~src = - Location.input_name := sourcefile; - let parseResult = - let engine = setup ~filename:sourcefile ~forPrinter ~src () in - let structure = Res_core.parseImplementation engine in - let (invalid, diagnostics) = match engine.diagnostics with - | [] as diagnostics -> (false, diagnostics) - | _ as diagnostics -> (true, diagnostics) - in { - filename = engine.scanner.filename; - source = engine.scanner.src; - parsetree = structure; - diagnostics; - invalid; - comments = List.rev engine.comments; - } - in - let () = if parseResult.invalid then - let errors = parseResult.diagnostics - |> List.map (fun d -> - let fullMsg = diagnosticToString ~src:parseResult.source d in - let shortMsg = Res_diagnostics.explain d in - let loc = { - Location.loc_start = Res_diagnostics.getStartPos d; - Location.loc_end = Res_diagnostics.getEndPos d; - loc_ghost = false - } in - { - fullMsg; - shortMsg; - loc; - } - ) - |> List.rev - in - raise (RescriptParsingErrors errors) - in - (parseResult.parsetree, parseResult.comments) -end - -let rescript_parse ~filename src = - let (structure, _ ) = ResDriver.parse_implementation ~forPrinter:false ~sourcefile:filename ~src - in - structure - - -module Printer = struct - let printExpr typ = - Printtyp.reset_names(); - Printtyp.reset_and_mark_loops typ; - Res_doc.toString - ~width:60 (Res_outcome_printer.printOutTypeDoc (Printtyp.tree_of_typexp false typ)) - - - let printDecl ~recStatus name decl = - Printtyp.reset_names(); - Res_doc.toString - ~width:60 - (Res_outcome_printer.printOutSigItemDoc (Printtyp.tree_of_type_declaration (Ident.create name) decl recStatus)) -end - -module Compile = struct - (* Apparently it's not possible to retrieve the loc info from - * Location.error_of_exn properly, so we need to do some extra - * overloading action - * *) - let warning_infos: LocWarnInfo.t array ref = ref [||] - let warning_buffer = Buffer.create 512 - let warning_ppf = Format.formatter_of_buffer warning_buffer - - let flush_warning_buffer () = - Format.pp_print_flush warning_ppf (); - let str = Buffer.contents warning_buffer in - Buffer.reset warning_buffer; - str - - (* We need to overload the original warning printer to capture the warnings - as an array *) - let playground_warning_printer loc ppf w = - match Warnings.report w with - | `Inactive -> () - | `Active { Warnings. number; is_error; } -> - Location.default_warning_printer loc ppf w; - let open LocWarnInfo in - let fullMsg = flush_warning_buffer () in - let shortMsg = Warnings.message w in - let info = { - fullMsg; - shortMsg; - warnNumber=number; - isError=is_error; - loc; - } in - warning_infos := Array.append !warning_infos [|info|] - - let () = - Location.formatter_for_warnings := warning_ppf; - Location.warning_printer := playground_warning_printer - - let handle_err e = - (match error_of_exn e with - | Some error -> - (* This branch handles all - * errors handled by the Location error reporting - * system. - * - * Here we can differentiate between the different kinds - * of error types just by looking at the raised exn names *) - let type_ = match e with - | Typetexp.Error _ - | Typecore.Error _ - | Typemod.Error _ -> "type_error" - | Lexer.Error _ - | Syntaxerr.Error _ -> "syntax_error" - | _ -> "other_error" - in - let fullMsg = - Location.report_error Format.str_formatter error; - Format.flush_str_formatter () - in - let err = { fullMsg; shortMsg=error.msg; loc=error.loc; } in - ErrorRet.fromLocErrors ~type_ [|err|] - | None -> - match e with - | RescriptParsingErrors errors -> - ErrorRet.fromSyntaxErrors(Array.of_list errors) - | _ -> - let msg = Printexc.to_string e in - match e with - | Warnings.Errors -> - ErrorRet.makeWarningError !warning_infos - | _ -> ErrorRet.makeUnexpectedError msg) - - (* Responsible for resetting all compiler state as if it were a new instance *) - let reset_compiler () = - warning_infos := [||]; - flush_warning_buffer () |> ignore; - Location.reset(); - Warnings.reset_fatal (); - Env.reset_cache_toplevel () - - (* Collects the type information from the typed_tree, so we can use that - * data to display types on hover etc. - * - * Note: start / end positions - * *) - let collectTypeHints typed_tree = - let open Typedtree in - let createTypeHintObj loc kind hint = - let open Location in - let (_ , startline, startcol) = Location.get_pos_info loc.loc_start in - let (_ , endline, endcol) = Location.get_pos_info loc.loc_end in - Js.Unsafe.(obj [| - "start", inject @@ (obj [| - "line", inject @@ (startline |> float_of_int |> Js.number_of_float); - "col", inject @@ (startcol|> float_of_int |> Js.number_of_float); - |]); - "end", inject @@ (obj [| - "line", inject @@ (endline |> float_of_int |> Js.number_of_float); - "col", inject @@ (endcol |> float_of_int |> Js.number_of_float); - |]); - "kind", inject @@ Js.string kind; - "hint", inject @@ Js.string hint; - |]) - in - let (structure, _) = typed_tree in - let acc = ref [] in - let module Iter = TypedtreeIter.MakeIterator (struct - include TypedtreeIter.DefaultIteratorArgument - - let cur_rec_status = ref None - - let enter_expression expr = - let hint = Printer.printExpr expr.exp_type in - let obj = createTypeHintObj expr.exp_loc "expression" hint in - acc := obj :: !acc - - let enter_binding binding = - let hint = Printer.printExpr binding.vb_expr.exp_type in - let obj = createTypeHintObj binding.vb_loc "binding" hint in - acc := obj :: !acc - - let enter_core_type ct = - let hint = Printer.printExpr ct.ctyp_type in - let obj = createTypeHintObj ct.ctyp_loc "core_type" hint in - acc := obj :: !acc - - let enter_type_declarations recFlag = - let status = match recFlag with - | Asttypes.Nonrecursive -> Types.Trec_not - | Recursive -> Trec_first - in - cur_rec_status := Some status - - let enter_type_declaration tdecl = - let open Types in - match !cur_rec_status with - | Some recStatus -> - let hint = Printer.printDecl ~recStatus tdecl.typ_name.Asttypes.txt tdecl.typ_type in - let obj = createTypeHintObj tdecl.typ_loc "type_declaration" hint in - acc := obj :: !acc; - (match recStatus with - | Trec_not - | Trec_first -> cur_rec_status := Some Trec_next - | _ -> ()) - | None -> () - end) - in - List.iter Iter.iter_structure_item structure.str_items; - Js.array (!acc |> Array.of_list) - - let implementation ~(config: BundleConfig.t) ~lang str = - let {BundleConfig.module_system; warn_flags; open_modules} = config in - try - reset_compiler (); - Warnings.parse_options false warn_flags; - let filename = get_filename ~lang config.filename in - let modulename = "Playground" in - let impl = match lang with - | Lang.OCaml -> ocaml_parse ~filename - | Res -> rescript_parse ~filename - in - Clflags.open_modules := open_modules; - (* let env = !Toploop.toplevel_env in *) - (* Res_compmisc.init_path (); *) - (* let modulename = module_of_filename ppf sourcefile outputprefix in *) - (* Env.set_unit_name modulename; *) - Lam_compile_env.reset () ; - let env = Res_compmisc.initial_env () in (* Question ?? *) - (* let finalenv = ref Env.empty in *) - let types_signature = ref [] in - Js_config.jsx_version := Some Js_config.Jsx_v4; (* default *) - Js_config.jsx_mode := Js_config.Automatic; (* default *) - let ast = impl (str) in - let ast = Ppx_entry.rewrite_implementation ast in - let typed_tree = - let (a,b,_,signature) = Typemod.type_implementation_more modulename modulename modulename env ast in - (* finalenv := c ; *) - types_signature := signature; - (a,b) in - typed_tree - |> Translmod.transl_implementation modulename - |> (* Printlambda.lambda ppf *) (fun (lam, exports) -> - let buffer = Buffer.create 1000 in - let () = Js_dump_program.pp_deps_program - ~output_prefix:"" (* does not matter here *) - module_system - (Lam_compile_main.compile "" exports lam) - (Ext_pp.from_buffer buffer) in - let v = Buffer.contents buffer in - let typeHints = collectTypeHints typed_tree in - Js.Unsafe.(obj [| - "js_code", inject @@ Js.string v; - "warnings", - inject @@ ( - !warning_infos - |> Array.map ErrorRet.makeWarning - |> Js.array - |> inject - ); - "type_hints", inject @@ typeHints; - "type" , inject @@ Js.string "success" - |])) - with - | e -> - match e with - | Arg.Bad msg -> - ErrorRet.makeWarningFlagError ~warn_flags msg - | _ -> handle_err e;; - - let syntax_format ?(filename: string option) ~(from:Lang.t) ~(to_:Lang.t) (src: string) = - let filename = get_filename ~lang:from filename in - try - let code = match (from, to_) with - | (OCaml, Res) -> - let structure = - src - |> lexbuf_from_string ~filename - |> Parse.implementation - in - Res_printer.printImplementation ~width:80 structure ~comments:[] - | (Res, OCaml) -> - let (structure, _) = - ResDriver.parse_implementation ~forPrinter:false ~sourcefile:filename ~src - in - Pprintast.structure Format.str_formatter structure; - Format.flush_str_formatter () - | (Res, Res) -> - (* Essentially pretty printing. - * IMPORTANT: we need forPrinter:true when parsing code here, - * otherwise we will loose some information for the ReScript printer *) - let (structure, comments) = - ResDriver.parse_implementation ~forPrinter:true ~sourcefile:filename ~src - in - Res_printer.printImplementation ~width:80 structure ~comments - | (OCaml, OCaml) -> src - in - Js.Unsafe.(obj [| - "code", inject @@ Js.string code; - "fromLang", inject @@ Js.string (Lang.toString from); - "toLang", inject @@ Js.string (Lang.toString to_); - "type" , inject @@ Js.string "success" - |]) - with - | e -> handle_err e -end - - -(* To add a directory to the load path *) -let dir_directory d = - Config.load_path := d :: !Config.load_path -let () = - dir_directory "/static" - -module Export = struct - let make_compiler ~config ~lang = - let open Lang in - let open Js.Unsafe in - let baseAttrs = - [|"compile", - inject @@ - Js.wrap_meth_callback - (fun _ code -> - (Compile.implementation ~config ~lang (Js.to_string code))); - "version", - inject @@ - Js.string - (match lang with - | Res -> Bs_version.version - | OCaml -> Sys.ocaml_version); - |] in - let attrs = - if lang != OCaml then - Array.append baseAttrs [| - ("format", - inject @@ - Js.wrap_meth_callback - (fun _ code -> - (match lang with - | OCaml -> ErrorRet.makeUnexpectedError ("OCaml pretty printing not supported") - | _ -> Compile.syntax_format ?filename:config.filename ~from:lang ~to_:lang (Js.to_string code)))) - |] - else - baseAttrs - in - obj attrs - - (* Creates a "compiler instance" binding the configuration context to the specific compile / formatter functions *) - let make () = - let open Lang in - let config = BundleConfig.make () in - let set_module_system value = - match value with - | "esmodule" | "es6" -> - config.module_system <- Ext_module_system.Esmodule; true - | "commonjs" | "nodejs" -> - config.module_system <- Commonjs; true - | _ -> false in - let set_filename value = - config.filename <- Some value; true - in - let set_warn_flags value = - config.warn_flags <- value; true - in - let set_open_modules value = - config.open_modules <- value; true - in - let convert_syntax ~(fromLang: string) ~(toLang: string) (src: string) = - let open Lang in - match (fromString fromLang, fromString toLang) with - | (Some from, Some to_) -> - Compile.syntax_format ?filename:config.filename ~from ~to_ src - | other -> - let msg = match other with - | (None, None) -> "Unknown from / to language: " ^ fromLang ^ ", " ^ toLang - | (None, Some _) -> "Unknown from language: " ^ fromLang - | (Some _, None) -> "Unknown to language: " ^ toLang - | (Some _, Some _) -> "Can't convert from " ^ fromLang ^ " to " ^ toLang - in - ErrorRet.makeUnexpectedError(msg) - in - Js.Unsafe.(obj [| - "version", - inject @@ Js.string Bs_version.version; - "ocaml", - inject @@ make_compiler ~config ~lang:OCaml; - "rescript", - inject @@ make_compiler ~config ~lang:Res; - "convertSyntax", - inject @@ - Js.wrap_meth_callback - (fun _ fromLang toLang src -> - (convert_syntax ~fromLang:(Js.to_string fromLang) ~toLang:(Js.to_string toLang) (Js.to_string src)) - ); - "setModuleSystem", - inject @@ - Js.wrap_meth_callback - (fun _ value -> - (Js.bool (set_module_system (Js.to_string value))) - ); - "setFilename", - inject @@ - Js.wrap_meth_callback - (fun _ value -> - (Js.bool (set_filename (Js.to_string value))) - ); - "setWarnFlags", - inject @@ - Js.wrap_meth_callback - (fun _ value -> - (Js.bool (set_warn_flags (Js.to_string value))) - ); - "setOpenModules", - inject @@ - Js.wrap_meth_callback - (fun _ (value) -> - (Js.bool (set_open_modules (value |> Js.to_array |> Array.map Js.to_string |> Array.to_list))) - ); - "getConfig", - inject @@ - Js.wrap_meth_callback - (fun _ -> - (Js.Unsafe.(obj - [| - "module_system", - inject @@ ( - config.module_system - |> BundleConfig.string_of_module_system - |> Js.string - ); - "warn_flags", - inject @@ (Js.string config.warn_flags); - "uncurried", inject @@ (Js.bool config.uncurried); - "open_modules", inject @@ (config.open_modules |> Array.of_list |> Js.array); - |])) - ); - |]) - -end - -let () = - export "rescript_compiler" - (Js.Unsafe.(obj - [| - "api_version", - inject @@ Js.string apiVersion; - "version", - inject @@ Js.string Bs_version.version; - "make", - inject @@ Export.make - |])) - diff --git a/jscomp/jsoo/jsoo_playground_main.mli b/jscomp/jsoo/jsoo_playground_main.mli deleted file mode 100644 index f4f9d89..0000000 --- a/jscomp/jsoo/jsoo_playground_main.mli +++ /dev/null @@ -1,25 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - diff --git a/jscomp/keywords.list b/jscomp/keywords.list deleted file mode 100644 index b51740d..0000000 --- a/jscomp/keywords.list +++ /dev/null @@ -1,661 +0,0 @@ -AbortController -AbortSignal -AbstractRange -AggregateError -AnalyserNode -Animation -AnimationEffect -AnimationEvent -AnimationPlaybackEvent -AnimationTimeline -Array -ArrayBuffer -Atomics -Attr -Audio -AudioBuffer -AudioBufferSourceNode -AudioContext -AudioData -AudioDestinationNode -AudioListener -AudioNode -AudioParam -AudioParamMap -AudioProcessingEvent -AudioScheduledSourceNode -AudioSinkInfo -AudioWorkletNode -BackgroundFetchManager -BackgroundFetchRecord -BackgroundFetchRegistration -BarProp -BaseAudioContext -BeforeInstallPromptEvent -BeforeUnloadEvent -BigInt -BigInt64Array -BigUint64Array -BiquadFilterNode -Blob -BlobEvent -BluetoothUUID -Boolean -BroadcastChannel -BrowserCaptureMediaStreamTrack -ByteLengthQueuingStrategy -CDATASection -CSS -CSSAnimation -CSSConditionRule -CSSContainerRule -CSSCounterStyleRule -CSSFontFaceRule -CSSFontPaletteValuesRule -CSSGroupingRule -CSSImageValue -CSSImportRule -CSSKeyframeRule -CSSKeyframesRule -CSSKeywordValue -CSSLayerBlockRule -CSSLayerStatementRule -CSSMathClamp -CSSMathInvert -CSSMathMax -CSSMathMin -CSSMathNegate -CSSMathProduct -CSSMathSum -CSSMathValue -CSSMatrixComponent -CSSMediaRule -CSSNamespaceRule -CSSNumericArray -CSSNumericValue -CSSPageRule -CSSPerspective -CSSPositionValue -CSSPropertyRule -CSSRotate -CSSRule -CSSRuleList -CSSScale -CSSSkew -CSSSkewX -CSSSkewY -CSSStyleDeclaration -CSSStyleRule -CSSStyleSheet -CSSStyleValue -CSSSupportsRule -CSSTransformComponent -CSSTransformValue -CSSTransition -CSSTranslate -CSSUnitValue -CSSUnparsedValue -CSSVariableReferenceValue -CanvasCaptureMediaStreamTrack -CanvasGradient -CanvasPattern -CanvasRenderingContext2D -ChannelMergerNode -ChannelSplitterNode -CharacterData -ClipboardEvent -CloseEvent -Comment -CompositionEvent -CompressionStream -ConstantSourceNode -ContentVisibilityAutoStateChangeEvent -ConvolverNode -CountQueuingStrategy -CropTarget -Crypto -CustomElementRegistry -CustomEvent -CustomStateSet -DOMError -DOMException -DOMImplementation -DOMMatrix -DOMMatrixReadOnly -DOMParser -DOMPoint -DOMPointReadOnly -DOMQuad -DOMRect -DOMRectList -DOMRectReadOnly -DOMStringList -DOMStringMap -DOMTokenList -DataTransfer -DataTransferItem -DataTransferItemList -DataView -Date -DecompressionStream -DelayNode -DelegatedInkTrailPresenter -Document -DocumentFragment -DocumentPictureInPictureEvent -DocumentTimeline -DocumentType -DragEvent -DynamicsCompressorNode -Element -ElementInternals -EncodedAudioChunk -EncodedVideoChunk -Error -ErrorEvent -EvalError -Event -EventCounts -EventSource -EventTarget -External -FeaturePolicy -File -FileList -FileReader -FinalizationRegistry -Float32Array -Float64Array -FocusEvent -FontFace -FontFaceSetLoadEvent -FormData -FormDataEvent -FragmentDirective -Function -GainNode -Gamepad -GamepadButton -GamepadEvent -GamepadHapticActuator -Geolocation -GeolocationCoordinates -GeolocationPosition -GeolocationPositionError -HTMLAllCollection -HTMLAnchorElement -HTMLAreaElement -HTMLAudioElement -HTMLBRElement -HTMLBaseElement -HTMLBodyElement -HTMLButtonElement -HTMLCanvasElement -HTMLCollection -HTMLDListElement -HTMLDataElement -HTMLDataListElement -HTMLDetailsElement -HTMLDialogElement -HTMLDirectoryElement -HTMLDivElement -HTMLDocument -HTMLElement -HTMLEmbedElement -HTMLFieldSetElement -HTMLFontElement -HTMLFormControlsCollection -HTMLFormElement -HTMLFrameElement -HTMLFrameSetElement -HTMLHRElement -HTMLHeadElement -HTMLHeadingElement -HTMLHtmlElement -HTMLIFrameElement -HTMLImageElement -HTMLInputElement -HTMLLIElement -HTMLLabelElement -HTMLLegendElement -HTMLLinkElement -HTMLMapElement -HTMLMarqueeElement -HTMLMediaElement -HTMLMenuElement -HTMLMetaElement -HTMLMeterElement -HTMLModElement -HTMLOListElement -HTMLObjectElement -HTMLOptGroupElement -HTMLOptionElement -HTMLOptionsCollection -HTMLOutputElement -HTMLParagraphElement -HTMLParamElement -HTMLPictureElement -HTMLPreElement -HTMLProgressElement -HTMLQuoteElement -HTMLScriptElement -HTMLSelectElement -HTMLSlotElement -HTMLSourceElement -HTMLSpanElement -HTMLStyleElement -HTMLTableCaptionElement -HTMLTableCellElement -HTMLTableColElement -HTMLTableElement -HTMLTableRowElement -HTMLTableSectionElement -HTMLTemplateElement -HTMLTextAreaElement -HTMLTimeElement -HTMLTitleElement -HTMLTrackElement -HTMLUListElement -HTMLUnknownElement -HTMLVideoElement -HashChangeEvent -Headers -Highlight -HighlightRegistry -History -IDBCursor -IDBCursorWithValue -IDBDatabase -IDBFactory -IDBIndex -IDBKeyRange -IDBObjectStore -IDBOpenDBRequest -IDBRequest -IDBTransaction -IDBVersionChangeEvent -IIRFilterNode -IdleDeadline -Image -ImageBitmap -ImageBitmapRenderingContext -ImageCapture -ImageData -ImageTrack -ImageTrackList -Infinity -Ink -InputDeviceCapabilities -InputDeviceInfo -InputEvent -Int16Array -Int32Array -Int8Array -IntersectionObserver -IntersectionObserverEntry -Intl -JSON -KeyboardEvent -KeyframeEffect -LargestContentfulPaint -LaunchParams -LaunchQueue -LayoutShift -LayoutShiftAttribution -Location -Map -Math -MathMLElement -MediaCapabilities -MediaElementAudioSourceNode -MediaEncryptedEvent -MediaError -MediaList -MediaMetadata -MediaQueryList -MediaQueryListEvent -MediaRecorder -MediaSession -MediaSource -MediaSourceHandle -MediaStream -MediaStreamAudioDestinationNode -MediaStreamAudioSourceNode -MediaStreamEvent -MediaStreamTrack -MediaStreamTrackEvent -MediaStreamTrackGenerator -MediaStreamTrackProcessor -MessageChannel -MessageEvent -MessagePort -MimeType -MimeTypeArray -MouseEvent -MutationEvent -MutationObserver -MutationRecord -NaN -NamedNodeMap -NavigateEvent -Navigation -NavigationCurrentEntryChangeEvent -NavigationDestination -NavigationHistoryEntry -NavigationTransition -Navigator -NavigatorUAData -NetworkInformation -Node -NodeFilter -NodeIterator -NodeList -Notification -Number -Object -OfflineAudioCompletionEvent -OfflineAudioContext -OffscreenCanvas -OffscreenCanvasRenderingContext2D -Option -OscillatorNode -OverconstrainedError -PageTransitionEvent -PannerNode -Path2D -PaymentManager -PaymentRequestUpdateEvent -Performance -PerformanceElementTiming -PerformanceEntry -PerformanceEventTiming -PerformanceLongTaskTiming -PerformanceMark -PerformanceMeasure -PerformanceNavigation -PerformanceNavigationTiming -PerformanceObserver -PerformanceObserverEntryList -PerformancePaintTiming -PerformanceResourceTiming -PerformanceServerTiming -PerformanceTiming -PeriodicSyncManager -PeriodicWave -PermissionStatus -Permissions -PictureInPictureEvent -PictureInPictureWindow -Plugin -PluginArray -PointerEvent -PopStateEvent -ProcessingInstruction -Profiler -ProgressEvent -Promise -PromiseRejectionEvent -Proxy -PushManager -PushSubscription -PushSubscriptionOptions -RTCCertificate -RTCDTMFSender -RTCDTMFToneChangeEvent -RTCDataChannel -RTCDataChannelEvent -RTCDtlsTransport -RTCEncodedAudioFrame -RTCEncodedVideoFrame -RTCError -RTCErrorEvent -RTCIceCandidate -RTCIceTransport -RTCPeerConnection -RTCPeerConnectionIceErrorEvent -RTCPeerConnectionIceEvent -RTCRtpReceiver -RTCRtpSender -RTCRtpTransceiver -RTCSctpTransport -RTCSessionDescription -RTCStatsReport -RTCTrackEvent -RadioNodeList -Range -RangeError -ReadableByteStreamController -ReadableStream -ReadableStreamBYOBReader -ReadableStreamBYOBRequest -ReadableStreamDefaultController -ReadableStreamDefaultReader -ReferenceError -Reflect -RegExp -RemotePlayback -ReportingObserver -Request -ResizeObserver -ResizeObserverEntry -ResizeObserverSize -Response -SVGAElement -SVGAngle -SVGAnimateElement -SVGAnimateMotionElement -SVGAnimateTransformElement -SVGAnimatedAngle -SVGAnimatedBoolean -SVGAnimatedEnumeration -SVGAnimatedInteger -SVGAnimatedLength -SVGAnimatedLengthList -SVGAnimatedNumber -SVGAnimatedNumberList -SVGAnimatedPreserveAspectRatio -SVGAnimatedRect -SVGAnimatedString -SVGAnimatedTransformList -SVGAnimationElement -SVGCircleElement -SVGClipPathElement -SVGComponentTransferFunctionElement -SVGDefsElement -SVGDescElement -SVGElement -SVGEllipseElement -SVGFEBlendElement -SVGFEColorMatrixElement -SVGFEComponentTransferElement -SVGFECompositeElement -SVGFEConvolveMatrixElement -SVGFEDiffuseLightingElement -SVGFEDisplacementMapElement -SVGFEDistantLightElement -SVGFEDropShadowElement -SVGFEFloodElement -SVGFEFuncAElement -SVGFEFuncBElement -SVGFEFuncGElement -SVGFEFuncRElement -SVGFEGaussianBlurElement -SVGFEImageElement -SVGFEMergeElement -SVGFEMergeNodeElement -SVGFEMorphologyElement -SVGFEOffsetElement -SVGFEPointLightElement -SVGFESpecularLightingElement -SVGFESpotLightElement -SVGFETileElement -SVGFETurbulenceElement -SVGFilterElement -SVGForeignObjectElement -SVGGElement -SVGGeometryElement -SVGGradientElement -SVGGraphicsElement -SVGImageElement -SVGLength -SVGLengthList -SVGLineElement -SVGLinearGradientElement -SVGMPathElement -SVGMarkerElement -SVGMaskElement -SVGMatrix -SVGMetadataElement -SVGNumber -SVGNumberList -SVGPathElement -SVGPatternElement -SVGPoint -SVGPointList -SVGPolygonElement -SVGPolylineElement -SVGPreserveAspectRatio -SVGRadialGradientElement -SVGRect -SVGRectElement -SVGSVGElement -SVGScriptElement -SVGSetElement -SVGStopElement -SVGStringList -SVGStyleElement -SVGSwitchElement -SVGSymbolElement -SVGTSpanElement -SVGTextContentElement -SVGTextElement -SVGTextPathElement -SVGTextPositioningElement -SVGTitleElement -SVGTransform -SVGTransformList -SVGUnitTypes -SVGUseElement -SVGViewElement -Scheduler -Scheduling -Screen -ScreenOrientation -ScriptProcessorNode -ScrollTimeline -SecurityPolicyViolationEvent -Selection -Set -ShadowRoot -SharedWorker -SourceBuffer -SourceBufferList -SpeechSynthesisErrorEvent -SpeechSynthesisEvent -SpeechSynthesisUtterance -StaticRange -StereoPannerNode -Storage -StorageEvent -String -StylePropertyMap -StylePropertyMapReadOnly -StyleSheet -StyleSheetList -SubmitEvent -Symbol -SyncManager -SyntaxError -TaskAttributionTiming -TaskController -TaskPriorityChangeEvent -TaskSignal -Text -TextDecoder -TextDecoderStream -TextEncoder -TextEncoderStream -TextEvent -TextMetrics -TextTrack -TextTrackCue -TextTrackCueList -TextTrackList -TimeRanges -ToggleEvent -Touch -TouchEvent -TouchList -TrackEvent -TransformStream -TransformStreamDefaultController -TransitionEvent -TreeWalker -TrustedHTML -TrustedScript -TrustedScriptURL -TrustedTypePolicy -TrustedTypePolicyFactory -TypeError -UIEvent -URIError -URL -URLPattern -URLSearchParams -Uint16Array -Uint32Array -Uint8Array -Uint8ClampedArray -UserActivation -VTTCue -ValidityState -VideoColorSpace -VideoFrame -VideoPlaybackQuality -ViewTimeline -ViewTransition -VirtualKeyboardGeometryChangeEvent -VisibilityStateEntry -VisualViewport -WaveShaperNode -WeakMap -WeakRef -WeakSet -WebAssembly -WebGL2RenderingContext -WebGLActiveInfo -WebGLBuffer -WebGLContextEvent -WebGLFramebuffer -WebGLProgram -WebGLQuery -WebGLRenderbuffer -WebGLRenderingContext -WebGLSampler -WebGLShader -WebGLShaderPrecisionFormat -WebGLSync -WebGLTexture -WebGLTransformFeedback -WebGLUniformLocation -WebGLVertexArrayObject -WebKitCSSMatrix -WebKitMutationObserver -WebSocket -WheelEvent -Window -WindowControlsOverlay -WindowControlsOverlayGeometryChangeEvent -Worker -WritableStream -WritableStreamDefaultController -WritableStreamDefaultWriter -XMLDocument -XMLHttpRequest -XMLHttpRequestEventTarget -XMLHttpRequestUpload -XMLSerializer -XPathEvaluator -XPathExpression -XPathResult -XSLTProcessor \ No newline at end of file diff --git a/jscomp/ml/.ocamlformat b/jscomp/ml/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/ml/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/ml/ast_async.ml b/jscomp/ml/ast_async.ml deleted file mode 100644 index b1552cd..0000000 --- a/jscomp/ml/ast_async.ml +++ /dev/null @@ -1,42 +0,0 @@ -let is_async : Parsetree.attribute -> bool = - fun ({txt}, _) -> txt = "async" || txt = "res.async" - -let add_promise_type ?(loc = Location.none) ~async - (result : Parsetree.expression) = - if async then - let unsafe_async = - Ast_helper.Exp.ident ~loc - {txt = Ldot (Ldot (Lident "Js", "Promise"), "unsafe_async"); loc} - in - Ast_helper.Exp.apply ~loc unsafe_async [(Nolabel, result)] - else result - -let add_async_attribute ~async (body : Parsetree.expression) = - if async then - ( - match body.pexp_desc with - | Pexp_construct (x, Some e) when Ast_uncurried.exprIsUncurriedFun body -> - {body with pexp_desc = Pexp_construct (x, Some {e with pexp_attributes = - ({txt = "res.async"; loc = Location.none}, PStr []) :: e.pexp_attributes} )} - | _ -> - { - body with - pexp_attributes = - ({txt = "res.async"; loc = Location.none}, PStr []) - :: body.pexp_attributes; - }) - else body - -let rec add_promise_to_result ~loc (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_fun (label, eo, pat, body) -> - let body = add_promise_to_result ~loc body in - {e with pexp_desc = Pexp_fun (label, eo, pat, body)} - | _ -> add_promise_type ~loc ~async:true e - -let make_function_async ~async (e : Parsetree.expression) = - if async then - match e.pexp_desc with - | Pexp_fun (_, _, {ppat_loc}, _) -> add_promise_to_result ~loc:ppat_loc e - | _ -> assert false - else e diff --git a/jscomp/ml/ast_await.ml b/jscomp/ml/ast_await.ml deleted file mode 100644 index 1393f04..0000000 --- a/jscomp/ml/ast_await.ml +++ /dev/null @@ -1,41 +0,0 @@ -let is_await : Parsetree.attribute -> bool = - fun ({txt}, _) -> txt = "await" || txt = "res.await" - -let create_await_expression (e : Parsetree.expression) = - let loc = {e.pexp_loc with loc_ghost = true} in - let unsafe_await = - Ast_helper.Exp.ident ~loc - {txt = Ldot (Ldot (Lident "Js", "Promise"), "unsafe_await"); loc} - in - Ast_helper.Exp.apply ~loc unsafe_await [(Nolabel, e)] - -(* Transform `@res.await M` to unpack(@res.await Js.import(module(M: __M0__))) *) -let create_await_module_expression ~module_type_lid (e : Parsetree.module_expr) - = - let open Ast_helper in - let remove_await_attribute = - List.filter (fun ((loc, _) : Parsetree.attribute) -> loc.txt != "res.await") - in - { - e with - pmod_desc = - Pmod_unpack - (create_await_expression - (Exp.apply ~loc:e.pmod_loc - (Exp.ident ~loc:e.pmod_loc - { - txt = Longident.Ldot (Lident "Js", "import"); - loc = e.pmod_loc; - }) - [ - ( Nolabel, - Exp.constraint_ ~loc:e.pmod_loc - (Exp.pack ~loc:e.pmod_loc - { - e with - pmod_attributes = - remove_await_attribute e.pmod_attributes; - }) - (Typ.package ~loc:e.pmod_loc module_type_lid []) ); - ])); - } diff --git a/jscomp/ml/ast_helper.ml b/jscomp/ml/ast_helper.ml deleted file mode 100644 index 80fb40a..0000000 --- a/jscomp/ml/ast_helper.ml +++ /dev/null @@ -1,560 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments *) - -open Asttypes -open Parsetree -open Docstrings - -type lid = Longident.t loc -type str = string loc -type loc = Location.t -type attrs = attribute list - -let default_loc = ref Location.none - -let with_default_loc l f = - let old = !default_loc in - default_loc := l; - try let r = f () in default_loc := old; r - with exn -> default_loc := old; raise exn - -module Const = struct - let integer ?suffix i = Pconst_integer (i, suffix) - let int ?suffix i = integer ?suffix (string_of_int i) - let int32 ?(suffix='l') i = integer ~suffix (Int32.to_string i) - let int64 ?(suffix='L') i = integer ~suffix (Int64.to_string i) - let nativeint ?(suffix='n') i = integer ~suffix (Nativeint.to_string i) - let float ?suffix f = Pconst_float (f, suffix) - let char c = Pconst_char (Char.code c) - let string ?quotation_delimiter s = Pconst_string (s, quotation_delimiter) -end - -module Typ = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ptyp_desc = d; ptyp_loc = loc; ptyp_attributes = attrs} - let attr d a = {d with ptyp_attributes = d.ptyp_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_arrow (a, b, c)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) - let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) - let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) - let class_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_class (a, b)) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) - let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) - - let force_poly t = - match t.ptyp_desc with - | Ptyp_poly _ -> t - | _ -> poly ~loc:t.ptyp_loc [] t (* -> ghost? *) - - let varify_constructors var_names t = - let check_variable vl loc v = - if List.mem v vl then - raise Syntaxerr.(Error(Variable_in_scope(loc,v))) in - let var_names = List.map (fun v -> v.txt) var_names in - let rec loop t = - let desc = - match t.ptyp_desc with - | Ptyp_any -> Ptyp_any - | Ptyp_var x -> - check_variable var_names t.ptyp_loc x; - Ptyp_var x - | Ptyp_arrow (label,core_type,core_type') -> - Ptyp_arrow(label, loop core_type, loop core_type') - | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) - | Ptyp_constr( { txt = Longident.Lident s }, []) - when List.mem s var_names -> - Ptyp_var s - | Ptyp_constr(longident, lst) -> - Ptyp_constr(longident, List.map loop lst) - | Ptyp_object (lst, o) -> - Ptyp_object (List.map loop_object_field lst, o) - | Ptyp_class (longident, lst) -> - Ptyp_class (longident, List.map loop lst) - | Ptyp_alias(core_type, string) -> - check_variable var_names t.ptyp_loc string; - Ptyp_alias(loop core_type, string) - | Ptyp_variant(row_field_list, flag, lbl_lst_option) -> - Ptyp_variant(List.map loop_row_field row_field_list, - flag, lbl_lst_option) - | Ptyp_poly(string_lst, core_type) -> - List.iter (fun v -> - check_variable var_names t.ptyp_loc v.txt) string_lst; - Ptyp_poly(string_lst, loop core_type) - | Ptyp_package(longident,lst) -> - Ptyp_package(longident,List.map (fun (n,typ) -> (n,loop typ) ) lst) - | Ptyp_extension (s, arg) -> - Ptyp_extension (s, arg) - in - {t with ptyp_desc = desc} - and loop_row_field = - function - | Rtag(label,attrs,flag,lst) -> - Rtag(label,attrs,flag,List.map loop lst) - | Rinherit t -> - Rinherit (loop t) - and loop_object_field = - function - | Otag(label, attrs, t) -> - Otag(label, attrs, loop t) - | Oinherit t -> - Oinherit (loop t) - in - loop t - -end - -module Pat = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {ppat_desc = d; ppat_loc = loc; ppat_attributes = attrs} - let attr d a = {d with ppat_attributes = d.ppat_attributes @ [a]} - - let any ?loc ?attrs () = mk ?loc ?attrs Ppat_any - let var ?loc ?attrs a = mk ?loc ?attrs (Ppat_var a) - let alias ?loc ?attrs a b = mk ?loc ?attrs (Ppat_alias (a, b)) - let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) - let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Ppat_record (a, b)) - let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) - let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_constraint (a, b)) - let type_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_type a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_lazy a) - let unpack ?loc ?attrs a = mk ?loc ?attrs (Ppat_unpack a) - let open_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_open (a, b)) - let exception_ ?loc ?attrs a = mk ?loc ?attrs (Ppat_exception a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Ppat_extension a) -end - -module Exp = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pexp_desc = d; pexp_loc = loc; pexp_attributes = attrs} - let attr d a = {d with pexp_attributes = d.pexp_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) - let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_fun (a, b, c, d)) - let function_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_function a) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pexp_apply (a, b)) - let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) - let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) - let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) - let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) - let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) - let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) - let array ?loc ?attrs a = mk ?loc ?attrs (Pexp_array a) - let ifthenelse ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_ifthenelse (a, b, c)) - let sequence ?loc ?attrs a b = mk ?loc ?attrs (Pexp_sequence (a, b)) - let while_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_while (a, b)) - let for_ ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_for (a, b, c, d, e)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_constraint (a, b)) - let coerce ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_coerce (a, b, c)) - let send ?loc ?attrs a b = mk ?loc ?attrs (Pexp_send (a, b)) - let new_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_new a) - let setinstvar ?loc ?attrs a b = mk ?loc ?attrs (Pexp_setinstvar (a, b)) - let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c= mk ?loc ?attrs (Pexp_letmodule (a, b, c)) - let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) - let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) - let poly ?loc ?attrs a b = mk ?loc ?attrs (Pexp_poly (a, b)) - let object_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_object a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) - let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) - let unreachable ?loc ?attrs () = mk ?loc ?attrs Pexp_unreachable - - let case lhs ?guard rhs = - { - pc_lhs = lhs; - pc_guard = guard; - pc_rhs = rhs; - } -end - -module Mty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmty_desc = d; pmty_loc = loc; pmty_attributes = attrs} - let attr d a = {d with pmty_attributes = d.pmty_attributes @ [a]} - - let ident ?loc ?attrs a = mk ?loc ?attrs (Pmty_ident a) - let alias ?loc ?attrs a = mk ?loc ?attrs (Pmty_alias a) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pmty_signature a) - let functor_ ?loc ?attrs a b c = mk ?loc ?attrs (Pmty_functor (a, b, c)) - let with_ ?loc ?attrs a b = mk ?loc ?attrs (Pmty_with (a, b)) - let typeof_ ?loc ?attrs a = mk ?loc ?attrs (Pmty_typeof a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmty_extension a) -end - -module Mod = struct -let mk ?(loc = !default_loc) ?(attrs = []) d = - {pmod_desc = d; pmod_loc = loc; pmod_attributes = attrs} - let attr d a = {d with pmod_attributes = d.pmod_attributes @ [a]} - - let ident ?loc ?attrs x = mk ?loc ?attrs (Pmod_ident x) - let structure ?loc ?attrs x = mk ?loc ?attrs (Pmod_structure x) - let functor_ ?loc ?attrs arg arg_ty body = - mk ?loc ?attrs (Pmod_functor (arg, arg_ty, body)) - let apply ?loc ?attrs m1 m2 = mk ?loc ?attrs (Pmod_apply (m1, m2)) - let constraint_ ?loc ?attrs m mty = mk ?loc ?attrs (Pmod_constraint (m, mty)) - let unpack ?loc ?attrs e = mk ?loc ?attrs (Pmod_unpack e) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pmod_extension a) -end - -module Sig = struct - let mk ?(loc = !default_loc) d = {psig_desc = d; psig_loc = loc} - - let value ?loc a = mk ?loc (Psig_value a) - let type_ ?loc rec_flag a = mk ?loc (Psig_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Psig_typext a) - let exception_ ?loc a = mk ?loc (Psig_exception a) - let module_ ?loc a = mk ?loc (Psig_module a) - let rec_module ?loc a = mk ?loc (Psig_recmodule a) - let modtype ?loc a = mk ?loc (Psig_modtype a) - let open_ ?loc a = mk ?loc (Psig_open a) - let include_ ?loc a = mk ?loc (Psig_include a) - - let class_type ?loc a = mk ?loc (Psig_class_type a) - let extension ?loc ?(attrs = []) a = mk ?loc (Psig_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Psig_attribute a) - let text txt = - let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "") in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Str = struct - let mk ?(loc = !default_loc) d = {pstr_desc = d; pstr_loc = loc} - - let eval ?loc ?(attrs = []) a = mk ?loc (Pstr_eval (a, attrs)) - let value ?loc a b = mk ?loc (Pstr_value (a, b)) - let primitive ?loc a = mk ?loc (Pstr_primitive a) - let type_ ?loc rec_flag a = mk ?loc (Pstr_type (rec_flag, a)) - let type_extension ?loc a = mk ?loc (Pstr_typext a) - let exception_ ?loc a = mk ?loc (Pstr_exception a) - let module_ ?loc a = mk ?loc (Pstr_module a) - let rec_module ?loc a = mk ?loc (Pstr_recmodule a) - let modtype ?loc a = mk ?loc (Pstr_modtype a) - let open_ ?loc a = mk ?loc (Pstr_open a) - let class_type ?loc a = mk ?loc (Pstr_class_type a) - let include_ ?loc a = mk ?loc (Pstr_include a) - let extension ?loc ?(attrs = []) a = mk ?loc (Pstr_extension (a, attrs)) - let attribute ?loc a = mk ?loc (Pstr_attribute a) - let text txt = - let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "") in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt -end - -module Cl = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcl_desc = d; - pcl_loc = loc; - pcl_attributes = attrs; - } - let attr d a = {d with pcl_attributes = d.pcl_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constr (a, b)) - let structure ?loc ?attrs a = mk ?loc ?attrs (Pcl_structure a) - let fun_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pcl_fun (a, b, c, d)) - let apply ?loc ?attrs a b = mk ?loc ?attrs (Pcl_apply (a, b)) - let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_let (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcl_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcl_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcl_open (a, b, c)) -end - -module Cty = struct - let mk ?(loc = !default_loc) ?(attrs = []) d = - { - pcty_desc = d; - pcty_loc = loc; - pcty_attributes = attrs; - } - let attr d a = {d with pcty_attributes = d.pcty_attributes @ [a]} - - let constr ?loc ?attrs a b = mk ?loc ?attrs (Pcty_constr (a, b)) - let signature ?loc ?attrs a = mk ?loc ?attrs (Pcty_signature a) - let arrow ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_arrow (a, b, c)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcty_extension a) - let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcty_open (a, b, c)) -end - -module Ctf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pctf_desc = d; - pctf_loc = loc; - pctf_attributes = add_docs_attrs docs attrs; - } - - let inherit_ ?loc ?attrs a = mk ?loc ?attrs (Pctf_inherit a) - let val_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_val (a, b, c, d)) - let method_ ?loc ?attrs a b c d = mk ?loc ?attrs (Pctf_method (a, b, c, d)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pctf_constraint (a, b)) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pctf_extension a) - let attribute ?loc a = mk ?loc (Pctf_attribute a) - let text txt = - let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "")in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let attr d a = {d with pctf_attributes = d.pctf_attributes @ [a]} - -end - -module Cf = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) d = - { - pcf_desc = d; - pcf_loc = loc; - pcf_attributes = add_docs_attrs docs attrs; - } - - - let val_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_val (a, b, c)) - let method_ ?loc ?attrs a b c = mk ?loc ?attrs (Pcf_method (a, b, c)) - let constraint_ ?loc ?attrs a b = mk ?loc ?attrs (Pcf_constraint (a, b)) - let initializer_ ?loc ?attrs a = mk ?loc ?attrs (Pcf_initializer a) - let extension ?loc ?attrs a = mk ?loc ?attrs (Pcf_extension a) - let attribute ?loc a = mk ?loc (Pcf_attribute a) - let text txt = - let f_txt = Ext_list.filter txt (fun ds -> docstring_body ds <> "")in - List.map - (fun ds -> attribute ~loc:(docstring_loc ds) (text_attr ds)) - f_txt - - let virtual_ ct = Cfk_virtual ct - let concrete o e = Cfk_concrete (o, e) - - let attr d a = {d with pcf_attributes = d.pcf_attributes @ [a]} - -end - -module Val = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(prim = []) name typ = - { - pval_name = name; - pval_type = typ; - pval_attributes = add_docs_attrs docs attrs; - pval_loc = loc; - pval_prim = prim; - } -end - -module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name typ = - { - pmd_name = name; - pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmd_loc = loc; - } -end - -module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) ?typ name = - { - pmtd_name = name; - pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmtd_loc = loc; - } -end - -module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) name expr = - { - pmb_name = name; - pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pmb_loc = loc; - } -end - -module Opn = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = - { - popen_lid = lid; - popen_override = override; - popen_loc = loc; - popen_attributes = add_docs_attrs docs attrs; - } -end - -module Incl = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) mexpr = - { - pincl_mod = mexpr; - pincl_loc = loc; - pincl_attributes = add_docs_attrs docs attrs; - } - -end - -module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(text = []) pat expr = - { - pvb_pat = pat; - pvb_expr = expr; - pvb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pvb_loc = loc; - } -end - -module Ci = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(virt = Concrete) ?(params = []) name expr = - { - pci_virt = virt; - pci_params = params; - pci_name = name; - pci_expr = expr; - pci_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - pci_loc = loc; - } -end - -module Type = struct - let mk ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(text = []) - ?(params = []) - ?(cstrs = []) - ?(kind = Ptype_abstract) - ?(priv = Public) - ?manifest - name = - { - ptype_name = name; - ptype_params = params; - ptype_cstrs = cstrs; - ptype_kind = kind; - ptype_private = priv; - ptype_manifest = manifest; - ptype_attributes = - add_text_attrs text (add_docs_attrs docs attrs); - ptype_loc = loc; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(args = Pcstr_tuple []) ?res name = - { - pcd_name = name; - pcd_args = args; - pcd_res = res; - pcd_loc = loc; - pcd_attributes = add_info_attrs info attrs; - } - - let field ?(loc = !default_loc) ?(attrs = []) ?(info = empty_info) - ?(mut = Immutable) name typ = - { - pld_name = name; - pld_mutable = mut; - pld_type = typ; - pld_loc = loc; - pld_attributes = add_info_attrs info attrs; - } - -end - -(** Type extensions *) -module Te = struct - let mk ?(attrs = []) ?(docs = empty_docs) - ?(params = []) ?(priv = Public) path constructors = - { - ptyext_path = path; - ptyext_params = params; - ptyext_constructors = constructors; - ptyext_private = priv; - ptyext_attributes = add_docs_attrs docs attrs; - } - - let constructor ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name kind = - { - pext_name = name; - pext_kind = kind; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let decl ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(info = empty_info) ?(args = Pcstr_tuple []) ?res name = - { - pext_name = name; - pext_kind = Pext_decl(args, res); - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - - let rebind ?(loc = !default_loc) ?(attrs = []) - ?(docs = empty_docs) ?(info = empty_info) name lid = - { - pext_name = name; - pext_kind = Pext_rebind lid; - pext_loc = loc; - pext_attributes = add_docs_attrs docs (add_info_attrs info attrs); - } - -end - -module Csig = struct - let mk self fields = - { - pcsig_self = self; - pcsig_fields = fields; - } -end - -module Cstr = struct - let mk self fields = - { - pcstr_self = self; - pcstr_fields = fields; - } -end diff --git a/jscomp/ml/ast_helper.mli b/jscomp/ml/ast_helper.mli deleted file mode 100644 index 67f6249..0000000 --- a/jscomp/ml/ast_helper.mli +++ /dev/null @@ -1,438 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments *) - -open Asttypes -open Docstrings -open Parsetree - -type lid = Longident.t loc -type str = string loc -type loc = Location.t -type attrs = attribute list - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val char : char -> constant - val string : ?quotation_delimiter:string -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str -> module_expr -> expression - -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance) list -> ?priv:private_flag -> - lid -> extension_constructor list -> type_extension - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?args:constructor_arguments -> ?res:core_type -> str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - str -> module_type option -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> extension_constructor -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> extension_constructor -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_description -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_type -> module_declaration - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - pattern -> expression -> value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> ?params:(core_type * variance) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end diff --git a/jscomp/ml/ast_invariants.ml b/jscomp/ml/ast_invariants.ml deleted file mode 100644 index 31ee17e..0000000 --- a/jscomp/ml/ast_invariants.ml +++ /dev/null @@ -1,166 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2015 Jane Street Group LLC *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Parsetree -open Ast_iterator - -let err = Syntaxerr.ill_formed_ast - -let empty_record loc = err loc "Records cannot be empty." -let empty_variant loc = err loc "Variant types cannot be empty." -let invalid_tuple loc = err loc "Tuples must have at least 2 components." -let no_args loc = err loc "Function application with no argument." -let empty_let loc = err loc "Let with no bindings." -let empty_type loc = err loc "Type declarations cannot be empty." -let complex_id loc = err loc "Functor application not allowed here." - -let simple_longident id = - let rec is_simple = function - | Longident.Lident _ -> true - | Longident.Ldot (id, _) -> is_simple id - | Longident.Lapply _ -> false - in - if not (is_simple id.txt) then complex_id id.loc - -let iterator = - let super = Ast_iterator.default_iterator in - let type_declaration self td = - super.type_declaration self td; - let loc = td.ptype_loc in - match td.ptype_kind with - | Ptype_record [] -> empty_record loc - | Ptype_variant [] -> empty_variant loc - | _ -> () - in - let typ self ty = - super.typ self ty; - let loc = ty.ptyp_loc in - match ty.ptyp_desc with - | Ptyp_tuple ([] | [_]) -> invalid_tuple loc - | Ptyp_class (id, _) -> simple_longident id - | Ptyp_package (_, cstrs) -> - List.iter (fun (id, _) -> simple_longident id) cstrs - | _ -> () - in - let pat self pat = - begin match pat.ppat_desc with - | Ppat_construct (_, Some ({ppat_desc = Ppat_tuple _} as p)) - when Builtin_attributes.explicit_arity pat.ppat_attributes -> - super.pat self p (* allow unary tuple, see GPR#523. *) - | _ -> - super.pat self pat - end; - let loc = pat.ppat_loc in - match pat.ppat_desc with - | Ppat_tuple ([] | [_]) -> invalid_tuple loc - | Ppat_record ([], _) -> empty_record loc - | Ppat_construct (id, _) -> simple_longident id - | Ppat_record (fields, _) -> - List.iter (fun (id, _) -> simple_longident id) fields - | _ -> () - in - let expr self exp = - begin match exp.pexp_desc with - | Pexp_construct (_, Some ({pexp_desc = Pexp_tuple _} as e)) - when Builtin_attributes.explicit_arity exp.pexp_attributes -> - super.expr self e (* allow unary tuple, see GPR#523. *) - | _ -> - super.expr self exp - end; - let loc = exp.pexp_loc in - match exp.pexp_desc with - | Pexp_tuple ([] | [_]) -> invalid_tuple loc - | Pexp_record ([], _) -> empty_record loc - | Pexp_apply (_, []) -> no_args loc - | Pexp_let (_, [], _) -> empty_let loc - | Pexp_ident id - | Pexp_construct (id, _) - | Pexp_field (_, id) - | Pexp_setfield (_, id, _) - | Pexp_new id - | Pexp_open (_, id, _) -> simple_longident id - | Pexp_record (fields, _) -> - List.iter (fun (id, _) -> simple_longident id) fields - | _ -> () - in - let extension_constructor self ec = - super.extension_constructor self ec; - match ec.pext_kind with - | Pext_rebind id -> simple_longident id - | _ -> () - in - let class_expr self ce = - super.class_expr self ce; - let loc = ce.pcl_loc in - match ce.pcl_desc with - | Pcl_apply (_, []) -> no_args loc - | Pcl_constr (id, _) -> simple_longident id - | _ -> () - in - let module_type self mty = - super.module_type self mty; - match mty.pmty_desc with - | Pmty_alias id -> simple_longident id - | _ -> () - in - let open_description self opn = - super.open_description self opn; - simple_longident opn.popen_lid - in - let with_constraint self wc = - super.with_constraint self wc; - match wc with - | Pwith_type (id, _) - | Pwith_module (id, _) -> simple_longident id - | _ -> () - in - let module_expr self me = - super.module_expr self me; - match me.pmod_desc with - | Pmod_ident id -> simple_longident id - | _ -> () - in - let structure_item self st = - super.structure_item self st; - let loc = st.pstr_loc in - match st.pstr_desc with - | Pstr_type (_, []) -> empty_type loc - | Pstr_value (_, []) -> empty_let loc - | _ -> () - in - let signature_item self sg = - super.signature_item self sg; - let loc = sg.psig_loc in - match sg.psig_desc with - | Psig_type (_, []) -> empty_type loc - | _ -> () - in - { super with - type_declaration - ; typ - ; pat - ; expr - ; extension_constructor - ; class_expr - ; module_expr - ; module_type - ; open_description - ; with_constraint - ; structure_item - ; signature_item - } - -let structure st = iterator.structure iterator st -let signature sg = iterator.signature iterator sg diff --git a/jscomp/ml/ast_invariants.mli b/jscomp/ml/ast_invariants.mli deleted file mode 100644 index 51d3f9d..0000000 --- a/jscomp/ml/ast_invariants.mli +++ /dev/null @@ -1,18 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2015 Jane Street Group LLC *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Check AST invariants *) - -val structure : Parsetree.structure -> unit -val signature : Parsetree.signature -> unit diff --git a/jscomp/ml/ast_iterator.ml b/jscomp/ml/ast_iterator.ml deleted file mode 100755 index f5fa930..0000000 --- a/jscomp/ml/ast_iterator.ml +++ /dev/null @@ -1,600 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Nicolas Ojeda Bar, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(* A generic Parsetree mapping class *) - -(* -[@@@warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - - -open Parsetree -open Location - -type iterator = { - attribute: iterator -> attribute -> unit; - attributes: iterator -> attribute list -> unit; - case: iterator -> case -> unit; - cases: iterator -> case list -> unit; - class_expr: iterator -> class_expr -> unit; - class_field: iterator -> class_field -> unit; - class_signature: iterator -> class_signature -> unit; - class_structure: iterator -> class_structure -> unit; - class_type: iterator -> class_type -> unit; - class_type_declaration: iterator -> class_type_declaration -> unit; - class_type_field: iterator -> class_type_field -> unit; - constructor_declaration: iterator -> constructor_declaration -> unit; - expr: iterator -> expression -> unit; - extension: iterator -> extension -> unit; - extension_constructor: iterator -> extension_constructor -> unit; - include_declaration: iterator -> include_declaration -> unit; - include_description: iterator -> include_description -> unit; - label_declaration: iterator -> label_declaration -> unit; - location: iterator -> Location.t -> unit; - module_binding: iterator -> module_binding -> unit; - module_declaration: iterator -> module_declaration -> unit; - module_expr: iterator -> module_expr -> unit; - module_type: iterator -> module_type -> unit; - module_type_declaration: iterator -> module_type_declaration -> unit; - open_description: iterator -> open_description -> unit; - pat: iterator -> pattern -> unit; - payload: iterator -> payload -> unit; - signature: iterator -> signature -> unit; - signature_item: iterator -> signature_item -> unit; - structure: iterator -> structure -> unit; - structure_item: iterator -> structure_item -> unit; - typ: iterator -> core_type -> unit; - type_declaration: iterator -> type_declaration -> unit; - type_extension: iterator -> type_extension -> unit; - type_kind: iterator -> type_kind -> unit; - value_binding: iterator -> value_binding -> unit; - value_description: iterator -> value_description -> unit; - with_constraint: iterator -> with_constraint -> unit; -} -(** A [iterator] record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the iterator to be applied to children in the syntax - tree. *) - -let iter_fst f (x, _) = f x -let iter_snd f (_, y) = f y -let iter_tuple f1 f2 (x, y) = f1 x; f2 y -let iter_tuple3 f1 f2 f3 (x, y, z) = f1 x; f2 y; f3 z -let iter_opt f = function None -> () | Some x -> f x - -let iter_loc sub {loc; txt = _} = sub.location sub loc - -module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (_, attrs, _, tl) -> - sub.attributes sub attrs; List.iter (sub.typ sub) tl - | Rinherit t -> sub.typ sub t - - let object_field sub = function - | Otag (_, attrs, t) -> - sub.attributes sub attrs; sub.typ sub t - | Oinherit t -> sub.typ sub t - - let iter sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Ptyp_any - | Ptyp_var _ -> () - | Ptyp_arrow (_lab, t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl - | Ptyp_constr (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_object (ol, _o) -> - List.iter (object_field sub) ol - | Ptyp_class (lid, tl) -> - iter_loc sub lid; List.iter (sub.typ sub) tl - | Ptyp_alias (t, _) -> sub.typ sub t - | Ptyp_variant (rl, _b, _ll) -> - List.iter (row_field sub) rl - | Ptyp_poly (_, t) -> sub.typ sub t - | Ptyp_package (lid, l) -> - iter_loc sub lid; - List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l - | Ptyp_extension x -> sub.extension sub x - - let iter_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private = _; - ptype_manifest; - ptype_attributes; - ptype_loc} = - iter_loc sub ptype_name; - List.iter (iter_fst (sub.typ sub)) ptype_params; - List.iter - (iter_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs; - sub.type_kind sub ptype_kind; - iter_opt (sub.typ sub) ptype_manifest; - sub.location sub ptype_loc; - sub.attributes sub ptype_attributes - - let iter_type_kind sub = function - | Ptype_abstract -> () - | Ptype_variant l -> - List.iter (sub.constructor_declaration sub) l - | Ptype_record l -> List.iter (sub.label_declaration sub) l - | Ptype_open -> () - - let iter_constructor_arguments sub = function - | Pcstr_tuple l -> List.iter (sub.typ sub) l - | Pcstr_record l -> - List.iter (sub.label_declaration sub) l - - let iter_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private = _; - ptyext_attributes} = - iter_loc sub ptyext_path; - List.iter (sub.extension_constructor sub) ptyext_constructors; - List.iter (iter_fst (sub.typ sub)) ptyext_params; - sub.attributes sub ptyext_attributes - - let iter_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - iter_constructor_arguments sub ctl; iter_opt (sub.typ sub) cto - | Pext_rebind li -> - iter_loc sub li - - let iter_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - iter_loc sub pext_name; - iter_extension_constructor_kind sub pext_kind; - sub.location sub pext_loc; - sub.attributes sub pext_attributes - -end - -module CT = struct - (* Type expressions for the class language *) - - let iter sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcty_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys - | Pcty_signature x -> sub.class_signature sub x - | Pcty_arrow (_lab, t, ct) -> - sub.typ sub t; sub.class_type sub ct - | Pcty_extension x -> sub.extension sub x - | Pcty_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_type sub e - - let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pctf_inherit ct -> sub.class_type sub ct - | Pctf_val (_s, _m, _v, t) -> sub.typ sub t - | Pctf_method (_s, _p, _v, t) -> sub.typ sub t - | Pctf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Pctf_attribute x -> sub.attribute sub x - | Pctf_extension x -> sub.extension sub x - - let iter_signature sub {pcsig_self; pcsig_fields} = - sub.typ sub pcsig_self; - List.iter (sub.class_type_field sub) pcsig_fields -end - -module MT = struct - (* Type expressions for the module language *) - - let iter sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pmty_ident s -> iter_loc sub s - | Pmty_alias s -> iter_loc sub s - | Pmty_signature sg -> sub.signature sub sg - | Pmty_functor (s, mt1, mt2) -> - iter_loc sub s; - iter_opt (sub.module_type sub) mt1; - sub.module_type sub mt2 - | Pmty_with (mt, l) -> - sub.module_type sub mt; - List.iter (sub.with_constraint sub) l - | Pmty_typeof me -> sub.module_expr sub me - | Pmty_extension x -> sub.extension sub x - - let iter_with_constraint sub = function - | Pwith_type (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d - | Pwith_module (lid, lid2) -> - iter_loc sub lid; iter_loc sub lid2 - | Pwith_typesubst (lid, d) -> - iter_loc sub lid; sub.type_declaration sub d - | Pwith_modsubst (s, lid) -> - iter_loc sub s; iter_loc sub lid - - let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = - sub.location sub loc; - match desc with - | Psig_value vd -> sub.value_description sub vd - | Psig_type (_rf, l) -> List.iter (sub.type_declaration sub) l - | Psig_typext te -> sub.type_extension sub te - | Psig_exception ed -> sub.extension_constructor sub ed - | Psig_module x -> sub.module_declaration sub x - | Psig_recmodule l -> - List.iter (sub.module_declaration sub) l - | Psig_modtype x -> sub.module_type_declaration sub x - | Psig_open x -> sub.open_description sub x - | Psig_include x -> sub.include_description sub x - | Psig_class () -> () - | Psig_class_type l -> - List.iter (sub.class_type_declaration sub) l - | Psig_extension (x, attrs) -> - sub.extension sub x; sub.attributes sub attrs - | Psig_attribute x -> sub.attribute sub x -end - - -module M = struct - (* Value expressions for the module language *) - - let iter sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pmod_ident x -> iter_loc sub x - | Pmod_structure str -> sub.structure sub str - | Pmod_functor (arg, arg_ty, body) -> - iter_loc sub arg; - iter_opt (sub.module_type sub) arg_ty; - sub.module_expr sub body - | Pmod_apply (m1, m2) -> - sub.module_expr sub m1; sub.module_expr sub m2 - | Pmod_constraint (m, mty) -> - sub.module_expr sub m; sub.module_type sub mty - | Pmod_unpack e -> sub.expr sub e - | Pmod_extension x -> sub.extension sub x - - let iter_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - sub.location sub loc; - match desc with - | Pstr_eval (x, attrs) -> - sub.expr sub x; sub.attributes sub attrs - | Pstr_value (_r, vbs) -> List.iter (sub.value_binding sub) vbs - | Pstr_primitive vd -> sub.value_description sub vd - | Pstr_type (_rf, l) -> List.iter (sub.type_declaration sub) l - | Pstr_typext te -> sub.type_extension sub te - | Pstr_exception ed -> sub.extension_constructor sub ed - | Pstr_module x -> sub.module_binding sub x - | Pstr_recmodule l -> List.iter (sub.module_binding sub) l - | Pstr_modtype x -> sub.module_type_declaration sub x - | Pstr_open x -> sub.open_description sub x - | Pstr_class () -> () - | Pstr_class_type l -> - List.iter (sub.class_type_declaration sub) l - | Pstr_include x -> sub.include_declaration sub x - | Pstr_extension (x, attrs) -> - sub.extension sub x; sub.attributes sub attrs - | Pstr_attribute x -> sub.attribute sub x -end - -module E = struct - (* Value expressions for the core language *) - - let iter sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pexp_ident x -> iter_loc sub x - | Pexp_constant _ -> () - | Pexp_let (_r, vbs, e) -> - List.iter (sub.value_binding sub) vbs; - sub.expr sub e - | Pexp_fun (_lab, def, p, e) -> - iter_opt (sub.expr sub) def; - sub.pat sub p; - sub.expr sub e - | Pexp_function pel -> sub.cases sub pel - | Pexp_apply (e, l) -> - sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l - | Pexp_match (e, pel) -> - sub.expr sub e; sub.cases sub pel - | Pexp_try (e, pel) -> sub.expr sub e; sub.cases sub pel - | Pexp_tuple el -> List.iter (sub.expr sub) el - | Pexp_construct (lid, arg) -> - iter_loc sub lid; iter_opt (sub.expr sub) arg - | Pexp_variant (_lab, eo) -> - iter_opt (sub.expr sub) eo - | Pexp_record (l, eo) -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; - iter_opt (sub.expr sub) eo - | Pexp_field (e, lid) -> - sub.expr sub e; iter_loc sub lid - | Pexp_setfield (e1, lid, e2) -> - sub.expr sub e1; iter_loc sub lid; - sub.expr sub e2 - | Pexp_array el -> List.iter (sub.expr sub) el - | Pexp_ifthenelse (e1, e2, e3) -> - sub.expr sub e1; sub.expr sub e2; - iter_opt (sub.expr sub) e3 - | Pexp_sequence (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 - | Pexp_while (e1, e2) -> - sub.expr sub e1; sub.expr sub e2 - | Pexp_for (p, e1, e2, _d, e3) -> - sub.pat sub p; sub.expr sub e1; sub.expr sub e2; - sub.expr sub e3 - | Pexp_coerce (e, t1, t2) -> - sub.expr sub e; iter_opt (sub.typ sub) t1; - sub.typ sub t2 - | Pexp_constraint (e, t) -> - sub.expr sub e; sub.typ sub t - | Pexp_send (e, _s) -> sub.expr sub e - | Pexp_new lid -> iter_loc sub lid - | Pexp_setinstvar (s, e) -> - iter_loc sub s; sub.expr sub e - | Pexp_override sel -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) sel - | Pexp_letmodule (s, me, e) -> - iter_loc sub s; sub.module_expr sub me; - sub.expr sub e - | Pexp_letexception (cd, e) -> - sub.extension_constructor sub cd; - sub.expr sub e - | Pexp_assert e -> sub.expr sub e - | Pexp_lazy e -> sub.expr sub e - | Pexp_poly (e, t) -> - sub.expr sub e; iter_opt (sub.typ sub) t - | Pexp_object cls -> sub.class_structure sub cls - | Pexp_newtype (_s, e) -> sub.expr sub e - | Pexp_pack me -> sub.module_expr sub me - | Pexp_open (_ovf, lid, e) -> - iter_loc sub lid; sub.expr sub e - | Pexp_extension x -> sub.extension sub x - | Pexp_unreachable -> () -end - -module P = struct - (* Patterns *) - - let iter sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Ppat_any -> () - | Ppat_var s -> iter_loc sub s - | Ppat_alias (p, s) -> sub.pat sub p; iter_loc sub s - | Ppat_constant _ -> () - | Ppat_interval _ -> () - | Ppat_tuple pl -> List.iter (sub.pat sub) pl - | Ppat_construct (l, p) -> - iter_loc sub l; iter_opt (sub.pat sub) p - | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p - | Ppat_record (lpl, _cf) -> - List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl - | Ppat_array pl -> List.iter (sub.pat sub) pl - | Ppat_or (p1, p2) -> sub.pat sub p1; sub.pat sub p2 - | Ppat_constraint (p, t) -> - sub.pat sub p; sub.typ sub t - | Ppat_type s -> iter_loc sub s - | Ppat_lazy p -> sub.pat sub p - | Ppat_unpack s -> iter_loc sub s - | Ppat_exception p -> sub.pat sub p - | Ppat_extension x -> sub.extension sub x - | Ppat_open (lid, p) -> - iter_loc sub lid; sub.pat sub p - -end - -module CE = struct - (* Value expressions for the class language *) - - let iter sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcl_constr (lid, tys) -> - iter_loc sub lid; List.iter (sub.typ sub) tys - | Pcl_structure s -> - sub.class_structure sub s - | Pcl_fun (_lab, e, p, ce) -> - iter_opt (sub.expr sub) e; - sub.pat sub p; - sub.class_expr sub ce - | Pcl_apply (ce, l) -> - sub.class_expr sub ce; - List.iter (iter_snd (sub.expr sub)) l - | Pcl_let (_r, vbs, ce) -> - List.iter (sub.value_binding sub) vbs; - sub.class_expr sub ce - | Pcl_constraint (ce, ct) -> - sub.class_expr sub ce; sub.class_type sub ct - | Pcl_extension x -> sub.extension sub x - | Pcl_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_expr sub e - - let iter_kind sub = function - | Cfk_concrete (_o, e) -> sub.expr sub e - | Cfk_virtual t -> sub.typ sub t - - let iter_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - sub.location sub loc; - sub.attributes sub attrs; - match desc with - | Pcf_inherit () -> () - | Pcf_val (s, _m, k) -> iter_loc sub s; iter_kind sub k - | Pcf_method (s, _p, k) -> - iter_loc sub s; iter_kind sub k - | Pcf_constraint (t1, t2) -> - sub.typ sub t1; sub.typ sub t2 - | Pcf_initializer e -> sub.expr sub e - | Pcf_attribute x -> sub.attribute sub x - | Pcf_extension x -> sub.extension sub x - - let iter_structure sub {pcstr_self; pcstr_fields} = - sub.pat sub pcstr_self; - List.iter (sub.class_field sub) pcstr_fields - - let class_infos sub f {pci_virt = _; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - List.iter (iter_fst (sub.typ sub)) pl; - iter_loc sub pci_name; - f pci_expr; - sub.location sub pci_loc; - sub.attributes sub pci_attributes -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_iterator = - { - structure = (fun this l -> List.iter (this.structure_item this) l); - structure_item = M.iter_structure_item; - module_expr = M.iter; - signature = (fun this l -> List.iter (this.signature_item this) l); - signature_item = MT.iter_signature_item; - module_type = MT.iter; - with_constraint = MT.iter_with_constraint; - class_expr = CE.iter; - class_field = CE.iter_field; - class_structure = CE.iter_structure; - class_type = CT.iter; - class_type_field = CT.iter_field; - class_signature = CT.iter_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.iter_type_declaration; - type_kind = T.iter_type_kind; - typ = T.iter; - type_extension = T.iter_type_extension; - extension_constructor = T.iter_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim = _; pval_loc; - pval_attributes} -> - iter_loc this pval_name; - this.typ this pval_type; - this.attributes this pval_attributes; - this.location this pval_loc - ); - - pat = P.iter; - expr = E.iter; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - iter_loc this pmd_name; - this.module_type this pmd_type; - this.attributes this pmd_attributes; - this.location this pmd_loc - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - iter_loc this pmtd_name; - iter_opt (this.module_type this) pmtd_type; - this.attributes this pmtd_attributes; - this.location this pmtd_loc - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - iter_loc this pmb_name; this.module_expr this pmb_expr; - this.attributes this pmb_attributes; - this.location this pmb_loc - ); - - - open_description = - (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_lid; - this.location this popen_loc; - this.attributes this popen_attributes - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_type this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - this.module_expr this pincl_mod; - this.location this pincl_loc; - this.attributes this pincl_attributes - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - this.pat this pvb_pat; - this.expr this pvb_expr; - this.location this pvb_loc; - this.attributes this pvb_attributes - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - iter_loc this pcd_name; - T.iter_constructor_arguments this pcd_args; - iter_opt (this.typ this) pcd_res; - this.location this pcd_loc; - this.attributes this pcd_attributes - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable = _; pld_attributes}-> - iter_loc this pld_name; - this.typ this pld_type; - this.location this pld_loc; - this.attributes this pld_attributes - ); - - cases = (fun this l -> List.iter (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - this.pat this pc_lhs; - iter_opt (this.expr this) pc_guard; - this.expr this pc_rhs - ); - - location = (fun _this _l -> ()); - - extension = (fun this (s, e) -> iter_loc this s; this.payload this e); - attribute = (fun this (s, e) -> iter_loc this s; this.payload this e); - attributes = (fun this l -> List.iter (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> this.structure this x - | PSig x -> this.signature this x - | PTyp x -> this.typ this x - | PPat (x, g) -> this.pat this x; iter_opt (this.expr this) g - ); - } diff --git a/jscomp/ml/ast_mapper.ml b/jscomp/ml/ast_mapper.ml deleted file mode 100644 index 5aa10df..0000000 --- a/jscomp/ml/ast_mapper.ml +++ /dev/null @@ -1,914 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(* A generic Parsetree mapping class *) - -(* -[@@@warning "+9"] - (* Ensure that record patterns don't miss any field. *) -*) - - -open Parsetree -open Ast_helper -open Location - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; -} - -let map_fst f (x, y) = (f x, y) -let map_snd f (x, y) = (x, f y) -let map_tuple f1 f2 (x, y) = (f1 x, f2 y) -let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let map_opt f = function None -> None | Some x -> Some (f x) - -let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - -module T = struct - (* Type expressions for the core language *) - - let row_field sub = function - | Rtag (l, attrs, b, tl) -> - Rtag (map_loc sub l, sub.attributes sub attrs, - b, List.map (sub.typ sub) tl) - | Rinherit t -> Rinherit (sub.typ sub t) - - let object_field sub = function - | Otag (l, attrs, t) -> - Otag (map_loc sub l, sub.attributes sub attrs, sub.typ sub t) - | Oinherit t -> Oinherit (sub.typ sub t) - - let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = - let open Typ in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ptyp_any -> any ~loc ~attrs () - | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) - | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (object_field sub) l) o - | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s - | Ptyp_variant (rl, b, ll) -> - variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs - (List.map (map_loc sub) sl) (sub.typ sub t) - | Ptyp_package (lid, l) -> - package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) - | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_type_declaration sub - {ptype_name; ptype_params; ptype_cstrs; - ptype_kind; - ptype_private; - ptype_manifest; - ptype_attributes; - ptype_loc} = - Type.mk (map_loc sub ptype_name) - ~params:(List.map (map_fst (sub.typ sub)) ptype_params) - ~priv:ptype_private - ~cstrs:(List.map - (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) - ptype_cstrs) - ~kind:(sub.type_kind sub ptype_kind) - ?manifest:(map_opt (sub.typ sub) ptype_manifest) - ~loc:(sub.location sub ptype_loc) - ~attrs:(sub.attributes sub ptype_attributes) - - let map_type_kind sub = function - | Ptype_abstract -> Ptype_abstract - | Ptype_variant l -> - Ptype_variant (List.map (sub.constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) - | Ptype_open -> Ptype_open - - let map_constructor_arguments sub = function - | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Pcstr_record l -> - Pcstr_record (List.map (sub.label_declaration sub) l) - - let map_type_extension sub - {ptyext_path; ptyext_params; - ptyext_constructors; - ptyext_private; - ptyext_attributes} = - Te.mk - (map_loc sub ptyext_path) - (List.map (sub.extension_constructor sub) ptyext_constructors) - ~params:(List.map (map_fst (sub.typ sub)) ptyext_params) - ~priv:ptyext_private - ~attrs:(sub.attributes sub ptyext_attributes) - - let map_extension_constructor_kind sub = function - Pext_decl(ctl, cto) -> - Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) - | Pext_rebind li -> - Pext_rebind (map_loc sub li) - - let map_extension_constructor sub - {pext_name; - pext_kind; - pext_loc; - pext_attributes} = - Te.constructor - (map_loc sub pext_name) - (map_extension_constructor_kind sub pext_kind) - ~loc:(sub.location sub pext_loc) - ~attrs:(sub.attributes sub pext_attributes) - -end - -module CT = struct - (* Type expressions for the class language *) - - let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = - let open Cty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) - | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) - | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (ovf, lid, ct) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) - - let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} - = - let open Ctf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) - | Pctf_val (s, m, v, t) -> - val_ ~loc ~attrs (map_loc sub s) m v (sub.typ sub t) - | Pctf_method (s, p, v, t) -> - method_ ~loc ~attrs (map_loc sub s) p v (sub.typ sub t) - | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pctf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_signature sub {pcsig_self; pcsig_fields} = - Csig.mk - (sub.typ sub pcsig_self) - (List.map (sub.class_type_field sub) pcsig_fields) -end - -module MT = struct - (* Type expressions for the module language *) - - let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = - let open Mty in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) - | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) - | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) - | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) - (Misc.may_map (sub.module_type sub) mt1) - (sub.module_type sub mt2) - | Pmty_with (mt, l) -> - with_ ~loc ~attrs (sub.module_type sub mt) - (List.map (sub.with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) - | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_with_constraint sub = function - | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, sub.type_declaration sub d) - | Pwith_module (lid, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst (lid, d) -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) - | Pwith_modsubst (s, lid) -> - Pwith_modsubst (map_loc sub s, map_loc sub lid) - - let map_signature_item sub {psig_desc = desc; psig_loc = loc} = - let open Sig in - let loc = sub.location sub loc in - match desc with - | Psig_value vd -> value ~loc (sub.value_description sub vd) - | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Psig_typext te -> type_extension ~loc (sub.type_extension sub te) - | Psig_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Psig_module x -> module_ ~loc (sub.module_declaration sub x) - | Psig_recmodule l -> - rec_module ~loc (List.map (sub.module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Psig_open x -> open_ ~loc (sub.open_description sub x) - | Psig_include x -> include_ ~loc (sub.include_description sub x) - | Psig_class _ -> assert false - | Psig_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Psig_attribute x -> attribute ~loc (sub.attribute sub x) -end - - -module M = struct - (* Value expressions for the module language *) - - let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = - let open Mod in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) - | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) - (Misc.may_map (sub.module_type sub) arg_ty) - (sub.module_expr sub body) - | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) - | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (sub.module_expr sub m) - (sub.module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) - | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = - let open Str in - let loc = sub.location sub loc in - match desc with - | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) - | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub.type_declaration sub) l) - | Pstr_typext te -> type_extension ~loc (sub.type_extension sub te) - | Pstr_exception ed -> exception_ ~loc (sub.extension_constructor sub ed) - | Pstr_module x -> module_ ~loc (sub.module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) - | Pstr_open x -> open_ ~loc (sub.open_description sub x) - | Pstr_class () -> {pstr_loc = loc ; pstr_desc = Pstr_class ()} - | Pstr_class_type l -> - class_type ~loc (List.map (sub.class_type_declaration sub) l) - | Pstr_include x -> include_ ~loc (sub.include_declaration sub x) - | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) - | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) -end - -module E = struct - (* Value expressions for the core language *) - - let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = - let open Exp in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) - | Pexp_constant x -> constant ~loc ~attrs x - | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.expr sub e) - | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) - (sub.expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) - | Pexp_apply (e, l) -> - apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) - | Pexp_match (e, pel) -> - match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) - | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) - (map_opt (sub.expr sub) eo) - | Pexp_field (e, lid) -> - field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) - | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) - (sub.expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - (map_opt (sub.expr sub) e3) - | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_while (e1, e2) -> - while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) - | Pexp_for (p, e1, e2, d, e3) -> - for_ ~loc ~attrs (sub.pat sub p) (sub.expr sub e1) (sub.expr sub e2) d - (sub.expr sub e3) - | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) - (sub.typ sub t2) - | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) - | Pexp_send (e, s) -> - send ~loc ~attrs (sub.expr sub e) (map_loc sub s) - | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) - | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_override sel -> - override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) - (sub.expr sub e) - | Pexp_letexception (cd, e) -> - letexception ~loc ~attrs - (sub.extension_constructor sub cd) - (sub.expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) - | Pexp_poly (e, t) -> - poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) - | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pexp_unreachable -> unreachable ~loc ~attrs () -end - -module P = struct - (* Patterns *) - - let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = - let open Pat in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Ppat_any -> any ~loc ~attrs () - | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) - | Ppat_constant c -> constant ~loc ~attrs c - | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) - | Ppat_record (lpl, cf) -> - record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) - | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) - | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) - | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) - | Ppat_open (lid,p) -> open_ ~loc ~attrs (map_loc sub lid) (sub.pat sub p) - | Ppat_exception p -> exception_ ~loc ~attrs (sub.pat sub p) - | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) -end - -module CE = struct - (* Value expressions for the class language *) - - let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = - let open Cl in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) - | Pcl_structure s -> - structure ~loc ~attrs (sub.class_structure sub s) - | Pcl_fun (lab, e, p, ce) -> - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) e) - (sub.pat sub p) - (sub.class_expr sub ce) - | Pcl_apply (ce, l) -> - apply ~loc ~attrs (sub.class_expr sub ce) - (List.map (map_snd (sub.expr sub)) l) - | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) - (sub.class_expr sub ce) - | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) - | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (ovf, lid, ce) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) - - let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) - | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) - - let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = - let open Cf in - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - match desc with - | Pcf_inherit () -> - {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} - | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) - | Pcf_method (s, p, k) -> - method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) - | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) - | Pcf_attribute x -> attribute ~loc (sub.attribute sub x) - | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) - - let map_structure sub {pcstr_self; pcstr_fields} = - { - pcstr_self = sub.pat sub pcstr_self; - pcstr_fields = List.map (sub.class_field sub) pcstr_fields; - } - - let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; - pci_loc; pci_attributes} = - Ci.mk - ~virt:pci_virt - ~params:(List.map (map_fst (sub.typ sub)) pl) - (map_loc sub pci_name) - (f pci_expr) - ~loc:(sub.location sub pci_loc) - ~attrs:(sub.attributes sub pci_attributes) -end - -(* Now, a generic AST mapper, to be extended to cover all kinds and - cases of the OCaml grammar. The default behavior of the mapper is - the identity. *) - -let default_mapper = - { - structure = (fun this l -> List.map (this.structure_item this) l); - structure_item = M.map_structure_item; - module_expr = M.map; - signature = (fun this l -> List.map (this.signature_item this) l); - signature_item = MT.map_signature_item; - module_type = MT.map; - with_constraint = MT.map_with_constraint; - class_expr = CE.map; - class_field = CE.map_field; - class_structure = CE.map_structure; - class_type = CT.map; - class_type_field = CT.map_field; - class_signature = CT.map_signature; - class_type_declaration = - (fun this -> CE.class_infos this (this.class_type this)); - type_declaration = T.map_type_declaration; - type_kind = T.map_type_kind; - typ = T.map; - type_extension = T.map_type_extension; - extension_constructor = T.map_extension_constructor; - value_description = - (fun this {pval_name; pval_type; pval_prim; pval_loc; - pval_attributes} -> - Val.mk - (map_loc this pval_name) - (this.typ this pval_type) - ~attrs:(this.attributes this pval_attributes) - ~loc:(this.location this pval_loc) - ~prim:pval_prim - ); - - pat = P.map; - expr = E.map; - - module_declaration = - (fun this {pmd_name; pmd_type; pmd_attributes; pmd_loc} -> - Md.mk - (map_loc this pmd_name) - (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) - ~loc:(this.location this pmd_loc) - ); - - module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> - Mtd.mk - (map_loc this pmtd_name) - ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) - ~loc:(this.location this pmtd_loc) - ); - - module_binding = - (fun this {pmb_name; pmb_expr; pmb_attributes; pmb_loc} -> - Mb.mk (map_loc this pmb_name) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) - ~loc:(this.location this pmb_loc) - ); - - - open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) - ~override:popen_override - ~loc:(this.location this popen_loc) - ~attrs:(this.attributes this popen_attributes) - ); - - - include_description = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_type this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - include_declaration = - (fun this {pincl_mod; pincl_attributes; pincl_loc} -> - Incl.mk (this.module_expr this pincl_mod) - ~loc:(this.location this pincl_loc) - ~attrs:(this.attributes this pincl_attributes) - ); - - - value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk - (this.pat this pvb_pat) - (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes) - ); - - - constructor_declaration = - (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> - Type.constructor - (map_loc this pcd_name) - ~args:(T.map_constructor_arguments this pcd_args) - ?res:(map_opt (this.typ this) pcd_res) - ~loc:(this.location this pcd_loc) - ~attrs:(this.attributes this pcd_attributes) - ); - - label_declaration = - (fun this {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} -> - Type.field - (map_loc this pld_name) - (this.typ this pld_type) - ~mut:pld_mutable - ~loc:(this.location this pld_loc) - ~attrs:(this.attributes this pld_attributes) - ); - - cases = (fun this l -> List.map (this.case this) l); - case = - (fun this {pc_lhs; pc_guard; pc_rhs} -> - { - pc_lhs = this.pat this pc_lhs; - pc_guard = map_opt (this.expr this) pc_guard; - pc_rhs = this.expr this pc_rhs; - } - ); - - - - location = (fun _this l -> l); - - extension = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attribute = (fun this (s, e) -> (map_loc this s, this.payload this e)); - attributes = (fun this l -> List.map (this.attribute this) l); - payload = - (fun this -> function - | PStr x -> PStr (this.structure this x) - | PSig x -> PSig (this.signature this x) - | PTyp x -> PTyp (this.typ this x) - | PPat (x, g) -> PPat (this.pat this x, map_opt (this.expr this) g) - ); - } - -let rec extension_of_error {loc; msg; if_highlight; sub} = - { loc; txt = "ocaml.error" }, - PStr ([Str.eval (Exp.constant (Pconst_string (msg, None))); - Str.eval (Exp.constant (Pconst_string (if_highlight, None)))] @ - (List.map (fun ext -> Str.extension (extension_of_error ext)) sub)) - -let attribute_of_warning loc s = - { loc; txt = "ocaml.ppwarning" }, - PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, None)))]) - -module StringMap = Map.Make(struct - type t = string - let compare = compare -end) - -let cookies = ref StringMap.empty - -let get_cookie k = - try Some (StringMap.find k !cookies) - with Not_found -> None - -let set_cookie k v = - cookies := StringMap.add k v !cookies - -let tool_name_ref = ref "_none_" - -let tool_name () = !tool_name_ref - - -module PpxContext = struct - open Longident - open Asttypes - open Ast_helper - - let lid name = { txt = Lident name; loc = Location.none } - - let make_string x = Exp.constant (Pconst_string (x, None)) - - let make_bool x = - if x - then Exp.construct (lid "true") None - else Exp.construct (lid "false") None - - let rec make_list f lst = - match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> - Exp.construct (lid "[]") None - - let make_pair f1 f2 (x1, x2) = - Exp.tuple [f1 x1; f2 x2] - - - let get_cookies () = - lid "cookies", - make_list (make_pair make_string (fun x -> x)) - (StringMap.bindings !cookies) - - let mk fields = - { txt = "ocaml.ppx.context"; loc = Location.none }, - Parsetree.PStr [Str.eval (Exp.record fields None)] - - let make ~tool_name () = - let fields = - [ - lid "tool_name", make_string tool_name; - lid "include_dirs", make_list make_string !Clflags.include_dirs; - lid "load_path", make_list make_string !Config.load_path; - lid "open_modules", make_list make_string !Clflags.open_modules; - lid "debug", make_bool !Clflags.debug; - get_cookies () - ] - in - mk fields - - let get_fields = function - | PStr [{pstr_desc = Pstr_eval - ({ pexp_desc = Pexp_record (fields, None) }, [])}] -> - fields - | _ -> - raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | { pexp_desc = Pexp_constant (Pconst_string (str, None)) } -> str - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] string syntax" name - and get_bool pexp = - match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, - None)} -> - true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, - None)} -> - false - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] bool syntax" name - and get_list elem = function - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]}) } -> - elem exp :: get_list elem rest - | {pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] list syntax" name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> - (f1 e1, f2 e2) - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context \ - { %s }] pair syntax" name - in - match name with - | "tool_name" -> - tool_name_ref := get_string payload - | "include_dirs" -> - Clflags.include_dirs := get_list get_string payload - | "load_path" -> - Config.load_path := get_list get_string payload - | "open_modules" -> - Clflags.open_modules := get_list get_string payload - | "debug" -> - Clflags.debug := get_bool payload - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> StringMap.add k v s) StringMap.empty - l - | _ -> - () - in - List.iter (function ({txt=Lident name}, x) -> field name x | _ -> ()) fields - - let update_cookies fields = - let fields = - Ext_list.filter fields - (function ({txt=Lident "cookies"}, _) -> false | _ -> true) - in - fields @ [get_cookies ()] -end - -let ppx_context = PpxContext.make - -let extension_of_exn exn = - match error_of_exn exn with - | Some (`Ok error) -> extension_of_error error - | Some `Already_displayed -> { loc = Location.none; txt = "ocaml.error" }, PStr [] - | None -> raise exn - - -let apply_lazy ~source ~target mapper = - let implem ast = - let fields, ast = - match ast with - | {pstr_desc = Pstr_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.structure mapper ast - with exn -> - [{pstr_desc = Pstr_extension (extension_of_exn exn, []); - pstr_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Str.attribute (PpxContext.mk fields) :: ast - in - let iface ast = - let fields, ast = - match ast with - | {psig_desc = Psig_attribute ({txt = "ocaml.ppx.context"}, x)} :: l -> - PpxContext.get_fields x, l - | _ -> [], ast - in - PpxContext.restore fields; - let ast = - try - let mapper = mapper () in - mapper.signature mapper ast - with exn -> - [{psig_desc = Psig_extension (extension_of_exn exn, []); - psig_loc = Location.none}] - in - let fields = PpxContext.update_cookies fields in - Sig.attribute (PpxContext.mk fields) :: ast - in - - let ic = open_in_bin source in - let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) - in - - let rewrite transform = - Location.set_input_name @@ input_value ic; - let ast = input_value ic in - close_in ic; - let ast = transform ast in - let oc = open_out_bin target in - output_string oc magic; - output_value oc !Location.input_name; - output_value oc ast; - close_out oc - and fail () = - close_in ic; - failwith "Ast_mapper: OCaml version mismatch or malformed input"; - in - - if magic = Config.ast_impl_magic_number then - rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then - rewrite (iface : signature -> signature) - else fail () - -let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute({Location.txt = "ocaml.ppx.context"}, a)} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute({Location.txt = "ocaml.ppx.context"}, a)} - :: items -> - if restore then - PpxContext.restore (PpxContext.get_fields a); - items - | items -> items - -let add_ppx_context_str ~tool_name ast = - Ast_helper.Str.attribute (ppx_context ~tool_name ()) :: ast - -let add_ppx_context_sig ~tool_name ast = - Ast_helper.Sig.attribute (ppx_context ~tool_name ()) :: ast - - -let apply ~source ~target mapper = - apply_lazy ~source ~target (fun () -> mapper) - -let run_main mapper = - try - let a = Sys.argv in - let n = Array.length a in - if n > 2 then - let mapper () = - try mapper (Array.to_list (Array.sub a 1 (n - 3))) - with exn -> - (* PR#6463 *) - let f _ _ = raise exn in - {default_mapper with structure = f; signature = f} - in - apply_lazy ~source:a.(n - 2) ~target:a.(n - 1) mapper - else begin - Printf.eprintf "Usage: %s [extra_args] \n%!" - Sys.executable_name; - exit 2 - end - with exn -> - prerr_endline (Printexc.to_string exn); - exit 2 - -let register_function = ref (fun _name f -> run_main f) -let register name f = !register_function name f diff --git a/jscomp/ml/ast_uncurried.ml b/jscomp/ml/ast_uncurried.ml deleted file mode 100644 index 432bb6c..0000000 --- a/jscomp/ml/ast_uncurried.ml +++ /dev/null @@ -1,125 +0,0 @@ -(* Uncurried AST *) - - -let encode_arity_string arity = "Has_arity" ^ string_of_int arity -let decode_arity_string arity_s = int_of_string ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) - -let arityType ~loc arity = - Ast_helper.Typ.variant ~loc - [ Rtag ({ txt = encode_arity_string arity; loc }, [], true, []) ] - Closed None - -let arityFromType (typ : Parsetree.core_type) = - match typ.ptyp_desc with - | Ptyp_variant ([Rtag ({txt}, _, _, _)], _, _) -> decode_arity_string txt - | _ -> assert false - -let uncurriedType ~loc ~arity tArg = - let tArity = arityType ~loc arity in - Ast_helper.Typ.constr ~loc - { txt = Lident "function$"; loc } - [ tArg; tArity ] - -let arity_to_attributes arity = - [ - ( Location.mknoloc "res.arity", - Parsetree.PStr - [ - Ast_helper.Str.eval - (Ast_helper.Exp.constant - (Pconst_integer (string_of_int arity, None))); - ] ); - ] - -let rec attributes_to_arity (attrs : Parsetree.attributes) = - match attrs with - | ( { txt = "res.arity" }, - PStr - [ - { - pstr_desc = - Pstr_eval - ({ pexp_desc = Pexp_constant (Pconst_integer (arity, _)) }, _); - }; - ] ) - :: _ -> - int_of_string arity - | _ :: rest -> attributes_to_arity rest - | _ -> assert false - -let uncurriedFun ~loc ~arity funExpr = - Ast_helper.Exp.construct ~loc - ~attrs:(arity_to_attributes arity) - (Location.mknoloc (Longident.Lident "Function$")) - (Some funExpr) - -let exprIsUncurriedFun (expr : Parsetree.expression) = - match expr.pexp_desc with - | Pexp_construct ({ txt = Lident "Function$" }, Some _) -> true - | _ -> false - -let exprExtractUncurriedFun (expr : Parsetree.expression) = - match expr.pexp_desc with - | Pexp_construct ({ txt = Lident "Function$" }, Some e) -> e - | _ -> assert false - -let coreTypeIsUncurriedFun (typ : Parsetree.core_type) = - match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow _}; _]) -> - true - | _ -> false - -let coreTypeExtractUncurriedFun (typ : Parsetree.core_type) = - match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident "function$"}, [tArg; tArity]) -> - (arityFromType tArity, tArg) - | _ -> assert false - -let typeIsUncurriedFun = Ast_uncurried_utils.typeIsUncurriedFun - -let typeExtractUncurriedFun (typ : Types.type_expr) = - match typ.desc with - | Tconstr (Pident {name = "function$"}, [tArg; _], _) -> - tArg - | _ -> assert false - -(* Typed AST *) - -let arity_to_type arity = - let arity_s = encode_arity_string arity in - Ctype.newty - (Tvariant - { - row_fields = [ (arity_s, Rpresent None) ]; - row_more = Ctype.newty Tnil; - row_bound = (); - row_closed = true; - row_fixed = false; - row_name = None; - }) - -let type_to_arity (tArity : Types.type_expr) = - match (Ctype.repr tArity).desc with - | Tvariant { row_fields = [ (label, _) ] } -> decode_arity_string label - | _ -> assert false - -let make_uncurried_type ~env ~arity t = - let typ_arity = arity_to_type arity in - let lid : Longident.t = Lident "function$" in - let path = Env.lookup_type lid env in - Ctype.newconstr path [ t; typ_arity ] - -let uncurried_type_get_arity ~env typ = - match (Ctype.expand_head env typ).desc with - | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) -> - type_to_arity tArity - | _ -> assert false - -let uncurried_type_get_arity_opt ~env typ = - match (Ctype.expand_head env typ).desc with - | Tconstr (Pident { name = "function$" }, [ _t; tArity ], _) -> - Some (type_to_arity tArity) - | _ -> None - - - diff --git a/jscomp/ml/ast_uncurried_utils.ml b/jscomp/ml/ast_uncurried_utils.ml deleted file mode 100644 index ad18b01..0000000 --- a/jscomp/ml/ast_uncurried_utils.ml +++ /dev/null @@ -1,5 +0,0 @@ -let typeIsUncurriedFun (typ : Types.type_expr) = - match typ.desc with - | Tconstr (Pident {name = "function$"}, [{desc = Tarrow _}; _], _) -> - true - | _ -> false \ No newline at end of file diff --git a/jscomp/ml/ast_untagged_variants.ml b/jscomp/ml/ast_untagged_variants.ml deleted file mode 100644 index 2622913..0000000 --- a/jscomp/ml/ast_untagged_variants.ml +++ /dev/null @@ -1,492 +0,0 @@ -module Instance = struct - type t = - | Array - | Blob - | Date - | File - | Promise - | RegExp - let to_string = function - Array -> "Array" - | Blob -> "Blob" - | Date -> "Date" - | File -> "File" - | Promise -> "Promise" - | RegExp -> "RegExp" -end - -type untaggedError = - | OnlyOneUnknown of string - | AtMostOneObject - | AtMostOneInstance of Instance.t - | AtMostOneFunction - | AtMostOneString - | AtMostOneNumber - | AtMostOneBigint - | AtMostOneBoolean - | DuplicateLiteral of string - | ConstructorMoreThanOneArg of string -type error = - | InvalidVariantAsAnnotation - | Duplicated_bs_as - | InvalidVariantTagAnnotation - | InvalidUntaggedVariantDefinition of untaggedError -exception Error of Location.t * error - -let report_error ppf = - let open Format in - function - | InvalidVariantAsAnnotation -> - fprintf ppf - "A variant case annotation @as(...) must be a string or integer, \ - boolean, null, undefined" - | Duplicated_bs_as -> fprintf ppf "duplicate @as " - | InvalidVariantTagAnnotation -> - fprintf ppf "A variant tag annotation @tag(...) must be a string" - | InvalidUntaggedVariantDefinition untaggedVariant -> - fprintf ppf "This untagged variant definition is invalid: %s" - (match untaggedVariant with - | OnlyOneUnknown name -> "Case " ^ name ^ " has a payload that is not of one of the recognized shapes (object, array, etc). Then it must be the only case with payloads." - | AtMostOneObject -> "At most one case can be an object type." - | AtMostOneInstance Array -> "At most one case can be an array or tuple type." - | AtMostOneInstance i -> "At most one case can be a " ^ (Instance.to_string i) ^ " type." - | AtMostOneFunction -> "At most one case can be a function type." - | AtMostOneString -> "At most one case can be a string type." - | AtMostOneBoolean -> "At most one case can be a boolean type." - | AtMostOneNumber -> - "At most one case can be a number type (int or float)." - | AtMostOneBigint -> - "At most one case can be a bigint type." - | DuplicateLiteral s -> "Duplicate literal " ^ s ^ "." - | ConstructorMoreThanOneArg (name) -> "Constructor " ^ name ^ " has more than one argument.") - -(* Type of the runtime representation of an untagged block (case with payoad) *) -type block_type = - | IntType - | StringType - | FloatType - | BigintType - | BooleanType - | InstanceType of Instance.t - | FunctionType - | ObjectType - | UnknownType - -(* - Type of the runtime representation of a tag. - Can be a literal (case with no payload), or a block (case with payload). - In the case of block it can be tagged or untagged. -*) -type tag_type = - | String of string - | Int of int - | Float of string - | BigInt of string - | Bool of bool - | Null - | Undefined (* literal or tagged block *) - | Untagged of block_type (* untagged block *) -type tag = {name: string; tag_type: tag_type option} -type block = {tag: tag; tag_name: string option; block_type: block_type option} -type switch_names = {consts: tag array; blocks: block array} - -let untagged = "unboxed" - -let has_untagged (attrs : Parsetree.attributes) = - Ext_list.exists attrs (function {txt}, _ -> txt = untagged) - -let process_untagged (attrs : Parsetree.attributes) = - let st = ref false in - Ext_list.iter attrs (fun ({txt}, _) -> - match txt with - | "unboxed" -> st := true - | _ -> ()); - !st - -let extract_concrete_typedecl: (Env.t -> - Types.type_expr -> - Path.t * Path.t * Types.type_declaration) ref = ref (Obj.magic ()) - -let expand_head: (Env.t -> Types.type_expr -> Types.type_expr) ref = ref (Obj.magic ()) - -let process_tag_type (attrs : Parsetree.attributes) = - let st : tag_type option ref = ref None in - Ext_list.iter attrs (fun ({txt; loc}, payload) -> - match txt with - | "bs.as" | "as" -> - if !st = None then ( - (match Ast_payload.is_single_string payload with - | None -> () - | Some (s, _dec) -> st := Some (String s)); - (match Ast_payload.is_single_int payload with - | None -> () - | Some i -> st := Some (Int i)); - (match Ast_payload.is_single_float payload with - | None -> () - | Some f -> st := Some (Float f)); - (match Ast_payload.is_single_bigint payload with - | None -> () - | Some i -> st := Some (BigInt i)); - (match Ast_payload.is_single_bool payload with - | None -> () - | Some b -> st := Some (Bool b)); - (match Ast_payload.is_single_ident payload with - | None -> () - | Some (Lident "null") -> st := Some Null - | Some (Lident "undefined") -> st := Some Undefined - | Some _ -> raise (Error (loc, InvalidVariantAsAnnotation))); - if !st = None then raise (Error (loc, InvalidVariantAsAnnotation))) - else raise (Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st - -let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) - | _ -> None) - -let reportConstructorMoreThanOneArg ~loc ~name = - raise (Error (loc, InvalidUntaggedVariantDefinition (ConstructorMoreThanOneArg name))) - -let type_is_builtin_object (t : Types.type_expr) = - match t.desc with - | Tconstr (Path.Pident ident, [_], _) when Ident.name ident = "dict" -> true - | Tconstr (path, _, _) -> - let name = Path.name path in - name = "Js.Dict.t" || name = "Js_dict.t" - | _ -> false - -let type_to_instanceof_backed_obj (t : Types.type_expr) = - match t.desc with - | Tconstr (path, _, _) when Path.same path Predef.path_promise -> - Some Instance.Promise - | Tconstr (path, _, _) when Path.same path Predef.path_array -> - Some Array - | Tconstr (path, _, _) -> ( - match Path.name path with - | "Js_date.t" -> Some(Date) - | "Js_re.t" -> Some(RegExp) - | "Js_file.t" -> Some(File) - | "Js_blob.t" -> Some(Blob) - | _ -> None) - | _ -> None - -let get_block_type_from_typ ~env (t: Types.type_expr) : block_type option = - let t = !expand_head env t in - match t with - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> - Some StringType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_int -> - Some IntType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_float -> - Some FloatType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bigint -> - Some BigintType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_bool -> - Some BooleanType - | ({desc = Tconstr _} as t) when Ast_uncurried_utils.typeIsUncurriedFun t -> - Some FunctionType - | {desc = Tarrow _} -> Some FunctionType - | {desc = Tconstr (path, _, _)} when Path.same path Predef.path_string -> - Some StringType - | ({desc = Tconstr _} as t) when type_is_builtin_object t -> - Some ObjectType - | ({desc = Tconstr _} as t) when type_to_instanceof_backed_obj t |> Option.is_some -> - (match type_to_instanceof_backed_obj t with - | None -> None - | Some instanceType -> Some (InstanceType instanceType)) - | {desc = Ttuple _} -> Some (InstanceType Array) - | _ -> None - -let get_block_type ~env (cstr : Types.constructor_declaration) : - block_type option = - match (process_untagged cstr.cd_attributes, cstr.cd_args) with - | false, _ -> None - | true, Cstr_tuple [t] when get_block_type_from_typ ~env t |> Option.is_some -> get_block_type_from_typ ~env t - | true, Cstr_tuple [ty] -> ( - let default = Some UnknownType in - match !extract_concrete_typedecl env ty with - | _, _, {type_kind = Type_record (_, Record_unboxed _)} -> default - | _, _, {type_kind = Type_record (_, _)} -> Some ObjectType - | _ -> default - | exception _ -> default) - | true, Cstr_tuple (_ :: _ :: _) -> - (* C(_, _) with at least 2 args is an object *) - Some ObjectType - | true, Cstr_record _ -> - (* inline record is an object *) - Some ObjectType - | true, _ -> None (* TODO: add restrictions here *) - -let process_tag_name (attrs : Parsetree.attributes) = - let st = ref None in - Ext_list.iter attrs (fun ({txt; loc}, payload) -> - match txt with - | "tag" -> - if !st = None then ( - (match Ast_payload.is_single_string payload with - | None -> () - | Some (s, _dec) -> st := Some s); - if !st = None then raise (Error (loc, InvalidVariantTagAnnotation))) - else raise (Error (loc, Duplicated_bs_as)) - | _ -> ()); - !st - -let get_tag_name (cstr : Types.constructor_declaration) = - process_tag_name cstr.cd_attributes - -let is_nullary_variant (x : Types.constructor_arguments) = - match x with - | Types.Cstr_tuple [] -> true - | _ -> false - -let checkInvariant ~isUntaggedDef ~(consts : (Location.t * tag) list) - ~(blocks : (Location.t * block) list) = - let module StringSet = Set.Make (String) in - let string_literals = ref StringSet.empty in - let nonstring_literals = ref StringSet.empty in - let instanceTypes = Hashtbl.create 1 in - let functionTypes = ref 0 in - let objectTypes = ref 0 in - let stringTypes = ref 0 in - let numberTypes = ref 0 in - let bigintTypes = ref 0 in - let booleanTypes = ref 0 in - let unknownTypes = ref 0 in - let addStringLiteral ~loc s = - if StringSet.mem s !string_literals then - raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - string_literals := StringSet.add s !string_literals - in - let addNonstringLiteral ~loc s = - if StringSet.mem s !nonstring_literals then - raise (Error (loc, InvalidUntaggedVariantDefinition (DuplicateLiteral s))); - nonstring_literals := StringSet.add s !nonstring_literals - in - let invariant loc name = - if !unknownTypes <> 0 && List.length blocks <> 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition (OnlyOneUnknown name))); - if !objectTypes > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneObject)); - Hashtbl.iter (fun i count -> - if count > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition (AtMostOneInstance i)))) - instanceTypes; - if !functionTypes > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneFunction)); - if !stringTypes > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneString)); - if !numberTypes > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneNumber)); - if !bigintTypes > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBigint)); - if !booleanTypes > 1 then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); - if !booleanTypes > 0 && (StringSet.mem "true" !nonstring_literals || StringSet.mem "false" !nonstring_literals) then - raise (Error (loc, InvalidUntaggedVariantDefinition AtMostOneBoolean)); - () - in - Ext_list.rev_iter consts (fun (loc, literal) -> - match literal.tag_type with - | Some (String s) -> addStringLiteral ~loc s - | Some (Int i) -> addNonstringLiteral ~loc (string_of_int i) - | Some (Float f) -> addNonstringLiteral ~loc f - | Some (BigInt i) -> addNonstringLiteral ~loc i - | Some Null -> addNonstringLiteral ~loc "null" - | Some Undefined -> addNonstringLiteral ~loc "undefined" - | Some (Bool b) -> addNonstringLiteral ~loc (if b then "true" else "false") - | Some (Untagged _) -> () - | None -> addStringLiteral ~loc literal.name); - if isUntaggedDef then - Ext_list.rev_iter blocks (fun (loc, block) -> - match block.block_type with - | Some block_type -> - (match block_type with - | UnknownType -> incr unknownTypes; - | ObjectType -> incr objectTypes; - | (InstanceType i) -> - let count = Hashtbl.find_opt instanceTypes i |> Option.value ~default:0 in - Hashtbl.replace instanceTypes i (count + 1); - | FunctionType -> incr functionTypes; - | (IntType | FloatType) -> incr numberTypes; - | BigintType -> incr bigintTypes; - | BooleanType -> incr booleanTypes; - | StringType -> incr stringTypes; - ); - invariant loc block.tag.name - | None -> () - ) - -let names_from_type_variant ?(isUntaggedDef = false) ~env - (cstrs : Types.constructor_declaration list) = - let get_cstr_name (cstr : Types.constructor_declaration) = - ( cstr.cd_loc, - { - name = Ident.name cstr.cd_id; - tag_type = process_tag_type cstr.cd_attributes; - } ) - in - let get_block (cstr : Types.constructor_declaration) : block = - let tag = snd (get_cstr_name cstr) in - {tag; tag_name = get_tag_name cstr; block_type = get_block_type ~env cstr} - in - let consts, blocks = - Ext_list.fold_left cstrs ([], []) (fun (consts, blocks) cstr -> - if is_nullary_variant cstr.cd_args then - (get_cstr_name cstr :: consts, blocks) - else (consts, (cstr.cd_loc, get_block cstr) :: blocks)) - in - checkInvariant ~isUntaggedDef ~consts ~blocks; - let blocks = blocks |> List.map snd in - let consts = consts |> List.map snd in - let consts = Ext_array.reverse_of_list consts in - let blocks = Ext_array.reverse_of_list blocks in - Some {consts; blocks} - -let check_well_formed ~env ~isUntaggedDef - (cstrs : Types.constructor_declaration list) = - ignore (names_from_type_variant ~env ~isUntaggedDef cstrs) - -let has_undefined_literal attrs = process_tag_type attrs = Some Undefined - -let block_is_object ~env attrs = get_block_type ~env attrs = Some ObjectType - -module DynamicChecks = struct - type op = EqEqEq | NotEqEq | Or | And - type 'a t = - | BinOp of op * 'a t * 'a t - | TagType of tag_type - | TypeOf of 'a t - | IsInstanceOf of Instance.t * 'a t - | Not of 'a t - | Expr of 'a - - let bin op x y = BinOp (op, x, y) - let tag_type t = TagType t - let typeof x = TypeOf x - let str s = String s |> tag_type - let is_instance i x = IsInstanceOf (i, x) - let not x = Not x - let nil = Null |> tag_type - let undefined = Undefined |> tag_type - let object_ = Untagged ObjectType |> tag_type - - let function_ = Untagged FunctionType |> tag_type - let string = Untagged StringType |> tag_type - let number = Untagged IntType |> tag_type - - let bigint = Untagged BigintType |> tag_type - - let boolean = Untagged BooleanType |> tag_type - - let ( == ) x y = bin EqEqEq x y - let ( != ) x y = bin NotEqEq x y - let ( ||| ) x y = bin Or x y - let ( &&& ) x y = bin And x y - - let rec is_a_literal_case ~(literal_cases : tag_type list) ~block_cases - (e : _ t) = - let literals_overlaps_with_string () = - Ext_list.exists literal_cases (function - | String _ -> true - | _ -> false) - in - let literals_overlaps_with_number () = - Ext_list.exists literal_cases (function - | Int _ | Float _ -> true - | _ -> false) - in - let literals_overlaps_with_bigint () = - Ext_list.exists literal_cases (function - | BigInt _ -> true - | _ -> false) - in - let literals_overlaps_with_boolean () = - Ext_list.exists literal_cases (function - | Bool _ -> true - | _ -> false) - in - let literals_overlaps_with_object () = - Ext_list.exists literal_cases (function - | Null -> true - | _ -> false) - in - let is_literal_case (t : tag_type) : _ t = e == tag_type t in - let is_not_block_case (c : block_type) : _ t = - match c with - | StringType - when literals_overlaps_with_string () = false (* No overlap *) -> - typeof e != string - | IntType when literals_overlaps_with_number () = false -> - typeof e != number - | FloatType when literals_overlaps_with_number () = false -> - typeof e != number - | BigintType when literals_overlaps_with_bigint () = false -> - typeof e != bigint - | BooleanType when literals_overlaps_with_boolean () = false -> - typeof e != boolean - | InstanceType i -> not (is_instance i e) - | FunctionType -> typeof e != function_ - | ObjectType when literals_overlaps_with_object () = false -> - typeof e != object_ - | ObjectType (* overlap *) -> e == nil ||| (typeof e != object_) - | StringType (* overlap *) - | IntType (* overlap *) - | FloatType (* overlap *) - | BigintType (* overlap *) - | BooleanType (* overlap *) - | UnknownType -> ( - (* We don't know the type of unknown, so we need to express: - this is not one of the literals *) - match literal_cases with - | [] -> - (* this should not happen *) - assert false - | l1 :: others -> - let is_literal_1 = is_literal_case l1 in - Ext_list.fold_right others is_literal_1 (fun literal_n acc -> - is_literal_case literal_n ||| acc)) - in - match block_cases with - | [c] -> is_not_block_case c - | c1 :: (_ :: _ as rest) -> - is_not_block_case c1 - &&& is_a_literal_case ~literal_cases ~block_cases:rest e - | [] -> assert false - - let is_int_tag ?(has_null_undefined_other = (false, false, false)) (e : _ t) : - _ t = - let has_null, has_undefined, has_other = has_null_undefined_other in - if has_null && has_undefined = false && has_other = false then - (* null *) - bin EqEqEq e nil - else if has_null && has_undefined && has_other = false then - (* null + undefined *) - e == nil ||| e == undefined - else if has_null = false && has_undefined && has_other = false then - (* undefined *) - e == undefined - else if has_null then - (* (null + undefined + other) || (null + other) *) - e == nil ||| typeof e != object_ - else (* (undefiled + other) || other *) - typeof e != object_ - - let add_runtime_type_check ~tag_type ~(block_cases : block_type list) x y = - let instances = Ext_list.filter_map block_cases (function InstanceType i -> Some i | _ -> None) in - match tag_type with - | Untagged (IntType | StringType | FloatType | BigintType | BooleanType | FunctionType) -> - typeof y == x - | Untagged ObjectType -> - if instances <> [] then - let not_one_of_the_instances = - Ext_list.fold_right instances (typeof y == x) (fun i x -> x &&& not (is_instance i y)) in - not_one_of_the_instances - else - typeof y == x - | Untagged (InstanceType i) -> is_instance i y - | Untagged UnknownType -> - (* This should not happen because unknown must be the only non-literal case *) - assert false - | Bool _ | Float _ | Int _ | BigInt _ | String _ | Null | Undefined -> x -end diff --git a/jscomp/ml/asttypes.ml b/jscomp/ml/asttypes.ml deleted file mode 100644 index 5abbdaa..0000000 --- a/jscomp/ml/asttypes.ml +++ /dev/null @@ -1,73 +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. *) -(* *) -(**************************************************************************) - -(** Auxiliary AST types used by parsetree and typedtree. *) - -type constant = - Const_int of int - | Const_char of int - | Const_string of string * string option - | Const_float of string - | Const_int32 of int32 - | Const_int64 of int64 - | Const_bigint of bool * string - -type rec_flag = Nonrecursive | Recursive - -type direction_flag = Upto | Downto - -(* Order matters, used in polymorphic comparison *) -type private_flag = Private | Public - -type mutable_flag = Immutable | Mutable - -type virtual_flag = Virtual | Concrete - -type override_flag = Override | Fresh - -type closed_flag = Closed | Open - -type label = string - -type arg_label = - Nolabel - | Labelled of string (* label:T -> ... *) - | Optional of string (* ?label:T -> ... *) - -type 'a loc = 'a Location.loc = { - txt : 'a; - loc : Location.t; -} - - -type variance = - | Covariant - | Contravariant - | Invariant - - -let same_arg_label (x : arg_label) y = - match x with - | Nolabel -> y = Nolabel - | Labelled s -> - begin match y with - | Labelled s0 -> s = s0 - | _ -> false - end - | Optional s -> - begin match y with - | Optional s0 -> s = s0 - | _ -> false - end diff --git a/jscomp/ml/bigint_utils.ml b/jscomp/ml/bigint_utils.ml deleted file mode 100644 index e0f3fe9..0000000 --- a/jscomp/ml/bigint_utils.ml +++ /dev/null @@ -1,84 +0,0 @@ -let is_neg s = String.length s > 0 && s.[0] = '-' -let is_pos s = String.length s > 0 && s.[0] = '+' - -let to_string sign s = (if sign then "" else "-") ^ s - -let remove_leading_sign str : bool * string = - let len = String.length str in - if len = 0 then (false, str) - else - if is_neg str || is_pos str then (not (is_neg str), String.sub str 1 (len -1)) - else (true, str) - -(* - Removes leading zeros from the string only if the first non-zero character - encountered is a digit. Unlike int and float, bigint cannot be of_string, so - This function removes only leading 0s. Instead, values like 00x1 are not converted - and are intended to be syntax errors. - - 000n -> 0n - 001n -> 1n - 01_000_000n -> 1000000n - -00100n -> -100n - - The following values are syntax errors - - 00o1n -> 00o1n - 00x1_000_000n -> 00x1000000n -*) -let remove_leading_zeros str = - let aux str = - let len = String.length str in - if len = 0 then "" - else - let is_digit c = c >= '0' && c <= '9' in - let idx = ref 0 in - while !idx < len && str.[!idx] = '0' do - incr idx - done; - if !idx >= len then "0" (* If the string contains only '0's, return '0'. *) - else if (is_digit str.[!idx]) then String.sub str !idx (len - !idx) (* Remove leading zeros and return the rest of the string. *) - else str - in - (* Replace the delimiters '_' inside number *) - let str = String.concat "" (String.split_on_char '_' str) in - (* Check if negative *) - let starts_with_minus = str <> "" && str.[0] = '-' in - let str = if is_neg str || is_pos str then String.sub str 1 (String.length str - 1) else str in - let processed_str = aux str in - if starts_with_minus then "-" ^ processed_str else processed_str - -let parse_bigint s = - let sign, i = remove_leading_sign s in - (sign, remove_leading_zeros i) - -let is_valid s = - let len = String.length s in - if len = 0 then false - else - let is_digit c = (c >= '0' && c <= '9') || c = '_' in - let first_char = s.[0] in - if first_char <> '-' && first_char <> '+' && not (is_digit first_char) then false - else - let rec check idx = - if idx >= len then true - else - let c = s.[idx] in - if is_digit c then check (idx + 1) - else false - in - check 1 - -let compare (p0, s0) (p1, s1) = - match (p0, p1) with - | (false, true) -> -1 (* If only s1 is positive, s0 is smaller. *) - | (true, false) -> 1 (* If only s0 is positive, s0 is larger. *) - | _ -> - (* If both numbers are either negative or positive, compare their lengths. *) - let len0, len1 = (String.length s0, String.length s1) in - if len0 = len1 then - if p0 then String.compare s0 s1 else String.compare s1 s0 (* If lengths are equal, compare the strings directly. *) - else if len0 > len1 then - if p0 then 1 else -1 (* A longer s0 means it's larger unless it's negative. *) - else (* len0 < len1 *) - if p0 then -1 else 1 (* A longer s1 means s0 is smaller unless s1 is negative. *) diff --git a/jscomp/ml/bigint_utils.mli b/jscomp/ml/bigint_utils.mli deleted file mode 100644 index 34f9dfb..0000000 --- a/jscomp/ml/bigint_utils.mli +++ /dev/null @@ -1,8 +0,0 @@ -val is_neg: string -> bool -val is_pos: string -> bool -val to_string: bool -> string -> string -val remove_leading_sign : string -> bool * string -val remove_leading_zeros : string -> string -val parse_bigint: string -> bool * string -val is_valid : string -> bool -val compare : bool * string -> bool * string -> int diff --git a/jscomp/ml/btype.ml b/jscomp/ml/btype.ml deleted file mode 100644 index de95c2d..0000000 --- a/jscomp/ml/btype.ml +++ /dev/null @@ -1,745 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Jerome Vouillon, 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. *) -(* *) -(**************************************************************************) - -(* Basic operations on core types *) - -open Misc -open Asttypes -open Types - -(**** Sets, maps and hashtables of types ****) - -module TypeSet = Set.Make(TypeOps) -module TypeMap = Map.Make (TypeOps) -module TypeHash = Hashtbl.Make(TypeOps) - -(**** Forward declarations ****) - -let print_raw = - ref (fun _ -> assert false : Format.formatter -> type_expr -> unit) - -(**** Type level management ****) - -let generic_level = 100000000 - -(* Used to mark a type during a traversal. *) -let lowest_level = 0 -let pivot_level = 2 * lowest_level - 1 - (* pivot_level - lowest_level < lowest_level *) - -(**** Some type creators ****) - -let new_id = ref (-1) - -let newty2 level desc = - incr new_id; { desc; level; id = !new_id } -let newgenty desc = newty2 generic_level desc -let newgenvar ?name () = newgenty (Tvar name) -(* -let newmarkedvar level = - incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } -let newmarkedgenvar () = - incr new_id; - { desc = Tvar; level = pivot_level - generic_level; id = !new_id } -*) - -(**** Check some types ****) - -let is_Tvar = function {desc=Tvar _} -> true | _ -> false -let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false -let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false - -let dummy_method = "*dummy method*" -let default_mty = function - Some mty -> mty - | None -> Mty_signature [] - -(**** Definitions for backtracking ****) - -type change = - Ctype of type_expr * type_desc - | Ccompress of type_expr * type_desc * type_desc - | Clevel of type_expr * int - | Cname of - (Path.t * type_expr list) option ref * (Path.t * type_expr list) option - | Crow of row_field option ref * row_field option - | Ckind of field_kind option ref * field_kind option - | Ccommu of commutable ref * commutable - | Cuniv of type_expr option ref * type_expr option - | Ctypeset of TypeSet.t ref * TypeSet.t - -type changes = - Change of change * changes ref - | Unchanged - | Invalid - -let trail = Weak.create 1 - -let log_change ch = - match Weak.get trail 0 with None -> () - | Some r -> - let r' = ref Unchanged in - r := Change (ch, r'); - Weak.set trail 0 (Some r') - -(**** Representative of a type ****) - -let rec field_kind_repr = - function - Fvar {contents = Some kind} -> field_kind_repr kind - | kind -> kind - -let rec repr_link compress t d = - function - {desc = Tlink t' as d'} -> - repr_link true t d' t' - | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> - repr_link true t d' t' - | t' -> - if compress then begin - log_change (Ccompress (t, t.desc, d)); t.desc <- d - end; - t' - -let repr t = - match t.desc with - Tlink t' as d -> - repr_link false t d t' - | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent -> - repr_link false t d t' - | _ -> t - -let rec commu_repr = function - Clink r when !r <> Cunknown -> commu_repr !r - | c -> c - -let rec row_field_repr_aux tl = function - Reither(_, tl', _, {contents = Some fi}) -> - row_field_repr_aux (tl@tl') fi - | Reither(c, tl', m, r) -> - Reither(c, tl@tl', m, r) - | Rpresent (Some _) when tl <> [] -> - Rpresent (Some (List.hd tl)) - | fi -> fi - -let row_field_repr fi = row_field_repr_aux [] fi - -let rec rev_concat l ll = - match ll with - [] -> l - | l'::ll -> rev_concat (l'@l) ll - -let rec row_repr_aux ll row = - match (repr row.row_more).desc with - | Tvariant row' -> - let f = row.row_fields in - row_repr_aux (if f = [] then ll else f::ll) row' - | _ -> - if ll = [] then row else - {row with row_fields = rev_concat row.row_fields ll} - -let row_repr row = row_repr_aux [] row - -let rec row_field tag row = - let rec find = function - | (tag',f) :: fields -> - if tag = tag' then row_field_repr f else find fields - | [] -> - match repr row.row_more with - | {desc=Tvariant row'} -> row_field tag row' - | _ -> Rabsent - in find row.row_fields - -let rec row_more row = - match repr row.row_more with - | {desc=Tvariant row'} -> row_more row' - | ty -> ty - -let row_fixed row = - let row = row_repr row in - row.row_fixed || - match (repr row.row_more).desc with - Tvar _ | Tnil -> false - | Tunivar _ | Tconstr _ -> true - | _ -> assert false - -let static_row row = - let row = row_repr row in - row.row_closed && - List.for_all - (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) - row.row_fields - -let hash_variant s = - let accu = ref 0 in - for i = 0 to String.length s - 1 do - accu := 223 * !accu + Char.code s.[i] - done; - (* reduce to 31 bits *) - accu := !accu land (1 lsl 31 - 1); - (* make it signed for 64 bits architectures *) - if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu - -let proxy ty = - let ty0 = repr ty in - match ty0.desc with - | Tvariant row when not (static_row row) -> - row_more row - | Tobject (ty, _) -> - let rec proxy_obj ty = - match ty.desc with - Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty - | Tvar _ | Tunivar _ | Tconstr _ -> ty - | Tnil -> ty0 - | _ -> assert false - in proxy_obj ty - | _ -> ty0 - -(**** Utilities for fixed row private types ****) - -let row_of_type t = - match (repr t).desc with - Tobject(t,_) -> - let rec get_row t = - let t = repr t in - match t.desc with - Tfield(_,_,_,t) -> get_row t - | _ -> t - in get_row t - | Tvariant row -> - row_more row - | _ -> - t - -let has_constr_row t = - not (is_Tconstr t) && is_Tconstr (row_of_type t) - -let is_row_name s = - let l = String.length s in - if l < 4 then false else String.sub s (l-4) 4 = "#row" - -let is_constr_row ~allow_ident t = - match t.desc with - Tconstr (Path.Pident id, _, _) when allow_ident -> - is_row_name (Ident.name id) - | Tconstr (Path.Pdot (_, s, _), _, _) -> is_row_name s - | _ -> false - - - (**********************************) - (* Utilities for type traversal *) - (**********************************) - -let rec iter_row f row = - List.iter - (fun (_, fi) -> - match row_field_repr fi with - | Rpresent(Some ty) -> f ty - | Reither(_, tl, _, _) -> List.iter f tl - | _ -> ()) - row.row_fields; - match (repr row.row_more).desc with - Tvariant row -> iter_row f row - | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> - Misc.may (fun (_,l) -> List.iter f l) row.row_name - | _ -> assert false - -let iter_type_expr f ty = - match ty.desc with - Tvar _ -> () - | Tarrow (_, ty1, ty2, _) -> f ty1; f ty2 - | Ttuple l -> List.iter f l - | Tconstr (_, l, _) -> List.iter f l - | Tobject(ty, {contents = Some (_, p)}) - -> f ty; List.iter f p - | Tobject (ty, _) -> f ty - | Tvariant row -> iter_row f row; f (row_more row) - | Tfield (_, _, ty1, ty2) -> f ty1; f ty2 - | Tnil -> () - | Tlink ty -> f ty - | Tsubst ty -> f ty - | Tunivar _ -> () - | Tpoly (ty, tyl) -> f ty; List.iter f tyl - | Tpackage (_, _, l) -> List.iter f l - -let rec iter_abbrev f = function - Mnil -> () - | Mcons(_, _, ty, ty', rem) -> f ty; f ty'; iter_abbrev f rem - | Mlink rem -> iter_abbrev f !rem - -type type_iterators = - { it_signature: type_iterators -> signature -> unit; - it_signature_item: type_iterators -> signature_item -> unit; - it_value_description: type_iterators -> value_description -> unit; - it_type_declaration: type_iterators -> type_declaration -> unit; - it_extension_constructor: type_iterators -> extension_constructor -> unit; - it_module_declaration: type_iterators -> module_declaration -> unit; - it_modtype_declaration: type_iterators -> modtype_declaration -> unit; - it_class_declaration: type_iterators -> class_declaration -> unit; - it_class_type_declaration: type_iterators -> class_type_declaration -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_class_type: type_iterators -> class_type -> unit; - it_type_kind: type_iterators -> type_kind -> unit; - it_do_type_expr: type_iterators -> type_expr -> unit; - it_type_expr: type_iterators -> type_expr -> unit; - it_path: Path.t -> unit; } - -let iter_type_expr_cstr_args f = function - | Cstr_tuple tl -> List.iter f tl - | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls - -let map_type_expr_cstr_args f = function - | Cstr_tuple tl -> Cstr_tuple (List.map f tl) - | Cstr_record lbls -> - Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) - -let iter_type_expr_kind f = function - | Type_abstract -> () - | Type_variant cstrs -> - List.iter - (fun cd -> - iter_type_expr_cstr_args f cd.cd_args; - Misc.may f cd.cd_res - ) - cstrs - | Type_record(lbls, _) -> - List.iter (fun d -> f d.ld_type) lbls - | Type_open -> - () - - -let type_iterators = - let it_signature it = - List.iter (it.it_signature_item it) - and it_signature_item it = function - Sig_value (_, vd) -> it.it_value_description it vd - | Sig_type (_, td, _) -> it.it_type_declaration it td - | Sig_typext (_, td, _) -> it.it_extension_constructor it td - | Sig_module (_, md, _) -> it.it_module_declaration it md - | Sig_modtype (_, mtd) -> it.it_modtype_declaration it mtd - | Sig_class () -> assert false - | Sig_class_type (_, ctd, _) -> it.it_class_type_declaration it ctd - and it_value_description it vd = - it.it_type_expr it vd.val_type - and it_type_declaration it td = - List.iter (it.it_type_expr it) td.type_params; - may (it.it_type_expr it) td.type_manifest; - it.it_type_kind it td.type_kind - and it_extension_constructor it td = - it.it_path td.ext_type_path; - List.iter (it.it_type_expr it) td.ext_type_params; - iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; - may (it.it_type_expr it) td.ext_ret_type - and it_module_declaration it md = - it.it_module_type it md.md_type - and it_modtype_declaration it mtd = - may (it.it_module_type it) mtd.mtd_type - and it_class_declaration it cd = - List.iter (it.it_type_expr it) cd.cty_params; - it.it_class_type it cd.cty_type; - may (it.it_type_expr it) cd.cty_new; - it.it_path cd.cty_path - and it_class_type_declaration it ctd = - List.iter (it.it_type_expr it) ctd.clty_params; - it.it_class_type it ctd.clty_type; - it.it_path ctd.clty_path - and it_module_type it = function - Mty_ident p - | Mty_alias(_, p) -> it.it_path p - | Mty_signature sg -> it.it_signature it sg - | Mty_functor (_, mto, mt) -> - may (it.it_module_type it) mto; - it.it_module_type it mt - and it_class_type it = function - Cty_constr (p, tyl, cty) -> - it.it_path p; - List.iter (it.it_type_expr it) tyl; - it.it_class_type it cty - | Cty_signature cs -> - it.it_type_expr it cs.csig_self; - Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; - List.iter - (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl) - cs.csig_inher - | Cty_arrow (_, ty, cty) -> - it.it_type_expr it ty; - it.it_class_type it cty - and it_type_kind it kind = - iter_type_expr_kind (it.it_type_expr it) kind - and it_do_type_expr it ty = - iter_type_expr (it.it_type_expr it) ty; - match ty.desc with - Tconstr (p, _, _) - | Tobject (_, {contents=Some (p, _)}) - | Tpackage (p, _, _) -> - it.it_path p - | Tvariant row -> - may (fun (p,_) -> it.it_path p) (row_repr row).row_name - | _ -> () - and it_path _p = () - in - { it_path; it_type_expr = it_do_type_expr; it_do_type_expr; - it_type_kind; it_class_type; it_module_type; - it_signature; it_class_type_declaration; it_class_declaration; - it_modtype_declaration; it_module_declaration; it_extension_constructor; - it_type_declaration; it_value_description; it_signature_item; } - -let copy_row f fixed row keep more = - let fields = List.map - (fun (l, fi) -> l, - match row_field_repr fi with - | Rpresent(Some ty) -> Rpresent(Some(f ty)) - | Reither(c, tl, m, e) -> - let e = if keep then e else ref None in - let m = if row.row_fixed then fixed else m in - let tl = List.map f tl in - Reither(c, tl, m, e) - | _ -> fi) - row.row_fields in - let name = - match row.row_name with None -> None - | Some (path, tl) -> Some (path, List.map f tl) in - { row_fields = fields; row_more = more; - row_bound = (); row_fixed = row.row_fixed && fixed; - row_closed = row.row_closed; row_name = name; } - -let rec copy_kind = function - Fvar{contents = Some k} -> copy_kind k - | Fvar _ -> Fvar (ref None) - | Fpresent -> Fpresent - | Fabsent -> assert false - -let copy_commu c = - if commu_repr c = Cok then Cok else Clink (ref Cunknown) - -(* Since univars may be used as row variables, we need to do some - encoding during substitution *) -let rec norm_univar ty = - match ty.desc with - Tunivar _ | Tsubst _ -> ty - | Tlink ty -> norm_univar ty - | Ttuple (ty :: _) -> norm_univar ty - | _ -> assert false - -let rec copy_type_desc ?(keep_names=false) f = function - Tvar _ as ty -> if keep_names then ty else Tvar None - | Tarrow (p, ty1, ty2, c)-> Tarrow (p, f ty1, f ty2, copy_commu c) - | Ttuple l -> Ttuple (List.map f l) - | Tconstr (p, l, _) -> Tconstr (p, List.map f l, ref Mnil) - | Tobject(ty, {contents = Some (p, tl)}) - -> Tobject (f ty, ref (Some(p, List.map f tl))) - | Tobject (ty, _) -> Tobject (f ty, ref None) - | Tvariant _ -> assert false (* too ambiguous *) - | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *) - Tfield (p, field_kind_repr k, f ty1, f ty2) - | Tnil -> Tnil - | Tlink ty -> copy_type_desc f ty.desc - | Tsubst _ -> assert false - | Tunivar _ as ty -> ty (* always keep the name *) - | Tpoly (ty, tyl) -> - let tyl = List.map (fun x -> norm_univar (f x)) tyl in - Tpoly (f ty, tyl) - | Tpackage (p, n, l) -> Tpackage (p, n, List.map f l) - -(* Utilities for copying *) - -let saved_desc = ref [] - (* Saved association of generic nodes with their description. *) - -let save_desc ty desc = - saved_desc := (ty, desc)::!saved_desc - -let saved_kinds = ref [] (* duplicated kind variables *) -let new_kinds = ref [] (* new kind variables *) -let dup_kind r = - (match !r with None -> () | Some _ -> assert false); - if not (List.memq r !new_kinds) then begin - saved_kinds := r :: !saved_kinds; - let r' = ref None in - new_kinds := r' :: !new_kinds; - r := Some (Fvar r') - end - -(* Restored type descriptions. *) -let cleanup_types () = - List.iter (fun (ty, desc) -> ty.desc <- desc) !saved_desc; - List.iter (fun r -> r := None) !saved_kinds; - saved_desc := []; saved_kinds := []; new_kinds := [] - -(* Mark a type. *) -let rec mark_type ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - iter_type_expr mark_type ty - end - -let mark_type_node ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - end - -let mark_type_params ty = - iter_type_expr mark_type ty - -let type_iterators = - let it_type_expr it ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - mark_type_node ty; - it.it_do_type_expr it ty; - end - in - {type_iterators with it_type_expr} - - -(* Remove marks from a type. *) -let rec unmark_type ty = - let ty = repr ty in - if ty.level < lowest_level then begin - ty.level <- pivot_level - ty.level; - iter_type_expr unmark_type ty - end - -let unmark_iterators = - let it_type_expr _it ty = unmark_type ty in - {type_iterators with it_type_expr} - -let unmark_type_decl decl = - unmark_iterators.it_type_declaration unmark_iterators decl - -let unmark_extension_constructor ext = - List.iter unmark_type ext.ext_type_params; - iter_type_expr_cstr_args unmark_type ext.ext_args; - Misc.may unmark_type ext.ext_ret_type - -let unmark_class_signature sign = - unmark_type sign.csig_self; - Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars - -let unmark_class_type cty = - unmark_iterators.it_class_type unmark_iterators cty - - - (*******************************************) - (* Memorization of abbreviation expansion *) - (*******************************************) - -(* Search whether the expansion has been memorized. *) - -let lte_public p1 p2 = (* Private <= Public *) - match p1, p2 with - | Private, _ | _, Public -> true - | Public, Private -> false - -let rec find_expans priv p1 = function - Mnil -> None - | Mcons (priv', p2, _ty0, ty, _) - when lte_public priv priv' && Path.same p1 p2 -> Some ty - | Mcons (_, _, _, _, rem) -> find_expans priv p1 rem - | Mlink {contents = rem} -> find_expans priv p1 rem - -(* debug: check for cycles in abbreviation. only works with -principal -let rec check_expans visited ty = - let ty = repr ty in - assert (not (List.memq ty visited)); - match ty.desc with - Tconstr (path, args, abbrev) -> - begin match find_expans path !abbrev with - Some ty' -> check_expans (ty :: visited) ty' - | None -> () - end - | _ -> () -*) - -let memo = ref [] - (* Contains the list of saved abbreviation expansions. *) - -let cleanup_abbrev () = - (* Remove all memorized abbreviation expansions. *) - List.iter (fun abbr -> abbr := Mnil) !memo; - memo := [] - -let memorize_abbrev mem priv path v v' = - (* Memorize the expansion of an abbreviation. *) - mem := Mcons (priv, path, v, v', !mem); - (* check_expans [] v; *) - memo := mem :: !memo - -let rec forget_abbrev_rec mem path = - match mem with - Mnil -> - assert false - | Mcons (_, path', _, _, rem) when Path.same path path' -> - rem - | Mcons (priv, path', v, v', rem) -> - Mcons (priv, path', v, v', forget_abbrev_rec rem path) - | Mlink mem' -> - mem' := forget_abbrev_rec !mem' path; - raise Exit - -let forget_abbrev mem path = - try mem := forget_abbrev_rec !mem path with Exit -> () - -(* debug: check for invalid abbreviations -let rec check_abbrev_rec = function - Mnil -> true - | Mcons (_, ty1, ty2, rem) -> - repr ty1 != repr ty2 - | Mlink mem' -> - check_abbrev_rec !mem' - -let check_memorized_abbrevs () = - List.for_all (fun mem -> check_abbrev_rec !mem) !memo -*) - - (**********************************) - (* Utilities for labels *) - (**********************************) - -let is_optional = function Optional _ -> true | _ -> false - -let label_name = function - Nolabel -> "" - | Labelled s - | Optional s -> s - -let prefixed_label_name = function - Nolabel -> "" - | Labelled s -> "~" ^ s - | Optional s -> "?" ^ s - - -type sargs = (Asttypes.arg_label * Parsetree.expression) list - -let rec extract_label_aux hd l = function - [] -> None - | (l',t as p) :: ls -> - if label_name l' = l then Some (l', t, List.rev_append hd ls) - else extract_label_aux (p::hd) l ls - -let extract_label l (ls : sargs) : (arg_label * Parsetree.expression * sargs) option = extract_label_aux [] l ls - - -let rec label_assoc x (args : sargs) = - match args with - | [] -> false - | (a, _) :: l -> Asttypes.same_arg_label a x || label_assoc x l - - (**********************************) - (* Utilities for backtracking *) - (**********************************) - -let undo_change = function - Ctype (ty, desc) -> ty.desc <- desc - | Ccompress (ty, desc, _) -> ty.desc <- desc - | Clevel (ty, level) -> ty.level <- level - | Cname (r, v) -> r := v - | Crow (r, v) -> r := v - | Ckind (r, v) -> r := v - | Ccommu (r, v) -> r := v - | Cuniv (r, v) -> r := v - | Ctypeset (r, v) -> r := v - -type snapshot = changes ref * int -let last_snapshot = ref 0 - -let log_type ty = - if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) -let link_type ty ty' = - log_type ty; - let desc = ty.desc in - ty.desc <- Tlink ty'; - (* Name is a user-supplied name for this unification variable (obtained - * through a type annotation for instance). *) - match desc, ty'.desc with - Tvar name, Tvar name' -> - begin match name, name' with - | Some _, None -> log_type ty'; ty'.desc <- Tvar name - | None, Some _ -> () - | Some _, Some _ -> - if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name) - | None, None -> () - end - | _ -> () - (* ; assert (check_memorized_abbrevs ()) *) - (* ; check_expans [] ty' *) -let set_level ty level = - if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); - ty.level <- level -let set_univar rty ty = - log_change (Cuniv (rty, !rty)); rty := Some ty -let set_name nm v = - log_change (Cname (nm, !nm)); nm := v -let set_row_field e v = - log_change (Crow (e, !e)); e := Some v -let set_kind rk k = - log_change (Ckind (rk, !rk)); rk := Some k -let set_commu rc c = - log_change (Ccommu (rc, !rc)); rc := c -let set_typeset rs s = - log_change (Ctypeset (rs, !rs)); rs := s - -let snapshot () = - let old = !last_snapshot in - last_snapshot := !new_id; - match Weak.get trail 0 with Some r -> (r, old) - | None -> - let r = ref Unchanged in - Weak.set trail 0 (Some r); - (r, old) - -let rec rev_log accu = function - Unchanged -> accu - | Invalid -> assert false - | Change (ch, next) -> - let d = !next in - next := Invalid; - rev_log (ch::accu) d - -let backtrack (changes, old) = - match !changes with - Unchanged -> last_snapshot := old - | Invalid -> failwith "Btype.backtrack" - | Change _ as change -> - cleanup_abbrev (); - let backlog = rev_log [] change in - List.iter undo_change backlog; - changes := Unchanged; - last_snapshot := old; - Weak.set trail 0 (Some changes) - -let rec rev_compress_log log r = - match !r with - Unchanged | Invalid -> - log - | Change (Ccompress _, next) -> - rev_compress_log (r::log) next - | Change (_, next) -> - rev_compress_log log next - -let undo_compress (changes, _old) = - match !changes with - Unchanged - | Invalid -> () - | Change _ -> - let log = rev_compress_log [] changes in - List.iter - (fun r -> match !r with - Change (Ccompress (ty, desc, d), next) when ty.desc == d -> - ty.desc <- desc; r := !next - | _ -> ()) - log diff --git a/jscomp/ml/btype.mli b/jscomp/ml/btype.mli deleted file mode 100644 index ca1066c..0000000 --- a/jscomp/ml/btype.mli +++ /dev/null @@ -1,224 +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. *) -(* *) -(**************************************************************************) - -(* Basic operations on core types *) - -open Asttypes -open Types - -(**** Sets, maps and hashtables of types ****) - -module TypeSet : Set.S with type elt = type_expr -module TypeMap : Map.S with type key = type_expr -module TypeHash : Hashtbl.S with type key = type_expr - -(**** Levels ****) - -val generic_level: int - -val newty2: int -> type_desc -> type_expr - (* Create a type *) -val newgenty: type_desc -> type_expr - (* Create a generic type *) -val newgenvar: ?name:string -> unit -> type_expr - (* Return a fresh generic variable *) - -(* Use Tsubst instead -val newmarkedvar: int -> type_expr - (* Return a fresh marked variable *) -val newmarkedgenvar: unit -> type_expr - (* Return a fresh marked generic variable *) -*) - -(**** Types ****) - -val is_Tvar: type_expr -> bool -val is_Tunivar: type_expr -> bool -val is_Tconstr: type_expr -> bool -val dummy_method: label -val default_mty: module_type option -> module_type - -val repr: type_expr -> type_expr - (* Return the canonical representative of a type. *) - -val field_kind_repr: field_kind -> field_kind - (* Return the canonical representative of an object field - kind. *) - -val commu_repr: commutable -> commutable - (* Return the canonical representative of a commutation lock *) - -(**** polymorphic variants ****) - -val row_repr: row_desc -> row_desc - (* Return the canonical representative of a row description *) -val row_field_repr: row_field -> row_field -val row_field: label -> row_desc -> row_field - (* Return the canonical representative of a row field *) -val row_more: row_desc -> type_expr - (* Return the extension variable of the row *) -val row_fixed: row_desc -> bool - (* Return whether the row should be treated as fixed or not *) -val static_row: row_desc -> bool - (* Return whether the row is static or not *) -val hash_variant: label -> int - (* Hash function for variant tags *) - -val proxy: type_expr -> type_expr - (* Return the proxy representative of the type: either itself - or a row variable *) - -(**** Utilities for private abbreviations with fixed rows ****) -val row_of_type: type_expr -> type_expr -val has_constr_row: type_expr -> bool -val is_row_name: string -> bool -val is_constr_row: allow_ident:bool -> type_expr -> bool - -(**** Utilities for type traversal ****) - -val iter_type_expr: (type_expr -> unit) -> type_expr -> unit - (* Iteration on types *) -val iter_row: (type_expr -> unit) -> row_desc -> unit - (* Iteration on types in a row *) -val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit - (* Iteration on types in an abbreviation list *) - -type type_iterators = - { it_signature: type_iterators -> signature -> unit; - it_signature_item: type_iterators -> signature_item -> unit; - it_value_description: type_iterators -> value_description -> unit; - it_type_declaration: type_iterators -> type_declaration -> unit; - it_extension_constructor: type_iterators -> extension_constructor -> unit; - it_module_declaration: type_iterators -> module_declaration -> unit; - it_modtype_declaration: type_iterators -> modtype_declaration -> unit; - it_class_declaration: type_iterators -> class_declaration -> unit; - it_class_type_declaration: type_iterators -> class_type_declaration -> unit; - it_module_type: type_iterators -> module_type -> unit; - it_class_type: type_iterators -> class_type -> unit; - it_type_kind: type_iterators -> type_kind -> unit; - it_do_type_expr: type_iterators -> type_expr -> unit; - it_type_expr: type_iterators -> type_expr -> unit; - it_path: Path.t -> unit; } -val type_iterators: type_iterators - (* Iteration on arbitrary type information. - [it_type_expr] calls [mark_type_node] to avoid loops. *) -val unmark_iterators: type_iterators - (* Unmark any structure containing types. See [unmark_type] below. *) - -val copy_type_desc: - ?keep_names:bool -> (type_expr -> type_expr) -> type_desc -> type_desc - (* Copy on types *) -val copy_row: - (type_expr -> type_expr) -> - bool -> row_desc -> bool -> type_expr -> row_desc -val copy_kind: field_kind -> field_kind - -val save_desc: type_expr -> type_desc -> unit - (* Save a type description *) -val dup_kind: field_kind option ref -> unit - (* Save a None field_kind, and make it point to a fresh Fvar *) -val cleanup_types: unit -> unit - (* Restore type descriptions *) - -val lowest_level: int - (* Marked type: ty.level < lowest_level *) -val pivot_level: int - (* Type marking: ty.level <- pivot_level - ty.level *) -val mark_type: type_expr -> unit - (* Mark a type *) -val mark_type_node: type_expr -> unit - (* Mark a type node (but not its sons) *) -val mark_type_params: type_expr -> unit - (* Mark the sons of a type node *) -val unmark_type: type_expr -> unit -val unmark_type_decl: type_declaration -> unit -val unmark_extension_constructor: extension_constructor -> unit -val unmark_class_type: class_type -> unit -val unmark_class_signature: class_signature -> unit - (* Remove marks from a type *) - -(**** Memorization of abbreviation expansion ****) - -val find_expans: private_flag -> Path.t -> abbrev_memo -> type_expr option - (* Look up a memorized abbreviation *) -val cleanup_abbrev: unit -> unit - (* Flush the cache of abbreviation expansions. - When some types are saved (using [output_value]), this - function MUST be called just before. *) -val memorize_abbrev: - abbrev_memo ref -> - private_flag -> Path.t -> type_expr -> type_expr -> unit - (* Add an expansion in the cache *) -val forget_abbrev: - abbrev_memo ref -> Path.t -> unit - (* Remove an abbreviation from the cache *) - -(**** Utilities for labels ****) - -val is_optional : arg_label -> bool -val label_name : arg_label -> label - -(* Returns the label name with first character '?' or '~' as appropriate. *) -val prefixed_label_name : arg_label -> label - -type sargs = (arg_label * Parsetree.expression) list - -val extract_label : - label -> sargs -> - (arg_label * Parsetree.expression * sargs) option - (* actual label, value, new list with the same order *) - -val label_assoc : arg_label -> sargs -> bool -(**** Utilities for backtracking ****) - -type snapshot - (* A snapshot for backtracking *) -val snapshot: unit -> snapshot - (* Make a snapshot for later backtracking. Costs nothing *) -val backtrack: snapshot -> unit - (* Backtrack to a given snapshot. Only possible if you have - not already backtracked to a previous snapshot. - Calls [cleanup_abbrev] internally *) -val undo_compress: snapshot -> unit - (* Backtrack only path compression. Only meaningful if you have - not already backtracked to a previous snapshot. - Does not call [cleanup_abbrev] *) - -(* Functions to use when modifying a type (only Ctype?) *) -val link_type: type_expr -> type_expr -> unit - (* Set the desc field of [t1] to [Tlink t2], logging the old - value if there is an active snapshot *) -val set_level: type_expr -> int -> unit -val set_name: - (Path.t * type_expr list) option ref -> - (Path.t * type_expr list) option -> unit -val set_row_field: row_field option ref -> row_field -> unit -val set_univar: type_expr option ref -> type_expr -> unit -val set_kind: field_kind option ref -> field_kind -> unit -val set_commu: commutable ref -> commutable -> unit -val set_typeset: TypeSet.t ref -> TypeSet.t -> unit - (* Set references, logging the old value *) -val log_type: type_expr -> unit - (* Log the old value of a type, before modifying it by hand *) - -(**** Forward declarations ****) -val print_raw: (Format.formatter -> type_expr -> unit) ref - -val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit) - -val iter_type_expr_cstr_args: (type_expr -> unit) -> - (constructor_arguments -> unit) -val map_type_expr_cstr_args: (type_expr -> type_expr) -> - (constructor_arguments -> constructor_arguments) diff --git a/jscomp/ml/builtin_attributes.ml b/jscomp/ml/builtin_attributes.ml deleted file mode 100755 index f53edbf..0000000 --- a/jscomp/ml/builtin_attributes.ml +++ /dev/null @@ -1,207 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Parsetree - -let string_of_cst = function - | Pconst_string(s, _) -> Some s - | _ -> None - -let string_of_payload = function - | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant c},_)}] -> - string_of_cst c - | _ -> None - -let string_of_opt_payload p = - match string_of_payload p with - | Some s -> s - | None -> "" - -let rec error_of_extension ext = - match ext with - | ({txt = ("ocaml.error"|"error") as txt; loc}, p) -> - let rec sub_from inner = - match inner with - | {pstr_desc=Pstr_extension (ext, _)} :: rest -> - error_of_extension ext :: sub_from rest - | _ :: rest -> - (Location.errorf ~loc - "Invalid syntax for sub-error of extension '%s'." txt) :: - sub_from rest - | [] -> [] - in - begin match p with - | PStr [] -> raise Location.Already_displayed_error - | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}:: - {pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(if_highlight,_))}, _)}:: - inner) -> - Location.error ~loc ~if_highlight ~sub:(sub_from inner) msg - | PStr({pstr_desc=Pstr_eval - ({pexp_desc=Pexp_constant(Pconst_string(msg,_))}, _)}::inner) -> - Location.error ~loc ~sub:(sub_from inner) msg - | _ -> Location.errorf ~loc "Invalid syntax for extension '%s'." txt - end - | ({txt; loc}, _) -> - Location.errorf ~loc "Uninterpreted extension '%s'." txt - -let cat s1 s2 = - if s2 = "" then s1 else - (* 2 spaces indentation for the next line *) - s1 ^ "\n " ^ s2 - -let rec deprecated_of_attrs = function - | [] -> None - | ({txt = "ocaml.deprecated"|"deprecated"; _}, p) :: _ -> - Some (string_of_opt_payload p) - | _ :: tl -> deprecated_of_attrs tl - -let check_deprecated loc attrs s = - match deprecated_of_attrs attrs with - | None -> () - | Some txt -> Location.deprecated loc (cat s txt) - -let check_deprecated_inclusion ~def ~use loc attrs1 attrs2 s = - match deprecated_of_attrs attrs1, deprecated_of_attrs attrs2 with - | None, _ | Some _, Some _ -> () - | Some txt, None -> Location.deprecated ~def ~use loc (cat s txt) - -let rec deprecated_mutable_of_attrs = function - | [] -> None - | ({txt = "ocaml.deprecated_mutable"|"deprecated_mutable"; _}, p) :: _ -> - Some (string_of_opt_payload p) - | _ :: tl -> deprecated_mutable_of_attrs tl - -let check_deprecated_mutable loc attrs s = - match deprecated_mutable_of_attrs attrs with - | None -> () - | Some txt -> - Location.deprecated loc (Printf.sprintf "mutating field %s" (cat s txt)) - -let check_deprecated_mutable_inclusion ~def ~use loc attrs1 attrs2 s = - match deprecated_mutable_of_attrs attrs1, - deprecated_mutable_of_attrs attrs2 - with - | None, _ | Some _, Some _ -> () - | Some txt, None -> - Location.deprecated ~def ~use loc - (Printf.sprintf "mutating field %s" (cat s txt)) - -let check_bs_attributes_inclusion = - ref (fun _attrs1 _attrs2 _s -> - None - ) - -let check_duplicated_labels : (_ -> _ option ) ref = ref (fun _lbls -> - None -) - -let rec deprecated_of_sig = function - | {psig_desc = Psig_attribute a} :: tl -> - begin match deprecated_of_attrs [a] with - | None -> deprecated_of_sig tl - | Some _ as r -> r - end - | _ -> None - - -let rec deprecated_of_str = function - | {pstr_desc = Pstr_attribute a} :: tl -> - begin match deprecated_of_attrs [a] with - | None -> deprecated_of_str tl - | Some _ as r -> r - end - | _ -> None - - -let warning_attribute ?(ppwarning = true) = - let process loc txt errflag payload = - match string_of_payload payload with - | Some s -> - begin try Warnings.parse_options errflag s - with Arg.Bad _ -> - Location.prerr_warning loc - (Warnings.Attribute_payload - (txt, "Ill-formed list of warnings")) - end - | None -> - Location.prerr_warning loc - (Warnings.Attribute_payload - (txt, "A single string literal is expected")) - in - function - | ({txt = ("ocaml.warning"|"warning") as txt; loc}, payload) -> - process loc txt false payload - | ({txt = ("ocaml.warnerror"|"warnerror") as txt; loc}, payload) -> - process loc txt true payload - | {txt="ocaml.ppwarning"|"ppwarning"}, - PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant - (Pconst_string (s, _))},_); - pstr_loc}] when ppwarning -> - Location.prerr_warning pstr_loc (Warnings.Preprocessor s) - | _ -> - () - -let warning_scope ?ppwarning attrs f = - let prev = Warnings.backup () in - try - List.iter (warning_attribute ?ppwarning) (List.rev attrs); - let ret = f () in - Warnings.restore prev; - ret - with exn -> - Warnings.restore prev; - raise exn - - -let warn_on_literal_pattern = - List.exists - (function - | ({txt="ocaml.warn_on_literal_pattern"|"warn_on_literal_pattern"; _}, _) - -> true - | _ -> false - ) - -let explicit_arity = - List.exists - (function - | ({txt="ocaml.explicit_arity"|"explicit_arity"; _}, _) -> true - | _ -> false - ) - -let immediate = - List.exists - (function - | ({txt="ocaml.immediate"|"immediate"; _}, _) -> true - | _ -> false - ) - -(* The "ocaml.boxed (default)" and "ocaml.unboxed (default)" - attributes cannot be input by the user, they are added by the - compiler when applying the default setting. This is done to record - in the .cmi the default used by the compiler when compiling the - source file because the default can change between compiler - invocations. *) - -let check l (x, _) = List.mem x.txt l - -let has_unboxed attr = - List.exists (check ["ocaml.unboxed"; "unboxed"]) - attr - -let has_boxed attr = - List.exists (check ["ocaml.boxed"; "boxed"]) attr diff --git a/jscomp/ml/builtin_attributes.mli b/jscomp/ml/builtin_attributes.mli deleted file mode 100755 index 7282dbb..0000000 --- a/jscomp/ml/builtin_attributes.mli +++ /dev/null @@ -1,84 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -(* Support for some of the builtin attributes: - - ocaml.deprecated - ocaml.error - ocaml.ppwarning - ocaml.warning - ocaml.warnerror - ocaml.explicit_arity (for camlp4/camlp5) - ocaml.warn_on_literal_pattern - ocaml.deprecated_mutable - ocaml.immediate - ocaml.boxed / ocaml.unboxed -*) - - -val check_deprecated: Location.t -> Parsetree.attributes -> string -> unit -val check_deprecated_inclusion: - def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> - Parsetree.attributes -> string -> unit -val deprecated_of_attrs: Parsetree.attributes -> string option -val deprecated_of_sig: Parsetree.signature -> string option -val deprecated_of_str: Parsetree.structure -> string option - -val check_deprecated_mutable: - Location.t -> Parsetree.attributes -> string -> unit -val check_deprecated_mutable_inclusion: - def:Location.t -> use:Location.t -> Location.t -> Parsetree.attributes -> - Parsetree.attributes -> string -> unit - -val check_bs_attributes_inclusion: - (Parsetree.attributes -> - Parsetree.attributes -> string -> (string*string) option ) ref - -val check_duplicated_labels: - (Parsetree.label_declaration list -> - string Asttypes.loc option - ) ref -val error_of_extension: Parsetree.extension -> Location.error - -val warning_attribute: ?ppwarning:bool -> Parsetree.attribute -> unit - (** Apply warning settings from the specified attribute. - "ocaml.warning"/"ocaml.warnerror" (and variants without the prefix) - are processed and other attributes are ignored. - - Also implement ocaml.ppwarning (unless ~ppwarning:false is - passed). - *) - -val warning_scope: - ?ppwarning:bool -> - Parsetree.attributes -> (unit -> 'a) -> 'a - (** Execute a function in a new scope for warning settings. This - means that the effect of any call to [warning_attribute] during - the execution of this function will be discarded after - execution. - - The function also takes a list of attributes which are processed - with [warning_attribute] in the fresh scope before the function - is executed. - *) - -val warn_on_literal_pattern: Parsetree.attributes -> bool -val explicit_arity: Parsetree.attributes -> bool - - -val immediate: Parsetree.attributes -> bool - -val has_unboxed: Parsetree.attributes -> bool -val has_boxed: Parsetree.attributes -> bool diff --git a/jscomp/ml/ccomp.ml b/jscomp/ml/ccomp.ml deleted file mode 100644 index ae2fb79..0000000 --- a/jscomp/ml/ccomp.ml +++ /dev/null @@ -1,9 +0,0 @@ - -let command cmdline = - if !Clflags.verbose then begin - prerr_string "+ "; - prerr_string cmdline; - prerr_newline() - end; - Sys.command cmdline - diff --git a/jscomp/ml/ccomp.mli b/jscomp/ml/ccomp.mli deleted file mode 100644 index 7ba8b4b..0000000 --- a/jscomp/ml/ccomp.mli +++ /dev/null @@ -1,2 +0,0 @@ - -val command: string -> int diff --git a/jscomp/ml/clflags.ml b/jscomp/ml/clflags.ml deleted file mode 100644 index b2b2a78..0000000 --- a/jscomp/ml/clflags.ml +++ /dev/null @@ -1,67 +0,0 @@ - - - - -let output_name = ref (None : string option) (* -o *) -and include_dirs = ref ([] : string list)(* -I *) -and debug = ref false (* -g *) -and fast = ref false (* -unsafe *) - -and nopervasives = ref false (* -nopervasives *) -and preprocessor = ref(None : string option) (* -pp *) -and all_ppx = ref ([] : string list) (* -ppx *) -let annotations = ref false (* -annot *) -let binary_annotations = ref false (* -annot *) -and noassert = ref false (* -noassert *) -and verbose = ref false (* -verbose *) -and open_modules = ref [] (* -open *) - -and real_paths = ref true (* -short-paths *) -and applicative_functors = ref true (* -no-app-funct *) -and error_size = ref 500 (* -error-size *) -and transparent_modules = ref false (* -trans-mod *) -let dump_source = ref false (* -dsource *) -let dump_parsetree = ref false (* -dparsetree *) -and dump_typedtree = ref false (* -dtypedtree *) -and dump_rawlambda = ref false (* -drawlambda *) -and dump_lambda = ref false (* -dlambda *) -and only_parse = ref false (* -only-parse *) -and ignore_parse_errors = ref false (* -ignore-parse-errors *) - -let dont_write_files = ref false (* set to true under ocamldoc *) - - -let reset_dump_state () = begin - dump_source := false; - dump_parsetree := false; - dump_typedtree := false; - dump_rawlambda := false -end - - - - -let keep_docs = ref false (* -keep-docs *) -let keep_locs = ref true (* -keep-locs *) - - - - -let parse_color_setting = function - | "auto" -> Some Misc.Color.Auto - | "always" -> Some Misc.Color.Always - | "never" -> Some Misc.Color.Never - | _ -> None -let color = ref None ;; (* -color *) - -let unboxed_types = ref false - - - - -type mli_status = Mli_exists | Mli_non_exists -let assume_no_mli = ref Mli_non_exists -let dont_record_crc_unit : string option ref = ref None -let bs_gentype = ref false -let no_assert_false = ref false -let dump_location = ref true diff --git a/jscomp/ml/cmi_format.ml b/jscomp/ml/cmi_format.ml deleted file mode 100644 index ee95e82..0000000 --- a/jscomp/ml/cmi_format.ml +++ /dev/null @@ -1,144 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 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 pers_flags = - | Deprecated of string - - - -type error = - Not_an_interface of string - | Wrong_version_interface of string * string - | Corrupted_interface of string - -exception Error of error - -type cmi_infos = { - cmi_name : string; - cmi_sign : Types.signature_item list; - cmi_crcs : (string * Digest.t option) list; - cmi_flags : pers_flags list; -} - -let input_cmi ic = - let (name, sign) = input_value ic in - let crcs = input_value ic in - let flags = input_value ic in - { - cmi_name = name; - cmi_sign = sign; - cmi_crcs = crcs; - cmi_flags = flags; - } - -let read_cmi filename = - let ic = open_in_bin filename in - try - let buffer = - really_input_string ic (String.length Config.cmi_magic_number) - in - if buffer <> Config.cmi_magic_number then begin - close_in ic; - let pre_len = String.length Config.cmi_magic_number - 3 in - if String.sub buffer 0 pre_len - = String.sub Config.cmi_magic_number 0 pre_len then - begin - let msg = - if buffer < Config.cmi_magic_number then "an older" else "a newer" in - raise (Error (Wrong_version_interface (filename, msg))) - end else begin - raise(Error(Not_an_interface filename)) - end - end; - let cmi = input_cmi ic in - close_in ic; - cmi - with End_of_file | Failure _ -> - close_in ic; - raise(Error(Corrupted_interface(filename))) - | Error e -> - close_in ic; - raise (Error e) - -let output_cmi filename oc cmi = -(* beware: the provided signature must have been substituted for saving *) - output_string oc Config.cmi_magic_number; - output_value oc (cmi.cmi_name, cmi.cmi_sign); - flush oc; - let crc = Digest.file filename in - let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in - output_value oc crcs; - output_value oc cmi.cmi_flags; - crc - - -(* This function is also called by [save_cmt] as cmi_format is subset of - cmt_format, so dont close the channel yet -*) -let create_cmi ?check_exists filename (cmi : cmi_infos) = - (* beware: the provided signature must have been substituted for saving *) - let content = - Config.cmi_magic_number ^ Marshal.to_string (cmi.cmi_name, cmi.cmi_sign) [] - (* checkout [output_value] in {!Pervasives} module *) - in - let crc = Digest.string content in - let cmi_infos = - if check_exists <> None && Sys.file_exists filename then - Some (read_cmi filename) - else None in - match cmi_infos with - | Some {cmi_name = _; cmi_sign = _; cmi_crcs = (old_name, Some old_crc)::rest ; cmi_flags} - (* TODO: design the cmi format so that we don't need read the whole cmi *) - when - cmi.cmi_name = old_name && - crc = old_crc && - cmi.cmi_crcs = rest && - cmi_flags = cmi.cmi_flags -> - crc - | _ -> - let crcs = (cmi.cmi_name, Some crc) :: cmi.cmi_crcs in - let oc = open_out_bin filename in - output_string oc content; - output_value oc crcs; - output_value oc cmi.cmi_flags; - close_out oc; - crc - - - - -(* Error report *) - -open Format - -let report_error ppf = function - | Not_an_interface filename -> - fprintf ppf "%a@ is not a compiled interface" - Location.print_filename filename - | Wrong_version_interface (filename, older_newer) -> - fprintf ppf - "%a@ is not a compiled interface for this version of OCaml.@.\ - It seems to be for %s version of OCaml." - Location.print_filename filename older_newer - | Corrupted_interface filename -> - fprintf ppf "Corrupted compiled interface@ %a" - Location.print_filename filename - -let () = - Location.register_error_of_exn - (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None - ) diff --git a/jscomp/ml/code_frame.ml b/jscomp/ml/code_frame.ml deleted file mode 100644 index dc53615..0000000 --- a/jscomp/ml/code_frame.ml +++ /dev/null @@ -1,258 +0,0 @@ -let digits_count n = - let rec loop n base count = - if n >= base then loop n (base * 10) (count + 1) else count - in - loop (abs n) 1 0 - -let seek_2_lines_before src (pos : Lexing.position) = - let original_line = pos.pos_lnum in - let rec loop current_line current_char = - if current_line + 2 >= original_line then - (current_char, current_line) - else - loop - (if src.[current_char] = '\n' then current_line + 1 else current_line) - (current_char + 1) - in - loop 1 0 - -let seek_2_lines_after src (pos : Lexing.position) = - let original_line = pos.pos_lnum in - let rec loop current_line current_char = - if current_char = String.length src then - (current_char, current_line) - else - match src.[current_char] with - | '\n' when current_line = original_line + 2 -> - (current_char, current_line) - | '\n' -> loop (current_line + 1) (current_char + 1) - | _ -> loop current_line (current_char + 1) - in - loop original_line pos.pos_cnum - -let leading_space_count str = - let rec loop i count = - if i = String.length str then count - else if str.[i] != ' ' then count - else loop (i + 1) (count + 1) - in - loop 0 0 - -let break_long_line max_width line = - let rec loop pos accum = - if pos = String.length line then accum - else - let chunk_length = min max_width (String.length line - pos) in - let chunk = String.sub line pos chunk_length in - loop (pos + chunk_length) (chunk::accum) - in - loop 0 [] |> List.rev - -let filter_mapi f l = - let rec loop f l i accum = - match l with - | [] -> accum - | head::rest -> - let accum = - match f i head with - | None -> accum - | Some result -> result::accum - in - loop f rest (i + 1) accum - in - loop f l 0 [] |> List.rev - -(* Spiritual equivalent of - https://github.com/ocaml/ocaml/blob/414bdec9ae387129b8102cc6bf3c0b6ae173eeb9/utils/misc.ml#L601 -*) -module Color = struct - type color = - | Dim - (* | Filename *) - | Err - | Warn - | NoColor - - let dim = "\x1b[2m" - (* let filename = "\x1b[46m" *) - let err = "\x1b[1;31m" - let warn = "\x1b[1;33m" - let reset = "\x1b[0m" - - external isatty : out_channel -> bool = "caml_sys_isatty" - (* reasonable heuristic on whether colors should be enabled *) - let should_enable_color () = - let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" - && term <> "" - && isatty stderr - - let color_enabled = ref true - - let setup = - let first = ref true in (* initialize only once *) - fun o -> - if !first then ( - first := false; - color_enabled := (match o with - | Some Misc.Color.Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()) - ); - () -end - -let setup = Color.setup - -type gutter = Number of int | Elided -type highlighted_string = {s: string; start: int; end_: int} -type line = { - gutter: gutter; - content: highlighted_string list; -} -(* - Features: - - display a line gutter - - break long line into multiple for terminal display - - peek 2 lines before & after for context - - center snippet when it's heavily indented - - ellide intermediate lines when the reported range is huge -*) -let print ~is_warning ~src ~(startPos : Lexing.position) ~(endPos:Lexing.position) = - let indent = 2 in - let highlight_line_start_line = startPos.pos_lnum in - let highlight_line_end_line = endPos.pos_lnum in - let (start_line_line_offset, first_shown_line) = seek_2_lines_before src startPos in - let (end_line_line_end_offset, last_shown_line) = seek_2_lines_after src endPos in - - let more_than_5_highlighted_lines = - highlight_line_end_line - highlight_line_start_line + 1 > 5 - in - let max_line_digits_count = digits_count last_shown_line in - (* TODO: change this back to a fixed 100? *) - (* 3 for separator + the 2 spaces around it *) - let line_width = 78 - max_line_digits_count - indent - 3 in - let lines = - String.sub src start_line_line_offset (end_line_line_end_offset - start_line_line_offset) - |> String.split_on_char '\n' - |> filter_mapi (fun i line -> - let line_number = i + first_shown_line in - if more_than_5_highlighted_lines then - if line_number = highlight_line_start_line + 2 then - Some (Elided, line) - else if line_number > highlight_line_start_line + 2 && line_number < highlight_line_end_line - 1 then None - else Some (Number line_number, line) - else Some (Number line_number, line) - ) - in - let leading_space_to_cut = lines |> List.fold_left (fun current_max (_, line) -> - let leading_spaces = leading_space_count line in - if String.length line = leading_spaces then - (* the line's nothing but spaces. Doesn't count *) - current_max - else - min leading_spaces current_max - ) 99999 - in - let separator = if leading_space_to_cut = 0 then "│" else "┆" in - let stripped_lines = lines |> List.map (fun (gutter, line) -> - let new_content = - if String.length line <= leading_space_to_cut then - [{s = ""; start = 0; end_ = 0}] - else - String.sub line leading_space_to_cut (String.length line - leading_space_to_cut) - |> break_long_line line_width - |> List.mapi (fun i line -> - match gutter with - | Elided -> {s = line; start = 0; end_ = 0} - | Number line_number -> - let highlight_line_start_offset = startPos.pos_cnum - startPos.pos_bol in - let highlight_line_end_offset = endPos.pos_cnum - endPos.pos_bol in - let start = - if i = 0 && line_number = highlight_line_start_line then - highlight_line_start_offset - leading_space_to_cut - else 0 - in - let end_ = - if line_number < highlight_line_start_line then 0 - else if line_number = highlight_line_start_line && line_number = highlight_line_end_line then - highlight_line_end_offset - leading_space_to_cut - else if line_number = highlight_line_start_line then - String.length line - else if line_number > highlight_line_start_line && line_number < highlight_line_end_line then - String.length line - else if line_number = highlight_line_end_line then highlight_line_end_offset - leading_space_to_cut - else 0 - in - {s = line; start; end_} - ) - in - {gutter; content = new_content} - ) - in - let buf = Buffer.create 100 in - let open Color in - let add_ch = - let last_color = ref NoColor in - fun color ch -> - if not !Color.color_enabled || !last_color = color then - Buffer.add_char buf ch - else begin - let ansi = match !last_color, color with - | NoColor, Dim -> dim - (* | NoColor, Filename -> filename *) - | NoColor, Err -> err - | NoColor, Warn -> warn - | _, NoColor -> reset - | _, Dim -> reset ^ dim - (* | _, Filename -> reset ^ filename *) - | _, Err -> reset ^ err - | _, Warn -> reset ^ warn - in - Buffer.add_string buf ansi; - Buffer.add_char buf ch; - last_color := color; - end - in - let draw_gutter color s = - for _i = 1 to (max_line_digits_count + indent - String.length s) do - add_ch NoColor ' ' - done; - s |> String.iter (add_ch color); - add_ch NoColor ' '; - separator |> String.iter (add_ch Dim); - add_ch NoColor ' '; - in - stripped_lines |> List.iter (fun {gutter; content} -> - match gutter with - | Elided -> - draw_gutter Dim "."; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch Dim '.'; - add_ch NoColor '\n'; - | Number line_number -> begin - content |> List.iteri (fun i line -> - let gutter_content = if i = 0 then string_of_int line_number else "" in - let gutter_color = - if i = 0 - && line_number >= highlight_line_start_line - && line_number <= highlight_line_end_line then - if is_warning then Warn else Err - else NoColor - in - draw_gutter gutter_color gutter_content; - - line.s |> String.iteri (fun ii ch -> - let c = - if ii >= line.start && ii < line.end_ then - if is_warning then Warn else Err - else NoColor in - add_ch c ch; - ); - add_ch NoColor '\n'; - ); - end - ); - Buffer.contents buf diff --git a/jscomp/ml/consistbl.ml b/jscomp/ml/consistbl.ml deleted file mode 100644 index dbba5d1..0000000 --- a/jscomp/ml/consistbl.ml +++ /dev/null @@ -1,66 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 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. *) -(* *) -(**************************************************************************) - -(* Consistency tables: for checking consistency of module CRCs *) - -type t = (string, Digest.t * string) Hashtbl.t - -let create () = Hashtbl.create 13 - -let clear = Hashtbl.clear - -exception Inconsistency of string * string * string - -exception Not_available of string - -let check tbl name crc source = - try - let (old_crc, old_source) = Hashtbl.find tbl name in - if crc <> old_crc then raise(Inconsistency(name, source, old_source)) - with Not_found -> - Hashtbl.add tbl name (crc, source) - -let check_noadd tbl name crc source = - try - let (old_crc, old_source) = Hashtbl.find tbl name in - if crc <> old_crc then raise(Inconsistency(name, source, old_source)) - with Not_found -> - raise (Not_available name) - -let set tbl name crc source = Hashtbl.add tbl name (crc, source) - -let source tbl name = snd (Hashtbl.find tbl name) - -let extract l tbl = - let l = List.sort_uniq String.compare l in - List.fold_left - (fun assc name -> - try - let (crc, _) = Hashtbl.find tbl name in - (name, Some crc) :: assc - with Not_found -> - (name, None) :: assc) - [] l - -let filter p tbl = - let to_remove = ref [] in - Hashtbl.iter - (fun name _ -> - if not (p name) then to_remove := name :: !to_remove) - tbl; - List.iter - (fun name -> - while Hashtbl.mem tbl name do Hashtbl.remove tbl name done) - !to_remove diff --git a/jscomp/ml/consistbl.mli b/jscomp/ml/consistbl.mli deleted file mode 100644 index c532bdd..0000000 --- a/jscomp/ml/consistbl.mli +++ /dev/null @@ -1,62 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 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. *) -(* *) -(**************************************************************************) - -(* Consistency tables: for checking consistency of module CRCs *) - -type t - -val create: unit -> t - -val clear: t -> unit - -val check: t -> string -> Digest.t -> string -> unit - (* [check tbl name crc source] - checks consistency of ([name], [crc]) with infos previously - stored in [tbl]. If no CRC was previously associated with - [name], record ([name], [crc]) in [tbl]. - [source] is the name of the file from which the information - comes from. This is used for error reporting. *) - -val check_noadd: t -> string -> Digest.t -> string -> unit - (* Same as [check], but raise [Not_available] if no CRC was previously - associated with [name]. *) - -val set: t -> string -> Digest.t -> string -> unit - (* [set tbl name crc source] forcefully associates [name] with - [crc] in [tbl], even if [name] already had a different CRC - associated with [name] in [tbl]. *) - -val source: t -> string -> string - (* [source tbl name] returns the file name associated with [name] - if the latter has an associated CRC in [tbl]. - Raise [Not_found] otherwise. *) - -val extract: string list -> t -> (string * Digest.t option) list - (* [extract tbl names] returns an associative list mapping each string - in [names] to the CRC associated with it in [tbl]. If no CRC is - associated with a name then it is mapped to [None]. *) - -val filter: (string -> bool) -> t -> unit - (* [filter pred tbl] removes from [tbl] table all (name, CRC) pairs - such that [pred name] is [false]. *) - -exception Inconsistency of string * string * string - (* Raised by [check] when a CRC mismatch is detected. - First string is the name of the compilation unit. - Second string is the source that caused the inconsistency. - Third string is the source that set the CRC. *) - -exception Not_available of string - (* Raised by [check_noadd] when a name doesn't have an associated CRC. *) diff --git a/jscomp/ml/ctype.ml b/jscomp/ml/ctype.ml deleted file mode 100644 index 901a0db..0000000 --- a/jscomp/ml/ctype.ml +++ /dev/null @@ -1,4651 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Jerome Vouillon, 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. *) -(* *) -(**************************************************************************) - -(* Operations on core types *) - -open Misc -open Asttypes -open Types -open Btype - -(* - Type manipulation after type inference - ====================================== - If one wants to manipulate a type after type inference (for - instance, during code generation or in the debugger), one must - first make sure that the type levels are correct, using the - function [correct_levels]. Then, this type can be correctly - manipulated by [apply], [expand_head] and [moregeneral]. -*) - -(* - General notes - ============= - - As much sharing as possible should be kept : it makes types - smaller and better abbreviated. - When necessary, some sharing can be lost. Types will still be - printed correctly (+++ TO DO...), and abbreviations defined by a - class do not depend on sharing thanks to constrained - abbreviations. (Of course, even if some sharing is lost, typing - will still be correct.) - - All nodes of a type have a level : that way, one know whether a - node need to be duplicated or not when instantiating a type. - - Levels of a type are decreasing (generic level being considered - as greatest). - - The level of a type constructor is superior to the binding - time of its path. - - Recursive types without limitation should be handled (even if - there is still an occur check). This avoid treating specially the - case for objects, for instance. Furthermore, the occur check - policy can then be easily changed. -*) - -(**** Errors ****) - -exception Unify of (type_expr * type_expr) list - -exception Tags of label * label - -let () = - Location.register_error_of_exn - (function - | Tags (l, l') -> - Some - Location. - (errorf ~loc:(in_file !input_name) - "In this program,@ variant constructors@ #%s and #%s@ \ - have the same hash value.@ Change one of them." l l' - ) - | _ -> None - ) - -exception Subtype of - (type_expr * type_expr) list * (type_expr * type_expr) list - -exception Cannot_expand - -exception Cannot_apply - -exception Recursive_abbrev - -(* GADT: recursive abbrevs can appear as a result of local constraints *) -exception Unification_recursive_abbrev of (type_expr * type_expr) list - -(**** Type level management ****) - -let current_level = ref 0 -let nongen_level = ref 0 -let global_level = ref 1 -let saved_level = ref [] - -type levels = - { current_level: int; nongen_level: int; global_level: int; - saved_level: (int * int) list; } -let save_levels () = - { current_level = !current_level; - nongen_level = !nongen_level; - global_level = !global_level; - saved_level = !saved_level } -let set_levels l = - current_level := l.current_level; - nongen_level := l.nongen_level; - global_level := l.global_level; - saved_level := l.saved_level - -let get_current_level () = !current_level -let init_def level = current_level := level; nongen_level := level -let begin_def () = - saved_level := (!current_level, !nongen_level) :: !saved_level; - incr current_level; nongen_level := !current_level -let begin_class_def () = - saved_level := (!current_level, !nongen_level) :: !saved_level; - incr current_level -let raise_nongen_level () = - saved_level := (!current_level, !nongen_level) :: !saved_level; - nongen_level := !current_level -let end_def () = - let (cl, nl) = List.hd !saved_level in - saved_level := List.tl !saved_level; - current_level := cl; nongen_level := nl - -let reset_global_level () = - global_level := !current_level + 1 -let increase_global_level () = - let gl = !global_level in - global_level := !current_level; - gl -let restore_global_level gl = - global_level := gl - -(**** Whether a path points to an object type (with hidden row variable) ****) -let is_object_type path = - let name = - match path with Path.Pident id -> Ident.name id - | Path.Pdot(_, s,_) -> s - | Path.Papply _ -> assert false - in name.[0] = '#' - -(**** Control tracing of GADT instances *) - -let trace_gadt_instances = ref false -let check_trace_gadt_instances env = - not !trace_gadt_instances && Env.has_local_constraints env && - (trace_gadt_instances := true; cleanup_abbrev (); true) - -let reset_trace_gadt_instances b = - if b then trace_gadt_instances := false - -let wrap_trace_gadt_instances env f x = - let b = check_trace_gadt_instances env in - let y = f x in - reset_trace_gadt_instances b; - y - -(**** Abbreviations without parameters ****) -(* Shall reset after generalizing *) - -let simple_abbrevs = ref Mnil - -let proper_abbrevs path tl abbrev = - if tl <> [] || !trace_gadt_instances || - is_object_type path - then abbrev - else simple_abbrevs - -(**** Some type creators ****) - -(* Re-export generic type creators *) - -let newty2 = Btype.newty2 -let newty desc = newty2 !current_level desc - -let newvar ?name () = newty2 !current_level (Tvar name) -let newvar2 ?name level = newty2 level (Tvar name) -let new_global_var ?name () = newty2 !global_level (Tvar name) - -let newobj fields = newty (Tobject (fields, ref None)) - -let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) - -let none = newty (Ttuple []) (* Clearly ill-formed type *) - -(**** Representative of a type ****) - -(* Re-export repr *) -let repr = repr - -(**** Type maps ****) - -module TypePairs = - Hashtbl.Make (struct - type t = type_expr * type_expr - let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') - let hash (t, t') = t.id + 93 * t'.id - end) - - -(**** unification mode ****) - -type unification_mode = - | Expression (* unification in expression *) - | Pattern (* unification in pattern which may add local constraints *) - -let umode = ref Expression -let generate_equations = ref false -let assume_injective = ref false -let variant_is_subtype = ref (fun _env _row _p1 -> false) -let set_mode_pattern ~generate ~injective f = - let old_unification_mode = !umode - and old_gen = !generate_equations - and old_inj = !assume_injective in - try - umode := Pattern; - generate_equations := generate; - assume_injective := injective; - let ret = f () in - umode := old_unification_mode; - generate_equations := old_gen; - assume_injective := old_inj; - ret - with e -> - umode := old_unification_mode; - generate_equations := old_gen; - assume_injective := old_inj; - raise e - -(*** Checks for type definitions ***) - -let in_current_module = function - | Path.Pident _ -> true - | Path.Pdot _ | Path.Papply _ -> false - -let in_pervasives p = - in_current_module p && - try ignore (Env.find_type p Env.initial_safe_string); true - with Not_found -> false - -let is_datatype decl= - match decl.type_kind with - Type_record _ | Type_variant _ | Type_open -> true - | Type_abstract -> false - - - (**********************************************) - (* Miscellaneous operations on object types *) - (**********************************************) - -(* Note: - We need to maintain some invariants: - * cty_self must be a Tobject - * ... -*) -type fields = (string * Types.field_kind * Types.type_expr) list -(**** Object field manipulation. ****) - -let object_fields ty = - match (repr ty).desc with - Tobject (fields, _) -> fields - | _ -> assert false - -let flatten_fields (ty : Types.type_expr) : fields * _ = - let rec flatten (l : fields) ty = - let ty = repr ty in - match ty.desc with - Tfield(s, k, ty1, ty2) -> - flatten ((s, k, ty1)::l) ty2 - | _ -> - (l, ty) - in - let (l, r) = flatten [] ty in - (List.sort (fun (n, _, _) (n', _, _) -> compare n n') l, r) - -let build_fields level = - List.fold_right - (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2))) - - -let associate_fields - (fields1 : fields ) - (fields2 : fields ) : _ * fields * fields = - let rec associate p s s' : fields * fields -> _ = - function - (l, []) -> - (List.rev p, (List.rev s) @ l, List.rev s') - | ([], l') -> - (List.rev p, List.rev s, (List.rev s') @ l') - | ((n, k, t)::r, (n', k', t')::r') when n = n' -> - associate ((n, k, t, k', t')::p) s s' (r, r') - | ((n, k, t)::r, ((n', _k', _t')::_ as l')) when n < n' -> - associate p ((n, k, t)::s) s' (r, l') - | (((_n, _k, _t)::_ as l), (n', k', t')::r') (* when n > n' *) -> - associate p s ((n', k', t')::s') (l, r') - in - associate [] [] [] (fields1, fields2) - -(**** Check whether an object is open ****) - -(* +++ The abbreviation should eventually be expanded *) -let rec object_row ty = - let ty = repr ty in - match ty.desc with - Tobject (t, _) -> object_row t - | Tfield(_, _, _, t) -> object_row t - | _ -> ty - -let opened_object ty = - match (object_row ty).desc with - | Tvar _ | Tunivar _ | Tconstr _ -> true - | _ -> false - -let concrete_object ty = - match (object_row ty).desc with - | Tvar _ -> false - | _ -> true - -(**** Close an object ****) - -let close_object ty = - let rec close ty = - let ty = repr ty in - match ty.desc with - Tvar _ -> - link_type ty (newty2 ty.level Tnil) - | Tfield(_, _, _, ty') -> close ty' - | _ -> assert false - in - match (repr ty).desc with - Tobject (ty, _) -> close ty - | _ -> assert false - -(**** Row variable of an object type ****) - -let row_variable ty = - let rec find ty = - let ty = repr ty in - match ty.desc with - Tfield (_, _, _, ty) -> find ty - | Tvar _ -> ty - | _ -> assert false - in - match (repr ty).desc with - Tobject (fi, _) -> find fi - | _ -> assert false - -(**** Object name manipulation ****) -(* +++ Bientot obsolete *) - -let set_object_name id rv params ty = - match (repr ty).desc with - Tobject (_fi, nm) -> - set_name nm (Some (Path.Pident id, rv::params)) - | _ -> - assert false - -let remove_object_name ty = - match (repr ty).desc with - Tobject (_, nm) -> set_name nm None - | Tconstr (_, _, _) -> () - | _ -> fatal_error "Ctype.remove_object_name" - -(**** Hiding of private methods ****) - -let hide_private_methods ty = - match (repr ty).desc with - Tobject (fi, nm) -> - nm := None; - let (fl, _) = flatten_fields fi in - List.iter - (function (_, k, _) -> - match field_kind_repr k with - Fvar r -> set_kind r Fabsent - | _ -> ()) - fl - | _ -> - assert false - - - (*******************************) - (* Operations on class types *) - (*******************************) - - -let rec signature_of_class_type = - function - Cty_constr (_, _, cty) -> signature_of_class_type cty - | Cty_signature sign -> sign - | Cty_arrow (_, _, cty) -> signature_of_class_type cty - -let self_type cty = - repr (signature_of_class_type cty).csig_self - -let rec class_type_arity = - function - Cty_constr (_, _, cty) -> class_type_arity cty - | Cty_signature _ -> 0 - | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty - - - (*******************************************) - (* Miscellaneous operations on row types *) - (*******************************************) -type row_fields = (Asttypes.label * Types.row_field) list -type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list -let sort_row_fields : row_fields -> row_fields = List.sort (fun (p,_) (q,_) -> compare (p : string) q) - -let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) (fi1 : row_fields) (fi2 : row_fields) = - match fi1, fi2 with - (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> - if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else - if l1 < l2 then merge_rf (p1::r1) r2 pairs fi1' fi2 else - merge_rf r1 (p2::r2) pairs fi1 fi2' - | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) - | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) - -let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : row_fields * row_fields * row_pairs = - match fi1, fi2 with - [], _ | _, [] -> (fi1, fi2, []) - | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) - | _, [p2] when not (List.mem_assoc (fst p2) fi1) -> (fi1, fi2, []) - | _ -> merge_rf [] [] [] (sort_row_fields fi1) (sort_row_fields fi2) - -let rec filter_row_fields erase = function - [] -> [] - | (_l,f as p)::fi -> - let fi = filter_row_fields erase fi in - match row_field_repr f with - Rabsent -> fi - | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi - | _ -> p :: fi - - (**************************************) - (* Check genericity of type schemes *) - (**************************************) - - -exception Non_closed of type_expr * bool - -let free_variables = ref [] -let really_closed = ref None - -let rec free_vars_rec real ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - begin match ty.desc, !really_closed with - Tvar _, _ -> - free_variables := (ty, real) :: !free_variables - | Tconstr (path, tl, _), Some env -> - begin try - let (_, body, _) = Env.find_type_expansion path env in - if (repr body).level <> generic_level then - free_variables := (ty, real) :: !free_variables - with Not_found -> () - end; - List.iter (free_vars_rec true) tl -(* Do not count "virtual" free variables - | Tobject(ty, {contents = Some (_, p)}) -> - free_vars_rec false ty; List.iter (free_vars_rec true) p -*) - | Tobject (ty, _), _ -> - free_vars_rec false ty - | Tfield (_, _, ty1, ty2), _ -> - free_vars_rec true ty1; free_vars_rec false ty2 - | Tvariant row, _ -> - let row = row_repr row in - iter_row (free_vars_rec true) row; - if not (static_row row) then free_vars_rec false row.row_more - | _ -> - iter_type_expr (free_vars_rec true) ty - end; - end - -let free_vars ?env ty = - free_variables := []; - really_closed := env; - free_vars_rec true ty; - let res = !free_variables in - free_variables := []; - really_closed := None; - res - -let free_variables ?env ty = - let tl = List.map fst (free_vars ?env ty) in - unmark_type ty; - tl - -let closed_type ty = - match free_vars ty with - [] -> () - | (v, real) :: _ -> raise (Non_closed (v, real)) - -let closed_parameterized_type params ty = - List.iter mark_type params; - let ok = - try closed_type ty; true with Non_closed _ -> false in - List.iter unmark_type params; - unmark_type ty; - ok - -let closed_type_decl decl = - try - List.iter mark_type decl.type_params; - begin match decl.type_kind with - Type_abstract -> - () - | Type_variant v -> - List.iter - (fun {cd_args; cd_res; _} -> - match cd_res with - | Some _ -> () - | None -> - match cd_args with - | Cstr_tuple l -> List.iter closed_type l - | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l - ) - v - | Type_record(r, _rep) -> - List.iter (fun l -> closed_type l.ld_type) r - | Type_open -> () - end; - begin match decl.type_manifest with - None -> () - | Some ty -> closed_type ty - end; - unmark_type_decl decl; - None - with Non_closed (ty, _) -> - unmark_type_decl decl; - Some ty - -let closed_extension_constructor ext = - try - List.iter mark_type ext.ext_type_params; - begin match ext.ext_ret_type with - | Some _ -> () - | None -> iter_type_expr_cstr_args closed_type ext.ext_args - end; - unmark_extension_constructor ext; - None - with Non_closed (ty, _) -> - unmark_extension_constructor ext; - Some ty - -type closed_class_failure = - CC_Method of type_expr * bool * string * type_expr - | CC_Value of type_expr * bool * string * type_expr - -exception CCFailure of closed_class_failure - -let closed_class params sign = - let ty = object_fields (repr sign.csig_self) in - let (fields, rest) = flatten_fields ty in - List.iter mark_type params; - mark_type rest; - List.iter - (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty) - fields; - try - mark_type_node (repr sign.csig_self); - List.iter - (fun (lab, kind, ty) -> - if field_kind_repr kind = Fpresent then - try closed_type ty with Non_closed (ty0, real) -> - raise (CCFailure (CC_Method (ty0, real, lab, ty)))) - fields; - mark_type_params (repr sign.csig_self); - List.iter unmark_type params; - unmark_class_signature sign; - None - with CCFailure reason -> - mark_type_params (repr sign.csig_self); - List.iter unmark_type params; - unmark_class_signature sign; - Some reason - - - (**********************) - (* Type duplication *) - (**********************) - - -(* Duplicate a type, preserving only type variables *) -let duplicate_type ty = - Subst.type_expr Subst.identity ty - -(* Same, for class types *) -let duplicate_class_type ty = - Subst.class_type Subst.identity ty - - - (*****************************) - (* Type level manipulation *) - (*****************************) - -(* - It would be a bit more efficient to remove abbreviation expansions - rather than generalizing them: these expansions will usually not be - used anymore. However, this is not possible in the general case, as - [expand_abbrev] (via [subst]) requires these expansions to be - preserved. Does it worth duplicating this code ? -*) -let rec generalize ty = - let ty = repr ty in - if (ty.level > !current_level) && (ty.level <> generic_level) then begin - set_level ty generic_level; - begin match ty.desc with - Tconstr (_, _, abbrev) -> - iter_abbrev generalize !abbrev - | _ -> () - end; - iter_type_expr generalize ty - end - -let generalize ty = - simple_abbrevs := Mnil; - generalize ty - -(* Generalize the structure and lower the variables *) - -let rec generalize_structure var_level ty = - let ty = repr ty in - if ty.level <> generic_level then begin - if is_Tvar ty && ty.level > var_level then - set_level ty var_level - else if - ty.level > !current_level && - match ty.desc with - Tconstr (p, _, abbrev) -> - not (is_object_type p) && (abbrev := Mnil; true) - | _ -> true - then begin - set_level ty generic_level; - iter_type_expr (generalize_structure var_level) ty - end - end - -let generalize_structure var_level ty = - simple_abbrevs := Mnil; - generalize_structure var_level ty - - -let forward_try_expand_once = (* Forward declaration *) - ref (fun _env _ty -> raise Cannot_expand) - -(* - Lower the levels of a type (assume [level] is not - [generic_level]). -*) -(* - The level of a type constructor must be greater than its binding - time. That way, a type constructor cannot escape the scope of its - definition, as would be the case in - let x = ref [] - module M = struct type t let _ = (x : t list ref) end - (without this constraint, the type system would actually be unsound.) -*) -let get_level env p = - try - match (Env.find_type p env).type_newtype_level with - | None -> Path.binding_time p - | Some (x, _) -> x - with - | Not_found -> - (* no newtypes in predef *) - Path.binding_time p - -let rec normalize_package_path env p = - let t = - try (Env.find_modtype p env).mtd_type - with Not_found -> None - in - match t with - | Some (Mty_ident p) -> normalize_package_path env p - | Some (Mty_signature _ | Mty_functor _ | Mty_alias _) | None -> - match p with - Path.Pdot (p1, s, n) -> - (* For module aliases *) - let p1' = Env.normalize_path None env p1 in - if Path.same p1 p1' then p else - normalize_package_path env (Path.Pdot (p1', s, n)) - | _ -> p - -let rec update_level env level expand ty = - let ty = repr ty in - if ty.level > level then begin - begin match Env.gadt_instance_level env ty with - Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)]) - | None -> () - end; - match ty.desc with - Tconstr(p, _tl, _abbrev) when level < get_level env p -> - (* Try first to replace an abbreviation by its expansion. *) - begin try - (* if is_newtype env p then raise Cannot_expand; *) - link_type ty (!forward_try_expand_once env ty); - update_level env level expand ty - with Cannot_expand -> - (* +++ Levels should be restored... *) - (* Format.printf "update_level: %i < %i@." level (get_level env p); *) - if level < get_level env p then raise (Unify [(ty, newvar2 level)]); - iter_type_expr (update_level env level expand) ty - end - | Tconstr(_, _ :: _, _) when expand -> - begin try - link_type ty (!forward_try_expand_once env ty); - update_level env level expand ty - with Cannot_expand -> - set_level ty level; - iter_type_expr (update_level env level expand) ty - end - | Tpackage (p, nl, tl) when level < Path.binding_time p -> - let p' = normalize_package_path env p in - if Path.same p p' then raise (Unify [(ty, newvar2 level)]); - log_type ty; ty.desc <- Tpackage (p', nl, tl); - update_level env level expand ty - | Tobject(_, ({contents=Some(p, _tl)} as nm)) - when level < get_level env p -> - set_name nm None; - update_level env level expand ty - | Tvariant row -> - let row = row_repr row in - begin match row.row_name with - | Some (p, _tl) when level < get_level env p -> - log_type ty; - ty.desc <- Tvariant {row with row_name = None} - | _ -> () - end; - set_level ty level; - iter_type_expr (update_level env level expand) ty - | Tfield(lab, _, ty1, _) - when lab = dummy_method && (repr ty1).level > level -> - raise (Unify [(ty1, newvar2 level)]) - | _ -> - set_level ty level; - (* XXX what about abbreviations in Tconstr ? *) - iter_type_expr (update_level env level expand) ty - end - -(* First try without expanding, then expand everything, - to avoid combinatorial blow-up *) -let update_level env level ty = - let ty = repr ty in - if ty.level > level then begin - let snap = snapshot () in - try - update_level env level false ty - with Unify _ -> - backtrack snap; - update_level env level true ty - end - -(* Generalize and lower levels of contravariant branches simultaneously *) - -let rec generalize_expansive env var_level visited ty = - let ty = repr ty in - if ty.level = generic_level || ty.level <= var_level then () else - if not (Hashtbl.mem visited ty.id) then begin - Hashtbl.add visited ty.id (); - match ty.desc with - Tconstr (path, tyl, abbrev) -> - let variance = - try (Env.find_type path env).type_variance - with Not_found -> List.map (fun _ -> Variance.may_inv) tyl in - abbrev := Mnil; - List.iter2 - (fun v t -> - if Variance.(mem May_weak v) - then generalize_structure var_level t - else generalize_expansive env var_level visited t) - variance tyl - | Tpackage (_, _, tyl) -> - List.iter (generalize_structure var_level) tyl - | Tarrow (_, t1, t2, _) -> - generalize_structure var_level t1; - generalize_expansive env var_level visited t2 - | _ -> - iter_type_expr (generalize_expansive env var_level visited) ty - end - -let generalize_expansive env ty = - simple_abbrevs := Mnil; - try - generalize_expansive env !nongen_level (Hashtbl.create 7) ty - with Unify ([_, ty'] as tr) -> - raise (Unify ((ty, ty') :: tr)) - -let generalize_global ty = generalize_structure !global_level ty -let generalize_structure ty = generalize_structure !current_level ty - -(* Correct the levels of type [ty]. *) -let correct_levels ty = - duplicate_type ty - -(* Only generalize the type ty0 in ty *) -let limited_generalize ty0 ty = - let ty0 = repr ty0 in - - let graph = Hashtbl.create 17 in - let idx = ref lowest_level in - let roots = ref [] in - - let rec inverse pty ty = - let ty = repr ty in - if (ty.level > !current_level) || (ty.level = generic_level) then begin - decr idx; - Hashtbl.add graph !idx (ty, ref pty); - if (ty.level = generic_level) || (ty == ty0) then - roots := ty :: !roots; - set_level ty !idx; - iter_type_expr (inverse [ty]) ty - end else if ty.level < lowest_level then begin - let (_, parents) = Hashtbl.find graph ty.level in - parents := pty @ !parents - end - - and generalize_parents ty = - let idx = ty.level in - if idx <> generic_level then begin - set_level ty generic_level; - List.iter generalize_parents !(snd (Hashtbl.find graph idx)); - (* Special case for rows: must generalize the row variable *) - match ty.desc with - Tvariant row -> - let more = row_more row in - let lv = more.level in - if (lv < lowest_level || lv > !current_level) - && lv <> generic_level then set_level more generic_level - | _ -> () - end - in - - inverse [] ty; - if ty0.level < lowest_level then - iter_type_expr (inverse []) ty0; - List.iter generalize_parents !roots; - Hashtbl.iter - (fun _ (ty, _) -> - if ty.level <> generic_level then set_level ty !current_level) - graph - - -(* Compute statically the free univars of all nodes in a type *) -(* This avoids doing it repeatedly during instantiation *) - -type inv_type_expr = - { inv_type : type_expr; - mutable inv_parents : inv_type_expr list } - -let rec inv_type hash pty ty = - let ty = repr ty in - try - let inv = TypeHash.find hash ty in - inv.inv_parents <- pty @ inv.inv_parents - with Not_found -> - let inv = { inv_type = ty; inv_parents = pty } in - TypeHash.add hash ty inv; - iter_type_expr (inv_type hash [inv]) ty - -let compute_univars ty = - let inverted = TypeHash.create 17 in - inv_type inverted [] ty; - let node_univars = TypeHash.create 17 in - let rec add_univar univ inv = - match inv.inv_type.desc with - Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () - | _ -> - try - let univs = TypeHash.find node_univars inv.inv_type in - if not (TypeSet.mem univ !univs) then begin - univs := TypeSet.add univ !univs; - List.iter (add_univar univ) inv.inv_parents - end - with Not_found -> - TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ)); - List.iter (add_univar univ) inv.inv_parents - in - TypeHash.iter (fun ty inv -> if is_Tunivar ty then add_univar ty inv) - inverted; - fun ty -> - try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty - - - (*******************) - (* Instantiation *) - (*******************) - - -let rec find_repr p1 = - function - Mnil -> - None - | Mcons (Public, p2, ty, _, _) when Path.same p1 p2 -> - Some ty - | Mcons (_, _, _, _, rem) -> - find_repr p1 rem - | Mlink {contents = rem} -> - find_repr p1 rem - -(* - Generic nodes are duplicated, while non-generic nodes are left - as-is. - During instantiation, the description of a generic node is first - replaced by a link to a stub ([Tsubst (newvar ())]). Once the - copy is made, it replaces the stub. - After instantiation, the description of generic node, which was - stored by [save_desc], must be put back, using [cleanup_types]. -*) - -let abbreviations = ref (ref Mnil) - (* Abbreviation memorized. *) - -(* partial: we may not wish to copy the non generic types - before we call type_pat *) -let rec copy ?env ?partial ?keep_names ty = - let copy = copy ?env ?partial ?keep_names in - let ty = repr ty in - match ty.desc with - Tsubst ty -> ty - | _ -> - if ty.level <> generic_level && partial = None then ty else - (* We only forget types that are non generic and do not contain - free univars *) - let forget = - if ty.level = generic_level then generic_level else - match partial with - None -> assert false - | Some (free_univars, keep) -> - if TypeSet.is_empty (free_univars ty) then - if keep then ty.level else !current_level - else generic_level - in - if forget <> generic_level then newty2 forget (Tvar None) else - let desc = ty.desc in - save_desc ty desc; - let t = newvar() in (* Stub *) - begin match env with - Some env when Env.has_local_constraints env -> - begin match Env.gadt_instance_level env ty with - Some lv -> Env.add_gadt_instances env lv [t] - | None -> () - end - | _ -> () - end; - ty.desc <- Tsubst t; - t.desc <- - begin match desc with - | Tconstr (p, tl, _) -> - let abbrevs = proper_abbrevs p tl !abbreviations in - begin match find_repr p !abbrevs with - Some ty when repr ty != t -> - Tlink ty - | _ -> - (* - One must allocate a new reference, so that abbrevia- - tions belonging to different branches of a type are - independent. - Moreover, a reference containing a [Mcons] must be - shared, so that the memorized expansion of an abbrevi- - ation can be released by changing the content of just - one reference. - *) - Tconstr (p, List.map copy tl, - ref (match !(!abbreviations) with - Mcons _ -> Mlink !abbreviations - | abbrev -> abbrev)) - end - | Tvariant row0 -> - let row = row_repr row0 in - let more = repr row.row_more in - (* We must substitute in a subtle way *) - (* Tsubst takes a tuple containing the row var and the variant *) - begin match more.desc with - Tsubst {desc = Ttuple [_;ty2]} -> - (* This variant type has been already copied *) - ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) - Tlink ty2 - | _ -> - (* If the row variable is not generic, we must keep it *) - let keep = more.level <> generic_level in - let more' = - match more.desc with - Tsubst ty -> ty - | Tconstr _ | Tnil -> - if keep then save_desc more more.desc; - copy more - | Tvar _ | Tunivar _ -> - save_desc more more.desc; - if keep then more else newty more.desc - | _ -> assert false - in - let row = - match repr more' with (* PR#6163 *) - {desc=Tconstr _} when not row.row_fixed -> - {row with row_fixed = true} - | _ -> row - in - (* Open row if partial for pattern and contains Reither *) - let more', row = - match partial with - Some (free_univars, false) -> - let more' = - if more.id != more'.id then more' else - let lv = if keep then more.level else !current_level in - newty2 lv (Tvar None) - in - let not_reither (_, f) = - match row_field_repr f with - Reither _ -> false - | _ -> true - in - if row.row_closed && not row.row_fixed - && TypeSet.is_empty (free_univars ty) - && not (List.for_all not_reither row.row_fields) then - (more', - {row_fields = Ext_list.filter row.row_fields not_reither; - row_more = more'; row_bound = (); - row_closed = false; row_fixed = false; row_name = None}) - else (more', row) - | _ -> (more', row) - in - (* Register new type first for recursion *) - more.desc <- Tsubst(newgenty(Ttuple[more';t])); - (* Return a new copy *) - Tvariant (copy_row copy true row keep more') - end - | Tfield (_p, k, _ty1, ty2) -> - begin match field_kind_repr k with - Fabsent -> Tlink (copy ty2) - | Fpresent -> copy_type_desc copy desc - | Fvar r -> - dup_kind r; - copy_type_desc copy desc - end - | Tobject (ty1, _) when partial <> None -> - Tobject (copy ty1, ref None) - | _ -> copy_type_desc ?keep_names copy desc - end; - t - -let simple_copy t = copy t - -(**** Variants of instantiations ****) - -let gadt_env env = - if Env.has_local_constraints env - then Some env - else None - -let instance ?partial env sch = - let env = gadt_env env in - let partial = - match partial with - None -> None - | Some keep -> Some (compute_univars sch, keep) - in - let ty = copy ?env ?partial sch in - cleanup_types (); - ty - -let instance_def sch = - let ty = copy sch in - cleanup_types (); - ty - -let generic_instance env sch = - let old = !current_level in - current_level := generic_level; - let ty = instance env sch in - current_level := old; - ty - -let instance_list env schl = - let env = gadt_env env in - let tyl = List.map (fun t -> copy ?env t) schl in - cleanup_types (); - tyl - -let reified_var_counter = ref Vars.empty -let reset_reified_var_counter () = - reified_var_counter := Vars.empty - -(* names given to new type constructors. - Used for existential types and - local constraints *) -let get_new_abstract_name s = - let index = - try Vars.find s !reified_var_counter + 1 - with Not_found -> 0 in - reified_var_counter := Vars.add s index !reified_var_counter; - if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else - Printf.sprintf "%s%d" s index - -let new_declaration newtype manifest = - { - type_params = []; - type_arity = 0; - type_kind = Type_abstract; - type_private = Public; - type_manifest = manifest; - type_variance = []; - type_newtype_level = newtype; - type_loc = Location.none; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - -let instance_constructor ?in_pattern cstr = - begin match in_pattern with - | None -> () - | Some (env, newtype_lev) -> - let process existential = - let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in - let name = - match repr existential with - {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name - | _ -> "$" ^ cstr.cstr_name - in - let path = Path.Pident (Ident.create (get_new_abstract_name name)) in - let new_env = Env.add_local_type path decl !env in - env := new_env; - let to_unify = newty (Tconstr (path,[],ref Mnil)) in - let tv = copy existential in - assert (is_Tvar tv); - link_type tv to_unify - in - List.iter process cstr.cstr_existentials - end; - let ty_res = copy cstr.cstr_res in - let ty_args = List.map simple_copy cstr.cstr_args in - cleanup_types (); - (ty_args, ty_res) - -let instance_parameterized_type ?keep_names sch_args sch = - let ty_args = List.map (fun t -> copy ?keep_names t) sch_args in - let ty = copy sch in - cleanup_types (); - (ty_args, ty) - -let instance_parameterized_type_2 sch_args sch_lst sch = - let ty_args = List.map simple_copy sch_args in - let ty_lst = List.map simple_copy sch_lst in - let ty = copy sch in - cleanup_types (); - (ty_args, ty_lst, ty) - -let map_kind f = function - | Type_abstract -> Type_abstract - | Type_open -> Type_open - | Type_variant cl -> - Type_variant ( - List.map - (fun c -> - {c with - cd_args = map_type_expr_cstr_args f c.cd_args; - cd_res = may_map f c.cd_res - }) - cl) - | Type_record (fl, rr) -> - Type_record ( - List.map - (fun l -> - {l with ld_type = f l.ld_type} - ) fl, rr) - - -let instance_declaration decl = - let decl = - {decl with type_params = List.map simple_copy decl.type_params; - type_manifest = may_map simple_copy decl.type_manifest; - type_kind = map_kind simple_copy decl.type_kind; - } - in - cleanup_types (); - decl - -let instance_class params cty = - let rec copy_class_type = - function - Cty_constr (path, tyl, cty) -> - Cty_constr (path, List.map simple_copy tyl, copy_class_type cty) - | Cty_signature sign -> - Cty_signature - {csig_self = copy sign.csig_self; - csig_vars = - Vars.map (function (m, v, ty) -> (m, v, copy ty)) sign.csig_vars; - csig_concr = sign.csig_concr; - csig_inher = - List.map (fun (p,tl) -> (p, List.map simple_copy tl)) - sign.csig_inher} - | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, copy ty, copy_class_type cty) - in - let params' = List.map simple_copy params in - let cty' = copy_class_type cty in - cleanup_types (); - (params', cty') - -(**** Instantiation for types with free universal variables ****) - -let rec diff_list l1 l2 = - if l1 == l2 then [] else - match l1 with [] -> invalid_arg "Ctype.diff_list" - | a :: l1 -> a :: diff_list l1 l2 - -let conflicts free bound = - let bound = List.map repr bound in - TypeSet.exists (fun t -> List.memq (repr t) bound) free - -let delayed_copy = ref [] - (* copying to do later *) - -(* Copy without sharing until there are no free univars left *) -(* all free univars must be included in [visited] *) -let rec copy_sep fixed free bound visited ty = - let ty = repr ty in - let univars = free ty in - if TypeSet.is_empty univars then - if ty.level <> generic_level then ty else - let t = newvar () in - delayed_copy := - lazy (t.desc <- Tlink (copy ty)) - :: !delayed_copy; - t - else try - let t, bound_t = List.assq ty visited in - let dl = if is_Tunivar ty then [] else diff_list bound bound_t in - if dl <> [] && conflicts univars dl then raise Not_found; - t - with Not_found -> begin - let t = newvar() in (* Stub *) - let visited = - match ty.desc with - Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ -> - (ty,(t,bound)) :: visited - | _ -> visited in - let copy_rec = copy_sep fixed free bound visited in - t.desc <- - begin match ty.desc with - | Tvariant row0 -> - let row = row_repr row0 in - let more = repr row.row_more in - (* We shall really check the level on the row variable *) - let keep = is_Tvar more && more.level <> generic_level in - let more' = copy_rec more in - let fixed' = fixed && is_Tvar (repr more') in - let row = copy_row copy_rec fixed' row keep more' in - Tvariant row - | Tpoly (t1, tl) -> - let tl = List.map repr tl in - let tl' = List.map (fun t -> newty t.desc) tl in - let bound = tl @ bound in - let visited = - List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in - Tpoly (copy_sep fixed free bound visited t1, tl') - | _ -> copy_type_desc copy_rec ty.desc - end; - t - end - -let instance_poly ?(keep_names=false) fixed univars sch = - let univars = List.map repr univars in - let copy_var ty = - match ty.desc with - Tunivar name -> if keep_names then newty (Tvar name) else newvar () - | _ -> assert false - in - let vars = List.map copy_var univars in - let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in - delayed_copy := []; - let ty = copy_sep fixed (compute_univars sch) [] pairs sch in - List.iter Lazy.force !delayed_copy; - delayed_copy := []; - cleanup_types (); - vars, ty - -let instance_label fixed lbl = - let ty_res = copy lbl.lbl_res in - let vars, ty_arg = - match repr lbl.lbl_arg with - {desc = Tpoly (ty, tl)} -> - instance_poly fixed tl ty - | _ -> - [], copy lbl.lbl_arg - in - cleanup_types (); - (vars, ty_arg, ty_res) - -(**** Instantiation with parameter substitution ****) - -let unify' = (* Forward declaration *) - ref (fun _env _ty1 _ty2 -> raise (Unify [])) - -let subst env level priv abbrev ty params args body = - if List.length params <> List.length args then raise (Unify []); - let old_level = !current_level in - current_level := level; - try - let body0 = newvar () in (* Stub *) - begin match ty with - None -> () - | Some ({desc = Tconstr (path, tl, _)} as ty) -> - let abbrev = proper_abbrevs path tl abbrev in - memorize_abbrev abbrev priv path ty body0 - | _ -> - assert false - end; - abbreviations := abbrev; - let (params', body') = instance_parameterized_type params body in - abbreviations := ref Mnil; - !unify' env body0 body'; - List.iter2 (!unify' env) params' args; - current_level := old_level; - body' - with Unify _ as exn -> - current_level := old_level; - raise exn - -(* - Only the shape of the type matters, not whether it is generic or - not. [generic_level] might be somewhat slower, but it ensures - invariants on types are enforced (decreasing levels), and we don't - care about efficiency here. -*) -let apply env params body args = - try - subst env generic_level Public (ref Mnil) None params args body - with - Unify _ -> raise Cannot_apply - -let () = Subst.ctype_apply_env_empty := apply Env.empty - - (****************************) - (* Abbreviation expansion *) - (****************************) - -(* - If the environment has changed, memorized expansions might not - be correct anymore, and so we flush the cache. This is safe but - quite pessimistic: it would be enough to flush the cache when a - type or module definition is overridden in the environment. -*) -let previous_env = ref Env.empty -(*let string_of_kind = function Public -> "public" | Private -> "private"*) -let check_abbrev_env env = - if env != !previous_env then begin - (* prerr_endline "cleanup expansion cache"; *) - cleanup_abbrev (); - previous_env := env - end - - -(* Expand an abbreviation. The expansion is memorized. *) -(* - Assume the level is greater than the path binding time of the - expanded abbreviation. -*) -(* - An abbreviation expansion will fail in either of these cases: - 1. The type constructor does not correspond to a manifest type. - 2. The type constructor is defined in an external file, and this - file is not in the path (missing -I options). - 3. The type constructor is not in the "local" environment. This can - happens when a non-generic type variable has been instantiated - afterwards to the not yet defined type constructor. (Actually, - this cannot happen at the moment due to the strong constraints - between type levels and constructor binding time.) - 4. The expansion requires the expansion of another abbreviation, - and this other expansion fails. -*) -let expand_abbrev_gen kind find_type_expansion env ty = - check_abbrev_env env; - match ty with - {desc = Tconstr (path, args, abbrev); level = level} -> - let lookup_abbrev = proper_abbrevs path args abbrev in - begin match find_expans kind path !lookup_abbrev with - Some ty' -> - (* prerr_endline - ("found a "^string_of_kind kind^" expansion for "^Path.name path);*) - if level <> generic_level then - begin try - update_level env level ty' - with Unify _ -> - (* XXX This should not happen. - However, levels are not correctly restored after a - typing error *) - () - end; - let ty' = repr ty' in - (* assert (ty != ty'); *) (* PR#7324 *) - ty' - | None -> - match find_type_expansion path env with - | exception Not_found -> - (* another way to expand is to normalize the path itself *) - let path' = Env.normalize_path None env path in - if Path.same path path' then raise Cannot_expand - else newty2 level (Tconstr (path', args, abbrev)) - | (params, body, lv) -> - (* prerr_endline - ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) - let ty' = subst env level kind abbrev (Some ty) params args body in - (* For gadts, remember type as non exportable *) - (* The ambiguous level registered for ty' should be the highest *) - if !trace_gadt_instances then begin - match Ext_pervasives.max_int_option lv (Env.gadt_instance_level env ty) with - None -> () - | Some lv -> - if level < lv then raise (Unify [(ty, newvar2 level)]); - Env.add_gadt_instances env lv [ty; ty'] - end; - ty' - end - | _ -> - assert false - -(* Expand respecting privacy *) -let expand_abbrev env ty = - expand_abbrev_gen Public Env.find_type_expansion env ty - -(* Expand once the head of a type *) -let expand_head_once env ty = - try expand_abbrev env (repr ty) with Cannot_expand -> assert false - -(* Check whether a type can be expanded *) -let safe_abbrev env ty = - let snap = Btype.snapshot () in - try ignore (expand_abbrev env ty); true - with Cannot_expand | Unify _ -> - Btype.backtrack snap; - false - -(* Expand the head of a type once. - Raise Cannot_expand if the type cannot be expanded. - May raise Unify, if a recursion was hidden in the type. *) -let try_expand_once env ty = - let ty = repr ty in - match ty.desc with - Tconstr _ -> repr (expand_abbrev env ty) - | _ -> raise Cannot_expand - -(* This one only raises Cannot_expand *) -let try_expand_safe env ty = - let snap = Btype.snapshot () in - try try_expand_once env ty - with Unify _ -> - Btype.backtrack snap; raise Cannot_expand - -(* Fully expand the head of a type. *) -let rec try_expand_head try_once env ty = - let ty' = try_once env ty in - try try_expand_head try_once env ty' - with Cannot_expand -> ty' - -let try_expand_head try_once env ty = - let ty' = try_expand_head try_once env ty in - begin match Env.gadt_instance_level env ty' with - None -> () - | Some lv -> Env.add_gadt_instance_chain env lv ty - end; - ty' - -(* Unsafe full expansion, may raise Unify. *) -let expand_head_unif env ty = - try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty - -(* Safe version of expand_head, never fails *) -let expand_head env ty = - try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty - -let _ = forward_try_expand_once := try_expand_safe - - -(* Expand until we find a non-abstract type declaration *) - -let rec extract_concrete_typedecl env ty = - let ty = repr ty in - match ty.desc with - Tconstr (p, _, _) -> - let decl = Env.find_type p env in - if decl.type_kind <> Type_abstract then (p, p, decl) else - let ty = - try try_expand_once env ty with Cannot_expand -> raise Not_found - in - let (_, p', decl) = extract_concrete_typedecl env ty in - (p, p', decl) - | _ -> raise Not_found - -(* Implementing function [expand_head_opt], the compiler's own version of - [expand_head] used for type-based optimisations. - [expand_head_opt] uses [Env.find_type_expansion_opt] to access the - manifest type information of private abstract data types which is - normally hidden to the type-checker out of the implementation module of - the private abbreviation. *) - -let expand_abbrev_opt = - expand_abbrev_gen Private Env.find_type_expansion_opt - -let try_expand_once_opt env ty = - let ty = repr ty in - match ty.desc with - Tconstr _ -> repr (expand_abbrev_opt env ty) - | _ -> raise Cannot_expand - -let rec try_expand_head_opt env ty = - let ty' = try_expand_once_opt env ty in - begin try - try_expand_head_opt env ty' - with Cannot_expand -> - ty' - end - -let expand_head_opt env ty = - let snap = Btype.snapshot () in - try try_expand_head_opt env ty - with Cannot_expand | Unify _ -> (* expand_head shall never fail *) - Btype.backtrack snap; - repr ty - -(* Make sure that the type parameters of the type constructor [ty] - respect the type constraints *) -let enforce_constraints env ty = - match ty with - {desc = Tconstr (path, args, _abbrev); level = level} -> - begin try - let decl = Env.find_type path env in - ignore - (subst env level Public (ref Mnil) None decl.type_params args - (newvar2 level)) - with Not_found -> () - end - | _ -> - assert false - -(* Recursively expand the head of a type. - Also expand #-types. *) -let full_expand env ty = - let ty = repr (expand_head env ty) in - match ty.desc with - Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) -> - newty2 ty.level (Tobject (fi, ref None)) - | _ -> - ty - -(* - Check whether the abbreviation expands to a well-defined type. - During the typing of a class, abbreviations for correspondings - types expand to non-generic types. -*) -let generic_abbrev env path = - try - let (_, body, _) = Env.find_type_expansion path env in - (repr body).level = generic_level - with - Not_found -> - false - -let generic_private_abbrev env path = - try - match Env.find_type path env with - {type_kind = Type_abstract; - type_private = Private; - type_manifest = Some body} -> - (repr body).level = generic_level - | _ -> false - with Not_found -> false - -let is_contractive env p = - try - let decl = Env.find_type p env in - in_pervasives p && decl.type_manifest = None || is_datatype decl - with Not_found -> false - - - (*****************) - (* Occur check *) - (*****************) - - -exception Occur - -let rec occur_rec env allow_recursive visited ty0 = function - | {desc=Tlink ty} -> - occur_rec env allow_recursive visited ty0 ty - | ty -> - if ty == ty0 then raise Occur; - match ty.desc with - Tconstr(p, _tl, _abbrev) -> - if allow_recursive && is_contractive env p then () else - begin try - if TypeSet.mem ty visited then raise Occur; - let visited = TypeSet.add ty visited in - iter_type_expr (occur_rec env allow_recursive visited ty0) ty - with Occur -> try - let ty' = try_expand_head try_expand_once env ty in - (* This call used to be inlined, but there seems no reason for it. - Message was referring to change in rev. 1.58 of the CVS repo. *) - occur_rec env allow_recursive visited ty0 ty' - with Cannot_expand -> - raise Occur - end - | Tobject _ | Tvariant _ -> - () - | _ -> - if allow_recursive || TypeSet.mem ty visited then () else begin - let visited = TypeSet.add ty visited in - iter_type_expr (occur_rec env allow_recursive visited ty0) ty - end - -let type_changed = ref false (* trace possible changes to the studied type *) - -let merge r b = if b then r := true - -let occur env ty0 ty = - let allow_recursive = (*!Clflags.recursive_types ||*) !umode = Pattern in - let old = !type_changed in - try - while - type_changed := false; - occur_rec env allow_recursive TypeSet.empty ty0 ty; - !type_changed - do () (* prerr_endline "changed" *) done; - merge type_changed old - with exn -> - merge type_changed old; - raise (match exn with Occur -> Unify [] | _ -> exn) - -let occur_in env ty0 t = - try occur env ty0 t; false with Unify _ -> true - -(* Check that a local constraint is well-founded *) -(* PR#6405: not needed since we allow recursion and work on normalized types *) -(* PR#6992: we actually need it for contractiveness *) -(* This is a simplified version of occur, only for the rectypes case *) - -let rec local_non_recursive_abbrev strict visited env p ty = - (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*) - let ty = repr ty in - if not (List.memq ty visited) then begin - match ty.desc with - Tconstr(p', args, _abbrev) -> - if Path.same p p' then raise Occur; - if not strict && is_contractive env p' then () else - let visited = ty :: visited in - begin try - (* try expanding, since [p] could be hidden *) - local_non_recursive_abbrev strict visited env p - (try_expand_head try_expand_once env ty) - with Cannot_expand -> - let params = - try (Env.find_type p' env).type_params - with Not_found -> args - in - List.iter2 - (fun tv ty -> - let strict = strict || not (is_Tvar (repr tv)) in - local_non_recursive_abbrev strict visited env p ty) - params args - end - | _ -> - if strict then (* PR#7374 *) - let visited = ty :: visited in - iter_type_expr (local_non_recursive_abbrev true visited env p) ty - end - -let local_non_recursive_abbrev env p ty = - try (* PR#7397: need to check trace_gadt_instances *) - wrap_trace_gadt_instances env - (local_non_recursive_abbrev false [] env p) ty; - true - with Occur -> false - - - (*****************************) - (* Polymorphic Unification *) - (*****************************) - -(* Since we cannot duplicate universal variables, unification must - be done at meta-level, using bindings in univar_pairs *) -let rec unify_univar t1 t2 = function - (cl1, cl2) :: rem -> - let find_univ t cl = - try - let (_, r) = List.find (fun (t',_) -> t == repr t') cl in - Some r - with Not_found -> None - in - begin match find_univ t1 cl1, find_univ t2 cl2 with - Some {contents=Some t'2}, Some _ when t2 == repr t'2 -> - () - | Some({contents=None} as r1), Some({contents=None} as r2) -> - set_univar r1 t2; set_univar r2 t1 - | None, None -> - unify_univar t1 t2 rem - | _ -> - raise (Unify []) - end - | [] -> raise (Unify []) - -(* Test the occurrence of free univars in a type *) -(* that's way too expensive. Must do some kind of caching *) -let occur_univar env ty = - let visited = ref TypeMap.empty in - let rec occur_rec bound ty = - let ty = repr ty in - if ty.level >= lowest_level && - if TypeSet.is_empty bound then - (ty.level <- pivot_level - ty.level; true) - else try - let bound' = TypeMap.find ty !visited in - if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then - (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; - true) - else false - with Not_found -> - visited := TypeMap.add ty bound !visited; - true - then - match ty.desc with - Tunivar _ -> - if not (TypeSet.mem ty bound) then raise (Unify [ty, newgenvar ()]) - | Tpoly (ty, tyl) -> - let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in - occur_rec bound ty - | Tconstr (_, [], _) -> () - | Tconstr (p, tl, _) -> - begin try - let td = Env.find_type p env in - List.iter2 - (fun t v -> - if Variance.(mem May_pos v || mem May_neg v) - then occur_rec bound t) - tl td.type_variance - with Not_found -> - List.iter (occur_rec bound) tl - end - | _ -> iter_type_expr (occur_rec bound) ty - in - try - occur_rec TypeSet.empty ty; unmark_type ty - with exn -> - unmark_type ty; raise exn - -(* Grouping univars by families according to their binders *) -let add_univars = - List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s) - -let get_univar_family univar_pairs univars = - if univars = [] then TypeSet.empty else - let insert s = function - cl1, (_::_ as cl2) -> - if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then - add_univars s cl2 - else s - | _ -> s - in - let s = List.fold_right TypeSet.add univars TypeSet.empty in - List.fold_left insert s univar_pairs - -(* Whether a family of univars escapes from a type *) -let univars_escape env univar_pairs vl ty = - let family = get_univar_family univar_pairs vl in - let visited = ref TypeSet.empty in - let rec occur t = - let t = repr t in - if TypeSet.mem t !visited then () else begin - visited := TypeSet.add t !visited; - match t.desc with - Tpoly (t, tl) -> - if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () - else occur t - | Tunivar _ -> - if TypeSet.mem t family then raise Occur - | Tconstr (_, [], _) -> () - | Tconstr (p, tl, _) -> - begin try - let td = Env.find_type p env in - List.iter2 - (fun t v -> - if Variance.(mem May_pos v || mem May_neg v) then occur t) - tl td.type_variance - with Not_found -> - List.iter occur tl - end - | _ -> - iter_type_expr occur t - end - in - try occur ty; false with Occur -> true - -(* Wrapper checking that no variable escapes and updating univar_pairs *) -let enter_poly env univar_pairs t1 tl1 t2 tl2 f = - let old_univars = !univar_pairs in - let known_univars = - List.fold_left (fun s (cl,_) -> add_univars s cl) - TypeSet.empty old_univars - in - let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in - if List.exists (fun t -> TypeSet.mem t known_univars) tl1 && - univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2))) - || List.exists (fun t -> TypeSet.mem t known_univars) tl2 && - univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1))) - then raise (Unify []); - let cl1 = List.map (fun t -> t, ref None) tl1 - and cl2 = List.map (fun t -> t, ref None) tl2 in - univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars; - try let res = f t1 t2 in univar_pairs := old_univars; res - with exn -> univar_pairs := old_univars; raise exn - -let univar_pairs = ref [] - - - (*****************) - (* Unification *) - (*****************) - - - -let rec has_cached_expansion p abbrev = - match abbrev with - Mnil -> false - | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem - | Mlink rem -> has_cached_expansion p !rem - -(**** Transform error trace ****) -(* +++ Move it to some other place ? *) - -let expand_trace env trace = - List.fold_right - (fun (t1, t2) rem -> - (repr t1, full_expand env t1)::(repr t2, full_expand env t2)::rem) - trace [] - -(* build a dummy variant type *) -let mkvariant fields closed = - newgenty - (Tvariant - {row_fields = fields; row_closed = closed; row_more = newvar(); - row_bound = (); row_fixed = false; row_name = None }) - -(**** Unification ****) - -(* Return whether [t0] occurs in [ty]. Objects are also traversed. *) -let deep_occur t0 ty = - let rec occur_rec ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - if ty == t0 then raise Occur; - ty.level <- pivot_level - ty.level; - iter_type_expr occur_rec ty - end - in - try - occur_rec ty; unmark_type ty; false - with Occur -> - unmark_type ty; true - -(* - 1. When unifying two non-abbreviated types, one type is made a link - to the other. When unifying an abbreviated type with a - non-abbreviated type, the non-abbreviated type is made a link to - the other one. When unifying to abbreviated types, these two - types are kept distincts, but they are made to (temporally) - expand to the same type. - 2. Abbreviations with at least one parameter are systematically - expanded. The overhead does not seem too high, and that way - abbreviations where some parameters does not appear in the - expansion, such as ['a t = int], are correctly handled. In - particular, for this example, unifying ['a t] with ['b t] keeps - ['a] and ['b] distincts. (Is it really important ?) - 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield - ['a t as 'a]. Indeed, the type variable would otherwise be lost. - This problem occurs for abbreviations expanding to a type - variable, but also to many other constrained abbreviations (for - instance, [(< x : 'a > -> unit) t = ]). The solution is - that, if an abbreviation is unified with some subpart of its - parameters, then the parameter actually does not get - abbreviated. It would be possible to check whether some - information is indeed lost, but it probably does not worth it. -*) - -let newtype_level = ref None - -let get_newtype_level () = - match !newtype_level with - | None -> assert false - | Some x -> x - -(* a local constraint can be added only if the rhs - of the constraint does not contain any Tvars. - They need to be removed using this function *) -let reify env t = - let newtype_level = get_newtype_level () in - let create_fresh_constr lev name = - let decl = new_declaration (Some (newtype_level, newtype_level)) None in - let name = match name with Some s -> "$'"^s | _ -> "$" in - let path = Path.Pident (Ident.create (get_new_abstract_name name)) in - let new_env = Env.add_local_type path decl !env in - let t = newty2 lev (Tconstr (path,[],ref Mnil)) in - env := new_env; - t - in - let visited = ref TypeSet.empty in - let rec iterator ty = - let ty = repr ty in - if TypeSet.mem ty !visited then () else begin - visited := TypeSet.add ty !visited; - match ty.desc with - Tvar o -> - let t = create_fresh_constr ty.level o in - link_type ty t; - if ty.level < newtype_level then - raise (Unify [t, newvar2 ty.level]) - | Tvariant r -> - let r = row_repr r in - if not (static_row r) then begin - if r.row_fixed then iterator (row_more r) else - let m = r.row_more in - match m.desc with - Tvar o -> - let t = create_fresh_constr m.level o in - let row = - {r with row_fields=[]; row_fixed=true; row_more = t} in - link_type m (newty2 m.level (Tvariant row)); - if m.level < newtype_level then - raise (Unify [t, newvar2 m.level]) - | _ -> assert false - end; - iter_row iterator r - | Tconstr (p, _, _) when is_object_type p -> - iter_type_expr iterator (full_expand !env ty) - | _ -> - iter_type_expr iterator ty - end - in - iterator t - -let is_newtype env p = - try - let decl = Env.find_type p env in - decl.type_newtype_level <> None && - decl.type_kind = Type_abstract && - decl.type_private = Public - with Not_found -> false - -let non_aliasable p decl = - (* in_pervasives p || (subsumed by in_current_module) *) - in_current_module p && decl.type_newtype_level = None - -let is_instantiable env p = - try - let decl = Env.find_type p env in - decl.type_kind = Type_abstract && - decl.type_private = Public && - decl.type_arity = 0 && - decl.type_manifest = None && - not (non_aliasable p decl) - with Not_found -> false - - -(* PR#7113: -safe-string should be a global property *) -let compatible_paths p1 p2 = - let open Predef in - Path.same p1 p2 || - Path.same p1 path_bytes && Path.same p2 path_string || - Path.same p1 path_string && Path.same p2 path_bytes - -(* Check for datatypes carefully; see PR#6348 *) -let rec expands_to_datatype env ty = - let ty = repr ty in - match ty.desc with - Tconstr (p, _, _) -> - begin try - is_datatype (Env.find_type p env) || - expands_to_datatype env (try_expand_once env ty) - with Not_found | Cannot_expand -> false - end - | _ -> false - -(* mcomp type_pairs subst env t1 t2 does not raise an - exception if it is possible that t1 and t2 are actually - equal, assuming the types in type_pairs are equal and - that the mapping subst holds. - Assumes that both t1 and t2 do not contain any tvars - and that both their objects and variants are closed - *) - -let rec mcomp type_pairs env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else - match (t1.desc, t2.desc) with - | (Tvar _, _) - | (_, Tvar _) -> - () - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> - () - | _ -> - let t1' = expand_head_opt env t1 in - let t2' = expand_head_opt env t2 in - (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else - begin try TypePairs.find type_pairs (t1', t2') - with Not_found -> - TypePairs.add type_pairs (t1', t2') (); - match (t1'.desc, t2'.desc) with - (Tvar _, Tvar _) -> assert false - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) - when Asttypes.same_arg_label l1 l2 || not (is_optional l1 || is_optional l2) -> - mcomp type_pairs env t1 t2; - mcomp type_pairs env u1 u2; - | (Ttuple tl1, Ttuple tl2) -> - mcomp_list type_pairs env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> - mcomp_type_decl type_pairs env p1 p2 tl1 tl2 - | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> - begin try - let decl = Env.find_type p env in - if non_aliasable p decl || is_datatype decl then raise (Unify []) - with Not_found -> () - end - (* - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when n1 = n2 -> - mcomp_list type_pairs env tl1 tl2 - *) - | (Tpackage _, Tpackage _) -> () - | (Tvariant row1, Tvariant row2) -> - mcomp_row type_pairs env row1 row2 - | (Tobject (fi1, _), Tobject (fi2, _)) -> - mcomp_fields type_pairs env fi1 fi2 - | (Tfield _, Tfield _) -> (* Actually unused *) - mcomp_fields type_pairs env t1' t2' - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - mcomp type_pairs env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (mcomp type_pairs env) - | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs - | (_, _) -> - raise (Unify []) - end - -and mcomp_list type_pairs env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); - List.iter2 (mcomp type_pairs env) tl1 tl2 - -and mcomp_fields type_pairs env ty1 ty2 = - if not (concrete_object ty1 && concrete_object ty2) then assert false; - let (fields2, rest2) = flatten_fields ty2 in - let (fields1, rest1) = flatten_fields ty1 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let has_present = - List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in - mcomp type_pairs env rest1 rest2; - if has_present miss1 && (object_row ty2).desc = Tnil - || has_present miss2 && (object_row ty1).desc = Tnil then raise (Unify []); - List.iter - (function (_n, k1, t1, k2, t2) -> - mcomp_kind k1 k2; - mcomp type_pairs env t1 t2) - pairs - -and mcomp_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - match k1, k2 with - (Fpresent, Fabsent) - | (Fabsent, Fpresent) -> raise (Unify []) - | _ -> () - -and mcomp_row type_pairs env row1 row2 = - let row1 = row_repr row1 and row2 = row_repr row2 in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - let cannot_erase (_,f) = - match row_field_repr f with - Rpresent _ -> true - | Rabsent | Reither _ -> false - in - if row1.row_closed && List.exists cannot_erase r2 - || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []); - List.iter - (fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent) - | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent) - | (Reither (_, _::_, _, _) | Rabsent), Rpresent None - | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) -> - raise (Unify []) - | Rpresent(Some t1), Rpresent(Some t2) -> - mcomp type_pairs env t1 t2 - | Rpresent(Some t1), Reither(false, tl2, _, _) -> - List.iter (mcomp type_pairs env t1) tl2 - | Reither(false, tl1, _, _), Rpresent(Some t2) -> - List.iter (mcomp type_pairs env t2) tl1 - | _ -> ()) - pairs - -and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = - try - let decl = Env.find_type p1 env in - let decl' = Env.find_type p2 env in - if compatible_paths p1 p2 then begin - let inj = - try List.map Variance.(mem Inj) (Env.find_type p1 env).type_variance - with Not_found -> List.map (fun _ -> false) tl1 - in - List.iter2 - (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) - inj (List.combine tl1 tl2) - end else if non_aliasable p1 decl && non_aliasable p2 decl' then - raise (Unify []) - else - match decl.type_kind, decl'.type_kind with - | Type_record (lst,r), Type_record (lst',r') when Types.same_record_representation r r' -> - mcomp_list type_pairs env tl1 tl2; - mcomp_record_description type_pairs env lst lst' - | Type_variant v1, Type_variant v2 -> - mcomp_list type_pairs env tl1 tl2; - mcomp_variant_description type_pairs env v1 v2 - | Type_open, Type_open -> - mcomp_list type_pairs env tl1 tl2 - | Type_abstract, Type_abstract -> () - | Type_abstract, _ when not (non_aliasable p1 decl)-> () - | _, Type_abstract when not (non_aliasable p2 decl') -> () - | _ -> raise (Unify []) - with Not_found -> () - -and mcomp_type_option type_pairs env t t' = - match t, t' with - None, None -> () - | Some t, Some t' -> mcomp type_pairs env t t' - | _ -> raise (Unify []) - -and mcomp_variant_description type_pairs env xs ys = - let rec iter = fun x y -> - match x, y with - | c1 :: xs, c2 :: ys -> - mcomp_type_option type_pairs env c1.cd_res c2.cd_res; - begin match c1.cd_args, c2.cd_args with - | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 - | Cstr_record l1, Cstr_record l2 -> - mcomp_record_description type_pairs env l1 l2 - | _ -> raise (Unify []) - end; - if Ident.name c1.cd_id = Ident.name c2.cd_id - then iter xs ys - else raise (Unify []) - | [],[] -> () - | _ -> raise (Unify []) - in - iter xs ys - -and mcomp_record_description type_pairs env = - let rec iter x y = - match x, y with - | l1 :: xs, l2 :: ys -> - mcomp type_pairs env l1.ld_type l2.ld_type; - if Ident.name l1.ld_id = Ident.name l2.ld_id && - l1.ld_mutable = l2.ld_mutable - then iter xs ys - else raise (Unify []) - | [], [] -> () - | _ -> raise (Unify []) - in - iter - -let mcomp env t1 t2 = - mcomp (TypePairs.create 4) env t1 t2 - -(* Real unification *) - - -let find_newtype_level env path = - try match (Env.find_type path env).type_newtype_level with - Some x -> x - | None -> raise Not_found - with Not_found -> let lev = Path.binding_time path in (lev, lev) - -let add_gadt_equation env source destination = - if local_non_recursive_abbrev !env source destination then begin - let destination = duplicate_type destination in - let source_lev = find_newtype_level !env source in - let decl = new_declaration (Some source_lev) (Some destination) in - let newtype_level = get_newtype_level () in - env := Env.add_local_constraint source decl newtype_level !env; - cleanup_abbrev () - end - -let unify_eq_set = TypePairs.create 11 - -let order_type_pair t1 t2 = - if t1.id <= t2.id then (t1, t2) else (t2, t1) - -let add_type_equality t1 t2 = - TypePairs.add unify_eq_set (order_type_pair t1 t2) () - -let eq_package_path env p1 p2 = - Path.same p1 p2 || - Path.same (normalize_package_path env p1) (normalize_package_path env p2) - -let nondep_type' = ref (fun _ _ _ -> assert false) -let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false) - -let rec concat_longident lid1 = - let open Longident in - function - Lident s -> Ldot (lid1, s) - | Ldot (lid2, s) -> Ldot (concat_longident lid1 lid2, s) - | Lapply (lid2, lid) -> Lapply (concat_longident lid1 lid2, lid) - -let nondep_instance env level id ty = - let ty = !nondep_type' env id ty in - if level = generic_level then duplicate_type ty else - let old = !current_level in - current_level := level; - let ty = instance env ty in - current_level := old; - ty - -(* Find the type paths nl1 in the module type mty2, and add them to the - list (nl2, tl2). raise Not_found if impossible *) -let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = - let id2 = Ident.create "Pkg" in - let env' = Env.add_module id2 mty2 env in - let rec complete nl1 ntl2 = - match nl1, ntl2 with - [], _ -> ntl2 - | n :: nl, (n2, _ as nt2) :: ntl' when Longident.cmp n n2 >= 0 -> - nt2 :: complete (if Longident.cmp n n2 = 0 then nl else nl1) ntl' - | n :: nl, _ -> - try - let path = - Env.lookup_type (concat_longident (Longident.Lident "Pkg") n) env' - in - match Env.find_type path env' with - {type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = Some t2} -> - (n, nondep_instance env' lv2 id2 t2) :: complete nl ntl2 - | {type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = None} when allow_absent -> - complete nl ntl2 - | _ -> raise Exit - with - | Not_found when allow_absent -> complete nl ntl2 - | Exit -> raise Not_found - in - complete nl1 (List.combine nl2 tl2) - -(* raise Not_found rather than Unify if the module types are incompatible *) -let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = - let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2 - and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in - unify_list (List.map snd ntl1) (List.map snd ntl2); - if eq_package_path env p1 p2 - || !package_subtype env p1 n1 tl1 p2 n2 tl2 - && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found - - -(* force unification in Reither when one side has a non-conjunctive type *) -let rigid_variants = ref false - -(* drop not force unification in Reither, even in fixed case - (not sound, only use it when checking exhaustiveness) *) -let passive_variants = ref false -let with_passive_variants f x = - if !passive_variants then f x else - match passive_variants := true; f x with - | r -> passive_variants := false; r - | exception e -> passive_variants := false; raise e - -let unify_eq t1 t2 = - t1 == t2 || - match !umode with - | Expression -> false - | Pattern -> - try TypePairs.find unify_eq_set (order_type_pair t1 t2); true - with Not_found -> false - -let unify1_var env t1 t2 = - assert (is_Tvar t1); - occur env t1 t2; - occur_univar env t2; - let d1 = t1.desc in - link_type t1 t2; - try - update_level env t1.level t2 - with Unify _ as e -> - t1.desc <- d1; - raise e - -let rec unify (env:Env.t ref) t1 t2 = - (* First step: special cases (optimizations) *) - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if unify_eq t1 t2 then () else - let reset_tracing = check_trace_gadt_instances !env in - - try - type_changed := true; - begin match (t1.desc, t2.desc) with - (Tvar _, Tconstr _) when deep_occur t1 t2 -> - unify2 env t1 t2 - | (Tconstr _, Tvar _) when deep_occur t2 t1 -> - unify2 env t1 t2 - | (Tvar _, _) -> - unify1_var !env t1 t2 - | (_, Tvar _) -> - unify1_var !env t2 t1 - | (Tunivar _, Tunivar _) -> - unify_univar t1 t2 !univar_pairs; - update_level !env t1.level t2; - link_type t1 t2 - | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) - when Path.same p1 p2 (* && actual_mode !env = Old *) - (* This optimization assumes that t1 does not expand to t2 - (and conversely), so we fall back to the general case - when any of the types has a cached expansion. *) - && not (has_cached_expansion p1 !a1 - || has_cached_expansion p2 !a2) -> - update_level !env t1.level t2; - link_type t1 t2 - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) - when Env.has_local_constraints !env - && is_newtype !env p1 && is_newtype !env p2 -> - (* Do not use local constraints more than necessary *) - begin try - let [@local] (<) ((a : int) ,(b : int)) (c,d) = - a < c || (a = c && b < d) in - if find_newtype_level !env p1 < find_newtype_level !env p2 then - unify env t1 (try_expand_once !env t2) - else - unify env (try_expand_once !env t1) t2 - with Cannot_expand -> - unify2 env t1 t2 - end - | _ -> - unify2 env t1 t2 - end; - reset_trace_gadt_instances reset_tracing; - with Unify trace -> - reset_trace_gadt_instances reset_tracing; - raise (Unify ((t1, t2)::trace)) - -and unify2 env t1 t2 = - (* Second step: expansion of abbreviations *) - (* Expansion may change the representative of the types. *) - ignore (expand_head_unif !env t1); - ignore (expand_head_unif !env t2); - let t1' = expand_head_unif !env t1 in - let t2' = expand_head_unif !env t2 in - let lv = Ext_pervasives.min_int t1'.level t2'.level in - update_level !env lv t2; - update_level !env lv t1; - if unify_eq t1' t2' then () else - - let t1 = repr t1 and t2 = repr t2 in - if !trace_gadt_instances then begin - (* All types in chains already have the same ambiguity levels *) - let ilevel t = - match Env.gadt_instance_level !env t with None -> 0 | Some lv -> lv in - let lv1 = ilevel t1 and lv2 = ilevel t2 in - if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else - if lv2 > lv1 then Env.add_gadt_instance_chain !env lv2 t1 - end; - if unify_eq t1 t1' || not (unify_eq t2 t2') then - unify3 env t1 t1' t2 t2' - else - try unify3 env t2 t2' t1 t1' with Unify trace -> - raise (Unify (List.map (fun (x, y) -> (y, x)) trace)) - -and unify3 env t1 t1' t2 t2' = - (* Third step: truly unification *) - (* Assumes either [t1 == t1'] or [t2 != t2'] *) - let d1 = t1'.desc and d2 = t2'.desc in - let create_recursion = (t2 != t2') && (deep_occur t1' t2) in - - begin match (d1, d2) with (* handle vars and univars specially *) - (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs; - link_type t1' t2' - | (Tvar _, _) -> - occur !env t1' t2; - occur_univar !env t2; - link_type t1' t2; - | (_, Tvar _) -> - occur !env t2' t1; - occur_univar !env t1; - link_type t2' t1; - | (Tfield _, Tfield _) -> (* special case for GADTs *) - unify_fields env t1' t2' - | (Tconstr (Pident {name="function$"}, [tFun; _], _), Tarrow _) when !Config.uncurried = Uncurried -> - (* subtype: an uncurried function is cast to a curried one *) - unify2 env tFun t2 - | _ -> - begin match !umode with - | Expression -> - occur !env t1' t2'; - link_type t1' t2 - | Pattern -> - add_type_equality t1' t2' - end; - try - begin match (d1, d2) with - (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when Asttypes.same_arg_label l1 l2 || - (!umode = Pattern) && - not (is_optional l1 || is_optional l2) -> - unify env t1 t2; unify env u1 u2; - begin match commu_repr c1, commu_repr c2 with - Clink r, c2 -> set_commu r c2 - | c1, Clink r -> set_commu r c1 - | _ -> () - end - | (Ttuple tl1, Ttuple tl2) -> - unify_list env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - if !umode = Expression || not !generate_equations then - unify_list env tl1 tl2 - else if !assume_injective then - set_mode_pattern ~generate:true ~injective:false - (fun () -> unify_list env tl1 tl2) - else if in_current_module p1 (* || in_pervasives p1 *) - || List.exists (expands_to_datatype !env) [t1'; t1; t2] then - unify_list env tl1 tl2 - else - let inj = - try List.map Variance.(mem Inj) - (Env.find_type p1 !env).type_variance - with Not_found -> List.map (fun _ -> false) tl1 - in - List.iter2 - (fun i (t1, t2) -> - if i then unify env t1 t2 else - set_mode_pattern ~generate:false ~injective:false - begin fun () -> - let snap = snapshot () in - try unify env t1 t2 with Unify _ -> - backtrack snap; - reify env t1; reify env t2 - end) - inj (List.combine tl1 tl2) - | (Tconstr (path,[],_), - Tconstr (path',[],_)) - when is_instantiable !env path && is_instantiable !env path' - && !generate_equations -> - let [@local] (>) ((a:int),(b:int)) (c,d) = - a > c || (a = c && b > d) - in - let source, destination = - if find_newtype_level !env path > find_newtype_level !env path' - then path , t2' - else path', t1' - in - add_gadt_equation env source destination - | (Tconstr (path,[],_), _) - when is_instantiable !env path && !generate_equations -> - reify env t2'; - add_gadt_equation env path t2' - | (_, Tconstr (path,[],_)) - when is_instantiable !env path && !generate_equations -> - reify env t1'; - add_gadt_equation env path t1' - | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern -> - reify env t1'; - reify env t2'; - if !generate_equations then mcomp !env t1' t2' - | (Tobject (fi1, nm1), Tobject (fi2, _)) -> - unify_fields env fi1 fi2; - (* Type [t2'] may have been instantiated by [unify_fields] *) - (* XXX One should do some kind of unification... *) - begin match (repr t2').desc with - Tobject (_, {contents = Some (_, va::_)}) when - (match (repr va).desc with - Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () - | Tobject (_, nm2) -> set_name nm2 !nm1 - | _ -> () - end - | (Tvariant row1, Tvariant row2) -> - if !umode = Expression then - unify_row env row1 row2 - else begin - let snap = snapshot () in - try unify_row env row1 row2 - with Unify _ -> - backtrack snap; - reify env t1'; - reify env t2'; - if !generate_equations then mcomp !env t1' t2' - end - | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> - begin match field_kind_repr kind with - Fvar r when f <> dummy_method -> - set_kind r Fabsent; - if d2 = Tnil then unify env rem t2' - else unify env (newty2 rem.level Tnil) rem - | _ -> raise (Unify []) - end - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - unify env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env) - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> - begin try - unify_package !env (unify_list env) - t1.level p1 n1 tl1 t2.level p2 n2 tl2 - with Not_found -> - if !umode = Expression then raise (Unify []); - List.iter (reify env) (tl1 @ tl2); - (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) - end - | (_, _) -> - raise (Unify []) - end; - (* XXX Commentaires + changer "create_recursion" - ||| Comments + change "create_recursion" *) - if create_recursion then - match t2.desc with - Tconstr (p, tl, abbrev) -> - forget_abbrev abbrev p; - let t2'' = expand_head_unif !env t2 in - if not (closed_parameterized_type tl t2'') then - link_type (repr t2) (repr t2') - | _ -> - () (* t2 has already been expanded by update_level *) - with Unify trace -> - t1'.desc <- d1; - raise (Unify trace) - end - -and unify_list env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); - List.iter2 (unify env) tl1 tl2 - -(* Build a fresh row variable for unification *) -and make_rowvar level use1 rest1 use2 rest2 = - let set_name ty name = - match ty.desc with - Tvar None -> log_type ty; ty.desc <- Tvar name - | _ -> () - in - let name = - match rest1.desc, rest2.desc with - Tvar (Some _ as name1), Tvar (Some _ as name2) -> - if rest1.level <= rest2.level then name1 else name2 - | Tvar (Some _ as name), _ -> - if use2 then set_name rest2 name; name - | _, Tvar (Some _ as name) -> - if use1 then set_name rest2 name; name - | _ -> None - in - if use1 then rest1 else - if use2 then rest2 else newvar2 ?name level - -and unify_fields env (ty1 : Types.type_expr) (ty2 : Types.type_expr) = (* Optimization *) - let (fields1, rest1) = flatten_fields ty1 - and (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let l1 = (repr ty1).level and l2 = (repr ty2).level in - let va = make_rowvar (Ext_pervasives.min_int l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in - let d1 = rest1.desc and d2 = rest2.desc in - try - unify env (build_fields l1 miss1 va) rest2; - unify env rest1 (build_fields l2 miss2 va); - List.iter - (fun (n, k1, t1, k2, t2) -> - unify_kind k1 k2; - try - if !trace_gadt_instances then update_level !env va.level t1; - unify env t1 t2 - with Unify trace -> - raise (Unify ((newty (Tfield(n, k1, t1, newty Tnil)), - newty (Tfield(n, k2, t2, newty Tnil)))::trace))) - pairs - with exn -> - log_type rest1; rest1.desc <- d1; - log_type rest2; rest2.desc <- d2; - raise exn - -and unify_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - if k1 == k2 then () else - match k1, k2 with - (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 - | (Fpresent, Fvar r) -> set_kind r k1 - | (Fpresent, Fpresent) -> () - | _ -> assert false - -and unify_row env row1 row2 = - let row1 = row_repr row1 and row2 = row_repr row2 in - let rm1 = row_more row1 and rm2 = row_more row2 in - if unify_eq rm1 rm2 then () else - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - if not !Config.bs_only && (r1 <> [] && r2 <> []) then begin - (* pairs are the intersection, r1 , r2 should be disjoint *) - let ht = Hashtbl.create (List.length r1) in - List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; - List.iter - (fun (l,_) -> - try raise (Tags(l, Hashtbl.find ht (hash_variant l))) - with Not_found -> ()) - r2 - end; - let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in - let more = - if fixed1 then rm1 else - if fixed2 then rm2 else - newty2 (Ext_pervasives.min_int rm1.level rm2.level) (Tvar None) in - let fixed = fixed1 || fixed2 - and closed = row1.row_closed || row2.row_closed in - let keep switch = - List.for_all - (fun (_,f1,f2) -> - let f1, f2 = switch f1 f2 in - row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent) - pairs - in - let empty fields = - List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in - (* Check whether we are going to build an empty type *) - if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed) - && List.for_all - (fun (_,f1,f2) -> - row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) - pairs - then raise (Unify [mkvariant [] true, mkvariant [] true]); - let name = - if row1.row_name <> None && (row1.row_closed || empty r2) && - (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1) - then row1.row_name - else if row2.row_name <> None && (row2.row_closed || empty r1) && - (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2) - then row2.row_name - else None - in - let row0 = {row_fields = []; row_more = more; row_bound = (); - row_closed = closed; row_fixed = fixed; row_name = name} in - let set_more row rest = - let rest = - if closed then - filter_row_fields row.row_closed rest - else rest in - if rest <> [] && (row.row_closed || row_fixed row) - || closed && row_fixed row && not row.row_closed then begin - let t1 = mkvariant [] true and t2 = mkvariant rest false in - raise (Unify [if row == row1 then (t1,t2) else (t2,t1)]) - end; - (* The following test is not principal... should rather use Tnil *) - let rm = row_more row in - (*if !trace_gadt_instances && rm.desc = Tnil then () else*) - if !trace_gadt_instances then - update_level !env rm.level (newgenty (Tvariant row)); - if row_fixed row then - if more == rm then () else - if is_Tvar rm then link_type rm more else unify env rm more - else - let ty = newgenty (Tvariant {row0 with row_fields = rest}) in - update_level !env rm.level ty; - link_type rm ty - in - let md1 = rm1.desc and md2 = rm2.desc in - begin try - set_more row2 r1; - set_more row1 r2; - List.iter - (fun (l,f1,f2) -> - try unify_row_field env fixed1 fixed2 more l f1 f2 - with Unify trace -> - raise (Unify ((mkvariant [l,f1] true, - mkvariant [l,f2] true) :: trace))) - pairs; - if static_row row1 then begin - let rm = row_more row1 in - if is_Tvar rm then link_type rm (newty2 rm.level Tnil) - end - with exn -> - log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn - end - -and unify_row_field env fixed1 fixed2 more l f1 f2 = - let f1 = row_field_repr f1 and f2 = row_field_repr f2 in - if f1 == f2 then () else - match f1, f2 with - Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 - | Rpresent None, Rpresent None -> () - | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> - if e1 == e2 then () else - if (fixed1 || fixed2) && not (c1 || c2) - && List.length tl1 = List.length tl2 then begin - (* PR#7496 *) - let f = Reither (c1 || c2, [], m1 || m2, ref None) in - set_row_field e1 f; set_row_field e2 f; - List.iter2 (unify env) tl1 tl2 - end - else let redo = - not !passive_variants && - (m1 || m2 || fixed1 || fixed2 || - !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && - begin match tl1 @ tl2 with [] -> false - | t1 :: tl -> - if c1 || c2 then raise (Unify []); - List.iter (unify env t1) tl; - !e1 <> None || !e2 <> None - end in - if redo then unify_row_field env fixed1 fixed2 more l f1 f2 else - let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in - let rec remq tl = function [] -> [] - | ty :: tl' -> - if List.memq ty tl then remq tl tl' else ty :: remq tl tl' - in - let tl2' = remq tl2 tl1 and tl1' = remq tl1 tl2 in - (* PR#6744 *) - let split_univars = - List.partition - (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in - let (tl1',tlu1) = split_univars tl1' - and (tl2',tlu2) = split_univars tl2' in - begin match tlu1, tlu2 with - [], [] -> () - | (tu1::tlu1), _ :: _ -> - (* Attempt to merge all the types containing univars *) - if not !passive_variants then - List.iter (unify env tu1) (tlu1@tlu2) - | (tu::_, []) | ([], tu::_) -> occur_univar !env tu - end; - (* Is this handling of levels really principal? *) - List.iter (update_level !env (repr more).level) (tl1' @ tl2'); - let e = ref None in - let f1' = Reither(c1 || c2, tl1', m1 || m2, e) - and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in - set_row_field e1 f1'; set_row_field e2 f2'; - | Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2 - | Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1 - | Rabsent, Rabsent -> () - | Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 -> - set_row_field e1 f2; - update_level !env (repr more).level t2; - (try List.iter (fun t1 -> unify env t1 t2) tl - with exn -> e1 := None; raise exn) - | Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 -> - set_row_field e2 f1; - update_level !env (repr more).level t1; - (try List.iter (unify env t1) tl - with exn -> e2 := None; raise exn) - | Reither(true, [], _, e1), Rpresent None when not fixed1 -> - set_row_field e1 f2 - | Rpresent None, Reither(true, [], _, e2) when not fixed2 -> - set_row_field e2 f1 - | _ -> raise (Unify []) - - -let unify env ty1 ty2 = - let snap = Btype.snapshot () in - try - unify env ty1 ty2 - with - Unify trace -> - undo_compress snap; - raise (Unify (expand_trace !env trace)) - | Recursive_abbrev -> - undo_compress snap; - raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)])) - -let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 = - try - univar_pairs := []; - newtype_level := Some lev; - set_mode_pattern ~generate:true ~injective:true - (fun () -> unify env ty1 ty2); - newtype_level := None; - TypePairs.clear unify_eq_set; - with e -> - newtype_level := None; - TypePairs.clear unify_eq_set; - raise e - -let unify_var env t1 t2 = - let t1 = repr t1 and t2 = repr t2 in - if t1 == t2 then () else - match t1.desc, t2.desc with - Tvar _, Tconstr _ when deep_occur t1 t2 -> - unify (ref env) t1 t2 - | Tvar _, _ -> - let reset_tracing = check_trace_gadt_instances env in - begin try - occur env t1 t2; - update_level env t1.level t2; - link_type t1 t2; - reset_trace_gadt_instances reset_tracing; - with Unify trace -> - reset_trace_gadt_instances reset_tracing; - let expanded_trace = expand_trace env ((t1,t2)::trace) in - raise (Unify expanded_trace) - end - | _ -> - unify (ref env) t1 t2 - -let _ = unify' := unify_var - -let unify_pairs env ty1 ty2 pairs = - univar_pairs := pairs; - unify env ty1 ty2 - -let unify env ty1 ty2 = - unify_pairs (ref env) ty1 ty2 [] - - - -(**** Special cases of unification ****) - -let expand_head_trace env t = - let reset_tracing = check_trace_gadt_instances env in - let t = expand_head_unif env t in - reset_trace_gadt_instances reset_tracing; - t - -(* - Unify [t] and [l:'a -> 'b]. Return ['a] and ['b]. - In label mode, label mismatch is accepted when - (1) the requested label is "" - (2) the original label is not optional -*) - -let filter_arrow env t l = - let t = expand_head_trace env t in - match t.desc with - Tvar _ -> - let lv = t.level in - let t1 = newvar2 lv and t2 = newvar2 lv in - let t' = newty2 lv (Tarrow (l, t1, t2, Cok)) in - link_type t t'; - (t1, t2) - | Tarrow(l', t1, t2, _) - when Asttypes.same_arg_label l l' -> - (t1, t2) - | _ -> - raise (Unify []) - -(* Used by [filter_method]. *) -let rec filter_method_field env name priv ty = - let ty = expand_head_trace env ty in - match ty.desc with - Tvar _ -> - let level = ty.level in - let ty1 = newvar2 level and ty2 = newvar2 level in - let ty' = newty2 level (Tfield (name, - begin match priv with - Private -> Fvar (ref None) - | Public -> Fpresent - end, - ty1, ty2)) - in - link_type ty ty'; - ty1 - | Tfield(n, kind, ty1, ty2) -> - let kind = field_kind_repr kind in - if (n = name) && (kind <> Fabsent) then begin - if priv = Public then - unify_kind kind Fpresent; - ty1 - end else - filter_method_field env name priv ty2 - | _ -> - raise (Unify []) - -(* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) -let filter_method env name priv ty = - let ty = expand_head_trace env ty in - match ty.desc with - Tvar _ -> - let ty1 = newvar () in - let ty' = newobj ty1 in - update_level env ty.level ty'; - link_type ty ty'; - filter_method_field env name priv ty1 - | Tobject(f, _) -> - filter_method_field env name priv f - | _ -> - raise (Unify []) - -let check_filter_method env name priv ty = - ignore(filter_method env name priv ty) - -let filter_self_method env lab priv meths ty = - let ty' = filter_method env lab priv ty in - try - Meths.find lab !meths - with Not_found -> - let pair = (Ident.create lab, ty') in - meths := Meths.add lab pair !meths; - pair - - - (***********************************) - (* Matching between type schemes *) - (***********************************) - -(* - Update the level of [ty]. First check that the levels of generic - variables from the subject are not lowered. -*) -let moregen_occur env level ty = - let rec occur ty = - let ty = repr ty in - if ty.level > level then begin - if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur; - ty.level <- pivot_level - ty.level; - match ty.desc with - Tvariant row when static_row row -> - iter_row occur row - | _ -> - iter_type_expr occur ty - end - in - begin try - occur ty; unmark_type ty - with Occur -> - unmark_type ty; raise (Unify []) - end; - (* also check for free univars *) - occur_univar env ty; - update_level env level ty - -let may_instantiate inst_nongen t1 = - if inst_nongen then t1.level <> generic_level - 1 - else t1.level = generic_level - -let rec moregen inst_nongen type_pairs env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else - - try - match (t1.desc, t2.desc) with - (Tvar _, _) when may_instantiate inst_nongen t1 -> - moregen_occur env t1.level t2; - occur env t1 t2; - link_type t1 t2 - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> - () - | _ -> - let t1' = expand_head env t1 in - let t2' = expand_head env t2 in - (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else - begin try - TypePairs.find type_pairs (t1', t2') - with Not_found -> - TypePairs.add type_pairs (t1', t2') (); - match (t1'.desc, t2'.desc) with - (Tvar _, _) when may_instantiate inst_nongen t1' -> - moregen_occur env t1'.level t2; - link_type t1' t2 - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when Asttypes.same_arg_label l1 l2 - -> - moregen inst_nongen type_pairs env t1 t2; - moregen inst_nongen type_pairs env u1 u2 - | (Ttuple tl1, Ttuple tl2) -> - moregen_list inst_nongen type_pairs env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) - when Path.same p1 p2 -> - moregen_list inst_nongen type_pairs env tl1 tl2 - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> - begin try - unify_package env (moregen_list inst_nongen type_pairs env) - t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 - with Not_found -> raise (Unify []) - end - | (Tvariant row1, Tvariant row2) -> - moregen_row inst_nongen type_pairs env row1 row2 - | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> - moregen_fields inst_nongen type_pairs env fi1 fi2 - | (Tfield _, Tfield _) -> (* Actually unused *) - moregen_fields inst_nongen type_pairs env t1' t2' - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - moregen inst_nongen type_pairs env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (moregen inst_nongen type_pairs env) - | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs - | (_, _) -> - raise (Unify []) - end - with Unify trace -> - raise (Unify ((t1, t2)::trace)) - -and moregen_list inst_nongen type_pairs env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); - List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 - -and moregen_fields inst_nongen type_pairs env ty1 ty2 = - let (fields1, rest1) = flatten_fields ty1 - and (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - if miss1 <> [] then raise (Unify []); - moregen inst_nongen type_pairs env rest1 - (build_fields (repr ty2).level miss2 rest2); - List.iter - (fun (n, k1, t1, k2, t2) -> - moregen_kind k1 k2; - try moregen inst_nongen type_pairs env t1 t2 with Unify trace -> - raise (Unify ((newty (Tfield(n, k1, t1, rest2)), - newty (Tfield(n, k2, t2, rest2)))::trace))) - pairs - -and moregen_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - if k1 == k2 then () else - match k1, k2 with - (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 - | (Fpresent, Fpresent) -> () - | _ -> raise (Unify []) - -and moregen_row inst_nongen type_pairs env row1 row2 = - let row1 = row_repr row1 and row2 = row_repr row2 in - let rm1 = repr row1.row_more and rm2 = repr row2.row_more in - if rm1 == rm2 then () else - let may_inst = - is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - let r1, r2 = - if row2.row_closed then - filter_row_fields may_inst r1, filter_row_fields false r2 - else r1, r2 - in - if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) - then raise (Unify []); - begin match rm1.desc, rm2.desc with - Tunivar _, Tunivar _ -> - unify_univar rm1 rm2 !univar_pairs - | Tunivar _, _ | _, Tunivar _ -> - raise (Unify []) - | _ when static_row row1 -> () - | _ when may_inst -> - let ext = - newgenty (Tvariant {row2 with row_fields = r2; row_name = None}) - in - moregen_occur env rm1.level ext; - link_type rm1 ext - | Tconstr _, Tconstr _ -> - moregen inst_nongen type_pairs env rm1 rm2 - | _ -> raise (Unify []) - end; - List.iter - (fun (_l,f1,f2) -> - let f1 = row_field_repr f1 and f2 = row_field_repr f2 in - if f1 == f2 then () else - match f1, f2 with - Rpresent(Some t1), Rpresent(Some t2) -> - moregen inst_nongen type_pairs env t1 t2 - | Rpresent None, Rpresent None -> () - | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst -> - set_row_field e1 f2; - List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) tl1 - | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> - if e1 != e2 then begin - if c1 && not c2 then raise(Unify []); - set_row_field e1 (Reither (c2, [], m2, e2)); - if List.length tl1 = List.length tl2 then - List.iter2 (moregen inst_nongen type_pairs env) tl1 tl2 - else match tl2 with - t2 :: _ -> - List.iter (fun t1 -> moregen inst_nongen type_pairs env t1 t2) - tl1 - | [] -> - if tl1 <> [] then raise (Unify []) - end - | Reither(true, [], _, e1), Rpresent None when may_inst -> - set_row_field e1 f2 - | Reither(_, _, _, e1), Rabsent when may_inst -> - set_row_field e1 f2 - | Rabsent, Rabsent -> () - | _ -> raise (Unify [])) - pairs - -(* Must empty univar_pairs first *) -let moregen inst_nongen type_pairs env patt subj = - univar_pairs := []; - moregen inst_nongen type_pairs env patt subj - -(* - Non-generic variable can be instantiated only if [inst_nongen] is - true. So, [inst_nongen] should be set to false if the subject might - contain non-generic variables (and we do not want them to be - instantiated). - Usually, the subject is given by the user, and the pattern - is unimportant. So, no need to propagate abbreviations. -*) -let moregeneral env inst_nongen pat_sch subj_sch = - let old_level = !current_level in - current_level := generic_level - 1; - (* - Generic variables are first duplicated with [instance]. So, - their levels are lowered to [generic_level - 1]. The subject is - then copied with [duplicate_type]. That way, its levels won't be - changed. - *) - let subj = duplicate_type (instance env subj_sch) in - current_level := generic_level; - (* Duplicate generic variables *) - let patt = instance env pat_sch in - let res = - try moregen inst_nongen (TypePairs.create 13) env patt subj; true with - Unify _ -> false - in - current_level := old_level; - res - - -(* Alternative approach: "rigidify" a type scheme, - and check validity after unification *) -(* Simpler, no? *) - -let rec rigidify_rec vars ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - match ty.desc with - | Tvar _ -> - if not (List.memq ty !vars) then vars := ty :: !vars - | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in - if is_Tvar more && not (row_fixed row) then begin - let more' = newty2 more.level more.desc in - let row' = {row with row_fixed=true; row_fields=[]; row_more=more'} - in link_type more (newty2 ty.level (Tvariant row')) - end; - iter_row (rigidify_rec vars) row; - (* only consider the row variable if the variant is not static *) - if not (static_row row) then rigidify_rec vars (row_more row) - | _ -> - iter_type_expr (rigidify_rec vars) ty - end - -let rigidify ty = - let vars = ref [] in - rigidify_rec vars ty; - unmark_type ty; - !vars - -let all_distinct_vars env vars = - let tyl = ref [] in - List.for_all - (fun ty -> - let ty = expand_head env ty in - if List.memq ty !tyl then false else - (tyl := ty :: !tyl; is_Tvar ty)) - vars - -let matches env ty ty' = - let snap = snapshot () in - let vars = rigidify ty in - cleanup_abbrev (); - let ok = - try unify env ty ty'; all_distinct_vars env vars - with Unify _ -> false - in - backtrack snap; - ok - - - (*********************************************) - (* Equivalence between parameterized types *) - (*********************************************) - -let expand_head_rigid env ty = - let old = !rigid_variants in - rigid_variants := true; - let ty' = expand_head env ty in - rigid_variants := old; ty' - -let normalize_subst subst = - if List.exists - (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) - !subst - then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst - -let rec eqtype rename type_pairs subst env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else - - try - match (t1.desc, t2.desc) with - (Tvar _, Tvar _) when rename -> - begin try - normalize_subst subst; - if List.assq t1 !subst != t2 then raise (Unify []) - with Not_found -> - if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []); - subst := (t1, t2) :: !subst - end - | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> - () - | _ -> - let t1' = expand_head_rigid env t1 in - let t2' = expand_head_rigid env t2 in - (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else - begin try - TypePairs.find type_pairs (t1', t2') - with Not_found -> - TypePairs.add type_pairs (t1', t2') (); - match (t1'.desc, t2'.desc) with - (Tvar _, Tvar _) when rename -> - begin try - normalize_subst subst; - if List.assq t1' !subst != t2' then raise (Unify []) - with Not_found -> - if List.exists (fun (_, t) -> t == t2') !subst - then raise (Unify []); - subst := (t1', t2') :: !subst - end - | (Tarrow (l1, t1, u1, _), Tarrow (l2, t2, u2, _)) when Asttypes.same_arg_label l1 l2 - -> - eqtype rename type_pairs subst env t1 t2; - eqtype rename type_pairs subst env u1 u2; - | (Ttuple tl1, Ttuple tl2) -> - eqtype_list rename type_pairs subst env tl1 tl2 - | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) - when Path.same p1 p2 -> - eqtype_list rename type_pairs subst env tl1 tl2 - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> - begin try - unify_package env (eqtype_list rename type_pairs subst env) - t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 - with Not_found -> raise (Unify []) - end - | (Tvariant row1, Tvariant row2) -> - eqtype_row rename type_pairs subst env row1 row2 - | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> - eqtype_fields rename type_pairs subst env fi1 fi2 - | (Tfield _, Tfield _) -> (* Actually unused *) - eqtype_fields rename type_pairs subst env t1' t2' - | (Tnil, Tnil) -> - () - | (Tpoly (t1, []), Tpoly (t2, [])) -> - eqtype rename type_pairs subst env t1 t2 - | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (eqtype rename type_pairs subst env) - | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs - | (_, _) -> - raise (Unify []) - end - with Unify trace -> - raise (Unify ((t1, t2)::trace)) - -and eqtype_list rename type_pairs subst env tl1 tl2 = - if List.length tl1 <> List.length tl2 then - raise (Unify []); - List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 - -and eqtype_fields rename type_pairs subst env ty1 ty2 : unit = - let (fields1, rest1) = flatten_fields ty1 in - let (fields2, rest2) = flatten_fields ty2 in - (* First check if same row => already equal *) - let same_row = - rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) || - (rename && List.mem (rest1, rest2) !subst) - in - if same_row then () else - (* Try expansion, needed when called from Includecore.type_manifest *) - match expand_head_rigid env rest2 with - {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 - | _ -> - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - eqtype rename type_pairs subst env rest1 rest2; - if (miss1 <> []) || (miss2 <> []) then raise (Unify []); - List.iter - (function (n, k1, t1, k2, t2) -> - eqtype_kind k1 k2; - try eqtype rename type_pairs subst env t1 t2 with Unify trace -> - raise (Unify ((newty (Tfield(n, k1, t1, rest2)), - newty (Tfield(n, k2, t2, rest2)))::trace))) - pairs - -and eqtype_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - match k1, k2 with - (Fvar _, Fvar _) - | (Fpresent, Fpresent) -> () - | _ -> raise (Unify []) - -and eqtype_row rename type_pairs subst env row1 row2 = - (* Try expansion, needed when called from Includecore.type_manifest *) - match expand_head_rigid env (row_more row2) with - {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 - | _ -> - let row1 = row_repr row1 and row2 = row_repr row2 in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - if row1.row_closed <> row2.row_closed - || not row1.row_closed && (r1 <> [] || r2 <> []) - || filter_row_fields false (r1 @ r2) <> [] - then raise (Unify []); - if not (static_row row1) then - eqtype rename type_pairs subst env row1.row_more row2.row_more; - List.iter - (fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent(Some t1), Rpresent(Some t2) -> - eqtype rename type_pairs subst env t1 t2 - | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 -> - () - | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _) when c1 = c2 -> - eqtype rename type_pairs subst env t1 t2; - if List.length tl1 = List.length tl2 then - (* if same length allow different types (meaning?) *) - List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 - else begin - (* otherwise everything must be equal *) - List.iter (eqtype rename type_pairs subst env t1) tl2; - List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 - end - | Rpresent None, Rpresent None -> () - | Rabsent, Rabsent -> () - | _ -> raise (Unify [])) - pairs - -(* Must empty univar_pairs first *) -let eqtype_list rename type_pairs subst env tl1 tl2 = - univar_pairs := []; - let snap = Btype.snapshot () in - try eqtype_list rename type_pairs subst env tl1 tl2; backtrack snap - with exn -> backtrack snap; raise exn - -let eqtype rename type_pairs subst env t1 t2 = - eqtype_list rename type_pairs subst env [t1] [t2] - -(* Two modes: with or without renaming of variables *) -let equal env rename tyl1 tyl2 = - try - eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true - with - Unify _ -> false - - - (*************************) - (* Class type matching *) - (*************************) - - -type class_match_failure = - CM_Virtual_class - | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Class_type_mismatch of Env.t * class_type * class_type - | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Non_mutable_value of string - | CM_Non_concrete_value of string - | CM_Missing_value of string - | CM_Missing_method of string - | CM_Hide_public of string - | CM_Hide_virtual of string * string - | CM_Public_method of string - | CM_Private_method of string - | CM_Virtual_method of string - -exception Failure of class_match_failure list - -let rec moregen_clty trace type_pairs env cty1 cty2 = - try - match cty1, cty2 with - Cty_constr (_, _, cty1), _ -> - moregen_clty true type_pairs env cty1 cty2 - | _, Cty_constr (_, _, cty2) -> - moregen_clty true type_pairs env cty1 cty2 - | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when Asttypes.same_arg_label l1 l2 -> - begin try moregen true type_pairs env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) - end; - moregen_clty false type_pairs env cty1' cty2' - | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.csig_self) in - let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, _rest1) = flatten_fields ty1 - and (fields2, _rest2) = flatten_fields ty2 in - let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in - List.iter - (fun (lab, _k1, t1, _k2, t2) -> - begin try moregen true type_pairs env t1 t2 with Unify trace -> - raise (Failure [CM_Meth_type_mismatch - (lab, env, expand_trace env trace)]) - end) - pairs; - Vars.iter - (fun lab (_mut, _v, ty) -> - let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in - try moregen true type_pairs env ty' ty with Unify trace -> - raise (Failure [CM_Val_type_mismatch - (lab, env, expand_trace env trace)])) - sign2.csig_vars - | _ -> - raise (Failure []) - with - Failure error when trace || error = [] -> - raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) - -let match_class_types ?(trace=true) env pat_sch subj_sch = - let type_pairs = TypePairs.create 53 in - let old_level = !current_level in - current_level := generic_level - 1; - (* - Generic variables are first duplicated with [instance]. So, - their levels are lowered to [generic_level - 1]. The subject is - then copied with [duplicate_type]. That way, its levels won't be - changed. - *) - let (_, subj_inst) = instance_class [] subj_sch in - let subj = duplicate_class_type subj_inst in - current_level := generic_level; - (* Duplicate generic variables *) - let (_, patt) = instance_class [] pat_sch in - let res = - let sign1 = signature_of_class_type patt in - let sign2 = signature_of_class_type subj in - let t1 = repr sign1.csig_self in - let t2 = repr sign2.csig_self in - TypePairs.add type_pairs (t1, t2) (); - let (fields1, rest1) = flatten_fields (object_fields t1) - and (fields2, rest2) = flatten_fields (object_fields t2) in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let error = - List.fold_right - (fun (lab, k, _) err -> - let err = - let k = field_kind_repr k in - begin match k with - Fvar r -> set_kind r Fabsent; err - | _ -> CM_Hide_public lab::err - end - in - if Concr.mem lab sign1.csig_concr then err - else CM_Hide_virtual ("method", lab) :: err) - miss1 [] - in - let missing_method = List.map (fun (m, _, _) -> m) miss2 in - let error = - (List.map (fun m -> CM_Missing_method m) missing_method) @ error - in - (* Always succeeds *) - moregen true type_pairs env rest1 rest2; - let error = - List.fold_right - (fun (lab, k1, _t1, k2, _t2) err -> - try moregen_kind k1 k2; err with - Unify _ -> CM_Public_method lab::err) - pairs error - in - let error = - Vars.fold - (fun lab (mut, vr, _ty) err -> - try - let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in - if mut = Mutable && mut' <> Mutable then - CM_Non_mutable_value lab::err - else if vr = Concrete && vr' <> Concrete then - CM_Non_concrete_value lab::err - else - err - with Not_found -> - CM_Missing_value lab::err) - sign2.csig_vars error - in - let error = - Vars.fold - (fun lab (_,vr,_) err -> - if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then - CM_Hide_virtual ("instance variable", lab) :: err - else err) - sign1.csig_vars error - in - let error = - List.fold_right - (fun e l -> - if List.mem e missing_method then l else CM_Virtual_method e::l) - (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) - error - in - match error with - [] -> - begin try - moregen_clty trace type_pairs env patt subj; - [] - with - Failure r -> r - end - | error -> - CM_Class_type_mismatch (env, patt, subj)::error - in - current_level := old_level; - res - -let rec equal_clty trace type_pairs subst env cty1 cty2 = - try - match cty1, cty2 with - Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) -> - equal_clty true type_pairs subst env cty1 cty2 - | Cty_constr (_, _, cty1), _ -> - equal_clty true type_pairs subst env cty1 cty2 - | _, Cty_constr (_, _, cty2) -> - equal_clty true type_pairs subst env cty1 cty2 - | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when Asttypes.same_arg_label l1 l2 -> - begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) - end; - equal_clty false type_pairs subst env cty1' cty2' - | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.csig_self) in - let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, _rest1) = flatten_fields ty1 - and (fields2, _rest2) = flatten_fields ty2 in - let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in - List.iter - (fun (lab, _k1, t1, _k2, t2) -> - begin try eqtype true type_pairs subst env t1 t2 with - Unify trace -> - raise (Failure [CM_Meth_type_mismatch - (lab, env, expand_trace env trace)]) - end) - pairs; - Vars.iter - (fun lab (_, _, ty) -> - let (_, _, ty') = Vars.find lab sign1.csig_vars in - try eqtype true type_pairs subst env ty' ty with Unify trace -> - raise (Failure [CM_Val_type_mismatch - (lab, env, expand_trace env trace)])) - sign2.csig_vars - | _ -> - raise - (Failure (if trace then [] - else [CM_Class_type_mismatch (env, cty1, cty2)])) - with - Failure error when trace -> - raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) - -let match_class_declarations env patt_params patt_type subj_params subj_type = - let type_pairs = TypePairs.create 53 in - let subst = ref [] in - let sign1 = signature_of_class_type patt_type in - let sign2 = signature_of_class_type subj_type in - let t1 = repr sign1.csig_self in - let t2 = repr sign2.csig_self in - TypePairs.add type_pairs (t1, t2) (); - let (fields1, rest1) = flatten_fields (object_fields t1) - and (fields2, rest2) = flatten_fields (object_fields t2) in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let error = - List.fold_right - (fun (lab, k, _) err -> - let err = - let k = field_kind_repr k in - begin match k with - Fvar _ -> err - | _ -> CM_Hide_public lab::err - end - in - if Concr.mem lab sign1.csig_concr then err - else CM_Hide_virtual ("method", lab) :: err) - miss1 [] - in - let missing_method = List.map (fun (m, _, _) -> m) miss2 in - let error = - (List.map (fun m -> CM_Missing_method m) missing_method) @ error - in - (* Always succeeds *) - eqtype true type_pairs subst env rest1 rest2; - let error = - List.fold_right - (fun (lab, k1, _t1, k2, _t2) err -> - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - match k1, k2 with - (Fvar _, Fvar _) - | (Fpresent, Fpresent) -> err - | (Fvar _, Fpresent) -> CM_Private_method lab::err - | (Fpresent, Fvar _) -> CM_Public_method lab::err - | _ -> assert false) - pairs error - in - let error = - Vars.fold - (fun lab (mut, vr, _ty) err -> - try - let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in - if mut = Mutable && mut' <> Mutable then - CM_Non_mutable_value lab::err - else if vr = Concrete && vr' <> Concrete then - CM_Non_concrete_value lab::err - else - err - with Not_found -> - CM_Missing_value lab::err) - sign2.csig_vars error - in - let error = - Vars.fold - (fun lab (_,vr,_) err -> - if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then - CM_Hide_virtual ("instance variable", lab) :: err - else err) - sign1.csig_vars error - in - let error = - List.fold_right - (fun e l -> - if List.mem e missing_method then l else CM_Virtual_method e::l) - (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) - error - in - match error with - [] -> - begin try - let lp = List.length patt_params in - let ls = List.length subj_params in - if lp <> ls then - raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); - List.iter2 (fun p s -> - try eqtype true type_pairs subst env p s with Unify trace -> - raise (Failure [CM_Type_parameter_mismatch - (env, expand_trace env trace)])) - patt_params subj_params; - (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) - equal_clty false type_pairs subst env - (Cty_signature sign1) (Cty_signature sign2); - (* Use moregeneral for class parameters, need to recheck everything to - keeps relationships (PR#4824) *) - let clty_params = - List.fold_right (fun ty cty -> Cty_arrow (Labelled "*",ty,cty)) in - match_class_types ~trace:false env - (clty_params patt_params patt_type) - (clty_params subj_params subj_type) - with - Failure r -> r - end - | error -> - error - - - (***************) - (* Subtyping *) - (***************) - - -(**** Build a subtype of a given type. ****) - -(* build_subtype: - [visited] traces traversed object and variant types - [loops] is a mapping from variables to variables, to reproduce - positive loops in a class type - [posi] true if the current variance is positive - [level] number of expansions/enlargement allowed on this branch *) - -let warn = ref false (* whether double coercion might do better *) -let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n -let pred_enlarge n = if n mod 2 = 1 then pred n else n - -type change = Unchanged | Equiv | Changed [@@immediate] - -let [@inline] max (c1:change) (c2 :change)= - (Obj.magic (Ext_pervasives.max_int (Obj.magic c1 : int) (Obj.magic c2 : int)) : change) -let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l - -let rec filter_visited = function - [] -> [] - | {desc=Tobject _|Tvariant _} :: _ as l -> l - | _ :: l -> filter_visited l - -let memq_warn t visited = - if List.memq t visited then (warn := true; true) else false - -let rec lid_of_path ?(hash="") = function - Path.Pident id -> - Longident.Lident (hash ^ Ident.name id) - | Path.Pdot (p1, s, _) -> - Longident.Ldot (lid_of_path p1, hash ^ s) - | Path.Papply (p1, p2) -> - Longident.Lapply (lid_of_path ~hash p1, lid_of_path p2) - -let find_cltype_for_path env p = - let cl_path = Env.lookup_type (lid_of_path ~hash:"#" p) env in - let cl_abbr = Env.find_type cl_path env in - - match cl_abbr.type_manifest with - Some ty -> - begin match (repr ty).desc with - Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty - | _ -> raise Not_found - end - | None -> assert false - -let has_constr_row' env t = - has_constr_row (expand_abbrev env t) - -let rec build_subtype env visited loops posi level t = - let t = repr t in - match t.desc with - Tvar _ -> - if posi then - try - let t' = List.assq t loops in - warn := true; - (t', Equiv) - with Not_found -> - (t, Unchanged) - else - (t, Unchanged) - | Tarrow(l, t1, t2, _) -> - if memq_warn t visited then (t, Unchanged) else - let visited = t :: visited in - let (t1', c1) = build_subtype env visited loops (not posi) level t1 in - let (t2', c2) = build_subtype env visited loops posi level t2 in - let c = max c1 c2 in - if c > Unchanged then (newty (Tarrow(l, t1', t2', Cok)), c) - else (t, Unchanged) - | Ttuple tlist -> - if memq_warn t visited then (t, Unchanged) else - let visited = t :: visited in - let tlist' = - List.map (build_subtype env visited loops posi level) tlist - in - let c = collect tlist' in - if c > Unchanged then (newty (Ttuple (List.map fst tlist')), c) - else (t, Unchanged) - | Tconstr(p, tl, abbrev) - when level > 0 && generic_abbrev env p && safe_abbrev env t - && not (has_constr_row' env t) -> - let t' = repr (expand_abbrev env t) in - let level' = pred_expand level in - begin try match t'.desc with - Tobject _ when posi && not (opened_object t') -> - let cl_abbr, body = find_cltype_for_path env p in - let ty = - subst env !current_level Public abbrev None - cl_abbr.type_params tl body in - let ty = repr ty in - let ty1, tl1 = - match ty.desc with - Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' -> - ty1, tl1 - | _ -> raise Not_found - in - (* Fix PR#4505: do not set ty to Tvar when it appears in tl1, - as this occurrence might break the occur check. - XXX not clear whether this correct anyway... *) - if List.exists (deep_occur ty) tl1 then raise Not_found; - ty.desc <- Tvar None; - let t'' = newvar () in - let loops = (ty, t'') :: loops in - (* May discard [visited] as level is going down *) - let (ty1', c) = - build_subtype env [t'] loops posi (pred_enlarge level') ty1 in - assert (is_Tvar t''); - let nm = - if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in - t''.desc <- Tobject (ty1', ref nm); - (try unify_var env ty t with Unify _ -> assert false); - (t'', Changed) - | _ -> raise Not_found - with Not_found -> - let (t'',c) = build_subtype env visited loops posi level' t' in - if c > Unchanged then (t'',c) - else (t, Unchanged) - end - | Tconstr(p, tl, _abbrev) -> - (* Must check recursion on constructors, since we do not always - expand them *) - if memq_warn t visited then (t, Unchanged) else - let visited = t :: visited in - begin try - let decl = Env.find_type p env in - if level = 0 && generic_abbrev env p && safe_abbrev env t - && not (has_constr_row' env t) - then warn := true; - let tl' = - List.map2 - (fun v t -> - let (co,cn) = Variance.get_upper v in - if cn then - if co then (t, Unchanged) - else build_subtype env visited loops (not posi) level t - else - if co then build_subtype env visited loops posi level t - else (newvar(), Changed)) - decl.type_variance tl - in - let c = collect tl' in - if c > Unchanged then (newconstr p (List.map fst tl'), c) - else (t, Unchanged) - with Not_found -> - (t, Unchanged) - end - | Tvariant row -> - let row = row_repr row in - if memq_warn t visited || not (static_row row) then (t, Unchanged) else - let level' = pred_enlarge level in - let visited = - t :: if level' < level then [] else filter_visited visited in - let fields = filter_row_fields false row.row_fields in - let fields = - List.map - (fun (l,f as orig) -> match row_field_repr f with - Rpresent None -> - if posi then - (l, Reither(true, [], false, ref None)), Unchanged - else - orig, Unchanged - | Rpresent(Some t) -> - let (t', c) = build_subtype env visited loops posi level' t in - let f = - if posi && level > 0 - then Reither(false, [t'], false, ref None) - else Rpresent(Some t') - in (l, f), c - | _ -> assert false) - fields - in - let c = collect fields in - let row = - { row_fields = List.map fst fields; row_more = newvar(); - row_bound = (); row_closed = posi; row_fixed = false; - row_name = if c > Unchanged then None else row.row_name } - in - (newty (Tvariant row), Changed) - | Tobject (t1, _) -> - if memq_warn t visited || opened_object t1 then (t, Unchanged) else - let level' = pred_enlarge level in - let visited = - t :: if level' < level then [] else filter_visited visited in - let (t1', c) = build_subtype env visited loops posi level' t1 in - if c > Unchanged then (newty (Tobject (t1', ref None)), c) - else (t, Unchanged) - | Tfield(s, _, t1, t2) (* Always present *) -> - let (t1', c1) = build_subtype env visited loops posi level t1 in - let (t2', c2) = build_subtype env visited loops posi level t2 in - let c = max c1 c2 in - if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c) - else (t, Unchanged) - | Tnil -> - if posi then - let v = newvar () in - (v, Changed) - else begin - warn := true; - (t, Unchanged) - end - | Tsubst _ | Tlink _ -> - assert false - | Tpoly(t1, tl) -> - let (t1', c) = build_subtype env visited loops posi level t1 in - if c > Unchanged then (newty (Tpoly(t1', tl)), c) - else (t, Unchanged) - | Tunivar _ | Tpackage _ -> - (t, Unchanged) - -let enlarge_type env ty = - warn := false; - (* [level = 4] allows 2 expansions involving objects/variants *) - let (ty', _) = build_subtype env [] [] true 4 ty in - (ty', !warn) - -(**** Check whether a type is a subtype of another type. ****) - -(* - During the traversal, a trace of visited types is maintained. It - is printed in case of error. - Constraints (pairs of types that must be equals) are accumulated - rather than being enforced straight. Indeed, the result would - otherwise depend on the order in which these constraints are - enforced. - A function enforcing these constraints is returned. That way, type - variables can be bound to their actual values before this function - is called (see Typecore). - Only well-defined abbreviations are expanded (hence the tests - [generic_abbrev ...]). -*) - -let subtypes = TypePairs.create 17 - -let subtype_error env trace = - raise (Subtype (expand_trace env (List.rev trace), [])) - -let extract_concrete_typedecl_opt env t = - match extract_concrete_typedecl env t with - | v -> Some v - | exception Not_found -> None - -let rec subtype_rec env trace t1 t2 cstrs = - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then cstrs else - - begin try - TypePairs.find subtypes (t1, t2); - cstrs - with Not_found -> - TypePairs.add subtypes (t1, t2) (); - match (t1.desc, t2.desc) with - (Tvar _, _) | (_, Tvar _) -> - (trace, t1, t2, !univar_pairs)::cstrs - | (Tarrow(l1, t1, u1, _), Tarrow(l2, t2, u2, _)) when Asttypes.same_arg_label l1 l2 - -> - let cstrs = subtype_rec env ((t2, t1)::trace) t2 t1 cstrs in - subtype_rec env ((u1, u2)::trace) u1 u2 cstrs - | (Ttuple tl1, Ttuple tl2) -> - subtype_list env trace tl1 tl2 cstrs - | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> - cstrs - | (Tconstr(p1, _tl1, _abbrev1), _) - when generic_abbrev env p1 && safe_abbrev env t1 -> - subtype_rec env trace (expand_abbrev env t1) t2 cstrs - | (_, Tconstr(p2, _tl2, _abbrev2)) - when generic_abbrev env p2 && safe_abbrev env t2 -> - subtype_rec env trace t1 (expand_abbrev env t2) cstrs - | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 -> - begin try - let decl = Env.find_type p1 env in - List.fold_left2 - (fun cstrs v (t1, t2) -> - let (co, cn) = Variance.get_upper v in - if co then - if cn then - (* Invariant type argument: check both ways *) - if - subtype_rec env ((t1, t2)::trace) t1 t2 [] = [] && - subtype_rec env ((t2, t1)::trace) t2 t1 [] = [] then - cstrs - else - (trace, newty2 t1.level (Ttuple[t1]), - newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs - else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - else - if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs - else cstrs) - cstrs decl.type_variance (List.combine tl1 tl2) - with Not_found -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 -> - subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs - | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 Predef.path_int && Path.same p2 Predef.path_float -> - cstrs - | (Tconstr(path, [], _), Tconstr(_, [], _)) when Variant_coercion.can_coerce_primitive path && - extract_concrete_typedecl_opt env t2 |> Variant_coercion.can_try_coerce_variant_to_primitive_opt |> Option.is_some - -> - (* type coercion for primitives (int/float/string) to elgible unboxed variants: - - must be unboxed - - must have a constructor case with a supported and matching primitive payload *) - (match Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t2) with - | Some (constructors, true) -> - if Variant_coercion.variant_has_catch_all_case constructors (fun p -> Path.same p path) then - cstrs - else - (trace, t1, t2, !univar_pairs)::cstrs - | _ -> (trace, t1, t2, !univar_pairs)::cstrs) - | (Tconstr(_, [], _), Tconstr(path, [], _)) when Variant_coercion.can_coerce_primitive path && - extract_concrete_typedecl_opt env t1 |> Variant_coercion.can_try_coerce_variant_to_primitive_opt |> Option.is_some - -> - (* type coercion for variants to primitives *) - (match Variant_coercion.can_try_coerce_variant_to_primitive_opt (extract_concrete_typedecl_opt env t1) with - | Some (constructors, unboxed) -> - if constructors |> Variant_coercion.variant_has_same_runtime_representation_as_target ~targetPath:path ~unboxed then - cstrs - else - (trace, t1, t2, !univar_pairs)::cstrs - | None -> (trace, t1, t2, !univar_pairs)::cstrs) - | (Tconstr(_, [], _), Tconstr(_, [], _)) -> (* type coercion for variants and records *) - (match extract_concrete_typedecl env t1, extract_concrete_typedecl env t2 with - | (_, _, {type_kind=Type_variant (c1); type_attributes=t1attrs}), (_, _, {type_kind=Type_variant (c2); type_attributes=t2attrs}) -> - if - Variant_coercion.variant_configuration_can_be_coerced t1attrs t2attrs = false - then - (trace, t1, t2, !univar_pairs)::cstrs - else - let c1_len = List.length c1 in - if c1_len > List.length c2 then (trace, t1, t2, !univar_pairs)::cstrs - else - let constructor_map = Hashtbl.create c1_len in - c2 - |> List.iter (fun (c : Types.constructor_declaration) -> - Hashtbl.add constructor_map (Ident.name c.cd_id) c); - if c1 |> List.for_all (fun (c : Types.constructor_declaration) -> - match (c, Hashtbl.find_opt constructor_map (Ident.name c.cd_id)) with - | ( {Types.cd_args = Cstr_record fields1; cd_attributes=c1_attributes}, - Some {Types.cd_args = Cstr_record fields2; cd_attributes=c2_attributes} ) -> - if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then - let violation, tl1, tl2 = Record_coercion.check_record_fields fields1 fields2 in - if violation then false - else - begin try - let lst = subtype_list env trace tl1 tl2 cstrs in - List.length lst = List.length cstrs - with | _ -> false end - else false - | ( {Types.cd_args = Cstr_tuple tl1; cd_attributes=c1_attributes}, - Some {Types.cd_args = Cstr_tuple tl2; cd_attributes=c2_attributes} ) -> - if Variant_coercion.variant_representation_matches c1_attributes c2_attributes then - begin try - let lst = subtype_list env trace tl1 tl2 cstrs in - List.length lst = List.length cstrs - with | _ -> false end - else false - | _ -> false) - then cstrs - else (trace, t1, t2, !univar_pairs)::cstrs - | (_, _, {type_kind=Type_record (fields1, repr1)}), (_, _, {type_kind=Type_record (fields2, repr2)}) -> - let same_repr = match repr1, repr2 with - | (Record_regular | Record_optional_labels _), (Record_regular | Record_optional_labels _) -> - true (* handled in the fields checks *) - | Record_unboxed b1, Record_unboxed b2 -> b1 = b2 - | Record_inlined _, Record_inlined _ -> repr1 = repr2 - | Record_extension, Record_extension -> true - | _ -> false in - if same_repr then - let violation, tl1, tl2 = Record_coercion.check_record_fields ~repr1 ~repr2 fields1 fields2 in - if violation - then (trace, t1, t2, !univar_pairs)::cstrs - else - subtype_list env trace tl1 tl2 cstrs - else - (trace, t1, t2, !univar_pairs)::cstrs - | _ -> (trace, t1, t2, !univar_pairs)::cstrs - | exception Not_found -> (trace, t1, t2, !univar_pairs)::cstrs - ) - (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> - subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) - | (Tobject (f1, _), Tobject (f2, _)) - when is_Tvar (object_row f1) && is_Tvar (object_row f2) -> - (* Same row variable implies same object. *) - (trace, t1, t2, !univar_pairs)::cstrs - | (Tobject (f1, _), Tobject (f2, _)) -> - subtype_fields env trace f1 f2 cstrs - | (Tvariant row1, Tvariant row2) -> - begin try - subtype_row env trace row1 row2 cstrs - with Exit -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | Tvariant v, _ when - !Config.bs_only && - !variant_is_subtype env (row_repr v) t2 - -> - cstrs - | (Tpoly (u1, []), Tpoly (u2, [])) -> - subtype_rec env trace u1 u2 cstrs - | (Tpoly (u1, tl1), Tpoly (u2, [])) -> - let _, u1' = instance_poly false tl1 u1 in - subtype_rec env trace u1' u2 cstrs - | (Tpoly (u1, tl1), Tpoly (u2,tl2)) -> - begin try - enter_poly env univar_pairs u1 tl1 u2 tl2 - (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) - with Unify _ -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) -> - begin try - let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1 - and ntl2 = complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2 - ~allow_absent:true in - let cstrs' = - List.map - (fun (n2,t2) -> (trace, List.assoc n2 ntl1, t2, !univar_pairs)) - ntl2 - in - if eq_package_path env p1 p2 then cstrs' @ cstrs - else begin - (* need to check module subtyping *) - let snap = Btype.snapshot () in - try - List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs'; - if !package_subtype env p1 nl1 tl1 p2 nl2 tl2 - then (Btype.backtrack snap; cstrs' @ cstrs) - else raise (Unify []) - with Unify _ -> - Btype.backtrack snap; raise Not_found - end - with Not_found -> - (trace, t1, t2, !univar_pairs)::cstrs - end - | (_, _) -> - (trace, t1, t2, !univar_pairs)::cstrs - end - -and subtype_list env trace tl1 tl2 cstrs = - if List.length tl1 <> List.length tl2 then - subtype_error env trace; - List.fold_left2 - (fun cstrs t1 t2 -> subtype_rec env ((t1, t2)::trace) t1 t2 cstrs) - cstrs tl1 tl2 - -and subtype_fields env trace ty1 ty2 cstrs = - (* Assume that either rest1 or rest2 is not Tvar *) - let (fields1, rest1) = flatten_fields ty1 in - let (fields2, rest2) = flatten_fields ty2 in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let cstrs = - if rest2.desc = Tnil then cstrs else - if miss1 = [] then - subtype_rec env ((rest1, rest2)::trace) rest1 rest2 cstrs - else - (trace, build_fields (repr ty1).level miss1 rest1, rest2, - !univar_pairs) :: cstrs - in - let cstrs = - if miss2 = [] then cstrs else - (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()), - !univar_pairs) :: cstrs - in - List.fold_left - (fun cstrs (_, _k1, t1, _k2, t2) -> - (* These fields are always present *) - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs) - cstrs pairs - -and subtype_row env trace row1 row2 cstrs = - let row1 = row_repr row1 and row2 = row_repr row2 in - let r1, r2, pairs = - merge_row_fields row1.row_fields row2.row_fields in - let more1 = repr row1.row_more - and more2 = repr row2.row_more in - match more1.desc, more2.desc with - Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> - subtype_rec env ((more1,more2)::trace) more1 more2 cstrs - | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) - when row1.row_closed && r1 = [] -> - List.fold_left - (fun cstrs (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - (Rpresent None|Reither(true,_,_,_)), Rpresent None -> - cstrs - | Rpresent(Some t1), Rpresent(Some t2) -> - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - | Reither(false, t1::_, _, _), Rpresent(Some t2) -> - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - | Rabsent, _ -> cstrs - | _ -> raise Exit) - cstrs pairs - | Tunivar _, Tunivar _ - when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] -> - let cstrs = - subtype_rec env ((more1,more2)::trace) more1 more2 cstrs in - List.fold_left - (fun cstrs (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent None, Rpresent None - | Reither(true,[],_,_), Reither(true,[],_,_) - | Rabsent, Rabsent -> - cstrs - | Rpresent(Some t1), Rpresent(Some t2) - | Reither(false,[t1],_,_), Reither(false,[t2],_,_) -> - subtype_rec env ((t1, t2)::trace) t1 t2 cstrs - | _ -> raise Exit) - cstrs pairs - | _ -> - raise Exit - -let subtype env ty1 ty2 = - TypePairs.clear subtypes; - univar_pairs := []; - (* Build constraint set. *) - let cstrs = subtype_rec env [(ty1, ty2)] ty1 ty2 [] in - TypePairs.clear subtypes; - (* Enforce constraints. *) - function () -> - List.iter - (function (trace0, t1, t2, pairs) -> - try unify_pairs (ref env) t1 t2 pairs with Unify trace -> - raise (Subtype (expand_trace env (List.rev trace0), - List.tl (List.tl trace)))) - (List.rev cstrs) - - (*******************) - (* Miscellaneous *) - (*******************) - -(* Utility for printing. The resulting type is not used in computation. *) -let rec unalias_object ty = - let ty = repr ty in - match ty.desc with - Tfield (s, k, t1, t2) -> - newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) - | Tvar _ | Tnil -> - newty2 ty.level ty.desc - | Tunivar _ -> - ty - | Tconstr _ -> - newvar2 ty.level - | _ -> - assert false - -let unalias ty = - let ty = repr ty in - match ty.desc with - Tvar _ | Tunivar _ -> - ty - | Tvariant row -> - let row = row_repr row in - let more = row.row_more in - newty2 ty.level - (Tvariant {row with row_more = newty2 more.level more.desc}) - | Tobject (ty, nm) -> - newty2 ty.level (Tobject (unalias_object ty, nm)) - | _ -> - newty2 ty.level ty.desc - -(* Return the arity (as for curried functions) of the given type. *) -let rec arity ty = - match (repr ty).desc with - Tarrow(_, _t1, t2, _) -> 1 + arity t2 - | _ -> 0 - -(* Check whether an abbreviation expands to itself. *) -let cyclic_abbrev env id ty = - let rec check_cycle seen ty = - let ty = repr ty in - match ty.desc with - Tconstr (p, _tl, _abbrev) -> - (match p with Path.Pident p -> Ident.same p id | _ -> false) || List.memq ty seen || - begin try - check_cycle (ty :: seen) (expand_abbrev_opt env ty) - with - Cannot_expand -> false - | Unify _ -> true - end - | _ -> - false - in check_cycle [] ty - -(* Check for non-generalizable type variables *) -exception Non_closed0 -let visited = ref TypeSet.empty - -let rec closed_schema_rec env ty = - let ty = repr ty in - if TypeSet.mem ty !visited then () else begin - visited := TypeSet.add ty !visited; - match ty.desc with - Tvar _ when ty.level <> generic_level -> - raise Non_closed0 - | Tconstr _ -> - let old = !visited in - begin try iter_type_expr (closed_schema_rec env) ty - with Non_closed0 -> try - visited := old; - closed_schema_rec env (try_expand_head try_expand_safe env ty) - with Cannot_expand -> - raise Non_closed0 - end - | Tfield(_, kind, t1, t2) -> - if field_kind_repr kind = Fpresent then - closed_schema_rec env t1; - closed_schema_rec env t2 - | Tvariant row -> - let row = row_repr row in - iter_row (closed_schema_rec env) row; - if not (static_row row) then closed_schema_rec env row.row_more - | _ -> - iter_type_expr (closed_schema_rec env) ty - end - -(* Return whether all variables of type [ty] are generic. *) -let closed_schema env ty = - visited := TypeSet.empty; - try - closed_schema_rec env ty; - visited := TypeSet.empty; - true - with Non_closed0 -> - visited := TypeSet.empty; - false - -(* Normalize a type before printing, saving... *) -(* Cannot use mark_type because deep_occur uses it too *) -let rec normalize_type_rec env visited ty = - let ty = repr ty in - if not (TypeSet.mem ty !visited) then begin - visited := TypeSet.add ty !visited; - let tm = row_of_type ty in - begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then - match tm.desc with (* PR#7348 *) - Tconstr (Path.Pdot(m,i,pos), tl, _abbrev) -> - let i' = String.sub i 0 (String.length i - 4) in - log_type ty; - ty.desc <- Tconstr(Path.Pdot(m,i',pos), tl, ref Mnil) - | _ -> assert false - else match ty.desc with - | Tvariant row -> - let row = row_repr row in - let fields = List.map - (fun (l,f0) -> - let f = row_field_repr f0 in l, - match f with Reither(b, ty::(_::_ as tyl), m, e) -> - let tyl' = - List.fold_left - (fun tyl ty -> - if List.exists (fun ty' -> equal env false [ty] [ty']) tyl - then tyl else ty::tyl) - [ty] tyl - in - if f != f0 || List.length tyl' < List.length tyl then - Reither(b, List.rev tyl', m, e) - else f - | _ -> f) - row.row_fields in - let fields = - List.sort (fun (p,_) (q,_) -> compare p q) - (Ext_list.filter fields (fun (_,fi) -> fi <> Rabsent)) in - log_type ty; - ty.desc <- Tvariant {row with row_fields = fields} - | Tobject (fi, nm) -> - begin match !nm with - | None -> () - | Some (n, v :: l) -> - if deep_occur ty (newgenty (Ttuple l)) then - (* The abbreviation may be hiding something, so remove it *) - set_name nm None - else let v' = repr v in - begin match v'.desc with - | Tvar _ | Tunivar _ -> - if v' != v then set_name nm (Some (n, v' :: l)) - | Tnil -> - log_type ty; ty.desc <- Tconstr (n, l, ref Mnil) - | _ -> set_name nm None - end - | _ -> - fatal_error "Ctype.normalize_type_rec" - end; - let fi = repr fi in - if fi.level < lowest_level then () else - let fields, row = flatten_fields fi in - let fi' = build_fields fi.level fields row in - log_type ty; fi.desc <- fi'.desc - | _ -> () - end; - iter_type_expr (normalize_type_rec env visited) ty - end - -let normalize_type env ty = - normalize_type_rec env (ref TypeSet.empty) ty - - - (*************************) - (* Remove dependencies *) - (*************************) - - -(* - Variables are left unchanged. Other type nodes are duplicated, with - levels set to generic level. - We cannot use Tsubst here, because unification may be called by - expand_abbrev. -*) - -let nondep_hash = TypeHash.create 47 -let nondep_variants = TypeHash.create 17 -let clear_hash () = - TypeHash.clear nondep_hash; TypeHash.clear nondep_variants - -let rec nondep_type_rec env id ty = - match ty.desc with - Tvar _ | Tunivar _ -> ty - | Tlink ty -> nondep_type_rec env id ty - | _ -> try TypeHash.find nondep_hash ty - with Not_found -> - let ty' = newgenvar () in (* Stub *) - TypeHash.add nondep_hash ty ty'; - ty'.desc <- - begin match ty.desc with - | Tconstr(p, tl, _abbrev) -> - if Path.isfree id p then - begin try - Tlink (nondep_type_rec env id - (expand_abbrev env (newty2 ty.level ty.desc))) - (* - The [Tlink] is important. The expanded type may be a - variable, or may not be completely copied yet - (recursive type), so one cannot just take its - description. - *) - with Cannot_expand | Unify _ -> - raise Not_found - end - else - Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil) - | Tpackage(p, nl, tl) when Path.isfree id p -> - let p' = normalize_package_path env p in - if Path.isfree id p' then raise Not_found; - Tpackage (p', nl, List.map (nondep_type_rec env id) tl) - | Tobject (t1, name) -> - Tobject (nondep_type_rec env id t1, - ref (match !name with - None -> None - | Some (p, tl) -> - if Path.isfree id p then None - else Some (p, List.map (nondep_type_rec env id) tl))) - | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in - (* We must keep sharing according to the row variable *) - begin try - let ty2 = TypeHash.find nondep_variants more in - (* This variant type has been already copied *) - TypeHash.add nondep_hash ty ty2; - Tlink ty2 - with Not_found -> - (* Register new type first for recursion *) - TypeHash.add nondep_variants more ty'; - let static = static_row row in - let more' = if static then newgenty Tnil else more in - (* Return a new copy *) - let row = - copy_row (nondep_type_rec env id) true row true more' in - match row.row_name with - Some (p, _tl) when Path.isfree id p -> - Tvariant {row with row_name = None} - | _ -> Tvariant row - end - | _ -> copy_type_desc (nondep_type_rec env id) ty.desc - end; - ty' - -let nondep_type env id ty = - try - let ty' = nondep_type_rec env id ty in - clear_hash (); - ty' - with Not_found -> - clear_hash (); - raise Not_found - -let () = nondep_type' := nondep_type - -let unroll_abbrev id tl ty = - let ty = repr ty and path = Path.Pident id in - if is_Tvar ty || (List.exists (deep_occur ty) tl) - || is_object_type path then - ty - else - let ty' = newty2 ty.level ty.desc in - link_type ty (newty2 ty.level (Tconstr (path, tl, ref Mnil))); - ty' - -(* Preserve sharing inside type declarations. *) -let nondep_type_decl env mid id is_covariant decl = - try - let params = List.map (nondep_type_rec env mid) decl.type_params in - let tk = - try map_kind (nondep_type_rec env mid) decl.type_kind - with Not_found when is_covariant -> Type_abstract - and tm = - try match decl.type_manifest with - None -> None - | Some ty -> - Some (unroll_abbrev id params (nondep_type_rec env mid ty)) - with Not_found when is_covariant -> - None - in - clear_hash (); - let priv = - match tm with - | Some ty when Btype.has_constr_row ty -> Private - | _ -> decl.type_private - in - { type_params = params; - type_arity = decl.type_arity; - type_kind = tk; - type_manifest = tm; - type_private = priv; - type_variance = decl.type_variance; - type_newtype_level = None; - type_loc = decl.type_loc; - type_attributes = decl.type_attributes; - type_immediate = decl.type_immediate; - type_unboxed = decl.type_unboxed; - } - with Not_found -> - clear_hash (); - raise Not_found - -(* Preserve sharing inside extension constructors. *) -let nondep_extension_constructor env mid ext = - try - let type_path, type_params = - if Path.isfree mid ext.ext_type_path then - begin - let ty = - newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) - in - let ty' = nondep_type_rec env mid ty in - match (repr ty').desc with - Tconstr(p, tl, _) -> p, tl - | _ -> raise Not_found - end - else - let type_params = - List.map (nondep_type_rec env mid) ext.ext_type_params - in - ext.ext_type_path, type_params - in - let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in - let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in - clear_hash (); - { ext_type_path = type_path; - ext_type_params = type_params; - ext_args = args; - ext_ret_type = ret_type; - ext_private = ext.ext_private; - ext_attributes = ext.ext_attributes; - ext_loc = ext.ext_loc; - } - with Not_found -> - clear_hash (); - raise Not_found - - -(* Preserve sharing inside class types. *) -let nondep_class_signature env id sign = - { csig_self = nondep_type_rec env id sign.csig_self; - csig_vars = - Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) - sign.csig_vars; - csig_concr = sign.csig_concr; - csig_inher = - List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl)) - sign.csig_inher } - -let rec nondep_class_type env id = - function - Cty_constr (p, _, cty) when Path.isfree id p -> - nondep_class_type env id cty - | Cty_constr (p, tyl, cty) -> - Cty_constr (p, List.map (nondep_type_rec env id) tyl, - nondep_class_type env id cty) - | Cty_signature sign -> - Cty_signature (nondep_class_signature env id sign) - | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, nondep_type_rec env id ty, nondep_class_type env id cty) - -let nondep_class_declaration env id decl = - assert (not (Path.isfree id decl.cty_path)); - let decl = - { cty_params = List.map (nondep_type_rec env id) decl.cty_params; - cty_variance = decl.cty_variance; - cty_type = nondep_class_type env id decl.cty_type; - cty_path = decl.cty_path; - cty_new = - begin match decl.cty_new with - None -> None - | Some ty -> Some (nondep_type_rec env id ty) - end; - cty_loc = decl.cty_loc; - cty_attributes = decl.cty_attributes; - } - in - clear_hash (); - decl - -let nondep_cltype_declaration env id decl = - assert (not (Path.isfree id decl.clty_path)); - let decl = - { clty_params = List.map (nondep_type_rec env id) decl.clty_params; - clty_variance = decl.clty_variance; - clty_type = nondep_class_type env id decl.clty_type; - clty_path = decl.clty_path; - clty_loc = decl.clty_loc; - clty_attributes = decl.clty_attributes; - } - in - clear_hash (); - decl - -(* collapse conjunctive types in class parameters *) -let rec collapse_conj env visited ty = - let ty = repr ty in - if List.memq ty visited then () else - let visited = ty :: visited in - match ty.desc with - Tvariant row -> - let row = row_repr row in - List.iter - (fun (_l,fi) -> - match row_field_repr fi with - Reither (c, t1::(_::_ as tl), m, e) -> - List.iter (unify env t1) tl; - set_row_field e (Reither (c, [t1], m, ref None)) - | _ -> - ()) - row.row_fields; - iter_row (collapse_conj env visited) row - | _ -> - iter_type_expr (collapse_conj env visited) ty - -let collapse_conj_params env params = - List.iter (collapse_conj env []) params - -let same_constr env t1 t2 = - let t1 = expand_head env t1 in - let t2 = expand_head env t2 in - match t1.desc, t2.desc with - | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 - | _ -> false - -let () = - Env.same_constr := same_constr - -let maybe_pointer_type env typ = - match (repr typ).desc with - | Tconstr(p, _args, _abbrev) -> - begin try - let type_decl = Env.find_type p env in - not type_decl.type_immediate - with Not_found -> true - (* This can happen due to e.g. missing -I options, - causing some .cmi files to be unavailable. - Maybe we should emit a warning. *) - end - | Tvariant row -> - let row = Btype.row_repr row in - (* if all labels are devoid of arguments, not a pointer *) - not row.row_closed - || List.exists - (function - | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true - | _ -> false) - row.row_fields - | _ -> true diff --git a/jscomp/ml/ctype.mli b/jscomp/ml/ctype.mli deleted file mode 100644 index 7b68649..0000000 --- a/jscomp/ml/ctype.mli +++ /dev/null @@ -1,293 +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. *) -(* *) -(**************************************************************************) - -(* Operations on core types *) - -open Asttypes -open Types - -exception Unify of (type_expr * type_expr) list -exception Tags of label * label -exception Subtype of - (type_expr * type_expr) list * (type_expr * type_expr) list -exception Cannot_expand -exception Cannot_apply -exception Recursive_abbrev -exception Unification_recursive_abbrev of (type_expr * type_expr) list - -val init_def: int -> unit - (* Set the initial variable level *) -val begin_def: unit -> unit - (* Raise the variable level by one at the beginning of a definition. *) -val end_def: unit -> unit - (* Lower the variable level by one at the end of a definition *) -val begin_class_def: unit -> unit -val raise_nongen_level: unit -> unit -val reset_global_level: unit -> unit - (* Reset the global level before typing an expression *) -val increase_global_level: unit -> int -val restore_global_level: int -> unit - (* This pair of functions is only used in Typetexp *) -type levels = - { current_level: int; nongen_level: int; global_level: int; - saved_level: (int * int) list; } -val save_levels: unit -> levels -val set_levels: levels -> unit - -val newty: type_desc -> type_expr -val newvar: ?name:string -> unit -> type_expr -val newvar2: ?name:string -> int -> type_expr - (* Return a fresh variable *) -val new_global_var: ?name:string -> unit -> type_expr - (* Return a fresh variable, bound at toplevel - (as type variables ['a] in type constraints). *) -val newobj: type_expr -> type_expr -val newconstr: Path.t -> type_expr list -> type_expr -val none: type_expr - (* A dummy type expression *) - -val repr: type_expr -> type_expr - (* Return the canonical representative of a type. *) - -val object_fields: type_expr -> type_expr -val flatten_fields: - type_expr -> (string * field_kind * type_expr) list * type_expr - (* Transform a field type into a list of pairs label-type *) - (* The fields are sorted *) -val associate_fields: - (string * field_kind * type_expr) list -> - (string * field_kind * type_expr) list -> - (string * field_kind * type_expr * field_kind * type_expr) list * - (string * field_kind * type_expr) list * - (string * field_kind * type_expr) list -val opened_object: type_expr -> bool -val close_object: type_expr -> unit -val row_variable: type_expr -> type_expr - (* Return the row variable of an open object type *) -val set_object_name: - Ident.t -> type_expr -> type_expr list -> type_expr -> unit -val remove_object_name: type_expr -> unit -val hide_private_methods: type_expr -> unit -val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr -val lid_of_path: ?hash:string -> Path.t -> Longident.t - -val sort_row_fields: (label * row_field) list -> (label * row_field) list -val merge_row_fields: - (label * row_field) list -> (label * row_field) list -> - (label * row_field) list * (label * row_field) list * - (label * row_field * row_field) list -val filter_row_fields: - bool -> (label * row_field) list -> (label * row_field) list - -val generalize: type_expr -> unit - (* Generalize in-place the given type *) -val generalize_expansive: Env.t -> type_expr -> unit - (* Generalize the covariant part of a type, making - contravariant branches non-generalizable *) -val generalize_global: type_expr -> unit - (* Generalize the structure of a type, lowering variables - to !global_level *) -val generalize_structure: type_expr -> unit - (* Same, but variables are only lowered to !current_level *) -val correct_levels: type_expr -> type_expr - (* Returns a copy with decreasing levels *) -val limited_generalize: type_expr -> type_expr -> unit - (* Only generalize some part of the type - Make the remaining of the type non-generalizable *) - -val instance: ?partial:bool -> Env.t -> type_expr -> type_expr - (* Take an instance of a type scheme *) - (* partial=None -> normal - partial=false -> newvar() for non generic subterms - partial=true -> newty2 ty.level Tvar for non generic subterms *) -val instance_def: type_expr -> type_expr - (* use defaults *) -val generic_instance: Env.t -> type_expr -> type_expr - (* Same as instance, but new nodes at generic_level *) -val instance_list: Env.t -> type_expr list -> type_expr list - (* Take an instance of a list of type schemes *) -val instance_constructor: - ?in_pattern:Env.t ref * int -> - constructor_description -> type_expr list * type_expr - (* Same, for a constructor *) -val instance_parameterized_type: - ?keep_names:bool -> - type_expr list -> type_expr -> type_expr list * type_expr -val instance_parameterized_type_2: - type_expr list -> type_expr list -> type_expr -> - type_expr list * type_expr list * type_expr -val instance_declaration: type_declaration -> type_declaration -val instance_class: - type_expr list -> class_type -> type_expr list * class_type -val instance_poly: - ?keep_names:bool -> - bool -> type_expr list -> type_expr -> type_expr list * type_expr - (* Take an instance of a type scheme containing free univars *) -val instance_label: - bool -> label_description -> type_expr list * type_expr * type_expr - (* Same, for a label *) -val apply: - Env.t -> type_expr list -> type_expr -> type_expr list -> type_expr - (* [apply [p1...pN] t [a1...aN]] match the arguments [ai] to - the parameters [pi] and returns the corresponding instance of - [t]. Exception [Cannot_apply] is raised in case of failure. *) - -val expand_head_once: Env.t -> type_expr -> type_expr -val expand_head: Env.t -> type_expr -> type_expr -val try_expand_once_opt: Env.t -> type_expr -> type_expr -val expand_head_opt: Env.t -> type_expr -> type_expr -(** The compiler's own version of [expand_head] necessary for type-based - optimisations. *) - -val full_expand: Env.t -> type_expr -> type_expr -val extract_concrete_typedecl: - Env.t -> type_expr -> Path.t * Path.t * type_declaration - (* Return the original path of the types, and the first concrete - type declaration found expanding it. - Raise [Not_found] if none appears or not a type constructor. *) - -val enforce_constraints: Env.t -> type_expr -> unit - -val unify: Env.t -> type_expr -> type_expr -> unit - (* Unify the two types given. Raise [Unify] if not possible. *) -val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit - (* Unify the two types given and update the environment with the - local constraints. Raise [Unify] if not possible. *) -val unify_var: Env.t -> type_expr -> type_expr -> unit - (* Same as [unify], but allow free univars when first type - is a variable. *) -val with_passive_variants: ('a -> 'b) -> ('a -> 'b) - (* Call [f] in passive_variants mode, for exhaustiveness check. *) -val filter_arrow: Env.t -> type_expr -> arg_label -> type_expr * type_expr - (* A special case of unification (with l:'a -> 'b). *) -val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr - (* A special case of unification (with {m : 'a; 'b}). *) -val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit - (* A special case of unification (with {m : 'a; 'b}), returning unit. *) -val occur_in: Env.t -> type_expr -> type_expr -> bool -val deep_occur: type_expr -> type_expr -> bool -val filter_self_method: - Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref -> - type_expr -> Ident.t * type_expr -val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool - (* Check if the first type scheme is more general than the second. *) - -val rigidify: type_expr -> type_expr list - (* "Rigidify" a type and return its type variable *) -val all_distinct_vars: Env.t -> type_expr list -> bool - (* Check those types are all distinct type variables *) -val matches: Env.t -> type_expr -> type_expr -> bool - (* Same as [moregeneral false], implemented using the two above - functions and backtracking. Ignore levels *) - -type class_match_failure = - CM_Virtual_class - | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Class_type_mismatch of Env.t * class_type * class_type - | CM_Parameter_mismatch of Env.t * (type_expr * type_expr) list - | CM_Val_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Meth_type_mismatch of string * Env.t * (type_expr * type_expr) list - | CM_Non_mutable_value of string - | CM_Non_concrete_value of string - | CM_Missing_value of string - | CM_Missing_method of string - | CM_Hide_public of string - | CM_Hide_virtual of string * string - | CM_Public_method of string - | CM_Private_method of string - | CM_Virtual_method of string -val match_class_types: - ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list - (* Check if the first class type is more general than the second. *) -val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool - (* [equal env [x1...xn] tau [y1...yn] sigma] - checks whether the parameterized types - [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) -val match_class_declarations: - Env.t -> type_expr list -> class_type -> type_expr list -> - class_type -> class_match_failure list - (* Check if the first class type is more general than the second. *) - -val enlarge_type: Env.t -> type_expr -> type_expr * bool - (* Make a type larger, flag is true if some pruning had to be done *) -val subtype: Env.t -> type_expr -> type_expr -> unit -> unit - (* [subtype env t1 t2] checks that [t1] is a subtype of [t2]. - It accumulates the constraints the type variables must - enforce and returns a function that enforces this - constraints. *) - -val nondep_type: Env.t -> Ident.t -> type_expr -> type_expr - (* Return a type equivalent to the given type but without - references to the given module identifier. Raise [Not_found] - if no such type exists. *) -val nondep_type_decl: - Env.t -> Ident.t -> Ident.t -> bool -> type_declaration -> - type_declaration - (* Same for type declarations. *) -val nondep_extension_constructor: - Env.t -> Ident.t -> extension_constructor -> - extension_constructor - (* Same for extension constructor *) -val nondep_class_declaration: - Env.t -> Ident.t -> class_declaration -> class_declaration - (* Same for class declarations. *) -val nondep_cltype_declaration: - Env.t -> Ident.t -> class_type_declaration -> class_type_declaration - (* Same for class type declarations. *) -(*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) -val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool -val is_contractive: Env.t -> Path.t -> bool -val normalize_type: Env.t -> type_expr -> unit - -val closed_schema: Env.t -> type_expr -> bool - (* Check whether the given type scheme contains no non-generic - type variables *) - -val free_variables: ?env:Env.t -> type_expr -> type_expr list - (* If env present, then check for incomplete definitions too *) -val closed_type_decl: type_declaration -> type_expr option -val closed_extension_constructor: extension_constructor -> type_expr option -type closed_class_failure = - CC_Method of type_expr * bool * string * type_expr - | CC_Value of type_expr * bool * string * type_expr -val closed_class: - type_expr list -> class_signature -> closed_class_failure option - (* Check whether all type variables are bound *) - -val unalias: type_expr -> type_expr -val signature_of_class_type: class_type -> class_signature -val self_type: class_type -> type_expr -val class_type_arity: class_type -> int -val arity: type_expr -> int - (* Return the arity (as for curried functions) of the given type. *) - -val collapse_conj_params: Env.t -> type_expr list -> unit - (* Collapse conjunctive types in class parameters *) - -val get_current_level: unit -> int -val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b -val reset_reified_var_counter: unit -> unit - -val maybe_pointer_type : Env.t -> type_expr -> bool - (* True if type is possibly pointer, false if definitely not a pointer *) - -(* Stubs *) -val package_subtype : - (Env.t -> Path.t -> Longident.t list -> type_expr list -> - Path.t -> Longident.t list -> type_expr list -> bool) ref - -val variant_is_subtype: - (Env.t -> Types.row_desc -> Types.type_expr -> bool) ref \ No newline at end of file diff --git a/jscomp/ml/datarepr.ml b/jscomp/ml/datarepr.ml deleted file mode 100644 index 8412621..0000000 --- a/jscomp/ml/datarepr.ml +++ /dev/null @@ -1,286 +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. *) -(* *) -(**************************************************************************) - -(* Compute constructor and label descriptions from type declarations, - determining their representation. *) - -open Asttypes -open Types -open Btype - -(* Simplified version of Ctype.free_vars *) -let free_vars ?(param=false) ty = - let ret = ref TypeSet.empty in - let rec loop ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - match ty.desc with - | Tvar _ -> - ret := TypeSet.add ty !ret - | Tvariant row -> - let row = row_repr row in - iter_row loop row; - if not (static_row row) then begin - match row.row_more.desc with - | Tvar _ when param -> ret := TypeSet.add ty !ret - | _ -> loop row.row_more - end - (* XXX: What about Tobject ? *) - | _ -> - iter_type_expr loop ty - end - in - loop ty; - unmark_type ty; - !ret - -let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) - -let constructor_existentials cd_args cd_res = - let tyl = - match cd_args with - | Cstr_tuple l -> l - | Cstr_record l -> List.map (fun l -> l.ld_type) l - in - let existentials = - match cd_res with - | None -> [] - | Some type_ret -> - let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in - let res_vars = free_vars type_ret in - TypeSet.elements (TypeSet.diff arg_vars_set res_vars) - in - (tyl, existentials) - -let constructor_args priv cd_args cd_res path rep = - let tyl, existentials = constructor_existentials cd_args cd_res in - match cd_args with - | Cstr_tuple l -> existentials, l, None - | Cstr_record lbls -> - let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in - let type_params = TypeSet.elements arg_vars_set in - let type_unboxed = - match rep with - | Record_unboxed _ -> unboxed_true_default_false - | _ -> unboxed_false_default_false - in - let tdecl = - { - type_params; - type_arity = List.length type_params; - type_kind = Type_record (lbls, rep); - type_private = priv; - type_manifest = None; - type_variance = List.map (fun _ -> Variance.full) type_params; - type_newtype_level = None; - type_loc = Location.none; - type_attributes = []; - type_immediate = false; - type_unboxed; - } - in - existentials, - [ newgenconstr path type_params ], - Some tdecl - -let internal_optional = "internal.optional" - -let optional_shape : Parsetree.attribute = - {txt = internal_optional ; loc = Location.none}, Parsetree.PStr [] - -let constructor_has_optional_shape ({cstr_attributes = attrs} : constructor_description) = - List.exists (fun (x,_) -> x.txt = internal_optional) attrs - - -let constructor_descrs ty_path decl cstrs = - let ty_res = newgenconstr ty_path decl.type_params in - let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in - List.iter - (fun {cd_args; cd_res; _} -> - if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; - if cd_res = None then incr num_normal) - cstrs; - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in - let rec describe_constructors idx_const idx_nonconst = function - [] -> [] - | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> - let ty_res = - match cd_res with - | Some ty_res' -> ty_res' - | None -> ty_res - in - let (tag, descr_rem) = - match cd_args with - | _ when decl.type_unboxed.unboxed -> - assert (rem = []); - (Cstr_unboxed, []) - | Cstr_tuple [] -> (Cstr_constant idx_const, - describe_constructors (idx_const+1) idx_nonconst rem) - | _ -> (Cstr_block idx_nonconst, - describe_constructors idx_const (idx_nonconst+1) rem) in - let cstr_name = Ident.name cd_id in - let optional_labels = match cd_args with - | Cstr_tuple _ -> [] - | Cstr_record lbls -> - Ext_list.filter_map lbls (fun ({ld_id;ld_attributes; _}) -> - if has_optional ld_attributes then Some ld_id.name else None) - in - let existentials, cstr_args, cstr_inlined = - let representation = - if decl.type_unboxed.unboxed - then Record_unboxed true - else Record_inlined {tag = idx_nonconst; name = cstr_name; num_nonconsts = !num_nonconsts; optional_labels; attrs = cd_attributes} - in - constructor_args decl.type_private cd_args cd_res - (Path.Pdot (ty_path, cstr_name, Path.nopos)) representation - in - let cstr = - { cstr_name; - cstr_res = ty_res; - cstr_existentials = existentials; - cstr_args; - cstr_arity = List.length cstr_args; - cstr_tag = tag; - cstr_consts = !num_consts; - cstr_nonconsts = !num_nonconsts; - cstr_normal = !num_normal; - cstr_private = decl.type_private; - cstr_generalized = cd_res <> None; - cstr_loc = cd_loc; - cstr_attributes = cd_attributes; - cstr_inlined; - } in - (cd_id, cstr) :: descr_rem in - let result = describe_constructors 0 0 cstrs in - match result with - | ( - [ ({Ident.name = "None"} as a_id, ({cstr_args = []} as a_descr) ) ; - ({Ident.name = "Some"} as b_id, ({ cstr_args = [_]} as b_descr)) - ] | - [ ({Ident.name = "Some"} as a_id, ({cstr_args = [_]} as a_descr) ) ; - ({Ident.name = "None"} as b_id, ({ cstr_args = []} as b_descr)) - ] - ) - -> - [ - (a_id, {a_descr with - cstr_attributes = - optional_shape :: a_descr.cstr_attributes}); - (b_id, {b_descr with - cstr_attributes = - optional_shape :: b_descr.cstr_attributes - }) - ] - | _ -> result - -let extension_descr path_ext ext = - let ty_res = - match ext.ext_ret_type with - Some type_ret -> type_ret - | None -> newgenconstr ext.ext_type_path ext.ext_type_params - in - let existentials, cstr_args, cstr_inlined = - constructor_args ext.ext_private ext.ext_args ext.ext_ret_type - path_ext Record_extension - in - { cstr_name = Path.last path_ext; - cstr_res = ty_res; - cstr_existentials = existentials; - cstr_args; - cstr_arity = List.length cstr_args; - cstr_tag = Cstr_extension(path_ext, cstr_args = []); - cstr_consts = -1; - cstr_nonconsts = -1; - cstr_private = ext.ext_private; - cstr_normal = -1; - cstr_generalized = ext.ext_ret_type <> None; - cstr_loc = ext.ext_loc; - cstr_attributes = ext.ext_attributes; - cstr_inlined; - } - -let none = {desc = Ttuple []; level = -1; id = -1} - (* Clearly ill-formed type *) -let dummy_label = - { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; - lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; - lbl_private = Public; - lbl_loc = Location.none; - lbl_attributes = []; - } - -let label_descrs ty_res lbls repres priv = - let all_labels = Array.make (List.length lbls) dummy_label in - let rec describe_labels num = function - [] -> [] - | l :: rest -> - let lbl = - { lbl_name = Ident.name l.ld_id; - lbl_res = ty_res; - lbl_arg = l.ld_type; - lbl_mut = l.ld_mutable; - lbl_pos = num; - lbl_all = all_labels; - lbl_repres = repres; - lbl_private = priv; - lbl_loc = l.ld_loc; - lbl_attributes = l.ld_attributes; - } in - all_labels.(num) <- lbl; - (l.ld_id, lbl) :: describe_labels (num+1) rest in - describe_labels 0 lbls - -exception Constr_not_found - -let rec find_constr tag num_const num_nonconst = function - [] -> - raise Constr_not_found - | {cd_args = Cstr_tuple []; _} as c :: rem -> - if Types.equal_tag tag (Cstr_constant num_const) - then c - else find_constr tag (num_const + 1) num_nonconst rem - | c :: rem -> - if Types.equal_tag tag (Cstr_block num_nonconst) || tag = Cstr_unboxed - then c - else find_constr tag num_const (num_nonconst + 1) rem - -let find_constr_by_tag tag cstrlist = - find_constr tag 0 0 cstrlist - -let constructors_of_type ty_path decl = - match decl.type_kind with - | Type_variant cstrs -> constructor_descrs ty_path decl cstrs - | Type_record _ | Type_abstract | Type_open -> [] - -let labels_of_type ty_path decl = - match decl.type_kind with - | Type_record(labels, rep) -> - label_descrs (newgenconstr ty_path decl.type_params) - labels rep decl.type_private - | Type_variant _ | Type_abstract | Type_open -> [] - -(* Set row_name in Env, cf. GPR#1204/1329 *) -let set_row_name decl path = - match decl.type_manifest with - None -> () - | Some ty -> - let ty = repr ty in - match ty.desc with - Tvariant row when static_row row -> - let row = {(row_repr row) with - row_name = Some (path, decl.type_params)} in - ty.desc <- Tvariant row - | _ -> () diff --git a/jscomp/ml/datarepr.mli b/jscomp/ml/datarepr.mli deleted file mode 100644 index f6bc50f..0000000 --- a/jscomp/ml/datarepr.mli +++ /dev/null @@ -1,51 +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. *) -(* *) -(**************************************************************************) - -(* Compute constructor and label descriptions from type declarations, - determining their representation. *) - -open Types - -val constructor_has_optional_shape: - Types.constructor_description -> bool - -val extension_descr: - Path.t -> extension_constructor -> constructor_description - -val labels_of_type: - Path.t -> type_declaration -> - (Ident.t * label_description) list -val constructors_of_type: - Path.t -> type_declaration -> - (Ident.t * constructor_description) list - - -exception Constr_not_found - -val find_constr_by_tag: - constructor_tag -> constructor_declaration list -> - constructor_declaration - -val constructor_existentials : - constructor_arguments -> type_expr option -> type_expr list * type_expr list -(** Takes [cd_args] and [cd_res] from a [constructor_declaration] and - returns: - - the types of the constructor's arguments - - the existential variables introduced by the constructor - *) - - -(* Set the polymorphic variant row_name field *) -val set_row_name : type_declaration -> Path.t -> unit diff --git a/jscomp/ml/depend.ml b/jscomp/ml/depend.ml deleted file mode 100644 index 5a4a336..0000000 --- a/jscomp/ml/depend.ml +++ /dev/null @@ -1,501 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Location -open Longident -open Parsetree - -let pp_deps = ref [] - -module StringSet = Set.Make(struct type t = string let compare = compare end) -module StringMap = Map.Make(String) - -(* Module resolution map *) -(* Node (set of imports for this path, map for submodules) *) -type map_tree = Node of StringSet.t * bound_map -and bound_map = map_tree StringMap.t -let bound = Node (StringSet.empty, StringMap.empty) - -(*let get_free (Node (s, _m)) = s*) -let get_map (Node (_s, m)) = m -let make_leaf s = Node (StringSet.singleton s, StringMap.empty) -let make_node m = Node (StringSet.empty, m) -let rec weaken_map s (Node(s0,m0)) = - Node (StringSet.union s s0, StringMap.map (weaken_map s) m0) -let rec collect_free (Node (s, m)) = - StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s - -(* Returns the imports required to access the structure at path p *) -(* Only raises Not_found if the head of p is not in the toplevel map *) -let rec lookup_free p m = - match p with - [] -> raise Not_found - | s::p -> - let Node (f, m') = StringMap.find s m in - try lookup_free p m' with Not_found -> f - -(* Returns the node corresponding to the structure at path p *) -let rec lookup_map lid m = - match lid with - Lident s -> StringMap.find s m - | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m)) - | Lapply _ -> raise Not_found - -(* Collect free module identifiers in the a.s.t. *) - -let free_structure_names = ref StringSet.empty - -let add_names s = - free_structure_names := StringSet.union s !free_structure_names - -let rec add_path bv ?(p=[]) = function - | Lident s -> - let free = - try lookup_free (s::p) bv with Not_found -> StringSet.singleton s - in - (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free; - prerr_endline "";*) - add_names free - | Ldot(l, s) -> add_path bv ~p:(s::p) l - | Lapply(l1, l2) -> add_path bv l1; add_path bv l2 - -let open_module bv lid = - match lookup_map lid bv with - | Node (s, m) -> - add_names s; - StringMap.fold StringMap.add m bv - | exception Not_found -> - add_path bv lid; bv - -let add_parent bv lid = - match lid.txt with - Ldot(l, _s) -> add_path bv l - | _ -> () - -let add = add_parent - -let addmodule bv lid = add_path bv lid.txt - -let handle_extension ext = - match (fst ext).txt with - | "error" | "ocaml.error" -> - raise (Location.Error - (Builtin_attributes.error_of_extension ext)) - | _ -> - () - -let rec add_type bv ty = - match ty.ptyp_desc with - Ptyp_any -> () - | Ptyp_var _ -> () - | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 - | Ptyp_tuple tl -> List.iter (add_type bv) tl - | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl - | Ptyp_object (fl, _) -> - List.iter - (function Otag (_, _, t) -> add_type bv t - | Oinherit t -> add_type bv t) fl - | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl - | Ptyp_alias(t, _) -> add_type bv t - | Ptyp_variant(fl, _, _) -> - List.iter - (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl - | Rinherit sty -> add_type bv sty) - fl - | Ptyp_poly(_, t) -> add_type bv t - | Ptyp_package pt -> add_package_type bv pt - | Ptyp_extension e -> handle_extension e - -and add_package_type bv (lid, l) = - add bv lid; - List.iter (add_type bv) (List.map (fun (_, e) -> e) l) - -let add_opt add_fn bv = function - None -> () - | Some x -> add_fn bv x - -let add_constructor_arguments bv = function - | Pcstr_tuple l -> List.iter (add_type bv) l - | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l - -let add_constructor_decl bv pcd = - add_constructor_arguments bv pcd.pcd_args; - Misc.may (add_type bv) pcd.pcd_res - -let add_type_declaration bv td = - List.iter - (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) - td.ptype_cstrs; - add_opt add_type bv td.ptype_manifest; - let add_tkind = function - Ptype_abstract -> () - | Ptype_variant cstrs -> - List.iter (add_constructor_decl bv) cstrs - | Ptype_record lbls -> - List.iter (fun pld -> add_type bv pld.pld_type) lbls - | Ptype_open -> () in - add_tkind td.ptype_kind - -let add_extension_constructor bv ext = - match ext.pext_kind with - Pext_decl(args, rty) -> - add_constructor_arguments bv args; - Misc.may (add_type bv) rty - | Pext_rebind lid -> add bv lid - -let add_type_extension bv te = - add bv te.ptyext_path; - List.iter (add_extension_constructor bv) te.ptyext_constructors - -let rec add_class_type bv cty = - match cty.pcty_desc with - Pcty_constr(l, tyl) -> - add bv l; List.iter (add_type bv) tyl - | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> - add_type bv ty; - List.iter (add_class_type_field bv) fieldl - | Pcty_arrow(_, ty1, cty2) -> - add_type bv ty1; add_class_type bv cty2 - | Pcty_extension e -> handle_extension e - | Pcty_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_class_type bv e - -and add_class_type_field bv pctf = - match pctf.pctf_desc with - Pctf_inherit cty -> add_class_type bv cty - | Pctf_val(_, _, _, ty) -> add_type bv ty - | Pctf_method(_, _, _, ty) -> add_type bv ty - | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 - | Pctf_attribute _ -> () - | Pctf_extension e -> handle_extension e - -let add_class_description bv infos = - add_class_type bv infos.pci_expr - -let add_class_type_declaration = add_class_description - -let pattern_bv = ref StringMap.empty - -let rec add_pattern bv pat = - match pat.ppat_desc with - Ppat_any -> () - | Ppat_var _ -> () - | Ppat_alias(p, _) -> add_pattern bv p - | Ppat_interval _ - | Ppat_constant _ -> () - | Ppat_tuple pl -> List.iter (add_pattern bv) pl - | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op - | Ppat_record(pl, _) -> - List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl - | Ppat_array pl -> List.iter (add_pattern bv) pl - | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 - | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty - | Ppat_variant(_, op) -> add_opt add_pattern bv op - | Ppat_type li -> add bv li - | Ppat_lazy p -> add_pattern bv p - | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv - | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p - | Ppat_exception p -> add_pattern bv p - | Ppat_extension e -> handle_extension e - -let add_pattern bv pat = - pattern_bv := bv; - add_pattern bv pat; - !pattern_bv - -let rec add_expr bv exp = - match exp.pexp_desc with - Pexp_ident l -> add bv l - | Pexp_constant _ -> () - | Pexp_let(rf, pel, e) -> - let bv = add_bindings rf bv pel in add_expr bv e - | Pexp_fun (_, opte, p, e) -> - add_opt add_expr bv opte; add_expr (add_pattern bv p) e - | Pexp_function pel -> - add_cases bv pel - | Pexp_apply(e, el) -> - add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el - | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel - | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel - | Pexp_tuple el -> List.iter (add_expr bv) el - | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte - | Pexp_variant(_, opte) -> add_opt add_expr bv opte - | Pexp_record(lblel, opte) -> - List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; - add_opt add_expr bv opte - | Pexp_field(e, fld) -> add_expr bv e; add bv fld - | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 - | Pexp_array el -> List.iter (add_expr bv) el - | Pexp_ifthenelse(e1, e2, opte3) -> - add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 - | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 - | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 - | Pexp_for( _, e1, e2, _, e3) -> - add_expr bv e1; add_expr bv e2; add_expr bv e3 - | Pexp_coerce(e1, oty2, ty3) -> - add_expr bv e1; - add_opt add_type bv oty2; - add_type bv ty3 - | Pexp_constraint(e1, ty2) -> - add_expr bv e1; - add_type bv ty2 - | Pexp_send(e, _m) -> add_expr bv e - | Pexp_new li -> add bv li - | Pexp_setinstvar(_v, e) -> add_expr bv e - | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel - | Pexp_letmodule(id, m, e) -> - let b = add_module_binding bv m in - add_expr (StringMap.add id.txt b bv) e - | Pexp_letexception(_, e) -> add_expr bv e - | Pexp_assert (e) -> add_expr bv e - | Pexp_lazy (e) -> add_expr bv e - | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t - | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } -> - let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl - | Pexp_newtype (_, e) -> add_expr bv e - | Pexp_pack m -> add_module bv m - | Pexp_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_expr bv e - | Pexp_extension (({ txt = ("ocaml.extension_constructor"| - "extension_constructor"); _ }, - PStr [item]) as e) -> - begin match item.pstr_desc with - | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c - | _ -> handle_extension e - end - | Pexp_extension e -> handle_extension e - | Pexp_unreachable -> () - -and add_cases bv cases = - List.iter (add_case bv) cases - -and add_case bv {pc_lhs; pc_guard; pc_rhs} = - let bv = add_pattern bv pc_lhs in - add_opt add_expr bv pc_guard; - add_expr bv pc_rhs - -and add_bindings recf bv pel = - let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in - let bv = if recf = Recursive then bv' else bv in - List.iter (fun x -> add_expr bv x.pvb_expr) pel; - bv' - -and add_modtype bv mty = - match mty.pmty_desc with - Pmty_ident l -> add bv l - | Pmty_alias l -> addmodule bv l - | Pmty_signature s -> add_signature bv s - | Pmty_functor(id, mty1, mty2) -> - Misc.may (add_modtype bv) mty1; - add_modtype (StringMap.add id.txt bound bv) mty2 - | Pmty_with(mty, cstrl) -> - add_modtype bv mty; - List.iter - (function - | Pwith_type (_, td) -> add_type_declaration bv td - | Pwith_module (_, lid) -> addmodule bv lid - | Pwith_typesubst (_, td) -> add_type_declaration bv td - | Pwith_modsubst (_, lid) -> addmodule bv lid - ) - cstrl - | Pmty_typeof m -> add_module bv m - | Pmty_extension e -> handle_extension e - -and add_module_alias bv l = - try - add_parent bv l; - lookup_map l.txt bv - with Not_found -> - match l.txt with - Lident s -> make_leaf s - | _ -> addmodule bv l; bound (* cannot delay *) - -and add_modtype_binding bv mty = - if not !Clflags.transparent_modules then add_modtype bv mty; - match mty.pmty_desc with - Pmty_alias l -> - add_module_alias bv l - | Pmty_signature s -> - make_node (add_signature_binding bv s) - | Pmty_typeof modl -> - add_module_binding bv modl - | _ -> - if !Clflags.transparent_modules then add_modtype bv mty; bound - -and add_signature bv sg = - ignore (add_signature_binding bv sg) - -and add_signature_binding bv sg = - snd (List.fold_left add_sig_item (bv, StringMap.empty) sg) - -and add_sig_item (bv, m) item = - match item.psig_desc with - Psig_value vd -> - add_type bv vd.pval_type; (bv, m) - | Psig_type (_, dcls) -> - List.iter (add_type_declaration bv) dcls; (bv, m) - | Psig_typext te -> - add_type_extension bv te; (bv, m) - | Psig_exception pext -> - add_extension_constructor bv pext; (bv, m) - | Psig_module pmd -> - let m' = add_modtype_binding bv pmd.pmd_type in - let add = StringMap.add pmd.pmd_name.txt m' in - (add bv, add m) - | Psig_recmodule decls -> - let add = - List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound) - decls - in - let bv' = add bv and m' = add m in - List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; - (bv', m') - | Psig_modtype x -> - begin match x.pmtd_type with - None -> () - | Some mty -> add_modtype bv mty - end; - (bv, m) - | Psig_open od -> - (open_module bv od.popen_lid.txt, m) - | Psig_include incl -> - let Node (s, m') = add_modtype_binding bv incl.pincl_mod in - add_names s; - let add = StringMap.fold StringMap.add m' in - (add bv, add m) - | Psig_class () -> - (bv, m) - | Psig_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) - | Psig_attribute _ -> (bv, m) - | Psig_extension (e, _) -> - handle_extension e; - (bv, m) - -and add_module_binding bv modl = - if not !Clflags.transparent_modules then add_module bv modl; - match modl.pmod_desc with - Pmod_ident l -> - begin try - add_parent bv l; - lookup_map l.txt bv - with Not_found -> - match l.txt with - Lident s -> make_leaf s - | _ -> addmodule bv l; bound - end - | Pmod_structure s -> - make_node (snd (add_structure_binding bv s)) - | _ -> - if !Clflags.transparent_modules then add_module bv modl; bound - -and add_module bv modl = - match modl.pmod_desc with - Pmod_ident l -> addmodule bv l - | Pmod_structure s -> ignore (add_structure bv s) - | Pmod_functor(id, mty, modl) -> - Misc.may (add_modtype bv) mty; - add_module (StringMap.add id.txt bound bv) modl - | Pmod_apply(mod1, mod2) -> - add_module bv mod1; add_module bv mod2 - | Pmod_constraint(modl, mty) -> - add_module bv modl; add_modtype bv mty - | Pmod_unpack(e) -> - add_expr bv e - | Pmod_extension e -> - handle_extension e - -and add_structure bv item_list = - let (bv, m) = add_structure_binding bv item_list in - add_names (collect_free (make_node m)); - bv - -and add_structure_binding bv item_list = - List.fold_left add_struct_item (bv, StringMap.empty) item_list - -and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = - match item.pstr_desc with - Pstr_eval (e, _attrs) -> - add_expr bv e; (bv, m) - | Pstr_value(rf, pel) -> - let bv = add_bindings rf bv pel in (bv, m) - | Pstr_primitive vd -> - add_type bv vd.pval_type; (bv, m) - | Pstr_type (_, dcls) -> - List.iter (add_type_declaration bv) dcls; (bv, m) - | Pstr_typext te -> - add_type_extension bv te; - (bv, m) - | Pstr_exception pext -> - add_extension_constructor bv pext; (bv, m) - | Pstr_module x -> - let b = add_module_binding bv x.pmb_expr in - let add = StringMap.add x.pmb_name.txt b in - (add bv, add m) - | Pstr_recmodule bindings -> - let add = - List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings - in - let bv' = add bv and m = add m in - List.iter - (fun x -> add_module bv' x.pmb_expr) - bindings; - (bv', m) - | Pstr_modtype x -> - begin match x.pmtd_type with - None -> () - | Some mty -> add_modtype bv mty - end; - (bv, m) - | Pstr_open od -> - (open_module bv od.popen_lid.txt, m) - | Pstr_class () -> - (bv,m) - | Pstr_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) - | Pstr_include incl -> - let Node (s, m') = add_module_binding bv incl.pincl_mod in - add_names s; - let add = StringMap.fold StringMap.add m' in - (add bv, add m) - | Pstr_attribute _ -> (bv, m) - | Pstr_extension (e, _) -> - handle_extension e; - (bv, m) - - -and add_implementation bv l = - if !Clflags.transparent_modules then - ignore (add_structure_binding bv l) - else ignore (add_structure bv l) - -and add_implementation_binding bv l = - snd (add_structure_binding bv l) - - - -and add_class_field bv pcf = - match pcf.pcf_desc with - Pcf_inherit() -> () - | Pcf_val(_, _, Cfk_concrete (_, e)) - | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e - | Pcf_val(_, _, Cfk_virtual ty) - | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty - | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 - | Pcf_initializer e -> add_expr bv e - | Pcf_attribute _ -> () - | Pcf_extension e -> handle_extension e - diff --git a/jscomp/ml/docstrings.ml b/jscomp/ml/docstrings.ml deleted file mode 100644 index 85c58ad..0000000 --- a/jscomp/ml/docstrings.ml +++ /dev/null @@ -1,343 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -open Location - -(* Docstrings *) - -(* A docstring is "attached" if it has been inserted in the AST. This - is used for generating unexpected docstring warnings. *) -type ds_attached = - | Unattached (* Not yet attached anything.*) - | Info (* Attached to a field or constructor. *) - | Docs (* Attached to an item or as floating text. *) - -(* A docstring is "associated" with an item if there are no blank lines between - them. This is used for generating docstring ambiguity warnings. *) -type ds_associated = - | Zero (* Not associated with an item *) - | One (* Associated with one item *) - | Many (* Associated with multiple items (ambiguity) *) - -type docstring = - { ds_body: string; - ds_loc: Location.t; - mutable ds_attached: ds_attached; - mutable ds_associated: ds_associated; } - -(* List of docstrings *) - -let docstrings : docstring list ref = ref [] - -(* Warn for unused and ambiguous docstrings *) - -let warn_bad_docstrings () = - if Warnings.is_active (Warnings.Bad_docstring true) then begin - List.iter - (fun ds -> - match ds.ds_attached with - | Info -> () - | Unattached -> - prerr_warning ds.ds_loc (Warnings.Bad_docstring true) - | Docs -> - match ds.ds_associated with - | Zero | One -> () - | Many -> - prerr_warning ds.ds_loc (Warnings.Bad_docstring false)) - (List.rev !docstrings) -end - -(* Docstring constructors and destructors *) - -let docstring body loc = - let ds = - { ds_body = body; - ds_loc = loc; - ds_attached = Unattached; - ds_associated = Zero; } - in - ds - -let register ds = - docstrings := ds :: !docstrings - -let docstring_body ds = ds.ds_body - -let docstring_loc ds = ds.ds_loc - -(* Docstrings attached to items *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -let empty_docs = { docs_pre = None; docs_post = None } - -let doc_loc = {txt = "ocaml.doc"; loc = Location.none} - -let docs_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (doc_loc, PStr [item]) - -let add_docs_attrs docs attrs = - let attrs = - match docs.docs_pre with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> docs_attr ds :: attrs - in - let attrs = - match docs.docs_post with - | None | Some { ds_body=""; _ } -> attrs - | Some ds -> attrs @ [docs_attr ds] - in - attrs - -(* Docstrings attached to constructors or fields *) - -type info = docstring option - -let empty_info = None - -let info_attr = docs_attr - -let add_info_attrs info attrs = - match info with - | None | Some {ds_body=""; _} -> attrs - | Some ds -> attrs @ [info_attr ds] - -(* Docstrings not attached to a specific item *) - -type text = docstring list - -let empty_text = [] -let empty_text_lazy = lazy [] - -let text_loc = {txt = "ocaml.text"; loc = Location.none} - -let text_attr ds = - let open Parsetree in - let exp = - { pexp_desc = Pexp_constant (Pconst_string(ds.ds_body, None)); - pexp_loc = ds.ds_loc; - pexp_attributes = []; } - in - let item = - { pstr_desc = Pstr_eval (exp, []); pstr_loc = exp.pexp_loc } - in - (text_loc, PStr [item]) - -let add_text_attrs dsl attrs = - let fdsl = Ext_list.filter dsl (function {ds_body=""} -> false| _ ->true) in - (List.map text_attr fdsl) @ attrs - -(* Find the first non-info docstring in a list, attach it and return it *) -let get_docstring ~info dsl = - let rec loop = function - | [] -> None - | {ds_attached = Info; _} :: rest -> loop rest - | ds :: _ -> - ds.ds_attached <- if info then Info else Docs; - Some ds - in - loop dsl - -(* Find all the non-info docstrings in a list, attach them and return them *) -let get_docstrings dsl = - let rec loop acc = function - | [] -> List.rev acc - | {ds_attached = Info; _} :: rest -> loop acc rest - | ds :: rest -> - ds.ds_attached <- Docs; - loop (ds :: acc) rest - in - loop [] dsl - -(* "Associate" all the docstrings in a list *) -let associate_docstrings dsl = - List.iter - (fun ds -> - match ds.ds_associated with - | Zero -> ds.ds_associated <- One - | (One | Many) -> ds.ds_associated <- Many) - dsl - -(* Map from positions to pre docstrings *) - -let pre_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_table pos dsl - -let get_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_pre_docs pos = - try - let dsl = Hashtbl.find pre_table pos in - associate_docstrings dsl - with Not_found -> () - -(* Map from positions to post docstrings *) - -let post_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_table pos dsl - -let get_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl; - get_docstring ~info:false dsl - with Not_found -> None - -let mark_post_docs pos = - try - let dsl = Hashtbl.find post_table pos in - associate_docstrings dsl - with Not_found -> () - -let get_info pos = - try - let dsl = Hashtbl.find post_table pos in - get_docstring ~info:true dsl - with Not_found -> None - -(* Map from positions to floating docstrings *) - -let floating_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_floating_docstrings pos dsl = - if dsl <> [] then Hashtbl.add floating_table pos dsl - -let get_text pos = - try - let dsl = Hashtbl.find floating_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Maps from positions to extra docstrings *) - -let pre_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_pre_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add pre_extra_table pos dsl - -let get_pre_extra_text pos = - try - let dsl = Hashtbl.find pre_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -let post_extra_table : (Lexing.position, docstring list) Hashtbl.t = - Hashtbl.create 50 - -let set_post_extra_docstrings pos dsl = - if dsl <> [] then Hashtbl.add post_extra_table pos dsl - -let get_post_extra_text pos = - try - let dsl = Hashtbl.find post_extra_table pos in - get_docstrings dsl - with Not_found -> [] - -(* Docstrings from parser actions *) - -let symbol_docs () = - { docs_pre = get_pre_docs (Parsing.symbol_start_pos ()); - docs_post = get_post_docs (Parsing.symbol_end_pos ()); } - -let symbol_docs_lazy () = - let p1 = Parsing.symbol_start_pos () in - let p2 = Parsing.symbol_end_pos () in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let rhs_docs pos1 pos2 = - { docs_pre = get_pre_docs (Parsing.rhs_start_pos pos1); - docs_post = get_post_docs (Parsing.rhs_end_pos pos2); } - -let rhs_docs_lazy pos1 pos2 = - let p1 = Parsing.rhs_start_pos pos1 in - let p2 = Parsing.rhs_end_pos pos2 in - lazy { docs_pre = get_pre_docs p1; - docs_post = get_post_docs p2; } - -let mark_symbol_docs () = - mark_pre_docs (Parsing.symbol_start_pos ()); - mark_post_docs (Parsing.symbol_end_pos ()) - -let mark_rhs_docs pos1 pos2 = - mark_pre_docs (Parsing.rhs_start_pos pos1); - mark_post_docs (Parsing.rhs_end_pos pos2) - -let symbol_info () = - get_info (Parsing.symbol_end_pos ()) - -let rhs_info pos = - get_info (Parsing.rhs_end_pos pos) - -let symbol_text () = - get_text (Parsing.symbol_start_pos ()) - -let symbol_text_lazy () = - let pos = Parsing.symbol_start_pos () in - lazy (get_text pos) - -let rhs_text pos = - get_text (Parsing.rhs_start_pos pos) - -let rhs_text_lazy pos = - let pos = Parsing.rhs_start_pos pos in - lazy (get_text pos) - -let symbol_pre_extra_text () = - get_pre_extra_text (Parsing.symbol_start_pos ()) - -let symbol_post_extra_text () = - get_post_extra_text (Parsing.symbol_end_pos ()) - -let rhs_pre_extra_text pos = - get_pre_extra_text (Parsing.rhs_start_pos pos) - -let rhs_post_extra_text pos = - get_post_extra_text (Parsing.rhs_end_pos pos) - - -(* (Re)Initialise all comment state *) - -let init () = - docstrings := []; - Hashtbl.reset pre_table; - Hashtbl.reset post_table; - Hashtbl.reset floating_table; - Hashtbl.reset pre_extra_table; - Hashtbl.reset post_extra_table diff --git a/jscomp/ml/docstrings.mli b/jscomp/ml/docstrings.mli deleted file mode 100644 index 892a80e..0000000 --- a/jscomp/ml/docstrings.mli +++ /dev/null @@ -1,157 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Documentation comments *) - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text diff --git a/jscomp/ml/dune b/jscomp/ml/dune deleted file mode 100644 index 93a50c6..0000000 --- a/jscomp/ml/dune +++ /dev/null @@ -1,11 +0,0 @@ -(library - (name ml) - (wrapped false) - (preprocess - (action - (run %{bin:cppo} %{env:CPPO_FLAGS=} %{input-file}))) - (flags - (:standard -w -A)) - (libraries ext js_parser)) - -(ocamllex lexer) diff --git a/jscomp/ml/env.ml b/jscomp/ml/env.ml deleted file mode 100644 index 8a914c8..0000000 --- a/jscomp/ml/env.ml +++ /dev/null @@ -1,2325 +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. *) -(* *) -(**************************************************************************) - -(* Environment handling *) - -open Cmi_format -open Config -open Misc -open Asttypes -open Longident -open Path -open Types -open Btype - - - -let value_declarations : ((string * Location.t), (unit -> unit)) Hashtbl.t = - Hashtbl.create 16 - (* This table is used to usage of value declarations. A declaration is - identified with its name and location. The callback attached to a - declaration is called whenever the value is used explicitly - (lookup_value) or implicitly (inclusion test between signatures, - cf Includemod.value_descriptions). *) - -let type_declarations = Hashtbl.create 16 -let module_declarations = Hashtbl.create 16 - -type constructor_usage = Positive | Pattern | Privatize -type constructor_usages = - { - mutable cu_positive: bool; - mutable cu_pattern: bool; - mutable cu_privatize: bool; - } -let add_constructor_usage cu = function - | Positive -> cu.cu_positive <- true - | Pattern -> cu.cu_pattern <- true - | Privatize -> cu.cu_privatize <- true -let constructor_usages () = - {cu_positive = false; cu_pattern = false; cu_privatize = false} - -let used_constructors : - (string * Location.t * string, (constructor_usage -> unit)) Hashtbl.t - = Hashtbl.create 16 - -let prefixed_sg = Hashtbl.create 113 - -type error = - | Illegal_renaming of string * string * string - | Inconsistent_import of string * string * string - | Need_recursive_types of string * string - | Missing_module of Location.t * Path.t * Path.t - | Illegal_value_name of Location.t * string - -exception Error of error - -let error err = raise (Error err) - -module EnvLazy : sig - type ('a,'b) t - - type log - - val force : ('a -> 'b) -> ('a,'b) t -> 'b - val create : 'a -> ('a,'b) t - val get_arg : ('a,'b) t -> 'a option - - (* [force_logged log f t] is equivalent to [force f t] but if [f] returns [None] then - [t] is recorded in [log]. [backtrack log] will then reset all the recorded [t]s back - to their original state. *) - val log : unit -> log - val force_logged : log -> ('a -> 'b option) -> ('a,'b option) t -> 'b option - val backtrack : log -> unit - -end = struct - - type ('a,'b) t = ('a,'b) eval ref - - and ('a,'b) eval = - | Done of 'b - | Raise of exn - | Thunk of 'a - - type undo = - | Nil - | Cons : ('a, 'b) t * 'a * undo -> undo - - type log = undo ref - - let force f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | y -> - x := Done y; - y - | exception e -> - x := Raise e; - raise e - - let get_arg x = - match !x with Thunk a -> Some a | _ -> None - - let create x = - ref (Thunk x) - - let log () = - ref Nil - - let force_logged log f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | None -> - x := Done None; - log := Cons(x, e, !log); - None - | Some _ as y -> - x := Done y; - y - | exception e -> - x := Raise e; - raise e - - let backtrack log = - let rec loop = function - | Nil -> () - | Cons(x, e, rest) -> - x := Thunk e; - loop rest - in - loop !log - -end - -module PathMap = Map.Make(Path) - -type summary = - Env_empty - | Env_value of summary * Ident.t * value_description - | Env_type of summary * Ident.t * type_declaration - | Env_extension of summary * Ident.t * extension_constructor - | Env_module of summary * Ident.t * module_declaration - | Env_modtype of summary * Ident.t * modtype_declaration - | Env_class of unit - | Env_cltype of summary * Ident.t * class_type_declaration - | Env_open of summary * Path.t - | Env_functor_arg of summary * Ident.t - | Env_constraints of summary * type_declaration PathMap.t - | Env_copy_types of summary * string list - -module TycompTbl = - struct - (** This module is used to store components of types (i.e. labels - and constructors). We keep a representation of each nested - "open" and the set of local bindings between each of them. *) - - type 'a t = { - current: 'a Ident.tbl; - (** Local bindings since the last open. *) - - opened: 'a opened option; - (** Symbolic representation of the last (innermost) open, if any. *) - } - - and 'a opened = { - components: (string, 'a list) Tbl.t; - (** Components from the opened module. We keep a list of - bindings for each name, as in comp_labels and - comp_constrs. *) - - using: (string -> ('a * 'a) option -> unit) option; - (** A callback to be applied when a component is used from this - "open". This is used to detect unused "opens". The - arguments are used to detect shadowing. *) - - next: 'a t; - (** The table before opening the module. *) - } - - let empty = { current = Ident.empty; opened = None } - - let add id x tbl = - {tbl with current = Ident.add id x tbl.current} - - let add_open slot wrap components next = - let using = - match slot with - | None -> None - | Some f -> Some (fun s x -> f s (wrap x)) - in - { - current = Ident.empty; - opened = Some {using; components; next}; - } - - let rec find_same id tbl = - try Ident.find_same id tbl.current - with Not_found as exn -> - begin match tbl.opened with - | Some {next; _} -> find_same id next - | None -> raise exn - end - - let nothing = fun () -> () - - let mk_callback rest name desc = function - | None -> nothing - | Some f -> - (fun () -> - match rest with - | [] -> f name None - | (hidden, _) :: _ -> f name (Some (desc, hidden)) - ) - - let rec find_all name tbl = - List.map (fun (_id, desc) -> desc, nothing) - (Ident.find_all name tbl.current) @ - match tbl.opened with - | None -> [] - | Some {using; next; components} -> - let rest = find_all name next in - match Tbl.find_str name components with - | exception Not_found -> rest - | opened -> - List.map - (fun desc -> desc, mk_callback rest name desc using) - opened - @ rest - - let rec fold_name f tbl acc = - let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in - match tbl.opened with - | Some {using = _; next; components} -> - acc - |> Tbl.fold - (fun _name -> List.fold_right (fun desc -> f desc)) - components - |> fold_name f next - | None -> - acc - - let rec local_keys tbl acc = - let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in - match tbl.opened with - | Some o -> local_keys o.next acc - | None -> acc - - let diff_keys is_local tbl1 tbl2 = - let keys2 = local_keys tbl2 [] in - Ext_list.filter keys2 - (fun id -> - is_local (find_same id tbl2) && - try ignore (find_same id tbl1); false - with Not_found -> true) - - end - - -module IdTbl = - struct - (** This module is used to store all kinds of components except - (labels and constructors) in environments. We keep a - representation of each nested "open" and the set of local - bindings between each of them. *) - - - type 'a t = { - current: 'a Ident.tbl; - (** Local bindings since the last open *) - - opened: 'a opened option; - (** Symbolic representation of the last (innermost) open, if any. *) - } - - and 'a opened = { - root: Path.t; - (** The path of the opened module, to be prefixed in front of - its local names to produce a valid path in the current - environment. *) - - components: (string, 'a * int) Tbl.t; - (** Components from the opened module. *) - - using: (string -> ('a * 'a) option -> unit) option; - (** A callback to be applied when a component is used from this - "open". This is used to detect unused "opens". The - arguments are used to detect shadowing. *) - - next: 'a t; - (** The table before opening the module. *) - } - - let empty = { current = Ident.empty; opened = None } - - let add id x tbl = - {tbl with current = Ident.add id x tbl.current} - - let add_open slot wrap root components next = - let using = - match slot with - | None -> None - | Some f -> Some (fun s x -> f s (wrap x)) - in - { - current = Ident.empty; - opened = Some {using; root; components; next}; - } - - let rec find_same id tbl = - try Ident.find_same id tbl.current - with Not_found as exn -> - begin match tbl.opened with - | Some {next; _} -> find_same id next - | None -> raise exn - end - - let rec find_name mark name tbl = - try - let (id, desc) = Ident.find_name name tbl.current in - Pident id, desc - with Not_found as exn -> - begin match tbl.opened with - | Some {using; root; next; components} -> - begin try - let (descr, pos) = Tbl.find_str name components in - let res = Pdot (root, name, pos), descr in - if mark then begin match using with - | None -> () - | Some f -> - begin try f name (Some (snd (find_name false name next), snd res)) - with Not_found -> f name None - end - end; - res - with Not_found -> - find_name mark name next - end - | None -> - raise exn - end - - let find_name name tbl = find_name true name tbl - - let rec update name f tbl = - try - let (id, desc) = Ident.find_name name tbl.current in - let new_desc = f desc in - {tbl with current = Ident.add id new_desc tbl.current} - with Not_found -> - begin match tbl.opened with - | Some {root; using; next; components} -> - begin try - let (desc, pos) = Tbl.find_str name components in - let new_desc = f desc in - let components = Tbl.add name (new_desc, pos) components in - {tbl with opened = Some {root; using; next; components}} - with Not_found -> - let next = update name f next in - {tbl with opened = Some {root; using; next; components}} - end - | None -> - tbl - end - - - - let rec find_all name tbl = - List.map (fun (id, desc) -> Pident id, desc) (Ident.find_all name tbl.current) @ - match tbl.opened with - | None -> [] - | Some {root; using = _; next; components} -> - try - let (desc, pos) = Tbl.find_str name components in - (Pdot (root, name, pos), desc) :: find_all name next - with Not_found -> - find_all name next - - let rec fold_name f tbl acc = - let acc = Ident.fold_name (fun id d -> f (Ident.name id) (Pident id, d)) tbl.current acc in - match tbl.opened with - | Some {root; using = _; next; components} -> - acc - |> Tbl.fold - (fun name (desc, pos) -> f name (Pdot (root, name, pos), desc)) - components - |> fold_name f next - | None -> - acc - - let rec local_keys tbl acc = - let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in - match tbl.opened with - | Some o -> local_keys o.next acc - | None -> acc - - - let rec iter f tbl = - Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; - match tbl.opened with - | Some {root; using = _; next; components} -> - Tbl.iter - (fun s (x, pos) -> f (Ident.hide (Ident.create s) (* ??? *)) (Pdot (root, s, pos), x)) - components; - iter f next - | None -> () - - let diff_keys tbl1 tbl2 = - let keys2 = local_keys tbl2 [] in - Ext_list.filter keys2 - (fun id -> - try ignore (find_same id tbl1); false - with Not_found -> true) - - - end - -type type_descriptions = - constructor_description list * label_description list - -let in_signature_flag = 0x01 -let implicit_coercion_flag = 0x02 - -type t = { - values: value_description IdTbl.t; - constrs: constructor_description TycompTbl.t; - labels: label_description TycompTbl.t; - types: (type_declaration * type_descriptions) IdTbl.t; - modules: (Subst.t * module_declaration, module_declaration) EnvLazy.t IdTbl.t; - modtypes: modtype_declaration IdTbl.t; - components: module_components IdTbl.t; - classes: class_declaration IdTbl.t; - cltypes: class_type_declaration IdTbl.t; - functor_args: unit Ident.tbl; - summary: summary; - local_constraints: type_declaration PathMap.t; - gadt_instances: (int * TypeSet.t ref) list; - flags: int; -} - -and module_components = - { - deprecated: string option; - loc: Location.t; - comps: - (t * Subst.t * Path.t * Types.module_type, module_components_repr option) - EnvLazy.t; - } - -and module_components_repr = - Structure_comps of structure_components - | Functor_comps of functor_components - -and 'a comp_tbl = (string, ('a * int)) Tbl.t - -and structure_components = { - mutable comp_values: value_description comp_tbl; - mutable comp_constrs: (string, constructor_description list) Tbl.t; - mutable comp_labels: (string, label_description list) Tbl.t; - mutable comp_types: (type_declaration * type_descriptions) comp_tbl; - mutable comp_modules: - (Subst.t * module_declaration, module_declaration) EnvLazy.t comp_tbl; - mutable comp_modtypes: modtype_declaration comp_tbl; - mutable comp_components: module_components comp_tbl; - comp_classes: class_declaration comp_tbl; (* warning -69*) - mutable comp_cltypes: class_type_declaration comp_tbl; -} - -and functor_components = { - fcomp_param: Ident.t; (* Formal parameter *) - fcomp_arg: module_type option; (* Argument signature *) - fcomp_res: module_type; (* Result signature *) - fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) - fcomp_subst_cache: (Path.t, module_type) Hashtbl.t -} - -let copy_local ~from env = - { env with - local_constraints = from.local_constraints; - gadt_instances = from.gadt_instances; - flags = from.flags } - -let same_constr = ref (fun _ _ _ -> assert false) - -(* Helper to decide whether to report an identifier shadowing - by some 'open'. For labels and constructors, we do not report - if the two elements are from the same re-exported declaration. - - Later, one could also interpret some attributes on value and - type declarations to silence the shadowing warnings. *) - -let check_shadowing env = function - | `Constructor (Some (c1, c2)) - when not (!same_constr env c1.cstr_res c2.cstr_res) -> - Some "constructor" - | `Label (Some (l1, l2)) - when not (!same_constr env l1.lbl_res l2.lbl_res) -> - Some "label" - | `Value (Some _) -> Some "value" - | `Type (Some _) -> Some "type" - | `Module (Some _) | `Component (Some _) -> Some "module" - | `Module_type (Some _) -> Some "module type" - | `Class (Some _) -> Some "class" - | `Class_type (Some _) -> Some "class type" - | `Constructor _ | `Label _ - | `Value None | `Type None | `Module None | `Module_type None - | `Class None | `Class_type None | `Component None -> - None - -let subst_modtype_maker (subst, md) = - if subst == Subst.identity then md - else {md with md_type = Subst.modtype subst md.md_type} - -let empty = { - values = IdTbl.empty; constrs = TycompTbl.empty; - labels = TycompTbl.empty; types = IdTbl.empty; - modules = IdTbl.empty; modtypes = IdTbl.empty; - components = IdTbl.empty; classes = IdTbl.empty; - cltypes = IdTbl.empty; - summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = []; - flags = 0; - functor_args = Ident.empty; - } - -let in_signature b env = - let flags = - if b then env.flags lor in_signature_flag - else env.flags land (lnot in_signature_flag) - in - {env with flags} - -let implicit_coercion env = - {env with flags = env.flags lor implicit_coercion_flag} - -let is_in_signature env = env.flags land in_signature_flag <> 0 -let is_implicit_coercion env = env.flags land implicit_coercion_flag <> 0 - -let is_ident = function - Pident _ -> true - | Pdot _ | Papply _ -> false - -let is_local_ext = function - | {cstr_tag = Cstr_extension(p, _)} -> is_ident p - | _ -> false - -let diff env1 env2 = - IdTbl.diff_keys env1.values env2.values @ - TycompTbl.diff_keys is_local_ext env1.constrs env2.constrs @ - IdTbl.diff_keys env1.modules env2.modules @ - IdTbl.diff_keys env1.classes env2.classes - -type can_load_cmis = - | Can_load_cmis - | Cannot_load_cmis of EnvLazy.log - -let can_load_cmis = ref Can_load_cmis - -let without_cmis f x = - let log = EnvLazy.log () in - let res = - Misc.(protect_refs - [R (can_load_cmis, Cannot_load_cmis log)] - (fun () -> f x)) - in - EnvLazy.backtrack log; - res - -(* Forward declarations *) - -let components_of_module' = - ref ((fun ~deprecated:_ ~loc:_ _env _sub _path _mty -> assert false) : - deprecated:string option -> loc:Location.t -> t -> Subst.t -> - Path.t -> module_type -> - module_components) -let components_of_module_maker' = - ref ((fun (_env, _sub, _path, _mty) -> assert false) : - t * Subst.t * Path.t * module_type -> module_components_repr option) -let components_of_functor_appl' = - ref ((fun _f _env _p1 _p2 -> assert false) : - functor_components -> t -> Path.t -> Path.t -> module_components) -let check_modtype_inclusion = - (* to be filled with Includemod.check_modtype_inclusion *) - ref ((fun ~loc:_ _env _mty1 _path1 _mty2 -> assert false) : - loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) -let strengthen = - (* to be filled with Mtype.strengthen *) - ref ((fun ~aliasable:_ _env _mty _path -> assert false) : - aliasable:bool -> t -> module_type -> Path.t -> module_type) - -let md md_type = - {md_type; md_attributes=[]; md_loc=Location.none} - -let get_components_opt c = - match !can_load_cmis with - | Can_load_cmis -> - EnvLazy.force !components_of_module_maker' c.comps - | Cannot_load_cmis log -> - EnvLazy.force_logged log !components_of_module_maker' c.comps - -let empty_structure = - Structure_comps { - comp_values = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = Tbl.empty; - comp_types = Tbl.empty; - comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; - comp_components = Tbl.empty; comp_classes = Tbl.empty; - comp_cltypes = Tbl.empty } - -let get_components c = - match get_components_opt c with - | None -> empty_structure - | Some c -> c - -(* The name of the compilation unit currently compiled. - "" if outside a compilation unit. *) - -let current_unit = ref "" - -(* Persistent structure descriptions *) - -type [@warning "-69"] pers_struct = - { ps_name: string; - ps_sig: signature Lazy.t; - ps_comps: module_components; - ps_crcs: (string * Digest.t option) list; - ps_filename: string; - ps_flags: pers_flags list } - -let persistent_structures = - (Hashtbl.create 17 : (string, pers_struct option) Hashtbl.t) - -(* Consistency between persistent structures *) - -let crc_units = Consistbl.create() - -module StringSet = - Set.Make(struct type t = string let compare = String.compare end) - -let imported_units = ref StringSet.empty - -let add_import s = - imported_units := StringSet.add s !imported_units - - -let clear_imports () = - Consistbl.clear crc_units; - imported_units := StringSet.empty - - -let check_consistency ps = - try - List.iter - (fun (name, crco) -> - match crco with - None -> () - | Some crc -> - add_import name; - Consistbl.check crc_units name crc ps.ps_filename) - ps.ps_crcs; - with Consistbl.Inconsistency(name, source, auth) -> - error (Inconsistent_import(name, auth, source)) - -(* Reading persistent structures from .cmi files *) - -let save_pers_struct crc ps = - let modname = ps.ps_name in - Hashtbl.add persistent_structures modname (Some ps); - Consistbl.set crc_units modname crc ps.ps_filename; - add_import modname - -module Persistent_signature = struct - type t = - { filename : string; - cmi : Cmi_format.cmi_infos } - - let load = ref (fun ~unit_name -> - match find_in_path_uncap !load_path (unit_name ^ ".cmi") with - | filename -> Some { filename; cmi = read_cmi filename } - | exception Not_found -> None) -end - -let acknowledge_pers_struct check modname - { Persistent_signature.filename; cmi } = - let name = cmi.cmi_name in - let sign = cmi.cmi_sign in - let crcs = cmi.cmi_crcs in - let flags = cmi.cmi_flags in - let deprecated = - List.fold_left (fun _ -> function Deprecated s -> Some s ) None - flags - in - let comps = - !components_of_module' ~deprecated ~loc:Location.none - empty Subst.identity - (Pident(Ident.create_persistent name)) - (Mty_signature sign) - in - let ps = { ps_name = name; - ps_sig = lazy (Subst.signature Subst.identity sign); - ps_comps = comps; - ps_crcs = crcs; - ps_filename = filename; - ps_flags = flags; - } in - if ps.ps_name <> modname then - error (Illegal_renaming(modname, ps.ps_name, filename)); - if check then check_consistency ps; - Hashtbl.add persistent_structures modname (Some ps); - ps - -let read_pers_struct check modname filename = - add_import modname; - let cmi = read_cmi filename in - acknowledge_pers_struct check modname - { Persistent_signature.filename; cmi } - -let find_pers_struct check name = - if name = "*predef*" then raise Not_found; - match Hashtbl.find persistent_structures name with - | Some ps -> ps - | None -> raise Not_found - | exception Not_found -> - match !can_load_cmis with - | Cannot_load_cmis _ -> raise Not_found - | Can_load_cmis -> - let ps = - match !Persistent_signature.load ~unit_name:name with - | Some ps -> ps - | None -> - Hashtbl.add persistent_structures name None; - raise Not_found - in - add_import name; - acknowledge_pers_struct check name ps - -(* Emits a warning if there is no valid cmi for name *) -let check_pers_struct name = - try - ignore (find_pers_struct false name) - with - | Not_found -> - let warn = Warnings.No_cmi_file(name, None) in - Location.prerr_warning Location.none warn - | Cmi_format.Error err -> - let msg = Format.asprintf "%a" Cmi_format.report_error err in - let warn = Warnings.No_cmi_file(name, Some msg) in - Location.prerr_warning Location.none warn - | Error err -> - let msg = - match err with - | Illegal_renaming(name, ps_name, filename) -> - Format.asprintf - " %a@ contains the compiled interface for @ \ - %s when %s was expected" - Location.print_filename filename ps_name name - | Inconsistent_import _ -> assert false - | Need_recursive_types(name, _) -> - Format.sprintf - "%s uses recursive types" - name - | Missing_module _ -> assert false - | Illegal_value_name _ -> assert false - in - let warn = Warnings.No_cmi_file(name, Some msg) in - Location.prerr_warning Location.none warn - -let read_pers_struct modname filename = - read_pers_struct true modname filename - -let find_pers_struct name = - find_pers_struct true name - -let check_pers_struct name = - if not (Hashtbl.mem persistent_structures name) then begin - (* PR#6843: record the weak dependency ([add_import]) regardless of - whether the check succeeds, to help make builds more - deterministic. *) - add_import name; - if (Warnings.is_active (Warnings.No_cmi_file("", None))) then - Delayed_checks.add_delayed_check - (fun () -> check_pers_struct name) - end - -let reset_cache () = - current_unit := ""; - Hashtbl.clear persistent_structures; - clear_imports (); - Hashtbl.clear value_declarations; - Hashtbl.clear type_declarations; - Hashtbl.clear module_declarations; - Hashtbl.clear used_constructors; - Hashtbl.clear prefixed_sg - -let reset_cache_toplevel () = - (* Delete 'missing cmi' entries from the cache. *) - let l = - Hashtbl.fold - (fun name r acc -> if r = None then name :: acc else acc) - persistent_structures [] - in - List.iter (Hashtbl.remove persistent_structures) l; - Hashtbl.clear value_declarations; - Hashtbl.clear type_declarations; - Hashtbl.clear module_declarations; - Hashtbl.clear used_constructors; - Hashtbl.clear prefixed_sg - - -let set_unit_name name = - current_unit := name - -let get_unit_name () = - !current_unit - -(* Lookup by identifier *) - -let rec find_module_descr path env = - match path with - Pident id -> - begin try - IdTbl.find_same id env.components - with Not_found -> - if Ident.persistent id && not (Ident.name id = !current_unit) - then (find_pers_struct (Ident.name id)).ps_comps - else raise Not_found - end - | Pdot(p, s, _pos) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - let (descr, _pos) = Tbl.find_str s c.comp_components in - descr - | Functor_comps _ -> - raise Not_found - end - | Papply(p1, p2) -> - begin match get_components (find_module_descr p1 env) with - Functor_comps f -> - !components_of_functor_appl' f env p1 p2 - | Structure_comps _ -> - raise Not_found - end - -let find proj1 proj2 path env = - match path with - Pident id -> - IdTbl.find_same id (proj1 env) - | Pdot(p, s, _pos) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - let (data, _pos) = Tbl.find_str s (proj2 c) in data - | Functor_comps _ -> - raise Not_found - end - | Papply _ -> - raise Not_found - -let find_value = - find (fun env -> env.values) (fun sc -> sc.comp_values) -and find_type_full = - find (fun env -> env.types) (fun sc -> sc.comp_types) -and find_modtype = - find (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) -and find_class = - find (fun env -> env.classes) (fun sc -> sc.comp_classes) -and find_cltype = - find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) - -let type_of_cstr path = function - | {cstr_inlined = Some d; _} -> - (d, ([], List.map snd (Datarepr.labels_of_type path d))) - | _ -> - assert false - -let find_type_full path env = - match Path.constructor_typath path with - | Regular p -> - (try (PathMap.find p env.local_constraints, ([], [])) - with Not_found -> find_type_full p env) - | Cstr (ty_path, s) -> - let (_, (cstrs, _)) = - try find_type_full ty_path env - with Not_found -> assert false - in - let cstr = - try List.find (fun cstr -> cstr.cstr_name = s) cstrs - with Not_found -> assert false - in - type_of_cstr path cstr - | LocalExt id -> - let cstr = - try TycompTbl.find_same id env.constrs - with Not_found -> assert false - in - type_of_cstr path cstr - | Ext (mod_path, s) -> - let comps = - try find_module_descr mod_path env - with Not_found -> assert false - in - let comps = - match get_components comps with - | Structure_comps c -> c - | Functor_comps _ -> assert false - in - let exts = - Ext_list.filter - (try Tbl.find_str s comps.comp_constrs - with Not_found -> assert false) - (function {cstr_tag=Cstr_extension _} -> true | _ -> false) - - in - match exts with - | [cstr] -> type_of_cstr path cstr - | _ -> assert false - -let find_type p env = - fst (find_type_full p env) -let find_type_descrs p env = - snd (find_type_full p env) - -let find_module ~alias path env = - match path with - Pident id -> - begin try - let data = IdTbl.find_same id env.modules in - EnvLazy.force subst_modtype_maker data - with Not_found -> - if Ident.persistent id && not (Ident.name id = !current_unit) then - let ps = find_pers_struct (Ident.name id) in - md (Mty_signature(Lazy.force ps.ps_sig)) - else raise Not_found - end - | Pdot(p, s, _pos) -> - begin match get_components (find_module_descr p env) with - Structure_comps c -> - let (data, _pos) = Tbl.find_str s c.comp_modules in - EnvLazy.force subst_modtype_maker data - | Functor_comps _ -> - raise Not_found - end - | Papply(p1, p2) -> - let desc1 = find_module_descr p1 env in - begin match get_components desc1 with - Functor_comps f -> - md begin match f.fcomp_res with - | Mty_alias _ as mty -> mty - | mty -> - if alias then mty else - try - Hashtbl.find f.fcomp_subst_cache p2 - with Not_found -> - let mty = - Subst.modtype - (Subst.add_module f.fcomp_param p2 Subst.identity) - f.fcomp_res in - Hashtbl.add f.fcomp_subst_cache p2 mty; - mty - end - | Structure_comps _ -> - raise Not_found - end - - - -let rec normalize_path lax env path = - let path = - match path with - Pdot(p, s, pos) -> - Pdot(normalize_path lax env p, s, pos) - | Papply(p1, p2) -> - Papply(normalize_path lax env p1, normalize_path true env p2) - | _ -> path - in - try match find_module ~alias:true path env with - {md_type=Mty_alias(_, path1)} -> - normalize_path lax env path1 - | _ -> path - with Not_found when lax - || (match path with Pident id -> not (Ident.persistent id) | _ -> true) -> - path - -let normalize_path oloc env path = - try normalize_path (oloc = None) env path - with Not_found -> - match oloc with None -> assert false - | Some loc -> - raise (Error(Missing_module(loc, path, normalize_path true env path))) - -let normalize_path_prefix oloc env path = - match path with - Pdot(p, s, pos) -> - Pdot(normalize_path oloc env p, s, pos) - | Pident _ -> - path - | Papply _ -> - assert false - - -let find_module = find_module ~alias:false - -(* Find the manifest type associated to a type when appropriate: - - the type should be public or should have a private row, - - the type should have an associated manifest type. *) -let find_type_expansion path env = - let decl = find_type path env in - match decl.type_manifest with - | Some body when decl.type_private = Public - || decl.type_kind <> Type_abstract - || Btype.has_constr_row body -> - (decl.type_params, body, may_map snd decl.type_newtype_level) - (* The manifest type of Private abstract data types without - private row are still considered unknown to the type system. - Hence, this case is caught by the following clause that also handles - purely abstract data types without manifest type definition. *) - | _ -> raise Not_found - -(* Find the manifest type information associated to a type, i.e. - the necessary information for the compiler's type-based optimisations. - In particular, the manifest type associated to a private abstract type - is revealed for the sake of compiler's type-based optimisations. *) -let find_type_expansion_opt path env = - let decl = find_type path env in - match decl.type_manifest with - (* The manifest type of Private abstract data types can still get - an approximation using their manifest type. *) - | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level) - | _ -> raise Not_found - -let find_modtype_expansion path env = - match (find_modtype path env).mtd_type with - | None -> raise Not_found - | Some mty -> mty - -let rec is_functor_arg path env = - match path with - Pident id -> - begin try Ident.find_same id env.functor_args; true - with Not_found -> false - end - | Pdot (p, _s, _) -> is_functor_arg p env - | Papply _ -> true - -(* Lookup by name *) - -exception Recmodule - -let report_deprecated ?loc p deprecated = - match loc, deprecated with - | Some loc, Some txt -> - let txt = if txt = "" then "" else "\n" ^ txt in - Location.deprecated loc (Printf.sprintf "module %s%s" (Path.name p) txt) - | _ -> () - -let mark_module_used env name loc = - if not (is_implicit_coercion env) then - try Hashtbl.find module_declarations (name, loc) () - with Not_found -> () - -let rec lookup_module_descr_aux ?loc lid env = - match lid with - Lident s -> - begin try - IdTbl.find_name s env.components - with Not_found -> - if s = !current_unit then raise Not_found; - let ps = find_pers_struct s in - (Pident(Ident.create_persistent s), ps.ps_comps) - end - | Ldot(l, s) -> - let (p, descr) = lookup_module_descr ?loc l env in - begin match get_components descr with - Structure_comps c -> - let (descr, pos) = Tbl.find_str s c.comp_components in - (Pdot(p, s, pos), descr) - | Functor_comps _ -> - raise Not_found - end - | Lapply(l1, l2) -> - let (p1, desc1) = lookup_module_descr ?loc l1 env in - let p2 = lookup_module ~load:true ?loc l2 env in - let {md_type=mty2} = find_module p2 env in - begin match get_components desc1 with - Functor_comps f -> - let loc = match loc with Some l -> l | None -> Location.none in - Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; - (Papply(p1, p2), !components_of_functor_appl' f env p1 p2) - | Structure_comps _ -> - raise Not_found - end - -and lookup_module_descr ?loc lid env = - let (p, comps) as res = lookup_module_descr_aux ?loc lid env in - mark_module_used env (Path.last p) comps.loc; -(* - Format.printf "USE module %s at %a@." (Path.last p) - Location.print comps.loc; -*) - report_deprecated ?loc p comps.deprecated; - res - -and lookup_module ~load ?loc lid env : Path.t = - match lid with - Lident s -> - begin try - let (p, data) = IdTbl.find_name s env.modules in - let {md_loc; md_attributes; md_type} = - EnvLazy.force subst_modtype_maker data - in - mark_module_used env s md_loc; - begin match md_type with - | Mty_ident (Path.Pident id) when Ident.name id = "#recmod#" -> - (* see #5965 *) - raise Recmodule - | Mty_alias (_, Path.Pident id) -> - if !Config.bs_only && not !Clflags.transparent_modules && Ident.persistent id then - find_pers_struct (Ident.name id) |> ignore - | _ -> () - end; - report_deprecated ?loc p - (Builtin_attributes.deprecated_of_attrs md_attributes); - p - with Not_found -> - if s = !current_unit then raise Not_found; - let p = Pident(Ident.create_persistent s) in - if !Clflags.transparent_modules && not load then check_pers_struct s - else begin - let ps = find_pers_struct s in - report_deprecated ?loc p ps.ps_comps.deprecated - end; - p - end - | Ldot(l, s) -> - let (p, descr) = lookup_module_descr ?loc l env in - begin match get_components descr with - Structure_comps c -> - let (_data, pos) = Tbl.find_str s c.comp_modules in - let (comps, _) = Tbl.find_str s c.comp_components in - mark_module_used env s comps.loc; - let p = Pdot(p, s, pos) in - report_deprecated ?loc p comps.deprecated; - p - | Functor_comps _ -> - raise Not_found - end - | Lapply(l1, l2) -> - let (p1, desc1) = lookup_module_descr ?loc l1 env in - let p2 = lookup_module ~load:true ?loc l2 env in - let {md_type=mty2} = find_module p2 env in - let p = Papply(p1, p2) in - begin match get_components desc1 with - Functor_comps f -> - let loc = match loc with Some l -> l | None -> Location.none in - Misc.may (!check_modtype_inclusion ~loc env mty2 p2) f.fcomp_arg; - p - | Structure_comps _ -> - raise Not_found - end - -let lookup proj1 proj2 ?loc lid env = - match lid with - Lident s -> - IdTbl.find_name s (proj1 env) - | Ldot(l, s) -> - let (p, desc) = lookup_module_descr ?loc l env in - begin match get_components desc with - Structure_comps c -> - let (data, pos) = Tbl.find_str s (proj2 c) in - (Pdot(p, s, pos), data) - | Functor_comps _ -> - raise Not_found - end - | Lapply _ -> - raise Not_found - -let lookup_all_simple proj1 proj2 shadow ?loc lid env = - match lid with - Lident s -> - let xl = TycompTbl.find_all s (proj1 env) in - let rec do_shadow = - function - | [] -> [] - | ((x, f) :: xs) -> - (x, f) :: - (do_shadow (Ext_list.filter xs (fun (y, _) -> not (shadow x y)))) - in - do_shadow xl - | Ldot(l, s) -> - let (_p, desc) = lookup_module_descr ?loc l env in - begin match get_components desc with - Structure_comps c -> - let comps = - try Tbl.find_str s (proj2 c) with Not_found -> [] - in - List.map - (fun data -> (data, (fun () -> ()))) - comps - | Functor_comps _ -> - raise Not_found - end - | Lapply _ -> - raise Not_found - -let has_local_constraints env = not (PathMap.is_empty env.local_constraints) - -let cstr_shadow cstr1 cstr2 = - match cstr1.cstr_tag, cstr2.cstr_tag with - | Cstr_extension _, Cstr_extension _ -> true - | _ -> false - -let lbl_shadow _lbl1 _lbl2 = false - -let lookup_value = - lookup (fun env -> env.values) (fun sc -> sc.comp_values) -let lookup_all_constructors = - lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) - cstr_shadow -let lookup_all_labels = - lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) - lbl_shadow -let lookup_type = - lookup (fun env -> env.types) (fun sc -> sc.comp_types) -let lookup_modtype = - lookup (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) -let lookup_class = - lookup (fun env -> env.classes) (fun sc -> sc.comp_classes) -let lookup_cltype = - lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) - -let copy_types l env = - let f desc = {desc with val_type = Subst.type_expr Subst.identity desc.val_type} in - let values = List.fold_left (fun env s -> IdTbl.update s f env) env.values l in - {env with values; summary = Env_copy_types (env.summary, l)} - -let mark_value_used env name vd = - if not (is_implicit_coercion env) then - try Hashtbl.find value_declarations (name, vd.val_loc) () - with Not_found -> () - -let mark_type_used env name vd = - if not (is_implicit_coercion env) then - try Hashtbl.find type_declarations (name, vd.type_loc) () - with Not_found -> () - -let mark_constructor_used usage env name vd constr = - if not (is_implicit_coercion env) then - try Hashtbl.find used_constructors (name, vd.type_loc, constr) usage - with Not_found -> () - -let mark_extension_used usage env ext name = - if not (is_implicit_coercion env) then - let ty_name = Path.last ext.ext_type_path in - try Hashtbl.find used_constructors (ty_name, ext.ext_loc, name) usage - with Not_found -> () - -let set_value_used_callback name vd callback = - let key = (name, vd.val_loc) in - try - let old = Hashtbl.find value_declarations key in - Hashtbl.replace value_declarations key (fun () -> old (); callback ()) - (* this is to support cases like: - let x = let x = 1 in x in x - where the two declarations have the same location - (e.g. resulting from Camlp4 expansion of grammar entries) *) - with Not_found -> - Hashtbl.add value_declarations key callback - -let set_type_used_callback name td callback = - let loc = td.type_loc in - if loc.Location.loc_ghost then () - else let key = (name, loc) in - let old = - try Hashtbl.find type_declarations key - with Not_found -> assert false - in - Hashtbl.replace type_declarations key (fun () -> callback old) - -let lookup_value ?loc lid env = - let (_, desc) as r = lookup_value ?loc lid env in - mark_value_used env (Longident.last lid) desc; - r - -let lookup_type ?loc lid env = - let (path, (decl, _)) = lookup_type ?loc lid env in - mark_type_used env (Longident.last lid) decl; - path - -let mark_type_path env path = - try - let decl = find_type path env in - mark_type_used env (Path.last path) decl - with Not_found -> () - -let ty_path t = - match repr t with - | {desc=Tconstr(path, _, _)} -> path - | _ -> assert false - -let lookup_constructor ?loc lid env = - match lookup_all_constructors ?loc lid env with - [] -> raise Not_found - | (desc, use) :: _ -> - mark_type_path env (ty_path desc.cstr_res); - use (); - desc - -let is_lident = function - Lident _ -> true - | _ -> false - -let lookup_all_constructors ?loc lid env = - try - let cstrs = lookup_all_constructors ?loc lid env in - let wrap_use desc use () = - mark_type_path env (ty_path desc.cstr_res); - use () - in - List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs - with - Not_found when is_lident lid -> [] - -let mark_constructor usage env name desc = - if not (is_implicit_coercion env) - then match desc.cstr_tag with - | Cstr_extension _ -> - begin - let ty_path = ty_path desc.cstr_res in - let ty_name = Path.last ty_path in - try Hashtbl.find used_constructors (ty_name, desc.cstr_loc, name) usage - with Not_found -> () - end - | _ -> - let ty_path = ty_path desc.cstr_res in - let ty_decl = try find_type ty_path env with Not_found -> assert false in - let ty_name = Path.last ty_path in - mark_constructor_used usage env ty_name ty_decl name - -let lookup_label ?loc lid env = - match lookup_all_labels ?loc lid env with - [] -> raise Not_found - | (desc, use) :: _ -> - mark_type_path env (ty_path desc.lbl_res); - use (); - desc - -let lookup_all_labels ?loc lid env = - try - let lbls = lookup_all_labels ?loc lid env in - let wrap_use desc use () = - mark_type_path env (ty_path desc.lbl_res); - use () - in - List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls - with - Not_found when is_lident lid -> [] - -let lookup_class ?loc lid env = - let (_, desc) as r = lookup_class ?loc lid env in - (* special support for Typeclass.unbound_class *) - if Path.name desc.cty_path = "" then ignore (lookup_type ?loc lid env) - else mark_type_path env desc.cty_path; - r - -let lookup_cltype ?loc lid env = - let (_, desc) as r = lookup_cltype ?loc lid env in - if Path.name desc.clty_path = "" then ignore (lookup_type ?loc lid env) - else mark_type_path env desc.clty_path; - mark_type_path env desc.clty_path; - r - -(* Iter on an environment (ignoring the body of functors and - not yet evaluated structures) *) - -type iter_cont = unit -> unit -let iter_env_cont = ref [] - -let rec scrape_alias_for_visit env mty = - match mty with - | Mty_alias(_, Pident id) - when Ident.persistent id - && not (Hashtbl.mem persistent_structures (Ident.name id)) -> false - | Mty_alias(_, path) -> (* PR#6600: find_module may raise Not_found *) - begin try scrape_alias_for_visit env (find_module path env).md_type - with Not_found -> false - end - | _ -> true - -let iter_env proj1 proj2 f env () = - IdTbl.iter (fun id x -> f (Pident id) x) (proj1 env); - let rec iter_components path path' mcomps = - let cont () = - let visit = - match EnvLazy.get_arg mcomps.comps with - | None -> true - | Some (env, _sub, _path, mty) -> scrape_alias_for_visit env mty - in - if not visit then () else - match get_components mcomps with - Structure_comps comps -> - Tbl.iter - (fun s (d, n) -> f (Pdot (path, s, n)) (Pdot (path', s, n), d)) - (proj2 comps); - Tbl.iter - (fun s (c, n) -> - iter_components (Pdot (path, s, n)) (Pdot (path', s, n)) c) - comps.comp_components - | Functor_comps _ -> () - in iter_env_cont := (path, cont) :: !iter_env_cont - in - Hashtbl.iter - (fun s pso -> - match pso with None -> () - | Some ps -> - let id = Pident (Ident.create_persistent s) in - iter_components id id ps.ps_comps) - persistent_structures; - IdTbl.iter - (fun id (path, comps) -> iter_components (Pident id) path comps) - env.components - -let run_iter_cont l = - iter_env_cont := []; - List.iter (fun c -> c ()) l; - let cont = List.rev !iter_env_cont in - iter_env_cont := []; - cont - -let iter_types f = iter_env (fun env -> env.types) (fun sc -> sc.comp_types) f - -let same_types env1 env2 = - env1.types == env2.types && env1.components == env2.components - -let used_persistent () = - let r = ref Concr.empty in - Hashtbl.iter (fun s pso -> if pso != None then r := Concr.add s !r) - persistent_structures; - !r - -let find_all_comps proj s (p,mcomps) = - match get_components mcomps with - Functor_comps _ -> [] - | Structure_comps comps -> - try let (c,n) = Tbl.find_str s (proj comps) in [Pdot(p,s,n), c] - with Not_found -> [] - -let rec find_shadowed_comps path env = - match path with - Pident id -> - IdTbl.find_all (Ident.name id) env.components - | Pdot (p, s, _) -> - let l = find_shadowed_comps p env in - let l' = - List.map (find_all_comps (fun comps -> comps.comp_components) s) l in - List.flatten l' - | Papply _ -> [] - -let find_shadowed proj1 proj2 path env = - match path with - Pident id -> - IdTbl.find_all (Ident.name id) (proj1 env) - | Pdot (p, s, _) -> - let l = find_shadowed_comps p env in - let l' = List.map (find_all_comps proj2 s) l in - List.flatten l' - | Papply _ -> [] - -let find_shadowed_types path env = - List.map fst - (find_shadowed - (fun env -> env.types) (fun comps -> comps.comp_types) path env) - - -(* GADT instance tracking *) - -let add_gadt_instance_level lv env = - {env with - gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances} - -let is_Tlink = function {desc = Tlink _} -> true | _ -> false - -let gadt_instance_level env t = - let rec find_instance = function - [] -> None - | (lv, r) :: rem -> - if TypeSet.exists is_Tlink !r then - (* Should we use set_typeset ? *) - r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty; - if TypeSet.mem t !r then Some lv else find_instance rem - in find_instance env.gadt_instances - -let add_gadt_instances env lv tl = - let r = - try List.assoc lv env.gadt_instances with Not_found -> assert false in - (* Format.eprintf "Added"; - List.iter (fun ty -> Format.eprintf "@ %a" !Btype.print_raw ty) tl; - Format.eprintf "@."; *) - set_typeset r (List.fold_right TypeSet.add tl !r) - -(* Only use this after expand_head! *) -let add_gadt_instance_chain env lv t = - let r = - try List.assoc lv env.gadt_instances with Not_found -> assert false in - let rec add_instance t = - let t = repr t in - if not (TypeSet.mem t !r) then begin - (* Format.eprintf "@ %a" !Btype.print_raw t; *) - set_typeset r (TypeSet.add t !r); - match t.desc with - Tconstr (p, _, memo) -> - may add_instance (find_expans Private p !memo) - | _ -> () - end - in - (* Format.eprintf "Added chain"; *) - add_instance t - (* Format.eprintf "@." *) - -(* Expand manifest module type names at the top of the given module type *) - -let rec scrape_alias env ?path mty = - match mty, path with - Mty_ident p, _ -> - begin try - scrape_alias env (find_modtype_expansion p env) ?path - with Not_found -> - mty - end - | Mty_alias(_, path), _ -> - begin try - scrape_alias env (find_module path env).md_type ~path - with Not_found -> - (*Location.prerr_warning Location.none - (Warnings.No_cmi_file (Path.name path));*) - mty - end - | mty, Some path -> - !strengthen ~aliasable:true env mty path - | _ -> mty - -let scrape_alias env mty = scrape_alias env mty - -(* Given a signature and a root path, prefix all idents in the signature - by the root path and build the corresponding substitution. *) - -let rec prefix_idents root pos sub = function - [] -> ([], sub) - | Sig_value(id, decl) :: rem -> - let p = Pdot(root, Ident.name id, pos) in - let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in - let (pl, final_sub) = prefix_idents root nextpos sub rem in - (p::pl, final_sub) - | Sig_type(id, _, _) :: rem -> - let p = Pdot(root, Ident.name id, nopos) in - let (pl, final_sub) = - prefix_idents root pos (Subst.add_type id p sub) rem in - (p::pl, final_sub) - | Sig_typext(id, _, _) :: rem -> - let p = Pdot(root, Ident.name id, pos) in - (* we extend the substitution in case of an inlined record *) - let (pl, final_sub) = - prefix_idents root (pos+1) (Subst.add_type id p sub) rem in - (p::pl, final_sub) - | Sig_module(id, _, _) :: rem -> - let p = Pdot(root, Ident.name id, pos) in - let (pl, final_sub) = - prefix_idents root (pos+1) (Subst.add_module id p sub) rem in - (p::pl, final_sub) - | Sig_modtype(id, _) :: rem -> - let p = Pdot(root, Ident.name id, nopos) in - let (pl, final_sub) = - prefix_idents root pos - (Subst.add_modtype id (Mty_ident p) sub) rem in - (p::pl, final_sub) - | Sig_class _ :: _ -> - assert false - | Sig_class_type(id, _, _) :: rem -> - let p = Pdot(root, Ident.name id, nopos) in - let (pl, final_sub) = - prefix_idents root pos (Subst.add_type id p sub) rem in - (p::pl, final_sub) - -let prefix_idents root sub sg = - if sub = Subst.identity then - let sgs = - try - Hashtbl.find prefixed_sg root - with Not_found -> - let sgs = ref [] in - Hashtbl.add prefixed_sg root sgs; - sgs - in - try - List.assq sg !sgs - with Not_found -> - let r = prefix_idents root 0 sub sg in - sgs := (sg, r) :: !sgs; - r - else - prefix_idents root 0 sub sg - -(* Compute structure descriptions *) - -let add_to_tbl id decl tbl = - let decls = - try Tbl.find_str id tbl with Not_found -> [] in - Tbl.add id (decl :: decls) tbl - -let rec components_of_module ~deprecated ~loc env sub path mty = - { - deprecated; - loc; - comps = EnvLazy.create (env, sub, path, mty) - } - -and components_of_module_maker (env, sub, path, mty) = - match scrape_alias env mty with - Mty_signature sg -> - let c = - { comp_values = Tbl.empty; - comp_constrs = Tbl.empty; - comp_labels = Tbl.empty; comp_types = Tbl.empty; - comp_modules = Tbl.empty; comp_modtypes = Tbl.empty; - comp_components = Tbl.empty; comp_classes = Tbl.empty; - comp_cltypes = Tbl.empty } in - let pl, sub = prefix_idents path sub sg in - let env = ref env in - let pos = ref 0 in - List.iter2 (fun item path -> - match item with - Sig_value(id, decl) -> - let decl' = Subst.value_description sub decl in - c.comp_values <- - Tbl.add (Ident.name id) (decl', !pos) c.comp_values; - begin match decl.val_kind with - Val_prim _ -> () | _ -> incr pos - end - | Sig_type(id, decl, _) -> - let decl' = Subst.type_declaration sub decl in - Datarepr.set_row_name decl' (Subst.type_path sub (Path.Pident id)); - let constructors = - List.map snd (Datarepr.constructors_of_type path decl') in - let labels = - List.map snd (Datarepr.labels_of_type path decl') in - c.comp_types <- - Tbl.add (Ident.name id) - ((decl', (constructors, labels)), nopos) - c.comp_types; - List.iter - (fun descr -> - c.comp_constrs <- - add_to_tbl descr.cstr_name descr c.comp_constrs) - constructors; - List.iter - (fun descr -> - c.comp_labels <- - add_to_tbl descr.lbl_name descr c.comp_labels) - labels; - env := store_type_infos id decl !env - | Sig_typext(id, ext, _) -> - let ext' = Subst.extension_constructor sub ext in - let descr = Datarepr.extension_descr path ext' in - c.comp_constrs <- - add_to_tbl (Ident.name id) descr c.comp_constrs; - incr pos - | Sig_module(id, md, _) -> - let md' = EnvLazy.create (sub, md) in - c.comp_modules <- - Tbl.add (Ident.name id) (md', !pos) c.comp_modules; - let deprecated = - Builtin_attributes.deprecated_of_attrs md.md_attributes - in - let comps = - components_of_module ~deprecated ~loc:md.md_loc !env sub path - md.md_type - in - c.comp_components <- - Tbl.add (Ident.name id) (comps, !pos) c.comp_components; - env := store_module ~check:false id md !env; - incr pos - | Sig_modtype(id, decl) -> - let decl' = Subst.modtype_declaration sub decl in - c.comp_modtypes <- - Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes; - env := store_modtype id decl !env - | Sig_class () -> assert false - | Sig_class_type(id, decl, _) -> - let decl' = Subst.cltype_declaration sub decl in - c.comp_cltypes <- - Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) - sg pl; - Some (Structure_comps c) - | Mty_functor(param, ty_arg, ty_res) -> - Some (Functor_comps { - fcomp_param = param; - (* fcomp_arg and fcomp_res must be prefixed eagerly, because - they are interpreted in the outer environment *) - fcomp_arg = may_map (Subst.modtype sub) ty_arg; - fcomp_res = Subst.modtype sub ty_res; - fcomp_cache = Hashtbl.create 17; - fcomp_subst_cache = Hashtbl.create 17 }) - | Mty_ident _ - | Mty_alias _ -> None - -(* Insertion of bindings by identifier + path *) - -and check_usage loc id warn tbl = - if not loc.Location.loc_ghost && Warnings.is_active (warn "") then begin - let name = Ident.name id in - let key = (name, loc) in - if Hashtbl.mem tbl key then () - else let used = ref false in - Hashtbl.add tbl key (fun () -> used := true); - if not (name = "" || name.[0] = '_' || name.[0] = '#') - then - Delayed_checks.add_delayed_check - (fun () -> if not !used then Location.prerr_warning loc (warn name)) - end; - -and check_value_name name loc = - (* Note: we could also check here general validity of the - identifier, to protect against bad identifiers forged by -pp or - -ppx preprocessors. *) - if name = "|." then raise (Error(Illegal_value_name(loc, name))) - else if String.length name > 0 && (name.[0] = '#') then - for i = 1 to String.length name - 1 do - if name.[i] = '#' then - raise (Error(Illegal_value_name(loc, name))) - done - - -and store_value ?check id decl env = - check_value_name (Ident.name id) decl.val_loc; - may (fun f -> check_usage decl.val_loc id f value_declarations) check; - { env with - values = IdTbl.add id decl env.values; - summary = Env_value(env.summary, id, decl) } - -and store_type ~check id info env = - let loc = info.type_loc in - if check then - check_usage loc id (fun s -> Warnings.Unused_type_declaration s) - type_declarations; - let path = Pident id in - let constructors = Datarepr.constructors_of_type path info in - let labels = Datarepr.labels_of_type path info in - let descrs = (List.map snd constructors, List.map snd labels) in - - if check && not loc.Location.loc_ghost && - Warnings.is_active (Warnings.Unused_constructor ("", false, false)) - then begin - let ty = Ident.name id in - List.iter - begin fun (_, {cstr_name = c; _}) -> - let k = (ty, loc, c) in - if not (Hashtbl.mem used_constructors k) then - let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); - if not (ty = "" || ty.[0] = '_') - then Delayed_checks.add_delayed_check - (fun () -> - if not (is_in_signature env) && not used.cu_positive then - Location.prerr_warning loc - (Warnings.Unused_constructor - (c, used.cu_pattern, used.cu_privatize))) - end - constructors - end; - { env with - constrs = - List.fold_right - (fun (id, descr) constrs -> TycompTbl.add id descr constrs) - constructors - env.constrs; - labels = - List.fold_right - (fun (id, descr) labels -> TycompTbl.add id descr labels) - labels - env.labels; - types = - IdTbl.add id (info, descrs) env.types; - summary = Env_type(env.summary, id, info) } - -and store_type_infos id info env = - (* Simplified version of store_type that doesn't compute and store - constructor and label infos, but simply record the arity and - manifest-ness of the type. Used in components_of_module to - keep track of type abbreviations (e.g. type t = float) in the - computation of label representations. *) - { env with - types = IdTbl.add id (info,([],[])) - env.types; - summary = Env_type(env.summary, id, info) } - -and store_extension ~check id ext env = - let loc = ext.ext_loc in - if check && not loc.Location.loc_ghost && - Warnings.is_active (Warnings.Unused_extension ("", false, false, false)) - then begin - let is_exception = Path.same ext.ext_type_path Predef.path_exn in - let ty = Path.last ext.ext_type_path in - let n = Ident.name id in - let k = (ty, loc, n) in - if not (Hashtbl.mem used_constructors k) then begin - let used = constructor_usages () in - Hashtbl.add used_constructors k (add_constructor_usage used); - Delayed_checks.add_delayed_check - (fun () -> - if not (is_in_signature env) && not used.cu_positive then - Location.prerr_warning loc - (Warnings.Unused_extension - (n, is_exception, used.cu_pattern, used.cu_privatize) - ) - ) - end; - end; - { env with - constrs = TycompTbl.add id - (Datarepr.extension_descr (Pident id) ext) - env.constrs; - summary = Env_extension(env.summary, id, ext) } - -and store_module ~check id md env = - let loc = md.md_loc in - if check then - check_usage loc id (fun s -> Warnings.Unused_module s) - module_declarations; - - let deprecated = Builtin_attributes.deprecated_of_attrs md.md_attributes in - { env with - modules = IdTbl.add id (EnvLazy.create (Subst.identity, md)) env.modules; - components = - IdTbl.add id - (components_of_module ~deprecated ~loc:md.md_loc - env Subst.identity (Pident id) md.md_type) - env.components; - summary = Env_module(env.summary, id, md) } - -and store_modtype id info env = - { env with - modtypes = IdTbl.add id info env.modtypes; - summary = Env_modtype(env.summary, id, info) } - - -and store_cltype id desc env = - { env with - cltypes = IdTbl.add id desc env.cltypes; - summary = Env_cltype(env.summary, id, desc) } - -(* Compute the components of a functor application in a path. *) - -let components_of_functor_appl f env p1 p2 = - try - Hashtbl.find f.fcomp_cache p2 - with Not_found -> - let p = Papply(p1, p2) in - let sub = Subst.add_module f.fcomp_param p2 Subst.identity in - let mty = Subst.modtype sub f.fcomp_res in - let comps = components_of_module ~deprecated:None ~loc:Location.none - (*???*) - env Subst.identity p mty in - Hashtbl.add f.fcomp_cache p2 comps; - comps - -(* Define forward functions *) - -let _ = - components_of_module' := components_of_module; - components_of_functor_appl' := components_of_functor_appl; - components_of_module_maker' := components_of_module_maker - -(* Insertion of bindings by identifier *) - -let add_functor_arg id env = - {env with - functor_args = Ident.add id () env.functor_args; - summary = Env_functor_arg (env.summary, id)} - -let add_value ?check id desc env = - store_value ?check id desc env - -let add_type ~check id info env = - store_type ~check id info env - -and add_extension ~check id ext env = - store_extension ~check id ext env - -and add_module_declaration ?(arg=false) ~check id md env = - let env = store_module ~check id md env in - if arg then add_functor_arg id env else env - -and add_modtype id info env = - store_modtype id info env - - - -and add_cltype id ty env = - store_cltype id ty env - -let add_module ?arg id mty env = - add_module_declaration ~check:false ?arg id (md mty) env - -let add_local_type path info env = - { env with - local_constraints = PathMap.add path info env.local_constraints } - -let add_local_constraint path info elv env = - match info with - {type_manifest = Some _; type_newtype_level = Some (lv, _)} -> - (* elv is the expansion level, lv is the definition level *) - let info = {info with type_newtype_level = Some (lv, elv)} in - add_local_type path info env - | _ -> assert false - - -(* Insertion of bindings by name *) - -let enter store_fun name data env = - let id = Ident.create name in (id, store_fun id data env) - -let enter_value ?check = enter (store_value ?check) -and enter_type = enter (store_type ~check:true) -and enter_extension = enter (store_extension ~check:true) -and enter_module_declaration ?arg id md env = - add_module_declaration ?arg ~check:true id md env - (* let (id, env) = enter store_module name md env in - (id, add_functor_arg ?arg id env) *) -and enter_modtype = enter store_modtype - -and enter_cltype = enter store_cltype - -let enter_module ?arg s mty env = - let id = Ident.create s in - (id, enter_module_declaration ?arg id (md mty) env) - -(* Insertion of all components of a signature *) - -let add_item comp env = - match comp with - Sig_value(id, decl) -> add_value id decl env - | Sig_type(id, decl, _) -> add_type ~check:false id decl env - | Sig_typext(id, ext, _) -> add_extension ~check:false id ext env - | Sig_module(id, md, _) -> add_module_declaration ~check:false id md env - | Sig_modtype(id, decl) -> add_modtype id decl env - | Sig_class() -> env - | Sig_class_type(id, decl, _) -> add_cltype id decl env - -let rec add_signature sg env = - match sg with - [] -> env - | comp :: rem -> add_signature rem (add_item comp env) - -(* Open a signature path *) - -let add_components slot root env0 comps = - let add_l w comps env0 = - TycompTbl.add_open slot w comps env0 - in - - let add w comps env0 = IdTbl.add_open slot w root comps env0 in - - let constrs = - add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs - in - let labels = - add_l (fun x -> `Label x) comps.comp_labels env0.labels - in - - let values = - add (fun x -> `Value x) comps.comp_values env0.values - in - let types = - add (fun x -> `Type x) comps.comp_types env0.types - in - let modtypes = - add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes - in - let classes = - add (fun x -> `Class x) comps.comp_classes env0.classes - in - let cltypes = - add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes - in - let components = - add (fun x -> `Component x) comps.comp_components env0.components - in - - let modules = - add (fun x -> `Module x) comps.comp_modules env0.modules - in - - { env0 with - summary = Env_open(env0.summary, root); - constrs; - labels; - values; - types; - modtypes; - classes; - cltypes; - components; - modules; - } - -let open_signature slot root env0 = - match get_components (find_module_descr root env0) with - | Functor_comps _ -> None - | Structure_comps comps -> Some (add_components slot root env0 comps) - - -(* Open a signature from a file *) - -let open_pers_signature name env = - match open_signature None (Pident(Ident.create_persistent name)) env with - | Some env -> env - | None -> assert false (* a compilation unit cannot refer to a functor *) - -let open_signature - ?(used_slot = ref false) - ?(loc = Location.none) ?(toplevel = false) ovf root env = - if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost - && (Warnings.is_active (Warnings.Unused_open "") - || Warnings.is_active (Warnings.Open_shadow_identifier ("", "")) - || Warnings.is_active (Warnings.Open_shadow_label_constructor ("",""))) - then begin - let used = used_slot in - Delayed_checks.add_delayed_check - (fun () -> - if not !used then begin - used := true; - Location.prerr_warning loc (Warnings.Unused_open (Path.name root)) - end - ); - let shadowed = ref [] in - let slot s b = - begin match check_shadowing env b with - | Some kind when not (List.mem (kind, s) !shadowed) -> - shadowed := (kind, s) :: !shadowed; - let w = - match kind with - | "label" | "constructor" -> - Warnings.Open_shadow_label_constructor (kind, s) - | _ -> Warnings.Open_shadow_identifier (kind, s) - in - Location.prerr_warning loc w - | _ -> () - end; - used := true - in - open_signature (Some slot) root env - end - else open_signature None root env - -(* Read a signature from a file *) - -let read_signature modname filename = - let ps = read_pers_struct modname filename in - Lazy.force ps.ps_sig - -(* Return the CRC of the interface of the given compilation unit *) - -let crc_of_unit name = - let ps = find_pers_struct name in - let crco = - try - List.assoc name ps.ps_crcs - with Not_found -> - assert false - in - match crco with - None -> assert false - | Some crc -> crc - -(* Return the list of imported interfaces with their CRCs *) - -let imports () = - let dont_record_crc_unit = !Clflags.dont_record_crc_unit in - match dont_record_crc_unit with - | None -> Consistbl.extract (StringSet.elements !imported_units) crc_units - | Some x -> - Consistbl.extract - (StringSet.fold - (fun m acc -> if m = x then acc else m::acc) - !imported_units []) crc_units - -(* Save a signature to a file *) - -let save_signature_with_imports ?check_exists ~deprecated sg modname filename imports = - (*prerr_endline filename; - List.iter (fun (name, crc) -> prerr_endline name) imports;*) - Btype.cleanup_abbrev (); - Subst.reset_for_saving (); - let sg = Subst.signature (Subst.for_saving Subst.identity) sg in - let flags = - (match deprecated with Some s -> [Deprecated s] | None -> []) - in - try - let cmi = { - cmi_name = modname; - cmi_sign = sg; - cmi_crcs = imports; - cmi_flags = flags; - } in - let crc = - create_cmi ?check_exists filename cmi in - (* Enter signature in persistent table so that imported_unit() - will also return its crc *) - let comps = - components_of_module ~deprecated ~loc:Location.none - empty Subst.identity - (Pident(Ident.create_persistent modname)) (Mty_signature sg) in - let ps = - { ps_name = modname; - ps_sig = lazy (Subst.signature Subst.identity sg); - ps_comps = comps; - ps_crcs = (cmi.cmi_name, Some crc) :: imports; - ps_filename = filename; - ps_flags = cmi.cmi_flags; - } in - save_pers_struct crc ps; - cmi - with exn -> - remove_file filename; - raise exn - -let save_signature ?check_exists ~deprecated sg modname filename = - save_signature_with_imports ?check_exists ~deprecated sg modname filename (imports()) - -(* Folding on environments *) - -let find_all proj1 proj2 f lid env acc = - match lid with - | None -> - IdTbl.fold_name - (fun name (p, data) acc -> f name p data acc) - (proj1 env) acc - | Some l -> - let p, desc = lookup_module_descr l env in - begin match get_components desc with - Structure_comps c -> - Tbl.fold - (fun s (data, pos) acc -> f s (Pdot (p, s, pos)) data acc) - (proj2 c) acc - | Functor_comps _ -> - acc - end - -let find_all_simple_list proj1 proj2 f lid env acc = - match lid with - | None -> - TycompTbl.fold_name - (fun data acc -> f data acc) - (proj1 env) acc - | Some l -> - let (_p, desc) = lookup_module_descr l env in - begin match get_components desc with - Structure_comps c -> - Tbl.fold - (fun _s comps acc -> - match comps with - [] -> acc - | data :: _ -> - f data acc) - (proj2 c) acc - | Functor_comps _ -> - acc - end - -let fold_modules f lid env acc = - match lid with - | None -> - let acc = - IdTbl.fold_name - (fun name (p, data) acc -> - let data = EnvLazy.force subst_modtype_maker data in - f name p data acc - ) - env.modules - acc - in - Hashtbl.fold - (fun name ps acc -> - match ps with - None -> acc - | Some ps -> - f name (Pident(Ident.create_persistent name)) - (md (Mty_signature (Lazy.force ps.ps_sig))) acc) - persistent_structures - acc - | Some l -> - let p, desc = lookup_module_descr l env in - begin match get_components desc with - Structure_comps c -> - Tbl.fold - (fun s (data, pos) acc -> - f s (Pdot (p, s, pos)) - (EnvLazy.force subst_modtype_maker data) acc) - c.comp_modules - acc - | Functor_comps _ -> - acc - end - -let fold_values f = - find_all (fun env -> env.values) (fun sc -> sc.comp_values) f -and fold_constructors f = - find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f -and fold_labels f = - find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f -and fold_types f = - find_all (fun env -> env.types) (fun sc -> sc.comp_types) f -and fold_modtypes f = - find_all (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f -and fold_classs f = - find_all (fun env -> env.classes) (fun sc -> sc.comp_classes) f -and fold_cltypes f = - find_all (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f - - -(* Make the initial environment *) -let initial_safe_string = - Predef.build_initial_env - (add_type ~check:false) - (add_extension ~check:false) - empty - -(* Return the environment summary *) - -let summary env = - if PathMap.is_empty env.local_constraints then env.summary - else Env_constraints (env.summary, env.local_constraints) - -let last_env = ref empty -let last_reduced_env = ref empty - -let keep_only_summary env = - if !last_env == env then !last_reduced_env - else begin - let new_env = - { - empty with - summary = env.summary; - local_constraints = env.local_constraints; - flags = env.flags; - } - in - last_env := env; - last_reduced_env := new_env; - new_env - end - - -let env_of_only_summary env_from_summary env = - let new_env = env_from_summary env.summary Subst.identity in - { new_env with - local_constraints = env.local_constraints; - flags = env.flags; - } - -(* Error report *) - -open Format - -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/typing/env.ml#L1842 *) -(* modified branches are commented *) -let report_error ppf = function - | Illegal_renaming(name, modname, _filename) -> - (* modified *) - fprintf ppf - "@[You referred to the module %s, but we've found one called %s instead.@ \ - Is the name's casing right?@]" - name modname - | Inconsistent_import(name, source1, source2) -> - (* modified *) - fprintf ppf "@[\ - @[@{It's possible that your build is stale.@}@ Try to clean the artifacts and build again?@]@,@,\ - @[@{Here's the original error message@}@]@,\ - @]"; - fprintf ppf - "@[The files %a@ and %a@ \ - make inconsistent assumptions@ over interface %s@]" - Location.print_filename source1 Location.print_filename source2 name - | Need_recursive_types(import, export) -> - fprintf ppf - "@[Unit %s imports from %s, which uses recursive types.@ %s@]" - export import "The compilation flag -rectypes is required" - | Missing_module(_, path1, path2) -> - fprintf ppf "@[@["; - if Path.same path1 path2 then - fprintf ppf "Internal path@ %s@ is dangling." (Path.name path1) - else - fprintf ppf "Internal path@ %s@ expands to@ %s@ which is dangling." - (Path.name path1) (Path.name path2); - fprintf ppf "@]@ @[%s@ %s@ %s.@]@]" - "The compiled interface for module" (Ident.name (Path.head path2)) - "was not found" - | Illegal_value_name(_loc, name) -> - fprintf ppf "'%s' is not a valid value identifier." - name - -let () = - Location.register_error_of_exn - (function - | Error (Missing_module (loc, _, _) - | Illegal_value_name (loc, _) - as err) when loc <> Location.none -> - Some (Location.error_of_printer loc report_error err) - | Error err -> Some (Location.error_of_printer_file report_error err) - | _ -> None - ) diff --git a/jscomp/ml/env.mli b/jscomp/ml/env.mli deleted file mode 100644 index dfa1027..0000000 --- a/jscomp/ml/env.mli +++ /dev/null @@ -1,323 +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. *) -(* *) -(**************************************************************************) - -(* Environment handling *) - -open Types - -module PathMap : Map.S with type key = Path.t - and type 'a t = 'a Map.Make(Path).t - -type summary = - Env_empty - | Env_value of summary * Ident.t * value_description - | Env_type of summary * Ident.t * type_declaration - | Env_extension of summary * Ident.t * extension_constructor - | Env_module of summary * Ident.t * module_declaration - | Env_modtype of summary * Ident.t * modtype_declaration - | Env_class of unit - | Env_cltype of summary * Ident.t * class_type_declaration - | Env_open of summary * Path.t - | Env_functor_arg of summary * Ident.t - | Env_constraints of summary * type_declaration PathMap.t - | Env_copy_types of summary * string list - -type t - -val empty: t -val initial_safe_string: t - -val diff: t -> t -> Ident.t list -val copy_local: from:t -> t -> t - -type type_descriptions = - constructor_description list * label_description list - -(* For short-paths *) -type iter_cont -val iter_types: - (Path.t -> Path.t * (type_declaration * type_descriptions) -> unit) -> - t -> iter_cont -val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list -val same_types: t -> t -> bool -val used_persistent: unit -> Concr.t -val find_shadowed_types: Path.t -> t -> Path.t list -val without_cmis: ('a -> 'b) -> 'a -> 'b - (* [without_cmis f arg] applies [f] to [arg], but does not - allow opening cmis during its execution *) - -(* Lookup by paths *) - -val find_value: Path.t -> t -> value_description -val find_type: Path.t -> t -> type_declaration -val find_type_descrs: Path.t -> t -> type_descriptions -val find_module: Path.t -> t -> module_declaration -val find_modtype: Path.t -> t -> modtype_declaration -val find_class: Path.t -> t -> class_declaration -val find_cltype: Path.t -> t -> class_type_declaration - -val find_type_expansion: - Path.t -> t -> type_expr list * type_expr * int option -val find_type_expansion_opt: - Path.t -> t -> type_expr list * type_expr * int option -(* Find the manifest type information associated to a type for the sake - of the compiler's type-based optimisations. *) -val find_modtype_expansion: Path.t -> t -> module_type -val add_functor_arg: Ident.t -> t -> t -val is_functor_arg: Path.t -> t -> bool -val normalize_path: Location.t option -> t -> Path.t -> Path.t -(* Normalize the path to a concrete value or module. - If the option is None, allow returning dangling paths. - Otherwise raise a Missing_module error, and may add forgotten - head as required global. *) -val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t -(* Only normalize the prefix part of the path *) - - - - -val has_local_constraints: t -> bool -val add_gadt_instance_level: int -> t -> t -val gadt_instance_level: t -> type_expr -> int option -val add_gadt_instances: t -> int -> type_expr list -> unit -val add_gadt_instance_chain: t -> int -> type_expr -> unit - -(* Lookup by long identifiers *) - -(* ?loc is used to report 'deprecated module' warnings *) - -val lookup_value: - ?loc:Location.t -> Longident.t -> t -> Path.t * value_description -val lookup_constructor: - ?loc:Location.t -> Longident.t -> t -> constructor_description -val lookup_all_constructors: - ?loc:Location.t -> - Longident.t -> t -> (constructor_description * (unit -> unit)) list -val lookup_label: - ?loc:Location.t -> Longident.t -> t -> label_description -val lookup_all_labels: - ?loc:Location.t -> - Longident.t -> t -> (label_description * (unit -> unit)) list -val lookup_type: - ?loc:Location.t -> Longident.t -> t -> Path.t - (* Since 4.04, this function no longer returns [type_description]. - To obtain it, you should either call [Env.find_type], or replace - it by [Typetexp.find_type] *) -val lookup_module: - load:bool -> ?loc:Location.t -> Longident.t -> t -> Path.t -val lookup_modtype: - ?loc:Location.t -> Longident.t -> t -> Path.t * modtype_declaration -val lookup_class: - ?loc:Location.t -> Longident.t -> t -> Path.t * class_declaration -val lookup_cltype: - ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration - -val copy_types: string list -> t -> t - (* Used only in Typecore.duplicate_ident_types. *) - -exception Recmodule - (* Raise by lookup_module when the identifier refers - to one of the modules of a recursive definition - during the computation of its approximation (see #5965). *) - -(* Insertion by identifier *) - -val add_value: - ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t -val add_type: check:bool -> Ident.t -> type_declaration -> t -> t -val add_extension: check:bool -> Ident.t -> extension_constructor -> t -> t -val add_module: ?arg:bool -> Ident.t -> module_type -> t -> t -val add_module_declaration: ?arg:bool -> check:bool -> Ident.t -> - module_declaration -> t -> t -val add_modtype: Ident.t -> modtype_declaration -> t -> t - -val add_cltype: Ident.t -> class_type_declaration -> t -> t -val add_local_constraint: Path.t -> type_declaration -> int -> t -> t -val add_local_type: Path.t -> type_declaration -> t -> t - -(* Insertion of all fields of a signature. *) - -val add_item: signature_item -> t -> t -val add_signature: signature -> t -> t - -(* Insertion of all fields of a signature, relative to the given path. - Used to implement open. Returns None if the path refers to a functor, - not a structure. *) -val open_signature: - ?used_slot:bool ref -> - ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t -> - t -> t option - -val open_pers_signature: string -> t -> t - -(* Insertion by name *) - -val enter_value: - ?check:(string -> Warnings.t) -> - string -> value_description -> t -> Ident.t * t -val enter_type: string -> type_declaration -> t -> Ident.t * t -val enter_extension: string -> extension_constructor -> t -> Ident.t * t -val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t -val enter_module_declaration: - ?arg:bool -> Ident.t -> module_declaration -> t -> t -val enter_modtype: string -> modtype_declaration -> t -> Ident.t * t - -val enter_cltype: string -> class_type_declaration -> t -> Ident.t * t - -(* Initialize the cache of in-core module interfaces. *) -val reset_cache: unit -> unit - -(* To be called before each toplevel phrase. *) -val reset_cache_toplevel: unit -> unit - -(* Remember the name of the current compilation unit. *) -val set_unit_name: string -> unit -val get_unit_name: unit -> string - -(* Read, save a signature to/from a file *) - -val read_signature: string -> string -> signature - (* Arguments: module name, file name. Results: signature. *) -val save_signature: - ?check_exists:unit -> - deprecated:string option -> signature -> string -> string -> Cmi_format.cmi_infos - (* Arguments: signature, module name, file name. *) -val save_signature_with_imports: - ?check_exists:unit -> - deprecated:string option -> - signature -> string -> string -> (string * Digest.t option) list - -> Cmi_format.cmi_infos - (* Arguments: signature, module name, file name, - imported units with their CRCs. *) - -(* Return the CRC of the interface of the given compilation unit *) - -val crc_of_unit: string -> Digest.t - -(* Return the set of compilation units imported, with their CRC *) - -val imports: unit -> (string * Digest.t option) list - - - -(* Direct access to the table of imported compilation units with their CRC *) - -val crc_units: Consistbl.t -val add_import: string -> unit - -(* Summaries -- compact representation of an environment, to be - exported in debugging information. *) - -val summary: t -> summary - -(* Return an equivalent environment where all fields have been reset, - except the summary. The initial environment can be rebuilt from the - summary, using Envaux.env_of_only_summary. *) - -val keep_only_summary : t -> t -val env_of_only_summary : (summary -> Subst.t -> t) -> t -> t - -(* Error report *) - -type error = - | Illegal_renaming of string * string * string - | Inconsistent_import of string * string * string - | Need_recursive_types of string * string - | Missing_module of Location.t * Path.t * Path.t - | Illegal_value_name of Location.t * string - -exception Error of error - -open Format - -val report_error: formatter -> error -> unit - - -val mark_value_used: t -> string -> value_description -> unit -val mark_module_used: t -> string -> Location.t -> unit -val mark_type_used: t -> string -> type_declaration -> unit - -type constructor_usage = Positive | Pattern | Privatize -val mark_constructor_used: - constructor_usage -> t -> string -> type_declaration -> string -> unit -val mark_constructor: - constructor_usage -> t -> string -> constructor_description -> unit -val mark_extension_used: - constructor_usage -> t -> extension_constructor -> string -> unit - -val in_signature: bool -> t -> t -val implicit_coercion: t -> t - -val is_in_signature: t -> bool - -val set_value_used_callback: - string -> value_description -> (unit -> unit) -> unit -val set_type_used_callback: - string -> type_declaration -> ((unit -> unit) -> unit) -> unit - -(* Forward declaration to break mutual recursion with Includemod. *) -val check_modtype_inclusion: - (loc:Location.t -> t -> module_type -> Path.t -> module_type -> unit) ref - -(* Forward declaration to break mutual recursion with Mtype. *) -val strengthen: - (aliasable:bool -> t -> module_type -> Path.t -> module_type) ref -(* Forward declaration to break mutual recursion with Ctype. *) -val same_constr: (t -> type_expr -> type_expr -> bool) ref - -(** Folding over all identifiers (for analysis purpose) *) - -val fold_values: - (string -> Path.t -> value_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_types: - (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_constructors: - (constructor_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_labels: - (label_description -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a - -(** Persistent structures are only traversed if they are already loaded. *) -val fold_modules: - (string -> Path.t -> module_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a - -val fold_modtypes: - (string -> Path.t -> modtype_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_classs: - (string -> Path.t -> class_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a -val fold_cltypes: - (string -> Path.t -> class_type_declaration -> 'a -> 'a) -> - Longident.t option -> t -> 'a -> 'a - -(** Utilities *) -val scrape_alias: t -> module_type -> module_type -val check_value_name: string -> Location.t -> unit - -module Persistent_signature : sig - type t = - { filename : string; (** Name of the file containing the signature. *) - cmi : Cmi_format.cmi_infos } - - (** Function used to load a persistent signature. The default is to look for - the .cmi file in the load path. This function can be overridden to load - it from memory, for instance to build a self-contained toplevel. *) - val load : (unit_name:string -> t option) ref -end diff --git a/jscomp/ml/envaux.ml b/jscomp/ml/envaux.ml deleted file mode 100644 index 5fd5020..0000000 --- a/jscomp/ml/envaux.ml +++ /dev/null @@ -1,94 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* OCaml port by John Malecki and Xavier Leroy *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -open Env - -type error = - Module_not_found of Path.t - -exception Error of error - -let env_cache = - (Hashtbl.create 59 : ((Env.summary * Subst.t), Env.t) Hashtbl.t) - -let reset_cache () = - Hashtbl.clear env_cache; - Env.reset_cache() - -let rec env_from_summary sum subst = - try - Hashtbl.find env_cache (sum, subst) - with Not_found -> - let env = - match sum with - Env_empty -> - Env.empty - | Env_value(s, id, desc) -> - Env.add_value id (Subst.value_description subst desc) - (env_from_summary s subst) - | Env_type(s, id, desc) -> - Env.add_type ~check:false id - (Subst.type_declaration subst desc) - (env_from_summary s subst) - | Env_extension(s, id, desc) -> - Env.add_extension ~check:false id - (Subst.extension_constructor subst desc) - (env_from_summary s subst) - | Env_module(s, id, desc) -> - Env.add_module_declaration ~check:false id - (Subst.module_declaration subst desc) - (env_from_summary s subst) - | Env_modtype(s, id, desc) -> - Env.add_modtype id (Subst.modtype_declaration subst desc) - (env_from_summary s subst) - | Env_cltype (s, id, desc) -> - Env.add_cltype id (Subst.cltype_declaration subst desc) - (env_from_summary s subst) - | Env_open(s, path) -> - let env = env_from_summary s subst in - let path' = Subst.module_path subst path in - begin match Env.open_signature Asttypes.Override path' env with - | Some env -> env - | None -> assert false - end - | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' -> - Env.add_module_declaration ~check:false - id (Subst.module_declaration subst desc) - ~arg:true (env_from_summary s subst) - | Env_class _ - | Env_functor_arg _ -> assert false - | Env_constraints(s, map) -> - PathMap.fold - (fun path info -> - Env.add_local_type (Subst.type_path subst path) - (Subst.type_declaration subst info)) - map (env_from_summary s subst) - | Env_copy_types (s, sl) -> - Env.copy_types sl (env_from_summary s subst) - in - Hashtbl.add env_cache (sum, subst) env; - env - -let env_of_only_summary env = - Env.env_of_only_summary env_from_summary env - -(* Error report *) - -open Format - -let report_error ppf = function - | Module_not_found p -> - fprintf ppf "@[Cannot find module %a@].@." Printtyp.path p diff --git a/jscomp/ml/envaux.mli b/jscomp/ml/envaux.mli deleted file mode 100644 index 2869890..0000000 --- a/jscomp/ml/envaux.mli +++ /dev/null @@ -1,36 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* OCaml port by John Malecki and Xavier Leroy *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -open Format - -(* Convert environment summaries to environments *) - -val env_from_summary : Env.summary -> Subst.t -> Env.t - -(* Empty the environment caches. To be called when load_path changes. *) - -val reset_cache: unit -> unit - -val env_of_only_summary : Env.t -> Env.t - -(* Error report *) - -type error = - Module_not_found of Path.t - -exception Error of error - -val report_error: formatter -> error -> unit diff --git a/jscomp/ml/error_message_utils.ml b/jscomp/ml/error_message_utils.ml deleted file mode 100644 index 14a4913..0000000 --- a/jscomp/ml/error_message_utils.ml +++ /dev/null @@ -1,215 +0,0 @@ -type typeClashStatement = FunctionCall -type typeClashContext = - | SetRecordField - | ArrayValue - | FunctionReturn - | MaybeUnwrapOption - | IfCondition - | IfReturn - | Switch - | StringConcat - | ComparisonOperator - | MathOperator of { - forFloat: bool; - operator: string; - isConstant: string option; - } - | FunctionArgument - | Statement of typeClashStatement - -let fprintf = Format.fprintf - -let errorTypeText ppf typeClashContext = - let text = - match typeClashContext with - | Some (Statement FunctionCall) -> "This function call returns:" - | Some (MathOperator {isConstant = Some _}) -> "This value has type:" - | Some ArrayValue -> "This array item has type:" - | Some SetRecordField -> - "You're assigning something to this field that has type:" - | _ -> "This has type:" - in - fprintf ppf "%s" text - -let errorExpectedTypeText ppf typeClashContext = - match typeClashContext with - | Some FunctionArgument -> - fprintf ppf "But this function argument is expecting:" - | Some ComparisonOperator -> - fprintf ppf "But it's being compared to something of type:" - | Some Switch -> fprintf ppf "But this switch is expected to return:" - | Some IfCondition -> - fprintf ppf "But @{if@} conditions must always be of type:" - | Some IfReturn -> - fprintf ppf "But this @{if@} statement is expected to return:" - | Some ArrayValue -> - fprintf ppf "But this array is expected to have items of type:" - | Some SetRecordField -> fprintf ppf "But this record field is of type:" - | Some (Statement FunctionCall) -> fprintf ppf "But it's expected to return:" - | Some (MathOperator {operator}) -> - fprintf ppf - "But it's being used with the @{%s@} operator, which works on:" - operator - | Some FunctionReturn -> - fprintf ppf "But this function is expecting you to return:" - | _ -> fprintf ppf "But it's expected to have type:" - -let printExtraTypeClashHelp ppf trace typeClashContext = - match (typeClashContext, trace) with - | Some (MathOperator {forFloat; operator; isConstant}), _ -> ( - let operatorForOtherType = - match operator with - | "+" -> "+." - | "+." -> "+" - | "/" -> "/." - | "/." -> "/" - | "-" -> "-." - | "*" -> "*." - | "*." -> "*" - | v -> v - in - let operatorText = - match operator.[0] with - | '+' -> "add" - | '-' -> "subtract" - | '/' -> "divide" - | '*' -> "multiply" - | _ -> "compute" - in - (* TODO check int vs float explicitly before showing this *) - (match (operator, trace) with - | ( "+", - [ - ({Types.desc = Tconstr (p1, _, _)}, _); - ({desc = Tconstr (p2, _, _)}, _); - ] ) - when Path.same Predef.path_string p1 || Path.same Predef.path_string p2 -> - fprintf ppf - "\n\n\ - \ Are you looking to concatenate strings? Use the operator \ - @{++@}, which concatenates strings.\n\n\ - \ Possible solutions:\n\ - \ - Change the @{+@} operator to @{++@} to concatenate \ - strings instead." - | _ -> - fprintf ppf - "\n\n\ - \ Floats and ints have their own mathematical operators. This means \ - you cannot %s a float and an int without converting between the two.\n\n\ - \ Possible solutions:\n\ - \ - Ensure all values in this calculation has the type @{%s@}. \ - You can convert between floats and ints via \ - @{Belt.Float.toInt@} and @{Belt.Int.fromFloat@}." - operatorText - (if forFloat then "float" else "int")); - match (isConstant, trace) with - | Some constant, _ -> - if forFloat then - fprintf ppf - "\n\ - \ - Make @{%s@} a @{float@} by adding a trailing dot: \ - @{%s.@}" - constant constant - else - fprintf ppf - "\n\ - \ - Make @{%s@} an @{int@} by removing the dot or \ - explicitly converting to int" - constant - | ( _, - [ - ({Types.desc = Tconstr (p1, _, _)}, _); - ({desc = Tconstr (p2, _, _)}, _); - ] ) -> ( - match (Path.name p1, Path.name p2) with - | "float", "int" | "int", "float" -> - fprintf ppf - "\n\ - \ - Change the operator to @{%s@}, which works on @{%s@}" - operatorForOtherType - (if forFloat then "int" else "float") - | _ -> ()) - | _ -> ()) - | Some Switch, _ -> - fprintf ppf - "\n\n\ - \ All branches in a @{switch@} must return the same type. To fix \ - this, change your branch to return the expected type." - | Some IfCondition, _ -> - fprintf ppf - "\n\n\ - \ To fix this, change the highlighted code so it evaluates to a \ - @{bool@}." - | Some IfReturn, _ -> - fprintf ppf - "\n\n\ - \ @{if@} expressions must return the same type in all branches \ - (@{if@}, @{else if@}, @{else@})." - | Some MaybeUnwrapOption, _ -> - fprintf ppf - "\n\n\ - \ Possible solutions:\n\ - \ - Unwrap the option to its underlying value using \ - `yourValue->Belt.Option.getWithDefault(someDefaultValue)`" - | Some ComparisonOperator, _ -> - fprintf ppf "\n\n You can only compare things of the same type." - | Some ArrayValue, _ -> - fprintf ppf - "\n\n\ - \ Arrays can only contain items of the same type.\n\n\ - \ Possible solutions:\n\ - \ - Convert all values in the array to the same type.\n\ - \ - Use a tuple, if your array is of fixed length. Tuples can mix types \ - freely, and compiles to a JavaScript array. Example of a tuple: `let \ - myTuple = (10, \"hello\", 15.5, true)" - | _ -> () - -let typeClashContextFromFunction sexp sfunct = - let isConstant = - match sexp.Parsetree.pexp_desc with - | Pexp_constant (Pconst_integer (txt, _) | Pconst_float (txt, _)) -> - Some txt - | _ -> None - in - match sfunct.Parsetree.pexp_desc with - | Pexp_ident - {txt = Lident ("=" | "==" | "<>" | "!=" | ">" | ">=" | "<" | "<=")} -> - Some ComparisonOperator - | Pexp_ident {txt = Lident "++"} -> Some StringConcat - | Pexp_ident {txt = Lident (("/." | "*." | "+." | "-.") as operator)} -> - Some (MathOperator {forFloat = true; operator; isConstant}) - | Pexp_ident {txt = Lident (("/" | "*" | "+" | "-") as operator)} -> - Some (MathOperator {forFloat = false; operator; isConstant}) - | _ -> Some FunctionArgument - -let typeClashContextForFunctionArgument typeClashContext sarg0 = - match typeClashContext with - | Some (MathOperator {forFloat; operator}) -> - Some - (MathOperator - { - forFloat; - operator; - isConstant = - (match sarg0.Parsetree.pexp_desc with - | Pexp_constant (Pconst_integer (txt, _) | Pconst_float (txt, _)) - -> - Some txt - | _ -> None); - }) - | typeClashContext -> typeClashContext - -let typeClashContextMaybeOption ty_expected ty_res = - match (ty_expected, ty_res) with - | ( {Types.desc = Tconstr (expectedPath, _, _)}, - {Types.desc = Tconstr (typePath, _, _)} ) - when Path.same Predef.path_option typePath - && Path.same expectedPath Predef.path_option = false - && Path.same expectedPath Predef.path_uncurried = false -> - Some MaybeUnwrapOption - | _ -> None - -let typeClashContextInStatement sexp = - match sexp.Parsetree.pexp_desc with - | Pexp_apply _ -> Some (Statement FunctionCall) - | _ -> None diff --git a/jscomp/ml/includeclass.ml b/jscomp/ml/includeclass.ml deleted file mode 100644 index 7f1b1bd..0000000 --- a/jscomp/ml/includeclass.ml +++ /dev/null @@ -1,116 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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. *) -(* *) -(**************************************************************************) - -(* Inclusion checks for the class language *) - -open Types - -let class_types env cty1 cty2 = - Ctype.match_class_types env cty1 cty2 - -let class_type_declarations ~loc env cty1 cty2 = - Builtin_attributes.check_deprecated_inclusion - ~def:cty1.clty_loc - ~use:cty2.clty_loc - loc - cty1.clty_attributes cty2.clty_attributes - (Path.last cty1.clty_path); - Ctype.match_class_declarations env - cty1.clty_params cty1.clty_type - cty2.clty_params cty2.clty_type - -let class_declarations env cty1 cty2 = - match cty1.cty_new, cty2.cty_new with - None, Some _ -> - [Ctype.CM_Virtual_class] - | _ -> - Ctype.match_class_declarations env - cty1.cty_params cty1.cty_type - cty2.cty_params cty2.cty_type - -open Format -open Ctype - -(* -let rec hide_params = function - Tcty_arrow ("*", _, cty) -> hide_params cty - | cty -> cty -*) - -let include_err ppf = - function - | CM_Virtual_class -> - fprintf ppf "A class cannot be changed from virtual to concrete" - | CM_Parameter_arity_mismatch _ -> - fprintf ppf - "The classes do not have the same number of type parameters" - | CM_Type_parameter_mismatch (env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "A type parameter has type") - (function ppf -> - fprintf ppf "but is expected to have type") - | CM_Class_type_mismatch (env, cty1, cty2) -> - Printtyp.wrap_printing_env env (fun () -> - fprintf ppf - "@[The class type@;<1 2>%a@ %s@;<1 2>%a@]" - Printtyp.class_type cty1 - "is not matched by the class type" - Printtyp.class_type cty2) - | CM_Parameter_mismatch (env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "A parameter has type") - (function ppf -> - fprintf ppf "but is expected to have type") - | CM_Val_type_mismatch (lab, env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "The instance variable %s@ has type" lab) - (function ppf -> - fprintf ppf "but is expected to have type") - | CM_Meth_type_mismatch (lab, env, trace) -> - Printtyp.report_unification_error ppf env ~unif:false trace - (function ppf -> - fprintf ppf "The method %s@ has type" lab) - (function ppf -> - fprintf ppf "but is expected to have type") - | CM_Non_mutable_value lab -> - fprintf ppf - "@[The non-mutable instance variable %s cannot become mutable@]" lab - | CM_Non_concrete_value lab -> - fprintf ppf - "@[The virtual instance variable %s cannot become concrete@]" lab - | CM_Missing_value lab -> - fprintf ppf "@[The first class type has no instance variable %s@]" lab - | CM_Missing_method lab -> - fprintf ppf "@[The first class type has no field %s@]" lab - | CM_Hide_public lab -> - fprintf ppf "@[The public method %s cannot be hidden@]" lab - | CM_Hide_virtual (k, lab) -> - fprintf ppf "@[The virtual %s %s cannot be hidden@]" k lab - | CM_Public_method lab -> - fprintf ppf "@[The public method %s cannot become private" lab - | CM_Virtual_method lab -> - fprintf ppf "@[The virtual method %s cannot become concrete" lab - | CM_Private_method lab -> - fprintf ppf "The private method %s cannot become public" lab - -let report_error ppf = function - | [] -> () - | err :: errs -> - let print_errs ppf errs = - List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in - fprintf ppf "@[%a%a@]" include_err err print_errs errs diff --git a/jscomp/ml/includeclass.mli b/jscomp/ml/includeclass.mli deleted file mode 100644 index ebfa978..0000000 --- a/jscomp/ml/includeclass.mli +++ /dev/null @@ -1,32 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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. *) -(* *) -(**************************************************************************) - -(* Inclusion checks for the class language *) - -open Types -open Ctype -open Format - -val class_types: - Env.t -> class_type -> class_type -> class_match_failure list -val class_type_declarations: - loc:Location.t -> - Env.t -> class_type_declaration -> class_type_declaration -> - class_match_failure list -val class_declarations: - Env.t -> class_declaration -> class_declaration -> - class_match_failure list - -val report_error: formatter -> class_match_failure list -> unit diff --git a/jscomp/ml/includecore.ml b/jscomp/ml/includecore.ml deleted file mode 100644 index 9bc13b9..0000000 --- a/jscomp/ml/includecore.ml +++ /dev/null @@ -1,432 +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. *) -(* *) -(**************************************************************************) - -(* Inclusion checks for the core language *) - -open Asttypes -open Path -open Types -open Typedtree - -(* Inclusion between value descriptions *) - -exception Dont_match - -let value_descriptions ~loc env name - (vd1 : Types.value_description) - (vd2 : Types.value_description) = - Builtin_attributes.check_deprecated_inclusion - ~def:vd1.val_loc - ~use:vd2.val_loc - loc - vd1.val_attributes vd2.val_attributes - (Ident.name name); - if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin - match (vd1.val_kind, vd2.val_kind) with - (Val_prim p1, Val_prim p2) -> - if !Primitive.coerce p1 p2 then Tcoerce_none else raise Dont_match - | (Val_prim p, _) -> - let pc = {pc_desc = p; pc_type = vd2.Types.val_type; - pc_env = env; pc_loc = vd1.Types.val_loc; - pc_id = name; - } in - Tcoerce_primitive pc - | (_, Val_prim _) -> raise Dont_match - | (_, _) -> Tcoerce_none - end else - raise Dont_match - -(* Inclusion between "private" annotations *) - -let private_flags decl1 decl2 = - match decl1.type_private, decl2.type_private with - | Private, Public -> - decl2.type_kind = Type_abstract && - (decl2.type_manifest = None || decl1.type_kind <> Type_abstract) - | _, _ -> true - -(* Inclusion between manifest types (particularly for private row types) *) - -let is_absrow env ty = - match ty.desc with - Tconstr(Pident _, _, _) -> - begin match Ctype.expand_head env ty with - {desc=Tobject _|Tvariant _} -> true - | _ -> false - end - | _ -> false - -let type_manifest env ty1 params1 ty2 params2 priv2 = - let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in - match ty1'.desc, ty2'.desc with - Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> - let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in - Ctype.equal env true (ty1::params1) (row2.row_more::params2) && - begin match row1.row_more with - {desc=Tvar _|Tconstr _|Tnil} -> true - | _ -> false - end && - let r1, r2, pairs = - Ctype.merge_row_fields row1.row_fields row2.row_fields in - (not row2.row_closed || - row1.row_closed && Ctype.filter_row_fields false r1 = []) && - List.for_all - (fun (_,f) -> match Btype.row_field_repr f with - Rabsent | Reither _ -> true | Rpresent _ -> false) - r2 && - let to_equal = ref (List.combine params1 params2) in - List.for_all - (fun (_, f1, f2) -> - match Btype.row_field_repr f1, Btype.row_field_repr f2 with - Rpresent(Some t1), - (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> - to_equal := (t1,t2) :: !to_equal; true - | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true - | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) - when List.length tl1 = List.length tl2 && c1 = c2 -> - to_equal := List.combine tl1 tl2 @ !to_equal; true - | Rabsent, (Reither _ | Rabsent) -> true - | _ -> false) - pairs && - let tl1, tl2 = List.split !to_equal in - Ctype.equal env true tl1 tl2 - | Tobject (fi1, _), Tobject (fi2, _) - when is_absrow env (snd(Ctype.flatten_fields fi2)) -> - let (fields2,rest2) = Ctype.flatten_fields fi2 in - Ctype.equal env true (ty1::params1) (rest2::params2) && - let (fields1,rest1) = Ctype.flatten_fields fi1 in - (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) && - let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in - miss2 = [] && - let tl1, tl2 = - List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in - Ctype.equal env true (params1 @ tl1) (params2 @ tl2) - | _ -> - let rec check_super ty1 = - Ctype.equal env true (ty1 :: params1) (ty2 :: params2) || - priv2 = Private && - try check_super - (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) - with Ctype.Cannot_expand -> false - in check_super ty1 - -(* Inclusion between type declarations *) - -type type_mismatch = - Arity - | Privacy - | Kind - | Constraint - | Manifest - | Variance - | Field_type of Ident.t - | Field_mutable of Ident.t - | Field_arity of Ident.t - | Field_names of int * string * string - | Field_missing of bool * Ident.t - | Record_representation of record_representation * record_representation - | Unboxed_representation of bool (* true means second one is unboxed *) - | Immediate - | Tag_name - | Variant_representation of Ident.t - -let report_type_mismatch0 first second decl ppf err = - let pr fmt = Format.fprintf ppf fmt in - match err with - Arity -> pr "They have different arities" - | Privacy -> pr "A private type would be revealed" - | Kind -> pr "Their kinds differ" - | Constraint -> pr "Their constraints differ" - | Manifest -> () - | Variance -> pr "Their variances do not agree" - | Field_type s -> - pr "The types for field %s are not equal" (Ident.name s) - | Field_mutable s -> - pr "The mutability of field %s is different" (Ident.name s) - | Field_arity s -> - pr "The arities for field %s differ" (Ident.name s) - | Field_names (n, name1, name2) -> - pr "Fields number %i have different names, %s and %s" - n name1 name2 - | Field_missing (b, s) -> - pr "The field %s is only present in %s %s" - (Ident.name s) (if b then second else first) decl - | Record_representation (rep1, rep2) -> - let default () = pr "Their internal representations differ" in - ( match rep1, rep2 with - | Record_optional_labels lbls1, Record_optional_labels lbls2 -> - let onlyInLhs = - Ext_list.find_first lbls1 (fun l -> not (Ext_list.mem_string lbls2 l)) in - let onlyInRhs = - Ext_list.find_first lbls2 (fun l -> not (Ext_list.mem_string lbls1 l)) in - (match onlyInLhs, onlyInRhs with - | Some l, _ -> - pr "@optional label %s only in %s" l second - | _, Some l -> - pr "@optional label %s only in %s" l first - | None, None -> default ()) - | _ -> - default () - ) - | Unboxed_representation b -> - pr "Their internal representations differ:@ %s %s %s" - (if b then second else first) decl - "uses unboxed representation" - | Immediate -> pr "%s is not an immediate type" first - | Tag_name -> pr "Their @tag annotations differ" - | Variant_representation s -> - pr "The internal representations for case %s are not equal" (Ident.name s) - -let report_type_mismatch first second decl ppf = - List.iter - (fun err -> - if err = Manifest then () else - Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) - -let rec compare_constructor_arguments ~loc env cstr params1 params2 arg1 arg2 = - match arg1, arg2 with - | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> - if List.length arg1 <> List.length arg2 then [Field_arity cstr] - else if - (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) - Ctype.equal env true (params1 @ arg1) (params2 @ arg2) - then [] else [Field_type cstr] - | Types.Cstr_record l1, Types.Cstr_record l2 -> - compare_records env ~loc params1 params2 0 l1 l2 - | _ -> [Field_type cstr] - -and compare_variants ~loc env params1 params2 n - (cstrs1 : Types.constructor_declaration list) - (cstrs2 : Types.constructor_declaration list) = - match cstrs1, cstrs2 with - [], [] -> [] - | [], c::_ -> [Field_missing (true, c.Types.cd_id)] - | c::_, [] -> [Field_missing (false, c.Types.cd_id)] - | cd1::rem1, cd2::rem2 -> - if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then - [Field_names (n, cd1.cd_id.name, cd2.cd_id.name)] - else begin - Builtin_attributes.check_deprecated_inclusion - ~def:cd1.cd_loc - ~use:cd2.cd_loc - loc - cd1.cd_attributes cd2.cd_attributes - (Ident.name cd1.cd_id); - let r = - match cd1.cd_res, cd2.cd_res with - | Some r1, Some r2 -> - if Ctype.equal env true [r1] [r2] then - compare_constructor_arguments ~loc env cd1.cd_id [r1] [r2] - cd1.cd_args cd2.cd_args - else [Field_type cd1.cd_id] - | Some _, None | None, Some _ -> - [Field_type cd1.cd_id] - | _ -> - compare_constructor_arguments ~loc env cd1.cd_id - params1 params2 cd1.cd_args cd2.cd_args - in - let r = - if r <> [] then r - else match Ast_untagged_variants.is_nullary_variant cd1.cd_args with - | true -> - let tag_type1 = Ast_untagged_variants.process_tag_type cd1.cd_attributes in - let tag_type2 = Ast_untagged_variants.process_tag_type cd2.cd_attributes in - if tag_type1 <> tag_type2 then [Variant_representation cd1.cd_id] - else [] - | false -> - r - in - if r <> [] then r - else compare_variants ~loc env params1 params2 (n+1) rem1 rem2 - end - -and compare_records ~loc env params1_ params2_ n_ - (labels1_ : Types.label_declaration list) - (labels2_ : Types.label_declaration list) = - (* First try a fast path that checks if all the fields at once are consistent. - When that fails, try a slow path that blames the first inconsistent field *) - let rec aux ~fast params1 params2 n labels1 labels2 = - match labels1, labels2 with - [], [] -> - if fast then - if Ctype.equal env true params1 params2 then - [] - else - aux ~fast:false params1_ params2_ n_ labels1_ labels2_ - else - [] - | [], l::_ -> [Field_missing (true, l.Types.ld_id)] - | l::_, [] -> [Field_missing (false, l.Types.ld_id)] - | ld1::rem1, ld2::rem2 -> - if Ident.name ld1.ld_id <> Ident.name ld2.ld_id - then [Field_names (n, ld1.ld_id.name, ld2.ld_id.name)] - else if ld1.ld_mutable <> ld2.ld_mutable then [Field_mutable ld1.ld_id] else begin - Builtin_attributes.check_deprecated_mutable_inclusion - ~def:ld1.ld_loc - ~use:ld2.ld_loc - loc - ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id); - let field_mismatch = !Builtin_attributes.check_bs_attributes_inclusion - ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id) in - match field_mismatch with - | Some (a,b) -> [Field_names (n,a,b)] - | None -> - let current_field_consistent = - if fast then true - else Ctype.equal env true (ld1.ld_type::params1)(ld2.ld_type::params2) in - if current_field_consistent - then (* add arguments to the parameters, cf. PR#7378 *) - aux ~fast - (ld1.ld_type::params1) (ld2.ld_type::params2) - (n+1) - rem1 rem2 - else - [Field_type ld1.ld_id] - end in - aux ~fast:true params1_ params2_ n_ labels1_ labels2_ - - -let type_declarations ?(equality = false) ~loc env name decl1 id decl2 = - Builtin_attributes.check_deprecated_inclusion - ~def:decl1.type_loc - ~use:decl2.type_loc - loc - decl1.type_attributes decl2.type_attributes - name; - if decl1.type_arity <> decl2.type_arity then [Arity] else - if not (private_flags decl1 decl2) then [Privacy] else - let err = match (decl1.type_manifest, decl2.type_manifest) with - (_, None) -> - if Ctype.equal env true decl1.type_params decl2.type_params - then [] else [Constraint] - | (Some ty1, Some ty2) -> - if type_manifest env ty1 decl1.type_params ty2 decl2.type_params - decl2.type_private - then [] else [Manifest] - | (None, Some ty2) -> - let ty1 = - Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil)) - in - if Ctype.equal env true decl1.type_params decl2.type_params then - if Ctype.equal env false [ty1] [ty2] then [] - else [Manifest] - else [Constraint] - in - if err <> [] then err else - let err = - let untagged1 = Ast_untagged_variants.process_untagged decl1.type_attributes in - let untagged2 = Ast_untagged_variants.process_untagged decl2.type_attributes in - match (decl2.type_kind, decl1.type_unboxed.unboxed || untagged1, - decl2.type_unboxed.unboxed || untagged2) with - | Type_abstract, _, _ -> [] - | _, true, false -> [Unboxed_representation false] - | _, false, true -> [Unboxed_representation true] - | _ -> [] - in - if err <> [] then err else - let err = - let tag1 = Ast_untagged_variants.process_tag_name decl1.type_attributes in - let tag2 = Ast_untagged_variants.process_tag_name decl2.type_attributes in - if tag1 <> tag2 then [Tag_name] else err in - if err <> [] then err else - let err = match (decl1.type_kind, decl2.type_kind) with - (_, Type_abstract) -> [] - | (Type_variant cstrs1, Type_variant cstrs2) -> - let mark cstrs usage name decl = - List.iter - (fun c -> - Env.mark_constructor_used usage env name decl - (Ident.name c.Types.cd_id)) - cstrs - in - let usage = - if decl1.type_private = Private || decl2.type_private = Public - then Env.Positive else Env.Privatize - in - mark cstrs1 usage name decl1; - if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; - compare_variants ~loc env decl1.type_params decl2.type_params 1 cstrs1 cstrs2 - | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - let err = compare_records ~loc env decl1.type_params decl2.type_params 1 labels1 labels2 in - if err <> [] || rep1 = rep2 then err else - [Record_representation (rep1, rep2)] - | (Type_open, Type_open) -> [] - | (_, _) -> [Kind] - in - if err <> [] then err else - let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in - (* If attempt to assign a non-immediate type (e.g. string) to a type that - * must be immediate, then we error *) - let err = - if abstr && - not decl1.type_immediate && - decl2.type_immediate then - [Immediate] - else [] - in - if err <> [] then err else - let need_variance = - abstr || decl1.type_private = Private || decl1.type_kind = Type_open in - if not need_variance then [] else - let abstr = abstr || decl2.type_private = Private in - let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in - let constrained ty = not (Btype.(is_Tvar (repr ty))) in - if List.for_all2 - (fun ty (v1,v2) -> - let open Variance in - let imp a b = not a || b in - let (co1,cn1) = get_upper v1 and (co2,cn2) = get_upper v2 in - (if abstr then (imp co1 co2 && imp cn1 cn2) - else if opn || constrained ty then (co1 = co2 && cn1 = cn2) - else true) && - let (p1,n1,i1,j1) = get_lower v1 and (p2,n2,i2,j2) = get_lower v2 in - imp abstr (imp p2 p1 && imp n2 n1 && imp i2 i1 && imp j2 j1)) - decl2.type_params (List.combine decl1.type_variance decl2.type_variance) - then [] else [Variance] - -(* Inclusion between extension constructors *) - -let extension_constructors ~loc env id ext1 ext2 = - let usage = - if ext1.ext_private = Private || ext2.ext_private = Public - then Env.Positive else Env.Privatize - in - Env.mark_extension_used usage env ext1 (Ident.name id); - let ty1 = - Btype.newgenty (Tconstr(ext1.ext_type_path, ext1.ext_type_params, ref Mnil)) - in - let ty2 = - Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) - in - if Ctype.equal env true - (ty1 :: ext1.ext_type_params) - (ty2 :: ext2.ext_type_params) - then - if compare_constructor_arguments ~loc env (Ident.create "") - ext1.ext_type_params ext2.ext_type_params - ext1.ext_args ext2.ext_args = [] then - if match ext1.ext_ret_type, ext2.ext_ret_type with - Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false - | Some _, None | None, Some _ -> false - | _ -> true - then - match ext1.ext_private, ext2.ext_private with - Private, Public -> false - | _, _ -> true - else false - else false - else false diff --git a/jscomp/ml/includemod.ml b/jscomp/ml/includemod.ml deleted file mode 100644 index 1f73880..0000000 --- a/jscomp/ml/includemod.ml +++ /dev/null @@ -1,694 +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. *) -(* *) -(**************************************************************************) - -(* Inclusion checks for the module language *) - -open Misc -open Path -open Typedtree -open Types - -type symptom = - Missing_field of Ident.t * Location.t * string (* kind *) - | Value_descriptions of Ident.t * value_description * value_description - | Type_declarations of Ident.t * type_declaration - * type_declaration * Includecore.type_mismatch list - | Extension_constructors of - Ident.t * extension_constructor * extension_constructor - | Module_types of module_type * module_type - | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration - | Modtype_permutation - | Interface_mismatch of string * string - | Class_type_declarations of - Ident.t * class_type_declaration * class_type_declaration * - Ctype.class_match_failure list - | Unbound_modtype_path of Path.t - | Unbound_module_path of Path.t - | Invalid_module_alias of Path.t - -type pos = - Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t -type error = pos list * Env.t * symptom - -exception Error of error list - -(* All functions "blah env x1 x2" check that x1 is included in x2, - i.e. that x1 is the type of an implementation that fulfills the - specification x2. If not, Error is raised with a backtrace of the error. *) - -(* Inclusion between value descriptions *) - -let value_descriptions ~loc env cxt subst id vd1 vd2 = - Cmt_format.record_value_dependency vd1 vd2; - Env.mark_value_used env (Ident.name id) vd1; - let vd2 = Subst.value_description subst vd2 in - try - Includecore.value_descriptions ~loc env id vd1 vd2 - with Includecore.Dont_match -> - raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)]) - -(* Inclusion between type declarations *) - -let type_declarations ~loc env ?(old_env=env) cxt subst id decl1 decl2 = - Env.mark_type_used env (Ident.name id) decl1; - let decl2 = Subst.type_declaration subst decl2 in - let err = - Includecore.type_declarations ~loc env (Ident.name id) decl1 id decl2 - in - if err <> [] then - raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)]) - -(* Inclusion between extension constructors *) - -let extension_constructors ~loc env cxt subst id ext1 ext2 = - let ext2 = Subst.extension_constructor subst ext2 in - if Includecore.extension_constructors ~loc env id ext1 ext2 - then () - else raise(Error[cxt, env, Extension_constructors(id, ext1, ext2)]) - -(* Inclusion between class declarations *) - -let class_type_declarations ~loc ~old_env env cxt subst id decl1 decl2 = - let decl2 = Subst.cltype_declaration subst decl2 in - match Includeclass.class_type_declarations ~loc env decl1 decl2 with - [] -> () - | reason -> - raise(Error[cxt, old_env, - Class_type_declarations(id, decl1, decl2, reason)]) - - -(* Expand a module type identifier when possible *) - -exception Dont_match - -let may_expand_module_path env path = - try ignore (Env.find_modtype_expansion path env); true - with Not_found -> false - -let expand_module_path env cxt path = - try - Env.find_modtype_expansion path env - with Not_found -> - raise(Error[cxt, env, Unbound_modtype_path path]) - -let expand_module_alias env cxt path = - try (Env.find_module path env).md_type - with Not_found -> - raise(Error[cxt, env, Unbound_module_path path]) - -(* -let rec normalize_module_path env cxt path = - match expand_module_alias env cxt path with - Mty_alias path' -> normalize_module_path env cxt path' - | _ -> path -*) - -(* Extract name, kind and ident from a signature item *) - -type field_desc = - Field_value of string - | Field_type of string - | Field_typext of string - | Field_module of string - | Field_modtype of string - | Field_classtype of string - -let kind_of_field_desc = function - | Field_value _ -> "value" - | Field_type _ -> "type" - | Field_typext _ -> "extension constructor" - | Field_module _ -> "module" - | Field_modtype _ -> "module type" - | Field_classtype _ -> "class type" - -let item_ident_name = function - Sig_value(id, d) -> (id, d.val_loc, Field_value(Ident.name id)) - | Sig_type(id, d, _) -> (id, d.type_loc, Field_type(Ident.name id)) - | Sig_typext(id, d, _) -> (id, d.ext_loc, Field_typext(Ident.name id)) - | Sig_module(id, d, _) -> (id, d.md_loc, Field_module(Ident.name id)) - | Sig_modtype(id, d) -> (id, d.mtd_loc, Field_modtype(Ident.name id)) - | Sig_class () -> assert false - | Sig_class_type(id, d, _) -> (id, d.clty_loc, Field_classtype(Ident.name id)) - -let is_runtime_component = function - | Sig_value(_,{val_kind = Val_prim _}) - | Sig_type(_,_,_) - | Sig_modtype(_,_) - | Sig_class_type(_,_,_) -> false - | Sig_value(_,_) - | Sig_typext(_,_,_) - | Sig_module(_,_,_) - | Sig_class() -> true - -(* Print a coercion *) - -let rec print_list pr ppf = function - [] -> () - | [a] -> pr ppf a - | a :: l -> pr ppf a; Format.fprintf ppf ";@ "; print_list pr ppf l -let print_list pr ppf l = - Format.fprintf ppf "[@[%a@]]" (print_list pr) l - -let rec print_coercion ppf c = - let pr fmt = Format.fprintf ppf fmt in - match c with - Tcoerce_none -> pr "id" - | Tcoerce_structure (fl, nl, _) -> - pr "@[<2>struct@ %a@ %a@]" - (print_list print_coercion2) fl - (print_list print_coercion3) nl - | Tcoerce_functor (inp, out) -> - pr "@[<2>functor@ (%a)@ (%a)@]" - print_coercion inp - print_coercion out - | Tcoerce_primitive {pc_desc; pc_env = _; pc_type} -> - pr "prim %s@ (%a)" pc_desc.Primitive.prim_name - Printtyp.raw_type_expr pc_type - | Tcoerce_alias (p, c) -> - pr "@[<2>alias %a@ (%a)@]" - Printtyp.path p - print_coercion c -and print_coercion2 ppf (n, c) = - Format.fprintf ppf "@[%d,@ %a@]" n print_coercion c -and print_coercion3 ppf (i, n, c) = - Format.fprintf ppf "@[%s, %d,@ %a@]" - (Ident.unique_name i) n print_coercion c - -(* Simplify a structure coercion *) - -let simplify_structure_coercion cc id_pos_list runtime_fields = - let rec is_identity_coercion pos = function - | [] -> - true - | (n, c) :: rem -> - n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in - if is_identity_coercion 0 cc - then Tcoerce_none - else Tcoerce_structure (cc, id_pos_list, runtime_fields) - -(* Inclusion between module types. - Return the restriction that transforms a value of the smaller type - into a value of the bigger type. *) - -let rec modtypes ~loc env cxt subst mty1 mty2 = - try - try_modtypes ~loc env cxt subst mty1 mty2 - with - Dont_match -> - raise(Error[cxt, env, Module_types(mty1, Subst.modtype subst mty2)]) - | Error reasons as err -> - match mty1, mty2 with - Mty_alias _, _ - | _, Mty_alias _ -> raise err - | _ -> - raise(Error((cxt, env, Module_types(mty1, Subst.modtype subst mty2)) - :: reasons)) - -and try_modtypes ~loc env cxt subst mty1 mty2 = - match (mty1, mty2) with - | (Mty_alias(pres1, p1), Mty_alias(pres2, p2)) -> begin - if Env.is_functor_arg p2 env then - raise (Error[cxt, env, Invalid_module_alias p2]); - if not (Path.same p1 p2) then begin - let p1 = Env.normalize_path None env p1 - and p2 = Env.normalize_path None env (Subst.module_path subst p2) in - if not (Path.same p1 p2) then raise Dont_match - end; - match pres1, pres2 with - | Mta_present, Mta_present -> Tcoerce_none - (* Should really be Tcoerce_ignore if it existed *) - | Mta_absent, Mta_absent -> Tcoerce_none - (* Should really be Tcoerce_empty if it existed *) - | Mta_present, Mta_absent -> Tcoerce_none - | Mta_absent, Mta_present -> - let p1 = try - Env.normalize_path (Some Location.none) env p1 - with Env.Error (Env.Missing_module (_, _, path)) -> - raise (Error[cxt, env, Unbound_module_path path]) - in - Tcoerce_alias (p1, Tcoerce_none) - end - | (Mty_alias(pres1, p1), _) -> begin - let p1 = try - Env.normalize_path (Some Location.none) env p1 - with Env.Error (Env.Missing_module (_, _, path)) -> - raise (Error[cxt, env, Unbound_module_path path]) - in - let mty1 = - Mtype.strengthen ~aliasable:true env - (expand_module_alias env cxt p1) p1 - in - let cc = modtypes ~loc env cxt subst mty1 mty2 in - match pres1 with - | Mta_present -> cc - | Mta_absent -> Tcoerce_alias (p1, cc) - end - | (Mty_ident p1, _) when may_expand_module_path env p1 -> - try_modtypes ~loc env cxt subst (expand_module_path env cxt p1) mty2 - | (_, Mty_ident _) -> - try_modtypes2 ~loc env cxt mty1 (Subst.modtype subst mty2) - | (Mty_signature sig1, Mty_signature sig2) -> - signatures ~loc env cxt subst sig1 sig2 - | (Mty_functor(param1, None, res1), Mty_functor(_param2, None, res2)) -> - begin match modtypes ~loc env (Body param1::cxt) subst res1 res2 with - Tcoerce_none -> Tcoerce_none - | cc -> Tcoerce_functor (Tcoerce_none, cc) - end - | (Mty_functor(param1, Some arg1, res1), - Mty_functor(param2, Some arg2, res2)) -> - let arg2' = Subst.modtype subst arg2 in - let cc_arg = modtypes ~loc env (Arg param1::cxt) Subst.identity arg2' arg1 in - let cc_res = - modtypes ~loc (Env.add_module param1 arg2' env) (Body param1::cxt) - (Subst.add_module param2 (Pident param1) subst) res1 res2 in - begin match (cc_arg, cc_res) with - (Tcoerce_none, Tcoerce_none) -> Tcoerce_none - | _ -> Tcoerce_functor(cc_arg, cc_res) - end - | (_, _) -> - raise Dont_match - -and try_modtypes2 ~loc env cxt mty1 mty2 = - (* mty2 is an identifier *) - match (mty1, mty2) with - (Mty_ident p1, Mty_ident p2) - when Path.same (Env.normalize_path_prefix None env p1) - (Env.normalize_path_prefix None env p2) -> - Tcoerce_none - | (_, Mty_ident p2) when may_expand_module_path env p2 -> - try_modtypes ~loc env cxt Subst.identity mty1 (expand_module_path env cxt p2) - | (_, _) -> - raise Dont_match - -(* Inclusion between signatures *) - -and signatures ~loc env cxt subst sig1 sig2 = - (* Environment used to check inclusion of components *) - let new_env = - Env.add_signature sig1 (Env.in_signature true env) in - (* Keep ids for module aliases *) - let (id_pos_list,_) = - List.fold_left - (fun ((l,pos) as id_pos) -> function - Sig_module (id, _, _) -> - ((id,pos,Tcoerce_none)::l , pos+1) - | item -> - if is_runtime_component item then (l,pos+1 ) else id_pos - ) - ([], 0) sig1 in - - let runtime_fields = - let get_id = function - | Sig_value (i,_) - | Sig_module (i,_,_) - | Sig_typext (i,_,_) - | Sig_modtype(i,_) - | Sig_class_type(i,_,_) - | Sig_type(i,_,_) -> Ident.name i - | Sig_class () -> assert false in - List.fold_right (fun item fields -> - if is_runtime_component item then get_id item :: fields else fields) sig2 [] in - - (* Build a table of the components of sig1, along with their positions. - The table is indexed by kind and name of component *) - let rec build_component_table pos tbl = function - [] -> pos, tbl - | item :: rem -> - let (id, _loc, name) = item_ident_name item in - let nextpos = if is_runtime_component item then pos + 1 else pos in - build_component_table nextpos - (Tbl.add name (id, item, pos) tbl) rem in - let len1, comps1 = - build_component_table 0 Tbl.empty sig1 in - let len2 = - List.fold_left - (fun n i -> if is_runtime_component i then n + 1 else n) - 0 - sig2 - in - (* Pair each component of sig2 with a component of sig1, - identifying the names along the way. - Return a coercion list indicating, for all run-time components - of sig2, the position of the matching run-time components of sig1 - and the coercion to be applied to it. *) - let rec pair_components subst paired unpaired = function - [] -> - begin match unpaired with - [] -> - let cc = - signature_components ~loc env new_env cxt subst - (List.rev paired) - in - if len1 = len2 then (* see PR#5098 *) - simplify_structure_coercion cc id_pos_list runtime_fields - else - Tcoerce_structure (cc, id_pos_list, runtime_fields) - | _ -> raise(Error unpaired) - end - | item2 :: rem -> - let (id2, loc, name2) = item_ident_name item2 in - let name2, report = - match item2, name2 with - Sig_type (_, {type_manifest=None}, _), Field_type s - when Btype.is_row_name s -> - (* Do not report in case of failure, - as the main type will generate an error *) - Field_type (String.sub s 0 (String.length s - 4)), false - | _ -> name2, true - in - begin match Tbl.find name2 comps1 with - | (id1, item1, pos1) -> - let new_subst = - match item2 with - Sig_type _ -> - Subst.add_type id2 (Pident id1) subst - | Sig_module _ -> - Subst.add_module id2 (Pident id1) subst - | Sig_modtype _ -> - Subst.add_modtype id2 (Mty_ident (Pident id1)) subst - | Sig_value _ | Sig_typext _ - | Sig_class _ | Sig_class_type _ -> - subst - in - pair_components new_subst - ((item1, item2, pos1) :: paired) unpaired rem - | exception Not_found -> - let unpaired = - if report then - (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) :: - unpaired - else unpaired in - pair_components subst paired unpaired rem - end in - (* Do the pairing and checking, and return the final coercion *) - pair_components subst [] [] sig2 - -(* Inclusion between signature components *) - -and signature_components ~loc old_env env cxt subst paired = - let comps_rec rem = signature_components ~loc old_env env cxt subst rem in - match paired with - [] -> [] - | (Sig_value(id1, valdecl1), Sig_value(_id2, valdecl2), pos) :: rem -> - let cc = value_descriptions ~loc env cxt subst id1 valdecl1 valdecl2 in - begin match valdecl2.val_kind with - Val_prim _ -> comps_rec rem - | _ -> (pos, cc) :: comps_rec rem - end - | (Sig_type(id1, tydecl1, _), Sig_type(_id2, tydecl2, _), _pos) :: rem -> - type_declarations ~loc ~old_env env cxt subst id1 tydecl1 tydecl2; - comps_rec rem - | (Sig_typext(id1, ext1, _), Sig_typext(_id2, ext2, _), pos) - :: rem -> - extension_constructors ~loc env cxt subst id1 ext1 ext2; - (pos, Tcoerce_none) :: comps_rec rem - | (Sig_module(id1, mty1, _), Sig_module(_id2, mty2, _), pos) :: rem -> - let cc = module_declarations ~loc env cxt subst id1 mty1 mty2 in - (pos, cc) :: comps_rec rem - | (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem -> - modtype_infos ~loc env cxt subst id1 info1 info2; - comps_rec rem - | (Sig_class _, Sig_class _ , _) :: _ -> assert false - | (Sig_class_type(id1, info1, _), - Sig_class_type(_id2, info2, _), _pos) :: rem -> - class_type_declarations ~loc ~old_env env cxt subst id1 info1 info2; - comps_rec rem - | _ -> - assert false - -and module_declarations ~loc env cxt subst id1 md1 md2 = - Builtin_attributes.check_deprecated_inclusion - ~def:md1.md_loc - ~use:md2.md_loc - loc - md1.md_attributes md2.md_attributes - (Ident.name id1); - let p1 = Pident id1 in - Env.mark_module_used env (Ident.name id1) md1.md_loc; - modtypes ~loc env (Module id1::cxt) subst - (Mtype.strengthen ~aliasable:true env md1.md_type p1) md2.md_type - -(* Inclusion between module type specifications *) - -and modtype_infos ~loc env cxt subst id info1 info2 = - Builtin_attributes.check_deprecated_inclusion - ~def:info1.mtd_loc - ~use:info2.mtd_loc - loc - info1.mtd_attributes info2.mtd_attributes - (Ident.name id); - let info2 = Subst.modtype_declaration subst info2 in - let cxt' = Modtype id :: cxt in - try - match (info1.mtd_type, info2.mtd_type) with - (None, None) -> () - | (Some _, None) -> () - | (Some mty1, Some mty2) -> - check_modtype_equiv ~loc env cxt' mty1 mty2 - | (None, Some mty2) -> - check_modtype_equiv ~loc env cxt' (Mty_ident(Pident id)) mty2 - with Error reasons -> - raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons)) - -and check_modtype_equiv ~loc env cxt mty1 mty2 = - match - (modtypes ~loc env cxt Subst.identity mty1 mty2, - modtypes ~loc env cxt Subst.identity mty2 mty1) - with - (Tcoerce_none, Tcoerce_none) -> () - | (_c1, _c2) -> - (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." - print_coercion _c1 print_coercion _c2; *) - raise(Error [cxt, env, Modtype_permutation]) - -(* Simplified inclusion check between module types (for Env) *) - -let can_alias env path = - let rec no_apply = function - | Pident _ -> true - | Pdot(p, _, _) -> no_apply p - | Papply _ -> false - in - no_apply path && not (Env.is_functor_arg path env) - -let check_modtype_inclusion ~loc env mty1 path1 mty2 = - try - let aliasable = can_alias env path1 in - ignore(modtypes ~loc env [] Subst.identity - (Mtype.strengthen ~aliasable env mty1 path1) mty2) - with Error _ -> - raise Not_found - -let _ = Env.check_modtype_inclusion := check_modtype_inclusion - -(* Check that an implementation of a compilation unit meets its - interface. *) - -let compunit env impl_name impl_sig intf_name intf_sig = - try - signatures ~loc:(Location.in_file impl_name) env [] Subst.identity - impl_sig intf_sig - with Error reasons -> - raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name)) - :: reasons)) - -(* Hide the context and substitution parameters to the outside world *) - -let modtypes ~loc env mty1 mty2 = modtypes ~loc env [] Subst.identity mty1 mty2 -let signatures env sig1 sig2 = - signatures ~loc:Location.none env [] Subst.identity sig1 sig2 -let type_declarations ~loc env id decl1 decl2 = - type_declarations ~loc env [] Subst.identity id decl1 decl2 - -(* -let modtypes env m1 m2 = - let c = modtypes env m1 m2 in - Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@." - Printtyp.modtype m1 Printtyp.modtype m2 - print_coercion c; - c -*) - -(* Error report *) - -open Format -open Printtyp - -let show_loc msg ppf loc = - fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg - -let show_locs ppf (loc1, loc2) = - show_loc "Expected declaration" ppf loc2; - show_loc "Actual declaration" ppf loc1 - -let include_err ~env ppf = function - | Missing_field (id, loc, kind) -> - fprintf ppf "The %s `%a' is required but not provided" kind ident id; - show_loc "Expected declaration" ppf loc - | Value_descriptions(id, d1, d2) -> - let curry_kind_1, curry_kind_2 = - match (Ctype.expand_head env d1.val_type, Ctype.expand_head env d2.val_type ) with - | { desc = Tarrow _ }, - { desc = Tconstr (Pident {name = "function$"},_,_)} -> (" (curried)", " (uncurried)") - | { desc = Tconstr (Pident {name = "function$"},_,_)}, - { desc = Tarrow _ } -> (" (uncurried)", " (curried)") - | _ -> ("", "") - in - fprintf ppf - "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" - (value_description id) d1 curry_kind_1 (value_description id) d2 curry_kind_2; - show_locs ppf (d1.val_loc, d2.val_loc); - | Type_declarations(id, d1, d2, errs) -> - fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" - "Type declarations do not match" - (type_declaration id) d1 - "is not included in" - (type_declaration id) d2 - show_locs (d1.type_loc, d2.type_loc) - (Includecore.report_type_mismatch - "the first" "the second" "declaration") errs - | Extension_constructors(id, x1, x2) -> - fprintf ppf - "@[Extension declarations do not match:@ \ - %a@;<1 -2>is not included in@ %a@]" - (extension_constructor id) x1 - (extension_constructor id) x2; - show_locs ppf (x1.ext_loc, x2.ext_loc) - | Module_types(mty1, mty2)-> - fprintf ppf - "@[Modules do not match:@ \ - %a@;<1 -2>is not included in@ %a@]" - modtype mty1 - modtype mty2 - | Modtype_infos(id, d1, d2) -> - fprintf ppf - "@[Module type declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]" - (modtype_declaration id) d1 - (modtype_declaration id) d2 - | Modtype_permutation -> - fprintf ppf "Illegal permutation of structure fields" - | Interface_mismatch(impl_name, intf_name) -> - fprintf ppf "@[The implementation %s@ does not match the interface %s:" - impl_name intf_name - | Class_type_declarations(id, d1, d2, reason) -> - fprintf ppf - "@[Class type declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]@ %a" - (Printtyp.cltype_declaration id) d1 - (Printtyp.cltype_declaration id) d2 - Includeclass.report_error reason - | Unbound_modtype_path path -> - fprintf ppf "Unbound module type %a" Printtyp.path path - | Unbound_module_path path -> - fprintf ppf "Unbound module %a" Printtyp.path path - | Invalid_module_alias path -> - fprintf ppf "Module %a cannot be aliased" Printtyp.path path - -let rec context ppf = function - Module id :: rem -> - fprintf ppf "@[<2>module %a%a@]" ident id args rem - | Modtype id :: rem -> - fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem - | Body x :: rem -> - fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem - | Arg x :: rem -> - fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem - | [] -> - fprintf ppf "" -and context_mty ppf = function - (Module _ | Modtype _) :: _ as rem -> - fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem - | cxt -> context ppf cxt -and args ppf = function - Body x :: rem -> - fprintf ppf "(%s)%a" (argname x) args rem - | Arg x :: rem -> - fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem - | cxt -> - fprintf ppf " :@ %a" context_mty cxt -and argname x = - let s = Ident.name x in - if s = "*" then "" else s - -let path_of_context = function - Module id :: rem -> - let rec subm path = function - [] -> path - | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem - | _ -> assert false - in subm (Pident id) rem - | _ -> assert false - -let context ppf cxt = - if cxt = [] then () else - if List.for_all (function Module _ -> true | _ -> false) cxt then - fprintf ppf "In module %a:@ " path (path_of_context cxt) - else - fprintf ppf "@[At position@ %a@]@ " context cxt - -let include_err ppf (cxt, env, err) = - Printtyp.wrap_printing_env env (fun () -> - fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err ~env) err) - -let buffer = ref Bytes.empty -let is_big obj = - let size = !Clflags.error_size in - size > 0 && - begin - if Bytes.length !buffer < size then buffer := Bytes.create size; - try ignore (Marshal.to_buffer !buffer 0 size obj []); false - with _ -> true - end - -let report_error ppf errs = - if errs = [] then () else - let (errs , err) = split_last errs in - let pe = ref true in - let include_err' ppf (_,_,obj as err) = - if not (is_big obj) then fprintf ppf "%a@ " include_err err - else if !pe then (fprintf ppf "...@ "; pe := false) - in - let print_errs ppf = List.iter (include_err' ppf) in - fprintf ppf "@[%a%a@]" print_errs errs include_err err - - -let better_candidate_loc (x : error list) = - match x with - | [ (_,_,Interface_mismatch _); (_,_,descr)] - -> - begin match descr with - | Value_descriptions (_,d1,_) -> Some d1.val_loc - | Type_declarations (_,tdcl1,_,_) -> - Some tdcl1.type_loc - | Missing_field (_,loc,_) -> Some loc - | _ -> None - end - | _ -> None - -(* We could do a better job to split the individual error items - as sub-messages of the main interface mismatch on the whole unit. *) -let () = - Location.register_error_of_exn - (function - | Error err -> - begin match better_candidate_loc err with - | None -> - Some (Location.error_of_printer_file report_error err) - | Some loc -> - Some (Location.error_of_printer loc report_error err) - end - | _ -> None - ) diff --git a/jscomp/ml/includemod.mli b/jscomp/ml/includemod.mli deleted file mode 100644 index 731baf7..0000000 --- a/jscomp/ml/includemod.mli +++ /dev/null @@ -1,62 +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. *) -(* *) -(**************************************************************************) - -(* Inclusion checks for the module language *) - -open Typedtree -open Types -open Format - -val modtypes: - loc:Location.t -> Env.t -> - module_type -> module_type -> module_coercion - -val signatures: Env.t -> signature -> signature -> module_coercion - -val compunit: - Env.t -> string -> signature -> string -> signature -> module_coercion - -val type_declarations: - loc:Location.t -> Env.t -> - Ident.t -> type_declaration -> type_declaration -> unit - -val print_coercion: formatter -> module_coercion -> unit - -type symptom = - Missing_field of Ident.t * Location.t * string (* kind *) - | Value_descriptions of Ident.t * value_description * value_description - | Type_declarations of Ident.t * type_declaration - * type_declaration * Includecore.type_mismatch list - | Extension_constructors of - Ident.t * extension_constructor * extension_constructor - | Module_types of module_type * module_type - | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration - | Modtype_permutation - | Interface_mismatch of string * string - | Class_type_declarations of - Ident.t * class_type_declaration * class_type_declaration * - Ctype.class_match_failure list - | Unbound_modtype_path of Path.t - | Unbound_module_path of Path.t - | Invalid_module_alias of Path.t - -type pos = - Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t -type error = pos list * Env.t * symptom - -exception Error of error list - -val report_error: formatter -> error list -> unit -val expand_module_alias: Env.t -> pos list -> Path.t -> Types.module_type diff --git a/jscomp/ml/lambda.ml b/jscomp/ml/lambda.ml deleted file mode 100644 index 91f63a9..0000000 --- a/jscomp/ml/lambda.ml +++ /dev/null @@ -1,799 +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. *) -(* *) -(**************************************************************************) - - - - - -type compile_time_constant = - | Big_endian - | Word_size - | Int_size - | Max_wosize - | Ostype_unix - | Ostype_win32 - | Ostype_cygwin - | Backend_type - -type loc_kind = - | Loc_FILE - | Loc_LINE - | Loc_MODULE - | Loc_LOC - | Loc_POS - -type record_repr = - | Record_regular - | Record_optional - - -type tag_info = - | Blk_constructor of {name : string ; num_nonconst : int ; tag : int; attrs : Parsetree.attributes } - | Blk_record_inlined of { name : string ; num_nonconst : int; tag : int; optional_labels: string list; fields : string array; mutable_flag : Asttypes.mutable_flag; attrs : Parsetree.attributes } - | Blk_tuple - | Blk_poly_var of string - | Blk_record of {fields : string array; mutable_flag : Asttypes.mutable_flag; record_repr : record_repr} - | Blk_module of string list - | Blk_module_export of Ident.t list - - | Blk_extension - | Blk_some - | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *) - | Blk_record_ext of { fields : string array; mutable_flag : Asttypes.mutable_flag} - | Blk_lazy_general - -let tag_of_tag_info (tag : tag_info ) = - match tag with - | Blk_constructor {tag} - | Blk_record_inlined {tag} -> tag - | Blk_tuple - | Blk_poly_var _ - | Blk_record _ - | Blk_module _ - | Blk_module_export _ - | Blk_extension - | Blk_some (* tag not make sense *) - | Blk_some_not_nested (* tag not make sense *) - | Blk_lazy_general (* tag not make sense 248 *) - | Blk_record_ext _ (* similar to Blk_extension*) - -> 0 - -let mutable_flag_of_tag_info (tag : tag_info) = - match tag with - | Blk_record_inlined {mutable_flag} - | Blk_record {mutable_flag} - | Blk_record_ext {mutable_flag} -> mutable_flag - | Blk_lazy_general -> Mutable - | Blk_tuple - | Blk_constructor _ - | Blk_poly_var _ - | Blk_module _ - | Blk_module_export _ - | Blk_extension - | Blk_some_not_nested - | Blk_some - -> Immutable - -type label = Types.label_description - -let find_name (attr : Parsetree.attribute) = - match attr with - | ( { txt = "bs.as" | "as" }, - PStr - [ - { - pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_constant (Pconst_string (s, _)) }, _); - }; - ] ) -> - Some s - | _ -> None - -let blk_record (fields : (label * _) array) mut record_repr = - let all_labels_info = - Ext_array.map fields (fun (lbl, _) -> - Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) - in - Blk_record - { fields = all_labels_info; mutable_flag = mut; record_repr } - - -let blk_record_ext fields mutable_flag = - let all_labels_info = - Array.map - (fun ((lbl : label), _) -> - Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name) - fields - in - Blk_record_ext {fields = all_labels_info; mutable_flag } - -let blk_record_inlined fields name num_nonconst optional_labels ~tag ~attrs mutable_flag = - let fields = - Array.map - (fun ((lbl : label), _) -> - Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) - fields - in - Blk_record_inlined {fields; name; num_nonconst; tag; mutable_flag; optional_labels; attrs } - -let ref_tag_info : tag_info = - Blk_record {fields = [| "contents" |]; mutable_flag = Mutable; record_repr = Record_regular} - -type field_dbg_info = - | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag} - | Fld_module of {name : string } - | Fld_record_inline of { name : string} - | Fld_record_extension of {name : string} - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - | Fld_array - -let fld_record (lbl : label) = - Fld_record - { - name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name; - mutable_flag = lbl.lbl_mut; - } - -let fld_record_extension (lbl : label) = - Fld_record_extension - { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name } - -let ref_field_info : field_dbg_info = - Fld_record { name = "contents"; mutable_flag = Mutable} - - -type set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string - -let ref_field_set_info : set_field_dbg_info = Fld_record_set "contents" -let fld_record_set (lbl : label) = - Fld_record_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) - -let fld_record_inline (lbl : label) = - Fld_record_inline - { name = Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name } - -let fld_record_inline_set (lbl : label) = - Fld_record_inline_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) - -let fld_record_extension_set (lbl : label) = - Fld_record_extension_set - (Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name) - -type immediate_or_pointer = - | Immediate - | Pointer - - - -type is_safe = - | Safe - | Unsafe - -type primitive = - | Pidentity - | Pbytes_to_string - | Pignore - | Prevapply - | Pdirapply - | Ploc of loc_kind - (* Globals *) - | Pgetglobal of Ident.t - (* Operations on heap blocks *) - | Pmakeblock of tag_info - | Pfield of int * field_dbg_info - | Psetfield of int * set_field_dbg_info - - - - | Pduprecord - (* Force lazy values *) - | Plazyforce - (* External call *) - | Pccall of Primitive.description - (* Exceptions *) - | Praise of raise_kind - (* Boolean operations *) - | Psequand | Psequor | Pnot - (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint - | Pintcomp of comparison - | Poffsetint of int - | Poffsetref of int - (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pfloatcomp of comparison - (* BigInt operations *) - | Pnegbigint | Paddbigint | Psubbigint | Ppowbigint - | Pmulbigint | Pdivbigint | Pmodbigint - | Pandbigint | Porbigint | Pxorbigint - | Plslbigint | Pasrbigint - | Pbigintcomp of comparison - (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - (* Array operations *) - | Pmakearray of Asttypes.mutable_flag - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - | Pisout - | Pbintofint of boxed_integer - | Pintofbint of boxed_integer - | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) - | Pnegbint of boxed_integer - | Paddbint of boxed_integer - | Psubbint of boxed_integer - | Pmulbint of boxed_integer - | Pdivbint of { size : boxed_integer; is_safe : is_safe } - | Pmodbint of { size : boxed_integer; is_safe : is_safe } - | Pandbint of boxed_integer - | Porbint of boxed_integer - | Pxorbint of boxed_integer - | Plslbint of boxed_integer - | Plsrbint of boxed_integer - | Pasrbint of boxed_integer - | Pbintcomp of boxed_integer * comparison - | Pctconst of compile_time_constant - (* Inhibition of optimisation *) - | Popaque - | Puncurried_apply - | Pcreate_extension of string -and comparison = - Ceq | Cneq | Clt | Cgt | Cle | Cge - -and value_kind = - Pgenval - - - -and boxed_integer = Primitive.boxed_integer = - Pbigint | Pint32 | Pint64 - - -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -type pointer_info = - | Pt_constructor of {name: string; const: int; non_const: int; attrs: Parsetree.attributes} - | Pt_variant of {name: string} - | Pt_module_alias - | Pt_shape_none - | Pt_assertfalse - - - -type structured_constant = - Const_base of Asttypes.constant - | Const_pointer of int * pointer_info - | Const_block of tag_info * structured_constant list - | Const_float_array of string list - | Const_immstring of string - | Const_false - | Const_true -type inline_attribute = - | Always_inline (* [@inline] or [@inline always] *) - | Never_inline (* [@inline never] *) - | Default_inline (* no [@inline] attribute *) - - - - -type let_kind = Strict | Alias | StrictOpt | Variable - - - - -type function_attribute = { - inline : inline_attribute; - is_a_functor: bool; - stub: bool; - return_unit : bool; - async : bool; - oneUnitArg : bool; -} - -type lambda = - Lvar of Ident.t - | Lconst of structured_constant - | Lapply of lambda_apply - | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * Asttypes.direction_flag * lambda - | Lassign of Ident.t * lambda - | Lsend of string * lambda * Location.t - -and lfunction = - { - params: Ident.t list; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc: Location.t; - } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_inlined : inline_attribute; - } - -and lambda_switch = - { sw_numconsts: int; - sw_consts: (int * lambda) list; - sw_numblocks: int; - sw_blocks: (int * lambda) list; - sw_failaction : lambda option; - sw_names: Ast_untagged_variants.switch_names option } - - - - -(* This is actually a dummy value - not necessary "()", it can be used as a place holder for module - alias etc. -*) -let const_unit = - Const_pointer - (0, Pt_constructor {name = "()"; const = 1; non_const = 0; attrs = []}) - -let lambda_assert_false = Lconst (Const_pointer(0, Pt_assertfalse)) - -let lambda_module_alias = Lconst (Const_pointer(0, Pt_module_alias)) - -let lambda_unit = Lconst const_unit - -let default_function_attribute = { - inline = Default_inline; - is_a_functor = false; - stub = false; - return_unit = false; - async = false; - oneUnitArg = false; -} - -let default_stub_attribute = - { default_function_attribute with stub = true } - -(* Build sharing keys *) -(* - Those keys are later compared with Pervasives.compare. - For that reason, they should not include cycles. -*) - -exception Not_simple - -let max_raw = 32 - -let make_key e = - let count = ref 0 (* Used for controling size *) - and make_key = Ident.make_key_generator () in - (* make_key is used for normalizing let-bound variables *) - let rec tr_rec env e = - incr count ; - if !count > max_raw then raise_notrace Not_simple ; (* Too big ! *) - match e with - | Lvar id -> - begin - try Ident.find_same id env - with Not_found -> e - end - | Lconst (Const_base (Const_string _)) -> - (* Mutable constants are not shared *) - raise_notrace Not_simple - | Lconst _ -> e - | Lapply ap -> - Lapply {ap with ap_func = tr_rec env ap.ap_func; - ap_args = tr_recs env ap.ap_args; - ap_loc = Location.none} - | Llet (Alias,_k,x,ex,e) -> (* Ignore aliases -> substitute *) - let ex = tr_rec env ex in - tr_rec (Ident.add x ex env) e - | Llet ((Strict | StrictOpt),_k,x,ex,Lvar v) when Ident.same v x -> - tr_rec env ex - | Llet (str,k,x,ex,e) -> - (* Because of side effects, keep other lets with normalized names *) - let ex = tr_rec env ex in - let y = make_key x in - Llet (str,k,y,ex,tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p,es,_) -> - Lprim (p,tr_recs env es, Location.none) - | Lswitch (e,sw,loc) -> - Lswitch (tr_rec env e,tr_sw env sw,loc) - | Lstringswitch (e,sw,d,_) -> - Lstringswitch - (tr_rec env e, - List.map (fun (s,e) -> s,tr_rec env e) sw, - tr_opt env d, - Location.none) - | Lstaticraise (i,es) -> - Lstaticraise (i,tr_recs env es) - | Lstaticcatch (e1,xs,e2) -> - Lstaticcatch (tr_rec env e1,xs,tr_rec env e2) - | Ltrywith (e1,x,e2) -> - Ltrywith (tr_rec env e1,x,tr_rec env e2) - | Lifthenelse (cond,ifso,ifnot) -> - Lifthenelse (tr_rec env cond,tr_rec env ifso,tr_rec env ifnot) - | Lsequence (e1,e2) -> - Lsequence (tr_rec env e1,tr_rec env e2) - | Lassign (x,e) -> - Lassign (x,tr_rec env e) - | Lsend (m,e1,_loc) -> - Lsend (m,tr_rec env e1,Location.none) - | Lletrec _|Lfunction _ - | Lfor _ | Lwhile _ - -> - raise_notrace Not_simple - - and tr_recs env es = List.map (tr_rec env) es - - and tr_sw env sw = - { sw with - sw_consts = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_consts ; - sw_blocks = List.map (fun (i,e) -> i,tr_rec env e) sw.sw_blocks ; - sw_failaction = tr_opt env sw.sw_failaction ; } - - and tr_opt env = function - | None -> None - | Some e -> Some (tr_rec env e) in - - try - Some (tr_rec Ident.empty e) - with Not_simple -> None - -(***************) - -let name_lambda strict arg fn = - match arg with - Lvar id -> fn id - | _ -> let id = Ident.create "let" in Llet(strict, Pgenval, id, arg, fn id) - -let name_lambda_list args fn = - let rec name_list names = function - [] -> fn (List.rev names) - | (Lvar _ as arg) :: rem -> - name_list (arg :: names) rem - | arg :: rem -> - let id = Ident.create "let" in - Llet(Strict, Pgenval, id, arg, name_list (Lvar id :: names) rem) in - name_list [] args - - -let iter_opt f = function - | None -> () - | Some e -> f e - -let iter f = function - Lvar _ - | Lconst _ -> () - | Lapply{ap_func = fn; ap_args = args} -> - f fn; List.iter f args - | Lfunction{body} -> - f body - | Llet(_str, _k, _id, arg, body) -> - f arg; f body - | Lletrec(decl, body) -> - f body; - List.iter (fun (_id, exp) -> f exp) decl - | Lprim(_p, args, _loc) -> - List.iter f args - | Lswitch(arg, sw,_) -> - f arg; - List.iter (fun (_key, case) -> f case) sw.sw_consts; - List.iter (fun (_key, case) -> f case) sw.sw_blocks; - iter_opt f sw.sw_failaction - | Lstringswitch (arg,cases,default,_) -> - f arg ; - List.iter (fun (_,act) -> f act) cases ; - iter_opt f default - | Lstaticraise (_,args) -> - List.iter f args - | Lstaticcatch(e1, _, e2) -> - f e1; f e2 - | Ltrywith(e1, _, e2) -> - f e1; f e2 - | Lifthenelse(e1, e2, e3) -> - f e1; f e2; f e3 - | Lsequence(e1, e2) -> - f e1; f e2 - | Lwhile(e1, e2) -> - f e1; f e2 - | Lfor(_v, e1, e2, _dir, e3) -> - f e1; f e2; f e3 - | Lassign(_, e) -> - f e - | Lsend (_k, obj, _) -> - f obj - -module IdentSet = Set.Make(Ident) - -let free_ids get l = - let fv = ref IdentSet.empty in - let rec free l = - iter free l; - fv := List.fold_right IdentSet.add (get l) !fv; - match l with - Lfunction{params} -> - List.iter (fun param -> fv := IdentSet.remove param !fv) params - | Llet(_str, _k, id, _arg, _body) -> - fv := IdentSet.remove id !fv - | Lletrec(decl, _body) -> - List.iter (fun (id, _exp) -> fv := IdentSet.remove id !fv) decl - | Lstaticcatch(_e1, (_,vars), _e2) -> - List.iter (fun id -> fv := IdentSet.remove id !fv) vars - | Ltrywith(_e1, exn, _e2) -> - fv := IdentSet.remove exn !fv - | Lfor(v, _e1, _e2, _dir, _e3) -> - fv := IdentSet.remove v !fv - | Lassign(id, _e) -> - fv := IdentSet.add id !fv - | Lvar _ | Lconst _ | Lapply _ - | Lprim _ | Lswitch _ | Lstringswitch _ | Lstaticraise _ - | Lifthenelse _ | Lsequence _ | Lwhile _ - | Lsend _ - -> () - in free l; !fv - -let free_variables l = - free_ids (function Lvar id -> [id] | _ -> []) l - - -(* Check if an action has a "when" guard *) -let raise_count = ref 0 - -let next_raise_count () = - incr raise_count ; - !raise_count - -let negative_raise_count = ref 0 - -let next_negative_raise_count () = - decr negative_raise_count ; - !negative_raise_count - -(* Anticipated staticraise, for guards *) -let staticfail = Lstaticraise (0,[]) - -let rec is_guarded = function - | Lifthenelse(_cond, _body, Lstaticraise (0,[])) -> true - | Llet(_str, _k, _id, _lam, body) -> is_guarded body - | _ -> false - -let rec patch_guarded patch = function - | Lifthenelse (cond, body, Lstaticraise (0,[])) -> - Lifthenelse (cond, body, patch) - | Llet(str, k, id, lam, body) -> - Llet (str, k, id, lam, patch_guarded patch body) - | _ -> assert false - -(* Translate an access path *) - -let rec transl_normal_path = function - Path.Pident id -> - if Ident.global id - then Lprim(Pgetglobal id, [], Location.none) - else Lvar id - | Pdot(p, s, pos) -> - Lprim(Pfield (pos, Fld_module {name = s}), [transl_normal_path p], Location.none) - | Papply _ -> - assert false - -(* Translation of identifiers *) - -let transl_module_path ?(loc=Location.none) env path = - transl_normal_path (Env.normalize_path (Some loc) env path) - -let transl_value_path ?(loc=Location.none) env path = - transl_normal_path (Env.normalize_path_prefix (Some loc) env path) - - -let transl_extension_path = transl_value_path - -(* compatibility alias, deprecated in the .mli *) -(* Compile a sequence of expressions *) - -let rec make_sequence fn = function - [] -> lambda_unit - | [x] -> fn x - | x::rem -> - let lam = fn x in Lsequence(lam, make_sequence fn rem) - -(* Apply a substitution to a lambda-term. - Assumes that the bound variables of the lambda-term do not - belong to the domain of the substitution. - Assumes that the image of the substitution is out of reach - of the bound variables of the lambda-term (no capture). *) - -let subst_lambda s lam = - let rec subst = function - Lvar id as l -> - begin try Ident.find_same id s with Not_found -> l end - | Lconst _ as l -> l - | Lapply ap -> - Lapply{ap with ap_func = subst ap.ap_func; - ap_args = List.map subst ap.ap_args} - | Lfunction{ params; body; attr; loc} -> - Lfunction{ params; body = subst body; attr; loc} - | Llet(str, k, id, arg, body) -> Llet(str, k, id, subst arg, subst body) - | Lletrec(decl, body) -> Lletrec(List.map subst_decl decl, subst body) - | Lprim(p, args, loc) -> Lprim(p, List.map subst args, loc) - | Lswitch(arg, sw, loc) -> - Lswitch(subst arg, - {sw with sw_consts = List.map subst_case sw.sw_consts; - sw_blocks = List.map subst_case sw.sw_blocks; - sw_failaction = subst_opt sw.sw_failaction; }, - loc) - | Lstringswitch (arg,cases,default,loc) -> - Lstringswitch - (subst arg,List.map subst_strcase cases,subst_opt default,loc) - | Lstaticraise (i,args) -> Lstaticraise (i, List.map subst args) - | Lstaticcatch(e1, io, e2) -> Lstaticcatch(subst e1, io, subst e2) - | Ltrywith(e1, exn, e2) -> Ltrywith(subst e1, exn, subst e2) - | Lifthenelse(e1, e2, e3) -> Lifthenelse(subst e1, subst e2, subst e3) - | Lsequence(e1, e2) -> Lsequence(subst e1, subst e2) - | Lwhile(e1, e2) -> Lwhile(subst e1, subst e2) - | Lfor(v, e1, e2, dir, e3) -> Lfor(v, subst e1, subst e2, dir, subst e3) - | Lassign(id, e) -> Lassign(id, subst e) - | Lsend (k, obj, loc) -> - Lsend (k,subst obj, loc) - and subst_decl (id, exp) = (id, subst exp) - and subst_case (key, case) = (key, subst case) - and subst_strcase (key, case) = (key, subst case) - and subst_opt = function - | None -> None - | Some e -> Some (subst e) - in subst lam - -let rec map f lam = - let lam = - match lam with - | Lvar _ -> lam - | Lconst _ -> lam - | Lapply { ap_func; ap_args; ap_loc; - ap_inlined; } -> - Lapply { - ap_func = map f ap_func; - ap_args = List.map (map f) ap_args; - ap_loc; - ap_inlined; - } - | Lfunction { params; body; attr; loc; } -> - Lfunction { params; body = map f body; attr; loc; } - | Llet (str, k, v, e1, e2) -> - Llet (str, k, v, map f e1, map f e2) - | Lletrec (idel, e2) -> - Lletrec (List.map (fun (v, e) -> (v, map f e)) idel, map f e2) - | Lprim (p, el, loc) -> - Lprim (p, List.map (map f) el, loc) - | Lswitch (e, sw, loc) -> - Lswitch (map f e, - { sw_numconsts = sw.sw_numconsts; - sw_consts = List.map (fun (n, e) -> (n, map f e)) sw.sw_consts; - sw_numblocks = sw.sw_numblocks; - sw_blocks = List.map (fun (n, e) -> (n, map f e)) sw.sw_blocks; - sw_failaction = Misc.may_map (map f) sw.sw_failaction; - sw_names = sw.sw_names - }, - loc) - | Lstringswitch (e, sw, default, loc) -> - Lstringswitch ( - map f e, - List.map (fun (s, e) -> (s, map f e)) sw, - Misc.may_map (map f) default, - loc) - | Lstaticraise (i, args) -> - Lstaticraise (i, List.map (map f) args) - | Lstaticcatch (body, id, handler) -> - Lstaticcatch (map f body, id, map f handler) - | Ltrywith (e1, v, e2) -> - Ltrywith (map f e1, v, map f e2) - | Lifthenelse (e1, e2, e3) -> - Lifthenelse (map f e1, map f e2, map f e3) - | Lsequence (e1, e2) -> - Lsequence (map f e1, map f e2) - | Lwhile (e1, e2) -> - Lwhile (map f e1, map f e2) - | Lfor (v, e1, e2, dir, e3) -> - Lfor (v, map f e1, map f e2, dir, map f e3) - | Lassign (v, e) -> - Lassign (v, map f e) - | Lsend (k, o, loc) -> - Lsend (k, map f o, loc) - in - f lam - -(* To let-bind expressions to variables *) - -let bind str var exp body = - match exp with - Lvar var' when Ident.same var var' -> body - | _ -> Llet(str, Pgenval, var, exp, body) - -and commute_comparison = function -| Ceq -> Ceq| Cneq -> Cneq -| Clt -> Cgt | Cle -> Cge -| Cgt -> Clt | Cge -> Cle - -and negate_comparison = function -| Ceq -> Cneq| Cneq -> Ceq -| Clt -> Cge | Cle -> Cgt -| Cgt -> Cle | Cge -> Clt - -let raise_kind = function - | Raise_regular -> "raise" - | Raise_reraise -> "reraise" - | Raise_notrace -> "raise_notrace" - -let lam_of_loc kind loc = - let loc_start = loc.Location.loc_start in - let (file, lnum, cnum) = Location.get_pos_info loc_start in - let file = Filename.basename file in - let enum = loc.Location.loc_end.Lexing.pos_cnum - - loc_start.Lexing.pos_cnum + cnum in - match kind with - | Loc_POS -> - Lconst (Const_block (Blk_tuple, [ - Const_immstring file; - Const_base (Const_int lnum); - Const_base (Const_int cnum); - Const_base (Const_int enum); - ])) - | Loc_FILE -> Lconst (Const_immstring file) - | Loc_MODULE -> - let filename = Filename.basename file in - let name = Env.get_unit_name () in - let module_name = if name = "" then "//"^filename^"//" else name in - Lconst (Const_immstring module_name) - | Loc_LOC -> - let loc = Printf.sprintf "File %S, line %d, characters %d-%d" - file lnum cnum enum in - Lconst (Const_immstring loc) - | Loc_LINE -> Lconst (Const_base (Const_int lnum)) - - -let reset () = - raise_count := 0 diff --git a/jscomp/ml/lambda.mli b/jscomp/ml/lambda.mli deleted file mode 100644 index f7fac1e..0000000 --- a/jscomp/ml/lambda.mli +++ /dev/null @@ -1,413 +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. *) -(* *) -(**************************************************************************) - -(* The "lambda" intermediate code *) - -open Asttypes - -type compile_time_constant = - | Big_endian - | Word_size - | Int_size - | Max_wosize - | Ostype_unix - | Ostype_win32 - | Ostype_cygwin - | Backend_type - -type loc_kind = - | Loc_FILE - | Loc_LINE - | Loc_MODULE - | Loc_LOC - | Loc_POS - -type record_repr = - | Record_regular - | Record_optional - -type tag_info = - | Blk_constructor of { name : string ; num_nonconst : int; tag : int; attrs : Parsetree.attributes } - | Blk_record_inlined of { name : string ; num_nonconst : int ; tag : int; optional_labels: string list; fields : string array; mutable_flag : mutable_flag; attrs : Parsetree.attributes } - | Blk_tuple - | Blk_poly_var of string - | Blk_record of {fields : string array; mutable_flag : mutable_flag; record_repr : record_repr } - | Blk_module of string list - | Blk_module_export of Ident.t list - | Blk_extension - (* underlying is the same as tuple, immutable block - {[ - exception A of int * int - ]} - is translated into - {[ - [A, x, y] - ]} - - *) - - | Blk_some - | Blk_some_not_nested (* ['a option] where ['a] can not inhabit a non-like value *) - | Blk_record_ext of {fields : string array; mutable_flag : mutable_flag} - | Blk_lazy_general - -val find_name : - Parsetree.attribute -> Asttypes.label option - -val tag_of_tag_info : tag_info -> int -val mutable_flag_of_tag_info : tag_info -> mutable_flag -val blk_record : - (Types.label_description* Typedtree.record_label_definition) array -> - mutable_flag -> - record_repr -> - tag_info - - -val blk_record_ext : - (Types.label_description* Typedtree.record_label_definition) array -> - mutable_flag -> - tag_info - - -val blk_record_inlined : - (Types.label_description* Typedtree.record_label_definition) array -> - string -> - int -> - string list -> - tag:int -> - attrs:Parsetree.attributes -> - mutable_flag -> - tag_info - - - - -val ref_tag_info : tag_info - -type field_dbg_info = - | Fld_record of {name : string; mutable_flag : Asttypes.mutable_flag} - | Fld_module of {name : string} - | Fld_record_inline of {name : string} - | Fld_record_extension of {name : string} - | Fld_tuple - | Fld_poly_var_tag - | Fld_poly_var_content - | Fld_extension - | Fld_variant - | Fld_cons - | Fld_array - -val fld_record : - Types.label_description -> - field_dbg_info - -val fld_record_inline : - Types.label_description -> - field_dbg_info - -val fld_record_extension : - Types.label_description -> - field_dbg_info - -val ref_field_info : field_dbg_info - - - -type set_field_dbg_info = - | Fld_record_set of string - | Fld_record_inline_set of string - | Fld_record_extension_set of string - -val ref_field_set_info : set_field_dbg_info - -val fld_record_set : - Types.label_description -> - set_field_dbg_info - -val fld_record_inline_set : - Types.label_description -> - set_field_dbg_info - -val fld_record_extension_set : - Types.label_description -> - set_field_dbg_info - -type immediate_or_pointer = - | Immediate - | Pointer -type is_safe = - | Safe - | Unsafe - -type pointer_info = - | Pt_constructor of {name: string; const: int; non_const: int; attrs: Parsetree.attributes} - | Pt_variant of {name: string} - | Pt_module_alias - | Pt_shape_none - | Pt_assertfalse - -type primitive = - | Pidentity - | Pbytes_to_string - | Pignore - | Prevapply - | Pdirapply - | Ploc of loc_kind - (* Globals *) - | Pgetglobal of Ident.t - (* Operations on heap blocks *) - | Pmakeblock of tag_info - | Pfield of int * field_dbg_info - | Psetfield of int * set_field_dbg_info - - - | Pduprecord - (* Force lazy values *) - | Plazyforce - (* External call *) - | Pccall of Primitive.description - (* Exceptions *) - | Praise of raise_kind - (* Boolean operations *) - | Psequand | Psequor | Pnot - (* Integer operations *) - | Pnegint | Paddint | Psubint | Pmulint - | Pdivint of is_safe | Pmodint of is_safe - | Pandint | Porint | Pxorint - | Plslint | Plsrint | Pasrint - | Pintcomp of comparison - | Poffsetint of int - | Poffsetref of int - (* Float operations *) - | Pintoffloat | Pfloatofint - | Pnegfloat | Pabsfloat - | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat - | Pfloatcomp of comparison - (* BigInt operations *) - | Pnegbigint | Paddbigint | Psubbigint | Ppowbigint - | Pmulbigint | Pdivbigint | Pmodbigint - | Pandbigint | Porbigint | Pxorbigint - | Plslbigint | Pasrbigint - | Pbigintcomp of comparison - (* String operations *) - | Pstringlength | Pstringrefu | Pstringrefs - | Pbyteslength | Pbytesrefu | Pbytessetu | Pbytesrefs | Pbytessets - (* Array operations *) - | Pmakearray of mutable_flag - | Parraylength - | Parrayrefu - | Parraysetu - | Parrayrefs - | Parraysets - (* Test if the argument is a block or an immediate integer *) - | Pisint - (* Test if the (integer) argument is outside an interval *) - | Pisout - (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *) - | Pbintofint of boxed_integer - | Pintofbint of boxed_integer - | Pcvtbint of boxed_integer (*source*) * boxed_integer (*destination*) - | Pnegbint of boxed_integer - | Paddbint of boxed_integer - | Psubbint of boxed_integer - | Pmulbint of boxed_integer - | Pdivbint of { size : boxed_integer; is_safe : is_safe } - | Pmodbint of { size : boxed_integer; is_safe : is_safe } - | Pandbint of boxed_integer - | Porbint of boxed_integer - | Pxorbint of boxed_integer - | Plslbint of boxed_integer - | Plsrbint of boxed_integer - | Pasrbint of boxed_integer - | Pbintcomp of boxed_integer * comparison - | Pctconst of compile_time_constant - (* Inhibition of optimisation *) - | Popaque - | Puncurried_apply - | Pcreate_extension of string -and comparison = - Ceq | Cneq | Clt | Cgt | Cle | Cge - - -and value_kind = - Pgenval - - -and boxed_integer = Primitive.boxed_integer = - Pbigint | Pint32 | Pint64 - - -and raise_kind = - | Raise_regular - | Raise_reraise - | Raise_notrace - -type structured_constant = - Const_base of constant - | Const_pointer of int * pointer_info - | Const_block of tag_info * structured_constant list - | Const_float_array of string list - | Const_immstring of string - | Const_false - | Const_true - -type inline_attribute = - | Always_inline (* [@inline] or [@inline always] *) - | Never_inline (* [@inline never] *) - | Default_inline (* no [@inline] attribute *) - - - - -type let_kind = Strict | Alias | StrictOpt | Variable -(* Meaning of kinds for let x = e in e': - Strict: e may have side-effects; always evaluate e first - (If e is a simple expression, e.g. a variable or constant, - we may still substitute e'[x/e].) - Alias: e is pure, we can substitute e'[x/e] if x has 0 or 1 occurrences - in e' - StrictOpt: e does not have side-effects, but depend on the store; - we can discard e if x does not appear in e' - Variable: the variable x is assigned later in e' - *) - - - - -(* [true] means yes, [false] may mean unknown *) -type function_attribute = { - inline : inline_attribute; - is_a_functor: bool; - stub: bool; - return_unit : bool; - async : bool; - oneUnitArg : bool; -} - -type lambda = - Lvar of Ident.t - | Lconst of structured_constant - | Lapply of lambda_apply - | Lfunction of lfunction - | Llet of let_kind * value_kind * Ident.t * lambda * lambda - | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t - | Lswitch of lambda * lambda_switch * Location.t -(* switch on strings, clauses are sorted by string order, - strings are pairwise distinct *) - | Lstringswitch of - lambda * (string * lambda) list * lambda option * Location.t - | Lstaticraise of int * lambda list - | Lstaticcatch of lambda * (int * Ident.t list) * lambda - | Ltrywith of lambda * Ident.t * lambda - | Lifthenelse of lambda * lambda * lambda - | Lsequence of lambda * lambda - | Lwhile of lambda * lambda - | Lfor of Ident.t * lambda * lambda * direction_flag * lambda - | Lassign of Ident.t * lambda - | Lsend of string * lambda * Location.t - -and lfunction = - { - params: Ident.t list; - body: lambda; - attr: function_attribute; (* specified with [@inline] attribute *) - loc : Location.t; } - -and lambda_apply = - { ap_func : lambda; - ap_args : lambda list; - ap_loc : Location.t; - ap_inlined : inline_attribute; (* specified with the [@inlined] attribute *) - } - -and lambda_switch = - { sw_numconsts: int; (* Number of integer cases *) - sw_consts: (int * lambda) list; (* Integer cases *) - sw_numblocks: int; (* Number of tag block cases *) - sw_blocks: (int * lambda) list; (* Tag block cases *) - sw_failaction : lambda option; (* Action to take if failure *) - sw_names: Ast_untagged_variants.switch_names option } - - - -(* Lambda code for the middle-end. - * In the closure case the code is a sequence of assignments to a - preallocated block of size [main_module_block_size] using - (Setfield(Getglobal(module_ident))). The size is used to preallocate - the block. - * In the flambda case the code is an expression returning a block - value of size [main_module_block_size]. The size is used to build - the module root as an initialize_symbol - Initialize_symbol(module_name, 0, - [getfield 0; ...; getfield (main_module_block_size - 1)]) -*) - -(* Sharing key *) -val make_key: lambda -> lambda option - -val const_unit: structured_constant -val lambda_assert_false: lambda -val lambda_unit: lambda -val lambda_module_alias : lambda -val name_lambda: let_kind -> lambda -> (Ident.t -> lambda) -> lambda -val name_lambda_list: lambda list -> (lambda list -> lambda) -> lambda - -val iter: (lambda -> unit) -> lambda -> unit -module IdentSet: Set.S with type elt = Ident.t -val free_variables: lambda -> IdentSet.t - -val transl_normal_path: Path.t -> lambda (* Path.t is already normal *) - -val transl_module_path: ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_value_path: ?loc:Location.t -> Env.t -> Path.t -> lambda -val transl_extension_path: ?loc:Location.t -> Env.t -> Path.t -> lambda - - -val make_sequence: ('a -> lambda) -> 'a list -> lambda - -val subst_lambda: lambda Ident.tbl -> lambda -> lambda -val map : (lambda -> lambda) -> lambda -> lambda -val bind : let_kind -> Ident.t -> lambda -> lambda -> lambda - -val commute_comparison : comparison -> comparison -val negate_comparison : comparison -> comparison - -val default_function_attribute : function_attribute -val default_stub_attribute : function_attribute - -(***********************) -(* For static failures *) -(***********************) - -(* Get a new static failure ident *) -val next_raise_count : unit -> int -val next_negative_raise_count : unit -> int - (* Negative raise counts are used to compile 'match ... with - exception x -> ...'. This disabled some simplifications - performed by the Simplif module that assume that static raises - are in tail position in their handler. *) - -val staticfail : lambda (* Anticipated static failure *) - -(* Check anticipated failure, substitute its final value *) -val is_guarded: lambda -> bool -val patch_guarded : lambda -> lambda -> lambda - -val raise_kind: raise_kind -> string -val lam_of_loc : loc_kind -> Location.t -> lambda - - -val reset: unit -> unit diff --git a/jscomp/ml/lexer.mli b/jscomp/ml/lexer.mli deleted file mode 100644 index 2388b9b..0000000 --- a/jscomp/ml/lexer.mli +++ /dev/null @@ -1,65 +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. *) -(* *) -(**************************************************************************) - -(* The lexical analyzer *) - -val init : unit -> unit -val token: Lexing.lexbuf -> Parser.token -val skip_hash_bang: Lexing.lexbuf -> unit - - -type error = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment of Location.t - | Unterminated_string - | Unterminated_string_in_comment of Location.t * Location.t - | Keyword_as_label of string - | Invalid_literal of string - | Invalid_directive of string * string option - -;; - -exception Error of error * Location.t - - - -val in_comment : unit -> bool;; -val in_string : unit -> bool;; - - -val print_warnings : bool ref -val handle_docstrings: bool ref -val comments : unit -> (string * Location.t) list -val token_with_comments : Lexing.lexbuf -> Parser.token - -(* - [set_preprocessor init preprocessor] registers [init] as the function -to call to initialize the preprocessor when the lexer is initialized, -and [preprocessor] a function that is called when a new token is needed -by the parser, as [preprocessor lexer lexbuf] where [lexer] is the -lexing function. - -When a preprocessor is configured by calling [set_preprocessor], the lexer -changes its behavior to accept backslash-newline as a token-separating blank. -*) - -val set_preprocessor : - (unit -> unit) -> - ((Lexing.lexbuf -> Parser.token) -> Lexing.lexbuf -> Parser.token) -> - unit - - - diff --git a/jscomp/ml/lexer.mll b/jscomp/ml/lexer.mll deleted file mode 100644 index 3663fd3..0000000 --- a/jscomp/ml/lexer.mll +++ /dev/null @@ -1,792 +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. *) -(* *) -(**************************************************************************) - -(* The lexer definition *) - -{ -open Lexing -open Misc -open Parser - -type error = - | Illegal_character of char - | Illegal_escape of string - | Unterminated_comment of Location.t - | Unterminated_string - | Unterminated_string_in_comment of Location.t * Location.t - | Keyword_as_label of string - | Invalid_literal of string - | Invalid_directive of string * string option -;; - -exception Error of error * Location.t;; - -(* The table of keywords *) - -let keyword_table = - create_hashtable 149 [ - "and", AND; - "as", AS; - "assert", ASSERT; - "begin", BEGIN; - "class", CLASS; - "constraint", CONSTRAINT; - "do", DO; - "done", DONE; - "downto", DOWNTO; - "else", ELSE; - "end", END; - "exception", EXCEPTION; - "external", EXTERNAL; - "false", FALSE; - "for", FOR; - "fun", FUN; - "function", FUNCTION; - "functor", FUNCTOR; - "if", IF; - "in", IN; - "include", INCLUDE; - "inherit", INHERIT; - "initializer", INITIALIZER; - "lazy", LAZY; - "let", LET; - "match", MATCH; - "method", METHOD; - "module", MODULE; - "mutable", MUTABLE; - "new", NEW; - "nonrec", NONREC; - "object", OBJECT; - "of", OF; - "open", OPEN; - "or", OR; -(* "parser", PARSER; *) - "private", PRIVATE; - "rec", REC; - "sig", SIG; - "struct", STRUCT; - "then", THEN; - "to", TO; - "true", TRUE; - "try", TRY; - "type", TYPE; - "val", VAL; - "virtual", VIRTUAL; - "when", WHEN; - "while", WHILE; - "with", WITH; - - "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) - "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) - "mod", INFIXOP3("mod"); - "land", INFIXOP3("land"); - "lsl", INFIXOP4("lsl"); - "lsr", INFIXOP4("lsr"); - "asr", INFIXOP4("asr") -] - -(* To buffer string literals *) - -let string_buffer = Buffer.create 256 -let reset_string_buffer () = Buffer.reset string_buffer -let get_stored_string () = Buffer.contents string_buffer - -let store_string_char c = Buffer.add_char string_buffer c -let store_string_utf_8_uchar u = Buffer.add_utf_8_uchar string_buffer u -let store_string s = Buffer.add_string string_buffer s -let store_lexeme lexbuf = store_string (Lexing.lexeme lexbuf) - -(* To store the position of the beginning of a string and comment *) -let string_start_loc = ref Location.none;; -let comment_start_loc = ref [];; -let in_comment () = !comment_start_loc <> [];; -let is_in_string = ref false -let in_string () = !is_in_string -let print_warnings = ref true - -(* Escaped chars are interpreted in strings unless they are in comments. *) -let store_escaped_char lexbuf c = - if in_comment () then store_lexeme lexbuf else store_string_char c - -let store_escaped_uchar lexbuf u = - if in_comment () then store_lexeme lexbuf else store_string_utf_8_uchar u - -let with_comment_buffer comment lexbuf = - let start_loc = Location.curr lexbuf in - comment_start_loc := [start_loc]; - reset_string_buffer (); - let end_loc = comment lexbuf in - let s = get_stored_string () in - reset_string_buffer (); - let loc = { start_loc with Location.loc_end = end_loc.Location.loc_end } in - s, loc - -(* To translate escape sequences *) - -let hex_digit_value d = (* assert (d in '0'..'9' 'a'..'f' 'A'..'F') *) - let d = Char.code d in - if d >= 97 then d - 87 else - if d >= 65 then d - 55 else - d - 48 - -let hex_num_value lexbuf ~first ~last = - let rec loop acc i = match i > last with - | true -> acc - | false -> - let value = hex_digit_value (Lexing.lexeme_char lexbuf i) in - loop (16 * acc + value) (i + 1) - in - loop 0 first - -let char_for_backslash = function - | 'n' -> '\010' - | 'r' -> '\013' - | 'b' -> '\008' - | 't' -> '\009' - | c -> c - -let char_for_decimal_code lexbuf i = - let c = 100 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + - 10 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in - if not (Uchar.is_valid c ) then - if in_comment () - then 'x' - else raise (Error(Illegal_escape (Lexing.lexeme lexbuf), - Location.curr lexbuf)) - else (Obj.magic (c : int) : char) - -let char_for_octal_code lexbuf i = - let c = 64 * (Char.code(Lexing.lexeme_char lexbuf i) - 48) + - 8 * (Char.code(Lexing.lexeme_char lexbuf (i+1)) - 48) + - (Char.code(Lexing.lexeme_char lexbuf (i+2)) - 48) in - Char.chr c - -let char_for_hexadecimal_code lexbuf i = - let byte = hex_num_value lexbuf ~first:i ~last:(i+1) in - Char.chr byte - -let uchar_for_uchar_escape lexbuf = - let err e = - raise - (Error (Illegal_escape (Lexing.lexeme lexbuf ^ e), Location.curr lexbuf)) - in - let len = Lexing.lexeme_end lexbuf - Lexing.lexeme_start lexbuf in - let first = 3 (* skip opening \u{ *) in - let last = len - 2 (* skip closing } *) in - let digit_count = last - first + 1 in - match digit_count > 6 with - | true -> err ", too many digits, expected 1 to 6 hexadecimal digits" - | false -> - let cp = hex_num_value lexbuf ~first ~last in - if Uchar.is_valid cp then Uchar.unsafe_of_int cp else - err (", " ^ Printf.sprintf "%X" cp ^ " is not a Unicode scalar value") - -(* recover the name from a LABEL or OPTLABEL token *) - -let get_label_name lexbuf = - let s = Lexing.lexeme lexbuf in - let name = String.sub s 1 (String.length s - 2) in - if Hashtbl.mem keyword_table name then - raise (Error(Keyword_as_label name, Location.curr lexbuf)); - name -;; - -(* Update the current location with file name and line number. *) - -let update_loc lexbuf file line absolute chars = - let pos = lexbuf.lex_curr_p in - let new_file = match file with - | None -> pos.pos_fname - | Some s -> s - in - lexbuf.lex_curr_p <- { pos with - pos_fname = new_file; - pos_lnum = if absolute then line else pos.pos_lnum + line; - pos_bol = pos.pos_cnum - chars; - } -;; - -let preprocessor = ref None - -let escaped_newlines = ref false - - -let handle_docstrings = ref true -let comment_list = ref [] - -let add_comment com = - comment_list := com :: !comment_list - -let add_docstring_comment ds = - let com = - ("*" ^ Docstrings.docstring_body ds, Docstrings.docstring_loc ds) - in - add_comment com - -let comments () = List.rev !comment_list - -(* Error report *) - -open Format - -let report_error ppf = function - | Illegal_character c -> - fprintf ppf "Illegal character (%s)" (Char.escaped c) - | Illegal_escape s -> - fprintf ppf "Illegal backslash escape in string or character (%s)" s - | Unterminated_comment _ -> - fprintf ppf "Comment not terminated" - | Unterminated_string -> - fprintf ppf "String literal not terminated" - | Unterminated_string_in_comment (_, loc) -> - fprintf ppf "This comment contains an unterminated string literal@.\ - %aString literal begins here" - (Location.print_error "") loc - | Keyword_as_label kwd -> - fprintf ppf "`%s' is a keyword, it cannot be used as label name" kwd - | Invalid_literal s -> - fprintf ppf "Invalid literal %s" s - | Invalid_directive (dir, explanation) -> - fprintf ppf "Invalid lexer directive %S" dir; - begin match explanation with - | None -> () - | Some expl -> fprintf ppf ": %s" expl - end - -let () = - Location.register_error_of_exn - (function - | Error (err, loc) -> - Some (Location.error_of_printer loc report_error err) - | _ -> - None - ) - -} - -let newline = ('\013'* '\010') -let blank = [' ' '\009' '\012'] -let lowercase = ['a'-'z' '_'] -let uppercase = ['A'-'Z'] -let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9'] -let symbolchar = - ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] -let dotsymbolchar = - ['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '~'] -let decimal_literal = - ['0'-'9'] ['0'-'9' '_']* -let hex_digit = - ['0'-'9' 'A'-'F' 'a'-'f'] -let hex_literal = - '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']* -let oct_literal = - '0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']* -let bin_literal = - '0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']* -let int_literal = - decimal_literal | hex_literal | oct_literal | bin_literal -let float_literal = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? -let hex_float_literal = - '0' ['x' 'X'] - ['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']* - ('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )? - (['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )? -let literal_modifier = ['G'-'Z' 'g'-'z'] - -rule token = parse - | "\\" newline { - if not !escaped_newlines then - raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), - Location.curr lexbuf)); - update_loc lexbuf None 1 false 0; - token lexbuf } - | newline - { update_loc lexbuf None 1 false 0; - EOL } - | blank + - { token lexbuf } - | "_" - { UNDERSCORE } - | "~" - { TILDE } - | "~" lowercase identchar * ':' - { LABEL (get_label_name lexbuf) } - | "?" - { QUESTION } - | "?" lowercase identchar * ':' - { OPTLABEL (get_label_name lexbuf) } - | lowercase identchar * - { let s = Lexing.lexeme lexbuf in - try Hashtbl.find keyword_table s - with Not_found -> LIDENT s } - | uppercase identchar * - { UIDENT(Lexing.lexeme lexbuf) } (* No capitalized keywords *) - | int_literal { INT (Lexing.lexeme lexbuf, None) } - | (int_literal as lit) (literal_modifier as modif) - { INT (lit, Some modif) } - | float_literal | hex_float_literal - { FLOAT (Lexing.lexeme lexbuf, None) } - | ((float_literal | hex_float_literal) as lit) (literal_modifier as modif) - { FLOAT (lit, Some modif) } - | (float_literal | hex_float_literal | int_literal) identchar+ - { raise (Error(Invalid_literal (Lexing.lexeme lexbuf), - Location.curr lexbuf)) } - | "\"" - { reset_string_buffer(); - is_in_string := true; - let string_start = lexbuf.lex_start_p in - string_start_loc := Location.curr lexbuf; - string lexbuf; - is_in_string := false; - lexbuf.lex_start_p <- string_start; - STRING (get_stored_string(), None) } - | "{" lowercase* "|" - { reset_string_buffer(); - let delim = Lexing.lexeme lexbuf in - let delim = String.sub delim 1 (String.length delim - 2) in - is_in_string := true; - let string_start = lexbuf.lex_start_p in - string_start_loc := Location.curr lexbuf; - quoted_string delim lexbuf; - is_in_string := false; - lexbuf.lex_start_p <- string_start; - STRING (get_stored_string(), Some delim) } - | "\'" newline "\'" - { update_loc lexbuf None 1 false 1; - CHAR (Lexing.lexeme_char lexbuf 1) } - | "\'" [^ '\\' '\'' '\010' '\013'] "\'" - { CHAR(Lexing.lexeme_char lexbuf 1) } - | "\'\\" ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] "\'" - { CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" - { CHAR(char_for_decimal_code lexbuf 2) } - | "\'\\" 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] "\'" - { CHAR(char_for_octal_code lexbuf 3) } - | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" - { CHAR(char_for_hexadecimal_code lexbuf 3) } - | "\'\\" _ - { let l = Lexing.lexeme lexbuf in - let esc = String.sub l 1 (String.length l - 1) in - raise (Error(Illegal_escape esc, Location.curr lexbuf)) - } - | "(*" - { let s, loc = with_comment_buffer comment lexbuf in - COMMENT (s, loc) } - | "(**" - { let s, loc = with_comment_buffer comment lexbuf in - if !handle_docstrings then - DOCSTRING (Docstrings.docstring s loc) - else - COMMENT ("*" ^ s, loc) - } - | "(**" (('*'+) as stars) - { let s, loc = - with_comment_buffer - (fun lexbuf -> - store_string ("*" ^ stars); - comment lexbuf) - lexbuf - in - COMMENT (s, loc) } - | "(*)" - { if !print_warnings then - Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; - let s, loc = with_comment_buffer comment lexbuf in - COMMENT (s, loc) } - | "(*" (('*'*) as stars) "*)" - { if !handle_docstrings && stars="" then - (* (**) is an empty docstring *) - DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf)) - else - COMMENT (stars, Location.curr lexbuf) } - | "*)" - { let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Comment_not_end; - lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; - let curpos = lexbuf.lex_curr_p in - lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 }; - STAR - } - | ("#" [' ' '\t']* (['0'-'9']+ as num) [' ' '\t']* - ("\"" ([^ '\010' '\013' '\"' ] * as name) "\"")?) as directive - [^ '\010' '\013'] * newline - { - match int_of_string num with - | exception _ -> - (* PR#7165 *) - let loc = Location.curr lexbuf in - let explanation = "line number out of range" in - let error = Invalid_directive (directive, Some explanation) in - raise (Error (error, loc)) - | line_num -> - (* Documentation says that the line number should be - positive, but we have never guarded against this and it - might have useful hackish uses. *) - update_loc lexbuf name line_num true 0; - token lexbuf - } - | "#" { HASH } - | "&" { AMPERSAND } - | "&&" { AMPERAMPER } - | "`" { BACKQUOTE } - | "\'" { QUOTE } - | "(" { LPAREN } - | ")" { RPAREN } - | "*" { STAR } - | "," { COMMA } - | "->" { MINUSGREATER } - | "." { DOT } - | ".." { DOTDOT } - | "." (dotsymbolchar symbolchar* as s) { DOTOP s } - | ":" { COLON } - | "::" { COLONCOLON } - | ":=" { COLONEQUAL } - | ":>" { COLONGREATER } - | ";" { SEMI } - | ";;" { SEMISEMI } - | "<" { LESS } - | "<-" { LESSMINUS } - | "=" { EQUAL } - | "[" { LBRACKET } - | "[|" { LBRACKETBAR } - | "[<" { LBRACKETLESS } - | "[>" { LBRACKETGREATER } - | "]" { RBRACKET } - | "{" { LBRACE } - | "{<" { LBRACELESS } - | "|" { BAR } - | "||" { BARBAR } - | "|]" { BARRBRACKET } - | ">" { GREATER } - | ">]" { GREATERRBRACKET } - | "}" { RBRACE } - | ">}" { GREATERRBRACE } - | "[@" { LBRACKETAT } - | "[@@" { LBRACKETATAT } - | "[@@@" { LBRACKETATATAT } - | "[%" { LBRACKETPERCENT } - | "[%%" { LBRACKETPERCENTPERCENT } - | "!" { BANG } - | "!=" { INFIXOP0 "!=" } - | "+" { PLUS } - | "+." { PLUSDOT } - | "+=" { PLUSEQ } - | "-" { MINUS } - | "-." { MINUSDOT } - - | "!" symbolchar + - { PREFIXOP(Lexing.lexeme lexbuf) } - | ['~' '?'] symbolchar + - { PREFIXOP(Lexing.lexeme lexbuf) } - | ['=' '<' '>' '|' '&' '$'] symbolchar * - { INFIXOP0(Lexing.lexeme lexbuf) } - | ['@' '^'] symbolchar * - { INFIXOP1(Lexing.lexeme lexbuf) } - | ['+' '-'] symbolchar * - { INFIXOP2(Lexing.lexeme lexbuf) } - | "**" symbolchar * - { INFIXOP4(Lexing.lexeme lexbuf) } - | '%' { PERCENT } - | ['*' '/' '%'] symbolchar * - { INFIXOP3(Lexing.lexeme lexbuf) } - | '#' (symbolchar | '#') + - { HASHOP(Lexing.lexeme lexbuf) } - | eof { Rescript_cpp.eof_check lexbuf; EOF} - | _ - { raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), - Location.curr lexbuf)) - } - -and comment = parse - "(*" - { comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; - store_lexeme lexbuf; - comment lexbuf - } - | "*)" - { match !comment_start_loc with - | [] -> assert false - | [_] -> comment_start_loc := []; Location.curr lexbuf - | _ :: l -> comment_start_loc := l; - store_lexeme lexbuf; - comment lexbuf - } - | "\"" - { - string_start_loc := Location.curr lexbuf; - store_string_char '\"'; - is_in_string := true; - begin try string lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), - loc)) - end; - is_in_string := false; - store_string_char '\"'; - comment lexbuf } - | "{" lowercase* "|" - { - let delim = Lexing.lexeme lexbuf in - let delim = String.sub delim 1 (String.length delim - 2) in - string_start_loc := Location.curr lexbuf; - store_lexeme lexbuf; - is_in_string := true; - begin try quoted_string delim lexbuf - with Error (Unterminated_string, str_start) -> - match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_string_in_comment (start, str_start), - loc)) - end; - is_in_string := false; - store_string_char '|'; - store_string delim; - store_string_char '}'; - comment lexbuf } - - | "\'\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'" newline "\'" - { update_loc lexbuf None 1 false 1; - store_lexeme lexbuf; - comment lexbuf - } - | "\'" [^ '\\' '\'' '\010' '\013' ] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" ['\\' '\"' '\'' 'n' 't' 'b' 'r' ' '] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" ['0'-'9'] ['0'-'9'] ['0'-'9'] "\'" - { store_lexeme lexbuf; comment lexbuf } - | "\'\\" 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] "\'" - { store_lexeme lexbuf; comment lexbuf } - | eof - { match !comment_start_loc with - | [] -> assert false - | loc :: _ -> - let start = List.hd (List.rev !comment_start_loc) in - comment_start_loc := []; - raise (Error (Unterminated_comment start, loc)) - } - | newline - { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - comment lexbuf - } - | _ - { store_lexeme lexbuf; comment lexbuf } - -and string = parse - '\"' - { () } - | '\\' newline ([' ' '\t'] * as space) - { update_loc lexbuf None 1 false (String.length space); - if in_comment () then store_lexeme lexbuf; - string lexbuf - } - | '\\' ['\\' '\'' '\"' 'n' 't' 'b' 'r' ' '] - { store_escaped_char lexbuf - (char_for_backslash(Lexing.lexeme_char lexbuf 1)); - string lexbuf } - | '\\' ['0'-'9'] ['0'-'9'] ['0'-'9'] - { store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); - string lexbuf } - | '\\' 'o' ['0'-'3'] ['0'-'7'] ['0'-'7'] - { store_escaped_char lexbuf (char_for_octal_code lexbuf 2); - string lexbuf } - | '\\' 'x' ['0'-'9' 'a'-'f' 'A'-'F'] ['0'-'9' 'a'-'f' 'A'-'F'] - { store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); - string lexbuf } - | '\\' 'u' '{' hex_digit+ '}' - { store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); - string lexbuf } - | '\\' _ - { if not (in_comment ()) then begin -(* Should be an error, but we are very lax. - raise (Error (Illegal_escape (Lexing.lexeme lexbuf), - Location.curr lexbuf)) -*) - let loc = Location.curr lexbuf in - Location.prerr_warning loc Warnings.Illegal_backslash; - end; - store_lexeme lexbuf; - string lexbuf - } - | newline - { if not (in_comment ()) then - Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; - update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - string lexbuf - } - | eof - { is_in_string := false; - raise (Error (Unterminated_string, !string_start_loc)) } - | _ - { store_string_char(Lexing.lexeme_char lexbuf 0); - string lexbuf } - -and quoted_string delim = parse - | newline - { update_loc lexbuf None 1 false 0; - store_lexeme lexbuf; - quoted_string delim lexbuf - } - | eof - { is_in_string := false; - raise (Error (Unterminated_string, !string_start_loc)) } - | "|" lowercase* "}" - { - let edelim = Lexing.lexeme lexbuf in - let edelim = String.sub edelim 1 (String.length edelim - 2) in - if delim = edelim then () - else (store_lexeme lexbuf; quoted_string delim lexbuf) - } - | _ - { store_string_char(Lexing.lexeme_char lexbuf 0); - quoted_string delim lexbuf } - -and skip_hash_bang = parse - | "#!" [^ '\n']* '\n' [^ '\n']* "\n!#\n" - { update_loc lexbuf None 3 false 0 } - | "#!" [^ '\n']* '\n' - { update_loc lexbuf None 1 false 0 } - | "" { () } - -{ - let token_with_comments lexbuf = - match !preprocessor with - | None -> token lexbuf - | Some (_init, preprocess) -> preprocess token lexbuf - - type newline_state = - | NoLine (* There have been no blank lines yet. *) - | NewLine - (* There have been no blank lines, and the previous - token was a newline. *) - | BlankLine (* There have been blank lines. *) - - type doc_state = - | Initial (* There have been no docstrings yet *) - | After of docstring list - (* There have been docstrings, none of which were - preceded by a blank line *) - | Before of docstring list * docstring list * docstring list - (* There have been docstrings, some of which were - preceded by a blank line *) - - and docstring = Docstrings.docstring - - let token lexbuf = - let post_pos = lexeme_end_p lexbuf in - let attach lines docs pre_pos = - let open Docstrings in - match docs, lines with - | Initial, _ -> () - | After a, (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_pre_docstrings pre_pos a; - | After a, BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_pre_extra_docstrings pre_pos (List.rev a) - | Before(a, f, b), (NoLine | NewLine) -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos (List.rev f); - set_pre_extra_docstrings pre_pos (List.rev a); - set_pre_docstrings pre_pos b - | Before(a, f, b), BlankLine -> - set_post_docstrings post_pos (List.rev a); - set_post_extra_docstrings post_pos - (List.rev_append f (List.rev b)); - set_floating_docstrings pre_pos - (List.rev_append f (List.rev b)); - set_pre_extra_docstrings pre_pos (List.rev a) - in - let rec loop lines docs lexbuf = - match token_with_comments lexbuf with - | COMMENT (s, loc) -> - add_comment (s, loc); - let lines' = - match lines with - | NoLine -> NoLine - | NewLine -> NoLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | EOL -> - let lines' = - match lines with - | NoLine -> NewLine - | NewLine -> BlankLine - | BlankLine -> BlankLine - in - loop lines' docs lexbuf - | HASH when Rescript_cpp.at_bol lexbuf -> - Rescript_cpp.interpret_directive lexbuf - ~cont:(fun lexbuf -> loop lines docs lexbuf) - ~token_with_comments - | DOCSTRING doc -> - Docstrings.register doc; - add_docstring_comment doc; - let docs' = - if Docstrings.docstring_body doc = "/*" then - match docs with - | Initial -> Before([], [doc], []) - | After a -> Before (a, [doc], []) - | Before(a, f, b) -> Before(a, doc :: b @ f, []) - else - match docs, lines with - | Initial, (NoLine | NewLine) -> After [doc] - | Initial, BlankLine -> Before([], [], [doc]) - | After a, (NoLine | NewLine) -> After (doc :: a) - | After a, BlankLine -> Before (a, [], [doc]) - | Before(a, f, b), (NoLine | NewLine) -> Before(a, f, doc :: b) - | Before(a, f, b), BlankLine -> Before(a, b @ f, [doc]) - in - loop NoLine docs' lexbuf - | tok -> - attach lines docs (lexeme_start_p lexbuf); - tok - in - Rescript_cpp.check_sharp_look_ahead (fun _ -> loop NoLine Initial lexbuf) - - let init () = - Rescript_cpp.init (); - is_in_string := false; - comment_start_loc := []; - comment_list := []; - match !preprocessor with - | None -> () - | Some (init, _preprocess) -> init () - - - let set_preprocessor init preprocess = - escaped_newlines := true; - preprocessor := Some (init, preprocess) - -} diff --git a/jscomp/ml/location.ml b/jscomp/ml/location.ml deleted file mode 100644 index 561a045..0000000 --- a/jscomp/ml/location.ml +++ /dev/null @@ -1,409 +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. *) -(* *) -(**************************************************************************) - -open Lexing - -let absname = ref false - (* This reference should be in Clflags, but it would create an additional - dependency and make bootstrapping Camlp4 more difficult. *) - -type t = Warnings.loc = { loc_start: position; loc_end: position; loc_ghost: bool };; - -let in_file name = - let loc = { - pos_fname = name; - pos_lnum = 1; - pos_bol = 0; - pos_cnum = -1; - } in - { loc_start = loc; loc_end = loc; loc_ghost = true } -;; - -let none = in_file "_none_";; - -let curr lexbuf = { - loc_start = lexbuf.lex_start_p; - loc_end = lexbuf.lex_curr_p; - loc_ghost = false -};; - -let init lexbuf fname = - lexbuf.lex_curr_p <- { - pos_fname = fname; - pos_lnum = 1; - pos_bol = 0; - pos_cnum = 0; - } -;; - -let symbol_rloc () = { - loc_start = Parsing.symbol_start_pos (); - loc_end = Parsing.symbol_end_pos (); - loc_ghost = false; -};; - -let symbol_gloc () = { - loc_start = Parsing.symbol_start_pos (); - loc_end = Parsing.symbol_end_pos (); - loc_ghost = true; -};; - -let rhs_loc n = { - loc_start = Parsing.rhs_start_pos n; - loc_end = Parsing.rhs_end_pos n; - loc_ghost = false; -};; - -let input_name = ref "_none_" -let input_lexbuf = ref (None : lexbuf option) -let set_input_name name = - if name <> "" then input_name := name -(* Terminal info *) - - - -let num_loc_lines = ref 0 (* number of lines already printed after input *) - -(* Print the location in some way or another *) - -open Format - -let absolute_path s = (* This function could go into Filename *) - let open Filename in - let s = if is_relative s then concat (Sys.getcwd ()) s else s in - (* Now simplify . and .. components *) - let rec aux s = - let base = basename s in - let dir = dirname s in - if dir = s then dir - else if base = current_dir_name then aux dir - else if base = parent_dir_name then dirname (aux dir) - else concat (aux dir) base - in - aux s - -let show_filename file = - let file = if file = "_none_" then !input_name else file in - if !absname then absolute_path file else file - -let print_filename ppf file = - Format.fprintf ppf "%s" (show_filename file) - -let reset () = - num_loc_lines := 0 - -(* return file, line, char from the given position *) -let get_pos_info pos = - (pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol) -;; - -let setup_colors () = - Misc.Color.setup !Clflags.color; - Code_frame.setup !Clflags.color - -(* ocaml's reported line/col numbering is horrible and super error-prone - when being handled programmatically (or humanly for that matter. If you're - an ocaml contributor reading this: who the heck reads the character count - starting from the first erroring character?) *) -let normalize_range loc = - (* TODO: lots of the handlings here aren't needed anymore because the new - rescript syntax has much stronger invariants regarding positions, e.g. - no -1 *) - let (_, start_line, start_char) = get_pos_info loc.loc_start in - let (_, end_line, end_char) = get_pos_info loc.loc_end in - (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) - (* start_char is inclusive, end_char is exclusive *) - if start_char == -1 || end_char == -1 then - (* happens sometimes. Syntax error for example *) - None - else if start_line = end_line && start_char >= end_char then - (* in some errors, starting char and ending char can be the same. But - since ending char was supposed to be exclusive, here it might end up - smaller than the starting char if we naively did start_char + 1 to - just the starting char and forget ending char *) - let same_char = start_char + 1 in - Some ((start_line, same_char), (end_line, same_char)) - else - (* again: end_char is exclusive, so +1-1=0 *) - Some ((start_line, start_char + 1), (end_line, end_char)) - -let print_loc ppf (loc : t) = - setup_colors (); - let normalized_range = normalize_range loc in - let dim_loc ppf = function - | None -> () - | Some ((start_line, start_line_start_char), (end_line, end_line_end_char)) -> - if start_line = end_line then - if start_line_start_char = end_line_end_char then - fprintf ppf ":@{%i:%i@}" start_line start_line_start_char - else - fprintf ppf ":@{%i:%i-%i@}" start_line start_line_start_char end_line_end_char - else - fprintf ppf ":@{%i:%i-%i:%i@}" start_line start_line_start_char end_line end_line_end_char - in - fprintf ppf "@{%a@}%a" print_filename loc.loc_start.pos_fname dim_loc normalized_range -;; - -let print ?(src = None) ~message_kind intro ppf (loc : t) = - begin match message_kind with - | `warning -> fprintf ppf "@[@{%s@}@]@," intro - | `warning_as_error -> fprintf ppf "@[@{%s@} (configured as error) @]@," intro - | `error -> fprintf ppf "@[@{%s@}@]@," intro - end; - (* ocaml's reported line/col numbering is horrible and super error-prone - when being handled programmatically (or humanly for that matter. If you're - an ocaml contributor reading this: who the heck reads the character count - starting from the first erroring character?) *) - let (file, start_line, start_char) = get_pos_info loc.loc_start in - let (_, end_line, end_char) = get_pos_info loc.loc_end in - (* line is 1-indexed, column is 0-indexed. We convert all of them to 1-indexed to avoid confusion *) - (* start_char is inclusive, end_char is exclusive *) - let normalizedRange = - (* TODO: lots of the handlings here aren't needed anymore because the new - rescript syntax has much stronger invariants regarding positions, e.g. - no -1 *) - if start_char == -1 || end_char == -1 then - (* happens sometimes. Syntax error for example *) - None - else if start_line = end_line && start_char >= end_char then - (* in some errors, starting char and ending char can be the same. But - since ending char was supposed to be exclusive, here it might end up - smaller than the starting char if we naively did start_char + 1 to - just the starting char and forget ending char *) - let same_char = start_char + 1 in - Some ((start_line, same_char), (end_line, same_char)) - else - (* again: end_char is exclusive, so +1-1=0 *) - Some ((start_line, start_char + 1), (end_line, end_char)) - in - fprintf ppf " @[%a@]@," print_loc loc; - match normalizedRange with - | None -> () - | Some _ -> begin - try - (* Print a syntax error that is a list of Res_diagnostics.t. - Instead of reading file for every error, it uses the source that the parser already has. *) - let src = match src with - | Some src -> src - | None -> Ext_io.load_file file - in - (* we're putting the line break `@,` here rather than above, because this - branch might not be reached (aka no inline file content display) so - we don't wanna end up with two line breaks in the the consequent *) - fprintf ppf "@,%s" - (Code_frame.print - ~is_warning:(message_kind=`warning) - ~src - ~startPos:loc.loc_start - ~endPos:loc.loc_end - ) - with - (* this might happen if the file is e.g. "", "_none_" or any of the fake file name placeholders. - we've already printed the location above, so nothing more to do here. *) - | Sys_error _ -> () - end -;; - -let error_prefix = "Error" - -let print_error_prefix ppf = - setup_colors (); - fprintf ppf "@{%s@}" error_prefix; -;; - -let print_compact ppf loc = - begin - let (file, line, startchar) = get_pos_info loc.loc_start in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in - fprintf ppf "%a:%i" print_filename file line; - if startchar >= 0 then fprintf ppf ",%i--%i" startchar endchar - end -;; - -let print_error intro ppf loc = - fprintf ppf "%a%t:" (print ~message_kind:`error intro) loc print_error_prefix; -;; - -let default_warning_printer loc ppf w = - match Warnings.report w with - | `Inactive -> () - | `Active { Warnings. number = _; message = _; is_error; sub_locs = _} -> - setup_colors (); - let message_kind = if is_error then `warning_as_error else `warning in - Format.fprintf ppf "@[@, %a@, %s@,@]@." - (print ~message_kind ("Warning number " ^ (Warnings.number w |> string_of_int))) - loc - (Warnings.message w); - (* at this point, you can display sub_locs too, from e.g. https://github.com/ocaml/ocaml/commit/f6d53cc38f87c67fbf49109f5fb79a0334bab17a - but we won't bother for now *) -;; - -let warning_printer = ref default_warning_printer ;; - -let print_warning loc ppf w = - !warning_printer loc ppf w -;; - -let formatter_for_warnings = ref err_formatter;; -let prerr_warning loc w = - print_warning loc !formatter_for_warnings w;; - -let echo_eof () = - print_newline (); - incr num_loc_lines - -type 'a loc = { - txt : 'a; - loc : t; -} - -let mkloc txt loc = { txt ; loc } -let mknoloc txt = mkloc txt none - - -type error = - { - loc: t; - msg: string; - sub: error list; - if_highlight: string; (* alternative message if locations are highlighted *) - } - -let pp_ksprintf ?before k fmt = - let buf = Buffer.create 64 in - let ppf = Format.formatter_of_buffer buf in - Misc.Color.set_color_tag_handling ppf; - begin match before with - | None -> () - | Some f -> f ppf - end; - kfprintf - (fun _ -> - pp_print_flush ppf (); - let msg = Buffer.contents buf in - k msg) - ppf fmt - -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L354 *) -(* Shift the formatter's offset by the length of the error prefix, which - is always added by the compiler after the message has been formatted *) -let print_phanton_error_prefix ppf = - (* modified from the original. We use only 2 indentations for error report - (see super_error_reporter above) *) - Format.pp_print_as ppf 2 "" - -let errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") fmt = - pp_ksprintf - ~before:print_phanton_error_prefix - (fun msg -> {loc; msg; sub; if_highlight}) - fmt - -let error ?(loc = none) ?(sub = []) ?(if_highlight = "") msg = - {loc; msg; sub; if_highlight} - -let error_of_exn : (exn -> error option) list ref = ref [] - -let register_error_of_exn f = error_of_exn := f :: !error_of_exn - -exception Already_displayed_error = Warnings.Errors - -let error_of_exn exn = - match exn with - | Already_displayed_error -> Some `Already_displayed - | _ -> - let rec loop = function - | [] -> None - | f :: rest -> - match f exn with - | Some error -> Some (`Ok error) - | None -> loop rest - in - loop !error_of_exn - -(* taken from https://github.com/rescript-lang/ocaml/blob/d4144647d1bf9bc7dc3aadc24c25a7efa3a67915/parsing/location.ml#L380 *) -(* This is the error report entry point. We'll replace the default reporter with this one. *) -let rec default_error_reporter ?(src = None) ppf ({loc; msg; sub}) = - setup_colors (); - (* open a vertical box. Everything in our message is indented 2 spaces *) - (* If src is given, it will display a syntax error after parsing. *) - let intro = match src with - | Some _ -> "Syntax error!" - | None -> "We've found a bug for you!" - in - Format.fprintf ppf "@[@, %a@, %s@,@]" (print ~src ~message_kind:`error intro) loc msg; - List.iter (Format.fprintf ppf "@,@[%a@]" (default_error_reporter ~src)) sub -(* no need to flush here; location's report_exception (which uses this ultimately) flushes *) - -let error_reporter = ref default_error_reporter - -let report_error ?(src = None) ppf err = - !error_reporter ~src ppf err -;; - -let error_of_printer loc print x = - errorf ~loc "%a@?" print x - -let error_of_printer_file print x = - error_of_printer (in_file !input_name) print x - -let () = - register_error_of_exn - (function - | Sys_error msg -> - Some (errorf ~loc:(in_file !input_name) - "I/O error: %s" msg) - - | Misc.HookExnWrapper {error = e; hook_name; - hook_info={Misc.sourcefile}} -> - let sub = match error_of_exn e with - | None | Some `Already_displayed -> error (Printexc.to_string e) - | Some (`Ok err) -> err - in - Some - (errorf ~loc:(in_file sourcefile) - "In hook %S:" hook_name - ~sub:[sub]) - | _ -> None - ) - -external reraise : exn -> 'a = "%reraise" - -let rec report_exception_rec n ppf exn = - try - match error_of_exn exn with - | None -> reraise exn - | Some `Already_displayed -> () - | Some (`Ok err) -> fprintf ppf "@[%a@]@." (report_error ~src:None) err - with exn when n > 0 -> report_exception_rec (n-1) ppf exn - -let report_exception ppf exn = report_exception_rec 5 ppf exn - - -exception Error of error - -let () = - register_error_of_exn - (function - | Error e -> Some e - | _ -> None - ) - -let raise_errorf ?(loc = none) ?(sub = []) ?(if_highlight = "") = - pp_ksprintf - ~before:print_phanton_error_prefix - (fun msg -> raise (Error ({loc; msg; sub; if_highlight}))) - -let deprecated ?(def = none) ?(use = none) loc msg = - prerr_warning loc (Warnings.Deprecated (msg, def, use)) diff --git a/jscomp/ml/location.mli b/jscomp/ml/location.mli deleted file mode 100644 index e0f91d4..0000000 --- a/jscomp/ml/location.mli +++ /dev/null @@ -1,145 +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. *) -(* *) -(**************************************************************************) - -(** Source code locations (ranges of positions), used in parsetree. *) - -open Format - -type t = Warnings.loc = { - loc_start: Lexing.position; - loc_end: Lexing.position; - loc_ghost: bool; -} - -(** Note on the use of Lexing.position in this module. - If [pos_fname = ""], then use [!input_name] instead. - If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and - re-parse the file to get the line and character numbers. - Else all fields are correct. -*) - -val none : t -(** An arbitrary value of type [t]; describes an empty ghost range. *) - -val in_file : string -> t -(** Return an empty ghost range located in a given file. *) - -val init : Lexing.lexbuf -> string -> unit -(** Set the file name and line number of the [lexbuf] to be the start - of the named file. *) - -val curr : Lexing.lexbuf -> t -(** Get the location of the current token from the [lexbuf]. *) - -val symbol_rloc: unit -> t -val symbol_gloc: unit -> t - -(** [rhs_loc n] returns the location of the symbol at position [n], starting - at 1, in the current parser rule. *) -val rhs_loc: int -> t - -val input_name: string ref -val set_input_name: string -> unit -val input_lexbuf: Lexing.lexbuf option ref - -val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) -val print_loc: formatter -> t -> unit -val print_error: tag -> formatter -> t -> unit - -val prerr_warning: t -> Warnings.t -> unit -val echo_eof: unit -> unit -val reset: unit -> unit - -val warning_printer : (t -> formatter -> Warnings.t -> unit) ref -(** Hook for intercepting warnings. *) - -val formatter_for_warnings : formatter ref - -val default_warning_printer : t -> formatter -> Warnings.t -> unit -(** Original warning printer for use in hooks. *) - -type 'a loc = { - txt : 'a; - loc : t; -} - -val mknoloc : 'a -> 'a loc -val mkloc : 'a -> t -> 'a loc - -val print: ?src:string option -> message_kind:[< `error | `warning | `warning_as_error > `warning] -> string -> formatter -> t -> unit -val print_compact: formatter -> t -> unit -val print_filename: formatter -> string -> unit - -val absolute_path: string -> string - -val show_filename: string -> string - (** In -absname mode, return the absolute path for this filename. - Otherwise, returns the filename unchanged. *) - - -val absname: bool ref - -(** Support for located errors *) - -type error = - { - loc: t; - msg: string; - sub: error list; - if_highlight: string; (* alternative message if locations are highlighted *) - } - -exception Already_displayed_error -exception Error of error - -val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error - - -val print_error_prefix : Format.formatter -> unit -val pp_ksprintf : ?before:(formatter -> unit) -> (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b - - -val errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string - -> ('a, Format.formatter, unit, error) format4 -> 'a - -val raise_errorf: ?loc:t -> ?sub:error list -> ?if_highlight:string - -> ('a, Format.formatter, unit, 'b) format4 -> 'a - -val error_of_printer: t -> (formatter -> 'a -> unit) -> 'a -> error - -val error_of_printer_file: (formatter -> 'a -> unit) -> 'a -> error - -val error_of_exn: exn -> [ `Ok of error | `Already_displayed ] option - -val register_error_of_exn: (exn -> error option) -> unit -(** Each compiler module which defines a custom type of exception - which can surface as a user-visible error should register - a "printer" for this exception using [register_error_of_exn]. - The result of the printer is an [error] value containing - a location, a message, and optionally sub-messages (each of them - being located as well). *) - -val report_error: ?src:string option -> formatter -> error -> unit - -val error_reporter : (?src:string option -> formatter -> error -> unit) ref -(** Hook for intercepting error reports. *) - -val default_error_reporter : ?src:string option -> formatter -> error -> unit -(** Original error reporter for use in hooks. *) - -val report_exception: formatter -> exn -> unit -(** Reraise the exception if it is unknown. *) - -val deprecated: ?def:t -> ?use:t -> t -> string -> unit diff --git a/jscomp/ml/longident.ml b/jscomp/ml/longident.ml deleted file mode 100644 index acae9a6..0000000 --- a/jscomp/ml/longident.ml +++ /dev/null @@ -1,63 +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. *) -(* *) -(**************************************************************************) - -type t = - Lident of string - | Ldot of t * string - | Lapply of t * t -let rec cmp : t -> t -> int = - fun a b -> - if a == b then 0 - else - match (a, b) with - | Lident a, Lident b -> compare a b - | Lident _, _ -> -1 - | _, Lident _ -> 1 - | Ldot (a, b), Ldot (c, d) -> ( - match cmp a c with 0 -> compare b d | n -> n) - | Ldot _, _ -> -1 - | _, Ldot _ -> 1 - | Lapply (a, b), Lapply (c, d) -> ( - match cmp a c with 0 -> cmp b d | n -> n) - -let rec flat accu = function - Lident s -> s :: accu - | Ldot(lid, s) -> flat (s :: accu) lid - | Lapply(_, _) -> Misc.fatal_error "Longident.flat" - -let flatten lid = flat [] lid - -let last = function - Lident s -> s - | Ldot(_, s) -> s - | Lapply(_, _) -> Misc.fatal_error "Longident.last" - -let rec split_at_dots s pos = - try - let dot = String.index_from s pos '.' in - String.sub s pos (dot - pos) :: split_at_dots s (dot + 1) - with Not_found -> - [String.sub s pos (String.length s - pos)] - -let unflatten l = - match l with - | [] -> None - | hd :: tl -> Some (List.fold_left (fun p s -> Ldot(p, s)) (Lident hd) tl) - -let parse s = - match unflatten (split_at_dots s 0) with - | None -> Lident "" (* should not happen, but don't put assert false - so as not to crash the toplevel (see Genprintval) *) - | Some v -> v diff --git a/jscomp/ml/matching.ml b/jscomp/ml/matching.ml deleted file mode 100644 index ff213fa..0000000 --- a/jscomp/ml/matching.ml +++ /dev/null @@ -1,3238 +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. *) -(* *) -(**************************************************************************) - -(* Compilation of pattern matching *) - -open Misc -open Asttypes -open Types -open Typedtree -open Lambda -open Parmatch -open Printf - - -let dbg = false - -(* See Peyton-Jones, ``The Implementation of functional programming - languages'', chapter 5. *) -(* - Well, it was true at the beginning of the world. - Now, see Lefessant-Maranget ``Optimizing Pattern-Matching'' ICFP'2001 -*) - -(* - Compatibility predicate that considers potential rebindings of constructors - of an extension type. - - "may_compat p q" returns false when p and q never admit a common instance; - returns true when they may have a common instance. -*) - -module MayCompat = - Parmatch.Compat (struct let equal = Types.may_equal_constr end) -let may_compat = MayCompat.compat -and may_compats = MayCompat.compats - -(* - Many functions on the various data structures of the algorithm : - - Pattern matrices. - - Default environments: mapping from matrices to exit numbers. - - Contexts: matrices whose column are partitioned into - left and right. - - Jump summaries: mapping from exit numbers to contexts -*) - - -let string_of_lam lam = - Printlambda.lambda Format.str_formatter lam ; - Format.flush_str_formatter () - -type matrix = pattern list list - -let add_omega_column pss = List.map (fun ps -> omega::ps) pss - -type ctx = {left:pattern list ; right:pattern list} - -let pretty_ctx ctx = - List.iter - (fun {left=left ; right=right} -> - prerr_string "LEFT:" ; - pretty_line left ; - prerr_string " RIGHT:" ; - pretty_line right ; - prerr_endline "") - ctx - -let le_ctx c1 c2 = - le_pats c1.left c2.left && - le_pats c1.right c2.right - -let lshift {left=left ; right=right} = match right with -| x::xs -> {left=x::left ; right=xs} -| _ -> assert false - -let lforget {left=left ; right=right} = match right with -| _::xs -> {left=omega::left ; right=xs} -| _ -> assert false - -let rec small_enough n = function - | [] -> true - | _::rem -> - if n <= 0 then false - else small_enough (n-1) rem - -let ctx_lshift ctx = - if small_enough 31 ctx then - List.map lshift ctx - else (* Context pruning *) begin - get_mins le_ctx (List.map lforget ctx) - end - -let rshift {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=p::right} -| _ -> assert false - -let ctx_rshift ctx = List.map rshift ctx - -let rec nchars n ps = - if n <= 0 then [],ps - else match ps with - | p::rem -> - let chars, cdrs = nchars (n-1) rem in - p::chars,cdrs - | _ -> assert false - -let rshift_num n {left=left ; right=right} = - let shifted,left = nchars n left in - {left=left ; right = shifted@right} - -let ctx_rshift_num n ctx = List.map (rshift_num n) ctx - -(* Recombination of contexts (eg: (_,_)::p1::p2::rem -> (p1,p2)::rem) - All mutable fields are replaced by '_', since side-effects in - guards can alter these fields *) - -let combine {left=left ; right=right} = match left with -| p::ps -> {left=ps ; right=set_args_erase_mutable p right} -| _ -> assert false - -let ctx_combine ctx = List.map combine ctx - -let ncols = function - | [] -> 0 - | ps::_ -> List.length ps - - -exception NoMatch -exception OrPat - -let filter_matrix matcher pss = - - let rec filter_rec = function - | (p::ps)::rem -> - begin match p.pat_desc with - | Tpat_alias (p,_,_) -> - filter_rec ((p::ps)::rem) - | Tpat_var _ -> - filter_rec ((omega::ps)::rem) - | _ -> - begin - let rem = filter_rec rem in - try - matcher p ps::rem - with - | NoMatch -> rem - | OrPat -> - match p.pat_desc with - | Tpat_or (p1,p2,_) -> filter_rec [(p1::ps) ;(p2::ps)]@rem - | _ -> assert false - end - end - | [] -> [] - | _ -> - pretty_matrix pss ; - fatal_error "Matching.filter_matrix" in - filter_rec pss - -let make_default matcher env = - let rec make_rec = function - | [] -> [] - | ([[]],i)::_ -> [[[]],i] - | (pss,i)::rem -> - let rem = make_rec rem in - match filter_matrix matcher pss with - | [] -> rem - | ([]::_) -> ([[]],i)::rem - | pss -> (pss,i)::rem in - make_rec env - -let ctx_matcher p = - let p = normalize_pat p in - match p.pat_desc with - | Tpat_construct (_, cstr,omegas) -> - (fun q rem -> match q.pat_desc with - | Tpat_construct (_, cstr',args) -(* NB: may_constr_equal considers (potential) constructor rebinding *) - when Types.may_equal_constr cstr cstr' -> - p,args@rem - | Tpat_any -> p,omegas @ rem - | _ -> raise NoMatch) - | Tpat_constant cst -> - (fun q rem -> match q.pat_desc with - | Tpat_constant cst' when const_compare cst cst' = 0 -> - p,rem - | Tpat_any -> p,rem - | _ -> raise NoMatch) - | Tpat_variant (lab,Some omega,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',Some arg,_) when lab=lab' -> - p,arg::rem - | Tpat_any -> p,omega::rem - | _ -> raise NoMatch) - | Tpat_variant (lab,None,_) -> - (fun q rem -> match q.pat_desc with - | Tpat_variant (lab',None,_) when lab=lab' -> - p,rem - | Tpat_any -> p,rem - | _ -> raise NoMatch) - | Tpat_array omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_array args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem - | _ -> raise NoMatch) - | Tpat_tuple omegas -> - let len = List.length omegas in - (fun q rem -> match q.pat_desc with - | Tpat_tuple args when List.length args = len -> p,args @ rem - | Tpat_any -> p, omegas @ rem - | _ -> raise NoMatch) - | Tpat_record (((_, lbl, _) :: _) as l,_) -> (* Records are normalized *) - let len = Array.length lbl.lbl_all in - (fun q rem -> match q.pat_desc with - | Tpat_record (((_, lbl', _) :: _) as l',_) - when Array.length lbl'.lbl_all = len -> - let l' = all_record_args l' in - p, List.fold_right (fun (_, _,p) r -> p::r) l' rem - | Tpat_any -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem - | _ -> raise NoMatch) - | Tpat_lazy omega -> - (fun q rem -> match q.pat_desc with - | Tpat_lazy arg -> p, (arg::rem) - | Tpat_any -> p, (omega::rem) - | _ -> raise NoMatch) - | _ -> fatal_error "Matching.ctx_matcher" - - - - -let filter_ctx q ctx = - - let matcher = ctx_matcher q in - - let rec filter_rec = function - | ({right=p::ps} as l)::rem -> - begin match p.pat_desc with - | Tpat_or (p1,p2,_) -> - filter_rec ({l with right=p1::ps}::{l with right=p2::ps}::rem) - | Tpat_alias (p,_,_) -> - filter_rec ({l with right=p::ps}::rem) - | Tpat_var _ -> - filter_rec ({l with right=omega::ps}::rem) - | _ -> - begin let rem = filter_rec rem in - try - let to_left, right = matcher p ps in - {left=to_left::l.left ; right=right}::rem - with - | NoMatch -> rem - end - end - | [] -> [] - | _ -> fatal_error "Matching.filter_ctx" in - - filter_rec ctx - -let select_columns pss ctx = - let n = ncols pss in - List.fold_right - (fun ps r -> - List.fold_right - (fun {left=left ; right=right} r -> - let transfert, right = nchars n right in - try - {left = lubs transfert ps @ left ; right=right}::r - with - | Empty -> r) - ctx r) - pss [] - -let ctx_lub p ctx = - List.fold_right - (fun {left=left ; right=right} r -> - match right with - | q::rem -> - begin try - {left=left ; right = lub p q::rem}::r - with - | Empty -> r - end - | _ -> fatal_error "Matching.ctx_lub") - ctx [] - -let ctx_match ctx pss = - List.exists - (fun {right=qs} -> List.exists (fun ps -> may_compats qs ps) pss) - ctx - -type jumps = (int * ctx list) list - -let pretty_jumps (env : jumps) = match env with -| [] -> () -| _ -> - List.iter - (fun (i,ctx) -> - Printf.fprintf stderr "jump for %d\n" i ; - pretty_ctx ctx) - env - - -let rec jumps_extract (i : int) = function - | [] -> [],[] - | (j,pss) as x::rem as all -> - if i=j then pss,rem - else if j < i then [],all - else - let r,rem = jumps_extract i rem in - r,(x::rem) - -let rec jumps_remove (i:int) = function - | [] -> [] - | (j,_)::rem when i=j -> rem - | x::rem -> x::jumps_remove i rem - -let jumps_empty = [] -and jumps_is_empty = function - | [] -> true - | _ -> false - -let jumps_singleton i = function - | [] -> [] - | ctx -> [i,ctx] - -let jumps_add i pss jumps = match pss with -| [] -> jumps -| _ -> - let rec add = function - | [] -> [i,pss] - | (j,qss) as x::rem as all -> - if (j:int) > i then x::add rem - else if j < i then (i,pss)::all - else (i,(get_mins le_ctx (pss@qss)))::rem in - add jumps - - -let rec jumps_union (env1:(int*ctx list)list) env2 = match env1,env2 with -| [],_ -> env2 -| _,[] -> env1 -| ((i1,pss1) as x1::rem1), ((i2,pss2) as x2::rem2) -> - if i1=i2 then - (i1,get_mins le_ctx (pss1@pss2))::jumps_union rem1 rem2 - else if i1 > i2 then - x1::jumps_union rem1 env2 - else - x2::jumps_union env1 rem2 - - -let rec merge = function - | env1::env2::rem -> jumps_union env1 env2::merge rem - | envs -> envs - -let rec jumps_unions envs = match envs with - | [] -> [] - | [env] -> env - | _ -> jumps_unions (merge envs) - -let jumps_map f env = - List.map - (fun (i,pss) -> i,f pss) - env - -(* Pattern matching before any compilation *) - -type pattern_matching = - { mutable cases : (pattern list * lambda) list; - args : (lambda * let_kind) list ; - default : (matrix * int) list} - -(* Pattern matching after application of both the or-pat rule and the - mixture rule *) - -type pm_or_compiled = - {body : pattern_matching ; - handlers : (matrix * int * Ident.t list * pattern_matching) list ; - or_matrix : matrix ; } - -type pm_half_compiled = - | PmOr of pm_or_compiled - | PmVar of pm_var_compiled - | Pm of pattern_matching - -and pm_var_compiled = - {inside : pm_half_compiled ; var_arg : lambda ; } - -type pm_half_compiled_info = - {me : pm_half_compiled ; - matrix : matrix ; - top_default : (matrix * int) list ; } - -let pretty_cases cases = - List.iter - (fun (ps,_l) -> - List.iter - (fun p -> - Parmatch.top_pretty Format.str_formatter p ; - prerr_string " " ; - prerr_string (Format.flush_str_formatter ())) - ps ; -(* - prerr_string " -> " ; - Printlambda.lambda Format.str_formatter l ; - prerr_string (Format.flush_str_formatter ()) ; -*) - prerr_endline "") - cases - -let pretty_def def = - prerr_endline "+++++ Defaults +++++" ; - List.iter - (fun (pss,i) -> - Printf.fprintf stderr "Matrix for %d\n" i ; - pretty_matrix pss) - def ; - prerr_endline "+++++++++++++++++++++" - -let pretty_pm pm = - pretty_cases pm.cases ; - if pm.default <> [] then - pretty_def pm.default - - -let rec pretty_precompiled = function - | Pm pm -> - prerr_endline "++++ PM ++++" ; - pretty_pm pm - | PmVar x -> - prerr_endline "++++ VAR ++++" ; - pretty_precompiled x.inside - | PmOr x -> - prerr_endline "++++ OR ++++" ; - pretty_pm x.body ; - pretty_matrix x.or_matrix ; - List.iter - (fun (_,i,_,pm) -> - eprintf "++ Handler %d ++\n" i ; - pretty_pm pm) - x.handlers - -let pretty_precompiled_res first nexts = - pretty_precompiled first ; - List.iter - (fun (e, pmh) -> - eprintf "** DEFAULT %d **\n" e ; - pretty_precompiled pmh) - nexts - - - -(* Identifying some semantically equivalent lambda-expressions, - Our goal here is also to - find alpha-equivalent (simple) terms *) - -(* However, as shown by PR#6359 such sharing may hinders the - lambda-code invariant that all bound idents are unique, - when switches are compiled to test sequences. - The definitive fix is the systematic introduction of exit/catch - in case action sharing is present. -*) - - -module StoreExp = - Switch.Store - (struct - type t = lambda - type key = lambda - let compare_key = compare - let make_key = Lambda.make_key - end) - - -let make_exit i = Lstaticraise (i,[]) - -(* Introduce a catch, if worth it *) -let make_catch d k = match d with -| Lstaticraise (_,[]) -> k d -| _ -> - let e = next_raise_count () in - Lstaticcatch (k (make_exit e),(e,[]),d) - -(* Introduce a catch, if worth it, delayed version *) -let rec as_simple_exit = function - | Lstaticraise (i,[]) -> Some i - | Llet (Alias,_k,_,_,e) -> as_simple_exit e - | _ -> None - - -let make_catch_delayed handler = match as_simple_exit handler with -| Some i -> i,(fun act -> act) -| None -> - let i = next_raise_count () in -(* - Printf.eprintf "SHARE LAMBDA: %i\n%s\n" i (string_of_lam handler); -*) - i, - (fun body -> match body with - | Lstaticraise (j,_) -> - if i=j then handler else body - | _ -> Lstaticcatch (body,(i,[]),handler)) - - -let raw_action l = - match make_key l with | Some l -> l | None -> l - - -let tr_raw act = match make_key act with -| Some act -> act -| None -> raise Exit - -let same_actions = function - | [] -> None - | [_,act] -> Some act - | (_,act0) :: rem -> - try - let raw_act0 = tr_raw act0 in - let rec s_rec = function - | [] -> Some act0 - | (_,act)::rem -> - if raw_act0 = tr_raw act then - s_rec rem - else - None in - s_rec rem - with - | Exit -> None - - -(* Test for swapping two clauses *) - -let up_ok_action act1 act2 = - try - let raw1 = tr_raw act1 - and raw2 = tr_raw act2 in - raw1 = raw2 - with - | Exit -> false - -let up_ok (ps,act_p) l = - List.for_all - (fun (qs,act_q) -> - up_ok_action act_p act_q || not (may_compats ps qs)) - l - -(* - The simplify function normalizes the first column of the match - - records are expanded so that they possess all fields - - aliases are removed and replaced by bindings in actions. - However or-patterns are simplified differently, - - aliases are not removed - - or-patterns (_|p) are changed into _ -*) - -exception Var of pattern - -let simplify_or p = - let rec simpl_rec p = match p with - | {pat_desc = Tpat_any|Tpat_var _} -> raise (Var p) - | {pat_desc = Tpat_alias (q,id,s)} -> - begin try - {p with pat_desc = Tpat_alias (simpl_rec q,id,s)} - with - | Var q -> raise (Var {p with pat_desc = Tpat_alias (q,id,s)}) - end - | {pat_desc = Tpat_or (p1,p2,o)} -> - let q1 = simpl_rec p1 in - begin try - let q2 = simpl_rec p2 in - {p with pat_desc = Tpat_or (q1, q2, o)} - with - | Var q2 -> raise (Var {p with pat_desc = Tpat_or (q1, q2, o)}) - end - | {pat_desc = Tpat_record (lbls,closed)} -> - let all_lbls = all_record_args lbls in - {p with pat_desc=Tpat_record (all_lbls, closed)} - | _ -> p in - try - simpl_rec p - with - | Var p -> p - -let simplify_cases args cls = match args with -| [] -> assert false -| (arg,_)::_ -> - let rec simplify = function - | [] -> [] - | ((pat :: patl, action) as cl) :: rem -> - begin match pat.pat_desc with - | Tpat_var (id, _) -> - (omega :: patl, bind Alias id arg action) :: - simplify rem - | Tpat_any -> - cl :: simplify rem - | Tpat_alias(p, id,_) -> - simplify ((p :: patl, bind Alias id arg action) :: rem) - | Tpat_record ([],_) -> - (omega :: patl, action):: - simplify rem - | Tpat_record (lbls, closed) -> - let all_lbls = all_record_args lbls in - let full_pat = - {pat with pat_desc=Tpat_record (all_lbls, closed)} in - (full_pat::patl,action):: - simplify rem - | Tpat_or _ -> - let pat_simple = simplify_or pat in - begin match pat_simple.pat_desc with - | Tpat_or _ -> - (pat_simple :: patl, action) :: - simplify rem - | _ -> - simplify ((pat_simple::patl,action) :: rem) - end - | _ -> cl :: simplify rem - end - | _ -> assert false in - - simplify cls - - - -(* Once matchings are simplified one can easily find - their nature *) - -let rec what_is_cases cases = match cases with -| ({pat_desc=Tpat_any} :: _, _) :: rem -> what_is_cases rem -| (({pat_desc=(Tpat_var _|Tpat_or (_,_,_)|Tpat_alias (_,_,_))}::_),_)::_ - -> assert false (* applies to simplified matchings only *) -| (p::_,_)::_ -> p -| [] -> omega -| _ -> assert false - - - -(* A few operations on default environments *) -let as_matrix cases = get_mins le_pats (List.map (fun (ps,_) -> ps) cases) - -let cons_default matrix raise_num default = - match matrix with - | [] -> default - | _ -> (matrix,raise_num)::default - -let default_compat p def = - List.fold_right - (fun (pss,i) r -> - let qss = - List.fold_right - (fun qs r -> match qs with - | q::rem when may_compat p q -> rem::r - | _ -> r) - pss [] in - match qss with - | [] -> r - | _ -> (qss,i)::r) - def [] - -(* Or-pattern expansion, variables are a complication w.r.t. the article *) -let rec extract_vars r p = match p.pat_desc with -| Tpat_var (id, _) -> IdentSet.add id r -| Tpat_alias (p, id,_ ) -> - extract_vars (IdentSet.add id r) p -| Tpat_tuple pats -> - List.fold_left extract_vars r pats -| Tpat_record (lpats,_) -> - List.fold_left - (fun r (_, _, p) -> extract_vars r p) - r lpats -| Tpat_construct (_, _, pats) -> - List.fold_left extract_vars r pats -| Tpat_array pats -> - List.fold_left extract_vars r pats -| Tpat_variant (_,Some p, _) -> extract_vars r p -| Tpat_lazy p -> extract_vars r p -| Tpat_or (p,_,_) -> extract_vars r p -| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r - -exception Cannot_flatten - -let mk_alpha_env arg aliases ids = - List.map - (fun id -> id, - if List.mem id aliases then - match arg with - | Some v -> v - | _ -> raise Cannot_flatten - else - Ident.create (Ident.name id)) - ids - -let rec explode_or_pat arg patl mk_action rem vars aliases = function - | {pat_desc = Tpat_or (p1,p2,_)} -> - explode_or_pat - arg patl mk_action - (explode_or_pat arg patl mk_action rem vars aliases p2) - vars aliases p1 - | {pat_desc = Tpat_alias (p,id, _)} -> - explode_or_pat arg patl mk_action rem vars (id::aliases) p - | {pat_desc = Tpat_var (x, _)} -> - let env = mk_alpha_env arg (x::aliases) vars in - (omega::patl,mk_action (List.map snd env))::rem - | p -> - let env = mk_alpha_env arg aliases vars in - (alpha_pat env p::patl,mk_action (List.map snd env))::rem - -let pm_free_variables {cases=cases} = - List.fold_right - (fun (_,act) r -> IdentSet.union (free_variables act) r) - cases IdentSet.empty - - -(* Basic grouping predicates *) -let pat_as_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr - | _ -> fatal_error "Matching.pat_as_constr" - -let group_constant = function - | {pat_desc= Tpat_constant _} -> true - | _ -> false - -and group_constructor = function - | {pat_desc = Tpat_construct (_,_,_)} -> true - | _ -> false - -and group_variant = function - | {pat_desc = Tpat_variant (_, _, _)} -> true - | _ -> false - -and group_var = function - | {pat_desc=Tpat_any} -> true - | _ -> false - -and group_tuple = function - | {pat_desc = (Tpat_tuple _|Tpat_any)} -> true - | _ -> false - -and group_record = function - | {pat_desc = (Tpat_record _|Tpat_any)} -> true - | _ -> false - -and group_array = function - | {pat_desc=Tpat_array _} -> true - | _ -> false - -and group_lazy = function - | {pat_desc = Tpat_lazy _} -> true - | _ -> false - -let get_group p = match p.pat_desc with -| Tpat_any -> group_var -| Tpat_constant _ -> group_constant -| Tpat_construct _ -> group_constructor -| Tpat_tuple _ -> group_tuple -| Tpat_record _ -> group_record -| Tpat_array _ -> group_array -| Tpat_variant (_,_,_) -> group_variant -| Tpat_lazy _ -> group_lazy -| _ -> fatal_error "Matching.get_group" - - - -let is_or p = match p.pat_desc with -| Tpat_or _ -> true -| _ -> false - -(* Conditions for appending to the Or matrix *) -let conda p q = not (may_compat p q) -and condb act ps qs = not (is_guarded act) && Parmatch.le_pats qs ps - -let or_ok p ps l = - List.for_all - (function - | ({pat_desc=Tpat_or _} as q::qs,act) -> - conda p q || condb act ps qs - | _ -> true) - l - -(* Insert or append a pattern in the Or matrix *) - -let equiv_pat p q = le_pat p q && le_pat q p - -let rec get_equiv p l = match l with - | (q::_,_) as cl::rem -> - if equiv_pat p q then - let others,rem = get_equiv p rem in - cl::others,rem - else - [],l - | _ -> [],l - - -let insert_or_append p ps act ors no = - let rec attempt seen = function - | (q::qs,act_q) as cl::rem -> - if is_or q then begin - if may_compat p q then - if - IdentSet.is_empty (extract_vars IdentSet.empty p) && - IdentSet.is_empty (extract_vars IdentSet.empty q) && - equiv_pat p q - then (* attempt insert, for equivalent orpats with no variables *) - let _, not_e = get_equiv q rem in - if - or_ok p ps not_e && (* check append condition for head of O *) - List.for_all (* check insert condition for tail of O *) - (fun cl -> match cl with - | (q::_,_) -> not (may_compat p q) - | _ -> assert false) - seen - then (* insert *) - List.rev_append seen ((p::ps,act)::cl::rem), no - else (* fail to insert or append *) - ors,(p::ps,act)::no - else if condb act_q ps qs then (* check condition (b) for append *) - attempt (cl::seen) rem - else - ors,(p::ps,act)::no - else (* p # q, go on with append/insert *) - attempt (cl::seen) rem - end else (* q is not an or-pat, go on with append/insert *) - attempt (cl::seen) rem - | _ -> (* [] in fact *) - (p::ps,act)::ors,no in (* success in appending *) - attempt [] ors - -(* Reconstruct default information from half_compiled pm list *) - -let rec rebuild_matrix pmh = match pmh with - | Pm pm -> as_matrix pm.cases - | PmOr {or_matrix=m} -> m - | PmVar x -> add_omega_column (rebuild_matrix x.inside) - -let rec rebuild_default nexts def = match nexts with -| [] -> def -| (e, pmh)::rem -> - (add_omega_column (rebuild_matrix pmh), e):: - rebuild_default rem def - -let rebuild_nexts arg nexts k = - List.fold_right - (fun (e, pm) k -> (e, PmVar {inside=pm ; var_arg=arg})::k) - nexts k - - -(* - Split a matching. - Splitting is first directed by or-patterns, then by - tests (e.g. constructors)/variable transitions. - - The approach is greedy, every split function attempts to - raise rows as much as possible in the top matrix, - then splitting applies again to the remaining rows. - - Some precompilation of or-patterns and - variable pattern occurs. Mostly this means that bindings - are performed now, being replaced by let-bindings - in actions (cf. simplify_cases). - - Additionally, if the match argument is a variable, matchings whose - first column is made of variables only are splitted further - (cf. precompile_var). - -*) - - -let rec split_or argo cls args def = - - let cls = simplify_cases args cls in - - let rec do_split before ors no = function - | [] -> - cons_next - (List.rev before) (List.rev ors) (List.rev no) - | ((p::ps,act) as cl)::rem -> - if up_ok cl no then - if is_or p then - let ors, no = insert_or_append p ps act ors no in - do_split before ors no rem - else begin - if up_ok cl ors then - do_split (cl::before) ors no rem - else if or_ok p ps ors then - do_split before (cl::ors) no rem - else - do_split before ors (cl::no) rem - end - else - do_split before ors (cl::no) rem - | _ -> assert false - - and cons_next yes yesor = function - | [] -> - precompile_or argo yes yesor args def [] - | rem -> - let {me=next ; matrix=matrix ; top_default=def},nexts = - do_split [] [] [] rem in - let idef = next_raise_count () in - precompile_or - argo yes yesor args - (cons_default matrix idef def) - ((idef,next)::nexts) in - - do_split [] [] [] cls - -(* Ultra-naive splitting, close to semantics, used for extension, - as potential rebind prevents any kind of optimisation *) - -and split_naive cls args def k = - - let rec split_exc cstr0 yes = function - | [] -> - let yes = List.rev yes in - { me = Pm {cases=yes; args=args; default=def;} ; - matrix = as_matrix yes ; - top_default=def}, - k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let cstr = pat_as_constr p in - if cstr = cstr0 then split_exc cstr0 (cl::yes) rem - else - let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_exc cstr [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts - else - let yes = List.rev yes in - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noexc [cl] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - { me = Pm {cases=yes; args=args; default=def} ; - matrix = as_matrix yes ; - top_default = def; }, - (idef,next)::nexts - | _ -> assert false - - and split_noexc yes = function - | [] -> precompile_var args (List.rev yes) def k - | (p::_,_ as cl)::rem -> - if group_constructor p then - let yes= List.rev yes in - let {me=next; matrix=matrix; top_default=def;},nexts = - split_exc (pat_as_constr p) [cl] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - else split_noexc (cl::yes) rem - | _ -> assert false in - - match cls with - | [] -> assert false - | (p::_,_ as cl)::rem -> - if group_constructor p then - split_exc (pat_as_constr p) [cl] rem - else - split_noexc [cl] rem - | _ -> assert false - -and split_constr cls args def k = - let ex_pat = what_is_cases cls in - match ex_pat.pat_desc with - | Tpat_any -> precompile_var args cls def k - | Tpat_construct (_,{cstr_tag=Cstr_extension _},_) -> - split_naive cls args def k - | _ -> - - let group = get_group ex_pat in - - let rec split_ex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def}, - k - | cl::rem -> - begin match yes with - | [] -> - (* Could not success in raising up a constr matching up *) - split_noex [cl] [] rem - | _ -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_noex [cl] [] rem in - let idef = next_raise_count () in - let def = cons_default matrix idef def in - {me = Pm {cases=yes ; args=args ; default=def} ; - matrix = as_matrix yes ; - top_default = def }, - (idef, next)::nexts - end - end - | (p::_,_) as cl::rem -> - if group p && up_ok cl no then - split_ex (cl::yes) no rem - else - split_ex yes (cl::no) rem - | _ -> assert false - - and split_noex yes no = function - | [] -> - let yes = List.rev yes and no = List.rev no in - begin match no with - | [] -> precompile_var args yes def k - | cl::rem -> - let {me=next ; matrix=matrix ; top_default=def}, nexts = - split_ex [cl] [] rem in - let idef = next_raise_count () in - precompile_var - args yes - (cons_default matrix idef def) - ((idef,next)::nexts) - end - | [ps,_ as cl] - when List.for_all group_var ps && yes <> [] -> - (* This enables an extra division in some frequent cases : - last row is made of variables only *) - split_noex yes (cl::no) [] - | (p::_,_) as cl::rem -> - if not (group p) && up_ok cl no then - split_noex (cl::yes) no rem - else - split_noex yes (cl::no) rem - | _ -> assert false in - - match cls with - | ((p::_,_) as cl)::rem -> - if group p then split_ex [cl] [] rem - else split_noex [cl] [] rem - | _ -> assert false - -and precompile_var args cls def k = match args with -| [] -> assert false -| _::((Lvar v as av,_) as arg)::rargs -> - begin match cls with - | [_] -> (* as splitted as it can *) - dont_precompile_var args cls def k - | _ -> -(* Precompile *) - let var_cls = - List.map - (fun (ps,act) -> match ps with - | _::ps -> ps,act | _ -> assert false) - cls - and var_def = make_default (fun _ rem -> rem) def in - let {me=first ; matrix=matrix}, nexts = - split_or (Some v) var_cls (arg::rargs) var_def in - -(* Compute top information *) - match nexts with - | [] -> (* If you need *) - dont_precompile_var args cls def k - | _ -> - let rfirst = - {me = PmVar {inside=first ; var_arg = av} ; - matrix = add_omega_column matrix ; - top_default = rebuild_default nexts def ; } - and rnexts = rebuild_nexts av nexts k in - rfirst, rnexts - end -| _ -> - dont_precompile_var args cls def k - -and dont_precompile_var args cls def k = - {me = Pm {cases = cls ; args = args ; default = def } ; - matrix=as_matrix cls ; - top_default=def},k - -and precompile_or argo cls ors args def k = match ors with -| [] -> split_constr cls args def k -| _ -> - let rec do_cases = function - | ({pat_desc=Tpat_or _} as orp::patl, action)::rem -> - let others,rem = get_equiv orp rem in - let orpm = - {cases = - (patl, action):: - List.map - (function - | (_::ps,action) -> ps,action - | _ -> assert false) - others ; - args = (match args with _::r -> r | _ -> assert false) ; - default = default_compat orp def} in - let vars = - IdentSet.elements - (IdentSet.inter - (extract_vars IdentSet.empty orp) - (pm_free_variables orpm)) in - let or_num = next_raise_count () in - let new_patl = Parmatch.omega_list patl in - - let mk_new_action vs = - Lstaticraise - (or_num, List.map (fun v -> Lvar v) vs) in - - let body,handlers = do_cases rem in - explode_or_pat - argo new_patl mk_new_action body vars [] orp, - let mat = [[orp]] in - ((mat, or_num, vars , orpm):: handlers) - | cl::rem -> - let new_ord,new_to_catch = do_cases rem in - cl::new_ord,new_to_catch - | [] -> [],[] in - - let end_body, handlers = do_cases ors in - let matrix = as_matrix (cls@ors) - and body = {cases=cls@end_body ; args=args ; default=def} in - {me = PmOr {body=body ; handlers=handlers ; or_matrix=matrix} ; - matrix=matrix ; - top_default=def}, - k - -let split_precompile argo pm = - let {me=next}, nexts = split_or argo pm.cases pm.args pm.default in - if dbg && (nexts <> [] || (match next with PmOr _ -> true | _ -> false)) - then begin - prerr_endline "** SPLIT **" ; - pretty_pm pm ; - pretty_precompiled_res next nexts - end ; - next, nexts - - -(* General divide functions *) - -let add_line patl_action pm = pm.cases <- patl_action :: pm.cases; pm - -type cell = - {pm : pattern_matching ; - ctx : ctx list ; - pat : pattern} - -let add make_matching_fun division eq_key key patl_action args = - try - let (_,cell) = List.find (fun (k,_) -> eq_key key k) division in - cell.pm.cases <- patl_action :: cell.pm.cases; - division - with Not_found -> - let cell = make_matching_fun args in - cell.pm.cases <- [patl_action] ; - (key, cell) :: division - - -let divide make eq_key get_key get_args ctx pm = - - let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add - (make p pm.default ctx) - this_match eq_key (get_key p) (get_args p patl,action) pm.args - | _ -> [] in - - divide_rec pm.cases - - -let divide_line make_ctx make get_args pat ctx pm = - let rec divide_rec = function - | (p::patl,action) :: rem -> - let this_match = divide_rec rem in - add_line (get_args p patl, action) this_match - | _ -> make pm.default pm.args in - - {pm = divide_rec pm.cases ; - ctx=make_ctx ctx ; - pat=pat} - - - -(* Then come various functions, - There is one set of functions per matching style - (constants, constructors etc.) - - - matcher functions are arguments to make_default (for default handlers) - They may raise NoMatch or OrPat and perform the full - matching (selection + arguments). - - - - get_args and get_key are for the compiled matrices, note that - selection and getting arguments are separated. - - - make_ _matching combines the previous functions for producing - new ``pattern_matching'' records. -*) - - - -let rec matcher_const cst p rem = match p.pat_desc with -| Tpat_or (p1,p2,_) -> - begin try - matcher_const cst p1 rem with - | NoMatch -> matcher_const cst p2 rem - end -| Tpat_constant c1 when const_compare c1 cst = 0 -> rem -| Tpat_any -> rem -| _ -> raise NoMatch - -let get_key_constant caller = function - | {pat_desc= Tpat_constant cst} -> cst - | p -> - prerr_endline ("BAD: "^caller) ; - pretty_pat p ; - assert false - -let get_args_constant _ rem = rem - -let make_constant_matching p def ctx = function - [] -> fatal_error "Matching.make_constant_matching" - | (_ :: argl) -> - let def = - make_default - (matcher_const (get_key_constant "make" p)) def - and ctx = - filter_ctx p ctx in - {pm = {cases = []; args = argl ; default = def} ; - ctx = ctx ; - pat = normalize_pat p} - - - - -let divide_constant ctx m = - divide - make_constant_matching - (fun c d -> const_compare c d = 0) (get_key_constant "divide") - get_args_constant - ctx m - -(* Matching against a constructor *) - - -let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = - let rec make_args pos = - if pos > last_pos - then argl - else (Lprim(Pfield (pos, fld_info), [arg], loc), binding_kind) :: make_args (pos + 1) - in make_args first_pos - -let get_key_constr = function - | {pat_desc=Tpat_construct (_, cstr,_)} -> cstr.cstr_tag - | _ -> assert false - -let get_args_constr p rem = match p with -| {pat_desc=Tpat_construct (_, _, args)} -> args @ rem -| _ -> assert false - -(* NB: matcher_constr applies to default matrices. - - In that context, matching by constructors of extensible - types degrades to arity checking, due to potential rebinding. - This comparison is performed by Types.may_equal_constr. -*) - -let matcher_constr cstr = match cstr.cstr_arity with -| 0 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> - begin - try matcher_rec p1 rem - with NoMatch -> matcher_rec p2 rem - end - | Tpat_construct (_, cstr',[]) - when Types.may_equal_constr cstr cstr' -> rem - | Tpat_any -> rem - | _ -> raise NoMatch in - matcher_rec -| 1 -> - let rec matcher_rec q rem = match q.pat_desc with - | Tpat_or (p1,p2,_) -> - let r1 = try Some (matcher_rec p1 rem) with NoMatch -> None - and r2 = try Some (matcher_rec p2 rem) with NoMatch -> None in - begin match r1,r2 with - | None, None -> raise NoMatch - | Some r1, None -> r1 - | None, Some r2 -> r2 - | Some (a1::_), Some (a2::_) -> - {a1 with - pat_loc = Location.none ; - pat_desc = Tpat_or (a1, a2, None)}:: - rem - | _, _ -> assert false - end - | Tpat_construct (_, cstr', [arg]) - when Types.may_equal_constr cstr cstr' -> arg::rem - | Tpat_any -> omega::rem - | _ -> raise NoMatch in - matcher_rec -| _ -> - fun q rem -> match q.pat_desc with - | Tpat_or (_,_,_) -> raise OrPat - | Tpat_construct (_,cstr',args) - when Types.may_equal_constr cstr cstr' -> args @ rem - | Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem - | _ -> raise NoMatch - -let is_not_none_bs_primitve : Lambda.primitive = - Pccall - (Primitive.simple ~name:"#is_not_none" ~arity:1 ~alloc:false) - -let val_from_option_bs_primitive : Lambda.primitive = - Pccall - (Primitive.simple ~name:"#val_from_option" ~arity:1 ~alloc:true) - -let val_from_unnest_option_bs_primitive : Lambda.primitive = - Pccall - (Primitive.simple ~name:"#val_from_unnest_option" ~arity:1 ~alloc:true) - -let make_constr_matching p def ctx = function - [] -> fatal_error "Matching.make_constr_matching" - | ((arg, _mut) :: argl) -> - let cstr = pat_as_constr p in - let untagged = Ast_untagged_variants.has_untagged cstr.cstr_attributes in - let newargs = - if cstr.cstr_inlined <> None || (untagged && cstr.cstr_args <> []) then - (arg, Alias) :: argl - else match cstr.cstr_tag with - | Cstr_block _ when - !Config.bs_only && - Datarepr.constructor_has_optional_shape cstr - -> - begin - let from_option = - match p.pat_desc with - | Tpat_construct(_, _, - [ { - pat_type ; pat_env - } ]) - when Typeopt.type_cannot_contain_undefined pat_type pat_env - -> val_from_unnest_option_bs_primitive - | _ -> val_from_option_bs_primitive in - (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl - end - | Cstr_constant _ - | Cstr_block _ -> - make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl - ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) - | Cstr_unboxed -> (arg, Alias) :: argl - | Cstr_extension _ -> - make_field_args p.pat_loc Alias arg 1 cstr.cstr_arity argl - ~fld_info:Fld_extension - in - {pm= - {cases = []; args = newargs; - default = make_default (matcher_constr cstr) def} ; - ctx = filter_ctx p ctx ; - pat=normalize_pat p} - - -let divide_constructor ctx pm = - divide - make_constr_matching - Types.equal_tag get_key_constr get_args_constr - ctx pm - -(* Matching against a variant *) - -let rec matcher_variant_const lab p rem = match p.pat_desc with -| Tpat_or (p1, p2, _) -> - begin - try - matcher_variant_const lab p1 rem - with - | NoMatch -> matcher_variant_const lab p2 rem - end -| Tpat_variant (lab1,_,_) when lab1=lab -> rem -| Tpat_any -> rem -| _ -> raise NoMatch - - -let make_variant_matching_constant p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_constant" - | (_ :: argl) -> - let def = make_default (matcher_variant_const lab) def - and ctx = filter_ctx p ctx in - {pm={ cases = []; args = argl ; default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let matcher_variant_nonconst lab p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_variant (lab1,Some arg,_) when lab1=lab -> arg::rem -| Tpat_any -> omega::rem -| _ -> raise NoMatch - - -let make_variant_matching_nonconst p lab def ctx = function - [] -> fatal_error "Matching.make_variant_matching_nonconst" - | ((arg, _mut) :: argl) -> - let def = make_default (matcher_variant_nonconst lab) def - and ctx = filter_ctx p ctx in - {pm= - {cases = []; args = (Lprim(Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) :: argl; - default=def} ; - ctx=ctx ; - pat = normalize_pat p} - -let divide_variant row ctx {cases = cl; args = al; default=def} = - let row = Btype.row_repr row in - let rec divide = function - ({pat_desc = Tpat_variant(lab, pato, _)} as p:: patl, action) :: rem -> - let variants = divide rem in - if try Btype.row_field_repr (List.assoc lab row.row_fields) = Rabsent - with Not_found -> true - then - variants - else begin - let tag = Btype.hash_variant lab in - let (=) ((a:string),(b:Types.constructor_tag)) (c,d) = - a = c && Types.equal_tag b d - in - match pato with - None -> - add (make_variant_matching_constant p lab def ctx) variants - (=) (lab,Cstr_constant tag) (patl, action) al - | Some pat -> - add (make_variant_matching_nonconst p lab def ctx) variants - (=) (lab,Cstr_block tag) (pat :: patl, action) al - end - | _ -> [] - in - divide cl - -(* - Three ``no-test'' cases - *) - -(* Matching against a variable *) - -let get_args_var _ rem = rem - - -let make_var_matching def = function - | [] -> fatal_error "Matching.make_var_matching" - | _::argl -> - {cases=[] ; - args = argl ; - default= make_default get_args_var def} - -let divide_var ctx pm = - divide_line ctx_lshift make_var_matching get_args_var omega ctx pm - -(* Matching and forcing a lazy value *) - -let get_arg_lazy p rem = match p with -| {pat_desc = Tpat_any} -> omega :: rem -| {pat_desc = Tpat_lazy arg} -> arg :: rem -| _ -> assert false - -let matcher_lazy p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omega :: rem -| Tpat_lazy arg -> arg :: rem -| _ -> raise NoMatch - -(* Inlining the tag tests before calling the primitive that works on - lazy blocks. This is also used in translcore.ml. - No other call than Obj.tag when the value has been forced before. -*) - - -let get_mod_field modname field = - lazy ( - try - let mod_ident = Ident.create_persistent modname in - let env = Env.open_pers_signature modname Env.initial_safe_string in - let p = try - match Env.lookup_value (Longident.Lident field) env with - | (Path.Pdot(_,_,i), _) -> i - | _ -> fatal_error ("Primitive "^modname^"."^field^" not found.") - with Not_found -> - fatal_error ("Primitive "^modname^"."^field^" not found.") - in - Lprim(Pfield (p, Fld_module {name = field}), - [Lprim(Pgetglobal mod_ident, [], Location.none)], - Location.none) - with Not_found -> fatal_error ("Module "^modname^" unavailable.") - ) - - -let code_force = - get_mod_field "CamlinternalLazy" "force" -;; - -(* inline_lazy_force inlines the beginning of the code of Lazy.force. When - the value argument is tagged as: - - forward, take field 0 - - lazy, call the primitive that forces (without testing again the tag) - - anything else, return it - - Using Lswitch below relies on the fact that the GC does not shortcut - Forward(val_out_of_heap). -*) - - -let inline_lazy_force arg loc = - Lapply { ap_func = Lazy.force code_force; ap_inlined = Default_inline; ap_args = [arg]; ap_loc = loc} -let make_lazy_matching def = function - [] -> fatal_error "Matching.make_lazy_matching" - | (arg,_mut) :: argl -> - { cases = []; - args = - (inline_lazy_force arg Location.none, Strict) :: argl; - default = make_default matcher_lazy def } - -let divide_lazy p ctx pm = - divide_line - (filter_ctx p) - make_lazy_matching - get_arg_lazy - p ctx pm - -(* Matching against a tuple pattern *) - - -let get_args_tuple arity p rem = match p with -| {pat_desc = Tpat_any} -> omegas arity @ rem -| {pat_desc = Tpat_tuple args} -> - args @ rem -| _ -> assert false - -let matcher_tuple arity p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> omegas arity @ rem -| Tpat_tuple args when List.length args = arity -> args @ rem -| _ -> raise NoMatch - -let make_tuple_matching loc arity def = function - [] -> fatal_error "Matching.make_tuple_matching" - | (arg, _mut) :: argl -> - let rec make_args pos = - if pos >= arity - then argl - else (Lprim(Pfield (pos, Fld_tuple), [arg], loc), Alias) :: make_args (pos + 1) in - {cases = []; args = make_args 0 ; - default=make_default (matcher_tuple arity) def} - - -let divide_tuple arity p ctx pm = - divide_line - (filter_ctx p) - (make_tuple_matching p.pat_loc arity) - (get_args_tuple arity) p ctx pm - -(* Matching against a record pattern *) - - -let record_matching_line num_fields lbl_pat_list = - let patv = Array.make num_fields omega in - List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; - Array.to_list patv - -let get_args_record num_fields p rem = match p with -| {pat_desc=Tpat_any} -> - record_matching_line num_fields [] @ rem -| {pat_desc=Tpat_record (lbl_pat_list,_)} -> - record_matching_line num_fields lbl_pat_list @ rem -| _ -> assert false - -let matcher_record num_fields p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_any -| Tpat_var _ -> - record_matching_line num_fields [] @ rem -| Tpat_record ([], _) when num_fields = 0 -> rem -| Tpat_record ((_, lbl, _) :: _ as lbl_pat_list, _) - when Array.length lbl.lbl_all = num_fields -> - record_matching_line num_fields lbl_pat_list @ rem -| _ -> raise NoMatch - -let make_record_matching loc all_labels def = function - [] -> fatal_error "Matching.make_record_matching" - | ((arg, _mut) :: argl) -> - let rec make_args pos = - if pos >= Array.length all_labels then argl else begin - let lbl = all_labels.(pos) in - let access = - match lbl.lbl_repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) - | Record_inlined _ -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) - | Record_unboxed _ -> arg - | Record_extension -> Lprim (Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], loc) - in - let str = - match lbl.lbl_mut with - Immutable -> Alias - | Mutable -> StrictOpt in - (access, str) :: make_args(pos + 1) - end in - let nfields = Array.length all_labels in - let def= make_default (matcher_record nfields) def in - {cases = []; args = make_args 0 ; default = def} - - -let divide_record all_labels p ctx pm = - let get_args = get_args_record (Array.length all_labels) in - divide_line - (filter_ctx p) - (make_record_matching p.pat_loc all_labels) - get_args - p ctx pm - -(* Matching against an array pattern *) - -let get_key_array = function - | {pat_desc=Tpat_array patl} -> List.length patl - | _ -> assert false - -let get_args_array p rem = match p with -| {pat_desc=Tpat_array patl} -> patl@rem -| _ -> assert false - -let matcher_array len p rem = match p.pat_desc with -| Tpat_or (_,_,_) -> raise OrPat -| Tpat_array args when List.length args=len -> args @ rem -| Tpat_any -> Parmatch.omegas len @ rem -| _ -> raise NoMatch - -let make_array_matching p def ctx = function - | [] -> fatal_error "Matching.make_array_matching" - | ((arg, _mut) :: argl) -> - let len = get_key_array p in - let rec make_args pos = - if pos >= len - then argl - else (Lprim(Parrayrefu , - [arg; Lconst(Const_base(Const_int pos))], - p.pat_loc), - StrictOpt) :: make_args (pos + 1) in - let def = make_default (matcher_array len) def - and ctx = filter_ctx p ctx in - {pm={cases = []; args = make_args 0 ; default = def} ; - ctx=ctx ; - pat = normalize_pat p} - -let divide_array ctx pm = - divide - make_array_matching - (=) get_key_array get_args_array ctx pm - - -(* - Specific string test sequence - Will be called by the bytecode compiler, from bytegen.ml. - The strategy is first dichotomic search (we perform 3-way tests - with compare_string), then sequence of equality tests - when there are less then T=strings_test_threshold static strings to match. - - Increasing T entails (slightly) less code, decreasing T - (slightly) favors runtime speed. - T=8 looks a decent tradeoff. -*) - -(* Utilities *) - -let strings_test_threshold = 8 - -let prim_string_notequal = - Pccall(Primitive.simple - ~name:"caml_string_notequal" - ~arity:2 - ~alloc:false) - -let prim_string_compare = - Pccall(Primitive.simple - ~name:"caml_string_compare" - ~arity:2 - ~alloc:false) - -let bind_sw arg k = match arg with -| Lvar _ -> k arg -| _ -> - let id = Ident.create "switch" in - Llet (Strict,Pgenval,id,arg,k (Lvar id)) - - -(* Sequential equality tests *) - -let make_string_test_sequence loc arg sw d = - let d,sw = match d with - | None -> - begin match sw with - | (_,d)::sw -> d,sw - | [] -> assert false - end - | Some d -> d,sw in - bind_sw arg - (fun arg -> - List.fold_right - (fun (s,lam) k -> - Lifthenelse - (Lprim - (prim_string_notequal, - [arg; Lconst (Const_immstring s)], loc), - k,lam)) - sw d) - -let rec split k xs = match xs with -| [] -> assert false -| x0::xs -> - if k <= 1 then [],x0,xs - else - let xs,y0,ys = split (k-2) xs in - x0::xs,y0,ys - -let zero_lam = Lconst (Const_base (Const_int 0)) - -let tree_way_test loc arg lt eq gt = - Lifthenelse - (Lprim (Pintcomp Clt,[arg;zero_lam], loc),lt, - Lifthenelse(Lprim (Pintcomp Clt,[zero_lam;arg], loc),gt,eq)) - -(* Dichotomic tree *) - - -let rec do_make_string_test_tree loc arg sw delta d = - let len = List.length sw in - if len <= strings_test_threshold+delta then - make_string_test_sequence loc arg sw d - else - let lt,(s,act),gt = split len sw in - bind_sw - (Lprim - (prim_string_compare, - [arg; Lconst (Const_immstring s)], loc)) - (fun r -> - tree_way_test loc r - (do_make_string_test_tree loc arg lt delta d) - act - (do_make_string_test_tree loc arg gt delta d)) - -(* Entry point *) -let expand_stringswitch loc arg sw d = match d with -| None -> - bind_sw arg - (fun arg -> do_make_string_test_tree loc arg sw 0 None) -| Some e -> - bind_sw arg - (fun arg -> - make_catch e - (fun d -> do_make_string_test_tree loc arg sw 1 (Some d))) - -(**********************) -(* Generic test trees *) -(**********************) - -(* Sharing *) - -(* Add handler, if shared *) -let handle_shared () = - let hs = ref (fun x -> x) in - let handle_shared act = match act with - | Switch.Single act -> act - | Switch.Shared act -> - let i,h = make_catch_delayed act in - let ohs = !hs in - hs := (fun act -> h (ohs act)) ; - make_exit i in - hs,handle_shared - - -let share_actions_tree sw d = - let store = StoreExp.mk_store () in -(* Default action is always shared *) - let d = - match d with - | None -> None - | Some d -> Some (store.Switch.act_store_shared d) in -(* Store all other actions *) - let sw = - List.map (fun (cst,act) -> cst,store.Switch.act_store act) sw in - -(* Retrieve all actions, including potential default *) - let acts = store.Switch.act_get_shared () in - -(* Array of actual actions *) - let hs,handle_shared = handle_shared () in - let acts = Array.map handle_shared acts in - -(* Reconstruct default and switch list *) - let d = match d with - | None -> None - | Some d -> Some (acts.(d)) in - let sw = List.map (fun (cst,j) -> cst,acts.(j)) sw in - !hs,sw,d - -(* Note: dichotomic search requires sorted input with no duplicates *) -let rec uniq_lambda_list sw = match sw with - | []|[_] -> sw - | (c1,_ as p1)::((c2,_)::sw2 as sw1) -> - if const_compare c1 c2 = 0 then uniq_lambda_list (p1::sw2) - else p1::uniq_lambda_list sw1 - -let sort_lambda_list l = - let l = - List.stable_sort (fun (x,_) (y,_) -> const_compare x y) l in - uniq_lambda_list l - -let rec cut n l = - if n = 0 then [],l - else match l with - [] -> raise (Invalid_argument "cut") - | a::l -> let l1,l2 = cut (n-1) l in a::l1, l2 - -let rec do_tests_fail loc fail tst arg = function - | [] -> fail - | (c, act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_fail loc fail tst arg rem, - act) - -let rec do_tests_nofail loc tst arg = function - | [] -> fatal_error "Matching.do_tests_nofail" - | [_,act] -> act - | (c,act)::rem -> - Lifthenelse - (Lprim (tst, [arg ; Lconst (Const_base c)], loc), - do_tests_nofail loc tst arg rem, - act) - -let make_test_sequence loc fail tst lt_tst arg const_lambda_list = - let const_lambda_list = sort_lambda_list const_lambda_list in - let hs,const_lambda_list,fail = - share_actions_tree const_lambda_list fail in - - let rec make_test_sequence const_lambda_list = - if List.length const_lambda_list >= 4 && lt_tst <> Pignore then - split_sequence const_lambda_list - else match fail with - | None -> do_tests_nofail loc tst arg const_lambda_list - | Some fail -> do_tests_fail loc fail tst arg const_lambda_list - - and split_sequence const_lambda_list = - let list1, list2 = - cut (List.length const_lambda_list / 2) const_lambda_list in - Lifthenelse(Lprim(lt_tst, - [arg; Lconst(Const_base (fst(List.hd list2)))], - loc), - make_test_sequence list1, make_test_sequence list2) - in - hs (make_test_sequence const_lambda_list) - - -module SArg = struct - type primitive = Lambda.primitive - - let eqint = Pintcomp Ceq - let neint = Pintcomp Cneq - let leint = Pintcomp Cle - let ltint = Pintcomp Clt - let geint = Pintcomp Cge - let gtint = Pintcomp Cgt - - type act = Lambda.lambda - - let make_prim p args = Lprim (p,args,Location.none) - let make_offset arg n = match n with - | 0 -> arg - | _ -> Lprim (Poffsetint n,[arg],Location.none) - - let bind arg body = - let newvar,newarg = match arg with - | Lvar v -> v,arg - | _ -> - let newvar = Ident.create "switcher" in - newvar,Lvar newvar in - bind Alias newvar arg (body newarg) - let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) - let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) - let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases acts ~offset sw_names = - let l = ref [] in - for i = Array.length cases-1 downto 0 do - l := (offset + i,acts.(cases.(i))) :: !l - done ; - Lswitch(arg, - {sw_numconsts = Array.length cases ; sw_consts = !l ; - sw_numblocks = 0 ; sw_blocks = [] ; - sw_failaction = None; - sw_names}, loc) - let make_catch = make_catch_delayed - let make_exit = make_exit - -end - -(* Action sharing for Lswitch argument *) -let share_actions_sw sw = -(* Attempt sharing on all actions *) - let store = StoreExp.mk_store () in - let fail = match sw.sw_failaction with - | None -> None - | Some fail -> - (* Fail is translated to exit, whatever happens *) - Some (store.Switch.act_store_shared fail) in - let consts = - List.map - (fun (i,e) -> i,store.Switch.act_store e) - sw.sw_consts - and blocks = - List.map - (fun (i,e) -> i,store.Switch.act_store e) - sw.sw_blocks in - let acts = store.Switch.act_get_shared () in - let hs,handle_shared = handle_shared () in - let acts = Array.map handle_shared acts in - let fail = match fail with - | None -> None - | Some fail -> Some (acts.(fail)) in - !hs, - { sw with - sw_consts = List.map (fun (i,j) -> i,acts.(j)) consts ; - sw_blocks = List.map (fun (i,j) -> i,acts.(j)) blocks ; - sw_failaction = fail; } - -(* Reintroduce fail action in switch argument, - for the sake of avoiding carrying over huge switches *) - -let reintroduce_fail sw = match sw.sw_failaction with -| None -> - let t = Hashtbl.create 17 in - let seen (_,l) = match as_simple_exit l with - | Some i -> - let old = try Hashtbl.find t i with Not_found -> 0 in - Hashtbl.replace t i (old+1) - | None -> () in - List.iter seen sw.sw_consts ; - List.iter seen sw.sw_blocks ; - let i_max = ref (-1) - and max = ref (-1) in - Hashtbl.iter - (fun i c -> - if c > !max then begin - i_max := i ; - max := c - end) t ; - if !max >= 3 then - let default = !i_max in - let remove ls = - Ext_list.filter ls - (fun (_,lam) -> match as_simple_exit lam with - | Some j -> j <> default - | None -> true) in - {sw with - sw_consts = remove sw.sw_consts ; - sw_blocks = remove sw.sw_blocks ; - sw_failaction = Some (make_exit default)} - else sw -| Some _ -> sw - - -module Switcher = Switch.Make(SArg) -open Switch - -let rec last def = function - | [] -> def - | [x,_] -> x - | _::rem -> last def rem - -let get_edges low high l = match l with -| [] -> low, high -| (x,_)::_ -> x, last high l - - -let as_interval_canfail fail low high l = - let store = StoreExp.mk_store () in - - let do_store _tag act = - - let i = store.act_store act in -(* - eprintf "STORE [%s] %i %s\n" tag i (string_of_lam act) ; -*) - i in - - let rec nofail_rec cur_low cur_high cur_act = function - | [] -> - if cur_high = high then - [cur_low,cur_high,cur_act] - else - [(cur_low,cur_high,cur_act) ; (cur_high+1,high, 0)] - | ((i,act_i)::rem) as all -> - let act_index = do_store "NO" act_i in - if cur_high+1= i then - if act_index=cur_act then - nofail_rec cur_low i cur_act rem - else if act_index=0 then - (cur_low,i-1, cur_act)::fail_rec i i rem - else - (cur_low, i-1, cur_act)::nofail_rec i i act_index rem - else if act_index = 0 then - (cur_low, cur_high, cur_act):: - fail_rec (cur_high+1) (cur_high+1) all - else - (cur_low, cur_high, cur_act):: - (cur_high+1,i-1,0):: - nofail_rec i i act_index rem - - and fail_rec cur_low cur_high = function - | [] -> [(cur_low, cur_high, 0)] - | (i,act_i)::rem -> - let index = do_store "YES" act_i in - if index=0 then fail_rec cur_low i rem - else - (cur_low,i-1,0):: - nofail_rec i i index rem in - - let init_rec = function - | [] -> [low,high,0] - | (i,act_i)::rem -> - let index = do_store "INIT" act_i in - if index=0 then - fail_rec low i rem - else - if low < i then - (low,i-1,0)::nofail_rec i i index rem - else - nofail_rec i i index rem in - - assert (do_store "FAIL" fail = 0) ; (* fail has action index 0 *) - let r = init_rec l in - Array.of_list r, store - -let as_interval_nofail l = - let store = StoreExp.mk_store () in - let rec some_hole = function - | []|[_] -> false - | (i,_)::((j,_)::_ as rem) -> - j > i+1 || some_hole rem in - let rec i_rec cur_low cur_high cur_act = function - | [] -> - [cur_low, cur_high, cur_act] - | (i,act)::rem -> - let act_index = store.act_store act in - if act_index = cur_act then - i_rec cur_low i cur_act rem - else - (cur_low, cur_high, cur_act):: - i_rec i i act_index rem in - let inters = match l with - | (i,act)::rem -> - let act_index = - (* In case there is some hole and that a switch is emitted, - action 0 will be used as the action of unreachable - cases (cf. switch.ml, make_switch). - Hence, this action will be shared *) - if some_hole rem then - store.act_store_shared act - else - store.act_store act in - assert (act_index = 0) ; - i_rec i i act_index rem - | _ -> assert false in - - Array.of_list inters, store - - -let sort_int_lambda_list l = - List.sort - (fun (i1,_) (i2,_) -> - if i1 < i2 then -1 - else if i2 < i1 then 1 - else 0) - l - -let as_interval fail low high l = - let l = sort_int_lambda_list l in - get_edges low high l, - (match fail with - | None -> as_interval_nofail l - | Some act -> as_interval_canfail act low high l) - -let call_switcher loc fail arg low high int_lambda_list sw_names = - let edges, (cases, actions) = - as_interval fail low high int_lambda_list in - Switcher.zyva loc edges arg cases actions sw_names - - -let rec list_as_pat = function - | [] -> fatal_error "Matching.list_as_pat" - | [pat] -> pat - | pat::rem -> - {pat with pat_desc = Tpat_or (pat,list_as_pat rem,None)} - - -let complete_pats_constrs = function - | p::_ as pats -> - List.map - (pat_of_constr p) - (complete_constrs p (List.map get_key_constr pats)) - | _ -> assert false - - -(* - Following two ``failaction'' function compute n, the trap handler - to jump to in case of failure of elementary tests -*) - -let mk_failaction_neg partial ctx def = match partial with -| Partial -> - begin match def with - | (_,idef)::_ -> - Some (Lstaticraise (idef,[])),jumps_singleton idef ctx - | [] -> - (* Act as Total, this means - If no appropriate default matrix exists, - then this switch cannot fail *) - None, jumps_empty - end -| Total -> - None, jumps_empty - - - -(* In line with the article and simpler than before *) -let mk_failaction_pos partial seen ctx defs = - if dbg then begin - prerr_endline "**POS**" ; - pretty_def defs ; - () - end ; - let rec scan_def env to_test defs = match to_test,defs with - | ([],_)|(_,[]) -> - List.fold_left - (fun (klist,jumps) (pats,i)-> - let action = Lstaticraise (i,[]) in - let klist = - List.fold_right - (fun pat r -> (get_key_constr pat,action)::r) - pats klist - and jumps = - jumps_add i (ctx_lub (list_as_pat pats) ctx) jumps in - klist,jumps) - ([],jumps_empty) env - | _,(pss,idef)::rem -> - let now, later = - List.partition - (fun (_p,p_ctx) -> ctx_match p_ctx pss) to_test in - match now with - | [] -> scan_def env to_test rem - | _ -> scan_def ((List.map fst now,idef)::env) later rem in - - let fail_pats = complete_pats_constrs seen in - if List.length fail_pats < 32 then begin - let fail,jmps = - scan_def - [] - (List.map - (fun pat -> pat, ctx_lub pat ctx) - fail_pats) - defs in - if dbg then begin - eprintf "POSITIVE JUMPS [%i]:\n" (List.length fail_pats); - pretty_jumps jmps - end ; - None,fail,jmps - end else begin (* Too many non-matched constructors -> reduced information *) - if dbg then eprintf "POS->NEG!!!\n%!" ; - let fail,jumps = mk_failaction_neg partial ctx defs in - if dbg then - eprintf "FAIL: %s\n" - (match fail with - | None -> "" - | Some lam -> string_of_lam lam) ; - fail,[],jumps - end - -let combine_constant names loc arg cst partial ctx def - (const_lambda_list, total, _pats) = - let fail, local_jumps = - mk_failaction_neg partial ctx def in - let lambda1 = - match cst with - | Const_int _ -> - let int_lambda_list = - List.map (function Const_int n, l -> n,l | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg min_int max_int int_lambda_list names - | Const_char _ -> - let int_lambda_list = - List.map (function Const_char c, l -> (c, l) - | _ -> assert false) - const_lambda_list in - call_switcher loc fail arg 0 max_int int_lambda_list names - | Const_string _ -> -(* Note as the bytecode compiler may resort to dichotomic search, - the clauses of stringswitch are sorted with duplicates removed. - This partly applies to the native code compiler, which requires - no duplicates *) - let const_lambda_list = sort_lambda_list const_lambda_list in - let sw = - List.map - (fun (c,act) -> match c with - | Const_string (s,_) -> s,act - | _ -> assert false) - const_lambda_list in - let hs,sw,fail = share_actions_tree sw fail in - hs (Lstringswitch (arg,sw,fail,loc)) - | Const_float _ -> - make_test_sequence loc - fail - (Pfloatcomp Cneq) (Pfloatcomp Clt) - arg const_lambda_list - | Const_int32 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint32, Cneq)) (Pbintcomp(Pint32, Clt)) - arg const_lambda_list - | Const_int64 _ -> - make_test_sequence loc - fail - (Pbintcomp(Pint64, Cneq)) (Pbintcomp(Pint64, Clt)) - arg const_lambda_list - | Const_bigint _ -> - make_test_sequence loc - fail - (Pbigintcomp Cneq) (Pbigintcomp Clt) - arg const_lambda_list - in lambda1,jumps_union local_jumps total - - - -let split_cases tag_lambda_list = - let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_constant n -> ((n, act) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, act) :: nonconsts) - | Cstr_unboxed -> (consts, (0, act) :: nonconsts) - | Cstr_extension _ -> assert false in - let const, nonconst = split_rec tag_lambda_list in - sort_int_lambda_list const, - sort_int_lambda_list nonconst - -(* refine [split_cases] and [split_variant_cases] *) -let split_variant_cases tag_lambda_list = - let rec split_rec = function - [] -> ([], []) - | ((name,cstr), act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_constant n -> ((n, (name, act)) :: consts, nonconsts) - | Cstr_block n -> (consts, (n, (name, act)) :: nonconsts) - | Cstr_unboxed -> assert false - | Cstr_extension _ -> assert false in - let const, nonconst = split_rec tag_lambda_list in - sort_int_lambda_list const, - sort_int_lambda_list nonconst - -let split_extension_cases tag_lambda_list = - let rec split_rec = function - [] -> ([], []) - | (cstr, act) :: rem -> - let (consts, nonconsts) = split_rec rem in - match cstr with - Cstr_extension(path, true) when not !Config.bs_only -> ((path, act) :: consts, nonconsts) - | Cstr_extension(path, _) -> (consts, (path, act) :: nonconsts) - | _ -> assert false in - split_rec tag_lambda_list - - -let extension_slot_eq = - Pccall (Primitive.simple ~name:"#extension_slot_eq" ~arity:2 ~alloc:false) -let combine_constructor sw_names loc arg ex_pat cstr partial ctx def - (tag_lambda_list, total1, pats) = - if cstr.cstr_consts < 0 then begin - (* Special cases for extensions *) - let fail, local_jumps = - mk_failaction_neg partial ctx def in - let lambda1 = - let consts, nonconsts = split_extension_cases tag_lambda_list in - let default, consts, nonconsts = - match fail with - | None -> - begin match consts, nonconsts with - | _, (_, act)::rem -> act, consts, rem - | (_, act)::rem, _ -> act, rem, nonconsts - | _ -> assert false - end - | Some fail -> fail, consts, nonconsts in - let nonconst_lambda = - match nonconsts with - [] -> default - | _ -> - let tag = Ident.create "tag" in - let tests = - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse(Lprim(extension_slot_eq , [Lvar tag; ext], loc), - act, rem)) - nonconsts - default - in - Llet(Alias, Pgenval,tag, arg, tests) - in - List.fold_right - (fun (path, act) rem -> - let ext = transl_extension_path ex_pat.pat_env path in - Lifthenelse(Lprim(extension_slot_eq , [arg; ext], loc), - act, rem)) - consts - nonconst_lambda - in - lambda1, jumps_union local_jumps total1 - end else begin - (* Regular concrete type *) - let ncases = List.length tag_lambda_list - and nconstrs = cstr.cstr_consts + cstr.cstr_nonconsts in - let sig_complete = ncases = nconstrs in - let fail_opt,fails,local_jumps = - if sig_complete then None,[],jumps_empty - else - mk_failaction_pos partial pats ctx def in - - let tag_lambda_list = fails @ tag_lambda_list in - let (consts, nonconsts) = split_cases tag_lambda_list in - let lambda1 = - match fail_opt,same_actions tag_lambda_list with - | None,Some act -> act (* Identical actions, no failure *) - | _ -> - match - (cstr.cstr_consts, cstr.cstr_nonconsts, consts, nonconsts) - with - | (1, 1, [0, act1], [0, act2]) - when cstr.cstr_name = "::" || cstr.cstr_name = "[]" || Datarepr.constructor_has_optional_shape cstr - -> - (* Typically, match on lists, will avoid isint primitive in that - case *) - let arg = - if !Config.bs_only && Datarepr.constructor_has_optional_shape cstr then - Lprim(is_not_none_bs_primitve , [arg], loc) - else arg - in - Lifthenelse(arg, act2, act1) - | (2,0, [(i1,act1); (_,act2)],[]) when cstr.cstr_name = "true" || cstr.cstr_name = "false" -> - if i1 = 0 then Lifthenelse(arg, act2, act1) - else Lifthenelse (arg, act1, act2) - | (n,0,_,[]) when false (* relies on tag being an int *) -> (* The type defines constant constructors only *) - call_switcher loc fail_opt arg 0 (n-1) consts sw_names - | (n, _, _, _) -> - let act0 = - (* = Some act when all non-const constructors match to act *) - match fail_opt,nonconsts with - | Some a,[] -> Some a - | Some _,_ -> - if List.length nonconsts = cstr.cstr_nonconsts then - same_actions nonconsts - else None - | None,_ -> same_actions nonconsts in - match act0 with - | Some act when false (* relies on tag being an int *) -> - Lifthenelse - (Lprim (Pisint, [arg], loc), - call_switcher loc - fail_opt arg - 0 (n-1) consts sw_names, - act) -(* Emit a switch, as bytecode implements this sophisticated instruction *) - | _ -> - let sw = - {sw_numconsts = cstr.cstr_consts; sw_consts = consts; - sw_numblocks = cstr.cstr_nonconsts; sw_blocks = nonconsts; - sw_failaction = fail_opt; - sw_names} in - let hs,sw = share_actions_sw sw in - let sw = reintroduce_fail sw in - hs (Lswitch (arg,sw,loc)) in - lambda1, jumps_union local_jumps total1 - end - -let make_test_sequence_variant_constant fail arg int_lambda_list = - let _, (cases, actions) = - as_interval fail min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) in - Switcher.test_sequence arg cases actions - -let call_switcher_variant_constant loc fail arg int_lambda_list names = - call_switcher loc fail arg min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) names - - -let call_switcher_variant_constr loc fail arg int_lambda_list names = - let v = Ident.create "variant" in - Llet(Alias, Pgenval, v, Lprim(Pfield (0, Fld_poly_var_tag), [arg], loc), - call_switcher loc - fail (Lvar v) min_int max_int (List.map (fun (a,(_,c)) -> (a,c)) int_lambda_list) names) - -let call_switcher_variant_constant : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref= ref call_switcher_variant_constant - -let call_switcher_variant_constr : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref - = ref call_switcher_variant_constr - -let make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) - ref - = ref make_test_sequence_variant_constant - -let combine_variant names loc row arg partial ctx def - (tag_lambda_list, total1, _pats) = - let row = Btype.row_repr row in - let num_constr = ref 0 in - if row.row_closed then - List.iter - (fun (_, f) -> - match Btype.row_field_repr f with - Rabsent | Reither(true, _::_, _, _) -> () - | _ -> incr num_constr) - row.row_fields - else - num_constr := max_int; - let test_int_or_block arg if_int if_block = - if !Config.bs_only then - Lifthenelse(Lprim (Pccall(Primitive.simple ~name:"#is_poly_var_block" ~arity:1 ~alloc:false), [arg], loc), if_block, if_int) - else - Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in - let sig_complete = List.length tag_lambda_list = !num_constr - and one_action = same_actions tag_lambda_list in (* reduandant work under bs context *) - let fail, local_jumps = - if - sig_complete || (match partial with Total -> true | _ -> false) - then - None, jumps_empty - else - mk_failaction_neg partial ctx def in - let (consts, nonconsts) = split_variant_cases tag_lambda_list in - let lambda1 = match fail, one_action with - | None, Some act -> act - | _,_ -> - match (consts, nonconsts) with - | ([_, (_,act1)], [_, (_,act2)]) when fail=None -> - test_int_or_block arg act1 act2 - | (_, []) -> (* One can compare integers and pointers *) - !make_test_sequence_variant_constant fail arg consts - | ([], _) -> - let lam = !call_switcher_variant_constr loc - fail arg nonconsts names in - (* One must not dereference integers *) - begin match fail with - | None -> lam - | Some fail -> test_int_or_block arg fail lam - end - | (_, _) -> - let lam_const = - !call_switcher_variant_constant loc - fail arg consts names - and lam_nonconst = - !call_switcher_variant_constr loc - fail arg nonconsts names in - test_int_or_block arg lam_const lam_nonconst - in - lambda1, jumps_union local_jumps total1 - - -let combine_array names loc arg partial ctx def - (len_lambda_list, total1, _pats) = - let fail, local_jumps = mk_failaction_neg partial ctx def in - let lambda1 = - let newvar = Ident.create "len" in - let switch = - call_switcher loc - fail (Lvar newvar) - 0 max_int len_lambda_list names in - bind - Alias newvar (Lprim(Parraylength , [arg], loc)) switch in - lambda1, jumps_union local_jumps total1 - -(* Insertion of debugging events *) - -let [@inline] event_branch _repr lam = lam - - -(* - This exception is raised when the compiler cannot produce code - because control cannot reach the compiled clause, - - Unused is raised initially in compile_test. - - compile_list (for compiling switch results) catch Unused - - comp_match_handlers (for compiling splitted matches) - may reraise Unused - - -*) - -exception Unused - -let compile_list compile_fun division = - - let rec c_rec totals = function - | [] -> [], jumps_unions totals, [] - | (key, cell) :: rem -> - begin match cell.ctx with - | [] -> c_rec totals rem - | _ -> - try - let (lambda1, total1) = compile_fun cell.ctx cell.pm in - let c_rem, total, new_pats = - c_rec - (jumps_map ctx_combine total1::totals) rem in - ((key,lambda1)::c_rem), total, (cell.pat::new_pats) - with - | Unused -> c_rec totals rem - end in - c_rec [] division - - -let compile_orhandlers compile_fun lambda1 total1 ctx to_catch = - let rec do_rec r total_r = function - | [] -> r,total_r - | (mat,i,vars,pm)::rem -> - begin try - let ctx = select_columns mat ctx in - let handler_i, total_i = - compile_fun ctx pm in - match raw_action r with - | Lstaticraise (j,args) -> - if i=j then - List.fold_right2 (bind Alias) vars args handler_i, - jumps_map (ctx_rshift_num (ncols mat)) total_i - else - do_rec r total_r rem - | _ -> - do_rec - (Lstaticcatch (r,(i,vars), handler_i)) - (jumps_union - (jumps_remove i total_r) - (jumps_map (ctx_rshift_num (ncols mat)) total_i)) - rem - with - | Unused -> - do_rec (Lstaticcatch (r, (i,vars), lambda_unit)) total_r rem - end in - do_rec lambda1 total1 to_catch - - -let compile_test compile_fun partial divide combine ctx to_match = - let division = divide ctx to_match in - let c_div = compile_list compile_fun division in - match c_div with - | [],_,_ -> - begin match mk_failaction_neg partial ctx to_match.default with - | None,_ -> raise Unused - | Some l,total -> l,total - end - | _ -> - combine ctx to_match.default c_div - -(* Attempt to avoid some useless bindings by lowering them *) - -(* Approximation of v present in lam *) -let rec approx_present v = function - | Lconst _ -> false - | Lstaticraise (_,args) -> - List.exists (fun lam -> approx_present v lam) args - | Lprim (_,args,_) -> - List.exists (fun lam -> approx_present v lam) args - | Llet (Alias, _k, _, l1, l2) -> - approx_present v l1 || approx_present v l2 - | Lvar vv -> Ident.same v vv - | _ -> true - -let rec lower_bind v arg lam = match lam with -| Lifthenelse (cond, ifso, ifnot) -> - let pcond = approx_present v cond - and pso = approx_present v ifso - and pnot = approx_present v ifnot in - begin match pcond, pso, pnot with - | false, false, false -> lam - | false, true, false -> - Lifthenelse (cond, lower_bind v arg ifso, ifnot) - | false, false, true -> - Lifthenelse (cond, ifso, lower_bind v arg ifnot) - | _,_,_ -> bind Alias v arg lam - end -| Lswitch (ls,({sw_consts=[i,act] ; sw_blocks = []} as sw), loc) - when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_consts = [i,lower_bind v arg act]}, loc) -| Lswitch (ls,({sw_consts=[] ; sw_blocks = [i,act]} as sw), loc) - when not (approx_present v ls) -> - Lswitch (ls, {sw with sw_blocks = [i,lower_bind v arg act]}, loc) -| Llet (Alias, k, vv, lv, l) -> - if approx_present v lv then - bind Alias v arg lam - else - Llet (Alias, k, vv, lv, lower_bind v arg l) -| Lvar u when Ident.same u v && Ident.name u = "*sth*" -> - arg (* eliminate let *sth* = from_option x in *sth* *) -| _ -> - bind Alias v arg lam - -let bind_check str v arg lam = match str,arg with -| _, Lvar _ ->bind str v arg lam -| Alias,_ -> lower_bind v arg lam -| _,_ -> bind str v arg lam - -let comp_exit ctx m = match m.default with -| (_,i)::_ -> Lstaticraise (i,[]), jumps_singleton i ctx -| _ -> fatal_error "Matching.comp_exit" - - - -let rec comp_match_handlers comp_fun partial ctx arg first_match next_matchs = - match next_matchs with - | [] -> comp_fun partial ctx arg first_match - | rem -> - let rec c_rec body total_body = function - | [] -> body, total_body - (* Hum, -1 means never taken - | (-1,pm)::rem -> c_rec body total_body rem *) - | (i,pm)::rem -> - let ctx_i,total_rem = jumps_extract i total_body in - begin match ctx_i with - | [] -> c_rec body total_body rem - | _ -> - try - let li,total_i = - comp_fun - (match rem with [] -> partial | _ -> Partial) - ctx_i arg pm in - c_rec - (Lstaticcatch (body,(i,[]),li)) - (jumps_union total_i total_rem) - rem - with - | Unused -> - c_rec (Lstaticcatch (body,(i,[]),lambda_unit)) - total_rem rem - end in - try - let first_lam,total = comp_fun Partial ctx arg first_match in - c_rec first_lam total rem - with Unused -> match next_matchs with - | [] -> raise Unused - | (_,x)::xs -> comp_match_handlers comp_fun partial ctx arg x xs - -(* To find reasonable names for variables *) - -let rec name_pattern default = function - (pat :: _, _) :: rem -> - begin match Typecore.id_of_pattern pat with - | Some id -> id - | None -> name_pattern default rem - end - | _ -> Ident.create default - -let arg_to_var arg cls = match arg with -| Lvar v -> v,arg -| _ -> - let v = name_pattern "match" cls in - v,Lvar v - -(* To be set by Lam_compile *) -let names_from_construct_pattern : (pattern -> Ast_untagged_variants.switch_names option) ref = - ref (fun _ -> None) - -(* - The main compilation function. - Input: - repr=used for inserting debug events - partial=exhaustiveness information from Parmatch - ctx=a context - m=a pattern matching - - Output: a lambda term, a jump summary {..., exit number -> context, .. } -*) - -let rec compile_match repr partial ctx m = match m with -| { cases = []; args = [] } -> comp_exit ctx m -| { cases = ([], action) :: rem } -> - if is_guarded action then begin - let (lambda, total) = - compile_match None partial ctx { m with cases = rem } in - event_branch repr (patch_guarded lambda action), total - end else - (event_branch repr action, jumps_empty) -| { args = (arg, str)::argl } -> - let v,newarg = arg_to_var arg m.cases in - let first_match,rem = - split_precompile (Some v) - { m with args = (newarg, Alias) :: argl } in - let (lam, total) = - comp_match_handlers - ((if dbg then do_compile_matching_pr else do_compile_matching) repr) - partial ctx newarg first_match rem in - bind_check str v arg lam, total -| _ -> assert false - - -(* verbose version of do_compile_matching, for debug *) - -and do_compile_matching_pr repr partial ctx arg x = - prerr_string "COMPILE: " ; - prerr_endline (match partial with Partial -> "Partial" | Total -> "Total") ; - prerr_endline "MATCH" ; - pretty_precompiled x ; - prerr_endline "CTX" ; - pretty_ctx ctx ; - let (_, jumps) as r = do_compile_matching repr partial ctx arg x in - prerr_endline "JUMPS" ; - pretty_jumps jumps ; - r - -and do_compile_matching repr partial ctx arg pmh = match pmh with -| Pm pm -> - let pat = what_is_cases pm.cases in - begin match pat.pat_desc with - | Tpat_any -> - compile_no_test - divide_var ctx_rshift repr partial ctx pm - | Tpat_tuple patl -> - compile_no_test - (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine - repr partial ctx pm - | Tpat_record ((_, lbl,_)::_,_) -> - compile_no_test - (divide_record lbl.lbl_all (normalize_pat pat)) - ctx_combine repr partial ctx pm - | Tpat_constant cst -> - let names = None in - compile_test - (compile_match repr partial) partial - divide_constant - (combine_constant names pat.pat_loc arg cst partial) - ctx pm - | Tpat_construct (_, cstr, _) -> - let sw_names = !names_from_construct_pattern pat in - compile_test - (compile_match repr partial) partial - divide_constructor - (combine_constructor sw_names pat.pat_loc arg pat cstr partial) - ctx pm - | Tpat_array _ -> - let names = None in - compile_test (compile_match repr partial) partial - divide_array (combine_array names pat.pat_loc arg partial) - ctx pm - | Tpat_lazy _ -> - compile_no_test - (divide_lazy (normalize_pat pat)) - ctx_combine repr partial ctx pm - | Tpat_variant(_, _, row) -> - let names = None in - compile_test (compile_match repr partial) partial - (divide_variant !row) - (combine_variant names pat.pat_loc !row arg partial) - ctx pm - | _ -> assert false - end -| PmVar {inside=pmh ; var_arg=arg} -> - let lam, total = - do_compile_matching repr partial (ctx_lshift ctx) arg pmh in - lam, jumps_map ctx_rshift total -| PmOr {body=body ; handlers=handlers} -> - let lam, total = compile_match repr partial ctx body in - compile_orhandlers (compile_match repr partial) lam total ctx handlers - -and compile_no_test divide up_ctx repr partial ctx to_match = - let {pm=this_match ; ctx=this_ctx } = divide ctx to_match in - let lambda,total = compile_match repr partial this_ctx this_match in - lambda, jumps_map up_ctx total - - - - -(* The entry points *) - -(* - If there is a guard in a matching or a lazy pattern, - then set exhaustiveness info to Partial. - (because of side effects, assume the worst). - - Notice that exhaustiveness information is trusted by the compiler, - that is, a match flagged as Total should not fail at runtime. - More specifically, for instance if match y with x::_ -> x is flagged - total (as it happens during JoCaml compilation) then y cannot be [] - at runtime. As a consequence, the static Total exhaustiveness information - have to be downgraded to Partial, in the dubious cases where guards - or lazy pattern execute arbitrary code that may perform side effects - and change the subject values. -LM: - Lazy pattern was PR#5992, initial patch by lpw25. - I have generalized the patch, so as to also find mutable fields. -*) - -let find_in_pat pred = - let rec find_rec p = - pred p.pat_desc || - begin match p.pat_desc with - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p -> - find_rec p - | Tpat_tuple ps|Tpat_construct (_,_,ps) | Tpat_array ps -> - List.exists find_rec ps - | Tpat_record (lpats,_) -> - List.exists - (fun (_, _, p) -> find_rec p) - lpats - | Tpat_or (p,q,_) -> - find_rec p || find_rec q - | Tpat_constant _ | Tpat_var _ - | Tpat_any | Tpat_variant (_,None,_) -> false - end in - find_rec - -let is_lazy_pat = function - | Tpat_lazy _ -> true - | Tpat_alias _ | Tpat_variant _ | Tpat_record _ - | Tpat_tuple _|Tpat_construct _ | Tpat_array _ - | Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any - -> false - -let is_lazy p = find_in_pat is_lazy_pat p - -let have_mutable_field p = match p with -| Tpat_record (lps,_) -> - List.exists - (fun (_,lbl,_) -> - match lbl.Types.lbl_mut with - | Mutable -> true - | Immutable -> false) - lps -| Tpat_alias _ | Tpat_variant _ | Tpat_lazy _ -| Tpat_tuple _|Tpat_construct _ | Tpat_array _ -| Tpat_or _ -| Tpat_constant _ | Tpat_var _ | Tpat_any - -> false - -let is_mutable p = find_in_pat have_mutable_field p - -(* Downgrade Total when - 1. Matching accesses some mutable fields; - 2. And there are guards or lazy patterns. -*) - -let check_partial is_mutable is_lazy pat_act_list = function - | Partial -> Partial - | Total -> - if - pat_act_list = [] || (* allow empty case list *) - List.exists - (fun (pats, lam) -> - is_mutable pats && (is_guarded lam || is_lazy pats)) - pat_act_list - then Partial - else Total - -let check_partial_list = - check_partial (List.exists is_mutable) (List.exists is_lazy) -let check_partial = check_partial is_mutable is_lazy - -(* have toplevel handler when appropriate *) - -let start_ctx n = [{left=[] ; right = omegas n}] - -let check_total total lambda i handler_fun = - if jumps_is_empty total then - lambda - else begin - Lstaticcatch(lambda, (i,[]), handler_fun()) - end - -let compile_matching repr handler_fun arg pat_act_list partial = - let partial = check_partial pat_act_list partial in - match partial with - | Partial -> - let raise_num = next_raise_count () in - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = [[[omega]],raise_num]} in - begin try - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - check_total total lambda raise_num handler_fun - with - | Unused -> assert false (* ; handler_fun() *) - end - | Total -> - let pm = - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [arg, Strict] ; - default = []} in - let (lambda, total) = compile_match repr partial (start_ctx 1) pm in - assert (jumps_is_empty total) ; - lambda - - -let partial_function loc () = - (* [Location.get_pos_info] is too expensive *) - let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in - let fname = - Filename.basename fname - in - Lprim(Praise Raise_regular, [Lprim(Pmakeblock(Blk_extension), - [transl_normal_path Predef.path_match_failure; - Lconst(Const_block(Blk_tuple, - [Const_base(Const_string (fname, None)); - Const_base(Const_int line); - Const_base(Const_int char)]))], loc)], loc) - -let for_function loc repr param pat_act_list partial = - compile_matching repr (partial_function loc) param pat_act_list partial - -(* In the following two cases, exhaustiveness info is not available! *) -let for_trywith param pat_act_list = - compile_matching None - (fun () -> Lprim(Praise Raise_reraise, [param], Location.none)) - param pat_act_list Partial - -let simple_for_let loc param pat body = - compile_matching None (partial_function loc) param [pat, body] Partial - - -(* Optimize binding of immediate tuples - - The goal of the implementation of 'for_let' below, which replaces - 'simple_for_let', is to avoid tuple allocation in cases such as - this one: - - let (x,y) = - let foo = ... in - if foo then (1, 2) else (3,4) - in bar - - The compiler easily optimizes the simple `let (x,y) = (1,2) in ...` - case (call to Matching.for_multiple_match from Translcore), but - didn't optimize situations where the rhs tuples are hidden under - a more complex context. - - The idea comes from Alain Frisch who suggested and implemented - the following compilation method, based on Lassign: - - let x = dummy in let y = dummy in - begin - let foo = ... in - if foo then - (let x1 = 1 in let y1 = 2 in x <- x1; y <- y1) - else - (let x2 = 3 in let y2 = 4 in x <- x2; y <- y2) - end; - bar - - The current implementation from Gabriel Scherer uses Lstaticcatch / - Lstaticraise instead: - - catch - let foo = ... in - if foo then - (let x1 = 1 in let y1 = 2 in exit x1 y1) - else - (let x2 = 3 in let y2 = 4 in exit x2 y2) - with x y -> - bar - - The catch/exit is used to avoid duplication of the let body ('bar' - in the example), on 'if' branches for example; it is useless for - linear contexts such as 'let', but we don't need to be careful to - generate nice code because Simplif will remove such useless - catch/exit. -*) - -let rec map_return f = function - | Llet (str, k, id, l1, l2) -> Llet (str, k, id, l1, map_return f l2) - | Lletrec (l1, l2) -> Lletrec (l1, map_return f l2) - | Lifthenelse (lcond, lthen, lelse) -> - Lifthenelse (lcond, map_return f lthen, map_return f lelse) - | Lsequence (l1, l2) -> Lsequence (l1, map_return f l2) - | Ltrywith (l1, id, l2) -> Ltrywith (map_return f l1, id, map_return f l2) - | Lstaticcatch (l1, b, l2) -> - Lstaticcatch (map_return f l1, b, map_return f l2) - | Lstaticraise _ | Lprim(Praise _, _, _) as l -> l - | l -> f l - -(* The 'opt' reference indicates if the optimization is worthy. - - It is shared by the different calls to 'assign_pat' performed from - 'map_return'. For example with the code - let (x, y) = if foo then z else (1,2) - the else-branch will activate the optimization for both branches. - - That means that the optimization is activated if *there exists* an - interesting tuple in one hole of the let-rhs context. We could - choose to activate it only if *all* holes are interesting. We made - that choice because being optimistic is extremely cheap (one static - exit/catch overhead in the "wrong cases"), while being pessimistic - can be costly (one unnecessary tuple allocation). -*) - -let assign_pat opt nraise catch_ids loc pat lam = - let rec collect acc pat lam = match pat.pat_desc, lam with - | Tpat_tuple patl, Lprim(Pmakeblock _, lams, _) -> - opt := true; - List.fold_left2 collect acc patl lams - | Tpat_tuple patl, Lconst(Const_block( _, scl)) -> - opt := true; - let collect_const acc pat sc = collect acc pat (Lconst sc) in - List.fold_left2 collect_const acc patl scl - | _ -> - (* pattern idents will be bound in staticcatch (let body), so we - refresh them here to guarantee binders uniqueness *) - let pat_ids = pat_bound_idents pat in - let fresh_ids = List.map (fun id -> id, Ident.rename id) pat_ids in - (fresh_ids, alpha_pat fresh_ids pat, lam) :: acc - in - - (* sublets were accumulated by 'collect' with the leftmost tuple - pattern at the bottom of the list; to respect right-to-left - evaluation order for tuples, we must evaluate sublets - top-to-bottom. To preserve tail-rec, we will fold_left the - reversed list. *) - let rev_sublets = List.rev (collect [] pat lam) in - let exit = - (* build an Ident.tbl to avoid quadratic refreshing costs *) - let add t (id, fresh_id) = Ident.add id fresh_id t in - let add_ids acc (ids, _pat, _lam) = List.fold_left add acc ids in - let tbl = List.fold_left add_ids Ident.empty rev_sublets in - let fresh_var id = Lvar (Ident.find_same id tbl) in - Lstaticraise(nraise, List.map fresh_var catch_ids) - in - let push_sublet code (_ids, pat, lam) = simple_for_let loc lam pat code in - List.fold_left push_sublet exit rev_sublets - -let for_let loc param pat body = - match pat.pat_desc with - | Tpat_any -> - (* This eliminates a useless variable (and stack slot in bytecode) - for "let _ = ...". See #6865. *) - Lsequence(param, body) - | Tpat_var (id, _) -> - (* fast path, and keep track of simple bindings to unboxable numbers *) - Llet(Strict, Pgenval, id, param, body) - | _ -> - (* Turn off such optimization to reduce diff in the beginning - FIXME*) - if !Config.bs_only then simple_for_let loc param pat body - else - let opt = ref false in - let nraise = next_raise_count () in - let catch_ids = pat_bound_idents pat in - let bind = map_return (assign_pat opt nraise catch_ids loc pat) param in - if !opt then Lstaticcatch(bind, (nraise, catch_ids), body) - else simple_for_let loc param pat body - -(* Handling of tupled functions and matchings *) - -(* Easy case since variables are available *) -let for_tupled_function loc paraml pats_act_list partial = - let partial = check_partial_list pats_act_list partial in - let raise_num = next_raise_count () in - let omegas = [List.map (fun _ -> omega) paraml] in - let pm = - { cases = pats_act_list; - args = List.map (fun id -> (Lvar id, Strict)) paraml ; - default = [omegas,raise_num] - } in - try - let (lambda, total) = compile_match None partial - (start_ctx (List.length paraml)) pm in - check_total total lambda raise_num (partial_function loc) - with - | Unused -> partial_function loc () - - - -let flatten_pattern size p = match p.pat_desc with -| Tpat_tuple args -> args -| Tpat_any -> omegas size -| _ -> raise Cannot_flatten - -let rec flatten_pat_line size p k = match p.pat_desc with -| Tpat_any -> omegas size::k -| Tpat_tuple args -> args::k -| Tpat_or (p1,p2,_) -> flatten_pat_line size p1 (flatten_pat_line size p2 k) -| Tpat_alias (p,_,_) -> (* Note: if this 'as' pat is here, then this is a - useless binding, solves PR#3780 *) - flatten_pat_line size p k -| _ -> fatal_error "Matching.flatten_pat_line" - -let flatten_cases size cases = - List.map - (fun (ps,action) -> match ps with - | [p] -> flatten_pattern size p,action - | _ -> fatal_error "Matching.flatten_case") - cases - -let flatten_matrix size pss = - List.fold_right - (fun ps r -> match ps with - | [p] -> flatten_pat_line size p r - | _ -> fatal_error "Matching.flatten_matrix") - pss [] - -let flatten_def size def = - List.map - (fun (pss,i) -> flatten_matrix size pss,i) - def - -let flatten_pm size args pm = - {args = args ; cases = flatten_cases size pm.cases ; - default = flatten_def size pm.default} - - -let flatten_precompiled size args pmh = match pmh with -| Pm pm -> Pm (flatten_pm size args pm) -| PmOr {body=b ; handlers=hs ; or_matrix=m} -> - PmOr - {body=flatten_pm size args b ; - handlers= - List.map - (fun (mat,i,vars,pm) -> flatten_matrix size mat,i,vars,pm) - hs ; - or_matrix=flatten_matrix size m ;} -| PmVar _ -> assert false - -(* - compiled_flattened is a ``comp_fun'' argument to comp_match_handlers. - Hence it needs a fourth argument, which it ignores -*) - -let compile_flattened repr partial ctx _ pmh = match pmh with -| Pm pm -> compile_match repr partial ctx pm -| PmOr {body=b ; handlers=hs} -> - let lam, total = compile_match repr partial ctx b in - compile_orhandlers (compile_match repr partial) lam total ctx hs -| PmVar _ -> assert false - -let do_for_multiple_match loc paraml pat_act_list partial = - let repr = None in - let partial = check_partial pat_act_list partial in - let raise_num,pm1 = - match partial with - | Partial -> - let raise_num = next_raise_count () in - raise_num, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock( Blk_tuple), paraml, loc), Strict]; - default = [[[omega]],raise_num] } - | _ -> - -1, - { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [Lprim(Pmakeblock( Blk_tuple), paraml, loc), Strict]; - default = [] } in - - try - try -(* Once for checking that compilation is possible *) - let next, nexts = split_precompile None pm1 in - - let size = List.length paraml - and idl = List.map (fun _ -> Ident.create "match") paraml in - let args = List.map (fun id -> Lvar id, Alias) idl in - - let flat_next = flatten_precompiled size args next - and flat_nexts = - List.map - (fun (e,pm) -> e,flatten_precompiled size args pm) - nexts in - - let lam, total = - comp_match_handlers - (compile_flattened repr) - partial (start_ctx size) () flat_next flat_nexts in - List.fold_right2 (bind Strict) idl paraml - (match partial with - | Partial -> - check_total total lam raise_num (partial_function loc) - | Total -> - assert (jumps_is_empty total) ; - lam) - with Cannot_flatten -> - let (lambda, total) = compile_match None partial (start_ctx 1) pm1 in - begin match partial with - | Partial -> - check_total total lambda raise_num (partial_function loc) - | Total -> - assert (jumps_is_empty total) ; - lambda - end - with Unused -> - assert false (* ; partial_function loc () *) - -(* PR#4828: Believe it or not, the 'paraml' argument below - may not be side effect free. *) - -let param_to_var param = match param with -| Lvar v -> v,None -| _ -> Ident.create "match",Some param - -let bind_opt (v,eo) k = match eo with -| None -> k -| Some e -> Lambda.bind Strict v e k - -let for_multiple_match loc paraml pat_act_list partial = - let v_paraml = List.map param_to_var paraml in - let paraml = List.map (fun (v,_) -> Lvar v) v_paraml in - List.fold_right bind_opt v_paraml - (do_for_multiple_match loc paraml pat_act_list partial) diff --git a/jscomp/ml/matching.mli b/jscomp/ml/matching.mli deleted file mode 100644 index 16fda89..0000000 --- a/jscomp/ml/matching.mli +++ /dev/null @@ -1,73 +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. *) -(* *) -(**************************************************************************) - -(* Compilation of pattern-matching *) - -open Typedtree -open Lambda - -val call_switcher_variant_constant : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref - -val call_switcher_variant_constr : - (Location.t -> - Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Ast_untagged_variants.switch_names option -> - Lambda.lambda) - ref - -val make_test_sequence_variant_constant : - (Lambda.lambda option -> - Lambda.lambda -> - (int * (string * Lambda.lambda)) list -> - Lambda.lambda) - ref - -(* Entry points to match compiler *) -val for_function: - Location.t -> int ref option -> lambda -> (pattern * lambda) list -> - partial -> lambda -val for_trywith: - lambda -> (pattern * lambda) list -> lambda -val for_let: - Location.t -> lambda -> pattern -> lambda -> lambda -val for_multiple_match: - Location.t -> lambda list -> (pattern * lambda) list -> partial -> - lambda - -val for_tupled_function: - Location.t -> Ident.t list -> (pattern list * lambda) list -> - partial -> lambda - -exception Cannot_flatten - -val flatten_pattern: int -> pattern -> pattern list - -(* Expand stringswitch to string test tree *) -val expand_stringswitch: - Location.t -> lambda -> (string * lambda) list -> lambda option -> lambda - -val inline_lazy_force : lambda -> Location.t -> lambda - -(* To be set by Lam_compile *) -val names_from_construct_pattern : (pattern -> Ast_untagged_variants.switch_names option) ref diff --git a/jscomp/ml/mtype.ml b/jscomp/ml/mtype.ml deleted file mode 100644 index 74aaedd..0000000 --- a/jscomp/ml/mtype.ml +++ /dev/null @@ -1,420 +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. *) -(* *) -(**************************************************************************) - -(* Operations on module types *) - -open Asttypes -open Path -open Types - - -let rec scrape env mty = - match mty with - Mty_ident p -> - begin try - scrape env (Env.find_modtype_expansion p env) - with Not_found -> - mty - end - | _ -> mty - -let freshen mty = - Subst.modtype Subst.identity mty - -let rec strengthen ~aliasable env mty p = - match scrape env mty with - Mty_signature sg -> - Mty_signature(strengthen_sig ~aliasable env sg p 0) - | Mty_functor(param, arg, res) - when !Clflags.applicative_functors && Ident.name param <> "*" -> - Mty_functor(param, arg, - strengthen ~aliasable:false env res (Papply(p, Pident param))) - | mty -> - mty - -and strengthen_sig ~aliasable env sg p pos = - match sg with - [] -> [] - | (Sig_value(_, desc) as sigelt) :: rem -> - let nextpos = - match desc.val_kind with - | Val_prim _ -> pos - | _ -> pos + 1 - in - sigelt :: strengthen_sig ~aliasable env rem p nextpos - | Sig_type(id, {type_kind=Type_abstract}, _) :: - (Sig_type(id', {type_private=Private}, _) :: _ as rem) - when Ident.name id = Ident.name id' ^ "#row" -> - strengthen_sig ~aliasable env rem p pos - | Sig_type(id, decl, rs) :: rem -> - let newdecl = - match decl.type_manifest, decl.type_private, decl.type_kind with - Some _, Public, _ -> decl - | Some _, Private, (Type_record _ | Type_variant _) -> decl - | _ -> - let manif = - Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos), - decl.type_params, ref Mnil))) in - if decl.type_kind = Type_abstract then - { decl with type_private = Public; type_manifest = manif } - else - { decl with type_manifest = manif } - in - Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos - | (Sig_typext _ as sigelt) :: rem -> - sigelt :: strengthen_sig ~aliasable env rem p (pos+1) - | Sig_module(id, md, rs) :: rem -> - let str = - strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos)) - in - Sig_module(id, str, rs) - :: strengthen_sig ~aliasable - (Env.add_module_declaration ~check:false id md env) rem p (pos+1) - (* Need to add the module in case it defines manifest module types *) - | Sig_modtype(id, decl) :: rem -> - let newdecl = - match decl.mtd_type with - None -> - {decl with mtd_type = Some(Mty_ident(Pdot(p,Ident.name id,nopos)))} - | Some _ -> - decl - in - Sig_modtype(id, newdecl) :: - strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos - (* Need to add the module type in case it is manifest *) - | (Sig_class _ as sigelt) :: rem -> - sigelt :: strengthen_sig ~aliasable env rem p (pos+1) - | (Sig_class_type _ as sigelt) :: rem -> - sigelt :: strengthen_sig ~aliasable env rem p pos - -and strengthen_decl ~aliasable env md p = - match md.md_type with - | Mty_alias _ -> md - | _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)} - | mty -> {md with md_type = strengthen ~aliasable env mty p} - -let () = Env.strengthen := strengthen - -(* In nondep_supertype, env is only used for the type it assigns to id. - Hence there is no need to keep env up-to-date by adding the bindings - traversed. *) - -type variance = Co | Contra | Strict - -let nondep_supertype env mid mty = - - let rec nondep_mty env va mty = - match mty with - Mty_ident p -> - if Path.isfree mid p then - nondep_mty env va (Env.find_modtype_expansion p env) - else mty - | Mty_alias(_, p) -> - if Path.isfree mid p then - nondep_mty env va (Env.find_module p env).md_type - else mty - | Mty_signature sg -> - Mty_signature(nondep_sig env va sg) - | Mty_functor(param, arg, res) -> - let var_inv = - match va with Co -> Contra | Contra -> Co | Strict -> Strict in - Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg, - nondep_mty - (Env.add_module ~arg:true param - (Btype.default_mty arg) env) va res) - - and nondep_sig env va = function - [] -> [] - | item :: rem -> - let rem' = nondep_sig env va rem in - match item with - Sig_value(id, d) -> - Sig_value(id, - {d with val_type = Ctype.nondep_type env mid d.val_type}) - :: rem' - | Sig_type(id, d, rs) -> - Sig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs) - :: rem' - | Sig_typext(id, ext, es) -> - Sig_typext(id, Ctype.nondep_extension_constructor env mid ext, es) - :: rem' - | Sig_module(id, md, rs) -> - Sig_module(id, {md with md_type=nondep_mty env va md.md_type}, rs) - :: rem' - | Sig_modtype(id, d) -> - begin try - Sig_modtype(id, nondep_modtype_decl env d) :: rem' - with Not_found -> - match va with - Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none; - mtd_attributes=[]}) :: rem' - | _ -> raise Not_found - end - | Sig_class _ -> assert false - | Sig_class_type(id, d, rs) -> - Sig_class_type(id, Ctype.nondep_cltype_declaration env mid d, rs) - :: rem' - - and nondep_modtype_decl env mtd = - {mtd with mtd_type = Misc.may_map (nondep_mty env Strict) mtd.mtd_type} - - in - nondep_mty env Co mty - -let enrich_typedecl env p decl = - match decl.type_manifest with - Some _ -> decl - | None -> - try - let orig_decl = Env.find_type p env in - if orig_decl.type_arity <> decl.type_arity - then decl - else {decl with type_manifest = - Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))} - with Not_found -> - decl - -let rec enrich_modtype env p mty = - match mty with - Mty_signature sg -> - Mty_signature(List.map (enrich_item env p) sg) - | _ -> - mty - -and enrich_item env p = function - Sig_type(id, decl, rs) -> - Sig_type(id, - enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs) - | Sig_module(id, md, rs) -> - Sig_module(id, - {md with - md_type = enrich_modtype env - (Pdot(p, Ident.name id, nopos)) md.md_type}, - rs) - | item -> item - -let rec type_paths env p mty = - match scrape env mty with - Mty_ident _ -> [] - | Mty_alias _ -> [] - | Mty_signature sg -> type_paths_sig env p 0 sg - | Mty_functor _ -> [] - -and type_paths_sig env p pos sg = - match sg with - [] -> [] - | Sig_value(_id, decl) :: rem -> - let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in - type_paths_sig env p pos' rem - | Sig_type(id, _decl, _) :: rem -> - Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem - | Sig_module(id, md, _) :: rem -> - type_paths env (Pdot(p, Ident.name id, pos)) md.md_type @ - type_paths_sig (Env.add_module_declaration ~check:false id md env) - p (pos+1) rem - | Sig_modtype(id, decl) :: rem -> - type_paths_sig (Env.add_modtype id decl env) p pos rem - | (Sig_typext _ | Sig_class _) :: rem -> - type_paths_sig env p (pos+1) rem - | (Sig_class_type _) :: rem -> - type_paths_sig env p pos rem - -let rec no_code_needed env mty = - match scrape env mty with - Mty_ident _ -> false - | Mty_signature sg -> no_code_needed_sig env sg - | Mty_functor(_, _, _) -> false - | Mty_alias(Mta_absent, _) -> true - | Mty_alias(Mta_present, _) -> false - -and no_code_needed_sig env sg = - match sg with - [] -> true - | Sig_value(_id, decl) :: rem -> - begin match decl.val_kind with - | Val_prim _ -> no_code_needed_sig env rem - | _ -> false - end - | Sig_module(id, md, _) :: rem -> - no_code_needed env md.md_type && - no_code_needed_sig - (Env.add_module_declaration ~check:false id md env) rem - | (Sig_type _ | Sig_modtype _ | Sig_class_type _) :: rem -> - no_code_needed_sig env rem - | (Sig_typext _ | Sig_class _) :: _ -> - false - - -(* Check whether a module type may return types *) - -let rec contains_type env = function - Mty_ident path -> - begin try match (Env.find_modtype path env).mtd_type with - | None -> raise Exit (* PR#6427 *) - | Some mty -> contains_type env mty - with Not_found -> raise Exit - end - | Mty_signature sg -> - contains_type_sig env sg - | Mty_functor (_, _, body) -> - contains_type env body - | Mty_alias _ -> - () - -and contains_type_sig env = List.iter (contains_type_item env) - -and contains_type_item env = function - Sig_type (_,({type_manifest = None} | - {type_kind = Type_abstract; type_private = Private}),_) - | Sig_modtype _ - | Sig_typext (_, {ext_args = Cstr_record _}, _) -> - (* We consider that extension constructors with an inlined - record create a type (the inlined record), even though - it would be technically safe to ignore that considering - the current constraints which guarantee that this type - is kept local to expressions. *) - raise Exit - | Sig_module (_, {md_type = mty}, _) -> - contains_type env mty - | Sig_value _ - | Sig_type _ - | Sig_typext _ - | Sig_class _ - | Sig_class_type _ -> - () - -let contains_type env mty = - try contains_type env mty; false with Exit -> true - - -(* Remove module aliases from a signature *) - -module PathSet = Set.Make (Path) -module PathMap = Map.Make (Path) -module IdentSet = Set.Make (Ident) - -let rec get_prefixes = function - Pident _ -> PathSet.empty - | Pdot (p, _, _) - | Papply (p, _) -> PathSet.add p (get_prefixes p) - -let rec get_arg_paths = function - Pident _ -> PathSet.empty - | Pdot (p, _, _) -> get_arg_paths p - | Papply (p1, p2) -> - PathSet.add p2 - (PathSet.union (get_prefixes p2) - (PathSet.union (get_arg_paths p1) (get_arg_paths p2))) - -let rec rollback_path subst p = - try Pident (PathMap.find p subst) - with Not_found -> - match p with - Pident _ | Papply _ -> p - | Pdot (p1, s, n) -> - let p1' = rollback_path subst p1 in - if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n)) - -let rec collect_ids subst bindings p = - begin match rollback_path subst p with - Pident id -> - let ids = - try collect_ids subst bindings (Ident.find_same id bindings) - with Not_found -> IdentSet.empty - in - IdentSet.add id ids - | _ -> IdentSet.empty - end - -let collect_arg_paths mty = - let open Btype in - let paths = ref PathSet.empty - and subst = ref PathMap.empty - and bindings = ref Ident.empty in - (* let rt = Ident.create "Root" in - and prefix = ref (Path.Pident rt) in *) - let it_path p = paths := PathSet.union (get_arg_paths p) !paths - and it_signature_item it si = - type_iterators.it_signature_item it si; - match si with - Sig_module (id, {md_type=Mty_alias(_, p)}, _) -> - bindings := Ident.add id p !bindings - | Sig_module (id, {md_type=Mty_signature sg}, _) -> - List.iter - (function Sig_module (id', _, _) -> - subst := - PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst - | _ -> ()) - sg - | _ -> () - in - let it = {type_iterators with it_path; it_signature_item} in - it.it_module_type it mty; - it.it_module_type unmark_iterators mty; - PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p)) - !paths IdentSet.empty - -let rec remove_aliases env excl mty = - match mty with - Mty_signature sg -> - Mty_signature (remove_aliases_sig env excl sg) - | Mty_alias _ -> - let mty' = Env.scrape_alias env mty in - if mty' = mty then mty else (* nested polymorphic comparison *) - remove_aliases env excl mty' - | mty -> - mty - -and remove_aliases_sig env excl sg = - match sg with - [] -> [] - | Sig_module(id, md, rs) :: rem -> - let mty = - match md.md_type with - Mty_alias _ when IdentSet.mem id excl -> - md.md_type - | mty -> - remove_aliases env excl mty - in - Sig_module(id, {md with md_type = mty} , rs) :: - remove_aliases_sig (Env.add_module id mty env) excl rem - | Sig_modtype(id, mtd) :: rem -> - Sig_modtype(id, mtd) :: - remove_aliases_sig (Env.add_modtype id mtd env) excl rem - | it :: rem -> - it :: remove_aliases_sig env excl rem - -let remove_aliases env sg = - let excl = collect_arg_paths sg in - (* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl; - Format.eprintf "@."; *) - remove_aliases env excl sg - - -(* Lower non-generalizable type variables *) - -let lower_nongen nglev mty = - let open Btype in - let it_type_expr it ty = - let ty = repr ty in - match ty with - {desc=Tvar _; level} -> - if level < generic_level && level > nglev then set_level ty nglev - | _ -> - type_iterators.it_type_expr it ty - in - let it = {type_iterators with it_type_expr} in - it.it_module_type it mty; - it.it_module_type unmark_iterators mty diff --git a/jscomp/ml/mtype.mli b/jscomp/ml/mtype.mli deleted file mode 100644 index 84e870a..0000000 --- a/jscomp/ml/mtype.mli +++ /dev/null @@ -1,45 +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. *) -(* *) -(**************************************************************************) - -(* Operations on module types *) - -open Types - -val scrape: Env.t -> module_type -> module_type - (* Expand toplevel module type abbreviations - till hitting a "hard" module type (signature, functor, - or abstract module type ident. *) -val freshen: module_type -> module_type - (* Return an alpha-equivalent copy of the given module type - where bound identifiers are fresh. *) -val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type - (* Strengthen abstract type components relative to the - given path. *) -val strengthen_decl: - aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration -val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type - (* Return the smallest supertype of the given type - in which the given ident does not appear. - Raise [Not_found] if no such type exists. *) -val no_code_needed: Env.t -> module_type -> bool -val no_code_needed_sig: Env.t -> signature -> bool - (* Determine whether a module needs no implementation code, - i.e. consists only of type definitions. *) -val enrich_modtype: Env.t -> Path.t -> module_type -> module_type -val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration -val type_paths: Env.t -> Path.t -> module_type -> Path.t list -val contains_type: Env.t -> module_type -> bool -val remove_aliases: Env.t -> module_type -> module_type -val lower_nongen: int -> module_type -> unit diff --git a/jscomp/ml/oprint.ml b/jscomp/ml/oprint.ml deleted file mode 100644 index fb97c8b..0000000 --- a/jscomp/ml/oprint.ml +++ /dev/null @@ -1,776 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2002 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. *) -(* *) -(**************************************************************************) - -open Format -open Outcometree - -exception Ellipsis - -let cautious f ppf arg = - try f ppf arg with - Ellipsis -> fprintf ppf "..." - -let out_ident = ref pp_print_string -let map_primitive_name = ref (fun x -> x) - -let print_lident ppf = function - | "::" -> !out_ident ppf "(::)" - | s -> !out_ident ppf s - -let rec print_ident ppf = - function - Oide_ident s -> print_lident ppf s - | Oide_dot (id, s) -> - print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s - | Oide_apply (id1, id2) -> - fprintf ppf "%a(%a)" print_ident id1 print_ident id2 - -let parenthesized_ident name = - (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) - || - (match name.[0] with - 'a'..'z' | 'A'..'Z' | '\223'..'\246' | '\248'..'\255' | '_' -> - false - | _ -> true) - -let value_ident ppf name = - if parenthesized_ident name then - fprintf ppf "( %s )" name - else - pp_print_string ppf name - -(* Values *) - -let valid_float_lexeme s = - let l = String.length s in - let rec loop i = - if i >= l then s ^ "." else - match s.[i] with - | '0' .. '9' | '-' -> loop (i+1) - | _ -> s - in loop 0 - -let float_repres f = - match classify_float f with - FP_nan -> "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = float_of_string s1 then s1 else - let s2 = Printf.sprintf "%.15g" f in - if f = float_of_string s2 then s2 else - Printf.sprintf "%.18g" f - in valid_float_lexeme float_val - -let parenthesize_if_neg ppf fmt v isneg = - if isneg then pp_print_char ppf '('; - fprintf ppf fmt v; - if isneg then pp_print_char ppf ')' - -let escape_string s = - (* Escape only C0 control characters (bytes <= 0x1F), DEL(0x7F), '\\' and '"' *) - let n = ref 0 in - for i = 0 to String.length s - 1 do - n := !n + - (match String.unsafe_get s i with - | '\"' | '\\' | '\n' | '\t' | '\r' | '\b' -> 2 - | '\x00' .. '\x1F' - | '\x7F' -> 4 - | _ -> 1) - done; - if !n = String.length s then s else begin - let s' = Bytes.create !n in - n := 0; - for i = 0 to String.length s - 1 do - begin match String.unsafe_get s i with - | ('\"' | '\\') as c -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n c - | '\n' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'n' - | '\t' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 't' - | '\r' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'r' - | '\b' -> - Bytes.unsafe_set s' !n '\\'; incr n; Bytes.unsafe_set s' !n 'b' - | '\x00' .. '\x1F' | '\x7F' as c -> - let a = Char.code c in - Bytes.unsafe_set s' !n '\\'; - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + a / 100)); - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + (a / 10) mod 10)); - incr n; - Bytes.unsafe_set s' !n (Char.chr (48 + a mod 10)); - | c -> Bytes.unsafe_set s' !n c - end; - incr n - done; - Bytes.to_string s' - end - - -let print_out_string ppf s = - let not_escaped = - (* let the user dynamically choose if strings should be escaped: *) - match Sys.getenv_opt "OCAMLTOP_UTF_8" with - | None -> true - | Some x -> - match bool_of_string_opt x with - | None -> true - | Some f -> f in - if not_escaped then - fprintf ppf "\"%s\"" (escape_string s) - else - fprintf ppf "%S" s - -let print_out_value ppf tree = - let rec print_tree_1 ppf = - function - | Oval_constr (name, [param]) -> - fprintf ppf "@[<1>%a@ %a@]" print_ident name print_constr_param param - | Oval_constr (name, (_ :: _ as params)) -> - fprintf ppf "@[<1>%a@ (%a)@]" print_ident name - (print_tree_list print_tree_1 ",") params - | Oval_variant (name, Some param) -> - fprintf ppf "@[<2>`%s@ %a@]" name print_constr_param param - | tree -> print_simple_tree ppf tree - and print_constr_param ppf = function - | Oval_int i -> parenthesize_if_neg ppf "%i" i (i < 0) - | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i (i < 0l) - | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i (i < 0L) - | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i (i < 0n) - | Oval_float f -> parenthesize_if_neg ppf "%s" (float_repres f) (f < 0.0) - | Oval_string (_,_, Ostr_bytes) as tree -> - pp_print_char ppf '('; - print_simple_tree ppf tree; - pp_print_char ppf ')'; - | tree -> print_simple_tree ppf tree - and print_simple_tree ppf = - function - Oval_int i -> fprintf ppf "%i" i - | Oval_int32 i -> fprintf ppf "%lil" i - | Oval_int64 i -> fprintf ppf "%LiL" i - | Oval_nativeint i -> fprintf ppf "%nin" i - | Oval_float f -> pp_print_string ppf (float_repres f) - | Oval_char c -> fprintf ppf "%C" c - | Oval_string (s, maxlen, kind) -> - begin try - let len = String.length s in - let s = if len > maxlen then String.sub s 0 maxlen else s in - begin match kind with - | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s - | Ostr_string -> print_out_string ppf s - end; - (if len > maxlen then - fprintf ppf - "... (* string length %d; truncated *)" len - ) - with - Invalid_argument _ (* "String.create" *)-> fprintf ppf "" - end - | Oval_list tl -> - fprintf ppf "@[<1>[%a]@]" (print_tree_list print_tree_1 ";") tl - | Oval_array tl -> - fprintf ppf "@[<2>[|%a|]@]" (print_tree_list print_tree_1 ";") tl - | Oval_constr (name, []) -> print_ident ppf name - | Oval_variant (name, None) -> fprintf ppf "`%s" name - | Oval_stuff s -> pp_print_string ppf s - | Oval_record fel -> - fprintf ppf "@[<1>{%a}@]" (cautious (print_fields true)) fel - | Oval_ellipsis -> raise Ellipsis - | Oval_printer f -> f ppf - | Oval_tuple tree_list -> - fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list - | tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree - and print_fields first ppf = - function - [] -> () - | (name, tree) :: fields -> - if not first then fprintf ppf ";@ "; - fprintf ppf "@[<1>%a@ =@ %a@]" print_ident name (cautious print_tree_1) - tree; - print_fields false ppf fields - and print_tree_list print_item sep ppf tree_list = - let rec print_list first ppf = - function - [] -> () - | tree :: tree_list -> - if not first then fprintf ppf "%s@ " sep; - print_item ppf tree; - print_list false ppf tree_list - in - cautious (print_list true) ppf tree_list - in - cautious print_tree_1 ppf tree - -let out_value = ref print_out_value - -(* Types *) - -let rec print_list_init pr sep ppf = - function - [] -> () - | a :: l -> sep ppf; pr ppf a; print_list_init pr sep ppf l - -let rec print_list pr sep ppf = - function - [] -> () - | [a] -> pr ppf a - | a :: l -> pr ppf a; sep ppf; print_list pr sep ppf l - -let pr_present = - print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ") - -let pr_vars = - print_list (fun ppf s -> fprintf ppf "'%s" s) (fun ppf -> fprintf ppf "@ ") - -let rec print_out_type ppf = - function - | Otyp_alias (ty, s) -> - fprintf ppf "@[%a@ as '%s@]" print_out_type ty s - | Otyp_poly (sl, ty) -> - fprintf ppf "@[%a.@ %a@]" - pr_vars sl - print_out_type ty - | ty -> - print_out_type_1 ppf ty - -and print_out_type_1 ppf = - function - Otyp_arrow (lab, ty1, ty2) -> - pp_open_box ppf 0; - if lab <> "" then (pp_print_string ppf lab; pp_print_char ppf ':'); - print_out_type_2 ppf ty1; - pp_print_string ppf " ->"; - pp_print_space ppf (); - print_out_type_1 ppf ty2; - pp_close_box ppf () - | ty -> print_out_type_2 ppf ty -and print_out_type_2 ppf = - function - Otyp_tuple tyl -> - fprintf ppf "@[<0>%a@]" (print_typlist print_simple_out_type " *") tyl - | ty -> print_simple_out_type ppf ty -and print_simple_out_type ppf = - function - Otyp_class (ng, id, tyl) -> - fprintf ppf "@[%a%s#%a@]" print_typargs tyl (if ng then "_" else "") - print_ident id - | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), name ), - [tyl]) - -> - let res = - if name = "arity0" then - Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),tyl) - else tyl - in - fprintf ppf "@[<0>(%a@ [@bs])@]" print_out_type_1 res - | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Meth" ),name), - [tyl]) - -> - let res = - if name = "arity0" then - Otyp_arrow ("", Otyp_constr (Oide_ident "unit", []),tyl) - else tyl - in - fprintf ppf "@[<0>(%a@ [@bs.meth])@]" print_out_type_1 res - | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js_OO", "Callback" ), _), - [tyl]) - -> - fprintf ppf "@[<0>(%a@ [@bs.this])@]" print_out_type_1 tyl - | Otyp_constr (id, tyl) -> - pp_open_box ppf 0; - print_typargs ppf tyl; - print_ident ppf id; - pp_close_box ppf () - | Otyp_object (fields, rest) -> - fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields - | Otyp_stuff s -> pp_print_string ppf s - | Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s - | Otyp_variant (non_gen, row_fields, closed, tags) -> - let print_present ppf = - function - None | Some [] -> () - | Some l -> fprintf ppf "@;<1 -2>> @[%a@]" pr_present l - in - let print_fields ppf = - function - Ovar_fields fields -> - print_list print_row_field (fun ppf -> fprintf ppf "@;<1 -2>| ") - ppf fields - | Ovar_typ typ -> - print_simple_out_type ppf typ - in - fprintf ppf "%s[%s@[@[%a@]%a ]@]" (if non_gen then "_" else "") - (if closed then if tags = None then " " else "< " - else if tags = None then "> " else "? ") - print_fields row_fields - print_present tags - | Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty -> - pp_open_box ppf 1; - pp_print_char ppf '('; - print_out_type ppf ty; - pp_print_char ppf ')'; - pp_close_box ppf () - | Otyp_abstract | Otyp_open - | Otyp_sum _ | Otyp_manifest (_, _) -> () - | Otyp_record lbls -> print_record_decl ppf lbls - | Otyp_module (p, n, tyl) -> - fprintf ppf "@[<1>(module %s" p; - let first = ref true in - List.iter2 - (fun s t -> - let sep = if !first then (first := false; "with") else "and" in - fprintf ppf " %s type %s = %a" sep s print_out_type t - ) - n tyl; - fprintf ppf ")@]" - | Otyp_attribute (t, attr) -> - fprintf ppf "@[<1>(%a [@@%s])@]" print_out_type t attr.oattr_name -and print_record_decl ppf lbls = - fprintf ppf "{%a@;<1 -2>}" - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls -and print_fields rest ppf = - function - [] -> - begin match rest with - Some non_gen -> fprintf ppf "%s.." (if non_gen then "_" else "") - | None -> () - end - | [s, t] -> - fprintf ppf "%s : %a" s print_out_type t; - begin match rest with - Some _ -> fprintf ppf ";@ " - | None -> () - end; - print_fields rest ppf [] - | (s, t) :: l -> - fprintf ppf "%s : %a;@ %a" s print_out_type t (print_fields rest) l -and print_row_field ppf (l, opt_amp, tyl) = - let pr_of ppf = - if opt_amp then fprintf ppf " of@ &@ " - else if tyl <> [] then fprintf ppf " of@ " - else fprintf ppf "" - in - fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") - tyl -and print_typlist print_elem sep ppf = - function - [] -> () - | [ty] -> print_elem ppf ty - | ty :: tyl -> - print_elem ppf ty; - pp_print_string ppf sep; - pp_print_space ppf (); - print_typlist print_elem sep ppf tyl -and print_typargs ppf = - function - [] -> () - | [ty1] -> print_simple_out_type ppf ty1; pp_print_space ppf () - | tyl -> - pp_open_box ppf 1; - pp_print_char ppf '('; - print_typlist print_out_type "," ppf tyl; - pp_print_char ppf ')'; - pp_close_box ppf (); - pp_print_space ppf () -and print_out_label ppf (name, mut, opt, arg) = - fprintf ppf "@[<2>%s%s%s :@ %a@];" (if opt then "@optional " else "") (if mut then "mutable " else "") name - print_out_type arg - -let out_type = ref print_out_type - -(* Class types *) - -let type_parameter ppf (ty, (co, cn)) = - fprintf ppf "%s%s" - (if not cn then "+" else if not co then "-" else "") - (if ty = "_" then ty else "'"^ty) - -let print_out_class_params ppf = - function - [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " - (print_list type_parameter (fun ppf -> fprintf ppf ", ")) - tyl - -let rec print_out_class_type ppf = - function - Octy_constr (id, tyl) -> - let pr_tyl ppf = - function - [] -> () - | tyl -> - fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl - in - fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_arrow (lab, ty, cty) -> - fprintf ppf "@[%s%a ->@ %a@]" (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty - | Octy_signature (self_ty, csil) -> - let pr_param ppf = - function - Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty - | None -> () - in - fprintf ppf "@[@[<2>object%a@]@ %a@;<1 -2>end@]" pr_param self_ty - (print_list print_out_class_sig_item (fun ppf -> fprintf ppf "@ ")) - csil -and print_out_class_sig_item ppf = - function - Ocsg_constraint (ty1, ty2) -> - fprintf ppf "@[<2>constraint %a =@ %a@]" !out_type ty1 - !out_type ty2 - | Ocsg_method (name, priv, virt, ty) -> - fprintf ppf "@[<2>method %s%s%s :@ %a@]" - (if priv then "private " else "") (if virt then "virtual " else "") - name !out_type ty - | Ocsg_value (name, mut, vr, ty) -> - fprintf ppf "@[<2>val %s%s%s :@ %a@]" - (if mut then "mutable " else "") - (if vr then "virtual " else "") - name !out_type ty - -let out_class_type = ref print_out_class_type - -(* Signature *) - -let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") -let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") -let out_signature = ref (fun _ -> failwith "Oprint.out_signature") -let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") - -let rec print_out_functor funct ppf = - function - Omty_functor (_, None, mty_res) -> - if funct then fprintf ppf "() %a" (print_out_functor true) mty_res - else fprintf ppf "functor@ () %a" (print_out_functor true) mty_res - | Omty_functor (name, Some mty_arg, mty_res) -> begin - match name, funct with - | "_", true -> - fprintf ppf "->@ %a ->@ %a" - print_out_module_type mty_arg (print_out_functor false) mty_res - | "_", false -> - fprintf ppf "%a ->@ %a" - print_out_module_type mty_arg (print_out_functor false) mty_res - | name, true -> - fprintf ppf "(%s : %a) %a" name - print_out_module_type mty_arg (print_out_functor true) mty_res - | name, false -> - fprintf ppf "functor@ (%s : %a) %a" name - print_out_module_type mty_arg (print_out_functor true) mty_res - end - | m -> - if funct then fprintf ppf "->@ %a" print_out_module_type m - else print_out_module_type ppf m - -and print_out_module_type ppf = - function - Omty_abstract -> () - | Omty_functor _ as t -> - fprintf ppf "@[<2>%a@]" (print_out_functor false) t - | Omty_ident id -> fprintf ppf "%a" print_ident id - | Omty_signature sg -> - fprintf ppf "@[sig@ %a@;<1 -2>end@]" !out_signature sg - | Omty_alias id -> fprintf ppf "(module %a)" print_ident id -and print_out_signature ppf = - function - [] -> () - | [item] -> !out_sig_item ppf item - | Osig_typext(ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - Osig_typext(ext, Oext_next) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] - items - in - let te = - { otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - fprintf ppf "%a@ %a" !out_type_extension te print_out_signature items - | item :: items -> - fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items -and print_out_sig_item ppf = - function - Osig_class (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]" - (if rs = Orec_next then "and" else "class") - (if vir_flag then " virtual" else "") print_out_class_params params - name !out_class_type clt - | Osig_class_type (vir_flag, name, params, clt, rs) -> - fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]" - (if rs = Orec_next then "and" else "class type") - (if vir_flag then " virtual" else "") print_out_class_params params - name !out_class_type clt - | Osig_typext (ext, Oext_exception) -> - fprintf ppf "@[<2>exception %a@]" - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) - | Osig_typext (ext, _es) -> - print_out_extension_constructor ppf ext - | Osig_modtype (name, Omty_abstract) -> - fprintf ppf "@[<2>module type %s@]" name - | Osig_modtype (name, mty) -> - fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty - | Osig_module (name, Omty_alias id, _) -> - fprintf ppf "@[<2>module %s =@ %a@]" name print_ident id - | Osig_module (name, mty, rs) -> - fprintf ppf "@[<2>%s %s :@ %a@]" - (match rs with Orec_not -> "module" - | Orec_first -> "module rec" - | Orec_next -> "and") - name !out_module_type mty - | Osig_type(td, rs) -> - print_out_type_decl - (match rs with - | Orec_not -> "type nonrec" - | Orec_first -> "type" - | Orec_next -> "and") - ppf td - | Osig_value vd -> - let kwd = if vd.oval_prims = [] then "val" else "external" in - let pr_prims ppf = - function - [] -> () - | s :: sl -> - fprintf ppf "@ = \"%s\"" s; - List.iter (fun s -> -(* TODO: in general, we should print bs attributes, some attributes like - bs.splice does need it *) - fprintf ppf "@ \"%s\"" (!map_primitive_name s) - ) sl - in - fprintf ppf "@[<2>%s %a :@ %a%a%a@]" kwd value_ident vd.oval_name - !out_type vd.oval_type pr_prims vd.oval_prims - (fun ppf -> List.iter (fun a -> fprintf ppf "@ [@@@@%s]" a.oattr_name)) - vd.oval_attributes - | Osig_ellipsis -> - fprintf ppf "..." - -and print_out_type_decl kwd ppf td = - let print_constraints ppf = - List.iter - (fun (ty1, ty2) -> - fprintf ppf "@ @[<2>constraint %a =@ %a@]" !out_type ty1 - !out_type ty2) - td.otype_cstrs - in - let type_defined ppf = - match td.otype_params with - [] -> pp_print_string ppf td.otype_name - | [param] -> fprintf ppf "@[%a@ %s@]" type_parameter param td.otype_name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list type_parameter (fun ppf -> fprintf ppf ",@ ")) - td.otype_params - td.otype_name - in - let print_manifest ppf = - function - Otyp_manifest (ty, _) -> fprintf ppf " =@ %a" !out_type ty - | _ -> () - in - let print_name_params ppf = - fprintf ppf "%s %t%a" kwd type_defined print_manifest td.otype_type - in - let ty = - match td.otype_type with - Otyp_manifest (_, ty) -> ty - | _ -> td.otype_type - in - let print_private ppf = function - Asttypes.Private -> fprintf ppf " private" - | Asttypes.Public -> () - in - let print_immediate ppf = - if td.otype_immediate then fprintf ppf " [%@%@immediate]" else () - in - let print_unboxed ppf = - if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else () - in - let print_out_tkind ppf = function - | Otyp_abstract -> () - | Otyp_record lbls -> - fprintf ppf " =%a %a" - print_private td.otype_private - print_record_decl lbls - | Otyp_sum constrs -> - fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - | Otyp_open -> - fprintf ppf " =%a .." - print_private td.otype_private - | ty -> - fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private - !out_type ty - in - fprintf ppf "@[<2>@[%t%a@]%t%t%t@]" - print_name_params - print_out_tkind ty - print_constraints - print_immediate - print_unboxed - -and print_out_constr ppf (name, tyl, ret_type_opt, repr) = - let () = match repr with - | None -> () - | Some s -> pp_print_string ppf s in - let name = - match name with - | "::" -> "(::)" (* #7200 *) - | s -> s - in - match ret_type_opt with - | None -> - begin match tyl with - | [] -> - pp_print_string ppf name - | _ -> - fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl - end - | Some ret_type -> - begin match tyl with - | [] -> - fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type - | _ -> - fprintf ppf "@[<2>%s :@ %a -> %a@]" name - (print_typlist print_simple_out_type " *") - tyl print_simple_out_type ret_type - end - -and print_out_extension_constructor ppf ext = - let print_extended_type ppf = - let print_type_parameter ppf ty = - fprintf ppf "%s" - (if ty = "_" then ty else "'"^ty) - in - match ext.oext_type_params with - [] -> fprintf ppf "%s" ext.oext_type_name - | [ty_param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter - ty_param - ext.oext_type_name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) - ext.oext_type_params - ext.oext_type_name - in - fprintf ppf "@[type %t +=%s@;<1 2>%a@]" - print_extended_type - (if ext.oext_private = Asttypes.Private then " private" else "") - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) - -and print_out_type_extension ppf te = - let print_extended_type ppf = - let print_type_parameter ppf ty = - fprintf ppf "%s" - (if ty = "_" then ty else "'"^ty) - in - match te.otyext_params with - [] -> fprintf ppf "%s" te.otyext_name - | [param] -> - fprintf ppf "@[%a@ %s@]" - print_type_parameter param - te.otyext_name - | _ -> - fprintf ppf "@[(@[%a)@]@ %s@]" - (print_list print_type_parameter (fun ppf -> fprintf ppf ",@ ")) - te.otyext_params - te.otyext_name - in - fprintf ppf "@[type %t +=%s@;<1 2>%a@]" - print_extended_type - (if te.otyext_private = Asttypes.Private then " private" else "") - (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) - te.otyext_constructors - -let _ = out_module_type := print_out_module_type -let _ = out_signature := print_out_signature -let _ = out_sig_item := print_out_sig_item -let _ = out_type_extension := print_out_type_extension - -(* Phrases *) - -let print_out_exception ppf exn outv = - match exn with - Sys.Break -> fprintf ppf "Interrupted.@." - | Out_of_memory -> fprintf ppf "Out of memory during evaluation.@." - | Stack_overflow -> - fprintf ppf "Stack overflow during evaluation (looping recursion?).@." - | _ -> fprintf ppf "@[Exception:@ %a.@]@." !out_value outv - -let rec print_items ppf = - function - [] -> () - | (Osig_typext(ext, Oext_first), None) :: items -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - (Osig_typext(ext, Oext_next), None) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] - items - in - let te = - { otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - fprintf ppf "@[%a@]" !out_type_extension te; - if items <> [] then fprintf ppf "@ %a" print_items items - | (tree, valopt) :: items -> - begin match valopt with - Some v -> - fprintf ppf "@[<2>%a =@ %a@]" !out_sig_item tree - !out_value v - | None -> fprintf ppf "@[%a@]" !out_sig_item tree - end; - if items <> [] then fprintf ppf "@ %a" print_items items - -let print_out_phrase ppf = - function - Ophr_eval (outv, ty) -> - fprintf ppf "@[- : %a@ =@ %a@]@." !out_type ty !out_value outv - | Ophr_signature [] -> () - | Ophr_signature items -> fprintf ppf "@[%a@]@." print_items items - | Ophr_exception (exn, outv) -> print_out_exception ppf exn outv - -let out_phrase = ref print_out_phrase diff --git a/jscomp/ml/outcometree.ml b/jscomp/ml/outcometree.ml deleted file mode 100644 index 2bad441..0000000 --- a/jscomp/ml/outcometree.ml +++ /dev/null @@ -1,145 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 2001 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. *) -(* *) -(**************************************************************************) - -(* Module [Outcometree]: results displayed by the toplevel *) - -(* These types represent messages that the toplevel displays as normal - results or errors. The real displaying is customisable using the hooks: - [Toploop.print_out_value] - [Toploop.print_out_type] - [Toploop.print_out_sig_item] - [Toploop.print_out_phrase] *) - -type out_ident = - | Oide_apply of out_ident * out_ident - | Oide_dot of out_ident * string - | Oide_ident of string - -type out_string = - | Ostr_string - | Ostr_bytes - -type out_attribute = - { oattr_name: string } - -type out_value = - | Oval_array of out_value list - | Oval_char of char - | Oval_constr of out_ident * out_value list - | Oval_ellipsis - | Oval_float of float - | Oval_int of int - | Oval_int32 of int32 - | Oval_int64 of int64 - | Oval_nativeint of nativeint - | Oval_list of out_value list - | Oval_printer of (Format.formatter -> unit) - | Oval_record of (out_ident * out_value) list - | Oval_string of string * int * out_string (* string, size-to-print, kind *) - | Oval_stuff of string - | Oval_tuple of out_value list - | Oval_variant of string * out_value option - -type out_type = - | Otyp_abstract - | Otyp_open - | Otyp_alias of out_type * string - | Otyp_arrow of string * out_type * out_type - | Otyp_class of bool * out_ident * out_type list - | Otyp_constr of out_ident * out_type list - | Otyp_manifest of out_type * out_type - | Otyp_object of (string * out_type) list * bool option - | Otyp_record of (string * bool * bool * out_type) list - | Otyp_stuff of string - | Otyp_sum of (string * out_type list * out_type option * string option) list - | Otyp_tuple of out_type list - | Otyp_var of bool * string - | Otyp_variant of - bool * out_variant * bool * (string list) option - | Otyp_poly of string list * out_type - | Otyp_module of string * string list * out_type list - | Otyp_attribute of out_type * out_attribute - -and out_variant = - | Ovar_fields of (string * bool * out_type list) list - | Ovar_typ of out_type - -type out_class_type = - | Octy_constr of out_ident * out_type list - | Octy_arrow of string * out_type * out_class_type - | Octy_signature of out_type option * out_class_sig_item list -and out_class_sig_item = - | Ocsg_constraint of out_type * out_type - | Ocsg_method of string * bool * bool * out_type - | Ocsg_value of string * bool * bool * out_type - -type out_module_type = - | Omty_abstract - | Omty_functor of string * out_module_type option * out_module_type - | Omty_ident of out_ident - | Omty_signature of out_sig_item list - | Omty_alias of out_ident -and out_sig_item = - | Osig_class of - bool * string * (string * (bool * bool)) list * out_class_type * - out_rec_status - | Osig_class_type of - bool * string * (string * (bool * bool)) list * out_class_type * - out_rec_status - | Osig_typext of out_extension_constructor * out_ext_status - | Osig_modtype of string * out_module_type - | Osig_module of string * out_module_type * out_rec_status - | Osig_type of out_type_decl * out_rec_status - | Osig_value of out_val_decl - | Osig_ellipsis -and out_type_decl = - { otype_name: string; - otype_params: (string * (bool * bool)) list; - otype_type: out_type; - otype_private: Asttypes.private_flag; - otype_immediate: bool; - otype_unboxed: bool; - otype_cstrs: (out_type * out_type) list } -and out_extension_constructor = - { oext_name: string; - oext_type_name: string; - oext_type_params: string list; - oext_args: out_type list; - oext_ret_type: out_type option; - oext_repr: string option; - oext_private: Asttypes.private_flag } -and out_type_extension = - { otyext_name: string; - otyext_params: string list; - otyext_constructors: (string * out_type list * out_type option * string option) list; - otyext_private: Asttypes.private_flag } -and out_val_decl = - { oval_name: string; - oval_type: out_type; - oval_prims: string list; - oval_attributes: out_attribute list } -and out_rec_status = - | Orec_not - | Orec_first - | Orec_next -and out_ext_status = - | Oext_first - | Oext_next - | Oext_exception - -type out_phrase = - | Ophr_eval of out_value * out_type - | Ophr_signature of (out_sig_item * out_value option) list - | Ophr_exception of (exn * out_value) diff --git a/jscomp/ml/parmatch.ml b/jscomp/ml/parmatch.ml deleted file mode 100644 index 7c98883..0000000 --- a/jscomp/ml/parmatch.ml +++ /dev/null @@ -1,2620 +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. *) -(* *) -(**************************************************************************) - -(* Detection of partial matches and unused match cases. *) - -open Misc -open Asttypes -open Types -open Typedtree - -(*************************************) -(* Utilities for building patterns *) -(*************************************) - -let make_pat desc ty tenv = - {pat_desc = desc; pat_loc = Location.none; pat_extra = []; - pat_type = ty ; pat_env = tenv; - pat_attributes = []; - } - -let omega = make_pat Tpat_any Ctype.none Env.empty - -let extra_pat = - make_pat - (Tpat_var (Ident.create "+", mknoloc "+")) - Ctype.none Env.empty - -let rec omegas i = - if i <= 0 then [] else omega :: omegas (i-1) - -let omega_list l = List.map (fun _ -> omega) l - -let zero = make_pat (Tpat_constant (Const_int 0)) Ctype.none Env.empty - -(*******************) -(* Coherence check *) -(*******************) - -(* For some of the operations we do in this module, we would like (because it - simplifies matters) to assume that patterns appearing on a given column in a - pattern matrix are /coherent/ (think "of the same type"). - Unfortunately that is not always true. - - Consider the following (well-typed) example: - {[ - type _ t = S : string t | U : unit t - - let f (type a) (t1 : a t) (t2 : a t) (a : a) = - match t1, t2, a with - | U, _, () -> () - | _, S, "" -> () - ]} - - Clearly the 3rd column contains incoherent patterns. - - On the example above, most of the algorithms will explore the pattern matrix - as illustrated by the following tree: - - {v - S - -------> | "" | - U | S, "" | __/ | () | - --------> | _, () | \ ¬ S - | U, _, () | __/ -------> | () | - | _, S, "" | \ - ---------> | S, "" | ----------> | "" | - ¬ U S - v} - - where following an edge labelled by a pattern P means "assuming the value I - am matching on is filtered by [P] on the column I am currently looking at, - then the following submatrix is still reachable". - - Notice that at any point of that tree, if the first column of a matrix is - incoherent, then the branch leading to it can only be taken if the scrutinee - is ill-typed. - In the example above the only case where we have a matrix with an incoherent - first column is when we consider [t1, t2, a] to be [U, S, ...]. However such - a value would be ill-typed, so we can never actually get there. - - Checking the first column at each step of the recursion and making the - concious decision of "aborting" the algorithm whenever the first column - becomes incoherent, allows us to retain the initial assumption in later - stages of the algorithms. - - --- - - N.B. two patterns can be considered coherent even though they might not be of - the same type. - - That's in part because we only care about the "head" of patterns and leave - checking coherence of subpatterns for the next steps of the algorithm: - ('a', 'b') and (1, ()) will be deemed coherent because they are both a tuples - of arity 2 (we'll notice at a later stage the incoherence of 'a' and 1). - - But also because it can be hard/costly to determine exactly whether two - patterns are of the same type or not (eg. in the example above with _ and S, - but see also the module [Coherence_illustration] in - testsuite/tests/basic-more/robustmatch.ml). - - For the moment our weak, loosely-syntactic, coherence check seems to be - enough and we leave it to each user to consider (and document!) what happens - when an "incoherence" is not detected by this check. -*) - - -let simplify_head_pat p k = - let rec simplify_head_pat p k = - match p.pat_desc with - | Tpat_alias (p,_,_) -> simplify_head_pat p k - | Tpat_var (_,_) -> omega :: k - | Tpat_or (p1,p2,_) -> simplify_head_pat p1 (simplify_head_pat p2 k) - | _ -> p :: k - in simplify_head_pat p k - -let rec simplified_first_col = function - | [] -> [] - | [] :: _ -> assert false (* the rows are non-empty! *) - | (p::_) :: rows -> - simplify_head_pat p (simplified_first_col rows) - -(* Given the simplified first column of a matrix, this function first looks for - a "discriminating" pattern on that column (i.e. a non-omega one) and then - check that every other head pattern in the column is coherent with that one. -*) -let all_coherent column = - let coherent_heads hp1 hp2 = - match hp1.pat_desc, hp2.pat_desc with - | (Tpat_var _ | Tpat_alias _ | Tpat_or _), _ - | _, (Tpat_var _ | Tpat_alias _ | Tpat_or _) -> - assert false - | Tpat_construct (_, c, _), Tpat_construct (_, c', _) -> - c.cstr_consts = c'.cstr_consts - && c.cstr_nonconsts = c'.cstr_nonconsts - | Tpat_constant c1, Tpat_constant c2 -> begin - match c1, c2 with - | Const_char _, Const_char _ - | Const_int _, Const_int _ - | Const_int32 _, Const_int32 _ - | Const_int64 _, Const_int64 _ - | Const_bigint _, Const_bigint _ - | Const_float _, Const_float _ - | Const_string _, Const_string _ -> true - | ( Const_char _ - | Const_int _ - | Const_int32 _ - | Const_int64 _ - | Const_bigint _ - | Const_float _ - | Const_string _), _ -> false - end - | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 - | Tpat_record ((_, lbl1, _) :: _, _), Tpat_record ((_, lbl2, _) :: _, _) -> - Array.length lbl1.lbl_all = Array.length lbl2.lbl_all - | Tpat_any, _ - | _, Tpat_any - | Tpat_record ([], _), Tpat_record (_, _) - | Tpat_record (_, _), Tpat_record ([], _) - | Tpat_variant _, Tpat_variant _ - | Tpat_array _, Tpat_array _ - | Tpat_lazy _, Tpat_lazy _ -> true - | _, _ -> false - in - match - List.find (fun head_pat -> - match head_pat.pat_desc with - | Tpat_var _ | Tpat_alias _ | Tpat_or _ -> assert false - | Tpat_any -> false - | _ -> true - ) column - with - | exception Not_found -> - (* only omegas on the column: the column is coherent. *) - true - | discr_pat -> - List.for_all (coherent_heads discr_pat) column - -let first_column simplified_matrix = - List.map fst simplified_matrix - -(***********************) -(* Compatibility check *) -(***********************) - -(* Patterns p and q compatible means: - there exists value V that matches both, However.... - - The case of extension types is dubious, as constructor rebind permits - that different constructors are the same (and are thus compatible). - - Compilation must take this into account, consider: - - type t = .. - type t += A|B - type t += C=A - - let f x y = match x,y with - | true,A -> '1' - | _,C -> '2' - | false,A -> '3' - | _,_ -> '_' - - As C is bound to A the value of f false A is '2' (and not '3' as it would - be in the absence of rebinding). - - Not considering rebinding, patterns "false,A" and "_,C" are incompatible - and the compiler can swap the second and third clause, resulting in the - (more efficiently compiled) matching - - match x,y with - | true,A -> '1' - | false,A -> '3' - | _,C -> '2' - | _,_ -> '_' - - This is not correct: when C is bound to A, "f false A" returns '2' (not '3') - - - However, diagnostics do not take constructor rebinding into account. - Notice, that due to module abstraction constructor rebinding is hidden. - - module X : sig type t = .. type t += A|B end = struct - type t = .. - type t += A - type t += B=A - end - - open X - - let f x = match x with - | A -> '1' - | B -> '2' - | _ -> '_' - - The second clause above will NOT (and cannot) be flagged as useless. - - Finally, there are two compatibility fonction - compat p q ---> 'syntactic compatibility, used for diagnostics. - may_compat p q ---> a safe approximation of possible compat, - for compilation - -*) - - -let is_absent tag row = Btype.row_field tag !row = Rabsent - -let is_absent_pat p = match p.pat_desc with -| Tpat_variant (tag, _, row) -> is_absent tag row -| _ -> false - -let const_compare x y = - match x,y with - | Const_float f1, Const_float f2 -> - compare (float_of_string f1) (float_of_string f2) - | Const_bigint (s1, b1), Const_bigint (s2, b2) -> - Bigint_utils.compare (s1, b1) (s2, b2) - | Const_string (s1, _), Const_string (s2, _) -> - String.compare s1 s2 - | _, _ -> compare x y - -let records_args l1 l2 = - (* Invariant: fields are already sorted by Typecore.type_label_a_list *) - let rec combine r1 r2 l1 l2 = match l1,l2 with - | [],[] -> List.rev r1, List.rev r2 - | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2 - | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 [] - | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 -> - if lbl1.lbl_pos < lbl2.lbl_pos then - combine (p1::r1) (omega::r2) rem1 l2 - else if lbl1.lbl_pos > lbl2.lbl_pos then - combine (omega::r1) (p2::r2) l1 rem2 - else (* same label on both sides *) - combine (p1::r1) (p2::r2) rem1 rem2 in - combine [] [] l1 l2 - - - -module Compat - (Constr:sig - val equal : - Types.constructor_description -> - Types.constructor_description -> - bool - end) = struct - - let rec compat p q = match p.pat_desc,q.pat_desc with -(* Variables match any value *) - | ((Tpat_any|Tpat_var _),_) - | (_,(Tpat_any|Tpat_var _)) -> true -(* Structural induction *) - | Tpat_alias (p,_,_),_ -> compat p q - | _,Tpat_alias (q,_,_) -> compat p q - | Tpat_or (p1,p2,_),_ -> - (compat p1 q || compat p2 q) - | _,Tpat_or (q1,q2,_) -> - (compat p q1 || compat p q2) -(* Constructors, with special case for extension *) - | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) -> - Constr.equal c1 c2 && compats ps1 ps2 -(* More standard stuff *) - | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) -> - l1=l2 && ocompat op1 op2 - | Tpat_constant c1, Tpat_constant c2 -> - const_compare c1 c2 = 0 - | Tpat_tuple ps, Tpat_tuple qs -> compats ps qs - | Tpat_lazy p, Tpat_lazy q -> compat p q - | Tpat_record (l1,_),Tpat_record (l2,_) -> - let ps,qs = records_args l1 l2 in - compats ps qs - | Tpat_array ps, Tpat_array qs -> - List.length ps = List.length qs && - compats ps qs - | _,_ -> false - - and ocompat op oq = match op,oq with - | None,None -> true - | Some p,Some q -> compat p q - | (None,Some _)|(Some _,None) -> false - - and compats ps qs = match ps,qs with - | [], [] -> true - | p::ps, q::qs -> compat p q && compats ps qs - | _,_ -> false - -end - -module SyntacticCompat = - Compat - (struct - let equal c1 c2 = Types.equal_tag c1.cstr_tag c2.cstr_tag - end) - -let compat = SyntacticCompat.compat -and compats = SyntacticCompat.compats - -(* Due to (potential) rebinding, two extension constructors - of the same arity type may equal *) - -exception Empty (* Empty pattern *) - -(****************************************) -(* Utilities for retrieving type paths *) -(****************************************) - -(* May need a clean copy, cf. PR#4745 *) -let clean_copy ty = - if ty.level = Btype.generic_level then ty - else Subst.type_expr Subst.identity ty - -let get_type_path ty tenv = - let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in - match ty.desc with - | Tconstr (path,_,_) -> path - | _ -> fatal_error "Parmatch.get_type_path" - -(*************************************) -(* Values as patterns pretty printer *) -(*************************************) - -let print_res_pat: (Typedtree.pattern -> string) ref = - ref (fun _ -> assert false) - -open Format -;; - -let is_cons = function -| {cstr_name = "::"} -> true -| _ -> false - -let pretty_const c = match c with -| Const_int i -> Printf.sprintf "%d" i -| Const_char i -> Printf.sprintf "%s" (Pprintast.string_of_int_as_char i) -| Const_string (s, _) -> Printf.sprintf "%S" s -| Const_float f -> Printf.sprintf "%s" f -| Const_int32 i -> Printf.sprintf "%ldl" i -| Const_int64 i -> Printf.sprintf "%LdL" i -| Const_bigint (sign, i) -> Printf.sprintf "%s" (Bigint_utils.to_string sign i) - -let rec pretty_val ppf v = - match v.pat_extra with - (cstr, _loc, _attrs) :: rem -> - begin match cstr with - | Tpat_unpack -> - fprintf ppf "@[(module %a)@]" pretty_val { v with pat_extra = rem } - | Tpat_constraint _ -> - fprintf ppf "@[(%a : _)@]" pretty_val { v with pat_extra = rem } - | Tpat_type _ -> - fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } - | Tpat_open _ -> - fprintf ppf "@[(# %a)@]" pretty_val { v with pat_extra = rem } - end - | [] -> - match v.pat_desc with - | Tpat_any -> fprintf ppf "_" - | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x) - | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) - | Tpat_tuple vs -> - fprintf ppf "@[(%a)@]" (pretty_vals ",") vs - | Tpat_construct (_, cstr, []) -> - fprintf ppf "%s" cstr.cstr_name - | Tpat_construct (_, cstr, [w]) -> - fprintf ppf "@[<2>%s(%a)@]" cstr.cstr_name pretty_arg w - | Tpat_construct (_, cstr, vs) -> - let name = cstr.cstr_name in - begin match (name, vs) with - ("::", [v1;v2]) -> - fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 - | _ -> - fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs - end - | Tpat_variant (l, None, _) -> - fprintf ppf "#%s" l - | Tpat_variant (l, Some w, _) -> - fprintf ppf "@[<2>#%s(%a)@]" l pretty_arg w - | Tpat_record (lvs,_) -> - let filtered_lvs = Ext_list.filter lvs - (function - | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *) - | _ -> true) in - begin match filtered_lvs with - | [] -> fprintf ppf "_" - | (_, _lbl, _) :: _q -> - let elision_mark _ = () in - fprintf ppf "@[{%a%t}@]" - pretty_lvals filtered_lvs elision_mark - end - | Tpat_array vs -> - fprintf ppf "@[[%a]@]" (pretty_vals ",") vs - | Tpat_lazy v -> - fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v - | Tpat_alias (v, x,_) -> - fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x - | Tpat_or (v,w,_) -> - fprintf ppf "@[%a | @,%a@]" pretty_or v pretty_or w - -and pretty_car ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [_ ; _]) - when is_cons cstr -> - fprintf ppf "(%a)" pretty_val v -| _ -> pretty_val ppf v - -and pretty_cdr ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [v1 ; v2]) - when is_cons cstr -> - fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 -| _ -> pretty_val ppf v - -and pretty_arg ppf v = match v.pat_desc with -| Tpat_construct (_,_,_::_) -| Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v -| _ -> pretty_val ppf v - -and pretty_or ppf v = match v.pat_desc with -| Tpat_or (v,w,_) -> - fprintf ppf "%a | @,%a" pretty_or v pretty_or w -| _ -> pretty_val ppf v - -and pretty_vals sep ppf = function - | [] -> () - | [v] -> pretty_val ppf v - | v::vs -> - fprintf ppf "%a%s@ %a" pretty_val v sep (pretty_vals sep) vs - -and pretty_lvals ppf = function - | [] -> () - | [_,lbl,v] -> - fprintf ppf "%s: %a" lbl.lbl_name pretty_val v - | (_, lbl,v)::rest -> - fprintf ppf "%s: %a,@ %a" - lbl.lbl_name pretty_val v pretty_lvals rest - -let top_pretty ppf v = - fprintf ppf "@[%a@]@?" pretty_val v - - -let pretty_pat p = - top_pretty Format.str_formatter p ; - prerr_string (Format.flush_str_formatter ()) - -type matrix = pattern list list - -let pretty_line ps = - List.iter - (fun p -> - top_pretty Format.str_formatter p ; - prerr_string " <" ; - prerr_string (Format.flush_str_formatter ()) ; - prerr_string ">") - ps - -let pretty_matrix (pss : matrix) = - prerr_endline "begin matrix" ; - List.iter - (fun ps -> - pretty_line ps ; - prerr_endline "") - pss ; - prerr_endline "end matrix" - - -(****************************) -(* Utilities for matching *) -(****************************) - -(* Check top matching *) -let simple_match p1 p2 = - match p1.pat_desc, p2.pat_desc with - | Tpat_construct(_, c1, _), Tpat_construct(_, c2, _) -> - Types.equal_tag c1.cstr_tag c2.cstr_tag - | Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) -> - l1 = l2 - | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 - | Tpat_lazy _, Tpat_lazy _ -> true - | Tpat_record _ , Tpat_record _ -> true - | Tpat_tuple p1s, Tpat_tuple p2s - | Tpat_array p1s, Tpat_array p2s -> List.length p1s = List.length p2s - | _, (Tpat_any | Tpat_var(_)) -> true - | _, _ -> false - - - - -(* extract record fields as a whole *) -let record_arg p = match p.pat_desc with -| Tpat_any -> [] -| Tpat_record (args,_) -> args -| _ -> fatal_error "Parmatch.as_record" - - -(* Raise Not_found when pos is not present in arg *) -let get_field pos arg = - let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in - p - -let extract_fields omegas arg = - List.map - (fun (_,lbl,_) -> - try - get_field lbl.lbl_pos arg - with Not_found -> omega) - omegas - -let all_record_args lbls = match lbls with -| (_,{lbl_all=lbl_all},_)::_ -> - let t = - Array.map - (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega) - lbl_all in - List.iter - (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x) - lbls ; - Array.to_list t -| _ -> fatal_error "Parmatch.all_record_args" - - -(* Build argument list when p2 >= p1, where p1 is a simple pattern *) -let rec simple_match_args p1 p2 = match p2.pat_desc with -| Tpat_alias (p2,_,_) -> simple_match_args p1 p2 -| Tpat_construct(_, _, args) -> args -| Tpat_variant(_, Some arg, _) -> [arg] -| Tpat_tuple(args) -> args -| Tpat_record(args,_) -> extract_fields (record_arg p1) args -| Tpat_array(args) -> args -| Tpat_lazy arg -> [arg] -| (Tpat_any | Tpat_var(_)) -> - begin match p1.pat_desc with - Tpat_construct(_, _,args) -> omega_list args - | Tpat_variant(_, Some _, _) -> [omega] - | Tpat_tuple(args) -> omega_list args - | Tpat_record(args,_) -> omega_list args - | Tpat_array(args) -> omega_list args - | Tpat_lazy _ -> [omega] - | _ -> [] - end -| _ -> [] - -(* - Normalize a pattern -> - all arguments are omega (simple pattern) and no more variables -*) - -let rec normalize_pat q = match q.pat_desc with - | Tpat_any | Tpat_constant _ -> q - | Tpat_var _ -> make_pat Tpat_any q.pat_type q.pat_env - | Tpat_alias (p,_,_) -> normalize_pat p - | Tpat_tuple (args) -> - make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env - | Tpat_construct (lid, c,args) -> - make_pat - (Tpat_construct (lid, c,omega_list args)) - q.pat_type q.pat_env - | Tpat_variant (l, arg, row) -> - make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row)) - q.pat_type q.pat_env - | Tpat_array (args) -> - make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env - | Tpat_record (largs, closed) -> - make_pat - (Tpat_record (List.map (fun (lid,lbl,_) -> - lid, lbl,omega) largs, closed)) - q.pat_type q.pat_env - | Tpat_lazy _ -> - make_pat (Tpat_lazy omega) q.pat_type q.pat_env - | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" - -(* - Build normalized (cf. supra) discriminating pattern, - in the non-data type case -*) - -let discr_pat q pss = - - let rec acc_pat acc pss = match pss with - ({pat_desc = Tpat_alias (p,_,_)}::ps)::pss -> - acc_pat acc ((p::ps)::pss) - | ({pat_desc = Tpat_or (p1,p2,_)}::ps)::pss -> - acc_pat acc ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var _)}::_)::pss -> - acc_pat acc pss - | (({pat_desc = Tpat_tuple _} as p)::_)::_ -> normalize_pat p - | (({pat_desc = Tpat_lazy _} as p)::_)::_ -> normalize_pat p - | (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss -> - let new_omegas = - List.fold_right - (fun (lid, lbl,_) r -> - try - let _ = get_field lbl.lbl_pos r in - r - with Not_found -> - (lid, lbl,omega)::r) - largs (record_arg acc) - in - acc_pat - (make_pat (Tpat_record (new_omegas, closed)) p.pat_type p.pat_env) - pss - | _ -> acc in - - match normalize_pat q with - | {pat_desc= (Tpat_any | Tpat_record _)} as q -> acc_pat q pss - | q -> q - -(* - In case a matching value is found, set actual arguments - of the matching pattern. -*) - -let rec read_args xs r = match xs,r with -| [],_ -> [],r -| _::xs, arg::rest -> - let args,rest = read_args xs rest in - arg::args,rest -| _,_ -> - fatal_error "Parmatch.read_args" - -let do_set_args erase_mutable q r = match q with -| {pat_desc = Tpat_tuple omegas} -> - let args,rest = read_args omegas r in - make_pat (Tpat_tuple args) q.pat_type q.pat_env::rest -| {pat_desc = Tpat_record (omegas,closed)} -> - let args,rest = read_args omegas r in - make_pat - (Tpat_record - (List.map2 (fun (lid, lbl,_) arg -> - if - erase_mutable && - (match lbl.lbl_mut with - | Mutable -> true | Immutable -> false) - then - lid, lbl, omega - else - lid, lbl, arg) - omegas args, closed)) - q.pat_type q.pat_env:: - rest -| {pat_desc = Tpat_construct (lid, c,omegas)} -> - let args,rest = read_args omegas r in - make_pat - (Tpat_construct (lid, c,args)) - q.pat_type q.pat_env:: - rest -| {pat_desc = Tpat_variant (l, omega, row)} -> - let arg, rest = - match omega, r with - Some _, a::r -> Some a, r - | None, r -> None, r - | _ -> assert false - in - make_pat - (Tpat_variant (l, arg, row)) q.pat_type q.pat_env:: - rest -| {pat_desc = Tpat_lazy _omega} -> - begin match r with - arg::rest -> - make_pat (Tpat_lazy arg) q.pat_type q.pat_env::rest - | _ -> fatal_error "Parmatch.do_set_args (lazy)" - end -| {pat_desc = Tpat_array omegas} -> - let args,rest = read_args omegas r in - make_pat - (Tpat_array args) q.pat_type q.pat_env:: - rest -| {pat_desc=Tpat_constant _|Tpat_any} -> - q::r (* case any is used in matching.ml *) -| _ -> fatal_error "Parmatch.set_args" - -let set_args q r = do_set_args false q r -and set_args_erase_mutable q r = do_set_args true q r - -(* filter pss according to pattern q *) -let filter_one q pss = - let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_rec ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_rec ((p1::ps)::(p2::ps)::pss) - | (p::ps)::pss -> - if simple_match q p - then (simple_match_args q p @ ps) :: filter_rec pss - else filter_rec pss - | _ -> [] in - filter_rec pss - -(* - Filter pss in the ``extra case''. This applies : - - According to an extra constructor (datatype case, non-complete signature). - - According to anything (all-variables case). -*) -let filter_extra pss = - let rec filter_rec = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_rec ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_rec ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))} :: qs) :: pss -> - qs :: filter_rec pss - | _::pss -> filter_rec pss - | [] -> [] in - filter_rec pss - -(* - Pattern p0 is the discriminating pattern, - returns [(q0,pss0) ; ... ; (qn,pssn)] - where the qi's are simple patterns and the pssi's are - matched matrices. - - NOTES - * (qi,[]) is impossible. - * In the case when matching is useless (all-variable case), - returns [] -*) - -let filter_all pat0 pss = - - let rec insert q qs env = - match env with - [] -> - let q0 = normalize_pat q in - [q0, [simple_match_args q0 q @ qs]] - | ((q0,pss) as c)::env -> - if simple_match q0 q - then (q0, ((simple_match_args q0 q @ qs) :: pss)) :: env - else c :: insert q qs env in - - let rec filter_rec env = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_rec env ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_rec env ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))}::_)::pss -> - filter_rec env pss - | (p::ps)::pss -> - filter_rec (insert p ps env) pss - | _ -> env - - and filter_omega env = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - filter_omega env ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - filter_omega env ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))}::ps)::pss -> - filter_omega - (List.map (fun (q,qss) -> (q,(simple_match_args q omega @ ps) :: qss)) - env) - pss - | _::pss -> filter_omega env pss - | [] -> env in - - filter_omega - (filter_rec - (match pat0.pat_desc with - (Tpat_record(_) | Tpat_tuple(_) | Tpat_lazy(_)) -> [pat0,[]] - | _ -> []) - pss) - pss - -(* Variant related functions *) - -let rec set_last a = function - [] -> [] - | [_] -> [a] - | x::l -> x :: set_last a l - -(* mark constructor lines for failure when they are incomplete *) -let rec mark_partial = function - ({pat_desc = Tpat_alias(p,_,_)}::ps)::pss -> - mark_partial ((p::ps)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps)::pss -> - mark_partial ((p1::ps)::(p2::ps)::pss) - | ({pat_desc = (Tpat_any | Tpat_var(_))} :: _ as ps) :: pss -> - ps :: mark_partial pss - | ps::pss -> - (set_last zero ps) :: mark_partial pss - | [] -> [] - -let close_variant env row = - let row = Btype.row_repr row in - let nm = - List.fold_left - (fun nm (_tag,f) -> - match Btype.row_field_repr f with - | Reither(_, _, false, e) -> - (* m=false means that this tag is not explicitly matched *) - Btype.set_row_field e Rabsent; - None - | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) - row.row_name row.row_fields in - if not row.row_closed || nm != row.row_name then begin - (* this unification cannot fail *) - Ctype.unify env row.row_more - (Btype.newgenty - (Tvariant {row with row_fields = []; row_more = Btype.newgenvar(); - row_closed = true; row_name = nm})) - end - -let row_of_pat pat = - match Ctype.expand_head pat.pat_env pat.pat_type with - {desc = Tvariant row} -> Btype.row_repr row - | _ -> assert false - -(* - Check whether the first column of env makes up a complete signature or - not. -*) - -let full_match closing env = match env with -| ({pat_desc = Tpat_construct(_,c,_)},_) :: _ -> - if c.cstr_consts < 0 then false (* extensions *) - else List.length env = c.cstr_consts + c.cstr_nonconsts -| ({pat_desc = Tpat_variant _} as p,_) :: _ -> - let fields = - List.map - (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag - | _ -> assert false) - env - in - let row = row_of_pat p in - if closing && not (Btype.row_fixed row) then - (* closing=true, we are considering the variant as closed *) - List.for_all - (fun (tag,f) -> - match Btype.row_field_repr f with - Rabsent | Reither(_, _, false, _) -> true - | Reither (_, _, true, _) - (* m=true, do not discard matched tags, rather warn *) - | Rpresent _ -> List.mem tag fields) - row.row_fields - else - row.row_closed && - List.for_all - (fun (tag,f) -> - Btype.row_field_repr f = Rabsent || List.mem tag fields) - row.row_fields -| ({pat_desc = Tpat_constant(_)},_) :: _ -> false -| ({pat_desc = Tpat_tuple(_)},_) :: _ -> true -| ({pat_desc = Tpat_record(_)},_) :: _ -> true -| ({pat_desc = Tpat_array(_)},_) :: _ -> false -| ({pat_desc = Tpat_lazy(_)},_) :: _ -> true -| ({pat_desc = (Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _)},_) :: _ -| [] - -> - assert false - -(* Written as a non-fragile matching, PR#7451 originated from a fragile matching below. *) -let should_extend ext env = match ext with -| None -> false -| Some ext -> begin match env with - | [] -> assert false - | (p,_)::_ -> - begin match p.pat_desc with - | Tpat_construct - (_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},_) -> - let path = get_type_path p.pat_type p.pat_env in - Path.same path ext - | Tpat_construct - (_, {cstr_tag=(Cstr_extension _)},_) -> false - | Tpat_constant _|Tpat_tuple _|Tpat_variant _ - | Tpat_record _|Tpat_array _ | Tpat_lazy _ - -> false - | Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _ - -> assert false - end -end - -module ConstructorTagHashtbl = Hashtbl.Make( - struct - type t = Types.constructor_tag - let hash = Hashtbl.hash - let equal = Types.equal_tag - end -) - -(* complement constructor tags *) -let complete_tags nconsts nconstrs tags = - let seen_const = Array.make nconsts false - and seen_constr = Array.make nconstrs false in - List.iter - (function - | Cstr_constant i -> seen_const.(i) <- true - | Cstr_block i -> seen_constr.(i) <- true - | _ -> assert false) - tags ; - let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in - for i = 0 to nconsts-1 do - if not seen_const.(i) then - ConstructorTagHashtbl.add r (Cstr_constant i) () - done ; - for i = 0 to nconstrs-1 do - if not seen_constr.(i) then - ConstructorTagHashtbl.add r (Cstr_block i) () - done ; - r - -(* build a pattern from a constructor list *) -let pat_of_constr ex_pat cstr = - {ex_pat with pat_desc = - Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"), - cstr, omegas cstr.cstr_arity)} - -let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_env - -let rec orify_many = function -| [] -> assert false -| [x] -> x -| x :: xs -> orify x (orify_many xs) - -let pat_of_constrs ex_pat cstrs = - if cstrs = [] then raise Empty else - orify_many (List.map (pat_of_constr ex_pat) cstrs) - -let pats_of_type ?(always=false) env ty = - let ty' = Ctype.expand_head env ty in - match ty'.desc with - | Tconstr (path, _, _) -> - begin try match (Env.find_type path env).type_kind with - | Type_variant cl when always || List.length cl = 1 || - List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> - let cstrs = fst (Env.find_type_descrs path env) in - List.map (pat_of_constr (make_pat Tpat_any ty env)) cstrs - | Type_record _ -> - let labels = snd (Env.find_type_descrs path env) in - let fields = - List.map (fun ld -> - mknoloc (Longident.Lident "?pat_of_label?"), ld, omega) - labels - in - [make_pat (Tpat_record (fields, Closed)) ty env] - | _ -> [omega] - with Not_found -> [omega] - end - | Ttuple tl -> - [make_pat (Tpat_tuple (omegas (List.length tl))) ty env] - | _ -> [omega] - -let rec get_variant_constructors env ty = - match (Ctype.repr ty).desc with - | Tconstr (path,_,_) -> begin - try match Env.find_type path env with - | {type_kind=Type_variant _} -> - fst (Env.find_type_descrs path env) - | {type_manifest = Some _} -> - get_variant_constructors env - (Ctype.expand_head_once env (clean_copy ty)) - | _ -> fatal_error "Parmatch.get_variant_constructors" - with Not_found -> - fatal_error "Parmatch.get_variant_constructors" - end - | _ -> fatal_error "Parmatch.get_variant_constructors" - -(* Sends back a pattern that complements constructor tags all_tag *) -let complete_constrs p all_tags = - let c = - match p.pat_desc with Tpat_construct (_, c, _) -> c | _ -> assert false in - let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in - let constrs = get_variant_constructors p.pat_env c.cstr_res in - let others = - Ext_list.filter constrs - (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) - in - let const, nonconst = - List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in - const @ nonconst - -let build_other_constrs env p = - match p.pat_desc with - Tpat_construct (_, {cstr_tag=Cstr_constant _|Cstr_block _}, _) -> - let get_tag = function - | {pat_desc = Tpat_construct (_,c,_)} -> c.cstr_tag - | _ -> fatal_error "Parmatch.get_tag" in - let all_tags = List.map (fun (p,_) -> get_tag p) env in - pat_of_constrs p (complete_constrs p all_tags) - | _ -> extra_pat - -(* Auxiliary for build_other *) - -let build_other_constant proj make first next p env = - let all = List.map (fun (p, _) -> proj p.pat_desc) env in - let rec try_const i = - if List.mem i all - then try_const (next i) - else make_pat (make i) p.pat_type p.pat_env - in try_const first - -(* - Builds a pattern that is incompatible with all patterns in - in the first column of env -*) - -let some_other_tag = "" - -let build_other ext env : Typedtree.pattern = match env with -| ({pat_desc = Tpat_construct (lid, {cstr_tag=Cstr_extension _},_)},_) :: _ -> - (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *) - make_pat (Tpat_var (Ident.create "*extension*", - {lid with txt="*extension*"})) Ctype.none Env.empty -| ({pat_desc = Tpat_construct _} as p,_) :: _ -> - begin match ext with - | Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) -> - extra_pat - | _ -> - build_other_constrs env p - end -| ({pat_desc = Tpat_variant (_,_,r)} as p,_) :: _ -> - let tags = - List.map - (function ({pat_desc = Tpat_variant (tag, _, _)}, _) -> tag - | _ -> assert false) - env - in - let row = row_of_pat p in - let make_other_pat tag const = - let arg = if const then None else Some omega in - make_pat (Tpat_variant(tag, arg, r)) p.pat_type p.pat_env in - begin match - List.fold_left - (fun others (tag,f) -> - if List.mem tag tags then others else - match Btype.row_field_repr f with - Rabsent (* | Reither _ *) -> others - (* This one is called after erasing pattern info *) - | Reither (c, _, _, _) -> make_other_pat tag c :: others - | Rpresent arg -> make_other_pat tag (arg = None) :: others) - [] row.row_fields - with - [] -> - make_other_pat some_other_tag true - | pat::other_pats -> - List.fold_left - (fun p_res pat -> - make_pat (Tpat_or (pat, p_res, None)) p.pat_type p.pat_env) - pat other_pats - end -| ({pat_desc=(Tpat_constant (Const_int _ ))} as p,_) :: _ -> - build_other_constant - (function Tpat_constant(Const_int i) -> i - | _ -> assert false) - (function i -> Tpat_constant(Const_int i)) - 0 succ p env -| ({pat_desc=(Tpat_constant (Const_char _ ))} as p,_) :: _ -> - build_other_constant - (function - | Tpat_constant (Const_char i) -> i - | _ -> assert false) - (function i -> Tpat_constant(Const_char i)) - 0 succ p env -| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ -> - build_other_constant - (function Tpat_constant(Const_int32 i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_int32 i)) - 0l Int32.succ p env -| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ -> - build_other_constant - (function Tpat_constant(Const_int64 i) -> i | _ -> assert false) - (function i -> Tpat_constant(Const_int64 i)) - 0L Int64.succ p env -| ({pat_desc=(Tpat_constant (Const_bigint _))} as p,_) :: _ -> - build_other_constant - (function Tpat_constant(Const_bigint (sign, i)) -> String.length (Bigint_utils.to_string sign i) | _ -> assert false) - (function i -> Tpat_constant(Const_bigint (true, (string_of_int i)))) - 0 succ p env -| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ -> - build_other_constant - (function Tpat_constant(Const_string (s, _)) -> String.length s - | _ -> assert false) - (function i -> Tpat_constant(Const_string(String.make i '*', None))) - 0 succ p env -| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ -> - build_other_constant - (function Tpat_constant(Const_float f) -> float_of_string f - | _ -> assert false) - (function f -> Tpat_constant(Const_float (string_of_float f))) - 0.0 (fun f -> f +. 1.0) p env - -| ({pat_desc = Tpat_array _} as p,_)::_ -> - let all_lengths = - List.map - (fun (p,_) -> match p.pat_desc with - | Tpat_array args -> List.length args - | _ -> assert false) - env in - let rec try_arrays l = - if List.mem l all_lengths then try_arrays (l+1) - else - make_pat - (Tpat_array (omegas l)) - p.pat_type p.pat_env in - try_arrays 0 -| [] -> omega -| _ -> omega - -(* - Core function : - Is the last row of pattern matrix pss + qs satisfiable ? - That is : - Does there exists at least one value vector, es such that : - 1- for all ps in pss ps # es (ps and es are not compatible) - 2- qs <= es (es matches qs) -*) - -let rec has_instance p = match p.pat_desc with - | Tpat_variant (l,_,r) when is_absent l r -> false - | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true - | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p - | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 - | Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps -> - has_instances ps - | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) - | Tpat_lazy p - -> has_instance p - - -and has_instances = function - | [] -> true - | q::rem -> has_instance q && has_instances rem - -(* - In two places in the following function, we check the coherence of the first - column of (pss + qs). - If it is incoherent, then we exit early saying that (pss + qs) is not - satisfiable (which is equivalent to saying "oh, we shouldn't have considered - that branch, no good result came come from here"). - - But what happens if we have a coherent but ill-typed column? - - we might end up returning [false], which is equivalent to noticing the - incompatibility: clearly this is fine. - - if we end up returning [true] then we're saying that [qs] is useful while - it is not. This is sad but not the end of the world, we're just allowing dead - code to survive. -*) -let rec satisfiable pss qs = match pss with -| [] -> has_instances qs -| _ -> - match qs with - | [] -> false - | {pat_desc = Tpat_or(q1,q2,_)}::qs -> - satisfiable pss (q1::qs) || satisfiable pss (q2::qs) - | {pat_desc = Tpat_alias(q,_,_)}::qs -> - satisfiable pss (q::qs) - | {pat_desc = (Tpat_any | Tpat_var(_))}::qs -> - if not (all_coherent (simplified_first_col pss)) then - false - else begin - let q0 = discr_pat omega pss in - match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> satisfiable (filter_extra pss) qs - | constrs -> - if full_match false constrs then - List.exists - (fun (p,pss) -> - not (is_absent_pat p) && - satisfiable pss (simple_match_args p omega @ qs)) - constrs - else - satisfiable (filter_extra pss) qs - end - | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false - | q::qs -> - if not (all_coherent (q :: simplified_first_col pss)) then - false - else begin - let q0 = discr_pat q pss in - satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs) - end - -(* Also return the remaining cases, to enable GADT handling - - For considerations regarding the coherence check, see the comment on - [satisfiable] above. *) -let rec satisfiables pss qs = match pss with -| [] -> if has_instances qs then [qs] else [] -| _ -> - match qs with - | [] -> [] - | {pat_desc = Tpat_or(q1,q2,_)}::qs -> - satisfiables pss (q1::qs) @ satisfiables pss (q2::qs) - | {pat_desc = Tpat_alias(q,_,_)}::qs -> - satisfiables pss (q::qs) - | {pat_desc = (Tpat_any | Tpat_var(_))}::qs -> - if not (all_coherent (simplified_first_col pss)) then - [] - else begin - let q0 = discr_pat omega pss in - let wild p = - List.map (fun qs -> p::qs) (satisfiables (filter_extra pss) qs) in - match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> - wild omega - | (p,_)::_ as constrs -> - let for_constrs () = - List.flatten ( - List.map - (fun (p,pss) -> - if is_absent_pat p then [] else - List.map (set_args p) - (satisfiables pss (simple_match_args p omega @ qs))) - constrs ) - in - if full_match false constrs then for_constrs () else - match p.pat_desc with - Tpat_construct _ -> - (* activate this code for checking non-gadt constructors *) - wild (build_other_constrs constrs p) @ for_constrs () - | _ -> - wild omega - end - | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> [] - | q::qs -> - if not (all_coherent (q :: simplified_first_col pss)) then - [] - else begin - let q0 = discr_pat q pss in - List.map (set_args q0) - (satisfiables (filter_one q0 pss) (simple_match_args q0 q @ qs)) - end - -(* - Now another satisfiable function that additionally - supplies an example of a matching value. - - This function should be called for exhaustiveness check only. -*) - -type 'a result = - | Rnone (* No matching value *) - | Rsome of 'a (* This matching value *) - -(* -let rec try_many f = function - | [] -> Rnone - | (p,pss)::rest -> - match f (p,pss) with - | Rnone -> try_many f rest - | r -> r -*) - -let rappend r1 r2 = - match r1, r2 with - | Rnone, _ -> r2 - | _, Rnone -> r1 - | Rsome l1, Rsome l2 -> Rsome (l1 @ l2) - -let rec try_many_gadt f = function - | [] -> Rnone - | (p,pss)::rest -> - rappend (f (p, pss)) (try_many_gadt f rest) - -(* -let rec exhaust ext pss n = match pss with -| [] -> Rsome (omegas n) -| []::_ -> Rnone -| pss -> - let q0 = discr_pat omega pss in - begin match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> - begin match exhaust ext (filter_extra pss) (n-1) with - | Rsome r -> Rsome (q0::r) - | r -> r - end - | constrs -> - let try_non_omega (p,pss) = - if is_absent_pat p then - Rnone - else - match - exhaust - ext pss (List.length (simple_match_args p omega) + n - 1) - with - | Rsome r -> Rsome (set_args p r) - | r -> r in - if - full_match true false constrs && not (should_extend ext constrs) - then - try_many try_non_omega constrs - else - (* - D = filter_extra pss is the default matrix - as it is included in pss, one can avoid - recursive calls on specialized matrices, - Essentially : - * D exhaustive => pss exhaustive - * D non-exhaustive => we have a non-filtered value - *) - let r = exhaust ext (filter_extra pss) (n-1) in - match r with - | Rnone -> Rnone - | Rsome r -> - try - Rsome (build_other ext constrs::r) - with - (* cannot occur, since constructors don't make a full signature *) - | Empty -> fatal_error "Parmatch.exhaust" - end - -let combinations f lst lst' = - let rec iter2 x = - function - [] -> [] - | y :: ys -> - f x y :: iter2 x ys - in - let rec iter = - function - [] -> [] - | x :: xs -> iter2 x lst' @ iter xs - in - iter lst -*) -(* -let print_pat pat = - let rec string_of_pat pat = - match pat.pat_desc with - Tpat_var _ -> "v" - | Tpat_any -> "_" - | Tpat_alias (p, x) -> Printf.sprintf "(%s) as ?" (string_of_pat p) - | Tpat_constant n -> "0" - | Tpat_construct (_, lid, _) -> - Printf.sprintf "%s" (String.concat "." (Longident.flatten lid.txt)) - | Tpat_lazy p -> - Printf.sprintf "(lazy %s)" (string_of_pat p) - | Tpat_or (p1,p2,_) -> - Printf.sprintf "(%s | %s)" (string_of_pat p1) (string_of_pat p2) - | Tpat_tuple list -> - Printf.sprintf "(%s)" (String.concat "," (List.map string_of_pat list)) - | Tpat_variant (_, _, _) -> "variant" - | Tpat_record (_, _) -> "record" - | Tpat_array _ -> "array" - in - Printf.fprintf stderr "PAT[%s]\n%!" (string_of_pat pat) -*) - -(* strictly more powerful than exhaust; however, exhaust - was kept for backwards compatibility *) -let rec exhaust_gadt (ext:Path.t option) pss n = match pss with -| [] -> Rsome [omegas n] -| []::_ -> Rnone -| pss -> - if not (all_coherent (simplified_first_col pss)) then - (* We're considering an ill-typed branch, we won't actually be able to - produce a well typed value taking that branch. *) - Rnone - else begin - (* Assuming the first column is ill-typed but considered coherent, we - might end up producing an ill-typed witness of non-exhaustivity - corresponding to the current branch. - - If [exhaust] has been called by [do_check_partial], then the witnesses - produced get typechecked and the ill-typed ones are discarded. - - If [exhaust] has been called by [do_check_fragile], then it is possible - we might fail to warn the user that the matching is fragile. See for - example testsuite/tests/warnings/w04_failure.ml. *) - let q0 = discr_pat omega pss in - match filter_all q0 pss with - (* first column of pss is made of variables only *) - | [] -> - begin match exhaust_gadt ext (filter_extra pss) (n-1) with - | Rsome r -> Rsome (List.map (fun row -> q0::row) r) - | r -> r - end - | constrs -> - let try_non_omega (p,pss) = - if is_absent_pat p then - Rnone - else - match - exhaust_gadt - ext pss (List.length (simple_match_args p omega) + n - 1) - with - | Rsome r -> Rsome (List.map (fun row -> (set_args p row)) r) - | r -> r in - let before = try_many_gadt try_non_omega constrs in - if - full_match false constrs && not (should_extend ext constrs) - then - before - else - (* - D = filter_extra pss is the default matrix - as it is included in pss, one can avoid - recursive calls on specialized matrices, - Essentially : - * D exhaustive => pss exhaustive - * D non-exhaustive => we have a non-filtered value - *) - let r = exhaust_gadt ext (filter_extra pss) (n-1) in - match r with - | Rnone -> before - | Rsome r -> - try - let p = build_other ext constrs in - let dug = List.map (fun tail -> p :: tail) r in - match before with - | Rnone -> Rsome dug - | Rsome x -> Rsome (x @ dug) - with - (* cannot occur, since constructors don't make a full signature *) - | Empty -> fatal_error "Parmatch.exhaust" - end - -let exhaust_gadt ext pss n = - let ret = exhaust_gadt ext pss n in - match ret with - Rnone -> Rnone - | Rsome lst -> - (* The following line is needed to compile stdlib/printf.ml *) - if lst = [] then Rsome (omegas n) else - let singletons = - List.map - (function - [x] -> x - | _ -> assert false) - lst - in - Rsome [orify_many singletons] - -(* - Another exhaustiveness check, enforcing variant typing. - Note that it does not check exact exhaustiveness, but whether a - matching could be made exhaustive by closing all variant types. - When this is true of all other columns, the current column is left - open (even if it means that the whole matching is not exhaustive as - a result). - When this is false for the matrix minus the current column, and the - current column is composed of variant tags, we close the variant - (even if it doesn't help in making the matching exhaustive). -*) - -let rec pressure_variants tdefs = function - | [] -> false - | []::_ -> true - | pss -> - if not (all_coherent (simplified_first_col pss)) then - true - else begin - let q0 = discr_pat omega pss in - match filter_all q0 pss with - [] -> pressure_variants tdefs (filter_extra pss) - | constrs -> - let rec try_non_omega = function - (_p,pss) :: rem -> - let ok = pressure_variants tdefs pss in - try_non_omega rem && ok - | [] -> true - in - if full_match (tdefs=None) constrs then - try_non_omega constrs - else if tdefs = None then - pressure_variants None (filter_extra pss) - else - let full = full_match true constrs in - let ok = - if full then try_non_omega constrs - else try_non_omega (filter_all q0 (mark_partial pss)) - in - begin match constrs, tdefs with - ({pat_desc=Tpat_variant _} as p,_):: _, Some env -> - let row = row_of_pat p in - if Btype.row_fixed row - || pressure_variants None (filter_extra pss) then () - else close_variant env row - | _ -> () - end; - ok - end - - -(* Yet another satisfiable function *) - -(* - This time every_satisfiable pss qs checks the - utility of every expansion of qs. - Expansion means expansion of or-patterns inside qs -*) - -type answer = - | Used (* Useful pattern *) - | Unused (* Useless pattern *) - | Upartial of Typedtree.pattern list (* Mixed, with list of useless ones *) - - - -(* this row type enable column processing inside the matrix - - left -> elements not to be processed, - - right -> elements to be processed -*) -type 'a row = {no_ors : 'a list ; ors : 'a list ; active : 'a list} - - -(* -let pretty_row {ors=ors ; no_ors=no_ors; active=active} = - pretty_line ors ; prerr_string " *" ; - pretty_line no_ors ; prerr_string " *" ; - pretty_line active - -let pretty_rows rs = - prerr_endline "begin matrix" ; - List.iter - (fun r -> - pretty_row r ; - prerr_endline "") - rs ; - prerr_endline "end matrix" -*) - -(* Initial build *) -let make_row ps = {ors=[] ; no_ors=[]; active=ps} - -let make_rows pss = List.map make_row pss - - -(* Useful to detect and expand or pats inside as pats *) -let rec unalias p = match p.pat_desc with -| Tpat_alias (p,_,_) -> unalias p -| _ -> p - - -let is_var p = match (unalias p).pat_desc with -| Tpat_any|Tpat_var _ -> true -| _ -> false - -let is_var_column rs = - List.for_all - (fun r -> match r.active with - | p::_ -> is_var p - | [] -> assert false) - rs - -(* Standard or-args for left-to-right matching *) -let rec or_args p = match p.pat_desc with -| Tpat_or (p1,p2,_) -> p1,p2 -| Tpat_alias (p,_,_) -> or_args p -| _ -> assert false - -(* Just remove current column *) -let remove r = match r.active with -| _::rem -> {r with active=rem} -| [] -> assert false - -let remove_column rs = List.map remove rs - -(* Current column has been processed *) -let push_no_or r = match r.active with -| p::rem -> { r with no_ors = p::r.no_ors ; active=rem} -| [] -> assert false - -let push_or r = match r.active with -| p::rem -> { r with ors = p::r.ors ; active=rem} -| [] -> assert false - -let push_or_column rs = List.map push_or rs -and push_no_or_column rs = List.map push_no_or rs - -(* Those are adaptations of the previous homonymous functions that - work on the current column, instead of the first column -*) - -let discr_pat q rs = - discr_pat q (List.map (fun r -> r.active) rs) - -let filter_one q rs = - let rec filter_rec rs = match rs with - | [] -> [] - | r::rem -> - match r.active with - | [] -> assert false - | {pat_desc = Tpat_alias(p,_,_)}::ps -> - filter_rec ({r with active = p::ps}::rem) - | {pat_desc = Tpat_or(p1,p2,_)}::ps -> - filter_rec - ({r with active = p1::ps}:: - {r with active = p2::ps}:: - rem) - | p::ps -> - if simple_match q p then - {r with active=simple_match_args q p @ ps} :: filter_rec rem - else - filter_rec rem in - filter_rec rs - - -(* Back to normal matrices *) -let make_vector r = List.rev r.no_ors - -let make_matrix rs = List.map make_vector rs - - -(* Standard union on answers *) -let union_res r1 r2 = match r1, r2 with -| (Unused,_) -| (_, Unused) -> Unused -| Used,_ -> r2 -| _, Used -> r1 -| Upartial u1, Upartial u2 -> Upartial (u1@u2) - -(* propose or pats for expansion *) -let extract_elements qs = - let rec do_rec seen = function - | [] -> [] - | q::rem -> - {no_ors= List.rev_append seen rem @ qs.no_ors ; - ors=[] ; - active = [q]}:: - do_rec (q::seen) rem in - do_rec [] qs.ors - -(* idem for matrices *) -let transpose rs = match rs with -| [] -> assert false -| r::rem -> - let i = List.map (fun x -> [x]) r in - List.fold_left - (List.map2 (fun r x -> x::r)) - i rem - -let extract_columns pss qs = match pss with -| [] -> List.map (fun _ -> []) qs.ors -| _ -> - let rows = List.map extract_elements pss in - transpose rows - -(* Core function - The idea is to first look for or patterns (recursive case), then - check or-patterns argument usefulness (terminal case) -*) -let rec simplified_first_usefulness_col = function - | [] -> [] - | row :: rows -> - match row.active with - | [] -> assert false (* the rows are non-empty! *) - | p :: _ -> simplify_head_pat p (simplified_first_usefulness_col rows) - -let rec every_satisfiables pss qs = match qs.active with -| [] -> - (* qs is now partitionned, check usefulness *) - begin match qs.ors with - | [] -> (* no or-patterns *) - if satisfiable (make_matrix pss) (make_vector qs) then - Used - else - Unused - | _ -> (* n or-patterns -> 2n expansions *) - List.fold_right2 - (fun pss qs r -> match r with - | Unused -> Unused - | _ -> - match qs.active with - | [q] -> - let q1,q2 = or_args q in - let r_loc = every_both pss qs q1 q2 in - union_res r r_loc - | _ -> assert false) - (extract_columns pss qs) (extract_elements qs) - Used - end -| q::rem -> - let uq = unalias q in - begin match uq.pat_desc with - | Tpat_any | Tpat_var _ -> - if is_var_column pss then -(* forget about ``all-variable'' columns now *) - every_satisfiables (remove_column pss) (remove qs) - else -(* otherwise this is direct food for satisfiable *) - every_satisfiables (push_no_or_column pss) (push_no_or qs) - | Tpat_or (q1,q2,_) -> - if - q1.pat_loc.Location.loc_ghost && - q2.pat_loc.Location.loc_ghost - then -(* syntactically generated or-pats should not be expanded *) - every_satisfiables (push_no_or_column pss) (push_no_or qs) - else -(* this is a real or-pattern *) - every_satisfiables (push_or_column pss) (push_or qs) - | Tpat_variant (l,_,r) when is_absent l r -> (* Ah Jacques... *) - Unused - | _ -> -(* standard case, filter matrix *) - (* The handling of incoherent matrices is kept in line with - [satisfiable] *) - if not (all_coherent (uq :: simplified_first_usefulness_col pss)) then - Unused - else begin - let q0 = discr_pat q pss in - every_satisfiables - (filter_one q0 pss) - {qs with active=simple_match_args q0 q @ rem} - end - end - -(* - This function ``every_both'' performs the usefulness check - of or-pat q1|q2. - The trick is to call every_satisfied twice with - current active columns restricted to q1 and q2, - That way, - - others orpats in qs.ors will not get expanded. - - all matching work performed on qs.no_ors is not performed again. - *) -and every_both pss qs q1 q2 = - let qs1 = {qs with active=[q1]} - and qs2 = {qs with active=[q2]} in - let r1 = every_satisfiables pss qs1 - and r2 = every_satisfiables (if compat q1 q2 then qs1::pss else pss) qs2 in - match r1 with - | Unused -> - begin match r2 with - | Unused -> Unused - | Used -> Upartial [q1] - | Upartial u2 -> Upartial (q1::u2) - end - | Used -> - begin match r2 with - | Unused -> Upartial [q2] - | _ -> r2 - end - | Upartial u1 -> - begin match r2 with - | Unused -> Upartial (u1@[q2]) - | Used -> r1 - | Upartial u2 -> Upartial (u1 @ u2) - end - - - - -(* le_pat p q means, forall V, V matches q implies V matches p *) -let rec le_pat p q = - match (p.pat_desc, q.pat_desc) with - | (Tpat_var _|Tpat_any),_ -> true - | Tpat_alias(p,_,_), _ -> le_pat p q - | _, Tpat_alias(q,_,_) -> le_pat p q - | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 - | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) -> - Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs - | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> - (l1 = l2 && le_pat p1 p2) - | Tpat_variant(l1,None,_r1), Tpat_variant(l2,None,_) -> - l1 = l2 - | Tpat_variant(_,_,_), Tpat_variant(_,_,_) -> false - | Tpat_tuple(ps), Tpat_tuple(qs) -> le_pats ps qs - | Tpat_lazy p, Tpat_lazy q -> le_pat p q - | Tpat_record (l1,_), Tpat_record (l2,_) -> - let ps,qs = records_args l1 l2 in - le_pats ps qs - | Tpat_array(ps), Tpat_array(qs) -> - Ext_list.same_length ps qs && le_pats ps qs -(* In all other cases, enumeration is performed *) - | _,_ -> not (satisfiable [[p]] [q]) - -and le_pats ps qs = - match ps,qs with - p::ps, q::qs -> le_pat p q && le_pats ps qs - | _, _ -> true - -let get_mins le ps = - let rec select_rec r = function - [] -> r - | p::ps -> - if List.exists (fun p0 -> le p0 p) ps - then select_rec r ps - else select_rec (p::r) ps in - select_rec [] (select_rec [] ps) - -(* - lub p q is a pattern that matches all values matched by p and q - may raise Empty, when p and q are not compatible -*) - -let rec lub p q = match p.pat_desc,q.pat_desc with -| Tpat_alias (p,_,_),_ -> lub p q -| _,Tpat_alias (q,_,_) -> lub p q -| (Tpat_any|Tpat_var _),_ -> q -| _,(Tpat_any|Tpat_var _) -> p -| Tpat_or (p1,p2,_),_ -> orlub p1 p2 q -| _,Tpat_or (q1,q2,_) -> orlub q1 q2 p (* Thanks god, lub is commutative *) -| Tpat_constant c1, Tpat_constant c2 when const_compare c1 c2 = 0 -> p -| Tpat_tuple ps, Tpat_tuple qs -> - let rs = lubs ps qs in - make_pat (Tpat_tuple rs) p.pat_type p.pat_env -| Tpat_lazy p, Tpat_lazy q -> - let r = lub p q in - make_pat (Tpat_lazy r) p.pat_type p.pat_env -| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2) - when Types.equal_tag c1.cstr_tag c2.cstr_tag -> - let rs = lubs ps1 ps2 in - make_pat (Tpat_construct (lid, c1,rs)) - p.pat_type p.pat_env -| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_) - when l1=l2 -> - let r=lub p1 p2 in - make_pat (Tpat_variant (l1,Some r,row)) p.pat_type p.pat_env -| Tpat_variant (l1,None,_row), Tpat_variant(l2,None,_) - when l1 = l2 -> p -| Tpat_record (l1,closed),Tpat_record (l2,_) -> - let rs = record_lubs l1 l2 in - make_pat (Tpat_record (rs, closed)) p.pat_type p.pat_env -| Tpat_array ps, Tpat_array qs - when List.length ps = List.length qs -> - let rs = lubs ps qs in - make_pat (Tpat_array rs) p.pat_type p.pat_env -| _,_ -> - raise Empty - -and orlub p1 p2 q = - try - let r1 = lub p1 q in - try - {q with pat_desc=(Tpat_or (r1,lub p2 q,None))} - with - | Empty -> r1 -with -| Empty -> lub p2 q - -and record_lubs l1 l2 = - let rec lub_rec l1 l2 = match l1,l2 with - | [],_ -> l2 - | _,[] -> l1 - | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 -> - if lbl1.lbl_pos < lbl2.lbl_pos then - (lid1, lbl1,p1)::lub_rec rem1 l2 - else if lbl2.lbl_pos < lbl1.lbl_pos then - (lid2, lbl2,p2)::lub_rec l1 rem2 - else - (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in - lub_rec l1 l2 - -and lubs ps qs = match ps,qs with -| p::ps, q::qs -> lub p q :: lubs ps qs -| _,_ -> [] - - -(******************************) -(* Exported variant closing *) -(******************************) - -(* Apply pressure to variants *) - -let pressure_variants tdefs patl = - let pss = List.map (fun p -> [p;omega]) patl in - ignore (pressure_variants (Some tdefs) pss) - -(*****************************) -(* Utilities for diagnostics *) -(*****************************) - -(* - Build up a working pattern matrix by forgetting - about guarded patterns -*) - -let rec initial_matrix = function - [] -> [] - | {c_guard=Some _} :: rem -> initial_matrix rem - | {c_guard=None; c_lhs=p} :: rem -> [p] :: initial_matrix rem - -(******************************************) -(* Look for a row that matches some value *) -(******************************************) - -(* - Useful for seeing if the example of - non-matched value can indeed be matched - (by a guarded clause) -*) - - - -exception NoGuard - -let rec initial_all no_guard = function - | [] -> - if no_guard then - raise NoGuard - else - [] - | {c_lhs=pat; c_guard; _} :: rem -> - ([pat], pat.pat_loc) :: initial_all (no_guard && c_guard = None) rem - - -let rec do_filter_var = function - | (_::ps,loc)::rem -> (ps,loc)::do_filter_var rem - | _ -> [] - -let do_filter_one q pss = - let rec filter_rec = function - | ({pat_desc = Tpat_alias(p,_,_)}::ps,loc)::pss -> - filter_rec ((p::ps,loc)::pss) - | ({pat_desc = Tpat_or(p1,p2,_)}::ps,loc)::pss -> - filter_rec ((p1::ps,loc)::(p2::ps,loc)::pss) - | (p::ps,loc)::pss -> - if simple_match q p - then (simple_match_args q p @ ps, loc) :: filter_rec pss - else filter_rec pss - | _ -> [] in - filter_rec pss - -let rec do_match pss qs = match qs with -| [] -> - begin match pss with - | ([],loc)::_ -> Some loc - | _ -> None - end -| q::qs -> match q with - | {pat_desc = Tpat_or (q1,q2,_)} -> - begin match do_match pss (q1::qs) with - | None -> do_match pss (q2::qs) - | r -> r - end - | {pat_desc = Tpat_any} -> - do_match (do_filter_var pss) qs - | _ -> - let q0 = normalize_pat q in - (* [pss] will (or won't) match [q0 :: qs] regardless of the coherence of - its first column. *) - do_match (do_filter_one q0 pss) (simple_match_args q0 q @ qs) - - -let check_partial_all v casel = - try - let pss = initial_all true casel in - do_match pss [v] - with - | NoGuard -> None - -(************************) -(* Exhaustiveness check *) -(************************) - -(* conversion from Typedtree.pattern to Parsetree.pattern list *) -module Conv = struct - open Parsetree - let mkpat desc = Ast_helper.Pat.mk desc - - let name_counter = ref 0 - let fresh name = - let current = !name_counter in - name_counter := !name_counter + 1; - "#$" ^ name ^ string_of_int current - - let conv typed = - let constrs = Hashtbl.create 7 in - let labels = Hashtbl.create 7 in - let rec loop pat = - match pat.pat_desc with - Tpat_or (pa,pb,_) -> - mkpat (Ppat_or (loop pa, loop pb)) - | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *) - mkpat (Ppat_var nm) - | Tpat_any - | Tpat_var _ -> - mkpat Ppat_any - | Tpat_constant c -> - mkpat (Ppat_constant (Untypeast.constant c)) - | Tpat_alias (p,_,_) -> loop p - | Tpat_tuple lst -> - mkpat (Ppat_tuple (List.map loop lst)) - | Tpat_construct (cstr_lid, cstr, lst) -> - let id = fresh cstr.cstr_name in - let lid = { cstr_lid with txt = Longident.Lident id } in - Hashtbl.add constrs id cstr; - let arg = - match List.map loop lst with - | [] -> None - | [p] -> Some p - | lst -> Some (mkpat (Ppat_tuple lst)) - in - mkpat (Ppat_construct(lid, arg)) - | Tpat_variant(label,p_opt,_row_desc) -> - let arg = Misc.may_map loop p_opt in - mkpat (Ppat_variant(label, arg)) - | Tpat_record (subpatterns, _closed_flag) -> - let fields = - List.map - (fun (_, lbl, p) -> - let id = fresh lbl.lbl_name in - Hashtbl.add labels id lbl; - (mknoloc (Longident.Lident id), loop p)) - subpatterns - in - mkpat (Ppat_record (fields, Open)) - | Tpat_array lst -> - mkpat (Ppat_array (List.map loop lst)) - | Tpat_lazy p -> - mkpat (Ppat_lazy (loop p)) - in - let ps = loop typed in - (ps, constrs, labels) -end - - -(* Whether the counter-example contains an extension pattern *) -let contains_extension pat = - let r = ref false in - let rec loop = function - {pat_desc=Tpat_var (_, {txt="*extension*"})} -> - r := true - | p -> Typedtree.iter_pattern_desc loop p.pat_desc - in loop pat; !r - -(* Build an untyped or-pattern from its expected type *) -let ppat_of_type env ty = - match pats_of_type env ty with - [{pat_desc = Tpat_any}] -> - (Conv.mkpat Parsetree.Ppat_any, Hashtbl.create 0, Hashtbl.create 0) - | pats -> - Conv.conv (orify_many pats) - -let do_check_partial ?pred exhaust loc casel pss = match pss with -| [] -> - (* - This can occur - - For empty matches generated by ocamlp4 (no warning) - - when all patterns have guards (then, casel <> []) - (specific warning) - Then match MUST be considered non-exhaustive, - otherwise compilation of PM is broken. - *) - begin match casel with - | [] -> () - | _ -> - if Warnings.is_active Warnings.All_clauses_guarded then - Location.prerr_warning loc Warnings.All_clauses_guarded - end ; - Partial -| ps::_ -> - begin match exhaust None pss (List.length ps) with - | Rnone -> Total - | Rsome [u] -> - let v = - match pred with - | Some pred -> - let (pattern,constrs,labels) = Conv.conv u in - let u' = pred constrs labels pattern in - (* pretty_pat u; - begin match u' with - None -> prerr_endline ": impossible" - | Some _ -> prerr_endline ": possible" - end; *) - u' - | None -> Some u - in - begin match v with - None -> Total - | Some v -> - if Warnings.is_active (Warnings.Partial_match "") then begin - let errmsg = - try - let buf = Buffer.create 16 in - Buffer.add_string buf "| "; - Buffer.add_string buf (!print_res_pat v); - begin match check_partial_all v casel with - | None -> () - | Some _ -> - (* This is 'Some loc', where loc is the location of - a possibly matching clause. - Forget about loc, because printing two locations - is a pain in the top-level *) - Buffer.add_string buf - "\n(However, some guarded clause may match this value.)" - end; - if contains_extension v then - Buffer.add_string buf - "\nMatching over values of extensible variant types \ - (the *extension* above)\n\ - must include a wild card pattern in order to be exhaustive." - ; - Buffer.contents buf - with _ -> - "" - in - Location.prerr_warning loc (Warnings.Partial_match errmsg) - end; - Partial - end - | _ -> - fatal_error "Parmatch.check_partial" - end - -(* -let do_check_partial_normal loc casel pss = - do_check_partial exhaust loc casel pss - *) - -let do_check_partial_gadt pred loc casel pss = - do_check_partial ~pred exhaust_gadt loc casel pss - - - -(*****************) -(* Fragile check *) -(*****************) - -(* Collect all data types in a pattern *) - -let rec add_path path = function - | [] -> [path] - | x::rem as paths -> - if Path.same path x then paths - else x::add_path path rem - -let extendable_path path = - not - (Path.same path Predef.path_bool || - Path.same path Predef.path_list || - Path.same path Predef.path_unit || - Path.same path Predef.path_option) - -let rec collect_paths_from_pat r p = match p.pat_desc with -| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps) - -> - let path = get_type_path p.pat_type p.pat_env in - List.fold_left - collect_paths_from_pat - (if extendable_path path then add_path path r else r) - ps -| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r -| Tpat_tuple ps | Tpat_array ps -| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)-> - List.fold_left collect_paths_from_pat r ps -| Tpat_record (lps,_) -> - List.fold_left - (fun r (_, _, p) -> collect_paths_from_pat r p) - r lps -| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p -| Tpat_or (p1,p2,_) -> - collect_paths_from_pat (collect_paths_from_pat r p1) p2 -| Tpat_lazy p - -> - collect_paths_from_pat r p - - -(* - Actual fragile check - 1. Collect data types in the patterns of the match. - 2. One exhaustivity check per datatype, considering that - the type is extended. -*) - -let do_check_fragile_param exhaust loc casel pss = - let exts = - List.fold_left - (fun r c -> collect_paths_from_pat r c.c_lhs) - [] casel in - match exts with - | [] -> () - | _ -> match pss with - | [] -> () - | ps::_ -> - List.iter - (fun ext -> - match exhaust (Some ext) pss (List.length ps) with - | Rnone -> - Location.prerr_warning - loc - (Warnings.Fragile_match (Path.name ext)) - | Rsome _ -> ()) - exts - -(*let do_check_fragile_normal = do_check_fragile_param exhaust*) -let do_check_fragile_gadt = do_check_fragile_param exhaust_gadt - -(********************************) -(* Exported unused clause check *) -(********************************) - -let check_unused pred casel = - if Warnings.is_active Warnings.Unused_match - || List.exists (fun c -> c.c_rhs.exp_desc = Texp_unreachable) casel then - let rec do_rec pref = function - | [] -> () - | {c_lhs=q; c_guard; c_rhs} :: rem -> - let qs = [q] in - begin try - let pss = - get_mins le_pats (Ext_list.filter pref (compats qs)) in - (* First look for redundant or partially redundant patterns *) - let r = every_satisfiables (make_rows pss) (make_row qs) in - let refute = (c_rhs.exp_desc = Texp_unreachable) in - (* Do not warn for unused [pat -> .] *) - if r = Unused && refute then () else - let r = - (* Do not refine if there are no other lines *) - let skip = - r = Unused || (not refute && pref = []) || - not(refute || Warnings.is_active Warnings.Unreachable_case) in - if skip then r else - (* Then look for empty patterns *) - let sfs = satisfiables pss qs in - if sfs = [] then Unused else - let sfs = - List.map (function [u] -> u | _ -> assert false) sfs in - let u = orify_many sfs in - (*Format.eprintf "%a@." pretty_val u;*) - let (pattern,constrs,labels) = Conv.conv u in - let pattern = {pattern with Parsetree.ppat_loc = q.pat_loc} in - match pred refute constrs labels pattern with - None when not refute -> - Location.prerr_warning q.pat_loc Warnings.Unreachable_case; - Used - | _ -> r - in - match r with - | Unused -> - Location.prerr_warning - q.pat_loc Warnings.Unused_match - | Upartial ps -> - List.iter - (fun p -> - Location.prerr_warning - p.pat_loc Warnings.Unused_pat) - ps - | Used -> () - with Empty | Not_found | NoGuard -> assert false - end ; - - if c_guard <> None then - do_rec pref rem - else - do_rec ([q]::pref) rem in - - do_rec [] casel - -(*********************************) -(* Exported irrefutability tests *) -(*********************************) - -let irrefutable pat = le_pat pat omega - -let inactive ~partial pat = - match partial with - | Partial -> false - | Total -> begin - let rec loop pat = - match pat.pat_desc with - | Tpat_lazy _ | Tpat_array _ -> - false - | Tpat_any | Tpat_var _ | Tpat_variant (_, None, _) -> - true - | Tpat_constant c -> begin - match c with - | Const_string _ -> true (*Config.safe_string*) - | Const_int _ | Const_char _ | Const_float _ - | Const_int32 _ | Const_int64 _ | Const_bigint _ -> true - end - | Tpat_tuple ps | Tpat_construct (_, _, ps) -> - List.for_all (fun p -> loop p) ps - | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> - loop p - | Tpat_record (ldps,_) -> - List.for_all - (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) - ldps - | Tpat_or (p,q,_) -> - loop p && loop q - in - loop pat - end - - - - - - - -(*********************************) -(* Exported exhaustiveness check *) -(*********************************) - -(* - Fragile check is performed when required and - on exhaustive matches only. -*) - -let check_partial_param do_check_partial do_check_fragile loc casel = - let pss = initial_matrix casel in - let pss = get_mins le_pats pss in - let total = do_check_partial loc casel pss in - if - total = Total && Warnings.is_active (Warnings.Fragile_match "") - then begin - do_check_fragile loc casel pss - end ; - total - -(*let check_partial = - check_partial_param - do_check_partial_normal - do_check_fragile_normal*) - -let check_partial_gadt pred loc casel = - check_partial_param (do_check_partial_gadt pred) - do_check_fragile_gadt loc casel - - -(*************************************) -(* Ambiguous variable in or-patterns *) -(*************************************) - -(* Specification: ambiguous variables in or-patterns. - - The semantics of or-patterns in OCaml is specified with - a left-to-right bias: a value [v] matches the pattern [p | q] if it - matches [p] or [q], but if it matches both, the environment - captured by the match is the environment captured by [p], never the - one captured by [q]. - - While this property is generally well-understood, one specific case - where users expect a different semantics is when a pattern is - followed by a when-guard: [| p when g -> e]. Consider for example: - - | ((Const x, _) | (_, Const x)) when is_neutral x -> branch - - The semantics is clear: match the scrutinee against the pattern, if - it matches, test the guard, and if the guard passes, take the - branch. - - However, consider the input [(Const a, Const b)], where [a] fails - the test [is_neutral f], while [b] passes the test [is_neutral - b]. With the left-to-right semantics, the clause above is *not* - taken by its input: matching [(Const a, Const b)] against the - or-pattern succeeds in the left branch, it returns the environment - [x -> a], and then the guard [is_neutral a] is tested and fails, - the branch is not taken. Most users, however, intuitively expect - that any pair that has one side passing the test will take the - branch. They assume it is equivalent to the following: - - | (Const x, _) when is_neutral x -> branch - | (_, Const x) when is_neutral x -> branch - - while it is not. - - The code below is dedicated to finding these confusing cases: the - cases where a guard uses "ambiguous" variables, that are bound to - different parts of the scrutinees by different sides of - a or-pattern. In other words, it finds the cases where the - specified left-to-right semantics is not equivalent to - a non-deterministic semantics (any branch can be taken) relatively - to a specific guard. -*) - -module IdSet = Set.Make(Ident) - -let pattern_vars p = IdSet.of_list (Typedtree.pat_bound_idents p) - -(* Row for ambiguous variable search, - unseen is the traditional pattern row, - seen is a list of position bindings *) - -type amb_row = { unseen : pattern list ; seen : IdSet.t list; } - - -(* Push binding variables now *) - -let rec do_push r p ps seen k = match p.pat_desc with -| Tpat_alias (p,x,_) -> do_push (IdSet.add x r) p ps seen k -| Tpat_var (x,_) -> - (omega,{ unseen = ps; seen=IdSet.add x r::seen; })::k -| Tpat_or (p1,p2,_) -> - do_push r p1 ps seen (do_push r p2 ps seen k) -| _ -> - (p,{ unseen = ps; seen = r::seen; })::k - -let rec push_vars = function - | [] -> [] - | { unseen = [] }::_ -> assert false - | { unseen = p::ps; seen; }::rem -> - do_push IdSet.empty p ps seen (push_vars rem) - -let collect_stable = function - | [] -> assert false - | { seen=xss; _}::rem -> - let rec c_rec xss = function - | [] -> xss - | {seen=yss; _}::rem -> - let xss = List.map2 IdSet.inter xss yss in - c_rec xss rem in - let inters = c_rec xss rem in - List.fold_left IdSet.union IdSet.empty inters - - -(*********************************************) -(* Filtering utilities for our specific rows *) -(*********************************************) - -(* Take a pattern matrix as a list (rows) of lists (columns) of patterns - | p1, p2, .., pn - | q1, q2, .., qn - | r1, r2, .., rn - | ... - - We split this matrix into a list of sub-matrices, one for each head - constructor appearing in the leftmost column. For each row whose - left column starts with a head constructor, remove this head - column, prepend one column for each argument of the constructor, - and add the resulting row in the sub-matrix corresponding to this - head constructor. - - Rows whose left column is omega (the Any pattern _) may match any - head constructor, so they are added to all groups. - - The list of sub-matrices is represented as a list of pair - (head constructor, submatrix) -*) - -let filter_all = - (* the head constructor (as a pattern with omega arguments) of - a pattern *) - let discr_head pat = - match pat.pat_desc with - | Tpat_record (lbls, closed) -> - (* a partial record pattern { f1 = p1; f2 = p2; _ } - needs to be expanded, otherwise matching against this head - would drop the pattern arguments for non-mentioned fields *) - let lbls = all_record_args lbls in - normalize_pat { pat with pat_desc = Tpat_record (lbls, closed) } - | _ -> normalize_pat pat - in - - (* insert a row of head [p] and rest [r] into the right group *) - let rec insert p r env = match env with - | [] -> - (* if no group matched this row, it has a head constructor that - was never seen before; add a new sub-matrix for this head *) - let p0 = discr_head p in - [p0,[{ r with unseen = simple_match_args p0 p @ r.unseen }]] - | (q0,rs) as bd::env -> - if simple_match q0 p then begin - let r = { r with unseen = simple_match_args q0 p@r.unseen; } in - (q0,r::rs)::env - end - else bd::insert p r env in - - (* insert a row of head omega into all groups *) - let insert_omega r env = - List.map - (fun (q0,rs) -> - let r = - { r with unseen = simple_match_args q0 omega @ r.unseen; } in - (q0,r::rs)) - env - in - - let rec filter_rec env = function - | [] -> env - | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false - | ({pat_desc=Tpat_any}, _)::rs -> filter_rec env rs - | (p,r)::rs -> filter_rec (insert p r env) rs in - - let rec filter_omega env = function - | [] -> env - | ({pat_desc=(Tpat_var _|Tpat_alias _|Tpat_or _)},_)::_ -> assert false - | ({pat_desc=Tpat_any},r)::rs -> filter_omega (insert_omega r env) rs - | _::rs -> filter_omega env rs in - - fun rs -> - (* first insert the rows with head constructors, - to get the definitive list of groups *) - let env = filter_rec [] rs in - (* then add the omega rows to all groups *) - filter_omega env rs - -(* Compute stable bindings *) - -let rec do_stable rs = match rs with -| [] -> assert false (* No empty matrix *) -| { unseen=[]; _ }::_ -> - collect_stable rs -| _ -> - let rs = push_vars rs in - if not (all_coherent (first_column rs)) then begin - (* If the first column is incoherent, then all the variables of this - matrix are stable. *) - List.fold_left (fun acc (_, { seen; _ }) -> - List.fold_left IdSet.union acc seen - ) IdSet.empty rs - end else begin - (* If the column is ill-typed but deemed coherent, we might spuriously - warn about some variables being unstable. - As sad as that might be, the warning can be silenced by splitting the - or-pattern... *) - match filter_all rs with - | [] -> - do_stable (List.map snd rs) - | (_,rs)::env -> - List.fold_left - (fun xs (_,rs) -> IdSet.inter xs (do_stable rs)) - (do_stable rs) env - end - -let stable p = do_stable [{unseen=[p]; seen=[];}] - - -(* All identifier paths that appear in an expression that occurs - as a clause right hand side or guard. - - The function is rather complex due to the compilation of - unpack patterns by introducing code in rhs expressions - and **guards**. - - For pattern (module M:S) -> e the code is - let module M_mod = unpack M .. in e - - Hence M is "free" in e iff M_mod is free in e. - - Not doing so will yield excessive warning in - (module (M:S) } ...) when true -> .... - as M is always present in - let module M_mod = unpack M .. in true -*) - -let all_rhs_idents exp = - let ids = ref IdSet.empty in - let module Iterator = TypedtreeIter.MakeIterator(struct - include TypedtreeIter.DefaultIteratorArgument - let enter_expression exp = match exp.exp_desc with - | Texp_ident (path, _lid, _descr) -> - List.iter - (fun id -> ids := IdSet.add id !ids) - (Path.heads path) - | _ -> () - -(* Very hackish, detect unpack pattern compilation - and perform "indirect check for them" *) - let is_unpack exp = - List.exists - (fun (attr, _) -> attr.txt = "#modulepat") exp.exp_attributes - - let leave_expression exp = - if is_unpack exp then begin match exp.exp_desc with - | Texp_letmodule - (id_mod,_, - {mod_desc= - Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)}, - _) -> - assert (IdSet.mem id_exp !ids) ; - if not (IdSet.mem id_mod !ids) then begin - ids := IdSet.remove id_exp !ids - end - | _ -> assert false - end - end) in - Iterator.iter_expression exp; - !ids - -let check_ambiguous_bindings = - let open Warnings in - let warn0 = Ambiguous_pattern [] in - fun cases -> - if is_active warn0 then - List.iter - (fun case -> match case with - | { c_guard=None ; _} -> () - | { c_lhs=p; c_guard=Some g; _} -> - let all = - IdSet.inter (pattern_vars p) (all_rhs_idents g) in - if not (IdSet.is_empty all) then begin - let st = stable p in - let ambiguous = IdSet.diff all st in - if not (IdSet.is_empty ambiguous) then begin - let pps = IdSet.elements ambiguous |> List.map Ident.name in - let warn = Ambiguous_pattern pps in - Location.prerr_warning p.pat_loc warn - end - end) - cases diff --git a/jscomp/ml/parmatch.mli b/jscomp/ml/parmatch.mli deleted file mode 100644 index e44fb78..0000000 --- a/jscomp/ml/parmatch.mli +++ /dev/null @@ -1,102 +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. *) -(* *) -(**************************************************************************) - -(* Detection of partial matches and unused match cases. *) -open Asttypes -open Typedtree -open Types - -val pretty_const : constant -> string -val top_pretty : Format.formatter -> pattern -> unit -val pretty_pat : pattern -> unit -val pretty_line : pattern list -> unit -val pretty_matrix : pattern list list -> unit - -val print_res_pat: (Typedtree.pattern -> string) ref - -val omega : pattern -val omegas : int -> pattern list -val omega_list : 'a list -> pattern list -val normalize_pat : pattern -> pattern -val all_record_args : - (Longident.t loc * label_description * pattern) list -> - (Longident.t loc * label_description * pattern) list -val const_compare : constant -> constant -> int - -val le_pat : pattern -> pattern -> bool -val le_pats : pattern list -> pattern list -> bool - -(* Exported compatibility functor, abstracted over constructor equality *) -module [@warning "-67"] Compat : - functor - (Constr: sig - val equal : - Types.constructor_description -> - Types.constructor_description -> - bool - end) -> sig - val compat : pattern -> pattern -> bool - val compats : pattern list -> pattern list -> bool - end - -exception Empty -val lub : pattern -> pattern -> pattern -val lubs : pattern list -> pattern list -> pattern list - -val get_mins : ('a -> 'a -> bool) -> 'a list -> 'a list - -(* Those two functions recombine one pattern and its arguments: - For instance: - (_,_)::p1::p2::rem -> (p1, p2)::rem - The second one will replace mutable arguments by '_' -*) -val set_args : pattern -> pattern list -> pattern list -val set_args_erase_mutable : pattern -> pattern list -> pattern list - -val pat_of_constr : pattern -> constructor_description -> pattern -val complete_constrs : - pattern -> constructor_tag list -> constructor_description list -val ppat_of_type : - Env.t -> type_expr -> - Parsetree.pattern * - (string, constructor_description) Hashtbl.t * - (string, label_description) Hashtbl.t - -val pressure_variants: Env.t -> pattern list -> unit -val check_partial_gadt: - ((string, constructor_description) Hashtbl.t -> - (string, label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> - Location.t -> case list -> partial -val check_unused: - (bool -> - (string, constructor_description) Hashtbl.t -> - (string, label_description) Hashtbl.t -> - Parsetree.pattern -> pattern option) -> - case list -> unit - -(* Irrefutability tests *) -val irrefutable : pattern -> bool - -(** An inactive pattern is a pattern, matching against which can be duplicated, erased or - delayed without change in observable behavior of the program. Patterns containing - (lazy _) subpatterns or reads of mutable fields are active. *) -val inactive : partial:partial -> pattern -> bool - -(* Ambiguous bindings *) -val check_ambiguous_bindings : case list -> unit - -(* The tag used for open polymorphic variant types *) -val some_other_tag : label diff --git a/jscomp/ml/parse.ml b/jscomp/ml/parse.ml deleted file mode 100644 index 7de593c..0000000 --- a/jscomp/ml/parse.ml +++ /dev/null @@ -1,36 +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. *) -(* *) -(**************************************************************************) - -(* Entry points in the parser *) - - -let wrap parsing_fun lexbuf = - try - Docstrings.init (); - Lexer.init (); - let ast = parsing_fun Lexer.token lexbuf in - Parsing.clear_parser(); - Docstrings.warn_bad_docstrings (); - ast - with - | Parsing.Parse_error | Syntaxerr.Escape_error -> - let loc = Location.curr lexbuf in - raise(Syntaxerr.Error(Syntaxerr.Other loc)) - -let implementation = wrap Parser.implementation -and interface = wrap Parser.interface -and core_type = wrap Parser.parse_core_type -and expression = wrap Parser.parse_expression -and pattern = wrap Parser.parse_pattern diff --git a/jscomp/ml/parse.mli b/jscomp/ml/parse.mli deleted file mode 100644 index a35feb8..0000000 --- a/jscomp/ml/parse.mli +++ /dev/null @@ -1,22 +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. *) -(* *) -(**************************************************************************) - -(** Entry points in the parser *) - -val implementation : Lexing.lexbuf -> Parsetree.structure -val interface : Lexing.lexbuf -> Parsetree.signature -val core_type : Lexing.lexbuf -> Parsetree.core_type -val expression : Lexing.lexbuf -> Parsetree.expression -val pattern : Lexing.lexbuf -> Parsetree.pattern diff --git a/jscomp/ml/parser.ml b/jscomp/ml/parser.ml deleted file mode 100644 index 31527cc..0000000 --- a/jscomp/ml/parser.ml +++ /dev/null @@ -1,12169 +0,0 @@ -type token = - | AMPERAMPER - | AMPERSAND - | AND - | AS - | ASSERT - | BACKQUOTE - | BANG - | BAR - | BARBAR - | BARRBRACKET - | BEGIN - | CHAR of (char) - | CLASS - | COLON - | COLONCOLON - | COLONEQUAL - | COLONGREATER - | COMMA - | CONSTRAINT - | DO - | DONE - | DOT - | DOTDOT - | DOWNTO - | ELSE - | END - | EOF - | EQUAL - | EXCEPTION - | EXTERNAL - | FALSE - | FLOAT of (string * char option) - | FOR - | FUN - | FUNCTION - | FUNCTOR - | GREATER - | GREATERRBRACE - | GREATERRBRACKET - | IF - | IN - | INCLUDE - | INFIXOP0 of (string) - | INFIXOP1 of (string) - | INFIXOP2 of (string) - | INFIXOP3 of (string) - | INFIXOP4 of (string) - | DOTOP of (string) - | INHERIT - | INITIALIZER - | INT of (string * char option) - | LABEL of (string) - | LAZY - | LBRACE - | LBRACELESS - | LBRACKET - | LBRACKETBAR - | LBRACKETLESS - | LBRACKETGREATER - | LBRACKETPERCENT - | LBRACKETPERCENTPERCENT - | LESS - | LESSMINUS - | LET - | LIDENT of (string) - | LPAREN - | LBRACKETAT - | LBRACKETATAT - | LBRACKETATATAT - | MATCH - | METHOD - | MINUS - | MINUSDOT - | MINUSGREATER - | MODULE - | MUTABLE - | NEW - | NONREC - | OBJECT - | OF - | OPEN - | OPTLABEL of (string) - | OR - | PERCENT - | PLUS - | PLUSDOT - | PLUSEQ - | PREFIXOP of (string) - | PRIVATE - | QUESTION - | QUOTE - | RBRACE - | RBRACKET - | REC - | RPAREN - | SEMI - | SEMISEMI - | HASH - | HASHOP of (string) - | SIG - | STAR - | STRING of (string * string option) - | STRUCT - | THEN - | TILDE - | TO - | TRUE - | TRY - | TYPE - | UIDENT of (string) - | UNDERSCORE - | VAL - | VIRTUAL - | WHEN - | WHILE - | WITH - | COMMENT of (string * Location.t) - | DOCSTRING of (Docstrings.docstring) - | EOL - -open Parsing;; -let _ = parse_error;; -# 19 "ml/parser.mly" -open Location -open Asttypes -open Longident -open Parsetree -open Ast_helper -open Docstrings - -let mktyp d = Typ.mk ~loc:(symbol_rloc()) d -let mkpat d = Pat.mk ~loc:(symbol_rloc()) d -let mkexp d = Exp.mk ~loc:(symbol_rloc()) d -let mkmty ?attrs d = Mty.mk ~loc:(symbol_rloc()) ?attrs d -let mksig d = Sig.mk ~loc:(symbol_rloc()) d -let mkmod ?attrs d = Mod.mk ~loc:(symbol_rloc()) ?attrs d -let mkstr d = Str.mk ~loc:(symbol_rloc()) d -let mkcty ?attrs d = Cty.mk ~loc:(symbol_rloc()) ?attrs d -let mkctf ?attrs ?docs d = - Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d -let mkcf ?attrs ?docs d = - Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d - -let mkrhs rhs pos = mkloc rhs (rhs_loc pos) - -let reloc_pat x = { x with ppat_loc = symbol_rloc () };; -let reloc_exp x = { x with pexp_loc = symbol_rloc () };; - -let mkoperator name pos = - let loc = rhs_loc pos in - Exp.mk ~loc (Pexp_ident(mkloc (Lident name) loc)) - -let mkpatvar name pos = - Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos)) - -(* - Ghost expressions and patterns: - expressions and patterns that do not appear explicitly in the - source file they have the loc_ghost flag set to true. - Then the profiler will not try to instrument them and the - -annot option will not try to display their type. - - Every grammar rule that generates an element with a location must - make at most one non-ghost element, the topmost one. - - How to tell whether your location must be ghost: - A location corresponds to a range of characters in the source file. - If the location contains a piece of code that is syntactically - valid (according to the documentation), and corresponds to the - AST node, then the location must be real; in all other cases, - it must be ghost. -*) -let ghexp d = Exp.mk ~loc:(symbol_gloc ()) d -let ghpat d = Pat.mk ~loc:(symbol_gloc ()) d -let ghtyp d = Typ.mk ~loc:(symbol_gloc ()) d -let ghloc d = { txt = d; loc = symbol_gloc () } -let ghstr d = Str.mk ~loc:(symbol_gloc()) d -let ghsig d = Sig.mk ~loc:(symbol_gloc()) d - -let mkinfix arg1 name arg2 = - mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2])) - -let neg_string f = - if String.length f > 0 && f.[0] = '-' - then String.sub f 1 (String.length f - 1) - else "-" ^ f - -let mkuminus name arg = - match name, arg.pexp_desc with - | "-", Pexp_constant(Pconst_integer (n,m)) -> - mkexp(Pexp_constant(Pconst_integer(neg_string n,m))) - | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> - mkexp(Pexp_constant(Pconst_float(neg_string f, m))) - | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) - -let mkuplus name arg = - let desc = arg.pexp_desc in - match name, desc with - | "+", Pexp_constant(Pconst_integer _) - | ("+" | "+."), Pexp_constant(Pconst_float _) -> mkexp desc - | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) - -let mkexp_cons consloc args loc = - Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args)) - -let mkpat_cons consloc args loc = - Pat.mk ~loc (Ppat_construct(mkloc (Lident "::") consloc, Some args)) - -let rec mktailexp nilloc = function - [] -> - let loc = { nilloc with loc_ghost = true } in - let nil = { txt = Lident "[]"; loc = loc } in - Exp.mk ~loc (Pexp_construct (nil, None)) - | e1 :: el -> - let exp_el = mktailexp nilloc el in - let loc = {loc_start = e1.pexp_loc.loc_start; - loc_end = exp_el.pexp_loc.loc_end; - loc_ghost = true} - in - let arg = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in - mkexp_cons {loc with loc_ghost = true} arg loc - -let rec mktailpat nilloc = function - [] -> - let loc = { nilloc with loc_ghost = true } in - let nil = { txt = Lident "[]"; loc = loc } in - Pat.mk ~loc (Ppat_construct (nil, None)) - | p1 :: pl -> - let pat_pl = mktailpat nilloc pl in - let loc = {loc_start = p1.ppat_loc.loc_start; - loc_end = pat_pl.ppat_loc.loc_end; - loc_ghost = true} - in - let arg = Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - mkpat_cons {loc with loc_ghost = true} arg loc - -let mkstrexp e attrs = - { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } - -let mkexp_constraint e (t1, t2) = - match t1, t2 with - | Some t, None -> ghexp(Pexp_constraint(e, t)) - | _, Some t -> ghexp(Pexp_coerce(e, t1, t)) - | None, None -> assert false - -let mkexp_opt_constraint e = function - | None -> e - | Some constraint_ -> mkexp_constraint e constraint_ - -let mkpat_opt_constraint p = function - | None -> p - | Some typ -> mkpat (Ppat_constraint(p, typ)) - -let array_function str name = - ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))) - -let syntax_error () = - raise Syntaxerr.Escape_error - -let unclosed opening_name opening_num closing_name closing_num = - raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name, - rhs_loc closing_num, closing_name))) - -let expecting pos nonterm = - raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm))) - -let not_expecting pos nonterm = - raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm))) - - -let lapply p1 p2 = - if !Clflags.applicative_functors - then Lapply(p1, p2) - else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc()))) - -let exp_of_label lbl pos = - mkexp (Pexp_ident(mkrhs (Lident(Longident.last lbl)) pos)) - -let pat_of_label lbl pos = - mkpat (Ppat_var (mkrhs (Longident.last lbl) pos)) - -let mk_newtypes newtypes exp = - List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) - newtypes exp - -let wrap_type_annotation newtypes core_type body = - let exp = mkexp(Pexp_constraint(body,core_type)) in - let exp = mk_newtypes newtypes exp in - (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type))) - -let wrap_exp_attrs body (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in - match ext with - | None -> body - | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []])) - -let mkexp_attrs d attrs = - wrap_exp_attrs (mkexp d) attrs - -let wrap_typ_attrs typ (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in - match ext with - | None -> typ - | Some id -> ghtyp(Ptyp_extension (id, PTyp typ)) - -let mktyp_attrs d attrs = - wrap_typ_attrs (mktyp d) attrs - -let wrap_pat_attrs pat (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in - match ext with - | None -> pat - | Some id -> ghpat(Ppat_extension (id, PPat (pat, None))) - -let mkpat_attrs d attrs = - wrap_pat_attrs (mkpat d) attrs - -let wrap_class_type_attrs body attrs = - {body with pcty_attributes = attrs @ body.pcty_attributes} -let wrap_mod_attrs body attrs = - {body with pmod_attributes = attrs @ body.pmod_attributes} -let wrap_mty_attrs body attrs = - {body with pmty_attributes = attrs @ body.pmty_attributes} - -let wrap_str_ext body ext = - match ext with - | None -> body - | Some id -> ghstr(Pstr_extension ((id, PStr [body]), [])) - -let mkstr_ext d ext = - wrap_str_ext (mkstr d) ext - -let wrap_sig_ext body ext = - match ext with - | None -> body - | Some id -> ghsig(Psig_extension ((id, PSig [body]), [])) - -let mksig_ext d ext = - wrap_sig_ext (mksig d) ext - -let text_str pos = Str.text (rhs_text pos) -let text_sig pos = Sig.text (rhs_text pos) -let text_cstr pos = Cf.text (rhs_text pos) -let text_csig pos = Ctf.text (rhs_text pos) - - -let extra_text text pos items = - let pre_extras = rhs_pre_extra_text pos in - let post_extras = rhs_post_extra_text pos in - text pre_extras @ items @ text post_extras - -let extra_str pos items = extra_text Str.text pos items -let extra_sig pos items = extra_text Sig.text pos items -let extra_cstr pos items = extra_text Cf.text pos items -let extra_csig pos items = extra_text Ctf.text pos items - -let extra_rhs_core_type ct ~pos = - let docs = rhs_info pos in - { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } - -type let_binding = - { lb_pattern: pattern; - lb_expression: expression; - lb_attributes: attributes; - lb_docs: docs Lazy.t; - lb_text: text Lazy.t; - lb_loc: Location.t; } - -type [@warning "-69"] let_bindings = - { lbs_bindings: let_binding list; - lbs_rec: rec_flag; - lbs_extension: string Asttypes.loc option; - lbs_loc: Location.t } - -let mklb first (p, e) attrs = - { lb_pattern = p; - lb_expression = e; - lb_attributes = attrs; - lb_docs = symbol_docs_lazy (); - lb_text = if first then empty_text_lazy - else symbol_text_lazy (); - lb_loc = symbol_rloc (); } - -let mklbs ext rf lb = - { lbs_bindings = [lb]; - lbs_rec = rf; - lbs_extension = ext ; - lbs_loc = symbol_rloc (); } - -let addlb lbs lb = - { lbs with lbs_bindings = lb :: lbs.lbs_bindings } - -let val_of_let_bindings lbs = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - ~docs:(Lazy.force lb.lb_docs) - ~text:(Lazy.force lb.lb_text) - lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - let str = mkstr(Pstr_value(lbs.lbs_rec, List.rev bindings)) in - match lbs.lbs_extension with - | None -> str - | Some id -> ghstr (Pstr_extension((id, PStr [str]), [])) - -let expr_of_let_bindings lbs body = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) - (lbs.lbs_extension, []) - - - -(* Alternatively, we could keep the generic module type in the Parsetree - and extract the package type during type-checking. In that case, - the assertions below should be turned into explicit checks. *) -let package_type_of_module_type pmty = - let err loc s = - raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s))) - in - let map_cstr = function - | Pwith_type (lid, ptyp) -> - let loc = ptyp.ptype_loc in - if ptyp.ptype_params <> [] then - err loc "parametrized types are not supported"; - if ptyp.ptype_cstrs <> [] then - err loc "constrained types are not supported"; - if ptyp.ptype_private <> Public then - err loc "private types are not supported"; - - (* restrictions below are checked by the 'with_constraint' rule *) - assert (ptyp.ptype_kind = Ptype_abstract); - assert (ptyp.ptype_attributes = []); - let ty = - match ptyp.ptype_manifest with - | Some ty -> ty - | None -> assert false - in - (lid, ty) - | _ -> - err pmty.pmty_loc "only 'with type t =' constraints are supported" - in - match pmty with - | {pmty_desc = Pmty_ident lid} -> (lid, []) - | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> - (lid, List.map map_cstr cstrs) - | _ -> - err pmty.pmty_loc - "only module type identifier and 'with type' constraints are supported" - - -# 466 "ml/parser.ml" -let yytransl_const = [| - 257 (* AMPERAMPER *); - 258 (* AMPERSAND *); - 259 (* AND *); - 260 (* AS *); - 261 (* ASSERT *); - 262 (* BACKQUOTE *); - 263 (* BANG *); - 264 (* BAR *); - 265 (* BARBAR *); - 266 (* BARRBRACKET *); - 267 (* BEGIN *); - 269 (* CLASS *); - 270 (* COLON *); - 271 (* COLONCOLON *); - 272 (* COLONEQUAL *); - 273 (* COLONGREATER *); - 274 (* COMMA *); - 275 (* CONSTRAINT *); - 276 (* DO *); - 277 (* DONE *); - 278 (* DOT *); - 279 (* DOTDOT *); - 280 (* DOWNTO *); - 281 (* ELSE *); - 282 (* END *); - 0 (* EOF *); - 283 (* EQUAL *); - 284 (* EXCEPTION *); - 285 (* EXTERNAL *); - 286 (* FALSE *); - 288 (* FOR *); - 289 (* FUN *); - 290 (* FUNCTION *); - 291 (* FUNCTOR *); - 292 (* GREATER *); - 293 (* GREATERRBRACE *); - 294 (* GREATERRBRACKET *); - 295 (* IF *); - 296 (* IN *); - 297 (* INCLUDE *); - 304 (* INHERIT *); - 305 (* INITIALIZER *); - 308 (* LAZY *); - 309 (* LBRACE *); - 310 (* LBRACELESS *); - 311 (* LBRACKET *); - 312 (* LBRACKETBAR *); - 313 (* LBRACKETLESS *); - 314 (* LBRACKETGREATER *); - 315 (* LBRACKETPERCENT *); - 316 (* LBRACKETPERCENTPERCENT *); - 317 (* LESS *); - 318 (* LESSMINUS *); - 319 (* LET *); - 321 (* LPAREN *); - 322 (* LBRACKETAT *); - 323 (* LBRACKETATAT *); - 324 (* LBRACKETATATAT *); - 325 (* MATCH *); - 326 (* METHOD *); - 327 (* MINUS *); - 328 (* MINUSDOT *); - 329 (* MINUSGREATER *); - 330 (* MODULE *); - 331 (* MUTABLE *); - 332 (* NEW *); - 333 (* NONREC *); - 334 (* OBJECT *); - 335 (* OF *); - 336 (* OPEN *); - 338 (* OR *); - 339 (* PERCENT *); - 340 (* PLUS *); - 341 (* PLUSDOT *); - 342 (* PLUSEQ *); - 344 (* PRIVATE *); - 345 (* QUESTION *); - 346 (* QUOTE *); - 347 (* RBRACE *); - 348 (* RBRACKET *); - 349 (* REC *); - 350 (* RPAREN *); - 351 (* SEMI *); - 352 (* SEMISEMI *); - 353 (* HASH *); - 355 (* SIG *); - 356 (* STAR *); - 358 (* STRUCT *); - 359 (* THEN *); - 360 (* TILDE *); - 361 (* TO *); - 362 (* TRUE *); - 363 (* TRY *); - 364 (* TYPE *); - 366 (* UNDERSCORE *); - 367 (* VAL *); - 368 (* VIRTUAL *); - 369 (* WHEN *); - 370 (* WHILE *); - 371 (* WITH *); - 374 (* EOL *); - 0|] - -let yytransl_block = [| - 268 (* CHAR *); - 287 (* FLOAT *); - 298 (* INFIXOP0 *); - 299 (* INFIXOP1 *); - 300 (* INFIXOP2 *); - 301 (* INFIXOP3 *); - 302 (* INFIXOP4 *); - 303 (* DOTOP *); - 306 (* INT *); - 307 (* LABEL *); - 320 (* LIDENT *); - 337 (* OPTLABEL *); - 343 (* PREFIXOP *); - 354 (* HASHOP *); - 357 (* STRING *); - 365 (* UIDENT *); - 372 (* COMMENT *); - 373 (* DOCSTRING *); - 0|] - -let yylhs = "\255\255\ -\001\000\002\000\003\000\004\000\005\000\011\000\011\000\012\000\ -\012\000\014\000\014\000\015\000\015\000\015\000\015\000\015\000\ -\015\000\015\000\015\000\015\000\018\000\018\000\018\000\018\000\ -\018\000\018\000\018\000\018\000\018\000\018\000\018\000\006\000\ -\006\000\024\000\024\000\024\000\025\000\025\000\025\000\025\000\ -\025\000\025\000\025\000\025\000\025\000\025\000\025\000\025\000\ -\025\000\025\000\037\000\041\000\041\000\041\000\032\000\033\000\ -\033\000\042\000\043\000\013\000\013\000\013\000\013\000\013\000\ -\013\000\013\000\013\000\013\000\013\000\013\000\007\000\007\000\ -\007\000\046\000\046\000\046\000\046\000\046\000\046\000\046\000\ -\046\000\046\000\046\000\046\000\046\000\046\000\046\000\035\000\ -\052\000\054\000\054\000\054\000\049\000\050\000\051\000\051\000\ -\055\000\056\000\057\000\057\000\034\000\059\000\059\000\061\000\ -\062\000\062\000\062\000\063\000\063\000\064\000\064\000\064\000\ -\064\000\064\000\064\000\065\000\065\000\065\000\065\000\066\000\ -\066\000\066\000\066\000\066\000\075\000\075\000\075\000\075\000\ -\075\000\075\000\075\000\078\000\079\000\079\000\080\000\080\000\ -\081\000\081\000\081\000\081\000\081\000\081\000\082\000\082\000\ -\082\000\085\000\067\000\036\000\036\000\086\000\087\000\009\000\ -\009\000\009\000\009\000\089\000\089\000\089\000\089\000\089\000\ -\089\000\089\000\089\000\094\000\094\000\091\000\091\000\090\000\ -\090\000\092\000\093\000\093\000\021\000\021\000\021\000\021\000\ -\021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ -\021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ -\021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ -\021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ -\021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ -\021\000\021\000\021\000\021\000\021\000\021\000\021\000\021\000\ -\021\000\021\000\021\000\021\000\021\000\021\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\096\000\096\000\096\000\096\000\ -\096\000\096\000\096\000\096\000\097\000\097\000\115\000\115\000\ -\116\000\116\000\116\000\116\000\117\000\074\000\074\000\118\000\ -\118\000\118\000\118\000\118\000\118\000\026\000\026\000\123\000\ -\124\000\126\000\126\000\073\000\073\000\073\000\100\000\100\000\ -\127\000\127\000\127\000\101\000\101\000\101\000\101\000\102\000\ -\102\000\111\000\111\000\129\000\129\000\129\000\130\000\130\000\ -\114\000\114\000\132\000\132\000\112\000\112\000\070\000\070\000\ -\070\000\070\000\070\000\131\000\131\000\010\000\010\000\010\000\ -\010\000\010\000\010\000\010\000\010\000\010\000\010\000\121\000\ -\121\000\121\000\121\000\121\000\121\000\121\000\121\000\121\000\ -\134\000\134\000\134\000\134\000\095\000\095\000\122\000\122\000\ -\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ -\122\000\122\000\122\000\122\000\122\000\122\000\122\000\122\000\ -\122\000\122\000\122\000\122\000\138\000\138\000\138\000\138\000\ -\138\000\138\000\138\000\133\000\133\000\133\000\135\000\135\000\ -\135\000\140\000\140\000\139\000\139\000\139\000\139\000\141\000\ -\141\000\142\000\142\000\028\000\143\000\143\000\027\000\029\000\ -\029\000\144\000\145\000\149\000\149\000\148\000\148\000\148\000\ -\148\000\148\000\148\000\148\000\148\000\148\000\148\000\148\000\ -\147\000\147\000\147\000\152\000\153\000\153\000\155\000\155\000\ -\156\000\154\000\154\000\154\000\157\000\060\000\060\000\150\000\ -\150\000\150\000\158\000\159\000\031\000\031\000\048\000\098\000\ -\161\000\161\000\161\000\161\000\162\000\162\000\151\000\151\000\ -\151\000\164\000\165\000\030\000\047\000\167\000\167\000\167\000\ -\167\000\167\000\167\000\168\000\168\000\168\000\169\000\170\000\ -\171\000\172\000\045\000\045\000\173\000\173\000\173\000\173\000\ -\174\000\174\000\120\000\120\000\071\000\071\000\166\000\166\000\ -\008\000\008\000\175\000\175\000\177\000\177\000\177\000\177\000\ -\177\000\128\000\128\000\179\000\179\000\179\000\179\000\179\000\ -\179\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ -\179\000\179\000\179\000\179\000\179\000\179\000\022\000\183\000\ -\183\000\184\000\184\000\182\000\182\000\186\000\186\000\187\000\ -\187\000\185\000\185\000\178\000\178\000\076\000\076\000\163\000\ -\163\000\180\000\180\000\180\000\180\000\180\000\180\000\180\000\ -\190\000\188\000\189\000\068\000\110\000\110\000\110\000\110\000\ -\136\000\136\000\136\000\136\000\136\000\058\000\058\000\119\000\ -\119\000\119\000\119\000\119\000\191\000\191\000\191\000\191\000\ -\191\000\191\000\191\000\191\000\191\000\191\000\191\000\191\000\ -\191\000\191\000\191\000\191\000\191\000\191\000\191\000\191\000\ -\191\000\191\000\191\000\191\000\191\000\191\000\191\000\191\000\ -\191\000\160\000\160\000\160\000\160\000\160\000\160\000\109\000\ -\109\000\103\000\103\000\103\000\103\000\103\000\103\000\103\000\ -\108\000\108\000\137\000\137\000\016\000\016\000\176\000\176\000\ -\176\000\044\000\044\000\077\000\077\000\181\000\181\000\104\000\ -\125\000\125\000\146\000\146\000\105\000\105\000\072\000\072\000\ -\069\000\069\000\084\000\084\000\083\000\083\000\083\000\083\000\ -\083\000\053\000\053\000\099\000\099\000\113\000\113\000\106\000\ -\106\000\107\000\107\000\192\000\192\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\192\000\192\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\192\000\192\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\192\000\192\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\192\000\192\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\192\000\192\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\192\000\192\000\192\000\088\000\088\000\ -\019\000\194\000\039\000\023\000\023\000\017\000\017\000\040\000\ -\040\000\040\000\020\000\038\000\193\000\193\000\193\000\193\000\ -\193\000\000\000\000\000\000\000\000\000\000\000" - -let yylen = "\002\000\ -\002\000\002\000\002\000\002\000\002\000\002\000\005\000\001\000\ -\001\000\002\000\001\000\001\000\004\000\004\000\005\000\002\000\ -\003\000\001\000\002\000\001\000\005\000\005\000\003\000\003\000\ -\005\000\007\000\009\000\007\000\006\000\006\000\005\000\003\000\ -\001\000\000\000\002\000\002\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\002\000\001\000\004\000\002\000\004\000\002\000\005\000\001\000\ -\002\000\006\000\005\000\001\000\004\000\004\000\005\000\003\000\ -\003\000\005\000\003\000\003\000\001\000\002\000\000\000\002\000\ -\002\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\002\000\001\000\005\000\ -\004\000\002\000\006\000\003\000\005\000\006\000\001\000\002\000\ -\007\000\006\000\000\000\002\000\006\000\000\000\003\000\002\000\ -\003\000\005\000\000\000\000\000\002\000\003\000\003\000\004\000\ -\004\000\002\000\001\000\007\000\007\000\006\000\007\000\007\000\ -\007\000\005\000\008\000\011\000\004\000\001\000\004\000\004\000\ -\002\000\001\000\007\000\002\000\003\000\000\000\000\000\002\000\ -\004\000\004\000\007\000\004\000\002\000\001\000\005\000\005\000\ -\003\000\003\000\003\000\001\000\002\000\009\000\008\000\001\000\ -\002\000\003\000\005\000\005\000\002\000\005\000\002\000\004\000\ -\002\000\002\000\001\000\001\000\001\000\000\000\002\000\001\000\ -\003\000\001\000\001\000\003\000\001\000\002\000\003\000\007\000\ -\006\000\007\000\004\000\004\000\007\000\006\000\006\000\005\000\ -\001\000\002\000\002\000\007\000\005\000\006\000\010\000\003\000\ -\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ -\003\000\003\000\003\000\003\000\003\000\003\000\003\000\003\000\ -\003\000\003\000\003\000\003\000\002\000\002\000\005\000\007\000\ -\007\000\007\000\007\000\007\000\009\000\009\000\009\000\003\000\ -\003\000\003\000\004\000\004\000\002\000\001\000\001\000\001\000\ -\001\000\001\000\003\000\003\000\004\000\003\000\004\000\004\000\ -\003\000\005\000\004\000\005\000\005\000\005\000\005\000\005\000\ -\005\000\005\000\005\000\005\000\005\000\005\000\007\000\007\000\ -\007\000\007\000\007\000\007\000\005\000\003\000\003\000\005\000\ -\005\000\004\000\004\000\002\000\006\000\004\000\006\000\004\000\ -\004\000\006\000\004\000\006\000\002\000\002\000\003\000\003\000\ -\002\000\005\000\004\000\005\000\003\000\003\000\005\000\007\000\ -\006\000\009\000\008\000\001\000\001\000\002\000\001\000\001\000\ -\002\000\002\000\002\000\002\000\001\000\001\000\002\000\002\000\ -\004\000\007\000\008\000\003\000\005\000\001\000\002\000\005\000\ -\004\000\001\000\003\000\002\000\002\000\005\000\001\000\003\000\ -\003\000\005\000\003\000\002\000\004\000\002\000\005\000\003\000\ -\003\000\003\000\001\000\001\000\003\000\002\000\004\000\002\000\ -\002\000\003\000\003\000\001\000\001\000\003\000\002\000\004\000\ -\002\000\002\000\002\000\001\000\000\000\003\000\003\000\001\000\ -\003\000\003\000\003\000\003\000\003\000\002\000\001\000\003\000\ -\003\000\001\000\003\000\003\000\003\000\003\000\002\000\001\000\ -\001\000\002\000\002\000\003\000\001\000\001\000\001\000\001\000\ -\003\000\001\000\001\000\002\000\001\000\003\000\004\000\004\000\ -\005\000\005\000\004\000\003\000\003\000\005\000\005\000\004\000\ -\005\000\007\000\007\000\001\000\003\000\003\000\004\000\004\000\ -\004\000\002\000\004\000\003\000\003\000\003\000\003\000\003\000\ -\003\000\001\000\003\000\001\000\002\000\004\000\003\000\004\000\ -\002\000\002\000\000\000\006\000\001\000\002\000\008\000\001\000\ -\002\000\008\000\007\000\003\000\000\000\000\000\002\000\003\000\ -\002\000\003\000\002\000\003\000\005\000\005\000\005\000\007\000\ -\000\000\001\000\003\000\002\000\001\000\003\000\002\000\001\000\ -\002\000\000\000\001\000\001\000\002\000\001\000\003\000\001\000\ -\001\000\002\000\003\000\004\000\001\000\007\000\006\000\003\000\ -\000\000\002\000\004\000\002\000\001\000\003\000\001\000\001\000\ -\002\000\005\000\007\000\009\000\009\000\001\000\001\000\001\000\ -\001\000\002\000\002\000\001\000\001\000\002\000\003\000\004\000\ -\004\000\005\000\001\000\003\000\006\000\005\000\004\000\004\000\ -\001\000\002\000\002\000\003\000\001\000\003\000\001\000\003\000\ -\001\000\002\000\001\000\004\000\001\000\006\000\004\000\005\000\ -\003\000\001\000\003\000\002\000\001\000\001\000\002\000\004\000\ -\003\000\002\000\002\000\003\000\005\000\003\000\004\000\005\000\ -\004\000\002\000\004\000\006\000\005\000\001\000\001\000\001\000\ -\003\000\001\000\001\000\005\000\002\000\001\000\000\000\001\000\ -\003\000\001\000\002\000\001\000\003\000\001\000\003\000\001\000\ -\003\000\002\000\002\000\001\000\001\000\001\000\001\000\001\000\ -\004\000\006\000\002\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\002\000\002\000\002\000\002\000\001\000\001\000\001\000\ -\003\000\003\000\002\000\003\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\003\000\004\000\003\000\004\000\003\000\004\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\002\000\002\000\003\000\001\000\001\000\001\000\ -\003\000\001\000\005\000\002\000\002\000\003\000\001\000\001\000\ -\001\000\003\000\001\000\003\000\001\000\003\000\001\000\003\000\ -\004\000\001\000\003\000\001\000\003\000\001\000\003\000\002\000\ -\000\000\001\000\000\000\001\000\001\000\001\000\000\000\001\000\ -\000\000\001\000\000\000\001\000\000\000\001\000\001\000\002\000\ -\002\000\000\000\001\000\000\000\001\000\000\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\001\000\ -\001\000\001\000\001\000\001\000\001\000\001\000\001\000\003\000\ -\004\000\004\000\004\000\000\000\002\000\000\000\002\000\000\000\ -\002\000\003\000\004\000\004\000\001\000\002\000\002\000\002\000\ -\004\000\002\000\002\000\002\000\002\000\002\000" - -let yydefred = "\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\054\002\000\000\000\000\000\000\111\002\056\002\ -\000\000\000\000\000\000\000\000\000\000\053\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\152\002\153\002\000\000\000\000\000\000\154\002\ -\155\002\000\000\000\000\055\002\112\002\000\000\000\000\117\002\ -\230\000\000\000\000\000\226\002\000\000\000\000\000\000\036\001\ -\000\000\033\000\000\000\000\000\038\000\039\000\000\000\041\000\ -\042\000\043\000\000\000\045\000\046\000\000\000\048\000\000\000\ -\050\000\056\000\205\001\000\000\148\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\231\000\232\000\104\002\054\001\168\001\ -\000\000\000\000\000\000\000\000\000\000\227\002\000\000\075\000\ -\074\000\000\000\082\000\083\000\000\000\000\000\087\000\000\000\ -\077\000\078\000\079\000\080\000\000\000\084\000\095\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\119\002\005\002\228\002\000\000\022\002\000\000\006\002\ -\249\001\000\000\000\000\253\001\000\000\229\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\064\002\000\000\000\000\ -\000\000\000\000\119\001\230\002\000\000\000\000\140\001\113\001\ -\000\000\000\000\057\002\117\001\118\001\000\000\103\001\000\000\ -\125\001\000\000\000\000\000\000\000\000\063\002\062\002\128\002\ -\022\001\233\000\234\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\075\001\000\000\025\001\052\002\000\000\000\000\ -\000\000\108\002\000\000\000\000\012\001\000\000\158\002\159\002\ -\160\002\161\002\162\002\163\002\164\002\165\002\166\002\167\002\ -\168\002\169\002\170\002\171\002\172\002\173\002\174\002\175\002\ -\176\002\177\002\178\002\179\002\180\002\181\002\182\002\156\002\ -\183\002\184\002\185\002\186\002\187\002\188\002\189\002\190\002\ -\191\002\192\002\193\002\194\002\195\002\196\002\197\002\198\002\ -\199\002\200\002\201\002\157\002\202\002\203\002\204\002\205\002\ -\206\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\067\002\094\002\093\002\000\000\092\002\000\000\095\002\088\002\ -\090\002\070\002\071\002\072\002\073\002\074\002\000\000\089\002\ -\000\000\000\000\000\000\091\002\097\002\000\000\000\000\096\002\ -\000\000\109\002\081\002\087\002\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\147\002\000\000\021\001\035\000\000\000\ -\000\000\000\000\000\000\001\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\229\000\ -\000\000\036\000\000\000\000\000\000\000\055\001\000\000\169\001\ -\000\000\057\000\000\000\149\000\049\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\037\001\040\001\000\000\000\000\000\000\213\000\214\000\000\000\ -\000\000\000\000\072\000\000\000\002\000\086\000\073\000\000\000\ -\096\000\000\000\115\002\000\000\027\002\000\000\000\000\149\002\ -\000\000\018\002\000\000\048\002\010\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\045\002\000\000\000\000\000\000\000\000\ -\000\000\000\000\004\002\126\002\000\000\011\002\003\000\250\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\007\002\004\000\ -\000\000\000\000\113\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\146\001\000\000\082\002\000\000\086\002\000\000\000\000\ -\084\002\069\002\000\000\059\002\058\002\061\002\060\002\124\001\ -\000\000\000\000\000\000\000\000\005\000\102\001\000\000\114\001\ -\115\001\000\000\000\000\000\000\000\000\217\002\000\000\000\000\ -\000\000\000\000\238\000\000\000\000\000\102\002\000\000\000\000\ -\103\002\098\002\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\163\000\122\001\123\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\018\000\020\000\ -\000\000\000\000\000\000\000\000\000\000\092\001\000\000\007\001\ -\006\001\000\000\000\000\024\001\023\001\000\000\081\001\000\000\ -\000\000\000\000\000\000\000\000\221\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\130\002\000\000\110\002\000\000\000\000\ -\000\000\068\002\000\000\236\000\235\000\000\000\066\002\065\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\108\000\ -\000\000\000\000\132\002\000\000\000\000\000\000\000\000\032\000\ -\213\002\000\000\000\000\000\000\000\000\000\000\118\002\105\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\154\000\000\000\ -\000\000\175\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\045\001\043\001\029\001\000\000\042\001\038\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\069\000\060\000\ -\122\002\000\000\000\000\000\000\000\000\000\000\026\002\000\000\ -\024\002\000\000\029\002\014\002\000\000\000\000\000\000\000\000\ -\051\002\009\002\042\002\043\002\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\040\002\000\000\116\002\120\002\000\000\ -\000\000\000\000\012\002\101\001\116\001\000\000\000\000\000\000\ -\142\001\141\001\000\000\000\000\000\000\000\000\000\000\133\001\ -\000\000\132\001\095\001\094\001\100\001\000\000\098\001\000\000\ -\150\001\000\000\000\000\000\000\126\001\000\000\121\001\000\000\ -\218\002\215\002\000\000\000\000\000\000\241\000\000\000\000\000\ -\000\000\239\000\237\000\140\002\000\000\099\002\000\000\100\002\ -\000\000\000\000\000\000\000\000\085\002\000\000\083\002\000\000\ -\000\000\162\000\000\000\164\000\000\000\165\000\159\000\170\000\ -\000\000\157\000\000\000\161\000\000\000\000\000\000\000\000\000\ -\180\000\000\000\000\000\063\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\016\000\019\000\051\000\000\000\000\000\074\001\ -\090\001\000\000\091\001\000\000\000\000\077\001\000\000\082\001\ -\000\000\017\001\016\001\011\001\010\001\222\002\000\000\000\000\ -\219\002\208\002\220\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\112\001\000\000\000\000\000\000\000\000\ -\000\000\240\000\211\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\228\000\227\000\000\000\000\000\ -\000\000\000\000\196\001\195\001\000\000\186\001\000\000\000\000\ -\000\000\000\000\000\000\027\001\000\000\019\001\000\000\014\001\ -\000\000\000\000\000\000\243\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\070\000\089\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\015\002\030\002\000\000\000\000\ -\000\000\019\002\017\002\000\000\000\000\000\000\247\001\000\000\ -\000\000\000\000\000\000\000\000\008\002\000\000\000\000\127\002\ -\000\000\000\000\121\002\252\001\114\002\000\000\000\000\000\000\ -\159\001\000\000\144\001\143\001\147\001\145\001\000\000\136\001\ -\000\000\127\001\131\001\128\001\000\000\209\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\101\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\210\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\068\001\070\001\000\000\000\000\ -\000\000\000\000\011\000\000\000\000\000\024\000\000\000\023\000\ -\000\000\017\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\056\001\000\000\000\000\000\000\000\000\048\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\111\001\000\000\000\000\ -\080\002\078\002\076\002\000\000\031\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\006\000\008\000\009\000\000\000\054\000\ -\055\000\000\000\105\000\000\000\000\000\000\000\000\000\000\000\ -\115\000\109\000\088\000\184\000\000\000\189\001\000\000\000\000\ -\000\000\000\000\192\001\188\001\000\000\000\000\210\002\009\001\ -\008\001\028\001\026\001\000\000\000\000\107\002\000\000\244\000\ -\242\000\155\000\057\001\000\000\000\000\000\000\005\001\248\000\ -\000\000\246\000\000\000\000\000\000\000\000\000\000\000\254\000\ -\000\000\250\000\000\000\252\000\000\000\000\000\068\000\067\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\235\001\000\000\ -\123\002\000\000\000\000\000\000\000\000\000\000\093\000\000\000\ -\000\000\025\002\032\002\000\000\016\002\034\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\021\002\013\002\000\000\041\002\ -\000\000\151\002\158\001\000\000\137\001\135\001\134\001\130\001\ -\129\001\247\000\245\000\000\000\000\000\000\000\253\000\249\000\ -\251\000\000\000\000\000\198\001\000\000\138\002\000\000\000\000\ -\215\001\000\000\000\000\000\000\000\000\207\001\000\000\134\002\ -\133\002\000\000\047\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\160\000\000\000\000\000\067\001\065\001\000\000\064\001\ -\000\000\000\000\010\000\000\000\000\000\014\000\013\000\000\000\ -\225\002\177\000\208\001\000\000\000\000\000\000\000\000\060\001\ -\000\000\000\000\000\000\058\001\061\001\105\001\104\001\110\001\ -\000\000\108\001\000\000\153\001\000\000\052\001\000\000\000\000\ -\033\001\000\000\000\000\000\000\101\000\058\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\114\000\ -\000\000\000\000\187\001\000\000\173\001\000\000\191\001\164\001\ -\190\000\020\001\018\001\015\001\013\001\000\000\173\001\059\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\062\000\061\000\000\000\000\000\000\000\ -\000\000\094\000\092\000\000\000\000\000\000\000\000\000\028\002\ -\020\002\035\002\248\001\244\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\103\000\000\000\193\001\000\000\000\000\ -\214\001\217\001\211\001\000\000\206\001\000\000\000\000\000\000\ -\181\000\000\000\167\000\158\000\156\000\000\000\069\001\000\000\ -\000\000\000\000\000\000\031\000\000\000\000\000\025\000\022\000\ -\021\000\176\000\178\000\000\000\000\000\000\000\049\001\000\000\ -\000\000\032\001\000\000\000\000\106\000\000\000\000\000\000\000\ -\000\000\111\000\000\000\110\000\190\001\000\000\179\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\200\001\201\001\ -\000\000\000\000\136\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\004\001\000\000\000\001\000\000\002\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\236\001\ -\097\000\000\000\000\000\098\000\033\002\050\002\139\001\138\001\ -\003\001\255\000\001\001\199\001\197\001\000\000\000\000\124\002\ -\000\000\130\000\000\000\126\000\000\000\000\000\166\001\167\001\ -\000\000\071\001\066\001\029\000\000\000\030\000\000\000\000\000\ -\000\000\000\000\059\001\053\001\007\000\000\000\112\000\113\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\180\001\ -\000\000\000\000\000\000\000\000\202\001\000\000\000\000\170\001\ -\000\000\000\000\000\000\222\001\223\001\224\001\225\001\035\001\ -\000\000\171\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\228\001\ -\229\001\000\000\000\000\000\000\129\000\150\000\000\000\000\000\ -\000\000\000\000\026\000\028\000\000\000\000\000\062\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\203\001\000\000\172\001\000\000\000\000\000\000\220\001\ -\226\001\227\001\034\001\151\000\000\000\000\000\000\000\238\001\ -\242\001\173\001\091\000\000\000\221\001\230\001\000\000\000\000\ -\000\000\000\000\135\000\125\002\000\000\191\000\000\000\000\000\ -\050\001\000\000\000\000\000\000\122\000\000\000\000\000\000\000\ -\000\000\204\001\183\001\000\000\000\000\181\001\000\000\000\000\ -\000\000\000\000\231\001\000\000\125\000\000\000\000\000\128\000\ -\127\000\000\000\000\000\027\000\051\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\118\000\000\000\000\000\ -\000\000\000\000\232\001\233\001\000\000\133\000\000\000\000\000\ -\000\000\000\000\000\000\142\000\136\000\219\001\120\000\121\000\ -\000\000\000\000\000\000\000\000\000\000\119\000\184\001\234\001\ -\000\000\000\000\000\000\000\000\000\000\141\000\000\000\123\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\140\000\137\000\144\002\145\002\ -\000\000\000\000\000\000\000\000\138\000\000\000\000\000\000\000\ -\000\000\000\000\124\000\000\000\000\000\000\000\139\000\000\000\ -\000\000" - -let yydgoto = "\006\000\ -\052\000\094\000\124\000\134\000\148\000\245\001\095\000\153\005\ -\054\000\171\001\250\002\175\003\065\003\132\003\200\002\055\000\ -\190\001\223\001\072\001\056\000\057\000\066\003\046\001\058\000\ -\059\000\136\000\061\000\062\000\063\000\064\000\065\000\066\000\ -\067\000\068\000\069\000\070\000\071\000\072\000\073\000\000\001\ -\251\002\074\000\082\001\088\002\238\003\104\000\105\000\075\000\ -\107\000\108\000\109\000\110\000\037\001\049\003\111\000\113\001\ -\168\003\089\002\102\003\026\004\015\002\016\002\255\002\186\003\ -\103\004\101\004\199\004\076\000\031\004\075\004\154\005\213\004\ -\076\004\117\003\003\005\136\001\004\005\114\005\115\005\146\005\ -\173\005\203\005\199\005\165\002\092\005\077\000\084\001\250\000\ -\192\002\120\003\047\004\121\003\119\003\183\002\152\000\078\000\ -\096\001\228\002\121\001\195\002\193\002\079\000\080\000\081\000\ -\042\004\082\000\083\000\185\000\084\000\085\000\186\000\196\000\ -\239\001\192\000\097\001\098\001\074\002\232\002\086\000\155\005\ -\234\002\157\000\087\000\078\001\253\001\077\004\196\002\127\000\ -\187\000\188\000\231\001\193\000\158\000\159\000\237\002\160\000\ -\128\000\161\000\158\001\161\001\159\001\128\002\167\004\088\000\ -\080\001\020\002\005\003\109\004\218\004\214\004\032\004\006\003\ -\191\003\007\003\196\003\028\004\158\004\215\004\216\004\217\004\ -\172\002\106\003\107\003\033\004\034\004\062\003\043\005\063\005\ -\044\005\045\005\046\005\047\005\239\003\059\005\129\000\130\000\ -\131\000\132\000\133\000\129\001\142\001\095\002\096\002\097\002\ -\255\003\055\003\252\003\130\001\131\001\132\001\030\001\251\000\ -\246\001\047\001" - -let yysindex = "\180\007\ -\119\061\200\008\016\047\124\064\160\067\000\000\076\004\241\002\ -\244\009\076\004\000\000\236\254\076\004\076\004\000\000\000\000\ -\076\004\076\004\076\004\076\004\076\004\000\000\076\004\044\067\ -\174\002\205\061\037\062\122\057\122\057\068\003\000\000\232\054\ -\122\057\076\004\000\000\000\000\036\004\076\004\106\000\000\000\ -\000\000\244\009\119\061\000\000\000\000\076\004\076\004\000\000\ -\000\000\076\004\076\004\000\000\254\000\102\000\157\000\000\000\ -\225\072\000\000\222\005\236\255\000\000\000\000\241\000\000\000\ -\000\000\000\000\017\001\000\000\000\000\024\002\000\000\102\000\ -\000\000\000\000\000\000\089\001\000\000\034\069\015\002\244\009\ -\244\009\124\064\124\064\000\000\000\000\000\000\000\000\000\000\ -\076\004\076\004\036\004\200\008\076\004\000\000\140\003\000\000\ -\000\000\241\000\000\000\000\000\024\002\102\000\000\000\200\008\ -\000\000\000\000\000\000\000\000\113\002\000\000\000\000\145\007\ -\220\002\050\255\122\009\044\003\165\016\016\047\054\003\241\002\ -\021\003\000\000\000\000\000\000\038\000\000\000\023\003\000\000\ -\000\000\115\001\232\000\000\000\061\002\000\000\216\004\236\255\ -\076\004\076\004\035\003\163\066\226\066\000\000\088\059\018\004\ -\129\004\086\003\000\000\000\000\067\000\251\003\000\000\000\000\ -\160\067\160\067\000\000\000\000\000\000\039\004\000\000\107\004\ -\000\000\122\057\122\057\033\004\244\009\000\000\000\000\000\000\ -\000\000\000\000\000\000\122\062\076\004\041\002\097\005\160\067\ -\040\066\220\002\124\064\019\002\244\009\000\000\188\004\113\001\ -\212\002\117\255\000\000\127\004\000\000\000\000\246\004\165\002\ -\224\004\000\000\073\073\248\004\000\000\248\004\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\032\061\080\005\032\061\076\004\076\004\106\000\022\005\ -\000\000\000\000\000\000\244\009\000\000\036\005\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\083\005\000\000\ -\000\000\000\000\165\000\000\000\000\000\000\000\000\000\000\000\ -\244\009\000\000\000\000\000\000\184\255\130\255\032\061\124\064\ -\076\004\160\255\070\005\000\000\076\004\000\000\000\000\124\064\ -\069\005\097\005\124\064\000\000\122\057\222\005\102\000\225\004\ -\124\064\124\064\124\064\124\064\124\064\124\064\124\064\124\064\ -\124\064\124\064\124\064\124\064\124\064\124\064\124\064\124\064\ -\124\064\124\064\124\064\124\064\124\064\207\062\124\064\000\000\ -\076\004\000\000\173\005\033\004\124\064\000\000\033\004\000\000\ -\033\004\000\000\033\004\000\000\000\000\124\064\104\003\099\005\ -\244\009\244\009\150\005\157\005\244\009\150\005\119\002\041\069\ -\000\000\000\000\124\064\119\002\119\002\000\000\000\000\041\002\ -\219\003\168\004\000\000\069\005\000\000\000\000\000\000\033\004\ -\000\000\174\004\000\000\017\255\000\000\138\005\235\005\000\000\ -\174\004\000\000\174\004\000\000\000\000\000\000\233\005\163\005\ -\231\005\043\017\043\017\000\000\016\047\076\004\033\004\183\000\ -\198\005\004\006\000\000\000\000\255\005\000\000\000\000\000\000\ -\090\008\094\003\170\005\194\005\016\047\021\003\000\000\000\000\ -\160\067\168\068\000\000\010\006\034\006\203\255\224\005\037\004\ -\236\005\000\000\236\005\000\000\018\004\000\000\165\000\129\004\ -\000\000\000\000\076\001\000\000\000\000\000\000\000\000\000\000\ -\053\002\152\013\239\059\044\060\000\000\000\000\144\003\000\000\ -\000\000\160\067\076\003\032\061\033\004\000\000\033\004\119\002\ -\189\004\102\005\000\000\205\001\227\005\000\000\251\005\158\000\ -\000\000\000\000\009\002\006\070\077\006\128\003\168\068\011\058\ -\104\002\136\005\205\005\188\065\000\000\000\000\000\000\160\067\ -\241\005\033\004\141\001\033\004\115\005\072\006\000\000\000\000\ -\119\002\143\005\035\003\070\006\214\007\000\000\078\006\000\000\ -\000\000\035\003\124\064\000\000\000\000\157\005\000\000\124\064\ -\118\255\051\003\200\073\160\067\000\000\020\006\122\057\023\006\ -\041\002\009\006\076\004\000\000\229\050\000\000\022\006\028\006\ -\029\006\000\000\019\002\000\000\000\000\038\006\000\000\000\000\ -\041\006\027\006\241\002\037\006\178\002\160\067\232\002\000\000\ -\043\006\032\006\000\000\029\005\122\006\123\006\032\061\000\000\ -\000\000\044\067\116\003\036\063\124\063\087\055\000\000\000\000\ -\166\073\166\073\134\073\247\007\073\073\134\073\239\009\239\009\ -\239\009\239\009\089\002\104\006\104\006\239\009\089\002\089\002\ -\134\073\104\006\089\002\089\002\089\002\122\057\000\000\104\006\ -\229\050\000\000\029\005\044\006\227\005\073\073\124\064\124\064\ -\124\064\170\004\092\006\124\064\124\064\124\064\119\002\119\002\ -\000\000\000\000\000\000\218\004\000\000\000\000\134\073\027\001\ -\033\004\219\003\048\006\033\004\000\000\211\002\000\000\000\000\ -\000\000\123\002\055\006\186\002\029\005\057\006\000\000\199\255\ -\000\000\155\006\000\000\000\000\174\004\091\001\211\255\062\048\ -\000\000\000\000\000\000\000\000\096\006\219\003\016\047\159\002\ -\016\047\016\047\119\003\000\000\071\006\000\000\000\000\021\001\ -\241\002\097\006\000\000\000\000\000\000\121\003\016\047\148\006\ -\000\000\000\000\053\003\160\067\029\000\108\005\067\006\000\000\ -\097\011\000\000\000\000\000\000\000\000\179\002\000\000\162\006\ -\000\000\173\000\031\067\178\059\000\000\173\000\000\000\094\006\ -\000\000\000\000\124\064\124\064\235\004\000\000\124\064\124\064\ -\124\064\000\000\000\000\000\000\132\006\000\000\095\006\000\000\ -\019\015\074\002\019\015\033\004\000\000\188\006\000\000\016\047\ -\124\064\000\000\126\006\000\000\160\067\000\000\000\000\000\000\ -\127\006\000\000\127\006\000\000\090\008\122\058\124\064\188\065\ -\000\000\108\000\184\006\000\000\124\064\130\006\033\004\073\001\ -\119\061\155\001\000\000\000\000\000\000\087\006\000\000\000\000\ -\000\000\161\000\000\000\033\004\124\064\000\000\073\073\000\000\ -\073\073\000\000\000\000\000\000\000\000\000\000\033\004\243\000\ -\000\000\000\000\000\000\157\006\027\001\178\002\043\006\102\000\ -\100\065\068\005\190\006\000\000\187\006\146\006\149\006\153\006\ -\021\002\000\000\000\000\220\002\191\006\178\002\219\003\019\002\ -\078\003\178\002\102\000\007\002\000\000\000\000\169\001\201\003\ -\091\005\103\004\000\000\000\000\176\003\000\000\244\254\016\047\ -\124\064\125\006\221\255\000\000\255\002\000\000\248\004\000\000\ -\248\004\128\006\165\000\000\000\165\255\124\064\102\000\156\006\ -\178\002\132\006\073\073\038\005\063\000\190\255\162\005\124\064\ -\085\070\117\070\195\070\130\006\094\255\145\006\200\008\219\003\ -\129\002\000\000\000\000\186\003\212\006\219\003\043\006\214\004\ -\102\000\176\003\214\006\174\004\000\000\000\000\016\047\057\000\ -\224\006\000\000\000\000\241\002\057\255\033\004\000\000\016\047\ -\180\001\137\006\033\004\021\003\000\000\097\006\159\006\000\000\ -\090\008\124\006\000\000\000\000\000\000\033\004\160\067\142\006\ -\000\000\037\004\000\000\000\000\000\000\000\000\149\000\000\000\ -\223\255\000\000\000\000\000\000\208\001\000\000\098\000\245\255\ -\181\005\227\070\049\071\081\071\103\004\174\006\000\000\164\006\ -\000\000\172\006\071\006\158\006\169\000\225\006\033\004\000\000\ -\102\000\144\000\182\255\126\006\154\006\125\005\226\006\226\006\ -\237\006\166\006\179\006\126\006\000\000\000\000\210\063\124\064\ -\160\067\041\073\000\000\044\005\124\064\000\000\219\003\000\000\ -\030\003\000\000\016\047\073\073\124\064\124\064\033\004\216\006\ -\060\255\000\000\028\009\124\064\233\058\234\006\000\000\161\065\ -\059\002\105\060\166\060\227\060\124\064\000\000\016\047\160\067\ -\000\000\000\000\000\000\015\000\000\000\160\067\219\003\102\000\ -\102\000\175\001\226\005\000\000\000\000\000\000\248\006\000\000\ -\000\000\016\047\000\000\033\004\033\004\106\000\106\000\102\000\ -\000\000\000\000\000\000\000\000\160\067\000\000\217\000\236\006\ -\180\006\241\002\000\000\000\000\234\005\244\006\000\000\000\000\ -\000\000\000\000\000\000\110\000\122\005\000\000\019\002\000\000\ -\000\000\000\000\000\000\236\006\102\000\203\006\000\000\000\000\ -\206\006\000\000\210\006\124\064\124\064\124\064\073\073\000\000\ -\211\006\000\000\217\006\000\000\223\006\199\005\000\000\000\000\ -\033\004\120\004\180\001\043\006\029\005\015\007\000\000\000\000\ -\000\000\219\003\180\001\201\003\061\001\008\007\000\000\200\006\ -\219\003\000\000\000\000\087\001\000\000\000\000\074\255\000\000\ -\016\047\241\002\193\006\097\006\000\000\000\000\016\047\000\000\ -\037\004\000\000\000\000\219\003\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\124\064\124\064\124\064\000\000\000\000\ -\000\000\228\255\201\006\000\000\007\007\000\000\157\005\208\006\ -\000\000\164\006\090\008\184\000\102\000\000\000\204\006\000\000\ -\000\000\124\064\000\000\188\065\016\047\124\064\209\006\215\006\ -\016\047\000\000\124\064\218\006\000\000\000\000\219\006\000\000\ -\124\064\019\002\000\000\174\069\097\255\000\000\000\000\033\004\ -\000\000\000\000\000\000\124\064\124\064\126\006\046\001\000\000\ -\126\006\124\064\019\007\000\000\000\000\000\000\000\000\000\000\ -\179\002\000\000\162\006\000\000\173\000\000\000\088\003\173\000\ -\000\000\227\006\184\006\180\001\000\000\000\000\019\002\219\003\ -\255\254\016\047\124\064\033\004\102\000\033\004\102\000\000\000\ -\184\006\103\004\000\000\162\011\000\000\229\006\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\108\002\000\000\000\000\ -\036\007\124\064\124\064\168\071\200\071\022\072\124\064\124\064\ -\124\064\219\003\019\002\000\000\000\000\202\005\035\003\129\002\ -\211\002\000\000\000\000\219\003\229\006\211\002\016\047\000\000\ -\000\000\000\000\000\000\000\000\033\004\097\006\001\000\054\072\ -\132\072\164\072\103\004\000\000\241\002\000\000\131\005\053\007\ -\000\000\000\000\000\000\055\007\000\000\204\006\102\000\048\007\ -\000\000\033\004\000\000\000\000\000\000\033\004\000\000\188\065\ -\124\064\073\073\226\005\000\000\094\000\082\001\000\000\000\000\ -\000\000\000\000\000\000\049\007\016\047\239\006\000\000\124\064\ -\124\064\000\000\226\005\161\003\000\000\125\003\102\000\102\000\ -\174\255\000\000\187\003\000\000\000\000\041\002\000\000\249\006\ -\222\069\229\045\000\000\222\003\021\007\070\007\000\000\000\000\ -\027\001\054\255\000\000\252\000\015\003\054\255\131\005\073\073\ -\073\073\000\000\018\007\000\000\022\007\000\000\024\007\073\073\ -\073\073\073\073\180\001\226\005\170\005\170\005\046\005\000\000\ -\000\000\105\004\048\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\016\047\001\007\000\000\ -\033\004\000\000\234\005\000\000\254\002\062\048\000\000\000\000\ -\124\064\000\000\000\000\000\000\202\000\000\000\250\006\016\047\ -\238\003\161\065\000\000\000\000\000\000\016\047\000\000\000\000\ -\233\006\229\006\157\005\235\006\164\006\157\005\027\001\000\000\ -\033\004\070\007\229\006\164\006\000\000\033\004\016\047\000\000\ -\041\002\030\002\193\001\000\000\000\000\000\000\000\000\000\000\ -\254\006\000\000\234\005\124\064\124\064\124\064\007\003\007\003\ -\016\047\005\007\016\047\061\001\041\002\027\001\008\002\000\000\ -\000\000\099\000\106\000\029\007\000\000\000\000\194\003\033\004\ -\079\007\219\003\000\000\000\000\065\004\124\064\000\000\033\004\ -\157\005\157\005\013\066\157\005\157\005\110\005\033\004\093\255\ -\010\007\000\000\090\004\000\000\106\002\074\002\033\004\000\000\ -\000\000\000\000\000\000\000\000\073\073\073\073\073\073\000\000\ -\000\000\000\000\000\000\027\001\000\000\000\000\213\003\033\004\ -\016\047\135\004\000\000\000\000\009\007\000\000\011\007\124\064\ -\000\000\092\007\093\007\060\017\000\000\094\007\097\007\124\064\ -\085\007\000\000\000\000\164\006\070\007\000\000\016\047\074\002\ -\033\004\033\004\000\000\096\007\000\000\043\006\083\001\000\000\ -\000\000\037\002\033\004\000\000\000\000\062\048\062\048\126\006\ -\033\004\086\007\075\001\016\047\016\047\000\000\124\064\025\007\ -\033\004\033\004\000\000\000\000\039\005\000\000\033\004\033\004\ -\033\004\033\004\102\000\000\000\000\000\000\000\000\000\000\000\ -\095\007\124\064\016\047\033\004\033\004\000\000\000\000\000\000\ -\131\005\016\047\131\005\139\001\009\003\000\000\016\047\000\000\ -\033\004\033\004\102\000\234\005\006\007\032\007\157\005\227\005\ -\164\006\107\007\102\000\091\004\000\000\000\000\000\000\000\000\ -\109\007\157\005\157\005\016\047\000\000\124\064\062\048\110\007\ -\111\007\033\004\000\000\102\000\016\047\016\047\000\000\033\004\ -\033\004" - -let yyrindex = "\000\000\ -\126\008\127\008\000\000\000\000\000\000\000\000\106\069\000\000\ -\000\000\039\064\000\000\000\000\214\002\242\005\000\000\000\000\ -\221\067\101\066\099\067\209\064\139\003\000\000\106\069\000\000\ -\000\000\000\000\000\000\000\000\000\000\248\067\193\017\000\000\ -\000\000\209\064\000\000\000\000\200\004\096\000\042\004\000\000\ -\000\000\000\000\060\000\000\000\000\000\209\064\225\007\000\000\ -\000\000\242\005\209\064\000\000\000\000\021\043\103\016\000\000\ -\136\044\000\000\060\000\120\043\000\000\000\000\067\044\000\000\ -\000\000\000\000\081\053\000\000\000\000\102\053\000\000\021\043\ -\000\000\000\000\000\000\000\000\000\000\035\025\221\027\058\024\ -\174\024\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\214\002\099\004\200\004\062\000\225\007\000\000\000\000\000\000\ -\000\000\218\012\000\000\000\000\111\053\146\053\000\000\062\000\ -\000\000\000\000\000\000\000\000\167\053\000\000\000\000\000\000\ -\113\005\113\005\000\000\188\012\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\240\016\000\000\ -\000\000\000\000\151\015\000\000\163\014\000\000\000\000\000\000\ -\221\067\229\068\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\014\049\000\000\000\000\ -\255\001\098\003\000\000\000\000\000\000\050\005\000\000\125\049\ -\000\000\000\000\000\000\117\054\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\221\001\000\000\000\000\000\000\ -\000\000\053\068\000\000\000\000\000\000\135\255\016\002\000\000\ -\214\255\000\000\000\000\076\000\000\000\000\000\069\255\000\000\ -\040\004\000\000\215\255\131\000\000\000\245\005\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\038\007\004\054\038\007\214\002\026\007\042\004\080\068\ -\000\000\000\000\000\000\012\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\028\056\114\056\139\003\000\000\000\000\200\056\030\057\000\000\ -\014\000\000\000\000\000\000\000\000\000\000\000\038\007\000\000\ -\217\003\000\000\008\003\000\000\026\007\000\000\000\000\000\000\ -\084\006\000\000\000\000\000\000\000\000\060\000\132\050\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\057\034\000\000\000\000\ -\248\067\000\000\120\043\141\068\000\000\000\000\041\005\000\000\ -\031\007\000\000\055\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\221\022\151\025\ -\000\000\000\000\000\000\011\026\128\026\000\000\000\000\000\000\ -\000\000\000\000\000\000\084\006\000\000\000\000\000\000\031\007\ -\000\000\000\000\000\000\125\001\000\000\120\007\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\147\255\000\000\098\007\ -\000\000\102\007\116\007\000\000\000\000\099\004\180\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\045\000\000\000\194\000\090\000\ -\131\000\000\000\245\005\000\000\066\000\000\000\026\007\101\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\038\007\117\054\000\000\155\048\244\026\ -\000\000\000\000\000\000\000\000\164\005\000\000\000\000\000\000\ -\000\000\000\000\068\017\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\066\007\000\000\198\055\021\043\207\002\000\000\000\000\ -\104\027\000\000\000\000\000\000\000\000\000\000\085\255\000\000\ -\000\000\196\000\000\000\000\000\000\000\069\004\000\000\162\000\ -\000\000\000\000\041\007\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\026\007\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\001\003\000\000\000\000\038\007\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\096\037\205\037\053\038\174\034\208\039\157\038\034\035\150\035\ -\011\036\127\036\127\031\081\028\197\028\243\036\244\031\104\032\ -\005\039\058\029\220\032\081\033\197\033\000\000\000\000\174\029\ -\000\000\000\000\111\003\000\000\164\005\051\040\000\000\000\000\ -\000\000\000\000\082\018\000\000\000\000\000\000\081\023\198\023\ -\000\000\000\000\000\000\105\022\000\000\000\000\109\039\025\053\ -\066\007\000\000\000\000\005\004\030\006\146\053\000\000\000\000\ -\000\000\000\000\000\000\000\000\001\003\000\000\000\000\000\000\ -\000\000\193\049\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\246\044\ -\000\000\000\000\000\000\000\000\205\045\000\000\000\000\000\000\ -\000\000\048\046\000\000\000\000\000\000\000\000\000\000\102\255\ -\000\000\000\000\222\000\162\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\202\006\000\000\093\005\ -\000\000\225\003\000\000\000\000\000\000\165\005\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\090\007\000\000\000\000\000\000\ -\000\000\000\000\000\000\238\039\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\034\030\000\000\000\000\000\000\038\065\000\000\ -\169\004\000\000\000\000\000\000\000\000\000\000\025\001\000\000\ -\000\000\084\255\000\000\169\255\000\000\000\000\185\255\000\000\ -\097\000\000\000\000\000\000\000\000\000\000\000\064\007\065\007\ -\000\000\000\000\000\000\000\000\136\003\000\000\000\000\213\005\ -\182\004\000\000\074\006\000\000\191\002\105\000\139\000\143\000\ -\000\000\000\000\000\000\053\068\185\040\000\000\000\000\000\000\ -\000\000\000\000\021\043\000\000\000\000\000\000\234\004\021\043\ -\053\068\228\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\131\000\000\000\ -\245\005\000\000\139\003\000\000\000\000\000\000\213\005\000\000\ -\000\000\090\007\000\000\198\006\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\018\005\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\146\053\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\047\002\000\000\000\000\ -\087\255\000\000\210\000\000\000\000\000\147\046\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\197\000\000\000\229\000\ -\000\000\125\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\068\007\000\000\000\000\099\007\ -\012\050\000\000\074\050\000\000\000\000\040\011\238\039\000\000\ -\021\043\000\000\000\000\174\001\000\000\049\255\073\007\073\007\ -\068\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\089\045\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\136\255\000\000\000\000\122\007\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\021\043\ -\028\041\000\000\127\010\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\050\038\065\139\004\225\002\136\004\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\163\051\ -\000\000\000\000\000\000\000\000\021\043\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\016\052\028\041\000\000\000\000\000\000\ -\198\018\000\000\058\019\000\000\000\000\000\000\155\040\000\000\ -\175\019\000\000\035\020\000\000\151\020\000\000\000\000\000\000\ -\235\003\000\000\162\050\000\000\001\003\240\047\000\000\119\007\ -\000\000\000\000\191\047\146\053\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\125\001\000\000\000\000\000\000\190\057\ -\000\000\000\000\128\007\248\046\000\000\000\000\000\000\000\000\ -\186\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\048\004\000\000\000\000\021\043\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\220\255\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\012\005\000\000\125\004\000\000\203\004\000\000\000\000\062\005\ -\000\000\000\000\151\030\231\041\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\120\003\136\004\058\003\136\004\000\000\ -\011\031\228\001\000\000\115\007\000\000\063\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\069\007\000\000\000\000\000\000\063\001\069\007\000\000\000\000\ -\000\000\000\000\000\000\000\000\229\015\091\047\000\000\000\000\ -\000\000\000\000\068\007\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\074\042\021\043\000\000\ -\000\000\103\001\000\000\000\000\000\000\148\001\000\000\000\000\ -\000\000\254\040\175\008\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\026\012\000\000\000\000\000\000\136\004\136\004\ -\108\007\000\000\099\007\000\000\000\000\000\000\000\000\000\000\ -\000\000\118\007\199\049\069\052\000\000\122\052\000\000\000\000\ -\249\050\028\041\000\000\000\000\000\000\028\041\000\000\097\041\ -\201\041\000\000\012\021\000\000\128\021\000\000\244\021\044\042\ -\143\042\247\042\049\051\042\048\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\044\001\000\000\028\041\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\112\007\108\007\000\000\114\007\099\007\000\000\249\050\000\000\ -\178\052\208\052\056\006\099\007\000\000\219\051\000\000\000\000\ -\000\000\092\052\021\043\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\028\041\000\000\000\000\000\000\106\010\238\013\ -\000\000\156\050\000\000\000\000\000\000\028\015\146\053\000\000\ -\000\000\000\000\115\003\193\002\000\000\000\000\000\000\249\004\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\111\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\219\051\000\000\ -\000\000\000\000\000\000\000\000\092\052\000\000\139\039\000\000\ -\000\000\000\000\000\000\000\000\090\043\189\043\037\044\000\000\ -\000\000\000\000\000\000\028\015\000\000\000\000\000\000\031\007\ -\000\000\000\000\000\000\000\000\082\007\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\099\007\008\053\000\000\000\000\000\000\ -\139\039\139\039\000\000\241\015\000\000\000\000\000\000\000\000\ -\000\000\019\005\161\004\000\000\000\000\000\000\000\000\000\000\ -\168\255\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\181\047\139\039\000\000\000\000\000\000\000\000\000\050\021\006\ -\120\003\058\003\243\004\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\032\002\071\003\000\000\000\000\000\000\ -\000\000\000\000\000\000\117\007\000\000\000\000\000\000\000\000\ -\182\002\105\051\243\004\243\004\125\007\126\007\000\000\130\007\ -\099\007\000\000\243\004\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\196\003\000\000\243\004\000\000\000\000\000\000\212\003\ -\237\004" - -let yygindex = "\000\000\ -\000\000\000\000\000\000\000\000\000\000\020\000\183\255\037\000\ -\168\000\184\005\119\253\000\000\166\254\147\005\096\255\145\008\ -\232\012\061\254\077\005\253\255\063\014\144\252\036\003\247\255\ -\000\000\046\000\016\000\021\000\027\000\000\000\000\000\000\000\ -\000\000\030\000\035\000\040\000\000\000\255\255\003\000\093\009\ -\084\002\000\000\000\000\000\000\000\000\000\000\000\000\041\000\ -\000\000\000\000\000\000\000\000\010\255\059\252\000\000\000\000\ -\000\000\004\000\148\005\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\010\003\056\000\112\251\081\255\136\253\214\251\ -\048\253\185\252\087\251\199\003\087\003\000\000\000\000\000\000\ -\000\000\000\000\000\000\211\253\000\000\000\000\000\000\042\000\ -\082\255\014\006\085\005\100\005\000\000\000\000\083\255\048\000\ -\000\000\000\000\170\255\035\002\103\253\160\006\187\010\173\011\ -\000\000\000\000\000\000\131\255\000\000\006\013\182\006\006\000\ -\104\255\048\003\121\007\000\000\124\007\165\006\244\010\176\253\ -\000\000\218\000\000\000\000\000\000\000\198\003\090\005\152\255\ -\254\004\000\000\000\000\000\000\000\000\227\000\000\000\034\007\ -\145\255\042\007\081\006\083\008\000\000\000\000\060\004\000\000\ -\000\000\129\007\233\253\016\005\193\251\101\251\000\252\028\253\ -\000\000\204\252\000\000\074\004\000\000\000\000\119\251\088\255\ -\101\253\062\006\091\007\000\000\000\000\232\003\000\000\000\000\ -\253\003\243\252\000\000\200\003\108\004\000\000\179\253\135\002\ -\155\255\000\000\000\000\192\005\147\254\157\255\199\254\151\255\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\055\255\000\000" - -let yytablesize = 19255 -let yytable = "\126\000\ -\102\000\151\000\212\001\213\001\103\000\203\001\119\001\117\001\ -\251\001\230\001\128\001\168\000\118\001\157\001\086\002\026\003\ -\137\001\096\000\107\001\221\001\053\000\151\001\097\000\061\003\ -\151\003\203\002\063\003\123\001\098\000\190\003\111\001\099\000\ -\198\000\162\004\176\001\024\003\100\000\143\001\126\003\125\000\ -\123\002\101\000\106\000\241\001\043\004\242\001\060\000\139\004\ -\027\004\074\001\248\001\090\004\052\004\051\005\034\005\222\004\ -\169\000\120\001\030\005\034\000\131\003\071\000\039\001\102\002\ -\162\000\103\002\181\001\220\004\084\001\050\003\252\000\184\000\ -\039\005\143\003\031\001\171\000\037\005\194\003\001\004\008\000\ -\191\000\206\002\162\000\087\001\080\001\009\002\023\002\173\000\ -\060\000\038\001\102\000\216\001\197\004\231\003\103\000\098\002\ -\184\004\195\003\243\004\069\004\206\004\161\001\102\000\023\002\ -\075\001\084\001\103\000\096\000\126\000\006\002\087\001\126\000\ -\097\000\126\000\126\000\131\005\232\001\218\002\098\000\096\000\ -\045\001\099\000\198\001\139\001\097\000\095\001\100\000\100\001\ -\101\001\007\002\098\000\101\000\106\000\099\000\113\002\079\001\ -\151\000\151\000\100\000\151\000\085\005\122\001\171\000\101\000\ -\106\000\132\005\002\004\199\001\113\002\151\000\151\000\113\002\ -\037\005\135\001\131\003\151\004\064\002\200\001\027\005\162\000\ -\052\002\113\002\162\000\084\001\208\003\145\004\040\003\245\001\ -\089\001\040\003\127\001\135\000\151\000\151\000\087\001\080\001\ -\224\001\087\001\087\001\080\001\023\002\064\002\115\002\004\002\ -\083\001\160\001\245\001\232\003\133\005\218\003\185\004\080\002\ -\161\001\245\001\245\001\089\001\161\001\228\001\201\001\029\001\ -\229\001\202\001\129\002\188\001\189\001\040\004\052\003\233\001\ -\041\003\219\002\115\002\041\003\192\001\093\001\085\001\245\001\ -\245\001\067\002\052\003\088\001\200\003\083\001\014\004\008\002\ -\085\001\113\002\079\001\245\001\225\001\113\002\079\001\064\002\ -\064\002\251\003\245\001\245\001\125\002\245\001\076\001\082\005\ -\093\001\115\002\152\002\115\002\218\003\155\004\088\001\037\003\ -\088\005\064\002\059\004\037\005\012\002\044\001\188\004\115\002\ -\247\004\190\004\209\003\089\001\203\002\025\005\089\001\089\001\ -\133\002\117\001\134\002\082\002\013\002\069\002\089\004\194\005\ -\117\001\196\005\117\001\077\001\160\001\005\002\245\001\083\001\ -\160\001\128\001\128\001\219\003\083\003\026\005\041\004\109\002\ -\162\000\178\002\053\003\089\005\024\002\130\002\213\001\060\000\ -\116\002\060\000\140\005\056\003\163\001\203\002\059\003\122\002\ -\093\001\081\002\085\001\169\000\093\001\085\001\088\001\201\003\ -\211\005\088\001\088\001\034\000\015\004\071\000\216\003\156\004\ -\052\003\085\002\071\004\158\002\013\005\015\005\177\001\163\001\ -\038\001\028\000\178\001\076\001\060\000\010\003\166\000\082\002\ -\229\002\179\001\019\004\196\001\180\001\034\000\023\002\071\000\ -\083\002\154\001\217\001\075\001\059\004\012\005\248\004\216\002\ -\086\001\216\003\241\002\154\001\083\002\087\002\027\004\162\000\ -\079\002\082\002\086\001\069\002\049\005\114\004\126\000\177\001\ -\036\001\084\002\216\002\178\001\111\002\126\000\107\005\126\000\ -\084\003\216\002\179\001\085\002\155\001\180\001\126\000\126\000\ -\081\002\126\000\150\002\160\005\162\000\205\004\155\001\163\001\ -\071\002\072\002\077\002\163\001\076\002\126\000\075\002\095\001\ -\216\002\126\000\169\004\075\002\253\003\151\000\151\000\034\000\ -\028\000\071\000\217\003\216\002\170\003\166\000\082\002\085\002\ -\216\002\151\002\012\004\216\002\002\002\216\002\076\001\083\002\ -\045\001\222\002\039\004\151\002\167\002\162\000\151\000\151\000\ -\151\000\139\003\048\001\147\004\127\003\154\001\151\000\006\001\ -\154\001\127\001\127\001\179\001\086\001\018\004\111\005\086\001\ -\084\002\156\001\083\002\078\001\162\001\038\002\079\002\010\002\ -\111\002\115\004\085\002\151\000\151\000\235\003\216\002\018\002\ -\151\000\162\000\022\002\243\003\151\000\135\004\006\004\224\001\ -\155\001\119\005\074\005\155\001\128\003\157\001\150\002\162\001\ -\126\000\126\000\162\000\039\002\150\002\065\005\162\000\203\002\ -\077\002\060\000\106\004\148\001\075\002\055\002\162\000\126\000\ -\151\000\102\000\013\004\079\001\058\002\103\000\177\001\163\000\ -\164\004\151\000\178\001\168\002\117\001\151\002\122\001\224\001\ -\069\003\179\001\096\000\041\005\180\001\157\001\026\001\097\000\ -\210\002\212\002\151\000\070\003\071\003\098\000\245\002\038\002\ -\099\000\038\002\213\001\081\001\112\002\100\000\010\005\223\002\ -\114\002\198\001\101\000\106\000\156\001\097\005\078\001\162\001\ -\226\002\015\003\017\003\162\001\031\002\191\000\114\002\075\005\ -\169\002\114\002\074\003\214\002\061\004\039\002\064\002\039\002\ -\149\001\110\005\199\001\114\002\162\000\151\000\107\004\061\005\ -\157\001\150\003\152\003\213\001\200\001\038\005\214\002\150\002\ -\105\003\245\004\116\002\189\004\060\000\214\002\135\002\064\002\ -\134\003\184\000\046\003\136\002\092\004\198\001\087\002\177\001\ -\177\005\014\005\191\000\178\001\123\003\147\001\135\003\171\003\ -\143\004\137\002\179\001\214\002\135\002\180\001\168\000\022\003\ -\179\005\126\000\052\003\141\003\126\000\201\001\199\001\214\002\ -\202\001\171\002\087\002\126\000\214\002\126\000\126\000\214\002\ -\200\001\214\002\075\003\114\002\081\002\135\002\204\003\114\002\ -\205\003\064\002\064\002\126\000\076\003\048\003\057\003\135\002\ -\151\000\172\000\125\005\087\005\214\002\126\000\193\001\002\004\ -\146\001\202\002\162\000\064\002\028\000\162\000\095\005\151\000\ -\151\000\166\000\082\002\067\003\162\000\193\003\086\001\137\004\ -\162\000\201\001\214\002\083\002\202\001\166\003\142\004\194\001\ -\214\002\168\000\095\005\078\003\002\004\126\000\136\003\126\000\ -\135\002\138\002\189\003\135\002\126\000\089\003\169\000\218\001\ -\166\005\151\000\203\002\147\001\084\002\061\003\058\003\011\004\ -\063\003\126\000\151\000\180\003\151\000\218\001\085\002\100\004\ -\102\004\137\005\248\003\046\001\172\000\021\003\224\001\028\000\ -\041\005\095\004\250\003\117\001\162\002\219\001\012\000\016\004\ -\137\005\092\001\093\001\177\001\114\003\028\000\235\002\178\001\ -\214\002\181\003\004\004\219\001\137\003\234\003\179\001\236\002\ -\008\004\180\001\197\005\227\001\029\000\151\000\163\002\029\003\ -\030\003\152\003\213\001\104\005\033\000\106\005\182\003\203\002\ -\162\000\169\000\220\001\087\002\224\001\162\000\060\000\040\003\ -\138\003\048\000\198\005\199\002\040\003\184\003\122\001\203\002\ -\220\001\185\003\122\001\045\001\126\000\196\004\122\001\048\000\ -\122\001\199\002\177\001\046\001\122\001\122\001\178\001\061\005\ -\122\001\162\000\235\002\216\002\178\003\179\001\169\002\183\003\ -\180\001\122\001\083\001\236\002\216\002\175\005\176\005\116\000\ -\099\001\041\003\164\003\170\002\087\002\102\000\041\003\235\004\ -\203\002\103\000\087\002\169\002\197\003\017\004\118\004\241\003\ -\126\000\242\004\116\000\126\000\139\002\218\001\096\000\167\005\ -\094\005\116\000\078\004\097\000\126\000\194\001\106\002\000\004\ -\122\001\098\000\095\003\096\003\099\000\126\000\198\001\122\001\ -\162\000\100\000\045\001\151\000\216\002\028\000\101\000\106\000\ -\116\000\194\001\214\002\219\001\168\005\202\002\162\000\171\002\ -\115\003\122\001\122\001\116\000\122\001\122\001\220\005\199\001\ -\029\000\123\001\116\000\116\000\179\003\116\000\125\003\015\000\ -\033\000\200\001\169\005\085\001\171\002\214\002\147\000\122\001\ -\106\002\106\002\165\003\112\001\142\000\204\001\214\002\169\002\ -\220\001\221\004\142\000\204\001\115\001\151\000\213\001\048\000\ -\108\003\147\000\106\002\087\002\136\005\060\001\061\001\126\000\ -\147\000\110\001\109\003\109\001\193\001\214\002\116\000\126\000\ -\044\003\151\000\201\001\170\005\151\000\202\001\151\000\151\000\ -\151\000\179\004\210\005\126\000\151\000\150\001\147\000\147\000\ -\087\002\150\004\151\000\087\002\236\001\194\001\214\002\180\002\ -\181\002\122\000\147\000\066\001\202\002\162\000\126\000\064\004\ -\198\003\147\000\147\000\045\000\147\000\246\001\048\000\210\002\ -\171\002\151\000\163\004\147\001\071\001\210\003\195\004\247\002\ -\134\000\179\001\106\001\087\004\180\001\111\004\106\001\046\003\ -\246\001\237\001\236\003\224\001\248\002\106\001\012\000\246\001\ -\246\001\012\000\189\000\134\000\047\003\182\002\097\004\092\001\ -\093\001\106\001\134\000\012\000\012\000\147\000\115\001\012\000\ -\149\001\228\001\236\004\120\001\229\001\246\001\246\001\253\002\ -\012\000\012\000\012\000\012\000\237\003\190\000\087\002\090\002\ -\134\000\246\001\249\002\216\002\162\000\087\002\012\000\012\000\ -\246\001\246\001\048\003\246\001\134\000\126\000\202\003\068\003\ -\106\001\254\002\213\001\126\000\134\000\148\004\134\000\107\000\ -\087\002\239\004\012\000\122\000\216\002\012\000\048\005\012\000\ -\012\000\012\000\012\000\071\005\162\000\045\001\216\002\012\000\ -\012\000\120\002\107\000\040\003\074\003\062\004\012\000\126\000\ -\146\002\107\000\146\002\203\003\246\001\031\005\054\004\055\004\ -\151\000\126\000\012\000\146\002\012\000\126\000\012\000\134\000\ -\166\000\081\002\220\002\042\005\065\004\066\004\224\001\063\004\ -\107\000\133\001\012\000\072\004\221\002\012\000\147\001\216\002\ -\185\001\012\000\216\002\107\000\086\004\041\003\117\000\147\001\ -\190\000\028\000\062\005\107\000\112\005\107\000\166\000\082\002\ -\146\002\170\004\025\002\200\005\140\001\174\004\160\004\011\000\ -\083\002\117\000\194\001\224\001\087\002\167\000\126\000\253\000\ -\117\000\123\001\155\001\152\003\213\001\123\001\119\001\117\001\ -\126\000\123\001\016\000\123\001\118\001\185\001\194\001\123\001\ -\123\001\084\002\193\004\123\001\155\001\138\001\107\000\117\000\ -\201\005\214\002\145\001\085\002\123\001\022\000\087\002\224\001\ -\093\005\048\000\117\000\177\001\214\002\162\000\198\004\178\001\ -\087\002\117\000\117\000\126\000\117\000\254\000\179\001\048\000\ -\212\004\180\001\144\000\255\000\108\005\115\001\163\000\022\005\ -\012\003\162\000\177\002\002\005\063\002\118\002\064\002\145\000\ -\253\004\048\000\080\003\123\001\152\003\213\001\129\005\155\001\ -\065\002\214\002\123\001\172\003\151\000\216\002\185\001\209\001\ -\044\000\087\002\087\002\190\000\146\002\117\000\072\003\214\002\ -\077\003\126\000\173\003\174\003\123\001\123\001\162\000\123\001\ -\123\001\162\000\122\000\145\000\139\000\216\002\147\002\141\000\ -\194\001\209\001\119\002\216\002\126\000\126\000\126\000\214\002\ -\148\002\168\004\123\001\144\000\048\000\171\004\145\000\152\001\ -\090\002\087\002\175\004\002\005\194\001\145\000\206\002\146\002\ -\149\001\017\005\162\000\031\002\149\001\031\002\144\000\214\002\ -\149\001\040\003\149\001\186\004\187\004\144\000\149\001\192\003\ -\216\002\191\004\149\001\145\000\090\002\135\001\033\005\216\002\ -\035\005\166\000\126\000\149\001\031\002\081\002\021\005\145\000\ -\205\002\116\005\126\000\144\000\214\002\028\005\145\000\145\000\ -\078\005\145\000\200\004\045\001\126\000\214\002\151\000\144\000\ -\183\001\214\002\126\000\041\003\000\005\028\000\144\000\144\000\ -\216\002\144\000\166\000\082\002\122\000\216\002\214\002\162\000\ -\214\002\214\002\135\001\126\000\083\002\214\002\240\003\150\002\ -\177\001\149\001\029\005\214\002\178\001\214\002\119\002\162\000\ -\172\001\096\001\145\000\179\001\077\005\126\000\180\001\126\000\ -\186\001\144\003\080\005\149\001\149\001\084\002\149\001\149\001\ -\214\002\122\000\144\000\173\001\151\002\216\002\087\002\085\002\ -\214\002\169\003\013\003\091\005\150\002\176\003\214\002\151\000\ -\214\002\149\001\083\005\164\000\214\002\086\005\164\000\214\002\ -\011\005\164\000\164\000\120\005\097\001\164\000\164\000\164\000\ -\164\000\164\000\162\000\164\000\214\002\162\000\162\000\019\005\ -\020\005\151\002\164\000\146\002\213\003\126\000\164\000\137\002\ -\214\002\164\000\164\000\214\002\135\005\214\005\163\000\132\004\ -\126\000\043\003\164\000\164\000\146\002\090\002\164\000\164\000\ -\107\001\187\001\162\000\126\000\107\001\216\002\144\005\212\002\ -\122\005\123\005\216\001\126\005\127\005\162\000\107\001\033\001\ -\171\005\133\004\126\000\126\000\172\005\143\005\146\002\107\001\ -\126\000\126\000\212\002\162\000\162\000\216\002\163\000\174\001\ -\145\005\212\002\216\002\216\002\148\001\164\000\164\000\164\000\ -\034\000\164\000\162\000\161\005\216\002\003\003\090\002\126\000\ -\073\005\040\003\175\001\008\000\090\002\002\005\126\000\002\005\ -\212\002\117\001\004\003\126\000\149\000\117\001\107\001\126\002\ -\180\005\181\005\034\000\212\002\117\001\216\002\060\005\117\001\ -\091\004\144\001\146\002\212\002\146\002\212\002\152\001\216\002\ -\126\000\226\001\152\001\126\000\212\002\164\000\164\000\193\005\ -\031\003\126\000\126\000\041\003\152\001\234\001\198\004\105\004\ -\214\002\182\001\146\002\204\005\112\000\152\001\113\000\114\000\ -\028\000\104\000\115\000\214\002\143\000\115\001\117\000\193\001\ -\191\001\063\002\212\002\155\002\202\005\121\005\212\002\117\001\ -\218\005\164\000\146\002\214\002\155\001\156\002\209\005\143\000\ -\126\002\224\005\225\005\104\000\091\002\212\002\143\000\120\000\ -\194\001\216\005\217\005\146\003\212\002\090\002\121\000\109\001\ -\235\001\071\000\132\000\109\001\092\002\026\002\027\002\028\002\ -\029\002\097\003\122\000\123\000\143\000\062\002\177\003\149\005\ -\142\000\030\002\212\002\187\003\216\002\215\003\109\001\158\005\ -\143\000\048\000\090\002\071\000\132\000\090\002\212\002\143\000\ -\143\000\096\001\143\000\245\003\216\002\096\001\212\002\099\001\ -\212\002\096\001\211\003\096\001\206\002\057\005\238\001\096\001\ -\096\001\151\001\246\003\160\001\160\001\151\001\182\005\153\003\ -\058\005\164\000\164\000\154\003\096\001\031\002\185\005\151\001\ -\184\001\185\001\155\003\214\002\247\003\156\003\240\001\214\002\ -\151\001\192\005\188\003\143\000\097\001\002\003\157\003\164\000\ -\097\001\212\002\120\001\003\003\097\001\247\001\097\001\206\001\ -\214\002\214\002\097\001\085\003\249\002\164\000\097\001\214\002\ -\004\003\164\000\252\001\096\001\058\004\086\003\148\002\097\001\ -\090\002\116\004\096\001\228\001\214\002\219\005\229\001\090\002\ -\177\001\254\001\214\002\117\004\178\001\162\000\014\002\255\001\ -\128\005\000\002\045\004\179\001\096\001\096\001\180\001\096\001\ -\096\001\019\002\090\002\001\002\038\004\164\000\214\002\068\002\ -\191\001\069\002\159\002\191\001\160\002\191\001\097\001\191\001\ -\142\000\204\001\096\001\070\002\148\001\097\001\161\002\148\002\ -\148\001\148\002\148\002\148\002\148\001\148\002\148\001\076\001\ -\148\002\148\002\148\001\202\002\162\000\045\001\148\001\097\001\ -\097\001\254\004\097\001\097\001\191\001\028\000\162\000\148\001\ -\191\001\255\004\000\005\026\002\027\002\028\002\029\002\184\002\ -\185\002\099\001\148\002\093\004\094\004\097\001\207\002\030\002\ -\001\005\148\002\164\000\144\001\212\002\073\002\220\003\212\002\ -\221\003\237\004\139\002\104\004\190\000\148\002\148\002\206\002\ -\208\002\212\002\222\003\139\002\238\004\100\002\090\002\214\002\ -\112\004\020\004\012\000\021\004\182\001\148\001\212\002\122\000\ -\212\002\212\002\101\002\164\000\150\002\022\004\104\002\182\001\ -\120\004\013\000\014\000\031\002\212\002\212\002\150\002\148\001\ -\148\001\105\002\148\001\148\001\182\001\182\001\021\000\249\002\ -\090\002\191\001\106\002\191\001\184\002\187\002\113\002\130\004\ -\212\002\114\002\090\002\212\002\115\002\148\001\122\000\138\004\ -\212\002\029\000\182\001\121\002\073\001\062\002\212\002\126\002\ -\062\002\033\000\202\002\162\000\212\002\005\005\191\001\037\000\ -\191\001\204\002\062\002\162\000\045\001\039\000\062\002\127\002\ -\212\002\216\002\216\002\119\002\212\002\186\002\188\002\062\002\ -\062\002\062\002\062\002\090\002\090\002\043\000\131\002\135\002\ -\212\002\107\002\108\002\212\002\212\002\209\002\062\002\164\000\ -\165\004\047\000\132\002\214\002\050\000\118\001\135\002\214\002\ -\124\002\118\001\164\002\214\002\214\002\135\002\166\002\197\002\ -\118\001\062\002\176\002\118\001\062\002\206\002\119\002\062\002\ -\062\002\062\002\214\002\090\002\118\001\005\005\062\002\062\002\ -\213\002\142\002\144\002\146\002\135\002\062\002\135\002\225\002\ -\238\002\150\002\227\002\055\005\056\005\230\002\062\002\239\002\ -\135\002\062\002\240\002\062\002\112\000\062\002\113\000\114\000\ -\028\000\214\002\115\000\242\002\243\002\116\000\117\000\008\003\ -\202\004\062\002\204\004\118\001\062\002\244\002\009\003\194\002\ -\062\002\246\002\001\003\131\002\131\002\061\001\118\000\048\000\ -\025\003\032\003\131\002\038\003\054\003\191\001\119\000\120\000\ -\191\001\135\002\042\003\045\003\135\002\051\003\121\000\131\002\ -\064\003\149\001\073\003\224\002\241\004\131\002\079\003\087\003\ -\179\001\244\004\122\000\123\000\001\000\002\000\003\000\004\000\ -\005\000\094\003\101\003\002\002\103\003\116\003\184\002\129\003\ -\131\002\131\002\249\002\031\002\142\003\252\002\185\000\185\000\ -\182\001\099\001\008\005\159\003\160\003\099\001\185\000\161\003\ -\090\002\099\001\162\003\099\001\185\000\185\000\163\003\099\001\ -\199\003\167\003\182\001\212\003\182\001\206\003\182\001\233\003\ -\185\000\242\003\182\001\249\003\099\001\008\000\005\004\007\004\ -\119\002\185\000\023\005\024\005\010\004\029\004\030\004\185\000\ -\185\000\185\000\185\000\185\000\035\004\005\005\036\004\044\004\ -\191\001\194\000\049\004\051\004\046\004\040\005\008\000\068\004\ -\114\001\050\005\185\000\050\004\074\004\096\004\108\004\185\000\ -\113\004\110\004\121\004\122\004\185\000\185\000\182\001\123\004\ -\127\004\136\004\099\001\191\001\204\002\140\004\128\004\185\000\ -\185\000\185\000\185\000\185\000\129\004\141\004\144\001\149\004\ -\144\001\159\004\157\004\177\004\099\001\099\001\070\005\099\001\ -\099\001\185\000\161\004\144\001\182\001\192\004\172\004\112\000\ -\166\004\113\000\114\000\028\000\173\004\115\000\158\003\176\004\ -\115\001\117\000\099\001\082\003\219\004\204\002\223\004\005\005\ -\194\004\005\005\006\005\009\005\212\002\018\003\016\005\212\002\ -\182\001\036\005\160\001\093\003\018\005\206\004\096\005\052\005\ -\067\005\212\002\120\000\053\005\166\002\054\005\100\005\076\005\ -\081\005\121\000\084\005\099\005\105\005\113\005\212\002\164\000\ -\212\002\212\002\109\005\118\005\134\005\122\000\123\000\147\005\ -\148\005\150\005\151\005\156\005\118\003\212\002\157\005\159\005\ -\178\005\042\003\039\005\183\005\191\005\207\005\062\002\208\005\ -\212\005\062\002\215\005\221\005\222\005\034\000\071\000\026\002\ -\212\002\034\000\214\002\062\002\071\000\047\002\216\002\062\002\ -\212\002\044\002\191\001\214\002\120\002\042\003\212\002\144\001\ -\062\002\062\002\062\002\062\002\212\002\150\000\008\000\046\002\ -\114\001\102\000\144\001\223\002\224\002\194\001\182\001\062\002\ -\212\002\214\002\137\002\049\002\212\002\144\001\166\000\135\002\ -\183\000\182\001\136\002\135\002\218\001\214\003\015\000\136\002\ -\212\002\138\002\062\002\212\002\141\002\062\002\230\003\120\002\ -\062\002\062\002\062\002\191\001\142\002\143\002\144\001\062\002\ -\062\002\139\002\182\001\195\005\066\005\141\005\062\002\112\000\ -\122\003\113\000\114\000\028\000\048\004\115\000\190\005\011\003\ -\115\001\117\000\062\002\081\003\062\002\211\002\062\002\079\005\ -\078\002\077\002\056\004\191\001\151\002\023\003\028\003\163\001\ -\149\002\007\005\062\002\119\004\252\004\062\002\205\005\206\005\ -\112\003\062\002\120\000\117\002\093\002\072\005\213\005\064\005\ -\000\000\121\000\098\005\240\004\000\000\000\000\042\003\204\002\ -\000\000\000\000\000\000\000\000\000\000\122\000\123\000\223\005\ -\191\001\191\001\000\000\000\000\000\000\052\001\009\004\000\000\ -\000\000\141\001\000\000\000\000\112\000\000\000\113\000\114\000\ -\028\000\144\001\115\000\000\000\000\000\116\000\117\000\000\000\ -\000\000\000\000\000\000\156\001\150\000\150\000\000\000\150\000\ -\216\002\216\002\059\001\060\001\061\001\000\000\118\000\216\002\ -\000\000\150\000\150\000\000\000\000\000\216\002\119\000\120\000\ -\000\000\000\000\000\000\000\000\216\002\191\001\121\000\042\003\ -\194\002\000\000\216\002\000\000\000\000\063\001\064\001\042\003\ -\150\000\150\000\122\000\123\000\222\001\000\000\000\000\000\000\ -\191\001\066\001\067\001\068\001\069\001\216\002\216\002\000\000\ -\000\000\081\004\083\004\085\004\000\000\182\001\000\000\088\004\ -\000\000\000\000\071\001\000\000\000\000\194\002\000\000\000\000\ -\000\000\000\000\000\000\165\000\000\000\000\000\172\000\000\000\ -\000\000\174\000\175\000\000\000\000\000\176\000\177\000\178\000\ -\179\000\180\000\000\000\181\000\194\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\032\001\000\000\ -\000\000\034\001\035\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\042\003\040\001\041\001\144\001\000\000\042\001\043\001\ -\112\000\000\000\113\000\114\000\028\000\000\000\115\000\000\000\ -\000\000\115\001\117\000\000\000\000\000\182\001\000\000\182\001\ -\000\000\182\001\000\000\144\001\182\001\000\000\000\000\000\000\ -\042\003\000\000\000\000\000\000\000\000\144\001\015\000\000\000\ -\191\001\015\000\191\001\120\000\000\000\104\001\105\001\106\001\ -\000\000\108\001\121\000\015\000\015\000\000\000\000\000\015\000\ -\000\000\000\000\204\002\000\000\000\000\000\000\122\000\123\000\ -\015\000\015\000\015\000\015\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\012\000\042\003\015\000\015\000\ -\000\000\000\000\042\003\000\000\000\000\000\000\000\000\000\000\ -\000\000\191\001\000\000\089\000\014\000\153\001\154\001\066\002\ -\000\000\000\000\015\000\000\000\000\000\015\000\000\000\000\000\ -\090\000\015\000\015\000\000\000\000\000\000\000\144\001\015\000\ -\015\000\000\000\144\001\000\000\000\000\000\000\015\000\204\002\ -\000\000\000\000\000\000\029\000\000\000\000\000\000\000\000\000\ -\000\000\197\001\015\000\033\000\015\000\000\000\015\000\204\002\ -\042\003\091\000\144\001\000\000\000\000\000\000\000\000\039\000\ -\000\000\000\000\015\000\209\002\000\000\015\000\000\000\000\000\ -\144\001\015\000\000\000\000\000\000\000\000\000\141\001\092\000\ -\000\000\150\000\150\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\093\000\000\000\000\000\050\000\042\003\ -\204\002\000\000\000\000\000\000\000\000\000\000\042\003\000\000\ -\000\000\000\000\150\000\150\000\150\000\000\000\000\000\000\000\ -\000\000\000\000\150\000\000\000\000\000\191\001\000\000\069\005\ -\000\000\157\002\112\000\000\000\113\000\114\000\028\000\000\000\ -\115\000\249\001\250\001\116\000\117\000\144\001\000\000\150\000\ -\150\000\000\000\000\000\000\000\150\000\000\000\000\000\000\000\ -\150\000\240\001\000\000\222\001\118\000\144\001\000\000\003\002\ -\000\000\000\000\191\001\156\001\119\000\060\003\000\000\000\000\ -\000\000\000\000\156\001\000\000\121\000\011\002\052\000\069\005\ -\000\000\017\002\000\000\000\000\150\000\000\000\000\000\070\004\ -\122\000\123\000\000\000\000\000\000\000\150\000\000\000\000\000\ -\124\001\000\000\000\000\222\001\191\001\000\000\000\000\000\000\ -\000\000\144\001\000\000\000\000\144\001\125\001\150\000\000\000\ -\000\000\000\003\000\000\191\001\000\000\000\000\000\000\144\001\ -\000\000\000\000\183\000\191\001\000\000\000\000\000\000\000\000\ -\112\000\000\000\113\000\114\000\028\000\000\000\115\000\000\000\ -\000\000\126\001\117\000\000\000\191\001\000\000\000\000\153\000\ -\000\000\000\000\000\000\170\000\000\000\000\000\000\000\000\000\ -\000\000\150\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\170\000\120\000\000\000\191\001\191\001\000\000\ -\000\000\000\000\121\000\144\001\000\000\000\000\000\000\191\001\ -\000\000\000\000\110\002\000\000\170\000\144\001\122\000\123\000\ -\000\000\000\000\000\000\000\000\000\000\144\001\191\001\000\000\ -\000\000\000\000\000\000\191\001\191\001\191\001\191\001\000\000\ -\156\000\008\000\009\000\000\000\000\000\052\001\010\000\011\000\ -\144\001\144\001\000\000\135\002\000\000\000\000\000\000\000\000\ -\170\000\000\000\170\000\170\000\000\000\144\001\069\005\000\000\ -\069\005\015\000\016\000\156\001\150\000\000\000\000\000\000\000\ -\144\001\058\001\059\001\060\001\061\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\150\000\150\000\022\000\144\001\106\002\ -\024\000\025\000\026\000\027\000\144\001\144\001\028\000\000\000\ -\162\000\000\000\000\000\142\000\032\000\063\001\064\001\000\000\ -\000\000\000\000\110\003\000\000\000\000\000\000\000\000\000\000\ -\000\000\066\001\067\001\068\001\069\001\150\000\153\000\153\000\ -\000\000\153\000\042\000\000\000\000\000\000\000\150\000\000\000\ -\150\000\000\000\071\001\153\000\153\000\000\000\000\000\231\002\ -\044\000\000\000\222\001\000\000\000\000\045\000\000\000\170\000\ -\048\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\240\001\153\000\214\001\240\001\000\000\000\000\170\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\240\001\145\003\ -\000\000\150\000\240\001\000\000\000\000\000\000\052\000\156\000\ -\156\000\052\000\156\000\240\001\240\001\240\001\240\001\000\000\ -\222\001\000\000\000\000\052\000\156\000\156\000\000\000\000\000\ -\000\000\000\000\240\001\000\000\000\000\000\000\000\000\000\000\ -\052\000\000\000\052\000\052\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\205\001\156\000\156\000\240\001\052\000\052\000\ -\240\001\000\000\000\000\240\001\240\001\240\001\000\000\000\000\ -\000\000\154\000\240\001\240\001\000\000\171\000\000\000\000\000\ -\000\000\240\001\052\000\000\000\000\000\052\000\170\000\244\003\ -\000\000\052\000\052\000\000\000\171\000\240\001\000\000\240\001\ -\052\000\240\001\000\000\000\000\000\000\000\000\052\000\000\000\ -\000\000\000\000\000\000\170\000\141\001\240\001\171\000\000\000\ -\240\001\000\000\052\000\000\000\240\001\000\000\052\000\150\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\052\000\000\000\000\000\052\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\171\000\000\000\171\000\171\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\150\000\000\000\170\000\170\000\000\000\000\000\170\000\ -\000\000\053\000\170\000\000\000\116\001\021\002\000\000\000\000\ -\000\000\000\000\000\000\032\002\000\000\150\000\000\000\106\002\ -\150\000\000\000\150\000\150\000\150\000\000\000\000\000\106\002\ -\150\000\000\000\000\000\000\000\106\002\000\000\150\000\000\000\ -\154\000\154\000\000\000\154\000\000\000\000\000\000\000\000\000\ -\000\000\106\002\000\000\106\002\106\002\154\000\154\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\150\000\000\000\000\000\ -\106\002\171\000\000\000\153\000\214\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\154\000\215\001\000\000\222\001\ -\088\003\171\000\000\000\106\002\000\000\000\000\106\002\000\000\ -\000\000\106\002\106\002\106\002\153\000\153\000\153\000\207\003\ -\000\000\106\002\000\000\000\000\153\000\000\000\000\000\106\002\ -\000\000\000\000\000\000\000\000\134\004\000\000\000\000\000\000\ -\000\000\000\000\000\000\106\002\000\000\000\000\000\000\106\002\ -\000\000\214\001\153\000\000\000\156\000\156\000\214\001\000\000\ -\000\000\000\000\153\000\106\002\000\000\000\000\106\002\112\000\ -\000\000\113\000\114\000\028\000\000\000\115\000\000\000\000\000\ -\116\000\117\000\000\000\000\000\140\002\156\000\156\000\156\000\ -\000\000\206\004\000\000\000\000\000\000\156\000\153\000\000\000\ -\171\000\118\000\000\000\000\000\000\000\000\000\000\000\153\000\ -\207\004\119\000\120\000\115\002\150\000\000\000\000\000\198\001\ -\000\000\121\000\156\000\156\000\000\000\171\000\000\000\156\000\ -\153\000\000\000\222\001\156\000\000\000\122\000\123\000\000\000\ -\000\000\000\000\000\000\000\000\170\000\032\002\000\000\000\000\ -\208\004\076\000\113\000\114\000\028\000\000\000\115\000\000\000\ -\000\000\116\000\209\004\000\000\000\000\000\000\000\000\156\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\222\001\ -\233\002\000\000\118\000\153\000\000\000\000\000\000\000\000\000\ -\000\000\210\004\119\000\120\000\000\000\000\000\000\000\000\000\ -\000\000\156\000\121\000\000\000\000\000\171\000\171\000\000\000\ -\000\000\171\000\155\000\201\001\171\000\000\000\211\004\123\000\ -\000\000\000\000\000\000\222\001\000\000\000\000\000\000\156\001\ -\000\000\053\000\000\000\000\000\053\000\000\000\116\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\116\001\053\000\116\001\ -\000\000\000\000\000\000\000\000\233\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\053\000\000\000\053\000\053\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\153\000\000\000\ -\150\000\053\000\053\000\000\000\000\000\154\000\215\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\153\000\153\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\053\000\000\000\000\000\ -\053\000\000\000\000\000\000\000\053\000\053\000\154\000\154\000\ -\154\000\000\000\000\000\053\000\111\003\000\000\154\000\000\000\ -\000\000\053\000\000\000\000\000\000\000\000\000\000\000\153\000\ -\000\000\000\000\000\000\000\000\000\000\053\000\000\000\156\000\ -\153\000\053\000\214\001\215\001\154\000\000\000\000\000\000\000\ -\215\001\000\000\000\000\000\000\154\000\053\000\156\000\156\000\ -\053\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\155\000\155\000\000\000\155\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\155\000\155\000\ -\154\000\000\000\150\000\214\001\000\000\000\000\000\000\000\000\ -\156\000\154\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\156\000\000\000\156\000\000\000\155\000\155\000\000\000\ -\000\000\000\000\154\000\115\002\000\000\115\002\115\002\115\002\ -\000\000\000\000\000\000\115\002\000\000\000\000\171\000\000\000\ -\115\002\000\000\000\000\000\000\115\002\115\002\115\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\115\002\115\002\115\002\ -\115\002\076\000\000\000\000\000\156\000\000\000\000\000\115\002\ -\000\000\000\000\000\000\150\000\115\002\154\000\076\000\000\000\ -\000\000\000\000\000\000\115\002\115\002\239\001\110\003\000\000\ -\000\000\000\000\000\000\076\000\000\000\076\000\076\000\115\002\ -\000\000\000\000\115\002\115\002\000\000\115\002\115\002\115\002\ -\000\000\115\002\076\000\000\000\115\002\115\002\000\000\000\000\ -\000\000\153\000\000\000\115\002\000\000\000\000\000\000\000\000\ -\000\000\116\001\000\000\000\000\000\000\076\000\115\002\115\002\ -\110\003\115\002\115\002\115\002\115\002\076\000\165\005\115\002\ -\000\000\000\000\000\000\076\000\000\000\000\000\000\000\115\002\ -\115\002\076\000\115\002\000\000\000\000\000\000\115\002\000\000\ -\154\000\000\000\000\000\057\002\000\000\076\000\059\002\000\000\ -\060\002\076\000\061\002\153\000\000\000\000\000\000\000\154\000\ -\154\000\000\000\156\000\000\000\000\000\076\000\000\000\000\000\ -\076\000\000\000\000\000\000\000\000\000\000\000\000\000\153\000\ -\000\000\000\000\214\001\000\000\153\000\153\000\153\000\094\002\ -\195\000\195\000\153\000\099\002\000\000\000\000\000\000\000\000\ -\153\000\154\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\154\000\000\000\215\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\156\000\000\000\000\000\153\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\156\000\000\000\000\000\156\000\079\004\156\000\156\000\156\000\ -\102\001\103\001\000\000\156\000\000\000\215\001\000\000\141\002\ -\000\000\156\000\000\000\000\000\000\000\008\000\155\000\155\000\ -\000\000\000\000\002\002\011\000\153\002\000\000\154\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\156\000\000\000\000\000\137\000\000\000\015\000\016\000\155\000\ -\155\000\155\000\000\000\000\000\000\000\000\000\000\000\155\000\ -\155\000\198\002\000\000\201\002\000\000\000\000\000\000\000\000\ -\000\000\022\000\000\000\138\000\139\000\000\000\140\000\141\000\ -\000\000\000\000\028\000\000\000\155\000\155\000\000\000\142\000\ -\143\000\155\000\000\000\000\000\000\000\155\000\144\000\000\000\ -\116\001\000\000\000\000\000\000\000\000\254\003\214\001\000\000\ -\000\000\000\000\000\000\145\000\000\000\239\001\000\000\000\000\ -\239\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\146\000\155\000\239\001\154\000\044\000\000\000\239\001\000\000\ -\000\000\045\000\155\000\000\000\048\000\147\000\000\000\239\001\ -\239\001\239\001\239\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\155\000\000\000\000\000\239\001\000\000\ -\000\000\000\000\000\000\209\001\000\000\000\000\000\000\156\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\239\001\000\000\000\000\239\001\154\000\000\000\239\001\ -\239\001\239\001\000\000\000\000\000\000\000\000\239\001\239\001\ -\036\003\000\000\000\000\039\003\000\000\239\001\155\000\000\000\ -\000\000\154\000\000\000\000\000\215\001\000\000\154\000\154\000\ -\154\000\239\001\000\000\239\001\154\000\239\001\000\000\000\000\ -\000\000\000\000\154\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\239\001\000\000\000\000\239\001\000\000\000\000\000\000\ -\239\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\154\000\214\001\000\000\000\000\000\000\000\000\033\002\ -\034\002\035\002\036\002\037\002\038\002\039\002\040\002\041\002\ -\042\002\043\002\044\002\045\002\046\002\047\002\048\002\049\002\ -\050\002\051\002\052\002\053\002\000\000\056\002\000\000\000\000\ -\000\000\155\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\113\003\062\002\000\000\251\001\000\000\ -\155\000\155\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\079\002\002\002\156\000\002\002\002\002\002\002\000\000\ -\000\000\000\000\002\002\146\004\000\000\000\000\133\003\002\002\ -\000\000\000\000\000\000\002\002\002\002\002\002\000\000\000\000\ -\000\000\000\000\155\000\000\000\002\002\002\002\002\002\002\002\ -\000\000\000\000\000\000\155\000\000\000\155\000\002\002\000\000\ -\000\000\000\000\002\002\002\002\214\001\000\000\000\000\000\000\ -\000\000\000\000\002\002\002\002\000\000\000\000\000\000\000\000\ -\215\001\000\000\000\000\000\000\000\000\000\000\002\002\000\000\ -\000\000\002\002\000\000\000\000\002\002\002\002\002\002\000\000\ -\002\002\000\000\000\000\002\002\002\002\000\000\155\000\000\000\ -\237\001\000\000\002\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\002\002\002\002\000\000\ -\002\002\002\002\002\002\000\000\000\000\156\000\002\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\214\001\002\002\000\000\ -\000\000\002\002\000\000\000\000\000\000\002\002\000\000\000\000\ -\138\005\000\000\000\000\209\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\209\001\000\000\003\004\000\000\000\000\ -\209\001\215\002\000\000\000\000\000\000\000\000\217\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\209\001\000\000\209\001\ -\209\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\162\005\000\000\209\001\000\000\156\000\104\003\ -\000\000\112\000\000\000\113\000\114\000\028\000\000\000\115\000\ -\000\000\000\000\115\001\117\000\155\000\000\000\037\004\209\001\ -\000\000\000\000\195\000\195\000\215\001\209\001\209\001\209\001\ -\000\000\000\000\000\000\000\000\000\000\209\001\106\002\000\000\ -\000\000\000\000\000\000\209\001\120\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\121\000\000\000\000\000\067\004\209\001\ -\000\000\000\000\000\000\209\001\116\001\027\003\000\000\122\000\ -\123\000\000\000\033\003\034\003\035\003\000\000\155\000\209\001\ -\000\000\000\000\209\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\251\001\000\000\ -\251\001\251\001\155\000\098\004\099\004\155\000\251\001\155\000\ -\155\000\155\000\000\000\251\001\000\000\155\000\000\000\251\001\ -\251\001\251\001\000\000\155\000\000\000\000\000\000\000\000\000\ -\251\001\251\001\251\001\251\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\251\001\000\000\000\000\000\000\215\001\251\001\ -\000\000\000\000\155\000\000\000\000\000\000\000\251\001\251\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\131\004\000\000\251\001\000\000\000\000\251\001\000\000\000\000\ -\251\001\251\001\251\001\000\000\251\001\098\003\099\003\100\003\ -\251\001\000\000\000\000\144\004\000\000\000\000\251\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\036\002\ -\237\001\251\001\251\001\237\001\251\001\251\001\251\001\000\000\ -\000\000\000\000\000\000\214\002\000\000\237\001\000\000\215\001\ -\000\000\237\001\251\001\130\003\000\000\251\001\000\000\000\000\ -\214\002\251\001\237\001\237\001\237\001\237\001\000\000\000\000\ -\000\000\000\000\000\000\140\003\000\000\000\000\000\000\000\000\ -\000\000\237\001\000\000\214\002\000\000\214\002\214\002\214\002\ -\000\000\214\002\000\000\000\000\214\002\214\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\237\001\000\000\000\000\237\001\ -\000\000\155\000\237\001\237\001\237\001\000\000\000\000\000\000\ -\000\000\237\001\237\001\000\000\000\000\000\000\214\002\000\000\ -\237\001\000\000\000\000\209\001\000\000\214\002\000\000\000\000\ -\000\000\000\000\000\000\201\004\237\001\203\004\237\001\000\000\ -\237\001\214\002\214\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\237\001\000\000\223\003\237\001\ -\000\000\000\000\000\000\237\001\000\000\000\000\106\002\106\002\ -\106\002\106\002\000\000\000\000\106\002\106\002\106\002\106\002\ -\106\002\106\002\106\002\106\002\106\002\106\002\106\002\106\002\ -\106\002\106\002\106\002\106\002\246\004\000\000\106\002\106\002\ -\106\002\106\002\106\002\106\002\106\002\106\002\000\000\000\000\ -\000\000\000\000\106\002\106\002\000\000\000\000\106\002\106\002\ -\106\002\106\002\106\002\106\002\106\002\106\002\000\000\106\002\ -\106\002\106\002\000\000\106\002\106\002\106\002\106\002\000\000\ -\000\000\106\002\106\002\106\002\000\000\106\002\106\002\106\002\ -\106\002\106\002\106\002\000\000\106\002\106\002\106\002\106\002\ -\106\002\000\000\000\000\000\000\000\000\155\000\106\002\106\002\ -\106\002\106\002\106\002\106\002\106\002\106\002\000\000\106\002\ -\064\002\106\002\106\002\060\004\106\002\106\002\106\002\106\002\ -\106\002\000\000\106\002\106\002\000\000\106\002\106\002\106\002\ -\106\002\000\000\106\002\106\002\000\000\106\002\000\000\000\000\ -\000\000\106\002\000\000\112\000\000\000\113\000\114\000\028\000\ -\000\000\115\000\000\000\000\000\116\000\117\000\000\000\000\000\ -\068\005\000\000\000\000\000\000\000\000\000\000\134\001\036\002\ -\000\000\036\002\036\002\036\002\000\000\118\000\000\000\036\002\ -\000\000\000\000\000\000\000\000\036\002\119\000\120\000\000\000\ -\036\002\036\002\036\002\000\000\000\000\121\000\000\000\000\000\ -\000\000\036\002\036\002\036\002\036\002\090\005\000\000\000\000\ -\000\000\122\000\123\000\036\002\000\000\000\000\000\000\155\000\ -\036\002\000\000\124\004\125\004\126\004\000\000\000\000\036\002\ -\036\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\036\002\000\000\000\000\036\002\117\005\ -\000\000\036\002\036\002\036\002\000\000\036\002\000\000\000\000\ -\036\002\036\002\000\000\000\000\000\000\000\000\130\005\036\002\ -\000\000\124\001\000\000\209\001\000\000\000\000\139\005\000\000\ -\000\000\000\000\036\002\036\002\000\000\036\002\036\002\036\002\ -\209\001\241\000\152\004\153\004\154\004\000\000\000\000\142\005\ -\155\000\000\000\000\000\036\002\000\000\209\001\036\002\209\001\ -\209\001\112\000\036\002\113\000\114\000\028\000\000\000\115\000\ -\000\000\000\000\126\001\117\000\209\001\000\000\000\000\000\000\ -\163\005\164\005\112\000\000\000\113\000\114\000\028\000\178\004\ -\115\000\000\000\174\005\116\000\117\000\000\000\000\000\209\001\ -\000\000\000\000\209\001\000\000\120\000\209\001\209\001\209\001\ -\000\000\184\005\000\000\121\000\118\000\209\001\186\005\187\005\ -\188\005\189\005\000\000\209\001\119\000\060\003\000\000\122\000\ -\123\000\000\000\000\000\000\000\121\000\000\000\000\000\209\001\ -\000\000\000\000\000\000\209\001\000\000\000\000\000\000\152\005\ -\122\000\123\000\000\000\000\000\000\000\000\000\000\000\209\001\ -\000\000\000\000\209\001\000\000\000\000\000\000\000\000\000\000\ -\224\004\225\004\000\000\000\000\000\000\232\004\233\004\234\004\ -\064\002\064\002\064\002\064\002\000\000\247\000\064\002\064\002\ -\064\002\064\002\064\002\064\002\064\002\064\002\064\002\064\002\ -\064\002\064\002\064\002\064\002\064\002\064\002\064\002\000\000\ -\064\002\064\002\064\002\064\002\064\002\064\002\064\002\064\002\ -\000\000\000\000\000\000\000\000\064\002\064\002\000\000\000\000\ -\064\002\064\002\064\002\064\002\064\002\064\002\064\002\064\002\ -\000\000\064\002\064\002\064\002\000\000\064\002\064\002\064\002\ -\064\002\000\000\000\000\064\002\064\002\064\002\052\002\064\002\ -\064\002\064\002\064\002\064\002\064\002\000\000\064\002\064\002\ -\064\002\064\002\064\002\000\000\000\000\000\000\000\000\000\000\ -\064\002\064\002\064\002\064\002\064\002\064\002\064\002\064\002\ -\000\000\064\002\000\000\064\002\064\002\000\000\064\002\064\002\ -\064\002\064\002\064\002\000\000\064\002\064\002\000\000\064\002\ -\064\002\064\002\064\002\000\000\064\002\064\002\000\000\064\002\ -\000\000\000\000\000\000\064\002\000\000\000\000\000\000\000\000\ -\000\000\245\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\241\000\241\000\241\000\241\000\000\000\000\000\241\000\ -\241\000\241\000\241\000\241\000\241\000\241\000\241\000\241\000\ -\241\000\241\000\241\000\241\000\241\000\241\000\241\000\241\000\ -\000\000\241\000\241\000\241\000\241\000\241\000\241\000\241\000\ -\241\000\000\000\101\005\102\005\103\005\241\000\241\000\000\000\ -\000\000\241\000\241\000\241\000\241\000\241\000\241\000\241\000\ -\241\000\000\000\241\000\241\000\241\000\000\000\241\000\241\000\ -\241\000\241\000\000\000\000\000\241\000\241\000\241\000\000\000\ -\241\000\241\000\241\000\241\000\241\000\241\000\000\000\241\000\ -\241\000\241\000\241\000\241\000\000\000\000\000\000\000\000\000\ -\000\000\241\000\241\000\241\000\241\000\241\000\241\000\241\000\ -\241\000\000\000\241\000\000\000\241\000\241\000\253\000\241\000\ -\241\000\241\000\241\000\241\000\000\000\241\000\241\000\000\000\ -\241\000\241\000\241\000\241\000\000\000\241\000\241\000\000\000\ -\241\000\000\000\000\000\000\000\241\000\247\000\247\000\247\000\ -\247\000\000\000\000\000\247\000\247\000\247\000\247\000\247\000\ -\247\000\247\000\247\000\247\000\247\000\247\000\247\000\247\000\ -\247\000\247\000\247\000\247\000\000\000\247\000\247\000\247\000\ -\247\000\247\000\247\000\247\000\247\000\000\000\000\000\000\000\ -\000\000\247\000\247\000\000\000\000\000\247\000\247\000\247\000\ -\247\000\247\000\247\000\247\000\247\000\000\000\247\000\247\000\ -\247\000\000\000\247\000\247\000\247\000\247\000\000\000\000\000\ -\247\000\247\000\247\000\000\000\247\000\247\000\247\000\247\000\ -\247\000\247\000\000\000\247\000\247\000\247\000\247\000\247\000\ -\000\000\000\000\000\000\000\000\000\000\247\000\247\000\247\000\ -\247\000\247\000\247\000\247\000\247\000\000\000\247\000\000\000\ -\247\000\247\000\249\000\247\000\247\000\247\000\247\000\247\000\ -\000\000\247\000\247\000\000\000\247\000\247\000\247\000\247\000\ -\000\000\247\000\247\000\000\000\247\000\000\000\000\000\000\000\ -\247\000\245\000\245\000\245\000\245\000\000\000\000\000\245\000\ -\245\000\245\000\245\000\245\000\245\000\245\000\245\000\245\000\ -\245\000\245\000\245\000\245\000\245\000\245\000\245\000\245\000\ -\000\000\245\000\245\000\245\000\245\000\245\000\245\000\245\000\ -\245\000\000\000\000\000\000\000\000\000\245\000\245\000\000\000\ -\000\000\245\000\245\000\245\000\245\000\245\000\245\000\245\000\ -\245\000\000\000\245\000\245\000\245\000\000\000\245\000\245\000\ -\245\000\245\000\000\000\000\000\245\000\245\000\245\000\000\000\ -\245\000\245\000\245\000\245\000\245\000\245\000\000\000\245\000\ -\245\000\245\000\245\000\245\000\000\000\000\000\000\000\000\000\ -\000\000\245\000\245\000\245\000\245\000\245\000\245\000\245\000\ -\245\000\000\000\245\000\000\000\245\000\245\000\251\000\245\000\ -\245\000\245\000\245\000\245\000\000\000\245\000\245\000\000\000\ -\245\000\245\000\245\000\245\000\000\000\245\000\245\000\000\000\ -\245\000\000\000\000\000\000\000\245\000\000\000\253\000\253\000\ -\253\000\253\000\000\000\000\000\253\000\253\000\253\000\253\000\ -\253\000\253\000\253\000\253\000\253\000\253\000\253\000\253\000\ -\253\000\253\000\253\000\253\000\253\000\000\000\253\000\253\000\ -\253\000\253\000\253\000\253\000\253\000\253\000\000\000\000\000\ -\000\000\000\000\253\000\253\000\000\000\000\000\253\000\253\000\ -\253\000\253\000\253\000\253\000\253\000\253\000\000\000\253\000\ -\253\000\253\000\000\000\253\000\253\000\253\000\253\000\000\000\ -\000\000\253\000\253\000\253\000\000\000\253\000\253\000\253\000\ -\253\000\253\000\253\000\000\000\253\000\253\000\253\000\253\000\ -\253\000\000\000\000\000\000\000\000\000\000\000\253\000\253\000\ -\253\000\253\000\253\000\253\000\253\000\253\000\000\000\253\000\ -\000\000\253\000\253\000\003\001\253\000\253\000\253\000\253\000\ -\253\000\000\000\253\000\253\000\000\000\253\000\253\000\253\000\ -\253\000\000\000\253\000\253\000\000\000\253\000\000\000\000\000\ -\000\000\253\000\249\000\249\000\249\000\249\000\000\000\000\000\ -\249\000\249\000\249\000\249\000\249\000\249\000\249\000\249\000\ -\249\000\249\000\249\000\249\000\249\000\249\000\249\000\249\000\ -\249\000\000\000\249\000\249\000\249\000\249\000\249\000\249\000\ -\249\000\249\000\000\000\000\000\000\000\000\000\249\000\249\000\ -\000\000\000\000\249\000\249\000\249\000\249\000\249\000\249\000\ -\249\000\249\000\000\000\249\000\249\000\249\000\000\000\249\000\ -\249\000\249\000\249\000\000\000\000\000\249\000\249\000\249\000\ -\000\000\249\000\249\000\249\000\249\000\249\000\249\000\000\000\ -\249\000\249\000\249\000\249\000\249\000\000\000\000\000\000\000\ -\000\000\000\000\249\000\249\000\249\000\249\000\249\000\249\000\ -\249\000\249\000\000\000\249\000\000\000\249\000\249\000\255\000\ -\249\000\249\000\249\000\249\000\249\000\000\000\249\000\249\000\ -\000\000\249\000\249\000\249\000\249\000\000\000\249\000\249\000\ -\000\000\249\000\000\000\000\000\000\000\249\000\251\000\251\000\ -\251\000\251\000\000\000\000\000\251\000\251\000\251\000\251\000\ -\251\000\251\000\251\000\251\000\251\000\251\000\251\000\251\000\ -\251\000\251\000\251\000\251\000\251\000\000\000\251\000\251\000\ -\251\000\251\000\251\000\251\000\251\000\251\000\000\000\000\000\ -\000\000\000\000\251\000\251\000\000\000\000\000\251\000\251\000\ -\251\000\251\000\251\000\251\000\251\000\251\000\000\000\251\000\ -\251\000\251\000\000\000\251\000\251\000\251\000\251\000\000\000\ -\000\000\251\000\251\000\251\000\000\000\251\000\251\000\251\000\ -\251\000\251\000\251\000\000\000\251\000\251\000\251\000\251\000\ -\251\000\000\000\000\000\000\000\000\000\000\000\251\000\251\000\ -\251\000\251\000\251\000\251\000\251\000\251\000\000\000\251\000\ -\000\000\251\000\251\000\001\001\251\000\251\000\251\000\251\000\ -\251\000\000\000\251\000\251\000\000\000\251\000\251\000\251\000\ -\251\000\000\000\251\000\251\000\000\000\251\000\000\000\000\000\ -\000\000\251\000\000\000\003\001\003\001\003\001\003\001\000\000\ -\000\000\003\001\003\001\003\001\003\001\003\001\003\001\003\001\ -\003\001\003\001\003\001\003\001\003\001\003\001\003\001\003\001\ -\003\001\003\001\000\000\003\001\003\001\003\001\003\001\003\001\ -\003\001\003\001\003\001\000\000\000\000\000\000\000\000\003\001\ -\003\001\000\000\000\000\003\001\003\001\003\001\003\001\003\001\ -\003\001\003\001\003\001\000\000\003\001\003\001\003\001\000\000\ -\003\001\003\001\003\001\003\001\000\000\000\000\003\001\003\001\ -\003\001\000\000\003\001\003\001\003\001\003\001\003\001\003\001\ -\000\000\003\001\003\001\003\001\003\001\003\001\000\000\000\000\ -\000\000\000\000\000\000\003\001\003\001\003\001\003\001\003\001\ -\003\001\003\001\003\001\000\000\003\001\000\000\003\001\003\001\ -\030\001\003\001\003\001\003\001\003\001\003\001\000\000\003\001\ -\003\001\000\000\003\001\003\001\003\001\003\001\000\000\003\001\ -\003\001\000\000\003\001\000\000\000\000\000\000\003\001\255\000\ -\255\000\255\000\255\000\000\000\000\000\255\000\255\000\255\000\ -\255\000\255\000\255\000\255\000\255\000\255\000\255\000\255\000\ -\255\000\255\000\255\000\255\000\255\000\255\000\000\000\255\000\ -\255\000\255\000\255\000\255\000\255\000\255\000\255\000\000\000\ -\000\000\000\000\000\000\255\000\255\000\000\000\000\000\255\000\ -\255\000\255\000\255\000\255\000\255\000\255\000\255\000\000\000\ -\255\000\255\000\255\000\000\000\255\000\255\000\255\000\255\000\ -\000\000\000\000\255\000\255\000\255\000\000\000\255\000\255\000\ -\255\000\255\000\255\000\255\000\000\000\255\000\255\000\255\000\ -\255\000\255\000\000\000\000\000\000\000\000\000\000\000\255\000\ -\255\000\255\000\255\000\255\000\255\000\255\000\255\000\000\000\ -\255\000\000\000\255\000\255\000\039\001\255\000\255\000\255\000\ -\255\000\255\000\000\000\255\000\255\000\000\000\255\000\255\000\ -\255\000\255\000\000\000\255\000\255\000\000\000\255\000\000\000\ -\000\000\000\000\255\000\001\001\001\001\001\001\001\001\000\000\ -\000\000\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ -\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\001\ -\001\001\001\001\000\000\001\001\001\001\001\001\001\001\001\001\ -\001\001\001\001\001\001\000\000\000\000\000\000\000\000\001\001\ -\001\001\000\000\000\000\001\001\001\001\001\001\001\001\001\001\ -\001\001\001\001\001\001\000\000\001\001\001\001\001\001\000\000\ -\001\001\001\001\001\001\001\001\000\000\000\000\001\001\001\001\ -\001\001\000\000\001\001\001\001\001\001\001\001\001\001\001\001\ -\000\000\001\001\001\001\001\001\001\001\001\001\000\000\000\000\ -\000\000\000\000\000\000\001\001\001\001\001\001\001\001\001\001\ -\001\001\001\001\001\001\000\000\001\001\000\000\001\001\001\001\ -\041\001\001\001\001\001\001\001\001\001\001\001\000\000\001\001\ -\001\001\000\000\001\001\001\001\001\001\001\001\000\000\001\001\ -\001\001\000\000\001\001\000\000\000\000\000\000\001\001\000\000\ -\030\001\030\001\030\001\030\001\000\000\000\000\030\001\030\001\ -\030\001\030\001\030\001\030\001\030\001\030\001\030\001\030\001\ -\030\001\030\001\030\001\030\001\030\001\030\001\000\000\000\000\ -\030\001\030\001\030\001\030\001\030\001\030\001\030\001\030\001\ -\000\000\000\000\000\000\000\000\030\001\030\001\000\000\000\000\ -\030\001\030\001\030\001\030\001\030\001\030\001\030\001\000\000\ -\000\000\030\001\030\001\030\001\000\000\030\001\030\001\030\001\ -\030\001\000\000\000\000\030\001\030\001\030\001\000\000\030\001\ -\030\001\030\001\030\001\030\001\030\001\000\000\030\001\030\001\ -\030\001\030\001\030\001\000\000\000\000\000\000\000\000\000\000\ -\030\001\030\001\030\001\030\001\030\001\030\001\030\001\030\001\ -\000\000\030\001\000\000\030\001\030\001\044\001\030\001\030\001\ -\030\001\030\001\030\001\000\000\030\001\030\001\000\000\030\001\ -\030\001\030\001\030\001\000\000\030\001\030\001\000\000\030\001\ -\000\000\000\000\000\000\030\001\039\001\039\001\039\001\039\001\ -\000\000\000\000\039\001\039\001\039\001\039\001\039\001\039\001\ -\039\001\039\001\039\001\039\001\039\001\039\001\039\001\039\001\ -\039\001\039\001\000\000\000\000\039\001\039\001\039\001\039\001\ -\039\001\039\001\039\001\039\001\000\000\000\000\000\000\000\000\ -\039\001\039\001\000\000\000\000\039\001\039\001\039\001\039\001\ -\039\001\039\001\039\001\000\000\000\000\039\001\039\001\039\001\ -\000\000\039\001\039\001\039\001\039\001\000\000\000\000\039\001\ -\039\001\039\001\000\000\039\001\039\001\039\001\039\001\039\001\ -\039\001\000\000\039\001\039\001\039\001\039\001\039\001\000\000\ -\000\000\000\000\000\000\000\000\039\001\039\001\039\001\039\001\ -\039\001\039\001\039\001\039\001\000\000\039\001\000\000\039\001\ -\039\001\233\000\039\001\039\001\039\001\000\000\000\000\000\000\ -\039\001\039\001\000\000\039\001\039\001\039\001\039\001\000\000\ -\039\001\039\001\000\000\039\001\000\000\000\000\000\000\039\001\ -\041\001\041\001\041\001\041\001\000\000\000\000\041\001\041\001\ -\041\001\041\001\041\001\041\001\041\001\041\001\041\001\041\001\ -\041\001\041\001\041\001\041\001\041\001\041\001\000\000\000\000\ -\041\001\041\001\041\001\041\001\041\001\041\001\041\001\041\001\ -\000\000\000\000\000\000\000\000\041\001\041\001\000\000\000\000\ -\041\001\041\001\041\001\041\001\041\001\041\001\041\001\000\000\ -\000\000\041\001\041\001\041\001\000\000\041\001\041\001\041\001\ -\041\001\000\000\000\000\041\001\041\001\041\001\000\000\041\001\ -\041\001\041\001\041\001\041\001\041\001\000\000\041\001\041\001\ -\041\001\041\001\041\001\000\000\000\000\000\000\000\000\000\000\ -\041\001\041\001\041\001\041\001\041\001\041\001\041\001\041\001\ -\000\000\041\001\000\000\041\001\041\001\234\000\041\001\041\001\ -\041\001\000\000\000\000\000\000\041\001\041\001\000\000\041\001\ -\041\001\041\001\041\001\000\000\041\001\041\001\000\000\041\001\ -\000\000\000\000\000\000\041\001\000\000\044\001\044\001\044\001\ -\044\001\000\000\000\000\044\001\044\001\044\001\044\001\044\001\ -\044\001\044\001\044\001\044\001\044\001\044\001\044\001\044\001\ -\044\001\044\001\044\001\000\000\000\000\044\001\044\001\044\001\ -\044\001\044\001\044\001\044\001\044\001\000\000\000\000\000\000\ -\000\000\044\001\044\001\000\000\000\000\044\001\044\001\044\001\ -\044\001\044\001\044\001\044\001\000\000\000\000\044\001\044\001\ -\044\001\000\000\044\001\044\001\044\001\044\001\000\000\000\000\ -\044\001\044\001\044\001\000\000\044\001\044\001\044\001\044\001\ -\044\001\044\001\000\000\044\001\044\001\044\001\044\001\044\001\ -\000\000\000\000\000\000\000\000\000\000\044\001\044\001\044\001\ -\044\001\044\001\044\001\044\001\044\001\000\000\044\001\000\000\ -\044\001\044\001\173\000\044\001\044\001\044\001\000\000\000\000\ -\000\000\044\001\044\001\000\000\044\001\044\001\044\001\044\001\ -\000\000\044\001\044\001\000\000\044\001\000\000\000\000\000\000\ -\044\001\233\000\233\000\233\000\233\000\000\000\000\000\000\000\ -\000\000\233\000\233\000\233\000\000\000\000\000\233\000\233\000\ -\233\000\233\000\233\000\233\000\233\000\233\000\233\000\233\000\ -\000\000\233\000\233\000\233\000\233\000\233\000\233\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\233\000\233\000\000\000\ -\000\000\233\000\233\000\233\000\233\000\233\000\233\000\233\000\ -\233\000\000\000\233\000\000\000\233\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\233\000\233\000\000\000\ -\233\000\000\000\000\000\233\000\233\000\233\000\000\000\233\000\ -\233\000\233\000\233\000\233\000\000\000\000\000\000\000\000\000\ -\000\000\233\000\233\000\233\000\233\000\233\000\233\000\233\000\ -\000\000\000\000\233\000\000\000\233\000\233\000\174\000\233\000\ -\233\000\233\000\233\000\233\000\000\000\233\000\000\000\000\000\ -\233\000\233\000\233\000\000\000\000\000\233\000\000\000\000\000\ -\233\000\000\000\000\000\000\000\233\000\234\000\234\000\234\000\ -\234\000\000\000\000\000\000\000\000\000\234\000\234\000\234\000\ -\000\000\000\000\234\000\234\000\234\000\234\000\234\000\234\000\ -\234\000\234\000\234\000\234\000\000\000\234\000\234\000\234\000\ -\234\000\234\000\234\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\234\000\234\000\000\000\000\000\234\000\234\000\234\000\ -\234\000\234\000\234\000\234\000\234\000\000\000\234\000\000\000\ -\234\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\234\000\234\000\000\000\234\000\000\000\000\000\234\000\ -\234\000\234\000\000\000\234\000\234\000\234\000\234\000\234\000\ -\000\000\000\000\000\000\000\000\000\000\234\000\234\000\234\000\ -\234\000\234\000\234\000\234\000\000\000\000\000\234\000\000\000\ -\234\000\234\000\186\000\234\000\234\000\234\000\234\000\234\000\ -\000\000\234\000\000\000\000\000\234\000\234\000\234\000\000\000\ -\000\000\234\000\000\000\000\000\234\000\000\000\000\000\000\000\ -\234\000\000\000\173\000\173\000\173\000\173\000\000\000\000\000\ -\000\000\000\000\173\000\173\000\173\000\000\000\000\000\173\000\ -\173\000\173\000\173\000\173\000\173\000\173\000\173\000\173\000\ -\000\000\000\000\173\000\173\000\173\000\173\000\173\000\173\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\173\000\173\000\ -\000\000\000\000\173\000\173\000\173\000\173\000\173\000\173\000\ -\173\000\000\000\000\000\173\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\173\000\173\000\ -\000\000\173\000\000\000\000\000\173\000\173\000\173\000\000\000\ -\173\000\173\000\173\000\173\000\173\000\000\000\000\000\000\000\ -\000\000\000\000\173\000\000\000\173\000\173\000\173\000\173\000\ -\173\000\000\000\000\000\000\000\000\000\173\000\173\000\187\000\ -\173\000\173\000\173\000\000\000\000\000\000\000\173\000\000\000\ -\000\000\173\000\000\000\173\000\000\000\000\000\173\000\000\000\ -\000\000\173\000\000\000\000\000\000\000\173\000\174\000\174\000\ -\174\000\174\000\000\000\000\000\000\000\000\000\174\000\174\000\ -\174\000\000\000\000\000\174\000\174\000\174\000\174\000\174\000\ -\174\000\174\000\174\000\174\000\000\000\000\000\174\000\174\000\ -\174\000\174\000\174\000\174\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\174\000\174\000\000\000\000\000\174\000\174\000\ -\174\000\174\000\174\000\174\000\174\000\000\000\000\000\174\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\174\000\174\000\000\000\174\000\000\000\000\000\ -\174\000\174\000\174\000\000\000\174\000\174\000\174\000\174\000\ -\174\000\000\000\000\000\000\000\000\000\000\000\174\000\000\000\ -\174\000\174\000\174\000\174\000\174\000\000\000\000\000\000\000\ -\000\000\174\000\174\000\225\000\174\000\174\000\174\000\000\000\ -\000\000\000\000\174\000\000\000\000\000\174\000\000\000\174\000\ -\000\000\000\000\174\000\000\000\000\000\174\000\000\000\000\000\ -\000\000\174\000\186\000\186\000\186\000\186\000\000\000\000\000\ -\000\000\000\000\186\000\186\000\186\000\000\000\000\000\186\000\ -\186\000\186\000\186\000\186\000\186\000\186\000\186\000\186\000\ -\000\000\000\000\186\000\186\000\186\000\186\000\186\000\186\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\186\000\186\000\ -\000\000\000\000\186\000\186\000\186\000\186\000\186\000\186\000\ -\186\000\000\000\000\000\186\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\186\000\186\000\ -\000\000\186\000\000\000\000\000\186\000\186\000\186\000\000\000\ -\186\000\186\000\186\000\186\000\186\000\000\000\000\000\000\000\ -\000\000\000\000\186\000\000\000\186\000\186\000\186\000\186\000\ -\186\000\000\000\000\000\000\000\000\000\186\000\186\000\226\000\ -\186\000\186\000\186\000\000\000\000\000\000\000\186\000\000\000\ -\000\000\186\000\000\000\186\000\000\000\000\000\186\000\000\000\ -\000\000\186\000\000\000\000\000\000\000\186\000\000\000\187\000\ -\187\000\187\000\187\000\000\000\000\000\000\000\000\000\187\000\ -\187\000\187\000\000\000\000\000\187\000\187\000\187\000\187\000\ -\187\000\187\000\187\000\187\000\187\000\000\000\000\000\187\000\ -\187\000\187\000\187\000\187\000\187\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\187\000\187\000\000\000\000\000\187\000\ -\187\000\187\000\187\000\187\000\187\000\187\000\000\000\000\000\ -\187\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\187\000\187\000\000\000\187\000\000\000\ -\000\000\187\000\187\000\187\000\000\000\187\000\187\000\187\000\ -\187\000\187\000\000\000\000\000\000\000\000\000\000\000\187\000\ -\000\000\187\000\187\000\187\000\187\000\187\000\000\000\000\000\ -\000\000\000\000\187\000\187\000\185\000\187\000\187\000\187\000\ -\000\000\000\000\000\000\187\000\000\000\000\000\187\000\000\000\ -\187\000\000\000\000\000\187\000\000\000\000\000\187\000\000\000\ -\000\000\000\000\187\000\225\000\225\000\225\000\225\000\000\000\ -\000\000\000\000\000\000\225\000\225\000\225\000\000\000\000\000\ -\225\000\225\000\225\000\225\000\225\000\225\000\225\000\225\000\ -\225\000\000\000\000\000\225\000\225\000\225\000\225\000\225\000\ -\225\000\000\000\000\000\000\000\000\000\000\000\000\000\225\000\ -\225\000\000\000\000\000\225\000\225\000\225\000\225\000\225\000\ -\225\000\225\000\000\000\000\000\225\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\225\000\ -\225\000\000\000\225\000\000\000\000\000\225\000\225\000\225\000\ -\000\000\225\000\225\000\225\000\225\000\225\000\000\000\000\000\ -\000\000\000\000\000\000\225\000\000\000\225\000\225\000\225\000\ -\225\000\225\000\000\000\000\000\000\000\000\000\225\000\225\000\ -\196\000\225\000\225\000\225\000\000\000\000\000\000\000\225\000\ -\000\000\000\000\225\000\000\000\225\000\000\000\000\000\225\000\ -\000\000\000\000\225\000\000\000\000\000\000\000\225\000\226\000\ -\226\000\226\000\226\000\000\000\000\000\000\000\000\000\226\000\ -\226\000\226\000\000\000\000\000\226\000\226\000\226\000\226\000\ -\226\000\226\000\226\000\226\000\226\000\000\000\000\000\226\000\ -\226\000\226\000\226\000\226\000\226\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\226\000\226\000\000\000\000\000\226\000\ -\226\000\226\000\226\000\226\000\226\000\226\000\000\000\000\000\ -\226\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\226\000\226\000\000\000\226\000\000\000\ -\000\000\226\000\226\000\226\000\000\000\226\000\226\000\226\000\ -\226\000\226\000\000\000\000\000\000\000\000\000\000\000\226\000\ -\000\000\226\000\226\000\226\000\226\000\226\000\000\000\000\000\ -\000\000\000\000\226\000\226\000\197\000\226\000\226\000\226\000\ -\000\000\000\000\000\000\226\000\000\000\000\000\226\000\000\000\ -\226\000\000\000\000\000\226\000\000\000\000\000\226\000\000\000\ -\000\000\000\000\226\000\000\000\185\000\185\000\185\000\185\000\ -\000\000\000\000\000\000\000\000\185\000\185\000\185\000\000\000\ -\000\000\185\000\185\000\185\000\185\000\185\000\000\000\185\000\ -\185\000\185\000\000\000\000\000\185\000\185\000\185\000\185\000\ -\185\000\185\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\185\000\185\000\000\000\000\000\185\000\185\000\185\000\185\000\ -\185\000\185\000\185\000\000\000\000\000\185\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\185\000\185\000\000\000\185\000\000\000\000\000\185\000\185\000\ -\185\000\000\000\185\000\185\000\185\000\185\000\185\000\000\000\ -\000\000\000\000\000\000\000\000\185\000\000\000\185\000\185\000\ -\185\000\185\000\185\000\000\000\000\000\000\000\000\000\185\000\ -\185\000\204\000\185\000\185\000\185\000\000\000\000\000\000\000\ -\185\000\000\000\000\000\185\000\000\000\185\000\000\000\000\000\ -\185\000\000\000\000\000\185\000\000\000\000\000\000\000\185\000\ -\196\000\196\000\196\000\196\000\000\000\000\000\000\000\000\000\ -\196\000\196\000\196\000\000\000\000\000\196\000\196\000\196\000\ -\196\000\196\000\196\000\196\000\196\000\196\000\000\000\000\000\ -\196\000\196\000\196\000\196\000\196\000\196\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\196\000\196\000\000\000\000\000\ -\196\000\196\000\196\000\196\000\196\000\196\000\000\000\000\000\ -\000\000\196\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\196\000\196\000\000\000\196\000\ -\000\000\000\000\196\000\196\000\196\000\000\000\196\000\196\000\ -\196\000\196\000\196\000\000\000\000\000\000\000\000\000\000\000\ -\196\000\000\000\196\000\196\000\196\000\196\000\196\000\000\000\ -\000\000\000\000\000\000\196\000\196\000\203\000\196\000\196\000\ -\196\000\000\000\000\000\000\000\196\000\000\000\000\000\196\000\ -\000\000\196\000\000\000\000\000\196\000\000\000\000\000\196\000\ -\000\000\000\000\000\000\196\000\197\000\197\000\197\000\197\000\ -\000\000\000\000\000\000\000\000\197\000\197\000\197\000\000\000\ -\000\000\197\000\197\000\197\000\197\000\197\000\197\000\197\000\ -\197\000\197\000\000\000\000\000\197\000\197\000\197\000\197\000\ -\197\000\197\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\197\000\197\000\000\000\000\000\197\000\197\000\197\000\197\000\ -\197\000\197\000\000\000\000\000\000\000\197\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\197\000\197\000\000\000\197\000\000\000\000\000\197\000\197\000\ -\197\000\000\000\197\000\197\000\197\000\197\000\197\000\000\000\ -\000\000\000\000\000\000\000\000\197\000\000\000\197\000\197\000\ -\197\000\197\000\197\000\000\000\000\000\000\000\000\000\197\000\ -\197\000\179\000\197\000\197\000\197\000\000\000\000\000\000\000\ -\197\000\000\000\000\000\197\000\000\000\197\000\000\000\000\000\ -\197\000\000\000\000\000\197\000\000\000\000\000\000\000\197\000\ -\000\000\204\000\204\000\204\000\204\000\000\000\000\000\000\000\ -\000\000\204\000\204\000\204\000\000\000\000\000\204\000\204\000\ -\204\000\204\000\204\000\204\000\204\000\204\000\204\000\000\000\ -\000\000\204\000\204\000\204\000\204\000\204\000\204\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\204\000\204\000\000\000\ -\000\000\204\000\204\000\204\000\204\000\204\000\204\000\000\000\ -\000\000\000\000\204\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\204\000\204\000\000\000\ -\204\000\000\000\000\000\204\000\204\000\204\000\000\000\204\000\ -\204\000\204\000\204\000\204\000\000\000\000\000\000\000\000\000\ -\000\000\204\000\000\000\204\000\204\000\204\000\204\000\204\000\ -\000\000\000\000\000\000\000\000\204\000\204\000\182\000\204\000\ -\204\000\204\000\000\000\000\000\000\000\204\000\000\000\000\000\ -\204\000\000\000\204\000\000\000\000\000\204\000\000\000\000\000\ -\204\000\000\000\000\000\000\000\204\000\203\000\203\000\203\000\ -\203\000\000\000\000\000\000\000\000\000\203\000\203\000\203\000\ -\000\000\000\000\203\000\203\000\203\000\203\000\203\000\203\000\ -\203\000\203\000\203\000\000\000\000\000\203\000\203\000\203\000\ -\203\000\203\000\203\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\203\000\203\000\000\000\000\000\203\000\203\000\203\000\ -\203\000\203\000\203\000\000\000\000\000\000\000\203\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\203\000\203\000\000\000\203\000\000\000\000\000\203\000\ -\203\000\203\000\000\000\203\000\203\000\203\000\203\000\203\000\ -\000\000\000\000\000\000\000\000\000\000\203\000\000\000\203\000\ -\203\000\203\000\203\000\203\000\000\000\000\000\000\000\000\000\ -\203\000\203\000\183\000\203\000\203\000\203\000\000\000\000\000\ -\000\000\203\000\000\000\000\000\203\000\000\000\203\000\000\000\ -\000\000\203\000\000\000\000\000\203\000\000\000\000\000\000\000\ -\203\000\179\000\179\000\179\000\179\000\000\000\000\000\000\000\ -\000\000\000\000\179\000\179\000\000\000\000\000\179\000\179\000\ -\179\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ -\000\000\179\000\179\000\179\000\179\000\179\000\179\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\179\000\179\000\000\000\ -\000\000\179\000\179\000\179\000\179\000\179\000\179\000\179\000\ -\000\000\000\000\179\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\179\000\179\000\000\000\ -\179\000\000\000\000\000\179\000\179\000\179\000\000\000\179\000\ -\179\000\179\000\179\000\179\000\000\000\000\000\000\000\000\000\ -\000\000\179\000\000\000\179\000\179\000\179\000\179\000\179\000\ -\000\000\000\000\000\000\000\000\179\000\179\000\195\000\179\000\ -\179\000\179\000\000\000\000\000\000\000\179\000\000\000\000\000\ -\179\000\000\000\179\000\000\000\000\000\179\000\000\000\000\000\ -\179\000\000\000\000\000\000\000\179\000\000\000\182\000\182\000\ -\182\000\182\000\000\000\000\000\000\000\000\000\000\000\182\000\ -\182\000\000\000\000\000\182\000\182\000\182\000\182\000\182\000\ -\182\000\182\000\182\000\182\000\000\000\000\000\182\000\182\000\ -\182\000\182\000\182\000\182\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\182\000\182\000\000\000\000\000\182\000\182\000\ -\182\000\182\000\182\000\182\000\182\000\000\000\000\000\182\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\182\000\182\000\000\000\182\000\000\000\000\000\ -\182\000\182\000\182\000\000\000\182\000\182\000\182\000\182\000\ -\182\000\000\000\000\000\000\000\000\000\000\000\182\000\000\000\ -\182\000\182\000\182\000\182\000\182\000\000\000\000\000\000\000\ -\000\000\182\000\182\000\201\000\182\000\182\000\182\000\000\000\ -\000\000\000\000\182\000\000\000\000\000\182\000\000\000\182\000\ -\000\000\000\000\182\000\000\000\000\000\182\000\000\000\000\000\ -\000\000\182\000\183\000\183\000\183\000\183\000\000\000\000\000\ -\000\000\000\000\000\000\183\000\183\000\000\000\000\000\183\000\ -\183\000\183\000\183\000\183\000\183\000\183\000\183\000\183\000\ -\000\000\000\000\183\000\183\000\183\000\183\000\183\000\183\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\183\000\183\000\ -\000\000\000\000\183\000\183\000\183\000\183\000\183\000\183\000\ -\183\000\000\000\000\000\183\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\183\000\183\000\ -\000\000\183\000\000\000\000\000\183\000\183\000\183\000\000\000\ -\183\000\183\000\183\000\183\000\183\000\000\000\000\000\000\000\ -\000\000\000\000\183\000\000\000\183\000\183\000\183\000\183\000\ -\183\000\000\000\000\000\000\000\000\000\183\000\183\000\202\000\ -\183\000\183\000\183\000\000\000\000\000\000\000\183\000\000\000\ -\000\000\183\000\000\000\183\000\000\000\000\000\183\000\000\000\ -\000\000\183\000\000\000\000\000\000\000\183\000\195\000\195\000\ -\195\000\195\000\000\000\000\000\000\000\000\000\195\000\195\000\ -\195\000\000\000\000\000\195\000\195\000\195\000\195\000\195\000\ -\195\000\195\000\195\000\195\000\000\000\000\000\195\000\195\000\ -\195\000\195\000\195\000\195\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\195\000\195\000\000\000\000\000\195\000\195\000\ -\195\000\195\000\195\000\000\000\000\000\000\000\000\000\195\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\195\000\195\000\000\000\195\000\000\000\000\000\ -\195\000\195\000\195\000\000\000\195\000\195\000\195\000\195\000\ -\195\000\000\000\000\000\000\000\000\000\000\000\195\000\000\000\ -\195\000\000\000\195\000\195\000\195\000\000\000\000\000\000\000\ -\000\000\195\000\195\000\198\000\195\000\195\000\195\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\195\000\000\000\195\000\ -\000\000\000\000\195\000\000\000\000\000\195\000\000\000\000\000\ -\000\000\195\000\000\000\201\000\201\000\201\000\201\000\000\000\ -\000\000\000\000\000\000\201\000\201\000\201\000\000\000\000\000\ -\201\000\201\000\201\000\201\000\201\000\201\000\201\000\201\000\ -\201\000\000\000\000\000\201\000\201\000\201\000\201\000\201\000\ -\201\000\000\000\000\000\000\000\000\000\000\000\000\000\201\000\ -\201\000\000\000\000\000\201\000\201\000\201\000\201\000\201\000\ -\000\000\000\000\000\000\000\000\201\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\201\000\ -\201\000\000\000\201\000\000\000\000\000\201\000\201\000\201\000\ -\000\000\201\000\201\000\201\000\201\000\201\000\000\000\000\000\ -\000\000\000\000\000\000\201\000\000\000\201\000\000\000\201\000\ -\201\000\201\000\000\000\000\000\000\000\000\000\201\000\201\000\ -\199\000\201\000\201\000\201\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\201\000\000\000\201\000\000\000\000\000\201\000\ -\000\000\000\000\201\000\000\000\000\000\000\000\201\000\202\000\ -\202\000\202\000\202\000\000\000\000\000\000\000\000\000\202\000\ -\202\000\202\000\000\000\000\000\202\000\202\000\202\000\202\000\ -\202\000\202\000\202\000\202\000\202\000\000\000\000\000\202\000\ -\202\000\202\000\202\000\202\000\202\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\202\000\202\000\000\000\000\000\202\000\ -\202\000\202\000\202\000\202\000\000\000\000\000\000\000\000\000\ -\202\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\202\000\202\000\000\000\202\000\000\000\ -\000\000\202\000\202\000\202\000\000\000\202\000\202\000\202\000\ -\202\000\202\000\000\000\000\000\000\000\000\000\000\000\202\000\ -\000\000\202\000\000\000\202\000\202\000\202\000\000\000\000\000\ -\000\000\000\000\202\000\202\000\200\000\202\000\202\000\202\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\202\000\000\000\ -\202\000\000\000\000\000\202\000\000\000\000\000\202\000\000\000\ -\000\000\000\000\202\000\198\000\198\000\198\000\198\000\000\000\ -\000\000\000\000\000\000\198\000\198\000\198\000\000\000\000\000\ -\198\000\198\000\198\000\198\000\198\000\198\000\198\000\198\000\ -\198\000\000\000\000\000\198\000\198\000\198\000\198\000\198\000\ -\198\000\000\000\000\000\000\000\000\000\000\000\000\000\198\000\ -\198\000\000\000\000\000\198\000\198\000\198\000\198\000\198\000\ -\000\000\000\000\000\000\000\000\198\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\198\000\ -\198\000\000\000\198\000\000\000\000\000\198\000\198\000\198\000\ -\000\000\198\000\198\000\198\000\198\000\198\000\000\000\000\000\ -\000\000\000\000\000\000\198\000\000\000\198\000\000\000\198\000\ -\198\000\198\000\000\000\000\000\000\000\000\000\198\000\198\000\ -\153\000\198\000\198\000\198\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\198\000\000\000\198\000\000\000\000\000\198\000\ -\000\000\000\000\198\000\000\000\000\000\000\000\198\000\000\000\ -\199\000\199\000\199\000\199\000\000\000\000\000\000\000\000\000\ -\199\000\199\000\199\000\000\000\000\000\199\000\199\000\199\000\ -\199\000\199\000\199\000\199\000\199\000\199\000\000\000\000\000\ -\199\000\199\000\199\000\199\000\199\000\199\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\199\000\199\000\000\000\000\000\ -\199\000\199\000\199\000\199\000\199\000\000\000\000\000\000\000\ -\000\000\199\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\199\000\199\000\000\000\199\000\ -\000\000\000\000\199\000\199\000\199\000\000\000\199\000\199\000\ -\199\000\199\000\199\000\000\000\000\000\000\000\000\000\000\000\ -\199\000\000\000\199\000\000\000\199\000\199\000\199\000\000\000\ -\000\000\000\000\000\000\199\000\199\000\192\000\199\000\199\000\ -\199\000\000\000\000\000\000\000\000\000\000\000\000\000\199\000\ -\000\000\199\000\000\000\000\000\199\000\000\000\000\000\199\000\ -\000\000\000\000\000\000\199\000\200\000\200\000\200\000\200\000\ -\000\000\000\000\000\000\000\000\200\000\200\000\200\000\000\000\ -\000\000\200\000\200\000\200\000\200\000\200\000\200\000\200\000\ -\200\000\200\000\000\000\000\000\200\000\200\000\200\000\200\000\ -\200\000\200\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\200\000\200\000\000\000\000\000\200\000\200\000\200\000\200\000\ -\200\000\000\000\000\000\000\000\000\000\200\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\200\000\200\000\000\000\200\000\000\000\000\000\200\000\200\000\ -\200\000\000\000\200\000\200\000\200\000\200\000\200\000\000\000\ -\000\000\000\000\000\000\000\000\200\000\000\000\200\000\000\000\ -\200\000\200\000\200\000\000\000\000\000\000\000\000\000\200\000\ -\200\000\205\000\200\000\200\000\200\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\200\000\000\000\200\000\000\000\000\000\ -\200\000\000\000\000\000\200\000\000\000\000\000\000\000\200\000\ -\153\000\153\000\153\000\153\000\000\000\000\000\000\000\000\000\ -\153\000\153\000\153\000\000\000\000\000\153\000\153\000\153\000\ -\153\000\153\000\153\000\153\000\153\000\153\000\000\000\000\000\ -\153\000\153\000\153\000\153\000\153\000\153\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\153\000\153\000\000\000\000\000\ -\153\000\153\000\153\000\153\000\153\000\153\000\153\000\000\000\ -\000\000\153\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\153\000\153\000\000\000\000\000\ -\000\000\000\000\153\000\153\000\153\000\000\000\153\000\000\000\ -\000\000\153\000\153\000\000\000\000\000\000\000\000\000\000\000\ -\153\000\000\000\153\000\000\000\000\000\000\000\153\000\000\000\ -\000\000\000\000\000\000\153\000\153\000\207\000\153\000\153\000\ -\153\000\000\000\000\000\000\000\153\000\000\000\000\000\153\000\ -\000\000\153\000\000\000\000\000\153\000\000\000\000\000\153\000\ -\000\000\000\000\000\000\153\000\000\000\192\000\192\000\192\000\ -\192\000\000\000\000\000\000\000\000\000\192\000\192\000\192\000\ -\000\000\000\000\192\000\192\000\000\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\000\000\000\000\192\000\192\000\192\000\ -\192\000\192\000\192\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\192\000\192\000\000\000\000\000\192\000\192\000\192\000\ -\192\000\000\000\000\000\000\000\000\000\000\000\192\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\192\000\192\000\000\000\192\000\000\000\000\000\192\000\ -\192\000\192\000\000\000\192\000\000\000\000\000\192\000\192\000\ -\000\000\000\000\000\000\000\000\000\000\192\000\000\000\192\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\192\000\192\000\193\000\192\000\192\000\192\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\192\000\000\000\192\000\000\000\ -\000\000\192\000\000\000\000\000\192\000\000\000\000\000\000\000\ -\192\000\205\000\205\000\205\000\205\000\000\000\000\000\000\000\ -\000\000\205\000\205\000\205\000\000\000\000\000\205\000\205\000\ -\000\000\205\000\205\000\205\000\205\000\205\000\205\000\000\000\ -\000\000\205\000\205\000\205\000\205\000\205\000\205\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\205\000\205\000\000\000\ -\000\000\205\000\205\000\205\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\205\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\205\000\205\000\000\000\ -\205\000\000\000\000\000\000\000\205\000\205\000\000\000\205\000\ -\000\000\000\000\205\000\205\000\000\000\000\000\000\000\000\000\ -\000\000\205\000\000\000\205\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\205\000\205\000\194\000\205\000\ -\205\000\205\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\205\000\000\000\205\000\000\000\000\000\205\000\000\000\000\000\ -\205\000\000\000\000\000\000\000\205\000\207\000\207\000\207\000\ -\207\000\000\000\000\000\000\000\000\000\207\000\207\000\207\000\ -\000\000\000\000\207\000\207\000\000\000\207\000\207\000\207\000\ -\207\000\207\000\207\000\000\000\000\000\207\000\207\000\207\000\ -\207\000\207\000\207\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\207\000\207\000\000\000\000\000\207\000\207\000\207\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\207\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\207\000\207\000\000\000\207\000\000\000\000\000\000\000\ -\207\000\207\000\000\000\207\000\000\000\000\000\207\000\207\000\ -\000\000\000\000\000\000\000\000\000\000\207\000\000\000\207\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\207\000\207\000\206\000\207\000\207\000\207\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\207\000\000\000\207\000\000\000\ -\000\000\207\000\000\000\000\000\207\000\000\000\000\000\000\000\ -\207\000\000\000\193\000\193\000\193\000\193\000\000\000\000\000\ -\000\000\000\000\193\000\193\000\193\000\000\000\000\000\193\000\ -\193\000\000\000\193\000\193\000\193\000\193\000\193\000\193\000\ -\000\000\000\000\193\000\193\000\193\000\193\000\193\000\193\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\193\000\193\000\ -\000\000\000\000\193\000\193\000\193\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\193\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\193\000\193\000\ -\000\000\193\000\000\000\000\000\000\000\193\000\193\000\000\000\ -\193\000\000\000\000\000\193\000\193\000\000\000\000\000\000\000\ -\000\000\000\000\193\000\000\000\193\000\000\000\000\000\211\000\ -\000\000\000\000\000\000\000\000\000\000\193\000\193\000\000\000\ -\193\000\193\000\193\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\193\000\000\000\193\000\000\000\000\000\193\000\000\000\ -\000\000\193\000\000\000\000\000\000\000\193\000\194\000\194\000\ -\194\000\194\000\000\000\000\000\000\000\000\000\194\000\194\000\ -\194\000\000\000\000\000\194\000\194\000\000\000\194\000\194\000\ -\194\000\194\000\194\000\194\000\000\000\000\000\194\000\194\000\ -\194\000\194\000\194\000\194\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\194\000\194\000\000\000\000\000\194\000\194\000\ -\194\000\000\000\000\000\000\000\000\000\000\000\000\000\194\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\194\000\194\000\000\000\194\000\000\000\000\000\ -\000\000\194\000\194\000\000\000\194\000\000\000\000\000\194\000\ -\194\000\000\000\000\000\000\000\210\000\000\000\194\000\000\000\ -\194\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\194\000\194\000\000\000\194\000\194\000\194\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\194\000\000\000\194\000\ -\000\000\000\000\194\000\000\000\000\000\194\000\000\000\000\000\ -\000\000\194\000\206\000\206\000\206\000\206\000\000\000\000\000\ -\000\000\000\000\206\000\206\000\206\000\000\000\000\000\206\000\ -\206\000\000\000\206\000\206\000\206\000\206\000\206\000\206\000\ -\000\000\000\000\206\000\206\000\206\000\206\000\206\000\206\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\206\000\206\000\ -\000\000\000\000\206\000\206\000\206\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\206\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\206\000\206\000\ -\000\000\206\000\000\000\000\000\209\000\206\000\206\000\000\000\ -\206\000\000\000\000\000\206\000\206\000\000\000\000\000\000\000\ -\000\000\000\000\206\000\000\000\206\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\206\000\206\000\000\000\ -\206\000\206\000\206\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\206\000\000\000\206\000\000\000\000\000\206\000\211\000\ -\000\000\206\000\211\000\000\000\000\000\206\000\000\000\211\000\ -\211\000\211\000\000\000\000\000\211\000\211\000\000\000\211\000\ -\211\000\211\000\211\000\211\000\211\000\000\000\000\000\211\000\ -\211\000\211\000\000\000\211\000\211\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\211\000\000\000\000\000\211\000\ -\211\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\211\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\211\000\073\001\000\000\211\000\000\000\ -\000\000\000\000\211\000\211\000\000\000\211\000\000\000\000\000\ -\211\000\211\000\000\000\000\000\000\000\000\000\000\000\211\000\ -\000\000\211\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\211\000\211\000\000\000\211\000\211\000\211\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\211\000\000\000\ -\211\000\000\000\000\000\211\000\210\000\000\000\211\000\210\000\ -\000\000\000\000\211\000\000\000\210\000\210\000\210\000\000\000\ -\000\000\210\000\210\000\000\000\210\000\210\000\210\000\210\000\ -\210\000\210\000\000\000\000\000\210\000\210\000\210\000\000\000\ -\210\000\210\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\210\000\000\000\000\000\210\000\210\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\210\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\208\000\000\000\000\000\000\000\ -\210\000\000\000\000\000\210\000\000\000\000\000\000\000\210\000\ -\210\000\000\000\210\000\000\000\000\000\210\000\210\000\000\000\ -\000\000\000\000\000\000\000\000\210\000\000\000\210\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\210\000\ -\210\000\000\000\210\000\210\000\210\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\210\000\209\000\210\000\000\000\209\000\ -\210\000\000\000\000\000\210\000\209\000\000\000\209\000\210\000\ -\000\000\209\000\209\000\000\000\209\000\209\000\209\000\209\000\ -\209\000\209\000\000\000\000\000\209\000\209\000\209\000\000\000\ -\209\000\209\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\209\000\000\000\000\000\209\000\209\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\209\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\072\001\000\000\000\000\000\000\ -\209\000\000\000\000\000\209\000\000\000\000\000\000\000\209\000\ -\209\000\000\000\209\000\000\000\000\000\209\000\209\000\000\000\ -\000\000\000\000\000\000\000\000\209\000\000\000\000\000\000\000\ -\000\000\000\000\214\002\000\000\000\000\000\000\000\000\209\000\ -\209\000\000\000\209\000\209\000\209\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\209\000\073\001\209\000\000\000\073\001\ -\209\000\000\000\000\000\209\000\073\001\000\000\073\001\209\000\ -\000\000\073\001\073\001\000\000\073\001\073\001\073\001\073\001\ -\073\001\073\001\000\000\000\000\073\001\073\001\073\001\000\000\ -\073\001\073\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\073\001\000\000\000\000\073\001\073\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\073\001\000\000\212\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\073\001\000\000\000\000\073\001\000\000\000\000\000\000\073\001\ -\073\001\000\000\073\001\000\000\000\000\073\001\073\001\000\000\ -\000\000\000\000\000\000\000\000\073\001\214\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\073\001\ -\073\001\000\000\073\001\073\001\073\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\073\001\208\000\073\001\000\000\208\000\ -\073\001\000\000\000\000\073\001\208\000\000\000\208\000\073\001\ -\000\000\208\000\208\000\000\000\208\000\208\000\208\000\208\000\ -\208\000\208\000\000\000\000\000\208\000\208\000\208\000\000\000\ -\208\000\208\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\208\000\000\000\000\000\208\000\208\000\000\000\000\000\ -\000\000\000\000\224\000\000\000\000\000\208\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\208\000\000\000\000\000\208\000\000\000\000\000\000\000\208\000\ -\208\000\000\000\208\000\000\000\000\000\208\000\208\000\000\000\ -\000\000\000\000\000\000\000\000\208\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\208\000\ -\208\000\000\000\208\000\208\000\208\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\208\000\072\001\208\000\000\000\072\001\ -\208\000\000\000\000\000\208\000\072\001\000\000\072\001\208\000\ -\000\000\072\001\072\001\000\000\072\001\072\001\072\001\072\001\ -\072\001\072\001\000\000\000\000\072\001\072\001\072\001\000\000\ -\072\001\072\001\214\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\072\001\214\002\000\000\072\001\072\001\000\000\214\002\ -\000\000\000\000\215\000\000\000\000\000\072\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\214\002\000\000\214\002\214\002\ -\072\001\000\000\000\000\072\001\000\000\000\000\000\000\072\001\ -\072\001\000\000\072\001\214\002\000\000\072\001\072\001\000\000\ -\099\000\000\000\000\000\000\000\072\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\214\002\072\001\ -\072\001\214\002\072\001\072\001\072\001\214\002\214\002\212\000\ -\000\000\000\000\212\000\072\001\214\002\072\001\000\000\212\000\ -\072\001\212\000\214\002\072\001\212\000\212\000\000\000\072\001\ -\212\000\000\000\212\000\212\000\212\000\000\000\214\002\212\000\ -\212\000\212\000\214\002\212\000\212\000\214\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\212\000\000\000\214\002\212\000\ -\212\000\214\002\214\002\000\000\000\000\188\000\000\000\000\000\ -\212\000\000\000\000\000\000\000\000\000\000\000\000\000\214\002\ -\000\000\214\002\214\002\212\000\000\000\000\000\212\000\000\000\ -\000\000\000\000\212\000\212\000\000\000\212\000\214\002\000\000\ -\212\000\212\000\000\000\212\002\000\000\000\000\000\000\212\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\214\002\212\000\212\000\214\002\212\000\212\000\212\000\ -\214\002\214\002\224\000\000\000\000\000\224\000\212\000\214\002\ -\212\000\000\000\224\000\212\000\224\000\214\002\212\000\224\000\ -\224\000\000\000\212\000\224\000\000\000\224\000\224\000\224\000\ -\000\000\214\002\224\000\224\000\224\000\214\002\224\000\224\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\224\000\ -\000\000\214\002\224\000\224\000\214\002\000\000\000\000\000\000\ -\217\000\000\000\000\000\224\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\224\000\000\000\ -\000\000\224\000\000\000\000\000\000\000\224\000\224\000\000\000\ -\224\000\000\000\000\000\224\000\224\000\000\000\000\000\000\000\ -\000\000\000\000\224\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\224\000\224\000\000\000\ -\224\000\224\000\224\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\224\000\215\000\224\000\000\000\215\000\224\000\000\000\ -\000\000\224\000\215\000\000\000\215\000\224\000\000\000\215\000\ -\215\000\000\000\000\000\215\000\000\000\215\000\215\000\215\000\ -\000\000\000\000\215\000\215\000\215\000\000\000\215\000\215\000\ -\099\000\000\000\000\000\000\000\000\000\000\000\000\000\215\000\ -\000\000\000\000\215\000\215\000\000\000\099\000\000\000\000\000\ -\216\000\000\000\000\000\215\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\099\000\000\000\099\000\099\000\215\000\000\000\ -\000\000\215\000\000\000\000\000\000\000\215\000\215\000\000\000\ -\215\000\099\000\000\000\215\000\215\000\000\000\100\000\000\000\ -\000\000\000\000\215\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\099\000\215\000\215\000\099\000\ -\215\000\215\000\215\000\099\000\099\000\188\000\000\000\000\000\ -\188\000\215\000\099\000\215\000\000\000\188\000\215\000\188\000\ -\099\000\215\000\188\000\188\000\000\000\215\000\188\000\000\000\ -\188\000\188\000\188\000\000\000\099\000\188\000\188\000\188\000\ -\099\000\188\000\188\000\212\002\000\000\000\000\212\002\000\000\ -\000\000\000\000\188\000\000\000\099\000\188\000\188\000\099\000\ -\212\002\000\000\000\000\220\000\000\000\000\000\188\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\212\002\000\000\212\002\ -\212\002\188\000\000\000\000\000\188\000\000\000\000\000\000\000\ -\188\000\188\000\000\000\188\000\212\002\000\000\188\000\188\000\ -\000\000\165\001\000\000\000\000\000\000\188\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\212\002\ -\188\000\188\000\212\002\188\000\188\000\188\000\000\000\212\002\ -\217\000\000\000\000\000\217\000\188\000\212\002\188\000\000\000\ -\217\000\188\000\217\000\212\002\188\000\217\000\217\000\000\000\ -\188\000\217\000\000\000\217\000\217\000\217\000\000\000\212\002\ -\217\000\217\000\217\000\212\002\217\000\217\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\217\000\000\000\212\002\ -\217\000\217\000\212\002\000\000\000\000\000\000\218\000\000\000\ -\000\000\217\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\217\000\000\000\000\000\217\000\ -\000\000\000\000\000\000\217\000\217\000\000\000\217\000\000\000\ -\000\000\217\000\217\000\000\000\000\000\000\000\000\000\000\000\ -\217\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\217\000\217\000\000\000\217\000\217\000\ -\217\000\000\000\000\000\000\000\000\000\000\000\000\000\217\000\ -\216\000\217\000\000\000\216\000\217\000\000\000\000\000\217\000\ -\216\000\000\000\216\000\217\000\000\000\216\000\216\000\000\000\ -\000\000\216\000\000\000\216\000\216\000\216\000\000\000\000\000\ -\216\000\216\000\216\000\000\000\216\000\216\000\100\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\216\000\000\000\000\000\ -\216\000\216\000\000\000\100\000\000\000\000\000\219\000\000\000\ -\000\000\216\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\100\000\000\000\100\000\100\000\216\000\000\000\000\000\216\000\ -\000\000\000\000\000\000\216\000\216\000\000\000\216\000\100\000\ -\000\000\216\000\216\000\000\000\212\002\000\000\000\000\000\000\ -\216\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\100\000\216\000\216\000\100\000\216\000\216\000\ -\216\000\100\000\100\000\220\000\000\000\000\000\220\000\216\000\ -\100\000\216\000\000\000\220\000\216\000\220\000\100\000\216\000\ -\220\000\220\000\000\000\216\000\220\000\000\000\220\000\220\000\ -\220\000\000\000\100\000\220\000\220\000\220\000\100\000\220\000\ -\220\000\165\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\220\000\000\000\100\000\220\000\220\000\100\000\165\001\000\000\ -\000\000\223\000\000\000\000\000\220\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\165\001\000\000\165\001\165\001\220\000\ -\000\000\000\000\220\000\000\000\000\000\000\000\220\000\220\000\ -\000\000\220\000\165\001\000\000\220\000\220\000\000\000\037\000\ -\000\000\000\000\000\000\220\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\165\001\220\000\220\000\ -\165\001\220\000\220\000\220\000\165\001\165\001\218\000\000\000\ -\000\000\218\000\220\000\165\001\220\000\000\000\218\000\220\000\ -\218\000\165\001\220\000\218\000\218\000\000\000\220\000\218\000\ -\000\000\218\000\218\000\218\000\000\000\165\001\218\000\218\000\ -\218\000\165\001\218\000\218\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\218\000\000\000\165\001\218\000\218\000\ -\165\001\000\000\000\000\000\000\221\000\000\000\000\000\218\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\218\000\000\000\000\000\218\000\000\000\000\000\ -\000\000\218\000\218\000\000\000\218\000\000\000\000\000\218\000\ -\218\000\000\000\000\000\000\000\000\000\000\000\218\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\218\000\218\000\000\000\218\000\218\000\218\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\218\000\219\000\218\000\ -\000\000\219\000\218\000\000\000\000\000\218\000\219\000\000\000\ -\219\000\218\000\000\000\219\000\219\000\000\000\000\000\219\000\ -\000\000\219\000\219\000\219\000\000\000\000\000\219\000\219\000\ -\219\000\000\000\219\000\219\000\212\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\219\000\000\000\000\000\219\000\219\000\ -\000\000\212\002\000\000\000\000\222\000\000\000\000\000\219\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\212\002\000\000\ -\212\002\212\002\219\000\000\000\000\000\219\000\000\000\000\000\ -\000\000\219\000\219\000\000\000\219\000\212\002\000\000\219\000\ -\219\000\000\000\040\000\000\000\000\000\000\000\219\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\212\002\219\000\219\000\212\002\219\000\219\000\219\000\000\000\ -\212\002\223\000\000\000\000\000\223\000\219\000\212\002\219\000\ -\000\000\223\000\219\000\223\000\212\002\219\000\223\000\223\000\ -\000\000\219\000\223\000\000\000\223\000\223\000\223\000\000\000\ -\212\002\223\000\223\000\223\000\212\002\223\000\223\000\037\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\223\000\000\000\ -\212\002\223\000\223\000\212\002\037\000\000\000\000\000\152\000\ -\000\000\000\000\223\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\037\000\000\000\037\000\037\000\223\000\000\000\000\000\ -\223\000\000\000\000\000\000\000\223\000\223\000\000\000\223\000\ -\037\000\000\000\223\000\223\000\000\000\000\000\000\000\000\000\ -\000\000\223\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\037\000\223\000\223\000\037\000\223\000\ -\223\000\223\000\000\000\037\000\221\000\000\000\000\000\221\000\ -\223\000\037\000\223\000\000\000\221\000\223\000\221\000\037\000\ -\223\000\221\000\221\000\000\000\223\000\221\000\000\000\221\000\ -\221\000\221\000\000\000\037\000\221\000\221\000\221\000\037\000\ -\221\000\221\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\221\000\000\000\037\000\221\000\221\000\037\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\221\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\003\002\000\000\000\000\ -\221\000\000\000\000\000\221\000\000\000\000\000\000\000\221\000\ -\221\000\000\000\221\000\000\000\000\000\221\000\221\000\000\000\ -\000\000\000\000\000\000\000\000\221\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\221\000\ -\221\000\000\000\221\000\221\000\221\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\221\000\222\000\221\000\000\000\222\000\ -\221\000\000\000\000\000\221\000\222\000\000\000\222\000\221\000\ -\000\000\222\000\222\000\000\000\000\000\222\000\000\000\222\000\ -\222\000\222\000\000\000\000\000\222\000\222\000\222\000\000\000\ -\222\000\222\000\040\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\222\000\000\000\000\000\222\000\222\000\000\000\040\000\ -\000\000\000\000\000\000\000\000\000\000\222\000\000\000\000\000\ -\189\000\000\000\000\000\000\000\040\000\000\000\040\000\040\000\ -\222\000\000\000\000\000\222\000\000\000\000\000\000\000\222\000\ -\222\000\000\000\222\000\040\000\000\000\222\000\222\000\000\000\ -\000\000\000\000\000\000\000\000\222\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\040\000\222\000\ -\222\000\040\000\222\000\222\000\222\000\000\000\040\000\152\000\ -\000\000\000\000\152\000\222\000\040\000\222\000\000\000\152\000\ -\222\000\152\000\040\000\222\000\152\000\152\000\000\000\222\000\ -\152\000\000\000\152\000\152\000\152\000\000\000\040\000\152\000\ -\152\000\152\000\040\000\152\000\152\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\152\000\000\000\040\000\152\000\ -\152\000\040\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\152\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\152\000\000\000\000\000\152\000\000\000\ -\000\000\000\000\152\000\152\000\037\002\152\000\000\000\000\000\ -\152\000\152\000\000\000\000\000\000\000\000\000\000\000\152\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\152\000\152\000\000\000\152\000\000\000\152\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\152\000\000\000\ -\152\000\000\000\000\000\152\000\000\000\003\002\152\000\003\002\ -\003\002\003\002\152\000\000\000\000\000\003\002\000\000\000\000\ -\000\000\000\000\003\002\000\000\000\000\000\000\003\002\003\002\ -\003\002\000\000\000\000\000\000\000\000\000\000\000\000\003\002\ -\003\002\003\002\003\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\003\002\000\000\000\000\000\000\003\002\003\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\003\002\003\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\001\002\ -\000\000\003\002\000\000\000\000\003\002\000\000\000\000\003\002\ -\003\002\003\002\000\000\003\002\000\000\000\000\003\002\003\002\ -\000\000\000\000\000\000\000\000\000\000\003\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\003\002\003\002\000\000\003\002\003\002\003\002\000\000\000\000\ -\189\000\003\002\000\000\189\000\000\000\000\000\000\000\000\000\ -\189\000\003\002\189\000\000\000\003\002\189\000\189\000\000\000\ -\003\002\189\000\000\000\189\000\189\000\189\000\000\000\000\000\ -\189\000\000\000\189\000\000\000\189\000\189\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\189\000\000\000\000\000\ -\189\000\189\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\189\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\255\001\000\000\189\000\000\000\000\000\189\000\ -\000\000\000\000\000\000\189\000\189\000\000\000\189\000\000\000\ -\000\000\189\000\189\000\000\000\000\000\000\000\000\000\000\000\ -\189\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\189\000\189\000\000\000\189\000\189\000\ -\189\000\000\000\000\000\000\000\000\000\000\000\000\000\189\000\ -\000\000\189\000\000\000\000\000\189\000\000\000\000\000\189\000\ -\000\000\000\000\000\000\189\000\037\002\000\000\037\002\037\002\ -\037\002\000\000\000\000\000\000\037\002\000\000\000\000\000\000\ -\000\000\037\002\000\000\000\000\000\000\037\002\037\002\037\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\037\002\037\002\ -\037\002\037\002\000\000\000\000\206\004\000\000\000\000\000\000\ -\037\002\000\000\000\000\000\000\000\000\037\002\000\000\000\002\ -\000\000\000\000\000\000\032\005\037\002\037\002\000\000\000\000\ -\000\000\000\000\198\001\000\000\000\000\000\000\000\000\000\000\ -\037\002\000\000\000\000\037\002\000\000\000\000\037\002\037\002\ -\037\002\000\000\037\002\000\000\000\000\037\002\037\002\000\000\ -\000\000\000\000\000\000\208\004\037\002\113\000\114\000\028\000\ -\000\000\115\000\000\000\000\000\116\000\209\004\000\000\037\002\ -\037\002\000\000\037\002\037\002\037\002\000\000\000\000\001\002\ -\000\000\001\002\001\002\001\002\000\000\118\000\000\000\001\002\ -\037\002\000\000\000\000\037\002\001\002\119\000\120\000\037\002\ -\001\002\001\002\001\002\000\000\000\000\121\000\000\000\000\000\ -\000\000\001\002\001\002\001\002\001\002\000\000\201\001\000\000\ -\000\000\211\004\123\000\001\002\000\000\000\000\000\000\000\000\ -\001\002\000\000\254\001\000\000\000\000\000\000\000\000\001\002\ -\001\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\001\002\000\000\000\000\001\002\000\000\ -\000\000\001\002\001\002\001\002\000\000\001\002\000\000\000\000\ -\000\000\001\002\000\000\000\000\000\000\000\000\000\000\001\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\001\002\001\002\000\000\001\002\001\002\001\002\ -\000\000\000\000\255\001\000\000\255\001\255\001\255\001\000\000\ -\000\000\000\000\255\001\001\002\000\000\000\000\001\002\255\001\ -\000\000\000\000\001\002\255\001\255\001\255\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\255\001\255\001\255\001\255\001\ -\000\000\000\000\000\000\000\000\146\000\000\000\255\001\000\000\ -\000\000\000\000\000\000\255\001\000\000\000\000\090\000\000\000\ -\000\000\000\000\255\001\255\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\255\001\000\000\ -\000\000\255\001\000\000\000\000\255\001\255\001\255\001\000\000\ -\255\001\000\000\000\000\000\000\255\001\000\000\000\000\000\000\ -\000\000\000\000\255\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\255\001\255\001\065\000\ -\255\001\255\001\255\001\000\000\000\000\000\000\000\000\000\002\ -\000\000\000\002\000\002\000\002\000\000\000\000\255\001\000\002\ -\000\000\255\001\000\000\000\000\000\002\255\001\000\000\000\000\ -\000\002\000\002\000\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\002\000\002\000\002\000\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\002\000\000\000\000\000\000\000\000\ -\000\002\000\000\000\000\000\000\000\000\000\000\000\000\000\002\ -\000\002\066\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\002\000\000\000\000\000\002\000\000\ -\000\000\000\002\000\002\000\002\000\000\000\002\000\000\000\000\ -\000\000\000\002\000\000\000\000\000\000\000\000\112\000\000\002\ -\113\000\114\000\028\000\000\000\115\000\000\000\000\000\116\000\ -\117\000\000\000\000\002\000\002\000\000\000\002\000\002\000\002\ -\000\000\000\000\254\001\000\000\254\001\254\001\254\001\000\000\ -\118\000\000\000\254\001\000\002\000\000\000\000\000\002\254\001\ -\119\000\120\000\000\002\254\001\254\001\254\001\000\000\000\000\ -\121\000\000\000\000\000\000\000\254\001\254\001\254\001\254\001\ -\000\000\000\000\000\000\000\000\122\000\123\000\254\001\000\000\ -\000\000\000\000\000\000\254\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\254\001\254\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\254\001\000\000\ -\000\000\254\001\214\002\000\000\254\001\254\001\254\001\000\000\ -\254\001\000\000\000\000\000\000\254\001\000\000\000\000\000\000\ -\000\000\000\000\254\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\146\000\254\001\254\001\146\000\ -\254\001\254\001\254\001\000\000\000\000\000\000\090\000\000\000\ -\000\000\146\000\000\000\000\000\000\000\146\000\254\001\146\000\ -\000\000\254\001\000\000\090\000\000\000\254\001\146\000\146\000\ -\146\000\146\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\090\000\000\000\090\000\090\000\000\000\146\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\090\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\065\000\ -\146\000\000\000\000\000\146\000\000\000\000\000\000\000\146\000\ -\146\000\000\000\090\000\000\000\065\000\146\000\146\000\000\000\ -\065\000\090\000\090\000\000\000\146\000\000\000\000\000\000\000\ -\090\000\065\000\065\000\065\000\065\000\106\002\090\000\000\000\ -\146\000\000\000\146\000\000\000\146\000\000\000\000\000\000\000\ -\065\000\000\000\090\000\000\000\000\000\000\000\090\000\000\000\ -\146\000\000\000\000\000\146\000\000\000\000\000\000\000\146\000\ -\000\000\066\000\090\000\065\000\066\000\090\000\065\000\000\000\ -\000\000\065\000\065\000\065\000\000\000\000\000\066\000\000\000\ -\065\000\065\000\066\000\000\000\000\000\000\000\000\000\065\000\ -\000\000\000\000\000\000\066\000\066\000\066\000\066\000\000\000\ -\000\000\000\000\000\000\065\000\000\000\065\000\000\000\065\000\ -\000\000\000\000\066\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\065\000\000\000\000\000\065\000\000\000\ -\000\000\000\000\065\000\000\000\000\000\066\000\000\000\000\000\ -\066\000\000\000\000\000\000\000\066\000\066\000\000\000\000\000\ -\000\000\000\000\066\000\066\000\112\000\000\000\113\000\114\000\ -\028\000\066\000\115\000\000\000\120\001\116\000\117\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\066\000\000\000\066\000\ -\000\000\066\000\000\000\000\000\000\000\000\000\118\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\066\000\119\000\060\003\ -\066\000\000\000\214\002\000\000\066\000\214\002\121\000\214\002\ -\214\002\214\002\214\002\000\000\000\000\214\002\214\002\214\002\ -\000\000\000\000\122\000\123\000\000\000\214\002\000\000\000\000\ -\000\000\214\002\000\000\000\000\214\002\000\000\214\002\214\002\ -\214\002\214\002\214\002\214\002\214\002\214\002\214\002\000\000\ -\000\000\214\002\214\002\214\002\000\000\000\000\098\002\000\000\ -\000\000\000\000\214\002\214\002\214\002\214\002\214\002\214\002\ -\214\002\214\002\214\002\214\002\214\002\214\002\214\002\214\002\ -\000\000\214\002\214\002\214\002\000\000\214\002\214\002\214\002\ -\214\002\214\002\214\002\000\000\214\002\214\002\000\000\214\002\ -\214\002\000\000\214\002\214\002\000\000\000\000\214\002\214\002\ -\000\000\214\002\214\002\214\002\214\002\214\002\214\002\214\002\ -\000\000\214\002\214\002\214\002\000\000\214\002\000\000\214\002\ -\214\002\000\000\214\002\000\000\214\002\214\002\214\002\214\002\ -\214\002\214\002\214\002\212\001\214\002\106\002\000\000\000\000\ -\000\000\106\002\000\000\106\002\000\000\106\002\000\000\106\002\ -\000\000\106\002\000\000\106\002\106\002\000\000\106\002\106\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\106\002\106\002\000\000\106\002\106\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\106\002\ -\106\002\106\002\106\002\000\000\106\002\106\002\000\000\000\000\ -\106\002\213\001\000\000\000\000\000\000\106\002\106\002\106\002\ -\000\000\000\000\000\000\000\000\106\002\000\000\106\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\106\002\000\000\ -\000\000\106\002\000\000\000\000\000\000\000\000\106\002\000\000\ -\106\002\106\002\000\000\106\002\106\002\000\000\106\002\000\000\ -\000\000\000\000\106\002\000\000\000\000\106\002\000\000\106\002\ -\000\000\000\000\106\002\106\002\120\001\000\000\106\002\000\000\ -\120\001\000\000\120\001\212\002\120\001\000\000\120\001\000\000\ -\120\001\000\000\120\001\120\001\000\000\120\001\120\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\120\001\ -\000\000\000\000\120\001\120\001\000\000\000\000\000\000\000\000\ -\000\000\064\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\120\001\120\001\ -\000\000\120\001\000\000\120\001\120\001\000\000\000\000\120\001\ -\000\000\000\000\000\000\000\000\120\001\120\001\120\001\000\000\ -\000\000\000\000\000\000\120\001\000\000\120\001\098\002\000\000\ -\000\000\098\002\000\000\000\000\000\000\120\001\098\002\000\000\ -\120\001\000\000\000\000\098\002\098\002\120\001\000\000\120\001\ -\120\001\098\002\120\001\120\001\119\002\120\001\000\000\000\000\ -\098\002\120\001\098\002\098\002\120\001\000\000\120\001\000\000\ -\000\000\120\001\120\001\000\000\000\000\120\001\000\000\098\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\031\002\ -\209\001\031\002\031\002\031\002\000\000\031\002\000\000\000\000\ -\031\002\031\002\098\002\000\000\000\000\098\002\000\000\119\002\ -\098\002\098\002\098\002\212\001\000\000\000\000\212\001\000\000\ -\098\002\031\002\000\000\212\001\000\000\098\002\098\002\000\000\ -\212\001\031\002\031\002\000\000\000\000\000\000\212\001\000\000\ -\000\000\031\002\098\002\000\000\000\000\212\001\098\002\212\001\ -\212\001\000\000\000\000\000\000\000\000\031\002\031\002\000\000\ -\063\000\000\000\098\002\212\001\212\001\098\002\214\002\000\000\ -\214\002\214\002\214\002\000\000\214\002\000\000\000\000\214\002\ -\214\002\000\000\000\000\000\000\000\000\000\000\000\000\212\001\ -\000\000\213\001\212\001\000\000\213\001\212\001\212\001\212\001\ -\214\002\213\001\000\000\000\000\040\002\212\001\213\001\000\000\ -\214\002\214\002\000\000\212\001\213\001\000\000\000\000\000\000\ -\214\002\000\000\000\000\213\001\000\000\213\001\213\001\212\001\ -\131\000\000\000\000\000\212\001\214\002\214\002\000\000\040\002\ -\000\000\213\001\213\001\000\000\000\000\000\000\000\000\212\001\ -\000\000\000\000\212\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\212\002\000\000\213\001\212\002\000\000\ -\213\001\000\000\000\000\213\001\213\001\213\001\000\000\000\000\ -\212\002\000\000\213\001\213\001\000\000\000\000\212\002\000\000\ -\000\000\213\001\000\000\000\000\000\000\212\002\000\000\212\002\ -\212\002\064\000\174\001\000\000\064\000\213\001\000\000\000\000\ -\000\000\213\001\000\000\212\002\212\002\000\000\064\000\000\000\ -\000\000\000\000\064\000\212\002\212\002\213\001\000\000\000\000\ -\213\001\000\000\000\000\064\000\064\000\064\000\064\000\212\002\ -\000\000\000\000\212\002\000\000\000\000\000\000\000\000\212\002\ -\000\000\212\002\064\000\000\000\000\000\212\002\000\000\000\000\ -\000\000\000\000\241\001\212\002\241\001\241\001\241\001\000\000\ -\241\001\000\000\214\002\241\001\241\001\064\000\000\000\212\002\ -\064\000\000\000\000\000\212\002\064\000\064\000\000\000\000\000\ -\000\000\000\000\008\000\064\000\241\001\000\000\000\000\212\002\ -\011\000\064\000\212\002\000\000\241\001\241\001\000\000\000\000\ -\209\001\000\000\000\000\209\001\241\001\064\000\000\000\064\000\ -\209\001\064\000\015\000\016\000\000\000\209\001\000\000\000\000\ -\241\001\241\001\000\000\209\001\000\000\064\000\000\000\174\001\ -\064\000\000\000\209\001\000\000\209\001\209\001\022\000\000\000\ -\138\000\139\000\000\000\140\000\141\000\000\000\000\000\028\000\ -\000\000\209\001\000\000\000\000\142\000\143\000\000\000\000\000\ -\000\000\000\000\000\000\144\000\000\000\000\000\000\000\000\000\ -\063\000\000\000\000\000\063\000\209\001\000\000\000\000\209\001\ -\145\000\000\000\209\001\209\001\209\001\063\000\000\000\000\000\ -\000\000\063\000\209\001\000\000\175\001\146\000\000\000\000\000\ -\209\001\044\000\063\000\063\000\063\000\063\000\045\000\000\000\ -\000\000\048\000\147\000\000\000\209\001\000\000\000\000\000\000\ -\209\001\063\000\000\000\209\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\209\001\000\000\000\000\209\001\ -\131\000\000\000\000\000\131\000\063\000\000\000\000\000\063\000\ -\000\000\000\000\000\000\063\000\063\000\131\000\000\000\000\000\ -\000\000\177\001\063\000\131\000\000\000\000\000\000\000\000\000\ -\063\000\000\000\131\000\000\000\131\000\131\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\063\000\000\000\063\000\000\000\ -\063\000\131\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\131\000\000\000\000\000\000\000\063\000\000\000\000\000\063\000\ -\000\000\000\000\174\001\000\000\131\000\174\001\000\000\131\000\ -\000\000\000\000\000\000\131\000\131\000\000\000\131\000\174\001\ -\000\000\176\001\131\000\000\000\000\000\174\001\000\000\000\000\ -\131\000\000\000\000\000\000\000\174\001\000\000\174\001\174\001\ -\000\000\000\000\000\000\000\000\131\000\000\000\000\000\000\000\ -\131\000\000\000\000\000\174\001\000\000\000\000\000\000\178\001\ -\000\000\000\000\000\000\000\000\131\000\000\000\000\000\131\000\ -\000\000\000\000\214\002\000\000\000\000\214\002\174\001\000\000\ -\000\000\174\001\214\002\000\000\000\000\174\001\174\001\214\002\ -\000\000\000\000\000\000\000\000\174\001\214\002\000\000\000\000\ -\000\000\000\000\174\001\000\000\214\002\000\000\214\002\214\002\ -\115\002\000\000\000\000\000\000\000\000\000\000\174\001\000\000\ -\000\000\000\000\174\001\214\002\000\000\000\000\000\000\182\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\174\001\174\001\ -\000\000\174\001\174\001\000\000\000\000\000\000\214\002\000\000\ -\209\001\214\002\000\000\000\000\174\001\214\002\214\002\000\000\ -\000\000\000\000\174\001\000\000\214\002\000\000\000\000\000\000\ -\000\000\174\001\214\002\174\001\174\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\214\002\000\000\ -\174\001\000\000\214\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\175\001\000\000\214\002\175\001\ -\000\000\214\002\000\000\174\001\000\000\000\000\174\001\000\000\ -\044\000\175\001\174\001\174\001\000\000\000\000\000\000\175\001\ -\000\000\174\001\000\000\209\001\000\000\000\000\175\001\174\001\ -\175\001\175\001\000\000\209\001\000\000\047\000\000\000\000\000\ -\209\001\000\000\000\000\174\001\000\000\175\001\085\000\174\001\ -\000\000\000\000\000\000\000\000\000\000\209\001\000\000\209\001\ -\209\001\177\001\000\000\174\001\177\001\000\000\174\001\000\000\ -\175\001\000\000\000\000\175\001\209\001\000\000\177\001\175\001\ -\175\001\000\000\000\000\000\000\177\001\000\000\175\001\000\000\ -\000\000\212\002\000\000\177\001\175\001\177\001\177\001\209\001\ -\000\000\000\000\209\001\000\000\000\000\209\001\209\001\209\001\ -\175\001\000\000\177\001\000\000\175\001\209\001\081\000\000\000\ -\000\000\000\000\000\000\209\001\000\000\000\000\000\000\000\000\ -\175\001\176\001\000\000\175\001\176\001\177\001\000\000\209\001\ -\177\001\000\000\000\000\209\001\177\001\177\001\176\001\000\000\ -\000\000\000\000\000\000\177\001\176\001\000\000\000\000\209\001\ -\000\000\177\001\209\001\176\001\000\000\176\001\176\001\178\001\ -\000\000\000\000\178\001\000\000\000\000\177\001\000\000\000\000\ -\000\000\177\001\176\001\000\000\178\001\000\000\000\000\000\000\ -\000\000\000\000\178\001\000\000\000\000\177\001\000\000\000\000\ -\177\001\178\001\000\000\178\001\178\001\176\001\000\000\000\000\ -\176\001\000\000\000\000\000\000\176\001\176\001\000\000\000\000\ -\178\001\000\000\000\000\176\001\000\000\000\000\000\000\000\000\ -\000\000\176\001\000\000\000\000\000\000\000\000\000\000\182\001\ -\000\000\000\000\182\001\178\001\000\000\176\001\178\001\000\000\ -\000\000\176\001\178\001\178\001\182\001\000\000\000\000\000\000\ -\209\001\178\001\182\001\000\000\000\000\176\001\000\000\178\001\ -\176\001\182\001\000\000\182\001\182\001\209\001\000\000\000\000\ -\000\000\000\000\000\000\178\001\000\000\000\000\000\000\178\001\ -\182\001\000\000\209\001\000\000\209\001\209\001\000\000\000\000\ -\000\000\000\000\000\000\178\001\000\000\000\000\178\001\000\000\ -\000\000\209\001\000\000\182\001\000\000\000\000\182\001\000\000\ -\000\000\000\000\182\001\182\001\000\000\000\000\000\000\000\000\ -\044\000\182\001\000\000\000\000\209\001\000\000\000\000\182\001\ -\000\000\000\000\209\001\209\001\209\001\044\000\000\000\000\000\ -\000\000\000\000\209\001\182\001\000\000\047\000\000\000\182\001\ -\209\001\000\000\044\000\000\000\044\000\044\000\085\000\000\000\ -\000\000\000\000\047\000\182\001\209\001\000\000\182\001\000\000\ -\209\001\044\000\000\000\085\000\000\000\000\000\000\000\047\000\ -\000\000\047\000\047\000\000\000\209\001\000\000\000\000\209\001\ -\085\000\000\000\085\000\085\000\044\000\000\000\047\000\044\000\ -\000\000\212\002\000\000\000\000\044\000\000\000\000\000\085\000\ -\000\000\000\000\044\000\000\000\000\000\000\000\212\002\000\000\ -\044\000\047\000\000\000\000\000\047\000\000\000\081\000\000\000\ -\000\000\047\000\085\000\212\002\044\000\212\002\212\002\047\000\ -\044\000\000\000\085\000\081\000\000\000\047\000\000\000\000\000\ -\085\000\000\000\212\002\000\000\044\000\000\000\085\000\044\000\ -\081\000\047\000\081\000\081\000\000\000\047\000\000\000\000\000\ -\000\000\000\000\085\000\000\000\000\000\212\002\085\000\081\000\ -\000\000\047\000\000\000\000\000\047\000\212\002\000\000\000\000\ -\000\000\000\000\085\000\212\002\000\000\085\000\000\000\000\000\ -\000\000\212\002\081\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\081\000\000\000\000\000\212\002\000\000\000\000\ -\081\000\212\002\000\000\000\000\000\000\000\000\081\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\212\002\000\000\000\000\ -\212\002\000\000\081\000\207\002\000\000\000\000\081\000\000\000\ -\207\002\207\002\207\002\207\002\000\000\000\000\207\002\207\002\ -\207\002\207\002\081\000\000\000\000\000\081\000\207\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\207\002\000\000\207\002\ -\207\002\207\002\207\002\207\002\207\002\207\002\207\002\000\000\ -\000\000\000\000\207\002\000\000\207\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\207\002\207\002\207\002\207\002\ -\207\002\207\002\207\002\207\002\000\000\000\000\207\002\207\002\ -\000\000\000\000\207\002\207\002\207\002\207\002\000\000\207\002\ -\207\002\207\002\207\002\207\002\000\000\207\002\000\000\000\000\ -\207\002\207\002\000\000\207\002\207\002\000\000\000\000\207\002\ -\207\002\000\000\207\002\000\000\207\002\207\002\000\000\207\002\ -\207\002\000\000\000\000\207\002\207\002\000\000\207\002\000\000\ -\207\002\207\002\000\000\207\002\000\000\207\002\207\002\207\002\ -\207\002\207\002\207\002\207\002\214\002\207\002\000\000\000\000\ -\000\000\214\002\214\002\214\002\214\002\000\000\000\000\214\002\ -\214\002\000\000\000\000\000\000\000\000\000\000\000\000\214\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\214\002\000\000\ -\214\002\000\000\214\002\214\002\214\002\214\002\214\002\214\002\ -\000\000\000\000\000\000\214\002\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\214\002\214\002\214\002\ -\214\002\214\002\214\002\214\002\214\002\000\000\000\000\214\002\ -\214\002\000\000\000\000\214\002\214\002\214\002\000\000\000\000\ -\214\002\214\002\214\002\214\002\214\002\000\000\214\002\000\000\ -\000\000\214\002\214\002\000\000\000\000\214\002\000\000\000\000\ -\214\002\214\002\000\000\214\002\000\000\214\002\214\002\000\000\ -\000\000\214\002\000\000\000\000\000\000\214\002\000\000\214\002\ -\000\000\214\002\214\002\000\000\214\002\000\000\214\002\214\002\ -\000\000\214\002\214\002\214\002\214\002\000\000\214\002\001\001\ -\002\001\003\001\000\000\000\000\007\000\008\000\004\001\000\000\ -\005\001\000\000\010\000\011\000\000\000\000\000\006\001\007\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\008\001\000\000\000\000\015\000\016\000\017\000\ -\018\000\019\000\000\000\009\001\000\000\000\000\020\000\000\000\ -\000\000\010\001\011\001\012\001\013\001\014\001\015\001\000\000\ -\000\000\022\000\000\000\023\000\024\000\025\000\026\000\027\000\ -\000\000\000\000\028\000\000\000\016\001\000\000\030\000\031\000\ -\032\000\000\000\000\000\000\000\034\000\000\000\017\001\018\001\ -\000\000\019\001\000\000\000\000\000\000\038\000\000\000\000\000\ -\000\000\020\001\021\001\022\001\023\001\024\001\025\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\026\001\000\000\000\000\ -\000\000\027\001\000\000\028\001\044\000\000\000\000\000\000\000\ -\000\000\045\000\046\000\000\000\048\000\049\000\001\001\002\001\ -\003\001\051\000\000\000\007\000\008\000\004\001\000\000\005\001\ -\000\000\010\000\011\000\000\000\000\000\018\003\007\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\008\001\000\000\000\000\015\000\016\000\017\000\018\000\ -\019\000\000\000\009\001\000\000\000\000\020\000\000\000\000\000\ -\010\001\011\001\012\001\013\001\014\001\015\001\000\000\000\000\ -\022\000\000\000\023\000\024\000\025\000\026\000\027\000\000\000\ -\000\000\028\000\000\000\016\001\000\000\030\000\031\000\032\000\ -\000\000\000\000\000\000\034\000\000\000\017\001\018\001\000\000\ -\019\003\000\000\000\000\000\000\038\000\000\000\000\000\000\000\ -\020\001\021\001\022\001\023\001\024\001\025\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\020\003\000\000\000\000\000\000\ -\027\001\000\000\028\001\044\000\000\000\000\000\000\000\000\000\ -\045\000\046\000\000\000\048\000\049\000\214\002\000\000\000\000\ -\051\000\000\000\214\002\214\002\214\002\000\000\000\000\000\000\ -\214\002\214\002\214\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\214\002\ -\000\000\214\002\214\002\214\002\214\002\214\002\214\002\214\002\ -\000\000\000\000\000\000\000\000\214\002\000\000\214\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\214\002\ -\000\000\214\002\214\002\214\002\214\002\214\002\000\000\000\000\ -\214\002\214\002\000\000\000\000\214\002\214\002\214\002\000\000\ -\000\000\214\002\214\002\000\000\214\002\214\002\000\000\214\002\ -\000\000\000\000\000\000\214\002\000\000\214\002\000\000\000\000\ -\000\000\214\002\214\002\085\002\214\002\000\000\000\000\000\000\ -\152\002\152\002\152\002\000\000\000\000\214\002\152\002\152\002\ -\000\000\000\000\214\002\000\000\000\000\000\000\000\000\214\002\ -\214\002\214\002\214\002\214\002\214\002\000\000\000\000\214\002\ -\000\000\152\002\152\002\152\002\152\002\152\002\000\000\000\000\ -\000\000\000\000\152\002\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\152\002\000\000\152\002\ -\152\002\152\002\152\002\152\002\000\000\000\000\152\002\000\000\ -\000\000\000\000\152\002\152\002\152\002\000\000\000\000\000\000\ -\152\002\000\000\152\002\152\002\000\000\000\000\000\000\000\000\ -\000\000\152\002\000\000\000\000\000\000\000\000\000\000\152\002\ -\152\002\086\002\152\002\000\000\000\000\000\000\153\002\153\002\ -\153\002\085\002\000\000\000\000\153\002\153\002\000\000\000\000\ -\152\002\000\000\000\000\000\000\000\000\152\002\152\002\000\000\ -\152\002\152\002\000\000\000\000\000\000\152\002\000\000\153\002\ -\153\002\153\002\153\002\153\002\000\000\000\000\000\000\000\000\ -\153\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\153\002\000\000\153\002\153\002\153\002\ -\153\002\153\002\000\000\000\000\153\002\000\000\000\000\000\000\ -\153\002\153\002\153\002\000\000\000\000\000\000\153\002\000\000\ -\153\002\153\002\000\000\000\000\000\000\000\000\000\000\153\002\ -\000\000\000\000\000\000\000\000\000\000\153\002\153\002\083\002\ -\153\002\000\000\000\000\000\000\154\002\154\002\154\002\086\002\ -\000\000\000\000\154\002\154\002\000\000\000\000\153\002\000\000\ -\000\000\000\000\000\000\153\002\153\002\000\000\153\002\153\002\ -\000\000\000\000\000\000\153\002\000\000\154\002\154\002\154\002\ -\154\002\154\002\000\000\000\000\000\000\000\000\154\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\154\002\000\000\154\002\154\002\154\002\154\002\154\002\ -\000\000\000\000\154\002\000\000\000\000\000\000\154\002\154\002\ -\154\002\000\000\000\000\000\000\154\002\000\000\154\002\154\002\ -\000\000\000\000\000\000\000\000\000\000\154\002\000\000\000\000\ -\000\000\000\000\000\000\154\002\154\002\084\002\154\002\000\000\ -\000\000\000\000\155\002\155\002\155\002\083\002\000\000\000\000\ -\155\002\155\002\000\000\000\000\154\002\000\000\000\000\000\000\ -\000\000\154\002\154\002\000\000\154\002\154\002\000\000\000\000\ -\000\000\154\002\000\000\155\002\155\002\155\002\155\002\155\002\ -\000\000\000\000\000\000\000\000\155\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\155\002\ -\000\000\155\002\155\002\155\002\155\002\155\002\000\000\000\000\ -\155\002\000\000\000\000\000\000\155\002\155\002\155\002\000\000\ -\000\000\000\000\155\002\000\000\155\002\155\002\000\000\000\000\ -\000\000\000\000\000\000\155\002\000\000\000\000\000\000\000\000\ -\000\000\155\002\155\002\000\000\155\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\084\002\199\000\200\000\201\000\000\000\ -\000\000\000\000\155\002\000\000\202\000\000\000\203\000\155\002\ -\155\002\000\000\155\002\155\002\204\000\205\000\206\000\155\002\ -\000\000\207\000\208\000\209\000\000\000\210\000\211\000\212\000\ -\000\000\213\000\214\000\215\000\216\000\000\000\000\000\000\000\ -\217\000\218\000\219\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\220\000\221\000\000\000\000\000\222\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\223\000\224\000\000\000\000\000\000\000\004\002\225\000\226\000\ -\000\000\004\002\000\000\227\000\228\000\229\000\230\000\231\000\ -\232\000\233\000\000\000\234\000\000\000\000\000\004\002\000\000\ -\004\002\235\000\000\000\243\001\000\000\000\000\236\000\004\002\ -\004\002\000\000\000\000\000\000\237\000\000\000\000\000\238\000\ -\239\000\004\002\240\000\241\000\242\000\243\000\244\000\000\000\ -\245\000\246\000\247\000\248\000\249\000\004\002\004\002\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\004\002\000\000\000\000\000\000\004\002\000\000\004\002\ -\004\002\004\002\000\000\004\002\000\000\000\000\004\002\000\000\ -\000\000\000\000\001\001\002\001\003\001\000\000\000\000\000\000\ -\008\000\164\001\000\000\005\001\000\000\000\000\011\000\243\001\ -\004\002\006\001\007\001\000\000\004\002\000\000\004\002\000\000\ -\000\000\004\002\000\000\000\000\000\000\008\001\137\000\000\000\ -\015\000\016\000\004\002\000\000\004\002\000\000\009\001\000\000\ -\000\000\000\000\000\000\000\000\010\001\011\001\012\001\013\001\ -\014\001\015\001\000\000\000\000\022\000\000\000\138\000\139\000\ -\000\000\140\000\141\000\000\000\000\000\028\000\000\000\016\001\ -\000\000\000\000\142\000\143\000\000\000\000\000\000\000\000\000\ -\000\000\165\001\166\001\000\000\167\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\020\001\021\001\168\001\169\001\ -\024\001\170\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\026\001\000\000\000\000\146\000\027\001\000\000\028\001\044\000\ -\000\000\000\000\000\000\000\000\045\000\000\000\179\002\048\000\ -\147\000\001\001\002\001\003\001\000\000\000\000\000\000\008\000\ -\164\001\000\000\005\001\000\000\000\000\011\000\000\000\000\000\ -\006\001\007\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\008\001\137\000\000\000\015\000\ -\016\000\000\000\000\000\000\000\000\000\009\001\000\000\000\000\ -\000\000\000\000\000\000\010\001\011\001\012\001\013\001\014\001\ -\015\001\000\000\000\000\022\000\000\000\138\000\139\000\000\000\ -\140\000\141\000\000\000\000\000\028\000\000\000\016\001\000\000\ -\000\000\142\000\143\000\000\000\000\000\000\000\000\000\000\000\ -\165\001\166\001\000\000\167\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\020\001\021\001\168\001\169\001\024\001\ -\170\001\000\000\000\000\000\000\000\000\000\000\000\000\026\001\ -\000\000\000\000\146\000\027\001\000\000\028\001\044\000\000\000\ -\000\000\000\000\000\000\045\000\000\000\124\003\048\000\147\000\ -\001\001\002\001\003\001\000\000\000\000\000\000\008\000\164\001\ -\000\000\005\001\000\000\000\000\011\000\000\000\000\000\006\001\ -\007\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\008\001\137\000\000\000\015\000\016\000\ -\000\000\000\000\000\000\000\000\009\001\000\000\000\000\000\000\ -\000\000\000\000\010\001\011\001\012\001\013\001\014\001\015\001\ -\000\000\000\000\022\000\000\000\138\000\139\000\000\000\140\000\ -\141\000\000\000\000\000\028\000\000\000\016\001\000\000\000\000\ -\142\000\143\000\000\000\000\000\000\000\000\000\000\000\165\001\ -\166\001\000\000\167\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\020\001\021\001\168\001\169\001\024\001\170\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\026\001\000\000\ -\000\000\146\000\027\001\000\000\028\001\044\000\000\000\000\000\ -\000\000\000\000\045\000\000\000\073\004\048\000\147\000\001\001\ -\002\001\003\001\000\000\000\000\000\000\008\000\164\001\000\000\ -\005\001\000\000\000\000\011\000\000\000\000\000\006\001\007\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\008\001\137\000\000\000\015\000\016\000\000\000\ -\000\000\000\000\000\000\009\001\000\000\000\000\000\000\000\000\ -\000\000\010\001\011\001\012\001\013\001\014\001\015\001\000\000\ -\000\000\022\000\000\000\138\000\139\000\000\000\140\000\141\000\ -\000\000\000\000\028\000\000\000\016\001\000\000\000\000\142\000\ -\143\000\000\000\000\000\000\000\000\000\000\000\165\001\166\001\ -\000\000\167\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\020\001\021\001\168\001\169\001\024\001\170\001\000\000\ -\000\000\091\003\000\000\000\000\000\000\026\001\000\000\008\000\ -\146\000\027\001\000\000\028\001\044\000\011\000\000\000\000\000\ -\018\003\045\000\000\000\000\000\048\000\147\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\137\000\000\000\015\000\ -\016\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\022\000\000\000\138\000\139\000\000\000\ -\140\000\141\000\000\000\000\000\028\000\000\000\143\002\000\000\ -\000\000\142\000\143\000\000\000\008\000\000\000\000\000\000\000\ -\144\000\000\000\011\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\145\000\000\000\000\000\ -\000\000\000\000\137\000\000\000\015\000\016\000\000\000\092\003\ -\000\000\000\000\146\000\000\000\000\000\000\000\044\000\000\000\ -\000\000\000\000\000\000\045\000\000\000\000\000\048\000\147\000\ -\022\000\000\000\138\000\139\000\000\000\140\000\141\000\000\000\ -\000\000\028\000\000\000\145\002\000\000\000\000\142\000\143\000\ -\000\000\008\000\000\000\000\000\000\000\144\000\000\000\011\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\145\000\000\000\000\000\000\000\000\000\137\000\ -\000\000\015\000\016\000\000\000\000\000\000\000\000\000\146\000\ -\000\000\000\000\000\000\044\000\000\000\000\000\000\000\000\000\ -\045\000\000\000\000\000\048\000\147\000\022\000\000\000\138\000\ -\139\000\000\000\140\000\141\000\000\000\000\000\028\000\000\000\ -\080\004\000\000\000\000\142\000\143\000\000\000\008\000\000\000\ -\000\000\000\000\144\000\000\000\011\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\145\000\ -\000\000\000\000\000\000\000\000\137\000\000\000\015\000\016\000\ -\000\000\000\000\000\000\000\000\146\000\000\000\000\000\000\000\ -\044\000\000\000\000\000\000\000\000\000\045\000\000\000\000\000\ -\048\000\147\000\022\000\000\000\138\000\139\000\000\000\140\000\ -\141\000\000\000\000\000\028\000\000\000\082\004\000\000\000\000\ -\142\000\143\000\000\000\008\000\000\000\000\000\000\000\144\000\ -\000\000\011\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\145\000\000\000\000\000\000\000\ -\000\000\137\000\000\000\015\000\016\000\000\000\000\000\000\000\ -\000\000\146\000\000\000\000\000\000\000\044\000\000\000\000\000\ -\000\000\000\000\045\000\000\000\000\000\048\000\147\000\022\000\ -\000\000\138\000\139\000\000\000\140\000\141\000\000\000\000\000\ -\028\000\000\000\084\004\000\000\000\000\142\000\143\000\000\000\ -\008\000\000\000\000\000\000\000\144\000\000\000\011\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\145\000\000\000\000\000\000\000\000\000\137\000\000\000\ -\015\000\016\000\000\000\000\000\000\000\000\000\146\000\000\000\ -\000\000\000\000\044\000\000\000\000\000\000\000\000\000\045\000\ -\000\000\000\000\048\000\147\000\022\000\000\000\138\000\139\000\ -\000\000\140\000\141\000\000\000\000\000\028\000\000\000\000\000\ -\000\000\000\000\142\000\143\000\007\000\008\000\009\000\000\000\ -\000\000\144\000\010\000\011\000\012\000\243\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\145\000\000\000\ -\000\000\000\000\000\000\013\000\014\000\015\000\016\000\017\000\ -\018\000\019\000\000\000\146\000\000\000\000\000\020\000\044\000\ -\021\000\000\000\000\000\000\000\045\000\000\000\000\000\048\000\ -\147\000\022\000\000\000\023\000\024\000\025\000\026\000\027\000\ -\000\000\000\000\028\000\029\000\000\000\000\000\030\000\031\000\ -\032\000\000\000\000\000\033\000\034\000\000\000\035\000\036\000\ -\000\000\037\000\000\000\000\000\000\000\038\000\000\000\039\000\ -\000\000\000\000\000\000\040\000\041\000\000\000\042\000\000\000\ -\244\001\000\000\000\000\007\000\008\000\009\000\000\000\043\000\ -\000\000\010\000\011\000\012\000\044\000\000\000\000\000\000\000\ -\000\000\045\000\046\000\047\000\048\000\049\000\050\000\000\000\ -\000\000\051\000\013\000\014\000\015\000\016\000\017\000\018\000\ -\019\000\000\000\000\000\000\000\000\000\020\000\000\000\021\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\022\000\000\000\023\000\024\000\025\000\026\000\027\000\000\000\ -\000\000\028\000\029\000\000\000\000\000\030\000\031\000\032\000\ -\000\000\000\000\033\000\034\000\000\000\035\000\036\000\000\000\ -\037\000\000\000\000\000\000\000\038\000\000\000\039\000\000\000\ -\000\000\000\000\040\000\041\000\000\000\042\000\000\000\000\000\ -\000\000\007\000\008\000\009\000\000\000\000\000\043\000\010\000\ -\011\000\000\000\000\000\044\000\000\000\000\000\000\000\000\000\ -\045\000\046\000\047\000\048\000\049\000\050\000\000\000\000\000\ -\051\000\000\000\015\000\016\000\017\000\018\000\019\000\000\000\ -\000\000\000\000\000\000\020\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\022\000\000\000\ -\023\000\024\000\025\000\026\000\027\000\000\000\000\000\028\000\ -\000\000\000\000\000\000\030\000\031\000\032\000\000\000\000\000\ -\000\000\034\000\000\000\035\000\036\000\000\000\000\000\000\000\ -\000\000\000\000\038\000\000\000\000\000\000\000\000\000\000\000\ -\040\000\041\000\000\000\042\000\000\000\000\000\000\000\000\000\ -\194\000\007\000\008\000\009\000\000\000\000\000\197\000\010\000\ -\011\000\044\000\000\000\000\000\000\000\000\000\045\000\046\000\ -\000\000\048\000\049\000\000\000\000\000\000\000\051\000\000\000\ -\000\000\000\000\015\000\016\000\017\000\018\000\019\000\000\000\ -\000\000\000\000\000\000\020\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\022\000\000\000\ -\023\000\024\000\025\000\026\000\027\000\000\000\000\000\028\000\ -\000\000\000\000\000\000\030\000\031\000\032\000\000\000\000\000\ -\000\000\034\000\000\000\035\000\036\000\000\000\000\000\000\000\ -\000\000\000\000\038\000\000\000\000\000\000\000\000\000\000\000\ -\040\000\041\000\000\000\042\000\000\000\000\000\007\000\008\000\ -\009\000\000\000\000\000\000\000\010\000\011\000\000\000\000\000\ -\000\000\044\000\000\000\000\000\000\000\000\000\045\000\046\000\ -\000\000\048\000\049\000\195\001\000\000\000\000\051\000\015\000\ -\016\000\017\000\018\000\019\000\000\000\000\000\000\000\000\000\ -\020\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\022\000\000\000\023\000\024\000\025\000\ -\026\000\027\000\000\000\000\000\028\000\000\000\000\000\000\000\ -\030\000\031\000\032\000\000\000\000\000\000\000\034\000\000\000\ -\035\000\036\000\000\000\000\000\000\000\000\000\000\000\038\000\ -\000\000\000\000\000\000\000\000\000\000\040\000\041\000\000\000\ -\042\000\000\000\000\000\007\000\008\000\009\000\000\000\000\000\ -\000\000\010\000\011\000\000\000\000\000\000\000\044\000\000\000\ -\000\000\000\000\000\000\045\000\046\000\000\000\048\000\049\000\ -\000\000\000\000\000\000\051\000\015\000\016\000\017\000\018\000\ -\019\000\000\000\000\000\000\000\000\000\020\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\022\000\000\000\023\000\024\000\025\000\026\000\027\000\000\000\ -\000\000\028\000\000\000\000\000\000\000\030\000\031\000\032\000\ -\000\000\000\000\000\000\034\000\000\000\035\000\036\000\000\000\ -\000\000\000\000\000\000\000\000\038\000\000\000\000\000\000\000\ -\000\000\054\002\040\000\041\000\000\000\042\000\000\000\000\000\ -\007\000\008\000\009\000\000\000\000\000\000\000\010\000\011\000\ -\000\000\000\000\000\000\044\000\000\000\000\000\000\000\000\000\ -\045\000\046\000\000\000\048\000\049\000\000\000\000\000\000\000\ -\051\000\015\000\016\000\017\000\018\000\019\000\000\000\000\000\ -\000\000\000\000\020\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\022\000\000\000\023\000\ -\024\000\025\000\026\000\027\000\000\000\000\000\028\000\000\000\ -\000\000\000\000\030\000\031\000\032\000\000\000\000\000\000\000\ -\034\000\000\000\035\000\036\000\000\000\000\000\000\000\000\000\ -\000\000\038\000\000\000\000\000\000\000\000\000\000\000\040\000\ -\041\000\000\000\042\000\000\000\000\000\000\000\000\000\014\003\ -\007\000\008\000\009\000\000\000\000\000\016\003\010\000\011\000\ -\044\000\000\000\000\000\000\000\000\000\045\000\046\000\000\000\ -\048\000\049\000\000\000\000\000\000\000\051\000\000\000\000\000\ -\000\000\015\000\016\000\017\000\018\000\019\000\000\000\000\000\ -\000\000\000\000\020\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\022\000\000\000\023\000\ -\024\000\025\000\026\000\027\000\000\000\000\000\028\000\000\000\ -\000\000\000\000\030\000\031\000\032\000\000\000\000\000\000\000\ -\034\000\000\000\035\000\036\000\000\000\000\000\000\000\000\000\ -\000\000\038\000\000\000\000\000\000\000\000\000\000\000\040\000\ -\041\000\000\000\042\000\000\000\000\000\000\000\007\000\008\000\ -\009\000\000\000\000\000\000\000\010\000\011\000\000\000\000\000\ -\044\000\000\000\000\000\000\000\000\000\045\000\046\000\053\004\ -\048\000\049\000\000\000\000\000\000\000\051\000\000\000\015\000\ -\016\000\017\000\018\000\019\000\000\000\000\000\000\000\000\000\ -\020\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\022\000\000\000\023\000\024\000\025\000\ -\026\000\027\000\000\000\000\000\028\000\000\000\000\000\000\000\ -\030\000\031\000\032\000\000\000\000\000\000\000\034\000\000\000\ -\035\000\036\000\000\000\000\000\000\000\000\000\000\000\038\000\ -\000\000\000\000\000\000\000\000\000\000\040\000\041\000\000\000\ -\042\000\000\000\000\000\216\002\216\002\216\002\000\000\000\000\ -\000\000\216\002\216\002\000\000\000\000\000\000\044\000\000\000\ -\000\000\000\000\000\000\045\000\046\000\000\000\048\000\049\000\ -\216\002\000\000\000\000\051\000\216\002\216\002\216\002\216\002\ -\216\002\000\000\000\000\000\000\000\000\216\002\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\216\002\000\000\216\002\216\002\216\002\216\002\216\002\000\000\ -\000\000\216\002\000\000\000\000\000\000\216\002\216\002\216\002\ -\000\000\000\000\000\000\216\002\000\000\216\002\216\002\000\000\ -\000\000\000\000\000\000\000\000\216\002\000\000\000\000\000\000\ -\000\000\000\000\216\002\216\002\000\000\216\002\000\000\000\000\ -\007\000\008\000\009\000\000\000\000\000\000\000\010\000\011\000\ -\000\000\000\000\000\000\216\002\000\000\000\000\000\000\000\000\ -\216\002\216\002\000\000\216\002\216\002\000\000\000\000\000\000\ -\216\002\015\000\016\000\017\000\018\000\019\000\000\000\000\000\ -\000\000\000\000\020\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\022\000\000\000\023\000\ -\024\000\025\000\026\000\027\000\000\000\000\000\028\000\000\000\ -\000\000\000\000\030\000\031\000\032\000\000\000\000\000\000\000\ -\034\000\000\000\035\000\036\000\000\000\000\000\000\000\000\000\ -\000\000\038\000\000\000\000\000\000\000\000\000\000\000\040\000\ -\041\000\000\000\042\000\000\000\000\000\216\002\216\002\216\002\ -\000\000\000\000\000\000\216\002\216\002\000\000\000\000\000\000\ -\044\000\000\000\000\000\000\000\000\000\045\000\046\000\000\000\ -\048\000\049\000\000\000\000\000\000\000\051\000\216\002\216\002\ -\216\002\216\002\216\002\000\000\000\000\000\000\000\000\216\002\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\216\002\000\000\216\002\216\002\216\002\216\002\ -\216\002\000\000\000\000\216\002\000\000\000\000\000\000\216\002\ -\216\002\216\002\000\000\000\000\000\000\216\002\000\000\216\002\ -\216\002\000\000\000\000\000\000\000\000\000\000\216\002\000\000\ -\000\000\000\000\000\000\000\000\216\002\216\002\000\000\216\002\ -\000\000\000\000\214\002\214\002\214\002\000\000\000\000\000\000\ -\214\002\214\002\000\000\000\000\000\000\216\002\000\000\000\000\ -\000\000\000\000\216\002\216\002\000\000\216\002\216\002\000\000\ -\000\000\000\000\216\002\214\002\214\002\214\002\214\002\214\002\ -\000\000\000\000\000\000\000\000\214\002\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\214\002\ -\000\000\214\002\214\002\214\002\214\002\214\002\000\000\000\000\ -\214\002\000\000\000\000\000\000\214\002\214\002\214\002\000\000\ -\000\000\008\000\214\002\000\000\214\002\214\002\000\000\011\000\ -\000\000\147\003\000\000\214\002\229\001\000\000\000\000\000\000\ -\000\000\214\002\214\002\000\000\214\002\000\000\148\003\000\000\ -\000\000\015\000\016\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\214\002\000\000\000\000\000\000\000\000\214\002\ -\214\002\000\000\214\002\214\002\000\000\022\000\207\001\214\002\ -\139\000\000\000\140\000\141\000\000\000\000\000\028\000\000\000\ -\000\000\000\000\000\000\142\000\149\003\000\000\008\000\000\000\ -\000\000\000\000\144\000\000\000\011\000\000\000\228\001\000\000\ -\000\000\229\001\000\000\000\000\209\001\000\000\000\000\145\000\ -\000\000\000\000\000\000\148\003\210\001\000\000\015\000\016\000\ -\000\000\008\000\000\000\000\000\146\000\000\000\000\000\011\000\ -\044\000\189\002\000\000\211\001\000\000\045\000\000\000\000\000\ -\048\000\147\000\022\000\207\001\000\000\139\000\000\000\140\000\ -\141\000\015\000\016\000\028\000\000\000\000\000\000\000\000\000\ -\142\000\149\003\000\000\000\000\000\000\000\000\000\000\144\000\ -\000\000\000\000\000\000\000\000\000\000\022\000\207\001\000\000\ -\139\000\209\001\140\000\141\000\145\000\000\000\028\000\000\000\ -\000\000\210\001\000\000\142\000\190\002\000\000\000\000\000\000\ -\000\000\146\000\144\000\000\000\191\002\044\000\000\000\000\000\ -\211\001\000\000\045\000\000\000\209\001\048\000\147\000\145\000\ -\000\000\000\000\008\000\000\000\210\001\000\000\000\000\000\000\ -\011\000\000\000\124\005\000\000\146\000\000\000\000\000\000\000\ -\044\000\000\000\000\000\211\001\000\000\045\000\000\000\148\003\ -\048\000\147\000\015\000\016\000\000\000\008\000\000\000\000\000\ -\000\000\000\000\000\000\011\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\022\000\207\001\ -\000\000\139\000\000\000\140\000\141\000\015\000\016\000\028\000\ -\000\000\000\000\000\000\000\000\142\000\149\003\000\000\000\000\ -\000\000\000\000\000\000\144\000\000\000\000\000\000\000\000\000\ -\000\000\022\000\207\001\000\000\139\000\209\001\140\000\141\000\ -\145\000\000\000\028\000\000\000\000\000\210\001\000\000\142\000\ -\208\001\000\000\216\002\000\000\000\000\146\000\144\000\000\000\ -\216\002\044\000\000\000\000\000\211\001\000\000\045\000\000\000\ -\209\001\048\000\147\000\145\000\000\000\000\000\000\000\000\000\ -\210\001\000\000\216\002\216\002\000\000\000\000\000\000\000\000\ -\146\000\000\000\000\000\000\000\044\000\000\000\000\000\211\001\ -\000\000\045\000\000\000\000\000\048\000\147\000\216\002\216\002\ -\000\000\216\002\000\000\216\002\216\002\000\000\000\000\216\002\ -\000\000\000\000\000\000\000\000\216\002\216\002\000\000\000\000\ -\008\000\000\000\000\000\216\002\000\000\000\000\011\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\216\002\000\000\000\000\ -\216\002\000\000\000\000\000\000\000\000\216\002\137\000\000\000\ -\015\000\016\000\000\000\000\000\000\000\216\002\000\000\000\000\ -\000\000\216\002\000\000\000\000\216\002\000\000\216\002\000\000\ -\000\000\216\002\216\002\000\000\022\000\000\000\138\000\139\000\ -\000\000\140\000\141\000\000\000\000\000\028\000\000\000\000\000\ -\000\000\000\000\142\000\143\000\000\000\000\000\000\000\008\000\ -\000\000\144\000\000\000\162\001\000\000\011\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\145\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\137\000\194\000\015\000\ -\016\000\000\000\000\000\146\000\000\000\000\000\000\000\044\000\ -\000\000\000\000\000\000\000\000\045\000\000\000\000\000\048\000\ -\147\000\000\000\000\000\022\000\000\000\138\000\139\000\000\000\ -\140\000\141\000\000\000\000\000\028\000\000\000\000\000\000\000\ -\000\000\142\000\143\000\000\000\008\000\000\000\000\000\000\000\ -\144\000\000\000\011\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\008\000\009\000\000\000\000\000\145\000\010\000\011\000\ -\000\000\000\000\137\000\000\000\015\000\016\000\000\000\000\000\ -\000\000\000\000\146\000\000\000\000\000\000\000\044\000\000\000\ -\000\000\015\000\016\000\045\000\000\000\000\000\048\000\147\000\ -\022\000\000\000\138\000\139\000\000\000\140\000\141\000\000\000\ -\000\000\028\000\000\000\000\000\000\000\022\000\142\000\143\000\ -\024\000\025\000\026\000\027\000\000\000\144\000\028\000\000\000\ -\216\002\000\000\216\002\182\000\032\000\000\000\216\002\000\000\ -\000\000\000\000\145\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\090\003\000\000\000\000\000\000\216\002\146\000\ -\216\002\216\002\042\000\044\000\000\000\000\000\000\000\000\000\ -\045\000\000\000\000\000\048\000\147\000\000\000\000\000\000\000\ -\044\000\000\000\000\000\000\000\216\002\045\000\216\002\216\002\ -\048\000\216\002\216\002\000\000\000\000\216\002\000\000\000\000\ -\000\000\000\000\216\002\216\002\000\000\008\000\000\000\000\000\ -\000\000\216\002\000\000\011\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\216\002\000\000\ -\000\000\000\000\000\000\137\000\000\000\015\000\016\000\000\000\ -\000\000\000\000\000\000\216\002\000\000\000\000\000\000\216\002\ -\000\000\000\000\000\000\000\000\216\002\000\000\000\000\216\002\ -\216\002\022\000\000\000\138\000\139\000\000\000\140\000\141\000\ -\000\000\000\000\028\000\000\000\000\000\000\000\000\000\142\000\ -\143\000\000\000\216\002\000\000\000\000\000\000\144\000\000\000\ -\216\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\145\000\000\000\000\000\000\000\000\000\ -\216\002\000\000\216\002\216\002\000\000\216\002\000\000\000\000\ -\146\000\000\000\000\000\216\002\044\000\000\000\000\000\000\000\ -\000\000\045\000\000\000\000\000\048\000\147\000\216\002\000\000\ -\216\002\216\002\000\000\216\002\216\002\216\002\216\002\216\002\ -\000\000\000\000\000\000\000\000\216\002\216\002\000\000\000\000\ -\000\000\000\000\000\000\216\002\000\000\000\000\000\000\000\000\ -\000\000\216\002\000\000\216\002\216\002\000\000\216\002\216\002\ -\216\002\000\000\216\002\000\000\000\000\000\000\000\000\216\002\ -\216\002\000\000\148\002\000\000\000\000\216\002\216\002\000\000\ -\148\002\216\002\000\000\000\000\000\000\000\000\216\002\000\000\ -\000\000\216\002\216\002\216\002\000\000\000\000\000\000\000\000\ -\148\002\000\000\148\002\148\002\216\002\129\002\000\000\000\000\ -\216\002\000\000\000\000\129\002\216\002\000\000\000\000\000\000\ -\000\000\216\002\000\000\000\000\216\002\216\002\148\002\000\000\ -\148\002\148\002\000\000\148\002\148\002\129\002\129\002\148\002\ -\000\000\000\000\000\000\000\000\148\002\148\002\000\000\000\000\ -\000\000\000\000\000\000\148\002\000\000\000\000\000\000\000\000\ -\000\000\129\002\000\000\129\002\129\002\000\000\129\002\129\002\ -\148\002\000\000\129\002\000\000\000\000\000\000\000\000\129\002\ -\129\002\000\000\214\002\000\000\000\000\148\002\129\002\000\000\ -\214\002\148\002\000\000\000\000\000\000\000\000\148\002\000\000\ -\000\000\148\002\148\002\129\002\000\000\000\000\000\000\000\000\ -\000\000\000\000\214\002\214\002\000\000\008\000\000\000\000\000\ -\129\002\000\000\000\000\011\000\129\002\000\000\000\000\000\000\ -\000\000\129\002\000\000\000\000\129\002\129\002\214\002\000\000\ -\214\002\214\002\000\000\214\002\214\002\015\000\016\000\214\002\ -\000\000\000\000\000\000\000\000\214\002\214\002\000\000\000\000\ -\000\000\000\000\000\000\214\002\000\000\000\000\000\000\000\000\ -\000\000\022\000\000\000\000\000\139\000\000\000\140\000\141\000\ -\214\002\000\000\028\000\000\000\000\000\000\000\000\000\142\000\ -\143\000\000\000\216\002\000\000\000\000\214\002\144\000\000\000\ -\216\002\214\002\000\000\000\000\000\000\000\000\214\002\000\000\ -\000\000\214\002\214\002\145\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\216\002\216\002\000\000\000\000\000\000\000\000\ -\146\000\000\000\000\000\000\000\044\000\000\000\000\000\000\000\ -\000\000\045\000\000\000\000\000\048\000\147\000\216\002\000\000\ -\000\000\216\002\000\000\216\002\216\002\000\000\000\000\216\002\ -\000\000\000\000\000\000\000\000\216\002\216\002\000\000\008\000\ -\009\000\000\000\000\000\216\002\010\000\011\000\008\000\009\000\ -\000\000\000\000\000\000\010\000\011\000\000\000\000\000\087\001\ -\216\002\000\000\000\000\000\000\000\000\000\000\000\000\015\000\ -\016\000\000\000\000\000\000\000\000\000\216\002\015\000\016\000\ -\000\000\216\002\000\000\000\000\000\000\000\000\216\002\000\000\ -\088\001\216\002\216\002\022\000\089\001\000\000\024\000\025\000\ -\026\000\027\000\022\000\089\001\028\000\024\000\025\000\026\000\ -\027\000\142\000\032\000\028\000\000\000\000\000\000\000\000\000\ -\142\000\032\000\000\000\000\000\000\000\000\000\000\000\216\002\ -\216\002\000\000\090\001\000\000\216\002\216\002\000\000\000\000\ -\042\000\090\001\091\001\000\000\000\000\000\000\000\000\042\000\ -\000\000\091\001\092\001\093\001\000\000\000\000\044\000\216\002\ -\216\002\094\001\000\000\045\000\000\000\044\000\048\000\000\000\ -\094\001\000\000\045\000\000\000\000\000\048\000\000\000\000\000\ -\000\000\000\000\000\000\216\002\000\000\000\000\216\002\216\002\ -\216\002\216\002\000\000\000\000\216\002\000\000\000\000\000\000\ -\000\000\216\002\216\002\000\000\000\000\180\004\049\001\050\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\051\001\000\000\ -\000\000\000\000\000\000\181\004\052\001\053\001\182\004\054\001\ -\216\002\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\055\001\000\000\000\000\000\000\000\000\000\000\216\002\000\000\ -\000\000\056\001\000\000\216\002\000\000\000\000\216\002\057\001\ -\058\001\059\001\060\001\061\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\062\001\000\000\167\002\000\000\000\000\162\000\ -\000\000\000\000\000\000\000\000\063\001\064\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\065\001\ -\066\001\067\001\068\001\069\001\000\000\001\001\002\001\003\001\ -\000\000\000\000\000\000\183\004\164\001\000\000\005\001\000\000\ -\000\000\071\001\000\000\000\000\112\000\007\001\113\000\114\000\ -\028\000\000\000\115\000\000\000\000\000\116\000\117\000\000\000\ -\008\001\000\000\000\000\000\000\000\000\000\000\000\000\134\001\ -\000\000\009\001\000\000\000\000\000\000\000\000\118\000\010\001\ -\011\001\012\001\013\001\014\001\015\001\000\000\119\000\120\000\ -\000\000\000\000\000\000\168\002\000\000\000\000\121\000\000\000\ -\000\000\000\000\016\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\122\000\123\000\173\002\166\001\000\000\174\002\ -\000\000\000\000\000\000\000\000\224\003\049\001\050\001\020\001\ -\021\001\175\002\169\001\024\001\170\001\051\001\000\000\000\000\ -\000\000\000\000\000\000\052\001\053\001\000\000\054\001\027\001\ -\000\000\028\001\000\000\000\000\000\000\000\000\000\000\055\001\ -\000\000\000\000\000\000\000\000\226\003\049\001\050\001\000\000\ -\056\001\000\000\000\000\000\000\000\000\051\001\057\001\058\001\ -\059\001\060\001\061\001\052\001\053\001\000\000\054\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\055\001\ -\000\000\062\001\000\000\000\000\000\000\000\000\162\000\000\000\ -\056\001\000\000\000\000\063\001\064\001\000\000\057\001\058\001\ -\059\001\060\001\061\001\000\000\000\000\000\000\065\001\066\001\ -\067\001\068\001\069\001\000\000\000\000\000\000\000\000\225\003\ -\000\000\062\001\000\000\000\000\000\000\000\000\162\000\000\000\ -\071\001\000\000\000\000\063\001\064\001\000\000\000\000\000\000\ -\000\000\000\000\228\003\049\001\050\001\000\000\065\001\066\001\ -\067\001\068\001\069\001\051\001\000\000\000\000\000\000\000\000\ -\227\003\052\001\053\001\000\000\054\001\000\000\000\000\000\000\ -\071\001\000\000\000\000\000\000\000\000\055\001\000\000\000\000\ -\000\000\000\000\224\003\049\001\050\001\000\000\056\001\000\000\ -\000\000\000\000\000\000\051\001\057\001\058\001\059\001\060\001\ -\061\001\052\001\053\001\000\000\054\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\055\001\000\000\062\001\ -\000\000\000\000\000\000\000\000\162\000\000\000\056\001\000\000\ -\000\000\063\001\064\001\000\000\057\001\058\001\059\001\060\001\ -\061\001\000\000\000\000\000\000\065\001\066\001\067\001\068\001\ -\069\001\000\000\000\000\000\000\000\000\000\000\000\000\062\001\ -\229\003\000\000\000\000\000\000\162\000\000\000\071\001\000\000\ -\000\000\063\001\064\001\000\000\000\000\000\000\000\000\000\000\ -\226\003\049\001\050\001\000\000\065\001\066\001\067\001\068\001\ -\069\001\051\001\000\000\000\000\000\000\023\004\000\000\052\001\ -\053\001\000\000\054\001\000\000\000\000\000\000\071\001\000\000\ -\000\000\000\000\000\000\055\001\000\000\000\000\000\000\000\000\ -\228\003\049\001\050\001\000\000\056\001\000\000\000\000\000\000\ -\000\000\051\001\057\001\058\001\059\001\060\001\061\001\052\001\ -\053\001\000\000\054\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\055\001\000\000\062\001\000\000\000\000\ -\000\000\000\000\162\000\000\000\056\001\000\000\000\000\063\001\ -\064\001\000\000\057\001\058\001\059\001\060\001\061\001\000\000\ -\000\000\000\000\065\001\066\001\067\001\068\001\069\001\000\000\ -\000\000\000\000\000\000\000\000\024\004\062\001\000\000\000\000\ -\000\000\000\000\162\000\000\000\071\001\000\000\000\000\063\001\ -\064\001\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\065\001\066\001\067\001\068\001\069\001\226\004\ -\049\001\050\001\000\000\000\000\000\000\000\000\025\004\000\000\ -\051\001\000\000\000\000\000\000\071\001\000\000\052\001\053\001\ -\000\000\054\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\055\001\000\000\000\000\000\000\000\000\228\004\ -\049\001\050\001\000\000\056\001\000\000\000\000\000\000\000\000\ -\051\001\057\001\058\001\059\001\060\001\061\001\052\001\053\001\ -\000\000\054\001\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\055\001\000\000\062\001\000\000\000\000\000\000\ -\000\000\162\000\000\000\056\001\000\000\000\000\063\001\064\001\ -\000\000\057\001\058\001\059\001\060\001\061\001\000\000\000\000\ -\000\000\065\001\066\001\067\001\068\001\069\001\000\000\000\000\ -\000\000\000\000\227\004\000\000\062\001\000\000\000\000\000\000\ -\000\000\162\000\000\000\071\001\000\000\000\000\063\001\064\001\ -\000\000\000\000\000\000\000\000\000\000\230\004\049\001\050\001\ -\000\000\065\001\066\001\067\001\068\001\069\001\051\001\000\000\ -\000\000\000\000\000\000\229\004\052\001\053\001\000\000\054\001\ -\000\000\000\000\000\000\071\001\000\000\000\000\000\000\000\000\ -\055\001\000\000\000\000\000\000\000\000\226\004\049\001\050\001\ -\000\000\056\001\000\000\000\000\000\000\000\000\051\001\057\001\ -\058\001\059\001\060\001\061\001\052\001\053\001\000\000\054\001\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\055\001\000\000\062\001\000\000\000\000\000\000\000\000\162\000\ -\000\000\056\001\000\000\000\000\063\001\064\001\000\000\057\001\ -\058\001\059\001\060\001\061\001\000\000\000\000\000\000\065\001\ -\066\001\067\001\068\001\069\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\062\001\231\004\000\000\000\000\000\000\162\000\ -\000\000\071\001\000\000\000\000\063\001\064\001\000\000\000\000\ -\000\000\000\000\000\000\228\004\049\001\050\001\000\000\065\001\ -\066\001\067\001\068\001\069\001\051\001\000\000\000\000\000\000\ -\249\004\000\000\052\001\053\001\000\000\054\001\000\000\000\000\ -\000\000\071\001\000\000\000\000\000\000\000\000\055\001\000\000\ -\000\000\000\000\000\000\230\004\049\001\050\001\000\000\056\001\ -\000\000\000\000\000\000\000\000\051\001\057\001\058\001\059\001\ -\060\001\061\001\052\001\053\001\000\000\054\001\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\055\001\000\000\ -\062\001\000\000\000\000\000\000\000\000\162\000\000\000\056\001\ -\000\000\000\000\063\001\064\001\000\000\057\001\058\001\059\001\ -\060\001\061\001\000\000\000\000\000\000\065\001\066\001\067\001\ -\068\001\069\001\000\000\000\000\000\000\000\000\000\000\250\004\ -\062\001\049\001\050\001\000\000\000\000\162\000\000\000\071\001\ -\000\000\051\001\063\001\064\001\000\000\000\000\000\000\052\001\ -\053\001\000\000\054\001\000\000\000\000\065\001\066\001\067\001\ -\068\001\069\001\000\000\055\001\000\000\000\000\000\000\000\000\ -\000\000\251\004\000\000\000\000\056\001\000\000\000\000\071\001\ -\000\000\000\000\057\001\058\001\059\001\060\001\061\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\062\001\000\000\000\000\ -\000\000\000\000\162\000\000\000\000\000\000\000\000\000\063\001\ -\064\001\049\001\050\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\051\001\065\001\066\001\067\001\068\001\069\001\052\001\ -\053\001\000\000\054\001\000\000\000\000\000\000\000\000\070\001\ -\000\000\057\004\000\000\055\001\071\001\000\000\000\000\000\000\ -\000\000\049\001\050\001\000\000\056\001\000\000\000\000\000\000\ -\000\000\051\001\057\001\058\001\059\001\060\001\061\001\052\001\ -\053\001\000\000\054\001\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\055\001\000\000\062\001\000\000\000\000\ -\000\000\000\000\162\000\000\000\056\001\000\000\000\000\063\001\ -\064\001\000\000\057\001\058\001\059\001\060\001\061\001\000\000\ -\000\000\000\000\065\001\066\001\067\001\068\001\069\001\000\000\ -\000\000\000\000\000\000\000\000\000\000\062\001\049\001\050\001\ -\000\000\000\000\162\000\000\000\071\001\000\000\051\001\063\001\ -\064\001\000\000\000\000\000\000\052\001\000\000\000\000\000\000\ -\000\000\000\000\065\001\066\001\067\001\068\001\069\001\000\000\ -\055\001\000\000\000\000\000\000\000\000\000\000\049\001\050\001\ -\000\000\056\001\000\000\000\000\071\001\000\000\000\000\057\001\ -\058\001\059\001\060\001\061\001\052\001\000\000\000\000\000\000\ -\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\055\001\000\000\062\001\000\000\000\000\000\000\000\000\162\000\ -\000\000\056\001\000\000\000\000\063\001\064\001\000\000\057\001\ -\058\001\059\001\060\001\061\001\012\000\000\000\000\000\065\001\ -\066\001\067\001\068\001\069\001\000\000\000\000\000\000\000\000\ -\000\000\000\000\062\001\089\000\014\000\000\000\000\000\162\000\ -\000\000\071\001\000\000\000\000\063\001\064\001\000\000\000\000\ -\090\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\066\001\067\001\068\001\069\001\000\000\000\000\112\000\000\000\ -\113\000\114\000\028\000\029\000\115\000\000\000\000\000\116\000\ -\117\000\071\001\000\000\033\000\000\000\000\000\000\000\000\000\ -\000\000\091\000\000\000\000\000\000\000\000\000\000\000\039\000\ -\118\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\119\000\120\000\000\000\000\000\000\000\000\000\000\000\092\000\ -\121\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ -\000\000\000\000\000\000\093\000\122\000\123\000\050\000" - -let yycheck = "\003\000\ -\002\000\005\000\177\000\177\000\002\000\174\000\112\000\112\000\ -\255\000\185\000\115\000\008\000\112\000\139\000\105\001\061\002\ -\118\000\002\000\092\000\180\000\001\000\133\000\002\000\104\002\ -\233\002\221\001\104\002\114\000\002\000\002\003\104\000\002\000\ -\027\000\034\004\146\000\059\002\002\000\000\000\192\002\003\000\ -\150\001\002\000\002\000\196\000\116\003\198\000\001\000\245\003\ -\101\003\059\000\252\000\164\003\124\003\223\004\210\004\119\004\ -\009\000\008\001\203\004\000\000\198\002\000\000\043\000\121\001\ -\066\001\123\001\000\000\110\004\000\001\093\002\029\000\024\000\ -\019\001\229\002\033\000\027\001\214\004\090\001\022\001\006\001\ -\025\000\022\001\066\001\000\001\000\001\031\001\000\001\108\001\ -\043\000\042\000\092\000\178\000\094\001\000\001\092\000\079\001\ -\000\001\110\001\141\004\040\001\008\001\000\001\104\000\017\001\ -\059\000\037\001\104\000\092\000\112\000\029\001\027\001\115\000\ -\092\000\117\000\118\000\023\001\000\001\000\001\092\000\104\000\ -\067\001\092\000\030\001\120\000\104\000\078\000\092\000\080\000\ -\081\000\000\001\104\000\092\000\092\000\104\000\000\001\000\001\ -\140\000\141\000\104\000\143\000\029\005\092\001\094\001\104\000\ -\104\000\053\001\090\001\055\001\014\001\153\000\154\000\017\001\ -\034\005\117\000\036\003\012\004\022\001\065\001\201\004\066\001\ -\014\001\027\001\066\001\095\001\000\001\092\001\073\001\000\001\ -\000\001\073\001\115\000\004\000\176\000\177\000\091\001\091\001\ -\180\000\094\001\095\001\095\001\094\001\047\001\036\001\000\001\ -\000\001\000\001\019\001\094\001\088\005\000\001\094\001\104\001\ -\091\001\026\001\027\001\027\001\095\001\014\001\106\001\032\000\ -\017\001\109\001\000\001\162\000\163\000\024\001\008\001\091\001\ -\115\001\092\001\064\001\115\001\165\000\000\001\000\001\048\001\ -\049\001\087\001\008\001\000\001\000\001\037\001\000\001\094\001\ -\010\001\091\001\091\001\060\001\181\000\095\001\095\001\097\001\ -\098\001\055\003\067\001\068\001\154\001\070\001\003\001\026\005\ -\027\001\095\001\188\001\097\001\000\001\018\001\027\001\082\002\ -\035\005\115\001\132\003\133\005\093\001\000\000\070\004\109\001\ -\000\001\073\004\094\001\091\001\200\002\088\001\094\001\095\001\ -\161\001\114\001\163\001\000\001\109\001\000\001\000\001\185\005\ -\121\001\187\005\123\001\040\001\091\001\094\001\111\001\095\001\ -\095\001\130\001\131\001\094\001\000\001\112\001\105\001\133\001\ -\066\001\207\001\092\001\036\005\046\001\091\001\212\001\250\000\ -\145\001\252\000\106\005\101\002\000\001\241\002\092\001\149\001\ -\091\001\035\001\092\001\004\001\095\001\095\001\091\001\091\001\ -\201\005\094\001\095\001\000\001\094\001\000\001\000\001\092\001\ -\008\001\000\001\147\003\193\001\181\004\182\004\004\001\027\001\ -\025\001\059\001\008\001\000\001\031\001\023\002\064\001\065\001\ -\249\001\015\001\094\001\172\000\018\001\026\001\045\001\026\001\ -\074\001\000\001\179\000\046\001\230\003\000\001\094\001\000\001\ -\000\001\000\001\003\002\010\001\000\001\105\001\155\004\066\001\ -\000\001\094\001\010\001\094\001\221\004\000\001\114\001\004\001\ -\007\001\099\001\019\001\008\001\018\001\121\001\060\005\123\001\ -\092\001\026\001\015\001\109\001\000\001\018\001\130\001\131\001\ -\035\001\133\001\000\001\132\005\066\001\106\004\010\001\091\001\ -\089\001\090\001\000\001\095\001\093\001\145\001\000\001\096\001\ -\049\001\149\001\044\004\092\001\092\001\153\001\154\001\092\001\ -\059\001\092\001\092\001\060\001\247\002\064\001\065\001\094\001\ -\065\001\000\001\014\001\068\001\000\001\070\001\091\001\074\001\ -\067\001\243\001\027\001\010\001\015\001\066\001\178\001\179\001\ -\180\001\017\001\022\001\001\004\073\001\092\001\186\001\015\001\ -\095\001\130\001\131\001\015\001\092\001\092\001\092\001\095\001\ -\099\001\000\001\094\001\000\001\000\001\018\001\094\001\032\001\ -\018\001\092\001\109\001\207\001\208\001\040\003\111\001\040\001\ -\212\001\066\001\043\001\046\003\216\001\237\003\068\003\219\001\ -\092\001\074\005\017\001\095\001\113\001\000\001\092\001\027\001\ -\228\001\229\001\066\001\018\001\000\001\243\004\066\001\171\003\ -\094\001\188\001\018\001\004\001\094\001\070\001\066\001\243\001\ -\244\001\243\001\094\001\003\001\077\001\243\001\004\001\083\001\ -\065\001\253\001\008\001\094\001\101\002\092\001\000\000\003\002\ -\112\002\015\001\243\001\008\001\018\001\131\002\094\001\243\001\ -\228\001\229\001\014\002\113\002\114\002\243\001\011\002\092\001\ -\243\001\094\001\192\002\003\001\094\001\243\001\176\004\243\001\ -\000\001\030\001\243\001\243\001\091\001\043\005\091\001\091\001\ -\247\001\028\002\029\002\095\001\109\001\238\001\014\001\094\001\ -\014\001\017\001\022\001\000\001\135\003\092\001\022\001\094\001\ -\073\001\063\005\055\001\027\001\066\001\057\002\094\001\008\001\ -\091\001\233\002\233\002\233\002\065\001\217\004\019\001\091\001\ -\169\002\143\004\171\002\022\001\023\002\026\001\008\001\047\001\ -\000\001\026\002\014\001\000\001\167\003\030\001\082\002\004\001\ -\152\005\000\001\027\002\008\001\189\002\065\001\014\001\248\002\ -\002\001\014\001\015\001\048\001\030\001\018\001\027\001\054\002\ -\022\001\101\002\008\001\113\001\104\002\106\001\055\001\060\001\ -\109\001\079\001\110\002\111\002\065\001\113\002\114\002\068\001\ -\065\001\070\001\094\001\091\001\035\001\055\001\015\003\095\001\ -\017\003\097\001\098\001\127\002\121\002\065\001\036\001\065\001\ -\132\002\027\001\083\005\031\005\008\001\137\002\022\001\090\001\ -\022\001\065\001\066\001\115\001\059\001\066\001\042\005\147\002\ -\148\002\064\001\065\001\111\002\066\001\005\003\062\001\242\003\ -\066\001\106\001\111\001\074\001\109\001\244\002\249\003\047\001\ -\036\001\094\001\062\005\127\002\090\001\169\002\094\001\171\002\ -\106\001\094\001\001\003\109\001\176\002\137\002\027\001\035\001\ -\094\001\181\002\118\004\065\001\099\001\006\005\092\001\080\003\ -\006\005\189\002\190\002\019\001\192\002\035\001\109\001\182\003\ -\183\003\093\005\050\003\022\001\094\001\030\002\202\002\059\001\ -\008\001\027\001\052\003\052\003\000\001\065\001\000\000\000\001\ -\108\005\097\001\098\001\004\001\176\002\059\001\253\001\008\001\ -\092\001\049\001\064\003\065\001\201\002\039\003\015\001\253\001\ -\073\003\018\001\088\001\115\001\060\001\233\002\026\001\064\002\ -\065\002\152\003\152\003\057\005\068\001\059\005\070\001\179\004\ -\066\001\094\001\102\001\247\002\248\002\066\001\201\002\073\001\ -\094\001\109\001\112\001\111\001\073\001\255\002\000\001\195\004\ -\102\001\255\002\004\001\067\001\008\003\096\004\008\001\109\001\ -\010\001\111\001\004\001\094\001\014\001\015\001\008\001\008\001\ -\018\001\066\001\057\002\055\001\014\001\015\001\014\001\111\001\ -\018\001\027\001\003\001\057\002\064\001\150\005\151\005\000\001\ -\018\001\115\001\014\001\027\001\040\003\039\003\115\001\130\004\ -\236\004\039\003\046\003\014\001\008\003\094\001\207\003\044\003\ -\052\003\140\004\019\001\055\003\000\001\035\001\039\003\019\001\ -\027\001\026\001\000\001\039\003\064\003\090\001\047\001\060\003\ -\066\001\039\003\155\002\156\002\039\003\073\003\030\001\073\001\ -\066\001\039\003\067\001\079\003\112\001\059\001\039\003\039\003\ -\049\001\110\001\036\001\065\001\048\001\065\001\066\001\079\001\ -\177\002\091\001\092\001\060\001\094\001\095\001\215\005\055\001\ -\060\001\000\000\067\001\068\001\094\001\070\001\191\002\030\001\ -\068\001\065\001\070\001\072\000\079\001\055\001\000\001\113\001\ -\097\001\098\001\094\001\003\001\064\001\065\001\064\001\014\001\ -\102\001\014\001\064\001\065\001\064\001\129\003\044\004\109\001\ -\055\001\019\001\115\001\135\003\027\001\045\001\046\001\139\003\ -\026\001\102\000\065\001\000\000\022\001\095\001\111\001\147\003\ -\022\001\149\003\106\001\111\001\152\003\109\001\154\003\155\003\ -\156\003\058\004\200\005\159\003\160\003\097\001\048\001\049\001\ -\164\003\007\004\166\003\167\003\000\001\047\001\112\001\064\001\ -\065\001\109\001\060\001\083\001\065\001\066\001\178\003\139\003\ -\009\003\067\001\068\001\106\001\070\001\000\001\109\001\147\003\ -\079\001\189\003\035\004\065\001\100\001\022\003\095\004\014\001\ -\000\001\015\001\004\001\159\003\018\001\194\003\008\001\014\001\ -\019\001\037\001\074\001\207\003\027\001\015\001\000\001\026\001\ -\027\001\003\001\037\001\019\001\027\001\110\001\178\003\097\001\ -\098\001\027\001\026\001\013\001\014\001\111\001\064\001\017\001\ -\000\000\014\001\131\004\008\001\017\001\048\001\049\001\000\001\ -\026\001\027\001\028\001\029\001\108\001\064\001\242\003\105\001\ -\048\001\060\001\065\001\030\001\066\001\249\003\040\001\041\001\ -\067\001\068\001\065\001\070\001\060\001\001\004\000\001\097\001\ -\066\001\026\001\176\004\007\004\068\001\002\004\070\001\000\001\ -\012\004\135\004\060\001\109\001\055\001\063\001\000\001\065\001\ -\066\001\067\001\068\001\022\001\066\001\067\001\065\001\073\001\ -\074\001\147\001\019\001\073\001\022\001\000\001\080\001\035\004\ -\064\001\026\001\066\001\037\001\111\001\206\004\127\003\128\003\ -\044\004\045\004\092\001\075\001\094\001\049\004\096\001\111\001\ -\064\001\035\001\000\001\220\004\141\003\142\003\058\004\026\001\ -\049\001\014\001\108\001\148\003\010\001\111\001\065\001\106\001\ -\064\001\115\001\109\001\060\001\157\003\115\001\000\001\065\001\ -\064\001\059\001\243\004\068\001\067\005\070\001\064\001\065\001\ -\112\001\045\004\047\001\075\001\064\001\049\004\031\004\012\001\ -\074\001\019\001\090\001\095\004\096\004\109\001\098\004\028\001\ -\026\001\000\001\064\001\018\005\018\005\004\001\208\004\208\004\ -\108\004\008\001\031\001\010\001\208\004\109\001\110\001\014\001\ -\015\001\099\001\027\001\018\001\064\001\064\001\111\001\049\001\ -\112\001\064\001\100\001\109\001\027\001\050\001\130\004\131\004\ -\041\005\109\001\060\001\004\001\075\001\066\001\098\004\008\001\ -\140\004\067\001\068\001\143\004\070\001\074\001\015\001\109\001\ -\108\004\018\001\071\001\080\001\061\005\064\001\083\001\027\001\ -\037\001\066\001\027\001\159\004\053\001\064\001\055\001\084\001\ -\157\004\109\001\110\001\066\001\083\005\083\005\086\005\064\001\ -\065\001\112\001\073\001\094\001\176\004\035\001\064\001\040\001\ -\101\001\181\004\182\004\064\001\066\001\111\001\064\001\064\001\ -\064\001\189\004\109\001\110\001\091\001\092\001\066\001\094\001\ -\095\001\066\001\109\001\000\001\053\001\059\001\055\001\056\001\ -\090\001\066\001\109\001\065\001\208\004\209\004\210\004\088\001\ -\065\001\042\004\113\001\000\001\109\001\046\004\019\001\000\000\ -\082\002\221\004\051\004\223\004\110\001\026\001\022\001\109\001\ -\000\001\189\004\066\001\109\001\004\001\109\001\019\001\112\001\ -\008\001\073\001\010\001\068\004\069\004\026\001\014\001\064\001\ -\102\001\074\004\018\001\048\001\110\002\209\004\210\004\109\001\ -\027\001\064\001\254\004\027\001\109\001\035\001\094\001\060\001\ -\221\001\064\001\006\005\048\001\000\001\075\001\067\001\068\001\ -\027\001\070\001\099\004\067\001\016\005\035\001\018\005\060\001\ -\022\001\013\001\022\005\115\001\064\001\059\001\067\001\068\001\ -\064\001\070\001\064\001\065\001\109\001\238\001\026\001\066\001\ -\028\001\029\001\254\004\039\005\074\001\059\001\109\001\000\001\ -\004\001\073\001\112\001\065\001\008\001\041\001\109\001\066\001\ -\031\001\000\000\111\001\015\001\016\005\057\005\018\001\059\005\ -\018\001\230\002\022\005\091\001\092\001\099\001\094\001\095\001\ -\060\001\109\001\111\001\050\001\000\001\109\001\074\005\109\001\ -\068\001\246\002\027\002\039\005\037\001\250\002\074\001\083\005\ -\102\001\113\001\027\005\007\000\080\001\030\005\010\000\109\001\ -\177\004\013\000\014\000\027\001\000\000\017\000\018\000\019\000\ -\020\000\021\000\066\001\023\000\096\001\066\001\066\001\192\004\ -\193\004\037\001\030\000\066\001\025\003\113\005\034\000\064\001\ -\108\001\037\000\038\000\111\001\027\001\027\001\083\001\000\001\ -\124\005\086\002\046\000\047\000\083\001\247\002\050\000\051\000\ -\004\001\023\001\066\001\135\005\008\001\035\001\000\001\000\001\ -\081\005\082\005\091\001\084\005\085\005\066\001\018\001\108\001\ -\146\005\026\001\150\005\151\005\146\005\113\005\109\001\027\001\ -\156\005\157\005\019\001\066\001\066\001\059\001\083\001\031\001\ -\026\001\026\001\064\001\065\001\000\000\089\000\090\000\091\000\ -\000\001\093\000\066\001\135\005\074\001\071\001\040\003\179\005\ -\009\005\073\001\050\001\006\001\046\003\185\005\186\005\187\005\ -\049\001\004\001\084\001\191\005\005\000\008\001\066\001\022\001\ -\156\005\157\005\026\001\060\001\015\001\099\001\094\001\018\001\ -\166\003\125\000\064\001\068\001\066\001\070\001\004\001\109\001\ -\212\005\022\001\008\001\215\005\000\000\137\000\138\000\179\005\ -\047\001\221\005\222\005\115\001\018\001\095\001\186\005\189\003\ -\064\001\149\000\088\001\191\005\055\001\027\001\057\001\058\001\ -\059\001\000\001\061\001\075\001\000\001\064\001\065\001\022\001\ -\164\000\053\001\000\001\055\001\189\005\078\005\111\001\066\001\ -\212\005\173\000\112\001\091\001\064\001\065\001\199\005\019\001\ -\022\001\221\005\222\005\026\001\093\001\019\001\026\001\090\001\ -\047\001\210\005\211\005\232\002\026\001\135\003\097\001\004\001\ -\027\001\000\001\000\001\008\001\109\001\053\001\054\001\055\001\ -\056\001\047\001\109\001\110\001\048\001\000\000\251\002\120\005\ -\064\001\065\001\048\001\000\003\093\001\000\001\027\001\128\005\ -\060\001\109\001\164\003\026\001\026\001\167\003\060\001\067\001\ -\068\001\000\001\070\001\094\001\109\001\004\001\068\001\018\001\ -\070\001\008\001\023\003\010\001\022\001\016\001\095\001\014\001\ -\015\001\004\001\109\001\140\000\141\000\008\001\159\005\004\001\ -\027\001\253\000\254\000\008\001\027\001\109\001\040\001\018\001\ -\153\000\154\000\015\001\091\001\049\003\018\001\095\001\095\001\ -\027\001\178\005\000\001\111\001\000\001\065\001\027\001\019\001\ -\004\001\111\001\008\001\071\001\008\001\022\001\010\001\176\000\ -\064\001\065\001\014\001\000\001\065\001\033\001\018\001\071\001\ -\084\001\037\001\093\001\066\001\073\001\010\001\006\001\027\001\ -\242\003\000\001\073\001\014\001\084\001\214\005\017\001\249\003\ -\004\001\094\001\090\001\010\001\008\001\066\001\065\001\053\001\ -\027\001\055\001\014\001\015\001\091\001\092\001\018\001\094\001\ -\095\001\077\001\012\004\065\001\113\003\073\001\110\001\053\001\ -\076\001\055\001\053\001\079\001\055\001\081\001\066\001\083\001\ -\064\001\065\001\113\001\065\001\000\001\073\001\065\001\055\001\ -\004\001\057\001\058\001\059\001\008\001\061\001\010\001\003\001\ -\064\001\065\001\014\001\065\001\066\001\067\001\018\001\091\001\ -\092\001\055\001\094\001\095\001\112\001\059\001\066\001\027\001\ -\116\001\063\001\064\001\053\001\054\001\055\001\056\001\064\001\ -\065\001\000\000\090\001\168\003\169\003\113\001\064\001\065\001\ -\078\001\097\001\134\001\135\001\000\001\064\001\053\001\003\001\ -\055\001\016\001\055\001\184\003\064\001\109\001\110\001\022\001\ -\227\001\013\001\065\001\064\001\027\001\092\001\096\004\234\001\ -\197\003\053\001\013\001\055\001\160\001\073\001\026\001\109\001\ -\028\001\029\001\008\001\167\001\000\001\065\001\014\001\171\001\ -\213\003\028\001\029\001\109\001\040\001\041\001\010\001\091\001\ -\092\001\095\001\094\001\095\001\184\001\185\001\041\001\065\001\ -\130\004\189\001\036\001\191\001\064\001\065\001\073\001\073\001\ -\060\001\014\001\140\004\063\001\022\001\113\001\109\001\244\003\ -\068\001\060\001\206\001\090\001\063\001\000\001\074\001\022\001\ -\003\001\068\001\065\001\066\001\080\001\159\004\218\001\074\001\ -\220\001\221\001\013\001\066\001\067\001\080\001\017\001\014\001\ -\092\001\064\001\065\001\022\001\096\001\210\001\211\001\026\001\ -\027\001\028\001\029\001\181\004\182\004\096\001\095\001\008\001\ -\108\001\130\001\131\001\111\001\000\000\000\001\041\001\251\001\ -\037\004\108\001\095\001\055\001\111\001\004\001\023\001\059\001\ -\153\001\008\001\112\001\063\001\064\001\030\001\092\001\103\001\ -\015\001\060\001\014\001\018\001\063\001\022\001\065\001\066\001\ -\067\001\068\001\078\001\221\004\027\001\223\004\073\001\074\001\ -\027\001\178\001\179\001\180\001\053\001\080\001\055\001\092\001\ -\091\001\186\001\092\001\237\004\238\004\109\001\000\000\092\001\ -\065\001\092\001\094\001\094\001\055\001\096\001\057\001\058\001\ -\059\001\109\001\061\001\094\001\092\001\064\001\065\001\014\001\ -\101\004\108\001\103\004\066\001\111\001\115\001\020\001\216\001\ -\115\001\109\001\115\001\064\001\065\001\046\001\081\001\109\001\ -\109\001\062\001\071\001\108\001\002\001\081\002\089\001\090\001\ -\084\002\106\001\086\002\109\001\109\001\109\001\097\001\084\001\ -\073\001\073\001\100\001\244\001\137\004\090\001\027\001\109\001\ -\015\001\142\004\109\001\110\001\001\000\002\000\003\000\004\000\ -\005\000\092\001\055\001\000\001\094\001\064\001\064\001\008\001\ -\109\001\110\001\065\001\109\001\040\001\014\002\001\001\002\001\ -\124\002\000\001\167\004\014\001\018\001\004\001\009\001\062\001\ -\074\005\008\001\062\001\010\001\015\001\016\001\062\001\014\001\ -\092\001\027\001\142\002\064\001\144\002\094\001\146\002\079\001\ -\027\001\014\001\150\002\014\001\027\001\006\001\094\001\073\001\ -\109\001\036\001\199\004\200\004\095\001\064\001\075\001\042\001\ -\043\001\044\001\045\001\046\001\073\001\111\005\022\001\094\001\ -\172\002\092\001\014\001\073\001\027\001\218\004\006\001\040\001\ -\008\001\222\004\061\001\094\001\027\001\014\001\027\001\066\001\ -\021\001\086\001\064\001\062\001\071\001\072\001\194\002\062\001\ -\062\001\003\001\073\001\199\002\200\002\014\001\062\001\082\001\ -\083\001\084\001\085\001\086\001\062\001\086\001\210\002\095\001\ -\212\002\027\001\090\001\073\001\091\001\092\001\003\005\094\001\ -\095\001\100\001\091\001\223\002\224\002\027\001\094\001\055\001\ -\101\001\057\001\058\001\059\001\094\001\061\001\234\002\094\001\ -\064\001\065\001\113\001\132\002\088\001\241\002\027\001\185\005\ -\094\001\187\005\014\001\020\001\000\001\015\001\022\001\003\001\ -\252\002\053\001\147\002\148\002\094\001\008\001\043\005\062\001\ -\080\001\013\001\090\001\062\001\092\001\062\001\051\005\094\001\ -\112\001\097\001\112\001\094\001\088\001\065\001\026\001\019\003\ -\028\001\029\001\063\005\021\001\091\001\109\001\110\001\095\001\ -\094\001\014\001\014\001\014\001\181\002\041\001\014\001\027\001\ -\027\001\037\003\019\001\091\001\022\001\112\001\000\001\088\001\ -\014\001\003\001\014\001\014\001\014\001\000\000\000\000\008\001\ -\060\001\092\001\065\001\013\001\092\001\036\001\109\001\017\001\ -\068\001\036\001\062\003\109\001\022\001\065\003\074\001\067\003\ -\026\001\027\001\028\001\029\001\080\001\005\000\006\001\036\001\ -\008\001\064\001\078\003\092\001\092\001\090\001\082\003\041\001\ -\092\001\040\001\064\001\036\001\096\001\089\003\094\001\053\001\ -\024\000\093\003\053\001\064\001\091\001\026\003\000\000\064\001\ -\108\001\064\001\060\001\111\001\064\001\063\001\036\003\065\001\ -\066\001\067\001\068\001\111\003\064\001\064\001\114\003\073\001\ -\074\001\064\001\118\003\186\005\254\004\111\005\080\001\055\001\ -\187\002\057\001\058\001\059\001\120\003\061\001\171\005\026\002\ -\064\001\065\001\092\001\131\002\094\001\000\001\096\001\018\005\ -\096\001\094\001\129\003\143\003\187\001\057\002\063\002\141\000\ -\183\001\166\004\108\001\212\003\155\004\111\001\195\005\196\005\ -\171\002\115\001\090\001\145\001\108\001\006\005\203\005\243\004\ -\255\255\097\001\043\005\136\004\255\255\255\255\170\003\171\003\ -\255\255\255\255\255\255\255\255\255\255\109\001\110\001\220\005\ -\180\003\181\003\255\255\255\255\255\255\015\001\079\003\255\255\ -\255\255\121\000\255\255\255\255\055\001\255\255\057\001\058\001\ -\059\001\197\003\061\001\255\255\255\255\064\001\065\001\255\255\ -\255\255\255\255\255\255\139\000\140\000\141\000\255\255\143\000\ -\064\001\065\001\044\001\045\001\046\001\255\255\081\001\071\001\ -\255\255\153\000\154\000\255\255\255\255\077\001\089\001\090\001\ -\255\255\255\255\255\255\255\255\084\001\233\003\097\001\235\003\ -\129\003\255\255\090\001\255\255\255\255\071\001\072\001\243\003\ -\176\000\177\000\109\001\110\001\180\000\255\255\255\255\255\255\ -\252\003\083\001\084\001\085\001\086\001\109\001\110\001\255\255\ -\255\255\154\003\155\003\156\003\255\255\009\004\255\255\160\003\ -\255\255\255\255\100\001\255\255\255\255\166\003\255\255\255\255\ -\255\255\255\255\255\255\007\000\255\255\255\255\010\000\255\255\ -\255\255\013\000\014\000\255\255\255\255\017\000\018\000\019\000\ -\020\000\021\000\255\255\023\000\189\003\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\034\000\255\255\ -\255\255\037\000\038\000\255\255\255\255\255\255\255\255\255\255\ -\255\255\061\004\046\000\047\000\064\004\255\255\050\000\051\000\ -\055\001\255\255\057\001\058\001\059\001\255\255\061\001\255\255\ -\255\255\064\001\065\001\255\255\255\255\081\004\255\255\083\004\ -\255\255\085\004\255\255\087\004\088\004\255\255\255\255\255\255\ -\092\004\255\255\255\255\255\255\255\255\097\004\000\001\255\255\ -\100\004\003\001\102\004\090\001\255\255\089\000\090\000\091\000\ -\255\255\093\000\097\001\013\001\014\001\255\255\255\255\017\001\ -\255\255\255\255\118\004\255\255\255\255\255\255\109\001\110\001\ -\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\013\001\137\004\040\001\041\001\ -\255\255\255\255\142\004\255\255\255\255\255\255\255\255\255\255\ -\255\255\149\004\255\255\028\001\029\001\137\000\138\000\087\001\ -\255\255\255\255\060\001\255\255\255\255\063\001\255\255\255\255\ -\041\001\067\001\068\001\255\255\255\255\255\255\170\004\073\001\ -\074\001\255\255\174\004\255\255\255\255\255\255\080\001\179\004\ -\255\255\255\255\255\255\060\001\255\255\255\255\255\255\255\255\ -\255\255\173\000\092\001\068\001\094\001\255\255\096\001\195\004\ -\196\004\074\001\198\004\255\255\255\255\255\255\255\255\080\001\ -\255\255\255\255\108\001\000\001\255\255\111\001\255\255\255\255\ -\212\004\115\001\255\255\255\255\255\255\255\255\150\001\096\001\ -\255\255\153\001\154\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\108\001\255\255\255\255\111\001\235\004\ -\236\004\255\255\255\255\255\255\255\255\255\255\242\004\255\255\ -\255\255\255\255\178\001\179\001\180\001\255\255\255\255\255\255\ -\255\255\255\255\186\001\255\255\255\255\001\005\255\255\003\005\ -\255\255\193\001\055\001\255\255\057\001\058\001\059\001\255\255\ -\061\001\253\000\254\000\064\001\065\001\017\005\255\255\207\001\ -\208\001\255\255\255\255\255\255\212\001\255\255\255\255\255\255\ -\216\001\000\000\255\255\219\001\081\001\033\005\255\255\019\001\ -\255\255\255\255\038\005\227\001\089\001\090\001\255\255\255\255\ -\255\255\255\255\234\001\255\255\097\001\033\001\000\000\051\005\ -\255\255\037\001\255\255\255\255\244\001\255\255\255\255\108\001\ -\109\001\110\001\255\255\255\255\255\255\253\001\255\255\255\255\ -\023\001\255\255\255\255\003\002\072\005\255\255\255\255\255\255\ -\255\255\077\005\255\255\255\255\080\005\036\001\014\002\255\255\ -\255\255\017\002\255\255\087\005\255\255\255\255\255\255\091\005\ -\255\255\255\255\026\002\095\005\255\255\255\255\255\255\255\255\ -\055\001\255\255\057\001\058\001\059\001\255\255\061\001\255\255\ -\255\255\064\001\065\001\255\255\112\005\255\255\255\255\005\000\ -\255\255\255\255\255\255\009\000\255\255\255\255\255\255\255\255\ -\255\255\057\002\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\024\000\090\001\255\255\137\005\138\005\255\255\ -\255\255\255\255\097\001\143\005\255\255\255\255\255\255\147\005\ -\255\255\255\255\134\001\255\255\042\000\153\005\109\001\110\001\ -\255\255\255\255\255\255\255\255\255\255\161\005\162\005\255\255\ -\255\255\255\255\255\255\167\005\168\005\169\005\170\005\255\255\ -\005\000\006\001\007\001\255\255\255\255\015\001\011\001\012\001\ -\180\005\181\005\255\255\167\001\255\255\255\255\255\255\255\255\ -\078\000\255\255\080\000\081\000\255\255\193\005\194\005\255\255\ -\196\005\030\001\031\001\131\002\132\002\255\255\255\255\255\255\ -\204\005\043\001\044\001\045\001\046\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\147\002\148\002\050\001\218\005\000\000\ -\053\001\054\001\055\001\056\001\224\005\225\005\059\001\255\255\ -\066\001\255\255\255\255\064\001\065\001\071\001\072\001\255\255\ -\255\255\255\255\170\002\255\255\255\255\255\255\255\255\255\255\ -\255\255\083\001\084\001\085\001\086\001\181\002\140\000\141\000\ -\255\255\143\000\087\001\255\255\255\255\255\255\190\002\255\255\ -\192\002\255\255\100\001\153\000\154\000\255\255\255\255\251\001\ -\101\001\255\255\202\002\255\255\255\255\106\001\255\255\165\000\ -\109\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\000\001\176\000\177\000\003\001\255\255\255\255\181\000\ -\255\255\255\255\255\255\255\255\255\255\255\255\013\001\231\002\ -\255\255\233\002\017\001\255\255\255\255\255\255\000\001\140\000\ -\141\000\003\001\143\000\026\001\027\001\028\001\029\001\255\255\ -\248\002\255\255\255\255\013\001\153\000\154\000\255\255\255\255\ -\255\255\255\255\041\001\255\255\255\255\255\255\255\255\255\255\ -\026\001\255\255\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\175\000\176\000\177\000\060\001\040\001\041\001\ -\063\001\255\255\255\255\066\001\067\001\068\001\255\255\255\255\ -\255\255\005\000\073\001\074\001\255\255\009\000\255\255\255\255\ -\255\255\080\001\060\001\255\255\255\255\063\001\004\001\047\003\ -\255\255\067\001\068\001\255\255\024\000\092\001\255\255\094\001\ -\074\001\096\001\255\255\255\255\255\255\255\255\080\001\255\255\ -\255\255\255\255\255\255\025\001\068\003\108\001\042\000\255\255\ -\111\001\255\255\092\001\255\255\115\001\255\255\096\001\079\003\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\078\000\255\255\080\000\081\000\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\129\003\255\255\089\001\090\001\255\255\255\255\093\001\ -\255\255\000\000\096\001\255\255\112\000\042\001\255\255\255\255\ -\255\255\255\255\255\255\048\001\255\255\149\003\255\255\000\001\ -\152\003\255\255\154\003\155\003\156\003\255\255\255\255\008\001\ -\160\003\255\255\255\255\255\255\013\001\255\255\166\003\255\255\ -\140\000\141\000\255\255\143\000\255\255\255\255\255\255\255\255\ -\255\255\026\001\255\255\028\001\029\001\153\000\154\000\255\255\ -\255\255\255\255\255\255\255\255\255\255\189\003\255\255\255\255\ -\041\001\165\000\255\255\153\001\154\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\176\000\177\000\255\255\207\003\ -\000\001\181\000\255\255\060\001\255\255\255\255\063\001\255\255\ -\255\255\066\001\067\001\068\001\178\001\179\001\180\001\019\003\ -\255\255\074\001\255\255\255\255\186\001\255\255\255\255\080\001\ -\255\255\255\255\255\255\255\255\236\003\255\255\255\255\255\255\ -\255\255\255\255\255\255\092\001\255\255\255\255\255\255\096\001\ -\255\255\207\001\208\001\255\255\153\001\154\001\212\001\255\255\ -\255\255\255\255\216\001\108\001\255\255\255\255\111\001\055\001\ -\255\255\057\001\058\001\059\001\255\255\061\001\255\255\255\255\ -\064\001\065\001\255\255\255\255\177\001\178\001\179\001\180\001\ -\255\255\008\001\255\255\255\255\255\255\186\001\244\001\255\255\ -\004\001\081\001\255\255\255\255\255\255\255\255\255\255\253\001\ -\023\001\089\001\090\001\000\000\044\004\255\255\255\255\030\001\ -\255\255\097\001\207\001\208\001\255\255\025\001\255\255\212\001\ -\014\002\255\255\058\004\216\001\255\255\109\001\110\001\255\255\ -\255\255\255\255\255\255\255\255\026\002\226\001\255\255\255\255\ -\055\001\000\000\057\001\058\001\059\001\255\255\061\001\255\255\ -\255\255\064\001\065\001\255\255\255\255\255\255\255\255\244\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\095\004\ -\253\001\255\255\081\001\057\002\255\255\255\255\255\255\255\255\ -\255\255\088\001\089\001\090\001\255\255\255\255\255\255\255\255\ -\255\255\014\002\097\001\255\255\255\255\089\001\090\001\255\255\ -\255\255\093\001\005\000\106\001\096\001\255\255\109\001\110\001\ -\255\255\255\255\255\255\131\004\255\255\255\255\255\255\135\004\ -\255\255\000\001\255\255\255\255\003\001\255\255\114\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\121\001\013\001\123\001\ -\255\255\255\255\255\255\255\255\057\002\255\255\255\255\255\255\ -\255\255\255\255\255\255\026\001\255\255\028\001\029\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\132\002\255\255\ -\176\004\040\001\041\001\255\255\255\255\153\001\154\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\147\002\148\002\255\255\ -\255\255\255\255\255\255\255\255\255\255\060\001\255\255\255\255\ -\063\001\255\255\255\255\255\255\067\001\068\001\178\001\179\001\ -\180\001\255\255\255\255\074\001\170\002\255\255\186\001\255\255\ -\255\255\080\001\255\255\255\255\255\255\255\255\255\255\181\002\ -\255\255\255\255\255\255\255\255\255\255\092\001\255\255\132\002\ -\190\002\096\001\192\002\207\001\208\001\255\255\255\255\255\255\ -\212\001\255\255\255\255\255\255\216\001\108\001\147\002\148\002\ -\111\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\140\000\141\000\255\255\143\000\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\153\000\154\000\ -\244\001\255\255\018\005\233\002\255\255\255\255\255\255\255\255\ -\181\002\253\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\190\002\255\255\192\002\255\255\176\000\177\000\255\255\ -\255\255\255\255\014\002\000\001\255\255\002\001\003\001\004\001\ -\255\255\255\255\255\255\008\001\255\255\255\255\026\002\255\255\ -\013\001\255\255\255\255\255\255\017\001\018\001\019\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\026\001\027\001\028\001\ -\029\001\000\001\255\255\255\255\233\002\255\255\255\255\036\001\ -\255\255\255\255\255\255\083\005\041\001\057\002\013\001\255\255\ -\255\255\255\255\255\255\048\001\049\001\000\000\094\005\255\255\ -\255\255\255\255\255\255\026\001\255\255\028\001\029\001\060\001\ -\255\255\255\255\063\001\064\001\255\255\066\001\067\001\068\001\ -\255\255\070\001\041\001\255\255\073\001\074\001\255\255\255\255\ -\255\255\079\003\255\255\080\001\255\255\255\255\255\255\255\255\ -\255\255\101\002\255\255\255\255\255\255\060\001\091\001\092\001\ -\136\005\094\001\095\001\096\001\097\001\068\001\142\005\100\001\ -\255\255\255\255\255\255\074\001\255\255\255\255\255\255\108\001\ -\109\001\080\001\111\001\255\255\255\255\255\255\115\001\255\255\ -\132\002\255\255\255\255\076\001\255\255\092\001\079\001\255\255\ -\081\001\096\001\083\001\129\003\255\255\255\255\255\255\147\002\ -\148\002\255\255\079\003\255\255\255\255\108\001\255\255\255\255\ -\111\001\255\255\255\255\255\255\255\255\255\255\255\255\149\003\ -\255\255\255\255\152\003\255\255\154\003\155\003\156\003\112\001\ -\026\000\027\000\160\003\116\001\255\255\255\255\255\255\255\255\ -\166\003\181\002\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\190\002\255\255\192\002\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\129\003\255\255\255\255\189\003\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\149\003\255\255\255\255\152\003\153\003\154\003\155\003\156\003\ -\082\000\083\000\255\255\160\003\255\255\233\002\255\255\000\001\ -\255\255\166\003\255\255\255\255\255\255\006\001\153\001\154\001\ -\255\255\255\255\000\000\012\001\189\001\255\255\191\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\189\003\255\255\255\255\028\001\255\255\030\001\031\001\178\001\ -\179\001\180\001\255\255\255\255\255\255\255\255\255\255\186\001\ -\187\001\218\001\255\255\220\001\255\255\255\255\255\255\255\255\ -\255\255\050\001\255\255\052\001\053\001\255\255\055\001\056\001\ -\255\255\255\255\059\001\255\255\207\001\208\001\255\255\064\001\ -\065\001\212\001\255\255\255\255\255\255\216\001\071\001\255\255\ -\052\003\255\255\255\255\255\255\255\255\057\003\044\004\255\255\ -\255\255\255\255\255\255\084\001\255\255\000\001\255\255\255\255\ -\003\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\097\001\244\001\013\001\079\003\101\001\255\255\017\001\255\255\ -\255\255\106\001\253\001\255\255\109\001\110\001\255\255\026\001\ -\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\014\002\255\255\255\255\041\001\255\255\ -\255\255\255\255\255\255\000\000\255\255\255\255\255\255\044\004\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\060\001\255\255\255\255\063\001\129\003\255\255\066\001\ -\067\001\068\001\255\255\255\255\255\255\255\255\073\001\074\001\ -\081\002\255\255\255\255\084\002\255\255\080\001\057\002\255\255\ -\255\255\149\003\255\255\255\255\152\003\255\255\154\003\155\003\ -\156\003\092\001\255\255\094\001\160\003\096\001\255\255\255\255\ -\255\255\255\255\166\003\255\255\255\255\255\255\255\255\255\255\ -\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\ -\115\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\189\003\176\004\255\255\255\255\255\255\255\255\049\001\ -\050\001\051\001\052\001\053\001\054\001\055\001\056\001\057\001\ -\058\001\059\001\060\001\061\001\062\001\063\001\064\001\065\001\ -\066\001\067\001\068\001\069\001\255\255\071\001\255\255\255\255\ -\255\255\132\002\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\172\002\086\001\255\255\000\000\255\255\ -\147\002\148\002\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\099\001\000\001\176\004\002\001\003\001\004\001\255\255\ -\255\255\255\255\008\001\255\003\255\255\255\255\199\002\013\001\ -\255\255\255\255\255\255\017\001\018\001\019\001\255\255\255\255\ -\255\255\255\255\181\002\255\255\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\190\002\255\255\192\002\036\001\255\255\ -\255\255\255\255\040\001\041\001\018\005\255\255\255\255\255\255\ -\255\255\255\255\048\001\049\001\255\255\255\255\255\255\255\255\ -\044\004\255\255\255\255\255\255\255\255\255\255\060\001\255\255\ -\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\ -\070\001\255\255\255\255\073\001\074\001\255\255\233\002\255\255\ -\000\000\255\255\080\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\091\001\092\001\255\255\ -\094\001\095\001\096\001\255\255\255\255\018\005\100\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\083\005\108\001\255\255\ -\255\255\111\001\255\255\255\255\255\255\115\001\255\255\255\255\ -\094\005\255\255\255\255\000\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\008\001\255\255\062\003\255\255\255\255\ -\013\001\235\001\255\255\255\255\255\255\255\255\240\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\026\001\255\255\028\001\ -\029\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\136\005\255\255\041\001\255\255\083\005\053\001\ -\255\255\055\001\255\255\057\001\058\001\059\001\255\255\061\001\ -\255\255\255\255\064\001\065\001\079\003\255\255\111\003\060\001\ -\255\255\255\255\028\002\029\002\176\004\066\001\067\001\068\001\ -\255\255\255\255\255\255\255\255\255\255\074\001\000\000\255\255\ -\255\255\255\255\255\255\080\001\090\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\097\001\255\255\255\255\143\003\092\001\ -\255\255\255\255\255\255\096\001\208\004\063\002\255\255\109\001\ -\110\001\255\255\068\002\069\002\070\002\255\255\129\003\108\001\ -\255\255\255\255\111\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\000\001\255\255\ -\002\001\003\001\149\003\180\003\181\003\152\003\008\001\154\003\ -\155\003\156\003\255\255\013\001\255\255\160\003\255\255\017\001\ -\018\001\019\001\255\255\166\003\255\255\255\255\255\255\255\255\ -\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\036\001\255\255\255\255\255\255\018\005\041\001\ -\255\255\255\255\189\003\255\255\255\255\255\255\048\001\049\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\233\003\255\255\060\001\255\255\255\255\063\001\255\255\255\255\ -\066\001\067\001\068\001\255\255\070\001\159\002\160\002\161\002\ -\074\001\255\255\255\255\252\003\255\255\255\255\080\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\000\ -\000\001\091\001\092\001\003\001\094\001\095\001\096\001\255\255\ -\255\255\255\255\255\255\023\001\255\255\013\001\255\255\083\005\ -\255\255\017\001\108\001\197\002\255\255\111\001\255\255\255\255\ -\036\001\115\001\026\001\027\001\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\213\002\255\255\255\255\255\255\255\255\ -\255\255\041\001\255\255\055\001\255\255\057\001\058\001\059\001\ -\255\255\061\001\255\255\255\255\064\001\065\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\060\001\255\255\255\255\063\001\ -\255\255\044\004\066\001\067\001\068\001\255\255\255\255\255\255\ -\255\255\073\001\074\001\255\255\255\255\255\255\090\001\255\255\ -\080\001\255\255\255\255\000\000\255\255\097\001\255\255\255\255\ -\255\255\255\255\255\255\100\004\092\001\102\004\094\001\255\255\ -\096\001\109\001\110\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\108\001\255\255\032\003\111\001\ -\255\255\255\255\255\255\115\001\255\255\255\255\000\001\001\001\ -\002\001\003\001\255\255\255\255\006\001\007\001\008\001\009\001\ -\010\001\011\001\012\001\013\001\014\001\015\001\016\001\017\001\ -\018\001\019\001\020\001\021\001\149\004\255\255\024\001\025\001\ -\026\001\027\001\028\001\029\001\030\001\031\001\255\255\255\255\ -\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\ -\042\001\043\001\044\001\045\001\046\001\047\001\255\255\049\001\ -\050\001\051\001\255\255\053\001\054\001\055\001\056\001\255\255\ -\255\255\059\001\060\001\061\001\255\255\063\001\064\001\065\001\ -\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\ -\074\001\255\255\255\255\255\255\255\255\176\004\080\001\081\001\ -\082\001\083\001\084\001\085\001\086\001\087\001\255\255\089\001\ -\000\000\091\001\092\001\133\003\094\001\095\001\096\001\097\001\ -\098\001\255\255\100\001\101\001\255\255\103\001\104\001\105\001\ -\106\001\255\255\108\001\109\001\255\255\111\001\255\255\255\255\ -\255\255\115\001\255\255\055\001\255\255\057\001\058\001\059\001\ -\255\255\061\001\255\255\255\255\064\001\065\001\255\255\255\255\ -\001\005\255\255\255\255\255\255\255\255\255\255\074\001\000\001\ -\255\255\002\001\003\001\004\001\255\255\081\001\255\255\008\001\ -\255\255\255\255\255\255\255\255\013\001\089\001\090\001\255\255\ -\017\001\018\001\019\001\255\255\255\255\097\001\255\255\255\255\ -\255\255\026\001\027\001\028\001\029\001\038\005\255\255\255\255\ -\255\255\109\001\110\001\036\001\255\255\255\255\255\255\018\005\ -\041\001\255\255\220\003\221\003\222\003\255\255\255\255\048\001\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\255\255\255\255\063\001\072\005\ -\255\255\066\001\067\001\068\001\255\255\070\001\255\255\255\255\ -\073\001\074\001\255\255\255\255\255\255\255\255\087\005\080\001\ -\255\255\023\001\255\255\000\001\255\255\255\255\095\005\255\255\ -\255\255\255\255\091\001\092\001\255\255\094\001\095\001\096\001\ -\013\001\000\000\020\004\021\004\022\004\255\255\255\255\112\005\ -\083\005\255\255\255\255\108\001\255\255\026\001\111\001\028\001\ -\029\001\055\001\115\001\057\001\058\001\059\001\255\255\061\001\ -\255\255\255\255\064\001\065\001\041\001\255\255\255\255\255\255\ -\137\005\138\005\055\001\255\255\057\001\058\001\059\001\057\004\ -\061\001\255\255\147\005\064\001\065\001\255\255\255\255\060\001\ -\255\255\255\255\063\001\255\255\090\001\066\001\067\001\068\001\ -\255\255\162\005\255\255\097\001\081\001\074\001\167\005\168\005\ -\169\005\170\005\255\255\080\001\089\001\090\001\255\255\109\001\ -\110\001\255\255\255\255\255\255\097\001\255\255\255\255\092\001\ -\255\255\255\255\255\255\096\001\255\255\255\255\255\255\108\001\ -\109\001\110\001\255\255\255\255\255\255\255\255\255\255\108\001\ -\255\255\255\255\111\001\255\255\255\255\255\255\255\255\255\255\ -\122\004\123\004\255\255\255\255\255\255\127\004\128\004\129\004\ -\000\001\001\001\002\001\003\001\255\255\000\000\006\001\007\001\ -\008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ -\016\001\017\001\018\001\019\001\020\001\021\001\022\001\255\255\ -\024\001\025\001\026\001\027\001\028\001\029\001\030\001\031\001\ -\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\ -\040\001\041\001\042\001\043\001\044\001\045\001\046\001\047\001\ -\255\255\049\001\050\001\051\001\255\255\053\001\054\001\055\001\ -\056\001\255\255\255\255\059\001\060\001\061\001\062\001\063\001\ -\064\001\065\001\066\001\067\001\068\001\255\255\070\001\071\001\ -\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\081\001\082\001\083\001\084\001\085\001\086\001\087\001\ -\255\255\089\001\255\255\091\001\092\001\255\255\094\001\095\001\ -\096\001\097\001\098\001\255\255\100\001\101\001\255\255\103\001\ -\104\001\105\001\106\001\255\255\108\001\109\001\255\255\111\001\ -\255\255\255\255\255\255\115\001\255\255\255\255\255\255\255\255\ -\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\000\001\001\001\002\001\003\001\255\255\255\255\006\001\ -\007\001\008\001\009\001\010\001\011\001\012\001\013\001\014\001\ -\015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ -\255\255\024\001\025\001\026\001\027\001\028\001\029\001\030\001\ -\031\001\255\255\052\005\053\005\054\005\036\001\037\001\255\255\ -\255\255\040\001\041\001\042\001\043\001\044\001\045\001\046\001\ -\047\001\255\255\049\001\050\001\051\001\255\255\053\001\054\001\ -\055\001\056\001\255\255\255\255\059\001\060\001\061\001\255\255\ -\063\001\064\001\065\001\066\001\067\001\068\001\255\255\070\001\ -\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\081\001\082\001\083\001\084\001\085\001\086\001\ -\087\001\255\255\089\001\255\255\091\001\092\001\000\000\094\001\ -\095\001\096\001\097\001\098\001\255\255\100\001\101\001\255\255\ -\103\001\104\001\105\001\106\001\255\255\108\001\109\001\255\255\ -\111\001\255\255\255\255\255\255\115\001\000\001\001\001\002\001\ -\003\001\255\255\255\255\006\001\007\001\008\001\009\001\010\001\ -\011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ -\019\001\020\001\021\001\022\001\255\255\024\001\025\001\026\001\ -\027\001\028\001\029\001\030\001\031\001\255\255\255\255\255\255\ -\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\ -\043\001\044\001\045\001\046\001\047\001\255\255\049\001\050\001\ -\051\001\255\255\053\001\054\001\055\001\056\001\255\255\255\255\ -\059\001\060\001\061\001\255\255\063\001\064\001\065\001\066\001\ -\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\ -\255\255\255\255\255\255\255\255\255\255\080\001\081\001\082\001\ -\083\001\084\001\085\001\086\001\087\001\255\255\089\001\255\255\ -\091\001\092\001\000\000\094\001\095\001\096\001\097\001\098\001\ -\255\255\100\001\101\001\255\255\103\001\104\001\105\001\106\001\ -\255\255\108\001\109\001\255\255\111\001\255\255\255\255\255\255\ -\115\001\000\001\001\001\002\001\003\001\255\255\255\255\006\001\ -\007\001\008\001\009\001\010\001\011\001\012\001\013\001\014\001\ -\015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ -\255\255\024\001\025\001\026\001\027\001\028\001\029\001\030\001\ -\031\001\255\255\255\255\255\255\255\255\036\001\037\001\255\255\ -\255\255\040\001\041\001\042\001\043\001\044\001\045\001\046\001\ -\047\001\255\255\049\001\050\001\051\001\255\255\053\001\054\001\ -\055\001\056\001\255\255\255\255\059\001\060\001\061\001\255\255\ -\063\001\064\001\065\001\066\001\067\001\068\001\255\255\070\001\ -\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\081\001\082\001\083\001\084\001\085\001\086\001\ -\087\001\255\255\089\001\255\255\091\001\092\001\000\000\094\001\ -\095\001\096\001\097\001\098\001\255\255\100\001\101\001\255\255\ -\103\001\104\001\105\001\106\001\255\255\108\001\109\001\255\255\ -\111\001\255\255\255\255\255\255\115\001\255\255\000\001\001\001\ -\002\001\003\001\255\255\255\255\006\001\007\001\008\001\009\001\ -\010\001\011\001\012\001\013\001\014\001\015\001\016\001\017\001\ -\018\001\019\001\020\001\021\001\022\001\255\255\024\001\025\001\ -\026\001\027\001\028\001\029\001\030\001\031\001\255\255\255\255\ -\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\ -\042\001\043\001\044\001\045\001\046\001\047\001\255\255\049\001\ -\050\001\051\001\255\255\053\001\054\001\055\001\056\001\255\255\ -\255\255\059\001\060\001\061\001\255\255\063\001\064\001\065\001\ -\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\ -\074\001\255\255\255\255\255\255\255\255\255\255\080\001\081\001\ -\082\001\083\001\084\001\085\001\086\001\087\001\255\255\089\001\ -\255\255\091\001\092\001\000\000\094\001\095\001\096\001\097\001\ -\098\001\255\255\100\001\101\001\255\255\103\001\104\001\105\001\ -\106\001\255\255\108\001\109\001\255\255\111\001\255\255\255\255\ -\255\255\115\001\000\001\001\001\002\001\003\001\255\255\255\255\ -\006\001\007\001\008\001\009\001\010\001\011\001\012\001\013\001\ -\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ -\022\001\255\255\024\001\025\001\026\001\027\001\028\001\029\001\ -\030\001\031\001\255\255\255\255\255\255\255\255\036\001\037\001\ -\255\255\255\255\040\001\041\001\042\001\043\001\044\001\045\001\ -\046\001\047\001\255\255\049\001\050\001\051\001\255\255\053\001\ -\054\001\055\001\056\001\255\255\255\255\059\001\060\001\061\001\ -\255\255\063\001\064\001\065\001\066\001\067\001\068\001\255\255\ -\070\001\071\001\072\001\073\001\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\081\001\082\001\083\001\084\001\085\001\ -\086\001\087\001\255\255\089\001\255\255\091\001\092\001\000\000\ -\094\001\095\001\096\001\097\001\098\001\255\255\100\001\101\001\ -\255\255\103\001\104\001\105\001\106\001\255\255\108\001\109\001\ -\255\255\111\001\255\255\255\255\255\255\115\001\000\001\001\001\ -\002\001\003\001\255\255\255\255\006\001\007\001\008\001\009\001\ -\010\001\011\001\012\001\013\001\014\001\015\001\016\001\017\001\ -\018\001\019\001\020\001\021\001\022\001\255\255\024\001\025\001\ -\026\001\027\001\028\001\029\001\030\001\031\001\255\255\255\255\ -\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\ -\042\001\043\001\044\001\045\001\046\001\047\001\255\255\049\001\ -\050\001\051\001\255\255\053\001\054\001\055\001\056\001\255\255\ -\255\255\059\001\060\001\061\001\255\255\063\001\064\001\065\001\ -\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\ -\074\001\255\255\255\255\255\255\255\255\255\255\080\001\081\001\ -\082\001\083\001\084\001\085\001\086\001\087\001\255\255\089\001\ -\255\255\091\001\092\001\000\000\094\001\095\001\096\001\097\001\ -\098\001\255\255\100\001\101\001\255\255\103\001\104\001\105\001\ -\106\001\255\255\108\001\109\001\255\255\111\001\255\255\255\255\ -\255\255\115\001\255\255\000\001\001\001\002\001\003\001\255\255\ -\255\255\006\001\007\001\008\001\009\001\010\001\011\001\012\001\ -\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ -\021\001\022\001\255\255\024\001\025\001\026\001\027\001\028\001\ -\029\001\030\001\031\001\255\255\255\255\255\255\255\255\036\001\ -\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\ -\045\001\046\001\047\001\255\255\049\001\050\001\051\001\255\255\ -\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\ -\061\001\255\255\063\001\064\001\065\001\066\001\067\001\068\001\ -\255\255\070\001\071\001\072\001\073\001\074\001\255\255\255\255\ -\255\255\255\255\255\255\080\001\081\001\082\001\083\001\084\001\ -\085\001\086\001\087\001\255\255\089\001\255\255\091\001\092\001\ -\000\000\094\001\095\001\096\001\097\001\098\001\255\255\100\001\ -\101\001\255\255\103\001\104\001\105\001\106\001\255\255\108\001\ -\109\001\255\255\111\001\255\255\255\255\255\255\115\001\000\001\ -\001\001\002\001\003\001\255\255\255\255\006\001\007\001\008\001\ -\009\001\010\001\011\001\012\001\013\001\014\001\015\001\016\001\ -\017\001\018\001\019\001\020\001\021\001\022\001\255\255\024\001\ -\025\001\026\001\027\001\028\001\029\001\030\001\031\001\255\255\ -\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\ -\041\001\042\001\043\001\044\001\045\001\046\001\047\001\255\255\ -\049\001\050\001\051\001\255\255\053\001\054\001\055\001\056\001\ -\255\255\255\255\059\001\060\001\061\001\255\255\063\001\064\001\ -\065\001\066\001\067\001\068\001\255\255\070\001\071\001\072\001\ -\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\081\001\082\001\083\001\084\001\085\001\086\001\087\001\255\255\ -\089\001\255\255\091\001\092\001\000\000\094\001\095\001\096\001\ -\097\001\098\001\255\255\100\001\101\001\255\255\103\001\104\001\ -\105\001\106\001\255\255\108\001\109\001\255\255\111\001\255\255\ -\255\255\255\255\115\001\000\001\001\001\002\001\003\001\255\255\ -\255\255\006\001\007\001\008\001\009\001\010\001\011\001\012\001\ -\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ -\021\001\022\001\255\255\024\001\025\001\026\001\027\001\028\001\ -\029\001\030\001\031\001\255\255\255\255\255\255\255\255\036\001\ -\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\ -\045\001\046\001\047\001\255\255\049\001\050\001\051\001\255\255\ -\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\ -\061\001\255\255\063\001\064\001\065\001\066\001\067\001\068\001\ -\255\255\070\001\071\001\072\001\073\001\074\001\255\255\255\255\ -\255\255\255\255\255\255\080\001\081\001\082\001\083\001\084\001\ -\085\001\086\001\087\001\255\255\089\001\255\255\091\001\092\001\ -\000\000\094\001\095\001\096\001\097\001\098\001\255\255\100\001\ -\101\001\255\255\103\001\104\001\105\001\106\001\255\255\108\001\ -\109\001\255\255\111\001\255\255\255\255\255\255\115\001\255\255\ -\000\001\001\001\002\001\003\001\255\255\255\255\006\001\007\001\ -\008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ -\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\ -\024\001\025\001\026\001\027\001\028\001\029\001\030\001\031\001\ -\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\ -\040\001\041\001\042\001\043\001\044\001\045\001\046\001\255\255\ -\255\255\049\001\050\001\051\001\255\255\053\001\054\001\055\001\ -\056\001\255\255\255\255\059\001\060\001\061\001\255\255\063\001\ -\064\001\065\001\066\001\067\001\068\001\255\255\070\001\071\001\ -\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\081\001\082\001\083\001\084\001\085\001\086\001\087\001\ -\255\255\089\001\255\255\091\001\092\001\000\000\094\001\095\001\ -\096\001\097\001\098\001\255\255\100\001\101\001\255\255\103\001\ -\104\001\105\001\106\001\255\255\108\001\109\001\255\255\111\001\ -\255\255\255\255\255\255\115\001\000\001\001\001\002\001\003\001\ -\255\255\255\255\006\001\007\001\008\001\009\001\010\001\011\001\ -\012\001\013\001\014\001\015\001\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\ -\028\001\029\001\030\001\031\001\255\255\255\255\255\255\255\255\ -\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\ -\044\001\045\001\046\001\255\255\255\255\049\001\050\001\051\001\ -\255\255\053\001\054\001\055\001\056\001\255\255\255\255\059\001\ -\060\001\061\001\255\255\063\001\064\001\065\001\066\001\067\001\ -\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\081\001\082\001\083\001\ -\084\001\085\001\086\001\087\001\255\255\089\001\255\255\091\001\ -\092\001\000\000\094\001\095\001\096\001\255\255\255\255\255\255\ -\100\001\101\001\255\255\103\001\104\001\105\001\106\001\255\255\ -\108\001\109\001\255\255\111\001\255\255\255\255\255\255\115\001\ -\000\001\001\001\002\001\003\001\255\255\255\255\006\001\007\001\ -\008\001\009\001\010\001\011\001\012\001\013\001\014\001\015\001\ -\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\ -\024\001\025\001\026\001\027\001\028\001\029\001\030\001\031\001\ -\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\ -\040\001\041\001\042\001\043\001\044\001\045\001\046\001\255\255\ -\255\255\049\001\050\001\051\001\255\255\053\001\054\001\055\001\ -\056\001\255\255\255\255\059\001\060\001\061\001\255\255\063\001\ -\064\001\065\001\066\001\067\001\068\001\255\255\070\001\071\001\ -\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\081\001\082\001\083\001\084\001\085\001\086\001\087\001\ -\255\255\089\001\255\255\091\001\092\001\000\000\094\001\095\001\ -\096\001\255\255\255\255\255\255\100\001\101\001\255\255\103\001\ -\104\001\105\001\106\001\255\255\108\001\109\001\255\255\111\001\ -\255\255\255\255\255\255\115\001\255\255\000\001\001\001\002\001\ -\003\001\255\255\255\255\006\001\007\001\008\001\009\001\010\001\ -\011\001\012\001\013\001\014\001\015\001\016\001\017\001\018\001\ -\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\ -\027\001\028\001\029\001\030\001\031\001\255\255\255\255\255\255\ -\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\ -\043\001\044\001\045\001\046\001\255\255\255\255\049\001\050\001\ -\051\001\255\255\053\001\054\001\055\001\056\001\255\255\255\255\ -\059\001\060\001\061\001\255\255\063\001\064\001\065\001\066\001\ -\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\ -\255\255\255\255\255\255\255\255\255\255\080\001\081\001\082\001\ -\083\001\084\001\085\001\086\001\087\001\255\255\089\001\255\255\ -\091\001\092\001\000\000\094\001\095\001\096\001\255\255\255\255\ -\255\255\100\001\101\001\255\255\103\001\104\001\105\001\106\001\ -\255\255\108\001\109\001\255\255\111\001\255\255\255\255\255\255\ -\115\001\000\001\001\001\002\001\003\001\255\255\255\255\255\255\ -\255\255\008\001\009\001\010\001\255\255\255\255\013\001\014\001\ -\015\001\016\001\017\001\018\001\019\001\020\001\021\001\022\001\ -\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\ -\255\255\040\001\041\001\042\001\043\001\044\001\045\001\046\001\ -\047\001\255\255\049\001\255\255\051\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\ -\063\001\255\255\255\255\066\001\067\001\068\001\255\255\070\001\ -\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\081\001\082\001\083\001\084\001\085\001\086\001\ -\255\255\255\255\089\001\255\255\091\001\092\001\000\000\094\001\ -\095\001\096\001\097\001\098\001\255\255\100\001\255\255\255\255\ -\103\001\104\001\105\001\255\255\255\255\108\001\255\255\255\255\ -\111\001\255\255\255\255\255\255\115\001\000\001\001\001\002\001\ -\003\001\255\255\255\255\255\255\255\255\008\001\009\001\010\001\ -\255\255\255\255\013\001\014\001\015\001\016\001\017\001\018\001\ -\019\001\020\001\021\001\022\001\255\255\024\001\025\001\026\001\ -\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\ -\043\001\044\001\045\001\046\001\047\001\255\255\049\001\255\255\ -\051\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\060\001\061\001\255\255\063\001\255\255\255\255\066\001\ -\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\ -\255\255\255\255\255\255\255\255\255\255\080\001\081\001\082\001\ -\083\001\084\001\085\001\086\001\255\255\255\255\089\001\255\255\ -\091\001\092\001\000\000\094\001\095\001\096\001\097\001\098\001\ -\255\255\100\001\255\255\255\255\103\001\104\001\105\001\255\255\ -\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\ -\115\001\255\255\000\001\001\001\002\001\003\001\255\255\255\255\ -\255\255\255\255\008\001\009\001\010\001\255\255\255\255\013\001\ -\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ -\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\ -\255\255\255\255\040\001\041\001\042\001\043\001\044\001\045\001\ -\046\001\255\255\255\255\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\ -\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\ -\070\001\071\001\072\001\073\001\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\082\001\083\001\084\001\085\001\ -\086\001\255\255\255\255\255\255\255\255\091\001\092\001\000\000\ -\094\001\095\001\096\001\255\255\255\255\255\255\100\001\255\255\ -\255\255\103\001\255\255\105\001\255\255\255\255\108\001\255\255\ -\255\255\111\001\255\255\255\255\255\255\115\001\000\001\001\001\ -\002\001\003\001\255\255\255\255\255\255\255\255\008\001\009\001\ -\010\001\255\255\255\255\013\001\014\001\015\001\016\001\017\001\ -\018\001\019\001\020\001\021\001\255\255\255\255\024\001\025\001\ -\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\ -\042\001\043\001\044\001\045\001\046\001\255\255\255\255\049\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\060\001\061\001\255\255\063\001\255\255\255\255\ -\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\ -\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\ -\082\001\083\001\084\001\085\001\086\001\255\255\255\255\255\255\ -\255\255\091\001\092\001\000\000\094\001\095\001\096\001\255\255\ -\255\255\255\255\100\001\255\255\255\255\103\001\255\255\105\001\ -\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\ -\255\255\115\001\000\001\001\001\002\001\003\001\255\255\255\255\ -\255\255\255\255\008\001\009\001\010\001\255\255\255\255\013\001\ -\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ -\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\ -\255\255\255\255\040\001\041\001\042\001\043\001\044\001\045\001\ -\046\001\255\255\255\255\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\ -\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\ -\070\001\071\001\072\001\073\001\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\082\001\083\001\084\001\085\001\ -\086\001\255\255\255\255\255\255\255\255\091\001\092\001\000\000\ -\094\001\095\001\096\001\255\255\255\255\255\255\100\001\255\255\ -\255\255\103\001\255\255\105\001\255\255\255\255\108\001\255\255\ -\255\255\111\001\255\255\255\255\255\255\115\001\255\255\000\001\ -\001\001\002\001\003\001\255\255\255\255\255\255\255\255\008\001\ -\009\001\010\001\255\255\255\255\013\001\014\001\015\001\016\001\ -\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\ -\025\001\026\001\027\001\028\001\029\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\ -\041\001\042\001\043\001\044\001\045\001\046\001\255\255\255\255\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\061\001\255\255\063\001\255\255\ -\255\255\066\001\067\001\068\001\255\255\070\001\071\001\072\001\ -\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\255\255\082\001\083\001\084\001\085\001\086\001\255\255\255\255\ -\255\255\255\255\091\001\092\001\000\000\094\001\095\001\096\001\ -\255\255\255\255\255\255\100\001\255\255\255\255\103\001\255\255\ -\105\001\255\255\255\255\108\001\255\255\255\255\111\001\255\255\ -\255\255\255\255\115\001\000\001\001\001\002\001\003\001\255\255\ -\255\255\255\255\255\255\008\001\009\001\010\001\255\255\255\255\ -\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ -\021\001\255\255\255\255\024\001\025\001\026\001\027\001\028\001\ -\029\001\255\255\255\255\255\255\255\255\255\255\255\255\036\001\ -\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\ -\045\001\046\001\255\255\255\255\049\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\ -\061\001\255\255\063\001\255\255\255\255\066\001\067\001\068\001\ -\255\255\070\001\071\001\072\001\073\001\074\001\255\255\255\255\ -\255\255\255\255\255\255\080\001\255\255\082\001\083\001\084\001\ -\085\001\086\001\255\255\255\255\255\255\255\255\091\001\092\001\ -\000\000\094\001\095\001\096\001\255\255\255\255\255\255\100\001\ -\255\255\255\255\103\001\255\255\105\001\255\255\255\255\108\001\ -\255\255\255\255\111\001\255\255\255\255\255\255\115\001\000\001\ -\001\001\002\001\003\001\255\255\255\255\255\255\255\255\008\001\ -\009\001\010\001\255\255\255\255\013\001\014\001\015\001\016\001\ -\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\ -\025\001\026\001\027\001\028\001\029\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\ -\041\001\042\001\043\001\044\001\045\001\046\001\255\255\255\255\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\061\001\255\255\063\001\255\255\ -\255\255\066\001\067\001\068\001\255\255\070\001\071\001\072\001\ -\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\255\255\082\001\083\001\084\001\085\001\086\001\255\255\255\255\ -\255\255\255\255\091\001\092\001\000\000\094\001\095\001\096\001\ -\255\255\255\255\255\255\100\001\255\255\255\255\103\001\255\255\ -\105\001\255\255\255\255\108\001\255\255\255\255\111\001\255\255\ -\255\255\255\255\115\001\255\255\000\001\001\001\002\001\003\001\ -\255\255\255\255\255\255\255\255\008\001\009\001\010\001\255\255\ -\255\255\013\001\014\001\015\001\016\001\017\001\255\255\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\ -\044\001\045\001\046\001\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\060\001\061\001\255\255\063\001\255\255\255\255\066\001\067\001\ -\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\082\001\083\001\ -\084\001\085\001\086\001\255\255\255\255\255\255\255\255\091\001\ -\092\001\000\000\094\001\095\001\096\001\255\255\255\255\255\255\ -\100\001\255\255\255\255\103\001\255\255\105\001\255\255\255\255\ -\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\ -\000\001\001\001\002\001\003\001\255\255\255\255\255\255\255\255\ -\008\001\009\001\010\001\255\255\255\255\013\001\014\001\015\001\ -\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\ -\024\001\025\001\026\001\027\001\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\ -\040\001\041\001\042\001\043\001\044\001\045\001\255\255\255\255\ -\255\255\049\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\060\001\061\001\255\255\063\001\ -\255\255\255\255\066\001\067\001\068\001\255\255\070\001\071\001\ -\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\255\255\082\001\083\001\084\001\085\001\086\001\255\255\ -\255\255\255\255\255\255\091\001\092\001\000\000\094\001\095\001\ -\096\001\255\255\255\255\255\255\100\001\255\255\255\255\103\001\ -\255\255\105\001\255\255\255\255\108\001\255\255\255\255\111\001\ -\255\255\255\255\255\255\115\001\000\001\001\001\002\001\003\001\ -\255\255\255\255\255\255\255\255\008\001\009\001\010\001\255\255\ -\255\255\013\001\014\001\015\001\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\ -\044\001\045\001\255\255\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\060\001\061\001\255\255\063\001\255\255\255\255\066\001\067\001\ -\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\082\001\083\001\ -\084\001\085\001\086\001\255\255\255\255\255\255\255\255\091\001\ -\092\001\000\000\094\001\095\001\096\001\255\255\255\255\255\255\ -\100\001\255\255\255\255\103\001\255\255\105\001\255\255\255\255\ -\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\ -\255\255\000\001\001\001\002\001\003\001\255\255\255\255\255\255\ -\255\255\008\001\009\001\010\001\255\255\255\255\013\001\014\001\ -\015\001\016\001\017\001\018\001\019\001\020\001\021\001\255\255\ -\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\ -\255\255\040\001\041\001\042\001\043\001\044\001\045\001\255\255\ -\255\255\255\255\049\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\ -\063\001\255\255\255\255\066\001\067\001\068\001\255\255\070\001\ -\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\255\255\082\001\083\001\084\001\085\001\086\001\ -\255\255\255\255\255\255\255\255\091\001\092\001\000\000\094\001\ -\095\001\096\001\255\255\255\255\255\255\100\001\255\255\255\255\ -\103\001\255\255\105\001\255\255\255\255\108\001\255\255\255\255\ -\111\001\255\255\255\255\255\255\115\001\000\001\001\001\002\001\ -\003\001\255\255\255\255\255\255\255\255\008\001\009\001\010\001\ -\255\255\255\255\013\001\014\001\015\001\016\001\017\001\018\001\ -\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\ -\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\ -\043\001\044\001\045\001\255\255\255\255\255\255\049\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\060\001\061\001\255\255\063\001\255\255\255\255\066\001\ -\067\001\068\001\255\255\070\001\071\001\072\001\073\001\074\001\ -\255\255\255\255\255\255\255\255\255\255\080\001\255\255\082\001\ -\083\001\084\001\085\001\086\001\255\255\255\255\255\255\255\255\ -\091\001\092\001\000\000\094\001\095\001\096\001\255\255\255\255\ -\255\255\100\001\255\255\255\255\103\001\255\255\105\001\255\255\ -\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\ -\115\001\000\001\001\001\002\001\003\001\255\255\255\255\255\255\ -\255\255\255\255\009\001\010\001\255\255\255\255\013\001\014\001\ -\015\001\016\001\017\001\018\001\019\001\020\001\021\001\255\255\ -\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\ -\255\255\040\001\041\001\042\001\043\001\044\001\045\001\046\001\ -\255\255\255\255\049\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\ -\063\001\255\255\255\255\066\001\067\001\068\001\255\255\070\001\ -\071\001\072\001\073\001\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\255\255\082\001\083\001\084\001\085\001\086\001\ -\255\255\255\255\255\255\255\255\091\001\092\001\000\000\094\001\ -\095\001\096\001\255\255\255\255\255\255\100\001\255\255\255\255\ -\103\001\255\255\105\001\255\255\255\255\108\001\255\255\255\255\ -\111\001\255\255\255\255\255\255\115\001\255\255\000\001\001\001\ -\002\001\003\001\255\255\255\255\255\255\255\255\255\255\009\001\ -\010\001\255\255\255\255\013\001\014\001\015\001\016\001\017\001\ -\018\001\019\001\020\001\021\001\255\255\255\255\024\001\025\001\ -\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\ -\042\001\043\001\044\001\045\001\046\001\255\255\255\255\049\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\060\001\061\001\255\255\063\001\255\255\255\255\ -\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\ -\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\ -\082\001\083\001\084\001\085\001\086\001\255\255\255\255\255\255\ -\255\255\091\001\092\001\000\000\094\001\095\001\096\001\255\255\ -\255\255\255\255\100\001\255\255\255\255\103\001\255\255\105\001\ -\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\ -\255\255\115\001\000\001\001\001\002\001\003\001\255\255\255\255\ -\255\255\255\255\255\255\009\001\010\001\255\255\255\255\013\001\ -\014\001\015\001\016\001\017\001\018\001\019\001\020\001\021\001\ -\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\ -\255\255\255\255\040\001\041\001\042\001\043\001\044\001\045\001\ -\046\001\255\255\255\255\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\ -\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\ -\070\001\071\001\072\001\073\001\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\082\001\083\001\084\001\085\001\ -\086\001\255\255\255\255\255\255\255\255\091\001\092\001\000\000\ -\094\001\095\001\096\001\255\255\255\255\255\255\100\001\255\255\ -\255\255\103\001\255\255\105\001\255\255\255\255\108\001\255\255\ -\255\255\111\001\255\255\255\255\255\255\115\001\000\001\001\001\ -\002\001\003\001\255\255\255\255\255\255\255\255\008\001\009\001\ -\010\001\255\255\255\255\013\001\014\001\015\001\016\001\017\001\ -\018\001\019\001\020\001\021\001\255\255\255\255\024\001\025\001\ -\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\ -\042\001\043\001\044\001\255\255\255\255\255\255\255\255\049\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\060\001\061\001\255\255\063\001\255\255\255\255\ -\066\001\067\001\068\001\255\255\070\001\071\001\072\001\073\001\ -\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\ -\082\001\255\255\084\001\085\001\086\001\255\255\255\255\255\255\ -\255\255\091\001\092\001\000\000\094\001\095\001\096\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\103\001\255\255\105\001\ -\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\ -\255\255\115\001\255\255\000\001\001\001\002\001\003\001\255\255\ -\255\255\255\255\255\255\008\001\009\001\010\001\255\255\255\255\ -\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ -\021\001\255\255\255\255\024\001\025\001\026\001\027\001\028\001\ -\029\001\255\255\255\255\255\255\255\255\255\255\255\255\036\001\ -\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\ -\255\255\255\255\255\255\255\255\049\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\ -\061\001\255\255\063\001\255\255\255\255\066\001\067\001\068\001\ -\255\255\070\001\071\001\072\001\073\001\074\001\255\255\255\255\ -\255\255\255\255\255\255\080\001\255\255\082\001\255\255\084\001\ -\085\001\086\001\255\255\255\255\255\255\255\255\091\001\092\001\ -\000\000\094\001\095\001\096\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\103\001\255\255\105\001\255\255\255\255\108\001\ -\255\255\255\255\111\001\255\255\255\255\255\255\115\001\000\001\ -\001\001\002\001\003\001\255\255\255\255\255\255\255\255\008\001\ -\009\001\010\001\255\255\255\255\013\001\014\001\015\001\016\001\ -\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\ -\025\001\026\001\027\001\028\001\029\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\036\001\037\001\255\255\255\255\040\001\ -\041\001\042\001\043\001\044\001\255\255\255\255\255\255\255\255\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\061\001\255\255\063\001\255\255\ -\255\255\066\001\067\001\068\001\255\255\070\001\071\001\072\001\ -\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\255\255\082\001\255\255\084\001\085\001\086\001\255\255\255\255\ -\255\255\255\255\091\001\092\001\000\000\094\001\095\001\096\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\103\001\255\255\ -\105\001\255\255\255\255\108\001\255\255\255\255\111\001\255\255\ -\255\255\255\255\115\001\000\001\001\001\002\001\003\001\255\255\ -\255\255\255\255\255\255\008\001\009\001\010\001\255\255\255\255\ -\013\001\014\001\015\001\016\001\017\001\018\001\019\001\020\001\ -\021\001\255\255\255\255\024\001\025\001\026\001\027\001\028\001\ -\029\001\255\255\255\255\255\255\255\255\255\255\255\255\036\001\ -\037\001\255\255\255\255\040\001\041\001\042\001\043\001\044\001\ -\255\255\255\255\255\255\255\255\049\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\ -\061\001\255\255\063\001\255\255\255\255\066\001\067\001\068\001\ -\255\255\070\001\071\001\072\001\073\001\074\001\255\255\255\255\ -\255\255\255\255\255\255\080\001\255\255\082\001\255\255\084\001\ -\085\001\086\001\255\255\255\255\255\255\255\255\091\001\092\001\ -\000\000\094\001\095\001\096\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\103\001\255\255\105\001\255\255\255\255\108\001\ -\255\255\255\255\111\001\255\255\255\255\255\255\115\001\255\255\ -\000\001\001\001\002\001\003\001\255\255\255\255\255\255\255\255\ -\008\001\009\001\010\001\255\255\255\255\013\001\014\001\015\001\ -\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\ -\024\001\025\001\026\001\027\001\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\ -\040\001\041\001\042\001\043\001\044\001\255\255\255\255\255\255\ -\255\255\049\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\060\001\061\001\255\255\063\001\ -\255\255\255\255\066\001\067\001\068\001\255\255\070\001\071\001\ -\072\001\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\255\255\082\001\255\255\084\001\085\001\086\001\255\255\ -\255\255\255\255\255\255\091\001\092\001\000\000\094\001\095\001\ -\096\001\255\255\255\255\255\255\255\255\255\255\255\255\103\001\ -\255\255\105\001\255\255\255\255\108\001\255\255\255\255\111\001\ -\255\255\255\255\255\255\115\001\000\001\001\001\002\001\003\001\ -\255\255\255\255\255\255\255\255\008\001\009\001\010\001\255\255\ -\255\255\013\001\014\001\015\001\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\027\001\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\036\001\037\001\255\255\255\255\040\001\041\001\042\001\043\001\ -\044\001\255\255\255\255\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\060\001\061\001\255\255\063\001\255\255\255\255\066\001\067\001\ -\068\001\255\255\070\001\071\001\072\001\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\082\001\255\255\ -\084\001\085\001\086\001\255\255\255\255\255\255\255\255\091\001\ -\092\001\000\000\094\001\095\001\096\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\103\001\255\255\105\001\255\255\255\255\ -\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\ -\000\001\001\001\002\001\003\001\255\255\255\255\255\255\255\255\ -\008\001\009\001\010\001\255\255\255\255\013\001\014\001\015\001\ -\016\001\017\001\018\001\019\001\020\001\021\001\255\255\255\255\ -\024\001\025\001\026\001\027\001\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\036\001\037\001\255\255\255\255\ -\040\001\041\001\042\001\043\001\044\001\045\001\046\001\255\255\ -\255\255\049\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\060\001\061\001\255\255\255\255\ -\255\255\255\255\066\001\067\001\068\001\255\255\070\001\255\255\ -\255\255\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\255\255\082\001\255\255\255\255\255\255\086\001\255\255\ -\255\255\255\255\255\255\091\001\092\001\000\000\094\001\095\001\ -\096\001\255\255\255\255\255\255\100\001\255\255\255\255\103\001\ -\255\255\105\001\255\255\255\255\108\001\255\255\255\255\111\001\ -\255\255\255\255\255\255\115\001\255\255\000\001\001\001\002\001\ -\003\001\255\255\255\255\255\255\255\255\008\001\009\001\010\001\ -\255\255\255\255\013\001\014\001\255\255\016\001\017\001\018\001\ -\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\ -\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\ -\043\001\255\255\255\255\255\255\255\255\255\255\049\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\060\001\061\001\255\255\063\001\255\255\255\255\066\001\ -\067\001\068\001\255\255\070\001\255\255\255\255\073\001\074\001\ -\255\255\255\255\255\255\255\255\255\255\080\001\255\255\082\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\091\001\092\001\000\000\094\001\095\001\096\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\103\001\255\255\105\001\255\255\ -\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\ -\115\001\000\001\001\001\002\001\003\001\255\255\255\255\255\255\ -\255\255\008\001\009\001\010\001\255\255\255\255\013\001\014\001\ -\255\255\016\001\017\001\018\001\019\001\020\001\021\001\255\255\ -\255\255\024\001\025\001\026\001\027\001\028\001\029\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\036\001\037\001\255\255\ -\255\255\040\001\041\001\042\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\049\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\060\001\061\001\255\255\ -\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\ -\255\255\255\255\073\001\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\255\255\082\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\091\001\092\001\000\000\094\001\ -\095\001\096\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\103\001\255\255\105\001\255\255\255\255\108\001\255\255\255\255\ -\111\001\255\255\255\255\255\255\115\001\000\001\001\001\002\001\ -\003\001\255\255\255\255\255\255\255\255\008\001\009\001\010\001\ -\255\255\255\255\013\001\014\001\255\255\016\001\017\001\018\001\ -\019\001\020\001\021\001\255\255\255\255\024\001\025\001\026\001\ -\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\036\001\037\001\255\255\255\255\040\001\041\001\042\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\049\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\060\001\061\001\255\255\063\001\255\255\255\255\255\255\ -\067\001\068\001\255\255\070\001\255\255\255\255\073\001\074\001\ -\255\255\255\255\255\255\255\255\255\255\080\001\255\255\082\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\091\001\092\001\000\000\094\001\095\001\096\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\103\001\255\255\105\001\255\255\ -\255\255\108\001\255\255\255\255\111\001\255\255\255\255\255\255\ -\115\001\255\255\000\001\001\001\002\001\003\001\255\255\255\255\ -\255\255\255\255\008\001\009\001\010\001\255\255\255\255\013\001\ -\014\001\255\255\016\001\017\001\018\001\019\001\020\001\021\001\ -\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\ -\255\255\255\255\040\001\041\001\042\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\ -\255\255\063\001\255\255\255\255\255\255\067\001\068\001\255\255\ -\070\001\255\255\255\255\073\001\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\082\001\255\255\255\255\000\000\ -\255\255\255\255\255\255\255\255\255\255\091\001\092\001\255\255\ -\094\001\095\001\096\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\103\001\255\255\105\001\255\255\255\255\108\001\255\255\ -\255\255\111\001\255\255\255\255\255\255\115\001\000\001\001\001\ -\002\001\003\001\255\255\255\255\255\255\255\255\008\001\009\001\ -\010\001\255\255\255\255\013\001\014\001\255\255\016\001\017\001\ -\018\001\019\001\020\001\021\001\255\255\255\255\024\001\025\001\ -\026\001\027\001\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\036\001\037\001\255\255\255\255\040\001\041\001\ -\042\001\255\255\255\255\255\255\255\255\255\255\255\255\049\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\060\001\061\001\255\255\063\001\255\255\255\255\ -\255\255\067\001\068\001\255\255\070\001\255\255\255\255\073\001\ -\074\001\255\255\255\255\255\255\000\000\255\255\080\001\255\255\ -\082\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\091\001\092\001\255\255\094\001\095\001\096\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\103\001\255\255\105\001\ -\255\255\255\255\108\001\255\255\255\255\111\001\255\255\255\255\ -\255\255\115\001\000\001\001\001\002\001\003\001\255\255\255\255\ -\255\255\255\255\008\001\009\001\010\001\255\255\255\255\013\001\ -\014\001\255\255\016\001\017\001\018\001\019\001\020\001\021\001\ -\255\255\255\255\024\001\025\001\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\036\001\037\001\ -\255\255\255\255\040\001\041\001\042\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\061\001\ -\255\255\063\001\255\255\255\255\000\000\067\001\068\001\255\255\ -\070\001\255\255\255\255\073\001\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\082\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\091\001\092\001\255\255\ -\094\001\095\001\096\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\103\001\255\255\105\001\255\255\255\255\108\001\000\001\ -\255\255\111\001\003\001\255\255\255\255\115\001\255\255\008\001\ -\009\001\010\001\255\255\255\255\013\001\014\001\255\255\016\001\ -\017\001\018\001\019\001\020\001\021\001\255\255\255\255\024\001\ -\025\001\026\001\255\255\028\001\029\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\037\001\255\255\255\255\040\001\ -\041\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\000\000\255\255\063\001\255\255\ -\255\255\255\255\067\001\068\001\255\255\070\001\255\255\255\255\ -\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\255\255\082\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\091\001\092\001\255\255\094\001\095\001\096\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\103\001\255\255\ -\105\001\255\255\255\255\108\001\000\001\255\255\111\001\003\001\ -\255\255\255\255\115\001\255\255\008\001\009\001\010\001\255\255\ -\255\255\013\001\014\001\255\255\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\255\255\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\037\001\255\255\255\255\040\001\041\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\000\000\255\255\255\255\255\255\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\082\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\091\001\ -\092\001\255\255\094\001\095\001\096\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\103\001\000\001\105\001\255\255\003\001\ -\108\001\255\255\255\255\111\001\008\001\255\255\010\001\115\001\ -\255\255\013\001\014\001\255\255\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\255\255\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\037\001\255\255\255\255\040\001\041\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\000\000\255\255\255\255\255\255\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\255\255\255\255\ -\255\255\255\255\000\000\255\255\255\255\255\255\255\255\091\001\ -\092\001\255\255\094\001\095\001\096\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\103\001\000\001\105\001\255\255\003\001\ -\108\001\255\255\255\255\111\001\008\001\255\255\010\001\115\001\ -\255\255\013\001\014\001\255\255\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\255\255\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\037\001\255\255\255\255\040\001\041\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\049\001\255\255\000\000\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\000\000\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\091\001\ -\092\001\255\255\094\001\095\001\096\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\103\001\000\001\105\001\255\255\003\001\ -\108\001\255\255\255\255\111\001\008\001\255\255\010\001\115\001\ -\255\255\013\001\014\001\255\255\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\255\255\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\037\001\255\255\255\255\040\001\041\001\255\255\255\255\ -\255\255\255\255\000\000\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\091\001\ -\092\001\255\255\094\001\095\001\096\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\103\001\000\001\105\001\255\255\003\001\ -\108\001\255\255\255\255\111\001\008\001\255\255\010\001\115\001\ -\255\255\013\001\014\001\255\255\016\001\017\001\018\001\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\255\255\ -\028\001\029\001\000\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\037\001\008\001\255\255\040\001\041\001\255\255\013\001\ -\255\255\255\255\000\000\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\026\001\255\255\028\001\029\001\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\070\001\041\001\255\255\073\001\074\001\255\255\ -\000\000\255\255\255\255\255\255\080\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\091\001\ -\092\001\063\001\094\001\095\001\096\001\067\001\068\001\000\001\ -\255\255\255\255\003\001\103\001\074\001\105\001\255\255\008\001\ -\108\001\010\001\080\001\111\001\013\001\014\001\255\255\115\001\ -\017\001\255\255\019\001\020\001\021\001\255\255\092\001\024\001\ -\025\001\026\001\096\001\028\001\029\001\000\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\037\001\255\255\108\001\040\001\ -\041\001\111\001\013\001\255\255\255\255\000\000\255\255\255\255\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\026\001\ -\255\255\028\001\029\001\060\001\255\255\255\255\063\001\255\255\ -\255\255\255\255\067\001\068\001\255\255\070\001\041\001\255\255\ -\073\001\074\001\255\255\000\000\255\255\255\255\255\255\080\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\060\001\091\001\092\001\063\001\094\001\095\001\096\001\ -\067\001\068\001\000\001\255\255\255\255\003\001\103\001\074\001\ -\105\001\255\255\008\001\108\001\010\001\080\001\111\001\013\001\ -\014\001\255\255\115\001\017\001\255\255\019\001\020\001\021\001\ -\255\255\092\001\024\001\025\001\026\001\096\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\037\001\ -\255\255\108\001\040\001\041\001\111\001\255\255\255\255\255\255\ -\000\000\255\255\255\255\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\255\255\ -\255\255\063\001\255\255\255\255\255\255\067\001\068\001\255\255\ -\070\001\255\255\255\255\073\001\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\091\001\092\001\255\255\ -\094\001\095\001\096\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\103\001\000\001\105\001\255\255\003\001\108\001\255\255\ -\255\255\111\001\008\001\255\255\010\001\115\001\255\255\013\001\ -\014\001\255\255\255\255\017\001\255\255\019\001\020\001\021\001\ -\255\255\255\255\024\001\025\001\026\001\255\255\028\001\029\001\ -\000\001\255\255\255\255\255\255\255\255\255\255\255\255\037\001\ -\255\255\255\255\040\001\041\001\255\255\013\001\255\255\255\255\ -\000\000\255\255\255\255\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\026\001\255\255\028\001\029\001\060\001\255\255\ -\255\255\063\001\255\255\255\255\255\255\067\001\068\001\255\255\ -\070\001\041\001\255\255\073\001\074\001\255\255\000\000\255\255\ -\255\255\255\255\080\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\060\001\091\001\092\001\063\001\ -\094\001\095\001\096\001\067\001\068\001\000\001\255\255\255\255\ -\003\001\103\001\074\001\105\001\255\255\008\001\108\001\010\001\ -\080\001\111\001\013\001\014\001\255\255\115\001\017\001\255\255\ -\019\001\020\001\021\001\255\255\092\001\024\001\025\001\026\001\ -\096\001\028\001\029\001\000\001\255\255\255\255\003\001\255\255\ -\255\255\255\255\037\001\255\255\108\001\040\001\041\001\111\001\ -\013\001\255\255\255\255\000\000\255\255\255\255\049\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\026\001\255\255\028\001\ -\029\001\060\001\255\255\255\255\063\001\255\255\255\255\255\255\ -\067\001\068\001\255\255\070\001\041\001\255\255\073\001\074\001\ -\255\255\000\000\255\255\255\255\255\255\080\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\060\001\ -\091\001\092\001\063\001\094\001\095\001\096\001\255\255\068\001\ -\000\001\255\255\255\255\003\001\103\001\074\001\105\001\255\255\ -\008\001\108\001\010\001\080\001\111\001\013\001\014\001\255\255\ -\115\001\017\001\255\255\019\001\020\001\021\001\255\255\092\001\ -\024\001\025\001\026\001\096\001\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\037\001\255\255\108\001\ -\040\001\041\001\111\001\255\255\255\255\255\255\000\000\255\255\ -\255\255\049\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\060\001\255\255\255\255\063\001\ -\255\255\255\255\255\255\067\001\068\001\255\255\070\001\255\255\ -\255\255\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\091\001\092\001\255\255\094\001\095\001\ -\096\001\255\255\255\255\255\255\255\255\255\255\255\255\103\001\ -\000\001\105\001\255\255\003\001\108\001\255\255\255\255\111\001\ -\008\001\255\255\010\001\115\001\255\255\013\001\014\001\255\255\ -\255\255\017\001\255\255\019\001\020\001\021\001\255\255\255\255\ -\024\001\025\001\026\001\255\255\028\001\029\001\000\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\037\001\255\255\255\255\ -\040\001\041\001\255\255\013\001\255\255\255\255\000\000\255\255\ -\255\255\049\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\026\001\255\255\028\001\029\001\060\001\255\255\255\255\063\001\ -\255\255\255\255\255\255\067\001\068\001\255\255\070\001\041\001\ -\255\255\073\001\074\001\255\255\000\000\255\255\255\255\255\255\ -\080\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\060\001\091\001\092\001\063\001\094\001\095\001\ -\096\001\067\001\068\001\000\001\255\255\255\255\003\001\103\001\ -\074\001\105\001\255\255\008\001\108\001\010\001\080\001\111\001\ -\013\001\014\001\255\255\115\001\017\001\255\255\019\001\020\001\ -\021\001\255\255\092\001\024\001\025\001\026\001\096\001\028\001\ -\029\001\000\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\037\001\255\255\108\001\040\001\041\001\111\001\013\001\255\255\ -\255\255\000\000\255\255\255\255\049\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\026\001\255\255\028\001\029\001\060\001\ -\255\255\255\255\063\001\255\255\255\255\255\255\067\001\068\001\ -\255\255\070\001\041\001\255\255\073\001\074\001\255\255\000\000\ -\255\255\255\255\255\255\080\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\060\001\091\001\092\001\ -\063\001\094\001\095\001\096\001\067\001\068\001\000\001\255\255\ -\255\255\003\001\103\001\074\001\105\001\255\255\008\001\108\001\ -\010\001\080\001\111\001\013\001\014\001\255\255\115\001\017\001\ -\255\255\019\001\020\001\021\001\255\255\092\001\024\001\025\001\ -\026\001\096\001\028\001\029\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\037\001\255\255\108\001\040\001\041\001\ -\111\001\255\255\255\255\255\255\000\000\255\255\255\255\049\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\060\001\255\255\255\255\063\001\255\255\255\255\ -\255\255\067\001\068\001\255\255\070\001\255\255\255\255\073\001\ -\074\001\255\255\255\255\255\255\255\255\255\255\080\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\091\001\092\001\255\255\094\001\095\001\096\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\103\001\000\001\105\001\ -\255\255\003\001\108\001\255\255\255\255\111\001\008\001\255\255\ -\010\001\115\001\255\255\013\001\014\001\255\255\255\255\017\001\ -\255\255\019\001\020\001\021\001\255\255\255\255\024\001\025\001\ -\026\001\255\255\028\001\029\001\000\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\037\001\255\255\255\255\040\001\041\001\ -\255\255\013\001\255\255\255\255\000\000\255\255\255\255\049\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\026\001\255\255\ -\028\001\029\001\060\001\255\255\255\255\063\001\255\255\255\255\ -\255\255\067\001\068\001\255\255\070\001\041\001\255\255\073\001\ -\074\001\255\255\000\000\255\255\255\255\255\255\080\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\060\001\091\001\092\001\063\001\094\001\095\001\096\001\255\255\ -\068\001\000\001\255\255\255\255\003\001\103\001\074\001\105\001\ -\255\255\008\001\108\001\010\001\080\001\111\001\013\001\014\001\ -\255\255\115\001\017\001\255\255\019\001\020\001\021\001\255\255\ -\092\001\024\001\025\001\026\001\096\001\028\001\029\001\000\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\037\001\255\255\ -\108\001\040\001\041\001\111\001\013\001\255\255\255\255\000\000\ -\255\255\255\255\049\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\026\001\255\255\028\001\029\001\060\001\255\255\255\255\ -\063\001\255\255\255\255\255\255\067\001\068\001\255\255\070\001\ -\041\001\255\255\073\001\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\091\001\092\001\063\001\094\001\ -\095\001\096\001\255\255\068\001\000\001\255\255\255\255\003\001\ -\103\001\074\001\105\001\255\255\008\001\108\001\010\001\080\001\ -\111\001\013\001\014\001\255\255\115\001\017\001\255\255\019\001\ -\020\001\021\001\255\255\092\001\024\001\025\001\026\001\096\001\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\037\001\255\255\108\001\040\001\041\001\111\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\049\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\000\000\255\255\255\255\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\091\001\ -\092\001\255\255\094\001\095\001\096\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\103\001\000\001\105\001\255\255\003\001\ -\108\001\255\255\255\255\111\001\008\001\255\255\010\001\115\001\ -\255\255\013\001\014\001\255\255\255\255\017\001\255\255\019\001\ -\020\001\021\001\255\255\255\255\024\001\025\001\026\001\255\255\ -\028\001\029\001\000\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\037\001\255\255\255\255\040\001\041\001\255\255\013\001\ -\255\255\255\255\255\255\255\255\255\255\049\001\255\255\255\255\ -\000\000\255\255\255\255\255\255\026\001\255\255\028\001\029\001\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\070\001\041\001\255\255\073\001\074\001\255\255\ -\255\255\255\255\255\255\255\255\080\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\091\001\ -\092\001\063\001\094\001\095\001\096\001\255\255\068\001\000\001\ -\255\255\255\255\003\001\103\001\074\001\105\001\255\255\008\001\ -\108\001\010\001\080\001\111\001\013\001\014\001\255\255\115\001\ -\017\001\255\255\019\001\020\001\021\001\255\255\092\001\024\001\ -\025\001\026\001\096\001\028\001\029\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\037\001\255\255\108\001\040\001\ -\041\001\111\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\255\255\255\255\063\001\255\255\ -\255\255\255\255\067\001\068\001\000\000\070\001\255\255\255\255\ -\073\001\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\091\001\092\001\255\255\094\001\255\255\096\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\103\001\255\255\ -\105\001\255\255\255\255\108\001\255\255\000\001\111\001\002\001\ -\003\001\004\001\115\001\255\255\255\255\008\001\255\255\255\255\ -\255\255\255\255\013\001\255\255\255\255\255\255\017\001\018\001\ -\019\001\255\255\255\255\255\255\255\255\255\255\255\255\026\001\ -\027\001\028\001\029\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\036\001\255\255\255\255\255\255\040\001\041\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\048\001\049\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\000\ -\255\255\060\001\255\255\255\255\063\001\255\255\255\255\066\001\ -\067\001\068\001\255\255\070\001\255\255\255\255\073\001\074\001\ -\255\255\255\255\255\255\255\255\255\255\080\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\091\001\092\001\255\255\094\001\095\001\096\001\255\255\255\255\ -\000\001\100\001\255\255\003\001\255\255\255\255\255\255\255\255\ -\008\001\108\001\010\001\255\255\111\001\013\001\014\001\255\255\ -\115\001\017\001\255\255\019\001\020\001\021\001\255\255\255\255\ -\024\001\255\255\026\001\255\255\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\037\001\255\255\255\255\ -\040\001\041\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\049\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\000\000\255\255\060\001\255\255\255\255\063\001\ -\255\255\255\255\255\255\067\001\068\001\255\255\070\001\255\255\ -\255\255\073\001\074\001\255\255\255\255\255\255\255\255\255\255\ -\080\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\091\001\092\001\255\255\094\001\095\001\ -\096\001\255\255\255\255\255\255\255\255\255\255\255\255\103\001\ -\255\255\105\001\255\255\255\255\108\001\255\255\255\255\111\001\ -\255\255\255\255\255\255\115\001\000\001\255\255\002\001\003\001\ -\004\001\255\255\255\255\255\255\008\001\255\255\255\255\255\255\ -\255\255\013\001\255\255\255\255\255\255\017\001\018\001\019\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\026\001\027\001\ -\028\001\029\001\255\255\255\255\008\001\255\255\255\255\255\255\ -\036\001\255\255\255\255\255\255\255\255\041\001\255\255\000\000\ -\255\255\255\255\255\255\023\001\048\001\049\001\255\255\255\255\ -\255\255\255\255\030\001\255\255\255\255\255\255\255\255\255\255\ -\060\001\255\255\255\255\063\001\255\255\255\255\066\001\067\001\ -\068\001\255\255\070\001\255\255\255\255\073\001\074\001\255\255\ -\255\255\255\255\255\255\055\001\080\001\057\001\058\001\059\001\ -\255\255\061\001\255\255\255\255\064\001\065\001\255\255\091\001\ -\092\001\255\255\094\001\095\001\096\001\255\255\255\255\000\001\ -\255\255\002\001\003\001\004\001\255\255\081\001\255\255\008\001\ -\108\001\255\255\255\255\111\001\013\001\089\001\090\001\115\001\ -\017\001\018\001\019\001\255\255\255\255\097\001\255\255\255\255\ -\255\255\026\001\027\001\028\001\029\001\255\255\106\001\255\255\ -\255\255\109\001\110\001\036\001\255\255\255\255\255\255\255\255\ -\041\001\255\255\000\000\255\255\255\255\255\255\255\255\048\001\ -\049\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\255\255\255\255\063\001\255\255\ -\255\255\066\001\067\001\068\001\255\255\070\001\255\255\255\255\ -\255\255\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\091\001\092\001\255\255\094\001\095\001\096\001\ -\255\255\255\255\000\001\255\255\002\001\003\001\004\001\255\255\ -\255\255\255\255\008\001\108\001\255\255\255\255\111\001\013\001\ -\255\255\255\255\115\001\017\001\018\001\019\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\000\000\255\255\036\001\255\255\ -\255\255\255\255\255\255\041\001\255\255\255\255\000\000\255\255\ -\255\255\255\255\048\001\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\255\255\ -\255\255\063\001\255\255\255\255\066\001\067\001\068\001\255\255\ -\070\001\255\255\255\255\255\255\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\091\001\092\001\000\000\ -\094\001\095\001\096\001\255\255\255\255\255\255\255\255\000\001\ -\255\255\002\001\003\001\004\001\255\255\255\255\108\001\008\001\ -\255\255\111\001\255\255\255\255\013\001\115\001\255\255\255\255\ -\017\001\018\001\019\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\026\001\027\001\028\001\029\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\036\001\255\255\255\255\255\255\255\255\ -\041\001\255\255\255\255\255\255\255\255\255\255\255\255\048\001\ -\049\001\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\060\001\255\255\255\255\063\001\255\255\ -\255\255\066\001\067\001\068\001\255\255\070\001\255\255\255\255\ -\255\255\074\001\255\255\255\255\255\255\255\255\055\001\080\001\ -\057\001\058\001\059\001\255\255\061\001\255\255\255\255\064\001\ -\065\001\255\255\091\001\092\001\255\255\094\001\095\001\096\001\ -\255\255\255\255\000\001\255\255\002\001\003\001\004\001\255\255\ -\081\001\255\255\008\001\108\001\255\255\255\255\111\001\013\001\ -\089\001\090\001\115\001\017\001\018\001\019\001\255\255\255\255\ -\097\001\255\255\255\255\255\255\026\001\027\001\028\001\029\001\ -\255\255\255\255\255\255\255\255\109\001\110\001\036\001\255\255\ -\255\255\255\255\255\255\041\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\048\001\049\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\060\001\255\255\ -\255\255\063\001\000\000\255\255\066\001\067\001\068\001\255\255\ -\070\001\255\255\255\255\255\255\074\001\255\255\255\255\255\255\ -\255\255\255\255\080\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\000\001\091\001\092\001\003\001\ -\094\001\095\001\096\001\255\255\255\255\255\255\000\001\255\255\ -\255\255\013\001\255\255\255\255\255\255\017\001\108\001\019\001\ -\255\255\111\001\255\255\013\001\255\255\115\001\026\001\027\001\ -\028\001\029\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\026\001\255\255\028\001\029\001\255\255\041\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\041\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\000\001\ -\060\001\255\255\255\255\063\001\255\255\255\255\255\255\067\001\ -\068\001\255\255\060\001\255\255\013\001\073\001\074\001\255\255\ -\017\001\067\001\068\001\255\255\080\001\255\255\255\255\255\255\ -\074\001\026\001\027\001\028\001\029\001\000\000\080\001\255\255\ -\092\001\255\255\094\001\255\255\096\001\255\255\255\255\255\255\ -\041\001\255\255\092\001\255\255\255\255\255\255\096\001\255\255\ -\108\001\255\255\255\255\111\001\255\255\255\255\255\255\115\001\ -\255\255\000\001\108\001\060\001\003\001\111\001\063\001\255\255\ -\255\255\066\001\067\001\068\001\255\255\255\255\013\001\255\255\ -\073\001\074\001\017\001\255\255\255\255\255\255\255\255\080\001\ -\255\255\255\255\255\255\026\001\027\001\028\001\029\001\255\255\ -\255\255\255\255\255\255\092\001\255\255\094\001\255\255\096\001\ -\255\255\255\255\041\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\108\001\255\255\255\255\111\001\255\255\ -\255\255\255\255\115\001\255\255\255\255\060\001\255\255\255\255\ -\063\001\255\255\255\255\255\255\067\001\068\001\255\255\255\255\ -\255\255\255\255\073\001\074\001\055\001\255\255\057\001\058\001\ -\059\001\080\001\061\001\255\255\000\000\064\001\065\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\092\001\255\255\094\001\ -\255\255\096\001\255\255\255\255\255\255\255\255\081\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\108\001\089\001\090\001\ -\111\001\255\255\000\001\255\255\115\001\003\001\097\001\005\001\ -\006\001\007\001\008\001\255\255\255\255\011\001\012\001\013\001\ -\255\255\255\255\109\001\110\001\255\255\019\001\255\255\255\255\ -\255\255\023\001\255\255\255\255\026\001\255\255\028\001\029\001\ -\030\001\031\001\032\001\033\001\034\001\035\001\036\001\255\255\ -\255\255\039\001\040\001\041\001\255\255\255\255\000\000\255\255\ -\255\255\255\255\048\001\049\001\050\001\051\001\052\001\053\001\ -\054\001\055\001\056\001\057\001\058\001\059\001\060\001\061\001\ -\255\255\063\001\064\001\065\001\255\255\067\001\068\001\069\001\ -\070\001\071\001\072\001\255\255\074\001\075\001\255\255\077\001\ -\078\001\255\255\080\001\081\001\255\255\255\255\084\001\085\001\ -\255\255\087\001\088\001\089\001\090\001\091\001\092\001\093\001\ -\255\255\095\001\096\001\097\001\255\255\099\001\255\255\101\001\ -\102\001\255\255\104\001\255\255\106\001\107\001\108\001\109\001\ -\110\001\111\001\112\001\000\000\114\001\000\001\255\255\255\255\ -\255\255\004\001\255\255\006\001\255\255\008\001\255\255\010\001\ -\255\255\012\001\255\255\014\001\015\001\255\255\017\001\018\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\027\001\028\001\255\255\030\001\031\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\ -\051\001\052\001\053\001\255\255\055\001\056\001\255\255\255\255\ -\059\001\000\000\255\255\255\255\255\255\064\001\065\001\066\001\ -\255\255\255\255\255\255\255\255\071\001\255\255\073\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\081\001\255\255\ -\255\255\084\001\255\255\255\255\255\255\255\255\089\001\255\255\ -\091\001\092\001\255\255\094\001\095\001\255\255\097\001\255\255\ -\255\255\255\255\101\001\255\255\255\255\104\001\255\255\106\001\ -\255\255\255\255\109\001\110\001\000\001\255\255\113\001\255\255\ -\004\001\255\255\006\001\000\000\008\001\255\255\010\001\255\255\ -\012\001\255\255\014\001\015\001\255\255\017\001\018\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\027\001\ -\255\255\255\255\030\001\031\001\255\255\255\255\255\255\255\255\ -\255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\050\001\051\001\ -\255\255\053\001\255\255\055\001\056\001\255\255\255\255\059\001\ -\255\255\255\255\255\255\255\255\064\001\065\001\066\001\255\255\ -\255\255\255\255\255\255\071\001\255\255\073\001\000\001\255\255\ -\255\255\003\001\255\255\255\255\255\255\081\001\008\001\255\255\ -\084\001\255\255\255\255\013\001\014\001\089\001\255\255\091\001\ -\092\001\019\001\094\001\095\001\022\001\097\001\255\255\255\255\ -\026\001\101\001\028\001\029\001\104\001\255\255\106\001\255\255\ -\255\255\109\001\110\001\255\255\255\255\113\001\255\255\041\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\055\001\ -\000\000\057\001\058\001\059\001\255\255\061\001\255\255\255\255\ -\064\001\065\001\060\001\255\255\255\255\063\001\255\255\065\001\ -\066\001\067\001\068\001\000\001\255\255\255\255\003\001\255\255\ -\074\001\081\001\255\255\008\001\255\255\079\001\080\001\255\255\ -\013\001\089\001\090\001\255\255\255\255\255\255\019\001\255\255\ -\255\255\097\001\092\001\255\255\255\255\026\001\096\001\028\001\ -\029\001\255\255\255\255\255\255\255\255\109\001\110\001\255\255\ -\000\000\255\255\108\001\040\001\041\001\111\001\055\001\255\255\ -\057\001\058\001\059\001\255\255\061\001\255\255\255\255\064\001\ -\065\001\255\255\255\255\255\255\255\255\255\255\255\255\060\001\ -\255\255\000\001\063\001\255\255\003\001\066\001\067\001\068\001\ -\081\001\008\001\255\255\255\255\073\001\074\001\013\001\255\255\ -\089\001\090\001\255\255\080\001\019\001\255\255\255\255\255\255\ -\097\001\255\255\255\255\026\001\255\255\028\001\029\001\092\001\ -\000\000\255\255\255\255\096\001\109\001\110\001\255\255\100\001\ -\255\255\040\001\041\001\255\255\255\255\255\255\255\255\108\001\ -\255\255\255\255\111\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\000\001\255\255\060\001\003\001\255\255\ -\063\001\255\255\255\255\066\001\067\001\068\001\255\255\255\255\ -\013\001\255\255\073\001\074\001\255\255\255\255\019\001\255\255\ -\255\255\080\001\255\255\255\255\255\255\026\001\255\255\028\001\ -\029\001\000\001\000\000\255\255\003\001\092\001\255\255\255\255\ -\255\255\096\001\255\255\040\001\041\001\255\255\013\001\255\255\ -\255\255\255\255\017\001\048\001\049\001\108\001\255\255\255\255\ -\111\001\255\255\255\255\026\001\027\001\028\001\029\001\060\001\ -\255\255\255\255\063\001\255\255\255\255\255\255\255\255\068\001\ -\255\255\070\001\041\001\255\255\255\255\074\001\255\255\255\255\ -\255\255\255\255\055\001\080\001\057\001\058\001\059\001\255\255\ -\061\001\255\255\000\000\064\001\065\001\060\001\255\255\092\001\ -\063\001\255\255\255\255\096\001\067\001\068\001\255\255\255\255\ -\255\255\255\255\006\001\074\001\081\001\255\255\255\255\108\001\ -\012\001\080\001\111\001\255\255\089\001\090\001\255\255\255\255\ -\000\001\255\255\255\255\003\001\097\001\092\001\255\255\094\001\ -\008\001\096\001\030\001\031\001\255\255\013\001\255\255\255\255\ -\109\001\110\001\255\255\019\001\255\255\108\001\255\255\000\000\ -\111\001\255\255\026\001\255\255\028\001\029\001\050\001\255\255\ -\052\001\053\001\255\255\055\001\056\001\255\255\255\255\059\001\ -\255\255\041\001\255\255\255\255\064\001\065\001\255\255\255\255\ -\255\255\255\255\255\255\071\001\255\255\255\255\255\255\255\255\ -\000\001\255\255\255\255\003\001\060\001\255\255\255\255\063\001\ -\084\001\255\255\066\001\067\001\068\001\013\001\255\255\255\255\ -\255\255\017\001\074\001\255\255\000\000\097\001\255\255\255\255\ -\080\001\101\001\026\001\027\001\028\001\029\001\106\001\255\255\ -\255\255\109\001\110\001\255\255\092\001\255\255\255\255\255\255\ -\096\001\041\001\255\255\000\000\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\108\001\255\255\255\255\111\001\ -\000\001\255\255\255\255\003\001\060\001\255\255\255\255\063\001\ -\255\255\255\255\255\255\067\001\068\001\013\001\255\255\255\255\ -\255\255\000\000\074\001\019\001\255\255\255\255\255\255\255\255\ -\080\001\255\255\026\001\255\255\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\092\001\255\255\094\001\255\255\ -\096\001\041\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\048\001\255\255\255\255\255\255\108\001\255\255\255\255\111\001\ -\255\255\255\255\000\001\255\255\060\001\003\001\255\255\063\001\ -\255\255\255\255\255\255\067\001\068\001\255\255\070\001\013\001\ -\255\255\000\000\074\001\255\255\255\255\019\001\255\255\255\255\ -\080\001\255\255\255\255\255\255\026\001\255\255\028\001\029\001\ -\255\255\255\255\255\255\255\255\092\001\255\255\255\255\255\255\ -\096\001\255\255\255\255\041\001\255\255\255\255\255\255\000\000\ -\255\255\255\255\255\255\255\255\108\001\255\255\255\255\111\001\ -\255\255\255\255\000\001\255\255\255\255\003\001\060\001\255\255\ -\255\255\063\001\008\001\255\255\255\255\067\001\068\001\013\001\ -\255\255\255\255\255\255\255\255\074\001\019\001\255\255\255\255\ -\255\255\255\255\080\001\255\255\026\001\255\255\028\001\029\001\ -\086\001\255\255\255\255\255\255\255\255\255\255\092\001\255\255\ -\255\255\255\255\096\001\041\001\255\255\255\255\255\255\000\000\ -\255\255\255\255\255\255\255\255\255\255\255\255\108\001\000\001\ -\255\255\111\001\003\001\255\255\255\255\255\255\060\001\255\255\ -\000\000\063\001\255\255\255\255\013\001\067\001\068\001\255\255\ -\255\255\255\255\019\001\255\255\074\001\255\255\255\255\255\255\ -\255\255\026\001\080\001\028\001\029\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\092\001\255\255\ -\041\001\255\255\096\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\000\001\255\255\108\001\003\001\ -\255\255\111\001\255\255\060\001\255\255\255\255\063\001\255\255\ -\000\000\013\001\067\001\068\001\255\255\255\255\255\255\019\001\ -\255\255\074\001\255\255\000\001\255\255\255\255\026\001\080\001\ -\028\001\029\001\255\255\008\001\255\255\000\000\255\255\255\255\ -\013\001\255\255\255\255\092\001\255\255\041\001\000\000\096\001\ -\255\255\255\255\255\255\255\255\255\255\026\001\255\255\028\001\ -\029\001\000\001\255\255\108\001\003\001\255\255\111\001\255\255\ -\060\001\255\255\255\255\063\001\041\001\255\255\013\001\067\001\ -\068\001\255\255\255\255\255\255\019\001\255\255\074\001\255\255\ -\255\255\000\000\255\255\026\001\080\001\028\001\029\001\060\001\ -\255\255\255\255\063\001\255\255\255\255\066\001\067\001\068\001\ -\092\001\255\255\041\001\255\255\096\001\074\001\000\000\255\255\ -\255\255\255\255\255\255\080\001\255\255\255\255\255\255\255\255\ -\108\001\000\001\255\255\111\001\003\001\060\001\255\255\092\001\ -\063\001\255\255\255\255\096\001\067\001\068\001\013\001\255\255\ -\255\255\255\255\255\255\074\001\019\001\255\255\255\255\108\001\ -\255\255\080\001\111\001\026\001\255\255\028\001\029\001\000\001\ -\255\255\255\255\003\001\255\255\255\255\092\001\255\255\255\255\ -\255\255\096\001\041\001\255\255\013\001\255\255\255\255\255\255\ -\255\255\255\255\019\001\255\255\255\255\108\001\255\255\255\255\ -\111\001\026\001\255\255\028\001\029\001\060\001\255\255\255\255\ -\063\001\255\255\255\255\255\255\067\001\068\001\255\255\255\255\ -\041\001\255\255\255\255\074\001\255\255\255\255\255\255\255\255\ -\255\255\080\001\255\255\255\255\255\255\255\255\255\255\000\001\ -\255\255\255\255\003\001\060\001\255\255\092\001\063\001\255\255\ -\255\255\096\001\067\001\068\001\013\001\255\255\255\255\255\255\ -\000\001\074\001\019\001\255\255\255\255\108\001\255\255\080\001\ -\111\001\026\001\255\255\028\001\029\001\013\001\255\255\255\255\ -\255\255\255\255\255\255\092\001\255\255\255\255\255\255\096\001\ -\041\001\255\255\026\001\255\255\028\001\029\001\255\255\255\255\ -\255\255\255\255\255\255\108\001\255\255\255\255\111\001\255\255\ -\255\255\041\001\255\255\060\001\255\255\255\255\063\001\255\255\ -\255\255\255\255\067\001\068\001\255\255\255\255\255\255\255\255\ -\000\001\074\001\255\255\255\255\060\001\255\255\255\255\080\001\ -\255\255\255\255\066\001\067\001\068\001\013\001\255\255\255\255\ -\255\255\255\255\074\001\092\001\255\255\000\001\255\255\096\001\ -\080\001\255\255\026\001\255\255\028\001\029\001\000\001\255\255\ -\255\255\255\255\013\001\108\001\092\001\255\255\111\001\255\255\ -\096\001\041\001\255\255\013\001\255\255\255\255\255\255\026\001\ -\255\255\028\001\029\001\255\255\108\001\255\255\255\255\111\001\ -\026\001\255\255\028\001\029\001\060\001\255\255\041\001\063\001\ -\255\255\000\001\255\255\255\255\068\001\255\255\255\255\041\001\ -\255\255\255\255\074\001\255\255\255\255\255\255\013\001\255\255\ -\080\001\060\001\255\255\255\255\063\001\255\255\000\001\255\255\ -\255\255\068\001\060\001\026\001\092\001\028\001\029\001\074\001\ -\096\001\255\255\068\001\013\001\255\255\080\001\255\255\255\255\ -\074\001\255\255\041\001\255\255\108\001\255\255\080\001\111\001\ -\026\001\092\001\028\001\029\001\255\255\096\001\255\255\255\255\ -\255\255\255\255\092\001\255\255\255\255\060\001\096\001\041\001\ -\255\255\108\001\255\255\255\255\111\001\068\001\255\255\255\255\ -\255\255\255\255\108\001\074\001\255\255\111\001\255\255\255\255\ -\255\255\080\001\060\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\068\001\255\255\255\255\092\001\255\255\255\255\ -\074\001\096\001\255\255\255\255\255\255\255\255\080\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\108\001\255\255\255\255\ -\111\001\255\255\092\001\000\001\255\255\255\255\096\001\255\255\ -\005\001\006\001\007\001\008\001\255\255\255\255\011\001\012\001\ -\013\001\014\001\108\001\255\255\255\255\111\001\019\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\026\001\255\255\028\001\ -\029\001\030\001\031\001\032\001\033\001\034\001\035\001\255\255\ -\255\255\255\255\039\001\255\255\041\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\049\001\050\001\051\001\052\001\ -\053\001\054\001\055\001\056\001\255\255\255\255\059\001\060\001\ -\255\255\255\255\063\001\064\001\065\001\066\001\255\255\068\001\ -\069\001\070\001\071\001\072\001\255\255\074\001\255\255\255\255\ -\077\001\078\001\255\255\080\001\081\001\255\255\255\255\084\001\ -\085\001\255\255\087\001\255\255\089\001\090\001\255\255\092\001\ -\093\001\255\255\255\255\096\001\097\001\255\255\099\001\255\255\ -\101\001\102\001\255\255\104\001\255\255\106\001\107\001\108\001\ -\109\001\110\001\111\001\112\001\000\001\114\001\255\255\255\255\ -\255\255\005\001\006\001\007\001\008\001\255\255\255\255\011\001\ -\012\001\255\255\255\255\255\255\255\255\255\255\255\255\019\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\026\001\255\255\ -\028\001\255\255\030\001\031\001\032\001\033\001\034\001\035\001\ -\255\255\255\255\255\255\039\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\049\001\050\001\051\001\ -\052\001\053\001\054\001\055\001\056\001\255\255\255\255\059\001\ -\060\001\255\255\255\255\063\001\064\001\065\001\255\255\255\255\ -\068\001\069\001\070\001\071\001\072\001\255\255\074\001\255\255\ -\255\255\077\001\078\001\255\255\255\255\081\001\255\255\255\255\ -\084\001\085\001\255\255\087\001\255\255\089\001\090\001\255\255\ -\255\255\093\001\255\255\255\255\255\255\097\001\255\255\099\001\ -\255\255\101\001\102\001\255\255\104\001\255\255\106\001\107\001\ -\255\255\109\001\110\001\111\001\112\001\255\255\114\001\000\001\ -\001\001\002\001\255\255\255\255\005\001\006\001\007\001\255\255\ -\009\001\255\255\011\001\012\001\255\255\255\255\015\001\016\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\027\001\255\255\255\255\030\001\031\001\032\001\ -\033\001\034\001\255\255\036\001\255\255\255\255\039\001\255\255\ -\255\255\042\001\043\001\044\001\045\001\046\001\047\001\255\255\ -\255\255\050\001\255\255\052\001\053\001\054\001\055\001\056\001\ -\255\255\255\255\059\001\255\255\061\001\255\255\063\001\064\001\ -\065\001\255\255\255\255\255\255\069\001\255\255\071\001\072\001\ -\255\255\074\001\255\255\255\255\255\255\078\001\255\255\255\255\ -\255\255\082\001\083\001\084\001\085\001\086\001\087\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\094\001\255\255\255\255\ -\255\255\098\001\255\255\100\001\101\001\255\255\255\255\255\255\ -\255\255\106\001\107\001\255\255\109\001\110\001\000\001\001\001\ -\002\001\114\001\255\255\005\001\006\001\007\001\255\255\009\001\ -\255\255\011\001\012\001\255\255\255\255\015\001\016\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\027\001\255\255\255\255\030\001\031\001\032\001\033\001\ -\034\001\255\255\036\001\255\255\255\255\039\001\255\255\255\255\ -\042\001\043\001\044\001\045\001\046\001\047\001\255\255\255\255\ -\050\001\255\255\052\001\053\001\054\001\055\001\056\001\255\255\ -\255\255\059\001\255\255\061\001\255\255\063\001\064\001\065\001\ -\255\255\255\255\255\255\069\001\255\255\071\001\072\001\255\255\ -\074\001\255\255\255\255\255\255\078\001\255\255\255\255\255\255\ -\082\001\083\001\084\001\085\001\086\001\087\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\094\001\255\255\255\255\255\255\ -\098\001\255\255\100\001\101\001\255\255\255\255\255\255\255\255\ -\106\001\107\001\255\255\109\001\110\001\000\001\255\255\255\255\ -\114\001\255\255\005\001\006\001\007\001\255\255\255\255\255\255\ -\011\001\012\001\013\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\026\001\ -\255\255\028\001\029\001\030\001\031\001\032\001\033\001\034\001\ -\255\255\255\255\255\255\255\255\039\001\255\255\041\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\ -\255\255\052\001\053\001\054\001\055\001\056\001\255\255\255\255\ -\059\001\060\001\255\255\255\255\063\001\064\001\065\001\255\255\ -\255\255\068\001\069\001\255\255\071\001\072\001\255\255\074\001\ -\255\255\255\255\255\255\078\001\255\255\080\001\255\255\255\255\ -\255\255\084\001\085\001\000\001\087\001\255\255\255\255\255\255\ -\005\001\006\001\007\001\255\255\255\255\096\001\011\001\012\001\ -\255\255\255\255\101\001\255\255\255\255\255\255\255\255\106\001\ -\107\001\108\001\109\001\110\001\111\001\255\255\255\255\114\001\ -\255\255\030\001\031\001\032\001\033\001\034\001\255\255\255\255\ -\255\255\255\255\039\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\ -\053\001\054\001\055\001\056\001\255\255\255\255\059\001\255\255\ -\255\255\255\255\063\001\064\001\065\001\255\255\255\255\255\255\ -\069\001\255\255\071\001\072\001\255\255\255\255\255\255\255\255\ -\255\255\078\001\255\255\255\255\255\255\255\255\255\255\084\001\ -\085\001\000\001\087\001\255\255\255\255\255\255\005\001\006\001\ -\007\001\094\001\255\255\255\255\011\001\012\001\255\255\255\255\ -\101\001\255\255\255\255\255\255\255\255\106\001\107\001\255\255\ -\109\001\110\001\255\255\255\255\255\255\114\001\255\255\030\001\ -\031\001\032\001\033\001\034\001\255\255\255\255\255\255\255\255\ -\039\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\050\001\255\255\052\001\053\001\054\001\ -\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\ -\063\001\064\001\065\001\255\255\255\255\255\255\069\001\255\255\ -\071\001\072\001\255\255\255\255\255\255\255\255\255\255\078\001\ -\255\255\255\255\255\255\255\255\255\255\084\001\085\001\000\001\ -\087\001\255\255\255\255\255\255\005\001\006\001\007\001\094\001\ -\255\255\255\255\011\001\012\001\255\255\255\255\101\001\255\255\ -\255\255\255\255\255\255\106\001\107\001\255\255\109\001\110\001\ -\255\255\255\255\255\255\114\001\255\255\030\001\031\001\032\001\ -\033\001\034\001\255\255\255\255\255\255\255\255\039\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\050\001\255\255\052\001\053\001\054\001\055\001\056\001\ -\255\255\255\255\059\001\255\255\255\255\255\255\063\001\064\001\ -\065\001\255\255\255\255\255\255\069\001\255\255\071\001\072\001\ -\255\255\255\255\255\255\255\255\255\255\078\001\255\255\255\255\ -\255\255\255\255\255\255\084\001\085\001\000\001\087\001\255\255\ -\255\255\255\255\005\001\006\001\007\001\094\001\255\255\255\255\ -\011\001\012\001\255\255\255\255\101\001\255\255\255\255\255\255\ -\255\255\106\001\107\001\255\255\109\001\110\001\255\255\255\255\ -\255\255\114\001\255\255\030\001\031\001\032\001\033\001\034\001\ -\255\255\255\255\255\255\255\255\039\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\ -\255\255\052\001\053\001\054\001\055\001\056\001\255\255\255\255\ -\059\001\255\255\255\255\255\255\063\001\064\001\065\001\255\255\ -\255\255\255\255\069\001\255\255\071\001\072\001\255\255\255\255\ -\255\255\255\255\255\255\078\001\255\255\255\255\255\255\255\255\ -\255\255\084\001\085\001\255\255\087\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\094\001\003\001\004\001\005\001\255\255\ -\255\255\255\255\101\001\255\255\011\001\255\255\013\001\106\001\ -\107\001\255\255\109\001\110\001\019\001\020\001\021\001\114\001\ -\255\255\024\001\025\001\026\001\255\255\028\001\029\001\030\001\ -\255\255\032\001\033\001\034\001\035\001\255\255\255\255\255\255\ -\039\001\040\001\041\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\048\001\049\001\255\255\255\255\052\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\063\001\064\001\255\255\255\255\255\255\000\001\069\001\070\001\ -\255\255\004\001\255\255\074\001\075\001\076\001\077\001\078\001\ -\079\001\080\001\255\255\082\001\255\255\255\255\017\001\255\255\ -\019\001\088\001\255\255\022\001\255\255\255\255\093\001\026\001\ -\027\001\255\255\255\255\255\255\099\001\255\255\255\255\102\001\ -\103\001\036\001\105\001\106\001\107\001\108\001\109\001\255\255\ -\111\001\112\001\113\001\114\001\115\001\048\001\049\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\060\001\255\255\255\255\255\255\064\001\255\255\066\001\ -\067\001\068\001\255\255\070\001\255\255\255\255\073\001\255\255\ -\255\255\255\255\000\001\001\001\002\001\255\255\255\255\255\255\ -\006\001\007\001\255\255\009\001\255\255\255\255\012\001\090\001\ -\091\001\015\001\016\001\255\255\095\001\255\255\097\001\255\255\ -\255\255\100\001\255\255\255\255\255\255\027\001\028\001\255\255\ -\030\001\031\001\109\001\255\255\111\001\255\255\036\001\255\255\ -\255\255\255\255\255\255\255\255\042\001\043\001\044\001\045\001\ -\046\001\047\001\255\255\255\255\050\001\255\255\052\001\053\001\ -\255\255\055\001\056\001\255\255\255\255\059\001\255\255\061\001\ -\255\255\255\255\064\001\065\001\255\255\255\255\255\255\255\255\ -\255\255\071\001\072\001\255\255\074\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\082\001\083\001\084\001\085\001\ -\086\001\087\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\094\001\255\255\255\255\097\001\098\001\255\255\100\001\101\001\ -\255\255\255\255\255\255\255\255\106\001\255\255\108\001\109\001\ -\110\001\000\001\001\001\002\001\255\255\255\255\255\255\006\001\ -\007\001\255\255\009\001\255\255\255\255\012\001\255\255\255\255\ -\015\001\016\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\027\001\028\001\255\255\030\001\ -\031\001\255\255\255\255\255\255\255\255\036\001\255\255\255\255\ -\255\255\255\255\255\255\042\001\043\001\044\001\045\001\046\001\ -\047\001\255\255\255\255\050\001\255\255\052\001\053\001\255\255\ -\055\001\056\001\255\255\255\255\059\001\255\255\061\001\255\255\ -\255\255\064\001\065\001\255\255\255\255\255\255\255\255\255\255\ -\071\001\072\001\255\255\074\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\082\001\083\001\084\001\085\001\086\001\ -\087\001\255\255\255\255\255\255\255\255\255\255\255\255\094\001\ -\255\255\255\255\097\001\098\001\255\255\100\001\101\001\255\255\ -\255\255\255\255\255\255\106\001\255\255\108\001\109\001\110\001\ -\000\001\001\001\002\001\255\255\255\255\255\255\006\001\007\001\ -\255\255\009\001\255\255\255\255\012\001\255\255\255\255\015\001\ -\016\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\027\001\028\001\255\255\030\001\031\001\ -\255\255\255\255\255\255\255\255\036\001\255\255\255\255\255\255\ -\255\255\255\255\042\001\043\001\044\001\045\001\046\001\047\001\ -\255\255\255\255\050\001\255\255\052\001\053\001\255\255\055\001\ -\056\001\255\255\255\255\059\001\255\255\061\001\255\255\255\255\ -\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\ -\072\001\255\255\074\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\082\001\083\001\084\001\085\001\086\001\087\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\094\001\255\255\ -\255\255\097\001\098\001\255\255\100\001\101\001\255\255\255\255\ -\255\255\255\255\106\001\255\255\108\001\109\001\110\001\000\001\ -\001\001\002\001\255\255\255\255\255\255\006\001\007\001\255\255\ -\009\001\255\255\255\255\012\001\255\255\255\255\015\001\016\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\027\001\028\001\255\255\030\001\031\001\255\255\ -\255\255\255\255\255\255\036\001\255\255\255\255\255\255\255\255\ -\255\255\042\001\043\001\044\001\045\001\046\001\047\001\255\255\ -\255\255\050\001\255\255\052\001\053\001\255\255\055\001\056\001\ -\255\255\255\255\059\001\255\255\061\001\255\255\255\255\064\001\ -\065\001\255\255\255\255\255\255\255\255\255\255\071\001\072\001\ -\255\255\074\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\082\001\083\001\084\001\085\001\086\001\087\001\255\255\ -\255\255\000\001\255\255\255\255\255\255\094\001\255\255\006\001\ -\097\001\098\001\255\255\100\001\101\001\012\001\255\255\255\255\ -\015\001\106\001\255\255\255\255\109\001\110\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\028\001\255\255\030\001\ -\031\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\050\001\255\255\052\001\053\001\255\255\ -\055\001\056\001\255\255\255\255\059\001\255\255\000\001\255\255\ -\255\255\064\001\065\001\255\255\006\001\255\255\255\255\255\255\ -\071\001\255\255\012\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\084\001\255\255\255\255\ -\255\255\255\255\028\001\255\255\030\001\031\001\255\255\094\001\ -\255\255\255\255\097\001\255\255\255\255\255\255\101\001\255\255\ -\255\255\255\255\255\255\106\001\255\255\255\255\109\001\110\001\ -\050\001\255\255\052\001\053\001\255\255\055\001\056\001\255\255\ -\255\255\059\001\255\255\000\001\255\255\255\255\064\001\065\001\ -\255\255\006\001\255\255\255\255\255\255\071\001\255\255\012\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\084\001\255\255\255\255\255\255\255\255\028\001\ -\255\255\030\001\031\001\255\255\255\255\255\255\255\255\097\001\ -\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\ -\106\001\255\255\255\255\109\001\110\001\050\001\255\255\052\001\ -\053\001\255\255\055\001\056\001\255\255\255\255\059\001\255\255\ -\000\001\255\255\255\255\064\001\065\001\255\255\006\001\255\255\ -\255\255\255\255\071\001\255\255\012\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\084\001\ -\255\255\255\255\255\255\255\255\028\001\255\255\030\001\031\001\ -\255\255\255\255\255\255\255\255\097\001\255\255\255\255\255\255\ -\101\001\255\255\255\255\255\255\255\255\106\001\255\255\255\255\ -\109\001\110\001\050\001\255\255\052\001\053\001\255\255\055\001\ -\056\001\255\255\255\255\059\001\255\255\000\001\255\255\255\255\ -\064\001\065\001\255\255\006\001\255\255\255\255\255\255\071\001\ -\255\255\012\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\084\001\255\255\255\255\255\255\ -\255\255\028\001\255\255\030\001\031\001\255\255\255\255\255\255\ -\255\255\097\001\255\255\255\255\255\255\101\001\255\255\255\255\ -\255\255\255\255\106\001\255\255\255\255\109\001\110\001\050\001\ -\255\255\052\001\053\001\255\255\055\001\056\001\255\255\255\255\ -\059\001\255\255\000\001\255\255\255\255\064\001\065\001\255\255\ -\006\001\255\255\255\255\255\255\071\001\255\255\012\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\084\001\255\255\255\255\255\255\255\255\028\001\255\255\ -\030\001\031\001\255\255\255\255\255\255\255\255\097\001\255\255\ -\255\255\255\255\101\001\255\255\255\255\255\255\255\255\106\001\ -\255\255\255\255\109\001\110\001\050\001\255\255\052\001\053\001\ -\255\255\055\001\056\001\255\255\255\255\059\001\255\255\255\255\ -\255\255\255\255\064\001\065\001\005\001\006\001\007\001\255\255\ -\255\255\071\001\011\001\012\001\013\001\014\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\084\001\255\255\ -\255\255\255\255\255\255\028\001\029\001\030\001\031\001\032\001\ -\033\001\034\001\255\255\097\001\255\255\255\255\039\001\101\001\ -\041\001\255\255\255\255\255\255\106\001\255\255\255\255\109\001\ -\110\001\050\001\255\255\052\001\053\001\054\001\055\001\056\001\ -\255\255\255\255\059\001\060\001\255\255\255\255\063\001\064\001\ -\065\001\255\255\255\255\068\001\069\001\255\255\071\001\072\001\ -\255\255\074\001\255\255\255\255\255\255\078\001\255\255\080\001\ -\255\255\255\255\255\255\084\001\085\001\255\255\087\001\255\255\ -\089\001\255\255\255\255\005\001\006\001\007\001\255\255\096\001\ -\255\255\011\001\012\001\013\001\101\001\255\255\255\255\255\255\ -\255\255\106\001\107\001\108\001\109\001\110\001\111\001\255\255\ -\255\255\114\001\028\001\029\001\030\001\031\001\032\001\033\001\ -\034\001\255\255\255\255\255\255\255\255\039\001\255\255\041\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\050\001\255\255\052\001\053\001\054\001\055\001\056\001\255\255\ -\255\255\059\001\060\001\255\255\255\255\063\001\064\001\065\001\ -\255\255\255\255\068\001\069\001\255\255\071\001\072\001\255\255\ -\074\001\255\255\255\255\255\255\078\001\255\255\080\001\255\255\ -\255\255\255\255\084\001\085\001\255\255\087\001\255\255\255\255\ -\255\255\005\001\006\001\007\001\255\255\255\255\096\001\011\001\ -\012\001\255\255\255\255\101\001\255\255\255\255\255\255\255\255\ -\106\001\107\001\108\001\109\001\110\001\111\001\255\255\255\255\ -\114\001\255\255\030\001\031\001\032\001\033\001\034\001\255\255\ -\255\255\255\255\255\255\039\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\050\001\255\255\ -\052\001\053\001\054\001\055\001\056\001\255\255\255\255\059\001\ -\255\255\255\255\255\255\063\001\064\001\065\001\255\255\255\255\ -\255\255\069\001\255\255\071\001\072\001\255\255\255\255\255\255\ -\255\255\255\255\078\001\255\255\255\255\255\255\255\255\255\255\ -\084\001\085\001\255\255\087\001\255\255\255\255\255\255\255\255\ -\092\001\005\001\006\001\007\001\255\255\255\255\010\001\011\001\ -\012\001\101\001\255\255\255\255\255\255\255\255\106\001\107\001\ -\255\255\109\001\110\001\255\255\255\255\255\255\114\001\255\255\ -\255\255\255\255\030\001\031\001\032\001\033\001\034\001\255\255\ -\255\255\255\255\255\255\039\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\050\001\255\255\ -\052\001\053\001\054\001\055\001\056\001\255\255\255\255\059\001\ -\255\255\255\255\255\255\063\001\064\001\065\001\255\255\255\255\ -\255\255\069\001\255\255\071\001\072\001\255\255\255\255\255\255\ -\255\255\255\255\078\001\255\255\255\255\255\255\255\255\255\255\ -\084\001\085\001\255\255\087\001\255\255\255\255\005\001\006\001\ -\007\001\255\255\255\255\255\255\011\001\012\001\255\255\255\255\ -\255\255\101\001\255\255\255\255\255\255\255\255\106\001\107\001\ -\255\255\109\001\110\001\026\001\255\255\255\255\114\001\030\001\ -\031\001\032\001\033\001\034\001\255\255\255\255\255\255\255\255\ -\039\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\050\001\255\255\052\001\053\001\054\001\ -\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\ -\063\001\064\001\065\001\255\255\255\255\255\255\069\001\255\255\ -\071\001\072\001\255\255\255\255\255\255\255\255\255\255\078\001\ -\255\255\255\255\255\255\255\255\255\255\084\001\085\001\255\255\ -\087\001\255\255\255\255\005\001\006\001\007\001\255\255\255\255\ -\255\255\011\001\012\001\255\255\255\255\255\255\101\001\255\255\ -\255\255\255\255\255\255\106\001\107\001\255\255\109\001\110\001\ -\255\255\255\255\255\255\114\001\030\001\031\001\032\001\033\001\ -\034\001\255\255\255\255\255\255\255\255\039\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\050\001\255\255\052\001\053\001\054\001\055\001\056\001\255\255\ -\255\255\059\001\255\255\255\255\255\255\063\001\064\001\065\001\ -\255\255\255\255\255\255\069\001\255\255\071\001\072\001\255\255\ -\255\255\255\255\255\255\255\255\078\001\255\255\255\255\255\255\ -\255\255\083\001\084\001\085\001\255\255\087\001\255\255\255\255\ -\005\001\006\001\007\001\255\255\255\255\255\255\011\001\012\001\ -\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\ -\106\001\107\001\255\255\109\001\110\001\255\255\255\255\255\255\ -\114\001\030\001\031\001\032\001\033\001\034\001\255\255\255\255\ -\255\255\255\255\039\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\ -\053\001\054\001\055\001\056\001\255\255\255\255\059\001\255\255\ -\255\255\255\255\063\001\064\001\065\001\255\255\255\255\255\255\ -\069\001\255\255\071\001\072\001\255\255\255\255\255\255\255\255\ -\255\255\078\001\255\255\255\255\255\255\255\255\255\255\084\001\ -\085\001\255\255\087\001\255\255\255\255\255\255\255\255\092\001\ -\005\001\006\001\007\001\255\255\255\255\010\001\011\001\012\001\ -\101\001\255\255\255\255\255\255\255\255\106\001\107\001\255\255\ -\109\001\110\001\255\255\255\255\255\255\114\001\255\255\255\255\ -\255\255\030\001\031\001\032\001\033\001\034\001\255\255\255\255\ -\255\255\255\255\039\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\ -\053\001\054\001\055\001\056\001\255\255\255\255\059\001\255\255\ -\255\255\255\255\063\001\064\001\065\001\255\255\255\255\255\255\ -\069\001\255\255\071\001\072\001\255\255\255\255\255\255\255\255\ -\255\255\078\001\255\255\255\255\255\255\255\255\255\255\084\001\ -\085\001\255\255\087\001\255\255\255\255\255\255\005\001\006\001\ -\007\001\255\255\255\255\255\255\011\001\012\001\255\255\255\255\ -\101\001\255\255\255\255\255\255\255\255\106\001\107\001\022\001\ -\109\001\110\001\255\255\255\255\255\255\114\001\255\255\030\001\ -\031\001\032\001\033\001\034\001\255\255\255\255\255\255\255\255\ -\039\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\050\001\255\255\052\001\053\001\054\001\ -\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\ -\063\001\064\001\065\001\255\255\255\255\255\255\069\001\255\255\ -\071\001\072\001\255\255\255\255\255\255\255\255\255\255\078\001\ -\255\255\255\255\255\255\255\255\255\255\084\001\085\001\255\255\ -\087\001\255\255\255\255\005\001\006\001\007\001\255\255\255\255\ -\255\255\011\001\012\001\255\255\255\255\255\255\101\001\255\255\ -\255\255\255\255\255\255\106\001\107\001\255\255\109\001\110\001\ -\026\001\255\255\255\255\114\001\030\001\031\001\032\001\033\001\ -\034\001\255\255\255\255\255\255\255\255\039\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\050\001\255\255\052\001\053\001\054\001\055\001\056\001\255\255\ -\255\255\059\001\255\255\255\255\255\255\063\001\064\001\065\001\ -\255\255\255\255\255\255\069\001\255\255\071\001\072\001\255\255\ -\255\255\255\255\255\255\255\255\078\001\255\255\255\255\255\255\ -\255\255\255\255\084\001\085\001\255\255\087\001\255\255\255\255\ -\005\001\006\001\007\001\255\255\255\255\255\255\011\001\012\001\ -\255\255\255\255\255\255\101\001\255\255\255\255\255\255\255\255\ -\106\001\107\001\255\255\109\001\110\001\255\255\255\255\255\255\ -\114\001\030\001\031\001\032\001\033\001\034\001\255\255\255\255\ -\255\255\255\255\039\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\050\001\255\255\052\001\ -\053\001\054\001\055\001\056\001\255\255\255\255\059\001\255\255\ -\255\255\255\255\063\001\064\001\065\001\255\255\255\255\255\255\ -\069\001\255\255\071\001\072\001\255\255\255\255\255\255\255\255\ -\255\255\078\001\255\255\255\255\255\255\255\255\255\255\084\001\ -\085\001\255\255\087\001\255\255\255\255\005\001\006\001\007\001\ -\255\255\255\255\255\255\011\001\012\001\255\255\255\255\255\255\ -\101\001\255\255\255\255\255\255\255\255\106\001\107\001\255\255\ -\109\001\110\001\255\255\255\255\255\255\114\001\030\001\031\001\ -\032\001\033\001\034\001\255\255\255\255\255\255\255\255\039\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\050\001\255\255\052\001\053\001\054\001\055\001\ -\056\001\255\255\255\255\059\001\255\255\255\255\255\255\063\001\ -\064\001\065\001\255\255\255\255\255\255\069\001\255\255\071\001\ -\072\001\255\255\255\255\255\255\255\255\255\255\078\001\255\255\ -\255\255\255\255\255\255\255\255\084\001\085\001\255\255\087\001\ -\255\255\255\255\005\001\006\001\007\001\255\255\255\255\255\255\ -\011\001\012\001\255\255\255\255\255\255\101\001\255\255\255\255\ -\255\255\255\255\106\001\107\001\255\255\109\001\110\001\255\255\ -\255\255\255\255\114\001\030\001\031\001\032\001\033\001\034\001\ -\255\255\255\255\255\255\255\255\039\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\050\001\ -\255\255\052\001\053\001\054\001\055\001\056\001\255\255\255\255\ -\059\001\255\255\255\255\255\255\063\001\064\001\065\001\255\255\ -\255\255\006\001\069\001\255\255\071\001\072\001\255\255\012\001\ -\255\255\014\001\255\255\078\001\017\001\255\255\255\255\255\255\ -\255\255\084\001\085\001\255\255\087\001\255\255\027\001\255\255\ -\255\255\030\001\031\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\101\001\255\255\255\255\255\255\255\255\106\001\ -\107\001\255\255\109\001\110\001\255\255\050\001\051\001\114\001\ -\053\001\255\255\055\001\056\001\255\255\255\255\059\001\255\255\ -\255\255\255\255\255\255\064\001\065\001\255\255\006\001\255\255\ -\255\255\255\255\071\001\255\255\012\001\255\255\014\001\255\255\ -\255\255\017\001\255\255\255\255\081\001\255\255\255\255\084\001\ -\255\255\255\255\255\255\027\001\089\001\255\255\030\001\031\001\ -\255\255\006\001\255\255\255\255\097\001\255\255\255\255\012\001\ -\101\001\014\001\255\255\104\001\255\255\106\001\255\255\255\255\ -\109\001\110\001\050\001\051\001\255\255\053\001\255\255\055\001\ -\056\001\030\001\031\001\059\001\255\255\255\255\255\255\255\255\ -\064\001\065\001\255\255\255\255\255\255\255\255\255\255\071\001\ -\255\255\255\255\255\255\255\255\255\255\050\001\051\001\255\255\ -\053\001\081\001\055\001\056\001\084\001\255\255\059\001\255\255\ -\255\255\089\001\255\255\064\001\065\001\255\255\255\255\255\255\ -\255\255\097\001\071\001\255\255\073\001\101\001\255\255\255\255\ -\104\001\255\255\106\001\255\255\081\001\109\001\110\001\084\001\ -\255\255\255\255\006\001\255\255\089\001\255\255\255\255\255\255\ -\012\001\255\255\014\001\255\255\097\001\255\255\255\255\255\255\ -\101\001\255\255\255\255\104\001\255\255\106\001\255\255\027\001\ -\109\001\110\001\030\001\031\001\255\255\006\001\255\255\255\255\ -\255\255\255\255\255\255\012\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\050\001\051\001\ -\255\255\053\001\255\255\055\001\056\001\030\001\031\001\059\001\ -\255\255\255\255\255\255\255\255\064\001\065\001\255\255\255\255\ -\255\255\255\255\255\255\071\001\255\255\255\255\255\255\255\255\ -\255\255\050\001\051\001\255\255\053\001\081\001\055\001\056\001\ -\084\001\255\255\059\001\255\255\255\255\089\001\255\255\064\001\ -\065\001\255\255\006\001\255\255\255\255\097\001\071\001\255\255\ -\012\001\101\001\255\255\255\255\104\001\255\255\106\001\255\255\ -\081\001\109\001\110\001\084\001\255\255\255\255\255\255\255\255\ -\089\001\255\255\030\001\031\001\255\255\255\255\255\255\255\255\ -\097\001\255\255\255\255\255\255\101\001\255\255\255\255\104\001\ -\255\255\106\001\255\255\255\255\109\001\110\001\050\001\051\001\ -\255\255\053\001\255\255\055\001\056\001\255\255\255\255\059\001\ -\255\255\255\255\255\255\255\255\064\001\065\001\255\255\255\255\ -\006\001\255\255\255\255\071\001\255\255\255\255\012\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\081\001\255\255\255\255\ -\084\001\255\255\255\255\255\255\255\255\089\001\028\001\255\255\ -\030\001\031\001\255\255\255\255\255\255\097\001\255\255\255\255\ -\255\255\101\001\255\255\255\255\104\001\255\255\106\001\255\255\ -\255\255\109\001\110\001\255\255\050\001\255\255\052\001\053\001\ -\255\255\055\001\056\001\255\255\255\255\059\001\255\255\255\255\ -\255\255\255\255\064\001\065\001\255\255\255\255\255\255\006\001\ -\255\255\071\001\255\255\010\001\255\255\012\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\084\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\028\001\092\001\030\001\ -\031\001\255\255\255\255\097\001\255\255\255\255\255\255\101\001\ -\255\255\255\255\255\255\255\255\106\001\255\255\255\255\109\001\ -\110\001\255\255\255\255\050\001\255\255\052\001\053\001\255\255\ -\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\ -\255\255\064\001\065\001\255\255\006\001\255\255\255\255\255\255\ -\071\001\255\255\012\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\006\001\007\001\255\255\255\255\084\001\011\001\012\001\ -\255\255\255\255\028\001\255\255\030\001\031\001\255\255\255\255\ -\255\255\255\255\097\001\255\255\255\255\255\255\101\001\255\255\ -\255\255\030\001\031\001\106\001\255\255\255\255\109\001\110\001\ -\050\001\255\255\052\001\053\001\255\255\055\001\056\001\255\255\ -\255\255\059\001\255\255\255\255\255\255\050\001\064\001\065\001\ -\053\001\054\001\055\001\056\001\255\255\071\001\059\001\255\255\ -\006\001\255\255\008\001\064\001\065\001\255\255\012\001\255\255\ -\255\255\255\255\084\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\092\001\255\255\255\255\255\255\028\001\097\001\ -\030\001\031\001\087\001\101\001\255\255\255\255\255\255\255\255\ -\106\001\255\255\255\255\109\001\110\001\255\255\255\255\255\255\ -\101\001\255\255\255\255\255\255\050\001\106\001\052\001\053\001\ -\109\001\055\001\056\001\255\255\255\255\059\001\255\255\255\255\ -\255\255\255\255\064\001\065\001\255\255\006\001\255\255\255\255\ -\255\255\071\001\255\255\012\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\084\001\255\255\ -\255\255\255\255\255\255\028\001\255\255\030\001\031\001\255\255\ -\255\255\255\255\255\255\097\001\255\255\255\255\255\255\101\001\ -\255\255\255\255\255\255\255\255\106\001\255\255\255\255\109\001\ -\110\001\050\001\255\255\052\001\053\001\255\255\055\001\056\001\ -\255\255\255\255\059\001\255\255\255\255\255\255\255\255\064\001\ -\065\001\255\255\006\001\255\255\255\255\255\255\071\001\255\255\ -\012\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\084\001\255\255\255\255\255\255\255\255\ -\028\001\255\255\030\001\031\001\255\255\006\001\255\255\255\255\ -\097\001\255\255\255\255\012\001\101\001\255\255\255\255\255\255\ -\255\255\106\001\255\255\255\255\109\001\110\001\050\001\255\255\ -\052\001\053\001\255\255\055\001\056\001\030\001\031\001\059\001\ -\255\255\255\255\255\255\255\255\064\001\065\001\255\255\255\255\ -\255\255\255\255\255\255\071\001\255\255\255\255\255\255\255\255\ -\255\255\050\001\255\255\052\001\053\001\255\255\055\001\056\001\ -\084\001\255\255\059\001\255\255\255\255\255\255\255\255\064\001\ -\065\001\255\255\006\001\255\255\255\255\097\001\071\001\255\255\ -\012\001\101\001\255\255\255\255\255\255\255\255\106\001\255\255\ -\255\255\109\001\110\001\084\001\255\255\255\255\255\255\255\255\ -\028\001\255\255\030\001\031\001\093\001\006\001\255\255\255\255\ -\097\001\255\255\255\255\012\001\101\001\255\255\255\255\255\255\ -\255\255\106\001\255\255\255\255\109\001\110\001\050\001\255\255\ -\052\001\053\001\255\255\055\001\056\001\030\001\031\001\059\001\ -\255\255\255\255\255\255\255\255\064\001\065\001\255\255\255\255\ -\255\255\255\255\255\255\071\001\255\255\255\255\255\255\255\255\ -\255\255\050\001\255\255\052\001\053\001\255\255\055\001\056\001\ -\084\001\255\255\059\001\255\255\255\255\255\255\255\255\064\001\ -\065\001\255\255\006\001\255\255\255\255\097\001\071\001\255\255\ -\012\001\101\001\255\255\255\255\255\255\255\255\106\001\255\255\ -\255\255\109\001\110\001\084\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\030\001\031\001\255\255\006\001\255\255\255\255\ -\097\001\255\255\255\255\012\001\101\001\255\255\255\255\255\255\ -\255\255\106\001\255\255\255\255\109\001\110\001\050\001\255\255\ -\052\001\053\001\255\255\055\001\056\001\030\001\031\001\059\001\ -\255\255\255\255\255\255\255\255\064\001\065\001\255\255\255\255\ -\255\255\255\255\255\255\071\001\255\255\255\255\255\255\255\255\ -\255\255\050\001\255\255\255\255\053\001\255\255\055\001\056\001\ -\084\001\255\255\059\001\255\255\255\255\255\255\255\255\064\001\ -\065\001\255\255\006\001\255\255\255\255\097\001\071\001\255\255\ -\012\001\101\001\255\255\255\255\255\255\255\255\106\001\255\255\ -\255\255\109\001\110\001\084\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\030\001\031\001\255\255\255\255\255\255\255\255\ -\097\001\255\255\255\255\255\255\101\001\255\255\255\255\255\255\ -\255\255\106\001\255\255\255\255\109\001\110\001\050\001\255\255\ -\255\255\053\001\255\255\055\001\056\001\255\255\255\255\059\001\ -\255\255\255\255\255\255\255\255\064\001\065\001\255\255\006\001\ -\007\001\255\255\255\255\071\001\011\001\012\001\006\001\007\001\ -\255\255\255\255\255\255\011\001\012\001\255\255\255\255\022\001\ -\084\001\255\255\255\255\255\255\255\255\255\255\255\255\030\001\ -\031\001\255\255\255\255\255\255\255\255\097\001\030\001\031\001\ -\255\255\101\001\255\255\255\255\255\255\255\255\106\001\255\255\ -\047\001\109\001\110\001\050\001\051\001\255\255\053\001\054\001\ -\055\001\056\001\050\001\051\001\059\001\053\001\054\001\055\001\ -\056\001\064\001\065\001\059\001\255\255\255\255\255\255\255\255\ -\064\001\065\001\255\255\255\255\255\255\255\255\255\255\006\001\ -\007\001\255\255\081\001\255\255\011\001\012\001\255\255\255\255\ -\087\001\081\001\089\001\255\255\255\255\255\255\255\255\087\001\ -\255\255\089\001\097\001\098\001\255\255\255\255\101\001\030\001\ -\031\001\104\001\255\255\106\001\255\255\101\001\109\001\255\255\ -\104\001\255\255\106\001\255\255\255\255\109\001\255\255\255\255\ -\255\255\255\255\255\255\050\001\255\255\255\255\053\001\054\001\ -\055\001\056\001\255\255\255\255\059\001\255\255\255\255\255\255\ -\255\255\064\001\065\001\255\255\255\255\000\001\001\001\002\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\009\001\255\255\ -\255\255\255\255\255\255\014\001\015\001\016\001\017\001\018\001\ -\087\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\027\001\255\255\255\255\255\255\255\255\255\255\101\001\255\255\ -\255\255\036\001\255\255\106\001\255\255\255\255\109\001\042\001\ -\043\001\044\001\045\001\046\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\061\001\255\255\015\001\255\255\255\255\066\001\ -\255\255\255\255\255\255\255\255\071\001\072\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\082\001\ -\083\001\084\001\085\001\086\001\255\255\000\001\001\001\002\001\ -\255\255\255\255\255\255\094\001\007\001\255\255\009\001\255\255\ -\255\255\100\001\255\255\255\255\055\001\016\001\057\001\058\001\ -\059\001\255\255\061\001\255\255\255\255\064\001\065\001\255\255\ -\027\001\255\255\255\255\255\255\255\255\255\255\255\255\074\001\ -\255\255\036\001\255\255\255\255\255\255\255\255\081\001\042\001\ -\043\001\044\001\045\001\046\001\047\001\255\255\089\001\090\001\ -\255\255\255\255\255\255\094\001\255\255\255\255\097\001\255\255\ -\255\255\255\255\061\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\109\001\110\001\071\001\072\001\255\255\074\001\ -\255\255\255\255\255\255\255\255\000\001\001\001\002\001\082\001\ -\083\001\084\001\085\001\086\001\087\001\009\001\255\255\255\255\ -\255\255\255\255\255\255\015\001\016\001\255\255\018\001\098\001\ -\255\255\100\001\255\255\255\255\255\255\255\255\255\255\027\001\ -\255\255\255\255\255\255\255\255\000\001\001\001\002\001\255\255\ -\036\001\255\255\255\255\255\255\255\255\009\001\042\001\043\001\ -\044\001\045\001\046\001\015\001\016\001\255\255\018\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\027\001\ -\255\255\061\001\255\255\255\255\255\255\255\255\066\001\255\255\ -\036\001\255\255\255\255\071\001\072\001\255\255\042\001\043\001\ -\044\001\045\001\046\001\255\255\255\255\255\255\082\001\083\001\ -\084\001\085\001\086\001\255\255\255\255\255\255\255\255\091\001\ -\255\255\061\001\255\255\255\255\255\255\255\255\066\001\255\255\ -\100\001\255\255\255\255\071\001\072\001\255\255\255\255\255\255\ -\255\255\255\255\000\001\001\001\002\001\255\255\082\001\083\001\ -\084\001\085\001\086\001\009\001\255\255\255\255\255\255\255\255\ -\092\001\015\001\016\001\255\255\018\001\255\255\255\255\255\255\ -\100\001\255\255\255\255\255\255\255\255\027\001\255\255\255\255\ -\255\255\255\255\000\001\001\001\002\001\255\255\036\001\255\255\ -\255\255\255\255\255\255\009\001\042\001\043\001\044\001\045\001\ -\046\001\015\001\016\001\255\255\018\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\027\001\255\255\061\001\ -\255\255\255\255\255\255\255\255\066\001\255\255\036\001\255\255\ -\255\255\071\001\072\001\255\255\042\001\043\001\044\001\045\001\ -\046\001\255\255\255\255\255\255\082\001\083\001\084\001\085\001\ -\086\001\255\255\255\255\255\255\255\255\255\255\255\255\061\001\ -\094\001\255\255\255\255\255\255\066\001\255\255\100\001\255\255\ -\255\255\071\001\072\001\255\255\255\255\255\255\255\255\255\255\ -\000\001\001\001\002\001\255\255\082\001\083\001\084\001\085\001\ -\086\001\009\001\255\255\255\255\255\255\091\001\255\255\015\001\ -\016\001\255\255\018\001\255\255\255\255\255\255\100\001\255\255\ -\255\255\255\255\255\255\027\001\255\255\255\255\255\255\255\255\ -\000\001\001\001\002\001\255\255\036\001\255\255\255\255\255\255\ -\255\255\009\001\042\001\043\001\044\001\045\001\046\001\015\001\ -\016\001\255\255\018\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\027\001\255\255\061\001\255\255\255\255\ -\255\255\255\255\066\001\255\255\036\001\255\255\255\255\071\001\ -\072\001\255\255\042\001\043\001\044\001\045\001\046\001\255\255\ -\255\255\255\255\082\001\083\001\084\001\085\001\086\001\255\255\ -\255\255\255\255\255\255\255\255\092\001\061\001\255\255\255\255\ -\255\255\255\255\066\001\255\255\100\001\255\255\255\255\071\001\ -\072\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\082\001\083\001\084\001\085\001\086\001\000\001\ -\001\001\002\001\255\255\255\255\255\255\255\255\094\001\255\255\ -\009\001\255\255\255\255\255\255\100\001\255\255\015\001\016\001\ -\255\255\018\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\027\001\255\255\255\255\255\255\255\255\000\001\ -\001\001\002\001\255\255\036\001\255\255\255\255\255\255\255\255\ -\009\001\042\001\043\001\044\001\045\001\046\001\015\001\016\001\ -\255\255\018\001\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\027\001\255\255\061\001\255\255\255\255\255\255\ -\255\255\066\001\255\255\036\001\255\255\255\255\071\001\072\001\ -\255\255\042\001\043\001\044\001\045\001\046\001\255\255\255\255\ -\255\255\082\001\083\001\084\001\085\001\086\001\255\255\255\255\ -\255\255\255\255\091\001\255\255\061\001\255\255\255\255\255\255\ -\255\255\066\001\255\255\100\001\255\255\255\255\071\001\072\001\ -\255\255\255\255\255\255\255\255\255\255\000\001\001\001\002\001\ -\255\255\082\001\083\001\084\001\085\001\086\001\009\001\255\255\ -\255\255\255\255\255\255\092\001\015\001\016\001\255\255\018\001\ -\255\255\255\255\255\255\100\001\255\255\255\255\255\255\255\255\ -\027\001\255\255\255\255\255\255\255\255\000\001\001\001\002\001\ -\255\255\036\001\255\255\255\255\255\255\255\255\009\001\042\001\ -\043\001\044\001\045\001\046\001\015\001\016\001\255\255\018\001\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\027\001\255\255\061\001\255\255\255\255\255\255\255\255\066\001\ -\255\255\036\001\255\255\255\255\071\001\072\001\255\255\042\001\ -\043\001\044\001\045\001\046\001\255\255\255\255\255\255\082\001\ -\083\001\084\001\085\001\086\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\061\001\094\001\255\255\255\255\255\255\066\001\ -\255\255\100\001\255\255\255\255\071\001\072\001\255\255\255\255\ -\255\255\255\255\255\255\000\001\001\001\002\001\255\255\082\001\ -\083\001\084\001\085\001\086\001\009\001\255\255\255\255\255\255\ -\091\001\255\255\015\001\016\001\255\255\018\001\255\255\255\255\ -\255\255\100\001\255\255\255\255\255\255\255\255\027\001\255\255\ -\255\255\255\255\255\255\000\001\001\001\002\001\255\255\036\001\ -\255\255\255\255\255\255\255\255\009\001\042\001\043\001\044\001\ -\045\001\046\001\015\001\016\001\255\255\018\001\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\027\001\255\255\ -\061\001\255\255\255\255\255\255\255\255\066\001\255\255\036\001\ -\255\255\255\255\071\001\072\001\255\255\042\001\043\001\044\001\ -\045\001\046\001\255\255\255\255\255\255\082\001\083\001\084\001\ -\085\001\086\001\255\255\255\255\255\255\255\255\255\255\092\001\ -\061\001\001\001\002\001\255\255\255\255\066\001\255\255\100\001\ -\255\255\009\001\071\001\072\001\255\255\255\255\255\255\015\001\ -\016\001\255\255\018\001\255\255\255\255\082\001\083\001\084\001\ -\085\001\086\001\255\255\027\001\255\255\255\255\255\255\255\255\ -\255\255\094\001\255\255\255\255\036\001\255\255\255\255\100\001\ -\255\255\255\255\042\001\043\001\044\001\045\001\046\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\061\001\255\255\255\255\ -\255\255\255\255\066\001\255\255\255\255\255\255\255\255\071\001\ -\072\001\001\001\002\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\009\001\082\001\083\001\084\001\085\001\086\001\015\001\ -\016\001\255\255\018\001\255\255\255\255\255\255\255\255\095\001\ -\255\255\025\001\255\255\027\001\100\001\255\255\255\255\255\255\ -\255\255\001\001\002\001\255\255\036\001\255\255\255\255\255\255\ -\255\255\009\001\042\001\043\001\044\001\045\001\046\001\015\001\ -\016\001\255\255\018\001\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\027\001\255\255\061\001\255\255\255\255\ -\255\255\255\255\066\001\255\255\036\001\255\255\255\255\071\001\ -\072\001\255\255\042\001\043\001\044\001\045\001\046\001\255\255\ -\255\255\255\255\082\001\083\001\084\001\085\001\086\001\255\255\ -\255\255\255\255\255\255\255\255\255\255\061\001\001\001\002\001\ -\255\255\255\255\066\001\255\255\100\001\255\255\009\001\071\001\ -\072\001\255\255\255\255\255\255\015\001\255\255\255\255\255\255\ -\255\255\255\255\082\001\083\001\084\001\085\001\086\001\255\255\ -\027\001\255\255\255\255\255\255\255\255\255\255\001\001\002\001\ -\255\255\036\001\255\255\255\255\100\001\255\255\255\255\042\001\ -\043\001\044\001\045\001\046\001\015\001\255\255\255\255\255\255\ -\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\027\001\255\255\061\001\255\255\255\255\255\255\255\255\066\001\ -\255\255\036\001\255\255\255\255\071\001\072\001\255\255\042\001\ -\043\001\044\001\045\001\046\001\013\001\255\255\255\255\082\001\ -\083\001\084\001\085\001\086\001\255\255\255\255\255\255\255\255\ -\255\255\255\255\061\001\028\001\029\001\255\255\255\255\066\001\ -\255\255\100\001\255\255\255\255\071\001\072\001\255\255\255\255\ -\041\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\083\001\084\001\085\001\086\001\255\255\255\255\055\001\255\255\ -\057\001\058\001\059\001\060\001\061\001\255\255\255\255\064\001\ -\065\001\100\001\255\255\068\001\255\255\255\255\255\255\255\255\ -\255\255\074\001\255\255\255\255\255\255\255\255\255\255\080\001\ -\081\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\089\001\090\001\255\255\255\255\255\255\255\255\255\255\096\001\ -\097\001\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ -\255\255\255\255\255\255\108\001\109\001\110\001\111\001" - -let yynames_const = "\ - AMPERAMPER\000\ - AMPERSAND\000\ - AND\000\ - AS\000\ - ASSERT\000\ - BACKQUOTE\000\ - BANG\000\ - BAR\000\ - BARBAR\000\ - BARRBRACKET\000\ - BEGIN\000\ - CLASS\000\ - COLON\000\ - COLONCOLON\000\ - COLONEQUAL\000\ - COLONGREATER\000\ - COMMA\000\ - CONSTRAINT\000\ - DO\000\ - DONE\000\ - DOT\000\ - DOTDOT\000\ - DOWNTO\000\ - ELSE\000\ - END\000\ - EOF\000\ - EQUAL\000\ - EXCEPTION\000\ - EXTERNAL\000\ - FALSE\000\ - FOR\000\ - FUN\000\ - FUNCTION\000\ - FUNCTOR\000\ - GREATER\000\ - GREATERRBRACE\000\ - GREATERRBRACKET\000\ - IF\000\ - IN\000\ - INCLUDE\000\ - INHERIT\000\ - INITIALIZER\000\ - LAZY\000\ - LBRACE\000\ - LBRACELESS\000\ - LBRACKET\000\ - LBRACKETBAR\000\ - LBRACKETLESS\000\ - LBRACKETGREATER\000\ - LBRACKETPERCENT\000\ - LBRACKETPERCENTPERCENT\000\ - LESS\000\ - LESSMINUS\000\ - LET\000\ - LPAREN\000\ - LBRACKETAT\000\ - LBRACKETATAT\000\ - LBRACKETATATAT\000\ - MATCH\000\ - METHOD\000\ - MINUS\000\ - MINUSDOT\000\ - MINUSGREATER\000\ - MODULE\000\ - MUTABLE\000\ - NEW\000\ - NONREC\000\ - OBJECT\000\ - OF\000\ - OPEN\000\ - OR\000\ - PERCENT\000\ - PLUS\000\ - PLUSDOT\000\ - PLUSEQ\000\ - PRIVATE\000\ - QUESTION\000\ - QUOTE\000\ - RBRACE\000\ - RBRACKET\000\ - REC\000\ - RPAREN\000\ - SEMI\000\ - SEMISEMI\000\ - HASH\000\ - SIG\000\ - STAR\000\ - STRUCT\000\ - THEN\000\ - TILDE\000\ - TO\000\ - TRUE\000\ - TRY\000\ - TYPE\000\ - UNDERSCORE\000\ - VAL\000\ - VIRTUAL\000\ - WHEN\000\ - WHILE\000\ - WITH\000\ - EOL\000\ - " - -let yynames_block = "\ - CHAR\000\ - FLOAT\000\ - INFIXOP0\000\ - INFIXOP1\000\ - INFIXOP2\000\ - INFIXOP3\000\ - INFIXOP4\000\ - DOTOP\000\ - INT\000\ - LABEL\000\ - LIDENT\000\ - OPTLABEL\000\ - PREFIXOP\000\ - HASHOP\000\ - STRING\000\ - UIDENT\000\ - COMMENT\000\ - DOCSTRING\000\ - " - -let yyact = [| - (fun _ -> failwith "parser") -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'structure) in - Obj.repr( -# 568 "ml/parser.mly" - ( extra_str 1 _1 ) -# 6360 "ml/parser.ml" - : Parsetree.structure)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'signature) in - Obj.repr( -# 571 "ml/parser.mly" - ( extra_sig 1 _1 ) -# 6367 "ml/parser.ml" - : Parsetree.signature)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in - Obj.repr( -# 576 "ml/parser.mly" - ( _1 ) -# 6374 "ml/parser.ml" - : Parsetree.core_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 579 "ml/parser.mly" - ( _1 ) -# 6381 "ml/parser.ml" - : Parsetree.expression)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in - Obj.repr( -# 582 "ml/parser.mly" - ( _1 ) -# 6388 "ml/parser.ml" - : Parsetree.pattern)) -; (fun __caml_parser_env -> - Obj.repr( -# 589 "ml/parser.mly" - ( mkrhs "*" 2, None ) -# 6394 "ml/parser.ml" - : 'functor_arg)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'functor_arg_name) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - Obj.repr( -# 591 "ml/parser.mly" - ( mkrhs _2 2, Some _4 ) -# 6402 "ml/parser.ml" - : 'functor_arg)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 595 "ml/parser.mly" - ( _1 ) -# 6409 "ml/parser.ml" - : 'functor_arg_name)) -; (fun __caml_parser_env -> - Obj.repr( -# 596 "ml/parser.mly" - ( "_" ) -# 6415 "ml/parser.ml" - : 'functor_arg_name)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'functor_args) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'functor_arg) in - Obj.repr( -# 601 "ml/parser.mly" - ( _2 :: _1 ) -# 6423 "ml/parser.ml" - : 'functor_args)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'functor_arg) in - Obj.repr( -# 603 "ml/parser.mly" - ( [ _1 ] ) -# 6430 "ml/parser.ml" - : 'functor_args)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'mod_longident) in - Obj.repr( -# 608 "ml/parser.mly" - ( mkmod(Pmod_ident (mkrhs _1 1)) ) -# 6437 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'structure) in - Obj.repr( -# 610 "ml/parser.mly" - ( mkmod ~attrs:_2 (Pmod_structure(extra_str 3 _3)) ) -# 6445 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'structure) in - Obj.repr( -# 612 "ml/parser.mly" - ( unclosed "struct" 1 "end" 4 ) -# 6453 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'functor_args) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in - Obj.repr( -# 614 "ml/parser.mly" - ( let modexp = - List.fold_left - (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) - _5 _3 - in wrap_mod_attrs modexp _2 ) -# 6466 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'paren_module_expr) in - Obj.repr( -# 620 "ml/parser.mly" - ( mkmod(Pmod_apply(_1, _2)) ) -# 6474 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'module_expr) in - Obj.repr( -# 622 "ml/parser.mly" - ( mkmod(Pmod_apply(_1, mkmod (Pmod_structure []))) ) -# 6481 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'paren_module_expr) in - Obj.repr( -# 624 "ml/parser.mly" - ( _1 ) -# 6488 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in - Obj.repr( -# 626 "ml/parser.mly" - ( Mod.attr _1 _2 ) -# 6496 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in - Obj.repr( -# 628 "ml/parser.mly" - ( mkmod(Pmod_extension _1) ) -# 6503 "ml/parser.ml" - : 'module_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - Obj.repr( -# 633 "ml/parser.mly" - ( mkmod(Pmod_constraint(_2, _4)) ) -# 6511 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - Obj.repr( -# 635 "ml/parser.mly" - ( unclosed "(" 1 ")" 5 ) -# 6519 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in - Obj.repr( -# 637 "ml/parser.mly" - ( _2 ) -# 6526 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in - Obj.repr( -# 639 "ml/parser.mly" - ( unclosed "(" 1 ")" 3 ) -# 6533 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 641 "ml/parser.mly" - ( mkmod ~attrs:_3 (Pmod_unpack _4)) -# 6541 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 643 "ml/parser.mly" - ( mkmod ~attrs:_3 - (Pmod_unpack( - ghexp(Pexp_constraint(_4, ghtyp(Ptyp_package _6))))) ) -# 6552 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 6 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 5 : 'expr) in - let _6 = (Parsing.peek_val __caml_parser_env 3 : 'package_type) in - let _8 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 648 "ml/parser.mly" - ( mkmod ~attrs:_3 - (Pmod_unpack( - ghexp(Pexp_coerce(_4, Some(ghtyp(Ptyp_package _6)), - ghtyp(Ptyp_package _8))))) ) -# 6565 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 653 "ml/parser.mly" - ( mkmod ~attrs:_3 - (Pmod_unpack( - ghexp(Pexp_coerce(_4, None, ghtyp(Ptyp_package _6))))) ) -# 6576 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - Obj.repr( -# 657 "ml/parser.mly" - ( unclosed "(" 1 ")" 6 ) -# 6584 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - Obj.repr( -# 659 "ml/parser.mly" - ( unclosed "(" 1 ")" 6 ) -# 6592 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 661 "ml/parser.mly" - ( unclosed "(" 1 ")" 5 ) -# 6600 "ml/parser.ml" - : 'paren_module_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'post_item_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'structure_tail) in - Obj.repr( -# 666 "ml/parser.mly" - ( mark_rhs_docs 1 2; - (text_str 1) @ mkstrexp _1 _2 :: _3 ) -# 6610 "ml/parser.ml" - : 'structure)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'structure_tail) in - Obj.repr( -# 668 "ml/parser.mly" - ( _1 ) -# 6617 "ml/parser.ml" - : 'structure)) -; (fun __caml_parser_env -> - Obj.repr( -# 671 "ml/parser.mly" - ( [] ) -# 6623 "ml/parser.ml" - : 'structure_tail)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'structure) in - Obj.repr( -# 672 "ml/parser.mly" - ( (text_str 1) @ _2 ) -# 6630 "ml/parser.ml" - : 'structure_tail)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'structure_item) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'structure_tail) in - Obj.repr( -# 673 "ml/parser.mly" - ( (text_str 1) @ _1 :: _2 ) -# 6638 "ml/parser.ml" - : 'structure_tail)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'let_bindings) in - Obj.repr( -# 677 "ml/parser.mly" - ( val_of_let_bindings _1 ) -# 6645 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'primitive_declaration) in - Obj.repr( -# 679 "ml/parser.mly" - ( let (body, ext) = _1 in mkstr_ext (Pstr_primitive body) ext ) -# 6652 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'value_description) in - Obj.repr( -# 681 "ml/parser.mly" - ( let (body, ext) = _1 in mkstr_ext (Pstr_primitive body) ext ) -# 6659 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_declarations) in - Obj.repr( -# 683 "ml/parser.mly" - ( let (nr, l, ext ) = _1 in mkstr_ext (Pstr_type (nr, List.rev l)) ext ) -# 6666 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'str_type_extension) in - Obj.repr( -# 685 "ml/parser.mly" - ( let (l, ext) = _1 in mkstr_ext (Pstr_typext l) ext ) -# 6673 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'str_exception_declaration) in - Obj.repr( -# 687 "ml/parser.mly" - ( let (l, ext) = _1 in mkstr_ext (Pstr_exception l) ext ) -# 6680 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_binding) in - Obj.repr( -# 689 "ml/parser.mly" - ( let (body, ext) = _1 in mkstr_ext (Pstr_module body) ext ) -# 6687 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_bindings) in - Obj.repr( -# 691 "ml/parser.mly" - ( let (l, ext) = _1 in mkstr_ext (Pstr_recmodule(List.rev l)) ext ) -# 6694 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_type_declaration) in - Obj.repr( -# 693 "ml/parser.mly" - ( let (body, ext) = _1 in mkstr_ext (Pstr_modtype body) ext ) -# 6701 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'open_statement) in - Obj.repr( -# 695 "ml/parser.mly" - ( let (body, ext) = _1 in mkstr_ext (Pstr_open body) ext ) -# 6708 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_type_declarations) in - Obj.repr( -# 697 "ml/parser.mly" - ( let (l, ext) = _1 in mkstr_ext (Pstr_class_type (List.rev l)) ext ) -# 6715 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'str_include_statement) in - Obj.repr( -# 699 "ml/parser.mly" - ( let (body, ext) = _1 in mkstr_ext (Pstr_include body) ext ) -# 6722 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 701 "ml/parser.mly" - ( mkstr(Pstr_extension (_1, (add_docs_attrs (symbol_docs ()) _2))) ) -# 6730 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in - Obj.repr( -# 703 "ml/parser.mly" - ( mark_symbol_docs (); - mkstr(Pstr_attribute _1) ) -# 6738 "ml/parser.ml" - : 'structure_item)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 708 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Incl.mk _3 ~attrs:(attrs@_4) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext ) -# 6750 "ml/parser.ml" - : 'str_include_statement)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in - Obj.repr( -# 715 "ml/parser.mly" - ( _2 ) -# 6757 "ml/parser.ml" - : 'module_binding_body)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in - Obj.repr( -# 717 "ml/parser.mly" - ( mkmod(Pmod_constraint(_4, _2)) ) -# 6765 "ml/parser.ml" - : 'module_binding_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'functor_arg) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_binding_body) in - Obj.repr( -# 719 "ml/parser.mly" - ( mkmod(Pmod_functor(fst _1, snd _1, _2)) ) -# 6773 "ml/parser.ml" - : 'module_binding_body)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_binding_body) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 723 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Mb.mk (mkrhs _3 3) _4 ~attrs:(attrs@_5) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext ) -# 6786 "ml/parser.ml" - : 'module_binding)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_binding) in - Obj.repr( -# 729 "ml/parser.mly" - ( let (b, ext) = _1 in ([b], ext) ) -# 6793 "ml/parser.ml" - : 'rec_module_bindings)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rec_module_bindings) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_module_binding) in - Obj.repr( -# 731 "ml/parser.mly" - ( let (l, ext) = _1 in (_2 :: l, ext) ) -# 6801 "ml/parser.ml" - : 'rec_module_bindings)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : string) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'module_binding_body) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 735 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Mb.mk (mkrhs _4 4) _5 ~attrs:(attrs@_6) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext ) -# 6814 "ml/parser.ml" - : 'rec_module_binding)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_binding_body) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 742 "ml/parser.mly" - ( Mb.mk (mkrhs _3 3) _4 ~attrs:(_2@_5) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) ) -# 6825 "ml/parser.ml" - : 'and_module_binding)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'mty_longident) in - Obj.repr( -# 750 "ml/parser.mly" - ( mkmty(Pmty_ident (mkrhs _1 1)) ) -# 6832 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'signature) in - Obj.repr( -# 752 "ml/parser.mly" - ( mkmty ~attrs:_2 (Pmty_signature (extra_sig 3 _3)) ) -# 6840 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'signature) in - Obj.repr( -# 754 "ml/parser.mly" - ( unclosed "sig" 1 "end" 4 ) -# 6848 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'functor_args) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in - Obj.repr( -# 757 "ml/parser.mly" - ( let mty = - List.fold_left - (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) - _5 _3 - in wrap_mty_attrs mty _2 ) -# 6861 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in - Obj.repr( -# 764 "ml/parser.mly" - ( mkmty(Pmty_functor(mknoloc "_", Some _1, _3)) ) -# 6869 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'with_constraints) in - Obj.repr( -# 766 "ml/parser.mly" - ( mkmty(Pmty_with(_1, List.rev _3)) ) -# 6877 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'attributes) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'module_expr) in - Obj.repr( -# 768 "ml/parser.mly" - ( mkmty ~attrs:_4 (Pmty_typeof _5) ) -# 6885 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - Obj.repr( -# 772 "ml/parser.mly" - ( _2 ) -# 6892 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - Obj.repr( -# 774 "ml/parser.mly" - ( unclosed "(" 1 ")" 3 ) -# 6899 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in - Obj.repr( -# 776 "ml/parser.mly" - ( mkmty(Pmty_extension _1) ) -# 6906 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in - Obj.repr( -# 778 "ml/parser.mly" - ( Mty.attr _1 _2 ) -# 6914 "ml/parser.ml" - : 'module_type)) -; (fun __caml_parser_env -> - Obj.repr( -# 781 "ml/parser.mly" - ( [] ) -# 6920 "ml/parser.ml" - : 'signature)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'signature) in - Obj.repr( -# 782 "ml/parser.mly" - ( (text_sig 1) @ _2 ) -# 6927 "ml/parser.ml" - : 'signature)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'signature_item) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'signature) in - Obj.repr( -# 783 "ml/parser.mly" - ( (text_sig 1) @ _1 :: _2 ) -# 6935 "ml/parser.ml" - : 'signature)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'value_description) in - Obj.repr( -# 787 "ml/parser.mly" - ( let (body, ext) = _1 in mksig_ext (Psig_value body) ext ) -# 6942 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'primitive_declaration) in - Obj.repr( -# 789 "ml/parser.mly" - ( let (body, ext) = _1 in mksig_ext (Psig_value body) ext) -# 6949 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_declarations) in - Obj.repr( -# 791 "ml/parser.mly" - ( let (nr, l, ext) = _1 in mksig_ext (Psig_type (nr, List.rev l)) ext ) -# 6956 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_type_extension) in - Obj.repr( -# 793 "ml/parser.mly" - ( let (l, ext) = _1 in mksig_ext (Psig_typext l) ext ) -# 6963 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_exception_declaration) in - Obj.repr( -# 795 "ml/parser.mly" - ( let (l, ext) = _1 in mksig_ext (Psig_exception l) ext ) -# 6970 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_declaration) in - Obj.repr( -# 797 "ml/parser.mly" - ( let (body, ext) = _1 in mksig_ext (Psig_module body) ext ) -# 6977 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_alias) in - Obj.repr( -# 799 "ml/parser.mly" - ( let (body, ext) = _1 in mksig_ext (Psig_module body) ext ) -# 6984 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_declarations) in - Obj.repr( -# 801 "ml/parser.mly" - ( let (l, ext) = _1 in mksig_ext (Psig_recmodule (List.rev l)) ext ) -# 6991 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_type_declaration) in - Obj.repr( -# 803 "ml/parser.mly" - ( let (body, ext) = _1 in mksig_ext (Psig_modtype body) ext ) -# 6998 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'open_statement) in - Obj.repr( -# 805 "ml/parser.mly" - ( let (body, ext) = _1 in mksig_ext (Psig_open body) ext ) -# 7005 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_include_statement) in - Obj.repr( -# 807 "ml/parser.mly" - ( let (body, ext) = _1 in mksig_ext (Psig_include body) ext ) -# 7012 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_type_declarations) in - Obj.repr( -# 809 "ml/parser.mly" - ( let (l, ext) = _1 in mksig_ext (Psig_class_type (List.rev l)) ext ) -# 7019 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 811 "ml/parser.mly" - ( mksig(Psig_extension (_1, (add_docs_attrs (symbol_docs ()) _2))) ) -# 7027 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in - Obj.repr( -# 813 "ml/parser.mly" - ( mark_symbol_docs (); - mksig(Psig_attribute _1) ) -# 7035 "ml/parser.ml" - : 'signature_item)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'override_flag) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'mod_longident) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 818 "ml/parser.mly" - ( let (ext, attrs) = _3 in - Opn.mk (mkrhs _4 4) ~override:_2 ~attrs:(attrs@_5) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext) -# 7048 "ml/parser.ml" - : 'open_statement)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 825 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Incl.mk _3 ~attrs:(attrs@_4) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext) -# 7060 "ml/parser.ml" - : 'sig_include_statement)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in - Obj.repr( -# 832 "ml/parser.mly" - ( _2 ) -# 7067 "ml/parser.ml" - : 'module_declaration_body)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'module_type) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'module_declaration_body) in - Obj.repr( -# 834 "ml/parser.mly" - ( mkmty(Pmty_functor(mkrhs _2 2, Some _4, _6)) ) -# 7076 "ml/parser.ml" - : 'module_declaration_body)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'module_declaration_body) in - Obj.repr( -# 836 "ml/parser.mly" - ( mkmty(Pmty_functor(mkrhs "*" 1, None, _3)) ) -# 7083 "ml/parser.ml" - : 'module_declaration_body)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_declaration_body) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 840 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Md.mk (mkrhs _3 3) _4 ~attrs:(attrs@_5) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext ) -# 7096 "ml/parser.ml" - : 'module_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'mod_longident) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 847 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Md.mk (mkrhs _3 3) - (Mty.alias ~loc:(rhs_loc 5) (mkrhs _5 5)) ~attrs:(attrs@_6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext ) -# 7110 "ml/parser.ml" - : 'module_alias)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'rec_module_declaration) in - Obj.repr( -# 855 "ml/parser.mly" - ( let (body, ext) = _1 in ([body], ext) ) -# 7117 "ml/parser.ml" - : 'rec_module_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'rec_module_declarations) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_module_declaration) in - Obj.repr( -# 857 "ml/parser.mly" - ( let (l, ext) = _1 in (_2 :: l, ext) ) -# 7125 "ml/parser.ml" - : 'rec_module_declarations)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 861 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Md.mk (mkrhs _4 4) _6 ~attrs:(attrs@_7) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext) -# 7138 "ml/parser.ml" - : 'rec_module_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'module_type) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 868 "ml/parser.mly" - ( Md.mk (mkrhs _3 3) _5 ~attrs:(_2@_6) ~loc:(symbol_rloc()) - ~text:(symbol_text()) ~docs:(symbol_docs()) ) -# 7149 "ml/parser.ml" - : 'and_module_declaration)) -; (fun __caml_parser_env -> - Obj.repr( -# 872 "ml/parser.mly" - ( None ) -# 7155 "ml/parser.ml" - : 'module_type_declaration_body)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in - Obj.repr( -# 873 "ml/parser.mly" - ( Some _2 ) -# 7162 "ml/parser.ml" - : 'module_type_declaration_body)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'ident) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'module_type_declaration_body) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 878 "ml/parser.mly" - ( let (ext, attrs) = _3 in - Mtd.mk (mkrhs _4 4) ?typ:_5 ~attrs:(attrs@_6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext ) -# 7175 "ml/parser.ml" - : 'module_type_declaration)) -; (fun __caml_parser_env -> - Obj.repr( -# 886 "ml/parser.mly" - ( [] ) -# 7181 "ml/parser.ml" - : 'class_type_parameters)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'type_parameter_list) in - Obj.repr( -# 887 "ml/parser.mly" - ( List.rev _2 ) -# 7188 "ml/parser.ml" - : 'class_type_parameters)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_self_pattern) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_fields) in - Obj.repr( -# 891 "ml/parser.mly" - ( Cstr.mk _1 (extra_cstr 2 (List.rev _2)) ) -# 7196 "ml/parser.ml" - : 'class_structure)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in - Obj.repr( -# 895 "ml/parser.mly" - ( reloc_pat _2 ) -# 7203 "ml/parser.ml" - : 'class_self_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in - Obj.repr( -# 897 "ml/parser.mly" - ( mkpat(Ppat_constraint(_2, _4)) ) -# 7211 "ml/parser.ml" - : 'class_self_pattern)) -; (fun __caml_parser_env -> - Obj.repr( -# 899 "ml/parser.mly" - ( ghpat(Ppat_any) ) -# 7217 "ml/parser.ml" - : 'class_self_pattern)) -; (fun __caml_parser_env -> - Obj.repr( -# 903 "ml/parser.mly" - ( [] ) -# 7223 "ml/parser.ml" - : 'class_fields)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_fields) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_field) in - Obj.repr( -# 905 "ml/parser.mly" - ( _2 :: (text_cstr 2) @ _1 ) -# 7231 "ml/parser.ml" - : 'class_fields)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 909 "ml/parser.mly" - ( let v, attrs = _2 in - mkcf (Pcf_val v) ~attrs:(attrs@_3) ~docs:(symbol_docs ()) ) -# 7240 "ml/parser.ml" - : 'class_field)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'method_) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 912 "ml/parser.mly" - ( let meth, attrs = _2 in - mkcf (Pcf_method meth) ~attrs:(attrs@_3) ~docs:(symbol_docs ()) ) -# 7249 "ml/parser.ml" - : 'class_field)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'constrain_field) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 915 "ml/parser.mly" - ( mkcf (Pcf_constraint _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) ) -# 7258 "ml/parser.ml" - : 'class_field)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 917 "ml/parser.mly" - ( mkcf (Pcf_initializer _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) ) -# 7267 "ml/parser.ml" - : 'class_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 919 "ml/parser.mly" - ( mkcf (Pcf_extension _1) ~attrs:_2 ~docs:(symbol_docs ()) ) -# 7275 "ml/parser.ml" - : 'class_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in - Obj.repr( -# 921 "ml/parser.mly" - ( mark_symbol_docs (); - mkcf (Pcf_attribute _1) ) -# 7283 "ml/parser.ml" - : 'class_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 927 "ml/parser.mly" - ( if _1 = Override then syntax_error (); - (mkloc _5 (rhs_loc 5), Mutable, Cfk_virtual _7), _2 ) -# 7294 "ml/parser.ml" - : 'value)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'mutable_flag) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 930 "ml/parser.mly" - ( if _1 = Override then syntax_error (); - (mkrhs _5 5, _4, Cfk_virtual _7), _2 ) -# 7306 "ml/parser.ml" - : 'value)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 5 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'mutable_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 933 "ml/parser.mly" - ( (mkrhs _4 4, _3, Cfk_concrete (_1, _6)), _2 ) -# 7317 "ml/parser.ml" - : 'value)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mutable_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'label) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'type_constraint) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 935 "ml/parser.mly" - ( - let e = mkexp_constraint _7 _5 in - (mkrhs _4 4, _3, Cfk_concrete (_1, e)), _2 - ) -# 7332 "ml/parser.ml" - : 'value)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'poly_type) in - Obj.repr( -# 943 "ml/parser.mly" - ( if _1 = Override then syntax_error (); - (mkloc _5 (rhs_loc 5), Private, Cfk_virtual _7), _2 ) -# 7343 "ml/parser.ml" - : 'method_)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'private_flag) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'poly_type) in - Obj.repr( -# 946 "ml/parser.mly" - ( if _1 = Override then syntax_error (); - (mkloc _5 (rhs_loc 5), _4, Cfk_virtual _7), _2 ) -# 7355 "ml/parser.ml" - : 'method_)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'private_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'label) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'strict_binding) in - Obj.repr( -# 949 "ml/parser.mly" - ( (mkloc _4 (rhs_loc 4), _3, - Cfk_concrete (_1, ghexp(Pexp_poly (_5, None)))), _2 ) -# 7367 "ml/parser.ml" - : 'method_)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 7 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 6 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 5 : 'private_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 4 : 'label) in - let _6 = (Parsing.peek_val __caml_parser_env 2 : 'poly_type) in - let _8 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 952 "ml/parser.mly" - ( (mkloc _4 (rhs_loc 4), _3, - Cfk_concrete (_1, ghexp(Pexp_poly(_8, Some _6)))), _2 ) -# 7380 "ml/parser.ml" - : 'method_)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 10 : 'override_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 9 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 8 : 'private_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 7 : 'label) in - let _7 = (Parsing.peek_val __caml_parser_env 4 : 'lident_list) in - let _9 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in - let _11 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 956 "ml/parser.mly" - ( let exp, poly = wrap_type_annotation _7 _9 _11 in - (mkloc _4 (rhs_loc 4), _3, - Cfk_concrete (_1, ghexp(Pexp_poly(exp, Some poly)))), _2 ) -# 7395 "ml/parser.ml" - : 'method_)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_comma_list) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'clty_longident) in - Obj.repr( -# 965 "ml/parser.mly" - ( mkcty(Pcty_constr (mkloc _4 (rhs_loc 4), List.rev _2)) ) -# 7403 "ml/parser.ml" - : 'class_signature)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'clty_longident) in - Obj.repr( -# 967 "ml/parser.mly" - ( mkcty(Pcty_constr (mkrhs _1 1, [])) ) -# 7410 "ml/parser.ml" - : 'class_signature)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_sig_body) in - Obj.repr( -# 969 "ml/parser.mly" - ( mkcty ~attrs:_2 (Pcty_signature _3) ) -# 7418 "ml/parser.ml" - : 'class_signature)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_sig_body) in - Obj.repr( -# 971 "ml/parser.mly" - ( unclosed "object" 1 "end" 4 ) -# 7426 "ml/parser.ml" - : 'class_signature)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in - Obj.repr( -# 973 "ml/parser.mly" - ( Cty.attr _1 _2 ) -# 7434 "ml/parser.ml" - : 'class_signature)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in - Obj.repr( -# 975 "ml/parser.mly" - ( mkcty(Pcty_extension _1) ) -# 7441 "ml/parser.ml" - : 'class_signature)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'attributes) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'class_signature) in - Obj.repr( -# 977 "ml/parser.mly" - ( wrap_class_type_attrs (mkcty(Pcty_open(_3, mkrhs _5 5, _7))) _4 ) -# 7451 "ml/parser.ml" - : 'class_signature)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_self_type) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_sig_fields) in - Obj.repr( -# 981 "ml/parser.mly" - ( Csig.mk _1 (extra_csig 2 (List.rev _2)) ) -# 7459 "ml/parser.ml" - : 'class_sig_body)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in - Obj.repr( -# 985 "ml/parser.mly" - ( _2 ) -# 7466 "ml/parser.ml" - : 'class_self_type)) -; (fun __caml_parser_env -> - Obj.repr( -# 987 "ml/parser.mly" - ( mktyp(Ptyp_any) ) -# 7472 "ml/parser.ml" - : 'class_self_type)) -; (fun __caml_parser_env -> - Obj.repr( -# 990 "ml/parser.mly" - ( [] ) -# 7478 "ml/parser.ml" - : 'class_sig_fields)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_sig_fields) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_sig_field) in - Obj.repr( -# 991 "ml/parser.mly" - ( _2 :: (text_csig 2) @ _1 ) -# 7486 "ml/parser.ml" - : 'class_sig_fields)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 995 "ml/parser.mly" - ( mkctf (Pctf_inherit _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) ) -# 7495 "ml/parser.ml" - : 'class_sig_field)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'value_type) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 997 "ml/parser.mly" - ( mkctf (Pctf_val _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) ) -# 7504 "ml/parser.ml" - : 'class_sig_field)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'private_virtual_flags) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'label) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'poly_type) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1000 "ml/parser.mly" - ( - let (p, v) = _3 in - mkctf (Pctf_method (mkrhs _4 4, p, v, _6)) ~attrs:(_2@_7) ~docs:(symbol_docs ()) - ) -# 7518 "ml/parser.ml" - : 'class_sig_field)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'constrain_field) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1005 "ml/parser.mly" - ( mkctf (Pctf_constraint _3) ~attrs:(_2@_4) ~docs:(symbol_docs ()) ) -# 7527 "ml/parser.ml" - : 'class_sig_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'item_extension) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1007 "ml/parser.mly" - ( mkctf (Pctf_extension _1) ~attrs:_2 ~docs:(symbol_docs ()) ) -# 7535 "ml/parser.ml" - : 'class_sig_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'floating_attribute) in - Obj.repr( -# 1009 "ml/parser.mly" - ( mark_symbol_docs (); - mkctf(Pctf_attribute _1) ) -# 7543 "ml/parser.ml" - : 'class_sig_field)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'mutable_flag) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1014 "ml/parser.mly" - ( mkrhs _3 3, _2, Virtual, _5 ) -# 7552 "ml/parser.ml" - : 'value_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'virtual_flag) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1016 "ml/parser.mly" - ( mkrhs _3 3, Mutable, _2, _5 ) -# 7561 "ml/parser.ml" - : 'value_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1018 "ml/parser.mly" - ( mkrhs _1 1, Immutable, Concrete, _3 ) -# 7569 "ml/parser.ml" - : 'value_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1021 "ml/parser.mly" - ( _1, _3, symbol_rloc() ) -# 7577 "ml/parser.ml" - : 'constrain)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1024 "ml/parser.mly" - ( _1, _3 ) -# 7585 "ml/parser.ml" - : 'constrain_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'class_type_declaration) in - Obj.repr( -# 1028 "ml/parser.mly" - ( let (body, ext) = _1 in ([body],ext) ) -# 7592 "ml/parser.ml" - : 'class_type_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'class_type_declarations) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_class_type_declaration) in - Obj.repr( -# 1030 "ml/parser.mly" - ( let (l, ext) = _1 in (_2 :: l, ext) ) -# 7600 "ml/parser.ml" - : 'class_type_declarations)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 6 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 5 : 'virtual_flag) in - let _5 = (Parsing.peek_val __caml_parser_env 4 : 'class_type_parameters) in - let _6 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _8 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in - let _9 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1035 "ml/parser.mly" - ( let (ext, attrs) = _3 in - Ci.mk (mkrhs _6 6) _8 ~virt:_4 ~params:_5 ~attrs:(attrs@_9) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext) -# 7615 "ml/parser.ml" - : 'class_type_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 6 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 5 : 'virtual_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 4 : 'class_type_parameters) in - let _5 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _7 = (Parsing.peek_val __caml_parser_env 1 : 'class_signature) in - let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1043 "ml/parser.mly" - ( Ci.mk (mkrhs _5 5) _7 ~virt:_3 ~params:_4 - ~attrs:(_2@_8) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) ) -# 7629 "ml/parser.ml" - : 'and_class_type_declaration)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1051 "ml/parser.mly" - ( _1 ) -# 7636 "ml/parser.ml" - : 'seq_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1052 "ml/parser.mly" - ( _1 ) -# 7643 "ml/parser.ml" - : 'seq_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1053 "ml/parser.mly" - ( mkexp(Pexp_sequence(_1, _3)) ) -# 7651 "ml/parser.ml" - : 'seq_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'attr_id) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1055 "ml/parser.mly" - ( let seq = mkexp(Pexp_sequence (_1, _5)) in - let payload = PStr [mkstrexp seq []] in - mkexp (Pexp_extension (_4, payload)) ) -# 7662 "ml/parser.ml" - : 'seq_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label_let_pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'opt_default) in - Obj.repr( -# 1061 "ml/parser.mly" - ( (Optional (fst _3), _4, snd _3) ) -# 7670 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_var) in - Obj.repr( -# 1063 "ml/parser.mly" - ( (Optional (fst _2), None, snd _2) ) -# 7677 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'let_pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'opt_default) in - Obj.repr( -# 1065 "ml/parser.mly" - ( (Optional _1, _4, _3) ) -# 7686 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_var) in - Obj.repr( -# 1067 "ml/parser.mly" - ( (Optional _1, None, _2) ) -# 7694 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'label_let_pattern) in - Obj.repr( -# 1069 "ml/parser.mly" - ( (Labelled (fst _3), None, snd _3) ) -# 7701 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_var) in - Obj.repr( -# 1071 "ml/parser.mly" - ( (Labelled (fst _2), None, snd _2) ) -# 7708 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in - Obj.repr( -# 1073 "ml/parser.mly" - ( (Labelled _1, None, _2) ) -# 7716 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in - Obj.repr( -# 1075 "ml/parser.mly" - ( (Nolabel, None, _1) ) -# 7723 "ml/parser.ml" - : 'labeled_simple_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 1078 "ml/parser.mly" - ( mkpat(Ppat_var (mkrhs _1 1)) ) -# 7730 "ml/parser.ml" - : 'pattern_var)) -; (fun __caml_parser_env -> - Obj.repr( -# 1079 "ml/parser.mly" - ( mkpat Ppat_any ) -# 7736 "ml/parser.ml" - : 'pattern_var)) -; (fun __caml_parser_env -> - Obj.repr( -# 1082 "ml/parser.mly" - ( None ) -# 7742 "ml/parser.ml" - : 'opt_default)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1083 "ml/parser.mly" - ( Some _2 ) -# 7749 "ml/parser.ml" - : 'opt_default)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_var) in - Obj.repr( -# 1087 "ml/parser.mly" - ( _1 ) -# 7756 "ml/parser.ml" - : 'label_let_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label_var) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1089 "ml/parser.mly" - ( let (lab, pat) = _1 in (lab, mkpat(Ppat_constraint(pat, _3))) ) -# 7764 "ml/parser.ml" - : 'label_let_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 1092 "ml/parser.mly" - ( (_1, mkpat(Ppat_var (mkrhs _1 1))) ) -# 7771 "ml/parser.ml" - : 'label_var)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1096 "ml/parser.mly" - ( _1 ) -# 7778 "ml/parser.ml" - : 'let_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1098 "ml/parser.mly" - ( mkpat(Ppat_constraint(_1, _3)) ) -# 7786 "ml/parser.ml" - : 'let_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1102 "ml/parser.mly" - ( _1 ) -# 7793 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_labeled_expr_list) in - Obj.repr( -# 1104 "ml/parser.mly" - ( mkexp(Pexp_apply(_1, List.rev _2)) ) -# 7801 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'let_bindings) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1106 "ml/parser.mly" - ( expr_of_let_bindings _1 _3 ) -# 7809 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'module_binding_body) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1108 "ml/parser.mly" - ( mkexp_attrs (Pexp_letmodule(mkrhs _4 4, _5, _7)) _3 ) -# 7819 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'let_exception_declaration) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1110 "ml/parser.mly" - ( mkexp_attrs (Pexp_letexception(_4, _6)) _3 ) -# 7828 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'override_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1112 "ml/parser.mly" - ( mkexp_attrs (Pexp_open(_3, mkrhs _5 5, _7)) _4 ) -# 7838 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_bar) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'match_cases) in - Obj.repr( -# 1114 "ml/parser.mly" - ( mkexp_attrs (Pexp_function(List.rev _4)) _2 ) -# 7847 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in - Obj.repr( -# 1116 "ml/parser.mly" - ( let (l,o,p) = _3 in - mkexp_attrs (Pexp_fun(l, o, p, _4)) _2 ) -# 7857 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'lident_list) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in - Obj.repr( -# 1119 "ml/parser.mly" - ( mkexp_attrs (mk_newtypes _5 _7).pexp_desc _2 ) -# 7866 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_bar) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'match_cases) in - Obj.repr( -# 1121 "ml/parser.mly" - ( mkexp_attrs (Pexp_match(_3, List.rev _6)) _2 ) -# 7876 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_bar) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'match_cases) in - Obj.repr( -# 1123 "ml/parser.mly" - ( mkexp_attrs (Pexp_try(_3, List.rev _6)) _2 ) -# 7886 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in - Obj.repr( -# 1125 "ml/parser.mly" - ( syntax_error() ) -# 7894 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'expr_comma_list) in - Obj.repr( -# 1127 "ml/parser.mly" - ( mkexp(Pexp_tuple(List.rev _1)) ) -# 7901 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1129 "ml/parser.mly" - ( mkexp(Pexp_construct(mkrhs _1 1, Some _2)) ) -# 7909 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1131 "ml/parser.mly" - ( mkexp(Pexp_variant(_1, Some _2)) ) -# 7917 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'seq_expr) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1133 "ml/parser.mly" - ( mkexp_attrs(Pexp_ifthenelse(_3, _5, Some _7)) _2 ) -# 7927 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1135 "ml/parser.mly" - ( mkexp_attrs (Pexp_ifthenelse(_3, _5, None)) _2 ) -# 7936 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1137 "ml/parser.mly" - ( mkexp_attrs (Pexp_while(_3, _5)) _2 ) -# 7945 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 8 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 7 : 'pattern) in - let _5 = (Parsing.peek_val __caml_parser_env 5 : 'seq_expr) in - let _6 = (Parsing.peek_val __caml_parser_env 4 : 'direction_flag) in - let _7 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in - let _9 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1140 "ml/parser.mly" - ( mkexp_attrs(Pexp_for(_3, _5, _7, _6, _9)) _2 ) -# 7957 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1142 "ml/parser.mly" - ( mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[_1;_3])) (symbol_rloc()) ) -# 7965 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1144 "ml/parser.mly" - ( mkinfix _1 _2 _3 ) -# 7974 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1146 "ml/parser.mly" - ( mkinfix _1 _2 _3 ) -# 7983 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1148 "ml/parser.mly" - ( mkinfix _1 _2 _3 ) -# 7992 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1150 "ml/parser.mly" - ( mkinfix _1 _2 _3 ) -# 8001 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1152 "ml/parser.mly" - ( mkinfix _1 _2 _3 ) -# 8010 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1154 "ml/parser.mly" - ( mkinfix _1 "+" _3 ) -# 8018 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1156 "ml/parser.mly" - ( mkinfix _1 "+." _3 ) -# 8026 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1158 "ml/parser.mly" - ( mkinfix _1 "+=" _3 ) -# 8034 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1160 "ml/parser.mly" - ( mkinfix _1 "-" _3 ) -# 8042 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1162 "ml/parser.mly" - ( mkinfix _1 "-." _3 ) -# 8050 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1164 "ml/parser.mly" - ( mkinfix _1 "*" _3 ) -# 8058 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1166 "ml/parser.mly" - ( mkinfix _1 "%" _3 ) -# 8066 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1168 "ml/parser.mly" - ( mkinfix _1 "=" _3 ) -# 8074 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1170 "ml/parser.mly" - ( mkinfix _1 "<" _3 ) -# 8082 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1172 "ml/parser.mly" - ( mkinfix _1 ">" _3 ) -# 8090 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1174 "ml/parser.mly" - ( mkinfix _1 "or" _3 ) -# 8098 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1176 "ml/parser.mly" - ( mkinfix _1 "||" _3 ) -# 8106 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1178 "ml/parser.mly" - ( mkinfix _1 "&" _3 ) -# 8114 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1180 "ml/parser.mly" - ( mkinfix _1 "&&" _3 ) -# 8122 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1182 "ml/parser.mly" - ( mkinfix _1 ":=" _3 ) -# 8130 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'subtractive) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1184 "ml/parser.mly" - ( mkuminus _1 _2 ) -# 8138 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'additive) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1186 "ml/parser.mly" - ( mkuplus _1 _2 ) -# 8146 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label_longident) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1188 "ml/parser.mly" - ( mkexp(Pexp_setfield(_1, mkrhs _3 3, _5)) ) -# 8155 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1190 "ml/parser.mly" - ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")), - [Nolabel,_1; Nolabel,_4; Nolabel,_7])) ) -# 8165 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'seq_expr) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1193 "ml/parser.mly" - ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")), - [Nolabel,_1; Nolabel,_4; Nolabel,_7])) ) -# 8175 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1196 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "[]<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _4; Nolabel, _7]) ) -# 8186 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1199 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "()<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _4; Nolabel, _7]) ) -# 8197 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1202 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "{}<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _4; Nolabel, _7]) ) -# 8208 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 8 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 6 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 5 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _9 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1205 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3,"." ^ _4 ^ "[]<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _6; Nolabel, _9]) ) -# 8220 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 8 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 6 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 5 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _9 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1208 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "()<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _6; Nolabel, _9]) ) -# 8232 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 8 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 6 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 5 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 3 : 'expr) in - let _9 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1211 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "{}<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, _1; Nolabel, _6; Nolabel, _9]) ) -# 8244 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1214 "ml/parser.mly" - ( mkexp(Pexp_setinstvar(mkrhs _1 1, _3)) ) -# 8252 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1216 "ml/parser.mly" - ( mkexp_attrs (Pexp_assert _3) _2 ) -# 8260 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1218 "ml/parser.mly" - ( mkexp_attrs (Pexp_lazy _3) _2 ) -# 8268 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_structure) in - Obj.repr( -# 1220 "ml/parser.mly" - ( mkexp_attrs (Pexp_object _3) _2 ) -# 8276 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'class_structure) in - Obj.repr( -# 1222 "ml/parser.mly" - ( unclosed "object" 1 "end" 4 ) -# 8284 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in - Obj.repr( -# 1224 "ml/parser.mly" - ( Exp.attr _1 _2 ) -# 8292 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - Obj.repr( -# 1226 "ml/parser.mly" - ( not_expecting 1 "wildcard \"_\"" ) -# 8298 "ml/parser.ml" - : 'expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'val_longident) in - Obj.repr( -# 1230 "ml/parser.mly" - ( mkexp(Pexp_ident (mkrhs _1 1)) ) -# 8305 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constant) in - Obj.repr( -# 1232 "ml/parser.mly" - ( mkexp(Pexp_constant _1) ) -# 8312 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constr_longident) in - Obj.repr( -# 1234 "ml/parser.mly" - ( mkexp(Pexp_construct(mkrhs _1 1, None)) ) -# 8319 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in - Obj.repr( -# 1236 "ml/parser.mly" - ( mkexp(Pexp_variant(_1, None)) ) -# 8326 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1238 "ml/parser.mly" - ( reloc_exp _2 ) -# 8333 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1240 "ml/parser.mly" - ( unclosed "(" 1 ")" 3 ) -# 8340 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1242 "ml/parser.mly" - ( wrap_exp_attrs (reloc_exp _3) _2 (* check location *) ) -# 8348 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in - Obj.repr( -# 1244 "ml/parser.mly" - ( mkexp_attrs (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()), - None)) _2 ) -# 8356 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1247 "ml/parser.mly" - ( unclosed "begin" 1 "end" 4 ) -# 8364 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'type_constraint) in - Obj.repr( -# 1249 "ml/parser.mly" - ( mkexp_constraint _2 _3 ) -# 8372 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'label_longident) in - Obj.repr( -# 1251 "ml/parser.mly" - ( mkexp(Pexp_field(_1, mkrhs _3 3)) ) -# 8380 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1253 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, _4)) ) -# 8388 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in - Obj.repr( -# 1255 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, - mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) ) -# 8396 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1258 "ml/parser.mly" - ( unclosed "(" 3 ")" 5 ) -# 8404 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1260 "ml/parser.mly" - ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")), - [Nolabel,_1; Nolabel,_4])) ) -# 8413 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1263 "ml/parser.mly" - ( unclosed "(" 3 ")" 5 ) -# 8421 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1265 "ml/parser.mly" - ( mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "get")), - [Nolabel,_1; Nolabel,_4])) ) -# 8430 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'seq_expr) in - Obj.repr( -# 1268 "ml/parser.mly" - ( unclosed "[" 3 "]" 5 ) -# 8438 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1270 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "[]")) in - mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _4]) ) -# 8448 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1273 "ml/parser.mly" - ( unclosed "[" 3 "]" 5 ) -# 8457 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1275 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "()")) in - mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _4]) ) -# 8467 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1278 "ml/parser.mly" - ( unclosed "(" 3 ")" 5 ) -# 8476 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1280 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ _2 ^ "{}")) in - mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _4]) ) -# 8486 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1283 "ml/parser.mly" - ( unclosed "{" 3 "}" 5 ) -# 8495 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1285 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "[]")) in - mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _6]) ) -# 8506 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1288 "ml/parser.mly" - ( unclosed "[" 5 "]" 7 ) -# 8516 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1290 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "()")) in - mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _6]) ) -# 8527 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1293 "ml/parser.mly" - ( unclosed "(" 5 ")" 7 ) -# 8537 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1295 "ml/parser.mly" - ( let id = mkexp @@ Pexp_ident( ghloc @@ Ldot(_3, "." ^ _4 ^ "{}")) in - mkexp @@ Pexp_apply(id, [Nolabel, _1; Nolabel, _6]) ) -# 8548 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'expr) in - Obj.repr( -# 1298 "ml/parser.mly" - ( unclosed "{" 5 "}" 7 ) -# 8558 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_expr) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'expr_comma_list) in - Obj.repr( -# 1300 "ml/parser.mly" - ( unclosed "{" 3 "}" 5 ) -# 8566 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in - Obj.repr( -# 1302 "ml/parser.mly" - ( let (exten, fields) = _2 in mkexp (Pexp_record(fields, exten)) ) -# 8573 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in - Obj.repr( -# 1304 "ml/parser.mly" - ( unclosed "{" 1 "}" 3 ) -# 8580 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in - Obj.repr( -# 1306 "ml/parser.mly" - ( let (exten, fields) = _4 in - let rec_exp = mkexp(Pexp_record(fields, exten)) in - mkexp(Pexp_open(Fresh, mkrhs _1 1, rec_exp)) ) -# 8590 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'record_expr) in - Obj.repr( -# 1310 "ml/parser.mly" - ( unclosed "{" 3 "}" 5 ) -# 8598 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1312 "ml/parser.mly" - ( mkexp (Pexp_array(List.rev _2)) ) -# 8606 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1314 "ml/parser.mly" - ( unclosed "[|" 1 "|]" 4 ) -# 8614 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - Obj.repr( -# 1316 "ml/parser.mly" - ( mkexp (Pexp_array []) ) -# 8620 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1318 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp(Pexp_array(List.rev _4)))) ) -# 8629 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in - Obj.repr( -# 1320 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp(Pexp_array []))) ) -# 8636 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1322 "ml/parser.mly" - ( unclosed "[|" 3 "|]" 6 ) -# 8645 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1324 "ml/parser.mly" - ( reloc_exp (mktailexp (rhs_loc 4) (List.rev _2)) ) -# 8653 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1326 "ml/parser.mly" - ( unclosed "[" 1 "]" 4 ) -# 8661 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1328 "ml/parser.mly" - ( let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev _4)) in - mkexp(Pexp_open(Fresh, mkrhs _1 1, list_exp)) ) -# 8671 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in - Obj.repr( -# 1331 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, - mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) ) -# 8679 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 5 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1334 "ml/parser.mly" - ( unclosed "[" 3 "]" 6 ) -# 8688 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1336 "ml/parser.mly" - ( mkexp(Pexp_apply(mkoperator _1 1, [Nolabel,_2])) ) -# 8696 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1338 "ml/parser.mly" - ( mkexp(Pexp_apply(mkoperator "!" 1, [Nolabel,_2])) ) -# 8703 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in - Obj.repr( -# 1340 "ml/parser.mly" - ( mkexp (Pexp_override _2) ) -# 8710 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in - Obj.repr( -# 1342 "ml/parser.mly" - ( unclosed "{<" 1 ">}" 3 ) -# 8717 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - Obj.repr( -# 1344 "ml/parser.mly" - ( mkexp (Pexp_override [])) -# 8723 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in - Obj.repr( -# 1346 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp (Pexp_override _4)))) -# 8731 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in - Obj.repr( -# 1348 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, mkexp (Pexp_override [])))) -# 8738 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr_list) in - Obj.repr( -# 1350 "ml/parser.mly" - ( unclosed "{<" 3 ">}" 5 ) -# 8746 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'label) in - Obj.repr( -# 1352 "ml/parser.mly" - ( mkexp(Pexp_send(_1, mkrhs _3 3)) ) -# 8754 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1354 "ml/parser.mly" - ( mkinfix _1 _2 _3 ) -# 8763 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'module_expr) in - Obj.repr( -# 1356 "ml/parser.mly" - ( mkexp_attrs (Pexp_pack _4) _3 ) -# 8771 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 1358 "ml/parser.mly" - ( mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack _4), - ghtyp (Ptyp_package _6))) - _3 ) -# 8782 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'module_expr) in - Obj.repr( -# 1362 "ml/parser.mly" - ( unclosed "(" 1 ")" 6 ) -# 8790 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 8 : 'mod_longident) in - let _5 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _6 = (Parsing.peek_val __caml_parser_env 3 : 'module_expr) in - let _8 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 1365 "ml/parser.mly" - ( mkexp(Pexp_open(Fresh, mkrhs _1 1, - mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack _6), - ghtyp (Ptyp_package _8))) - _5 )) ) -# 8803 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 7 : 'mod_longident) in - let _5 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _6 = (Parsing.peek_val __caml_parser_env 2 : 'module_expr) in - Obj.repr( -# 1370 "ml/parser.mly" - ( unclosed "(" 3 ")" 8 ) -# 8812 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in - Obj.repr( -# 1372 "ml/parser.mly" - ( mkexp (Pexp_extension _1) ) -# 8819 "ml/parser.ml" - : 'simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'labeled_simple_expr) in - Obj.repr( -# 1376 "ml/parser.mly" - ( [_1] ) -# 8826 "ml/parser.ml" - : 'simple_labeled_expr_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_labeled_expr_list) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'labeled_simple_expr) in - Obj.repr( -# 1378 "ml/parser.mly" - ( _2 :: _1 ) -# 8834 "ml/parser.ml" - : 'simple_labeled_expr_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1382 "ml/parser.mly" - ( (Nolabel, _1) ) -# 8841 "ml/parser.ml" - : 'labeled_simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_expr) in - Obj.repr( -# 1384 "ml/parser.mly" - ( _1 ) -# 8848 "ml/parser.ml" - : 'labeled_simple_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1388 "ml/parser.mly" - ( (Labelled _1, _2) ) -# 8856 "ml/parser.ml" - : 'label_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_ident) in - Obj.repr( -# 1390 "ml/parser.mly" - ( (Labelled (fst _2), snd _2) ) -# 8863 "ml/parser.ml" - : 'label_expr)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_ident) in - Obj.repr( -# 1392 "ml/parser.mly" - ( (Optional (fst _2), snd _2) ) -# 8870 "ml/parser.ml" - : 'label_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_expr) in - Obj.repr( -# 1394 "ml/parser.mly" - ( (Optional _1, _2) ) -# 8878 "ml/parser.ml" - : 'label_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 1397 "ml/parser.mly" - ( (_1, mkexp(Pexp_ident(mkrhs (Lident _1) 1))) ) -# 8885 "ml/parser.ml" - : 'label_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 1400 "ml/parser.mly" - ( [mkrhs _1 1] ) -# 8892 "ml/parser.ml" - : 'lident_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : string) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'lident_list) in - Obj.repr( -# 1401 "ml/parser.mly" - ( mkrhs _1 1 :: _2 ) -# 8900 "ml/parser.ml" - : 'lident_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'val_ident) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'strict_binding) in - Obj.repr( -# 1405 "ml/parser.mly" - ( (mkpatvar _1 1, _2) ) -# 8908 "ml/parser.ml" - : 'let_binding_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'val_ident) in - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'type_constraint) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1407 "ml/parser.mly" - ( let v = mkpatvar _1 1 in (* PR#7344 *) - let t = - match _2 with - Some t, None -> t - | _, Some t -> t - | _ -> assert false - in - (ghpat(Ppat_constraint(v, ghtyp(Ptyp_poly([],t)))), - mkexp_constraint _4 _2) ) -# 8925 "ml/parser.ml" - : 'let_binding_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'val_ident) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'typevar_list) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1417 "ml/parser.mly" - ( (ghpat(Ppat_constraint(mkpatvar _1 1, - ghtyp(Ptyp_poly(List.rev _3,_5)))), - _7) ) -# 8937 "ml/parser.ml" - : 'let_binding_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 7 : 'val_ident) in - let _4 = (Parsing.peek_val __caml_parser_env 4 : 'lident_list) in - let _6 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in - let _8 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1421 "ml/parser.mly" - ( let exp, poly = wrap_type_annotation _4 _6 _8 in - (ghpat(Ppat_constraint(mkpatvar _1 1, poly)), exp) ) -# 8948 "ml/parser.ml" - : 'let_binding_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1424 "ml/parser.mly" - ( (_1, _3) ) -# 8956 "ml/parser.ml" - : 'let_binding_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'simple_pattern_not_ident) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1426 "ml/parser.mly" - ( (ghpat(Ppat_constraint(_1, _3)), _5) ) -# 8965 "ml/parser.ml" - : 'let_binding_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'let_binding) in - Obj.repr( -# 1429 "ml/parser.mly" - ( _1 ) -# 8972 "ml/parser.ml" - : 'let_bindings)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'let_bindings) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_let_binding) in - Obj.repr( -# 1430 "ml/parser.mly" - ( addlb _1 _2 ) -# 8980 "ml/parser.ml" - : 'let_bindings)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'rec_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'let_binding_body) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1434 "ml/parser.mly" - ( let (ext, attr) = _2 in - mklbs ext _3 (mklb true _4 (attr@_5)) ) -# 8991 "ml/parser.ml" - : 'let_binding)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'let_binding_body) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1439 "ml/parser.mly" - ( mklb false _3 (_2@_4) ) -# 9000 "ml/parser.ml" - : 'and_let_binding)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'strict_binding) in - Obj.repr( -# 1443 "ml/parser.mly" - ( _1 ) -# 9007 "ml/parser.ml" - : 'fun_binding)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'type_constraint) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1445 "ml/parser.mly" - ( mkexp_constraint _3 _1 ) -# 9015 "ml/parser.ml" - : 'fun_binding)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1449 "ml/parser.mly" - ( _2 ) -# 9022 "ml/parser.ml" - : 'strict_binding)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'fun_binding) in - Obj.repr( -# 1451 "ml/parser.mly" - ( let (l, o, p) = _1 in ghexp(Pexp_fun(l, o, p, _2)) ) -# 9030 "ml/parser.ml" - : 'strict_binding)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'lident_list) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'fun_binding) in - Obj.repr( -# 1453 "ml/parser.mly" - ( mk_newtypes _3 _5 ) -# 9038 "ml/parser.ml" - : 'strict_binding)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'match_case) in - Obj.repr( -# 1456 "ml/parser.mly" - ( [_1] ) -# 9045 "ml/parser.ml" - : 'match_cases)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'match_cases) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'match_case) in - Obj.repr( -# 1457 "ml/parser.mly" - ( _3 :: _1 ) -# 9053 "ml/parser.ml" - : 'match_cases)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1461 "ml/parser.mly" - ( Exp.case _1 _3 ) -# 9061 "ml/parser.ml" - : 'match_case)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'seq_expr) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1463 "ml/parser.mly" - ( Exp.case _1 ~guard:_3 _5 ) -# 9070 "ml/parser.ml" - : 'match_case)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - Obj.repr( -# 1465 "ml/parser.mly" - ( Exp.case _1 (Exp.unreachable ~loc:(rhs_loc 3) ())) -# 9077 "ml/parser.ml" - : 'match_case)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1469 "ml/parser.mly" - ( _2 ) -# 9084 "ml/parser.ml" - : 'fun_def)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 1471 "ml/parser.mly" - ( mkexp (Pexp_constraint (_4, _2)) ) -# 9092 "ml/parser.ml" - : 'fun_def)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'labeled_simple_pattern) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in - Obj.repr( -# 1474 "ml/parser.mly" - ( - let (l,o,p) = _1 in - ghexp(Pexp_fun(l, o, p, _2)) - ) -# 9103 "ml/parser.ml" - : 'fun_def)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'lident_list) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'fun_def) in - Obj.repr( -# 1479 "ml/parser.mly" - ( mk_newtypes _3 _5 ) -# 9111 "ml/parser.ml" - : 'fun_def)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr_comma_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1482 "ml/parser.mly" - ( _3 :: _1 ) -# 9119 "ml/parser.ml" - : 'expr_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1483 "ml/parser.mly" - ( [_3; _1] ) -# 9127 "ml/parser.ml" - : 'expr_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr_list) in - Obj.repr( -# 1486 "ml/parser.mly" - ( (Some _1, _3) ) -# 9135 "ml/parser.ml" - : 'record_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr_list) in - Obj.repr( -# 1487 "ml/parser.mly" - ( (None, _1) ) -# 9142 "ml/parser.ml" - : 'record_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr) in - Obj.repr( -# 1490 "ml/parser.mly" - ( [_1] ) -# 9149 "ml/parser.ml" - : 'lbl_expr_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'lbl_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_expr_list) in - Obj.repr( -# 1491 "ml/parser.mly" - ( _1 :: _3 ) -# 9157 "ml/parser.ml" - : 'lbl_expr_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_expr) in - Obj.repr( -# 1492 "ml/parser.mly" - ( [_1] ) -# 9164 "ml/parser.ml" - : 'lbl_expr_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'label_longident) in - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_type_constraint) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1496 "ml/parser.mly" - ( (mkrhs _1 1, mkexp_opt_constraint _4 _2) ) -# 9173 "ml/parser.ml" - : 'lbl_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label_longident) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_type_constraint) in - Obj.repr( -# 1498 "ml/parser.mly" - ( (mkrhs _1 1, mkexp_opt_constraint (exp_of_label _1 1) _2) ) -# 9181 "ml/parser.ml" - : 'lbl_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'field_expr) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_semi) in - Obj.repr( -# 1501 "ml/parser.mly" - ( [_1] ) -# 9189 "ml/parser.ml" - : 'field_expr_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'field_expr) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'field_expr_list) in - Obj.repr( -# 1502 "ml/parser.mly" - ( _1 :: _3 ) -# 9197 "ml/parser.ml" - : 'field_expr_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'label) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1506 "ml/parser.mly" - ( (mkrhs _1 1, _3) ) -# 9205 "ml/parser.ml" - : 'field_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label) in - Obj.repr( -# 1508 "ml/parser.mly" - ( (mkrhs _1 1, exp_of_label (Lident _1) 1) ) -# 9212 "ml/parser.ml" - : 'field_expr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1511 "ml/parser.mly" - ( [_1] ) -# 9219 "ml/parser.ml" - : 'expr_semi_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'expr_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'expr) in - Obj.repr( -# 1512 "ml/parser.mly" - ( _3 :: _1 ) -# 9227 "ml/parser.ml" - : 'expr_semi_list)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1515 "ml/parser.mly" - ( (Some _2, None) ) -# 9234 "ml/parser.ml" - : 'type_constraint)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1516 "ml/parser.mly" - ( (Some _2, Some _4) ) -# 9242 "ml/parser.ml" - : 'type_constraint)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1517 "ml/parser.mly" - ( (None, Some _2) ) -# 9249 "ml/parser.ml" - : 'type_constraint)) -; (fun __caml_parser_env -> - Obj.repr( -# 1518 "ml/parser.mly" - ( syntax_error() ) -# 9255 "ml/parser.ml" - : 'type_constraint)) -; (fun __caml_parser_env -> - Obj.repr( -# 1519 "ml/parser.mly" - ( syntax_error() ) -# 9261 "ml/parser.ml" - : 'type_constraint)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_constraint) in - Obj.repr( -# 1522 "ml/parser.mly" - ( Some _1 ) -# 9268 "ml/parser.ml" - : 'opt_type_constraint)) -; (fun __caml_parser_env -> - Obj.repr( -# 1523 "ml/parser.mly" - ( None ) -# 9274 "ml/parser.ml" - : 'opt_type_constraint)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in - Obj.repr( -# 1530 "ml/parser.mly" - ( mkpat(Ppat_alias(_1, mkrhs _3 3)) ) -# 9282 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - Obj.repr( -# 1532 "ml/parser.mly" - ( expecting 3 "identifier" ) -# 9289 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_comma_list) in - Obj.repr( -# 1534 "ml/parser.mly" - ( mkpat(Ppat_tuple(List.rev _1)) ) -# 9296 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1536 "ml/parser.mly" - ( mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[_1;_3])) (symbol_rloc()) ) -# 9304 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - Obj.repr( -# 1538 "ml/parser.mly" - ( expecting 3 "pattern" ) -# 9311 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1540 "ml/parser.mly" - ( mkpat(Ppat_or(_1, _3)) ) -# 9319 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - Obj.repr( -# 1542 "ml/parser.mly" - ( expecting 3 "pattern" ) -# 9326 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1544 "ml/parser.mly" - ( mkpat_attrs (Ppat_exception _3) _2) -# 9334 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in - Obj.repr( -# 1546 "ml/parser.mly" - ( Pat.attr _1 _2 ) -# 9342 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_gen) in - Obj.repr( -# 1547 "ml/parser.mly" - ( _1 ) -# 9349 "ml/parser.ml" - : 'pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in - Obj.repr( -# 1551 "ml/parser.mly" - ( mkpat(Ppat_alias(_1, mkrhs _3 3)) ) -# 9357 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - Obj.repr( -# 1553 "ml/parser.mly" - ( expecting 3 "identifier" ) -# 9364 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_no_exn_comma_list) in - Obj.repr( -# 1555 "ml/parser.mly" - ( mkpat(Ppat_tuple(List.rev _1)) ) -# 9371 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1557 "ml/parser.mly" - ( mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[_1;_3])) (symbol_rloc()) ) -# 9379 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - Obj.repr( -# 1559 "ml/parser.mly" - ( expecting 3 "pattern" ) -# 9386 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1561 "ml/parser.mly" - ( mkpat(Ppat_or(_1, _3)) ) -# 9394 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - Obj.repr( -# 1563 "ml/parser.mly" - ( expecting 3 "pattern" ) -# 9401 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'pattern_no_exn) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in - Obj.repr( -# 1565 "ml/parser.mly" - ( Pat.attr _1 _2 ) -# 9409 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern_gen) in - Obj.repr( -# 1566 "ml/parser.mly" - ( _1 ) -# 9416 "ml/parser.ml" - : 'pattern_no_exn)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in - Obj.repr( -# 1570 "ml/parser.mly" - ( _1 ) -# 9423 "ml/parser.ml" - : 'pattern_gen)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1572 "ml/parser.mly" - ( mkpat(Ppat_construct(mkrhs _1 1, Some _2)) ) -# 9431 "ml/parser.ml" - : 'pattern_gen)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1574 "ml/parser.mly" - ( mkpat(Ppat_variant(_1, Some _2)) ) -# 9439 "ml/parser.ml" - : 'pattern_gen)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern) in - Obj.repr( -# 1576 "ml/parser.mly" - ( mkpat_attrs (Ppat_lazy _3) _2) -# 9447 "ml/parser.ml" - : 'pattern_gen)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in - Obj.repr( -# 1580 "ml/parser.mly" - ( mkpat(Ppat_var (mkrhs _1 1)) ) -# 9454 "ml/parser.ml" - : 'simple_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_pattern_not_ident) in - Obj.repr( -# 1581 "ml/parser.mly" - ( _1 ) -# 9461 "ml/parser.ml" - : 'simple_pattern)) -; (fun __caml_parser_env -> - Obj.repr( -# 1585 "ml/parser.mly" - ( mkpat(Ppat_any) ) -# 9467 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'signed_constant) in - Obj.repr( -# 1587 "ml/parser.mly" - ( mkpat(Ppat_constant _1) ) -# 9474 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'signed_constant) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'signed_constant) in - Obj.repr( -# 1589 "ml/parser.mly" - ( mkpat(Ppat_interval (_1, _3)) ) -# 9482 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constr_longident) in - Obj.repr( -# 1591 "ml/parser.mly" - ( mkpat(Ppat_construct(mkrhs _1 1, None)) ) -# 9489 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in - Obj.repr( -# 1593 "ml/parser.mly" - ( mkpat(Ppat_variant(_1, None)) ) -# 9496 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in - Obj.repr( -# 1595 "ml/parser.mly" - ( mkpat(Ppat_type (mkrhs _2 2)) ) -# 9503 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_delimited_pattern) in - Obj.repr( -# 1597 "ml/parser.mly" - ( _1 ) -# 9510 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_delimited_pattern) in - Obj.repr( -# 1599 "ml/parser.mly" - ( mkpat @@ Ppat_open(mkrhs _1 1, _3) ) -# 9518 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in - Obj.repr( -# 1601 "ml/parser.mly" - ( mkpat @@ Ppat_open(mkrhs _1 1, mkpat @@ - Ppat_construct ( mkrhs (Lident "[]") 4, None)) ) -# 9526 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in - Obj.repr( -# 1604 "ml/parser.mly" - ( mkpat @@ Ppat_open( mkrhs _1 1, mkpat @@ - Ppat_construct ( mkrhs (Lident "()") 4, None) ) ) -# 9534 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in - Obj.repr( -# 1607 "ml/parser.mly" - ( mkpat @@ Ppat_open (mkrhs _1 1, _4)) -# 9542 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in - Obj.repr( -# 1609 "ml/parser.mly" - (unclosed "(" 3 ")" 5 ) -# 9550 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_longident) in - Obj.repr( -# 1611 "ml/parser.mly" - ( expecting 4 "pattern" ) -# 9557 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in - Obj.repr( -# 1613 "ml/parser.mly" - ( reloc_pat _2 ) -# 9564 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pattern) in - Obj.repr( -# 1615 "ml/parser.mly" - ( unclosed "(" 1 ")" 3 ) -# 9571 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in - Obj.repr( -# 1617 "ml/parser.mly" - ( mkpat(Ppat_constraint(_2, _4)) ) -# 9579 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in - Obj.repr( -# 1619 "ml/parser.mly" - ( unclosed "(" 1 ")" 5 ) -# 9587 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - Obj.repr( -# 1621 "ml/parser.mly" - ( expecting 4 "type" ) -# 9594 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : string) in - Obj.repr( -# 1623 "ml/parser.mly" - ( mkpat_attrs (Ppat_unpack (mkrhs _4 4)) _3 ) -# 9602 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 1625 "ml/parser.mly" - ( mkpat_attrs - (Ppat_constraint(mkpat(Ppat_unpack (mkrhs _4 4)), - ghtyp(Ptyp_package _6))) - _3 ) -# 9614 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 1630 "ml/parser.mly" - ( unclosed "(" 1 ")" 7 ) -# 9623 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in - Obj.repr( -# 1632 "ml/parser.mly" - ( mkpat(Ppat_extension _1) ) -# 9630 "ml/parser.ml" - : 'simple_pattern_not_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_pattern_list) in - Obj.repr( -# 1637 "ml/parser.mly" - ( let (fields, closed) = _2 in mkpat(Ppat_record(fields, closed)) ) -# 9637 "ml/parser.ml" - : 'simple_delimited_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_pattern_list) in - Obj.repr( -# 1639 "ml/parser.mly" - ( unclosed "{" 1 "}" 3 ) -# 9644 "ml/parser.ml" - : 'simple_delimited_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1641 "ml/parser.mly" - ( reloc_pat (mktailpat (rhs_loc 4) (List.rev _2)) ) -# 9652 "ml/parser.ml" - : 'simple_delimited_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1643 "ml/parser.mly" - ( unclosed "[" 1 "]" 4 ) -# 9660 "ml/parser.ml" - : 'simple_delimited_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1645 "ml/parser.mly" - ( mkpat(Ppat_array(List.rev _2)) ) -# 9668 "ml/parser.ml" - : 'simple_delimited_pattern)) -; (fun __caml_parser_env -> - Obj.repr( -# 1647 "ml/parser.mly" - ( mkpat(Ppat_array []) ) -# 9674 "ml/parser.ml" - : 'simple_delimited_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'opt_semi) in - Obj.repr( -# 1649 "ml/parser.mly" - ( unclosed "[|" 1 "|]" 4 ) -# 9682 "ml/parser.ml" - : 'simple_delimited_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_comma_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1652 "ml/parser.mly" - ( _3 :: _1 ) -# 9690 "ml/parser.ml" - : 'pattern_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1653 "ml/parser.mly" - ( [_3; _1] ) -# 9698 "ml/parser.ml" - : 'pattern_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - Obj.repr( -# 1654 "ml/parser.mly" - ( expecting 3 "pattern" ) -# 9705 "ml/parser.ml" - : 'pattern_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn_comma_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1657 "ml/parser.mly" - ( _3 :: _1 ) -# 9713 "ml/parser.ml" - : 'pattern_no_exn_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1658 "ml/parser.mly" - ( [_3; _1] ) -# 9721 "ml/parser.ml" - : 'pattern_no_exn_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_no_exn) in - Obj.repr( -# 1659 "ml/parser.mly" - ( expecting 3 "pattern" ) -# 9728 "ml/parser.ml" - : 'pattern_no_exn_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1662 "ml/parser.mly" - ( [_1] ) -# 9735 "ml/parser.ml" - : 'pattern_semi_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'pattern_semi_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1663 "ml/parser.mly" - ( _3 :: _1 ) -# 9743 "ml/parser.ml" - : 'pattern_semi_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_pattern) in - Obj.repr( -# 1666 "ml/parser.mly" - ( [_1], Closed ) -# 9750 "ml/parser.ml" - : 'lbl_pattern_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'lbl_pattern) in - Obj.repr( -# 1667 "ml/parser.mly" - ( [_1], Closed ) -# 9757 "ml/parser.ml" - : 'lbl_pattern_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'lbl_pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'opt_semi) in - Obj.repr( -# 1668 "ml/parser.mly" - ( [_1], Open ) -# 9765 "ml/parser.ml" - : 'lbl_pattern_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'lbl_pattern) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'lbl_pattern_list) in - Obj.repr( -# 1670 "ml/parser.mly" - ( let (fields, closed) = _3 in _1 :: fields, closed ) -# 9773 "ml/parser.ml" - : 'lbl_pattern_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'label_longident) in - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_pattern_type_constraint) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 1674 "ml/parser.mly" - ( (mkrhs _1 1, mkpat_opt_constraint _4 _2) ) -# 9782 "ml/parser.ml" - : 'lbl_pattern)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label_longident) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'opt_pattern_type_constraint) in - Obj.repr( -# 1676 "ml/parser.mly" - ( (mkrhs _1 1, mkpat_opt_constraint (pat_of_label _1 1) _2) ) -# 9790 "ml/parser.ml" - : 'lbl_pattern)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1679 "ml/parser.mly" - ( Some _2 ) -# 9797 "ml/parser.ml" - : 'opt_pattern_type_constraint)) -; (fun __caml_parser_env -> - Obj.repr( -# 1680 "ml/parser.mly" - ( None ) -# 9803 "ml/parser.ml" - : 'opt_pattern_type_constraint)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'val_ident) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1687 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Val.mk (mkrhs _3 3) _5 ~attrs:(attrs@_6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext ) -# 9816 "ml/parser.ml" - : 'value_description)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string * string option) in - Obj.repr( -# 1696 "ml/parser.mly" - ( [fst _1] ) -# 9823 "ml/parser.ml" - : 'primitive_declaration_body)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : string * string option) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'primitive_declaration_body) in - Obj.repr( -# 1697 "ml/parser.mly" - ( fst _1 :: _2 ) -# 9831 "ml/parser.ml" - : 'primitive_declaration_body)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 6 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 5 : 'val_ident) in - let _5 = (Parsing.peek_val __caml_parser_env 3 : 'core_type) in - let _7 = (Parsing.peek_val __caml_parser_env 1 : 'primitive_declaration_body) in - let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1702 "ml/parser.mly" - ( let (ext, attrs) = _2 in - Val.mk (mkrhs _3 3) _5 ~prim:_7 ~attrs:(attrs@_8) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext ) -# 9845 "ml/parser.ml" - : 'primitive_declaration)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_declaration) in - Obj.repr( -# 1712 "ml/parser.mly" - ( let (nonrec_flag, ty, ext) = _1 in (nonrec_flag, [ty], ext) ) -# 9852 "ml/parser.ml" - : 'type_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'type_declarations) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'and_type_declaration) in - Obj.repr( -# 1714 "ml/parser.mly" - ( let (nonrec_flag, tys, ext) = _1 in (nonrec_flag, _2 :: tys, ext) ) -# 9860 "ml/parser.ml" - : 'type_declarations)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 6 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 5 : 'nonrec_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 4 : 'optional_type_parameters) in - let _5 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _6 = (Parsing.peek_val __caml_parser_env 2 : 'type_kind) in - let _7 = (Parsing.peek_val __caml_parser_env 1 : 'constraints) in - let _8 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1720 "ml/parser.mly" - ( let (kind, priv, manifest) = _6 in - let (ext, attrs) = _2 in - let ty = - Type.mk (mkrhs _5 5) ~params:_4 ~cstrs:(List.rev _7) ~kind - ~priv ?manifest ~attrs:(attrs@_8) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - in - (_3, ty, ext) ) -# 9880 "ml/parser.ml" - : 'type_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'optional_type_parameters) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'type_kind) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'constraints) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1732 "ml/parser.mly" - ( let (kind, priv, manifest) = _5 in - Type.mk (mkrhs _4 4) ~params:_3 ~cstrs:(List.rev _6) - ~kind ~priv ?manifest ~attrs:(_2@_7) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) ) -# 9895 "ml/parser.ml" - : 'and_type_declaration)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constraints) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'constrain) in - Obj.repr( -# 1738 "ml/parser.mly" - ( _3 :: _1 ) -# 9903 "ml/parser.ml" - : 'constraints)) -; (fun __caml_parser_env -> - Obj.repr( -# 1739 "ml/parser.mly" - ( [] ) -# 9909 "ml/parser.ml" - : 'constraints)) -; (fun __caml_parser_env -> - Obj.repr( -# 1743 "ml/parser.mly" - ( (Ptype_abstract, Public, None) ) -# 9915 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1745 "ml/parser.mly" - ( (Ptype_abstract, Public, Some _2) ) -# 9922 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1747 "ml/parser.mly" - ( (Ptype_abstract, Private, Some _3) ) -# 9929 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declarations) in - Obj.repr( -# 1749 "ml/parser.mly" - ( (Ptype_variant(List.rev _2), Public, None) ) -# 9936 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declarations) in - Obj.repr( -# 1751 "ml/parser.mly" - ( (Ptype_variant(List.rev _3), Private, None) ) -# 9943 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - Obj.repr( -# 1753 "ml/parser.mly" - ( (Ptype_open, Public, None) ) -# 9949 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - Obj.repr( -# 1755 "ml/parser.mly" - ( (Ptype_open, Private, None) ) -# 9955 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'private_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'label_declarations) in - Obj.repr( -# 1757 "ml/parser.mly" - ( (Ptype_record _4, _2, None) ) -# 9963 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'core_type) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'private_flag) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declarations) in - Obj.repr( -# 1759 "ml/parser.mly" - ( (Ptype_variant(List.rev _5), _4, Some _2) ) -# 9972 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'core_type) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'private_flag) in - Obj.repr( -# 1761 "ml/parser.mly" - ( (Ptype_open, _4, Some _2) ) -# 9980 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'core_type) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'private_flag) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'label_declarations) in - Obj.repr( -# 1763 "ml/parser.mly" - ( (Ptype_record _6, _4, Some _2) ) -# 9989 "ml/parser.ml" - : 'type_kind)) -; (fun __caml_parser_env -> - Obj.repr( -# 1766 "ml/parser.mly" - ( [] ) -# 9995 "ml/parser.ml" - : 'optional_type_parameters)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_parameter) in - Obj.repr( -# 1767 "ml/parser.mly" - ( [_1] ) -# 10002 "ml/parser.ml" - : 'optional_type_parameters)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'optional_type_parameter_list) in - Obj.repr( -# 1768 "ml/parser.mly" - ( List.rev _2 ) -# 10009 "ml/parser.ml" - : 'optional_type_parameters)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'type_variance) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_variable) in - Obj.repr( -# 1771 "ml/parser.mly" - ( _2, _1 ) -# 10017 "ml/parser.ml" - : 'optional_type_parameter)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_parameter) in - Obj.repr( -# 1774 "ml/parser.mly" - ( [_1] ) -# 10024 "ml/parser.ml" - : 'optional_type_parameter_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'optional_type_parameter_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'optional_type_parameter) in - Obj.repr( -# 1775 "ml/parser.mly" - ( _3 :: _1 ) -# 10032 "ml/parser.ml" - : 'optional_type_parameter_list)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 1778 "ml/parser.mly" - ( mktyp(Ptyp_var _2) ) -# 10039 "ml/parser.ml" - : 'optional_type_variable)) -; (fun __caml_parser_env -> - Obj.repr( -# 1779 "ml/parser.mly" - ( mktyp(Ptyp_any) ) -# 10045 "ml/parser.ml" - : 'optional_type_variable)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'type_variance) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'type_variable) in - Obj.repr( -# 1784 "ml/parser.mly" - ( _2, _1 ) -# 10053 "ml/parser.ml" - : 'type_parameter)) -; (fun __caml_parser_env -> - Obj.repr( -# 1787 "ml/parser.mly" - ( Invariant ) -# 10059 "ml/parser.ml" - : 'type_variance)) -; (fun __caml_parser_env -> - Obj.repr( -# 1788 "ml/parser.mly" - ( Covariant ) -# 10065 "ml/parser.ml" - : 'type_variance)) -; (fun __caml_parser_env -> - Obj.repr( -# 1789 "ml/parser.mly" - ( Contravariant ) -# 10071 "ml/parser.ml" - : 'type_variance)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 1792 "ml/parser.mly" - ( mktyp(Ptyp_var _2) ) -# 10078 "ml/parser.ml" - : 'type_variable)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_parameter) in - Obj.repr( -# 1795 "ml/parser.mly" - ( [_1] ) -# 10085 "ml/parser.ml" - : 'type_parameter_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'type_parameter_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'type_parameter) in - Obj.repr( -# 1796 "ml/parser.mly" - ( _3 :: _1 ) -# 10093 "ml/parser.ml" - : 'type_parameter_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_declaration) in - Obj.repr( -# 1799 "ml/parser.mly" - ( [_1] ) -# 10100 "ml/parser.ml" - : 'constructor_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_constructor_declaration) in - Obj.repr( -# 1800 "ml/parser.mly" - ( [_1] ) -# 10107 "ml/parser.ml" - : 'constructor_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'constructor_declarations) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_constructor_declaration) in - Obj.repr( -# 1801 "ml/parser.mly" - ( _2 :: _1 ) -# 10115 "ml/parser.ml" - : 'constructor_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1805 "ml/parser.mly" - ( - let args,res = _2 in - Type.constructor (mkrhs _1 1) ~args ?res ~attrs:_3 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) - ) -# 10128 "ml/parser.ml" - : 'constructor_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1813 "ml/parser.mly" - ( - let args,res = _3 in - Type.constructor (mkrhs _2 2) ~args ?res ~attrs:_4 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) - ) -# 10141 "ml/parser.ml" - : 'bar_constructor_declaration)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'sig_exception_declaration) in - Obj.repr( -# 1820 "ml/parser.mly" - ( _1 ) -# 10148 "ml/parser.ml" - : 'str_exception_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 4 : 'constr_ident) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'constr_longident) in - let _6 = (Parsing.peek_val __caml_parser_env 1 : 'attributes) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1823 "ml/parser.mly" - ( let (ext,attrs) = _2 in - Te.rebind (mkrhs _3 3) (mkrhs _5 5) ~attrs:(attrs @ _6 @ _7) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext ) -# 10162 "ml/parser.ml" - : 'str_exception_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'constr_ident) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'generalized_constructor_arguments) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'attributes) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1831 "ml/parser.mly" - ( let args, res = _4 in - let (ext,attrs) = _2 in - Te.decl (mkrhs _3 3) ~args ?res ~attrs:(attrs @ _5 @ _6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext ) -# 10177 "ml/parser.ml" - : 'sig_exception_declaration)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1839 "ml/parser.mly" - ( let args, res = _2 in - Te.decl (mkrhs _1 1) ~args ?res ~attrs:_3 ~loc:(symbol_rloc()) ) -# 10187 "ml/parser.ml" - : 'let_exception_declaration)) -; (fun __caml_parser_env -> - Obj.repr( -# 1843 "ml/parser.mly" - ( (Pcstr_tuple [],None) ) -# 10193 "ml/parser.ml" - : 'generalized_constructor_arguments)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'constructor_arguments) in - Obj.repr( -# 1844 "ml/parser.mly" - ( (_2,None) ) -# 10200 "ml/parser.ml" - : 'generalized_constructor_arguments)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'constructor_arguments) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in - Obj.repr( -# 1846 "ml/parser.mly" - ( (_2,Some _4) ) -# 10208 "ml/parser.ml" - : 'generalized_constructor_arguments)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in - Obj.repr( -# 1848 "ml/parser.mly" - ( (Pcstr_tuple [],Some _2) ) -# 10215 "ml/parser.ml" - : 'generalized_constructor_arguments)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_list) in - Obj.repr( -# 1852 "ml/parser.mly" - ( Pcstr_tuple (List.rev _1) ) -# 10222 "ml/parser.ml" - : 'constructor_arguments)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'label_declarations) in - Obj.repr( -# 1853 "ml/parser.mly" - ( Pcstr_record _2 ) -# 10229 "ml/parser.ml" - : 'constructor_arguments)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_declaration) in - Obj.repr( -# 1856 "ml/parser.mly" - ( [_1] ) -# 10236 "ml/parser.ml" - : 'label_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'label_declaration_semi) in - Obj.repr( -# 1857 "ml/parser.mly" - ( [_1] ) -# 10243 "ml/parser.ml" - : 'label_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'label_declaration_semi) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'label_declarations) in - Obj.repr( -# 1858 "ml/parser.mly" - ( _1 :: _2 ) -# 10251 "ml/parser.ml" - : 'label_declarations)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mutable_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'label) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'poly_type_no_attr) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1862 "ml/parser.mly" - ( - Type.field (mkrhs _2 2) _4 ~mut:_1 ~attrs:_5 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) - ) -# 10264 "ml/parser.ml" - : 'label_declaration)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 6 : 'mutable_flag) in - let _2 = (Parsing.peek_val __caml_parser_env 5 : 'label) in - let _4 = (Parsing.peek_val __caml_parser_env 3 : 'poly_type_no_attr) in - let _5 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _7 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1869 "ml/parser.mly" - ( - let info = - match rhs_info 5 with - | Some _ as info_before_semi -> info_before_semi - | None -> symbol_info () - in - Type.field (mkrhs _2 2) _4 ~mut:_1 ~attrs:(_5 @ _7) - ~loc:(symbol_rloc()) ~info - ) -# 10283 "ml/parser.ml" - : 'label_declaration_semi)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 7 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 6 : 'nonrec_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 5 : 'optional_type_parameters) in - let _5 = (Parsing.peek_val __caml_parser_env 4 : 'type_longident) in - let _7 = (Parsing.peek_val __caml_parser_env 2 : 'private_flag) in - let _8 = (Parsing.peek_val __caml_parser_env 1 : 'str_extension_constructors) in - let _9 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1885 "ml/parser.mly" - ( let (ext, attrs) = _2 in - if _3 <> Recursive then not_expecting 3 "nonrec flag"; - Te.mk (mkrhs _5 5) (List.rev _8) ~params:_4 ~priv:_7 - ~attrs:(attrs@_9) ~docs:(symbol_docs ()) - , ext ) -# 10300 "ml/parser.ml" - : 'str_type_extension)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 7 : 'ext_attributes) in - let _3 = (Parsing.peek_val __caml_parser_env 6 : 'nonrec_flag) in - let _4 = (Parsing.peek_val __caml_parser_env 5 : 'optional_type_parameters) in - let _5 = (Parsing.peek_val __caml_parser_env 4 : 'type_longident) in - let _7 = (Parsing.peek_val __caml_parser_env 2 : 'private_flag) in - let _8 = (Parsing.peek_val __caml_parser_env 1 : 'sig_extension_constructors) in - let _9 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 1894 "ml/parser.mly" - ( let (ext, attrs) = _2 in - if _3 <> Recursive then not_expecting 3 "nonrec flag"; - Te.mk (mkrhs _5 5) (List.rev _8) ~params:_4 ~priv:_7 - ~attrs:(attrs @ _9) ~docs:(symbol_docs ()) - , ext ) -# 10317 "ml/parser.ml" - : 'sig_type_extension)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension_constructor_declaration) in - Obj.repr( -# 1901 "ml/parser.mly" - ( [_1] ) -# 10324 "ml/parser.ml" - : 'str_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in - Obj.repr( -# 1902 "ml/parser.mly" - ( [_1] ) -# 10331 "ml/parser.ml" - : 'str_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension_constructor_rebind) in - Obj.repr( -# 1903 "ml/parser.mly" - ( [_1] ) -# 10338 "ml/parser.ml" - : 'str_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_rebind) in - Obj.repr( -# 1904 "ml/parser.mly" - ( [_1] ) -# 10345 "ml/parser.ml" - : 'str_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'str_extension_constructors) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in - Obj.repr( -# 1906 "ml/parser.mly" - ( _2 :: _1 ) -# 10353 "ml/parser.ml" - : 'str_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'str_extension_constructors) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_rebind) in - Obj.repr( -# 1908 "ml/parser.mly" - ( _2 :: _1 ) -# 10361 "ml/parser.ml" - : 'str_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension_constructor_declaration) in - Obj.repr( -# 1911 "ml/parser.mly" - ( [_1] ) -# 10368 "ml/parser.ml" - : 'sig_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in - Obj.repr( -# 1912 "ml/parser.mly" - ( [_1] ) -# 10375 "ml/parser.ml" - : 'sig_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'sig_extension_constructors) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'bar_extension_constructor_declaration) in - Obj.repr( -# 1914 "ml/parser.mly" - ( _2 :: _1 ) -# 10383 "ml/parser.ml" - : 'sig_extension_constructors)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1918 "ml/parser.mly" - ( let args, res = _2 in - Te.decl (mkrhs _1 1) ~args ?res ~attrs:_3 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) ) -# 10394 "ml/parser.ml" - : 'extension_constructor_declaration)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'constr_ident) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'generalized_constructor_arguments) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1924 "ml/parser.mly" - ( let args, res = _3 in - Te.decl (mkrhs _2 2) ~args ?res ~attrs:_4 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) ) -# 10405 "ml/parser.ml" - : 'bar_extension_constructor_declaration)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'constr_ident) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1930 "ml/parser.mly" - ( Te.rebind (mkrhs _1 1) (mkrhs _3 3) ~attrs:_4 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) ) -# 10415 "ml/parser.ml" - : 'extension_constructor_rebind)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'constr_ident) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'constr_longident) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 1935 "ml/parser.mly" - ( Te.rebind (mkrhs _2 2) (mkrhs _4 4) ~attrs:_5 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) ) -# 10425 "ml/parser.ml" - : 'bar_extension_constructor_rebind)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'with_constraint) in - Obj.repr( -# 1942 "ml/parser.mly" - ( [_1] ) -# 10432 "ml/parser.ml" - : 'with_constraints)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'with_constraints) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'with_constraint) in - Obj.repr( -# 1943 "ml/parser.mly" - ( _3 :: _1 ) -# 10440 "ml/parser.ml" - : 'with_constraints)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'optional_type_parameters) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'label_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'with_type_binder) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'core_type_no_attr) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'constraints) in - Obj.repr( -# 1948 "ml/parser.mly" - ( Pwith_type - (mkrhs _3 3, - (Type.mk (mkrhs (Longident.last _3) 3) - ~params:_2 - ~cstrs:(List.rev _6) - ~manifest:_5 - ~priv:_4 - ~loc:(symbol_rloc()))) ) -# 10458 "ml/parser.ml" - : 'with_constraint)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'optional_type_parameters) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'label_longident) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in - Obj.repr( -# 1959 "ml/parser.mly" - ( Pwith_typesubst - (mkrhs _3 3, - (Type.mk (mkrhs (Longident.last _3) 3) - ~params:_2 - ~manifest:_5 - ~loc:(symbol_rloc()))) ) -# 10472 "ml/parser.ml" - : 'with_constraint)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'mod_ext_longident) in - Obj.repr( -# 1966 "ml/parser.mly" - ( Pwith_module (mkrhs _2 2, mkrhs _4 4) ) -# 10480 "ml/parser.ml" - : 'with_constraint)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'mod_ext_longident) in - Obj.repr( -# 1968 "ml/parser.mly" - ( Pwith_modsubst (mkrhs _2 2, mkrhs _4 4) ) -# 10488 "ml/parser.ml" - : 'with_constraint)) -; (fun __caml_parser_env -> - Obj.repr( -# 1971 "ml/parser.mly" - ( Public ) -# 10494 "ml/parser.ml" - : 'with_type_binder)) -; (fun __caml_parser_env -> - Obj.repr( -# 1972 "ml/parser.mly" - ( Private ) -# 10500 "ml/parser.ml" - : 'with_type_binder)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 1978 "ml/parser.mly" - ( [mkrhs _2 2] ) -# 10507 "ml/parser.ml" - : 'typevar_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'typevar_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 1979 "ml/parser.mly" - ( mkrhs _3 3 :: _1 ) -# 10515 "ml/parser.ml" - : 'typevar_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1983 "ml/parser.mly" - ( _1 ) -# 10522 "ml/parser.ml" - : 'poly_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'typevar_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 1985 "ml/parser.mly" - ( mktyp(Ptyp_poly(List.rev _1, _3)) ) -# 10530 "ml/parser.ml" - : 'poly_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in - Obj.repr( -# 1989 "ml/parser.mly" - ( _1 ) -# 10537 "ml/parser.ml" - : 'poly_type_no_attr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'typevar_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in - Obj.repr( -# 1991 "ml/parser.mly" - ( mktyp(Ptyp_poly(List.rev _1, _3)) ) -# 10545 "ml/parser.ml" - : 'poly_type_no_attr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in - Obj.repr( -# 1998 "ml/parser.mly" - ( _1 ) -# 10552 "ml/parser.ml" - : 'core_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'core_type) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attribute) in - Obj.repr( -# 2000 "ml/parser.mly" - ( Typ.attr _1 _2 ) -# 10560 "ml/parser.ml" - : 'core_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in - Obj.repr( -# 2004 "ml/parser.mly" - ( _1 ) -# 10567 "ml/parser.ml" - : 'core_type_no_attr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'core_type2) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 2006 "ml/parser.mly" - ( mktyp(Ptyp_alias(_1, _4)) ) -# 10575 "ml/parser.ml" - : 'core_type_no_attr)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type_or_tuple) in - Obj.repr( -# 2010 "ml/parser.mly" - ( _1 ) -# 10582 "ml/parser.ml" - : 'core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : string) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in - Obj.repr( -# 2012 "ml/parser.mly" - ( let param = extra_rhs_core_type _4 ~pos:4 in - mktyp (Ptyp_arrow(Optional _2 , param, _6)) ) -# 10592 "ml/parser.ml" - : 'core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in - Obj.repr( -# 2015 "ml/parser.mly" - ( let param = extra_rhs_core_type _2 ~pos:2 in - mktyp(Ptyp_arrow(Optional _1 , param, _4)) - ) -# 10603 "ml/parser.ml" - : 'core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in - Obj.repr( -# 2019 "ml/parser.mly" - ( let param = extra_rhs_core_type _3 ~pos:3 in - mktyp(Ptyp_arrow(Labelled _1, param, _5)) ) -# 10613 "ml/parser.ml" - : 'core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type2) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type2) in - Obj.repr( -# 2022 "ml/parser.mly" - ( let param = extra_rhs_core_type _1 ~pos:1 in - mktyp(Ptyp_arrow(Nolabel, param, _3)) ) -# 10622 "ml/parser.ml" - : 'core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type2) in - Obj.repr( -# 2028 "ml/parser.mly" - ( _1 ) -# 10629 "ml/parser.ml" - : 'simple_core_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'core_type_comma_list) in - Obj.repr( -# 2030 "ml/parser.mly" - ( match _2 with [sty] -> sty | _ -> raise Parse_error ) -# 10636 "ml/parser.ml" - : 'simple_core_type)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 2035 "ml/parser.mly" - ( mktyp(Ptyp_var _2) ) -# 10643 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - Obj.repr( -# 2037 "ml/parser.mly" - ( mktyp(Ptyp_any) ) -# 10649 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in - Obj.repr( -# 2039 "ml/parser.mly" - ( mktyp(Ptyp_constr(mkrhs _1 1, [])) ) -# 10656 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_core_type2) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in - Obj.repr( -# 2041 "ml/parser.mly" - ( mktyp(Ptyp_constr(mkrhs _2 2, [_1])) ) -# 10664 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_comma_list) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'type_longident) in - Obj.repr( -# 2043 "ml/parser.mly" - ( mktyp(Ptyp_constr(mkrhs _4 4, List.rev _2)) ) -# 10672 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'meth_list) in - Obj.repr( -# 2045 "ml/parser.mly" - ( let (f, c) = _2 in mktyp(Ptyp_object (f, c)) ) -# 10679 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - Obj.repr( -# 2047 "ml/parser.mly" - ( mktyp(Ptyp_object ([], Closed)) ) -# 10685 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in - Obj.repr( -# 2049 "ml/parser.mly" - ( mktyp(Ptyp_class(mkrhs _2 2, [])) ) -# 10692 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type2) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in - Obj.repr( -# 2051 "ml/parser.mly" - ( mktyp(Ptyp_class(mkrhs _3 3, [_1])) ) -# 10700 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'core_type_comma_list) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'class_longident) in - Obj.repr( -# 2053 "ml/parser.mly" - ( mktyp(Ptyp_class(mkrhs _5 5, List.rev _2)) ) -# 10708 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'tag_field) in - Obj.repr( -# 2055 "ml/parser.mly" - ( mktyp(Ptyp_variant([_2], Closed, None)) ) -# 10715 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in - Obj.repr( -# 2061 "ml/parser.mly" - ( mktyp(Ptyp_variant(List.rev _3, Closed, None)) ) -# 10722 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 3 : 'row_field) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in - Obj.repr( -# 2063 "ml/parser.mly" - ( mktyp(Ptyp_variant(_2 :: List.rev _4, Closed, None)) ) -# 10730 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_bar) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in - Obj.repr( -# 2065 "ml/parser.mly" - ( mktyp(Ptyp_variant(List.rev _3, Open, None)) ) -# 10738 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - Obj.repr( -# 2067 "ml/parser.mly" - ( mktyp(Ptyp_variant([], Open, None)) ) -# 10744 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'opt_bar) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'row_field_list) in - Obj.repr( -# 2069 "ml/parser.mly" - ( mktyp(Ptyp_variant(List.rev _3, Closed, Some [])) ) -# 10752 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 4 : 'opt_bar) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'row_field_list) in - let _5 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag_list) in - Obj.repr( -# 2071 "ml/parser.mly" - ( mktyp(Ptyp_variant(List.rev _3, Closed, Some (List.rev _5))) ) -# 10761 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'ext_attributes) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'package_type) in - Obj.repr( -# 2073 "ml/parser.mly" - ( mktyp_attrs (Ptyp_package _4) _3 ) -# 10769 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'extension) in - Obj.repr( -# 2075 "ml/parser.mly" - ( mktyp (Ptyp_extension _1) ) -# 10776 "ml/parser.ml" - : 'simple_core_type2)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'module_type) in - Obj.repr( -# 2078 "ml/parser.mly" - ( package_type_of_module_type _1 ) -# 10783 "ml/parser.ml" - : 'package_type)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'row_field) in - Obj.repr( -# 2081 "ml/parser.mly" - ( [_1] ) -# 10790 "ml/parser.ml" - : 'row_field_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'row_field_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'row_field) in - Obj.repr( -# 2082 "ml/parser.mly" - ( _3 :: _1 ) -# 10798 "ml/parser.ml" - : 'row_field_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'tag_field) in - Obj.repr( -# 2085 "ml/parser.mly" - ( _1 ) -# 10805 "ml/parser.ml" - : 'row_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in - Obj.repr( -# 2086 "ml/parser.mly" - ( Rinherit _1 ) -# 10812 "ml/parser.ml" - : 'row_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'name_tag) in - let _3 = (Parsing.peek_val __caml_parser_env 2 : 'opt_ampersand) in - let _4 = (Parsing.peek_val __caml_parser_env 1 : 'amper_type_list) in - let _5 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 2090 "ml/parser.mly" - ( Rtag (mkrhs _1 1, add_info_attrs (symbol_info ()) _5, - _3, List.rev _4) ) -# 10823 "ml/parser.ml" - : 'tag_field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 2093 "ml/parser.mly" - ( Rtag (mkrhs _1 1, add_info_attrs (symbol_info ()) _2, true, []) ) -# 10831 "ml/parser.ml" - : 'tag_field)) -; (fun __caml_parser_env -> - Obj.repr( -# 2096 "ml/parser.mly" - ( true ) -# 10837 "ml/parser.ml" - : 'opt_ampersand)) -; (fun __caml_parser_env -> - Obj.repr( -# 2097 "ml/parser.mly" - ( false ) -# 10843 "ml/parser.ml" - : 'opt_ampersand)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in - Obj.repr( -# 2100 "ml/parser.mly" - ( [_1] ) -# 10850 "ml/parser.ml" - : 'amper_type_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'amper_type_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_no_attr) in - Obj.repr( -# 2101 "ml/parser.mly" - ( _3 :: _1 ) -# 10858 "ml/parser.ml" - : 'amper_type_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in - Obj.repr( -# 2104 "ml/parser.mly" - ( [_1] ) -# 10865 "ml/parser.ml" - : 'name_tag_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'name_tag_list) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'name_tag) in - Obj.repr( -# 2105 "ml/parser.mly" - ( _2 :: _1 ) -# 10873 "ml/parser.ml" - : 'name_tag_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in - Obj.repr( -# 2108 "ml/parser.mly" - ( _1 ) -# 10880 "ml/parser.ml" - : 'simple_core_type_or_tuple)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'simple_core_type) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type_list) in - Obj.repr( -# 2110 "ml/parser.mly" - ( mktyp(Ptyp_tuple(_1 :: List.rev _3)) ) -# 10888 "ml/parser.ml" - : 'simple_core_type_or_tuple)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 2113 "ml/parser.mly" - ( [_1] ) -# 10895 "ml/parser.ml" - : 'core_type_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_comma_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 2114 "ml/parser.mly" - ( _3 :: _1 ) -# 10903 "ml/parser.ml" - : 'core_type_comma_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in - Obj.repr( -# 2117 "ml/parser.mly" - ( [_1] ) -# 10910 "ml/parser.ml" - : 'core_type_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'core_type_list) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in - Obj.repr( -# 2118 "ml/parser.mly" - ( _3 :: _1 ) -# 10918 "ml/parser.ml" - : 'core_type_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'field_semi) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'meth_list) in - Obj.repr( -# 2121 "ml/parser.mly" - ( let (f, c) = _2 in (_1 :: f, c) ) -# 10926 "ml/parser.ml" - : 'meth_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'inherit_field_semi) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'meth_list) in - Obj.repr( -# 2122 "ml/parser.mly" - ( let (f, c) = _2 in (_1 :: f, c) ) -# 10934 "ml/parser.ml" - : 'meth_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'field_semi) in - Obj.repr( -# 2123 "ml/parser.mly" - ( [_1], Closed ) -# 10941 "ml/parser.ml" - : 'meth_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'field) in - Obj.repr( -# 2124 "ml/parser.mly" - ( [_1], Closed ) -# 10948 "ml/parser.ml" - : 'meth_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'inherit_field_semi) in - Obj.repr( -# 2125 "ml/parser.mly" - ( [_1], Closed ) -# 10955 "ml/parser.ml" - : 'meth_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'simple_core_type) in - Obj.repr( -# 2126 "ml/parser.mly" - ( [Oinherit _1], Closed ) -# 10962 "ml/parser.ml" - : 'meth_list)) -; (fun __caml_parser_env -> - Obj.repr( -# 2127 "ml/parser.mly" - ( [], Open ) -# 10968 "ml/parser.ml" - : 'meth_list)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'label) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'poly_type_no_attr) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 2131 "ml/parser.mly" - ( Otag (mkrhs _1 1, add_info_attrs (symbol_info ()) _4, _3) ) -# 10977 "ml/parser.ml" - : 'field)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 5 : 'label) in - let _3 = (Parsing.peek_val __caml_parser_env 3 : 'poly_type_no_attr) in - let _4 = (Parsing.peek_val __caml_parser_env 2 : 'attributes) in - let _6 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 2136 "ml/parser.mly" - ( let info = - match rhs_info 4 with - | Some _ as info_before_semi -> info_before_semi - | None -> symbol_info () - in - ( Otag (mkrhs _1 1, add_info_attrs info (_4 @ _6), _3)) ) -# 10992 "ml/parser.ml" - : 'field_semi)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'simple_core_type) in - Obj.repr( -# 2145 "ml/parser.mly" - ( Oinherit _1 ) -# 10999 "ml/parser.ml" - : 'inherit_field_semi)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2148 "ml/parser.mly" - ( _1 ) -# 11006 "ml/parser.ml" - : 'label)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in - Obj.repr( -# 2154 "ml/parser.mly" - ( let (n, m) = _1 in Pconst_integer (n, m) ) -# 11013 "ml/parser.ml" - : 'constant)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : char) in - Obj.repr( -# 2155 "ml/parser.mly" - ( Pconst_char (Char.code _1) ) -# 11020 "ml/parser.ml" - : 'constant)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string * string option) in - Obj.repr( -# 2156 "ml/parser.mly" - ( let (s, d) = _1 in Pconst_string (s, d) ) -# 11027 "ml/parser.ml" - : 'constant)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in - Obj.repr( -# 2157 "ml/parser.mly" - ( let (f, m) = _1 in Pconst_float (f, m) ) -# 11034 "ml/parser.ml" - : 'constant)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'constant) in - Obj.repr( -# 2160 "ml/parser.mly" - ( _1 ) -# 11041 "ml/parser.ml" - : 'signed_constant)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in - Obj.repr( -# 2161 "ml/parser.mly" - ( let (n, m) = _2 in Pconst_integer("-" ^ n, m) ) -# 11048 "ml/parser.ml" - : 'signed_constant)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in - Obj.repr( -# 2162 "ml/parser.mly" - ( let (f, m) = _2 in Pconst_float("-" ^ f, m) ) -# 11055 "ml/parser.ml" - : 'signed_constant)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in - Obj.repr( -# 2163 "ml/parser.mly" - ( let (n, m) = _2 in Pconst_integer (n, m) ) -# 11062 "ml/parser.ml" - : 'signed_constant)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : string * char option) in - Obj.repr( -# 2164 "ml/parser.mly" - ( let (f, m) = _2 in Pconst_float(f, m) ) -# 11069 "ml/parser.ml" - : 'signed_constant)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2170 "ml/parser.mly" - ( _1 ) -# 11076 "ml/parser.ml" - : 'ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2171 "ml/parser.mly" - ( _1 ) -# 11083 "ml/parser.ml" - : 'ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2174 "ml/parser.mly" - ( _1 ) -# 11090 "ml/parser.ml" - : 'val_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'operator) in - Obj.repr( -# 2175 "ml/parser.mly" - ( _2 ) -# 11097 "ml/parser.ml" - : 'val_ident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'operator) in - Obj.repr( -# 2176 "ml/parser.mly" - ( unclosed "(" 1 ")" 3 ) -# 11104 "ml/parser.ml" - : 'val_ident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2177 "ml/parser.mly" - ( expecting 2 "operator" ) -# 11110 "ml/parser.ml" - : 'val_ident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2178 "ml/parser.mly" - ( expecting 3 "module-expr" ) -# 11116 "ml/parser.ml" - : 'val_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2181 "ml/parser.mly" - ( _1 ) -# 11123 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2182 "ml/parser.mly" - ( _1 ) -# 11130 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2183 "ml/parser.mly" - ( _1 ) -# 11137 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2184 "ml/parser.mly" - ( _1 ) -# 11144 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2185 "ml/parser.mly" - ( _1 ) -# 11151 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2186 "ml/parser.mly" - ( _1 ) -# 11158 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in - Obj.repr( -# 2187 "ml/parser.mly" - ( "."^ _1 ^"()" ) -# 11165 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in - Obj.repr( -# 2188 "ml/parser.mly" - ( "."^ _1 ^ "()<-" ) -# 11172 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in - Obj.repr( -# 2189 "ml/parser.mly" - ( "."^ _1 ^"[]" ) -# 11179 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in - Obj.repr( -# 2190 "ml/parser.mly" - ( "."^ _1 ^ "[]<-" ) -# 11186 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in - Obj.repr( -# 2191 "ml/parser.mly" - ( "."^ _1 ^"{}" ) -# 11193 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in - Obj.repr( -# 2192 "ml/parser.mly" - ( "."^ _1 ^ "{}<-" ) -# 11200 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2193 "ml/parser.mly" - ( _1 ) -# 11207 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2194 "ml/parser.mly" - ( "!" ) -# 11213 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2195 "ml/parser.mly" - ( "+" ) -# 11219 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2196 "ml/parser.mly" - ( "+." ) -# 11225 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2197 "ml/parser.mly" - ( "-" ) -# 11231 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2198 "ml/parser.mly" - ( "-." ) -# 11237 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2199 "ml/parser.mly" - ( "*" ) -# 11243 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2200 "ml/parser.mly" - ( "=" ) -# 11249 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2201 "ml/parser.mly" - ( "<" ) -# 11255 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2202 "ml/parser.mly" - ( ">" ) -# 11261 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2203 "ml/parser.mly" - ( "or" ) -# 11267 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2204 "ml/parser.mly" - ( "||" ) -# 11273 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2205 "ml/parser.mly" - ( "&" ) -# 11279 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2206 "ml/parser.mly" - ( "&&" ) -# 11285 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2207 "ml/parser.mly" - ( ":=" ) -# 11291 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2208 "ml/parser.mly" - ( "+=" ) -# 11297 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - Obj.repr( -# 2209 "ml/parser.mly" - ( "%" ) -# 11303 "ml/parser.ml" - : 'operator)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2212 "ml/parser.mly" - ( _1 ) -# 11310 "ml/parser.ml" - : 'constr_ident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2213 "ml/parser.mly" - ( "[]" ) -# 11316 "ml/parser.ml" - : 'constr_ident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2214 "ml/parser.mly" - ( "()" ) -# 11322 "ml/parser.ml" - : 'constr_ident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2215 "ml/parser.mly" - ( "::" ) -# 11328 "ml/parser.ml" - : 'constr_ident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2216 "ml/parser.mly" - ( "false" ) -# 11334 "ml/parser.ml" - : 'constr_ident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2217 "ml/parser.mly" - ( "true" ) -# 11340 "ml/parser.ml" - : 'constr_ident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in - Obj.repr( -# 2221 "ml/parser.mly" - ( Lident _1 ) -# 11347 "ml/parser.ml" - : 'val_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'val_ident) in - Obj.repr( -# 2222 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11355 "ml/parser.ml" - : 'val_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'mod_longident) in - Obj.repr( -# 2225 "ml/parser.mly" - ( _1 ) -# 11362 "ml/parser.ml" - : 'constr_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 4 : 'mod_longident) in - Obj.repr( -# 2226 "ml/parser.mly" - ( Ldot(_1,"::") ) -# 11369 "ml/parser.ml" - : 'constr_longident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2227 "ml/parser.mly" - ( Lident "[]" ) -# 11375 "ml/parser.ml" - : 'constr_longident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2228 "ml/parser.mly" - ( Lident "()" ) -# 11381 "ml/parser.ml" - : 'constr_longident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2229 "ml/parser.mly" - ( Lident "::" ) -# 11387 "ml/parser.ml" - : 'constr_longident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2230 "ml/parser.mly" - ( Lident "false" ) -# 11393 "ml/parser.ml" - : 'constr_longident)) -; (fun __caml_parser_env -> - Obj.repr( -# 2231 "ml/parser.mly" - ( Lident "true" ) -# 11399 "ml/parser.ml" - : 'constr_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2234 "ml/parser.mly" - ( Lident _1 ) -# 11406 "ml/parser.ml" - : 'label_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2235 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11414 "ml/parser.ml" - : 'label_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2238 "ml/parser.mly" - ( Lident _1 ) -# 11421 "ml/parser.ml" - : 'type_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2239 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11429 "ml/parser.ml" - : 'type_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2242 "ml/parser.mly" - ( Lident _1 ) -# 11436 "ml/parser.ml" - : 'mod_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2243 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11444 "ml/parser.ml" - : 'mod_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2246 "ml/parser.mly" - ( Lident _1 ) -# 11451 "ml/parser.ml" - : 'mod_ext_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2247 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11459 "ml/parser.ml" - : 'mod_ext_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 3 : 'mod_ext_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'mod_ext_longident) in - Obj.repr( -# 2248 "ml/parser.mly" - ( lapply _1 _3 ) -# 11467 "ml/parser.ml" - : 'mod_ext_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 2251 "ml/parser.mly" - ( Lident _1 ) -# 11474 "ml/parser.ml" - : 'mty_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 2252 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11482 "ml/parser.ml" - : 'mty_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2255 "ml/parser.mly" - ( Lident _1 ) -# 11489 "ml/parser.ml" - : 'clty_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_ext_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2256 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11497 "ml/parser.ml" - : 'clty_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2259 "ml/parser.mly" - ( Lident _1 ) -# 11504 "ml/parser.ml" - : 'class_longident)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'mod_longident) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2260 "ml/parser.mly" - ( Ldot(_1, _3) ) -# 11512 "ml/parser.ml" - : 'class_longident)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'ident) in - Obj.repr( -# 2269 "ml/parser.mly" - ( _2 ) -# 11519 "ml/parser.ml" - : 'name_tag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2272 "ml/parser.mly" - ( Nonrecursive ) -# 11525 "ml/parser.ml" - : 'rec_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2273 "ml/parser.mly" - ( Recursive ) -# 11531 "ml/parser.ml" - : 'rec_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2276 "ml/parser.mly" - ( Recursive ) -# 11537 "ml/parser.ml" - : 'nonrec_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2277 "ml/parser.mly" - ( Nonrecursive ) -# 11543 "ml/parser.ml" - : 'nonrec_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2280 "ml/parser.mly" - ( Upto ) -# 11549 "ml/parser.ml" - : 'direction_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2281 "ml/parser.mly" - ( Downto ) -# 11555 "ml/parser.ml" - : 'direction_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2284 "ml/parser.mly" - ( Public ) -# 11561 "ml/parser.ml" - : 'private_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2285 "ml/parser.mly" - ( Private ) -# 11567 "ml/parser.ml" - : 'private_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2288 "ml/parser.mly" - ( Immutable ) -# 11573 "ml/parser.ml" - : 'mutable_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2289 "ml/parser.mly" - ( Mutable ) -# 11579 "ml/parser.ml" - : 'mutable_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2292 "ml/parser.mly" - ( Concrete ) -# 11585 "ml/parser.ml" - : 'virtual_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2293 "ml/parser.mly" - ( Virtual ) -# 11591 "ml/parser.ml" - : 'virtual_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2296 "ml/parser.mly" - ( Public, Concrete ) -# 11597 "ml/parser.ml" - : 'private_virtual_flags)) -; (fun __caml_parser_env -> - Obj.repr( -# 2297 "ml/parser.mly" - ( Private, Concrete ) -# 11603 "ml/parser.ml" - : 'private_virtual_flags)) -; (fun __caml_parser_env -> - Obj.repr( -# 2298 "ml/parser.mly" - ( Public, Virtual ) -# 11609 "ml/parser.ml" - : 'private_virtual_flags)) -; (fun __caml_parser_env -> - Obj.repr( -# 2299 "ml/parser.mly" - ( Private, Virtual ) -# 11615 "ml/parser.ml" - : 'private_virtual_flags)) -; (fun __caml_parser_env -> - Obj.repr( -# 2300 "ml/parser.mly" - ( Private, Virtual ) -# 11621 "ml/parser.ml" - : 'private_virtual_flags)) -; (fun __caml_parser_env -> - Obj.repr( -# 2303 "ml/parser.mly" - ( Fresh ) -# 11627 "ml/parser.ml" - : 'override_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2304 "ml/parser.mly" - ( Override ) -# 11633 "ml/parser.ml" - : 'override_flag)) -; (fun __caml_parser_env -> - Obj.repr( -# 2307 "ml/parser.mly" - ( () ) -# 11639 "ml/parser.ml" - : 'opt_bar)) -; (fun __caml_parser_env -> - Obj.repr( -# 2308 "ml/parser.mly" - ( () ) -# 11645 "ml/parser.ml" - : 'opt_bar)) -; (fun __caml_parser_env -> - Obj.repr( -# 2311 "ml/parser.mly" - ( () ) -# 11651 "ml/parser.ml" - : 'opt_semi)) -; (fun __caml_parser_env -> - Obj.repr( -# 2312 "ml/parser.mly" - ( () ) -# 11657 "ml/parser.ml" - : 'opt_semi)) -; (fun __caml_parser_env -> - Obj.repr( -# 2315 "ml/parser.mly" - ( "-" ) -# 11663 "ml/parser.ml" - : 'subtractive)) -; (fun __caml_parser_env -> - Obj.repr( -# 2316 "ml/parser.mly" - ( "-." ) -# 11669 "ml/parser.ml" - : 'subtractive)) -; (fun __caml_parser_env -> - Obj.repr( -# 2319 "ml/parser.mly" - ( "+" ) -# 11675 "ml/parser.ml" - : 'additive)) -; (fun __caml_parser_env -> - Obj.repr( -# 2320 "ml/parser.mly" - ( "+." ) -# 11681 "ml/parser.ml" - : 'additive)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2326 "ml/parser.mly" - ( _1 ) -# 11688 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in - Obj.repr( -# 2327 "ml/parser.mly" - ( _1 ) -# 11695 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2328 "ml/parser.mly" - ( "and" ) -# 11701 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2329 "ml/parser.mly" - ( "as" ) -# 11707 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2330 "ml/parser.mly" - ( "assert" ) -# 11713 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2331 "ml/parser.mly" - ( "begin" ) -# 11719 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2332 "ml/parser.mly" - ( "class" ) -# 11725 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2333 "ml/parser.mly" - ( "constraint" ) -# 11731 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2334 "ml/parser.mly" - ( "do" ) -# 11737 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2335 "ml/parser.mly" - ( "done" ) -# 11743 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2336 "ml/parser.mly" - ( "downto" ) -# 11749 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2337 "ml/parser.mly" - ( "else" ) -# 11755 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2338 "ml/parser.mly" - ( "end" ) -# 11761 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2339 "ml/parser.mly" - ( "exception" ) -# 11767 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2340 "ml/parser.mly" - ( "external" ) -# 11773 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2341 "ml/parser.mly" - ( "false" ) -# 11779 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2342 "ml/parser.mly" - ( "for" ) -# 11785 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2343 "ml/parser.mly" - ( "fun" ) -# 11791 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2344 "ml/parser.mly" - ( "function" ) -# 11797 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2345 "ml/parser.mly" - ( "functor" ) -# 11803 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2346 "ml/parser.mly" - ( "if" ) -# 11809 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2347 "ml/parser.mly" - ( "in" ) -# 11815 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2348 "ml/parser.mly" - ( "include" ) -# 11821 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2349 "ml/parser.mly" - ( "inherit" ) -# 11827 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2350 "ml/parser.mly" - ( "initializer" ) -# 11833 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2351 "ml/parser.mly" - ( "lazy" ) -# 11839 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2352 "ml/parser.mly" - ( "let" ) -# 11845 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2353 "ml/parser.mly" - ( "match" ) -# 11851 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2354 "ml/parser.mly" - ( "method" ) -# 11857 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2355 "ml/parser.mly" - ( "module" ) -# 11863 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2356 "ml/parser.mly" - ( "mutable" ) -# 11869 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2357 "ml/parser.mly" - ( "new" ) -# 11875 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2358 "ml/parser.mly" - ( "nonrec" ) -# 11881 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2359 "ml/parser.mly" - ( "object" ) -# 11887 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2360 "ml/parser.mly" - ( "of" ) -# 11893 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2361 "ml/parser.mly" - ( "open" ) -# 11899 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2362 "ml/parser.mly" - ( "or" ) -# 11905 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2363 "ml/parser.mly" - ( "private" ) -# 11911 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2364 "ml/parser.mly" - ( "rec" ) -# 11917 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2365 "ml/parser.mly" - ( "sig" ) -# 11923 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2366 "ml/parser.mly" - ( "struct" ) -# 11929 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2367 "ml/parser.mly" - ( "then" ) -# 11935 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2368 "ml/parser.mly" - ( "to" ) -# 11941 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2369 "ml/parser.mly" - ( "true" ) -# 11947 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2370 "ml/parser.mly" - ( "try" ) -# 11953 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2371 "ml/parser.mly" - ( "type" ) -# 11959 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2372 "ml/parser.mly" - ( "val" ) -# 11965 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2373 "ml/parser.mly" - ( "virtual" ) -# 11971 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2374 "ml/parser.mly" - ( "when" ) -# 11977 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2375 "ml/parser.mly" - ( "while" ) -# 11983 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - Obj.repr( -# 2376 "ml/parser.mly" - ( "with" ) -# 11989 "ml/parser.ml" - : 'single_attr_id)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'single_attr_id) in - Obj.repr( -# 2381 "ml/parser.mly" - ( mkloc _1 (symbol_rloc()) ) -# 11996 "ml/parser.ml" - : 'attr_id)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 2 : 'single_attr_id) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attr_id) in - Obj.repr( -# 2382 "ml/parser.mly" - ( mkloc (_1 ^ "." ^ _3.txt) (symbol_rloc())) -# 12004 "ml/parser.ml" - : 'attr_id)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in - Obj.repr( -# 2385 "ml/parser.mly" - ( (_2, _3) ) -# 12012 "ml/parser.ml" - : 'attribute)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in - Obj.repr( -# 2388 "ml/parser.mly" - ( (_2, _3) ) -# 12020 "ml/parser.ml" - : 'post_item_attribute)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in - Obj.repr( -# 2391 "ml/parser.mly" - ( (_2, _3) ) -# 12028 "ml/parser.ml" - : 'floating_attribute)) -; (fun __caml_parser_env -> - Obj.repr( -# 2394 "ml/parser.mly" - ( [] ) -# 12034 "ml/parser.ml" - : 'post_item_attributes)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'post_item_attribute) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'post_item_attributes) in - Obj.repr( -# 2395 "ml/parser.mly" - ( _1 :: _2 ) -# 12042 "ml/parser.ml" - : 'post_item_attributes)) -; (fun __caml_parser_env -> - Obj.repr( -# 2398 "ml/parser.mly" - ( [] ) -# 12048 "ml/parser.ml" - : 'attributes)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'attribute) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 2399 "ml/parser.mly" - ( _1 :: _2 ) -# 12056 "ml/parser.ml" - : 'attributes)) -; (fun __caml_parser_env -> - Obj.repr( -# 2402 "ml/parser.mly" - ( None, [] ) -# 12062 "ml/parser.ml" - : 'ext_attributes)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 1 : 'attribute) in - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 2403 "ml/parser.mly" - ( None, _1 :: _2 ) -# 12070 "ml/parser.ml" - : 'ext_attributes)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 1 : 'attr_id) in - let _3 = (Parsing.peek_val __caml_parser_env 0 : 'attributes) in - Obj.repr( -# 2404 "ml/parser.mly" - ( Some _2, _3 ) -# 12078 "ml/parser.ml" - : 'ext_attributes)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in - Obj.repr( -# 2407 "ml/parser.mly" - ( (_2, _3) ) -# 12086 "ml/parser.ml" - : 'extension)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'attr_id) in - let _3 = (Parsing.peek_val __caml_parser_env 1 : 'payload) in - Obj.repr( -# 2410 "ml/parser.mly" - ( (_2, _3) ) -# 12094 "ml/parser.ml" - : 'item_extension)) -; (fun __caml_parser_env -> - let _1 = (Parsing.peek_val __caml_parser_env 0 : 'structure) in - Obj.repr( -# 2413 "ml/parser.mly" - ( PStr _1 ) -# 12101 "ml/parser.ml" - : 'payload)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'signature) in - Obj.repr( -# 2414 "ml/parser.mly" - ( PSig _2 ) -# 12108 "ml/parser.ml" - : 'payload)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'core_type) in - Obj.repr( -# 2415 "ml/parser.mly" - ( PTyp _2 ) -# 12115 "ml/parser.ml" - : 'payload)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 0 : 'pattern) in - Obj.repr( -# 2416 "ml/parser.mly" - ( PPat (_2, None) ) -# 12122 "ml/parser.ml" - : 'payload)) -; (fun __caml_parser_env -> - let _2 = (Parsing.peek_val __caml_parser_env 2 : 'pattern) in - let _4 = (Parsing.peek_val __caml_parser_env 0 : 'seq_expr) in - Obj.repr( -# 2417 "ml/parser.mly" - ( PPat (_2, Some _4) ) -# 12130 "ml/parser.ml" - : 'payload)) -(* Entry implementation *) -; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) -(* Entry interface *) -; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) -(* Entry parse_core_type *) -; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) -(* Entry parse_expression *) -; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) -(* Entry parse_pattern *) -; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) -|] -let yytables = - { Parsing.actions=yyact; - Parsing.transl_const=yytransl_const; - Parsing.transl_block=yytransl_block; - Parsing.lhs=yylhs; - Parsing.len=yylen; - Parsing.defred=yydefred; - Parsing.dgoto=yydgoto; - Parsing.sindex=yysindex; - Parsing.rindex=yyrindex; - Parsing.gindex=yygindex; - Parsing.tablesize=yytablesize; - Parsing.table=yytable; - Parsing.check=yycheck; - Parsing.error_function=parse_error; - Parsing.names_const=yynames_const; - Parsing.names_block=yynames_block } -let implementation (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = - (Parsing.yyparse yytables 1 lexfun lexbuf : Parsetree.structure) -let interface (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = - (Parsing.yyparse yytables 2 lexfun lexbuf : Parsetree.signature) -let parse_core_type (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = - (Parsing.yyparse yytables 3 lexfun lexbuf : Parsetree.core_type) -let parse_expression (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = - (Parsing.yyparse yytables 4 lexfun lexbuf : Parsetree.expression) -let parse_pattern (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = - (Parsing.yyparse yytables 5 lexfun lexbuf : Parsetree.pattern) -;; diff --git a/jscomp/ml/parser.mli b/jscomp/ml/parser.mli deleted file mode 100644 index fd7969f..0000000 --- a/jscomp/ml/parser.mli +++ /dev/null @@ -1,131 +0,0 @@ -type token = - | AMPERAMPER - | AMPERSAND - | AND - | AS - | ASSERT - | BACKQUOTE - | BANG - | BAR - | BARBAR - | BARRBRACKET - | BEGIN - | CHAR of (char) - | CLASS - | COLON - | COLONCOLON - | COLONEQUAL - | COLONGREATER - | COMMA - | CONSTRAINT - | DO - | DONE - | DOT - | DOTDOT - | DOWNTO - | ELSE - | END - | EOF - | EQUAL - | EXCEPTION - | EXTERNAL - | FALSE - | FLOAT of (string * char option) - | FOR - | FUN - | FUNCTION - | FUNCTOR - | GREATER - | GREATERRBRACE - | GREATERRBRACKET - | IF - | IN - | INCLUDE - | INFIXOP0 of (string) - | INFIXOP1 of (string) - | INFIXOP2 of (string) - | INFIXOP3 of (string) - | INFIXOP4 of (string) - | DOTOP of (string) - | INHERIT - | INITIALIZER - | INT of (string * char option) - | LABEL of (string) - | LAZY - | LBRACE - | LBRACELESS - | LBRACKET - | LBRACKETBAR - | LBRACKETLESS - | LBRACKETGREATER - | LBRACKETPERCENT - | LBRACKETPERCENTPERCENT - | LESS - | LESSMINUS - | LET - | LIDENT of (string) - | LPAREN - | LBRACKETAT - | LBRACKETATAT - | LBRACKETATATAT - | MATCH - | METHOD - | MINUS - | MINUSDOT - | MINUSGREATER - | MODULE - | MUTABLE - | NEW - | NONREC - | OBJECT - | OF - | OPEN - | OPTLABEL of (string) - | OR - | PERCENT - | PLUS - | PLUSDOT - | PLUSEQ - | PREFIXOP of (string) - | PRIVATE - | QUESTION - | QUOTE - | RBRACE - | RBRACKET - | REC - | RPAREN - | SEMI - | SEMISEMI - | HASH - | HASHOP of (string) - | SIG - | STAR - | STRING of (string * string option) - | STRUCT - | THEN - | TILDE - | TO - | TRUE - | TRY - | TYPE - | UIDENT of (string) - | UNDERSCORE - | VAL - | VIRTUAL - | WHEN - | WHILE - | WITH - | COMMENT of (string * Location.t) - | DOCSTRING of (Docstrings.docstring) - | EOL - -val implementation : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.structure -val interface : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.signature -val parse_core_type : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.core_type -val parse_expression : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.expression -val parse_pattern : - (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Parsetree.pattern diff --git a/jscomp/ml/parser.mly b/jscomp/ml/parser.mly deleted file mode 100644 index fe4ace9..0000000 --- a/jscomp/ml/parser.mly +++ /dev/null @@ -1,2419 +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. */ -/* */ -/**************************************************************************/ - -/* The parser definition */ - -%{ -open Location -open Asttypes -open Longident -open Parsetree -open Ast_helper -open Docstrings - -let mktyp d = Typ.mk ~loc:(symbol_rloc()) d -let mkpat d = Pat.mk ~loc:(symbol_rloc()) d -let mkexp d = Exp.mk ~loc:(symbol_rloc()) d -let mkmty ?attrs d = Mty.mk ~loc:(symbol_rloc()) ?attrs d -let mksig d = Sig.mk ~loc:(symbol_rloc()) d -let mkmod ?attrs d = Mod.mk ~loc:(symbol_rloc()) ?attrs d -let mkstr d = Str.mk ~loc:(symbol_rloc()) d -let mkcty ?attrs d = Cty.mk ~loc:(symbol_rloc()) ?attrs d -let mkctf ?attrs ?docs d = - Ctf.mk ~loc:(symbol_rloc()) ?attrs ?docs d -let mkcf ?attrs ?docs d = - Cf.mk ~loc:(symbol_rloc()) ?attrs ?docs d - -let mkrhs rhs pos = mkloc rhs (rhs_loc pos) - -let reloc_pat x = { x with ppat_loc = symbol_rloc () };; -let reloc_exp x = { x with pexp_loc = symbol_rloc () };; - -let mkoperator name pos = - let loc = rhs_loc pos in - Exp.mk ~loc (Pexp_ident(mkloc (Lident name) loc)) - -let mkpatvar name pos = - Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos)) - -(* - Ghost expressions and patterns: - expressions and patterns that do not appear explicitly in the - source file they have the loc_ghost flag set to true. - Then the profiler will not try to instrument them and the - -annot option will not try to display their type. - - Every grammar rule that generates an element with a location must - make at most one non-ghost element, the topmost one. - - How to tell whether your location must be ghost: - A location corresponds to a range of characters in the source file. - If the location contains a piece of code that is syntactically - valid (according to the documentation), and corresponds to the - AST node, then the location must be real; in all other cases, - it must be ghost. -*) -let ghexp d = Exp.mk ~loc:(symbol_gloc ()) d -let ghpat d = Pat.mk ~loc:(symbol_gloc ()) d -let ghtyp d = Typ.mk ~loc:(symbol_gloc ()) d -let ghloc d = { txt = d; loc = symbol_gloc () } -let ghstr d = Str.mk ~loc:(symbol_gloc()) d -let ghsig d = Sig.mk ~loc:(symbol_gloc()) d - -let mkinfix arg1 name arg2 = - mkexp(Pexp_apply(mkoperator name 2, [Nolabel, arg1; Nolabel, arg2])) - -let neg_string f = - if String.length f > 0 && f.[0] = '-' - then String.sub f 1 (String.length f - 1) - else "-" ^ f - -let mkuminus name arg = - match name, arg.pexp_desc with - | "-", Pexp_constant(Pconst_integer (n,m)) -> - mkexp(Pexp_constant(Pconst_integer(neg_string n,m))) - | ("-" | "-."), Pexp_constant(Pconst_float (f, m)) -> - mkexp(Pexp_constant(Pconst_float(neg_string f, m))) - | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) - -let mkuplus name arg = - let desc = arg.pexp_desc in - match name, desc with - | "+", Pexp_constant(Pconst_integer _) - | ("+" | "+."), Pexp_constant(Pconst_float _) -> mkexp desc - | _ -> - mkexp(Pexp_apply(mkoperator ("~" ^ name) 1, [Nolabel, arg])) - -let mkexp_cons consloc args loc = - Exp.mk ~loc (Pexp_construct(mkloc (Lident "::") consloc, Some args)) - -let mkpat_cons consloc args loc = - Pat.mk ~loc (Ppat_construct(mkloc (Lident "::") consloc, Some args)) - -let rec mktailexp nilloc = function - [] -> - let loc = { nilloc with loc_ghost = true } in - let nil = { txt = Lident "[]"; loc = loc } in - Exp.mk ~loc (Pexp_construct (nil, None)) - | e1 :: el -> - let exp_el = mktailexp nilloc el in - let loc = {loc_start = e1.pexp_loc.loc_start; - loc_end = exp_el.pexp_loc.loc_end; - loc_ghost = true} - in - let arg = Exp.mk ~loc (Pexp_tuple [e1; exp_el]) in - mkexp_cons {loc with loc_ghost = true} arg loc - -let rec mktailpat nilloc = function - [] -> - let loc = { nilloc with loc_ghost = true } in - let nil = { txt = Lident "[]"; loc = loc } in - Pat.mk ~loc (Ppat_construct (nil, None)) - | p1 :: pl -> - let pat_pl = mktailpat nilloc pl in - let loc = {loc_start = p1.ppat_loc.loc_start; - loc_end = pat_pl.ppat_loc.loc_end; - loc_ghost = true} - in - let arg = Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - mkpat_cons {loc with loc_ghost = true} arg loc - -let mkstrexp e attrs = - { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } - -let mkexp_constraint e (t1, t2) = - match t1, t2 with - | Some t, None -> ghexp(Pexp_constraint(e, t)) - | _, Some t -> ghexp(Pexp_coerce(e, t1, t)) - | None, None -> assert false - -let mkexp_opt_constraint e = function - | None -> e - | Some constraint_ -> mkexp_constraint e constraint_ - -let mkpat_opt_constraint p = function - | None -> p - | Some typ -> mkpat (Ppat_constraint(p, typ)) - -let array_function str name = - ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name))) - -let syntax_error () = - raise Syntaxerr.Escape_error - -let unclosed opening_name opening_num closing_name closing_num = - raise(Syntaxerr.Error(Syntaxerr.Unclosed(rhs_loc opening_num, opening_name, - rhs_loc closing_num, closing_name))) - -let expecting pos nonterm = - raise Syntaxerr.(Error(Expecting(rhs_loc pos, nonterm))) - -let not_expecting pos nonterm = - raise Syntaxerr.(Error(Not_expecting(rhs_loc pos, nonterm))) - - -let lapply p1 p2 = - if !Clflags.applicative_functors - then Lapply(p1, p2) - else raise (Syntaxerr.Error(Syntaxerr.Applicative_path (symbol_rloc()))) - -let exp_of_label lbl pos = - mkexp (Pexp_ident(mkrhs (Lident(Longident.last lbl)) pos)) - -let pat_of_label lbl pos = - mkpat (Ppat_var (mkrhs (Longident.last lbl) pos)) - -let mk_newtypes newtypes exp = - List.fold_right (fun newtype exp -> mkexp (Pexp_newtype (newtype, exp))) - newtypes exp - -let wrap_type_annotation newtypes core_type body = - let exp = mkexp(Pexp_constraint(body,core_type)) in - let exp = mk_newtypes newtypes exp in - (exp, ghtyp(Ptyp_poly(newtypes, Typ.varify_constructors newtypes core_type))) - -let wrap_exp_attrs body (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let body = {body with pexp_attributes = attrs @ body.pexp_attributes} in - match ext with - | None -> body - | Some id -> ghexp(Pexp_extension (id, PStr [mkstrexp body []])) - -let mkexp_attrs d attrs = - wrap_exp_attrs (mkexp d) attrs - -let wrap_typ_attrs typ (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let typ = {typ with ptyp_attributes = attrs @ typ.ptyp_attributes} in - match ext with - | None -> typ - | Some id -> ghtyp(Ptyp_extension (id, PTyp typ)) - -let mktyp_attrs d attrs = - wrap_typ_attrs (mktyp d) attrs - -let wrap_pat_attrs pat (ext, attrs) = - (* todo: keep exact location for the entire attribute *) - let pat = {pat with ppat_attributes = attrs @ pat.ppat_attributes} in - match ext with - | None -> pat - | Some id -> ghpat(Ppat_extension (id, PPat (pat, None))) - -let mkpat_attrs d attrs = - wrap_pat_attrs (mkpat d) attrs - -let wrap_class_type_attrs body attrs = - {body with pcty_attributes = attrs @ body.pcty_attributes} -let wrap_mod_attrs body attrs = - {body with pmod_attributes = attrs @ body.pmod_attributes} -let wrap_mty_attrs body attrs = - {body with pmty_attributes = attrs @ body.pmty_attributes} - -let wrap_str_ext body ext = - match ext with - | None -> body - | Some id -> ghstr(Pstr_extension ((id, PStr [body]), [])) - -let mkstr_ext d ext = - wrap_str_ext (mkstr d) ext - -let wrap_sig_ext body ext = - match ext with - | None -> body - | Some id -> ghsig(Psig_extension ((id, PSig [body]), [])) - -let mksig_ext d ext = - wrap_sig_ext (mksig d) ext - -let text_str pos = Str.text (rhs_text pos) -let text_sig pos = Sig.text (rhs_text pos) -let text_cstr pos = Cf.text (rhs_text pos) -let text_csig pos = Ctf.text (rhs_text pos) - - -let extra_text text pos items = - let pre_extras = rhs_pre_extra_text pos in - let post_extras = rhs_post_extra_text pos in - text pre_extras @ items @ text post_extras - -let extra_str pos items = extra_text Str.text pos items -let extra_sig pos items = extra_text Sig.text pos items -let extra_cstr pos items = extra_text Cf.text pos items -let extra_csig pos items = extra_text Ctf.text pos items - -let extra_rhs_core_type ct ~pos = - let docs = rhs_info pos in - { ct with ptyp_attributes = add_info_attrs docs ct.ptyp_attributes } - -type let_binding = - { lb_pattern: pattern; - lb_expression: expression; - lb_attributes: attributes; - lb_docs: docs Lazy.t; - lb_text: text Lazy.t; - lb_loc: Location.t; } - -type [@warning "-69"] let_bindings = - { lbs_bindings: let_binding list; - lbs_rec: rec_flag; - lbs_extension: string Asttypes.loc option; - lbs_loc: Location.t } - -let mklb first (p, e) attrs = - { lb_pattern = p; - lb_expression = e; - lb_attributes = attrs; - lb_docs = symbol_docs_lazy (); - lb_text = if first then empty_text_lazy - else symbol_text_lazy (); - lb_loc = symbol_rloc (); } - -let mklbs ext rf lb = - { lbs_bindings = [lb]; - lbs_rec = rf; - lbs_extension = ext ; - lbs_loc = symbol_rloc (); } - -let addlb lbs lb = - { lbs with lbs_bindings = lb :: lbs.lbs_bindings } - -let val_of_let_bindings lbs = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - ~docs:(Lazy.force lb.lb_docs) - ~text:(Lazy.force lb.lb_text) - lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - let str = mkstr(Pstr_value(lbs.lbs_rec, List.rev bindings)) in - match lbs.lbs_extension with - | None -> str - | Some id -> ghstr (Pstr_extension((id, PStr [str]), [])) - -let expr_of_let_bindings lbs body = - let bindings = - List.map - (fun lb -> - Vb.mk ~loc:lb.lb_loc ~attrs:lb.lb_attributes - lb.lb_pattern lb.lb_expression) - lbs.lbs_bindings - in - mkexp_attrs (Pexp_let(lbs.lbs_rec, List.rev bindings, body)) - (lbs.lbs_extension, []) - - - -(* Alternatively, we could keep the generic module type in the Parsetree - and extract the package type during type-checking. In that case, - the assertions below should be turned into explicit checks. *) -let package_type_of_module_type pmty = - let err loc s = - raise (Syntaxerr.Error (Syntaxerr.Invalid_package_type (loc, s))) - in - let map_cstr = function - | Pwith_type (lid, ptyp) -> - let loc = ptyp.ptype_loc in - if ptyp.ptype_params <> [] then - err loc "parametrized types are not supported"; - if ptyp.ptype_cstrs <> [] then - err loc "constrained types are not supported"; - if ptyp.ptype_private <> Public then - err loc "private types are not supported"; - - (* restrictions below are checked by the 'with_constraint' rule *) - assert (ptyp.ptype_kind = Ptype_abstract); - assert (ptyp.ptype_attributes = []); - let ty = - match ptyp.ptype_manifest with - | Some ty -> ty - | None -> assert false - in - (lid, ty) - | _ -> - err pmty.pmty_loc "only 'with type t =' constraints are supported" - in - match pmty with - | {pmty_desc = Pmty_ident lid} -> (lid, []) - | {pmty_desc = Pmty_with({pmty_desc = Pmty_ident lid}, cstrs)} -> - (lid, List.map map_cstr cstrs) - | _ -> - err pmty.pmty_loc - "only module type identifier and 'with type' constraints are supported" - - -%} - -/* Tokens */ - -%token AMPERAMPER -%token AMPERSAND -%token AND -%token AS -%token ASSERT -%token BACKQUOTE -%token BANG -%token BAR -%token BARBAR -%token BARRBRACKET -%token BEGIN -%token CHAR -%token CLASS -%token COLON -%token COLONCOLON -%token COLONEQUAL -%token COLONGREATER -%token COMMA -%token CONSTRAINT -%token DO -%token DONE -%token DOT -%token DOTDOT -%token DOWNTO -%token ELSE -%token END -%token EOF -%token EQUAL -%token EXCEPTION -%token EXTERNAL -%token FALSE -%token FLOAT -%token FOR -%token FUN -%token FUNCTION -%token FUNCTOR -%token GREATER -%token GREATERRBRACE -%token GREATERRBRACKET -%token IF -%token IN -%token INCLUDE -%token INFIXOP0 -%token INFIXOP1 -%token INFIXOP2 -%token INFIXOP3 -%token INFIXOP4 -%token DOTOP -%token INHERIT -%token INITIALIZER -%token INT -%token LABEL -%token LAZY -%token LBRACE -%token LBRACELESS -%token LBRACKET -%token LBRACKETBAR -%token LBRACKETLESS -%token LBRACKETGREATER -%token LBRACKETPERCENT -%token LBRACKETPERCENTPERCENT -%token LESS -%token LESSMINUS -%token LET -%token LIDENT -%token LPAREN -%token LBRACKETAT -%token LBRACKETATAT -%token LBRACKETATATAT -%token MATCH -%token METHOD -%token MINUS -%token MINUSDOT -%token MINUSGREATER -%token MODULE -%token MUTABLE -%token NEW -%token NONREC -%token OBJECT -%token OF -%token OPEN -%token OPTLABEL -%token OR -/* %token PARSER */ -%token PERCENT -%token PLUS -%token PLUSDOT -%token PLUSEQ -%token PREFIXOP -%token PRIVATE -%token QUESTION -%token QUOTE -%token RBRACE -%token RBRACKET -%token REC -%token RPAREN -%token SEMI -%token SEMISEMI -%token HASH -%token HASHOP -%token SIG -%token STAR -%token STRING -%token STRUCT -%token THEN -%token TILDE -%token TO -%token TRUE -%token TRY -%token TYPE -%token UIDENT -%token UNDERSCORE -%token VAL -%token VIRTUAL -%token WHEN -%token WHILE -%token WITH -%token COMMENT -%token DOCSTRING - -%token EOL - -/* Precedences and associativities. - -Tokens and rules have precedences. A reduce/reduce conflict is resolved -in favor of the first rule (in source file order). A shift/reduce conflict -is resolved by comparing the precedence and associativity of the token to -be shifted with those of the rule to be reduced. - -By default, a rule has the precedence of its rightmost terminal (if any). - -When there is a shift/reduce conflict between a rule and a token that -have the same precedence, it is resolved using the associativity: -if the token is left-associative, the parser will reduce; if -right-associative, the parser will shift; if non-associative, -the parser will declare a syntax error. - -We will only use associativities with operators of the kind x * x -> x -for example, in the rules of the form expr: expr BINOP expr -in all other cases, we define two precedences if needed to resolve -conflicts. - -The precedences must be listed from low to high. -*/ - -%nonassoc IN -%nonassoc below_SEMI -%nonassoc SEMI /* below EQUAL ({lbl=...; lbl=...}) */ -%nonassoc LET /* above SEMI ( ...; let ... in ...) */ -%nonassoc below_WITH -%nonassoc FUNCTION WITH /* below BAR (match ... with ...) */ -%nonassoc AND /* above WITH (module rec A: SIG with ... and ...) */ -%nonassoc THEN /* below ELSE (if ... then ...) */ -%nonassoc ELSE /* (if ... then ... else ...) */ -%nonassoc LESSMINUS /* below COLONEQUAL (lbl <- x := e) */ -%right COLONEQUAL /* expr (e := e := e) */ -%nonassoc AS -%left BAR /* pattern (p|p|p) */ -%nonassoc below_COMMA -%left COMMA /* expr/expr_comma_list (e,e,e) */ -%right MINUSGREATER /* core_type2 (t -> t -> t) */ -%right OR BARBAR /* expr (e || e || e) */ -%right AMPERSAND AMPERAMPER /* expr (e && e && e) */ -%nonassoc below_EQUAL -%left INFIXOP0 EQUAL LESS GREATER /* expr (e OP e OP e) */ -%right INFIXOP1 /* expr (e OP e OP e) */ -%nonassoc below_LBRACKETAT -%nonassoc LBRACKETAT -%nonassoc LBRACKETATAT -%right COLONCOLON /* expr (e :: e :: e) */ -%left INFIXOP2 PLUS PLUSDOT MINUS MINUSDOT PLUSEQ /* expr (e OP e OP e) */ -%left PERCENT INFIXOP3 STAR /* expr (e OP e OP e) */ -%right INFIXOP4 /* expr (e OP e OP e) */ -%nonassoc prec_unary_minus prec_unary_plus /* unary - */ -%nonassoc prec_constant_constructor /* cf. simple_expr (C versus C x) */ -%nonassoc prec_constr_appl /* above AS BAR COLONCOLON COMMA */ -%nonassoc below_HASH -%nonassoc HASH /* simple_expr/toplevel_directive */ -%left HASHOP -%nonassoc below_DOT -%nonassoc DOT DOTOP -/* Finally, the first tokens of simple_expr are above everything else. */ -%nonassoc BACKQUOTE BANG BEGIN CHAR FALSE FLOAT INT - LBRACE LBRACELESS LBRACKET LBRACKETBAR LIDENT LPAREN - NEW PREFIXOP STRING TRUE UIDENT - LBRACKETPERCENT LBRACKETPERCENTPERCENT - - -/* Entry points */ - -%start implementation /* for implementation files */ -%type implementation -%start interface /* for interface files */ -%type interface -%start parse_core_type -%type parse_core_type -%start parse_expression -%type parse_expression -%start parse_pattern -%type parse_pattern -%% - -/* Entry points */ - -implementation: - structure EOF { extra_str 1 $1 } -; -interface: - signature EOF { extra_sig 1 $1 } -; - - -parse_core_type: - core_type EOF { $1 } -; -parse_expression: - seq_expr EOF { $1 } -; -parse_pattern: - pattern EOF { $1 } -; - -/* Module expressions */ - -functor_arg: - LPAREN RPAREN - { mkrhs "*" 2, None } - | LPAREN functor_arg_name COLON module_type RPAREN - { mkrhs $2 2, Some $4 } -; - -functor_arg_name: - UIDENT { $1 } - | UNDERSCORE { "_" } -; - -functor_args: - functor_args functor_arg - { $2 :: $1 } - | functor_arg - { [ $1 ] } -; - -module_expr: - mod_longident - { mkmod(Pmod_ident (mkrhs $1 1)) } - | STRUCT attributes structure END - { mkmod ~attrs:$2 (Pmod_structure(extra_str 3 $3)) } - | STRUCT attributes structure error - { unclosed "struct" 1 "end" 4 } - | FUNCTOR attributes functor_args MINUSGREATER module_expr - { let modexp = - List.fold_left - (fun acc (n, t) -> mkmod(Pmod_functor(n, t, acc))) - $5 $3 - in wrap_mod_attrs modexp $2 } - | module_expr paren_module_expr - { mkmod(Pmod_apply($1, $2)) } - | module_expr LPAREN RPAREN - { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) } - | paren_module_expr - { $1 } - | module_expr attribute - { Mod.attr $1 $2 } - | extension - { mkmod(Pmod_extension $1) } -; - -paren_module_expr: - LPAREN module_expr COLON module_type RPAREN - { mkmod(Pmod_constraint($2, $4)) } - | LPAREN module_expr COLON module_type error - { unclosed "(" 1 ")" 5 } - | LPAREN module_expr RPAREN - { $2 } - | LPAREN module_expr error - { unclosed "(" 1 ")" 3 } - | LPAREN VAL attributes expr RPAREN - { mkmod ~attrs:$3 (Pmod_unpack $4)} - | LPAREN VAL attributes expr COLON package_type RPAREN - { mkmod ~attrs:$3 - (Pmod_unpack( - ghexp(Pexp_constraint($4, ghtyp(Ptyp_package $6))))) } - | LPAREN VAL attributes expr COLON package_type COLONGREATER package_type - RPAREN - { mkmod ~attrs:$3 - (Pmod_unpack( - ghexp(Pexp_coerce($4, Some(ghtyp(Ptyp_package $6)), - ghtyp(Ptyp_package $8))))) } - | LPAREN VAL attributes expr COLONGREATER package_type RPAREN - { mkmod ~attrs:$3 - (Pmod_unpack( - ghexp(Pexp_coerce($4, None, ghtyp(Ptyp_package $6))))) } - | LPAREN VAL attributes expr COLON error - { unclosed "(" 1 ")" 6 } - | LPAREN VAL attributes expr COLONGREATER error - { unclosed "(" 1 ")" 6 } - | LPAREN VAL attributes expr error - { unclosed "(" 1 ")" 5 } -; - -structure: - seq_expr post_item_attributes structure_tail - { mark_rhs_docs 1 2; - (text_str 1) @ mkstrexp $1 $2 :: $3 } - | structure_tail { $1 } -; -structure_tail: - /* empty */ { [] } - | SEMISEMI structure { (text_str 1) @ $2 } - | structure_item structure_tail { (text_str 1) @ $1 :: $2 } -; -structure_item: - let_bindings - { val_of_let_bindings $1 } - | primitive_declaration - { let (body, ext) = $1 in mkstr_ext (Pstr_primitive body) ext } - | value_description - { let (body, ext) = $1 in mkstr_ext (Pstr_primitive body) ext } - | type_declarations - { let (nr, l, ext ) = $1 in mkstr_ext (Pstr_type (nr, List.rev l)) ext } - | str_type_extension - { let (l, ext) = $1 in mkstr_ext (Pstr_typext l) ext } - | str_exception_declaration - { let (l, ext) = $1 in mkstr_ext (Pstr_exception l) ext } - | module_binding - { let (body, ext) = $1 in mkstr_ext (Pstr_module body) ext } - | rec_module_bindings - { let (l, ext) = $1 in mkstr_ext (Pstr_recmodule(List.rev l)) ext } - | module_type_declaration - { let (body, ext) = $1 in mkstr_ext (Pstr_modtype body) ext } - | open_statement - { let (body, ext) = $1 in mkstr_ext (Pstr_open body) ext } - | class_type_declarations - { let (l, ext) = $1 in mkstr_ext (Pstr_class_type (List.rev l)) ext } - | str_include_statement - { let (body, ext) = $1 in mkstr_ext (Pstr_include body) ext } - | item_extension post_item_attributes - { mkstr(Pstr_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } - | floating_attribute - { mark_symbol_docs (); - mkstr(Pstr_attribute $1) } -; -str_include_statement: - INCLUDE ext_attributes module_expr post_item_attributes - { let (ext, attrs) = $2 in - Incl.mk $3 ~attrs:(attrs@$4) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -module_binding_body: - EQUAL module_expr - { $2 } - | COLON module_type EQUAL module_expr - { mkmod(Pmod_constraint($4, $2)) } - | functor_arg module_binding_body - { mkmod(Pmod_functor(fst $1, snd $1, $2)) } -; -module_binding: - MODULE ext_attributes UIDENT module_binding_body post_item_attributes - { let (ext, attrs) = $2 in - Mb.mk (mkrhs $3 3) $4 ~attrs:(attrs@$5) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; -rec_module_bindings: - rec_module_binding { let (b, ext) = $1 in ([b], ext) } - | rec_module_bindings and_module_binding - { let (l, ext) = $1 in ($2 :: l, ext) } -; -rec_module_binding: - MODULE ext_attributes REC UIDENT module_binding_body post_item_attributes - { let (ext, attrs) = $2 in - Mb.mk (mkrhs $4 4) $5 ~attrs:(attrs@$6) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; -and_module_binding: - AND attributes UIDENT module_binding_body post_item_attributes - { Mb.mk (mkrhs $3 3) $4 ~attrs:($2@$5) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; - -/* Module types */ - -module_type: - mty_longident - { mkmty(Pmty_ident (mkrhs $1 1)) } - | SIG attributes signature END - { mkmty ~attrs:$2 (Pmty_signature (extra_sig 3 $3)) } - | SIG attributes signature error - { unclosed "sig" 1 "end" 4 } - | FUNCTOR attributes functor_args MINUSGREATER module_type - %prec below_WITH - { let mty = - List.fold_left - (fun acc (n, t) -> mkmty(Pmty_functor(n, t, acc))) - $5 $3 - in wrap_mty_attrs mty $2 } - | module_type MINUSGREATER module_type - %prec below_WITH - { mkmty(Pmty_functor(mknoloc "_", Some $1, $3)) } - | module_type WITH with_constraints - { mkmty(Pmty_with($1, List.rev $3)) } - | MODULE TYPE OF attributes module_expr %prec below_LBRACKETAT - { mkmty ~attrs:$4 (Pmty_typeof $5) } -/* | LPAREN MODULE mod_longident RPAREN - { mkmty (Pmty_alias (mkrhs $3 3)) } */ - | LPAREN module_type RPAREN - { $2 } - | LPAREN module_type error - { unclosed "(" 1 ")" 3 } - | extension - { mkmty(Pmty_extension $1) } - | module_type attribute - { Mty.attr $1 $2 } -; -signature: - /* empty */ { [] } - | SEMISEMI signature { (text_sig 1) @ $2 } - | signature_item signature { (text_sig 1) @ $1 :: $2 } -; -signature_item: - value_description - { let (body, ext) = $1 in mksig_ext (Psig_value body) ext } - | primitive_declaration - { let (body, ext) = $1 in mksig_ext (Psig_value body) ext} - | type_declarations - { let (nr, l, ext) = $1 in mksig_ext (Psig_type (nr, List.rev l)) ext } - | sig_type_extension - { let (l, ext) = $1 in mksig_ext (Psig_typext l) ext } - | sig_exception_declaration - { let (l, ext) = $1 in mksig_ext (Psig_exception l) ext } - | module_declaration - { let (body, ext) = $1 in mksig_ext (Psig_module body) ext } - | module_alias - { let (body, ext) = $1 in mksig_ext (Psig_module body) ext } - | rec_module_declarations - { let (l, ext) = $1 in mksig_ext (Psig_recmodule (List.rev l)) ext } - | module_type_declaration - { let (body, ext) = $1 in mksig_ext (Psig_modtype body) ext } - | open_statement - { let (body, ext) = $1 in mksig_ext (Psig_open body) ext } - | sig_include_statement - { let (body, ext) = $1 in mksig_ext (Psig_include body) ext } - | class_type_declarations - { let (l, ext) = $1 in mksig_ext (Psig_class_type (List.rev l)) ext } - | item_extension post_item_attributes - { mksig(Psig_extension ($1, (add_docs_attrs (symbol_docs ()) $2))) } - | floating_attribute - { mark_symbol_docs (); - mksig(Psig_attribute $1) } -; -open_statement: - | OPEN override_flag ext_attributes mod_longident post_item_attributes - { let (ext, attrs) = $3 in - Opn.mk (mkrhs $4 4) ~override:$2 ~attrs:(attrs@$5) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext} -; -sig_include_statement: - INCLUDE ext_attributes module_type post_item_attributes %prec below_WITH - { let (ext, attrs) = $2 in - Incl.mk $3 ~attrs:(attrs@$4) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext} -; -module_declaration_body: - COLON module_type - { $2 } - | LPAREN UIDENT COLON module_type RPAREN module_declaration_body - { mkmty(Pmty_functor(mkrhs $2 2, Some $4, $6)) } - | LPAREN RPAREN module_declaration_body - { mkmty(Pmty_functor(mkrhs "*" 1, None, $3)) } -; -module_declaration: - MODULE ext_attributes UIDENT module_declaration_body post_item_attributes - { let (ext, attrs) = $2 in - Md.mk (mkrhs $3 3) $4 ~attrs:(attrs@$5) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -module_alias: - MODULE ext_attributes UIDENT EQUAL mod_longident post_item_attributes - { let (ext, attrs) = $2 in - Md.mk (mkrhs $3 3) - (Mty.alias ~loc:(rhs_loc 5) (mkrhs $5 5)) ~attrs:(attrs@$6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -rec_module_declarations: - rec_module_declaration - { let (body, ext) = $1 in ([body], ext) } - | rec_module_declarations and_module_declaration - { let (l, ext) = $1 in ($2 :: l, ext) } -; -rec_module_declaration: - MODULE ext_attributes REC UIDENT COLON module_type post_item_attributes - { let (ext, attrs) = $2 in - Md.mk (mkrhs $4 4) $6 ~attrs:(attrs@$7) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext} -; -and_module_declaration: - AND attributes UIDENT COLON module_type post_item_attributes - { Md.mk (mkrhs $3 3) $5 ~attrs:($2@$6) ~loc:(symbol_rloc()) - ~text:(symbol_text()) ~docs:(symbol_docs()) } -; -module_type_declaration_body: - /* empty */ { None } - | EQUAL module_type { Some $2 } -; -module_type_declaration: - MODULE TYPE ext_attributes ident module_type_declaration_body - post_item_attributes - { let (ext, attrs) = $3 in - Mtd.mk (mkrhs $4 4) ?typ:$5 ~attrs:(attrs@$6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -/* Class expressions */ - -class_type_parameters: - /*empty*/ { [] } - | LBRACKET type_parameter_list RBRACKET { List.rev $2 } -; -class_structure: - | class_self_pattern class_fields - { Cstr.mk $1 (extra_cstr 2 (List.rev $2)) } -; -class_self_pattern: - LPAREN pattern RPAREN - { reloc_pat $2 } - | LPAREN pattern COLON core_type RPAREN - { mkpat(Ppat_constraint($2, $4)) } - | /* empty */ - { ghpat(Ppat_any) } -; -class_fields: - /* empty */ - { [] } - | class_fields class_field - { $2 :: (text_cstr 2) @ $1 } -; -class_field: - | VAL value post_item_attributes - { let v, attrs = $2 in - mkcf (Pcf_val v) ~attrs:(attrs@$3) ~docs:(symbol_docs ()) } - | METHOD method_ post_item_attributes - { let meth, attrs = $2 in - mkcf (Pcf_method meth) ~attrs:(attrs@$3) ~docs:(symbol_docs ()) } - | CONSTRAINT attributes constrain_field post_item_attributes - { mkcf (Pcf_constraint $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | INITIALIZER attributes seq_expr post_item_attributes - { mkcf (Pcf_initializer $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | item_extension post_item_attributes - { mkcf (Pcf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } - | floating_attribute - { mark_symbol_docs (); - mkcf (Pcf_attribute $1) } -; -value: -/* TODO: factorize these rules (also with method): */ - override_flag attributes MUTABLE VIRTUAL label COLON core_type - { if $1 = Override then syntax_error (); - (mkloc $5 (rhs_loc 5), Mutable, Cfk_virtual $7), $2 } - | override_flag attributes VIRTUAL mutable_flag label COLON core_type - { if $1 = Override then syntax_error (); - (mkrhs $5 5, $4, Cfk_virtual $7), $2 } - | override_flag attributes mutable_flag label EQUAL seq_expr - { (mkrhs $4 4, $3, Cfk_concrete ($1, $6)), $2 } - | override_flag attributes mutable_flag label type_constraint EQUAL seq_expr - { - let e = mkexp_constraint $7 $5 in - (mkrhs $4 4, $3, Cfk_concrete ($1, e)), $2 - } -; -method_: -/* TODO: factorize those rules... */ - override_flag attributes PRIVATE VIRTUAL label COLON poly_type - { if $1 = Override then syntax_error (); - (mkloc $5 (rhs_loc 5), Private, Cfk_virtual $7), $2 } - | override_flag attributes VIRTUAL private_flag label COLON poly_type - { if $1 = Override then syntax_error (); - (mkloc $5 (rhs_loc 5), $4, Cfk_virtual $7), $2 } - | override_flag attributes private_flag label strict_binding - { (mkloc $4 (rhs_loc 4), $3, - Cfk_concrete ($1, ghexp(Pexp_poly ($5, None)))), $2 } - | override_flag attributes private_flag label COLON poly_type EQUAL seq_expr - { (mkloc $4 (rhs_loc 4), $3, - Cfk_concrete ($1, ghexp(Pexp_poly($8, Some $6)))), $2 } - | override_flag attributes private_flag label COLON TYPE lident_list - DOT core_type EQUAL seq_expr - { let exp, poly = wrap_type_annotation $7 $9 $11 in - (mkloc $4 (rhs_loc 4), $3, - Cfk_concrete ($1, ghexp(Pexp_poly(exp, Some poly)))), $2 } -; - -/* Class types */ - -class_signature: - LBRACKET core_type_comma_list RBRACKET clty_longident - { mkcty(Pcty_constr (mkloc $4 (rhs_loc 4), List.rev $2)) } - | clty_longident - { mkcty(Pcty_constr (mkrhs $1 1, [])) } - | OBJECT attributes class_sig_body END - { mkcty ~attrs:$2 (Pcty_signature $3) } - | OBJECT attributes class_sig_body error - { unclosed "object" 1 "end" 4 } - | class_signature attribute - { Cty.attr $1 $2 } - | extension - { mkcty(Pcty_extension $1) } - | LET OPEN override_flag attributes mod_longident IN class_signature - { wrap_class_type_attrs (mkcty(Pcty_open($3, mkrhs $5 5, $7))) $4 } -; -class_sig_body: - class_self_type class_sig_fields - { Csig.mk $1 (extra_csig 2 (List.rev $2)) } -; -class_self_type: - LPAREN core_type RPAREN - { $2 } - | /* empty */ - { mktyp(Ptyp_any) } -; -class_sig_fields: - /* empty */ { [] } -| class_sig_fields class_sig_field { $2 :: (text_csig 2) @ $1 } -; -class_sig_field: - INHERIT attributes class_signature post_item_attributes - { mkctf (Pctf_inherit $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | VAL attributes value_type post_item_attributes - { mkctf (Pctf_val $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | METHOD attributes private_virtual_flags label COLON poly_type - post_item_attributes - { - let (p, v) = $3 in - mkctf (Pctf_method (mkrhs $4 4, p, v, $6)) ~attrs:($2@$7) ~docs:(symbol_docs ()) - } - | CONSTRAINT attributes constrain_field post_item_attributes - { mkctf (Pctf_constraint $3) ~attrs:($2@$4) ~docs:(symbol_docs ()) } - | item_extension post_item_attributes - { mkctf (Pctf_extension $1) ~attrs:$2 ~docs:(symbol_docs ()) } - | floating_attribute - { mark_symbol_docs (); - mkctf(Pctf_attribute $1) } -; -value_type: - VIRTUAL mutable_flag label COLON core_type - { mkrhs $3 3, $2, Virtual, $5 } - | MUTABLE virtual_flag label COLON core_type - { mkrhs $3 3, Mutable, $2, $5 } - | label COLON core_type - { mkrhs $1 1, Immutable, Concrete, $3 } -; -constrain: - core_type EQUAL core_type { $1, $3, symbol_rloc() } -; -constrain_field: - core_type EQUAL core_type { $1, $3 } -; -class_type_declarations: - class_type_declaration - { let (body, ext) = $1 in ([body],ext) } - | class_type_declarations and_class_type_declaration - { let (l, ext) = $1 in ($2 :: l, ext) } -; -class_type_declaration: - CLASS TYPE ext_attributes virtual_flag class_type_parameters LIDENT EQUAL - class_signature post_item_attributes - { let (ext, attrs) = $3 in - Ci.mk (mkrhs $6 6) $8 ~virt:$4 ~params:$5 ~attrs:(attrs@$9) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext} -; -and_class_type_declaration: - AND attributes virtual_flag class_type_parameters LIDENT EQUAL - class_signature post_item_attributes - { Ci.mk (mkrhs $5 5) $7 ~virt:$3 ~params:$4 - ~attrs:($2@$8) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; - -/* Core expressions */ - -seq_expr: - | expr %prec below_SEMI { $1 } - | expr SEMI { $1 } - | expr SEMI seq_expr { mkexp(Pexp_sequence($1, $3)) } - | expr SEMI PERCENT attr_id seq_expr - { let seq = mkexp(Pexp_sequence ($1, $5)) in - let payload = PStr [mkstrexp seq []] in - mkexp (Pexp_extension ($4, payload)) } -; -labeled_simple_pattern: - QUESTION LPAREN label_let_pattern opt_default RPAREN - { (Optional (fst $3), $4, snd $3) } - | QUESTION label_var - { (Optional (fst $2), None, snd $2) } - | OPTLABEL LPAREN let_pattern opt_default RPAREN - { (Optional $1, $4, $3) } - | OPTLABEL pattern_var - { (Optional $1, None, $2) } - | TILDE LPAREN label_let_pattern RPAREN - { (Labelled (fst $3), None, snd $3) } - | TILDE label_var - { (Labelled (fst $2), None, snd $2) } - | LABEL simple_pattern - { (Labelled $1, None, $2) } - | simple_pattern - { (Nolabel, None, $1) } -; -pattern_var: - LIDENT { mkpat(Ppat_var (mkrhs $1 1)) } - | UNDERSCORE { mkpat Ppat_any } -; -opt_default: - /* empty */ { None } - | EQUAL seq_expr { Some $2 } -; -label_let_pattern: - label_var - { $1 } - | label_var COLON core_type - { let (lab, pat) = $1 in (lab, mkpat(Ppat_constraint(pat, $3))) } -; -label_var: - LIDENT { ($1, mkpat(Ppat_var (mkrhs $1 1))) } -; -let_pattern: - pattern - { $1 } - | pattern COLON core_type - { mkpat(Ppat_constraint($1, $3)) } -; -expr: - simple_expr %prec below_HASH - { $1 } - | simple_expr simple_labeled_expr_list - { mkexp(Pexp_apply($1, List.rev $2)) } - | let_bindings IN seq_expr - { expr_of_let_bindings $1 $3 } - | LET MODULE ext_attributes UIDENT module_binding_body IN seq_expr - { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 } - | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr - { mkexp_attrs (Pexp_letexception($4, $6)) $3 } - | LET OPEN override_flag ext_attributes mod_longident IN seq_expr - { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 } - | FUNCTION ext_attributes opt_bar match_cases - { mkexp_attrs (Pexp_function(List.rev $4)) $2 } - | FUN ext_attributes labeled_simple_pattern fun_def - { let (l,o,p) = $3 in - mkexp_attrs (Pexp_fun(l, o, p, $4)) $2 } - | FUN ext_attributes LPAREN TYPE lident_list RPAREN fun_def - { mkexp_attrs (mk_newtypes $5 $7).pexp_desc $2 } - | MATCH ext_attributes seq_expr WITH opt_bar match_cases - { mkexp_attrs (Pexp_match($3, List.rev $6)) $2 } - | TRY ext_attributes seq_expr WITH opt_bar match_cases - { mkexp_attrs (Pexp_try($3, List.rev $6)) $2 } - | TRY ext_attributes seq_expr WITH error - { syntax_error() } - | expr_comma_list %prec below_COMMA - { mkexp(Pexp_tuple(List.rev $1)) } - | constr_longident simple_expr %prec below_HASH - { mkexp(Pexp_construct(mkrhs $1 1, Some $2)) } - | name_tag simple_expr %prec below_HASH - { mkexp(Pexp_variant($1, Some $2)) } - | IF ext_attributes seq_expr THEN expr ELSE expr - { mkexp_attrs(Pexp_ifthenelse($3, $5, Some $7)) $2 } - | IF ext_attributes seq_expr THEN expr - { mkexp_attrs (Pexp_ifthenelse($3, $5, None)) $2 } - | WHILE ext_attributes seq_expr DO seq_expr DONE - { mkexp_attrs (Pexp_while($3, $5)) $2 } - | FOR ext_attributes pattern EQUAL seq_expr direction_flag seq_expr DO - seq_expr DONE - { mkexp_attrs(Pexp_for($3, $5, $7, $6, $9)) $2 } - | expr COLONCOLON expr - { mkexp_cons (rhs_loc 2) (ghexp(Pexp_tuple[$1;$3])) (symbol_rloc()) } - | expr INFIXOP0 expr - { mkinfix $1 $2 $3 } - | expr INFIXOP1 expr - { mkinfix $1 $2 $3 } - | expr INFIXOP2 expr - { mkinfix $1 $2 $3 } - | expr INFIXOP3 expr - { mkinfix $1 $2 $3 } - | expr INFIXOP4 expr - { mkinfix $1 $2 $3 } - | expr PLUS expr - { mkinfix $1 "+" $3 } - | expr PLUSDOT expr - { mkinfix $1 "+." $3 } - | expr PLUSEQ expr - { mkinfix $1 "+=" $3 } - | expr MINUS expr - { mkinfix $1 "-" $3 } - | expr MINUSDOT expr - { mkinfix $1 "-." $3 } - | expr STAR expr - { mkinfix $1 "*" $3 } - | expr PERCENT expr - { mkinfix $1 "%" $3 } - | expr EQUAL expr - { mkinfix $1 "=" $3 } - | expr LESS expr - { mkinfix $1 "<" $3 } - | expr GREATER expr - { mkinfix $1 ">" $3 } - | expr OR expr - { mkinfix $1 "or" $3 } - | expr BARBAR expr - { mkinfix $1 "||" $3 } - | expr AMPERSAND expr - { mkinfix $1 "&" $3 } - | expr AMPERAMPER expr - { mkinfix $1 "&&" $3 } - | expr COLONEQUAL expr - { mkinfix $1 ":=" $3 } - | subtractive expr %prec prec_unary_minus - { mkuminus $1 $2 } - | additive expr %prec prec_unary_plus - { mkuplus $1 $2 } - | simple_expr DOT label_longident LESSMINUS expr - { mkexp(Pexp_setfield($1, mkrhs $3 3, $5)) } - | simple_expr DOT LPAREN seq_expr RPAREN LESSMINUS expr - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "set")), - [Nolabel,$1; Nolabel,$4; Nolabel,$7])) } - | simple_expr DOT LBRACKET seq_expr RBRACKET LESSMINUS expr - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "set")), - [Nolabel,$1; Nolabel,$4; Nolabel,$7])) } - | simple_expr DOTOP LBRACKET expr RBRACKET LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) } - | simple_expr DOTOP LPAREN expr RPAREN LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) } - | simple_expr DOTOP LBRACE expr RBRACE LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $4; Nolabel, $7]) } - | simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3,"." ^ $4 ^ "[]<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) } - | simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) } - | simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE LESSMINUS expr - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}<-")) in - mkexp @@ Pexp_apply(id , [Nolabel, $1; Nolabel, $6; Nolabel, $9]) } - | label LESSMINUS expr - { mkexp(Pexp_setinstvar(mkrhs $1 1, $3)) } - | ASSERT ext_attributes simple_expr %prec below_HASH - { mkexp_attrs (Pexp_assert $3) $2 } - | LAZY ext_attributes simple_expr %prec below_HASH - { mkexp_attrs (Pexp_lazy $3) $2 } - | OBJECT ext_attributes class_structure END - { mkexp_attrs (Pexp_object $3) $2 } - | OBJECT ext_attributes class_structure error - { unclosed "object" 1 "end" 4 } - | expr attribute - { Exp.attr $1 $2 } - | UNDERSCORE - { not_expecting 1 "wildcard \"_\"" } -; -simple_expr: - val_longident - { mkexp(Pexp_ident (mkrhs $1 1)) } - | constant - { mkexp(Pexp_constant $1) } - | constr_longident %prec prec_constant_constructor - { mkexp(Pexp_construct(mkrhs $1 1, None)) } - | name_tag %prec prec_constant_constructor - { mkexp(Pexp_variant($1, None)) } - | LPAREN seq_expr RPAREN - { reloc_exp $2 } - | LPAREN seq_expr error - { unclosed "(" 1 ")" 3 } - | BEGIN ext_attributes seq_expr END - { wrap_exp_attrs (reloc_exp $3) $2 (* check location *) } - | BEGIN ext_attributes END - { mkexp_attrs (Pexp_construct (mkloc (Lident "()") (symbol_rloc ()), - None)) $2 } - | BEGIN ext_attributes seq_expr error - { unclosed "begin" 1 "end" 4 } - | LPAREN seq_expr type_constraint RPAREN - { mkexp_constraint $2 $3 } - | simple_expr DOT label_longident - { mkexp(Pexp_field($1, mkrhs $3 3)) } - | mod_longident DOT LPAREN seq_expr RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) } - | mod_longident DOT LPAREN RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, - mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) } - | mod_longident DOT LPAREN seq_expr error - { unclosed "(" 3 ")" 5 } - | simple_expr DOT LPAREN seq_expr RPAREN - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "Array" "get")), - [Nolabel,$1; Nolabel,$4])) } - | simple_expr DOT LPAREN seq_expr error - { unclosed "(" 3 ")" 5 } - | simple_expr DOT LBRACKET seq_expr RBRACKET - { mkexp(Pexp_apply(ghexp(Pexp_ident(array_function "String" "get")), - [Nolabel,$1; Nolabel,$4])) } - | simple_expr DOT LBRACKET seq_expr error - { unclosed "[" 3 "]" 5 } - | simple_expr DOTOP LBRACKET expr RBRACKET - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "[]")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) } - | simple_expr DOTOP LBRACKET expr error - { unclosed "[" 3 "]" 5 } - | simple_expr DOTOP LPAREN expr RPAREN - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "()")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) } - | simple_expr DOTOP LPAREN expr error - { unclosed "(" 3 ")" 5 } - | simple_expr DOTOP LBRACE expr RBRACE - { let id = mkexp @@ Pexp_ident( ghloc @@ Lident ("." ^ $2 ^ "{}")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $4]) } - | simple_expr DOTOP LBRACE expr error - { unclosed "{" 3 "}" 5 } - | simple_expr DOT mod_longident DOTOP LBRACKET expr RBRACKET - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "[]")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) } - | simple_expr DOT mod_longident DOTOP LBRACKET expr error - { unclosed "[" 5 "]" 7 } - | simple_expr DOT mod_longident DOTOP LPAREN expr RPAREN - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "()")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) } - | simple_expr DOT mod_longident DOTOP LPAREN expr error - { unclosed "(" 5 ")" 7 } - | simple_expr DOT mod_longident DOTOP LBRACE expr RBRACE - { let id = mkexp @@ Pexp_ident( ghloc @@ Ldot($3, "." ^ $4 ^ "{}")) in - mkexp @@ Pexp_apply(id, [Nolabel, $1; Nolabel, $6]) } - | simple_expr DOT mod_longident DOTOP LBRACE expr error - { unclosed "{" 5 "}" 7 } - | simple_expr DOT LBRACE expr_comma_list error - { unclosed "{" 3 "}" 5 } - | LBRACE record_expr RBRACE - { let (exten, fields) = $2 in mkexp (Pexp_record(fields, exten)) } - | LBRACE record_expr error - { unclosed "{" 1 "}" 3 } - | mod_longident DOT LBRACE record_expr RBRACE - { let (exten, fields) = $4 in - let rec_exp = mkexp(Pexp_record(fields, exten)) in - mkexp(Pexp_open(Fresh, mkrhs $1 1, rec_exp)) } - | mod_longident DOT LBRACE record_expr error - { unclosed "{" 3 "}" 5 } - | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET - { mkexp (Pexp_array(List.rev $2)) } - | LBRACKETBAR expr_semi_list opt_semi error - { unclosed "[|" 1 "|]" 4 } - | LBRACKETBAR BARRBRACKET - { mkexp (Pexp_array []) } - | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi BARRBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array(List.rev $4)))) } - | mod_longident DOT LBRACKETBAR BARRBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array []))) } - | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi error - { unclosed "[|" 3 "|]" 6 } - | LBRACKET expr_semi_list opt_semi RBRACKET - { reloc_exp (mktailexp (rhs_loc 4) (List.rev $2)) } - | LBRACKET expr_semi_list opt_semi error - { unclosed "[" 1 "]" 4 } - | mod_longident DOT LBRACKET expr_semi_list opt_semi RBRACKET - { let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev $4)) in - mkexp(Pexp_open(Fresh, mkrhs $1 1, list_exp)) } - | mod_longident DOT LBRACKET RBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, - mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) } - | mod_longident DOT LBRACKET expr_semi_list opt_semi error - { unclosed "[" 3 "]" 6 } - | PREFIXOP simple_expr - { mkexp(Pexp_apply(mkoperator $1 1, [Nolabel,$2])) } - | BANG simple_expr - { mkexp(Pexp_apply(mkoperator "!" 1, [Nolabel,$2])) } - | LBRACELESS field_expr_list GREATERRBRACE - { mkexp (Pexp_override $2) } - | LBRACELESS field_expr_list error - { unclosed "{<" 1 ">}" 3 } - | LBRACELESS GREATERRBRACE - { mkexp (Pexp_override [])} - | mod_longident DOT LBRACELESS field_expr_list GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override $4)))} - | mod_longident DOT LBRACELESS GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))} - | mod_longident DOT LBRACELESS field_expr_list error - { unclosed "{<" 3 ">}" 5 } - | simple_expr HASH label - { mkexp(Pexp_send($1, mkrhs $3 3)) } - | simple_expr HASHOP simple_expr - { mkinfix $1 $2 $3 } - | LPAREN MODULE ext_attributes module_expr RPAREN - { mkexp_attrs (Pexp_pack $4) $3 } - | LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN - { mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $4), - ghtyp (Ptyp_package $6))) - $3 } - | LPAREN MODULE ext_attributes module_expr COLON error - { unclosed "(" 1 ")" 6 } - | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON - package_type RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, - mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $6), - ghtyp (Ptyp_package $8))) - $5 )) } - | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON error - { unclosed "(" 3 ")" 8 } - | extension - { mkexp (Pexp_extension $1) } -; -simple_labeled_expr_list: - labeled_simple_expr - { [$1] } - | simple_labeled_expr_list labeled_simple_expr - { $2 :: $1 } -; -labeled_simple_expr: - simple_expr %prec below_HASH - { (Nolabel, $1) } - | label_expr - { $1 } -; -label_expr: - LABEL simple_expr %prec below_HASH - { (Labelled $1, $2) } - | TILDE label_ident - { (Labelled (fst $2), snd $2) } - | QUESTION label_ident - { (Optional (fst $2), snd $2) } - | OPTLABEL simple_expr %prec below_HASH - { (Optional $1, $2) } -; -label_ident: - LIDENT { ($1, mkexp(Pexp_ident(mkrhs (Lident $1) 1))) } -; -lident_list: - LIDENT { [mkrhs $1 1] } - | LIDENT lident_list { mkrhs $1 1 :: $2 } -; -let_binding_body: - val_ident strict_binding - { (mkpatvar $1 1, $2) } - | val_ident type_constraint EQUAL seq_expr - { let v = mkpatvar $1 1 in (* PR#7344 *) - let t = - match $2 with - Some t, None -> t - | _, Some t -> t - | _ -> assert false - in - (ghpat(Ppat_constraint(v, ghtyp(Ptyp_poly([],t)))), - mkexp_constraint $4 $2) } - | val_ident COLON typevar_list DOT core_type EQUAL seq_expr - { (ghpat(Ppat_constraint(mkpatvar $1 1, - ghtyp(Ptyp_poly(List.rev $3,$5)))), - $7) } - | val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr - { let exp, poly = wrap_type_annotation $4 $6 $8 in - (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) } - | pattern_no_exn EQUAL seq_expr - { ($1, $3) } - | simple_pattern_not_ident COLON core_type EQUAL seq_expr - { (ghpat(Ppat_constraint($1, $3)), $5) } -; -let_bindings: - let_binding { $1 } - | let_bindings and_let_binding { addlb $1 $2 } -; -let_binding: - LET ext_attributes rec_flag let_binding_body post_item_attributes - { let (ext, attr) = $2 in - mklbs ext $3 (mklb true $4 (attr@$5)) } -; -and_let_binding: - AND attributes let_binding_body post_item_attributes - { mklb false $3 ($2@$4) } -; -fun_binding: - strict_binding - { $1 } - | type_constraint EQUAL seq_expr - { mkexp_constraint $3 $1 } -; -strict_binding: - EQUAL seq_expr - { $2 } - | labeled_simple_pattern fun_binding - { let (l, o, p) = $1 in ghexp(Pexp_fun(l, o, p, $2)) } - | LPAREN TYPE lident_list RPAREN fun_binding - { mk_newtypes $3 $5 } -; -match_cases: - match_case { [$1] } - | match_cases BAR match_case { $3 :: $1 } -; -match_case: - pattern MINUSGREATER seq_expr - { Exp.case $1 $3 } - | pattern WHEN seq_expr MINUSGREATER seq_expr - { Exp.case $1 ~guard:$3 $5 } - | pattern MINUSGREATER DOT - { Exp.case $1 (Exp.unreachable ~loc:(rhs_loc 3) ())} -; -fun_def: - MINUSGREATER seq_expr - { $2 } - | COLON simple_core_type MINUSGREATER seq_expr - { mkexp (Pexp_constraint ($4, $2)) } -/* Cf #5939: we used to accept (fun p when e0 -> e) */ - | labeled_simple_pattern fun_def - { - let (l,o,p) = $1 in - ghexp(Pexp_fun(l, o, p, $2)) - } - | LPAREN TYPE lident_list RPAREN fun_def - { mk_newtypes $3 $5 } -; -expr_comma_list: - expr_comma_list COMMA expr { $3 :: $1 } - | expr COMMA expr { [$3; $1] } -; -record_expr: - simple_expr WITH lbl_expr_list { (Some $1, $3) } - | lbl_expr_list { (None, $1) } -; -lbl_expr_list: - lbl_expr { [$1] } - | lbl_expr SEMI lbl_expr_list { $1 :: $3 } - | lbl_expr SEMI { [$1] } -; -lbl_expr: - label_longident opt_type_constraint EQUAL expr - { (mkrhs $1 1, mkexp_opt_constraint $4 $2) } - | label_longident opt_type_constraint - { (mkrhs $1 1, mkexp_opt_constraint (exp_of_label $1 1) $2) } -; -field_expr_list: - field_expr opt_semi { [$1] } - | field_expr SEMI field_expr_list { $1 :: $3 } -; -field_expr: - label EQUAL expr - { (mkrhs $1 1, $3) } - | label - { (mkrhs $1 1, exp_of_label (Lident $1) 1) } -; -expr_semi_list: - expr { [$1] } - | expr_semi_list SEMI expr { $3 :: $1 } -; -type_constraint: - COLON core_type { (Some $2, None) } - | COLON core_type COLONGREATER core_type { (Some $2, Some $4) } - | COLONGREATER core_type { (None, Some $2) } - | COLON error { syntax_error() } - | COLONGREATER error { syntax_error() } -; -opt_type_constraint: - type_constraint { Some $1 } - | /* empty */ { None } -; - -/* Patterns */ - -pattern: - | pattern AS val_ident - { mkpat(Ppat_alias($1, mkrhs $3 3)) } - | pattern AS error - { expecting 3 "identifier" } - | pattern_comma_list %prec below_COMMA - { mkpat(Ppat_tuple(List.rev $1)) } - | pattern COLONCOLON pattern - { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) } - | pattern COLONCOLON error - { expecting 3 "pattern" } - | pattern BAR pattern - { mkpat(Ppat_or($1, $3)) } - | pattern BAR error - { expecting 3 "pattern" } - | EXCEPTION ext_attributes pattern %prec prec_constr_appl - { mkpat_attrs (Ppat_exception $3) $2} - | pattern attribute - { Pat.attr $1 $2 } - | pattern_gen { $1 } -; -pattern_no_exn: - | pattern_no_exn AS val_ident - { mkpat(Ppat_alias($1, mkrhs $3 3)) } - | pattern_no_exn AS error - { expecting 3 "identifier" } - | pattern_no_exn_comma_list %prec below_COMMA - { mkpat(Ppat_tuple(List.rev $1)) } - | pattern_no_exn COLONCOLON pattern - { mkpat_cons (rhs_loc 2) (ghpat(Ppat_tuple[$1;$3])) (symbol_rloc()) } - | pattern_no_exn COLONCOLON error - { expecting 3 "pattern" } - | pattern_no_exn BAR pattern - { mkpat(Ppat_or($1, $3)) } - | pattern_no_exn BAR error - { expecting 3 "pattern" } - | pattern_no_exn attribute - { Pat.attr $1 $2 } - | pattern_gen { $1 } -; -pattern_gen: - simple_pattern - { $1 } - | constr_longident pattern %prec prec_constr_appl - { mkpat(Ppat_construct(mkrhs $1 1, Some $2)) } - | name_tag pattern %prec prec_constr_appl - { mkpat(Ppat_variant($1, Some $2)) } - | LAZY ext_attributes simple_pattern - { mkpat_attrs (Ppat_lazy $3) $2} -; -simple_pattern: - val_ident %prec below_EQUAL - { mkpat(Ppat_var (mkrhs $1 1)) } - | simple_pattern_not_ident { $1 } -; -simple_pattern_not_ident: - | UNDERSCORE - { mkpat(Ppat_any) } - | signed_constant - { mkpat(Ppat_constant $1) } - | signed_constant DOTDOT signed_constant - { mkpat(Ppat_interval ($1, $3)) } - | constr_longident - { mkpat(Ppat_construct(mkrhs $1 1, None)) } - | name_tag - { mkpat(Ppat_variant($1, None)) } - | HASH type_longident - { mkpat(Ppat_type (mkrhs $2 2)) } - | simple_delimited_pattern - { $1 } - | mod_longident DOT simple_delimited_pattern - { mkpat @@ Ppat_open(mkrhs $1 1, $3) } - | mod_longident DOT LBRACKET RBRACKET - { mkpat @@ Ppat_open(mkrhs $1 1, mkpat @@ - Ppat_construct ( mkrhs (Lident "[]") 4, None)) } - | mod_longident DOT LPAREN RPAREN - { mkpat @@ Ppat_open( mkrhs $1 1, mkpat @@ - Ppat_construct ( mkrhs (Lident "()") 4, None) ) } - | mod_longident DOT LPAREN pattern RPAREN - { mkpat @@ Ppat_open (mkrhs $1 1, $4)} - | mod_longident DOT LPAREN pattern error - {unclosed "(" 3 ")" 5 } - | mod_longident DOT LPAREN error - { expecting 4 "pattern" } - | LPAREN pattern RPAREN - { reloc_pat $2 } - | LPAREN pattern error - { unclosed "(" 1 ")" 3 } - | LPAREN pattern COLON core_type RPAREN - { mkpat(Ppat_constraint($2, $4)) } - | LPAREN pattern COLON core_type error - { unclosed "(" 1 ")" 5 } - | LPAREN pattern COLON error - { expecting 4 "type" } - | LPAREN MODULE ext_attributes UIDENT RPAREN - { mkpat_attrs (Ppat_unpack (mkrhs $4 4)) $3 } - | LPAREN MODULE ext_attributes UIDENT COLON package_type RPAREN - { mkpat_attrs - (Ppat_constraint(mkpat(Ppat_unpack (mkrhs $4 4)), - ghtyp(Ptyp_package $6))) - $3 } - | LPAREN MODULE ext_attributes UIDENT COLON package_type error - { unclosed "(" 1 ")" 7 } - | extension - { mkpat(Ppat_extension $1) } -; - -simple_delimited_pattern: - | LBRACE lbl_pattern_list RBRACE - { let (fields, closed) = $2 in mkpat(Ppat_record(fields, closed)) } - | LBRACE lbl_pattern_list error - { unclosed "{" 1 "}" 3 } - | LBRACKET pattern_semi_list opt_semi RBRACKET - { reloc_pat (mktailpat (rhs_loc 4) (List.rev $2)) } - | LBRACKET pattern_semi_list opt_semi error - { unclosed "[" 1 "]" 4 } - | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET - { mkpat(Ppat_array(List.rev $2)) } - | LBRACKETBAR BARRBRACKET - { mkpat(Ppat_array []) } - | LBRACKETBAR pattern_semi_list opt_semi error - { unclosed "[|" 1 "|]" 4 } - -pattern_comma_list: - pattern_comma_list COMMA pattern { $3 :: $1 } - | pattern COMMA pattern { [$3; $1] } - | pattern COMMA error { expecting 3 "pattern" } -; -pattern_no_exn_comma_list: - pattern_no_exn_comma_list COMMA pattern { $3 :: $1 } - | pattern_no_exn COMMA pattern { [$3; $1] } - | pattern_no_exn COMMA error { expecting 3 "pattern" } -; -pattern_semi_list: - pattern { [$1] } - | pattern_semi_list SEMI pattern { $3 :: $1 } -; -lbl_pattern_list: - lbl_pattern { [$1], Closed } - | lbl_pattern SEMI { [$1], Closed } - | lbl_pattern SEMI UNDERSCORE opt_semi { [$1], Open } - | lbl_pattern SEMI lbl_pattern_list - { let (fields, closed) = $3 in $1 :: fields, closed } -; -lbl_pattern: - label_longident opt_pattern_type_constraint EQUAL pattern - { (mkrhs $1 1, mkpat_opt_constraint $4 $2) } - | label_longident opt_pattern_type_constraint - { (mkrhs $1 1, mkpat_opt_constraint (pat_of_label $1 1) $2) } -; -opt_pattern_type_constraint: - COLON core_type { Some $2 } - | /* empty */ { None } -; - -/* Value descriptions */ - -value_description: - VAL ext_attributes val_ident COLON core_type post_item_attributes - { let (ext, attrs) = $2 in - Val.mk (mkrhs $3 3) $5 ~attrs:(attrs@$6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; - -/* Primitive declarations */ - -primitive_declaration_body: - STRING { [fst $1] } - | STRING primitive_declaration_body { fst $1 :: $2 } -; -primitive_declaration: - EXTERNAL ext_attributes val_ident COLON core_type EQUAL - primitive_declaration_body post_item_attributes - { let (ext, attrs) = $2 in - Val.mk (mkrhs $3 3) $5 ~prim:$7 ~attrs:(attrs@$8) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - , ext } -; - -/* Type declarations */ - -type_declarations: - type_declaration - { let (nonrec_flag, ty, ext) = $1 in (nonrec_flag, [ty], ext) } - | type_declarations and_type_declaration - { let (nonrec_flag, tys, ext) = $1 in (nonrec_flag, $2 :: tys, ext) } -; - -type_declaration: - TYPE ext_attributes nonrec_flag optional_type_parameters LIDENT - type_kind constraints post_item_attributes - { let (kind, priv, manifest) = $6 in - let (ext, attrs) = $2 in - let ty = - Type.mk (mkrhs $5 5) ~params:$4 ~cstrs:(List.rev $7) ~kind - ~priv ?manifest ~attrs:(attrs@$8) - ~loc:(symbol_rloc ()) ~docs:(symbol_docs ()) - in - ($3, ty, ext) } -; -and_type_declaration: - AND attributes optional_type_parameters LIDENT type_kind constraints - post_item_attributes - { let (kind, priv, manifest) = $5 in - Type.mk (mkrhs $4 4) ~params:$3 ~cstrs:(List.rev $6) - ~kind ~priv ?manifest ~attrs:($2@$7) ~loc:(symbol_rloc ()) - ~text:(symbol_text ()) ~docs:(symbol_docs ()) } -; -constraints: - constraints CONSTRAINT constrain { $3 :: $1 } - | /* empty */ { [] } -; -type_kind: - /*empty*/ - { (Ptype_abstract, Public, None) } - | EQUAL core_type - { (Ptype_abstract, Public, Some $2) } - | EQUAL PRIVATE core_type - { (Ptype_abstract, Private, Some $3) } - | EQUAL constructor_declarations - { (Ptype_variant(List.rev $2), Public, None) } - | EQUAL PRIVATE constructor_declarations - { (Ptype_variant(List.rev $3), Private, None) } - | EQUAL DOTDOT - { (Ptype_open, Public, None) } - | EQUAL PRIVATE DOTDOT - { (Ptype_open, Private, None) } - | EQUAL private_flag LBRACE label_declarations RBRACE - { (Ptype_record $4, $2, None) } - | EQUAL core_type EQUAL private_flag constructor_declarations - { (Ptype_variant(List.rev $5), $4, Some $2) } - | EQUAL core_type EQUAL private_flag DOTDOT - { (Ptype_open, $4, Some $2) } - | EQUAL core_type EQUAL private_flag LBRACE label_declarations RBRACE - { (Ptype_record $6, $4, Some $2) } -; -optional_type_parameters: - /*empty*/ { [] } - | optional_type_parameter { [$1] } - | LPAREN optional_type_parameter_list RPAREN { List.rev $2 } -; -optional_type_parameter: - type_variance optional_type_variable { $2, $1 } -; -optional_type_parameter_list: - optional_type_parameter { [$1] } - | optional_type_parameter_list COMMA optional_type_parameter { $3 :: $1 } -; -optional_type_variable: - QUOTE ident { mktyp(Ptyp_var $2) } - | UNDERSCORE { mktyp(Ptyp_any) } -; - - -type_parameter: - type_variance type_variable { $2, $1 } -; -type_variance: - /* empty */ { Invariant } - | PLUS { Covariant } - | MINUS { Contravariant } -; -type_variable: - QUOTE ident { mktyp(Ptyp_var $2) } -; -type_parameter_list: - type_parameter { [$1] } - | type_parameter_list COMMA type_parameter { $3 :: $1 } -; -constructor_declarations: - constructor_declaration { [$1] } - | bar_constructor_declaration { [$1] } - | constructor_declarations bar_constructor_declaration { $2 :: $1 } -; -constructor_declaration: - | constr_ident generalized_constructor_arguments attributes - { - let args,res = $2 in - Type.constructor (mkrhs $1 1) ~args ?res ~attrs:$3 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) - } -; -bar_constructor_declaration: - | BAR constr_ident generalized_constructor_arguments attributes - { - let args,res = $3 in - Type.constructor (mkrhs $2 2) ~args ?res ~attrs:$4 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) - } -; -str_exception_declaration: - | sig_exception_declaration { $1 } - | EXCEPTION ext_attributes constr_ident EQUAL constr_longident attributes - post_item_attributes - { let (ext,attrs) = $2 in - Te.rebind (mkrhs $3 3) (mkrhs $5 5) ~attrs:(attrs @ $6 @ $7) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -sig_exception_declaration: - | EXCEPTION ext_attributes constr_ident generalized_constructor_arguments - attributes post_item_attributes - { let args, res = $4 in - let (ext,attrs) = $2 in - Te.decl (mkrhs $3 3) ~args ?res ~attrs:(attrs @ $5 @ $6) - ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) - , ext } -; -let_exception_declaration: - constr_ident generalized_constructor_arguments attributes - { let args, res = $2 in - Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 ~loc:(symbol_rloc()) } -; -generalized_constructor_arguments: - /*empty*/ { (Pcstr_tuple [],None) } - | OF constructor_arguments { ($2,None) } - | COLON constructor_arguments MINUSGREATER simple_core_type - { ($2,Some $4) } - | COLON simple_core_type - { (Pcstr_tuple [],Some $2) } -; - -constructor_arguments: - | core_type_list { Pcstr_tuple (List.rev $1) } - | LBRACE label_declarations RBRACE { Pcstr_record $2 } -; -label_declarations: - label_declaration { [$1] } - | label_declaration_semi { [$1] } - | label_declaration_semi label_declarations { $1 :: $2 } -; -label_declaration: - mutable_flag label COLON poly_type_no_attr attributes - { - Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:$5 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) - } -; -label_declaration_semi: - mutable_flag label COLON poly_type_no_attr attributes SEMI attributes - { - let info = - match rhs_info 5 with - | Some _ as info_before_semi -> info_before_semi - | None -> symbol_info () - in - Type.field (mkrhs $2 2) $4 ~mut:$1 ~attrs:($5 @ $7) - ~loc:(symbol_rloc()) ~info - } -; - -/* Type Extensions */ - -str_type_extension: - TYPE ext_attributes nonrec_flag optional_type_parameters type_longident - PLUSEQ private_flag str_extension_constructors post_item_attributes - { let (ext, attrs) = $2 in - if $3 <> Recursive then not_expecting 3 "nonrec flag"; - Te.mk (mkrhs $5 5) (List.rev $8) ~params:$4 ~priv:$7 - ~attrs:(attrs@$9) ~docs:(symbol_docs ()) - , ext } -; -sig_type_extension: - TYPE ext_attributes nonrec_flag optional_type_parameters type_longident - PLUSEQ private_flag sig_extension_constructors post_item_attributes - { let (ext, attrs) = $2 in - if $3 <> Recursive then not_expecting 3 "nonrec flag"; - Te.mk (mkrhs $5 5) (List.rev $8) ~params:$4 ~priv:$7 - ~attrs:(attrs @ $9) ~docs:(symbol_docs ()) - , ext } -; -str_extension_constructors: - extension_constructor_declaration { [$1] } - | bar_extension_constructor_declaration { [$1] } - | extension_constructor_rebind { [$1] } - | bar_extension_constructor_rebind { [$1] } - | str_extension_constructors bar_extension_constructor_declaration - { $2 :: $1 } - | str_extension_constructors bar_extension_constructor_rebind - { $2 :: $1 } -; -sig_extension_constructors: - extension_constructor_declaration { [$1] } - | bar_extension_constructor_declaration { [$1] } - | sig_extension_constructors bar_extension_constructor_declaration - { $2 :: $1 } -; -extension_constructor_declaration: - | constr_ident generalized_constructor_arguments attributes - { let args, res = $2 in - Te.decl (mkrhs $1 1) ~args ?res ~attrs:$3 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) } -; -bar_extension_constructor_declaration: - | BAR constr_ident generalized_constructor_arguments attributes - { let args, res = $3 in - Te.decl (mkrhs $2 2) ~args ?res ~attrs:$4 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) } -; -extension_constructor_rebind: - | constr_ident EQUAL constr_longident attributes - { Te.rebind (mkrhs $1 1) (mkrhs $3 3) ~attrs:$4 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) } -; -bar_extension_constructor_rebind: - | BAR constr_ident EQUAL constr_longident attributes - { Te.rebind (mkrhs $2 2) (mkrhs $4 4) ~attrs:$5 - ~loc:(symbol_rloc()) ~info:(symbol_info ()) } -; - -/* "with" constraints (additional type equations over signature components) */ - -with_constraints: - with_constraint { [$1] } - | with_constraints AND with_constraint { $3 :: $1 } -; -with_constraint: - TYPE optional_type_parameters label_longident with_type_binder - core_type_no_attr constraints - { Pwith_type - (mkrhs $3 3, - (Type.mk (mkrhs (Longident.last $3) 3) - ~params:$2 - ~cstrs:(List.rev $6) - ~manifest:$5 - ~priv:$4 - ~loc:(symbol_rloc()))) } - /* used label_longident instead of type_longident to disallow - functor applications in type path */ - | TYPE optional_type_parameters label_longident COLONEQUAL core_type_no_attr - { Pwith_typesubst - (mkrhs $3 3, - (Type.mk (mkrhs (Longident.last $3) 3) - ~params:$2 - ~manifest:$5 - ~loc:(symbol_rloc()))) } - | MODULE mod_longident EQUAL mod_ext_longident - { Pwith_module (mkrhs $2 2, mkrhs $4 4) } - | MODULE mod_longident COLONEQUAL mod_ext_longident - { Pwith_modsubst (mkrhs $2 2, mkrhs $4 4) } -; -with_type_binder: - EQUAL { Public } - | EQUAL PRIVATE { Private } -; - -/* Polymorphic types */ - -typevar_list: - QUOTE ident { [mkrhs $2 2] } - | typevar_list QUOTE ident { mkrhs $3 3 :: $1 } -; -poly_type: - core_type - { $1 } - | typevar_list DOT core_type - { mktyp(Ptyp_poly(List.rev $1, $3)) } -; -poly_type_no_attr: - core_type_no_attr - { $1 } - | typevar_list DOT core_type_no_attr - { mktyp(Ptyp_poly(List.rev $1, $3)) } -; - -/* Core types */ - -core_type: - core_type_no_attr - { $1 } - | core_type attribute - { Typ.attr $1 $2 } -; -core_type_no_attr: - core_type2 %prec MINUSGREATER - { $1 } - | core_type2 AS QUOTE ident - { mktyp(Ptyp_alias($1, $4)) } -; -core_type2: - simple_core_type_or_tuple - { $1 } - | QUESTION LIDENT COLON core_type2 MINUSGREATER core_type2 - { let param = extra_rhs_core_type $4 ~pos:4 in - mktyp (Ptyp_arrow(Optional $2 , param, $6)) } - | OPTLABEL core_type2 MINUSGREATER core_type2 - { let param = extra_rhs_core_type $2 ~pos:2 in - mktyp(Ptyp_arrow(Optional $1 , param, $4)) - } - | LIDENT COLON core_type2 MINUSGREATER core_type2 - { let param = extra_rhs_core_type $3 ~pos:3 in - mktyp(Ptyp_arrow(Labelled $1, param, $5)) } - | core_type2 MINUSGREATER core_type2 - { let param = extra_rhs_core_type $1 ~pos:1 in - mktyp(Ptyp_arrow(Nolabel, param, $3)) } -; - -simple_core_type: - simple_core_type2 %prec below_HASH - { $1 } - | LPAREN core_type_comma_list RPAREN %prec below_HASH - { match $2 with [sty] -> sty | _ -> raise Parse_error } -; - -simple_core_type2: - QUOTE ident - { mktyp(Ptyp_var $2) } - | UNDERSCORE - { mktyp(Ptyp_any) } - | type_longident - { mktyp(Ptyp_constr(mkrhs $1 1, [])) } - | simple_core_type2 type_longident - { mktyp(Ptyp_constr(mkrhs $2 2, [$1])) } - | LPAREN core_type_comma_list RPAREN type_longident - { mktyp(Ptyp_constr(mkrhs $4 4, List.rev $2)) } - | LESS meth_list GREATER - { let (f, c) = $2 in mktyp(Ptyp_object (f, c)) } - | LESS GREATER - { mktyp(Ptyp_object ([], Closed)) } - | HASH class_longident - { mktyp(Ptyp_class(mkrhs $2 2, [])) } - | simple_core_type2 HASH class_longident - { mktyp(Ptyp_class(mkrhs $3 3, [$1])) } - | LPAREN core_type_comma_list RPAREN HASH class_longident - { mktyp(Ptyp_class(mkrhs $5 5, List.rev $2)) } - | LBRACKET tag_field RBRACKET - { mktyp(Ptyp_variant([$2], Closed, None)) } -/* PR#3835: this is not LR(1), would need lookahead=2 - | LBRACKET simple_core_type RBRACKET - { mktyp(Ptyp_variant([$2], Closed, None)) } -*/ - | LBRACKET BAR row_field_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, Closed, None)) } - | LBRACKET row_field BAR row_field_list RBRACKET - { mktyp(Ptyp_variant($2 :: List.rev $4, Closed, None)) } - | LBRACKETGREATER opt_bar row_field_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, Open, None)) } - | LBRACKETGREATER RBRACKET - { mktyp(Ptyp_variant([], Open, None)) } - | LBRACKETLESS opt_bar row_field_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, Closed, Some [])) } - | LBRACKETLESS opt_bar row_field_list GREATER name_tag_list RBRACKET - { mktyp(Ptyp_variant(List.rev $3, Closed, Some (List.rev $5))) } - | LPAREN MODULE ext_attributes package_type RPAREN - { mktyp_attrs (Ptyp_package $4) $3 } - | extension - { mktyp (Ptyp_extension $1) } -; -package_type: - module_type { package_type_of_module_type $1 } -; -row_field_list: - row_field { [$1] } - | row_field_list BAR row_field { $3 :: $1 } -; -row_field: - tag_field { $1 } - | simple_core_type { Rinherit $1 } -; -tag_field: - name_tag OF opt_ampersand amper_type_list attributes - { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $5, - $3, List.rev $4) } - | name_tag attributes - { Rtag (mkrhs $1 1, add_info_attrs (symbol_info ()) $2, true, []) } -; -opt_ampersand: - AMPERSAND { true } - | /* empty */ { false } -; -amper_type_list: - core_type_no_attr { [$1] } - | amper_type_list AMPERSAND core_type_no_attr { $3 :: $1 } -; -name_tag_list: - name_tag { [$1] } - | name_tag_list name_tag { $2 :: $1 } -; -simple_core_type_or_tuple: - simple_core_type { $1 } - | simple_core_type STAR core_type_list - { mktyp(Ptyp_tuple($1 :: List.rev $3)) } -; -core_type_comma_list: - core_type { [$1] } - | core_type_comma_list COMMA core_type { $3 :: $1 } -; -core_type_list: - simple_core_type { [$1] } - | core_type_list STAR simple_core_type { $3 :: $1 } -; -meth_list: - field_semi meth_list { let (f, c) = $2 in ($1 :: f, c) } - | inherit_field_semi meth_list { let (f, c) = $2 in ($1 :: f, c) } - | field_semi { [$1], Closed } - | field { [$1], Closed } - | inherit_field_semi { [$1], Closed } - | simple_core_type { [Oinherit $1], Closed } - | DOTDOT { [], Open } -; -field: - label COLON poly_type_no_attr attributes - { Otag (mkrhs $1 1, add_info_attrs (symbol_info ()) $4, $3) } -; - -field_semi: - label COLON poly_type_no_attr attributes SEMI attributes - { let info = - match rhs_info 4 with - | Some _ as info_before_semi -> info_before_semi - | None -> symbol_info () - in - ( Otag (mkrhs $1 1, add_info_attrs info ($4 @ $6), $3)) } -; - -inherit_field_semi: - simple_core_type SEMI { Oinherit $1 } - -label: - LIDENT { $1 } -; - -/* Constants */ - -constant: - | INT { let (n, m) = $1 in Pconst_integer (n, m) } - | CHAR { Pconst_char (Char.code $1) } - | STRING { let (s, d) = $1 in Pconst_string (s, d) } - | FLOAT { let (f, m) = $1 in Pconst_float (f, m) } -; -signed_constant: - constant { $1 } - | MINUS INT { let (n, m) = $2 in Pconst_integer("-" ^ n, m) } - | MINUS FLOAT { let (f, m) = $2 in Pconst_float("-" ^ f, m) } - | PLUS INT { let (n, m) = $2 in Pconst_integer (n, m) } - | PLUS FLOAT { let (f, m) = $2 in Pconst_float(f, m) } -; - -/* Identifiers and long identifiers */ - -ident: - UIDENT { $1 } - | LIDENT { $1 } -; -val_ident: - LIDENT { $1 } - | LPAREN operator RPAREN { $2 } - | LPAREN operator error { unclosed "(" 1 ")" 3 } - | LPAREN error { expecting 2 "operator" } - | LPAREN MODULE error { expecting 3 "module-expr" } -; -operator: - PREFIXOP { $1 } - | INFIXOP0 { $1 } - | INFIXOP1 { $1 } - | INFIXOP2 { $1 } - | INFIXOP3 { $1 } - | INFIXOP4 { $1 } - | DOTOP LPAREN RPAREN { "."^ $1 ^"()" } - | DOTOP LPAREN RPAREN LESSMINUS { "."^ $1 ^ "()<-" } - | DOTOP LBRACKET RBRACKET { "."^ $1 ^"[]" } - | DOTOP LBRACKET RBRACKET LESSMINUS { "."^ $1 ^ "[]<-" } - | DOTOP LBRACE RBRACE { "."^ $1 ^"{}" } - | DOTOP LBRACE RBRACE LESSMINUS { "."^ $1 ^ "{}<-" } - | HASHOP { $1 } - | BANG { "!" } - | PLUS { "+" } - | PLUSDOT { "+." } - | MINUS { "-" } - | MINUSDOT { "-." } - | STAR { "*" } - | EQUAL { "=" } - | LESS { "<" } - | GREATER { ">" } - | OR { "or" } - | BARBAR { "||" } - | AMPERSAND { "&" } - | AMPERAMPER { "&&" } - | COLONEQUAL { ":=" } - | PLUSEQ { "+=" } - | PERCENT { "%" } -; -constr_ident: - UIDENT { $1 } - | LBRACKET RBRACKET { "[]" } - | LPAREN RPAREN { "()" } - | LPAREN COLONCOLON RPAREN { "::" } - | FALSE { "false" } - | TRUE { "true" } -; - -val_longident: - val_ident { Lident $1 } - | mod_longident DOT val_ident { Ldot($1, $3) } -; -constr_longident: - mod_longident %prec below_DOT { $1 } - | mod_longident DOT LPAREN COLONCOLON RPAREN { Ldot($1,"::") } - | LBRACKET RBRACKET { Lident "[]" } - | LPAREN RPAREN { Lident "()" } - | LPAREN COLONCOLON RPAREN { Lident "::" } - | FALSE { Lident "false" } - | TRUE { Lident "true" } -; -label_longident: - LIDENT { Lident $1 } - | mod_longident DOT LIDENT { Ldot($1, $3) } -; -type_longident: - LIDENT { Lident $1 } - | mod_ext_longident DOT LIDENT { Ldot($1, $3) } -; -mod_longident: - UIDENT { Lident $1 } - | mod_longident DOT UIDENT { Ldot($1, $3) } -; -mod_ext_longident: - UIDENT { Lident $1 } - | mod_ext_longident DOT UIDENT { Ldot($1, $3) } - | mod_ext_longident LPAREN mod_ext_longident RPAREN { lapply $1 $3 } -; -mty_longident: - ident { Lident $1 } - | mod_ext_longident DOT ident { Ldot($1, $3) } -; -clty_longident: - LIDENT { Lident $1 } - | mod_ext_longident DOT LIDENT { Ldot($1, $3) } -; -class_longident: - LIDENT { Lident $1 } - | mod_longident DOT LIDENT { Ldot($1, $3) } -; - -/* Toplevel directives */ - - -/* Miscellaneous */ - -name_tag: - BACKQUOTE ident { $2 } -; -rec_flag: - /* empty */ { Nonrecursive } - | REC { Recursive } -; -nonrec_flag: - /* empty */ { Recursive } - | NONREC { Nonrecursive } -; -direction_flag: - TO { Upto } - | DOWNTO { Downto } -; -private_flag: - /* empty */ { Public } - | PRIVATE { Private } -; -mutable_flag: - /* empty */ { Immutable } - | MUTABLE { Mutable } -; -virtual_flag: - /* empty */ { Concrete } - | VIRTUAL { Virtual } -; -private_virtual_flags: - /* empty */ { Public, Concrete } - | PRIVATE { Private, Concrete } - | VIRTUAL { Public, Virtual } - | PRIVATE VIRTUAL { Private, Virtual } - | VIRTUAL PRIVATE { Private, Virtual } -; -override_flag: - /* empty */ { Fresh } - | BANG { Override } -; -opt_bar: - /* empty */ { () } - | BAR { () } -; -opt_semi: - | /* empty */ { () } - | SEMI { () } -; -subtractive: - | MINUS { "-" } - | MINUSDOT { "-." } -; -additive: - | PLUS { "+" } - | PLUSDOT { "+." } -; - -/* Attributes and extensions */ - -single_attr_id: - LIDENT { $1 } - | UIDENT { $1 } - | AND { "and" } - | AS { "as" } - | ASSERT { "assert" } - | BEGIN { "begin" } - | CLASS { "class" } - | CONSTRAINT { "constraint" } - | DO { "do" } - | DONE { "done" } - | DOWNTO { "downto" } - | ELSE { "else" } - | END { "end" } - | EXCEPTION { "exception" } - | EXTERNAL { "external" } - | FALSE { "false" } - | FOR { "for" } - | FUN { "fun" } - | FUNCTION { "function" } - | FUNCTOR { "functor" } - | IF { "if" } - | IN { "in" } - | INCLUDE { "include" } - | INHERIT { "inherit" } - | INITIALIZER { "initializer" } - | LAZY { "lazy" } - | LET { "let" } - | MATCH { "match" } - | METHOD { "method" } - | MODULE { "module" } - | MUTABLE { "mutable" } - | NEW { "new" } - | NONREC { "nonrec" } - | OBJECT { "object" } - | OF { "of" } - | OPEN { "open" } - | OR { "or" } - | PRIVATE { "private" } - | REC { "rec" } - | SIG { "sig" } - | STRUCT { "struct" } - | THEN { "then" } - | TO { "to" } - | TRUE { "true" } - | TRY { "try" } - | TYPE { "type" } - | VAL { "val" } - | VIRTUAL { "virtual" } - | WHEN { "when" } - | WHILE { "while" } - | WITH { "with" } -/* mod/land/lor/lxor/lsl/lsr/asr are not supported for now */ -; - -attr_id: - single_attr_id { mkloc $1 (symbol_rloc()) } - | single_attr_id DOT attr_id { mkloc ($1 ^ "." ^ $3.txt) (symbol_rloc())} -; -attribute: - LBRACKETAT attr_id payload RBRACKET { ($2, $3) } -; -post_item_attribute: - LBRACKETATAT attr_id payload RBRACKET { ($2, $3) } -; -floating_attribute: - LBRACKETATATAT attr_id payload RBRACKET { ($2, $3) } -; -post_item_attributes: - /* empty */ { [] } - | post_item_attribute post_item_attributes { $1 :: $2 } -; -attributes: - /* empty */{ [] } - | attribute attributes { $1 :: $2 } -; -ext_attributes: - /* empty */ { None, [] } - | attribute attributes { None, $1 :: $2 } - | PERCENT attr_id attributes { Some $2, $3 } -; -extension: - LBRACKETPERCENT attr_id payload RBRACKET { ($2, $3) } -; -item_extension: - LBRACKETPERCENTPERCENT attr_id payload RBRACKET { ($2, $3) } -; -payload: - structure { PStr $1 } - | COLON signature { PSig $2 } - | COLON core_type { PTyp $2 } - | QUESTION pattern { PPat ($2, None) } - | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) } -; -%% diff --git a/jscomp/ml/parsetree.ml b/jscomp/ml/parsetree.ml deleted file mode 100644 index 159a832..0000000 --- a/jscomp/ml/parsetree.ml +++ /dev/null @@ -1,860 +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. *) -(* *) -(**************************************************************************) - -(** Abstract syntax tree produced by parsing *) - -open Asttypes - -type constant = - Pconst_integer of string * char option - (* 3 3l 3L 3n - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes except 'l', 'L' are rejected by the typechecker - *) - | Pconst_char of int - (* 'c' *) - | Pconst_string of string * string option - (* "constant" - {delim|other constant|delim} - *) - | Pconst_float of string * char option - (* 3.4 2e5 1.4e-4 - - Suffixes [g-z][G-Z] are accepted by the parser. - Suffixes are rejected by the typechecker. - *) - -(** {1 Extension points} *) - -type attribute = string loc * payload - (* [@id ARG] - [@@id ARG] - - Metadata containers passed around within the AST. - The compiler ignores unknown attributes. - *) - -and extension = string loc * payload - (* [%id ARG] - [%%id ARG] - - Sub-language placeholder -- rejected by the typechecker. - *) - -and attributes = attribute list - -and payload = - | PStr of structure - | PSig of signature (* : SIG *) - | PTyp of core_type (* : T *) - | PPat of pattern * expression option (* ? P or ? P when E *) - -(** {1 Core language} *) - -(* Type expressions *) - -and core_type = - { - ptyp_desc: core_type_desc; - ptyp_loc: Location.t; - ptyp_attributes: attributes; (* ... [@id1] [@id2] *) - } - -and core_type_desc = - | Ptyp_any - (* _ *) - | Ptyp_var of string - (* 'a *) - | Ptyp_arrow of arg_label * core_type * core_type - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) - | Ptyp_tuple of core_type list - (* T1 * ... * Tn - - Invariant: n >= 2 - *) - | Ptyp_constr of Longident.t loc * core_type list - (* tconstr - T tconstr - (T1, ..., Tn) tconstr - *) - | Ptyp_object of object_field list * closed_flag - (* < l1:T1; ...; ln:Tn > (flag = Closed) - < l1:T1; ...; ln:Tn; .. > (flag = Open) - *) - | Ptyp_class of Longident.t loc * core_type list - (* #tconstr - T #tconstr - (T1, ..., Tn) #tconstr - *) - | Ptyp_alias of core_type * string - (* T as 'a *) - | Ptyp_variant of row_field list * closed_flag * label list option - (* [ `A|`B ] (flag = Closed; labels = None) - [> `A|`B ] (flag = Open; labels = None) - [< `A|`B ] (flag = Closed; labels = Some []) - [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) - *) - | Ptyp_poly of string loc list * core_type - (* 'a1 ... 'an. T - - Can only appear in the following context: - - - As the core_type of a Ppat_constraint node corresponding - to a constraint on a let-binding: let x : 'a1 ... 'an. T - = e ... - - - Under Cfk_virtual for methods (not values). - - - As the core_type of a Pctf_method node. - - - As the core_type of a Pexp_poly node. - - - As the pld_type field of a label_declaration. - - - As a core_type of a Ptyp_object node. - *) - - | Ptyp_package of package_type - (* (module S) *) - | Ptyp_extension of extension - (* [%id] *) - -and package_type = Longident.t loc * (Longident.t loc * core_type) list - (* - (module S) - (module S with type t1 = T1 and ... and tn = Tn) - *) - -and row_field = - | Rtag of label loc * attributes * bool * core_type list - (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - - - The 2nd field is true if the tag contains a - constant (empty) constructor. - - '&' occurs when several types are used for the same constructor - (see 4.2 in the manual) - - - TODO: switch to a record representation, and keep location - *) - | Rinherit of core_type - (* [ T ] *) - -and object_field = - | Otag of label loc * attributes * core_type - | Oinherit of core_type - -(* Patterns *) - -and pattern = - { - ppat_desc: pattern_desc; - ppat_loc: Location.t; - ppat_attributes: attributes; (* ... [@id1] [@id2] *) - } - -and pattern_desc = - | Ppat_any - (* _ *) - | Ppat_var of string loc - (* x *) - | Ppat_alias of pattern * string loc - (* P as 'a *) - | Ppat_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Ppat_interval of constant * constant - (* 'a'..'z' - - Other forms of interval are recognized by the parser - but rejected by the type-checker. *) - | Ppat_tuple of pattern list - (* (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) - *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) - *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag - (* { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Ppat_array of pattern list - (* [| P1; ...; Pn |] *) - | Ppat_or of pattern * pattern - (* P1 | P2 *) - | Ppat_constraint of pattern * core_type - (* (P : T) *) - | Ppat_type of Longident.t loc - (* #tconst *) - | Ppat_lazy of pattern - (* lazy P *) - | Ppat_unpack of string loc - (* (module P) - Note: (module P : S) is represented as - Ppat_constraint(Ppat_unpack, Ptyp_package) - *) - | Ppat_exception of pattern - (* exception P *) - | Ppat_extension of extension - (* [%id] *) - | Ppat_open of Longident.t loc * pattern - (* M.(P) *) - -(* Value expressions *) - -and expression = - { - pexp_desc: expression_desc; - pexp_loc: Location.t; - pexp_attributes: attributes; (* ... [@id1] [@id2] *) - } - -and expression_desc = - | Pexp_ident of Longident.t loc - (* x - M.x - *) - | Pexp_constant of constant - (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Pexp_let of rec_flag * value_binding list * expression - (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Pexp_function of case list - (* function P1 -> E1 | ... | Pn -> En *) - | Pexp_fun of arg_label * expression option * pattern * expression - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) - - Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - - "let f P = E" is represented using Pexp_fun. - *) - | Pexp_apply of expression * (arg_label * expression) list - (* E0 ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pexp_match of expression * case list - (* match E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_try of expression * case list - (* try E0 with P1 -> E1 | ... | Pn -> En *) - | Pexp_tuple of expression list - (* (E1, ..., En) - - Invariant: n >= 2 - *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) - *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) - *) - | Pexp_record of (Longident.t loc * expression) list * expression option - (* { l1=P1; ...; ln=Pn } (None) - { E0 with l1=P1; ...; ln=Pn } (Some E0) - - Invariant: n > 0 - *) - | Pexp_field of expression * Longident.t loc - (* E.l *) - | Pexp_setfield of expression * Longident.t loc * expression - (* E1.l <- E2 *) - | Pexp_array of expression list - (* [| E1; ...; En |] *) - | Pexp_ifthenelse of expression * expression * expression option - (* if E1 then E2 else E3 *) - | Pexp_sequence of expression * expression - (* E1; E2 *) - | Pexp_while of expression * expression - (* while E1 do E2 done *) - | Pexp_for of - pattern * expression * expression * direction_flag * expression - (* for i = E1 to E2 do E3 done (flag = Upto) - for i = E1 downto E2 do E3 done (flag = Downto) - *) - | Pexp_constraint of expression * core_type - (* (E : T) *) - | Pexp_coerce of expression * core_type option * core_type - (* (E :> T) (None, T) - (E : T0 :> T) (Some T0, T) - *) - | Pexp_send of expression * label loc - (* E # m *) - | Pexp_new of Longident.t loc - (* new M.c *) - | Pexp_setinstvar of label loc * expression - (* x <- 2 *) - | Pexp_override of (label loc * expression) list - (* {< x1 = E1; ...; Xn = En >} *) - | Pexp_letmodule of string loc * module_expr * expression - (* let module M = ME in E *) - | Pexp_letexception of extension_constructor * expression - (* let exception C in E *) - | Pexp_assert of expression - (* assert E - Note: "assert false" is treated in a special way by the - type-checker. *) - | Pexp_lazy of expression - (* lazy E *) - | Pexp_poly of expression * core_type option - (* Used for method bodies. - - Can only be used as the expression under Cfk_concrete - for methods (not values). *) - | Pexp_object of class_structure - (* object ... end *) - | Pexp_newtype of string loc * expression - (* fun (type t) -> E *) - | Pexp_pack of module_expr - (* (module ME) - - (module ME : S) is represented as - Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression - (* M.(E) - let open M in E - let! open M in E *) - | Pexp_extension of extension - (* [%id] *) - | Pexp_unreachable - (* . *) - -and case = (* (P -> E) or (P when E0 -> E) *) - { - pc_lhs: pattern; - pc_guard: expression option; - pc_rhs: expression; - } - -(* Value descriptions *) - -and value_description = - { - pval_name: string loc; - pval_type: core_type; - pval_prim: string list; - pval_attributes: attributes; (* ... [@@id1] [@@id2] *) - pval_loc: Location.t; - } - -(* - val x: T (prim = []) - external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) -*) - -(* Type declarations *) - -and type_declaration = - { - ptype_name: string loc; - ptype_params: (core_type * variance) list; - (* ('a1,...'an) t; None represents _*) - ptype_cstrs: (core_type * core_type * Location.t) list; - (* ... constraint T1=T1' ... constraint Tn=Tn' *) - ptype_kind: type_kind; - ptype_private: private_flag; (* = private ... *) - ptype_manifest: core_type option; (* = T *) - ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - ptype_loc: Location.t; - } - -(* - type t (abstract, no manifest) - type t = T0 (abstract, manifest=T0) - type t = C of T | ... (variant, no manifest) - type t = T0 = C of T | ... (variant, manifest=T0) - type t = {l: T; ...} (record, no manifest) - type t = T0 = {l : T; ...} (record, manifest=T0) - type t = .. (open, no manifest) -*) - -and type_kind = - | Ptype_abstract - | Ptype_variant of constructor_declaration list - (* Invariant: non-empty list *) - | Ptype_record of label_declaration list - (* Invariant: non-empty list *) - | Ptype_open - -and label_declaration = - { - pld_name: string loc; - pld_mutable: mutable_flag; - pld_type: core_type; - pld_loc: Location.t; - pld_attributes: attributes; (* l : T [@id1] [@id2] *) - } - -(* { ...; l: T; ... } (mutable=Immutable) - { ...; mutable l: T; ... } (mutable=Mutable) - - Note: T can be a Ptyp_poly. -*) - -and constructor_declaration = - { - pcd_name: string loc; - pcd_args: constructor_arguments; - pcd_res: core_type option; - pcd_loc: Location.t; - pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - -and constructor_arguments = - | Pcstr_tuple of core_type list - | Pcstr_record of label_declaration list - -(* - | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) - | C: T0 (res = Some T0, args = []) - | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) - | C of {...} (res = None, args = Pcstr_record) - | C: {...} -> T0 (res = Some T0, args = Pcstr_record) - | C of {...} as t (res = None, args = Pcstr_record) -*) - -and type_extension = - { - ptyext_path: Longident.t loc; - ptyext_params: (core_type * variance) list; - ptyext_constructors: extension_constructor list; - ptyext_private: private_flag; - ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* - type t += ... -*) - -and extension_constructor = - { - pext_name: string loc; - pext_kind : extension_constructor_kind; - pext_loc : Location.t; - pext_attributes: attributes; (* C of ... [@id1] [@id2] *) - } - -and extension_constructor_kind = - Pext_decl of constructor_arguments * core_type option - (* - | C of T1 * ... * Tn ([T1; ...; Tn], None) - | C: T0 ([], Some T0) - | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) - *) - | Pext_rebind of Longident.t loc - (* - | C = D - *) - -(** {1 Class language} *) - -(* Type expressions for the class language *) - -and class_type = - { - pcty_desc: class_type_desc; - pcty_loc: Location.t; - pcty_attributes: attributes; (* ... [@id1] [@id2] *) - } - -and class_type_desc = - | Pcty_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcty_signature of class_signature - (* object ... end *) - | Pcty_arrow of arg_label * core_type * class_type - (* T -> CT Simple - ~l:T -> CT Labelled l - ?l:T -> CT Optional l - *) - | Pcty_extension of extension - (* [%id] *) - | Pcty_open of override_flag * Longident.t loc * class_type - (* let open M in CT *) - -and class_signature = - { - pcsig_self: core_type; - pcsig_fields: class_type_field list; - } -(* object('selfpat) ... end - object ... end (self = Ptyp_any) - *) - -and class_type_field = - { - pctf_desc: class_type_field_desc; - pctf_loc: Location.t; - pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - -and class_type_field_desc = - | Pctf_inherit of class_type - (* inherit CT *) - | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) - (* val x: T *) - | Pctf_method of (label loc * private_flag * virtual_flag * core_type) - (* method x: T - - Note: T can be a Ptyp_poly. - *) - | Pctf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pctf_attribute of attribute - (* [@@@id] *) - | Pctf_extension of extension - (* [%%id] *) - -and 'a class_infos = - { - pci_virt: virtual_flag; - pci_params: (core_type * variance) list; - pci_name: string loc; - pci_expr: 'a; - pci_loc: Location.t; - pci_attributes: attributes; (* ... [@@id1] [@@id2] *) - } -(* class c = ... - class ['a1,...,'an] c = ... - class virtual c = ... - - Also used for "class type" declaration. -*) - - - -and class_type_declaration = class_type class_infos - -(* Value expressions for the class language *) - -and class_expr = - { - pcl_desc: class_expr_desc; - pcl_loc: Location.t; - pcl_attributes: attributes; (* ... [@id1] [@id2] *) - } - -and class_expr_desc = - | Pcl_constr of Longident.t loc * core_type list - (* c - ['a1, ..., 'an] c *) - | Pcl_structure of class_structure - (* object ... end *) - | Pcl_fun of arg_label * expression option * pattern * class_expr - (* fun P -> CE (Simple, None) - fun ~l:P -> CE (Labelled l, None) - fun ?l:P -> CE (Optional l, None) - fun ?l:(P = E0) -> CE (Optional l, Some E0) - *) - | Pcl_apply of class_expr * (arg_label * expression) list - (* CE ~l1:E1 ... ~ln:En - li can be empty (non labeled argument) or start with '?' - (optional argument). - - Invariant: n > 0 - *) - | Pcl_let of rec_flag * value_binding list * class_expr - (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) - *) - | Pcl_constraint of class_expr * class_type - (* (CE : CT) *) - | Pcl_extension of extension - (* [%id] *) - | Pcl_open of override_flag * Longident.t loc * class_expr - (* let open M in CE *) - - -and class_structure = - { - pcstr_self: pattern; - pcstr_fields: class_field list; - } -(* object(selfpat) ... end - object ... end (self = Ppat_any) - *) - -and class_field = - { - pcf_desc: class_field_desc; - pcf_loc: Location.t; - pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) - } - -and class_field_desc = - | Pcf_inherit of unit - (* inherit CE - inherit CE as x - inherit! CE - inherit! CE as x - *) - | Pcf_val of (label loc * mutable_flag * class_field_kind) - (* val x = E - val virtual x: T - *) - | Pcf_method of (label loc * private_flag * class_field_kind) - (* method x = E (E can be a Pexp_poly) - method virtual x: T (T can be a Ptyp_poly) - *) - | Pcf_constraint of (core_type * core_type) - (* constraint T1 = T2 *) - | Pcf_initializer of expression - (* initializer E *) - | Pcf_attribute of attribute - (* [@@@id] *) - | Pcf_extension of extension - (* [%%id] *) - -and class_field_kind = - | Cfk_virtual of core_type - | Cfk_concrete of override_flag * expression - - - -(** {1 Module language} *) - -(* Type expressions for the module language *) - -and module_type = - { - pmty_desc: module_type_desc; - pmty_loc: Location.t; - pmty_attributes: attributes; (* ... [@id1] [@id2] *) - } - -and module_type_desc = - | Pmty_ident of Longident.t loc - (* S *) - | Pmty_signature of signature - (* sig ... end *) - | Pmty_functor of string loc * module_type option * module_type - (* functor(X : MT1) -> MT2 *) - | Pmty_with of module_type * with_constraint list - (* MT with ... *) - | Pmty_typeof of module_expr - (* module type of ME *) - | Pmty_extension of extension - (* [%id] *) - | Pmty_alias of Longident.t loc - (* (module M) *) - -and signature = signature_item list - -and signature_item = - { - psig_desc: signature_item_desc; - psig_loc: Location.t; - } - -and signature_item_desc = - | Psig_value of value_description - (* - val x: T - external x: T = "s1" ... "sn" - *) - | Psig_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Psig_typext of type_extension - (* type t1 += ... *) - | Psig_exception of extension_constructor - (* exception C of T *) - | Psig_module of module_declaration - (* module X : MT *) - | Psig_recmodule of module_declaration list - (* module rec X1 : MT1 and ... and Xn : MTn *) - | Psig_modtype of module_type_declaration - (* module type S = MT - module type S *) - | Psig_open of open_description - (* open X *) - | Psig_include of include_description - (* include MT *) - | Psig_class of unit - (* class c1 : ... and ... and cn : ... *) - | Psig_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Psig_attribute of attribute - (* [@@@id] *) - | Psig_extension of extension * attributes - (* [%%id] *) - -and module_declaration = - { - pmd_name: string loc; - pmd_type: module_type; - pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmd_loc: Location.t; - } -(* S : MT *) - -and module_type_declaration = - { - pmtd_name: string loc; - pmtd_type: module_type option; - pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) - pmtd_loc: Location.t; - } -(* S = MT - S (abstract module type declaration, pmtd_type = None) -*) - -and open_description = - { - popen_lid: Longident.t loc; - popen_override: override_flag; - popen_loc: Location.t; - popen_attributes: attributes; - } -(* open! X - popen_override = Override (silences the 'used identifier - shadowing' warning) - open X - popen_override = Fresh - *) - -and 'a include_infos = - { - pincl_mod: 'a; - pincl_loc: Location.t; - pincl_attributes: attributes; - } - -and include_description = module_type include_infos -(* include MT *) - -and include_declaration = module_expr include_infos -(* include ME *) - -and with_constraint = - | Pwith_type of Longident.t loc * type_declaration - (* with type X.t = ... - - Note: the last component of the longident must match - the name of the type_declaration. *) - | Pwith_module of Longident.t loc * Longident.t loc - (* with module X.Y = Z *) - | Pwith_typesubst of Longident.t loc * type_declaration - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_modsubst of Longident.t loc * Longident.t loc - (* with module X.Y := Z *) - -(* Value expressions for the module language *) - -and module_expr = - { - pmod_desc: module_expr_desc; - pmod_loc: Location.t; - pmod_attributes: attributes; (* ... [@id1] [@id2] *) - } - -and module_expr_desc = - | Pmod_ident of Longident.t loc - (* X *) - | Pmod_structure of structure - (* struct ... end *) - | Pmod_functor of string loc * module_type option * module_expr - (* functor(X : MT1) -> ME *) - | Pmod_apply of module_expr * module_expr - (* ME1(ME2) *) - | Pmod_constraint of module_expr * module_type - (* (ME : MT) *) - | Pmod_unpack of expression - (* (val E) *) - | Pmod_extension of extension - (* [%id] *) - -and structure = structure_item list - -and structure_item = - { - pstr_desc: structure_item_desc; - pstr_loc: Location.t; - } - -and structure_item_desc = - | Pstr_eval of expression * attributes - (* E *) - | Pstr_value of rec_flag * value_binding list - (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN (flag = Recursive) - *) - | Pstr_primitive of value_description - (* val x: T - external x: T = "s1" ... "sn" *) - | Pstr_type of rec_flag * type_declaration list - (* type t1 = ... and ... and tn = ... *) - | Pstr_typext of type_extension - (* type t1 += ... *) - | Pstr_exception of extension_constructor - (* exception C of T - exception C = M.X *) - | Pstr_module of module_binding - (* module X = ME *) - | Pstr_recmodule of module_binding list - (* module rec X1 = ME1 and ... and Xn = MEn *) - | Pstr_modtype of module_type_declaration - (* module type S = MT *) - | Pstr_open of open_description - (* open X *) - | Pstr_class of unit - (* Dummy AST node *) - | Pstr_class_type of class_type_declaration list - (* class type ct1 = ... and ... and ctn = ... *) - | Pstr_include of include_declaration - (* include ME *) - | Pstr_attribute of attribute - (* [@@@id] *) - | Pstr_extension of extension * attributes - (* [%%id] *) - -and value_binding = - { - pvb_pat: pattern; - pvb_expr: expression; - pvb_attributes: attributes; - pvb_loc: Location.t; - } - -and module_binding = - { - pmb_name: string loc; - pmb_expr: module_expr; - pmb_attributes: attributes; - pmb_loc: Location.t; - } -(* X = ME *) - diff --git a/jscomp/ml/path.ml b/jscomp/ml/path.ml deleted file mode 100644 index 5189386..0000000 --- a/jscomp/ml/path.ml +++ /dev/null @@ -1,109 +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. *) -(* *) -(**************************************************************************) - -type t = - Pident of Ident.t - | Pdot of t * string * int - | Papply of t * t - -let nopos = -1 - -let rec same p1 p2 = - match (p1, p2) with - (Pident id1, Pident id2) -> Ident.same id1 id2 - | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> s1 = s2 && same p1 p2 - | (Papply(fun1, arg1), Papply(fun2, arg2)) -> - same fun1 fun2 && same arg1 arg2 - | (_, _) -> false - -let rec compare p1 p2 = - match (p1, p2) with - (Pident id1, Pident id2) -> Ident.compare id1 id2 - | (Pdot(p1, s1, _pos1), Pdot(p2, s2, _pos2)) -> - let h = compare p1 p2 in - if h <> 0 then h else String.compare s1 s2 - | (Papply(fun1, arg1), Papply(fun2, arg2)) -> - let h = compare fun1 fun2 in - if h <> 0 then h else compare arg1 arg2 - | ((Pident _ | Pdot _), (Pdot _ | Papply _)) -> -1 - | ((Pdot _ | Papply _), (Pident _ | Pdot _)) -> 1 - -let rec isfree id = function - Pident id' -> Ident.same id id' - | Pdot(p, _s, _pos) -> isfree id p - | Papply(p1, p2) -> isfree id p1 || isfree id p2 - -let rec binding_time = function - Pident id -> Ident.binding_time id - | Pdot(p, _s, _pos) -> binding_time p - | Papply(p1, p2) -> Ext_pervasives.max_int (binding_time p1) (binding_time p2) - -let kfalse _ = false - -let rec name ?(paren=kfalse) = function - Pident id -> Ident.name id - | Pdot(p, s, _pos) -> - name ~paren p ^ if paren s then ".( " ^ s ^ " )" else "." ^ s - | Papply(p1, p2) -> name ~paren p1 ^ "(" ^ name ~paren p2 ^ ")" - -let rec head = function - Pident id -> id - | Pdot(p, _s, _pos) -> head p - | Papply _ -> assert false - -let flatten = - let rec flatten acc = function - | Pident id -> `Ok (id, acc) - | Pdot (p, s, _) -> flatten (s :: acc) p - | Papply _ -> `Contains_apply - in - fun t -> flatten [] t - -let heads p = - let rec heads p acc = match p with - | Pident id -> id :: acc - | Pdot (p, _s, _pos) -> heads p acc - | Papply(p1, p2) -> - heads p1 (heads p2 acc) - in heads p [] - -let rec last = function - | Pident id -> Ident.name id - | Pdot(_, s, _) -> s - | Papply(_, p) -> last p - -let is_uident s = - assert (s <> ""); - match s.[0] with - | 'A'..'Z' -> true - | _ -> false - -type typath = - | Regular of t - | Ext of t * string - | LocalExt of Ident.t - | Cstr of t * string - -let constructor_typath = function - | Pident id when is_uident (Ident.name id) -> LocalExt id - | Pdot(ty_path, s, _) when is_uident s -> - if is_uident (last ty_path) then Ext (ty_path, s) - else Cstr (ty_path, s) - | p -> Regular p - -let is_constructor_typath p = - match constructor_typath p with - | Regular _ -> false - | _ -> true diff --git a/jscomp/ml/path.mli b/jscomp/ml/path.mli deleted file mode 100644 index 1849146..0000000 --- a/jscomp/ml/path.mli +++ /dev/null @@ -1,46 +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. *) -(* *) -(**************************************************************************) - -(* Access paths *) - -type t = - Pident of Ident.t - | Pdot of t * string * int - | Papply of t * t - -val same: t -> t -> bool -val compare: t -> t -> int -val isfree: Ident.t -> t -> bool -val binding_time: t -> int -val flatten : t -> [ `Contains_apply | `Ok of Ident.t * string list ] - -val nopos: int - -val name: ?paren:(string -> bool) -> t -> string - (* [paren] tells whether a path suffix needs parentheses *) -val head: t -> Ident.t - -val heads: t -> Ident.t list - -val last: t -> string - -type typath = - | Regular of t - | Ext of t * string - | LocalExt of Ident.t - | Cstr of t * string - -val constructor_typath: t -> typath -val is_constructor_typath: t -> bool diff --git a/jscomp/ml/pprintast.ml b/jscomp/ml/pprintast.ml deleted file mode 100644 index b531404..0000000 --- a/jscomp/ml/pprintast.ml +++ /dev/null @@ -1,1444 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire, OCamlPro *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* Hongbo Zhang, University of Pennsylvania *) -(* *) -(* Copyright 2007 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. *) -(* *) -(**************************************************************************) - -(* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) -(* Printing code expressions *) -(* Authors: Ed Pizzi, Fabrice Le Fessant *) -(* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) -(* TODO more fine-grained precedence pretty-printing *) - -open Asttypes -open Format -open Location -open Longident -open Parsetree -open Ast_helper - -let prefix_symbols = [ '!'; '?'; '~' ] ;; -let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; - '$'; '%'; '#' ] - -(* type fixity = Infix| Prefix *) -let special_infix_strings = - ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] - -(* determines if the string is an infix string. - checks backwards, first allowing a renaming postfix ("_102") which - may have resulted from Pexp -> Texp -> Pexp translation, then checking - if all the characters in the beginning of the string are valid infix - characters. *) -let fixity_of_string = function - | s when List.mem s special_infix_strings -> `Infix s - | s when List.mem s.[0] infix_symbols -> `Infix s - | s when List.mem s.[0] prefix_symbols -> `Prefix s - | s when s.[0] = '.' -> `Mixfix s - | _ -> `Normal - -let view_fixity_of_exp = function - | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> - fixity_of_string l - | _ -> `Normal - -let is_infix = function | `Infix _ -> true | _ -> false -let is_mixfix = function `Mixfix _ -> true | _ -> false - -(* which identifiers are in fact operators needing parentheses *) -let needs_parens txt = - let fix = fixity_of_string txt in - is_infix fix - || is_mixfix fix - || List.mem txt.[0] prefix_symbols - -(* some infixes need spaces around parens to avoid clashes with comment - syntax *) -let needs_spaces txt = - txt.[0]='*' || txt.[String.length txt - 1] = '*' - -(* add parentheses to binders when they are in fact infix or prefix operators *) -let protect_ident ppf txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%s" - else if needs_spaces txt then "(@;%s@;)" - else "(%s)" - in fprintf ppf format txt - -let protect_longident ppf print_longident longprefix txt = - let format : (_, _, _) format = - if not (needs_parens txt) then "%a.%s" - else if needs_spaces txt then "%a.(@;%s@;)" - else "%a.(%s)" in - fprintf ppf format print_longident longprefix txt - -type space_formatter = (unit, Format.formatter, unit) format - -let override = function - | Override -> "!" - | Fresh -> "" - -(* variance encoding: need to sync up with the [parser.mly] *) -let type_variance = function - | Invariant -> "" - | Covariant -> "+" - | Contravariant -> "-" - -type construct = - [ `cons of expression list - | `list of expression list - | `nil - | `normal - | `simple of Longident.t - | `tuple ] - -let view_expr x = - match x.pexp_desc with - | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple - | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil - | Pexp_construct ( {txt= Lident"::";_},Some _) -> - let rec loop exp acc = match exp with - | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); - pexp_attributes = []} -> - (List.rev acc,true) - | {pexp_desc= - Pexp_construct ({txt=Lident "::";_}, - Some ({pexp_desc= Pexp_tuple([e1;e2]); - pexp_attributes = []})); - pexp_attributes = []} - -> - loop e2 (e1::acc) - | e -> (List.rev (e::acc),false) in - let (ls,b) = loop x [] in - if b then - `list ls - else `cons ls - | Pexp_construct (x,None) -> `simple (x.txt) - | _ -> `normal - -let is_simple_construct :construct -> bool = function - | `nil | `tuple | `list _ | `simple _ -> true - | `cons _ | `normal -> false - -let pp = fprintf - -type ctxt = { - pipe : bool; - semi : bool; - ifthenelse : bool; -} - -let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } -let under_pipe ctxt = { ctxt with pipe=true } -let under_semi ctxt = { ctxt with semi=true } -let under_ifthenelse ctxt = { ctxt with ifthenelse=true } -(* -let reset_semi ctxt = { ctxt with semi=false } -let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } -let reset_pipe ctxt = { ctxt with pipe=false } -*) - -let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> - ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> - Format.formatter -> 'a list -> unit - = fun ?sep ?first ?last fu f xs -> - let first = match first with Some x -> x |None -> ("": _ format6) - and last = match last with Some x -> x |None -> ("": _ format6) - and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in - let aux f = function - | [] -> () - | [x] -> fu f x - | xs -> - let rec loop f = function - | [x] -> fu f x - | x::xs -> fu f x; pp f sep; loop f xs; - | _ -> assert false in begin - pp f first; loop f xs; pp f last; - end in - aux f xs - -let option : 'a. ?first:space_formatter -> ?last:space_formatter -> - (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit - = fun ?first ?last fu f a -> - let first = match first with Some x -> x | None -> ("": _ format6) - and last = match last with Some x -> x | None -> ("": _ format6) in - match a with - | None -> () - | Some x -> pp f first; fu f x; pp f last - -let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> - bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit - = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> - if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") - else fu f x - -let rec longident f = function - | Lident s -> protect_ident f s - | Ldot(y,s) -> protect_longident f longident y s - | Lapply (y,s) -> - pp f "%a(%a)" longident y longident s - -let longident_loc f x = pp f "%a" longident x.txt - -let string_of_int_as_char i = Ext_util.string_of_int_as_char i - -let constant f = function - | Pconst_char i -> pp f "%s" (string_of_int_as_char i) - | Pconst_string (i, None) -> pp f "%S" i - | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim - | Pconst_integer (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i - | Pconst_integer (i, Some m) -> - paren (i.[0]='-') (fun f (i, m) -> pp f "%s%c" i m) f (i,m) - | Pconst_float (i, None) -> paren (i.[0]='-') (fun f -> pp f "%s") f i - | Pconst_float (i, Some m) -> paren (i.[0]='-') (fun f (i,m) -> - pp f "%s%c" i m) f (i,m) - -(* trailing space*) -let mutable_flag f = function - | Immutable -> () - | Mutable -> pp f "mutable@;" -let virtual_flag f = function - | Concrete -> () - | Virtual -> pp f "virtual@;" - -(* trailing space added *) -let rec_flag f rf = - match rf with - | Nonrecursive -> () - | Recursive -> pp f "rec " -let nonrec_flag f rf = - match rf with - | Nonrecursive -> pp f "nonrec " - | Recursive -> () -let direction_flag f = function - | Upto -> pp f "to@ " - | Downto -> pp f "downto@ " -let private_flag f = function - | Public -> () - | Private -> pp f "private@ " - -let constant_string f s = pp f "%S" s -let tyvar f str = pp f "'%s" str -let tyvar_loc f str = pp f "'%s" str.txt -let string_quot f x = pp f "`%s" x - -(* c ['a,'b] *) -let rec class_params_def ctxt f = function - | [] -> () - | l -> - pp f "[%a] " (* space *) - (list (type_param ctxt) ~sep:",") l - -and type_with_label ctxt f (label, c) = - match label with - | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) - | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c - | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c - -and core_type ctxt f x = - if x.ptyp_attributes <> [] then begin - pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} - (attributes ctxt) x.ptyp_attributes - end - else match x.ptyp_desc with - | Ptyp_arrow (l, ct1, ct2) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 - | Ptyp_alias (ct, s) -> - pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s - | Ptyp_poly ([], ct) -> - core_type ctxt f ct - | Ptyp_poly (sl, ct) -> - pp f "@[<2>%a%a@]" - (fun f l -> - pp f "%a" - (fun f l -> match l with - | [] -> () - | _ -> - pp f "%a@;.@;" - (list tyvar_loc ~sep:"@;") l) - l) - sl (core_type ctxt) ct - | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x - -and core_type1 ctxt f x = - if x.ptyp_attributes <> [] then core_type ctxt f x - else match x.ptyp_desc with - | Ptyp_any -> pp f "_"; - | Ptyp_var s -> tyvar f s; - | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Ptyp_constr (li, l) -> - pp f (* "%a%a@;" *) "%a%a" - (fun f l -> match l with - |[] -> () - |[x]-> pp f "%a@;" (core_type1 ctxt) x - | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) - l longident_loc li - | Ptyp_variant (l, closed, low) -> - let type_variant_helper f x = - match x with - | Rtag (l, attrs, _, ctl) -> - pp f "@[<2>%a%a@;%a@]" string_quot l.txt - (fun f l -> match l with - |[] -> () - | _ -> pp f "@;of@;%a" - (list (core_type ctxt) ~sep:"&") ctl) ctl - (attributes ctxt) attrs - | Rinherit ct -> core_type ctxt f ct in - pp f "@[<2>[%a%a]@]" - (fun f l -> - match l, closed with - | [], Closed -> () - | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) - | _ -> - pp f "%s@;%a" - (match (closed,low) with - | (Closed,None) -> "" - | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) - | (Open,_) -> ">") - (list type_variant_helper ~sep:"@;<1 -2>| ") l) l - (fun f low -> match low with - |Some [] |None -> () - |Some xs -> - pp f ">@ %a" - (list string_quot) xs) low - | Ptyp_object (l, o) -> - let core_field_type f = function - | Otag (l, attrs, ct) -> - pp f "@[%s: %a@ %a@ @]" l.txt - (core_type ctxt) ct (attributes ctxt) attrs (* Cf #7200 *) - | Oinherit ct -> - pp f "@[%a@ @]" (core_type ctxt) ct - in - let field_var f = function - | Asttypes.Closed -> () - | Asttypes.Open -> - match l with - | [] -> pp f ".." - | _ -> pp f " ;.." - in - pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l - field_var o (* Cf #7200 *) - | Ptyp_class (li, l) -> (*FIXME*) - pp f "@[%a#%a@]" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l - longident_loc li - | Ptyp_package (lid, cstrs) -> - let aux f (s, ct) = - pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in - (match cstrs with - |[] -> pp f "@[(module@ %a)@]" longident_loc lid - |_ -> - pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid - (list aux ~sep:"@ and@ ") cstrs) - | Ptyp_extension e -> extension ctxt f e - | _ -> paren true (core_type ctxt) f x - -(********************pattern********************) -(* be cautious when use [pattern], [pattern1] is preferred *) -and pattern ctxt f x = - let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) - | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> - list_of_pattern (p2::acc) p1 - | x -> x::acc - in - if x.ppat_attributes <> [] then begin - pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} - (attributes ctxt) x.ppat_attributes - end - else match x.ppat_desc with - | Ppat_alias (p, s) -> - pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) - | Ppat_or _ -> (* *) - pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) - (list_of_pattern [] x) - | _ -> pattern1 ctxt f x - -and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = - let rec pattern_list_helper f = function - | {ppat_desc = - Ppat_construct - ({ txt = Lident("::") ;_}, - Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); - ppat_attributes = []} - - -> - pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) - | p -> pattern1 ctxt f p - in - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_variant (l, Some p) -> - pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p - | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x - | Ppat_construct (({txt;_} as li), po) -> - (* FIXME The third field always false *) - if txt = Lident "::" then - pp f "%a" pattern_list_helper x - else - (match po with - | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) - | _ -> simple_pattern ctxt f x - -and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = - if x.ppat_attributes <> [] then pattern ctxt f x - else match x.ppat_desc with - | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x - | Ppat_any -> pp f "_"; - | Ppat_var ({txt = txt;_}) -> protect_ident f txt - | Ppat_array l -> - pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l - | Ppat_unpack (s) -> - pp f "(module@ %s)@ " s.txt - | Ppat_type li -> - pp f "#%a" longident_loc li - | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = - match (li,p) with - | ({txt=Lident s;_ }, - {ppat_desc=Ppat_var {txt;_}; - ppat_attributes=[]; _}) - when s = txt -> - pp f "@[<2>%a@]" longident_loc li - | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p - in - begin match closed with - | Closed -> - pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l - | _ -> - pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l - end - | Ppat_tuple l -> - pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) - | Ppat_constant (c) -> pp f "%a" constant c - | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l,None) -> pp f "`%s" l - | Ppat_constraint (p, ct) -> - pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct - | Ppat_lazy p -> - pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p - | Ppat_exception p -> - pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p - | Ppat_extension e -> extension ctxt f e - | Ppat_open (lid, p) -> - let with_paren = - match p.ppat_desc with - | Ppat_array _ | Ppat_record _ - | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false - | _ -> true in - pp f "@[<2>%a.%a @]" longident_loc lid - (paren with_paren @@ pattern1 ctxt) p - | _ -> paren true (pattern ctxt) f x - -and label_exp ctxt f (l,opt,p) = - match l with - | Nolabel -> - (* single case pattern parens needed here *) - pp f "%a@ " (simple_pattern ctxt) p - | Optional rest -> - begin match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = rest -> - (match opt with - | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o - | None -> pp f "?%s@ " rest) - | _ -> - (match opt with - | Some o -> - pp f "?%s:(%a=@;%a)@;" - rest (pattern1 ctxt) p (expression ctxt) o - | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) - end - | Labelled l -> match p with - | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} - when txt = l -> - pp f "~%s@;" l - | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p - -and sugar_expr ctxt f e = - if e.pexp_attributes <> [] then false - else match e.pexp_desc with - | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; - pexp_attributes=[]; _}, args) - when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin - let print_indexop a path_prefix assign left right print_index indices - rem_args = - let print_path ppf = function - | None -> () - | Some m -> pp ppf ".%a" longident m in - match assign, rem_args with - | false, [] -> - pp f "@[%a%a%s%a%s@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right; true - | true, [v] -> - pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" - (simple_expr ctxt) a print_path path_prefix - left (list ~sep:"," print_index) indices right - (simple_expr ctxt) v; true - | _ -> false in - match id, List.map snd args with - | Lident "!", [e] -> - pp f "@[!%a@]" (simple_expr ctxt) e; true - | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin - let assign = func = "set" in - let print = print_indexop a None assign in - match path, other_args with - | Lident "Array", i :: rest -> - print ".(" ")" (expression ctxt) [i] rest - | Lident "String", i :: rest -> - print ".[" "]" (expression ctxt) [i] rest - | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1] rest - | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2] rest - | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> - print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest - | Ldot (Lident "Bigarray", "Genarray"), - {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> - print ".{" "}" (simple_expr ctxt) indexes rest - | _ -> false - end - | (Lident s | Ldot(_,s)) , a :: i :: rest - when s.[0] = '.' -> - let n = String.length s in - (* extract operator: - assignment operators end with [right_bracket ^ "<-"], - access operators end with [right_bracket] directly - *) - let assign = s.[n - 1] = '-' in - let kind = - (* extract the right end bracket *) - if assign then s.[n - 3] else s.[n - 1] in - let left, right = match kind with - | ')' -> '(', ")" - | ']' -> '[', "]" - | '}' -> '{', "}" - | _ -> assert false in - let path_prefix = match id with - | Ldot(m,_) -> Some m - | _ -> None in - let left = String.sub s 0 (1+String.index s left) in - print_indexop a path_prefix assign left right - (expression ctxt) [i] rest - | _ -> false - end - | _ -> false - -and expression ctxt f x = - if x.pexp_attributes <> [] then - pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} - (attributes ctxt) x.pexp_attributes - else match x.pexp_desc with - | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ - when ctxt.pipe || ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> - paren true (expression reset_ctxt) f x - | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ - when ctxt.semi -> - paren true (expression reset_ctxt) f x - | Pexp_fun (l, e0, p, e) -> - pp f "@[<2>fun@;%a->@;%a@]" - (label_exp ctxt) (l, e0, p) - (expression ctxt) e - | Pexp_function l -> - pp f "@[function%a@]" (case_list ctxt) l - | Pexp_match (e, l) -> - pp f "@[@[@[<2>match %a@]@ with@]%a@]" - (expression reset_ctxt) e (case_list ctxt) l - - | Pexp_try (e, l) -> - pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" - (* "try@;@[<2>%a@]@\nwith@\n%a"*) - (expression reset_ctxt) e (case_list ctxt) l - | Pexp_let (rf, l, e) -> - (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" - (*no indentation here, a new line*) *) - (* rec_flag rf *) - pp f "@[<2>%a in@;<1 -2>%a@]" - (bindings reset_ctxt) (rf,l) - (expression ctxt) e - | Pexp_apply (e, l) -> - begin if not (sugar_expr ctxt f x) then - match view_fixity_of_exp e with - | `Infix s -> - begin match l with - | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> - (* FIXME associativity label_x_expression_param *) - pp f "@[<2>%a@;%s@;%a@]" - (label_x_expression_param reset_ctxt) arg1 s - (label_x_expression_param ctxt) arg2 - | _ -> - pp f "@[<2>%a %a@]" - (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | `Prefix s -> - let s = - if List.mem s ["~+";"~-";"~+.";"~-."] && - (match l with - (* See #7200: avoid turning (~- 1) into (- 1) which is - parsed as an int literal *) - |[(_,{pexp_desc=Pexp_constant _})] -> false - | _ -> true) - then String.sub s 1 (String.length s -1) - else s in - begin match l with - | [(Nolabel, x)] -> - pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x - | _ -> - pp f "@[<2>%a %a@]" (simple_expr ctxt) e - (list (label_x_expression_param ctxt)) l - end - | _ -> - pp f "@[%a@]" begin fun f (e,l) -> - pp f "%a@ %a" (expression2 ctxt) e - (list (label_x_expression_param reset_ctxt)) l - (* reset here only because [function,match,try,sequence] - are lower priority *) - end (e,l) - end - - | Pexp_construct (li, Some eo) - when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) - (match view_expr x with - | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" - | `normal -> - pp f "@[<2>%a@;%a@]" longident_loc li - (simple_expr ctxt) eo - | _ -> assert false) - | Pexp_setfield (e1, li, e2) -> - pp f "@[<2>%a.%a@ <-@ %a@]" - (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 - | Pexp_ifthenelse (e1, e2, eo) -> - (* @;@[<2>else@ %a@]@] *) - let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in - let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in - pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 - (fun f eo -> match eo with - | Some x -> - pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x - | None -> () (* pp f "()" *)) eo - | Pexp_sequence _ -> - let rec sequence_helper acc = function - | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> - sequence_helper (e1::acc) e2 - | v -> List.rev (v::acc) in - let lst = sequence_helper [] x in - pp f "@[%a@]" - (list (expression (under_semi ctxt)) ~sep:";@;") lst - | Pexp_new (li) -> - pp f "@[new@ %a@]" longident_loc li; - | Pexp_setinstvar (s, e) -> - pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e - | Pexp_override l -> (* FIXME *) - let string_x_expression f (s, e) = - pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in - pp f "@[{<%a>}@]" - (list string_x_expression ~sep:";" ) l; - | Pexp_letmodule (s, me, e) -> - pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt - (module_expr reset_ctxt) me (expression ctxt) e - | Pexp_letexception (cd, e) -> - pp f "@[let@ exception@ %a@ in@ %a@]" - (extension_constructor ctxt) cd - (expression ctxt) e - | Pexp_assert e -> - pp f "@[assert@ %a@]" (simple_expr ctxt) e - | Pexp_lazy (e) -> - pp f "@[lazy@ %a@]" (simple_expr ctxt) e - (* Pexp_poly: impossible but we should print it anyway, rather than - assert false *) - | Pexp_poly (e, None) -> - pp f "@[!poly!@ %a@]" (simple_expr ctxt) e - | Pexp_poly (e, Some ct) -> - pp f "@[(!poly!@ %a@ : %a)@]" - (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid - (expression ctxt) e - | Pexp_variant (l,Some eo) -> - pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo - | Pexp_extension e -> extension ctxt f e - | Pexp_unreachable -> pp f "." - | _ -> expression1 ctxt f x - -and expression1 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs - | _ -> expression2 ctxt f x -(* used in [Pexp_apply] *) - -and expression2 ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_field (e, li) -> - pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li - | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt - - | _ -> simple_expr ctxt f x - -and simple_expr ctxt f x = - if x.pexp_attributes <> [] then expression ctxt f x - else match x.pexp_desc with - | Pexp_construct _ when is_simple_construct (view_expr x) -> - (match view_expr x with - | `nil -> pp f "[]" - | `tuple -> pp f "()" - | `list xs -> - pp f "@[[%a]@]" - (list (expression (under_semi ctxt)) ~sep:";@;") xs - | `simple x -> longident f x - | _ -> assert false) - | Pexp_ident li -> - longident_loc f li - (* (match view_fixity_of_exp x with *) - (* |`Normal -> longident_loc f li *) - (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) - | Pexp_constant c -> constant f c; - | Pexp_pack me -> - pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_newtype (lid, e) -> - pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e - | Pexp_tuple l -> - pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l - | Pexp_constraint (e, ct) -> - pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_coerce (e, cto1, ct) -> - pp f "(%a%a :> %a)" (expression ctxt) e - (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) - (core_type ctxt) ct - | Pexp_variant (l, None) -> pp f "`%s" l - | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = - match e with - | {pexp_desc=Pexp_ident {txt;_}; - pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li - | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e - in - pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) - (option ~last:" with@;" (simple_expr ctxt)) eo - (list longident_x_expression ~sep:";@;") l - | Pexp_array (l) -> - pp f "@[<0>@[<2>[|%a|]@]@]" - (list (simple_expr (under_semi ctxt)) ~sep:";") l - | Pexp_while (e1, e2) -> - let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in - pp f fmt (expression ctxt) e1 (expression ctxt) e2 - | Pexp_for (s, e1, e2, df, e3) -> - let fmt:(_,_,_)format = - "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in - let expression = expression ctxt in - pp f fmt (pattern ctxt) s expression e1 direction_flag - df expression e2 expression e3 - | _ -> paren true (expression ctxt) f x - -and attributes ctxt f l = - List.iter (attribute ctxt f) l - -and item_attributes ctxt f l = - List.iter (item_attribute ctxt f) l - -and attribute ctxt f (s, e) = - pp f "@[<2>[@@%s@ %a]@]" s.txt (payload ctxt) e - -and item_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@%s@ %a]@]" s.txt (payload ctxt) e - -and floating_attribute ctxt f (s, e) = - pp f "@[<2>[@@@@@@%s@ %a]@]" s.txt (payload ctxt) e - -and value_description ctxt f x = - (* note: value_description has an attribute field, - but they're already printed by the callers this method *) - pp f "@[%a%a@]" (core_type ctxt) x.pval_type - (fun f x -> -#ifndef RELEASE - match x.pval_prim with - | first :: second :: _ - when Ext_string.first_marshal_char second - -> - pp f "@ =@ %a -- %a" - constant_string first - Ext_obj.pp_any (Marshal.from_string second 0) - | [] -> () - | _ -> - pp f "@ =@ %a" (list constant_string) x.pval_prim - -#else - if x.pval_prim <> [] - then pp f "@ =@ %a" (list constant_string) x.pval_prim -#endif - ) x - -and extension ctxt f (s, e) = - pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e - -and item_extension ctxt f (s, e) = - pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e - -and exception_declaration ctxt f ext = - pp f "@[exception@ %a@]" (extension_constructor ctxt) ext - -and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = - let class_type_field f x = - match x.pctf_desc with - | Pctf_inherit (ct) -> - pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_val (s, mf, vf, ct) -> - pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" - mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_method (s, pf, vf, ct) -> - pp f "@[<2>method %a %a%s :@;%a@]%a" - private_flag pf virtual_flag vf s.txt (core_type ctxt) ct - (item_attributes ctxt) x.pctf_attributes - | Pctf_constraint (ct1, ct2) -> - pp f "@[<2>constraint@ %a@ =@ %a@]%a" - (core_type ctxt) ct1 (core_type ctxt) ct2 - (item_attributes ctxt) x.pctf_attributes - | Pctf_attribute a -> floating_attribute ctxt f a - | Pctf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pctf_attributes - in - pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" - (fun f -> function - {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () - | ct -> pp f " (%a)" (core_type ctxt) ct) ct - (list class_type_field ~sep:"@;") l - -(* call [class_signature] called by [class_signature] *) -and class_type ctxt f x = - match x.pcty_desc with - | Pcty_signature cs -> - class_signature ctxt f cs; - attributes ctxt f x.pcty_attributes - | Pcty_constr (li, l) -> - pp f "%a%a%a" - (fun f l -> match l with - | [] -> () - | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l - longident_loc li - (attributes ctxt) x.pcty_attributes - | Pcty_arrow (l, co, cl) -> - pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) - (type_with_label ctxt) (l,co) - (class_type ctxt) cl - | Pcty_extension e -> - extension ctxt f e; - attributes ctxt f x.pcty_attributes - | Pcty_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid - (class_type ctxt) e - -(* [class type a = object end] *) -and class_type_declaration_list ctxt f l = - let class_type_declaration kwd f x = - let { pci_params=ls; pci_name={ txt; _ }; _ } = x in - pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd - virtual_flag x.pci_virt - (class_params_def ctxt) ls txt - (class_type ctxt) x.pci_expr - (item_attributes ctxt) x.pci_attributes - in - match l with - | [] -> () - | [x] -> class_type_declaration "class type" f x - | x :: xs -> - pp f "@[%a@,%a@]" - (class_type_declaration "class type") x - (list ~sep:"@," (class_type_declaration "and")) xs - -and class_field ctxt f x = - match x.pcf_desc with - | Pcf_inherit () -> () - | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> - pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) - mutable_flag mf s.txt - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_virtual ct) -> - pp f "@[<2>method virtual %a %s :@;%a@]%a" - private_flag pf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_val (s, mf, Cfk_virtual ct) -> - pp f "@[<2>val virtual %a%s :@ %a@]%a" - mutable_flag mf s.txt - (core_type ctxt) ct - (item_attributes ctxt) x.pcf_attributes - | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> - let bind e = - binding ctxt f - {pvb_pat= - {ppat_desc=Ppat_var s;ppat_loc=Location.none;ppat_attributes=[]}; - pvb_expr=e; - pvb_attributes=[]; - pvb_loc=Location.none; - } - in - pp f "@[<2>method%s %a%a@]%a" - (override ovf) - private_flag pf - (fun f -> function - | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> - pp f "%s :@;%a=@;%a" - s.txt (core_type ctxt) ct (expression ctxt) e - | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> - bind e - | _ -> bind e) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_constraint (ct1, ct2) -> - pp f "@[<2>constraint %a =@;%a@]%a" - (core_type ctxt) ct1 - (core_type ctxt) ct2 - (item_attributes ctxt) x.pcf_attributes - | Pcf_initializer (e) -> - pp f "@[<2>initializer@ %a@]%a" - (expression ctxt) e - (item_attributes ctxt) x.pcf_attributes - | Pcf_attribute a -> floating_attribute ctxt f a - | Pcf_extension e -> - item_extension ctxt f e; - item_attributes ctxt f x.pcf_attributes - -and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = - pp f "@[@[object%a@;%a@]@;end@]" - (fun f p -> match p.ppat_desc with - | Ppat_any -> () - | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p - | _ -> pp f " (%a)" (pattern ctxt) p) p - (list (class_field ctxt)) l - -and module_type ctxt f x = - if x.pmty_attributes <> [] then begin - pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} - (attributes ctxt) x.pmty_attributes - end else - match x.pmty_desc with - | Pmty_ident li -> - pp f "%a" longident_loc li; - | Pmty_alias li -> - pp f "(module %a)" longident_loc li; - | Pmty_signature (s) -> - pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) - (list (signature_item ctxt)) s (* FIXME wrong indentation*) - | Pmty_functor (_, None, mt2) -> - pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 - | Pmty_functor (s, Some mt1, mt2) -> - if s.txt = "_" then - pp f "@[%a@ ->@ %a@]" - (module_type ctxt) mt1 (module_type ctxt) mt2 - else - pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt - (module_type ctxt) mt1 (module_type ctxt) mt2 - | Pmty_with (mt, l) -> - let with_constraint f = function - | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a =@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; - | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a :=@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li - (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 in - (match l with - | [] -> pp f "@[%a@]" (module_type ctxt) mt - | _ -> pp f "@[(%a@ with@ %a)@]" - (module_type ctxt) mt (list with_constraint ~sep:"@ and@ ") l) - | Pmty_typeof me -> - pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me - | Pmty_extension e -> extension ctxt f e - -and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x - -and signature_item ctxt f x : unit = - match x.psig_desc with - | Psig_type (rf, l) -> - type_def_list ctxt f (rf, l) - | Psig_value vd -> - let intro = if vd.pval_prim = [] then "val" else "external" in - pp f "@[<2>%s@ %a@ :@ %a@]%a" intro - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Psig_typext te -> - type_extension ctxt f te - | Psig_exception ed -> - exception_declaration ctxt f ed - | Psig_class () -> - () - | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; - pmty_attributes=[]; _};_} as pmd) -> - pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt - longident_loc alias - (item_attributes ctxt) pmd.pmd_attributes - | Psig_module pmd -> - pp f "@[module@ %s@ :@ %a@]%a" - pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - | Psig_open od -> - pp f "@[open%s@ %a@]%a" - (override od.popen_override) - longident_loc od.popen_lid - (item_attributes ctxt) od.popen_attributes - | Psig_include incl -> - pp f "@[include@ %a@]%a" - (module_type ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Psig_class_type (l) -> class_type_declaration_list ctxt f l - | Psig_recmodule decls -> - let rec string_x_module_type_list f ?(first=true) l = - match l with - | [] -> () ; - | pmd :: tl -> - if not first then - pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes - else - pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt - (module_type ctxt) pmd.pmd_type - (item_attributes ctxt) pmd.pmd_attributes; - string_x_module_type_list f ~first:false tl - in - string_x_module_type_list f decls - | Psig_attribute a -> floating_attribute ctxt f a - | Psig_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and module_expr ctxt f x = - if x.pmod_attributes <> [] then - pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} - (attributes ctxt) x.pmod_attributes - else match x.pmod_desc with - | Pmod_structure (s) -> - pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" - (list (structure_item ctxt) ~sep:"@\n") s; - | Pmod_constraint (me, mt) -> - pp f "@[(%a@ :@ %a)@]" - (module_expr ctxt) me - (module_type ctxt) mt - | Pmod_ident (li) -> - pp f "%a" longident_loc li; - | Pmod_functor (_, None, me) -> - pp f "functor ()@;->@;%a" (module_expr ctxt) me - | Pmod_functor (s, Some mt, me) -> - pp f "functor@ (%s@ :@ %a)@;->@;%a" - s.txt (module_type ctxt) mt (module_expr ctxt) me - | Pmod_apply (me1, me2) -> - pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 - (* Cf: #7200 *) - | Pmod_unpack e -> - pp f "(val@ %a)" (expression ctxt) e - | Pmod_extension e -> extension ctxt f e - -and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x - -and payload ctxt f = function - | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> - pp f "@[<2>%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | PStr x -> structure ctxt f x - | PTyp x -> pp f ":"; core_type ctxt f x - | PSig x -> pp f ":"; signature ctxt f x - | PPat (x, None) -> pp f "?"; pattern ctxt f x - | PPat (x, Some e) -> - pp f "?"; pattern ctxt f x; - pp f " when "; expression ctxt f e - -(* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) -and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = - (* .pvb_attributes have already been printed by the caller, #bindings *) - let rec pp_print_pexp_function f x = - if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x - else match x.pexp_desc with - | Pexp_fun (label, eo, p, e) -> - if label=Nolabel then - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e - else - pp f "%a@ %a" - (label_exp ctxt) (label,eo,p) pp_print_pexp_function e - | Pexp_newtype (str,e) -> - pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e - | _ -> pp f "=@;%a" (expression ctxt) x - in - let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in - let is_desugared_gadt p e = - let gadt_pattern = - match p with - | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, - {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); - ppat_attributes=[]}-> - Some (pat, args_tyvars, rt) - | _ -> None in - let rec gadt_exp tyvars e = - match e with - | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> - gadt_exp (tyvar :: tyvars) e - | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> - Some (List.rev tyvars, e, ct) - | _ -> None in - let gadt_exp = gadt_exp [] e in - match gadt_pattern, gadt_exp with - | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) - when tyvars_str pt_tyvars = tyvars_str e_tyvars -> - let ety = Typ.varify_constructors e_tyvars e_ct in - if ety = pt_ct then - Some (p, pt_tyvars, e_ct, e) else None - | _ -> None in - if x.pexp_attributes <> [] - then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else - match is_desugared_gadt p x with - | Some (p, [], ct, e) -> - pp f "%a@;: %a@;=@;%a" - (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e - | Some (p, tyvars, ct, e) -> begin - pp f "%a@;: type@;%a.@;%a@;=@;%a" - (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") - (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e - end - | None -> begin - match p with - | {ppat_desc=Ppat_constraint(p ,ty); - ppat_attributes=[]} -> (* special case for the first*) - begin match ty with - | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> - pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - | _ -> - pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p - (core_type ctxt) ty (expression ctxt) x - end - | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x - | _ -> - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - end - -(* [in] is not printed *) -and bindings ctxt f (rf,l) = - let binding kwd rf f x = - pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf - (binding ctxt) x (item_attributes ctxt) x.pvb_attributes - in - match l with - | [] -> () - | [x] -> binding "let" rf f x - | x::xs -> - pp f "@[%a@,%a@]" - (binding "let" rf) x - (list ~sep:"@," (binding "and" Nonrecursive)) xs - -and structure_item ctxt f x = - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - pp f "@[;;%a@]%a" - (expression ctxt) e - (item_attributes ctxt) attrs - | Pstr_type (_, []) -> assert false - | Pstr_type (rf, l) -> type_def_list ctxt f (rf, l) - | Pstr_value (rf, l) -> - (* pp f "@[let %a%a@]" rec_flag rf bindings l *) - pp f "@[<2>%a@]" (bindings ctxt) (rf,l) - | Pstr_typext te -> type_extension ctxt f te - | Pstr_exception ed -> exception_declaration ctxt f ed - | Pstr_module x -> - let rec module_helper = function - | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> - if mt = None then pp f "()" - else Misc.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; - module_helper me' - | me -> me - in - pp f "@[module %s%a@]%a" - x.pmb_name.txt - (fun f me -> - let me = module_helper me in - match me with - | {pmod_desc= - Pmod_constraint - (me', - ({pmty_desc=(Pmty_ident (_) - | Pmty_signature (_));_} as mt)); - pmod_attributes = []} -> - pp f " :@;%a@;=@;%a@;" - (module_type ctxt) mt (module_expr ctxt) me' - | _ -> pp f " =@ %a" (module_expr ctxt) me - ) x.pmb_expr - (item_attributes ctxt) x.pmb_attributes - | Pstr_open od -> - pp f "@[<2>open%s@;%a@]%a" - (override od.popen_override) - longident_loc od.popen_lid - (item_attributes ctxt) od.popen_attributes - | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> - pp f "@[module@ type@ %s%a@]%a" - s.txt - (fun f md -> match md with - | None -> () - | Some mt -> - pp_print_space f () ; - pp f "@ =@ %a" (module_type ctxt) mt - ) md - (item_attributes ctxt) attrs - | Pstr_class () -> () - | Pstr_class_type l -> class_type_declaration_list ctxt f l - | Pstr_primitive vd -> - pp f "@[external@ %a@ :@ %a@]%a" - protect_ident vd.pval_name.txt - (value_description ctxt) vd - (item_attributes ctxt) vd.pval_attributes - | Pstr_include incl -> - pp f "@[include@ %a@]%a" - (module_expr ctxt) incl.pincl_mod - (item_attributes ctxt) incl.pincl_attributes - | Pstr_recmodule decls -> (* 3.07 *) - let aux f = function - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> - pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - | _ -> assert false - in - begin match decls with - | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> - pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" - pmb.pmb_name.txt - (module_type ctxt) typ - (module_expr ctxt) expr - (item_attributes ctxt) pmb.pmb_attributes - (fun f l2 -> List.iter (aux f) l2) l2 - | _ -> assert false - end - | Pstr_attribute a -> floating_attribute ctxt f a - | Pstr_extension(e, a) -> - item_extension ctxt f e; - item_attributes ctxt f a - -and type_param ctxt f (ct, a) = - pp f "%s%a" (type_variance a) (core_type ctxt) ct - -and type_params ctxt f = function - | [] -> () - | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l - -and type_def_list ctxt f (rf, l) = - let type_decl kwd rf f x = - let eq = - if (x.ptype_kind = Ptype_abstract) - && (x.ptype_manifest = None) then "" - else " =" - in - pp f "@[<2>%s %a%a%s%s%a@]%a" kwd - nonrec_flag rf - (type_params ctxt) x.ptype_params - x.ptype_name.txt eq - (type_declaration ctxt) x - (item_attributes ctxt) x.ptype_attributes - in - match l with - | [] -> assert false - | [x] -> type_decl "type" rf f x - | x :: xs -> pp f "@[%a@,%a@]" - (type_decl "type" rf) x - (list ~sep:"@," (type_decl "and" Recursive)) xs - -and record_declaration ctxt f lbls = - let type_record_field f pld = - pp f "@[<2>%a%s:@;%a@;%a@]" - mutable_flag pld.pld_mutable - pld.pld_name.txt - (core_type ctxt) pld.pld_type - (attributes ctxt) pld.pld_attributes - in - pp f "{@\n%a}" - (list type_record_field ~sep:";@\n" ) lbls - -and type_declaration ctxt f x = - (* type_declaration has an attribute field, - but it's been printed by the caller of this method *) - let priv f = - match x.ptype_private with - | Public -> () - | Private -> pp f "@;private" - in - let manifest f = - match x.ptype_manifest with - | None -> () - | Some y -> - if x.ptype_kind = Ptype_abstract then - pp f "%t@;%a" priv (core_type ctxt) y - else - pp f "@;%a" (core_type ctxt) y - in - let constructor_declaration f pcd = - pp f "|@;"; - constructor_declaration ctxt f - (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) - in - let repr f = - let intro f = - if x.ptype_manifest = None then () - else pp f "@;=" - in - match x.ptype_kind with - | Ptype_variant xs -> - pp f "%t%t@\n%a" intro priv - (list ~sep:"@\n" constructor_declaration) xs - | Ptype_abstract -> () - | Ptype_record l -> - pp f "%t%t@;%a" intro priv (record_declaration ctxt) l - | Ptype_open -> pp f "%t%t@;.." intro priv - in - let constraints f = - List.iter - (fun (ct1,ct2,_) -> - pp f "@[@ constraint@ %a@ =@ %a@]" - (core_type ctxt) ct1 (core_type ctxt) ct2) - x.ptype_cstrs - in - pp f "%t%t%t" manifest repr constraints - -and type_extension ctxt f x = - let extension_constructor f x = - pp f "@\n|@;%a" (extension_constructor ctxt) x - in - pp f "@[<2>type %a%a += %a@ %a@]%a" - (fun f -> function - | [] -> () - | l -> - pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) - x.ptyext_params - longident_loc x.ptyext_path - private_flag x.ptyext_private (* Cf: #7200 *) - (list ~sep:"" extension_constructor) - x.ptyext_constructors - (item_attributes ctxt) x.ptyext_attributes - -and constructor_declaration ctxt f (name, args, res, attrs) = - let name = - match name with - | "::" -> "(::)" - | s -> s in - match res with - | None -> - pp f "%s%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> () - | Pcstr_tuple l -> - pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l - | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l - ) args - (attributes ctxt) attrs - | Some r -> - pp f "%s:@;%a@;%a" name - (fun f -> function - | Pcstr_tuple [] -> core_type1 ctxt f r - | Pcstr_tuple l -> pp f "%a@;->@;%a" - (list (core_type1 ctxt) ~sep:"@;*@;") l - (core_type1 ctxt) r - | Pcstr_record l -> - pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r - ) - args - (attributes ctxt) attrs - -and extension_constructor ctxt f x = - (* Cf: #7200 *) - match x.pext_kind with - | Pext_decl(l, r) -> - constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) - | Pext_rebind li -> - pp f "%s%a@;=@;%a" x.pext_name.txt - (attributes ctxt) x.pext_attributes - longident_loc li - -and case_list ctxt f l : unit = - let aux f {pc_lhs; pc_guard; pc_rhs} = - pp f "@;| @[<2>%a%a@;->@;%a@]" - (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") - pc_guard (expression (under_pipe ctxt)) pc_rhs - in - list aux f l ~sep:"" - -and label_x_expression_param ctxt f (l,e) = - let simple_name = match e with - | {pexp_desc=Pexp_ident {txt=Lident l;_}; - pexp_attributes=[]} -> Some l - | _ -> None - in match l with - | Nolabel -> expression2 ctxt f e (* level 2*) - | Optional str -> - if Some str = simple_name then - pp f "?%s" str - else - pp f "?%s:%a" str (simple_expr ctxt) e - | Labelled lbl -> - if Some lbl = simple_name then - pp f "~%s" lbl - else - pp f "~%s:%a" lbl (simple_expr ctxt) e - - - -let expression f x = - pp f "@[%a@]" (expression reset_ctxt) x - -let string_of_expression x = - ignore (flush_str_formatter ()) ; - let f = str_formatter in - expression f x; - flush_str_formatter () - -let string_of_structure x = - ignore (flush_str_formatter ()); - let f = str_formatter in - structure reset_ctxt f x; - flush_str_formatter () - - -let core_type = core_type reset_ctxt -let pattern = pattern reset_ctxt -let signature = signature reset_ctxt -let structure = structure reset_ctxt diff --git a/jscomp/ml/predef.ml b/jscomp/ml/predef.ml deleted file mode 100644 index fb45e34..0000000 --- a/jscomp/ml/predef.ml +++ /dev/null @@ -1,348 +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. *) -(* *) -(**************************************************************************) - -(* Predefined type constructors (with special typing rules in typecore) *) - -open Path -open Types -open Btype - -let builtin_idents = ref [] - -let wrap create s = - let id = create s in - builtin_idents := (s, id) :: !builtin_idents; - id - -let ident_create = wrap Ident.create -let ident_create_predef_exn = wrap Ident.create_predef_exn - -let ident_int = ident_create "int" -and ident_char = ident_create "char" -and ident_bytes = ident_create "bytes" -and ident_float = ident_create "float" -and ident_bool = ident_create "bool" -and ident_unit = ident_create "unit" -and ident_exn = ident_create "exn" -and ident_array = ident_create "array" -and ident_list = ident_create "list" -and ident_option = ident_create "option" -and ident_result = ident_create "result" -and ident_dict = ident_create "dict" - -and ident_int64 = ident_create "int64" -and ident_bigint = ident_create "bigint" -and ident_lazy_t = ident_create "lazy_t" -and ident_string = ident_create "string" -and ident_extension_constructor = ident_create "extension_constructor" -and ident_floatarray = ident_create "floatarray" - -and ident_unknown = ident_create "unknown" - -and ident_promise = ident_create "promise" -and ident_uncurried = ident_create "function$" - -type test = - | For_sure_yes - | For_sure_no - | NA - -let type_is_builtin_path_but_option (p : Path.t) : test = - match p with - | Pident {stamp} -> - if - stamp >= ident_int.stamp - && stamp <= ident_floatarray.stamp - then - if (stamp = ident_option.stamp) - || (stamp = ident_unit.stamp) then - For_sure_no - else For_sure_yes - else NA - | _ -> NA - -let path_int = Pident ident_int -and path_char = Pident ident_char -and path_bytes = Pident ident_bytes -and path_float = Pident ident_float -and path_bool = Pident ident_bool -and path_unit = Pident ident_unit -and path_exn = Pident ident_exn -and path_array = Pident ident_array -and path_list = Pident ident_list -and path_option = Pident ident_option -and path_result = Pident ident_result -and path_dict = Pident ident_dict - - -and path_int64 = Pident ident_int64 -and path_bigint = Pident ident_bigint -and path_lazy_t = Pident ident_lazy_t -and path_string = Pident ident_string - -and path_unkonwn = Pident ident_unknown -and path_extension_constructor = Pident ident_extension_constructor -and path_floatarray = Pident ident_floatarray - -and path_promise = Pident ident_promise -and path_uncurried = Pident ident_uncurried - -let type_int = newgenty (Tconstr(path_int, [], ref Mnil)) -and type_char = newgenty (Tconstr(path_char, [], ref Mnil)) -and type_bytes = newgenty (Tconstr(path_bytes, [], ref Mnil)) -and type_float = newgenty (Tconstr(path_float, [], ref Mnil)) -and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil)) -and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil)) -and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil)) -and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil)) -and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil)) -and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil)) -and type_result t1 t2 = newgenty (Tconstr(path_result, [t1; t2], ref Mnil)) -and type_dict t = newgenty (Tconstr(path_dict, [t], ref Mnil)) - -and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil)) -and type_bigint = newgenty (Tconstr(path_bigint, [], ref Mnil)) -and type_lazy_t t = newgenty (Tconstr(path_lazy_t, [t], ref Mnil)) -and type_string = newgenty (Tconstr(path_string, [], ref Mnil)) - -and type_unknown = newgenty (Tconstr(path_unkonwn, [], ref Mnil)) -and type_extension_constructor = - newgenty (Tconstr(path_extension_constructor, [], ref Mnil)) -and type_floatarray = newgenty (Tconstr(path_floatarray, [], ref Mnil)) - -let ident_match_failure = ident_create_predef_exn "Match_failure" - -and ident_invalid_argument = ident_create_predef_exn "Invalid_argument" -and ident_failure = ident_create_predef_exn "Failure" -and ident_ok = ident_create_predef_exn "Ok" -and ident_error = ident_create_predef_exn "Error" - -and ident_js_error = ident_create_predef_exn "JsError" -and ident_not_found = ident_create_predef_exn "Not_found" - -and ident_end_of_file = ident_create_predef_exn "End_of_file" -and ident_division_by_zero = ident_create_predef_exn "Division_by_zero" - - -and ident_assert_failure = ident_create_predef_exn "Assert_failure" -and ident_undefined_recursive_module = - ident_create_predef_exn "Undefined_recursive_module" - -let all_predef_exns = [ - ident_match_failure; - ident_invalid_argument; - ident_failure; - ident_js_error; - ident_not_found; - ident_end_of_file; - ident_division_by_zero; - ident_assert_failure; - ident_undefined_recursive_module; -] - -let path_match_failure = Pident ident_match_failure -and path_assert_failure = Pident ident_assert_failure -and path_undefined_recursive_module = Pident ident_undefined_recursive_module - -let decl_abstr = - {type_params = []; - type_arity = 0; - type_kind = Type_abstract; - type_loc = Location.none; - type_private = Asttypes.Public; - type_manifest = None; - type_variance = []; - type_newtype_level = None; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - -let decl_abstr_imm = {decl_abstr with type_immediate = true} - -let cstr id args = - { - cd_id = id; - cd_args = Cstr_tuple args; - cd_res = None; - cd_loc = Location.none; - cd_attributes = []; - } - -let ident_false = ident_create "false" -and ident_true = ident_create "true" -and ident_void = ident_create "()" -and ident_nil = ident_create "[]" -and ident_cons = ident_create "::" -and ident_none = ident_create "None" -and ident_some = ident_create "Some" -and ident_ctor_unknown = ident_create "Unknown" -and ident_ctor_uncurried = ident_create "Function$" - -let common_initial_env add_type add_extension empty_env = - let decl_bool = - {decl_abstr with - type_kind = Type_variant([cstr ident_false []; cstr ident_true []]); - type_immediate = true} - and decl_unit = - {decl_abstr with - type_kind = Type_variant([cstr ident_void []]); - type_immediate = true} - and decl_exn = - {decl_abstr with - type_kind = Type_open} - and decl_array = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_variance = [Variance.full]} - and decl_list = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_kind = - Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]); - type_variance = [Variance.covariant]} - and decl_option = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_kind = Type_variant([cstr ident_none []; cstr ident_some [tvar]]); - type_variance = [Variance.covariant]} - and decl_result = - let tvar1, tvar2 = newgenvar(), newgenvar() in - {decl_abstr with - type_params = [tvar1; tvar2]; - type_arity = 2; - type_kind = - Type_variant([cstr ident_ok [tvar1]; - cstr ident_error [tvar2]]); - type_variance = [Variance.covariant; Variance.covariant]} - and decl_dict = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_variance = [Variance.full]} - and decl_uncurried = - let tvar1, tvar2 = newgenvar(), newgenvar() in - {decl_abstr with - type_params = [tvar1; tvar2]; - type_arity = 2; - type_kind = Type_variant([cstr ident_ctor_uncurried [tvar1]]); - type_variance = [Variance.covariant; Variance.covariant]; - type_unboxed = Types.unboxed_true_default_false; - } - and decl_unknown = - let tvar = newgenvar () in - {decl_abstr with - type_params = []; - type_arity = 0; - type_kind = Type_variant ([ { - cd_id = ident_ctor_unknown; - cd_args = Cstr_tuple [tvar]; - cd_res = Some type_unknown; - cd_loc = Location.none; - cd_attributes = [] - }]); - type_unboxed = Types.unboxed_true_default_false - } - and decl_lazy_t = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_variance = [Variance.covariant]} - and decl_promise = - let tvar = newgenvar() in - {decl_abstr with - type_params = [tvar]; - type_arity = 1; - type_variance = [Variance.covariant]} - in - - let add_extension id l = - add_extension id - { ext_type_path = path_exn; - ext_type_params = []; - ext_args = Cstr_tuple l; - ext_ret_type = None; - ext_private = Asttypes.Public; - ext_loc = Location.none; - ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern"; - loc=Location.none}, - Parsetree.PStr[]] } - in - add_extension ident_match_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_extension ident_invalid_argument [type_string] ( - add_extension ident_js_error [type_unknown] ( - add_extension ident_failure [type_string] ( - add_extension ident_not_found [] ( - add_extension ident_end_of_file [] ( - add_extension ident_division_by_zero [] ( - add_extension ident_assert_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_extension ident_undefined_recursive_module - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_type ident_int64 decl_abstr ( - add_type ident_bigint decl_abstr ( - - add_type ident_lazy_t decl_lazy_t ( - add_type ident_option decl_option ( - add_type ident_result decl_result ( - add_type ident_dict decl_dict ( - add_type ident_list decl_list ( - add_type ident_array decl_array ( - add_type ident_exn decl_exn ( - add_type ident_unit decl_unit ( - add_type ident_bool decl_bool ( - add_type ident_float decl_abstr ( - add_type ident_unknown decl_unknown ( - add_type ident_uncurried decl_uncurried ( - add_type ident_string decl_abstr ( - add_type ident_int decl_abstr_imm ( - add_type ident_extension_constructor decl_abstr ( - add_type ident_floatarray decl_abstr ( - add_type ident_promise decl_promise ( - empty_env)))))))))))))))))))))))))))) - -let build_initial_env add_type add_exception empty_env = - let common = common_initial_env add_type add_exception empty_env in - let res = add_type ident_bytes decl_abstr common in - let decl_type_char = - {decl_abstr with - type_manifest = Some type_int; - type_private = Private} in - add_type ident_char decl_type_char res - - -let builtin_values = - List.map (fun id -> Ident.make_global id; (Ident.name id, id)) - [ident_match_failure; - ident_invalid_argument; - ident_failure; ident_js_error; ident_not_found; ident_end_of_file; - ident_division_by_zero; - ident_assert_failure; ident_undefined_recursive_module ] - -(* Start non-predef identifiers at 1000. This way, more predefs can - be defined in this file (above!) without breaking .cmi - compatibility. *) - -let _ = Ident.set_current_time 999 -let builtin_idents = List.rev !builtin_idents diff --git a/jscomp/ml/predef.mli b/jscomp/ml/predef.mli deleted file mode 100644 index a8049b5..0000000 --- a/jscomp/ml/predef.mli +++ /dev/null @@ -1,93 +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. *) -(* *) -(**************************************************************************) - -(* Predefined type constructors (with special typing rules in typecore) *) - -open Types - -val type_int: type_expr -val type_char: type_expr -val type_string: type_expr -val type_bytes: type_expr -val type_float: type_expr -val type_bool: type_expr -val type_unit: type_expr -val type_exn: type_expr -val type_array: type_expr -> type_expr -val type_list: type_expr -> type_expr -val type_option: type_expr -> type_expr -val type_result: type_expr -> type_expr -> type_expr -val type_dict: type_expr -> type_expr - -val type_int64: type_expr -val type_bigint: type_expr -val type_lazy_t: type_expr -> type_expr -val type_extension_constructor:type_expr -val type_floatarray:type_expr - -val path_int: Path.t -val path_char: Path.t -val path_string: Path.t -val path_bytes: Path.t -val path_float: Path.t -val path_bool: Path.t -val path_unit: Path.t -val path_exn: Path.t -val path_array: Path.t -val path_list: Path.t -val path_option: Path.t -val path_result: Path.t -val path_dict: Path.t - -val path_int64: Path.t -val path_bigint: Path.t -val path_lazy_t: Path.t -val path_extension_constructor: Path.t -val path_floatarray: Path.t -val path_promise: Path.t -val path_uncurried: Path.t - -val path_match_failure: Path.t -val path_assert_failure : Path.t -val path_undefined_recursive_module : Path.t - -(* To build the initial environment. Since there is a nasty mutual - recursion between predef and env, we break it by parameterizing - over Env.t, Env.add_type and Env.add_extension. *) - -val build_initial_env: - (Ident.t -> type_declaration -> 'a -> 'a) -> - (Ident.t -> extension_constructor -> 'a -> 'a) -> - 'a -> 'a - -(* To initialize linker tables *) - -val builtin_values: (string * Ident.t) list -val builtin_idents: (string * Ident.t) list - -(** All predefined exceptions, exposed as [Ident.t] for flambda (for - building value approximations). - The [Ident.t] for division by zero is also exported explicitly - so flambda can generate code to raise it. *) -val ident_division_by_zero: Ident.t -val all_predef_exns : Ident.t list - -type test = - | For_sure_yes - | For_sure_no - | NA - -val type_is_builtin_path_but_option : - Path.t -> test diff --git a/jscomp/ml/primitive.ml b/jscomp/ml/primitive.ml deleted file mode 100644 index 0fff0cc..0000000 --- a/jscomp/ml/primitive.ml +++ /dev/null @@ -1,100 +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. *) -(* *) -(**************************************************************************) - -(* Description of primitive functions *) - -open Misc -open Parsetree - -type boxed_integer = Pbigint | Pint32 | Pint64 - -type native_repr = - | Same_as_ocaml_repr - -type description = - { prim_name: string; (* Name of primitive or C function *) - prim_arity: int; (* Number of arguments *) - prim_alloc: bool; (* Does it allocates or raise? *) - prim_native_name: string; (* Name of C function for the nat. code gen. *) - prim_native_repr_args: native_repr list; - prim_native_repr_res: native_repr } - -let coerce : (description -> description -> bool) ref = - ref (fun - (p1 : description) (p2 : description) -> - p1 = p2 - ) - - - -let rec make_native_repr_args arity x = - if arity = 0 then - [] - else - x :: make_native_repr_args (arity - 1) x - -let simple ~name ~arity ~alloc = - {prim_name = name; - prim_arity = arity; - prim_alloc = alloc; - prim_native_name = ""; - prim_native_repr_args = make_native_repr_args arity Same_as_ocaml_repr; - prim_native_repr_res = Same_as_ocaml_repr} - -let make ~name ~alloc ~native_name ~native_repr_args ~native_repr_res = - {prim_name = name; - prim_arity = List.length native_repr_args; - prim_alloc = alloc; - prim_native_name = native_name; - prim_native_repr_args = native_repr_args; - prim_native_repr_res = native_repr_res} - -let parse_declaration valdecl ~native_repr_args ~native_repr_res = - let arity = List.length native_repr_args in - let name, native_name = - match valdecl.pval_prim with - | name :: name2 :: _ -> (name, name2) - | name :: _ -> (name, "") - | [] -> - fatal_error "Primitive.parse_declaration" - in - {prim_name = name; - prim_arity = arity; - prim_alloc = true; - prim_native_name = native_name; - prim_native_repr_args = native_repr_args; - prim_native_repr_res = native_repr_res} - -open Outcometree - -let print p osig_val_decl = - let prims = - if p.prim_native_name <> "" then - [p.prim_name; p.prim_native_name] - else - [p.prim_name] - in - { osig_val_decl with - oval_prims = prims; - oval_attributes = [] } - -let native_name p = - if p.prim_native_name <> "" - then p.prim_native_name - else p.prim_name - -let byte_name p = - p.prim_name - diff --git a/jscomp/ml/primitive.mli b/jscomp/ml/primitive.mli deleted file mode 100644 index c364c4c..0000000 --- a/jscomp/ml/primitive.mli +++ /dev/null @@ -1,65 +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. *) -(* *) -(**************************************************************************) - -(* Description of primitive functions *) - -type boxed_integer = Pbigint | Pint32 | Pint64 - -(* Representation of arguments/result for the native code version - of a primitive *) -type native_repr = - | Same_as_ocaml_repr - -type description = private - { prim_name: string; (* Name of primitive or C function *) - prim_arity: int; (* Number of arguments *) - prim_alloc: bool; (* Does it allocates or raise? *) - prim_native_name: string; (* Name of C function for the nat. code gen. *) - prim_native_repr_args: native_repr list; - prim_native_repr_res: native_repr } - -(* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *) - -val simple - : name:string - -> arity:int - -> alloc:bool - -> description - -val make - : name:string - -> alloc:bool - -> native_name:string - -> native_repr_args: native_repr list - -> native_repr_res: native_repr - -> description - -val parse_declaration - : Parsetree.value_description - -> native_repr_args:native_repr list - -> native_repr_res:native_repr - -> description - -val print - : description - -> Outcometree.out_val_decl - -> Outcometree.out_val_decl - -val native_name: description -> string -val byte_name: description -> string - - -val coerce : - (description -> description -> bool ) ref diff --git a/jscomp/ml/printast.ml b/jscomp/ml/printast.ml deleted file mode 100644 index eee7a90..0000000 --- a/jscomp/ml/printast.ml +++ /dev/null @@ -1,840 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 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. *) -(* *) -(**************************************************************************) - -open Asttypes;; -open Format;; -open Lexing;; -open Location;; -open Parsetree;; - -let fmt_position with_name f l = - let fname = if with_name then l.pos_fname else "" in - if l.pos_lnum = -1 - then fprintf f "%s[%d]" fname l.pos_cnum - else fprintf f "%s[%d,%d+%d]" fname l.pos_lnum l.pos_bol - (l.pos_cnum - l.pos_bol) -;; - -let fmt_location f loc = - if !Clflags.dump_location then ( - let p_2nd_name = loc.loc_start.pos_fname <> loc.loc_end.pos_fname in - fprintf f "(%a..%a)" (fmt_position true) loc.loc_start - (fmt_position p_2nd_name) loc.loc_end; - if loc.loc_ghost then fprintf f " ghost"; - ) -;; - -let rec fmt_longident_aux f x = - match x with - | Longident.Lident (s) -> fprintf f "%s" s; - | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; - | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; -;; - - -let fmt_longident_loc f (x : Longident.t loc) = - fprintf f "\"%a\" %a" fmt_longident_aux x.txt fmt_location x.loc; -;; - -let fmt_string_loc f (x : string loc) = - fprintf f "\"%s\" %a" x.txt fmt_location x.loc; -;; - -let fmt_char_option f = function - | None -> fprintf f "None" - | Some c -> fprintf f "Some %c" c - -let fmt_constant f x = - match x with - | Pconst_integer (i,m) -> fprintf f "PConst_int (%s,%a)" i fmt_char_option m; - | Pconst_char (c) -> fprintf f "PConst_char %02x" c; - | Pconst_string (s, None) -> fprintf f "PConst_string(%S,None)" s; - | Pconst_string (s, Some delim) -> - fprintf f "PConst_string (%S,Some %S)" s delim; - | Pconst_float (s,m) -> fprintf f "PConst_float (%s,%a)" s fmt_char_option m; -;; - -let fmt_mutable_flag f x = - match x with - | Immutable -> fprintf f "Immutable"; - | Mutable -> fprintf f "Mutable"; -;; - -let fmt_virtual_flag f x = - match x with - | Virtual -> fprintf f "Virtual"; - | Concrete -> fprintf f "Concrete"; -;; - -let fmt_override_flag f x = - match x with - | Override -> fprintf f "Override"; - | Fresh -> fprintf f "Fresh"; -;; - -let fmt_closed_flag f x = - match x with - | Closed -> fprintf f "Closed" - | Open -> fprintf f "Open" - -let fmt_rec_flag f x = - match x with - | Nonrecursive -> fprintf f "Nonrec"; - | Recursive -> fprintf f "Rec"; -;; - -let fmt_direction_flag f x = - match x with - | Upto -> fprintf f "Up"; - | Downto -> fprintf f "Down"; -;; - -let fmt_private_flag f x = - match x with - | Public -> fprintf f "Public"; - | Private -> fprintf f "Private"; -;; - -let line i f s (*...*) = - fprintf f "%s" (String.make ((2*i) mod 72) ' '); - fprintf f s (*...*) -;; - -let list i f ppf l = - match l with - | [] -> line i ppf "[]\n"; - | _ :: _ -> - line i ppf "[\n"; - List.iter (f (i+1) ppf) l; - line i ppf "]\n"; -;; - -let option i f ppf x = - match x with - | None -> line i ppf "None\n"; - | Some x -> - line i ppf "Some\n"; - f (i+1) ppf x; -;; - -let longident_loc i ppf li = line i ppf "%a\n" fmt_longident_loc li;; -let string i ppf s = line i ppf "\"%s\"\n" s;; -let string_loc i ppf s = line i ppf "%a\n" fmt_string_loc s;; -let arg_label i ppf = function - | Nolabel -> line i ppf "Nolabel\n" - | Optional s -> line i ppf "Optional \"%s\"\n" s - | Labelled s -> line i ppf "Labelled \"%s\"\n" s -;; - -let rec core_type i ppf x = - line i ppf "core_type %a\n" fmt_location x.ptyp_loc; - attributes i ppf x.ptyp_attributes; - let i = i+1 in - match x.ptyp_desc with - | Ptyp_any -> line i ppf "Ptyp_any\n"; - | Ptyp_var (s) -> line i ppf "Ptyp_var %s\n" s; - | Ptyp_arrow (l, ct1, ct2) -> - line i ppf "Ptyp_arrow\n"; - arg_label i ppf l; - core_type i ppf ct1; - core_type i ppf ct2; - | Ptyp_tuple l -> - line i ppf "Ptyp_tuple\n"; - list i core_type ppf l; - | Ptyp_constr (li, l) -> - line i ppf "Ptyp_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Ptyp_variant (l, closed, low) -> - line i ppf "Ptyp_variant closed=%a\n" fmt_closed_flag closed; - list i label_x_bool_x_core_type_list ppf l; - option i (fun i -> list i string) ppf low - | Ptyp_object (l, c) -> - line i ppf "Ptyp_object %a\n" fmt_closed_flag c; - let i = i + 1 in - List.iter ( - function - | Otag (l, attrs, t) -> - line i ppf "method %s\n" l.txt; - attributes i ppf attrs; - core_type (i + 1) ppf t - | Oinherit ct -> - line i ppf "Oinherit\n"; - core_type (i + 1) ppf ct - ) l - | Ptyp_class (li, l) -> - line i ppf "Ptyp_class %a\n" fmt_longident_loc li; - list i core_type ppf l - | Ptyp_alias (ct, s) -> - line i ppf "Ptyp_alias \"%s\"\n" s; - core_type i ppf ct; - | Ptyp_poly (sl, ct) -> - line i ppf "Ptyp_poly%a\n" - (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x.txt)) sl; - core_type i ppf ct; - | Ptyp_package (s, l) -> - line i ppf "Ptyp_package %a\n" fmt_longident_loc s; - list i package_with ppf l; - | Ptyp_extension (s, arg) -> - line i ppf "Ptyp_extension \"%s\"\n" s.txt; - payload i ppf arg - -and package_with i ppf (s, t) = - line i ppf "with type %a\n" fmt_longident_loc s; - core_type i ppf t - -and pattern i ppf x = - line i ppf "pattern %a\n" fmt_location x.ppat_loc; - attributes i ppf x.ppat_attributes; - let i = i+1 in - match x.ppat_desc with - | Ppat_any -> line i ppf "Ppat_any\n"; - | Ppat_var (s) -> line i ppf "Ppat_var %a\n" fmt_string_loc s; - | Ppat_alias (p, s) -> - line i ppf "Ppat_alias %a\n" fmt_string_loc s; - pattern i ppf p; - | Ppat_constant (c) -> line i ppf "Ppat_constant %a\n" fmt_constant c; - | Ppat_interval (c1, c2) -> - line i ppf "Ppat_interval %a..%a\n" fmt_constant c1 fmt_constant c2; - | Ppat_tuple (l) -> - line i ppf "Ppat_tuple\n"; - list i pattern ppf l; - | Ppat_construct (li, po) -> - line i ppf "Ppat_construct %a\n" fmt_longident_loc li; - option i pattern ppf po; - | Ppat_variant (l, po) -> - line i ppf "Ppat_variant \"%s\"\n" l; - option i pattern ppf po; - | Ppat_record (l, c) -> - line i ppf "Ppat_record %a\n" fmt_closed_flag c; - list i longident_x_pattern ppf l; - | Ppat_array (l) -> - line i ppf "Ppat_array\n"; - list i pattern ppf l; - | Ppat_or (p1, p2) -> - line i ppf "Ppat_or\n"; - pattern i ppf p1; - pattern i ppf p2; - | Ppat_lazy p -> - line i ppf "Ppat_lazy\n"; - pattern i ppf p; - | Ppat_constraint (p, ct) -> - line i ppf "Ppat_constraint\n"; - pattern i ppf p; - core_type i ppf ct; - | Ppat_type (li) -> - line i ppf "Ppat_type\n"; - longident_loc i ppf li - | Ppat_unpack s -> - line i ppf "Ppat_unpack %a\n" fmt_string_loc s; - | Ppat_exception p -> - line i ppf "Ppat_exception\n"; - pattern i ppf p - | Ppat_open (m,p) -> - line i ppf "Ppat_open \"%a\"\n" fmt_longident_loc m; - pattern i ppf p - | Ppat_extension (s, arg) -> - line i ppf "Ppat_extension \"%s\"\n" s.txt; - payload i ppf arg - -and expression i ppf x = - line i ppf "expression %a\n" fmt_location x.pexp_loc; - attributes i ppf x.pexp_attributes; - let i = i+1 in - match x.pexp_desc with - | Pexp_ident (li) -> line i ppf "Pexp_ident %a\n" fmt_longident_loc li; - | Pexp_constant (c) -> line i ppf "Pexp_constant %a\n" fmt_constant c; - | Pexp_let (rf, l, e) -> - line i ppf "Pexp_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - expression i ppf e; - | Pexp_function l -> - line i ppf "Pexp_function\n"; - list i case ppf l; - | Pexp_fun (l, eo, p, e) -> - line i ppf "Pexp_fun\n"; - arg_label i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e; - | Pexp_apply (e, l) -> - line i ppf "Pexp_apply\n"; - expression i ppf e; - list i label_x_expression ppf l; - | Pexp_match (e, l) -> - line i ppf "Pexp_match\n"; - expression i ppf e; - list i case ppf l; - | Pexp_try (e, l) -> - line i ppf "Pexp_try\n"; - expression i ppf e; - list i case ppf l; - | Pexp_tuple (l) -> - line i ppf "Pexp_tuple\n"; - list i expression ppf l; - | Pexp_construct (li, eo) -> - line i ppf "Pexp_construct %a\n" fmt_longident_loc li; - option i expression ppf eo; - | Pexp_variant (l, eo) -> - line i ppf "Pexp_variant \"%s\"\n" l; - option i expression ppf eo; - | Pexp_record (l, eo) -> - line i ppf "Pexp_record\n"; - list i longident_x_expression ppf l; - option i expression ppf eo; - | Pexp_field (e, li) -> - line i ppf "Pexp_field\n"; - expression i ppf e; - longident_loc i ppf li; - | Pexp_setfield (e1, li, e2) -> - line i ppf "Pexp_setfield\n"; - expression i ppf e1; - longident_loc i ppf li; - expression i ppf e2; - | Pexp_array (l) -> - line i ppf "Pexp_array\n"; - list i expression ppf l; - | Pexp_ifthenelse (e1, e2, eo) -> - line i ppf "Pexp_ifthenelse\n"; - expression i ppf e1; - expression i ppf e2; - option i expression ppf eo; - | Pexp_sequence (e1, e2) -> - line i ppf "Pexp_sequence\n"; - expression i ppf e1; - expression i ppf e2; - | Pexp_while (e1, e2) -> - line i ppf "Pexp_while\n"; - expression i ppf e1; - expression i ppf e2; - | Pexp_for (p, e1, e2, df, e3) -> - line i ppf "Pexp_for %a\n" fmt_direction_flag df; - pattern i ppf p; - expression i ppf e1; - expression i ppf e2; - expression i ppf e3; - | Pexp_constraint (e, ct) -> - line i ppf "Pexp_constraint\n"; - expression i ppf e; - core_type i ppf ct; - | Pexp_coerce (e, cto1, cto2) -> - line i ppf "Pexp_coerce\n"; - expression i ppf e; - option i core_type ppf cto1; - core_type i ppf cto2; - | Pexp_send (e, s) -> - line i ppf "Pexp_send \"%s\"\n" s.txt; - expression i ppf e; - | Pexp_new (li) -> line i ppf "Pexp_new %a\n" fmt_longident_loc li; - | Pexp_setinstvar (s, e) -> - line i ppf "Pexp_setinstvar %a\n" fmt_string_loc s; - expression i ppf e; - | Pexp_override (l) -> - line i ppf "Pexp_override\n"; - list i string_x_expression ppf l; - | Pexp_letmodule (s, me, e) -> - line i ppf "Pexp_letmodule %a\n" fmt_string_loc s; - module_expr i ppf me; - expression i ppf e; - | Pexp_letexception (cd, e) -> - line i ppf "Pexp_letexception\n"; - extension_constructor i ppf cd; - expression i ppf e; - | Pexp_assert (e) -> - line i ppf "Pexp_assert\n"; - expression i ppf e; - | Pexp_lazy (e) -> - line i ppf "Pexp_lazy\n"; - expression i ppf e; - | Pexp_poly (e, cto) -> - line i ppf "Pexp_poly\n"; - expression i ppf e; - option i core_type ppf cto; - | Pexp_object s -> - line i ppf "Pexp_object\n"; - class_structure i ppf s - | Pexp_newtype (s, e) -> - line i ppf "Pexp_newtype \"%s\"\n" s.txt; - expression i ppf e - | Pexp_pack me -> - line i ppf "Pexp_pack\n"; - module_expr i ppf me - | Pexp_open (ovf, m, e) -> - line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; - expression i ppf e - | Pexp_extension (s, arg) -> - line i ppf "Pexp_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pexp_unreachable -> - line i ppf "Pexp_unreachable" - -and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_string_loc - x.pval_name fmt_location x.pval_loc; - attributes i ppf x.pval_attributes; - core_type (i+1) ppf x.pval_type; - list (i+1) string ppf x.pval_prim - -and type_parameter i ppf (x, _variance) = core_type i ppf x - -and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_string_loc x.ptype_name - fmt_location x.ptype_loc; - attributes i ppf x.ptype_attributes; - let i = i+1 in - line i ppf "ptype_params =\n"; - list (i+1) type_parameter ppf x.ptype_params; - line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; - line i ppf "ptype_kind =\n"; - type_kind (i+1) ppf x.ptype_kind; - line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; - line i ppf "ptype_manifest =\n"; - option (i+1) core_type ppf x.ptype_manifest - -and attributes i ppf l = - let i = i + 1 in - List.iter - (fun (s, arg) -> - line i ppf "attribute %a \"%s\"\n" fmt_location (s: _ Asttypes.loc).loc s.txt; - payload (i + 1) ppf arg; - ) - l - -and payload i ppf = function - | PStr x -> structure i ppf x - | PSig x -> signature i ppf x - | PTyp x -> core_type i ppf x - | PPat (x, None) -> pattern i ppf x - | PPat (x, Some g) -> - pattern i ppf x; - line i ppf "\n"; - expression (i + 1) ppf g - - -and type_kind i ppf x = - match x with - | Ptype_abstract -> - line i ppf "Ptype_abstract\n" - | Ptype_variant l -> - line i ppf "Ptype_variant\n"; - list (i+1) constructor_decl ppf l; - | Ptype_record l -> - line i ppf "Ptype_record\n"; - list (i+1) label_decl ppf l; - | Ptype_open -> - line i ppf "Ptype_open\n"; - -and type_extension i ppf x = - line i ppf "type_extension\n"; - attributes i ppf x.ptyext_attributes; - let i = i+1 in - line i ppf "ptyext_path = %a\n" fmt_longident_loc x.ptyext_path; - line i ppf "ptyext_params =\n"; - list (i+1) type_parameter ppf x.ptyext_params; - line i ppf "ptyext_constructors =\n"; - list (i+1) extension_constructor ppf x.ptyext_constructors; - line i ppf "ptyext_private = %a\n" fmt_private_flag x.ptyext_private; - -and extension_constructor i ppf x = - line i ppf "extension_constructor %a\n" fmt_location x.pext_loc; - attributes i ppf x.pext_attributes; - let i = i + 1 in - line i ppf "pext_name = \"%s\"\n" x.pext_name.txt; - line i ppf "pext_kind =\n"; - extension_constructor_kind (i + 1) ppf x.pext_kind; - -and extension_constructor_kind i ppf x = - match x with - Pext_decl(a, r) -> - line i ppf "Pext_decl\n"; - constructor_arguments (i+1) ppf a; - option (i+1) core_type ppf r; - | Pext_rebind li -> - line i ppf "Pext_rebind\n"; - line (i+1) ppf "%a\n" fmt_longident_loc li; - -and class_type i ppf x = - line i ppf "class_type %a\n" fmt_location x.pcty_loc; - attributes i ppf x.pcty_attributes; - let i = i+1 in - match x.pcty_desc with - | Pcty_constr (li, l) -> - line i ppf "Pcty_constr %a\n" fmt_longident_loc li; - list i core_type ppf l; - | Pcty_signature (cs) -> - line i ppf "Pcty_signature\n"; - class_signature i ppf cs; - | Pcty_arrow (l, co, cl) -> - line i ppf "Pcty_arrow\n"; - arg_label i ppf l; - core_type i ppf co; - class_type i ppf cl; - | Pcty_extension (s, arg) -> - line i ppf "Pcty_extension \"%s\"\n" s.txt; - payload i ppf arg - | Pcty_open (ovf, m, e) -> - line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; - class_type i ppf e - -and class_signature i ppf cs = - line i ppf "class_signature\n"; - core_type (i+1) ppf cs.pcsig_self; - list (i+1) class_type_field ppf cs.pcsig_fields; - -and class_type_field i ppf x = - line i ppf "class_type_field %a\n" fmt_location x.pctf_loc; - let i = i+1 in - attributes i ppf x.pctf_attributes; - match x.pctf_desc with - | Pctf_inherit (ct) -> - line i ppf "Pctf_inherit\n"; - class_type i ppf ct; - | Pctf_val (s, mf, vf, ct) -> - line i ppf "Pctf_val \"%s\" %a %a\n" s.txt fmt_mutable_flag mf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Pctf_method (s, pf, vf, ct) -> - line i ppf "Pctf_method \"%s\" %a %a\n" s.txt fmt_private_flag pf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Pctf_constraint (ct1, ct2) -> - line i ppf "Pctf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Pctf_attribute (s, arg) -> - line i ppf "Pctf_attribute \"%s\"\n" s.txt; - payload i ppf arg - | Pctf_extension (s, arg) -> - line i ppf "Pctf_extension \"%s\"\n" s.txt; - payload i ppf arg - - -and class_type_declaration i ppf x = - line i ppf "class_type_declaration %a\n" fmt_location x.pci_loc; - attributes i ppf x.pci_attributes; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.pci_params; - line i ppf "pci_name = %a\n" fmt_string_loc x.pci_name; - line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.pci_expr; - -and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = - line i ppf "class_structure\n"; - pattern (i+1) ppf p; - list (i+1) class_field ppf l; - -and class_field i ppf x = - line i ppf "class_field %a\n" fmt_location x.pcf_loc; - let i = i + 1 in - attributes i ppf x.pcf_attributes; - match x.pcf_desc with - | Pcf_inherit () -> () - | Pcf_val (s, mf, k) -> - line i ppf "Pcf_val %a\n" fmt_mutable_flag mf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k - | Pcf_method (s, pf, k) -> - line i ppf "Pcf_method %a\n" fmt_private_flag pf; - line (i+1) ppf "%a\n" fmt_string_loc s; - class_field_kind (i+1) ppf k - | Pcf_constraint (ct1, ct2) -> - line i ppf "Pcf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Pcf_initializer (e) -> - line i ppf "Pcf_initializer\n"; - expression (i+1) ppf e; - | Pcf_attribute (s, arg) -> - line i ppf "Pcf_attribute \"%s\"\n" s.txt; - payload i ppf arg - | Pcf_extension (s, arg) -> - line i ppf "Pcf_extension \"%s\"\n" s.txt; - payload i ppf arg - -and class_field_kind i ppf = function - | Cfk_concrete (o, e) -> - line i ppf "Concrete %a\n" fmt_override_flag o; - expression i ppf e - | Cfk_virtual t -> - line i ppf "Virtual\n"; - core_type i ppf t - -and module_type i ppf x = - line i ppf "module_type %a\n" fmt_location x.pmty_loc; - attributes i ppf x.pmty_attributes; - let i = i+1 in - match x.pmty_desc with - | Pmty_ident li -> line i ppf "Pmty_ident %a\n" fmt_longident_loc li; - | Pmty_alias li -> line i ppf "Pmty_alias %a\n" fmt_longident_loc li; - | Pmty_signature (s) -> - line i ppf "Pmty_signature\n"; - signature i ppf s; - | Pmty_functor (s, mt1, mt2) -> - line i ppf "Pmty_functor %a\n" fmt_string_loc s; - Misc.may (module_type i ppf) mt1; - module_type i ppf mt2; - | Pmty_with (mt, l) -> - line i ppf "Pmty_with\n"; - module_type i ppf mt; - list i with_constraint ppf l; - | Pmty_typeof m -> - line i ppf "Pmty_typeof\n"; - module_expr i ppf m; - | Pmty_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg - -and signature i ppf x = list i signature_item ppf x - -and signature_item i ppf x = - line i ppf "signature_item %a\n" fmt_location x.psig_loc; - let i = i+1 in - match x.psig_desc with - | Psig_value vd -> - line i ppf "Psig_value\n"; - value_description i ppf vd; - | Psig_type (rf, l) -> - line i ppf "Psig_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Psig_typext te -> - line i ppf "Psig_typext\n"; - type_extension i ppf te - | Psig_exception ext -> - line i ppf "Psig_exception\n"; - extension_constructor i ppf ext; - | Psig_module pmd -> - line i ppf "Psig_module %a\n" fmt_string_loc pmd.pmd_name; - attributes i ppf pmd.pmd_attributes; - module_type i ppf pmd.pmd_type - | Psig_recmodule decls -> - line i ppf "Psig_recmodule\n"; - list i module_declaration ppf decls; - | Psig_modtype x -> - line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Psig_open od -> - line i ppf "Psig_open %a %a\n" - fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; - attributes i ppf od.popen_attributes - | Psig_include incl -> - line i ppf "Psig_include\n"; - module_type i ppf incl.pincl_mod; - attributes i ppf incl.pincl_attributes - | Psig_class () -> () - | Psig_class_type (l) -> - line i ppf "Psig_class_type\n"; - list i class_type_declaration ppf l; - | Psig_extension ((s, arg), attrs) -> - line i ppf "Psig_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg - | Psig_attribute (s, arg) -> - line i ppf "Psig_attribute \"%s\"\n" s.txt; - payload i ppf arg - -and modtype_declaration i ppf = function - | None -> line i ppf "#abstract" - | Some mt -> module_type (i+1) ppf mt - -and with_constraint i ppf x = - match x with - | Pwith_type (lid, td) -> - line i ppf "Pwith_type %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; - | Pwith_typesubst (lid, td) -> - line i ppf "Pwith_typesubst %a\n" fmt_longident_loc lid; - type_declaration (i+1) ppf td; - | Pwith_module (lid1, lid2) -> - line i ppf "Pwith_module %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; - | Pwith_modsubst (lid1, lid2) -> - line i ppf "Pwith_modsubst %a = %a\n" - fmt_longident_loc lid1 - fmt_longident_loc lid2; - -and module_expr i ppf x = - line i ppf "module_expr %a\n" fmt_location x.pmod_loc; - attributes i ppf x.pmod_attributes; - let i = i+1 in - match x.pmod_desc with - | Pmod_ident (li) -> line i ppf "Pmod_ident %a\n" fmt_longident_loc li; - | Pmod_structure (s) -> - line i ppf "Pmod_structure\n"; - structure i ppf s; - | Pmod_functor (s, mt, me) -> - line i ppf "Pmod_functor %a\n" fmt_string_loc s; - Misc.may (module_type i ppf) mt; - module_expr i ppf me; - | Pmod_apply (me1, me2) -> - line i ppf "Pmod_apply\n"; - module_expr i ppf me1; - module_expr i ppf me2; - | Pmod_constraint (me, mt) -> - line i ppf "Pmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; - | Pmod_unpack (e) -> - line i ppf "Pmod_unpack\n"; - expression i ppf e; - | Pmod_extension (s, arg) -> - line i ppf "Pmod_extension \"%s\"\n" s.txt; - payload i ppf arg - -and structure i ppf x = list i structure_item ppf x - -and structure_item i ppf x = - line i ppf "structure_item %a\n" fmt_location x.pstr_loc; - let i = i+1 in - match x.pstr_desc with - | Pstr_eval (e, attrs) -> - line i ppf "Pstr_eval\n"; - attributes i ppf attrs; - expression i ppf e; - | Pstr_value (rf, l) -> - line i ppf "Pstr_value %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - | Pstr_primitive vd -> - line i ppf "Pstr_primitive\n"; - value_description i ppf vd; - | Pstr_type (rf, l) -> - line i ppf "Pstr_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Pstr_typext te -> - line i ppf "Pstr_typext\n"; - type_extension i ppf te - | Pstr_exception ext -> - line i ppf "Pstr_exception\n"; - extension_constructor i ppf ext; - | Pstr_module x -> - line i ppf "Pstr_module\n"; - module_binding i ppf x - | Pstr_recmodule bindings -> - line i ppf "Pstr_recmodule\n"; - list i module_binding ppf bindings; - | Pstr_modtype x -> - line i ppf "Pstr_modtype %a\n" fmt_string_loc x.pmtd_name; - attributes i ppf x.pmtd_attributes; - modtype_declaration i ppf x.pmtd_type - | Pstr_open od -> - line i ppf "Pstr_open %a %a\n" - fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; - attributes i ppf od.popen_attributes - | Pstr_class () -> () - | Pstr_class_type (l) -> - line i ppf "Pstr_class_type\n"; - list i class_type_declaration ppf l; - | Pstr_include incl -> - line i ppf "Pstr_include"; - attributes i ppf incl.pincl_attributes; - module_expr i ppf incl.pincl_mod - | Pstr_extension ((s, arg), attrs) -> - line i ppf "Pstr_extension \"%s\"\n" s.txt; - attributes i ppf attrs; - payload i ppf arg - | Pstr_attribute (s, arg) -> - line i ppf "Pstr_attribute \"%s\"\n" s.txt; - payload i ppf arg - -and module_declaration i ppf pmd = - string_loc i ppf pmd.pmd_name; - attributes i ppf pmd.pmd_attributes; - module_type (i+1) ppf pmd.pmd_type; - -and module_binding i ppf x = - string_loc i ppf x.pmb_name; - attributes i ppf x.pmb_attributes; - module_expr (i+1) ppf x.pmb_expr - -and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = - line i ppf " %a\n" fmt_location l; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - -and constructor_decl i ppf - {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = - line i ppf "%a\n" fmt_location pcd_loc; - line (i+1) ppf "%a\n" fmt_string_loc pcd_name; - attributes i ppf pcd_attributes; - constructor_arguments (i+1) ppf pcd_args; - option (i+1) core_type ppf pcd_res - -and constructor_arguments i ppf = function - | Pcstr_tuple l -> list i core_type ppf l - | Pcstr_record l -> list i label_decl ppf l - -and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= - line i ppf "%a\n" fmt_location pld_loc; - attributes i ppf pld_attributes; - line (i+1) ppf "%a\n" fmt_mutable_flag pld_mutable; - line (i+1) ppf "%a" fmt_string_loc pld_name; - core_type (i+1) ppf pld_type - -and longident_x_pattern i ppf (li, p) = - line i ppf "%a\n" fmt_longident_loc li; - pattern (i+1) ppf p; - -and case i ppf {pc_lhs; pc_guard; pc_rhs} = - line i ppf "\n"; - pattern (i+1) ppf pc_lhs; - begin match pc_guard with - | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf pc_rhs; - -and value_binding i ppf x = - line i ppf "\n"; - attributes (i+1) ppf x.pvb_attributes; - pattern (i+1) ppf x.pvb_pat; - expression (i+1) ppf x.pvb_expr - -and string_x_expression i ppf (s, e) = - line i ppf " %a\n" fmt_string_loc s; - expression (i+1) ppf e; - -and longident_x_expression i ppf (li, e) = - line i ppf "%a\n" fmt_longident_loc li; - expression (i+1) ppf e; - -and label_x_expression i ppf (l,e) = - line i ppf "\n"; - arg_label i ppf l; - expression (i+1) ppf e; - -and label_x_bool_x_core_type_list i ppf x = - match x with - Rtag (l, attrs, b, ctl) -> - line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); - attributes (i+1) ppf attrs; - list (i+1) core_type ppf ctl - | Rinherit (ct) -> - line i ppf "Rinherit\n"; - core_type (i+1) ppf ct -;; - - -let interface ppf x = list 0 signature_item ppf x;; - -let implementation ppf x = list 0 structure_item ppf x;; - diff --git a/jscomp/ml/printlambda.ml b/jscomp/ml/printlambda.ml deleted file mode 100644 index ee67f25..0000000 --- a/jscomp/ml/printlambda.ml +++ /dev/null @@ -1,496 +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. *) -(* *) -(**************************************************************************) - -open Format -open Asttypes -open Primitive -open Lambda - - -let rec struct_const ppf = function - | Const_base(Const_int n) -> fprintf ppf "%i" n - | Const_base(Const_char i) -> fprintf ppf "%s" (Pprintast.string_of_int_as_char i) - | Const_base(Const_string (s, _)) -> fprintf ppf "%S" s - | Const_immstring s -> fprintf ppf "#%S" s - | Const_base(Const_float f) -> fprintf ppf "%s" f - | Const_base(Const_int32 n) -> fprintf ppf "%lil" n - | Const_base(Const_int64 n) -> fprintf ppf "%LiL" n - | Const_base(Const_bigint (sign, n)) -> fprintf ppf "%sn" (Bigint_utils.to_string sign n) - | Const_pointer (n,_) -> fprintf ppf "%ia" n - | Const_block(tag_info, []) -> - let tag = Lambda.tag_of_tag_info tag_info in - fprintf ppf "[%i]" tag - | Const_block(tag_info,sc1::scl) -> - let tag = Lambda.tag_of_tag_info tag_info in - let sconsts ppf scl = - List.iter (fun sc -> fprintf ppf "@ %a" struct_const sc) scl in - fprintf ppf "@[<1>[%i:@ @[%a%a@]]@]" tag struct_const sc1 sconsts scl - | Const_float_array [] -> - fprintf ppf "[| |]" - | Const_float_array (f1 :: fl) -> - let floats ppf fl = - List.iter (fun f -> fprintf ppf "@ %s" f) fl in - fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl - - | Const_false -> fprintf ppf "false" - | Const_true -> fprintf ppf "true" -let boxed_integer_name = function - | Pbigint -> "bigint" - | Pint32 -> "int32" - | Pint64 -> "int64" - -let value_kind = function - | Pgenval -> "" - -(* let field_kind = function - | Pgenval -> "*" - | Pintval -> "int" - | Pfloatval -> "float" - | Pboxedintval bi -> boxed_integer_name bi *) - -let print_boxed_integer_conversion ppf bi1 bi2 = - fprintf ppf "%s_of_%s" (boxed_integer_name bi2) (boxed_integer_name bi1) - -let boxed_integer_mark name = function - | Pbigint -> Printf.sprintf "BigInt.%s" name - | Pint32 -> Printf.sprintf "Int32.%s" name - | Pint64 -> Printf.sprintf "Int64.%s" name - -let print_boxed_integer name ppf bi = - fprintf ppf "%s" (boxed_integer_mark name bi);; - - - - -let string_of_loc_kind = function - | Loc_FILE -> "loc_FILE" - | Loc_LINE -> "loc_LINE" - | Loc_MODULE -> "loc_MODULE" - | Loc_POS -> "loc_POS" - | Loc_LOC -> "loc_LOC" - -(* let block_shape ppf shape = match shape with - | None | Some [] -> () - | Some l when List.for_all ((=) Pgenval) l -> () - | Some [elt] -> - Format.fprintf ppf " (%s)" (field_kind elt) - | Some (h :: t) -> - Format.fprintf ppf " (%s" (field_kind h); - List.iter (fun elt -> - Format.fprintf ppf ",%s" (field_kind elt)) - t; - Format.fprintf ppf ")" *) - - -let str_of_field_info (fld_info : Lambda.field_dbg_info)= - match fld_info with - | (Fld_module {name } | Fld_record {name} | Fld_record_inline {name} | Fld_record_extension {name}) - -> name - | Fld_tuple -> "[]" - | Fld_poly_var_tag->"`" - | Fld_poly_var_content -> "#" - | Fld_extension -> "ext" - | Fld_variant -> "var" - | Fld_cons -> "cons" - | Fld_array -> "[||]" -let print_taginfo ppf = function - | Blk_extension -> fprintf ppf "ext" - | Blk_record_ext {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) - | Blk_tuple -> fprintf ppf "tuple" - | Blk_constructor {name ;num_nonconst} -> fprintf ppf "%s/%i" name num_nonconst - | Blk_poly_var name -> fprintf ppf "`%s" name - | Blk_record {fields = ss} -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) - | Blk_module ss -> fprintf ppf "[%s]" (String.concat ";" ss) - | Blk_some -> fprintf ppf "some" - | Blk_some_not_nested -> fprintf ppf "some_not_nested" - | Blk_lazy_general -> fprintf ppf "lazy_general" - | Blk_module_export _ -> fprintf ppf "module/exports" - | Blk_record_inlined {fields = ss } - -> fprintf ppf "[%s]" (String.concat ";" (Array.to_list ss) ) - -let primitive ppf = function - | Puncurried_apply -> fprintf ppf "@app" - | Pidentity -> fprintf ppf "id" - | Pbytes_to_string -> fprintf ppf "bytes_to_string" - | Pignore -> fprintf ppf "ignore" - | Prevapply -> fprintf ppf "revapply" - | Pdirapply -> fprintf ppf "dirapply" - | Ploc kind -> fprintf ppf "%s" (string_of_loc_kind kind) - | Pgetglobal id -> fprintf ppf "global %a" Ident.print id - | Pmakeblock(taginfo) -> - fprintf ppf "makeblock %a" print_taginfo taginfo - | Pfield (n, fld) -> fprintf ppf "field:%s/%i" (str_of_field_info fld) n - | Psetfield(n, _) -> - fprintf ppf "setfield %i" n - | Pduprecord -> fprintf ppf "duprecord" - | Plazyforce -> fprintf ppf "force" - | Pccall p -> fprintf ppf "%s" p.prim_name - | Praise k -> fprintf ppf "%s" (Lambda.raise_kind k) - | Psequand -> fprintf ppf "&&" - | Psequor -> fprintf ppf "||" - | Pnot -> fprintf ppf "not" - | Pnegint -> fprintf ppf "~" - | Paddint -> fprintf ppf "+" - | Psubint -> fprintf ppf "-" - | Pmulint -> fprintf ppf "*" - | Pdivint Safe -> fprintf ppf "/" - | Pdivint Unsafe -> fprintf ppf "/u" - | Pmodint Safe -> fprintf ppf "mod" - | Pmodint Unsafe -> fprintf ppf "mod_unsafe" - | Pandint -> fprintf ppf "and" - | Porint -> fprintf ppf "or" - | Pxorint -> fprintf ppf "xor" - | Plslint -> fprintf ppf "lsl" - | Plsrint -> fprintf ppf "lsr" - | Pasrint -> fprintf ppf "asr" - | Pintcomp(Ceq) -> fprintf ppf "==" - | Pintcomp(Cneq) -> fprintf ppf "!=" - | Pintcomp(Clt) -> fprintf ppf "<" - | Pintcomp(Cle) -> fprintf ppf "<=" - | Pintcomp(Cgt) -> fprintf ppf ">" - | Pintcomp(Cge) -> fprintf ppf ">=" - | Poffsetint n -> fprintf ppf "%i+" n - | Poffsetref n -> fprintf ppf "+:=%i"n - | Pintoffloat -> fprintf ppf "int_of_float" - | Pfloatofint -> fprintf ppf "float_of_int" - | Pnegfloat -> fprintf ppf "~." - | Pabsfloat -> fprintf ppf "abs." - | Paddfloat -> fprintf ppf "+." - | Psubfloat -> fprintf ppf "-." - | Pmulfloat -> fprintf ppf "*." - | Pdivfloat -> fprintf ppf "/." - | Pfloatcomp(Ceq) -> fprintf ppf "==." - | Pfloatcomp(Cneq) -> fprintf ppf "!=." - | Pfloatcomp(Clt) -> fprintf ppf "<." - | Pfloatcomp(Cle) -> fprintf ppf "<=." - | Pfloatcomp(Cgt) -> fprintf ppf ">." - | Pfloatcomp(Cge) -> fprintf ppf ">=." - | Pnegbigint -> fprintf ppf "~" - | Paddbigint -> fprintf ppf "+" - | Psubbigint -> fprintf ppf "-" - | Pmulbigint -> fprintf ppf "*" - | Ppowbigint -> fprintf ppf "**" - | Pandbigint -> fprintf ppf "and" - | Porbigint -> fprintf ppf "or" - | Pxorbigint -> fprintf ppf "xor" - | Plslbigint -> fprintf ppf "lsl" - | Pasrbigint -> fprintf ppf "asr" - | Pdivbigint -> fprintf ppf "/" - | Pmodbigint -> fprintf ppf "mod" - | Pbigintcomp(Ceq) -> fprintf ppf "==," - | Pbigintcomp(Cneq) -> fprintf ppf "!=," - | Pbigintcomp(Clt) -> fprintf ppf "<," - | Pbigintcomp(Cle) -> fprintf ppf "<=," - | Pbigintcomp(Cgt) -> fprintf ppf ">," - | Pbigintcomp(Cge) -> fprintf ppf ">=," - | Pstringlength -> fprintf ppf "string.length" - | Pstringrefu -> fprintf ppf "string.unsafe_get" - | Pstringrefs -> fprintf ppf "string.get" - | Pbyteslength -> fprintf ppf "bytes.length" - | Pbytesrefu -> fprintf ppf "bytes.unsafe_get" - | Pbytessetu -> fprintf ppf "bytes.unsafe_set" - | Pbytesrefs -> fprintf ppf "bytes.get" - | Pbytessets -> fprintf ppf "bytes.set" - - | Parraylength -> fprintf ppf "array.length" - | Pmakearray Mutable -> fprintf ppf "makearray" - | Pmakearray Immutable -> fprintf ppf "makearray_imm" - | Parrayrefu -> fprintf ppf "array.unsafe_get" - | Parraysetu -> fprintf ppf "array.unsafe_set" - | Parrayrefs -> fprintf ppf "array.get" - | Parraysets -> fprintf ppf "array.set" - | Pctconst c -> - let const_name = match c with - | Big_endian -> "big_endian" - | Word_size -> "word_size" - | Int_size -> "int_size" - | Max_wosize -> "max_wosize" - | Ostype_unix -> "ostype_unix" - | Ostype_win32 -> "ostype_win32" - | Ostype_cygwin -> "ostype_cygwin" - | Backend_type -> "backend_type" in - fprintf ppf "sys.constant_%s" const_name - | Pisint -> fprintf ppf "isint" - | Pisout -> fprintf ppf "isout" - | Pbintofint bi -> print_boxed_integer "of_int" ppf bi - | Pintofbint bi -> print_boxed_integer "to_int" ppf bi - | Pcvtbint (bi1, bi2) -> print_boxed_integer_conversion ppf bi1 bi2 - | Pnegbint bi -> print_boxed_integer "neg" ppf bi - | Paddbint bi -> print_boxed_integer "add" ppf bi - | Psubbint bi -> print_boxed_integer "sub" ppf bi - | Pmulbint bi -> print_boxed_integer "mul" ppf bi - | Pdivbint { size = bi; is_safe = Safe } -> - print_boxed_integer "div" ppf bi - | Pdivbint { size = bi; is_safe = Unsafe } -> - print_boxed_integer "div_unsafe" ppf bi - | Pmodbint { size = bi; is_safe = Safe } -> - print_boxed_integer "mod" ppf bi - | Pmodbint { size = bi; is_safe = Unsafe } -> - print_boxed_integer "mod_unsafe" ppf bi - | Pandbint bi -> print_boxed_integer "and" ppf bi - | Porbint bi -> print_boxed_integer "or" ppf bi - | Pxorbint bi -> print_boxed_integer "xor" ppf bi - | Plslbint bi -> print_boxed_integer "lsl" ppf bi - | Plsrbint bi -> print_boxed_integer "lsr" ppf bi - | Pasrbint bi -> print_boxed_integer "asr" ppf bi - | Pbintcomp(bi, Ceq) -> print_boxed_integer "==" ppf bi - | Pbintcomp(bi, Cneq) -> print_boxed_integer "!=" ppf bi - | Pbintcomp(bi, Clt) -> print_boxed_integer "<" ppf bi - | Pbintcomp(bi, Cgt) -> print_boxed_integer ">" ppf bi - | Pbintcomp(bi, Cle) -> print_boxed_integer "<=" ppf bi - | Pbintcomp(bi, Cge) -> print_boxed_integer ">=" ppf bi - | Popaque -> fprintf ppf "opaque" - | Pcreate_extension s -> fprintf ppf "extension[%s]" s -let name_of_primitive = function - | Puncurried_apply -> "Puncurried_apply" - | Pidentity -> "Pidentity" - | Pbytes_to_string -> "Pbytes_to_string" - | Pignore -> "Pignore" - | Prevapply -> "Prevapply" - | Pdirapply -> "Pdirapply" - | Ploc _ -> "Ploc" - | Pgetglobal _ -> "Pgetglobal" - | Pmakeblock _ -> "Pmakeblock" - | Pfield _ -> "Pfield" - | Psetfield _ -> "Psetfield" - | Pduprecord -> "Pduprecord" - | Plazyforce -> "Plazyforce" - | Pccall _ -> "Pccall" - | Praise _ -> "Praise" - | Psequand -> "Psequand" - | Psequor -> "Psequor" - | Pnot -> "Pnot" - | Pnegint -> "Pnegint" - | Paddint -> "Paddint" - | Psubint -> "Psubint" - | Pmulint -> "Pmulint" - | Pdivint _ -> "Pdivint" - | Pmodint _ -> "Pmodint" - | Pandint -> "Pandint" - | Porint -> "Porint" - | Pxorint -> "Pxorint" - | Plslint -> "Plslint" - | Plsrint -> "Plsrint" - | Pasrint -> "Pasrint" - | Pintcomp _ -> "Pintcomp" - | Poffsetint _ -> "Poffsetint" - | Poffsetref _ -> "Poffsetref" - | Pintoffloat -> "Pintoffloat" - | Pfloatofint -> "Pfloatofint" - | Pnegfloat -> "Pnegfloat" - | Pabsfloat -> "Pabsfloat" - | Paddfloat -> "Paddfloat" - | Psubfloat -> "Psubfloat" - | Pmulfloat -> "Pmulfloat" - | Pdivfloat -> "Pdivfloat" - | Pfloatcomp _ -> "Pfloatcomp" - | Pnegbigint -> "Pnegbigint" - | Paddbigint -> "Paddbigint" - | Psubbigint -> "Psubbigint" - | Pmulbigint -> "Pmulbigint" - | Pdivbigint -> "Pdivbigint" - | Pmodbigint -> "Pmodbigint" - | Ppowbigint -> "Ppowbigint" - | Pandbigint -> "Pandbigint" - | Porbigint -> "Porbigint" - | Pxorbigint -> "Pxorbigint" - | Plslbigint -> "Plslbigint" - | Pasrbigint -> "Pasrbigint" - | Pbigintcomp _ -> "Pbigintcomp" - | Pstringlength -> "Pstringlength" - | Pstringrefu -> "Pstringrefu" - | Pstringrefs -> "Pstringrefs" - | Pbyteslength -> "Pbyteslength" - | Pbytesrefu -> "Pbytesrefu" - | Pbytessetu -> "Pbytessetu" - | Pbytesrefs -> "Pbytesrefs" - | Pbytessets -> "Pbytessets" - | Parraylength -> "Parraylength" - | Pmakearray _-> "Pmakearray" - | Parrayrefu -> "Parrayrefu" - | Parraysetu -> "Parraysetu" - | Parrayrefs -> "Parrayrefs" - | Parraysets -> "Parraysets" - | Pctconst _ -> "Pctconst" - | Pisint -> "Pisint" - | Pisout -> "Pisout" - | Pbintofint _ -> "Pbintofint" - | Pintofbint _ -> "Pintofbint" - | Pcvtbint _ -> "Pcvtbint" - | Pnegbint _ -> "Pnegbint" - | Paddbint _ -> "Paddbint" - | Psubbint _ -> "Psubbint" - | Pmulbint _ -> "Pmulbint" - | Pdivbint _ -> "Pdivbint" - | Pmodbint _ -> "Pmodbint" - | Pandbint _ -> "Pandbint" - | Porbint _ -> "Porbint" - | Pxorbint _ -> "Pxorbint" - | Plslbint _ -> "Plslbint" - | Plsrbint _ -> "Plsrbint" - | Pasrbint _ -> "Pasrbint" - | Pbintcomp _ -> "Pbintcomp" - | Popaque -> "Popaque" - | Pcreate_extension _ -> "Pcreate_extension" - -let function_attribute ppf { inline; is_a_functor; stub; return_unit } = - if is_a_functor then - fprintf ppf "is_a_functor@ "; - if stub then - fprintf ppf "stub@ "; - if return_unit then - fprintf ppf "void@ "; - begin match inline with - | Default_inline -> () - | Always_inline -> fprintf ppf "always_inline@ " - | Never_inline -> fprintf ppf "never_inline@ " - end - - -let apply_inlined_attribute ppf = function - | Default_inline -> () - | Always_inline -> fprintf ppf " always_inline" - | Never_inline -> fprintf ppf " never_inline" - - -let rec lam ppf = function - | Lvar id -> - Ident.print ppf id - | Lconst cst -> - struct_const ppf cst - | Lapply ap -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(apply@ %a%a%a)@]" lam ap.ap_func lams ap.ap_args - apply_inlined_attribute ap.ap_inlined - - | Lfunction{ params; body; attr} -> - let pr_params ppf params = - List.iter (fun param -> fprintf ppf "@ %a" Ident.print param) params - in - fprintf ppf "@[<2>(function%a@ %a%a)@]" pr_params params - function_attribute attr lam body - | Llet(str, k, id, arg, body) -> - let kind = function - Alias -> "a" | Strict -> "" | StrictOpt -> "o" | Variable -> "v" - in - let rec letbody = function - | Llet(str, k, id, arg, body) -> - fprintf ppf "@ @[<2>%a =%s%s@ %a@]" - Ident.print id (kind str) (value_kind k) lam arg; - letbody body - | expr -> expr in - fprintf ppf "@[<2>(let@ @[(@[<2>%a =%s%s@ %a@]" - Ident.print id (kind str) (value_kind k) lam arg; - let expr = letbody body in - fprintf ppf ")@]@ %a)@]" lam expr - | Lletrec(id_arg_list, body) -> - let bindings ppf id_arg_list = - let spc = ref false in - List.iter - (fun (id, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[<2>%a@ %a@]" Ident.print id lam l) - id_arg_list in - fprintf ppf - "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim(prim, largs, _) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs - | Lswitch(larg, sw, _loc) -> - let switch ppf sw = - let spc = ref false in - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case int %i:@ %a@]" n lam l) - sw.sw_consts; - List.iter - (fun (n, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case tag %i:@ %a@]" n lam l) - sw.sw_blocks ; - begin match sw.sw_failaction with - | None -> () - | Some l -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam l - end in - fprintf ppf - "@[<1>(%s %a@ @[%a@])@]" - (match sw.sw_failaction with None -> "switch*" | _ -> "switch") - lam larg switch sw - | Lstringswitch(arg, cases, default, _) -> - let switch ppf cases = - let spc = ref false in - List.iter - (fun (s, l) -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[case \"%s\":@ %a@]" (String.escaped s) lam l) - cases; - begin match default with - | Some default -> - if !spc then fprintf ppf "@ " else spc := true; - fprintf ppf "@[default:@ %a@]" lam default - | None -> () - end in - fprintf ppf - "@[<1>(stringswitch %a@ @[%a@])@]" lam arg switch cases - | Lstaticraise (i, ls) -> - let lams ppf largs = - List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in - fprintf ppf "@[<2>(exit@ %d%a)@]" i lams ls; - | Lstaticcatch(lbody, (i, vars), lhandler) -> - fprintf ppf "@[<2>(catch@ %a@;<1 -1>with (%d%a)@ %a)@]" - lam lbody i - (fun ppf vars -> match vars with - | [] -> () - | _ -> - List.iter - (fun x -> fprintf ppf " %a" Ident.print x) - vars) - vars - lam lhandler - | Ltrywith(lbody, param, lhandler) -> - fprintf ppf "@[<2>(try@ %a@;<1 -1>with %a@ %a)@]" - lam lbody Ident.print param lam lhandler - | Lifthenelse(lcond, lif, lelse) -> - fprintf ppf "@[<2>(if@ %a@ %a@ %a)@]" lam lcond lam lif lam lelse - | Lsequence(l1, l2) -> - fprintf ppf "@[<2>(seq@ %a@ %a)@]" lam l1 sequence l2 - | Lwhile(lcond, lbody) -> - fprintf ppf "@[<2>(while@ %a@ %a)@]" lam lcond lam lbody - | Lfor(param, lo, hi, dir, body) -> - fprintf ppf "@[<2>(for %a@ %a@ %s@ %a@ %a)@]" - Ident.print param lam lo - (match dir with Upto -> "to" | Downto -> "downto") - lam hi lam body - | Lassign(id, expr) -> - fprintf ppf "@[<2>(assign@ %a@ %a)@]" Ident.print id lam expr - | Lsend (name,obj, _) -> - fprintf ppf "@[<2>(send%s@ %a@ )@]" name lam obj - -and sequence ppf = function - | Lsequence(l1, l2) -> - fprintf ppf "%a@ %a" sequence l1 sequence l2 - | l -> - lam ppf l - -let structured_constant = struct_const - -let lambda = lam - - diff --git a/jscomp/ml/printtyp.ml b/jscomp/ml/printtyp.ml deleted file mode 100644 index 7f89f03..0000000 --- a/jscomp/ml/printtyp.ml +++ /dev/null @@ -1,1716 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Jerome Vouillon, 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. *) -(* *) -(**************************************************************************) - -(* Printing functions *) - -open Misc -open Ctype -open Format -open Longident -open Path -open Asttypes -open Types -open Btype -open Outcometree - -let print_res_poly_identifier: (string -> string) ref = ref (fun _ -> assert false) - -(* Print a long identifier *) - -let rec longident ppf = function - | Lident s -> pp_print_string ppf s - | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s - | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 - -(* Print an identifier *) - -let unique_names = ref Ident.empty - -let ident_name id = - try Ident.find_same id !unique_names with Not_found -> Ident.name id - -let add_unique id = - try ignore (Ident.find_same id !unique_names) - with Not_found -> - unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names - -let ident ppf id = pp_print_string ppf (ident_name id) - -(* Print a path *) - -let ident_pervasives = Ident.create_persistent "Pervasives" -let ident_pervasives_u = Ident.create_persistent "PervasivesU" -let printing_env = ref Env.empty -let non_shadowed_pervasive = function - | Pdot(Pident id, s, _pos) as path -> - (Ident.same id ident_pervasives || Ident.same id ident_pervasives_u) && - (try Path.same path (Env.lookup_type (Lident s) !printing_env) - with Not_found -> true) - | _ -> false - -let rec tree_of_path = function - | Pident id -> - Oide_ident (ident_name id) - | Pdot(_, s, _pos) as path when non_shadowed_pervasive path -> - Oide_ident s - | Pdot(p, s, _pos) -> - Oide_dot (tree_of_path p, s) - | Papply(p1, p2) -> - Oide_apply (tree_of_path p1, tree_of_path p2) - -let rec path ppf = function - | Pident id -> - ident ppf id - | Pdot(_, s, _pos) as path when non_shadowed_pervasive path -> - pp_print_string ppf s - | Pdot(p, s, _pos) -> - path ppf p; - pp_print_char ppf '.'; - pp_print_string ppf s - | Papply(p1, p2) -> - fprintf ppf "%a(%a)" path p1 path p2 - -let rec string_of_out_ident = function - | Oide_ident s -> s - | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s] - | Oide_apply (id1, id2) -> - String.concat "" - [string_of_out_ident id1; "("; string_of_out_ident id2; ")"] - -let string_of_path p = string_of_out_ident (tree_of_path p) - -(* Print a recursive annotation *) - -let tree_of_rec = function - | Trec_not -> Orec_not - | Trec_first -> Orec_first - | Trec_next -> Orec_next - -(* Print a raw type expression, with sharing *) - -let raw_list pr ppf = function - [] -> fprintf ppf "[]" - | a :: l -> - fprintf ppf "@[<1>[%a%t]@]" pr a - (fun ppf -> List.iter (fun x -> fprintf ppf ";@,%a" pr x) l) - -let kind_vars = ref [] -let kind_count = ref 0 - -let rec safe_kind_repr v = function - Fvar {contents=Some k} -> - if List.memq k v then "Fvar loop" else - safe_kind_repr (k::v) k - | Fvar r -> - let vid = - try List.assq r !kind_vars - with Not_found -> - let c = incr kind_count; !kind_count in - kind_vars := (r,c) :: !kind_vars; - c - in - Printf.sprintf "Fvar {None}@%d" vid - | Fpresent -> "Fpresent" - | Fabsent -> "Fabsent" - -let rec safe_commu_repr v = function - Cok -> "Cok" - | Cunknown -> "Cunknown" - | Clink r -> - if List.memq r v then "Clink loop" else - safe_commu_repr (r::v) !r - -let rec safe_repr v = function - {desc = Tlink t} when not (List.memq t v) -> - safe_repr (t::v) t - | t -> t - -let rec list_of_memo = function - Mnil -> [] - | Mcons (_priv, p, _t1, _t2, rem) -> p :: list_of_memo rem - | Mlink rem -> list_of_memo !rem - -let print_name ppf = function - None -> fprintf ppf "None" - | Some name -> fprintf ppf "\"%s\"" name - -let string_of_label = function - Nolabel -> "" - | Labelled s -> s - | Optional s -> "?"^s - -let visited = ref [] -let rec raw_type ppf ty = - let ty = safe_repr [] ty in - if List.memq ty !visited then fprintf ppf "{id=%d}" ty.id else begin - visited := ty :: !visited; - fprintf ppf "@[<1>{id=%d;level=%d;desc=@,%a}@]" ty.id ty.level - raw_type_desc ty.desc - end -and raw_type_list tl = raw_list raw_type tl -and raw_type_desc ppf = function - Tvar name -> fprintf ppf "Tvar %a" print_name name - | Tarrow(l,t1,t2,c) -> - fprintf ppf "@[Tarrow(\"%s\",@,%a,@,%a,@,%s)@]" - (string_of_label l) raw_type t1 raw_type t2 - (safe_commu_repr [] c) - | Ttuple tl -> - fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl - | Tconstr (p, tl, abbrev) -> - fprintf ppf "@[Tconstr(@,%a,@,%a,@,%a)@]" path p - raw_type_list tl - (raw_list path) (list_of_memo !abbrev) - | Tobject (t, nm) -> - fprintf ppf "@[Tobject(@,%a,@,@[<1>ref%t@])@]" raw_type t - (fun ppf -> - match !nm with None -> fprintf ppf " None" - | Some(p,tl) -> - fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) - | Tfield (f, k, t1, t2) -> - fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f - (safe_kind_repr [] k) - raw_type t1 raw_type t2 - | Tnil -> fprintf ppf "Tnil" - | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t - | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t - | Tunivar name -> fprintf ppf "Tunivar %a" print_name name - | Tpoly (t, tl) -> - fprintf ppf "@[Tpoly(@,%a,@,%a)@]" - raw_type t - raw_type_list tl - | Tvariant row -> - fprintf ppf - "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%B;@ @[<1>%s%t@]}@]" - "row_fields=" - (raw_list (fun ppf (l, f) -> - fprintf ppf "@[%s,@ %a@]" l raw_field f)) - row.row_fields - "row_more=" raw_type row.row_more - "row_closed=" row.row_closed - "row_fixed=" row.row_fixed - "row_name=" - (fun ppf -> - match row.row_name with None -> fprintf ppf "None" - | Some(p,tl) -> - fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) - | Tpackage (p, _, tl) -> - fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p - raw_type_list tl - -and raw_field ppf = function - Rpresent None -> fprintf ppf "Rpresent None" - | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t - | Reither (c,tl,m,e) -> - fprintf ppf "@[Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c - raw_type_list tl m - (fun ppf -> - match !e with None -> fprintf ppf " None" - | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) - | Rabsent -> fprintf ppf "Rabsent" - -let raw_type_expr ppf t = - visited := []; kind_vars := []; kind_count := 0; - raw_type ppf t; - visited := []; kind_vars := [] - -let () = Btype.print_raw := raw_type_expr - -(* Normalize paths *) - -type param_subst = Id | Nth of int | Map of int list - -let is_nth = function - Nth _ -> true - | _ -> false - -let compose l1 = function - | Id -> Map l1 - | Map l2 -> Map (List.map (List.nth l1) l2) - | Nth n -> Nth (List.nth l1 n) - -let apply_subst s1 tyl = - if tyl = [] then [] - (* cf. PR#7543: Typemod.type_package doesn't respect type constructor arity *) - else - match s1 with - Nth n1 -> [List.nth tyl n1] - | Map l1 -> List.map (List.nth tyl) l1 - | Id -> tyl - -type best_path = Paths of Path.t list | Best of Path.t - -let printing_depth = ref 0 -let printing_cont = ref ([] : Env.iter_cont list) -let printing_old = ref Env.empty -let printing_pers = ref Concr.empty -module PathMap = Map.Make(Path) -let printing_map = ref PathMap.empty - -let same_type t t' = repr t == repr t' - -let rec index l x = - match l with - [] -> raise Not_found - | a :: l -> if x == a then 0 else 1 + index l x - -let rec uniq = function - [] -> true - | a :: l -> not (List.memq a l) && uniq l - -let rec normalize_type_path ?(cache=false) env p = - try - let (params, ty, _) = Env.find_type_expansion p env in - let params = List.map repr params in - match repr ty with - {desc = Tconstr (p1, tyl, _)} -> - let tyl = List.map repr tyl in - if List.length params = List.length tyl - && List.for_all2 (==) params tyl - then normalize_type_path ~cache env p1 - else if cache || List.length params <= List.length tyl - || not (uniq tyl) then (p, Id) - else - let l1 = List.map (index params) tyl in - let (p2, s2) = normalize_type_path ~cache env p1 in - (p2, compose l1 s2) - | ty -> - (p, Nth (index params ty)) - with - Not_found -> - (Env.normalize_path None env p, Id) - -let penalty s = - if s <> "" && s.[0] = '_' then - 10 - else - try - for i = 0 to String.length s - 2 do - if s.[i] = '_' && s.[i + 1] = '_' then - raise Exit - done; - 1 - with Exit -> 10 - -let rec path_size = function - Pident id -> - penalty (Ident.name id), -Ident.binding_time id - | Pdot (p, _, _) -> - let (l, b) = path_size p in (1+l, b) - | Papply (p1, p2) -> - let (l, b) = path_size p1 in - (l + fst (path_size p2), b) - -let same_printing_env env = - let used_pers = Env.used_persistent () in - Env.same_types !printing_old env && Concr.equal !printing_pers used_pers - -let set_printing_env env = - printing_env := env; - if !Clflags.real_paths - || !printing_env == Env.empty || same_printing_env env then () else - begin - (* printf "Reset printing_map@."; *) - printing_old := env; - printing_pers := Env.used_persistent (); - printing_map := PathMap.empty; - printing_depth := 0; - (* printf "Recompute printing_map.@."; *) - let cont = - Env.iter_types - (fun p (p', _decl) -> - let (p1, s1) = normalize_type_path env p' ~cache:true in - (* Format.eprintf "%a -> %a = %a@." path p path p' path p1 *) - if s1 = Id then - try - let r = PathMap.find p1 !printing_map in - match !r with - Paths l -> r := Paths (p :: l) - | Best p' -> r := Paths [p; p'] (* assert false *) - with Not_found -> - printing_map := PathMap.add p1 (ref (Paths [p])) !printing_map) - env in - printing_cont := [cont]; - end - -let wrap_printing_env env f = - set_printing_env env; - try_finally f (fun () -> set_printing_env Env.empty) - -let wrap_printing_env env f = - Env.without_cmis (wrap_printing_env env) f - -let is_unambiguous path env = - let l = Env.find_shadowed_types path env in - List.exists (Path.same path) l || (* concrete paths are ok *) - match l with - [] -> true - | p :: rem -> - (* allow also coherent paths: *) - let normalize p = fst (normalize_type_path ~cache:true env p) in - let p' = normalize p in - List.for_all (fun p -> Path.same (normalize p) p') rem || - (* also allow repeatedly defining and opening (for toplevel) *) - let id = lid_of_path p in - List.for_all (fun p -> lid_of_path p = id) rem && - Path.same p (Env.lookup_type id env) - -let rec get_best_path r = - match !r with - Best p' -> p' - | Paths [] -> raise Not_found - | Paths l -> - r := Paths []; - List.iter - (fun p -> - (* Format.eprintf "evaluating %a@." path p; *) - match !r with - Best p' when path_size p >= path_size p' -> () - | _ -> if is_unambiguous p !printing_env then r := Best p) - (* else Format.eprintf "%a ignored as ambiguous@." path p *) - l; - get_best_path r - -let best_type_path p = - if !Clflags.real_paths || !printing_env == Env.empty - then (p, Id) - else - let (p', s) = normalize_type_path !printing_env p in - let get_path () = get_best_path (PathMap.find p' !printing_map) in - while !printing_cont <> [] && - try fst (path_size (get_path ())) > !printing_depth with Not_found -> true - do - printing_cont := List.map snd (Env.run_iter_cont !printing_cont); - incr printing_depth; - done; - let p'' = try get_path () with Not_found -> p' in - (* Format.eprintf "%a = %a -> %a@." path p path p' path p''; *) - (p'', s) - -(* Print a type expression *) - -let names = ref ([] : (type_expr * string) list) -let name_counter = ref 0 -let named_vars = ref ([] : string list) - -let weak_counter = ref 1 -let weak_var_map = ref TypeMap.empty -let named_weak_vars = ref StringSet.empty - -let reset_names () = names := []; name_counter := 0; named_vars := [] -let add_named_var ty = - match ty.desc with - Tvar (Some name) | Tunivar (Some name) -> - if List.mem name !named_vars then () else - named_vars := name :: !named_vars - | _ -> () - -let name_is_already_used name = - List.mem name !named_vars - || List.exists (fun (_, name') -> name = name') !names - || StringSet.mem name !named_weak_vars - -let rec new_name () = - let name = - if !name_counter < 26 - then String.make 1 (Char.chr(97 + !name_counter)) - else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ - string_of_int(!name_counter / 26) in - incr name_counter; - if name_is_already_used name then new_name () else name - -let rec new_weak_name ty () = - let name = "weak" ^ string_of_int !weak_counter in - incr weak_counter; - if name_is_already_used name then new_weak_name ty () - else begin - named_weak_vars := StringSet.add name !named_weak_vars; - weak_var_map := TypeMap.add ty name !weak_var_map; - name - end - -let name_of_type name_generator t = - (* We've already been through repr at this stage, so t is our representative - of the union-find class. *) - try List.assq t !names with Not_found -> - try TypeMap.find t !weak_var_map with Not_found -> - let name = - match t.desc with - Tvar (Some name) | Tunivar (Some name) -> - (* Some part of the type we've already printed has assigned another - * unification variable to that name. We want to keep the name, so try - * adding a number until we find a name that's not taken. *) - let current_name = ref name in - let i = ref 0 in - while List.exists (fun (_, name') -> !current_name = name') !names do - current_name := name ^ (string_of_int !i); - i := !i + 1; - done; - !current_name - | _ -> - (* No name available, create a new one *) - name_generator () - in - (* Exception for type declarations *) - if name <> "_" then names := (t, name) :: !names; - name - -let check_name_of_type t = ignore(name_of_type new_name t) - -let remove_names tyl = - let tyl = List.map repr tyl in - names := Ext_list.filter !names (fun (ty,_) -> not (List.memq ty tyl)) - -let visited_objects = ref ([] : type_expr list) -let aliased = ref ([] : type_expr list) -let delayed = ref ([] : type_expr list) - -let add_delayed t = - if not (List.memq t !delayed) then delayed := t :: !delayed - -let is_aliased ty = List.memq (proxy ty) !aliased -let add_alias ty = - let px = proxy ty in - if not (is_aliased px) then begin - aliased := px :: !aliased; - add_named_var px - end - -let aliasable ty = - match ty.desc with - Tvar _ | Tunivar _ | Tpoly _ -> false - | Tconstr (p, _, _) -> - not (is_nth (snd (best_type_path p))) - | _ -> true - -let namable_row row = - row.row_name <> None && - List.for_all - (fun (_, f) -> - match row_field_repr f with - | Reither(c, l, _, _) -> - row.row_closed && if c then l = [] else List.length l = 1 - | _ -> true) - row.row_fields - -let rec mark_loops_rec visited ty = - let ty = repr ty in - let px = proxy ty in - if List.memq px visited && aliasable ty then add_alias px else - let visited = px :: visited in - match ty.desc with - | Tvar _ -> add_named_var ty - | Tarrow(_, ty1, ty2, _) -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl - | Tconstr(p, tyl, _) -> - let (_p', s) = best_type_path p in - List.iter (mark_loops_rec visited) (apply_subst s tyl) - | Tpackage (_, _, tyl) -> - List.iter (mark_loops_rec visited) tyl - | Tvariant row -> - if List.memq px !visited_objects then add_alias px else - begin - let row = row_repr row in - if not (static_row row) then - visited_objects := px :: !visited_objects; - match row.row_name with - | Some(_p, tyl) when namable_row row -> - List.iter (mark_loops_rec visited) tyl - | _ -> - iter_row (mark_loops_rec visited) row - end - | Tobject (fi, nm) -> - if List.memq px !visited_objects then add_alias px else - begin - if opened_object ty then - visited_objects := px :: !visited_objects; - begin match !nm with - | None -> - let fields, _ = flatten_fields fi in - List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpresent then - mark_loops_rec visited ty) - fields - | Some (_, l) -> - List.iter (mark_loops_rec visited) (List.tl l) - end - end - | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Tfield(_, _, _, ty2) -> - mark_loops_rec visited ty2 - | Tnil -> () - | Tsubst ty -> mark_loops_rec visited ty - | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" - | Tpoly (ty, tyl) -> - List.iter (fun t -> add_alias t) tyl; - mark_loops_rec visited ty - | Tunivar _ -> add_named_var ty - -let mark_loops ty = - normalize_type Env.empty ty; - mark_loops_rec [] ty;; - -let reset_loop_marks () = - visited_objects := []; aliased := []; delayed := [] - -let reset () = - unique_names := Ident.empty; reset_names (); reset_loop_marks () - -let reset_and_mark_loops ty = - reset (); mark_loops ty - -let reset_and_mark_loops_list tyl = - reset (); List.iter mark_loops tyl - -(* Disabled in classic mode when printing an unification error *) - - -let rec tree_of_typexp sch ty = - let ty = repr ty in - let px = proxy ty in - if List.mem_assq px !names && not (List.memq px !delayed) then - let mark = is_non_gen sch ty in - let name = name_of_type (if mark then new_weak_name ty else new_name) px in - Otyp_var (mark, name) else - - let pr_typ () = - match ty.desc with - | Tvar _ -> - (*let lev = - if is_non_gen sch ty then "/" ^ string_of_int ty.level else "" in*) - let non_gen = is_non_gen sch ty in - let name_gen = if non_gen then new_weak_name ty else new_name in - Otyp_var (non_gen, name_of_type name_gen ty) - | Tarrow(l, ty1, ty2, _) -> - let pr_arrow l ty1 ty2 = - let lab = - string_of_label l - in - let t1 = - if is_optional l then - match (repr ty1).desc with - | Tconstr(path, [ty], _) - when Path.same path Predef.path_option -> - tree_of_typexp sch ty - | _ -> Otyp_stuff "" - else tree_of_typexp sch ty1 in - Otyp_arrow (lab, t1, tree_of_typexp sch ty2) in - pr_arrow l ty1 ty2 - | Ttuple tyl -> - Otyp_tuple (tree_of_typlist sch tyl) - | Tconstr(p, tyl, _abbrev) -> - let p', s = best_type_path p in - let tyl' = apply_subst s tyl in - if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else - Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') - | Tvariant row -> - let row = row_repr row in - let fields = - if row.row_closed then - Ext_list.filter row.row_fields (fun (_, f) -> row_field_repr f <> Rabsent) - else row.row_fields in - let present = - Ext_list.filter fields - (fun (_, f) -> - match row_field_repr f with - | Rpresent _ -> true - | _ -> false) - in - let all_present = List.length present = List.length fields in - begin match row.row_name with - | Some(p, tyl) when namable_row row -> - let (p', s) = best_type_path p in - let id = tree_of_path p' in - let args = tree_of_typlist sch (apply_subst s tyl) in - let out_variant = - if is_nth s then List.hd args else Otyp_constr (id, args) in - if row.row_closed && all_present then - out_variant - else - let non_gen = is_non_gen sch px in - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags) - | _ -> - let non_gen = - not (row.row_closed && all_present) && is_non_gen sch px in - let fields = List.map (tree_of_row_field sch) fields in - let tags = - if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags) - end - | Tobject (fi, nm) -> - tree_of_typobject sch fi !nm - | Tnil | Tfield _ -> - tree_of_typobject sch ty None - | Tsubst ty -> - tree_of_typexp sch ty - | Tlink _ -> - fatal_error "Printtyp.tree_of_typexp" - | Tpoly (ty, []) -> - tree_of_typexp sch ty - | Tpoly (ty, tyl) -> - (*let print_names () = - List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; - prerr_string "; " in *) - let tyl = List.map repr tyl in - if tyl = [] then tree_of_typexp sch ty else begin - let old_delayed = !delayed in - (* Make the names delayed, so that the real type is - printed once when used as proxy *) - List.iter add_delayed tyl; - let tl = List.map (name_of_type new_name) tyl in - let tr = Otyp_poly (tl, tree_of_typexp sch ty) in - (* Forget names when we leave scope *) - remove_names tyl; - delayed := old_delayed; tr - end - | Tunivar _ -> - Otyp_var (false, name_of_type new_name ty) - | Tpackage (p, n, tyl) -> - let n = - List.map (fun li -> String.concat "." (Longident.flatten li)) n in - Otyp_module (Path.name p, n, tree_of_typlist sch tyl) - in - if List.memq px !delayed then delayed := Ext_list.filter !delayed ((!=) px) ; - if is_aliased px && aliasable ty then begin - check_name_of_type px; - Otyp_alias (pr_typ (), name_of_type new_name px) end - else pr_typ () - -and tree_of_row_field sch (l, f) = - match row_field_repr f with - | Rpresent None | Reither(true, [], _, _) -> (l, false, []) - | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty]) - | Reither(c, tyl, _, _) -> - if c (* contradiction: constant constructor with an argument *) - then (l, true, tree_of_typlist sch tyl) - else (l, false, tree_of_typlist sch tyl) - | Rabsent -> (l, false, [] (* actually, an error *)) - -and tree_of_typlist sch tyl = - List.map (tree_of_typexp sch) tyl - -and tree_of_typobject sch fi nm = - begin match nm with - | None -> - let pr_fields fi = - let (fields, rest) = flatten_fields fi in - let present_fields = - List.fold_right - (fun (n, k, t) l -> - match field_kind_repr k with - | Fpresent -> (n, t) :: l - | _ -> l) - fields [] in - let sorted_fields = - List.sort - (fun (n, _) (n', _) -> String.compare n n') present_fields in - tree_of_typfields sch rest sorted_fields in - let (fields, rest) = pr_fields fi in - Otyp_object (fields, rest) - | Some (p, ty :: tyl) -> - let non_gen = is_non_gen sch (repr ty) in - let args = tree_of_typlist sch tyl in - let (p', s) = best_type_path p in - assert (s = Id); - Otyp_class (non_gen, tree_of_path p', args) - | _ -> - fatal_error "Printtyp.tree_of_typobject" - end - -and is_non_gen sch ty = - sch && is_Tvar ty && ty.level <> generic_level - -and tree_of_typfields sch rest = function - | [] -> - let rest = - match rest.desc with - | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) - | Tconstr _ -> Some false - | Tnil -> None - | _ -> fatal_error "typfields (1)" - in - ([], rest) - | (s, t) :: l -> - let field = (s, tree_of_typexp sch t) in - let (fields, rest) = tree_of_typfields sch rest l in - (field :: fields, rest) - -let typexp sch ppf ty = - !Oprint.out_type ppf (tree_of_typexp sch ty) - -let type_expr ppf ty = typexp false ppf ty - -and type_sch ppf ty = typexp true ppf ty - -and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty - -(* Maxence *) -let type_scheme_max ?(b_reset_names=true) ppf ty = - if b_reset_names then reset_names () ; - typexp true ppf ty -(* End Maxence *) - -let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty - -(* Print one type declaration *) - -let tree_of_constraints params = - List.fold_right - (fun ty list -> - let ty' = unalias ty in - if proxy ty != proxy ty' then - let tr = tree_of_typexp true ty in - (tr, tree_of_typexp true ty') :: list - else list) - params [] - -let filter_params tyl = - let params = - List.fold_left - (fun tyl ty -> - let ty = repr ty in - if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl - else ty :: tyl) - [] tyl - in List.rev params - -let mark_loops_constructor_arguments = function - | Cstr_tuple l -> List.iter mark_loops l - | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l - -let rec tree_of_type_decl id decl = - - reset(); - - let params = filter_params decl.type_params in - - begin match decl.type_manifest with - | Some ty -> - let vars = free_variables ty in - List.iter - (function {desc = Tvar (Some "_")} as ty -> - if List.memq ty vars then ty.desc <- Tvar None - | _ -> ()) - params - | None -> () - end; - - List.iter add_alias params; - List.iter mark_loops params; - List.iter check_name_of_type (List.map proxy params); - let ty_manifest = - match decl.type_manifest with - | None -> None - | Some ty -> - let ty = - (* Special hack to hide variant name *) - match repr ty with {desc=Tvariant row} -> - let row = row_repr row in - begin match row.row_name with - Some (Pident id', _) when Ident.same id id' -> - newgenty (Tvariant {row with row_name = None}) - | _ -> ty - end - | _ -> ty - in - mark_loops ty; - Some ty - in - begin match decl.type_kind with - | Type_abstract -> () - | Type_variant cstrs -> - List.iter - (fun c -> - mark_loops_constructor_arguments c.cd_args; - may mark_loops c.cd_res) - cstrs - | Type_record(l, _rep) -> - List.iter (fun l -> mark_loops l.ld_type) l - | Type_open -> () - end; - - let type_param = - function - | Otyp_var (_, id) -> id - | _ -> "?" - in - let type_defined decl = - let abstr = - match decl.type_kind with - Type_abstract -> - decl.type_manifest = None || decl.type_private = Private - | Type_record _ -> - decl.type_private = Private - | Type_variant tll -> - decl.type_private = Private || - List.exists (fun cd -> cd.cd_res <> None) tll - | Type_open -> - decl.type_manifest = None - in - let vari = - List.map2 - (fun ty v -> - if abstr || not (is_Tvar (repr ty)) then Variance.get_upper v - else (true,true)) - decl.type_params decl.type_variance - in - (Ident.name id, - List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn) - params vari) - in - let tree_of_manifest ty1 = - match ty_manifest with - | None -> ty1 - | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1) - in - let (name, args) = type_defined decl in - let constraints = tree_of_constraints params in - let untagged = ref false in - let ty, priv = - match decl.type_kind with - | Type_abstract -> - begin match ty_manifest with - | None -> (Otyp_abstract, Public) - | Some ty -> - tree_of_typexp false ty, decl.type_private - end - | Type_variant cstrs -> - untagged := Ast_untagged_variants.process_untagged decl.type_attributes; - tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), - decl.type_private - | Type_record(lbls, _rep) -> - tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), - decl.type_private - | Type_open -> - tree_of_manifest Otyp_open, - decl.type_private - in - let immediate = - Builtin_attributes.immediate decl.type_attributes - in - { otype_name = name; - otype_params = args; - otype_type = ty; - otype_private = priv; - otype_immediate = immediate; - otype_unboxed = decl.type_unboxed.unboxed || !untagged; - otype_cstrs = constraints ; - } - -and tree_of_constructor_arguments = function - | Cstr_tuple l -> tree_of_typlist false l - | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] - -and tree_of_constructor cd = - let name = Ident.name cd.cd_id in - let nullary = Ast_untagged_variants.is_nullary_variant cd.cd_args in - let repr = - if not nullary then None - else match Ast_untagged_variants.process_tag_type cd.cd_attributes with - | Some Null -> Some "@as(null)" - | Some Undefined -> Some "@as(undefined)" - | Some (String s) -> Some (Printf.sprintf "@as(%S)" s) - | Some (Int i) -> Some (Printf.sprintf "@as(%d)" i) - | Some (Float f) -> Some (Printf.sprintf "@as(%s)" f) - | Some (Bool b) -> Some (Printf.sprintf "@as(%b)" b) - | Some (BigInt s) -> Some (Printf.sprintf "@as(%sn)" s) - | Some (Untagged _) (* should never happen *) - | None -> None in - let arg () = tree_of_constructor_arguments cd.cd_args in - match cd.cd_res with - | None -> (name, arg (), None, repr) - | Some res -> - let nm = !names in - names := []; - let ret = tree_of_typexp false res in - let args = arg () in - names := nm; - (name, args, Some ret, repr) - -and tree_of_label l = - let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "ns.optional" || txt = "res.optional") in - let typ = match l.ld_type.desc with - | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 - | _ -> l.ld_type in - (Ident.name l.ld_id, l.ld_mutable = Mutable, opt, tree_of_typexp false typ) - -let tree_of_type_declaration id decl rs = - Osig_type (tree_of_type_decl id decl, tree_of_rec rs) - -let type_declaration id ppf decl = - !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_not) - -let constructor_arguments ppf a = - let tys = tree_of_constructor_arguments a in - !Oprint.out_type ppf (Otyp_tuple tys) - -(* Print an extension declaration *) - -let tree_of_extension_constructor id ext es = - reset (); - let ty_name = Path.name ext.ext_type_path in - let ty_params = filter_params ext.ext_type_params in - List.iter add_alias ty_params; - List.iter mark_loops ty_params; - List.iter check_name_of_type (List.map proxy ty_params); - mark_loops_constructor_arguments ext.ext_args; - may mark_loops ext.ext_ret_type; - let type_param = - function - | Otyp_var (_, id) -> id - | _ -> "?" - in - let ty_params = - List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params - in - let name = Ident.name id in - let args, ret = - match ext.ext_ret_type with - | None -> (tree_of_constructor_arguments ext.ext_args, None) - | Some res -> - let nm = !names in - names := []; - let ret = tree_of_typexp false res in - let args = tree_of_constructor_arguments ext.ext_args in - names := nm; - (args, Some ret) - in - let ext = - { oext_name = name; - oext_type_name = ty_name; - oext_type_params = ty_params; - oext_args = args; - oext_ret_type = ret; - oext_repr = None; - oext_private = ext.ext_private } - in - let es = - match es with - Text_first -> Oext_first - | Text_next -> Oext_next - | Text_exception -> Oext_exception - in - Osig_typext (ext, es) - -let extension_constructor id ppf ext = - !Oprint.out_sig_item ppf (tree_of_extension_constructor id ext Text_first) - -(* Print a value declaration *) - -let tree_of_value_description id decl = - (* Format.eprintf "@[%a@]@." raw_type_expr decl.val_type; *) - let id = Ident.name id in - let ty = tree_of_type_scheme decl.val_type in - let vd = - { oval_name = id; - oval_type = ty; - oval_prims = []; - oval_attributes = [] } - in - let vd = - match decl.val_kind with - | Val_prim p -> Primitive.print p vd - | _ -> vd - in - Osig_value vd - -let value_description id ppf decl = - !Oprint.out_sig_item ppf (tree_of_value_description id decl) - -(* Print a class type *) - -let method_type (_, kind, ty) = - match field_kind_repr kind, repr ty with - Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl) - | _ , ty -> (ty, []) - -let tree_of_metho sch concrete csil (lab, kind, ty) = - if lab <> dummy_method then begin - let kind = field_kind_repr kind in - let priv = kind <> Fpresent in - let virt = not (Concr.mem lab concrete) in - let (ty, tyl) = method_type (lab, kind, ty) in - let tty = tree_of_typexp sch ty in - remove_names tyl; - Ocsg_method (lab, priv, virt, tty) :: csil - end - else csil - -let rec prepare_class_type params = function - | Cty_constr (_p, tyl, cty) -> - let sty = Ctype.self_type cty in - if List.memq (proxy sty) !visited_objects - || not (List.for_all is_Tvar params) - || List.exists (deep_occur sty) tyl - then prepare_class_type params cty - else List.iter mark_loops tyl - | Cty_signature sign -> - let sty = repr sign.csig_self in - (* Self may have a name *) - let px = proxy sty in - if List.memq px !visited_objects then add_alias sty - else visited_objects := px :: !visited_objects; - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) - in - List.iter (fun met -> mark_loops (fst (method_type met))) fields; - Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars - | Cty_arrow (_, ty, cty) -> - mark_loops ty; - prepare_class_type params cty - -let rec tree_of_class_type sch params = - function - | Cty_constr (p', tyl, cty) -> - let sty = Ctype.self_type cty in - if List.memq (proxy sty) !visited_objects - || not (List.for_all is_Tvar params) - then - tree_of_class_type sch params cty - else - Octy_constr (tree_of_path p', tree_of_typlist true tyl) - | Cty_signature sign -> - let sty = repr sign.csig_self in - let self_ty = - if is_aliased sty then - Some (Otyp_var (false, name_of_type new_name (proxy sty))) - else None - in - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) - in - let csil = [] in - let csil = - List.fold_left - (fun csil (ty1, ty2) -> Ocsg_constraint (ty1, ty2) :: csil) - csil (tree_of_constraints params) - in - let all_vars = - Vars.fold (fun l (m, v, t) all -> (l, m, v, t) :: all) sign.csig_vars [] - in - (* Consequence of PR#3607: order of Map.fold has changed! *) - let all_vars = List.rev all_vars in - let csil = - List.fold_left - (fun csil (l, m, v, t) -> - Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) - :: csil) - csil all_vars - in - let csil = - List.fold_left (tree_of_metho sch sign.csig_concr) csil fields - in - Octy_signature (self_ty, List.rev csil) - | Cty_arrow (l, ty, cty) -> - let lab = - string_of_label l - in - let ty = - if is_optional l then - match (repr ty).desc with - | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty - | _ -> newconstr (Path.Pident(Ident.create "")) [] - else ty in - let tr = tree_of_typexp sch ty in - Octy_arrow (lab, tr, tree_of_class_type sch params cty) - -let class_type ppf cty = - reset (); - prepare_class_type [] cty; - !Oprint.out_class_type ppf (tree_of_class_type false [] cty) - -let tree_of_class_param param variance = - (match tree_of_typexp true param with - Otyp_var (_, s) -> s - | _ -> "?"), - if is_Tvar (repr param) then (true, true) else variance - -let class_variance = - List.map Variance.(fun v -> mem May_pos v, mem May_neg v) - -let tree_of_class_declaration id cl rs = - let params = filter_params cl.cty_params in - - reset (); - List.iter add_alias params; - prepare_class_type params cl.cty_type; - let sty = Ctype.self_type cl.cty_type in - List.iter mark_loops params; - - List.iter check_name_of_type (List.map proxy params); - if is_aliased sty then check_name_of_type (proxy sty); - - let vir_flag = cl.cty_new = None in - Osig_class - (vir_flag, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.cty_variance), - tree_of_class_type true params cl.cty_type, - tree_of_rec rs) - -let class_declaration id ppf cl = - !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) - -let tree_of_cltype_declaration id cl rs = - let params = List.map repr cl.clty_params in - - reset (); - List.iter add_alias params; - prepare_class_type params cl.clty_type; - let sty = Ctype.self_type cl.clty_type in - List.iter mark_loops params; - - List.iter check_name_of_type (List.map proxy params); - if is_aliased sty then check_name_of_type (proxy sty); - - let sign = Ctype.signature_of_class_type cl.clty_type in - - let virt = - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in - List.exists - (fun (lab, _, _) -> - not (lab = dummy_method || Concr.mem lab sign.csig_concr)) - fields - || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false - in - - Osig_class_type - (virt, Ident.name id, - List.map2 tree_of_class_param params (class_variance cl.clty_variance), - tree_of_class_type true params cl.clty_type, - tree_of_rec rs) - -let cltype_declaration id ppf cl = - !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first) - -(* Print a module type *) - -let wrap_env fenv ftree arg = - let env = !printing_env in - set_printing_env (fenv env); - let tree = ftree arg in - set_printing_env env; - tree - -let filter_rem_sig item rem = - match item, rem with - | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> - ([tydecl1; tydecl2], rem) - | _ -> - ([], rem) - -let dummy = - { type_params = []; type_arity = 0; type_kind = Type_abstract; - type_private = Public; type_manifest = None; type_variance = []; - type_newtype_level = None; type_loc = Location.none; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - -let hide_rec_items = function - | Sig_type(id, _decl, rs) ::rem - when rs = Trec_first && not !Clflags.real_paths -> - let rec get_ids = function - Sig_type (id, _, Trec_next) :: rem -> - id :: get_ids rem - | _ -> [] - in - let ids = id :: get_ids rem in - set_printing_env - (List.fold_right - (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) - ids !printing_env) - | _ -> () - -let rec tree_of_modtype ?(ellipsis=false) = function - | Mty_ident p -> - Omty_ident (tree_of_path p) - | Mty_signature sg -> - Omty_signature (if ellipsis then [Osig_ellipsis] - else tree_of_signature sg) - | Mty_functor(param, ty_arg, ty_res) -> - let res = - match ty_arg with None -> tree_of_modtype ~ellipsis ty_res - | Some mty -> - wrap_env (Env.add_module ~arg:true param mty) - (tree_of_modtype ~ellipsis) ty_res - in - Omty_functor (Ident.name param, - may_map (tree_of_modtype ~ellipsis:false) ty_arg, res) - | Mty_alias(_, p) -> - Omty_alias (tree_of_path p) - -and tree_of_signature sg = - wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg - -and tree_of_signature_rec env' in_type_group = function - [] -> [] - | item :: rem as items -> - let in_type_group = - match in_type_group, item with - true, Sig_type (_, _, Trec_next) -> true - | _, Sig_type (_, _, (Trec_not | Trec_first)) -> - set_printing_env env'; true - | _ -> set_printing_env env'; false - in - let (sg, rem) = filter_rem_sig item rem in - hide_rec_items items; - let trees = trees_of_sigitem item in - let env' = Env.add_signature (item :: sg) env' in - trees @ tree_of_signature_rec env' in_type_group rem - -and trees_of_sigitem = function - | Sig_value(id, decl) -> - [tree_of_value_description id decl] - | Sig_type(id, _, _) when is_row_name (Ident.name id) -> - [] - | Sig_type(id, decl, rs) -> - [tree_of_type_declaration id decl rs] - | Sig_typext(id, ext, es) -> - [tree_of_extension_constructor id ext es] - | Sig_module(id, md, rs) -> - let ellipsis = - List.exists (function ({txt="..."}, Parsetree.PStr []) -> true - | _ -> false) - md.md_attributes in - [tree_of_module id md.md_type rs ~ellipsis] - | Sig_modtype(id, decl) -> - [tree_of_modtype_declaration id decl] - | Sig_class() -> - [] - | Sig_class_type(id, decl, rs) -> - [tree_of_cltype_declaration id decl rs] - -and tree_of_modtype_declaration id decl = - let mty = - match decl.mtd_type with - | None -> Omty_abstract - | Some mty -> tree_of_modtype mty - in - Osig_modtype (Ident.name id, mty) - -and tree_of_module id ?ellipsis mty rs = - Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) - -let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) -let modtype_declaration id ppf decl = - !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) - -(* For the toplevel: merge with tree_of_signature? *) - -(* Refresh weak variable map in the toplevel *) -let refresh_weak () = - let refresh t name (m,s) = - if is_non_gen true (repr t) then - begin - TypeMap.add t name m, - StringSet.add name s - end - else m, s in - let m, s = - TypeMap.fold refresh !weak_var_map (TypeMap.empty ,StringSet.empty) in - named_weak_vars := s; - weak_var_map := m - -let print_items showval env x = - refresh_weak(); - let rec print showval env = function - | [] -> [] - | item :: rem as items -> - let (_sg, rem) = filter_rem_sig item rem in - hide_rec_items items; - let trees = trees_of_sigitem item in - List.map (fun d -> (d, showval env item)) trees @ - print showval env rem in - print showval env x - -(* Print a signature body (used by -i when compiling a .ml) *) - -let print_signature ppf tree = - fprintf ppf "@[%a@]" !Oprint.out_signature tree - -let signature ppf sg = - fprintf ppf "%a" print_signature (tree_of_signature sg) - -(* Print an unification error *) - -let same_path t t' = - let t = repr t and t' = repr t' in - t == t' || - match t.desc, t'.desc with - Tconstr(p,tl,_), Tconstr(p',tl',_) -> - let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in - begin match s1, s2 with - Nth n1, Nth n2 when n1 = n2 -> true - | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> - let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in - List.length tl = List.length tl' && - List.for_all2 same_type tl tl' - | _ -> false - end - | _ -> - false - -let type_expansion t ppf t' = - if same_path t t' - then begin add_delayed (proxy t); type_expr ppf t end - else - let t' = if proxy t == proxy t' then unalias t' else t' in - fprintf ppf "@[<2>%a@ =@ %a@]" type_expr t type_expr t' - -let type_path_expansion tp ppf tp' = - if Path.same tp tp' then path ppf tp else - fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp' - -let rec trace fst txt ppf = function - | (t1, t1') :: (t2, t2') :: rem -> - if not fst then fprintf ppf "@,"; - fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a" - (type_expansion t1) t1' txt (type_expansion t2) t2' - (trace false txt) rem - | _ -> () - -let rec filter_trace keep_last = function - | (_, t1') :: (_, t2') :: [] when is_Tvar t1' || is_Tvar t2' -> - [] - | (t1, t1') :: (t2, t2') :: rem -> - let rem' = filter_trace keep_last rem in - if is_constr_row ~allow_ident:true t1' - || is_constr_row ~allow_ident:true t2' - || same_path t1 t1' && same_path t2 t2' && not (keep_last && rem' = []) - then rem' - else (t1, t1') :: (t2, t2') :: rem' - | _ -> [] - -let rec type_path_list ppf = function - | [tp, tp'] -> type_path_expansion tp ppf tp' - | (tp, tp') :: rem -> - fprintf ppf "%a@;<2 0>%a" - (type_path_expansion tp) tp' - type_path_list rem - | [] -> () - -(* Hide variant name and var, to force printing the expanded type *) -let hide_variant_name t = - match repr t with - | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> - newty2 t.level - (Tvariant {(row_repr row) with row_name = None; - row_more = newvar2 (row_more row).level}) - | _ -> t - -let prepare_expansion (t, t') = - let t' = hide_variant_name t' in - mark_loops t; - if not (same_path t t') then mark_loops t'; - (t, t') - -let may_prepare_expansion compact (t, t') = - match (repr t').desc with - Tvariant _ | Tobject _ when compact -> - mark_loops t; (t, t) - | _ -> prepare_expansion (t, t') - -let print_tags ppf fields = - match fields with [] -> () - | (t, _) :: fields -> - fprintf ppf "%s" (!print_res_poly_identifier t); - List.iter (fun (t, _) -> fprintf ppf ",@ %s" (!print_res_poly_identifier t)) fields - -let has_explanation t3 t4 = - match t3.desc, t4.desc with - Tfield _, (Tnil|Tconstr _) | (Tnil|Tconstr _), Tfield _ - | Tnil, Tconstr _ | Tconstr _, Tnil - | _, Tvar _ | Tvar _, _ - | Tvariant _, Tvariant _ -> true - | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) -> l = l' - | _ -> false - -let rec mismatch = function - (_, t) :: (_, t') :: rem -> - begin match mismatch rem with - Some _ as m -> m - | None -> - if has_explanation t t' then Some(t,t') else None - end - | [] -> None - | _ -> assert false - -let explanation unif t3 t4 ppf = - match t3.desc, t4.desc with - | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> - fprintf ppf "@,Self type cannot escape its class" - | Tconstr (p, _, _), Tvar _ - when unif && t4.level < Path.binding_time p -> - fprintf ppf - "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - path p - | Tvar _, Tconstr (p, _, _) - when unif && t3.level < Path.binding_time p -> - fprintf ppf - "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - path p - | Tvar _, Tunivar _ | Tunivar _, Tvar _ -> - fprintf ppf "@,The universal variable %a would escape its scope" - type_expr (if is_Tunivar t3 then t3 else t4) - | Tvar _, _ | _, Tvar _ -> - let t, t' = if is_Tvar t3 then (t3, t4) else (t4, t3) in - if occur_in Env.empty t t' then - fprintf ppf "@,@[The type variable %a occurs inside@ %a@]" - type_expr t type_expr t' - else - fprintf ppf "@,@[This instance of %a is ambiguous:@ %s@]" - type_expr t' - "it would escape the scope of its equation" - | Tfield (lab, _, _, _), _ when lab = dummy_method -> - fprintf ppf - "@,Self type cannot be unified with a closed object type" - | _, Tfield (lab, _, _, _) when lab = dummy_method -> - fprintf ppf - "@,Self type cannot be unified with a closed object type" - | Tfield (l,_,_,{desc=Tnil}), Tfield (l',_,_,{desc=Tnil}) when l = l' -> - fprintf ppf "@,Types for method %s are incompatible" l - | (Tnil|Tconstr _), Tfield (l, _, _, _) -> - fprintf ppf - "@,@[The first object type has no field %s@]" l - | Tfield (l, _, _, _), (Tnil|Tconstr _) -> - fprintf ppf - "@,@[The second object type has no field %s@]" l - | Tnil, Tconstr _ | Tconstr _, Tnil -> - fprintf ppf - "@,@[The %s object type has an abstract row, it cannot be closed@]" - (if t4.desc = Tnil then "first" else "second") - | Tvariant row1, Tvariant row2 -> - let row1 = row_repr row1 and row2 = row_repr row2 in - begin match - row1.row_fields, row1.row_closed, row2.row_fields, row2.row_closed with - | [], true, [], true -> - fprintf ppf "@,These two variant types have no intersection" - | [], true, (_::_ as fields), _ -> - fprintf ppf - "@,@[The first variant type does not allow tag(s)@ @[%a@]@]" - print_tags fields - | (_::_ as fields), _, [], true -> - fprintf ppf - "@,@[The second variant type does not allow tag(s)@ @[%a@]@]" - print_tags fields - | [l1,_], true, [l2,_], true when l1 = l2 -> - fprintf ppf "@,Types for tag %s are incompatible" (!print_res_poly_identifier l1) - | _ -> () - end - | _ -> () - - -let warn_on_missing_def env ppf t = - match t.desc with - | Tconstr (p,_,_) -> - begin - try - ignore(Env.find_type p env : Types.type_declaration) - with Not_found -> - fprintf ppf - "@,@[%a is abstract because no corresponding cmi file was found \ - in path.@]" path p - end - | _ -> () - -let explanation unif mis ppf = - match mis with - None -> () - | Some (t3, t4) -> explanation unif t3 t4 ppf - -let ident_same_name id1 id2 = - if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin - add_unique id1; add_unique id2 - end - -let rec path_same_name p1 p2 = - match p1, p2 with - Pident id1, Pident id2 -> ident_same_name id1 id2 - | Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2 - | Papply (p1, p1'), Papply (p2, p2') -> - path_same_name p1 p2; path_same_name p1' p2' - | _ -> () - -let type_same_name t1 t2 = - match (repr t1).desc, (repr t2).desc with - Tconstr (p1, _, _), Tconstr (p2, _, _) -> - path_same_name (fst (best_type_path p1)) (fst (best_type_path p2)) - | _ -> () - -let rec trace_same_names = function - (t1, t1') :: (t2, t2') :: rem -> - type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem - | _ -> () - -let unification_error env unif tr txt1 ppf txt2 = - reset (); - trace_same_names tr; - let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in - let mis = mismatch tr in - match tr with - | [] | _ :: [] -> assert false - | t1 :: t2 :: tr -> - try - let tr = filter_trace (mis = None) tr in - let t1, t1' = may_prepare_expansion (tr = []) t1 - and t2, t2' = may_prepare_expansion (tr = []) t2 in - let tr = List.map prepare_expansion tr in - fprintf ppf - "@[\ - @[%t@;<1 2>%a@ \ - %t@;<1 2>%a\ - @]%a%t\ - @]" - txt1 (type_expansion t1) t1' - txt2 (type_expansion t2) t2' - (trace false "is not compatible with type") tr - (explanation unif mis); - if env <> Env.empty - then begin - warn_on_missing_def env ppf t1; - warn_on_missing_def env ppf t2 - end; - with exn -> - raise exn - -let report_unification_error ppf env ?(unif=true) - tr txt1 txt2 = - wrap_printing_env env (fun () -> unification_error env unif tr txt1 ppf txt2) -;; - - -let super_type_expansion ~tag t ppf t' = - let tag = Format.String_tag tag in - if same_path t t' then begin - Format.pp_open_stag ppf tag; - type_expr ppf t; - Format.pp_close_stag ppf (); - end else begin - let t' = if proxy t == proxy t' then unalias t' else t' in - fprintf ppf "@[<2>"; - Format.pp_open_stag ppf tag; - fprintf ppf "%a" type_expr t; - Format.pp_close_stag ppf (); - fprintf ppf "@ @{(defined as@}@ "; - Format.pp_open_stag ppf tag; - fprintf ppf "%a" type_expr t'; - Format.pp_close_stag ppf (); - fprintf ppf "@{)@}"; - fprintf ppf "@]"; - end - -let super_trace ppf = - let rec super_trace first_report ppf = function - | (t1, t1') :: (t2, t2') :: rem -> - fprintf ppf - "@,@,@["; - if first_report then - fprintf ppf "The incompatible parts:@," - else begin - fprintf ppf "Further expanded:@," - end; - fprintf ppf - "@[%a@ vs@ %a@]%a" - (super_type_expansion ~tag:"error" t1) t1' - (super_type_expansion ~tag:"info" t2) t2' - (super_trace false) rem; - fprintf ppf "@]" - | _ -> () - in super_trace true ppf - -let super_unification_error unif tr txt1 ppf txt2 = begin - reset (); - trace_same_names tr; - let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in - let mis = mismatch tr in - match tr with - | [] | _ :: [] -> assert false - | t1 :: t2 :: tr -> - try - let tr = filter_trace (mis = None) tr in - let t1, t1' = may_prepare_expansion (tr = []) t1 - and t2, t2' = may_prepare_expansion (tr = []) t2 in - let tr = List.map prepare_expansion tr in - fprintf ppf - "@[\ - @[%t@ %a@]@,\ - @[%t@ %a@]\ - %a\ - %t\ - @]" - txt1 (super_type_expansion ~tag:"error" t1) t1' - txt2 (super_type_expansion ~tag:"info" t2) t2' - super_trace tr - (explanation unif mis); - with exn -> - raise exn -end - -let super_report_unification_error ppf env ?(unif=true) - tr txt1 txt2 = - wrap_printing_env env (fun () -> super_unification_error unif tr txt1 ppf txt2) -;; - - -let trace fst keep_last txt ppf tr = - trace_same_names tr; - try match tr with - t1 :: t2 :: tr' -> - if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr') - else trace fst txt ppf (filter_trace keep_last tr); - | _ -> () - with exn -> - raise exn - -let report_subtyping_error ppf env tr1 txt1 tr2 = - wrap_printing_env env (fun () -> - reset (); - let tr1 = List.map prepare_expansion tr1 - and tr2 = List.map prepare_expansion tr2 in - fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; - if tr2 = [] then fprintf ppf "@]" else - let mis = mismatch tr2 in - fprintf ppf "%a%t@]" - (trace false (mis = None) "is not compatible with type") tr2 - (explanation true mis)) - -let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = - wrap_printing_env env (fun () -> - reset (); - List.iter - (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp') - tpl; - match tpl with - [] -> assert false - | [tp, tp'] -> - fprintf ppf - "@[%t@;<1 2>%a@ \ - %t@;<1 2>%a\ - @]" - txt1 (type_path_expansion tp) tp' - txt3 (type_path_expansion tp0) tp0' - | _ -> - fprintf ppf - "@[%t@;<1 2>@[%a@]\ - @ %t@;<1 2>%a\ - @]" - txt2 type_path_list tpl - txt3 (type_path_expansion tp0) tp0') diff --git a/jscomp/ml/printtyp.mli b/jscomp/ml/printtyp.mli deleted file mode 100644 index af92ffa..0000000 --- a/jscomp/ml/printtyp.mli +++ /dev/null @@ -1,99 +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. *) -(* *) -(**************************************************************************) - -(* Printing functions *) - -open Format -open Types -open Outcometree - -val print_res_poly_identifier: (string -> string) ref -val longident: formatter -> Longident.t -> unit -val ident: formatter -> Ident.t -> unit -val tree_of_path: Path.t -> out_ident -val path: formatter -> Path.t -> unit -val string_of_path: Path.t -> string -val raw_type_expr: formatter -> type_expr -> unit -val string_of_label: Asttypes.arg_label -> string - -val wrap_printing_env: Env.t -> (unit -> 'a) -> 'a - (* Call the function using the environment for type path shortening *) - (* This affects all the printing functions below *) - -val reset: unit -> unit -val mark_loops: type_expr -> unit -val reset_and_mark_loops: type_expr -> unit -val reset_and_mark_loops_list: type_expr list -> unit -val type_expr: formatter -> type_expr -> unit -val constructor_arguments: formatter -> constructor_arguments -> unit -val tree_of_type_scheme: type_expr -> out_type -val type_sch : formatter -> type_expr -> unit -val type_scheme: formatter -> type_expr -> unit -(* Maxence *) -val reset_names: unit -> unit -val type_scheme_max: ?b_reset_names: bool -> - formatter -> type_expr -> unit -(* End Maxence *) -val tree_of_value_description: Ident.t -> value_description -> out_sig_item -val value_description: Ident.t -> formatter -> value_description -> unit -val tree_of_type_declaration: - Ident.t -> type_declaration -> rec_status -> out_sig_item -val type_declaration: Ident.t -> formatter -> type_declaration -> unit -val tree_of_extension_constructor: - Ident.t -> extension_constructor -> ext_status -> out_sig_item -val extension_constructor: - Ident.t -> formatter -> extension_constructor -> unit -val tree_of_module: - Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item -val modtype: formatter -> module_type -> unit -val signature: formatter -> signature -> unit -val tree_of_modtype_declaration: - Ident.t -> modtype_declaration -> out_sig_item -val tree_of_signature: Types.signature -> out_sig_item list -val tree_of_typexp: bool -> type_expr -> out_type -val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit -val class_type: formatter -> class_type -> unit -val tree_of_class_declaration: - Ident.t -> class_declaration -> rec_status -> out_sig_item -val class_declaration: Ident.t -> formatter -> class_declaration -> unit -val tree_of_cltype_declaration: - Ident.t -> class_type_declaration -> rec_status -> out_sig_item -val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit -val type_expansion: type_expr -> Format.formatter -> type_expr -> unit -val prepare_expansion: type_expr * type_expr -> type_expr * type_expr -val trace: - bool -> bool-> string -> formatter -> (type_expr * type_expr) list -> unit -val report_unification_error: - formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list -> - (formatter -> unit) -> (formatter -> unit) -> - unit - - -val super_report_unification_error: - formatter -> Env.t -> ?unif:bool -> (type_expr * type_expr) list -> - (formatter -> unit) -> (formatter -> unit) -> - unit - - -val report_subtyping_error: - formatter -> Env.t -> (type_expr * type_expr) list -> - string -> (type_expr * type_expr) list -> unit -val report_ambiguous_type_error: - formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> - (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit - -(* for toploop *) -val print_items: (Env.t -> signature_item -> 'a option) -> - Env.t -> signature_item list -> (out_sig_item * 'a option) list diff --git a/jscomp/ml/printtyped.ml b/jscomp/ml/printtyped.ml deleted file mode 100644 index e38d17d..0000000 --- a/jscomp/ml/printtyped.ml +++ /dev/null @@ -1,786 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 1999 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. *) -(* *) -(**************************************************************************) - -open Asttypes;; -open Format;; -open Lexing;; -open Location;; -open Typedtree;; - -let fmt_position f l = - if l.pos_lnum = -1 - then fprintf f "%s[%d]" l.pos_fname l.pos_cnum - else fprintf f "%s[%d,%d+%d]" l.pos_fname l.pos_lnum l.pos_bol - (l.pos_cnum - l.pos_bol) -;; - -let fmt_location f loc = - if !Clflags.dump_location then ( - fprintf f "(%a..%a)" fmt_position loc.loc_start fmt_position loc.loc_end; - if loc.loc_ghost then fprintf f " ghost"; - ) -;; - -let rec fmt_longident_aux f x = - match x with - | Longident.Lident (s) -> fprintf f "%s" s; - | Longident.Ldot (y, s) -> fprintf f "%a.%s" fmt_longident_aux y s; - | Longident.Lapply (y, z) -> - fprintf f "%a(%a)" fmt_longident_aux y fmt_longident_aux z; -;; - -let fmt_longident f x = fprintf f "\"%a\"" fmt_longident_aux x.txt;; - -let fmt_ident = Ident.print - -let rec fmt_path_aux f x = - match x with - | Path.Pident (s) -> fprintf f "%a" fmt_ident s; - | Path.Pdot (y, s, _pos) -> fprintf f "%a.%s" fmt_path_aux y s; - | Path.Papply (y, z) -> - fprintf f "%a(%a)" fmt_path_aux y fmt_path_aux z; -;; - -let fmt_path f x = fprintf f "\"%a\"" fmt_path_aux x;; - -let fmt_constant f x = - match x with - | Const_int (i) -> fprintf f "Const_int %d" i; - | Const_char (c) -> fprintf f "Const_char %02x" c; - | Const_string (s, None) -> fprintf f "Const_string(%S,None)" s; - | Const_string (s, Some delim) -> - fprintf f "Const_string (%S,Some %S)" s delim; - | Const_float (s) -> fprintf f "Const_float %s" s; - | Const_int32 (i) -> fprintf f "Const_int32 %ld" i; - | Const_int64 (i) -> fprintf f "Const_int64 %Ld" i; - | Const_bigint (sign, i) -> fprintf f "Const_bigint %s" (Bigint_utils.to_string sign i); -;; - -let fmt_mutable_flag f x = - match x with - | Immutable -> fprintf f "Immutable"; - | Mutable -> fprintf f "Mutable"; -;; - -let fmt_virtual_flag f x = - match x with - | Virtual -> fprintf f "Virtual"; - | Concrete -> fprintf f "Concrete"; -;; - -let fmt_override_flag f x = - match x with - | Override -> fprintf f "Override"; - | Fresh -> fprintf f "Fresh"; -;; - -let fmt_closed_flag f x = - match x with - | Closed -> fprintf f "Closed" - | Open -> fprintf f "Open" - -let fmt_rec_flag f x = - match x with - | Nonrecursive -> fprintf f "Nonrec"; - | Recursive -> fprintf f "Rec"; -;; - -let fmt_direction_flag f x = - match x with - | Upto -> fprintf f "Up"; - | Downto -> fprintf f "Down"; -;; - -let fmt_private_flag f x = - match x with - | Public -> fprintf f "Public"; - | Private -> fprintf f "Private"; -;; - -let line i f s (*...*) = - fprintf f "%s" (String.make (2*i) ' '); - fprintf f s (*...*) -;; - -let list i f ppf l = - match l with - | [] -> line i ppf "[]\n"; - | _ :: _ -> - line i ppf "[\n"; - List.iter (f (i+1) ppf) l; - line i ppf "]\n"; -;; - -let array i f ppf a = - if Array.length a = 0 then - line i ppf "[]\n" - else begin - line i ppf "[\n"; - Array.iter (f (i+1) ppf) a; - line i ppf "]\n" - end -;; - -let option i f ppf x = - match x with - | None -> line i ppf "None\n"; - | Some x -> - line i ppf "Some\n"; - f (i+1) ppf x; -;; - -let longident i ppf li = line i ppf "%a\n" fmt_longident li;; -let string i ppf s = line i ppf "\"%s\"\n" s;; -let arg_label i ppf = function - | Nolabel -> line i ppf "Nolabel\n" - | Optional s -> line i ppf "Optional \"%s\"\n" s - | Labelled s -> line i ppf "Labelled \"%s\"\n" s -;; - -let record_representation i ppf = let open Types in function - | Record_regular -> line i ppf "Record_regular\n" - | Record_float_unused -> assert false - | Record_optional_labels lbls -> - line i ppf "Record_optional_labels %s\n" (lbls |> String.concat ", ") - | Record_unboxed b -> line i ppf "Record_unboxed %b\n" b - | Record_inlined {tag = i} -> line i ppf "Record_inlined %d\n" i - | Record_extension -> line i ppf "Record_extension\n" - -let attributes i ppf l = - let i = i + 1 in - List.iter - (fun (s, arg) -> - line i ppf "attribute \"%s\"\n" s.txt; - Printast.payload (i + 1) ppf arg; - ) - l - -let rec core_type i ppf x = - line i ppf "core_type %a\n" fmt_location x.ctyp_loc; - attributes i ppf x.ctyp_attributes; - let i = i+1 in - match x.ctyp_desc with - | Ttyp_any -> line i ppf "Ttyp_any\n"; - | Ttyp_var (s) -> line i ppf "Ttyp_var %s\n" s; - | Ttyp_arrow (l, ct1, ct2) -> - line i ppf "Ttyp_arrow\n"; - arg_label i ppf l; - core_type i ppf ct1; - core_type i ppf ct2; - | Ttyp_tuple l -> - line i ppf "Ttyp_tuple\n"; - list i core_type ppf l; - | Ttyp_constr (li, _, l) -> - line i ppf "Ttyp_constr %a\n" fmt_path li; - list i core_type ppf l; - | Ttyp_variant (l, closed, low) -> - line i ppf "Ttyp_variant closed=%a\n" fmt_closed_flag closed; - list i label_x_bool_x_core_type_list ppf l; - option i (fun i -> list i string) ppf low - | Ttyp_object (l, c) -> - line i ppf "Ttyp_object %a\n" fmt_closed_flag c; - let i = i + 1 in - List.iter (function - | OTtag (s, attrs, t) -> - line i ppf "method %s\n" s.txt; - attributes i ppf attrs; - core_type (i + 1) ppf t - | OTinherit ct -> - line i ppf "OTinherit\n"; - core_type (i + 1) ppf ct - ) l - | Ttyp_class (li, _, l) -> - line i ppf "Ttyp_class %a\n" fmt_path li; - list i core_type ppf l; - | Ttyp_alias (ct, s) -> - line i ppf "Ttyp_alias \"%s\"\n" s; - core_type i ppf ct; - | Ttyp_poly (sl, ct) -> - line i ppf "Ttyp_poly%a\n" - (fun ppf -> List.iter (fun x -> fprintf ppf " '%s" x)) sl; - core_type i ppf ct; - | Ttyp_package { pack_path = s; pack_fields = l } -> - line i ppf "Ttyp_package %a\n" fmt_path s; - list i package_with ppf l; - -and package_with i ppf (s, t) = - line i ppf "with type %a\n" fmt_longident s; - core_type i ppf t - -and pattern i ppf x = - line i ppf "pattern %a\n" fmt_location x.pat_loc; - attributes i ppf x.pat_attributes; - let i = i+1 in - match x.pat_extra with - | (Tpat_unpack, _, attrs) :: rem -> - line i ppf "Tpat_unpack\n"; - attributes i ppf attrs; - pattern i ppf { x with pat_extra = rem } - | (Tpat_constraint cty, _, attrs) :: rem -> - line i ppf "Tpat_constraint\n"; - attributes i ppf attrs; - core_type i ppf cty; - pattern i ppf { x with pat_extra = rem } - | (Tpat_type (id, _), _, attrs) :: rem -> - line i ppf "Tpat_type %a\n" fmt_path id; - attributes i ppf attrs; - pattern i ppf { x with pat_extra = rem } - | (Tpat_open (id,_,_), _, attrs)::rem -> - line i ppf "Tpat_open \"%a\"\n" fmt_path id; - attributes i ppf attrs; - pattern i ppf { x with pat_extra = rem } - | [] -> - match x.pat_desc with - | Tpat_any -> line i ppf "Tpat_any\n"; - | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; - | Tpat_alias (p, s,_) -> - line i ppf "Tpat_alias \"%a\"\n" fmt_ident s; - pattern i ppf p; - | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c; - | Tpat_tuple (l) -> - line i ppf "Tpat_tuple\n"; - list i pattern ppf l; - | Tpat_construct (li, _, po) -> - line i ppf "Tpat_construct %a\n" fmt_longident li; - list i pattern ppf po; - | Tpat_variant (l, po, _) -> - line i ppf "Tpat_variant \"%s\"\n" l; - option i pattern ppf po; - | Tpat_record (l, _c) -> - line i ppf "Tpat_record\n"; - list i longident_x_pattern ppf l; - | Tpat_array (l) -> - line i ppf "Tpat_array\n"; - list i pattern ppf l; - | Tpat_or (p1, p2, _) -> - line i ppf "Tpat_or\n"; - pattern i ppf p1; - pattern i ppf p2; - | Tpat_lazy p -> - line i ppf "Tpat_lazy\n"; - pattern i ppf p; - -and expression_extra i ppf x attrs = - match x with - | Texp_constraint ct -> - line i ppf "Texp_constraint\n"; - attributes i ppf attrs; - core_type i ppf ct; - | Texp_coerce (cto1, cto2) -> - line i ppf "Texp_coerce\n"; - attributes i ppf attrs; - option i core_type ppf cto1; - core_type i ppf cto2; - | Texp_open (ovf, m, _, _) -> - line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; - attributes i ppf attrs; - | Texp_poly cto -> - line i ppf "Texp_poly\n"; - attributes i ppf attrs; - option i core_type ppf cto; - | Texp_newtype s -> - line i ppf "Texp_newtype \"%s\"\n" s; - attributes i ppf attrs; - -and expression i ppf x = - line i ppf "expression %a\n" fmt_location x.exp_loc; - attributes i ppf x.exp_attributes; - let i = - List.fold_left (fun i (extra,_,attrs) -> - expression_extra i ppf extra attrs; i+1) - (i+1) x.exp_extra - in - match x.exp_desc with - | Texp_ident (li,_,_) -> line i ppf "Texp_ident %a\n" fmt_path li; - | Texp_instvar () -> assert false - | Texp_constant (c) -> line i ppf "Texp_constant %a\n" fmt_constant c; - | Texp_let (rf, l, e) -> - line i ppf "Texp_let %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - expression i ppf e; - | Texp_function { arg_label = p; param ; cases; partial = _; } -> - line i ppf "Texp_function\n"; - line i ppf "%a" Ident.print param; - arg_label i ppf p; - list i case ppf cases; - | Texp_apply (e, l) -> - line i ppf "Texp_apply\n"; - expression i ppf e; - list i label_x_expression ppf l; - | Texp_match (e, l1, l2, _partial) -> - line i ppf "Texp_match\n"; - expression i ppf e; - list i case ppf l1; - list i case ppf l2; - | Texp_try (e, l) -> - line i ppf "Texp_try\n"; - expression i ppf e; - list i case ppf l; - | Texp_tuple (l) -> - line i ppf "Texp_tuple\n"; - list i expression ppf l; - | Texp_construct (li, _, eo) -> - line i ppf "Texp_construct %a\n" fmt_longident li; - list i expression ppf eo; - | Texp_variant (l, eo) -> - line i ppf "Texp_variant \"%s\"\n" l; - option i expression ppf eo; - | Texp_record { fields; representation; extended_expression } -> - line i ppf "Texp_record\n"; - let i = i+1 in - line i ppf "fields =\n"; - array (i+1) record_field ppf fields; - line i ppf "representation =\n"; - record_representation (i+1) ppf representation; - line i ppf "extended_expression =\n"; - option (i+1) expression ppf extended_expression; - | Texp_field (e, li, _) -> - line i ppf "Texp_field\n"; - expression i ppf e; - longident i ppf li; - | Texp_setfield (e1, li, _, e2) -> - line i ppf "Texp_setfield\n"; - expression i ppf e1; - longident i ppf li; - expression i ppf e2; - | Texp_array (l) -> - line i ppf "Texp_array\n"; - list i expression ppf l; - | Texp_ifthenelse (e1, e2, eo) -> - line i ppf "Texp_ifthenelse\n"; - expression i ppf e1; - expression i ppf e2; - option i expression ppf eo; - | Texp_sequence (e1, e2) -> - line i ppf "Texp_sequence\n"; - expression i ppf e1; - expression i ppf e2; - | Texp_while (e1, e2) -> - line i ppf "Texp_while\n"; - expression i ppf e1; - expression i ppf e2; - | Texp_for (s, _, e1, e2, df, e3) -> - line i ppf "Texp_for \"%a\" %a\n" fmt_ident s fmt_direction_flag df; - expression i ppf e1; - expression i ppf e2; - expression i ppf e3; - | Texp_send (e, Tmeth_name s, eo) -> - line i ppf "Texp_send \"%s\"\n" s; - expression i ppf e; - option i expression ppf eo - | Texp_new _ - | Texp_setinstvar _ - | Texp_override _ -> - () - | Texp_letmodule (s, _, me, e) -> - line i ppf "Texp_letmodule \"%a\"\n" fmt_ident s; - module_expr i ppf me; - expression i ppf e; - | Texp_letexception (cd, e) -> - line i ppf "Texp_letexception\n"; - extension_constructor i ppf cd; - expression i ppf e; - | Texp_assert (e) -> - line i ppf "Texp_assert"; - expression i ppf e; - | Texp_lazy (e) -> - line i ppf "Texp_lazy"; - expression i ppf e; - | Texp_object () -> - () - | Texp_pack me -> - line i ppf "Texp_pack"; - module_expr i ppf me - | Texp_unreachable -> - line i ppf "Texp_unreachable" - | Texp_extension_constructor (li, _) -> - line i ppf "Texp_extension_constructor %a" fmt_longident li - -and value_description i ppf x = - line i ppf "value_description %a %a\n" fmt_ident x.val_id fmt_location - x.val_loc; - attributes i ppf x.val_attributes; - core_type (i+1) ppf x.val_desc; - list (i+1) string ppf x.val_prim; - -and type_parameter i ppf (x, _variance) = core_type i ppf x - -and type_declaration i ppf x = - line i ppf "type_declaration %a %a\n" fmt_ident x.typ_id fmt_location - x.typ_loc; - attributes i ppf x.typ_attributes; - let i = i+1 in - line i ppf "ptype_params =\n"; - list (i+1) type_parameter ppf x.typ_params; - line i ppf "ptype_cstrs =\n"; - list (i+1) core_type_x_core_type_x_location ppf x.typ_cstrs; - line i ppf "ptype_kind =\n"; - type_kind (i+1) ppf x.typ_kind; - line i ppf "ptype_private = %a\n" fmt_private_flag x.typ_private; - line i ppf "ptype_manifest =\n"; - option (i+1) core_type ppf x.typ_manifest; - -and type_kind i ppf x = - match x with - | Ttype_abstract -> - line i ppf "Ttype_abstract\n" - | Ttype_variant l -> - line i ppf "Ttype_variant\n"; - list (i+1) constructor_decl ppf l; - | Ttype_record l -> - line i ppf "Ttype_record\n"; - list (i+1) label_decl ppf l; - | Ttype_open -> - line i ppf "Ttype_open\n" - -and type_extension i ppf x = - line i ppf "type_extension\n"; - attributes i ppf x.tyext_attributes; - let i = i+1 in - line i ppf "ptyext_path = %a\n" fmt_path x.tyext_path; - line i ppf "ptyext_params =\n"; - list (i+1) type_parameter ppf x.tyext_params; - line i ppf "ptyext_constructors =\n"; - list (i+1) extension_constructor ppf x.tyext_constructors; - line i ppf "ptyext_private = %a\n" fmt_private_flag x.tyext_private; - -and extension_constructor i ppf x = - line i ppf "extension_constructor %a\n" fmt_location x.ext_loc; - attributes i ppf x.ext_attributes; - let i = i + 1 in - line i ppf "pext_name = \"%a\"\n" fmt_ident x.ext_id; - line i ppf "pext_kind =\n"; - extension_constructor_kind (i + 1) ppf x.ext_kind; - -and extension_constructor_kind i ppf x = - match x with - Text_decl(a, r) -> - line i ppf "Text_decl\n"; - constructor_arguments (i+1) ppf a; - option (i+1) core_type ppf r; - | Text_rebind(p, _) -> - line i ppf "Text_rebind\n"; - line (i+1) ppf "%a\n" fmt_path p; - -and class_type i ppf x = - line i ppf "class_type %a\n" fmt_location x.cltyp_loc; - attributes i ppf x.cltyp_attributes; - let i = i+1 in - match x.cltyp_desc with - | Tcty_constr (li, _, l) -> - line i ppf "Tcty_constr %a\n" fmt_path li; - list i core_type ppf l; - | Tcty_signature (cs) -> - line i ppf "Tcty_signature\n"; - class_signature i ppf cs; - | Tcty_arrow (l, co, cl) -> - line i ppf "Tcty_arrow\n"; - arg_label i ppf l; - core_type i ppf co; - class_type i ppf cl; - | Tcty_open (ovf, m, _, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; - class_type i ppf e - -and class_signature i ppf { csig_self = ct; csig_fields = l } = - line i ppf "class_signature\n"; - core_type (i+1) ppf ct; - list (i+1) class_type_field ppf l; - -and class_type_field i ppf x = - line i ppf "class_type_field %a\n" fmt_location x.ctf_loc; - let i = i+1 in - attributes i ppf x.ctf_attributes; - match x.ctf_desc with - | Tctf_inherit (ct) -> - line i ppf "Tctf_inherit\n"; - class_type i ppf ct; - | Tctf_val (s, mf, vf, ct) -> - line i ppf "Tctf_val \"%s\" %a %a\n" s fmt_mutable_flag mf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Tctf_method (s, pf, vf, ct) -> - line i ppf "Tctf_method \"%s\" %a %a\n" s fmt_private_flag pf - fmt_virtual_flag vf; - core_type (i+1) ppf ct; - | Tctf_constraint (ct1, ct2) -> - line i ppf "Tctf_constraint\n"; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - | Tctf_attribute (s, arg) -> - line i ppf "Tctf_attribute \"%s\"\n" s.txt; - Printast.payload i ppf arg - - -and class_type_declaration i ppf x = - line i ppf "class_type_declaration %a\n" fmt_location x.ci_loc; - let i = i+1 in - line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt; - line i ppf "pci_params =\n"; - list (i+1) type_parameter ppf x.ci_params; - line i ppf "pci_name = \"%s\"\n" x.ci_id_name.txt; - line i ppf "pci_expr =\n"; - class_type (i+1) ppf x.ci_expr; - - -and module_type i ppf x = - line i ppf "module_type %a\n" fmt_location x.mty_loc; - attributes i ppf x.mty_attributes; - let i = i+1 in - match x.mty_desc with - | Tmty_ident (li,_) -> line i ppf "Tmty_ident %a\n" fmt_path li; - | Tmty_alias (li,_) -> line i ppf "Tmty_alias %a\n" fmt_path li; - | Tmty_signature (s) -> - line i ppf "Tmty_signature\n"; - signature i ppf s; - | Tmty_functor (s, _, mt1, mt2) -> - line i ppf "Tmty_functor \"%a\"\n" fmt_ident s; - Misc.may (module_type i ppf) mt1; - module_type i ppf mt2; - | Tmty_with (mt, l) -> - line i ppf "Tmty_with\n"; - module_type i ppf mt; - list i longident_x_with_constraint ppf l; - | Tmty_typeof m -> - line i ppf "Tmty_typeof\n"; - module_expr i ppf m; - -and signature i ppf x = list i signature_item ppf x.sig_items - -and signature_item i ppf x = - line i ppf "signature_item %a\n" fmt_location x.sig_loc; - let i = i+1 in - match x.sig_desc with - | Tsig_value vd -> - line i ppf "Tsig_value\n"; - value_description i ppf vd; - | Tsig_type (rf, l) -> - line i ppf "Tsig_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Tsig_typext e -> - line i ppf "Tsig_typext\n"; - type_extension i ppf e; - | Tsig_exception ext -> - line i ppf "Tsig_exception\n"; - extension_constructor i ppf ext - | Tsig_module md -> - line i ppf "Tsig_module \"%a\"\n" fmt_ident md.md_id; - attributes i ppf md.md_attributes; - module_type i ppf md.md_type - | Tsig_recmodule decls -> - line i ppf "Tsig_recmodule\n"; - list i module_declaration ppf decls; - | Tsig_modtype x -> - line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; - attributes i ppf x.mtd_attributes; - modtype_declaration i ppf x.mtd_type - | Tsig_open od -> - line i ppf "Tsig_open %a %a\n" - fmt_override_flag od.open_override - fmt_path od.open_path; - attributes i ppf od.open_attributes - | Tsig_include incl -> - line i ppf "Tsig_include\n"; - attributes i ppf incl.incl_attributes; - module_type i ppf incl.incl_mod - | Tsig_class () -> - () - | Tsig_class_type (l) -> - line i ppf "Tsig_class_type\n"; - list i class_type_declaration ppf l; - | Tsig_attribute (s, arg) -> - line i ppf "Tsig_attribute \"%s\"\n" s.txt; - Printast.payload i ppf arg - -and module_declaration i ppf md = - line i ppf "%a" fmt_ident md.md_id; - attributes i ppf md.md_attributes; - module_type (i+1) ppf md.md_type; - -and module_binding i ppf x = - line i ppf "%a\n" fmt_ident x.mb_id; - attributes i ppf x.mb_attributes; - module_expr (i+1) ppf x.mb_expr - -and modtype_declaration i ppf = function - | None -> line i ppf "#abstract" - | Some mt -> module_type (i + 1) ppf mt - -and with_constraint i ppf x = - match x with - | Twith_type (td) -> - line i ppf "Twith_type\n"; - type_declaration (i+1) ppf td; - | Twith_typesubst (td) -> - line i ppf "Twith_typesubst\n"; - type_declaration (i+1) ppf td; - | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li; - | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li; - -and module_expr i ppf x = - line i ppf "module_expr %a\n" fmt_location x.mod_loc; - attributes i ppf x.mod_attributes; - let i = i+1 in - match x.mod_desc with - | Tmod_ident (li,_) -> line i ppf "Tmod_ident %a\n" fmt_path li; - | Tmod_structure (s) -> - line i ppf "Tmod_structure\n"; - structure i ppf s; - | Tmod_functor (s, _, mt, me) -> - line i ppf "Tmod_functor \"%a\"\n" fmt_ident s; - Misc.may (module_type i ppf) mt; - module_expr i ppf me; - | Tmod_apply (me1, me2, _) -> - line i ppf "Tmod_apply\n"; - module_expr i ppf me1; - module_expr i ppf me2; - | Tmod_constraint (me, _, Tmodtype_explicit mt, _) -> - line i ppf "Tmod_constraint\n"; - module_expr i ppf me; - module_type i ppf mt; - | Tmod_constraint (me, _, Tmodtype_implicit, _) -> module_expr i ppf me - | Tmod_unpack (e, _) -> - line i ppf "Tmod_unpack\n"; - expression i ppf e; - -and structure i ppf x = list i structure_item ppf x.str_items - -and structure_item i ppf x = - line i ppf "structure_item %a\n" fmt_location x.str_loc; - let i = i+1 in - match x.str_desc with - | Tstr_eval (e, attrs) -> - line i ppf "Tstr_eval\n"; - attributes i ppf attrs; - expression i ppf e; - | Tstr_value (rf, l) -> - line i ppf "Tstr_value %a\n" fmt_rec_flag rf; - list i value_binding ppf l; - | Tstr_primitive vd -> - line i ppf "Tstr_primitive\n"; - value_description i ppf vd; - | Tstr_type (rf, l) -> - line i ppf "Tstr_type %a\n" fmt_rec_flag rf; - list i type_declaration ppf l; - | Tstr_typext te -> - line i ppf "Tstr_typext\n"; - type_extension i ppf te - | Tstr_exception ext -> - line i ppf "Tstr_exception\n"; - extension_constructor i ppf ext; - | Tstr_module x -> - line i ppf "Tstr_module\n"; - module_binding i ppf x - | Tstr_recmodule bindings -> - line i ppf "Tstr_recmodule\n"; - list i module_binding ppf bindings - | Tstr_modtype x -> - line i ppf "Tstr_modtype \"%a\"\n" fmt_ident x.mtd_id; - attributes i ppf x.mtd_attributes; - modtype_declaration i ppf x.mtd_type - | Tstr_open od -> - line i ppf "Tstr_open %a %a\n" - fmt_override_flag od.open_override - fmt_path od.open_path; - attributes i ppf od.open_attributes - | Tstr_class () -> () - | Tstr_class_type (l) -> - line i ppf "Tstr_class_type\n"; - list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l); - | Tstr_include incl -> - line i ppf "Tstr_include"; - attributes i ppf incl.incl_attributes; - module_expr i ppf incl.incl_mod; - | Tstr_attribute (s, arg) -> - line i ppf "Tstr_attribute \"%s\"\n" s.txt; - Printast.payload i ppf arg - -and longident_x_with_constraint i ppf (li, _, wc) = - line i ppf "%a\n" fmt_path li; - with_constraint (i+1) ppf wc; - -and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = - line i ppf " %a\n" fmt_location l; - core_type (i+1) ppf ct1; - core_type (i+1) ppf ct2; - -and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; - cd_attributes} = - line i ppf "%a\n" fmt_location cd_loc; - line (i+1) ppf "%a\n" fmt_ident cd_id; - attributes i ppf cd_attributes; - constructor_arguments (i+1) ppf cd_args; - option (i+1) core_type ppf cd_res - -and constructor_arguments i ppf = function - | Cstr_tuple l -> list i core_type ppf l - | Cstr_record l -> list i label_decl ppf l - -and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; - ld_attributes} = - line i ppf "%a\n" fmt_location ld_loc; - attributes i ppf ld_attributes; - line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable; - line (i+1) ppf "%a" fmt_ident ld_id; - core_type (i+1) ppf ld_type - -and longident_x_pattern i ppf (li, _, p) = - line i ppf "%a\n" fmt_longident li; - pattern (i+1) ppf p; - -and case i ppf {c_lhs; c_guard; c_rhs} = - line i ppf "\n"; - pattern (i+1) ppf c_lhs; - begin match c_guard with - | None -> () - | Some g -> line (i+1) ppf "\n"; expression (i + 2) ppf g - end; - expression (i+1) ppf c_rhs; - -and value_binding i ppf x = - line i ppf "\n"; - attributes (i+1) ppf x.vb_attributes; - pattern (i+1) ppf x.vb_pat; - expression (i+1) ppf x.vb_expr - - -and record_field i ppf = function - | _, Overridden (li, e) -> - line i ppf "%a\n" fmt_longident li; - expression (i+1) ppf e; - | _, Kept _ -> - line i ppf "" - -and label_x_expression i ppf (l, e) = - line i ppf "\n"; - arg_label (i+1) ppf l; - (match e with None -> () | Some e -> expression (i+1) ppf e) - -and label_x_bool_x_core_type_list i ppf x = - match x with - Ttag (l, attrs, b, ctl) -> - line i ppf "Ttag \"%s\" %s\n" l.txt (string_of_bool b); - attributes (i+1) ppf attrs; - list (i+1) core_type ppf ctl - | Tinherit (ct) -> - line i ppf "Tinherit\n"; - core_type (i+1) ppf ct -;; - -let interface ppf x = list 0 signature_item ppf x.sig_items;; - -let implementation ppf x = list 0 structure_item ppf x.str_items;; - -let implementation_with_coercion ppf (x, _) = implementation ppf x diff --git a/jscomp/ml/rec_check.ml b/jscomp/ml/rec_check.ml deleted file mode 100644 index 161afcd..0000000 --- a/jscomp/ml/rec_check.ml +++ /dev/null @@ -1,474 +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. *) -(* *) -(**************************************************************************) - -type error = Illegal_letrec_expr - -exception Error of Location.t * error - -module Rec_context = struct - type access = - | Dereferenced - (** [Dereferenced] indicates that the value (not just the address) of a - variable is accessed *) - | Guarded - (** [Guarded] indicates that the address of a variable is used in a - guarded context, i.e. under a constructor. A variable that is - dereferenced within a function body or lazy context is also considered - guarded. *) - | Unguarded - (** [Unguarded] indicates that the address of a variable is used in an - unguarded context, i.e. not under a constructor. *) - - (** [guard] represents guarded contexts such as [C -] and [{l = -}] *) - let guard : access -> access = function - | Dereferenced -> Dereferenced - | Guarded -> Guarded - | Unguarded -> Guarded - - (** [inspect] represents elimination contexts such as [match - with cases], - [e -] and [- e] *) - let inspect : access -> access = function - | Dereferenced -> Dereferenced - | Guarded -> Dereferenced - | Unguarded -> Dereferenced - - (** [delay] represents contexts that delay evaluation such as [fun p -> -] - or [lazy -] *) - let delay : access -> access = function - | Dereferenced -> Guarded - | Guarded -> Guarded - | Unguarded -> Guarded - - module Use : sig - type t - - val guard : t -> t - (** An expression appears in a guarded context *) - - val discard : t -> t - (** The address of a subexpression is not used, but may be bound *) - - val inspect : t -> t - (** The value of a subexpression is inspected with match, application, etc. *) - - val delay : t -> t - (** An expression appears under 'fun p ->' or 'lazy' *) - - val join : t -> t -> t - (** Combine the access information of two expressions *) - - val single : Ident.t -> access -> t - (** Combine the access information of two expressions *) - - val empty : t - (** No variables are accessed in an expression; it might be a - constant or a global identifier *) - - val unguarded : t -> Ident.t list - (** The list of identifiers that are used in an unguarded context *) - - val dependent : t -> Ident.t list - (** The list of all used identifiers *) - end = struct - module M = Map.Make (Ident) - - type t = access M.t - (** A "t" maps each rec-bound variable to an access status *) - - let map f tbl = M.map f tbl - - let guard t = map guard t - - let inspect t = map inspect t - - let delay t = map delay t - - let discard = guard - - let prec x y = - match (x, y) with - | Dereferenced, _ | _, Dereferenced -> Dereferenced - | Unguarded, _ | _, Unguarded -> Unguarded - | _ -> Guarded - - let join x y = - M.fold - (fun id v tbl -> - let v' = try M.find id tbl with Not_found -> Guarded in - M.add id (prec v v') tbl) - x y - - let single id access = M.add id access M.empty - - let empty = M.empty - - let list_matching p t = - let r = ref [] in - M.iter (fun id v -> if p v then r := id :: !r) t; - !r - - let unguarded = - list_matching (function Unguarded | Dereferenced -> true | _ -> false) - - let dependent = list_matching (function _ -> true) - end - - module Env = struct - (* A typing environment maps identifiers to types *) - type env = Use.t Ident.tbl - - let empty = Ident.empty - - let join x y = - let r = - Ident.fold_all - (fun id v tbl -> - let v' = try Ident.find_same id tbl with Not_found -> Use.empty in - Ident.add id (Use.join v v') tbl) - x y - in - r - end -end - -let rec pattern_variables : Typedtree.pattern -> Ident.t list = - fun pat -> - match pat.pat_desc with - | Tpat_any -> [] - | Tpat_var (id, _) -> [ id ] - | Tpat_alias (pat, id, _) -> id :: pattern_variables pat - | Tpat_constant _ -> [] - | Tpat_tuple pats -> List.concat (List.map pattern_variables pats) - | Tpat_construct (_, _, pats) -> List.concat (List.map pattern_variables pats) - | Tpat_variant (_, Some pat, _) -> pattern_variables pat - | Tpat_variant (_, None, _) -> [] - | Tpat_record (fields, _) -> - List.concat (List.map (fun (_, _, p) -> pattern_variables p) fields) - | Tpat_array pats -> List.concat (List.map pattern_variables pats) - | Tpat_or (l, r, _) -> pattern_variables l @ pattern_variables r - | Tpat_lazy p -> pattern_variables p - -open Rec_context -open Asttypes -open Typedtree - -let build_unguarded_env : Ident.t list -> Env.env = - fun idlist -> - List.fold_left - (fun env id -> Ident.add id (Use.single id Unguarded) env) - Env.empty idlist - -let is_ref : Types.value_description -> bool = function - | { - Types.val_kind = - Types.Val_prim { Primitive.prim_name = "%makemutable"; prim_arity = 1 }; - } -> - true - | _ -> false - -type sd = Static | Dynamic - -let rec classify_expression : Typedtree.expression -> sd = - fun exp -> - match exp.exp_desc with - | Texp_let (_, _, e) - | Texp_letmodule (_, _, _, e) - | Texp_sequence (_, e) - | Texp_letexception (_, e) -> - classify_expression e - | Texp_ident _ | Texp_for _ | Texp_constant _ | Texp_new _ | Texp_instvar _ - | Texp_tuple _ | Texp_array _ | Texp_construct _ | Texp_variant _ - | Texp_record _ | Texp_setfield _ | Texp_while _ | Texp_setinstvar _ - | Texp_pack _ | Texp_object _ | Texp_function _ | Texp_lazy _ - | Texp_unreachable | Texp_extension_constructor _ -> - Static - | Texp_apply ({ exp_desc = Texp_ident (_, _, vd) }, _) when is_ref vd -> - Static - | Texp_apply _ | Texp_match _ | Texp_ifthenelse _ | Texp_send _ | Texp_field _ - | Texp_assert _ | Texp_try _ | Texp_override _ -> - Dynamic - -let rec expression : Env.env -> Typedtree.expression -> Use.t = - fun env exp -> - match exp.exp_desc with - | Texp_ident (pth, _, _) -> path env pth - | Texp_let (rec_flag, bindings, body) -> - let env', ty = value_bindings rec_flag env bindings in - (* Here and in other binding constructs 'discard' is used in a - similar way to the way it's used in sequence: uses are - propagated, but unguarded access are not. *) - Use.join (Use.discard ty) (expression (Env.join env env') body) - | Texp_letmodule (x, _, m, e) -> - let ty = modexp env m in - Use.join (Use.discard ty) (expression (Ident.add x ty env) e) - | Texp_match (e, val_cases, exn_cases, _) -> - let t = expression env e in - let exn_case env { Typedtree.c_rhs } = expression env c_rhs in - let cs = list (case ~scrutinee:t) env val_cases - and es = list exn_case env exn_cases in - Use.(join cs es) - | Texp_for (_, _, e1, e2, _, e3) -> - Use.( - join - (join (inspect (expression env e1)) (inspect (expression env e2))) - (* The body is evaluated, but not used, and not available - for inclusion in another value *) - (discard (expression env e3))) - | Texp_constant _ -> Use.empty - | Texp_new _ -> assert false - | Texp_instvar _ -> Use.empty - | Texp_apply ({ exp_desc = Texp_ident (_, _, vd) }, [ (_, Some arg) ]) - when is_ref vd -> - Use.guard (expression env arg) - | Texp_apply (e, args) -> - let arg env (_, eo) = option expression env eo in - Use.(join (inspect (expression env e)) (inspect (list arg env args))) - | Texp_tuple exprs -> Use.guard (list expression env exprs) - | Texp_array exprs -> Use.guard (list expression env exprs) - | Texp_construct (_, desc, exprs) -> - let access_constructor = - match desc.cstr_tag with - | Cstr_extension (pth, _) -> Use.inspect (path env pth) - | _ -> Use.empty - in - let use = - match desc.cstr_tag with - | Cstr_unboxed -> fun x -> x - | Cstr_constant _ | Cstr_block _ | Cstr_extension _ -> Use.guard - in - Use.join access_constructor (use (list expression env exprs)) - | Texp_variant (_, eo) -> Use.guard (option expression env eo) - | Texp_record { fields = es; extended_expression = eo; representation = rep } - -> - let use = - match rep with - | Record_unboxed _ -> fun x -> x - | Record_float_unused -> assert false - | Record_optional_labels _ | Record_regular | Record_inlined _ | Record_extension - -> - Use.guard - in - let field env = function - | _, Kept _ -> Use.empty - | _, Overridden (_, e) -> expression env e - in - Use.join (use (array field env es)) (option expression env eo) - | Texp_ifthenelse (cond, ifso, ifnot) -> - Use.( - join - (inspect (expression env cond)) - (join (expression env ifso) (option expression env ifnot))) - | Texp_setfield (e1, _, _, e2) -> - Use.(join (inspect (expression env e1)) (inspect (expression env e2))) - | Texp_sequence (e1, e2) -> - Use.(join (discard (expression env e1)) (expression env e2)) - | Texp_while (e1, e2) -> - Use.(join (inspect (expression env e1)) (discard (expression env e2))) - | Texp_send (e1, _, eo) -> - Use.( - join (inspect (expression env e1)) (inspect (option expression env eo))) - | Texp_field (e, _, _) -> Use.(inspect (expression env e)) - | Texp_setinstvar () -> assert false - | Texp_letexception (_, e) -> expression env e - | Texp_assert e -> Use.inspect (expression env e) - | Texp_pack m -> modexp env m - | Texp_object () -> assert false - | Texp_try (e, cases) -> - (* This is more permissive than the old check. *) - let case env { Typedtree.c_rhs } = expression env c_rhs in - Use.join (expression env e) (list case env cases) - | Texp_override () -> assert false - | Texp_function { cases } -> - Use.delay (list (case ~scrutinee:Use.empty) env cases) - | Texp_lazy e -> ( - match Typeopt.classify_lazy_argument e with - | `Constant_or_function | `Identifier _ | `Float -> expression env e - | `Other -> Use.delay (expression env e)) - | Texp_unreachable -> Use.empty - | Texp_extension_constructor _ -> Use.empty - -and option : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a option -> Use.t = - fun f env -> Misc.Stdlib.Option.value_default (f env) ~default:Use.empty - -and list : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a list -> Use.t = - fun f env -> - List.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty - -and array : 'a. (Env.env -> 'a -> Use.t) -> Env.env -> 'a array -> Use.t = - fun f env -> - Array.fold_left (fun typ item -> Use.join (f env item) typ) Use.empty - -and modexp : Env.env -> Typedtree.module_expr -> Use.t = - fun env m -> - match m.mod_desc with - | Tmod_ident (pth, _) -> path env pth - | Tmod_structure s -> structure env s - | Tmod_functor (_, _, _, e) -> Use.delay (modexp env e) - | Tmod_apply (f, p, _) -> - Use.(join (inspect (modexp env f)) (inspect (modexp env p))) - | Tmod_constraint (m, _, _, Tcoerce_none) -> modexp env m - | Tmod_constraint (m, _, _, _) -> Use.inspect (modexp env m) - | Tmod_unpack (e, _) -> expression env e - -and path : Env.env -> Path.t -> Use.t = - fun env pth -> - match pth with - | Path.Pident x -> ( try Ident.find_same x env with Not_found -> Use.empty) - | Path.Pdot (t, _, _) -> Use.inspect (path env t) - | Path.Papply (f, p) -> Use.(inspect (join (path env f) (path env p))) - -and structure : Env.env -> Typedtree.structure -> Use.t = - fun env s -> - let _, ty = - List.fold_left - (fun (env, ty) item -> - let env', ty' = structure_item env item in - (Env.join env env', Use.join ty ty')) - (env, Use.empty) s.str_items - in - Use.guard ty - -and structure_item : Env.env -> Typedtree.structure_item -> Env.env * Use.t = - fun env s -> - match s.str_desc with - | Tstr_eval (e, _) -> (Env.empty, expression env e) - | Tstr_value (rec_flag, valbinds) -> value_bindings rec_flag env valbinds - | Tstr_module { mb_id; mb_expr } -> - let ty = modexp env mb_expr in - (Ident.add mb_id ty Env.empty, ty) - | Tstr_recmodule mbs -> - let modbind env { mb_expr } = modexp env mb_expr in - (* Over-approximate: treat any access as a use *) - (Env.empty, Use.inspect (list modbind env mbs)) - | Tstr_primitive _ -> (Env.empty, Use.empty) - | Tstr_type _ -> (Env.empty, Use.empty) - | Tstr_typext _ -> (Env.empty, Use.empty) - | Tstr_exception _ -> (Env.empty, Use.empty) - | Tstr_modtype _ -> (Env.empty, Use.empty) - | Tstr_open _ -> (Env.empty, Use.empty) - | Tstr_class () -> (Env.empty, Use.empty) - | Tstr_class_type _ -> (Env.empty, Use.empty) - | Tstr_include inc -> - (* This is a kind of projection. There's no need to add - anything to the environment because everything is used in - the type component already *) - (Env.empty, Use.inspect (modexp env inc.incl_mod)) - | Tstr_attribute _ -> (Env.empty, Use.empty) - -and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t = - fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty -> - let ty = - if is_destructuring_pattern c_lhs then Use.inspect ty else Use.discard ty - (* as in 'let' *) - in - let vars = pattern_variables c_lhs in - let env = List.fold_left (fun env id -> Ident.add id ty env) env vars in - Use.( - join ty - (join (expression env c_rhs) (inspect (option expression env c_guard)))) - -and value_bindings : - rec_flag -> Env.env -> Typedtree.value_binding list -> Env.env * Use.t = - fun rec_flag env bindings -> - match rec_flag with - | Recursive -> - (* Approximation: - let rec y = - let rec x1 = e1 - and x2 = e2 - in e - treated as - let rec y = - let rec x = (e1, e2)[x1:=fst x, x2:=snd x] in - e[x1:=fst x, x2:=snd x] - Further, use the fact that x1,x2 cannot occur unguarded in e1, e2 - to avoid recursive trickiness. - *) - let ids, ty = - List.fold_left - (fun (pats, tys) { vb_pat = p; vb_expr = e } -> - (pattern_variables p @ pats, Use.join (expression env e) tys)) - ([], Use.empty) bindings - in - ( List.fold_left - (fun (env : Env.env) (id : Ident.t) -> Ident.add id ty env) - Env.empty ids, - ty ) - | Nonrecursive -> - List.fold_left - (fun (env2, ty) binding -> - let env', ty' = value_binding env binding in - (Env.join env2 env', Use.join ty ty')) - (Env.empty, Use.empty) bindings - -and value_binding : Env.env -> Typedtree.value_binding -> Env.env * Use.t = - (* NB: returns new environment only *) - fun env { vb_pat; vb_expr } -> - let vars = pattern_variables vb_pat in - let ty = expression env vb_expr in - let ty = if is_destructuring_pattern vb_pat then Use.inspect ty else ty in - (List.fold_left (fun env id -> Ident.add id ty env) Env.empty vars, ty) - -and is_destructuring_pattern : Typedtree.pattern -> bool = - fun pat -> - match pat.pat_desc with - | Tpat_any -> false - | Tpat_var (_, _) -> false - | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat - | Tpat_constant _ -> true - | Tpat_tuple _ -> true - | Tpat_construct (_, _, _) -> true - | Tpat_variant _ -> true - | Tpat_record (_, _) -> true - | Tpat_array _ -> true - | Tpat_or (l, r, _) -> - is_destructuring_pattern l || is_destructuring_pattern r - | Tpat_lazy _ -> true - -let check_recursive_expression idlist expr = - let ty = expression (build_unguarded_env idlist) expr in - match (Use.unguarded ty, Use.dependent ty, classify_expression expr) with - | _ :: _, _, _ (* The expression inspects rec-bound variables *) - | _, _ :: _, Dynamic -> - (* The expression depends on rec-bound variables - and its size is unknown *) - raise (Error (expr.exp_loc, Illegal_letrec_expr)) - | [], _, Static (* The expression has known size *) | [], [], Dynamic -> - (* The expression has unknown size, - but does not depend on rec-bound variables *) - () - -let check_recursive_bindings valbinds = - let ids = - List.concat (List.map (fun b -> pattern_variables b.vb_pat) valbinds) - in - Ext_list.iter valbinds (fun { vb_expr } -> - match vb_expr.exp_desc with - | Texp_record - { fields = [| (_, Overridden (_, { exp_desc = Texp_function _ })) |] } - | Texp_function _ -> - () - (*TODO: add uncurried function too*) - | _ -> check_recursive_expression ids vb_expr) - -let report_error ppf = function - | Illegal_letrec_expr -> - Format.fprintf ppf - "This kind of expression is not allowed as right-hand side of `let rec'" - -let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) - | _ -> None) diff --git a/jscomp/ml/rec_check.mli b/jscomp/ml/rec_check.mli deleted file mode 100644 index f37e891..0000000 --- a/jscomp/ml/rec_check.mli +++ /dev/null @@ -1,4 +0,0 @@ - - - -val check_recursive_bindings : Typedtree.value_binding list -> unit diff --git a/jscomp/ml/record_coercion.ml b/jscomp/ml/record_coercion.ml deleted file mode 100644 index 338749e..0000000 --- a/jscomp/ml/record_coercion.ml +++ /dev/null @@ -1,33 +0,0 @@ -let check_record_fields ?repr1 ?repr2 (fields1 : Types.label_declaration list) - (fields2 : Types.label_declaration list) = - let field_is_optional id repr = - match repr with - | Some (Types.Record_optional_labels lbls) -> List.mem (Ident.name id) lbls - | _ -> false - in - let violation = ref false in - let label_decl_sub (acc1, acc2) (ld2 : Types.label_declaration) = - match - Ext_list.find_first fields1 (fun ld1 -> ld1.ld_id.name = ld2.ld_id.name) - with - | Some ld1 -> - if field_is_optional ld1.ld_id repr1 <> field_is_optional ld2.ld_id repr2 - then (* optional field can't be modified *) - violation := true; - let get_as (({txt}, payload) : Parsetree.attribute) = - if txt = "as" then Ast_payload.is_single_string payload else None - in - let get_as_name (ld : Types.label_declaration) = - match Ext_list.filter_map ld.ld_attributes get_as with - | [] -> ld.ld_id.name - | (s, _) :: _ -> s - in - if get_as_name ld1 <> get_as_name ld2 then violation := true; - (ld1.ld_type :: acc1, ld2.ld_type :: acc2) - | None -> - (* field must be present *) - violation := true; - (acc1, acc2) - in - let tl1, tl2 = List.fold_left label_decl_sub ([], []) fields2 in - (!violation, tl1, tl2) \ No newline at end of file diff --git a/jscomp/ml/record_type_spread.ml b/jscomp/ml/record_type_spread.ml deleted file mode 100644 index 76cc710..0000000 --- a/jscomp/ml/record_type_spread.ml +++ /dev/null @@ -1,88 +0,0 @@ -module StringMap = Map.Make (String) - -let t_equals t1 t2 = t1.Types.level = t2.Types.level && t1.id = t2.id - -let substitute_types ~type_map (t : Types.type_expr) = - if StringMap.is_empty type_map then t - else - let apply_substitution type_variable_name t = - match StringMap.find_opt type_variable_name type_map with - | None -> t - | Some substituted_type -> substituted_type - in - let rec loop (t : Types.type_expr) = - match t.desc with - | Tlink t -> {t with desc = Tlink (loop t)} - | Tvar (Some type_variable_name) -> - apply_substitution type_variable_name t - | Tvar None -> t - | Tunivar _ -> t - | Tconstr (path, args, _memo) -> - {t with desc = Tconstr (path, args |> List.map loop, ref Types.Mnil)} - | Tsubst t -> {t with desc = Tsubst (loop t)} - | Tvariant rd -> {t with desc = Tvariant (row_desc rd)} - | Tnil -> t - | Tarrow (lbl, t1, t2, c) -> - {t with desc = Tarrow (lbl, loop t1, loop t2, c)} - | Ttuple tl -> {t with desc = Ttuple (tl |> List.map loop)} - | Tobject (t, r) -> {t with desc = Tobject (loop t, r)} - | Tfield (n, k, t1, t2) -> {t with desc = Tfield (n, k, loop t1, loop t2)} - | Tpoly (t, []) -> loop t - | Tpoly (t, tl) -> {t with desc = Tpoly (loop t, tl |> List.map loop)} - | Tpackage (p, l, tl) -> - {t with desc = Tpackage (p, l, tl |> List.map loop)} - and row_desc (rd : Types.row_desc) = - let row_fields = - rd.row_fields |> List.map (fun (l, rf) -> (l, row_field rf)) - in - let row_more = loop rd.row_more in - let row_name = - match rd.row_name with - | None -> None - | Some (p, tl) -> Some (p, tl |> List.map loop) - in - {rd with row_fields; row_more; row_name} - and row_field (rf : Types.row_field) = - match rf with - | Rpresent None -> rf - | Rpresent (Some t) -> Rpresent (Some (loop t)) - | Reither (b1, tl, b2, r) -> Reither (b1, tl |> List.map loop, b2, r) - | Rabsent -> Rabsent - in - loop t - -let substitute_type_vars (type_vars : (string * Types.type_expr) list) - (typ : Types.type_expr) = - let type_map = - type_vars - |> List.fold_left - (fun acc (tvar_name, tvar_typ) -> StringMap.add tvar_name tvar_typ acc) - StringMap.empty - in - substitute_types ~type_map typ - -let has_type_spread (lbls : Typedtree.label_declaration list) = - lbls - |> List.exists (fun (l : Typedtree.label_declaration) -> - match l with - | {ld_name = {txt = "..."}} -> true - | _ -> false) - -let extract_type_vars (type_params : Types.type_expr list) - (typ : Types.type_expr) = - (* The type variables applied to the record spread itself. *) - let applied_type_vars = - match Ctype.repr typ with - | {desc = Tpoly ({desc = Tconstr (_, tvars, _)}, _)} -> tvars - | _ -> [] - in - if List.length type_params = List.length applied_type_vars then - (* Track which type param in the record we're spreading - belongs to which type variable applied to the spread itself. *) - let paired_type_vars = List.combine type_params applied_type_vars in - paired_type_vars - |> List.filter_map (fun (t, applied_tvar) -> - match t.Types.desc with - | Tvar (Some tname) -> Some (tname, applied_tvar) - | _ -> None) - else [] \ No newline at end of file diff --git a/jscomp/ml/rescript_cpp.ml b/jscomp/ml/rescript_cpp.ml deleted file mode 100644 index 71938df..0000000 --- a/jscomp/ml/rescript_cpp.ml +++ /dev/null @@ -1,572 +0,0 @@ -(* Copyright (C) 2021- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -type directive_type = - | Dir_type_bool - | Dir_type_float - | Dir_type_int - | Dir_type_string - | Dir_type_null - -type pp_error = - | Unterminated_paren_in_conditional - | Unterminated_if - | Unterminated_else - | Unexpected_token_in_conditional - | Expect_hash_then_in_conditional - | Illegal_semver of string - | Unexpected_directive - | Conditional_expr_expected_type of directive_type * directive_type - -exception Pp_error of pp_error * Location.t - -type directive_value = - | Dir_bool of bool - | Dir_float of float - | Dir_int of int - | Dir_string of string - | Dir_null - -let type_of_directive x = - match x with - | Dir_bool _ -> Dir_type_bool - | Dir_float _ -> Dir_type_float - | Dir_int _ -> Dir_type_int - | Dir_string _ -> Dir_type_string - | Dir_null -> Dir_type_null - -let string_of_type_directive x = - match x with - | Dir_type_bool -> "bool" - | Dir_type_float -> "float" - | Dir_type_int -> "int" - | Dir_type_string -> "string" - | Dir_type_null -> "null" - -let prepare_pp_error loc = function - | Unterminated_if -> Location.errorf ~loc "#if not terminated" - | Unterminated_else -> Location.errorf ~loc "#else not terminated" - | Unexpected_directive -> Location.errorf ~loc "Unexpected directive" - | Unexpected_token_in_conditional -> - Location.errorf ~loc "Unexpected token in conditional predicate" - | Unterminated_paren_in_conditional -> - Location.errorf ~loc "Unterminated parens in conditional predicate" - | Expect_hash_then_in_conditional -> - Location.errorf ~loc "Expect `then` after conditional predicate" - | Conditional_expr_expected_type (a, b) -> - Location.errorf ~loc "Conditional expression type mismatch (%s,%s)" - (string_of_type_directive a) - (string_of_type_directive b) - | Illegal_semver s -> - Location.errorf ~loc "Illegal semantic version string %s" s - -let () = - Location.register_error_of_exn (function - | Pp_error (err, loc) -> Some (prepare_pp_error loc err) - | _ -> None) - -let assert_same_type lexbuf x y = - let lhs = type_of_directive x in - let rhs = type_of_directive y in - if lhs <> rhs then - raise - (Pp_error (Conditional_expr_expected_type (lhs, rhs), Location.curr lexbuf)) - else y - -let directive_built_in_values = Hashtbl.create 51 - -let replace_directive_built_in_value k v = - Hashtbl.replace directive_built_in_values k v - -let remove_directive_built_in_value k = - Hashtbl.replace directive_built_in_values k Dir_null - -let replace_directive_bool k v = - Hashtbl.replace directive_built_in_values k (Dir_bool v) - -let replace_directive_string k v = - Hashtbl.replace directive_built_in_values k (Dir_string v) - -let () = - (* Note we use {!Config} instead of {!Sys} becasue - we want to overwrite in some cases with the - same stdlib - *) - let version = Config.version (* so that it can be overridden*) in - replace_directive_built_in_value "OCAML_VERSION" (Dir_string version); - replace_directive_built_in_value "OS_TYPE" (Dir_string Sys.os_type) - -let find_directive_built_in_value k = Hashtbl.find directive_built_in_values k - -let iter_directive_built_in_value f = Hashtbl.iter f directive_built_in_values -(* let iter_directive_built_in_value f = Hashtbl.iter f directive_built_in_values *) - -(* - {[ - # semver 0 "12";; - - : int * int * int * string = (12, 0, 0, "");; - # semver 0 "12.3";; - - : int * int * int * string = (12, 3, 0, "");; - semver 0 "12.3.10";; - - : int * int * int * string = (12, 3, 10, "");; - # semver 0 "12.3.10+x";; - - : int * int * int * string = (12, 3, 10, "+x") - ]} - *) -let zero = Char.code '0' - -let dot = Char.code '.' - -let semantic_version_parse str start last_index = - let rec aux start acc last_index = - if start <= last_index then - let c = Char.code (String.unsafe_get str start) in - if c = dot then (acc, start + 1) (* consume [4.] instead of [4]*) - else - let v = c - zero in - if v >= 0 && v <= 9 then aux (start + 1) ((acc * 10) + v) last_index - else (acc, start) - else (acc, start) - in - let major, major_end = aux start 0 last_index in - let minor, minor_end = aux major_end 0 last_index in - let patch, patch_end = aux minor_end 0 last_index in - let additional = String.sub str patch_end (last_index - patch_end + 1) in - ((major, minor, patch), additional) - -(** - {[ - semver Location.none "1.2.3" "~1.3.0" = false;; - semver Location.none "1.2.3" "^1.3.0" = true ;; - semver Location.none "1.2.3" ">1.3.0" = false ;; - semver Location.none "1.2.3" ">=1.3.0" = false ;; - semver Location.none "1.2.3" "<1.3.0" = true ;; - semver Location.none "1.2.3" "<=1.3.0" = true ;; - ]} - *) -let semver loc lhs str = - let last_index = String.length str - 1 in - if last_index < 0 then raise (Pp_error (Illegal_semver str, loc)) - else - let pred, (((major, minor, _patch) as version), _) = - let v = String.unsafe_get str 0 in - match v with - | '>' -> - if last_index = 0 then raise (Pp_error (Illegal_semver str, loc)) - else if String.unsafe_get str 1 = '=' then - (`Ge, semantic_version_parse str 2 last_index) - else (`Gt, semantic_version_parse str 1 last_index) - | '<' -> - if last_index = 0 then raise (Pp_error (Illegal_semver str, loc)) - else if String.unsafe_get str 1 = '=' then - (`Le, semantic_version_parse str 2 last_index) - else (`Lt, semantic_version_parse str 1 last_index) - | '^' -> (`Compatible, semantic_version_parse str 1 last_index) - | '~' -> (`Approximate, semantic_version_parse str 1 last_index) - | _ -> (`Exact, semantic_version_parse str 0 last_index) - in - let ((l_major, l_minor, _l_patch) as lversion), _ = - semantic_version_parse lhs 0 (String.length lhs - 1) - in - match pred with - | `Ge -> lversion >= version - | `Gt -> lversion > version - | `Le -> lversion <= version - | `Lt -> lversion < version - | `Approximate -> major = l_major && minor = l_minor - | `Compatible -> major = l_major - | `Exact -> lversion = version - -let pp_directive_value fmt (x : directive_value) = - match x with - | Dir_bool b -> Format.pp_print_bool fmt b - | Dir_int b -> Format.pp_print_int fmt b - | Dir_float b -> Format.pp_print_float fmt b - | Dir_string s -> Format.fprintf fmt "%S" s - | Dir_null -> Format.pp_print_string fmt "null" - -let list_variables fmt = - iter_directive_built_in_value (fun s dir_value -> - Format.fprintf fmt "@[%s@ %a@]@." s pp_directive_value dir_value) - -let defined str = - match find_directive_built_in_value str with - | Dir_null -> false - | _ -> true - | exception _ -> ( - try - ignore @@ Sys.getenv str; - true - with _ -> false) - -let query _loc str = - match find_directive_built_in_value str with - | Dir_null -> Dir_bool false - | v -> v - | exception Not_found -> ( - match Sys.getenv str with - | v -> ( - try Dir_bool (bool_of_string v) - with _ -> ( - try Dir_int (int_of_string v) - with _ -> ( - try Dir_float (float_of_string v) with _ -> Dir_string v))) - | exception Not_found -> Dir_bool false) - -let define_key_value key v = - if String.length key > 0 && Char.uppercase_ascii key.[0] = key.[0] then ( - replace_directive_built_in_value key - (* NEED Sync up across {!lexer.mll} {!bspp.ml} and here, - TODO: put it in {!lexer.mll} - *) - (try Dir_bool (bool_of_string v) - with _ -> ( - try Dir_int (int_of_string v) - with _ -> ( - try Dir_float (float_of_string v) with _ -> Dir_string v))); - true) - else false - -let cvt_int_literal s = -int_of_string ("-" ^ s) - -let value_of_token loc (t : Parser.token) = - match t with - | INT (i, None) -> Dir_int (cvt_int_literal i) - | STRING (s, _) -> Dir_string s - | FLOAT (s, None) -> Dir_float (float_of_string s) - | TRUE -> Dir_bool true - | FALSE -> Dir_bool false - | UIDENT s -> query loc s - | _ -> raise (Pp_error (Unexpected_token_in_conditional, loc)) - -let directive_parse (token_with_comments : Lexing.lexbuf -> Parser.token) lexbuf - = - let look_ahead = ref None in - let token () : Parser.token = - let v = !look_ahead in - match v with - | Some v -> - look_ahead := None; - v - | None -> - let rec skip () = - match token_with_comments lexbuf with - | COMMENT _ | DOCSTRING _ -> skip () - | EOF -> raise (Pp_error (Unterminated_if, Location.curr lexbuf)) - | t -> t - in - skip () - in - let push e = - (* INVARIANT: only look at most one token *) - assert (!look_ahead = None); - look_ahead := Some e - in - let rec token_op calc ~no lhs = - match token () with - | (LESS | GREATER | INFIXOP0 "<=" | INFIXOP0 ">=" | EQUAL | INFIXOP0 "<>") - as op -> - let f = - match op with - | LESS -> ( < ) - | GREATER -> ( > ) - | INFIXOP0 "<=" -> ( <= ) - | EQUAL -> ( = ) - | INFIXOP0 "<>" -> ( <> ) - | _ -> assert false - in - let curr_loc = Location.curr lexbuf in - let rhs = value_of_token curr_loc (token ()) in - (not calc) || f lhs (assert_same_type lexbuf lhs rhs) - | INFIXOP0 "=~" -> ( - (not calc) - || - match lhs with - | Dir_string s -> ( - let curr_loc = Location.curr lexbuf in - let rhs = value_of_token curr_loc (token ()) in - match rhs with - | Dir_string rhs -> semver curr_loc s rhs - | _ -> - raise - (Pp_error - ( Conditional_expr_expected_type - (Dir_type_string, type_of_directive lhs), - Location.curr lexbuf ))) - | _ -> - raise - (Pp_error - ( Conditional_expr_expected_type - (Dir_type_string, type_of_directive lhs), - Location.curr lexbuf ))) - | e -> no e - and parse_or calc : bool = parse_or_aux calc (parse_and calc) - and (* a || (b || (c || d))*) - parse_or_aux calc v : bool = - (* let l = v in *) - match token () with - | BARBAR -> - let b = parse_or (calc && not v) in - v || b - | e -> - push e; - v - and parse_and calc = parse_and_aux calc (parse_relation calc) - and parse_and_aux calc v = - (* a && (b && (c && d)) *) - (* let l = v in *) - match token () with - | AMPERAMPER -> - let b = parse_and (calc && v) in - v && b - | e -> - push e; - v - and parse_relation (calc : bool) : bool = - let curr_token = token () in - let curr_loc = Location.curr lexbuf in - match curr_token with - | TRUE -> true - | FALSE -> false - | UIDENT v -> - let value_v = query curr_loc v in - token_op calc - ~no:(fun e -> - push e; - match value_v with - | Dir_bool b -> b - | _ -> - let ty = type_of_directive value_v in - raise - (Pp_error - ( Conditional_expr_expected_type (Dir_type_bool, ty), - curr_loc ))) - value_v - | INT (v, None) -> - let num_v = cvt_int_literal v in - token_op calc - ~no:(fun e -> - push e; - num_v <> 0) - (Dir_int num_v) - | FLOAT (v, None) -> - token_op calc - ~no:(fun _e -> - raise - (Pp_error - ( Conditional_expr_expected_type (Dir_type_bool, Dir_type_float), - curr_loc ))) - (Dir_float (float_of_string v)) - | STRING (v, _) -> - token_op calc - ~no:(fun _e -> - raise - (Pp_error - ( Conditional_expr_expected_type - (Dir_type_bool, Dir_type_string), - curr_loc ))) - (Dir_string v) - | LIDENT (("defined" | "undefined") as r) -> ( - let t = token () in - let loc = Location.curr lexbuf in - match t with - | UIDENT s -> - (not calc) || if r.[0] = 'u' then not @@ defined s else defined s - | _ -> raise (Pp_error (Unexpected_token_in_conditional, loc))) - | LPAREN -> ( - let v = parse_or calc in - match token () with - | RPAREN -> v - | _ -> - raise - (Pp_error (Unterminated_paren_in_conditional, Location.curr lexbuf)) - ) - | _ -> raise (Pp_error (Unexpected_token_in_conditional, curr_loc)) - in - let v = parse_or true in - match token () with - | THEN | EOL -> v - | _ -> - raise (Pp_error (Expect_hash_then_in_conditional, Location.curr lexbuf)) - -type dir_conditional = Dir_if_true | Dir_if_false | Dir_out - -(* let string_of_dir_conditional (x : dir_conditional) = *) -(* match x with *) -(* | Dir_if_true -> "Dir_if_true" *) -(* | Dir_if_false -> "Dir_if_false" *) -(* | Dir_out -> "Dir_out" *) - -let if_then_else = ref Dir_out - -(* store the token after hash, [# token] - when we see `#if` we do the processing immediately - when we see #method, we produce `HASH` token and save `method` - token so that the next lexing produce the right one. -*) -let sharp_look_ahead = ref None - -let update_if_then_else v = - (* Format.fprintf Format.err_formatter "@[update %s \n@]@." (string_of_dir_conditional v); *) - if_then_else := v - -let at_bol lexbuf = - let pos = Lexing.lexeme_start_p lexbuf in - pos.pos_cnum = pos.pos_bol - -(* skip to #else | #end | #elif *) -let rec skip_from_if_false (token_with_comments : Lexing.lexbuf -> Parser.token) - cont lexbuf = - let token = token_with_comments lexbuf in - if token = EOF then raise (Pp_error (Unterminated_if, Location.curr lexbuf)) - else if token = HASH && at_bol lexbuf then - let token = token_with_comments lexbuf in - match token with - | END | LIDENT "endif" -> - update_if_then_else Dir_out; - cont lexbuf - | ELSE -> - update_if_then_else Dir_if_false; - cont lexbuf - | IF -> raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | LIDENT "elif" when directive_parse token_with_comments lexbuf -> - update_if_then_else Dir_if_true; - cont lexbuf - | _ -> skip_from_if_false token_with_comments cont lexbuf - else skip_from_if_false token_with_comments cont lexbuf - -let interpret_directive_cont lexbuf ~cont - ~(token_with_comments : Lexing.lexbuf -> Parser.token) look_ahead = - (* current state *) - let if_then_else = !if_then_else in - match (token_with_comments lexbuf, if_then_else) with - | IF, Dir_out -> - if directive_parse token_with_comments lexbuf then ( - update_if_then_else Dir_if_true (* Next state: ELSE *); - cont lexbuf) - else skip_from_if_false token_with_comments cont lexbuf - | LIDENT (("ifndef" | "ifdef") as s), Dir_out -> - let rec token () = - match token_with_comments lexbuf with - | COMMENT _ | DOCSTRING _ -> token () - | EOF -> raise (Pp_error (Unterminated_if, Location.curr lexbuf)) - | t -> t - in - let t0 = token () in - let t = - match t0 with - | UIDENT t -> t - | _ -> - raise - (Pp_error (Unexpected_token_in_conditional, Location.curr lexbuf)) - in - let t1 = token () in - (match t1 with - | THEN | EOL -> () - | _ -> - raise - (Pp_error (Expect_hash_then_in_conditional, Location.curr lexbuf))); - let boolean = defined t = (s = "ifdef") in - if boolean then ( - update_if_then_else Dir_if_true (* Next state: ELSE *); - cont lexbuf) - else skip_from_if_false token_with_comments cont lexbuf - | (IF | LIDENT "ifndef" | LIDENT "ifdef"), (Dir_if_false | Dir_if_true) -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | LIDENT "elif", (Dir_if_false | Dir_out) -> - (* when the predicate is false, it will continue eating `elif` *) - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | ((LIDENT "elif" | ELSE) as token), Dir_if_true -> - (* looking for #end, however, it can not see #if anymore, - we need do some validation *) - let rec skip_from_if_true else_seen = - let token = token_with_comments lexbuf in - if token = EOF then - raise (Pp_error (Unterminated_else, Location.curr lexbuf)) - else if token = HASH && at_bol lexbuf then - let token = token_with_comments lexbuf in - match token with - | END | LIDENT "endif" -> - update_if_then_else Dir_out; - cont lexbuf - | IF -> raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | ELSE -> - if else_seen then - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - else skip_from_if_true true - | LIDENT "elif" when else_seen -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | _ -> skip_from_if_true else_seen - else skip_from_if_true else_seen - in - skip_from_if_true (token = ELSE) - | ELSE, Dir_if_false | ELSE, Dir_out -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | (END | LIDENT "endif"), (Dir_if_false | Dir_if_true) -> - update_if_then_else Dir_out; - cont lexbuf - | (END | LIDENT "endif"), Dir_out -> - raise (Pp_error (Unexpected_directive, Location.curr lexbuf)) - | token, (Dir_if_true | Dir_if_false | Dir_out) -> look_ahead token - -let interpret_directive lexbuf ~cont ~token_with_comments : Parser.token = - interpret_directive_cont lexbuf ~cont ~token_with_comments - (fun (token : 'a) : 'a -> - sharp_look_ahead := Some token; - HASH) - -let eof_check lexbuf = - if !if_then_else <> Dir_out then - if !if_then_else = Dir_if_true then - raise (Pp_error (Unterminated_if, Location.curr lexbuf)) - else raise (Pp_error (Unterminated_else, Location.curr lexbuf)) - -let init () = - sharp_look_ahead := None; - update_if_then_else Dir_out - -let check_sharp_look_ahead action : Parser.token = - match !sharp_look_ahead with - | None -> action () - | Some token -> - sharp_look_ahead := None; - token - -let rec filter_directive ~(token_with_comments : Lexing.lexbuf -> Parser.token) - pos acc lexbuf : (int * int) list = - match token_with_comments lexbuf with - | HASH when at_bol lexbuf -> - (* ^[start_pos]#if ... #then^[end_pos] *) - let start_pos = Lexing.lexeme_start lexbuf in - interpret_directive_cont lexbuf - ~cont:(fun lexbuf -> - filter_directive (Lexing.lexeme_end lexbuf) ~token_with_comments - ((pos, start_pos) :: acc) lexbuf) - ~token_with_comments - (fun _token -> filter_directive pos acc lexbuf ~token_with_comments) - | EOF -> (pos, Lexing.lexeme_end lexbuf) :: acc - | _ -> filter_directive ~token_with_comments pos acc lexbuf - -let filter_directive_from_lexbuf lexbuf ~token_with_comments = - List.rev (filter_directive 0 [] lexbuf ~token_with_comments) diff --git a/jscomp/ml/rescript_cpp.mli b/jscomp/ml/rescript_cpp.mli deleted file mode 100644 index 46fe631..0000000 --- a/jscomp/ml/rescript_cpp.mli +++ /dev/null @@ -1,54 +0,0 @@ -(* Copyright (C) 2021- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -val at_bol : Lexing.lexbuf -> bool - -val interpret_directive : - Lexing.lexbuf -> - cont:(Lexing.lexbuf -> Parser.token) -> - token_with_comments:(Lexing.lexbuf -> Parser.token) -> - Parser.token - -val eof_check : Lexing.lexbuf -> unit - -val init : unit -> unit - -val check_sharp_look_ahead : (unit -> Parser.token) -> Parser.token - -(* Methods below are used for cpp, they are not needed by the compiler patches*) -val remove_directive_built_in_value : string -> unit - -val replace_directive_string : string -> string -> unit - -val replace_directive_bool : string -> bool -> unit - -val define_key_value : string -> string -> bool -(** @return false means failed to define *) - -val list_variables : Format.formatter -> unit - -val filter_directive_from_lexbuf : - Lexing.lexbuf -> - token_with_comments:(Lexing.lexbuf -> Parser.token) -> - (int * int) list diff --git a/jscomp/ml/stypes.ml b/jscomp/ml/stypes.ml deleted file mode 100644 index 879aef7..0000000 --- a/jscomp/ml/stypes.ml +++ /dev/null @@ -1,210 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2003 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. *) -(* *) -(**************************************************************************) - -(* Recording and dumping (partial) type information *) - -(* - We record all types in a list as they are created. - This means we can dump type information even if type inference fails, - which is extremely important, since type information is most - interesting in case of errors. -*) - -open Annot;; -open Lexing;; -open Location;; -open Typedtree;; - -let output_int oc i = output_string oc (string_of_int i) - -type annotation = - | Ti_pat of pattern - | Ti_expr of expression - | Ti_class of unit - | Ti_mod of module_expr - | An_call of Location.t * Annot.call - | An_ident of Location.t * string * Annot.ident -;; - -let get_location ti = - match ti with - Ti_pat p -> p.pat_loc - | Ti_expr e -> e.exp_loc - | Ti_class () -> assert false - | Ti_mod m -> m.mod_loc - | An_call (l, _k) -> l - | An_ident (l, _s, _k) -> l -;; - -let annotations = ref ([] : annotation list);; -let phrases = ref ([] : Location.t list);; - -let record ti = - if !Clflags.annotations && not (get_location ti).Location.loc_ghost then - annotations := ti :: !annotations -;; - -let record_phrase loc = - if !Clflags.annotations then phrases := loc :: !phrases; -;; - -(* comparison order: - the intervals are sorted by order of increasing upper bound - same upper bound -> sorted by decreasing lower bound -*) -let cmp_loc_inner_first loc1 loc2 = - match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with - | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum - | x -> x -;; -let cmp_ti_inner_first ti1 ti2 = - cmp_loc_inner_first (get_location ti1) (get_location ti2) -;; - -let print_position pp pos = - if pos = dummy_pos then - output_string pp "--" - else begin - output_char pp '\"'; - output_string pp (String.escaped pos.pos_fname); - output_string pp "\" "; - output_int pp pos.pos_lnum; - output_char pp ' '; - output_int pp pos.pos_bol; - output_char pp ' '; - output_int pp pos.pos_cnum; - end -;; - -let print_location pp loc = - print_position pp loc.loc_start; - output_char pp ' '; - print_position pp loc.loc_end; -;; - -let sort_filter_phrases () = - let ph = List.sort (fun x y -> cmp_loc_inner_first y x) !phrases in - let rec loop accu cur l = - match l with - | [] -> accu - | loc :: t -> - if cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum - && cur.loc_end.pos_cnum >= loc.loc_end.pos_cnum - then loop accu cur t - else loop (loc :: accu) loc t - in - phrases := loop [] Location.none ph; -;; - -let rec printtyp_reset_maybe loc = - match !phrases with - | cur :: t when cur.loc_start.pos_cnum <= loc.loc_start.pos_cnum -> - Printtyp.reset (); - phrases := t; - printtyp_reset_maybe loc; - | _ -> () -;; - -let call_kind_string k = - match k with - | Tail -> "tail" - | Stack -> "stack" - | Inline -> "inline" -;; - -let print_ident_annot pp str k = - match k with - | Idef l -> - output_string pp "def "; - output_string pp str; - output_char pp ' '; - print_location pp l; - output_char pp '\n' - | Iref_internal l -> - output_string pp "int_ref "; - output_string pp str; - output_char pp ' '; - print_location pp l; - output_char pp '\n' - | Iref_external -> - output_string pp "ext_ref "; - output_string pp str; - output_char pp '\n' -;; - -(* The format of the annotation file is documented in emacs/caml-types.el. *) - -let print_info pp prev_loc ti = - match ti with - | Ti_class _ | Ti_mod _ -> prev_loc - | Ti_pat {pat_loc = loc; pat_type = typ; pat_env = env} - | Ti_expr {exp_loc = loc; exp_type = typ; exp_env = env} -> - if loc <> prev_loc then begin - print_location pp loc; - output_char pp '\n' - end; - output_string pp "type(\n"; - printtyp_reset_maybe loc; - Printtyp.mark_loops typ; - Format.pp_print_string Format.str_formatter " "; - Printtyp.wrap_printing_env env - (fun () -> Printtyp.type_sch Format.str_formatter typ); - Format.pp_print_newline Format.str_formatter (); - let s = Format.flush_str_formatter () in - output_string pp s; - output_string pp ")\n"; - loc - | An_call (loc, k) -> - if loc <> prev_loc then begin - print_location pp loc; - output_char pp '\n' - end; - output_string pp "call(\n "; - output_string pp (call_kind_string k); - output_string pp "\n)\n"; - loc - | An_ident (loc, str, k) -> - if loc <> prev_loc then begin - print_location pp loc; - output_char pp '\n' - end; - output_string pp "ident(\n "; - print_ident_annot pp str k; - output_string pp ")\n"; - loc -;; - -let get_info () = - let info = List.fast_sort cmp_ti_inner_first !annotations in - annotations := []; - info -;; - -let dump filename = - if !Clflags.annotations then begin - let do_dump _temp_filename pp = - let info = get_info () in - sort_filter_phrases (); - ignore (List.fold_left (print_info pp) Location.none info) in - begin match filename with - | None -> do_dump "" stdout - | Some filename -> - Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump - end; - phrases := []; - end else begin - annotations := []; - end; -;; diff --git a/jscomp/ml/subst.ml b/jscomp/ml/subst.ml deleted file mode 100644 index f30b7a1..0000000 --- a/jscomp/ml/subst.ml +++ /dev/null @@ -1,474 +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. *) -(* *) -(**************************************************************************) - -(* Substitutions *) - -open Misc -open Path -open Types -open Btype - -type type_replacement = - | Path of Path.t - | Type_function of { params : type_expr list; body : type_expr } - -module PathMap = Map.Make(Path) - -type t = - { types: type_replacement PathMap.t; - modules: Path.t PathMap.t; - modtypes: (Ident.t, module_type) Tbl.t; - for_saving: bool; - } - -let identity = - { types = PathMap.empty; - modules = PathMap.empty; - modtypes = Tbl.empty; - for_saving = false; - } - -let add_type_path id p s = { s with types = PathMap.add id (Path p) s.types } -let add_type id p s = add_type_path (Pident id) p s - -let add_type_function id ~params ~body s = - { s with types = PathMap.add id (Type_function { params; body }) s.types } - -let add_module_path id p s = { s with modules = PathMap.add id p s.modules } -let add_module id p s = add_module_path (Pident id) p s - -let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes } - -let for_saving s = { s with for_saving = true } - -let loc s x = - if s.for_saving && not !Clflags.keep_locs then Location.none else x - -let remove_loc = - let open Ast_mapper in - {default_mapper with location = (fun _this _loc -> Location.none)} - -let is_not_doc = function - | ({Location.txt = "ocaml.doc"}, _) -> false - | ({Location.txt = "ocaml.text"}, _) -> false - | ({Location.txt = "doc"}, _) -> false - | ({Location.txt = "text"}, _) -> false - | _ -> true - -let attrs s x = - let x = - if s.for_saving && not !Clflags.keep_docs then - Ext_list.filter x is_not_doc - else x - in - if s.for_saving && not !Clflags.keep_locs - then remove_loc.Ast_mapper.attributes remove_loc x - else x - -let rec module_path s path = - try PathMap.find path s.modules - with Not_found -> - match path with - | Pident _ -> path - | Pdot(p, n, pos) -> - Pdot(module_path s p, n, pos) - | Papply(p1, p2) -> - Papply(module_path s p1, module_path s p2) - -let modtype_path s = function - Pident id as p -> - begin try - match Tbl.find id s.modtypes with - | Mty_ident p -> p - | _ -> fatal_error "Subst.modtype_path" - with Not_found -> p end - | Pdot(p, n, pos) -> - Pdot(module_path s p, n, pos) - | Papply _ -> - fatal_error "Subst.modtype_path" - -let type_path s path = - match PathMap.find path s.types with - | Path p -> p - | Type_function _ -> assert false - | exception Not_found -> - match path with - | Pident _ -> path - | Pdot(p, n, pos) -> - Pdot(module_path s p, n, pos) - | Papply _ -> - fatal_error "Subst.type_path" - -let type_path s p = - match Path.constructor_typath p with - | Regular p -> type_path s p - | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos) - | LocalExt _ -> type_path s p - | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos) - -let to_subst_by_type_function s p = - match PathMap.find p s.types with - | Path _ -> false - | Type_function _ -> true - | exception Not_found -> false - -(* Special type ids for saved signatures *) - -let new_id = ref (-1) -let reset_for_saving () = new_id := -1 - -let newpersty desc = - decr new_id; - { desc = desc; level = generic_level; id = !new_id } - -(* ensure that all occurrences of 'Tvar None' are physically shared *) -let tvar_none = Tvar None -let tunivar_none = Tunivar None -let norm = function - | Tvar None -> tvar_none - | Tunivar None -> tunivar_none - | d -> d - -let ctype_apply_env_empty = ref (fun _ -> assert false) - -(* Similar to [Ctype.nondep_type_rec]. *) -let rec typexp s ty = - let ty = repr ty in - match ty.desc with - Tvar _ | Tunivar _ as desc -> - if s.for_saving || ty.id < 0 then - let ty' = - if s.for_saving then newpersty (norm desc) - else newty2 ty.level desc - in - save_desc ty desc; ty.desc <- Tsubst ty'; ty' - else ty - | Tsubst ty -> - ty - | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method - && field_kind_repr k <> Fabsent && (repr ty).level < generic_level -> - (* do not copy the type of self when it is not generalized *) - ty -(* cannot do it, since it would omit substitution - | Tvariant row when not (static_row row) -> - ty -*) - | _ -> - let desc = ty.desc in - save_desc ty desc; - let tm = row_of_type ty in - let has_fixed_row = - not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in - (* Make a stub *) - let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in - ty.desc <- Tsubst ty'; - ty'.desc <- - begin if has_fixed_row then - match tm.desc with (* PR#7348 *) - Tconstr (Pdot(m,i,pos), tl, _abbrev) -> - let i' = String.sub i 0 (String.length i - 4) in - Tconstr(type_path s (Pdot(m,i',pos)), tl, ref Mnil) - | _ -> assert false - else match desc with - | Tconstr (p, args, _abbrev) -> - let args = List.map (typexp s) args in - begin match PathMap.find p s.types with - | exception Not_found -> Tconstr(type_path s p, args, ref Mnil) - | Path _ -> Tconstr(type_path s p, args, ref Mnil) - | Type_function { params; body } -> - (!ctype_apply_env_empty params body args).desc - end - | Tpackage(p, n, tl) -> - Tpackage(modtype_path s p, n, List.map (typexp s) tl) - | Tobject (t1, name) -> - Tobject (typexp s t1, - ref (match !name with - None -> None - | Some (p, tl) -> - if to_subst_by_type_function s p - then None - else Some (type_path s p, List.map (typexp s) tl))) - | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in - (* We must substitute in a subtle way *) - (* Tsubst takes a tuple containing the row var and the variant *) - begin match more.desc with - Tsubst {desc = Ttuple [_;ty2]} -> - (* This variant type has been already copied *) - ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) - Tlink ty2 - | _ -> - let dup = - s.for_saving || more.level = generic_level || static_row row || - match more.desc with Tconstr _ -> true | _ -> false in - (* Various cases for the row variable *) - let more' = - match more.desc with - Tsubst ty -> ty - | Tconstr _ | Tnil -> typexp s more - | Tunivar _ | Tvar _ -> - save_desc more more.desc; - if s.for_saving then newpersty (norm more.desc) else - if dup && is_Tvar more then newgenty more.desc else more - | _ -> assert false - in - (* Register new type first for recursion *) - more.desc <- Tsubst(newgenty(Ttuple[more';ty'])); - (* Return a new copy *) - let row = - copy_row (typexp s) true row (not dup) more' in - match row.row_name with - | Some (p, tl) -> - Tvariant {row with row_name = - if to_subst_by_type_function s p - then None - else Some (type_path s p, tl)} - | None -> - Tvariant row - end - | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> - Tlink (typexp s t2) - | _ -> copy_type_desc (typexp s) desc - end; - ty' - -(* - Always make a copy of the type. If this is not done, type levels - might not be correct. -*) -let type_expr s ty = - let ty' = typexp s ty in - cleanup_types (); - ty' - -let label_declaration s l = - { - ld_id = l.ld_id; - ld_mutable = l.ld_mutable; - ld_type = typexp s l.ld_type; - ld_loc = loc s l.ld_loc; - ld_attributes = attrs s l.ld_attributes; - } - -let constructor_arguments s = function - | Cstr_tuple l -> - Cstr_tuple (List.map (typexp s) l) - | Cstr_record l -> - Cstr_record (List.map (label_declaration s) l) - -let constructor_declaration s c = - { - cd_id = c.cd_id; - cd_args = constructor_arguments s c.cd_args; - cd_res = may_map (typexp s) c.cd_res; - cd_loc = loc s c.cd_loc; - cd_attributes = attrs s c.cd_attributes; - } - -let type_declaration s decl = - let decl = - { type_params = List.map (typexp s) decl.type_params; - type_arity = decl.type_arity; - type_kind = - begin match decl.type_kind with - Type_abstract -> Type_abstract - | Type_variant cstrs -> - Type_variant (List.map (constructor_declaration s) cstrs) - | Type_record(lbls, rep) -> - Type_record (List.map (label_declaration s) lbls, rep) - | Type_open -> Type_open - end; - type_manifest = - begin - match decl.type_manifest with - None -> None - | Some ty -> Some(typexp s ty) - end; - type_private = decl.type_private; - type_variance = decl.type_variance; - type_newtype_level = None; - type_loc = loc s decl.type_loc; - type_attributes = attrs s decl.type_attributes; - type_immediate = decl.type_immediate; - type_unboxed = decl.type_unboxed; - } - in - cleanup_types (); - decl - -let class_signature s sign = - { csig_self = typexp s sign.csig_self; - csig_vars = - Vars.map (function (m, v, t) -> (m, v, typexp s t)) sign.csig_vars; - csig_concr = sign.csig_concr; - csig_inher = - List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl)) - sign.csig_inher; - } - -let rec class_type s = - function - Cty_constr (p, tyl, cty) -> - Cty_constr (type_path s p, List.map (typexp s) tyl, class_type s cty) - | Cty_signature sign -> - Cty_signature (class_signature s sign) - | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, typexp s ty, class_type s cty) - - - -let cltype_declaration s decl = - let decl = - { clty_params = List.map (typexp s) decl.clty_params; - clty_variance = decl.clty_variance; - clty_type = class_type s decl.clty_type; - clty_path = type_path s decl.clty_path; - clty_loc = loc s decl.clty_loc; - clty_attributes = attrs s decl.clty_attributes; - } - in - (* Do clean up even if saving: type_declaration may be recursive *) - cleanup_types (); - decl - -let class_type s cty = - let cty = class_type s cty in - cleanup_types (); - cty - -let value_description s descr = - { val_type = type_expr s descr.val_type; - val_kind = descr.val_kind; - val_loc = loc s descr.val_loc; - val_attributes = attrs s descr.val_attributes; - } - -let extension_constructor s ext = - let ext = - { ext_type_path = type_path s ext.ext_type_path; - ext_type_params = List.map (typexp s) ext.ext_type_params; - ext_args = constructor_arguments s ext.ext_args; - ext_ret_type = may_map (typexp s) ext.ext_ret_type; - ext_private = ext.ext_private; - ext_attributes = attrs s ext.ext_attributes; - ext_loc = if s.for_saving then Location.none else ext.ext_loc; } - in - cleanup_types (); - ext - -let rec rename_bound_idents s idents = function - [] -> (List.rev idents, s) - | Sig_type(id, _, _) :: sg -> - let id' = Ident.rename id in - rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | Sig_module(id, _, _) :: sg -> - let id' = Ident.rename id in - rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg - | Sig_modtype(id, _) :: sg -> - let id' = Ident.rename id in - rename_bound_idents (add_modtype id (Mty_ident(Pident id')) s) - (id' :: idents) sg - | Sig_class_type(id, _, _) :: sg -> - (* cheat and pretend they are types cf. PR#6650 *) - let id' = Ident.rename id in - rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg - | (Sig_value(id, _) | Sig_typext(id, _, _)) :: sg -> - let id' = Ident.rename id in - rename_bound_idents s (id' :: idents) sg - | Sig_class _ :: _ -> assert false -let rec modtype s = function - Mty_ident p as mty -> - begin match p with - Pident id -> - begin try Tbl.find id s.modtypes with Not_found -> mty end - | Pdot(p, n, pos) -> - Mty_ident(Pdot(module_path s p, n, pos)) - | Papply _ -> - fatal_error "Subst.modtype" - end - | Mty_signature sg -> - Mty_signature(signature s sg) - | Mty_functor(id, arg, res) -> - let id' = Ident.rename id in - Mty_functor(id', may_map (modtype s) arg, - modtype (add_module id (Pident id') s) res) - | Mty_alias(pres, p) -> - Mty_alias(pres, module_path s p) - -and signature s sg = - (* Components of signature may be mutually recursive (e.g. type declarations - or class and type declarations), so first build global renaming - substitution... *) - let (new_idents, s') = rename_bound_idents s [] sg in - (* ... then apply it to each signature component in turn *) - List.map2 (signature_component s') sg new_idents - -and signature_component s comp newid = - match comp with - Sig_value(_id, d) -> - Sig_value(newid, value_description s d) - | Sig_type(_id, d, rs) -> - Sig_type(newid, type_declaration s d, rs) - | Sig_typext(_id, ext, es) -> - Sig_typext(newid, extension_constructor s ext, es) - | Sig_module(_id, d, rs) -> - Sig_module(newid, module_declaration s d, rs) - | Sig_modtype(_id, d) -> - Sig_modtype(newid, modtype_declaration s d) - | Sig_class() -> - Sig_class() - | Sig_class_type(_id, d, rs) -> - Sig_class_type(newid, cltype_declaration s d, rs) - -and module_declaration s decl = - { - md_type = modtype s decl.md_type; - md_attributes = attrs s decl.md_attributes; - md_loc = loc s decl.md_loc; - } - -and modtype_declaration s decl = - { - mtd_type = may_map (modtype s) decl.mtd_type; - mtd_attributes = attrs s decl.mtd_attributes; - mtd_loc = loc s decl.mtd_loc; - } - -(* For every binding k |-> d of m1, add k |-> f d to m2 - and return resulting merged map. *) - -let merge_tbls f m1 m2 = - Tbl.fold (fun k d accu -> Tbl.add k (f d) accu) m1 m2 - -let merge_path_maps f m1 m2 = - PathMap.fold (fun k d accu -> PathMap.add k (f d) accu) m1 m2 - -let type_replacement s = function - | Path p -> Path (type_path s p) - | Type_function { params; body } -> - let params = List.map (typexp s) params in - let body = typexp s body in - Type_function { params; body } - -(* Composition of substitutions: - apply (compose s1 s2) x = apply s2 (apply s1 x) *) - -let compose s1 s2 = - { types = merge_path_maps (type_replacement s2) s1.types s2.types; - modules = merge_path_maps (module_path s2) s1.modules s2.modules; - modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes; - for_saving = s1.for_saving || s2.for_saving; - } diff --git a/jscomp/ml/subst.mli b/jscomp/ml/subst.mli deleted file mode 100644 index 3f975b4..0000000 --- a/jscomp/ml/subst.mli +++ /dev/null @@ -1,70 +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. *) -(* *) -(**************************************************************************) - -(* Substitutions *) - -open Types - -type t - -(* - Substitutions are used to translate a type from one context to - another. This requires substituting paths for identifiers, and - possibly also lowering the level of non-generic variables so that - they are inferior to the maximum level of the new context. - - Substitutions can also be used to create a "clean" copy of a type. - Indeed, non-variable node of a type are duplicated, with their - levels set to generic level. That way, the resulting type is - well-formed (decreasing levels), even if the original one was not. -*) - -val identity: t - -val add_type: Ident.t -> Path.t -> t -> t -val add_type_path: Path.t -> Path.t -> t -> t -val add_type_function: - Path.t -> params:type_expr list -> body:type_expr -> t -> t -val add_module: Ident.t -> Path.t -> t -> t -val add_module_path: Path.t -> Path.t -> t -> t -val add_modtype: Ident.t -> module_type -> t -> t -val for_saving: t -> t -val reset_for_saving: unit -> unit - -val module_path: t -> Path.t -> Path.t -val type_path: t -> Path.t -> Path.t - -val type_expr: t -> type_expr -> type_expr -val class_type: t -> class_type -> class_type -val value_description: t -> value_description -> value_description -val type_declaration: t -> type_declaration -> type_declaration -val extension_constructor: - t -> extension_constructor -> extension_constructor - -val cltype_declaration: t -> class_type_declaration -> class_type_declaration -val modtype: t -> module_type -> module_type -val signature: t -> signature -> signature -val modtype_declaration: t -> modtype_declaration -> modtype_declaration -val module_declaration: t -> module_declaration -> module_declaration -val typexp : t -> Types.type_expr -> Types.type_expr -val class_signature: t -> class_signature -> class_signature - -(* Composition of substitutions: - apply (compose s1 s2) x = apply s2 (apply s1 x) *) -val compose: t -> t -> t - -(* A forward reference to be filled in ctype.ml. *) -val ctype_apply_env_empty: - (type_expr list -> type_expr -> type_expr list -> type_expr) ref diff --git a/jscomp/ml/switch.ml b/jscomp/ml/switch.ml deleted file mode 100644 index a4bab63..0000000 --- a/jscomp/ml/switch.ml +++ /dev/null @@ -1,868 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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 'a shared = Shared of 'a | Single of 'a - -type 'a t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'a -> int ; - act_store_shared : 'a -> int ; } - -exception Not_simple - -module type Stored = sig - type t - type key - val compare_key : key -> key -> int - val make_key : t -> key option -end - -module Store(A:Stored) = struct - module AMap = - Map.Make(struct type t = A.key let compare = A.compare_key end) - - type intern = - { mutable map : (bool * int) AMap.t ; - mutable next : int ; - mutable acts : (bool * A.t) list; } - - let mk_store () = - let st = - { map = AMap.empty ; - next = 0 ; - acts = [] ; } in - - let add mustshare act = - let i = st.next in - st.acts <- (mustshare,act) :: st.acts ; - st.next <- i+1 ; - i in - - let store mustshare act = match A.make_key act with - | Some key -> - begin try - let (shared,i) = AMap.find key st.map in - if not shared then st.map <- AMap.add key (true,i) st.map ; - i - with Not_found -> - let i = add mustshare act in - st.map <- AMap.add key (mustshare,i) st.map ; - i - end - | None -> - add mustshare act - - and get () = Array.of_list (List.rev_map (fun (_,act) -> act) st.acts) - - and get_shared () = - let acts = - Array.of_list - (List.rev_map - (fun (shared,act) -> - if shared then Shared act else Single act) - st.acts) in - AMap.iter - (fun _ (shared,i) -> - if shared then match acts.(i) with - | Single act -> acts.(i) <- Shared act - | Shared _ -> ()) - st.map ; - acts in - {act_store = store false ; act_store_shared = store true ; - act_get = get; act_get_shared = get_shared; } -end - - - -module type S = - sig - type primitive - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - type act - - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - val make_switch : Location.t -> act -> int array -> act array -> offset:int -> Ast_untagged_variants.switch_names option -> act - val make_catch : act -> int * (act -> act) - val make_exit : int -> act - end - -(* The module will ``produce good code for the case statement'' *) -(* - Adaptation of - R.L. Berstein - ``Producing good code for the case statement'' - Sofware Practice and Experience, 15(10) (1985) - and - D.L. Spuler - ``Two-Way Comparison Search Trees, a Generalisation of Binary Search Trees - and Split Trees'' - ``Compiler Code Generation for Multiway Branch Statement as - a Static Search Problem'' - Technical Reports, James Cook University -*) -(* - Main adaptation is considering interval tests - (implemented as one addition + one unsigned test and branch) - which leads to exhaustive search for finding the optimal - test sequence in small cases and heuristics otherwise. -*) -module Make (Arg : S) = - struct - - type 'a inter = - {cases : (int * int * int) array ; - actions : 'a array} - -type 'a t_ctx = {off : int ; arg : 'a} - -let cut = ref 8 -and more_cut = ref 16 - -(* -let pint chan i = - if i = min_int then Printf.fprintf chan "-oo" - else if i=max_int then Printf.fprintf chan "oo" - else Printf.fprintf chan "%d" i - -let pcases chan cases = - for i =0 to Array.length cases-1 do - let l,h,act = cases.(i) in - if l=h then - Printf.fprintf chan "%d:%d " l act - else - Printf.fprintf chan "%a..%a:%d " pint l pint h act - done - -let prerr_inter i = Printf.fprintf stderr - "cases=%a" pcases i.cases -*) - -let get_act cases i = - let _,_,r = cases.(i) in - r -and get_low cases i = - let r,_,_ = cases.(i) in - r - -type ctests = { - mutable n : int ; - mutable ni : int ; - } - -let too_much = {n=max_int ; ni=max_int} - -(* -let ptests chan {n=n ; ni=ni} = - Printf.fprintf chan "{n=%d ; ni=%d}" n ni - -let pta chan t = - for i =0 to Array.length t-1 do - Printf.fprintf chan "%d: %a\n" i ptests t.(i) - done -*) - -let less_tests c1 c2 = - if c1.n < c2.n then - true - else if c1.n = c2.n then begin - if c1.ni < c2.ni then - true - else - false - end else - false - -and eq_tests c1 c2 = c1.n = c2.n && c1.ni=c2.ni - -let less2tests (c1,d1) (c2,d2) = - if eq_tests c1 c2 then - less_tests d1 d2 - else - less_tests c1 c2 - -let add_test t1 t2 = - t1.n <- t1.n + t2.n ; - t1.ni <- t1.ni + t2.ni ; - -type t_ret = Inter of int * int | Sep of int | No - -(* -let pret chan = function - | Inter (i,j)-> Printf.fprintf chan "Inter %d %d" i j - | Sep i -> Printf.fprintf chan "Sep %d" i - | No -> Printf.fprintf chan "No" -*) - -let coupe cases i = - let l,_,_ = cases.(i) in - l, - Array.sub cases 0 i, - Array.sub cases i (Array.length cases-i) - - -let case_append c1 c2 = - let len1 = Array.length c1 - and len2 = Array.length c2 in - match len1,len2 with - | 0,_ -> c2 - | _,0 -> c1 - | _,_ -> - let l1,h1,act1 = c1.(Array.length c1-1) - and l2,h2,act2 = c2.(0) in - if act1 = act2 then - let r = Array.make (len1+len2-1) c1.(0) in - for i = 0 to len1-2 do - r.(i) <- c1.(i) - done ; - - let l = - if len1-2 >= 0 then begin - let _,h,_ = r.(len1-2) in - if h+1 < l1 then - h+1 - else - l1 - end else - l1 - and h = - if 1 < len2-1 then begin - let l,_,_ = c2.(1) in - if h2+1 < l then - l-1 - else - h2 - end else - h2 in - r.(len1-1) <- (l,h,act1) ; - for i=1 to len2-1 do - r.(len1-1+i) <- c2.(i) - done ; - r - else if h1 > l1 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-2 do - r.(i) <- c1.(i) - done ; - r.(len1-1) <- (l1,l2-1,act1) ; - for i=0 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else if h2 > l2 then - let r = Array.make (len1+len2) c1.(0) in - for i = 0 to len1-1 do - r.(i) <- c1.(i) - done ; - r.(len1) <- (h1+1,h2,act2) ; - for i=1 to len2-1 do - r.(len1+i) <- c2.(i) - done ; - r - else - Array.append c1 c2 - - -let coupe_inter i j cases = - let lcases = Array.length cases in - let low,_,_ = cases.(i) - and _,high,_ = cases.(j) in - low,high, - Array.sub cases i (j-i+1), - case_append (Array.sub cases 0 i) (Array.sub cases (j+1) (lcases-(j+1))) - -type kind = Kvalue of int | Kinter of int | Kempty - -(* -let pkind chan = function - | Kvalue i ->Printf.fprintf chan "V%d" i - | Kinter i -> Printf.fprintf chan "I%d" i - | Kempty -> Printf.fprintf chan "E" - -let rec pkey chan = function - | [] -> () - | [k] -> pkind chan k - | k::rem -> - Printf.fprintf chan "%a %a" pkey rem pkind k -*) - -let t = Hashtbl.create 17 - -let make_key cases = - let seen = ref [] - and count = ref 0 in - let rec got_it act = function - | [] -> - seen := (act,!count):: !seen ; - let r = !count in - incr count ; - r - | (act0,index) :: rem -> - if act0 = act then - index - else - got_it act rem in - - let make_one (l:int) h act = - if l=h then - Kvalue (got_it act !seen) - else - Kinter (got_it act !seen) in - - let rec make_rec i pl = - if i < 0 then - [] - else - let l,h,act = cases.(i) in - if pl = h+1 then - make_one l h act::make_rec (i-1) l - else - Kempty::make_one l h act::make_rec (i-1) l in - - let l,h,act = cases.(Array.length cases-1) in - make_one l h act::make_rec (Array.length cases-2) l - - - let same_act t = - let len = Array.length t in - let a = get_act t (len-1) in - let rec do_rec i = - if i < 0 then true - else - let b = get_act t i in - b=a && do_rec (i-1) in - do_rec (len-2) - - -(* - Interval test x in [l,h] works by checking x-l in [0,h-l] - * This may be false for arithmetic modulo 2^31 - * Subtracting l may change the relative ordering of values - and invalid the invariant that matched values are given in - increasing order - - To avoid this, interval check is allowed only when the - integers indeed present in the whole case interval are - in [-2^16 ; 2^16] - - This condition is checked by zyva -*) - -let inter_limit = 1 lsl 16 - -let ok_inter = ref false - -let rec opt_count top cases = - let key = make_key cases in - try - Hashtbl.find t key - with - | Not_found -> - let r = - let lcases = Array.length cases in - match lcases with - | 0 -> assert false - | _ when same_act cases -> No, ({n=0; ni=0},{n=0; ni=0}) - | _ -> - if lcases < !cut then - enum top cases - else if lcases < !more_cut then - heuristic cases - else - divide cases in - Hashtbl.add t key r ; - r - -and divide cases = - let lcases = Array.length cases in - let m = lcases/2 in - let _,left,right = coupe cases m in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr - else - add_test cm cml ; - Sep m,(cm, ci) - -and heuristic cases = - let lcases = Array.length cases in - - let sep,csep = divide cases - - and inter,cinter = - if !ok_inter then begin - let _,_,act0 = cases.(0) - and _,_,act1 = cases.(lcases-1) in - if act0 = act1 then begin - let low, high, inside, outside = coupe_inter 1 (lcases-2) cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - Inter (1,lcases-2),(cmij,cij) - end else - Inter (-1,-1),(too_much, too_much) - end else - Inter (-1,-1),(too_much, too_much) in - if less2tests csep cinter then - sep,csep - else - inter,cinter - - -and enum top cases = - let lcases = Array.length cases in - let lim, with_sep = - let best = ref (-1) and best_cost = ref (too_much,too_much) in - - for i = 1 to lcases-(1) do - let _,left,right = coupe cases i in - let ci = {n=1 ; ni=0} - and cm = {n=1 ; ni=0} - and _,(cml,cleft) = opt_count false left - and _,(cmr,cright) = opt_count false right in - add_test ci cleft ; - add_test ci cright ; - if less_tests cml cmr then - add_test cm cmr - else - add_test cm cml ; - - if - less2tests (cm,ci) !best_cost - then begin - if top then - Printf.fprintf stderr "Get it: %d\n" i ; - best := i ; - best_cost := (cm,ci) - end - done ; - !best, !best_cost in - - let ilow, ihigh, with_inter = - if not !ok_inter then - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - let low, high, inside, outside = coupe_inter i i cases in - if low=high then begin - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=0} - and cij = {n=1 ; ni=0} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := i ; - best_cost := (cmij,cij) - end - end - done ; - !rlow, !rhigh, !best_cost - else - let rlow = ref (-1) and rhigh = ref (-1) - and best_cost= ref (too_much,too_much) in - for i=1 to lcases-2 do - for j=i to lcases-2 do - let low, high, inside, outside = coupe_inter i j cases in - let _,(cmi,cinside) = opt_count false inside - and _,(cmo,coutside) = opt_count false outside - and cmij = {n=1 ; ni=(if low=high then 0 else 1)} - and cij = {n=1 ; ni=(if low=high then 0 else 1)} in - add_test cij cinside ; - add_test cij coutside ; - if less_tests cmi cmo then - add_test cmij cmo - else - add_test cmij cmi ; - if less2tests (cmij,cij) !best_cost then begin - rlow := i ; - rhigh := j ; - best_cost := (cmij,cij) - end - done - done ; - !rlow, !rhigh, !best_cost in - let r = ref (Inter (ilow,ihigh)) and rc = ref with_inter in - if less2tests with_sep !rc then begin - r := Sep lim ; rc := with_sep - end ; - !r, !rc - - let make_if_test test arg i ifso ifnot = - Arg.make_if - (Arg.make_prim test [arg ; Arg.make_const i]) - ifso ifnot - - let make_if_lt arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.leint arg 0 ifso ifnot - | _ -> - make_if_test Arg.ltint arg i ifso ifnot - - and make_if_ge arg i ifso ifnot = match i with - | 1 -> - make_if_test Arg.gtint arg 0 ifso ifnot - | _ -> - make_if_test Arg.geint arg i ifso ifnot - - and make_if_eq arg i ifso ifnot = - make_if_test Arg.eqint arg i ifso ifnot - - and make_if_ne arg i ifso ifnot = - make_if_test Arg.neint arg i ifso ifnot - - let do_make_if_out h arg ifso ifno = - Arg.make_if (Arg.make_isout h arg) ifso ifno - - let make_if_out ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_out - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - if (*true || *)!Config.bs_only then - do_make_if_out - (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else - Arg.bind - (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_out - (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - - let do_make_if_in h arg ifso ifno = - Arg.make_if (Arg.make_isin h arg) ifso ifno - - let make_if_in ctx l d mk_ifso mk_ifno = match l with - | 0 -> - do_make_if_in - (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) - | _ -> - if (*true || *) !Config.bs_only then - do_make_if_in - (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else - Arg.bind - (Arg.make_offset ctx.arg (-l)) - (fun arg -> - let ctx = {off= (-l+ctx.off) ; arg=arg} in - do_make_if_in - (Arg.make_const d) arg (mk_ifso ctx) (mk_ifno ctx)) - - let rec c_test ctx ({cases=cases ; actions=actions} as s) = - let lcases = Array.length cases in - assert(lcases > 0) ; - if lcases = 1 then - actions.(get_act cases 0) ctx - - else begin - - let w,_c = opt_count false cases in -(* - Printf.fprintf stderr - "off=%d tactic=%a for %a\n" - ctx.off pret w pcases cases ; - *) - match w with - | No -> actions.(get_act cases 0) ctx - | Inter (i,j) -> - let low,high,inside, outside = coupe_inter i j cases in - let _,(cinside,_) = opt_count false inside - and _,(coutside,_) = opt_count false outside in -(* Costs are retrieved to put the code with more remaining tests - in the privileged (positive) branch of ``if'' *) - if low=high then begin - if less_tests coutside cinside then - make_if_eq - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=inside}) - (c_test ctx {s with cases=outside}) - else - make_if_ne - ctx.arg - (low+ctx.off) - (c_test ctx {s with cases=outside}) - (c_test ctx {s with cases=inside}) - end else begin - if less_tests coutside cinside then - make_if_in - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=inside}) - (fun ctx -> c_test ctx {s with cases=outside}) - else - make_if_out - ctx - (low+ctx.off) - (high-low) - (fun ctx -> c_test ctx {s with cases=outside}) - (fun ctx -> c_test ctx {s with cases=inside}) - end - | Sep i -> - let lim,left,right = coupe cases i in - let _,(cleft,_) = opt_count false left - and _,(cright,_) = opt_count false right in - let left = {s with cases=left} - and right = {s with cases=right} in - - if i=1 && (lim+ctx.off)=1 && get_low cases 0+ctx.off=0 then - make_if_ne - ctx.arg 0 - (c_test ctx right) (c_test ctx left) - else if less_tests cright cleft then - make_if_lt - ctx.arg (lim+ctx.off) - (c_test ctx left) (c_test ctx right) - else - make_if_ge - ctx.arg (lim+ctx.off) - (c_test ctx right) (c_test ctx left) - - end - - -(* Minimal density of switches *) -let theta = ref 0.33333 - -(* Minimal number of tests to make a switch *) -let switch_min = ref 3 - -(* Particular case 0, 1, 2 *) -let particular_case cases i j = - j-i = 2 && - (let l1,_h1,act1 = cases.(i) - and l2,_h2,_act2 = cases.(i+1) - and l3,h3,act3 = cases.(i+2) in - l1+1=l2 && l2+1=l3 && l3=h3 && - act1 <> act3) - -let approx_count cases i j = - let l = j-i+1 in - if l < !cut then - let _,(_,{n=ntests}) = opt_count false (Array.sub cases i l) in - ntests - else - l-1 - -(* Sends back a boolean that says whether is switch is worth or not *) - -let dense {cases} i j = - if i=j then true - else - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - let ntests = approx_count cases i j in -(* - (ntests+1) >= theta * (h-l+1) -*) - particular_case cases i j || - (ntests >= !switch_min && - float_of_int ntests +. 1.0 >= - !theta *. (float_of_int h -. float_of_int l +. 1.0)) - -(* Compute clusters by dynamic programming - Adaptation of the correction to Bernstein - ``Correction to `Producing Good Code for the Case Statement' '' - S.K. Kannan and T.A. Proebsting - Software Practice and Experience Vol. 24(2) 233 (Feb 1994) -*) - -let comp_clusters s = - let len = Array.length s.cases in - let min_clusters = Array.make len max_int - and k = Array.make len 0 in - let get_min i = if i < 0 then 0 else min_clusters.(i) in - - for i = 0 to len-1 do - for j = 0 to i do - if - dense s j i && - get_min (j-1) + 1 < min_clusters.(i) - then begin - k.(i) <- j ; - min_clusters.(i) <- get_min (j-1) + 1 - end - done ; - done ; - min_clusters.(len-1),k - -(* Assume j > i *) -let make_switch loc {cases=cases ; actions=actions} i j sw_names = - let ll,_,_ = cases.(i) - and _,hh,_ = cases.(j) in - let tbl = Array.make (hh-ll+1) 0 - and t = Hashtbl.create 17 - and index = ref 0 in - let get_index act = - try - Hashtbl.find t act - with - | Not_found -> - let i = !index in - incr index ; - Hashtbl.add t act i ; - i in - - for k=i to j do - let l,h,act = cases.(k) in - let index = get_index act in - for kk=l-ll to h-ll do - tbl.(kk) <- index - done - done ; - let acts = Array.make !index actions.(0) in - Hashtbl.iter - (fun act i -> acts.(i) <- actions.(act)) - t ; - (fun ctx -> - if !Config.bs_only then - Arg.make_switch ~offset:(ll+ctx.off) loc ctx.arg tbl acts sw_names - else - match -ll-ctx.off with - | 0 -> Arg.make_switch loc ctx.arg tbl acts sw_names ~offset:0 - | _ -> - Arg.bind - (Arg.make_offset ctx.arg (-ll-ctx.off)) - (fun arg -> Arg.make_switch loc arg tbl acts sw_names ~offset:0)) - - -let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k sw_names = - let len = Array.length cases in - let r = Array.make n_clusters (0,0,0) - and t = Hashtbl.create 17 - and index = ref 0 - and bidon = ref (Array.length actions) in - let get_index act = - try - let i,_ = Hashtbl.find t act in - i - with - | Not_found -> - let i = !index in - incr index ; - Hashtbl.add - t act - (i,(fun _ -> actions.(act))) ; - i - and add_index act = - let i = !index in - incr index ; - incr bidon ; - Hashtbl.add t !bidon (i,act) ; - i in - - let rec zyva j ir = - let i = k.(j) in - begin if i=j then - let l,h,act = cases.(i) in - r.(ir) <- (l,h,get_index act) - else (* assert i < j *) - let l,_,_ = cases.(i) - and _,h,_ = cases.(j) in - r.(ir) <- (l,h,add_index (make_switch loc s i j sw_names)) - end ; - if i > 0 then zyva (i-1) (ir-1) in - - zyva (len-1) (n_clusters-1) ; - let acts = Array.make !index (fun _ -> assert false) in - Hashtbl.iter (fun _ (i,act) -> acts.(i) <- act) t ; - {cases = r ; actions = acts} -;; - - -let do_zyva loc (low,high) arg cases actions sw_names = - let old_ok = !ok_inter in - ok_inter := (abs low <= inter_limit && abs high <= inter_limit) ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - - let s = {cases=cases ; actions=actions} in - -(* - Printf.eprintf "ZYVA: %B [low=%i,high=%i]\n" !ok_inter low high ; - pcases stderr cases ; - prerr_endline "" ; -*) - let n_clusters,k = comp_clusters s in - let clusters = make_clusters loc s n_clusters k sw_names in - c_test {arg=arg ; off=0} clusters - -let abstract_shared actions = - let handlers = ref (fun x -> x) in - let actions = - Array.map - (fun act -> match act with - | Single act -> act - | Shared act -> - let i,h = Arg.make_catch act in - let oh = !handlers in - handlers := (fun act -> h (oh act)) ; - Arg.make_exit i) - actions in - !handlers,actions - -let zyva loc lh arg cases actions names = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - hs (do_zyva loc lh arg cases actions names) - -and test_sequence arg cases actions = - assert (Array.length cases > 0) ; - let actions = actions.act_get_shared () in - let hs,actions = abstract_shared actions in - let old_ok = !ok_inter in - ok_inter := false ; - if !ok_inter <> old_ok then Hashtbl.clear t ; - let s = - {cases=cases ; - actions=Array.map (fun act -> (fun _ -> act)) actions} in -(* - Printf.eprintf "SEQUENCE: %B\n" !ok_inter ; - pcases stderr cases ; - prerr_endline "" ; -*) - hs (c_test {arg=arg ; off=0} s) -;; - -end diff --git a/jscomp/ml/switch.mli b/jscomp/ml/switch.mli deleted file mode 100644 index a12a1be..0000000 --- a/jscomp/ml/switch.mli +++ /dev/null @@ -1,119 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Luc Maranget, projet Moscova, INRIA Rocquencourt *) -(* *) -(* Copyright 2000 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. *) -(* *) -(**************************************************************************) - -(* - This module transforms generic switches in combinations - of if tests and switches. -*) - -(* For detecting action sharing, object style *) - -(* Store for actions in object style: - act_store : store an action, returns index in table - In case an action with equal key exists, returns index - of the stored action. Otherwise add entry in table. - act_store_shared : This stored action will always be shared. - act_get : retrieve table - act_get_shared : retrieve table, with sharing explicit -*) - -type 'a shared = Shared of 'a | Single of 'a - -type 'a t_store = - {act_get : unit -> 'a array ; - act_get_shared : unit -> 'a shared array ; - act_store : 'a -> int ; - act_store_shared : 'a -> int ; } - -exception Not_simple - -module type Stored = sig - type t - type key - val compare_key : key -> key -> int - val make_key : t -> key option -end - -module Store(A:Stored) : - sig - val mk_store : unit -> A.t t_store - end - -(* Arguments to the Make functor *) -module type S = - sig - (* type of basic tests *) - type primitive - (* basic tests themselves *) - val eqint : primitive - val neint : primitive - val leint : primitive - val ltint : primitive - val geint : primitive - val gtint : primitive - (* type of actions *) - type act - - (* Various constructors, for making a binder, - adding one integer, etc. *) - val bind : act -> (act -> act) -> act - val make_const : int -> act - val make_offset : act -> int -> act - val make_prim : primitive -> act list -> act - val make_isout : act -> act -> act - val make_isin : act -> act -> act - val make_if : act -> act -> act -> act - (* construct an actual switch : - make_switch arg cases acts - NB: cases is in the value form *) - val make_switch : - Location.t -> act -> int array -> act array -> offset:int -> Ast_untagged_variants.switch_names option -> act - (* Build last minute sharing of action stuff *) - val make_catch : act -> int * (act -> act) - val make_exit : int -> act - - end - - -(* - Make.zyva arg low high cases actions where - - arg is the argument of the switch. - - low, high are the interval limits. - - cases is a list of sub-interval and action indices - - actions is an array of actions. - - All these arguments specify a switch construct and zyva - returns an action that performs the switch. -*) -module Make : - functor (Arg : S) -> - sig -(* Standard entry point, sharing is tracked *) - val zyva : - Location.t -> - (int * int) -> - Arg.act -> - (int * int * int) array -> - Arg.act t_store -> - Ast_untagged_variants.switch_names option -> - Arg.act - -(* Output test sequence, sharing tracked *) - val test_sequence : - Arg.act -> - (int * int * int) array -> - Arg.act t_store -> - Arg.act - end diff --git a/jscomp/ml/syntaxerr.ml b/jscomp/ml/syntaxerr.ml deleted file mode 100644 index 0bb55ab..0000000 --- a/jscomp/ml/syntaxerr.ml +++ /dev/null @@ -1,87 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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. *) -(* *) -(**************************************************************************) - -(* Auxiliary type for reporting syntax errors *) - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - -exception Error of error -exception Escape_error - -let prepare_error = function - | Unclosed(opening_loc, opening, closing_loc, closing) -> - Location.errorf ~loc:closing_loc - ~sub:[ - Location.errorf ~loc:opening_loc - "This '%s' might be unmatched" opening - ] - ~if_highlight: - (Printf.sprintf "Syntax error: '%s' expected, \ - the highlighted '%s' might be unmatched" - closing opening) - "Syntax error: '%s' expected" closing - - | Expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %s expected." nonterm - | Not_expecting (loc, nonterm) -> - Location.errorf ~loc "Syntax error: %s not expected." nonterm - | Applicative_path loc -> - Location.errorf ~loc - "Syntax error: applicative paths of the form F(X).t \ - are not supported when the option -no-app-func is set." - | Variable_in_scope (loc, var) -> - Location.errorf ~loc - "In this scoped type, variable '%s \ - is reserved for the local type %s." - var var - | Other loc -> - Location.errorf ~loc "Syntax error" - | Ill_formed_ast (loc, s) -> - Location.errorf ~loc "broken invariant in parsetree: %s" s - | Invalid_package_type (loc, s) -> - Location.errorf ~loc "invalid package type: %s" s - -let () = - Location.register_error_of_exn - (function - | Error err -> Some (prepare_error err) - | _ -> None - ) - - -let report_error ppf err = - Location.report_error ppf (prepare_error err) - -let location_of_error = function - | Unclosed(l,_,_,_) - | Applicative_path l - | Variable_in_scope(l,_) - | Other l - | Not_expecting (l, _) - | Ill_formed_ast (l, _) - | Invalid_package_type (l, _) - | Expecting (l, _) -> l - - -let ill_formed_ast loc s = - raise (Error (Ill_formed_ast (loc, s))) diff --git a/jscomp/ml/syntaxerr.mli b/jscomp/ml/syntaxerr.mli deleted file mode 100644 index 319eb57..0000000 --- a/jscomp/ml/syntaxerr.mli +++ /dev/null @@ -1,37 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1997 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. *) -(* *) -(**************************************************************************) - -(** Auxiliary type for reporting syntax errors *) - -open Format - -type error = - Unclosed of Location.t * string * Location.t * string - | Expecting of Location.t * string - | Not_expecting of Location.t * string - | Applicative_path of Location.t - | Variable_in_scope of Location.t * string - | Other of Location.t - | Ill_formed_ast of Location.t * string - | Invalid_package_type of Location.t * string - -exception Error of error -exception Escape_error - -val report_error: formatter -> error -> unit - (** @deprecated Use {!Location.error_of_exn}, {!Location.report_error}. *) - -val location_of_error: error -> Location.t -val ill_formed_ast: Location.t -> string -> 'a diff --git a/jscomp/ml/tast_mapper.ml b/jscomp/ml/tast_mapper.ml deleted file mode 100644 index eaf6aa4..0000000 --- a/jscomp/ml/tast_mapper.ml +++ /dev/null @@ -1,610 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2015 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Typedtree - -(* TODO: add 'methods' for location, attribute, extension, - open_description, include_declaration, include_description *) - -type mapper = - { - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_description: mapper -> class_description -> class_description; - - class_signature: mapper -> class_signature -> class_signature; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> - class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - env: mapper -> Env.t -> Env.t; - expr: mapper -> expression -> expression; - extension_constructor: mapper -> extension_constructor -> - extension_constructor; - module_binding: mapper -> module_binding -> module_binding; - module_coercion: mapper -> module_coercion -> module_coercion; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: - mapper -> module_type_declaration -> module_type_declaration; - package_type: mapper -> package_type -> package_type; - pat: mapper -> pattern -> pattern; - row_field: mapper -> row_field -> row_field; - object_field: mapper -> object_field -> object_field; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_declarations: mapper -> (rec_flag * type_declaration list) -> - (rec_flag * type_declaration list); - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_bindings: mapper -> (rec_flag * value_binding list) -> - (rec_flag * value_binding list); - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - -let id x = x -let tuple2 f1 f2 (x, y) = (f1 x, f2 y) -let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -let opt f = function None -> None | Some x -> Some (f x) - -let structure sub {str_items; str_type; str_final_env} = - { - str_items = List.map (sub.structure_item sub) str_items; - str_final_env = sub.env sub str_final_env; - str_type; - } - -let class_infos sub f x = - {x with - ci_params = List.map (tuple2 (sub.typ sub) id) x.ci_params; - ci_expr = f x.ci_expr; - } - -let module_type_declaration sub x = - let mtd_type = opt (sub.module_type sub) x.mtd_type in - {x with mtd_type} - -let module_declaration sub x = - let md_type = sub.module_type sub x.md_type in - {x with md_type} - -let include_infos f x = {x with incl_mod = f x.incl_mod} - -let class_type_declaration sub x = - class_infos sub (sub.class_type sub) x - - -let structure_item sub {str_desc; str_loc; str_env} = - let str_env = sub.env sub str_env in - let str_desc = - match str_desc with - | Tstr_eval (exp, attrs) -> Tstr_eval (sub.expr sub exp, attrs) - | Tstr_value (rec_flag, list) -> - let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in - Tstr_value (rec_flag, list) - | Tstr_primitive v -> Tstr_primitive (sub.value_description sub v) - | Tstr_type (rec_flag, list) -> - let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in - Tstr_type (rec_flag, list) - | Tstr_typext te -> Tstr_typext (sub.type_extension sub te) - | Tstr_exception ext -> Tstr_exception (sub.extension_constructor sub ext) - | Tstr_module mb -> Tstr_module (sub.module_binding sub mb) - | Tstr_recmodule list -> - Tstr_recmodule (List.map (sub.module_binding sub) list) - | Tstr_modtype x -> Tstr_modtype (sub.module_type_declaration sub x) - | Tstr_class () -> Tstr_class () - | Tstr_class_type list -> - Tstr_class_type - (List.map (tuple3 id id (sub.class_type_declaration sub)) list) - | Tstr_include incl -> - Tstr_include (include_infos (sub.module_expr sub) incl) - | Tstr_open _ - | Tstr_attribute _ as d -> d - in - {str_desc; str_env; str_loc} - -let value_description sub x = - let val_desc = sub.typ sub x.val_desc in - {x with val_desc} - -let label_decl sub x = - let ld_type = sub.typ sub x.ld_type in - {x with ld_type} - -let constructor_args sub = function - | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l) - | Cstr_record l -> Cstr_record (List.map (label_decl sub) l) - -let constructor_decl sub cd = - let cd_args = constructor_args sub cd.cd_args in - let cd_res = opt (sub.typ sub) cd.cd_res in - {cd with cd_args; cd_res} - -let type_kind sub = function - | Ttype_abstract -> Ttype_abstract - | Ttype_variant list -> Ttype_variant (List.map (constructor_decl sub) list) - | Ttype_record list -> Ttype_record (List.map (label_decl sub) list) - | Ttype_open -> Ttype_open - -let type_declaration sub x = - let typ_cstrs = - List.map - (tuple3 (sub.typ sub) (sub.typ sub) id) - x.typ_cstrs - in - let typ_kind = sub.type_kind sub x.typ_kind in - let typ_manifest = opt (sub.typ sub) x.typ_manifest in - let typ_params = List.map (tuple2 (sub.typ sub) id) x.typ_params in - {x with typ_cstrs; typ_kind; typ_manifest; typ_params} - -let type_declarations sub (rec_flag, list) = - (rec_flag, List.map (sub.type_declaration sub) list) - -let type_extension sub x = - let tyext_params = List.map (tuple2 (sub.typ sub) id) x.tyext_params in - let tyext_constructors = - List.map (sub.extension_constructor sub) x.tyext_constructors - in - {x with tyext_constructors; tyext_params} - -let extension_constructor sub x = - let ext_kind = - match x.ext_kind with - Text_decl(ctl, cto) -> - Text_decl(constructor_args sub ctl, opt (sub.typ sub) cto) - | Text_rebind _ as d -> d - in - {x with ext_kind} - -let pat sub x = - let extra = function - | Tpat_type _ - | Tpat_unpack as d -> d - | Tpat_open (path,loc,env) -> Tpat_open (path, loc, sub.env sub env) - | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) - in - let pat_env = sub.env sub x.pat_env in - let pat_extra = List.map (tuple3 extra id id) x.pat_extra in - let pat_desc = - match x.pat_desc with - | Tpat_any - | Tpat_var _ - | Tpat_constant _ as d -> d - | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) - | Tpat_construct (loc, cd, l) -> - Tpat_construct (loc, cd, List.map (sub.pat sub) l) - | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd) - | Tpat_record (l, closed) -> - Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) - | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) - | Tpat_or (p1, p2, rd) -> - Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) - | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) - | Tpat_lazy p -> Tpat_lazy (sub.pat sub p) - in - {x with pat_extra; pat_desc; pat_env} - -let expr sub x = - let extra = function - | Texp_constraint cty -> - Texp_constraint (sub.typ sub cty) - | Texp_coerce (cty1, cty2) -> - Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2) - | Texp_open (ovf, path, loc, env) -> - Texp_open (ovf, path, loc, sub.env sub env) - | Texp_newtype _ as d -> d - | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto) - in - let exp_extra = List.map (tuple3 extra id id) x.exp_extra in - let exp_env = sub.env sub x.exp_env in - let exp_desc = - match x.exp_desc with - | Texp_ident _ - | Texp_constant _ as d -> d - | Texp_let (rec_flag, list, exp) -> - let (rec_flag, list) = sub.value_bindings sub (rec_flag, list) in - Texp_let (rec_flag, list, sub.expr sub exp) - | Texp_function { arg_label; param; cases; partial; } -> - Texp_function { arg_label; param; cases = sub.cases sub cases; - partial; } - | Texp_apply (exp, list) -> - Texp_apply ( - sub.expr sub exp, - List.map (tuple2 id (opt (sub.expr sub))) list - ) - | Texp_match (exp, cases, exn_cases, p) -> - Texp_match ( - sub.expr sub exp, - sub.cases sub cases, - sub.cases sub exn_cases, - p - ) - | Texp_try (exp, cases) -> - Texp_try ( - sub.expr sub exp, - sub.cases sub cases - ) - | Texp_tuple list -> - Texp_tuple (List.map (sub.expr sub) list) - | Texp_construct (lid, cd, args) -> - Texp_construct (lid, cd, List.map (sub.expr sub) args) - | Texp_variant (l, expo) -> - Texp_variant (l, opt (sub.expr sub) expo) - | Texp_record { fields; representation; extended_expression } -> - let fields = Array.map (function - | label, Kept t -> label, Kept t - | label, Overridden (lid, exp) -> - label, Overridden (lid, sub.expr sub exp)) - fields - in - Texp_record { - fields; representation; - extended_expression = opt (sub.expr sub) extended_expression; - } - | Texp_field (exp, lid, ld) -> - Texp_field (sub.expr sub exp, lid, ld) - | Texp_setfield (exp1, lid, ld, exp2) -> - Texp_setfield ( - sub.expr sub exp1, - lid, - ld, - sub.expr sub exp2 - ) - | Texp_array list -> - Texp_array (List.map (sub.expr sub) list) - | Texp_ifthenelse (exp1, exp2, expo) -> - Texp_ifthenelse ( - sub.expr sub exp1, - sub.expr sub exp2, - opt (sub.expr sub) expo - ) - | Texp_sequence (exp1, exp2) -> - Texp_sequence ( - sub.expr sub exp1, - sub.expr sub exp2 - ) - | Texp_while (exp1, exp2) -> - Texp_while ( - sub.expr sub exp1, - sub.expr sub exp2 - ) - | Texp_for (id, p, exp1, exp2, dir, exp3) -> - Texp_for ( - id, - p, - sub.expr sub exp1, - sub.expr sub exp2, - dir, - sub.expr sub exp3 - ) - | Texp_send (exp, meth, expo) -> - Texp_send - ( - sub.expr sub exp, - meth, - opt (sub.expr sub) expo - ) - | Texp_new _ - | Texp_instvar _ as d -> d - | Texp_setinstvar _ - | Texp_override _ -> - assert false - | Texp_letmodule (id, s, mexpr, exp) -> - Texp_letmodule ( - id, - s, - sub.module_expr sub mexpr, - sub.expr sub exp - ) - | Texp_letexception (cd, exp) -> - Texp_letexception ( - sub.extension_constructor sub cd, - sub.expr sub exp - ) - | Texp_assert exp -> - Texp_assert (sub.expr sub exp) - | Texp_lazy exp -> - Texp_lazy (sub.expr sub exp) - | Texp_object () -> - Texp_object () - | Texp_pack mexpr -> - Texp_pack (sub.module_expr sub mexpr) - | Texp_unreachable -> - Texp_unreachable - | Texp_extension_constructor _ as e -> - e - in - {x with exp_extra; exp_desc; exp_env} - - -let package_type sub x = - let pack_fields = List.map (tuple2 id (sub.typ sub)) x.pack_fields in - {x with pack_fields} - -let signature sub x = - let sig_final_env = sub.env sub x.sig_final_env in - let sig_items = List.map (sub.signature_item sub) x.sig_items in - {x with sig_items; sig_final_env} - -let signature_item sub x = - let sig_env = sub.env sub x.sig_env in - let sig_desc = - match x.sig_desc with - | Tsig_value v -> - Tsig_value (sub.value_description sub v) - | Tsig_type (rec_flag, list) -> - let (rec_flag, list) = sub.type_declarations sub (rec_flag, list) in - Tsig_type (rec_flag, list) - | Tsig_typext te -> - Tsig_typext (sub.type_extension sub te) - | Tsig_exception ext -> - Tsig_exception (sub.extension_constructor sub ext) - | Tsig_module x -> - Tsig_module (sub.module_declaration sub x) - | Tsig_recmodule list -> - Tsig_recmodule (List.map (sub.module_declaration sub) list) - | Tsig_modtype x -> - Tsig_modtype (sub.module_type_declaration sub x) - | Tsig_include incl -> - Tsig_include (include_infos (sub.module_type sub) incl) - | Tsig_class_type list -> - Tsig_class_type - (List.map (sub.class_type_declaration sub) list) - | Tsig_class _ - | Tsig_open _ - | Tsig_attribute _ as d -> d - in - {x with sig_desc; sig_env} - -let class_description sub x = - class_infos sub (sub.class_type sub) x - -let module_type sub x = - let mty_env = sub.env sub x.mty_env in - let mty_desc = - match x.mty_desc with - | Tmty_ident _ - | Tmty_alias _ as d -> d - | Tmty_signature sg -> Tmty_signature (sub.signature sub sg) - | Tmty_functor (id, s, mtype1, mtype2) -> - Tmty_functor ( - id, - s, - opt (sub.module_type sub) mtype1, - sub.module_type sub mtype2 - ) - | Tmty_with (mtype, list) -> - Tmty_with ( - sub.module_type sub mtype, - List.map (tuple3 id id (sub.with_constraint sub)) list - ) - | Tmty_typeof mexpr -> - Tmty_typeof (sub.module_expr sub mexpr) - in - {x with mty_desc; mty_env} - -let with_constraint sub = function - | Twith_type decl -> Twith_type (sub.type_declaration sub decl) - | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) - | Twith_module _ - | Twith_modsubst _ as d -> d - -let module_coercion sub = function - | Tcoerce_none -> Tcoerce_none - | Tcoerce_functor (c1,c2) -> - Tcoerce_functor (sub.module_coercion sub c1, sub.module_coercion sub c2) - | Tcoerce_alias (p, c1) -> - Tcoerce_alias (p, sub.module_coercion sub c1) - | Tcoerce_structure (l1, l2, runtime_fields) -> - let l1' = List.map (fun (i,c) -> i, sub.module_coercion sub c) l1 in - let l2' = - List.map (fun (id,i,c) -> id, i, sub.module_coercion sub c) l2 - in - Tcoerce_structure (l1', l2', runtime_fields) - | Tcoerce_primitive pc -> - Tcoerce_primitive {pc with pc_env = sub.env sub pc.pc_env} - -let module_expr sub x = - let mod_env = sub.env sub x.mod_env in - let mod_desc = - match x.mod_desc with - | Tmod_ident _ as d -> d - | Tmod_structure st -> Tmod_structure (sub.structure sub st) - | Tmod_functor (id, s, mtype, mexpr) -> - Tmod_functor ( - id, - s, - opt (sub.module_type sub) mtype, - sub.module_expr sub mexpr - ) - | Tmod_apply (mexp1, mexp2, c) -> - Tmod_apply ( - sub.module_expr sub mexp1, - sub.module_expr sub mexp2, - sub.module_coercion sub c - ) - | Tmod_constraint (mexpr, mt, Tmodtype_implicit, c) -> - Tmod_constraint (sub.module_expr sub mexpr, mt, Tmodtype_implicit, - sub.module_coercion sub c) - | Tmod_constraint (mexpr, mt, Tmodtype_explicit mtype, c) -> - Tmod_constraint ( - sub.module_expr sub mexpr, - mt, - Tmodtype_explicit (sub.module_type sub mtype), - sub.module_coercion sub c - ) - | Tmod_unpack (exp, mty) -> - Tmod_unpack - ( - sub.expr sub exp, - mty - ) - in - {x with mod_desc; mod_env} - -let module_binding sub x = - let mb_expr = sub.module_expr sub x.mb_expr in - {x with mb_expr} - - -let class_type sub x = - let cltyp_env = sub.env sub x.cltyp_env in - let cltyp_desc = - match x.cltyp_desc with - | Tcty_signature csg -> Tcty_signature (sub.class_signature sub csg) - | Tcty_constr (path, lid, list) -> - Tcty_constr ( - path, - lid, - List.map (sub.typ sub) list - ) - | Tcty_arrow (label, ct, cl) -> - Tcty_arrow - (label, - sub.typ sub ct, - sub.class_type sub cl - ) - | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e) - in - {x with cltyp_desc; cltyp_env} - -let class_signature sub x = - let csig_self = sub.typ sub x.csig_self in - let csig_fields = List.map (sub.class_type_field sub) x.csig_fields in - {x with csig_self; csig_fields} - -let class_type_field sub x = - let ctf_desc = - match x.ctf_desc with - | Tctf_inherit ct -> - Tctf_inherit (sub.class_type sub ct) - | Tctf_val (s, mut, virt, ct) -> - Tctf_val (s, mut, virt, sub.typ sub ct) - | Tctf_method (s, priv, virt, ct) -> - Tctf_method (s, priv, virt, sub.typ sub ct) - | Tctf_constraint (ct1, ct2) -> - Tctf_constraint (sub.typ sub ct1, sub.typ sub ct2) - | Tctf_attribute _ as d -> d - in - {x with ctf_desc} - -let typ sub x = - let ctyp_env = sub.env sub x.ctyp_env in - let ctyp_desc = - match x.ctyp_desc with - | Ttyp_any - | Ttyp_var _ as d -> d - | Ttyp_arrow (label, ct1, ct2) -> - Ttyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) - | Ttyp_tuple list -> Ttyp_tuple (List.map (sub.typ sub) list) - | Ttyp_constr (path, lid, list) -> - Ttyp_constr (path, lid, List.map (sub.typ sub) list) - | Ttyp_object (list, closed) -> - Ttyp_object ((List.map (sub.object_field sub) list), closed) - | Ttyp_class (path, lid, list) -> - Ttyp_class - (path, - lid, - List.map (sub.typ sub) list - ) - | Ttyp_alias (ct, s) -> - Ttyp_alias (sub.typ sub ct, s) - | Ttyp_variant (list, closed, labels) -> - Ttyp_variant (List.map (sub.row_field sub) list, closed, labels) - | Ttyp_poly (sl, ct) -> - Ttyp_poly (sl, sub.typ sub ct) - | Ttyp_package pack -> - Ttyp_package (sub.package_type sub pack) - in - {x with ctyp_desc; ctyp_env} - - -let row_field sub = function - | Ttag (label, attrs, b, list) -> - Ttag (label, attrs, b, List.map (sub.typ sub) list) - | Tinherit ct -> Tinherit (sub.typ sub ct) - -let object_field sub = function - | OTtag (label, attrs, ct) -> - OTtag (label, attrs, (sub.typ sub ct)) - | OTinherit ct -> OTinherit (sub.typ sub ct) - - - -let value_bindings sub (rec_flag, list) = - (rec_flag, List.map (sub.value_binding sub) list) - -let cases sub l = - List.map (sub.case sub) l - -let case sub {c_lhs; c_guard; c_rhs} = - { - c_lhs = sub.pat sub c_lhs; - c_guard = opt (sub.expr sub) c_guard; - c_rhs = sub.expr sub c_rhs; - } - -let value_binding sub x = - let vb_pat = sub.pat sub x.vb_pat in - let vb_expr = sub.expr sub x.vb_expr in - {x with vb_pat; vb_expr} - -let env _sub x = x - -let default = - { - case; - cases; - class_description; - class_signature; - class_type; - class_type_declaration; - class_type_field; - env; - expr; - extension_constructor; - module_binding; - module_coercion; - module_declaration; - module_expr; - module_type; - module_type_declaration; - package_type; - pat; - row_field; - object_field; - signature; - signature_item; - structure; - structure_item; - typ; - type_declaration; - type_declarations; - type_extension; - type_kind; - value_binding; - value_bindings; - value_description; - with_constraint; - } diff --git a/jscomp/ml/tast_mapper.mli b/jscomp/ml/tast_mapper.mli deleted file mode 100644 index 4fd87b6..0000000 --- a/jscomp/ml/tast_mapper.mli +++ /dev/null @@ -1,64 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2015 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Typedtree - -(** {1 A generic Typedtree mapper} *) - -type mapper = - { - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_description: mapper -> class_description -> class_description; - class_signature: mapper -> class_signature -> class_signature; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration -> - class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - env: mapper -> Env.t -> Env.t; - expr: mapper -> expression -> expression; - extension_constructor: mapper -> extension_constructor -> - extension_constructor; - module_binding: mapper -> module_binding -> module_binding; - module_coercion: mapper -> module_coercion -> module_coercion; - module_declaration: mapper -> module_declaration -> module_declaration; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: - mapper -> module_type_declaration -> module_type_declaration; - package_type: mapper -> package_type -> package_type; - pat: mapper -> pattern -> pattern; - row_field: mapper -> row_field -> row_field; - object_field: mapper -> object_field -> object_field; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_declarations: mapper -> (rec_flag * type_declaration list) -> - (rec_flag * type_declaration list); - type_extension: mapper -> type_extension -> type_extension; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_bindings: mapper -> (rec_flag * value_binding list) -> - (rec_flag * value_binding list); - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - } - - -val default: mapper diff --git a/jscomp/ml/tbl.ml b/jscomp/ml/tbl.ml deleted file mode 100644 index fa278b4..0000000 --- a/jscomp/ml/tbl.ml +++ /dev/null @@ -1,123 +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. *) -(* *) -(**************************************************************************) - -type ('k, 'v) t = - Empty - | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int - -let empty = Empty - -let height = function - Empty -> 0 - | Node(_,_,_,_,h) -> h - -let create l x d r = - let hl = height l and hr = height r in - Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) - -let bal l x d r = - let hl = height l and hr = height r in - if hl > hr + 1 then - match l with - | Node (ll, lv, ld, lr, _) when height ll >= height lr -> - create ll lv ld (create lr x d r) - | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) -> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - | _ -> assert false - else if hr > hl + 1 then - match r with - | Node (rl, rv, rd, rr, _) when height rr >= height rl -> - create (create l x d rl) rv rd rr - | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - | _ -> assert false - else - create l x d r - -let rec add x data = function - Empty -> - Node(Empty, x, data, Empty, 1) - | Node(l, v, d, r, h) -> - let c = compare x v in - if c = 0 then - Node(l, x, data, r, h) - else if c < 0 then - bal (add x data l) v d r - else - bal l v d (add x data r) - -let rec find x = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = compare x v in - if c = 0 then d - else find x (if c < 0 then l else r) - -let rec find_str (x : string) = function - Empty -> - raise Not_found - | Node(l, v, d, r, _) -> - let c = compare x v in - if c = 0 then d - else find_str x (if c < 0 then l else r) - -let rec mem x = function - Empty -> false - | Node(l, v, _d, r, _) -> - let c = compare x v in - c = 0 || mem x (if c < 0 then l else r) - -let rec merge t1 t2 = - match (t1, t2) with - (Empty, t) -> t - | (t, Empty) -> t - | (Node(l1, v1, d1, r1, _h1), Node(l2, v2, d2, r2, _h2)) -> - bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) - -let rec remove x = function - Empty -> - Empty - | Node(l, v, d, r, _h) -> - let c = compare x v in - if c = 0 then - merge l r - else if c < 0 then - bal (remove x l) v d r - else - bal l v d (remove x r) - -let rec iter f = function - Empty -> () - | Node(l, v, d, r, _) -> - iter f l; f v d; iter f r - -let rec map f = function - Empty -> Empty - | Node(l, v, d, r, h) -> Node(map f l, v, f v d, map f r, h) - -let rec fold f m accu = - match m with - | Empty -> accu - | Node(l, v, d, r, _) -> - fold f r (f v d (fold f l accu)) - -open Format - -let print print_key print_data ppf tbl = - let print_tbl ppf tbl = - iter (fun k d -> fprintf ppf "@[<2>%a ->@ %a;@]@ " print_key k print_data d) - tbl in - fprintf ppf "@[[[%a]]@]" print_tbl tbl diff --git a/jscomp/ml/tbl.mli b/jscomp/ml/tbl.mli deleted file mode 100644 index d23b959..0000000 --- a/jscomp/ml/tbl.mli +++ /dev/null @@ -1,34 +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. *) -(* *) -(**************************************************************************) - -(* Association tables from any ordered type to any type. - We use the generic ordering to compare keys. *) - -type ('k, 'v) t - -val empty: ('k, 'v) t -val add: 'k -> 'v -> ('k, 'v) t -> ('k, 'v) t -val find: 'k -> ('k, 'v) t -> 'v -val find_str: string -> (string, 'v) t -> 'v -val mem: 'k -> ('k, 'v) t -> bool -val remove: 'k -> ('k, 'v) t -> ('k, 'v) t -val iter: ('k -> 'v -> unit) -> ('k, 'v) t -> unit -val map: ('k -> 'v1 -> 'v2) -> ('k, 'v1) t -> ('k, 'v2) t -val fold: ('k -> 'v -> 'acc -> 'acc) -> ('k, 'v) t -> 'acc -> 'acc - -open Format - -val print: (formatter -> 'k -> unit) -> (formatter -> 'v -> unit) -> - formatter -> ('k, 'v) t -> unit diff --git a/jscomp/ml/terminfo.ml b/jscomp/ml/terminfo.ml deleted file mode 100644 index 5ed4bb5..0000000 --- a/jscomp/ml/terminfo.ml +++ /dev/null @@ -1,26 +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. *) -(* *) -(**************************************************************************) - -(* Basic interface to the terminfo database *) - -type status = - | Uninitialised - | Bad_term - | Good_term of int -;; -external setup : out_channel -> status = "caml_terminfo_setup";; -external backup : int -> unit = "caml_terminfo_backup";; -external standout : bool -> unit = "caml_terminfo_standout";; -external resume : int -> unit = "caml_terminfo_resume";; diff --git a/jscomp/ml/terminfo.mli b/jscomp/ml/terminfo.mli deleted file mode 100644 index 92af80f..0000000 --- a/jscomp/ml/terminfo.mli +++ /dev/null @@ -1,26 +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. *) -(* *) -(**************************************************************************) - -(* Basic interface to the terminfo database *) - -type status = - | Uninitialised - | Bad_term - | Good_term of int (* number of lines of the terminal *) -;; -external setup : out_channel -> status = "caml_terminfo_setup";; -external backup : int -> unit = "caml_terminfo_backup";; -external standout : bool -> unit = "caml_terminfo_standout";; -external resume : int -> unit = "caml_terminfo_resume";; diff --git a/jscomp/ml/transl_recmodule.ml b/jscomp/ml/transl_recmodule.ml deleted file mode 100644 index 5d2c174..0000000 --- a/jscomp/ml/transl_recmodule.ml +++ /dev/null @@ -1,280 +0,0 @@ -open Types -open Typedtree -open Lambda - -type error = Circular_dependency of Ident.t - -exception Error of Location.t * error -(* Reorder bindings to honor dependencies. *) - -(* Utilities for compiling "module rec" definitions *) - -let undefined_location loc = - let fname, line, char = Location.get_pos_info loc.Location.loc_start in - let fname = Filename.basename fname in - Lconst - (Const_block - ( Lambda.Blk_tuple, - [ - Const_base (Const_string (fname, None)); - Const_base (Const_int line); - Const_base (Const_int char); - ] )) - -let cstr_const = 3 - -let cstr_non_const = 2 - -let init_shape modl = - let add_name x id = - Const_block - (Blk_tuple, [ x; Const_base (Const_string (Ident.name id, None)) ]) - in - let module_tag_info : Lambda.tag_info = - Blk_constructor { name="Module"; num_nonconst = 2; tag = 0; attrs = [] } - in - let value_tag_info : Lambda.tag_info = - Blk_constructor { name = "value"; num_nonconst = 2; tag = 1; attrs = [] } - in - let rec init_shape_mod env mty = - match Mtype.scrape env mty with - | Mty_ident _ -> raise Not_found - | Mty_alias _ -> - Const_block (value_tag_info, [ Const_pointer (0, Pt_module_alias) ]) - | Mty_signature sg -> - Const_block - ( module_tag_info, - [ Const_block (Blk_tuple, init_shape_struct env sg) ] ) - | Mty_functor _ -> raise Not_found - (* can we do better? *) - and init_shape_struct env sg = - match sg with - | [] -> [] - | Sig_value (id, { val_kind = Val_reg; val_type = ty }) :: rem -> - let is_function t = - Ast_uncurried_utils.typeIsUncurriedFun t || match t.desc with - | Tarrow _ -> true - | _ -> false in - let init_v = - match Ctype.expand_head env ty with - | t when is_function t -> - Const_pointer - ( 0, - Pt_constructor - { - name = "Function"; - const = cstr_const; - non_const = cstr_non_const; - attrs = []; - } ) - | { desc = Tconstr (p, _, _) } when Path.same p Predef.path_lazy_t -> - Const_pointer - ( 1, - Pt_constructor - { - name = "Lazy"; - const = cstr_const; - non_const = cstr_non_const; - attrs = []; - } ) - | _ -> raise Not_found - in - add_name init_v id :: init_shape_struct env rem - | Sig_value (_, { val_kind = Val_prim _ }) :: rem -> - init_shape_struct env rem - | Sig_type (id, tdecl, _) :: rem -> - init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_typext _ :: _ -> raise Not_found - | Sig_module (id, md, _) :: rem -> - add_name (init_shape_mod env md.md_type) id - :: - init_shape_struct - (Env.add_module_declaration ~check:false id md env) - rem - | Sig_modtype (id, minfo) :: rem -> - init_shape_struct (Env.add_modtype id minfo env) rem - | Sig_class _ :: _ -> assert false - | Sig_class_type _ :: rem -> init_shape_struct env rem - in - try - Some - ( undefined_location modl.mod_loc, - Lconst (init_shape_mod modl.mod_env modl.mod_type) ) - with Not_found -> None - -type binding_status = Undefined | Inprogress | Defined - -let reorder_rec_bindings bindings = - let id = Array.of_list (List.map (fun (id, _, _, _) -> id) bindings) - and loc = Array.of_list (List.map (fun (_, loc, _, _) -> loc) bindings) - and init = Array.of_list (List.map (fun (_, _, init, _) -> init) bindings) - and rhs = Array.of_list (List.map (fun (_, _, _, rhs) -> rhs) bindings) in - let fv = Array.map Lambda.free_variables rhs in - let num_bindings = Array.length id in - let status = Array.make num_bindings Undefined in - let res = ref [] in - let rec emit_binding i = - match status.(i) with - | Defined -> () - | Inprogress -> raise (Error (loc.(i), Circular_dependency id.(i))) - | Undefined -> - if init.(i) = None then ( - status.(i) <- Inprogress; - for j = 0 to num_bindings - 1 do - if IdentSet.mem id.(j) fv.(i) then emit_binding j - done); - res := (id.(i), init.(i), rhs.(i)) :: !res; - status.(i) <- Defined - in - for i = 0 to num_bindings - 1 do - match status.(i) with - | Undefined -> emit_binding i - | Inprogress -> assert false - | Defined -> () - done; - List.rev !res - -type t = Lambda.lambda - -(* Utilities for compiling "module rec" definitions *) - -let bs_init_mod (args : t list) loc : t = - Lprim - (Pccall (Primitive.simple ~name:"#init_mod" ~arity:2 ~alloc:true), args, loc) - -let bs_update_mod (args : t list) loc : t = - Lprim - ( Pccall (Primitive.simple ~name:"#update_mod" ~arity:3 ~alloc:true), - args, - loc ) - -type loc = t - -type shape = t - -type binding = Ident.t * (loc * shape) option * t - -let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = - let rec bind_inits args acc = - match args with - | [] -> acc - | (_id, None, _rhs) :: rem -> bind_inits rem acc - | (id, Some (loc, shape), _rhs) :: rem -> - Lambda.Llet - ( Strict, - Pgenval, - id, - bs_init_mod [ loc; shape ] Location.none, - bind_inits rem acc ) - in - let rec bind_strict args acc = - match args with - | [] -> acc - | (id, None, rhs) :: rem -> - Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc) - | (_id, Some _, _rhs) :: rem -> bind_strict rem acc - in - let rec patch_forwards args = - match args with - | [] -> cont - | (_id, None, _rhs) :: rem -> patch_forwards rem - | (id, Some (_loc, shape), rhs) :: rem -> - Lsequence - ( bs_update_mod [ shape; Lvar id; rhs ] Location.none, - patch_forwards rem ) - in - bind_inits bindings (bind_strict bindings (patch_forwards bindings)) - -(* collect all function declarations - if the module creation is just a set of function declarations and consts, - it is good -*) -let rec is_function_or_const_block (lam : Lambda.lambda) acc = - match lam with - | Lprim (Pmakeblock _, args, _) -> - Ext_list.for_all args (fun x -> - match x with - | Lvar id -> Set_ident.mem acc id - | Lfunction _ | Lconst _ -> true - | _ -> false) - | Llet (_, _, id, Lfunction _, cont) -> - is_function_or_const_block cont (Set_ident.add acc id) - | Lletrec (bindings, cont) -> ( - let rec aux_bindings bindings acc = - match bindings with - | [] -> Some acc - | (id, Lambda.Lfunction _) :: rest -> - aux_bindings rest (Set_ident.add acc id) - | (_, _) :: _ -> None - in - match aux_bindings bindings acc with - | None -> false - | Some acc -> is_function_or_const_block cont acc) - | Llet (_, _, _, Lconst _, cont) -> is_function_or_const_block cont acc - | Llet (_, _, id1, Lvar id2, cont) when Set_ident.mem acc id2 -> - is_function_or_const_block cont (Set_ident.add acc id1) - | _ -> false - -let is_strict_or_all_functions (xs : binding list) = - Ext_list.for_all xs (fun (_, opt, rhs) -> - match opt with - | None -> true - | _ -> is_function_or_const_block rhs Set_ident.empty) - -(* Without such optimizations: - - {[ - module rec X : sig - val f : int -> int - end = struct - let f x = x + 1 - end - and Y : sig - val f : int -> int - end = struct - let f x = x + 2 - end - ]} - would generate such rawlambda: - - {[ - (setglobal Debug_tmp! - (let - (X/1002 = (#init_mod [0: "debug_tmp.ml" 15 6] [0: [0: [0: 0a "f"]]]) - Y/1003 = (#init_mod [0: "debug_tmp.ml" 20 6] [0: [0: [0: 0a "f"]]])) - (seq - (#update_mod [0: [0: [0: 0a "f"]]] X/1002 - (let (f/1010 = (function x/1011 (+ x/1011 1))) - (makeblock 0/[f] f/1010))) - (#update_mod [0: [0: [0: 0a "f"]]] Y/1003 - (let (f/1012 = (function x/1013 (+ x/1013 2))) - (makeblock 0/[f] f/1012))) - (makeblock 0/module/exports X/1002 Y/1003)))) - - ]} -*) -let eval_rec_bindings (bindings : binding list) (cont : t) : t = - if is_strict_or_all_functions bindings then - Lambda.Lletrec (Ext_list.map bindings (fun (id, _, rhs) -> (id, rhs)), cont) - else eval_rec_bindings_aux bindings cont - -let compile_recmodule compile_rhs bindings cont = - eval_rec_bindings - (reorder_rec_bindings - (List.map - (fun { mb_id = id; mb_expr = modl; mb_loc = loc; _ } -> - (id, modl.mod_loc, init_shape modl, compile_rhs id modl loc)) - bindings)) - cont - -let report_error ppf = function - | Circular_dependency id -> - Format.fprintf ppf - "@[Cannot safely evaluate the definition@ of the recursively-defined \ - module %a@]" - Printtyp.ident id - -let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) - | _ -> None) diff --git a/jscomp/ml/translattribute.ml b/jscomp/ml/translattribute.ml deleted file mode 100644 index 4f7eca2..0000000 --- a/jscomp/ml/translattribute.ml +++ /dev/null @@ -1,124 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* *) -(* Copyright 2015 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 t = Parsetree.attribute - -let is_inline_attribute (attr : t) = - match attr with { txt = "inline" }, _ -> true | _ -> false - -let is_inlined_attribute (attr : t) = - match attr with { txt = "inlined" }, _ -> true | _ -> false - -let find_attribute p (attributes : t list) = - let inline_attribute, other_attributes = List.partition p attributes in - let attr = - match inline_attribute with - | [] -> None - | [ attr ] -> Some attr - | _ :: ({ txt; loc }, _) :: _ -> - Location.prerr_warning loc (Warnings.Duplicated_attribute txt); - None - in - (attr, other_attributes) - -let parse_inline_attribute (attr : t option) : Lambda.inline_attribute = - match attr with - | None -> Default_inline - | Some ({ txt; loc }, payload) -> ( - let open Parsetree in - (* the 'inline' and 'inlined' attributes can be used as - [@inline], [@inline never] or [@inline always]. - [@inline] is equivalent to [@inline always] *) - let warning txt = - Warnings.Attribute_payload - (txt, "It must be either empty, 'always' or 'never'") - in - match payload with - | PStr [] -> Always_inline - | PStr [ { pstr_desc = Pstr_eval ({ pexp_desc }, []) } ] -> ( - match pexp_desc with - | Pexp_ident { txt = Longident.Lident "never" } -> Never_inline - | Pexp_ident { txt = Longident.Lident "always" } -> Always_inline - | _ -> - Location.prerr_warning loc (warning txt); - Default_inline) - | _ -> - Location.prerr_warning loc (warning txt); - Default_inline) - -let get_inline_attribute l = - let attr, _ = find_attribute is_inline_attribute l in - parse_inline_attribute attr - -let rec add_inline_attribute (expr : Lambda.lambda) loc attributes = - match (expr, get_inline_attribute attributes) with - | expr, Default_inline -> expr - | Lfunction ({ attr = { stub = false } as attr } as funct), inline -> - (match attr.inline with - | Default_inline -> () - | Always_inline | Never_inline -> - Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); - let attr = { attr with inline } in - Lfunction { funct with attr } - | Lprim (Pccall {prim_name = "#fn_mk" | "#fn_mk_unit"} as p, [e], l), _ -> - Lambda.Lprim (p, [add_inline_attribute e loc attributes], l) - | expr, (Always_inline) -> - Location.prerr_warning loc (Warnings.Misplaced_attribute "inline1"); - expr - | expr, (Never_inline) -> - Location.prerr_warning loc (Warnings.Misplaced_attribute "inline2"); - expr - -(* Get the [@inlined] attribute payload (or default if not present). - It also returns the expression without this attribute. This is - used to ensure that this attribute is not misplaced: If it - appears on any expression, it is an error, otherwise it would - have been removed by this function *) -let get_and_remove_inlined_attribute (e : Typedtree.expression) = - let attr, exp_attributes = - find_attribute is_inlined_attribute e.exp_attributes - in - let inlined = parse_inline_attribute attr in - (inlined, { e with exp_attributes }) - -let get_and_remove_inlined_attribute_on_module (e : Typedtree.module_expr) = - let attr, mod_attributes = - find_attribute is_inlined_attribute e.mod_attributes - in - let inlined = parse_inline_attribute attr in - (inlined, { e with mod_attributes }) - -let check_attribute (e : Typedtree.expression) (({ txt; loc }, _) : t) = - match txt with - | "inline" -> ( - match e.exp_desc with - | Texp_function _ -> () - | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) - | "inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc (Warnings.Misplaced_attribute txt) - | _ -> () - -let check_attribute_on_module (e : Typedtree.module_expr) - (({ txt; loc }, _) : t) = - match txt with - | "inline" -> ( - match e.mod_desc with - | Tmod_functor _ -> () - | _ -> Location.prerr_warning loc (Warnings.Misplaced_attribute txt)) - | "inlined" -> - (* Removed by the Texp_apply cases *) - Location.prerr_warning loc (Warnings.Misplaced_attribute txt) - | _ -> () diff --git a/jscomp/ml/translcore.ml b/jscomp/ml/translcore.ml deleted file mode 100644 index 9cf09f8..0000000 --- a/jscomp/ml/translcore.ml +++ /dev/null @@ -1,1362 +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. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the core language *) - -open Misc -open Asttypes -open Primitive -open Types -open Typedtree -open Typeopt -open Lambda - -type error = Unknown_builtin_primitive of string | Unreachable_reached - -exception Error of Location.t * error - -(* Forward declaration -- to be filled in by Translmod.transl_module *) -let transl_module = - ref - (fun _cc _rootpath _modl -> assert false - : module_coercion -> Path.t option -> module_expr -> lambda) - -(* Compile an exception/extension definition *) - -let transl_extension_constructor env path ext = - let name = - match path (*!Clflags.for_package*) with - | None -> Ident.name ext.ext_id - | Some p -> Path.name p - in - let loc = ext.ext_loc in - match ext.ext_kind with - | Text_decl _ -> Lprim (Pcreate_extension name, [], loc) - | Text_rebind (path, _lid) -> transl_extension_path ~loc env path - -(* Translation of primitives *) - -type specialized = { - gencomp : Lambda.primitive; - intcomp : Lambda.primitive; - boolcomp : Lambda.primitive; - floatcomp : Lambda.primitive; - stringcomp : Lambda.primitive; - bytescomp : Lambda.primitive; - int64comp : Lambda.primitive; - bigintcomp : Lambda.primitive; - simplify_constant_constructor : bool; -} - -let arity2 name : Lambda.primitive = - Lambda.Pccall (Primitive.simple ~name ~arity:2 ~alloc:true) - -let comparisons_table = - create_hashtable 11 - [ - ( "%equal", - { - gencomp = - Pccall (Primitive.simple ~name:"caml_equal" ~arity:2 ~alloc:true); - intcomp = Pintcomp Ceq; - boolcomp = - Pccall - (Primitive.simple ~name:"caml_bool_equal" ~arity:2 ~alloc:false); - floatcomp = Pfloatcomp Ceq; - stringcomp = - Pccall - (Primitive.simple ~name:"caml_string_equal" ~arity:2 ~alloc:false); - bytescomp = - Pccall - (Primitive.simple ~name:"caml_bytes_equal" ~arity:2 ~alloc:false); - int64comp = Pbintcomp (Pint64, Ceq); - bigintcomp = Pbigintcomp Ceq; - simplify_constant_constructor = true; - } ); - ( "%notequal", - { - gencomp = - Pccall (Primitive.simple ~name:"caml_notequal" ~arity:2 ~alloc:true); - intcomp = Pintcomp Cneq; - boolcomp = - Pccall - (Primitive.simple ~name:"caml_bool_notequal" ~arity:2 ~alloc:false); - floatcomp = Pfloatcomp Cneq; - stringcomp = - Pccall - (Primitive.simple ~name:"caml_string_notequal" ~arity:2 - ~alloc:false); - bytescomp = - Pccall - (Primitive.simple ~name:"caml_bytes_notequal" ~arity:2 - ~alloc:false); - int64comp = Pbintcomp (Pint64, Cneq); - bigintcomp = Pbigintcomp Cneq; - simplify_constant_constructor = true; - } ); - ( "%lessthan", - { - gencomp = - Pccall (Primitive.simple ~name:"caml_lessthan" ~arity:2 ~alloc:true); - intcomp = Pintcomp Clt; - boolcomp = - Pccall - (Primitive.simple ~name:"caml_bool_lessthan" ~arity:2 ~alloc:false); - floatcomp = Pfloatcomp Clt; - stringcomp = - Pccall - (Primitive.simple ~name:"caml_string_lessthan" ~arity:2 - ~alloc:false); - bytescomp = - Pccall - (Primitive.simple ~name:"caml_bytes_lessthan" ~arity:2 - ~alloc:false); - int64comp = Pbintcomp (Pint64, Clt); - bigintcomp = Pbigintcomp Clt; - simplify_constant_constructor = false; - } ); - ( "%greaterthan", - { - gencomp = - Pccall - (Primitive.simple ~name:"caml_greaterthan" ~arity:2 ~alloc:true); - intcomp = Pintcomp Cgt; - boolcomp = - Pccall - (Primitive.simple ~name:"caml_bool_greaterthan" ~arity:2 - ~alloc:false); - floatcomp = Pfloatcomp Cgt; - stringcomp = - Pccall - (Primitive.simple ~name:"caml_string_greaterthan" ~arity:2 - ~alloc:false); - bytescomp = - Pccall - (Primitive.simple ~name:"caml_bytes_greaterthan" ~arity:2 - ~alloc:false); - int64comp = Pbintcomp (Pint64, Cgt); - bigintcomp = Pbigintcomp Cgt; - simplify_constant_constructor = false; - } ); - ( "%lessequal", - { - gencomp = - Pccall - (Primitive.simple ~name:"caml_lessequal" ~arity:2 ~alloc:true); - intcomp = Pintcomp Cle; - boolcomp = - Pccall - (Primitive.simple ~name:"caml_bool_lessequal" ~arity:2 - ~alloc:false); - floatcomp = Pfloatcomp Cle; - stringcomp = - Pccall - (Primitive.simple ~name:"caml_string_lessequal" ~arity:2 - ~alloc:false); - bytescomp = - Pccall - (Primitive.simple ~name:"caml_bytes_lessequal" ~arity:2 - ~alloc:false); - int64comp = Pbintcomp (Pint64, Cle); - bigintcomp = Pbigintcomp Cle; - simplify_constant_constructor = false; - } ); - ( "%greaterequal", - { - gencomp = - Pccall - (Primitive.simple ~name:"caml_greaterequal" ~arity:2 ~alloc:true); - intcomp = Pintcomp Cge; - boolcomp = - Pccall - (Primitive.simple ~name:"caml_bool_greaterequal" ~arity:2 - ~alloc:false); - floatcomp = Pfloatcomp Cge; - stringcomp = - Pccall - (Primitive.simple ~name:"caml_string_greaterequal" ~arity:2 - ~alloc:false); - bytescomp = - Pccall - (Primitive.simple ~name:"caml_bytes_greaterequal" ~arity:2 - ~alloc:false); - int64comp = Pbintcomp (Pint64, Cge); - bigintcomp = Pbigintcomp Cge; - simplify_constant_constructor = false; - } ); - ( "%compare", - { - gencomp = - Pccall (Primitive.simple ~name:"caml_compare" ~arity:2 ~alloc:true); - (* Not unboxed since the comparison is done directly on tagged int *) - intcomp = - Pccall - (Primitive.simple ~name:"caml_int_compare" ~arity:2 ~alloc:false); - boolcomp = - Pccall - (Primitive.simple ~name:"caml_bool_compare" ~arity:2 ~alloc:false); - floatcomp = - Pccall - (Primitive.simple ~name:"caml_float_compare" ~arity:2 ~alloc:false); - stringcomp = - Pccall - (Primitive.simple ~name:"caml_string_compare" ~arity:2 - ~alloc:false); - bytescomp = - Pccall - (Primitive.simple ~name:"caml_bytes_compare" ~arity:2 ~alloc:false); - int64comp = - Pccall - (Primitive.simple ~name:"caml_int64_compare" ~arity:2 ~alloc:false); - bigintcomp = - Pccall - (Primitive.simple ~name:"caml_bigint_compare" ~arity:2 ~alloc:false); - simplify_constant_constructor = false; - } ); - ( "%bs_max", - { - gencomp = arity2 "caml_max"; - bytescomp = arity2 "caml_max"; - (* FIXME bytescomp*) - intcomp = arity2 "caml_int_max"; - boolcomp = arity2 "caml_bool_max"; - floatcomp = arity2 "caml_float_max"; - stringcomp = arity2 "caml_string_max"; - int64comp = arity2 "caml_int64_max"; - bigintcomp = arity2 "caml_bigint_max"; - simplify_constant_constructor = false; - } ); - ( "%bs_min", - { - gencomp = arity2 "caml_min"; - bytescomp = arity2 "caml_min"; - intcomp = arity2 "caml_int_min"; - boolcomp = arity2 "caml_bool_min"; - floatcomp = arity2 "caml_float_min"; - stringcomp = arity2 "caml_string_min"; - int64comp = arity2 "caml_int64_min"; - bigintcomp = arity2 "caml_bigint_min"; - simplify_constant_constructor = false; - } ); - ( "%bs_equal_null", - { - gencomp = arity2 "caml_equal_null"; - bytescomp = arity2 "caml_equal_null"; - (* FIXME*) - intcomp = arity2 "caml_int_equal_null"; - boolcomp = arity2 "caml_bool_equal_null"; - floatcomp = arity2 "caml_float_equal_null"; - stringcomp = arity2 "caml_string_equal_null"; - int64comp = arity2 "caml_int64_equal_null"; - bigintcomp = arity2 "caml_bigint_equal_null"; - simplify_constant_constructor = true; - } ); - ( "%bs_equal_undefined", - { - gencomp = arity2 "caml_equal_undefined"; - bytescomp = arity2 "caml_equal_undefined"; - (* FIXME*) - intcomp = arity2 "caml_int_equal_undefined"; - boolcomp = arity2 "caml_bool_equal_undefined"; - floatcomp = arity2 "caml_float_equal_undefined"; - stringcomp = arity2 "caml_string_equal_undefined"; - int64comp = arity2 "caml_int64_equal_undefined"; - bigintcomp = arity2 "caml_bigint_equal_undefined"; - simplify_constant_constructor = true; - } ); - ( "%bs_equal_nullable", - { - gencomp = arity2 "caml_equal_nullable"; - bytescomp = arity2 "caml_equal_nullable"; - (* FIXME *) - intcomp = arity2 "caml_int_equal_nullable"; - boolcomp = arity2 "caml_bool_equal_nullable"; - floatcomp = arity2 "caml_float_equal_nullable"; - stringcomp = arity2 "caml_string_equal_nullable"; - int64comp = arity2 "caml_int64_equal_nullable"; - bigintcomp = arity2 "caml_bigint_equal_nullable"; - simplify_constant_constructor = true; - } ); - ] - -let primitives_table = - create_hashtable 57 - [ - ("%identity", Pidentity); - ("%bytes_to_string", Pbytes_to_string); - ("%ignore", Pignore); - ("%revapply", Prevapply); - ("%apply", Pdirapply); - ("%loc_LOC", Ploc Loc_LOC); - ("%loc_FILE", Ploc Loc_FILE); - ("%loc_LINE", Ploc Loc_LINE); - ("%loc_POS", Ploc Loc_POS); - ("%loc_MODULE", Ploc Loc_MODULE); - (* BEGIN Triples for ref data type *) - ("%bs_ref_setfield0", Psetfield (0, Lambda.ref_field_set_info)); - ("%bs_ref_field0", Pfield (0, Lambda.ref_field_info)); - ("%makemutable", Pmakeblock Lambda.ref_tag_info); - ("%incr", Poffsetref 1); - ("%decr", Poffsetref (-1)); - (* Finish Triples for ref data type *) - ("%field0", Pfield (0, Fld_tuple)); - ("%field1", Pfield (1, Fld_tuple)); - ("%obj_field", Parrayrefu); - ("%obj_set_field", Parraysetu); - ("%obj_is_int", Pisint); - ("%raise", Praise Raise_regular); - ("%reraise", Praise Raise_reraise); - ("%raise_notrace", Praise Raise_notrace); - ("%sequand", Psequand); - ("%sequor", Psequor); - ("%boolnot", Pnot); - ("%big_endian", Pctconst Big_endian); - ("%backend_type", Pctconst Backend_type); - ("%word_size", Pctconst Word_size); - ("%int_size", Pctconst Int_size); - ("%max_wosize", Pctconst Max_wosize); - ("%ostype_unix", Pctconst Ostype_unix); - ("%ostype_win32", Pctconst Ostype_win32); - ("%ostype_cygwin", Pctconst Ostype_cygwin); - ("%negint", Pnegint); - ("%succint", Poffsetint 1); - ("%predint", Poffsetint (-1)); - ("%addint", Paddint); - ("%subint", Psubint); - ("%mulint", Pmulint); - ("%divint", Pdivint Safe); - ("%modint", Pmodint Safe); - ("%andint", Pandint); - ("%orint", Porint); - ("%xorint", Pxorint); - ("%lslint", Plslint); - ("%lsrint", Plsrint); - ("%asrint", Pasrint); - ("%andbigint", Pandbigint); - ("%orbigint", Porbigint); - ("%xorbigint", Pxorbigint); - ("%lslbigint", Plslbigint); - ("%asrbigint", Pasrbigint); - ("%eq", Pintcomp Ceq); - ("%noteq", Pintcomp Cneq); - ("%ltint", Pintcomp Clt); - ("%leint", Pintcomp Cle); - ("%gtint", Pintcomp Cgt); - ("%geint", Pintcomp Cge); - ("%intoffloat", Pintoffloat); - ("%floatofint", Pfloatofint); - ("%negfloat", Pnegfloat); - ("%absfloat", Pabsfloat); - ("%addfloat", Paddfloat); - ("%subfloat", Psubfloat); - ("%mulfloat", Pmulfloat); - ("%divfloat", Pdivfloat); - ("%eqfloat", Pfloatcomp Ceq); - ("%noteqfloat", Pfloatcomp Cneq); - ("%ltfloat", Pfloatcomp Clt); - ("%lefloat", Pfloatcomp Cle); - ("%gtfloat", Pfloatcomp Cgt); - ("%gefloat", Pfloatcomp Cge); - ("%negbigint", Pnegbigint); - ("%addbigint", Paddbigint); - ("%subbigint", Psubbigint); - ("%mulbigint", Pmulbigint); - ("%divbigint", Pdivbigint); - ("%powbigint", Ppowbigint); - ("%modbigint", Pmodbigint); - ("%eqbigint", Pbigintcomp Ceq); - ("%noteqbigint", Pbigintcomp Cneq); - ("%ltbigint", Pbigintcomp Clt); - ("%lebigint", Pbigintcomp Cle); - ("%gtbigint", Pbigintcomp Cgt); - ("%gebigint", Pbigintcomp Cge); - ("%string_length", Pstringlength); - ("%string_safe_get", Pstringrefs); - ("%string_unsafe_get", Pstringrefu); - ("%bytes_length", Pbyteslength); - ("%bytes_safe_get", Pbytesrefs); - ("%bytes_safe_set", Pbytessets); - ("%bytes_unsafe_get", Pbytesrefu); - ("%bytes_unsafe_set", Pbytessetu); - ("%array_length", Parraylength); - ("%array_safe_get", Parrayrefs); - ("%array_safe_set", Parraysets); - ("%array_unsafe_get", Parrayrefu); - ("%array_unsafe_set", Parraysetu); - ("%floatarray_length", Parraylength); - ("%floatarray_safe_get", Parrayrefs); - ("%floatarray_safe_set", Parraysets); - ("%floatarray_unsafe_get", Parrayrefu); - ("%floatarray_unsafe_set", Parraysetu); - ("%lazy_force", Plazyforce); - ("%int64_of_int", Pbintofint Pint64); - ("%int64_to_int", Pintofbint Pint64); - ("%int64_neg", Pnegbint Pint64); - ("%int64_add", Paddbint Pint64); - ("%int64_sub", Psubbint Pint64); - ("%int64_mul", Pmulbint Pint64); - ("%int64_div", Pdivbint { size = Pint64; is_safe = Safe }); - ("%int64_mod", Pmodbint { size = Pint64; is_safe = Safe }); - ("%int64_and", Pandbint Pint64); - ("%int64_or", Porbint Pint64); - ("%int64_xor", Pxorbint Pint64); - ("%int64_lsl", Plslbint Pint64); - ("%int64_lsr", Plsrbint Pint64); - ("%int64_asr", Pasrbint Pint64); - ("%bigint_of_int32", Pcvtbint (Pint32, Pbigint)); - ("%bigint_to_int32", Pcvtbint (Pbigint, Pint32)); - ("%int64_of_int32", Pcvtbint (Pint32, Pint64)); - ("%int64_to_int32", Pcvtbint (Pint64, Pint32)); - ("%int64_of_bigint", Pcvtbint (Pbigint, Pint64)); - ("%int64_to_bigint", Pcvtbint (Pint64, Pbigint)); - ("%opaque", Popaque); - ("%uncurried_apply", Puncurried_apply); - ] - -let find_primitive prim_name = Hashtbl.find primitives_table prim_name - -let specialize_comparison - ({ gencomp; intcomp; floatcomp; stringcomp; bytescomp; int64comp; bigintcomp; boolcomp } : - specialized) env ty = - match () with - | () - when is_base_type env ty Predef.path_int - || is_base_type env ty Predef.path_char - || maybe_pointer_type env ty = Immediate -> - intcomp - | () when is_base_type env ty Predef.path_float -> floatcomp - | () when is_base_type env ty Predef.path_string -> stringcomp - | () when is_base_type env ty Predef.path_bytes -> bytescomp - | () when is_base_type env ty Predef.path_int64 -> int64comp - | () when is_base_type env ty Predef.path_bigint -> bigintcomp - | () when is_base_type env ty Predef.path_bool -> boolcomp - | () -> gencomp - -(* Specialize a primitive from available type information, - raise Not_found if primitive is unknown *) - -let specialize_primitive p env ty (* ~has_constant_constructor *) = - try - let table = Hashtbl.find comparisons_table p.prim_name in - match is_function_type env ty with - | Some (lhs, _rhs) -> specialize_comparison table env lhs - | None -> table.gencomp - with Not_found -> find_primitive p.prim_name - -(* Eta-expand a primitive *) - -let transl_primitive loc p env ty = - let prim = - try specialize_primitive p env ty (* ~has_constant_constructor:false *) - with Not_found -> Pccall p - in - match prim with - | Plazyforce -> - let parm = Ident.create "prim" in - Lfunction - { - params = [ parm ]; - body = Matching.inline_lazy_force (Lvar parm) Location.none; - loc; - attr = default_stub_attribute; - } - | Ploc kind -> ( - let lam = lam_of_loc kind loc in - match p.prim_arity with - | 0 -> lam - | 1 -> - (* TODO: we should issue a warning ? *) - let param = Ident.create "prim" in - Lfunction - { - params = [ param ]; - attr = default_stub_attribute; - loc; - body = Lprim (Pmakeblock Blk_tuple, [ lam; Lvar param ], loc); - } - | _ -> assert false) - | _ -> - let rec make_params n total = - if n <= 0 then [] - else - Ident.create ("prim" ^ string_of_int (total - n)) - :: make_params (n - 1) total - in - let prim_arity = p.prim_arity in - if prim_arity = 0 then Lprim (prim, [], loc) - else - let params = - if prim_arity = 1 then [ Ident.create "prim" ] - else make_params prim_arity prim_arity - in - Lfunction - { - params; - attr = default_stub_attribute; - loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); - } - -let transl_primitive_application loc prim env ty args = - let prim_name = prim.prim_name in - try - match args with - | [ arg1; _ ] - when is_base_type env arg1.exp_type Predef.path_bool - && Hashtbl.mem comparisons_table prim_name -> - (Hashtbl.find comparisons_table prim_name).boolcomp - | _ -> - let has_constant_constructor = - match args with - | [ - _; - { - exp_desc = Texp_construct (_, { cstr_tag = Cstr_constant _ }, _); - }; - ] - | [ - { - exp_desc = Texp_construct (_, { cstr_tag = Cstr_constant _ }, _); - }; - _; - ] - | [ _; { exp_desc = Texp_variant (_, None) } ] - | [ { exp_desc = Texp_variant (_, None) }; _ ] -> - true - | _ -> false - in - if has_constant_constructor then - match Hashtbl.find_opt comparisons_table prim_name with - | Some table when table.simplify_constant_constructor -> table.intcomp - | Some _ | None -> specialize_primitive prim env ty - (* ~has_constant_constructor*) - else specialize_primitive prim env ty - with Not_found -> - if String.length prim_name > 0 && prim_name.[0] = '%' then - raise (Error (loc, Unknown_builtin_primitive prim_name)); - Pccall prim - -(* To propagate structured constants *) - -exception Not_constant - -let extract_constant = function - | Lconst sc -> sc - | _ -> raise_notrace Not_constant - -(* Push the default values under the functional abstractions *) -(* Also push bindings of module patterns, since this sound *) - -type binding = - | Bind_value of value_binding list - | Bind_module of Ident.t * string loc * module_expr - -let rec push_defaults loc bindings cases partial = - match cases with - | [ - { - c_lhs = pat; - c_guard = None; - c_rhs = - { exp_desc = Texp_function { arg_label; param; cases; partial } } as exp; - }; - ] -> - let cases = push_defaults exp.exp_loc bindings cases partial in - [ - { - c_lhs = pat; - c_guard = None; - c_rhs = - { - exp with - exp_desc = Texp_function { arg_label; param; cases; partial }; - }; - }; - ] - | [ - { - c_lhs = pat; - c_guard = None; - c_rhs = - { - exp_attributes = [ ({ txt = "#default" }, _) ]; - exp_desc = - Texp_let (Nonrecursive, binds, ({ exp_desc = Texp_function _ } as e2)); - }; - }; - ] -> - push_defaults loc - (Bind_value binds :: bindings) - [ { c_lhs = pat; c_guard = None; c_rhs = e2 } ] - partial - | [ - { - c_lhs = pat; - c_guard = None; - c_rhs = - { - exp_attributes = [ ({ txt = "#modulepat" }, _) ]; - exp_desc = - Texp_letmodule - (id, name, mexpr, ({ exp_desc = Texp_function _ } as e2)); - }; - }; - ] -> - push_defaults loc - (Bind_module (id, name, mexpr) :: bindings) - [ { c_lhs = pat; c_guard = None; c_rhs = e2 } ] - partial - | [ case ] -> - let exp = - List.fold_left - (fun exp binds -> - { - exp with - exp_desc = - (match binds with - | Bind_value binds -> Texp_let (Nonrecursive, binds, exp) - | Bind_module (id, name, mexpr) -> - Texp_letmodule (id, name, mexpr, exp)); - }) - case.c_rhs bindings - in - [ { case with c_rhs = exp } ] - | { c_lhs = pat; c_rhs = exp; c_guard = _ } :: _ when bindings <> [] -> - let param = Typecore.name_pattern "param" cases in - let name = Ident.name param in - let exp = - { - exp with - exp_loc = loc; - exp_desc = - Texp_match - ( { - exp with - exp_type = pat.pat_type; - exp_desc = - Texp_ident - ( Path.Pident param, - mknoloc (Longident.Lident name), - { - val_type = pat.pat_type; - val_kind = Val_reg; - val_attributes = []; - Types.val_loc = Location.none; - } ); - }, - cases, - [], - partial ); - } - in - push_defaults loc bindings - [ - { - c_lhs = { pat with pat_desc = Tpat_var (param, mknoloc name) }; - c_guard = None; - c_rhs = exp; - }; - ] - Total - | _ -> cases - - - -(* Assertions *) - -let assert_failed exp = - let fname, line, char = - Location.get_pos_info exp.exp_loc.Location.loc_start - in - let fname = Filename.basename fname in - Lprim - ( Praise Raise_regular, - [ - Lprim - ( Pmakeblock Blk_extension, - [ - transl_normal_path Predef.path_assert_failure; - Lconst - (Const_block - ( Blk_tuple, - [ - Const_base (Const_string (fname, None)); - Const_base (Const_int line); - Const_base (Const_int char); - ] )); - ], - exp.exp_loc ); - ], - exp.exp_loc ) - -let rec cut n l = - if n = 0 then ([], l) - else - match l with - | [] -> failwith "Translcore.cut" - | a :: l -> - let l1, l2 = cut (n - 1) l in - (a :: l1, l2) - -(* Translation of expressions *) - -let try_ids = Hashtbl.create 8 - -let has_async_attribute exp = exp.exp_attributes |> List.exists (fun ({txt}, _payload) -> txt = "res.async") - -let rec transl_exp e = - List.iter (Translattribute.check_attribute e) e.exp_attributes; - transl_exp0 e - -and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = - match e.exp_desc with - | Texp_ident (_, _, { val_kind = Val_prim p }) -> - transl_primitive e.exp_loc p e.exp_env e.exp_type - | Texp_ident (path, _, { val_kind = Val_reg }) -> - transl_value_path ~loc:e.exp_loc e.exp_env path - | Texp_constant cst -> Lconst (Const_base cst) - | Texp_let (rec_flag, pat_expr_list, body) -> - transl_let rec_flag pat_expr_list (transl_exp body) - | Texp_function { arg_label = _; param; cases; partial } -> - let async = has_async_attribute e in - let params, body, return_unit = - let pl = push_defaults e.exp_loc [] cases partial in - transl_function e.exp_loc partial param pl - in - let attr = - { - default_function_attribute with - inline = Translattribute.get_inline_attribute e.exp_attributes; - async; - return_unit; - } - in - let loc = e.exp_loc in - Lfunction { params; body; attr; loc } - | Texp_apply - ( ({ - exp_desc = Texp_ident (_, _, { val_kind = Val_prim p }); - exp_type = prim_type; - } as funct), - oargs ) - when List.length oargs >= p.prim_arity - && List.for_all (fun (_, arg) -> arg <> None) oargs -> ( - let args, args' = cut p.prim_arity oargs in - let wrap f = - if args' = [] then f - else - let inlined, _ = - Translattribute.get_and_remove_inlined_attribute funct - in - transl_apply ~inlined f args' e.exp_loc - in - let args = - List.map (function _, Some x -> x | _ -> assert false) args - in - let argl = transl_list args in - let prim = - transl_primitive_application e.exp_loc p e.exp_env prim_type args - in - match (prim, args) with - | Praise k, [ _ ] -> - let targ = List.hd argl in - let k = - match (k, targ) with - | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> - Raise_reraise - | _ -> k - in - wrap (Lprim (Praise k, [ targ ], e.exp_loc)) - | Ploc kind, [] -> lam_of_loc kind e.exp_loc - | Ploc kind, [ arg1 ] -> - let lam = lam_of_loc kind arg1.exp_loc in - Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) - | Ploc _, _ -> assert false - | _, _ -> ( - match (prim, argl) with - | Plazyforce, [ a ] -> wrap (Matching.inline_lazy_force a e.exp_loc) - | Plazyforce, _ -> assert false - | _ -> - wrap (Lprim (prim, argl, e.exp_loc)) - )) - | Texp_apply (funct, oargs) -> - let inlined, funct = - Translattribute.get_and_remove_inlined_attribute funct - in - let uncurried_partial_application = - (* In case of partial application foo(args, ...) when some args are missing, - get the arity *) - let uncurried_partial_app = Ext_list.exists e.exp_attributes (fun ({txt },_) -> txt = "res.partial") in - if uncurried_partial_app then - let arity_opt = Ast_uncurried.uncurried_type_get_arity_opt ~env:funct.exp_env funct.exp_type in - match arity_opt with - | Some arity -> - let real_args = List.filter (fun (_, x) -> Option.is_some x) oargs in - if arity > List.length real_args then - Some arity - else None - | None -> None - else - None in - transl_apply ~inlined ~uncurried_partial_application (transl_exp funct) oargs e.exp_loc - | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) -> - transl_match e arg pat_expr_list exn_pat_expr_list partial - | Texp_try (body, pat_expr_list) -> - let id = Typecore.name_pattern "exn" pat_expr_list in - Ltrywith - ( transl_exp body, - id, - Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list) ) - | Texp_tuple el -> ( - let ll = transl_list el in - try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) - | Texp_construct ({ txt = Lident "false" }, _, []) -> Lconst Const_false - | Texp_construct ({ txt = Lident "true" }, _, []) -> Lconst Const_true - | Texp_construct ({ txt = Lident "Function$"}, _, [expr]) -> - (* ReScript uncurried encoding *) - let loc = expr.exp_loc in - let lambda = transl_exp expr in - let arity = Ast_uncurried.uncurried_type_get_arity ~env:e.exp_env e.exp_type in - let arity_s = arity |> string_of_int in - let name = match (Ctype.expand_head expr.exp_env expr.exp_type).desc with - | Tarrow (Nolabel, t, _, _) -> ( - match (Ctype.expand_head expr.exp_env t).desc with - | Tconstr (Pident {name= "unit"}, [], _) -> "#fn_mk_unit" - | _ -> "#fn_mk" - ) - | _ -> "#fn_mk" in - let prim = - Primitive.make ~name ~alloc:true ~native_name:arity_s - ~native_repr_args:[ Same_as_ocaml_repr ] - ~native_repr_res:Same_as_ocaml_repr - in - Lprim - ( Pccall prim - (* could be replaced with Opaque in the future except arity 0*), - [ lambda ], - loc ) - | Texp_construct (lid, cstr, args) -> ( - let ll = transl_list args in - if cstr.cstr_inlined <> None then - match ll with [ x ] -> x | _ -> assert false - else - match cstr.cstr_tag with - | Cstr_constant n -> - Lconst - (Const_pointer - ( n, - match lid.txt with - | Longident.Ldot (Longident.Lident "*predef*", "None") - | Longident.Lident "None" - when Datarepr.constructor_has_optional_shape cstr -> - Pt_shape_none - | _ -> - if Datarepr.constructor_has_optional_shape cstr then - Pt_shape_none - else - Pt_constructor - { - name = cstr.cstr_name; - const = cstr.cstr_consts; - non_const = cstr.cstr_nonconsts; - attrs = cstr.cstr_attributes; - } )) - | Cstr_unboxed -> ( match ll with [ v ] -> v | _ -> assert false) - | Cstr_block n -> ( - let tag_info : Lambda.tag_info = - if Datarepr.constructor_has_optional_shape cstr then - match args with - | [ arg ] - when Typeopt.type_cannot_contain_undefined arg.exp_type - arg.exp_env -> - (* Format.fprintf Format.err_formatter "@[special boxingl@]@."; *) - Blk_some_not_nested - | _ -> Blk_some - else - Blk_constructor - { - name = cstr.cstr_name; - num_nonconst = cstr.cstr_nonconsts; - tag = n; - attrs = cstr.cstr_attributes; - } - in - try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) - | Cstr_extension (path, _) -> - Lprim - ( Pmakeblock Blk_extension, - transl_extension_path e.exp_env path :: ll, - e.exp_loc )) - | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path - | Texp_variant (l, arg) -> ( - let tag = Btype.hash_variant l in - match arg with - | None -> Lconst (Const_pointer (tag, Pt_variant { name = l })) - | Some arg -> ( - let lam = transl_exp arg in - let tag_info = Blk_poly_var l in - try - Lconst - (Const_block - (tag_info, [ Const_base (Const_int tag); extract_constant lam ])) - with Not_constant -> - Lprim - ( Pmakeblock tag_info, - [ Lconst (Const_base (Const_int tag)); lam ], - e.exp_loc ))) - | Texp_record { fields; representation; extended_expression } -> - transl_record e.exp_loc e.exp_env fields representation - extended_expression - | Texp_field (arg, _, lbl) -> ( - let targ = transl_exp arg in - match lbl.lbl_repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [ targ ], e.exp_loc) - | Record_inlined _ -> - Lprim - ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), - [ targ ], - e.exp_loc ) - | Record_unboxed _ -> targ - | Record_extension -> - Lprim - ( Pfield - (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), - [ targ ], - e.exp_loc )) - | Texp_setfield (arg, _, lbl, newval) -> - let access = - match lbl.lbl_repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) - | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) - | Record_unboxed _ -> assert false - | Record_extension -> - Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) - in - Lprim (access, [ transl_exp arg; transl_exp newval ], e.exp_loc) - | Texp_array expr_list -> - let ll = transl_list expr_list in - Lprim (Pmakearray Mutable, ll, e.exp_loc) - | Texp_ifthenelse (cond, ifso, Some ifnot) -> - Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) - | Texp_ifthenelse (cond, ifso, None) -> - Lifthenelse (transl_exp cond, transl_exp ifso, lambda_unit) - | Texp_sequence (expr1, expr2) -> - Lsequence (transl_exp expr1, transl_exp expr2) - | Texp_while (cond, body) -> Lwhile (transl_exp cond, transl_exp body) - | Texp_for (param, _, low, high, dir, body) -> - Lfor (param, transl_exp low, transl_exp high, dir, transl_exp body) - | Texp_send (expr, Tmeth_name nm, _) -> - let obj = transl_exp expr in - Lsend (nm, obj, e.exp_loc) - | Texp_new _ | Texp_instvar _ | Texp_setinstvar _ | Texp_override _ -> - assert false - | Texp_letmodule (id, _loc, modl, body) -> - let defining_expr = !transl_module Tcoerce_none None modl in - Llet (Strict, Pgenval, id, defining_expr, transl_exp body) - | Texp_letexception (cd, body) -> - Llet - ( Strict, - Pgenval, - cd.ext_id, - transl_extension_constructor e.exp_env None cd, - transl_exp body ) - | Texp_pack modl -> !transl_module Tcoerce_none None modl - | Texp_assert { exp_desc = Texp_construct (_, { cstr_name = "false" }, _) } -> - if !Clflags.no_assert_false then Lambda.lambda_assert_false - else assert_failed e - | Texp_assert cond -> - if !Clflags.noassert then lambda_unit - else Lifthenelse (transl_exp cond, lambda_unit, assert_failed e) - | Texp_lazy e -> - (* when e needs no computation (constants, identifiers, ...), we - optimize the translation just as Lazy.lazy_from_val would - do *) - Lprim (Pmakeblock Blk_lazy_general, [ transl_exp e ], e.exp_loc) - | Texp_object () -> assert false - | Texp_unreachable -> raise (Error (e.exp_loc, Unreachable_reached)) - -and transl_list expr_list = List.map transl_exp expr_list - -and transl_guard guard rhs = - let expr = transl_exp rhs in - match guard with - | None -> expr - | Some cond -> Lifthenelse (transl_exp cond, expr, staticfail) - -and transl_case { c_lhs; c_guard; c_rhs } = (c_lhs, transl_guard c_guard c_rhs) - -and transl_cases cases = - let cases = - Ext_list.filter cases (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) - in - List.map transl_case cases - -and transl_case_try { c_lhs; c_guard; c_rhs } = - match c_lhs.pat_desc with - | Tpat_var (id, _) | Tpat_alias (_, id, _) -> - Hashtbl.replace try_ids id (); - Misc.try_finally - (fun () -> (c_lhs, transl_guard c_guard c_rhs)) - (fun () -> Hashtbl.remove try_ids id) - | _ -> (c_lhs, transl_guard c_guard c_rhs) - -and transl_cases_try cases = - let cases = - Ext_list.filter cases (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) - in - List.map transl_case_try cases - -and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application=None) lam sargs loc = - let lapply funct args = - match funct with - (* Attention: This may not be what we need to change the application arity*) - | Lapply ap -> Lapply { ap with ap_args = ap.ap_args @ args; ap_loc = loc } - | lexp -> - Lapply - { ap_loc = loc; ap_func = lexp; ap_args = args; ap_inlined = inlined } - in - let rec build_apply lam args = function - | (None, optional) :: l -> - let defs = ref [] in - let protect name lam = - match lam with - | Lvar _ | Lconst _ -> lam - | _ -> - let id = Ident.create name in - defs := (id, lam) :: !defs; - Lvar id - in - let args, args' = - if List.for_all (fun (_, opt) -> opt) args then ([], args) - else (args, []) - in - let lam = - if args = [] then lam else lapply lam (List.rev_map fst args) - in - let handle = protect "func" lam - and l = - List.map (fun (arg, opt) -> (may_map (protect "arg") arg, opt)) l - and id_arg = Ident.create "param" in - let body = - match build_apply handle ((Lvar id_arg, optional) :: args') l with - | Lfunction { params = ids; body = lam; attr; loc } -> - Lfunction { params = id_arg :: ids; body = lam; attr; loc } - | lam -> - Lfunction - { - params = [ id_arg ]; - body = lam; - attr = default_stub_attribute; - loc; - } - in - List.fold_left - (fun body (id, lam) -> Llet (Strict, Pgenval, id, lam, body)) - body !defs - | (Some arg, optional) :: l -> build_apply lam ((arg, optional) :: args) l - | [] -> lapply lam (List.rev_map fst args) - in - match uncurried_partial_application with - | Some arity -> - let extra_arity = arity - List.length sargs in - let none_ids = ref [] in - let args = Ext_list.filter_map sargs (function - | _, Some e -> - Some (transl_exp e) - | _, None -> - let id_arg = Ident.create "none" in - none_ids := id_arg :: !none_ids; - Some (Lvar id_arg)) in - let extra_ids = ref [] in - extra_ids := Ident.create "extra" :: !extra_ids; - let extra_ids = Array.init extra_arity (fun _ -> Ident.create "extra") |> Array.to_list in - let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in - let ap_args = args @ extra_args in - let l0 = Lapply { ap_func = lam; ap_args; ap_inlined = inlined; ap_loc = loc } in - Lfunction - { - params = List.rev_append !none_ids extra_ids ; - body = l0; - attr = default_function_attribute; - loc; - } - | _ -> - (build_apply lam [] - (List.map - (fun (l, x) -> (may_map transl_exp x, Btype.is_optional l)) - sargs) - : Lambda.lambda) - -and transl_function loc partial param cases = - match cases with - | [ - { - c_lhs = pat; - c_guard = None; - c_rhs = - { - exp_desc = - Texp_function - { arg_label = _; param = param'; cases; partial = partial' }; - } as exp; - }; - ] - when Parmatch.inactive ~partial pat && not (exp |> has_async_attribute) -> - let params, body, return_unit = - transl_function exp.exp_loc partial' param' cases - in - ( param :: params, - Matching.for_function loc None (Lvar param) [ (pat, body) ] partial, - return_unit ) - | { c_rhs = { exp_env; exp_type }; _ } :: _ -> - ( [ param ], - Matching.for_function loc None (Lvar param) (transl_cases cases) partial, - is_base_type exp_env exp_type Predef.path_unit ) - | _ -> assert false - -and transl_let rec_flag pat_expr_list body = - match rec_flag with - | Nonrecursive -> - let rec transl = function - | [] -> body - | { vb_pat = pat; vb_expr = expr; vb_attributes = attr; vb_loc } :: rem - -> - let lam = transl_exp expr in - let lam = Translattribute.add_inline_attribute lam vb_loc attr in - Matching.for_let pat.pat_loc lam pat (transl rem) - in - transl pat_expr_list - | Recursive -> - let transl_case { vb_expr = expr; vb_attributes; vb_loc; vb_pat = pat } = - let id = - match pat.pat_desc with - | Tpat_var (id, _) -> id - | Tpat_alias ({ pat_desc = Tpat_any }, id, _) -> id - | _ -> assert false - (* Illegal_letrec_pat - Only variables are allowed as left-hand side of `let rec' - *) - in - let lam = transl_exp expr in - let lam = - Translattribute.add_inline_attribute lam vb_loc vb_attributes - in - (id, lam) - in - Lletrec (Ext_list.map pat_expr_list transl_case, body) - -and transl_record loc env fields repres opt_init_expr = - match (opt_init_expr, repres, fields) with - | None, Record_unboxed _, [| ({ lbl_name; lbl_loc }, Overridden (_, expr)) |] - -> - (* ReScript uncurried encoding *) - let loc = lbl_loc in - let lambda = transl_exp expr in - if lbl_name.[0] = 'I' then - let arity_s = String.sub lbl_name 1 (String.length lbl_name - 1) in - let prim = - Primitive.make ~name:"#fn_mk" ~alloc:true ~native_name:arity_s - ~native_repr_args:[ Same_as_ocaml_repr ] - ~native_repr_res:Same_as_ocaml_repr - in - Lprim - ( Pccall prim - (* could be replaced with Opaque in the future except arity 0*), - [ lambda ], - loc ) - else lambda - | _ -> ( - let size = Array.length fields in - (* Determine if there are "enough" fields (only relevant if this is a - functional-style record update *) - let no_init = match opt_init_expr with None -> true | _ -> false in - if - no_init || (size < 20 && (match repres with Record_optional_labels _ -> false | _ -> true)) - (* TODO: More strategies - 3 + 2 * List.length lbl_expr_list >= size (density) - *) - then - (* Allocate new record with given fields (and remaining fields - taken from init_expr if any *) - let init_id = Ident.create "init" in - let lv = - Array.mapi - (fun i (lbl, definition) -> - match definition with - | Kept _ -> - let access = - match repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Pfield (i, Lambda.fld_record lbl) - | Record_inlined _ -> - Pfield (i, Lambda.fld_record_inline lbl) - | Record_unboxed _ -> assert false - | Record_extension -> - Pfield - (i + 1, Lambda.fld_record_extension lbl) - in - Lprim (access, [ Lvar init_id ], loc) - | Overridden (_lid, expr) -> transl_exp expr) - fields - in - let ll = Array.to_list lv in - let mut = - if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields then - Mutable - else Immutable - in - let lam = - try - if mut = Mutable then raise Not_constant; - let cl = List.map extract_constant ll in - match repres with - | Record_float_unused -> assert false - | Record_regular -> - Lconst - (Const_block (Lambda.blk_record fields mut Record_regular, cl)) - | Record_optional_labels _ -> - Lconst - (Const_block (Lambda.blk_record fields mut Record_optional, cl)) - | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> - Lconst - (Const_block - ( Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs - mut, - cl )) - | Record_unboxed _ -> - Lconst (match cl with [ v ] -> v | _ -> assert false) - | Record_extension -> raise Not_constant - with Not_constant -> ( - match repres with - | Record_regular -> - Lprim - ( Pmakeblock (Lambda.blk_record fields mut Record_regular), - ll, - loc ) - | Record_optional_labels _ -> - Lprim - ( Pmakeblock (Lambda.blk_record fields mut Record_optional), - ll, - loc ) - | Record_float_unused -> assert false - | Record_inlined { tag; name; num_nonconsts; optional_labels; attrs } -> - Lprim - ( Pmakeblock - (Lambda.blk_record_inlined fields name num_nonconsts optional_labels ~tag ~attrs - mut), - ll, - loc ) - | Record_unboxed _ -> ( - match ll with [ v ] -> v | _ -> assert false) - | Record_extension -> - let path = - let label, _ = fields.(0) in - match label.lbl_res.desc with - | Tconstr (p, _, _) -> p - | _ -> assert false - in - let slot = transl_extension_path env path in - Lprim - ( Pmakeblock (Lambda.blk_record_ext fields mut), - slot :: ll, - loc )) - in - match opt_init_expr with - | None -> lam - | Some init_expr -> - Llet (Strict, Pgenval, init_id, transl_exp init_expr, lam) - else - (* Take a shallow copy of the init record, then mutate the fields - of the copy *) - let copy_id = Ident.create "newrecord" in - let update_field cont (lbl, definition) = - match definition with - | Kept _type -> cont - | Overridden (_lid, expr) -> - let upd = - match repres with - | Record_float_unused -> assert false - | Record_regular | Record_optional_labels _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_set lbl) - | Record_inlined _ -> - Psetfield (lbl.lbl_pos, Lambda.fld_record_inline_set lbl) - | Record_unboxed _ -> assert false - | Record_extension -> - Psetfield - (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) - in - Lsequence - (Lprim (upd, [ Lvar copy_id; transl_exp expr ], loc), cont) - in - match opt_init_expr with - | None -> assert false - | Some init_expr -> - Llet - ( Strict, - Pgenval, - copy_id, - Lprim (Pduprecord, [ transl_exp init_expr ], loc), - Array.fold_left update_field (Lvar copy_id) fields )) - -and transl_match e arg pat_expr_list exn_pat_expr_list partial = - let id = Typecore.name_pattern "exn" exn_pat_expr_list - and cases = transl_cases pat_expr_list - and exn_cases = transl_cases_try exn_pat_expr_list in - let static_catch body val_ids handler = - let static_exception_id = next_negative_raise_count () in - Lstaticcatch - ( Ltrywith - ( Lstaticraise (static_exception_id, body), - id, - Matching.for_trywith (Lvar id) exn_cases ), - (static_exception_id, val_ids), - handler ) - in - match (arg, exn_cases) with - | { exp_desc = Texp_tuple argl }, [] -> - Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial - | { exp_desc = Texp_tuple argl }, _ :: _ -> - let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in - let lvars = List.map (fun id -> Lvar id) val_ids in - static_catch (transl_list argl) val_ids - (Matching.for_multiple_match e.exp_loc lvars cases partial) - | arg, [] -> - Matching.for_function e.exp_loc None (transl_exp arg) cases partial - | arg, _ :: _ -> - let val_id = Typecore.name_pattern "val" pat_expr_list in - static_catch [ transl_exp arg ] [ val_id ] - (Matching.for_function e.exp_loc None (Lvar val_id) cases partial) - -open Format - -let report_error ppf = function - | Unknown_builtin_primitive prim_name -> - fprintf ppf "Unknown builtin primitive \"%s\"" prim_name - | Unreachable_reached -> fprintf ppf "Unreachable expression was reached" - -let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) - | _ -> None) diff --git a/jscomp/ml/translmod.ml b/jscomp/ml/translmod.ml deleted file mode 100644 index 8815209..0000000 --- a/jscomp/ml/translmod.ml +++ /dev/null @@ -1,535 +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. *) -(* *) -(**************************************************************************) - -(* Translation from typed abstract syntax to lambda terms, - for the module language *) - -open Typedtree - -type error = Conflicting_inline_attributes | Fragile_pattern_in_toplevel - -exception Error of Location.t * error - -(* Keep track of the root path (from the root of the namespace to the - currently compiled module expression). Useful for naming extensions. *) - -let global_path glob : Path.t option = Some (Pident glob) - -let is_top (rootpath : Path.t option) = - match rootpath with Some (Pident _) -> true | _ -> false - -let functor_path path param : Path.t option = - match path with None -> None | Some p -> Some (Papply (p, Pident param)) - -let field_path path field : Path.t option = - match path with - | None -> None - | Some p -> Some (Pdot (p, Ident.name field, Path.nopos)) - -(* Compile type extensions *) - -let transl_type_extension env rootpath (tyext : Typedtree.type_extension) body : - Lambda.lambda = - List.fold_right - (fun ext body -> - let lam = - Translcore.transl_extension_constructor env - (field_path rootpath ext.ext_id) - ext - in - Lambda.Llet (Strict, Pgenval, ext.ext_id, lam, body)) - tyext.tyext_constructors body - -(* Compile a coercion *) - -let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = - match restr with - | Tcoerce_none -> arg - | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> - Lambda.name_lambda strict arg (fun id -> - let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module { name }), [ Lvar id ], loc) - in - let lam = - Lambda.Lprim - ( Pmakeblock (Blk_module runtime_fields), - Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> - apply_coercion loc Alias cc - (Lprim - (Pfield (pos, Fld_module { name }), [ Lvar id ], loc))), - loc ) - in - wrap_id_pos_list loc id_pos_list get_field_name lam) - | Tcoerce_functor (cc_arg, cc_res) -> - let param = Ident.create "funarg" in - let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [ param ] [ carg ] cc_res - | Tcoerce_primitive { pc_loc; pc_desc; pc_env; pc_type } -> - Translcore.transl_primitive pc_loc pc_desc pc_env pc_type - | Tcoerce_alias (path, cc) -> - Lambda.name_lambda strict arg (fun _ -> - apply_coercion loc Alias cc (Lambda.transl_normal_path path)) - -and apply_coercion_result loc strict funct params args cc_res = - match cc_res with - | Tcoerce_functor (cc_arg, cc_res) -> - let param = Ident.create "funarg" in - let arg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict funct (param :: params) (arg :: args) - cc_res - | _ -> - Lambda.name_lambda strict funct (fun id -> - Lfunction - { - params = List.rev params; - attr = - { - Lambda.default_function_attribute with - is_a_functor = true; - stub = true; - }; - loc; - body = - apply_coercion loc Strict cc_res - (Lapply - { - ap_loc = loc; - ap_func = Lvar id; - ap_args = List.rev args; - ap_inlined = Default_inline; - }); - }) - -and wrap_id_pos_list loc id_pos_list get_field lam = - let fv = Lambda.free_variables lam in - (*Format.eprintf "%a@." Printlambda.lambda lam; - IdentSet.iter (fun id -> Format.eprintf "%a " Ident.print id) fv; - Format.eprintf "@.";*) - let lam, s = - List.fold_left - (fun (lam, s) (id', pos, c) -> - if Lambda.IdentSet.mem id' fv then - let id'' = Ident.create (Ident.name id') in - ( Lambda.Llet - ( Alias, - Pgenval, - id'', - apply_coercion loc Alias c (get_field (Ident.name id') pos), - lam ), - Ident.add id' (Lambda.Lvar id'') s ) - else (lam, s)) - (lam, Ident.empty) id_pos_list - in - if s == Ident.empty then lam else Lambda.subst_lambda s lam - -(* Compose two coercions - apply_coercion c1 (apply_coercion c2 e) behaves like - apply_coercion (compose_coercions c1 c2) e. *) - -let rec compose_coercions c1 c2 = - match (c1, c2) with - | Tcoerce_none, c2 -> c2 - | c1, Tcoerce_none -> c1 - | ( Tcoerce_structure (pc1, ids1, runtime_fields1), - Tcoerce_structure (pc2, ids2, _runtime_fields2) ) -> - let v2 = Array.of_list pc2 in - let ids1 = - List.map - (fun (id, pos1, c1) -> - let pos2, c2 = v2.(pos1) in - (id, pos2, compose_coercions c1 c2)) - ids1 - in - Tcoerce_structure - ( List.map - (function - | (_p1, Tcoerce_primitive _) as x -> - x (* (p1, Tcoerce_primitive p) *) - | p1, c1 -> - let p2, c2 = v2.(p1) in - (p2, compose_coercions c1 c2)) - pc1, - ids1 @ ids2, - runtime_fields1 ) - | Tcoerce_functor (arg1, res1), Tcoerce_functor (arg2, res2) -> - Tcoerce_functor (compose_coercions arg2 arg1, compose_coercions res1 res2) - | c1, Tcoerce_alias (path, c2) -> Tcoerce_alias (path, compose_coercions c1 c2) - | _, _ -> Misc.fatal_error "Translmod.compose_coercions" - -(* -let apply_coercion a b c = - Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b; - apply_coercion a b c - -let compose_coercions c1 c2 = - let c3 = compose_coercions c1 c2 in - let open Includemod in - Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@." - print_coercion c1 print_coercion c2 print_coercion c3; - c3 -*) - -(* Record the primitive declarations occurring in the module compiled *) - -let rec pure_module m : Lambda.let_kind = - match m.mod_desc with - | Tmod_ident _ -> Alias - | Tmod_constraint (m, _, _, _) -> pure_module m - | _ -> Strict - -(* Generate lambda-code for a reordered list of bindings *) - -(* Extract the list of "value" identifiers bound by a signature. - "Value" identifiers are identifiers for signature components that - correspond to a run-time value: values, extensions, modules, classes. - Note: manifest primitives do not correspond to a run-time value! *) - -let rec bound_value_identifiers : Types.signature_item list -> Ident.t list = - function - | [] -> [] - | Sig_value (id, { val_kind = Val_reg }) :: rem -> - id :: bound_value_identifiers rem - | Sig_typext (id, _, _) :: rem -> id :: bound_value_identifiers rem - | Sig_module (id, _, _) :: rem -> id :: bound_value_identifiers rem - | Sig_class _ :: _ -> assert false - | _ :: rem -> bound_value_identifiers rem - -(* Compile one or more functors, merging curried functors to produce - multi-argument functors. Any [@inline] attribute on a functor that is - merged must be consistent with any other [@inline] attribute(s) on the - functor(s) being merged with. Such an attribute will be placed on the - resulting merged functor. *) - -let merge_inline_attributes (attr1 : Lambda.inline_attribute) - (attr2 : Lambda.inline_attribute) loc = - match (attr1, attr2) with - | Lambda.Default_inline, _ -> attr2 - | _, Lambda.Default_inline -> attr1 - | _, _ -> - if attr1 = attr2 then attr1 - else raise (Error (loc, Conflicting_inline_attributes)) - -let merge_functors mexp coercion root_path = - let rec merge mexp coercion path acc inline_attribute = - let finished = (acc, mexp, path, coercion, inline_attribute) in - match mexp.mod_desc with - | Tmod_functor (param, _, _, body) -> - let inline_attribute' = - Translattribute.get_inline_attribute mexp.mod_attributes - in - let arg_coercion, res_coercion = - match coercion with - | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) - | Tcoerce_functor (arg_coercion, res_coercion) -> - (arg_coercion, res_coercion) - | _ -> Misc.fatal_error "Translmod.merge_functors: bad coercion" - in - let loc = mexp.mod_loc in - let path = functor_path path param in - let inline_attribute = - merge_inline_attributes inline_attribute inline_attribute' loc - in - merge body res_coercion path - ((param, loc, arg_coercion) :: acc) - inline_attribute - | _ -> finished - in - merge mexp coercion root_path [] Default_inline - -let export_identifiers : Ident.t list ref = ref [] - -let rec compile_functor mexp coercion root_path loc = - let functor_params_rev, body, body_path, res_coercion, inline_attribute = - merge_functors mexp coercion root_path - in - assert (functor_params_rev <> []); - (* cf. [transl_module] *) - let params, body = - List.fold_left - (fun (params, body) (param, loc, arg_coercion) -> - let param' = Ident.rename param in - let arg = apply_coercion loc Alias arg_coercion (Lvar param') in - let params = param' :: params in - let body = Lambda.Llet (Alias, Pgenval, param, arg, body) in - (params, body)) - ([], transl_module res_coercion body_path body) - functor_params_rev - in - Lambda.Lfunction - { - params; - attr = - { - inline = inline_attribute; - is_a_functor = true; - stub = false; - return_unit = false; - async = false; - oneUnitArg = false; - }; - loc; - body; - } - -(* Compile a module expression *) -and transl_module cc rootpath mexp = - List.iter (Translattribute.check_attribute_on_module mexp) mexp.mod_attributes; - let loc = mexp.mod_loc in - match mexp.mod_type with - | Mty_alias (Mta_absent, _) -> - apply_coercion loc Alias cc Lambda.lambda_module_alias - | _ -> ( - match mexp.mod_desc with - | Tmod_ident (path, _) -> - apply_coercion loc Strict cc - (Lambda.transl_module_path ~loc mexp.mod_env path) - | Tmod_structure str -> fst (transl_struct loc [] cc rootpath str) - | Tmod_functor _ -> compile_functor mexp cc rootpath loc - | Tmod_apply (funct, arg, ccarg) -> - let inlined_attribute, funct = - Translattribute.get_and_remove_inlined_attribute_on_module funct - in - apply_coercion loc Strict cc - (Lapply - { - ap_loc = loc; - ap_func = transl_module Tcoerce_none None funct; - ap_args = [ transl_module ccarg None arg ]; - ap_inlined = inlined_attribute; - }) - | Tmod_constraint (arg, _, _, ccarg) -> - transl_module (compose_coercions cc ccarg) rootpath arg - | Tmod_unpack (arg, _) -> - apply_coercion loc Strict cc (Translcore.transl_exp arg)) - -and transl_struct loc fields cc rootpath str = - transl_structure loc fields cc rootpath str.str_final_env str.str_items - -and transl_structure loc fields cc rootpath final_env = function - | [] -> ( - let is_top_root_path = is_top rootpath in - - match cc with - | Tcoerce_none -> - let block_fields = - List.fold_left - (fun acc id -> - if is_top_root_path then - export_identifiers := id :: !export_identifiers; - Lambda.Lvar id :: acc) - [] fields - in - ( Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then - Blk_module_export !export_identifiers - else - Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), - block_fields, - loc ), - List.length fields ) - | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> - (* Do not ignore id_pos_list ! *) - (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; - List.iter (fun l -> Format.eprintf "%a@ " Ident.print l) - fields; - Format.eprintf "@]@.";*) - assert (List.length runtime_fields = List.length pos_cc_list); - let v = Ext_array.reverse_of_list fields in - let get_field pos = Lambda.Lvar v.(pos) - and ids = - List.fold_right Lambda.IdentSet.add fields Lambda.IdentSet.empty - in - let get_field_name _name = get_field in - let result = - List.fold_right - (fun (pos, cc) code -> - match cc with - | Tcoerce_primitive p -> - if is_top rootpath then - export_identifiers := p.pc_id :: !export_identifiers; - Translcore.transl_primitive p.pc_loc p.pc_desc p.pc_env - p.pc_type - :: code - | _ -> - if is_top rootpath then - export_identifiers := v.(pos) :: !export_identifiers; - apply_coercion loc Strict cc (get_field pos) :: code) - pos_cc_list [] - in - let lam = - Lambda.Lprim - ( Pmakeblock - (if is_top_root_path then - Blk_module_export !export_identifiers - else Blk_module runtime_fields), - result, - loc ) - and id_pos_list = - Ext_list.filter id_pos_list (fun (id, _, _) -> - not (Lambda.IdentSet.mem id ids)) - in - ( wrap_id_pos_list loc id_pos_list get_field_name lam, - List.length pos_cc_list ) - | _ -> Misc.fatal_error "Translmod.transl_structure") - | item :: rem -> ( - match item.str_desc with - | Tstr_eval (expr, _) -> - let body, size = - transl_structure loc fields cc rootpath final_env rem - in - (Lsequence (Translcore.transl_exp expr, body), size) - | Tstr_value (rec_flag, pat_expr_list) -> - let ext_fields = rev_let_bound_idents pat_expr_list @ fields in - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - (* Recursve already excludes complex pattern bindings*) - if is_top rootpath && rec_flag = Nonrecursive then - Ext_list.iter pat_expr_list (fun { vb_pat } -> - match vb_pat.pat_desc with - | Tpat_var _ | Tpat_alias _ -> () - | _ -> - if not (Parmatch.irrefutable vb_pat) then - raise - (Error (vb_pat.pat_loc, Fragile_pattern_in_toplevel))); - (Translcore.transl_let rec_flag pat_expr_list body, size) - | Tstr_typext tyext -> - let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in - let body, size = - transl_structure loc - (List.rev_append ids fields) - cc rootpath final_env rem - in - (transl_type_extension item.str_env rootpath tyext body, size) - | Tstr_exception ext -> - let id = ext.ext_id in - let path = field_path rootpath id in - let body, size = - transl_structure loc (id :: fields) cc rootpath final_env rem - in - ( Llet - ( Strict, - Pgenval, - id, - Translcore.transl_extension_constructor item.str_env path ext, - body ), - size ) - | Tstr_module mb as s -> - let id = mb.mb_id in - let body, size = - transl_structure loc - (if Typemod.rescript_hide s then fields else id :: fields) - cc rootpath final_env rem - in - let module_body = - transl_module Tcoerce_none (field_path rootpath id) mb.mb_expr - in - let module_body = - Translattribute.add_inline_attribute module_body mb.mb_loc - mb.mb_attributes - in - (Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), size) - | Tstr_recmodule bindings -> - let ext_fields = - List.rev_append (List.map (fun mb -> mb.mb_id) bindings) fields - in - let body, size = - transl_structure loc ext_fields cc rootpath final_env rem - in - let lam = - Transl_recmodule.compile_recmodule - (fun id modl _loc -> - transl_module Tcoerce_none (field_path rootpath id) modl) - bindings body - in - (lam, size) - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create "include" in - let rec rebind_idents pos newfields = function - | [] -> transl_structure loc newfields cc rootpath final_env rem - | id :: ids -> - let body, size = - rebind_idents (pos + 1) (id :: newfields) ids - in - ( Llet - ( Alias, - Pgenval, - id, - Lprim - ( Pfield (pos, Fld_module { name = Ident.name id }), - [ Lvar mid ], - incl.incl_loc ), - body ), - size ) - in - let body, size = rebind_idents 0 fields ids in - ( Llet - ( pure_module modl, - Pgenval, - mid, - transl_module Tcoerce_none None modl, - body ), - size ) - | Tstr_class _ | Tstr_primitive _ | Tstr_type _ | Tstr_modtype _ - | Tstr_open _ | Tstr_class_type _ | Tstr_attribute _ -> - transl_structure loc fields cc rootpath final_env rem) - -(* Update forward declaration in Translcore *) -let _ = Translcore.transl_module := transl_module - -(* Introduce dependencies on modules referenced only by "external". *) - -(* Compile an implementation *) - -let transl_implementation module_name (str, cc) = - export_identifiers := []; - let module_id = Ident.create_persistent module_name in - let body, _ = transl_struct Location.none [] cc (global_path module_id) str in - (body, !export_identifiers) - -(* Build the list of value identifiers defined by a toplevel structure - (excluding primitive declarations). *) - -(* second level idents (module M = struct ... let id = ... end), - and all sub-levels idents *) -(* A variant of transl_structure used to compile toplevel structure definitions - for the native-code compiler. Store the defined values in the fields - of the global as soon as they are defined, in order to reduce register - pressure. Also rewrites the defining expressions so that they - refer to earlier fields of the structure through the fields of - the global, not by their names. - "map" is a table from defined idents to (pos in global block, coercion). - "prim" is a list of (pos in global block, primitive declaration). *) - -(* Compile an implementation using transl_store_structure - (for the native-code compiler). *) - -(* Compile a toplevel phrase *) - -(* Error report *) - -let report_error ppf = function - | Conflicting_inline_attributes -> - Format.fprintf ppf "@[Conflicting ``inline'' attributes@]" - | Fragile_pattern_in_toplevel -> - Format.fprintf ppf "@[Such fragile pattern not allowed in the toplevel@]" - -let () = - Location.register_error_of_exn (function - | Error (loc, err) -> Some (Location.error_of_printer loc report_error err) - | _ -> None) diff --git a/jscomp/ml/typeclass.ml b/jscomp/ml/typeclass.ml deleted file mode 100644 index 00ea7df..0000000 --- a/jscomp/ml/typeclass.ml +++ /dev/null @@ -1,1105 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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. *) -(* *) -(**************************************************************************) - -open Parsetree -open Asttypes -open Types -open Typetexp -open Format - -type 'a class_info = { - cls_id : Ident.t; - cls_id_loc : string loc; - cls_decl : class_declaration; - cls_ty_id : Ident.t; - cls_ty_decl : class_type_declaration; - cls_obj_id : Ident.t; - cls_obj_abbr : type_declaration; - cls_typesharp_id : Ident.t; - cls_abbr : type_declaration; - cls_arity : int; - cls_pub_methods : string list; - cls_info : 'a; -} - -type class_type_info = { - clsty_ty_id : Ident.t; - clsty_id_loc : string loc; - clsty_ty_decl : class_type_declaration; - clsty_obj_id : Ident.t; - clsty_obj_abbr : type_declaration; - clsty_typesharp_id : Ident.t; - clsty_abbr : type_declaration; - clsty_info : Typedtree.class_type_declaration; -} - -type error = - Unconsistent_constraint of (type_expr * type_expr) list - | Field_type_mismatch of string * string * (type_expr * type_expr) list - | Structure_expected of class_type - | Pattern_type_clash of type_expr - | Repeated_parameter - | Unbound_class_type_2 of Longident.t - | Abbrev_type_clash of type_expr * type_expr * type_expr - | Constructor_type_mismatch of string * (type_expr * type_expr) list - | Virtual_class of bool * bool * string list * string list - | Parameter_arity_mismatch of Longident.t * int * int - | Parameter_mismatch of (type_expr * type_expr) list - | Bad_parameters of Ident.t * type_expr * type_expr - - | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure - | Non_generalizable_class of Ident.t * Types.class_declaration - | Cannot_coerce_self of type_expr - | Non_collapsable_conjunction of - Ident.t * Types.class_declaration * (type_expr * type_expr) list - | No_overriding of string * string - - -exception Error of Location.t * Env.t * error -exception Error_forward of Location.error - -open Typedtree - -let ctyp desc typ env loc = - { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; - ctyp_attributes = [] } - - (**********************) - (* Useful constants *) - (**********************) - - -(* - Self type have a dummy private method, thus preventing it to become - closed. -*) -let dummy_method = Btype.dummy_method - -(* - Path associated to the temporary class type of a class being typed - (its constructor is not available). -*) -let unbound_class = Path.Pident (Ident.create "*undef*") - - - (************************************) - (* Some operations on class types *) - (************************************) - - -(* Fully expand the head of a class type *) -let rec scrape_class_type = - function - Cty_constr (_, _, cty) -> scrape_class_type cty - | cty -> cty - -(* Generalize a class type *) -let rec generalize_class_type gen = - function - Cty_constr (_, params, cty) -> - List.iter gen params; - generalize_class_type gen cty - | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} -> - gen sty; - Vars.iter (fun _ (_, _, ty) -> gen ty) vars; - List.iter (fun (_,tl) -> List.iter gen tl) inher - | Cty_arrow (_, ty, cty) -> - gen ty; - generalize_class_type gen cty - -let generalize_class_type vars = - let gen = if vars then Ctype.generalize else Ctype.generalize_structure in - generalize_class_type gen - -(* Return the virtual methods of a class type *) -let virtual_methods sign = - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self) - in - List.fold_left - (fun virt (lab, _, _) -> - if lab = dummy_method then virt else - if Concr.mem lab sign.csig_concr then virt else - lab::virt) - [] fields - -(* Return the constructor type associated to a class type *) -let rec constructor_type constr cty = - match cty with - Cty_constr (_, _, cty) -> - constructor_type constr cty - | Cty_signature _ -> - constr - | Cty_arrow (l, ty, cty) -> - Ctype.newty (Tarrow (l, ty, constructor_type constr cty, Cok)) - -let rec class_body cty = - match cty with - Cty_constr _ -> - cty (* Only class bodies can be abbreviated *) - | Cty_signature _ -> - cty - | Cty_arrow (_, _, cty) -> - class_body cty - - -(* Check that all type variables are generalizable *) -(* Use Env.empty to prevent expansion of recursively defined object types; - cf. typing-poly/poly.ml *) -let rec closed_class_type = - function - Cty_constr (_, params, _) -> - List.for_all (Ctype.closed_schema Env.empty) params - | Cty_signature sign -> - Ctype.closed_schema Env.empty sign.csig_self - && - Vars.fold (fun _ (_, _, ty) cc -> Ctype.closed_schema Env.empty ty && cc) - sign.csig_vars - true - | Cty_arrow (_, ty, cty) -> - Ctype.closed_schema Env.empty ty - && - closed_class_type cty - -let closed_class cty = - List.for_all (Ctype.closed_schema Env.empty) cty.cty_params - && - closed_class_type cty.cty_type - -let rec limited_generalize rv = - function - Cty_constr (_path, params, cty) -> - List.iter (Ctype.limited_generalize rv) params; - limited_generalize rv cty - | Cty_signature sign -> - Ctype.limited_generalize rv sign.csig_self; - Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) - sign.csig_vars; - List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) - sign.csig_inher - | Cty_arrow (_, ty, cty) -> - Ctype.limited_generalize rv ty; - limited_generalize rv cty - - - - (***********************************) - (* Primitives for typing classes *) - (***********************************) - - - -(* Enter an instance variable in the environment *) -let concr_vals vars = - Vars.fold - (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s) - vars Concr.empty - -let inheritance self_type env ovf concr_meths warn_vals loc parent = - match scrape_class_type parent with - Cty_signature cl_sig -> - - (* Methods *) - begin try - Ctype.unify env self_type cl_sig.csig_self - with Ctype.Unify trace -> - match trace with - _::_::_::({desc = Tfield(n, _, _, _)}, _)::rem -> - raise(Error(loc, env, Field_type_mismatch ("method", n, rem))) - | _ -> - assert false - end; - - (* Overriding *) - let over_meths = Concr.inter cl_sig.csig_concr concr_meths in - let concr_vals = concr_vals cl_sig.csig_vars in - let over_vals = Concr.inter concr_vals warn_vals in - begin match ovf with - Some Fresh -> - let cname = - match parent with - Cty_constr (p, _, _) -> Path.name p - | _ -> "inherited" - in - if not (Concr.is_empty over_meths) then - Location.prerr_warning loc - (Warnings.Method_override (cname :: Concr.elements over_meths)); - if not (Concr.is_empty over_vals) then - Location.prerr_warning loc - (Warnings.Instance_variable_override - (cname :: Concr.elements over_vals)); - | Some Override - when Concr.is_empty over_meths && Concr.is_empty over_vals -> - raise (Error(loc, env, No_overriding ("",""))) - | _ -> () - end; - - let concr_meths = Concr.union cl_sig.csig_concr concr_meths - and warn_vals = Concr.union concr_vals warn_vals in - - (cl_sig, concr_meths, warn_vals) - - | _ -> - raise(Error(loc, env, Structure_expected parent)) - - -let delayed_meth_specs = ref [] - -let declare_method val_env meths self_type lab priv sty loc = - let (_, ty') = - Ctype.filter_self_method val_env lab priv meths self_type - in - let unif ty = - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))) - in - let sty = Ast_helper.Typ.force_poly sty in - match sty.ptyp_desc, priv with - Ptyp_poly ([],sty'), Public -> -(* TODO: we moved the [transl_simple_type_univars] outside of the lazy, -so that we can get an immediate value. Is that correct ? Ask Jacques. *) - let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in - delayed_meth_specs := - Warnings.mk_lazy (fun () -> - let cty = transl_simple_type_univars val_env sty' in - let ty = cty.ctyp_type in - unif ty; - returned_cty.ctyp_desc <- Ttyp_poly ([], cty); - returned_cty.ctyp_type <- ty; - ) :: - !delayed_meth_specs; - returned_cty - | _ -> - let cty = transl_simple_type val_env false sty in - let ty = cty.ctyp_type in - unif ty; - cty - -let type_constraint val_env sty sty' loc = - let cty = transl_simple_type val_env false sty in - let ty = cty.ctyp_type in - let cty' = transl_simple_type val_env false sty' in - let ty' = cty'.ctyp_type in - begin - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, val_env, Unconsistent_constraint trace)); - end; - (cty, cty') - - -(*******************************) - -let add_val lab (mut, virt, ty) val_sig = - let virt = - try - let (_mut', virt', _ty') = Vars.find lab val_sig in - if virt' = Concrete then virt' else virt - with Not_found -> virt - in - Vars.add lab (mut, virt, ty) val_sig - -let rec class_type_field env self_type meths arg ctf = - Builtin_attributes.warning_scope ctf.pctf_attributes - (fun () -> class_type_field_aux env self_type meths arg ctf) - -and class_type_field_aux env self_type meths - (fields, val_sig, concr_meths, inher) ctf = - - let loc = ctf.pctf_loc in - let mkctf desc = - { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } - in - match ctf.pctf_desc with - Pctf_inherit sparent -> - let parent = class_type env sparent in - let inher = - match parent.cltyp_type with - Cty_constr (p, tl, _) -> (p, tl) :: inher - | _ -> inher - in - let (cl_sig, concr_meths, _) = - inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc - parent.cltyp_type - in - let val_sig = - Vars.fold add_val cl_sig.csig_vars val_sig in - (mkctf (Tctf_inherit parent) :: fields, - val_sig, concr_meths, inher) - - | Pctf_val ({txt=lab}, mut, virt, sty) -> - let cty = transl_simple_type env false sty in - let ty = cty.ctyp_type in - (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields, - add_val lab (mut, virt, ty) val_sig, concr_meths, inher) - - | Pctf_method ({txt=lab}, priv, virt, sty) -> - let cty = - declare_method env meths self_type lab priv sty ctf.pctf_loc in - let concr_meths = - match virt with - | Concrete -> Concr.add lab concr_meths - | Virtual -> concr_meths - in - (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields, - val_sig, concr_meths, inher) - - | Pctf_constraint (sty, sty') -> - let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in - (mkctf (Tctf_constraint (cty, cty')) :: fields, - val_sig, concr_meths, inher) - - | Pctf_attribute x -> - Builtin_attributes.warning_attribute x; - (mkctf (Tctf_attribute x) :: fields, - val_sig, concr_meths, inher) - - | Pctf_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - -and class_signature env {pcsig_self=sty; pcsig_fields=sign} = - let meths = ref Meths.empty in - let self_cty = transl_simple_type env false sty in - let self_cty = { self_cty with - ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in - let self_type = self_cty.ctyp_type in - - (* Check that the binder is a correct type, and introduce a dummy - method preventing self type from being closed. *) - let dummy_obj = Ctype.newvar () in - Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj) - (Ctype.newty (Ttuple [])); - begin try - Ctype.unify env self_type dummy_obj - with Ctype.Unify _ -> - raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) - end; - - (* Class type fields *) - let (rev_fields, val_sig, concr_meths, inher) = - Builtin_attributes.warning_scope [] - (fun () -> - List.fold_left (class_type_field env self_type meths) - ([], Vars.empty, Concr.empty, []) - sign - ) - in - let cty = {csig_self = self_type; - csig_vars = val_sig; - csig_concr = concr_meths; - csig_inher = inher} - in - { csig_self = self_cty; - csig_fields = List.rev rev_fields; - csig_type = cty; - } - -and class_type env scty = - Builtin_attributes.warning_scope scty.pcty_attributes - (fun () -> class_type_aux env scty) - -and class_type_aux env scty = - let cltyp desc typ = - { - cltyp_desc = desc; - cltyp_type = typ; - cltyp_loc = scty.pcty_loc; - cltyp_env = env; - cltyp_attributes = scty.pcty_attributes; - } - in - match scty.pcty_desc with - Pcty_constr (lid, styl) -> - let (path, decl) = Typetexp.find_class_type env scty.pcty_loc lid.txt in - if Path.same decl.clty_path unbound_class then - raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); - let (params, clty) = - Ctype.instance_class decl.clty_params decl.clty_type - in - if List.length params <> List.length styl then - raise(Error(scty.pcty_loc, env, - Parameter_arity_mismatch (lid.txt, List.length params, - List.length styl))); - let ctys = List.map2 - (fun sty ty -> - let cty' = transl_simple_type env false sty in - let ty' = cty'.ctyp_type in - begin - try Ctype.unify env ty' ty with Ctype.Unify trace -> - raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace)) - end; - cty' - ) styl params - in - let typ = Cty_constr (path, params, clty) in - cltyp (Tcty_constr ( path, lid , ctys)) typ - - | Pcty_signature pcsig -> - let clsig = class_signature env pcsig in - let typ = Cty_signature clsig.csig_type in - cltyp (Tcty_signature clsig) typ - - | Pcty_arrow (l, sty, scty) -> - let cty = transl_simple_type env false sty in - let ty = cty.ctyp_type in - let ty = - if Btype.is_optional l - then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil)) - else ty in - let clty = class_type env scty in - let typ = Cty_arrow (l, ty, clty.cltyp_type) in - cltyp (Tcty_arrow (l, cty, clty)) typ - - | Pcty_open (ovf, lid, e) -> - let (path, newenv) = !Typecore.type_open ovf env scty.pcty_loc lid in - let clty = class_type newenv e in - cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type - - | Pcty_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - -let class_type env scty = - delayed_meth_specs := []; - let cty = class_type env scty in - List.iter Lazy.force (List.rev !delayed_meth_specs); - delayed_meth_specs := []; - cty - -(*******************************) - - -(*******************************) - -(* Approximate the type of the constructor to allow recursive use *) -(* of optional parameters *) - -let var_option = Predef.type_option (Btype.newgenvar ()) - - -let rec approx_description ct = - match ct.pcty_desc with - Pcty_arrow (l, _, ct) -> - let arg = - if Btype.is_optional l then Ctype.instance_def var_option - else Ctype.newvar () in - Ctype.newty (Tarrow (l, arg, approx_description ct, Cok)) - | _ -> Ctype.newvar () - -(*******************************) - -let temp_abbrev loc env id arity = - let params = ref [] in - for _i = 1 to arity do - params := Ctype.newvar () :: !params - done; - let ty = Ctype.newobj (Ctype.newvar ()) in - let env = - Env.add_type ~check:true id - {type_params = !params; - type_arity = arity; - type_kind = Type_abstract; - type_private = Public; - type_manifest = Some ty; - type_variance = Misc.replicate_list Variance.full arity; - type_newtype_level = None; - type_loc = loc; - type_attributes = []; (* or keep attrs from the class decl? *) - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - env - in - (!params, ty, env) - -let initial_env approx - (res, env) (cl, id, ty_id, obj_id, cl_id) = - (* Temporary abbreviations *) - let arity = List.length cl.pci_params in - let (obj_params, obj_ty, env) = temp_abbrev cl.pci_loc env obj_id arity in - let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity in - - (* Temporary type for the class constructor *) - let constr_type = approx cl.pci_expr in - let dummy_cty = - Cty_signature - { csig_self = Ctype.newvar (); - csig_vars = Vars.empty; - csig_concr = Concr.empty; - csig_inher = [] } - in - let dummy_class = - {Types.cty_params = []; (* Dummy value *) - cty_variance = []; - cty_type = dummy_cty; (* Dummy value *) - cty_path = unbound_class; - cty_new = - begin match cl.pci_virt with - | Virtual -> None - | Concrete -> Some constr_type - end; - cty_loc = Location.none; - cty_attributes = []; - } - in - let env = - Env.add_cltype ty_id - {clty_params = []; (* Dummy value *) - clty_variance = []; - clty_type = dummy_cty; (* Dummy value *) - clty_path = unbound_class; - clty_loc = Location.none; - clty_attributes = []; - } env - in - ((cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class)::res, - env) - -let class_infos kind - (cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class) - (res, env) = - - reset_type_variables (); - Ctype.begin_class_def (); - - (* Introduce class parameters *) - let ci_params = - let make_param (sty, v) = - try - (transl_type_param env sty, v) - with Already_bound -> - raise(Error(sty.ptyp_loc, env, Repeated_parameter)) - in - List.map make_param cl.pci_params - in - let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in - - (* Allow self coercions (only for class declarations) *) - let coercion_locs = ref [] in - - (* Type the class expression *) - let (expr, typ) = - try - Typecore.self_coercion := - (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion; - let res = kind env cl.pci_expr in - Typecore.self_coercion := List.tl !Typecore.self_coercion; - res - with exn -> - Typecore.self_coercion := []; raise exn - in - - Ctype.end_def (); - - let sty = Ctype.self_type typ in - - (* First generalize the type of the dummy method (cf PR#6123) *) - let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in - List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty) - fields; - (* Generalize the row variable *) - let rv = Ctype.row_variable sty in - List.iter (Ctype.limited_generalize rv) params; - limited_generalize rv typ; - - (* Check the abbreviation for the object type *) - let (obj_params', obj_type) = Ctype.instance_class params typ in - let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in - begin - let ty = Ctype.self_type obj_type in - Ctype.hide_private_methods ty; - Ctype.close_object ty; - begin try - List.iter2 (Ctype.unify env) obj_params obj_params' - with Ctype.Unify _ -> - raise(Error(cl.pci_loc, env, - Bad_parameters (obj_id, constr, - Ctype.newconstr (Path.Pident obj_id) - obj_params'))) - end; - begin try - Ctype.unify env ty constr - with Ctype.Unify _ -> - raise(Error(cl.pci_loc, env, - Abbrev_type_clash (constr, ty, Ctype.expand_head env constr))) - end - end; - - (* Check the other temporary abbreviation (#-type) *) - begin - let (cl_params', cl_type) = Ctype.instance_class params typ in - let ty = Ctype.self_type cl_type in - Ctype.hide_private_methods ty; - Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty; - begin try - List.iter2 (Ctype.unify env) cl_params cl_params' - with Ctype.Unify _ -> - raise(Error(cl.pci_loc, env, - Bad_parameters (cl_id, - Ctype.newconstr (Path.Pident cl_id) - cl_params, - Ctype.newconstr (Path.Pident cl_id) - cl_params'))) - end; - begin try - Ctype.unify env ty cl_ty - with Ctype.Unify _ -> - let constr = Ctype.newconstr (Path.Pident cl_id) params in - raise(Error(cl.pci_loc, env, Abbrev_type_clash (constr, ty, cl_ty))) - end - end; - - (* Type of the class constructor *) - begin try - Ctype.unify env - (constructor_type constr obj_type) - (Ctype.instance env constr_type) - with Ctype.Unify trace -> - raise(Error(cl.pci_loc, env, - Constructor_type_mismatch (cl.pci_name.txt, trace))) - end; - - (* Class and class type temporary definitions *) - let cty_variance = List.map (fun _ -> Variance.full) params in - let cltydef = - {clty_params = params; clty_type = class_body typ; - clty_variance = cty_variance; - clty_path = Path.Pident obj_id; - clty_loc = cl.pci_loc; - clty_attributes = cl.pci_attributes; - } - in - dummy_class.cty_type <- typ; - let env = - Env.add_cltype ty_id cltydef ( - env) - in - - if cl.pci_virt = Concrete then begin - let sign = Ctype.signature_of_class_type typ in - let mets = virtual_methods sign in - let vals = - Vars.fold - (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l) - sign.csig_vars [] in - if mets <> [] || vals <> [] then - raise(Error(cl.pci_loc, env, Virtual_class(false, false, mets, - vals))); - end; - - (* Misc. *) - let arity = Ctype.class_type_arity typ in - let pub_meths = - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty)) - in - List.map (function (lab, _, _) -> lab) fields - in - - (* Final definitions *) - let (params', typ') = Ctype.instance_class params typ in - let cltydef = - {clty_params = params'; clty_type = class_body typ'; - clty_variance = cty_variance; - clty_path = Path.Pident obj_id; - clty_loc = cl.pci_loc; - clty_attributes = cl.pci_attributes; - } - and clty = - {cty_params = params'; cty_type = typ'; - cty_variance = cty_variance; - cty_path = Path.Pident obj_id; - cty_new = - begin match cl.pci_virt with - | Virtual -> None - | Concrete -> Some (Ctype.instance env constr_type) - end; - cty_loc = cl.pci_loc; - cty_attributes = cl.pci_attributes; - } - in - let obj_abbr = - {type_params = obj_params; - type_arity = List.length obj_params; - type_kind = Type_abstract; - type_private = Public; - type_manifest = Some obj_ty; - type_variance = List.map (fun _ -> Variance.full) obj_params; - type_newtype_level = None; - type_loc = cl.pci_loc; - type_attributes = []; (* or keep attrs from cl? *) - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - in - let (cl_params, cl_ty) = - Ctype.instance_parameterized_type params (Ctype.self_type typ) - in - Ctype.hide_private_methods cl_ty; - Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; - let cl_abbr = - {type_params = cl_params; - type_arity = List.length cl_params; - type_kind = Type_abstract; - type_private = Public; - type_manifest = Some cl_ty; - type_variance = List.map (fun _ -> Variance.full) cl_params; - type_newtype_level = None; - type_loc = cl.pci_loc; - type_attributes = []; (* or keep attrs from cl? *) - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - in - ((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, - arity, pub_meths, List.rev !coercion_locs, expr) :: res, - env) - -let final_decl env - (cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params, - arity, pub_meths, coe, expr) = - - begin try Ctype.collapse_conj_params env clty.cty_params - with Ctype.Unify trace -> - raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace))) - end; - - List.iter Ctype.generalize clty.cty_params; - generalize_class_type true clty.cty_type; - Misc.may Ctype.generalize clty.cty_new; - List.iter Ctype.generalize obj_abbr.type_params; - Misc.may Ctype.generalize obj_abbr.type_manifest; - List.iter Ctype.generalize cl_abbr.type_params; - Misc.may Ctype.generalize cl_abbr.type_manifest; - - if not (closed_class clty) then - raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty))); - - begin match - Ctype.closed_class clty.cty_params - (Ctype.signature_of_class_type clty.cty_type) - with - None -> () - | Some reason -> - let printer = - function ppf -> Printtyp.cltype_declaration id ppf cltydef - in - raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) - end; - - (id, cl.pci_name, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, - { ci_loc = cl.pci_loc; - ci_virt = cl.pci_virt; - ci_params = ci_params; -(* TODO : check that we have the correct use of identifiers *) - ci_id_name = cl.pci_name; - ci_id_class = id; - ci_id_class_type = ty_id; - ci_id_object = obj_id; - ci_id_typehash = cl_id; - ci_expr = expr; - ci_decl = clty; - ci_type_decl = cltydef; - ci_attributes = cl.pci_attributes; - }) -(* (cl.pci_variance, cl.pci_loc)) *) - -let class_infos kind - (cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class) - (res, env) = - Builtin_attributes.warning_scope cl.pci_attributes - (fun () -> - class_infos kind - (cl, id, ty_id, - obj_id, obj_params, obj_ty, - cl_id, cl_params, cl_ty, - constr_type, dummy_class) - (res, env) - ) - -let extract_type_decls - (_id, _id_loc, clty, _ty_id, cltydef, obj_id, obj_abbr, _cl_id, cl_abbr, - _arity, _pub_meths, _coe, _expr, required) decls = - (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls - -let merge_type_decls - (id, id_loc, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr, - arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) = - (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coe, expr, req) - -let final_env env - (_id, _id_loc, _clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - _arity, _pub_meths, _coe, _expr, _req) = - (* Add definitions after cleaning them *) - Env.add_type ~check:true obj_id - (Subst.type_declaration Subst.identity obj_abbr) ( - Env.add_type ~check:true cl_id - (Subst.type_declaration Subst.identity cl_abbr) ( - Env.add_cltype ty_id (Subst.cltype_declaration Subst.identity cltydef) - env)) - -(* Check that #c is coercible to c if there is a self-coercion *) -let check_coercions env - (id, id_loc, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, - arity, pub_meths, coercion_locs, _expr, req) = - begin match coercion_locs with [] -> () - | loc :: _ -> - let cl_ty, obj_ty = - match cl_abbr.type_manifest, obj_abbr.type_manifest with - Some cl_ab, Some obj_ab -> - let cl_params, cl_ty = - Ctype.instance_parameterized_type cl_abbr.type_params cl_ab - and obj_params, obj_ty = - Ctype.instance_parameterized_type obj_abbr.type_params obj_ab - in - List.iter2 (Ctype.unify env) cl_params obj_params; - cl_ty, obj_ty - | _ -> assert false - in - begin try Ctype.subtype env cl_ty obj_ty () - with Ctype.Subtype (tr1, tr2) -> - raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2))) - end; - if not (Ctype.opened_object cl_ty) then - raise(Error(loc, env, Cannot_coerce_self obj_ty)) - end; - {cls_id = id; - cls_id_loc = id_loc; - cls_decl = clty; - cls_ty_id = ty_id; - cls_ty_decl = cltydef; - cls_obj_id = obj_id; - cls_obj_abbr = obj_abbr; - cls_typesharp_id = cl_id; - cls_abbr = cl_abbr; - cls_arity = arity; - cls_pub_methods = pub_meths; - cls_info=req} - -(*******************************) -(* FIXME: [define_class] is always [false] here *) -let type_classes approx kind env cls = - let cls = - List.map - (function cl -> - (cl, - Ident.create cl.pci_name.txt, Ident.create cl.pci_name.txt, - Ident.create cl.pci_name.txt, Ident.create ("#" ^ cl.pci_name.txt))) - cls - in - Ctype.init_def (Ident.current_time ()); - Ctype.begin_class_def (); - let (res, env) = - List.fold_left (initial_env approx) ([], env) cls - in - let (res, env) = - List.fold_right (class_infos kind) res ([], env) - in - Ctype.end_def (); - let res = List.rev_map (final_decl env ) res in - let decls = List.fold_right extract_type_decls res [] in - let decls = Typedecl.compute_variance_decls env decls in - let res = List.map2 merge_type_decls res decls in - let env = List.fold_left final_env env res in - let res = List.map (check_coercions env) res in - (res, env) - - -let class_description env sexpr = - let expr = class_type env sexpr in - (expr, expr.cltyp_type) - - - -let class_type_declarations env cls = - let (decls, env) = - type_classes approx_description class_description env cls - in - (List.map - (fun decl -> - {clsty_ty_id = decl.cls_ty_id; - clsty_id_loc = decl.cls_id_loc; - clsty_ty_decl = decl.cls_ty_decl; - clsty_obj_id = decl.cls_obj_id; - clsty_obj_abbr = decl.cls_obj_abbr; - clsty_typesharp_id = decl.cls_typesharp_id; - clsty_abbr = decl.cls_abbr; - clsty_info = decl.cls_info}) - decls, - env) - - - -(*******************************) - -(* Approximate the class declaration as class ['params] id = object end *) -let approx_class sdecl = - let open Ast_helper in - let self' = Typ.any () in - let clty' = Cty.signature ~loc:sdecl.pci_expr.pcty_loc (Csig.mk self' []) in - { sdecl with pci_expr = clty' } - -let approx_class_declarations env sdecls = - fst (class_type_declarations env (List.map approx_class sdecls)) - -(*******************************) - -(* Error report *) - -open Format - -let report_error env ppf = function - | Repeated_parameter -> - fprintf ppf "A type parameter occurs several times" - | Unconsistent_constraint trace -> - fprintf ppf "The class constraints are not consistent.@."; - Printtyp.report_unification_error ppf env trace - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type") - | Field_type_mismatch (k, m, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The %s %s@ has type" k m) - (function ppf -> - fprintf ppf "but is expected to have type") - | Structure_expected clty -> - fprintf ppf - "@[This class expression is not a class structure; it has type@ %a@]" - Printtyp.class_type clty - | Pattern_type_clash ty -> - (* XXX Trace *) - (* XXX Revoir message d'erreur | Improve error message *) - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[%s@ %a@]" - "This pattern cannot match self: it only matches values of type" - Printtyp.type_expr ty - | Unbound_class_type_2 cl -> - fprintf ppf "@[The class type@ %a@ is not yet completely defined@]" - Printtyp.longident cl - | Abbrev_type_clash (abbrev, actual, expected) -> - (* XXX Afficher une trace ? | Print a trace? *) - Printtyp.reset_and_mark_loops_list [abbrev; actual; expected]; - fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ - but is used with type@ %a@]" - Printtyp.type_expr abbrev - Printtyp.type_expr actual - Printtyp.type_expr expected - | Constructor_type_mismatch (c, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The expression \"new %s\" has type" c) - (function ppf -> - fprintf ppf "but is used with type") - | Virtual_class (cl, imm, mets, vals) -> - let print_mets ppf mets = - List.iter (function met -> fprintf ppf "@ %s" met) mets in - let missings = - match mets, vals with - [], _ -> "variables" - | _, [] -> "methods" - | _ -> "methods and variables" - in - let print_msg ppf = - if imm then fprintf ppf "This object has virtual %s" missings - else if cl then fprintf ppf "This class should be virtual" - else fprintf ppf "This class type should be virtual" - in - fprintf ppf - "@[%t.@ @[<2>The following %s are undefined :%a@]@]" - print_msg missings print_mets (mets @ vals) - | Parameter_arity_mismatch(lid, expected, provided) -> - fprintf ppf - "@[The class constructor %a@ expects %i type argument(s),@ \ - but is here applied to %i type argument(s)@]" - Printtyp.longident lid expected provided - | Parameter_mismatch trace -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The type parameter") - (function ppf -> - fprintf ppf "does not meet its constraint: it should be") - | Bad_parameters (id, params, cstrs) -> - Printtyp.reset_and_mark_loops_list [params; cstrs]; - fprintf ppf - "@[The abbreviation %a@ is used with parameters@ %a@ \ - which are incompatible with constraints@ %a@]" - Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs - | Unbound_type_var (printer, reason) -> - let print_common ppf kind ty0 real lab ty = - let ty1 = - if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in - List.iter Printtyp.mark_loops [ty; ty1]; - fprintf ppf - "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" - kind lab Printtyp.type_expr ty Printtyp.type_expr ty0 - in - let print_reason ppf = function - | Ctype.CC_Method (ty0, real, lab, ty) -> - print_common ppf "method" ty0 real lab ty - | Ctype.CC_Value (ty0, real, lab, ty) -> - print_common ppf "instance variable" ty0 real lab ty - in - Printtyp.reset (); - fprintf ppf - "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ - @[%a@]@]" - printer print_reason reason - | Non_generalizable_class (id, clty) -> - fprintf ppf - "@[The type of this class,@ %a,@ \ - contains type variables that cannot be generalized@]" - (Printtyp.class_declaration id) clty - | Cannot_coerce_self ty -> - fprintf ppf - "@[The type of self cannot be coerced to@ \ - the type of the current class:@ %a.@.\ - Some occurrences are contravariant@]" - Printtyp.type_scheme ty - | Non_collapsable_conjunction (id, clty, trace) -> - fprintf ppf - "@[The type of this class,@ %a,@ \ - contains non-collapsible conjunctive types in constraints@]" - (Printtyp.class_declaration id) clty; - Printtyp.report_unification_error ppf env trace - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type") - | No_overriding (_, "") -> - fprintf ppf "@[This inheritance does not override any method@ %s@]" - "instance variable" - | No_overriding (kind, name) -> - fprintf ppf "@[The %s `%s'@ has no previous definition@]" kind name - -let report_error env ppf err = - Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) - -let () = - Location.register_error_of_exn - (function - | Error (loc, env, err) -> - Some (Location.error_of_printer loc (report_error env) err) - | Error_forward err -> - Some err - | _ -> - None - ) diff --git a/jscomp/ml/typeclass.mli b/jscomp/ml/typeclass.mli deleted file mode 100644 index b31bff9..0000000 --- a/jscomp/ml/typeclass.mli +++ /dev/null @@ -1,65 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jerome Vouillon, 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Types -open Format - -type 'a class_info = { - cls_id : Ident.t; - cls_id_loc : string loc; - cls_decl : class_declaration; - cls_ty_id : Ident.t; - cls_ty_decl : class_type_declaration; - cls_obj_id : Ident.t; - cls_obj_abbr : type_declaration; - cls_typesharp_id : Ident.t; - cls_abbr : type_declaration; - cls_arity : int; - cls_pub_methods : string list; - cls_info : 'a; -} - -type class_type_info = { - clsty_ty_id : Ident.t; - clsty_id_loc : string loc; - clsty_ty_decl : class_type_declaration; - clsty_obj_id : Ident.t; - clsty_obj_abbr : type_declaration; - clsty_typesharp_id : Ident.t; - clsty_abbr : type_declaration; - clsty_info : Typedtree.class_type_declaration; -} - - - - - -val class_type_declarations: - Env.t -> Parsetree.class_type_declaration list -> class_type_info list * Env.t - - -val approx_class_declarations: - Env.t -> Parsetree.class_type_declaration list -> class_type_info list - -val virtual_methods: Types.class_signature -> label list - - -type error - -exception Error of Location.t * Env.t * error -exception Error_forward of Location.error - -val report_error : Env.t -> formatter -> error -> unit diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml deleted file mode 100644 index 0c9f0eb..0000000 --- a/jscomp/ml/typecore.ml +++ /dev/null @@ -1,4114 +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. *) -(* *) -(**************************************************************************) - -(* Typechecking for the core language *) - -open Misc -open Asttypes -open Parsetree -open Types -open Typedtree -open Btype -open Ctype -open Error_message_utils - -type error = - Polymorphic_label of Longident.t - | Constructor_arity_mismatch of Longident.t * int * int - | Label_mismatch of Longident.t * (type_expr * type_expr) list - | Pattern_type_clash of (type_expr * type_expr) list - | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list - | Multiply_bound_variable of string - | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of (type_expr * type_expr) list * (typeClashContext option) - | Apply_non_function of type_expr - | Apply_wrong_label of arg_label * type_expr - | Label_multiply_defined of string - | Labels_missing of string list * bool - | Label_not_mutable of Longident.t - | Wrong_name of string * type_expr * string * Path.t * string * string list - | Name_type_mismatch of - string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list - | Undefined_method of type_expr * string * string list option - | Private_type of type_expr - | Private_label of Longident.t * type_expr - - | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list - | Coercion_failure of - type_expr * type_expr * (type_expr * type_expr) list * bool - | Too_many_arguments of bool * type_expr - | Abstract_wrong_label of arg_label * type_expr - | Scoping_let_module of string * type_expr - | Not_a_variant_type of Longident.t - | Incoherent_label_order - | Less_general of string * (type_expr * type_expr) list - | Modules_not_allowed - | Cannot_infer_signature - | Not_a_packed_module of type_expr - | Recursive_local_constraint of (type_expr * type_expr) list - | Unexpected_existential - | Unqualified_gadt_pattern of Path.t * string - | Invalid_interval - | Invalid_for_loop_index - | No_value_clauses - | Exception_pattern_below_toplevel - | Inlined_record_escape - | Inlined_record_expected - | Unrefuted_pattern of pattern - | Invalid_extension_constructor_payload - | Not_an_extension_constructor - | Literal_overflow of string - | Unknown_literal of string * char - | Illegal_letrec_pat - | Labels_omitted of string list - | Empty_record_literal - | Uncurried_arity_mismatch of type_expr * int * int - | Field_not_optional of string * type_expr -exception Error of Location.t * Env.t * error -exception Error_forward of Location.error - -(* Forward declaration, to be filled in by Typemod.type_module *) - -let type_module = - ref ((fun _env _md -> assert false) : - Env.t -> Parsetree.module_expr -> Typedtree.module_expr) - -(* Forward declaration, to be filled in by Typemod.type_open *) - -let type_open : - (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Longident.t loc -> Path.t * Env.t) - ref = - ref (fun ?used_slot:_ _ -> assert false) - -(* Forward declaration, to be filled in by Typemod.type_package *) - -let type_package = - ref (fun _ -> assert false) - -(* Forward declaration, to be filled in by Typeclass.class_structure *) - -(* - Saving and outputting type information. - We keep these function names short, because they have to be - called each time we create a record of type [Typedtree.expression] - or [Typedtree.pattern] that will end up in the typed AST. -*) -let re node = - Cmt_format.add_saved_type (Cmt_format.Partial_expression node); - Stypes.record (Stypes.Ti_expr node); - node -;; -let rp node = - Cmt_format.add_saved_type (Cmt_format.Partial_pattern node); - Stypes.record (Stypes.Ti_pat node); - node -;; - - -type recarg = - | Allowed - | Required - | Rejected - - -let case lhs rhs = - {c_lhs = lhs; c_guard = None; c_rhs = rhs} - -(* Upper approximation of free identifiers on the parse tree *) - -let iter_expression f e = - - let rec expr e = - f e; - match e.pexp_desc with - | Pexp_extension _ (* we don't iterate under extension point *) - | Pexp_ident _ - | Pexp_new _ - | Pexp_constant _ -> () - | Pexp_function pel -> List.iter case pel - | Pexp_fun (_, eo, _, e) -> may expr eo; expr e - | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel - | Pexp_let (_, pel, e) -> expr e; List.iter binding pel - | Pexp_match (e, pel) - | Pexp_try (e, pel) -> expr e; List.iter case pel - | Pexp_array el - | Pexp_tuple el -> List.iter expr el - | Pexp_construct (_, eo) - | Pexp_variant (_, eo) -> may expr eo - | Pexp_record (iel, eo) -> - may expr eo; List.iter (fun (_, e) -> expr e) iel - | Pexp_open (_, _, e) - | Pexp_newtype (_, e) - | Pexp_poly (e, _) - | Pexp_lazy e - | Pexp_assert e - | Pexp_setinstvar (_, e) - | Pexp_send (e, _) - | Pexp_constraint (e, _) - | Pexp_coerce (e, _, _) - | Pexp_letexception (_, e) - | Pexp_field (e, _) -> expr e - | Pexp_while (e1, e2) - | Pexp_sequence (e1, e2) - | Pexp_setfield (e1, _, e2) -> expr e1; expr e2 - | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; may expr eo - | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3 - | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel - | Pexp_letmodule (_, me, e) -> expr e; module_expr me - | Pexp_object _ -> assert false - | Pexp_pack me -> module_expr me - | Pexp_unreachable -> () - - and case {pc_lhs = _; pc_guard; pc_rhs} = - may expr pc_guard; - expr pc_rhs - - and binding x = - expr x.pvb_expr - - and module_expr me = - match me.pmod_desc with - | Pmod_extension _ - | Pmod_ident _ -> () - | Pmod_structure str -> List.iter structure_item str - | Pmod_constraint (me, _) - | Pmod_functor (_, _, me) -> module_expr me - | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2 - | Pmod_unpack e -> expr e - - - and structure_item str = - match str.pstr_desc with - | Pstr_eval (e, _) -> expr e - | Pstr_value (_, pel) -> List.iter binding pel - | Pstr_primitive _ - | Pstr_type _ - | Pstr_typext _ - | Pstr_exception _ - | Pstr_modtype _ - | Pstr_open _ - | Pstr_class_type _ - | Pstr_attribute _ - | Pstr_extension _ -> () - | Pstr_include {pincl_mod = me} - | Pstr_module {pmb_expr = me} -> module_expr me - | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l - | Pstr_class () -> () - - - - - in - expr e - - -let all_idents_cases el = - let idents = Hashtbl.create 8 in - let f = function - | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} -> - Hashtbl.replace idents id () - | _ -> () - in - List.iter - (fun cp -> - may (iter_expression f) cp.pc_guard; - iter_expression f cp.pc_rhs - ) - el; - Hashtbl.fold (fun x () rest -> x :: rest) idents [] - - -(* Typing of constants *) - -let type_constant = function - Const_int _ -> instance_def Predef.type_int - | Const_char _ -> instance_def Predef.type_char - | Const_string _ -> instance_def Predef.type_string - | Const_float _ -> instance_def Predef.type_float - | Const_int64 _ -> instance_def Predef.type_int64 - | Const_bigint _ -> instance_def Predef.type_bigint - | Const_int32 _ -> assert false - -let constant : Parsetree.constant -> (Asttypes.constant, error) result = - function - | Pconst_integer (i,None) -> - begin - try Ok (Const_int (Misc.Int_literal_converter.int i)) - with Failure _ -> Error (Literal_overflow "int") - end - | Pconst_integer (i,Some 'l') -> - begin - try Ok (Const_int32 (Misc.Int_literal_converter.int32 i)) - with Failure _ -> Error (Literal_overflow "int32") - end - | Pconst_integer (i,Some 'L') -> - begin - try Ok (Const_int64 (Misc.Int_literal_converter.int64 i)) - with Failure _ -> Error (Literal_overflow "int64") - end - | Pconst_integer (i,Some 'n') -> - let sign, i = Bigint_utils.parse_bigint i in - Ok (Const_bigint (sign, i)) - | Pconst_integer (i,Some c) -> Error (Unknown_literal (i, c)) - | Pconst_char c -> Ok (Const_char c) - | Pconst_string (s,d) -> Ok (Const_string (s,d)) - | Pconst_float (f,None)-> Ok (Const_float f) - | Pconst_float (f,Some c) -> Error (Unknown_literal (f, c)) - -let constant_or_raise env loc cst = - match constant cst with - | Ok c -> c - | Error err -> raise (Error (loc, env, err)) - -(* Specific version of type_option, using newty rather than newgenty *) - -let type_option ty = - newty (Tconstr(Predef.path_option,[ty], ref Mnil)) - -let mkexp exp_desc exp_type exp_loc exp_env = - { exp_desc; exp_type; exp_loc; exp_env; exp_extra = []; exp_attributes = [] } - -let option_none ty loc = - let lid = Longident.Lident "None" - and env = Env.initial_safe_string in - let cnone = Env.lookup_constructor lid env in - mkexp (Texp_construct(mknoloc lid, cnone, [])) ty loc env - -let option_some texp = - let lid = Longident.Lident "Some" in - let csome = Env.lookup_constructor lid Env.initial_safe_string in - mkexp ( Texp_construct(mknoloc lid , csome, [texp]) ) - (type_option texp.exp_type) texp.exp_loc texp.exp_env - -let extract_option_type env ty = - match expand_head env ty with {desc = Tconstr(path, [ty], _)} - when Path.same path Predef.path_option -> ty - | _ -> assert false - -let extract_concrete_record env ty = - match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_record (fields, repr)}) -> (p0, p, fields, repr) - | _ -> raise Not_found - -let extract_concrete_variant env ty = - match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_variant cstrs}) - when not (Ast_uncurried.typeIsUncurriedFun ty) - -> (p0, p, cstrs) - | (p0, p, {type_kind=Type_open}) -> (p0, p, []) - | _ -> raise Not_found - -let has_optional_labels ld = - match ld.lbl_repres with - | Record_optional_labels _ -> true - | Record_inlined {optional_labels} -> optional_labels <> [] - | _ -> false - -let label_is_optional ld = - match ld.lbl_repres with - | Record_optional_labels lbls -> Ext_list.mem_string lbls ld.lbl_name - | Record_inlined {optional_labels} -> Ext_list.mem_string optional_labels ld.lbl_name - | _ -> false - -let check_optional_attr env ld attrs loc = - let check_redundant () = - if not (label_is_optional ld) then - raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); - true in - Ext_list.exists attrs (fun ({txt}, _) -> - txt = "res.optional" && check_redundant ()) - -(* unification inside type_pat*) -let unify_pat_types loc env ty ty' = - try - unify env ty ty' - with - Unify trace -> - raise(Error(loc, env, Pattern_type_clash(trace))) - | Tags(l1,l2) -> - raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) - -(* unification inside type_exp and type_expect *) -let unify_exp_types ?typeClashContext loc env ty expected_ty = - (* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type - Printtyp.raw_type_expr expected_ty; *) - try - unify env ty expected_ty - with - Unify trace -> - raise(Error(loc, env, Expr_type_clash(trace, typeClashContext))) - | Tags(l1,l2) -> - raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) - -(* level at which to create the local type declarations *) -let newtype_level = ref None -let get_newtype_level () = - match !newtype_level with - Some y -> y - | None -> assert false - -let unify_pat_types_gadt loc env ty ty' = - let newtype_level = - match !newtype_level with - | None -> assert false - | Some x -> x - in - try - unify_gadt ~newtype_level env ty ty' - with - Unify trace -> - raise(Error(loc, !env, Pattern_type_clash(trace))) - | Tags(l1,l2) -> - raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2))) - | Unification_recursive_abbrev trace -> - raise(Error(loc, !env, Recursive_local_constraint trace)) - - -(* Creating new conjunctive types is not allowed when typing patterns *) - -let unify_pat env pat expected_ty = - unify_pat_types pat.pat_loc env pat.pat_type expected_ty - -(* make all Reither present in open variants *) -let finalize_variant pat = - match pat.pat_desc with - Tpat_variant(tag, opat, r) -> - let row = - match expand_head pat.pat_env pat.pat_type with - {desc = Tvariant row} -> r := row; row_repr row - | _ -> assert false - in - begin match row_field tag row with - | Rabsent -> () (* assert false *) - | Reither (true, [], _, e) when not row.row_closed -> - set_row_field e (Rpresent None) - | Reither (false, ty::tl, _, e) when not row.row_closed -> - set_row_field e (Rpresent (Some ty)); - begin match opat with None -> assert false - | Some pat -> List.iter (unify_pat pat.pat_env pat) (ty::tl) - end - | Reither (c, _l, true, e) when not (row_fixed row) -> - set_row_field e (Reither (c, [], false, ref None)) - | _ -> () - end; - (* Force check of well-formedness WHY? *) - (* unify_pat pat.pat_env pat - (newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false; - row_bound=(); row_fixed=false; row_name=None})); *) - | _ -> () - -let rec iter_pattern f p = - f p; - iter_pattern_desc (iter_pattern f) p.pat_desc - -let has_variants p = - try - iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ()) - p; - false - with Exit -> - true - - -(* pattern environment *) -let pattern_variables = ref ([] : - (Ident.t * type_expr * string loc * Location.t * bool (* as-variable *)) list) -let pattern_force = ref ([] : (unit -> unit) list) -let pattern_scope = ref (None : Annot.ident option);; -let allow_modules = ref false -let module_variables = ref ([] : (string loc * Location.t) list) -let reset_pattern scope allow = - pattern_variables := []; - pattern_force := []; - pattern_scope := scope; - allow_modules := allow; - module_variables := []; -;; - -let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty = - if List.exists (fun (id, _, _, _, _) -> Ident.name id = name.txt) - !pattern_variables - then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt)); - let id = Ident.create name.txt in - pattern_variables := - (id, ty, name, loc, is_as_variable) :: !pattern_variables; - if is_module then begin - (* Note: unpack patterns enter a variable of the same name *) - if not !allow_modules then - raise (Error (loc, Env.empty, Modules_not_allowed)); - module_variables := (name, loc) :: !module_variables - end else - (* moved to genannot *) - may (fun s -> Stypes.record (Stypes.An_ident (name.loc, name.txt, s))) - !pattern_scope; - id - -let sort_pattern_variables vs = - List.sort - (fun (x,_,_,_,_) (y,_,_,_,_) -> - compare (Ident.name x) (Ident.name y)) - vs - -let enter_orpat_variables loc env p1_vs p2_vs = - (* unify_vars operate on sorted lists *) - - let p1_vs = sort_pattern_variables p1_vs - and p2_vs = sort_pattern_variables p2_vs in - - let rec unify_vars p1_vs p2_vs = - let vars vs = List.map (fun (x,_t,_,_l,_a) -> x) vs in - match p1_vs, p2_vs with - | (x1,t1,_,_l1,_a1)::rem1, (x2,t2,_,_l2,_a2)::rem2 - when Ident.equal x1 x2 -> - if x1==x2 then - unify_vars rem1 rem2 - else begin - begin try - unify env t1 t2 - with - | Unify trace -> - raise(Error(loc, env, Or_pattern_type_clash(x1, trace))) - end; - (x2,x1)::unify_vars rem1 rem2 - end - | [],[] -> [] - | (x,_,_,_,_)::_, [] -> raise (Error (loc, env, Orpat_vars (x, []))) - | [],(y,_,_,_,_)::_ -> raise (Error (loc, env, Orpat_vars (y, []))) - | (x,_,_,_,_)::_, (y,_,_,_,_)::_ -> - let err = - if Ident.name x < Ident.name y - then Orpat_vars (x, vars p2_vs) - else Orpat_vars (y, vars p1_vs) in - raise (Error (loc, env, err)) in - unify_vars p1_vs p2_vs - -let rec build_as_type env p = - match p.pat_desc with - Tpat_alias(p1,_, _) -> build_as_type env p1 - | Tpat_tuple pl -> - let tyl = List.map (build_as_type env) pl in - newty (Ttuple tyl) - | Tpat_construct(_, cstr, pl) -> - let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in - if keep then p.pat_type else - let tyl = List.map (build_as_type env) pl in - let ty_args, ty_res = instance_constructor cstr in - List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty}) - (List.combine pl tyl) ty_args; - ty_res - | Tpat_variant(l, p', _) -> - let ty = may_map (build_as_type env) p' in - newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); - row_bound=(); row_name=None; - row_fixed=false; row_closed=false}) - | Tpat_record (lpl,_) -> - let lbl = snd3 (List.hd lpl) in - if lbl.lbl_private = Private then p.pat_type else - let ty = newvar () in - let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in - let do_label lbl = - let _, ty_arg, ty_res = instance_label false lbl in - unify_pat env {p with pat_type = ty} ty_res; - let refinable = - lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && - match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in - if refinable then begin - let arg = List.assoc lbl.lbl_pos ppl in - unify_pat env {arg with pat_type = build_as_type env arg} ty_arg - end else begin - let _, ty_arg', ty_res' = instance_label false lbl in - unify env ty_arg ty_arg'; - unify_pat env p ty_res' - end in - Array.iter do_label lbl.lbl_all; - ty - | Tpat_or(p1, p2, row) -> - begin match row with - None -> - let ty1 = build_as_type env p1 and ty2 = build_as_type env p2 in - unify_pat env {p2 with pat_type = ty2} ty1; - ty1 - | Some row -> - let row = row_repr row in - newty (Tvariant{row with row_closed=false; row_more=newvar()}) - end - | Tpat_any | Tpat_var _ | Tpat_constant _ - | Tpat_array _ | Tpat_lazy _ -> p.pat_type - -let build_or_pat env loc lid = - let path, decl = Typetexp.find_type env lid.loc lid.txt - in - let tyl = List.map (fun _ -> newvar()) decl.type_params in - let row0 = - let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in - match ty.desc with - Tvariant row when static_row row -> row - | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt)) - in - let pats, fields = - List.fold_left - (fun (pats,fields) (l,f) -> - match row_field_repr f with - Rpresent None -> - (l,None) :: pats, - (l, Reither(true,[], true, ref None)) :: fields - | Rpresent (Some ty) -> - (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; - pat_type=ty; pat_extra=[]; pat_attributes=[]}) - :: pats, - (l, Reither(false, [ty], true, ref None)) :: fields - | _ -> pats, fields) - ([],[]) (row_repr row0).row_fields in - let row = - { row_fields = List.rev fields; row_more = newvar(); row_bound = (); - row_closed = false; row_fixed = false; row_name = Some (path, tyl) } - in - let ty = newty (Tvariant row) in - let gloc = {loc with Location.loc_ghost=true} in - let row' = ref {row with row_more=newvar()} in - let pats = - List.map - (fun (l,p) -> - {pat_desc=Tpat_variant(l,p,row'); pat_loc=gloc; - pat_env=env; pat_type=ty; pat_extra=[]; pat_attributes=[]}) - pats - in - match pats with - [] -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt)) - | pat :: pats -> - let r = - List.fold_left - (fun pat pat0 -> - {pat_desc=Tpat_or(pat0,pat,Some row0); pat_extra=[]; - pat_loc=gloc; pat_env=env; pat_type=ty; pat_attributes=[]}) - pat pats in - (path, rp { r with pat_loc = loc },ty) - -(* Type paths *) - -let rec expand_path env p = - let decl = - try Some (Env.find_type p env) with Not_found -> None - in - match decl with - Some {type_manifest = Some ty} -> - begin match repr ty with - {desc=Tconstr(p,_,_)} -> expand_path env p - | _ -> p - (* PR#6394: recursive module may introduce incoherent manifest *) - end - | _ -> - let p' = Env.normalize_path None env p in - if Path.same p p' then p else expand_path env p' - -let compare_type_path env tpath1 tpath2 = - Path.same (expand_path env tpath1) (expand_path env tpath2) - -let fprintf = Format.fprintf - -let rec bottom_aliases = function - | (_, one) :: (_, two) :: rest -> begin match bottom_aliases rest with - | Some types -> Some types - | None -> Some (one, two) - end - | _ -> None - -let simple_conversions = [ - (("float", "int"), "Belt.Float.toInt"); - (("float", "string"), "Belt.Float.toString"); - (("int", "float"), "Belt.Int.toFloat"); - (("int", "string"), "Belt.Int.toString"); - (("string", "float"), "Belt.Float.fromString"); - (("string", "int"), "Belt.Int.fromString"); -] - -let print_simple_conversion ppf (actual, expected) = - try ( - let converter = List.assoc (actual, expected) simple_conversions in - fprintf ppf "@,@,@[You can convert @{%s@} to @{%s@} with @{%s@}.@]" actual expected converter - ) with | Not_found -> () - -let print_simple_message ppf = function - | ("float", "int") -> fprintf ppf "@ If this is a literal, try a number without a trailing dot (e.g. @{20@})." - | ("int", "float") -> fprintf ppf "@ If this is a literal, try a number with a trailing dot (e.g. @{20.@})." - | _ -> () - -let show_extra_help ppf _env trace = begin - match bottom_aliases trace with - | Some ({Types.desc = Tconstr (actualPath, actualArgs, _)}, {desc = Tconstr (expectedPath, expextedArgs, _)}) -> begin - match (actualPath, actualArgs, expectedPath, expextedArgs) with - | (Pident {name = actualName}, [], Pident {name = expectedName}, []) -> begin - print_simple_conversion ppf (actualName, expectedName); - print_simple_message ppf (actualName, expectedName); - end - | _ -> () - end; - | _ -> (); -end - -let rec collect_missing_arguments env type1 type2 = match type1 with - (* why do we use Ctype.matches here? Please see https://github.com/rescript-lang/rescript-compiler/pull/2554 *) - | {Types.desc=Tarrow (label, argtype, typ, _)} when Ctype.matches env typ type2 -> - Some [(label, argtype)] - | {desc=Tarrow (label, argtype, typ, _)} -> begin - match collect_missing_arguments env typ type2 with - | Some res -> Some ((label, argtype) :: res) - | None -> None - end - | t when Ast_uncurried.typeIsUncurriedFun t -> - let typ = Ast_uncurried.typeExtractUncurriedFun t in - collect_missing_arguments env typ type2 - | _ -> None - -let print_expr_type_clash ?typeClashContext env trace ppf = begin - (* this is the most frequent error. We should do whatever we can to provide - specific guidance to this generic error before giving up *) - let bottom_aliases_result = bottom_aliases trace in - let missing_arguments = match bottom_aliases_result with - | Some (actual, expected) -> collect_missing_arguments env actual expected - | None -> assert false - in - let print_arguments = - Format.pp_print_list - ~pp_sep:(fun ppf _ -> fprintf ppf ",@ ") - (fun ppf (label, argtype) -> - match label with - | Asttypes.Nolabel -> fprintf ppf "@[%a@]" Printtyp.type_expr argtype - | Labelled label -> - fprintf ppf "@[(~%s: %a)@]" label Printtyp.type_expr argtype - | Optional label -> - fprintf ppf "@[(?%s: %a)@]" label Printtyp.type_expr argtype - ) - in - match missing_arguments with - | Some [singleArgument] -> - (* btw, you can't say "final arguments". Intermediate labeled - arguments might be the ones missing *) - fprintf ppf "@[@{This call is missing an argument@} of type@ %a@]" - print_arguments [singleArgument] - | Some arguments -> - fprintf ppf "@[@{This call is missing arguments@} of type:@ %a@]" - print_arguments arguments - | None -> - let missing_parameters = match bottom_aliases_result with - | Some (actual, expected) -> collect_missing_arguments env expected actual - | None -> assert false - in - begin match missing_parameters with - | Some [singleParameter] -> - fprintf ppf "@[This value might need to be @{wrapped in a function@ that@ takes@ an@ extra@ parameter@}@ of@ type@ %a@]@,@," - print_arguments [singleParameter]; - fprintf ppf "@[@{Here's the original error message@}@]@," - | Some arguments -> - fprintf ppf "@[This value seems to @{need to be wrapped in a function that takes extra@ arguments@}@ of@ type:@ @[%a@]@]@,@," - print_arguments arguments; - fprintf ppf "@[@{Here's the original error message@}@]@," - | None -> () - end; - - Printtyp.super_report_unification_error ppf env trace - (function ppf -> - errorTypeText ppf typeClashContext) - (function ppf -> - errorExpectedTypeText ppf typeClashContext); - printExtraTypeClashHelp ppf trace typeClashContext; - show_extra_help ppf env trace; -end - -let reportArityMismatch ~arityA ~arityB ppf = - fprintf ppf "This function expected @{%s@} %s, but got @{%s@}" - arityB - (if arityB = "1" then "argument" else "arguments") - arityA - -(* Records *) -let label_of_kind kind = - if kind = "record" then "field" else "constructor" - -module NameChoice(Name : sig - type t - val type_kind: string - val get_name: t -> string - val get_type: t -> type_expr - val get_descrs: Env.type_descriptions -> t list - val unbound_name_error: Env.t -> Longident.t loc -> 'a - -end) = struct - open Name - - let get_type_path d = - match (repr (get_type d)).desc with - | Tconstr(p, _, _) -> p - | _ -> assert false - - let lookup_from_type env tpath lid = - let descrs = get_descrs (Env.find_type_descrs tpath env) in - Env.mark_type_used env (Path.last tpath) (Env.find_type tpath env); - match lid.txt with - Longident.Lident s -> begin - try - List.find (fun nd -> get_name nd = s) descrs - with Not_found -> - let names = List.map get_name descrs in - raise (Error (lid.loc, env, - Wrong_name ("", newvar (), type_kind, tpath, s, names))) - end - | _ -> raise Not_found - - let rec unique eq acc = function - [] -> List.rev acc - | x :: rem -> - if List.exists (eq x) acc then unique eq acc rem - else unique eq (x :: acc) rem - - let ambiguous_types env lbl others = - let tpath = get_type_path lbl in - let others = - List.map (fun (lbl, _) -> get_type_path lbl) others in - let tpaths = unique (compare_type_path env) [tpath] others in - match tpaths with - [_] -> [] - | _ -> List.map Printtyp.string_of_path tpaths - - let disambiguate_by_type env tpath lbls = - let check_type (lbl, _) = - let lbl_tpath = get_type_path lbl in - compare_type_path env tpath lbl_tpath - in - List.find check_type lbls - - let disambiguate ?(warn=Location.prerr_warning) ?(check_lk=fun _ _ -> ()) - ?scope lid env opath lbls = - let scope = match scope with None -> lbls | Some l -> l in - let lbl = match opath with - None -> - begin match lbls with - [] -> unbound_name_error env lid - | (lbl, use) :: rest -> - use (); - let paths = ambiguous_types env lbl rest in - if paths <> [] then - warn lid.loc - (Warnings.Ambiguous_name ([Longident.last lid.txt], - paths, false)); - lbl - end - | Some(tpath0, tpath) -> - try - let lbl, use = disambiguate_by_type env tpath scope in - use (); - lbl - with Not_found -> try - let lbl = lookup_from_type env tpath lid in - check_lk tpath lbl; - lbl - with Not_found -> - if lbls = [] then unbound_name_error env lid else - let tp = (tpath0, expand_path env tpath) in - let tpl = - List.map - (fun (lbl, _) -> - let tp0 = get_type_path lbl in - let tp = expand_path env tp0 in - (tp0, tp)) - lbls - in - raise (Error (lid.loc, env, - Name_type_mismatch (type_kind, lid.txt, tp, tpl))) - in - lbl -end - -let wrap_disambiguate kind ty f x = - try f x with Error (loc, env, Wrong_name ("",_,tk,tp,name,valid_names)) -> - raise (Error (loc, env, Wrong_name (kind,ty,tk,tp,name,valid_names))) - -module Label = NameChoice (struct - type t = label_description - let type_kind = "record" - let get_name lbl = lbl.lbl_name - let get_type lbl = lbl.lbl_res - let get_descrs = snd - let unbound_name_error = Typetexp.unbound_label_error -end) - -let disambiguate_label_by_ids keep closed ids labels = - let check_ids (lbl, _) = - let lbls = Hashtbl.create 8 in - Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; - List.for_all (Hashtbl.mem lbls) ids in - let mandatory_labels_are_present num_ids lbl = (* check that all mandatory labels are present *) - if has_optional_labels lbl then ( - let mandatory_lbls = ref 0 in - Ext_array.iter lbl.lbl_all (fun l -> if not (label_is_optional l) then incr mandatory_lbls); - num_ids >= !mandatory_lbls) - else num_ids = Array.length lbl.lbl_all in - let check_closed (lbl, _) = - (not closed || mandatory_labels_are_present (List.length ids) lbl) - in - let labels' = Ext_list.filter labels check_ids in - if keep && labels' = [] then (false, labels) else - let labels'' = Ext_list.filter labels' check_closed in - if keep && labels'' = [] then (false, labels') else (true, labels'') - -(* Only issue warnings once per record constructor/pattern *) -let disambiguate_lid_a_list loc closed env opath lid_a_list = - let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in - let w_amb = ref [] in - let warn loc msg = - let open Warnings in - match msg with - - | Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb - | _ -> Location.prerr_warning loc msg - in - let process_label lid = - (* Strategy for each field: - * collect all the labels in scope for that name - * if the type is known and principal, just eventually warn - if the real label was not in scope - * fail if there is no known type and no label found - * otherwise use other fields to reduce the list of candidates - * if there is no known type reduce it incrementally, so that - there is still at least one candidate (for error message) - * if the reduced list is valid, call Label.disambiguate - *) - let scope = Typetexp.find_all_labels env lid.loc lid.txt in - if opath = None && scope = [] then - Typetexp.unbound_label_error env lid; - let (ok, labels) = - match opath with - Some (_, _) -> (true, scope) (* disambiguate only checks scope *) - | _ -> disambiguate_label_by_ids (opath=None) closed ids scope - in - if ok then Label.disambiguate lid env opath labels ~warn ~scope - else fst (List.hd labels) (* will fail later *) - in - let lbl_a_list = - List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in - begin - match List.rev !w_amb with - (_,types)::_ as amb -> - let paths = - List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in - let path = List.hd paths in - if List.for_all (compare_type_path env path) (List.tl paths) then - Location.prerr_warning loc - (Warnings.Ambiguous_name (List.map fst amb, types, true)) - else - List.iter - (fun (s,l) -> Location.prerr_warning loc - (Warnings.Ambiguous_name ([s],l,false))) - amb - | _ -> () - end; - lbl_a_list - -let rec find_record_qual = function - | [] -> None - | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname - | _ :: rest -> find_record_qual rest - -let map_fold_cont f xs k = - List.fold_right (fun x k ys -> f x (fun y -> k (y :: ys))) - xs (fun ys -> k (List.rev ys)) [] - -let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k = - let lbl_a_list = - match lid_a_list, labels with - ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s -> - (* Special case for rebuilt syntax trees *) - List.map - (function lid, a -> match lid.txt with - Longident.Lident s -> lid, Hashtbl.find labels s, a - | _ -> assert false) - lid_a_list - | _ -> - let lid_a_list = - match find_record_qual lid_a_list with - None -> lid_a_list - | Some modname -> - List.map - (fun (lid, a as lid_a) -> - match lid.txt with Longident.Lident s -> - {lid with txt=Longident.Ldot (modname, s)}, a - | _ -> lid_a) - lid_a_list - in - disambiguate_lid_a_list loc closed env opath lid_a_list - in - (* Invariant: records are sorted in the typed tree *) - let lbl_a_list = - List.sort - (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) - lbl_a_list - in - map_fold_cont type_lbl_a lbl_a_list k -;; - -(* Checks over the labels mentioned in a record pattern: - no duplicate definitions (error); properly closed (warning) *) - -let check_recordpat_labels loc lbl_pat_list closed = - match lbl_pat_list with - | [] -> () (* should not happen *) - | (_, label1, _) :: _ -> - let all = label1.lbl_all in - let defined = Array.make (Array.length all) false in - let check_defined (_, label, _) = - if defined.(label.lbl_pos) - then raise(Error(loc, Env.empty, Label_multiply_defined label.lbl_name)) - else defined.(label.lbl_pos) <- true in - List.iter check_defined lbl_pat_list; - if closed = Closed - && Warnings.is_active (Warnings.Non_closed_record_pattern "") - then begin - let undefined = ref [] in - for i = 0 to Array.length all - 1 do - if not defined.(i) then undefined := all.(i).lbl_name :: !undefined - done; - if !undefined <> [] then begin - let u = String.concat ", " (List.rev !undefined) in - Location.prerr_warning loc (Warnings.Non_closed_record_pattern u) - end - end - -(* Constructors *) - -module Constructor = NameChoice (struct - type t = constructor_description - let type_kind = "variant" - let get_name cstr = cstr.cstr_name - let get_type cstr = cstr.cstr_res - let get_descrs = fst - let unbound_name_error = Typetexp.unbound_constructor_error -end) - -(* unification of a type with a tconstr with - freshly created arguments *) -let unify_head_only loc env ty constr = - let (_, ty_res) = instance_constructor constr in - match (repr ty_res).desc with - | Tconstr(p,args,m) -> - ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m); - enforce_constraints env ty_res; - unify_pat_types loc env ty_res ty - | _ -> assert false - -(* Typing of patterns *) - -(* Remember current state for backtracking. - No variable information, as we only backtrack on - patterns without variables (cf. assert statements). *) -type state = - { snapshot: Btype.snapshot; - levels: Ctype.levels; - env: Env.t; } -let save_state env = - { snapshot = Btype.snapshot (); - levels = Ctype.save_levels (); - env = !env; } -let set_state s env = - Btype.backtrack s.snapshot; - Ctype.set_levels s.levels; - env := s.env - -(* type_pat does not generate local constraints inside or patterns *) -type type_pat_mode = - | Normal - | Splitting_or (* splitting an or-pattern *) - | Inside_or (* inside a non-split or-pattern *) - | Split_or (* always split or-patterns *) - -exception Need_backtrack - -(* type_pat propagates the expected type as well as maps for - constructors and labels. - Unification may update the typing environment. *) -(* constrs <> None => called from parmatch: backtrack on or-patterns - explode > 0 => explode Ppat_any for gadts *) -let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env - sp expected_ty k = - Builtin_attributes.warning_scope sp.ppat_attributes - (fun () -> - type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env - sp expected_ty k - ) - -and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env - sp expected_ty k = - let mode' = if mode = Splitting_or then Normal else mode in - let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode') - ?(explode=explode) ?(env=env) = - type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env in - let loc = sp.ppat_loc in - let rp k x : pattern = if constrs = None then k (rp x) else k x in - match sp.ppat_desc with - Ppat_any -> - let k' d = rp k { - pat_desc = d; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - in - if explode > 0 then - let (sp, constrs, labels) = Parmatch.ppat_of_type !env expected_ty in - if sp.ppat_desc = Parsetree.Ppat_any then k' Tpat_any else - if mode = Inside_or then raise Need_backtrack else - let explode = - match sp.ppat_desc with - Parsetree.Ppat_or _ -> explode - 5 - | _ -> explode - 1 - in - type_pat ~constrs:(Some constrs) ~labels:(Some labels) - ~explode sp expected_ty k - else k' Tpat_any - | Ppat_var name -> - let id = (* PR#7330 *) - if name.txt = "*extension*" then Ident.create name.txt else - enter_variable loc name expected_ty - in - rp k { - pat_desc = Tpat_var (id, name); - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - | Ppat_unpack name -> - assert (constrs = None); - let id = enter_variable loc name expected_ty ~is_module:true in - rp k { - pat_desc = Tpat_var (id, name); - pat_loc = sp.ppat_loc; - pat_extra=[Tpat_unpack, loc, sp.ppat_attributes]; - pat_type = expected_ty; - pat_attributes = []; - pat_env = !env } - | Ppat_constraint({ppat_desc=Ppat_var name; ppat_loc=lloc}, - ({ptyp_desc=Ptyp_poly _} as sty)) -> - (* explicitly polymorphic type *) - assert (constrs = None); - let cty, force = Typetexp.transl_simple_type_delayed !env sty in - let ty = cty.ctyp_type in - unify_pat_types lloc !env ty expected_ty; - pattern_force := force :: !pattern_force; - begin match ty.desc with - | Tpoly (body, tyl) -> - begin_def (); - let _, ty' = instance_poly ~keep_names:true false tyl body in - end_def (); - generalize ty'; - let id = enter_variable lloc name ty' in - rp k { - pat_desc = Tpat_var (id, name); - pat_loc = lloc; - pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; - pat_type = ty; - pat_attributes = []; - pat_env = !env - } - | _ -> assert false - end - | Ppat_alias(sq, name) -> - assert (constrs = None); - type_pat sq expected_ty (fun q -> - begin_def (); - let ty_var = build_as_type !env q in - end_def (); - generalize ty_var; - let id = enter_variable ~is_as_variable:true loc name ty_var in - rp k { - pat_desc = Tpat_alias(q, id, name); - pat_loc = loc; pat_extra=[]; - pat_type = q.pat_type; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_constant cst -> - let cst = constant_or_raise !env loc cst in - unify_pat_types loc !env (type_constant cst) expected_ty; - rp k { - pat_desc = Tpat_constant cst; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - | Ppat_interval (Pconst_char c1, Pconst_char c2) -> - let open Ast_helper.Pat in - let gloc = {loc with Location.loc_ghost=true} in - let rec loop c1 c2 = - if c1 = c2 then constant ~loc:gloc (Pconst_char c1) - else - or_ ~loc:gloc - (constant ~loc:gloc (Pconst_char c1)) - (loop (c1 + 1) c2) - in - let p = if c1 <= c2 then loop c1 c2 else loop c2 c1 in - let p = {p with ppat_loc=loc} in - type_pat ~explode:0 p expected_ty k - (* TODO: record 'extra' to remember about interval *) - | Ppat_interval _ -> - raise (Error (loc, !env, Invalid_interval)) - | Ppat_tuple spl -> - assert (List.length spl >= 2); - let spl_ann = List.map (fun p -> (p,newvar ())) spl in - let ty = newty (Ttuple(List.map snd spl_ann)) in - unify_pat_types loc !env ty expected_ty; - map_fold_cont (fun (p,t) -> type_pat p t) spl_ann (fun pl -> - rp k { - pat_desc = Tpat_tuple pl; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_construct(lid, sarg) -> - let opath = - try - let (p0, p, _) = extract_concrete_variant !env expected_ty in - Some (p0, p) - with Not_found -> None - in - let candidates = - match lid.txt, constrs with - Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> - [Hashtbl.find constrs s, (fun () -> ())] - | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt - in - let check_lk tpath constr = - if constr.cstr_generalized then - raise (Error (lid.loc, !env, - Unqualified_gadt_pattern (tpath, constr.cstr_name))) - in - let constr = - wrap_disambiguate "This variant pattern is expected to have" expected_ty - (Constructor.disambiguate lid !env opath ~check_lk) candidates - in - if constr.cstr_generalized && constrs <> None && mode = Inside_or - then raise Need_backtrack; - Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; - Builtin_attributes.check_deprecated loc constr.cstr_attributes - constr.cstr_name; - if no_existentials && constr.cstr_existentials <> [] then - raise (Error (loc, !env, Unexpected_existential)); - (* if constructor is gadt, we must verify that the expected type has the - correct head *) - if constr.cstr_generalized then - unify_head_only loc !env expected_ty constr; - let sargs = - match sarg with - None -> [] - | Some {ppat_desc = Ppat_tuple spl} when - constr.cstr_arity > 1 || - Builtin_attributes.explicit_arity sp.ppat_attributes - -> spl - | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> - if constr.cstr_arity = 0 then - Location.prerr_warning sp.ppat_loc - Warnings.Wildcard_arg_to_constant_constr; - replicate_list sp constr.cstr_arity - | Some sp -> [sp] in - begin match sargs with - | [{ppat_desc = Ppat_constant _} as sp] - when Builtin_attributes.warn_on_literal_pattern - constr.cstr_attributes -> - Location.prerr_warning sp.ppat_loc - Warnings.Fragile_literal_pattern - | _ -> () - end; - if List.length sargs <> constr.cstr_arity then - raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt, - constr.cstr_arity, List.length sargs))); - let (ty_args, ty_res) = - instance_constructor ~in_pattern:(env, get_newtype_level ()) constr - in - (* PR#7214: do not use gadt unification for toplevel lets *) - if not constr.cstr_generalized || mode = Inside_or || no_existentials - then unify_pat_types loc !env ty_res expected_ty - else unify_pat_types_gadt loc env ty_res expected_ty; - - let rec check_non_escaping p = - match p.ppat_desc with - | Ppat_or (p1, p2) -> - check_non_escaping p1; - check_non_escaping p2 - | Ppat_alias (p, _) -> - check_non_escaping p - | Ppat_constraint _ -> - raise (Error (p.ppat_loc, !env, Inlined_record_escape)) - | _ -> - () - in - if constr.cstr_inlined <> None then List.iter check_non_escaping sargs; - - map_fold_cont (fun (p,t) -> type_pat p t) (List.combine sargs ty_args) - (fun args -> - rp k { - pat_desc=Tpat_construct(lid, constr, args); - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_variant(l, sarg) -> - let arg_type = match sarg with None -> [] | Some _ -> [newvar()] in - let row = { row_fields = - [l, Reither(sarg = None, arg_type, true, ref None)]; - row_bound = (); - row_closed = false; - row_more = newvar (); - row_fixed = false; - row_name = None } in - (* PR#7404: allow some_other_tag blindly, as it would not unify with - the abstract row variable *) - if l = Parmatch.some_other_tag then assert (constrs <> None) - else unify_pat_types loc !env (newty (Tvariant row)) expected_ty; - let k arg = - rp k { - pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - in begin - (* PR#6235: propagate type information *) - match sarg, arg_type with - Some p, [ty] -> type_pat p ty (fun p -> k (Some p)) - | _ -> k None - end - | Ppat_record(lid_sp_list, closed) -> - let opath, record_ty = - try - let (p0, p, _, _) = extract_concrete_record !env expected_ty in - Some (p0, p), expected_ty - with Not_found -> None, newvar () - in - let process_optional_label (ld, pat) = - let exp_optional_attr = check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc in - let isFromPamatch = match pat.ppat_desc with - | Ppat_construct ({txt = Lident s}, _) -> - String.length s >= 2 && s.[0] = '#' && s.[1] = '$' - | _ -> false - in - if label_is_optional ld && not exp_optional_attr && not isFromPamatch then - let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in - Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat) - else pat - in - let type_label_pat (label_lid, label, sarg) k = - let sarg = process_optional_label (label, sarg) in - begin_def (); - let (vars, ty_arg, ty_res) = instance_label false label in - if vars = [] then end_def (); - begin try - unify_pat_types loc !env ty_res record_ty - with Unify trace -> - raise(Error(label_lid.loc, !env, - Label_mismatch(label_lid.txt, trace))) - end; - type_pat sarg ty_arg (fun arg -> - if vars <> [] then begin - end_def (); - generalize ty_arg; - List.iter generalize vars; - let instantiated tv = - let tv = expand_head !env tv in - not (is_Tvar tv) || tv.level <> generic_level in - if List.exists instantiated vars then - raise - (Error(label_lid.loc, !env, Polymorphic_label label_lid.txt)) - end; - k (label_lid, label, arg)) - in - let k' k lbl_pat_list = - check_recordpat_labels loc lbl_pat_list closed; - unify_pat_types loc !env record_ty expected_ty; - rp k { - pat_desc = Tpat_record (lbl_pat_list, closed); - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - in - if constrs = None then - k (wrap_disambiguate "This record pattern is expected to have" - expected_ty - (type_label_a_list ?labels loc false !env type_label_pat opath - lid_sp_list) - (k' (fun x -> x))) - else - type_label_a_list ?labels loc false !env type_label_pat opath - lid_sp_list (k' k) - | Ppat_array spl -> - let ty_elt = newvar() in - unify_pat_types - loc !env (instance_def (Predef.type_array ty_elt)) expected_ty; - let spl_ann = List.map (fun p -> (p,newvar())) spl in - map_fold_cont (fun (p,_) -> type_pat p ty_elt) spl_ann (fun pl -> - rp k { - pat_desc = Tpat_array pl; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_or(sp1, sp2) -> - let state = save_state env in - begin match - if mode = Split_or || mode = Splitting_or then raise Need_backtrack; - let initial_pattern_variables = !pattern_variables in - let initial_module_variables = !module_variables in - let p1 = - try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x)) - with Need_backtrack -> None in - let p1_variables = !pattern_variables in - let p1_module_variables = !module_variables in - pattern_variables := initial_pattern_variables; - module_variables := initial_module_variables; - let p2 = - try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x)) - with Need_backtrack -> None in - let p2_variables = !pattern_variables in - match p1, p2 with - None, None -> raise Need_backtrack - | Some p, None | None, Some p -> p (* no variables in this case *) - | Some p1, Some p2 -> - let alpha_env = - enter_orpat_variables loc !env p1_variables p2_variables in - pattern_variables := p1_variables; - module_variables := p1_module_variables; - { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None); - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env } - with - p -> rp k p - | exception Need_backtrack when mode <> Inside_or -> - assert (constrs <> None); - set_state state env; - let mode = - if mode = Split_or then mode else Splitting_or in - try type_pat ~mode sp1 expected_ty k with Error _ -> - set_state state env; - type_pat ~mode sp2 expected_ty k - end - | Ppat_lazy sp1 -> - let nv = newvar () in - unify_pat_types loc !env (instance_def (Predef.type_lazy_t nv)) - expected_ty; - (* do not explode under lazy: PR#7421 *) - type_pat ~explode:0 sp1 nv (fun p1 -> - rp k { - pat_desc = Tpat_lazy p1; - pat_loc = loc; pat_extra=[]; - pat_type = expected_ty; - pat_attributes = sp.ppat_attributes; - pat_env = !env }) - | Ppat_constraint(sp, sty) -> - (* Separate when not already separated by !principal *) - let separate = true in - if separate then begin_def(); - let cty, force = Typetexp.transl_simple_type_delayed !env sty in - let ty = cty.ctyp_type in - let ty, expected_ty' = - if separate then begin - end_def(); - generalize_structure ty; - instance !env ty, instance !env ty - end else ty, ty - in - unify_pat_types loc !env ty expected_ty; - type_pat sp expected_ty' (fun p -> - (*Format.printf "%a@.%a@." - Printtyp.raw_type_expr ty - Printtyp.raw_type_expr p.pat_type;*) - pattern_force := force :: !pattern_force; - let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in - let p = - if not separate then p else - match p.pat_desc with - Tpat_var (id,s) -> - {p with pat_type = ty; - pat_desc = Tpat_alias - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); - pat_extra = [extra]; - } - | _ -> {p with pat_type = ty; - pat_extra = extra :: p.pat_extra} - in k p) - | Ppat_type lid -> - let (path, p,ty) = build_or_pat !env loc lid in - unify_pat_types loc !env ty expected_ty; - k { p with pat_extra = - (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } - | Ppat_open (lid,p) -> - let path, new_env = - !type_open Asttypes.Fresh !env sp.ppat_loc lid in - let new_env = ref new_env in - type_pat ~env:new_env p expected_ty ( fun p -> - env := Env.copy_local !env ~from:!new_env; - k { p with pat_extra =( Tpat_open (path,lid,!new_env), - loc, sp.ppat_attributes) :: p.pat_extra } - ) - | Ppat_exception _ -> - raise (Error (loc, !env, Exception_pattern_below_toplevel)) - | Ppat_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - -let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal) - ?(explode=0) ?(lev=get_current_level()) env sp expected_ty = - newtype_level := Some lev; - try - let r = - type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels - ~mode ~explode ~env sp expected_ty (fun x -> x) in - iter_pattern (fun p -> p.pat_env <- !env) r; - newtype_level := None; - r - with e -> - newtype_level := None; - raise e - - -(* this function is passed to Partial.parmatch - to type check gadt nonexhaustiveness *) -let partial_pred ~lev ?mode ?explode env expected_ty constrs labels p = - let env = ref env in - let state = save_state env in - try - reset_pattern None true; - let typed_p = - Ctype.with_passive_variants - (type_pat ~allow_existentials:true ~lev - ~constrs ~labels ?mode ?explode env p) - expected_ty - in - set_state state env; - (* types are invalidated but we don't need them here *) - Some typed_p - with Error _ -> - set_state state env; - None - -let check_partial ?(lev=get_current_level ()) env expected_ty loc cases = - let explode = match cases with [_] -> 5 | _ -> 0 in - Parmatch.check_partial_gadt - (partial_pred ~lev ~explode env expected_ty) loc cases - -let check_unused ?(lev=get_current_level ()) env expected_ty cases = - Parmatch.check_unused - (fun refute constrs labels spat -> - match - partial_pred ~lev ~mode:Split_or ~explode:5 - env expected_ty constrs labels spat - with - Some pat when refute -> - raise (Error (spat.ppat_loc, env, Unrefuted_pattern pat)) - | r -> r) - cases - -let add_pattern_variables ?check ?check_as env = - let pv = get_ref pattern_variables in - (List.fold_right - (fun (id, ty, _name, loc, as_var) env -> - let check = if as_var then check_as else check in - Env.add_value ?check id - {val_type = ty; val_kind = Val_reg; Types.val_loc = loc; - val_attributes = []; - } env - ) - pv env, - get_ref module_variables) - -let type_pattern ~lev env spat scope expected_ty = - reset_pattern scope true; - let new_env = ref env in - let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in - let new_env, unpacks = - add_pattern_variables !new_env - ~check:(fun s -> Warnings.Unused_var_strict s) - ~check_as:(fun s -> Warnings.Unused_var s) in - (pat, new_env, get_ref pattern_force, unpacks) - -let type_pattern_list env spatl scope expected_tys allow = - reset_pattern scope allow; - let new_env = ref env in - let type_pat (attrs, pat) ty = - Builtin_attributes.warning_scope ~ppwarning:false attrs - (fun () -> - type_pat new_env pat ty - ) - in - let patl = List.map2 type_pat spatl expected_tys in - let new_env, unpacks = add_pattern_variables !new_env in - (patl, new_env, get_ref pattern_force, unpacks) - - - - -let rec final_subexpression sexp = - match sexp.pexp_desc with - Pexp_let (_, _, e) - | Pexp_sequence (_, e) - | Pexp_try (e, _) - | Pexp_ifthenelse (_, e, _) - | Pexp_match (_, {pc_rhs=e} :: _) - -> final_subexpression e - | _ -> sexp - -(* Generalization criterion for expressions *) - -let rec is_nonexpansive exp = - List.exists (function (({txt = "internal.expansive"},_) : Parsetree.attribute) -> true | _ -> false) - exp.exp_attributes || - match exp.exp_desc with - Texp_ident(_,_,_) -> true - | Texp_constant _ -> true - | Texp_let(_rec_flag, pat_exp_list, body) -> - List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list && - is_nonexpansive body - | Texp_function _ -> true - | Texp_apply(e, (_,None)::el) -> - is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el) - | Texp_match(e, cases, [], _) -> - is_nonexpansive e && - List.for_all - (fun {c_lhs = _; c_guard; c_rhs} -> - is_nonexpansive_opt c_guard && is_nonexpansive c_rhs - ) cases - | Texp_tuple el -> - List.for_all is_nonexpansive el - | Texp_construct( _, _, el) -> - List.for_all is_nonexpansive el - | Texp_variant(_, arg) -> is_nonexpansive_opt arg - | Texp_record { fields; extended_expression } -> - Array.for_all - (fun (lbl, definition) -> - match definition with - | Overridden (_, exp) -> - lbl.lbl_mut = Immutable && is_nonexpansive exp - | Kept _ -> true) - fields - && is_nonexpansive_opt extended_expression - | Texp_field(exp, _, _) -> is_nonexpansive exp - | Texp_array [] -> !Config.unsafe_empty_array - | Texp_ifthenelse(_cond, ifso, ifnot) -> - is_nonexpansive ifso && is_nonexpansive_opt ifnot - | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) - | Texp_new _ -> - assert false - (* Note: nonexpansive only means no _observable_ side effects *) - | Texp_lazy e -> is_nonexpansive e - | Texp_object () -> - assert false - | Texp_letmodule (_, _, mexp, e) -> - is_nonexpansive_mod mexp && is_nonexpansive e - | Texp_pack mexp -> - is_nonexpansive_mod mexp - (* Computations which raise exceptions are nonexpansive, since (raise e) is equivalent - to (raise e; diverge), and a nonexpansive "diverge" can be produced using lazy values - or the relaxed value restriction. See GPR#1142 *) - | Texp_assert exp -> - is_nonexpansive exp - | Texp_apply ( - { exp_desc = Texp_ident (_, _, {val_kind = - Val_prim {Primitive.prim_name = "%raise"}}) }, - [Nolabel, Some e]) -> - is_nonexpansive e - | _ -> false - -and is_nonexpansive_mod mexp = - match mexp.mod_desc with - | Tmod_ident _ -> true - | Tmod_functor _ -> true - | Tmod_unpack (e, _) -> is_nonexpansive e - | Tmod_constraint (m, _, _, _) -> is_nonexpansive_mod m - | Tmod_structure str -> - List.for_all - (fun item -> match item.str_desc with - | Tstr_eval _ | Tstr_primitive _ | Tstr_type _ - | Tstr_modtype _ | Tstr_open _ | Tstr_class_type _ -> true - | Tstr_value (_, pat_exp_list) -> - List.for_all (fun vb -> is_nonexpansive vb.vb_expr) pat_exp_list - | Tstr_module {mb_expr=m;_} - | Tstr_include {incl_mod=m;_} -> is_nonexpansive_mod m - | Tstr_recmodule id_mod_list -> - List.for_all (fun {mb_expr=m;_} -> is_nonexpansive_mod m) - id_mod_list - | Tstr_exception {ext_kind = Text_decl _} -> - false (* true would be unsound *) - | Tstr_exception {ext_kind = Text_rebind _} -> true - | Tstr_typext te -> - List.for_all - (function {ext_kind = Text_decl _} -> false - | {ext_kind = Text_rebind _} -> true) - te.tyext_constructors - | Tstr_class _ -> false (* could be more precise *) - | Tstr_attribute _ -> true - ) - str.str_items - | Tmod_apply _ -> false - -and is_nonexpansive_opt = function - None -> true - | Some e -> is_nonexpansive e - - - - -(* Approximate the type of an expression, for better recursion *) - -let rec approx_type env sty = - match sty.ptyp_desc with - Ptyp_arrow (p, _, sty) -> - let ty1 = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow (p, ty1, approx_type env sty, Cok)) - | Ptyp_tuple args -> - newty (Ttuple (List.map (approx_type env) args)) - | Ptyp_constr (lid, ctl) -> - begin try - let path = Env.lookup_type lid.txt env in - let decl = Env.find_type path env in - if List.length ctl <> decl.type_arity then raise Not_found; - let tyl = List.map (approx_type env) ctl in - newconstr path tyl - with Not_found -> newvar () - end - | Ptyp_poly (_, sty) -> - approx_type env sty - | _ -> newvar () - -let rec type_approx env sexp = - match sexp.pexp_desc with - Pexp_let (_, _, e) -> type_approx env e - | Pexp_fun (p, _, _, e) -> - let ty = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow(p, ty, type_approx env e, Cok)) - | Pexp_function ({pc_rhs=e}::_) -> - newty (Tarrow(Nolabel, newvar (), type_approx env e, Cok)) - | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e - | Pexp_try (e, _) -> type_approx env e - | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) - | Pexp_ifthenelse (_,e,_) -> type_approx env e - | Pexp_sequence (_,e) -> type_approx env e - | Pexp_constraint (e, sty) -> - let ty = type_approx env e in - let ty1 = approx_type env sty in - begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None))) - end; - ty1 - | Pexp_coerce (e, sty1, sty2) -> - let approx_ty_opt = function - | None -> newvar () - | Some sty -> approx_type env sty - in - let ty = type_approx env e - and ty1 = approx_ty_opt sty1 - and ty2 = approx_type env sty2 in - begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None))) - end; - ty2 - | _ -> newvar () - -(* List labels in a function type, and whether return type is a variable *) -let rec list_labels_aux env visited ls ty_fun = - let ty = expand_head env ty_fun in - if List.memq ty visited then - List.rev ls, false - else match ty.desc with - Tarrow (l, _, ty_res, _) -> - list_labels_aux env (ty::visited) (l::ls) ty_res - | _ -> - List.rev ls, is_Tvar ty - -let list_labels env ty = - wrap_trace_gadt_instances env (list_labels_aux env [] []) ty - -(* Check that all univars are safe in a type *) -let check_univars env expans kind exp ty_expected vars = - if expans && not (is_nonexpansive exp) then - generalize_expansive env exp.exp_type; - (* need to expand twice? cf. Ctype.unify2 *) - let vars = List.map (expand_head env) vars in - let vars = List.map (expand_head env) vars in - let vars' = - Ext_list.filter vars - (fun t -> - let t = repr t in - generalize t; - match t.desc with - Tvar name when t.level = generic_level -> - log_type t; t.desc <- Tunivar name; true - | _ -> false) - in - if List.length vars = List.length vars' then () else - let ty = newgenty (Tpoly(repr exp.exp_type, vars')) - and ty_expected = repr ty_expected in - raise (Error (exp.exp_loc, env, - Less_general(kind, [ty, ty; ty_expected, ty_expected]))) - -(* Check that a type is not a function *) -let check_application_result env statement exp = - let loc = exp.exp_loc in - match (expand_head env exp.exp_type).desc with - | Tarrow _ -> - Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar _ -> () - | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () - | _ -> - if statement then - Location.prerr_warning loc Warnings.Statement_type - -(* Check that a type is generalizable at some level *) -let generalizable level ty = - let rec check ty = - let ty = repr ty in - if ty.level < lowest_level then () else - if ty.level <= level then raise Exit else - (mark_type_node ty; iter_type_expr check ty) - in - try check ty; unmark_type ty; true - with Exit -> unmark_type ty; false - -(* Hack to allow coercion of self. Will clean-up later. *) -let self_coercion = ref ([] : (Path.t * Location.t list ref) list) - -(* Helpers for packaged modules. *) -let create_package_type loc env (p, l) = - let s = !Typetexp.transl_modtype_longident loc env p in - let fields = List.map (fun (name, ct) -> - name, Typetexp.transl_simple_type env false ct) l in - let ty = newty (Tpackage (s, - List.map fst l, - List.map (fun (_, cty) -> cty.ctyp_type) fields)) - in - (s, fields, ty) - - let wrap_unpacks sexp unpacks = - let open Ast_helper in - List.fold_left - (fun sexp (name, loc) -> - Exp.letmodule ~loc:sexp.pexp_loc ~attrs:[mknoloc "#modulepat",PStr []] - name - (Mod.unpack ~loc - (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt) - name.loc))) - sexp - ) - sexp unpacks - -(* Helpers for type_cases *) - -let contains_variant_either ty = - let rec loop ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - mark_type_node ty; - match ty.desc with - Tvariant row -> - let row = row_repr row in - if not row.row_fixed then - List.iter - (fun (_,f) -> - match row_field_repr f with Reither _ -> raise Exit | _ -> ()) - row.row_fields; - iter_row loop row - | _ -> - iter_type_expr loop ty - end - in - try loop ty; unmark_type ty; false - with Exit -> unmark_type ty; true - -let iter_ppat f p = - match p.ppat_desc with - | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ - | Ppat_extension _ - | Ppat_type _ | Ppat_unpack _ -> () - | Ppat_array pats -> List.iter f pats - | Ppat_or (p1,p2) -> f p1; f p2 - | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg - | Ppat_tuple lst -> List.iter f lst - | Ppat_exception p | Ppat_alias (p,_) - | Ppat_open (_,p) - | Ppat_constraint (p,_) | Ppat_lazy p -> f p - | Ppat_record (args, _flag) -> List.iter (fun (_,p) -> f p) args - -let contains_polymorphic_variant p = - let rec loop p = - match p.ppat_desc with - Ppat_variant _ | Ppat_type _ -> raise Exit - | _ -> iter_ppat loop p - in - try loop p; false with Exit -> true - -let contains_gadt env p = - let rec loop env p = - match p.ppat_desc with - | Ppat_construct (lid, _) -> - begin try - let cstrs = Env.lookup_all_constructors lid.txt env in - List.iter (fun (cstr,_) -> if cstr.cstr_generalized then raise_notrace Exit) - cstrs - with Not_found -> () - end; iter_ppat (loop env) p - | Ppat_open (lid,sub_p) -> - let _, new_env = !type_open Asttypes.Override env p.ppat_loc lid in - loop new_env sub_p - | _ -> iter_ppat (loop env) p - in - try loop env p; false with Exit -> true - -let check_absent_variant env = - iter_pattern - (function {pat_desc = Tpat_variant (s, arg, row)} as pat -> - let row = row_repr !row in - if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) - row.row_fields - || not row.row_fixed && not (static_row row) (* same as Ctype.poly *) - then () else - let ty_arg = - match arg with None -> [] | Some p -> [correct_levels p.pat_type] in - let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)]; - row_more = newvar (); row_bound = (); - row_closed = false; row_fixed = false; row_name = None} in - (* Should fail *) - unify_pat env {pat with pat_type = newty (Tvariant row')} - (correct_levels pat.pat_type) - | _ -> ()) - -(* Duplicate types of values in the environment *) -(* XXX Should we do something about global type variables too? *) - -let duplicate_ident_types caselist env = - let caselist = - Ext_list.filter caselist (fun {pc_lhs} -> contains_gadt env pc_lhs) in - Env.copy_types (all_idents_cases caselist) env - - -(* type_label_a_list returns a list of labels sorted by lbl_pos *) -(* note: check_duplicates would better be implemented in - type_label_a_list directly *) -let rec check_duplicates loc env = function - | (_, lbl1, _) :: (_, lbl2, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos -> - raise(Error(loc, env, Label_multiply_defined lbl1.lbl_name)) - | _ :: rem -> - check_duplicates loc env rem - | [] -> () -(* Getting proper location of already typed expressions. - - Used to avoid confusing locations on type error messages in presence of - type constraints. - For example: - - (* Before patch *) - # let x : string = (5 : int);; - ^ - (* After patch *) - # let x : string = (5 : int);; - ^^^^^^^^^ -*) -let proper_exp_loc exp = - let rec aux = function - | [] -> exp.exp_loc - | ((Texp_constraint _ | Texp_coerce _), loc, _) :: _ -> loc - | _ :: rest -> aux rest - in - aux exp.exp_extra - -let id_of_pattern : Typedtree.pattern -> Ident.t option = fun pat -> - match pat.pat_desc with - | Tpat_var (id, _) -> Some id - | Tpat_alias(_, id, _) -> Some id - | Tpat_construct (_,_, - [{pat_desc = (Tpat_var (id,_) | Tpat_alias(_,id,_))}]) - -> Some (Ident.rename id) - | _ -> None -(* To find reasonable names for let-bound and lambda-bound idents *) - -let rec name_pattern default = function - [] -> Ident.create default - | {c_lhs=p; _} :: rem -> - match id_of_pattern p with - | None -> name_pattern default rem - | Some id -> id - -(* Typing of expressions *) - -let unify_exp ?typeClashContext env exp expected_ty = - let loc = proper_exp_loc exp in - unify_exp_types ?typeClashContext loc env exp.exp_type expected_ty - - -let is_ignore funct env = - match funct.exp_desc with - Texp_ident (_, _, {val_kind=Val_prim{Primitive.prim_name="%ignore"}}) -> - (try ignore (filter_arrow env (instance env funct.exp_type) Nolabel); - true - with Unify _ -> false) - | _ -> false - -let not_identity = function - | Texp_ident(_,_,{val_kind=Val_prim - {Primitive.prim_name="%identity"}}) -> - false - | _ -> true - -let rec lower_args env seen ty_fun = - let ty = expand_head env ty_fun in - if List.memq ty seen then () else - match ty.desc with - Tarrow (_l, ty_arg, ty_fun, _com) -> - (try unify_var env (newvar()) ty_arg with Unify _ -> assert false); - lower_args env (ty::seen) ty_fun - | _ -> () - -let not_function env ty = - let ls, tvar = list_labels env ty in - ls = [] && not tvar - -let check_might_be_component env ty_record = - match (expand_head env ty_record).desc with - | Tconstr (path, _, _) when path |> Path.last = "props" -> true - | _ -> false - -type lazy_args = - (Asttypes.arg_label * (unit -> Typedtree.expression) option) list - -type targs = - (Asttypes.arg_label * Typedtree.expression option) list -let rec type_exp ?recarg env sexp = - (* We now delegate everything to type_expect *) - type_expect ?recarg env sexp (newvar ()) - -(* Typing of an expression with an expected type. - This provide better error messages, and allows controlled - propagation of return type information. - In the principal case, [type_expected'] may be at generic_level. - *) - -and type_expect ?typeClashContext ?in_function ?recarg env sexp ty_expected = - let previous_saved_types = Cmt_format.get_saved_types () in - let exp = - Builtin_attributes.warning_scope sexp.pexp_attributes - (fun () -> - type_expect_ ?typeClashContext ?in_function ?recarg env sexp ty_expected - ) - in - Cmt_format.set_saved_types - (Cmt_format.Partial_expression exp :: previous_saved_types); - exp - -and type_expect_ ?typeClashContext ?in_function ?(recarg=Rejected) env sexp ty_expected = - let loc = sexp.pexp_loc in - (* Record the expression type before unifying it with the expected type *) - let rue exp = - unify_exp ?typeClashContext env (re exp) (instance env ty_expected); - exp - in - let process_optional_label (id, ld, e) = - let exp_optional_attr = check_optional_attr env ld e.pexp_attributes e.pexp_loc in - if label_is_optional ld && not exp_optional_attr then - let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in - let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) - in (id, ld, e) - else (id, ld, e) - in - match sexp.pexp_desc with - | Pexp_ident lid -> - begin - let (path, desc) = Typetexp.find_value env lid.loc lid.txt in - if !Clflags.annotations then begin - let dloc = desc.Types.val_loc in - let annot = - if dloc.Location.loc_ghost then Annot.Iref_external - else Annot.Iref_internal dloc - in - let name = Path.name ~paren:Oprint.parenthesized_ident path in - Stypes.record (Stypes.An_ident (loc, name, annot)) - end; - let is_recarg = - match (repr desc.val_type).desc with - | Tconstr(p, _, _) -> Path.is_constructor_typath p - | _ -> false - in - - begin match is_recarg, recarg, (repr desc.val_type).desc with - | _, Allowed, _ - | true, Required, _ - | false, Rejected, _ - -> () - | true, Rejected, _ - | false, Required, (Tvar _ | Tconstr _) -> - raise (Error (loc, env, Inlined_record_escape)) - | false, Required, _ -> - () (* will fail later *) - end; - rue { - exp_desc = Texp_ident(path, lid, desc); - exp_loc = loc; exp_extra = []; - exp_type = instance env desc.val_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - end - | Pexp_constant cst -> - let cst = constant_or_raise env loc cst in - rue { - exp_desc = Texp_constant cst; - exp_loc = loc; exp_extra = []; - exp_type = type_constant cst; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_let(Nonrecursive, - [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody) - when contains_gadt env spat -> - (* TODO: allow non-empty attributes? *) - type_expect ?in_function env - {sexp with - pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])} - ty_expected - | Pexp_let(rec_flag, spat_sexp_list, sbody) -> - let scp = - match sexp.pexp_attributes, rec_flag with - | [{txt="#default"},_], _ -> None - | _, Recursive -> Some (Annot.Idef loc) - | _, Nonrecursive -> Some (Annot.Idef sbody.pexp_loc) - in - let (pat_exp_list, new_env, unpacks) = - type_let env rec_flag spat_sexp_list scp true in - let body = - type_expect new_env (wrap_unpacks sbody unpacks) ty_expected in - let () = - if rec_flag = Recursive then - Rec_check.check_recursive_bindings pat_exp_list - in - re { - exp_desc = Texp_let(rec_flag, pat_exp_list, body); - exp_loc = loc; exp_extra = []; - exp_type = body.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_fun (l, Some default, spat, sbody) -> - assert(is_optional l); (* default allowed only with optional argument *) - let open Ast_helper in - let default_loc = default.pexp_loc in - let scases = [ - Exp.case - (Pat.construct ~loc:default_loc - (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) - (Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))) - (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"))); - - Exp.case - (Pat.construct ~loc:default_loc - (mknoloc (Longident.(Ldot (Lident "*predef*", "None")))) - None) - default; - ] - in - let sloc = - { Location.loc_start = spat.ppat_loc.Location.loc_start; - loc_end = default_loc.Location.loc_end; - loc_ghost = true } - in - let smatch = - Exp.match_ ~loc:sloc - (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) - scases - in - let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in - let body = - Exp.let_ ~loc Nonrecursive ~attrs:[mknoloc "#default",PStr []] - [Vb.mk spat smatch] sbody - in - type_function ?in_function loc sexp.pexp_attributes env ty_expected - l [Exp.case pat body] - | Pexp_fun (l, None, spat, sbody) -> - type_function ?in_function loc sexp.pexp_attributes env ty_expected - l [Ast_helper.Exp.case spat sbody] - | Pexp_function caselist -> - type_function ?in_function - loc sexp.pexp_attributes env ty_expected Nolabel caselist - | Pexp_apply(sfunct, sargs) -> - assert (sargs <> []); - begin_def (); (* one more level for non-returning functions *) - let funct = type_exp env sfunct in - let ty = instance env funct.exp_type in - end_def (); - wrap_trace_gadt_instances env (lower_args env []) ty; - begin_def (); - let uncurried = - Ext_list.exists sexp.pexp_attributes (fun ({txt },_) -> txt = "res.uapp") - && not @@ Ext_list.exists sexp.pexp_attributes (fun ({txt },_) -> txt = "res.partial") - && not @@ is_automatic_curried_application env funct in - let typeClashContext = typeClashContextFromFunction sexp sfunct in - let (args, ty_res, fully_applied) = type_application ?typeClashContext uncurried env funct sargs in - end_def (); - unify_var env (newvar()) funct.exp_type; - - let mk_exp ?(loc=Location.none) exp_desc exp_type = - { exp_desc; - exp_loc = loc; exp_extra = []; - exp_type; - exp_attributes = []; - exp_env = env } in - let apply_internal name e = - let lid:Longident.t = Ldot (Ldot (Lident "Js", "Internal"), name) in - let (path, desc) = Env.lookup_value lid env in - let id = mk_exp (Texp_ident(path, {txt=lid; loc=Location.none}, desc)) desc.val_type in - mk_exp ~loc:e.exp_loc (Texp_apply(id, [(Nolabel, Some e)])) e.exp_type in - - let mk_apply funct args = - rue { - exp_desc = Texp_apply(funct, args); - exp_loc = loc; exp_extra = []; - exp_type = ty_res; - exp_attributes = sexp.pexp_attributes; - exp_env = env } in - - let is_primitive = match funct.exp_desc with - | Texp_ident (_, _, {val_kind = Val_prim _}) -> true - | _ -> false in - - if fully_applied && not is_primitive then - rue (apply_internal "opaqueFullApply" (mk_apply (apply_internal "opaque" funct) args)) - else - rue (mk_apply funct args) - | Pexp_match(sarg, caselist) -> - begin_def (); - let arg = type_exp env sarg in - end_def (); - if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type; - generalize arg.exp_type; - let rec split_cases vc ec = function - | [] -> List.rev vc, List.rev ec - | {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest -> - split_cases vc ({c with pc_lhs = p} :: ec) rest - | c :: rest -> - split_cases (c :: vc) ec rest - in - let val_caselist, exn_caselist = split_cases [] [] caselist in - if val_caselist = [] && exn_caselist <> [] then - raise (Error (loc, env, No_value_clauses)); - (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully - empty pattern matching can be generated by Camlp4 with its - revised syntax. Let's accept it for backward compatibility. *) - let val_cases, partial = - type_cases ~rootTypeClashContext:Switch env arg.exp_type ty_expected true loc val_caselist in - let exn_cases, _ = - type_cases ~rootTypeClashContext:Switch env Predef.type_exn ty_expected false loc exn_caselist in - re { - exp_desc = Texp_match(arg, val_cases, exn_cases, partial); - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_try(sbody, caselist) -> - let body = type_expect env sbody ty_expected in - let cases, _ = - type_cases env Predef.type_exn ty_expected false loc caselist in - re { - exp_desc = Texp_try(body, cases); - exp_loc = loc; exp_extra = []; - exp_type = body.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_tuple sexpl -> - assert (List.length sexpl >= 2); - let subtypes = List.map (fun _ -> newgenvar ()) sexpl in - let to_unify = newgenty (Ttuple subtypes) in - unify_exp_types loc env to_unify ty_expected; - let expl = - List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes - in - re { - exp_desc = Texp_tuple expl; - exp_loc = loc; exp_extra = []; - (* Keep sharing *) - exp_type = newty (Ttuple (List.map (fun e -> e.exp_type) expl)); - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_construct({txt = Lident "Function$"} as lid, sarg) -> - let state = Warnings.backup () in - let arity = Ast_uncurried.attributes_to_arity sexp.pexp_attributes in - let uncurried_typ = Ast_uncurried.make_uncurried_type ~env ~arity (newvar()) in - unify_exp_types loc env uncurried_typ ty_expected; - (* Disable Unerasable_optional_argument for uncurried functions *) - let unerasable_optional_argument = Warnings.number Unerasable_optional_argument in - Warnings.parse_options false ("-" ^ string_of_int unerasable_optional_argument); - let exp = type_construct env loc lid sarg uncurried_typ sexp.pexp_attributes in - Warnings.restore state; - exp - | Pexp_construct(lid, sarg) -> - type_construct env loc lid sarg ty_expected sexp.pexp_attributes - | Pexp_variant(l, sarg) -> - (* Keep sharing *) - let ty_expected0 = instance env ty_expected in - begin try match - sarg, expand_head env ty_expected, expand_head env ty_expected0 with - | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> - let row = row_repr row in - begin match row_field_repr (List.assoc l row.row_fields), - row_field_repr (List.assoc l row0.row_fields) with - Rpresent (Some ty), Rpresent (Some ty0) -> - let arg = type_argument env sarg ty ty0 in - re { exp_desc = Texp_variant(l, Some arg); - exp_loc = loc; exp_extra = []; - exp_type = ty_expected0; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | _ -> raise Not_found - end - | _ -> raise Not_found - with Not_found -> - let arg = may_map (type_exp env) sarg in - let arg_type = may_map (fun arg -> arg.exp_type) arg in - rue { - exp_desc = Texp_variant(l, arg); - exp_loc = loc; exp_extra = []; - exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; - row_more = newvar (); - row_bound = (); - row_closed = false; - row_fixed = false; - row_name = None}); - exp_attributes = sexp.pexp_attributes; - exp_env = env } - end - | Pexp_record(lid_sexp_list, None) -> - let ty_record, opath, fields, repr_opt = - match extract_concrete_record env ty_expected with - | (p0, p, fields, repr) -> - (* XXX level may be wrong *) - ty_expected, Some (p0, p), fields, Some repr - | exception Not_found -> - newvar (), None, [], None - - in - let lbl_exp_list = - wrap_disambiguate "This record expression is expected to have" ty_record - (type_label_a_list loc true env - (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e))) - opath lid_sexp_list) - (fun x -> x) - in - unify_exp_types loc env ty_record (instance env ty_expected); - check_duplicates loc env lbl_exp_list; - let label_descriptions, representation = match lbl_exp_list, repr_opt with - | (_, { lbl_all = label_descriptions; lbl_repres = representation}, _) :: _, _ -> label_descriptions, representation - | [], Some (representation) when lid_sexp_list = [] -> - let optional_labels = match representation with - | Record_optional_labels optional_labels -> optional_labels - | Record_inlined {optional_labels} -> optional_labels - | _ -> [] in - let filter_missing (ld : Types.label_declaration) = - let name = Ident.name ld.ld_id in - if List.mem name optional_labels then - None - else - Some name in - let labels_missing = fields |> List.filter_map filter_missing in - if labels_missing <> [] then ( - let might_be_component = check_might_be_component env ty_record in - raise(Error(loc, env, Labels_missing (labels_missing, might_be_component)))); - [||], representation - | [], _ -> - if fields = [] && repr_opt <> None then - [||], Record_optional_labels [] - else - raise(Error(loc, env, Empty_record_literal)) in - let labels_missing = ref [] in - let label_definitions = - let matching_label lbl = - List.find - (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos) - lbl_exp_list - in - Array.map - (fun lbl -> - match matching_label lbl with - | (lid, _lbl, lbl_exp) -> - Overridden (lid, lbl_exp) - | exception Not_found -> - if not (label_is_optional lbl) then labels_missing := lbl.lbl_name :: !labels_missing; - Overridden ({loc ; txt = Lident lbl.lbl_name}, option_none lbl.lbl_arg loc)) - label_descriptions - in - if !labels_missing <> [] then ( - let might_be_component = check_might_be_component env ty_record in - raise(Error(loc, env, Labels_missing ((List.rev !labels_missing), might_be_component)))); - let fields = - Array.map2 (fun descr def -> descr, def) - label_descriptions label_definitions - in - re { - exp_desc = Texp_record { - fields; representation; - extended_expression = None - }; - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_record(lid_sexp_list, Some sexp) -> - assert (lid_sexp_list <> []); - let exp = type_exp ~recarg env sexp in - let ty_record, opath = - let get_path ty = - try - let (p0, p, _, _) = extract_concrete_record env ty in - (* XXX level may be wrong *) - Some (p0, p) - with Not_found -> None - in - match get_path ty_expected with - None -> - begin - match get_path exp.exp_type with - None -> newvar (), None - | Some (_, p') as op -> - let decl = Env.find_type p' env in - begin_def (); - let ty = - newconstr p' (instance_list env decl.type_params) in - end_def (); - generalize_structure ty; - ty, op - end - | op -> ty_expected, op - in - let closed = false in - let lbl_exp_list = - wrap_disambiguate "This record expression is expected to have" ty_record - (type_label_a_list loc closed env - (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e))) - opath lid_sexp_list) - (fun x -> x) - in - unify_exp_types loc env ty_record (instance env ty_expected); - check_duplicates loc env lbl_exp_list; - let opt_exp, label_definitions = - let (_lid, lbl, _lbl_exp) = List.hd lbl_exp_list in - let matching_label lbl = - List.find - (fun (_, lbl',_) -> lbl'.lbl_pos = lbl.lbl_pos) - lbl_exp_list - in - let ty_exp = instance env exp.exp_type in - let unify_kept lbl = - let _, ty_arg1, ty_res1 = instance_label false lbl in - unify_exp_types exp.exp_loc env ty_exp ty_res1; - match matching_label lbl with - | lid, _lbl, lbl_exp -> - (* do not connect result types for overridden labels *) - Overridden (lid, lbl_exp) - | exception Not_found -> begin - let _, ty_arg2, ty_res2 = instance_label false lbl in - unify_exp_types loc env ty_arg1 ty_arg2; - unify_exp_types loc env (instance env ty_expected) ty_res2; - Kept ty_arg1 - end - in - let label_definitions = Array.map unify_kept lbl.lbl_all in - Some {exp with exp_type = ty_exp}, label_definitions - in - let num_fields = - match lbl_exp_list with [] -> assert false - | (_, lbl,_)::_ -> Array.length lbl.lbl_all in - let opt_exp = - if List.length lid_sexp_list = num_fields then - (Location.prerr_warning loc Warnings.Useless_record_with; None) - else opt_exp - in - let label_descriptions, representation = - let (_, { lbl_all; lbl_repres }, _) = List.hd lbl_exp_list in - lbl_all, lbl_repres - in - let fields = - Array.map2 (fun descr def -> descr, def) - label_descriptions label_definitions - in - re { - exp_desc = Texp_record { - fields; representation; - extended_expression = opt_exp - }; - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_field(srecord, lid) -> - let (record, label, _) = type_label_access env srecord lid in - let (_, ty_arg, ty_res) = instance_label false label in - unify_exp env record ty_res; - rue { - exp_desc = Texp_field(record, lid, label); - exp_loc = loc; exp_extra = []; - exp_type = ty_arg; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_setfield(srecord, lid, snewval) -> - let (record, label, opath) = type_label_access env srecord lid in - let ty_record = if opath = None then newvar () else record.exp_type in - let (label_loc, label, newval) = - type_label_exp ~typeClashContext:SetRecordField false env loc ty_record (lid, label, snewval) in - unify_exp env record ty_record; - if label.lbl_mut = Immutable then - raise(Error(loc, env, Label_not_mutable lid.txt)); - Builtin_attributes.check_deprecated_mutable lid.loc label.lbl_attributes - (Longident.last lid.txt); - rue { - exp_desc = Texp_setfield(record, label_loc, label, newval); - exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_array(sargl) -> - let ty = newgenvar() in - let to_unify = Predef.type_array ty in - unify_exp_types loc env to_unify ty_expected; - let argl = List.map (fun sarg -> type_expect ~typeClashContext:ArrayValue env sarg ty) sargl in - re { - exp_desc = Texp_array argl; - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_ifthenelse(scond, sifso, sifnot) -> - let cond = type_expect ~typeClashContext:IfCondition env scond Predef.type_bool in - begin match sifnot with - None -> - let ifso = type_expect ~typeClashContext:IfReturn env sifso Predef.type_unit in - rue { - exp_desc = Texp_ifthenelse(cond, ifso, None); - exp_loc = loc; exp_extra = []; - exp_type = ifso.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Some sifnot -> - let ifso = type_expect ~typeClashContext:IfReturn env sifso ty_expected in - let ifnot = type_expect ~typeClashContext:IfReturn env sifnot ty_expected in - (* Keep sharing *) - unify_exp ~typeClashContext:IfReturn env ifnot ifso.exp_type; - re { - exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot); - exp_loc = loc; exp_extra = []; - exp_type = ifso.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - end - | Pexp_sequence(sexp1, sexp2) -> - let exp1 = type_statement env sexp1 in - let exp2 = type_expect env sexp2 ty_expected in - re { - exp_desc = Texp_sequence(exp1, exp2); - exp_loc = loc; exp_extra = []; - exp_type = exp2.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_while(scond, sbody) -> - let cond = type_expect env scond Predef.type_bool in - let body = type_statement env sbody in - rue { - exp_desc = Texp_while(cond, body); - exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_for(param, slow, shigh, dir, sbody) -> - let low = type_expect env slow Predef.type_int in - let high = type_expect env shigh Predef.type_int in - let id, new_env = - match param.ppat_desc with - | Ppat_any -> Ident.create "_for", env - | Ppat_var {txt} -> - Env.enter_value txt {val_type = instance_def Predef.type_int; - val_attributes = []; - val_kind = Val_reg; Types.val_loc = loc; } env - ~check:(fun s -> Warnings.Unused_for_index s) - | _ -> - raise (Error (param.ppat_loc, env, Invalid_for_loop_index)) - in - let body = type_statement new_env sbody in - rue { - exp_desc = Texp_for(id, param, low, high, dir, body); - exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_unit; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_constraint (sarg, sty) -> - let separate = true in (* always separate, 1% slowdown for lablgtk *) - if separate then begin_def (); - let cty = Typetexp.transl_simple_type env false sty in - let ty = cty.ctyp_type in - let (arg, ty') = - if separate then begin - end_def (); - generalize_structure ty; - (type_argument env sarg ty (instance env ty), instance env ty) - end else - (type_argument env sarg ty ty, ty) - in - rue { - exp_desc = arg.exp_desc; - exp_loc = arg.exp_loc; - exp_type = ty'; - exp_attributes = arg.exp_attributes; - exp_env = env; - exp_extra = - (Texp_constraint cty, loc, sexp.pexp_attributes) :: arg.exp_extra; - } - | Pexp_coerce(sarg, sty, sty') -> - let separate = true in (* always separate, 1% slowdown for lablgtk *) - (* Also see PR#7199 for a problem with the following: - let separate = Env.has_local_constraints env in*) - let (arg, ty',cty,cty') = - match sty with - | None -> - let (cty', force) = - Typetexp.transl_simple_type_delayed env sty' - in - let ty' = cty'.ctyp_type in - if separate then begin_def (); - let arg = type_exp env sarg in - let gen = - if separate then begin - end_def (); - let tv = newvar () in - let gen = generalizable tv.level arg.exp_type in - (try unify_var env tv arg.exp_type with Unify trace -> - raise(Error(arg.exp_loc, env, Expr_type_clash (trace, typeClashContext)))); - gen - end else true - in - begin match arg.exp_desc, !self_coercion, (repr ty').desc with - | _ when free_variables ~env arg.exp_type = [] - && free_variables ~env ty' = [] -> - if not gen && (* first try a single coercion *) - let snap = snapshot () in - let ty, _b = enlarge_type env ty' in - try - force (); Ctype.unify env arg.exp_type ty; true - with Unify _ -> - backtrack snap; false - then () - else begin try - let force' = subtype env arg.exp_type ty' in - force (); force' (); - with Subtype (tr1, tr2) -> - (* prerr_endline "coercion failed"; *) - raise(Error(loc, env, Not_subtype(tr1, tr2))) - end; - | _ -> - let ty, b = enlarge_type env ty' in - force (); - begin try Ctype.unify env arg.exp_type ty with Unify trace -> - raise(Error(sarg.pexp_loc, env, - Coercion_failure(ty', full_expand env ty', trace, b))) - end - end; - (arg, ty', None, cty') - | Some sty -> - if separate then begin_def (); - let (cty, force) = - Typetexp.transl_simple_type_delayed env sty - and (cty', force') = - Typetexp.transl_simple_type_delayed env sty' - in - let ty = cty.ctyp_type in - let ty' = cty'.ctyp_type in - begin try - let force'' = subtype env ty ty' in - force (); force' (); force'' () - with Subtype (tr1, tr2) -> - raise(Error(loc, env, Not_subtype(tr1, tr2))) - end; - if separate then begin - end_def (); - generalize_structure ty; - generalize_structure ty'; - (type_argument env sarg ty (instance env ty), - instance env ty', Some cty, cty') - end else - (type_argument env sarg ty ty, ty', Some cty, cty') - in - rue { - exp_desc = arg.exp_desc; - exp_loc = arg.exp_loc; - exp_type = ty'; - exp_attributes = arg.exp_attributes; - exp_env = env; - exp_extra = (Texp_coerce (cty, cty'), loc, sexp.pexp_attributes) :: - arg.exp_extra; - } - | Pexp_send (e, {txt=met}) -> - let obj = type_exp env e in - let obj_meths = ref None in - begin try - let (meth, exp, typ) = - match obj.exp_desc with - | _ -> - (Tmeth_name met, None, - filter_method env met Public obj.exp_type) - in - let typ = - match repr typ with - {desc = Tpoly (ty, [])} -> - instance env ty - | {desc = Tpoly (ty, tl); level = _} -> - snd (instance_poly false tl ty) - | {desc = Tvar _} as ty -> - let ty' = newvar () in - unify env (instance_def ty) (newty(Tpoly(ty',[]))); - (* if not !Clflags.nolabels then - Location.prerr_warning loc (Warnings.Unknown_method met); *) - ty' - | _ -> - assert false - in - rue { - exp_desc = Texp_send(obj, meth, exp); - exp_loc = loc; exp_extra = []; - exp_type = typ; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - with Unify _ -> - let valid_methods = - match !obj_meths with - | Some meths -> - Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths []) - | None -> - match (expand_head env obj.exp_type).desc with - | Tobject (fields, _) -> - let (fields, _) = Ctype.flatten_fields fields in - let collect_fields li (meth, meth_kind, _meth_ty) = - if meth_kind = Fpresent then meth::li else li in - Some (List.fold_left collect_fields [] fields) - | _ -> None - in - raise(Error(e.pexp_loc, env, - Undefined_method (obj.exp_type, met, valid_methods))) - end - | Pexp_new _ - | Pexp_setinstvar _ - | Pexp_override _ -> - assert false - | Pexp_letmodule(name, smodl, sbody) -> - let ty = newvar() in - (* remember original level *) - begin_def (); - Ident.set_current_time ty.level; - let context = Typetexp.narrow () in - let modl = !type_module env smodl in - let (id, new_env) = Env.enter_module name.txt modl.mod_type env in - Ctype.init_def(Ident.current_time()); - Typetexp.widen context; - let body = type_expect new_env sbody ty_expected in - (* go back to original level *) - end_def (); - (* Unification of body.exp_type with the fresh variable ty - fails if and only if the prefix condition is violated, - i.e. if generative types rooted at id show up in the - type body.exp_type. Thus, this unification enforces the - scoping condition on "let module". *) - (* Note that this code will only be reached if ty_expected - is a generic type variable, otherwise the error will occur - above in type_expect *) - begin try - Ctype.unify_var new_env ty body.exp_type - with Unify _ -> - raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type))) - end; - re { - exp_desc = Texp_letmodule(id, name, modl, body); - exp_loc = loc; exp_extra = []; - exp_type = ty; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_letexception(cd, sbody) -> - let (cd, newenv) = Typedecl.transl_exception env cd in - let body = type_expect newenv sbody ty_expected in - re { - exp_desc = Texp_letexception(cd, body); - exp_loc = loc; exp_extra = []; - exp_type = body.exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - - | Pexp_assert (e) -> - let cond = type_expect env e Predef.type_bool in - let exp_type = - match cond.exp_desc with - | Texp_construct(_, {cstr_name="false"}, _) -> - instance env ty_expected - | _ -> - instance_def Predef.type_unit - in - rue { - exp_desc = Texp_assert cond; - exp_loc = loc; exp_extra = []; - exp_type; - exp_attributes = sexp.pexp_attributes; - exp_env = env; - } - | Pexp_lazy e -> - let ty = newgenvar () in - let to_unify = Predef.type_lazy_t ty in - unify_exp_types loc env to_unify ty_expected; - let arg = type_expect env e ty in - re { - exp_desc = Texp_lazy arg; - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env; - } - | Pexp_object _ -> assert false - | Pexp_poly(sbody, sty) -> - let ty, cty = - match sty with None -> repr ty_expected, None - | Some sty -> - let sty = Ast_helper.Typ.force_poly sty in - let cty = Typetexp.transl_simple_type env false sty in - repr cty.ctyp_type, Some cty - in - if sty <> None then - unify_exp_types loc env (instance env ty) (instance env ty_expected); - let exp = - match (expand_head env ty).desc with - Tpoly (ty', []) -> - let exp = type_expect env sbody ty' in - { exp with exp_type = instance env ty } - | Tpoly (ty', tl) -> - (* One more level to generalize locally *) - begin_def (); - let vars, ty'' = instance_poly true tl ty' in - let exp = type_expect env sbody ty'' in - end_def (); - check_univars env false "method" exp ty_expected vars; - { exp with exp_type = instance env ty } - | Tvar _ -> - let exp = type_exp env sbody in - let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in - unify_exp env exp ty; - exp - | _ -> assert false - in - re { exp with exp_extra = - (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra } - | Pexp_newtype({txt=name}, sbody) -> - let ty = newvar () in - (* remember original level *) - begin_def (); - (* Create a fake abstract type declaration for name. *) - let level = get_current_level () in - let decl = { - type_params = []; - type_arity = 0; - type_kind = Type_abstract; - type_private = Public; - type_manifest = None; - type_variance = []; - type_newtype_level = Some (level, level); - type_loc = loc; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - in - Ident.set_current_time ty.level; - let (id, new_env) = Env.enter_type name decl env in - Ctype.init_def(Ident.current_time()); - - let body = type_exp new_env sbody in - (* Replace every instance of this type constructor in the resulting - type. *) - let seen = Hashtbl.create 8 in - let rec replace t = - if Hashtbl.mem seen t.id then () - else begin - Hashtbl.add seen t.id (); - match t.desc with - | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty - | _ -> Btype.iter_type_expr replace t - end - in - let ety = Subst.type_expr Subst.identity body.exp_type in - replace ety; - (* back to original level *) - end_def (); - (* lower the levels of the result type *) - (* unify_var env ty ety; *) - - (* non-expansive if the body is non-expansive, so we don't introduce - any new extra node in the typed AST. *) - rue { body with exp_loc = loc; exp_type = ety; - exp_extra = - (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } - | Pexp_pack m -> - let (p, nl) = - match Ctype.expand_head env (instance env ty_expected) with - {desc = Tpackage (p, nl, _tl)} -> - (p, nl) - | {desc = Tvar _} -> - raise (Error (loc, env, Cannot_infer_signature)) - | _ -> - raise (Error (loc, env, Not_a_packed_module ty_expected)) - in - let (modl, tl') = !type_package env m p nl in - rue { - exp_desc = Texp_pack modl; - exp_loc = loc; exp_extra = []; - exp_type = newty (Tpackage (p, nl, tl')); - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | Pexp_open (ovf, lid, e) -> - let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in - let exp = type_expect newenv e ty_expected in - { exp with - exp_extra = (Texp_open (ovf, path, lid, newenv), loc, - sexp.pexp_attributes) :: - exp.exp_extra; - } - - | Pexp_extension ({ txt = ("ocaml.extension_constructor" - |"extension_constructor"); _ }, - payload) -> - begin match payload with - | PStr [ { pstr_desc = - Pstr_eval ({ pexp_desc = Pexp_construct (lid, None); _ }, _) - } ] -> - let path = - match (Typetexp.find_constructor env lid.loc lid.txt).cstr_tag with - | Cstr_extension (path, _) -> path - | _ -> raise (Error (lid.loc, env, Not_an_extension_constructor)) - in - rue { - exp_desc = Texp_extension_constructor (lid, path); - exp_loc = loc; exp_extra = []; - exp_type = instance_def Predef.type_extension_constructor; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - | _ -> - raise (Error (loc, env, Invalid_extension_constructor_payload)) - end - | Pexp_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - - | Pexp_unreachable -> - re { exp_desc = Texp_unreachable; - exp_loc = loc; exp_extra = []; - exp_type = instance env ty_expected; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - -and type_function ?in_function loc attrs env ty_expected l caselist = - let (loc_fun, ty_fun) = - match in_function with Some p -> p - | None -> (loc, instance env ty_expected) - in - let separate = Env.has_local_constraints env in - if separate then begin_def (); - let (ty_arg, ty_res) = - try filter_arrow env (instance env ty_expected) l - with Unify _ -> - match expand_head env ty_expected with - {desc = Tarrow _} as ty -> - raise(Error(loc, env, Abstract_wrong_label(l, ty))) - | _ -> - raise(Error(loc_fun, env, - Too_many_arguments (in_function <> None, ty_fun))) - in - let ty_arg = - if is_optional l then - let tv = newvar() in - begin - try unify env ty_arg (type_option tv) - with Unify _ -> assert false - end; - type_option tv - else ty_arg - in - if separate then begin - end_def (); - generalize_structure ty_arg; - generalize_structure ty_res - end; - let cases, partial = - type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res - true loc caselist in - if is_optional l && not_function env ty_res then - Location.prerr_warning (List.hd cases).c_lhs.pat_loc - Warnings.Unerasable_optional_argument; - let param = name_pattern "param" cases in - re { - exp_desc = Texp_function { arg_label = l; param; cases; partial; }; - exp_loc = loc; exp_extra = []; - exp_type = instance env (newgenty (Tarrow(l, ty_arg, ty_res, Cok))); - exp_attributes = attrs; - exp_env = env } - - -and type_label_access env srecord lid = - let record = type_exp ~recarg:Allowed env srecord in - let ty_exp = record.exp_type in - let opath = - try - let (p0, p, _, _) = extract_concrete_record env ty_exp in - Some(p0, p) - with Not_found -> None - in - let labels = Typetexp.find_all_labels env lid.loc lid.txt in - let label = - wrap_disambiguate "This expression has" ty_exp - (Label.disambiguate lid env opath) labels in - (record, label, opath) - -(* Typing format strings for printing or reading. - These formats are used by functions in modules Printf, Format, and Scanf. - (Handling of * modifiers contributed by Thorsten Ohl.) *) -and type_label_exp ?typeClashContext create env loc ty_expected - (lid, label, sarg) = - (* Here also ty_expected may be at generic_level *) - begin_def (); - let separate = Env.has_local_constraints env in - if separate then (begin_def (); begin_def ()); - let (vars, ty_arg, ty_res) = instance_label true label in - if separate then begin - end_def (); - (* Generalize label information *) - generalize_structure ty_arg; - generalize_structure ty_res - end; - begin try - unify env (instance_def ty_res) (instance env ty_expected) - with Unify trace -> - raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace))) - end; - (* Instantiate so that we can generalize internal nodes *) - let ty_arg = instance_def ty_arg in - if separate then begin - end_def (); - (* Generalize information merged from ty_expected *) - generalize_structure ty_arg - end; - if label.lbl_private = Private then - if create then - raise (Error(loc, env, Private_type ty_expected)) - else - raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected))); - let arg = - let snap = if vars = [] then None else Some (Btype.snapshot ()) in - let arg = type_argument ?typeClashContext env sarg ty_arg (instance env ty_arg) in - end_def (); - try - check_univars env (vars <> []) "field value" arg label.lbl_arg vars; - arg - with exn when not (is_nonexpansive arg) -> try - (* Try to retype without propagating ty_arg, cf PR#4862 *) - may Btype.backtrack snap; - begin_def (); - let arg = type_exp env sarg in - end_def (); - generalize_expansive env arg.exp_type; - unify_exp env arg ty_arg; - check_univars env false "field value" arg label.lbl_arg vars; - arg - with Error (_, _, Less_general _) as e -> raise e - | _ -> raise exn (* In case of failure return the first error *) - in - (lid, label, {arg with exp_type = instance env arg.exp_type}) - -and type_argument ?typeClashContext ?recarg env sarg ty_expected' ty_expected = - (* ty_expected' may be generic *) - let no_labels ty = - let ls, tvar = list_labels env ty in - not tvar && List.for_all (fun x -> x = Nolabel) ls - in - let rec is_inferred sexp = - match sexp.pexp_desc with - Pexp_ident _ | Pexp_apply _ | Pexp_field _ | Pexp_constraint _ - | Pexp_coerce _ | Pexp_send _ | Pexp_new _ -> true - | Pexp_sequence (_, e) | Pexp_open (_, _, e) -> is_inferred e - | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 - | _ -> false - in - match expand_head env ty_expected' with - {desc = Tarrow(Nolabel,ty_arg,ty_res,_); level = _} - when is_inferred sarg -> - (* apply optional arguments when expected type is "" *) - (* we must be very careful about not breaking the semantics *) - let texp = type_exp env sarg in - let rec make_args args ty_fun = - match (expand_head env ty_fun).desc with - | Tarrow (l,ty_arg,ty_fun,_) when is_optional l -> - let ty = option_none (instance env ty_arg) sarg.pexp_loc in - make_args ((l, Some ty) :: args) ty_fun - | Tarrow (Nolabel,_,ty_res',_) -> - List.rev args, ty_fun, no_labels ty_res' - | Tvar _ -> List.rev args, ty_fun, false - | _ -> [], texp.exp_type, false - in - let args, ty_fun', simple_res = make_args [] texp.exp_type in - let texp = {texp with exp_type = instance env texp.exp_type} - and ty_fun = instance env ty_fun' in - if not (simple_res || no_labels ty_res) then begin - unify_exp env texp ty_expected; - texp - end else begin - unify_exp env {texp with exp_type = ty_fun} ty_expected; - if args = [] then texp else - (* eta-expand to avoid side effects *) - let var_pair name ty = - let id = Ident.create name in - {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[]; - pat_attributes = []; - pat_loc = Location.none; pat_env = env}, - {exp_type = ty; exp_loc = Location.none; exp_env = env; - exp_extra = []; exp_attributes = []; - exp_desc = - Texp_ident(Path.Pident id, mknoloc (Longident.Lident name), - {val_type = ty; val_kind = Val_reg; - val_attributes = []; - Types.val_loc = Location.none})} - in - let eta_pat, eta_var = var_pair "eta" ty_arg in - let func texp = - let e = - {texp with exp_type = ty_res; exp_desc = - Texp_apply - (texp, - args @ [Nolabel, Some eta_var])} - in - let cases = [case eta_pat e] in - let param = name_pattern "param" cases in - { texp with exp_type = ty_fun; exp_desc = - Texp_function { arg_label = Nolabel; param; cases; - partial = Total; } } - in - Location.prerr_warning texp.exp_loc - (Warnings.Eliminated_optional_arguments - (List.map (fun (l, _) -> Printtyp.string_of_label l) args)); - (* let-expand to have side effects *) - let let_pat, let_var = var_pair "arg" texp.exp_type in - re { texp with exp_type = ty_fun; exp_desc = - Texp_let (Nonrecursive, - [{vb_pat=let_pat; vb_expr=texp; vb_attributes=[]; - vb_loc=Location.none; - }], - func let_var) } - end - | _ -> - let texp = type_expect ?typeClashContext ?recarg env sarg ty_expected' in - unify_exp ?typeClashContext env texp ty_expected; - texp -and is_automatic_curried_application env funct = - (* When a curried function is used with uncurried application, treat it as a curried application *) - !Config.uncurried = Uncurried && - match (expand_head env funct.exp_type).desc with - | Tarrow _ -> true - | _ -> false -and type_application ?typeClashContext uncurried env funct (sargs : sargs) : targs * Types.type_expr * bool = - (* funct.exp_type may be generic *) - let result_type omitted ty_fun = - List.fold_left - (fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok))) - ty_fun omitted - in - let has_label l ty_fun = - let ls, tvar = list_labels env ty_fun in - tvar || List.mem l ls - in - let ignored = ref [] in - let has_uncurried_type t = - match (expand_head env t).desc with - | Tconstr (Pident {name = "function$"},[t; tArity],_) -> - let arity = Ast_uncurried.type_to_arity tArity in - Some (arity, t) - | _ -> None in - let force_uncurried_type funct = - match has_uncurried_type funct.exp_type with - | None -> - let arity = List.length sargs in - let uncurried_typ = Ast_uncurried.make_uncurried_type ~env ~arity (newvar()) in - begin - match (expand_head env funct.exp_type).desc with - | Tvar _ | Tarrow _ -> - unify_exp env funct uncurried_typ - | _ -> - raise(Error(funct.exp_loc, env, Apply_non_function (expand_head env funct.exp_type))) - end - | Some _ -> () in - let extract_uncurried_type t = - match has_uncurried_type t with - | Some (arity, t1) -> - if List.length sargs > arity then - raise(Error(funct.exp_loc, env, - Uncurried_arity_mismatch (t, arity, List.length sargs))); - t1, arity - | None -> t, max_int in - let update_uncurried_arity ~nargs t newT = - match has_uncurried_type t with - | Some (arity, _) -> - let newarity = arity - nargs in - let fully_applied = newarity <= 0 in - if uncurried && not fully_applied then - raise(Error(funct.exp_loc, env, - Uncurried_arity_mismatch (t, arity, List.length sargs))); - let newT = if fully_applied then newT else Ast_uncurried.make_uncurried_type ~env ~arity:newarity newT in - (fully_applied, newT) - | _ -> (false, newT) - in - let rec type_unknown_args max_arity ~(args : lazy_args) omitted ty_fun (syntax_args : sargs) - : targs * _ = - match syntax_args with - | [] -> - let collect_args () = - (List.map - (function l, None -> l, None - | l, Some f -> l, Some (f ())) - (List.rev args), - instance env (result_type omitted ty_fun)) in - if List.length args < max_arity && uncurried then - (match (expand_head env ty_fun).desc with - | Tarrow (Optional l,t1,t2,_) -> - ignored := (Optional l,t1,ty_fun.level) :: !ignored; - let arg = Optional l, Some (fun () -> option_none (instance env t1) Location.none) in - type_unknown_args max_arity ~args:(arg::args) omitted t2 [] - | _ -> collect_args ()) - else - collect_args () - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] - when uncurried && omitted = [] && args <> [] && List.length args = List.length !ignored -> - (* foo(. ) treated as empty application if all args are optional (hence ignored) *) - type_unknown_args max_arity ~args omitted ty_fun [] - | (l1, sarg1) :: sargl -> - let (ty1, ty2) = - let ty_fun = expand_head env ty_fun in - let arity_ok = List.length args < max_arity in - match ty_fun.desc with - Tvar _ -> - let t1 = newvar () and t2 = newvar () in - if ty_fun.level >= t1.level && not_identity funct.exp_desc then - Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument; - unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown)))); - (t1, t2) - | Tarrow (l,t1,t2,_) when Asttypes.same_arg_label l l1 && arity_ok - -> - (t1, t2) - | td -> - let ty_fun = - match td with Tarrow _ -> newty td | _ -> ty_fun in - let ty_res = result_type (omitted @ !ignored) ty_fun in - match ty_res.desc with - Tarrow _ -> - if not arity_ok then - raise (Error(sarg1.pexp_loc, env, - Apply_wrong_label(l1, funct.exp_type))) else - if (not (has_label l1 ty_fun)) then - raise (Error(sarg1.pexp_loc, env, - Apply_wrong_label(l1, ty_res))) - else - raise (Error(funct.exp_loc, env, Incoherent_label_order)) - | _ -> - raise(Error(funct.exp_loc, env, Apply_non_function - (expand_head env funct.exp_type))) - in - let optional = is_optional l1 in - let arg1 () = - let arg1 = type_expect env sarg1 ty1 in - if optional then - unify_exp env arg1 (type_option(newvar())); - arg1 - in - type_unknown_args max_arity ~args:((l1, Some arg1) :: args) omitted ty2 sargl - in - let rec type_args ?typeClashContext max_arity args omitted ~ty_fun ty_fun0 ~(sargs : sargs) = - match expand_head env ty_fun, expand_head env ty_fun0 with - {desc=Tarrow (l, ty, ty_fun, com); level=lv} , - {desc=Tarrow (_, ty0, ty_fun0, _)} - when (sargs <> [] ) && commu_repr com = Cok && List.length args < max_arity -> - let name = label_name l - and optional = is_optional l in - let sargs, omitted, arg = - match extract_label name sargs with - | None -> - if optional && (uncurried || label_assoc Nolabel sargs) - then begin - ignored := (l,ty,lv) :: !ignored; - sargs, omitted , Some (fun () -> option_none (instance env ty) Location.none) - end else - sargs, (l,ty,lv) :: omitted , None - | Some (l', sarg0, sargs) -> - if not optional && is_optional l' then - Location.prerr_warning sarg0.pexp_loc - (Warnings.Nonoptional_label (Printtyp.string_of_label l)); - sargs, omitted , - Some ( - if not optional || is_optional l' then - (fun () -> type_argument ?typeClashContext:(typeClashContextForFunctionArgument typeClashContext sarg0) env sarg0 ty ty0) - else - (fun () -> option_some (type_argument ?typeClashContext env sarg0 - (extract_option_type env ty) - (extract_option_type env ty0)))) - in - type_args ?typeClashContext max_arity ((l,arg)::args) omitted ~ty_fun ty_fun0 ~sargs - | _ -> - type_unknown_args max_arity ~args omitted ty_fun0 sargs (* This is the hot path for non-labeled function*) - in - let () = - let ls, tvar = list_labels env funct.exp_type in - if not tvar then - let labels = Ext_list.filter ls (fun l -> not (is_optional l)) in - if Ext_list.same_length labels sargs && - List.for_all (fun (l,_) -> l = Nolabel) sargs && - List.exists (fun l -> l <> Nolabel) labels then - raise - (Error( - funct.exp_loc, env, - (Labels_omitted - (List.map Printtyp.string_of_label - (Ext_list.filter labels (fun x -> x <> Nolabel)))))) - in - match sargs with - (* Special case for ignore: avoid discarding warning *) - [Nolabel, sarg] when is_ignore funct env -> - let ty_arg, ty_res = - filter_arrow env (instance env funct.exp_type) Nolabel - in - let exp = type_expect env sarg ty_arg in - begin match (expand_head env exp.exp_type).desc with - | Tarrow _ -> - Location.prerr_warning exp.exp_loc Warnings.Partial_application - | Tvar _ -> - Delayed_checks.add_delayed_check (fun () -> check_application_result env false exp) - | _ -> () - end; - ([Nolabel, Some exp], ty_res, false) - | _ -> - if uncurried then force_uncurried_type funct; - let ty, max_arity = extract_uncurried_type funct.exp_type in - let targs, ret_t = type_args ?typeClashContext max_arity [] [] ~ty_fun:ty (instance env ty) ~sargs in - let fully_applied, ret_t = - update_uncurried_arity funct.exp_type ~nargs:(List.length !ignored + List.length sargs) ret_t in - targs, ret_t, fully_applied - -and type_construct env loc lid sarg ty_expected attrs = - let opath = - try - let (p0, p,_) = extract_concrete_variant env ty_expected in - Some(p0, p) - with Not_found -> None - in - let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in - let constr = - wrap_disambiguate "This variant expression is expected to have" ty_expected - (Constructor.disambiguate lid env opath) constrs in - Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; - Builtin_attributes.check_deprecated loc constr.cstr_attributes - constr.cstr_name; - let sargs = - match sarg with - None -> [] - | Some {pexp_desc = Pexp_tuple sel} when - constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs - -> sel - | Some se -> [se] in - if List.length sargs <> constr.cstr_arity then - raise(Error(loc, env, Constructor_arity_mismatch - (lid.txt, constr.cstr_arity, List.length sargs))); - let separate = Env.has_local_constraints env in - if separate then (begin_def (); begin_def ()); - let (ty_args, ty_res) = instance_constructor constr in - let texp = - re { - exp_desc = Texp_construct(lid, constr, []); - exp_loc = loc; exp_extra = []; - exp_type = ty_res; - exp_attributes = attrs; - exp_env = env } in - let typeClashContext = typeClashContextMaybeOption ty_expected ty_res in - if separate then begin - end_def (); - generalize_structure ty_res; - unify_exp ?typeClashContext env {texp with exp_type = instance_def ty_res} - (instance env ty_expected); - end_def (); - List.iter generalize_structure ty_args; - generalize_structure ty_res; - end; - let ty_args0, ty_res = - match instance_list env (ty_res :: ty_args) with - t :: tl -> tl, t - | _ -> assert false - in - let texp = {texp with exp_type = ty_res} in - if not separate then unify_exp ?typeClashContext env texp (instance env ty_expected); - let recarg = - match constr.cstr_inlined with - | None -> Rejected - | Some _ -> - begin match sargs with - | [{pexp_desc = - Pexp_ident _ | - Pexp_record (_, (Some {pexp_desc = Pexp_ident _}| None))}] -> - Required - | _ -> - raise (Error(loc, env, Inlined_record_expected)) - end - in - let args = - List.map2 (fun e (t,t0) -> type_argument ~recarg env e t t0) sargs - (List.combine ty_args ty_args0) in - if constr.cstr_private = Private then - raise(Error(loc, env, Private_type ty_res)); - (* NOTE: shouldn't we call "re" on this final expression? -- AF *) - { texp with - exp_desc = Texp_construct(lid, constr, args) } - -(* Typing of statements (expressions whose values are discarded) *) - -and type_statement env sexp = - let loc = (final_subexpression sexp).pexp_loc in - begin_def(); - let exp = type_exp env sexp in - end_def(); - let ty = expand_head env exp.exp_type and tv = newvar() in - if is_Tvar ty && ty.level > tv.level then - Location.prerr_warning loc Warnings.Nonreturning_statement; - let expected_ty = instance_def Predef.type_unit in - let typeClashContext = typeClashContextInStatement sexp in - unify_exp ?typeClashContext env exp expected_ty; - exp - -(* Typing of match cases *) - -and type_cases ?rootTypeClashContext ?in_function env ty_arg ty_res partial_flag loc caselist : _ * Typedtree.partial = - (* ty_arg is _fully_ generalized *) - let patterns = List.map (fun {pc_lhs=p} -> p) caselist in - let contains_polyvars = List.exists contains_polymorphic_variant patterns in - let erase_either = contains_polyvars && contains_variant_either ty_arg - and has_gadts = List.exists (contains_gadt env) patterns in -(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *) - let ty_arg = - if (has_gadts || erase_either) - then correct_levels ty_arg else ty_arg - and ty_res, env = - if has_gadts then - correct_levels ty_res, duplicate_ident_types caselist env - else ty_res, env - in - let rec is_var spat = - match spat.ppat_desc with - Ppat_any | Ppat_var _ -> true - | Ppat_alias (spat, _) -> is_var spat - | _ -> false in - let needs_exhaust_check = - match caselist with - [{pc_rhs = {pexp_desc = Pexp_unreachable}}] -> true - | [{pc_lhs}] when is_var pc_lhs -> false - | _ -> true - in - let init_env () = - (* raise level for existentials *) - begin_def (); - Ident.set_current_time (get_current_level ()); - let lev = Ident.current_time () in - Ctype.init_def (lev+1000); (* up to 1000 existentials *) - (lev, Env.add_gadt_instance_level lev env) - in - let lev, env = - if has_gadts then init_env () else (get_current_level (), env) - in -(* if has_gadts then - Format.printf "lev = %d@.%a@." lev Printtyp.raw_type_expr ty_res; *) - (* Do we need to propagate polymorphism *) - let propagate = - has_gadts || (repr ty_arg).level = generic_level || - match caselist with - [{pc_lhs}] when is_var pc_lhs -> false - | _ -> true in - if propagate then begin_def (); (* propagation of the argument *) - let pattern_force = ref [] in -(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level()) - Printtyp.raw_type_expr ty_arg; *) - let pat_env_list = - List.map - (fun {pc_lhs; pc_guard; pc_rhs} -> - let loc = - let open Location in - match pc_guard with - | None -> pc_rhs.pexp_loc - | Some g -> {pc_rhs.pexp_loc with loc_start=g.pexp_loc.loc_start} - in - let scope = Some (Annot.Idef loc) in - let (pat, ext_env, force, unpacks) = - let partial = - if erase_either - then Some false else None in - let ty_arg = instance ?partial env ty_arg in - type_pattern ~lev env pc_lhs scope ty_arg - in - pattern_force := force @ !pattern_force; - (pat, (ext_env, unpacks))) - caselist in - (* Unify all cases (delayed to keep it order-free) *) - let ty_arg' = newvar () in - let unify_pats ty = - List.iter (fun (pat, (ext_env, _)) -> unify_pat ext_env pat ty) - pat_env_list in - unify_pats ty_arg'; - (* Check for polymorphic variants to close *) - let patl = List.map fst pat_env_list in - if List.exists has_variants patl then begin - Parmatch.pressure_variants env patl; - List.iter (iter_pattern finalize_variant) patl - end; - (* `Contaminating' unifications start here *) - List.iter (fun f -> f()) !pattern_force; - (* Post-processing and generalization *) - if propagate || erase_either then unify_pats (instance env ty_arg); - if propagate then begin - List.iter - (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl; - end_def (); - List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl; - end; - (* type bodies *) - let in_function = if List.length caselist = 1 then in_function else None in - let cases = - List.map2 - (fun (pat, (ext_env, unpacks)) {pc_lhs; pc_guard; pc_rhs} -> - let sexp = wrap_unpacks pc_rhs unpacks in - let ty_res' = - if contains_gadt env pc_lhs then correct_levels ty_res - else ty_res in -(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level()) - Printtyp.raw_type_expr ty_res'; *) - let guard = - match pc_guard with - | None -> None - | Some scond -> - Some - (type_expect ?typeClashContext:(if Option.is_some rootTypeClashContext then Some IfCondition else None) ext_env (wrap_unpacks scond unpacks) - Predef.type_bool) - in - let exp = type_expect ?typeClashContext:rootTypeClashContext ?in_function ext_env sexp ty_res' in - { - c_lhs = pat; - c_guard = guard; - c_rhs = {exp with exp_type = instance env ty_res'} - } - ) - pat_env_list caselist - in - if has_gadts then begin - let ty_res' = instance env ty_res in - List.iter (fun c -> unify_exp env c.c_rhs ty_res') cases - end; - let do_init = has_gadts || needs_exhaust_check in - let lev, env = - if do_init && not has_gadts then init_env () else lev, env in - let ty_arg_check = - if do_init then - (* Hack: use for_saving to copy variables too *) - Subst.type_expr (Subst.for_saving Subst.identity) ty_arg - else ty_arg - in - let partial = - if partial_flag then - check_partial ~lev env ty_arg_check loc cases - else - Partial - in - let unused_check () = - List.iter (fun (pat, (env, _)) -> check_absent_variant env pat) - pat_env_list; - check_unused ~lev env (instance env ty_arg_check) cases ; - Parmatch.check_ambiguous_bindings cases - in - if contains_polyvars || do_init then - Delayed_checks.add_delayed_check unused_check - else - unused_check (); - (* Check for unused cases, do not delay because of gadts *) - if do_init then begin - end_def (); - (* Ensure that existential types do not escape *) - unify_exp_types loc env (instance env ty_res) (newvar ()) ; - end; - cases, partial - -(* Typing of let bindings *) - -and type_let ?(check = fun s -> Warnings.Unused_var s) - ?(check_strict = fun s -> Warnings.Unused_var_strict s) - env rec_flag spat_sexp_list scope allow = - begin_def(); - let is_fake_let = - match spat_sexp_list with - | [{pvb_expr={pexp_desc=Pexp_match( - {pexp_desc=Pexp_ident({ txt = Longident.Lident "*opt*"})},_)}}] -> - true (* the fake let-declaration introduced by fun ?(x = e) -> ... *) - | _ -> - false - in - let check = if is_fake_let then check_strict else check in - - let spatl = - List.map - (fun {pvb_pat=spat; pvb_attributes=attrs} -> - attrs, spat) - spat_sexp_list in - let nvs = List.map (fun _ -> newvar ()) spatl in - let (pat_list, new_env, force, unpacks) = - type_pattern_list env spatl scope nvs allow in - let attrs_list = List.map fst spatl in - let is_recursive = (rec_flag = Recursive) in - (* If recursive, first unify with an approximation of the expression *) - if is_recursive then - List.iter2 - (fun pat binding -> - let pat = - match pat.pat_type.desc with - | Tpoly (ty, tl) -> - {pat with pat_type = - snd (instance_poly ~keep_names:true false tl ty)} - | _ -> pat - in unify_pat env pat (type_approx env binding.pvb_expr)) - pat_list spat_sexp_list; - (* Polymorphic variant processing *) - List.iter - (fun pat -> - if has_variants pat then begin - Parmatch.pressure_variants env [pat]; - iter_pattern finalize_variant pat - end) - pat_list; - (* Only bind pattern variables after generalizing *) - List.iter (fun f -> f()) force; - let exp_env = - if is_recursive then new_env else env in - - let current_slot = ref None in - let rec_needed = ref false in - let warn_about_unused_bindings = - List.exists - (fun attrs -> - Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> - Warnings.is_active (check "") || Warnings.is_active (check_strict "") || - (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)))) - attrs_list - in - let pat_slot_list = - (* Algorithm to detect unused declarations in recursive bindings: - - During type checking of the definitions, we capture the 'value_used' - events on the bound identifiers and record them in a slot corresponding - to the current definition (!current_slot). - In effect, this creates a dependency graph between definitions. - - - After type checking the definition (!current_slot = None), - when one of the bound identifier is effectively used, we trigger - again all the events recorded in the corresponding slot. - The effect is to traverse the transitive closure of the graph created - in the first step. - - We also keep track of whether *all* variables in a given pattern - are unused. If this is the case, for local declarations, the issued - warning is 26, not 27. - *) - List.map2 - (fun attrs pat -> - Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> - if not warn_about_unused_bindings then pat, None - else - let some_used = ref false in - (* has one of the identifier of this pattern been used? *) - let slot = ref [] in - List.iter - (fun id -> - let vd = Env.find_value (Path.Pident id) new_env in - (* note: Env.find_value does not trigger the value_used event *) - let name = Ident.name id in - let used = ref false in - if not (name = "" || name.[0] = '_' || name.[0] = '#') then - Delayed_checks.add_delayed_check - (fun () -> - if not !used then - Location.prerr_warning vd.Types.val_loc - ((if !some_used then check_strict else check) name) - ); - Env.set_value_used_callback - name vd - (fun () -> - match !current_slot with - | Some slot -> - slot := (name, vd) :: !slot; rec_needed := true - | None -> - List.iter - (fun (name, vd) -> Env.mark_value_used env name vd) - (get_ref slot); - used := true; - some_used := true - ) - ) - (Typedtree.pat_bound_idents pat); - pat, Some slot - )) - attrs_list - pat_list - in - let exp_list = - List.map2 - (fun {pvb_expr=sexp; pvb_attributes; _} (pat, slot) -> - let sexp = - if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in - if is_recursive then current_slot := slot; - match pat.pat_type.desc with - | Tpoly (ty, tl) -> - begin_def (); - let vars, ty' = instance_poly ~keep_names:true true tl ty in - let exp = - Builtin_attributes.warning_scope pvb_attributes - (fun () -> type_expect exp_env sexp ty') - in - end_def (); - check_univars env true "definition" exp pat.pat_type vars; - {exp with exp_type = instance env exp.exp_type} - | _ -> - Builtin_attributes.warning_scope pvb_attributes (fun () -> - type_expect exp_env sexp pat.pat_type)) - spat_sexp_list pat_slot_list in - current_slot := None; - if is_recursive && not !rec_needed - && Warnings.is_active Warnings.Unused_rec_flag then begin - let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in - (* See PR#6677 *) - Builtin_attributes.warning_scope ~ppwarning:false pvb_attributes - (fun () -> - Location.prerr_warning pvb_pat.ppat_loc Warnings.Unused_rec_flag - ) - end; - List.iter2 - (fun pat (attrs, exp) -> - Builtin_attributes.warning_scope ~ppwarning:false attrs - (fun () -> - ignore(check_partial env pat.pat_type pat.pat_loc - [case pat exp]) - ) - ) - pat_list - (List.map2 (fun (attrs, _) e -> attrs, e) spatl exp_list); - end_def(); - List.iter2 - (fun pat exp -> - if not (is_nonexpansive exp) then - iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat) - pat_list exp_list; - List.iter - (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat) - pat_list; - let l = List.combine pat_list exp_list in - let l = - List.map2 - (fun (p, e) pvb -> - {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; - vb_loc=pvb.pvb_loc; - }) - l spat_sexp_list - in - if is_recursive then - List.iter - (fun {vb_pat=pat} -> match pat.pat_desc with - Tpat_var _ -> () - | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () - | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat))) - l; - (l, new_env, unpacks) - -(* Typing of toplevel bindings *) - -let type_binding env rec_flag spat_sexp_list scope = - Typetexp.reset_type_variables(); - let (pat_exp_list, new_env, _unpacks) = - type_let - ~check:(fun s -> Warnings.Unused_value_declaration s) - ~check_strict:(fun s -> Warnings.Unused_value_declaration s) - env rec_flag spat_sexp_list scope false - in - (pat_exp_list, new_env) - -let type_let env rec_flag spat_sexp_list scope = - let (pat_exp_list, new_env, _unpacks) = - type_let env rec_flag spat_sexp_list scope false in - (pat_exp_list, new_env) - -(* Typing of toplevel expressions *) - -let type_expression env sexp = - Typetexp.reset_type_variables(); - begin_def(); - let exp = type_exp env sexp in - if Warnings.is_active (Bs_toplevel_expression_unit None) then - (try unify env exp.exp_type - (instance_def Predef.type_unit) with - | Unify _ -> - let buffer = Buffer.create 10 in - let formatter = Format.formatter_of_buffer buffer in - Printtyp.type_expr formatter exp.exp_type; - Format.pp_print_flush formatter (); - let returnType = Buffer.contents buffer in - Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit ( - match sexp.pexp_desc with - | Pexp_apply _ -> Some (returnType, FunctionCall) - | _ -> Some (returnType, Other) - )) - | Tags _ -> Location.prerr_warning sexp.pexp_loc (Bs_toplevel_expression_unit None)); - end_def(); - if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; - generalize exp.exp_type; - match sexp.pexp_desc with - Pexp_ident lid -> - (* Special case for keeping type variables when looking-up a variable *) - let (_path, desc) = Env.lookup_value lid.txt env in - {exp with exp_type = desc.val_type} - | _ -> exp - -(* Error report *) - -let spellcheck ppf unbound_name valid_names = - Misc.did_you_mean ppf (fun () -> - Misc.spellcheck valid_names unbound_name - ) - -let spellcheck_idents ppf unbound valid_idents = - spellcheck ppf (Ident.name unbound) (List.map Ident.name valid_idents) - -open Format -let longident = Printtyp.longident -let super_report_unification_error = Printtyp.super_report_unification_error -let report_ambiguous_type_error = Printtyp.report_ambiguous_type_error -let report_subtyping_error = Printtyp.report_subtyping_error -let type_expr ppf typ = (* print a type and avoid infinite loops *) - Printtyp.reset_and_mark_loops typ; - Printtyp.type_expr ppf typ - -let report_error env ppf = function - | Polymorphic_label lid -> - fprintf ppf "@[The record field %a is polymorphic.@ %s@]" - longident lid "You cannot instantiate it in a pattern." - | Constructor_arity_mismatch(lid, expected, provided) -> - (* modified *) - fprintf ppf - "@[This variant constructor, %a, expects %i %s; here, we've %sfound %i.@]" - longident lid expected (if expected == 1 then "argument" else "arguments") (if provided < expected then "only " else "") provided - | Label_mismatch(lid, trace) -> - (* modified *) - super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The record field %a@ belongs to the type" - longident lid) - (function ppf -> - fprintf ppf "but is mixed here with fields of type") - | Pattern_type_clash trace -> - (* modified *) - super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "This pattern matches values of type") - (function ppf -> - fprintf ppf "but a pattern was expected which matches values of type") - | Or_pattern_type_clash (id, trace) -> - (* modified *) - super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The variable %s on the left-hand side of this or-pattern has type" (Ident.name id)) - (function ppf -> - fprintf ppf "but on the right-hand side it has type") - | Multiply_bound_variable name -> - fprintf ppf "Variable %s is bound several times in this matching" name - | Orpat_vars (id, valid_idents) -> - fprintf ppf "Variable %s must occur on both sides of this | pattern" - (Ident.name id); - spellcheck_idents ppf id valid_idents - | Expr_type_clash (( - (_, {desc = Tarrow _}) :: - (_, {desc = Tconstr (Pident {name = "function$"},_,_)}) :: _ - ), _) -> - fprintf ppf "This function is a curried function where an uncurried function is expected" - | Expr_type_clash (( - (_, {desc = Tconstr (Pident {name = "function$"}, [{desc=Tvar _}; _],_)}) :: - (_, {desc = Tarrow _}) :: _ - ), _) -> - fprintf ppf "This function is an uncurried function where a curried function is expected" - | Expr_type_clash (( - (_, {desc = Tconstr (Pident {name = "function$"},[_; tA],_)}) :: - (_, {desc = Tconstr (Pident {name = "function$"},[_; tB],_)}) :: _ - ), _) when Ast_uncurried.type_to_arity tA <> Ast_uncurried.type_to_arity tB -> - let arityA = Ast_uncurried.type_to_arity tA |> string_of_int in - let arityB = Ast_uncurried.type_to_arity tB |> string_of_int in - reportArityMismatch ~arityA ~arityB ppf - | Expr_type_clash (( - (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),a,_),_,_)}) :: - (_, {desc = Tconstr (Pdot (Pdot(Pident {name = "Js_OO"},"Meth",_),b,_),_,_)}) :: _ - ), _) when a <> b -> - fprintf ppf "This method has %s but was expected %s" a b - - | Expr_type_clash (trace, typeClashContext) -> - (* modified *) - fprintf ppf "@["; - print_expr_type_clash ?typeClashContext env trace ppf; - fprintf ppf "@]" - | Apply_non_function typ -> - (* modified *) - begin match (repr typ).desc with - Tarrow (_, _inputType, returnType, _) -> - let rec countNumberOfArgs count {Types.desc} = match desc with - | Tarrow (_, _inputType, returnType, _) -> countNumberOfArgs (count + 1) returnType - | _ -> count - in - let countNumberOfArgs = countNumberOfArgs 1 in - let acceptsCount = countNumberOfArgs returnType in - fprintf ppf "@[@[<2>This function has type@ @{%a@}@]" - type_expr typ; - fprintf ppf "@ @[It only accepts %i %s; here, it's called with more.@]@]" - acceptsCount (if acceptsCount == 1 then "argument" else "arguments") - | _ -> - fprintf ppf "@[@[<2>This expression has type@ %a@]@ %s@]" - type_expr typ - "It is not a function." - end - | Apply_wrong_label (l, ty) -> - let print_label ppf = function - | Nolabel -> fprintf ppf "without label" - | l -> - fprintf ppf "with label %s" (prefixed_label_name l) - in - fprintf ppf - "@[@[<2>The function applied to this argument has type@ %a@]@.\ - This argument cannot be applied %a@]" - type_expr ty print_label l - | Label_multiply_defined s -> - fprintf ppf "The record field label %s is defined several times" s - | Labels_missing (labels, might_be_component) -> - let print_labels ppf = - List.iter (fun lbl -> fprintf ppf "@ %s" ( lbl)) in - let component_text = if might_be_component then " If this is a component, add the missing props." else "" in - fprintf ppf "@[Some required record fields are missing:%a.%s@]" - print_labels labels component_text - | Label_not_mutable lid -> - fprintf ppf "The record field %a is not mutable" longident lid - | Wrong_name (eorp, ty, kind, p, name, valid_names) -> - (* modified *) - if Path.is_constructor_typath p then begin - fprintf ppf "@[The field %s is not part of the record \ - argument for the %a constructor@]" - name - Printtyp.path p; - end else begin - fprintf ppf "@["; - - fprintf ppf "@[<2>The %s @{%s@} does not belong to type @{%a@}@]@,@," - (label_of_kind kind) - name (*kind*) Printtyp.path p; - - fprintf ppf "@[<2>%s type@ @{%a@}@]" - eorp type_expr ty; - - fprintf ppf "@]"; - end; - spellcheck ppf name valid_names; - | Name_type_mismatch (kind, lid, tp, tpl) -> - let name = label_of_kind kind in - report_ambiguous_type_error ppf env tp tpl - (function ppf -> - fprintf ppf "The %s %a@ belongs to the %s type" - name longident lid kind) - (function ppf -> - fprintf ppf "The %s %a@ belongs to one of the following %s types:" - name longident lid kind) - (function ppf -> - fprintf ppf "but a %s was expected belonging to the %s type" - name kind) - | Undefined_method (ty, me, valid_methods) -> - fprintf ppf - "@[@[This expression has type@;<1 2>%a@]@,\ - It has no field %s@]" type_expr ty me; - begin match valid_methods with - | None -> () - | Some valid_methods -> spellcheck ppf me valid_methods - end - | Not_subtype(tr1, tr2) -> - report_subtyping_error ppf env tr1 "is not a subtype of" tr2 - | Coercion_failure (ty, ty', trace, b) -> - (* modified *) - super_report_unification_error ppf env trace - (function ppf -> - let ty, ty' = Printtyp.prepare_expansion (ty, ty') in - fprintf ppf - "This expression cannot be coerced to type@;<1 2>%a;@ it has type" - (Printtyp.type_expansion ty) ty') - (function ppf -> - fprintf ppf "but is here used with type"); - if b then - fprintf ppf ".@.@[%s@ %s@]" - "This simple coercion was not fully general." - "Consider using a double coercion." - | Too_many_arguments (in_function, ty) -> - (* modified *) - if in_function then begin - fprintf ppf "@[This function expects too many arguments,@ "; - fprintf ppf "it should have type@ %a@]" - type_expr ty - end else begin - match ty with - | {desc = Tconstr (Pident {name = "function$"},_,_)} -> - fprintf ppf "This expression is expected to have an uncurried function" - | _ -> - fprintf ppf "@[This expression should not be a function,@ "; - fprintf ppf "the expected type is@ %a@]" - type_expr ty - end - | Abstract_wrong_label (l, ty) -> - let label_mark = function - | Nolabel -> "but its first argument is not labelled" - | l -> sprintf "but its first argument is labelled %s" - (prefixed_label_name l) in - fprintf ppf "@[@[<2>This function should have type@ %a@]@,%s@]" - type_expr ty (label_mark l) - | Scoping_let_module(id, ty) -> - fprintf ppf - "This `let module' expression has type@ %a@ " type_expr ty; - fprintf ppf - "In this type, the locally bound module name %s escapes its scope" id - | Private_type ty -> - fprintf ppf "Cannot create values of the private type %a" type_expr ty - | Private_label (lid, ty) -> - fprintf ppf "Cannot assign field %a of the private type %a" - longident lid type_expr ty - | Not_a_variant_type lid -> - fprintf ppf "The type %a@ is not a variant type" longident lid - | Incoherent_label_order -> - fprintf ppf "This labeled function is applied to arguments@ "; - fprintf ppf "in an order different from other calls.@ "; - fprintf ppf "This is only allowed when the real type is known." - | Less_general (kind, trace) -> - (* modified *) - super_report_unification_error ppf env trace - (fun ppf -> fprintf ppf "This %s has type" kind) - (fun ppf -> fprintf ppf "which is less general than") - | Modules_not_allowed -> - fprintf ppf "Modules are not allowed in this pattern." - | Cannot_infer_signature -> - fprintf ppf - "The signature for this packaged module couldn't be inferred." - | Not_a_packed_module ty -> - fprintf ppf - "This expression is packed module, but the expected type is@ %a" - type_expr ty - | Recursive_local_constraint trace -> - (* modified *) - super_report_unification_error ppf env trace - (function ppf -> - fprintf ppf "Recursive local constraint when unifying") - (function ppf -> - fprintf ppf "with") - | Unexpected_existential -> - fprintf ppf - "Unexpected existential" - | Unqualified_gadt_pattern (tpath, name) -> - fprintf ppf "@[The GADT constructor %s of type %a@ %s.@]" - name Printtyp.path tpath - "must be qualified in this pattern" - | Invalid_interval -> - fprintf ppf "@[Only character intervals are supported in patterns.@]" - | Invalid_for_loop_index -> - fprintf ppf - "@[Invalid for-loop index: only variables and _ are allowed.@]" - | No_value_clauses -> - fprintf ppf - "None of the patterns in this 'match' expression match values." - | Exception_pattern_below_toplevel -> - fprintf ppf - "@[Exception patterns must be at the top level of a match case.@]" - | Inlined_record_escape -> - fprintf ppf - "@[This form is not allowed as the type of the inlined record could \ - escape.@]" - | Inlined_record_expected -> - fprintf ppf - "@[This constructor expects an inlined record argument.@]" - | Unrefuted_pattern pat -> - fprintf ppf - "@[%s@ %s@ %a@]" - "This match case could not be refuted." - "Here is an example of a value that would reach it:" - Parmatch.top_pretty pat - | Invalid_extension_constructor_payload -> - fprintf ppf - "Invalid [%%extension_constructor] payload, a constructor is expected." - | Not_an_extension_constructor -> - fprintf ppf - "This constructor is not an extension constructor." - | Literal_overflow ty -> - fprintf ppf "Integer literal exceeds the range of representable \ - integers of type %s" ty - | Unknown_literal (n, m) -> - fprintf ppf "Unknown modifier '%c' for literal %s%c" m n m - | Illegal_letrec_pat -> - fprintf ppf - "Only variables are allowed as left-hand side of `let rec'" - | Labels_omitted [label] -> - fprintf ppf "Label ~%s was omitted in the application of this labeled function." - label - | Labels_omitted labels -> - let labelsString = labels |> List.map(fun label -> "~" ^ label) |> String.concat ", " in - fprintf ppf "Labels %s were omitted in the application of this labeled function." - labelsString - | Empty_record_literal -> - fprintf ppf "Empty record literal {} should be type annotated or used in a record context." - | Uncurried_arity_mismatch (typ, arity, args) -> - fprintf ppf "@[@[<2>This uncurried function has type@ %a@]" - type_expr typ; - fprintf ppf "@ @[It is applied with @{%d@} argument%s but it requires @{%d@}.@]@]" - args (if args = 0 then "" else "s") arity - | Field_not_optional (name, typ) -> - fprintf ppf - "Field @{%s@} is not optional in type %a. Use without ?" name - type_expr typ - - -let super_report_error_no_wrap_printing_env = report_error - - -let report_error env ppf err = - Printtyp.wrap_printing_env env (fun () -> report_error env ppf err) - -let () = - Location.register_error_of_exn - (function - | Error (loc, env, err) -> - Some (Location.error_of_printer loc (report_error env) err) - | Error_forward err -> - Some err - | _ -> - None - ) - - -(* drop ?recarg argument from the external API *) -let type_expect ?in_function env e ty = type_expect ?in_function env e ty -let type_exp env e = type_exp env e -let type_argument env e t1 t2 = type_argument env e t1 t2 diff --git a/jscomp/ml/typecore.mli b/jscomp/ml/typecore.mli deleted file mode 100644 index 650bae0..0000000 --- a/jscomp/ml/typecore.mli +++ /dev/null @@ -1,142 +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. *) -(* *) -(**************************************************************************) - -(* Type inference for the core language *) - -open Asttypes -open Types -open Format - -val is_nonexpansive: Typedtree.expression -> bool - -val type_binding: - Env.t -> rec_flag -> - Parsetree.value_binding list -> - Annot.ident option -> - Typedtree.value_binding list * Env.t -val type_let: - Env.t -> rec_flag -> - Parsetree.value_binding list -> - Annot.ident option -> - Typedtree.value_binding list * Env.t -val type_expression: - Env.t -> Parsetree.expression -> Typedtree.expression -val check_partial: - ?lev:int -> Env.t -> type_expr -> - Location.t -> Typedtree.case list -> Typedtree.partial -val type_expect: - ?in_function:(Location.t * type_expr) -> - Env.t -> Parsetree.expression -> type_expr -> Typedtree.expression -val type_exp: - Env.t -> Parsetree.expression -> Typedtree.expression -val type_approx: - Env.t -> Parsetree.expression -> type_expr -val type_argument: - Env.t -> Parsetree.expression -> - type_expr -> type_expr -> Typedtree.expression - -val option_some: Typedtree.expression -> Typedtree.expression -val option_none: type_expr -> Location.t -> Typedtree.expression -val extract_option_type: Env.t -> type_expr -> type_expr -val iter_pattern: (Typedtree.pattern -> unit) -> Typedtree.pattern -> unit -val generalizable: int -> type_expr -> bool - - - -val id_of_pattern : Typedtree.pattern -> Ident.t option -val name_pattern : string -> Typedtree.case list -> Ident.t - -val self_coercion : (Path.t * Location.t list ref) list ref - -type error = - Polymorphic_label of Longident.t - | Constructor_arity_mismatch of Longident.t * int * int - | Label_mismatch of Longident.t * (type_expr * type_expr) list - | Pattern_type_clash of (type_expr * type_expr) list - | Or_pattern_type_clash of Ident.t * (type_expr * type_expr) list - | Multiply_bound_variable of string - | Orpat_vars of Ident.t * Ident.t list - | Expr_type_clash of (type_expr * type_expr) list * (Error_message_utils.typeClashContext option) - | Apply_non_function of type_expr - | Apply_wrong_label of arg_label * type_expr - | Label_multiply_defined of string - | Labels_missing of string list * bool - | Label_not_mutable of Longident.t - | Wrong_name of string * type_expr * string * Path.t * string * string list - | Name_type_mismatch of - string * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list - | Undefined_method of type_expr * string * string list option - | Private_type of type_expr - | Private_label of Longident.t * type_expr - | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list - | Coercion_failure of - type_expr * type_expr * (type_expr * type_expr) list * bool - | Too_many_arguments of bool * type_expr - | Abstract_wrong_label of arg_label * type_expr - | Scoping_let_module of string * type_expr - | Not_a_variant_type of Longident.t - | Incoherent_label_order - | Less_general of string * (type_expr * type_expr) list - | Modules_not_allowed - | Cannot_infer_signature - | Not_a_packed_module of type_expr - | Recursive_local_constraint of (type_expr * type_expr) list - | Unexpected_existential - | Unqualified_gadt_pattern of Path.t * string - | Invalid_interval - | Invalid_for_loop_index - | No_value_clauses - | Exception_pattern_below_toplevel - | Inlined_record_escape - | Inlined_record_expected - | Unrefuted_pattern of Typedtree.pattern - | Invalid_extension_constructor_payload - | Not_an_extension_constructor - | Literal_overflow of string - | Unknown_literal of string * char - | Illegal_letrec_pat - | Labels_omitted of string list - | Empty_record_literal - | Uncurried_arity_mismatch of type_expr * int * int - | Field_not_optional of string * type_expr -exception Error of Location.t * Env.t * error -exception Error_forward of Location.error - - -val super_report_error_no_wrap_printing_env: Env.t -> formatter -> error -> unit - - -val report_error: Env.t -> formatter -> error -> unit - (* Deprecated. Use Location.{error_of_exn, report_error}. *) - -(* Forward declaration, to be filled in by Typemod.type_module *) -val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref -(* Forward declaration, to be filled in by Typemod.type_open *) -val type_open: - (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Longident.t loc -> Path.t * Env.t) - ref -(* Forward declaration, to be filled in by Typeclass.class_structure *) -val type_package: - (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> - Typedtree.module_expr * type_expr list) ref - -val create_package_type : Location.t -> Env.t -> - Longident.t * (Longident.t * Parsetree.core_type) list -> - Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr - -val constant: Parsetree.constant -> (Asttypes.constant, error) result - - diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml deleted file mode 100644 index 532c093..0000000 --- a/jscomp/ml/typedecl.ml +++ /dev/null @@ -1,2206 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Jerome Vouillon, 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. *) -(* *) -(**************************************************************************) - -(**** Typing of type definitions ****) - -open Misc -open Asttypes -open Parsetree -open Primitive -open Types -open Typetexp - -type native_repr_kind = Unboxed | Untagged - -type error = - Repeated_parameter - | Duplicate_constructor of string - | Duplicate_label of string * string option - | Recursive_abbrev of string - | Cycle_in_def of string * type_expr - | Definition_mismatch of type_expr * Includecore.type_mismatch list - | Constraint_failed of type_expr * type_expr - | Inconsistent_constraint of Env.t * (type_expr * type_expr) list - | Type_clash of Env.t * (type_expr * type_expr) list - | Parameters_differ of Path.t * type_expr * type_expr - | Null_arity_external - | Unbound_type_var of type_expr * type_declaration - | Cannot_extend_private_type of Path.t - | Not_extensible_type of Path.t - | Extension_mismatch of Path.t * Includecore.type_mismatch list - | Rebind_wrong_type of Longident.t * Env.t * (type_expr * type_expr) list - | Rebind_mismatch of Longident.t * Path.t * Path.t - | Rebind_private of Longident.t - | Bad_variance of int * (bool * bool * bool) * (bool * bool * bool) - | Unavailable_type_constructor of Path.t - | Bad_fixed_type of string - | Unbound_type_var_ext of type_expr * extension_constructor - | Varying_anonymous - | Val_in_structure - | Bad_immediate_attribute - | Bad_unboxed_attribute of string - | Boxed_and_unboxed - | Nonrec_gadt - | Variant_runtime_representation_mismatch of Variant_coercion.variant_error - | Variant_spread_fail of Variant_type_spread.variant_type_spread_error - -open Typedtree - -exception Error of Location.t * error - -(* Note: do not factor the branches in the following pattern-matching: - the records must be constants for the compiler to do sharing on them. -*) -let get_unboxed_from_attributes sdecl = - let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in - let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in - match boxed, unboxed, !Clflags.unboxed_types with - | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed)) - | true, false, _ -> unboxed_false_default_false - | false, true, _ -> unboxed_true_default_false - | false, false, false -> unboxed_false_default_true - | false, false, true -> unboxed_true_default_true - -(* Enter all declared types in the environment as abstract types *) - -let enter_type rec_flag env sdecl id = - let needed = - match rec_flag with - | Asttypes.Nonrecursive -> - begin match sdecl.ptype_kind with - | Ptype_variant scds -> - List.iter (fun cd -> - if cd.pcd_res <> None then raise (Error(cd.pcd_loc, Nonrec_gadt))) - scds - | _ -> () - end; - Btype.is_row_name (Ident.name id) - | Asttypes.Recursive -> true - in - if not needed then env else - let decl = - { type_params = - List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; - type_arity = List.length sdecl.ptype_params; - type_kind = Type_abstract; - type_private = sdecl.ptype_private; - type_manifest = - begin match sdecl.ptype_manifest with None -> None - | Some _ -> Some(Ctype.newvar ()) end; - type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params; - type_newtype_level = None; - type_loc = sdecl.ptype_loc; - type_attributes = sdecl.ptype_attributes; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - in - Env.add_type ~check:true id decl env - -let update_type temp_env env id loc = - let path = Path.Pident id in - let decl = Env.find_type path temp_env in - match decl.type_manifest with None -> () - | Some ty -> - let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in - try Ctype.unify env (Ctype.newconstr path params) ty - with Ctype.Unify trace -> - raise (Error(loc, Type_clash (env, trace))) - -(* We use the Ctype.expand_head_opt version of expand_head to get access - to the manifest type of private abbreviations. *) -let rec get_unboxed_type_representation env ty fuel = - if fuel < 0 then None else - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in - match ty.desc with - | Tconstr (p, args, _) -> - begin match Env.find_type p env with - | exception Not_found -> Some ty - | {type_unboxed = {unboxed = false}} -> Some ty - | {type_params; type_kind = - Type_record ([{ld_type = ty2; _}], _) - | Type_variant [{cd_args = Cstr_tuple [ty2]; _}] - | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]} - - -> get_unboxed_type_representation env - (Ctype.apply env type_params ty2 args) (fuel - 1) - | {type_kind=Type_abstract} -> None - (* This case can occur when checking a recursive unboxed type - declaration. *) - | _ -> assert false (* only the above can be unboxed *) - end - | _ -> Some ty - -let get_unboxed_type_representation env ty = - (* Do not give too much fuel: PR#7424 *) - get_unboxed_type_representation env ty 100 -;; - - -(* Determine if a type definition defines a fixed type. (PW) *) -let is_fixed_type sd = - let rec has_row_var sty = - match sty.ptyp_desc with - Ptyp_alias (sty, _) -> has_row_var sty - | Ptyp_class _ - | Ptyp_object (_, Open) - | Ptyp_variant (_, Open, _) - | Ptyp_variant (_, Closed, Some _) -> true - | _ -> false - in - match sd.ptype_manifest with - None -> false - | Some sty -> - sd.ptype_kind = Ptype_abstract && - sd.ptype_private = Private && - has_row_var sty - -(* Set the row variable in a fixed type *) -let set_fixed_row env loc p decl = - let tm = - match decl.type_manifest with - None -> assert false - | Some t -> Ctype.expand_head env t - in - let rv = - match tm.desc with - Tvariant row -> - let row = Btype.row_repr row in - tm.desc <- Tvariant {row with row_fixed = true}; - if Btype.static_row row then Btype.newgenty Tnil - else row.row_more - | Tobject (ty, _) -> - snd (Ctype.flatten_fields ty) - | _ -> - raise (Error (loc, Bad_fixed_type "is not an object or variant")) - in - if not (Btype.is_Tvar rv) then - raise (Error (loc, Bad_fixed_type "has no row variable")); - rv.desc <- Tconstr (p, decl.type_params, ref Mnil) - -(* Translate one type declaration *) - -module StringSet = - Set.Make(struct - type t = string - let compare (x:t) y = compare x y - end) - -let make_params env params = - let make_param (sty, v) = - try - (transl_type_param env sty, v) - with Already_bound -> - raise(Error(sty.ptyp_loc, Repeated_parameter)) - in - List.map make_param params - -let transl_labels ?recordName env closed lbls = - if !Config.bs_only then - match !Builtin_attributes.check_duplicated_labels lbls with - | None -> () - | Some {loc;txt=name} -> raise (Error(loc,Duplicate_label (name, recordName))) - else ( - let all_labels = ref StringSet.empty in - List.iter - (fun {pld_name = {txt=name; loc}} -> - if StringSet.mem name !all_labels then - raise(Error(loc, Duplicate_label (name, recordName))); - all_labels := StringSet.add name !all_labels) - lbls); - let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc; - pld_attributes=attrs} = - Builtin_attributes.warning_scope attrs - (fun () -> - let arg = Ast_helper.Typ.force_poly arg in - let cty = transl_simple_type env closed arg in - {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; - ld_type = cty; ld_loc = loc; ld_attributes = attrs} - ) - in - let lbls = List.map mk lbls in - let lbls' = - List.map - (fun ld -> - let ty = ld.ld_type.ctyp_type in - let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in - {Types.ld_id = ld.ld_id; - ld_mutable = ld.ld_mutable; - ld_type = ty; - ld_loc = ld.ld_loc; - ld_attributes = ld.ld_attributes - } - ) - lbls in - lbls, lbls' - -let transl_constructor_arguments env closed = function - | Pcstr_tuple l -> - let l = List.map (transl_simple_type env closed) l in - Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), - Cstr_tuple l - | Pcstr_record l -> - let lbls, lbls' = transl_labels env closed l in - Types.Cstr_record lbls', - Cstr_record lbls - -let make_constructor env type_path type_params sargs sret_type = - match sret_type with - | None -> - let args, targs = - transl_constructor_arguments env true sargs - in - targs, None, args, None, type_params - | Some sret_type -> - (* if it's a generalized constructor we must first narrow and - then widen so as to not introduce any new constraints *) - let z = narrow () in - reset_type_variables (); - let args, targs = - transl_constructor_arguments env false sargs - in - let tret_type = transl_simple_type env false sret_type in - let ret_type = tret_type.ctyp_type in - let params = - match (Ctype.repr ret_type).desc with - | Tconstr (p', params, _) when Path.same type_path p' -> - params - | _ -> - raise (Error (sret_type.ptyp_loc, Constraint_failed - (ret_type, Ctype.newconstr type_path type_params))) - in - widen z; - targs, Some tret_type, args, Some ret_type, params - - -(* Check that all the variables found in [ty] are in [univ]. - Because [ty] is the argument to an abstract type, the representation - of that abstract type could be any subexpression of [ty], in particular - any type variable present in [ty]. -*) - - -let transl_declaration ~typeRecordAsObject env sdecl id = - (* Bind type parameters *) - reset_type_variables(); - Ctype.begin_def (); - let tparams = make_params env sdecl.ptype_params in - let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in - let cstrs = List.map - (fun (sty, sty', loc) -> - transl_simple_type env false sty, - transl_simple_type env false sty', loc) - sdecl.ptype_cstrs - in - let raw_status = get_unboxed_from_attributes sdecl in - - let checkUntaggedVariant() = match sdecl.ptype_kind with - | Ptype_variant cds -> Ext_list.for_all cds (function - | {pcd_args = Pcstr_tuple ([] | [_])} -> - (* at most one payload allowed for untagged variants *) - true - | {pcd_args = Pcstr_tuple (_::_::_); pcd_name={txt=name}} -> - Ast_untagged_variants.reportConstructorMoreThanOneArg ~loc:sdecl.ptype_loc ~name - | {pcd_args = Pcstr_record _} -> true - ) - | _ -> false - in - - if raw_status.unboxed && not raw_status.default && not (checkUntaggedVariant()) then begin - match sdecl.ptype_kind with - | Ptype_abstract -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "it is abstract")) - | Ptype_variant _ -> () - | Ptype_record [{pld_mutable=Immutable; _}] -> () - | Ptype_record [{pld_mutable=Mutable; _}] -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "it is mutable")) - | Ptype_record _ -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "it has more than one field")) - | Ptype_open -> - raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute - "extensible variant types cannot be unboxed")) - end; - let unboxed_status = - match sdecl.ptype_kind with - | Ptype_variant [{pcd_args = Pcstr_tuple []; _}] -> - unboxed_false_default_false - | Ptype_variant [{pcd_args = Pcstr_tuple _; _}] - | Ptype_variant [{pcd_args = Pcstr_record - [{pld_mutable = Immutable; _}]; _}] - | Ptype_record [{pld_mutable = Immutable; _}] -> - raw_status - | _ -> (* The type is not unboxable, mark it as boxed *) - unboxed_false_default_false - in - let unbox = unboxed_status.unboxed in - let (tkind, kind, sdecl) = - match sdecl.ptype_kind with - | Ptype_abstract -> Ttype_abstract, Type_abstract, sdecl - | Ptype_variant scstrs -> - assert (scstrs <> []); - if List.exists (fun cstr -> cstr.pcd_res <> None) scstrs then begin - match cstrs with - [] -> () - | (_,_,loc)::_ -> - Location.prerr_warning loc Warnings.Constraint_on_gadt - end; - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in - let scstrs = - Ext_list.map scstrs (fun ({pcd_args} as cstr) -> - match pcd_args with - | Pcstr_tuple _ -> cstr - | Pcstr_record lds -> - {cstr with pcd_args = Pcstr_record (Ext_list.map lds (fun ld -> - if has_optional ld.pld_attributes then - let typ = ld.pld_type in - let typ = {typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])} in - {ld with pld_type = typ} - else ld - ))} - ) in - let all_constrs = ref StringSet.empty in - List.iter - (fun {pcd_name = {txt = name}} -> - if StringSet.mem name !all_constrs then - raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); - all_constrs := StringSet.add name !all_constrs) - scstrs; - let copy_tag_attr_from_decl attr = - let tag_attrs = Ext_list.filter sdecl.ptype_attributes (fun ({txt}, _) -> txt = "tag" || txt = Ast_untagged_variants.untagged) in - if tag_attrs = [] then attr else tag_attrs @ attr in - let constructors_from_variant_spreads = Hashtbl.create 10 in - let make_cstr scstr = - let name = Ident.create scstr.pcd_name.txt in - let targs, tret_type, args, ret_type, _cstr_params = - make_constructor env (Path.Pident id) params - scstr.pcd_args scstr.pcd_res - in - if String.starts_with scstr.pcd_name.txt ~prefix:"..." then ( - (* Any constructor starting with "..." represents a variant type spread, and - will have the spread variant itself as a single argument. - - We pull that variant type out, and then track the type of each of its - constructors, so that we can replace our dummy constructors added before - type checking with the realtypes for each constructor. - *) - (match args with - | Cstr_tuple [spread_variant] -> ( - match Ctype.extract_concrete_typedecl env spread_variant with - | (_, _, {type_kind=Type_variant constructors}) -> ( - constructors |> List.iter(fun (c: Types.constructor_declaration) -> - Hashtbl.add constructors_from_variant_spreads c.cd_id.name c) - ) - | _ -> () - ) - | _ -> ()); - None) - else ( - (* Check if this constructor is from a variant spread. If so, we need to replace - its type with the right type we've pulled from the type checked spread variant - itself. *) - let tcstr, cstr = match Hashtbl.find_opt constructors_from_variant_spreads (Ident.name name) with - | Some cstr -> - let tcstr = - { - cd_id = name; - cd_name = scstr.pcd_name; - cd_args = - (match cstr.cd_args with - | Cstr_tuple args -> - Cstr_tuple - (args - |> List.map (fun texpr : Typedtree.core_type -> - { - ctyp_attributes = cstr.cd_attributes; - ctyp_loc = cstr.cd_loc; - ctyp_env = env; - ctyp_type = texpr; - ctyp_desc = Ttyp_any; - (* This is fine because the type checker seems to only look at `ctyp_type` for type checking. *) - })) - | Cstr_record lbls -> - Cstr_record - (lbls - |> List.map - (fun (l : Types.label_declaration) : Typedtree.label_declaration - -> - { - ld_id = l.ld_id; - ld_name = Location.mkloc (Ident.name l.ld_id) l.ld_loc; - ld_mutable = l.ld_mutable; - ld_type = - { - ctyp_desc = Ttyp_any; - ctyp_type = l.ld_type; - ctyp_env = env; - ctyp_loc = l.ld_loc; - ctyp_attributes = []; - }; - ld_loc = l.ld_loc; - ld_attributes = l.ld_attributes; - }))); - cd_res = tret_type; - (* This is also strictly wrong, but is fine because the type checker does not look at this field. *) - cd_loc = scstr.pcd_loc; - cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl; - } - in - tcstr, cstr - | None -> - let tcstr = - { cd_id = name; - cd_name = scstr.pcd_name; - cd_args = targs; - cd_res = tret_type; - cd_loc = scstr.pcd_loc; - cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl } - in - let cstr = - { Types.cd_id = name; - cd_args = args; - cd_res = ret_type; - cd_loc = scstr.pcd_loc; - cd_attributes = scstr.pcd_attributes |> copy_tag_attr_from_decl } - in - tcstr, cstr - in Some (tcstr, cstr) - ) - in - let make_cstr scstr = - Builtin_attributes.warning_scope scstr.pcd_attributes - (fun () -> make_cstr scstr) - in - let tcstrs, cstrs = List.split (List.filter_map make_cstr scstrs) in - let isUntaggedDef = Ast_untagged_variants.has_untagged sdecl.ptype_attributes in - Ast_untagged_variants.check_well_formed ~env ~isUntaggedDef cstrs; - Ttype_variant tcstrs, Type_variant cstrs, sdecl - | Ptype_record lbls_ -> - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "res.optional") in - let optionalLabels = - Ext_list.filter_map lbls_ - (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in - let lbls = - if optionalLabels = [] then lbls_ - else Ext_list.map lbls_ (fun lbl -> - let typ = lbl.pld_type in - let typ = - if has_optional lbl.pld_attributes then - {typ with ptyp_desc = Ptyp_constr ({txt = Lident "option"; loc=typ.ptyp_loc}, [typ])} - else typ in - {lbl with pld_type = typ }) in - let lbls, lbls' = transl_labels ~recordName:(sdecl.ptype_name.txt) env true lbls in - let lbls_opt = match Record_type_spread.has_type_spread lbls with - | true -> - let rec extract t = match t.desc with - | Tpoly(t, []) -> extract t - | _ -> Ctype.repr t in - let mkLbl (l: Types.label_declaration) (ld_type: Typedtree.core_type) (type_vars: (string * Types.type_expr) list) : Typedtree.label_declaration = - { - ld_id = l.ld_id; - ld_name = {txt = Ident.name l.ld_id; loc = l.ld_loc}; - ld_mutable = l.ld_mutable; - ld_type = {ld_type with ctyp_type = Record_type_spread.substitute_type_vars type_vars l.ld_type}; - ld_loc = l.ld_loc; - ld_attributes = l.ld_attributes; - } in - let rec process_lbls acc lbls lbls' = match lbls, lbls' with - | {ld_name = {txt = "..."}; ld_type} :: rest, _ :: rest' -> - (match Ctype.extract_concrete_typedecl env (extract ld_type.ctyp_type) with - (_p0, _p, {type_kind=Type_record (fields, _repr); type_params}) -> - let type_vars = Record_type_spread.extract_type_vars type_params ld_type.ctyp_type in - process_lbls - ( fst acc - @ (Ext_list.map fields (fun l -> - mkLbl l ld_type type_vars)) - , - snd acc - @ (Ext_list.map fields (fun l -> - { - l with - ld_type = - Record_type_spread.substitute_type_vars type_vars l.ld_type; - })) ) - rest rest' - | _ -> assert false - | exception _ -> None) - | lbl::rest, lbl'::rest' -> process_lbls (fst acc @ [lbl], snd acc @ [lbl']) rest rest' - | _ -> Some acc - in - process_lbls ([], []) lbls lbls' - | false -> Some (lbls, lbls') in - let rec check_duplicates loc (lbls : Typedtree.label_declaration list) seen = match lbls with - | [] -> () - | lbl::rest -> - let name = lbl.ld_id.name in - if StringSet.mem name seen then raise(Error(loc, Duplicate_label (name, Some sdecl.ptype_name.txt))); - check_duplicates loc rest (StringSet.add name seen) in - (match lbls_opt with - | Some (lbls, lbls') -> - check_duplicates sdecl.ptype_loc lbls StringSet.empty; - let optionalLabels = - Ext_list.filter_map lbls (fun lbl -> - if has_optional lbl.ld_attributes then Some lbl.ld_name.txt else None) - in - Ttype_record lbls, Type_record(lbls', if unbox then - Record_unboxed false - else if optionalLabels <> [] then - Record_optional_labels optionalLabels - else Record_regular), sdecl - | None -> - (* Could not find record type decl for ...t: assume t is an object type and this is syntax ambiguity *) - typeRecordAsObject := true; - let fields = Ext_list.map lbls_ (fun ld -> - match ld.pld_name.txt with - | "..." -> Parsetree.Oinherit ld.pld_type - | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) in - let sdecl = - {sdecl with - ptype_kind = Ptype_abstract; - ptype_manifest = Some (Ast_helper.Typ.object_ ~loc:sdecl.ptype_loc fields Closed); - } in - (Ttype_abstract, Type_abstract, sdecl)) - | Ptype_open -> Ttype_open, Type_open, sdecl - in - let (tman, man) = match sdecl.ptype_manifest with - None -> None, None - | Some sty -> - let no_row = not (is_fixed_type sdecl) in - let cty = transl_simple_type env no_row sty in - Some cty, Some cty.ctyp_type - in - let decl = - { type_params = params; - type_arity = List.length params; - type_kind = kind; - type_private = sdecl.ptype_private; - type_manifest = man; - type_variance = List.map (fun _ -> Variance.full) params; - type_newtype_level = None; - type_loc = sdecl.ptype_loc; - type_attributes = sdecl.ptype_attributes; - type_immediate = false; - type_unboxed = unboxed_status; - } in - - (* Check constraints *) - List.iter - (fun (cty, cty', loc) -> - let ty = cty.ctyp_type in - let ty' = cty'.ctyp_type in - try Ctype.unify env ty ty' with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint (env, tr)))) - cstrs; - Ctype.end_def (); - (* Add abstract row *) - if is_fixed_type sdecl then begin - let p = - try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env - with Not_found -> assert false in - set_fixed_row env sdecl.ptype_loc p decl - end; - (* Check for cyclic abbreviations *) - begin match decl.type_manifest with None -> () - | Some ty -> - if Ctype.cyclic_abbrev env id ty then - raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt)); - end; - { - typ_id = id; - typ_name = sdecl.ptype_name; - typ_params = tparams; - typ_type = decl; - typ_cstrs = cstrs; - typ_loc = sdecl.ptype_loc; - typ_manifest = tman; - typ_kind = tkind; - typ_private = sdecl.ptype_private; - typ_attributes = sdecl.ptype_attributes; - } - -(* Generalize a type declaration *) - -let generalize_decl decl = - List.iter Ctype.generalize decl.type_params; - Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; - begin match decl.type_manifest with - | None -> () - | Some ty -> Ctype.generalize ty - end - -(* Check that all constraints are enforced *) - -module TypeSet = Btype.TypeSet -module TypeMap = Btype.TypeMap - -let rec check_constraints_rec env loc visited ty = - let ty = Ctype.repr ty in - if TypeSet.mem ty !visited then () else begin - visited := TypeSet.add ty !visited; - match ty.desc with - | Tconstr (path, args, _) -> - let args' = List.map (fun _ -> Ctype.newvar ()) args in - let ty' = Ctype.newconstr path args' in - begin try Ctype.enforce_constraints env ty' - with Ctype.Unify _ -> assert false - | Not_found -> raise (Error(loc, Unavailable_type_constructor path)) - end; - if not (Ctype.matches env ty ty') then - raise (Error(loc, Constraint_failed (ty, ty'))); - List.iter (check_constraints_rec env loc visited) args - | Tpoly (ty, tl) -> - let _, ty = Ctype.instance_poly false tl ty in - check_constraints_rec env loc visited ty - | _ -> - Btype.iter_type_expr (check_constraints_rec env loc visited) ty - end - -module SMap = Map.Make(String) - -let check_constraints_labels env visited l pl = - let rec get_loc name = function - [] -> Location.none - | pld :: tl -> - if name = pld.pld_name.txt then pld.pld_type.ptyp_loc - else get_loc name tl - in - List.iter - (fun {Types.ld_id=name; ld_type=ty} -> - check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) - l - -let check_constraints ~typeRecordAsObject env sdecl (_, decl) = - let visited = ref TypeSet.empty in - begin match decl.type_kind with - | Type_abstract -> () - | Type_variant l -> - let find_pl = function - Ptype_variant pl -> pl - | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false - in - let pl = find_pl sdecl.ptype_kind in - let pl_index = - let foldf acc x = - SMap.add x.pcd_name.txt x acc - in - List.fold_left foldf SMap.empty pl - in - List.iter - (fun {Types.cd_id=name; cd_args; cd_res} -> - let {pcd_args; pcd_res; _} = - try SMap.find (Ident.name name) pl_index - with Not_found -> assert false in - begin match cd_args, pcd_args with - | Cstr_tuple tyl, Pcstr_tuple styl -> - List.iter2 - (fun sty ty -> - check_constraints_rec env sty.ptyp_loc visited ty) - styl tyl - | Cstr_record tyl, Pcstr_record styl -> - check_constraints_labels env visited tyl styl - | _ -> assert false - end; - match pcd_res, cd_res with - | Some sr, Some r -> - check_constraints_rec env sr.ptyp_loc visited r - | _ -> - () ) - l - | Type_record (l, _) -> - let find_pl = function - Ptype_record pl -> pl - | Ptype_variant _ | Ptype_abstract | Ptype_open -> assert false - in - let pl = find_pl sdecl.ptype_kind in - check_constraints_labels env visited l pl - | Type_open -> () - end; - begin match decl.type_manifest with - | None -> () - | Some ty -> - if not !typeRecordAsObject then - let sty = - match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false - in - check_constraints_rec env sty.ptyp_loc visited ty - - end - -(* - If both a variant/record definition and a type equation are given, - need to check that the equation refers to a type of the same kind - with the same constructors and labels. -*) -let check_coherence env loc id decl = - match decl with - { type_kind = (Type_variant _ | Type_record _| Type_open); - type_manifest = Some ty } -> - begin match (Ctype.repr ty).desc with - Tconstr(path, args, _) -> - begin try - let decl' = Env.find_type path env in - let err = - if List.length args <> List.length decl.type_params - then [Includecore.Arity] - else if not (Ctype.equal env false args decl.type_params) - then [Includecore.Constraint] - else - Includecore.type_declarations ~loc ~equality:true env - (Path.last path) - decl' - id - (Subst.type_declaration - (Subst.add_type id path Subst.identity) decl) - in - if err <> [] then - raise(Error(loc, Definition_mismatch (ty, err))) - with Not_found -> - raise(Error(loc, Unavailable_type_constructor path)) - end - | _ -> raise(Error(loc, Definition_mismatch (ty, []))) - end - | _ -> () - -let check_abbrev env sdecl (id, decl) = - check_coherence env sdecl.ptype_loc id decl - -(* Check that recursion is well-founded *) - -let check_well_founded env loc path to_check ty = - let visited = ref TypeMap.empty in - let rec check ty0 parents ty = - let ty = Btype.repr ty in - if TypeSet.mem ty parents then begin - (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) - if match ty0.desc with - | Tconstr (p, _, _) -> Path.same p path - | _ -> false - then raise (Error (loc, Recursive_abbrev (Path.name path))) - else raise (Error (loc, Cycle_in_def (Path.name path, ty0))) - end; - let (fini, parents) = - try - let prev = TypeMap.find ty !visited in - if TypeSet.subset parents prev then (true, parents) else - (false, TypeSet.union parents prev) - with Not_found -> - (false, parents) - in - if fini then () else - let rec_ok = - match ty.desc with - Tconstr(_p,_,_) -> - false (*!Clflags.recursive_types && Ctype.is_contractive env p*) - | Tobject _ | Tvariant _ -> true - | _ -> false (* !Clflags.recursive_types*) - in - let visited' = TypeMap.add ty parents !visited in - let arg_exn = - try - visited := visited'; - let parents = - if rec_ok then TypeSet.empty else TypeSet.add ty parents in - Btype.iter_type_expr (check ty0 parents) ty; - None - with e -> - visited := visited'; Some e - in - match ty.desc with - | Tconstr(p, _, _) when arg_exn <> None || to_check p -> - if to_check p then may raise arg_exn - else Btype.iter_type_expr (check ty0 TypeSet.empty) ty; - begin try - let ty' = Ctype.try_expand_once_opt env ty in - let ty0 = if TypeSet.is_empty parents then ty else ty0 in - check ty0 (TypeSet.add ty parents) ty' - with - Ctype.Cannot_expand -> may raise arg_exn - end - | _ -> may raise arg_exn - in - let snap = Btype.snapshot () in - try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty - with Ctype.Unify _ -> - (* Will be detected by check_recursion *) - Btype.backtrack snap - -let check_well_founded_manifest env loc path decl = - if decl.type_manifest = None then () else - let args = List.map (fun _ -> Ctype.newvar()) decl.type_params in - check_well_founded env loc path (Path.same path) (Ctype.newconstr path args) - -let check_well_founded_decl env loc path decl to_check = - let open Btype in - let it = - {type_iterators with - it_type_expr = (fun _ -> check_well_founded env loc path to_check)} in - it.it_type_declaration it (Ctype.instance_declaration decl) - -(* Check for ill-defined abbrevs *) - -let check_recursion env loc path decl to_check = - (* to_check is true for potentially mutually recursive paths. - (path, decl) is the type declaration to be checked. *) - - if decl.type_params = [] then () else - - let visited = ref [] in - - let rec check_regular cpath args prev_exp ty = - let ty = Ctype.repr ty in - if not (List.memq ty !visited) then begin - visited := ty :: !visited; - match ty.desc with - | Tconstr(path', args', _) -> - if Path.same path path' then begin - if not (Ctype.equal env false args args') then - raise (Error(loc, - Parameters_differ(cpath, ty, Ctype.newconstr path args))) - end - (* Attempt to expand a type abbreviation if: - 1- [to_check path'] holds - (otherwise the expansion cannot involve [path]); - 2- we haven't expanded this type constructor before - (otherwise we could loop if [path'] is itself - a non-regular abbreviation). *) - else if to_check path' && not (List.mem path' prev_exp) then begin - try - (* Attempt expansion *) - let (params0, body0, _) = Env.find_type_expansion path' env in - let (params, body) = - Ctype.instance_parameterized_type params0 body0 in - begin - try List.iter2 (Ctype.unify env) params args' - with Ctype.Unify _ -> - raise (Error(loc, Constraint_failed - (ty, Ctype.newconstr path' params0))); - end; - check_regular path' args (path' :: prev_exp) body - with Not_found -> () - end; - List.iter (check_regular cpath args prev_exp) args' - | Tpoly (ty, tl) -> - let (_, ty) = Ctype.instance_poly ~keep_names:true false tl ty in - check_regular cpath args prev_exp ty - | _ -> - Btype.iter_type_expr (check_regular cpath args prev_exp) ty - end in - - Misc.may - (fun body -> - let (args, body) = - Ctype.instance_parameterized_type - ~keep_names:true decl.type_params body in - check_regular path args [] body) - decl.type_manifest - -let check_abbrev_recursion env id_loc_list to_check tdecl = - let decl = tdecl.typ_type in - let id = tdecl.typ_id in - check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check - -(* Compute variance *) - -let get_variance ty visited = - try TypeMap.find ty !visited with Not_found -> Variance.null - -let compute_variance env visited vari ty = - let rec compute_variance_rec vari ty = - (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) - let ty = Ctype.repr ty in - let vari' = get_variance ty visited in - if Variance.subset vari vari' then () else - let vari = Variance.union vari vari' in - visited := TypeMap.add ty vari !visited; - let compute_same = compute_variance_rec vari in - match ty.desc with - Tarrow (_, ty1, ty2, _) -> - let open Variance in - let v = conjugate vari in - let v1 = - if mem May_pos v || mem May_neg v - then set May_weak true v else v - in - compute_variance_rec v1 ty1; - compute_same ty2 - | Ttuple tl -> - List.iter compute_same tl - | Tconstr (path, tl, _) -> - let open Variance in - if tl = [] then () else begin - try - let decl = Env.find_type path env in - let cvari f = mem f vari in - List.iter2 - (fun ty v -> - let cv f = mem f v in - let strict = - cvari Inv && cv Inj || (cvari Pos || cvari Neg) && cv Inv - in - if strict then compute_variance_rec full ty else - let p1 = inter v vari - and n1 = inter v (conjugate vari) in - let v1 = - union (inter covariant (union p1 (conjugate p1))) - (inter (conjugate covariant) (union n1 (conjugate n1))) - and weak = - cvari May_weak && (cv May_pos || cv May_neg) || - (cvari May_pos || cvari May_neg) && cv May_weak - in - let v2 = set May_weak weak v1 in - compute_variance_rec v2 ty) - tl decl.type_variance - with Not_found -> - List.iter (compute_variance_rec may_inv) tl - end - | Tobject (ty, _) -> - compute_same ty - | Tfield (_, _, ty1, ty2) -> - compute_same ty1; - compute_same ty2 - | Tsubst ty -> - compute_same ty - | Tvariant row -> - let row = Btype.row_repr row in - List.iter - (fun (_,f) -> - match Btype.row_field_repr f with - Rpresent (Some ty) -> - compute_same ty - | Reither (_, tyl, _, _) -> - let open Variance in - let upper = - List.fold_left (fun s f -> set f true s) - null [May_pos; May_neg; May_weak] - in - let v = inter vari upper in - (* cf PR#7269: - if List.length tyl > 1 then upper else inter vari upper *) - List.iter (compute_variance_rec v) tyl - | _ -> ()) - row.row_fields; - compute_same row.row_more - | Tpoly (ty, _) -> - compute_same ty - | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () - | Tpackage (_, _, tyl) -> - let v = - Variance.(if mem Pos vari || mem Neg vari then full else may_inv) - in - List.iter (compute_variance_rec v) tyl - in - compute_variance_rec vari ty - -let make p n i = - let open Variance in - set May_pos p (set May_neg n (set May_weak n (set Inj i null))) - -let compute_variance_type env check (required, loc) decl tyl = - (* Requirements *) - let required = - List.map (fun (c,n,i) -> if c || n then (c,n,i) else (true,true,i)) - required - in - (* Prepare *) - let params = List.map Btype.repr decl.type_params in - let tvl = ref TypeMap.empty in - (* Compute occurrences in the body *) - let open Variance in - List.iter - (fun (cn,ty) -> - compute_variance env tvl (if cn then full else covariant) ty) - tyl; - if check then begin - (* Check variance of parameters *) - let pos = ref 0 in - List.iter2 - (fun ty (c, n, i) -> - incr pos; - let var = get_variance ty tvl in - let (co,cn) = get_upper var and ij = mem Inj var in - if Btype.is_Tvar ty && (co && not c || cn && not n || not ij && i) - then raise (Error(loc, Bad_variance (!pos, (co,cn,ij), (c,n,i))))) - params required; - (* Check propagation from constrained parameters *) - let args = Btype.newgenty (Ttuple params) in - let fvl = Ctype.free_variables args in - let fvl = Ext_list.filter fvl (fun v -> not (List.memq v params)) in - (* If there are no extra variables there is nothing to do *) - if fvl = [] then () else - let tvl2 = ref TypeMap.empty in - List.iter2 - (fun ty (p,n,_) -> - if Btype.is_Tvar ty then () else - let v = - if p then if n then full else covariant else conjugate covariant in - compute_variance env tvl2 v ty) - params required; - let visited = ref TypeSet.empty in - let rec check ty = - let ty = Ctype.repr ty in - if TypeSet.mem ty !visited then () else - let visited' = TypeSet.add ty !visited in - visited := visited'; - let v1 = get_variance ty tvl in - let snap = Btype.snapshot () in - let v2 = - TypeMap.fold - (fun t vt v -> - if Ctype.equal env false [ty] [t] then union vt v else v) - !tvl2 null in - Btype.backtrack snap; - let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in - if c1 && not c2 || n1 && not n2 then - if List.memq ty fvl then - let code = if not i2 then -2 else if c2 || n2 then -1 else -3 in - raise (Error (loc, Bad_variance (code, (c1,n1,false), (c2,n2,false)))) - else - Btype.iter_type_expr check ty - in - List.iter (fun (_,ty) -> check ty) tyl; - end; - List.map2 - (fun ty (p, n, i) -> - let v = get_variance ty tvl in - let tr = decl.type_private in - (* Use required variance where relevant *) - let concr = decl.type_kind <> Type_abstract (*|| tr = Type_new*) in - let (p, n) = - if tr = Private || not (Btype.is_Tvar ty) then (p, n) (* set *) - else (false, false) (* only check *) - and i = concr || i && tr = Private in - let v = union v (make p n i) in - let v = - if not concr then v else - if mem Pos v && mem Neg v then full else - if Btype.is_Tvar ty then v else - union v - (if p then if n then full else covariant else conjugate covariant) - in - if decl.type_kind = Type_abstract && tr = Public then v else - set May_weak (mem May_neg v) v) - params required - -let add_false = List.map (fun ty -> false, ty) - -(* A parameter is constrained if it is either instantiated, - or it is a variable appearing in another parameter *) -let constrained vars ty = - match ty.desc with - | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars - | _ -> true - -let for_constr = function - | Types.Cstr_tuple l -> add_false l - | Types.Cstr_record l -> - List.map - (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) - l - -let compute_variance_gadt env check (required, loc as rloc) decl - (tl, ret_type_opt) = - match ret_type_opt with - | None -> - compute_variance_type env check rloc {decl with type_private = Private} - (for_constr tl) - | Some ret_type -> - match Ctype.repr ret_type with - | {desc=Tconstr (_, tyl, _)} -> - (* let tyl = List.map (Ctype.expand_head env) tyl in *) - let tyl = List.map Ctype.repr tyl in - let fvl = List.map (Ctype.free_variables ?env:None) tyl in - let _ = - List.fold_left2 - (fun (fv1,fv2) ty (c,n,_) -> - match fv2 with [] -> assert false - | fv :: fv2 -> - (* fv1 @ fv2 = free_variables of other parameters *) - if (c||n) && constrained (fv1 @ fv2) ty then - raise (Error(loc, Varying_anonymous)); - (fv :: fv1, fv2)) - ([], fvl) tyl required - in - compute_variance_type env check rloc - {decl with type_params = tyl; type_private = Private} - (for_constr tl) - | _ -> assert false - -let compute_variance_extension env check decl ext rloc = - compute_variance_gadt env check rloc - {decl with type_params = ext.ext_type_params} - (ext.ext_args, ext.ext_ret_type) - -let compute_variance_decl env check decl (required, _ as rloc) = - if (decl.type_kind = Type_abstract || decl.type_kind = Type_open) - && decl.type_manifest = None then - List.map - (fun (c, n, i) -> - make (not n) (not c) (decl.type_kind <> Type_abstract || i)) - required - else - let mn = - match decl.type_manifest with - None -> [] - | Some ty -> [false, ty] - in - match decl.type_kind with - Type_abstract | Type_open -> - compute_variance_type env check rloc decl mn - | Type_variant tll -> - if List.for_all (fun c -> c.Types.cd_res = None) tll then - compute_variance_type env check rloc decl - (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) - tll)) - else begin - let mn = - List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in - let tll = - mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in - match List.map (compute_variance_gadt env check rloc decl) tll with - | vari :: rem -> - let varl = List.fold_left (List.map2 Variance.union) vari rem in - List.map - Variance.(fun v -> if mem Pos v && mem Neg v then full else v) - varl - | _ -> assert false - end - | Type_record (ftl, _) -> - compute_variance_type env check rloc decl - (mn @ List.map (fun {Types.ld_mutable; ld_type} -> - (ld_mutable = Mutable, ld_type)) ftl) - -let is_hash id = - let s = Ident.name id in - String.length s > 0 && s.[0] = '#' - -let marked_as_immediate decl = - Builtin_attributes.immediate decl.type_attributes - -let compute_immediacy env tdecl = - match (tdecl.type_kind, tdecl.type_manifest) with - | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _) - | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _) - | (Type_record ([{ld_type = arg; _}], _), _) - when tdecl.type_unboxed.unboxed -> - begin match get_unboxed_type_representation env arg with - | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr) - | None -> false - end - | (Type_variant (_ :: _ as cstrs), _) -> - not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) - | (Type_abstract, Some(typ)) -> - not (Ctype.maybe_pointer_type env typ) - | (Type_abstract, None) -> marked_as_immediate tdecl - | _ -> false - -(* Computes the fixpoint for the variance and immediacy of type declarations *) - -let rec compute_properties_fixpoint env decls required variances immediacies = - let new_decls = - List.map2 - (fun (id, decl) (variance, immediacy) -> - id, {decl with type_variance = variance; type_immediate = immediacy}) - decls (List.combine variances immediacies) - in - let new_env = - List.fold_right - (fun (id, decl) env -> Env.add_type ~check:true id decl env) - new_decls env - in - let new_variances = - List.map2 - (fun (_id, decl) -> compute_variance_decl new_env false decl) - new_decls required - in - let new_variances = - List.map2 (List.map2 Variance.union) new_variances variances in - let new_immediacies = - List.map - (fun (_id, decl) -> compute_immediacy new_env decl) - new_decls - in - if new_variances <> variances || new_immediacies <> immediacies then - compute_properties_fixpoint env decls required new_variances new_immediacies - else begin - (* List.iter (fun (id, decl) -> - Printf.eprintf "%s:" (Ident.name id); - List.iter (fun (v : Variance.t) -> - Printf.eprintf " %x" (Obj.magic v : int)) - decl.type_variance; - prerr_endline "") - new_decls; *) - List.iter (fun (_, decl) -> - if (marked_as_immediate decl) && (not decl.type_immediate) then - raise (Error (decl.type_loc, Bad_immediate_attribute)) - else ()) - new_decls; - List.iter2 - (fun (id, decl) req -> if not (is_hash id) then - ignore (compute_variance_decl new_env true decl req)) - new_decls required; - new_decls, new_env - end - -let init_variance (_id, decl) = - List.map (fun _ -> Variance.null) decl.type_params - -let add_injectivity = - List.map - (function - | Covariant -> (true, false, false) - | Contravariant -> (false, true, false) - | Invariant -> (false, false, false) - ) - -(* for typeclass.ml *) -let compute_variance_decls env cldecls = - let decls, required = - List.fold_right - (fun (obj_id, obj_abbr, _cl_abbr, _clty, _cltydef, ci) (decls, req) -> - let variance = List.map snd ci.ci_params in - (obj_id, obj_abbr) :: decls, - (add_injectivity variance, ci.ci_loc) :: req) - cldecls ([],[]) - in - let (decls, _) = - compute_properties_fixpoint env decls required - (List.map init_variance decls) - (List.map (fun _ -> false) decls) - in - List.map2 - (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) -> - let variance = decl.type_variance in - (decl, {cl_abbr with type_variance = variance}, - {clty with cty_variance = variance}, - {cltydef with clty_variance = variance})) - decls cldecls - -(* Check multiple declarations of labels/constructors *) - -let check_duplicates sdecl_list = - let labels = Hashtbl.create 7 and constrs = Hashtbl.create 7 in - List.iter - (fun sdecl -> match sdecl.ptype_kind with - Ptype_variant cl -> - List.iter - (fun pcd -> - try - let name' = Hashtbl.find constrs pcd.pcd_name.txt in - Location.prerr_warning pcd.pcd_loc - (Warnings.Duplicate_definitions - ("constructor", pcd.pcd_name.txt, name', - sdecl.ptype_name.txt)) - with Not_found -> - Hashtbl.add constrs pcd.pcd_name.txt sdecl.ptype_name.txt) - cl - | Ptype_record fl -> - List.iter - (fun {pld_name=cname;pld_loc=loc} -> - try - let name' = Hashtbl.find labels cname.txt in - if cname.txt <> "..." then - Location.prerr_warning loc - (Warnings.Duplicate_definitions - ("label", cname.txt, name', sdecl.ptype_name.txt)) - with Not_found -> Hashtbl.add labels cname.txt sdecl.ptype_name.txt) - fl - | Ptype_abstract -> () - | Ptype_open -> ()) - sdecl_list - -(* Force recursion to go through id for private types*) -let name_recursion sdecl id decl = - match decl with - | { type_kind = Type_abstract; - type_manifest = Some ty; - type_private = Private; } when is_fixed_type sdecl -> - let ty = Ctype.repr ty in - let ty' = Btype.newty2 ty.level ty.desc in - if Ctype.deep_occur ty ty' then - let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in - Btype.link_type ty (Btype.newty2 ty.level td); - {decl with type_manifest = Some ty'} - else decl - | _ -> decl - -(* Translate a set of type declarations, mutually recursive or not *) -let transl_type_decl env rec_flag sdecl_list = - (* Add dummy types for fixed rows *) - let fixed_types = Ext_list.filter sdecl_list is_fixed_type in - let sdecl_list = - List.map - (fun sdecl -> - let ptype_name = - mkloc (sdecl.ptype_name.txt ^"#row") sdecl.ptype_name.loc in - {sdecl with - ptype_name; ptype_kind = Ptype_abstract; ptype_manifest = None}) - fixed_types - @ (try - sdecl_list |> Variant_type_spread.expand_variant_spreads env - with - | Variant_coercion.VariantConfigurationError ((VariantError {left_loc}) as err) -> raise(Error(left_loc, Variant_runtime_representation_mismatch err)) - | Variant_type_spread.VariantTypeSpreadError (loc, err) -> raise(Error(loc, Variant_spread_fail err)) - ) - in - - (* Create identifiers. *) - let id_list = - List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list - in - (* - Since we've introduced fresh idents, make sure the definition - level is at least the binding time of these events. Otherwise, - passing one of the recursively-defined type constrs as argument - to an abbreviation may fail. - *) - Ctype.init_def(Ident.current_time()); - Ctype.begin_def(); - (* Enter types. *) - let temp_env = - List.fold_left2 (enter_type rec_flag) env sdecl_list id_list in - (* Translate each declaration. *) - let current_slot = ref None in - let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in - let id_slots id = - match rec_flag with - | Asttypes.Recursive when warn_unused -> - (* See typecore.ml for a description of the algorithm used - to detect unused declarations in a set of recursive definitions. *) - let slot = ref [] in - let td = Env.find_type (Path.Pident id) temp_env in - let name = Ident.name id in - Env.set_type_used_callback - name td - (fun old_callback -> - match !current_slot with - | Some slot -> slot := (name, td) :: !slot - | None -> - List.iter (fun (name, d) -> Env.mark_type_used env name d) - (get_ref slot); - old_callback () - ); - id, Some slot - | Asttypes.Recursive | Asttypes.Nonrecursive -> - id, None - in - let typeRecordAsObject = ref false in - let transl_declaration name_sdecl (id, slot) = - current_slot := slot; - Builtin_attributes.warning_scope - name_sdecl.ptype_attributes - (fun () -> transl_declaration ~typeRecordAsObject temp_env name_sdecl id) - in - let tdecls = - List.map2 transl_declaration sdecl_list (List.map id_slots id_list) in - let decls = - List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in - let sdecl_list = Variant_type_spread.expand_dummy_constructor_args sdecl_list decls in - current_slot := None; - (* Check for duplicates *) - check_duplicates sdecl_list; - (* Build the final env. *) - let newenv = - List.fold_right - (fun (id, decl) env -> Env.add_type ~check:true id decl env) - decls env - in - (* Update stubs *) - begin match rec_flag with - | Asttypes.Nonrecursive -> () - | Asttypes.Recursive -> - List.iter2 - (fun id sdecl -> update_type temp_env newenv id sdecl.ptype_loc) - id_list sdecl_list - end; - (* Generalize type declarations. *) - Ctype.end_def(); - List.iter (fun (_, decl) -> generalize_decl decl) decls; - (* Check for ill-formed abbrevs *) - let id_loc_list = - List.map2 (fun id sdecl -> (id, sdecl.ptype_loc)) - id_list sdecl_list - in - List.iter (fun (id, decl) -> - check_well_founded_manifest newenv (List.assoc id id_loc_list) - (Path.Pident id) decl) - decls; - let to_check = - function Path.Pident id -> List.mem_assoc id id_loc_list | _ -> false in - List.iter (fun (id, decl) -> - check_well_founded_decl newenv (List.assoc id id_loc_list) (Path.Pident id) - decl to_check) - decls; - List.iter (check_abbrev_recursion newenv id_loc_list to_check) tdecls; - (* Check that all type variables are closed *) - List.iter2 - (fun sdecl tdecl -> - let decl = tdecl.typ_type in - match Ctype.closed_type_decl decl with - Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) - | None -> ()) - sdecl_list tdecls; - (* Check that constraints are enforced *) - List.iter2 (check_constraints ~typeRecordAsObject newenv) sdecl_list decls; - (* Name recursion *) - let decls = - List.map2 (fun sdecl (id, decl) -> id, name_recursion sdecl id decl) - sdecl_list decls - in - (* Add variances to the environment *) - let required = - List.map - (fun sdecl -> - add_injectivity (List.map snd sdecl.ptype_params), - sdecl.ptype_loc - ) - sdecl_list - in - let final_decls, final_env = - compute_properties_fixpoint env decls required - (List.map init_variance decls) - (List.map (fun _ -> false) decls) - in - (* Check re-exportation *) - List.iter2 (check_abbrev final_env) sdecl_list final_decls; - (* Keep original declaration *) - let final_decls = - List.map2 - (fun tdecl (_id2, decl) -> - { tdecl with typ_type = decl } - ) tdecls final_decls - in - (* Done *) - (final_decls, final_env) - -(* Translating type extensions *) - -let transl_extension_constructor env type_path type_params - typext_params priv sext = - let id = Ident.create sext.pext_name.txt in - let args, ret_type, kind = - match sext.pext_kind with - Pext_decl(sargs, sret_type) -> - let targs, tret_type, args, ret_type, _ = - make_constructor env type_path typext_params - sargs sret_type - in - args, ret_type, Text_decl(targs, tret_type) - | Pext_rebind lid -> - let cdescr = Typetexp.find_constructor env lid.loc lid.txt in - let usage = - if cdescr.cstr_private = Private || priv = Public - then Env.Positive else Env.Privatize - in - Env.mark_constructor usage env (Longident.last lid.txt) cdescr; - let (args, cstr_res) = Ctype.instance_constructor cdescr in - let res, ret_type = - if cdescr.cstr_generalized then - let params = Ctype.instance_list env type_params in - let res = Ctype.newconstr type_path params in - let ret_type = Some (Ctype.newconstr type_path params) in - res, ret_type - else (Ctype.newconstr type_path typext_params), None - in - begin - try - Ctype.unify env cstr_res res - with Ctype.Unify trace -> - raise (Error(lid.loc, - Rebind_wrong_type(lid.txt, env, trace))) - end; - (* Remove "_" names from parameters used in the constructor *) - if not cdescr.cstr_generalized then begin - let vars = - Ctype.free_variables (Btype.newgenty (Ttuple args)) - in - List.iter - (function {desc = Tvar (Some "_")} as ty -> - if List.memq ty vars then ty.desc <- Tvar None - | _ -> ()) - typext_params - end; - (* Ensure that constructor's type matches the type being extended *) - let cstr_type_path, cstr_type_params = - match cdescr.cstr_res.desc with - Tconstr (p, _, _) -> - let decl = Env.find_type p env in - p, decl.type_params - | _ -> assert false - in - let cstr_types = - (Btype.newgenty - (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) - :: cstr_type_params - in - let ext_types = - (Btype.newgenty - (Tconstr(type_path, type_params, ref Mnil))) - :: type_params - in - if not (Ctype.equal env true cstr_types ext_types) then - raise (Error(lid.loc, - Rebind_mismatch(lid.txt, cstr_type_path, type_path))); - (* Disallow rebinding private constructors to non-private *) - begin - match cdescr.cstr_private, priv with - Private, Public -> - raise (Error(lid.loc, Rebind_private lid.txt)) - | _ -> () - end; - let path = - match cdescr.cstr_tag with - Cstr_extension(path, _) -> path - | _ -> assert false - in - let args = - match cdescr.cstr_inlined with - | None -> - Types.Cstr_tuple args - | Some decl -> - let tl = - match args with - | [ {desc=Tconstr(_, tl, _)} ] -> tl - | _ -> assert false - in - let decl = Ctype.instance_declaration decl in - assert (List.length decl.type_params = List.length tl); - List.iter2 (Ctype.unify env) decl.type_params tl; - let lbls = - match decl.type_kind with - | Type_record (lbls, Record_extension) -> lbls - | _ -> assert false - in - Types.Cstr_record lbls - in - args, ret_type, Text_rebind(path, lid) - in - let ext = - { ext_type_path = type_path; - ext_type_params = typext_params; - ext_args = args; - ext_ret_type = ret_type; - ext_private = priv; - Types.ext_loc = sext.pext_loc; - Types.ext_attributes = sext.pext_attributes; } - in - { ext_id = id; - ext_name = sext.pext_name; - ext_type = ext; - ext_kind = kind; - Typedtree.ext_loc = sext.pext_loc; - Typedtree.ext_attributes = sext.pext_attributes; } - -let transl_extension_constructor env type_path type_params - typext_params priv sext = - Builtin_attributes.warning_scope sext.pext_attributes - (fun () -> transl_extension_constructor env type_path type_params - typext_params priv sext) - -let transl_type_extension extend env loc styext = - reset_type_variables(); - Ctype.begin_def(); - let (type_path, type_decl) = - let lid = styext.ptyext_path in - Typetexp.find_type env lid.loc lid.txt - in - begin - match type_decl.type_kind with - | Type_open -> begin - match type_decl.type_private with - | Private when extend -> begin - match - List.find - (function {pext_kind = Pext_decl _} -> true - | {pext_kind = Pext_rebind _} -> false) - styext.ptyext_constructors - with - | {pext_loc} -> - raise (Error(pext_loc, Cannot_extend_private_type type_path)) - | exception Not_found -> () - end - | _ -> () - end - | _ -> - raise (Error(loc, Not_extensible_type type_path)) - end; - let type_variance = - List.map (fun v -> - let (co, cn) = Variance.get_upper v in - (not cn, not co, false)) - type_decl.type_variance - in - let err = - if type_decl.type_arity <> List.length styext.ptyext_params then - [Includecore.Arity] - else - if List.for_all2 - (fun (c1, n1, _) (c2, n2, _) -> (not c2 || c1) && (not n2 || n1)) - type_variance - (add_injectivity (List.map snd styext.ptyext_params)) - then [] else [Includecore.Variance] - in - if err <> [] then - raise (Error(loc, Extension_mismatch (type_path, err))); - let ttype_params = make_params env styext.ptyext_params in - let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in - List.iter2 (Ctype.unify_var env) - (Ctype.instance_list env type_decl.type_params) - type_params; - let constructors = - List.map (transl_extension_constructor env type_path - type_decl.type_params type_params styext.ptyext_private) - styext.ptyext_constructors - in - Ctype.end_def(); - (* Generalize types *) - List.iter Ctype.generalize type_params; - List.iter - (fun ext -> - Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; - may Ctype.generalize ext.ext_type.ext_ret_type) - constructors; - (* Check that all type variables are closed *) - List.iter - (fun ext -> - match Ctype.closed_extension_constructor ext.ext_type with - Some ty -> - raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) - | None -> ()) - constructors; - (* Check variances are correct *) - List.iter - (fun ext-> - ignore (compute_variance_extension env true type_decl - ext.ext_type (type_variance, loc))) - constructors; - (* Add extension constructors to the environment *) - let newenv = - List.fold_left - (fun env ext -> - Env.add_extension ~check:true ext.ext_id ext.ext_type env) - env constructors - in - let tyext = - { tyext_path = type_path; - tyext_txt = styext.ptyext_path; - tyext_params = ttype_params; - tyext_constructors = constructors; - tyext_private = styext.ptyext_private; - tyext_attributes = styext.ptyext_attributes; } - in - (tyext, newenv) - -let transl_type_extension extend env loc styext = - Builtin_attributes.warning_scope styext.ptyext_attributes - (fun () -> transl_type_extension extend env loc styext) - -let transl_exception env sext = - reset_type_variables(); - Ctype.begin_def(); - let ext = - transl_extension_constructor env - Predef.path_exn [] [] Asttypes.Public sext - in - Ctype.end_def(); - (* Generalize types *) - Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; - may Ctype.generalize ext.ext_type.ext_ret_type; - (* Check that all type variables are closed *) - begin match Ctype.closed_extension_constructor ext.ext_type with - Some ty -> - raise (Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type))) - | None -> () - end; - let newenv = Env.add_extension ~check:true ext.ext_id ext.ext_type env in - ext, newenv - - - -let rec parse_native_repr_attributes env core_type ty = - match core_type.ptyp_desc, (Ctype.repr ty).desc - with - | Ptyp_arrow (_, _, ct2), Tarrow (_, _, t2, _) -> - let repr_arg = Same_as_ocaml_repr in - let repr_args, repr_res = - parse_native_repr_attributes env ct2 t2 - in - (repr_arg :: repr_args, repr_res) - | Ptyp_arrow _, _ | _, Tarrow _ -> assert false - | _ -> ([], Same_as_ocaml_repr) - - -let parse_native_repr_attributes env core_type ty = - match core_type.ptyp_desc, (Ctype.repr ty).desc - with - | Ptyp_constr ({txt = Lident "function$"}, [{ptyp_desc = Ptyp_arrow (_, _, ct2)}; _]), - Tconstr (Pident {name = "function$"},[{desc = Tarrow (_, _, t2, _)}; _],_) -> - let repr_args, repr_res = parse_native_repr_attributes env ct2 t2 in - let native_repr_args = Same_as_ocaml_repr :: repr_args in - (native_repr_args, repr_res) - | _ -> parse_native_repr_attributes env core_type ty - -(* Translate a value declaration *) -let transl_value_decl env loc valdecl = - let cty = Typetexp.transl_type_scheme env valdecl.pval_type in - let ty = cty.ctyp_type in - let v = - match valdecl.pval_prim with - [] when Env.is_in_signature env -> - { val_type = ty; val_kind = Val_reg; Types.val_loc = loc; - val_attributes = valdecl.pval_attributes } - | [] -> - raise (Error(valdecl.pval_loc, Val_in_structure)) - | _ -> - let native_repr_args, native_repr_res = - let rec scann (attrs : Parsetree.attributes) = - match attrs with - | ({txt = "internal.arity";_}, - PStr [ {pstr_desc = Pstr_eval - ( - ({pexp_desc = Pexp_constant (Pconst_integer (i,_))} : - Parsetree.expression) ,_)}]) :: _ -> - Some (int_of_string i) - | _ :: rest -> scann rest - | [] -> None - and make n = - if n = 0 then [] - else Primitive.Same_as_ocaml_repr :: make (n - 1) - in - match scann valdecl.pval_attributes with - | None -> parse_native_repr_attributes env valdecl.pval_type ty - | Some x -> make x , Primitive.Same_as_ocaml_repr - in - let prim = - Primitive.parse_declaration valdecl - ~native_repr_args - ~native_repr_res - in - let prim_native_name = prim.prim_native_name in - if prim.prim_arity = 0 && - not ( String.length prim_native_name >= 20 && - String.unsafe_get prim_native_name 0 = '\132' && - String.unsafe_get prim_native_name 1 = '\149' - ) && - (prim.prim_name = "" || (prim.prim_name.[0] <> '%' && prim.prim_name.[0] <> '#')) then - raise(Error(valdecl.pval_type.ptyp_loc, Null_arity_external)); - { val_type = ty; val_kind = Val_prim prim; Types.val_loc = loc; - val_attributes = valdecl.pval_attributes } - in - let (id, newenv) = - Env.enter_value valdecl.pval_name.txt v env - ~check:(fun s -> Warnings.Unused_value_declaration s) - in - let desc = - { - val_id = id; - val_name = valdecl.pval_name; - val_desc = cty; val_val = v; - val_prim = valdecl.pval_prim; - val_loc = valdecl.pval_loc; - val_attributes = valdecl.pval_attributes; - } - in - desc, newenv - -let transl_value_decl env loc valdecl = - Builtin_attributes.warning_scope valdecl.pval_attributes - (fun () -> transl_value_decl env loc valdecl) - -(* Translate a "with" constraint -- much simplified version of - transl_type_decl. *) -let transl_with_constraint env id row_path orig_decl sdecl = - Env.mark_type_used env (Ident.name id) orig_decl; - reset_type_variables(); - Ctype.begin_def(); - let tparams = make_params env sdecl.ptype_params in - let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in - let orig_decl = Ctype.instance_declaration orig_decl in - let arity_ok = List.length params = orig_decl.type_arity in - if arity_ok then - List.iter2 (Ctype.unify_var env) params orig_decl.type_params; - let constraints = List.map - (function (ty, ty', loc) -> - try - let cty = transl_simple_type env false ty in - let cty' = transl_simple_type env false ty' in - let ty = cty.ctyp_type in - let ty' = cty'.ctyp_type in - Ctype.unify env ty ty'; - (cty, cty', loc) - with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint (env, tr)))) - sdecl.ptype_cstrs - in - let no_row = not (is_fixed_type sdecl) in - let (tman, man) = match sdecl.ptype_manifest with - None -> None, None - | Some sty -> - let cty = transl_simple_type env no_row sty in - Some cty, Some cty.ctyp_type - in - let priv = - if sdecl.ptype_private = Private then Private else - if arity_ok && orig_decl.type_kind <> Type_abstract - then orig_decl.type_private else sdecl.ptype_private - in - if arity_ok && orig_decl.type_kind <> Type_abstract - && sdecl.ptype_private = Private then - Location.deprecated sdecl.ptype_loc "spurious use of private"; - let type_kind, type_unboxed = - if arity_ok && man <> None then - orig_decl.type_kind, orig_decl.type_unboxed - else - Type_abstract, unboxed_false_default_false - in - let decl = - { type_params = params; - type_arity = List.length params; - type_kind; - type_private = priv; - type_manifest = man; - type_variance = []; - type_newtype_level = None; - type_loc = sdecl.ptype_loc; - type_attributes = sdecl.ptype_attributes; - type_immediate = false; - type_unboxed; - } - in - begin match row_path with None -> () - | Some p -> set_fixed_row env sdecl.ptype_loc p decl - end; - begin match Ctype.closed_type_decl decl with None -> () - | Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl))) - end; - let decl = name_recursion sdecl id decl in - let type_variance = - compute_variance_decl env true decl - (add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc) - in - let type_immediate = compute_immediacy env decl in - let decl = {decl with type_variance; type_immediate} in - Ctype.end_def(); - generalize_decl decl; - { - typ_id = id; - typ_name = sdecl.ptype_name; - typ_params = tparams; - typ_type = decl; - typ_cstrs = constraints; - typ_loc = sdecl.ptype_loc; - typ_manifest = tman; - typ_kind = Ttype_abstract; - typ_private = sdecl.ptype_private; - typ_attributes = sdecl.ptype_attributes; - } - -(* Approximate a type declaration: just make all types abstract *) - -let abstract_type_decl arity = - let rec make_params n = - if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in - Ctype.begin_def(); - let decl = - { type_params = make_params arity; - type_arity = arity; - type_kind = Type_abstract; - type_private = Public; - type_manifest = None; - type_variance = replicate_list Variance.full arity; - type_newtype_level = None; - type_loc = Location.none; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } in - Ctype.end_def(); - generalize_decl decl; - decl - -let approx_type_decl sdecl_list = - List.map - (fun sdecl -> - (Ident.create sdecl.ptype_name.txt, - abstract_type_decl (List.length sdecl.ptype_params))) - sdecl_list - -(* Variant of check_abbrev_recursion to check the well-formedness - conditions on type abbreviations defined within recursive modules. *) - -let check_recmod_typedecl env loc recmod_ids path decl = - (* recmod_ids is the list of recursively-defined module idents. - (path, decl) is the type declaration to be checked. *) - let to_check path = - List.exists (fun id -> Path.isfree id path) recmod_ids in - check_well_founded_decl env loc path decl to_check; - check_recursion env loc path decl to_check - - -(**** Error report ****) - -open Format - -let explain_unbound_gen ppf tv tl typ kwd pr = - try - let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in - let ty0 = (* Hack to force aliasing when needed *) - Btype.newgenty (Tobject(tv, ref None)) in - Printtyp.reset_and_mark_loops_list [typ ti; ty0]; - fprintf ppf - ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]" - kwd pr ti Printtyp.type_expr tv - with Not_found -> () - -let explain_unbound ppf tv tl typ kwd lab = - explain_unbound_gen ppf tv tl typ kwd - (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) - -let explain_unbound_single ppf tv ty = - let trivial ty = - explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in - match (Ctype.repr ty).desc with - Tobject(fi,_) -> - let (tl, rv) = Ctype.flatten_fields fi in - if rv == tv then trivial ty else - explain_unbound ppf tv tl (fun (_,_,t) -> t) - "method" (fun (lab,_,_) -> lab ^ ": ") - | Tvariant row -> - let row = Btype.row_repr row in - if row.row_more == tv then trivial ty else - explain_unbound ppf tv row.row_fields - (fun (_l,f) -> match Btype.row_field_repr f with - Rpresent (Some t) -> t - | Reither (_,[t],_,_) -> t - | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) - | _ -> Btype.newgenty (Ttuple[])) - "case" (fun (lab,_) -> "`" ^ lab ^ " of ") - | _ -> trivial ty - - -let tys_of_constr_args = function - | Types.Cstr_tuple tl -> tl - | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls - -let report_error ppf = function - | Repeated_parameter -> - fprintf ppf "A type parameter occurs several times" - | Duplicate_constructor s -> - fprintf ppf "Two constructors are named %s" s - | Duplicate_label (s, None) -> - fprintf ppf "The field @{%s@} is defined several times in this record. Fields can only be added once to a record." s - | Duplicate_label (s, Some recordName) -> - fprintf ppf "The field @{%s@} is defined several times in the record @{%s@}. Fields can only be added once to a record." s recordName - | Recursive_abbrev s -> - fprintf ppf "The type abbreviation %s is cyclic" s - | Cycle_in_def (s, ty) -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[The definition of %s contains a cycle:@ %a@]" - s Printtyp.type_expr ty - | Definition_mismatch (ty, errs) -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" - "This variant or record definition" "does not match that of type" - Printtyp.type_expr ty - (Includecore.report_type_mismatch "the original" "this" "definition") - errs - | Constraint_failed (ty, ty') -> - Printtyp.reset_and_mark_loops ty; - Printtyp.mark_loops ty'; - fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]" - "Constraints are not satisfied in this type." - Printtyp.type_expr ty Printtyp.type_expr ty' - | Parameters_differ (path, ty, ty') -> - Printtyp.reset_and_mark_loops ty; - Printtyp.mark_loops ty'; - fprintf ppf - "@[In the definition of %s, type@ %a@ should be@ %a@]" - (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty' - | Inconsistent_constraint (env, trace) -> - fprintf ppf "The type constraints are not consistent.@."; - Printtyp.report_unification_error ppf env trace - (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type") - | Type_clash (env, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "This type constructor expands to type") - (function ppf -> - fprintf ppf "but is used here with type") - | Null_arity_external -> - fprintf ppf "External identifiers must be functions" - | Unbound_type_var (ty, decl) -> - fprintf ppf "A type variable is unbound in this type declaration"; - let ty = Ctype.repr ty in - begin match decl.type_kind, decl.type_manifest with - | Type_variant tl, _ -> - explain_unbound_gen ppf ty tl (fun c -> - let tl = tys_of_constr_args c.Types.cd_args in - Btype.newgenty (Ttuple tl) - ) - "case" (fun ppf c -> - fprintf ppf - "%s of %a" (Ident.name c.Types.cd_id) - Printtyp.constructor_arguments c.Types.cd_args) - | Type_record (tl, _), _ -> - explain_unbound ppf ty tl (fun l -> l.Types.ld_type) - "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") - | Type_abstract, Some ty' -> - explain_unbound_single ppf ty ty' - | _ -> () - end - | Unbound_type_var_ext (ty, ext) -> - fprintf ppf "A type variable is unbound in this extension constructor"; - let args = tys_of_constr_args ext.ext_args in - explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") - | Cannot_extend_private_type path -> - fprintf ppf "@[%s@ %a@]" - "Cannot extend private type definition" - Printtyp.path path - | Not_extensible_type path -> - fprintf ppf "@[%s@ %a@ %s@]" - "Type definition" - Printtyp.path path - "is not extensible" - | Extension_mismatch (path, errs) -> - fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]" - "This extension" "does not match the definition of type" - (Path.name path) - (Includecore.report_type_mismatch - "the type" "this extension" "definition") - errs - | Rebind_wrong_type (lid, env, trace) -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "The constructor %a@ has type" - Printtyp.longident lid) - (function ppf -> - fprintf ppf "but was expected to be of type") - | Rebind_mismatch (lid, p, p') -> - fprintf ppf - "@[%s@ %a@ %s@ %s@ %s@ %s@ %s@]" - "The constructor" Printtyp.longident lid - "extends type" (Path.name p) - "whose declaration does not match" - "the declaration of type" (Path.name p') - | Rebind_private lid -> - fprintf ppf "@[%s@ %a@ %s@]" - "The constructor" - Printtyp.longident lid - "is private" - | Bad_variance (n, v1, v2) -> - let variance (p,n,i) = - let inj = if i then "injective " else "" in - match p, n with - true, true -> inj ^ "invariant" - | true, false -> inj ^ "covariant" - | false, true -> inj ^ "contravariant" - | false, false -> if inj = "" then "unrestricted" else inj - in - let suffix n = - let teen = (n mod 100)/10 = 1 in - match n mod 10 with - | 1 when not teen -> "st" - | 2 when not teen -> "nd" - | 3 when not teen -> "rd" - | _ -> "th" - in - if n = -1 then - fprintf ppf "@[%s@ %s@ It" - "In this definition, a type variable has a variance that" - "is not reflected by its occurrence in type parameters." - else if n = -2 then - fprintf ppf "@[%s@ %s@]" - "In this definition, a type variable cannot be deduced" - "from the type parameters." - else if n = -3 then - fprintf ppf "@[%s@ %s@ It" - "In this definition, a type variable has a variance that" - "cannot be deduced from the type parameters." - else - fprintf ppf "@[%s@ %s@ The %d%s type parameter" - "In this definition, expected parameter" - "variances are not satisfied." - n (suffix n); - if n <> -2 then - fprintf ppf " was expected to be %s,@ but it is %s.@]" - (variance v2) (variance v1) - | Unavailable_type_constructor p -> - fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p - | Bad_fixed_type r -> - fprintf ppf "This fixed type %s" r - | Varying_anonymous -> - fprintf ppf "@[%s@ %s@ %s@]" - "In this GADT definition," "the variance of some parameter" - "cannot be checked" - | Val_in_structure -> - fprintf ppf "Value declarations are only allowed in signatures" - | Bad_immediate_attribute -> - fprintf ppf "@[%s@ %s@]" - "Types marked with the immediate attribute must be" - "non-pointer types like int or bool" - | Bad_unboxed_attribute msg -> - fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg - | Boxed_and_unboxed -> - fprintf ppf "@[A type cannot be boxed and unboxed at the same time.@]" - | Nonrec_gadt -> - fprintf ppf - "@[GADT case syntax cannot be used in a 'nonrec' block.@]" - | Variant_runtime_representation_mismatch - (Variant_coercion.VariantError - {is_spread_context; error = Variant_coercion.Untagged {left_is_unboxed}}) - -> - let other_variant_text = - if is_spread_context then "the variant where this is spread" - else "the other variant" - in - fprintf ppf "@[%s.@]" - ("This variant is " - ^ (if left_is_unboxed then "unboxed" else "not unboxed") - ^ ", but " ^ other_variant_text - ^ " is not. Both variants unboxed configuration must match") - | Variant_runtime_representation_mismatch - (Variant_coercion.VariantError - {is_spread_context; error = Variant_coercion.TagName _}) -> - let other_variant_text = - if is_spread_context then "the variant where this is spread" - else "the other variant" - in - fprintf ppf "@[%s.@]" - ("The @tag attribute does not match for this variant and " - ^ other_variant_text - ^ ". Both variants must have the same @tag attribute configuration, or no \ - @tag attribute at all") - | Variant_spread_fail Variant_type_spread.InvalidType -> - fprintf ppf "@[This type is not a valid type to spread. It's only possible to spread other variants.@]" - | Variant_spread_fail Variant_type_spread.CouldNotFindType -> - fprintf ppf "@[This type could not be found. It's only possible to spread variants that are known as the spread happens. This means for example that you can't spread variants in recursive definitions.@]" - | Variant_spread_fail Variant_type_spread.HasTypeParams -> - fprintf ppf "@[Type parameters are not supported in variant type spreads.@]" - | Variant_spread_fail Variant_type_spread.DuplicateConstructor - {variant_with_overlapping_constructor; overlapping_constructor_name} -> - fprintf ppf "@[Variant %s has a constructor named %s, but a constructor named %s already exists in the variant it's spread into.@ You cannot spread variants with overlapping constructors.@]" - variant_with_overlapping_constructor overlapping_constructor_name overlapping_constructor_name - - -let () = - Location.register_error_of_exn - (function - | Error (loc, err) -> - Some (Location.error_of_printer loc report_error err) - | _ -> - None - ) diff --git a/jscomp/ml/typedecl.mli b/jscomp/ml/typedecl.mli deleted file mode 100644 index 03f1b8b..0000000 --- a/jscomp/ml/typedecl.mli +++ /dev/null @@ -1,72 +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. *) -(* *) -(**************************************************************************) - -(* Typing of type definitions and primitive definitions *) - -open Types -open Format - -val transl_type_decl: - Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list -> - Typedtree.type_declaration list * Env.t - -val transl_exception: - Env.t -> - Parsetree.extension_constructor -> Typedtree.extension_constructor * Env.t - -val transl_type_extension: - bool -> Env.t -> Location.t -> Parsetree.type_extension -> - Typedtree.type_extension * Env.t - -val transl_value_decl: - Env.t -> Location.t -> - Parsetree.value_description -> Typedtree.value_description * Env.t - -val transl_with_constraint: - Env.t -> Ident.t -> Path.t option -> Types.type_declaration -> - Parsetree.type_declaration -> Typedtree.type_declaration - -val abstract_type_decl: int -> type_declaration -val approx_type_decl: - Parsetree.type_declaration list -> - (Ident.t * type_declaration) list -val check_recmod_typedecl: - Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit -val check_coherence: - Env.t -> Location.t -> Ident.t -> type_declaration -> unit - -(* for fixed types *) -val is_fixed_type : Parsetree.type_declaration -> bool - -(* for typeclass.ml *) -val compute_variance_decls: - Env.t -> - (Ident.t * Types.type_declaration * Types.type_declaration * - Types.class_declaration * Types.class_type_declaration * - 'a Typedtree.class_infos) list -> - (Types.type_declaration * Types.type_declaration * - Types.class_declaration * Types.class_type_declaration) list - -(* for typeopt.ml *) -val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option - - -type native_repr_kind = Unboxed | Untagged - -type error - -exception Error of Location.t * error - -val report_error: formatter -> error -> unit diff --git a/jscomp/ml/typedtree.ml b/jscomp/ml/typedtree.ml deleted file mode 100644 index 5744f0d..0000000 --- a/jscomp/ml/typedtree.ml +++ /dev/null @@ -1,569 +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. *) -(* *) -(**************************************************************************) - -(* Abstract syntax tree after typing *) - -open Misc -open Asttypes -open Types - -(* Value expressions for the core language *) - -type partial = Partial | Total - -type attribute = Parsetree.attribute -type attributes = attribute list - -type pattern = - { pat_desc: pattern_desc; - pat_loc: Location.t; - pat_extra : (pat_extra * Location.t * attribute list) list; - pat_type: type_expr; - mutable pat_env: Env.t; - pat_attributes: attribute list; - } - -and pat_extra = - | Tpat_constraint of core_type - | Tpat_type of Path.t * Longident.t loc - | Tpat_open of Path.t * Longident.t loc * Env.t - | Tpat_unpack - -and pattern_desc = - Tpat_any - | Tpat_var of Ident.t * string loc - | Tpat_alias of pattern * Ident.t * string loc - | Tpat_constant of constant - | Tpat_tuple of pattern list - | Tpat_construct of - Longident.t loc * constructor_description * pattern list - | Tpat_variant of label * pattern option * row_desc ref - | Tpat_record of - (Longident.t loc * label_description * pattern) list * - closed_flag - | Tpat_array of pattern list - | Tpat_or of pattern * pattern * row_desc option - | Tpat_lazy of pattern - -and expression = - { exp_desc: expression_desc; - exp_loc: Location.t; - exp_extra: (exp_extra * Location.t * attribute list) list; - exp_type: type_expr; - exp_env: Env.t; - exp_attributes: attribute list; - } - -and exp_extra = - | Texp_constraint of core_type - | Texp_coerce of core_type option * core_type - | Texp_open of override_flag * Path.t * Longident.t loc * Env.t - | Texp_poly of core_type option - | Texp_newtype of string - -and expression_desc = - Texp_ident of Path.t * Longident.t loc * Types.value_description - | Texp_constant of constant - | Texp_let of rec_flag * value_binding list * expression - | Texp_function of { arg_label : arg_label; param : Ident.t; - cases : case list; partial : partial; } - | Texp_apply of expression * (arg_label * expression option) list - | Texp_match of expression * case list * case list * partial - | Texp_try of expression * case list - | Texp_tuple of expression list - | Texp_construct of - Longident.t loc * constructor_description * expression list - | Texp_variant of label * expression option - | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; - representation : Types.record_representation; - extended_expression : expression option; - } - | Texp_field of expression * Longident.t loc * label_description - | Texp_setfield of - expression * Longident.t loc * label_description * expression - | Texp_array of expression list - | Texp_ifthenelse of expression * expression * expression option - | Texp_sequence of expression * expression - | Texp_while of expression * expression - | Texp_for of - Ident.t * Parsetree.pattern * expression * expression * direction_flag * - expression - | Texp_send of expression * meth * expression option - | Texp_new of unit - | Texp_instvar of unit - | Texp_setinstvar of unit - | Texp_override of unit - | Texp_letmodule of Ident.t * string loc * module_expr * expression - | Texp_letexception of extension_constructor * expression - | Texp_assert of expression - | Texp_lazy of expression - | Texp_object of unit - | Texp_pack of module_expr - | Texp_unreachable - | Texp_extension_constructor of Longident.t loc * Path.t - -and meth = - Tmeth_name of string - -and case = - { - c_lhs: pattern; - c_guard: expression option; - c_rhs: expression; - } - -and record_label_definition = - | Kept of Types.type_expr - | Overridden of Longident.t loc * expression - -(* Value expressions for the class language *) - - - - - -(* Value expressions for the module language *) - -and module_expr = - { mod_desc: module_expr_desc; - mod_loc: Location.t; - mod_type: Types.module_type; - mod_env: Env.t; - mod_attributes: attribute list; - } - -and module_type_constraint = - Tmodtype_implicit -| Tmodtype_explicit of module_type - -and module_expr_desc = - Tmod_ident of Path.t * Longident.t loc - | Tmod_structure of structure - | Tmod_functor of Ident.t * string loc * module_type option * module_expr - | Tmod_apply of module_expr * module_expr * module_coercion - | Tmod_constraint of - module_expr * Types.module_type * module_type_constraint * module_coercion - | Tmod_unpack of expression * Types.module_type - -and structure = { - str_items : structure_item list; - str_type : Types.signature; - str_final_env : Env.t; -} - -and structure_item = - { str_desc : structure_item_desc; - str_loc : Location.t; - str_env : Env.t - } - -and structure_item_desc = - Tstr_eval of expression * attributes - | Tstr_value of rec_flag * value_binding list - | Tstr_primitive of value_description - | Tstr_type of rec_flag * type_declaration list - | Tstr_typext of type_extension - | Tstr_exception of extension_constructor - | Tstr_module of module_binding - | Tstr_recmodule of module_binding list - | Tstr_modtype of module_type_declaration - | Tstr_open of open_description - | Tstr_class of unit - | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list - | Tstr_include of include_declaration - | Tstr_attribute of attribute - -and module_binding = - { - mb_id: Ident.t; - mb_name: string loc; - mb_expr: module_expr; - mb_attributes: attribute list; - mb_loc: Location.t; - } - -and value_binding = - { - vb_pat: pattern; - vb_expr: expression; - vb_attributes: attributes; - vb_loc: Location.t; - } - -and module_coercion = - Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list * - (Ident.t * int * module_coercion) list * - string list (* runtime fields *) - | Tcoerce_functor of module_coercion * module_coercion - | Tcoerce_primitive of primitive_coercion - | Tcoerce_alias of Path.t * module_coercion - -and module_type = - { mty_desc: module_type_desc; - mty_type : Types.module_type; - mty_env : Env.t; - mty_loc: Location.t; - mty_attributes: attribute list; - } - -and module_type_desc = - Tmty_ident of Path.t * Longident.t loc - | Tmty_signature of signature - | Tmty_functor of Ident.t * string loc * module_type option * module_type - | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list - | Tmty_typeof of module_expr - | Tmty_alias of Path.t * Longident.t loc - -(* Keep primitive type information for type-based lambda-code specialization *) -and primitive_coercion = - { - pc_desc: Primitive.description; - pc_type: type_expr; - pc_env: Env.t; - pc_loc : Location.t; - pc_id : Ident.t; (*RE:Added *) - } - -and signature = { - sig_items : signature_item list; - sig_type : Types.signature; - sig_final_env : Env.t; -} - -and signature_item = - { sig_desc: signature_item_desc; - sig_env : Env.t; (* BINANNOT ADDED *) - sig_loc: Location.t } - -and signature_item_desc = - Tsig_value of value_description - | Tsig_type of rec_flag * type_declaration list - | Tsig_typext of type_extension - | Tsig_exception of extension_constructor - | Tsig_module of module_declaration - | Tsig_recmodule of module_declaration list - | Tsig_modtype of module_type_declaration - | Tsig_open of open_description - | Tsig_include of include_description - | Tsig_class of unit - | Tsig_class_type of class_type_declaration list - | Tsig_attribute of attribute - -and module_declaration = - { - md_id: Ident.t; - md_name: string loc; - md_type: module_type; - md_attributes: attribute list; - md_loc: Location.t; - } - -and module_type_declaration = - { - mtd_id: Ident.t; - mtd_name: string loc; - mtd_type: module_type option; - mtd_attributes: attribute list; - mtd_loc: Location.t; - } - -and open_description = - { - open_path: Path.t; - open_txt: Longident.t loc; - open_override: override_flag; - open_loc: Location.t; - open_attributes: attribute list; - } - -and 'a include_infos = - { - incl_mod: 'a; - incl_type: Types.signature; - incl_loc: Location.t; - incl_attributes: attribute list; - } - -and include_description = module_type include_infos - -and include_declaration = module_expr include_infos - -and with_constraint = - Twith_type of type_declaration - | Twith_module of Path.t * Longident.t loc - | Twith_typesubst of type_declaration - | Twith_modsubst of Path.t * Longident.t loc - -and core_type = -(* mutable because of [Typeclass.declare_method] *) - { mutable ctyp_desc : core_type_desc; - mutable ctyp_type : type_expr; - ctyp_env : Env.t; (* BINANNOT ADDED *) - ctyp_loc : Location.t; - ctyp_attributes: attribute list; - } - -and core_type_desc = - Ttyp_any - | Ttyp_var of string - | Ttyp_arrow of arg_label * core_type * core_type - | Ttyp_tuple of core_type list - | Ttyp_constr of Path.t * Longident.t loc * core_type list - | Ttyp_object of object_field list * closed_flag - | Ttyp_class of Path.t * Longident.t loc * core_type list - | Ttyp_alias of core_type * string - | Ttyp_variant of row_field list * closed_flag * label list option - | Ttyp_poly of string list * core_type - | Ttyp_package of package_type - -and package_type = { - pack_path : Path.t; - pack_fields : (Longident.t loc * core_type) list; - pack_type : Types.module_type; - pack_txt : Longident.t loc; -} - -and row_field = - Ttag of string loc * attributes * bool * core_type list - | Tinherit of core_type - -and object_field = - | OTtag of string loc * attributes * core_type - | OTinherit of core_type - -and value_description = - { val_id: Ident.t; - val_name: string loc; - val_desc: core_type; - val_val: Types.value_description; - val_prim: string list; - val_loc: Location.t; - val_attributes: attribute list; - } - -and type_declaration = - { typ_id: Ident.t; - typ_name: string loc; - typ_params: (core_type * variance) list; - typ_type: Types.type_declaration; - typ_cstrs: (core_type * core_type * Location.t) list; - typ_kind: type_kind; - typ_private: private_flag; - typ_manifest: core_type option; - typ_loc: Location.t; - typ_attributes: attribute list; - } - -and type_kind = - Ttype_abstract - | Ttype_variant of constructor_declaration list - | Ttype_record of label_declaration list - | Ttype_open - -and label_declaration = - { - ld_id: Ident.t; - ld_name: string loc; - ld_mutable: mutable_flag; - ld_type: core_type; - ld_loc: Location.t; - ld_attributes: attribute list; - } - -and constructor_declaration = - { - cd_id: Ident.t; - cd_name: string loc; - cd_args: constructor_arguments; - cd_res: core_type option; - cd_loc: Location.t; - cd_attributes: attribute list; - } - -and constructor_arguments = - | Cstr_tuple of core_type list - | Cstr_record of label_declaration list - -and type_extension = - { - tyext_path: Path.t; - tyext_txt: Longident.t loc; - tyext_params: (core_type * variance) list; - tyext_constructors: extension_constructor list; - tyext_private: private_flag; - tyext_attributes: attribute list; - } - -and extension_constructor = - { - ext_id: Ident.t; - ext_name: string loc; - ext_type: Types.extension_constructor; - ext_kind: extension_constructor_kind; - ext_loc: Location.t; - ext_attributes: attribute list; - } - -and extension_constructor_kind = - Text_decl of constructor_arguments * core_type option - | Text_rebind of Path.t * Longident.t loc - -and class_type = - { - cltyp_desc: class_type_desc; - cltyp_type: Types.class_type; - cltyp_env: Env.t; - cltyp_loc: Location.t; - cltyp_attributes: attribute list; - } - -and class_type_desc = - Tcty_constr of Path.t * Longident.t loc * core_type list - | Tcty_signature of class_signature - | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type - -and class_signature = { - csig_self: core_type; - csig_fields: class_type_field list; - csig_type: Types.class_signature; - } - -and class_type_field = { - ctf_desc: class_type_field_desc; - ctf_loc: Location.t; - ctf_attributes: attribute list; - } - -and class_type_field_desc = - | Tctf_inherit of class_type - | Tctf_val of (string * mutable_flag * virtual_flag * core_type) - | Tctf_method of (string * private_flag * virtual_flag * core_type) - | Tctf_constraint of (core_type * core_type) - | Tctf_attribute of attribute - - -and class_description = - class_type class_infos - -and class_type_declaration = - class_type class_infos - -and 'a class_infos = - { ci_virt: virtual_flag; - ci_params: (core_type * variance) list; - ci_id_name: string loc; - ci_id_class: Ident.t; - ci_id_class_type: Ident.t; - ci_id_object: Ident.t; - ci_id_typehash: Ident.t; - ci_expr: 'a; - ci_decl: Types.class_declaration; - ci_type_decl: Types.class_type_declaration; - ci_loc: Location.t; - ci_attributes: attribute list; - } - -(* Auxiliary functions over the a.s.t. *) - -let iter_pattern_desc f = function - | Tpat_alias(p, _, _) -> f p - | Tpat_tuple patl -> List.iter f patl - | Tpat_construct(_, _, patl) -> List.iter f patl - | Tpat_variant(_, pat, _) -> may f pat - | Tpat_record (lbl_pat_list, _) -> - List.iter (fun (_, _, pat) -> f pat) lbl_pat_list - | Tpat_array patl -> List.iter f patl - | Tpat_or(p1, p2, _) -> f p1; f p2 - | Tpat_lazy p -> f p - | Tpat_any - | Tpat_var _ - | Tpat_constant _ -> () - -let map_pattern_desc f d = - match d with - | Tpat_alias (p1, id, s) -> - Tpat_alias (f p1, id, s) - | Tpat_tuple pats -> - Tpat_tuple (List.map f pats) - | Tpat_record (lpats, closed) -> - Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed) - | Tpat_construct (lid, c,pats) -> - Tpat_construct (lid, c, List.map f pats) - | Tpat_array pats -> - Tpat_array (List.map f pats) - | Tpat_lazy p1 -> Tpat_lazy (f p1) - | Tpat_variant (x1, Some p1, x2) -> - Tpat_variant (x1, Some (f p1), x2) - | Tpat_or (p1,p2,path) -> - Tpat_or (f p1, f p2, path) - | Tpat_var _ - | Tpat_constant _ - | Tpat_any - | Tpat_variant (_,None,_) -> d - -(* List the identifiers bound by a pattern or a let *) - -let idents = ref([]: (Ident.t * string loc) list) - -let rec bound_idents pat = - match pat.pat_desc with - | Tpat_var (id,s) -> idents := (id,s) :: !idents - | Tpat_alias(p, id, s ) -> - bound_idents p; idents := (id,s) :: !idents - | Tpat_or(p1, _, _) -> - (* Invariant : both arguments binds the same variables *) - bound_idents p1 - | d -> iter_pattern_desc bound_idents d - -let pat_bound_idents pat = - idents := []; - bound_idents pat; - let res = !idents in - idents := []; - List.map fst res - -let rev_let_bound_idents_with_loc bindings = - idents := []; - List.iter (fun vb -> bound_idents vb.vb_pat) bindings; - let res = !idents in idents := []; res - -let let_bound_idents_with_loc pat_expr_list = - List.rev(rev_let_bound_idents_with_loc pat_expr_list) - -let rev_let_bound_idents pat = List.map fst (rev_let_bound_idents_with_loc pat) -let let_bound_idents pat = List.map fst (let_bound_idents_with_loc pat) - -let alpha_var env id = List.assoc id env - -let rec alpha_pat env p = match p.pat_desc with -| Tpat_var (id, s) -> (* note the ``Not_found'' case *) - {p with pat_desc = - try Tpat_var (alpha_var env id, s) with - | Not_found -> Tpat_any} -| Tpat_alias (p1, id, s) -> - let new_p = alpha_pat env p1 in - begin try - {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)} - with - | Not_found -> new_p - end -| d -> - {p with pat_desc = map_pattern_desc (alpha_pat env) d} - -let mkloc = Location.mkloc -let mknoloc = Location.mknoloc diff --git a/jscomp/ml/typedtree.mli b/jscomp/ml/typedtree.mli deleted file mode 100644 index a4559f3..0000000 --- a/jscomp/ml/typedtree.mli +++ /dev/null @@ -1,614 +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. *) -(* *) -(**************************************************************************) - -(** Abstract syntax tree after typing *) - - -(** By comparison with {!Parsetree}: - - Every {!Longindent.t} is accompanied by a resolved {!Path.t}. - -*) - -open Asttypes -open Types - -(* Value expressions for the core language *) - -type partial = Partial | Total - -(** {1 Extension points} *) - -type attribute = Parsetree.attribute -type attributes = attribute list - -(** {1 Core language} *) - -type pattern = - { pat_desc: pattern_desc; - pat_loc: Location.t; - pat_extra : (pat_extra * Location.t * attributes) list; - pat_type: type_expr; - mutable pat_env: Env.t; - pat_attributes: attributes; - } - -and pat_extra = - | Tpat_constraint of core_type - (** P : T { pat_desc = P - ; pat_extra = (Tpat_constraint T, _, _) :: ... } - *) - | Tpat_type of Path.t * Longident.t loc - (** #tconst { pat_desc = disjunction - ; pat_extra = (Tpat_type (P, "tconst"), _, _) :: ...} - - where [disjunction] is a [Tpat_or _] representing the - branches of [tconst]. - *) - | Tpat_open of Path.t * Longident.t loc * Env.t - | Tpat_unpack - (** (module P) { pat_desc = Tpat_var "P" - ; pat_extra = (Tpat_unpack, _, _) :: ... } - *) - -and pattern_desc = - Tpat_any - (** _ *) - | Tpat_var of Ident.t * string loc - (** x *) - | Tpat_alias of pattern * Ident.t * string loc - (** P as a *) - | Tpat_constant of constant - (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Tpat_tuple of pattern list - (** (P1, ..., Pn) - - Invariant: n >= 2 - *) - | Tpat_construct of - Longident.t loc * constructor_description * pattern list - (** C [] - C P [P] - C (P1, ..., Pn) [P1; ...; Pn] - *) - | Tpat_variant of label * pattern option * row_desc ref - (** `A (None) - `A P (Some P) - - See {!Types.row_desc} for an explanation of the last parameter. - *) - | Tpat_record of - (Longident.t loc * label_description * pattern) list * - closed_flag - (** { l1=P1; ...; ln=Pn } (flag = Closed) - { l1=P1; ...; ln=Pn; _} (flag = Open) - - Invariant: n > 0 - *) - | Tpat_array of pattern list - (** [| P1; ...; Pn |] *) - | Tpat_or of pattern * pattern * row_desc option - (** P1 | P2 - - [row_desc] = [Some _] when translating [Ppat_type _], - [None] otherwise. - *) - | Tpat_lazy of pattern - (** lazy P *) - -and expression = - { exp_desc: expression_desc; - exp_loc: Location.t; - exp_extra: (exp_extra * Location.t * attributes) list; - exp_type: type_expr; - exp_env: Env.t; - exp_attributes: attributes; - } - -and exp_extra = - | Texp_constraint of core_type - (** E : T *) - | Texp_coerce of core_type option * core_type - (** E :> T [Texp_coerce (None, T)] - E : T0 :> T [Texp_coerce (Some T0, T)] - *) - | Texp_open of override_flag * Path.t * Longident.t loc * Env.t - (** let open[!] M in [Texp_open (!, P, M, env)] - where [env] is the environment after opening [P] - *) - | Texp_poly of core_type option - (** Used for method bodies. *) - | Texp_newtype of string - (** fun (type t) -> *) - -and expression_desc = - Texp_ident of Path.t * Longident.t loc * Types.value_description - (** x - M.x - *) - | Texp_constant of constant - (** 1, 'a', "true", 1.0, 1l, 1L, 1n *) - | Texp_let of rec_flag * value_binding list * expression - (** let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) - let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) - *) - | Texp_function of { arg_label : arg_label; param : Ident.t; - cases : case list; partial : partial; } - (** [Pexp_fun] and [Pexp_function] both translate to [Texp_function]. - See {!Parsetree} for more details. - - [param] is the identifier that is to be used to name the - parameter of the function. - - partial = - [Partial] if the pattern match is partial - [Total] otherwise. - *) - | Texp_apply of expression * (arg_label * expression option) list - (** E0 ~l1:E1 ... ~ln:En - - The expression can be None if the expression is abstracted over - this argument. It currently appears when a label is applied. - - For example: - let f x ~y = x + y in - f ~y:3 - - The resulting typedtree for the application is: - Texp_apply (Texp_ident "f/1037", - [(Nolabel, None); - (Labelled "y", Some (Texp_constant Const_int 3)) - ]) - *) - | Texp_match of expression * case list * case list * partial - (** match E0 with - | P1 -> E1 - | P2 -> E2 - | exception P3 -> E3 - - [Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)] - *) - | Texp_try of expression * case list - (** try E with P1 -> E1 | ... | PN -> EN *) - | Texp_tuple of expression list - (** (E1, ..., EN) *) - | Texp_construct of - Longident.t loc * constructor_description * expression list - (** C [] - C E [E] - C (E1, ..., En) [E1;...;En] - *) - | Texp_variant of label * expression option - | Texp_record of { - fields : ( Types.label_description * record_label_definition ) array; - representation : Types.record_representation; - extended_expression : expression option; - } - (** { l1=P1; ...; ln=Pn } (extended_expression = None) - { E0 with l1=P1; ...; ln=Pn } (extended_expression = Some E0) - - Invariant: n > 0 - - If the type is { l1: t1; l2: t2 }, the expression - { E0 with t2=P2 } is represented as - Texp_record - { fields = [| l1, Kept t1; l2 Override P2 |]; representation; - extended_expression = Some E0 } - *) - | Texp_field of expression * Longident.t loc * label_description - | Texp_setfield of - expression * Longident.t loc * label_description * expression - | Texp_array of expression list - | Texp_ifthenelse of expression * expression * expression option - | Texp_sequence of expression * expression - | Texp_while of expression * expression - | Texp_for of - Ident.t * Parsetree.pattern * expression * expression * direction_flag * - expression - | Texp_send of expression * meth * expression option - | Texp_new of unit - | Texp_instvar of unit - | Texp_setinstvar of unit - | Texp_override of unit - | Texp_letmodule of Ident.t * string loc * module_expr * expression - | Texp_letexception of extension_constructor * expression - | Texp_assert of expression - | Texp_lazy of expression - | Texp_object of unit - | Texp_pack of module_expr - | Texp_unreachable - | Texp_extension_constructor of Longident.t loc * Path.t - -and meth = - Tmeth_name of string - -and case = - { - c_lhs: pattern; - c_guard: expression option; - c_rhs: expression; - } - -and record_label_definition = - | Kept of Types.type_expr - | Overridden of Longident.t loc * expression - - - -(* Value expressions for the module language *) - -and module_expr = - { mod_desc: module_expr_desc; - mod_loc: Location.t; - mod_type: Types.module_type; - mod_env: Env.t; - mod_attributes: attributes; - } - -(** Annotations for [Tmod_constraint]. *) -and module_type_constraint = - | Tmodtype_implicit - (** The module type constraint has been synthesized during typechecking. *) - | Tmodtype_explicit of module_type - (** The module type was in the source file. *) - -and module_expr_desc = - Tmod_ident of Path.t * Longident.t loc - | Tmod_structure of structure - | Tmod_functor of Ident.t * string loc * module_type option * module_expr - | Tmod_apply of module_expr * module_expr * module_coercion - | Tmod_constraint of - module_expr * Types.module_type * module_type_constraint * module_coercion - (** ME (constraint = Tmodtype_implicit) - (ME : MT) (constraint = Tmodtype_explicit MT) - *) - | Tmod_unpack of expression * Types.module_type - -and structure = { - str_items : structure_item list; - str_type : Types.signature; - str_final_env : Env.t; -} - -and structure_item = - { str_desc : structure_item_desc; - str_loc : Location.t; - str_env : Env.t - } - -and structure_item_desc = - Tstr_eval of expression * attributes - | Tstr_value of rec_flag * value_binding list - | Tstr_primitive of value_description - | Tstr_type of rec_flag * type_declaration list - | Tstr_typext of type_extension - | Tstr_exception of extension_constructor - | Tstr_module of module_binding - | Tstr_recmodule of module_binding list - | Tstr_modtype of module_type_declaration - | Tstr_open of open_description - | Tstr_class of unit - | Tstr_class_type of (Ident.t * string loc * class_type_declaration) list - | Tstr_include of include_declaration - | Tstr_attribute of attribute - -and module_binding = - { - mb_id: Ident.t; - mb_name: string loc; - mb_expr: module_expr; - mb_attributes: attributes; - mb_loc: Location.t; - } - -and value_binding = - { - vb_pat: pattern; - vb_expr: expression; - vb_attributes: attributes; - vb_loc: Location.t; - } - -and module_coercion = - Tcoerce_none - | Tcoerce_structure of (int * module_coercion) list * - (Ident.t * int * module_coercion) list * - string list (* runtime fields *) - | Tcoerce_functor of module_coercion * module_coercion - | Tcoerce_primitive of primitive_coercion - | Tcoerce_alias of Path.t * module_coercion - -and module_type = - { mty_desc: module_type_desc; - mty_type : Types.module_type; - mty_env : Env.t; - mty_loc: Location.t; - mty_attributes: attributes; - } - -and module_type_desc = - Tmty_ident of Path.t * Longident.t loc - | Tmty_signature of signature - | Tmty_functor of Ident.t * string loc * module_type option * module_type - | Tmty_with of module_type * (Path.t * Longident.t loc * with_constraint) list - | Tmty_typeof of module_expr - | Tmty_alias of Path.t * Longident.t loc - -and primitive_coercion = - { - pc_desc: Primitive.description; - pc_type: type_expr; - pc_env: Env.t; - pc_loc : Location.t; - pc_id : Ident.t; - } - -and signature = { - sig_items : signature_item list; - sig_type : Types.signature; - sig_final_env : Env.t; -} - -and signature_item = - { sig_desc: signature_item_desc; - sig_env : Env.t; (* BINANNOT ADDED *) - sig_loc: Location.t } - -and signature_item_desc = - Tsig_value of value_description - | Tsig_type of rec_flag * type_declaration list - | Tsig_typext of type_extension - | Tsig_exception of extension_constructor - | Tsig_module of module_declaration - | Tsig_recmodule of module_declaration list - | Tsig_modtype of module_type_declaration - | Tsig_open of open_description - | Tsig_include of include_description - | Tsig_class of unit - | Tsig_class_type of class_type_declaration list - | Tsig_attribute of attribute - -and module_declaration = - { - md_id: Ident.t; - md_name: string loc; - md_type: module_type; - md_attributes: attributes; - md_loc: Location.t; - } - -and module_type_declaration = - { - mtd_id: Ident.t; - mtd_name: string loc; - mtd_type: module_type option; - mtd_attributes: attributes; - mtd_loc: Location.t; - } - -and open_description = - { - open_path: Path.t; - open_txt: Longident.t loc; - open_override: override_flag; - open_loc: Location.t; - open_attributes: attribute list; - } - -and 'a include_infos = - { - incl_mod: 'a; - incl_type: Types.signature; - incl_loc: Location.t; - incl_attributes: attribute list; - } - -and include_description = module_type include_infos - -and include_declaration = module_expr include_infos - -and with_constraint = - Twith_type of type_declaration - | Twith_module of Path.t * Longident.t loc - | Twith_typesubst of type_declaration - | Twith_modsubst of Path.t * Longident.t loc - -and core_type = - { mutable ctyp_desc : core_type_desc; - (** mutable because of [Typeclass.declare_method] *) - mutable ctyp_type : type_expr; - (** mutable because of [Typeclass.declare_method] *) - ctyp_env : Env.t; (* BINANNOT ADDED *) - ctyp_loc : Location.t; - ctyp_attributes: attributes; - } - -and core_type_desc = - Ttyp_any - | Ttyp_var of string - | Ttyp_arrow of arg_label * core_type * core_type - | Ttyp_tuple of core_type list - | Ttyp_constr of Path.t * Longident.t loc * core_type list - | Ttyp_object of object_field list * closed_flag - | Ttyp_class of Path.t * Longident.t loc * core_type list - | Ttyp_alias of core_type * string - | Ttyp_variant of row_field list * closed_flag * label list option - | Ttyp_poly of string list * core_type - | Ttyp_package of package_type - -and package_type = { - pack_path : Path.t; - pack_fields : (Longident.t loc * core_type) list; - pack_type : Types.module_type; - pack_txt : Longident.t loc; -} - -and row_field = - Ttag of string loc * attributes * bool * core_type list - | Tinherit of core_type - -and object_field = - | OTtag of string loc * attributes * core_type - | OTinherit of core_type - -and value_description = - { val_id: Ident.t; - val_name: string loc; - val_desc: core_type; - val_val: Types.value_description; - val_prim: string list; - val_loc: Location.t; - val_attributes: attributes; - } - -and type_declaration = - { - typ_id: Ident.t; - typ_name: string loc; - typ_params: (core_type * variance) list; - typ_type: Types.type_declaration; - typ_cstrs: (core_type * core_type * Location.t) list; - typ_kind: type_kind; - typ_private: private_flag; - typ_manifest: core_type option; - typ_loc: Location.t; - typ_attributes: attributes; - } - -and type_kind = - Ttype_abstract - | Ttype_variant of constructor_declaration list - | Ttype_record of label_declaration list - | Ttype_open - -and label_declaration = - { - ld_id: Ident.t; - ld_name: string loc; - ld_mutable: mutable_flag; - ld_type: core_type; - ld_loc: Location.t; - ld_attributes: attributes; - } - -and constructor_declaration = - { - cd_id: Ident.t; - cd_name: string loc; - cd_args: constructor_arguments; - cd_res: core_type option; - cd_loc: Location.t; - cd_attributes: attributes; - } - -and constructor_arguments = - | Cstr_tuple of core_type list - | Cstr_record of label_declaration list - -and type_extension = - { - tyext_path: Path.t; - tyext_txt: Longident.t loc; - tyext_params: (core_type * variance) list; - tyext_constructors: extension_constructor list; - tyext_private: private_flag; - tyext_attributes: attributes; - } - -and extension_constructor = - { - ext_id: Ident.t; - ext_name: string loc; - ext_type : Types.extension_constructor; - ext_kind : extension_constructor_kind; - ext_loc : Location.t; - ext_attributes: attributes; - } - -and extension_constructor_kind = - Text_decl of constructor_arguments * core_type option - | Text_rebind of Path.t * Longident.t loc - -and class_type = - { - cltyp_desc: class_type_desc; - cltyp_type: Types.class_type; - cltyp_env: Env.t; - cltyp_loc: Location.t; - cltyp_attributes: attributes; - } - -and class_type_desc = - Tcty_constr of Path.t * Longident.t loc * core_type list - | Tcty_signature of class_signature - | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type - -and class_signature = { - csig_self : core_type; - csig_fields : class_type_field list; - csig_type : Types.class_signature; - } - -and class_type_field = { - ctf_desc: class_type_field_desc; - ctf_loc: Location.t; - ctf_attributes: attributes; - } - -and class_type_field_desc = - | Tctf_inherit of class_type - | Tctf_val of (string * mutable_flag * virtual_flag * core_type) - | Tctf_method of (string * private_flag * virtual_flag * core_type) - | Tctf_constraint of (core_type * core_type) - | Tctf_attribute of attribute - - -and class_description = - class_type class_infos - -and class_type_declaration = - class_type class_infos - -and 'a class_infos = - { ci_virt: virtual_flag; - ci_params: (core_type * variance) list; - ci_id_name : string loc; - ci_id_class: Ident.t; - ci_id_class_type : Ident.t; - ci_id_object : Ident.t; - ci_id_typehash : Ident.t; - ci_expr: 'a; - ci_decl: Types.class_declaration; - ci_type_decl : Types.class_type_declaration; - ci_loc: Location.t; - ci_attributes: attributes; - } - -(* Auxiliary functions over the a.s.t. *) - -val iter_pattern_desc: (pattern -> unit) -> pattern_desc -> unit -val map_pattern_desc: (pattern -> pattern) -> pattern_desc -> pattern_desc - -val let_bound_idents: value_binding list -> Ident.t list -val rev_let_bound_idents: value_binding list -> Ident.t list - - -(** Alpha conversion of patterns *) -val alpha_pat: (Ident.t * Ident.t) list -> pattern -> pattern - -val mknoloc: 'a -> 'a Asttypes.loc -val mkloc: 'a -> Location.t -> 'a Asttypes.loc - -val pat_bound_idents: pattern -> Ident.t list diff --git a/jscomp/ml/typedtreeIter.ml b/jscomp/ml/typedtreeIter.ml deleted file mode 100644 index 779a7c9..0000000 --- a/jscomp/ml/typedtreeIter.ml +++ /dev/null @@ -1,594 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 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. *) -(* *) -(**************************************************************************) - -(* -TODO: - - 2012/05/10: Follow camlp4 way of building map and iter using classes - and inheritance ? -*) - -open Asttypes -open Typedtree - -module type IteratorArgument = sig - - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_signature : class_signature -> unit - - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit - - - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_signature : class_signature -> unit - - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit - - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit - - end - -module MakeIterator(Iter : IteratorArgument) : sig - - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - - end = struct - - let may_iter f v = - match v with - None -> () - | Some x -> f x - - - let rec iter_structure str = - Iter.enter_structure str; - List.iter iter_structure_item str.str_items; - Iter.leave_structure str - - - and iter_binding vb = - Iter.enter_binding vb; - iter_pattern vb.vb_pat; - iter_expression vb.vb_expr; - Iter.leave_binding vb - - and iter_bindings rec_flag list = - Iter.enter_bindings rec_flag; - List.iter iter_binding list; - Iter.leave_bindings rec_flag - - and iter_case {c_lhs; c_guard; c_rhs} = - iter_pattern c_lhs; - may_iter iter_expression c_guard; - iter_expression c_rhs - - and iter_cases cases = - List.iter iter_case cases - - and iter_structure_item item = - Iter.enter_structure_item item; - begin - match item.str_desc with - Tstr_eval (exp, _attrs) -> iter_expression exp - | Tstr_value (rec_flag, list) -> - iter_bindings rec_flag list - | Tstr_primitive vd -> iter_value_description vd - | Tstr_type (rf, list) -> iter_type_declarations rf list - | Tstr_typext tyext -> iter_type_extension tyext - | Tstr_exception ext -> iter_extension_constructor ext - | Tstr_module x -> iter_module_binding x - | Tstr_recmodule list -> List.iter iter_module_binding list - | Tstr_modtype mtd -> iter_module_type_declaration mtd - | Tstr_open _ -> () - | Tstr_class () -> () - | Tstr_class_type list -> - List.iter - (fun (_, _, ct) -> iter_class_type_declaration ct) - list - | Tstr_include incl -> iter_module_expr incl.incl_mod - | Tstr_attribute _ -> - () - end; - Iter.leave_structure_item item - - and iter_module_binding x = - iter_module_expr x.mb_expr - - and iter_value_description v = - Iter.enter_value_description v; - iter_core_type v.val_desc; - Iter.leave_value_description v - - and iter_constructor_arguments = function - | Cstr_tuple l -> List.iter iter_core_type l - | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l - - and iter_constructor_declaration cd = - iter_constructor_arguments cd.cd_args; - option iter_core_type cd.cd_res; - - and iter_type_parameter (ct, _v) = - iter_core_type ct - - and iter_type_declaration decl = - Iter.enter_type_declaration decl; - List.iter iter_type_parameter decl.typ_params; - List.iter (fun (ct1, ct2, _loc) -> - iter_core_type ct1; - iter_core_type ct2 - ) decl.typ_cstrs; - begin match decl.typ_kind with - Ttype_abstract -> () - | Ttype_variant list -> - List.iter iter_constructor_declaration list - | Ttype_record list -> - List.iter - (fun ld -> - iter_core_type ld.ld_type - ) list - | Ttype_open -> () - end; - option iter_core_type decl.typ_manifest; - Iter.leave_type_declaration decl - - and iter_type_declarations rec_flag decls = - Iter.enter_type_declarations rec_flag; - List.iter iter_type_declaration decls; - Iter.leave_type_declarations rec_flag - - and iter_extension_constructor ext = - Iter.enter_extension_constructor ext; - begin match ext.ext_kind with - Text_decl(args, ret) -> - iter_constructor_arguments args; - option iter_core_type ret - | Text_rebind _ -> () - end; - Iter.leave_extension_constructor ext; - - and iter_type_extension tyext = - Iter.enter_type_extension tyext; - List.iter iter_type_parameter tyext.tyext_params; - List.iter iter_extension_constructor tyext.tyext_constructors; - Iter.leave_type_extension tyext - - and iter_pattern pat = - Iter.enter_pattern pat; - List.iter (fun (cstr, _, _attrs) -> match cstr with - | Tpat_type _ -> () - | Tpat_unpack -> () - | Tpat_open _ -> () - | Tpat_constraint ct -> iter_core_type ct) pat.pat_extra; - begin - match pat.pat_desc with - Tpat_any -> () - | Tpat_var _ -> () - | Tpat_alias (pat1, _, _) -> iter_pattern pat1 - | Tpat_constant _ -> () - | Tpat_tuple list -> - List.iter iter_pattern list - | Tpat_construct (_, _, args) -> - List.iter iter_pattern args - | Tpat_variant (_, pato, _) -> - begin match pato with - None -> () - | Some pat -> iter_pattern pat - end - | Tpat_record (list, _closed) -> - List.iter (fun (_, _, pat) -> iter_pattern pat) list - | Tpat_array list -> List.iter iter_pattern list - | Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2 - | Tpat_lazy p -> iter_pattern p - end; - Iter.leave_pattern pat - - and option f x = match x with None -> () | Some e -> f e - - and iter_expression exp = - Iter.enter_expression exp; - List.iter (function (cstr, _, _attrs) -> - match cstr with - Texp_constraint ct -> - iter_core_type ct - | Texp_coerce (cty1, cty2) -> - option iter_core_type cty1; iter_core_type cty2 - | Texp_open _ -> () - | Texp_poly cto -> option iter_core_type cto - | Texp_newtype _ -> ()) - exp.exp_extra; - begin - match exp.exp_desc with - Texp_ident _ -> () - | Texp_constant _ -> () - | Texp_let (rec_flag, list, exp) -> - iter_bindings rec_flag list; - iter_expression exp - | Texp_function { cases; _ } -> - iter_cases cases - | Texp_apply (exp, list) -> - iter_expression exp; - List.iter (fun (_label, expo) -> - match expo with - None -> () - | Some exp -> iter_expression exp - ) list - | Texp_match (exp, list1, list2, _) -> - iter_expression exp; - iter_cases list1; - iter_cases list2; - | Texp_try (exp, list) -> - iter_expression exp; - iter_cases list - | Texp_tuple list -> - List.iter iter_expression list - | Texp_construct (_, _, args) -> - List.iter iter_expression args - | Texp_variant (_label, expo) -> - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_record { fields; extended_expression; _ } -> - Array.iter (function - | _, Kept _ -> () - | _, Overridden (_, exp) -> iter_expression exp) - fields; - begin match extended_expression with - None -> () - | Some exp -> iter_expression exp - end - | Texp_field (exp, _, _label) -> - iter_expression exp - | Texp_setfield (exp1, _, _label, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_array list -> - List.iter iter_expression list - | Texp_ifthenelse (exp1, exp2, expo) -> - iter_expression exp1; - iter_expression exp2; - begin match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_sequence (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_while (exp1, exp2) -> - iter_expression exp1; - iter_expression exp2 - | Texp_for (_id, _, exp1, exp2, _dir, exp3) -> - iter_expression exp1; - iter_expression exp2; - iter_expression exp3 - | Texp_send (exp, _meth, expo) -> - iter_expression exp; - begin - match expo with - None -> () - | Some exp -> iter_expression exp - end - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> () - | Texp_letmodule (_id, _, mexpr, exp) -> - iter_module_expr mexpr; - iter_expression exp - | Texp_letexception (cd, exp) -> - iter_extension_constructor cd; - iter_expression exp - | Texp_assert exp -> iter_expression exp - | Texp_lazy exp -> iter_expression exp - | Texp_object () -> - () - | Texp_pack (mexpr) -> - iter_module_expr mexpr - | Texp_unreachable -> - () - | Texp_extension_constructor _ -> - () - end; - Iter.leave_expression exp; - - and iter_package_type pack = - Iter.enter_package_type pack; - List.iter (fun (_s, ct) -> iter_core_type ct) pack.pack_fields; - Iter.leave_package_type pack; - - and iter_signature sg = - Iter.enter_signature sg; - List.iter iter_signature_item sg.sig_items; - Iter.leave_signature sg; - - and iter_signature_item item = - Iter.enter_signature_item item; - begin - match item.sig_desc with - Tsig_value vd -> - iter_value_description vd - | Tsig_type (rf, list) -> - iter_type_declarations rf list - | Tsig_exception ext -> - iter_extension_constructor ext - | Tsig_typext tyext -> - iter_type_extension tyext - | Tsig_module md -> - iter_module_type md.md_type - | Tsig_recmodule list -> - List.iter (fun md -> iter_module_type md.md_type) list - | Tsig_modtype mtd -> - iter_module_type_declaration mtd - | Tsig_open _ -> () - | Tsig_include incl -> iter_module_type incl.incl_mod - | Tsig_class () -> () - | Tsig_class_type list -> - List.iter iter_class_type_declaration list - | Tsig_attribute _ -> () - end; - Iter.leave_signature_item item; - - and iter_module_type_declaration mtd = - Iter.enter_module_type_declaration mtd; - begin - match mtd.mtd_type with - | None -> () - | Some mtype -> iter_module_type mtype - end; - Iter.leave_module_type_declaration mtd - - - - and iter_class_type_declaration cd = - Iter.enter_class_type_declaration cd; - List.iter iter_type_parameter cd.ci_params; - iter_class_type cd.ci_expr; - Iter.leave_class_type_declaration cd; - - and iter_module_type mty = - Iter.enter_module_type mty; - begin - match mty.mty_desc with - Tmty_ident _ -> () - | Tmty_alias _ -> () - | Tmty_signature sg -> iter_signature sg - | Tmty_functor (_, _, mtype1, mtype2) -> - Misc.may iter_module_type mtype1; iter_module_type mtype2 - | Tmty_with (mtype, list) -> - iter_module_type mtype; - List.iter (fun (_path, _, withc) -> - iter_with_constraint withc - ) list - | Tmty_typeof mexpr -> - iter_module_expr mexpr - end; - Iter.leave_module_type mty; - - and iter_with_constraint cstr = - Iter.enter_with_constraint cstr; - begin - match cstr with - Twith_type decl -> iter_type_declaration decl - | Twith_module _ -> () - | Twith_typesubst decl -> iter_type_declaration decl - | Twith_modsubst _ -> () - end; - Iter.leave_with_constraint cstr; - - and iter_module_expr mexpr = - Iter.enter_module_expr mexpr; - begin - match mexpr.mod_desc with - Tmod_ident _ -> () - | Tmod_structure st -> iter_structure st - | Tmod_functor (_, _, mtype, mexpr) -> - Misc.may iter_module_type mtype; - iter_module_expr mexpr - | Tmod_apply (mexp1, mexp2, _) -> - iter_module_expr mexp1; - iter_module_expr mexp2 - | Tmod_constraint (mexpr, _, Tmodtype_implicit, _ ) -> - iter_module_expr mexpr - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - iter_module_expr mexpr; - iter_module_type mtype - | Tmod_unpack (exp, _mty) -> - iter_expression exp -(* iter_module_type mty *) - end; - Iter.leave_module_expr mexpr; - - - and iter_class_type ct = - Iter.enter_class_type ct; - begin - match ct.cltyp_desc with - Tcty_signature csg -> iter_class_signature csg - | Tcty_constr (_path, _, list) -> - List.iter iter_core_type list - | Tcty_arrow (_label, ct, cl) -> - iter_core_type ct; - iter_class_type cl - | Tcty_open (_, _, _, _, e) -> - iter_class_type e - end; - Iter.leave_class_type ct; - - and iter_class_signature cs = - Iter.enter_class_signature cs; - iter_core_type cs.csig_self; - List.iter iter_class_type_field cs.csig_fields; - Iter.leave_class_signature cs - - - and iter_class_type_field ctf = - Iter.enter_class_type_field ctf; - begin - match ctf.ctf_desc with - Tctf_inherit ct -> iter_class_type ct - | Tctf_val (_s, _mut, _virt, ct) -> - iter_core_type ct - | Tctf_method (_s, _priv, _virt, ct) -> - iter_core_type ct - | Tctf_constraint (ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Tctf_attribute _ -> () - end; - Iter.leave_class_type_field ctf - - and iter_core_type ct = - Iter.enter_core_type ct; - begin - match ct.ctyp_desc with - Ttyp_any -> () - | Ttyp_var _ -> () - | Ttyp_arrow (_label, ct1, ct2) -> - iter_core_type ct1; - iter_core_type ct2 - | Ttyp_tuple list -> List.iter iter_core_type list - | Ttyp_constr (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_object (list, _o) -> - List.iter iter_object_field list - | Ttyp_class (_path, _, list) -> - List.iter iter_core_type list - | Ttyp_alias (ct, _s) -> - iter_core_type ct - | Ttyp_variant (list, _bool, _labels) -> - List.iter iter_row_field list - | Ttyp_poly (_list, ct) -> iter_core_type ct - | Ttyp_package pack -> iter_package_type pack - end; - Iter.leave_core_type ct - - and iter_row_field rf = - match rf with - Ttag (_label, _attrs, _bool, list) -> - List.iter iter_core_type list - | Tinherit ct -> iter_core_type ct - - and iter_object_field ofield = - match ofield with - OTtag (_, _, ct) | OTinherit ct -> iter_core_type ct - - end - -module DefaultIteratorArgument = struct - - let enter_structure _ = () - let enter_value_description _ = () - let enter_type_extension _ = () - let enter_extension_constructor _ = () - let enter_pattern _ = () - let enter_expression _ = () - let enter_package_type _ = () - let enter_signature _ = () - let enter_signature_item _ = () - let enter_module_type_declaration _ = () - let enter_module_type _ = () - let enter_module_expr _ = () - let enter_with_constraint _ = () - let enter_class_signature _ = () - - let enter_class_description _ = () - let enter_class_type_declaration _ = () - let enter_class_type _ = () - let enter_class_type_field _ = () - let enter_core_type _ = () - let enter_structure_item _ = () - - - let leave_structure _ = () - let leave_value_description _ = () - let leave_type_extension _ = () - let leave_extension_constructor _ = () - let leave_pattern _ = () - let leave_expression _ = () - let leave_package_type _ = () - let leave_signature _ = () - let leave_signature_item _ = () - let leave_module_type_declaration _ = () - let leave_module_type _ = () - let leave_module_expr _ = () - let leave_with_constraint _ = () - let leave_class_signature _ = () - - let leave_class_description _ = () - let leave_class_type_declaration _ = () - let leave_class_type _ = () - let leave_class_type_field _ = () - let leave_core_type _ = () - let leave_structure_item _ = () - - let enter_binding _ = () - let leave_binding _ = () - - let enter_bindings _ = () - let leave_bindings _ = () - - let enter_type_declaration _ = () - let leave_type_declaration _ = () - - let enter_type_declarations _ = () - let leave_type_declarations _ = () -end diff --git a/jscomp/ml/typedtreeIter.mli b/jscomp/ml/typedtreeIter.mli deleted file mode 100644 index b215c20..0000000 --- a/jscomp/ml/typedtreeIter.mli +++ /dev/null @@ -1,88 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 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. *) -(* *) -(**************************************************************************) - -open Asttypes -open Typedtree - - -module type IteratorArgument = sig - val enter_structure : structure -> unit - val enter_value_description : value_description -> unit - val enter_type_extension : type_extension -> unit - val enter_extension_constructor : extension_constructor -> unit - val enter_pattern : pattern -> unit - val enter_expression : expression -> unit - val enter_package_type : package_type -> unit - val enter_signature : signature -> unit - val enter_signature_item : signature_item -> unit - val enter_module_type_declaration : module_type_declaration -> unit - val enter_module_type : module_type -> unit - val enter_module_expr : module_expr -> unit - val enter_with_constraint : with_constraint -> unit - val enter_class_signature : class_signature -> unit - val enter_class_description : class_description -> unit - val enter_class_type_declaration : class_type_declaration -> unit - val enter_class_type : class_type -> unit - val enter_class_type_field : class_type_field -> unit - val enter_core_type : core_type -> unit - val enter_structure_item : structure_item -> unit - - - val leave_structure : structure -> unit - val leave_value_description : value_description -> unit - val leave_type_extension : type_extension -> unit - val leave_extension_constructor : extension_constructor -> unit - val leave_pattern : pattern -> unit - val leave_expression : expression -> unit - val leave_package_type : package_type -> unit - val leave_signature : signature -> unit - val leave_signature_item : signature_item -> unit - val leave_module_type_declaration : module_type_declaration -> unit - val leave_module_type : module_type -> unit - val leave_module_expr : module_expr -> unit - val leave_with_constraint : with_constraint -> unit - val leave_class_signature : class_signature -> unit - val leave_class_description : class_description -> unit - val leave_class_type_declaration : class_type_declaration -> unit - val leave_class_type : class_type -> unit - val leave_class_type_field : class_type_field -> unit - val leave_core_type : core_type -> unit - val leave_structure_item : structure_item -> unit - - val enter_bindings : rec_flag -> unit - val enter_binding : value_binding -> unit - val leave_binding : value_binding -> unit - val leave_bindings : rec_flag -> unit - - val enter_type_declarations : rec_flag -> unit - val enter_type_declaration : type_declaration -> unit - val leave_type_declaration : type_declaration -> unit - val leave_type_declarations : rec_flag -> unit - -end - -module [@warning "-67"] MakeIterator : - functor (Iter : IteratorArgument) -> - sig - val iter_structure : structure -> unit - val iter_signature : signature -> unit - val iter_structure_item : structure_item -> unit - val iter_signature_item : signature_item -> unit - val iter_expression : expression -> unit - val iter_module_type : module_type -> unit - val iter_pattern : pattern -> unit - end - -module DefaultIteratorArgument : IteratorArgument diff --git a/jscomp/ml/typedtreeMap.ml b/jscomp/ml/typedtreeMap.ml deleted file mode 100644 index 7d4119b..0000000 --- a/jscomp/ml/typedtreeMap.ml +++ /dev/null @@ -1,633 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -open Typedtree - -module type MapArgument = sig - val enter_structure : structure -> structure - val enter_value_description : value_description -> value_description - val enter_type_declaration : type_declaration -> type_declaration - val enter_type_extension : type_extension -> type_extension - val enter_extension_constructor : - extension_constructor -> extension_constructor - val enter_pattern : pattern -> pattern - val enter_expression : expression -> expression - val enter_package_type : package_type -> package_type - val enter_signature : signature -> signature - val enter_signature_item : signature_item -> signature_item - val enter_module_type_declaration : - module_type_declaration -> module_type_declaration - val enter_module_type : module_type -> module_type - val enter_module_expr : module_expr -> module_expr - val enter_with_constraint : with_constraint -> with_constraint - val enter_class_signature : class_signature -> class_signature - - val enter_class_description : class_description -> class_description - val enter_class_type_declaration : - class_type_declaration -> class_type_declaration - val enter_class_type : class_type -> class_type - val enter_class_type_field : class_type_field -> class_type_field - val enter_core_type : core_type -> core_type - val enter_structure_item : structure_item -> structure_item - - val leave_structure : structure -> structure - val leave_value_description : value_description -> value_description - val leave_type_declaration : type_declaration -> type_declaration - val leave_type_extension : type_extension -> type_extension - val leave_extension_constructor : - extension_constructor -> extension_constructor - val leave_pattern : pattern -> pattern - val leave_expression : expression -> expression - val leave_package_type : package_type -> package_type - val leave_signature : signature -> signature - val leave_signature_item : signature_item -> signature_item - val leave_module_type_declaration : - module_type_declaration -> module_type_declaration - val leave_module_type : module_type -> module_type - val leave_module_expr : module_expr -> module_expr - val leave_with_constraint : with_constraint -> with_constraint - val leave_class_signature : class_signature -> class_signature - - val leave_class_description : class_description -> class_description - val leave_class_type_declaration : - class_type_declaration -> class_type_declaration - val leave_class_type : class_type -> class_type - val leave_class_type_field : class_type_field -> class_type_field - val leave_core_type : core_type -> core_type - val leave_structure_item : structure_item -> structure_item - -end - - -module MakeMap(Map : MapArgument) = struct - - open Misc - - let rec map_structure str = - let str = Map.enter_structure str in - let str_items = List.map map_structure_item str.str_items in - Map.leave_structure { str with str_items = str_items } - - and map_binding vb = - { - vb_pat = map_pattern vb.vb_pat; - vb_expr = map_expression vb.vb_expr; - vb_attributes = vb.vb_attributes; - vb_loc = vb.vb_loc; - } - - and map_bindings list = - List.map map_binding list - - and map_case {c_lhs; c_guard; c_rhs} = - { - c_lhs = map_pattern c_lhs; - c_guard = may_map map_expression c_guard; - c_rhs = map_expression c_rhs; - } - - and map_cases list = - List.map map_case list - - and map_structure_item item = - let item = Map.enter_structure_item item in - let str_desc = - match item.str_desc with - Tstr_eval (exp, attrs) -> Tstr_eval (map_expression exp, attrs) - | Tstr_value (rec_flag, list) -> - Tstr_value (rec_flag, map_bindings list) - | Tstr_primitive vd -> - Tstr_primitive (map_value_description vd) - | Tstr_type (rf, list) -> - Tstr_type (rf, List.map map_type_declaration list) - | Tstr_typext tyext -> - Tstr_typext (map_type_extension tyext) - | Tstr_exception ext -> - Tstr_exception (map_extension_constructor ext) - | Tstr_module x -> - Tstr_module (map_module_binding x) - | Tstr_recmodule list -> - let list = List.map map_module_binding list in - Tstr_recmodule list - | Tstr_modtype mtd -> - Tstr_modtype (map_module_type_declaration mtd) - | Tstr_open od -> Tstr_open od - | Tstr_class () -> assert false - | Tstr_class_type list -> - let list = - List.map - (fun (id, name, ct) -> - id, name, map_class_type_declaration ct) - list - in - Tstr_class_type list - | Tstr_include incl -> - Tstr_include {incl with incl_mod = map_module_expr incl.incl_mod} - | Tstr_attribute x -> Tstr_attribute x - in - Map.leave_structure_item { item with str_desc = str_desc} - - and map_module_binding x = - {x with mb_expr = map_module_expr x.mb_expr} - - and map_value_description v = - let v = Map.enter_value_description v in - let val_desc = map_core_type v.val_desc in - Map.leave_value_description { v with val_desc = val_desc } - - and map_type_declaration decl = - let decl = Map.enter_type_declaration decl in - let typ_params = List.map map_type_parameter decl.typ_params in - let typ_cstrs = List.map (fun (ct1, ct2, loc) -> - (map_core_type ct1, - map_core_type ct2, - loc) - ) decl.typ_cstrs in - let typ_kind = match decl.typ_kind with - Ttype_abstract -> Ttype_abstract - | Ttype_variant list -> - let list = List.map map_constructor_declaration list in - Ttype_variant list - | Ttype_record list -> - let list = - List.map - (fun ld -> - {ld with ld_type = map_core_type ld.ld_type} - ) list - in - Ttype_record list - | Ttype_open -> Ttype_open - in - let typ_manifest = may_map map_core_type decl.typ_manifest in - Map.leave_type_declaration { decl with typ_params = typ_params; - typ_cstrs = typ_cstrs; typ_kind = typ_kind; typ_manifest = typ_manifest } - - and map_type_parameter (ct, v) = (map_core_type ct, v) - - and map_constructor_arguments = function - | Cstr_tuple l -> - Cstr_tuple (List.map map_core_type l) - | Cstr_record l -> - Cstr_record - (List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type}) - l) - - and map_constructor_declaration cd = - let cd_args = map_constructor_arguments cd.cd_args in - {cd with cd_args; - cd_res = may_map map_core_type cd.cd_res - } - - and map_type_extension tyext = - let tyext = Map.enter_type_extension tyext in - let tyext_params = List.map map_type_parameter tyext.tyext_params in - let tyext_constructors = - List.map map_extension_constructor tyext.tyext_constructors - in - Map.leave_type_extension { tyext with tyext_params = tyext_params; - tyext_constructors = tyext_constructors } - - and map_extension_constructor ext = - let ext = Map.enter_extension_constructor ext in - let ext_kind = match ext.ext_kind with - Text_decl(args, ret) -> - let args = map_constructor_arguments args in - let ret = may_map map_core_type ret in - Text_decl(args, ret) - | Text_rebind(p, lid) -> Text_rebind(p, lid) - in - Map.leave_extension_constructor {ext with ext_kind = ext_kind} - - and map_pattern pat = - let pat = Map.enter_pattern pat in - let pat_desc = - match pat.pat_desc with - | Tpat_alias (pat1, p, text) -> - let pat1 = map_pattern pat1 in - Tpat_alias (pat1, p, text) - | Tpat_tuple list -> Tpat_tuple (List.map map_pattern list) - | Tpat_construct (lid, cstr_decl, args) -> - Tpat_construct (lid, cstr_decl, - List.map map_pattern args) - | Tpat_variant (label, pato, rowo) -> - let pato = match pato with - None -> pato - | Some pat -> Some (map_pattern pat) - in - Tpat_variant (label, pato, rowo) - | Tpat_record (list, closed) -> - Tpat_record (List.map (fun (lid, lab_desc, pat) -> - (lid, lab_desc, map_pattern pat) ) list, closed) - | Tpat_array list -> Tpat_array (List.map map_pattern list) - | Tpat_or (p1, p2, rowo) -> - Tpat_or (map_pattern p1, map_pattern p2, rowo) - | Tpat_lazy p -> Tpat_lazy (map_pattern p) - | Tpat_constant _ - | Tpat_any - | Tpat_var _ -> pat.pat_desc - - in - let pat_extra = List.map map_pat_extra pat.pat_extra in - Map.leave_pattern { pat with pat_desc = pat_desc; pat_extra = pat_extra } - - and map_pat_extra pat_extra = - match pat_extra with - | Tpat_constraint ct, loc, attrs -> - (Tpat_constraint (map_core_type ct), loc, attrs) - | (Tpat_type _ | Tpat_unpack | Tpat_open _ ), _, _ -> pat_extra - - and map_expression exp = - let exp = Map.enter_expression exp in - let exp_desc = - match exp.exp_desc with - Texp_ident (_, _, _) - | Texp_constant _ -> exp.exp_desc - | Texp_let (rec_flag, list, exp) -> - Texp_let (rec_flag, - map_bindings list, - map_expression exp) - | Texp_function { arg_label; param; cases; partial; } -> - Texp_function { arg_label; param; cases = map_cases cases; partial; } - | Texp_apply (exp, list) -> - Texp_apply (map_expression exp, - List.map (fun (label, expo) -> - let expo = - match expo with - None -> expo - | Some exp -> Some (map_expression exp) - in - (label, expo) - ) list ) - | Texp_match (exp, list1, list2, partial) -> - Texp_match ( - map_expression exp, - map_cases list1, - map_cases list2, - partial - ) - | Texp_try (exp, list) -> - Texp_try ( - map_expression exp, - map_cases list - ) - | Texp_tuple list -> - Texp_tuple (List.map map_expression list) - | Texp_construct (lid, cstr_desc, args) -> - Texp_construct (lid, cstr_desc, - List.map map_expression args ) - | Texp_variant (label, expo) -> - let expo =match expo with - None -> expo - | Some exp -> Some (map_expression exp) - in - Texp_variant (label, expo) - | Texp_record { fields; representation; extended_expression } -> - let fields = - Array.map (function - | label, Kept t -> label, Kept t - | label, Overridden (lid, exp) -> - label, Overridden (lid, map_expression exp)) - fields - in - let extended_expression = match extended_expression with - None -> extended_expression - | Some exp -> Some (map_expression exp) - in - Texp_record { fields; representation; extended_expression } - | Texp_field (exp, lid, label) -> - Texp_field (map_expression exp, lid, label) - | Texp_setfield (exp1, lid, label, exp2) -> - Texp_setfield ( - map_expression exp1, - lid, - label, - map_expression exp2) - | Texp_array list -> - Texp_array (List.map map_expression list) - | Texp_ifthenelse (exp1, exp2, expo) -> - Texp_ifthenelse ( - map_expression exp1, - map_expression exp2, - match expo with - None -> expo - | Some exp -> Some (map_expression exp) - ) - | Texp_sequence (exp1, exp2) -> - Texp_sequence ( - map_expression exp1, - map_expression exp2 - ) - | Texp_while (exp1, exp2) -> - Texp_while ( - map_expression exp1, - map_expression exp2 - ) - | Texp_for (id, name, exp1, exp2, dir, exp3) -> - Texp_for ( - id, name, - map_expression exp1, - map_expression exp2, - dir, - map_expression exp3 - ) - | Texp_send (exp, meth, expo) -> - Texp_send (map_expression exp, meth, may_map map_expression expo) - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> - assert false - | Texp_letmodule (id, name, mexpr, exp) -> - Texp_letmodule ( - id, name, - map_module_expr mexpr, - map_expression exp - ) - | Texp_letexception (cd, exp) -> - Texp_letexception ( - map_extension_constructor cd, - map_expression exp - ) - | Texp_assert exp -> Texp_assert (map_expression exp) - | Texp_lazy exp -> Texp_lazy (map_expression exp) - | Texp_object () -> - Texp_object () - | Texp_pack (mexpr) -> - Texp_pack (map_module_expr mexpr) - | Texp_unreachable -> - Texp_unreachable - | Texp_extension_constructor _ as e -> - e - in - let exp_extra = List.map map_exp_extra exp.exp_extra in - Map.leave_expression { - exp with - exp_desc = exp_desc; - exp_extra = exp_extra; } - - and map_exp_extra ((desc, loc, attrs) as exp_extra) = - match desc with - | Texp_constraint ct -> - Texp_constraint (map_core_type ct), loc, attrs - | Texp_coerce (None, ct) -> - Texp_coerce (None, map_core_type ct), loc, attrs - | Texp_coerce (Some ct1, ct2) -> - Texp_coerce (Some (map_core_type ct1), - map_core_type ct2), loc, attrs - | Texp_poly (Some ct) -> - Texp_poly (Some ( map_core_type ct )), loc, attrs - | Texp_newtype _ - | Texp_open _ - | Texp_poly None -> exp_extra - - - and map_package_type pack = - let pack = Map.enter_package_type pack in - let pack_fields = List.map ( - fun (s, ct) -> (s, map_core_type ct) ) pack.pack_fields in - Map.leave_package_type { pack with pack_fields = pack_fields } - - and map_signature sg = - let sg = Map.enter_signature sg in - let sig_items = List.map map_signature_item sg.sig_items in - Map.leave_signature { sg with sig_items = sig_items } - - and map_signature_item item = - let item = Map.enter_signature_item item in - let sig_desc = - match item.sig_desc with - Tsig_value vd -> - Tsig_value (map_value_description vd) - | Tsig_type (rf, list) -> - Tsig_type (rf, List.map map_type_declaration list) - | Tsig_typext tyext -> - Tsig_typext (map_type_extension tyext) - | Tsig_exception ext -> - Tsig_exception (map_extension_constructor ext) - | Tsig_module md -> - Tsig_module {md with md_type = map_module_type md.md_type} - | Tsig_recmodule list -> - Tsig_recmodule - (List.map - (fun md -> {md with md_type = map_module_type md.md_type}) - list - ) - | Tsig_modtype mtd -> - Tsig_modtype (map_module_type_declaration mtd) - | Tsig_open _ -> item.sig_desc - | Tsig_include incl -> - Tsig_include {incl with incl_mod = map_module_type incl.incl_mod} - | Tsig_class () -> Tsig_class () - | Tsig_class_type list -> - Tsig_class_type (List.map map_class_type_declaration list) - | Tsig_attribute _ as x -> x - in - Map.leave_signature_item { item with sig_desc = sig_desc } - - and map_module_type_declaration mtd = - let mtd = Map.enter_module_type_declaration mtd in - let mtd = {mtd with mtd_type = may_map map_module_type mtd.mtd_type} in - Map.leave_module_type_declaration mtd - - - - and map_class_type_declaration cd = - let cd = Map.enter_class_type_declaration cd in - let ci_params = List.map map_type_parameter cd.ci_params in - let ci_expr = map_class_type cd.ci_expr in - Map.leave_class_type_declaration - { cd with ci_params = ci_params; ci_expr = ci_expr } - - and map_module_type mty = - let mty = Map.enter_module_type mty in - let mty_desc = - match mty.mty_desc with - Tmty_ident _ -> mty.mty_desc - | Tmty_alias _ -> mty.mty_desc - | Tmty_signature sg -> Tmty_signature (map_signature sg) - | Tmty_functor (id, name, mtype1, mtype2) -> - Tmty_functor (id, name, Misc.may_map map_module_type mtype1, - map_module_type mtype2) - | Tmty_with (mtype, list) -> - Tmty_with (map_module_type mtype, - List.map (fun (path, lid, withc) -> - (path, lid, map_with_constraint withc) - ) list) - | Tmty_typeof mexpr -> - Tmty_typeof (map_module_expr mexpr) - in - Map.leave_module_type { mty with mty_desc = mty_desc} - - and map_with_constraint cstr = - let cstr = Map.enter_with_constraint cstr in - let cstr = - match cstr with - Twith_type decl -> Twith_type (map_type_declaration decl) - | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl) - | Twith_module _ -> cstr - | Twith_modsubst _ -> cstr - in - Map.leave_with_constraint cstr - - and map_module_expr mexpr = - let mexpr = Map.enter_module_expr mexpr in - let mod_desc = - match mexpr.mod_desc with - Tmod_ident _ -> mexpr.mod_desc - | Tmod_structure st -> Tmod_structure (map_structure st) - | Tmod_functor (id, name, mtype, mexpr) -> - Tmod_functor (id, name, Misc.may_map map_module_type mtype, - map_module_expr mexpr) - | Tmod_apply (mexp1, mexp2, coercion) -> - Tmod_apply (map_module_expr mexp1, map_module_expr mexp2, coercion) - | Tmod_constraint (mexpr, mod_type, Tmodtype_implicit, coercion ) -> - Tmod_constraint (map_module_expr mexpr, mod_type, - Tmodtype_implicit, coercion) - | Tmod_constraint (mexpr, mod_type, - Tmodtype_explicit mtype, coercion) -> - Tmod_constraint (map_module_expr mexpr, mod_type, - Tmodtype_explicit (map_module_type mtype), - coercion) - | Tmod_unpack (exp, mod_type) -> - Tmod_unpack (map_expression exp, mod_type) - in - Map.leave_module_expr { mexpr with mod_desc = mod_desc } - - and map_class_type ct = - let ct = Map.enter_class_type ct in - let cltyp_desc = - match ct.cltyp_desc with - Tcty_signature csg -> Tcty_signature (map_class_signature csg) - | Tcty_constr (path, lid, list) -> - Tcty_constr (path, lid, List.map map_core_type list) - | Tcty_arrow (label, ct, cl) -> - Tcty_arrow (label, map_core_type ct, map_class_type cl) - | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, env, map_class_type e) - in - Map.leave_class_type { ct with cltyp_desc = cltyp_desc } - - and map_class_signature cs = - let cs = Map.enter_class_signature cs in - let csig_self = map_core_type cs.csig_self in - let csig_fields = List.map map_class_type_field cs.csig_fields in - Map.leave_class_signature { cs with - csig_self = csig_self; csig_fields = csig_fields } - - - and map_class_type_field ctf = - let ctf = Map.enter_class_type_field ctf in - let ctf_desc = - match ctf.ctf_desc with - Tctf_inherit ct -> Tctf_inherit (map_class_type ct) - | Tctf_val (s, mut, virt, ct) -> - Tctf_val (s, mut, virt, map_core_type ct) - | Tctf_method (s, priv, virt, ct) -> - Tctf_method (s, priv, virt, map_core_type ct) - | Tctf_constraint (ct1, ct2) -> - Tctf_constraint (map_core_type ct1, map_core_type ct2) - | Tctf_attribute _ as x -> x - in - Map.leave_class_type_field { ctf with ctf_desc = ctf_desc } - - and map_core_type ct = - let ct = Map.enter_core_type ct in - let ctyp_desc = - match ct.ctyp_desc with - Ttyp_any - | Ttyp_var _ -> ct.ctyp_desc - | Ttyp_arrow (label, ct1, ct2) -> - Ttyp_arrow (label, map_core_type ct1, map_core_type ct2) - | Ttyp_tuple list -> Ttyp_tuple (List.map map_core_type list) - | Ttyp_constr (path, lid, list) -> - Ttyp_constr (path, lid, List.map map_core_type list) - | Ttyp_object (list, o) -> - Ttyp_object - (List.map map_object_field list, o) - | Ttyp_class (path, lid, list) -> - Ttyp_class (path, lid, List.map map_core_type list) - | Ttyp_alias (ct, s) -> Ttyp_alias (map_core_type ct, s) - | Ttyp_variant (list, bool, labels) -> - Ttyp_variant (List.map map_row_field list, bool, labels) - | Ttyp_poly (list, ct) -> Ttyp_poly (list, map_core_type ct) - | Ttyp_package pack -> Ttyp_package (map_package_type pack) - in - Map.leave_core_type { ct with ctyp_desc = ctyp_desc } - - and map_row_field rf = - match rf with - Ttag (label, attrs, bool, list) -> - Ttag (label, attrs, bool, List.map map_core_type list) - | Tinherit ct -> Tinherit (map_core_type ct) - - and map_object_field ofield = - match ofield with - OTtag (label, attrs, ct) -> - OTtag (label, attrs, map_core_type ct) - | OTinherit ct -> OTinherit (map_core_type ct) - -end - - -module DefaultMapArgument = struct - - let enter_structure t = t - let enter_value_description t = t - let enter_type_declaration t = t - let enter_type_extension t = t - let enter_extension_constructor t = t - let enter_pattern t = t - let enter_expression t = t - let enter_package_type t = t - let enter_signature t = t - let enter_signature_item t = t - let enter_module_type_declaration t = t - let enter_module_type t = t - let enter_module_expr t = t - let enter_with_constraint t = t - let enter_class_signature t = t - - let enter_class_description t = t - let enter_class_type_declaration t = t - let enter_class_type t = t - let enter_class_type_field t = t - let enter_core_type t = t - let enter_structure_item t = t - - - let leave_structure t = t - let leave_value_description t = t - let leave_type_declaration t = t - let leave_type_extension t = t - let leave_extension_constructor t = t - let leave_pattern t = t - let leave_expression t = t - let leave_package_type t = t - let leave_signature t = t - let leave_signature_item t = t - let leave_module_type_declaration t = t - let leave_module_type t = t - let leave_module_expr t = t - let leave_with_constraint t = t - let leave_class_signature t = t - - let leave_class_description t = t - let leave_class_type_declaration t = t - let leave_class_type t = t - let leave_class_type_field t = t - let leave_core_type t = t - let leave_structure_item t = t - -end diff --git a/jscomp/ml/typedtreeMap.mli b/jscomp/ml/typedtreeMap.mli deleted file mode 100644 index ca23e62..0000000 --- a/jscomp/ml/typedtreeMap.mli +++ /dev/null @@ -1,85 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Fabrice Le Fessant, INRIA Saclay *) -(* *) -(* Copyright 2012 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. *) -(* *) -(**************************************************************************) - -open Typedtree - -module type MapArgument = sig - val enter_structure : structure -> structure - val enter_value_description : value_description -> value_description - val enter_type_declaration : type_declaration -> type_declaration - val enter_type_extension : type_extension -> type_extension - val enter_extension_constructor : - extension_constructor -> extension_constructor - val enter_pattern : pattern -> pattern - val enter_expression : expression -> expression - val enter_package_type : package_type -> package_type - val enter_signature : signature -> signature - val enter_signature_item : signature_item -> signature_item - val enter_module_type_declaration : - module_type_declaration -> module_type_declaration - val enter_module_type : module_type -> module_type - val enter_module_expr : module_expr -> module_expr - val enter_with_constraint : with_constraint -> with_constraint - val enter_class_signature : class_signature -> class_signature - val enter_class_description : class_description -> class_description - val enter_class_type_declaration : - class_type_declaration -> class_type_declaration - val enter_class_type : class_type -> class_type - val enter_class_type_field : class_type_field -> class_type_field - val enter_core_type : core_type -> core_type - val enter_structure_item : structure_item -> structure_item - - val leave_structure : structure -> structure - val leave_value_description : value_description -> value_description - val leave_type_declaration : type_declaration -> type_declaration - val leave_type_extension : type_extension -> type_extension - val leave_extension_constructor : - extension_constructor -> extension_constructor - val leave_pattern : pattern -> pattern - val leave_expression : expression -> expression - val leave_package_type : package_type -> package_type - val leave_signature : signature -> signature - val leave_signature_item : signature_item -> signature_item - val leave_module_type_declaration : - module_type_declaration -> module_type_declaration - val leave_module_type : module_type -> module_type - val leave_module_expr : module_expr -> module_expr - val leave_with_constraint : with_constraint -> with_constraint - val leave_class_signature : class_signature -> class_signature - val leave_class_description : class_description -> class_description - val leave_class_type_declaration : - class_type_declaration -> class_type_declaration - val leave_class_type : class_type -> class_type - val leave_class_type_field : class_type_field -> class_type_field - val leave_core_type : core_type -> core_type - val leave_structure_item : structure_item -> structure_item - -end - -module MakeMap : - functor - (Iter : MapArgument) -> -sig - val map_structure : structure -> structure - val map_pattern : pattern -> pattern - val map_structure_item : structure_item -> structure_item - val map_expression : expression -> expression - - val map_signature : signature -> signature - val map_signature_item : signature_item -> signature_item - val map_module_type : module_type -> module_type -end - -module DefaultMapArgument : MapArgument diff --git a/jscomp/ml/typemod.ml b/jscomp/ml/typemod.ml deleted file mode 100644 index 76b9cf1..0000000 --- a/jscomp/ml/typemod.ml +++ /dev/null @@ -1,1935 +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. *) -(* *) -(**************************************************************************) - -open Misc -open Longident -open Path -open Asttypes -open Parsetree -open Types -open Format - -type error = - Cannot_apply of module_type - | Not_included of Includemod.error list - | Cannot_eliminate_dependency of module_type - | Signature_expected - | Structure_expected of module_type - | With_no_component of Longident.t - | With_mismatch of Longident.t * Includemod.error list - | With_makes_applicative_functor_ill_typed of - Longident.t * Path.t * Includemod.error list - | With_changes_module_alias of Longident.t * Ident.t * Path.t - | With_cannot_remove_constrained_type - | Repeated_name of string * string * Warnings.loc - | Non_generalizable of type_expr - | Non_generalizable_module of module_type - | Interface_not_compiled of string - | Not_allowed_in_functor_body - | Not_a_packed_module of type_expr - | Incomplete_packed_module of type_expr - | Scoping_pack of Longident.t * type_expr - | Recursive_module_require_explicit_type - | Apply_generative - | Cannot_scrape_alias of Path.t - -exception Error of Location.t * Env.t * error -exception Error_forward of Location.error - - - -let rescript_hide_attributes (x : Typedtree.attributes) = - match x with - | [] -> false - | ({txt = "internal.local";_},_) :: _ -> true - | _ :: rest -> - Ext_list.exists rest (fun (x,_) -> x.txt = "internal.local") - -let rescript_hide (x : Typedtree.structure_item_desc) = - match x with - | Tstr_module {mb_attributes} -> rescript_hide_attributes mb_attributes - | _ -> false - -open Typedtree - -let fst3 (x,_,_) = x - -let rec path_concat head p = - match p with - Pident tail -> Pdot (Pident head, Ident.name tail, 0) - | Pdot (pre, s, pos) -> Pdot (path_concat head pre, s, pos) - | Papply _ -> assert false - -(* Extract a signature from a module type *) - -let extract_sig env loc mty = - match Env.scrape_alias env mty with - Mty_signature sg -> sg - | Mty_alias(_, path) -> - raise(Error(loc, env, Cannot_scrape_alias path)) - | _ -> raise(Error(loc, env, Signature_expected)) - -let extract_sig_open env loc mty = - match Env.scrape_alias env mty with - Mty_signature sg -> sg - | Mty_alias(_, path) -> - raise(Error(loc, env, Cannot_scrape_alias path)) - | mty -> raise(Error(loc, env, Structure_expected mty)) - -(* Compute the environment after opening a module *) - -let type_open_ ?used_slot ?toplevel ovf env loc lid = - let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in - match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with - | Some env -> path, env - | None -> - let md = Env.find_module path env in - ignore (extract_sig_open env lid.loc md.md_type); - assert false - -let type_open ?toplevel env sod = - let (path, newenv) = - Builtin_attributes.warning_scope sod.popen_attributes - (fun () -> - type_open_ ?toplevel sod.popen_override env sod.popen_loc - sod.popen_lid - ) - in - let od = - { - open_override = sod.popen_override; - open_path = path; - open_txt = sod.popen_lid; - open_attributes = sod.popen_attributes; - open_loc = sod.popen_loc; - } - in - (path, newenv, od) - -(* Record a module type *) -let rm node = - Stypes.record (Stypes.Ti_mod node); - node - -(* Forward declaration, to be filled in by type_module_type_of *) -let type_module_type_of_fwd : - (Env.t -> Parsetree.module_expr -> - Typedtree.module_expr * Types.module_type) ref - = ref (fun _env _m -> assert false) - -(* Merge one "with" constraint in a signature *) - -let rec add_rec_types env = function - Sig_type(id, decl, Trec_next) :: rem -> - add_rec_types (Env.add_type ~check:true id decl env) rem - | _ -> env - -let check_type_decl env loc id row_id newdecl decl rs rem = - let env = Env.add_type ~check:true id newdecl env in - let env = - match row_id with - | None -> env - | Some id -> Env.add_type ~check:false id newdecl env - in - let env = if rs = Trec_not then env else add_rec_types env rem in - Includemod.type_declarations ~loc env id newdecl decl; - Typedecl.check_coherence env loc id newdecl - -let update_rec_next rs rem = - match rs with - Trec_next -> rem - | Trec_first | Trec_not -> - match rem with - Sig_type (id, decl, Trec_next) :: rem -> - Sig_type (id, decl, rs) :: rem - | Sig_module (id, mty, Trec_next) :: rem -> - Sig_module (id, mty, rs) :: rem - | _ -> rem - -let make p n i = - let open Variance in - set May_pos p (set May_neg n (set May_weak n (set Inj i null))) - -let rec iter_path_apply p ~f = - match p with - | Pident _ -> () - | Pdot (p, _, _) -> iter_path_apply p ~f - | Papply (p1, p2) -> - iter_path_apply p1 ~f; - iter_path_apply p2 ~f; - f p1 p2 (* after recursing, so we know both paths are well typed *) - -let path_is_strict_prefix = - let rec list_is_strict_prefix l ~prefix = - match l, prefix with - | [], [] -> false - | _ :: _, [] -> true - | [], _ :: _ -> false - | s1 :: t1, s2 :: t2 -> - String.equal s1 s2 && list_is_strict_prefix t1 ~prefix:t2 - in - fun path ~prefix -> - match Path.flatten path, Path.flatten prefix with - | `Contains_apply, _ | _, `Contains_apply -> false - | `Ok (ident1, l1), `Ok (ident2, l2) -> - Ident.same ident1 ident2 - && list_is_strict_prefix l1 ~prefix:l2 - -let iterator_with_env env = - let env = ref env in - let super = Btype.type_iterators in - env, { super with - Btype.it_signature = (fun self sg -> - (* add all items to the env before recursing down, to handle recursive - definitions *) - let env_before = !env in - List.iter (fun i -> env := Env.add_item i !env) sg; - super.Btype.it_signature self sg; - env := env_before - ); - Btype.it_module_type = (fun self -> function - | Mty_functor (param, mty_arg, mty_body) -> - may (self.Btype.it_module_type self) mty_arg; - let env_before = !env in - env := Env.add_module ~arg:true param (Btype.default_mty mty_arg) !env; - self.Btype.it_module_type self mty_body; - env := env_before; - | mty -> - super.Btype.it_module_type self mty - ) - } - -let retype_applicative_functor_type ~loc env funct arg = - let mty_functor = (Env.find_module funct env).md_type in - let mty_arg = (Env.find_module arg env).md_type in - let mty_param = - match Env.scrape_alias env mty_functor with - | Mty_functor (_, Some mty_param, _) -> mty_param - | _ -> assert false (* could trigger due to MPR#7611 *) - in - let aliasable = not (Env.is_functor_arg arg env) in - ignore(Includemod.modtypes ~loc env - (Mtype.strengthen ~aliasable env mty_arg arg) mty_param) - -(* When doing a deep destructive substitution with type M.N.t := .., we change M - and M.N and so we have to check that uses of the modules other than just - extracting components from them still make sense. There are only two such - kinds of uses: - - applicative functor types: F(M).t might not be well typed anymore - - aliases: module A = M still makes sense but it doesn't mean the same thing - anymore, so it's forbidden until it's clear what we should do with it. - This function would be called with M.N.t and N.t to check for these uses. *) -let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid = - let iterator = - let env, super = iterator_with_env env in - { super with - Btype.it_signature_item = (fun self -> function - | Sig_module (id, { md_type = Mty_alias (_, aliased_path); _ }, _) - when List.exists - (fun path -> path_is_strict_prefix path ~prefix:aliased_path) - paths - -> - let e = With_changes_module_alias (lid.txt, id, aliased_path) in - raise(Error(loc, !env, e)) - | sig_item -> - super.Btype.it_signature_item self sig_item - ); - Btype.it_path = (fun referenced_path -> - iter_path_apply referenced_path ~f:(fun funct arg -> - if List.exists - (fun path -> path_is_strict_prefix path ~prefix:arg) - paths - then - let env = !env in - try retype_applicative_functor_type ~loc env funct arg - with Includemod.Error explanation -> - raise(Error(loc, env, - With_makes_applicative_functor_ill_typed - (lid.txt, referenced_path, explanation))) - ) - ); - } - in - iterator.Btype.it_signature iterator signature; - Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature - -let type_decl_is_alias sdecl = (* assuming no explicit constraint *) - match sdecl.ptype_manifest with - | Some {ptyp_desc = Ptyp_constr (lid, stl)} - when List.length stl = List.length sdecl.ptype_params -> - begin - match - List.iter2 (fun x (y, _) -> - match x, y with - {ptyp_desc=Ptyp_var sx}, {ptyp_desc=Ptyp_var sy} - when sx = sy -> () - | _, _ -> raise Exit) - stl sdecl.ptype_params; - with - | exception Exit -> None - | () -> Some lid - end - | _ -> None -;; - -let params_are_constrained = - let rec loop = function - | [] -> false - | hd :: tl -> - match (Btype.repr hd).desc with - | Tvar _ -> List.memq hd tl || loop tl - | _ -> true - in - loop -;; - -let merge_constraint initial_env loc sg constr = - let lid = - match constr with - | Pwith_type (lid, _) | Pwith_module (lid, _) - | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid - in - let destructive_substitution = - match constr with - | Pwith_type _ | Pwith_module _ -> false - | Pwith_typesubst _ | Pwith_modsubst _ -> true - in - let real_ids = ref [] in - let rec merge env sg namelist row_id = - match (sg, namelist, constr) with - ([], _, _) -> - raise(Error(loc, env, With_no_component lid.txt)) - | (Sig_type(id, decl, rs) :: rem, [s], - Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl))) - when Ident.name id = s && Typedecl.is_fixed_type sdecl -> - let decl_row = - { type_params = - List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; - type_arity = List.length sdecl.ptype_params; - type_kind = Type_abstract; - type_private = Private; - type_manifest = None; - type_variance = - List.map - (fun (_, v) -> - let (c, n) = - match v with - | Covariant -> true, false - | Contravariant -> false, true - | Invariant -> false, false - in - make (not n) (not c) false - ) - sdecl.ptype_params; - type_loc = sdecl.ptype_loc; - type_newtype_level = None; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - } - and id_row = Ident.create (s^"#row") in - let initial_env = - Env.add_type ~check:false id_row decl_row initial_env - in - let tdecl = Typedecl.transl_with_constraint - initial_env id (Some(Pident id_row)) decl sdecl in - let newdecl = tdecl.typ_type in - check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; - let decl_row = {decl_row with type_params = newdecl.type_params} in - let rs' = if rs = Trec_first then Trec_not else rs in - (Pident id, lid, Twith_type tdecl), - Sig_type(id_row, decl_row, rs') :: Sig_type(id, newdecl, rs) :: rem - | (Sig_type(id, decl, rs) :: rem , [s], Pwith_type (_, sdecl)) - when Ident.name id = s -> - let tdecl = - Typedecl.transl_with_constraint initial_env id None decl sdecl in - let newdecl = tdecl.typ_type in - check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; - (Pident id, lid, Twith_type tdecl), Sig_type(id, newdecl, rs) :: rem - | (Sig_type(id, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) - when Ident.name id = s ^ "#row" -> - merge env rem namelist (Some id) - | (Sig_type(id, decl, rs) :: rem, [s], Pwith_typesubst (_, sdecl)) - when Ident.name id = s -> - (* Check as for a normal with constraint, but discard definition *) - let tdecl = - Typedecl.transl_with_constraint initial_env id None decl sdecl in - let newdecl = tdecl.typ_type in - check_type_decl env sdecl.ptype_loc id row_id newdecl decl rs rem; - real_ids := [Pident id]; - (Pident id, lid, Twith_typesubst tdecl), - update_rec_next rs rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_module (_, lid')) - when Ident.name id = s -> - let path, md' = Typetexp.find_module initial_env loc lid'.txt in - let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in - let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in - ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); - (Pident id, lid, Twith_module (path, lid')), - Sig_module(id, newmd, rs) :: rem - | (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid')) - when Ident.name id = s -> - let path, md' = Typetexp.find_module initial_env loc lid'.txt in - let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in - ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type); - real_ids := [Pident id]; - (Pident id, lid, Twith_modsubst (path, lid')), - update_rec_next rs rem - | (Sig_module(id, md, rs) :: rem, s :: namelist, _) - when Ident.name id = s -> - let ((path, _path_loc, tcstr), newsg) = - merge env (extract_sig env loc md.md_type) namelist None in - let path = path_concat id path in - real_ids := path :: !real_ids; - let item = Sig_module(id, {md with md_type=Mty_signature newsg}, rs) in - (path, lid, tcstr), - item :: rem - | (item :: rem, _, _) -> - let (cstr, items) = merge (Env.add_item item env) rem namelist row_id - in - cstr, item :: items - in - try - let names = Longident.flatten lid.txt in - let (tcstr, sg) = merge initial_env sg names None in - if destructive_substitution then ( - match List.rev !real_ids with - | [] -> assert false - | last :: rest -> - (* The last item is the one that's removed. We don't need to check how - it's used since it's replaced by a more specific type/module. *) - assert (match last with Pident _ -> true | _ -> false); - match rest with - | [] -> () - | _ :: _ -> - check_usage_of_path_of_substituted_item - rest initial_env sg ~loc ~lid; - ); - let sg = - match tcstr with - | (_, _, Twith_typesubst tdecl) -> - let how_to_extend_subst = - let sdecl = - match constr with - | Pwith_typesubst (_, sdecl) -> sdecl - | _ -> assert false - in - match type_decl_is_alias sdecl with - | Some lid -> - let replacement = - try Env.lookup_type lid.txt initial_env - with Not_found -> assert false - in - fun s path -> Subst.add_type_path path replacement s - | None -> - let body = - match tdecl.typ_type.type_manifest with - | None -> assert false - | Some x -> x - in - let params = tdecl.typ_type.type_params in - if params_are_constrained params - then raise(Error(loc, initial_env, With_cannot_remove_constrained_type)); - fun s path -> Subst.add_type_function path ~params ~body s - in - let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in - Subst.signature sub sg - | (_, _, Twith_modsubst (real_path, _)) -> - let sub = - List.fold_left - (fun s path -> Subst.add_module_path path real_path s) - Subst.identity - !real_ids - in - Subst.signature sub sg - | _ -> - sg - in - (tcstr, sg) - with Includemod.Error explanation -> - raise(Error(loc, initial_env, With_mismatch(lid.txt, explanation))) - -(* Add recursion flags on declarations arising from a mutually recursive - block. *) - -let map_rec fn decls rem = - match decls with - | [] -> rem - | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem - -let map_rec_type ~rec_flag fn decls rem = - match decls with - | [] -> rem - | d1 :: dl -> - let first = - match rec_flag with - | Recursive -> Trec_first - | Nonrecursive -> Trec_not - in - fn first d1 :: map_end (fn Trec_next) dl rem - -let rec map_rec_type_with_row_types ~rec_flag fn decls rem = - match decls with - | [] -> rem - | d1 :: dl -> - if Btype.is_row_name (Ident.name d1.typ_id) then - fn Trec_not d1 :: map_rec_type_with_row_types ~rec_flag fn dl rem - else - map_rec_type ~rec_flag fn decls rem - -(* Add type extension flags to extension constructors *) -let map_ext fn exts rem = - match exts with - | [] -> rem - | d1 :: dl -> fn Text_first d1 :: map_end (fn Text_next) dl rem - -(* Auxiliary for translating recursively-defined module types. - Return a module type that approximates the shape of the given module - type AST. Retain only module, type, and module type - components of signatures. For types, retain only their arity, - making them abstract otherwise. *) - -let rec approx_modtype env smty = - match smty.pmty_desc with - Pmty_ident lid -> - let (path, _info) = Typetexp.find_modtype env smty.pmty_loc lid.txt in - Mty_ident path - | Pmty_alias lid -> - let path = Typetexp.lookup_module env smty.pmty_loc lid.txt in - Mty_alias(Mta_absent, path) - | Pmty_signature ssg -> - Mty_signature(approx_sig env ssg) - | Pmty_functor(param, sarg, sres) -> - let arg = may_map (approx_modtype env) sarg in - let (id, newenv) = - Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in - let res = approx_modtype newenv sres in - Mty_functor(id, arg, res) - | Pmty_with(sbody, _constraints) -> - approx_modtype env sbody - | Pmty_typeof smod -> - let (_, mty) = !type_module_type_of_fwd env smod in - mty - | Pmty_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - -and approx_module_declaration env pmd = - { - Types.md_type = approx_modtype env pmd.pmd_type; - md_attributes = pmd.pmd_attributes; - md_loc = pmd.pmd_loc; - } - -and approx_sig env ssg = - match ssg with - [] -> [] - | item :: srem -> - match item.psig_desc with - | Psig_type (rec_flag, sdecls) -> - let decls = Typedecl.approx_type_decl sdecls in - let rem = approx_sig env srem in - map_rec_type ~rec_flag - (fun rs (id, info) -> Sig_type(id, info, rs)) decls rem - | Psig_module pmd -> - let id = Ident.create pmd.pmd_name.txt in - let md = approx_module_declaration env pmd in - let newenv = Env.enter_module_declaration id md env in - Sig_module(id, md, Trec_not) :: approx_sig newenv srem - | Psig_recmodule sdecls -> - let decls = - List.map - (fun pmd -> - (Ident.create pmd.pmd_name.txt, - approx_module_declaration env pmd) - ) - sdecls - in - let newenv = - List.fold_left - (fun env (id, md) -> Env.add_module_declaration ~check:false - id md env) - env decls in - map_rec (fun rs (id, md) -> Sig_module(id, md, rs)) decls - (approx_sig newenv srem) - | Psig_modtype d -> - let info = approx_modtype_info env d in - let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in - Sig_modtype(id, info) :: approx_sig newenv srem - | Psig_open sod -> - let (_path, mty, _od) = type_open env sod in - approx_sig mty srem - | Psig_include sincl -> - let smty = sincl.pincl_mod in - let mty = approx_modtype env smty in - let sg = Subst.signature Subst.identity - (extract_sig env smty.pmty_loc mty) in - let newenv = Env.add_signature sg env in - sg @ approx_sig newenv srem - | Psig_class_type sdecls -> - let decls = Typeclass.approx_class_declarations env sdecls in - let rem = approx_sig env srem in - List.flatten - (map_rec - (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) - decls [rem]) - | Psig_class () -> assert false - | _ -> - approx_sig env srem - -and approx_modtype_info env sinfo = - { - mtd_type = may_map (approx_modtype env) sinfo.pmtd_type; - mtd_attributes = sinfo.pmtd_attributes; - mtd_loc = sinfo.pmtd_loc; - } - -let approx_modtype env smty = - Warnings.without_warnings - (fun () -> approx_modtype env smty) - -(* Additional validity checks on type definitions arising from - recursive modules *) - -let check_recmod_typedecls env sdecls decls = - let recmod_ids = List.map fst3 decls in - List.iter2 - (fun pmd (id, _, mty) -> - let mty = mty.mty_type in - List.iter - (fun path -> - Typedecl.check_recmod_typedecl env pmd.pmd_type.pmty_loc recmod_ids - path (Env.find_type path env)) - (Mtype.type_paths env (Pident id) mty)) - sdecls decls - -(* Auxiliaries for checking uniqueness of names in signatures and structures *) - -module StringSet = - Set.Make(struct type t = string let compare (x:t) y = String.compare x y end) - -let check cl loc tbl name = - match Hashtbl.find_opt tbl name with - | Some repeated_loc -> - raise(Error(loc, Env.empty, Repeated_name(cl, name, repeated_loc))) - | None -> Hashtbl.add tbl name loc - -type names = - { - types: (string, Warnings.loc) Hashtbl.t; - modules: (string, Warnings.loc) Hashtbl.t; - modtypes: (string, Warnings.loc) Hashtbl.t; - typexts: (string, Warnings.loc) Hashtbl.t; - } - -let new_names () = - { - types = (Hashtbl.create 10); - modules = (Hashtbl.create 10); - modtypes = (Hashtbl.create 10); - typexts = (Hashtbl.create 10); - } - - -let check_name check names name = check names name.loc name.txt -let check_type names loc s = check "type" loc names.types s -let check_module names loc s = check "module" loc names.modules s -let check_modtype names loc s = check "module type" loc names.modtypes s -let check_typext names loc s = check "extension constructor" loc names.typexts s - - -let check_sig_item names loc = function - | Sig_type(id, _, _) -> check_type names loc (Ident.name id) - | Sig_module(id, _, _) -> check_module names loc (Ident.name id) - | Sig_modtype(id, _) -> check_modtype names loc (Ident.name id) - | Sig_typext(id, _, _) -> check_typext names loc (Ident.name id) - | _ -> () - -(* Simplify multiple specifications of a value or an extension in a signature. - (Other signature components, e.g. types, modules, etc, are checked for - name uniqueness.) If multiple specifications with the same name, - keep only the last (rightmost) one. *) - -let simplify_signature sg = - let rec aux = function - | [] -> [], StringSet.empty - | (Sig_value(id, _descr) as component) :: sg -> - let (sg, val_names) as k = aux sg in - let name = Ident.name id in - if StringSet.mem name val_names then k - else (component :: sg, StringSet.add name val_names) - | component :: sg -> - let (sg, val_names) = aux sg in - (component :: sg, val_names) - in - let (sg, _) = aux sg in - sg - -(* Check and translate a module type expression *) - -let transl_modtype_longident loc env lid = - let (path, _info) = Typetexp.find_modtype env loc lid in - path - -let transl_module_alias loc env lid = - Typetexp.lookup_module env loc lid - -let mkmty desc typ env loc attrs = - let mty = { - mty_desc = desc; - mty_type = typ; - mty_loc = loc; - mty_env = env; - mty_attributes = attrs; - } in - Cmt_format.add_saved_type (Cmt_format.Partial_module_type mty); - mty - -let mksig desc env loc = - let sg = { sig_desc = desc; sig_loc = loc; sig_env = env } in - Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); - sg - -(* let signature sg = List.map (fun item -> item.sig_type) sg *) - -let rec transl_modtype env smty = - Builtin_attributes.warning_scope smty.pmty_attributes - (fun () -> transl_modtype_aux env smty) - -and transl_modtype_aux env smty = - let loc = smty.pmty_loc in - match smty.pmty_desc with - Pmty_ident lid -> - let path = transl_modtype_longident loc env lid.txt in - mkmty (Tmty_ident (path, lid)) (Mty_ident path) env loc - smty.pmty_attributes - | Pmty_alias lid -> - let path = transl_module_alias loc env lid.txt in - mkmty (Tmty_alias (path, lid)) (Mty_alias(Mta_absent, path)) env loc - smty.pmty_attributes - | Pmty_signature ssg -> - let sg = transl_signature env ssg in - mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc - smty.pmty_attributes - | Pmty_functor(param, sarg, sres) -> - let arg = Misc.may_map (transl_modtype env) sarg in - let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in - let (id, newenv) = - Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in - Ctype.init_def(Ident.current_time()); (* PR#6513 *) - let res = transl_modtype newenv sres in - mkmty (Tmty_functor (id, param, arg, res)) - (Mty_functor(id, ty_arg, res.mty_type)) env loc - smty.pmty_attributes - | Pmty_with(sbody, constraints) -> - let body = transl_modtype env sbody in - let init_sg = extract_sig env sbody.pmty_loc body.mty_type in - let (rev_tcstrs, final_sg) = - List.fold_left - (fun (rev_tcstrs,sg) sdecl -> - let (tcstr, sg) = merge_constraint env smty.pmty_loc sg sdecl - in - (tcstr :: rev_tcstrs, sg) - ) - ([],init_sg) constraints in - mkmty (Tmty_with ( body, List.rev rev_tcstrs)) - (Mtype.freshen (Mty_signature final_sg)) env loc - smty.pmty_attributes - | Pmty_typeof smod -> - let env = Env.in_signature false env in - let tmty, mty = !type_module_type_of_fwd env smod in - mkmty (Tmty_typeof tmty) mty env loc smty.pmty_attributes - | Pmty_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - -and transl_signature env sg = - let names = new_names () in - let rec transl_sig env sg = - Ctype.init_def(Ident.current_time()); - match sg with - [] -> [], [], env - | item :: srem -> - let loc = item.psig_loc in - match item.psig_desc with - | Psig_value sdesc -> - let (tdesc, newenv) = - Typedecl.transl_value_decl env item.psig_loc sdesc - in - let (trem,rem, final_env) = transl_sig newenv srem in - mksig (Tsig_value tdesc) env loc :: trem, - Sig_value(tdesc.val_id, tdesc.val_val) :: rem, - final_env - | Psig_type (rec_flag, sdecls) -> - List.iter - (fun decl -> check_name check_type names decl.ptype_name) - sdecls; - let (decls, newenv) = - Typedecl.transl_type_decl env rec_flag sdecls - in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_type (rec_flag, decls)) env loc :: trem, - map_rec_type_with_row_types ~rec_flag - (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem, - final_env - | Psig_typext styext -> - List.iter - (fun pext -> check_name check_typext names pext.pext_name) - styext.ptyext_constructors; - let (tyext, newenv) = - Typedecl.transl_type_extension false env item.psig_loc styext - in - let (trem, rem, final_env) = transl_sig newenv srem in - let constructors = tyext.tyext_constructors in - mksig (Tsig_typext tyext) env loc :: trem, - map_ext (fun es ext -> - Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem, - final_env - | Psig_exception sext -> - check_name check_typext names sext.pext_name; - let (ext, newenv) = Typedecl.transl_exception env sext in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_exception ext) env loc :: trem, - Sig_typext(ext.ext_id, ext.ext_type, Text_exception) :: rem, - final_env - | Psig_module pmd -> - check_name check_module names pmd.pmd_name; - let id = Ident.create pmd.pmd_name.txt in - let tmty = - Builtin_attributes.warning_scope pmd.pmd_attributes - (fun () -> transl_modtype env pmd.pmd_type) - in - let md = { - md_type=tmty.mty_type; - md_attributes=pmd.pmd_attributes; - md_loc=pmd.pmd_loc; - } - in - let newenv = Env.enter_module_declaration id md env in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name; md_type=tmty; - md_loc=pmd.pmd_loc; - md_attributes=pmd.pmd_attributes}) - env loc :: trem, - Sig_module(id, md, Trec_not) :: rem, - final_env - | Psig_recmodule sdecls -> - List.iter - (fun pmd -> check_name check_module names pmd.pmd_name) - sdecls; - let (decls, newenv) = - transl_recmodule_modtypes env sdecls in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_recmodule decls) env loc :: trem, - map_rec (fun rs md -> - let d = {Types.md_type = md.md_type.mty_type; - md_attributes = md.md_attributes; - md_loc = md.md_loc; - } in - Sig_module(md.md_id, d, rs)) - decls rem, - final_env - | Psig_modtype pmtd -> - let newenv, mtd, sg = - transl_modtype_decl names env pmtd - in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_modtype mtd) env loc :: trem, - sg :: rem, - final_env - | Psig_open sod -> - let (_path, newenv, od) = type_open env sod in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_open od) env loc :: trem, - rem, final_env - | Psig_include sincl -> - let smty = sincl.pincl_mod in - let tmty = - Builtin_attributes.warning_scope sincl.pincl_attributes - (fun () -> transl_modtype env smty) - in - let mty = tmty.mty_type in - let sg = Subst.signature Subst.identity - (extract_sig env smty.pmty_loc mty) in - List.iter (check_sig_item names item.psig_loc) sg; - let newenv = Env.add_signature sg env in - let incl = - { incl_mod = tmty; - incl_type = sg; - incl_attributes = sincl.pincl_attributes; - incl_loc = sincl.pincl_loc; - } - in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_include incl) env loc :: trem, - sg @ rem, - final_env - | Psig_class _ -> assert false - | Psig_class_type cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, newenv) = Typeclass.class_type_declarations env cl in - let (trem,rem, final_env) = transl_sig newenv srem in - mksig (Tsig_class_type - (List.map (fun decl -> decl.Typeclass.clsty_info) classes)) - env loc :: trem, - List.flatten - (map_rec - (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) - classes [rem]), - final_env - | Psig_attribute x -> - Builtin_attributes.warning_attribute x; - let (trem,rem, final_env) = transl_sig env srem in - mksig (Tsig_attribute x) env loc :: trem, rem, final_env - | Psig_extension (ext, _attrs) -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - in - let previous_saved_types = Cmt_format.get_saved_types () in - Builtin_attributes.warning_scope [] - (fun () -> - let (trem, rem, final_env) = transl_sig (Env.in_signature true env) sg in - let rem = simplify_signature rem in - let sg = { sig_items = trem; sig_type = rem; sig_final_env = final_env } in - Cmt_format.set_saved_types - ((Cmt_format.Partial_signature sg) :: previous_saved_types); - sg - ) - -and transl_modtype_decl names env pmtd = - Builtin_attributes.warning_scope pmtd.pmtd_attributes - (fun () -> transl_modtype_decl_aux names env pmtd) - -and transl_modtype_decl_aux names env - {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = - check_name check_modtype names pmtd_name; - let tmty = Misc.may_map (transl_modtype env) pmtd_type in - let decl = - { - Types.mtd_type=may_map (fun t -> t.mty_type) tmty; - mtd_attributes=pmtd_attributes; - mtd_loc=pmtd_loc; - } - in - let (id, newenv) = Env.enter_modtype pmtd_name.txt decl env in - let mtd = - { - mtd_id=id; - mtd_name=pmtd_name; - mtd_type=tmty; - mtd_attributes=pmtd_attributes; - mtd_loc=pmtd_loc; - } - in - newenv, mtd, Sig_modtype(id, decl) - -and transl_recmodule_modtypes env sdecls = - let make_env curr = - List.fold_left - (fun env (id, _, mty) -> Env.add_module ~arg:true id mty env) - env curr in - let make_env2 curr = - List.fold_left - (fun env (id, _, mty) -> Env.add_module ~arg:true id mty.mty_type env) - env curr in - let transition env_c curr = - List.map2 - (fun pmd (id, id_loc, _mty) -> - let tmty = - Builtin_attributes.warning_scope pmd.pmd_attributes - (fun () -> transl_modtype env_c pmd.pmd_type) - in - (id, id_loc, tmty)) - sdecls curr in - let ids = List.map (fun x -> Ident.create x.pmd_name.txt) sdecls in - let approx_env = - (* - cf #5965 - We use a dummy module type in order to detect a reference to one - of the module being defined during the call to approx_modtype. - It will be detected in Env.lookup_module. - *) - List.fold_left - (fun env id -> - let dummy = Mty_ident (Path.Pident (Ident.create "#recmod#")) in - Env.add_module ~arg:true id dummy env - ) - env ids - in - Ctype.init_def(Ident.current_time()); (* PR#7082 *) - let init = - List.map2 - (fun id pmd -> - (id, pmd.pmd_name, approx_modtype approx_env pmd.pmd_type)) - ids sdecls - in - let env0 = make_env init in - let dcl1 = - Warnings.without_warnings - (fun () -> transition env0 init) - in - let env1 = make_env2 dcl1 in - check_recmod_typedecls env1 sdecls dcl1; - let dcl2 = transition env1 dcl1 in -(* - List.iter - (fun (id, mty) -> - Format.printf "%a: %a@." Printtyp.ident id Printtyp.modtype mty) - dcl2; -*) - let env2 = make_env2 dcl2 in - check_recmod_typedecls env2 sdecls dcl2; - let dcl2 = - List.map2 - (fun pmd (id, id_loc, mty) -> - {md_id=id; md_name=id_loc; md_type=mty; - md_loc=pmd.pmd_loc; - md_attributes=pmd.pmd_attributes}) - sdecls dcl2 - in - (dcl2, env2) - -(* Try to convert a module expression to a module path. *) - -exception Not_a_path - -let rec path_of_module mexp = - match mexp.mod_desc with - Tmod_ident (p,_) -> p - | Tmod_apply(funct, arg, _coercion) when !Clflags.applicative_functors -> - Papply(path_of_module funct, path_of_module arg) - | Tmod_constraint (mexp, _, _, _) -> - path_of_module mexp - | _ -> raise Not_a_path - -let path_of_module mexp = - try Some (path_of_module mexp) with Not_a_path -> None - -(* Check that all core type schemes in a structure are closed *) - -let rec closed_modtype env = function - Mty_ident _ -> true - | Mty_alias _ -> true - | Mty_signature sg -> - let env = Env.add_signature sg env in - List.for_all (closed_signature_item env) sg - | Mty_functor(id, param, body) -> - let env = Env.add_module ~arg:true id (Btype.default_mty param) env in - closed_modtype env body - -and closed_signature_item env = function - Sig_value(_id, desc) -> Ctype.closed_schema env desc.val_type - | Sig_module(_id, md, _) -> closed_modtype env md.md_type - | _ -> true - -let check_nongen_scheme env sig_item = - match sig_item with - Sig_value(_id, vd) -> - if not (Ctype.closed_schema env vd.val_type) then - raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) - | Sig_module (_id, md, _) -> - if not (closed_modtype env md.md_type) then - raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) - | _ -> () - -let check_nongen_schemes env sg = - List.iter (check_nongen_scheme env) sg - -(* Helpers for typing recursive modules *) - -let anchor_submodule name anchor = - match anchor with None -> None | Some p -> Some(Pdot(p, name, nopos)) -let anchor_recmodule id = - Some (Pident id) - -let enrich_type_decls anchor decls oldenv newenv = - match anchor with - None -> newenv - | Some p -> - List.fold_left - (fun e info -> - let id = info.typ_id in - let info' = - Mtype.enrich_typedecl oldenv (Pdot(p, Ident.name id, nopos)) - info.typ_type - in - Env.add_type ~check:true id info' e) - oldenv decls - -let enrich_module_type anchor name mty env = - match anchor with - None -> mty - | Some p -> Mtype.enrich_modtype env (Pdot(p, name, nopos)) mty - -let check_recmodule_inclusion env bindings = - (* PR#4450, PR#4470: consider - module rec X : DECL = MOD where MOD has inferred type ACTUAL - The "natural" typing condition - E, X: ACTUAL |- ACTUAL <: DECL - leads to circularities through manifest types. - Instead, we "unroll away" the potential circularities a finite number - of times. The (weaker) condition we implement is: - E, X: DECL, - X1: ACTUAL, - X2: ACTUAL{X <- X1}/X1 - ... - Xn: ACTUAL{X <- X(n-1)}/X(n-1) - |- ACTUAL{X <- Xn}/Xn <: DECL{X <- Xn} - so that manifest types rooted at X(n+1) are expanded in terms of X(n), - avoiding circularities. The strengthenings ensure that - Xn.t = X(n-1).t = ... = X2.t = X1.t. - N can be chosen arbitrarily; larger values of N result in more - recursive definitions being accepted. A good choice appears to be - the number of mutually recursive declarations. *) - - let subst_and_strengthen env s id mty = - Mtype.strengthen ~aliasable:false env (Subst.modtype s mty) - (Subst.module_path s (Pident id)) in - - let rec check_incl first_time n env s = - if n > 0 then begin - (* Generate fresh names Y_i for the rec. bound module idents X_i *) - let bindings1 = - List.map - (fun (id, _, _mty_decl, _modl, mty_actual, _attrs, _loc) -> - (id, Ident.rename id, mty_actual)) - bindings in - (* Enter the Y_i in the environment with their actual types substituted - by the input substitution s *) - let env' = - List.fold_left - (fun env (id, id', mty_actual) -> - let mty_actual' = - if first_time - then mty_actual - else subst_and_strengthen env s id mty_actual in - Env.add_module ~arg:false id' mty_actual' env) - env bindings1 in - (* Build the output substitution Y_i <- X_i *) - let s' = - List.fold_left - (fun s (id, id', _mty_actual) -> - Subst.add_module id (Pident id') s) - Subst.identity bindings1 in - (* Recurse with env' and s' *) - check_incl false (n-1) env' s' - end else begin - (* Base case: check inclusion of s(mty_actual) in s(mty_decl) - and insert coercion if needed *) - let check_inclusion (id, id_loc, mty_decl, modl, mty_actual, attrs, loc) = - let mty_decl' = Subst.modtype s mty_decl.mty_type - and mty_actual' = subst_and_strengthen env s id mty_actual in - let coercion = - try - Includemod.modtypes ~loc:modl.mod_loc env mty_actual' mty_decl' - with Includemod.Error msg -> - raise(Error(modl.mod_loc, env, Not_included msg)) in - let modl' = - { mod_desc = Tmod_constraint(modl, mty_decl.mty_type, - Tmodtype_explicit mty_decl, coercion); - mod_type = mty_decl.mty_type; - mod_env = env; - mod_loc = modl.mod_loc; - mod_attributes = []; - } in - { - mb_id = id; - mb_name = id_loc; - mb_expr = modl'; - mb_attributes = attrs; - mb_loc = loc; - } - in - List.map check_inclusion bindings - end - in check_incl true (List.length bindings) env Subst.identity - -(* Helper for unpack *) - -let rec package_constraints env loc mty constrs = - if constrs = [] then mty - else let sg = extract_sig env loc mty in - let sg' = - List.map - (function - | Sig_type (id, ({type_params=[]} as td), rs) - when List.mem_assoc [Ident.name id] constrs -> - let ty = List.assoc [Ident.name id] constrs in - Sig_type (id, {td with type_manifest = Some ty}, rs) - | Sig_module (id, md, rs) -> - let rec aux = function - | (m :: ((_ :: _) as l), t) :: rest when m = Ident.name id -> - (l, t) :: aux rest - | _ :: rest -> aux rest - | [] -> [] - in - let md = - {md with - md_type = package_constraints env loc md.md_type (aux constrs) - } - in - Sig_module (id, md, rs) - | item -> item - ) - sg - in - Mty_signature sg' - -let modtype_of_package env loc p nl tl = - try match (Env.find_modtype p env).mtd_type with - | Some mty when nl <> [] -> - package_constraints env loc mty - (List.combine (List.map Longident.flatten nl) tl) - | _ -> - if nl = [] then Mty_ident p - else raise(Error(loc, env, Signature_expected)) - with Not_found -> - let error = Typetexp.Unbound_modtype (Ctype.lid_of_path p) in - raise(Typetexp.Error(loc, env, error)) - -let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = - let mkmty p nl tl = - let ntl = - Ext_list.filter (List.combine nl tl) (fun (_n,t) -> Ctype.free_variables t = []) - in - let (nl, tl) = List.split ntl in - modtype_of_package env Location.none p nl tl - in - let mty1 = mkmty p1 nl1 tl1 and mty2 = mkmty p2 nl2 tl2 in - try Includemod.modtypes ~loc:Location.none env mty1 mty2 = Tcoerce_none - with Includemod.Error _msg -> false - (* raise(Error(Location.none, env, Not_included msg)) *) - -let () = Ctype.package_subtype := package_subtype - -let wrap_constraint env arg mty explicit = - let coercion = - try - Includemod.modtypes ~loc:arg.mod_loc env arg.mod_type mty - with Includemod.Error msg -> - raise(Error(arg.mod_loc, env, Not_included msg)) in - { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); - mod_type = mty; - mod_env = env; - mod_attributes = []; - mod_loc = arg.mod_loc } - -(* Type a module value expression *) - -let rec type_module ?(alias=false) sttn funct_body anchor env smod = - Builtin_attributes.warning_scope smod.pmod_attributes - (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) - -and type_module_aux ~alias sttn funct_body anchor env smod = - match smod.pmod_desc with - Pmod_ident lid -> - let path = - Typetexp.lookup_module ~load:(not alias) env smod.pmod_loc lid.txt in - let md = { mod_desc = Tmod_ident (path, lid); - mod_type = Mty_alias(Mta_absent, path); - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } in - let aliasable = not (Env.is_functor_arg path env) in - let md = - if alias && aliasable then - md - else match (Env.find_module path env).md_type with - Mty_alias(_, p1) when not alias -> - let p1 = Env.normalize_path (Some smod.pmod_loc) env p1 in - let mty = Includemod.expand_module_alias env [] p1 in - { md with - mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit, - Tcoerce_alias (p1, Tcoerce_none)); - mod_type = - if sttn then Mtype.strengthen ~aliasable:true env mty p1 - else mty } - | mty -> - let mty = - if sttn then Mtype.strengthen ~aliasable env mty path - else mty - in - { md with mod_type = mty } - in rm md - | Pmod_structure sstr -> - let (str, sg, _finalenv) = - type_structure funct_body anchor env sstr smod.pmod_loc in - let md = - rm { mod_desc = Tmod_structure str; - mod_type = Mty_signature sg; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - in - let sg' = simplify_signature sg in - if List.length sg' = List.length sg then md else - wrap_constraint (Env.implicit_coercion env) md (Mty_signature sg') - Tmodtype_implicit - | Pmod_functor(name, smty, sbody) -> - let mty = may_map (transl_modtype env) smty in - let ty_arg = may_map (fun m -> m.mty_type) mty in - let (id, newenv), funct_body = - match ty_arg with None -> (Ident.create "*", env), false - | Some mty -> Env.enter_module ~arg:true name.txt mty env, true in - Ctype.init_def(Ident.current_time()); (* PR#6981 *) - let body = type_module sttn funct_body None newenv sbody in - rm { mod_desc = Tmod_functor(id, name, mty, body); - mod_type = Mty_functor(id, ty_arg, body.mod_type); - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Pmod_apply(sfunct, sarg) -> - let arg = type_module true funct_body None env sarg in - let path = path_of_module arg in - let funct = - type_module (sttn && path <> None) funct_body None env sfunct in - begin match Env.scrape_alias env funct.mod_type with - Mty_functor(param, mty_param, mty_res) as mty_functor -> - let generative, mty_param = - (mty_param = None, Btype.default_mty mty_param) in - if generative then begin - if sarg.pmod_desc <> Pmod_structure [] then - raise (Error (sfunct.pmod_loc, env, Apply_generative)); - if funct_body && Mtype.contains_type env funct.mod_type then - raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); - end; - let coercion = - try - Includemod.modtypes ~loc:sarg.pmod_loc env arg.mod_type mty_param - with Includemod.Error msg -> - raise(Error(sarg.pmod_loc, env, Not_included msg)) in - let mty_appl = - match path with - Some path -> - Subst.modtype (Subst.add_module param path Subst.identity) - mty_res - | None -> - if generative then mty_res else - try - Mtype.nondep_supertype - (Env.add_module ~arg:true param arg.mod_type env) - param mty_res - with Not_found -> - raise(Error(smod.pmod_loc, env, - Cannot_eliminate_dependency mty_functor)) - in - rm { mod_desc = Tmod_apply(funct, arg, coercion); - mod_type = mty_appl; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Mty_alias(_, path) -> - raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path)) - | _ -> - raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type)) - end - | Pmod_constraint(sarg, smty) -> - let arg = type_module ~alias true funct_body anchor env sarg in - let mty = transl_modtype env smty in - rm {(wrap_constraint env arg mty.mty_type (Tmodtype_explicit mty)) with - mod_loc = smod.pmod_loc; - mod_attributes = smod.pmod_attributes; - } - - | Pmod_unpack sexp -> - let exp = Typecore.type_exp env sexp in - let mty = - match Ctype.expand_head env exp.exp_type with - {desc = Tpackage (p, nl, tl)} -> - if List.exists (fun t -> Ctype.free_variables t <> []) tl then - raise (Error (smod.pmod_loc, env, - Incomplete_packed_module exp.exp_type)); - modtype_of_package env smod.pmod_loc p nl tl - | {desc = Tvar _} -> - raise (Typecore.Error - (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) - | _ -> - raise (Error(smod.pmod_loc, env, Not_a_packed_module exp.exp_type)) - in - if funct_body && Mtype.contains_type env mty then - raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); - rm { mod_desc = Tmod_unpack(exp, mty); - mod_type = mty; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Pmod_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - -and type_structure ?(toplevel = false) funct_body anchor env sstr scope = - let names = new_names () in - - let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = - match desc with - | Pstr_eval (sexpr, attrs) -> - let expr = - Builtin_attributes.warning_scope attrs - (fun () -> Typecore.type_expression env sexpr) - in - Tstr_eval (expr, attrs), [], env - | Pstr_value(rec_flag, sdefs) -> - let scope = - match rec_flag with - | Recursive -> - Some (Annot.Idef {scope with - Location.loc_start = loc.Location.loc_start}) - | Nonrecursive -> - let start = - match srem with - | [] -> loc.Location.loc_end - | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start - in - Some (Annot.Idef {scope with Location.loc_start = start}) - in - let (defs, newenv) = - Typecore.type_binding env rec_flag sdefs scope in - let () = if rec_flag = Recursive then - Rec_check.check_recursive_bindings defs - in - (* Note: Env.find_value does not trigger the value_used event. Values - will be marked as being used during the signature inclusion test. *) - Tstr_value(rec_flag, defs), - List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv)) - (let_bound_idents defs), - newenv - | Pstr_primitive sdesc -> - let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in - Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv - | Pstr_type (rec_flag, sdecls) -> - List.iter - (fun decl -> check_name check_type names decl.ptype_name) - sdecls; - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in - Tstr_type (rec_flag, decls), - map_rec_type_with_row_types ~rec_flag - (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) - decls [], - enrich_type_decls anchor decls env newenv - | Pstr_typext styext -> - List.iter - (fun pext -> check_name check_typext names pext.pext_name) - styext.ptyext_constructors; - let (tyext, newenv) = - Typedecl.transl_type_extension true env loc styext - in - (Tstr_typext tyext, - map_ext - (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es)) - tyext.tyext_constructors [], - newenv) - | Pstr_exception sext -> - check_name check_typext names sext.pext_name; - let (ext, newenv) = Typedecl.transl_exception env sext in - Tstr_exception ext, - [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)], - newenv - | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; - pmb_loc; - } -> - check_name check_module names name; - let id = Ident.create name.txt in (* create early for PR#6752 *) - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module ~alias:true true funct_body - (anchor_submodule name.txt anchor) env smodl - ) - in - let md = - { md_type = enrich_module_type anchor name.txt modl.mod_type env; - md_attributes = attrs; - md_loc = pmb_loc; - } - in - (*prerr_endline (Ident.unique_toplevel_name id);*) - Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; - let newenv = Env.enter_module_declaration id md env in - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; - mb_attributes=attrs; mb_loc=pmb_loc; - }, - [Sig_module(id, - {md_type = modl.mod_type; - md_attributes = attrs; - md_loc = pmb_loc; - }, Trec_not)], - newenv - | Pstr_recmodule sbind -> - let sbind = - List.map - (function - | {pmb_name = name; - pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; - pmb_attributes = attrs; - pmb_loc = loc; - } -> - name, typ, expr, attrs, loc - | mb -> - raise (Error (mb.pmb_expr.pmod_loc, env, - Recursive_module_require_explicit_type)) - ) - sbind - in - List.iter - (fun (name, _, _, _, _) -> check_name check_module names name) - sbind; - let (decls, newenv) = - transl_recmodule_modtypes env - (List.map (fun (name, smty, _smodl, attrs, loc) -> - {pmd_name=name; pmd_type=smty; - pmd_attributes=attrs; pmd_loc=loc}) sbind - ) in - let bindings1 = - List.map2 - (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) -> - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module true funct_body (anchor_recmodule id) - newenv smodl - ) - in - let mty' = - enrich_module_type anchor (Ident.name id) modl.mod_type newenv - in - (id, name, mty, modl, mty', attrs, loc)) - decls sbind in - let newenv = (* allow aliasing recursive modules from outside *) - List.fold_left - (fun env md -> - let mdecl = - { - md_type = md.md_type.mty_type; - md_attributes = md.md_attributes; - md_loc = md.md_loc; - } - in - Env.add_module_declaration ~check:true md.md_id mdecl env - ) - env decls - in - let bindings2 = - check_recmodule_inclusion newenv bindings1 in - Tstr_recmodule bindings2, - map_rec (fun rs mb -> - Sig_module(mb.mb_id, { - md_type=mb.mb_expr.mod_type; - md_attributes=mb.mb_attributes; - md_loc=mb.mb_loc; - }, rs)) - bindings2 [], - newenv - | Pstr_modtype pmtd -> - (* check that it is non-abstract *) - let newenv, mtd, sg = - transl_modtype_decl names env pmtd - in - Tstr_modtype mtd, [sg], newenv - | Pstr_open sod -> - let (_path, newenv, od) = type_open ~toplevel env sod in - Tstr_open od, [], newenv - | Pstr_class () -> - assert false - | Pstr_class_type cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, new_env) = Typeclass.class_type_declarations env cl in - Tstr_class_type - (List.map (fun cl -> - (cl.Typeclass.clsty_ty_id, - cl.Typeclass.clsty_id_loc, - cl.Typeclass.clsty_info)) classes), -(* TODO: check with Jacques why this is here - Tstr_type - (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) - List.flatten - (map_rec - (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) - classes []), - new_env - | Pstr_include sincl -> - let smodl = sincl.pincl_mod in - let modl = - Builtin_attributes.warning_scope sincl.pincl_attributes - (fun () -> type_module true funct_body None env smodl) - in - (* Rename all identifiers bound by this signature to avoid clashes *) - let sg = Subst.signature Subst.identity - (extract_sig_open env smodl.pmod_loc modl.mod_type) in - List.iter (check_sig_item names loc) sg; - let new_env = Env.add_signature sg env in - let incl = - { incl_mod = modl; - incl_type = sg; - incl_attributes = sincl.pincl_attributes; - incl_loc = sincl.pincl_loc; - } - in - Tstr_include incl, sg, new_env - | Pstr_extension (ext, _attrs) -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - | Pstr_attribute x -> - Builtin_attributes.warning_attribute x; - Tstr_attribute x, [], env - in - let rec type_struct env sstr = - Ctype.init_def(Ident.current_time()); - match sstr with - | [] -> ([], [], env) - | pstr :: srem -> - let previous_saved_types = Cmt_format.get_saved_types () in - let desc, sg, new_env = type_str_item env srem pstr in - let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in - Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str - :: previous_saved_types); - let (str_rem, sig_rem, final_env) = type_struct new_env srem in - let new_sg = - if rescript_hide desc then sig_rem - else - sg @ sig_rem in - (str :: str_rem, new_sg, final_env) - in - if !Clflags.annotations then - (* moved to genannot *) - List.iter (function {pstr_loc = l} -> Stypes.record_phrase l) sstr; - let previous_saved_types = Cmt_format.get_saved_types () in - let run () = - let (items, sg, final_env) = type_struct env sstr in - let str = { str_items = items; str_type = sg; str_final_env = final_env } in - Cmt_format.set_saved_types - (Cmt_format.Partial_structure str :: previous_saved_types); - str, sg, final_env - in - if toplevel then run () - else Builtin_attributes.warning_scope [] run - -let type_toplevel_phrase env s = - type_structure ~toplevel:true false None env s Location.none - - -let type_module_alias = type_module ~alias:true true false None -let type_module = type_module true false None -let type_structure = type_structure false None - -(* Normalize types in a signature *) - -let rec normalize_modtype env = function - Mty_ident _ - | Mty_alias _ -> () - | Mty_signature sg -> normalize_signature env sg - | Mty_functor(_id, _param, body) -> normalize_modtype env body - -and normalize_signature env = List.iter (normalize_signature_item env) - -and normalize_signature_item env = function - Sig_value(_id, desc) -> Ctype.normalize_type env desc.val_type - | Sig_module(_id, md, _) -> normalize_modtype env md.md_type - | _ -> () - -(* Extract the module type of a module expression *) - -let type_module_type_of env smod = - let tmty = - match smod.pmod_desc with - | Pmod_ident lid -> (* turn off strengthening in this case *) - let path, md = Typetexp.find_module env smod.pmod_loc lid.txt in - rm { mod_desc = Tmod_ident (path, lid); - mod_type = md.md_type; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | _ -> type_module env smod in - let mty = tmty.mod_type in - (* PR#6307: expand aliases at root and submodules *) - let mty = Mtype.remove_aliases env mty in - (* PR#5036: must not contain non-generalized type variables *) - if not (closed_modtype env mty) then - raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); - tmty, mty - -(* For Typecore *) - -let type_package env m p nl = - (* Same as Pexp_letmodule *) - (* remember original level *) - let lv = Ctype.get_current_level () in - Ctype.begin_def (); - Ident.set_current_time lv; - let context = Typetexp.narrow () in - let modl = type_module env m in - Ctype.init_def(Ident.current_time()); - Typetexp.widen context; - let (mp, env) = - match modl.mod_desc with - Tmod_ident (mp,_) -> (mp, env) - | Tmod_constraint ({mod_desc=Tmod_ident (mp,_)}, _, Tmodtype_implicit, _) - -> (mp, env) (* PR#6982 *) - | _ -> - let (id, new_env) = Env.enter_module ~arg:true "%M" modl.mod_type env in - (Pident id, new_env) - in - let rec mkpath mp = function - | Lident name -> Pdot(mp, name, nopos) - | Ldot (m, name) -> Pdot(mkpath mp m, name, nopos) - | _ -> assert false - in - let tl' = - List.map - (fun name -> Btype.newgenty (Tconstr (mkpath mp name,[],ref Mnil))) - (* beware of interactions with Printtyp and short-path: - mp.name may have an arity > 0, cf. PR#7534 *) - nl in - (* go back to original level *) - Ctype.end_def (); - if nl = [] then - (wrap_constraint env modl (Mty_ident p) Tmodtype_implicit, []) - else let mty = modtype_of_package env modl.mod_loc p nl tl' in - List.iter2 - (fun n ty -> - try Ctype.unify env ty (Ctype.newvar ()) - with Ctype.Unify _ -> - raise (Error(m.pmod_loc, env, Scoping_pack (n,ty)))) - nl tl'; - (wrap_constraint env modl mty Tmodtype_implicit, tl') - -(* Fill in the forward declarations *) -let () = - Typecore.type_module := type_module_alias; - Typetexp.transl_modtype_longident := transl_modtype_longident; - Typetexp.transl_modtype := transl_modtype; - Typecore.type_open := type_open_ ?toplevel:None; - Typecore.type_package := type_package; - type_module_type_of_fwd := type_module_type_of - - -(* Typecheck an implementation file *) - -let type_implementation_more ?check_exists sourcefile outputprefix modulename initial_env ast = - Cmt_format.clear (); - try - Delayed_checks.reset_delayed_checks (); - let (str, sg, finalenv) = - type_structure initial_env ast (Location.in_file sourcefile) in - let simple_sg = simplify_signature sg in - begin - let sourceintf = - Filename.remove_extension sourcefile ^ !Config.interface_suffix in - let mli_status = !Clflags.assume_no_mli in - if mli_status = Clflags.Mli_exists then begin - let intf_file = - try - find_in_path_uncap !Config.load_path (modulename ^ ".cmi") - with Not_found -> - raise(Error(Location.in_file sourcefile, Env.empty, - Interface_not_compiled sourceintf)) in - let dclsig = Env.read_signature modulename intf_file in - let coercion = - Includemod.compunit initial_env sourcefile sg intf_file dclsig in - Delayed_checks.force_delayed_checks (); - (* It is important to run these checks after the inclusion test above, - so that value declarations which are not used internally but exported - are not reported as being unused. *) - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env None; - (str, coercion, finalenv, dclsig) - (* identifier is useless might read from serialized cmi files*) - end else begin - let coercion = - Includemod.compunit initial_env sourcefile sg - "(inferred signature)" simple_sg in - check_nongen_schemes finalenv simple_sg; - normalize_signature finalenv simple_sg; - Delayed_checks.force_delayed_checks (); - (* See comment above. Here the target signature contains all - the value being exported. We can still capture unused - declarations like "let x = true;; let x = 1;;", because in this - case, the inferred signature contains only the last declaration. *) - if not !Clflags.dont_write_files then begin - let deprecated = Builtin_attributes.deprecated_of_str ast in - let cmi = - Env.save_signature ?check_exists ~deprecated - simple_sg modulename (outputprefix ^ ".cmi") - in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) - (Some sourcefile) initial_env (Some cmi); - end; - (str, coercion, finalenv, simple_sg) - end - end - with e -> - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Partial_implementation - (Array.of_list (Cmt_format.get_saved_types ()))) - (Some sourcefile) initial_env None; - raise e - -let type_implementation sourcefile outputprefix modulename initial_env ast = - let (a,b,_,_) = - type_implementation_more sourcefile outputprefix modulename initial_env ast in - a,b - - -let save_signature modname tsg outputprefix source_file initial_env cmi = - Cmt_format.save_cmt (outputprefix ^ ".cmti") modname - (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) - - -(* "Packaging" of several compilation units into one unit - having them as sub-modules. *) - - -(* Error report *) - -open Printtyp - -let non_generalizable_msg ppf print_fallback_msg = - fprintf ppf - "%a@,@,\ - @[This happens when the type system senses there's a mutation/side-effect,@ in combination with a polymorphic value.@,\ - @{Using or annotating that value usually solves it.@}@]" - print_fallback_msg () - -let report_error ppf = function - Cannot_apply mty -> - fprintf ppf - "@[This module is not a functor; it has type@ %a@]" modtype mty - | Not_included errs -> - fprintf ppf - "@[Signature mismatch:@ %a@]" Includemod.report_error errs - | Cannot_eliminate_dependency mty -> - fprintf ppf - "@[This functor has type@ %a@ \ - The parameter cannot be eliminated in the result type.@ \ - Please bind the argument to a module identifier.@]" modtype mty - | Signature_expected -> fprintf ppf "This module type is not a signature" - | Structure_expected mty -> - fprintf ppf - "@[This module is not a structure; it has type@ %a" modtype mty - | With_no_component lid -> - fprintf ppf - "@[The signature constrained by `with' has no component named %a@]" - longident lid - | With_mismatch(lid, explanation) -> - fprintf ppf - "@[\ - @[In this `with' constraint, the new definition of %a@ \ - does not match its original definition@ \ - in the constrained signature:@]@ \ - %a@]" - longident lid Includemod.report_error explanation - | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> - fprintf ppf - "@[\ - @[This `with' constraint on %a makes the applicative functor @ \ - type %s ill-typed in the constrained signature:@]@ \ - %a@]" - longident lid (Path.name path) Includemod.report_error explanation - | With_changes_module_alias(lid, id, path) -> - fprintf ppf - "@[\ - @[This `with' constraint on %a changes %s, which is aliased @ \ - in the constrained signature (as %s)@].@]" - longident lid (Path.name path) (Ident.name id) - | With_cannot_remove_constrained_type -> - fprintf ppf - "@[Destructive substitutions are not supported for constrained @ \ - types (other than when replacing a type constructor with @ \ - a type constructor with the same arguments).@]" - | Repeated_name(kind, name, repeated_loc) -> - fprintf ppf - "@[Multiple definition of the %s name %s @ \ - at @{%a@}@ @ \ - Names must be unique in a given structure or signature.@]" kind name Location.print_loc repeated_loc - | Non_generalizable typ -> - (* modified *) - fprintf ppf "@["; - non_generalizable_msg - ppf - (fun ppf () -> - fprintf ppf - "@[This expression's type contains type variables that cannot be generalized:@,@{%a@}@]" - type_scheme typ); - fprintf ppf "@]" - | Non_generalizable_module mty -> - (* modified *) - fprintf ppf "@["; - non_generalizable_msg - ppf - (fun ppf () -> - fprintf ppf - "@[The type of this module contains type variables that cannot be generalized:@,@{%a@}@]" - modtype mty); - fprintf ppf "@]" - | Interface_not_compiled intf_name -> - fprintf ppf - "@[Could not find the .cmi file for interface@ %a.@]" - Location.print_filename intf_name - | Not_allowed_in_functor_body -> - fprintf ppf - "@[This expression creates fresh types.@ %s@]" - "It is not allowed inside applicative functors." - | Not_a_packed_module ty -> - fprintf ppf - "This expression is not a packed module. It has type@ %a" - type_expr ty - | Incomplete_packed_module ty -> - fprintf ppf - "The type of this packed module contains variables:@ %a" - type_expr ty - | Scoping_pack (lid, ty) -> - fprintf ppf - "The type %a in this module cannot be exported.@ " longident lid; - fprintf ppf - "Its type contains local dependencies:@ %a" type_expr ty - | Recursive_module_require_explicit_type -> - fprintf ppf "Recursive modules require an explicit module type." - | Apply_generative -> - fprintf ppf "This is a generative functor. It can only be applied to ()" - | Cannot_scrape_alias p -> - fprintf ppf - "This is an alias for module %a, which is missing" - path p - - -let super_report_error_no_wrap_printing_env = report_error - - -let report_error env ppf err = - Printtyp.wrap_printing_env env (fun () -> report_error ppf err) - -let () = - Location.register_error_of_exn - (function - | Error (loc, env, err) -> - Some (Location.error_of_printer loc (report_error env) err) - | Error_forward err -> - Some err - | _ -> - None - ) diff --git a/jscomp/ml/typemod.mli b/jscomp/ml/typemod.mli deleted file mode 100644 index e7bcece..0000000 --- a/jscomp/ml/typemod.mli +++ /dev/null @@ -1,89 +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. *) -(* *) -(**************************************************************************) - -(** Type-checking of the module language and typed ast plugin hooks *) - -open Types -open Format - -val type_module: - Env.t -> Parsetree.module_expr -> Typedtree.module_expr -val type_structure: - Env.t -> Parsetree.structure -> Location.t -> - Typedtree.structure * Types.signature * Env.t -val type_toplevel_phrase: - Env.t -> Parsetree.structure -> - Typedtree.structure * Types.signature * Env.t - - -val rescript_hide : Typedtree.structure_item_desc -> bool - -val type_implementation_more: ?check_exists:unit -> - string -> string -> string -> Env.t -> Parsetree.structure -> - Typedtree.structure * Typedtree.module_coercion * Env.t * Types.signature - -val type_implementation: - string -> string -> string -> Env.t -> Parsetree.structure -> - Typedtree.structure * Typedtree.module_coercion - -val transl_signature: - Env.t -> Parsetree.signature -> Typedtree.signature -val check_nongen_schemes: - Env.t -> Types.signature -> unit -val type_open_: - ?used_slot:bool ref -> ?toplevel:bool -> Asttypes.override_flag -> - Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t -val simplify_signature: signature -> signature - -val path_of_module : Typedtree.module_expr -> Path.t option - -val save_signature: - string -> Typedtree.signature -> string -> string -> - Env.t -> Cmi_format.cmi_infos -> unit - -type error = - Cannot_apply of module_type - | Not_included of Includemod.error list - | Cannot_eliminate_dependency of module_type - | Signature_expected - | Structure_expected of module_type - | With_no_component of Longident.t - | With_mismatch of Longident.t * Includemod.error list - | With_makes_applicative_functor_ill_typed of - Longident.t * Path.t * Includemod.error list - | With_changes_module_alias of Longident.t * Ident.t * Path.t - | With_cannot_remove_constrained_type - | Repeated_name of string * string * Warnings.loc - | Non_generalizable of type_expr - | Non_generalizable_module of module_type - | Interface_not_compiled of string - | Not_allowed_in_functor_body - | Not_a_packed_module of type_expr - | Incomplete_packed_module of type_expr - | Scoping_pack of Longident.t * type_expr - | Recursive_module_require_explicit_type - | Apply_generative - | Cannot_scrape_alias of Path.t - -exception Error of Location.t * Env.t * error -exception Error_forward of Location.error - - -val super_report_error_no_wrap_printing_env: formatter -> error -> unit - - -val report_error: Env.t -> formatter -> error -> unit - - diff --git a/jscomp/ml/typeopt.ml b/jscomp/ml/typeopt.ml deleted file mode 100644 index 565cc3b..0000000 --- a/jscomp/ml/typeopt.ml +++ /dev/null @@ -1,200 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 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. *) -(* *) -(**************************************************************************) - -(* Auxiliaries for type-based optimizations, e.g. array kinds *) - - -open Types -open Asttypes -open Typedtree -open Lambda - -let scrape_ty env ty = - let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in - match ty.desc with - | Tconstr (p, _, _) -> - begin match Env.find_type p env with - | {type_unboxed = {unboxed = true; _}; _} -> - begin match Typedecl.get_unboxed_type_representation env ty with - | None -> ty - | Some ty2 -> ty2 - end - | _ -> ty - | exception Not_found -> ty - end - | _ -> ty - -let scrape env ty = - (scrape_ty env ty).desc - - -(** [Types.constructor_description] - records the type at the definition type so for ['a option] - it will always be [Tvar] -*) -let rec type_cannot_contain_undefined (typ : Types.type_expr) (env : Env.t) = - match scrape env typ with - | Tconstr(p, _,_) -> - (* all built in types could not inhabit none-like values: - int, char, float, bool, unit, exn, array, list, nativeint, - int32, int64, lazy_t, bytes - *) - (match Predef.type_is_builtin_path_but_option p with - | For_sure_yes -> true - | For_sure_no -> false - | NA -> - let untagged = ref false in - begin match - let decl = Env.find_type p env in - let () = - if Ast_untagged_variants.has_untagged decl.type_attributes - then untagged := true in - decl.type_kind with - | exception _ -> - false - | Type_abstract | Type_open -> false - | Type_record _ -> true - | Type_variant - ([{cd_id = {name="None"}; cd_args = Cstr_tuple [] }; - {cd_id = {name = "Some"}; cd_args = Cstr_tuple [_]}] - | - [{cd_id = {name="Some"}; cd_args = Cstr_tuple [_] }; - {cd_id = {name = "None"}; cd_args = Cstr_tuple []}] - | [{cd_id= {name = "()"}; cd_args = Cstr_tuple []}] - ) - -> false (* conservative *) - | Type_variant cdecls -> - Ext_list.for_all cdecls (fun cd -> - if Ast_untagged_variants.has_undefined_literal cd.cd_attributes - then false - else if !untagged then - match cd.cd_args with - | Cstr_tuple [t] -> - Ast_untagged_variants.type_is_builtin_object t || type_cannot_contain_undefined t env - | Cstr_tuple [] -> true - | Cstr_tuple (_::_::_) -> true (* Not actually possible for untagged *) - | Cstr_record [{ld_type=t}] -> - Ast_untagged_variants.type_is_builtin_object t || type_cannot_contain_undefined t env - | Cstr_record ([] | _::_::_) -> true - else - true) - end) - | Ttuple _ - | Tvariant _ - | Tpackage _ - | Tarrow _ -> true - | Tfield _ - | Tpoly _ - | Tunivar _ - | Tlink _ - | Tsubst _ - | Tnil - | Tvar _ - | Tobject _ - -> false - -let is_function_type env ty = - match scrape env ty with - | Tarrow (_, lhs, rhs, _) -> Some (lhs, rhs) - | _ -> None - -let is_base_type env ty base_ty_path = - match scrape env ty with - | Tconstr(p, _, _) -> Path.same p base_ty_path - | _ -> false - -let maybe_pointer_type env ty = - if Ctype.maybe_pointer_type env ty then - Pointer - else - Immediate - -let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type - -type classification = - | Int - | Float - | Lazy - | Addr (* anything except a float or a lazy *) - | Any - -let classify env ty = - let ty = scrape_ty env ty in - if maybe_pointer_type env ty = Immediate then Int - else match ty.desc with - | Tvar _ | Tunivar _ -> - Any - | Tconstr (p, _args, _abbrev) -> - if Path.same p Predef.path_float then Float - else if Path.same p Predef.path_lazy_t then Lazy - else if Path.same p Predef.path_string - || Path.same p Predef.path_bytes - || Path.same p Predef.path_array - || Path.same p Predef.path_int64 then Addr - else begin - try - match (Env.find_type p env).type_kind with - | Type_abstract -> - Any - | Type_record _ | Type_variant _ | Type_open -> - Addr - with Not_found -> - (* This can happen due to e.g. missing -I options, - causing some .cmi files to be unavailable. - Maybe we should emit a warning. *) - Any - end - | Tarrow _ | Ttuple _ | Tpackage _ | Tobject _ | Tnil | Tvariant _ -> - Addr - | Tlink _ | Tsubst _ | Tpoly _ | Tfield _ -> - assert false - - - - - - - -(** Whether a forward block is needed for a lazy thunk on a value, i.e. - if the value can be represented as a float/forward/lazy *) -let lazy_val_requires_forward env ty = - match classify env ty with - | Any | Lazy -> true - | Float (*-> Config.flat_float_array*) - | Addr | Int -> false - -(** The compilation of the expression [lazy e] depends on the form of e: - constants, floats and identifiers are optimized. The optimization must be - taken into account when determining whether a recursive binding is safe. *) -let classify_lazy_argument : Typedtree.expression -> - [`Constant_or_function - |`Float - |`Identifier of [`Forward_value|`Other] - |`Other] = - fun e -> match e.exp_desc with - | Texp_constant - ( Const_int _ | Const_char _ | Const_string _ - | Const_int32 _ | Const_int64 _ | Const_bigint _ ) - | Texp_function _ - | Texp_construct (_, {cstr_arity = 0}, _) -> - `Constant_or_function - | Texp_constant(Const_float _) -> - `Float - | Texp_ident _ when lazy_val_requires_forward e.exp_env e.exp_type -> - `Identifier `Forward_value - | Texp_ident _ -> - `Identifier `Other - | _ -> - `Other diff --git a/jscomp/ml/typeopt.mli b/jscomp/ml/typeopt.mli deleted file mode 100644 index d0d5dff..0000000 --- a/jscomp/ml/typeopt.mli +++ /dev/null @@ -1,41 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1998 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. *) -(* *) -(**************************************************************************) - -(* Auxiliaries for type-based optimizations, e.g. array kinds *) - -val is_function_type : - Env.t -> Types.type_expr -> (Types.type_expr * Types.type_expr) option -val is_base_type : Env.t -> Types.type_expr -> Path.t -> bool - -val maybe_pointer_type : Env.t -> Types.type_expr - -> Lambda.immediate_or_pointer -val maybe_pointer : Typedtree.expression -> Lambda.immediate_or_pointer - - - - - - -val classify_lazy_argument : Typedtree.expression -> - [ `Constant_or_function - | `Float - | `Identifier of [`Forward_value | `Other] - | `Other] - -val type_cannot_contain_undefined: - Types.type_expr -> - Env.t -> - bool - diff --git a/jscomp/ml/types.ml b/jscomp/ml/types.ml deleted file mode 100644 index 0c94b4b..0000000 --- a/jscomp/ml/types.ml +++ /dev/null @@ -1,357 +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. *) -(* *) -(**************************************************************************) - -(* Representation of types and declarations *) - -open Asttypes - -(* Type expressions for the core language *) - -type type_expr = - { mutable desc: type_desc; - mutable level: int; - id: int } - -and type_desc = - Tvar of string option - | Tarrow of arg_label * type_expr * type_expr * commutable - | Ttuple of type_expr list - | Tconstr of Path.t * type_expr list * abbrev_memo ref - | Tobject of type_expr * (Path.t * type_expr list) option ref - | Tfield of string * field_kind * type_expr * type_expr - | Tnil - | Tlink of type_expr - | Tsubst of type_expr (* for copying *) - | Tvariant of row_desc - | Tunivar of string option - | Tpoly of type_expr * type_expr list - | Tpackage of Path.t * Longident.t list * type_expr list - -and row_desc = - { row_fields: (label * row_field) list; - row_more: type_expr; - row_bound: unit; - row_closed: bool; - row_fixed: bool; - row_name: (Path.t * type_expr list) option } - -and row_field = - Rpresent of type_expr option - | Reither of bool * type_expr list * bool * row_field option ref - (* 1st true denotes a constant constructor *) - (* 2nd true denotes a tag in a pattern matching, and - is erased later *) - | Rabsent - -and abbrev_memo = - Mnil - | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo - | Mlink of abbrev_memo ref - -and field_kind = - Fvar of field_kind option ref - | Fpresent - | Fabsent - -and commutable = - Cok - | Cunknown - | Clink of commutable ref - -module TypeOps = struct - type t = type_expr - let compare t1 t2 = t1.id - t2.id - let hash t = t.id - let equal t1 t2 = t1 == t2 -end - -(* Maps of methods and instance variables *) - -module OrderedString = - struct type t = string let compare (x:t) y = compare x y end -module Meths = Map.Make(OrderedString) -module Vars = Meths - -(* Value descriptions *) - -type value_description = - { val_type: type_expr; (* Type of the value *) - val_kind: value_kind; - val_loc: Location.t; - val_attributes: Parsetree.attributes; - } - -and value_kind = - Val_reg (* Regular value *) - | Val_prim of Primitive.description (* Primitive *) - -(* Variance *) - -module Variance = struct - type t = int - type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv - let single = function - | May_pos -> 1 - | May_neg -> 2 - | May_weak -> 4 - | Inj -> 8 - | Pos -> 16 - | Neg -> 32 - | Inv -> 64 - let union v1 v2 = v1 lor v2 - let inter v1 v2 = v1 land v2 - let subset v1 v2 = (v1 land v2 = v1) - let set x b v = - if b then v lor single x else v land (lnot (single x)) - let mem x = subset (single x) - let null = 0 - let may_inv = 7 - let full = 127 - let covariant = single May_pos lor single Pos lor single Inj - let swap f1 f2 v = - let v' = set f1 (mem f2 v) v in set f2 (mem f1 v) v' - let conjugate v = swap May_pos May_neg (swap Pos Neg v) - let get_upper v = (mem May_pos v, mem May_neg v) - let get_lower v = (mem Pos v, mem Neg v, mem Inv v, mem Inj v) -end - -(* Type definitions *) - -type type_declaration = - { type_params: type_expr list; - type_arity: int; - type_kind: type_kind; - type_private: private_flag; - type_manifest: type_expr option; - type_variance: Variance.t list; - type_newtype_level: (int * int) option; - type_loc: Location.t; - type_attributes: Parsetree.attributes; - type_immediate: bool; - type_unboxed: unboxed_status; - } - -and type_kind = - Type_abstract - | Type_record of label_declaration list * record_representation - | Type_variant of constructor_declaration list - | Type_open - -and record_representation = - | Record_regular (* All fields are boxed / tagged *) - | Record_float_unused (* Was: all fields are floats. Now: unused *) - | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) - | Record_inlined of (* Inlined record *) - { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes} - | Record_extension (* Inlined record under extension *) - | Record_optional_labels of string list (* List of optional labels *) - -and label_declaration = - { - ld_id: Ident.t; - ld_mutable: mutable_flag; - ld_type: type_expr; - ld_loc: Location.t; - ld_attributes: Parsetree.attributes; - } - -and constructor_declaration = - { - cd_id: Ident.t; - cd_args: constructor_arguments; - cd_res: type_expr option; - cd_loc: Location.t; - cd_attributes: Parsetree.attributes; - } - -and constructor_arguments = - | Cstr_tuple of type_expr list - | Cstr_record of label_declaration list - -and unboxed_status = - { - unboxed: bool; - default: bool; (* False if the unboxed field was set from an attribute. *) - } - -let unboxed_false_default_false = {unboxed = false; default = false} -let unboxed_false_default_true = {unboxed = false; default = true} -let unboxed_true_default_false = {unboxed = true; default = false} -let unboxed_true_default_true = {unboxed = true; default = true} - -type extension_constructor = - { ext_type_path: Path.t; - ext_type_params: type_expr list; - ext_args: constructor_arguments; - ext_ret_type: type_expr option; - ext_private: private_flag; - ext_loc: Location.t; - ext_attributes: Parsetree.attributes; } - -and type_transparence = - Type_public (* unrestricted expansion *) - | Type_new (* "new" type *) - | Type_private (* private type *) - -(* Type expressions for the class language *) - -module Concr = Set.Make(OrderedString) - -type class_type = - Cty_constr of Path.t * type_expr list * class_type - | Cty_signature of class_signature - | Cty_arrow of arg_label * type_expr * class_type - -and class_signature = - { csig_self: type_expr; - csig_vars: - (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; - csig_concr: Concr.t; - csig_inher: (Path.t * type_expr list) list } - -type class_declaration = - { cty_params: type_expr list; - mutable cty_type: class_type; - cty_path: Path.t; - cty_new: type_expr option; - cty_variance: Variance.t list; - cty_loc: Location.t; - cty_attributes: Parsetree.attributes; - } - -type class_type_declaration = - { clty_params: type_expr list; - clty_type: class_type; - clty_path: Path.t; - clty_variance: Variance.t list; - clty_loc: Location.t; - clty_attributes: Parsetree.attributes; - } - -(* Type expressions for the module language *) - -type module_type = - Mty_ident of Path.t - | Mty_signature of signature - | Mty_functor of Ident.t * module_type option * module_type - | Mty_alias of alias_presence * Path.t - -and alias_presence = - | Mta_present - | Mta_absent - -and signature = signature_item list - -and signature_item = - Sig_value of Ident.t * value_description - | Sig_type of Ident.t * type_declaration * rec_status - | Sig_typext of Ident.t * extension_constructor * ext_status - | Sig_module of Ident.t * module_declaration * rec_status - | Sig_modtype of Ident.t * modtype_declaration - | Sig_class of unit - | Sig_class_type of Ident.t * class_type_declaration * rec_status - -and module_declaration = - { - md_type: module_type; - md_attributes: Parsetree.attributes; - md_loc: Location.t; - } - -and modtype_declaration = - { - mtd_type: module_type option; (* Note: abstract *) - mtd_attributes: Parsetree.attributes; - mtd_loc: Location.t; - } - -and rec_status = - Trec_not (* first in a nonrecursive group *) - | Trec_first (* first in a recursive group *) - | Trec_next (* not first in a recursive/nonrecursive group *) - -and ext_status = - Text_first (* first constructor of an extension *) - | Text_next (* not first constructor of an extension *) - | Text_exception (* an exception *) - - -(* Constructor and record label descriptions inserted held in typing - environments *) - -type constructor_description = - { cstr_name: string; (* Constructor name *) - cstr_res: type_expr; (* Type of the result *) - cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) - cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag; (* Read-only constructor? *) - cstr_loc: Location.t; - cstr_attributes: Parsetree.attributes; - cstr_inlined: type_declaration option; - } - -and constructor_tag = - Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_unboxed (* Constructor of an unboxed type *) - | Cstr_extension of Path.t * bool (* Extension constructor - true if a constant false if a block*) - -let equal_tag t1 t2 = - match (t1, t2) with - | Cstr_constant i1, Cstr_constant i2 -> i2 = i1 - | Cstr_block i1, Cstr_block i2 -> i2 = i1 - | Cstr_unboxed, Cstr_unboxed -> true - | Cstr_extension (path1, b1), Cstr_extension (path2, b2) -> - Path.same path1 path2 && b1 = b2 - | (Cstr_constant _|Cstr_block _|Cstr_unboxed|Cstr_extension _), _ -> false - -let may_equal_constr c1 c2 = match c1.cstr_tag,c2.cstr_tag with -| Cstr_extension _,Cstr_extension _ -> c1.cstr_arity = c2.cstr_arity -| tag1,tag2 -> equal_tag tag1 tag2 - -type label_description = - { lbl_name: string; (* Short name *) - lbl_res: type_expr; (* Type of the result *) - lbl_arg: type_expr; (* Type of the argument *) - lbl_mut: mutable_flag; (* Is this a mutable field? *) - lbl_pos: int; (* Position in block *) - lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - } -let same_record_representation x y = - match x with - | Record_regular -> y = Record_regular - | Record_float_unused -> y = Record_float_unused - | Record_optional_labels lbls -> ( - match y with - | Record_optional_labels lbls2 -> lbls = lbls2 - | _ -> false) - | Record_inlined {tag; name; num_nonconsts; optional_labels} -> ( - match y with - | Record_inlined y -> - tag = y.tag && name = y.name && num_nonconsts = y.num_nonconsts && optional_labels = y.optional_labels - | _ -> false) - | Record_extension -> y = Record_extension - | Record_unboxed x -> ( match y with Record_unboxed y -> x = y | _ -> false) diff --git a/jscomp/ml/types.mli b/jscomp/ml/types.mli deleted file mode 100644 index eacf0b7..0000000 --- a/jscomp/ml/types.mli +++ /dev/null @@ -1,490 +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. *) -(* *) -(**************************************************************************) - -(** {0 Representation of types and declarations} *) - -(** [Types] defines the representation of types and declarations (that is, the - content of module signatures). - - CMI files are made of marshalled types. -*) - -(** Asttypes exposes basic definitions shared both by Parsetree and Types. *) -open Asttypes - -(** Type expressions for the core language. - - The [type_desc] variant defines all the possible type expressions one can - find in OCaml. [type_expr] wraps this with some annotations. - - The [level] field tracks the level of polymorphism associated to a type, - guiding the generalization algorithm. - Put shortly, when referring to a type in a given environment, both the type - and the environment have a level. If the type has an higher level, then it - can be considered fully polymorphic (type variables will be printed as - ['a]), otherwise it'll be weakly polymorphic, or non generalized (type - variables printed as ['_a]). - See [http://okmij.org/ftp/ML/generalization.html] for more information. - - Note about [type_declaration]: one should not make the confusion between - [type_expr] and [type_declaration]. - - [type_declaration] refers specifically to the [type] construct in OCaml - language, where you create and name a new type or type alias. - - [type_expr] is used when you refer to existing types, e.g. when annotating - the expected type of a value. - - Also, as the type system of OCaml is generative, a [type_declaration] can - have the side-effect of introducing a new type constructor, different from - all other known types. - Whereas [type_expr] is a pure construct which allows referring to existing - types. - - Note on mutability: TBD. - *) -type type_expr = - { mutable desc: type_desc; - mutable level: int; - id: int } - -and type_desc = - | Tvar of string option - (** [Tvar (Some "a")] ==> ['a] or ['_a] - [Tvar None] ==> [_] *) - - | Tarrow of arg_label * type_expr * type_expr * commutable - (** [Tarrow (Nolabel, e1, e2, c)] ==> [e1 -> e2] - [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] - [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] - - See [commutable] for the last argument. *) - - | Ttuple of type_expr list - (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) - - | Tconstr of Path.t * type_expr list * abbrev_memo ref - (** [Tconstr (`A.B.t', [t1;...;tn], _)] ==> [(t1,...,tn) A.B.t] - The last parameter keep tracks of known expansions, see [abbrev_memo]. *) - - | Tobject of type_expr * (Path.t * type_expr list) option ref - (** [Tobject (`f1:t1;...;fn: tn', `None')] ==> [< f1: t1; ...; fn: tn >] - f1, fn are represented as a linked list of types using Tfield and Tnil - constructors. - - [Tobject (_, `Some (`A.ct', [t1;...;tn]')] ==> [(t1, ..., tn) A.ct]. - where A.ct is the type of some class. - - There are also special cases for so-called "class-types", cf. [Typeclass] - and [Ctype.set_object_name]: - - [Tobject (Tfield(_,_,...(Tfield(_,_,rv)...), - Some(`A.#ct`, [rv;t1;...;tn])] - ==> [(t1, ..., tn) #A.ct] - [Tobject (_, Some(`A.#ct`, [Tnil;t1;...;tn])] ==> [(t1, ..., tn) A.ct] - - where [rv] is the hidden row variable. - *) - - | Tfield of string * field_kind * type_expr * type_expr - (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) - - | Tnil - (** [Tnil] ==> [<...; >] *) - - | Tlink of type_expr - (** Indirection used by unification engine. *) - - | Tsubst of type_expr (* for copying *) - (** [Tsubst] is used temporarily to store information in low-level - functions manipulating representation of types, such as - instantiation or copy. - This constructor should not appear outside of these cases. *) - - | Tvariant of row_desc - (** Representation of polymorphic variants, see [row_desc]. *) - - | Tunivar of string option - (** Occurrence of a type variable introduced by a - forall quantifier / [Tpoly]. *) - - | Tpoly of type_expr * type_expr list - (** [Tpoly (ty,tyl)] ==> ['a1... 'an. ty], - where 'a1 ... 'an are names given to types in tyl - and occurrences of those types in ty. *) - - | Tpackage of Path.t * Longident.t list * type_expr list - (** Type of a first-class module (a.k.a package). *) - -(** [ `X | `Y ] (row_closed = true) - [< `X | `Y ] (row_closed = true) - [> `X | `Y ] (row_closed = false) - [< `X | `Y > `X ] (row_closed = true) - - type t = [> `X ] as 'a (row_more = Tvar a) - type t = private [> `X ] (row_more = Tconstr (t#row, [], ref Mnil) - - And for: - - let f = function `X -> `X -> | `Y -> `X - - the type of "f" will be a [Tarrow] whose lhs will (basically) be: - - Tvariant { row_fields = [("X", _)]; - row_more = - Tvariant { row_fields = [("Y", _)]; - row_more = - Tvariant { row_fields = []; - row_more = _; - _ }; - _ }; - _ - } - -*) -and row_desc = - { row_fields: (label * row_field) list; - row_more: type_expr; - row_bound: unit; (* kept for compatibility *) - row_closed: bool; - row_fixed: bool; - row_name: (Path.t * type_expr list) option } - -and row_field = - Rpresent of type_expr option - | Reither of bool * type_expr list * bool * row_field option ref - (* 1st true denotes a constant constructor *) - (* 2nd true denotes a tag in a pattern matching, and - is erased later *) - | Rabsent - -(** [abbrev_memo] allows one to keep track of different expansions of a type - alias. This is done for performance purposes. - - For instance, when defining [type 'a pair = 'a * 'a], when one refers to an - ['a pair], it is just a shortcut for the ['a * 'a] type. - This expansion will be stored in the [abbrev_memo] of the corresponding - [Tconstr] node. - - In practice, [abbrev_memo] behaves like list of expansions with a mutable - tail. - - Note on marshalling: [abbrev_memo] must not appear in saved types. - [Btype], with [cleanup_abbrev] and [memo], takes care of tracking and - removing abbreviations. -*) -and abbrev_memo = - | Mnil (** No known abbreviation *) - - | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo - (** Found one abbreviation. - A valid abbreviation should be at least as visible and reachable by the - same path. - The first expression is the abbreviation and the second the expansion. *) - - | Mlink of abbrev_memo ref - (** Abbreviations can be found after this indirection *) - -and field_kind = - Fvar of field_kind option ref - | Fpresent - | Fabsent - -(** [commutable] is a flag appended to every arrow type. - - When typing an application, if the type of the functional is - known, its type is instantiated with [Cok] arrows, otherwise as - [Clink (ref Cunknown)]. - - When the type is not known, the application will be used to infer - the actual type. This is fragile in presence of labels where - there is no principal type. - - Two incompatible applications relying on [Cunknown] arrows will - trigger an error. - - let f g = - g ~a:() ~b:(); - g ~b:() ~a:(); - - Error: This function is applied to arguments - in an order different from other calls. - This is only allowed when the real type is known. -*) -and commutable = - Cok - | Cunknown - | Clink of commutable ref - -module TypeOps : sig - type t = type_expr - val compare : t -> t -> int - val equal : t -> t -> bool - val hash : t -> int -end - -(* Maps of methods and instance variables *) - -module Meths : Map.S with type key = string -module Vars : Map.S with type key = string - -(* Value descriptions *) - -type value_description = - { val_type: type_expr; (* Type of the value *) - val_kind: value_kind; - val_loc: Location.t; - val_attributes: Parsetree.attributes; - } - -and value_kind = - Val_reg (* Regular value *) - | Val_prim of Primitive.description (* Primitive *) - -(* Variance *) - -module Variance : sig - type t - type f = May_pos | May_neg | May_weak | Inj | Pos | Neg | Inv - val null : t (* no occurrence *) - val full : t (* strictly invariant *) - val covariant : t (* strictly covariant *) - val may_inv : t (* maybe invariant *) - val union : t -> t -> t - val inter : t -> t -> t - val subset : t -> t -> bool - val set : f -> bool -> t -> t - val mem : f -> t -> bool - val conjugate : t -> t (* exchange positive and negative *) - val get_upper : t -> bool * bool (* may_pos, may_neg *) - val get_lower : t -> bool * bool * bool * bool (* pos, neg, inv, inj *) -end - -(* Type definitions *) - -type type_declaration = - { type_params: type_expr list; - type_arity: int; - type_kind: type_kind; - type_private: private_flag; - type_manifest: type_expr option; - type_variance: Variance.t list; - (* covariant, contravariant, weakly contravariant, injective *) - type_newtype_level: (int * int) option; - (* definition level * expansion level *) - type_loc: Location.t; - type_attributes: Parsetree.attributes; - type_immediate: bool; (* true iff type should not be a pointer *) - type_unboxed: unboxed_status; - } - -and type_kind = - Type_abstract - | Type_record of label_declaration list * record_representation - | Type_variant of constructor_declaration list - | Type_open - -and record_representation = - | Record_regular (* All fields are boxed / tagged *) - | Record_float_unused (* Was: all fields are floats. Now: unused *) - | Record_unboxed of bool (* Unboxed single-field record, inlined or not *) - | Record_inlined of (* Inlined record *) - { tag : int ; name : string; num_nonconsts : int; optional_labels : string list; attrs: Parsetree.attributes } - | Record_extension (* Inlined record under extension *) - | Record_optional_labels of string list (* List of optional labels *) - -and label_declaration = - { - ld_id: Ident.t; - ld_mutable: mutable_flag; - ld_type: type_expr; - ld_loc: Location.t; - ld_attributes: Parsetree.attributes; - } - -and constructor_declaration = - { - cd_id: Ident.t; - cd_args: constructor_arguments; - cd_res: type_expr option; - cd_loc: Location.t; - cd_attributes: Parsetree.attributes; - } - -and constructor_arguments = - | Cstr_tuple of type_expr list - | Cstr_record of label_declaration list - -and unboxed_status = private - (* This type must be private in order to ensure perfect sharing of the - four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce - different executables. *) - { - unboxed: bool; - default: bool; (* True for unannotated unboxable types. *) - } - -val unboxed_false_default_false : unboxed_status -val unboxed_false_default_true : unboxed_status -val unboxed_true_default_false : unboxed_status -val unboxed_true_default_true : unboxed_status - -type extension_constructor = - { - ext_type_path: Path.t; - ext_type_params: type_expr list; - ext_args: constructor_arguments; - ext_ret_type: type_expr option; - ext_private: private_flag; - ext_loc: Location.t; - ext_attributes: Parsetree.attributes; - } - -and type_transparence = - Type_public (* unrestricted expansion *) - | Type_new (* "new" type *) - | Type_private (* private type *) - -(* Type expressions for the class language *) - -module Concr : Set.S with type elt = string - -type class_type = - Cty_constr of Path.t * type_expr list * class_type - | Cty_signature of class_signature - | Cty_arrow of arg_label * type_expr * class_type - -and class_signature = - { csig_self: type_expr; - csig_vars: - (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; - csig_concr: Concr.t; - csig_inher: (Path.t * type_expr list) list } - -type class_declaration = - { cty_params: type_expr list; - mutable cty_type: class_type; - cty_path: Path.t; - cty_new: type_expr option; - cty_variance: Variance.t list; - cty_loc: Location.t; - cty_attributes: Parsetree.attributes; - } - -type class_type_declaration = - { clty_params: type_expr list; - clty_type: class_type; - clty_path: Path.t; - clty_variance: Variance.t list; - clty_loc: Location.t; - clty_attributes: Parsetree.attributes; - } - -(* Type expressions for the module language *) - -type module_type = - Mty_ident of Path.t - | Mty_signature of signature - | Mty_functor of Ident.t * module_type option * module_type - | Mty_alias of alias_presence * Path.t - -and alias_presence = - | Mta_present - | Mta_absent - -and signature = signature_item list - -and signature_item = - Sig_value of Ident.t * value_description - | Sig_type of Ident.t * type_declaration * rec_status - | Sig_typext of Ident.t * extension_constructor * ext_status - | Sig_module of Ident.t * module_declaration * rec_status - | Sig_modtype of Ident.t * modtype_declaration - | Sig_class of unit - | Sig_class_type of Ident.t * class_type_declaration * rec_status - -and module_declaration = - { - md_type: module_type; - md_attributes: Parsetree.attributes; - md_loc: Location.t; - } - -and modtype_declaration = - { - mtd_type: module_type option; (* None: abstract *) - mtd_attributes: Parsetree.attributes; - mtd_loc: Location.t; - } - -and rec_status = - Trec_not (* first in a nonrecursive group *) - | Trec_first (* first in a recursive group *) - | Trec_next (* not first in a recursive/nonrecursive group *) - -and ext_status = - Text_first (* first constructor in an extension *) - | Text_next (* not first constructor in an extension *) - | Text_exception - - -(* Constructor and record label descriptions inserted held in typing - environments *) - -type constructor_description = - { cstr_name: string; (* Constructor name *) - cstr_res: type_expr; (* Type of the result *) - cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) - cstr_arity: int; (* Number of arguments *) - cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) - cstr_generalized: bool; (* Constrained return type? *) - cstr_private: private_flag; (* Read-only constructor? *) - cstr_loc: Location.t; - cstr_attributes: Parsetree.attributes; - cstr_inlined: type_declaration option; - } - -and constructor_tag = - Cstr_constant of int (* Constant constructor (an int) *) - | Cstr_block of int (* Regular constructor (a block) *) - | Cstr_unboxed (* Constructor of an unboxed type *) - | Cstr_extension of Path.t * bool (* Extension constructor - true if a constant false if a block*) - -(* Constructors are the same *) -val equal_tag : constructor_tag -> constructor_tag -> bool - -(* Constructors may be the same, given potential rebinding *) -val may_equal_constr : - constructor_description -> constructor_description -> bool - -type label_description = - { lbl_name: string; (* Short name *) - lbl_res: type_expr; (* Type of the result *) - lbl_arg: type_expr; (* Type of the argument *) - lbl_mut: mutable_flag; (* Is this a mutable field? *) - lbl_pos: int; (* Position in block *) - lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation; (* Representation for this record *) - lbl_private: private_flag; (* Read-only field? *) - lbl_loc: Location.t; - lbl_attributes: Parsetree.attributes; - } - -val same_record_representation : record_representation -> record_representation -> bool \ No newline at end of file diff --git a/jscomp/ml/typetexp.ml b/jscomp/ml/typetexp.ml deleted file mode 100644 index 5e63257..0000000 --- a/jscomp/ml/typetexp.ml +++ /dev/null @@ -1,1070 +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. *) -(* *) -(**************************************************************************) - -(* typetexp.ml,v 1.34.4.9 2002/01/07 08:39:16 garrigue Exp *) - -(* Typechecking of type expressions for the core language *) - -open Asttypes -open Misc -open Parsetree -open Typedtree -open Types -open Ctype - -exception Already_bound - -type error = - Unbound_type_variable of string - | Unbound_type_constructor of Longident.t - | Unbound_type_constructor_2 of Path.t - | Type_arity_mismatch of Longident.t * int * int - | Bound_type_variable of string - | Recursive_type - | Unbound_row_variable of Longident.t - | Type_mismatch of (type_expr * type_expr) list - | Alias_type_mismatch of (type_expr * type_expr) list - | Present_has_conjunction of string - | Present_has_no_type of string - | Constructor_mismatch of type_expr * type_expr - | Not_a_variant of type_expr - | Variant_tags of string * string - | Invalid_variable_name of string - | Cannot_quantify of string * type_expr - | Multiple_constraints_on_type of Longident.t - | Method_mismatch of string * type_expr * type_expr - | Unbound_value of Longident.t - | Unbound_constructor of Longident.t - | Unbound_label of Longident.t - | Unbound_module of Longident.t - | Unbound_class of Longident.t - | Unbound_modtype of Longident.t - | Unbound_cltype of Longident.t - | Ill_typed_functor_application of Longident.t - | Illegal_reference_to_recursive_module - | Access_functor_as_structure of Longident.t - | Apply_structure_as_functor of Longident.t - | Cannot_scrape_alias of Longident.t * Path.t - | Opened_object of Path.t option - | Not_an_object of type_expr - -exception Error of Location.t * Env.t * error -exception Error_forward of Location.error - - -type variable_context = int * (string, type_expr) Tbl.t - -(* Local definitions *) - -let instance_list = Ctype.instance_list Env.empty - -(* Narrowing unbound identifier errors. *) - -let rec narrow_unbound_lid_error : 'a. _ -> _ -> _ -> _ -> 'a = - fun env loc lid make_error -> - let check_module mlid = - try ignore (Env.lookup_module ~load:true mlid env) with - | Not_found -> - narrow_unbound_lid_error env loc mlid (fun lid -> Unbound_module lid) - | Env.Recmodule -> - raise (Error (loc, env, Illegal_reference_to_recursive_module)) - in - begin match lid with - | Longident.Lident _ -> () - | Longident.Ldot (mlid, _) -> - check_module mlid; - let md = Env.find_module (Env.lookup_module ~load:true mlid env) env in - begin match Env.scrape_alias env md.md_type with - | Mty_functor _ -> - raise (Error (loc, env, Access_functor_as_structure mlid)) - | Mty_alias(_, p) -> - raise (Error (loc, env, Cannot_scrape_alias(mlid, p))) - | _ -> () - end - | Longident.Lapply (flid, mlid) -> - check_module flid; - let fmd = Env.find_module (Env.lookup_module ~load:true flid env) env in - begin match Env.scrape_alias env fmd.md_type with - | Mty_signature _ -> - raise (Error (loc, env, Apply_structure_as_functor flid)) - | Mty_alias(_, p) -> - raise (Error (loc, env, Cannot_scrape_alias(flid, p))) - | _ -> () - end; - check_module mlid; - let mmd = Env.find_module (Env.lookup_module ~load:true mlid env) env in - begin match Env.scrape_alias env mmd.md_type with - | Mty_alias(_, p) -> - raise (Error (loc, env, Cannot_scrape_alias(mlid, p))) - | _ -> - raise (Error (loc, env, Ill_typed_functor_application lid)) - end - end; - raise (Error (loc, env, make_error lid)) - -let find_component (lookup : ?loc:_ -> _) make_error env loc lid = - try - match lid with - | Longident.Ldot (Longident.Lident "*predef*", s) -> - lookup ~loc (Longident.Lident s) Env.initial_safe_string - | _ -> - lookup ~loc lid env - with Not_found -> - narrow_unbound_lid_error env loc lid make_error - | Env.Recmodule -> - raise (Error (loc, env, Illegal_reference_to_recursive_module)) - -let find_type env loc lid = - let path = - find_component Env.lookup_type (fun lid -> Unbound_type_constructor lid) - env loc lid - in - let decl = Env.find_type path env in - Builtin_attributes.check_deprecated loc decl.type_attributes (Path.name path); - (path, decl) - -let find_constructor = - find_component Env.lookup_constructor (fun lid -> Unbound_constructor lid) -let find_all_constructors = - find_component Env.lookup_all_constructors - (fun lid -> Unbound_constructor lid) -let find_label = - find_component Env.lookup_label (fun lid -> Unbound_label lid) -let find_all_labels = - find_component Env.lookup_all_labels (fun lid -> Unbound_label lid) - -let find_class env loc lid = - let (path, decl) as r = - find_component Env.lookup_class (fun lid -> Unbound_class lid) env loc lid - in - Builtin_attributes.check_deprecated loc decl.cty_attributes (Path.name path); - r - -let find_value env loc lid = - Env.check_value_name (Longident.last lid) loc; - let (path, decl) as r = - find_component Env.lookup_value (fun lid -> Unbound_value lid) env loc lid - in - Builtin_attributes.check_deprecated loc decl.val_attributes (Path.name path); - r - -let lookup_module ?(load=false) env loc lid = - find_component (fun ?loc lid env -> (Env.lookup_module ~load ?loc lid env)) - (fun lid -> Unbound_module lid) env loc lid - -let find_module env loc lid = - let path = lookup_module ~load:true env loc lid in - let decl = Env.find_module path env in - (* No need to check for deprecated here, this is done in Env. *) - (path, decl) - -let find_modtype env loc lid = - let (path, decl) as r = - find_component Env.lookup_modtype (fun lid -> Unbound_modtype lid) - env loc lid - in - Builtin_attributes.check_deprecated loc decl.mtd_attributes (Path.name path); - r - -let find_class_type env loc lid = - let (path, decl) as r = - find_component Env.lookup_cltype (fun lid -> Unbound_cltype lid) - env loc lid - in - Builtin_attributes.check_deprecated loc decl.clty_attributes (Path.name path); - r - -let unbound_constructor_error env lid = - narrow_unbound_lid_error env lid.loc lid.txt - (fun lid -> Unbound_constructor lid) - -let unbound_label_error env lid = - narrow_unbound_lid_error env lid.loc lid.txt - (fun lid -> Unbound_label lid) - -(* Support for first-class modules. *) - -let transl_modtype_longident = ref (fun _ -> assert false) -let transl_modtype = ref (fun _ -> assert false) - -let create_package_mty fake loc env (p, l) = - let l = - List.sort - (fun (s1, _t1) (s2, _t2) -> - if s1.txt = s2.txt then - raise (Error (loc, env, Multiple_constraints_on_type s1.txt)); - compare s1.txt s2.txt) - l - in - l, - List.fold_left - (fun mty (s, t) -> - let d = {ptype_name = mkloc (Longident.last s.txt) s.loc; - ptype_params = []; - ptype_cstrs = []; - ptype_kind = Ptype_abstract; - ptype_private = Asttypes.Public; - ptype_manifest = if fake then None else Some t; - ptype_attributes = []; - ptype_loc = loc} in - Ast_helper.Mty.mk ~loc - (Pmty_with (mty, [ Pwith_type ({ txt = s.txt; loc }, d) ])) - ) - (Ast_helper.Mty.mk ~loc (Pmty_ident p)) - l - -(* Translation of type expressions *) - -let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t) -let univars = ref ([] : (string * type_expr) list) -let pre_univars = ref ([] : type_expr list) -let used_variables = ref (Tbl.empty : (string, type_expr * Location.t) Tbl.t) - -let reset_type_variables () = - reset_global_level (); - Ctype.reset_reified_var_counter (); - type_variables := Tbl.empty - -let narrow () = - (increase_global_level (), !type_variables) - -let widen (gl, tv) = - restore_global_level gl; - type_variables := tv - -let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z') - -let validate_name = function - None -> None - | Some name as s -> - if name <> "" && strict_ident name.[0] then s else None - -let new_global_var ?name () = - new_global_var ?name:(validate_name name) () -let newvar ?name () = - newvar ?name:(validate_name name) () - -let type_variable loc name = - try - Tbl.find name !type_variables - with Not_found -> - raise(Error(loc, Env.empty, Unbound_type_variable ("'" ^ name))) - -let transl_type_param env styp = - let loc = styp.ptyp_loc in - match styp.ptyp_desc with - Ptyp_any -> - let ty = new_global_var ~name:"_" () in - { ctyp_desc = Ttyp_any; ctyp_type = ty; ctyp_env = env; - ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } - | Ptyp_var name -> - let ty = - try - if name <> "" && name.[0] = '_' then - raise (Error (loc, Env.empty, Invalid_variable_name ("'" ^ name))); - ignore (Tbl.find name !type_variables); - raise Already_bound - with Not_found -> - let v = new_global_var ~name () in - type_variables := Tbl.add name v !type_variables; - v - in - { ctyp_desc = Ttyp_var name; ctyp_type = ty; ctyp_env = env; - ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes; } - | _ -> assert false - -let transl_type_param env styp = - (* Currently useless, since type parameters cannot hold attributes - (but this could easily be lifted in the future). *) - Builtin_attributes.warning_scope styp.ptyp_attributes - (fun () -> transl_type_param env styp) - - -let new_pre_univar ?name () = - let v = newvar ?name () in pre_univars := v :: !pre_univars; v - -let rec swap_list = function - x :: y :: l -> y :: x :: swap_list l - | l -> l - -type policy = Fixed | Extensible | Univars - -let rec transl_type env policy styp = - Builtin_attributes.warning_scope styp.ptyp_attributes - (fun () -> transl_type_aux env policy styp) - -and transl_type_aux env policy styp = - let loc = styp.ptyp_loc in - let ctyp ctyp_desc ctyp_type = - { ctyp_desc; ctyp_type; ctyp_env = env; - ctyp_loc = loc; ctyp_attributes = styp.ptyp_attributes } - in - match styp.ptyp_desc with - Ptyp_any -> - let ty = - if policy = Univars then new_pre_univar () else - if policy = Fixed then - raise (Error (styp.ptyp_loc, env, Unbound_type_variable "_")) - else newvar () - in - ctyp Ttyp_any ty - | Ptyp_var name -> - let ty = - if name <> "" && name.[0] = '_' then - raise (Error (styp.ptyp_loc, env, Invalid_variable_name ("'" ^ name))); - begin try - instance env (List.assoc name !univars) - with Not_found -> try - instance env (fst(Tbl.find name !used_variables)) - with Not_found -> - let v = - if policy = Univars then new_pre_univar ~name () else newvar ~name () - in - used_variables := Tbl.add name (v, styp.ptyp_loc) !used_variables; - v - end - in - ctyp (Ttyp_var name) ty - | Ptyp_arrow(l, st1, st2) -> - let cty1 = transl_type env policy st1 in - let cty2 = transl_type env policy st2 in - let ty1 = cty1.ctyp_type in - let ty1 = - if Btype.is_optional l - then newty (Tconstr(Predef.path_option,[ty1], ref Mnil)) - else ty1 in - let ty = newty (Tarrow(l, ty1, cty2.ctyp_type, Cok)) in - ctyp (Ttyp_arrow (l, cty1, cty2)) ty - | Ptyp_tuple stl -> - assert (List.length stl >= 2); - let ctys = List.map (transl_type env policy) stl in - let ty = newty (Ttuple (List.map (fun ctyp -> ctyp.ctyp_type) ctys)) in - ctyp (Ttyp_tuple ctys) ty - | Ptyp_constr(lid, stl) -> - let (path, decl) = find_type env lid.loc lid.txt in - let stl = - match stl with - | [ {ptyp_desc=Ptyp_any} as t ] when decl.type_arity > 1 -> - List.map (fun _ -> t) decl.type_params - | _ -> stl - in - if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, env, - Type_arity_mismatch(lid.txt, decl.type_arity, - List.length stl))); - let args = List.map (transl_type env policy) stl in - let params = instance_list decl.type_params in - let unify_param = - match decl.type_manifest with - None -> unify_var - | Some ty -> - if (repr ty).level = Btype.generic_level then unify_var else unify - in - List.iter2 - (fun (sty, cty) ty' -> - try unify_param env ty' cty.ctyp_type with Unify trace -> - raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) - (List.combine stl args) params; - let constr = - newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in - begin try - Ctype.enforce_constraints env constr - with Unify trace -> - raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) - end; - ctyp (Ttyp_constr (path, lid, args)) constr - | Ptyp_object (fields, o) -> - let ty, fields = transl_fields env policy o fields in - ctyp (Ttyp_object (fields, o)) (newobj ty) - | Ptyp_class(lid, stl) -> - let (path, decl, _is_variant) = - try - let path = Env.lookup_type lid.txt env in - let decl = Env.find_type path env in - let rec check decl = - match decl.type_manifest with - None -> raise Not_found - | Some ty -> - match (repr ty).desc with - Tvariant row when Btype.static_row row -> () - | Tconstr (path, _, _) -> - check (Env.find_type path env) - | _ -> raise Not_found - in check decl; - Location.deprecated styp.ptyp_loc - "old syntax for polymorphic variant type"; - (path, decl,true) - with Not_found -> try - let lid2 = - match lid.txt with - Longident.Lident s -> Longident.Lident ("#" ^ s) - | Longident.Ldot(r, s) -> Longident.Ldot (r, "#" ^ s) - | Longident.Lapply(_, _) -> fatal_error "Typetexp.transl_type" - in - let path = Env.lookup_type lid2 env in - let decl = Env.find_type path env in - (path, decl, false) - with Not_found -> - ignore (find_class env lid.loc lid.txt); assert false - in - if List.length stl <> decl.type_arity then - raise(Error(styp.ptyp_loc, env, - Type_arity_mismatch(lid.txt, decl.type_arity, - List.length stl))); - let args = List.map (transl_type env policy) stl in - let params = instance_list decl.type_params in - List.iter2 - (fun (sty, cty) ty' -> - try unify_var env ty' cty.ctyp_type with Unify trace -> - raise (Error(sty.ptyp_loc, env, Type_mismatch (swap_list trace)))) - (List.combine stl args) params; - let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in - let ty = - try Ctype.expand_head env (newconstr path ty_args) - with Unify trace -> - raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) - in - let ty = match ty.desc with - Tvariant row -> - let row = Btype.row_repr row in - let fields = - List.map - (fun (l,f) -> l, - match Btype.row_field_repr f with - | Rpresent (Some ty) -> - Reither(false, [ty], false, ref None) - | Rpresent None -> - Reither (true, [], false, ref None) - | _ -> f) - row.row_fields - in - let row = { row_closed = true; row_fields = fields; - row_bound = (); row_name = Some (path, ty_args); - row_fixed = false; row_more = newvar () } in - let static = Btype.static_row row in - let row = - if static then { row with row_more = newty Tnil } - else if policy <> Univars then row - else { row with row_more = new_pre_univar () } - in - newty (Tvariant row) - | Tobject (fi, _) -> - let _, tv = flatten_fields fi in - if policy = Univars then pre_univars := tv :: !pre_univars; - ty - | _ -> - assert false - in - ctyp (Ttyp_class (path, lid, args)) ty - | Ptyp_alias(st, alias) -> - let cty = - try - let t = - try List.assoc alias !univars - with Not_found -> - instance env (fst(Tbl.find alias !used_variables)) - in - let ty = transl_type env policy st in - begin try unify_var env t ty.ctyp_type with Unify trace -> - let trace = swap_list trace in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) - end; - ty - with Not_found -> - let t = newvar () in - used_variables := Tbl.add alias (t, styp.ptyp_loc) !used_variables; - let ty = transl_type env policy st in - begin try unify_var env t ty.ctyp_type with Unify trace -> - let trace = swap_list trace in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) - end; - let t = instance env t in - let px = Btype.proxy t in - begin match px.desc with - | Tvar None -> Btype.log_type px; px.desc <- Tvar (Some alias) - | Tunivar None -> Btype.log_type px; px.desc <- Tunivar (Some alias) - | _ -> () - end; - { ty with ctyp_type = t } - in - ctyp (Ttyp_alias (cty, alias)) cty.ctyp_type - | Ptyp_variant(fields, closed, present) -> - let name = ref None in - let mkfield l f = - newty (Tvariant {row_fields=[l,f]; row_more=newvar(); - row_bound=(); row_closed=true; - row_fixed=false; row_name=None}) in - let hfields = Hashtbl.create 17 in - let collection_detect = Hashtbl.create 17 in - let add_typed_field loc l f = - if not !Config.bs_only then begin - let h = Btype.hash_variant l in - if Hashtbl.mem collection_detect h then - let l' = Hashtbl.find collection_detect h in - (* Check for tag conflicts *) - if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); - else Hashtbl.add collection_detect h l - end ; - try - let (_,f') = Hashtbl.find hfields l in - let ty = mkfield l f and ty' = mkfield l f' in - if equal env false [ty] [ty'] then () else - try unify env ty ty' - with Unify _trace -> - raise(Error(loc, env, Constructor_mismatch (ty,ty'))) - with Not_found -> - Hashtbl.add hfields l (l,f) - in - let add_field = function - Rtag (l, attrs, c, stl) -> - name := None; - let tl = - Builtin_attributes.warning_scope attrs - (fun () -> List.map (transl_type env policy) stl) - in - let f = match present with - Some present when not (List.mem l.txt present) -> - let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in - Reither(c, ty_tl, false, ref None) - | _ -> - if List.length stl > 1 || c && stl <> [] then - raise(Error(styp.ptyp_loc, env, - Present_has_conjunction l.txt)); - match tl with [] -> Rpresent None - | st :: _ -> - Rpresent (Some st.ctyp_type) - in - add_typed_field styp.ptyp_loc l.txt f; - Ttag (l,attrs,c,tl) - | Rinherit sty -> - let cty = transl_type env policy sty in - let ty = cty.ctyp_type in - let nm = - match repr cty.ctyp_type with - {desc=Tconstr(p, tl, _)} -> Some(p, tl) - | _ -> None - in - begin - (* Set name if there are no fields yet *) - if Hashtbl.length hfields <> 0 then name := None - else name := nm - end; - let fl = match expand_head env cty.ctyp_type, nm with - {desc=Tvariant row}, _ when Btype.static_row row -> - let row = Btype.row_repr row in - row.row_fields - | {desc=Tvar _}, Some(p, _) -> - raise(Error(sty.ptyp_loc, env, Unbound_type_constructor_2 p)) - | _ -> - raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) - in - List.iter - (fun (l, f) -> - let f = match present with - Some present when not (List.mem l present) -> - begin match f with - Rpresent(Some ty) -> - Reither(false, [ty], false, ref None) - | Rpresent None -> - Reither(true, [], false, ref None) - | _ -> - assert false - end - | _ -> f - in - add_typed_field sty.ptyp_loc l f) - fl; - Tinherit cty - in - let tfields = List.map add_field fields in - let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in - begin match present with None -> () - | Some present -> - List.iter - (fun l -> if not (List.mem_assoc l fields) then - raise(Error(styp.ptyp_loc, env, Present_has_no_type l))) - present - end; - let row = - { row_fields = List.rev fields; row_more = newvar (); - row_bound = (); row_closed = (closed = Closed); - row_fixed = false; row_name = !name } in - let static = Btype.static_row row in - let row = - if static then { row with row_more = newty Tnil } - else if policy <> Univars then row - else { row with row_more = new_pre_univar () } - in - let ty = newty (Tvariant row) in - ctyp (Ttyp_variant (tfields, closed, present)) ty - | Ptyp_poly(vars, st) -> - let vars = List.map (fun v -> v.txt) vars in - begin_def(); - let new_univars = List.map (fun name -> name, newvar ~name ()) vars in - let old_univars = !univars in - univars := new_univars @ !univars; - let cty = transl_type env policy st in - let ty = cty.ctyp_type in - univars := old_univars; - end_def(); - generalize ty; - let ty_list = - List.fold_left - (fun tyl (name, ty1) -> - let v = Btype.proxy ty1 in - if deep_occur v ty then begin - match v.desc with - Tvar name when v.level = Btype.generic_level -> - v.desc <- Tunivar name; - v :: tyl - | _ -> - raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v))) - end else tyl) - [] new_univars - in - let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in - unify_var env (newvar()) ty'; - ctyp (Ttyp_poly (vars, cty)) ty' - | Ptyp_package (p, l) -> - let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in - let z = narrow () in - let mty = !transl_modtype env mty in - widen z; - let ptys = List.map (fun (s, pty) -> - s, transl_type env policy pty - ) l in - let path = !transl_modtype_longident styp.ptyp_loc env p.txt in - let ty = newty (Tpackage (path, - List.map (fun (s, _pty) -> s.txt) l, - List.map (fun (_,cty) -> cty.ctyp_type) ptys)) - in - ctyp (Ttyp_package { - pack_path = path; - pack_type = mty.mty_type; - pack_fields = ptys; - pack_txt = p; - }) ty - | Ptyp_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - -and transl_poly_type env policy t = - transl_type env policy (Ast_helper.Typ.force_poly t) - -and transl_fields env policy o fields = - let hfields = Hashtbl.create 17 in - let add_typed_field loc l ty = - try - let ty' = Hashtbl.find hfields l in - if equal env false [ty] [ty'] then () else - try unify env ty ty' - with Unify _trace -> - raise(Error(loc, env, Method_mismatch (l, ty, ty'))) - with Not_found -> - Hashtbl.add hfields l ty in - let add_field = function - | Otag (s, a, ty1) -> begin - let ty1 = - Builtin_attributes.warning_scope a - (fun () -> transl_poly_type env policy ty1) - in - let field = OTtag (s, a, ty1) in - add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; - field - end - | Oinherit sty -> begin - let cty = transl_type env policy sty in - let nm = - match repr cty.ctyp_type with - {desc=Tconstr(p, _, _)} -> Some p - | _ -> None in - let t = expand_head env cty.ctyp_type in - match t, nm with - {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin - if opened_object t then - raise (Error (sty.ptyp_loc, env, Opened_object nm)); - let rec iter_add = function - | Tfield (s, _k, ty1, ty2) -> begin - add_typed_field sty.ptyp_loc s ty1; - iter_add ty2.desc - end - | Tnil -> () - | _ -> assert false in - iter_add tf; - OTinherit cty - end - | {desc=Tvar _}, Some p -> - raise (Error (sty.ptyp_loc, env, Unbound_type_constructor_2 p)) - | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t)) - end in - let object_fields = List.map add_field fields in - let fields = Hashtbl.fold (fun s ty l -> (s, ty) :: l) hfields [] in - let ty_init = - match o, policy with - | Closed, _ -> newty Tnil - | Open, Univars -> new_pre_univar () - | Open, _ -> newvar () in - let ty = List.fold_left (fun ty (s, ty') -> - newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in - ty, object_fields - - -(* Make the rows "fixed" in this type, to make universal check easier *) -let rec make_fixed_univars ty = - let ty = repr ty in - if ty.level >= Btype.lowest_level then begin - Btype.mark_type_node ty; - match ty.desc with - | Tvariant row -> - let row = Btype.row_repr row in - if Btype.is_Tunivar (Btype.row_more row) then - ty.desc <- Tvariant - {row with row_fixed=true; - row_fields = List.map - (fun (s,f as p) -> match Btype.row_field_repr f with - Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r) - | _ -> p) - row.row_fields}; - Btype.iter_row make_fixed_univars row - | _ -> - Btype.iter_type_expr make_fixed_univars ty - end - -let make_fixed_univars ty = - make_fixed_univars ty; - Btype.unmark_type ty - -let create_package_mty = create_package_mty false - -let globalize_used_variables env fixed = - let r = ref [] in - Tbl.iter - (fun name (ty, loc) -> - let v = new_global_var () in - let snap = Btype.snapshot () in - if try unify env v ty; true with _ -> Btype.backtrack snap; false - then try - r := (loc, v, Tbl.find name !type_variables) :: !r - with Not_found -> - if fixed && Btype.is_Tvar (repr ty) then - raise(Error(loc, env, Unbound_type_variable ("'"^name))); - let v2 = new_global_var () in - r := (loc, v, v2) :: !r; - type_variables := Tbl.add name v2 !type_variables) - !used_variables; - used_variables := Tbl.empty; - fun () -> - List.iter - (function (loc, t1, t2) -> - try unify env t1 t2 with Unify trace -> - raise (Error(loc, env, Type_mismatch trace))) - !r - -let transl_simple_type env fixed styp = - univars := []; used_variables := Tbl.empty; - let typ = transl_type env (if fixed then Fixed else Extensible) styp in - globalize_used_variables env fixed (); - make_fixed_univars typ.ctyp_type; - typ - -let transl_simple_type_univars env styp = - univars := []; used_variables := Tbl.empty; pre_univars := []; - begin_def (); - let typ = transl_type env Univars styp in - (* Only keep already global variables in used_variables *) - let new_variables = !used_variables in - used_variables := Tbl.empty; - Tbl.iter - (fun name p -> - if Tbl.mem name !type_variables then - used_variables := Tbl.add name p !used_variables) - new_variables; - globalize_used_variables env false (); - end_def (); - generalize typ.ctyp_type; - let univs = - List.fold_left - (fun acc v -> - let v = repr v in - match v.desc with - Tvar name when v.level = Btype.generic_level -> - v.desc <- Tunivar name; v :: acc - | _ -> acc) - [] !pre_univars - in - make_fixed_univars typ.ctyp_type; - { typ with ctyp_type = - instance env (Btype.newgenty (Tpoly (typ.ctyp_type, univs))) } - -let transl_simple_type_delayed env styp = - univars := []; used_variables := Tbl.empty; - let typ = transl_type env Extensible styp in - make_fixed_univars typ.ctyp_type; - (typ, globalize_used_variables env false) - -let transl_type_scheme env styp = - reset_type_variables(); - begin_def(); - let typ = transl_simple_type env false styp in - end_def(); - generalize typ.ctyp_type; - typ - - -(* Error report *) - -open Format -open Printtyp - -let did_you_mean ppf choices : bool = - (* flush now to get the error report early, in the (unheard of) case - where the linear search would take a bit of time; in the worst - case, the user has seen the error, she can interrupt the process - before the spell-checking terminates. *) - Format.fprintf ppf "@?"; - match choices () with - | [] -> false - | last :: rev_rest -> - Format.fprintf ppf "@[@,@,@{Hint: Did you mean %s%s%s?@}@]" - (String.concat ", " (List.rev rev_rest)) - (if rev_rest = [] then "" else " or ") - last; - true - -let super_spellcheck ppf fold env lid = - let choices path name : string list = - let env : string list = fold (fun x _ _ xs -> x ::xs ) path env [] in - Misc.spellcheck env name in - match lid with - | Longident.Lapply _ -> false - | Longident.Lident s -> - did_you_mean ppf (fun _ -> choices None s) - | Longident.Ldot (r, s) -> - did_you_mean ppf (fun _ -> choices (Some r) s) - -let spellcheck ppf fold env lid = - let choices ~path name = - let env = fold (fun x xs -> x::xs) path env [] in - Misc.spellcheck env name in - match lid with - | Longident.Lapply _ -> () - | Longident.Lident s -> - Misc.did_you_mean ppf (fun () -> choices ~path:None s) - | Longident.Ldot (r, s) -> - Misc.did_you_mean ppf (fun () -> choices ~path:(Some r) s) - -let fold_descr fold get_name f = fold (fun descr acc -> f (get_name descr) acc) -let fold_simple fold4 f = fold4 (fun name _path _descr acc -> f name acc) - -let fold_constructors = fold_descr Env.fold_constructors (fun d -> d.cstr_name) -let fold_labels = fold_descr Env.fold_labels (fun d -> d.lbl_name) -let fold_classs = fold_simple Env.fold_classs -let fold_modtypes = fold_simple Env.fold_modtypes -let fold_cltypes = fold_simple Env.fold_cltypes - -let report_error env ppf = function - | Unbound_type_variable name -> - (* we don't use "spellcheck" here: the function that raises this - error seems not to be called anywhere, so it's unclear how it - should be handled *) - fprintf ppf "Unbound type parameter %s@." name - | Unbound_type_constructor lid -> - (* modified *) - Format.fprintf ppf "@[This type constructor, `%a`, can't be found.@ " Printtyp.longident lid; - let has_candidate = super_spellcheck ppf Env.fold_types env lid in - if !Config.syntax_kind = `rescript && not has_candidate then - Format.fprintf ppf "If you wanted to write a recursive type, don't forget the `rec` in `type rec`@]" - | Unbound_type_constructor_2 p -> - fprintf ppf "The type constructor@ %a@ is not yet completely defined" - path p - | Type_arity_mismatch(lid, expected, provided) -> - if expected==0 then - fprintf ppf - "@[The type %a is not generic so expects no arguments,@ \ - but is here applied to %i argument(s).@ \ - Have you tried removing the angular brackets `<` and `>` and the@ \ - arguments within them and just writing `%a` instead? @]" - longident lid provided longident lid - else - fprintf ppf - "@[The type constructor %a@ expects %i argument(s),@ \ - but is here applied to %i argument(s)@]" - longident lid expected provided - | Bound_type_variable name -> - fprintf ppf "Already bound type parameter '%s" name - | Recursive_type -> - fprintf ppf "This type is recursive" - | Unbound_row_variable lid -> - (* we don't use "spellcheck" here: this error is not raised - anywhere so it's unclear how it should be handled *) - fprintf ppf "Unbound row variable in #%a" longident lid - | Type_mismatch trace -> - Printtyp.report_unification_error ppf Env.empty trace - (function ppf -> - fprintf ppf "This type") - (function ppf -> - fprintf ppf "should be an instance of type") - | Alias_type_mismatch trace -> - Printtyp.report_unification_error ppf Env.empty trace - (function ppf -> - fprintf ppf "This alias is bound to type") - (function ppf -> - fprintf ppf "but is used as an instance of type") - | Present_has_conjunction l -> - fprintf ppf "The present constructor %s has a conjunctive type" l - | Present_has_no_type l -> - fprintf ppf "The present constructor %s has no type" l - | Constructor_mismatch (ty, ty') -> - wrap_printing_env env (fun () -> - Printtyp.reset_and_mark_loops_list [ty; ty']; - fprintf ppf "@[%s %a@ %s@ %a@]" - "This variant type contains a constructor" - Printtyp.type_expr ty - "which should be" - Printtyp.type_expr ty') - | Not_a_variant ty -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf - "@[The type %a@ does not expand to a polymorphic variant type@]" - Printtyp.type_expr ty; - begin match ty.desc with - | Tvar (Some s) -> - (* PR#7012: help the user that wrote 'Foo instead of `Foo *) - Misc.did_you_mean ppf (fun () -> ["`" ^ s]) - | _ -> () - end - | Variant_tags (lab1, lab2) -> - fprintf ppf - "@[Variant tags %s@ and %s have the same hash value.@ %s@]" - (!Printtyp.print_res_poly_identifier lab1) (!Printtyp.print_res_poly_identifier lab2) "Change one of them." - | Invalid_variable_name name -> - fprintf ppf "The type variable name %s is not allowed in programs" name - | Cannot_quantify (name, v) -> - fprintf ppf - "@[The universal type variable '%s cannot be generalized:@ %s.@]" - name - (if Btype.is_Tvar v then "it escapes its scope" else - if Btype.is_Tunivar v then "it is already bound to another variable" - else "it is not a variable") - | Multiple_constraints_on_type s -> - fprintf ppf "Multiple constraints for type %a" longident s - | Method_mismatch (l, ty, ty') -> - wrap_printing_env env (fun () -> - Printtyp.reset_and_mark_loops_list [ty; ty']; - fprintf ppf "@[Method '%s' has type %a,@ which should be %a@]" - l Printtyp.type_expr ty Printtyp.type_expr ty') - | Unbound_value lid -> - (* modified *) - begin - match lid with - | Ldot (outer, inner) -> - Format.fprintf ppf "The value %s can't be found in %a" - inner - Printtyp.longident outer; - | other_ident -> Format.fprintf ppf "The value %a can't be found" Printtyp.longident other_ident - end; - super_spellcheck ppf Env.fold_values env lid |> ignore - | Unbound_module lid -> - (* modified *) - begin match lid with - | Lident "Str" -> - begin - Format.fprintf ppf "@[\ - @{The module or file %a can't be found.@}@,@,\ - Are you trying to use the standard library's Str?@ \ - If you're compiling to JavaScript,@ use @{Js.Re@} instead.@ \ - Otherwise, add str.cma to your ocamlc/ocamlopt command.\ - @]" - Printtyp.longident lid - end - | lid -> - begin - Format.fprintf ppf "@[\ - @{The module or file %a can't be found.@}@,\ - @[- If it's a third-party dependency:@,\ - - Did you add it to the \"bs-dependencies\" or \"bs-dev-dependencies\" in bsconfig.json?@]@,\ - - Did you include the file's directory to the \"sources\" in bsconfig.json?@,\ - " - Printtyp.longident lid - end - end; - super_spellcheck ppf Env.fold_modules env lid |> ignore - | Unbound_constructor lid -> - (* modified *) - Format.fprintf ppf "@[\ - @{The variant constructor %a can't be found.@}@,@,\ - @[- If it's defined in another module or file, bring it into scope by:@,\ - @[- Prefixing it with said module name:@ @{TheModule.%a@}@]@,\ - @[- Or specifying its type:@ @{let theValue: TheModule.theType = %a@}@]\ - @]@,\ - - @[Constructors and modules are both capitalized.@ Did you want the latter?@ Then instead of @{let foo = Bar@}, try @{module Foo = Bar@}.@]\ - @]" - Printtyp.longident lid - Printtyp.longident lid - Printtyp.longident lid; - spellcheck ppf fold_constructors env lid - | Unbound_label lid -> - (* modified *) - Format.fprintf ppf "@[\ - @{The record field %a can't be found.@}@,@,\ - If it's defined in another module or file, bring it into scope by:@,\ - @[- Prefixing it with said module name:@ @{TheModule.%a@}@]@,\ - @[- Or specifying its type:@ @{let theValue: TheModule.theType = {%a: VALUE}@}@]\ - @]" - Printtyp.longident lid - Printtyp.longident lid - Printtyp.longident lid; - spellcheck ppf fold_labels env lid; - | Unbound_class lid -> - fprintf ppf "Unbound class %a" longident lid; - spellcheck ppf fold_classs env lid; - | Unbound_modtype lid -> - fprintf ppf "Unbound module type %a" longident lid; - spellcheck ppf fold_modtypes env lid; - | Unbound_cltype lid -> - fprintf ppf "Unbound class type %a" longident lid; - spellcheck ppf fold_cltypes env lid; - | Ill_typed_functor_application lid -> - fprintf ppf "Ill-typed functor application %a" longident lid - | Illegal_reference_to_recursive_module -> - fprintf ppf "Illegal recursive module reference" - | Access_functor_as_structure lid -> - fprintf ppf "The module %a is a functor, not a structure" longident lid - | Apply_structure_as_functor lid -> - fprintf ppf "The module %a is a structure, not a functor" longident lid - | Cannot_scrape_alias(lid, p) -> - fprintf ppf - "The module %a is an alias for module %a, which is missing" - longident lid path p - | Opened_object nm -> - fprintf ppf - "Illegal open object type%a" - (fun ppf -> function - Some p -> fprintf ppf "@ %a" path p - | None -> fprintf ppf "") nm - | Not_an_object ty -> - Printtyp.reset_and_mark_loops ty; - fprintf ppf "@[The type %a@ is not an object type@]" - Printtyp.type_expr ty - -let () = - Location.register_error_of_exn - (function - | Error (loc, env, err) -> - Some (Location.error_of_printer loc (report_error env) err) - | Error_forward err -> - Some err - | _ -> - None - ) diff --git a/jscomp/ml/typetexp.mli b/jscomp/ml/typetexp.mli deleted file mode 100644 index 165c17d..0000000 --- a/jscomp/ml/typetexp.mli +++ /dev/null @@ -1,122 +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. *) -(* *) -(**************************************************************************) - -(* Typechecking of type expressions for the core language *) - -open Types - -val transl_simple_type: - Env.t -> bool -> Parsetree.core_type -> Typedtree.core_type -val transl_simple_type_univars: - Env.t -> Parsetree.core_type -> Typedtree.core_type -val transl_simple_type_delayed: - Env.t -> Parsetree.core_type -> Typedtree.core_type * (unit -> unit) - (* Translate a type, but leave type variables unbound. Returns - the type and a function that binds the type variable. *) -val transl_type_scheme: - Env.t -> Parsetree.core_type -> Typedtree.core_type -val reset_type_variables: unit -> unit -val type_variable: Location.t -> string -> type_expr -val transl_type_param: - Env.t -> Parsetree.core_type -> Typedtree.core_type - -type variable_context -val narrow: unit -> variable_context -val widen: variable_context -> unit - -exception Already_bound - -type error = - Unbound_type_variable of string - | Unbound_type_constructor of Longident.t - | Unbound_type_constructor_2 of Path.t - | Type_arity_mismatch of Longident.t * int * int - | Bound_type_variable of string - | Recursive_type - | Unbound_row_variable of Longident.t - | Type_mismatch of (type_expr * type_expr) list - | Alias_type_mismatch of (type_expr * type_expr) list - | Present_has_conjunction of string - | Present_has_no_type of string - | Constructor_mismatch of type_expr * type_expr - | Not_a_variant of type_expr - | Variant_tags of string * string - | Invalid_variable_name of string - | Cannot_quantify of string * type_expr - | Multiple_constraints_on_type of Longident.t - | Method_mismatch of string * type_expr * type_expr - | Unbound_value of Longident.t - | Unbound_constructor of Longident.t - | Unbound_label of Longident.t - | Unbound_module of Longident.t - | Unbound_class of Longident.t - | Unbound_modtype of Longident.t - | Unbound_cltype of Longident.t - | Ill_typed_functor_application of Longident.t - | Illegal_reference_to_recursive_module - | Access_functor_as_structure of Longident.t - | Apply_structure_as_functor of Longident.t - | Cannot_scrape_alias of Longident.t * Path.t - | Opened_object of Path.t option - | Not_an_object of type_expr - -exception Error of Location.t * Env.t * error - -val report_error: Env.t -> Format.formatter -> error -> unit - -(* Support for first-class modules. *) -val transl_modtype_longident: (* from Typemod *) - (Location.t -> Env.t -> Longident.t -> Path.t) ref -val transl_modtype: (* from Typemod *) - (Env.t -> Parsetree.module_type -> Typedtree.module_type) ref -val create_package_mty: - Location.t -> Env.t -> Parsetree.package_type -> - (Longident.t Asttypes.loc * Parsetree.core_type) list * - Parsetree.module_type - -val find_type: - Env.t -> Location.t -> Longident.t -> Path.t * type_declaration -val find_constructor: - Env.t -> Location.t -> Longident.t -> constructor_description -val find_all_constructors: - Env.t -> Location.t -> Longident.t -> - (constructor_description * (unit -> unit)) list -val find_label: - Env.t -> Location.t -> Longident.t -> label_description -val find_all_labels: - Env.t -> Location.t -> Longident.t -> - (label_description * (unit -> unit)) list -val find_value: - Env.t -> Location.t -> Longident.t -> Path.t * value_description -val find_class: - Env.t -> Location.t -> Longident.t -> Path.t * class_declaration -val find_module: - Env.t -> Location.t -> Longident.t -> Path.t * module_declaration -val lookup_module: - ?load:bool -> Env.t -> Location.t -> Longident.t -> Path.t -val find_modtype: - Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration -val find_class_type: - Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration - -val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a -val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a - - -val spellcheck: - Format.formatter -> - (('a -> 'a list -> 'a list) -> - Longident.t option -> 'b -> 'c list -> string list) -> - 'b -> Longident.t -> unit diff --git a/jscomp/ml/untypeast.ml b/jscomp/ml/untypeast.ml deleted file mode 100644 index 17203b0..0000000 --- a/jscomp/ml/untypeast.ml +++ /dev/null @@ -1,717 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 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. *) -(* *) -(**************************************************************************) - -open Longident -open Asttypes -open Parsetree -open Ast_helper - -module T = Typedtree - -type mapper = { - attribute: mapper -> T.attribute -> attribute; - attributes: mapper -> T.attribute list -> attribute list; - case: mapper -> T.case -> case; - cases: mapper -> T.case list -> case list; - class_signature: mapper -> T.class_signature -> class_signature; - class_type: mapper -> T.class_type -> class_type; - class_type_declaration: mapper -> T.class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> T.class_type_field -> class_type_field; - constructor_declaration: mapper -> T.constructor_declaration - -> constructor_declaration; - expr: mapper -> T.expression -> expression; - extension_constructor: mapper -> T.extension_constructor - -> extension_constructor; - include_declaration: mapper -> T.include_declaration -> include_declaration; - include_description: mapper -> T.include_description -> include_description; - label_declaration: mapper -> T.label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> T.module_binding -> module_binding; - module_declaration: mapper -> T.module_declaration -> module_declaration; - module_expr: mapper -> T.module_expr -> module_expr; - module_type: mapper -> T.module_type -> module_type; - module_type_declaration: - mapper -> T.module_type_declaration -> module_type_declaration; - package_type: mapper -> T.package_type -> package_type; - open_description: mapper -> T.open_description -> open_description; - pat: mapper -> T.pattern -> pattern; - row_field: mapper -> T.row_field -> row_field; - object_field: mapper -> T.object_field -> object_field; - signature: mapper -> T.signature -> signature; - signature_item: mapper -> T.signature_item -> signature_item; - structure: mapper -> T.structure -> structure; - structure_item: mapper -> T.structure_item -> structure_item; - typ: mapper -> T.core_type -> core_type; - type_declaration: mapper -> T.type_declaration -> type_declaration; - type_extension: mapper -> T.type_extension -> type_extension; - type_kind: mapper -> T.type_kind -> type_kind; - value_binding: mapper -> T.value_binding -> value_binding; - value_description: mapper -> T.value_description -> value_description; - with_constraint: - mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) - -> with_constraint; -} - -open T - -(* -Some notes: - - * For Pexp_function, we cannot go back to the exact original version - when there is a default argument, because the default argument is - translated in the typer. The code, if printed, will not be parsable because - new generated identifiers are not correct. - - * For Pexp_apply, it is unclear whether arguments are reordered, especially - when there are optional arguments. - -*) - - -(** Utility functions. *) - - -let map_opt f = function None -> None | Some e -> Some (f e) - -let rec lident_of_path = function - | Path.Pident id -> Longident.Lident (Ident.name id) - | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) - | Path.Papply (p1, p2) -> - Longident.Lapply (lident_of_path p1, lident_of_path p2) - -let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} - -(** Try a name [$name$0], check if it's free, if not, increment and repeat. *) -let fresh_name s env = - let rec aux i = - let name = s ^ string_of_int i in - try - let _ = Env.lookup_value (Lident name) env in - name - with - | Not_found -> aux (i+1) - in - aux 0 - -(** Mapping functions. *) - -let constant = function - | Const_char c -> Pconst_char c - | Const_string (s,d) -> Pconst_string (s,d) - | Const_int i -> Pconst_integer (string_of_int i, None) - | Const_int32 i -> Pconst_integer (Int32.to_string i, Some 'l') - | Const_int64 i -> Pconst_integer (Int64.to_string i, Some 'L') - | Const_bigint (sign, i) -> - Pconst_integer (Bigint_utils.to_string sign i, Some 'n') - | Const_float f -> Pconst_float (f,None) - -let attribute sub (s, p) = (map_loc sub s, p) -let attributes sub l = List.map (sub.attribute sub) l - -let structure sub str = - List.map (sub.structure_item sub) str.str_items - -let open_description sub od = - let loc = sub.location sub od.open_loc in - let attrs = sub.attributes sub od.open_attributes in - Opn.mk ~loc ~attrs - ~override:od.open_override - (map_loc sub od.open_txt) - -let structure_item sub item = - let loc = sub.location sub item.str_loc in - let desc = - match item.str_desc with - Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) - | Tstr_value (rec_flag, list) -> - Pstr_value (rec_flag, List.map (sub.value_binding sub) list) - | Tstr_primitive vd -> - Pstr_primitive (sub.value_description sub vd) - | Tstr_type (rec_flag, list) -> - Pstr_type (rec_flag, List.map (sub.type_declaration sub) list) - | Tstr_typext tyext -> - Pstr_typext (sub.type_extension sub tyext) - | Tstr_exception ext -> - Pstr_exception (sub.extension_constructor sub ext) - | Tstr_module mb -> - Pstr_module (sub.module_binding sub mb) - | Tstr_recmodule list -> - Pstr_recmodule (List.map (sub.module_binding sub) list) - | Tstr_modtype mtd -> - Pstr_modtype (sub.module_type_declaration sub mtd) - | Tstr_open od -> - Pstr_open (sub.open_description sub od) - | Tstr_class _list -> - Pstr_class () - | Tstr_class_type list -> - Pstr_class_type - (List.map - (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) - list) - | Tstr_include incl -> - Pstr_include (sub.include_declaration sub incl) - | Tstr_attribute x -> - Pstr_attribute x - in - Str.mk ~loc desc - -let value_description sub v = - let loc = sub.location sub v.val_loc in - let attrs = sub.attributes sub v.val_attributes in - Val.mk ~loc ~attrs - ~prim:v.val_prim - (map_loc sub v.val_name) - (sub.typ sub v.val_desc) - -let module_binding sub mb = - let loc = sub.location sub mb.mb_loc in - let attrs = sub.attributes sub mb.mb_attributes in - Mb.mk ~loc ~attrs - (map_loc sub mb.mb_name) - (sub.module_expr sub mb.mb_expr) - -let type_parameter sub (ct, v) = (sub.typ sub ct, v) - -let type_declaration sub decl = - let loc = sub.location sub decl.typ_loc in - let attrs = sub.attributes sub decl.typ_attributes in - Type.mk ~loc ~attrs - ~params:(List.map (type_parameter sub) decl.typ_params) - ~cstrs:( - List.map - (fun (ct1, ct2, loc) -> - (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) - decl.typ_cstrs) - ~kind:(sub.type_kind sub decl.typ_kind) - ~priv:decl.typ_private - ?manifest:(map_opt (sub.typ sub) decl.typ_manifest) - (map_loc sub decl.typ_name) - -let type_kind sub tk = match tk with - | Ttype_abstract -> Ptype_abstract - | Ttype_variant list -> - Ptype_variant (List.map (sub.constructor_declaration sub) list) - | Ttype_record list -> - Ptype_record (List.map (sub.label_declaration sub) list) - | Ttype_open -> Ptype_open - -let constructor_arguments sub = function - | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) - | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) - -let constructor_declaration sub cd = - let loc = sub.location sub cd.cd_loc in - let attrs = sub.attributes sub cd.cd_attributes in - Type.constructor ~loc ~attrs - ~args:(constructor_arguments sub cd.cd_args) - ?res:(map_opt (sub.typ sub) cd.cd_res) - (map_loc sub cd.cd_name) - -let label_declaration sub ld = - let loc = sub.location sub ld.ld_loc in - let attrs = sub.attributes sub ld.ld_attributes in - Type.field ~loc ~attrs - ~mut:ld.ld_mutable - (map_loc sub ld.ld_name) - (sub.typ sub ld.ld_type) - -let type_extension sub tyext = - let attrs = sub.attributes sub tyext.tyext_attributes in - Te.mk ~attrs - ~params:(List.map (type_parameter sub) tyext.tyext_params) - ~priv:tyext.tyext_private - (map_loc sub tyext.tyext_txt) - (List.map (sub.extension_constructor sub) tyext.tyext_constructors) - -let extension_constructor sub ext = - let loc = sub.location sub ext.ext_loc in - let attrs = sub.attributes sub ext.ext_attributes in - Te.constructor ~loc ~attrs - (map_loc sub ext.ext_name) - (match ext.ext_kind with - | Text_decl (args, ret) -> - Pext_decl (constructor_arguments sub args, - map_opt (sub.typ sub) ret) - | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) - ) - -let pattern sub pat = - let loc = sub.location sub pat.pat_loc in - (* todo: fix attributes on extras *) - let attrs = sub.attributes sub pat.pat_attributes in - let desc = - match pat with - { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> - Ppat_unpack name - | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> - Ppat_type (map_loc sub lid) - | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> - Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, - sub.typ sub ct) - | _ -> - match pat.pat_desc with - Tpat_any -> Ppat_any - | Tpat_var (id, name) -> - begin - match (Ident.name id).[0] with - 'A'..'Z' -> - Ppat_unpack name - | _ -> - Ppat_var name - end - - (* We transform (_ as x) in x if _ and x have the same location. - The compiler transforms (x:t) into (_ as x : t). - This avoids transforming a warning 27 into a 26. - *) - | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name) - when pat_loc = pat.pat_loc -> - Ppat_var name - - | Tpat_alias (pat, _id, name) -> - Ppat_alias (sub.pat sub pat, name) - | Tpat_constant cst -> Ppat_constant (constant cst) - | Tpat_tuple list -> - Ppat_tuple (List.map (sub.pat sub) list) - | Tpat_construct (lid, _, args) -> - Ppat_construct (map_loc sub lid, - (match args with - [] -> None - | [arg] -> Some (sub.pat sub arg) - | args -> - Some - (Pat.tuple ~loc - (List.map (sub.pat sub) args) - ) - )) - | Tpat_variant (label, pato, _) -> - Ppat_variant (label, map_opt (sub.pat sub) pato) - | Tpat_record (list, closed) -> - Ppat_record (List.map (fun (lid, _, pat) -> - map_loc sub lid, sub.pat sub pat) list, closed) - | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) - | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) - | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) - in - Pat.mk ~loc ~attrs desc - -let exp_extra sub (extra, loc, attrs) sexp = - let loc = sub.location sub loc in - let attrs = sub.attributes sub attrs in - let desc = - match extra with - Texp_coerce (cty1, cty2) -> - Pexp_coerce (sexp, - map_opt (sub.typ sub) cty1, - sub.typ sub cty2) - | Texp_constraint cty -> - Pexp_constraint (sexp, sub.typ sub cty) - | Texp_open (ovf, _path, lid, _) -> - Pexp_open (ovf, map_loc sub lid, sexp) - | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) - | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) - in - Exp.mk ~loc ~attrs desc - -let cases sub l = List.map (sub.case sub) l - -let case sub {c_lhs; c_guard; c_rhs} = - { - pc_lhs = sub.pat sub c_lhs; - pc_guard = map_opt (sub.expr sub) c_guard; - pc_rhs = sub.expr sub c_rhs; - } - -let value_binding sub vb = - let loc = sub.location sub vb.vb_loc in - let attrs = sub.attributes sub vb.vb_attributes in - Vb.mk ~loc ~attrs - (sub.pat sub vb.vb_pat) - (sub.expr sub vb.vb_expr) - -let expression sub exp = - let loc = sub.location sub exp.exp_loc in - let attrs = sub.attributes sub exp.exp_attributes in - let desc = - match exp.exp_desc with - Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) - | Texp_constant cst -> Pexp_constant (constant cst) - | Texp_let (rec_flag, list, exp) -> - Pexp_let (rec_flag, - List.map (sub.value_binding sub) list, - sub.expr sub exp) - - (* Pexp_function can't have a label, so we split in 3 cases. *) - (* One case, no guard: It's a fun. *) - | Texp_function { arg_label; cases = [{c_lhs=p; c_guard=None; c_rhs=e}]; - _ } -> - Pexp_fun (arg_label, None, sub.pat sub p, sub.expr sub e) - (* No label: it's a function. *) - | Texp_function { arg_label = Nolabel; cases; _; } -> - Pexp_function (sub.cases sub cases) - (* Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) - | Texp_function { arg_label = Labelled s | Optional s as label; cases; - _ } -> - let name = fresh_name s exp.exp_env in - Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, - Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) - (sub.cases sub cases)) - | Texp_apply (exp, list) -> - Pexp_apply (sub.expr sub exp, - List.fold_right (fun (label, expo) list -> - match expo with - None -> list - | Some exp -> (label, sub.expr sub exp) :: list - ) list []) - | Texp_match (exp, cases, exn_cases, _) -> - let merged_cases = sub.cases sub cases - @ List.map - (fun c -> - let uc = sub.case sub c in - let pat = { uc.pc_lhs - with ppat_desc = Ppat_exception uc.pc_lhs } - in - { uc with pc_lhs = pat }) - exn_cases - in - Pexp_match (sub.expr sub exp, merged_cases) - | Texp_try (exp, cases) -> - Pexp_try (sub.expr sub exp, sub.cases sub cases) - | Texp_tuple list -> - Pexp_tuple (List.map (sub.expr sub) list) - | Texp_construct (lid, _, args) -> - Pexp_construct (map_loc sub lid, - (match args with - [] -> None - | [ arg ] -> Some (sub.expr sub arg) - | args -> - Some - (Exp.tuple ~loc (List.map (sub.expr sub) args)) - )) - | Texp_variant (label, expo) -> - Pexp_variant (label, map_opt (sub.expr sub) expo) - | Texp_record { fields; extended_expression; _ } -> - let list = Array.fold_left (fun l -> function - | _, Kept _ -> l - | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) - [] fields - in - Pexp_record (list, map_opt (sub.expr sub) extended_expression) - | Texp_field (exp, lid, _label) -> - Pexp_field (sub.expr sub exp, map_loc sub lid) - | Texp_setfield (exp1, lid, _label, exp2) -> - Pexp_setfield (sub.expr sub exp1, map_loc sub lid, - sub.expr sub exp2) - | Texp_array list -> - Pexp_array (List.map (sub.expr sub) list) - | Texp_ifthenelse (exp1, exp2, expo) -> - Pexp_ifthenelse (sub.expr sub exp1, - sub.expr sub exp2, - map_opt (sub.expr sub) expo) - | Texp_sequence (exp1, exp2) -> - Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) - | Texp_while (exp1, exp2) -> - Pexp_while (sub.expr sub exp1, sub.expr sub exp2) - | Texp_for (_id, name, exp1, exp2, dir, exp3) -> - Pexp_for (name, - sub.expr sub exp1, sub.expr sub exp2, - dir, sub.expr sub exp3) - | Texp_send (exp, meth, _) -> - Pexp_send (sub.expr sub exp, match meth with - Tmeth_name name -> mkloc name loc) - | Texp_new _ - | Texp_instvar _ - | Texp_setinstvar _ - | Texp_override _ -> - assert false - | Texp_letmodule (_id, name, mexpr, exp) -> - Pexp_letmodule (name, sub.module_expr sub mexpr, - sub.expr sub exp) - | Texp_letexception (ext, exp) -> - Pexp_letexception (sub.extension_constructor sub ext, - sub.expr sub exp) - | Texp_assert exp -> Pexp_assert (sub.expr sub exp) - | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) - | Texp_object () -> - assert false - | Texp_pack (mexpr) -> - Pexp_pack (sub.module_expr sub mexpr) - | Texp_unreachable -> - Pexp_unreachable - | Texp_extension_constructor (lid, _) -> - Pexp_extension ({ txt = "ocaml.extension_constructor"; loc }, - PStr [ Str.eval ~loc - (Exp.construct ~loc (map_loc sub lid) None) - ]) - in - List.fold_right (exp_extra sub) exp.exp_extra - (Exp.mk ~loc ~attrs desc) - -let package_type sub pack = - (map_loc sub pack.pack_txt, - List.map (fun (s, ct) -> - (s, sub.typ sub ct)) pack.pack_fields) - -let module_type_declaration sub mtd = - let loc = sub.location sub mtd.mtd_loc in - let attrs = sub.attributes sub mtd.mtd_attributes in - Mtd.mk ~loc ~attrs - ?typ:(map_opt (sub.module_type sub) mtd.mtd_type) - (map_loc sub mtd.mtd_name) - -let signature sub sg = - List.map (sub.signature_item sub) sg.sig_items - -let signature_item sub item = - let loc = sub.location sub item.sig_loc in - let desc = - match item.sig_desc with - Tsig_value v -> - Psig_value (sub.value_description sub v) - | Tsig_type (rec_flag, list) -> - Psig_type (rec_flag, List.map (sub.type_declaration sub) list) - | Tsig_typext tyext -> - Psig_typext (sub.type_extension sub tyext) - | Tsig_exception ext -> - Psig_exception (sub.extension_constructor sub ext) - | Tsig_module md -> - Psig_module (sub.module_declaration sub md) - | Tsig_recmodule list -> - Psig_recmodule (List.map (sub.module_declaration sub) list) - | Tsig_modtype mtd -> - Psig_modtype (sub.module_type_declaration sub mtd) - | Tsig_open od -> - Psig_open (sub.open_description sub od) - | Tsig_include incl -> - Psig_include (sub.include_description sub incl) - | Tsig_class () -> - Psig_class () - | Tsig_class_type list -> - Psig_class_type (List.map (sub.class_type_declaration sub) list) - | Tsig_attribute x -> - Psig_attribute x - in - Sig.mk ~loc desc - -let module_declaration sub md = - let loc = sub.location sub md.md_loc in - let attrs = sub.attributes sub md.md_attributes in - Md.mk ~loc ~attrs - (map_loc sub md.md_name) - (sub.module_type sub md.md_type) - -let include_infos f sub incl = - let loc = sub.location sub incl.incl_loc in - let attrs = sub.attributes sub incl.incl_attributes in - Incl.mk ~loc ~attrs - (f sub incl.incl_mod) - -let include_declaration sub = include_infos sub.module_expr sub -let include_description sub = include_infos sub.module_type sub - -let class_infos f sub ci = - let loc = sub.location sub ci.ci_loc in - let attrs = sub.attributes sub ci.ci_attributes in - Ci.mk ~loc ~attrs - ~virt:ci.ci_virt - ~params:(List.map (type_parameter sub) ci.ci_params) - (map_loc sub ci.ci_id_name) - (f sub ci.ci_expr) - -let class_type_declaration sub = class_infos sub.class_type sub - -let module_type sub mty = - let loc = sub.location sub mty.mty_loc in - let attrs = sub.attributes sub mty.mty_attributes in - let desc = match mty.mty_desc with - Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) - | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) - | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) - | Tmty_functor (_id, name, mtype1, mtype2) -> - Pmty_functor (name, map_opt (sub.module_type sub) mtype1, - sub.module_type sub mtype2) - | Tmty_with (mtype, list) -> - Pmty_with (sub.module_type sub mtype, - List.map (sub.with_constraint sub) list) - | Tmty_typeof mexpr -> - Pmty_typeof (sub.module_expr sub mexpr) - in - Mty.mk ~loc ~attrs desc - -let with_constraint sub (_path, lid, cstr) = - match cstr with - | Twith_type decl -> - Pwith_type (map_loc sub lid, sub.type_declaration sub decl) - | Twith_module (_path, lid2) -> - Pwith_module (map_loc sub lid, map_loc sub lid2) - | Twith_typesubst decl -> - Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) - | Twith_modsubst (_path, lid2) -> - Pwith_modsubst (map_loc sub lid, map_loc sub lid2) - -let module_expr sub mexpr = - let loc = sub.location sub mexpr.mod_loc in - let attrs = sub.attributes sub mexpr.mod_attributes in - match mexpr.mod_desc with - Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> - sub.module_expr sub m - | _ -> - let desc = match mexpr.mod_desc with - Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) - | Tmod_structure st -> Pmod_structure (sub.structure sub st) - | Tmod_functor (_id, name, mtype, mexpr) -> - Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype, - sub.module_expr sub mexpr) - | Tmod_apply (mexp1, mexp2, _) -> - Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - Pmod_constraint (sub.module_expr sub mexpr, - sub.module_type sub mtype) - | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> - assert false - | Tmod_unpack (exp, _pack) -> - Pmod_unpack (sub.expr sub exp) - (* TODO , sub.package_type sub pack) *) - in - Mod.mk ~loc ~attrs desc - - - -let class_type sub ct = - let loc = sub.location sub ct.cltyp_loc in - let attrs = sub.attributes sub ct.cltyp_attributes in - let desc = match ct.cltyp_desc with - Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) - | Tcty_constr (_path, lid, list) -> - Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) - | Tcty_arrow (label, ct, cl) -> - Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) - | Tcty_open (ovf, _p, lid, _env, e) -> - Pcty_open (ovf, lid, sub.class_type sub e) - in - Cty.mk ~loc ~attrs desc - -let class_signature sub cs = - { - pcsig_self = sub.typ sub cs.csig_self; - pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields; - } - -let class_type_field sub ctf = - let loc = sub.location sub ctf.ctf_loc in - let attrs = sub.attributes sub ctf.ctf_attributes in - let desc = match ctf.ctf_desc with - Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) - | Tctf_val (s, mut, virt, ct) -> - Pctf_val (mkloc s loc, mut, virt, sub.typ sub ct) - | Tctf_method (s, priv, virt, ct) -> - Pctf_method (mkloc s loc, priv, virt, sub.typ sub ct) - | Tctf_constraint (ct1, ct2) -> - Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) - | Tctf_attribute x -> Pctf_attribute x - in - Ctf.mk ~loc ~attrs desc - -let core_type sub ct = - let loc = sub.location sub ct.ctyp_loc in - let attrs = sub.attributes sub ct.ctyp_attributes in - let desc = match ct.ctyp_desc with - Ttyp_any -> Ptyp_any - | Ttyp_var s -> Ptyp_var s - | Ttyp_arrow (label, ct1, ct2) -> - Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) - | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) - | Ttyp_constr (_path, lid, list) -> - Ptyp_constr (map_loc sub lid, - List.map (sub.typ sub) list) - | Ttyp_object (list, o) -> - Ptyp_object - (List.map (sub.object_field sub) list, o) - | Ttyp_class (_path, lid, list) -> - Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) - | Ttyp_alias (ct, s) -> - Ptyp_alias (sub.typ sub ct, s) - | Ttyp_variant (list, bool, labels) -> - Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) - | Ttyp_poly (list, ct) -> - let list = List.map (fun v -> mkloc v loc) list in - Ptyp_poly (list, sub.typ sub ct) - | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) - in - Typ.mk ~loc ~attrs desc - - -let row_field sub rf = - match rf with - Ttag (label, attrs, bool, list) -> - Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list) - | Tinherit ct -> Rinherit (sub.typ sub ct) - -let object_field sub ofield = - match ofield with - OTtag (label, attrs, ct) -> - Otag (label, sub.attributes sub attrs, sub.typ sub ct) - | OTinherit ct -> Oinherit (sub.typ sub ct) - - - -let location _sub l = l - -let default_mapper = - { - attribute = attribute ; - attributes = attributes ; - structure = structure; - structure_item = structure_item; - module_expr = module_expr; - signature = signature; - signature_item = signature_item; - module_type = module_type; - with_constraint = with_constraint; - class_type = class_type; - class_type_field = class_type_field; - class_signature = class_signature; - class_type_declaration = class_type_declaration; - type_declaration = type_declaration; - type_kind = type_kind; - typ = core_type; - type_extension = type_extension; - extension_constructor = extension_constructor; - value_description = value_description; - pat = pattern; - expr = expression; - module_declaration = module_declaration; - module_type_declaration = module_type_declaration; - module_binding = module_binding; - package_type = package_type ; - open_description = open_description; - include_description = include_description; - include_declaration = include_declaration; - value_binding = value_binding; - constructor_declaration = constructor_declaration; - label_declaration = label_declaration; - cases = cases; - case = case; - location = location; - row_field = row_field ; - object_field = object_field ; - } - -let untype_structure ?(mapper=default_mapper) structure = - mapper.structure mapper structure - -let untype_signature ?(mapper=default_mapper) signature = - mapper.signature mapper signature diff --git a/jscomp/ml/untypeast.mli b/jscomp/ml/untypeast.mli deleted file mode 100644 index d6bfdd0..0000000 --- a/jscomp/ml/untypeast.mli +++ /dev/null @@ -1,74 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Thomas Gazagnaire (OCamlPro), Fabrice Le Fessant (INRIA Saclay) *) -(* *) -(* Copyright 2007 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. *) -(* *) -(**************************************************************************) - -open Parsetree - -val lident_of_path : Path.t -> Longident.t - -type mapper = { - attribute: mapper -> Typedtree.attribute -> attribute; - attributes: mapper -> Typedtree.attribute list -> attribute list; - case: mapper -> Typedtree.case -> case; - cases: mapper -> Typedtree.case list -> case list; - class_signature: mapper -> Typedtree.class_signature -> class_signature; - class_type: mapper -> Typedtree.class_type -> class_type; - class_type_declaration: mapper -> Typedtree.class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; - constructor_declaration: mapper -> Typedtree.constructor_declaration - -> constructor_declaration; - expr: mapper -> Typedtree.expression -> expression; - extension_constructor: mapper -> Typedtree.extension_constructor - -> extension_constructor; - include_declaration: - mapper -> Typedtree.include_declaration -> include_declaration; - include_description: - mapper -> Typedtree.include_description -> include_description; - label_declaration: - mapper -> Typedtree.label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> Typedtree.module_binding -> module_binding; - module_declaration: - mapper -> Typedtree.module_declaration -> module_declaration; - module_expr: mapper -> Typedtree.module_expr -> module_expr; - module_type: mapper -> Typedtree.module_type -> module_type; - module_type_declaration: - mapper -> Typedtree.module_type_declaration -> module_type_declaration; - package_type: mapper -> Typedtree.package_type -> package_type; - open_description: mapper -> Typedtree.open_description -> open_description; - pat: mapper -> Typedtree.pattern -> pattern; - row_field: mapper -> Typedtree.row_field -> row_field; - object_field: mapper -> Typedtree.object_field -> object_field; - signature: mapper -> Typedtree.signature -> signature; - signature_item: mapper -> Typedtree.signature_item -> signature_item; - structure: mapper -> Typedtree.structure -> structure; - structure_item: mapper -> Typedtree.structure_item -> structure_item; - typ: mapper -> Typedtree.core_type -> core_type; - type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; - type_extension: mapper -> Typedtree.type_extension -> type_extension; - type_kind: mapper -> Typedtree.type_kind -> type_kind; - value_binding: mapper -> Typedtree.value_binding -> value_binding; - value_description: mapper -> Typedtree.value_description -> value_description; - with_constraint: - mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) - -> with_constraint; -} - -val default_mapper : mapper - -val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure -val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature - -val constant : Asttypes.constant -> Parsetree.constant diff --git a/jscomp/ml/variant_coercion.ml b/jscomp/ml/variant_coercion.ml deleted file mode 100644 index e2b272d..0000000 --- a/jscomp/ml/variant_coercion.ml +++ /dev/null @@ -1,153 +0,0 @@ -(* TODO: Improve error messages? Say why we can't coerce. *) - -(* Right now we only allow coercing to primitives string/int/float *) -let can_coerce_primitive (path : Path.t) = - Path.same path Predef.path_string - || Path.same path Predef.path_int - || Path.same path Predef.path_float - || Path.same path Predef.path_bigint - -let check_paths_same p1 p2 target_path = - Path.same p1 target_path && Path.same p2 target_path - -let variant_has_catch_all_case (constructors : Types.constructor_declaration list) path_is_same = - let has_catch_all_string_case (c : Types.constructor_declaration) = - let args = c.cd_args in - match args with - | Cstr_tuple [{desc = Tconstr (p, [], _)}] -> - path_is_same p - | _ -> false - in - - constructors |> List.exists has_catch_all_string_case - -let variant_has_relevant_primitive_catch_all (constructors : Types.constructor_declaration list) = - variant_has_catch_all_case constructors can_coerce_primitive - -(* Checks if every case of the variant has the same runtime representation as the target type. *) -let variant_has_same_runtime_representation_as_target ~(targetPath : Path.t) - ~unboxed (constructors : Types.constructor_declaration list) = - (* Helper function to check if a constructor has the same runtime representation as the target type *) - let has_same_runtime_representation (c : Types.constructor_declaration) = - let args = c.cd_args in - let asPayload = Ast_untagged_variants.process_tag_type c.cd_attributes in - - match args with - | Cstr_tuple [{desc = Tconstr (p, [], _)}] when unboxed -> - let path_same = check_paths_same p targetPath in - (* unboxed String(string) :> string *) - path_same Predef.path_string - || (* unboxed Number(float) :> float *) - path_same Predef.path_float - || (* unboxed BigInt(bigint) :> bigint *) - path_same Predef.path_bigint - | Cstr_tuple [] -> ( - (* Check that @as payloads match with the target path to coerce to. - No @as means the default encoding, which is string *) - match asPayload with - | None | Some (String _) -> Path.same targetPath Predef.path_string - | Some (Int _) -> Path.same targetPath Predef.path_int - | Some (Float _) -> Path.same targetPath Predef.path_float - | Some (BigInt _) -> Path.same targetPath Predef.path_bigint - | Some (Null | Undefined | Bool _ | Untagged _) -> false) - | _ -> false - in - - List.for_all has_same_runtime_representation constructors - -let can_try_coerce_variant_to_primitive - ((_, p, typedecl) : Path.t * Path.t * Types.type_declaration) = - match typedecl with - | {type_kind = Type_variant constructors; type_params = []; type_attributes} - when Path.name p <> "bool" -> - (* bool is represented as a variant internally, so we need to account for that *) - Some (constructors, type_attributes |> Ast_untagged_variants.has_untagged) - | _ -> None - -let can_try_coerce_variant_to_primitive_opt p = - match p with - | None -> None - | Some p -> can_try_coerce_variant_to_primitive p - -let variant_representation_matches (c1_attrs : Parsetree.attributes) - (c2_attrs : Parsetree.attributes) = - match - ( Ast_untagged_variants.process_tag_type c1_attrs, - Ast_untagged_variants.process_tag_type c2_attrs ) - with - | None, None -> true - | Some s1, Some s2 when s1 = s2 -> true - | _ -> false - -type variant_configuration_error = - | Untagged of {left_is_unboxed: bool} - | TagName of {left_tag: string option; right_tag: string option} - -type variant_error = - | VariantError of { - left_loc: Location.t; - right_loc: Location.t; - error: variant_configuration_error; - is_spread_context: bool; - } - -exception VariantConfigurationError of variant_error - -let variant_configuration_can_be_coerced (a1 : Parsetree.attributes) - (a2 : Parsetree.attributes) = - let unboxed = - match - ( Ast_untagged_variants.process_untagged a1, - Ast_untagged_variants.process_untagged a2 ) - with - | true, true | false, false -> true - | _ -> false - in - if not unboxed then false - else - let tag = - match - ( Ast_untagged_variants.process_tag_name a1, - Ast_untagged_variants.process_tag_name a2 ) - with - | Some tag1, Some tag2 when tag1 = tag2 -> true - | None, None -> true - | _ -> false - in - if not tag then false else true - -let variant_configuration_can_be_coerced_raises ~is_spread_context ~left_loc - ~right_loc ~(left_attributes : Parsetree.attributes) - ~(right_attributes : Parsetree.attributes) = - (match - ( Ast_untagged_variants.process_untagged left_attributes, - Ast_untagged_variants.process_untagged right_attributes ) - with - | true, true | false, false -> () - | left, _right -> - raise - (VariantConfigurationError - (VariantError - { - is_spread_context; - left_loc; - right_loc; - error = Untagged {left_is_unboxed = left}; - }))); - - match - ( Ast_untagged_variants.process_tag_name left_attributes, - Ast_untagged_variants.process_tag_name right_attributes ) - with - | Some host_tag, Some spread_tag when host_tag = spread_tag -> () - | None, None -> () - | left_tag, right_tag -> - raise - (VariantConfigurationError - (VariantError - { - is_spread_context; - left_loc; - right_loc; - error = TagName {left_tag; right_tag}; - })) diff --git a/jscomp/others/.depend b/jscomp/others/.depend deleted file mode 100644 index 30f49d6..0000000 --- a/jscomp/others/.depend +++ /dev/null @@ -1,162 +0,0 @@ -node_path.cmj : -node_fs.cmj : node.cmj js_string.cmj -node_process.cmj : js_dict.cmj node_process.cmi -node_module.cmj : node.cmj js_dict.cmj -js_array.cmj : -js_string.cmj : js_re.cmi js_array.cmj -js_int.cmj : -js_float.cmj : -js_exn.cmj : js_exn.cmi -js_null.cmj : js_exn.cmj js_null.cmi -js_undefined.cmj : js_exn.cmj js_undefined.cmi -js_null_undefined.cmj : js_null_undefined.cmi -js_typed_array.cmj : -node_buffer.cmj : node.cmj -js_types.cmj : js_null.cmj js_types.cmi -js_json.cmj : js_types.cmj js_string.cmj js_dict.cmj js_array.cmj \ - js_json.cmi -js_obj.cmj : -js_vector.cmj : js_array.cmj js_vector.cmi -js_list.cmj : js_vector.cmj js_list.cmi -js_option.cmj : js_exn.cmj js_option.cmi -js_console.cmj : -js_result.cmj : js_result.cmi -js_mapperRt.cmj : js_exn.cmj js_array.cmj js_mapperRt.cmi -belt_Array.cmj : js_math.cmj belt_Array.cmi -belt_internalAVLset.cmj : belt_SortArray.cmj belt_Id.cmj belt_Array.cmj \ - belt_internalAVLset.cmi -belt_internalAVLtree.cmj : belt_SortArray.cmj belt_Id.cmj belt_Array.cmj \ - belt_internalAVLtree.cmi -belt_List.cmj : belt_SortArray.cmj belt_Array.cmj belt_List.cmi -belt_SortArray.cmj : belt_SortArrayString.cmj belt_SortArrayInt.cmj \ - belt_Array.cmj belt_SortArray.cmi -belt_SortArrayInt.cmj : belt_Array.cmj belt_SortArrayInt.cmi -belt_SortArrayString.cmj : belt_Array.cmj belt_SortArrayString.cmi -belt_Range.cmj : belt_Range.cmi -belt_internalBucketsType.cmj : belt_Array.cmj belt_internalBucketsType.cmi -belt_internalSetBuckets.cmj : belt_internalBucketsType.cmj belt_Array.cmj \ - belt_internalSetBuckets.cmi -belt_internalBuckets.cmj : belt_internalBucketsType.cmj belt_Array.cmj \ - belt_internalBuckets.cmi -belt_HashMap.cmj : belt_internalBucketsType.cmj belt_internalBuckets.cmj \ - belt_Id.cmj belt_HashMapString.cmj belt_HashMapInt.cmj belt_Array.cmj \ - belt_HashMap.cmi -belt_HashSet.cmj : belt_internalSetBuckets.cmj belt_internalBucketsType.cmj \ - belt_Id.cmj belt_HashSetString.cmj belt_HashSetInt.cmj belt_Array.cmj \ - belt_HashSet.cmi -belt_HashSetString.cmj : belt_internalSetBuckets.cmj \ - belt_internalBucketsType.cmj belt_Array.cmj belt_HashSetString.cmi -belt_HashSetInt.cmj : belt_internalSetBuckets.cmj \ - belt_internalBucketsType.cmj belt_Array.cmj belt_HashSetInt.cmi -belt_Id.cmj : belt_Id.cmi -belt_MapDict.cmj : belt_internalAVLtree.cmj belt_Id.cmj belt_Array.cmj \ - belt_MapDict.cmi -belt_SetDict.cmj : belt_internalAVLset.cmj belt_Id.cmj belt_Array.cmj \ - belt_SetDict.cmi -belt_Map.cmj : belt_MapString.cmj belt_MapInt.cmj belt_MapDict.cmj \ - belt_Id.cmj belt_Array.cmj belt_Map.cmi -belt_internalMapInt.cmj : belt_internalAVLtree.cmj belt_SortArray.cmj \ - belt_Array.cmj -belt_internalMapString.cmj : belt_internalAVLtree.cmj belt_SortArray.cmj \ - belt_Array.cmj -belt_MapString.cmj : belt_internalMapString.cmj belt_internalAVLtree.cmj \ - belt_Array.cmj belt_MapString.cmi -belt_MapInt.cmj : belt_internalMapInt.cmj belt_internalAVLtree.cmj \ - belt_Array.cmj belt_MapInt.cmi -belt_Option.cmj : belt_Option.cmi -belt_Result.cmj : belt_Result.cmi -belt_Set.cmj : belt_SetString.cmj belt_SetInt.cmj belt_SetDict.cmj \ - belt_Id.cmj belt_Array.cmj belt_Set.cmi -belt_MutableSet.cmj : belt_internalAVLset.cmj belt_SortArray.cmj \ - belt_MutableSetString.cmj belt_MutableSetInt.cmj belt_Id.cmj \ - belt_Array.cmj belt_MutableSet.cmi -belt_MutableSetInt.cmj : belt_internalSetInt.cmj belt_internalAVLset.cmj \ - belt_SortArrayInt.cmj belt_Array.cmj belt_MutableSetInt.cmi -belt_MutableSetString.cmj : belt_internalSetString.cmj \ - belt_internalAVLset.cmj belt_SortArrayString.cmj belt_Array.cmj \ - belt_MutableSetString.cmi -belt_MutableMap.cmj : belt_internalAVLtree.cmj belt_MutableMapString.cmj \ - belt_MutableMapInt.cmj belt_Id.cmj belt_Array.cmj belt_MutableMap.cmi -belt_MutableMapInt.cmj : belt_internalMapInt.cmj belt_internalAVLtree.cmj \ - belt_Array.cmj belt_MutableMapInt.cmi -belt_MutableMapString.cmj : belt_internalMapString.cmj \ - belt_internalAVLtree.cmj belt_Array.cmj belt_MutableMapString.cmi -belt_internalSetInt.cmj : belt_internalAVLset.cmj belt_SortArrayInt.cmj \ - belt_Array.cmj -belt_internalSetString.cmj : belt_internalAVLset.cmj \ - belt_SortArrayString.cmj belt_Array.cmj -belt_SetInt.cmj : belt_internalSetInt.cmj belt_internalAVLset.cmj \ - belt_Array.cmj belt_SetInt.cmi -belt_SetString.cmj : belt_internalSetString.cmj belt_internalAVLset.cmj \ - belt_Array.cmj belt_SetString.cmi -belt_MutableStack.cmj : js_null.cmj belt_MutableStack.cmi -belt_MutableQueue.cmj : js_null.cmj belt_Array.cmj belt_MutableQueue.cmi -node_child_process.cmj : node.cmj -js_math.cmj : js_int.cmj -js_dict.cmj : js_array.cmj js_dict.cmi -js_date.cmj : -js_global.cmj : -js_cast.cmj : js_cast.cmi -js_promise.cmj : -belt_HashMapInt.cmj : belt_internalBucketsType.cmj belt_internalBuckets.cmj \ - belt_Array.cmj belt_HashMapInt.cmi -belt_HashMapString.cmj : belt_internalBucketsType.cmj \ - belt_internalBuckets.cmj belt_Array.cmj belt_HashMapString.cmi -belt_Debug.cmj : -node_process.cmi : js_dict.cmi -js_exn.cmi : -js_re.cmi : -js_null.cmi : -js_undefined.cmi : -js_null_undefined.cmi : -js_types.cmi : -js_json.cmi : js_types.cmi js_string.cmj js_null.cmi js_dict.cmi -js_vector.cmi : -js_list.cmi : js_vector.cmi -js_option.cmi : -js_result.cmi : -js_mapperRt.cmi : -belt_Array.cmi : -belt_internalAVLset.cmi : belt_Id.cmi -belt_internalAVLtree.cmi : belt_Id.cmi -belt_List.cmi : -belt_SortArray.cmi : belt_SortArrayString.cmi belt_SortArrayInt.cmi -belt_SortArrayInt.cmi : -belt_SortArrayString.cmi : -belt_Range.cmi : -belt_internalBucketsType.cmi : -belt_internalSetBuckets.cmi : belt_internalBucketsType.cmi -belt_internalBuckets.cmi : belt_internalBucketsType.cmi -belt_HashMap.cmi : belt_Id.cmi belt_HashMapString.cmi belt_HashMapInt.cmi -belt_HashSet.cmi : belt_Id.cmi belt_HashSetString.cmi belt_HashSetInt.cmi -belt_HashSetString.cmi : -belt_HashSetInt.cmi : -belt_Id.cmi : -belt_MapDict.cmi : belt_Id.cmi -belt_SetDict.cmi : belt_Id.cmi -belt_Map.cmi : belt_MapString.cmi belt_MapInt.cmi belt_MapDict.cmi \ - belt_Id.cmi -belt_MapString.cmi : -belt_MapInt.cmi : -belt_Option.cmi : -belt_Result.cmi : -belt_Set.cmi : belt_SetString.cmi belt_SetInt.cmi belt_SetDict.cmi \ - belt_Id.cmi -belt_MutableSet.cmi : belt_MutableSetString.cmi belt_MutableSetInt.cmi \ - belt_Id.cmi -belt_MutableSetInt.cmi : -belt_MutableSetString.cmi : -belt_MutableMap.cmi : belt_MutableMapString.cmi belt_MutableMapInt.cmi \ - belt_Id.cmi -belt_MutableMapInt.cmi : -belt_MutableMapString.cmi : -belt_SetInt.cmi : -belt_SetString.cmi : -belt_MutableStack.cmi : -belt_MutableQueue.cmi : -js_dict.cmi : -js_cast.cmi : -dom.cmi : dom_storage.cmi -dom_storage.cmi : -belt_HashMapInt.cmi : -belt_HashMapString.cmi : diff --git a/jscomp/others/Design.md b/jscomp/others/Design.md deleted file mode 100644 index 0447c3e..0000000 --- a/jscomp/others/Design.md +++ /dev/null @@ -1,54 +0,0 @@ - - - - -hierachy - -# set -## bs_internalAVLset (basic module with rotation) - - methods in this moudle could be shared by (at least 2 of them) - - fuctional set, functional specialized set - mutable set, mutable specialized set. - - for example, [mem0] could be shared by functional/mutable poly set - - -## bs_Set - functional poly set (depends on bs_internalAVLset) - -## intenral_set.cppo.ml -## bs_intenralSetInt -## bs_internalSetString - - methods could be shared by funcitional/imperative specialized set. - This intermediate module is created since we want to share methods - like [findOpt], [cmp] - -## set.cppo.ml -## bs_SetInt -## bs_SetString - - - -## setm.cpp.ml -## bs_SetIntM -## bs_SetStringM - -# map -## bs_internalAVLtree (basic module with rotation) - -## bs_Map - -## internal_map.cpp.ml -## bs_internalMapInt -## bs_internalMapString - -## map.cppo.ml -## bs_MapInt -## bs_MapString - -## mapm.cppo.ml -## bs_MapIntM -## bs_MapStringM \ No newline at end of file diff --git a/jscomp/others/README.md b/jscomp/others/README.md deleted file mode 100644 index cb5a854..0000000 --- a/jscomp/others/README.md +++ /dev/null @@ -1,32 +0,0 @@ -Belt is a data structures and utilities library that ships with ReScript and bsb-native, optimized for the web. - -```ocaml -let a = Belt.Array.make 10 0 -let b = Belt.Array.map a (fun x -> x + 1) - -module Comparator = Belt.Id.MakeComparable(struct - type t = int - let cmp = Pervasives.compare -end) - -let c = Belt.Map.make ~id:(module Comparator) - -let d = Belt.Map.set c 10 "Hello" -let e = Belt.Map.set d 11 "World!" - -let _ = - match Belt.Map.get e 11 with - | None -> print_endline "Not possible, I'm pretty sure!" - | Some world -> print_endline ("Hello " ^ world) - -let _ = - match Belt.Map.get d 11 with - | None -> print_endline "Maps are immutable" - | _ -> print_endline "I will never print!" -``` - -## Contributing - -You'll need to build `bspp.exe` that is inside `../lib` by simply running `make -C ../lib bspp.exe`. - -Then you can recompile all of belt to JS by running `make all`. diff --git a/jscomp/others/belt.res b/jscomp/others/belt.res deleted file mode 100644 index c97d77f..0000000 --- a/jscomp/others/belt.res +++ /dev/null @@ -1,361 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** The ReScript standard library. - -Belt is currently mostly covering collection types. It has no string or date functions yet, although Belt.String is in the works. In the meantime, use [Js.String](js/string) for string functions and [Js.Date](js/date) for date functions. - -## Motivation - -Belt provides: - -- The **highest quality** immutable data structures in JavaScript. -- Safety by default: A Belt function will never throw exceptions, unless it is - indicated explicitly in the function name (suffix "Exn"). -- Better performance and smaller code size running on the JS platform. -- Ready for [Tree Shaking](https://webpack.js.org/guides/tree-shaking/). - -## Usage - -To use modules from Belt, either refer to them by their fully qualified name (`Belt.List`, `Belt.Array` etc.) or open the `Belt` module by putting - -## Examples - -```rescript -open Belt -``` - -at the top of your source files. After opening Belt this way, `Array` will refer to `Belt.Array`, `List` will refer to `Belt.List` etc. in the subsequent code. - -If you want to open Belt globally for all files in your project instead, you can put - -```json -{ - "bsc-flags": ["-open Belt"] -} -``` - -into your `bsconfig.json`. - -**Note**: this is the **only** `open` we encourage. - -Example usage: - -## Examples - -```rescript -let someNumbers = [1, 1, 4, 2, 3, 6, 3, 4, 2] - -let greaterThan2UniqueAndSorted = - someNumbers - ->Belt.Array.keep(x => x > 2) - // convert to and from set to make values unique - ->Belt.Set.Int.fromArray - ->Belt.Set.Int.toArray // output is already sorted - -Js.log2("result", greaterThan2UniqueAndSorted) -``` - -## Curried vs. Uncurried Callbacks - -For functions taking a callback parameter, there are usually two versions -available: - -- curried (no suffix) -- uncurried (suffixed with `U`) - -E.g.: - -## Examples - -```rescript -let forEach: (t<'a>, 'a => unit) => unit - -let forEachU: (t<'a>, (. 'a) => unit) => unit -``` - -The uncurried version will be faster in some cases, but for simplicity we recommend to stick with the curried version unless you need the extra performance. - -The two versions can be invoked as follows: - -## Examples - -```rescript -["a", "b", "c"]->Belt.Array.forEach(x => Js.log(x)) - -["a", "b", "c"]->Belt.Array.forEachU((. x) => Js.log(x)) -``` - -## Specialized Collections - -For collections types like set or map, Belt provides both a generic module as well as specialized, more efficient implementations for string and int keys. - -For example, Belt has the following set modules: - -- [Belt.Set](belt/set) -- [Belt.Set.Int](belt/set/int) -- [Belt.Set.String](belt/set/string) - -## Implementation Details - -### Array access runtime safety - -One common confusion comes from the way Belt handles array access. It differs from than the default standard library's. - -## Examples - -```rescript -let letters = ["a", "b", "c"] -let a = letters[0] // a == "a" -let capitalA = Js.String.toUpperCase(a) -let k = letters[10] // Raises an exception! The 10th index doesn't exist. -``` - -Because Belt avoids exceptions and returns `options` instead, this code behaves differently: - -## Examples - -```rescript -open Belt -let letters = ["a", "b", "c"] -let a = letters[0] // a == Some("a") -let captialA = Js.String.toUpperCase(a) // Type error! This code will not compile. -let k = letters[10] // k == None -``` - -Although we've fixed the problem where `k` raises an exception, we now have a type error when trying to capitalize `a`. There are a few things going on here: - -- Reason transforms array index access to the function `Array.get`. So `letters[0]` is the same as `Array.get(letters, 0)`. -- The compiler uses whichever `Array` module is in scope. If you `open Belt`, then it uses `Belt.Array`. -- `Belt.Array.get` returns values wrapped in options, so `letters[0] == Some("a")`. - -Fortunately, this is easy to fix: - -## Examples - -```rescript -open Belt -let letters = ["a", "b", "c"] -let a = letters[0] - -// Use a switch statement: -let capitalA = - switch a { - | Some(a) => Some(Js.String.toUpperCase(a)) - | None => None - } - -let k = letters[10] // k == None -``` - -With that little bit of tweaking, our code now compiles successfully and is 100% free of runtime errors! - -### A Special Encoding for Collection Safety - -When we create a collection library for a custom data type we need a way to provide a comparator function. Take Set for example, suppose its element type is a pair of ints, it needs a custom compare function that takes two tuples and returns their order. The Set could not just be typed as Set.t (int \* int) , its customized compare function needs to manifest itself in the signature, otherwise, if the user creates another customized compare function, the two collection could mix which would result in runtime error. - -We use a phantom type to solve the problem: - -## Examples - -```rescript -module Comparable1 = - Belt.Id.MakeComparable( - { - type t = (int, int) - let cmp = ((a0, a1), (b0, b1)) => - switch Pervasives.compare(a0, b0) { - | 0 => Pervasives.compare(a1, b1) - | c => c - } - } - ) - -let mySet1 = Belt.Set.make(~id=module(Comparable1)) - -module Comparable2 = - Belt.Id.MakeComparable( - { - type t = (int, int) - let cmp = ((a0, a1), (b0, b1)) => - switch Pervasives.compare(a0, b0) { - | 0 => Pervasives.compare(a1, b1) - | c => c - } - } - ) - -let mySet2 = Belt.Set.make(~id=module(Comparable2)) -``` - -Here, the compiler would infer `mySet1` and `mySet2` having different type, so e.g. a `merge` operation that tries to merge these two sets will correctly fail. - -## Examples - -```rescript -let mySet1: t<(int, int), Comparable1.identity> -let mySet2: t<(int, int), Comparable2.identity> -``` - -`Comparable1.identity` and `Comparable2.identity` are not the same using our encoding scheme. - -*/ - -@@warning("-49") - -/** [`Belt.Id`]() - - Provide utilities to create identified comparators or hashes for - data structures used below. - - It create a unique identifier per module of - functions so that different data structures with slightly different - comparison functions won't mix -*/ -module Id = Belt_Id - -/** [`Belt.Array`]() - - **mutable array**: Utilities functions -*/ -module Array = Belt_Array - -/** [`Belt.SortArray`]() - - The top level provides some generic sort related utilities. - - It also has two specialized inner modules - [`Belt.SortArray.Int`]() and [`Belt.SortArray.String`]() -*/ -module SortArray = Belt_SortArray - -/** [`Belt.MutableQueue`]() - - An FIFO(first in first out) queue data structure -*/ -module MutableQueue = Belt_MutableQueue - -/** [`Belt.MutableStack`]() - - An FILO(first in last out) stack data structure -*/ -module MutableStack = Belt_MutableStack - -/** [`Belt.List`]() - - Utilities for List data type -*/ -module List = Belt_List - -/** [`Belt.Range`]() - - Utilities for a closed range `(from, start)` -*/ -module Range = Belt_Range - -/** [`Belt.Set`]() - - The top level provides generic **immutable** set operations. - - It also has three specialized inner modules - [`Belt.Set.Int`](), [`Belt.Set.String`]() and - - [`Belt.Set.Dict`](): This module separates data from function - which is more verbose but slightly more efficient - -*/ -module Set = Belt_Set - -/** [`Belt.Map`](), - - The top level provides generic **immutable** map operations. - - It also has three specialized inner modules - [`Belt.Map.Int`](), [`Belt.Map.String`]() and - - [`Belt.Map.Dict`](): This module separates data from function - which is more verbose but slightly more efficient -*/ -module Map = Belt_Map - -/** [`Belt.MutableSet`]() - - The top level provides generic **mutable** set operations. - - It also has two specialized inner modules - [`Belt.MutableSet.Int`]() and [`Belt.MutableSet.String`]() -*/ -module MutableSet = Belt_MutableSet - -/** [`Belt.MutableMap`]() - - The top level provides generic **mutable** map operations. - - It also has two specialized inner modules - [`Belt.MutableMap.Int`]() and [`Belt.MutableMap.String`]() - -*/ -module MutableMap = Belt_MutableMap - -/** [`Belt.HashSet`]() - - The top level provides generic **mutable** hash set operations. - - It also has two specialized inner modules - [`Belt.HashSet.Int`]() and [`Belt.HashSet.String`]() -*/ -module HashSet = Belt_HashSet - -/** [`Belt.HashMap`]() - - The top level provides generic **mutable** hash map operations. - - It also has two specialized inner modules - [`Belt.HashMap.Int`]() and [`Belt.HashMap.String`]() -*/ -module HashMap = Belt_HashMap - -/** [`Belt.Option`]() - - Utilities for option data type. -*/ -module Option = Belt_Option - -/** [`Belt.Result`]() - - Utilities for result data type. -*/ -module Result = Belt_Result - -/** [`Belt.Int`]() - - Utilities for Int. -*/ -module Int = Belt_Int - -/** [`Belt.Float`]() - - Utilities for Float. -*/ -module Float = Belt_Float diff --git a/jscomp/others/belt_Array.res b/jscomp/others/belt_Array.res deleted file mode 100644 index fdb72f4..0000000 --- a/jscomp/others/belt_Array.res +++ /dev/null @@ -1,647 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* ********************************************************************* */ - -/* Array operations */ -type t<'a> = array<'a> - -external length: t<'a> => int = "%array_length" - -external size: t<'a> => int = "%array_length" - -external getUnsafe: (t<'a>, int) => 'a = "%array_unsafe_get" - -external setUnsafe: (t<'a>, int, 'a) => unit = "%array_unsafe_set" - -external getUndefined: (t<'a>, int) => Js.undefined<'a> = "%array_unsafe_get" - -/* external get: 'a t -> int -> 'a = "%array_safe_get" */ -let get = (arr, i) => - if i >= 0 && i < length(arr) { - Some(getUnsafe(arr, i)) - } else { - None - } - -let getExn = (arr, i) => { - assert(i >= 0 && i < length(arr)) - getUnsafe(arr, i) -} - -let set = (arr, i, v) => - if i >= 0 && i < length(arr) { - setUnsafe(arr, i, v) - true - } else { - false - } - -let setExn = (arr, i, v) => { - assert(i >= 0 && i < length(arr)) - setUnsafe(arr, i, v) -} - -@set external truncateToLengthUnsafe: (t<'a>, int) => unit = "length" - -@new external makeUninitialized: int => array> = "Array" - -@new external makeUninitializedUnsafe: int => array<'a> = "Array" - -@send external copy: (t<'a>, @as(0) _) => t<'a> = "slice" - -let swapUnsafe = (xs, i, j) => { - let tmp = getUnsafe(xs, i) - setUnsafe(xs, i, getUnsafe(xs, j)) - setUnsafe(xs, j, tmp) -} - -let shuffleInPlace = xs => { - let len = length(xs) - for i in 0 to len - 1 { - swapUnsafe(xs, i, Js_math.random_int(i, len)) /* [i,len) */ - } -} - -let shuffle = xs => { - let result = copy(xs) - shuffleInPlace(result) - - /* TODO: improve */ - result -} - -let reverseAux = (xs, ofs, len) => - for i in 0 to len / 2 - 1 { - swapUnsafe(xs, ofs + i, ofs + len - i - 1) - } - -let reverseInPlace = xs => { - let len = length(xs) - reverseAux(xs, 0, len) -} - -let reverse = xs => { - let len = length(xs) - let result = makeUninitializedUnsafe(len) - for i in 0 to len - 1 { - setUnsafe(result, i, getUnsafe(xs, len - 1 - i)) - } - result -} - -let make = (l, f) => - if l <= 0 { - [] - } else { - let res = makeUninitializedUnsafe(l) - for i in 0 to l - 1 { - setUnsafe(res, i, f) - } - res - } - -/* See #6575. We could also check for maximum array size, but this depends - on whether we create a float array or a regular one... */ -let makeByU = (l, f) => - if l <= 0 { - [] - } else { - let res = makeUninitializedUnsafe(l) - for i in 0 to l - 1 { - setUnsafe(res, i, f(. i)) - } - res - } - -let makeBy = (l, f) => makeByU(l, (. a) => f(a)) - -let makeByAndShuffleU = (l, f) => { - let u = makeByU(l, f) - shuffleInPlace(u) - u -} - -let makeByAndShuffle = (l, f) => makeByAndShuffleU(l, (. a) => f(a)) - -let range = (start, finish) => { - let cut = finish - start - if cut < 0 { - [] - } else { - let arr = makeUninitializedUnsafe(cut + 1) - for i in 0 to cut { - setUnsafe(arr, i, start + i) - } - arr - } -} - -let rangeBy = (start, finish, ~step) => { - let cut = finish - start - if cut < 0 || step <= 0 { - [] - } else { - let nb = cut / step + 1 - let arr = makeUninitializedUnsafe(nb) - let cur = ref(start) - for i in 0 to nb - 1 { - setUnsafe(arr, i, cur.contents) - cur.contents = cur.contents + step - } - arr - } -} - -let zip = (xs, ys) => { - let (lenx, leny) = (length(xs), length(ys)) - let len = Pervasives.min(lenx, leny) - let s = makeUninitializedUnsafe(len) - for i in 0 to len - 1 { - setUnsafe(s, i, (getUnsafe(xs, i), getUnsafe(ys, i))) - } - s -} - -let zipByU = (xs, ys, f) => { - let (lenx, leny) = (length(xs), length(ys)) - let len = Pervasives.min(lenx, leny) - let s = makeUninitializedUnsafe(len) - for i in 0 to len - 1 { - setUnsafe(s, i, f(. getUnsafe(xs, i), getUnsafe(ys, i))) - } - s -} - -let zipBy = (xs, ys, f) => zipByU(xs, ys, (. a, b) => f(a, b)) - -let concat = (a1, a2) => { - let l1 = length(a1) - let l2 = length(a2) - let a1a2 = makeUninitializedUnsafe(l1 + l2) - for i in 0 to l1 - 1 { - setUnsafe(a1a2, i, getUnsafe(a1, i)) - } - for i in 0 to l2 - 1 { - setUnsafe(a1a2, l1 + i, getUnsafe(a2, i)) - } - a1a2 -} - -let concatMany = arrs => { - let lenArrs = length(arrs) - let totalLen = ref(0) - for i in 0 to lenArrs - 1 { - totalLen.contents = totalLen.contents + length(getUnsafe(arrs, i)) - } - let result = makeUninitializedUnsafe(totalLen.contents) - totalLen.contents = 0 - for j in 0 to lenArrs - 1 { - let cur = getUnsafe(arrs, j) - for k in 0 to length(cur) - 1 { - setUnsafe(result, totalLen.contents, getUnsafe(cur, k)) - totalLen.contents = totalLen.contents + 1 - } - } - result -} - -let slice = (a, ~offset, ~len) => - if len <= 0 { - [] - } else { - let lena = length(a) - let ofs = if offset < 0 { - Pervasives.max(lena + offset, 0) - } else { - offset - } - let hasLen = lena - ofs - let copyLength = Pervasives.min(hasLen, len) - if copyLength <= 0 { - [] - } else { - let result = makeUninitializedUnsafe(copyLength) - for i in 0 to copyLength - 1 { - setUnsafe(result, i, getUnsafe(a, ofs + i)) - } - result - } - } - -let sliceToEnd = (a, offset) => { - let lena = length(a) - let ofs = if offset < 0 { - Pervasives.max(lena + offset, 0) - } else { - offset - } - let len = if lena > ofs { - lena - ofs - } else { - 0 - } - let result = makeUninitializedUnsafe(len) - for i in 0 to len - 1 { - setUnsafe(result, i, getUnsafe(a, ofs + i)) - } - result -} - -let fill = (a, ~offset, ~len, v) => - if len > 0 { - let lena = length(a) - let ofs = if offset < 0 { - Pervasives.max(lena + offset, 0) - } else { - offset - } - let hasLen = lena - ofs - let fillLength = Pervasives.min(hasLen, len) - if fillLength > 0 { - for i in ofs to ofs + fillLength - 1 { - setUnsafe(a, i, v) - } - } - } - -let blitUnsafe = ( - ~src as a1, - ~srcOffset as srcofs1, - ~dst as a2, - ~dstOffset as srcofs2, - ~len as blitLength, -) => - if srcofs2 <= srcofs1 { - for j in 0 to blitLength - 1 { - setUnsafe(a2, j + srcofs2, getUnsafe(a1, j + srcofs1)) - } - } else { - for j in blitLength - 1 downto 0 { - setUnsafe(a2, j + srcofs2, getUnsafe(a1, j + srcofs1)) - } - } - -/* We don't need check `blitLength` since when `blitLength < 0` the - for loop will be nop -*/ -let blit = (~src as a1, ~srcOffset as ofs1, ~dst as a2, ~dstOffset as ofs2, ~len) => { - let lena1 = length(a1) - let lena2 = length(a2) - let srcofs1 = if ofs1 < 0 { - Pervasives.max(lena1 + ofs1, 0) - } else { - ofs1 - } - let srcofs2 = if ofs2 < 0 { - Pervasives.max(lena2 + ofs2, 0) - } else { - ofs2 - } - let blitLength = Pervasives.min(len, Pervasives.min(lena1 - srcofs1, lena2 - srcofs2)) - - /* blitUnsafe a1 srcofs1 a2 srcofs2 blitLength */ - if srcofs2 <= srcofs1 { - for j in 0 to blitLength - 1 { - setUnsafe(a2, j + srcofs2, getUnsafe(a1, j + srcofs1)) - } - } else { - for j in blitLength - 1 downto 0 { - setUnsafe(a2, j + srcofs2, getUnsafe(a1, j + srcofs1)) - } - } -} - -let forEachU = (a, f) => - for i in 0 to length(a) - 1 { - f(. getUnsafe(a, i)) - } - -let forEach = (a, f) => forEachU(a, (. a) => f(a)) - -let mapU = (a, f) => { - let l = length(a) - let r = makeUninitializedUnsafe(l) - for i in 0 to l - 1 { - setUnsafe(r, i, f(. getUnsafe(a, i))) - } - r -} - -let map = (a, f) => mapU(a, (. a) => f(a)) - -let flatMapU = (a, f) => concatMany(mapU(a, f)) - -let flatMap = (a, f) => flatMapU(a, (. a) => f(a)) - -let getByU = (a, p) => { - let l = length(a) - let i = ref(0) - let r = ref(None) - while r.contents == None && i.contents < l { - let v = getUnsafe(a, i.contents) - if p(. v) { - r.contents = Some(v) - } - i.contents = i.contents + 1 - } - r.contents -} - -let getBy = (a, p) => getByU(a, (. a) => p(a)) - -let getIndexByU = (a, p) => { - let l = length(a) - let i = ref(0) - let r = ref(None) - while r.contents == None && i.contents < l { - let v = getUnsafe(a, i.contents) - if p(. v) { - r.contents = Some(i.contents) - } - i.contents = i.contents + 1 - } - r.contents -} - -let getIndexBy = (a, p) => getIndexByU(a, (. a) => p(a)) - -let keepU = (a, f) => { - let l = length(a) - let r = makeUninitializedUnsafe(l) - let j = ref(0) - for i in 0 to l - 1 { - let v = getUnsafe(a, i) - if f(. v) { - setUnsafe(r, j.contents, v) - j.contents = j.contents + 1 - } - } - truncateToLengthUnsafe(r, j.contents) - r -} - -let keep = (a, f) => keepU(a, (. a) => f(a)) - -let keepWithIndexU = (a, f) => { - let l = length(a) - let r = makeUninitializedUnsafe(l) - let j = ref(0) - for i in 0 to l - 1 { - let v = getUnsafe(a, i) - if f(. v, i) { - setUnsafe(r, j.contents, v) - j.contents = j.contents + 1 - } - } - truncateToLengthUnsafe(r, j.contents) - r -} - -let keepWithIndex = (a, f) => keepWithIndexU(a, (. a, i) => f(a, i)) - -let keepMapU = (a, f) => { - let l = length(a) - let r = makeUninitializedUnsafe(l) - let j = ref(0) - for i in 0 to l - 1 { - let v = getUnsafe(a, i) - switch f(. v) { - | None => () - | Some(v) => - setUnsafe(r, j.contents, v) - j.contents = j.contents + 1 - } - } - truncateToLengthUnsafe(r, j.contents) - r -} - -let keepMap = (a, f) => keepMapU(a, (. a) => f(a)) - -let forEachWithIndexU = (a, f) => - for i in 0 to length(a) - 1 { - f(. i, getUnsafe(a, i)) - } - -let forEachWithIndex = (a, f) => forEachWithIndexU(a, (. a, b) => f(a, b)) - -let mapWithIndexU = (a, f) => { - let l = length(a) - let r = makeUninitializedUnsafe(l) - for i in 0 to l - 1 { - setUnsafe(r, i, f(. i, getUnsafe(a, i))) - } - r -} - -let mapWithIndex = (a, f) => mapWithIndexU(a, (. a, b) => f(a, b)) - -let reduceU = (a, x, f) => { - let r = ref(x) - for i in 0 to length(a) - 1 { - r.contents = f(. r.contents, getUnsafe(a, i)) - } - r.contents -} - -let reduce = (a, x, f) => reduceU(a, x, (. a, b) => f(a, b)) - -let reduceReverseU = (a, x, f) => { - let r = ref(x) - for i in length(a) - 1 downto 0 { - r.contents = f(. r.contents, getUnsafe(a, i)) - } - r.contents -} - -let reduceReverse = (a, x, f) => reduceReverseU(a, x, (. a, b) => f(a, b)) - -let reduceReverse2U = (a, b, x, f) => { - let r = ref(x) - let len = Pervasives.min(length(a), length(b)) - for i in len - 1 downto 0 { - r.contents = f(. r.contents, getUnsafe(a, i), getUnsafe(b, i)) - } - r.contents -} - -let reduceReverse2 = (a, b, x, f) => reduceReverse2U(a, b, x, (. a, b, c) => f(a, b, c)) - -let reduceWithIndexU = (a, x, f) => { - let r = ref(x) - for i in 0 to length(a) - 1 { - r.contents = f(. r.contents, getUnsafe(a, i), i) - } - r.contents -} - -let reduceWithIndex = (a, x, f) => reduceWithIndexU(a, x, (. a, b, c) => f(a, b, c)) - -let rec everyAux = (arr, i, b, len) => - if i == len { - true - } else if b(. getUnsafe(arr, i)) { - everyAux(arr, i + 1, b, len) - } else { - false - } - -let rec someAux = (arr, i, b, len) => - if i == len { - false - } else if b(. getUnsafe(arr, i)) { - true - } else { - someAux(arr, i + 1, b, len) - } - -let everyU = (arr, b) => { - let len = length(arr) - everyAux(arr, 0, b, len) -} - -let every = (arr, f) => everyU(arr, (. b) => f(b)) - -let someU = (arr, b) => { - let len = length(arr) - someAux(arr, 0, b, len) -} - -let some = (arr, f) => someU(arr, (. b) => f(b)) - -let rec everyAux2 = (arr1, arr2, i, b, len) => - if i == len { - true - } else if b(. getUnsafe(arr1, i), getUnsafe(arr2, i)) { - everyAux2(arr1, arr2, i + 1, b, len) - } else { - false - } - -let rec someAux2 = (arr1, arr2, i, b, len) => - if i == len { - false - } else if b(. getUnsafe(arr1, i), getUnsafe(arr2, i)) { - true - } else { - someAux2(arr1, arr2, i + 1, b, len) - } - -let every2U = (a, b, p) => everyAux2(a, b, 0, p, Pervasives.min(length(a), length(b))) - -let every2 = (a, b, p) => every2U(a, b, (. a, b) => p(a, b)) - -let some2U = (a, b, p) => someAux2(a, b, 0, p, Pervasives.min(length(a), length(b))) - -let some2 = (a, b, p) => some2U(a, b, (. a, b) => p(a, b)) - -let eqU = (a, b, p) => { - let lena = length(a) - let lenb = length(b) - if lena == lenb { - everyAux2(a, b, 0, p, lena) - } else { - false - } -} - -let eq = (a, b, p) => eqU(a, b, (. a, b) => p(a, b)) - -let rec everyCmpAux2 = (arr1, arr2, i, b, len) => - if i == len { - 0 - } else { - let c = b(. getUnsafe(arr1, i), getUnsafe(arr2, i)) - if c == 0 { - everyCmpAux2(arr1, arr2, i + 1, b, len) - } else { - c - } - } - -let cmpU = (a, b, p) => { - let lena = length(a) - let lenb = length(b) - if lena > lenb { - 1 - } else if lena < lenb { - -1 - } else { - everyCmpAux2(a, b, 0, p, lena) - } -} - -let cmp = (a, b, p) => cmpU(a, b, (. a, b) => p(a, b)) - -let partitionU = (a, f) => { - let l = length(a) - let i = ref(0) - let j = ref(0) - let a1 = makeUninitializedUnsafe(l) - let a2 = makeUninitializedUnsafe(l) - for ii in 0 to l - 1 { - let v = getUnsafe(a, ii) - if f(. v) { - setUnsafe(a1, i.contents, v) - i.contents = i.contents + 1 - } else { - setUnsafe(a2, j.contents, v) - j.contents = j.contents + 1 - } - } - truncateToLengthUnsafe(a1, i.contents) - truncateToLengthUnsafe(a2, j.contents) - (a1, a2) -} - -let partition = (a, f) => partitionU(a, (. x) => f(x)) - -let unzip = a => { - let l = length(a) - let a1 = makeUninitializedUnsafe(l) - let a2 = makeUninitializedUnsafe(l) - for i in 0 to l - 1 { - let (v1, v2) = getUnsafe(a, i) - setUnsafe(a1, i, v1) - setUnsafe(a2, i, v2) - } - (a1, a2) -} - -let joinWithU = (a, sep, toString) => - switch length(a) { - | 0 => "" - | l => - let lastIndex = l - 1 - let rec aux = (i, res) => - if i == lastIndex { - res ++ toString(. getUnsafe(a, i)) - } else { - aux(i + 1, res ++ (toString(. getUnsafe(a, i)) ++ sep)) - } - - aux(0, "") - } - -let joinWith = (a, sep, toString) => joinWithU(a, sep, (. x) => toString(x)) - -let initU = (n, f) => { - let v = makeUninitializedUnsafe(n) - for i in 0 to n - 1 { - setUnsafe(v, i, f(. i)) - } - v -} - -let init = (n, f) => initU(n, (. i) => f(i)) - -@send external push: (t<'a>, 'a) => unit = "push" diff --git a/jscomp/others/belt_Array.resi b/jscomp/others/belt_Array.resi deleted file mode 100644 index eb81098..0000000 --- a/jscomp/others/belt_Array.resi +++ /dev/null @@ -1,771 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* ********************************************************************* */ -/* Adapted significantly by Authors of ReScript */ - -/*** -Utilities for `Array` functions. - -### Note about index syntax - -Code like `arr[0]` does *not* compile to JavaScript `arr[0]`. Reason transforms -the `[]` index syntax into a function: `Array.get(arr, 0)`. By default, this -uses the default standard library's `Array.get` function, which may raise an -exception if the index isn't found. If you `open Belt`, it will use the -`Belt.Array.get` function which returns options instead of raising exceptions. -[See this for more information](../belt.mdx#array-access-runtime-safety). -*/ - -type t<'a> = array<'a> - -/** -Return the size of the array - -## Examples - -```rescript -// Returns 1 -Belt.Array.length(["test"]) -``` -*/ -external length: t<'a> => int = "%array_length" - -/** See [`Belt.Array.length`]() */ -external size: t<'a> => int = "%array_length" - -/** -If `i <= 0 <= length(arr)` returns `Some(value)` where `value` is the item at index `i`. -If `i` is out of range returns `None`. - -## Examples - -```rescript -Belt.Array.get(["a", "b", "c"], 0) == Some("a") -Belt.Array.get(["a", "b", "c"], 3) == None -Belt.Array.get(["a", "b", "c"], -1) == None -``` -*/ -let get: (t<'a>, int) => option<'a> - -/** -Raise an exception if `i` is out of range. -Otherwise return the value at index `i` in `arr`. -*/ -let getExn: (t<'a>, int) => 'a - -/** -`getUnsafe(arr, i)` - -**Unsafe** - -no bounds checking; this would cause type error if `i` does not stay within range -*/ -external getUnsafe: (t<'a>, int) => 'a = "%array_unsafe_get" - -/** -`getUndefined(arr, i)` - -It does the samething in the runtime as [`getUnsafe`](); -it is _type safe_ since the return type still track whether it is -in range or not -*/ -external getUndefined: (t<'a>, int) => Js.undefined<'a> = "%array_unsafe_get" - -/** -`set(arr, n, x)` modifies `arr` in place; it replaces the nth element of `arr` -with `x`. Returning `false` means not updated due to out of range. -*/ -let set: (t<'a>, int, 'a) => bool - -/** -`setExn(arr, i, x)` raise an exception if `i` is out of range. -*/ -let setExn: (t<'a>, int, 'a) => unit - -external setUnsafe: (t<'a>, int, 'a) => unit = "%array_unsafe_set" - -/** -`shuffleInPlace(arr)` randomly re-orders the items in `arr` -*/ -let shuffleInPlace: t<'a> => unit - -/** Returns a fresh array with items in original array randomly shuffled. */ -let shuffle: t<'a> => t<'a> - -/** -`reverseInPlace(arr)` reverses items in `arr` in place. - -## Examples - -```rescript -let arr = [10, 11, 12, 13, 14] - -let () = Belt.Array.reverseInPlace(arr) - -arr == [14, 13, 12, 11, 10] -``` -*/ -let reverseInPlace: t<'a> => unit - -/** -`reverse(arr)` returns a fresh array with items in arr in reverse order. - -## Examples - -```rescript -Belt.Array.reverse([10, 11, 12, 13, 14]) == [14, 13, 12, 11, 10] -``` -*/ -let reverse: t<'a> => t<'a> - -@new -/** -`makeUninitialized(n)` creates an array of length `n` filled with the undefined -value. You must specify the type of data that will eventually fill the array. - -## Examples - -```rescript -let arr: array> = Belt.Array.makeUninitialized(5) - -Belt.Array.getExn(arr, 0) == Js.undefined -``` -*/ -external makeUninitialized: int => array> = "Array" - -@new -/** -**Unsafe** - -## Examples - -```rescript -let arr = Belt.Array.makeUninitializedUnsafe(5) - -Js.log(Belt.Array.getExn(arr, 0)) // undefined - -Belt.Array.setExn(arr, 0, "example") - -Js.log(Belt.Array.getExn(arr, 0) == "example") -``` -*/ -external makeUninitializedUnsafe: int => t<'a> = "Array" - -/** -`make(n, e)` return an array of size `n` filled with value `e`. -Returns an empty array when `n` is negative. -*/ -let make: (int, 'a) => t<'a> - -/** -`range(start, finish)` create an inclusive array. - -## Examples - -```rescript -Belt.Array.range(0, 3) == [0, 1, 2, 3] - -Belt.Array.range(3, 0) == [] - -Belt.Array.range(3, 3) == [3] -``` -*/ -let range: (int, int) => array - -/** -`rangeBy(start, finish, ~step)` returns empty array when step is 0 or negative. -It also return an empty array when `start > finish`. - -## Examples - -```rescript -Belt.Array.rangeBy(0, 10, ~step=3) == [0, 3, 6, 9] - -Belt.Array.rangeBy(0, 12, ~step=3) == [0, 3, 6, 9, 12] - -Belt.Array.rangeBy(33, 0, ~step=1) == [] - -Belt.Array.rangeBy(33, 0, ~step=-1) == [] - -Belt.Array.rangeBy(3, 12, ~step=-1) == [] - -Belt.Array.rangeBy(3, 3, ~step=0) == [] - -Belt.Array.rangeBy(3, 3, ~step=1) == [3] -``` -*/ -let rangeBy: (int, int, ~step: int) => array - -let makeByU: (int, (. int) => 'a) => t<'a> -/** -`makeBy(n, f)` return an empty array when n is negative return an array of size -n populated by `f(i)` start from `0` to `n - 1`. - -## Examples - -```rescript -Belt.Array.makeBy(5, (i) => i) == [0, 1, 2, 3, 4] - -Belt.Array.makeBy(5, (i) => i * i) == [0, 1, 4, 9, 16] -``` -*/ -let makeBy: (int, int => 'a) => t<'a> - -let makeByAndShuffleU: (int, (. int) => 'a) => t<'a> -/** -Equivalent to `shuffle(makeBy(n, f))` -*/ -let makeByAndShuffle: (int, int => 'a) => t<'a> - -/** -`zip(a, b)` create an array of pairs from corresponding elements of a and b. -Stop with the shorter array. - -## Examples - -```rescript -Belt.Array.zip([1, 2], [3, 4, 5]) == [(1, 3), (2, 4)] -``` -*/ -let zip: (t<'a>, array<'b>) => array<('a, 'b)> - -let zipByU: (t<'a>, array<'b>, (. 'a, 'b) => 'c) => array<'c> -/** -`zipBy(xs, ys, f)` create an array by applying `f` to corresponding elements of -`xs` and `ys`. Stops with shorter array. - -Equivalent to `map(zip(xs, ys), ((a, b)) => f(a, b))` - -## Examples - -```rescript -Belt.Array.zipBy([1, 2, 3], [4, 5], (a, b) => 2 * a + b) == [6, 9] -``` -*/ -let zipBy: (t<'a>, array<'b>, ('a, 'b) => 'c) => array<'c> - -/** -`unzip(a)` takes an array of pairs and creates a pair of arrays. The first array -contains all the first items of the pairs; the second array contains all the -second items. - -## Examples - -```rescript -Belt.Array.unzip([(1, 2), (3, 4)]) == ([1, 3], [2, 4]) - -Belt.Array.unzip([(1, 2), (3, 4), (5, 6), (7, 8)]) == ([1, 3, 5, 7], [2, 4, 6, 8]) -``` -*/ -let unzip: array<('a, 'b)> => (t<'a>, array<'b>) - -/** -`concat(xs, ys)` returns a fresh array containing the concatenation of the arrays -`v1` and `v2`, so even if `v1` or `v2` is empty; it can not be shared. - -## Examples - -```rescript -Belt.Array.concat([1, 2, 3], [4, 5]) == [1, 2, 3, 4, 5] - -Belt.Array.concat([], ["a", "b", "c"]) == ["a", "b", "c"] -``` -*/ -let concat: (t<'a>, t<'a>) => t<'a> - -/** -`concatMany(xss)` returns a fresh array as the concatenation of `xss` (an array of arrays) - -## Examples - -```rescript -Belt.Array.concatMany([[1, 2, 3], [4, 5, 6], [7, 8]]) == [1, 2, 3, 4, 5, 6, 7, 8] -``` -*/ -let concatMany: array> => t<'a> - -/** -`slice(xs, offset, len)` creates a new array with the len elements of `xs` -starting at `offset` for `offset` can be negative;and is evaluated as -`length(xs) - offset(slice, xs) - 1(1)` means get the last element as a -singleton array `slice(xs, ~-len, len)` will return a copy of the array if the -array does not have enough data; `slice` extracts through the end of sequence. - -if `len` is negative; returns the empty array. - -## Examples - -```rescript -Belt.Array.slice([10, 11, 12, 13, 14, 15, 16], ~offset=2, ~len=3) == [12, 13, 14] - -Belt.Array.slice([10, 11, 12, 13, 14, 15, 16], ~offset=-4, ~len=3) == [13, 14, 15] - -Belt.Array.slice([10, 11, 12, 13, 14, 15, 16], ~offset=4, ~len=9) == [14, 15, 16] -``` -*/ -let slice: (t<'a>, ~offset: int, ~len: int) => t<'a> - -/** -`sliceToEnd(xs, offset)` creates a new array with the elements of `xs` starting -at `offset` - -`offset` can be negative; and is evaluated as `length(xs) - offset(sliceToEnd, xs) - 1` -means get the last element as a singleton array - -`sliceToEnd(xs, 0)` will return a copy of the array - -## Examples - -```rescript -Belt.Array.sliceToEnd([10, 11, 12, 13, 14, 15, 16], 2) == [12, 13, 14, 15, 16] - -Belt.Array.sliceToEnd([10, 11, 12, 13, 14, 15, 16], -4) == [13, 14, 15, 16] -``` -*/ -let sliceToEnd: (t<'a>, int) => t<'a> - -@send -/** -`copy(a)` returns a copy of `a`; that is; a fresh array containing the same -elements as `a`. -*/ -external copy: (t<'a>, @as(0) _) => t<'a> = "slice" - -/** -`fill(arr, ~offset, ~len, x)` modifies `arr` in place, storing `x` in elements -number `offset` to `offset + len - 1`. `offset` can be negative; and is evaluated -as `length(arr - offset)`. - -`fill(arr, ~offset=-1, ~len=1)` means fill the last element, if the array does not have enough data; `fill` will ignore it - -## Examples - -```rescript -let arr = Belt.Array.makeBy(5, (i) => i) - -Belt.Array.fill(arr, ~offset=2, ~len=2, 9) - -arr == [0, 1, 9, 9, 4] - -Belt.Array.fill(arr, ~offset=7, ~len=2, 8) - -arr == [0, 1, 9, 9, 4] -*/ -let fill: (t<'a>, ~offset: int, ~len: int, 'a) => unit - -/** -`blit(~src=v1, ~srcOffset=o1, ~dst=v2, ~dstOffset=o2, ~len)` copies `len` elements -from array `v1`;starting at element number `o1`;to array `v2`, starting at element -number `o2`. It works correctly even if `v1` and `v2` are the same array and the -source and destination chunks overlap. - -`offset` can be negative; `-1` means `len - 1`; if `len + offset` is still negative;it will be set as 0 - -For each of the examples;presume that `v1 == [10, 11, 12, 13, 14, 15, 16, 17]` and `v2 == [20, 21, 22, 23, 24, 25, 26, 27]`. The result shown is the content of the destination array. - -## Examples - -```rescript -let v1 = [10, 11, 12, 13, 14, 15, 16, 17] -let v2 = [20, 21, 22, 23, 24, 25, 26, 27] - -Belt.Array.blit(~src=v1, ~srcOffset=4, ~dst=v2, ~dstOffset=2, ~len=3) -v2 == [20, 21, 14, 15, 16, 25, 26, 27] - -Belt.Array.blit(~src=v1, ~srcOffset=4, ~dst=v1, ~dstOffset=2, ~len=3) -v1 == [10, 11, 14, 15, 16, 15, 16, 17] -``` -*/ -let blit: (~src: t<'a>, ~srcOffset: int, ~dst: t<'a>, ~dstOffset: int, ~len: int) => unit - -/** -Unsafe blit without bounds checking. -*/ -let blitUnsafe: (~src: t<'a>, ~srcOffset: int, ~dst: t<'a>, ~dstOffset: int, ~len: int) => unit - -let forEachU: (t<'a>, (. 'a) => unit) => unit -/** -`forEach(xs, f)` - -Call `f` on each element of `xs` from the beginning to end. `f` returns `unit` -so no new array is created. Use `forEach` when you are primarily concerned with -repetitively creating side effects. - -## Examples - -```rescript -Belt.Array.forEach(["a", "b", "c"], x => Js.log("Item: " ++ x)) - -/* - prints: - Item: a - Item: b - Item: c -*/ -let total = ref(0) - -Belt.Array.forEach([1, 2, 3, 4], x => total := total.contents + x) - -total.contents == 1 + 2 + 3 + 4 -``` -*/ -let forEach: (t<'a>, 'a => unit) => unit - -let mapU: (t<'a>, (. 'a) => 'b) => array<'b> -/** -`map(xs, f)` returns a new array by calling `f` for each element of `xs` from -the beginning to end. - -## Examples - -```rescript -Belt.Array.map([1, 2], (x) => x + 1) == [3, 4] -``` -*/ -let map: (t<'a>, 'a => 'b) => array<'b> - -let flatMapU: (t<'a>, (. 'a) => array<'b>) => array<'b> -/** -`flatMap(xs, f)` returns a new array by calling `f` for each element of `xs` from -the beginning to end, concatenating the results. - -## Examples - -```rescript -Belt.Array.flatMap([1, 2], x => [x + 10, x + 20]) == [11, 21, 12, 22] -``` -*/ -let flatMap: (t<'a>, 'a => array<'b>) => array<'b> - -let getByU: (t<'a>, (. 'a) => bool) => option<'a> -/** -`getBy(xs, p)` returns `Some(value)` for the first value in `xs` that satisifies -the predicate function `p`; returns `None` if no element satisifies the function. - -## Examples - -```rescript -Belt.Array.getBy([1, 4, 3, 2], (x) => mod(x, 2) == 0) == Some(4) -Belt.Array.getBy([15, 13, 11], (x) => mod(x, 2) == 0) == None -``` -*/ -let getBy: (t<'a>, 'a => bool) => option<'a> - -let getIndexByU: (t<'a>, (. 'a) => bool) => option -/** -`getIndexBy(xs, p)` returns `Some(index)` for the first value in `xs` that -satisifies the predicate function `p`; returns `None` if no element satisifies -the function. - -## Examples - -```rescript -Belt.Array.getIndexBy([1, 4, 3, 2], (x) => mod(x, 2) == 0) == Some(1) -Belt.Array.getIndexBy([15, 13, 11], (x) => mod(x, 2) == 0) == None -``` -*/ -let getIndexBy: (t<'a>, 'a => bool) => option - -let keepU: (t<'a>, (. 'a) => bool) => t<'a> -/** -`keep(xs, p)` returns a new array that keep all elements satisfy `p`. -*/ -let keep: (t<'a>, 'a => bool) => t<'a> - -let keepWithIndexU: (t<'a>, (. 'a, int) => bool) => t<'a> -/** -`keepWithIndex(xs, p)` returns a new array that keep all elements satisfy `p`. - -## Examples - -```rescript -Belt.Array.keepWithIndex([1, 2, 3], (_x, i) => i == 1) == [2] -``` -*/ -let keepWithIndex: (t<'a>, ('a, int) => bool) => t<'a> - -let keepMapU: (t<'a>, (. 'a) => option<'b>) => array<'b> -/** -`keepMap(xs, p)` returns a new array that keep all elements that return a non -None applied `p`. - -## Examples - -```rescript -Belt.Array.keepMap([1, 2, 3], x => - if mod(x, 2) == 0 { - Some(x) - } else { - None - } -) -== [2] -``` -*/ -let keepMap: (t<'a>, 'a => option<'b>) => array<'b> - -let forEachWithIndexU: (t<'a>, (. int, 'a) => unit) => unit -/** -`forEachWithIndex(xs, f)` same as `Belt.Array.forEach`, except that `f` is -supplied two arguments: the index starting from 0 and the element from `xs`. - -## Examples - -```rescript -Belt.Array.forEachWithIndex(["a", "b", "c"], (i, x) => Js.log("Item " ++ Belt.Int.toString(i) ++ " is " ++ x)) - -/* - prints: - Item 0 is a - Item 1 is b - Item 2 is cc -*/ -let total = ref(0) - -Belt.Array.forEachWithIndex([10, 11, 12, 13], (i, x) => total := total.contents + x + i) - -total.contents == 0 + 10 + 1 + 11 + 2 + 12 + 3 + 13 -``` -*/ -let forEachWithIndex: (t<'a>, (int, 'a) => unit) => unit - -let mapWithIndexU: (t<'a>, (. int, 'a) => 'b) => array<'b> -/** -`mapWithIndex(xs, f)` applies `f` to each element of `xs`. Function `f` takes -two arguments: the index starting from 0 and the element from `xs`. - -## Examples - -```rescript -Belt.Array.mapWithIndex([1, 2, 3], (i, x) => i + x) == [0 + 1, 1 + 2, 2 + 3] -``` -*/ -let mapWithIndex: (t<'a>, (int, 'a) => 'b) => array<'b> - -let partitionU: (t<'a>, (. 'a) => bool) => (t<'a>, t<'a>) -/** -`partition(f, a)` split array into tuple of two arrays based on predicate `f`; -first of tuple where predicate cause true, second where predicate cause false - -## Examples - -```rescript -Belt.Array.partition([1, 2, 3, 4, 5], (x) => mod(x, 2) == 0) == ([2, 4], [1, 3, 5]) - -Belt.Array.partition([1, 2, 3, 4, 5], (x) => mod(x, 2) != 0) == ([1, 3, 5], [2, 4]) -``` -*/ -let partition: (t<'a>, 'a => bool) => (t<'a>, t<'a>) - -let reduceU: (array<'b>, 'a, (. 'a, 'b) => 'a) => 'a -/** -`reduce(xs, init, f)` applies `f` to each element of `xs` from beginning to end. -Function `f` has two parameters: the item from the list and an “accumulator”; -which starts with a value of `init`. `reduce` returns the final value of the -accumulator. - -## Examples - -```rescript -Belt.Array.reduce([2, 3, 4], 1, (a, b) => a + b) == 10 - -Belt.Array.reduce(["a", "b", "c", "d"], "", (a, b) => a ++ b) == "abcd" -``` -*/ -let reduce: (array<'b>, 'a, ('a, 'b) => 'a) => 'a - -let reduceReverseU: (array<'b>, 'a, (. 'a, 'b) => 'a) => 'a -/** -`reduceReverse(xs, init, f)` works like `Belt.Array.reduce` except that -function `f` is applied to each item of `xs` from the last back to the first. - -## Examples - -```rescript -Belt.Array.reduceReverse(["a", "b", "c", "d"], "", (a, b) => a ++ b) == "dcba" -``` -*/ -let reduceReverse: (array<'b>, 'a, ('a, 'b) => 'a) => 'a - -let reduceReverse2U: (t<'a>, array<'b>, 'c, (. 'c, 'a, 'b) => 'c) => 'c -/** -`reduceReverse2(xs, ys, init, f)` reduces two arrays xs and ys;taking items -starting at `min(length(xs), length(ys))` down to and including zero. - -## Examples - -```rescript -Belt.Array.reduceReverse2([1, 2, 3], [1, 2], 0, (acc, x, y) => acc + x + y) == 6 -``` -*/ -let reduceReverse2: (t<'a>, array<'b>, 'c, ('c, 'a, 'b) => 'c) => 'c - -let reduceWithIndexU: (t<'a>, 'b, (. 'b, 'a, int) => 'b) => 'b -/** -Applies `f` to each element of `xs` from beginning to end. Function `f` has -three parameters: the item from the array and an “accumulator”, which starts -with a value of `init` and the index of each element. `reduceWithIndex` returns -the final value of the accumulator. - -## Examples - -```rescript -Belt.Array.reduceWithIndex([1, 2, 3, 4], 0, (acc, x, i) => acc + x + i) == 16 -``` -*/ -let reduceWithIndex: (t<'a>, 'b, ('b, 'a, int) => 'b) => 'b - -let joinWithU: (t<'a>, string, (. 'a) => string) => string -/** -`joinWith(xs, sep, toString)` - -Concatenates all the elements of `xs` converted to string with `toString`, each -separated by `sep`, the string given as the second argument, into a single string. -If the array has only one element, then that element will be returned without -using the separator. If the array is empty, the empty string will be returned. - -## Examples - -```rescript -Belt.Array.joinWith([0, 1], ", ", Js.Int.toString) == "0, 1" -Belt.Array.joinWith([], " ", Js.Int.toString) == "" -Belt.Array.joinWith([1], " ", Js.Int.toString) == "1" -``` -*/ -let joinWith: (t<'a>, string, 'a => string) => string - -let someU: (t<'a>, (. 'a) => bool) => bool -/** -`some(xs, p)` returns true if at least one of the elements in `xs` satifies `p`; -where `p` is a predicate: a function taking an element and returning a `bool`. - -## Examples - -```rescript -Belt.Array.some([2, 3, 4], (x) => mod(x, 2) == 1) == true - -Belt.Array.some([(-1), (-3), (-5)], (x) => x > 0) == false -``` -*/ -let some: (t<'a>, 'a => bool) => bool - -let everyU: (t<'a>, (. 'a) => bool) => bool -/** -`every(xs, p)` returns `true` if all elements satisfy `p`; where `p` is a -predicate: a function taking an element and returning a `bool`. - -## Examples - -```rescript -Belt.Array.every([1, 3, 5], (x) => mod(x, 2) == 1) == true - -Belt.Array.every([1, (-3), 5], (x) => x > 0) == false -``` -*/ -let every: (t<'a>, 'a => bool) => bool - -let every2U: (t<'a>, array<'b>, (. 'a, 'b) => bool) => bool -/** -`every2(xs, ys, p)` returns true if `p(xi, yi)` is true for all pairs of -elements up to the shorter length (i.e. `min(length(xs), length(ys))`) - -## Examples - -```rescript -Belt.Array.every2([1, 2, 3], [0, 1], (a, b) => a > b) == true - -Belt.Array.every2([], [1], (x, y) => x > y) == true - -Belt.Array.every2([2, 3], [1], (x, y) => x > y) == true - -Belt.Array.every2([0, 1], [5, 0], (x, y) => x > y) == false -``` -*/ -let every2: (t<'a>, array<'b>, ('a, 'b) => bool) => bool - -let some2U: (t<'a>, array<'b>, (. 'a, 'b) => bool) => bool -/** -`some2(xs, ys, p)` returns true if `p(xi, yi)` is true for any pair of elements -up to the shorter length (i.e. `min(length(xs), length(ys))`) - -## Examples - -```rescript -Belt.Array.some2([0, 2], [1, 0, 3], (a, b) => a > b) == true - -Belt.Array.some2([], [1], (x, y) => x > y) == false - -Belt.Array.some2([2, 3], [1, 4], (x, y) => x > y) == true -``` -*/ -let some2: (t<'a>, array<'b>, ('a, 'b) => bool) => bool - -let cmpU: (t<'a>, t<'a>, (. 'a, 'a) => int) => int -/** -`cmp(xs, ys, f)` compared by length if `length(xs) != length(ys)`; returning `-1` -if `length(xs) < length(ys)` or 1 if `length(xs) > length(ys)`. Otherwise -compare one by one `f(x, y)`. `f` returns a negative number if `x` is “less than” `y` -zero if `x` is “equal to” `y` a positive number if `x` is “greater than” -`y`. The comparison returns the first non-zero result of `f`; or zero if `f` -returns zero for all `x` and `y`. - -## Examples - -```rescript -Belt.Array.cmp([1, 3, 5], [1, 4, 2], (a, b) => compare(a, b)) == -1 - -Belt.Array.cmp([1, 3, 5], [1, 2, 3], (a, b) => compare(a, b)) == 1 - -Belt.Array.cmp([1, 3, 5], [1, 3, 5], (a, b) => compare(a, b)) == 0 -``` -*/ -let cmp: (t<'a>, t<'a>, ('a, 'a) => int) => int - -let eqU: (t<'a>, t<'a>, (. 'a, 'a) => bool) => bool -/** -`eq(xs, ys)` return `false` if length is not the same otherwise compare items -one by one using `f(xi, yi)`; and return true if all results are true false otherwise - -## Examples - -```rescript -Belt.Array.eq([1, 2, 3], [(-1), (-2), (-3)], (a, b) => abs(a) == abs(b)) == true -``` -*/ -let eq: (t<'a>, t<'a>, ('a, 'a) => bool) => bool - -@set -/** -Unsafe `truncateToLengthUnsafe(xs, n)` sets length of array `xs` to `n`. If `n` -is greater than the length of `xs`; the extra elements are set to `Js.Null_undefined.null`. -If `n` is less than zero; raises a `RangeError`. - -## Examples - -```rescript -let arr = ["ant", "bee", "cat", "dog", "elk"] - -Belt.Array.truncateToLengthUnsafe(arr, 3) - -arr == ["ant", "bee", "cat"] -``` -*/ -external truncateToLengthUnsafe: (t<'a>, int) => unit = "length" - -let initU: (int, (. int) => 'a) => t<'a> -let init: (int, int => 'a) => t<'a> - -/** -`arr->push(item)` pushes an element `item` into an array `arr`. -*/ -@send -external push: (t<'a>, 'a) => unit = "push" diff --git a/jscomp/others/belt_Float.res b/jscomp/others/belt_Float.res deleted file mode 100644 index a30e295..0000000 --- a/jscomp/others/belt_Float.res +++ /dev/null @@ -1,51 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** [`Belt.Float`]() - Utilities for Float -*/ - -@val external isNaN: float => bool = "isNaN" - -external toInt: float => int = "%intoffloat" - -external fromInt: int => float = "%identity" - -@val external fromString: string => float = "parseFloat" - -let fromString = i => - switch fromString(i) { - | i if isNaN(i) => None - | i => Some(i) - } - -@val external toString: float => string = "String" - -external \"+": (float, float) => float = "%addfloat" - -external \"-": (float, float) => float = "%subfloat" - -external \"*": (float, float) => float = "%mulfloat" - -external \"/": (float, float) => float = "%divfloat" diff --git a/jscomp/others/belt_Float.resi b/jscomp/others/belt_Float.resi deleted file mode 100644 index bc6fbf9..0000000 --- a/jscomp/others/belt_Float.resi +++ /dev/null @@ -1,122 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** This module includes convenience methods for handling `float` types. */ - -/** -Converts a given `float` to an `int`. - -## Examples - -```rescript -Js.log(Belt.Float.toInt(1.0) === 1) /* true */ -``` -*/ -external toInt: float => int = "%intoffloat" - -/** -Converts a given `int` to a `float`. - -## Examples - -```rescript -Js.log(Belt.Float.fromInt(1) === 1.0) /* true */ -``` -*/ -external fromInt: int => float = "%identity" - -/** -Converts a given `string` to a `float`. Returns `Some(float)` when the input is a number, `None` otherwise. - -## Examples - -```rescript -Js.log(Belt.Float.fromString("1.0") === Some(1.0)) /* true */ -``` -*/ -let fromString: string => option - -@val -/** -Converts a given `float` to a `string`. Uses the JavaScript `String` constructor under the hood. - -## Examples - -```rescript -Js.log(Belt.Float.toString(1.0) === "1.0") /* true */ -``` -*/ -external toString: float => string = "String" - -/** -Addition of two `float` values. -Can be opened in a module to avoid dot-notation (`+.`), however this yields a shadow warning (Warning number 44) in the default configuration. - -## Examples - -```rescript -open Belt.Float -Js.log(2.0 + 2.0 === 4.0) /* true */ -``` -*/ -external \"+": (float, float) => float = "%addfloat" - -/** -Subtraction of two `float` values. -Can be opened in a module to avoid dot-notation (`-.`), however this yields a shadow warning (Warning number 44) in the default configuration. - -## Examples - -```rescript -open Belt.Float -Js.log(2.0 - 1.0 === 1.0) /* true */ -``` -*/ -external \"-": (float, float) => float = "%subfloat" - -/** -Multiplication of two `float` values. -Can be opened in a module to avoid dot-notation (`*.`), however this yields a shadow warning (Warning number 44) in the default configuration. - -## Examples - -```rescript -open Belt.Float -Js.log(2.0 * 2.0 === 4.0) /* true */ -``` -*/ -external \"*": (float, float) => float = "%mulfloat" - -/** -Division of two `float` values. -Can be opened in a module to avoid dot-notation (`/.`), however this yields a shadow warning (Warning number 44) in the default configuration. - -## Examples - -```rescript -open Belt.Float -Js.log(4.0 / 2.0 === 2.0) /* true */ -``` -*/ -external \"/": (float, float) => float = "%divfloat" diff --git a/jscomp/others/belt_HashMap.res b/jscomp/others/belt_HashMap.res deleted file mode 100644 index 38650bd..0000000 --- a/jscomp/others/belt_HashMap.res +++ /dev/null @@ -1,229 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* Adapted by Hongbo Zhang, Authors of ReScript 2017 */ -/* ********************************************************************* */ - -module N = Belt_internalBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type eq<'a, 'id> = Belt_Id.eq<'a, 'id> -type hash<'a, 'id> = Belt_Id.hash<'a, 'id> -type id<'a, 'id> = Belt_Id.hashable<'a, 'id> -type t<'a, 'b, 'id> = N.t, eq<'a, 'id>, 'a, 'b> - -let clear = C.clear -let size = h => h.C.size -let forEach = N.forEach -let forEachU = N.forEachU -let reduce = N.reduce -let reduceU = N.reduceU -let logStats = N.logStats -let keepMapInPlaceU = N.keepMapInPlaceU -let keepMapInPlace = N.keepMapInPlace -let toArray = N.toArray -let copy = N.copy -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let rec copyBucketReHash = (~hash, ~h_buckets, ~ndata_tail, old_bucket) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(hash(. cell.N.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucketReHash(~hash, ~h_buckets, ~ndata_tail, cell.N.next) - } - -let resize = (~hash, h) => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.C.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucketReHash(~hash, ~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.N.next = C.emptyOpt - } - } - } -} - -let rec replaceInBucket = (~eq, key, info, cell) => - if eq(. cell.N.key, key) { - cell.N.value = info - false - } else { - switch C.toOpt(cell.N.next) { - | None => true - | Some(cell) => replaceInBucket(~eq, key, info, cell) - } - } - -let set0 = (h, key, value, ~eq, ~hash) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(hash(. key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: C.emptyOpt})) - h.C.size = h.C.size + 1 - | Some(bucket) => - if replaceInBucket(~eq, key, value, bucket) { - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: l})) - h.C.size = h.C.size + 1 - } - } - if h.C.size > lsl(buckets_len, 1) { - resize(~hash, h) - } -} - -/* if `key` already exists, replace it, otherwise add it - Here we add it to the head, it could be tail -*/ -let set = (h, key, value) => - set0(h, key, value, ~eq=Belt_Id.getEqInternal(h.C.eq), ~hash=Belt_Id.getHashInternal(h.C.hash)) - -let rec removeInBucket = (h, h_buckets, i, key, prec, bucket, ~eq) => - switch C.toOpt(bucket) { - | None => () - | Some(cell) => - let cell_next = cell.N.next - if eq(. cell.N.key, key) { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - removeInBucket(~eq, h, h_buckets, i, key, cell, cell_next) - } - } - -let remove = (h, key) => { - let h_buckets = h.C.buckets - let i = land(Belt_Id.getHashInternal(h.C.hash)(. key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, i) - switch C.toOpt(bucket) { - | None => () - | Some(cell) => - let eq = Belt_Id.getEqInternal(h.C.eq) - if eq(. cell.N.key, key) { - A.setUnsafe(h_buckets, i, cell.N.next) - h.C.size = h.C.size - 1 - } else { - removeInBucket(~eq, h, h_buckets, i, key, cell, cell.N.next) - } - } -} - -let rec getAux = (~eq, key, buckets) => - switch C.toOpt(buckets) { - | None => None - | Some(cell) => - if eq(. key, cell.N.key) { - Some(cell.N.value) - } else { - getAux(~eq, key, cell.N.next) - } - } - -let get = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(Belt_Id.getHashInternal(h.C.hash)(. key), A.length(h_buckets) - 1) - switch C.toOpt(A.getUnsafe(h_buckets, nid)) { - | None => None - | Some(cell1: N.bucket<_>) => - let eq = Belt_Id.getEqInternal(h.C.eq) - if eq(. key, cell1.key) { - Some(cell1.value) - } else { - switch C.toOpt(cell1.N.next) { - | None => None - | Some(cell2) => - if eq(. key, cell2.key) { - Some(cell2.value) - } else { - switch C.toOpt(cell2.next) { - | None => None - | Some(cell3) => - if eq(. key, cell3.key) { - Some(cell3.value) - } else { - getAux(~eq, key, cell3.next) - } - } - } - } - } - } -} - -let rec memInBucket = (key, cell, ~eq) => - eq(. cell.N.key, key) || - switch C.toOpt(cell.N.next) { - | None => false - | Some(nextCell) => memInBucket(~eq, key, nextCell) - } - -let has = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(Belt_Id.getHashInternal(h.C.hash)(. key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(~eq=Belt_Id.getEqInternal(h.C.eq), key, bucket) - } -} - -let make = (type key identity, ~hintSize, ~id: id) => { - module M = unpack(id) - C.make(~hash=M.hash, ~eq=M.eq, ~hintSize) -} - -let fromArray = (type a identity, arr, ~id: id) => { - module M = unpack(id) - let (hash, eq) = (M.hash, M.eq) - let len = A.length(arr) - let v = C.make(~hash, ~eq, ~hintSize=len) - let (eq, hash) = (Belt_Id.getEqInternal(eq), Belt_Id.getHashInternal(hash)) - for i in 0 to len - 1 { - let (key, value) = A.getUnsafe(arr, i) - set0(~eq, ~hash, v, key, value) - } - v -} - -let mergeMany = (h, arr) => { - let (hash, eq) = (Belt_Id.getHashInternal(h.C.hash), Belt_Id.getEqInternal(h.C.eq)) - let len = A.length(arr) - for i in 0 to len - 1 { - let (key, value) = A.getUnsafe(arr, i) - set0(h, ~eq, ~hash, key, value) - } -} - -module Int = Belt_HashMapInt -module String = Belt_HashMapString diff --git a/jscomp/others/belt_HashMap.resi b/jscomp/others/belt_HashMap.resi deleted file mode 100644 index 972b858..0000000 --- a/jscomp/others/belt_HashMap.resi +++ /dev/null @@ -1,467 +0,0 @@ -/* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -A **mutable** Hash map which allows customized [`hash`]() behavior. - -All data are parameterized by not its only type but also a unique identity in -the time of initialization, so that two _HashMaps of ints_ initialized with different -_hash_ functions will have different type. - -## Examples - -```rescript -type t = int -module I0 = unpack(Belt.Id.hashableU(~hash=(. a: t) => "&"(a, 0xff_ff), ~eq=(. a, b) => a == b)) -let s0: t<_, string, _> = make(~hintSize=40, ~id=module(I0)) - -module I1 = unpack(Belt.Id.hashableU(~hash=(. a: t) => "&"(a, 0xff), ~eq=(. a, b) => a == b)) -let s1: t<_, string, _> = make(~hintSize=40, ~id=module(I1)) -``` - -The invariant must be held: for two elements who are _equal_, -their hashed value should be the same - -Here the compiler would infer `s0` and `s1` having different type so that -it would not mix. - -## Examples - -```rescript -let s0: t -let s1: t -``` - -We can add elements to the collection: - -## Examples - -```rescript -let () = { - add(s1, 0, "3") - add(s1, 1, "3") -} -``` - -Since this is an mutable data strucure, `s1` will contain two pairs. -*/ - -/** Specalized when key type is `int`, more efficient than the generic type */ -module Int = Belt_HashMapInt - -/** Specalized when key type is `string`, more efficient than the generic type */ -module String = Belt_HashMapString - -/** The type of hash tables from type `'key` to type `'value`. */ -type t<'key, 'value, 'id> - -/** The identity needed for making an empty hash map. */ -type id<'a, 'id> = Belt_Id.hashable<'a, 'id> - -/** -`make(~hintSize=10, ~id)` creates a new map by taking in the comparator and `hintSize`. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let hMap = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) - -Belt.HashMap.set(hMap, 0, "a") -``` -*/ -let make: (~hintSize: int, ~id: id<'key, 'id>) => t<'key, 'value, 'id> - -/* TODO: allow randomization for security */ - -/** -Clears a hash table. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let hMap = Belt.HashMap.fromArray([(1, "1")], ~id=module(IntHash)) -Belt.HashMap.clear(hMap) -Belt.HashMap.isEmpty(hMap) == true -``` -*/ -let clear: t<'key, 'value, 'id> => unit - -/** -`isEmpty(m)` checks whether a hash map is empty. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -Belt.HashMap.isEmpty(Belt.HashMap.fromArray([(1, "1")], ~id=module(IntHash))) == false -``` -*/ -let isEmpty: t<_> => bool - -/** -`set(hMap, k, v)` if `k` does not exist, add the binding `k,v`, otherwise, update the old value with the new `v`. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntHash)) - -Belt.HashMap.set(s0, 2, "3") - -Belt.HashMap.valuesToArray(s0) == ["1", "3", "3"] -``` -*/ -let set: (t<'key, 'value, 'id>, 'key, 'value) => unit - -/** -Creates copy of a hash map. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntHash)) -let s1 = Belt.HashMap.copy(s0) - -Belt.HashMap.set(s0, 2, "3") - -Belt.HashMap.get(s0, 2) != Belt.HashMap.get(s1, 2) -``` -*/ -let copy: t<'key, 'value, 'id> => t<'key, 'value, 'id> - -/** -Returns value bound under specific key. If values not exist returns `None`. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") - -Belt.HashMap.get(s0, 1) == Some("value1") -Belt.HashMap.get(s0, 2) == None -``` -*/ -let get: (t<'key, 'value, 'id>, 'key) => option<'value> - -/** -Checks if `x` is bound in `tbl`. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") - -Belt.HashMap.has(s0, 1) == true -Belt.HashMap.has(s0, 2) == false -``` -*/ -let has: (t<'key, 'value, 'id>, 'key) => bool - -/** -If bound exists, removes it from the hash map. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.remove(s0, 1) -Belt.HashMap.has(s0, 1) == false -``` -*/ -let remove: (t<'key, 'value, 'id>, 'key) => unit - -/** Same as [forEach](#forEach) but takes uncurried function. */ -let forEachU: (t<'key, 'value, 'id>, (. 'key, 'value) => unit) => unit - -/** -`forEach(tbl, f)` applies `f` to all bindings in table `tbl`. `f` receives the key as first argument, and the associated value as second argument. Each binding is presented exactly once to `f`. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.forEach(s0, (key, value) => Js.log2(key, value)) -// prints (1, "value1") -``` -*/ -let forEach: (t<'key, 'value, 'id>, ('key, 'value) => unit) => unit - -let reduceU: (t<'key, 'value, 'id>, 'c, (. 'c, 'key, 'value) => 'c) => 'c -/** -`reduce(tbl, init, f)` computes `(f(kN, dN) ... (f(k1, d1, init))...)`, where `k1 ... kN` are the keys of all bindings in `tbl`, and `d1 ... dN` are the associated values. Each binding is presented exactly once to `f`. - -The order in which the bindings are passed to `f` is unspecified. However, if the table contains several bindings for the same key, they are passed to `f` in reverse order of introduction, that is, the most recent binding is passed first. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.set(s0, 2, "value2") - -Belt.HashMap.reduce(s0, "", (acc, key, value) => acc ++ (", " ++ value)) == "value1, value2" -``` -*/ -let reduce: (t<'key, 'value, 'id>, 'c, ('c, 'key, 'value) => 'c) => 'c - -/** Same as [keepMapInPlace](#keepMapInPlace) but takes uncurried function. */ -let keepMapInPlaceU: (t<'key, 'value, 'id>, (. 'key, 'value) => option<'value>) => unit - -/** -Filters out values for which function `f` returned `None`. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.set(s0, 2, "value2") - -Belt.HashMap.keepMapInPlace(s0, (key, value) => key == 1 ? None : Some(value)) -``` -*/ -let keepMapInPlace: (t<'key, 'value, 'id>, ('key, 'value) => option<'value>) => unit - -/** -`size(tbl)` returns the number of bindings in `tbl`. It takes constant time. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.set(s0, 2, "value2") - -Belt.HashMap.size(s0) == 2 -``` -*/ -let size: t<_> => int - -/** -Returns array of key value pairs. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.set(s0, 2, "value2") - -Belt.HashMap.toArray(s0) == [(1, "value1"), (2, "value2")] -``` -*/ -let toArray: t<'key, 'value, 'id> => array<('key, 'value)> - -/** -Returns array of keys. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.set(s0, 2, "value2") - -Belt.HashMap.keysToArray(s0) == [1, 2] -``` - */ -let keysToArray: t<'key, _, _> => array<'key> - -/** -Returns array of values. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(s0, 1, "value1") -Belt.HashMap.set(s0, 2, "value2") - -Belt.HashMap.valuesToArray(s0) == ["value1", "value2"] -``` -*/ -let valuesToArray: t<_, 'value, _> => array<'value> - -/** -Creates new hash map from array of pairs. - -Returns array of values. - -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let s0 = Belt.HashMap.fromArray([(1, "value1"), (2, "value2")], ~id=module(IntHash)) -Belt.HashMap.toArray(s0) == [(1, "value1"), (2, "value2")] -``` -*/ -let fromArray: (array<('key, 'value)>, ~id: id<'key, 'id>) => t<'key, 'value, 'id> - -/** -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) - -let hMap = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.mergeMany(hMap, [(1, "1"), (2, "2")]) -``` -*/ -let mergeMany: (t<'key, 'value, 'id>, array<('key, 'value)>) => unit - -/** -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) -let hMap = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(hMap, 1, "1") - -Belt.HashMap.getBucketHistogram(hMap) -``` -*/ -let getBucketHistogram: t<_> => array - -/** -## Examples - -```rescript -module IntHash = Belt.Id.MakeHashable({ - type t = int - let hash = a => a - let eq = (a, b) => a == b -}) -let hMap = Belt.HashMap.make(~hintSize=10, ~id=module(IntHash)) -Belt.HashMap.set(hMap, 1, "1") - -Belt.HashMap.logStats(hMap) -``` -*/ -let logStats: t<_> => unit diff --git a/jscomp/others/belt_HashMapInt.res b/jscomp/others/belt_HashMapInt.res deleted file mode 100644 index 0c19f8c..0000000 --- a/jscomp/others/belt_HashMapInt.res +++ /dev/null @@ -1,215 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* ********************************************************************* */ - -/* Adapted by Hongbo Zhang, Authors of ReScript 2017 */ - -type key = int -type seed = int -external caml_hash_mix_int: (seed, int) => seed = "?hash_mix_int" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_int(0, s)) - -module N = Belt_internalBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type t<'b> = N.t - -let rec copyBucketReHash = (~h_buckets, ~ndata_tail, old_bucket: C.opt>) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(hash(cell.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucketReHash(~h_buckets, ~ndata_tail, cell.next) - } - -let resize = h => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.C.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucketReHash(~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.next = C.emptyOpt - } - } - } -} - -let rec replaceInBucket = (key: key, info, cell) => - if cell.N.key == key { - cell.N.value = info - false - } else { - switch C.toOpt(cell.next) { - | None => true - | Some(cell) => replaceInBucket(key, info, cell) - } - } - -let set = (h, key: key, value) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(hash(key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: C.emptyOpt})) - h.C.size = h.C.size + 1 - | Some(bucket) => - if replaceInBucket(key, value, bucket) { - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: l})) - h.C.size = h.C.size + 1 - } - } - if h.C.size > lsl(buckets_len, 1) { - resize(h) - } -} - -let rec removeInBucket = (h, h_buckets, i, key: key, prec, buckets) => - switch C.toOpt(buckets) { - | None => () - | Some(cell) => - let cell_next = cell.N.next - if cell.N.key == key { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - removeInBucket(h, h_buckets, i, key, cell, cell_next) - } - } - -let remove = (h, key) => { - let h_buckets = h.C.buckets - let i = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, i) - switch C.toOpt(bucket) { - | None => () - | Some(cell) => - if cell.N.key == key { - A.setUnsafe(h_buckets, i, cell.next) - h.C.size = h.C.size - 1 - } else { - removeInBucket(h, h_buckets, i, key, cell, cell.next) - } - } -} - -let rec getAux = (key: key, buckets) => - switch C.toOpt(buckets) { - | None => None - | Some(cell) => - if key == cell.N.key { - Some(cell.N.value) - } else { - getAux(key, cell.next) - } - } - -let get = (h, key: key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - switch C.toOpt(A.getUnsafe(h_buckets, nid)) { - | None => None - | Some(cell1) => - if key == cell1.N.key { - Some(cell1.N.value) - } else { - switch C.toOpt(cell1.N.next) { - | None => None - | Some(cell2) => - if key == cell2.N.key { - Some(cell2.N.value) - } else { - switch C.toOpt(cell2.N.next) { - | None => None - | Some(cell3) => - if key == cell3.N.key { - Some(cell3.N.value) - } else { - getAux(key, cell3.N.next) - } - } - } - } - } - } -} - -let rec memInBucket = (key: key, cell) => - cell.N.key == key || - switch C.toOpt(cell.next) { - | None => false - | Some(nextCell) => memInBucket(key, nextCell) - } - -let has = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(key, bucket) - } -} - -let make = (~hintSize) => C.make(~hintSize, ~hash=(), ~eq=()) -let clear = C.clear -let size = h => h.C.size -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let logStats = N.logStats -let keepMapInPlaceU = N.keepMapInPlaceU -let keepMapInPlace = N.keepMapInPlace -let toArray = N.toArray -let copy = N.copy -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let fromArray = arr => { - let len = A.length(arr) - let v = make(~hintSize=len) - for i in 0 to len - 1 { - let (k, value) = A.getUnsafe(arr, i) - set(v, k, value) - } - v -} - -/* TOOD: optimize heuristics for resizing */ -let mergeMany = (h, arr) => { - let len = A.length(arr) - for i in 0 to len - 1 { - let (k, v) = A.getUnsafe(arr, i) - set(h, k, v) - } -} diff --git a/jscomp/others/belt_HashMapInt.resi b/jscomp/others/belt_HashMapInt.resi deleted file mode 100644 index 67ea502..0000000 --- a/jscomp/others/belt_HashMapInt.resi +++ /dev/null @@ -1,41 +0,0 @@ -type key = int - -type t<'b> - -let make: (~hintSize: int) => t<'b> - -let clear: t<'b> => unit - -let isEmpty: t<_> => bool - -/** -`setDone(tbl, k, v)` if `k` does not exist, add the binding `k,v`, otherwise, -update the old value with the new `v` -*/ -let set: (t<'a>, key, 'a) => unit - -let copy: t<'a> => t<'a> -let get: (t<'a>, key) => option<'a> - -let has: (t<'b>, key) => bool - -let remove: (t<'a>, key) => unit - -let forEachU: (t<'b>, (. key, 'b) => unit) => unit -let forEach: (t<'b>, (key, 'b) => unit) => unit - -let reduceU: (t<'b>, 'c, (. 'c, key, 'b) => 'c) => 'c -let reduce: (t<'b>, 'c, ('c, key, 'b) => 'c) => 'c - -let keepMapInPlaceU: (t<'a>, (. key, 'a) => option<'a>) => unit -let keepMapInPlace: (t<'a>, (key, 'a) => option<'a>) => unit - -let size: t<_> => int - -let toArray: t<'a> => array<(key, 'a)> -let keysToArray: t<'a> => array -let valuesToArray: t<'a> => array<'a> -let fromArray: array<(key, 'a)> => t<'a> -let mergeMany: (t<'a>, array<(key, 'a)>) => unit -let getBucketHistogram: t<_> => array -let logStats: t<_> => unit diff --git a/jscomp/others/belt_HashMapString.res b/jscomp/others/belt_HashMapString.res deleted file mode 100644 index c4959dd..0000000 --- a/jscomp/others/belt_HashMapString.res +++ /dev/null @@ -1,215 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* ********************************************************************* */ - -/* Adapted by Hongbo Zhang, Authors of ReScript 2017 */ - -type key = string -type seed = int -external caml_hash_mix_string: (seed, string) => seed = "?hash_mix_string" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_string(0, s)) - -module N = Belt_internalBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type t<'b> = N.t - -let rec copyBucketReHash = (~h_buckets, ~ndata_tail, old_bucket: C.opt>) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(hash(cell.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucketReHash(~h_buckets, ~ndata_tail, cell.next) - } - -let resize = h => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.C.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucketReHash(~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.next = C.emptyOpt - } - } - } -} - -let rec replaceInBucket = (key: key, info, cell) => - if cell.N.key == key { - cell.N.value = info - false - } else { - switch C.toOpt(cell.next) { - | None => true - | Some(cell) => replaceInBucket(key, info, cell) - } - } - -let set = (h, key: key, value) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(hash(key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: C.emptyOpt})) - h.C.size = h.C.size + 1 - | Some(bucket) => - if replaceInBucket(key, value, bucket) { - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: l})) - h.C.size = h.C.size + 1 - } - } - if h.C.size > lsl(buckets_len, 1) { - resize(h) - } -} - -let rec removeInBucket = (h, h_buckets, i, key: key, prec, buckets) => - switch C.toOpt(buckets) { - | None => () - | Some(cell) => - let cell_next = cell.N.next - if cell.N.key == key { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - removeInBucket(h, h_buckets, i, key, cell, cell_next) - } - } - -let remove = (h, key) => { - let h_buckets = h.C.buckets - let i = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, i) - switch C.toOpt(bucket) { - | None => () - | Some(cell) => - if cell.N.key == key { - A.setUnsafe(h_buckets, i, cell.next) - h.C.size = h.C.size - 1 - } else { - removeInBucket(h, h_buckets, i, key, cell, cell.next) - } - } -} - -let rec getAux = (key: key, buckets) => - switch C.toOpt(buckets) { - | None => None - | Some(cell) => - if key == cell.N.key { - Some(cell.N.value) - } else { - getAux(key, cell.next) - } - } - -let get = (h, key: key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - switch C.toOpt(A.getUnsafe(h_buckets, nid)) { - | None => None - | Some(cell1) => - if key == cell1.N.key { - Some(cell1.N.value) - } else { - switch C.toOpt(cell1.N.next) { - | None => None - | Some(cell2) => - if key == cell2.N.key { - Some(cell2.N.value) - } else { - switch C.toOpt(cell2.N.next) { - | None => None - | Some(cell3) => - if key == cell3.N.key { - Some(cell3.N.value) - } else { - getAux(key, cell3.N.next) - } - } - } - } - } - } -} - -let rec memInBucket = (key: key, cell) => - cell.N.key == key || - switch C.toOpt(cell.next) { - | None => false - | Some(nextCell) => memInBucket(key, nextCell) - } - -let has = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(key, bucket) - } -} - -let make = (~hintSize) => C.make(~hintSize, ~hash=(), ~eq=()) -let clear = C.clear -let size = h => h.C.size -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let logStats = N.logStats -let keepMapInPlaceU = N.keepMapInPlaceU -let keepMapInPlace = N.keepMapInPlace -let toArray = N.toArray -let copy = N.copy -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let fromArray = arr => { - let len = A.length(arr) - let v = make(~hintSize=len) - for i in 0 to len - 1 { - let (k, value) = A.getUnsafe(arr, i) - set(v, k, value) - } - v -} - -/* TOOD: optimize heuristics for resizing */ -let mergeMany = (h, arr) => { - let len = A.length(arr) - for i in 0 to len - 1 { - let (k, v) = A.getUnsafe(arr, i) - set(h, k, v) - } -} diff --git a/jscomp/others/belt_HashMapString.resi b/jscomp/others/belt_HashMapString.resi deleted file mode 100644 index be4cf46..0000000 --- a/jscomp/others/belt_HashMapString.resi +++ /dev/null @@ -1,41 +0,0 @@ -type key = string - -type t<'b> - -let make: (~hintSize: int) => t<'b> - -let clear: t<'b> => unit - -let isEmpty: t<_> => bool - -/** -`setDone(tbl, k, v)` if `k` does not exist, add the binding `k,v`, otherwise, -update the old value with the new `v` -*/ -let set: (t<'a>, key, 'a) => unit - -let copy: t<'a> => t<'a> -let get: (t<'a>, key) => option<'a> - -let has: (t<'b>, key) => bool - -let remove: (t<'a>, key) => unit - -let forEachU: (t<'b>, (. key, 'b) => unit) => unit -let forEach: (t<'b>, (key, 'b) => unit) => unit - -let reduceU: (t<'b>, 'c, (. 'c, key, 'b) => 'c) => 'c -let reduce: (t<'b>, 'c, ('c, key, 'b) => 'c) => 'c - -let keepMapInPlaceU: (t<'a>, (. key, 'a) => option<'a>) => unit -let keepMapInPlace: (t<'a>, (key, 'a) => option<'a>) => unit - -let size: t<_> => int - -let toArray: t<'a> => array<(key, 'a)> -let keysToArray: t<'a> => array -let valuesToArray: t<'a> => array<'a> -let fromArray: array<(key, 'a)> => t<'a> -let mergeMany: (t<'a>, array<(key, 'a)>) => unit -let getBucketHistogram: t<_> => array -let logStats: t<_> => unit diff --git a/jscomp/others/belt_HashSet.res b/jscomp/others/belt_HashSet.res deleted file mode 100644 index f4d0a70..0000000 --- a/jscomp/others/belt_HashSet.res +++ /dev/null @@ -1,188 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Int = Belt_HashSetInt - -module String = Belt_HashSetString - -module N = Belt_internalSetBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type eq<'a, 'id> = Belt_Id.eq<'a, 'id> -type hash<'a, 'id> = Belt_Id.hash<'a, 'id> -type id<'a, 'id> = Belt_Id.hashable<'a, 'id> - -type t<'a, 'id> = N.t, eq<'a, 'id>, 'a> - -let rec copyBucket = (~hash, ~h_buckets, ~ndata_tail, old_bucket) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(Belt_Id.getHashInternal(hash)(. cell.N.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucket(~hash, ~h_buckets, ~ndata_tail, cell.N.next) - } - -let tryDoubleResize = (~hash, h) => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucket(~hash, ~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.N.next = C.emptyOpt - } - } - } -} - -let rec removeBucket = (~eq, h, h_buckets, i, key, prec, cell) => { - let cell_next = cell.N.next - if Belt_Id.getEqInternal(eq)(. cell.N.key, key) { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - switch C.toOpt(cell_next) { - | None => () - | Some(cell_next) => removeBucket(~eq, h, h_buckets, i, key, cell, cell_next) - } - } -} - -let remove = (h, key) => { - let eq = h.C.eq - let h_buckets = h.C.buckets - let i = land(Belt_Id.getHashInternal(h.C.hash)(. key), A.length(h_buckets) - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => () - | Some(cell) => - let next_cell = cell.N.next - if Belt_Id.getEqInternal(eq)(. cell.N.key, key) { - h.C.size = h.C.size - 1 - A.setUnsafe(h_buckets, i, next_cell) - } else { - switch C.toOpt(next_cell) { - | None => () - | Some(next_cell) => removeBucket(~eq, h, h_buckets, i, key, cell, next_cell) - } - } - } -} - -let rec addBucket = (h, key, cell, ~eq) => - if !Belt_Id.getEqInternal(eq)(. cell.N.key, key) { - let n = cell.N.next - switch C.toOpt(n) { - | None => - h.C.size = h.C.size + 1 - cell.N.next = C.return({N.key, next: C.emptyOpt}) - | Some(n) => addBucket(~eq, h, key, n) - } - } - -let add0 = (h, key, ~hash, ~eq) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(Belt_Id.getHashInternal(hash)(. key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - h.C.size = h.C.size + 1 - A.setUnsafe(h_buckets, i, C.return({N.key, next: C.emptyOpt})) - | Some(cell) => addBucket(~eq, h, key, cell) - } - if h.C.size > lsl(buckets_len, 1) { - tryDoubleResize(~hash, h) - } -} - -let add = (h, key) => add0(~hash=h.C.hash, ~eq=h.C.eq, h, key) - -let rec memInBucket = (~eq, key, cell) => - Belt_Id.getEqInternal(eq)(. cell.N.key, key) || - switch C.toOpt(cell.N.next) { - | None => false - | Some(nextCell) => memInBucket(~eq, key, nextCell) - } - -let has = (h, key) => { - let (eq, h_buckets) = (h.C.eq, h.C.buckets) - let nid = land(Belt_Id.getHashInternal(h.C.hash)(. key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(~eq, key, bucket) - } -} - -let make = (type value identity, ~hintSize, ~id: id) => { - module M = unpack(id) - C.make(~hintSize, ~hash=M.hash, ~eq=M.eq) -} - -let clear = C.clear -let size = h => h.C.size -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let logStats = N.logStats -let toArray = N.toArray -let copy = N.copy -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let fromArray = (type a identity, arr, ~id: id) => { - module M = unpack(id) - let (eq, hash) = (M.eq, M.hash) - let len = A.length(arr) - let v = C.make(~hintSize=len, ~hash, ~eq) - for i in 0 to len - 1 { - add0(~eq, ~hash, v, A.getUnsafe(arr, i)) - } - v -} - -let mergeMany = (h, arr) => { - let (eq, hash) = (h.C.eq, h.hash) - let len = A.length(arr) - for i in 0 to len - 1 { - add0(h, ~eq, ~hash, A.getUnsafe(arr, i)) - } -} diff --git a/jscomp/others/belt_HashSet.resi b/jscomp/others/belt_HashSet.resi deleted file mode 100644 index 6055194..0000000 --- a/jscomp/others/belt_HashSet.resi +++ /dev/null @@ -1,122 +0,0 @@ -/* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -A **mutable** Hash set which allows customized `hash` behavior. - -All data are parameterized by not its only type but also a unique identity in -the time of initialization, so that two _HashSets of ints_ initialized with -different _hash_ functions will have different type. - -## Examples - -```rescript -module I0 = unpack( - Belt.Id.hashableU( - ~hash=(. a: int) => land(a, 65535), - ~eq=(. a, b) => a == b, - ) -) - -let s0 = Belt.HashSet.make(~id=module(I0), ~hintSize=40) - -module I1 = unpack( - Belt.Id.hashableU( - ~hash=(. a: int) => land(a, 255), - ~eq=(. a, b) => a == b, - ) -) - -let s1 = Belt.HashSet.make(~id=module(I1), ~hintSize=40) - -Belt.HashSet.add(s1, 0) -Belt.HashSet.add(s1, 1) -``` - -The invariant must be held: for two elements who are equal, their hashed -value should be the same. - -Here the compiler would infer `s0` and `s1` having different type so that it -would not mix. - -## Examples - -```rescript -let s0: Belt.HashSet.t -let s1: Belt.HashSet.t -``` - -We can add elements to the collection (see last two lines in the example -above). Since this is an mutable data structure, `s1` will contain two pairs. -*/ - -/** Specalized when key type is `int`, more efficient than the generic type */ -module Int = Belt_HashSetInt - -/** Specalized when key type is `string`, more efficient than the generic type */ -module String = Belt_HashSetString - -/* TODO: add a poly module - module Poly = Belt_HashSetPoly - challenge: - - generic equal handles JS data structure - - eq/hash consistent -*/ - -type t<'a, 'id> - -/** The type of hash tables from type `'a` to type `'b`. */ -type id<'a, 'id> = Belt_Id.hashable<'a, 'id> - -let make: (~hintSize: int, ~id: id<'a, 'id>) => t<'a, 'id> -let clear: t<'a, 'id> => unit -let isEmpty: t<_> => bool - -let add: (t<'a, 'id>, 'a) => unit - -let copy: t<'a, 'id> => t<'a, 'id> - -let has: (t<'a, 'id>, 'a) => bool - -let remove: (t<'a, 'id>, 'a) => unit - -let forEachU: (t<'a, 'id>, (. 'a) => unit) => unit -/** Order unspecified. */ -let forEach: (t<'a, 'id>, 'a => unit) => unit - -let reduceU: (t<'a, 'id>, 'c, (. 'c, 'a) => 'c) => 'c -/** Order unspecified. */ -let reduce: (t<'a, 'id>, 'c, ('c, 'a) => 'c) => 'c - -let size: t<'a, 'id> => int - -let logStats: t<_> => unit - -let toArray: t<'a, 'id> => array<'a> - -let fromArray: (array<'a>, ~id: id<'a, 'id>) => t<'a, 'id> - -let mergeMany: (t<'a, 'id>, array<'a>) => unit - -let getBucketHistogram: t<_> => array diff --git a/jscomp/others/belt_HashSetInt.res b/jscomp/others/belt_HashSetInt.res deleted file mode 100644 index f8ad65c..0000000 --- a/jscomp/others/belt_HashSetInt.res +++ /dev/null @@ -1,154 +0,0 @@ -type key = int -type seed = int -external caml_hash_mix_int: (seed, int) => seed = "?hash_mix_int" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_int(0, s)) - -module N = Belt_internalSetBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type t = N.t - -let rec copyBucket = (~h_buckets, ~ndata_tail, old_bucket) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(hash(cell.N.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucket(~h_buckets, ~ndata_tail, cell.N.next) - } - -let tryDoubleResize = h => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.C.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucket(~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.N.next = C.emptyOpt - } - } - } -} - -let rec removeBucket = (h, h_buckets, i, key: key, prec, cell) => { - let cell_next = cell.N.next - if cell.N.key == key { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - switch C.toOpt(cell_next) { - | None => () - | Some(cell_next) => removeBucket(h, h_buckets, i, key, cell, cell_next) - } - } -} - -let remove = (h, key: key) => { - let h_buckets = h.C.buckets - let i = land(hash(key), A.length(h_buckets) - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => () - | Some(cell) => - let next_cell = cell.N.next - if cell.N.key == key { - h.C.size = h.C.size - 1 - A.setUnsafe(h_buckets, i, next_cell) - } else { - switch C.toOpt(next_cell) { - | None => () - | Some(next_cell) => removeBucket(h, h_buckets, i, key, cell, next_cell) - } - } - } -} - -let rec addBucket = (h, key: key, cell) => - if cell.N.key != key { - let n = cell.N.next - switch C.toOpt(n) { - | None => - h.C.size = h.C.size + 1 - cell.N.next = C.return({N.key, next: C.emptyOpt}) - | Some(n) => addBucket(h, key, n) - } - } - -let add = (h, key: key) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(hash(key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - A.setUnsafe(h_buckets, i, C.return({N.key, next: C.emptyOpt})) - h.C.size = h.C.size + 1 - | Some(cell) => addBucket(h, key, cell) - } - if h.C.size > lsl(buckets_len, 1) { - tryDoubleResize(h) - } -} - -let rec memInBucket = (key: key, cell) => - cell.N.key == key || - switch C.toOpt(cell.N.next) { - | None => false - | Some(nextCell) => memInBucket(key, nextCell) - } - -let has = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(key, bucket) - } -} - -let make = (~hintSize) => C.make(~hintSize, ~hash=(), ~eq=()) - -let clear = C.clear -let size = h => h.C.size -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let logStats = N.logStats -let toArray = N.toArray -let copy = N.copy -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let fromArray = arr => { - let len = A.length(arr) - let v = C.make(~hintSize=len, ~hash=(), ~eq=()) - for i in 0 to len - 1 { - add(v, A.getUnsafe(arr, i)) - } - v -} - -/* TOOD: optimize heuristics for resizing */ -let mergeMany = (h, arr) => { - let len = A.length(arr) - for i in 0 to len - 1 { - add(h, A.getUnsafe(arr, i)) - } -} diff --git a/jscomp/others/belt_HashSetInt.resi b/jscomp/others/belt_HashSetInt.resi deleted file mode 100644 index 05325e8..0000000 --- a/jscomp/others/belt_HashSetInt.resi +++ /dev/null @@ -1,68 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module is [`Belt.HashSet`]() specialized with key type to be a primitive type. - -It is more efficient in general, the API is the same with [`Belt.HashSet`]() except its key type is fixed, -and identity is not needed(using the built-in one) - -**See** [`Belt.HashSet`]() -*/ - -type key = int - -type t - -let make: (~hintSize: int) => t - -let clear: t => unit - -let isEmpty: t => bool - -let add: (t, key) => unit - -let copy: t => t - -let has: (t, key) => bool - -let remove: (t, key) => unit - -let forEachU: (t, (. key) => unit) => unit -let forEach: (t, key => unit) => unit - -let reduceU: (t, 'c, (. 'c, key) => 'c) => 'c -let reduce: (t, 'c, ('c, key) => 'c) => 'c - -let size: t => int - -let logStats: t => unit - -let toArray: t => array - -let fromArray: array => t - -let mergeMany: (t, array) => unit - -let getBucketHistogram: t => array diff --git a/jscomp/others/belt_HashSetString.res b/jscomp/others/belt_HashSetString.res deleted file mode 100644 index be19839..0000000 --- a/jscomp/others/belt_HashSetString.res +++ /dev/null @@ -1,154 +0,0 @@ -type key = string -type seed = int -external caml_hash_mix_string: (seed, string) => seed = "?hash_mix_string" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_string(0, s)) - -module N = Belt_internalSetBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type t = N.t - -let rec copyBucket = (~h_buckets, ~ndata_tail, old_bucket) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(hash(cell.N.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucket(~h_buckets, ~ndata_tail, cell.N.next) - } - -let tryDoubleResize = h => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.C.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucket(~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.N.next = C.emptyOpt - } - } - } -} - -let rec removeBucket = (h, h_buckets, i, key: key, prec, cell) => { - let cell_next = cell.N.next - if cell.N.key == key { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - switch C.toOpt(cell_next) { - | None => () - | Some(cell_next) => removeBucket(h, h_buckets, i, key, cell, cell_next) - } - } -} - -let remove = (h, key: key) => { - let h_buckets = h.C.buckets - let i = land(hash(key), A.length(h_buckets) - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => () - | Some(cell) => - let next_cell = cell.N.next - if cell.N.key == key { - h.C.size = h.C.size - 1 - A.setUnsafe(h_buckets, i, next_cell) - } else { - switch C.toOpt(next_cell) { - | None => () - | Some(next_cell) => removeBucket(h, h_buckets, i, key, cell, next_cell) - } - } - } -} - -let rec addBucket = (h, key: key, cell) => - if cell.N.key != key { - let n = cell.N.next - switch C.toOpt(n) { - | None => - h.C.size = h.C.size + 1 - cell.N.next = C.return({N.key, next: C.emptyOpt}) - | Some(n) => addBucket(h, key, n) - } - } - -let add = (h, key: key) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(hash(key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - A.setUnsafe(h_buckets, i, C.return({N.key, next: C.emptyOpt})) - h.C.size = h.C.size + 1 - | Some(cell) => addBucket(h, key, cell) - } - if h.C.size > lsl(buckets_len, 1) { - tryDoubleResize(h) - } -} - -let rec memInBucket = (key: key, cell) => - cell.N.key == key || - switch C.toOpt(cell.N.next) { - | None => false - | Some(nextCell) => memInBucket(key, nextCell) - } - -let has = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(key, bucket) - } -} - -let make = (~hintSize) => C.make(~hintSize, ~hash=(), ~eq=()) - -let clear = C.clear -let size = h => h.C.size -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let logStats = N.logStats -let toArray = N.toArray -let copy = N.copy -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let fromArray = arr => { - let len = A.length(arr) - let v = C.make(~hintSize=len, ~hash=(), ~eq=()) - for i in 0 to len - 1 { - add(v, A.getUnsafe(arr, i)) - } - v -} - -/* TOOD: optimize heuristics for resizing */ -let mergeMany = (h, arr) => { - let len = A.length(arr) - for i in 0 to len - 1 { - add(h, A.getUnsafe(arr, i)) - } -} diff --git a/jscomp/others/belt_HashSetString.resi b/jscomp/others/belt_HashSetString.resi deleted file mode 100644 index 3c2532f..0000000 --- a/jscomp/others/belt_HashSetString.resi +++ /dev/null @@ -1,68 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module is [`Belt.HashSet`]() specialized with key type to be a primitive type. - -It is more efficient in general, the API is the same with [`Belt.HashSet`]() except its key type is fixed, -and identity is not needed(using the built-in one) - -**See** [`Belt.HashSet`]() -*/ - -type key = string - -type t - -let make: (~hintSize: int) => t - -let clear: t => unit - -let isEmpty: t => bool - -let add: (t, key) => unit - -let copy: t => t - -let has: (t, key) => bool - -let remove: (t, key) => unit - -let forEachU: (t, (. key) => unit) => unit -let forEach: (t, key => unit) => unit - -let reduceU: (t, 'c, (. 'c, key) => 'c) => 'c -let reduce: (t, 'c, ('c, key) => 'c) => 'c - -let size: t => int - -let logStats: t => unit - -let toArray: t => array - -let fromArray: array => t - -let mergeMany: (t, array) => unit - -let getBucketHistogram: t => array diff --git a/jscomp/others/belt_Id.res b/jscomp/others/belt_Id.res deleted file mode 100644 index 7fc993e..0000000 --- a/jscomp/others/belt_Id.res +++ /dev/null @@ -1,137 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type hash<'a, 'id> = (. 'a) => int -type eq<'a, 'id> = (. 'a, 'a) => bool -type cmp<'a, 'id> = (. 'a, 'a) => int - -external getHashInternal: hash<'a, 'id> => (. 'a) => int = "%identity" -external getEqInternal: eq<'a, 'id> => (. 'a, 'a) => bool = "%identity" -external getCmpInternal: cmp<'a, 'id> => (. 'a, 'a) => int = "%identity" - -module type Comparable = { - type identity - type t - let cmp: cmp -} - -type comparable<'key, 'id> = module(Comparable with type t = 'key and type identity = 'id) - -module MakeComparableU = ( - M: { - type t - let cmp: (. t, t) => int - }, -) => { - type identity - include M -} - -module MakeComparable = ( - M: { - type t - let cmp: (t, t) => int - }, -) => { - type identity - type t = M.t - /* see https://github.com/rescript-lang/rescript-compiler/pull/2589/files/5ef875b7665ee08cfdc59af368fc52bac1fe9130#r173330825 */ - let cmp = { - let cmp = M.cmp - (. a, b) => cmp(a, b) - } -} - -let comparableU = (type key, ~cmp): module(Comparable with type t = key) => - module( - MakeComparableU({ - type t = key - let cmp = cmp - }) - ) - -let comparable = (type key, ~cmp) => { - module N = MakeComparable({ - type t = key - let cmp = cmp - }) - module(N: Comparable with type t = key) -} - -module type Hashable = { - type identity - type t - let hash: hash - let eq: eq -} - -type hashable<'key, 'id> = module(Hashable with type t = 'key and type identity = 'id) - -module MakeHashableU = ( - M: { - type t - let hash: (. t) => int - let eq: (. t, t) => bool - }, -) => { - type identity - include M -} - -module MakeHashable = ( - M: { - type t - let hash: t => int - let eq: (t, t) => bool - }, -) => { - type identity - type t = M.t - let hash = { - let hash = M.hash - (. a) => hash(a) - } - let eq = { - let eq = M.eq - (. a, b) => eq(a, b) - } -} - -let hashableU = (type key, ~hash, ~eq): module(Hashable with type t = key) => - module( - MakeHashableU({ - type t = key - let hash = hash - let eq = eq - }) - ) - -let hashable = (type key, ~hash, ~eq) => { - module N = MakeHashable({ - type t = key - let hash = hash - let eq = eq - }) - module(N: Hashable with type t = key) -} diff --git a/jscomp/others/belt_Id.resi b/jscomp/others/belt_Id.resi deleted file mode 100644 index 72aecc4..0000000 --- a/jscomp/others/belt_Id.resi +++ /dev/null @@ -1,149 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -[`Belt.Id`]() - -Provide utiliites to create identified comparators or hashes for -data structures used below. - -It create a unique identifer per module of functions so that different data structures with slightly different -comparison functions won't mix. -*/ - -/** -`('a, 'id) hash` - -Its runtime represenation is a `hash` function, but signed with a -type parameter, so that different hash functions type mismatch -*/ -type hash<'a, 'id> - -/** -`('a, 'id) eq` - -Its runtime represenation is an `eq` function, but signed with a -type parameter, so that different hash functions type mismatch -*/ -type eq<'a, 'id> - -/** -`('a,'id) cmp` - -Its runtime representation is a `cmp` function, but signed with a -type parameter, so that different hash functions type mismatch -*/ -type cmp<'a, 'id> - -module type Comparable = { - type identity - type t - let cmp: cmp -} - -/** -`('key, 'id) cmparable` is a module of functions, here it only includes `cmp`. - -Unlike normal functions, when created, it comes with a unique identity (guaranteed -by the type system). - -It can be created using function [`comparableU`]() or [`comparable`](). - -The idea of a unique identity when created is that it makes sure two sets would type -mismatch if they use different comparison function -*/ -type comparable<'key, 'id> = module(Comparable with type t = 'key and type identity = 'id) - -module MakeComparableU: ( - M: { - type t - let cmp: (. t, t) => int - }, -) => (Comparable with type t = M.t) - -module MakeComparable: ( - M: { - type t - let cmp: (t, t) => int - }, -) => (Comparable with type t = M.t) - -let comparableU: (~cmp: (. 'a, 'a) => int) => module(Comparable with type t = 'a) - -/** -## Examples - -```rescript -module C = ( - val Belt.Id.comparable ~cmp:(compare : int -> int -> int) -) -let m = Belt.Set.make(module C) -``` -Note that the name of C can not be ignored -*/ -let comparable: (~cmp: ('a, 'a) => int) => module(Comparable with type t = 'a) - -module type Hashable = { - type identity - type t - let hash: hash - let eq: eq -} - -/** -`('key, 'id) hashable` is a module of functions, here it only includes `hash`, `eq`. - -Unlike normal functions, when created, it comes with a unique identity (guaranteed -by the type system). - -It can be created using function [`hashableU`]() or [`hashable`](). - -The idea of a unique identity when created is that it makes sure two hash sets would type -mismatch if they use different comparison function -*/ -type hashable<'key, 'id> = module(Hashable with type t = 'key and type identity = 'id) - -module MakeHashableU: ( - M: { - type t - let hash: (. t) => int - let eq: (. t, t) => bool - }, -) => (Hashable with type t = M.t) - -module MakeHashable: ( - M: { - type t - let hash: t => int - let eq: (t, t) => bool - }, -) => (Hashable with type t = M.t) - -let hashableU: (~hash: (. 'a) => int, ~eq: (. 'a, 'a) => bool) => module(Hashable with type t = 'a) - -let hashable: (~hash: 'a => int, ~eq: ('a, 'a) => bool) => module(Hashable with type t = 'a) - -external getHashInternal: hash<'a, 'id> => (. 'a) => int = "%identity" -external getEqInternal: eq<'a, 'id> => (. 'a, 'a) => bool = "%identity" -external getCmpInternal: cmp<'a, 'id> => (. 'a, 'a) => int = "%identity" diff --git a/jscomp/others/belt_Int.res b/jscomp/others/belt_Int.res deleted file mode 100644 index fdf1423..0000000 --- a/jscomp/others/belt_Int.res +++ /dev/null @@ -1,51 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** [`Belt.Int`]() - Utilities for Int -*/ - -@val external isNaN: int => bool = "isNaN" - -external toFloat: int => float = "%identity" - -external fromFloat: float => int = "%intoffloat" - -@val external fromString: (string, @as(10) _) => int = "parseInt" - -let fromString = i => - switch fromString(i) { - | i if isNaN(i) => None - | i => Some(i) - } - -@val external toString: int => string = "String" - -external \"+": (int, int) => int = "%addint" - -external \"-": (int, int) => int = "%subint" - -external \"*": (int, int) => int = "%mulint" - -external \"/": (int, int) => int = "%divint" diff --git a/jscomp/others/belt_Int.resi b/jscomp/others/belt_Int.resi deleted file mode 100644 index 0d64b76..0000000 --- a/jscomp/others/belt_Int.resi +++ /dev/null @@ -1,120 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module includes convenience methods for handling `int` types. -*/ - -/** -Converts a given `int` to a `float`. - -## Examples - -```rescript -Js.log(Belt.Int.toFloat(1) === 1.0) /* true */ -``` -*/ -external toFloat: int => float = "%identity" - -/** -Converts a given `float` to an `int`. - -## Examples - -```rescript -Js.log(Belt.Int.fromFloat(1.0) === 1) /* true */ -``` -*/ -external fromFloat: float => int = "%intoffloat" - -/** -Converts a given `string` to an `int`. Returns `Some(int)` when the input is a number, `None` otherwise. - -## Examples - -```rescript -Js.log(Belt.Int.fromString("1") === Some(1)) /* true */ -``` -*/ -let fromString: string => option - -/** -Converts a given `int` to a `string`. Uses the JavaScript `String` constructor under the hood. - -## Examples - -```rescript -Js.log(Belt.Int.toString(1) === "1") /* true */ -``` -*/ -@val -external toString: int => string = "String" - -/** -Addition of two `int` values. Same as the addition from `Pervasives`. - -## Examples - -```rescript -open Belt.Int -Js.log(2 + 2 === 4) /* true */ -``` -*/ -external \"+": (int, int) => int = "%addint" - -/** -Subtraction of two `int` values. Same as the subtraction from `Pervasives`. - -## Examples - -```rescript -open Belt.Int -Js.log(2 - 1 === 1) /* true */ -``` -*/ -external \"-": (int, int) => int = "%subint" - -/** -Multiplication of two `int` values. Same as the multiplication from `Pervasives`. - -## Examples - -```rescript -open Belt.Int -Js.log(2 * 2 === 4) /* true */ -``` -*/ -external \"*": (int, int) => int = "%mulint" - -/** -Division of two `int` values. Same as the division from `Pervasives`. - -## Examples - -```rescript -open Belt.Int -Js.log(4 / 2 === 2); /* true */ -``` -*/ -external \"/": (int, int) => int = "%divint" diff --git a/jscomp/others/belt_List.res b/jscomp/others/belt_List.res deleted file mode 100644 index e3f73fd..0000000 --- a/jscomp/others/belt_List.res +++ /dev/null @@ -1,909 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* - perf is not everything, there are better memory represenations - - ``` - type 'a cell = { - mutable head : 'a; - mutable tail : 'a opt_cell - } - - and 'a opt_cell = 'a cell Js.null - - and 'a t = { - length : int ; - data : 'a opt_cell - } - ``` - However, - - people use List not because of its perf, but its - convenience, in that case, pattern match and compatibility seems - more attractive, we could keep a mutable list - - The built in types would indicate that - its construtor is immutable, a better optimizer would break such code - - ``` - type 'a t = { - head : 'a; - mutable tail : 'a t | int - } - ``` - In the future, we could come up with a safer version - ``` - type 'a t = - | Nil - | Cons of { hd : 'a ; mutable tail : 'a t } - ``` -*/ - -@@bs.config({flags: ["-bs-noassertfalse"]}) - -type t<'a> = list<'a> - -module A = Belt_Array - -external mutableCell: ('a, t<'a>) => t<'a> = "#makemutablelist" - -/* - `mutableCell x []` == `x` - but tell the compiler that is a mutable cell, so it wont - be mis-inlined in the future - dont inline a binding to mutable cell, it is mutable -*/ -/* INVARIANT: relies on Literals.tl (internal representation) */ -@set external unsafeMutateTail: (t<'a>, t<'a>) => unit = "tl" - -/* - - the cell is not empty -*/ - -let head = x => - switch x { - | list{} => None - | list{x, ..._} => Some(x) - } - -let headExn = x => - switch x { - | list{} => raise(Not_found) - | list{x, ..._} => x - } - -let tail = x => - switch x { - | list{} => None - | list{_, ...xs} => Some(xs) - } - -let tailExn = x => - switch x { - | list{} => raise(Not_found) - | list{_, ...t} => t - } - -let add = (xs, x) => list{x, ...xs} - -/* Assume `n >=0` */ -let rec nthAux = (x, n) => - switch x { - | list{h, ...t} => - if n == 0 { - Some(h) - } else { - nthAux(t, n - 1) - } - | _ => None - } - -let rec nthAuxAssert = (x, n) => - switch x { - | list{h, ...t} => - if n == 0 { - h - } else { - nthAuxAssert(t, n - 1) - } - | _ => raise(Not_found) - } - -let get = (x, n) => - if n < 0 { - None - } else { - nthAux(x, n) - } - -let getExn = (x, n) => - if n < 0 { - raise(Not_found) - } else { - nthAuxAssert(x, n) - } - -let rec partitionAux = (p, cell, precX, precY) => - switch cell { - | list{} => () - | list{h, ...t} => - let next = mutableCell(h, list{}) - if p(. h) { - unsafeMutateTail(precX, next) - partitionAux(p, t, next, precY) - } else { - unsafeMutateTail(precY, next) - partitionAux(p, t, precX, next) - } - } - -let rec splitAux = (cell, precX, precY) => - switch cell { - | list{} => () - | list{(a, b), ...t} => - let nextA = mutableCell(a, list{}) - let nextB = mutableCell(b, list{}) - unsafeMutateTail(precX, nextA) - unsafeMutateTail(precY, nextB) - splitAux(t, nextA, nextB) - } - -/* return the tail pointer so it can continue copy other - list -*/ -let rec copyAuxCont = (cellX, prec) => - switch cellX { - | list{} => prec - | list{h, ...t} => - let next = mutableCell(h, list{}) - unsafeMutateTail(prec, next) - copyAuxCont(t, next) - } - -let rec copyAuxWitFilter = (f, cellX, prec) => - switch cellX { - | list{} => () - | list{h, ...t} => - if f(. h) { - let next = mutableCell(h, list{}) - unsafeMutateTail(prec, next) - copyAuxWitFilter(f, t, next) - } else { - copyAuxWitFilter(f, t, prec) - } - } - -let rec copyAuxWithFilterIndex = (f, cellX, prec, i) => - switch cellX { - | list{} => () - | list{h, ...t} => - if f(. h, i) { - let next = mutableCell(h, list{}) - unsafeMutateTail(prec, next) - copyAuxWithFilterIndex(f, t, next, i + 1) - } else { - copyAuxWithFilterIndex(f, t, prec, i + 1) - } - } - -let rec copyAuxWitFilterMap = (f, cellX, prec) => - switch cellX { - | list{} => () - | list{h, ...t} => - switch f(. h) { - | Some(h) => - let next = mutableCell(h, list{}) - unsafeMutateTail(prec, next) - copyAuxWitFilterMap(f, t, next) - | None => copyAuxWitFilterMap(f, t, prec) - } - } - -let rec removeAssocAuxWithMap = (cellX, x, prec, f) => - switch cellX { - | list{} => false - | list{(a, _) as h, ...t} => - if f(. a, x) { - unsafeMutateTail(prec, t) - true - } else { - let next = mutableCell(h, list{}) - unsafeMutateTail(prec, next) - removeAssocAuxWithMap(t, x, next, f) - } - } - -let rec setAssocAuxWithMap = (cellX, x, k, prec, eq) => - switch cellX { - | list{} => false - | list{(a, _) as h, ...t} => - if eq(. a, x) { - unsafeMutateTail(prec, list{(x, k), ...t}) - true - } else { - let next = mutableCell(h, list{}) - unsafeMutateTail(prec, next) - setAssocAuxWithMap(t, x, k, next, eq) - } - } - -let rec copyAuxWithMap = (cellX, prec, f) => - switch cellX { - | list{} => () - | list{h, ...t} => - let next = mutableCell(f(. h), list{}) - unsafeMutateTail(prec, next) - copyAuxWithMap(t, next, f) - } - -let rec zipAux = (cellX, cellY, prec) => - switch (cellX, cellY) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let next = mutableCell((h1, h2), list{}) - unsafeMutateTail(prec, next) - zipAux(t1, t2, next) - | (list{}, _) | (_, list{}) => () - } - -let rec copyAuxWithMap2 = (f, cellX, cellY, prec) => - switch (cellX, cellY) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let next = mutableCell(f(. h1, h2), list{}) - unsafeMutateTail(prec, next) - copyAuxWithMap2(f, t1, t2, next) - | (list{}, _) | (_, list{}) => () - } - -let rec copyAuxWithMapI = (f, i, cellX, prec) => - switch cellX { - | list{h, ...t} => - let next = mutableCell(f(. i, h), list{}) - unsafeMutateTail(prec, next) - copyAuxWithMapI(f, i + 1, t, next) - | list{} => () - } - -let rec takeAux = (n, cell, prec) => - if n == 0 { - true - } else { - switch cell { - | list{} => false - | list{x, ...xs} => - let cell = mutableCell(x, list{}) - unsafeMutateTail(prec, cell) - takeAux(n - 1, xs, cell) - } - } - -let rec splitAtAux = (n, cell, prec) => - if n == 0 { - Some(cell) - } else { - switch cell { - | list{} => None - | list{x, ...xs} => - let cell = mutableCell(x, list{}) - unsafeMutateTail(prec, cell) - splitAtAux(n - 1, xs, cell) - } - } - -/* invarint `n >= 0` */ -let take = (lst, n) => - if n < 0 { - None - } else if n == 0 { - Some(list{}) - } else { - switch lst { - | list{} => None - | list{x, ...xs} => - let cell = mutableCell(x, list{}) - let has = takeAux(n - 1, xs, cell) - if has { - Some(cell) - } else { - None - } - } - } -/* invariant `n >= 0 ` */ -let rec dropAux = (l, n) => - if n == 0 { - Some(l) - } else { - switch l { - | list{_, ...tl} => dropAux(tl, n - 1) - | list{} => None - } - } - -let drop = (lst, n) => - if n < 0 { - None - } else { - dropAux(lst, n) - } - -let splitAt = (lst, n) => - if n < 0 { - None - } else if n == 0 { - Some(list{}, lst) - } else { - switch lst { - | list{} => None - | list{x, ...xs} => - let cell = mutableCell(x, list{}) - let rest = splitAtAux(n - 1, xs, cell) - switch rest { - | Some(rest) => Some(cell, rest) - | None => None - } - } - } - -let concat = (xs, ys) => - switch xs { - | list{} => ys - | list{h, ...t} => - let cell = mutableCell(h, list{}) - unsafeMutateTail(copyAuxCont(t, cell), ys) - cell - } - -let mapU = (xs, f) => - switch xs { - | list{} => list{} - | list{h, ...t} => - let cell = mutableCell(f(. h), list{}) - copyAuxWithMap(t, cell, f) - cell - } - -let map = (xs, f) => mapU(xs, (. x) => f(x)) - -let zipByU = (l1, l2, f) => - switch (l1, l2) { - | (list{a1, ...l1}, list{a2, ...l2}) => - let cell = mutableCell(f(. a1, a2), list{}) - copyAuxWithMap2(f, l1, l2, cell) - cell - | (list{}, _) | (_, list{}) => list{} - } - -let zipBy = (l1, l2, f) => zipByU(l1, l2, (. x, y) => f(x, y)) - -let mapWithIndexU = (xs, f) => - switch xs { - | list{} => list{} - | list{h, ...t} => - let cell = mutableCell(f(. 0, h), list{}) - copyAuxWithMapI(f, 1, t, cell) - cell - } - -let mapWithIndex = (xs, f) => mapWithIndexU(xs, (. i, x) => f(i, x)) - -let makeByU = (n, f) => - if n <= 0 { - list{} - } else { - let headX = mutableCell(f(. 0), list{}) - let cur = ref(headX) - let i = ref(1) - while i.contents < n { - let v = mutableCell(f(. i.contents), list{}) - unsafeMutateTail(cur.contents, v) - cur.contents = v - i.contents = i.contents + 1 - } - - headX - } - -let makeBy = (n, f) => makeByU(n, (. x) => f(x)) - -let make = (type a, n, v: a): list => - if n <= 0 { - list{} - } else { - let headX = mutableCell(v, list{}) - let cur = ref(headX) - let i = ref(1) - while i.contents < n { - let v = mutableCell(v, list{}) - unsafeMutateTail(cur.contents, v) - cur.contents = v - i.contents = i.contents + 1 - } - - headX - } - -let rec lengthAux = (x, acc) => - switch x { - | list{} => acc - | list{_, ...t} => lengthAux(t, acc + 1) - } - -let length = xs => lengthAux(xs, 0) -let size = length - -let rec fillAux = (arr, i, x) => - switch x { - | list{} => () - | list{h, ...t} => - A.setUnsafe(arr, i, h) - fillAux(arr, i + 1, t) - } - -let rec fromArrayAux = (a, i, res) => - if i < 0 { - res - } else { - fromArrayAux(a, i - 1, list{A.getUnsafe(a, i), ...res}) - } - -let fromArray = a => fromArrayAux(a, A.length(a) - 1, list{}) - -let toArray = (x: t<_>) => { - let len = length(x) - let arr = A.makeUninitializedUnsafe(len) - fillAux(arr, 0, x) - arr -} - -let shuffle = xs => { - let v = toArray(xs) - A.shuffleInPlace(v) - fromArray(v) -} - -/* let rec fillAuxMap arr i x f = - match x with - | [] -> () - | h::t -> - A.setUnsafe arr i (f h [@bs]) ; - fillAuxMap arr (i + 1) t f */ - -/* module J = Js_json */ -/* type json = J.t */ -/* let toJson x f = */ -/* let len = length x in */ -/* let arr = Belt_Array.makeUninitializedUnsafe len in */ -/* fillAuxMap arr 0 x f; */ -/* J.array arr */ - -/* TODO: best practice about raising excpetion - 1. raise OCaml exception, no stacktrace - 2. raise JS exception, how to pattern match -*/ - -let rec reverseConcat = (l1, l2) => - switch l1 { - | list{} => l2 - | list{a, ...l} => reverseConcat(l, list{a, ...l2}) - } - -let reverse = l => reverseConcat(l, list{}) - -let rec flattenAux = (prec, xs) => - switch xs { - | list{} => unsafeMutateTail(prec, list{}) - | list{h, ...r} => flattenAux(copyAuxCont(h, prec), r) - } - -let rec flatten = xs => - switch xs { - | list{} => list{} - | list{list{}, ...xs} => flatten(xs) - | list{list{h, ...t}, ...r} => - let cell = mutableCell(h, list{}) - flattenAux(copyAuxCont(t, cell), r) - cell - } - -let concatMany = xs => - switch xs { - | [] => list{} - | [x] => x - | _ => - let len = A.length(xs) - let v = ref(A.getUnsafe(xs, len - 1)) - for i in len - 2 downto 0 { - v.contents = concat(A.getUnsafe(xs, i), v.contents) - } - v.contents - } - -let rec mapRevAux = (f, accu, xs) => - switch xs { - | list{} => accu - | list{a, ...l} => mapRevAux(f, list{f(. a), ...accu}, l) - } - -let mapReverseU = (l, f) => mapRevAux(f, list{}, l) - -let mapReverse = (l, f) => mapReverseU(l, (. x) => f(x)) - -let rec forEachU = (xs, f) => - switch xs { - | list{} => () - | list{a, ...l} => - f(. a)->ignore - forEachU(l, f) - } - -let forEach = (xs, f) => forEachU(xs, (. x) => f(x)) - -let rec iteri = (xs, i, f) => - switch xs { - | list{} => () - | list{a, ...l} => - f(. i, a)->ignore - iteri(l, i + 1, f) - } - -let forEachWithIndexU = (l, f) => iteri(l, 0, f) -let forEachWithIndex = (l, f) => forEachWithIndexU(l, (. i, x) => f(i, x)) - -let rec reduceU = (l, accu, f) => - switch l { - | list{} => accu - | list{a, ...l} => reduceU(l, f(. accu, a), f) - } - -let reduce = (l, accu, f) => reduceU(l, accu, (. acc, x) => f(acc, x)) - -let rec reduceReverseUnsafeU = (l, accu, f) => - switch l { - | list{} => accu - | list{a, ...l} => f(. reduceReverseUnsafeU(l, accu, f), a) - } - -let reduceReverseU = (type a b, l: list, acc: b, f) => { - let len = length(l) - if len < 1000 { - reduceReverseUnsafeU(l, acc, f) - } else { - A.reduceReverseU(toArray(l), acc, f) - } -} - -let reduceReverse = (l, accu, f) => reduceReverseU(l, accu, (. a, b) => f(a, b)) - -let rec reduceWithIndexAuxU = (l, acc, f, i) => - switch l { - | list{} => acc - | list{x, ...xs} => reduceWithIndexAuxU(xs, f(. acc, x, i), f, i + 1) - } - -let reduceWithIndexU = (l, acc, f) => reduceWithIndexAuxU(l, acc, f, 0) - -let reduceWithIndex = (l, acc, f) => reduceWithIndexU(l, acc, (. acc, x, i) => f(acc, x, i)) - -let rec mapRevAux2 = (l1, l2, accu, f) => - switch (l1, l2) { - | (list{a1, ...l1}, list{a2, ...l2}) => mapRevAux2(l1, l2, list{f(. a1, a2), ...accu}, f) - | (_, list{}) | (list{}, _) => accu - } - -let mapReverse2U = (l1, l2, f) => mapRevAux2(l1, l2, list{}, f) - -let mapReverse2 = (l1, l2, f) => mapReverse2U(l1, l2, (. a, b) => f(a, b)) - -let rec forEach2U = (l1, l2, f) => - switch (l1, l2) { - | (list{a1, ...l1}, list{a2, ...l2}) => - f(. a1, a2)->ignore - forEach2U(l1, l2, f) - | (list{}, _) | (_, list{}) => () - } - -let forEach2 = (l1, l2, f) => forEach2U(l1, l2, (. a, b) => f(a, b)) - -let rec reduce2U = (l1, l2, accu, f) => - switch (l1, l2) { - | (list{a1, ...l1}, list{a2, ...l2}) => reduce2U(l1, l2, f(. accu, a1, a2), f) - | (list{}, _) | (_, list{}) => accu - } - -let reduce2 = (l1, l2, acc, f) => reduce2U(l1, l2, acc, (. a, b, c) => f(a, b, c)) - -let rec reduceReverse2UnsafeU = (l1, l2, accu, f) => - switch (l1, l2) { - | (list{}, list{}) => accu - | (list{a1, ...l1}, list{a2, ...l2}) => f(. reduceReverse2UnsafeU(l1, l2, accu, f), a1, a2) - | (_, list{}) | (list{}, _) => accu - } - -let reduceReverse2U = (type a b c, l1: list, l2: list, acc: c, f) => { - let len = length(l1) - if len < 1000 { - reduceReverse2UnsafeU(l1, l2, acc, f) - } else { - A.reduceReverse2U(toArray(l1), toArray(l2), acc, f) - } -} - -let reduceReverse2 = (l1, l2, acc, f) => reduceReverse2U(l1, l2, acc, (. a, b, c) => f(a, b, c)) - -let rec everyU = (xs, p) => - switch xs { - | list{} => true - | list{a, ...l} => p(. a) && everyU(l, p) - } - -let every = (xs, p) => everyU(xs, (. x) => p(x)) - -let rec someU = (xs, p) => - switch xs { - | list{} => false - | list{a, ...l} => p(. a) || someU(l, p) - } - -let some = (xs, p) => someU(xs, (. x) => p(x)) - -let rec every2U = (l1, l2, p) => - switch (l1, l2) { - | (_, list{}) | (list{}, _) => true - | (list{a1, ...l1}, list{a2, ...l2}) => p(. a1, a2) && every2U(l1, l2, p) - } - -let every2 = (l1, l2, p) => every2U(l1, l2, (. a, b) => p(a, b)) - -let rec cmpByLength = (l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => 0 - | (_, list{}) => 1 - | (list{}, _) => -1 - | (list{_, ...l1s}, list{_, ...l2s}) => cmpByLength(l1s, l2s) - } - -let rec cmpU = (l1, l2, p) => - switch (l1, l2) { - | (list{}, list{}) => 0 - | (_, list{}) => 1 - | (list{}, _) => -1 - | (list{a1, ...l1}, list{a2, ...l2}) => - let c = p(. a1, a2) - if c == 0 { - cmpU(l1, l2, p) - } else { - c - } - } - -let cmp = (l1, l2, f) => cmpU(l1, l2, (. x, y) => f(x, y)) - -let rec eqU = (l1, l2, p) => - switch (l1, l2) { - | (list{}, list{}) => true - | (_, list{}) - | (list{}, _) => false - | (list{a1, ...l1}, list{a2, ...l2}) => - if p(. a1, a2) { - eqU(l1, l2, p) - } else { - false - } - } -let eq = (l1, l2, f) => eqU(l1, l2, (. x, y) => f(x, y)) - -let rec some2U = (l1, l2, p) => - switch (l1, l2) { - | (list{}, _) | (_, list{}) => false - | (list{a1, ...l1}, list{a2, ...l2}) => p(. a1, a2) || some2U(l1, l2, p) - } - -let some2 = (l1, l2, p) => some2U(l1, l2, (. a, b) => p(a, b)) - -let rec hasU = (xs, x, eq) => - switch xs { - | list{} => false - | list{a, ...l} => eq(. a, x) || hasU(l, x, eq) - } - -let has = (xs, x, eq) => hasU(xs, x, (. a, b) => eq(a, b)) - -let rec getAssocU = (xs, x, eq) => - switch xs { - | list{} => None - | list{(a, b), ...l} => - if eq(. a, x) { - Some(b) - } else { - getAssocU(l, x, eq) - } - } - -let getAssoc = (xs, x, eq) => getAssocU(xs, x, (. a, b) => eq(a, b)) - -let rec hasAssocU = (xs, x, eq) => - switch xs { - | list{} => false - | list{(a, _), ...l} => eq(. a, x) || hasAssocU(l, x, eq) - } - -let hasAssoc = (xs, x, eq) => hasAssocU(xs, x, (. a, b) => eq(a, b)) - -let removeAssocU = (xs, x, eq) => - switch xs { - | list{} => list{} - | list{(a, _) as pair, ...l} => - if eq(. a, x) { - l - } else { - let cell = mutableCell(pair, list{}) - let removed = removeAssocAuxWithMap(l, x, cell, eq) - if removed { - cell - } else { - xs - } - } - } - -let removeAssoc = (xs, x, eq) => removeAssocU(xs, x, (. a, b) => eq(a, b)) - -let setAssocU = (xs, x, k, eq) => - switch xs { - | list{} => list{(x, k)} - | list{(a, _) as pair, ...l} => - if eq(. a, x) { - list{(x, k), ...l} - } else { - let cell = mutableCell(pair, list{}) - let replaced = setAssocAuxWithMap(l, x, k, cell, eq) - if replaced { - cell - } else { - list{(x, k), ...xs} - } - } - } - -let setAssoc = (xs, x, k, eq) => setAssocU(xs, x, k, (. a, b) => eq(a, b)) - -let sortU = (xs, cmp) => { - let arr = toArray(xs) - Belt_SortArray.stableSortInPlaceByU(arr, cmp) - fromArray(arr) -} - -let sort = (xs, cmp) => sortU(xs, (. x, y) => cmp(x, y)) - -let rec getByU = (xs, p) => - switch xs { - | list{} => None - | list{x, ...l} => - if p(. x) { - Some(x) - } else { - getByU(l, p) - } - } - -let getBy = (xs, p) => getByU(xs, (. a) => p(a)) - -let rec keepU = (xs, p) => - switch xs { - | list{} => list{} - | list{h, ...t} => - if p(. h) { - let cell = mutableCell(h, list{}) - copyAuxWitFilter(p, t, cell) - cell - } else { - keepU(t, p) - } - } - -let keep = (xs, p) => keepU(xs, (. x) => p(x)) - -let filter = keep - -let keepWithIndexU = (xs, p) => { - let rec auxKeepWithIndex = (xs, p, i) => - switch xs { - | list{} => list{} - | list{h, ...t} => - if p(. h, i) { - let cell = mutableCell(h, list{}) - copyAuxWithFilterIndex(p, t, cell, i + 1) - cell - } else { - auxKeepWithIndex(t, p, i + 1) - } - } - auxKeepWithIndex(xs, p, 0) -} - -let keepWithIndex = (xs, p) => keepWithIndexU(xs, (. x, i) => p(x, i)) - -let filterWithIndex = keepWithIndex - -let rec keepMapU = (xs, p) => - switch xs { - | list{} => list{} - | list{h, ...t} => - switch p(. h) { - | Some(h) => - let cell = mutableCell(h, list{}) - copyAuxWitFilterMap(p, t, cell) - cell - | None => keepMapU(t, p) - } - } - -let keepMap = (xs, p) => keepMapU(xs, (. x) => p(x)) - -let partitionU = (l, p) => - switch l { - | list{} => (list{}, list{}) - | list{h, ...t} => - let nextX = mutableCell(h, list{}) - let nextY = mutableCell(h, list{}) - let b = p(. h) - partitionAux(p, t, nextX, nextY) - if b { - ( - nextX, - switch nextY { - | list{_, ...tail} => tail - | list{} => assert(false) - }, - ) - } else { - ( - switch nextX { - | list{_, ...tail} => tail - | list{} => assert(false) - }, - nextY, - ) - } - } - -let partition = (l, p) => partitionU(l, (. x) => p(x)) - -let unzip = xs => - switch xs { - | list{} => (list{}, list{}) - | list{(x, y), ...l} => - let cellX = mutableCell(x, list{}) - let cellY = mutableCell(y, list{}) - splitAux(l, cellX, cellY) - (cellX, cellY) - } - -let zip = (l1, l2) => - switch (l1, l2) { - | (_, list{}) | (list{}, _) => list{} - | (list{a1, ...l1}, list{a2, ...l2}) => - let cell = mutableCell((a1, a2), list{}) - zipAux(l1, l2, cell) - cell - } diff --git a/jscomp/others/belt_List.resi b/jscomp/others/belt_List.resi deleted file mode 100644 index 15811ed..0000000 --- a/jscomp/others/belt_List.resi +++ /dev/null @@ -1,955 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Collection functions for manipulating the `list` data structures, a singly-linked list. - -**Prefer Array** if you need any of the following: - -- Random access of element -- Better interop with JavaScript -- Better memory usage & performance. -*/ - -/** `'a t` is compatible with built-in `list` type */ -type t<'a> = list<'a> - -/** -Returns the length of a list. - -## Examples - -```rescript -Belt.List.length(list{1, 2, 3}) // 3 -``` -*/ -let length: t<'a> => int - -/** See `Belt.List.length` */ -let size: t<'a> => int - -/** -Returns `Some(value)` where `value` is the first element in the list, or -`None` if `someList` is an empty list. - -## Examples - -```rescript -Belt.List.head(list{}) // None -Belt.List.head(list{1, 2, 3}) // Some(1) -``` -*/ -let head: t<'a> => option<'a> - -/** -Same as `Belt.List.head` but raises an exception if `someList` is empty. Use -with care. - -## Examples - -```rescript -Belt.List.headExn(list{1, 2, 3}) // 1 - -Belt.List.headExn(list{}) // Raises an Error -``` -*/ -let headExn: t<'a> => 'a - -/** -Returns `None` if `someList` is empty, otherwise it returns `Some(tail)` -where `tail` is everything except the first element of `someList`. - -## Examples - -```rescript -Belt.List.tail(list{1, 2, 3}) // Some(list{2, 3}) - -Belt.List.tail(list{}) // None -``` -*/ -let tail: t<'a> => option> - -/** -Same as `Belt.List.tail` but raises an exception if `someList` is empty. Use -with care. - -## Examples - -```rescript -Belt.List.tailExn(list{1, 2, 3}) // list{2, 3} - -Belt.List.tailExn(list{}) // Raises an Error -``` -*/ -let tailExn: t<'a> => t<'a> - -/** -Adds `value` to the beginning of `someList`. - -## Examples - -```rescript -Belt.List.add(list{2, 3}, 1) // list{1, 2, 3} - -Belt.List.add(list{"World", "!"}, "Hello") // list{"Hello", "World", "!"} -``` -*/ -let add: (t<'a>, 'a) => t<'a> - -/** -Return the nth element in `someList`, or `None` if `index` is larger than the -length. - -## Examples - -```rescript -let abc = list{"A", "B", "C"} - -abc->Belt.List.get(1) // Some("B") - -abc->Belt.List.get(4) // None -``` -*/ -let get: (t<'a>, int) => option<'a> - -/** -Same as `Belt.List.get` but raises an exception if `index` is larger than the -length. Use with care. - -## Examples - -```rescript -let abc = list{"A", "B", "C"} - -abc->Belt.List.getExn(1) // "B" - -abc->Belt.List.getExn(4) // Raises an Error -``` -*/ -let getExn: (t<'a>, int) => 'a - -/** -Returns a list of length `numItems` with each element filled with value `v`. Returns an empty list if `numItems` is negative. - -## Examples - -```rescript -Belt.List.make(3, 1) // list{1, 1, 1} -``` -*/ -let make: (int, 'a) => t<'a> - -/** Uncurried version of [makeBy](#makeBy) */ -let makeByU: (int, (. int) => 'a) => t<'a> - -/** -Return a list of length `numItems` with element `i` initialized with `f(i)`. -Returns an empty list if `numItems` is negative. - -## Examples - -```rescript -Belt.List.makeBy(5, i => i) // list{0, 1, 2, 3, 4} - -Belt.List.makeBy(5, i => i * i) // list{0, 1, 4, 9, 16} -``` -*/ -let makeBy: (int, int => 'a) => t<'a> - -/** -Returns a new list in random order. - -## Examples - -```rescript -Belt.List.shuffle(list{1, 2, 3}) // list{2, 1, 3} -``` -*/ -let shuffle: t<'a> => t<'a> - -/** -Return a new list, dropping the first `n` elements. Returns `None` if `someList` has fewer than `n` elements. - -## Examples - -```rescript -list{1, 2, 3}->Belt.List.drop(2) // Some(list{3}) - -list{1, 2, 3}->Belt.List.drop(3) // Some(list{}) - -list{1, 2, 3}->Belt.List.drop(4) // None -``` -*/ -let drop: (t<'a>, int) => option> - -/** -Returns a list with the first `n` elements from `someList`, or `None` if `someList` has fewer than `n` elements. - -## Examples - -```rescript -list{1, 2, 3}->Belt.List.take(1) // Some(list{1}) - -list{1, 2, 3}->Belt.List.take(2) // Some(list{1, 2}) - -list{1, 2, 3}->Belt.List.take(4) // None -``` -*/ -let take: (t<'a>, int) => option> - -/** -Split the list `someList` at `index`. Returns `None` when the length of `someList` is less than `index`. - -## Examples - -```rescript -list{"Hello", "World"}->Belt.List.splitAt(1) // Some((list{"Hello"}, list{"World"})) - -list{0, 1, 2, 3, 4}->Belt.List.splitAt(2) // Some((list{0, 1}, list{2, 3, 4})) -``` -*/ -let splitAt: (t<'a>, int) => option<(list<'a>, list<'a>)> - -/** -Returns the list obtained by adding `secondList` after `firstList`. - -## Examples - -```rescript -Belt.List.concat(list{1, 2, 3}, list{4, 5}) // list{1, 2, 3, 4, 5} -``` -*/ -let concat: (t<'a>, t<'a>) => t<'a> - -/** -Returns the list obtained by concatenating all the lists in array `a`, in -order. - -## Examples - -```rescript -Belt.List.concatMany([list{1, 2, 3}, list{}, list{3}]) // list{1, 2, 3, 3} -``` -*/ -let concatMany: array> => t<'a> - -/** -Equivalent to writing: `concat(reverse(firstList, secondList)` - -## Examples - -```rescript -Belt.List.reverseConcat(list{1, 2}, list{3, 4}) // list{2, 1, 3, 4} -``` -*/ -let reverseConcat: (t<'a>, t<'a>) => t<'a> - -/** -Return the list obtained by concatenating all the lists in list `ls`, in order. - -## Examples - -```rescript -Belt.List.flatten(list{list{1, 2, 3}, list{}, list{3}}) // list{1, 2, 3, 3} -``` -*/ -let flatten: t> => t<'a> - -/** Uncurried version of [map](#map). */ -let mapU: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -Returns a new list with `f` applied to each element of `someList`. - -## Examples - -```rescript -list{1, 2}->Belt.List.map(x => x + 1) // list{3, 4} -``` -*/ -let map: (t<'a>, 'a => 'b) => t<'b> - -/** -Returns a list of pairs from the two lists with the length of the shorter list. - -## Examples - -```rescript -Belt.List.zip(list{1, 2}, list{3, 4, 5}) // list{(1, 3), (2, 4)} -``` -*/ -let zip: (t<'a>, t<'b>) => t<('a, 'b)> - -/** Uncurried version of [zipBy](#zipBy). */ -let zipByU: (t<'a>, t<'b>, (. 'a, 'b) => 'c) => t<'c> - -/** -See [Belt.List.zip](#zip) - -## Examples - -```rescript -Belt.List.zipBy(list{1, 2, 3}, list{4, 5}, (a, b) => 2 * a + b) // list{6, 9} -``` -*/ -let zipBy: (t<'a>, t<'b>, ('a, 'b) => 'c) => t<'c> - -/** Uncurried version of [mapWithIndex](#mapWithIndex). */ -let mapWithIndexU: (t<'a>, (. int, 'a) => 'b) => t<'b> - -/** -Applies `f` to each element of `someList`. -Function `f` takes two arguments: the index starting from 0 and the element from `someList`, in that order. - -## Examples - -```rescript -list{1, 2, 3}->Belt.List.mapWithIndex((index, x) => index + x) // list{1, 3, 5} -``` -*/ -let mapWithIndex: (t<'a>, (int, 'a) => 'b) => t<'b> - -/** -Converts the given array to a list. - -## Examples - -```rescript -Belt.List.fromArray([1, 2, 3]) // list{1, 2, 3} -``` -*/ -let fromArray: array<'a> => t<'a> - -/** -Converts the given list to an array. - -## Examples - -```rescript -Belt.List.toArray(list{1, 2, 3}) // [1, 2, 3] -``` -*/ -let toArray: t<'a> => array<'a> - -/* type json = Js_json.t */ - -/* val toJson : 'a t -> ('a -> json [@bs]) -> json */ -/* val fromJson : json -> (json -> 'a [@bs]) -> 'a t */ - -/** -Returns a new list whose elements are those of `someList` in reversed order. - -## Examples - -```rescript -Belt.List.reverse(list{1, 2, 3}) /* list{3, 2, 1} */ -``` -*/ -let reverse: t<'a> => t<'a> - -/** Uncurried version of [mapReverse](#mapReverse). */ -let mapReverseU: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -Equivalent to: - -```res -map(someList, f)->reverse -``` - -## Examples - -```rescript -list{3, 4, 5}->Belt.List.mapReverse(x => x * x) /* list{25, 16, 9} */ -``` -*/ -let mapReverse: (t<'a>, 'a => 'b) => t<'b> - -/** Uncurried version of [forEach](#forEach). */ -let forEachU: (t<'a>, (. 'a) => 'b) => unit - -/** -Call `f` on each element of `someList` from the beginning to end. -`f` returns `unit`, so no new array is created. Use `forEach` when you are primarily concerned with repetitively creating side effects. - -## Examples - -```rescript -Belt.List.forEach(list{"a", "b", "c"}, x => Js.log("Item: " ++ x)) -/* - prints: - Item: a - Item: b - Item: c -*/ -``` -*/ -let forEach: (t<'a>, 'a => 'b) => unit - -/** Uncurried version of [forEachWithIndex](#forEachWithIndex). */ -let forEachWithIndexU: (t<'a>, (. int, 'a) => 'b) => unit - -/** -Call `f` on each element of `someList` from beginning to end. -Function `f` takes two arguments: the index starting from 0 and the element from `someList`. `f` returns `unit`. - -## Examples - -```rescript -Belt.List.forEachWithIndex(list{"a", "b", "c"}, (index, x) => { - Js.log("Item " ++ Belt.Int.toString(index) ++ " is " ++ x) -}) -/* - prints: - Item 0 is a - Item 1 is b - Item 2 is cc -*/ -``` -*/ -let forEachWithIndex: (t<'a>, (int, 'a) => 'b) => unit - -/** Uncurried version of [reduce](#reduce). */ -let reduceU: (t<'a>, 'b, (. 'b, 'a) => 'b) => 'b - -/** -Applies `f` to each element of `someList` from beginning to end. Function `f` has two parameters: the item from the list and an “accumulator”, which starts with a value of `initialValue`. reduce returns the final value of the accumulator. - -## Examples - -```rescript -list{1, 2, 3, 4}->Belt.List.reduce(0, (a, b) => a + b) /* 10 */ - -/* same as */ - -list{1, 2, 3, 4}->Belt.List.reduce(0, (acc, item) => acc + item) /* 10 */ -``` -*/ -let reduce: (t<'a>, 'b, ('b, 'a) => 'b) => 'b - -/** Uncurried version of [reduceWithIndex](#reduceWithIndex). */ -let reduceWithIndexU: (t<'a>, 'b, (. 'b, 'a, int) => 'b) => 'b - -/** -Applies `f` to each element of `someList` from beginning to end. Function `f` has three parameters: the item from the list and an “accumulator”, which starts with a value of `initialValue` and the index of each element. `reduceWithIndex` returns the final value of the accumulator. - -## Examples - -```rescript -list{1, 2, 3, 4}->Belt.List.reduceWithIndex(0, (acc, item, index) => acc + item + index) /* 16 */ -``` -*/ -let reduceWithIndex: (t<'a>, 'b, ('b, 'a, int) => 'b) => 'b - -/** Uncurried version of [reduceReverse](#reduceReverse). */ -let reduceReverseU: (t<'a>, 'b, (. 'b, 'a) => 'b) => 'b - -/** -Works like [reduce](#reduce), except that function `f` is applied to each -item of `someList` from the last back to the first. - -## Examples - -```rescript -list{1, 2, 3, 4}->Belt.List.reduceReverse(0, (a, b) => a + b) /* 10 */ - -list{1, 2, 3, 4}->Belt.List.reduceReverse(10, (a, b) => a - b) /* 0 */ - -list{1, 2, 3, 4}->Belt.List.reduceReverse(list{}, Belt.List.add) // list{1, 2, 3, 4} -``` -*/ -let reduceReverse: (t<'a>, 'b, ('b, 'a) => 'b) => 'b - -/** Uncurried version of [mapReverse2](#mapReverse2). */ -let mapReverse2U: (t<'a>, t<'b>, (. 'a, 'b) => 'c) => t<'c> - -/** -Equivalent to: `zipBy(xs, ys, f)->reverse` - -## Examples - -```rescript - -Belt.List.mapReverse2(list{1, 2, 3}, list{1, 2}, (a, b) => a + b) // list{4, 2} -``` -*/ -let mapReverse2: (t<'a>, t<'b>, ('a, 'b) => 'c) => t<'c> - -/** Uncurried version of [forEach2](#forEach2). */ -let forEach2U: (t<'a>, t<'b>, (. 'a, 'b) => 'c) => unit - -/** -Stops at the length of the shorter list. - -## Examples - -```rescript -Belt.List.forEach2(list{"Z", "Y"}, list{"A", "B", "C"}, (x, y) => Js.log2(x, y)) - -/* - prints: - "Z" "A" - "Y" "B" -*/ -``` -*/ -let forEach2: (t<'a>, t<'b>, ('a, 'b) => 'c) => unit - -/** Uncurried version of [reduce2](#reduce2). */ -let reduce2U: (t<'b>, t<'c>, 'a, (. 'a, 'b, 'c) => 'a) => 'a - -/** -Applies `f` to each element of `firstList` and `secondList` from beginning to end. Stops with the shorter list. Function `f` has three parameters: an “accumulator” which starts with a value of `initialValue`, an item from `firstList`, and an item from `secondList`. `reduce2` returns the final value of the accumulator. - -## Examples - -```rescript -Belt.List.reduce2(list{1, 2, 3}, list{4, 5}, 0, (acc, x, y) => acc + x * x + y) /* 0 + (1 * 1 + 4) + (2 * 2 + 5) */ -``` -*/ -let reduce2: (t<'b>, t<'c>, 'a, ('a, 'b, 'c) => 'a) => 'a - -/** Uncurried version of [reduceReverse2](#reduceReverse2). */ -let reduceReverse2U: (t<'a>, t<'b>, 'c, (. 'c, 'a, 'b) => 'c) => 'c - -/** -Applies `f` to each element of `firstList` and `secondList` from end to -beginning. Stops with the shorter list. Function `f` has three parameters: an -“accumulator” which starts with a value of init, an item from `firstList`, -and an item from `secondList`. `reduce2` returns the final value of the -accumulator. - -## Examples - -```rescript -Belt.List.reduceReverse2(list{1, 2, 3}, list{4, 5}, 0, (acc, x, y) => acc + x * x + y) /* + (1 * 1 + 4) + (2 * 2 + 5) */ -``` -*/ -let reduceReverse2: (t<'a>, t<'b>, 'c, ('c, 'a, 'b) => 'c) => 'c - -/** Uncurried version of [every](#every). */ -let everyU: (t<'a>, (. 'a) => bool) => bool - -/** -Returns `true` if all elements satisfy `pred`, where `pred` is a predicate: a function taking an element and returning a bool. - -## Examples - -```rescript -let isBelow10 = value => value < 10 - -list{1, 9, 8, 2}->Belt.List.every(isBelow10) /* true */ - -list{1, 99, 8, 2}->Belt.List.every(isBelow10) /* false */ -``` -*/ -let every: (t<'a>, 'a => bool) => bool - -/** Uncurried version of [some](#some). */ -let someU: (t<'a>, (. 'a) => bool) => bool - -/** -Returns `true` if at least _one_ of the elements in `someList` satisfies -`pred`, where `pred` is a predicate: a function taking an element and -returning a bool. - -## Examples - -```rescript -let isAbove100 = value => value > 100 - -list{101, 1, 2, 3}->Belt.List.some(isAbove100) /* true */ - -list{1, 2, 3, 4}->Belt.List.some(isAbove100) /* false */ -``` -*/ -let some: (t<'a>, 'a => bool) => bool - -/** Uncurried version of [every2](#every2). */ -let every2U: (t<'a>, t<'b>, (. 'a, 'b) => bool) => bool - -/** -Returns `true` if predicate `pred(a, b)` is `true` for all pairs of elements -up to the shorter length (i.e. `min(length(firstList), length(secondList))`) - -## Examples - -```rescript -Belt.List.every2(list{1, 2, 3}, list{0, 1}, (a, b) => a > b) /* true */ - -Belt.List.every2(list{}, list{1}, (a, b) => a > b) /* true */ - -Belt.List.every2(list{2, 3}, list{1}, (a, b) => a > b) /* true */ - -Belt.List.every2(list{0, 1}, list{5, 0}, (a, b) => a > b) /* false */ -``` -*/ -let every2: (t<'a>, t<'b>, ('a, 'b) => bool) => bool - -/** Uncurried version of [some2](#some2). */ -let some2U: (t<'a>, t<'b>, (. 'a, 'b) => bool) => bool - -/** -Returns `true` if predicate `pred(a, b)` is true for any pair of elements up -to the shorter length (i.e. `min(length(firstList), length(secondList))`) - -## Examples - -```rescript -Belt.List.some2(list{1, 2, 3}, list{0, 1}, (a, b) => a > b) /* true */ - -Belt.List.some2(list{}, list{1}, (a, b) => a > b) /* false */ - -Belt.List.some2(list{2, 3}, list{1}, (a, b) => a > b) /* true */ - -Belt.List.some2(list{0, 1}, list{5, 0}, (a, b) => a > b) /* true */ -``` -*/ -let some2: (t<'a>, t<'b>, ('a, 'b) => bool) => bool - -/** -Compare two lists solely by length. Returns `-1` if `length(firstList)` is -less than `length(secondList)`, `0` if `length(firstList)` equals -`length(secondList)`, and `1` if `length(firstList)` is greater than -`length(secondList)`. - -## Examples - -```rescript -Belt.List.cmpByLength(list{1, 2}, list{3, 4, 5, 6}) /* -1 */ - -Belt.List.cmpByLength(list{1, 2, 3}, list{4, 5, 6}) /* = 0 */ - -Belt.List.cmpByLength(list{1, 2, 3, 4}, list{5, 6}) /* = 1 */ -``` -*/ -let cmpByLength: (t<'a>, t<'a>) => int - -/** Uncurried version of [cmp](#cmp). */ -let cmpU: (t<'a>, t<'a>, (. 'a, 'a) => int) => int - -/** -Compare elements one by one `compareFn(a, b)`. `compareFn` returns a negative number if `a` is "less than" `b`, zero if `a` is "equal to" `b`, a positive number if `a` is "greater than" `b`. - -The comparison returns the first non-zero result of `compareFn`, or zero if `compareFn` returns zero for all `a` and `b`. - -If all items have compared equal, but `firstList` is exhausted first, return `-1`. (`firstList` is shorter). -If all items have compared equal, but `secondList` is exhausted first, return `1` (`firstList` is longer). - -## Examples - -```rescript -Belt.List.cmp(list{3}, list{3, 7}, (a, b) => compare(a, b)) /* (-1) */ - -Belt.List.cmp(list{5, 3}, list{5}, (a, b) => compare(a, b)) /* 1 */ - -Belt.List.cmp(list{1, 3, 5}, list{1, 4, 2}, (a, b) => compare(a, b)) /* (-1) */ - -Belt.List.cmp(list{1, 3, 5}, list{1, 2, 3}, (a, b) => compare(a, b)) /* 1 */ - -Belt.List.cmp(list{1, 3, 5}, list{1, 3, 5}, (a, b) => compare(a, b)) /* 0 */ -``` - -**Please note:** The total ordering of List is different from Array, -for Array, we compare the length first and, only if the lengths are equal, elements one by one. -For lists, we just compare elements one by one. -*/ -let cmp: (t<'a>, t<'a>, ('a, 'a) => int) => int - -/** Uncurried version of [eq](#eq). */ -let eqU: (t<'a>, t<'a>, (. 'a, 'a) => bool) => bool - -/** -Check equality of `firstList` and `secondList` using `eqElem` for equality on -elements, where `eqElem` is a function that returns `true` if items `x` and -`y` meet some criterion for equality, `false` otherwise. eq `false` if length -of `firstList` and `secondList` are not the same. - -## Examples - -```rescript -Belt.List.eq(list{1, 2, 3}, list{1, 2}, (a, b) => a == b) /* false */ - -Belt.List.eq(list{1, 2}, list{1, 2}, (a, b) => a == b) /* true */ - -Belt.List.eq(list{1, 2, 3}, list{(-1), (-2), (-3)}, (a, b) => abs(a) == abs(b)) /* true */ -``` -*/ -let eq: (t<'a>, t<'a>, ('a, 'a) => bool) => bool - -/** Uncurried version of [has](#has). */ -let hasU: (t<'a>, 'b, (. 'a, 'b) => bool) => bool - -/** -Returns `true` if the list contains at least one element for which -`eqFunction(x)` returns true. - -## Examples - -```rescript -list{1, 2, 3}->Belt.List.has(2, (a, b) => a == b) /* true */ - -list{1, 2, 3}->Belt.List.has(4, (a, b) => a == b) /* false */ - -list{(-1), (-2), (-3)}->Belt.List.has(2, (a, b) => abs(a) == abs(b)) /* true */ -``` -*/ -let has: (t<'a>, 'b, ('a, 'b) => bool) => bool - -/** Uncurried version of [getBy](#getBy). */ -let getByU: (t<'a>, (. 'a) => bool) => option<'a> - -/** -Returns `Some(value)` for the first value in `someList` that satisfies the -predicate function `pred`. Returns `None` if no element satisfies the function. - -## Examples - -```rescript -Belt.List.getBy(list{1, 4, 3, 2}, x => x > 3) /* Some(4) */ - -Belt.List.getBy(list{1, 4, 3, 2}, x => x > 4) /* None */ -``` -*/ -let getBy: (t<'a>, 'a => bool) => option<'a> - -/** Uncurried version of [keep](#keep). */ -let keepU: (t<'a>, (. 'a) => bool) => t<'a> - -/** -Returns a list of all elements in `someList` which satisfy the predicate function `pred`. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -Belt.List.keep(list{1, 2, 3, 4}, isEven) /* list{2, 4} */ - -Belt.List.keep(list{None, Some(2), Some(3), None}, Belt.Option.isSome) /* list{Some(2), Some(3)} */ -``` -*/ -let keep: (t<'a>, 'a => bool) => t<'a> - -@deprecated("This function will soon be deprecated. Please, use `List.keep` instead.") -/** -Returns a list of all elements in `someList` which satisfy the predicate function `pred`. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -Belt.List.filter(list{1, 2, 3, 4}, isEven) /* list{2, 4} */ - -Belt.List.filter(list{None, Some(2), Some(3), None}, Belt.Option.isSome) /* list{Some(2), Some(3)} */ -``` -*/ -let filter: (t<'a>, 'a => bool) => t<'a> - -/** Uncurried version of [keepWithIndex](#keepWithIndex). */ -let keepWithIndexU: (t<'a>, (. 'a, int) => bool) => t<'a> - -/** -Returns a list of all elements in `someList` which satisfy the predicate function `pred`. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -Belt.List.keepWithIndex(list{1, 2, 3, 4}, (_x, index) => isEven(index)) /* list{1, 3} */ -``` -*/ -let keepWithIndex: (t<'a>, ('a, int) => bool) => t<'a> - -@deprecated( - "This function will soon be deprecated. Please, use `List.keepWithIndex` \ - instead." -) -/** -Returns a list of all elements in `someList` which satisfy the predicate function `pred`. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -Belt.List.filterWithIndex(list{1, 2, 3, 4}, (_x, index) => isEven(index)) /* list{1, 3} */ -``` -*/ -let filterWithIndex: (t<'a>, ('a, int) => bool) => t<'a> - -/** Uncurried version of [keepMap](#keepMap). */ -let keepMapU: (t<'a>, (. 'a) => option<'b>) => t<'b> - -/** -Applies `f` to each element of `someList`. If `f(x)` returns `Some(value)`, then `value` is _kept_ in the resulting list. -If `f(x)` returns `None`, the element is _not_ retained in the result. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -list{1, 2, 3, 4} -->Belt.List.keepMap(x => - if (isEven(x)) { - Some(x) - } else { - None - } - ) /* list{2, 4} */ - -list{Some(1), Some(2), None}->Belt.List.keepMap(x => x) /* list{1, 2} */ -``` -*/ -let keepMap: (t<'a>, 'a => option<'b>) => t<'b> - -/** Uncurried version of [partition](#partition). */ -let partitionU: (t<'a>, (. 'a) => bool) => (t<'a>, t<'a>) - -/** -Creates a pair of lists; the first list consists of all elements of `someList` that satisfy the predicate function `pred`; the second list consists of all elements of `someList` that _do not_ satisfy `pred. - -In other words: - -```rescript -(elementsThatSatisfies, elementsThatDoesNotSatisfy) -``` - -## Examples - -```rescript -Belt.List.partition(list{1, 2, 3, 4}, x => x > 2) /* (list{3, 4}, list{1, 2}) */ -``` -*/ -let partition: (t<'a>, 'a => bool) => (t<'a>, t<'a>) - -/** -Takes a list of pairs and creates a pair of lists. The first list contains all the first items of the pairs; the second list contains all the second items. - -## Examples - -```rescript -Belt.List.unzip(list{(1, 2), (3, 4)}) /* (list{1, 3}, list{2, 4}) */ - -Belt.List.unzip(list{("H", "W"), ("e", "o"), ("l", "r"), ("l", "l"), ("o", "d"), (" ", "!")}) -/* (list{"H", "e", "l", "l", "o", " "}, list{"W", "o", "r", "l", "d", "!"}) */ -``` -*/ -let unzip: t<('a, 'b)> => (t<'a>, t<'b>) - -/** Uncurried version of [getAssoc](#getAssoc). */ -let getAssocU: (t<('a, 'c)>, 'b, (. 'a, 'b) => bool) => option<'c> - -/** -Return the second element of a pair in `someList` where the first element equals `k` as per the predicate function `eqFunction`, or `None` if not found. - -## Examples - -```rescript -list{(1, "a"), (2, "b"), (3, "c")}->Belt.List.getAssoc(3, (a, b) => a == b) /* Some("c") */ - -list{(9, "morning"), (15, "afternoon"), (22, "night")} -->Belt.List.getAssoc(15, (k, item) => k /* 15 */ == item /* 9, 5, 22 */) -/* Some("afternoon") */ -``` -*/ -let getAssoc: (t<('a, 'c)>, 'b, ('a, 'b) => bool) => option<'c> - -/** Uncurried version of [hasAssoc](#hasAssoc). */ -let hasAssocU: (t<('a, 'c)>, 'b, (. 'a, 'b) => bool) => bool - -/** -Returns `true` if there is a pair in `someList` where the first element equals `k` as per the predicate function `eqFunction`. - -## Examples - -```rescript -list{(1, "a"), (2, "b"), (3, "c")}->Belt.List.hasAssoc(1, (a, b) => a == b) /* true */ - -list{(9, "morning"), (15, "afternoon"), (22, "night")} -->Belt.List.hasAssoc(25, (k, item) => k /* 25 */ == item /* 9, 5, 22 */) /* false */ -``` -*/ -let hasAssoc: (t<('a, 'c)>, 'b, ('a, 'b) => bool) => bool - -/** Uncurried version of [removeAssoc](#removeAssoc). */ -let removeAssocU: (t<('a, 'c)>, 'b, (. 'a, 'b) => bool) => t<('a, 'c)> - -/** -Return a list after removing the first pair whose first value is `k` per the equality predicate `eqFunction`; if not found, return a new list identical to `someList`. - -## Examples - -```rescript -list{(1, "a"), (2, "b"), (3, "c")}->Belt.List.removeAssoc(1, (a, b) => a == b) /* list{(2, "b"), (3, "c")} */ - -list{(9, "morning"), (15, "afternoon"), (22, "night")} -->Belt.List.removeAssoc(9, (k, item) => k /* 9 */ == item /* 9, 5, 22 */) -/* list{(15, "afternoon"), (22, "night")} */ -``` -*/ -let removeAssoc: (t<('a, 'c)>, 'b, ('a, 'b) => bool) => t<('a, 'c)> - -/** Uncurried version of [setAssoc](#setAssoc). */ -let setAssocU: (t<('a, 'c)>, 'a, 'c, (. 'a, 'a) => bool) => t<('a, 'c)> - -/** -If `k` exists in `someList` by satisfying the `eqFunction` predicate, return a new list with the key and value replaced by the new `k` and `v`; otherwise, return a new list with the pair `k`, `v` added to the head of `someList`. - -## Examples - -```rescript -list{(1, "a"), (2, "b"), (3, "c")}->Belt.List.setAssoc(2, "x", (a, b) => a == b) /* list{(1, "a"), (2, "x"), (3, "c")} */ - -list{(1, "a"), (3, "c")}->Belt.List.setAssoc(2, "b", (a, b) => a == b) /* list{(2, "b"), (1, "a"), (3, "c")} */ - -list{(9, "morning"), (3, "morning?!"), (22, "night")} -->Belt.List.setAssoc(15, "afternoon", (a, b) => mod(a, 12) == mod(b, 12)) -/* list{(9, "morning"), (15, "afternoon"), (22, "night")} */ -``` - -**Please note** - -In the last example, since: `15 mod 12` equals `3 mod 12` - -Both the key _and_ the value are replaced in the list. -*/ -let setAssoc: (t<('a, 'c)>, 'a, 'c, ('a, 'a) => bool) => t<('a, 'c)> - -/** Uncurried version of [sort](#sort). */ -let sortU: (t<'a>, (. 'a, 'a) => int) => t<'a> - -/** -Returns a sorted list. - -## Examples - -```rescript -Belt.List.sort(list{5, 4, 9, 3, 7}, (a, b) => a - b) // list{3, 4, 5, 7, 9} -``` -*/ -let sort: (t<'a>, ('a, 'a) => int) => t<'a> diff --git a/jscomp/others/belt_Map.res b/jscomp/others/belt_Map.res deleted file mode 100644 index cfd9edf..0000000 --- a/jscomp/others/belt_Map.res +++ /dev/null @@ -1,164 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* Adapted by authors of ReScript without using functors */ -/* ********************************************************************* */ - -/** specalized when key type is `int`, more efficient - than the generic type -*/ -module Int = Belt_MapInt - -/** specalized when key type is `string`, more efficient - than the generic type */ -module String = Belt_MapString - -/** seprate function from data, a more verboe but slightly - more efficient -*/ -module Dict = Belt_MapDict - -type id<'key, 'id> = Belt_Id.comparable<'key, 'id> -type cmp<'key, 'id> = Belt_Id.cmp<'key, 'id> - -type t<'k, 'v, 'id> = { - cmp: cmp<'k, 'id>, - data: Dict.t<'k, 'v, 'id>, -} - -let fromArray = (type k idx, data, ~id: id) => { - module M = unpack(id) - let cmp = M.cmp - {cmp, data: Dict.fromArray(~cmp, data)} -} - -let remove = (m, x) => { - let {cmp, data: odata} = m - let newData = Dict.remove(odata, x, ~cmp) - if newData === odata { - m - } else { - {cmp, data: newData} - } -} - -let removeMany = (m, x) => { - let {cmp, data: odata} = m - let newData = Dict.removeMany(odata, x, ~cmp) - {cmp, data: newData} -} - -let set = (m, key, d) => { - let cmp = m.cmp - {cmp, data: Dict.set(~cmp, m.data, key, d)} -} - -let mergeMany = (m, e) => { - let cmp = m.cmp - {cmp, data: Dict.mergeMany(~cmp, m.data, e)} -} - -let updateU = (m, key, f) => { - let cmp = m.cmp - {cmp, data: Dict.updateU(~cmp, m.data, key, f)} -} -let update = (m, key, f) => updateU(m, key, (. a) => f(a)) -let split = (m, x) => { - let cmp = m.cmp - let ((l, r), b) = Dict.split(~cmp, m.data, x) - (({cmp, data: l}, {cmp, data: r}), b) -} - -let mergeU = (s1, s2, f) => { - let cmp = s1.cmp - {cmp, data: Dict.mergeU(~cmp, s1.data, s2.data, f)} -} - -let merge = (s1, s2, f) => mergeU(s1, s2, (. a, b, c) => f(a, b, c)) - -let make = (type key idx, ~id: id) => { - module M = unpack(id) - {cmp: M.cmp, data: Dict.empty} -} - -let isEmpty = map => Dict.isEmpty(map.data) - -let findFirstByU = (m, f) => Dict.findFirstByU(m.data, f) -let findFirstBy = (m, f) => findFirstByU(m, (. a, b) => f(a, b)) -let forEachU = (m, f) => Dict.forEachU(m.data, f) -let forEach = (m, f) => forEachU(m, (. a, b) => f(a, b)) -let reduceU = (m, acc, f) => Dict.reduceU(m.data, acc, f) -let reduce = (m, acc, f) => reduceU(m, acc, (. a, b, c) => f(a, b, c)) -let everyU = (m, f) => Dict.everyU(m.data, f) -let every = (m, f) => everyU(m, (. a, b) => f(a, b)) -let someU = (m, f) => Dict.someU(m.data, f) -let some = (m, f) => someU(m, (. a, b) => f(a, b)) -let keepU = (m, f) => {cmp: m.cmp, data: Dict.keepU(m.data, f)} -let keep = (m, f) => keepU(m, (. a, b) => f(a, b)) - -let partitionU = (m, p) => { - let cmp = m.cmp - let (l, r) = m.data->Dict.partitionU(p) - ({cmp, data: l}, {cmp, data: r}) -} -let partition = (m, p) => partitionU(m, (. a, b) => p(a, b)) - -let mapU = (m, f) => {cmp: m.cmp, data: Dict.mapU(m.data, f)} -let map = (m, f) => mapU(m, (. a) => f(a)) -let mapWithKeyU = (m, f) => {cmp: m.cmp, data: Dict.mapWithKeyU(m.data, f)} -let mapWithKey = (m, f) => mapWithKeyU(m, (. a, b) => f(a, b)) -let size = map => Dict.size(map.data) -let toList = map => Dict.toList(map.data) -let toArray = m => Dict.toArray(m.data) -let keysToArray = m => Dict.keysToArray(m.data) -let valuesToArray = m => Dict.valuesToArray(m.data) -let minKey = m => Dict.minKey(m.data) -let minKeyUndefined = m => Dict.minKeyUndefined(m.data) -let maxKey = m => Dict.maxKey(m.data) -let maxKeyUndefined = m => Dict.maxKeyUndefined(m.data) -let minimum = m => Dict.minimum(m.data) -let minUndefined = m => Dict.minUndefined(m.data) -let maximum = m => Dict.maximum(m.data) -let maxUndefined = m => Dict.maxUndefined(m.data) - -let get = (map, x) => Dict.get(~cmp=map.cmp, map.data, x) - -let getUndefined = (map, x) => Dict.getUndefined(~cmp=map.cmp, map.data, x) - -let getWithDefault = (map, x, def) => Dict.getWithDefault(~cmp=map.cmp, map.data, x, def) - -let getExn = (map, x) => Dict.getExn(~cmp=map.cmp, map.data, x) - -let has = (map, x) => Dict.has(~cmp=map.cmp, map.data, x) - -let checkInvariantInternal = m => Dict.checkInvariantInternal(m.data) - -let eqU = (m1, m2, veq) => Dict.eqU(~kcmp=m1.cmp, ~veq, m1.data, m2.data) -let eq = (m1, m2, veq) => eqU(m1, m2, (. a, b) => veq(a, b)) - -let cmpU = (m1, m2, vcmp) => Dict.cmpU(~kcmp=m1.cmp, ~vcmp, m1.data, m2.data) -let cmp = (m1, m2, vcmp) => cmpU(m1, m2, (. a, b) => vcmp(a, b)) - -let getData = m => m.data - -let getId = (type key identity, m: t): id => { - module T = { - type identity = identity - type t = key - let cmp = m.cmp - } - module(T) -} - -let packIdData = (type key idx, ~id: id, ~data) => { - module M = unpack(id) - {cmp: M.cmp, data} -} diff --git a/jscomp/others/belt_Map.resi b/jscomp/others/belt_Map.resi deleted file mode 100644 index ae5638d..0000000 --- a/jscomp/others/belt_Map.resi +++ /dev/null @@ -1,520 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* Adapted by authors of ReScript without using functors */ -/* ********************************************************************* */ - -/*** -The top level provides generic immutable map operations. - -It also has three specialized inner modules `Belt.Map.Int`, `Belt.Map.String` -and `Belt.Map.Dict`. -*/ - -/** -## Examples - -```rescript -type t<'key, 'value, 'identity> -type id<'key, 'id> = Belt_Id.comparable<'key, 'id> -``` -*/ - -module Int = Belt_MapInt - -module String = Belt_MapString - -module Dict = Belt_MapDict - -/** -`'key` is the field type - -`'value` is the element type - -`'identity` the identity of the collection -*/ -type t<'key, 'value, 'identity> - -/** The identity needed for making an empty map. */ -type id<'key, 'id> = Belt_Id.comparable<'key, 'id> - -/** -`make(~id)` creates a new map by taking in the comparator. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -let m = Belt.Map.make(~id=module(IntCmp)) - -Belt.Map.set(m, 0, "a") -``` -*/ -let make: (~id: id<'k, 'id>) => t<'k, 'v, 'id> - -/** - -`isEmpty(m)` checks whether a map m is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.isEmpty(Belt.Map.fromArray([(1, "1")], ~id=module(IntCmp))) == false -``` -*/ -let isEmpty: t<_> => bool - -/** -`has(m, k)` checks whether `m` has the key `k`. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.has(Belt.Map.fromArray([(1, "1")], ~id=module(IntCmp)), 1) == true -``` -*/ -let has: (t<'k, 'v, 'id>, 'k) => bool - -let cmpU: (t<'k, 'v, 'id>, t<'k, 'v, 'id>, (. 'v, 'v) => int) => int -/** -`cmp(m0, m1, vcmp);` - -Total ordering of map given total ordering of value function. - -It will compare size first and each element following the order one by one. -*/ -let cmp: (t<'k, 'v, 'id>, t<'k, 'v, 'id>, ('v, 'v) => int) => int - -let eqU: (t<'k, 'v, 'id>, t<'k, 'v, 'id>, (. 'v, 'v) => bool) => bool -/** -eq(m1, m2, veq)` tests whether the maps `m1` and `m2` are equal, that is, -contain equal keys and associate them with equal data. `veq` is the -equality predicate used to compare the data associated with the keys. -*/ -let eq: (t<'k, 'v, 'id>, t<'k, 'v, 'id>, ('v, 'v) => bool) => bool - -let findFirstByU: (t<'k, 'v, 'id>, (. 'k, 'v) => bool) => option<('k, 'v)> -/** ` -findFirstBy(m, p)` uses function `f` to find the first key value pair to match predicate `p`. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -let s0 = Belt.Map.fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2"), (3, "")]) - -Belt.Map.findFirstBy(s0, (k, v) => k == 4) /* (4, "4") */ -``` -*/ -let findFirstBy: (t<'k, 'v, 'id>, ('k, 'v) => bool) => option<('k, 'v)> - -let forEachU: (t<'k, 'v, 'id>, (. 'k, 'v) => unit) => unit -/** - `forEach(m, f)` applies `f` to all bindings in map `m`. `f` receives the -`'k` as first argument, and the associated value as second argument. The -bindings are passed to `f` in increasing order with respect to the ordering -over the type of the keys. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -let s0 = Belt.Map.fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2"), (3, "")]) - -let acc = ref(list{}) - -Belt.Map.forEach(s0, (k, v) => acc := list{(k, v), ...acc.contents}) - -acc.contents == list{(4, "4"), (3, "3"), (2, "2"), (1, "1")} -``` -*/ -let forEach: (t<'k, 'v, 'id>, ('k, 'v) => unit) => unit - -let reduceU: (t<'k, 'v, 'id>, 'acc, (. 'acc, 'k, 'v) => 'acc) => 'acc -/** - `reduce(m, a, f)` computes `(f(kN, dN) ... (f(k1, d1, a))...)`, where `k1 -... kN` are the keys of all bindings in m (in increasing order), and `d1 -... dN` are the associated data. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -let s0 = Belt.Map.fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2"), (3, "3")]) - -Belt.Map.reduce(s0, list{}, (acc, k, v) => list{ - (k, v), - ...acc, -}) /* [(4, "4"), (3, "3"), (2, "2"), (1, "1"), 0] */ -``` -*/ -let reduce: (t<'k, 'v, 'id>, 'acc, ('acc, 'k, 'v) => 'acc) => 'acc - -let everyU: (t<'k, 'v, 'id>, (. 'k, 'v) => bool) => bool -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate -`p`. Order unspecified -*/ -let every: (t<'k, 'v, 'id>, ('k, 'v) => bool) => bool - -let someU: (t<'k, 'v, 'id>, (. 'k, 'v) => bool) => bool -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate -`p`. Order unspecified */ -let some: (t<'k, 'v, 'id>, ('k, 'v) => bool) => bool - -/** - `size(s)` - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.size(Belt.Map.fromArray([(2, "2"), (2, "1"), (3, "3")], ~id=module(IntCmp))) == 2 -``` -*/ -let size: t<'k, 'v, 'id> => int - -/** - `toArray(s)` - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.toArray(Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp))) == [ - (1, "1"), - (2, "2"), - (3, "3"), - ] -``` -*/ -let toArray: t<'k, 'v, 'id> => array<('k, 'v)> - -/** In increasing order. See `Belt.Map.toArray`*/ -let toList: t<'k, 'v, 'id> => list<('k, 'v)> - -/** -`fromArray(kvs, ~id);` - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.toArray(Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp))) == [ - (1, "1"), - (2, "2"), - (3, "3"), - ] -``` -*/ -let fromArray: (array<('k, 'v)>, ~id: id<'k, 'id>) => t<'k, 'v, 'id> - -/** -`keysToArray(s);` - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.keysToArray(Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp))) == [ - 1, - 2, - 3, - ] -``` -*/ -let keysToArray: t<'k, 'v, 'id> => array<'k> - -/** - `valuesToArray(s);` - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.valuesToArray( - Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp)), -) == ["1", "2", "3"] -``` -*/ -let valuesToArray: t<'k, 'v, 'id> => array<'v> - -/** `minKey(s)` returns the minimum key, None if not exist. */ -let minKey: t<'k, _, _> => option<'k> - -/** See `Belt.Map.minKey` */ -let minKeyUndefined: t<'k, _, _> => Js.undefined<'k> - -/** `maxKey(s)` returns the maximum key, None if not exist. */ -let maxKey: t<'k, _, _> => option<'k> - -/** See `Belt.Map.maxKey` */ -let maxKeyUndefined: t<'k, _, _> => Js.undefined<'k> - -/** `minimum(s)` returns the minimum key value pair, None if not exist. */ -let minimum: t<'k, 'v, _> => option<('k, 'v)> - -/** See `Belt.Map.minimum` */ -let minUndefined: t<'k, 'v, _> => Js.undefined<('k, 'v)> - -/** `maximum(s)` returns the maximum key value pair, None if not exist. */ -let maximum: t<'k, 'v, _> => option<('k, 'v)> - -/** See `Belt.Map.maximum` */ -let maxUndefined: t<'k, 'v, _> => Js.undefined<('k, 'v)> - -/** - `get(s, k)` - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -Belt.Map.get(Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp)), 2) == - Some("2") - -Belt.Map.get(Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp)), 2) == None -``` -*/ -let get: (t<'k, 'v, 'id>, 'k) => option<'v> - -/** See `Belt.Map.get`. Returns `undefined` when not found*/ -let getUndefined: (t<'k, 'v, 'id>, 'k) => Js.undefined<'v> - -/** -`getWithDefault(s, k, default)` - -See `Belt.Map.get` - -Returns default when `k` is not found. -*/ -let getWithDefault: (t<'k, 'v, 'id>, 'k, 'v) => 'v - -/** -`getExn(s, k)` - -See `Belt.Map.getExn` - -raise when `k` not exist -*/ -let getExn: (t<'k, 'v, 'id>, 'k) => 'v - -/* ************************************************************************** */ - -/** -`remove(m, x)` when `x` is not in `m`, `m` is returned reference unchanged. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -let s0 = Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp)) - -let s1 = Belt.Map.remove(s0, 1) - -let s2 = Belt.Map.remove(s1, 1) - -s1 === s2 - -Belt.Map.keysToArray(s1) == [2, 3] -``` -*/ -let remove: (t<'k, 'v, 'id>, 'k) => t<'k, 'v, 'id> - -/** -`removeMany(s, xs)` - -Removing each of `xs` to `s`, note unlike `Belt.Map.remove`, the reference -of return value might be changed even if none in `xs` exists `s`. -*/ -let removeMany: (t<'k, 'v, 'id>, array<'k>) => t<'k, 'v, 'id> - -/** -`set(m, x, y)` returns a map containing the same bindings as `m`, with a -new binding of `x` to `y`. If `x` was already bound in `m`, its previous -binding disappears. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = (a, b) => Pervasives.compare(a, b) -}) - -let s0 = Belt.Map.fromArray([(2, "2"), (1, "1"), (3, "3")], ~id=module(IntCmp)) - -let s1 = Belt.Map.set(s0, 2, "3") - -Belt.Map.valuesToArray(s1) == ["1", "3", "3"] -``` -*/ -let set: (t<'k, 'v, 'id>, 'k, 'v) => t<'k, 'v, 'id> - -let updateU: (t<'k, 'v, 'id>, 'k, (. option<'v>) => option<'v>) => t<'k, 'v, 'id> -/** -`update(m, x, f)` returns a map containing the same bindings as `m`, except -for the binding of `x`. Depending on the value of `y` where `y` is -`f(get(m, x))`, the binding of `x` is added, removed or updated. If `y` is -`None`, the binding is removed if it exists; otherwise, if `y` is `Some(z)` -then `x` is associated to `z` in the resulting map. -*/ -let update: (t<'k, 'v, 'id>, 'k, option<'v> => option<'v>) => t<'k, 'v, 'id> - -/** - `mergeMany(s, xs)` - -Adding each of `xs` to `s`, note unlike `add`, the reference of return -value might be changed even if all values in `xs` exist `s`. -*/ -let mergeMany: (t<'k, 'v, 'id>, array<('k, 'v)>) => t<'k, 'v, 'id> - -let mergeU: ( - t<'k, 'v, 'id>, - t<'k, 'v2, 'id>, - (. 'k, option<'v>, option<'v2>) => option<'v3>, -) => t<'k, 'v3, 'id> -/** -`merge(m1, m2, f)` computes a map whose keys is a subset of keys of `m1` -and of `m2`. The presence of each such binding, and the corresponding -value, is determined with the function `f`. -*/ -let merge: ( - t<'k, 'v, 'id>, - t<'k, 'v2, 'id>, - ('k, option<'v>, option<'v2>) => option<'v3>, -) => t<'k, 'v3, 'id> - -let keepU: (t<'k, 'v, 'id>, (. 'k, 'v) => bool) => t<'k, 'v, 'id> -/** -`keep(m, p)` returns the map with all the bindings in m that satisfy -predicate `p`. -*/ -let keep: (t<'k, 'v, 'id>, ('k, 'v) => bool) => t<'k, 'v, 'id> - -let partitionU: (t<'k, 'v, 'id>, (. 'k, 'v) => bool) => (t<'k, 'v, 'id>, t<'k, 'v, 'id>) -/** -`partition(m, p)` returns a pair of maps `(m1, m2)`, where `m1` contains -all the bindings of `s` that satisfy the predicate `p`, and `m2` is the map -with all the bindings of `s` that do not satisfy `p`. -*/ -let partition: (t<'k, 'v, 'id>, ('k, 'v) => bool) => (t<'k, 'v, 'id>, t<'k, 'v, 'id>) - -/** -`split(x, m)` returns a tuple `(l, r)`, data, where `l` is the map with all -the bindings of `m` whose 'k is strictly less than `x`; `r` is the map with -all the bindings of m whose 'k is strictly greater than `x`; `data` is -`None` if `m` contains no binding for `x`, or `Some(v)` if `m` binds `v` to -`x`. -*/ -let split: (t<'k, 'v, 'id>, 'k) => ((t<'k, 'v, 'id>, t<'k, 'v, 'id>), option<'v>) - -let mapU: (t<'k, 'v, 'id>, (. 'v) => 'v2) => t<'k, 'v2, 'id> -/** -`map(m, f) returns a map with same domain as`m`, where the associated -value`a`of all bindings of`m`has been replaced by the result of the -application of`f`to`a`. The bindings are passed to`f` in increasing order -with respect to the ordering over the type of the keys. -*/ -let map: (t<'k, 'v, 'id>, 'v => 'v2) => t<'k, 'v2, 'id> - -let mapWithKeyU: (t<'k, 'v, 'id>, (. 'k, 'v) => 'v2) => t<'k, 'v2, 'id> -/** -`mapWithKey(m, f)` - -The same as `Belt.Map.map` except that `f` is supplied with one more -argument: the key. -*/ -let mapWithKey: (t<'k, 'v, 'id>, ('k, 'v) => 'v2) => t<'k, 'v2, 'id> - -/** -`getData(s0)` - -Advanced usage only - -Returns the raw data (detached from comparator), but its type is still -manifested, so that user can pass identity directly without boxing. -*/ -let getData: t<'k, 'v, 'id> => Belt_MapDict.t<'k, 'v, 'id> - -/** -Advanced usage only. Returns the identity of s0. -*/ -let getId: t<'k, 'v, 'id> => id<'k, 'id> - -/** -`packIdData(~id, ~data)` - -Advanced usage only - -Returns the packed collection. -*/ -let packIdData: (~id: id<'k, 'id>, ~data: Belt_MapDict.t<'k, 'v, 'id>) => t<'k, 'v, 'id> - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit diff --git a/jscomp/others/belt_MapDict.res b/jscomp/others/belt_MapDict.res deleted file mode 100644 index 0b9dff9..0000000 --- a/jscomp/others/belt_MapDict.res +++ /dev/null @@ -1,294 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module N = Belt_internalAVLtree -module A = Belt_Array - -type t<'key, 'a, 'id> = N.t<'key, 'a> - -type cmp<'key, 'id> = Belt_Id.cmp<'key, 'id> - -let empty = None -let fromArray = N.fromArray -let isEmpty = N.isEmpty -let cmp = N.cmp -let cmpU = N.cmpU -let eq = N.eq -let eqU = N.eqU -let has = N.has - -let forEach = N.forEach -let forEachU = N.forEachU -let reduce = N.reduce -let reduceU = N.reduceU -let every = N.every -let everyU = N.everyU -let some = N.some -let someU = N.someU - -let size = N.size -let toList = N.toList -let toArray = N.toArray -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray - -let minimum = N.minimum -let maximum = N.maximum -let minKey = N.minKey -let maxKey = N.maxKey -let minKeyUndefined = N.minKeyUndefined -let maxKeyUndefined = N.maxKeyUndefined -let minUndefined = N.minUndefined -let maxUndefined = N.maxUndefined -let get = N.get -let getUndefined = N.getUndefined -let getWithDefault = N.getWithDefault -let getExn = N.getExn - -let mapWithKey = N.mapWithKey -let mapWithKeyU = N.mapWithKeyU - -let mapU = N.mapU -let map = N.map -let keep = N.keepShared -let keepU = N.keepSharedU -let partitionU = N.partitionSharedU -let partition = N.partitionShared -let checkInvariantInternal = N.checkInvariantInternal -let rec set = (t: t<_>, newK, newD, ~cmp) => - switch t { - | None => N.singleton(newK, newD) - | Some(n) => - let k = n.N.key - let c = Belt_Id.getCmpInternal(cmp)(. newK, k) - if c == 0 { - Some(N.updateValue(n, newD)) - } else { - let (l, r, v) = (n.N.left, n.N.right, n.N.value) - if c < 0 { - /* Worth optimize for reference equality? */ - N.bal(set(~cmp, l, newK, newD), k, v, r) - } else { - N.bal(l, k, v, set(~cmp, r, newK, newD)) - } - } - } - -let rec updateU = (t: t<_>, newK, f, ~cmp): t<_> => - switch t { - | None => - switch f(. None) { - | None => t - | Some(newD) => N.singleton(newK, newD) - } - | Some(n) => - let k = n.N.key - let c = Belt_Id.getCmpInternal(cmp)(. newK, k) - if c == 0 { - switch f(. Some(n.N.value)) { - | None => - let (l, r) = (n.N.left, n.N.right) - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.key), ref(rn.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - | Some(newD) => Some(N.updateValue(n, newD)) - } - } else { - let (l, r, v) = (n.N.left, n.N.right, n.N.value) - if c < 0 { - let ll = updateU(~cmp, l, newK, f) - if l === ll { - t - } else { - N.bal(ll, k, v, r) - } - } else { - let rr = updateU(~cmp, r, newK, f) - if r === rr { - t - } else { - N.bal(l, k, v, rr) - } - } - } - } - -let update = (t, newK, f, ~cmp) => updateU(t, newK, (. a) => f(a), ~cmp) - -/* unboxing API was not exported - since the correct API is really awkard - `bool -> 'k Js.null -> ('a Js.null * bool)` - even for specialized `k` the first `bool` can - be erased, maybe the perf boost does not justify the inclusion of such API - - `updateWithNull m x f` - the callback to `f exist v` - when `v` is non-null, - `exist` is guaranteed to be true - `v` is guranteed to be `null`, - when `exist` is `true`, `v` could be `null`, - since `'a` is polymorphic -*/ - -let rec removeAux0 = (n, x, ~cmp) => { - let {N.left: l, key: v, right: r} = n - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.key), ref(rn.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - } else if c < 0 { - switch l { - | None => Some(n) /* Nothing to remove */ - | Some(left) => - let ll = removeAux0(left, x, ~cmp) - if ll === l { - Some(n) - } else { - N.bal(ll, v, n.N.value, r) - } - } - } else { - switch r { - | None => Some(n) /* Nothing to remove */ - | Some(right) => - let rr = removeAux0(~cmp, right, x) - if rr === r { - Some(n) - } else { - N.bal(l, v, n.N.value, rr) - } - } - } -} - -let remove = (n, x, ~cmp) => - switch n { - | None => None - | Some(n) => removeAux0(n, x, ~cmp) - } - -let mergeMany = (h, arr, ~cmp) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let (key, value) = A.getUnsafe(arr, i) - v.contents = set(v.contents, ~cmp, key, value) - } - v.contents -} - -let rec splitAuxPivot = (n, x, pres, ~cmp) => { - let {N.left: l, key: v, value: d, right: r} = n - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - pres.contents = Some(d) - (l, r) - } else if c < 0 { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxPivot(~cmp, l, x, pres) - (ll, N.join(rl, v, d, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxPivot(~cmp, r, x, pres) - (N.join(l, v, d, lr), rr) - } - } -} - -let split = (n, x, ~cmp) => - switch n { - | None => ((None, None), None) - | Some(n) => - let pres = ref(None) - let v = splitAuxPivot(~cmp, n, x, pres) - (v, pres.contents) - } - -let findFirstByU = N.findFirstByU -let findFirstBy = N.findFirstBy - -let rec mergeU = (s1, s2, f, ~cmp) => - switch (s1, s2) { - | (None, None) => None - | (Some(_), None) => N.keepMapU(s1, (. k, v) => f(. k, Some(v), None)) - | (None, Some(_)) => N.keepMapU(s2, (. k, v) => f(. k, None, Some(v))) - | (Some(s1n), Some(s2n)) => - if s1n.height >= s2n.height { - let {N.left: l1, key: v1, value: d1, right: r1} = s1n - let d2 = ref(None) - let (l2, r2) = splitAuxPivot(~cmp, s2n, v1, d2) - let d2 = d2.contents - let newLeft = mergeU(~cmp, l1, l2, f) - let newD = f(. v1, Some(d1), d2) - let newRight = mergeU(~cmp, r1, r2, f) - N.concatOrJoin(newLeft, v1, newD, newRight) - } else { - let {N.left: l2, key: v2, value: d2, right: r2} = s2n - let d1 = ref(None) - let (l1, r1) = splitAuxPivot(~cmp, s1n, v2, d1) - let d1 = d1.contents - let newLeft = mergeU(~cmp, l1, l2, f) - let newD = f(. v2, d1, Some(d2)) - let newRight = mergeU(~cmp, r1, r2, f) - N.concatOrJoin(newLeft, v2, newD, newRight) - } - } - -let merge = (s1, s2, f, ~cmp) => mergeU(s1, s2, (. a, b, c) => f(a, b, c), ~cmp) - -let rec removeMany0 = (t, xs, i, len, ~cmp) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeAux0(t, ele, ~cmp) - switch u { - | None => u - | Some(t) => removeMany0(t, xs, i + 1, len, ~cmp) - } - } else { - Some(t) - } - -let removeMany = (t, keys, ~cmp) => { - let len = A.length(keys) - switch t { - | None => None - | Some(t) => removeMany0(t, keys, 0, len, ~cmp) - } -} diff --git a/jscomp/others/belt_MapDict.resi b/jscomp/others/belt_MapDict.resi deleted file mode 100644 index 7dafef6..0000000 --- a/jscomp/others/belt_MapDict.resi +++ /dev/null @@ -1,234 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module separates identity from data, it is a bit more verbose but -slightly more efficient due to the fact that there is no need to pack -identity and data back after each operation. - -**_Advanced usage only_** -*/ - -/* -## Examples - -```rescript -type t<'key, 'value, 'id> -type cmp<'key, 'id> = Belt_Id.cmp<'key, 'id> -``` -*/ - -type t<'key, 'value, 'id> - -type cmp<'key, 'id> = Belt_Id.cmp<'key, 'id> - -let empty: t<'k, 'v, 'id> - -let isEmpty: t<'k, 'v, 'id> => bool - -let has: (t<'k, 'a, 'id>, 'k, ~cmp: cmp<'k, 'id>) => bool - -let cmpU: (t<'k, 'v, 'id>, t<'k, 'v, 'id>, ~kcmp: cmp<'k, 'id>, ~vcmp: (. 'v, 'v) => int) => int -let cmp: (t<'k, 'v, 'id>, t<'k, 'v, 'id>, ~kcmp: cmp<'k, 'id>, ~vcmp: ('v, 'v) => int) => int - -let eqU: (t<'k, 'a, 'id>, t<'k, 'a, 'id>, ~kcmp: cmp<'k, 'id>, ~veq: (. 'a, 'a) => bool) => bool -/** -`eq(m1, m2, cmp)` tests whether the maps `m1` and `m2` are equal, that is, -contain equal keys and associate them with equal data. `cmp` is the -equality predicate used to compare the data associated with the keys. -*/ -let eq: (t<'k, 'a, 'id>, t<'k, 'a, 'id>, ~kcmp: cmp<'k, 'id>, ~veq: ('a, 'a) => bool) => bool - -let findFirstByU: (t<'k, 'v, 'id>, (. 'k, 'v) => bool) => option<('k, 'v)> -/** -`findFirstBy(m, p)` uses function `f` to find the first key value pair to -match predicate `p`. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Map.Dict.fromArray([(4, "4"), (1, "1"), (2, "2"), (3, "3")], ~cmp=IntCmp.cmp) - -Belt.Map.Dict.findFirstBy(s0, (k, _) => k == 4) == Some((4, "4")) -``` -*/ -let findFirstBy: (t<'k, 'v, 'id>, ('k, 'v) => bool) => option<('k, 'v)> - -let forEachU: (t<'k, 'a, 'id>, (. 'k, 'a) => unit) => unit -/** -`forEach(m, f)` applies `f` to all bindings in map `m`. `f` receives the -key as first argument, and the associated value as second argument. The -bindings are passed to `f` in increasing order with respect to the ordering -over the type of the keys. -*/ -let forEach: (t<'k, 'a, 'id>, ('k, 'a) => unit) => unit - -let reduceU: (t<'k, 'a, 'id>, 'b, (. 'b, 'k, 'a) => 'b) => 'b -/** -`reduce(m, a, f)` computes `f(kN, dN ... f(k1, d1, a)...)`, where `k1 ... kN` -are the keys of all bindings in `m` (in increasing order), and `d1 ... dN` -are the associated data. -*/ -let reduce: (t<'k, 'a, 'id>, 'b, ('b, 'k, 'a) => 'b) => 'b - -let everyU: (t<'k, 'a, 'id>, (. 'k, 'a) => bool) => bool -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate -`p`. Order unspecified -*/ -let every: (t<'k, 'a, 'id>, ('k, 'a) => bool) => bool - -let someU: (t<'k, 'a, 'id>, (. 'k, 'a) => bool) => bool -/** -`some(m, p)` checks if at least one binding of the map satisfy the -predicate `p`. Order unspecified -*/ -let some: (t<'k, 'a, 'id>, ('k, 'a) => bool) => bool - -let size: t<'k, 'a, 'id> => int - -/** In increasing order. */ -let toList: t<'k, 'a, 'id> => list<('k, 'a)> - -let toArray: t<'k, 'a, 'id> => array<('k, 'a)> - -let fromArray: (array<('k, 'a)>, ~cmp: cmp<'k, 'id>) => t<'k, 'a, 'id> - -let keysToArray: t<'k, 'a, 'id> => array<'k> - -let valuesToArray: t<'k, 'a, 'id> => array<'a> - -let minKey: t<'k, _, _> => option<'k> - -let minKeyUndefined: t<'k, _, _> => Js.undefined<'k> - -let maxKey: t<'k, _, _> => option<'k> - -let maxKeyUndefined: t<'k, _, _> => Js.undefined<'k> - -let minimum: t<'k, 'a, _> => option<('k, 'a)> - -let minUndefined: t<'k, 'a, _> => Js.undefined<('k, 'a)> - -let maximum: t<'k, 'a, _> => option<('k, 'a)> - -let maxUndefined: t<'k, 'a, _> => Js.undefined<('k, 'a)> - -let get: (t<'k, 'a, 'id>, 'k, ~cmp: cmp<'k, 'id>) => option<'a> - -let getUndefined: (t<'k, 'a, 'id>, 'k, ~cmp: cmp<'k, 'id>) => Js.undefined<'a> - -let getWithDefault: (t<'k, 'a, 'id>, 'k, 'a, ~cmp: cmp<'k, 'id>) => 'a - -let getExn: (t<'k, 'a, 'id>, 'k, ~cmp: cmp<'k, 'id>) => 'a - -let checkInvariantInternal: t<_> => unit - -/** -`remove(m, x)` returns a map containing the same bindings as `m`, except -for `x` which is unbound in the returned map. -*/ -let remove: (t<'a, 'b, 'id>, 'a, ~cmp: cmp<'a, 'id>) => t<'a, 'b, 'id> - -let removeMany: (t<'a, 'b, 'id>, array<'a>, ~cmp: cmp<'a, 'id>) => t<'a, 'b, 'id> - -/** -`set(m, x, y)` returns a map containing the same bindings as `m`, plus a -binding of `x` to `y`. If `x` was already bound in `m`, its previous -binding disappears. -*/ -let set: (t<'a, 'b, 'id>, 'a, 'b, ~cmp: cmp<'a, 'id>) => t<'a, 'b, 'id> - -let updateU: ( - t<'a, 'b, 'id>, - 'a, - (. option<'b>) => option<'b>, - ~cmp: cmp<'a, 'id>, -) => t<'a, 'b, 'id> -let update: (t<'a, 'b, 'id>, 'a, option<'b> => option<'b>, ~cmp: cmp<'a, 'id>) => t<'a, 'b, 'id> - -let mergeU: ( - t<'a, 'b, 'id>, - t<'a, 'c, 'id>, - (. 'a, option<'b>, option<'c>) => option<'d>, - ~cmp: cmp<'a, 'id>, -) => t<'a, 'd, 'id> -/** -`merge(m1, m2, f)` computes a map whose keys is a subset of keys of `m1` -and of `m2`. The presence of each such binding, and the corresponding -value, is determined with the function `f`. -*/ -let merge: ( - t<'a, 'b, 'id>, - t<'a, 'c, 'id>, - ('a, option<'b>, option<'c>) => option<'d>, - ~cmp: cmp<'a, 'id>, -) => t<'a, 'd, 'id> - -let mergeMany: (t<'a, 'b, 'id>, array<('a, 'b)>, ~cmp: cmp<'a, 'id>) => t<'a, 'b, 'id> - -let keepU: (t<'k, 'a, 'id>, (. 'k, 'a) => bool) => t<'k, 'a, 'id> -/** -`keep(m, p)` returns the map with all the bindings in `m` that satisfy -predicate `p`. -*/ -let keep: (t<'k, 'a, 'id>, ('k, 'a) => bool) => t<'k, 'a, 'id> - -let partitionU: (t<'k, 'a, 'id>, (. 'k, 'a) => bool) => (t<'k, 'a, 'id>, t<'k, 'a, 'id>) -/** -`partition(m, p)` returns a pair of maps `(m1, m2)`, where `m1` contains -all the bindings of `s` that satisfy the predicate `p`, and `m2` is the map -with all the bindings of `s` that do not satisfy `p`. -*/ -let partition: (t<'k, 'a, 'id>, ('k, 'a) => bool) => (t<'k, 'a, 'id>, t<'k, 'a, 'id>) - -/** -`split(x, m)` returns a triple `(l, data, r)`, where `l` is the map with -all the bindings of `m` whose key is strictly less than `x`; `r` is the map -with all the bindings of `m` whose key is strictly greater than `x`; `data` -is `None` if `m` contains no binding for `x`, or `Some(v)` if `m` binds `v` -to `x`. -*/ -let split: ( - t<'a, 'b, 'id>, - 'a, - ~cmp: cmp<'a, 'id>, -) => ((t<'a, 'b, 'id>, t<'a, 'b, 'id>), option<'b>) - -let mapU: (t<'k, 'a, 'id>, (. 'a) => 'b) => t<'k, 'b, 'id> -/** -`map(m, f)` returns a map with same domain as `m`, where the associated -value `a` of all bindings of `m` has been replaced by the result of the -application of `f` to `a`. The bindings are passed to `f` in increasing -order with respect to the ordering over the type of the keys. -*/ -let map: (t<'k, 'a, 'id>, 'a => 'b) => t<'k, 'b, 'id> - -let mapWithKeyU: (t<'k, 'a, 'id>, (. 'k, 'a) => 'b) => t<'k, 'b, 'id> -let mapWithKey: (t<'k, 'a, 'id>, ('k, 'a) => 'b) => t<'k, 'b, 'id> diff --git a/jscomp/others/belt_MapInt.res b/jscomp/others/belt_MapInt.res deleted file mode 100644 index d560164..0000000 --- a/jscomp/others/belt_MapInt.res +++ /dev/null @@ -1,192 +0,0 @@ -type key = int -module I = Belt_internalMapInt - -module N = Belt_internalAVLtree -module A = Belt_Array - -type t<'a> = N.t - -let empty = None -let isEmpty = N.isEmpty -/* let singleton = N.singleton */ - -let minKey = N.minKey -let minKeyUndefined = N.minKeyUndefined -let maxKey = N.maxKey -let maxKeyUndefined = N.maxKeyUndefined -let minimum = N.minimum -let minUndefined = N.minUndefined -let maximum = N.maximum -let maxUndefined = N.maxUndefined -let forEachU = N.forEachU -let forEach = N.forEach -let mapU = N.mapU -let map = N.map -let mapWithKeyU = N.mapWithKeyU -let mapWithKey = N.mapWithKey -let reduceU = N.reduceU -let reduce = N.reduce -let everyU = N.everyU -let every = N.every -let someU = N.someU -let some = N.some -let keepU = N.keepSharedU -let keep = N.keepShared -let partitionU = N.partitionSharedU -let partition = N.partitionShared -let size = N.size -let toList = N.toList -let toArray = N.toArray -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray -let checkInvariantInternal = N.checkInvariantInternal - -let rec set = (t, newK: key, newD: _) => - switch t { - | None => N.singleton(newK, newD) - | Some(n) => - let k = n.N.key - if newK == k { - Some(N.updateValue(n, newD)) - } else { - let v = n.N.value - if newK < k { - N.bal(set(n.N.left, newK, newD), k, v, n.N.right) - } else { - N.bal(n.N.left, k, v, set(n.N.right, newK, newD)) - } - } - } - -let rec updateU = (t, x: key, f) => - switch t { - | None => - switch f(. None) { - | None => t - | Some(data) => N.singleton(x, data) - } - | Some(n) => - let k = n.N.key - if x == k { - switch f(. Some(n.N.value)) { - | None => - let {N.left: l, right: r} = n - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.N.key), ref(rn.N.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - | Some(data) => Some(N.updateValue(n, data)) - } - } else { - let {N.left: l, right: r, value: v} = n - if x < k { - let ll = updateU(l, x, f) - if l === ll { - t - } else { - N.bal(ll, k, v, r) - } - } else { - let rr = updateU(r, x, f) - if r === rr { - t - } else { - N.bal(l, k, v, rr) - } - } - } - } - -let update = (t, x, f) => updateU(t, x, (. a) => f(a)) - -let rec removeAux = (n, x: key) => { - let {N.left: l, key: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.N.key), ref(rn.N.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - } else if x < v { - switch l { - | None => Some(n) - | Some(left) => - let ll = removeAux(left, x) - if ll === l { - Some(n) - } else { - open N - bal(ll, v, n.value, r) - } - } - } else { - switch r { - | None => Some(n) - | Some(right) => - let rr = removeAux(right, x) - N.bal(l, v, n.N.value, rr) - } - } -} - -let remove = (n, x) => - switch n { - | None => None - | Some(n) => removeAux(n, x) - } - -let rec removeMany0 = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeAux(t, ele) - switch u { - | None => u - | Some(t) => removeMany0(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (t, keys) => { - let len = A.length(keys) - switch t { - | None => None - | Some(t) => removeMany0(t, keys, 0, len) - } -} - -let findFirstByU = N.findFirstByU -let findFirstBy = N.findFirstBy - -let mergeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let (key, value) = A.getUnsafe(arr, i) - v.contents = set(v.contents, key, value) - } - v.contents -} - -/* let mergeArray = mergeMany */ - -let has = I.has -let cmpU = I.cmpU -let cmp = I.cmp -let eqU = I.eqU -let eq = I.eq -let get = I.get -let getUndefined = I.getUndefined -let getWithDefault = I.getWithDefault -let getExn = I.getExn -let split = I.split -let mergeU = I.mergeU -let merge = I.merge -let fromArray = I.fromArray diff --git a/jscomp/others/belt_MapInt.resi b/jscomp/others/belt_MapInt.resi deleted file mode 100644 index a4c1f60..0000000 --- a/jscomp/others/belt_MapInt.resi +++ /dev/null @@ -1,175 +0,0 @@ -type key = int - -/** The type of maps from type `key` to type `'value`. */ -type t<'value> - -let empty: t<'v> - -let isEmpty: t<'v> => bool - -let has: (t<'v>, key) => bool - -let cmpU: (t<'v>, t<'v>, (. 'v, 'v) => int) => int -let cmp: (t<'v>, t<'v>, ('v, 'v) => int) => int - -let eqU: (t<'v>, t<'v>, (. 'v, 'v) => bool) => bool - -/** -`eq(m1, m2)` tests whether the maps `m1` and `m2` are -equal, that is, contain equal keys and associate them with -equal data. -*/ -let eq: (t<'v>, t<'v>, ('v, 'v) => bool) => bool - -let findFirstByU: (t<'v>, (. key, 'v) => bool) => option<(key, 'v)> - -/** -`findFirstBy(m, p)` uses funcion `f` to find the first key value pair -to match predicate `p`. - -```rescript -let s0 = fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2,"(3, ""))]) -findFirstBy(s0, (k, v) => k == 4) == option((4, "4")) -``` -*/ -let findFirstBy: (t<'v>, (key, 'v) => bool) => option<(key, 'v)> - -let forEachU: (t<'v>, (. key, 'v) => unit) => unit - -/** -`forEach(m, f)` applies `f` to all bindings in map `m`. -`f` receives the key as first argument, and the associated value -as second argument. The bindings are passed to `f` in increasing -order with respect to the ordering over the type of the keys. -*/ -let forEach: (t<'v>, (key, 'v) => unit) => unit - -let reduceU: (t<'v>, 'v2, (. 'v2, key, 'v) => 'v2) => 'v2 - -/** -`reduce(m, a, f)` computes `(f kN dN ... (f k1 d1 a)...)`, -where `k1 ... kN` are the keys of all bindings in `m` -(in increasing order), and `d1 ... dN` are the associated data. -*/ -let reduce: (t<'v>, 'v2, ('v2, key, 'v) => 'v2) => 'v2 - -let everyU: (t<'v>, (. key, 'v) => bool) => bool - -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate `p`. -Order unspecified */ -let every: (t<'v>, (key, 'v) => bool) => bool - -let someU: (t<'v>, (. key, 'v) => bool) => bool - -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate -`p`. Order unspecified */ -let some: (t<'v>, (key, 'v) => bool) => bool - -let size: t<'v> => int - -/** In increasing order. */ -let toList: t<'v> => list<(key, 'v)> - -let toArray: t<'v> => array<(key, 'v)> - -let fromArray: array<(key, 'v)> => t<'v> - -let keysToArray: t<'v> => array - -let valuesToArray: t<'v> => array<'v> - -let minKey: t<_> => option - -let minKeyUndefined: t<_> => Js.undefined - -let maxKey: t<_> => option - -let maxKeyUndefined: t<_> => Js.undefined - -let minimum: t<'v> => option<(key, 'v)> - -let minUndefined: t<'v> => Js.undefined<(key, 'v)> - -let maximum: t<'v> => option<(key, 'v)> - -let maxUndefined: t<'v> => Js.undefined<(key, 'v)> - -let get: (t<'v>, key) => option<'v> - -let getUndefined: (t<'v>, key) => Js.undefined<'v> - -let getWithDefault: (t<'v>, key, 'v) => 'v - -let getExn: (t<'v>, key) => 'v - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/** `remove m x` returns a map containing the same bindings as - `m`, except for `x` which is unbound in the returned map. */ -let remove: (t<'v>, key) => t<'v> - -let removeMany: (t<'v>, array) => t<'v> - -/** -`set(m, x, y)` returns a map containing the same bindings as -`m`, plus a binding of `x` to `y`. If `x` was already bound -in `m`, its previous binding disappears. -*/ -let set: (t<'v>, key, 'v) => t<'v> - -let updateU: (t<'v>, key, (. option<'v>) => option<'v>) => t<'v> -let update: (t<'v>, key, option<'v> => option<'v>) => t<'v> - -let mergeU: (t<'v>, t<'v2>, (. key, option<'v>, option<'v2>) => option<'c>) => t<'c> - -/** -`merge(m1, m2, f)` computes a map whose keys is a subset of keys of `m1` -and of `m2`. The presence of each such binding, and the corresponding -value, is determined with the function `f`. -*/ -let merge: (t<'v>, t<'v2>, (key, option<'v>, option<'v2>) => option<'c>) => t<'c> - -let mergeMany: (t<'v>, array<(key, 'v)>) => t<'v> - -let keepU: (t<'v>, (. key, 'v) => bool) => t<'v> - -/** -`keep(m, p)` returns the map with all the bindings in `m` that satisfy predicate -`p`. -*/ -let keep: (t<'v>, (key, 'v) => bool) => t<'v> - -let partitionU: (t<'v>, (. key, 'v) => bool) => (t<'v>, t<'v>) - -/** -`partition(m, p)` returns a pair of maps `(m1, m2)`, where `m1` contains all the -bindings of `s` that satisfy the predicate `p`, and `m2` is the map with all the -bindings of `s` that do not satisfy `p`. -*/ -let partition: (t<'v>, (key, 'v) => bool) => (t<'v>, t<'v>) - -/** -`split(x, m)` returns a triple `(l, data, r)`, where `l` is the map with all the -bindings of `m` whose key is strictly less than `x`; `r` is the map with all the -bindings of `m` whose key is strictly greater than `x`; `data` is `None` if `m` -contains no binding for `x`, or `Some(v)` if `m` binds `v` to `x`. -*/ -let split: (key, t<'v>) => (t<'v>, option<'v>, t<'v>) - -let mapU: (t<'v>, (. 'v) => 'v2) => t<'v2> - -/** -`map(m, f)` returns a map with same domain as `m`, where the associated value `a` -of all bindings of `m` has been replaced by the result of the application of `f` -to `a`. The bindings are passed to `f` in increasing order with respect to the -ordering over the type of the keys. -*/ -let map: (t<'v>, 'v => 'v2) => t<'v2> - -let mapWithKeyU: (t<'v>, (. key, 'v) => 'v2) => t<'v2> -let mapWithKey: (t<'v>, (key, 'v) => 'v2) => t<'v2> diff --git a/jscomp/others/belt_MapString.res b/jscomp/others/belt_MapString.res deleted file mode 100644 index 460e6a4..0000000 --- a/jscomp/others/belt_MapString.res +++ /dev/null @@ -1,192 +0,0 @@ -type key = string -module I = Belt_internalMapString - -module N = Belt_internalAVLtree -module A = Belt_Array - -type t<'a> = N.t - -let empty = None -let isEmpty = N.isEmpty -/* let singleton = N.singleton */ - -let minKey = N.minKey -let minKeyUndefined = N.minKeyUndefined -let maxKey = N.maxKey -let maxKeyUndefined = N.maxKeyUndefined -let minimum = N.minimum -let minUndefined = N.minUndefined -let maximum = N.maximum -let maxUndefined = N.maxUndefined -let forEachU = N.forEachU -let forEach = N.forEach -let mapU = N.mapU -let map = N.map -let mapWithKeyU = N.mapWithKeyU -let mapWithKey = N.mapWithKey -let reduceU = N.reduceU -let reduce = N.reduce -let everyU = N.everyU -let every = N.every -let someU = N.someU -let some = N.some -let keepU = N.keepSharedU -let keep = N.keepShared -let partitionU = N.partitionSharedU -let partition = N.partitionShared -let size = N.size -let toList = N.toList -let toArray = N.toArray -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray -let checkInvariantInternal = N.checkInvariantInternal - -let rec set = (t, newK: key, newD: _) => - switch t { - | None => N.singleton(newK, newD) - | Some(n) => - let k = n.N.key - if newK == k { - Some(N.updateValue(n, newD)) - } else { - let v = n.N.value - if newK < k { - N.bal(set(n.N.left, newK, newD), k, v, n.N.right) - } else { - N.bal(n.N.left, k, v, set(n.N.right, newK, newD)) - } - } - } - -let rec updateU = (t, x: key, f) => - switch t { - | None => - switch f(. None) { - | None => t - | Some(data) => N.singleton(x, data) - } - | Some(n) => - let k = n.N.key - if x == k { - switch f(. Some(n.N.value)) { - | None => - let {N.left: l, right: r} = n - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.N.key), ref(rn.N.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - | Some(data) => Some(N.updateValue(n, data)) - } - } else { - let {N.left: l, right: r, value: v} = n - if x < k { - let ll = updateU(l, x, f) - if l === ll { - t - } else { - N.bal(ll, k, v, r) - } - } else { - let rr = updateU(r, x, f) - if r === rr { - t - } else { - N.bal(l, k, v, rr) - } - } - } - } - -let update = (t, x, f) => updateU(t, x, (. a) => f(a)) - -let rec removeAux = (n, x: key) => { - let {N.left: l, key: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.N.key), ref(rn.N.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - } else if x < v { - switch l { - | None => Some(n) - | Some(left) => - let ll = removeAux(left, x) - if ll === l { - Some(n) - } else { - open N - bal(ll, v, n.value, r) - } - } - } else { - switch r { - | None => Some(n) - | Some(right) => - let rr = removeAux(right, x) - N.bal(l, v, n.N.value, rr) - } - } -} - -let remove = (n, x) => - switch n { - | None => None - | Some(n) => removeAux(n, x) - } - -let rec removeMany0 = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeAux(t, ele) - switch u { - | None => u - | Some(t) => removeMany0(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (t, keys) => { - let len = A.length(keys) - switch t { - | None => None - | Some(t) => removeMany0(t, keys, 0, len) - } -} - -let findFirstByU = N.findFirstByU -let findFirstBy = N.findFirstBy - -let mergeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let (key, value) = A.getUnsafe(arr, i) - v.contents = set(v.contents, key, value) - } - v.contents -} - -/* let mergeArray = mergeMany */ - -let has = I.has -let cmpU = I.cmpU -let cmp = I.cmp -let eqU = I.eqU -let eq = I.eq -let get = I.get -let getUndefined = I.getUndefined -let getWithDefault = I.getWithDefault -let getExn = I.getExn -let split = I.split -let mergeU = I.mergeU -let merge = I.merge -let fromArray = I.fromArray diff --git a/jscomp/others/belt_MapString.resi b/jscomp/others/belt_MapString.resi deleted file mode 100644 index 5cd8792..0000000 --- a/jscomp/others/belt_MapString.resi +++ /dev/null @@ -1,175 +0,0 @@ -type key = string - -/** The type of maps from type `key` to type `'value`. */ -type t<'value> - -let empty: t<'v> - -let isEmpty: t<'v> => bool - -let has: (t<'v>, key) => bool - -let cmpU: (t<'v>, t<'v>, (. 'v, 'v) => int) => int -let cmp: (t<'v>, t<'v>, ('v, 'v) => int) => int - -let eqU: (t<'v>, t<'v>, (. 'v, 'v) => bool) => bool - -/** -`eq(m1, m2)` tests whether the maps `m1` and `m2` are -equal, that is, contain equal keys and associate them with -equal data. -*/ -let eq: (t<'v>, t<'v>, ('v, 'v) => bool) => bool - -let findFirstByU: (t<'v>, (. key, 'v) => bool) => option<(key, 'v)> - -/** -`findFirstBy(m, p)` uses funcion `f` to find the first key value pair -to match predicate `p`. - -```rescript -let s0 = fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2,"(3, ""))]) -findFirstBy(s0, (k, v) => k == 4) == option((4, "4")) -``` -*/ -let findFirstBy: (t<'v>, (key, 'v) => bool) => option<(key, 'v)> - -let forEachU: (t<'v>, (. key, 'v) => unit) => unit - -/** -`forEach(m, f)` applies `f` to all bindings in map `m`. -`f` receives the key as first argument, and the associated value -as second argument. The bindings are passed to `f` in increasing -order with respect to the ordering over the type of the keys. -*/ -let forEach: (t<'v>, (key, 'v) => unit) => unit - -let reduceU: (t<'v>, 'v2, (. 'v2, key, 'v) => 'v2) => 'v2 - -/** -`reduce(m, a, f)` computes `(f kN dN ... (f k1 d1 a)...)`, -where `k1 ... kN` are the keys of all bindings in `m` -(in increasing order), and `d1 ... dN` are the associated data. -*/ -let reduce: (t<'v>, 'v2, ('v2, key, 'v) => 'v2) => 'v2 - -let everyU: (t<'v>, (. key, 'v) => bool) => bool - -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate `p`. -Order unspecified */ -let every: (t<'v>, (key, 'v) => bool) => bool - -let someU: (t<'v>, (. key, 'v) => bool) => bool - -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate -`p`. Order unspecified */ -let some: (t<'v>, (key, 'v) => bool) => bool - -let size: t<'v> => int - -/** In increasing order. */ -let toList: t<'v> => list<(key, 'v)> - -let toArray: t<'v> => array<(key, 'v)> - -let fromArray: array<(key, 'v)> => t<'v> - -let keysToArray: t<'v> => array - -let valuesToArray: t<'v> => array<'v> - -let minKey: t<_> => option - -let minKeyUndefined: t<_> => Js.undefined - -let maxKey: t<_> => option - -let maxKeyUndefined: t<_> => Js.undefined - -let minimum: t<'v> => option<(key, 'v)> - -let minUndefined: t<'v> => Js.undefined<(key, 'v)> - -let maximum: t<'v> => option<(key, 'v)> - -let maxUndefined: t<'v> => Js.undefined<(key, 'v)> - -let get: (t<'v>, key) => option<'v> - -let getUndefined: (t<'v>, key) => Js.undefined<'v> - -let getWithDefault: (t<'v>, key, 'v) => 'v - -let getExn: (t<'v>, key) => 'v - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/** `remove m x` returns a map containing the same bindings as - `m`, except for `x` which is unbound in the returned map. */ -let remove: (t<'v>, key) => t<'v> - -let removeMany: (t<'v>, array) => t<'v> - -/** -`set(m, x, y)` returns a map containing the same bindings as -`m`, plus a binding of `x` to `y`. If `x` was already bound -in `m`, its previous binding disappears. -*/ -let set: (t<'v>, key, 'v) => t<'v> - -let updateU: (t<'v>, key, (. option<'v>) => option<'v>) => t<'v> -let update: (t<'v>, key, option<'v> => option<'v>) => t<'v> - -let mergeU: (t<'v>, t<'v2>, (. key, option<'v>, option<'v2>) => option<'c>) => t<'c> - -/** -`merge(m1, m2, f)` computes a map whose keys is a subset of keys of `m1` -and of `m2`. The presence of each such binding, and the corresponding -value, is determined with the function `f`. -*/ -let merge: (t<'v>, t<'v2>, (key, option<'v>, option<'v2>) => option<'c>) => t<'c> - -let mergeMany: (t<'v>, array<(key, 'v)>) => t<'v> - -let keepU: (t<'v>, (. key, 'v) => bool) => t<'v> - -/** -`keep(m, p)` returns the map with all the bindings in `m` that satisfy predicate -`p`. -*/ -let keep: (t<'v>, (key, 'v) => bool) => t<'v> - -let partitionU: (t<'v>, (. key, 'v) => bool) => (t<'v>, t<'v>) - -/** -`partition(m, p)` returns a pair of maps `(m1, m2)`, where `m1` contains all the -bindings of `s` that satisfy the predicate `p`, and `m2` is the map with all the -bindings of `s` that do not satisfy `p`. -*/ -let partition: (t<'v>, (key, 'v) => bool) => (t<'v>, t<'v>) - -/** -`split(x, m)` returns a triple `(l, data, r)`, where `l` is the map with all the -bindings of `m` whose key is strictly less than `x`; `r` is the map with all the -bindings of `m` whose key is strictly greater than `x`; `data` is `None` if `m` -contains no binding for `x`, or `Some(v)` if `m` binds `v` to `x`. -*/ -let split: (key, t<'v>) => (t<'v>, option<'v>, t<'v>) - -let mapU: (t<'v>, (. 'v) => 'v2) => t<'v2> - -/** -`map(m, f)` returns a map with same domain as `m`, where the associated value `a` -of all bindings of `m` has been replaced by the result of the application of `f` -to `a`. The bindings are passed to `f` in increasing order with respect to the -ordering over the type of the keys. -*/ -let map: (t<'v>, 'v => 'v2) => t<'v2> - -let mapWithKeyU: (t<'v>, (. key, 'v) => 'v2) => t<'v2> -let mapWithKey: (t<'v>, (key, 'v) => 'v2) => t<'v2> diff --git a/jscomp/others/belt_MutableMap.res b/jscomp/others/belt_MutableMap.res deleted file mode 100644 index ba367b4..0000000 --- a/jscomp/others/belt_MutableMap.res +++ /dev/null @@ -1,235 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Int = Belt_MutableMapInt -module String = Belt_MutableMapString - -module N = Belt_internalAVLtree -module A = Belt_Array - -type id<'key, 'id> = Belt_Id.comparable<'key, 'id> -type cmp<'key, 'id> = Belt_Id.cmp<'key, 'id> - -type t<'k, 'v, 'id> = { - cmp: cmp<'k, 'id>, - mutable data: N.t<'k, 'v>, -} - -let rec removeMutateAux = (nt, x, ~cmp) => { - let k = nt.N.key - let c = Belt_Id.getCmpInternal(cmp)(. x, k) - if c == 0 { - let {N.left: l, right: r} = nt - switch (l, r) { - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - | (None, Some(_)) => r - | (Some(_) | None, None) => l - } - } else if c < 0 { - switch nt.N.left { - | None => Some(nt) - | Some(l) => - nt.left = removeMutateAux(~cmp, l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeMutateAux(~cmp, r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, k) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(oldRoot2) => - let newRoot = removeMutateAux(~cmp=d.cmp, oldRoot2, k) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec removeArrayMutateAux = (t, xs, i, len, ~cmp) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeMutateAux(t, ele, ~cmp) - switch u { - | None => None - | Some(t) => removeArrayMutateAux(t, xs, i + 1, len, ~cmp) - } - } else { - Some(t) - } - -let removeMany = (d, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - let newRoot = removeArrayMutateAux(nt, xs, 0, len, ~cmp=d.cmp) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec updateDone = (t, x, f, ~cmp) => - switch t { - | None => - switch f(. None) { - | Some(data) => N.singleton(x, data) - | None => t - } - | Some(nt) => - let k = nt.N.key - let c = Belt_Id.getCmpInternal(cmp)(. x, k) - if c == 0 { - switch f(. Some(nt.value)) { - | None => - let {N.left: l, right: r} = nt - switch (l, r) { - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - | (None, Some(_)) => r - | (Some(_) | None, None) => l - } - | Some(data) => - nt.value = data - Some(nt) - } - } else { - if c < 0 { - nt.left = updateDone(nt.left, x, f, ~cmp) - } else { - nt.right = updateDone(nt.right, x, f, ~cmp) - } - Some(N.balMutate(nt)) - } - } -let updateU = (t, x, f) => { - let oldRoot = t.data - let newRoot = updateDone(oldRoot, x, f, ~cmp=t.cmp) - if newRoot !== oldRoot { - t.data = newRoot - } -} -let update = (t, x, f) => updateU(t, x, (. a) => f(a)) - -let make = (type key identity, ~id: id) => { - module M = unpack(id) - {cmp: M.cmp, data: None} -} - -let clear = m => m.data = None - -let isEmpty = d => N.isEmpty(d.data) - -let minKey = m => N.minKey(m.data) -let minKeyUndefined = m => N.minKeyUndefined(m.data) -let maxKey = m => N.maxKey(m.data) -let maxKeyUndefined = m => N.maxKeyUndefined(m.data) -let minimum = m => N.minimum(m.data) -let minUndefined = m => N.minUndefined(m.data) -let maximum = m => N.maximum(m.data) -let maxUndefined = m => N.maxUndefined(m.data) - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a, b) => f(a, b)) -let reduceU = (d, acc, cb) => N.reduceU(d.data, acc, cb) -let reduce = (d, acc, cb) => reduceU(d, acc, (. a, b, c) => cb(a, b, c)) -let everyU = (d, p) => N.everyU(d.data, p) -let every = (d, p) => everyU(d, (. a, b) => p(a, b)) -let someU = (d, p) => N.someU(d.data, p) -let some = (d, p) => someU(d, (. a, b) => p(a, b)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) -let keysToArray = d => N.keysToArray(d.data) -let valuesToArray = d => N.valuesToArray(d.data) - -/* let fromSortedArrayUnsafe (type key) (type identity) ~(id : (key,identity) id) xs : _ t = - let module M = (val id) in - S.t ~data:(N.fromSortedArrayUnsafe xs) ~cmp:M.cmp */ - -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) - -let cmpU = (m1, m2, cmp) => N.cmpU(~kcmp=m1.cmp, ~vcmp=cmp, m1.data, m2.data) -let cmp = (m1, m2, cmp) => cmpU(m1, m2, (. a, b) => cmp(a, b)) - -let eqU = (m1, m2, cmp) => N.eqU(~kcmp=m1.cmp, ~veq=cmp, m1.data, m2.data) -let eq = (m1, m2, cmp) => eqU(m1, m2, (. a, b) => cmp(a, b)) - -let mapU = (m, f) => {cmp: m.cmp, data: N.mapU(m.data, f)} -let map = (m, f) => mapU(m, (. a) => f(a)) -let mapWithKeyU = (m, f) => {cmp: m.cmp, data: N.mapWithKeyU(m.data, f)} -let mapWithKey = (m, f) => mapWithKeyU(m, (. a, b) => f(a, b)) -let get = (m, x) => N.get(~cmp=m.cmp, m.data, x) - -let getUndefined = (m, x) => N.getUndefined(~cmp=m.cmp, m.data, x) - -let getWithDefault = (m, x, def) => N.getWithDefault(~cmp=m.cmp, m.data, x, def) - -let getExn = (m, x) => N.getExn(~cmp=m.cmp, m.data, x) - -let has = (m, x) => N.has(~cmp=m.cmp, m.data, x) - -let fromArray = (type k identity, data, ~id: id) => { - module M = unpack(id) - let cmp = M.cmp - {cmp, data: N.fromArray(~cmp, data)} -} - -let set = (m, e, v) => { - let oldRoot = m.data - let newRoot = N.updateMutate(~cmp=m.cmp, oldRoot, e, v) - if newRoot !== oldRoot { - m.data = newRoot - } -} - -let mergeManyAux = (t, xs, ~cmp) => { - let v = ref(t) - for i in 0 to A.length(xs) - 1 { - let (key, value) = A.getUnsafe(xs, i) - v.contents = N.updateMutate(v.contents, key, value, ~cmp) - } - v.contents -} - -let mergeMany = (d, xs) => { - let oldRoot = d.data - let newRoot = mergeManyAux(oldRoot, xs, ~cmp=d.cmp) - if newRoot !== oldRoot { - d.data = newRoot - } -} diff --git a/jscomp/others/belt_MutableMap.resi b/jscomp/others/belt_MutableMap.resi deleted file mode 100644 index 5451272..0000000 --- a/jscomp/others/belt_MutableMap.resi +++ /dev/null @@ -1,148 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Int = Belt_MutableMapInt - -module String = Belt_MutableMapString - -/*** -A mutable sorted map module which allows customize compare behavior. - -Same as `Belt.Map`, but mutable. -*/ - -/* -## Examples - -```rescript -type t<'k, 'v, 'id> -type id<'key, 'id> = Belt_Id.comparable<'key, 'id> -``` -*/ - -type t<'k, 'v, 'id> -type id<'key, 'id> = Belt_Id.comparable<'key, 'id> - -let make: (~id: id<'k, 'id>) => t<'k, 'a, 'id> -let clear: t<_> => unit -let isEmpty: t<_> => bool -let has: (t<'k, _, _>, 'k) => bool - -let cmpU: (t<'k, 'a, 'id>, t<'k, 'a, 'id>, (. 'a, 'a) => int) => int -/** -`cmp(m1, m2, cmp)` First compare by size, if size is the same, compare by -key, value pair. -*/ -let cmp: (t<'k, 'a, 'id>, t<'k, 'a, 'id>, ('a, 'a) => int) => int - -let eqU: (t<'k, 'a, 'id>, t<'k, 'a, 'id>, (. 'a, 'a) => bool) => bool -/** -`eq(m1, m2, eqf)` tests whether the maps `m1` and `m2` are equal, that is, -contain equal keys and associate them with equal data. `eqf` is the -equality predicate used to compare the data associated with the keys. -*/ -let eq: (t<'k, 'a, 'id>, t<'k, 'a, 'id>, ('a, 'a) => bool) => bool - -let forEachU: (t<'k, 'a, 'id>, (. 'k, 'a) => unit) => unit -/** -`forEach(m, f)` applies f to all bindings in map `m`. `f` receives the `'k` -as first argument, and the associated value as second argument. The -bindings are passed to `f` in increasing order with respect to the ordering -over the type of the keys. -*/ -let forEach: (t<'k, 'a, 'id>, ('k, 'a) => unit) => unit - -let reduceU: (t<'k, 'a, 'id>, 'b, (. 'b, 'k, 'a) => 'b) => 'b -/** -`reduce(m, a, f), computes`(f(kN, dN) ... (f(k1, d1, a))...)`, where`k1 ... -kN`are the keys of all bindings in`m`(in increasing order), and`d1 ... dN` -are the associated data. -*/ -let reduce: (t<'k, 'a, 'id>, 'b, ('b, 'k, 'a) => 'b) => 'b - -let everyU: (t<'k, 'a, 'id>, (. 'k, 'a) => bool) => bool -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate `p`. -*/ -let every: (t<'k, 'a, 'id>, ('k, 'a) => bool) => bool - -let someU: (t<'k, 'a, 'id>, (. 'k, 'a) => bool) => bool -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate `p`. -*/ -let some: (t<'k, 'a, 'id>, ('k, 'a) => bool) => bool - -let size: t<'k, 'a, 'id> => int - -/** In increasing order. */ -let toList: t<'k, 'a, 'id> => list<('k, 'a)> - -let toArray: t<'k, 'a, 'id> => array<('k, 'a)> - -let fromArray: (array<('k, 'a)>, ~id: id<'k, 'id>) => t<'k, 'a, 'id> -let keysToArray: t<'k, _, _> => array<'k> -let valuesToArray: t<_, 'a, _> => array<'a> -let minKey: t<'k, _, _> => option<'k> -let minKeyUndefined: t<'k, _, _> => Js.undefined<'k> -let maxKey: t<'k, _, _> => option<'k> -let maxKeyUndefined: t<'k, _, _> => Js.undefined<'k> -let minimum: t<'k, 'a, _> => option<('k, 'a)> -let minUndefined: t<'k, 'a, _> => Js.undefined<('k, 'a)> -let maximum: t<'k, 'a, _> => option<('k, 'a)> -let maxUndefined: t<'k, 'a, _> => Js.undefined<('k, 'a)> -let get: (t<'k, 'a, 'id>, 'k) => option<'a> -let getUndefined: (t<'k, 'a, 'id>, 'k) => Js.undefined<'a> -let getWithDefault: (t<'k, 'a, 'id>, 'k, 'a) => 'a -let getExn: (t<'k, 'a, 'id>, 'k) => 'a -/** Raise when invariant is not held. */ -let checkInvariantInternal: t<_> => unit - -/* ************************************************************************** */ - -/* TODO: add functional `merge, partition, keep, split` */ - -/** `remove(m, x)` do the in-place modification. */ -let remove: (t<'k, 'a, 'id>, 'k) => unit - -let removeMany: (t<'k, 'a, 'id>, array<'k>) => unit - -/** `set(m, x, y)` do the in-place modification */ -let set: (t<'k, 'a, 'id>, 'k, 'a) => unit - -let updateU: (t<'k, 'a, 'id>, 'k, (. option<'a>) => option<'a>) => unit -let update: (t<'k, 'a, 'id>, 'k, option<'a> => option<'a>) => unit - -let mergeMany: (t<'k, 'a, 'id>, array<('k, 'a)>) => unit - -let mapU: (t<'k, 'a, 'id>, (. 'a) => 'b) => t<'k, 'b, 'id> -/** -`map(m, f)` returns a map with same domain as `m`, where the associated -value a of all bindings of `m` has been replaced by the result of the -application of `f` to `a`. The bindings are passed to `f` in increasing -order with respect to the ordering over the type of the keys. -*/ -let map: (t<'k, 'a, 'id>, 'a => 'b) => t<'k, 'b, 'id> - -let mapWithKeyU: (t<'k, 'a, 'id>, (. 'k, 'a) => 'b) => t<'k, 'b, 'id> -let mapWithKey: (t<'k, 'a, 'id>, ('k, 'a) => 'b) => t<'k, 'b, 'id> diff --git a/jscomp/others/belt_MutableMapInt.res b/jscomp/others/belt_MutableMapInt.res deleted file mode 100644 index a8e7d69..0000000 --- a/jscomp/others/belt_MutableMapInt.res +++ /dev/null @@ -1,176 +0,0 @@ -module I = Belt_internalMapInt -type key = int - -module N = Belt_internalAVLtree -module A = Belt_Array - -type t<'a> = {mutable data: I.t<'a>} - -let make = () => {data: None} -let isEmpty = m => N.isEmpty(m.data) -let clear = m => m.data = None -/* let singleton k v = t ~data:(N.singleton k v) */ - -let minKeyUndefined = m => N.minKeyUndefined(m.data) -let minKey = m => N.minKey(m.data) -let maxKeyUndefined = m => N.maxKeyUndefined(m.data) -let maxKey = m => N.maxKey(m.data) -let minimum = m => N.minimum(m.data) -let minUndefined = m => N.minUndefined(m.data) -let maximum = m => N.maximum(m.data) -let maxUndefined = m => N.maxUndefined(m.data) - -let set = (m: t<_>, k, v) => { - let old_data = m.data - let v = I.addMutate(old_data, k, v) - if v !== old_data { - m.data = v - } -} - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a, b) => f(a, b)) -let mapU = (d, f) => {data: N.mapU(d.data, f)} -let map = (d, f) => mapU(d, (. a) => f(a)) -let mapWithKeyU = (d, f) => {data: N.mapWithKeyU(d.data, f)} -let mapWithKey = (d, f) => mapWithKeyU(d, (. a, b) => f(a, b)) -let reduceU = (d, acc, f) => N.reduceU(d.data, acc, f) -let reduce = (d, acc, f) => reduceU(d, acc, (. a, b, c) => f(a, b, c)) -let everyU = (d, f) => N.everyU(d.data, f) -let every = (d, f) => everyU(d, (. a, b) => f(a, b)) -let someU = (d, f) => N.someU(d.data, f) -let some = (d, f) => someU(d, (. a, b) => f(a, b)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) -let keysToArray = d => N.keysToArray(d.data) -let valuesToArray = d => N.valuesToArray(d.data) -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) -let has = (d, v) => I.has(d.data, v) - -let rec removeMutateAux = (nt, x: key) => { - let k = nt.N.key - if x == k { - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = removeMutateAux(l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeMutateAux(r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(root) => - let newRoot = removeMutateAux(root, v) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec updateDone = (t, x: key, f) => - switch t { - | None => - switch f(. None) { - | Some(data) => N.singleton(x, data) - | None => t - } - | Some(nt) => - let k = nt.N.key - - /* let c = (Belt_Cmp.getCmpInternal cmp) x k [@bs] in */ - if k == x { - switch f(. Some(nt.value)) { - | None => - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - | Some(data) => - nt.value = data - Some(nt) - } - } else { - let {N.left: l, right: r} = nt - if x < k { - let ll = updateDone(l, x, f) - nt.left = ll - } else { - nt.right = updateDone(r, x, f) - } - Some(N.balMutate(nt)) - } - } - -let updateU = (t, x, f) => { - let oldRoot = t.data - let newRoot = updateDone(oldRoot, x, f) - if newRoot !== oldRoot { - t.data = newRoot - } -} -let update = (t, x, f) => updateU(t, x, (. a) => f(a)) -let rec removeArrayMutateAux = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeMutateAux(t, ele) - switch u { - | None => None - | Some(t) => removeArrayMutateAux(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (d: t<_>, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - let newRoot = removeArrayMutateAux(nt, xs, 0, len) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -/* let split = I.split */ -/* let merge = I.merge */ - -let fromArray = xs => {data: I.fromArray(xs)} - -let cmpU = (d0, d1, f) => I.cmpU(d0.data, d1.data, f) -let cmp = (d0, d1, f) => cmpU(d0, d1, (. a, b) => f(a, b)) - -let eqU = (d0, d1, f) => I.eqU(d0.data, d1.data, f) -let eq = (d0, d1, f) => eqU(d0, d1, (. a, b) => f(a, b)) - -let get = (d, x) => I.get(d.data, x) -let getUndefined = (d, x) => I.getUndefined(d.data, x) -let getWithDefault = (d, x, def) => I.getWithDefault(d.data, x, def) -let getExn = (d, x) => I.getExn(d.data, x) diff --git a/jscomp/others/belt_MutableMapInt.resi b/jscomp/others/belt_MutableMapInt.resi deleted file mode 100644 index 6f1b66a..0000000 --- a/jscomp/others/belt_MutableMapInt.resi +++ /dev/null @@ -1,137 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type key = int - -type t<'a> - -let make: unit => t<'a> -let clear: t<'a> => unit -let isEmpty: t<'a> => bool - -let has: (t<'a>, key) => bool - -let cmpU: (t<'a>, t<'a>, (. 'a, 'a) => int) => int - -/** -`cmp(m1, m2, cmp)`. First compare by size, if size is the same, compare by key, -value pair -*/ -let cmp: (t<'a>, t<'a>, ('a, 'a) => int) => int - -let eqU: (t<'a>, t<'a>, (. 'a, 'a) => bool) => bool - -/** `eq(m1, m2, cmp)` */ -let eq: (t<'a>, t<'a>, ('a, 'a) => bool) => bool - -let forEachU: (t<'a>, (. key, 'a) => unit) => unit - -/** -`forEach(m, f)` applies `f` to all bindings in map `m`. `f` receives the key as -first argument, and the associated value as second argument. The application -order of `f` is in increasing order. */ -let forEach: (t<'a>, (key, 'a) => unit) => unit - -let reduceU: (t<'a>, 'b, (. 'b, key, 'a) => 'b) => 'b - -/** -`reduce(m, a, f)` computes `(f kN dN ... (f k1 d1 a)...)`, where `k1 ... kN` are -the keys of all bindings in `m` (in increasing order), and `d1 ... dN` are the -associated data. */ -let reduce: (t<'a>, 'b, ('b, key, 'a) => 'b) => 'b - -let everyU: (t<'a>, (. key, 'a) => bool) => bool - -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate `p`. -The application order of `p` is unspecified. -*/ -let every: (t<'a>, (key, 'a) => bool) => bool - -let someU: (t<'a>, (. key, 'a) => bool) => bool - -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate `p`. -The application order of `p` is unspecified. -*/ -let some: (t<'a>, (key, 'a) => bool) => bool - -let size: t<'a> => int - -/** In increasing order */ -let toList: t<'a> => list<(key, 'a)> - -/** In increasing order */ -let toArray: t<'a> => array<(key, 'a)> - -let fromArray: array<(key, 'a)> => t<'a> -let keysToArray: t<'a> => array -let valuesToArray: t<'a> => array<'a> -let minKey: t<_> => option -let minKeyUndefined: t<_> => Js.undefined -let maxKey: t<_> => option -let maxKeyUndefined: t<_> => Js.undefined -let minimum: t<'a> => option<(key, 'a)> -let minUndefined: t<'a> => Js.undefined<(key, 'a)> -let maximum: t<'a> => option<(key, 'a)> -let maxUndefined: t<'a> => Js.undefined<(key, 'a)> -let get: (t<'a>, key) => option<'a> -let getUndefined: (t<'a>, key) => Js.undefined<'a> -let getWithDefault: (t<'a>, key, 'a) => 'a -let getExn: (t<'a>, key) => 'a - -/** - **raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/* ************************************************************************** */ - -/* TODO: add functional `merge, partition, keep, split` */ - -/** `remove(m, x)` do the in-place modification */ -let remove: (t<'a>, key) => unit - -let removeMany: (t<'a>, array) => unit - -/** -`set(m, x, y)` do the in-place modification, return `m` for chaining. If `x` was -already bound in `m`, its previous binding disappears. -*/ -let set: (t<'a>, key, 'a) => unit - -let updateU: (t<'a>, key, (. option<'a>) => option<'a>) => unit -let update: (t<'a>, key, option<'a> => option<'a>) => unit - -let mapU: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -`map(m, f)` returns a map with same domain as `m`, where the associated value `a` -of all bindings of `m` has been replaced by the result of the application of `f` -to `a`. The bindings are passed to `f` in increasing order with respect to the -ordering over the type of the keys. */ -let map: (t<'a>, 'a => 'b) => t<'b> - -let mapWithKeyU: (t<'a>, (. key, 'a) => 'b) => t<'b> -let mapWithKey: (t<'a>, (key, 'a) => 'b) => t<'b> diff --git a/jscomp/others/belt_MutableMapString.res b/jscomp/others/belt_MutableMapString.res deleted file mode 100644 index 3bbb2c0..0000000 --- a/jscomp/others/belt_MutableMapString.res +++ /dev/null @@ -1,176 +0,0 @@ -module I = Belt_internalMapString -type key = string - -module N = Belt_internalAVLtree -module A = Belt_Array - -type t<'a> = {mutable data: I.t<'a>} - -let make = () => {data: None} -let isEmpty = m => N.isEmpty(m.data) -let clear = m => m.data = None -/* let singleton k v = t ~data:(N.singleton k v) */ - -let minKeyUndefined = m => N.minKeyUndefined(m.data) -let minKey = m => N.minKey(m.data) -let maxKeyUndefined = m => N.maxKeyUndefined(m.data) -let maxKey = m => N.maxKey(m.data) -let minimum = m => N.minimum(m.data) -let minUndefined = m => N.minUndefined(m.data) -let maximum = m => N.maximum(m.data) -let maxUndefined = m => N.maxUndefined(m.data) - -let set = (m: t<_>, k, v) => { - let old_data = m.data - let v = I.addMutate(old_data, k, v) - if v !== old_data { - m.data = v - } -} - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a, b) => f(a, b)) -let mapU = (d, f) => {data: N.mapU(d.data, f)} -let map = (d, f) => mapU(d, (. a) => f(a)) -let mapWithKeyU = (d, f) => {data: N.mapWithKeyU(d.data, f)} -let mapWithKey = (d, f) => mapWithKeyU(d, (. a, b) => f(a, b)) -let reduceU = (d, acc, f) => N.reduceU(d.data, acc, f) -let reduce = (d, acc, f) => reduceU(d, acc, (. a, b, c) => f(a, b, c)) -let everyU = (d, f) => N.everyU(d.data, f) -let every = (d, f) => everyU(d, (. a, b) => f(a, b)) -let someU = (d, f) => N.someU(d.data, f) -let some = (d, f) => someU(d, (. a, b) => f(a, b)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) -let keysToArray = d => N.keysToArray(d.data) -let valuesToArray = d => N.valuesToArray(d.data) -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) -let has = (d, v) => I.has(d.data, v) - -let rec removeMutateAux = (nt, x: key) => { - let k = nt.N.key - if x == k { - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = removeMutateAux(l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeMutateAux(r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(root) => - let newRoot = removeMutateAux(root, v) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec updateDone = (t, x: key, f) => - switch t { - | None => - switch f(. None) { - | Some(data) => N.singleton(x, data) - | None => t - } - | Some(nt) => - let k = nt.N.key - - /* let c = (Belt_Cmp.getCmpInternal cmp) x k [@bs] in */ - if k == x { - switch f(. Some(nt.value)) { - | None => - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - | Some(data) => - nt.value = data - Some(nt) - } - } else { - let {N.left: l, right: r} = nt - if x < k { - let ll = updateDone(l, x, f) - nt.left = ll - } else { - nt.right = updateDone(r, x, f) - } - Some(N.balMutate(nt)) - } - } - -let updateU = (t, x, f) => { - let oldRoot = t.data - let newRoot = updateDone(oldRoot, x, f) - if newRoot !== oldRoot { - t.data = newRoot - } -} -let update = (t, x, f) => updateU(t, x, (. a) => f(a)) -let rec removeArrayMutateAux = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeMutateAux(t, ele) - switch u { - | None => None - | Some(t) => removeArrayMutateAux(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (d: t<_>, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - let newRoot = removeArrayMutateAux(nt, xs, 0, len) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -/* let split = I.split */ -/* let merge = I.merge */ - -let fromArray = xs => {data: I.fromArray(xs)} - -let cmpU = (d0, d1, f) => I.cmpU(d0.data, d1.data, f) -let cmp = (d0, d1, f) => cmpU(d0, d1, (. a, b) => f(a, b)) - -let eqU = (d0, d1, f) => I.eqU(d0.data, d1.data, f) -let eq = (d0, d1, f) => eqU(d0, d1, (. a, b) => f(a, b)) - -let get = (d, x) => I.get(d.data, x) -let getUndefined = (d, x) => I.getUndefined(d.data, x) -let getWithDefault = (d, x, def) => I.getWithDefault(d.data, x, def) -let getExn = (d, x) => I.getExn(d.data, x) diff --git a/jscomp/others/belt_MutableMapString.resi b/jscomp/others/belt_MutableMapString.resi deleted file mode 100644 index fc4fcb3..0000000 --- a/jscomp/others/belt_MutableMapString.resi +++ /dev/null @@ -1,137 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type key = string - -type t<'a> - -let make: unit => t<'a> -let clear: t<'a> => unit -let isEmpty: t<'a> => bool - -let has: (t<'a>, key) => bool - -let cmpU: (t<'a>, t<'a>, (. 'a, 'a) => int) => int - -/** -`cmp(m1, m2, cmp)`. First compare by size, if size is the same, compare by key, -value pair -*/ -let cmp: (t<'a>, t<'a>, ('a, 'a) => int) => int - -let eqU: (t<'a>, t<'a>, (. 'a, 'a) => bool) => bool - -/** `eq(m1, m2, cmp)` */ -let eq: (t<'a>, t<'a>, ('a, 'a) => bool) => bool - -let forEachU: (t<'a>, (. key, 'a) => unit) => unit - -/** -`forEach(m, f)` applies `f` to all bindings in map `m`. `f` receives the key as -first argument, and the associated value as second argument. The application -order of `f` is in increasing order. */ -let forEach: (t<'a>, (key, 'a) => unit) => unit - -let reduceU: (t<'a>, 'b, (. 'b, key, 'a) => 'b) => 'b - -/** -`reduce(m, a, f)` computes `(f kN dN ... (f k1 d1 a)...)`, where `k1 ... kN` are -the keys of all bindings in `m` (in increasing order), and `d1 ... dN` are the -associated data. */ -let reduce: (t<'a>, 'b, ('b, key, 'a) => 'b) => 'b - -let everyU: (t<'a>, (. key, 'a) => bool) => bool - -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate `p`. -The application order of `p` is unspecified. -*/ -let every: (t<'a>, (key, 'a) => bool) => bool - -let someU: (t<'a>, (. key, 'a) => bool) => bool - -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate `p`. -The application order of `p` is unspecified. -*/ -let some: (t<'a>, (key, 'a) => bool) => bool - -let size: t<'a> => int - -/** In increasing order */ -let toList: t<'a> => list<(key, 'a)> - -/** In increasing order */ -let toArray: t<'a> => array<(key, 'a)> - -let fromArray: array<(key, 'a)> => t<'a> -let keysToArray: t<'a> => array -let valuesToArray: t<'a> => array<'a> -let minKey: t<_> => option -let minKeyUndefined: t<_> => Js.undefined -let maxKey: t<_> => option -let maxKeyUndefined: t<_> => Js.undefined -let minimum: t<'a> => option<(key, 'a)> -let minUndefined: t<'a> => Js.undefined<(key, 'a)> -let maximum: t<'a> => option<(key, 'a)> -let maxUndefined: t<'a> => Js.undefined<(key, 'a)> -let get: (t<'a>, key) => option<'a> -let getUndefined: (t<'a>, key) => Js.undefined<'a> -let getWithDefault: (t<'a>, key, 'a) => 'a -let getExn: (t<'a>, key) => 'a - -/** - **raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/* ************************************************************************** */ - -/* TODO: add functional `merge, partition, keep, split` */ - -/** `remove(m, x)` do the in-place modification */ -let remove: (t<'a>, key) => unit - -let removeMany: (t<'a>, array) => unit - -/** -`set(m, x, y)` do the in-place modification, return `m` for chaining. If `x` was -already bound in `m`, its previous binding disappears. -*/ -let set: (t<'a>, key, 'a) => unit - -let updateU: (t<'a>, key, (. option<'a>) => option<'a>) => unit -let update: (t<'a>, key, option<'a> => option<'a>) => unit - -let mapU: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -`map(m, f)` returns a map with same domain as `m`, where the associated value `a` -of all bindings of `m` has been replaced by the result of the application of `f` -to `a`. The bindings are passed to `f` in increasing order with respect to the -ordering over the type of the keys. */ -let map: (t<'a>, 'a => 'b) => t<'b> - -let mapWithKeyU: (t<'a>, (. key, 'a) => 'b) => t<'b> -let mapWithKey: (t<'a>, (key, 'a) => 'b) => t<'b> diff --git a/jscomp/others/belt_MutableQueue.res b/jscomp/others/belt_MutableQueue.res deleted file mode 100644 index 86dd07f..0000000 --- a/jscomp/others/belt_MutableQueue.res +++ /dev/null @@ -1,230 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Francois Pottier, projet Cristal, INRIA Rocquencourt */ -/* Jeremie Dimino, Jane Street Europe */ -/* */ -/* Copyright 2002 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. */ -/* */ -/* ************************************************************************ */ -/* Adapted significantly by ReScript Authors */ -module A = Belt_Array - -type rec node<'a> = { - content: 'a, - mutable next: cell<'a>, -} -and cell<'a> = option> -and t<'a> = { - mutable length: int, - mutable first: cell<'a>, - mutable last: cell<'a>, -} - -let make = () => { - length: 0, - first: None, - last: None, -} - -let clear = q => { - q.length = 0 - q.first = None - q.last = None -} - -let add = (q, x) => { - let cell = Some({ - content: x, - next: None, - }) - switch q.last { - | None => - /* TODO: better names for intermediate var */ - q.length = 1 - q.first = cell - q.last = cell - | Some(last) => - q.length = q.length + 1 - last.next = cell - q.last = cell - } -} - -let peek = q => - switch q.first { - /* same here could be v */ - | None => None - | Some(v) => Some(v.content) - } - -let peekUndefined = q => - switch q.first { - | None => Js.undefined - | Some(v) => Js.Undefined.return(v.content) - } - -let peekExn = q => - switch q.first { - | None => raise(Not_found) - | Some(v) => v.content - } - -let pop = q => - switch q.first { - | None => None - | Some(x) => - let next = x.next - if next == None { - /* only one element */ - clear(q) - Some(x.content) - } else { - q.length = q.length - 1 - q.first = next - Some(x.content) - } - } - -let popExn = q => - /* TO fix */ - switch q.first { - | None => raise(Not_found) - | Some(x) => - let next = x.next - if next == None { - /* only one element */ - clear(q) - x.content - } else { - q.length = q.length - 1 - q.first = next - x.content - } - } - -let popUndefined = q => - switch q.first { - | None => Js.undefined - | Some(x) => - let next = x.next - if next == None { - /* only one element */ - clear(q) - Js.Undefined.return(x.content) - } else { - q.length = q.length - 1 - q.first = next - Js.Undefined.return(x.content) - } - } - -let rec copyAux = (qRes, prev, cell) => - switch cell { - | None => - qRes.last = prev - qRes - | Some(x) => - let content = x.content - let res = Some({content, next: None}) - switch prev { - | None => qRes.first = res - | Some(p) => p.next = res - } - copyAux(qRes, res, x.next) - } - -let copy = q => copyAux({length: q.length, first: None, last: None}, None, q.first) - -let rec copyMapAux = (qRes, prev, cell, f) => - switch cell { - | None => - qRes.last = prev - qRes - | Some(x) => - let content = f(. x.content) - let res = Some({content, next: None}) - switch prev { - /* TODO: optimize to remove such check */ - | None => qRes.first = res - | Some(p) => p.next = res - } - copyMapAux(qRes, res, x.next, f) - } - -let mapU = (q, f) => copyMapAux({length: q.length, first: None, last: None}, None, q.first, f) - -let map = (q, f) => mapU(q, (. a) => f(a)) - -let isEmpty = q => q.length == 0 - -let size = q => q.length - -let rec iterAux = (cell, f) => - switch cell { - | None => () - | Some(x) => - f(. x.content) - iterAux(x.next, f) - } - -let forEachU = (q, f) => iterAux(q.first, f) - -let forEach = (q, f) => forEachU(q, (. a) => f(a)) - -let rec foldAux = (f, accu, cell) => - switch cell { - | None => accu - | Some(x) => - let accu = f(. accu, x.content) - foldAux(f, accu, x.next) - } - -let reduceU = (q, accu, f) => foldAux(f, accu, q.first) - -let reduce = (q, accu, f) => reduceU(q, accu, (. a, b) => f(a, b)) - -let transfer = (q1, q2) => - if q1.length > 0 { - switch q2.last { - | None => - q2.length = q1.length - q2.first = q1.first - q2.last = q1.last - clear(q1) - | Some(l) => - q2.length = q2.length + q1.length - l.next = q1.first - q2.last = q1.last - clear(q1) - } - } - -let rec fillAux = (i, arr, cell) => - switch cell { - | None => () - | Some(x) => - A.setUnsafe(arr, i, x.content) - fillAux(i + 1, arr, x.next) - } - -let toArray = x => { - let v = A.makeUninitializedUnsafe(x.length) - fillAux(0, v, x.first) - v -} - -/* TODO: optimize */ -let fromArray = arr => { - let q = make() - for i in 0 to A.length(arr) - 1 { - add(q, A.getUnsafe(arr, i)) - } - q -} diff --git a/jscomp/others/belt_MutableQueue.resi b/jscomp/others/belt_MutableQueue.resi deleted file mode 100644 index 1bc2f8c..0000000 --- a/jscomp/others/belt_MutableQueue.resi +++ /dev/null @@ -1,120 +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. */ -/* */ -/* ************************************************************************ */ -/* Adapted significantly by ReScript Authors */ - -/*** -A FIFO (first in first out) queue data structure. -*/ - -/** -The type of queues containing elements of `type('a)`. -*/ -type t<'a> - -/** -Returns a new queue, initially empty. -*/ -let make: unit => t<'a> - -/** -Discard all elements from the queue. -*/ -let clear: t<'a> => unit - -/** -Returns `true` if the given queue is empty, `false` otherwise. -*/ -let isEmpty: t<'a> => bool - -/** -`fromArray` a is equivalent to `Array.forEach(a, add(q, a));` -*/ -let fromArray: array<'a> => t<'a> - -/** -`add(q, x)` adds the element `x` at the end of the queue `q`. -*/ -let add: (t<'a>, 'a) => unit - -/** -`peekOpt(q)` returns the first element in queue `q`, without removing it from the queue. -*/ -let peek: t<'a> => option<'a> - -/** -`peekUndefined(q)` returns `undefined` if not found. -*/ -let peekUndefined: t<'a> => Js.undefined<'a> - -/** -raise an exception if `q` is empty -*/ -let peekExn: t<'a> => 'a - -/** -`pop(q)` removes and returns the first element in queue `q`. -*/ -let pop: t<'a> => option<'a> - -/** -`popUndefined(q)` removes and returns the first element in queue `q`. it will -return `undefined` if it is already empty. -*/ -let popUndefined: t<'a> => Js.undefined<'a> - -/** -`popExn(q)` raise an exception if q is empty. -*/ -let popExn: t<'a> => 'a - -/** -`copy(q)` returns a fresh queue. -*/ -let copy: t<'a> => t<'a> - -/** -Returns the number of elements in a queue. -*/ -let size: t<'a> => int - -let mapU: (t<'a>, (. 'a) => 'b) => t<'b> -let map: (t<'a>, 'a => 'b) => t<'b> -let forEachU: (t<'a>, (. 'a) => unit) => unit - -/** -`forEach(q, f) applies`f`in turn to all elements of`q`, from the least -recently entered to the most recently entered. The queue itself is unchanged. -*/ -let forEach: (t<'a>, 'a => unit) => unit - -let reduceU: (t<'a>, 'b, (. 'b, 'a) => 'b) => 'b - -/** -`reduce(q, accu, f)` is equivalent to `List.reduce(l, accu, f)`, where `l` is the -list of `q`'s elements. The queue remains unchanged. -*/ -let reduce: (t<'a>, 'b, ('b, 'a) => 'b) => 'b - -/** -`transfer(q1, q2)` adds all of `q1`'s elements at the end of the queue `q2`, -then clears `q1`. It is equivalent to the sequence `forEach((x) => add(x, q2), q1)`; -clear `q1`, but runs in constant time. -*/ -let transfer: (t<'a>, t<'a>) => unit - -/** -First added will be in the beginning of the array. -*/ -let toArray: t<'a> => array<'a> diff --git a/jscomp/others/belt_MutableSet.res b/jscomp/others/belt_MutableSet.res deleted file mode 100644 index e48b6a0..0000000 --- a/jscomp/others/belt_MutableSet.res +++ /dev/null @@ -1,374 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Int = Belt_MutableSetInt -module String = Belt_MutableSetString - -module N = Belt_internalAVLset -module A = Belt_Array -module Sort = Belt_SortArray - -type id<'k, 'id> = Belt_Id.comparable<'k, 'id> -type cmp<'key, 'id> = Belt_Id.cmp<'key, 'id> - -type t<'value, 'id> = { - cmp: cmp<'value, 'id>, - mutable data: N.t<'value>, -} - -let rec remove0 = (nt, x, ~cmp) => { - let k = nt.N.value - let c = cmp(. x, k) - if c == 0 { - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if c < 0 { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = remove0(~cmp, l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = remove0(~cmp, r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(oldRoot2) => - let newRoot = remove0(~cmp=Belt_Id.getCmpInternal(d.cmp), oldRoot2, v) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec removeMany0 = (t, xs, i, len, ~cmp) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = remove0(t, ele, ~cmp) - switch u { - | None => None - | Some(t) => removeMany0(t, xs, i + 1, len, ~cmp) - } - } else { - Some(t) - } - -let removeMany = (d, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - d.data = removeMany0(nt, xs, 0, len, ~cmp=Belt_Id.getCmpInternal(d.cmp)) - } -} - -let rec removeCheck0 = (nt, x, removed, ~cmp) => { - let k = nt.N.value - let c = Belt_Id.getCmpInternal(cmp)(. x, k) - if c == 0 { - let () = removed.contents = true - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if c < 0 { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = removeCheck0(~cmp, l, x, removed) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeCheck0(~cmp, r, x, removed) - Some(N.balMutate(nt)) - } - } -} - -let removeCheck = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => false - | Some(oldRoot2) => - let removed = ref(false) - let newRoot = removeCheck0(~cmp=d.cmp, oldRoot2, v, removed) - if newRoot !== oldRoot { - d.data = newRoot - } - removed.contents - } -} - -let rec addCheck0 = (t, x, added, ~cmp) => - switch t { - | None => - added.contents = true - N.singleton(x) - | Some(nt) => - let k = nt.N.value - let c = cmp(. x, k) - if c == 0 { - t - } else { - let {N.left: l, right: r} = nt - if c < 0 { - let ll = addCheck0(~cmp, l, x, added) - nt.left = ll - } else { - nt.right = addCheck0(~cmp, r, x, added) - } - Some(N.balMutate(nt)) - } - } - -let addCheck = (m, e) => { - let oldRoot = m.data - let added = ref(false) - let newRoot = addCheck0(~cmp=Belt_Id.getCmpInternal(m.cmp), oldRoot, e, added) - if newRoot !== oldRoot { - m.data = newRoot - } - added.contents -} - -let add = (m, e) => { - let oldRoot = m.data - let newRoot = N.addMutate(~cmp=m.cmp, oldRoot, e) - if newRoot !== oldRoot { - m.data = newRoot - } -} - -let addArrayMutate = (t, xs, ~cmp) => { - let v = ref(t) - for i in 0 to A.length(xs) - 1 { - v.contents = N.addMutate(v.contents, A.getUnsafe(xs, i), ~cmp) - } - v.contents -} - -let mergeMany = (d, xs) => d.data = addArrayMutate(d.data, xs, ~cmp=d.cmp) - -let make = (type value identity, ~id: id) => { - module M = unpack(id) - {cmp: M.cmp, data: None} -} - -let isEmpty = d => N.isEmpty(d.data) - -let minimum = d => N.minimum(d.data) -let minUndefined = d => N.minUndefined(d.data) -let maximum = d => N.maximum(d.data) -let maxUndefined = d => N.maxUndefined(d.data) - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a) => f(a)) -let reduceU = (d, acc, cb) => N.reduceU(d.data, acc, cb) -let reduce = (d, acc, cb) => reduceU(d, acc, (. a, b) => cb(a, b)) -let everyU = (d, p) => N.everyU(d.data, p) -let every = (d, p) => everyU(d, (. a) => p(a)) -let someU = (d, p) => N.someU(d.data, p) -let some = (d, p) => someU(d, (. a) => p(a)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) - -let fromSortedArrayUnsafe = (type value identity, xs, ~id: id): t<_> => { - module M = unpack(id) - {data: N.fromSortedArrayUnsafe(xs), cmp: M.cmp} -} - -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) - -let fromArray = (type value identity, data, ~id: id) => { - module M = unpack(id) - let cmp = M.cmp - {cmp, data: N.fromArray(~cmp, data)} -} - -let cmp = (d0, d1) => N.cmp(~cmp=d0.cmp, d0.data, d1.data) - -let eq = (d0, d1) => N.eq(~cmp=d0.cmp, d0.data, d1.data) - -let get = (d, x) => N.get(~cmp=d.cmp, d.data, x) - -let getUndefined = (d, x) => N.getUndefined(~cmp=d.cmp, d.data, x) - -let getExn = (d, x) => N.getExn(~cmp=d.cmp, d.data, x) - -let split = (d, key) => { - let arr = N.toArray(d.data) - let cmp = d.cmp - let i = Sort.binarySearchByU(arr, key, Belt_Id.getCmpInternal(cmp)) - let len = A.length(arr) - if i < 0 { - let next = -i - 1 - ( - ( - { - data: N.fromSortedArrayAux(arr, 0, next), - cmp, - }, - { - data: N.fromSortedArrayAux(arr, next, len - next), - cmp, - }, - ), - false, - ) - } else { - ( - ( - { - data: N.fromSortedArrayAux(arr, 0, i), - cmp, - }, - { - data: N.fromSortedArrayAux(arr, i + 1, len - i - 1), - cmp, - }, - ), - true, - ) - } -} - -let keepU = (d, p) => {data: N.keepCopyU(d.data, p), cmp: d.cmp} - -let keep = (d, p) => keepU(d, (. a) => p(a)) - -let partitionU = (d, p) => { - let cmp = d.cmp - let (a, b) = N.partitionCopyU(d.data, p) - ({data: a, cmp}, {data: b, cmp}) -} - -let partition = (d, p) => partitionU(d, (. a) => p(a)) - -let subset = (a, b) => N.subset(~cmp=a.cmp, a.data, b.data) - -let intersect = (a, b): t<_> => { - let cmp = a.cmp - switch (a.data, b.data) { - | (None, _) => {cmp, data: None} - | (_, None) => {cmp, data: None} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - let p = Belt_Id.getCmpInternal(cmp) - if ( - p(. A.getUnsafe(tmp, sizea - 1), A.getUnsafe(tmp, sizea)) < 0 || - p(. A.getUnsafe(tmp, totalSize - 1), A.getUnsafe(tmp, 0)) < 0 - ) { - {cmp, data: None} - } else { - let tmp2 = A.makeUninitializedUnsafe(Pervasives.min(sizea, sizeb)) - let k = Sort.intersectU(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0, p) - { - data: N.fromSortedArrayAux(tmp2, 0, k), - cmp, - } - } - } -} - -let diff = (a, b): t<_> => { - let cmp = a.cmp - let dataa = a.data - switch (dataa, b.data) { - | (None, _) => {cmp, data: None} - | (_, None) => {data: N.copy(dataa), cmp} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - let p = Belt_Id.getCmpInternal(cmp) - if ( - p(. A.getUnsafe(tmp, sizea - 1), A.getUnsafe(tmp, sizea)) < 0 || - p(. A.getUnsafe(tmp, totalSize - 1), A.getUnsafe(tmp, 0)) < 0 - ) { - {data: N.copy(dataa), cmp} - } else { - let tmp2 = A.makeUninitializedUnsafe(sizea) - let k = Sort.diffU(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0, p) - {data: N.fromSortedArrayAux(tmp2, 0, k), cmp} - } - } -} - -let union = (a, b) => { - let cmp = a.cmp - let (dataa, datab) = (a.data, b.data) - switch (dataa, datab) { - | (None, _) => {data: N.copy(datab), cmp} - | (_, None) => {data: N.copy(dataa), cmp} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - let p = Belt_Id.getCmpInternal(cmp) - if p(. A.getUnsafe(tmp, sizea - 1), A.getUnsafe(tmp, sizea)) < 0 { - {data: N.fromSortedArrayAux(tmp, 0, totalSize), cmp} - } else { - let tmp2 = A.makeUninitializedUnsafe(totalSize) - let k = Sort.unionU(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0, p) - {data: N.fromSortedArrayAux(tmp2, 0, k), cmp} - } - } -} - -let has = (d, x) => N.has(~cmp=d.cmp, d.data, x) - -let copy = d => {data: N.copy(d.data), cmp: d.cmp} diff --git a/jscomp/others/belt_MutableSet.resi b/jscomp/others/belt_MutableSet.resi deleted file mode 100644 index 8a52652..0000000 --- a/jscomp/others/belt_MutableSet.resi +++ /dev/null @@ -1,666 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -A **mutable** sorted set module which allows customized compare behavior. -The implementation uses balanced binary trees, and therefore searching and insertion take time logarithmic in the size of the map. - -It also has two specialized inner modules [Belt.MutableSet.Int](mutable-set-int) and [Belt.MutableSet.String](mutable-set-string) - This module separates data from function which is more verbose but slightly more efficient - -## Examples - -```rescript -module PairComparator = Belt.Id.MakeComparable({ - type t = (int, int) - let cmp = ((a0, a1), (b0, b1)) => - switch Pervasives.compare(a0, b0) { - | 0 => Pervasives.compare(a1, b1) - | c => c - } -}) - -let mySet = Belt.MutableSet.make(~id=module(PairComparator)) -mySet->Belt.MutableSet.add((1, 2)) -``` -*/ - -/** Specialized when key type is `int`, more efficient than the generic type */ -module Int = Belt_MutableSetInt - -/** Specialized when key type is `string`, more efficient than the generic type */ -module String = Belt_MutableSetString - -/** -`'value` is the element type - -`'identity` the identity of the collection -*/ -type t<'value, 'identity> - -/** -The identity needed for making a set from scratch -*/ -type id<'value, 'id> = Belt_Id.comparable<'value, 'id> - -/** -Creates a new set by taking in the comparator -*/ -let make: (~id: id<'value, 'id>) => t<'value, 'id> - -/** -Creates new set from array of elements. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([1, 3, 2, 4], ~id=module(IntCmp)) - -s0->Belt.MutableSet.toArray /* [1, 2, 3, 4] */ -``` -*/ -let fromArray: (array<'value>, ~id: id<'value, 'id>) => t<'value, 'id> - -/** -The same as [fromArray][#fromarray] except it is after assuming the input array is already sorted. -*/ -let fromSortedArrayUnsafe: (array<'value>, ~id: id<'value, 'id>) => t<'value, 'id> - -/** -Returns copy of a set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([1, 3, 2, 4], ~id=module(IntCmp)) - -let copied = s0->Belt.MutableSet.copy -copied->Belt.MutableSet.toArray /* [1, 2, 3, 4] */ -``` -*/ -let copy: t<'value, 'id> => t<'value, 'id> - -/** -Checks if set is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let empty = Belt.MutableSet.fromArray([], ~id=module(IntCmp)) -let notEmpty = Belt.MutableSet.fromArray([1], ~id=module(IntCmp)) - -Belt.MutableSet.isEmpty(empty) /* true */ -Belt.MutableSet.isEmpty(notEmpty) /* false */ -``` -*/ -let isEmpty: t<_> => bool - -/** -Checks if element exists in set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let set = Belt.MutableSet.fromArray([1, 4, 2, 5], ~id=module(IntCmp)) - -set->Belt.MutableSet.has(3) /* false */ -set->Belt.MutableSet.has(1) /* true */ -``` -*/ -let has: (t<'value, 'id>, 'value) => bool - -/** -Adds element to set. If element existed in set, value is unchanged. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.make(~id=module(IntCmp)) -s0->Belt.MutableSet.add(1) -s0->Belt.MutableSet.add(2) -s0->Belt.MutableSet.add(2) - -s0->Belt.MutableSet.toArray /* [1, 2] */ -``` -*/ -let add: (t<'value, 'id>, 'value) => unit - -let addCheck: (t<'value, 'id>, 'value) => bool - -/** -Adds each element of array to set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let set = Belt.MutableSet.make(~id=module(IntCmp)) - -set->Belt.MutableSet.mergeMany([5, 4, 3, 2, 1]) -set->Belt.MutableSet.toArray /* [1, 2, 3, 4, 5] */ -``` -*/ -let mergeMany: (t<'value, 'id>, array<'value>) => unit - -/** -Removes element from set. If element did not exist in set, value is unchanged. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([2, 3, 1, 4, 5], ~id=module(IntCmp)) -s0->Belt.MutableSet.remove(1) -s0->Belt.MutableSet.remove(3) -s0->Belt.MutableSet.remove(3) - -s0->Belt.MutableSet.toArray /* [2,4,5] */ -``` -*/ -let remove: (t<'value, 'id>, 'value) => unit - -let removeCheck: (t<'value, 'id>, 'value) => bool -/* `b = removeCheck s e` `b` is true means one element removed */ - -/** -Removes each element of array from set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let set = Belt.MutableSet.fromArray([1, 2, 3, 4], ~id=module(IntCmp)) - -set->Belt.MutableSet.removeMany([5, 4, 3, 2, 1]) -set->Belt.MutableSet.toArray /* [] */ -``` -*/ -let removeMany: (t<'value, 'id>, array<'value>) => unit - -/** -Returns union of two sets. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([5, 2, 3, 5, 6], ~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([5, 2, 3, 1, 5, 4], ~id=module(IntCmp)) -let union = Belt.MutableSet.union(s0, s1) -union->Belt.MutableSet.toArray /* [1,2,3,4,5,6] */ -``` -*/ -let union: (t<'value, 'id>, t<'value, 'id>) => t<'value, 'id> - -/** -Returns intersection of two sets. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([5, 2, 3, 5, 6], ~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([5, 2, 3, 1, 5, 4], ~id=module(IntCmp)) -let intersect = Belt.MutableSet.intersect(s0, s1) -intersect->Belt.MutableSet.toArray /* [2,3,5] */ -``` -*/ -let intersect: (t<'value, 'id>, t<'value, 'id>) => t<'value, 'id> - -/** -Returns elements from first set, not existing in second set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([5, 2, 3, 5, 6], ~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([5, 2, 3, 1, 5, 4], ~id=module(IntCmp)) -Belt.MutableSet.toArray(Belt.MutableSet.diff(s0, s1)) /* [6] */ -Belt.MutableSet.toArray(Belt.MutableSet.diff(s1, s0)) /* [1,4] */ -``` -*/ -let diff: (t<'value, 'id>, t<'value, 'id>) => t<'value, 'id> - -/** -Checks if second set is subset of first set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([5, 2, 3, 5, 6], ~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([5, 2, 3, 1, 5, 4], ~id=module(IntCmp)) -let s2 = Belt.MutableSet.intersect(s0, s1) -Belt.MutableSet.subset(s2, s0) /* true */ -Belt.MutableSet.subset(s2, s1) /* true */ -Belt.MutableSet.subset(s1, s0) /* false */ -``` -*/ -let subset: (t<'value, 'id>, t<'value, 'id>) => bool - -/** -Total ordering between sets. Can be used as the ordering function for doing sets of sets. -It compares size first and then iterates over each element following the order of elements. -*/ -let cmp: (t<'value, 'id>, t<'value, 'id>) => int - -/** -Checks if two sets are equal. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([5, 2, 3], ~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([3, 2, 5], ~id=module(IntCmp)) - -Belt.MutableSet.eq(s0, s1) /* true */ -``` -*/ -let eq: (t<'value, 'id>, t<'value, 'id>) => bool - -/** - Same as `Belt.MutableSet.forEach` but takes uncurried functon. -*/ -let forEachU: (t<'value, 'id>, (. 'value) => unit) => unit - -/** -Applies function `f` in turn to all elements of set in increasing order. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([5, 2, 3, 5, 6], ~id=module(IntCmp)) -let acc = ref(list{}) -s0->Belt.MutableSet.forEach(x => acc := Belt.List.add(acc.contents, x)) -acc /* [6,5,3,2] */ -``` -*/ -let forEach: (t<'value, 'id>, 'value => unit) => unit - -let reduceU: (t<'value, 'id>, 'a, (. 'a, 'value) => 'a) => 'a - -/** -Applies function `f` to each element of set in increasing order. Function `f` has two parameters: the item from the set and an “accumulator”, which starts with a value of `initialValue`. `reduce` returns the final value of the accumulator. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([5, 2, 3, 5, 6], ~id=module(IntCmp)) -s0->Belt.MutableSet.reduce(list{}, (acc, element) => acc->Belt.List.add(element)) /* [6,5,3,2] */ -``` -*/ -let reduce: (t<'value, 'id>, 'a, ('a, 'value) => 'a) => 'a - -let everyU: (t<'value, 'id>, (. 'value) => bool) => bool - -/** -Checks if all elements of the set satisfy the predicate. Order unspecified. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isEven = x => mod(x, 2) == 0 - -let s0 = Belt.MutableSet.fromArray([2, 4, 6, 8], ~id=module(IntCmp)) -s0->Belt.MutableSet.every(isEven) /* true */ -``` -*/ -let every: (t<'value, 'id>, 'value => bool) => bool - -let someU: (t<'value, 'id>, (. 'value) => bool) => bool - -/** -Checks if at least one element of the set satisfies the predicate. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isOdd = x => mod(x, 2) != 0 - -let s0 = Belt.MutableSet.fromArray([1, 2, 4, 6, 8], ~id=module(IntCmp)) -s0->Belt.MutableSet.some(isOdd) /* true */ -``` -*/ -let some: (t<'value, 'id>, 'value => bool) => bool - -let keepU: (t<'value, 'id>, (. 'value) => bool) => t<'value, 'id> - -/** -Returns the set of all elements that satisfy the predicate. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isEven = x => mod(x, 2) == 0 - -let s0 = Belt.MutableSet.fromArray([1, 2, 3, 4, 5], ~id=module(IntCmp)) -let s1 = s0->Belt.MutableSet.keep(isEven) - -s1->Belt.MutableSet.toArray /* [2, 4] */ -``` -*/ -let keep: (t<'value, 'id>, 'value => bool) => t<'value, 'id> - -let partitionU: (t<'value, 'id>, (. 'value) => bool) => (t<'value, 'id>, t<'value, 'id>) - -/** -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isOdd = x => mod(x, 2) != 0 - -let s0 = Belt.MutableSet.fromArray([1, 2, 3, 4, 5], ~id=module(IntCmp)) -let (s1, s2) = s0->Belt.MutableSet.partition(isOdd) - -s1->Belt.MutableSet.toArray /* [1,3,5] */ -s2->Belt.MutableSet.toArray /* [2,4] */ -``` -*/ -let partition: (t<'value, 'id>, 'value => bool) => (t<'value, 'id>, t<'value, 'id>) - -/** -Returns size of the set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([1, 2, 3, 4], ~id=module(IntCmp)) - -s0->Belt.MutableSet.size /* 4 */ -``` -*/ -let size: t<'value, 'id> => int - -/** -Returns list of ordered set elements. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([3, 2, 1, 5], ~id=module(IntCmp)) - -s0->Belt.MutableSet.toList /* [1,2,3,5] */ -``` -*/ -let toList: t<'value, 'id> => list<'value> - -/** -Returns array of ordered set elements. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([3, 2, 1, 5], ~id=module(IntCmp)) - -s0->Belt.MutableSet.toArray /* [1,2,3,5] */ -``` -*/ -let toArray: t<'value, 'id> => array<'value> - -/** -Returns minimum value of the collection. `None` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.make(~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([3, 2, 1, 5], ~id=module(IntCmp)) - -s0->Belt.MutableSet.minimum /* None */ -s1->Belt.MutableSet.minimum /* Some(1) */ -``` -*/ -let minimum: t<'value, 'id> => option<'value> - -/** -Returns minimum value of the collection. `undefined` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.make(~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([3, 2, 1, 5], ~id=module(IntCmp)) - -s0->Belt.MutableSet.minUndefined /* undefined */ -s1->Belt.MutableSet.minUndefined /* 1 */ -``` -*/ -let minUndefined: t<'value, 'id> => Js.undefined<'value> - -/** -Returns maximum value of the collection. `None` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.make(~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([3, 2, 1, 5], ~id=module(IntCmp)) - -s0->Belt.MutableSet.maximum /* None */ -s1->Belt.MutableSet.maximum /* Some(5) */ -``` -*/ -let maximum: t<'value, 'id> => option<'value> - -/** -Returns maximum value of the collection. `undefined` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.make(~id=module(IntCmp)) -let s1 = Belt.MutableSet.fromArray([3, 2, 1, 5], ~id=module(IntCmp)) - -s0->Belt.MutableSet.maxUndefined /* undefined */ -s1->Belt.MutableSet.maxUndefined /* 5 */ -``` -*/ -let maxUndefined: t<'value, 'id> => Js.undefined<'value> - -/** -Returns the reference of the value which is equivalent to value using the comparator specifiecd by this collection. Returns `None` if element does not exist. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([1, 2, 3, 4, 5], ~id=module(IntCmp)) - -s0->Belt.MutableSet.get(3) /* Some(3) */ -s0->Belt.MutableSet.get(20) /* None */ -``` -*/ -let get: (t<'value, 'id>, 'value) => option<'value> - -/** -Same as `Belt.MutableSet.get` but returns `undefined` when element does not exist. -*/ -let getUndefined: (t<'value, 'id>, 'value) => Js.undefined<'value> - -/** -Same as `Belt.MutableSet.get` but raise when element does not exist. -*/ -let getExn: (t<'value, 'id>, 'value) => 'value - -/** -Returns a tuple `((smaller, larger), present)`, `present` is true when element exist in set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.MutableSet.fromArray([1, 2, 3, 4, 5], ~id=module(IntCmp)) - -let ((smaller, larger), present) = s0->Belt.MutableSet.split(3) - -present /* true */ -smaller->Belt.MutableSet.toArray /* [1,2] */ -larger->Belt.MutableSet.toArray /* [4,5] */ -``` -*/ -let split: (t<'value, 'id>, 'value) => ((t<'value, 'id>, t<'value, 'id>), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/* - `add0` was not exposed for various reasons: - 1. such api is dangerious - [ cmp: ('value,'id) Belt_Cmp.cmp -> - ('value, 'id) t0 -> 'value -> - ('value, 'id) t0] - 2. It is not really significantly more */ diff --git a/jscomp/others/belt_MutableSetInt.res b/jscomp/others/belt_MutableSetInt.res deleted file mode 100644 index 4c50fcd..0000000 --- a/jscomp/others/belt_MutableSetInt.res +++ /dev/null @@ -1,339 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** This module is [`Belt.MutableSet`]() specialized with key type to be a primitive type. - It is more efficient in general, the API is the same with [`Belt_MutableSet`]() except its key type is fixed, - and identity is not needed(using the built-in one) -*/ - -module I = Belt_internalSetInt -module S = Belt_SortArrayInt - -module N = Belt_internalAVLset -module A = Belt_Array - -/** The type of the set elements. */ -type value = I.value - -/** The type of sets. */ -type t = {mutable data: I.t} - -let rec remove0 = (nt, x: value) => { - let k = nt.N.value - if x == k { - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = remove0(l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = remove0(r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(oldRoot2) => - let newRoot = remove0(oldRoot2, v) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec removeMany0 = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = remove0(t, ele) - switch u { - | None => None - | Some(t) => removeMany0(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (d: t, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - d.data = removeMany0(nt, xs, 0, len) - } -} - -let rec removeCheck0 = (nt, x: value, removed) => { - let k = nt.N.value - if x == k { - let () = removed.contents = true - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = removeCheck0(l, x, removed) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeCheck0(r, x, removed) - Some(N.balMutate(nt)) - } - } -} - -let removeCheck = (d: t, v) => { - let oldRoot = d.data - switch oldRoot { - | None => false - | Some(oldRoot2) => - let removed = ref(false) - let newRoot = removeCheck0(oldRoot2, v, removed) - if newRoot !== oldRoot { - d.data = newRoot - } - removed.contents - } -} - -let rec addCheck0 = (t, x: value, added) => - switch t { - | None => - added.contents = true - N.singleton(x) - | Some(nt) => - let k = nt.N.value - if x == k { - t - } else { - let {N.left: l, right: r} = nt - if x < k { - let ll = addCheck0(l, x, added) - nt.left = ll - } else { - nt.right = addCheck0(r, x, added) - } - Some(N.balMutate(nt)) - } - } - -let addCheck = (m: t, e) => { - let oldRoot = m.data - let added = ref(false) - let newRoot = addCheck0(oldRoot, e, added) - if newRoot !== oldRoot { - m.data = newRoot - } - added.contents -} - -let add = (d, k) => { - let oldRoot = d.data - let v = I.addMutate(oldRoot, k) - if v !== oldRoot { - d.data = v - } -} - -let addArrayMutate = (t, xs) => { - let v = ref(t) - for i in 0 to A.length(xs) - 1 { - v.contents = I.addMutate(v.contents, A.getUnsafe(xs, i)) - } - v.contents -} - -let mergeMany = (d, arr) => d.data = addArrayMutate(d.data, arr) - -let make = () => {data: None} - -let isEmpty = d => N.isEmpty(d.data) - -let minimum = d => N.minimum(d.data) - -let minUndefined = d => N.minUndefined(d.data) - -let maximum = d => N.maximum(d.data) - -let maxUndefined = d => N.maxUndefined(d.data) - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a) => f(a)) - -let reduceU = (d, acc, cb) => N.reduceU(d.data, acc, cb) -let reduce = (d, acc, cb) => reduceU(d, acc, (. a, b) => cb(a, b)) - -let everyU = (d, p) => N.everyU(d.data, p) -let every = (d, p) => everyU(d, (. a) => p(a)) -let someU = (d, p) => N.someU(d.data, p) -let some = (d, p) => someU(d, (. a) => p(a)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) - -let fromSortedArrayUnsafe = xs => {data: N.fromSortedArrayUnsafe(xs)} - -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) - -let fromArray = xs => {data: I.fromArray(xs)} - -let cmp = (d0, d1) => I.cmp(d0.data, d1.data) -let eq = (d0, d1) => I.eq(d0.data, d1.data) -let get = (d, x) => I.get(d.data, x) -let getUndefined = (d, x) => I.getUndefined(d.data, x) -let getExn = (d, x) => I.getExn(d.data, x) - -let split = (d, key) => { - let arr = N.toArray(d.data) - let i = S.binarySearch(arr, key) - let len = A.length(arr) - if i < 0 { - let next = -i - 1 - ( - ( - {data: N.fromSortedArrayAux(arr, 0, next)}, - {data: N.fromSortedArrayAux(arr, next, len - next)}, - ), - false, - ) - } else { - ( - ( - {data: N.fromSortedArrayAux(arr, 0, i)}, - {data: N.fromSortedArrayAux(arr, i + 1, len - i - 1)}, - ), - true, - ) - } -} - -let keepU = (d, p) => {data: N.keepCopyU(d.data, p)} -let keep = (d, p) => keepU(d, (. a) => p(a)) - -let partitionU = (d, p) => { - let (a, b) = N.partitionCopyU(d.data, p) - ({data: a}, {data: b}) -} -let partition = (d, p) => partitionU(d, (. a) => p(a)) - -let subset = (a, b) => I.subset(a.data, b.data) -let intersect = (dataa, datab) => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => make() - | (_, None) => make() - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if ( - A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) || - A.getUnsafe(tmp, totalSize - 1) < A.getUnsafe(tmp, 0) - ) { - make() - } else { - let tmp2 = A.makeUninitializedUnsafe(Pervasives.min(sizea, sizeb)) - let k = S.intersect(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let diff = (dataa, datab): t => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => make() - | (_, None) => {data: N.copy(dataa)} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if ( - A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) || - A.getUnsafe(tmp, totalSize - 1) < A.getUnsafe(tmp, 0) - ) { - {data: N.copy(dataa)} - } else { - let tmp2 = A.makeUninitializedUnsafe(sizea) - let k = S.diff(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let union = (dataa: t, datab: t): t => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => {data: N.copy(datab)} - | (_, None) => {data: N.copy(dataa)} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) { - {data: N.fromSortedArrayAux(tmp, 0, totalSize)} - } else { - let tmp2 = A.makeUninitializedUnsafe(totalSize) - let k = S.union(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let has = (d, x) => I.has(d.data, x) - -let copy = d => {data: N.copy(d.data)} diff --git a/jscomp/others/belt_MutableSetInt.resi b/jscomp/others/belt_MutableSetInt.resi deleted file mode 100644 index e7dc512..0000000 --- a/jscomp/others/belt_MutableSetInt.resi +++ /dev/null @@ -1,131 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module is [`Belt.MutableSet`]() specialized with key type to be a primitive type. - -It is more efficient in general, the API is the same with [`Belt.MutableSet`]() except its key type is fixed, -and identity is not needed(using the built-in one) - -**See** [`Belt.MutableSet`]() -*/ - -/** The type of the set elements. */ -type value = int - -/** The type of sets. */ -type t - -let make: unit => t - -let fromArray: array => t -let fromSortedArrayUnsafe: array => t - -let copy: t => t -let isEmpty: t => bool -let has: (t, value) => bool - -let add: (t, value) => unit -let addCheck: (t, value) => bool -let mergeMany: (t, array) => unit -let remove: (t, value) => unit -let removeCheck: (t, value) => bool -let removeMany: (t, array) => unit - -let union: (t, t) => t -let intersect: (t, t) => t -let diff: (t, t) => t -let subset: (t, t) => bool - -let cmp: (t, t) => int -let eq: (t, t) => bool - -let forEachU: (t, (. value) => unit) => unit - -/** In increasing order*/ -let forEach: (t, value => unit) => unit - -let reduceU: (t, 'a, (. 'a, value) => 'a) => 'a - -/** Iterate in increasing order. */ -let reduce: (t, 'a, ('a, value) => 'a) => 'a - -let everyU: (t, (. value) => bool) => bool - -/** -`every(p, s)` checks if all elements of the set satisfy the predicate `p`. -Order unspecified. */ -let every: (t, value => bool) => bool - -let someU: (t, (. value) => bool) => bool - -/** -`some(p, s)` checks if at least one element of the set satisfies the predicate -`p`. Oder unspecified. -*/ -let some: (t, value => bool) => bool - -let keepU: (t, (. value) => bool) => t - -/** -`keep(s, p)` returns a fresh copy of the set of all elements in `s` that satisfy -predicate `p`. -*/ -let keep: (t, value => bool) => t - -let partitionU: (t, (. value) => bool) => (t, t) - -/** -`partition(s, p)` returns a fresh copy pair of sets `(s1, s2)`, where `s1` is -the set of all the elements of `s` that satisfy the predicate `p`, and `s2` is -the set of all the elements of `s` that do not satisfy `p`. -*/ -let partition: (t, value => bool) => (t, t) - -let size: t => int - -/** In increasing order with respect */ -let toList: t => list - -/** In increasing order with respect */ -let toArray: t => array - -let minimum: t => option -let minUndefined: t => Js.undefined -let maximum: t => option -let maxUndefined: t => Js.undefined - -let get: (t, value) => option -let getUndefined: (t, value) => Js.undefined -let getExn: (t, value) => value - -/** -`split(s, key)` return a fresh copy of each -*/ -let split: (t, value) => ((t, t), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t => unit diff --git a/jscomp/others/belt_MutableSetString.res b/jscomp/others/belt_MutableSetString.res deleted file mode 100644 index eb0cb4f..0000000 --- a/jscomp/others/belt_MutableSetString.res +++ /dev/null @@ -1,339 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** This module is [`Belt.MutableSet`]() specialized with key type to be a primitive type. - It is more efficient in general, the API is the same with [`Belt_MutableSet`]() except its key type is fixed, - and identity is not needed(using the built-in one) -*/ - -module I = Belt_internalSetString -module S = Belt_SortArrayString - -module N = Belt_internalAVLset -module A = Belt_Array - -/** The type of the set elements. */ -type value = I.value - -/** The type of sets. */ -type t = {mutable data: I.t} - -let rec remove0 = (nt, x: value) => { - let k = nt.N.value - if x == k { - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = remove0(l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = remove0(r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(oldRoot2) => - let newRoot = remove0(oldRoot2, v) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec removeMany0 = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = remove0(t, ele) - switch u { - | None => None - | Some(t) => removeMany0(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (d: t, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - d.data = removeMany0(nt, xs, 0, len) - } -} - -let rec removeCheck0 = (nt, x: value, removed) => { - let k = nt.N.value - if x == k { - let () = removed.contents = true - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = removeCheck0(l, x, removed) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeCheck0(r, x, removed) - Some(N.balMutate(nt)) - } - } -} - -let removeCheck = (d: t, v) => { - let oldRoot = d.data - switch oldRoot { - | None => false - | Some(oldRoot2) => - let removed = ref(false) - let newRoot = removeCheck0(oldRoot2, v, removed) - if newRoot !== oldRoot { - d.data = newRoot - } - removed.contents - } -} - -let rec addCheck0 = (t, x: value, added) => - switch t { - | None => - added.contents = true - N.singleton(x) - | Some(nt) => - let k = nt.N.value - if x == k { - t - } else { - let {N.left: l, right: r} = nt - if x < k { - let ll = addCheck0(l, x, added) - nt.left = ll - } else { - nt.right = addCheck0(r, x, added) - } - Some(N.balMutate(nt)) - } - } - -let addCheck = (m: t, e) => { - let oldRoot = m.data - let added = ref(false) - let newRoot = addCheck0(oldRoot, e, added) - if newRoot !== oldRoot { - m.data = newRoot - } - added.contents -} - -let add = (d, k) => { - let oldRoot = d.data - let v = I.addMutate(oldRoot, k) - if v !== oldRoot { - d.data = v - } -} - -let addArrayMutate = (t, xs) => { - let v = ref(t) - for i in 0 to A.length(xs) - 1 { - v.contents = I.addMutate(v.contents, A.getUnsafe(xs, i)) - } - v.contents -} - -let mergeMany = (d, arr) => d.data = addArrayMutate(d.data, arr) - -let make = () => {data: None} - -let isEmpty = d => N.isEmpty(d.data) - -let minimum = d => N.minimum(d.data) - -let minUndefined = d => N.minUndefined(d.data) - -let maximum = d => N.maximum(d.data) - -let maxUndefined = d => N.maxUndefined(d.data) - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a) => f(a)) - -let reduceU = (d, acc, cb) => N.reduceU(d.data, acc, cb) -let reduce = (d, acc, cb) => reduceU(d, acc, (. a, b) => cb(a, b)) - -let everyU = (d, p) => N.everyU(d.data, p) -let every = (d, p) => everyU(d, (. a) => p(a)) -let someU = (d, p) => N.someU(d.data, p) -let some = (d, p) => someU(d, (. a) => p(a)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) - -let fromSortedArrayUnsafe = xs => {data: N.fromSortedArrayUnsafe(xs)} - -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) - -let fromArray = xs => {data: I.fromArray(xs)} - -let cmp = (d0, d1) => I.cmp(d0.data, d1.data) -let eq = (d0, d1) => I.eq(d0.data, d1.data) -let get = (d, x) => I.get(d.data, x) -let getUndefined = (d, x) => I.getUndefined(d.data, x) -let getExn = (d, x) => I.getExn(d.data, x) - -let split = (d, key) => { - let arr = N.toArray(d.data) - let i = S.binarySearch(arr, key) - let len = A.length(arr) - if i < 0 { - let next = -i - 1 - ( - ( - {data: N.fromSortedArrayAux(arr, 0, next)}, - {data: N.fromSortedArrayAux(arr, next, len - next)}, - ), - false, - ) - } else { - ( - ( - {data: N.fromSortedArrayAux(arr, 0, i)}, - {data: N.fromSortedArrayAux(arr, i + 1, len - i - 1)}, - ), - true, - ) - } -} - -let keepU = (d, p) => {data: N.keepCopyU(d.data, p)} -let keep = (d, p) => keepU(d, (. a) => p(a)) - -let partitionU = (d, p) => { - let (a, b) = N.partitionCopyU(d.data, p) - ({data: a}, {data: b}) -} -let partition = (d, p) => partitionU(d, (. a) => p(a)) - -let subset = (a, b) => I.subset(a.data, b.data) -let intersect = (dataa, datab) => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => make() - | (_, None) => make() - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if ( - A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) || - A.getUnsafe(tmp, totalSize - 1) < A.getUnsafe(tmp, 0) - ) { - make() - } else { - let tmp2 = A.makeUninitializedUnsafe(Pervasives.min(sizea, sizeb)) - let k = S.intersect(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let diff = (dataa, datab): t => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => make() - | (_, None) => {data: N.copy(dataa)} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if ( - A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) || - A.getUnsafe(tmp, totalSize - 1) < A.getUnsafe(tmp, 0) - ) { - {data: N.copy(dataa)} - } else { - let tmp2 = A.makeUninitializedUnsafe(sizea) - let k = S.diff(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let union = (dataa: t, datab: t): t => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => {data: N.copy(datab)} - | (_, None) => {data: N.copy(dataa)} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) { - {data: N.fromSortedArrayAux(tmp, 0, totalSize)} - } else { - let tmp2 = A.makeUninitializedUnsafe(totalSize) - let k = S.union(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let has = (d, x) => I.has(d.data, x) - -let copy = d => {data: N.copy(d.data)} diff --git a/jscomp/others/belt_MutableSetString.resi b/jscomp/others/belt_MutableSetString.resi deleted file mode 100644 index 72aa9be..0000000 --- a/jscomp/others/belt_MutableSetString.resi +++ /dev/null @@ -1,131 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module is [`Belt.MutableSet`]() specialized with key type to be a primitive type. - -It is more efficient in general, the API is the same with [`Belt.MutableSet`]() except its key type is fixed, -and identity is not needed(using the built-in one) - -**See** [`Belt.MutableSet`]() -*/ - -/** The type of the set elements. */ -type value = string - -/** The type of sets. */ -type t - -let make: unit => t - -let fromArray: array => t -let fromSortedArrayUnsafe: array => t - -let copy: t => t -let isEmpty: t => bool -let has: (t, value) => bool - -let add: (t, value) => unit -let addCheck: (t, value) => bool -let mergeMany: (t, array) => unit -let remove: (t, value) => unit -let removeCheck: (t, value) => bool -let removeMany: (t, array) => unit - -let union: (t, t) => t -let intersect: (t, t) => t -let diff: (t, t) => t -let subset: (t, t) => bool - -let cmp: (t, t) => int -let eq: (t, t) => bool - -let forEachU: (t, (. value) => unit) => unit - -/** In increasing order*/ -let forEach: (t, value => unit) => unit - -let reduceU: (t, 'a, (. 'a, value) => 'a) => 'a - -/** Iterate in increasing order. */ -let reduce: (t, 'a, ('a, value) => 'a) => 'a - -let everyU: (t, (. value) => bool) => bool - -/** -`every(p, s)` checks if all elements of the set satisfy the predicate `p`. -Order unspecified. */ -let every: (t, value => bool) => bool - -let someU: (t, (. value) => bool) => bool - -/** -`some(p, s)` checks if at least one element of the set satisfies the predicate -`p`. Oder unspecified. -*/ -let some: (t, value => bool) => bool - -let keepU: (t, (. value) => bool) => t - -/** -`keep(s, p)` returns a fresh copy of the set of all elements in `s` that satisfy -predicate `p`. -*/ -let keep: (t, value => bool) => t - -let partitionU: (t, (. value) => bool) => (t, t) - -/** -`partition(s, p)` returns a fresh copy pair of sets `(s1, s2)`, where `s1` is -the set of all the elements of `s` that satisfy the predicate `p`, and `s2` is -the set of all the elements of `s` that do not satisfy `p`. -*/ -let partition: (t, value => bool) => (t, t) - -let size: t => int - -/** In increasing order with respect */ -let toList: t => list - -/** In increasing order with respect */ -let toArray: t => array - -let minimum: t => option -let minUndefined: t => Js.undefined -let maximum: t => option -let maxUndefined: t => Js.undefined - -let get: (t, value) => option -let getUndefined: (t, value) => Js.undefined -let getExn: (t, value) => value - -/** -`split(s, key)` return a fresh copy of each -*/ -let split: (t, value) => ((t, t), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t => unit diff --git a/jscomp/others/belt_MutableStack.res b/jscomp/others/belt_MutableStack.res deleted file mode 100644 index 2d7b34f..0000000 --- a/jscomp/others/belt_MutableStack.res +++ /dev/null @@ -1,103 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type rec t<'a> = {mutable root: opt_cell<'a>} -and opt_cell<'a> = option> -and cell<'a> = { - head: 'a, - tail: opt_cell<'a>, -} - -let make = () => {root: None} - -let clear = s => s.root = None - -let copy = (s: t<_>): t<_> => {root: s.root} - -let push = (s, x) => s.root = Some({head: x, tail: s.root}) - -let topUndefined = (s: t<'a>) => - switch s.root { - | None => Js.undefined - | Some(x) => Js.Undefined.return(x.head) - } - -let top = s => - switch s.root { - | None => None - | Some(x) => Some(x.head) - } - -let isEmpty = s => s.root == None - -let popUndefined = s => - switch s.root { - | None => Js.undefined - | Some(x) => - s.root = x.tail - Js.Undefined.return(x.head) - } - -let pop = s => - switch s.root { - | None => None - | Some(x) => - s.root = x.tail - Some(x.head) - } - -let rec lengthAux = (x: cell<_>, acc) => - switch x.tail { - | None => acc + 1 - | Some(x) => lengthAux(x, acc + 1) - } - -let size = s => - switch s.root { - | None => 0 - | Some(x) => lengthAux(x, 0) - } - -let rec iterAux = (s: opt_cell<_>, f) => - switch s { - | None => () - | Some(x) => - f(. x.head) - iterAux(x.tail, f) - } - -let forEachU = (s, f) => iterAux(s.root, f) - -let forEach = (s, f) => forEachU(s, (. x) => f(x)) - -let rec dynamicPopIterU = (s, f) => - switch s.root { - | Some({tail, head}) => - s.root = tail - f(. head) - dynamicPopIterU(s, f) /* using root, `f` may change it */ - | None => () - } - -let dynamicPopIter = (s, f) => dynamicPopIterU(s, (. x) => f(x)) diff --git a/jscomp/others/belt_MutableStack.resi b/jscomp/others/belt_MutableStack.resi deleted file mode 100644 index cb11d4a..0000000 --- a/jscomp/others/belt_MutableStack.resi +++ /dev/null @@ -1,63 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -First in last out stack. This module implements stacks, with in-place -modification. -*/ - -type t<'a> - -/** -Returns a new stack, initially empty. -*/ -let make: unit => t<'a> - -/** -Discard all elements from the stack. -*/ -let clear: t<'a> => unit - -/** -`copy(x)` O(1) operation, return a new stack. -*/ -let copy: t<'a> => t<'a> - -let push: (t<'a>, 'a) => unit -let popUndefined: t<'a> => Js.undefined<'a> -let pop: t<'a> => option<'a> -let topUndefined: t<'a> => Js.undefined<'a> -let top: t<'a> => option<'a> -let isEmpty: t<'a> => bool -let size: t<'a> => int -let forEachU: (t<'a>, (. 'a) => unit) => unit -let forEach: (t<'a>, 'a => unit) => unit -let dynamicPopIterU: (t<'a>, (. 'a) => unit) => unit - -/** -`dynamicPopIter(s, f)` apply `f` to each element of `s`. The item is poped -before applying `f`, `s` will be empty after this opeartion. This function is -useful for worklist algorithm. - */ -let dynamicPopIter: (t<'a>, 'a => unit) => unit diff --git a/jscomp/others/belt_Option.res b/jscomp/others/belt_Option.res deleted file mode 100644 index b7371b4..0000000 --- a/jscomp/others/belt_Option.res +++ /dev/null @@ -1,113 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let keepU = (opt, p) => - switch opt { - | Some(x) as some if p(. x) => some - | _ => None - } - -let keep = (opt, p) => keepU(opt, (. x) => p(x)) - -let forEachU = (opt, f) => - switch opt { - | Some(x) => f(. x) - | None => () - } - -let forEach = (opt, f) => forEachU(opt, (. x) => f(x)) - -let getExn = x => - switch x { - | Some(x) => x - | None => raise(Not_found) - } - -external getUnsafe: option<'a> => 'a = "%identity" - -let mapWithDefaultU = (opt, default, f) => - switch opt { - | Some(x) => f(. x) - | None => default - } - -let mapWithDefault = (opt, default, f) => mapWithDefaultU(opt, default, (. x) => f(x)) - -let mapU = (opt, f) => - switch opt { - | Some(x) => Some(f(. x)) - | None => None - } - -let map = (opt, f) => mapU(opt, (. x) => f(x)) - -let flatMapU = (opt, f) => - switch opt { - | Some(x) => f(. x) - | None => None - } - -let flatMap = (opt, f) => flatMapU(opt, (. x) => f(x)) - -let getWithDefault = (opt, default) => - switch opt { - | Some(x) => x - | None => default - } - -let orElse = (opt, other) => - switch opt { - | Some(_) as some => some - | None => other - } - -let isSome = x => - switch x { - | Some(_) => true - | None => false - } - -let isNone = x => x == None - -let eqU = (a, b, f) => - switch a { - | Some(a) => - switch b { - | None => false - | Some(b) => f(. a, b) - } - | None => b == None - } - -let eq = (a, b, f) => eqU(a, b, (. x, y) => f(x, y)) - -let cmpU = (a, b, f) => - switch (a, b) { - | (Some(a), Some(b)) => f(. a, b) - | (None, Some(_)) => -1 - | (Some(_), None) => 1 - | (None, None) => 0 - } - -let cmp = (a, b, f) => cmpU(a, b, (. x, y) => f(x, y)) diff --git a/jscomp/others/belt_Option.resi b/jscomp/others/belt_Option.resi deleted file mode 100644 index 5764811..0000000 --- a/jscomp/others/belt_Option.resi +++ /dev/null @@ -1,295 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -In Belt we represent the existence and nonexistence of a value by wrapping it -with the `option` type. In order to make it a bit more convenient to work with -option-types, Belt provides utility-functions for it. - -The `option` type is a part of the ReScript standard library which is defined like this: - -## Examples - -```rescript -type option<'a> = None | Some('a) -``` - -```rescript -let someString: option = Some("hello") -``` -*/ - -/** Uncurried version of `keep` */ -let keepU: (option<'a>, (. 'a) => bool) => option<'a> - -/** -If `optionValue` is `Some(value)` and `p(value) = true`, it returns `Some(value)`; otherwise returns `None` - -## Examples - -```rescript -Belt.Option.keep(Some(10), x => x > 5) /* returns `Some(10)` */ -Belt.Option.keep(Some(4), x => x > 5) /* returns `None` */ -Belt.Option.keep(None, x => x > 5) /* returns `None` */ -``` -*/ -let keep: (option<'a>, 'a => bool) => option<'a> - -/** Uncurried version of `forEach` */ -let forEachU: (option<'a>, (. 'a) => unit) => unit - -/** -If `optionValue` is `Some(value`), it calls `f(value)`; otherwise returns `()` - -## Examples - -```rescript -Belt.Option.forEach(Some("thing"), x => Js.log(x)) /* logs "thing" */ -Belt.Option.forEach(None, x => Js.log(x)) /* returns () */ -``` -*/ -let forEach: (option<'a>, 'a => unit) => unit - -/** -Raises an Error in case `None` is provided. Use with care. - -## Examples - -```rescript -Belt.Option.getExn(Some(3)) /* 3 */ - -Belt.Option.getExn(None) /* Raises an Error */ -``` -*/ -let getExn: option<'a> => 'a - -/** -`getUnsafe(x)` returns `x` - -This is an unsafe operation, it assumes `x` is neither `None` -nor `Some(None(...)))` -*/ -external getUnsafe: option<'a> => 'a = "%identity" - -/** Uncurried version of `mapWithDefault` */ -let mapWithDefaultU: (option<'a>, 'b, (. 'a) => 'b) => 'b - -/** -If `optionValue` is of `Some(value)`, -this function returns that value applied with `f`, in other words `f(value)`. - -If `optionValue` is `None`, the default is returned. - -## Examples - -```rescript -let someValue = Some(3) -someValue->Belt.Option.mapWithDefault(0, x => x + 5) /* 8 */ - -let noneValue = None -noneValue->Belt.Option.mapWithDefault(0, x => x + 5) /* 0 */ -``` -*/ -let mapWithDefault: (option<'a>, 'b, 'a => 'b) => 'b - -/** Uncurried version of `map` */ -let mapU: (option<'a>, (. 'a) => 'b) => option<'b> - -/** -If `optionValue` is `Some(value)` this returns `f(value)`, otherwise it returns `None`. - -## Examples - -```rescript -Belt.Option.map(Some(3), x => x * x) /* Some(9) */ - -Belt.Option.map(None, x => x * x) /* None */ -``` -*/ -let map: (option<'a>, 'a => 'b) => option<'b> - -/** Uncurried version of `flatMap` */ -let flatMapU: (option<'a>, (. 'a) => option<'b>) => option<'b> - -/** -If `optionValue` is `Some(value)`, returns `f(value)`, otherwise returns -`None`.
-The function `f` must have a return type of `option<'b>`. - -## Examples - -```rescript -let addIfAboveOne = value => - if (value > 1) { - Some(value + 1) - } else { - None - } - -Belt.Option.flatMap(Some(2), addIfAboveOne) /* Some(3) */ - -Belt.Option.flatMap(Some(-4), addIfAboveOne) /* None */ - -Belt.Option.flatMap(None, addIfAboveOne) /* None */ -``` -*/ -let flatMap: (option<'a>, 'a => option<'b>) => option<'b> - -/** -If `optionalValue` is `Some(value)`, returns `value`, otherwise default. - -## Examples - -```rescript -Belt.Option.getWithDefault(None, "Banana") /* Banana */ - -Belt.Option.getWithDefault(Some("Apple"), "Banana") /* Apple */ -``` - -```rescript -let greet = (firstName: option) => - "Greetings " ++ firstName->Belt.Option.getWithDefault("Anonymous") - -Some("Jane")->greet /* "Greetings Jane" */ - -None->greet /* "Greetings Anonymous" */ -``` -*/ -let getWithDefault: (option<'a>, 'a) => 'a - -/** -`orElse(optionalValue, otherOptional)` if `optionalValue` is `Some(value)`, -returns `Some(value)`, otherwise `otherOptional` - -## Examples - -```rescript -Belt.Option.orElse(Some(1812), Some(1066)) == Some(1812) -Belt.Option.orElse(None, Some(1066)) == Some(1066) -Belt.Option.orElse(None, None) == None -``` -*/ -let orElse: (option<'a>, option<'a>) => option<'a> - -/** -Returns `true` if the argument is `Some(value)`, `false` otherwise. - -## Examples - -```rescript -Belt.Option.isSome(None) /* false */ - -Belt.Option.isSome(Some(1)) /* true */ -``` -*/ -let isSome: option<'a> => bool - -/** -Returns `true` if the argument is `None`, `false` otherwise. - -## Examples - -```rescript -Belt.Option.isNone(None) /* true */ - -Belt.Option.isNone(Some(1)) /* false */ -``` -*/ -let isNone: option<'a> => bool - -/** -Uncurried version of `eq` -*/ -let eqU: (option<'a>, option<'b>, (. 'a, 'b) => bool) => bool - -/** -Evaluates two optional values for equality with respect to a predicate -function. If both `optValue1` and `optValue2` are `None`, returns `true`. -If one of the arguments is `Some(value)` and the other is `None`, returns -`false`. - -If arguments are `Some(value1)` and `Some(value2)`, returns the result of -`predicate(value1, value2)`; the predicate function must return a bool. - -## Examples - -```rescript -let clockEqual = (a, b) => mod(a, 12) == mod(b, 12) - -open Belt.Option - -eq(Some(3), Some(15), clockEqual) /* true */ - -eq(Some(3), None, clockEqual) /* false */ - -eq(None, Some(3), clockEqual) /* false */ - -eq(None, None, clockEqual) /* true */ -``` -*/ -let eq: (option<'a>, option<'b>, ('a, 'b) => bool) => bool - -/** -Uncurried version of `cmp` -*/ -let cmpU: (option<'a>, option<'b>, (. 'a, 'b) => int) => int - -/** -`cmp(optValue1, optValue2, comparisonFunction)` compares two optional values -with respect to given `comparisonFunction`. - -If both `optValue1` and `optValue2` are `None`, it returns `0`. - -If the first argument is `Some(value1)` and the second is `None`, returns `1` -(something is greater than nothing). - -If the first argument is `None` and the second is `Some(value2)`, returns `-1` -(nothing is less than something). - -If the arguments are `Some(value1)` and `Some(value2)`, returns the result of -`comparisonFunction(value1, value2)`; comparisonFunction takes two arguments -and returns `-1` if the first argument is less than the second, `0` if the -arguments are equal, and `1` if the first argument is greater than the second. - -## Examples - -```rescript -let clockCompare = (a, b) => compare(mod(a, 12), mod(b, 12)) - -open Belt.Option - -cmp(Some(3), Some(15), clockCompare) /* 0 */ - -cmp(Some(3), Some(14), clockCompare) /* 1 */ - -cmp(Some(2), Some(15), clockCompare) /* (-1) */ - -cmp(None, Some(15), clockCompare) /* (-1) */ - -cmp(Some(14), None, clockCompare) /* 1 */ - -cmp(None, None, clockCompare) /* 0 */ -``` -*/ -let cmp: (option<'a>, option<'b>, ('a, 'b) => int) => int diff --git a/jscomp/others/belt_Range.res b/jscomp/others/belt_Range.res deleted file mode 100644 index c8f5d33..0000000 --- a/jscomp/others/belt_Range.res +++ /dev/null @@ -1,80 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let forEachU = (s, f, action) => - for i in s to f { - (action(. i): unit) - } - -let forEach = (s, f, action) => forEachU(s, f, (. a) => action(a)) - -let rec everyU = (s, f, p) => - if s > f { - true - } else { - p(. s) && everyU(s + 1, f, p) - } - -let every = (s, f, p) => everyU(s, f, (. a) => p(a)) - -let rec everyByAux = (s, f, ~step, p) => - if s > f { - true - } else { - p(. s) && everyByAux(s + step, f, ~step, p) - } - -let everyByU = (s, f, ~step, p) => - if step > 0 { - everyByAux(s, f, ~step, p) - } else { - true - } /* return empty range `true` */ - -let everyBy = (s, f, ~step, p) => everyByU(s, f, ~step, (. a) => p(a)) - -let rec someU = (s, f, p) => - if s > f { - false - } else { - p(. s) || someU(s + 1, f, p) - } - -let some = (s, f, p) => someU(s, f, (. a) => p(a)) - -let rec someByAux = (s, f, ~step, p) => - if s > f { - false - } else { - p(. s) || someByAux(s + step, f, ~step, p) - } - -let someByU = (s, f, ~step, p) => - if step > 0 { - someByAux(s, f, ~step, p) - } else { - false - } /* return empty range, `false` */ - -let someBy = (s, f, ~step, p) => someByU(s, f, ~step, (. a) => p(a)) diff --git a/jscomp/others/belt_Range.resi b/jscomp/others/belt_Range.resi deleted file mode 100644 index b0ad2f2..0000000 --- a/jscomp/others/belt_Range.resi +++ /dev/null @@ -1,109 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -A small utility module to provide inclusive range operations for `[start, finish]`. -Internally it is relying on loops instead of creating new arrays, which makes it -pretty performant and memory friendly. -*/ - -let forEachU: (int, int, (. int) => unit) => unit - -/** -`forEach(start, finish, action)` equivalent to `Belt.Array.forEach(Belt.Array.range(start, finish), action))` - -## Examples - -```rescript -Belt.Range.forEach(0, 4, (i) => Js.log(i)) - -// Prints: -// 0 -// 1 -// 2 -// 3 -// 4 -``` -*/ -let forEach: (int, int, int => unit) => unit - -let everyU: (int, int, (. int) => bool) => bool - -/** -`every(start, finish, p)` equivalent to `Belt.Array.every(Belt.Array.range(start, finish), p)` -## Examples - -```rescript -Belt.Range.every(0, 4, (i) => i < 5) /* true */ - -Belt.Range.every(0, 4, (i) => i < 4) /* false */ -``` -*/ -let every: (int, int, int => bool) => bool - -let everyByU: (int, int, ~step: int, (. int) => bool) => bool - -/** -`everyBy(start, finish, ~step, p)`. See `Belt.Array.rangeBy`, equivalent to -`Belt.Array.every(Belt.Array.rangeBy(start, finish, ~step), p)` - -## Examples - -```rescript -Belt.Range.everyBy(0, 4, ~step=1, (i) => mod(i, 2) === 0) /* false */ - -Belt.Range.everyBy(0, 4, ~step=2, (i) => mod(i, 2) === 0) /* true */ -``` -*/ -let everyBy: (int, int, ~step: int, int => bool) => bool - -let someU: (int, int, (. int) => bool) => bool - -/** -`some(start, finish, p)` equivalent to `Belt.Array.some(Belt.Array.range(start, finish), p)` - -## Examples - -```rescript -Belt.Range.some(0, 4, (i) => i > 5) /* false */ - -Belt.Range.some(0, 4, (i) => i > 2) /* true */ -``` -*/ -let some: (int, int, int => bool) => bool - -let someByU: (int, int, ~step: int, (. int) => bool) => bool - -/** -`someBy(start, finish, ~step, p)` See `Belt.Array.rangeBy`, equivalent to -`Belt.Array.some(Belt.Array.rangeBy(start, finish, ~step), p)` - -## Examples - -```rescript -Belt.Range.someBy(1, 5, ~step=2, (i) => mod(i, 2) === 0) /* false */ -Belt.Range.someBy(0, 4, ~step=2, (i) => mod(i, 2) === 0) /* true */ -``` -*/ -let someBy: (int, int, ~step: int, int => bool) => bool diff --git a/jscomp/others/belt_Result.res b/jscomp/others/belt_Result.res deleted file mode 100644 index a1cbba1..0000000 --- a/jscomp/others/belt_Result.res +++ /dev/null @@ -1,95 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t<'a, 'b> = result<'a, 'b> = - | Ok('a) - | Error('b) - -let getExn = x => - switch x { - | Ok(x) => x - | Error(_) => raise(Not_found) - } - -let mapWithDefaultU = (opt, default, f) => - switch opt { - | Ok(x) => f(. x) - | Error(_) => default - } - -let mapWithDefault = (opt, default, f) => mapWithDefaultU(opt, default, (. x) => f(x)) - -let mapU = (opt, f) => - switch opt { - | Ok(x) => Ok(f(. x)) - | Error(y) => Error(y) - } - -let map = (opt, f) => mapU(opt, (. x) => f(x)) - -let flatMapU = (opt, f) => - switch opt { - | Ok(x) => f(. x) - | Error(y) => Error(y) - } - -let flatMap = (opt, f) => flatMapU(opt, (. x) => f(x)) - -let getWithDefault = (opt, default) => - switch opt { - | Ok(x) => x - | Error(_) => default - } - -let isOk = x => - switch x { - | Ok(_) => true - | Error(_) => false - } - -let isError = x => - switch x { - | Ok(_) => false - | Error(_) => true - } - -let eqU = (a, b, f) => - switch (a, b) { - | (Ok(a), Ok(b)) => f(. a, b) - | (Error(_), Ok(_)) - | (Ok(_), Error(_)) => false - | (Error(_), Error(_)) => true - } - -let eq = (a, b, f) => eqU(a, b, (. x, y) => f(x, y)) - -let cmpU = (a, b, f) => - switch (a, b) { - | (Ok(a), Ok(b)) => f(. a, b) - | (Error(_), Ok(_)) => -1 - | (Ok(_), Error(_)) => 1 - | (Error(_), Error(_)) => 0 - } - -let cmp = (a, b, f) => cmpU(a, b, (. x, y) => f(x, y)) diff --git a/jscomp/others/belt_Result.resi b/jscomp/others/belt_Result.resi deleted file mode 100644 index 91e1f66..0000000 --- a/jscomp/others/belt_Result.resi +++ /dev/null @@ -1,204 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Result types are really useful to describe the result of a certain operation -without relying on exceptions or `option` types. - -This module gives you useful utilities to create and combine `Result` data. -*/ - -type t<'a, 'b> = result<'a, 'b> = - | Ok('a) - | Error('b) - -/** -`getExn(res)`: when `res` is `Ok(n)`, returns `n` when `res` is `Error(m)`, raise an exception - -## Examples - -```rescript -Belt.Result.getExn(Belt.Result.Ok(42)) == 42 - -Belt.Result.getExn(Belt.Result.Error("Invalid data")) /* raises exception */ -``` -*/ -let getExn: t<'a, 'b> => 'a - -let mapWithDefaultU: (t<'a, 'c>, 'b, (. 'a) => 'b) => 'b -/** -`mapWithDefault(res, default, f)`: When res is `Ok(n)`, returns `f(n)`, -otherwise `default`. - -## Examples - -```rescript -let ok = Belt.Result.Ok(42) -Belt.Result.mapWithDefault(ok, 0, (x) => x / 2) == 21 - -let error = Belt.Result.Error("Invalid data") -Belt.Result.mapWithDefault(error, 0, (x) => x / 2) == 0 -``` -*/ -let mapWithDefault: (t<'a, 'c>, 'b, 'a => 'b) => 'b - -let mapU: (t<'a, 'c>, (. 'a) => 'b) => t<'b, 'c> -/** -`map(res, f)`: When res is `Ok(n)`, returns `Ok(f(n))`. Otherwise returns res -unchanged. Function `f` takes a value of the same type as `n` and returns an -ordinary value. - -## Examples - -```rescript -let f = (x) => sqrt(Belt.Int.toFloat(x)) - -Belt.Result.map(Ok(64), f) == Ok(8.0) - -Belt.Result.map(Error("Invalid data"), f) == Error("Invalid data") -``` -*/ -let map: (t<'a, 'c>, 'a => 'b) => t<'b, 'c> - -let flatMapU: (t<'a, 'c>, (. 'a) => t<'b, 'c>) => t<'b, 'c> -/** -`flatMap(res, f)`: When res is `Ok(n)`, returns `f(n)`. Otherwise, returns res -unchanged. Function `f` takes a value of the same type as `n` and returns a -`Belt.Result`. - -## Examples - -```rescript -let recip = (x) => - if (x !== 0.0) { - Belt.Result.Ok(1.0 /. x) - } else { - Belt.Result.Error("Divide by zero") - } - -Belt.Result.flatMap(Ok(2.0), recip) == Ok(0.5) - -Belt.Result.flatMap(Ok(0.0), recip) == Error("Divide by zero") - -Belt.Result.flatMap(Error("Already bad"), recip) == Error("Already bad") -``` -*/ -let flatMap: (t<'a, 'c>, 'a => t<'b, 'c>) => t<'b, 'c> - -/** -`getWithDefault(res, defaultValue)`: If `res` is `Ok(n)`, returns `n`, -otherwise `default` - -## Examples - -```rescript -Belt.Result.getWithDefault(Ok(42), 0) == 42 - -Belt.Result.getWithDefault(Error("Invalid Data"), 0) == 0 -``` -*/ -let getWithDefault: (t<'a, 'b>, 'a) => 'a - -/** -`isOk(res)`: Returns `true` if `res` is of the form `Ok(n)`, `false` if it is -the `Error(e)` variant. -*/ -let isOk: t<'a, 'b> => bool - -/** -`isError(res)`: Returns `true` if `res` is of the form `Error(e)`, `false` if -it is the `Ok(n)` variant. -*/ -let isError: t<'a, 'b> => bool - -let eqU: (t<'a, 'c>, t<'b, 'd>, (. 'a, 'b) => bool) => bool -/** -`eq(res1, res2, f)`: Determine if two `Belt.Result` variables are equal with -respect to an equality function. If `res1` and `res2` are of the form `Ok(n)` -and `Ok(m)`, return the result of `f(n, m)`. If one of `res1` and `res2` are of -the form `Error(e)`, return false If both `res1` and `res2` are of the form -`Error(e)`, return true - -## Examples - -```rescript -let good1 = Belt.Result.Ok(42) - -let good2 = Belt.Result.Ok(32) - -let bad1 = Belt.Result.Error("invalid") - -let bad2 = Belt.Result.Error("really invalid") - -let mod10equal = (a, b) => mod(a, 10) === mod(b, 10) - -Belt.Result.eq(good1, good2, mod10equal) == true - -Belt.Result.eq(good1, bad1, mod10equal) == false - -Belt.Result.eq(bad2, good2, mod10equal) == false - -Belt.Result.eq(bad1, bad2, mod10equal) == true -``` -*/ -let eq: (t<'a, 'c>, t<'b, 'd>, ('a, 'b) => bool) => bool - -let cmpU: (t<'a, 'c>, t<'b, 'd>, (. 'a, 'b) => int) => int -/** -`cmp(res1, res2, f)`: Compare two `Belt.Result` variables with respect to a -comparison function. The comparison function returns -1 if the first variable -is "less than" the second, 0 if the two variables are equal, and 1 if the first -is "greater than" the second. - -If `res1` and `res2` are of the form `Ok(n)` and `Ok(m)`, return the result of -`f(n, m)`. If `res1` is of the form `Error(e)` and `res2` of the form `Ok(n)`, -return -1 (nothing is less than something) If `res1` is of the form `Ok(n)` and -`res2` of the form `Error(e)`, return 1 (something is greater than nothing) If -both `res1` and `res2` are of the form `Error(e)`, return 0 (equal) - -## Examples - -```rescript -let good1 = Belt.Result.Ok(59) - -let good2 = Belt.Result.Ok(37) - -let bad1 = Belt.Result.Error("invalid") - -let bad2 = Belt.Result.Error("really invalid") - -let mod10cmp = (a, b) => Pervasives.compare(mod(a, 10), mod(b, 10)) - -Belt.Result.cmp(Ok(39), Ok(57), mod10cmp) == 1 - -Belt.Result.cmp(Ok(57), Ok(39), mod10cmp) == (-1) - -Belt.Result.cmp(Ok(39), Error("y"), mod10cmp) == 1 - -Belt.Result.cmp(Error("x"), Ok(57), mod10cmp) == (-1) - -Belt.Result.cmp(Error("x"), Error("y"), mod10cmp) == 0 -``` -*/ -let cmp: (t<'a, 'c>, t<'b, 'd>, ('a, 'b) => int) => int diff --git a/jscomp/others/belt_Set.cppo.res b/jscomp/others/belt_Set.cppo.res deleted file mode 100644 index 2ef4124..0000000 --- a/jscomp/others/belt_Set.cppo.res +++ /dev/null @@ -1,233 +0,0 @@ -#ifdef TYPE_INT -module I = Belt_internalSetInt -#elif defined TYPE_STRING -module I = Belt_internalSetString -#else -[%error "unknown type"] -#endif - -module N = Belt_internalAVLset -module A = Belt_Array - -type value = I.value -type t = I.t - -let empty = None -let isEmpty = N.isEmpty -let minimum = N.minimum -let minUndefined = N.minUndefined -let maximum = N.maximum -let maxUndefined = N.maxUndefined - -let forEach = N.forEach -let forEachU = N.forEachU -let reduce = N.reduce -let reduceU = N.reduceU -let every = N.every -let everyU = N.everyU -let some = N.some -let someU = N.someU -let keep = N.keepShared -let keepU = N.keepSharedU -let partition = N.partitionShared -let partitionU = N.partitionSharedU - -let size = N.size -let toList = N.toList -let toArray = N.toArray -let fromSortedArrayUnsafe = N.fromSortedArrayUnsafe -let checkInvariantInternal = N.checkInvariantInternal - -let rec add = (t: t, x: value): t => - switch t { - | None => N.singleton(x) - | Some(nt) => - let v = nt.value - if x == v { - t - } else { - let {N.left: l, right: r} = nt - if x < v { - let ll = add(l, x) - if ll === l { - t - } else { - N.bal(ll, v, r) - } - } else { - let rr = add(r, x) - if rr === r { - t - } else { - N.bal(l, v, rr) - } - } - } - } - -let mergeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = add(v.contents, key) - } - v.contents -} - -let rec remove = (t: t, x: value): t => - switch t { - | None => t - | Some(n) => - let {N.left: l, value: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let v = ref(rn.value) - let r = N.removeMinAuxWithRef(rn, v) - N.bal(l, v.contents, r) - } - } else if x < v { - let ll = remove(l, x) - if ll === l { - t - } else { - N.bal(ll, v, r) - } - } else { - let rr = remove(r, x) - if rr === r { - t - } else { - N.bal(l, v, rr) - } - } - } - -let removeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = remove(v.contents, key) - } - v.contents -} - -let fromArray = I.fromArray -let cmp = I.cmp -let eq = I.eq -let get = I.get -let getUndefined = I.getUndefined -let getExn = I.getExn -let subset = I.subset -let has = I.has - -let rec splitAuxNoPivot = (n: N.node<_>, x: value): (t, t) => { - let {N.left: l, value: v, right: r} = n - if x == v { - (l, r) - } else if x < v { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxNoPivot(l, x) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxNoPivot(r, x) - (N.joinShared(l, v, lr), rr) - } - } -} - -let rec splitAuxPivot = (n: N.node<_>, x: value, pres): (t, t) => { - let {N.left: l, value: v, right: r} = n - if x == v { - pres.contents = true - (l, r) - } else if x < v { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxPivot(l, x, pres) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxPivot(r, x, pres) - (N.joinShared(l, v, lr), rr) - } - } -} - -let split = (t: t, x: value) => - switch t { - | None => ((None, None), false) - | Some(n) => - let pres = ref(false) - let v = splitAuxPivot(n, x, pres) - (v, pres.contents) - } - -let rec union = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) => s2 - | (_, None) => s1 - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) */ => - let (h1, h2) = (n1.height, n2.height) - if h1 >= h2 { - if h2 == 1 { - add(s1, n2.value) - } else { - let {N.left: l1, value: v1, right: r1} = n1 - let (l2, r2) = splitAuxNoPivot(n2, v1) - N.joinShared(union(l1, l2), v1, union(r1, r2)) - } - } else if h1 == 1 { - add(s2, n1.value) - } else { - let {N.left: l2, value: v2, right: r2} = n2 - let (l1, r1) = splitAuxNoPivot(n1, v2) - N.joinShared(union(l1, l2), v2, union(r1, r2)) - } - } - -let rec intersect = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) | (_, None) => None - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, _), t2) */ => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(n2, v1, pres) - let ll = intersect(l1, l2) - let rr = intersect(r1, r2) - if pres.contents { - N.joinShared(ll, v1, rr) - } else { - N.concatShared(ll, rr) - } - } - -let rec diff = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) | (_, None) => s1 - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, _), t2) */ => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(n2, v1, pres) - let ll = diff(l1, l2) - let rr = diff(r1, r2) - if pres.contents { - N.concatShared(ll, rr) - } else { - N.joinShared(ll, v1, rr) - } - } diff --git a/jscomp/others/belt_Set.cppo.resi b/jscomp/others/belt_Set.cppo.resi deleted file mode 100644 index 6871bd3..0000000 --- a/jscomp/others/belt_Set.cppo.resi +++ /dev/null @@ -1,169 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** - This module is [`Belt.Set`]() specialized with value type to be a primitive type. - It is more efficient in general, the API is the same with [`Belt_Set`]() except its value type is fixed, - and identity is not needed(using the built-in one) - - **See** [`Belt.Set`]() -*/ - -#ifdef TYPE_STRING -/** The type of the set elements. */ -type value = string -#elif defined TYPE_INT -/** The type of the set elements. */ -type value = int -#else -[%error "unknown type"] -#endif - -/** The type of sets. */ -type t - -let empty: t - -let fromArray: array => t - -let fromSortedArrayUnsafe: array => t - -let isEmpty: t => bool - -let has: (t, value) => bool - -/** -`add(s, x)` If `x` was already in `s`, `s` is returned unchanged. -*/ -let add: (t, value) => t - -let mergeMany: (t, array) => t - -/** -`remove(m, x)` If `x` was not in `m`, `m` is returned reference unchanged. -*/ -let remove: (t, value) => t - -let removeMany: (t, array) => t - -let union: (t, t) => t - -let intersect: (t, t) => t - -let diff: (t, t) => t - -/** -`subset(s1, s2)` tests whether the set `s1` is a subset of the set `s2`. -*/ -let subset: (t, t) => bool - -/** -Total ordering between sets. Can be used as the ordering function for doing sets -of sets. -*/ -let cmp: (t, t) => int - -/** -`eq(s1, s2)` tests whether the sets `s1` and `s2` are equal, that is, contain -equal elements. -*/ -let eq: (t, t) => bool - -let forEachU: (t, (. value) => unit) => unit - -/** -`forEach(s, f)` applies `f` in turn to all elements of `s`. In increasing order -*/ -let forEach: (t, value => unit) => unit - -let reduceU: (t, 'a, (. 'a, value) => 'a) => 'a - -/** Iterate in increasing order. */ -let reduce: (t, 'a, ('a, value) => 'a) => 'a - -let everyU: (t, (. value) => bool) => bool - -/** -`every(p, s)` checks if all elements of the set satisfy the predicate `p`. Order -unspecified. -*/ -let every: (t, value => bool) => bool - -let someU: (t, (. value) => bool) => bool - -/** -`some(p, s)` checks if at least one element of the set satisfies the predicate -`p`. Oder unspecified. -*/ -let some: (t, value => bool) => bool - -let keepU: (t, (. value) => bool) => t - -/** -`keep(p, s)` returns the set of all elements in `s` that satisfy predicate `p`. -*/ -let keep: (t, value => bool) => t - -let partitionU: (t, (. value) => bool) => (t, t) - -/** -`partition(p, s)` returns a pair of sets `(s1, s2)`, where `s1` is the set of -all the elements of `s` that satisfy the predicate `p`, and `s2` is the set of -all the elements of `s` that do not satisfy `p`. -*/ -let partition: (t, value => bool) => (t, t) - -let size: t => int - -/** In increasing order */ -let toList: t => list - -let toArray: t => array - -let minimum: t => option - -let minUndefined: t => Js.undefined - -let maximum: t => option - -let maxUndefined: t => Js.undefined - -let get: (t, value) => option - -let getUndefined: (t, value) => Js.undefined - -let getExn: (t, value) => value - -/** -`split(x, s)` returns a triple `(l, present, r)`, where `l` is the set of -elements of `s` that are strictly less than `x`;`r` is the set of elements of -`s` that are strictly greater than `x`; `present` is `false` if `s` contains no -element equal to `x`, or `true` if `s` contains an element equal to `x`. -*/ -let split: (t, value) => ((t, t), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t => unit diff --git a/jscomp/others/belt_Set.res b/jscomp/others/belt_Set.res deleted file mode 100644 index 612a9fd..0000000 --- a/jscomp/others/belt_Set.res +++ /dev/null @@ -1,164 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Int = Belt_SetInt -module String = Belt_SetString -module Dict = Belt_SetDict - -type id<'value, 'id> = Belt_Id.comparable<'value, 'id> -type cmp<'value, 'id> = Belt_Id.cmp<'value, 'id> - -type t<'value, 'id> = { - cmp: cmp<'value, 'id>, - data: Dict.t<'value, 'id>, -} - -let fromArray = (type value identity, data, ~id: id) => { - module M = unpack(id) - let cmp = M.cmp - {cmp, data: Dict.fromArray(~cmp, data)} -} - -let remove = (m, e) => { - let {cmp, data} = m - let newData = Dict.remove(~cmp, data, e) - if newData === data { - m - } else { - {cmp, data: newData} - } -} - -let add = (m, e) => { - let {cmp, data} = m - let newData = Dict.add(~cmp, data, e) - if newData === data { - m - } else { - {cmp, data: newData} - } -} - -let mergeMany = ({cmp} as m, e) => {cmp, data: Dict.mergeMany(~cmp, m.data, e)} - -let removeMany = ({cmp} as m, e) => {cmp, data: Dict.removeMany(~cmp, m.data, e)} - -let union = ({cmp} as m, n) => {data: Dict.union(~cmp, m.data, n.data), cmp} - -let intersect = (m, n) => { - let cmp = m.cmp - {data: Dict.intersect(~cmp, m.data, n.data), cmp} -} - -let diff = (m, n) => { - let cmp = m.cmp - {cmp, data: Dict.diff(~cmp, m.data, n.data)} -} - -let subset = (m, n) => { - let cmp = m.cmp - Dict.subset(~cmp, m.data, n.data) -} - -let split = (m, e) => { - let cmp = m.cmp - let ((l, r), b) = Dict.split(~cmp, m.data, e) - (({cmp, data: l}, {cmp, data: r}), b) -} - -let make = (type value identity, ~id: id) => { - module M = unpack(id) - {cmp: M.cmp, data: Dict.empty} -} - -let isEmpty = m => Dict.isEmpty(m.data) - -let cmp = (m, n) => { - let cmp = m.cmp - Dict.cmp(~cmp, m.data, n.data) -} - -let eq = (m, n) => Dict.eq(~cmp=m.cmp, m.data, n.data) - -let forEachU = (m, f) => Dict.forEachU(m.data, f) -let forEach = (m, f) => forEachU(m, (. a) => f(a)) - -let reduceU = (m, acc, f) => Dict.reduceU(m.data, acc, f) -let reduce = (m, acc, f) => reduceU(m, acc, (. a, b) => f(a, b)) - -let everyU = (m, f) => Dict.everyU(m.data, f) -let every = (m, f) => everyU(m, (. a) => f(a)) - -let someU = (m, f) => Dict.someU(m.data, f) -let some = (m, f) => someU(m, (. a) => f(a)) - -let keepU = (m, f) => {cmp: m.cmp, data: Dict.keepU(m.data, f)} -let keep = (m, f) => keepU(m, (. a) => f(a)) - -let partitionU = (m, f) => { - let (l, r) = Dict.partitionU(m.data, f) - let cmp = m.cmp - ({data: l, cmp}, {data: r, cmp}) -} -let partition = (m, f) => partitionU(m, (. a) => f(a)) - -let size = m => Dict.size(m.data) -let toList = m => Dict.toList(m.data) -let toArray = m => Dict.toArray(m.data) - -let minimum = m => Dict.minimum(m.data) -let minUndefined = m => Dict.minUndefined(m.data) -let maximum = m => Dict.maximum(m.data) -let maxUndefined = m => Dict.maxUndefined(m.data) - -let get = (m, e) => Dict.get(~cmp=m.cmp, m.data, e) - -let getUndefined = (m, e) => Dict.getUndefined(~cmp=m.cmp, m.data, e) - -let getExn = (m, e) => Dict.getExn(~cmp=m.cmp, m.data, e) - -let has = (m, e) => Dict.has(~cmp=m.cmp, m.data, e) - -let fromSortedArrayUnsafe = (type value identity, xs, ~id: id) => { - module M = unpack(id) - {cmp: M.cmp, data: Dict.fromSortedArrayUnsafe(xs)} -} - -let getData = m => m.data - -let getId = (type value identity, m: t): id => { - module T = { - type identity = identity - type t = value - let cmp = m.cmp - } - module(T) -} - -let packIdData = (type value identity, ~id: id, ~data) => { - module M = unpack(id) - {cmp: M.cmp, data} -} - -let checkInvariantInternal = d => Dict.checkInvariantInternal(d.data) diff --git a/jscomp/others/belt_Set.resi b/jscomp/others/belt_Set.resi deleted file mode 100644 index a7b8e00..0000000 --- a/jscomp/others/belt_Set.resi +++ /dev/null @@ -1,575 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -An _immutable_ sorted set module which allows customized _compare_ behavior. - -The implementation uses balanced binary trees, and therefore searching -and insertion take time logarithmic in the size of the map. - -For more info on this module's usage of identity, `make` and others, please see -the top level documentation of Belt, **A special encoding for collection safety**. - -## Examples - -```rescript -module PairComparator = - Belt.Id.MakeComparable({ - type t = (int, int) - let cmp = ((a0, a1), (b0, b1)) => - switch (Pervasives.compare(a0, b0)) { - | 0 => Pervasives.compare(a1, b1) - | c => c - } - }) - -let mySet = Belt.Set.make(~id=module(PairComparator)) -let mySet2 = Belt.Set.add(mySet, (1, 2)) -``` - -**Note:** This module's examples will assume a predeclared module for integers -called `IntCmp`. It is declared like this: - -```rescript -module IntCmp = - Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare - }) -``` -*/ - -/** -Specialized when value type is `int`, more efficient than the generic type, its -compare behavior is fixed using the built-in comparison -*/ -module Int = Belt_SetInt - -/** -Specialized when value type is `string`, more efficient than the generic type, -its compare behavior is fixed using the built-in comparison -*/ -module String = Belt_SetString - -/** -This module separates identity from data, it is a bit more verbose but slightly -more efficient due to the fact that there is no need to pack identity and data back -after each operation -*/ -module Dict = Belt_SetDict - -/** -`'value` is the element type - -`'identity` the identity of the collection -*/ -type t<'value, 'identity> - -/** -The identity needed for making a set from scratch -*/ -type id<'value, 'id> = Belt_Id.comparable<'value, 'id> - -/** -Creates a new set by taking in the comparator - -## Examples - -```rescript -let set = Belt.Set.make(~id=module(IntCmp)) -``` -*/ -let make: (~id: id<'value, 'id>) => t<'value, 'id> - -/** -Creates new set from array of elements. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([1, 3, 2, 4], ~id=module(IntCmp)) - -s0->Belt.Set.toArray /* [1, 2, 3, 4] */ -``` -*/ -let fromArray: (array<'value>, ~id: id<'value, 'id>) => t<'value, 'id> - -/** -The same as [fromArray][#fromarray] except it is after assuming the input array -is already sorted. -*/ -let fromSortedArrayUnsafe: (array<'value>, ~id: id<'value, 'id>) => t<'value, 'id> - -/** -Checks if set is empty. - -## Examples - -```rescript -let empty = Belt.Set.fromArray([], ~id=module(IntCmp)) -let notEmpty = Belt.Set.fromArray([1],~id=module(IntCmp)) - -Belt.Set.isEmpty(empty) /* true */ -Belt.Set.isEmpty(notEmpty) /* false */ -``` -*/ -let isEmpty: t<_> => bool - -/** -Checks if element exists in set. - -## Examples - -```rescript -let set = Belt.Set.fromArray([1, 4, 2, 5], ~id=module(IntCmp)) - -set->Belt.Set.has(3) /* false */ -set->Belt.Set.has(1) /* true */ -``` -*/ -let has: (t<'value, 'id>, 'value) => bool - -/** -Adds element to set. If element existed in set, value is unchanged. - -## Examples - -```rescript -let s0 = Belt.Set.make(~id=module(IntCmp)) -let s1 = s0->Belt.Set.add(1) -let s2 = s1->Belt.Set.add(2) -let s3 = s2->Belt.Set.add(2) -s0->Belt.Set.toArray /* [] */ -s1->Belt.Set.toArray /* [1] */ -s2->Belt.Set.toArray /* [1, 2] */ -s3->Belt.Set.toArray /* [1,2 ] */ -s2 == s3 /* true */ -``` -*/ -let add: (t<'value, 'id>, 'value) => t<'value, 'id> - -/** -Adds each element of array to set. Unlike `Belt.Set.add`](#add), the reference of return value might be changed even if all values in array already exist in set - -## Examples - -```rescript -let set = Belt.Set.make(~id=module(IntCmp)) - -let newSet = set->Belt.Set.mergeMany([5, 4, 3, 2, 1]) -newSet->Belt.Set.toArray /* [1, 2, 3, 4, 5] */ -``` -*/ -let mergeMany: (t<'value, 'id>, array<'value>) => t<'value, 'id> - -/** -Removes element from set. If element did not exist in set, value is unchanged. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([2,3,1,4,5], ~id=module(IntCmp)) -let s1 = s0->Belt.Set.remove(1) -let s2 = s1->Belt.Set.remove(3) -let s3 = s2->Belt.Set.remove(3) - -s1->Belt.Set.toArray /* [2,3,4,5] */ -s2->Belt.Set.toArray /* [2,4,5] */ -s2 == s3 /* true */ -``` -*/ -let remove: (t<'value, 'id>, 'value) => t<'value, 'id> - -/** -Removes each element of array from set. Unlike [remove](#remove), the reference of return value might be changed even if none of values in array existed in set. - -## Examples - -```rescript -let set = Belt.Set.fromArray([1, 2, 3, 4],~id=module(IntCmp)) - -let newSet = set->Belt.Set.removeMany([5, 4, 3, 2, 1]) -newSet->Belt.Set.toArray /* [] */ -``` -*/ -let removeMany: (t<'value, 'id>, array<'value>) => t<'value, 'id> - -/** - Returns union of two sets. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([5,2,3,5,6], ~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([5,2,3,1,5,4], ~id=module(IntCmp)) -let union = Belt.Set.union(s0, s1) -union->Belt.Set.toArray /* [1,2,3,4,5,6] */ -``` -*/ -let union: (t<'value, 'id>, t<'value, 'id>) => t<'value, 'id> - -/** -Returns intersection of two sets. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([5,2,3,5,6], ~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([5,2,3,1,5,4], ~id=module(IntCmp)) -let intersect = Belt.Set.intersect(s0, s1) -intersect->Belt.Set.toArray /* [2,3,5] */ -``` -*/ -let intersect: (t<'value, 'id>, t<'value, 'id>) => t<'value, 'id> - -/** -Returns elements from first set, not existing in second set. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([5,2,3,5,6], ~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([5,2,3,1,5,4], ~id=module(IntCmp)) -Belt.Set.toArray(Belt.Set.diff(s0, s1)) /* [6] */ -Belt.Set.toArray(Belt.Set.diff(s1,s0)) /* [1,4] */ -``` -*/ -let diff: (t<'value, 'id>, t<'value, 'id>) => t<'value, 'id> - -/** -Checks if second set is subset of first set. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([5,2,3,5,6], ~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([5,2,3,1,5,4], ~id=module(IntCmp)) -let s2 = Belt.Set.intersect(s0, s1) -Belt.Set.subset(s2, s0) /* true */ -Belt.Set.subset(s2, s1) /* true */ -Belt.Set.subset(s1, s0) /* false */ -``` -*/ -let subset: (t<'value, 'id>, t<'value, 'id>) => bool - -/** -Total ordering between sets. Can be used as the ordering function for doing sets -of sets. It compares size first and then iterates over each element following -the order of elements. -*/ -let cmp: (t<'value, 'id>, t<'value, 'id>) => int - -/** -Checks if two sets are equal. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([5,2,3], ~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([3,2,5], ~id=module(IntCmp)) - -Belt.Set.eq(s0, s1) /* true */ -``` -*/ -let eq: (t<'value, 'id>, t<'value, 'id>) => bool - -/** -Same as [forEach](#forEach) but takes uncurried functon. -*/ -let forEachU: (t<'value, 'id>, (. 'value) => unit) => unit - -/** -Applies function `f` in turn to all elements of set in increasing order. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([5,2,3,5,6], ~id=module(IntCmp)) -let acc = ref(list{}) -s0->Belt.Set.forEach(x => { - acc := Belt.List.add(acc.contents, x) -}) -acc /* [6,5,3,2] */ -``` -*/ -let forEach: (t<'value, 'id>, 'value => unit) => unit - -let reduceU: (t<'value, 'id>, 'a, (. 'a, 'value) => 'a) => 'a - -/** -Applies function `f` to each element of set in increasing order. Function `f` has two parameters: the item from the set and an “accumulator”, which starts with a value of `initialValue`. `reduce` returns the final value of the accumulator. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([5,2,3,5,6], ~id=module(IntCmp)) -s0->Belt.Set.reduce(list{}, (acc, element) => - acc->Belt.List.add(element) -) /* [6,5,3,2] */ -``` -*/ -let reduce: (t<'value, 'id>, 'a, ('a, 'value) => 'a) => 'a - -let everyU: (t<'value, 'id>, (. 'value) => bool) => bool - -/** -Checks if all elements of the set satisfy the predicate. Order unspecified. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -let s0 = Belt.Set.fromArray([2,4,6,8], ~id=module(IntCmp)) -s0->Belt.Set.every(isEven) /* true */ -``` -*/ -let every: (t<'value, 'id>, 'value => bool) => bool - -let someU: (t<'value, 'id>, (. 'value) => bool) => bool - -/** -Checks if at least one element of the set satisfies the predicate. - -## Examples - -```rescript -let isOdd = x => mod(x, 2) != 0 - -let s0 = Belt.Set.fromArray([1,2,4,6,8], ~id=module(IntCmp)) -s0->Belt.Set.some(isOdd) /* true */ -``` -*/ -let some: (t<'value, 'id>, 'value => bool) => bool - -let keepU: (t<'value, 'id>, (. 'value) => bool) => t<'value, 'id> - -/** -Returns the set of all elements that satisfy the predicate. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -let s0 = Belt.Set.fromArray([1,2,3,4,5], ~id=module(IntCmp)) -let s1 = s0->Belt.Set.keep(isEven) - -s1->Belt.Set.toArray /* [2,4] */ -``` -*/ -let keep: (t<'value, 'id>, 'value => bool) => t<'value, 'id> - -let partitionU: (t<'value, 'id>, (. 'value) => bool) => (t<'value, 'id>, t<'value, 'id>) - -/** -Returns a pair of sets, where first is the set of all the elements of set that satisfy the predicate, and second is the set of all the elements of set that do not satisfy the predicate. - -## Examples - -```rescript -let isOdd = x => mod(x, 2) != 0 - -let s0 = Belt.Set.fromArray([1,2,3,4,5], ~id=module(IntCmp)) -let (s1, s2) = s0->Belt.Set.partition(isOdd) - -s1->Belt.Set.toArray /* [1,3,5] */ -s2->Belt.Set.toArray /* [2,4] */ -``` -*/ -let partition: (t<'value, 'id>, 'value => bool) => (t<'value, 'id>, t<'value, 'id>) - -/** -Returns size of the set. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([1,2,3,4], ~id=module(IntCmp)) - -s0->Belt.Set.size /* 4 */ -``` -*/ -let size: t<'value, 'id> => int - -/** -Returns array of ordered set elements. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([3,2,1,5], ~id=module(IntCmp)) - -s0->Belt.Set.toArray /* [1,2,3,5] */ -``` -*/ -let toArray: t<'value, 'id> => array<'value> - -/** -Returns list of ordered set elements. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([3,2,1,5], ~id=module(IntCmp)) - -s0->Belt.Set.toList /* [1,2,3,5] */ -``` -*/ -let toList: t<'value, 'id> => list<'value> - -/** -Returns minimum value of the collection. `None` if collection is empty. - -## Examples - -```rescript -let s0 = Belt.Set.make(~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([3,2,1,5], ~id=module(IntCmp)) - -s0->Belt.Set.minimum /* None */ -s1->Belt.Set.minimum /* Some(1) */ -``` -*/ -let minimum: t<'value, 'id> => option<'value> - -/** -Returns minimum value of the collection. `undefined` if collection is empty. - -## Examples - -```rescript -let s0 = Belt.Set.make(~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([3,2,1,5], ~id=module(IntCmp)) - -s0->Belt.Set.minUndefined /* undefined */ -s1->Belt.Set.minUndefined /* 1 */ -``` -*/ -let minUndefined: t<'value, 'id> => Js.undefined<'value> - -/** -Returns maximum value of the collection. `None` if collection is empty. - -## Examples - -```rescript -let s0 = Belt.Set.make(~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([3,2,1,5], ~id=module(IntCmp)) - -s0->Belt.Set.maximum /* None */ -s1->Belt.Set.maximum /* Some(5) */ -``` -*/ -let maximum: t<'value, 'id> => option<'value> - -/** -Returns maximum value of the collection. `undefined` if collection is empty. - -## Examples - -```rescript -let s0 = Belt.Set.make(~id=module(IntCmp)) -let s1 = Belt.Set.fromArray([3,2,1,5], ~id=module(IntCmp)) - -s0->Belt.Set.maxUndefined /* undefined */ -s1->Belt.Set.maxUndefined /* 5 */ -``` -*/ -let maxUndefined: t<'value, 'id> => Js.undefined<'value> - -/** -Returns the reference of the value which is equivalent to value using the comparator specifiecd by this collection. Returns `None` if element does not exist. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([1,2,3,4,5], ~id=module(IntCmp)) - -s0->Belt.Set.get(3) /* Some(3) */ -s0->Belt.Set.get(20) /* None */ -``` -*/ -let get: (t<'value, 'id>, 'value) => option<'value> - -/** -Same as [get](#get) but returns `undefined` when element does not exist. -*/ -let getUndefined: (t<'value, 'id>, 'value) => Js.undefined<'value> - -/** -Same as [get](#get) but raise when element does not exist. -*/ -let getExn: (t<'value, 'id>, 'value) => 'value - -/** -Returns a tuple `((smaller, larger), present)`, `present` is true when element exist in set. - -## Examples - -```rescript -let s0 = Belt.Set.fromArray([1,2,3,4,5], ~id=module(IntCmp)) - -let ((smaller, larger), present) = s0->Belt.Set.split(3) - -present /* true */ -smaller->Belt.Set.toArray /* [1,2] */ -larger->Belt.Set.toArray /* [4,5] */ - -``` -*/ -let split: (t<'value, 'id>, 'value) => ((t<'value, 'id>, t<'value, 'id>), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/* ************************************************************************** - Below are operations only when better performance needed, - it is still safe API but more verbose. - More API will be exposed by needs -*/ - -/** -**Advanced usage only** - -Returns the raw data (detached from comparator), but its type is still manifested, -so that user can pass identity directly without boxing. -*/ -let getData: t<'value, 'id> => Belt_SetDict.t<'value, 'id> - -/** -**Advanced usage only** - -Returns the identity of set. -*/ -let getId: t<'value, 'id> => id<'value, 'id> - -/** -**Advanced usage only** - -Returns the packed collection. -*/ -let packIdData: (~id: id<'value, 'id>, ~data: Belt_SetDict.t<'value, 'id>) => t<'value, 'id> diff --git a/jscomp/others/belt_SetDict.res b/jscomp/others/belt_SetDict.res deleted file mode 100644 index 0a9a59b..0000000 --- a/jscomp/others/belt_SetDict.res +++ /dev/null @@ -1,264 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module N = Belt_internalAVLset -module A = Belt_Array - -type t<'k, 'id> = N.t<'k> - -type cmp<'key, 'id> = Belt_Id.cmp<'key, 'id> - -/* here we relies on reference transparence - address equality means everything equal across time - no need to call `bal` again -*/ -let rec add = (t: t<_>, x, ~cmp): t<_> => - switch t { - | None => N.singleton(x) - | Some(nt) => - let k = nt.value - let c = Belt_Id.getCmpInternal(cmp)(. x, k) - if c == 0 { - t - } else { - let {N.left: l, right: r} = nt - if c < 0 { - let ll = add(~cmp, l, x) - if ll === l { - t - } else { - N.bal(ll, k, r) - } - } else { - let rr = add(~cmp, r, x) - if rr === r { - t - } else { - N.bal(l, k, rr) - } - } - } - } - -let rec remove = (t: t<_>, x, ~cmp): t<_> => - switch t { - | None => t - | Some(n) => - let {N.left: l, value: v, right: r} = n - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let v = ref(rn.value) - let r = N.removeMinAuxWithRef(rn, v) - N.bal(l, v.contents, r) - } - } else if c < 0 { - let ll = remove(~cmp, l, x) - if ll === l { - t - } else { - N.bal(ll, v, r) - } - } else { - let rr = remove(~cmp, r, x) - if rr === r { - t - } else { - N.bal(l, v, rr) - } - } - } - -let mergeMany = (h, arr, ~cmp) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = add(v.contents, ~cmp, key) - } - v.contents -} - -let removeMany = (h, arr, ~cmp) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = remove(v.contents, ~cmp, key) - } - v.contents -} - -let rec splitAuxNoPivot = (~cmp, n: N.node<_>, x): (_, _) => { - let {N.left: l, value: v, right: r} = n - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - (l, r) - } else if c < 0 { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxNoPivot(~cmp, l, x) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxNoPivot(~cmp, r, x) - (N.joinShared(l, v, lr), rr) - } - } -} - -let rec splitAuxPivot = (~cmp, n: N.node<_>, x, pres): (_, _) => { - let {N.left: l, value: v, right: r} = n - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - pres.contents = true - (l, r) - } else if c < 0 { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxPivot(~cmp, l, x, pres) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxPivot(~cmp, r, x, pres) - (N.joinShared(l, v, lr), rr) - } - } -} - -let split = (t: t<_>, x, ~cmp) => - switch t { - | None => ((None, None), false) - | Some(n) => - let pres = ref(false) - let v = splitAuxPivot(~cmp, n, x, pres) - (v, pres.contents) - } - -/* `union s1 s2` - Use the pivot to split the smaller collection -*/ -let rec union = (s1: t<_>, s2: t<_>, ~cmp): t<_> => - switch (s1, s2) { - | (None, _) => s2 - | (_, None) => s1 - | (Some(n1), Some(n2)) => - let (h1, h2) = (n1.height, n2.height) - if h1 >= h2 { - if h2 == 1 { - add(~cmp, s1, n2.value) - } else { - let {N.left: l1, value: v1, right: r1} = n1 - let (l2, r2) = splitAuxNoPivot(~cmp, n2, v1) - N.joinShared(union(~cmp, l1, l2), v1, union(~cmp, r1, r2)) - } - } else if h1 == 1 { - add(s2, ~cmp, n1.value) - } else { - let {N.left: l2, value: v2, right: r2} = n2 - let (l1, r1) = splitAuxNoPivot(~cmp, n1, v2) - N.joinShared(union(~cmp, l1, l2), v2, union(~cmp, r1, r2)) - } - } - -let rec intersect = (s1: t<_>, s2: t<_>, ~cmp) => - switch (s1, s2) { - | (None, _) - | (_, None) => - None - | (Some(n1), Some(n2)) => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(~cmp, n2, v1, pres) - let ll = intersect(~cmp, l1, l2) - let rr = intersect(~cmp, r1, r2) - if pres.contents { - N.joinShared(ll, v1, rr) - } else { - N.concatShared(ll, rr) - } - } - -let rec diff = (s1, s2, ~cmp) => - switch (s1, s2) { - | (None, _) - | (_, None) => s1 - | (Some(n1), Some(n2)) => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(~cmp, n2, v1, pres) - let ll = diff(~cmp, l1, l2) - let rr = diff(~cmp, r1, r2) - if pres.contents { - N.concatShared(ll, rr) - } else { - N.joinShared(ll, v1, rr) - } - } - -let empty = None -let fromArray = N.fromArray -let isEmpty = N.isEmpty - -let cmp = N.cmp -let eq = N.eq -let has = N.has -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let everyU = N.everyU -let every = N.every -let someU = N.someU -let some = N.some -let size = N.size -let toList = N.toList -let toArray = N.toArray -let minimum = N.minimum -let maximum = N.maximum -let maxUndefined = N.maxUndefined -let minUndefined = N.minUndefined -let get = N.get -let getExn = N.getExn -let getUndefined = N.getUndefined - -let fromSortedArrayUnsafe = N.fromSortedArrayUnsafe -let subset = N.subset -let keep = N.keepShared -let keepU = N.keepSharedU -let partitionU = N.partitionSharedU -let partition = N.partitionShared - -let checkInvariantInternal = N.checkInvariantInternal diff --git a/jscomp/others/belt_SetDict.resi b/jscomp/others/belt_SetDict.resi deleted file mode 100644 index 4f740a6..0000000 --- a/jscomp/others/belt_SetDict.resi +++ /dev/null @@ -1,633 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module separates identity from data. It is a bit more verbose but slightly -more efficient due to the fact that there is no need to pack identity and data -back after each operation. -*/ - -/** -`'value` is the element type - -`'identity` the identity of the collection -*/ -type t<'value, 'identity> - -/** -Type of compare function. -*/ -type cmp<'value, 'id> = Belt_Id.cmp<'value, 'id> - -/** -## Examples - -```rescript -let s0 = Belt.Set.Dict.empty -``` -*/ -let empty: t<'value, 'id> - -/** -Creates new set from array of elements. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([1, 3, 2, 4], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.toArray /* [1, 2, 3, 4] */ -``` -*/ -let fromArray: (array<'value>, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -The same as [fromArray][#fromarray] except it is after assuming the input array -is already sorted. -*/ -let fromSortedArrayUnsafe: array<'value> => t<'value, 'id> - -/** -Checks if set is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let empty = Belt.Set.Dict.fromArray([], ~cmp=IntCmp.cmp) -let notEmpty = Belt.Set.Dict.fromArray([1], ~cmp=IntCmp.cmp) - -Belt.Set.Dict.isEmpty(empty) /* true */ -Belt.Set.Dict.isEmpty(notEmpty) /* false */ -``` -*/ -let isEmpty: t<_> => bool - -/** -Checks if an element exists in the set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let set = Belt.Set.Dict.fromArray([1, 4, 2, 5], ~cmp=IntCmp.cmp) - -set->Belt.Set.Dict.has(3, ~cmp=IntCmp.cmp) /* false */ -set->Belt.Set.Dict.has(1, ~cmp=IntCmp.cmp) /* true */ -``` -*/ -let has: (t<'value, 'id>, 'value, ~cmp: cmp<'value, 'id>) => bool - -/** -Adds element to set. If element existed in set, value is unchanged. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.empty -let s1 = s0->Belt.Set.Dict.add(1, ~cmp=IntCmp.cmp) -let s2 = s1->Belt.Set.Dict.add(2, ~cmp=IntCmp.cmp) -let s3 = s2->Belt.Set.Dict.add(2, ~cmp=IntCmp.cmp) -s0->Belt.Set.Dict.toArray /* [] */ -s1->Belt.Set.Dict.toArray /* [1] */ -s2->Belt.Set.Dict.toArray /* [1, 2] */ -s3->Belt.Set.Dict.toArray /* [1,2 ] */ -s2 == s3 /* true */ -``` -*/ -let add: (t<'value, 'id>, 'value, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -Adds each element of array to set. Unlike [add](#add), the reference of return value might be changed even if all values in array already exist in set - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let set = Belt.Set.Dict.empty - -let newSet = set->Belt.Set.Dict.mergeMany([5, 4, 3, 2, 1], ~cmp=IntCmp.cmp) -newSet->Belt.Set.Dict.toArray /* [1, 2, 3, 4, 5] */ -``` -*/ -let mergeMany: (t<'value, 'id>, array<'value>, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -Removes element from set. If element did not exist in set, value is unchanged. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([2, 3, 1, 4, 5], ~cmp=IntCmp.cmp) -let s1 = s0->Belt.Set.Dict.remove(1, ~cmp=IntCmp.cmp) -let s2 = s1->Belt.Set.Dict.remove(3, ~cmp=IntCmp.cmp) -let s3 = s2->Belt.Set.Dict.remove(3, ~cmp=IntCmp.cmp) - -s1->Belt.Set.Dict.toArray /* [2,3,4,5] */ -s2->Belt.Set.Dict.toArray /* [2,4,5] */ -s2 == s3 /* true */ -``` -*/ -let remove: (t<'value, 'id>, 'value, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -Removes each element of array from set. Unlike [remove](#remove), the reference of return value might be changed even if any values in array not existed in set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let set = Belt.Set.Dict.fromArray([1, 2, 3, 4], ~cmp=IntCmp.cmp) - -let newSet = set->Belt.Set.Dict.removeMany([5, 4, 3, 2, 1], ~cmp=IntCmp.cmp) -newSet->Belt.Set.Dict.toArray /* [] */ -``` -*/ -let removeMany: (t<'value, 'id>, array<'value>, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -Returns union of two sets. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([5, 2, 3, 5, 6], ~cmp=IntCmp.cmp) -let s1 = Belt.Set.Dict.fromArray([5, 2, 3, 1, 5, 4], ~cmp=IntCmp.cmp) -let union = Belt.Set.Dict.union(s0, s1, ~cmp=IntCmp.cmp) -union->Belt.Set.Dict.toArray /* [1,2,3,4,5,6] */ -``` -*/ -let union: (t<'value, 'id>, t<'value, 'id>, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -Returns intersection of two sets. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([5, 2, 3, 5, 6], ~cmp=IntCmp.cmp) -let s1 = Belt.Set.Dict.fromArray([5, 2, 3, 1, 5, 4], ~cmp=IntCmp.cmp) -let intersect = Belt.Set.Dict.intersect(s0, s1, ~cmp=IntCmp.cmp) -intersect->Belt.Set.Dict.toArray /* [2,3,5] */ -``` -*/ -let intersect: (t<'value, 'id>, t<'value, 'id>, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -Returns elements from first set, not existing in second set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([5, 2, 3, 5, 6], ~cmp=IntCmp.cmp) -let s1 = Belt.Set.Dict.fromArray([5, 2, 3, 1, 5, 4], ~cmp=IntCmp.cmp) - -let diff1 = Belt.Set.Dict.diff(s0, s1, ~cmp=IntCmp.cmp) -let diff2 = Belt.Set.Dict.diff(s1, s0, ~cmp=IntCmp.cmp) - -diff1->Belt.Set.Dict.toArray /* [6] */ -diff2->Belt.Set.Dict.toArray /* [1,4] */ -``` -*/ -let diff: (t<'value, 'id>, t<'value, 'id>, ~cmp: cmp<'value, 'id>) => t<'value, 'id> - -/** -Checks if second set is subset of first set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([5, 2, 3, 5, 6], ~cmp=IntCmp.cmp) -let s1 = Belt.Set.Dict.fromArray([5, 2, 3, 1, 5, 4], ~cmp=IntCmp.cmp) -let s2 = Belt.Set.Dict.intersect(s0, s1, ~cmp=IntCmp.cmp) -Belt.Set.Dict.subset(s2, s0, ~cmp=IntCmp.cmp) /* true */ -Belt.Set.Dict.subset(s2, s1, ~cmp=IntCmp.cmp) /* true */ -Belt.Set.Dict.subset(s1, s0, ~cmp=IntCmp.cmp) /* false */ -``` -*/ -let subset: (t<'value, 'id>, t<'value, 'id>, ~cmp: cmp<'value, 'id>) => bool - -/** -Total ordering between sets. Can be used as the ordering function for doing sets -of sets. It compares size first and then iterates over each element following the -order of elements. -*/ -let cmp: (t<'value, 'id>, t<'value, 'id>, ~cmp: cmp<'value, 'id>) => int - -/** -Checks if two sets are equal. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([5, 2, 3], ~cmp=IntCmp.cmp) -let s1 = Belt.Set.Dict.fromArray([3, 2, 5], ~cmp=IntCmp.cmp) - -Belt.Set.Dict.eq(s0, s1, ~cmp=IntCmp.cmp) /* true */ -``` -*/ -let eq: (t<'value, 'id>, t<'value, 'id>, ~cmp: cmp<'value, 'id>) => bool - -/** -Same as [forEach](##forEach) but takes uncurried functon. -*/ -let forEachU: (t<'value, 'id>, (. 'value) => unit) => unit - -/** -Applies function `f` in turn to all elements of set in increasing order. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([5, 2, 3, 5, 6], ~cmp=IntCmp.cmp) -let acc = ref(list{}) -s0->Belt.Set.Dict.forEach(x => acc := Belt.List.add(acc.contents, x)) -acc /* [6,5,3,2] */ -``` -*/ -let forEach: (t<'value, 'id>, 'value => unit) => unit - -let reduceU: (t<'value, 'id>, 'a, (. 'a, 'value) => 'a) => 'a - -/** -Applies function `f` to each element of set in increasing order. Function `f` has two parameters: the item from the set and an “accumulator”, which starts with a value of `initialValue`. `reduce` returns the final value of the accumulator. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([5, 2, 3, 5, 6], ~cmp=IntCmp.cmp) -s0->Belt.Set.Dict.reduce(list{}, (acc, element) => acc->Belt.List.add(element)) /* [6,5,3,2] */ -``` -*/ -let reduce: (t<'value, 'id>, 'a, ('a, 'value) => 'a) => 'a - -let everyU: (t<'value, 'id>, (. 'value) => bool) => bool - -/** -Checks if all elements of the set satisfy the predicate. Order unspecified. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isEven = x => mod(x, 2) == 0 - -let s0 = Belt.Set.Dict.fromArray([2, 4, 6, 8], ~cmp=IntCmp.cmp) -s0->Belt.Set.Dict.every(isEven) /* true */ -``` -*/ -let every: (t<'value, 'id>, 'value => bool) => bool - -let someU: (t<'value, 'id>, (. 'value) => bool) => bool - -/** -Checks if at least one element of the set satisfies the predicate. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isOdd = x => mod(x, 2) != 0 - -let s0 = Belt.Set.Dict.fromArray([1, 2, 4, 6, 8], ~cmp=IntCmp.cmp) -s0->Belt.Set.Dict.some(isOdd) /* true */ -``` -*/ -let some: (t<'value, 'id>, 'value => bool) => bool - -let keepU: (t<'value, 'id>, (. 'value) => bool) => t<'value, 'id> - -/** -Returns the set of all elements that satisfy the predicate. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isEven = x => mod(x, 2) == 0 - -let s0 = Belt.Set.Dict.fromArray([1, 2, 3, 4, 5], ~cmp=IntCmp.cmp) -let s1 = s0->Belt.Set.Dict.keep(isEven) - -s1->Belt.Set.Dict.toArray /* [2,4] */ -``` -*/ -let keep: (t<'value, 'id>, 'value => bool) => t<'value, 'id> - -let partitionU: (t<'value, 'id>, (. 'value) => bool) => (t<'value, 'id>, t<'value, 'id>) - -/** -Returns a pair of sets, where first is the set of all the elements of set that satisfy the predicate, and second is the set of all the elements of set that do not satisfy the predicate. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let isOdd = x => mod(x, 2) != 0 - -let s0 = Belt.Set.Dict.fromArray([1, 2, 3, 4, 5], ~cmp=IntCmp.cmp) -let (s1, s2) = s0->Belt.Set.Dict.partition(isOdd) - -s1->Belt.Set.Dict.toArray /* [1,3,5] */ -s2->Belt.Set.Dict.toArray /* [2,4] */ -``` -*/ -let partition: (t<'value, 'id>, 'value => bool) => (t<'value, 'id>, t<'value, 'id>) - -/** -Returns size of the set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([1, 2, 3, 4], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.size /* 4 */ -``` -*/ -let size: t<'value, 'id> => int - -/** -Returns list of ordered set elements. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([3, 2, 1, 5], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.toList /* [1,2,3,5] */ -``` -*/ -let toList: t<'value, 'id> => list<'value> - -/** -Returns array of ordered set elements. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([3, 2, 1, 5], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.toArray /* [1,2,3,5] */ -``` -*/ -let toArray: t<'value, 'id> => array<'value> - -/** -Returns minimum value of the collection. `None` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.empty -let s1 = Belt.Set.Dict.fromArray([3, 2, 1, 5], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.minimum /* None */ -s1->Belt.Set.Dict.minimum /* Some(1) */ -``` -*/ -let minimum: t<'value, 'id> => option<'value> - -/** -Returns minimum value of the collection. `undefined` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.empty -let s1 = Belt.Set.Dict.fromArray([3, 2, 1, 5], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.minUndefined /* undefined */ -s1->Belt.Set.Dict.minUndefined /* 1 */ -``` -*/ -let minUndefined: t<'value, 'id> => Js.undefined<'value> - -/** -Returns maximum value of the collection. `None` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.empty -let s1 = Belt.Set.Dict.fromArray([3, 2, 1, 5], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.maximum /* None */ -s1->Belt.Set.Dict.maximum /* Some(5) */ -``` -*/ -let maximum: t<'value, 'id> => option<'value> - -/** -Returns maximum value of the collection. `undefined` if collection is empty. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.empty -let s1 = Belt.Set.Dict.fromArray([3, 2, 1, 5], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.maxUndefined /* undefined */ -s1->Belt.Set.Dict.maxUndefined /* 5 */ -``` -*/ -let maxUndefined: t<'value, 'id> => Js.undefined<'value> - -/** -Returns the reference of the value which is equivalent to value using the comparator -specifiecd by this collection. Returns `None` if element does not exist. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([1, 2, 3, 4, 5], ~cmp=IntCmp.cmp) - -s0->Belt.Set.Dict.get(3, ~cmp=IntCmp.cmp) /* Some(3) */ -s0->Belt.Set.Dict.get(20, ~cmp=IntCmp.cmp) /* None */ -``` -*/ -let get: (t<'value, 'id>, 'value, ~cmp: cmp<'value, 'id>) => option<'value> - -/** -Same as [get](#get) but returns `undefined` when element does not exist. -*/ -let getUndefined: (t<'value, 'id>, 'value, ~cmp: cmp<'value, 'id>) => Js.undefined<'value> - -/** -Same as [get](#get) but raise when element does not exist. -*/ -let getExn: (t<'value, 'id>, 'value, ~cmp: cmp<'value, 'id>) => 'value - -/** -Returns a tuple `((smaller, larger), present)`, `present` is true when element exist in set. - -## Examples - -```rescript -module IntCmp = Belt.Id.MakeComparable({ - type t = int - let cmp = Pervasives.compare -}) - -let s0 = Belt.Set.Dict.fromArray([1, 2, 3, 4, 5], ~cmp=IntCmp.cmp) - -let ((smaller, larger), present) = s0->Belt.Set.Dict.split(3, ~cmp=IntCmp.cmp) - -present /* true */ -smaller->Belt.Set.Dict.toArray /* [1,2] */ -larger->Belt.Set.Dict.toArray /* [4,5] */ -``` -*/ -let split: ( - t<'value, 'id>, - 'value, - ~cmp: cmp<'value, 'id>, -) => ((t<'value, 'id>, t<'value, 'id>), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit diff --git a/jscomp/others/belt_SetInt.res b/jscomp/others/belt_SetInt.res deleted file mode 100644 index 8d75c14..0000000 --- a/jscomp/others/belt_SetInt.res +++ /dev/null @@ -1,227 +0,0 @@ -module I = Belt_internalSetInt - -module N = Belt_internalAVLset -module A = Belt_Array - -type value = I.value -type t = I.t - -let empty = None -let isEmpty = N.isEmpty -let minimum = N.minimum -let minUndefined = N.minUndefined -let maximum = N.maximum -let maxUndefined = N.maxUndefined - -let forEach = N.forEach -let forEachU = N.forEachU -let reduce = N.reduce -let reduceU = N.reduceU -let every = N.every -let everyU = N.everyU -let some = N.some -let someU = N.someU -let keep = N.keepShared -let keepU = N.keepSharedU -let partition = N.partitionShared -let partitionU = N.partitionSharedU - -let size = N.size -let toList = N.toList -let toArray = N.toArray -let fromSortedArrayUnsafe = N.fromSortedArrayUnsafe -let checkInvariantInternal = N.checkInvariantInternal - -let rec add = (t: t, x: value): t => - switch t { - | None => N.singleton(x) - | Some(nt) => - let v = nt.value - if x == v { - t - } else { - let {N.left: l, right: r} = nt - if x < v { - let ll = add(l, x) - if ll === l { - t - } else { - N.bal(ll, v, r) - } - } else { - let rr = add(r, x) - if rr === r { - t - } else { - N.bal(l, v, rr) - } - } - } - } - -let mergeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = add(v.contents, key) - } - v.contents -} - -let rec remove = (t: t, x: value): t => - switch t { - | None => t - | Some(n) => - let {N.left: l, value: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let v = ref(rn.value) - let r = N.removeMinAuxWithRef(rn, v) - N.bal(l, v.contents, r) - } - } else if x < v { - let ll = remove(l, x) - if ll === l { - t - } else { - N.bal(ll, v, r) - } - } else { - let rr = remove(r, x) - if rr === r { - t - } else { - N.bal(l, v, rr) - } - } - } - -let removeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = remove(v.contents, key) - } - v.contents -} - -let fromArray = I.fromArray -let cmp = I.cmp -let eq = I.eq -let get = I.get -let getUndefined = I.getUndefined -let getExn = I.getExn -let subset = I.subset -let has = I.has - -let rec splitAuxNoPivot = (n: N.node<_>, x: value): (t, t) => { - let {N.left: l, value: v, right: r} = n - if x == v { - (l, r) - } else if x < v { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxNoPivot(l, x) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxNoPivot(r, x) - (N.joinShared(l, v, lr), rr) - } - } -} - -let rec splitAuxPivot = (n: N.node<_>, x: value, pres): (t, t) => { - let {N.left: l, value: v, right: r} = n - if x == v { - pres.contents = true - (l, r) - } else if x < v { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxPivot(l, x, pres) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxPivot(r, x, pres) - (N.joinShared(l, v, lr), rr) - } - } -} - -let split = (t: t, x: value) => - switch t { - | None => ((None, None), false) - | Some(n) => - let pres = ref(false) - let v = splitAuxPivot(n, x, pres) - (v, pres.contents) - } - -let rec union = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) => s2 - | (_, None) => s1 - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) */ => - let (h1, h2) = (n1.height, n2.height) - if h1 >= h2 { - if h2 == 1 { - add(s1, n2.value) - } else { - let {N.left: l1, value: v1, right: r1} = n1 - let (l2, r2) = splitAuxNoPivot(n2, v1) - N.joinShared(union(l1, l2), v1, union(r1, r2)) - } - } else if h1 == 1 { - add(s2, n1.value) - } else { - let {N.left: l2, value: v2, right: r2} = n2 - let (l1, r1) = splitAuxNoPivot(n1, v2) - N.joinShared(union(l1, l2), v2, union(r1, r2)) - } - } - -let rec intersect = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) | (_, None) => None - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, _), t2) */ => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(n2, v1, pres) - let ll = intersect(l1, l2) - let rr = intersect(r1, r2) - if pres.contents { - N.joinShared(ll, v1, rr) - } else { - N.concatShared(ll, rr) - } - } - -let rec diff = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) | (_, None) => s1 - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, _), t2) */ => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(n2, v1, pres) - let ll = diff(l1, l2) - let rr = diff(r1, r2) - if pres.contents { - N.concatShared(ll, rr) - } else { - N.joinShared(ll, v1, rr) - } - } diff --git a/jscomp/others/belt_SetInt.resi b/jscomp/others/belt_SetInt.resi deleted file mode 100644 index 7805e9e..0000000 --- a/jscomp/others/belt_SetInt.resi +++ /dev/null @@ -1,162 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** - This module is [`Belt.Set`]() specialized with value type to be a primitive type. - It is more efficient in general, the API is the same with [`Belt_Set`]() except its value type is fixed, - and identity is not needed(using the built-in one) - - **See** [`Belt.Set`]() -*/ - -/** The type of the set elements. */ -type value = int - -/** The type of sets. */ -type t - -let empty: t - -let fromArray: array => t - -let fromSortedArrayUnsafe: array => t - -let isEmpty: t => bool - -let has: (t, value) => bool - -/** -`add(s, x)` If `x` was already in `s`, `s` is returned unchanged. -*/ -let add: (t, value) => t - -let mergeMany: (t, array) => t - -/** -`remove(m, x)` If `x` was not in `m`, `m` is returned reference unchanged. -*/ -let remove: (t, value) => t - -let removeMany: (t, array) => t - -let union: (t, t) => t - -let intersect: (t, t) => t - -let diff: (t, t) => t - -/** -`subset(s1, s2)` tests whether the set `s1` is a subset of the set `s2`. -*/ -let subset: (t, t) => bool - -/** -Total ordering between sets. Can be used as the ordering function for doing sets -of sets. -*/ -let cmp: (t, t) => int - -/** -`eq(s1, s2)` tests whether the sets `s1` and `s2` are equal, that is, contain -equal elements. -*/ -let eq: (t, t) => bool - -let forEachU: (t, (. value) => unit) => unit - -/** -`forEach(s, f)` applies `f` in turn to all elements of `s`. In increasing order -*/ -let forEach: (t, value => unit) => unit - -let reduceU: (t, 'a, (. 'a, value) => 'a) => 'a - -/** Iterate in increasing order. */ -let reduce: (t, 'a, ('a, value) => 'a) => 'a - -let everyU: (t, (. value) => bool) => bool - -/** -`every(p, s)` checks if all elements of the set satisfy the predicate `p`. Order -unspecified. -*/ -let every: (t, value => bool) => bool - -let someU: (t, (. value) => bool) => bool - -/** -`some(p, s)` checks if at least one element of the set satisfies the predicate -`p`. Oder unspecified. -*/ -let some: (t, value => bool) => bool - -let keepU: (t, (. value) => bool) => t - -/** -`keep(p, s)` returns the set of all elements in `s` that satisfy predicate `p`. -*/ -let keep: (t, value => bool) => t - -let partitionU: (t, (. value) => bool) => (t, t) - -/** -`partition(p, s)` returns a pair of sets `(s1, s2)`, where `s1` is the set of -all the elements of `s` that satisfy the predicate `p`, and `s2` is the set of -all the elements of `s` that do not satisfy `p`. -*/ -let partition: (t, value => bool) => (t, t) - -let size: t => int - -/** In increasing order */ -let toList: t => list - -let toArray: t => array - -let minimum: t => option - -let minUndefined: t => Js.undefined - -let maximum: t => option - -let maxUndefined: t => Js.undefined - -let get: (t, value) => option - -let getUndefined: (t, value) => Js.undefined - -let getExn: (t, value) => value - -/** -`split(x, s)` returns a triple `(l, present, r)`, where `l` is the set of -elements of `s` that are strictly less than `x`;`r` is the set of elements of -`s` that are strictly greater than `x`; `present` is `false` if `s` contains no -element equal to `x`, or `true` if `s` contains an element equal to `x`. -*/ -let split: (t, value) => ((t, t), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t => unit diff --git a/jscomp/others/belt_SetString.res b/jscomp/others/belt_SetString.res deleted file mode 100644 index 972aa53..0000000 --- a/jscomp/others/belt_SetString.res +++ /dev/null @@ -1,227 +0,0 @@ -module I = Belt_internalSetString - -module N = Belt_internalAVLset -module A = Belt_Array - -type value = I.value -type t = I.t - -let empty = None -let isEmpty = N.isEmpty -let minimum = N.minimum -let minUndefined = N.minUndefined -let maximum = N.maximum -let maxUndefined = N.maxUndefined - -let forEach = N.forEach -let forEachU = N.forEachU -let reduce = N.reduce -let reduceU = N.reduceU -let every = N.every -let everyU = N.everyU -let some = N.some -let someU = N.someU -let keep = N.keepShared -let keepU = N.keepSharedU -let partition = N.partitionShared -let partitionU = N.partitionSharedU - -let size = N.size -let toList = N.toList -let toArray = N.toArray -let fromSortedArrayUnsafe = N.fromSortedArrayUnsafe -let checkInvariantInternal = N.checkInvariantInternal - -let rec add = (t: t, x: value): t => - switch t { - | None => N.singleton(x) - | Some(nt) => - let v = nt.value - if x == v { - t - } else { - let {N.left: l, right: r} = nt - if x < v { - let ll = add(l, x) - if ll === l { - t - } else { - N.bal(ll, v, r) - } - } else { - let rr = add(r, x) - if rr === r { - t - } else { - N.bal(l, v, rr) - } - } - } - } - -let mergeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = add(v.contents, key) - } - v.contents -} - -let rec remove = (t: t, x: value): t => - switch t { - | None => t - | Some(n) => - let {N.left: l, value: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let v = ref(rn.value) - let r = N.removeMinAuxWithRef(rn, v) - N.bal(l, v.contents, r) - } - } else if x < v { - let ll = remove(l, x) - if ll === l { - t - } else { - N.bal(ll, v, r) - } - } else { - let rr = remove(r, x) - if rr === r { - t - } else { - N.bal(l, v, rr) - } - } - } - -let removeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let key = A.getUnsafe(arr, i) - v.contents = remove(v.contents, key) - } - v.contents -} - -let fromArray = I.fromArray -let cmp = I.cmp -let eq = I.eq -let get = I.get -let getUndefined = I.getUndefined -let getExn = I.getExn -let subset = I.subset -let has = I.has - -let rec splitAuxNoPivot = (n: N.node<_>, x: value): (t, t) => { - let {N.left: l, value: v, right: r} = n - if x == v { - (l, r) - } else if x < v { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxNoPivot(l, x) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxNoPivot(r, x) - (N.joinShared(l, v, lr), rr) - } - } -} - -let rec splitAuxPivot = (n: N.node<_>, x: value, pres): (t, t) => { - let {N.left: l, value: v, right: r} = n - if x == v { - pres.contents = true - (l, r) - } else if x < v { - switch l { - | None => (None, Some(n)) - | Some(l) => - let (ll, rl) = splitAuxPivot(l, x, pres) - (ll, N.joinShared(rl, v, r)) - } - } else { - switch r { - | None => (Some(n), None) - | Some(r) => - let (lr, rr) = splitAuxPivot(r, x, pres) - (N.joinShared(l, v, lr), rr) - } - } -} - -let split = (t: t, x: value) => - switch t { - | None => ((None, None), false) - | Some(n) => - let pres = ref(false) - let v = splitAuxPivot(n, x, pres) - (v, pres.contents) - } - -let rec union = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) => s2 - | (_, None) => s1 - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) */ => - let (h1, h2) = (n1.height, n2.height) - if h1 >= h2 { - if h2 == 1 { - add(s1, n2.value) - } else { - let {N.left: l1, value: v1, right: r1} = n1 - let (l2, r2) = splitAuxNoPivot(n2, v1) - N.joinShared(union(l1, l2), v1, union(r1, r2)) - } - } else if h1 == 1 { - add(s2, n1.value) - } else { - let {N.left: l2, value: v2, right: r2} = n2 - let (l1, r1) = splitAuxNoPivot(n1, v2) - N.joinShared(union(l1, l2), v2, union(r1, r2)) - } - } - -let rec intersect = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) | (_, None) => None - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, _), t2) */ => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(n2, v1, pres) - let ll = intersect(l1, l2) - let rr = intersect(r1, r2) - if pres.contents { - N.joinShared(ll, v1, rr) - } else { - N.concatShared(ll, rr) - } - } - -let rec diff = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) | (_, None) => s1 - | (Some(n1), Some(n2)) /* (Node(l1, v1, r1, _), t2) */ => - let {N.left: l1, value: v1, right: r1} = n1 - let pres = ref(false) - let (l2, r2) = splitAuxPivot(n2, v1, pres) - let ll = diff(l1, l2) - let rr = diff(r1, r2) - if pres.contents { - N.concatShared(ll, rr) - } else { - N.joinShared(ll, v1, rr) - } - } diff --git a/jscomp/others/belt_SetString.resi b/jscomp/others/belt_SetString.resi deleted file mode 100644 index b169be5..0000000 --- a/jscomp/others/belt_SetString.resi +++ /dev/null @@ -1,162 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** - This module is [`Belt.Set`]() specialized with value type to be a primitive type. - It is more efficient in general, the API is the same with [`Belt_Set`]() except its value type is fixed, - and identity is not needed(using the built-in one) - - **See** [`Belt.Set`]() -*/ - -/** The type of the set elements. */ -type value = string - -/** The type of sets. */ -type t - -let empty: t - -let fromArray: array => t - -let fromSortedArrayUnsafe: array => t - -let isEmpty: t => bool - -let has: (t, value) => bool - -/** -`add(s, x)` If `x` was already in `s`, `s` is returned unchanged. -*/ -let add: (t, value) => t - -let mergeMany: (t, array) => t - -/** -`remove(m, x)` If `x` was not in `m`, `m` is returned reference unchanged. -*/ -let remove: (t, value) => t - -let removeMany: (t, array) => t - -let union: (t, t) => t - -let intersect: (t, t) => t - -let diff: (t, t) => t - -/** -`subset(s1, s2)` tests whether the set `s1` is a subset of the set `s2`. -*/ -let subset: (t, t) => bool - -/** -Total ordering between sets. Can be used as the ordering function for doing sets -of sets. -*/ -let cmp: (t, t) => int - -/** -`eq(s1, s2)` tests whether the sets `s1` and `s2` are equal, that is, contain -equal elements. -*/ -let eq: (t, t) => bool - -let forEachU: (t, (. value) => unit) => unit - -/** -`forEach(s, f)` applies `f` in turn to all elements of `s`. In increasing order -*/ -let forEach: (t, value => unit) => unit - -let reduceU: (t, 'a, (. 'a, value) => 'a) => 'a - -/** Iterate in increasing order. */ -let reduce: (t, 'a, ('a, value) => 'a) => 'a - -let everyU: (t, (. value) => bool) => bool - -/** -`every(p, s)` checks if all elements of the set satisfy the predicate `p`. Order -unspecified. -*/ -let every: (t, value => bool) => bool - -let someU: (t, (. value) => bool) => bool - -/** -`some(p, s)` checks if at least one element of the set satisfies the predicate -`p`. Oder unspecified. -*/ -let some: (t, value => bool) => bool - -let keepU: (t, (. value) => bool) => t - -/** -`keep(p, s)` returns the set of all elements in `s` that satisfy predicate `p`. -*/ -let keep: (t, value => bool) => t - -let partitionU: (t, (. value) => bool) => (t, t) - -/** -`partition(p, s)` returns a pair of sets `(s1, s2)`, where `s1` is the set of -all the elements of `s` that satisfy the predicate `p`, and `s2` is the set of -all the elements of `s` that do not satisfy `p`. -*/ -let partition: (t, value => bool) => (t, t) - -let size: t => int - -/** In increasing order */ -let toList: t => list - -let toArray: t => array - -let minimum: t => option - -let minUndefined: t => Js.undefined - -let maximum: t => option - -let maxUndefined: t => Js.undefined - -let get: (t, value) => option - -let getUndefined: (t, value) => Js.undefined - -let getExn: (t, value) => value - -/** -`split(x, s)` returns a triple `(l, present, r)`, where `l` is the set of -elements of `s` that are strictly less than `x`;`r` is the set of elements of -`s` that are strictly greater than `x`; `present` is `false` if `s` contains no -element equal to `x`, or `true` if `s` contains an element equal to `x`. -*/ -let split: (t, value) => ((t, t), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t => unit diff --git a/jscomp/others/belt_SortArray.res b/jscomp/others/belt_SortArray.res deleted file mode 100644 index 462b468..0000000 --- a/jscomp/others/belt_SortArray.res +++ /dev/null @@ -1,354 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Int = Belt_SortArrayInt - -module String = Belt_SortArrayString - -module A = Belt_Array - -let rec sortedLengthAuxMore = (xs, prec, acc, len, lt) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if lt(. v, prec) { - sortedLengthAuxMore(xs, v, acc + 1, len, lt) - } else { - acc - } - } - -let rec sortedLengthAuxLess = (xs, prec, acc, len, lt) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if lt(. prec, v) { - sortedLengthAuxLess(xs, v, acc + 1, len, lt) - } else { - acc - } - } - -let strictlySortedLengthU = (xs, lt) => { - let len = A.length(xs) - switch len { - | 0 | 1 => len - | _ => - let (x0, x1) = (A.getUnsafe(xs, 0), A.getUnsafe(xs, 1)) - - /* let c = cmp x0 x1 [@bs] in */ - if lt(. x0, x1) { - sortedLengthAuxLess(xs, x1, 2, len, lt) - } else if lt(. x1, x0) { - -sortedLengthAuxMore(xs, x1, 2, len, lt) - } else { - 1 - } - } -} - -let strictlySortedLength = (xs, lt) => strictlySortedLengthU(xs, (. x, y) => lt(x, y)) - -let rec isSortedAux = (a, i, cmp, last_bound) => - /* when `i = len - 1`, it reaches the last element */ - if i == last_bound { - true - } else if cmp(. A.getUnsafe(a, i), A.getUnsafe(a, i + 1)) <= 0 { - isSortedAux(a, i + 1, cmp, last_bound) - } else { - false - } - -let isSortedU = (a, cmp) => { - let len = A.length(a) - if len == 0 { - true - } else { - isSortedAux(a, 0, cmp, len - 1) - } -} - -let isSorted = (a, cmp) => isSortedU(a, (. x, y) => cmp(x, y)) - -let cutoff = 5 - -let merge = (src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp) => { - let src1r = src1ofs + src1len and src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - if cmp(. s1, s2) <= 0 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d + 1) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d + 1, ~len=src2r - i2) - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d + 1) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d + 1, ~len=src1r - i1) - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let unionU = (src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => { - let c = cmp(. s1, s2) - if c < 0 { - /* `s1` is larger than all elements in `d` */ - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let d = d + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } - } else if c == 0 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - let d = d + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let union = (src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp) => - unionU(src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, (. x, y) => cmp(x, y)) - -let intersectU = (src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => { - let c = cmp(. s1, s2) - if c < 0 { - /* A.setUnsafe dst d s1; */ - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if c == 0 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } else { - /* A.setUnsafe dst d s2; */ - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let intersect = (src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp) => - intersectU(src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, (. x, y) => cmp(x, y)) - -let diffU = (src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => { - let c = cmp(. s1, s2) - if c < 0 { - A.setUnsafe(dst, d, s1) - let d = d + 1 - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if c == 0 { - let i1 = i1 + 1 - let i2 = i2 + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - d - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let diff = (src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp) => - diffU(src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, (. x, y) => cmp(x, y)) - -/* `<=` alone is not enough for stable sort */ -let insertionSort = (src, srcofs, dst, dstofs, len, cmp) => - for i in 0 to len - 1 { - let e = A.getUnsafe(src, srcofs + i) - let j = ref(dstofs + i - 1) - while j.contents >= dstofs && cmp(. A.getUnsafe(dst, j.contents), e) > 0 { - A.setUnsafe(dst, j.contents + 1, A.getUnsafe(dst, j.contents)) - j.contents = j.contents - 1 - } - A.setUnsafe(dst, j.contents + 1, e) - } - -let rec sortTo = (src, srcofs, dst, dstofs, len, cmp) => - if len <= cutoff { - insertionSort(src, srcofs, dst, dstofs, len, cmp) - } else { - let l1 = len / 2 - let l2 = len - l1 - sortTo(src, srcofs + l1, dst, dstofs + l1, l2, cmp) - sortTo(src, srcofs, src, srcofs + l2, l1, cmp) - merge(src, srcofs + l2, l1, dst, dstofs + l1, l2, dst, dstofs, cmp) - } - -let stableSortInPlaceByU = (a, cmp) => { - let l = A.length(a) - if l <= cutoff { - insertionSort(a, 0, a, 0, l, cmp) - } else { - let l1 = l / 2 - let l2 = l - l1 - let t = Belt_Array.makeUninitializedUnsafe(l2) - sortTo(a, l1, t, 0, l2, cmp) - sortTo(a, 0, a, l2, l1, cmp) - merge(a, l2, l1, t, 0, l2, a, 0, cmp) - } -} - -let stableSortInPlaceBy = (a, cmp) => stableSortInPlaceByU(a, (. x, y) => cmp(x, y)) - -let stableSortByU = (a, cmp) => { - let b = A.copy(a) - stableSortInPlaceByU(b, cmp) - b -} - -let stableSortBy = (a, cmp) => stableSortByU(a, (. x, y) => cmp(x, y)) -/* - `binarySearchAux arr lo hi key cmp` - range [lo, hi] - input (lo <= hi) - `arr[lo] <= key <= arr[hi]` */ -let rec binarySearchAux = (arr, lo, hi, key, cmp) => { - let mid = (lo + hi) / 2 - let midVal = A.getUnsafe(arr, mid) - let c = cmp(. key, midVal) - if c == 0 { - mid - } else if c < 0 { - /* a[lo] =< key < a[mid] <= a[hi] */ - if hi == mid { - if cmp(. A.getUnsafe(arr, lo), key) == 0 { - lo - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, lo, mid, key, cmp) - } - } /* a[lo] =< a[mid] < key <= a[hi] */ - else if lo == mid { - if cmp(. A.getUnsafe(arr, hi), key) == 0 { - hi - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, mid, hi, key, cmp) - } -} - -let binarySearchByU = (sorted, key, cmp): int => { - let len = A.length(sorted) - if len == 0 { - -1 - } else { - let lo = A.getUnsafe(sorted, 0) - let c = cmp(. key, lo) - if c < 0 { - -1 - } else { - let hi = A.getUnsafe(sorted, len - 1) - let c2 = cmp(. key, hi) - if c2 > 0 { - -(len + 1) - } else { - binarySearchAux(sorted, 0, len - 1, key, cmp) - } - } - } -} - -let binarySearchBy = (sorted, key, cmp) => binarySearchByU(sorted, key, (. x, y) => cmp(x, y)) diff --git a/jscomp/others/belt_SortArray.resi b/jscomp/others/belt_SortArray.resi deleted file mode 100644 index ced18fc..0000000 --- a/jscomp/others/belt_SortArray.resi +++ /dev/null @@ -1,115 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -A module for Array sort relevant utiliites -*/ - -/** -Specalized when key type is `int`, more efficient than the generic type -*/ -module Int = Belt_SortArrayInt - -/** -Specalized when key type is `string`, more efficient than the generic type -*/ -module String = Belt_SortArrayString - -let strictlySortedLengthU: (array<'a>, (. 'a, 'a) => bool) => int - -/** -`strictlySortedLenght(xs, cmp);` return `+n` means increasing order `-n` means negative order - -## Examples - -```rescript -Belt.SortArray.strictlySortedLength([1, 2, 3, 4, 3], (x, y) => x < y) == 4 - -Belt.SortArray.strictlySortedLength([], (x, y) => x < y) == 0 - -Belt.SortArray.strictlySortedLength([1], (x, y) => x < y) == 1 - -Belt.SortArray.strictlySortedLength([4, 3, 2, 1], (x, y) => x < y) == -4 -``` -*/ -let strictlySortedLength: (array<'a>, ('a, 'a) => bool) => int - -let isSortedU: (array<'a>, (. 'a, 'a) => int) => bool -/** -`isSorted(arr, cmp)`: Returns true if array is increasingly sorted (equal is okay) -*/ -let isSorted: (array<'a>, ('a, 'a) => int) => bool - -let stableSortInPlaceByU: (array<'a>, (. 'a, 'a) => int) => unit -let stableSortInPlaceBy: (array<'a>, ('a, 'a) => int) => unit - -let stableSortByU: (array<'a>, (. 'a, 'a) => int) => array<'a> -/** -`stableSortBy(xs, cmp)`: Returns a fresh array Sort `xs` in place using -comparator `cmp`, the stable means if the elements are equal, their order will -be preserved -*/ -let stableSortBy: (array<'a>, ('a, 'a) => int) => array<'a> - -let binarySearchByU: (array<'a>, 'a, (. 'a, 'a) => int) => int - -/** -If value is not found and value is less than one or more elements in array, the -negative number returned is the bitwise complement of the index of the first -element that is larger than value. - -If value is not found and value is greater -than all elements in array, the negative number returned is the bitwise -complement of (the index of the last element plus 1)for example, if `key` is -smaller than all elements return `-1` since `lnot(-1) == 0` if `key` is larger -than all elements return `lnot(-1) == 0` since `lnot(- (len + 1)) == len` - -## Examples - -```rescript -Belt.SortArray.binarySearchBy([1, 2, 3, 4, 33, 35, 36], 33, Pervasives.compare) == 4 - -lnot(Belt.SortArray.binarySearchBy([1, 3, 5, 7], 4, Pervasives.compare)) == 2 -``` -*/ -let binarySearchBy: (array<'a>, 'a, ('a, 'a) => int) => int - -let unionU: (array<'a>, int, int, array<'a>, int, int, array<'a>, int, (. 'a, 'a) => int) => int -/** -`union src src1ofs src1len src2 src2ofs src2len dst dstofs cmp` assume `src` and -`src2` is strictly sorted. for equivalent elements, it is picked from `src` -also assume that `dst` is large enough to store all elements -*/ -let union: (array<'a>, int, int, array<'a>, int, int, array<'a>, int, ('a, 'a) => int) => int - -let intersectU: (array<'a>, int, int, array<'a>, int, int, array<'a>, int, (. 'a, 'a) => int) => int -/** -`union src src1ofs src1len src2 src2ofs src2len dst dstofs cmp` - -**return** the `offset` in the output array -*/ -let intersect: (array<'a>, int, int, array<'a>, int, int, array<'a>, int, ('a, 'a) => int) => int - -let diffU: (array<'a>, int, int, array<'a>, int, int, array<'a>, int, (. 'a, 'a) => int) => int -let diff: (array<'a>, int, int, array<'a>, int, int, array<'a>, int, ('a, 'a) => int) => int diff --git a/jscomp/others/belt_SortArrayInt.res b/jscomp/others/belt_SortArrayInt.res deleted file mode 100644 index 40215df..0000000 --- a/jscomp/others/belt_SortArrayInt.res +++ /dev/null @@ -1,304 +0,0 @@ -type element = int - -module A = Belt_Array - -let rec sortedLengthAuxMore = (xs: array, prec, acc, len) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if prec > v { - sortedLengthAuxMore(xs, v, acc + 1, len) - } else { - acc - } - } - -let rec sortedLengthAuxLess = (xs: array, prec, acc, len) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if prec < v { - sortedLengthAuxLess(xs, v, acc + 1, len) - } else { - acc - } - } - -let strictlySortedLength = (xs: array) => { - let len = A.length(xs) - switch len { - | 0 | 1 => len - | _ => - let (x0, x1) = (A.getUnsafe(xs, 0), A.getUnsafe(xs, 1)) - - /* let c = cmp x0 x1 [@bs] in */ - if x0 < x1 { - sortedLengthAuxLess(xs, x1, 2, len) - } else if x0 > x1 { - -sortedLengthAuxMore(xs, x1, 2, len) - } else { - 1 - } - } -} - -let rec isSortedAux = (a: array, i, last_bound) => - /* when `i = len - 1`, it reaches the last element */ - if i == last_bound { - true - } else if A.getUnsafe(a, i) <= A.getUnsafe(a, i + 1) { - isSortedAux(a, i + 1, last_bound) - } else { - false - } - -let isSorted = a => { - let len = A.length(a) - if len == 0 { - true - } else { - isSortedAux(a, 0, len - 1) - } -} - -let cutoff = 5 - -let merge = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len and src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - if s1 <= s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d + 1) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d + 1, ~len=src2r - i2) - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d + 1) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d + 1, ~len=src1r - i1) - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let union = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - /* `s1` is larger than all elements in `d` */ - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let d = d + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } - } else if s1 == s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - let d = d + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let intersect = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - /* A.setUnsafe dst d s1; */ - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if s1 == s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } else { - /* A.setUnsafe dst d s2; */ - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let diff = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - A.setUnsafe(dst, d, s1) - let d = d + 1 - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if s1 == s2 { - let i1 = i1 + 1 - let i2 = i2 + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - d - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let insertionSort = (src: array, srcofs, dst, dstofs, len) => - for i in 0 to len - 1 { - let e = A.getUnsafe(src, srcofs + i) - let j = ref(dstofs + i - 1) - while j.contents >= dstofs && A.getUnsafe(dst, j.contents) > e { - A.setUnsafe(dst, j.contents + 1, A.getUnsafe(dst, j.contents)) - j.contents = j.contents - 1 - } - A.setUnsafe(dst, j.contents + 1, e) - } - -let rec sortTo = (src: array, srcofs, dst, dstofs, len) => - if len <= cutoff { - insertionSort(src, srcofs, dst, dstofs, len) - } else { - let l1 = len / 2 - let l2 = len - l1 - sortTo(src, srcofs + l1, dst, dstofs + l1, l2) - sortTo(src, srcofs, src, srcofs + l2, l1) - merge(src, srcofs + l2, l1, dst, dstofs + l1, l2, dst, dstofs) - } - -let stableSortInPlace = (a: array) => { - let l = A.length(a) - if l <= cutoff { - insertionSort(a, 0, a, 0, l) - } else { - let l1 = l / 2 - let l2 = l - l1 - let t = Belt_Array.makeUninitializedUnsafe(l2) - sortTo(a, l1, t, 0, l2) - sortTo(a, 0, a, l2, l1) - merge(a, l2, l1, t, 0, l2, a, 0) - } -} - -let stableSort = a => { - let b = A.copy(a) - stableSortInPlace(b) - b -} - -let rec binarySearchAux = (arr: array, lo, hi, key) => { - let mid = (lo + hi) / 2 - let midVal = A.getUnsafe(arr, mid) - - /* let c = cmp key midVal [@bs] in */ - if key == midVal { - mid - } else if key < midVal { - /* a[lo] =< key < a[mid] <= a[hi] */ - if hi == mid { - if A.getUnsafe(arr, lo) == key { - lo - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, lo, mid, key) - } - } /* a[lo] =< a[mid] < key <= a[hi] */ - else if lo == mid { - if A.getUnsafe(arr, hi) == key { - hi - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, mid, hi, key) - } -} - -let binarySearch = (sorted: array, key): int => { - let len = A.length(sorted) - if len == 0 { - -1 - } else { - let lo = A.getUnsafe(sorted, 0) - - /* let c = cmp key lo [@bs] in */ - if key < lo { - -1 - } else { - let hi = A.getUnsafe(sorted, len - 1) - - /* let c2 = cmp key hi [@bs]in */ - if key > hi { - -(len + 1) - } else { - binarySearchAux(sorted, 0, len - 1, key) - } - } - } -} diff --git a/jscomp/others/belt_SortArrayInt.resi b/jscomp/others/belt_SortArrayInt.resi deleted file mode 100644 index ce1c48c..0000000 --- a/jscomp/others/belt_SortArrayInt.resi +++ /dev/null @@ -1,75 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This is a specialized module for [`Belt_SortArray`](), the docs in that module also -applies here, except the comparator is fixed and inlined -*/ - -type element = int - -/** -The same as [`Belt_SortArray.strictlySortedLength`]() except the comparator is fixed - -**return** `+n` means increasing order `-n` means negative order -*/ -let strictlySortedLength: array => int - -/** `sorted(xs)` return true if `xs` is in non strict increasing order */ -let isSorted: array => bool - -/** -The same as [`Belt_SortArray.stableSortInPlaceBy`]() except the comparator is fixed -*/ -let stableSortInPlace: array => unit - -/** -The same as [`Belt_SortArray.stableSortBy`]() except the comparator is fixed -*/ -let stableSort: array => array - -/** -If value is not found and value is less than one or more elements in array, -the negative number returned is the bitwise complement of the index of the first element -that is larger than value. - -If value is not found and value is greater than all elements in array, -the negative number returned is the bitwise complement of -(the index of the last element plus 1) - -for example, if `key` is smaller than all elements return `-1` since `lnot (-1) = 0` -if `key` is larger than all elements return `- (len + 1)` since `lnot (-(len+1)) = len` -*/ -let binarySearch: (array, element) => int - -/** -`union(src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp)` assume -`src` and `src2` is strictly sorted. for equivalent elements, it is picked from -`src` also assume that `dst` is large enough to store all elements -*/ -let union: (array, int, int, array, int, int, array, int) => int - -let intersect: (array, int, int, array, int, int, array, int) => int - -let diff: (array, int, int, array, int, int, array, int) => int diff --git a/jscomp/others/belt_SortArrayString.res b/jscomp/others/belt_SortArrayString.res deleted file mode 100644 index 08f55e1..0000000 --- a/jscomp/others/belt_SortArrayString.res +++ /dev/null @@ -1,304 +0,0 @@ -type element = string - -module A = Belt_Array - -let rec sortedLengthAuxMore = (xs: array, prec, acc, len) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if prec > v { - sortedLengthAuxMore(xs, v, acc + 1, len) - } else { - acc - } - } - -let rec sortedLengthAuxLess = (xs: array, prec, acc, len) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if prec < v { - sortedLengthAuxLess(xs, v, acc + 1, len) - } else { - acc - } - } - -let strictlySortedLength = (xs: array) => { - let len = A.length(xs) - switch len { - | 0 | 1 => len - | _ => - let (x0, x1) = (A.getUnsafe(xs, 0), A.getUnsafe(xs, 1)) - - /* let c = cmp x0 x1 [@bs] in */ - if x0 < x1 { - sortedLengthAuxLess(xs, x1, 2, len) - } else if x0 > x1 { - -sortedLengthAuxMore(xs, x1, 2, len) - } else { - 1 - } - } -} - -let rec isSortedAux = (a: array, i, last_bound) => - /* when `i = len - 1`, it reaches the last element */ - if i == last_bound { - true - } else if A.getUnsafe(a, i) <= A.getUnsafe(a, i + 1) { - isSortedAux(a, i + 1, last_bound) - } else { - false - } - -let isSorted = a => { - let len = A.length(a) - if len == 0 { - true - } else { - isSortedAux(a, 0, len - 1) - } -} - -let cutoff = 5 - -let merge = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len and src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - if s1 <= s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d + 1) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d + 1, ~len=src2r - i2) - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d + 1) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d + 1, ~len=src1r - i1) - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let union = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - /* `s1` is larger than all elements in `d` */ - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let d = d + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } - } else if s1 == s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - let d = d + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let intersect = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - /* A.setUnsafe dst d s1; */ - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if s1 == s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } else { - /* A.setUnsafe dst d s2; */ - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let diff = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - A.setUnsafe(dst, d, s1) - let d = d + 1 - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if s1 == s2 { - let i1 = i1 + 1 - let i2 = i2 + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - d - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let insertionSort = (src: array, srcofs, dst, dstofs, len) => - for i in 0 to len - 1 { - let e = A.getUnsafe(src, srcofs + i) - let j = ref(dstofs + i - 1) - while j.contents >= dstofs && A.getUnsafe(dst, j.contents) > e { - A.setUnsafe(dst, j.contents + 1, A.getUnsafe(dst, j.contents)) - j.contents = j.contents - 1 - } - A.setUnsafe(dst, j.contents + 1, e) - } - -let rec sortTo = (src: array, srcofs, dst, dstofs, len) => - if len <= cutoff { - insertionSort(src, srcofs, dst, dstofs, len) - } else { - let l1 = len / 2 - let l2 = len - l1 - sortTo(src, srcofs + l1, dst, dstofs + l1, l2) - sortTo(src, srcofs, src, srcofs + l2, l1) - merge(src, srcofs + l2, l1, dst, dstofs + l1, l2, dst, dstofs) - } - -let stableSortInPlace = (a: array) => { - let l = A.length(a) - if l <= cutoff { - insertionSort(a, 0, a, 0, l) - } else { - let l1 = l / 2 - let l2 = l - l1 - let t = Belt_Array.makeUninitializedUnsafe(l2) - sortTo(a, l1, t, 0, l2) - sortTo(a, 0, a, l2, l1) - merge(a, l2, l1, t, 0, l2, a, 0) - } -} - -let stableSort = a => { - let b = A.copy(a) - stableSortInPlace(b) - b -} - -let rec binarySearchAux = (arr: array, lo, hi, key) => { - let mid = (lo + hi) / 2 - let midVal = A.getUnsafe(arr, mid) - - /* let c = cmp key midVal [@bs] in */ - if key == midVal { - mid - } else if key < midVal { - /* a[lo] =< key < a[mid] <= a[hi] */ - if hi == mid { - if A.getUnsafe(arr, lo) == key { - lo - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, lo, mid, key) - } - } /* a[lo] =< a[mid] < key <= a[hi] */ - else if lo == mid { - if A.getUnsafe(arr, hi) == key { - hi - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, mid, hi, key) - } -} - -let binarySearch = (sorted: array, key): int => { - let len = A.length(sorted) - if len == 0 { - -1 - } else { - let lo = A.getUnsafe(sorted, 0) - - /* let c = cmp key lo [@bs] in */ - if key < lo { - -1 - } else { - let hi = A.getUnsafe(sorted, len - 1) - - /* let c2 = cmp key hi [@bs]in */ - if key > hi { - -(len + 1) - } else { - binarySearchAux(sorted, 0, len - 1, key) - } - } - } -} diff --git a/jscomp/others/belt_SortArrayString.resi b/jscomp/others/belt_SortArrayString.resi deleted file mode 100644 index 3742ce2..0000000 --- a/jscomp/others/belt_SortArrayString.resi +++ /dev/null @@ -1,75 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This is a specialized module for [`Belt_SortArray`](), the docs in that module also -applies here, except the comparator is fixed and inlined -*/ - -type element = string - -/** -The same as [`Belt_SortArray.strictlySortedLength`]() except the comparator is fixed - -**return** `+n` means increasing order `-n` means negative order -*/ -let strictlySortedLength: array => int - -/** `sorted(xs)` return true if `xs` is in non strict increasing order */ -let isSorted: array => bool - -/** -The same as [`Belt_SortArray.stableSortInPlaceBy`]() except the comparator is fixed -*/ -let stableSortInPlace: array => unit - -/** -The same as [`Belt_SortArray.stableSortBy`]() except the comparator is fixed -*/ -let stableSort: array => array - -/** -If value is not found and value is less than one or more elements in array, -the negative number returned is the bitwise complement of the index of the first element -that is larger than value. - -If value is not found and value is greater than all elements in array, -the negative number returned is the bitwise complement of -(the index of the last element plus 1) - -for example, if `key` is smaller than all elements return `-1` since `lnot (-1) = 0` -if `key` is larger than all elements return `- (len + 1)` since `lnot (-(len+1)) = len` -*/ -let binarySearch: (array, element) => int - -/** -`union(src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp)` assume -`src` and `src2` is strictly sorted. for equivalent elements, it is picked from -`src` also assume that `dst` is large enough to store all elements -*/ -let union: (array, int, int, array, int, int, array, int) => int - -let intersect: (array, int, int, array, int, int, array, int) => int - -let diff: (array, int, int, array, int, int, array, int) => int diff --git a/jscomp/others/belt_internalAVLset.res b/jscomp/others/belt_internalAVLset.res deleted file mode 100644 index 1fedc4f..0000000 --- a/jscomp/others/belt_internalAVLset.res +++ /dev/null @@ -1,765 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -@@bs.config({flags: ["-bs-noassertfalse"]}) -type rec node<'value> = { - @as("v") mutable value: 'value, - @as("h") mutable height: int, - @as("l") mutable left: t<'value>, - @as("r") mutable right: t<'value>, -} -and t<'value> = option> - -module A = Belt_Array -module S = Belt_SortArray - -type cmp<'a, 'b> = Belt_Id.cmp<'a, 'b> - -/* Sets are represented by balanced binary trees (the heights of the - children differ by at most 2 */ - -@inline -let height = (n: t<_>) => - switch n { - | None => 0 - | Some(n) => n.height - } - -let rec copy = n => - switch n { - | None => n - | Some(n) => - Some({ - left: copy(n.left), - right: copy(n.right), - value: n.value, - height: n.height, - }) - } - -/* Creates a new node with leftGet son l, value v and right son r. - We must have all elements of l < v < all elements of r. - l and r must be balanced and | treeHeight l - treeHeight r | <= 2. - Inline expansion of treeHeight for better speed. */ - -@inline -let calcHeight = (hl: int, hr) => - if hl >= hr { - hl - } else { - hr - } + 1 - -let create = (l: t<_>, v, r: t<_>) => { - let hl = height(l) - let hr = height(r) - Some({left: l, value: v, right: r, height: calcHeight(hl, hr)}) -} - -let singleton = x => Some({left: None, value: x, right: None, height: 1}) - -let heightGe = (l, r) => - switch (l, r) { - | (_, None) => true - | (Some(hl), Some(hr)) => hl.height >= hr.height - | (None, Some(_)) => false - } -/* Same as create, but performs one step of rebalancing if necessary. - Assumes l and r balanced and | treeHeight l - treeHeight r | <= 3. - Inline expansion of create for better speed in the most frequent case - where no rebalancing is required. */ -/* TODO: inline all `create` operation, save duplicated `heightGet` calcuation */ -let bal = (l, v, r) => { - let (hl, hr) = (height(l), height(r)) - if hl > hr + 2 { - switch l { - | None => assert(false) - | Some({left: ll, right: lr} as l) => - if heightGe(ll, lr) { - create(ll, l.value, create(lr, v, r)) - } else { - switch lr { - | None => assert(false) - | Some(lr) => create(create(ll, l.value, lr.left), lr.value, create(lr.right, v, r)) - } - } - } - } else if hr > hl + 2 { - switch r { - | None => assert(false) - | Some({left: rl, right: rr} as r) => - if heightGe(rr, rl) { - create(create(l, v, rl), r.value, rr) - } else { - switch rl { - | None => assert(false) - | Some(rl) => create(create(l, v, rl.left), rl.value, create(rl.right, r.value, rr)) - } - } - } - } else { - Some({left: l, value: v, right: r, height: calcHeight(hl, hr)}) - } -} - -let rec min0Aux = n => - switch n.left { - | None => n.value - | Some(n) => min0Aux(n) - } - -let minimum = n => - switch n { - | None => None - | Some(n) => Some(min0Aux(n)) - } - -let minUndefined = n => - switch n { - | None => Js.undefined - | Some(n) => Js.Undefined.return(min0Aux(n)) - } - -let rec max0Aux = n => - switch n.right { - | None => n.value - | Some(n) => max0Aux(n) - } - -let maximum = n => - switch n { - | None => None - | Some(n) => Some(max0Aux(n)) - } - -let maxUndefined = n => - switch n { - | None => Js.undefined - | Some(n) => Js.Undefined.return(max0Aux(n)) - } - -let rec removeMinAuxWithRef = (n, v) => - switch n.left { - | None => - v.contents = n.value - n.right - | Some(ln) => bal(removeMinAuxWithRef(ln, v), n.value, n.right) - } - -/* Implementation of the set operations */ - -let isEmpty = n => - switch n { - | Some(_) => false - | None => true - } - -let rec stackAllLeft = (v, s) => - switch v { - | None => s - | Some(x) => stackAllLeft(x.left, list{x, ...s}) - } - -let rec forEachU = (n, f) => - switch n { - | None => () - | Some(n) => - forEachU(n.left, f) - f(. n.value) - forEachU(n.right, f) - } - -let forEach = (n, f) => forEachU(n, (. a) => f(a)) - -let rec reduceU = (s, accu, f) => - switch s { - | None => accu - | Some(n) => reduceU(n.right, f(. reduceU(n.left, accu, f), n.value), f) - } - -let reduce = (s, accu, f) => reduceU(s, accu, (. a, b) => f(a, b)) - -let rec everyU = (n, p) => - switch n { - | None => true - | Some(n) => p(. n.value) && (n.left->everyU(p) && n.right->everyU(p)) - } - -let every = (n, p) => everyU(n, (. a) => p(a)) - -let rec someU = (n, p) => - switch n { - | None => false - | Some(n) => p(. n.value) || (someU(n.left, p) || someU(n.right, p)) - } - -let some = (n, p) => someU(n, (. a) => p(a)) -/* `addMinElement v n` and `addMaxElement v n` - assume that the added v is *strictly* - smaller (or bigger) than all the present elements in the tree. - They are only used during the "join" operation which - respects this precondition. -*/ - -let rec addMinElement = (n, v) => - switch n { - | None => singleton(v) - | Some(n) => bal(addMinElement(n.left, v), n.value, n.right) - } - -let rec addMaxElement = (n, v) => - switch n { - | None => singleton(v) - | Some(n) => bal(n.left, n.value, addMaxElement(n.right, v)) - } - -/* `join ln v rn` Some a balanced tree simliar to `create ln v rn` - bal, but no assumptions are made on the - relative heights of `ln` and `rn`. */ - -let rec joinShared = (ln, v, rn) => - switch (ln, rn) { - | (None, _) => addMinElement(rn, v) - | (_, None) => addMaxElement(ln, v) - | (Some(l), Some(r)) => - let lh = l.height - let rh = r.height - if lh > rh + 2 { - bal(l.left, l.value, joinShared(l.right, v, rn)) - } else if rh > lh + 2 { - bal(joinShared(ln, v, r.left), r.value, r.right) - } else { - create(ln, v, rn) - } - } - -/* `concat l r` - No assumption on the heights of l and r. */ - -let concatShared = (t1, t2) => - switch (t1, t2) { - | (None, _) => t2 - | (_, None) => t1 - | (_, Some(t2n)) => - let v = ref(t2n.value) - let t2r = removeMinAuxWithRef(t2n, v) - joinShared(t1, v.contents, t2r) - } - -let rec partitionSharedU = (n, p) => - switch n { - | None => (None, None) - | Some(n) => - let value = n.value - let (lt, lf) = partitionSharedU(n.left, p) - let pv = p(. value) - let (rt, rf) = partitionSharedU(n.right, p) - if pv { - (joinShared(lt, value, rt), concatShared(lf, rf)) - } else { - (concatShared(lt, rt), joinShared(lf, value, rf)) - } - } - -let partitionShared = (n, p) => partitionSharedU(n, (. a) => p(a)) - -let rec lengthNode = n => { - let {left: l, right: r} = n - let sizeL = switch l { - | None => 0 - | Some(l) => lengthNode(l) - } - let sizeR = switch r { - | None => 0 - | Some(r) => lengthNode(r) - } - 1 + sizeL + sizeR -} - -let size = n => - switch n { - | None => 0 - | Some(n) => lengthNode(n) - } - -let rec toListAux = (n, accu) => - switch n { - | None => accu - | Some(n) => toListAux(n.left, list{n.value, ...toListAux(n.right, accu)}) - } - -let toList = s => toListAux(s, list{}) - -let rec checkInvariantInternal = (v: t<_>) => - switch v { - | None => () - | Some(n) => - let {left: l, right: r} = n - let diff = height(l) - height(r) - assert(diff <= 2 && diff >= -2) - checkInvariantInternal(l) - checkInvariantInternal(r) - } - -let rec fillArray = (n, i, arr) => { - let {left: l, value: v, right: r} = n - let next = switch l { - | None => i - | Some(l) => fillArray(l, i, arr) - } - A.setUnsafe(arr, next, v) - let rnext = next + 1 - switch r { - | None => rnext - | Some(r) => fillArray(r, rnext, arr) - } -} - -type cursor = {mutable forward: int, mutable backward: int} - -let rec fillArrayWithPartition = (n, cursor, arr, p) => { - let {left: l, value: v, right: r} = n - switch l { - | None => () - | Some(l) => fillArrayWithPartition(l, cursor, arr, p) - } - if p(. v) { - let c = cursor.forward - A.setUnsafe(arr, c, v) - cursor.forward = c + 1 - } else { - let c = cursor.backward - A.setUnsafe(arr, c, v) - cursor.backward = c - 1 - } - switch r { - | None => () - | Some(r) => fillArrayWithPartition(r, cursor, arr, p) - } -} - -let rec fillArrayWithFilter = (n, i, arr, p) => { - let {left: l, value: v, right: r} = n - let next = switch l { - | None => i - | Some(l) => fillArrayWithFilter(l, i, arr, p) - } - let rnext = if p(. v) { - A.setUnsafe(arr, next, v) - next + 1 - } else { - next - } - switch r { - | None => rnext - | Some(r) => fillArrayWithFilter(r, rnext, arr, p) - } -} - -let toArray = n => - switch n { - | None => [] - | Some(n) => - let size = lengthNode(n) - let v = A.makeUninitializedUnsafe(size) - ignore((fillArray(n, 0, v): int)) /* may add assertion */ - v - } - -let rec fromSortedArrayRevAux = (arr, off, len) => - switch len { - | 0 => None - | 1 => singleton(A.getUnsafe(arr, off)) - | 2 => - let (x0, x1) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off - 1)) - } - - Some({left: singleton(x0), value: x1, height: 2, right: None}) - | 3 => - let (x0, x1, x2) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off - 1), getUnsafe(arr, off - 2)) - } - Some({ - left: singleton(x0), - right: singleton(x2), - value: x1, - height: 2, - }) - | _ => - let nl = len / 2 - let left = fromSortedArrayRevAux(arr, off, nl) - let mid = A.getUnsafe(arr, off - nl) - let right = fromSortedArrayRevAux(arr, off - nl - 1, len - nl - 1) - create(left, mid, right) - } - -let rec fromSortedArrayAux = (arr, off, len) => - switch len { - | 0 => None - | 1 => singleton(A.getUnsafe(arr, off)) - | 2 => - let (x0, x1) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off + 1)) - } - - Some({left: singleton(x0), value: x1, height: 2, right: None}) - | 3 => - let (x0, x1, x2) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off + 1), getUnsafe(arr, off + 2)) - } - Some({ - left: singleton(x0), - right: singleton(x2), - value: x1, - height: 2, - }) - | _ => - let nl = len / 2 - let left = fromSortedArrayAux(arr, off, nl) - let mid = A.getUnsafe(arr, off + nl) - let right = fromSortedArrayAux(arr, off + nl + 1, len - nl - 1) - create(left, mid, right) - } - -let fromSortedArrayUnsafe = arr => fromSortedArrayAux(arr, 0, A.length(arr)) - -let rec keepSharedU = (n, p) => - switch n { - | None => None - | Some(n) => - let {left: l, value: v, right: r} = n - let newL = keepSharedU(l, p) - let pv = p(. v) - let newR = keepSharedU(r, p) - if pv { - if l === newL && r === newR { - Some(n) - } else { - joinShared(newL, v, newR) - } - } else { - concatShared(newL, newR) - } - } - -let keepShared = (n, p) => keepSharedU(n, (. a) => p(a)) -/* ATT: functional methods in general can be shared with - imperative methods, however, it does not apply when functional - methods makes use of referential equality -*/ - -let keepCopyU = (n, p): t<_> => - switch n { - | None => None - | Some(n) => - let size = lengthNode(n) - let v = A.makeUninitializedUnsafe(size) - let last = fillArrayWithFilter(n, 0, v, p) - fromSortedArrayAux(v, 0, last) - } - -let keepCopy = (n, p) => keepCopyU(n, (. x) => p(x)) - -let partitionCopyU = (n, p) => - switch n { - | None => (None, None) - | Some(n) => - let size = lengthNode(n) - let v = A.makeUninitializedUnsafe(size) - let backward = size - 1 - let cursor = {forward: 0, backward} - fillArrayWithPartition(n, cursor, v, p) - let forwardLen = cursor.forward - (fromSortedArrayAux(v, 0, forwardLen), fromSortedArrayRevAux(v, backward, size - forwardLen)) - } - -let partitionCopy = (n, p) => partitionCopyU(n, (. a) => p(a)) - -let rec has = (t: t<_>, x, ~cmp) => - switch t { - | None => false - | Some(n) => - let v = n.value - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - c == 0 || - has( - ~cmp, - if c < 0 { - n.left - } else { - n.right - }, - x, - ) - } - -let rec compareAux = (e1, e2, ~cmp) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = Belt_Id.getCmpInternal(cmp)(. h1.value, h2.value) - if c == 0 { - compareAux(~cmp, h1.right->stackAllLeft(t1), h2.right->stackAllLeft(t2)) - } else { - c - } - | (_, _) => 0 - } - -let cmp = (s1, s2, ~cmp) => { - let (len1, len2) = (size(s1), size(s2)) - if len1 == len2 { - compareAux(~cmp, stackAllLeft(s1, list{}), stackAllLeft(s2, list{})) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let eq = (s1, s2, ~cmp as c) => cmp(~cmp=c, s1, s2) == 0 - -let rec subset = (s1: t<_>, s2: t<_>, ~cmp) => - switch (s1, s2) { - | (None, _) => true - | (_, None) => false - | (Some(t1), Some(t2)) => - let {left: l1, value: v1, right: r1} = t1 - let {left: l2, value: v2, right: r2} = t2 - let c = Belt_Id.getCmpInternal(cmp)(. v1, v2) - if c == 0 { - subset(~cmp, l1, l2) && subset(~cmp, r1, r2) - } else if c < 0 { - subset(~cmp, create(l1, v1, None), l2) && subset(~cmp, r1, s2) - } else { - subset(~cmp, create(None, v1, r1), r2) && subset(~cmp, l1, s2) - } - } - -let rec get = (n: t<_>, x, ~cmp) => - switch n { - | None => None - | Some(t) /* Node(l, v, r, _) */ => - let v = t.value - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - Some(v) - } else { - get( - ~cmp, - if c < 0 { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getUndefined = (n: t<_>, x, ~cmp) => - switch n { - | None => Js.Undefined.empty - | Some(t) /* Node(l, v, r, _) */ => - let v = t.value - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - Js.Undefined.return(v) - } else { - getUndefined( - ~cmp, - if c < 0 { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getExn = (n: t<_>, x, ~cmp) => - switch n { - | None => raise(Not_found) - | Some(t) /* Node(l, v, r, _) */ => - let v = t.value - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - v - } else { - getExn( - ~cmp, - if c < 0 { - t.left - } else { - t.right - }, - x, - ) - } - } - -/* **************************************************************** */ - -/* - L rotation, Some root node -*/ -let rotateWithLeftChild = k2 => - switch k2.left { - | None => assert(false) - | Some(k1) => - k2.left = k1.right - k1.right = Some(k2) - let (hlk2, hrk2) = (k2.left->height, k2.right->height) - k2.height = Pervasives.max(hlk2, hrk2) + 1 - let (hlk1, hk2) = (k1.left->height, k2.height) - k1.height = Pervasives.max(hlk1, hk2) + 1 - k1 - } -/* right rotation */ -let rotateWithRightChild = k1 => - switch k1.right { - | None => assert(false) - | Some(k2) => - k1.right = k2.left - k2.left = Some(k1) - let (hlk1, hrk1) = (k1.left->height, k1.right->height) - k1.height = Pervasives.max(hlk1, hrk1) + 1 - let (hrk2, hk1) = (k2.right->height, k1.height) - k2.height = Pervasives.max(hrk2, hk1) + 1 - k2 - } - -/* - double l rotation -*/ -/** */ -let doubleWithLeftChild = k3 => - switch k3.left { - | None => assert(false) - | Some(k3l) => - let v = k3l->rotateWithRightChild->Some - k3.left = v - k3->rotateWithLeftChild - } - -let doubleWithRightChild = k2 => - switch k2.right { - | None => assert(false) - | Some(k2r) => - let v = k2r->rotateWithLeftChild->Some - k2.right = v - rotateWithRightChild(k2) - } - -let heightUpdateMutate = t => { - let (hlt, hrt) = (t.left->height, t.right->height) - t.height = Pervasives.max(hlt, hrt) + 1 - t -} - -let balMutate = nt => { - let {left: l, right: r} = nt - let (hl, hr) = (height(l), height(r)) - if hl > 2 + hr { - switch l { - | None => assert(false) - | Some({left: ll, right: lr}) => - if heightGe(ll, lr) { - heightUpdateMutate(rotateWithLeftChild(nt)) - } else { - heightUpdateMutate(doubleWithLeftChild(nt)) - } - } - } else if hr > 2 + hl { - switch r { - | None => assert(false) - | Some({left: rl, right: rr}) => - if heightGe(rr, rl) { - heightUpdateMutate(rotateWithRightChild(nt)) - } else { - heightUpdateMutate(doubleWithRightChild(nt)) - } - } - } else { - nt.height = Pervasives.max(hl, hr) + 1 - nt - } -} - -let rec addMutate = (~cmp, t: t<_>, x) => - switch t { - | None => singleton(x) - | Some(nt) => - let k = nt.value - let c = Belt_Id.getCmpInternal(cmp)(. x, k) - if c == 0 { - t - } else { - let {left: l, right: r} = nt - if c < 0 { - let ll = addMutate(~cmp, l, x) - nt.left = ll - } else { - nt.right = addMutate(~cmp, r, x) - } - Some(balMutate(nt)) - } - } - -let fromArray = (xs: array<_>, ~cmp) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref(S.strictlySortedLengthU(xs, (. x, y) => Belt_Id.getCmpInternal(cmp)(. x, y) < 0)) - let result = ref( - if next.contents >= 0 { - fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - result.contents = addMutate(~cmp, result.contents, A.getUnsafe(xs, i)) - } - result.contents - } -} - -let rec removeMinAuxWithRootMutate = (nt, n) => { - let {right: rn, left: ln} = n - switch ln { - | None => - nt.value = n.value - rn - | Some(ln) => - n.left = removeMinAuxWithRootMutate(nt, ln) - Some(balMutate(n)) - } -} diff --git a/jscomp/others/belt_internalAVLset.resi b/jscomp/others/belt_internalAVLset.resi deleted file mode 100644 index 0f7ccf5..0000000 --- a/jscomp/others/belt_internalAVLset.resi +++ /dev/null @@ -1,116 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* -This internal module contains methods which does not rely on ordering. -Such methods could be shared between `generic set/specalized set` whether mutable -or immutable depends on use cases -*/ -type rec t<'value> = option> -and node<'value> = { - @as("v") mutable value: 'value, - @as("h") mutable height: int, - @as("l") mutable left: t<'value>, - @as("r") mutable right: t<'value>, -} - -type cmp<'a, 'b> = Belt_Id.cmp<'a, 'b> - -let copy: t<'a> => t<'a> -let create: (t<'a>, 'a, t<'a>) => t<'a> -let bal: (t<'a>, 'a, t<'a>) => t<'a> -let singleton: 'a => t<'a> - -let minimum: t<'a> => option<'a> -let minUndefined: t<'a> => Js.undefined<'a> -let maximum: t<'a> => option<'a> -let maxUndefined: t<'a> => Js.undefined<'a> - -let removeMinAuxWithRef: (node<'a>, ref<'a>) => t<'a> -/* `removeMinAuxWithRef n cell` return a new node with - minimum removed and stored in cell */ - -let isEmpty: t<'a> => bool - -let stackAllLeft: (t<'a>, list>) => list> - -let forEachU: (t<'a>, (. 'a) => unit) => unit -let forEach: (t<'a>, 'a => unit) => unit - -let reduceU: (t<'a>, 'b, (. 'b, 'a) => 'b) => 'b -let reduce: (t<'a>, 'b, ('b, 'a) => 'b) => 'b - -let everyU: (t<'a>, (. 'a) => bool) => bool -let every: (t<'a>, 'a => bool) => bool - -let someU: (t<'a>, (. 'a) => bool) => bool -let some: (t<'a>, 'a => bool) => bool - -let joinShared: (t<'a>, 'a, t<'a>) => t<'a> -let concatShared: (t<'a>, t<'a>) => t<'a> - -let keepSharedU: (t<'a>, (. 'a) => bool) => t<'a> -let keepShared: (t<'a>, 'a => bool) => t<'a> - -let keepCopyU: (t<'a>, (. 'a) => bool) => t<'a> -let keepCopy: (t<'a>, 'a => bool) => t<'a> - -let partitionSharedU: (t<'a>, (. 'a) => bool) => (t<'a>, t<'a>) -let partitionShared: (t<'a>, 'a => bool) => (t<'a>, t<'a>) - -let partitionCopyU: (t<'a>, (. 'a) => bool) => (t<'a>, t<'a>) -let partitionCopy: (t<'a>, 'a => bool) => (t<'a>, t<'a>) - -let lengthNode: node<'a> => int -let size: t<'a> => int - -let toList: t<'a> => list<'a> - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -let fillArray: (node<'a>, int, array<'a>) => int -let toArray: t<'a> => array<'a> -let fromSortedArrayAux: (array<'a>, int, int) => t<'a> -let fromSortedArrayRevAux: (array<'a>, int, int) => t<'a> -let fromSortedArrayUnsafe: array<'a> => t<'a> -let has: (t<'a>, 'a, ~cmp: cmp<'a, 'b>) => bool -let cmp: (t<'a>, t<'a>, ~cmp: cmp<'a, 'b>) => int -let eq: (t<'a>, t<'a>, ~cmp: cmp<'a, 'b>) => bool -let subset: (t<'a>, t<'a>, ~cmp: cmp<'a, 'b>) => bool -let get: (t<'a>, 'a, ~cmp: cmp<'a, 'b>) => option<'a> -let getUndefined: (t<'a>, 'a, ~cmp: cmp<'a, 'b>) => Js.undefined<'a> -let getExn: (t<'a>, 'a, ~cmp: cmp<'a, 'b>) => 'a - -let fromArray: (array<'a>, ~cmp: cmp<'a, 'b>) => t<'a> - -let addMutate: (~cmp: cmp<'a, 'b>, t<'a>, 'a) => t<'a> -let balMutate: node<'a> => node<'a> -/** -`removeMinAuxWithRootMutate(root, n)` remove the minimum of n in place and store -its value in the `key root` -*/ -let removeMinAuxWithRootMutate: (node<'a>, node<'a>) => t<'a> diff --git a/jscomp/others/belt_internalAVLtree.res b/jscomp/others/belt_internalAVLtree.res deleted file mode 100644 index ff557ba..0000000 --- a/jscomp/others/belt_internalAVLtree.res +++ /dev/null @@ -1,945 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* ********************************************************************* */ - -/* Almost rewritten by authors of ReScript */ - -@@bs.config({flags: ["-bs-noassertfalse"]}) -type rec node<'k, 'v> = { - @as("k") mutable key: 'k, - @as("v") mutable value: 'v, - @as("h") mutable height: int, - @as("l") mutable left: t<'k, 'v>, - @as("r") mutable right: t<'k, 'v>, -} -and t<'key, 'a> = option> - -type cmp<'k, 'id> = Belt_Id.cmp<'k, 'id> - -module A = Belt_Array -module S = Belt_SortArray - -let treeHeight = (n: t<_>) => - switch n { - | None => 0 - | Some(n) => n.height - } - -let rec copy = n => - switch n { - | None => n - | Some(n) => Some({...n, left: copy(n.left), right: copy(n.right)}) - } - -let create = (l, x, d, r) => { - let (hl, hr) = (treeHeight(l), treeHeight(r)) - Some({ - left: l, - key: x, - value: d, - right: r, - height: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) -} - -let singleton = (x, d) => Some({left: None, key: x, value: d, right: None, height: 1}) - -let heightGe = (l, r) => - switch (l, r) { - | (_, None) => true - | (Some(hl), Some(hr)) => hl.height >= hr.height - | (None, Some(_)) => false - } - -let updateValue = (n, newValue) => - if n.value === newValue { - n - } else { - { - left: n.left, - right: n.right, - key: n.key, - value: newValue, - height: n.height, - } - } - -let bal = (l, x, d, r) => { - let hl = switch l { - | None => 0 - | Some(n) => n.height - } - let hr = switch r { - | None => 0 - | Some(n) => n.height - } - if hl > hr + 2 { - switch l { - | None => assert(false) - | Some({left: ll, right: lr} as l) => - if treeHeight(ll) >= treeHeight(lr) { - create(ll, l.key, l.value, create(lr, x, d, r)) - } else { - switch lr { - | None => assert(false) - | Some(lr) => - create(create(ll, l.key, l.value, lr.left), lr.key, lr.value, create(lr.right, x, d, r)) - } - } - } - } else if hr > hl + 2 { - switch r { - | None => assert(false) - | Some({left: rl, right: rr} as r) => - if treeHeight(rr) >= treeHeight(rl) { - create(create(l, x, d, rl), r.key, r.value, rr) - } else { - switch rl { - | None => assert(false) - | Some(rl) => - create(create(l, x, d, rl.left), rl.key, rl.value, create(rl.right, r.key, r.value, rr)) - } - } - } - } else { - Some({ - left: l, - key: x, - value: d, - right: r, - height: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } -} - -let rec minKey0Aux = n => - switch n.left { - | None => n.key - | Some(n) => minKey0Aux(n) - } - -let minKey = n => - switch n { - | None => None - | Some(n) => Some(minKey0Aux(n)) - } - -let minKeyUndefined = n => - switch n { - | None => Js.undefined - | Some(n) => Js.Undefined.return(minKey0Aux(n)) - } - -let rec maxKey0Aux = n => - switch n.right { - | None => n.key - | Some(n) => maxKey0Aux(n) - } - -let maxKey = n => - switch n { - | None => None - | Some(n) => Some(maxKey0Aux(n)) - } - -let maxKeyUndefined = n => - switch n { - | None => Js.undefined - | Some(n) => Js.Undefined.return(maxKey0Aux(n)) - } - -let rec minKV0Aux = n => - switch n.left { - | None => (n.key, n.value) - | Some(n) => minKV0Aux(n) - } - -let minimum = n => - switch n { - | None => None - | Some(n) => Some(minKV0Aux(n)) - } - -let minUndefined = n => - switch n { - | None => Js.undefined - | Some(n) => Js.Undefined.return(minKV0Aux(n)) - } - -let rec maxKV0Aux = n => - switch n.right { - | None => (n.key, n.value) - | Some(n) => maxKV0Aux(n) - } - -let maximum = n => - switch n { - | None => None - | Some(n) => Some(maxKV0Aux(n)) - } - -let maxUndefined = n => - switch n { - | None => Js.undefined - | Some(n) => Js.Undefined.return(maxKV0Aux(n)) - } - -/* TODO: use kv ref */ -let rec removeMinAuxWithRef = (n, kr, vr) => - switch n.left { - | None => - kr.contents = n.key - vr.contents = n.value - n.right - | Some(ln) => bal(removeMinAuxWithRef(ln, kr, vr), n.key, n.value, n.right) - } - -let isEmpty = x => - switch x { - | None => true - | Some(_) => false - } - -let rec stackAllLeft = (v, s) => - switch v { - | None => s - | Some(x) => stackAllLeft(x.left, list{x, ...s}) - } - -let rec findFirstByU = (n, p) => - switch n { - | None => None - | Some(n) => - let left = findFirstByU(n.left, p) - if left != None { - left - } else { - let {key: v, value: d} = n - let pvd = p(. v, d) - if pvd { - Some(v, d) - } else { - let right = findFirstByU(n.right, p) - if right != None { - right - } else { - None - } - } - } - } - -let findFirstBy = (n, p) => findFirstByU(n, (. a, b) => p(a, b)) - -let rec forEachU = (n, f) => - switch n { - | None => () - | Some(n) => - forEachU(n.left, f) - f(. n.key, n.value) - forEachU(n.right, f) - } - -let forEach = (n, f) => forEachU(n, (. a, b) => f(a, b)) - -let rec mapU = (n, f) => - switch n { - | None => None - | Some(n) => - let newLeft = mapU(n.left, f) - let newD = f(. n.value) - let newRight = mapU(n.right, f) - Some({left: newLeft, key: n.key, value: newD, right: newRight, height: n.height}) - } - -let map = (n, f) => mapU(n, (. a) => f(a)) - -let rec mapWithKeyU = (n, f) => - switch n { - | None => None - | Some(n) => - let key = n.key - let newLeft = mapWithKeyU(n.left, f) - let newD = f(. key, n.value) - let newRight = mapWithKeyU(n.right, f) - Some({left: newLeft, key, value: newD, right: newRight, height: n.height}) - } - -let mapWithKey = (n, f) => mapWithKeyU(n, (. a, b) => f(a, b)) - -let rec reduceU = (m, accu, f) => - switch m { - | None => accu - | Some(n) => - let {left: l, key: v, value: d, right: r} = n - reduceU(r, f(. reduceU(l, accu, f), v, d), f) - } - -let reduce = (m, accu, f) => reduceU(m, accu, (. a, b, c) => f(a, b, c)) - -let rec everyU = (n, p) => - switch n { - | None => true - | Some(n) => p(. n.key, n.value) && (everyU(n.left, p) && everyU(n.right, p)) - } -let every = (n, p) => everyU(n, (. a, b) => p(a, b)) - -let rec someU = (n, p) => - switch n { - | None => false - | Some(n) => p(. n.key, n.value) || (someU(n.left, p) || someU(n.right, p)) - } -let some = (n, p) => someU(n, (. a, b) => p(a, b)) -/* Beware: those two functions assume that the added k is *strictly* - smaller (or bigger) than all the present keys in the tree; it - does not test for equality with the current min (or max) key. - - Indeed, they are only used during the "join" operation which - respects this precondition. -*/ - -let rec addMinElement = (n, k, v) => - switch n { - | None => singleton(k, v) - | Some(n) => bal(addMinElement(n.left, k, v), n.key, n.value, n.right) - } - -let rec addMaxElement = (n, k, v) => - switch n { - | None => singleton(k, v) - | Some(n) => bal(n.left, n.key, n.value, addMaxElement(n.right, k, v)) - } - -/* Same as create and bal, but no assumptions are made on the - relative heights of l and r. */ - -let rec join = (ln, v, d, rn) => - switch (ln, rn) { - | (None, _) => addMinElement(rn, v, d) - | (_, None) => addMaxElement(ln, v, d) - | (Some(l), Some(r)) => - let {left: ll, key: lv, value: ld, right: lr, height: lh} = l - let {left: rl, key: rv, value: rd, right: rr, height: rh} = r - if lh > rh + 2 { - bal(ll, lv, ld, join(lr, v, d, rn)) - } else if rh > lh + 2 { - bal(join(ln, v, d, rl), rv, rd, rr) - } else { - create(ln, v, d, rn) - } - } - -/* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. */ - -let concat = (t1, t2) => - switch (t1, t2) { - | (None, _) => t2 - | (_, None) => t1 - | (_, Some(t2n)) => - let (kr, vr) = (ref(t2n.key), ref(t2n.value)) - let t2r = removeMinAuxWithRef(t2n, kr, vr) - join(t1, kr.contents, vr.contents, t2r) - } - -let concatOrJoin = (t1, v, d, t2) => - switch d { - | Some(d) => join(t1, v, d, t2) - | None => concat(t1, t2) - } - -let rec keepSharedU = (n, p) => - switch n { - | None => None - | Some(n) => - /* call `p` in the expected left-to-right order */ - let {key: v, value: d} = n - let newLeft = keepSharedU(n.left, p) - let pvd = p(. v, d) - let newRight = keepSharedU(n.right, p) - if pvd { - join(newLeft, v, d, newRight) - } else { - concat(newLeft, newRight) - } - } - -let keepShared = (n, p) => keepSharedU(n, (. a, b) => p(a, b)) - -let rec keepMapU = (n, p) => - switch n { - | None => None - | Some(n) => - /* call `p` in the expected left-to-right order */ - let {key: v, value: d} = n - let newLeft = keepMapU(n.left, p) - let pvd = p(. v, d) - let newRight = keepMapU(n.right, p) - switch pvd { - | None => concat(newLeft, newRight) - | Some(d) => join(newLeft, v, d, newRight) - } - } - -let keepMap = (n, p) => keepMapU(n, (. a, b) => p(a, b)) - -let rec partitionSharedU = (n, p) => - switch n { - | None => (None, None) - | Some(n) => - let {key, value} = n - /* call `p` in the expected left-to-right order */ - let (lt, lf) = partitionSharedU(n.left, p) - let pvd = p(. key, value) - let (rt, rf) = partitionSharedU(n.right, p) - if pvd { - (join(lt, key, value, rt), concat(lf, rf)) - } else { - (concat(lt, rt), join(lf, key, value, rf)) - } - } - -let partitionShared = (n, p) => partitionSharedU(n, (. a, b) => p(a, b)) - -let rec lengthNode = n => { - let {left: l, right: r} = n - let sizeL = switch l { - | None => 0 - | Some(l) => lengthNode(l) - } - let sizeR = switch r { - | None => 0 - | Some(r) => lengthNode(r) - } - 1 + sizeL + sizeR -} - -let size = n => - switch n { - | None => 0 - | Some(n) => lengthNode(n) - } - -let rec toListAux = (n, accu) => - switch n { - | None => accu - | Some(n) => - let {left: l, right: r, key: k, value: v} = n - toListAux(l, list{(k, v), ...toListAux(r, accu)}) - } - -let toList = s => toListAux(s, list{}) - -let rec checkInvariantInternal = (v: t<_>) => - switch v { - | None => () - | Some(n) => - let (l, r) = (n.left, n.right) - let diff = treeHeight(l) - treeHeight(r) - assert(diff <= 2 && diff >= -2) - checkInvariantInternal(l) - checkInvariantInternal(r) - } - -let rec fillArrayKey = (n, i, arr) => { - let {left: l, key: v, right: r} = n - let next = switch l { - | None => i - | Some(l) => fillArrayKey(l, i, arr) - } - A.setUnsafe(arr, next, v) - let rnext = next + 1 - switch r { - | None => rnext - | Some(r) => fillArrayKey(r, rnext, arr) - } -} - -let rec fillArrayValue = (n, i, arr) => { - let (l, r) = (n.left, n.right) - let next = switch l { - | None => i - | Some(l) => fillArrayValue(l, i, arr) - } - A.setUnsafe(arr, next, n.value) - let rnext = next + 1 - switch r { - | None => rnext - | Some(r) => fillArrayValue(r, rnext, arr) - } -} - -let rec fillArray = (n, i, arr) => { - let (l, v, r) = (n.left, n.key, n.right) - let next = switch l { - | None => i - | Some(l) => fillArray(l, i, arr) - } - A.setUnsafe(arr, next, (v, n.value)) - let rnext = next + 1 - switch r { - | None => rnext - | Some(r) => fillArray(r, rnext, arr) - } -} - -/* let rec fillArrayWithPartition n cursor arr p = - let l,v,r = n.left, n.key , n.right in - (match l with - | None -> () - | Some l -> - fillArrayWithPartition l cursor arr p); - (if p v [@bs] then begin - let c = forwardGet cursor in - A.setUnsafe arr c (v,n.value); - forwardSet cursor (c + 1) - end - else begin - let c = backwardGet cursor in - A.setUnsafe arr c (v, n.value); - backwardSet cursor (c - 1) - end); - match r with - | None -> () - | Some r -> - fillArrayWithPartition r cursor arr p - -let rec fillArrayWithFilter n i arr p = - let l,v,r = n.left, n.key , n.right in - let next = - match l with - | None -> i - | Some l -> - fillArrayWithFilter l i arr p in - let rnext = - if p v [@bs] then - (A.setUnsafe arr next (v, n.value); - next + 1 - ) - else next in - match r with - | None -> rnext - | Some r -> - fillArrayWithFilter r rnext arr p - */ - -let toArray = n => - switch n { - | None => [] - | Some(n) => - let size = lengthNode(n) - let v = A.makeUninitializedUnsafe(size) - ignore((fillArray(n, 0, v): int)) /* may add assertion */ - v - } - -let keysToArray = n => - switch n { - | None => [] - | Some(n) => - let size = lengthNode(n) - let v = A.makeUninitializedUnsafe(size) - ignore((fillArrayKey(n, 0, v): int)) /* may add assertion */ - v - } - -let valuesToArray = n => - switch n { - | None => [] - | Some(n) => - let size = lengthNode(n) - let v = A.makeUninitializedUnsafe(size) - ignore((fillArrayValue(n, 0, v): int)) /* may add assertion */ - v - } - -let rec fromSortedArrayRevAux = (arr, off, len) => - switch len { - | 0 => None - | 1 => - let (k, v) = A.getUnsafe(arr, off) - singleton(k, v) - | 2 => - let ((x0, y0), (x1, y1)) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off - 1)) - } - - Some({left: singleton(x0, y0), key: x1, value: y1, height: 2, right: None}) - | 3 => - let ((x0, y0), (x1, y1), (x2, y2)) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off - 1), getUnsafe(arr, off - 2)) - } - Some({ - left: singleton(x0, y0), - right: singleton(x2, y2), - key: x1, - value: y1, - height: 2, - }) - | _ => - let nl = len / 2 - let left = fromSortedArrayRevAux(arr, off, nl) - let (midK, midV) = A.getUnsafe(arr, off - nl) - let right = fromSortedArrayRevAux(arr, off - nl - 1, len - nl - 1) - create(left, midK, midV, right) - } - -let rec fromSortedArrayAux = (arr, off, len) => - switch len { - | 0 => None - | 1 => - let (k, v) = A.getUnsafe(arr, off) - singleton(k, v) - | 2 => - let ((x0, y0), (x1, y1)) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off + 1)) - } - - Some({left: singleton(x0, y0), key: x1, value: y1, height: 2, right: None}) - | 3 => - let ((x0, y0), (x1, y1), (x2, y2)) = { - open A - (getUnsafe(arr, off), getUnsafe(arr, off + 1), getUnsafe(arr, off + 2)) - } - Some({ - left: singleton(x0, y0), - right: singleton(x2, y2), - key: x1, - value: y1, - height: 2, - }) - | _ => - let nl = len / 2 - let left = fromSortedArrayAux(arr, off, nl) - let (midK, midV) = A.getUnsafe(arr, off + nl) - let right = fromSortedArrayAux(arr, off + nl + 1, len - nl - 1) - create(left, midK, midV, right) - } - -let fromSortedArrayUnsafe = arr => fromSortedArrayAux(arr, 0, A.length(arr)) - -let rec compareAux = (e1, e2, ~kcmp, ~vcmp) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = Belt_Id.getCmpInternal(kcmp)(. h1.key, h2.key) - if c == 0 { - let cx = vcmp(. h1.value, h2.value) - if cx == 0 { - compareAux(~kcmp, ~vcmp, stackAllLeft(h1.right, t1), stackAllLeft(h2.right, t2)) - } else { - cx - } - } else { - c - } - | (_, _) => 0 - } - -let rec eqAux = (e1, e2, ~kcmp, ~veq) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - if Belt_Id.getCmpInternal(kcmp)(. h1.key, h2.key) == 0 && veq(. h1.value, h2.value) { - eqAux(~kcmp, ~veq, stackAllLeft(h1.right, t1), stackAllLeft(h2.right, t2)) - } else { - false - } - | (_, _) => true - } - -let cmpU = (s1, s2, ~kcmp, ~vcmp) => { - let (len1, len2) = (size(s1), size(s2)) - if len1 == len2 { - compareAux(stackAllLeft(s1, list{}), stackAllLeft(s2, list{}), ~kcmp, ~vcmp) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let cmp = (s1, s2, ~kcmp, ~vcmp) => cmpU(s1, s2, ~kcmp, ~vcmp=(. a, b) => vcmp(a, b)) - -let eqU = (s1, s2, ~kcmp, ~veq) => { - let (len1, len2) = (size(s1), size(s2)) - if len1 == len2 { - eqAux(stackAllLeft(s1, list{}), stackAllLeft(s2, list{}), ~kcmp, ~veq) - } else { - false - } -} - -let eq = (s1, s2, ~kcmp, ~veq) => eqU(s1, s2, ~kcmp, ~veq=(. a, b) => veq(a, b)) - -let rec get = (n, x, ~cmp) => - switch n { - | None => None - | Some(n) /* Node(l, v, d, r, _) */ => - let v = n.key - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - Some(n.value) - } else { - get( - ~cmp, - if c < 0 { - n.left - } else { - n.right - }, - x, - ) - } - } - -let rec getUndefined = (n, x, ~cmp) => - switch n { - | None => Js.undefined - | Some(n) => - let v = n.key - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - Js.Undefined.return(n.value) - } else { - getUndefined( - ~cmp, - if c < 0 { - n.left - } else { - n.right - }, - x, - ) - } - } - -let rec getExn = (n, x, ~cmp) => - switch n { - | None => raise(Not_found) - | Some(n) /* Node(l, v, d, r, _) */ => - let v = n.key - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - n.value - } else { - getExn( - ~cmp, - if c < 0 { - n.left - } else { - n.right - }, - x, - ) - } - } - -let rec getWithDefault = (n, x, def, ~cmp) => - switch n { - | None => def - | Some(n) /* Node(l, v, d, r, _) */ => - let v = n.key - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - if c == 0 { - n.value - } else { - getWithDefault( - ~cmp, - if c < 0 { - n.left - } else { - n.right - }, - x, - def, - ) - } - } - -let rec has = (n, x, ~cmp) => - switch n { - | None => false - | Some(n) /* Node(l, v, d, r, _) */ => - let v = n.key - let c = Belt_Id.getCmpInternal(cmp)(. x, v) - c == 0 || - has( - ~cmp, - if c < 0 { - n.left - } else { - n.right - }, - x, - ) - } - -/* **************************************************************** */ - -/* - L rotation, Some root node -*/ -let rotateWithLeftChild = k2 => - switch k2.left { - | None => assert(false) - | Some(k1) => - k2.left = k1.right - k1.right = Some(k2) - let (hlk2, hrk2) = (treeHeight(k2.left), treeHeight(k2.right)) - k2.height = Pervasives.max(hlk2, hrk2) + 1 - let (hlk1, hk2) = (treeHeight(k1.left), k2.height) - k1.height = Pervasives.max(hlk1, hk2) + 1 - k1 - } -/* right rotation */ -let rotateWithRightChild = k1 => - switch k1.right { - | None => assert(false) - | Some(k2) => - k1.right = k2.left - k2.left = Some(k1) - let (hlk1, hrk1) = (treeHeight(k1.left), treeHeight(k1.right)) - k1.height = Pervasives.max(hlk1, hrk1) + 1 - let (hrk2, hk1) = (treeHeight(k2.right), k1.height) - k2.height = Pervasives.max(hrk2, hk1) + 1 - k2 - } - -/* - double l rotation -*/ -let doubleWithLeftChild = k3 => { - let k3l = switch k3.left { - | None => assert(false) - | Some(x) => x - } - let v = rotateWithRightChild(k3l) - k3.left = Some(v) - rotateWithLeftChild(k3) -} - -let doubleWithRightChild = k2 => { - let k2r = switch k2.right { - | None => assert(false) - | Some(x) => x - } - let v = rotateWithLeftChild(k2r) - k2.right = Some(v) - rotateWithRightChild(k2) -} - -let heightUpdateMutate = t => { - let (hlt, hrt) = (treeHeight(t.left), treeHeight(t.right)) - t.height = Pervasives.max(hlt, hrt) + 1 - t -} - -let balMutate = nt => { - let (l, r) = (nt.left, nt.right) - let (hl, hr) = (treeHeight(l), treeHeight(r)) - if hl > 2 + hr { - switch l { - | None => assert(false) - | Some({left: ll, right: lr}) => - if heightGe(ll, lr) { - heightUpdateMutate(rotateWithLeftChild(nt)) - } else { - heightUpdateMutate(doubleWithLeftChild(nt)) - } - } - } else if hr > 2 + hl { - switch r { - | None => assert(false) - | Some({left: rl, right: rr}) => - if heightGe(rr, rl) { - heightUpdateMutate(rotateWithRightChild(nt)) - } else { - heightUpdateMutate(doubleWithRightChild(nt)) - } - } - } else { - nt.height = Pervasives.max(hl, hr) + 1 - nt - } -} - -let rec updateMutate = (t: t<_>, x, data, ~cmp) => - switch t { - | None => singleton(x, data) - | Some(nt) => - let k = nt.key - let c = Belt_Id.getCmpInternal(cmp)(. x, k) - if c == 0 { - nt.value = data - Some(nt) - } else { - let (l, r) = (nt.left, nt.right) - if c < 0 { - let ll = updateMutate(~cmp, l, x, data) - nt.left = ll - } else { - nt.right = updateMutate(~cmp, r, x, data) - } - Some(balMutate(nt)) - } - } - -let fromArray = (xs: array<_>, ~cmp) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref( - S.strictlySortedLengthU(xs, (. (x0, _), (y0, _)) => - Belt_Id.getCmpInternal(cmp)(. x0, y0) < 0 - ), - ) - - let result = ref( - if next.contents >= 0 { - fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - let (k, v) = A.getUnsafe(xs, i) - result.contents = updateMutate(~cmp, result.contents, k, v) - } - result.contents - } -} - -let rec removeMinAuxWithRootMutate = (nt, n) => { - let (rn, ln) = (n.right, n.left) - switch ln { - | None => - nt.key = n.key - nt.value = n.value - rn - | Some(ln) => - n.left = removeMinAuxWithRootMutate(nt, ln) - Some(balMutate(n)) - } -} diff --git a/jscomp/others/belt_internalAVLtree.resi b/jscomp/others/belt_internalAVLtree.resi deleted file mode 100644 index a1b58f3..0000000 --- a/jscomp/others/belt_internalAVLtree.resi +++ /dev/null @@ -1,139 +0,0 @@ -/* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type rec t<'key, 'a> = option> - -and node<'k, 'v> = { - @as("k") mutable key: 'k, - @as("v") mutable value: 'v, - @as("h") mutable height: int, - @as("l") mutable left: t<'k, 'v>, - @as("r") mutable right: t<'k, 'v>, -} - -type cmp<'k, 'id> = Belt_Id.cmp<'k, 'id> - -let copy: t<'k, 'v> => t<'k, 'v> -let create: (t<'a, 'b>, 'a, 'b, t<'a, 'b>) => t<'a, 'b> -let bal: (t<'a, 'b>, 'a, 'b, t<'a, 'b>) => t<'a, 'b> - -let singleton: ('a, 'b) => t<'a, 'b> - -let updateValue: (node<'k, 'v>, 'v) => node<'k, 'v> - -let minKey: t<'a, 'b> => option<'a> -let minKeyUndefined: t<'a, 'b> => Js.undefined<'a> - -let maxKey: t<'a, 'b> => option<'a> -let maxKeyUndefined: t<'a, 'b> => Js.undefined<'a> - -let minimum: t<'a, 'b> => option<('a, 'b)> -let minUndefined: t<'a, 'b> => Js.undefined<('a, 'b)> - -let maximum: t<'a, 'b> => option<('a, 'b)> -let maxUndefined: t<'a, 'b> => Js.undefined<('a, 'b)> - -let removeMinAuxWithRef: (node<'a, 'b>, ref<'a>, ref<'b>) => t<'a, 'b> - -let isEmpty: t<_> => bool - -let stackAllLeft: (t<'a, 'b>, list>) => list> - -let findFirstByU: (t<'a, 'b>, (. 'a, 'b) => bool) => option<('a, 'b)> -let findFirstBy: (t<'a, 'b>, ('a, 'b) => bool) => option<('a, 'b)> - -let forEachU: (t<'a, 'b>, (. 'a, 'b) => unit) => unit -let forEach: (t<'a, 'b>, ('a, 'b) => unit) => unit - -let mapU: (t<'c, 'a>, (. 'a) => 'b) => t<'c, 'b> -let map: (t<'c, 'a>, 'a => 'b) => t<'c, 'b> - -let mapWithKeyU: (t<'a, 'b>, (. 'a, 'b) => 'c) => t<'a, 'c> -let mapWithKey: (t<'a, 'b>, ('a, 'b) => 'c) => t<'a, 'c> - -let reduceU: (t<'a, 'b>, 'c, (. 'c, 'a, 'b) => 'c) => 'c -let reduce: (t<'a, 'b>, 'c, ('c, 'a, 'b) => 'c) => 'c - -let everyU: (t<'a, 'b>, (. 'a, 'b) => bool) => bool -let every: (t<'a, 'b>, ('a, 'b) => bool) => bool - -let someU: (t<'a, 'b>, (. 'a, 'b) => bool) => bool -let some: (t<'a, 'b>, ('a, 'b) => bool) => bool - -let join: (t<'a, 'b>, 'a, 'b, t<'a, 'b>) => t<'a, 'b> - -let concat: (t<'a, 'b>, t<'a, 'b>) => t<'a, 'b> - -let concatOrJoin: (t<'a, 'b>, 'a, option<'b>, t<'a, 'b>) => t<'a, 'b> - -let keepSharedU: (t<'a, 'b>, (. 'a, 'b) => bool) => t<'a, 'b> -let keepShared: (t<'a, 'b>, ('a, 'b) => bool) => t<'a, 'b> - -let keepMapU: (t<'a, 'b>, (. 'a, 'b) => option<'c>) => t<'a, 'c> -let keepMap: (t<'a, 'b>, ('a, 'b) => option<'c>) => t<'a, 'c> - -/* seems no sharing, could be shared with mutation */ -let partitionSharedU: (t<'a, 'b>, (. 'a, 'b) => bool) => (t<'a, 'b>, t<'a, 'b>) -let partitionShared: (t<'a, 'b>, ('a, 'b) => bool) => (t<'a, 'b>, t<'a, 'b>) - -let lengthNode: node<'a, 'b> => int -let size: t<'a, 'b> => int - -let toList: t<'a, 'b> => list<('a, 'b)> -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<'a, 'b> => unit - -let fillArray: (node<'a, 'b>, int, array<('a, 'b)>) => int - -let toArray: t<'a, 'b> => array<('a, 'b)> -let keysToArray: t<'a, 'b> => array<'a> -let valuesToArray: t<'a, 'b> => array<'b> -let fromSortedArrayAux: (array<('a, 'b)>, int, int) => t<'a, 'b> -let fromSortedArrayRevAux: (array<('a, 'b)>, int, int) => t<'a, 'b> -let fromSortedArrayUnsafe: array<('a, 'b)> => t<'a, 'b> - -let cmpU: (t<'a, 'b>, t<'a, 'c>, ~kcmp: cmp<'a, _>, ~vcmp: (. 'b, 'c) => int) => int -let cmp: (t<'a, 'b>, t<'a, 'c>, ~kcmp: cmp<'a, _>, ~vcmp: ('b, 'c) => int) => int - -let eqU: (t<'a, 'b>, t<'a, 'c>, ~kcmp: cmp<'a, _>, ~veq: (. 'b, 'c) => bool) => bool -let eq: (t<'a, 'b>, t<'a, 'c>, ~kcmp: cmp<'a, _>, ~veq: ('b, 'c) => bool) => bool - -let get: (t<'a, 'b>, 'a, ~cmp: cmp<'a, _>) => option<'b> - -let getUndefined: (t<'a, 'b>, 'a, ~cmp: cmp<'a, _>) => Js.undefined<'b> - -let getWithDefault: (t<'a, 'b>, 'a, 'b, ~cmp: cmp<'a, _>) => 'b -let getExn: (t<'a, 'b>, 'a, ~cmp: cmp<'a, _>) => 'b - -let has: (t<'a, 'b>, 'a, ~cmp: cmp<'a, _>) => bool - -let fromArray: (array<('a, 'b)>, ~cmp: cmp<'a, 'id>) => t<'a, 'b> - -let updateMutate: (t<'a, 'b>, 'a, 'b, ~cmp: cmp<'a, 'id>) => t<'a, 'b> - -let balMutate: node<'a, 'b> => node<'a, 'b> - -let removeMinAuxWithRootMutate: (node<'a, 'b>, node<'a, 'b>) => t<'a, 'b> diff --git a/jscomp/others/belt_internalBuckets.res b/jscomp/others/belt_internalBuckets.res deleted file mode 100644 index d9eeb7e..0000000 --- a/jscomp/others/belt_internalBuckets.res +++ /dev/null @@ -1,225 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* ********************************************************************* */ - -/* Adapted by Hongbo Zhang, Authors of ReScript 2017 */ - -/* For JS backends, we use `undefined` as default value, so that buckets - could be allocated lazily -*/ - -/* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. */ -module C = Belt_internalBucketsType -/* TODO: - the current implementation relies on the fact that bucket - empty value is `undefined` in both places, - in theory, it can be different - -*/ -type rec bucket<'a, 'b> = { - mutable key: 'a, - mutable value: 'b, - mutable next: C.opt>, -} -and t<'hash, 'eq, 'a, 'b> = C.container<'hash, 'eq, bucket<'a, 'b>> - -module A = Belt_Array - -let rec copy = (x: t<_>): t<_> => { - hash: x.hash, - eq: x.eq, - size: x.size, - buckets: copyBuckets(x.buckets), -} -and copyBuckets = (buckets: array>>) => { - let len = A.length(buckets) - let newBuckets = A.makeUninitializedUnsafe(len) - for i in 0 to len - 1 { - A.setUnsafe(newBuckets, i, copyBucket(A.getUnsafe(buckets, i))) - } - newBuckets -} -and copyBucket = c => - switch C.toOpt(c) { - | None => c - | Some(c) => - let head = { - key: c.key, - value: c.value, - next: C.emptyOpt, - } - copyAuxCont(c.next, head) - C.return(head) - } -and copyAuxCont = (c, prec) => - switch C.toOpt(c) { - | None => () - | Some(nc) => - let ncopy = {key: nc.key, value: nc.value, next: C.emptyOpt} - prec.next = C.return(ncopy) - copyAuxCont(nc.next, ncopy) - } - -let rec bucketLength = (accu, buckets) => - switch C.toOpt(buckets) { - | None => accu - | Some(cell) => bucketLength(accu + 1, cell.next) - } - -let rec do_bucket_iter = (~f, buckets) => - switch C.toOpt(buckets) { - | None => () - | Some(cell) => - f(. cell.key, cell.value)->ignore - do_bucket_iter(~f, cell.next) - } - -let forEachU = (h, f) => { - let d = h.C.buckets - for i in 0 to A.length(d) - 1 { - do_bucket_iter(~f, A.getUnsafe(d, i)) - } -} - -let forEach = (h, f) => forEachU(h, (. a, b) => f(a, b)) - -let rec do_bucket_fold = (~f, b, accu) => - switch C.toOpt(b) { - | None => accu - | Some(cell) => do_bucket_fold(~f, cell.next, f(. accu, cell.key, cell.value)) - } - -let reduceU = (h, init, f) => { - let d = h.C.buckets - let accu = ref(init) - for i in 0 to A.length(d) - 1 { - accu.contents = do_bucket_fold(~f, A.getUnsafe(d, i), accu.contents) - } - accu.contents -} - -let reduce = (h, init, f) => reduceU(h, init, (. a, b, c) => f(a, b, c)) - -let getMaxBucketLength = h => - A.reduceU(h.C.buckets, 0, (. m, b) => { - let len = bucketLength(0, b) - Pervasives.max(m, len) - }) - -let getBucketHistogram = h => { - let mbl = getMaxBucketLength(h) - let histo = A.makeByU(mbl + 1, (. _) => 0) - A.forEachU(h.C.buckets, (. b) => { - let l = bucketLength(0, b) - A.setUnsafe(histo, l, A.getUnsafe(histo, l) + 1) - }) - histo -} - -let logStats = h => { - let histogram = getBucketHistogram(h) - Js.log({ - "bindings": h.C.size, - "buckets": A.length(h.C.buckets), - "histogram": histogram, - }) -} - -/** iterate the Buckets, in place remove the elements */ -let rec filterMapInplaceBucket = (f, h, i, prec, cell) => { - let n = cell.next - switch f(. cell.key, cell.value) { - | None => - h.C.size = h.C.size - 1 /* delete */ - switch C.toOpt(n) { - | Some(nextCell) => filterMapInplaceBucket(f, h, i, prec, nextCell) - | None => - switch C.toOpt(prec) { - | None => A.setUnsafe(h.C.buckets, i, prec) - | Some(cell) => cell.next = n - } - } - | Some(data) => - /* replace */ - let bucket = C.return(cell) - switch C.toOpt(prec) { - | None => A.setUnsafe(h.C.buckets, i, bucket) - | Some(_) => cell.next = bucket - } - cell.value = data - switch C.toOpt(n) { - | None => cell.next = n - | Some(nextCell) => filterMapInplaceBucket(f, h, i, bucket, nextCell) - } - } -} - -let keepMapInPlaceU = (h, f) => { - let h_buckets = h.C.buckets - for i in 0 to A.length(h_buckets) - 1 { - let v = A.getUnsafe(h_buckets, i) - switch C.toOpt(v) { - | None => () - | Some(v) => filterMapInplaceBucket(f, h, i, C.emptyOpt, v) - } - } -} - -let keepMapInPlace = (h, f) => keepMapInPlaceU(h, (. a, b) => f(a, b)) - -let rec fillArray = (i, arr, cell) => { - A.setUnsafe(arr, i, (cell.key, cell.value)) - switch C.toOpt(cell.next) { - | None => i + 1 - | Some(v) => fillArray(i + 1, arr, v) - } -} - -/* let toArray h = - let d =h.bucketsin - let current = ref 0 in - let arr = A.makeUninitializedUnsafe (C.sizeGet h) in - for i = 0 to A.length d - 1 do - let cell = A.getUnsafe d i in - match C.toOpt cell with - | None -> () - | Some cell -> - current .contents<- fillArray current.contents arr cell - done; - arr */ - -let rec fillArrayMap = (i, arr, cell, f) => { - A.setUnsafe(arr, i, f(. cell)) - switch C.toOpt(cell.next) { - | None => i + 1 - | Some(v) => fillArrayMap(i + 1, arr, v, f) - } -} - -let linear = (h, f) => { - let d = h.C.buckets - let current = ref(0) - let arr = A.makeUninitializedUnsafe(h.C.size) - for i in 0 to A.length(d) - 1 { - let cell = A.getUnsafe(d, i) - switch C.toOpt(cell) { - | None => () - | Some(cell) => current.contents = fillArrayMap(current.contents, arr, cell, f) - } - } - arr -} - -let keysToArray = h => linear(h, (. x) => x.key) -let valuesToArray = h => linear(h, (. x) => x.value) -let toArray = h => linear(h, (. x) => (x.key, x.value)) diff --git a/jscomp/others/belt_internalBuckets.resi b/jscomp/others/belt_internalBuckets.resi deleted file mode 100644 index 149309b..0000000 --- a/jscomp/others/belt_internalBuckets.resi +++ /dev/null @@ -1,55 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module C = Belt_internalBucketsType - -type rec bucket<'a, 'b> = { - mutable key: 'a, - mutable value: 'b, - mutable next: C.opt>, -} -and t<'hash, 'eq, 'a, 'b> = C.container<'hash, 'eq, bucket<'a, 'b>> - -let copy: t<'hash, 'eq, 'a, 'b> => t<'hash, 'eq, 'a, 'b> - -let forEachU: (t<_, _, 'a, 'b>, (. 'a, 'b) => 'c) => unit -let forEach: (t<_, _, 'a, 'b>, ('a, 'b) => 'c) => unit - -let reduceU: (t<_, _, 'a, 'b>, 'c, (. 'c, 'a, 'b) => 'c) => 'c -let reduce: (t<_, _, 'a, 'b>, 'c, ('c, 'a, 'b) => 'c) => 'c - -let logStats: t<_> => unit - -let keepMapInPlaceU: (t<_, _, 'a, 'b>, (. 'a, 'b) => option<'b>) => unit -let keepMapInPlace: (t<_, _, 'a, 'b>, ('a, 'b) => option<'b>) => unit - -let fillArray: (int, array<('a, 'b)>, bucket<'a, 'b>) => int - -let keysToArray: t<_, _, 'a, _> => array<'a> - -let valuesToArray: t<_, _, _, 'b> => array<'b> - -let toArray: t<_, _, 'a, 'b> => array<('a, 'b)> - -let getBucketHistogram: t<_> => array diff --git a/jscomp/others/belt_internalBucketsType.res b/jscomp/others/belt_internalBucketsType.res deleted file mode 100644 index d7d0c68..0000000 --- a/jscomp/others/belt_internalBucketsType.res +++ /dev/null @@ -1,66 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -type opt<'a> = Js.undefined<'a> - -type container<'hash, 'eq, 'c> = { - mutable size: int /* number of entries */, - mutable buckets: array> /* the buckets */, - hash: 'hash, - eq: 'eq, -} - -module A = Belt_Array -external toOpt: opt<'a> => option<'a> = "#undefined_to_opt" -external return: 'a => opt<'a> = "%identity" - -let emptyOpt = Js.undefined -let rec power_2_above = (x, n) => - if x >= n { - x - } else if x * 2 < x { - x /* overflow */ - } else { - power_2_above(x * 2, n) - } - -let make = (~hash, ~eq, ~hintSize) => { - let s = power_2_above(16, hintSize) - { - size: 0, - buckets: A.makeUninitialized(s), - hash, - eq, - } -} - -let clear = h => { - h.size = 0 - let h_buckets = h.buckets - let len = A.length(h_buckets) - for i in 0 to len - 1 { - A.setUnsafe(h_buckets, i, emptyOpt) - } -} - -let isEmpty = h => h.size == 0 diff --git a/jscomp/others/belt_internalBucketsType.resi b/jscomp/others/belt_internalBucketsType.resi deleted file mode 100644 index cab76a7..0000000 --- a/jscomp/others/belt_internalBucketsType.resi +++ /dev/null @@ -1,41 +0,0 @@ -/* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type opt<'a> = Js.undefined<'a> -type container<'hash, 'eq, 'c> = { - mutable size: int /* number of entries */, - mutable buckets: array> /* the buckets */, - hash: 'hash, - eq: 'eq, -} - -external toOpt: opt<'a> => option<'a> = "#undefined_to_opt" -external return: 'a => opt<'a> = "%identity" - -let emptyOpt: Js.undefined<'a> -let make: (~hash: 'hash, ~eq: 'eq, ~hintSize: int) => container<'hash, 'eq, _> - -let clear: container<_> => unit - -let isEmpty: container<_> => bool diff --git a/jscomp/others/belt_internalMapInt.res b/jscomp/others/belt_internalMapInt.res deleted file mode 100644 index 86d18f7..0000000 --- a/jscomp/others/belt_internalMapInt.res +++ /dev/null @@ -1,288 +0,0 @@ -@@bs.config({flags: ["-bs-noassertfalse"]}) - -type key = int - -module N = Belt_internalAVLtree -module A = Belt_Array -module S = Belt_SortArray - -type t<'a> = N.t - -let rec add = (t, x: key, data: _) => - switch t { - | None => N.singleton(x, data) - | Some(n) => - let k = n.N.key - if x == k { - Some(N.updateValue(n, data)) - } else { - let v = n.N.value - if x < k { - N.bal(add(n.N.left, x, data), k, v, n.N.right) - } else { - N.bal(n.N.left, k, v, add(n.N.right, x, data)) - } - } - } - -let rec get = (n, x: key) => - switch n { - | None => None - | Some(n) => - let v = n.N.key - if x == v { - Some(n.N.value) - } else { - get( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getUndefined = (n, x: key) => - switch n { - | None => Js.undefined - | Some(n) => - let v = n.N.key - if x == v { - Js.Undefined.return(n.N.value) - } else { - getUndefined( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getExn = (n, x: key) => - switch n { - | None => raise(Not_found) - | Some(n) => - let v = n.N.key - if x == v { - n.N.value - } else { - getExn( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getWithDefault = (n, x: key, def) => - switch n { - | None => def - | Some(n) => - let v = n.N.key - if x == v { - n.N.value - } else { - getWithDefault( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - def, - ) - } - } - -let rec has = (n, x: key) => - switch n { - | None => false - | Some(n) /* Node(l, v, d, r, _) */ => - let v = n.N.key - x == v || - has( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - -let rec remove = (n, x: key) => - switch n { - | None => n - | Some(n) => - let {N.left: l, key: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.key), ref(rn.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - } else if x < v { - open N - bal(remove(l, x), v, n.value, r) - } else { - open N - bal(l, v, n.value, remove(r, x)) - } - } - -let rec splitAux = (x: key, n: N.node<_>): (t<_>, option<_>, t<_>) => { - let {N.left: l, key: v, value: d, right: r} = n - if x == v { - (l, Some(d), r) - } else if x < v { - switch l { - | None => (None, None, Some(n)) - | Some(l) => - let (ll, pres, rl) = splitAux(x, l) - (ll, pres, N.join(rl, v, d, r)) - } - } else { - switch r { - | None => (Some(n), None, None) - | Some(r) => - let (lr, pres, rr) = splitAux(x, r) - (N.join(l, v, d, lr), pres, rr) - } - } -} - -let split = (x: key, n) => - switch n { - | None => (None, None, None) - | Some(n) => splitAux(x, n) - } - -let rec mergeU = (s1, s2, f) => - switch (s1, s2) { - | (None, None) => None - | (Some(n) /* (Node (l1, v1, d1, r1, h1), _) */, _) - if n.N.height >= - switch s2 { - | None => 0 - | Some(n) => n.N.height - } => - let {N.left: l1, key: v1, value: d1, right: r1} = n - let (l2, d2, r2) = split(v1, s2) - N.concatOrJoin(mergeU(l1, l2, f), v1, f(. v1, Some(d1), d2), mergeU(r1, r2, f)) - | (_, Some(n)) /* Node (l2, v2, d2, r2, h2) */ => - let {N.left: l2, key: v2, value: d2, right: r2} = n - let (l1, d1, r1) = split(v2, s1) - N.concatOrJoin(mergeU(l1, l2, f), v2, f(. v2, d1, Some(d2)), mergeU(r1, r2, f)) - | _ => assert(false) - } - -let merge = (s1, s2, f) => mergeU(s1, s2, (. a, b, c) => f(a, b, c)) - -let rec compareAux = (e1, e2, vcmp) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = Pervasives.compare((h1.N.key: key), h2.N.key) - if c == 0 { - let cx = vcmp(. h1.N.value, h2.N.value) - if cx == 0 { - compareAux(N.stackAllLeft(h1.N.right, t1), N.stackAllLeft(h2.N.right, t2), vcmp) - } else { - cx - } - } else { - c - } - | (_, _) => 0 - } - -let cmpU = (s1, s2, cmp) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - compareAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{}), cmp) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let cmp = (s1, s2, f) => cmpU(s1, s2, (. a, b) => f(a, b)) - -let rec eqAux = (e1, e2, eq) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - if (h1.N.key: key) == h2.N.key && eq(. h1.N.value, h2.N.value) { - eqAux(N.stackAllLeft(h1.N.right, t1), N.stackAllLeft(h2.N.right, t2), eq) - } else { - false - } - | (_, _) => true - } /* end */ - -let eqU = (s1, s2, eq) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - eqAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{}), eq) - } else { - false - } -} - -let eq = (s1, s2, f) => eqU(s1, s2, (. a, b) => f(a, b)) - -let rec addMutate = (t: t<_>, x, data): t<_> => - switch t { - | None => N.singleton(x, data) - | Some(nt) => - let k = nt.N.key - - /* let c = (Belt_Cmp.getCmpInternal cmp) x k [@bs] in */ - if x == k { - nt.N.key = x - nt.value = data - Some(nt) - } else { - let (l, r) = (nt.N.left, nt.N.right) - if x < k { - let ll = addMutate(l, x, data) - nt.left = ll - } else { - nt.right = addMutate(r, x, data) - } - Some(N.balMutate(nt)) - } - } - -let fromArray = (xs: array<(key, _)>) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref(S.strictlySortedLengthU(xs, (. (x0, _), (y0, _)) => x0 < y0)) - - let result = ref( - if next.contents >= 0 { - N.fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - N.fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - let (k, v) = A.getUnsafe(xs, i) - result.contents = addMutate(result.contents, k, v) - } - result.contents - } -} diff --git a/jscomp/others/belt_internalMapString.res b/jscomp/others/belt_internalMapString.res deleted file mode 100644 index e088f69..0000000 --- a/jscomp/others/belt_internalMapString.res +++ /dev/null @@ -1,288 +0,0 @@ -@@bs.config({flags: ["-bs-noassertfalse"]}) - -type key = string - -module N = Belt_internalAVLtree -module A = Belt_Array -module S = Belt_SortArray - -type t<'a> = N.t - -let rec add = (t, x: key, data: _) => - switch t { - | None => N.singleton(x, data) - | Some(n) => - let k = n.N.key - if x == k { - Some(N.updateValue(n, data)) - } else { - let v = n.N.value - if x < k { - N.bal(add(n.N.left, x, data), k, v, n.N.right) - } else { - N.bal(n.N.left, k, v, add(n.N.right, x, data)) - } - } - } - -let rec get = (n, x: key) => - switch n { - | None => None - | Some(n) => - let v = n.N.key - if x == v { - Some(n.N.value) - } else { - get( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getUndefined = (n, x: key) => - switch n { - | None => Js.undefined - | Some(n) => - let v = n.N.key - if x == v { - Js.Undefined.return(n.N.value) - } else { - getUndefined( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getExn = (n, x: key) => - switch n { - | None => raise(Not_found) - | Some(n) => - let v = n.N.key - if x == v { - n.N.value - } else { - getExn( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getWithDefault = (n, x: key, def) => - switch n { - | None => def - | Some(n) => - let v = n.N.key - if x == v { - n.N.value - } else { - getWithDefault( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - def, - ) - } - } - -let rec has = (n, x: key) => - switch n { - | None => false - | Some(n) /* Node(l, v, d, r, _) */ => - let v = n.N.key - x == v || - has( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - -let rec remove = (n, x: key) => - switch n { - | None => n - | Some(n) => - let {N.left: l, key: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.key), ref(rn.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - } else if x < v { - open N - bal(remove(l, x), v, n.value, r) - } else { - open N - bal(l, v, n.value, remove(r, x)) - } - } - -let rec splitAux = (x: key, n: N.node<_>): (t<_>, option<_>, t<_>) => { - let {N.left: l, key: v, value: d, right: r} = n - if x == v { - (l, Some(d), r) - } else if x < v { - switch l { - | None => (None, None, Some(n)) - | Some(l) => - let (ll, pres, rl) = splitAux(x, l) - (ll, pres, N.join(rl, v, d, r)) - } - } else { - switch r { - | None => (Some(n), None, None) - | Some(r) => - let (lr, pres, rr) = splitAux(x, r) - (N.join(l, v, d, lr), pres, rr) - } - } -} - -let split = (x: key, n) => - switch n { - | None => (None, None, None) - | Some(n) => splitAux(x, n) - } - -let rec mergeU = (s1, s2, f) => - switch (s1, s2) { - | (None, None) => None - | (Some(n) /* (Node (l1, v1, d1, r1, h1), _) */, _) - if n.N.height >= - switch s2 { - | None => 0 - | Some(n) => n.N.height - } => - let {N.left: l1, key: v1, value: d1, right: r1} = n - let (l2, d2, r2) = split(v1, s2) - N.concatOrJoin(mergeU(l1, l2, f), v1, f(. v1, Some(d1), d2), mergeU(r1, r2, f)) - | (_, Some(n)) /* Node (l2, v2, d2, r2, h2) */ => - let {N.left: l2, key: v2, value: d2, right: r2} = n - let (l1, d1, r1) = split(v2, s1) - N.concatOrJoin(mergeU(l1, l2, f), v2, f(. v2, d1, Some(d2)), mergeU(r1, r2, f)) - | _ => assert(false) - } - -let merge = (s1, s2, f) => mergeU(s1, s2, (. a, b, c) => f(a, b, c)) - -let rec compareAux = (e1, e2, vcmp) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = Pervasives.compare((h1.N.key: key), h2.N.key) - if c == 0 { - let cx = vcmp(. h1.N.value, h2.N.value) - if cx == 0 { - compareAux(N.stackAllLeft(h1.N.right, t1), N.stackAllLeft(h2.N.right, t2), vcmp) - } else { - cx - } - } else { - c - } - | (_, _) => 0 - } - -let cmpU = (s1, s2, cmp) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - compareAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{}), cmp) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let cmp = (s1, s2, f) => cmpU(s1, s2, (. a, b) => f(a, b)) - -let rec eqAux = (e1, e2, eq) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - if (h1.N.key: key) == h2.N.key && eq(. h1.N.value, h2.N.value) { - eqAux(N.stackAllLeft(h1.N.right, t1), N.stackAllLeft(h2.N.right, t2), eq) - } else { - false - } - | (_, _) => true - } /* end */ - -let eqU = (s1, s2, eq) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - eqAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{}), eq) - } else { - false - } -} - -let eq = (s1, s2, f) => eqU(s1, s2, (. a, b) => f(a, b)) - -let rec addMutate = (t: t<_>, x, data): t<_> => - switch t { - | None => N.singleton(x, data) - | Some(nt) => - let k = nt.N.key - - /* let c = (Belt_Cmp.getCmpInternal cmp) x k [@bs] in */ - if x == k { - nt.N.key = x - nt.value = data - Some(nt) - } else { - let (l, r) = (nt.N.left, nt.N.right) - if x < k { - let ll = addMutate(l, x, data) - nt.left = ll - } else { - nt.right = addMutate(r, x, data) - } - Some(N.balMutate(nt)) - } - } - -let fromArray = (xs: array<(key, _)>) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref(S.strictlySortedLengthU(xs, (. (x0, _), (y0, _)) => x0 < y0)) - - let result = ref( - if next.contents >= 0 { - N.fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - N.fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - let (k, v) = A.getUnsafe(xs, i) - result.contents = addMutate(result.contents, k, v) - } - result.contents - } -} diff --git a/jscomp/others/belt_internalSetBuckets.res b/jscomp/others/belt_internalSetBuckets.res deleted file mode 100644 index 56fcb8c..0000000 --- a/jscomp/others/belt_internalSetBuckets.res +++ /dev/null @@ -1,161 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. */ -module C = Belt_internalBucketsType -/* TODO: - the current implementation relies on the fact that bucket - empty value is `undefined` in both places, - in theory, it can be different - -*/ -type rec bucket<'a> = { - mutable key: 'a, - mutable next: C.opt>, -} -and t<'hash, 'eq, 'a> = C.container<'hash, 'eq, bucket<'a>> - -module A = Belt_Array - -let rec copy = (x: t<_>): t<_> => { - hash: x.hash, - eq: x.eq, - size: x.size, - buckets: copyBuckets(x.buckets), -} -and copyBuckets = (buckets: array>>) => { - let len = A.length(buckets) - let newBuckets = A.makeUninitializedUnsafe(len) - for i in 0 to len - 1 { - A.setUnsafe(newBuckets, i, copyBucket(A.getUnsafe(buckets, i))) - } - newBuckets -} -and copyBucket = c => - switch C.toOpt(c) { - | None => c - | Some(c) => - let head = { - key: c.key, - next: C.emptyOpt, - } - copyAuxCont(c.next, head) - C.return(head) - } -and copyAuxCont = (c, prec) => - switch C.toOpt(c) { - | None => () - | Some(nc) => - let ncopy = {key: nc.key, next: C.emptyOpt} - prec.next = C.return(ncopy) - copyAuxCont(nc.next, ncopy) - } - -let rec bucketLength = (accu, buckets) => - switch C.toOpt(buckets) { - | None => accu - | Some(cell) => bucketLength(accu + 1, cell.next) - } - -let rec doBucketIter = (~f, buckets) => - switch C.toOpt(buckets) { - | None => () - | Some(cell) => - f(. cell.key) - doBucketIter(~f, cell.next) - } - -let forEachU = (h, f) => { - let d = h.C.buckets - for i in 0 to A.length(d) - 1 { - doBucketIter(~f, A.getUnsafe(d, i)) - } -} - -let forEach = (h, f) => forEachU(h, (. a) => f(a)) - -let rec fillArray = (i, arr, cell) => { - A.setUnsafe(arr, i, cell.key) - switch C.toOpt(cell.next) { - | None => i + 1 - | Some(v) => fillArray(i + 1, arr, v) - } -} - -let toArray = h => { - let d = h.C.buckets - let current = ref(0) - let arr = A.makeUninitializedUnsafe(h.C.size) - for i in 0 to A.length(d) - 1 { - let cell = A.getUnsafe(d, i) - switch C.toOpt(cell) { - | None => () - | Some(cell) => current.contents = fillArray(current.contents, arr, cell) - } - } - arr -} - -let rec doBucketFold = (~f, b, accu) => - switch C.toOpt(b) { - | None => accu - | Some(cell) => doBucketFold(~f, cell.next, f(. accu, cell.key)) - } - -let reduceU = (h, init, f) => { - let d = h.C.buckets - let accu = ref(init) - for i in 0 to A.length(d) - 1 { - accu.contents = doBucketFold(~f, A.getUnsafe(d, i), accu.contents) - } - accu.contents -} - -let reduce = (h, init, f) => reduceU(h, init, (. a, b) => f(a, b)) - -let getMaxBucketLength = h => - A.reduceU(h.C.buckets, 0, (. m, b) => { - let len = bucketLength(0, b) - Pervasives.max(m, len) - }) - -let getBucketHistogram = h => { - let mbl = getMaxBucketLength(h) - let histo = A.makeByU(mbl + 1, (. _) => 0) - A.forEachU(h.C.buckets, (. b) => { - let l = bucketLength(0, b) - A.setUnsafe(histo, l, A.getUnsafe(histo, l) + 1) - }) - histo -} - -let logStats = h => { - let histogram = getBucketHistogram(h) - Js.log({ - "bindings": h.C.size, - "buckets": A.length(h.C.buckets), - "histogram": histogram, - }) -} diff --git a/jscomp/others/belt_internalSetBuckets.resi b/jscomp/others/belt_internalSetBuckets.resi deleted file mode 100644 index bd71b16..0000000 --- a/jscomp/others/belt_internalSetBuckets.resi +++ /dev/null @@ -1,46 +0,0 @@ -/* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module C = Belt_internalBucketsType - -type rec bucket<'a> = { - mutable key: 'a, - mutable next: C.opt>, -} -and t<'hash, 'eq, 'a> = C.container<'hash, 'eq, bucket<'a>> - -let copy: t<'hash, 'eq, 'a> => t<'hash, 'eq, 'a> - -let forEachU: (t<'hash, 'eq, 'a>, (. 'a) => unit) => unit -let forEach: (t<'hash, 'eq, 'a>, 'a => unit) => unit -let fillArray: (int, array<'a>, bucket<'a>) => int - -let toArray: t<_, _, 'a> => array<'a> - -let reduceU: (t<_, _, 'a>, 'b, (. 'b, 'a) => 'b) => 'b -let reduce: (t<_, _, 'a>, 'b, ('b, 'a) => 'b) => 'b - -let logStats: t<_> => unit - -let getBucketHistogram: t<_> => array diff --git a/jscomp/others/belt_internalSetInt.res b/jscomp/others/belt_internalSetInt.res deleted file mode 100644 index 676e955..0000000 --- a/jscomp/others/belt_internalSetInt.res +++ /dev/null @@ -1,164 +0,0 @@ -type value = int -module S = Belt_SortArrayInt - -module N = Belt_internalAVLset -module A = Belt_Array - -type t = N.t - -let rec has = (t: t, x: value) => - switch t { - | None => false - | Some(n) => - let v = n.value - x == v || - has( - if x < v { - n.left - } else { - n.right - }, - x, - ) - } - -let rec compareAux = (e1, e2) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let (k1: value, k2) = (h1.N.value, h2.N.value) - if k1 == k2 { - compareAux(N.stackAllLeft(h1.right, t1), N.stackAllLeft(h2.right, t2)) - } else if k1 < k2 { - -1 - } else { - 1 - } - | (_, _) => 0 - } - -let cmp = (s1, s2) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - compareAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{})) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let eq = (s1: t, s2) => cmp(s1, s2) == 0 - -/* This algorithm applies to BST, it does not need to be balanced tree */ -let rec subset = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) => true - | (_, None) => false - | (Some(t1), Some(t2)) /* Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) */ => - let {N.left: l1, value: v1, right: r1} = t1 - let {N.left: l2, value: v2, right: r2} = t2 - if v1 == v2 { - subset(l1, l2) && subset(r1, r2) - } else if v1 < v2 { - subset(N.create(l1, v1, None), l2) && subset(r1, s2) - } else { - subset(N.create(None, v1, r1), r2) && subset(l1, s2) - } - } - -let rec get = (n: t, x: value) => - switch n { - | None => None - | Some(t) => - let v = t.value - if x == v { - Some(v) - } else { - get( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getUndefined = (n: t, x: value) => - switch n { - | None => Js.undefined - | Some(t) => - let v = t.value - if x == v { - Js.Undefined.return(v) - } else { - getUndefined( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getExn = (n: t, x: value) => - switch n { - | None => raise(Not_found) - | Some(t) => - let v = t.value - if x == v { - v - } else { - getExn( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -/* ************************************************************************** */ -let rec addMutate = (t, x: value) => - switch t { - | None => N.singleton(x) - | Some(nt) => - let k = nt.N.value - if x == k { - t - } else { - let {N.left: l, right: r} = nt - if x < k { - nt.left = addMutate(l, x) - } else { - nt.right = addMutate(r, x) - } - Some(N.balMutate(nt)) - } - } - -let fromArray = (xs: array) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref(S.strictlySortedLength(xs)) - let result = ref( - if next.contents >= 0 { - N.fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - N.fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - result.contents = addMutate(result.contents, A.getUnsafe(xs, i)) - } - result.contents - } -} diff --git a/jscomp/others/belt_internalSetString.res b/jscomp/others/belt_internalSetString.res deleted file mode 100644 index ef38792..0000000 --- a/jscomp/others/belt_internalSetString.res +++ /dev/null @@ -1,164 +0,0 @@ -type value = string -module S = Belt_SortArrayString - -module N = Belt_internalAVLset -module A = Belt_Array - -type t = N.t - -let rec has = (t: t, x: value) => - switch t { - | None => false - | Some(n) => - let v = n.value - x == v || - has( - if x < v { - n.left - } else { - n.right - }, - x, - ) - } - -let rec compareAux = (e1, e2) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let (k1: value, k2) = (h1.N.value, h2.N.value) - if k1 == k2 { - compareAux(N.stackAllLeft(h1.right, t1), N.stackAllLeft(h2.right, t2)) - } else if k1 < k2 { - -1 - } else { - 1 - } - | (_, _) => 0 - } - -let cmp = (s1, s2) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - compareAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{})) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let eq = (s1: t, s2) => cmp(s1, s2) == 0 - -/* This algorithm applies to BST, it does not need to be balanced tree */ -let rec subset = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) => true - | (_, None) => false - | (Some(t1), Some(t2)) /* Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) */ => - let {N.left: l1, value: v1, right: r1} = t1 - let {N.left: l2, value: v2, right: r2} = t2 - if v1 == v2 { - subset(l1, l2) && subset(r1, r2) - } else if v1 < v2 { - subset(N.create(l1, v1, None), l2) && subset(r1, s2) - } else { - subset(N.create(None, v1, r1), r2) && subset(l1, s2) - } - } - -let rec get = (n: t, x: value) => - switch n { - | None => None - | Some(t) => - let v = t.value - if x == v { - Some(v) - } else { - get( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getUndefined = (n: t, x: value) => - switch n { - | None => Js.undefined - | Some(t) => - let v = t.value - if x == v { - Js.Undefined.return(v) - } else { - getUndefined( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getExn = (n: t, x: value) => - switch n { - | None => raise(Not_found) - | Some(t) => - let v = t.value - if x == v { - v - } else { - getExn( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -/* ************************************************************************** */ -let rec addMutate = (t, x: value) => - switch t { - | None => N.singleton(x) - | Some(nt) => - let k = nt.N.value - if x == k { - t - } else { - let {N.left: l, right: r} = nt - if x < k { - nt.left = addMutate(l, x) - } else { - nt.right = addMutate(r, x) - } - Some(N.balMutate(nt)) - } - } - -let fromArray = (xs: array) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref(S.strictlySortedLength(xs)) - let result = ref( - if next.contents >= 0 { - N.fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - N.fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - result.contents = addMutate(result.contents, A.getUnsafe(xs, i)) - } - result.contents - } -} diff --git a/jscomp/others/belt_internals.resi b/jscomp/others/belt_internals.resi deleted file mode 100644 index 2325c1e..0000000 --- a/jscomp/others/belt_internals.resi +++ /dev/null @@ -1,68 +0,0 @@ -// Since [others] depend on this file, its public mli files **should not -// export types** introduced here, otherwise it would cause -// conflicts here. -// -// If the type exported here is also exported in modules from others, -// you will get a type not equivalent. -// -// Types defined here but should not export: -// - ref (make sure not exported in public others/*.mli) - -external \"^": (string, string) => string = "#string_append" -external \"=": ('a, 'a) => bool = "%equal" -external \"<>": ('a, 'a) => bool = "%notequal" -external \"==": ('a, 'a) => bool = "%eq" -external \"!=": ('a, 'a) => bool = "%noteq" -external \"<": ('a, 'a) => bool = "%lessthan" -external \">": ('a, 'a) => bool = "%greaterthan" -external \"<=": ('a, 'a) => bool = "%lessequal" -external \">=": ('a, 'a) => bool = "%greaterequal" -external \"+": (int, int) => int = "%addint" -external \"-": (int, int) => int = "%subint" -external \"~-": int => int = "%negint" -external \"*": (int, int) => int = "%mulint" -external \"/": (int, int) => int = "%divint" -external lsl: (int, int) => int = "%lslint" -external lor: (int, int) => int = "%orint" -external land: (int, int) => int = "%andint" -external mod: (int, int) => int = "%modint" -external lsr: (int, int) => int = "%lsrint" -external lxor: (int, int) => int = "%xorint" -external asr: (int, int) => int = "%asrint" -type ref<'a> = {mutable contents: 'a} -external ref: 'a => ref<'a> = "%makemutable" - -external \"||": (bool, bool) => bool = "%sequor" -external \"&&": (bool, bool) => bool = "%sequand" -external not: bool => bool = "%boolnot" - -external raise: exn => 'a = "%raise" -external ignore: 'a => unit = "%ignore" -external \"|>": ('a, 'a => 'b) => 'b = "%revapply" -external \"@@": ('a => 'b, 'a) => 'b = "%apply" - -@val @scope("Math") external \"**": (float, float) => float = "pow" -external \"~-.": float => float = "%negfloat" -external \"+.": (float, float) => float = "%addfloat" -external \"-.": (float, float) => float = "%subfloat" -external \"*.": (float, float) => float = "%mulfloat" -external \"/.": (float, float) => float = "%divfloat" - -module Obj: { - type t - external field: (t, int) => t = "%obj_field" - external set_field: (t, int, t) => unit = "%obj_set_field" - external tag: t => int = "?obj_tag" - external repr: 'a => t = "%identity" - external obj: t => 'a = "%identity" - external magic: 'a => 'b = "%identity" - external size: t => int = "#obj_length" -} - -module Pervasives: { - external compare: ('a, 'a) => int = "%compare" - external not: bool => bool = "%boolnot" - external min: ('a, 'a) => 'a = "%bs_min" - external max: ('a, 'a) => 'a = "%bs_max" - external \"=": ('a, 'a) => bool = "%equal" -} diff --git a/jscomp/others/dom.res b/jscomp/others/dom.res deleted file mode 100644 index 3667459..0000000 --- a/jscomp/others/dom.res +++ /dev/null @@ -1,295 +0,0 @@ -type _baseClass - -type animation /* Web Animations API */ - -/* TODO: Should we bother with this indirection? -(* core *) -type domString = string -type domTimestamp = float -*/ - -/* css */ -type cssStyleDeclaration -type cssStyleSheet - -/* events (early) */ -type eventTarget_like<'a> -type eventTarget = eventTarget_like<_baseClass> - -/* nodes */ -type _node<'a> -type node_like<'a> = eventTarget_like<_node<'a>> -type node = node_like<_baseClass> -type _attr -type attr = node_like<_attr> -type _characterData<'a> -type characterData_like<'a> = node_like<_characterData<'a>> -type characterData = characterData_like<_baseClass> -type _cdataSection -type cdataSection = characterData_like<_cdataSection> -type _comment -type comment = characterData_like<_comment> -type _document<'a> -type document_like<'a> = node_like<_document<'a>> -type document = document_like<_baseClass> -type _documentFragment -type documentFragment = node_like<_documentFragment> -type _documentType -type documentType = node_like<_documentType> -type domImplementation -type _element<'a> -type element_like<'a> = node_like<_element<'a>> -type element = element_like<_baseClass> -type htmlCollection -type htmlFormControlsCollection -type htmlOptionsCollection -type intersectionObserver -type intersectionObserverEntry -type mutationObserver -type mutationRecord -type performanceObserver -type performanceObserverEntryList -type reportingObserver -type reportingObserverOptions -type resizeObserver -type resizeObserverEntry -type namedNodeMap -type nodeList -type radioNodeList -type processingInstruction -type _shadowRoot -type shadowRoot = node_like<_shadowRoot> -type _text -type text = characterData_like<_text> - -/* geometry */ -type domRect - -/* html */ -type dataTransfer /* Drag and Drop API */ -type domStringMap -type history -type _htmlDocument -type htmlDocument = document_like<_htmlDocument> -type _htmlElement<'a> -type htmlElement_like<'a> = element_like<_htmlElement<'a>> -type htmlElement = htmlElement_like<_baseClass> -type _htmlAnchorElement -type htmlAnchorElement = htmlElement_like<_htmlAnchorElement> -type _htmlAreaElement -type htmlAreaElement = htmlElement_like<_htmlAreaElement> -type _htmlAudioElement -type htmlAudioElement = htmlElement_like<_htmlAudioElement> -type _htmlBaseElement -type htmlBaseElement = htmlElement_like<_htmlBaseElement> -type _htmlBodyElement -type htmlBodyElement = htmlElement_like<_htmlBodyElement> -type _htmlBrElement -type htmlBrElement = htmlElement_like<_htmlBrElement> -type _htmlButtonElement -type htmlButtonElement = htmlElement_like<_htmlButtonElement> -type _htmlCanvasElement -type htmlCanvasElement = htmlElement_like<_htmlCanvasElement> -type _htmlDataElement -type htmlDataElement = htmlElement_like<_htmlDataElement> -type _htmlDataListElement -type htmlDataListElement = htmlElement_like<_htmlDataListElement> -type _htmlDialogElement -type htmlDialogElement = htmlElement_like<_htmlDialogElement> -type _htmlDivElement -type htmlDivElement = htmlElement_like<_htmlDivElement> -type _htmlDlistElement -type htmlDlistElement = htmlElement_like<_htmlDlistElement> -type _htmlEmbedElement -type htmlEmbedElement = htmlElement_like<_htmlEmbedElement> -type _htmlFieldSetElement -type htmlFieldSetElement = htmlElement_like<_htmlFieldSetElement> -type _htmlFormElement -type htmlFormElement = htmlElement_like<_htmlFormElement> -type _htmlHeadElement -type htmlHeadElement = htmlElement_like<_htmlHeadElement> -type _htmlHeadingElement -type htmlHeadingElement = htmlElement_like<_htmlHeadingElement> -type _htmlHrElement -type htmlHrElement = htmlElement_like<_htmlHrElement> -type _htmlHtmlElement -type htmlHtmlElement = htmlElement_like<_htmlHtmlElement> -type _htmlIframeElement -type htmlIframeElement = htmlElement_like<_htmlIframeElement> -type _htmlImageElement -type htmlImageElement = htmlElement_like<_htmlImageElement> -type _htmlInputElement -type htmlInputElement = htmlElement_like<_htmlInputElement> -type _htmlLabelElement -type htmlLabelElement = htmlElement_like<_htmlLabelElement> -type _htmlLegendElement -type htmlLegendElement = htmlElement_like<_htmlLegendElement> -type _htmlLiElement -type htmlLiElement = htmlElement_like<_htmlLiElement> -type _htmlLinkElement -type htmlLinkElement = htmlElement_like<_htmlLinkElement> -type _htmlMapElement -type htmlMapElement = htmlElement_like<_htmlMapElement> -type _htmlMediaElement -type htmlMediaElement = htmlElement_like<_htmlMediaElement> -type _htmlMenuElement -type htmlMenuElement = htmlElement_like<_htmlMenuElement> -type _htmlMetaElement -type htmlMetaElement = htmlElement_like<_htmlMetaElement> -type _htmlMeterElement -type htmlMeterElement = htmlElement_like<_htmlMeterElement> -type _htmlModElement -type htmlModElement = htmlElement_like<_htmlModElement> -type _htmlOListElement -type htmlOListElement = htmlElement_like<_htmlOListElement> -type _htmlObjectElement -type htmlObjectElement = htmlElement_like<_htmlObjectElement> -type _htmlOptGroupElement -type htmlOptGroupElement = htmlElement_like<_htmlOptGroupElement> -type _htmlOptionElement -type htmlOptionElement = htmlElement_like<_htmlOptionElement> -type _htmlOutputElement -type htmlOutputElement = htmlElement_like<_htmlOutputElement> -type _htmlParagraphElement -type htmlParagraphElement = htmlElement_like<_htmlParagraphElement> -type _htmlParamElement -type htmlParamElement = htmlElement_like<_htmlParamElement> -type _htmlPreElement -type htmlPreElement = htmlElement_like<_htmlPreElement> -type _htmlProgressElement -type htmlProgressElement = htmlElement_like<_htmlProgressElement> -type _htmlQuoteElement -type htmlQuoteElement = htmlElement_like<_htmlQuoteElement> -type _htmlScriptElement -type htmlScriptElement = htmlElement_like<_htmlScriptElement> -type _htmlSelectElement -type htmlSelectElement = htmlElement_like<_htmlSelectElement> -type _htmlSlotElement -type htmlSlotElement = htmlElement_like<_htmlSlotElement> -type _htmlSourceElement -type htmlSourceElement = htmlElement_like<_htmlSourceElement> -type _htmlSpanElement -type htmlSpanElement = htmlElement_like<_htmlSpanElement> -type _htmlStyleElement -type htmlStyleElement = htmlElement_like<_htmlStyleElement> -type _htmlTableCaptionElement -type htmlTableCaptionElement = htmlElement_like<_htmlTableCaptionElement> -type _htmlTableCellElement -type htmlTableCellElement = htmlElement_like<_htmlTableCellElement> -type _htmlTableColElement -type htmlTableColElement = htmlElement_like<_htmlTableColElement> -type _htmlTableDataCellElement -type htmlTableDataCellElement = htmlElement_like<_htmlTableDataCellElement> -type _htmlTableElement -type htmlTableElement = htmlElement_like<_htmlTableElement> -type _htmlTableHeaderCellElement -type htmlTableHeaderCellElement = htmlElement_like<_htmlTableHeaderCellElement> -type _htmlTableRowElement -type htmlTableRowElement = htmlElement_like<_htmlTableRowElement> -type _htmlTableSectionElement -type htmlTableSectionElement = htmlElement_like<_htmlTableSectionElement> -type _htmlTextAreaElement -type htmlTextAreaElement = htmlElement_like<_htmlTextAreaElement> -type _htmlTimeElement -type htmlTimeElement = htmlElement_like<_htmlTimeElement> -type _htmlTitleElement -type htmlTitleElement = htmlElement_like<_htmlTitleElement> -type _htmlTrackElement -type htmlTrackElement = htmlElement_like<_htmlTrackElement> -type _htmlUlistElement -type htmlUlistElement = htmlElement_like<_htmlUlistElement> -type _htmlUnknownElement -type htmlUnknownElement = htmlElement_like<_htmlUnknownElement> -type _htmlVideoElement -type htmlVideoElement = htmlElement_like<_htmlVideoElement> -type location -type window -type _xmlDocument -type xmlDocument = document_like<_xmlDocument> - -/* events */ -type event_like<'a> -type event = event_like<_baseClass> -type _uiEvent<'a> -type uiEvent_like<'a> = event_like<_uiEvent<'a>> -type uiEvent = uiEvent_like<_baseClass> -type _animationEvent -type animationEvent = event_like<_animationEvent> -type _beforeUnloadEvent -type beforeUnloadEvent = event_like<_beforeUnloadEvent> -type _clipboardEvent -type clipboardEvent = event_like<_clipboardEvent> -type _closeEvent -type closeEvent = event_like<_closeEvent> -type _compositionEvent -type compositionEvent = uiEvent_like<_compositionEvent> -type _customEvent -type customEvent = event_like<_customEvent> -type _dragEvent -type dragEvent = event_like<_dragEvent> -type _errorEvent -type errorEvent = event_like<_errorEvent> -type _focusEvent -type focusEvent = uiEvent_like<_focusEvent> -type _idbVersionChangeEvent -type idbVersionChangeEvent = event_like<_idbVersionChangeEvent> -type _inputEvent -type inputEvent = uiEvent_like<_inputEvent> -type _keyboardEvent -type keyboardEvent = uiEvent_like<_keyboardEvent> -type _mouseEvent<'a> -type mouseEvent_like<'a> = uiEvent_like<_mouseEvent<'a>> -type mouseEvent = mouseEvent_like<_baseClass> -type _pageTransitionEvent -type pageTransitionEvent = event_like<_pageTransitionEvent> -type _pointerEvent -type pointerEvent = mouseEvent_like<_pointerEvent> -type _popStateEvent -type popStateEvent = event_like<_popStateEvent> -type _progressEvent -type progressEvent = event_like<_progressEvent> -type _relatedEvent -type relatedEvent = event_like<_relatedEvent> -type _storageEvent -type storageEvent = event_like<_storageEvent> -type _svgZoomEvent -type svgZoomEvent = event_like<_svgZoomEvent> -type _timeEvent -type timeEvent = event_like<_timeEvent> -type _touchEvent -type touchEvent = uiEvent_like<_touchEvent> -type _trackEvent -type trackEvent = event_like<_trackEvent> -type _transitionEvent -type transitionEvent = event_like<_transitionEvent> -type _webGlContextEvent -type webGlContextEvent = event_like<_webGlContextEvent> -type _wheelEvent -type wheelEvent = uiEvent_like<_wheelEvent> - -/* ranges */ -type range - -/* selection (TODO: move out of dom?) */ -type selection - -/* sets */ -type domTokenList -type domSettableTokenList - -/* traversal */ -type nodeFilter = { - acceptNode: element => int /* return type should be NodeFilter.action, but that would create a cycle */, -} -type nodeIterator -type treeWalker - -/* SVG */ -type svgRect -type svgPoint - -/* special */ -type eventPointerId - -module Storage = Dom_storage -module Storage2 = Dom_storage2 diff --git a/jscomp/others/dom_storage.res b/jscomp/others/dom_storage.res deleted file mode 100644 index 7f1f0bc..0000000 --- a/jscomp/others/dom_storage.res +++ /dev/null @@ -1,22 +0,0 @@ -type t = Dom_storage2.t - -@send @return(null_to_opt) external getItem: (t, string) => option = "getItem" -let getItem = (s, obj) => obj->getItem(s) -/* https://developer.mozilla.org/en-US/docs/Web/API/Storage/getItem - If the key does not exist, `null` is returned -*/ - -@send external setItem: (t, string, string) => unit = "setItem" -let setItem = (k, v, obj): unit => obj->setItem(k, v) -@send external removeItem: (t, string) => unit = "removeItem" -let removeItem = (s, obj): unit => obj->removeItem(s) -@send external clear: t => unit = "clear" -@send @return(null_to_opt) external key: (t, int) => option = "key" -/* A DOMString containing the name of the key. If the index does not exist, null is returned. - If the key does not exist, `null` is returned -*/ -let key = (i, obj): option => obj->key(i) -@get external length: t => int = "length" - -@val external localStorage: t = "localStorage" -@val external sessionStorage: t = "sessionStorage" diff --git a/jscomp/others/dom_storage2.res b/jscomp/others/dom_storage2.res deleted file mode 100644 index 33a0fc4..0000000 --- a/jscomp/others/dom_storage2.res +++ /dev/null @@ -1,11 +0,0 @@ -type t - -@send @return(null_to_opt) external getItem: (t, string) => option = "getItem" -@send external setItem: (t, string, string) => unit = "setItem" -@send external removeItem: (t, string) => unit = "removeItem" -@send external clear: t => unit = "clear" -@send @return(null_to_opt) external key: (t, int) => option = "key" -@get external length: t => int = "length" - -@val external localStorage: t = "localStorage" -@val external sessionStorage: t = "sessionStorage" diff --git a/jscomp/others/hashmap.cppo.res b/jscomp/others/hashmap.cppo.res deleted file mode 100644 index e5de8ed..0000000 --- a/jscomp/others/hashmap.cppo.res +++ /dev/null @@ -1,225 +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 Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/* ********************************************************************* */ - -/* Adapted by Hongbo Zhang, Authors of ReScript 2017 */ - -#ifdef TYPE_STRING -type key = string -type seed = int -external caml_hash_mix_string: (seed, string) => seed = "?hash_mix_string" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_string(0, s)) -#elif defined TYPE_INT -type key = int -type seed = int -external caml_hash_mix_int: (seed, int) => seed = "?hash_mix_int" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_int(0, s)) -#else -[%error "unknown type"] -#endif - -module N = Belt_internalBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type t<'b> = N.t - -let rec copyBucketReHash = (~h_buckets, ~ndata_tail, old_bucket: C.opt>) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(hash(cell.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucketReHash(~h_buckets, ~ndata_tail, cell.next) - } - -let resize = h => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.C.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucketReHash(~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.next = C.emptyOpt - } - } - } -} - -let rec replaceInBucket = (key: key, info, cell) => - if cell.N.key == key { - cell.N.value = info - false - } else { - switch C.toOpt(cell.next) { - | None => true - | Some(cell) => replaceInBucket(key, info, cell) - } - } - -let set = (h, key: key, value) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(hash(key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: C.emptyOpt})) - h.C.size = h.C.size + 1 - | Some(bucket) => - if replaceInBucket(key, value, bucket) { - A.setUnsafe(h_buckets, i, C.return({N.key, value, next: l})) - h.C.size = h.C.size + 1 - } - } - if h.C.size > lsl(buckets_len, 1) { - resize(h) - } -} - -let rec removeInBucket = (h, h_buckets, i, key: key, prec, buckets) => - switch C.toOpt(buckets) { - | None => () - | Some(cell) => - let cell_next = cell.N.next - if cell.N.key == key { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - removeInBucket(h, h_buckets, i, key, cell, cell_next) - } - } - -let remove = (h, key) => { - let h_buckets = h.C.buckets - let i = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, i) - switch C.toOpt(bucket) { - | None => () - | Some(cell) => - if cell.N.key == key { - A.setUnsafe(h_buckets, i, cell.next) - h.C.size = h.C.size - 1 - } else { - removeInBucket(h, h_buckets, i, key, cell, cell.next) - } - } -} - -let rec getAux = (key: key, buckets) => - switch C.toOpt(buckets) { - | None => None - | Some(cell) => - if key == cell.N.key { - Some(cell.N.value) - } else { - getAux(key, cell.next) - } - } - -let get = (h, key: key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - switch C.toOpt(A.getUnsafe(h_buckets, nid)) { - | None => None - | Some(cell1) => - if key == cell1.N.key { - Some(cell1.N.value) - } else { - switch C.toOpt(cell1.N.next) { - | None => None - | Some(cell2) => - if key == cell2.N.key { - Some(cell2.N.value) - } else { - switch C.toOpt(cell2.N.next) { - | None => None - | Some(cell3) => - if key == cell3.N.key { - Some(cell3.N.value) - } else { - getAux(key, cell3.N.next) - } - } - } - } - } - } -} - -let rec memInBucket = (key: key, cell) => - cell.N.key == key || - switch C.toOpt(cell.next) { - | None => false - | Some(nextCell) => memInBucket(key, nextCell) - } - -let has = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(key, bucket) - } -} - -let make = (~hintSize) => C.make(~hintSize, ~hash=(), ~eq=()) -let clear = C.clear -let size = h => h.C.size -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let logStats = N.logStats -let keepMapInPlaceU = N.keepMapInPlaceU -let keepMapInPlace = N.keepMapInPlace -let toArray = N.toArray -let copy = N.copy -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let fromArray = arr => { - let len = A.length(arr) - let v = make(~hintSize=len) - for i in 0 to len - 1 { - let (k, value) = A.getUnsafe(arr, i) - set(v, k, value) - } - v -} - -/* TOOD: optimize heuristics for resizing */ -let mergeMany = (h, arr) => { - let len = A.length(arr) - for i in 0 to len - 1 { - let (k, v) = A.getUnsafe(arr, i) - set(h, k, v) - } -} diff --git a/jscomp/others/hashmap.cppo.resi b/jscomp/others/hashmap.cppo.resi deleted file mode 100644 index a6ce4e6..0000000 --- a/jscomp/others/hashmap.cppo.resi +++ /dev/null @@ -1,47 +0,0 @@ -#ifdef TYPE_STRING -type key = string -#elif defined TYPE_INT -type key = int -#else -[%error "unknown type"] -#endif - -type t<'b> - -let make: (~hintSize: int) => t<'b> - -let clear: t<'b> => unit - -let isEmpty: t<_> => bool - -/** -`setDone(tbl, k, v)` if `k` does not exist, add the binding `k,v`, otherwise, -update the old value with the new `v` -*/ -let set: (t<'a>, key, 'a) => unit - -let copy: t<'a> => t<'a> -let get: (t<'a>, key) => option<'a> - -let has: (t<'b>, key) => bool - -let remove: (t<'a>, key) => unit - -let forEachU: (t<'b>, (. key, 'b) => unit) => unit -let forEach: (t<'b>, (key, 'b) => unit) => unit - -let reduceU: (t<'b>, 'c, (. 'c, key, 'b) => 'c) => 'c -let reduce: (t<'b>, 'c, ('c, key, 'b) => 'c) => 'c - -let keepMapInPlaceU: (t<'a>, (. key, 'a) => option<'a>) => unit -let keepMapInPlace: (t<'a>, (key, 'a) => option<'a>) => unit - -let size: t<_> => int - -let toArray: t<'a> => array<(key, 'a)> -let keysToArray: t<'a> => array -let valuesToArray: t<'a> => array<'a> -let fromArray: array<(key, 'a)> => t<'a> -let mergeMany: (t<'a>, array<(key, 'a)>) => unit -let getBucketHistogram: t<_> => array -let logStats: t<_> => unit diff --git a/jscomp/others/hashset.cppo.res b/jscomp/others/hashset.cppo.res deleted file mode 100644 index af73488..0000000 --- a/jscomp/others/hashset.cppo.res +++ /dev/null @@ -1,164 +0,0 @@ -#ifdef TYPE_STRING -type key = string -type seed = int -external caml_hash_mix_string: (seed, string) => seed = "?hash_mix_string" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_string(0, s)) -#elif defined TYPE_INT -type key = int -type seed = int -external caml_hash_mix_int: (seed, int) => seed = "?hash_mix_int" -external final_mix: seed => seed = "?hash_final_mix" -let hash = (s: key) => final_mix(caml_hash_mix_int(0, s)) -#else -[%error "unknown type"] -#endif - -module N = Belt_internalSetBuckets -module C = Belt_internalBucketsType -module A = Belt_Array - -type t = N.t - -let rec copyBucket = (~h_buckets, ~ndata_tail, old_bucket) => - switch C.toOpt(old_bucket) { - | None => () - | Some(cell) => - let nidx = land(hash(cell.N.key), A.length(h_buckets) - 1) - let v = C.return(cell) - switch C.toOpt(A.getUnsafe(ndata_tail, nidx)) { - | None => A.setUnsafe(h_buckets, nidx, v) - | Some(tail) => tail.N.next = v /* cell put at the end */ - } - A.setUnsafe(ndata_tail, nidx, v) - copyBucket(~h_buckets, ~ndata_tail, cell.N.next) - } - -let tryDoubleResize = h => { - let odata = h.C.buckets - let osize = A.length(odata) - let nsize = osize * 2 - if nsize >= osize { - /* no overflow */ - let h_buckets = A.makeUninitialized(nsize) - let ndata_tail = A.makeUninitialized(nsize) /* keep track of tail */ - h.C.buckets = h_buckets /* so that indexfun sees the new bucket count */ - for i in 0 to osize - 1 { - copyBucket(~h_buckets, ~ndata_tail, A.getUnsafe(odata, i)) - } - for i in 0 to nsize - 1 { - switch C.toOpt(A.getUnsafe(ndata_tail, i)) { - | None => () - | Some(tail) => tail.N.next = C.emptyOpt - } - } - } -} - -let rec removeBucket = (h, h_buckets, i, key: key, prec, cell) => { - let cell_next = cell.N.next - if cell.N.key == key { - prec.N.next = cell_next - h.C.size = h.C.size - 1 - } else { - switch C.toOpt(cell_next) { - | None => () - | Some(cell_next) => removeBucket(h, h_buckets, i, key, cell, cell_next) - } - } -} - -let remove = (h, key: key) => { - let h_buckets = h.C.buckets - let i = land(hash(key), A.length(h_buckets) - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => () - | Some(cell) => - let next_cell = cell.N.next - if cell.N.key == key { - h.C.size = h.C.size - 1 - A.setUnsafe(h_buckets, i, next_cell) - } else { - switch C.toOpt(next_cell) { - | None => () - | Some(next_cell) => removeBucket(h, h_buckets, i, key, cell, next_cell) - } - } - } -} - -let rec addBucket = (h, key: key, cell) => - if cell.N.key != key { - let n = cell.N.next - switch C.toOpt(n) { - | None => - h.C.size = h.C.size + 1 - cell.N.next = C.return({N.key, next: C.emptyOpt}) - | Some(n) => addBucket(h, key, n) - } - } - -let add = (h, key: key) => { - let h_buckets = h.C.buckets - let buckets_len = A.length(h_buckets) - let i = land(hash(key), buckets_len - 1) - let l = A.getUnsafe(h_buckets, i) - switch C.toOpt(l) { - | None => - A.setUnsafe(h_buckets, i, C.return({N.key, next: C.emptyOpt})) - h.C.size = h.C.size + 1 - | Some(cell) => addBucket(h, key, cell) - } - if h.C.size > lsl(buckets_len, 1) { - tryDoubleResize(h) - } -} - -let rec memInBucket = (key: key, cell) => - cell.N.key == key || - switch C.toOpt(cell.N.next) { - | None => false - | Some(nextCell) => memInBucket(key, nextCell) - } - -let has = (h, key) => { - let h_buckets = h.C.buckets - let nid = land(hash(key), A.length(h_buckets) - 1) - let bucket = A.getUnsafe(h_buckets, nid) - switch C.toOpt(bucket) { - | None => false - | Some(bucket) => memInBucket(key, bucket) - } -} - -let make = (~hintSize) => C.make(~hintSize, ~hash=(), ~eq=()) - -let clear = C.clear -let size = h => h.C.size -let forEachU = N.forEachU -let forEach = N.forEach -let reduceU = N.reduceU -let reduce = N.reduce -let logStats = N.logStats -let toArray = N.toArray -let copy = N.copy -let getBucketHistogram = N.getBucketHistogram -let isEmpty = C.isEmpty - -let fromArray = arr => { - let len = A.length(arr) - let v = C.make(~hintSize=len, ~hash=(), ~eq=()) - for i in 0 to len - 1 { - add(v, A.getUnsafe(arr, i)) - } - v -} - -/* TOOD: optimize heuristics for resizing */ -let mergeMany = (h, arr) => { - let len = A.length(arr) - for i in 0 to len - 1 { - add(h, A.getUnsafe(arr, i)) - } -} diff --git a/jscomp/others/hashset.cppo.resi b/jscomp/others/hashset.cppo.resi deleted file mode 100644 index a410122..0000000 --- a/jscomp/others/hashset.cppo.resi +++ /dev/null @@ -1,74 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** - This module is [`Belt.HashSet`]() specialized with key type to be a primitive type. - - It is more efficient in general, the API is the same with [`Belt.HashSet`]() except its key type is fixed, - and identity is not needed(using the built-in one) - - **See** [`Belt.HashSet`]() -*/ - -#ifdef TYPE_STRING -type key = string -#elif defined TYPE_INT -type key = int -#else -[%error "unknown type"] -#endif - -type t - -let make: (~hintSize: int) => t - -let clear: t => unit - -let isEmpty: t => bool - -let add: (t, key) => unit - -let copy: t => t - -let has: (t, key) => bool - -let remove: (t, key) => unit - -let forEachU: (t, (. key) => unit) => unit -let forEach: (t, key => unit) => unit - -let reduceU: (t, 'c, (. 'c, key) => 'c) => 'c -let reduce: (t, 'c, ('c, key) => 'c) => 'c - -let size: t => int - -let logStats: t => unit - -let toArray: t => array - -let fromArray: array => t - -let mergeMany: (t, array) => unit - -let getBucketHistogram: t => array diff --git a/jscomp/others/internal_map.cppo.res b/jscomp/others/internal_map.cppo.res deleted file mode 100644 index 0afe893..0000000 --- a/jscomp/others/internal_map.cppo.res +++ /dev/null @@ -1,294 +0,0 @@ -@@bs.config({flags: ["-bs-noassertfalse"]}) - -#ifdef TYPE_STRING -type key = string -#elif defined TYPE_INT -type key = int -#else -[%error "unknown type"] -#endif - -module N = Belt_internalAVLtree -module A = Belt_Array -module S = Belt_SortArray - -type t<'a> = N.t - -let rec add = (t, x: key, data: _) => - switch t { - | None => N.singleton(x, data) - | Some(n) => - let k = n.N.key - if x == k { - Some(N.updateValue(n, data)) - } else { - let v = n.N.value - if x < k { - N.bal(add(n.N.left, x, data), k, v, n.N.right) - } else { - N.bal(n.N.left, k, v, add(n.N.right, x, data)) - } - } - } - -let rec get = (n, x: key) => - switch n { - | None => None - | Some(n) => - let v = n.N.key - if x == v { - Some(n.N.value) - } else { - get( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getUndefined = (n, x: key) => - switch n { - | None => Js.undefined - | Some(n) => - let v = n.N.key - if x == v { - Js.Undefined.return(n.N.value) - } else { - getUndefined( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getExn = (n, x: key) => - switch n { - | None => raise(Not_found) - | Some(n) => - let v = n.N.key - if x == v { - n.N.value - } else { - getExn( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - } - -let rec getWithDefault = (n, x: key, def) => - switch n { - | None => def - | Some(n) => - let v = n.N.key - if x == v { - n.N.value - } else { - getWithDefault( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - def, - ) - } - } - -let rec has = (n, x: key) => - switch n { - | None => false - | Some(n) /* Node(l, v, d, r, _) */ => - let v = n.N.key - x == v || - has( - if x < v { - n.N.left - } else { - n.N.right - }, - x, - ) - } - -let rec remove = (n, x: key) => - switch n { - | None => n - | Some(n) => - let {N.left: l, key: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.key), ref(rn.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - } else if x < v { - open N - bal(remove(l, x), v, n.value, r) - } else { - open N - bal(l, v, n.value, remove(r, x)) - } - } - -let rec splitAux = (x: key, n: N.node<_>): (t<_>, option<_>, t<_>) => { - let {N.left: l, key: v, value: d, right: r} = n - if x == v { - (l, Some(d), r) - } else if x < v { - switch l { - | None => (None, None, Some(n)) - | Some(l) => - let (ll, pres, rl) = splitAux(x, l) - (ll, pres, N.join(rl, v, d, r)) - } - } else { - switch r { - | None => (Some(n), None, None) - | Some(r) => - let (lr, pres, rr) = splitAux(x, r) - (N.join(l, v, d, lr), pres, rr) - } - } -} - -let split = (x: key, n) => - switch n { - | None => (None, None, None) - | Some(n) => splitAux(x, n) - } - -let rec mergeU = (s1, s2, f) => - switch (s1, s2) { - | (None, None) => None - | (Some(n) /* (Node (l1, v1, d1, r1, h1), _) */, _) - if n.N.height >= - switch s2 { - | None => 0 - | Some(n) => n.N.height - } => - let {N.left: l1, key: v1, value: d1, right: r1} = n - let (l2, d2, r2) = split(v1, s2) - N.concatOrJoin(mergeU(l1, l2, f), v1, f(. v1, Some(d1), d2), mergeU(r1, r2, f)) - | (_, Some(n)) /* Node (l2, v2, d2, r2, h2) */ => - let {N.left: l2, key: v2, value: d2, right: r2} = n - let (l1, d1, r1) = split(v2, s1) - N.concatOrJoin(mergeU(l1, l2, f), v2, f(. v2, d1, Some(d2)), mergeU(r1, r2, f)) - | _ => assert(false) - } - -let merge = (s1, s2, f) => mergeU(s1, s2, (. a, b, c) => f(a, b, c)) - -let rec compareAux = (e1, e2, vcmp) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = Pervasives.compare((h1.N.key: key), h2.N.key) - if c == 0 { - let cx = vcmp(. h1.N.value, h2.N.value) - if cx == 0 { - compareAux(N.stackAllLeft(h1.N.right, t1), N.stackAllLeft(h2.N.right, t2), vcmp) - } else { - cx - } - } else { - c - } - | (_, _) => 0 - } - -let cmpU = (s1, s2, cmp) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - compareAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{}), cmp) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let cmp = (s1, s2, f) => cmpU(s1, s2, (. a, b) => f(a, b)) - -let rec eqAux = (e1, e2, eq) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - if (h1.N.key: key) == h2.N.key && eq(. h1.N.value, h2.N.value) { - eqAux(N.stackAllLeft(h1.N.right, t1), N.stackAllLeft(h2.N.right, t2), eq) - } else { - false - } - | (_, _) => true - } /* end */ - -let eqU = (s1, s2, eq) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - eqAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{}), eq) - } else { - false - } -} - -let eq = (s1, s2, f) => eqU(s1, s2, (. a, b) => f(a, b)) - -let rec addMutate = (t: t<_>, x, data): t<_> => - switch t { - | None => N.singleton(x, data) - | Some(nt) => - let k = nt.N.key - - /* let c = (Belt_Cmp.getCmpInternal cmp) x k [@bs] in */ - if x == k { - nt.N.key = x - nt.value = data - Some(nt) - } else { - let (l, r) = (nt.N.left, nt.N.right) - if x < k { - let ll = addMutate(l, x, data) - nt.left = ll - } else { - nt.right = addMutate(r, x, data) - } - Some(N.balMutate(nt)) - } - } - -let fromArray = (xs: array<(key, _)>) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref(S.strictlySortedLengthU(xs, (. (x0, _), (y0, _)) => x0 < y0)) - - let result = ref( - if next.contents >= 0 { - N.fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - N.fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - let (k, v) = A.getUnsafe(xs, i) - result.contents = addMutate(result.contents, k, v) - } - result.contents - } -} diff --git a/jscomp/others/internal_set.cppo.res b/jscomp/others/internal_set.cppo.res deleted file mode 100644 index 944ec29..0000000 --- a/jscomp/others/internal_set.cppo.res +++ /dev/null @@ -1,171 +0,0 @@ -#ifdef TYPE_STRING -type value = string -module S = Belt_SortArrayString -#elif defined TYPE_INT -type value = int -module S = Belt_SortArrayInt -#else -[%error "unknown type"] -#endif - -module N = Belt_internalAVLset -module A = Belt_Array - -type t = N.t - -let rec has = (t: t, x: value) => - switch t { - | None => false - | Some(n) => - let v = n.value - x == v || - has( - if x < v { - n.left - } else { - n.right - }, - x, - ) - } - -let rec compareAux = (e1, e2) => - switch (e1, e2) { - | (list{h1, ...t1}, list{h2, ...t2}) => - let (k1: value, k2) = (h1.N.value, h2.N.value) - if k1 == k2 { - compareAux(N.stackAllLeft(h1.right, t1), N.stackAllLeft(h2.right, t2)) - } else if k1 < k2 { - -1 - } else { - 1 - } - | (_, _) => 0 - } - -let cmp = (s1, s2) => { - let (len1, len2) = (N.size(s1), N.size(s2)) - if len1 == len2 { - compareAux(N.stackAllLeft(s1, list{}), N.stackAllLeft(s2, list{})) - } else if len1 < len2 { - -1 - } else { - 1 - } -} - -let eq = (s1: t, s2) => cmp(s1, s2) == 0 - -/* This algorithm applies to BST, it does not need to be balanced tree */ -let rec subset = (s1: t, s2: t) => - switch (s1, s2) { - | (None, _) => true - | (_, None) => false - | (Some(t1), Some(t2)) /* Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) */ => - let {N.left: l1, value: v1, right: r1} = t1 - let {N.left: l2, value: v2, right: r2} = t2 - if v1 == v2 { - subset(l1, l2) && subset(r1, r2) - } else if v1 < v2 { - subset(N.create(l1, v1, None), l2) && subset(r1, s2) - } else { - subset(N.create(None, v1, r1), r2) && subset(l1, s2) - } - } - -let rec get = (n: t, x: value) => - switch n { - | None => None - | Some(t) => - let v = t.value - if x == v { - Some(v) - } else { - get( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getUndefined = (n: t, x: value) => - switch n { - | None => Js.undefined - | Some(t) => - let v = t.value - if x == v { - Js.Undefined.return(v) - } else { - getUndefined( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -let rec getExn = (n: t, x: value) => - switch n { - | None => raise(Not_found) - | Some(t) => - let v = t.value - if x == v { - v - } else { - getExn( - if x < v { - t.left - } else { - t.right - }, - x, - ) - } - } - -/* ************************************************************************** */ -let rec addMutate = (t, x: value) => - switch t { - | None => N.singleton(x) - | Some(nt) => - let k = nt.N.value - if x == k { - t - } else { - let {N.left: l, right: r} = nt - if x < k { - nt.left = addMutate(l, x) - } else { - nt.right = addMutate(r, x) - } - Some(N.balMutate(nt)) - } - } - -let fromArray = (xs: array) => { - let len = A.length(xs) - if len == 0 { - None - } else { - let next = ref(S.strictlySortedLength(xs)) - let result = ref( - if next.contents >= 0 { - N.fromSortedArrayAux(xs, 0, next.contents) - } else { - next.contents = -next.contents - N.fromSortedArrayRevAux(xs, next.contents - 1, next.contents) - }, - ) - for i in next.contents to len - 1 { - result.contents = addMutate(result.contents, A.getUnsafe(xs, i)) - } - result.contents - } -} diff --git a/jscomp/others/intro.txt b/jscomp/others/intro.txt deleted file mode 100644 index 768a12b..0000000 --- a/jscomp/others/intro.txt +++ /dev/null @@ -1,37 +0,0 @@ -{!indexlist} - -{1 Libraries shipped with ReScript} - -ReScript is mostly a compiler, but it does ship some libraries for users' convenience - -{2 4 libraries} - -{!Js} - -This library are mostly {i bindings} to JS, it should work with both NodeJS and Browser. -It is strongly recommended to use qualified name instead of flatten module name. -For example -{[ - [| 1; 2 ; 3 |] - |> Js.Array.map (fun x -> x + 1 ) - |> Js.log -]} - -{!Belt} - -The ReScript standard library ({b beta}). - -ReScript also ships the vanilla OCaml standard library. -@see OCaml standard library - -{!Node} - -This library contains bindings to NodeJS, it is still work in progress, use it with care, -and we may break API backward compatiblity in the future. - -{!Dom} - -This library are for DOM API, currently it only defines some -types for diferent packages to talk to each other - - diff --git a/jscomp/others/js.ml b/jscomp/others/js.ml deleted file mode 100644 index d3224d1..0000000 --- a/jscomp/others/js.ml +++ /dev/null @@ -1,296 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@bs.config { flags = [| "-unboxed-types"; "-w"; "-49" |] }] -(* DESIGN: - - It does not have any code, all its code will be inlined so that - there will never be - {[ require('js')]} - - Its interface should be minimal -*) - -(** -The Js module mostly contains ReScript bindings to _standard JavaScript APIs_ -like [console.log](https://developer.mozilla.org/en-US/docs/Web/API/Console/log), -or the JavaScript -[String](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String), -[Date](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date), and -[Promise](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Promise) -classes. - -It is meant as a zero-abstraction interop layer and directly exposes JavaScript functions as they are. If you can find your API in this module, prefer this over an equivalent Belt helper. For example, prefer [Js.Array2](js/array2) over [Belt.Array](belt/array) - -## Argument Order - -For historical reasons, some APIs in the Js namespace (e.g. [Js.String](js/string)) are -using the data-last argument order whereas others (e.g. [Js.Date](js/date)) are using data-first. - -For more information about these argument orders and the trade-offs between them, see -[this blog post](https://www.javierchavarri.com/data-first-and-data-last-a-comparison/). - -_Eventually, all modules in the Js namespace are going to be migrated to data-first though._ - -In the meantime, there are several options for dealing with the data-last APIs: - -## Examples - -```rescript -/* Js.String (data-last API used with pipe last operator) */ -Js.log("2019-11-10" |> Js.String.split("-")) -Js.log("ReScript" |> Js.String.startsWith("Re")) - -/* Js.String (data-last API used with pipe first operator) */ -Js.log("2019-11-10"->Js.String.split("-", _)) -Js.log("ReScript"->Js.String.startsWith("Re", _)) - -/* Js.String (data-last API used without any piping) */ -Js.log(Js.String.split("-", "2019-11-10")) -Js.log(Js.String.startsWith("Re", "ReScript")) -``` -## Js.Xxx2 Modules - -Prefer `Js.Array2` over `Js.Array`, `Js.String2` over `Js.String`, etc. The latters are old modules. -*) - -type 'a t = < .. > as 'a -(** JS object type *) - -module MapperRt = Js_mapperRt - -module Internal = struct - external opaqueFullApply : 'a -> 'a = "%uncurried_apply" - - (* Use opaque instead of [._n] to prevent some optimizations happening *) - external run : (unit -> 'a [@bs]) -> 'a = "#run" - external opaque : 'a -> 'a = "%opaque" -end - -(**/**) - -type +'a null = - | Value of 'a - | Null [@as null] -[@@unboxed] -(** - Nullable value of this type can be either null or 'a. This type is equivalent to Js.Null.t. -*) - -type +'a undefined -(** - A value of this type can be either undefined or 'a. This type is equivalent to Js.Undefined.t. -*) - -type +'a nullable = - | Value of 'a - | Null [@as null] - | Undefined [@as undefined] -[@@unboxed] - -(** - A value of this type can be undefined, null or 'a. This type is equivalent to Js.Null_undefined.t. -*) - -type +'a null_undefined = 'a nullable - -external toOption : 'a nullable -> 'a option = "#nullable_to_opt" -external undefinedToOption : 'a undefined -> 'a option = "#undefined_to_opt" -external nullToOption : 'a null -> 'a option = "#null_to_opt" -external isNullable : 'a nullable -> bool = "#is_nullable" -external import : 'a -> 'a promise = "#import" - -external testAny : 'a -> bool = "#is_nullable" -(** The same as {!test} except that it is more permissive on the types of input *) - -type (+'a, +'e) promise -(** - The promise type, defined here for interoperation across packages. -*) - -external null : 'a null = "#null" -(** - The same as empty in `Js.Null`. Compiles to `null`. -*) - -external undefined : 'a undefined = "#undefined" -(** - The same as empty `Js.Undefined`. Compiles to `undefined`. -*) - -external typeof : 'a -> string = "#typeof" -(** -`typeof x` will be compiled as `typeof x` in JS. Please consider functions in -`Js.Types` for a type safe way of reflection. -*) - -external log : 'a -> unit = "log" - [@@val] [@@scope "console"] -(** Equivalent to console.log any value. *) - -external log2 : 'a -> 'b -> unit = "log" [@@bs.val] [@@bs.scope "console"] -external log3 : 'a -> 'b -> 'c -> unit = "log" [@@bs.val] [@@bs.scope "console"] - -external log4 : 'a -> 'b -> 'c -> 'd -> unit = "log" - [@@bs.val] [@@bs.scope "console"] - -external logMany : 'a array -> unit = "log" - [@@bs.val] [@@bs.scope "console"] [@@bs.splice] -(** A convenience function to console.log more than 4 arguments *) - -external eqNull : 'a -> 'a null -> bool = "%bs_equal_null" -external eqUndefined : 'a -> 'a undefined -> bool = "%bs_equal_undefined" -external eqNullable : 'a -> 'a nullable -> bool = "%bs_equal_nullable" - -(** ## Operators *) - -external unsafe_lt : 'a -> 'a -> bool = "#unsafe_lt" -(** - `unsafe_lt(a, b)` will be compiled as `a < b`. - It is marked as unsafe, since it is impossible - to give a proper semantics for comparision which applies to any type -*) - -external unsafe_le : 'a -> 'a -> bool = "#unsafe_le" -(** - `unsafe_le(a, b)` will be compiled as `a <= b`. - See also `Js.unsafe_lt`. -*) - -external unsafe_gt : 'a -> 'a -> bool = "#unsafe_gt" -(** - `unsafe_gt(a, b)` will be compiled as `a > b`. - See also `Js.unsafe_lt`. -*) - -external unsafe_ge : 'a -> 'a -> bool = "#unsafe_ge" -(** - `unsafe_ge(a, b)` will be compiled as `a >= b`. - See also `Js.unsafe_lt`. -*) - -(** ## Nested Modules *) - -module Null = Js_null -(** Provide utilities for `Js.null<'a>` *) - -module Undefined = Js_undefined -(** Provide utilities for `Js.undefined<'a>` *) - -module Nullable = Js_null_undefined -(** Provide utilities for `Js.null_undefined` *) - -module Null_undefined = Js_null_undefined -[@deprecated "Please use `Js.Nullable`"] - -module Exn = Js_exn -(** Provide utilities for dealing with Js exceptions *) - -module Array = Js_array -(** Provide bindings to JS array*) - -module Array2 = Js_array2 -(** Provide bindings to JS array*) - -module String = Js_string -(** Provide bindings to JS string *) - -module String2 = Js_string2 -(** Provide bindings to JS string *) - -module Re = Js_re -(** Provide bindings to JS regex expression *) - -module Promise = Js_promise -(** Provide bindings to JS Promise *) - -module Promise2 = Js_promise2 -(** Provide bindings to JS Promise *) - -module Date = Js_date -(** Provide bindings for JS Date *) - -module Dict = Js_dict -(** Provide utilities for JS dictionary object *) - -module Global = Js_global -(** Provide bindings to JS global functions in global namespace*) - -module Json = Js_json -(** Provide utilities for json *) - -module Math = Js_math -(** Provide bindings for JS `Math` object *) - -module Obj = Js_obj -(** Provide utilities for `Js.t` *) - -module Typed_array = Js_typed_array -(** Provide bindings for JS typed array *) - -module TypedArray2 = Js_typed_array2 -(** Provide bindings for JS typed array *) - -module Types = Js_types -(** Provide utilities for manipulating JS types *) - -module Float = Js_float -(** Provide utilities for JS float *) - -module Int = Js_int -(** Provide utilities for int *) - -module BigInt = Js_bigint -(** Provide utilities for bigint *) - -module File = Js_file -(** Provide utilities for File *) - -module Blob = Js_blob -(** Provide utilities for Blob *) - -module Option = Js_option -(** Provide utilities for option *) - -module Result = Js_result -(** Define the interface for result *) - -module List = Js_list -(** Provide utilities for list *) - -module Vector = Js_vector -(** Provides bindings for JS Vector *) - -module Console = Js_console -(** Provides bindings for console *) - -module Set = Js_set -(** Provides bindings for ES6 Set *) - -module WeakSet = Js_weakset -(** Provides bindings for ES6 WeakSet *) - -module Map = Js_map -(** Provides bindings for ES6 Map *) - -module WeakMap = Js_weakmap -(** Provides bindings for ES6 WeakMap *) diff --git a/jscomp/others/js_OO.res b/jscomp/others/js_OO.res deleted file mode 100644 index e568c95..0000000 --- a/jscomp/others/js_OO.res +++ /dev/null @@ -1,52 +0,0 @@ -/* Copyright (C) 2020- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@@bs.config({flags: ["-unboxed-types"]}) - -external unsafe_to_method: 'a => 'a = "#fn_method" - -module Callback = { - type arity1<'a> = {@internal i1: 'a} - type arity2<'a> = {@internal i2: 'a} - type arity3<'a> = {@internal i3: 'a} - type arity4<'a> = {@internal i4: 'a} - type arity5<'a> = {@internal i5: 'a} - type arity6<'a> = {@internal i6: 'a} - type arity7<'a> = {@internal i7: 'a} - type arity8<'a> = {@internal i8: 'a} - type arity9<'a> = {@internal i9: 'a} - type arity10<'a> = {@internal i10: 'a} - type arity11<'a> = {@internal i11: 'a} - type arity12<'a> = {@internal i12: 'a} - type arity13<'a> = {@internal i13: 'a} - type arity14<'a> = {@internal i14: 'a} - type arity15<'a> = {@internal i15: 'a} - type arity16<'a> = {@internal i16: 'a} - type arity17<'a> = {@internal i17: 'a} - type arity18<'a> = {@internal i18: 'a} - type arity19<'a> = {@internal i19: 'a} - type arity20<'a> = {@internal i20: 'a} - type arity21<'a> = {@internal i21: 'a} - type arity22<'a> = {@internal i22: 'a} -} diff --git a/jscomp/others/js_array.res b/jscomp/others/js_array.res deleted file mode 100644 index caf332f..0000000 --- a/jscomp/others/js_array.res +++ /dev/null @@ -1,1087 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provides bindings to JavaScript’s `Array` functions. These bindings are -optimized for pipe-last (`|>`), where the array to be processed is the last -parameter in the function. - -Here is an example to find the sum of squares of all even numbers in an array. -Without pipe last, we must call the functions in reverse order: - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 -let square = x => x * x -let result = { - open Js.Array - reduce(\"+", 0, map(square, filter(isEven, [5, 2, 3, 4, 1]))) -} -``` - -With pipe last, we call the functions in the “natural” order: - -```rescript -let isEven = x => mod(x, 2) == 0 -let square = x => x * x -let result = { - open Js.Array - [5, 2, 3, 4, 1] |> filter(isEven) |> map(square) |> reduce("+", 0) -} -``` -*/ - -@@warning("-103") - -/** -The type used to describe a JavaScript array. -*/ -type t<'a> = array<'a> - -/** -A type used to describe JavaScript objects that are like an array or are iterable. -*/ -type array_like<'a> = Js_array2.array_like<'a> - -/* commented out until bs has a plan for iterators - type 'a array_iter = 'a array_like -*/ - -@val -/** -Creates a shallow copy of an array from an array-like object. See [`Array.from`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/from) on MDN. - -## Examples - -```rescript -let strArr = Js.String.castToArrayLike("abcd") -Js.Array.from(strArr) == ["a", "b", "c", "d"] -``` -*/ -external from: array_like<'a> => array<'a> = "Array.from" - -/* ES2015 */ - -@val -/** -Creates a new array by applying a function (the second argument) to each item -in the `array_like` first argument. See -[`Array.from`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/from) -on MDN. - -## Examples - -```rescript -let strArr = Js.String.castToArrayLike("abcd") -let code = s => Js.String.charCodeAt(0, s) -Js.Array.fromMap(strArr, code) == [97.0, 98.0, 99.0, 100.0] -``` -*/ -external fromMap: (array_like<'a>, @uncurry ('a => 'b)) => array<'b> = "Array.from" - -/* ES2015 */ - -@val external isArray: 'a => bool = "Array.isArray" -/* ES2015 */ -/* -Returns `true` if its argument is an array; `false` otherwise. This is a -runtime check, which is why the second example returns `true` — a list is -internally represented as a nested JavaScript array. - -## Examples - -```rescript -Js.Array.isArray([5, 2, 3, 1, 4]) == true -Js.Array.isArray(list{5, 2, 3, 1, 4}) == true -Js.Array.isArray("abcd") == false -``` -*/ - -@get -/** -Returns the number of elements in the array. See [`Array.length`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/length) on MDN. -*/ -external length: array<'a> => int = "length" - -/* Mutator functions */ - -@bs.send.pipe(: t<'a> as 'this) -/** -Copies from the first element in the given array to the designated `~to_` position, returning the resulting array. *This function modifies the original array.* See [`Array.copyWithin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/copyWithin) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array.copyWithin(~to_=2, arr) == [100, 101, 100, 101, 102] -arr == [100, 101, 100, 101, 102] -``` -*/ -external copyWithin: (~to_: int) => 'this = "copyWithin" - -/* ES2015 */ - -@bs.send.pipe(: t<'a> as 'this) -/** -Copies starting at element `~from` in the given array to the designated `~to_` position, returning the resulting array. *This function modifies the original array.* See [`Array.copyWithin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/copyWithin) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array.copyWithinFrom(~from=2, ~to_=0, arr) == [102, 103, 104, 103, 104] -arr == [102, 103, 104, 103, 104] -``` -*/ -external copyWithinFrom: (~to_: int, ~from: int) => 'this = "copyWithin" - -/* ES2015 */ - -@bs.send.pipe(: t<'a> as 'this) -/** -Copies starting at element `~start` in the given array up to but not including `~end_` to the designated `~to_` position, returning the resulting array. *This function modifies the original array.* See [`Array.copyWithin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/copyWithin) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104, 105] -Js.Array.copyWithinFromRange(~start=2, ~end_=5, ~to_=1, arr) == [100, 102, 103, 104, 104, 105] -arr == [100, 102, 103, 104, 104, 105] -``` -*/ -external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => 'this = "copyWithin" - -/* ES2015 */ - -@bs.send.pipe(: t<'a> as 'this) -/** -Sets all elements of the given array (the second arumgent) to the designated value (the first argument), returning the resulting array. *This function modifies the original array.* See [`Array.fill`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/fill) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array.fillInPlace(99, arr) == [99, 99, 99, 99, 99] -arr == [99, 99, 99, 99, 99] -``` -*/ -external fillInPlace: 'a => 'this = "fill" - -/* ES2015 */ - -@bs.send.pipe(: t<'a> as 'this) -/** -Sets all elements of the given array (the last arumgent) from position `~from` to the end to the designated value (the first argument), returning the resulting array. *This function modifies the original array.* See [`Array.fill`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/fill) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array.fillFromInPlace(99, ~from=2, arr) == [100, 101, 99, 99, 99] -arr == [100, 101, 99, 99, 99] -``` -*/ -external fillFromInPlace: ('a, ~from: int) => 'this = "fill" - -/* ES2015 */ - -@bs.send.pipe(: t<'a> as 'this) -/** -Sets the elements of the given array (the last arumgent) from position `~start` up to but not including position `~end_` to the designated value (the first argument), returning the resulting array. *This function modifies the original array.* See [`Array.fill`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/fill) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array.fillRangeInPlace(99, ~start=1, ~end_=4, arr) == [100, 99, 99, 99, 104] -arr == [100, 99, 99, 99, 104] -``` -*/ -external fillRangeInPlace: ('a, ~start: int, ~end_: int) => 'this = "fill" - -/* ES2015 */ - -@bs.send.pipe(: t<'a> as 'this) -@return(undefined_to_opt) -/** -If the array is not empty, removes the last element and returns it as `Some(value)`; returns `None` if the array is empty. *This function modifies the original array.* See [`Array.pop`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/pop) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array.pop(arr) == Some(104) -arr == [100, 101, 102, 103] - -let empty: array = [] -Js.Array.pop(empty) == None -``` -*/ -external pop: option<'a> = "pop" - -@bs.send.pipe(: t<'a> as 'this) -/** -Appends the given value to the array, returning the number of elements in the updated array. *This function modifies the original array.* See [`Array.push`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/push) on MDN. - -## Examples - -```rescript -let arr = ["ant", "bee", "cat"] -Js.Array.push("dog", arr) == 4 -arr == ["ant", "bee", "cat", "dog"] -``` -*/ -external push: 'a => int = "push" - -@bs.send.pipe(: t<'a> as 'this) -@variadic -/** -Appends the values from one array (the first argument) to another (the second argument), returning the number of elements in the updated array. *This function modifies the original array.* See [`Array.push`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/push) on MDN. - -## Examples - -```rescript -let arr = ["ant", "bee", "cat"] -Js.Array.pushMany(["dog", "elk"], arr) == 5 -arr == ["ant", "bee", "cat", "dog", "elk"] -``` -*/ -external pushMany: array<'a> => int = "push" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns an array with the elements of the input array in reverse order. *This function modifies the original array.* See [`Array.reverse`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reverse) on MDN. - -## Examples - -```rescript -let arr = ["ant", "bee", "cat"] -Js.Array.reverseInPlace(arr) == ["cat", "bee", "ant"] -arr == ["cat", "bee", "ant"] -``` -*/ -external reverseInPlace: 'this = "reverse" - -@bs.send.pipe(: t<'a> as 'this) -@return({undefined_to_opt: undefined_to_opt}) -/** -If the array is not empty, removes the first element and returns it as `Some(value)`; returns `None` if the array is empty. *This function modifies the original array.* See [`Array.shift`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/shift) on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array.shift(arr) == Some(100) -arr == [101, 102, 103, 104] - -let empty: array = [] -Js.Array.shift(empty) == None -``` -*/ -external shift: option<'a> = "shift" - -@bs.send.pipe(: t<'a> as 'this) -/** -Sorts the given array in place and returns the sorted array. JavaScript sorts the array by converting the arguments to UTF-16 strings and sorting them. See the second example with sorting numbers, which does not do a numeric sort. *This function modifies the original array.* See [`Array.sort`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/sort) on MDN. - -## Examples - -```rescript -let words = ["bee", "dog", "ant", "cat"] -Js.Array.sortInPlace(words) == ["ant", "bee", "cat", "dog"] -words == ["ant", "bee", "cat", "dog"] - -let numbers = [3, 30, 10, 1, 20, 2] -Js.Array.sortInPlace(numbers) == [1, 10, 2, 20, 3, 30] -numbers == [1, 10, 2, 20, 3, 30] -``` -*/ -external sortInPlace: 'this = "sort" - -@bs.send.pipe(: t<'a> as 'this) -/** -Sorts the given array in place and returns the sorted array. *This function modifies the original array.* - -The first argument to `sortInPlaceWith()` is a function that compares two items from the array and returns: - -* an integer less than zero if the first item is less than the second item -* zero if the items are equal -* an integer greater than zero if the first item is greater than the second item - -See [`Array.sort`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/sort) on MDN. - -## Examples - -```rescript -// sort by word length -let words = ["horse", "aardvark", "dog", "camel"] -let byLength = (s1, s2) => Js.String.length(s1) - Js.String.length(s2) - -Js.Array.sortInPlaceWith(byLength, words) == ["dog", "horse", "camel", "aardvark"] - -// sort in reverse numeric order -let numbers = [3, 30, 10, 1, 20, 2] -let reverseNumeric = (n1, n2) => n2 - n1 -Js.Array.sortInPlaceWith(reverseNumeric, numbers) == [30, 20, 10, 3, 2, 1] -``` -*/ -external sortInPlaceWith: (@uncurry ('a, 'a) => int) => 'this = "sort" - -@bs.send.pipe(: t<'a> as 'this) -@variadic -/** -Starting at position `~pos`, remove `~remove` elements and then add the -elements from the `~add` array. Returns an array consisting of the removed -items. *This function modifies the original array.* See -[`Array.splice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/splice) -on MDN. - -## Examples - -```rescript -let arr = ["a", "b", "c", "d", "e", "f"] -Js.Array.spliceInPlace(~pos=2, ~remove=2, ~add=["x", "y", "z"], arr) == ["c", "d"] -arr == ["a", "b", "x", "y", "z", "e", "f"] - -let arr2 = ["a", "b", "c", "d"] -Js.Array.spliceInPlace(~pos=3, ~remove=0, ~add=["x", "y"], arr2) == [] -arr2 == ["a", "b", "c", "x", "y", "d"] - -let arr3 = ["a", "b", "c", "d", "e", "f"] -Js.Array.spliceInPlace(~pos=9, ~remove=2, ~add=["x", "y", "z"], arr3) == [] -arr3 == ["a", "b", "c", "d", "e", "f", "x", "y", "z"] -``` -*/ -external spliceInPlace: (~pos: int, ~remove: int, ~add: array<'a>) => 'this = "splice" - -@bs.send.pipe(: t<'a> as 'this) -/** -Removes elements from the given array starting at position `~pos` to the end -of the array, returning the removed elements. *This function modifies the -original array.* See -[`Array.splice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/splice) -on MDN. - -## Examples - -```rescript -let arr = ["a", "b", "c", "d", "e", "f"] -Js.Array.removeFromInPlace(~pos=4, arr) == ["e", "f"] -arr == ["a", "b", "c", "d"] -``` -*/ -external removeFromInPlace: (~pos: int) => 'this = "splice" - -@bs.send.pipe(: t<'a> as 'this) -/** -Removes `~count` elements from the given array starting at position `~pos`, -returning the removed elements. *This function modifies the original array.* -See -[`Array.splice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/splice) -on MDN. - -## Examples - -```rescript -let arr = ["a", "b", "c", "d", "e", "f"] -Js.Array.removeCountInPlace(~pos=2, ~count=3, arr) == ["c", "d", "e"] -arr == ["a", "b", "f"] -``` -*/ -external removeCountInPlace: (~pos: int, ~count: int) => 'this = "splice" - -@bs.send.pipe(: t<'a> as 'this) -/** -Adds the given element to the array, returning the new number of elements in -the array. *This function modifies the original array.* See -[`Array.unshift`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/unshift) -on MDN. - -## Examples - -```rescript -let arr = ["b", "c", "d"] -Js.Array.unshift("a", arr) == 4 -arr == ["a", "b", "c", "d"] -``` -*/ -external unshift: 'a => int = "unshift" - -@bs.send.pipe(: t<'a> as 'this) -@variadic -/** -Adds the elements in the first array argument at the beginning of the second -array argument, returning the new number of elements in the array. *This -function modifies the original array.* See -[`Array.unshift`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/unshift) -on MDN. - -## Examples - -```rescript -let arr = ["d", "e"] -Js.Array.unshiftMany(["a", "b", "c"], arr) == 5 -arr == ["a", "b", "c", "d", "e"] -``` -*/ -external unshiftMany: array<'a> => int = "unshift" - -/* Accessor functions - */ -@bs.send.pipe(: t<'a> as 'this) -/** -Concatenates the first array argument to the second array argument, returning -a new array. The original arrays are not modified. See -[`Array.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/concat) -on MDN. - -## Examples - -```rescript -Js.Array.concat(["c", "d", "e"], ["a", "b"]) == ["a", "b", "c", "d", "e"] -``` -*/ -external concat: 'this => 'this = "concat" - -@bs.send.pipe(: t<'a> as 'this) -@variadic -/** -The first argument to `concatMany()` is an array of arrays; these are added -at the end of the second argument, returning a new array. See -[`Array.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/concat) -on MDN. - -## Examples - -```rescript -Js.Array.concatMany([["d", "e"], ["f", "g", "h"]], ["a", "b", "c"]) == [ - "a", - "b", - "c", - "d", - "e", - "f", - "g", - "h", - ] -``` -*/ -external concatMany: array<'this> => 'this = "concat" - -/* ES2016 */ -@bs.send.pipe(: t<'a> as 'this) -/** -Returns true if the given value is in the array, `false` otherwise. See -[`Array.includes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/includes) -on MDN. - -## Examples - -```rescript -Js.Array.includes("b", ["a", "b", "c"]) == true -Js.Array.includes("x", ["a", "b", "c"]) == false -``` -*/ -external includes: 'a => bool = "includes" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns the index of the first element in the array that has the given value. -If the value is not in the array, returns -1. See -[`Array.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/indexOf) -on MDN. - -## Examples - -```rescript -Js.Array.indexOf(102, [100, 101, 102, 103]) == 2 -Js.Array.indexOf(999, [100, 101, 102, 103]) == -1 -``` -*/ -external indexOf: 'a => int = "indexOf" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns the index of the first element in the array with the given value. The -search starts at position `~from`. See -[`Array.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/indexOf) -on MDN. - -## Examples - -```rescript -Js.Array.indexOfFrom("a", ~from=2, ["a", "b", "a", "c", "a"]) == 2 -Js.Array.indexOfFrom("a", ~from=3, ["a", "b", "a", "c", "a"]) == 4 -Js.Array.indexOfFrom("b", ~from=2, ["a", "b", "a", "c", "a"]) == -1 -``` -*/ -external indexOfFrom: ('a, ~from: int) => int = "indexOf" - -@send @deprecated("please use joinWith instead") -external join: t<'a> => string = "join" - -@bs.send.pipe(: t<'a> as 'this) -/** -This function converts each element of the array to a string (via JavaScript) -and concatenates them, separated by the string given in the first argument, -into a single string. See -[`Array.join`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/join) -on MDN. - -## Examples - -```rescript -Js.Array.joinWith("--", ["ant", "bee", "cat"]) == "ant--bee--cat" -Js.Array.joinWith("", ["door", "bell"]) == "doorbell" -Js.Array.joinWith("/", [2020, 9, 4]) == "2020/9/4" -Js.Array.joinWith(";", [2.5, 3.6, 3e-2]) == "2.5;3.6;0.03" -``` -*/ -external joinWith: string => string = "join" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns the index of the last element in the array that has the given value. -If the value is not in the array, returns -1. See -[`Array.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.Array.lastIndexOf("a", ["a", "b", "a", "c"]) == 2 -Js.Array.lastIndexOf("x", ["a", "b", "a", "c"]) == -1 -``` -*/ -external lastIndexOf: 'a => int = "lastIndexOf" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns the index of the last element in the array that has the given value, -searching from position `~from` down to the start of the array. If the value -is not in the array, returns -1. See -[`Array.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.Array.lastIndexOfFrom("a", ~from=3, ["a", "b", "a", "c", "a", "d"]) == 2 -Js.Array.lastIndexOfFrom("c", ~from=2, ["a", "b", "a", "c", "a", "d"]) == -1 -``` -*/ -external lastIndexOfFrom: ('a, ~from: int) => int = "lastIndexOf" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns a shallow copy of the given array from the `~start` index up to but -not including the `~end_` position. Negative numbers indicate an offset from -the end of the array. See -[`Array.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/slice) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104, 105, 106] -Js.Array.slice(~start=2, ~end_=5, arr) == [102, 103, 104] -Js.Array.slice(~start=-3, ~end_=-1, arr) == [104, 105] -Js.Array.slice(~start=9, ~end_=10, arr) == [] -``` -*/ -external slice: (~start: int, ~end_: int) => 'this = "slice" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns a copy of the entire array. Same as `Js.Array.Slice(~start=0, -~end_=Js.Array.length(arr), arr)`. See -[`Array.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/slice) -on MDN. -*/ -external copy: 'this = "slice" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns a shallow copy of the given array from the given index to the end. -See [`Array.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/slice) on MDN. - -## Examples - -```rescript -Js.Array.sliceFrom(2, [100, 101, 102, 103, 104]) == [102, 103, 104] -``` -*/ -external sliceFrom: int => 'this = "slice" - -@bs.send.pipe(: t<'a> as 'this) -/** -Converts the array to a string. Each element is converted to a string using -JavaScript. Unlike the JavaScript `Array.toString()`, all elements in a -ReasonML array must have the same type. See -[`Array.toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/toString) -on MDN. - -## Examples - -```rescript -Js.Array.toString([3.5, 4.6, 7.8]) == "3.5,4.6,7.8" -Js.Array.toString(["a", "b", "c"]) == "a,b,c" -``` -*/ -external toString: string = "toString" - -@bs.send.pipe(: t<'a> as 'this) -/** -Converts the array to a string using the conventions of the current locale. -Each element is converted to a string using JavaScript. Unlike the JavaScript -`Array.toLocaleString()`, all elements in a ReasonML array must have the same -type. See -[`Array.toLocaleString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/toLocaleString) -on MDN. - -## Examples - -```rescript -Js.Array.toLocaleString([Js.Date.make()]) -// returns "3/19/2020, 10:52:11 AM" for locale en_US.utf8 -// returns "2020-3-19 10:52:11" for locale de_DE.utf8 -``` -*/ -external toLocaleString: string = "toLocaleString" - -/* Iteration functions - */ -/* commented out until bs has a plan for iterators - external entries : (int * 'a) array_iter = "" [@@bs.send.pipe: 'a t as 'this] (* ES2015 *) -*/ - -@bs.send.pipe(: t<'a> as 'this) -/** -The first argument to `every()` is a predicate function that returns a boolean. The `every()` function returns `true` if the predicate function is true for all items in the given array. If given an empty array, returns `true`. See [`Array.every`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/every) on MDN. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 -Js.Array.every(isEven, [6, 22, 8, 4]) == true -Js.Array.every(isEven, [6, 22, 7, 4]) == false -``` -*/ -external every: (@uncurry ('a => bool)) => bool = "every" - -@bs.send.pipe(: t<'a> as 'this) -/** -The first argument to `everyi()` is a predicate function with two arguments: an array element and that element’s index; it returns a boolean. The `everyi()` function returns `true` if the predicate function is true for all items in the given array. If given an empty array, returns `true`. See [`Array.every`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/every) on MDN. - -## Examples - -```rescript -// determine if all even-index items are positive -let evenIndexPositive = (item, index) => mod(index, 2) == 0 ? item > 0 : true - -Js.Array.everyi(evenIndexPositive, [6, -3, 5, 8]) == true -Js.Array.everyi(evenIndexPositive, [6, 3, -5, 8]) == false -``` -*/ -external everyi: (@uncurry ('a, int) => bool) => bool = "every" - -@bs.send.pipe(: t<'a> as 'this) -/** -Applies the given predicate function to each element in the array; the result is an array of those elements for which the predicate function returned `true`. See [`Array.filter`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/filter) on MDN. - -## Examples - -```rescript -let nonEmpty = s => s != "" -Js.Array.filter(nonEmpty, ["abc", "", "", "def", "ghi"]) == ["abc", "def", "ghi"] -``` -*/ -external filter: (@uncurry ('a => bool)) => 'this = "filter" - -@bs.send.pipe(: t<'a> as 'this) -/** -Each element of the given array are passed to the predicate function. The -return value is an array of all those elements for which the predicate -function returned `true`. See -[`Array.filter`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/filter) -on MDN. - -## Examples - -```rescript -// keep only positive elements at odd indices -let positiveOddElement = (item, index) => mod(index, 2) == 1 && item > 0 - -Js.Array.filteri(positiveOddElement, [6, 3, 5, 8, 7, -4, 1]) == [3, 8] -``` -*/ -external filteri: (@uncurry ('a, int) => bool) => 'this = "filter" - -@bs.send.pipe(: t<'a> as 'this) -@return({undefined_to_opt: undefined_to_opt}) -/** -Returns `Some(value)` for the first element in the array that satisifies the -given predicate function, or `None` if no element satisifies the predicate. -See -[`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) -on MDN. - -## Examples - -```rescript -// find first negative element -Js.Array.find(x => x < 0, [33, 22, -55, 77, -44]) == Some(-55) -Js.Array.find(x => x < 0, [33, 22, 55, 77, 44]) == None -``` -*/ -external find: (@uncurry ('a => bool)) => option<'a> = "find" - -@bs.send.pipe(: t<'a> as 'this) -@return({undefined_to_opt: undefined_to_opt}) -/** -Returns `Some(value)` for the first element in the array that satisifies the given predicate function, or `None` if no element satisifies the predicate. The predicate function takes an array element and an index as its parameters. See [`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) on MDN. - -## Examples - -```rescript -// find first positive item at an odd index -let positiveOddElement = (item, index) => mod(index, 2) == 1 && item > 0 - -Js.Array.findi(positiveOddElement, [66, -33, 55, 88, 22]) == Some(88) -Js.Array.findi(positiveOddElement, [66, -33, 55, -88, 22]) == None -``` -*/ -external findi: (@uncurry ('a, int) => bool) => option<'a> = "find" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns the index of the first element in the array that satisifies the given predicate function, or -1 if no element satisifies the predicate. See [`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) on MDN. - -## Examples - -```rescript -Js.Array.findIndex(x => x < 0, [33, 22, -55, 77, -44]) == 2 -Js.Array.findIndex(x => x < 0, [33, 22, 55, 77, 44]) == -1 -``` -*/ -external findIndex: (@uncurry ('a => bool)) => int = "findIndex" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns `Some(value)` for the first element in the array that satisifies the given predicate function, or `None` if no element satisifies the predicate. The predicate function takes an array element and an index as its parameters. See [`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) on MDN. - -## Examples - -```rescript -// find index of first positive item at an odd index -let positiveOddElement = (item, index) => mod(index, 2) == 1 && item > 0 - -Js.Array.findIndexi(positiveOddElement, [66, -33, 55, 88, 22]) == 3 -Js.Array.findIndexi(positiveOddElement, [66, -33, 55, -88, 22]) == -1 -``` -*/ -external findIndexi: (@uncurry ('a, int) => bool) => int = "findIndex" - -@bs.send.pipe(: t<'a> as 'this) -/** -The `forEach()` function applies the function given as the first argument to each element in the array. The function you provide returns `unit`, and the `forEach()` function also returns `unit`. You use `forEach()` when you need to process each element in the array but not return any new array or value; for example, to print the items in an array. See [`Array.forEach`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/forEach) on MDN. - -## Examples - -```rescript -// display all elements in an array -Js.Array.forEach(x => Js.log(x), ["a", "b", "c"]) == () -``` -*/ -external forEach: (@uncurry ('a => unit)) => unit = "forEach" - -@bs.send.pipe(: t<'a> as 'this) -/** -The `forEachi()` function applies the function given as the first argument to each element in the array. The function you provide takes an item in the array and its index number, and returns `unit`. The `forEachi()` function also returns `unit`. You use `forEachi()` when you need to process each element in the array but not return any new array or value; for example, to print the items in an array. See [`Array.forEach`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/forEach) on MDN. - -## Examples - -```rescript -// display all elements in an array as a numbered list -Js.Array.forEachi((item, index) => Js.log2(index + 1, item), ["a", "b", "c"]) == () -``` -*/ -external forEachi: (@uncurry ('a, int) => unit) => unit = "forEach" - -/* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: 'a t as 'this] (* ES2015 *) -*/ - -@bs.send.pipe(: t<'a> as 'this) -/** -Applies the function (given as the first argument) to each item in the array, -returning a new array. The result array does not have to have elements of the -same type as the input array. See -[`Array.map`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/map) -on MDN. - -## Examples - -```rescript -Js.Array.map(x => x * x, [12, 4, 8]) == [144, 16, 64] -Js.Array.map(Js.String.length, ["animal", "vegetable", "mineral"]) == [6, 9, 7] -``` -*/ -external map: (@uncurry ('a => 'b)) => t<'b> = "map" - -@bs.send.pipe(: t<'a> as 'this) -/** -Applies the function (given as the first argument) to each item in the array, -returning a new array. The function acceps two arguments: an item from the -array and its index number. The result array does not have to have elements -of the same type as the input array. See -[`Array.map`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/map) -on MDN. - -## Examples - -```rescript -// multiply each item in array by its position -let product = (item, index) => item * index -Js.Array.mapi(product, [10, 11, 12]) == [0, 11, 24] -``` -*/ -external mapi: (@uncurry ('a, int) => 'b) => t<'b> = "map" - -@bs.send.pipe(: t<'a> as 'this) -/** -The `reduce()` function takes three parameters: a *reducer function*, a -beginning accumulator value, and an array. The reducer function has two -parameters: an accumulated value and an element of the array. - -`reduce()` first calls the reducer function with the beginning value and the -first element in the array. The result becomes the new accumulator value, which -is passed in to the reducer function along with the second element in the -array. `reduce()` proceeds through the array, passing in the result of each -stage as the accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reduce()`. See -[`Array.reduce`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduce) -on MDN. - -## Examples - -```rescript -let sumOfSquares = (accumulator, item) => accumulator + item * item - -Js.Array.reduce(sumOfSquares, 0, [10, 2, 4]) == 120 -Js.Array.reduce(\"*", 1, [10, 2, 4]) == 80 -Js.Array.reduce( - (acc, item) => acc + Js.String.length(item), - 0, - ["animal", "vegetable", "mineral"], -) == 22 // 6 + 9 + 7 -Js.Array.reduce((acc, item) => item /. acc, 1.0, [2.0, 4.0]) == 2.0 // 4.0 / (2.0 / 1.0) -``` -*/ -external reduce: (@uncurry ('b, 'a) => 'b, 'b) => 'b = "reduce" - -@bs.send.pipe(: t<'a> as 'this) -/** -The `reducei()` function takes three parameters: a *reducer function*, a -beginning accumulator value, and an array. The reducer function has three -parameters: an accumulated value, an element of the array, and the index of -that element. - -`reducei()` first calls the reducer function with the beginning value, the -first element in the array, and zero (its index). The result becomes the new -accumulator value, which is passed to the reducer function along with the -second element in the array and one (its index). `reducei()` proceeds from left -to right through the array, passing in the result of each stage as the -accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reducei()`. See -[`Array.reduce`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduce) -on MDN. - -## Examples - -```rescript -// find sum of even-index elements in array -let sumOfEvens = (accumulator, item, index) => - if mod(index, 2) == 0 { - accumulator + item - } else { - accumulator - } - -Js.Array.reducei(sumOfEvens, 0, [2, 5, 1, 4, 3]) == 6 -``` -*/ -external reducei: (@uncurry ('b, 'a, int) => 'b, 'b) => 'b = "reduce" - -@bs.send.pipe(: t<'a> as 'this) -/** -The `reduceRight()` function takes three parameters: a *reducer function*, a -beginning accumulator value, and an array. The reducer function has two -parameters: an accumulated value and an element of the array. - -`reduceRight()` first calls the reducer function with the beginning value and -the last element in the array. The result becomes the new accumulator value, -which is passed in to the reducer function along with the next-to-last element -in the array. `reduceRight()` proceeds from right to left through the array, -passing in the result of each stage as the accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reduceRight()`. See -[`Array.reduceRight`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduceRight) -on MDN. - -**NOTE:** In many cases, `reduce()` and `reduceRight()` give the same result. However, see the last example here and compare it to the example from `reduce()`, where order makes a difference. - -## Examples - -```rescript -let sumOfSquares = (accumulator, item) => accumulator + item * item - -Js.Array.reduceRight(sumOfSquares, 0, [10, 2, 4]) == 120 -Js.Array.reduceRight((acc, item) => item /. acc, 1.0, [2.0, 4.0]) == 0.5 // 2.0 / (4.0 / 1.0) -``` -*/ -external reduceRight: (@uncurry ('b, 'a) => 'b, 'b) => 'b = "reduceRight" - -@bs.send.pipe(: t<'a> as 'this) -/** -The `reduceRighti()` function takes three parameters: a *reducer function*, a -beginning accumulator value, and an array. The reducer function has three -parameters: an accumulated value, an element of the array, and the index of -that element. `reduceRighti()` first calls the reducer function with the -beginning value, the last element in the array, and its index (length of array -minus one). The result becomes the new accumulator value, which is passed in to -the reducer function along with the second element in the array and one (its -index). `reduceRighti()` proceeds from right to left through the array, passing -in the result of each stage as the accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reduceRighti()`. See -[`Array.reduceRight`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduceRight) -on MDN. - -**NOTE:** In many cases, `reducei()` and `reduceRighti()` give the same result. -However, there are cases where the order in which items are processed makes a -difference. - -## Examples - -```rescript -// find sum of even-index elements in array -let sumOfEvens = (accumulator, item, index) => - if mod(index, 2) == 0 { - accumulator + item - } else { - accumulator - } - -Js.Array.reduceRighti(sumOfEvens, 0, [2, 5, 1, 4, 3]) == 6 -``` -*/ -external reduceRighti: (@uncurry ('b, 'a, int) => 'b, 'b) => 'b = "reduceRight" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns `true` if the predicate function given as the first argument to -`some()` returns `true` for any element in the array; `false` otherwise. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -Js.Array.some(isEven, [3, 7, 5, 2, 9]) == true -Js.Array.some(isEven, [3, 7, 5, 1, 9]) == false -``` -*/ -external some: (@uncurry ('a => bool)) => bool = "some" - -@bs.send.pipe(: t<'a> as 'this) -/** -Returns `true` if the predicate function given as the first argument to -`somei()` returns `true` for any element in the array; `false` otherwise. The -predicate function has two arguments: an item from the array and the index -value - -## Examples - -```rescript -// Does any string in the array -// have the same length as its index? - -let sameLength = (str, index) => Js.String.length(str) == index - -// "ef" has length 2 and is it at index 2 -Js.Array.somei(sameLength, ["ab", "cd", "ef", "gh"]) == true -// no item has the same length as its index -Js.Array.somei(sameLength, ["a", "bc", "def", "gh"]) == false -``` -*/ -external somei: (@uncurry ('a, int) => bool) => bool = "some" - -/* commented out until bs has a plan for iterators - external values : 'a array_iter = "" [@@bs.send.pipe: 'a t as 'this] (* ES2015 *) -*/ -/** -Returns the value at the given position in the array if the position is in -bounds; returns the JavaScript value `undefined` otherwise. - -## Examples - -```rescript -let arr = [100, 101, 102, 103] -Js.Array.unsafe_get(arr, 3) == 103 -Js.Array.unsafe_get(arr, 4) // returns undefined -``` -*/ -external unsafe_get: (array<'a>, int) => 'a = "%array_unsafe_get" - -/** -Sets the value at the given position in the array if the position is in bounds. -If the index is out of bounds, well, “here there be dragons.“ *This function - modifies the original array.* - -## Examples - -```rescript -let arr = [100, 101, 102, 103] -Js.Array.unsafe_set(arr, 3, 99) -// result is [100, 101, 102, 99] - -Js.Array.unsafe_set(arr, 4, 88) -// result is [100, 101, 102, 99, 88] - -Js.Array.unsafe_set(arr, 6, 77) -// result is [100, 101, 102, 99, 88, <1 empty item>, 77] - -Js.Array.unsafe_set(arr, -1, 66) -// you don't want to know. -``` -*/ -external unsafe_set: (array<'a>, int, 'a) => unit = "%array_unsafe_set" diff --git a/jscomp/others/js_array2.res b/jscomp/others/js_array2.res deleted file mode 100644 index 7c270f0..0000000 --- a/jscomp/others/js_array2.res +++ /dev/null @@ -1,1185 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provides bindings to JavaScript’s `Array` functions. These bindings are optimized for pipe-first (`->`), where the array to be processed is the first parameter in the function. - -Here is an example to find the sum of squares of all even numbers in an array. -Without pipe first, we must call the functions in reverse order: - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 -let square = x => x * x -let result = { - open Js.Array2 - reduce(map(filter([5, 2, 3, 4, 1], isEven), square), "+", 0) -} -``` - -With pipe first, we call the functions in the “natural” order: - -```rescript -let isEven = x => mod(x, 2) == 0 -let square = x => x * x -let result = { - open Js.Array2 - [5, 2, 3, 4, 1]->filter(isEven)->map(square)->reduce("+", 0) -} -``` -*/ - -/** -The type used to describe a JavaScript array. -*/ -type t<'a> = array<'a> - -/** -A type used to describe JavaScript objects that are like an array or are iterable. -*/ -type array_like<'a> - -/* commented out until bs has a plan for iterators - type 'a array_iter = 'a array_like -*/ - -@val -/** -Creates a shallow copy of an array from an array-like object. See -[`Array.from`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/from) -on MDN. - -## Examples - -```rescript -let strArr = Js.String.castToArrayLike("abcd") -Js.Array2.from(strArr) == ["a", "b", "c", "d"] -``` -*/ -external from: array_like<'a> => array<'a> = "Array.from" - -/* ES2015 */ - -@val -/** -Creates a new array by applying a function (the second argument) to each item -in the `array_like` first argument. See -[`Array.from`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/from) -on MDN. - -## Examples - -```rescript -let strArr = Js.String.castToArrayLike("abcd") -let code = s => Js.String.charCodeAt(0, s) -Js.Array2.fromMap(strArr, code) == [97.0, 98.0, 99.0, 100.0] -``` -*/ -external fromMap: (array_like<'a>, @uncurry ('a => 'b)) => array<'b> = "Array.from" - -/* ES2015 */ - -@val -/** -Returns `true` if its argument is an array; `false` otherwise. This is a runtime check, which is why the second example returns `true`---a list is internally represented as a nested JavaScript array. - -## Examples - -```rescript -Js.Array2.isArray([5, 2, 3, 1, 4]) == true -Js.Array2.isArray(list{5, 2, 3, 1, 4}) == true -Js.Array2.isArray("abcd") == false -``` -*/ -external isArray: 'a => bool = "Array.isArray" - -@get -/** -Returns the number of elements in the array. See -[`Array.length`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/length) -on MDN. -*/ -external length: array<'a> => int = "length" - -/* Mutator functions */ - -@send -/** -Copies from the first element in the given array to the designated `~to_` -position, returning the resulting array. *This function modifies the original -array.* See -[`Array.copyWithin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/copyWithin) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array2.copyWithin(arr, ~to_=2) == [100, 101, 100, 101, 102] -arr == [100, 101, 100, 101, 102] -``` -*/ -external copyWithin: (t<'a>, ~to_: int) => t<'a> = "copyWithin" - -/* ES2015 */ - -@send -/** -Copies starting at element `~from` in the given array to the designated `~to_` -position, returning the resulting array. *This function modifies the original -array.* See -[`Array.copyWithin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/copyWithin) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array2.copyWithinFrom(arr, ~from=2, ~to_=0) == [102, 103, 104, 103, 104] -arr == [102, 103, 104, 103, 104] -``` -*/ -external copyWithinFrom: (t<'a>, ~to_: int, ~from: int) => t<'a> = "copyWithin" - -/* ES2015 */ - -@send -/** -Copies starting at element `~start` in the given array up to but not including -`~end_` to the designated `~to_` position, returning the resulting array. *This -function modifies the original array.* See -[`Array.copyWithin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/copyWithin) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104, 105] -Js.Array2.copyWithinFromRange(arr, ~start=2, ~end_=5, ~to_=1) == [100, 102, 103, 104, 104, 105] -arr == [100, 102, 103, 104, 104, 105] -``` -*/ -external copyWithinFromRange: (t<'a>, ~to_: int, ~start: int, ~end_: int) => t<'a> = "copyWithin" - -/* ES2015 */ - -@send -/** -Sets all elements of the given array (the first arumgent) to the designated -value (the secon argument), returning the resulting array. *This function - modifies the original array.* - -See -[`Array.fill`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/fill) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array2.fillInPlace(arr, 99) == [99, 99, 99, 99, 99] -arr == [99, 99, 99, 99, 99] -``` -*/ -external fillInPlace: (t<'a>, 'a) => t<'a> = "fill" - -/* ES2015 */ - -@send -/** -Sets all elements of the given array (the first arumgent) from position `~from` -to the end to the designated value (the second argument), returning the -resulting array. *This function modifies the original array.* See -[`Array.fill`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/fill) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array2.fillFromInPlace(arr, 99, ~from=2) == [100, 101, 99, 99, 99] -arr == [100, 101, 99, 99, 99] -``` -*/ -external fillFromInPlace: (t<'a>, 'a, ~from: int) => t<'a> = "fill" - -/* ES2015 */ - -@send -/** -Sets the elements of the given array (the first arumgent) from position -`~start` up to but not including position `~end_` to the designated value (the -second argument), returning the resulting array. *This function modifies the -original array.* See -[`Array.fill`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/fill) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array2.fillRangeInPlace(arr, 99, ~start=1, ~end_=4) == [100, 99, 99, 99, 104] -arr == [100, 99, 99, 99, 104] -``` -*/ -external fillRangeInPlace: (t<'a>, 'a, ~start: int, ~end_: int) => t<'a> = "fill" - -/* ES2015 */ - -@send -@return(undefined_to_opt) -/** -If the array is not empty, removes the last element and returns it as -`Some(value)`; returns `None` if the array is empty. *This function modifies -the original array.* See -[`Array.pop`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/pop) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array2.pop(arr) == Some(104) -arr == [100, 101, 102, 103] - -let empty: array = [] -Js.Array2.pop(empty) == None -``` -*/ -external pop: t<'a> => option<'a> = "pop" - -@send -/** -Appends the given value to the array, returning the number of elements in the -updated array. *This function modifies the original array.* See -[`Array.push`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/push) -on MDN. - -## Examples - -```rescript -let arr = ["ant", "bee", "cat"] -Js.Array2.push(arr, "dog") == 4 -arr == ["ant", "bee", "cat", "dog"] -``` -*/ -external push: (t<'a>, 'a) => int = "push" - -@send -@variadic -/** -Appends the values from one array (the second argument) to another (the first -argument), returning the number of elements in the updated array. *This -function modifies the original array.* See -[`Array.push`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/push) -on MDN. - -## Examples - -```rescript -let arr = ["ant", "bee", "cat"] -Js.Array2.pushMany(arr, ["dog", "elk"]) == 5 -arr == ["ant", "bee", "cat", "dog", "elk"] -``` -*/ -external pushMany: (t<'a>, array<'a>) => int = "push" - -@send -/** -Returns an array with the elements of the input array in reverse order. *This -function modifies the original array.* See -[`Array.reverse`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reverse) -on MDN. - -## Examples - -```rescript -let arr = ["ant", "bee", "cat"] -Js.Array2.reverseInPlace(arr) == ["cat", "bee", "ant"] -arr == ["cat", "bee", "ant"] -``` -*/ -external reverseInPlace: t<'a> => t<'a> = "reverse" - -@send -@return(undefined_to_opt) -/** -If the array is not empty, removes the first element and returns it as -`Some(value)`; returns `None` if the array is empty. *This function modifies -the original array.* See -[`Array.shift`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/shift) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104] -Js.Array2.shift(arr) == Some(100) -arr == [101, 102, 103, 104] - -let empty: array = [] -Js.Array2.shift(empty) == None -``` -*/ -external shift: t<'a> => option<'a> = "shift" - -@send -/** -Sorts the given array in place and returns the sorted array. JavaScript sorts -the array by converting the arguments to UTF-16 strings and sorting them. See -the second example with sorting numbers, which does not do a numeric sort. -*This function modifies the original array.* See -[`Array.sort`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/sort) -on MDN. - -## Examples - -```rescript -let words = ["bee", "dog", "ant", "cat"] -Js.Array2.sortInPlace(words) == ["ant", "bee", "cat", "dog"] -words == ["ant", "bee", "cat", "dog"] - -let numbers = [3, 30, 10, 1, 20, 2] -Js.Array2.sortInPlace(numbers) == [1, 10, 2, 20, 3, 30] -numbers == [1, 10, 2, 20, 3, 30] -``` -*/ -external sortInPlace: t<'a> => t<'a> = "sort" - -@send -/** -Sorts the given array in place and returns the sorted array. *This function - modifies the original array.* - -The first argument to `sortInPlaceWith()` is a function that compares two items -from the array and returns: - -* an integer less than zero if the first item is less than the second item * -zero if the items are equal * an integer greater than zero if the first item is -greater than the second item - -See -[`Array.sort`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/sort) -on MDN. - -## Examples - -```rescript -// sort by word length -let words = ["horse", "aardvark", "dog", "camel"] -let byLength = (s1, s2) => Js.String.length(s1) - Js.String.length(s2) - -Js.Array2.sortInPlaceWith(words, byLength) == ["dog", "horse", "camel", "aardvark"] - -// sort in reverse numeric order -let numbers = [3, 30, 10, 1, 20, 2] -let reverseNumeric = (n1, n2) => n2 - n1 -Js.Array2.sortInPlaceWith(numbers, reverseNumeric) == [30, 20, 10, 3, 2, 1] -``` -*/ -external sortInPlaceWith: (t<'a>, @uncurry ('a, 'a) => int) => t<'a> = "sort" - -@send -@variadic -/** -Starting at position `~pos`, remove `~remove` elements and then add the -elements from the `~add` array. Returns an array consisting of the removed -items. *This function modifies the original array.* See -[`Array.splice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/splice) -on MDN. - -## Examples - -```rescript -let arr = ["a", "b", "c", "d", "e", "f"] -Js.Array2.spliceInPlace(arr, ~pos=2, ~remove=2, ~add=["x", "y", "z"]) == ["c", "d"] -arr == ["a", "b", "x", "y", "z", "e", "f"] - -let arr2 = ["a", "b", "c", "d"] -Js.Array2.spliceInPlace(arr2, ~pos=3, ~remove=0, ~add=["x", "y"]) == [] -arr2 == ["a", "b", "c", "x", "y", "d"] - -let arr3 = ["a", "b", "c", "d", "e", "f"] -Js.Array2.spliceInPlace(arr3, ~pos=9, ~remove=2, ~add=["x", "y", "z"]) == [] -arr3 == ["a", "b", "c", "d", "e", "f", "x", "y", "z"] -``` -*/ -external spliceInPlace: (t<'a>, ~pos: int, ~remove: int, ~add: array<'a>) => t<'a> = "splice" - -@send -/** -Removes elements from the given array starting at position `~pos` to the end of -the array, returning the removed elements. *This function modifies the original -array.* See -[`Array.splice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/splice) -on MDN. - -## Examples - -```rescript -let arr = ["a", "b", "c", "d", "e", "f"] -Js.Array2.removeFromInPlace(arr, ~pos=4) == ["e", "f"] -arr == ["a", "b", "c", "d"] -``` -*/ -external removeFromInPlace: (t<'a>, ~pos: int) => t<'a> = "splice" - -@send -/** -Removes `~count` elements from the given array starting at position `~pos`, -returning the removed elements. *This function modifies the original array.* -See -[`Array.splice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/splice) -on MDN. - -## Examples - -```rescript -let arr = ["a", "b", "c", "d", "e", "f"] -Js.Array2.removeCountInPlace(arr, ~pos=2, ~count=3) == ["c", "d", "e"] -arr == ["a", "b", "f"] -``` -*/ -external removeCountInPlace: (t<'a>, ~pos: int, ~count: int) => t<'a> = "splice" - -@send -/** -Adds the given element to the array, returning the new number of elements in -the array. *This function modifies the original array.* See -[`Array.unshift`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/unshift) -on MDN. - -## Examples - -```rescript -let arr = ["b", "c", "d"] -Js.Array2.unshift(arr, "a") == 4 -arr == ["a", "b", "c", "d"] -``` -*/ -external unshift: (t<'a>, 'a) => int = "unshift" - -@send -@variadic -/** -Adds the elements in the second array argument at the beginning of the first -array argument, returning the new number of elements in the array. *This -function modifies the original array.* See -[`Array.unshift`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/unshift) -on MDN. - -## Examples - -```rescript -let arr = ["d", "e"] -Js.Array2.unshiftMany(arr, ["a", "b", "c"]) == 5 -arr == ["a", "b", "c", "d", "e"] -``` -*/ -external unshiftMany: (t<'a>, array<'a>) => int = "unshift" - -/* Accessor functions - */ -@send @deprecated("`append` is not type-safe. Use `concat` instead.") -external append: (t<'a>, 'a) => t<'a> = "concat" - -@send -/** -Concatenates the second array argument to the first array argument, returning a -new array. The original arrays are not modified. See -[`Array.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/concat) -on MDN. - -## Examples - -```rescript -Js.Array2.concat(["a", "b"], ["c", "d", "e"]) == ["a", "b", "c", "d", "e"] -``` -*/ -external concat: (t<'a>, t<'a>) => t<'a> = "concat" - -@send -@variadic -/** -The second argument to `concatMany()` is an array of arrays; these are added at -the end of the first argument, returning a new array. See -[`Array.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/concat) -on MDN. - -## Examples - -```rescript -Js.Array2.concatMany(["a", "b", "c"], [["d", "e"], ["f", "g", "h"]]) == [ - "a", - "b", - "c", - "d", - "e", - "f", - "g", - "h", - ] -``` -*/ -external concatMany: (t<'a>, array>) => t<'a> = "concat" - -@send -/** -Returns true if the given value is in the array, `false` otherwise. See -[`Array.includes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/includes) -on MDN. - -## Examples - -```rescript -Js.Array2.includes(["a", "b", "c"], "b") == true -Js.Array2.includes(["a", "b", "c"], "x") == false -``` -*/ -external includes: (t<'a>, 'a) => bool = "includes" - -@send -/** -Returns the index of the first element in the array that has the given value. -If the value is not in the array, returns -1. See -[`Array.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/indexOf) -on MDN. - -## Examples - -```rescript -Js.Array2.indexOf([100, 101, 102, 103], 102) == 2 -Js.Array2.indexOf([100, 101, 102, 103], 999) == -1 -``` -*/ -external indexOf: (t<'a>, 'a) => int = "indexOf" - -@send -/** -Returns the index of the first element in the array with the given value. The -search starts at position `~from`. See -[`Array.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/indexOf) -on MDN. - -## Examples - -```rescript -Js.Array2.indexOfFrom(["a", "b", "a", "c", "a"], "a", ~from=2) == 2 -Js.Array2.indexOfFrom(["a", "b", "a", "c", "a"], "a", ~from=3) == 4 -Js.Array2.indexOfFrom(["a", "b", "a", "c", "a"], "b", ~from=2) == -1 -``` -*/ -external indexOfFrom: (t<'a>, 'a, ~from: int) => int = "indexOf" - -@send -/** -This function converts each element of the array to a string (via JavaScript) -and concatenates them, separated by the string given in the first argument, -into a single string. See -[`Array.join`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/join) -on MDN. - -## Examples - -```rescript -Js.Array2.joinWith(["ant", "bee", "cat"], "--") == "ant--bee--cat" -Js.Array2.joinWith(["door", "bell"], "") == "doorbell" -Js.Array2.joinWith([2020, 9, 4], "/") == "2020/9/4" -Js.Array2.joinWith([2.5, 3.6, 3e-2], ";") == "2.5;3.6;0.03" -``` -*/ -external joinWith: (t<'a>, string) => string = "join" - -@send -/** -Returns the index of the last element in the array that has the given value. If -the value is not in the array, returns -1. See -[`Array.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.Array2.lastIndexOf(["a", "b", "a", "c"], "a") == 2 -Js.Array2.lastIndexOf(["a", "b", "a", "c"], "x") == -1 -``` -*/ -external lastIndexOf: (t<'a>, 'a) => int = "lastIndexOf" - -@send -/** -Returns the index of the last element in the array that has the given value, -searching from position `~from` down to the start of the array. If the value is -not in the array, returns -1. See -[`Array.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.Array2.lastIndexOfFrom(["a", "b", "a", "c", "a", "d"], "a", ~from=3) == 2 -Js.Array2.lastIndexOfFrom(["a", "b", "a", "c", "a", "d"], "c", ~from=2) == -1 -``` -*/ -external lastIndexOfFrom: (t<'a>, 'a, ~from: int) => int = "lastIndexOf" - -@send -/** -Returns a shallow copy of the given array from the `~start` index up to but not -including the `~end_` position. Negative numbers indicate an offset from the -end of the array. See -[`Array.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/slice) -on MDN. - -## Examples - -```rescript -let arr = [100, 101, 102, 103, 104, 105, 106] -Js.Array2.slice(arr, ~start=2, ~end_=5) == [102, 103, 104] -Js.Array2.slice(arr, ~start=-3, ~end_=-1) == [104, 105] -Js.Array2.slice(arr, ~start=9, ~end_=10) == [] -``` -*/ -external slice: (t<'a>, ~start: int, ~end_: int) => t<'a> = "slice" - -@send -/** -Returns a copy of the entire array. Same as `Js.Array2.Slice(arr, ~start=0, -~end_=Js.Array2.length(arr))`. See -[`Array.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/slice) -on MDN. -*/ -external copy: t<'a> => t<'a> = "slice" - -@send -/** -Returns a shallow copy of the given array from the given index to the end. See -[`Array.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/slice) -on MDN. -*/ -external sliceFrom: (t<'a>, int) => t<'a> = "slice" - -@send -/** -Converts the array to a string. Each element is converted to a string using -JavaScript. Unlike the JavaScript `Array.toString()`, all elements in a -ReasonML array must have the same type. See -[`Array.toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/toString) -on MDN. - -## Examples - -```rescript -Js.Array2.toString([3.5, 4.6, 7.8]) == "3.5,4.6,7.8" -Js.Array2.toString(["a", "b", "c"]) == "a,b,c" -``` -*/ -external toString: t<'a> => string = "toString" - -@send -/** -Converts the array to a string using the conventions of the current locale. -Each element is converted to a string using JavaScript. Unlike the JavaScript -`Array.toLocaleString()`, all elements in a ReasonML array must have the same -type. See -[`Array.toLocaleString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/toLocaleString) -on MDN. - -## Examples - -```rescript -Js.Array2.toLocaleString([Js.Date.make()]) -// returns "3/19/2020, 10:52:11 AM" for locale en_US.utf8 -// returns "2020-3-19 10:52:11" for locale de_DE.utf8 -``` -*/ -external toLocaleString: t<'a> => string = "toLocaleString" - -/* Iteration functions - */ -/* commented out until bs has a plan for iterators - external entries : 'a t -> (int * 'a) array_iter = "" [@@bs.send] (* ES2015 *) -*/ - -@send -/** -The first argument to `every()` is an array. The second argument is a predicate -function that returns a boolean. The `every()` function returns `true` if the -predicate function is true for all items in the given array. If given an empty -array, returns `true`. See -[`Array.every`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/every) -on MDN. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 -Js.Array2.every([6, 22, 8, 4], isEven) == true -Js.Array2.every([6, 22, 7, 4], isEven) == false -``` -*/ -external every: (t<'a>, @uncurry ('a => bool)) => bool = "every" - -@send -/** -The first argument to `everyi()` is an array. The second argument is a -predicate function with two arguments: an array element and that element’s -index; it returns a boolean. The `everyi()` function returns `true` if the -predicate function is true for all items in the given array. If given an empty -array, returns `true`. See -[`Array.every`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/every) -on MDN. - -## Examples - -```rescript -// determine if all even-index items are positive -let evenIndexPositive = (item, index) => mod(index, 2) == 0 ? item > 0 : true - -Js.Array2.everyi([6, -3, 5, 8], evenIndexPositive) == true -Js.Array2.everyi([6, 3, -5, 8], evenIndexPositive) == false -``` -*/ -external everyi: (t<'a>, @uncurry ('a, int) => bool) => bool = "every" - -@send -/** -Applies the given predicate function (the second argument) to each element in -the array; the result is an array of those elements for which the predicate -function returned `true`. See -[`Array.filter`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/filter) -on MDN. - -## Examples - -```rescript -let nonEmpty = s => s != "" -Js.Array2.filter(["abc", "", "", "def", "ghi"], nonEmpty) == ["abc", "def", "ghi"] -``` -*/ -external filter: (t<'a>, @uncurry ('a => bool)) => t<'a> = "filter" - -@send -/** -Each element of the given array are passed to the predicate function. The -return value is an array of all those elements for which the predicate function -returned `true`. - -See -[`Array.filter`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/filter) -on MDN. - -## Examples - -```rescript -// keep only positive elements at odd indices -let positiveOddElement = (item, index) => mod(index, 2) == 1 && item > 0 - -Js.Array2.filteri([6, 3, 5, 8, 7, -4, 1], positiveOddElement) == [3, 8] -``` -*/ -external filteri: (t<'a>, @uncurry ('a, int) => bool) => t<'a> = "filter" - -@send -@return({undefined_to_opt: undefined_to_opt}) -/** -Returns `Some(value)` for the first element in the array that satisifies the -given predicate function, or `None` if no element satisifies the predicate. See -[`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) -on MDN. - -## Examples - -```rescript -// find first negative element -Js.Array2.find([33, 22, -55, 77, -44], x => x < 0) == Some(-55) -Js.Array2.find([33, 22, 55, 77, 44], x => x < 0) == None -``` -*/ -external find: (t<'a>, @uncurry ('a => bool)) => option<'a> = "find" - -/* ES2015 */ - -@send -@return({undefined_to_opt: undefined_to_opt}) -/** -Returns `Some(value)` for the first element in the array that satisifies the -given predicate function, or `None` if no element satisifies the predicate. The -predicate function takes an array element and an index as its parameters. See -[`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) -on MDN. - -## Examples - -```rescript -// find first positive item at an odd index -let positiveOddElement = (item, index) => mod(index, 2) == 1 && item > 0 - -Js.Array2.findi([66, -33, 55, 88, 22], positiveOddElement) == Some(88) -Js.Array2.findi([66, -33, 55, -88, 22], positiveOddElement) == None -``` -*/ -external findi: (t<'a>, @uncurry ('a, int) => bool) => option<'a> = "find" - -/* ES2015 */ - -@send -/** -Returns the index of the first element in the array that satisifies the given -predicate function, or -1 if no element satisifies the predicate. See -[`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) -on MDN. - -## Examples - -```rescript -Js.Array2.findIndex([33, 22, -55, 77, -44], x => x < 0) == 2 -Js.Array2.findIndex([33, 22, 55, 77, 44], x => x < 0) == -1 -``` -*/ -external findIndex: (t<'a>, @uncurry ('a => bool)) => int = "findIndex" - -/* ES2015 */ - -@send -/** -Returns `Some(value)` for the first element in the array that satisifies the -given predicate function, or `None` if no element satisifies the predicate. The -predicate function takes an array element and an index as its parameters. See -[`Array.find`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/find) -on MDN. - -## Examples - -```rescript -// find index of first positive item at an odd index -let positiveOddElement = (item, index) => mod(index, 2) == 1 && item > 0 - -Js.Array2.findIndexi([66, -33, 55, 88, 22], positiveOddElement) == 3 -Js.Array2.findIndexi([66, -33, 55, -88, 22], positiveOddElement) == -1 -``` -*/ -external findIndexi: (t<'a>, @uncurry ('a, int) => bool) => int = "findIndex" - -/* ES2015 */ - -@send -/** -The `forEach()` function applies the function given as the second argument to -each element in the array. The function you provide returns `unit`, and the -`forEach()` function also returns `unit`. You use `forEach()` when you need to -process each element in the array but not return any new array or value; for -example, to print the items in an array. See -[`Array.forEach`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/forEach) -on MDN. - -## Examples - -```rescript -// display all elements in an array -Js.Array2.forEach(["a", "b", "c"], x => Js.log(x)) == () -``` -*/ -external forEach: (t<'a>, @uncurry ('a => unit)) => unit = "forEach" - -@send -/** -The `forEachi()` function applies the function given as the second argument to -each element in the array. The function you provide takes an item in the array -and its index number, and returns `unit`. The `forEachi()` function also -returns `unit`. You use `forEachi()` when you need to process each element in -the array but not return any new array or value; for example, to print the -items in an array. See -[`Array.forEach`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/forEach) -on MDN. - -## Examples - -```rescript -// display all elements in an array as a numbered list -Js.Array2.forEachi(["a", "b", "c"], (item, index) => Js.log2(index + 1, item)) == () -``` -*/ -external forEachi: (t<'a>, @uncurry ('a, int) => unit) => unit = "forEach" - -/* commented out until bs has a plan for iterators - external keys : 'a t -> int array_iter = "" [@@bs.send] (* ES2015 *) -*/ - -@send -/** -Applies the function (the second argument) to each item in the array, returning -a new array. The result array does not have to have elements of the same type -as the input array. See -[`Array.map`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/map) -on MDN. - -## Examples - -```rescript -Js.Array2.map([12, 4, 8], x => x * x) == [144, 16, 64] -Js.Array2.map(["animal", "vegetable", "mineral"], Js.String.length) == [6, 9, 7] -``` -*/ -external map: (t<'a>, @uncurry ('a => 'b)) => t<'b> = "map" - -@send -/** -Applies the function (the second argument) to each item in the array, returning -a new array. The function acceps two arguments: an item from the array and its -index number. The result array does not have to have elements of the same type -as the input array. See -[`Array.map`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/map) -on MDN. - -## Examples - -```rescript -// multiply each item in array by its position -let product = (item, index) => item * index -Js.Array2.mapi([10, 11, 12], product) == [0, 11, 24] -``` -*/ -external mapi: (t<'a>, @uncurry ('a, int) => 'b) => t<'b> = "map" - -@send -/** -The `reduce()` function takes three parameters: an array, a *reducer function*, -and a beginning accumulator value. The reducer function has two parameters: an -accumulated value and an element of the array. - -`reduce()` first calls the reducer function with the beginning value and the -first element in the array. The result becomes the new accumulator value, which -is passed in to the reducer function along with the second element in the -array. `reduce()` proceeds through the array, passing in the result of each -stage as the accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reduce()`. See -[`Array.reduce`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduce) -on MDN. - -## Examples - -```rescript -let sumOfSquares = (accumulator, item) => accumulator + item * item - -Js.Array2.reduce([10, 2, 4], sumOfSquares, 0) == 120 -Js.Array2.reduce([10, 2, 4], "*", 1) == 80 -Js.Array2.reduce( - ["animal", "vegetable", "mineral"], - (acc, item) => acc + Js.String.length(item), - 0, -) == 22 // 6 + 9 + 7 -Js.Array2.reduce([2.0, 4.0], (acc, item) => item /. acc, 1.0) == 2.0 // 4.0 / (2.0 / 1.0) -``` -*/ -external reduce: (t<'a>, @uncurry ('b, 'a) => 'b, 'b) => 'b = "reduce" - -@send -/** -The `reducei()` function takes three parameters: an array, a *reducer -function*, and a beginning accumulator value. The reducer function has three -parameters: an accumulated value, an element of the array, and the index of -that element. - -`reducei()` first calls the reducer function with the beginning value, the -first element in the array, and zero (its index). The result becomes the new -accumulator value, which is passed to the reducer function along with the -second element in the array and one (its index). `reducei()` proceeds from left -to right through the array, passing in the result of each stage as the -accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reducei()`. See -[`Array.reduce`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduce) -on MDN. - -## Examples - -```rescript -// find sum of even-index elements in array -let sumOfEvens = (accumulator, item, index) => - if mod(index, 2) == 0 { - accumulator + item - } else { - accumulator - } - -Js.Array2.reducei([2, 5, 1, 4, 3], sumOfEvens, 0) == 6 -``` -*/ -external reducei: (t<'a>, @uncurry ('b, 'a, int) => 'b, 'b) => 'b = "reduce" - -@send -/** -The `reduceRight()` function takes three parameters: an array, a *reducer -function*, and a beginning accumulator value. The reducer function has two -parameters: an accumulated value and an element of the array. - -`reduceRight()` first calls the reducer function with the beginning value and -the last element in the array. The result becomes the new accumulator value, -which is passed in to the reducer function along with the next-to-last element -in the array. `reduceRight()` proceeds from right to left through the array, -passing in the result of each stage as the accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reduceRight()`. See -[`Array.reduceRight`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduceRight) -on MDN. - -**NOTE:** In many cases, `reduce()` and `reduceRight()` give the same result. -However, see the last example here and compare it to the example from -`reduce()`, where order makes a difference. - -## Examples - -```rescript -let sumOfSquares = (accumulator, item) => accumulator + item * item - -Js.Array2.reduceRight([10, 2, 4], sumOfSquares, 0) == 120 -Js.Array2.reduceRight([2.0, 4.0], (acc, item) => item /. acc, 1.0) == 0.5 // 2.0 / (4.0 / 1.0) -``` -*/ -external reduceRight: (t<'a>, @uncurry ('b, 'a) => 'b, 'b) => 'b = "reduceRight" - -@send -/** -The `reduceRighti()` function takes three parameters: an array, a *reducer -function*, and a beginning accumulator value. The reducer function has three -parameters: an accumulated value, an element of the array, and the index of -that element. `reduceRighti()` first calls the reducer function with the -beginning value, the last element in the array, and its index (length of array -minus one). The result becomes the new accumulator value, which is passed in to -the reducer function along with the second element in the array and one (its -index). `reduceRighti()` proceeds from right to left through the array, passing -in the result of each stage as the accumulator to the reducer function. - -When all array elements are processed, the final value of the accumulator -becomes the return value of `reduceRighti()`. See -[`Array.reduceRight`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Array/reduceRight) -on MDN. - -**NOTE:** In many cases, `reducei()` and `reduceRighti()` give the same result. -However, there are cases where the order in which items are processed makes a -difference. - -## Examples - -```rescript -// find sum of even-index elements in array -let sumOfEvens = (accumulator, item, index) => - if mod(index, 2) == 0 { - accumulator + item - } else { - accumulator - } - -Js.Array2.reduceRighti([2, 5, 1, 4, 3], sumOfEvens, 0) == 6 -``` -*/ -external reduceRighti: (t<'a>, @uncurry ('b, 'a, int) => 'b, 'b) => 'b = "reduceRight" - -@send -/** -Returns `true` if the predicate function given as the second argument to -`some()` returns `true` for any element in the array; `false` otherwise. - -## Examples - -```rescript -let isEven = x => mod(x, 2) == 0 - -Js.Array2.some([3, 7, 5, 2, 9], isEven) == true -Js.Array2.some([3, 7, 5, 1, 9], isEven) == false -``` -*/ -external some: (t<'a>, @uncurry ('a => bool)) => bool = "some" - -@send -/** -Returns `true` if the predicate function given as the second argument to -`somei()` returns `true` for any element in the array; `false` otherwise. The -predicate function has two arguments: an item from the array and the index -value - -## Examples - -```rescript -// Does any string in the array -// have the same length as its index? - -let sameLength = (str, index) => Js.String.length(str) == index - -// "ef" has length 2 and is it at index 2 -Js.Array2.somei(["ab", "cd", "ef", "gh"], sameLength) == true -// no item has the same length as its index -Js.Array2.somei(["a", "bc", "def", "gh"], sameLength) == false -``` -*/ -external somei: (t<'a>, @uncurry ('a, int) => bool) => bool = "some" - -/* commented out until bs has a plan for iterators - external values : 'a t -> 'a array_iter = "" [@@bs.send] (* ES2015 *) -*/ - -/** -Returns the value at the given position in the array if the position is in -bounds; returns the JavaScript value `undefined` otherwise. - -## Examples - -```rescript -let arr = [100, 101, 102, 103] -Js.Array2.unsafe_get(arr, 3) == 103 -Js.Array2.unsafe_get(arr, 4) // returns undefined -``` -*/ -external unsafe_get: (array<'a>, int) => 'a = "%array_unsafe_get" - -/** -Sets the value at the given position in the array if the position is in bounds. -If the index is out of bounds, well, “here there be dragons.“ - -*This function modifies the original array.* - -## Examples - -```rescript -let arr = [100, 101, 102, 103] -Js.Array2.unsafe_set(arr, 3, 99) -// result is [100, 101, 102, 99]; - -Js.Array2.unsafe_set(arr, 4, 88) -// result is [100, 101, 102, 99, 88] - -Js.Array2.unsafe_set(arr, 6, 77) -// result is [100, 101, 102, 99, 88, <1 empty item>, 77] - -Js.Array2.unsafe_set(arr, -1, 66) -// you don't want to know. -``` -*/ -external unsafe_set: (array<'a>, int, 'a) => unit = "%array_unsafe_set" diff --git a/jscomp/others/js_bigint.res b/jscomp/others/js_bigint.res deleted file mode 100644 index 4288f1a..0000000 --- a/jscomp/others/js_bigint.res +++ /dev/null @@ -1,81 +0,0 @@ -/*** JavaScript BigInt API */ - -@val -/** -Parses the given `string` into a `bigint` using JavaScript semantics. Return the -number as a `bigint` if successfully parsed. Uncaught syntax exception otherwise. - -## Examples - -```rescript -/* returns 123n */ -Js.BigInt.fromStringExn("123") - -/* returns 0n */ -Js.BigInt.fromStringExn("") - -/* returns 17n */ -Js.BigInt.fromStringExn("0x11") - -/* returns 3n */ -Js.BigInt.fromStringExn("0b11") - -/* returns 9n */ -Js.BigInt.fromStringExn("0o11") - -/* catch exception */ -try { - Js.BigInt.fromStringExn("a") -} catch { -| _ => ... -} -``` -*/ -external fromStringExn: string => bigint = "BigInt" - -// Operations - -external \"~-": bigint => bigint = "%negbigint" -external \"~+": bigint => bigint = "%identity" -external \"+": (bigint, bigint) => bigint = "%addbigint" -external \"-": (bigint, bigint) => bigint = "%subbigint" -external \"*": (bigint, bigint) => bigint = "%mulbigint" -external \"/": (bigint, bigint) => bigint = "%divbigint" -external mod: (bigint, bigint) => bigint = "%modbigint" -external \"**": (bigint, bigint) => bigint = "%powbigint" - -external land: (bigint, bigint) => bigint = "%andbigint" -external lor: (bigint, bigint) => bigint = "%orbigint" -external lxor: (bigint, bigint) => bigint = "%xorbigint" - -let lnot = x => lxor(x, -1n) - -external lsl: (bigint, bigint) => bigint = "%lslbigint" -external asr: (bigint, bigint) => bigint = "%asrbigint" - -@send -/** -Formats a `bigint` as a string. Return a `string` representing the given value. -See [`toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toString) on MDN. - -## Examples - -```rescript -/* prints "123" */ -Js.BigInt.toString(123n)->Js.log -``` -*/ -external toString: bigint => string = "toString" - -@send -/** -Returns a string with a language-sensitive representation of this BigInt value. - -## Examples - -```rescript -/* prints "123" */ -Js.BigInt.toString(123n)->Js.log -``` -*/ -external toLocaleString: bigint => string = "toLocaleString" diff --git a/jscomp/others/js_blob.res b/jscomp/others/js_blob.res deleted file mode 100644 index 969208c..0000000 --- a/jscomp/others/js_blob.res +++ /dev/null @@ -1,3 +0,0 @@ -/*** JavaScript Blob API */ - -type t diff --git a/jscomp/others/js_cast.res b/jscomp/others/js_cast.res deleted file mode 100644 index 0713541..0000000 --- a/jscomp/others/js_cast.res +++ /dev/null @@ -1,27 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -external intOfBool: bool => int = "%identity" - -external floatOfInt: int => float = "%identity" diff --git a/jscomp/others/js_cast.resi b/jscomp/others/js_cast.resi deleted file mode 100644 index 8ef323b..0000000 --- a/jscomp/others/js_cast.resi +++ /dev/null @@ -1,48 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Safe cast between OCaml values which share the same -runtime representation - -Different OCaml types might share the same represention in the -ReScript runtime; while this is a compiler internal knowledge, -applications might benefit from having a safe and zero cost -conversion between those types. - -This modules acts as the **single place** for such conversion. - -If for any reason, the runtime representation changes, those function -will be modified accordingly. -*/ - -/** -`intOfBool(b)` returns `1` for when `b` is `true` and `0` when `b` is `false` -*/ -external intOfBool: bool => int = "%identity" - -/** -`floatOfInt(i)` returns the float value of `i` -*/ -external floatOfInt: int => float = "%identity" diff --git a/jscomp/others/js_console.res b/jscomp/others/js_console.res deleted file mode 100644 index 9e0eda9..0000000 --- a/jscomp/others/js_console.res +++ /dev/null @@ -1,29 +0,0 @@ -@val @scope("console") external log: 'a => unit = "log" -@val @scope("console") external log2: ('a, 'b) => unit = "log" -@val @scope("console") external log3: ('a, 'b, 'c) => unit = "log" -@val @scope("console") external log4: ('a, 'b, 'c, 'd) => unit = "log" -@val @scope("console") @variadic external logMany: array<'a> => unit = "log" - -@val @scope("console") external info: 'a => unit = "info" -@val @scope("console") external info2: ('a, 'b) => unit = "info" -@val @scope("console") external info3: ('a, 'b, 'c) => unit = "info" -@val @scope("console") external info4: ('a, 'b, 'c, 'd) => unit = "info" -@val @scope("console") @variadic external infoMany: array<'a> => unit = "info" - -@val @scope("console") external warn: 'a => unit = "warn" -@val @scope("console") external warn2: ('a, 'b) => unit = "warn" -@val @scope("console") external warn3: ('a, 'b, 'c) => unit = "warn" -@val @scope("console") external warn4: ('a, 'b, 'c, 'd) => unit = "warn" -@val @scope("console") @variadic external warnMany: array<'a> => unit = "warn" - -@val @scope("console") external error: 'a => unit = "error" -@val @scope("console") external error2: ('a, 'b) => unit = "error" -@val @scope("console") external error3: ('a, 'b, 'c) => unit = "error" -@val @scope("console") external error4: ('a, 'b, 'c, 'd) => unit = "error" -@val @scope("console") @variadic external errorMany: array<'a> => unit = "error" - -@val @scope("console") external trace: unit => unit = "trace" - -@val @scope("console") external timeStart: string => unit = "time" - -@val @scope("console") external timeEnd: string => unit = "timeEnd" diff --git a/jscomp/others/js_date.res b/jscomp/others/js_date.res deleted file mode 100644 index 2a7b6be..0000000 --- a/jscomp/others/js_date.res +++ /dev/null @@ -1,1382 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provide bindings to JS date. (See -[`Date`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date) -on MDN.) JavaScript stores dates as the number of milliseconds since the UNIX -*epoch*, midnight 1 January 1970, UTC. -*/ - -type t - -@send -/** -Returns the primitive value of this date, equivalent to `getTime()`. (See -[`Date.valueOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/valueOf) -on MDN.) - -## Examples - -```rescript -Js.Date.valueOf(exampleDate) == 123456654321.0 -``` -*/ -external valueOf: t => float = "valueOf" - -@new -/** -Returns a date representing the current time. See [`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -on MDN. - -## Examples - -```rescript -let now = Js.Date.make() -``` -*/ -external make: unit => t = "Date" - -@new -/** -Returns a date representing the given argument, which is a number of -milliseconds since the epoch. See [`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -on MDN. - -## Examples - -```rescript -Js.Date.fromFloat(123456654321.0) == exampleDate -``` -*/ -external fromFloat: float => t = "Date" - -@new -/** -Returns a `Js.Date.t` represented by the given string. The string can be in -“IETF-compliant RFC 2822 timestamps, and also strings in a version of ISO8601.” -Returns `NaN` if given an invalid date string. According to the [`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -documentation on MDN, its use is discouraged. - -## Examples - -```rescript -Js.Date.fromString("Thu, 29 Nov 1973 21:30:54.321 GMT") == exampleDate -Js.Date.fromString("1973-11-29T21:30:54.321Z00:00") == exampleDate -Js.Date.fromString("Thor, 32 Lok -19 60:70:80 XYZ") // returns NaN -``` -*/ -external fromString: string => t = "Date" - -@new -/** -Returns a date representing midnight of the first day of the given month and -year in the current time zone. Fractional parts of arguments are ignored. See -[`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -on MDN. - -## Examples - -```rescript -let november1 = Js.Date.makeWithYM(~year=2020.0, ~month=10.0, ()) -``` -*/ -external makeWithYM: (~year: float, ~month: float, unit) => t = "Date" - -@new -/** -Returns a date representing midnight of the given date of the given month and -year in the current time zone. Fractional parts of arguments are ignored. See -[`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -on MDN. -*/ -external makeWithYMD: (~year: float, ~month: float, ~date: float, unit) => t = "Date" - -@new -/** -Returns a date representing the given date of the given month and year, at zero -minutes and zero seconds past the given `hours`, in the current time zone. -Fractional parts of arguments are ignored. See [`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -on MDN. Fractional parts of the arguments are ignored. -*/ -external makeWithYMDH: (~year: float, ~month: float, ~date: float, ~hours: float, unit) => t = - "Date" - -@new -/** -Returns a date representing the given date of the given month and year, at zero -seconds past the given time in hours and minutes in the current time zone. -Fractional parts of arguments are ignored. See [`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -on MDN. -*/ -external makeWithYMDHM: ( - ~year: float, - ~month: float, - ~date: float, - ~hours: float, - ~minutes: float, - unit, -) => t = "Date" - -@new -/** -Returns a date representing the given date of the given month and year, at the -given time in hours, minutes, and seconds in the current time zone. Fractional -parts of arguments are ignored. See [`Date()` -Constructor](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/Date) -on MDN. - -## Examples - -```rescript -Js.Date.makeWithYMDHMS( - ~year=1973.0, - ~month=11.0, - ~date=29.0, - ~hours=21.0, - ~minutes=30.0, - ~seconds=54.321, - (), -) == exampleDate -``` -*/ -external makeWithYMDHMS: ( - ~year: float, - ~month: float, - ~date: float, - ~hours: float, - ~minutes: float, - ~seconds: float, - unit, -) => t = "Date" - -@val("Date.UTC") -/** -Returns a float representing the number of milliseconds past the epoch for -midnight of the first day of the given month and year in UTC. Fractional parts -of arguments are ignored. See -[`Date.UTC`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/UTC) -on MDN. - -## Examples - -```rescript -let november1 = Js.Date.utcWithYM(~year=2020.0, ~month=10.0, ()) -``` -*/ -external utcWithYM: (~year: float, ~month: float, unit) => float = "" - -@val("Date.UTC") -/** -Returns a float representing the number of milliseconds past the epoch for -midnight of the given date of the given month and year in UTC. Fractional parts -of arguments are ignored. See -[`Date.UTC`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/UTC) -on MDN. -*/ -external utcWithYMD: (~year: float, ~month: float, ~date: float, unit) => float = "" - -@val("Date.UTC") -/** -Returns a float representing the number of milliseconds past the epoch for -midnight of the given date of the given month and year, at zero minutes and -seconds past the given hours in UTC. Fractional parts of arguments are ignored. -See -[`Date.UTC`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/UTC) -on MDN. -*/ -external utcWithYMDH: (~year: float, ~month: float, ~date: float, ~hours: float, unit) => float = "" - -@val("Date.UTC") -/** -Returns a float representing the number of milliseconds past the epoch for -midnight of the given date of the given month and year, at zero seconds past -the given number of minutes past the given hours in UTC. Fractional parts of -arguments are ignored. See -[`Date.UTC`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/UTC) -on MDN. -*/ -external utcWithYMDHM: ( - ~year: float, - ~month: float, - ~date: float, - ~hours: float, - ~minutes: float, - unit, -) => float = "" - -@val("Date.UTC") -/** -Returns a float representing the number of milliseconds past the epoch for -midnight of the given date of the given month and year, at the given time in -hours, minutes and seconds in UTC. Fractional parts of arguments are ignored. - -See -[`Date.UTC`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/UTC) -on MDN. -*/ -external utcWithYMDHMS: ( - ~year: float, - ~month: float, - ~date: float, - ~hours: float, - ~minutes: float, - ~seconds: float, - unit, -) => float = "" - -@val("Date.now") /** Returns the current time as number of milliseconds since Unix epoch. */ -external now: unit => float = "" - -@new @deprecated("Please use `fromString` instead") external parse: string => t = "Date" - -@val("parse") -@scope("Date") -/** -Returns a float with the number of milliseconds past the epoch represented by -the given string. The string can be in “IETF-compliant RFC 2822 timestamps, and -also strings in a version of ISO8601.” Returns `NaN` if given an invalid date -string. According to the -[`Date.parse`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/parse) -documentation on MDN, its use is discouraged. Returns `NaN` if passed invalid -date string. -*/ -external parseAsFloat: string => float = "" - -@send -/** -Returns the day of the month for its argument. The argument is evaluated in the -current time zone. See -[`Date.getDate`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getDate) -on MDN. - -## Examples - -```rescript -Js.Date.getDate(exampleDate) == 29.0 -``` -*/ -external getDate: t => float = "getDate" - -@send -/** -Returns the day of the week (0.0-6.0) for its argument, where 0.0 represents -Sunday. The argument is evaluated in the current time zone. See -[`Date.getDay`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getDay) -on MDN. - -## Examples - -```rescript -Js.Date.getDay(exampleDate) == 4.0 -``` -*/ -external getDay: t => float = "getDay" - -@send -/** -Returns the full year (as opposed to the range 0-99) for its argument. The -argument is evaluated in the current time zone. See -[`Date.getFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getFullYear) -on MDN. - -## Examples - -```rescript -Js.Date.getFullYear(exampleDate) == 1973.0 -``` -*/ -external getFullYear: t => float = "getFullYear" - -@send -/** -Returns the hours for its argument, evaluated in the current time zone. See -[`Date.getHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getHours) -on MDN. - -## Examples - -```rescript -Js.Date.getHours(exampleDate) == 22.0 // Vienna is in GMT+01:00 -``` -*/ -external getHours: t => float = "getHours" - -@send -/** -Returns the number of milliseconds for its argument, evaluated in the current -time zone. See -[`Date.getMilliseconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getMilliseconds) -on MDN. - -## Examples - -```rescript -Js.Date.getMilliseconds(exampleDate) == 321.0 -``` -*/ -external getMilliseconds: t => float = "getMilliseconds" - -@send -/** -Returns the number of minutes for its argument, evaluated in the current time -zone. See -[`Date.getMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getMinutes) -on MDN. - -## Examples - -```rescript -Js.Date.getMinutes(exampleDate) == 30.0 -``` -*/ -external getMinutes: t => float = "getMinutes" - -@send -/** -Returns the month (0.0-11.0) for its argument, evaluated in the current time -zone. January is month zero. See -[`Date.getMonth`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getMonth) -on MDN. - -## Examples - -```rescript -Js.Date.getMonth(exampleDate) == 10.0 -``` -*/ -external getMonth: t => float = "getMonth" - -@send -/** -Returns the seconds for its argument, evaluated in the current time zone. See -[`Date.getSeconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getSeconds) -on MDN. - -## Examples - -```rescript -Js.Date.getSeconds(exampleDate) == 54.0 -``` -*/ -external getSeconds: t => float = "getSeconds" - -@send -/** -Returns the number of milliseconds since Unix epoch, evaluated in UTC. See -[`Date.getTime`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getTime) -on MDN. - -## Examples - -```rescript -Js.Date.getTime(exampleDate) == 123456654321.0 -``` -*/ -external getTime: t => float = "getTime" - -@send -/** -Returns the time zone offset in minutes from the current time zone to UTC. See -[`Date.getTimezoneOffset`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getTimezoneOffset) -on MDN. - -## Examples - -```rescript -Js.Date.getTimezoneOffset(exampleDate) == -60.0 -``` -*/ -external getTimezoneOffset: t => float = "getTimezoneOffset" - -@send -/** -Returns the day of the month of the argument, evaluated in UTC. See -[`Date.getUTCDate`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCDate) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCDate(exampleDate) == 29.0 -``` -*/ -external getUTCDate: t => float = "getUTCDate" - -@send -/** -Returns the day of the week of the argument, evaluated in UTC. The range of the -return value is 0.0-6.0, where Sunday is zero. See -[`Date.getUTCDay`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCDay) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCDay(exampleDate) == 4.0 -``` -*/ -external getUTCDay: t => float = "getUTCDay" - -@send -/** -Returns the full year (as opposed to the range 0-99) for its argument. The -argument is evaluated in UTC. See -[`Date.getUTCFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCFullYear) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCFullYear(exampleDate) == 1973.0 -``` -*/ -external getUTCFullYear: t => float = "getUTCFullYear" - -@send -/** -Returns the hours for its argument, evaluated in the current time zone. See -[`Date.getUTCHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCHours) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCHours(exampleDate) == 21.0 -``` -*/ -external getUTCHours: t => float = "getUTCHours" - -@send -/** -Returns the number of milliseconds for its argument, evaluated in UTC. See -[`Date.getUTCMilliseconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCMilliseconds) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCMilliseconds(exampleDate) == 321.0 -``` -*/ -external getUTCMilliseconds: t => float = "getUTCMilliseconds" - -@send -/** -Returns the number of minutes for its argument, evaluated in UTC. See -[`Date.getUTCMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCMinutes) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCMinutes(exampleDate) == 30.0 -``` -*/ -external getUTCMinutes: t => float = "getUTCMinutes" - -@send -/** -Returns the month (0.0-11.0) for its argument, evaluated in UTC. January is -month zero. See -[`Date.getUTCMonth`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCMonth) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCMonth(exampleDate) == 10.0 -``` -*/ -external getUTCMonth: t => float = "getUTCMonth" - -@send -/** -Returns the seconds for its argument, evaluated in UTC. See -[`Date.getUTCSeconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/getUTCSeconds) -on MDN. - -## Examples - -```rescript -Js.Date.getUTCSeconds(exampleDate) == 54.0 -``` -*/ -external getUTCSeconds: t => float = "getUTCSeconds" - -@send @deprecated("Use `getFullYear` instead.") external getYear: t => float = "getYear" - -@send -/** -Sets the given `Date`’s day of month to the value in the second argument -according to the current time zone. Returns the number of milliseconds since -the epoch of the updated `Date`. *This function modifies the original `Date`.* -See -[`Date.setDate`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setDate) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let twoWeeksBefore = Js.Date.setDate(date1, 15.0) -date1 == Js.Date.fromString("1973-11-15T21:30:54.321Z00:00") -twoWeeksBefore == Js.Date.getTime(date1) -``` -*/ -external setDate: (t, float) => float = "setDate" - -@send -/** -Sets the given `Date`’s year to the value in the second argument according to -the current time zone. Returns the number of milliseconds since the epoch of -the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setFullYear) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let nextYear = Js.Date.setFullYear(date1, 1974.0) -date1 == Js.Date.fromString("1974-11-15T21:30:54.321Z00:00") -nextYear == Js.Date.getTime(date1) -``` -*/ -external setFullYear: (t, float) => float = "setFullYear" - -@send -/** -Sets the given `Date`’s year and month to the values in the labeled arguments -according to the current time zone. Returns the number of milliseconds since -the epoch of the updated `Date`. *This function modifies the original `Date`.* -See -[`Date.setFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setFullYear) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let future = Js.Date.setFullYearM(date1, ~year=1974.0, ~month=0.0, ()) -date1 == Js.Date.fromString("1974-01-22T21:30:54.321Z00:00") -future == Js.Date.getTime(date1) -``` -*/ -external setFullYearM: (t, ~year: float, ~month: float, unit) => float = "setFullYear" - -@send -/** -Sets the given `Date`’s year, month, and day of month to the values in the -labeled arguments according to the current time zone. Returns the number of -milliseconds since the epoch of the updated `Date`. *This function modifies the -original `Date`.* See -[`Date.setFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setFullYear) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let future = Js.Date.setFullYearMD(date1, ~year=1974.0, ~month=0.0, ~date=7.0, ()) -date1 == Js.Date.fromString("1974-01-07T21:30:54.321Z00:00") -future == Js.Date.getTime(date1) -``` -*/ -external setFullYearMD: (t, ~year: float, ~month: float, ~date: float, unit) => float = - "setFullYear" - -@send -/** -Sets the given `Date`’s hours to the value in the second argument according to -the current time zone. Returns the number of milliseconds since the epoch of -the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let nextHour = Js.Date.setHours(date1, 22.0) -date1 == Js.Date.fromString("1973-11-29T22:30:54.321Z00:00") -nextHour == Js.Date.getTime(date1) -``` -*/ -external setHours: (t, float) => float = "setHours" - -@send -/** -Sets the given `Date`’s hours and minutes to the values in the labeled -arguments according to the current time zone. Returns the number of -milliseconds since the epoch of the updated `Date`. *This function modifies the -original `Date`.* See -[`Date.setHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setHoursM(date1, ~hours=22.0, ~minutes=46.0, ()) -date1 == Js.Date.fromString("1973-11-29T22:46:54.321Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setHoursM: (t, ~hours: float, ~minutes: float, unit) => float = "setHours" - -@send -/** -Sets the given `Date`’s hours, minutes, and seconds to the values in the -labeled arguments according to the current time zone. Returns the number of -milliseconds since the epoch of the updated `Date`. *This function modifies the -original `Date`.* See -[`Date.setHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setHoursMS(date1, ~hours=22.0, ~minutes=46.0, ~seconds=37.0, ()) -date1 == Js.Date.fromString("1973-11-29T22:46:37.321Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setHoursMS: (t, ~hours: float, ~minutes: float, ~seconds: float, unit) => float = - "setHours" - -@send -/** -Sets the given `Date`’s hours, minutes, seconds, and milliseconds to the values -in the labeled arguments according to the current time zone. Returns the number -of milliseconds since the epoch of the updated `Date`. *This function modifies -the original `Date`.* See -[`Date.setHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setHoursMSMs( - date1, - ~hours=22.0, - ~minutes=46.0, - ~seconds=37.0, - ~milliseconds=494.0, - (), -) -date1 == Js.Date.fromString("1973-11-29T22:46:37.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setHoursMSMs: ( - t, - ~hours: float, - ~minutes: float, - ~seconds: float, - ~milliseconds: float, - unit, -) => float = "setHours" - -@send -/** -Sets the given `Date`’s milliseconds to the value in the second argument -according to the current time zone. Returns the number of milliseconds since -the epoch of the updated `Date`. *This function modifies the original `Date`.* -See -[`Date.setMilliseconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setMilliseconds) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setMilliseconds(date1, 494.0) -date1 == Js.Date.fromString("1973-11-29T21:30:54.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setMilliseconds: (t, float) => float = "setMilliseconds" - -@send -/** -Sets the given `Date`’s minutes to the value in the second argument according -to the current time zone. Returns the number of milliseconds since the epoch of -the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setMinutes) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setMinutes(date1, 34.0) -date1 == Js.Date.fromString("1973-11-29T21:34:54.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setMinutes: (t, float) => float = "setMinutes" - -@send -/** -Sets the given `Date`’s minutes and seconds to the values in the labeled -arguments according to the current time zone. Returns the number of -milliseconds since the epoch of the updated `Date`. *This function modifies the -original `Date`.* See -[`Date.setMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setMinutes) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setMinutesS(date1, ~minutes=34.0, ~seconds=56.0, ()) -date1 == Js.Date.fromString("1973-11-29T21:34:56.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setMinutesS: (t, ~minutes: float, ~seconds: float, unit) => float = "setMinutes" - -@send -/** -Sets the given `Date`’s minutes, seconds, and milliseconds to the values in the -labeled arguments according to the current time zone. Returns the number of -milliseconds since the epoch of the updated `Date`. *This function modifies the -original `Date`.* See -[`Date.setMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setMinutes) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setMinutesSMs( - date1, - ~minutes=34.0, - ~seconds=56.0, - ~milliseconds=789.0, - (), -) -date1 == Js.Date.fromString("1973-11-29T21:34:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setMinutesSMs: (t, ~minutes: float, ~seconds: float, ~milliseconds: float, unit) => float = - "setMinutes" - -@send -/** -Sets the given `Date`’s month to the value in the second argument according to -the current time zone. Returns the number of milliseconds since the epoch of -the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setMonth`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setMonth) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setMonth(date1, 11.0) -date1 == Js.Date.fromString("1973-12-29T21:34:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setMonth: (t, float) => float = "setMonth" - -@send -/** -Sets the given `Date`’s month and day of month to the values in the labeled -arguments according to the current time zone. Returns the number of -milliseconds since the epoch of the updated `Date`. *This function modifies the -original `Date`.* See -[`Date.setMonth`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setMonth) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setMonthD(date1, ~month=11.0, ~date=8.0, ()) -date1 == Js.Date.fromString("1973-12-08T21:34:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setMonthD: (t, ~month: float, ~date: float, unit) => float = "setMonth" - -@send -/** -Sets the given `Date`’s seconds to the value in the second argument according -to the current time zone. Returns the number of milliseconds since the epoch of -the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setSeconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setSeconds) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setSeconds(date1, 56.0) -date1 == Js.Date.fromString("1973-12-29T21:30:56.321Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setSeconds: (t, float) => float = "setSeconds" - -@send -/** -Sets the given `Date`’s seconds and milliseconds to the values in the labeled -arguments according to the current time zone. Returns the number of -milliseconds since the epoch of the updated `Date`. *This function modifies the -original `Date`.* See -[`Date.setSeconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setSeconds) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setSecondsMs(date1, ~seconds=56.0, ~milliseconds=789.0, ()) -date1 == Js.Date.fromString("1973-12-29T21:30:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setSecondsMs: (t, ~seconds: float, ~milliseconds: float, unit) => float = "setSeconds" - -@send -/** -Sets the given `Date`’s value in terms of milliseconds since the epoch. Returns -the number of milliseconds since the epoch of the updated `Date`. *This -function modifies the original `Date`.* See -[`Date.setTime`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setTime) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setTime(date1, 198765432101.0) - -date1 == Js.Date.fromString("1976-04-19T12:37:12.101Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setTime: (t, float) => float = "setTime" - -@send -/** -Sets the given `Date`’s day of month to the value in the second argument -according to UTC. Returns the number of milliseconds since the epoch of the -updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCDate`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCDate) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let twoWeeksBefore = Js.Date.setUTCDate(date1, 15.0) -date1 == Js.Date.fromString("1973-11-15T21:30:54.321Z00:00") -twoWeeksBefore == Js.Date.getTime(date1) -``` -*/ -external setUTCDate: (t, float) => float = "setUTCDate" - -@send -/** -Sets the given `Date`’s year to the value in the second argument according to -UTC. Returns the number of milliseconds since the epoch of the updated `Date`. -*This function modifies the original `Date`.* See -[`Date.setUTCFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCFullYear) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let nextYear = Js.Date.setUTCFullYear(date1, 1974.0) -date1 == Js.Date.fromString("1974-11-15T21:30:54.321Z00:00") -nextYear == Js.Date.getTime(date1) -``` -*/ -external setUTCFullYear: (t, float) => float = "setUTCFullYear" - -@send -/** -Sets the given `Date`’s year and month to the values in the labeled arguments -according to UTC. Returns the number of milliseconds since the epoch of the -updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCFullYear) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let future = Js.Date.setUTCFullYearM(date1, ~year=1974.0, ~month=0.0, ()) -date1 == Js.Date.fromString("1974-01-22T21:30:54.321Z00:00") -future == Js.Date.getTime(date1) -``` -*/ -external setUTCFullYearM: (t, ~year: float, ~month: float, unit) => float = "setUTCFullYear" - -@send -/** -Sets the given `Date`’s year, month, and day of month to the values in the -labeled arguments according to UTC. Returns the number of milliseconds since -the epoch of the updated `Date`. *This function modifies the original `Date`.* -See -[`Date.setUTCFullYear`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCFullYear) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let future = Js.Date.setUTCFullYearMD(date1, ~year=1974.0, ~month=0.0, ~date=7.0, ()) -date1 == Js.Date.fromString("1974-01-07T21:30:54.321Z00:00") -future == Js.Date.getTime(date1) -``` -*/ -external setUTCFullYearMD: (t, ~year: float, ~month: float, ~date: float, unit) => float = - "setUTCFullYear" - -@send -/** -Sets the given `Date`’s hours to the value in the second argument according to -UTC. Returns the number of milliseconds since the epoch of the updated `Date`. -*This function modifies the original `Date`.* See -[`Date.setUTCHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let nextHour = Js.Date.setUTCHours(date1, 22.0) -date1 == Js.Date.fromString("1973-11-29T22:30:54.321Z00:00") -nextHour == Js.Date.getTime(date1) -``` -*/ -external setUTCHours: (t, float) => float = "setUTCHours" - -@send -/** -Sets the given `Date`’s hours and minutes to the values in the labeled -arguments according to UTC. Returns the number of milliseconds since the epoch -of the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCHoursM(date1, ~hours=22.0, ~minutes=46.0, ()) -date1 == Js.Date.fromString("1973-11-29T22:46:54.321Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCHoursM: (t, ~hours: float, ~minutes: float, unit) => float = "setUTCHours" - -@send -/** -Sets the given `Date`’s hours, minutes, and seconds to the values in the -labeled arguments according to UTC. Returns the number of milliseconds since -the epoch of the updated `Date`. *This function modifies the original `Date`.* - -See -[`Date.setUTCHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCHoursMS(date1, ~hours=22.0, ~minutes=46.0, ~seconds=37.0, ()) -date1 == Js.Date.fromString("1973-11-29T22:46:37.321Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCHoursMS: (t, ~hours: float, ~minutes: float, ~seconds: float, unit) => float = - "setUTCHours" - -@send -/** -Sets the given `Date`’s hours, minutes, seconds, and milliseconds to the values -in the labeled arguments according to UTC. Returns the number of milliseconds -since the epoch of the updated `Date`. *This function modifies the original -`Date`.* See -[`Date.setUTCHours`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCHours) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCHoursMSMs( - date1, - ~hours=22.0, - ~minutes=46.0, - ~seconds=37.0, - ~milliseconds=494.0, - (), -) -date1 == Js.Date.fromString("1973-11-29T22:46:37.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCHoursMSMs: ( - t, - ~hours: float, - ~minutes: float, - ~seconds: float, - ~milliseconds: float, - unit, -) => float = "setUTCHours" - -@send -/** -Sets the given `Date`’s milliseconds to the value in the second argument -according to UTC. Returns the number of milliseconds since the epoch of the -updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCMilliseconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCMilliseconds) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCMilliseconds(date1, 494.0) -date1 == Js.Date.fromString("1973-11-29T21:30:54.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCMilliseconds: (t, float) => float = "setUTCMilliseconds" - -@send -/** -Sets the given `Date`’s minutes to the value in the second argument according -to the current time zone. Returns the number of milliseconds since the epoch of -the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCMinutes) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCMinutes(date1, 34.0) -date1 == Js.Date.fromString("1973-11-29T21:34:54.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCMinutes: (t, float) => float = "setUTCMinutes" - -@send -/** -Sets the given `Date`’s minutes and seconds to the values in the labeled -arguments according to UTC. Returns the number of milliseconds since the epoch -of the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCMinutes) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCMinutesS(date1, ~minutes=34.0, ~seconds=56.0, ()) -date1 == Js.Date.fromString("1973-11-29T21:34:56.494Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCMinutesS: (t, ~minutes: float, ~seconds: float, unit) => float = "setUTCMinutes" - -@send -/** -Sets the given `Date`’s minutes, seconds, and milliseconds to the values in the -labeled arguments according to UTC. Returns the number of milliseconds since -the epoch of the updated `Date`. *This function modifies the original `Date`.* -See -[`Date.setUTCMinutes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCMinutes) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCMinutesSMs( - date1, - ~minutes=34.0, - ~seconds=56.0, - ~milliseconds=789.0, - (), -) -date1 == Js.Date.fromString("1973-11-29T21:34:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCMinutesSMs: ( - t, - ~minutes: float, - ~seconds: float, - ~milliseconds: float, - unit, -) => float = "setUTCMinutes" - -@send -/** -Sets the given `Date`’s month to the value in the second argument according to -UTC. Returns the number of milliseconds since the epoch of the updated `Date`. -*This function modifies the original `Date`.* See -[`Date.setUTCMonth`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCMonth) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCMonth(date1, 11.0) -date1 == Js.Date.fromString("1973-12-29T21:34:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCMonth: (t, float) => float = "setUTCMonth" - -@send -/** -Sets the given `Date`’s month and day of month to the values in the labeled -arguments according to UTC. Returns the number of milliseconds since the epoch -of the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCMonth`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCMonth) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCMonthD(date1, ~month=11.0, ~date=8.0, ()) -date1 == Js.Date.fromString("1973-12-08T21:34:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCMonthD: (t, ~month: float, ~date: float, unit) => float = "setUTCMonth" - -@send -/** -Sets the given `Date`’s seconds to the value in the second argument according -to UTC. Returns the number of milliseconds since the epoch of the updated -`Date`. *This function modifies the original `Date`.* See -[`Date.setUTCSeconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCSeconds) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCSeconds(date1, 56.0) -date1 == Js.Date.fromString("1973-12-29T21:30:56.321Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCSeconds: (t, float) => float = "setUTCSeconds" - -@send -/** -Sets the given `Date`’s seconds and milliseconds to the values in the labeled -arguments according to UTC. Returns the number of milliseconds since the epoch -of the updated `Date`. *This function modifies the original `Date`.* See -[`Date.setUTCSeconds`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/setUTCSeconds) -on MDN. - -## Examples - -```rescript -let date1 = Js.Date.fromFloat(123456654321.0) // 29 November 1973 21:30:54.321 GMT -let futureTime = Js.Date.setUTCSecondsMs(date1, ~seconds=56.0, ~milliseconds=789.0, ()) -date1 == Js.Date.fromString("1973-12-29T21:30:56.789Z00:00") -futureTime == Js.Date.getTime(date1) -``` -*/ -external setUTCSecondsMs: (t, ~seconds: float, ~milliseconds: float, unit) => float = - "setUTCSeconds" - -@send /** Same as [`setTime()`](#settime). */ -external setUTCTime: (t, float) => float = "setTime" - -@send @deprecated("Use `setFullYear` instead") external setYear: (t, float) => float = "setYear" - -@send -/** -Returns the date (day of week, year, month, and day of month) portion of a -`Date` in English. See -[`Date.toDateString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toDateString) -on MDN. - -## Examples - -```rescript -Js.Date.toDateString(exampleDate) == "Thu Nov 29 1973" -``` -*/ -external toDateString: t => string = "toDateString" - -@send @deprecated("Use `toUTCString` instead") external toGMTString: t => string = "toGMTString" - -@send -/** -Returns a simplified version of the ISO 8601 format for the date. See -[`Date.toISOString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toISOString) -on MDN. - -## Examples - -```rescript -Js.Date.toISOString(exampleDate) == "1973-11-29T21:30:54.321Z" -``` -*/ -external toISOString: t => string = "toISOString" - -@send -@deprecated( - "This method is unsafe. It will be changed to return option in a future \ - release. Please use toJSONUnsafe instead." -) -external toJSON: t => string = "toJSON" - -@send -/** -Returns a string representation of the given date. See -[`Date.toJSON`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toJSON) -on MDN. -*/ -external toJSONUnsafe: t => string = "toJSON" - -@send -/** -Returns the year, month, and day for the given `Date` in the current locale -format. See -[`Date.toLocaleDateString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toLocaleDateString) -on MDN. - -## Examples - -```rescript -Js.Date.toLocaleDateString(exampleDate) == "11/29/1973" // for en_US.utf8 -Js.Date.toLocaleDateString(exampleDate) == "29.11.73" // for de_DE.utf8 -``` -*/ -external toLocaleDateString: t => string = "toLocaleDateString" - -/* TODO: has overloads with somewhat poor browser support */ - -@send -/** -Returns the time and date for the given `Date` in the current locale format. -See -[`Date.toLocaleString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toLocaleString) -on MDN. - -## Examples - -```rescript -Js.Date.toLocaleString(exampleDate) == "11/29/1973, 10:30:54 PM" // for en_US.utf8 -Js.Date.toLocaleString(exampleDate) == "29.11.1973, 22:30:54" // for de_DE.utf8 -``` -*/ -external toLocaleString: t => string = "toLocaleString" - -/* TODO: has overloads with somewhat poor browser support */ - -@send -/** -Returns the time of day for the given `Date` in the current locale format. See -[`Date.toLocaleTimeString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toLocaleTimeString) -on MDN. - -## Examples - -```rescript -Js.Date.toLocaleString(exampleDate) == "10:30:54 PM" // for en_US.utf8 -Js.Date.toLocaleString(exampleDate) == "22:30:54" // for de_DE.utf8 -``` -*/ -external toLocaleTimeString: t => string = "toLocaleTimeString" - -/* TODO: has overloads with somewhat poor browser support */ - -@send -/** -Returns a string representing the date and time of day for the given `Date` in -the current locale and time zone. See -[`Date.toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toString) -on MDN. - -## Examples - -```rescript -Js.Date.toString( - exampleDate, -) == "Thu Nov 29 1973 22:30:54 GMT+0100 (Central European Standard Time)" -``` -*/ -external toString: t => string = "toString" - -@send -/** -Returns a string representing the time of day for the given `Date` in the -current locale and time zone. See -[`Date.toTimeString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toTimeString) -on MDN. - -## Examples - -```rescript -Js.Date.toTimeString(exampleDate) == "22:30:54 GMT+0100 (Central European Standard Time)" -``` -*/ -external toTimeString: t => string = "toTimeString" - -@send -/** -Returns a string representing the date and time of day for the given `Date` in -the current locale and UTC (GMT time zone). See -[`Date.toUTCString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Date/toUTCString) -on MDN. - -## Examples - -```rescript -Js.Date.toUTCString(exampleDate) == "Thu, 29 Nov 1973 21:30:54 GMT" -``` -*/ -external toUTCString: t => string = "toUTCString" diff --git a/jscomp/others/js_dict.res b/jscomp/others/js_dict.res deleted file mode 100644 index 5daef59..0000000 --- a/jscomp/others/js_dict.res +++ /dev/null @@ -1,124 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provides a simple key-value dictionary abstraction over native JavaScript objects */ - -/** The dict type */ -type t<'a> = dict<'a> - -/** The key type, an alias of string */ -type key = string - -/** - `unsafeGet dict key` returns the value associated with `key` in `dict` - - This function will return an invalid value (`undefined`) if `key` does not exist in `dict`. It - will not throw an error. -*/ -@get_index -external unsafeGet: (t<'a>, key) => 'a = "" -let \".!()" = unsafeGet - -/** `get dict key` returns the value associated with `key` in `dict` */ -let get = (type u, dict: t, k: key): option => - if %raw(`k in dict`) { - Some(\".!()"(dict, k)) - } else { - None - } - -/** `set dict key value` sets the value of `key` in `dict` to `value` */ -@set_index -external set: (t<'a>, key, 'a) => unit = "" - -/** `keys dict` returns an array of all the keys in `dict` */ -@val -external keys: t<'a> => array = "Object.keys" - -/** `empty ()` creates an empty dictionary */ -@obj -external empty: unit => t<'a> = "" - -let unsafeDeleteKey: (. t, string) => unit = %raw(` function (dict,key){ - delete dict[key]; - } - `) - -@new external unsafeCreate: int => array<'a> = "Array" -/* external entries : 'a t -> (key * 'a) array = "Object.entries" [@@bs.val] (* ES2017 *) */ -let entries = dict => { - let keys = keys(dict) - let l = Js_array2.length(keys) - let values = unsafeCreate(l) - for i in 0 to l - 1 { - let key = Js_array2.unsafe_get(keys, i) - Js_array2.unsafe_set(values, i, (key, \".!()"(dict, key))) - } - values -} - -/* external values : 'a t -> 'a array = "Object.values" [@@bs.val] (* ES2017 *) */ -let values = dict => { - let keys = keys(dict) - let l = Js_array2.length(keys) - let values = unsafeCreate(l) - for i in 0 to l - 1 { - Js_array2.unsafe_set(values, i, \".!()"(dict, Js_array2.unsafe_get(keys, i))) - } - values -} - -let fromList = entries => { - let dict = empty() - let rec loop = x => - switch x { - | list{} => dict - | list{(key, value), ...rest} => - set(dict, key, value) - loop(rest) - } - - loop(entries) -} - -let fromArray = entries => { - let dict = empty() - let l = Js_array2.length(entries) - for i in 0 to l - 1 { - let (key, value) = Js_array2.unsafe_get(entries, i) - set(dict, key, value) - } - dict -} - -let map = (f, source) => { - let target = empty() - let keys = keys(source) - let l = Js_array2.length(keys) - for i in 0 to l - 1 { - let key = Js_array2.unsafe_get(keys, i) - set(target, key, f(. unsafeGet(source, key))) - } - target -} diff --git a/jscomp/others/js_dict.resi b/jscomp/others/js_dict.resi deleted file mode 100644 index 5f6a30f..0000000 --- a/jscomp/others/js_dict.resi +++ /dev/null @@ -1,173 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provide utilities for JS dictionary object. - -**Note:** This module's examples will assume this predeclared dictionary: - -## Examples - -```rescript -let ages = Js.Dict.fromList(list{("Maria", 30), ("Vinh", 22), ("Fred", 49)}) -``` -*/ - -/* -Dictionary type (ie an '{ }' JS object). However it is restricted to hold a -single type; therefore values must have the same type. This Dictionary type is -mostly used with the Js_json.t type. -*/ -type t<'a> = dict<'a> - -/** - The type for dictionary keys. This means that dictionaries *must* use `string`s as their keys. -*/ -type key = string - -/** -`Js.Dict.get(key)` returns `None` if the key is not found in the dictionary, -`Some(value)` otherwise. - -## Examples - -```rescript -Js.Dict.get(ages, "Vinh") == Some(22) -Js.Dict.get(ages, "Paul") == None -``` -*/ -let get: (t<'a>, key) => option<'a> - -@get_index -/** -`Js.Dict.unsafeGet(key)` returns the value if the key exists, otherwise an `undefined` value is returned. Use this only when you are sure the key exists (i.e. when having used the `keys()` function to check that the key is valid). - -## Examples - -```rescript -Js.Dict.unsafeGet(ages, "Fred") == 49 -Js.Dict.unsafeGet(ages, "Paul") // returns undefined -``` -*/ -external unsafeGet: (t<'a>, key) => 'a = "" - -@set_index -/** -`Js.Dict.set(dict, key, value)` sets the key/value in the dictionary `dict`. If -the key does not exist, and entry will be created for it. - -*This function modifies the original dictionary.* - -## Examples - -```rescript -Js.Dict.set(ages, "Maria", 31) -Js.log(ages == Js.Dict.fromList(list{("Maria", 31), ("Vinh", 22), ("Fred", 49)})) - -Js.Dict.set(ages, "David", 66) -Js.log(ages == Js.Dict.fromList(list{("Maria", 31), ("Vinh", 22), ("Fred", 49), ("David", 66)})) -``` -*/ -external set: (t<'a>, key, 'a) => unit = "" - -@val -/** -Returns all the keys in the dictionary `dict`. - -## Examples - -```rescript -Js.Dict.keys(ages) == ["Maria", "Vinh", "Fred"] -``` -*/ -external keys: t<'a> => array = "Object.keys" - -@obj /** Returns an empty dictionary. */ -external empty: unit => t<'a> = "" - -/** Experimental internal function */ -let unsafeDeleteKey: (. t, string) => unit - -/** -Returns an array of key/value pairs in the given dictionary (ES2017). - -## Examples - -```rescript -Js.Dict.entries(ages) == [("Maria", 30), ("Vinh", 22), ("Fred", 49)] -``` -*/ -let entries: t<'a> => array<(key, 'a)> - -/** -Returns the values in the given dictionary (ES2017). - -## Examples - -```rescript -Js.Dict.values(ages) == [30, 22, 49] -``` -*/ -let values: t<'a> => array<'a> - -/** -Creates a new dictionary containing each (key, value) pair in its list -argument. - -## Examples - -```rescript -let capitals = Js.Dict.fromList(list{("Japan", "Tokyo"), ("France", "Paris"), ("Egypt", "Cairo")}) -``` -*/ -let fromList: list<(key, 'a)> => t<'a> - -/** -Creates a new dictionary containing each (key, value) pair in its array -argument. - -## Examples - -```rescript -let capitals2 = Js.Dict.fromArray([("Germany", "Berlin"), ("Burkina Faso", "Ouagadougou")]) -``` -*/ -let fromArray: array<(key, 'a)> => t<'a> - -/** -`map(f, dict)` maps `dict` to a new dictionary with the same keys, using the -function `f` to map each value. - -## Examples - -```rescript -let prices = Js.Dict.fromList(list{("pen", 1.00), ("book", 5.00), ("stapler", 7.00)}) - -let discount = (. price) => price *. 0.90 -let salePrices = Js.Dict.map(discount, prices) - -salePrices == Js.Dict.fromList(list{("pen", 0.90), ("book", 4.50), ("stapler", 6.30)}) -``` -*/ -let map: ((. 'a) => 'b, t<'a>) => t<'b> diff --git a/jscomp/others/js_exn.res b/jscomp/others/js_exn.res deleted file mode 100644 index 9cd37bc..0000000 --- a/jscomp/others/js_exn.res +++ /dev/null @@ -1,87 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t = unknown - -@@warning("-38") /* unused extension constructor */ -exception Error = JsError - -external asJsExn: exn => option = "?as_js_exn" - -@get external stack: t => option = "stack" -@get external message: t => option = "message" -@get external name: t => option = "name" -@get external fileName: t => option = "fileName" - -type error -@new external makeError: string => error = "Error" -external isCamlExceptionOrOpenVariant: 'a => bool = "?is_extension" - -external anyToExnInternal: 'a => exn = "#wrap_exn" - -let raiseError = str => raise((Obj.magic((makeError(str): error)): exn)) - -type eval_error -@new external makeEvalError: string => eval_error = "EvalError" - -let raiseEvalError = str => raise((Obj.magic((makeEvalError(str): eval_error)): exn)) - -type range_error -@new external makeRangeError: string => range_error = "RangeError" - -let raiseRangeError = str => raise((Obj.magic((makeRangeError(str): range_error)): exn)) - -type reference_error - -@new external makeReferenceError: string => reference_error = "ReferenceError" - -let raiseReferenceError = str => raise(Obj.magic(makeReferenceError(str))) - -type syntax_error -@new external makeSyntaxError: string => syntax_error = "SyntaxError" - -let raiseSyntaxError = str => raise(Obj.magic(makeSyntaxError(str))) - -type type_error -@new external makeTypeError: string => type_error = "TypeError" - -let raiseTypeError = str => raise(Obj.magic(makeTypeError(str))) - -type uri_error -@new external makeURIError: string => uri_error = "URIError" - -let raiseUriError = str => raise(Obj.magic(makeURIError(str))) - -/* TODO add predicate to tell which error is which " */ - -/* -exception EvalError of error -exception RangeError of error -exception ReferenceError of error -exception SyntaxError of error -exception TypeError of error - - The URIError object represents an error when a global URI handling function was used in a wrong way. -exception URIError of error -*/ diff --git a/jscomp/others/js_exn.resi b/jscomp/others/js_exn.resi deleted file mode 100644 index 87ce8ca..0000000 --- a/jscomp/others/js_exn.resi +++ /dev/null @@ -1,76 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provide utilities for dealing with JS exceptions. -*/ - -/** Represents a JS exception */ -type t - -type exn += private Error(t) - -external asJsExn: exn => option = "?as_js_exn" - -@get external stack: t => option = "stack" -@get external message: t => option = "message" -@get external name: t => option = "name" -@get external fileName: t => option = "fileName" - -/** internal use only */ -external isCamlExceptionOrOpenVariant: 'a => bool = "?is_extension" - -/** -`anyToExnInternal(obj)` will take any value `obj` and wrap it -in a Js.Exn.Error if given value is not an exn already. If -`obj` is an exn, it will return `obj` without any changes. - -This function is mostly useful for cases where you want to unify a type of a value -that potentially is either exn, a JS error, or any other JS value really (e.g. for -a value passed to a Promise.catch callback) - -**IMPORTANT**: This is an internal API and may be changed / removed any time in the future. - -## Examples - -```rescript -switch (Js.Exn.unsafeAnyToExn("test")) { -| Js.Exn.Error(v) => - switch(Js.Exn.message(v)) { - | Some(str) => Js.log("We won't end up here") - | None => Js.log2("We will land here: ", v) - } -} -``` -*/ -external anyToExnInternal: 'a => exn = "#wrap_exn" - -/** Raise Js exception Error object with stacktrace */ -let raiseError: string => 'a -let raiseEvalError: string => 'a -let raiseRangeError: string => 'a -let raiseReferenceError: string => 'a -let raiseSyntaxError: string => 'a -let raiseTypeError: string => 'a -let raiseUriError: string => 'a diff --git a/jscomp/others/js_file.res b/jscomp/others/js_file.res deleted file mode 100644 index 9836eff..0000000 --- a/jscomp/others/js_file.res +++ /dev/null @@ -1,3 +0,0 @@ -/*** JavaScript File API */ - -type t diff --git a/jscomp/others/js_float.res b/jscomp/others/js_float.res deleted file mode 100644 index 0b63205..0000000 --- a/jscomp/others/js_float.res +++ /dev/null @@ -1,274 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provide utilities for JS float. -*/ - -@val -/** -The special value "Not a Number". See [`NaN`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/NaN) on MDN. -*/ -external _NaN: float = "NaN" - -@val -@scope("Number") -/** -Tests if the given value is `_NaN` - -Note that both `_NaN = _NaN` and `_NaN == _NaN` will return `false`. `isNaN` is -therefore necessary to test for `_NaN`. Return `true` if the given value is -`_NaN`, `false` otherwise. See [`isNaN`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/isNaN) on MDN. -*/ -external isNaN: float => bool = "isNaN" - -@val -@scope("Number") -/** -Tests if the given value is finite. Return `true` if the given value is a finite -number, `false` otherwise. See [`isFinite`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/isFinite) on MDN. - -## Examples - -```rescript -/* returns [false] */ -Js.Float.isFinite(infinity) - -/* returns [false] */ -Js.Float.isFinite(neg_infinity) - -/* returns [false] */ -Js.Float.isFinite(Js.Float._NaN) - -/* returns [true] */ -Js.Float.isFinite(1234.) -``` -*/ -external isFinite: float => bool = "isFinite" - -@send -/** -Formats a `float` using exponential (scientific) notation. Return a -`string` representing the given value in exponential notation. Raise -RangeError if digits is not in the range [0, 20] (inclusive). See [`toExponential`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toExponential) on MDN. - -## Examples - -```rescript -/* prints "7.71234e+1" */ -Js.Float.toExponential(77.1234)->Js.log - -/* prints "7.7e+1" */ -Js.Float.toExponential(77.)->Js.log -``` -*/ -external toExponential: float => string = "toExponential" - -@send -/** -Formats a `float` using exponential (scientific) notation. `digits` specifies -how many digits should appear after the decimal point. The value must be in -the range [0, 20] (inclusive). Return a `string` representing the given value -in exponential notation. The output will be rounded or padded with zeroes if -necessary. Raise RangeError if `digits` is not in the range [0, 20] (inclusive). -See [`toExponential`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toExponential) on MDN. - -## Examples - -```rescript -/* prints "7.71e+1" */ -Js.Float.toExponentialWithPrecision(77.1234, ~digits=2)->Js.log -``` -*/ -external toExponentialWithPrecision: (float, ~digits: int) => string = "toExponential" - -@send -/** -Formats a `float` using fixed point notation. Return a `string` representing the -given value in fixed-point notation (usually). Raise RangeError if digits is not -in the range [0, 20] (inclusive). See [`toFixed`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toFixed) on MDN. - -## Examples - -```rescript -/* prints "12346" (note the rounding) */ -Js.Float.toFixed(12345.6789)->Js.log - -/* print "1.2e+21" */ -Js.Float.toFixed(1.2e21)->Js.log -``` -*/ -external toFixed: float => string = "toFixed" - -@send -/** -Formats a `float` using fixed point notation. `digits` specifies how many digits -should appear after the decimal point. The value must be in the range [0, 20] -(inclusive). Defaults to `0`. Return a `string` representing the given value in -fixed-point notation (usually). See [`toFixed`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toFixed) on MDN. - -The output will be rounded or padded with zeroes if necessary. - -Raise RangeError if digits is not in the range [0, 20] (inclusive) - -## Examples - -```rescript -/* prints "12345.7" (note the rounding) */ -Js.Float.toFixedWithPrecision(12345.6789, ~digits=1)->Js.log - -/* prints "0.00" (note the added zeroes) */ -Js.Float.toFixedWithPrecision(0., ~digits=2)->Js.log -``` -*/ -external toFixedWithPrecision: (float, ~digits: int) => string = "toFixed" - -@send -/** -Formats a `float` using some fairly arbitrary rules. Return a `string` -representing the given value in fixed-point (usually). `toPrecision` differs -from `Js.Float.toFixed` in that the former will format the number with full -precision, while the latter will not output any digits after the decimal point. -See [`toPrecision`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toPrecision) on MDN. - -Raise RangeError if digits is not in the range accepted by this function (what do you mean "vague"?) - -## Examples - -```rescript -/* prints "12345.6789" */ -Js.Float.toPrecision(12345.6789)->Js.log - -/* print "1.2e+21" */ -Js.Float.toPrecision(1.2e21)->Js.log -``` -*/ -external toPrecision: float => string = "toPrecision" - -/* equivalent to `toString` I think */ - -@send -/** -Formats a `float` using some fairly arbitrary rules. `digits` specifies how many -digits should appear in total. The value must between 0 and some arbitrary number -that's hopefully at least larger than 20 (for Node it's 21. Why? Who knows). -See [`toPrecision`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toPrecision) on MDN. - -Return a `string` representing the given value in fixed-point or scientific -notation. The output will be rounded or padded with zeroes if necessary. - -`toPrecisionWithPrecision` differs from `toFixedWithPrecision` in that the former -will count all digits against the precision, while the latter will count only -the digits after the decimal point. `toPrecisionWithPrecision` will also use -scientific notation if the specified precision is less than the number for digits -before the decimal point. - -Raise RangeError if digits is not in the range accepted by this function (what do you mean "vague"?) - -## Examples - -```rescript -/* prints "1e+4" */ -Js.Float.toPrecisionWithPrecision(12345.6789, ~digits=1)->Js.log - -/* prints "0.0" */ -Js.Float.toPrecisionWithPrecision(0., ~digits=2)->Js.log -``` -*/ -external toPrecisionWithPrecision: (float, ~digits: int) => string = "toPrecision" - -@send -/** -Formats a `float` as a string. Return a `string` representing the given value in -fixed-point (usually). See [`toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toString) on MDN. - -## Examples - -```rescript -/* prints "12345.6789" */ -Js.Float.toString(12345.6789)->Js.log -``` -*/ -external toString: float => string = "toString" - -@send -/** -Formats a `float` as a string. `radix` specifies the radix base to use for the -formatted number. The value must be in the range [2, 36] (inclusive). Return a -`string` representing the given value in fixed-point (usually). See [`toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toString) on MDN. - -Raise RangeError if radix is not in the range [2, 36] (inclusive) - -## Examples - -```rescript -/* prints "110" */ -Js.Float.toStringWithRadix(6., ~radix=2)->Js.log - -/* prints "11.001000111101011100001010001111010111000010100011111" */ -Js.Float.toStringWithRadix(3.14, ~radix=2)->Js.log - -/* prints "deadbeef" */ -Js.Float.toStringWithRadix(3735928559., ~radix=16)->Js.log - -/* prints "3f.gez4w97ry0a18ymf6qadcxr" */ -Js.Float.toStringWithRadix(123.456, ~radix=36)->Js.log -``` -*/ -external toStringWithRadix: (float, ~radix: int) => string = "toString" - -@val -/** -Parses the given `string` into a `float` using JavaScript semantics. Return the -number as a `float` if successfully parsed, `_NaN` otherwise. - -## Examples - -```rescript -/* returns 123 */ -Js.Float.fromString("123") - -/* returns 12.3 */ -Js.Float.fromString("12.3") - -/* returns 0 */ -Js.Float.fromString("") - -/* returns 17 */ -Js.Float.fromString("0x11") - -/* returns 3 */ -Js.Float.fromString("0b11") - -/* returns 9 */ -Js.Float.fromString("0o11") - -/* returns [_NaN] */ -Js.Float.fromString("hello") - -/* returns [_NaN] */ -Js.Float.fromString("100a") -``` -*/ -external fromString: string => float = "Number" diff --git a/jscomp/others/js_global.res b/jscomp/others/js_global.res deleted file mode 100644 index 901a64d..0000000 --- a/jscomp/others/js_global.res +++ /dev/null @@ -1,197 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Contains functions available in the global scope (`window` in a browser context) -*/ - -/** Identify an interval started by `Js.Global.setInterval`. */ -type intervalId - -/** Identify timeout started by `Js.Global.setTimeout`. */ -type timeoutId - -@val -/** -Clear an interval started by `Js.Global.setInterval` - -## Examples - -```rescript -/* API for a somewhat aggressive snoozing alarm clock */ - -let punchSleepyGuy = () => Js.log("Punch") - -let interval = ref(Js.Nullable.null) - -let remind = () => { - Js.log("Wake Up!") - punchSleepyGuy() -} - -let snooze = mins => - interval := Js.Nullable.return(Js.Global.setInterval(remind, mins * 60 * 1000)) - -let cancel = () => - Js.Nullable.iter(interval.contents, (. intervalId) => Js.Global.clearInterval(intervalId)) -``` -*/ -external clearInterval: intervalId => unit = "clearInterval" - -@val -/** -Clear a timeout started by `Js.Global.setTimeout`. - -## Examples - -```rescript -/* A simple model of a code monkey's brain */ - -let closeHackerNewsTab = () => Js.log("close") - -let timer = ref(Js.Nullable.null) - -let work = () => closeHackerNewsTab() - -let procrastinate = mins => { - Js.Nullable.iter(timer.contents, (. timer) => Js.Global.clearTimeout(timer)) - timer := Js.Nullable.return(Js.Global.setTimeout(work, mins * 60 * 1000)) -} -``` -*/ -external clearTimeout: timeoutId => unit = "clearTimeout" - -@val -/** -Repeatedly executes a callback with a specified interval (in milliseconds) -between calls. Returns a `Js.Global.intervalId` that can be passed to -`Js.Global.clearInterval` to cancel the timeout. - -## Examples - -```rescript -/* Will count up and print the count to the console every second */ - -let count = ref(0) - -let tick = () => { - count := count.contents + 1 - Js.log(Belt.Int.toString(count.contents)) -} - -Js.Global.setInterval(tick, 1000) -``` -*/ -external setInterval: (unit => unit, int) => intervalId = "setInterval" - -@val -/** -Repeatedly executes a callback with a specified interval (in milliseconds) -between calls. Returns a `Js.Global.intervalId` that can be passed to -`Js.Global.clearInterval` to cancel the timeout. - -## Examples - -```rescript -/* Will count up and print the count to the console every second */ - -let count = ref(0) - -let tick = () => { - count := count.contents + 1 - Js.log(Belt.Int.toString(count.contents)) -} - -Js.Global.setIntervalFloat(tick, 1000.0) -``` -*/ -external setIntervalFloat: (unit => unit, float) => intervalId = "setInterval" - -@val -/** -Execute a callback after a specified delay (in milliseconds). Returns a -`Js.Global.timeoutId` that can be passed to `Js.Global.clearTimeout` to cancel -the timeout. - -## Examples - -```rescript -/* Prints "Timed out!" in the console after one second */ - -let message = "Timed out!" - -Js.Global.setTimeout(() => Js.log(message), 1000) -``` -*/ -external setTimeout: (unit => unit, int) => timeoutId = "setTimeout" - -@val -/** -Execute a callback after a specified delay (in milliseconds). Returns a -`Js.Global.timeoutId` that can be passed to `Js.Global.clearTimeout` to cancel -the timeout. - -## Examples - -```rescript -/* Prints "Timed out!" in the console after one second */ - -let message = "Timed out!" - -Js.Global.setTimeoutFloat(() => Js.log(message), 1000.0) -``` -*/ -external setTimeoutFloat: (unit => unit, float) => timeoutId = "setTimeout" - -@val -/** -URL-encodes a string. - -See [`encodeURI`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/encodeURI) on MDN. -*/ -external encodeURI: string => string = "encodeURI" - -@val -/** -Decodes a URL-enmcoded string produced by `encodeURI` - -See [`decodeURI`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/decodeURI) on MDN. -*/ -external decodeURI: string => string = "decodeURI" - -@val -/** -URL-encodes a string, including characters with special meaning in a URI. - -See [`encodeURIComponent`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/encodeURIComponent) on MDN. -*/ -external encodeURIComponent: string => string = "encodeURIComponent" - -@val -/** -Decodes a URL-enmcoded string produced by `encodeURIComponent` - -See [`decodeURIComponent`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/decodeURIComponent) on MDN. -*/ -external decodeURIComponent: string => string = "decodeURIComponent" diff --git a/jscomp/others/js_int.res b/jscomp/others/js_int.res deleted file mode 100644 index f375b05..0000000 --- a/jscomp/others/js_int.res +++ /dev/null @@ -1,171 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provide utilities for handling `int`. -*/ - -/* -If we use number, we need coerce to int32 by adding `|0`, -otherwise `+0` can be wrong. -Most JS API is float oriented, it may overflow int32 or -comes with `NAN` -*/ - -/* + conversion */ - -@send -/** -Formats an `int` using exponential (scientific) notation. -Returns a `string` representing the given value in exponential notation. -Raises `RangeError` if digits is not in the range \[0, 20\] (inclusive). - -See [`toExponential`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toExponential) on MDN. - -## Examples - -```rescript -/* prints "7.7e+1" */ -Js.log(Js.Int.toExponential(77)) -``` -*/ -external toExponential: int => string = "toExponential" - -@send -/** -Formats an `int` using exponential (scientific) notation. -`digits` specifies how many digits should appear after the decimal point. The value must be in the range \[0, 20\] (inclusive). - -Returns a `string` representing the given value in exponential notation. - -The output will be rounded or padded with zeroes if necessary. -Raises `RangeError` if `digits` is not in the range \[0, 20\] (inclusive). - -See [`toExponential`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toExponential) on MDN. - -## Examples - -```rescript -/* prints "7.70e+1" */ -Js.log(Js.Int.toExponentialWithPrecision(77, ~digits=2)) - -/* prints "5.68e+3" */ -Js.log(Js.Int.toExponentialWithPrecision(5678, ~digits=2)) -``` -*/ -external toExponentialWithPrecision: (int, ~digits: int) => string = "toExponential" - -@send -/** -Formats an `int` using some fairly arbitrary rules. -Returns a `string` representing the given value in fixed-point (usually). - -`toPrecision` differs from `toFixed` in that the former will format the number with full precision, while the latter will not output any digits after the decimal point. -Raises `RangeError` if `digits` is not in the range accepted by this function. - -See [`toPrecision`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toPrecision) on MDN. - -## Examples - -```rescript -/* prints "123456789" */ -Js.log(Js.Int.toPrecision(123456789)) -``` -*/ -external toPrecision: int => string = "toPrecision" - -@send -/** -Formats an `int` using some fairly arbitrary rules. -`digits` specifies how many digits should appear in total. The value must between 0 and some arbitrary number that's hopefully at least larger than 20 (for Node it's 21. Why? Who knows). - -Returns a `string` representing the given value in fixed-point or scientific notation. - -The output will be rounded or padded with zeroes if necessary. - -`toPrecisionWithPrecision` differs from `toFixedWithPrecision` in that the former will count all digits against the precision, while the latter will count only the digits after the decimal point. -`toPrecisionWithPrecision` will also use scientific notation if the specified precision is less than the number of digits before the decimal point. -Raises `RangeError` if `digits` is not in the range accepted by this function. - - -See [`toPrecision`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toPrecision) on MDN. - -## Examples - -```rescript -/* prints "1.2e+8" */ -Js.log(Js.Int.toPrecisionWithPrecision(123456789, ~digits=2)) - -/* prints "0.0" */ -Js.log(Js.Int.toPrecisionWithPrecision(0, ~digits=2)) -``` -*/ -external toPrecisionWithPrecision: (int, ~digits: int) => string = "toPrecision" - -@send -/** -Formats an `int` as a `string`. Returns a `string` representing the given value -in fixed-point (usually). - -See [`toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toString) on MDN. - -## Examples - -```rescript -/* prints "123456789" */ -Js.log(Js.Int.toString(123456789)) -``` -*/ -external toString: int => string = "toString" - -@send -/** -Formats an `int` as a `string`. `radix` specifies the radix base to use for the -formatted number. The value must be in the range \[2, 36\] (inclusive). Returns -a `string` representing the given value in fixed-point (usually). Raises -`RangeError` if `radix` is not in the range \[2, 36\] (inclusive). - - -See [`toString`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Number/toString) on MDN. - -## Examples - -```rescript -/* prints "110" */ -Js.log(Js.Int.toStringWithRadix(6, ~radix=2)) - -/* prints "deadbeef" */ -Js.log(Js.Int.toStringWithRadix(3735928559, ~radix=16)) - -/* prints "2n9c" */ -Js.log(Js.Int.toStringWithRadix(123456, ~radix=36)) -``` -*/ -external toStringWithRadix: (int, ~radix: int) => string = "toString" - -external toFloat: int => float = "%floatofint" - -let equal = (x: int, y) => x == y -let max: int = 2147483647 -let min: int = -2147483648 diff --git a/jscomp/others/js_json.res b/jscomp/others/js_json.res deleted file mode 100644 index ccfa6de..0000000 --- a/jscomp/others/js_json.res +++ /dev/null @@ -1,216 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Efficient JSON encoding using JavaScript API */ - -@unboxed -type rec t = - | Boolean(bool) - | @as(null) Null - | String(string) - | Number(float) - | Object(Js.Dict.t) - | Array(array) - -module Kind = { - type json = t - type rec t<_> = - | String: t - | Number: t - | Object: t> - | Array: t> - | Boolean: t - | Null: t -} - -type tagged_t = - | JSONFalse - | JSONTrue - | JSONNull - | JSONString(string) - | JSONNumber(float) - | JSONObject(Js_dict.t) - | JSONArray(array) - -let classify = (x: t): tagged_t => { - let ty = Js.typeof(x) - if ty == "string" { - JSONString(Obj.magic(x)) - } else if ty == "number" { - JSONNumber(Obj.magic(x)) - } else if ty == "boolean" { - if Obj.magic(x) == true { - JSONTrue - } else { - JSONFalse - } - } else if Obj.magic(x) === Js.null { - JSONNull - } else if Js_array2.isArray(x) { - JSONArray(Obj.magic(x)) - } else { - JSONObject(Obj.magic(x)) - } -} - -let test = (type a, x: 'a, v: Kind.t
): bool => - switch v { - | Kind.Number => Js.typeof(x) == "number" - | Kind.Boolean => Js.typeof(x) == "boolean" - | Kind.String => Js.typeof(x) == "string" - | Kind.Null => Obj.magic(x) === Js.null - | Kind.Array => Js_array2.isArray(x) - | Kind.Object => Obj.magic(x) !== Js.null && (Js.typeof(x) == "object" && !Js_array2.isArray(x)) - } - -let decodeString = json => - if Js.typeof(json) == "string" { - Some((Obj.magic((json: t)): string)) - } else { - None - } - -let decodeNumber = json => - if Js.typeof(json) == "number" { - Some((Obj.magic((json: t)): float)) - } else { - None - } - -let decodeObject = json => - if ( - Js.typeof(json) == "object" && - (!Js_array2.isArray(json) && - !((Obj.magic(json): Js.null<'a>) === Js.null)) - ) { - Some((Obj.magic((json: t)): Js_dict.t)) - } else { - None - } - -let decodeArray = json => - if Js_array2.isArray(json) { - Some((Obj.magic((json: t)): array)) - } else { - None - } - -let decodeBoolean = (json: t) => - if Js.typeof(json) == "boolean" { - Some((Obj.magic((json: t)): bool)) - } else { - None - } - -let decodeNull = (json): option> => - if (Obj.magic(json): Js.null<'a>) === Js.null { - Some(Js.null) - } else { - None - } - -/* external parse : string -> t = "parse" - [@@bs.val][@@bs.scope "JSON"] */ - -@val @scope("JSON") external parseExn: string => t = "parse" - -@val @scope("JSON") external stringifyAny: 'a => option = "stringify" -/* TODO: more docs when parse error happens or stringify non-stringfy value */ - -@val external null: t = "null" -external string: string => t = "%identity" -external number: float => t = "%identity" -external boolean: bool => t = "%identity" -external object_: Js_dict.t => t = "%identity" - -/* external array_ : t array -> t = "%identity" */ - -external array: array => t = "%identity" -external stringArray: array => t = "%identity" -external numberArray: array => t = "%identity" -external booleanArray: array => t = "%identity" -external objectArray: array> => t = "%identity" -@val @scope("JSON") external stringify: t => string = "stringify" -@val @scope("JSON") external stringifyWithSpace: (t, @as(json`null`) _, int) => string = "stringify" - -/* in memory modification does not work until your root is - actually None, so we need wrap it as ``v`` and - return the first element instead */ - -let patch: _ => _ = %raw(`function (json) { - var x = [json]; - var q = [{ kind: 0, i: 0, parent: x }]; - while (q.length !== 0) { - // begin pop the stack - var cur = q[q.length - 1]; - if (cur.kind === 0) { - cur.val = cur.parent[cur.i]; // patch the undefined value for array - if (++cur.i === cur.parent.length) { - q.pop(); - } - } else { - q.pop(); - } - // finish - var task = cur.val; - if (typeof task === "object") { - if (Array.isArray(task) && task.length !== 0) { - q.push({ kind: 0, i: 0, parent: task, val: undefined }); - } else { - for (var k in task) { - if (k === "RE_PRIVATE_NONE") { - if (cur.kind === 0) { - cur.parent[cur.i - 1] = undefined; - } else { - cur.parent[cur.i] = undefined; - } - continue; - } - q.push({ kind: 1, i: k, parent: task, val: task[k] }); - } - } - } - } - return x[0]; -} -`) - -let serializeExn = (type t, x: t): string => - %raw(` function(obj){ - var output= JSON.stringify(obj,function(_,value){ - if(value===undefined){ - return {RE_PRIVATE_NONE : true} - } - return value - }); - - if(output === undefined){ - // JSON.stringify will raise TypeError when it detects cylic objects - throw new TypeError("output is undefined") - } - return output - } -`)(x) - -let deserializeUnsafe = (s: string): 'a => patch(parseExn(s)) diff --git a/jscomp/others/js_json.resi b/jscomp/others/js_json.resi deleted file mode 100644 index 218d5f5..0000000 --- a/jscomp/others/js_json.resi +++ /dev/null @@ -1,277 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Efficient JSON encoding using JavaScript API - -**see** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/JSON) -*/ - -/* ## Types */ - -@unboxed /** The JSON data structure */ -type rec t = - | Boolean(bool) - | @as(null) Null - | String(string) - | Number(float) - | Object(Js.Dict.t) - | Array(array) - -module Kind: { - type json = t - /** Underlying type of a JSON value */ - type rec t<_> = - | String: t - | Number: t - | Object: t> - | Array: t> - | Boolean: t - | Null: t -} - -type tagged_t = - | JSONFalse - | JSONTrue - | JSONNull - | JSONString(string) - | JSONNumber(float) - | JSONObject(Js_dict.t) - | JSONArray(array) - -/* ## Accessors */ - -let classify: t => tagged_t - -/** -`test(v, kind)` returns `true` if `v` is of `kind`. -*/ -let test: ('a, Kind.t<'b>) => bool - -/** -`decodeString(json)` returns `Some(s)` if `json` is a `string`, `None` otherwise. -*/ -let decodeString: t => option - -/** -`decodeNumber(json)` returns `Some(n)` if `json` is a `number`, `None` otherwise. -*/ -let decodeNumber: t => option - -/** -`decodeObject(json)` returns `Some(o)` if `json` is an `object`, `None` otherwise. -*/ -let decodeObject: t => option> - -/** -`decodeArray(json)` returns `Some(a)` if `json` is an `array`, `None` otherwise. -*/ -let decodeArray: t => option> - -/** -`decodeBoolean(json)` returns `Some(b)` if `json` is a `boolean`, `None` otherwise. -*/ -let decodeBoolean: t => option - -/** -`decodeNull(json)` returns `Some(null)` if `json` is a `null`, `None` otherwise. -*/ -let decodeNull: t => option> - -/* ## Constructors */ - -/* - Those functions allows the construction of an arbitrary complex - JSON values. -*/ - -@val /** `null` is the singleton null JSON value. */ -external null: t = "null" - -/** `string(s)` makes a JSON string of the `string` `s`. */ -external string: string => t = "%identity" - -/** `number(n)` makes a JSON number of the `float` `n`. */ -external number: float => t = "%identity" - -/** `boolean(b)` makes a JSON boolean of the `bool` `b`. */ -external boolean: bool => t = "%identity" - -/** `object_(dict)` makes a JSON object of the `Js.Dict.t` `dict`. */ -external object_: Js_dict.t => t = "%identity" - -/** `array_(a)` makes a JSON array of the `Js.Json.t` array `a`. */ -external array: array => t = "%identity" - -/* - The functions below are specialized for specific array type which - happened to be already JSON object in the ReScript runtime. Therefore - they are more efficient (constant time rather than linear conversion). -*/ - -/** `stringArray(a)` makes a JSON array of the `string` array `a`. */ -external stringArray: array => t = "%identity" - -/** `numberArray(a)` makes a JSON array of the `float` array `a`. */ -external numberArray: array => t = "%identity" - -/** `booleanArray(a)` makes a JSON array of the `bool` array `a`. */ -external booleanArray: array => t = "%identity" - -/** `objectArray(a) makes a JSON array of the `JsDict.t` array `a`. */ -external objectArray: array> => t = "%identity" - -/* ## String conversion */ - -@val -@scope("JSON") -/** -`parseExn(s)` parses the `string` `s` into a JSON data structure. -Returns a JSON data structure. -Raises `SyntaxError` if the given string is not a valid JSON. Note: `SyntaxError` is a JavaScript exception. - -See [`parse`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/JSON/parse) on MDN. - -## Examples - -```rescript -/* parse a simple JSON string */ - -let json = try Js.Json.parseExn(` "hello" `) catch { -| _ => failwith("Error parsing JSON string") -} - -switch Js.Json.classify(json) { -| Js.Json.JSONString(value) => Js.log(value) -| _ => failwith("Expected a string") -} -``` - -```rescript -/* parse a complex JSON string */ - -let getIds = s => { - let json = try Js.Json.parseExn(s) catch { - | _ => failwith("Error parsing JSON string") - } - - switch Js.Json.classify(json) { - | Js.Json.JSONObject(value) => - /* In this branch, compiler infer value : Js.Json.t Js.Dict.t */ - switch Js.Dict.get(value, "ids") { - | Some(ids) => - switch Js.Json.classify(ids) { - | Js.Json.JSONArray(ids) => /* In this branch compiler infer ids : Js.Json.t array */ - ids - | _ => failwith("Expected an array") - } - | None => failwith("Expected an `ids` property") - } - | _ => failwith("Expected an object") - } -} - -/* prints `1, 2, 3` */ -Js.log(getIds(` { "ids" : [1, 2, 3 ] } `)) -``` -*/ -external parseExn: string => t = "parse" - -@val -@scope("JSON") -/** -`stringify(json)` formats the JSON data structure as a `string`. -Returns the string representation of a given JSON data structure. - -See [`stringify`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/JSON/stringify) on MDN. - -## Examples - -```rescript -/* Creates and stringifies a simple JS object */ - -let dict = Js.Dict.empty() -Js.Dict.set(dict, "name", Js.Json.string("John Doe")) -Js.Dict.set(dict, "age", Js.Json.number(30.0)) -Js.Dict.set(dict, "likes", Js.Json.stringArray(["ReScript", "ocaml", "js"])) - -Js.log(Js.Json.stringify(Js.Json.object_(dict))) -``` -*/ -external stringify: t => string = "stringify" - -@val -@scope("JSON") -/** -`stringifyWithSpace(json)` formats the JSON data structure as a `string`. -Returns the string representation of a given JSON data structure with spacing. - -See [`stringify`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/JSON/stringify) on MDN. - -## Examples - -```rescript -/* Creates and stringifies a simple JS object with spacing */ - -let dict = Js.Dict.empty() -Js.Dict.set(dict, "name", Js.Json.string("John Doe")) -Js.Dict.set(dict, "age", Js.Json.number(30.0)) -Js.Dict.set(dict, "likes", Js.Json.stringArray(["ReScript", "ocaml", "js"])) - -Js.log(Js.Json.stringifyWithSpace(Js.Json.object_(dict), 2)) -``` -*/ -external stringifyWithSpace: (t, @as(json`null`) _, int) => string = "stringify" - -@val -@scope("JSON") -/** -`stringifyAny(value)` formats any value into a JSON string. - -## Examples - -```rescript -/* prints `["hello", "world"]` */ -Js.log(Js.Json.stringifyAny(["hello", "world"])) -``` -*/ -external stringifyAny: 'a => option = "stringify" - -/** -Best-effort serialization, it tries to seralize as -many objects as possible and deserialize it back - -It is unsafe in two aspects -- It may throw during parsing -- when you cast it to a specific type, it may have a type mismatch -*/ -let deserializeUnsafe: string => 'a - -/** -It will raise in such situations: -- The object can not be serlialized to a JSON -- There are cycles -- Some JS engines can not stringify deeply nested json objects -*/ -let serializeExn: 'a => string diff --git a/jscomp/others/js_list.res b/jscomp/others/js_list.res deleted file mode 100644 index 72c66b5..0000000 --- a/jscomp/others/js_list.res +++ /dev/null @@ -1,213 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@@warning("-3") - -type t<'a> = list<'a> - -let rec lengthAux = (len, x) => - switch x { - | list{} => len - | list{_, ...l} => lengthAux(len + 1, l) - } - -let length = l => lengthAux(0, l) - -let cons = (x, xs) => list{x, ...xs} - -let isEmpty = x => x == list{} - -let hd = x => - switch x { - | list{} => None - | list{a, ..._} => Some(a) - } - -let tl = x => - switch x { - | list{} => None - | list{_, ...l} => Some(l) - } - -let nth = (l, n) => - if n < 0 { - None - } else { - let rec nth_aux = (l, n) => - switch l { - | list{} => None - | list{a, ...l} => - if n == 0 { - Some(a) - } else { - nth_aux(l, n - 1) - } - } - nth_aux(l, n) - } - -let rec revAppend = (l1, l2) => - switch l1 { - | list{} => l2 - | list{a, ...l} => revAppend(l, list{a, ...l2}) - } - -let rev = l => revAppend(l, list{}) - -let rec mapRevAux = (f, acc, ls) => - switch ls { - | list{} => acc - | list{a, ...l} => mapRevAux(f, list{f(. a), ...acc}, l) - } - -let mapRev = (f, ls) => mapRevAux(f, list{}, ls) - -let map = (f, ls) => rev(mapRevAux(f, list{}, ls)) - -let rec iter = (f, x) => - switch x { - | list{} => () - | list{a, ...l} => - f(. a) - iter(f, l) - } - -let rec iteri = (i, f, x) => - switch x { - | list{} => () - | list{a, ...l} => - f(. i, a) - iteri(i + 1, f, l) - } - -let iteri = (f, l) => iteri(0, f, l) - -let rec foldLeft = (f, accu, l) => - switch l { - | list{} => accu - | list{a, ...l} => foldLeft(f, f(. accu, a), l) - } - -let foldRightMaxStack = 1000 - -let rec tailLoop = (f, acc, x) => - switch x { - | list{} => acc - | list{h, ...t} => tailLoop(f, f(. h, acc), t) - } - -let foldRight = (f, l, init) => { - let rec loop = (n, x) => - switch x { - | list{} => init - | list{h, ...t} => - if n < foldRightMaxStack { - f(. h, loop(n + 1, t)) - } else { - f(. h, tailLoop(f, init, rev(t))) - } - } - - loop(0, l) -} - -let rec flattenAux = (acc, lx) => - switch lx { - | list{} => rev(acc) - | list{y, ...ys} => flattenAux(revAppend(y, acc), ys) - } - -let flatten = lx => flattenAux(list{}, lx) - -let rec filterRevAux = (f, acc, xs) => - switch xs { - | list{} => acc - | list{y, ...ys} => - switch f(. y) { - | false => filterRevAux(f, acc, ys) - | true => filterRevAux(f, list{y, ...acc}, ys) - } - } - -let filter = (f, xs) => rev(filterRevAux(f, list{}, xs)) - -let rec filterMapRevAux = (f: (. 'a) => option<'b>, acc, xs) => - switch xs { - | list{} => acc - | list{y, ...ys} => - switch f(. y) { - | None => filterMapRevAux(f, acc, ys) - | Some(z) => filterMapRevAux(f, list{z, ...acc}, ys) - } - } - -let filterMap = (f, xs) => rev(filterMapRevAux(f, list{}, xs)) - -let rec countByAux = (f, acc, xs) => - switch xs { - | list{} => acc - | list{y, ...ys} => - countByAux( - f, - if f(. y) { - acc + 1 - } else { - acc - }, - ys, - ) - } - -let countBy = (f, xs) => countByAux(f, 0, xs) - -let init = (n, f) => Js_vector.toList(Js_vector.init(n, f)) - -@new external createUnsafe: int => array<'a> = "Array" - -let toVector = xs => - switch xs { - | list{} => [] - | l => - let a = createUnsafe(length(l)) - let rec fill = (i, x) => - switch x { - | list{} => a - | list{hd, ...tl} => - Js_array2.unsafe_set(a, i, hd) - fill(i + 1, tl) - } - fill(0, l) - } - -let rec equal = (cmp, xs, ys) => - switch (xs, ys) { - | (list{}, list{}) => true - | (list{x, ...xs}, list{y, ...ys}) => - if cmp(. x, y) { - equal(cmp, xs, ys) - } else { - false - } - | (_, _) => false - } diff --git a/jscomp/others/js_list.resi b/jscomp/others/js_list.resi deleted file mode 100644 index d4c9efa..0000000 --- a/jscomp/others/js_list.resi +++ /dev/null @@ -1,71 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@@deprecated("Use Belt.List instead") - -type t<'a> = list<'a> - -let length: t<'a> => int - -let cons: ('a, t<'a>) => t<'a> - -let isEmpty: t<'a> => bool - -let hd: t<'a> => option<'a> - -let tl: t<'a> => option> - -let nth: (t<'a>, int) => option<'a> - -let revAppend: (t<'a>, t<'a>) => t<'a> - -let rev: t<'a> => t<'a> - -let mapRev: ((. 'a) => 'b, t<'a>) => t<'b> - -let map: ((. 'a) => 'b, t<'a>) => t<'b> - -let iter: ((. 'a) => unit, t<'a>) => unit - -let iteri: ((. int, 'a) => unit, t<'a>) => unit - -/** Application order is left to right, tail recurisve */ -let foldLeft: ((. 'a, 'b) => 'a, 'a, list<'b>) => 'a - -/** Application order is right to left tail-recursive. */ -let foldRight: ((. 'a, 'b) => 'b, list<'a>, 'b) => 'b - -let flatten: t> => t<'a> - -let filter: ((. 'a) => bool, t<'a>) => t<'a> - -let filterMap: ((. 'a) => option<'b>, t<'a>) => t<'b> - -let countBy: ((. 'a) => bool, list<'a>) => int - -let init: (int, (. int) => 'a) => t<'a> - -let toVector: t<'a> => array<'a> - -let equal: ((. 'a, 'a) => bool, list<'a>, list<'a>) => bool diff --git a/jscomp/others/js_map.res b/jscomp/others/js_map.res deleted file mode 100644 index e5e1c8e..0000000 --- a/jscomp/others/js_map.res +++ /dev/null @@ -1,3 +0,0 @@ -/*** ES6 Map API */ - -type t<'k, 'v> diff --git a/jscomp/others/js_mapperRt.res b/jscomp/others/js_mapperRt.res deleted file mode 100644 index 4c68f13..0000000 --- a/jscomp/others/js_mapperRt.res +++ /dev/null @@ -1,61 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@get_index external unsafeGet: (array, int) => int = "" - -let raiseWhenNotFound = x => - if Js.testAny(x) { - raise(Not_found) - } else { - x - } - -let rec fromIntAux = (enum: int, i, len, xs) => - if i == len { - None - } else { - let k = unsafeGet(xs, i) - if k == enum { - Some(i) - } else { - fromIntAux(enum, i + 1, len, xs) - } - } - -let fromInt = (len, xs: array, enum: int): option<'variant> => fromIntAux(enum, 0, len, xs) - -let rec fromIntAssertAux = (len, enum: int, i, xs) => - if i == len { - raise(Not_found) - } else { - let k = unsafeGet(xs, i) - if k == enum { - i - } else { - fromIntAssertAux(len, enum, i + 1, xs) - } - } - -/** `length` is not relevant any more */ -let fromIntAssert = (len, xs: array, enum: int) => fromIntAssertAux(len, enum, 0, xs) diff --git a/jscomp/others/js_mapperRt.resi b/jscomp/others/js_mapperRt.resi deleted file mode 100644 index 6b9dbdd..0000000 --- a/jscomp/others/js_mapperRt.resi +++ /dev/null @@ -1,32 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let raiseWhenNotFound: 'a => 'a - -/** -`fromInt(len, array, int)` return the mapped `enum` -*/ -let fromInt: (int, array, int) => option - -let fromIntAssert: (int /* len */, array, int) => int diff --git a/jscomp/others/js_math.ml b/jscomp/others/js_math.ml deleted file mode 100644 index c03ffcb..0000000 --- a/jscomp/others/js_math.ml +++ /dev/null @@ -1,656 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -(** -Provide utilities for JS Math. Note: The constants `_E`, `_LN10`, `_LN2`, -`_LOG10E`, `_LOG2E`, `_PI`, `_SQRT1_2`, and `_SQRT2` begin with an underscore -because ReScript variable names cannot begin with a capital letter. (Module -names begin with upper case.) -*) - -(** -Euler's number; ≈ 2.718281828459045. See -[`Math.E`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/E) -on MDN. -*) -external _E : float = "E" [@@bs.val] [@@bs.scope "Math"] - -(** -Natural logarithm of 2; ≈ 0.6931471805599453. See -[`Math.LN2`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/LN2) -on MDN. -*) -external _LN2 : float = "LN2" [@@bs.val] [@@bs.scope "Math"] - -(** -Natural logarithm of 10; ≈ 2.302585092994046. See -[`Math.LN10`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/LN10) -on MDN. -*) -external _LN10 : float = "LN10" [@@bs.val] [@@bs.scope "Math"] - -(** -Base 2 logarithm of E; ≈ 1.4426950408889634. See -[`Math.LOG2E`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/LOG2E) -on MDN. -*) -external _LOG2E : float = "LOG2E" [@@bs.val] [@@bs.scope "Math"] - -(** -Base 10 logarithm of E; ≈ 0.4342944819032518. See -[`Math.LOG10E`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/LOG10E) -on MDN. -*) -external _LOG10E : float = "LOG10E" [@@bs.val] [@@bs.scope "Math"] - -(** -Pi - ratio of the circumference to the diameter of a circle; ≈ 3.141592653589793. See -[`Math.PI`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/PI) -on MDN. -*) -external _PI : float = "PI" [@@bs.val] [@@bs.scope "Math"] - -(** -Square root of 1/2; ≈ 0.7071067811865476. See -[`Math.SQRT1_2`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/SQRT1_2) -on MDN. -*) -external _SQRT1_2 : float = "SQRT1_2" [@@bs.val] [@@bs.scope "Math"] - -(** -Square root of 2; ≈ 1.4142135623730951. See -[`Math.SQRT2`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/SQRT2) -on MDN. -*) -external _SQRT2 : float = "SQRT2" [@@bs.val] [@@bs.scope "Math"] - -(** -Absolute value for integer argument. See -[`Math.abs`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/abs) -on MDN. -*) -external abs_int : int -> int = "abs" [@@bs.val] [@@bs.scope "Math"] - -(** -Absolute value for float argument. See -[`Math.abs`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/abs) -on MDN. -*) -external abs_float : float -> float = "abs" [@@bs.val] [@@bs.scope "Math"] - -(** -Arccosine (in radians) of argument; returns `NaN` if the argument is outside -the range [-1.0, 1.0]. See -[`Math.acos`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/acos) -on MDN. -*) -external acos : float -> float = "acos" [@@bs.val] [@@bs.scope "Math"] - -(** -Hyperbolic arccosine (in radians) of argument; returns `NaN` if the argument -is less than 1.0. See -[`Math.acosh`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/acosh) -on MDN. -*) -external acosh : float -> float = "acosh" [@@bs.val] [@@bs.scope "Math"] - -(** -Arcsine (in radians) of argument; returns `NaN` if the argument is outside -the range [-1.0, 1.0]. See -[`Math.asin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/asin) -on MDN. -*) -external asin : float -> float = "asin" [@@bs.val] [@@bs.scope "Math"] - -(** -Hyperbolic arcsine (in radians) of argument. See -[`Math.asinh`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/asinh) -on MDN. -*) -external asinh : float -> float = "asinh" [@@bs.val] [@@bs.scope "Math"] - -(** -Arctangent (in radians) of argument. See -[`Math.atan`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/atan) -on MDN. -*) -external atan : float -> float = "atan" [@@bs.val] [@@bs.scope "Math"] - -(** -Hyperbolic arctangent (in radians) of argument; returns `NaN` if the argument -is is outside the range [-1.0, 1.0]. Returns `-Infinity` and `Infinity` for -arguments -1.0 and 1.0. See -[`Math.atanh`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/atanh) -on MDN. -*) -external atanh : float -> float = "atanh" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the angle (in radians) of the quotient `y /. x`. It is also the angle -between the *x*-axis and point (*x*, *y*). See -[`Math.atan2`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/atan2) -on MDN. - -## Examples - -```rescript -Js.Math.atan2(~y=0.0, ~x=10.0, ()) == 0.0 -Js.Math.atan2(~x=5.0, ~y=5.0, ()) == Js.Math._PI /. 4.0 -Js.Math.atan2(~x=-5.0, ~y=5.0, ()) -Js.Math.atan2(~x=-5.0, ~y=5.0, ()) == 3.0 *. Js.Math._PI /. 4.0 -Js.Math.atan2(~x=-0.0, ~y=-5.0, ()) == -.Js.Math._PI /. 2.0 -``` -*) -external atan2 : y:float -> x:float -> unit -> float = "atan2" [@@bs.val] [@@bs.scope "Math"] - -(** -Cube root. See -[`Math.cbrt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/cbrt) -on MDN -*) -external cbrt : float -> float = "cbrt" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the smallest integer greater than or equal to the argument. This -function may return values not representable by `int`, whose range is --2147483648 to 2147483647. This is because, in JavaScript, there are only -64-bit floating point numbers, which can represent integers in the range -±(253-1) exactly. See -[`Math.ceil`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/ceil) -on MDN. - -## Examples - -```rescript -Js.Math.unsafe_ceil_int(3.1) == 4 -Js.Math.unsafe_ceil_int(3.0) == 3 -Js.Math.unsafe_ceil_int(-3.1) == -3 -Js.Math.unsafe_ceil_int(1.0e15) // result is outside range of int datatype -``` -*) -external unsafe_ceil_int : float -> int = "ceil" [@@bs.val] [@@bs.scope "Math"] - -let unsafe_ceil = unsafe_ceil_int -[@@deprecated "Please use `unsafe_ceil_int` instead"] - -(** -Returns the smallest `int` greater than or equal to the argument; the result -is pinned to the range of the `int` data type: -2147483648 to 2147483647. See -[`Math.ceil`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/ceil) -on MDN. - -## Examples - -```rescript -Js.Math.ceil_int(3.1) == 4 -Js.Math.ceil_int(3.0) == 3 -Js.Math.ceil_int(-3.1) == -3 -Js.Math.ceil_int(-1.0e15) == -2147483648 -Js.Math.ceil_int(1.0e15) == 2147483647 -``` -*) -let ceil_int (f : float) : int = - if f > Js_int.toFloat Js_int.max then Js_int.max - else if f < Js_int.toFloat Js_int.min then Js_int.min - else unsafe_ceil_int f - -let ceil = ceil_int -[@@deprecated "Please use `ceil_int` instead"] - -(** -Returns the smallest integral value greater than or equal to the argument. -The result is a `float` and is not restricted to the `int` data type range. -See -[`Math.ceil`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/ceil) -on MDN. - -## Examples - -```rescript -Js.Math.ceil_float(3.1) == 4.0 -Js.Math.ceil_float(3.0) == 3.0 -Js.Math.ceil_float(-3.1) == -3.0 -Js.Math.ceil_float(2_150_000_000.3) == 2_150_000_001.0 -``` -*) -external ceil_float : float -> float = "ceil" [@@bs.val] [@@bs.scope "Math"] - -(** -Number of leading zero bits of the argument's 32 bit int representation. See -[`Math.clz32`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/clz32) -on MDN. - -## Examples - -```rescript -Js.Math.clz32(0) == 32 -Js.Math.clz32(-1) == 0 -Js.Math.clz32(255) == 24 -``` -*) -external clz32 : int -> int = "clz32" [@@bs.val] [@@bs.scope "Math"] - -(** -Cosine of argument, which must be specified in radians. See -[`Math.cos`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/cos) -on MDN. -*) -external cos : float -> float = "cos" [@@bs.val] [@@bs.scope "Math"] - -(** -Hyperbolic cosine of argument, which must be specified in radians. See -[`Math.cosh`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/cosh) -on MDN. -*) -external cosh : float -> float = "cosh" [@@bs.val] [@@bs.scope "Math"] - -(** -Natural exponentional; returns *e* (the base of natural logarithms) to the -power of the given argument. See -[`Math.exp`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/exp) -on MDN. -*) -external exp : float -> float = "exp" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns *e* (the base of natural logarithms) to the power of the given -argument minus 1. See -[`Math.expm1`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/expm1) -on MDN. -*) -external expm1 : float -> float = "expm1" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the largest integer less than or equal to the argument. This function -may return values not representable by `int`, whose range is -2147483648 to -2147483647. This is because, in JavaScript, there are only 64-bit floating -point numbers, which can represent integers in the range -±(253-1) exactly. See -[`Math.floor`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/floor) -on MDN. - -## Examples - -```rescript -Js.Math.unsafe_floor_int(3.7) == 3 -Js.Math.unsafe_floor_int(3.0) == 3 -Js.Math.unsafe_floor_int(-3.7) == -4 -Js.Math.unsafe_floor_int(1.0e15) // result is outside range of int datatype -``` -*) -external unsafe_floor_int : float -> int = "floor" [@@bs.val] [@@bs.scope "Math"] - -let unsafe_floor = unsafe_floor_int -[@@deprecated "Please use `unsafe_floor_int` instead"] - -(** -Returns the largest `int` less than or equal to the argument; the result is -pinned to the range of the `int` data type: -2147483648 to 2147483647. See -[`Math.floor`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/floor) -on MDN. - -## Examples - -```rescript -Js.Math.floor_int(3.7) == 3 -Js.Math.floor_int(3.0) == 3 -Js.Math.floor_int(-3.1) == -4 -Js.Math.floor_int(-1.0e15) == -2147483648 -Js.Math.floor_int(1.0e15) == 2147483647 -``` -*) -let floor_int f = - if f > Js_int.toFloat Js_int.max then Js_int.max - else if f < Js_int.toFloat Js_int.min then Js_int.min - else unsafe_floor f - -let floor = floor_int -[@@deprecated "Please use `floor_int` instead"] - -(** -Returns the largest integral value less than or equal to the argument. The -result is a `float` and is not restricted to the `int` data type range. See -[`Math.floor`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/floor) -on MDN. - -## Examples - -```rescript -Js.Math.floor_float(3.7) == 3.0 -Js.Math.floor_float(3.0) == 3.0 -Js.Math.floor_float(-3.1) == -4.0 -Js.Math.floor_float(2_150_000_000.3) == 2_150_000_000.0 -``` -*) -external floor_float : float -> float = "floor" [@@bs.val] [@@bs.scope "Math"] - -(** -Round to nearest single precision float. See -[`Math.fround`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/fround) -on MDN. - -## Examples - -```rescript -Js.Math.fround(5.5) == 5.5 -Js.Math.fround(5.05) == 5.050000190734863 -``` -*) -external fround : float -> float = "fround" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the square root of the sum of squares of its two arguments (the -Pythagorean formula). See -[`Math.hypot`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/hypot) -on MDN. -*) -external hypot : float -> float -> float = "hypot" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the square root of the sum of squares of the numbers in the array -argument (generalized Pythagorean equation). Using an array allows you to -have more than two items. See -[`Math.hypot`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/hypot) -on MDN. - -## Examples - -```rescript -Js.Math.hypotMany([3.0, 4.0, 12.0]) == 13.0 -``` -*) -external hypotMany : float array -> float = "hypot" [@@bs.val] [@@bs.splice] [@@bs.scope "Math"] - -(** -32-bit integer multiplication. Use this only when you need to optimize -performance of multiplication of numbers stored as 32-bit integers. See -[`Math.imul`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/imul) -on MDN. -*) -external imul : int -> int -> int = "imul" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the natural logarithm of its argument; this is the number *x* such -that *e**x* equals the argument. Returns `NaN` for negative -arguments. See -[`Math.log`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/log) -on MDN. - -## Examples - -```rescript -Js.Math.log(Js.Math._E) == 1.0 -Js.Math.log(100.0) == 4.605170185988092 -``` -*) -external log : float -> float = "log" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the natural logarithm of one plus the argument. Returns `NaN` for -arguments less than -1. See -[`Math.log1p`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/log1p) -on MDN. - -## Examples - -```rescript -Js.Math.log1p(Js.Math._E -. 1.0) == 1.0 -Js.Math.log1p(99.0) == 4.605170185988092 -``` -*) -external log1p : float -> float = "log1p" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the base 10 logarithm of its argument. Returns `NaN` for negative -arguments. See -[`Math.log10`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/log10) -on MDN. - -## Examples - -```rescript -Js.Math.log10(1000.0) == 3.0 -Js.Math.log10(0.01) == -2.0 -Js.Math.log10(Js.Math.sqrt(10.0)) == 0.5 -``` -*) -external log10 : float -> float = "log10" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the base 2 logarithm of its argument. Returns `NaN` for negative -arguments. See -[`Math.log2`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/log2) -on MDN. - -## Examples - -```rescript -Js.Math.log2(512.0) == 9.0 -Js.Math.log2(0.125) == -3.0 -Js.Math.log2(Js.Math._SQRT2) == 0.5000000000000001 // due to precision -``` -*) -external log2 : float -> float = "log2" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the maximum of its two integer arguments. See -[`Math.max`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/max) -on MDN. -*) -external max_int : int -> int -> int = "max" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the maximum of the integers in the given array. See -[`Math.max`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/max) -on MDN. -*) -external maxMany_int : int array -> int = "max" [@@bs.val] [@@bs.splice] [@@bs.scope "Math"] - -(** -Returns the maximum of its two floating point arguments. See -[`Math.max`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/max) -on MDN. -*) -external max_float : float -> float -> float = "max" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the maximum of the floating point values in the given array. See -[`Math.max`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/max) -on MDN. -*) -external maxMany_float : float array -> float = "max" [@@bs.val] [@@bs.splice] [@@bs.scope "Math"] - -(** -Returns the minimum of its two integer arguments. See -[`Math.min`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/min) -on MDN. -*) -external min_int : int -> int -> int = "min" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the minimum of the integers in the given array. See -[`Math.min`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/min) -on MDN. -*) -external minMany_int : int array -> int = "min" [@@bs.val] [@@bs.splice] [@@bs.scope "Math"] - -(** -Returns the minimum of its two floating point arguments. See -[`Math.min`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/min) -on MDN. -*) -external min_float : float -> float -> float = "min" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the minimum of the floating point values in the given array. See -[`Math.min`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/min) -on MDN. -*) -external minMany_float : float array -> float = "min" [@@bs.val] [@@bs.splice] [@@bs.scope "Math"] - -(** -Raises the given base to the given exponent. (Arguments and result are -integers.) See -[`Math.pow`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/pow) -on MDN. - -## Examples - -```rescript -Js.Math.pow_int(~base=3, ~exp=4) == 81 -``` -*) -external pow_int : base:int -> exp:int -> int = "pow" [@@bs.val] [@@bs.scope "Math"] -[@@deprecated "use `pow_float` instead, the return type may be not int"] - -(** -Raises the given base to the given exponent. (Arguments and result are -floats.) Returns `NaN` if the result would be imaginary. See -[`Math.pow`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/pow) -on MDN. - -## Examples - -```rescript -Js.Math.pow_float(~base=3.0, ~exp=4.0) == 81.0 -Js.Math.pow_float(~base=4.0, ~exp=-2.0) == 0.0625 -Js.Math.pow_float(~base=625.0, ~exp=0.5) == 25.0 -Js.Math.pow_float(~base=625.0, ~exp=-0.5) == 0.04 -Js.Float.isNaN(Js.Math.pow_float(~base=-2.0, ~exp=0.5)) == true -``` -*) -external pow_float : base:float -> exp:float -> float = "pow" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns a random number in the half-closed interval [0,1). See -[`Math.random`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/random) -on MDN. -*) -external random : unit -> float = "random" [@@bs.val] [@@bs.scope "Math"] - -(** -A call to `random_int(minVal, maxVal)` returns a random number in the -half-closed interval [minVal, maxVal). See -[`Math.random`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/random) -on MDN. -*) -let random_int min max = - floor ((random ()) *. (Js_int.toFloat (max - min))) + min - -(** -Rounds its argument to nearest integer. For numbers with a fractional portion -of exactly 0.5, the argument is rounded to the next integer in the direction -of positive infinity. This function may return values not representable by -`int`, whose range is -2147483648 to 2147483647. This is because, in -JavaScript, there are only 64-bit floating point numbers, which can represent -integers in the range ±(253-1) exactly. See -[`Math.round`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/round) -on MDN. - -## Examples - -```rescript -Js.Math.unsafe_round(3.7) == 4 -Js.Math.unsafe_round(-3.5) == -3 -Js.Math.unsafe_round(2_150_000_000_000.3) // out of range for int -``` -*) -external unsafe_round : float -> int = "round" [@@bs.val] [@@bs.scope "Math"] - -(** -Rounds to nearest integral value (expressed as a float). See -[`Math.round`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/round) -on MDN. -*) -external round : float -> float = "round" [@@bs.val] [@@bs.scope "Math"] - -(** -Returns the sign of its integer argument: -1 if negative, 0 if zero, 1 if -positive. See -[`Math.sign`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sign) -on MDN. -*) -external sign_int : int -> int = "sign" [@@bs.val][@@bs.scope "Math"] - -(** -Returns the sign of its float argument: -1.0 if negative, 0.0 if zero, 1.0 if -positive. See -[`Math.sign`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sign) -on MDN. -*) -external sign_float : float -> float = "sign" [@@bs.val][@@bs.scope "Math"] - -(** -Sine of argument, which must be specified in radians. See -[`Math.sin`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sin) -on MDN. -*) -external sin : float -> float = "sin" [@@bs.val][@@bs.scope "Math"] - -(** -Hyperbolic sine of argument, which must be specified in radians. See -[`Math.sinh`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sinh) -on MDN. -*) -external sinh : float -> float = "sinh" [@@bs.val][@@bs.scope "Math"] - -(** -Square root. If the argument is negative, this function returns `NaN`. See -[`Math.sqrt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/sqrt) -on MDN. -*) -external sqrt : float -> float = "sqrt" [@@bs.val][@@bs.scope "Math"] - -(** -Tangent of argument, which must be specified in radians. Returns `NaN` if the -argument is positive infinity or negative infinity. See -[`Math.cos`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/cos) -on MDN. -*) -external tan : float -> float = "tan" [@@bs.val][@@bs.scope "Math"] - -(** -Hyperbolic tangent of argument, which must be specified in radians. See -[`Math.tanh`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/tanh) -on MDN. -*) -external tanh : float -> float = "tanh" [@@bs.val][@@bs.scope "Math"] - -(** -Truncates its argument; i.e., removes fractional digits. This function may -return values not representable by `int`, whose range is -2147483648 to -2147483647. This is because, in JavaScript, there are only 64-bit floating -point numbers, which can represent integers in the range ±(253-1) -exactly. See -[`Math.trunc`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/trunc) -on MDN. -*) -external unsafe_trunc : float -> int = "trunc" [@@bs.val][@@bs.scope "Math"] - -(** -Truncates its argument; i.e., removes fractional digits. See -[`Math.trunc`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Math/trunc) -on MDN. -*) -external trunc : float -> float = "trunc" [@@bs.val][@@bs.scope "Math"] diff --git a/jscomp/others/js_null.res b/jscomp/others/js_null.res deleted file mode 100644 index 6c3adbc..0000000 --- a/jscomp/others/js_null.res +++ /dev/null @@ -1,63 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provides functionality for dealing with the `'a Js.null` type */ - -@unboxed -type t<+'a> = Js.null<'a> = - | Value('a) - | @as(null) Null - -external to_opt: t<'a> => option<'a> = "#null_to_opt" -external toOption: t<'a> => option<'a> = "#null_to_opt" -external return: 'a => t<'a> = "%identity" -let test: t<'a> => bool = x => x == Js.null -external empty: t<'a> = "#null" -external getUnsafe: t<'a> => 'a = "%identity" - -let getExn = f => - switch toOption(f) { - | None => Js_exn.raiseError("Js.Null.getExn") - | Some(x) => x - } - -let bind = (x, f) => - switch toOption(x) { - | None => empty - | Some(x) => return(f(. x)) - } - -let iter = (x, f) => - switch toOption(x) { - | None => () - | Some(x) => f(. x) - } - -let fromOption = x => - switch x { - | None => empty - | Some(x) => return(x) - } - -let from_opt = fromOption diff --git a/jscomp/others/js_null.resi b/jscomp/others/js_null.resi deleted file mode 100644 index 4c99635..0000000 --- a/jscomp/others/js_null.resi +++ /dev/null @@ -1,90 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provides functionality for dealing with the `Js.null<'a>` type */ - -@unboxed /** Local alias for `Js.null<'a>` */ -type t<+'a> = Js.null<'a> = - | Value('a) - | @as(null) Null - -/** Constructs a value of `Js.null<'a>` containing a value of `'a`. */ -external return: 'a => t<'a> = "%identity" - -@deprecated("Use = Js.null directly ") -/** Returns `true` if the given value is empty (`null`), `false` otherwise. */ -let test: t<'a> => bool - -/** The empty value, `null` */ -external empty: t<'a> = "#null" - -external getUnsafe: t<'a> => 'a = "%identity" -let getExn: t<'a> => 'a - -/** -Maps the contained value using the given function. - -If `Js.null<'a>` contains a value, that value is unwrapped, mapped to a `'b` -using the given function `'a => 'b`, then wrapped back up and returned as -`Js.null<'b>`. - -## Examples - -```rescript -let maybeGreetWorld = (maybeGreeting: Js.null) => - Js.Null.bind(maybeGreeting, (. greeting) => greeting ++ " world!") -``` -*/ -let bind: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -Iterates over the contained value with the given function. -If `Js.null<'a>` contains a value, that value is unwrapped and applied to the given function. - -## Examples - -```rescript -let maybeSay = (maybeMessage: Js.null) => - Js.Null.iter(maybeMessage, (. message) => Js.log(message)) -``` -*/ -let iter: (t<'a>, (. 'a) => unit) => unit - -/** -Maps `option<'a>` to `Js.null<'a>`. -`Some(a)` => `a` -`None` => `empty` -*/ -let fromOption: option<'a> => t<'a> - -@deprecated("Use fromOption instead") let from_opt: option<'a> => t<'a> - -/** -Maps `Js.null<'a>` to `option<'a>`. -`a` => `Some(a)` -`empty` => `None` -*/ -external toOption: t<'a> => option<'a> = "#null_to_opt" - -@deprecated("Use toOption instead") external to_opt: t<'a> => option<'a> = "#null_to_opt" diff --git a/jscomp/others/js_null_undefined.res b/jscomp/others/js_null_undefined.res deleted file mode 100644 index 7c5ab1b..0000000 --- a/jscomp/others/js_null_undefined.res +++ /dev/null @@ -1,58 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Contains functionality for dealing with values that can be both `null` and `undefined` */ - -@unboxed -type t<+'a> = Js.nullable<'a> = - | Value('a) - | @as(null) Null - | @as(undefined) Undefined - -external toOption: t<'a> => option<'a> = "#nullable_to_opt" -external to_opt: t<'a> => option<'a> = "#nullable_to_opt" -external return: 'a => t<'a> = "%identity" -external isNullable: t<'a> => bool = "#is_nullable" -external null: t<'a> = "#null" -external undefined: t<'a> = "#undefined" - -let bind = (x, f) => - switch to_opt(x) { - | None => (Obj.magic((x: t<'a>)): t<'b>) - | Some(x) => return(f(. x)) - } - -let iter = (x, f) => - switch to_opt(x) { - | None => () - | Some(x) => f(. x) - } - -let fromOption = x => - switch x { - | None => undefined - | Some(x) => return(x) - } - -let from_opt = fromOption diff --git a/jscomp/others/js_null_undefined.resi b/jscomp/others/js_null_undefined.resi deleted file mode 100644 index e183e73..0000000 --- a/jscomp/others/js_null_undefined.resi +++ /dev/null @@ -1,94 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Contains functionality for dealing with values that can be both `null` and `undefined` -*/ - -/** Local alias for `Js.null_undefined<'a>`. */ -@unboxed -type t<+'a> = Js.nullable<'a> = - | Value('a) - | @as(null) Null - | @as(undefined) Undefined - -/** Constructs a value of `Js.null_undefined<'a>` containing a value of `'a`. */ -external return: 'a => t<'a> = "%identity" - -/** Returns `true` if the given value is null or undefined, `false` otherwise. */ -external isNullable: t<'a> => bool = "#is_nullable" - -/** The null value of type `Js.null_undefined<'a>`. */ -external null: t<'a> = "#null" - -/** The undefined value of type `Js.null_undefined<'a>`. */ -external undefined: t<'a> = "#undefined" - -/** -Maps the contained value using the given function. - -If `Js.null_undefined<'a>` contains a value, that value is unwrapped, mapped to -a `'b` using the given function `a' => 'b`, then wrapped back up and returned -as `Js.null_undefined<'b>`. - -## Examples - -```rescript -let maybeGreetWorld = (maybeGreeting: Js.null_undefined) => - Js.Null_undefined.bind(maybeGreeting, (. greeting) => greeting ++ " world!") -``` -*/ -let bind: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -Iterates over the contained value with the given function. -If `Js.null_undefined<'a>` contains a value, that value is unwrapped and applied to the given function. - -## Examples - -```rescript -let maybeSay = (maybeMessage: Js.null_undefined) => - Js.Null_undefined.iter(maybeMessage, (. message) => Js.log(message)) -``` -*/ -let iter: (t<'a>, (. 'a) => unit) => unit - -/** -Maps `option<'a>` to `Js.null_undefined<'a>`. -`Some(a)` => `a` -`None` => `undefined` -*/ -let fromOption: option<'a> => t<'a> - -@deprecated("Use fromOption instead") let from_opt: option<'a> => t<'a> - -/** -Maps `Js.null_undefined<'a>` to `option<'a>`. -`a` => `Some(a)` -`undefined` => `None` -`null` => `None` -*/ -external toOption: t<'a> => option<'a> = "#nullable_to_opt" - -@deprecated("Use toOption instead") external to_opt: t<'a> => option<'a> = "#nullable_to_opt" diff --git a/jscomp/others/js_obj.res b/jscomp/others/js_obj.res deleted file mode 100644 index eb3fb14..0000000 --- a/jscomp/others/js_obj.res +++ /dev/null @@ -1,103 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provides functions for inspecting and manipulating native JavaScript objects -*/ - -@obj /** `empty()` returns the empty object `{}` */ -external empty: unit => {..} = "" - -@val -/** -`assign(target, source)` copies properties from source to target. -Properties in `target` will be overwritten by properties in `source` if they have the same key. -Returns `target`. - -**See** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Object/assign) - -## Examples - -```rescript -/* Copy an object */ - -let obj = {"a": 1} - -let copy = Js.Obj.assign(Js.Obj.empty(), obj) - -/* prints "{ a: 1 }" */ -Js.log(copy) - -/* Merge objects with same properties */ - -let target = {"a": 1, "b": 1} -let source = {"b": 2} - -let obj = Js.Obj.assign(target, source) - -/* prints "{ a: 1, b: 2 }" */ -Js.log(obj) - -/* prints "{ a: 1, b: 2 }", target is modified */ -Js.log(target) -``` -*/ -external assign: ({..}, {..}) => {..} = "Object.assign" - -/* TODO: - - Should we map this API as directly as possible, provide some abstractions, or deliberately nerf it? - - "static": - - Object.create - - Object.defineProperty - - Object.defineProperties - - Object.entries - experimental - - Object.getOwnPropertyDescriptor - - Object.getOwnPropertyDescriptors - - Object.getOwnPropertyNames - - Object.getOwnPropertySymbols - - Object.getPrototypeOf - - Object.isExtensible - - Object.isFrozen - - Object.isSealed - - Object.preventExtension - - Object.seal - - Object.setPrototypeOf - - Object.values - experimental - - bs.send: - - hasOwnProperty - - isPrototypeOf - - propertyIsEnumerable - - toLocaleString - - toString - - Put directly on Js? - - Object.is -*/ - -/** `keys(obj)` returns an `array` of the keys of `obj`'s own enumerable properties. */ -@val -external keys: {..} => array = "Object.keys" diff --git a/jscomp/others/js_option.res b/jscomp/others/js_option.res deleted file mode 100644 index d18e815..0000000 --- a/jscomp/others/js_option.res +++ /dev/null @@ -1,232 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provide utilities for handling `option`. */ - -/** -`Js.Option.t` is an alias for `option` -*/ -type t<'a> = option<'a> - -/** -Wraps the given value in `Some()` - -## Examples - -```rescript -Js.Option.some(1066) == Some(1066) -``` -*/ -let some = x => Some(x) - -/** -Returns `true` if the argument is `Some(value)`; `false` if the argument is -`None`. -*/ -let isSome = x => - switch x { - | None => false - | Some(_) => true - } - -/** -The first argument to `isSomeValue` is an uncurried function `eq()` that -takes two arguments and returns `true` if they are considered to be equal. It -is used to compare a plain value `v1`(the second argument) with an `option` -value. If the `option` value is `None`, `isSomeValue()` returns `false`; if -the third argument is `Some(v2)`, `isSomeValue()` returns the result of -calling `eq(v1, v2)`. - -## Examples - -```rescript -let clockEqual = (. a, b) => mod(a, 12) == mod(b, 12) -Js.Option.isSomeValue(clockEqual, 3, Some(15)) == true -Js.Option.isSomeValue(clockEqual, 3, Some(4)) == false -Js.Option.isSomeValue(clockEqual, 3, None) == false -``` -*/ -let isSomeValue = (eq, v, x) => - switch x { - | None => false - | Some(x) => eq(. v, x) - } - -/** Returns `true` if the argument is `None`; `false` otherwise. */ -let isNone = x => - switch x { - | None => true - | Some(_) => false - } - -/** -If the argument to `getExn()` is of the form `Some(value)`, returns `value`. -If given `None`, it throws a `getExn` exception. -*/ -let getExn = x => - switch x { - | None => Js_exn.raiseError("getExn") - | Some(x) => x - } - -/** -The first argument to `equal` is an uncurried function `eq()` that takes two -arguments and returns `true` if they are considered to be equal. The second -and third arguments are `option` values. - -If the second and third arguments are of the form: - -* `Some(v1)` and `Some(v2)`: returns `eq(v1, v2)` -* `Some(v1)` and `None`: returns `false` -* `None` and `Some(v2)`: returns `false` -* `None` and `None`: returns `true` - -## Examples - -```rescript -let clockEqual = (. a, b) => mod(a, 12) == mod(b, 12) -Js.Option.equal(clockEqual, Some(3), Some(15)) == true -Js.Option.equal(clockEqual, Some(3), Some(16)) == false -Js.Option.equal(clockEqual, Some(3), None) == false -Js.Option.equal(clockEqual, None, Some(15)) == false -Js.Option.equal(clockEqual, None, None) == true -``` -*/ -let equal = (eq, a, b) => - switch a { - | None => b == None - | Some(x) => - switch b { - | None => false - | Some(y) => eq(. x, y) - } - } - -/** -The first argument to `andThen()` is an uncurried function `f()` that takes a -plain value and returns an `option` result. The second argument is an -`option` value. If the second argument is `None`, the return value is `None`. -If the second argument is `Some(v)`, the return value is `f(v)`. - -## Examples - -```rescript -let reciprocal = (. x) => x == 0 ? None : Some(1.0 /. Belt.Int.toFloat(x)) -Js.Option.andThen(reciprocal, Some(5)) == Some(0.2) -Js.Option.andThen(reciprocal, Some(0)) == None -Js.Option.andThen(reciprocal, None) == None -``` -*/ -let andThen = (f, x) => - switch x { - | None => None - | Some(x) => f(. x) - } - -/** -The first argument to `map()` is an uncurried function `f()` that takes a -plain value and returns a plain result. The second argument is an `option` -value. If it is of the form `Some(v)`, `map()` returns `Some(f(v))`; if it is -`None`, the return value is `None`, and function `f()` is not called. - -## Examples - -```rescript -let square = (. x) => x * x -Js.Option.map(square, Some(3)) == Some(9) -Js.Option.map(square, None) == None -``` -*/ -let map = (f, x) => - switch x { - | None => None - | Some(x) => Some(f(. x)) - } - -/** -The first argument to `getWithDefault()` is a default value. If the second -argument is of the form `Some(v)`, `getWithDefault()` returns `v`; if the -second argument is `None`, the return value is the default value. - -## Examples - -```rescript -Js.Option.getWithDefault(1066, Some(15)) == 15 -Js.Option.getWithDefault(1066, None) == 1066 -``` -*/ -let getWithDefault = (a, x) => - switch x { - | None => a - | Some(x) => x - } - -/** **See:** [getWithDefault](#getWithDefault) */ -let default = getWithDefault - -/** -The first argument to `filter()` is an uncurried function that takes a plain -value and returns a boolean. The second argument is an `option` value. - -If the second argument is of the form `Some(v)` and `f(v)` is `true`, -the return value is `Some(v)`. Otherwise, the return value is `None`. - -## Examples - -```rescript -let isEven = (. x) => mod(x, 2) == 0 -Js.Option.filter(isEven, Some(2)) == Some(2) -Js.Option.filter(isEven, Some(3)) == None -Js.Option.filter(isEven, None) == None -``` -*/ -let filter = (f, x) => - switch x { - | None => None - | Some(x) => - if f(. x) { - Some(x) - } else { - None - } - } - -/** -The `firstSome()` function takes two `option` values; if the first is of the form `Some(v1)`, that is the return value. Otherwise, `firstSome()` returns the second value. - -## Examples - -```rescript -Js.Option.firstSome(Some("one"), Some("two")) == Some("one") -Js.Option.firstSome(Some("one"), None) == Some("one") -Js.Option.firstSome(None, Some("two")) == Some("two") -Js.Option.firstSome(None, None) == None -``` -*/ -let firstSome = (a, b) => - switch (a, b) { - | (Some(_), _) => a - | (None, Some(_)) => b - | (None, None) => None - } diff --git a/jscomp/others/js_option.resi b/jscomp/others/js_option.resi deleted file mode 100644 index dca50e3..0000000 --- a/jscomp/others/js_option.resi +++ /dev/null @@ -1,50 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t<'a> = option<'a> - -let some: 'a => option<'a> - -let isSome: option<'a> => bool - -let isSomeValue: ((. 'a, 'a) => bool, 'a, option<'a>) => bool - -let isNone: option<'a> => bool - -let getExn: option<'a> => 'a - -let equal: ((. 'a, 'b) => bool, option<'a>, option<'b>) => bool - -let andThen: ((. 'a) => option<'b>, option<'a>) => option<'b> - -let map: ((. 'a) => 'b, option<'a>) => option<'b> - -let getWithDefault: ('a, option<'a>) => 'a - -@deprecated("Use `getWithDefault` instead since default has special meaning in ES module") -let default: ('a, option<'a>) => 'a - -let filter: ((. 'a) => bool, option<'a>) => option<'a> - -let firstSome: (option<'a>, option<'a>) => option<'a> diff --git a/jscomp/others/js_promise.res b/jscomp/others/js_promise.res deleted file mode 100644 index 7268e1e..0000000 --- a/jscomp/others/js_promise.res +++ /dev/null @@ -1,106 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Deprecation note: These bindings are pretty outdated and cannot be used properly -with the `->` operator. - -More details on proper Promise usage can be found here: -https://rescript-lang.org/docs/manual/latest/promise#promise-legacy -*/ - -@@warning("-103") - -type t<+'a> = promise<'a> -type error = Js_promise2.error - -/* -## Examples - -```rescript -type error -``` -*/ - -@new -external make: ((@uncurry ~resolve: (. 'a) => unit, ~reject: (. exn) => unit) => unit) => promise< - 'a, -> = "Promise" - -/* `make (fun resolve reject -> .. )` */ -@val @scope("Promise") external resolve: 'a => promise<'a> = "resolve" -@val @scope("Promise") external reject: exn => promise<'a> = "reject" - -@val @scope("Promise") external all: array> => promise> = "all" - -@val @scope("Promise") external all2: ((promise<'a0>, promise<'a1>)) => promise<('a0, 'a1)> = "all" - -@val @scope("Promise") -external all3: ((promise<'a0>, promise<'a1>, promise<'a2>)) => promise<('a0, 'a1, 'a2)> = "all" - -@val @scope("Promise") -external all4: ((promise<'a0>, promise<'a1>, promise<'a2>, promise<'a3>)) => promise<( - 'a0, - 'a1, - 'a2, - 'a3, -)> = "all" - -@val @scope("Promise") -external all5: ((promise<'a0>, promise<'a1>, promise<'a2>, promise<'a3>, promise<'a4>)) => promise<( - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, -)> = "all" - -@val @scope("Promise") -external all6: ( - (promise<'a0>, promise<'a1>, promise<'a2>, promise<'a3>, promise<'a4>, promise<'a5>) -) => promise<('a0, 'a1, 'a2, 'a3, 'a4, 'a5)> = "all" - -@val @scope("Promise") external race: array> => promise<'a> = "race" - -@bs.send.pipe(: promise<'a>) external then_: (@uncurry ('a => promise<'b>)) => promise<'b> = "then" - -@bs.send.pipe(: promise<'a>) -external catch: (@uncurry (error => promise<'a>)) => promise<'a> = "catch" -/* ` p|> catch handler` - Note in JS the returned promise type is actually runtime dependent, - if promise is rejected, it will pick the `handler` otherwise the original promise, - to make it strict we enforce reject handler - https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/Promise/catch -*/ - -external unsafe_async: 'a => promise<'a> = "%identity" -external unsafe_await: promise<'a> => 'a = "?await" - -/* -let errorAsExn (x : error) (e : (exn ->'a option))= - if Caml_exceptions.isCamlExceptionOrOpenVariant (Obj.magic x ) then - e (Obj.magic x) - else None -[%bs.error? ] -*/ diff --git a/jscomp/others/js_promise2.res b/jscomp/others/js_promise2.res deleted file mode 100644 index 4fa6778..0000000 --- a/jscomp/others/js_promise2.res +++ /dev/null @@ -1,58 +0,0 @@ -type t<+'a> = promise<'a> -type error - -/** Type-safe t-first then */ -let then: (promise<'a>, 'a => promise<'b>) => promise<'b> = %raw(` - function(p, cont) { - return Promise.resolve(p).then(cont) - } - `) - -/** Type-safe t-first catch */ -let catch: (promise<'a>, error => promise<'a>) => promise<'a> = %raw(` - function(p, cont) { - return Promise.resolve(p).catch(cont) - } - `) - -@new -external make: ((@uncurry ~resolve: (. 'a) => unit, ~reject: (. exn) => unit) => unit) => promise< - 'a, -> = "Promise" - -@val @scope("Promise") external resolve: 'a => promise<'a> = "resolve" -@val @scope("Promise") external reject: exn => promise<'a> = "reject" - -@val @scope("Promise") external all: array> => promise> = "all" - -@val @scope("Promise") external all2: ((promise<'a0>, promise<'a1>)) => promise<('a0, 'a1)> = "all" - -@val @scope("Promise") -external all3: ((promise<'a0>, promise<'a1>, promise<'a2>)) => promise<('a0, 'a1, 'a2)> = "all" - -@val @scope("Promise") -external all4: ((promise<'a0>, promise<'a1>, promise<'a2>, promise<'a3>)) => promise<( - 'a0, - 'a1, - 'a2, - 'a3, -)> = "all" - -@val @scope("Promise") -external all5: ((promise<'a0>, promise<'a1>, promise<'a2>, promise<'a3>, promise<'a4>)) => promise<( - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, -)> = "all" - -@val @scope("Promise") -external all6: ( - (promise<'a0>, promise<'a1>, promise<'a2>, promise<'a3>, promise<'a4>, promise<'a5>) -) => promise<('a0, 'a1, 'a2, 'a3, 'a4, 'a5)> = "all" - -@val @scope("Promise") external race: array> => promise<'a> = "race" - -external unsafe_async: 'a => promise<'a> = "%identity" -external unsafe_await: promise<'a> => 'a = "?await" diff --git a/jscomp/others/js_re.res b/jscomp/others/js_re.res deleted file mode 100644 index 5ba7b60..0000000 --- a/jscomp/others/js_re.res +++ /dev/null @@ -1,201 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -Provide bindings to JS regular expressions (RegExp). - -**Note:** This is not an immutable API. A RegExp object with the `global` ("g") -flag set will modify the [`lastIndex`]() property when the RegExp object is used, -and subsequent uses will continue the search from the previous [`lastIndex`](). -*/ - -/** The RegExp object. */ -type t - -/** The result of a executing a RegExp on a string. */ -type result - -/** -An `array` of the match and captures, the first is the full match and the -remaining are the substring captures. -*/ -external captures: result => array> = "%identity" - -@deprecated("Use Js.Re.captures instead") -external matches: result => array = "%identity" - -/** 0-based index of the match in the input string. */ -@get -external index: result => int = "index" - -/** The original input string. */ -@get -external input: result => string = "input" - -/** -Constructs a RegExp object (Js.Re.t) from a `string`. -Regex literals `%re("/.../")` should generally be preferred, but `fromString` -is useful when you need to dynamically construct a regex using strings, -exactly like when you do so in JavaScript. - -## Examples - -```rescript -let firstReScriptFileExtension = (filename, content) => { - let result = Js.Re.fromString(filename ++ "\.(res|resi)")->Js.Re.exec_(content) - switch result { - | Some(r) => Js.Nullable.toOption(Js.Re.captures(r)[1]) - | None => None - } -} - -// outputs "res" -firstReScriptFileExtension("School", "School.res School.resi Main.js School.bs.js") -``` -*/ -@new -external fromString: string => t = "RegExp" - -/** -Constructs a RegExp object (`Js.Re.t`) from a string with the given flags. -See `Js.Re.fromString`. - -Valid flags: - -- **g** global -- **i** ignore case -- **m** multiline -- **u** unicode (es2015) -- **y** sticky (es2015) -*/ -@new -external fromStringWithFlags: (string, ~flags: string) => t = "RegExp" - -/** Returns the enabled flags as a string. */ -@get -external flags: t => string = "flags" - -/** Returns a `bool` indicating whether the global flag is set. */ -@get -external global: t => bool = "global" - -/** Returns a `bool` indicating whether the ignoreCase flag is set. */ -@get -external ignoreCase: t => bool = "ignoreCase" - -/** -Returns the index where the next match will start its search. This property -will be modified when the RegExp object is used, if the global ("g") flag is -set. - -## Examples - -```rescript -let re = %re("/ab*TODO/g") -let str = "abbcdefabh" - -let break = ref(false) -while !break.contents { - switch Js.Re.exec_(re, str) { - | Some(result) => Js.Nullable.iter(Js.Re.captures(result)[0], (. match_) => { - let next = Belt.Int.toString(Js.Re.lastIndex(re)) - Js.log("Found " ++ (match_ ++ (". Next match starts at " ++ next))) - }) - | None => break := true - } -} -``` - -See -[`RegExp: lastIndex`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/RegExp/lastIndex) -on MDN. -*/ -@get -external lastIndex: t => int = "lastIndex" - -/** Sets the index at which the next match will start its search from. */ -@set -external setLastIndex: (t, int) => unit = "lastIndex" - -/** Returns a `bool` indicating whether the multiline flag is set. */ -@get -external multiline: t => bool = "multiline" - -/** Returns the pattern as a `string`. */ -@get -external source: t => string = "source" - -/** Returns a `bool` indicating whether the sticky flag is set. */ -@get -external sticky: t => bool = "sticky" - -/** Returns a `bool` indicating whether the unicode flag is set. */ -@get -external unicode: t => bool = "unicode" - -/** -Executes a search on a given string using the given RegExp object. -Returns `Some(Js.Re.result)` if a match is found, `None` otherwise. - -## Examples - -```rescript -/* Match "quick brown" followed by "jumps", ignoring characters in between - * Remember "brown" and "jumps" - * Ignore case - */ - -let re = %re("/quick\s(brown).+?(jumps)/ig") -let result = Js.Re.exec_(re, "The Quick Brown Fox Jumps Over The Lazy Dog") -``` - -See [`RegExp.prototype.exec()`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/RegExp/exec) -on MDN. -*/ -@send -@return(null_to_opt) -external exec_: (t, string) => option = "exec" - -/** -Tests whether the given RegExp object will match a given `string`. -Returns true if a match is found, false otherwise. - -## Examples - -```rescript -/* A simple implementation of Js.String.startsWith */ - -let str = "hello world!" - -let startsWith = (target, substring) => - Js.Re.fromString("^" ++ substring)->Js.Re.test_(target) - -Js.log(str->startsWith("hello")) /* prints "true" */ -``` - -See [`RegExp.prototype.test()`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/RegExp/test) -on MDN. -*/ -@send -external test_: (t, string) => bool = "test" diff --git a/jscomp/others/js_result.res b/jscomp/others/js_result.res deleted file mode 100644 index 8cb2ab1..0000000 --- a/jscomp/others/js_result.res +++ /dev/null @@ -1,28 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@deprecated("Please use `Belt.Result.t` instead") -type t<+'good, +'bad> = - | Ok('good) - | Error('bad) diff --git a/jscomp/others/js_result.resi b/jscomp/others/js_result.resi deleted file mode 100644 index 8cb2ab1..0000000 --- a/jscomp/others/js_result.resi +++ /dev/null @@ -1,28 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@deprecated("Please use `Belt.Result.t` instead") -type t<+'good, +'bad> = - | Ok('good) - | Error('bad) diff --git a/jscomp/others/js_set.res b/jscomp/others/js_set.res deleted file mode 100644 index 8e0d51d..0000000 --- a/jscomp/others/js_set.res +++ /dev/null @@ -1,3 +0,0 @@ -/*** ES6 Set API */ - -type t<'a> diff --git a/jscomp/others/js_string.res b/jscomp/others/js_string.res deleted file mode 100644 index 811d1b2..0000000 --- a/jscomp/others/js_string.res +++ /dev/null @@ -1,1006 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** JavaScript String API */ - -@@warning("-103") - -type t = string - -@val -/** -`make(value)` converts the given value to a `string`. - -## Examples - -```rescript -Js.String2.make(3.5) == "3.5" -Js.String2.make([1, 2, 3]) == "1,2,3" -``` -*/ -external make: 'a => t = "String" - -@val -/** -`fromCharCode(n)` creates a `string` containing the character corresponding to that number; `n` ranges from 0 to 65535. -If out of range, the lower 16 bits of the value are used. Thus, `fromCharCode(0x1F63A)` gives the same result as `fromCharCode(0xF63A)`. See [`String.fromCharCode`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCharCode) on MDN. - -## Examples - -```rescript -Js.String2.fromCharCode(65) == "A" -Js.String2.fromCharCode(0x3c8) == `ψ` -Js.String2.fromCharCode(0xd55c) == `한` -Js.String2.fromCharCode(-64568) == `ψ` -``` -*/ -external fromCharCode: int => t = "String.fromCharCode" - -@val -@variadic -/** -`fromCharCodeMany([n1, n2, n3])` creates a `string` from the characters -corresponding to the given numbers, using the same rules as `fromCharCode`. See -[`String.fromCharCode`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCharCode) -on MDN. -*/ -external fromCharCodeMany: array => t = "String.fromCharCode" - -@val -/** -`fromCodePoint(n)` creates a `string` containing the character corresponding to -that numeric code point. If the number is not a valid code point, it raises -`RangeError`.Thus, `fromCodePoint(0x1F63A)` will produce a correct value, -unlike `fromCharCode(0x1F63A)`, and `fromCodePoint(-5)` will raise a -`RangeError`. - -See [`String.fromCodePoint`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCodePoint) -on MDN. - -## Examples - -```rescript -Js.String2.fromCodePoint(65) == "A" -Js.String2.fromCodePoint(0x3c8) == `ψ` -Js.String2.fromCodePoint(0xd55c) == `한` -Js.String2.fromCodePoint(0x1f63a) == `😺` -``` -*/ -external fromCodePoint: int => t = "String.fromCodePoint" - -@val -@variadic -/** -`fromCodePointMany([n1, n2, n3])` creates a `string` from the characters -corresponding to the given code point numbers, using the same rules as -`fromCodePoint`. - -See [`String.fromCodePoint`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCodePoint) -on MDN. - -## Examples - -```rescript -Js.String2.fromCodePointMany([0xd55c, 0xae00, 0x1f63a]) == `한글😺` -``` -*/ -external fromCodePointMany: array => t = "String.fromCodePoint" - -/* String.raw: ES2015, meant to be used with template strings, not directly */ - -@get -/** -`length(s)` returns the length of the given `string`. See -[`String.length`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/length) -on MDN. - -## Examples - -```rescript -Js.String2.length("abcd") == 4 -``` -*/ -external length: t => int = "length" - -@get_index -/** -`get(s, n)` returns as a `string` the character at the given index number. If -`n` is out of range, this function returns `undefined`, so at some point this -function may be modified to return `option`. - -## Examples - -```rescript -Js.String2.get("Reason", 0) == "R" -Js.String2.get("Reason", 4) == "o" -Js.String2.get(`Rẽasöń`, 5) == `ń` -``` -*/ -external get: (t, int) => t = "" - -@bs.send.pipe(: t) -/** -`charAt(n, s)` gets the character at index `n` within string `s`. If `n` is -negative or greater than the length of `s`, it returns the empty string. If the -string contains characters outside the range \u0000-\uffff, it will return the -first 16-bit value at that position in the string. - -See [`String.charAt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/charAt) -on MDN. - -## Examples - -```rescript -Js.String.charAt(0, "Reason") == "R" -Js.String.charAt(12, "Reason") == "" -Js.String.charAt(5, `Rẽasöń`) == `ń` -``` -*/ -external charAt: int => t = "charAt" - -@bs.send.pipe(: t) -/** -`charCodeAt(n, s)` returns the character code at position `n` in string `s`; -the result is in the range 0-65535, unlke `codePointAt`, so it will not work -correctly for characters with code points greater than or equal to 0x10000. The -return type is `float` because this function returns NaN if `n` is less than -zero or greater than the length of the string. - -See [`String.charCodeAt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/charCodeAt) -on MDN. - -## Examples - -```rescript -Js.String.charCodeAt(0, `😺`) == 0xd83d->Belt.Int.toFloat -Js.String.codePointAt(0, `😺`) == Some(0x1f63a) -``` -*/ -external charCodeAt: int => float = "charCodeAt" - -@bs.send.pipe(: t) -/** -`codePointAt(n, s)` returns the code point at position `n` within string `s` as -a `Some(value)`. The return value handles code points greater than or equal to -0x10000. If there is no code point at the given position, the function returns -`None`. - -See [`String.codePointAt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/codePointAt) -on MDN. - -## Examples - -```rescript -Js.String.codePointAt(1, `¿😺?`) == Some(0x1f63a) -Js.String.codePointAt(5, "abc") == None -``` -*/ -external codePointAt: int => option = "codePointAt" - -@bs.send.pipe(: t) -/** -`concat(append, original)` returns a new `string` with `append` added after -`original`. - -See [`String.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/concat) -on MDN. - -## Examples - -```rescript -Js.String.concat("bell", "cow") == "cowbell" -``` -*/ -external concat: t => t = "concat" - -@bs.send.pipe(: t) -@variadic -/** -`concat(arr, original)` returns a new `string` consisting of each item of an -array of strings added to the `original` string. - -See [`String.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/concat) -on MDN. - -## Examples - -```rescript -Js.String.concatMany(["2nd", "3rd", "4th"], "1st") == "1st2nd3rd4th" -``` -*/ -external concatMany: array => t = "concat" - -@bs.send.pipe(: t) -/** -ES2015: `endsWith(substr, str)` returns `true` if the `str` ends with `substr`, -`false` otherwise. - -See [`String.endsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/endsWith) -on MDN. - -## Examples - -```rescript -Js.String.endsWith("Script", "ReScript") == true -Js.String.endsWith("Script", "C++") == false -``` -*/ -external endsWith: t => bool = "endsWith" - -@bs.send.pipe(: t) -/** -`endsWithFrom(ending, len, str)` returns `true` if the first len characters of -`str` end with `ending`, `false` otherwise. If `len` is greater than or equal -to the length of `str`, then it works like `endsWith`. (Honestly, this should -have been named endsWithAt, but oh well.) - -See [`String.endsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/endsWith) -on MDN. - -## Examples - -```rescript -Js.String.endsWithFrom("cd", 4, "abcd") == true -Js.String.endsWithFrom("cd", 3, "abcde") == false -Js.String.endsWithFrom("cde", 99, "abcde") == true -Js.String.endsWithFrom("ple", 7, "example.dat") == true -``` -*/ -external endsWithFrom: (t, int) => bool = "endsWith" - -@bs.send.pipe(: t) -/** -ES2015: `includes(searchValue, str)` returns `true` if `searchValue` is found -anywhere within `str`, false otherwise. - -See [`String.includes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/includes) -on MDN. - -## Examples - -```rescript -Js.String.includes("gram", "programmer") == true -Js.String.includes("er", "programmer") == true -Js.String.includes("pro", "programmer") == true -Js.String.includes("xyz", "programmer.dat") == false -``` -*/ -external includes: t => bool = "includes" - -@bs.send.pipe(: t) -/** -ES2015: `includes(searchValue start, str)` returns `true` if `searchValue` is -found anywhere within `str` starting at character number `start` (where 0 is -the first character), `false` otherwise. - -See [`String.includes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/includes) -on MDN. - -## Examples - -```rescript -Js.String.includesFrom("gram", 1, "programmer") == true -Js.String.includesFrom("gram", 4, "programmer") == false -Js.String.includesFrom(`한`, 1, `대한민국`) == true -``` -*/ -external includesFrom: (t, int) => bool = "includes" - -@bs.send.pipe(: t) -/** -ES2015: `indexOf(searchValue, str)` returns the position at which `searchValue` -was first found within `str`, or -1 if `searchValue` is not in `str`. - -See [`String.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/indexOf) -on MDN. - -## Examples - -```rescript -Js.String.indexOf("ok", "bookseller") == 2 -Js.String.indexOf("sell", "bookseller") == 4 -Js.String.indexOf("ee", "beekeeper") == 1 -Js.String.indexOf("xyz", "bookseller") == -1 -``` -*/ -external indexOf: t => int = "indexOf" - -@bs.send.pipe(: t) -/** -`indexOfFrom(searchValue, start, str)` returns the position at which -`searchValue` was found within `str` starting at character position `start`, or --1 if `searchValue` is not found in that portion of `str`. The return value is -relative to the beginning of the string, no matter where the search started -from. - -See [`String.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/indexOf) -on MDN. - -## Examples - -```rescript -Js.String.indexOfFrom("ok", 1, "bookseller") == 2 -Js.String.indexOfFrom("sell", 2, "bookseller") == 4 -Js.String.indexOfFrom("sell", 5, "bookseller") == -1 -``` -*/ -external indexOfFrom: (t, int) => int = "indexOf" - -@bs.send.pipe(: t) -/** -`lastIndexOf(searchValue, str)` returns the position of the last occurrence of -`searchValue` within `str`, searching backwards from the end of the string. -Returns -1 if `searchValue` is not in `str`. The return value is always -relative to the beginning of the string. - -See [`String.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.String.lastIndexOf("ok", "bookseller") == 2 -Js.String.lastIndexOf("ee", "beekeeper") == 4 -Js.String.lastIndexOf("xyz", "abcdefg") == -1 -``` -*/ -external lastIndexOf: t => int = "lastIndexOf" - -@bs.send.pipe(: t) -/** -`lastIndexOfFrom(searchValue, start, str)` returns the position of the last -occurrence of `searchValue` within `str`, searching backwards from the given -start position. Returns -1 if `searchValue` is not in `str`. The return value -is always relative to the beginning of the string. - -See [`String.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.String.lastIndexOfFrom("ok", 6, "bookseller") == 2 -Js.String.lastIndexOfFrom("ee", 8, "beekeeper") == 4 -Js.String.lastIndexOfFrom("ee", 3, "beekeeper") == 1 -Js.String.lastIndexOfFrom("xyz", 4, "abcdefg") == -1 -``` -*/ -external lastIndexOfFrom: (t, int) => int = "lastIndexOf" - -/* extended by ECMA-402 */ - -@bs.send.pipe(: t) -/** -`localeCompare(comparison, reference)` returns -- a negative value if reference comes before comparison in sort order -- zero if reference and comparison have the same sort order -- a positive value if reference comes after comparison in sort order - -See [`String.localeCompare`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/localeCompare) on MDN. - -## Examples - -```rescript -Js.String.localeCompare("ant", "zebra") > 0.0 -Js.String.localeCompare("zebra", "ant") < 0.0 -Js.String.localeCompare("cat", "cat") == 0.0 -Js.String.localeCompare("cat", "CAT") > 0.0 -``` -*/ -external localeCompare: t => float = "localeCompare" - -@bs.send.pipe(: t) -@return({null_to_opt: null_to_opt}) -/** -`match(regexp, str)` matches a `string` against the given `regexp`. If there is -no match, it returns `None`. For regular expressions without the g modifier, if - there is a match, the return value is `Some(array)` where the array contains: -- The entire matched string -- Any capture groups if the regexp had parentheses - -For regular expressions with the g modifier, a matched expression returns -`Some(array)` with all the matched substrings and no capture groups. - -See [`String.match`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/match) -on MDN. - -## Examples - -```rescript -Js.String.match_(%re("/b[aeiou]t/"), "The better bats") == Some(["bet"]) -Js.String.match_(%re("/b[aeiou]t/g"), "The better bats") == Some(["bet", "bat"]) -Js.String.match_(%re("/(\d+)-(\d+)-(\d+)/"), "Today is 2018-04-05.") == - Some(["2018-04-05", "2018", "04", "05"]) -Js.String.match_(%re("/b[aeiou]g/"), "The large container.") == None -``` -*/ -external match_: Js_re.t => option>> = "match" - -@bs.send.pipe(: t) -/** -`normalize(str)` returns the normalized Unicode string using Normalization Form -Canonical (NFC) Composition. Consider the character ã, which can be represented -as the single codepoint \u00e3 or the combination of a lower case letter A -\u0061 and a combining tilde \u0303. Normalization ensures that both can be -stored in an equivalent binary representation. - -See [`String.normalize`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/normalize) -on MDN. - -See also [Unicode technical report #15](https://unicode.org/reports/tr15/) for -details. -*/ -external normalize: t = "normalize" - -@bs.send.pipe(: t) -/** -ES2015: `normalize(form, str)` returns the normalized Unicode string using the specified form of normalization, which may be one of: -- "NFC" — Normalization Form Canonical Composition. -- "NFD" — Normalization Form Canonical Decomposition. -- "NFKC" — Normalization Form Compatibility Composition. -- "NFKD" — Normalization Form Compatibility Decomposition. - -See [`String.normalize`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/normalize) on MDN. - -See also [Unicode technical report #15](https://unicode.org/reports/tr15/) for details. -*/ -external normalizeByForm: t => t = "normalize" - -@bs.send.pipe(: t) -/** -`repeat(n, str)` returns a `string` that consists of `n` repetitions of `str`. -Raises `RangeError` if `n` is negative. - -See [`String.repeat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/repeat) -on MDN. - -## Examples - -```rescript -Js.String.repeat(3, "ha") == "hahaha" -Js.String.repeat(0, "empty") == "" -``` -*/ -external repeat: int => t = "repeat" - -@bs.send.pipe(: t) -/** -ES2015: `replace(substr, newSubstr, str)` returns a new `string` which is -identical to `str` except with the first matching instance of `substr` replaced -by `newSubstr`. `substr` is treated as a verbatim string to match, not a -regular expression. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -Js.String.replace("old", "new", "old string") == "new string" -Js.String.replace("the", "this", "the cat and the dog") == "this cat and the dog" -``` -*/ -external replace: (t, t) => t = "replace" - -@bs.send.pipe(: t) -/** -`replaceByRe(regex, replacement, str)` returns a new `string` where occurrences -matching regex have been replaced by `replacement`. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -Js.String.replaceByRe(%re("/[aeiou]/g"), "x", "vowels be gone") == "vxwxls bx gxnx" -Js.String.replaceByRe(%re("/(\w+) (\w+)/"), "$2, $1", "Juan Fulano") == "Fulano, Juan" -``` -*/ -external replaceByRe: (Js_re.t, t) => t = "replace" - -@bs.send.pipe(: t) -/** -Returns a new `string` with some or all matches of a pattern with no capturing -parentheses replaced by the value returned from the given function. The -function receives as its parameters the matched string, the offset at which the -match begins, and the whole string being matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -let str = "beautiful vowels" -let re = %re("/[aeiou]/g") -let matchFn = (matchPart, _offset, _wholeString) => Js.String.toUpperCase(matchPart) - -Js.String.unsafeReplaceBy0(re, matchFn, str) == "bEAUtIfUl vOwEls" -``` -*/ -external unsafeReplaceBy0: (Js_re.t, @uncurry (t, int, t) => t) => t = "replace" - -@bs.send.pipe(: t) -/** -Returns a new `string` with some or all matches of a pattern with one set of -capturing parentheses replaced by the value returned from the given function. -The function receives as its parameters the matched string, the captured -string, the offset at which the match begins, and the whole string being -matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -let str = "Jony is 40" -let re = %re("/(Jony is )\d+/g") -let matchFn = (_match, part1, _offset, _wholeString) => { - part1 ++ "41" -} - -Js.String.unsafeReplaceBy1(re, matchFn, str) == "Jony is 41" -``` -*/ -external unsafeReplaceBy1: (Js_re.t, @uncurry (t, t, int, t) => t) => t = "replace" - -@bs.send.pipe(: t) -/** -Returns a new `string` with some or all matches of a pattern with two sets of -capturing parentheses replaced by the value returned from the given function. -The function receives as its parameters the matched string, the captured -strings, the offset at which the match begins, and the whole string being -matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -let str = "7 times 6" -let re = %re("/(\d+) times (\d+)/") -let matchFn = (_match, p1, p2, _offset, _wholeString) => { - switch (Belt.Int.fromString(p1), Belt.Int.fromString(p2)) { - | (Some(x), Some(y)) => Belt.Int.toString(x * y) - | _ => "???" - } -} - -Js.String.unsafeReplaceBy2(re, matchFn, str) == "42" -``` -*/ -external unsafeReplaceBy2: (Js_re.t, @uncurry (t, t, t, int, t) => t) => t = "replace" - -@bs.send.pipe(: t) -/** -Returns a new `string` with some or all matches of a pattern with three sets of -capturing parentheses replaced by the value returned from the given function. -The function receives as its parameters the matched string, the captured -strings, the offset at which the match begins, and the whole string being -matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. -*/ -external unsafeReplaceBy3: (Js_re.t, @uncurry (t, t, t, t, int, t) => t) => t = "replace" - -@bs.send.pipe(: t) -/** -`search(regexp, str)` returns the starting position of the first match of -`regexp` in the given `str`, or -1 if there is no match. - -See [`String.search`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/search) -on MDN. - -## Examples - -```rescript -Js.String.search(%re("/\d+/"), "testing 1 2 3") == 8 -Js.String.search(%re("/\d+/"), "no numbers") == -1 -``` -*/ -external search: Js_re.t => int = "search" - -@bs.send.pipe(: t) -/** -`slice(from:n1, to_:n2, str)` returns the substring of `str` starting at -character `n1` up to but not including `n2`. -- If either `n1` or `n2` is negative, then it is evaluated as `length(str - n1)` or `length(str - n2)`. -- If `n2` is greater than the length of `str`, then it is treated as `length(str)`. -- If `n1` is greater than `n2`, slice returns the empty string. - -See [`String.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/slice) on MDN. - -## Examples - -```rescript -Js.String.slice(~from=2, ~to_=5, "abcdefg") == "cde" -Js.String.slice(~from=2, ~to_=9, "abcdefg") == "cdefg" -Js.String.slice(~from=-4, ~to_=-2, "abcdefg") == "de" -Js.String.slice(~from=5, ~to_=1, "abcdefg") == "" -``` -*/ -external slice: (~from: int, ~to_: int) => t = "slice" - -@bs.send.pipe(: t) -/** -`sliceToEnd(str, from:n)` returns the substring of `str` starting at character -`n` to the end of the string. -- If `n` is negative, then it is evaluated as `length(str - n)`. -- If `n` is greater than the length of `str`, then sliceToEnd returns the empty string. - -See [`String.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/slice) on MDN. - -## Examples - -```rescript -Js.String.sliceToEnd(~from=4, "abcdefg") == "efg" -Js.String.sliceToEnd(~from=-2, "abcdefg") == "fg" -Js.String.sliceToEnd(~from=7, "abcdefg") == "" -``` -*/ -external sliceToEnd: (~from: int) => t = "slice" - -@bs.send.pipe(: t) -/** -`split(delimiter, str)` splits the given `str` at every occurrence of -`delimiter` and returns an array of the resulting substrings. - -See [`String.split`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/split) -on MDN. - -## Examples - -```rescript -Js.String.split("-", "2018-01-02") == ["2018", "01", "02"] -Js.String.split(",", "a,b,,c") == ["a", "b", "", "c"] -Js.String.split("::", "good::bad as great::awful") == ["good", "bad as great", "awful"] -Js.String.split(";", "has-no-delimiter") == ["has-no-delimiter"] -``` -*/ -external split: t => array = "split" - -@bs.send.pipe(: t) -/** -`splitAtMost(delimiter, ~limit:n, str)` splits the given `str` at every -occurrence of `delimiter` and returns an array of the first `n` resulting -substrings. If `n` is negative or greater than the number of substrings, the -array will contain all the substrings. - -See [`String.split`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/split) -on MDN. - -## Examples - -```rescript -Js.String.splitAtMost("/", ~limit=3, "ant/bee/cat/dog/elk") == ["ant", "bee", "cat"] -Js.String.splitAtMost("/", ~limit=0, "ant/bee/cat/dog/elk") == [] -Js.String.splitAtMost("/", ~limit=9, "ant/bee/cat/dog/elk") == ["ant", "bee", "cat", "dog", "elk"] -``` -*/ -external splitAtMost: (t, ~limit: int) => array = "split" - -@bs.send.pipe(: t) -@ocaml.doc(" -`splitByRe(regex, str)` splits the given `str` at every occurrence of `regex` -and returns an array of the resulting substrings. - -See [`String.split`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/split) -on MDN. - -## Examples - -```rescript -Js.String.splitByRe(%re(\"/\s*[,;]\s*/\"), \"art; bed , cog ;dad\") == [ - Some(\"art\"), - Some(\"bed\"), - Some(\"cog\"), - Some(\"dad\"), - ] -``` -") -external splitByRe: Js_re.t => array> = "split" - -@bs.send.pipe(: t) -@ocaml.doc(" -`splitByReAtMost(regex, ~limit:n, str)` splits the given `str` at every -occurrence of `regex` and returns an array of the first `n` resulting -substrings. If `n` is negative or greater than the number of substrings, the -array will contain all the substrings. - -See [`String.split`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/split) -on MDN. - -## Examples - -```rescript -Js.String.splitByReAtMost(%re(\"/\s*:\s*/\"), ~limit=3, \"one: two: three: four\") == [ - Some(\"one\"), - Some(\"two\"), - Some(\"three\"), - ] - -Js.String.splitByReAtMost(%re(\"/\s*:\s*/\"), ~limit=0, \"one: two: three: four\") == [] - -Js.String.splitByReAtMost(%re(\"/\s*:\s*/\"), ~limit=8, \"one: two: three: four\") == [ - Some(\"one\"), - Some(\"two\"), - Some(\"three\"), - Some(\"four\"), - ] -``` -") -external splitByReAtMost: (Js_re.t, ~limit: int) => array> = "split" - -@bs.send.pipe(: t) -/** -ES2015: `startsWith(substr, str)` returns `true` if the `str` starts with -`substr`, `false` otherwise. - -See [`String.startsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/startsWith) -on MDN. - -## Examples - -```rescript -Js.String.startsWith("Re", "ReScript") == true -Js.String.startsWith("", "ReScript") == true -Js.String.startsWith("Re", "JavaScript") == false -``` -*/ -external startsWith: t => bool = "startsWith" - -@bs.send.pipe(: t) -/** -ES2015: `startsWithFrom(substr, n, str)` returns `true` if the `str` starts -with `substr` starting at position `n`, false otherwise. If `n` is negative, -the search starts at the beginning of `str`. - -See [`String.startsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/startsWith) -on MDN. - -## Examples - -```rescript -Js.String.startsWithFrom("Scri", 2, "ReScript") == true -Js.String.startsWithFrom("", 2, "ReScript") == true -Js.String.startsWithFrom("Scri", 2, "JavaScript") == false -``` -*/ -external startsWithFrom: (t, int) => bool = "startsWith" - -@bs.send.pipe(: t) -/** -`substr(~from:n, str)` returns the substring of `str` from position `n` to the -end of the string. -- If `n` is less than zero, the starting position is the length of `str - n`. -- If `n` is greater than or equal to the length of `str`, returns the empty string. - -JavaScript’s `String.substr()` is a legacy function. When possible, use -`substring()` instead. - -See [`String.substr`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substr) -on MDN. - -## Examples - -```rescript -Js.String.substr(~from=3, "abcdefghij") == "defghij" -Js.String.substr(~from=-3, "abcdefghij") == "hij" -Js.String.substr(~from=12, "abcdefghij") == "" -``` -*/ -external substr: (~from: int) => t = "substr" - -@bs.send.pipe(: t) -/** -`substrAtMost(~from: pos, ~length: n, str)` returns the substring of `str` of -length `n` starting at position `pos`. -- If `pos` is less than zero, the starting position is the length of `str - pos`. -- If `pos` is greater than or equal to the length of `str`, returns the empty string. -- If `n` is less than or equal to zero, returns the empty string. - -JavaScript’s `String.substr()` is a legacy function. When possible, use -`substring()` instead. - -See [`String.substr`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substr) -on MDN. - -## Examples - -```rescript -Js.String.substrAtMost(~from=3, ~length=4, "abcdefghij") == "defg" -Js.String.substrAtMost(~from=-3, ~length=4, "abcdefghij") == "hij" -Js.String.substrAtMost(~from=12, ~length=2, "abcdefghij") == "" -``` -*/ -external substrAtMost: (~from: int, ~length: int) => t = "substr" - -@bs.send.pipe(: t) -/** -`substring(~from: start, ~to_: finish, str)` returns characters `start` up to -but not including finish from `str`. -- If `start` is less than zero, it is treated as zero. -- If `finish` is zero or negative, the empty string is returned. -- If `start` is greater than `finish`, the `start` and `finish` points are swapped. - -See [`String.substring`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substring) on MDN. - -## Examples - -```rescript -Js.String.substring(~from=3, ~to_=6, "playground") == "ygr" -Js.String.substring(~from=6, ~to_=3, "playground") == "ygr" -Js.String.substring(~from=4, ~to_=12, "playground") == "ground" -``` -*/ -external substring: (~from: int, ~to_: int) => t = "substring" - -@bs.send.pipe(: t) -/** -`substringToEnd(~from: start, str)` returns the substring of `str` from -position `start` to the end. -- If `start` is less than or equal to zero, the entire string is returned. -- If `start` is greater than or equal to the length of `str`, the empty string is returned. - -See [`String.substring`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substring) on MDN. - -## Examples - -```rescript -Js.String.substringToEnd(~from=4, "playground") == "ground" -Js.String.substringToEnd(~from=-3, "playground") == "playground" -Js.String.substringToEnd(~from=12, "playground") == "" -``` -*/ -external substringToEnd: (~from: int) => t = "substring" - -@bs.send.pipe(: t) -/** -`toLowerCase(str)` converts `str` to lower case using the locale-insensitive -case mappings in the Unicode Character Database. Notice that the conversion can -give different results depending upon context, for example with the Greek -letter sigma, which has two different lower case forms; one when it is the last -character in a string and another when it is not. - -See [`String.toLowerCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toLowerCase) -on MDN. - -## Examples - -```rescript -Js.String.toLowerCase("ABC") == "abc" -Js.String.toLowerCase(`ΣΠ`) == `σπ` -Js.String.toLowerCase(`ΠΣ`) == `πς` -``` -*/ -external toLowerCase: t = "toLowerCase" - -@bs.send.pipe(: t) -/** -`toLocaleLowerCase(str)` converts `str` to lower case using the current locale. - -See [`String.toLocaleLowerCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toLocaleLowerCase) -on MDN. -*/ -external toLocaleLowerCase: t = "toLocaleLowerCase" - -@bs.send.pipe(: t) -/** -`toUpperCase(str)` converts `str` to upper case using the locale-insensitive -case mappings in the Unicode Character Database. Notice that the conversion can -expand the number of letters in the result; for example the German ß -capitalizes to two Ses in a row. - -See [`String.toUpperCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toUpperCase) -on MDN. - -## Examples - -```rescript -Js.String.toUpperCase("abc") == "ABC" -Js.String.toUpperCase(`Straße`) == `STRASSE` -Js.String.toUpperCase(`πς`) == `ΠΣ` -``` -*/ -external toUpperCase: t = "toUpperCase" - -@bs.send.pipe(: t) -/** -`toLocaleUpperCase(str)` converts `str` to upper case using the current locale. - -See [`String.to:LocaleUpperCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toLocaleUpperCase) -on MDN. -*/ -external toLocaleUpperCase: t = "toLocaleUpperCase" - -@bs.send.pipe(: t) -/** -`trim(str)` returns a string that is `str` with whitespace stripped from both -ends. Internal whitespace is not removed. - -See [`String.trim`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/trim) -on MDN. - -## Examples - -```rescript -Js.String.trim(" abc def ") == "abc def" -Js.String.trim("\n\r\t abc def \n\n\t\r ") == "abc def" -``` -*/ -external trim: t = "trim" - -/* HTML wrappers */ - -@bs.send.pipe(: t) -/** -`anchor(anchorName, anchorText)` creates a string with an HTML `` element -with name attribute of `anchorName` and `anchorText` as its content. Please do -not use this method, as it has been removed from the relevant web standards. - -See [`String.anchor`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/anchor) -on MDN. - -## Examples - -```rescript -Js.String.anchor("page1", "Page One") == "Page One" -``` -*/ -external anchor: t => t = "anchor" - -@bs.send.pipe(: t) -/** -ES2015: `link(urlText, linkText)` creates a string with an HTML `` element -with href attribute of `urlText` and `linkText` as its content. Please do not -use this method, as it has been removed from the relevant web standards. - -See [`String.link`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/link) -on MDN. - -## Examples - -```rescript -Js.String.link("page2.html", "Go to page two") == "Go to page two" -``` -*/ -external link: t => t = "link" - -/** -Casts its argument to an `array_like` entity that can be processed by functions -such as `Js.Array2.fromMap()` - -## Examples - -```rescript -let s = "abcde" -let arr = Js.Array2.fromMap(Js.String.castToArrayLike(s), x => x) -arr == ["a", "b", "c", "d", "e"] -``` -*/ -external castToArrayLike: t => Js_array2.array_like = "%identity" diff --git a/jscomp/others/js_string2.res b/jscomp/others/js_string2.res deleted file mode 100644 index 998b60c..0000000 --- a/jscomp/others/js_string2.res +++ /dev/null @@ -1,1001 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provide bindings to JS string. Optimized for pipe-first. */ - -type t = string - -@val -/** -`make(value)` converts the given value to a `string`. - -## Examples - -```rescript -Js.String2.make(3.5) == "3.5" -Js.String2.make([1, 2, 3]) == "1,2,3" -``` -*/ -external make: 'a => t = "String" - -@val -/** -`fromCharCode(n)` creates a `string` containing the character corresponding to -that number; `n` ranges from 0 to 65535.If out of range, the lower 16 bits of -the value are used. Thus, `fromCharCode(0x1F63A)` gives the same result as -`fromCharCode(0xF63A)`. - -See [`String.fromCharCode`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCharCode) -on MDN. - -## Examples - -```rescript -Js.String2.fromCharCode(65) == "A" -Js.String2.fromCharCode(0x3c8) == `ψ` -Js.String2.fromCharCode(0xd55c) == `한` -Js.String2.fromCharCode(-64568) == `ψ` -``` -*/ -external fromCharCode: int => t = "String.fromCharCode" - -@val -@variadic -/** -`fromCharCodeMany([n1, n2, n3])` creates a `string` from the characters -corresponding to the given numbers, using the same rules as `fromCharCode`. - -See [`String.fromCharCode`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCharCode) -on MDN. -*/ -external fromCharCodeMany: array => t = "String.fromCharCode" - -@val -/** -`fromCodePoint(n)` creates a `string` containing the character corresponding to -that numeric code point. If the number is not a valid code point, it raises -`RangeError`. Thus, `fromCodePoint(0x1F63A)` will produce a correct value, -unlike `fromCharCode(0x1F63A)`, and `fromCodePoint(-5)` will raise a -`RangeError`. - -See [`String.fromCodePoint`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCodePoint) -on MDN. - -## Examples - -```rescript -Js.String2.fromCodePoint(65) == "A" -Js.String2.fromCodePoint(0x3c8) == `ψ` -Js.String2.fromCodePoint(0xd55c) == `한` -Js.String2.fromCodePoint(0x1f63a) == `😺` -``` -*/ -external fromCodePoint: int => t = "String.fromCodePoint" - -@val -@variadic -/** -`fromCodePointMany([n1, n2, n3])` creates a `string` from the characters -corresponding to the given code point numbers, using the same rules as -`fromCodePoint`. - -See [`String.fromCodePoint`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/fromCodePoint) -on MDN. - -## Examples - -```rescript -Js.String2.fromCodePointMany([0xd55c, 0xae00, 0x1f63a]) == `한글😺` -``` -*/ -external fromCodePointMany: array => t = "String.fromCodePoint" - -/* String.raw: ES2015, meant to be used with template strings, not directly */ - -@get -/** -`length(s)` returns the length of the given `string`. - -See [`String.length`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/length) -on MDN. - -## Examples - -```rescript -Js.String2.length("abcd") == 4 -``` -*/ -external length: t => int = "length" - -@get_index -/** -`get(s, n)` returns as a `string` the character at the given index number. If -`n` is out of range, this function returns `undefined`,so at some point this -function may be modified to return `option`. - -## Examples - -```rescript -Js.String2.get("Reason", 0) == "R" -Js.String2.get("Reason", 4) == "o" -Js.String2.get(`Rẽasöń`, 5) == `ń` -``` -*/ -external get: (t, int) => t = "" - -@send -/** -`charAt(s, n)` gets the character at index `n` within string `s`. If `n` is -negative or greater than the length of `s`, it returns the empty string. If the -string contains characters outside the range \u0000-\uffff, it will return the -first 16-bit value at that position in the string. - -See [`String.charAt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/charAt) -on MDN. - -## Examples - -```rescript -Js.String2.charAt("Reason", 0) == "R" -Js.String2.charAt("Reason", 12) == "" -Js.String2.charAt(`Rẽasöń`, 5) == `ń` -``` -*/ -external charAt: (t, int) => t = "charAt" - -@send -/** -`charCodeAt(s, n)` returns the character code at position `n` in string `s`; -the result is in the range 0-65535, unlke `codePointAt`, so it will not work -correctly for characters with code points greater than or equal to 0x10000. The -return type is `float` because this function returns NaN if `n` is less than -zero or greater than the length of the string. - -See [`String.charCodeAt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/charCodeAt) -on MDN. - -## Examples - -```rescript -Js.String2.charCodeAt(`😺`, 0) == 0xd83d->Belt.Int.toFloat -Js.String2.codePointAt(`😺`, 0) == Some(0x1f63a) -``` -*/ -external charCodeAt: (t, int) => float = "charCodeAt" - -@send -/** -`codePointAt(s, n)` returns the code point at position `n` within string `s` as -a `Some(value)`. The return value handles code points greater than or equal to -0x10000. If there is no code point at the given position, the function returns -`None`. - -See [`String.codePointAt`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/codePointAt) -on MDN. - -## Examples - -```rescript -Js.String2.codePointAt(`¿😺?`, 1) == Some(0x1f63a) -Js.String2.codePointAt("abc", 5) == None -``` -*/ -external codePointAt: (t, int) => option = "codePointAt" - -@send -/** -`concat(original, append)` returns a new `string` with `append` added after -`original`. - -See [`String.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/concat) -on MDN. - -## Examples - -```rescript -Js.String2.concat("cow", "bell") == "cowbell" -``` -*/ -external concat: (t, t) => t = "concat" - -@send -@variadic -/** -`concatMany(original, arr)` returns a new `string` consisting of each item of an -array of strings added to the `original` string. - -See [`String.concat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/concat) -on MDN. - -## Examples - -```rescript -Js.String2.concatMany("1st", ["2nd", "3rd", "4th"]) == "1st2nd3rd4th" -``` -*/ -external concatMany: (t, array) => t = "concat" - -@send -/** -ES2015: `endsWith(str, substr)` returns `true` if the `str` ends with `substr`, -`false` otherwise. - -See [`String.endsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/endsWith) -on MDN. - -## Examples - -```rescript -Js.String2.endsWith("ReScript", "Script") == true -Js.String2.endsWith("C++", "Script") == false -``` -*/ -external endsWith: (t, t) => bool = "endsWith" - -@send -/** -`endsWithFrom(str, ending, len)` returns `true` if the first len characters of -`str` end with `ending`, `false` otherwise. If `len` is greater than or equal -to the length of `str`, then it works like `endsWith`. (Honestly, this should -have been named endsWithAt, but oh well). - -See [`String.endsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/endsWith) -on MDN. - -## Examples - -```rescript -Js.String2.endsWithFrom("abcd", "cd", 4) == true -Js.String2.endsWithFrom("abcde", "cd", 3) == false -Js.String2.endsWithFrom("abcde", "cde", 99) == true -Js.String2.endsWithFrom("example.dat", "ple", 7) == true -``` -*/ -external endsWithFrom: (t, t, int) => bool = "endsWith" - -@send -/** -ES2015: `includes(str, searchValue)` returns `true` if `searchValue` is found -anywhere within `str`, false otherwise. - -See [`String.includes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/includes) -on MDN. - -## Examples - -```rescript -Js.String2.includes("programmer", "gram") == true -Js.String2.includes("programmer", "er") == true -Js.String2.includes("programmer", "pro") == true -Js.String2.includes("programmer.dat", "xyz") == false -``` -*/ -external includes: (t, t) => bool = "includes" - -@send -/** -ES2015: `includes(str, searchValue start)` returns `true` if `searchValue` is -found anywhere within `str` starting at character number `start` (where 0 is -the first character), `false` otherwise. - -See [`String.includes`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/includes) -on MDN. - -## Examples - -```rescript -Js.String2.includesFrom("programmer", "gram", 1) == true -Js.String2.includesFrom("programmer", "gram", 4) == false -Js.String2.includesFrom(`대한민국`, `한`, 1) == true -``` -*/ -external includesFrom: (t, t, int) => bool = "includes" - -@send -/** -ES2015: `indexOf(str, searchValue)` returns the position at which `searchValue` -was first found within `str`, or -1 if `searchValue` is not in `str`. - -See [`String.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/indexOf) -on MDN. - -## Examples - -```rescript -Js.String2.indexOf("bookseller", "ok") == 2 -Js.String2.indexOf("bookseller", "sell") == 4 -Js.String2.indexOf("beekeeper", "ee") == 1 -Js.String2.indexOf("bookseller", "xyz") == -1 -``` -*/ -external indexOf: (t, t) => int = "indexOf" - -@send -/** -`indexOfFrom(str, searchValue, start)` returns the position at which -`searchValue` was found within `str` starting at character position `start`, or --1 if `searchValue` is not found in that portion of `str`. The return value is -relative to the beginning of the string, no matter where the search started -from. - -See [`String.indexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/indexOf) -on MDN. - -## Examples - -```rescript -Js.String2.indexOfFrom("bookseller", "ok", 1) == 2 -Js.String2.indexOfFrom("bookseller", "sell", 2) == 4 -Js.String2.indexOfFrom("bookseller", "sell", 5) == -1 -``` -*/ -external indexOfFrom: (t, t, int) => int = "indexOf" - -@send -/** -`lastIndexOf(str, searchValue)` returns the position of the last occurrence of -`searchValue` within `str`, searching backwards from the end of the string. -Returns -1 if `searchValue` is not in `str`. The return value is always -relative to the beginning of the string. - -See [`String.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.String2.lastIndexOf("bookseller", "ok") == 2 -Js.String2.lastIndexOf("beekeeper", "ee") == 4 -Js.String2.lastIndexOf("abcdefg", "xyz") == -1 -``` -*/ -external lastIndexOf: (t, t) => int = "lastIndexOf" - -@send -/** -`lastIndexOfFrom(str, searchValue, start)` returns the position of the last -occurrence of `searchValue` within `str`, searching backwards from the given -start position. Returns -1 if `searchValue` is not in `str`. The return value -is always relative to the beginning of the string. - -See [`String.lastIndexOf`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/lastIndexOf) -on MDN. - -## Examples - -```rescript -Js.String2.lastIndexOfFrom("bookseller", "ok", 6) == 2 -Js.String2.lastIndexOfFrom("beekeeper", "ee", 8) == 4 -Js.String2.lastIndexOfFrom("beekeeper", "ee", 3) == 1 -Js.String2.lastIndexOfFrom("abcdefg", "xyz", 4) == -1 -``` -*/ -external lastIndexOfFrom: (t, t, int) => int = "lastIndexOf" - -/* extended by ECMA-402 */ - -@send -/** -`localeCompare(reference, comparison)` returns -- a negative value if reference comes before comparison in sort order -- zero if reference and comparison have the same sort order -- a positive value if reference comes after comparison in sort order - -See [`String.localeCompare`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/localeCompare) on MDN. - -## Examples - -```rescript -Js.String2.localeCompare("zebra", "ant") > 0.0 -Js.String2.localeCompare("ant", "zebra") < 0.0 -Js.String2.localeCompare("cat", "cat") == 0.0 -Js.String2.localeCompare("CAT", "cat") > 0.0 -``` -*/ -external localeCompare: (t, t) => float = "localeCompare" - -@send -@return({null_to_opt: null_to_opt}) -/** -`match(str, regexp)` matches a `string` against the given `regexp`. If there is -no match, it returns `None`. For regular expressions without the g modifier, if - there is a match, the return value is `Some(array)` where the array contains: -- The entire matched string -- Any capture groups if the regexp had parentheses -For regular expressions with the g modifier, a matched expression returns -`Some(array)` with all the matched substrings and no capture groups. - -See [`String.match`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/match) -on MDN. - -## Examples - -```rescript -Js.String2.match_("The better bats", %re("/b[aeiou]t/")) == Some(["bet"]) -Js.String2.match_("The better bats", %re("/b[aeiou]t/g")) == Some(["bet", "bat"]) -Js.String2.match_("Today is 2018-04-05.", %re("/(\d+)-(\d+)-(\d+)/")) == - Some(["2018-04-05", "2018", "04", "05"]) -Js.String2.match_("The large container.", %re("/b[aeiou]g/")) == None -``` -*/ -external match_: (t, Js_re.t) => option>> = "match" - -@send -/** -`normalize(str)` returns the normalized Unicode string using Normalization Form -Canonical (NFC) Composition. Consider the character ã, which can be represented -as the single codepoint \u00e3 or the combination of a lower case letter A -\u0061 and a combining tilde \u0303. Normalization ensures that both can be -stored in an equivalent binary representation. - -See [`String.normalize`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/normalize) -on MDN. See also [Unicode technical report -#15](https://unicode.org/reports/tr15/) for details. -*/ -external normalize: t => t = "normalize" - -@send -/** -ES2015: `normalize(str, form)` returns the normalized Unicode string using the -specified form of normalization, which may be one of: -- "NFC" — Normalization Form Canonical Composition. -- "NFD" — Normalization Form Canonical Decomposition. -- "NFKC" — Normalization Form Compatibility Composition. -- "NFKD" — Normalization Form Compatibility Decomposition. - -See [`String.normalize`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/normalize) on MDN. -See also [Unicode technical report #15](https://unicode.org/reports/tr15/) for details. -*/ -external normalizeByForm: (t, t) => t = "normalize" - -@send -/** -`repeat(str, n)` returns a `string` that consists of `n` repetitions of `str`. -Raises `RangeError` if `n` is negative. - -See [`String.repeat`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/repeat) -on MDN. - -## Examples - -```rescript -Js.String2.repeat("ha", 3) == "hahaha" -Js.String2.repeat("empty", 0) == "" -``` -*/ -external repeat: (t, int) => t = "repeat" - -@send -/** -ES2015: `replace(str, substr, newSubstr)` returns a new `string` which is -identical to `str` except with the first matching instance of `substr` replaced -by `newSubstr`. `substr` is treated as a verbatim string to match, not a -regular expression. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -Js.String2.replace("old string", "old", "new") == "new string" -Js.String2.replace("the cat and the dog", "the", "this") == "this cat and the dog" -``` -*/ -external replace: (t, t, t) => t = "replace" - -@send -/** -`replaceByRe(str, regex, replacement)` returns a new `string` where occurrences -matching regex have been replaced by `replacement`. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -Js.String2.replaceByRe("vowels be gone", %re("/[aeiou]/g"), "x") == "vxwxls bx gxnx" -Js.String2.replaceByRe("Juan Fulano", %re("/(\w+) (\w+)/"), "$2, $1") == "Fulano, Juan" -``` -*/ -external replaceByRe: (t, Js_re.t, t) => t = "replace" - -@send -/** -Returns a new `string` with some or all matches of a pattern with no capturing -parentheses replaced by the value returned from the given function. The -function receives as its parameters the matched string, the offset at which the -match begins, and the whole string being matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -let str = "beautiful vowels" -let re = %re("/[aeiou]/g") -let matchFn = (matchPart, _offset, _wholeString) => Js.String2.toUpperCase(matchPart) - -Js.String2.unsafeReplaceBy0(str, re, matchFn) == "bEAUtIfUl vOwEls" -``` -*/ -external unsafeReplaceBy0: (t, Js_re.t, @uncurry (t, int, t) => t) => t = "replace" - -@send -/** -Returns a new `string` with some or all matches of a pattern with one set of -capturing parentheses replaced by the value returned from the given function. -The function receives as its parameters the matched string, the captured -string, the offset at which the match begins, and the whole string being -matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -let str = "Jony is 40" -let re = %re("/(Jony is )\d+/g") -let matchFn = (_match, part1, _offset, _wholeString) => { - part1 ++ "41" -} - -Js.String2.unsafeReplaceBy1(str, re, matchFn) == "Jony is 41" -``` -*/ -external unsafeReplaceBy1: (t, Js_re.t, @uncurry (t, t, int, t) => t) => t = "replace" - -@send -/** -Returns a new `string` with some or all matches of a pattern with two sets of -capturing parentheses replaced by the value returned from the given function. -The function receives as its parameters the matched string, the captured -strings, the offset at which the match begins, and the whole string being -matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. - -## Examples - -```rescript -let str = "7 times 6" -let re = %re("/(\d+) times (\d+)/") -let matchFn = (_match, p1, p2, _offset, _wholeString) => { - switch (Belt.Int.fromString(p1), Belt.Int.fromString(p2)) { - | (Some(x), Some(y)) => Belt.Int.toString(x * y) - | _ => "???" - } -} - -Js.String2.unsafeReplaceBy2(str, re, matchFn) == "42" -``` -*/ -external unsafeReplaceBy2: (t, Js_re.t, @uncurry (t, t, t, int, t) => t) => t = "replace" - -@send -/** -Returns a new `string` with some or all matches of a pattern with three sets of -capturing parentheses replaced by the value returned from the given function. -The function receives as its parameters the matched string, the captured -strings, the offset at which the match begins, and the whole string being -matched. - -See [`String.replace`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/replace) -on MDN. -*/ -external unsafeReplaceBy3: (t, Js_re.t, @uncurry (t, t, t, t, int, t) => t) => t = "replace" - -@send -/** -`search(str, regexp)` returns the starting position of the first match of -`regexp` in the given `str`, or -1 if there is no match. - -See [`String.search`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/search) -on MDN. - -## Examples - -```rescript -Js.String2.search("testing 1 2 3", %re("/\d+/")) == 8 -Js.String2.search("no numbers", %re("/\d+/")) == -1 -``` -*/ -external search: (t, Js_re.t) => int = "search" - -@send -/** -`slice(str, from:n1, to_:n2)` returns the substring of `str` starting at -character `n1` up to but not including `n2`. -- If either `n1` or `n2` is negative, then it is evaluated as `length(str - n1)` or `length(str - n2)`. -- If `n2` is greater than the length of `str`, then it is treated as `length(str)`. -- If `n1` is greater than `n2`, slice returns the empty string. - -See [`String.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/slice) on MDN. - -## Examples - -```rescript -Js.String2.slice("abcdefg", ~from=2, ~to_=5) == "cde" -Js.String2.slice("abcdefg", ~from=2, ~to_=9) == "cdefg" -Js.String2.slice("abcdefg", ~from=-4, ~to_=-2) == "de" -Js.String2.slice("abcdefg", ~from=5, ~to_=1) == "" -``` -*/ -external slice: (t, ~from: int, ~to_: int) => t = "slice" - -@send -/** -`sliceToEnd(str, from:n)` returns the substring of `str` starting at character -`n` to the end of the string. -- If `n` is negative, then it is evaluated as `length(str - n)`. -- If `n` is greater than the length of `str`, then sliceToEnd returns the empty string. - -See [`String.slice`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/slice) on MDN. - -## Examples - -```rescript -Js.String2.sliceToEnd("abcdefg", ~from=4) == "efg" -Js.String2.sliceToEnd("abcdefg", ~from=-2) == "fg" -Js.String2.sliceToEnd("abcdefg", ~from=7) == "" -``` -*/ -external sliceToEnd: (t, ~from: int) => t = "slice" - -@send -/** -`split(str, delimiter)` splits the given `str` at every occurrence of -`delimiter` and returns an array of the resulting substrings. - -See [`String.split`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/split) -on MDN. - -## Examples - -```rescript -Js.String2.split("2018-01-02", "-") == ["2018", "01", "02"] -Js.String2.split("a,b,,c", ",") == ["a", "b", "", "c"] -Js.String2.split("good::bad as great::awful", "::") == ["good", "bad as great", "awful"] -Js.String2.split("has-no-delimiter", ";") == ["has-no-delimiter"] -``` -*/ -external split: (t, t) => array = "split" - -@send -/** -`splitAtMost delimiter ~limit: n str` splits the given `str` at every occurrence of `delimiter` and returns an array of the first `n` resulting substrings. If `n` is negative or greater than the number of substrings, the array will contain all the substrings. - -``` -splitAtMost "ant/bee/cat/dog/elk" "/" ~limit: 3 = [|"ant"; "bee"; "cat"|];; -splitAtMost "ant/bee/cat/dog/elk" "/" ~limit: 0 = [| |];; -splitAtMost "ant/bee/cat/dog/elk" "/" ~limit: 9 = [|"ant"; "bee"; "cat"; "dog"; "elk"|];; -``` -*/ -external splitAtMost: (t, t, ~limit: int) => array = "split" - -@send -/** -`splitByRe(str, regex)` splits the given `str` at every occurrence of `regex` -and returns an array of the resulting substrings. - -See [`String.split`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/split) -on MDN. - -## Examples - -```rescript -Js.String2.splitByRe("art; bed , cog ;dad", %re("/\s*[,;]\s*TODO/")) == [ - Some("art"), - Some("bed"), - Some("cog"), - Some("dad"), - ] -``` -*/ -external splitByRe: (t, Js_re.t) => array> = "split" - -@send -/** -`splitByReAtMost(str, regex, ~limit:n)` splits the given `str` at every -occurrence of `regex` and returns an array of the first `n` resulting -substrings. If `n` is negative or greater than the number of substrings, the -array will contain all the substrings. - -See [`String.split`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/split) -on MDN. - -## Examples - -```rescript -Js.String2.splitByReAtMost("one: two: three: four", %re("/\s*:\s*TODO/"), ~limit=3) == [ - Some("one"), - Some("two"), - Some("three"), - ] - -Js.String2.splitByReAtMost("one: two: three: four", %re("/\s*:\s*TODO/"), ~limit=0) == [] - -Js.String2.splitByReAtMost("one: two: three: four", %re("/\s*:\s*TODO/"), ~limit=8) == [ - Some("one"), - Some("two"), - Some("three"), - Some("four"), - ] -``` -*/ -external splitByReAtMost: (t, Js_re.t, ~limit: int) => array> = "split" - -@send -/** -ES2015: `startsWith(str, substr)` returns `true` if the `str` starts with -`substr`, `false` otherwise. - -See [`String.startsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/startsWith) -on MDN. - -## Examples - -```rescript -Js.String2.startsWith("ReScript", "Re") == true -Js.String2.startsWith("ReScript", "") == true -Js.String2.startsWith("JavaScript", "Re") == false -``` -*/ -external startsWith: (t, t) => bool = "startsWith" - -@send -/** -ES2015: `startsWithFrom(str, substr, n)` returns `true` if the `str` starts -with `substr` starting at position `n`, false otherwise. If `n` is negative, -the search starts at the beginning of `str`. - -See [`String.startsWith`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/startsWith) -on MDN. - -## Examples - -```rescript -Js.String2.startsWithFrom("ReScript", "Scri", 2) == true -Js.String2.startsWithFrom("ReScript", "", 2) == true -Js.String2.startsWithFrom("JavaScript", "Scri", 2) == false -``` -*/ -external startsWithFrom: (t, t, int) => bool = "startsWith" - -@send -/** -`substr(str, ~from:n)` returns the substring of `str` from position `n` to the -end of the string. -- If `n` is less than zero, the starting position is the length of `str - n`. -- If `n` is greater than or equal to the length of `str`, returns the empty string. - -JavaScript’s `String.substr()` is a legacy function. When possible, use -`substring()` instead. - -See [`String.substr`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substr) -on MDN. - -## Examples - -```rescript -Js.String2.substr("abcdefghij", ~from=3) == "defghij" -Js.String2.substr("abcdefghij", ~from=-3) == "hij" -Js.String2.substr("abcdefghij", ~from=12) == "" -``` -*/ -external substr: (t, ~from: int) => t = "substr" - -@send -/** -`substrAtMost(str, ~from: pos, ~length: n)` returns the substring of `str` of -length `n` starting at position `pos`. -- If `pos` is less than zero, the starting position is the length of `str - pos`. -- If `pos` is greater than or equal to the length of `str`, returns the empty string. -- If `n` is less than or equal to zero, returns the empty string. - -JavaScript’s `String.substr()` is a legacy function. When possible, use -`substring()` instead. - -See [`String.substr`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substr) -on MDN. - -## Examples - -```rescript -Js.String2.substrAtMost("abcdefghij", ~from=3, ~length=4) == "defg" -Js.String2.substrAtMost("abcdefghij", ~from=-3, ~length=4) == "hij" -Js.String2.substrAtMost("abcdefghij", ~from=12, ~length=2) == "" -``` -*/ -external substrAtMost: (t, ~from: int, ~length: int) => t = "substr" - -@send -/** -`substring(str, ~from: start, ~to_: finish)` returns characters `start` up to -but not including finish from `str`. -- If `start` is less than zero, it is treated as zero. -- If `finish` is zero or negative, the empty string is returned. -- If `start` is greater than `finish`, the `start` and `finish` points are swapped. - -See [`String.substring`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substring) on MDN. - -## Examples - -```rescript -Js.String2.substring("playground", ~from=3, ~to_=6) == "ygr" -Js.String2.substring("playground", ~from=6, ~to_=3) == "ygr" -Js.String2.substring("playground", ~from=4, ~to_=12) == "ground" -``` -*/ -external substring: (t, ~from: int, ~to_: int) => t = "substring" - -@send -/** -`substringToEnd(str, ~from: start)` returns the substring of `str` from -position `start` to the end. -- If `start` is less than or equal to zero, the entire string is returned. -- If `start` is greater than or equal to the length of `str`, the empty string is returned. - -See [`String.substring`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/substring) on MDN. - -## Examples - -```rescript -Js.String2.substringToEnd("playground", ~from=4) == "ground" -Js.String2.substringToEnd("playground", ~from=-3) == "playground" -Js.String2.substringToEnd("playground", ~from=12) == "" -``` -*/ -external substringToEnd: (t, ~from: int) => t = "substring" - -@send -/** -`toLowerCase(str)` converts `str` to lower case using the locale-insensitive -case mappings in the Unicode Character Database. Notice that the conversion can -give different results depending upon context, for example with the Greek -letter sigma, which has two different lower case forms; one when it is the last -character in a string and another when it is not. - -See [`String.toLowerCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toLowerCase) -on MDN. - -## Examples - -```rescript -Js.String2.toLowerCase("ABC") == "abc" -Js.String2.toLowerCase(`ΣΠ`) == `σπ` -Js.String2.toLowerCase(`ΠΣ`) == `πς` -``` -*/ -external toLowerCase: t => t = "toLowerCase" - -@send -/** -`toLocaleLowerCase(str)` converts `str` to lower case using the current locale. -See [`String.toLocaleLowerCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toLocaleLowerCase) -on MDN. -*/ -external toLocaleLowerCase: t => t = "toLocaleLowerCase" - -@send -/** -`toUpperCase(str)` converts `str` to upper case using the locale-insensitive -case mappings in the Unicode Character Database. Notice that the conversion can -expand the number of letters in the result; for example the German ß -capitalizes to two Ses in a row. - -See [`String.toUpperCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toUpperCase) -on MDN. - -## Examples - -```rescript -Js.String2.toUpperCase("abc") == "ABC" -Js.String2.toUpperCase(`Straße`) == `STRASSE` -Js.String2.toUpperCase(`πς`) == `ΠΣ` -``` -*/ -external toUpperCase: t => t = "toUpperCase" - -@send -/** -`toLocaleUpperCase(str)` converts `str` to upper case using the current locale. -See [`String.to:LocaleUpperCase`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/toLocaleUpperCase) -on MDN. -*/ -external toLocaleUpperCase: t => t = "toLocaleUpperCase" - -@send -/** -`trim(str)` returns a string that is `str` with whitespace stripped from both -ends. Internal whitespace is not removed. - -See [`String.trim`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/trim) -on MDN. - -## Examples - -```rescript -Js.String2.trim(" abc def ") == "abc def" -Js.String2.trim("\n\r\t abc def \n\n\t\r ") == "abc def" -``` -*/ -external trim: t => t = "trim" - -/* HTML wrappers */ - -@send -/** -`anchor(anchorText, anchorName)` creates a string with an HTML `` element -with name attribute of `anchorName` and `anchorText` as its content. Please do -not use this method, as it has been removed from the relevant web standards. - -See [`String.anchor`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/anchor) -on MDN. - -## Examples - -```rescript -Js.String2.anchor("Page One", "page1") == "Page One" -``` -*/ -external anchor: (t, t) => t = "anchor" - -@send -/** -ES2015: `link(linkText, urlText)` creates a string with an HTML `` element -with href attribute of `urlText` and `linkText` as its content. Please do not -use this method, as it has been removed from the relevant web standards. See -[`String.link`](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/String/link) -on MDN. - -## Examples - -```rescript -Js.String2.link("Go to page two", "page2.html") == "Go to page two" -``` -*/ -external link: (t, t) => t = "link" - -/* FIXME: we should not encourage people to use [%identity], better - to provide something using [@@bs.val] so that we can track such - casting -*/ -/** -Casts its argument to an `array_like` entity that can be processed by functions -such as `Js.Array2.fromMap()` - -## Examples - -```rescript -let s = "abcde" -let arr = Js.Array2.fromMap(Js.String2.castToArrayLike(s), x => x) -arr == ["a", "b", "c", "d", "e"] -``` -*/ -external castToArrayLike: t => Js_array2.array_like = "%identity" diff --git a/jscomp/others/js_typed_array.res b/jscomp/others/js_typed_array.res deleted file mode 100644 index 21b010b..0000000 --- a/jscomp/others/js_typed_array.res +++ /dev/null @@ -1,1353 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -JavaScript Typed Array API - -**see** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/TypedArray) -*/ - -@@warning("-103") - -type array_buffer = Js_typed_array2.array_buffer -type array_like<'a> = Js_typed_array2.array_like<'a> - -module type Type = { - type t -} -module ArrayBuffer = { - /*** - The underlying buffer that the typed arrays provide views of - - **see** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/ArrayBuffer) - */ - - type t = array_buffer - - @new /** takes length. initializes elements to 0 */ - external make: int => t = "ArrayBuffer" - - /* ArrayBuffer.isView: seems pointless with a type system */ - /* experimental - external transfer : array_buffer -> t = "ArrayBuffer.transfer" [@@bs.val] - external transferWithLength : array_buffer -> int -> t = "ArrayBuffer.transfer" [@@bs.val] - */ - - @get external byteLength: t => int = "byteLength" - - @bs.send.pipe(: t) external slice: (~start: int, ~end_: int) => array_buffer = "slice" /* FIXME */ - @bs.send.pipe(: t) external sliceFrom: int => array_buffer = "slice" -} -module type S = { - /*** Implements functionality common to all the typed arrays */ - - type elt - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) - * --- - */ - @get external length: t => int = "length" - - /* Mutator functions - */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions - */ - @bs.send.pipe(: t) /** ES2016 */ - external includes: elt => bool = "includes" - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) external slice: (~start: int, ~end_: int) => t = "slice" - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) external subarray: (~start: int, ~end_: int) => t = "subarray" - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions - */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - /** should we use `bool` or `boolean` seems they are intechangeable here */ - @bs.send.pipe(: t) - external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - /* commented out until bs has a plan for iterators - external values : elt array_iter = "" [@@bs.send.pipe: t] - */ -} - -/* commented out until bs has a plan for iterators - external values : elt array_iter = "" [@@bs.send.pipe: t] - */ - -module Int8Array = { - /** */ - type elt = int - type typed_array<'a> = Js_typed_array2.Int8Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Int8Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Int8Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Int8Array" - - /** - raise Js.Exn.Error raise Js exception - - param offset is in bytes - */ - @new - external fromBufferOffset: (array_buffer, int) => t = "Int8Array" - - @new - /** - raise Js.Exn.Error raises Js exception - - param offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Int8Array" - - @new external fromLength: int => t = "Int8Array" - @val external from: array_like => t = "Int8Array.from" - /* *Array.of is redundant, use make */ -} - -module Uint8Array = { - /** */ - type elt = int - type typed_array<'a> = Js_typed_array2.Uint8Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint8Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint8Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint8Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Uint8Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint8Array" - - @new external fromLength: int => t = "Uint8Array" - @val external from: array_like => t = "Uint8Array.from" - /* *Array.of is redundant, use make */ -} - -module Uint8ClampedArray = { - /** */ - type elt = int - type typed_array<'a> = Js_typed_array2.Uint8ClampedArray.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint8ClampedArray.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint8ClampedArray" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint8ClampedArray" - - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - @new - external fromBufferOffset: (array_buffer, int) => t = "Uint8ClampedArray" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint8ClampedArray" - - @new external fromLength: int => t = "Uint8ClampedArray" - @val external from: array_like => t = "Uint8ClampedArray.from" - /* *Array.of is redundant, use make */ -} - -module Int16Array = { - /** */ - type elt = int - type typed_array<'a> = Js_typed_array2.Int16Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Int16Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Int16Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Int16Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Int16Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Int16Array" - - @new external fromLength: int => t = "Int16Array" - @val external from: array_like => t = "Int16Array.from" - /* *Array.of is redundant, use make */ -} - -module Uint16Array = { - /** */ - type elt = int - type typed_array<'a> = Js_typed_array2.Uint16Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint16Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint16Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint16Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Uint16Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint16Array" - - @new external fromLength: int => t = "Uint16Array" - @val external from: array_like => t = "Uint16Array.from" - /* *Array.of is redundant, use make */ -} - -module Int32Array = { - /** */ - type elt = int - type typed_array<'a> = Js_typed_array2.Int32Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Int32Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Int32Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Int32Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Int32Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Int32Array" - - @new external fromLength: int => t = "Int32Array" - @val external from: array_like => t = "Int32Array.from" - /* *Array.of is redundant, use make */ - @new @deprecated("use `make` instead") external create: array => t = "Int32Array" - @new @deprecated("use `fromBuffer` instead") external of_buffer: array_buffer => t = "Int32Array" -} -module Int32_array = Int32Array - -module Uint32Array = { - /** */ - type elt = int - type typed_array<'a> = Js_typed_array2.Uint32Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint32Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint32Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint32Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Uint32Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint32Array" - - @new external fromLength: int => t = "Uint32Array" - @val external from: array_like => t = "Uint32Array.from" - /* *Array.of is redundant, use make */ -} - -/* - it still return number, `float` in this case -*/ -module Float32Array = { - /** */ - type elt = float - type typed_array<'a> = Js_typed_array2.Float32Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Float32Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Float32Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Float32Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Float32Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Float32Array" - - @new external fromLength: int => t = "Float32Array" - @val external from: array_like => t = "Float32Array.from" - /* *Array.of is redundant, use make */ - @new @deprecated("use `make` instead") external create: array => t = "Float32Array" - @new @deprecated("use `fromBuffer` instead") - external of_buffer: array_buffer => t = "Float32Array" -} -module Float32_array = Float32Array - -module Float64Array = { - /** */ - type elt = float - type typed_array<'a> = Js_typed_array2.Float64Array.typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @bs.send.pipe(: t) external setArray: array => unit = "set" - @bs.send.pipe(: t) external setArrayOffset: (array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @bs.send.pipe(: t) external copyWithin: (~to_: int) => t = "copyWithin" - @bs.send.pipe(: t) external copyWithinFrom: (~to_: int, ~from: int) => t = "copyWithin" - @bs.send.pipe(: t) - external copyWithinFromRange: (~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @bs.send.pipe(: t) external fillInPlace: elt => t = "fill" - @bs.send.pipe(: t) external fillFromInPlace: (elt, ~from: int) => t = "fill" - @bs.send.pipe(: t) external fillRangeInPlace: (elt, ~start: int, ~end_: int) => t = "fill" - - @bs.send.pipe(: t) external reverseInPlace: t = "reverse" - - @bs.send.pipe(: t) external sortInPlace: t = "sort" - @bs.send.pipe(: t) external sortInPlaceWith: ((. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @bs.send.pipe(: t) external includes: elt => bool = "includes" /* ES2016 */ - - @bs.send.pipe(: t) external indexOf: elt => int = "indexOf" - @bs.send.pipe(: t) external indexOfFrom: (elt, ~from: int) => int = "indexOf" - - @bs.send.pipe(: t) external join: string = "join" - @bs.send.pipe(: t) external joinWith: string => string = "join" - - @bs.send.pipe(: t) external lastIndexOf: elt => int = "lastIndexOf" - @bs.send.pipe(: t) external lastIndexOfFrom: (elt, ~from: int) => int = "lastIndexOf" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external slice: (~start: int, ~end_: int) => t = "slice" - - @bs.send.pipe(: t) external copy: t = "slice" - @bs.send.pipe(: t) external sliceFrom: int => t = "slice" - - @bs.send.pipe(: t) /** `start` is inclusive, `end_` exclusive */ - external subarray: (~start: int, ~end_: int) => t = "subarray" - - @bs.send.pipe(: t) external subarrayFrom: int => t = "subarray" - - @bs.send.pipe(: t) external toString: string = "toString" - @bs.send.pipe(: t) external toLocaleString: string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : (int * elt) array_iter = "" [@@bs.send.pipe: t] - */ - @bs.send.pipe(: t) external every: ((. elt) => bool) => bool = "every" - @bs.send.pipe(: t) external everyi: ((. elt, int) => bool) => bool = "every" - - @bs.send.pipe(: t) external filter: ((. elt) => bool) => t = "filter" - @bs.send.pipe(: t) external filteri: ((. elt, int) => bool) => t = "filter" - - @bs.send.pipe(: t) external find: ((. elt) => bool) => Js.undefined = "find" - @bs.send.pipe(: t) external findi: ((. elt, int) => bool) => Js.undefined = "find" - - @bs.send.pipe(: t) external findIndex: ((. elt) => bool) => int = "findIndex" - @bs.send.pipe(: t) external findIndexi: ((. elt, int) => bool) => int = "findIndex" - - @bs.send.pipe(: t) external forEach: ((. elt) => unit) => unit = "forEach" - @bs.send.pipe(: t) external forEachi: ((. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : int array_iter = "" [@@bs.send.pipe: t] - */ - - @bs.send.pipe(: t) external map: ((. elt) => 'b) => typed_array<'b> = "map" - @bs.send.pipe(: t) external mapi: ((. elt, int) => 'b) => typed_array<'b> = "map" - - @bs.send.pipe(: t) external reduce: ((. 'b, elt) => 'b, 'b) => 'b = "reduce" - @bs.send.pipe(: t) external reducei: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @bs.send.pipe(: t) external reduceRight: ((. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @bs.send.pipe(: t) external reduceRighti: ((. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @bs.send.pipe(: t) external some: ((. elt) => bool) => bool = "some" - @bs.send.pipe(: t) external somei: ((. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Float64Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Float64Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Float64Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Float64Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Float64Array" - - @new external fromLength: int => t = "Float64Array" - @val external from: array_like => t = "Float64Array.from" - /* *Array.of is redundant, use make */ - @new @deprecated("use `make` instead") external create: array => t = "Float64Array" - @new @deprecated("use `fromBuffer` instead") - external of_buffer: array_buffer => t = "Float64Array" -} -module Float64_array = Float64Array - -/** -The DataView view provides a low-level interface for reading and writing -multiple number types in an ArrayBuffer irrespective of the platform's endianness. - -**see** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView) -*/ -module DataView = { - type t = Js_typed_array2.DataView.t - - @new external make: array_buffer => t = "DataView" - @new external fromBuffer: array_buffer => t = "DataView" - @new external fromBufferOffset: (array_buffer, int) => t = "DataView" - @new external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "DataView" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external getInt8: (t, int) => int = "getInt8" - @send external getUint8: (t, int) => int = "getUint8" - - @send external getInt16: (t, int) => int = "getInt16" - @send external getInt16LittleEndian: (t, int, @as(1) _) => int = "getInt16" - - @send external getUint16: (t, int) => int = "getUint16" - @send external getUint16LittleEndian: (t, int, @as(1) _) => int = "getUint16" - - @send external getInt32: (t, int) => int = "getInt32" - @send external getInt32LittleEndian: (t, int, @as(1) _) => int = "getInt32" - - @send external getUint32: (t, int) => int = "getUint32" - @send external getUint32LittleEndian: (t, int, @as(1) _) => int = "getUint32" - - @send external getFloat32: (t, int) => float = "getFloat32" - @send external getFloat32LittleEndian: (t, int, @as(1) _) => float = "getFloat32" - - @send external getFloat64: (t, int) => float = "getFloat64" - @send external getFloat64LittleEndian: (t, int, @as(1) _) => float = "getFloat64" - - @send external setInt8: (t, int, int) => unit = "setInt8" - @send external setUint8: (t, int, int) => unit = "setUint8" - - @send external setInt16: (t, int, int) => unit = "setInt16" - @send external setInt16LittleEndian: (t, int, int, @as(1) _) => unit = "setInt16" - - @send external setUint16: (t, int, int) => unit = "setUint16" - @send external setUint16LittleEndian: (t, int, int, @as(1) _) => unit = "setUint16" - - @send external setInt32: (t, int, int) => unit = "setInt32" - @send external setInt32LittleEndian: (t, int, int, @as(1) _) => unit = "setInt32" - - @send external setUint32: (t, int, int) => unit = "setUint32" - @send external setUint32LittleEndian: (t, int, int, @as(1) _) => unit = "setUint32" - - @send external setFloat32: (t, int, float) => unit = "setFloat32" - @send external setFloat32LittleEndian: (t, int, float, @as(1) _) => unit = "setFloat32" - - @send external setFloat64: (t, int, float) => unit = "setFloat64" - @send external setFloat64LittleEndian: (t, int, float, @as(1) _) => unit = "setFloat64" -} diff --git a/jscomp/others/js_typed_array2.res b/jscomp/others/js_typed_array2.res deleted file mode 100644 index 93bae0e..0000000 --- a/jscomp/others/js_typed_array2.res +++ /dev/null @@ -1,1222 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -JavaScript Typed Array API - -**see** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/TypedArray) -*/ - -type array_buffer -type array_like<'a> /* should be shared with js_array */ - -module ArrayBuffer = { - /*** - The underlying buffer that the typed arrays provide views of - - **see** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/ArrayBuffer) - */ - - type t = array_buffer - - @new /** takes length. initializes elements to 0 */ - external make: int => t = "ArrayBuffer" - - /* ArrayBuffer.isView: seems pointless with a type system */ - /* experimental - external transfer : array_buffer -> t = "ArrayBuffer.transfer" [@@bs.val] - external transferWithLength : array_buffer -> int -> t = "ArrayBuffer.transfer" [@@bs.val] - */ - - @get external byteLength: t => int = "byteLength" - - @send external slice: (t, ~start: int, ~end_: int) => array_buffer = "slice" - @send external sliceFrom: (t, int) => array_buffer = "slice" -} - -/* commented out until bs has a plan for iterators - external values : t -> elt array_iter = "" [@@bs.send] - */ - -module Int8Array = { - /** */ - type elt = int - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Int8Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Int8Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Int8Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Int8Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Int8Array" - - @new external fromLength: int => t = "Int8Array" - @val external from: array_like => t = "Int8Array.from" - /* *Array.of is redundant, use make */ -} - -module Uint8Array = { - /** */ - type elt = int - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint8Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint8Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint8Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Uint8Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint8Array" - - @new external fromLength: int => t = "Uint8Array" - @val external from: array_like => t = "Uint8Array.from" - /* *Array.of is redundant, use make */ -} - -module Uint8ClampedArray = { - /** */ - type elt = int - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint8ClampedArray.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint8ClampedArray" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint8ClampedArray" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Uint8ClampedArray" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint8ClampedArray" - - @new external fromLength: int => t = "Uint8ClampedArray" - @val external from: array_like => t = "Uint8ClampedArray.from" - /* *Array.of is redundant, use make */ -} - -module Int16Array = { - /** */ - type elt = int - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Int16Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Int16Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Int16Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Int16Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Int16Array" - - @new external fromLength: int => t = "Int16Array" - @val external from: array_like => t = "Int16Array.from" - /* *Array.of is redundant, use make */ -} - -module Uint16Array = { - /** */ - type elt = int - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint16Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint16Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint16Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Uint16Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint16Array" - - @new external fromLength: int => t = "Uint16Array" - @val external from: array_like => t = "Uint16Array.from" - /* *Array.of is redundant, use make */ -} - -module Int32Array = { - /** */ - type elt = int - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Int32Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Int32Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Int32Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Int32Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Int32Array" - - @new external fromLength: int => t = "Int32Array" - @val external from: array_like => t = "Int32Array.from" - /* *Array.of is redundant, use make */ -} - -module Uint32Array = { - /** */ - type elt = int - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Uint32Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Uint32Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Uint32Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Uint32Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Uint32Array" - - @new external fromLength: int => t = "Uint32Array" - @val external from: array_like => t = "Uint32Array.from" - /* *Array.of is redundant, use make */ -} - -/* - it still return number, `float` in this case -*/ -module Float32Array = { - /** */ - type elt = float - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Float32Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Float32Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Float32Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Float32Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Float32Array" - - @new external fromLength: int => t = "Float32Array" - @val external from: array_like => t = "Float32Array.from" - /* *Array.of is redundant, use make */ -} - -module Float64Array = { - /** */ - type elt = float - type typed_array<'a> - type t = typed_array - - @get_index external unsafe_get: (t, int) => elt = "" - @set_index external unsafe_set: (t, int, elt) => unit = "" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external setArray: (t, array) => unit = "set" - @send external setArrayOffset: (t, array, int) => unit = "set" - /* There's also an overload for typed arrays, but don't know how to model that without subtyping */ - - /* Array interface(-ish) */ - @get external length: t => int = "length" - - /* Mutator functions */ - @send external copyWithin: (t, ~to_: int) => t = "copyWithin" - @send external copyWithinFrom: (t, ~to_: int, ~from: int) => t = "copyWithin" - @send external copyWithinFromRange: (t, ~to_: int, ~start: int, ~end_: int) => t = "copyWithin" - - @send external fillInPlace: (t, elt) => t = "fill" - @send external fillFromInPlace: (t, elt, ~from: int) => t = "fill" - @send external fillRangeInPlace: (t, elt, ~start: int, ~end_: int) => t = "fill" - - @send external reverseInPlace: t => t = "reverse" - - @send external sortInPlace: t => t = "sort" - @send external sortInPlaceWith: (t, (. elt, elt) => int) => t = "sort" - - /* Accessor functions */ - @send external includes: (t, elt) => bool = "includes" /* ES2016 */ - - @send external indexOf: (t, elt) => int = "indexOf" - @send external indexOfFrom: (t, elt, ~from: int) => int = "indexOf" - - @send external join: t => string = "join" - @send external joinWith: (t, string) => string = "join" - - @send external lastIndexOf: (t, elt) => int = "lastIndexOf" - @send external lastIndexOfFrom: (t, elt, ~from: int) => int = "lastIndexOf" - - @send /** `start` is inclusive, `end_` exclusive */ - external slice: (t, ~start: int, ~end_: int) => t = "slice" - - @send external copy: t => t = "slice" - @send external sliceFrom: (t, int) => t = "slice" - - @send /** `start` is inclusive, `end_` exclusive */ - external subarray: (t, ~start: int, ~end_: int) => t = "subarray" - - @send external subarrayFrom: (t, int) => t = "subarray" - - @send external toString: t => string = "toString" - @send external toLocaleString: t => string = "toLocaleString" - - /* Iteration functions */ - /* commented out until bs has a plan for iterators - external entries : t -> (int * elt) array_iter = "" [@@bs.send] - */ - @send external every: (t, (. elt) => bool) => bool = "every" - @send external everyi: (t, (. elt, int) => bool) => bool = "every" - - @send external filter: (t, (. elt) => bool) => t = "filter" - @send external filteri: (t, (. elt, int) => bool) => t = "filter" - - @send external find: (t, (. elt) => bool) => Js.undefined = "find" - @send external findi: (t, (. elt, int) => bool) => Js.undefined = "find" - - @send external findIndex: (t, (. elt) => bool) => int = "findIndex" - @send external findIndexi: (t, (. elt, int) => bool) => int = "findIndex" - - @send external forEach: (t, (. elt) => unit) => unit = "forEach" - @send external forEachi: (t, (. elt, int) => unit) => unit = "forEach" - - /* commented out until bs has a plan for iterators - external keys : t -> int array_iter = "" [@@bs.send] - */ - - @send external map: (t, (. elt) => 'b) => typed_array<'b> = "map" - @send external mapi: (t, (. elt, int) => 'b) => typed_array<'b> = "map" - - @send external reduce: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduce" - @send external reducei: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduce" - - @send external reduceRight: (t, (. 'b, elt) => 'b, 'b) => 'b = "reduceRight" - @send external reduceRighti: (t, (. 'b, elt, int) => 'b, 'b) => 'b = "reduceRight" - - @send external some: (t, (. elt) => bool) => bool = "some" - @send external somei: (t, (. elt, int) => bool) => bool = "some" - - @val external _BYTES_PER_ELEMENT: int = "Float64Array.BYTES_PER_ELEMENT" - - @new external make: array => t = "Float64Array" - @new /** can throw */ - external fromBuffer: array_buffer => t = "Float64Array" - - @new - /** - **raise** Js.Exn.Error raise Js exception - - **param** offset is in bytes - */ - external fromBufferOffset: (array_buffer, int) => t = "Float64Array" - - @new - /** - **raise** Js.Exn.Error raises Js exception - - **param** offset is in bytes, length in elements - */ - external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "Float64Array" - - @new external fromLength: int => t = "Float64Array" - @val external from: array_like => t = "Float64Array.from" - /* *Array.of is redundant, use make */ -} - -/** -The DataView view provides a low-level interface for reading and writing -multiple number types in an ArrayBuffer irrespective of the platform's endianness. - -**see** [MDN](https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/DataView) -*/ -module DataView = { - type t - - @new external make: array_buffer => t = "DataView" - @new external fromBuffer: array_buffer => t = "DataView" - @new external fromBufferOffset: (array_buffer, int) => t = "DataView" - @new external fromBufferRange: (array_buffer, ~offset: int, ~length: int) => t = "DataView" - - @get external buffer: t => array_buffer = "buffer" - @get external byteLength: t => int = "byteLength" - @get external byteOffset: t => int = "byteOffset" - - @send external getInt8: (t, int) => int = "getInt8" - @send external getUint8: (t, int) => int = "getUint8" - - @send external getInt16: (t, int) => int = "getInt16" - @send external getInt16LittleEndian: (t, int, @as(1) _) => int = "getInt16" - - @send external getUint16: (t, int) => int = "getUint16" - @send external getUint16LittleEndian: (t, int, @as(1) _) => int = "getUint16" - - @send external getInt32: (t, int) => int = "getInt32" - @send external getInt32LittleEndian: (t, int, @as(1) _) => int = "getInt32" - - @send external getUint32: (t, int) => int = "getUint32" - @send external getUint32LittleEndian: (t, int, @as(1) _) => int = "getUint32" - - @send external getFloat32: (t, int) => float = "getFloat32" - @send external getFloat32LittleEndian: (t, int, @as(1) _) => float = "getFloat32" - - @send external getFloat64: (t, int) => float = "getFloat64" - @send external getFloat64LittleEndian: (t, int, @as(1) _) => float = "getFloat64" - - @send external setInt8: (t, int, int) => unit = "setInt8" - @send external setUint8: (t, int, int) => unit = "setUint8" - - @send external setInt16: (t, int, int) => unit = "setInt16" - @send external setInt16LittleEndian: (t, int, int, @as(1) _) => unit = "setInt16" - - @send external setUint16: (t, int, int) => unit = "setUint16" - @send external setUint16LittleEndian: (t, int, int, @as(1) _) => unit = "setUint16" - - @send external setInt32: (t, int, int) => unit = "setInt32" - @send external setInt32LittleEndian: (t, int, int, @as(1) _) => unit = "setInt32" - - @send external setUint32: (t, int, int) => unit = "setUint32" - @send external setUint32LittleEndian: (t, int, int, @as(1) _) => unit = "setUint32" - - @send external setFloat32: (t, int, float) => unit = "setFloat32" - @send external setFloat32LittleEndian: (t, int, float, @as(1) _) => unit = "setFloat32" - - @send external setFloat64: (t, int, float) => unit = "setFloat64" - @send external setFloat64LittleEndian: (t, int, float, @as(1) _) => unit = "setFloat64" -} diff --git a/jscomp/others/js_types.res b/jscomp/others/js_types.res deleted file mode 100644 index 9048765..0000000 --- a/jscomp/others/js_types.res +++ /dev/null @@ -1,101 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/** Js symbol type only available in ES6 */ -type symbol - -/** Js bigint type only available in ES2020 */ -type bigint_val = bigint - -type obj_val -/** This type has only one value `undefined` */ -type undefined_val - -/** This type has only one value `null` */ -type null_val - -type function_val - -type rec t<_> = - | Undefined: t - | Null: t - | Boolean: t - | Number: t - | String: t - | Function: t - | Object: t - | Symbol: t - | BigInt: t - -type tagged_t = - | JSFalse - | JSTrue - | JSNull - | JSUndefined - | JSNumber(float) - | JSString(string) - | JSFunction(function_val) - | JSObject(obj_val) - | JSSymbol(symbol) - | JSBigInt(bigint_val) - -let classify = (x: 'a): tagged_t => { - let ty = Js.typeof(x) - if ty == "undefined" { - JSUndefined - } else if x === Obj.magic(Js_null.empty) { - JSNull - } else if ty == "number" { - JSNumber(Obj.magic(x)) - } else if ty == "bigint" { - JSBigInt(Obj.magic(x)) - } else if ty == "string" { - JSString(Obj.magic(x)) - } else if ty == "boolean" { - if Obj.magic(x) == true { - JSTrue - } else { - JSFalse - } - } else if ty == "symbol" { - JSSymbol(Obj.magic(x)) - } else if ty == "function" { - JSFunction(Obj.magic(x)) - } else { - JSObject(Obj.magic(x)) - } -} - -let test = (type a, x: 'a, v: t): bool => - switch v { - | Number => Js.typeof(x) == "number" - | Boolean => Js.typeof(x) == "boolean" - | Undefined => Js.typeof(x) == "undefined" - | Null => x === Obj.magic(Js_null.empty) - | String => Js.typeof(x) == "string" - | Function => Js.typeof(x) == "function" - | Object => Js.typeof(x) == "object" - | Symbol => Js.typeof(x) == "symbol" - | BigInt => Js.typeof(x) == "bigint" - } diff --git a/jscomp/others/js_types.resi b/jscomp/others/js_types.resi deleted file mode 100644 index f267cd2..0000000 --- a/jscomp/others/js_types.resi +++ /dev/null @@ -1,80 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provide utilities for manipulating JS types. */ - -/** Js symbol type (only available in ES6) */ -type symbol - -/** Js bigint type only available in ES2020 */ -type bigint_val - -type obj_val - -/** This type has only one value `undefined` */ -type undefined_val - -/** This type has only one value `null` */ -type null_val - -type function_val - -type rec t<_> = - | Undefined: t - | Null: t - | Boolean: t - | Number: t - | String: t - | Function: t - | Object: t - | Symbol: t - | BigInt: t - -/** -`test(value, t)` returns `true` if `value` is `typeof t`, otherwise `false`. -This is useful for doing runtime reflection on any given value. - -## Examples - -```rescript -test("test", String) == true -test(() => true, Function) == true -test("test", Boolean) == false -``` -*/ -let test: ('a, t<'b>) => bool - -type tagged_t = - | JSFalse - | JSTrue - | JSNull - | JSUndefined - | JSNumber(float) - | JSString(string) - | JSFunction(function_val) - | JSObject(obj_val) - | JSSymbol(symbol) - | JSBigInt(bigint_val) - -let classify: 'a => tagged_t diff --git a/jscomp/others/js_undefined.res b/jscomp/others/js_undefined.res deleted file mode 100644 index c35340c..0000000 --- a/jscomp/others/js_undefined.res +++ /dev/null @@ -1,61 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provides functionality for dealing with the `'a Js.undefined` type */ - -type t<+'a> = Js.undefined<'a> -external to_opt: t<'a> => option<'a> = "#undefined_to_opt" -external toOption: t<'a> => option<'a> = "#undefined_to_opt" -external return: 'a => t<'a> = "%identity" - -external empty: t<'a> = "#undefined" -let test: t<'a> => bool = x => x == empty -let testAny: 'a => bool = x => Obj.magic(x) == empty -external getUnsafe: t<'a> => 'a = "%identity" - -let getExn = f => - switch toOption(f) { - | None => Js_exn.raiseError("Js.Undefined.getExn") - | Some(x) => x - } - -let bind = (x, f) => - switch to_opt(x) { - | None => empty - | Some(x) => return(f(. x)) - } - -let iter = (x, f) => - switch to_opt(x) { - | None => () - | Some(x) => f(. x) - } - -let fromOption = x => - switch x { - | None => empty - | Some(x) => return(x) - } - -let from_opt = fromOption diff --git a/jscomp/others/js_undefined.resi b/jscomp/others/js_undefined.resi deleted file mode 100644 index cfa08b6..0000000 --- a/jscomp/others/js_undefined.resi +++ /dev/null @@ -1,95 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Provides functionality for dealing with the `Js.undefined<'a>` type */ - -/** Local alias for `Js.undefined<'a>` */ -type t<+'a> = Js.undefined<'a> - -/** Constructs a value of `Js.undefined<'a>` containing a value of `'a`. */ -external return: 'a => t<'a> = "%identity" - -@deprecated("Use = Js.undefined directly") -/** Returns `true` if the given value is empty (undefined), `false` otherwise. */ -let test: t<'a> => bool - -/** -Returns `true` if the given value is empty (undefined). - -**since 1.6.1** -*/ -let testAny: 'a => bool - -/** The empty value, `undefined` */ -external empty: t<'a> = "#undefined" - -external getUnsafe: t<'a> => 'a = "%identity" -let getExn: t<'a> => 'a - -/** -Maps the contained value using the given function. -If `Js.undefined<'a>` contains a value, that value is unwrapped, mapped to a -`'b` using the given function `a' => 'b`, then wrapped back up and returned as -`Js.undefined<'b>`. - -## Examples - -```rescript -let maybeGreetWorld = (maybeGreeting: Js.undefined) => - Js.Undefined.bind(maybeGreeting, (. greeting) => greeting ++ " world!") -``` -*/ -let bind: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -Iterates over the contained value with the given function. If -`Js.undefined<'a>` contains a value, that value is unwrapped and applied to the -given function. - -## Examples - -```rescript -let maybeSay = (maybeMessage: Js.undefined) => - Js.Undefined.iter(maybeMessage, (. message) => Js.log(message)) -``` -*/ -let iter: (t<'a>, (. 'a) => unit) => unit - -/** -Maps `option<'a>` to `Js.undefined<'a>`. -`Some(a)` => `a` -`None` => `empty` -*/ -let fromOption: option<'a> => t<'a> - -@deprecated("Use fromOption instead") let from_opt: option<'a> => t<'a> - -/** -Maps `Js.undefined<'a>` to `option<'a>` -`a` => `Some(a)` -`empty` => `None` -*/ -external toOption: t<'a> => option<'a> = "#undefined_to_opt" - -@deprecated("use toOption instead") external to_opt: t<'a> => option<'a> = "#undefined_to_opt" diff --git a/jscomp/others/js_vector.res b/jscomp/others/js_vector.res deleted file mode 100644 index 15b1ff0..0000000 --- a/jscomp/others/js_vector.res +++ /dev/null @@ -1,149 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t<'a> = array<'a> - -external length: array<'a> => int = "%array_length" -external get: (array<'a>, int) => 'a = "%array_safe_get" -external set: (array<'a>, int, 'a) => unit = "%array_safe_set" -external make: (int, 'a) => array<'a> = "?make_vect" -external unsafe_get: (t<'a>, int) => 'a = "%array_unsafe_get" -external unsafe_set: (t<'a>, int, 'a) => unit = "%array_unsafe_set" - -/** -**param** a array - -**param** p predicate -*/ -let filterInPlace = (p, a) => { - let i = ref(0) - let j = ref(0) - while i.contents < Js_array2.length(a) { - let v = Js_array2.unsafe_get(a, i.contents) - if p(. v) { - Js_array2.unsafe_set(a, j.contents, v) - j.contents = j.contents + 1 - } - i.contents = i.contents + 1 - } - Js_array2.removeFromInPlace(a, ~pos=j.contents)->ignore -} - -let empty = a => Js_array2.removeFromInPlace(a, ~pos=0)->ignore - -let pushBack = (x, xs) => Js_array2.push(xs, x)->ignore - -/** Find by JS (===) equality */ -let memByRef = (x, xs) => Js_array2.indexOf(xs, x) >= 0 - -let iter = (f, xs) => - for i in 0 to Js_array2.length(xs) - 1 { - f(. Js_array2.unsafe_get(xs, i)) - } - -let iteri = (f, a) => - for i in 0 to length(a) - 1 { - f(. i, unsafe_get(a, i)) - } - -@new external createUnsafe: int => t<'a> = "Array" - -/* let ofList xs = */ -/* match xs with */ -/* | [] -> [||] */ -/* | l -> */ -/* let a = createUnsafe (Js_list.length l) in */ -/* let rec fill i = function */ -/* | [] -> a */ -/* | hd::tl -> Array.unsafe_set a i hd; fill (i+1) tl in */ -/* fill 0 l */ - -let toList = a => { - let rec tolist = (i, res) => - if i < 0 { - res - } else { - tolist(i - 1, list{unsafe_get(a, i), ...res}) - } - tolist(length(a) - 1, list{}) -} - -let init = (n, f) => { - let v = createUnsafe(n) - for i in 0 to n - 1 { - unsafe_set(v, i, f(. i)) - } - v -} - -let copy = x => { - let len = length(x) - let b = createUnsafe(len) - for i in 0 to len - 1 { - unsafe_set(b, i, unsafe_get(x, i)) - } - b -} - -let map = (f, a) => { - let l = Js_array2.length(a) - let r = createUnsafe(l) - for i in 0 to l - 1 { - unsafe_set(r, i, f(. unsafe_get(a, i))) - } - r -} - -let foldLeft = (f, x, a) => { - let r = ref(x) - for i in 0 to length(a) - 1 { - r.contents = f(. r.contents, unsafe_get(a, i)) - } - r.contents -} - -let foldRight = (f, a, x) => { - let r = ref(x) - for i in length(a) - 1 downto 0 { - r.contents = f(. unsafe_get(a, i), r.contents) - } - r.contents -} - -let mapi = (f, a) => { - let l = length(a) - if l == 0 { - [] - } else { - let r = createUnsafe(l) - for i in 0 to l - 1 { - unsafe_set(r, i, f(. i, unsafe_get(a, i))) - } - r - } -} - -let append = (x, a) => Js_array2.concat(a, [x]) - -/* TODO: add `append` */ diff --git a/jscomp/others/js_vector.resi b/jscomp/others/js_vector.resi deleted file mode 100644 index 6218e9a..0000000 --- a/jscomp/others/js_vector.resi +++ /dev/null @@ -1,92 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@@deprecated("Use Belt.Array instead") - -type t<'a> = array<'a> - -let filterInPlace: ((. 'a) => bool, t<'a>) => unit -let empty: t<'a> => unit -let pushBack: ('a, t<'a>) => unit - -/** shallow copy */ -let copy: t<'a> => t<'a> - -let memByRef: ('a, t<'a>) => bool -let iter: ((. 'a) => unit, t<'a>) => unit -let iteri: ((. int, 'a) => unit, t<'a>) => unit - -/* [@@deprecated "Use Js.List.toVector instead"] */ -/* val ofList : 'a list -> 'a t */ -/* removed, we choose that [`Js.List`]() depends on Vector to avoid cylic dependency - */ - -let toList: t<'a> => list<'a> -let map: ((. 'a) => 'b, t<'a>) => t<'b> -let mapi: ((. int, 'a) => 'b, t<'a>) => t<'b> -let foldLeft: ((. 'a, 'b) => 'a, 'a, t<'b>) => 'a -let foldRight: ((. 'b, 'a) => 'a, t<'b>, 'a) => 'a - -/** Return the length (number of elements) of the given array. */ -external length: t<'a> => int = "%array_length" - -/** -`Vector.get(a, n)` returns the element number `n` of vector `a`. The first -element has number 0. The last element has number `Vector.length(a) - 1`. You -can also write `a[n]` instead of `Vector.get(a, n)`. Raise `Invalid_argument -"index out of bounds"` if `n` is outside the range 0 to (`Array.length(a) - -1`). -*/ -external get: (t<'a>, int) => 'a = "%array_safe_get" - -/** -`Vector.set(a, n, x)` modifies vector `a` in place, replacing element number -`n` with `x`. Raise `Invalid_argument "index out of bounds"` if `n` is outside -the range 0 to `Array.length(a) - 1`. -*/ -external set: (t<'a>, int, 'a) => unit = "%array_safe_set" - -/** -`Vector.make(n, x)` returns a fresh vector of length `n`, initialized with `x`. -All the elements of this new vector are initially physically equal to `x` (in -the sense of the `==` predicate). Consequently, if `x` is mutable, it is shared -among all elements of the array, and modifying `x` through one of the array -entries will modify all other entries at the same time. Raise -`Invalid_argument` if `n < 0` or `n > Sys.max_array_length`. If the value of -`x` is a floating-point number, then the maximum size is only -`Sys.max_array_length / 2`. -*/ -external make: (int, 'a) => t<'a> = "?make_vect" - -/** -Raises `RangeError` when n is negative. -n : size -*/ -let init: (int, (. int) => 'a) => t<'a> - -/** `append(x, a)` returns a fresh vector with `x` appended to `a`. */ -let append: ('a, t<'a>) => t<'a> - -external unsafe_get: (t<'a>, int) => 'a = "%array_unsafe_get" -external unsafe_set: (t<'a>, int, 'a) => unit = "%array_unsafe_set" diff --git a/jscomp/others/js_weakmap.res b/jscomp/others/js_weakmap.res deleted file mode 100644 index 926ceaf..0000000 --- a/jscomp/others/js_weakmap.res +++ /dev/null @@ -1,3 +0,0 @@ -/*** ES6 WeakMap API */ - -type t<'k, 'v> diff --git a/jscomp/others/js_weakset.res b/jscomp/others/js_weakset.res deleted file mode 100644 index e9652c4..0000000 --- a/jscomp/others/js_weakset.res +++ /dev/null @@ -1,3 +0,0 @@ -/*** ES6 WeakSet API */ - -type t<'a> diff --git a/jscomp/others/jsxC.res b/jscomp/others/jsxC.res deleted file mode 100644 index d7e08eb..0000000 --- a/jscomp/others/jsxC.res +++ /dev/null @@ -1,42 +0,0 @@ -/* Copyright (C) 2022- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Internal: use Jsx directly. */ - -type element -type ref - -@val external null: element = "null" - -external float: float => element = "%identity" -external int: int => element = "%identity" -external string: string => element = "%identity" - -external array: array => element = "%identity" - -type componentLike<'props, 'return> = 'props => 'return -type component<'props> = componentLike<'props, element> - -/* this function exists to prepare for making `component` abstract */ -external component: componentLike<'props, element> => component<'props> = "%identity" diff --git a/jscomp/others/jsxDOMC.res b/jscomp/others/jsxDOMC.res deleted file mode 100644 index c1d7098..0000000 --- a/jscomp/others/jsxDOMC.res +++ /dev/null @@ -1,622 +0,0 @@ -/* Copyright (C) 2022- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Internal: use JsxDOM directly. */ - -type style = JsxDOMStyle.t -type domRef - -/* - This list isn't exhaustive. We'll add more as we go. -*/ -type domProps = { - key?: string, - children?: JsxC.element, - ref?: domRef, - /* accessibility */ - /* https://www.w3.org/TR/wai-aria-1.1/ */ - /* https://accessibilityresources.org/ is a great resource for these */ - @as("aria-current") - ariaCurrent?: [#page | #step | #location | #date | #time | #"true" | #"false"], - @as("aria-details") - ariaDetails?: string, - @as("aria-disabled") - ariaDisabled?: bool, - @as("aria-hidden") - ariaHidden?: bool, - @as("aria-invalid") ariaInvalid?: [#grammar | #"false" | #spelling | #"true"], - @as("aria-keyshortcuts") - ariaKeyshortcuts?: string, - @as("aria-label") - ariaLabel?: string, - @as("aria-roledescription") - ariaRoledescription?: string, - /* Widget Attributes */ - @as("aria-autocomplete") ariaAutocomplete?: [#inline | #list | #both | #none], - /* https://www.w3.org/TR/wai-aria-1.1/#valuetype_tristate */ - @as("aria-checked") - ariaChecked?: [#"true" | #"false" | #mixed], - @as("aria-expanded") - ariaExpanded?: bool, - @as("aria-haspopup") - ariaHaspopup?: [#menu | #listbox | #tree | #grid | #dialog | #"true" | #"false"], - @as("aria-level") - ariaLevel?: int, - @as("aria-modal") - ariaModal?: bool, - @as("aria-multiline") - ariaMultiline?: bool, - @as("aria-multiselectable") - ariaMultiselectable?: bool, - @as("aria-orientation") ariaOrientation?: [#horizontal | #vertical | #undefined], - @as("aria-placeholder") - ariaPlaceholder?: string, - /* https://www.w3.org/TR/wai-aria-1.1/#valuetype_tristate */ - @as("aria-pressed") ariaPressed?: [#"true" | #"false" | #mixed], - @as("aria-readonly") - ariaReadonly?: bool, - @as("aria-required") - ariaRequired?: bool, - @as("aria-selected") - ariaSelected?: bool, - @as("aria-sort") - ariaSort?: string, - @as("aria-valuemax") - ariaValuemax?: float, - @as("aria-valuemin") - ariaValuemin?: float, - @as("aria-valuenow") - ariaValuenow?: float, - @as("aria-valuetext") - ariaValuetext?: string, - /* Live Region Attributes */ - @as("aria-atomic") - ariaAtomic?: bool, - @as("aria-busy") - ariaBusy?: bool, - @as("aria-live") ariaLive?: [#off | #polite | #assertive | #rude], - @as("aria-relevant") - ariaRelevant?: string, - /* Drag-and-Drop Attributes */ - @as("aria-dropeffect") ariaDropeffect?: [#copy | #move | #link | #execute | #popup | #none], - @as("aria-grabbed") - ariaGrabbed?: bool, - /* Relationship Attributes */ - @as("aria-activedescendant") - ariaActivedescendant?: string, - @as("aria-colcount") - ariaColcount?: int, - @as("aria-colindex") - ariaColindex?: int, - @as("aria-colspan") - ariaColspan?: int, - @as("aria-controls") - ariaControls?: string, - @as("aria-describedby") - ariaDescribedby?: string, - @as("aria-errormessage") - ariaErrormessage?: string, - @as("aria-flowto") - ariaFlowto?: string, - @as("aria-labelledby") - ariaLabelledby?: string, - @as("aria-owns") - ariaOwns?: string, - @as("aria-posinset") - ariaPosinset?: int, - @as("aria-rowcount") - ariaRowcount?: int, - @as("aria-rowindex") - ariaRowindex?: int, - @as("aria-rowspan") - ariaRowspan?: int, - @as("aria-setsize") - ariaSetsize?: int, - /* react textarea/input */ - defaultChecked?: bool, - defaultValue?: string, - /* global html attributes */ - accessKey?: string, - className?: string /* substitute for "class" */, - contentEditable?: bool, - contextMenu?: string, - @as("data-testid") dataTestId?: string, - dir?: string /* "ltr", "rtl" or "auto" */, - draggable?: bool, - hidden?: bool, - id?: string, - lang?: string, - role?: string /* ARIA role */, - style?: style, - spellCheck?: bool, - tabIndex?: int, - title?: string, - /* html5 microdata */ - itemID?: string, - itemProp?: string, - itemRef?: string, - itemScope?: bool, - itemType?: string /* uri */, - /* tag-specific html attributes */ - accept?: string, - acceptCharset?: string, - action?: string /* uri */, - allowFullScreen?: bool, - alt?: string, - @as("as") - as_?: string, - async?: bool, - autoComplete?: string /* has a fixed, but large-ish, set of possible values */, - autoCapitalize?: string /* Mobile Safari specific */, - autoFocus?: bool, - autoPlay?: bool, - challenge?: string, - charSet?: string, - checked?: bool, - cite?: string /* uri */, - crossOrigin?: string /* anonymous, use-credentials */, - cols?: int, - colSpan?: int, - content?: string, - controls?: bool, - coords?: string /* set of values specifying the coordinates of a region */, - data?: string /* uri */, - dateTime?: string /* "valid date string with optional time" */, - default?: bool, - defer?: bool, - disabled?: bool, - download?: string /* should really be either a boolean, signifying presence, or a string */, - encType?: string /* "application/x-www-form-urlencoded", "multipart/form-data" or "text/plain" */, - form?: string, - formAction?: string /* uri */, - formTarget?: string /* "_blank", "_self", etc. */, - formMethod?: string /* "post", "get", "put" */, - headers?: string, - height?: string /* in html5 this can only be a number, but in html4 it can ba a percentage as well */, - high?: int, - href?: string /* uri */, - hrefLang?: string, - htmlFor?: string /* substitute for "for" */, - httpEquiv?: string /* has a fixed set of possible values */, - icon?: string /* uri? */, - inputMode?: string /* "verbatim", "latin", "numeric", etc. */, - integrity?: string, - keyType?: string, - kind?: string /* has a fixed set of possible values */, - label?: string, - list?: string, - loading?: [#"lazy" | #eager], - loop?: bool, - low?: int, - manifest?: string /* uri */, - max?: string /* should be int or Js.Date.t */, - maxLength?: int, - media?: string /* a valid media query */, - mediaGroup?: string, - method?: string /* "post" or "get" */, - min?: string, - minLength?: int, - multiple?: bool, - muted?: bool, - name?: string, - nonce?: string, - noValidate?: bool, - @as("open") - open_?: bool /* use this one. Previous one is deprecated */, - optimum?: int, - pattern?: string /* valid Js RegExp */, - placeholder?: string, - playsInline?: bool, - poster?: string /* uri */, - preload?: string /* "none", "metadata" or "auto" (and "" as a synonym for "auto") */, - radioGroup?: string, - readOnly?: bool, - rel?: string /* a space- or comma-separated (depending on the element) list of a fixed set of "link types" */, - required?: bool, - reversed?: bool, - rows?: int, - rowSpan?: int, - sandbox?: string /* has a fixed set of possible values */, - scope?: string /* has a fixed set of possible values */, - scoped?: bool, - scrolling?: string /* html4 only, "auto", "yes" or "no" */, - /* seamless - supported by React, but removed from the html5 spec */ - selected?: bool, - shape?: string, - size?: int, - sizes?: string, - span?: int, - src?: string /* uri */, - srcDoc?: string, - srcLang?: string, - srcSet?: string, - start?: int, - step?: float, - summary?: string /* deprecated */, - target?: string, - @as("type") - type_?: string /* has a fixed but large-ish set of possible values */ /* use this one. Previous one is deprecated */, - useMap?: string, - value?: string, - width?: string /* in html5 this can only be a number, but in html4 it can ba a percentage as well */, - wrap?: string /* "hard" or "soft" */, - /* Clipboard events */ - onCopy?: JsxEventC.Clipboard.t => unit, - onCut?: JsxEventC.Clipboard.t => unit, - onPaste?: JsxEventC.Clipboard.t => unit, - /* Composition events */ - onCompositionEnd?: JsxEventC.Composition.t => unit, - onCompositionStart?: JsxEventC.Composition.t => unit, - onCompositionUpdate?: JsxEventC.Composition.t => unit, - /* Keyboard events */ - onKeyDown?: JsxEventC.Keyboard.t => unit, - onKeyPress?: JsxEventC.Keyboard.t => unit, - onKeyUp?: JsxEventC.Keyboard.t => unit, - /* Focus events */ - onFocus?: JsxEventC.Focus.t => unit, - onBlur?: JsxEventC.Focus.t => unit, - /* Form events */ - onBeforeInput?: JsxEventC.Form.t => unit, - onChange?: JsxEventC.Form.t => unit, - onInput?: JsxEventC.Form.t => unit, - onReset?: JsxEventC.Form.t => unit, - onSubmit?: JsxEventC.Form.t => unit, - onInvalid?: JsxEventC.Form.t => unit, - /* Mouse events */ - onClick?: JsxEventC.Mouse.t => unit, - onContextMenu?: JsxEventC.Mouse.t => unit, - onDoubleClick?: JsxEventC.Mouse.t => unit, - onDrag?: JsxEventC.Mouse.t => unit, - onDragEnd?: JsxEventC.Mouse.t => unit, - onDragEnter?: JsxEventC.Mouse.t => unit, - onDragExit?: JsxEventC.Mouse.t => unit, - onDragLeave?: JsxEventC.Mouse.t => unit, - onDragOver?: JsxEventC.Mouse.t => unit, - onDragStart?: JsxEventC.Mouse.t => unit, - onDrop?: JsxEventC.Mouse.t => unit, - onMouseDown?: JsxEventC.Mouse.t => unit, - onMouseEnter?: JsxEventC.Mouse.t => unit, - onMouseLeave?: JsxEventC.Mouse.t => unit, - onMouseMove?: JsxEventC.Mouse.t => unit, - onMouseOut?: JsxEventC.Mouse.t => unit, - onMouseOver?: JsxEventC.Mouse.t => unit, - onMouseUp?: JsxEventC.Mouse.t => unit, - /* Selection events */ - onSelect?: JsxEventC.Selection.t => unit, - /* Touch events */ - onTouchCancel?: JsxEventC.Touch.t => unit, - onTouchEnd?: JsxEventC.Touch.t => unit, - onTouchMove?: JsxEventC.Touch.t => unit, - onTouchStart?: JsxEventC.Touch.t => unit, - // Pointer events - onPointerOver?: JsxEventC.Pointer.t => unit, - onPointerEnter?: JsxEventC.Pointer.t => unit, - onPointerDown?: JsxEventC.Pointer.t => unit, - onPointerMove?: JsxEventC.Pointer.t => unit, - onPointerUp?: JsxEventC.Pointer.t => unit, - onPointerCancel?: JsxEventC.Pointer.t => unit, - onPointerOut?: JsxEventC.Pointer.t => unit, - onPointerLeave?: JsxEventC.Pointer.t => unit, - onGotPointerCapture?: JsxEventC.Pointer.t => unit, - onLostPointerCapture?: JsxEventC.Pointer.t => unit, - /* UI events */ - onScroll?: JsxEventC.UI.t => unit, - /* Wheel events */ - onWheel?: JsxEventC.Wheel.t => unit, - /* Media events */ - onAbort?: JsxEventC.Media.t => unit, - onCanPlay?: JsxEventC.Media.t => unit, - onCanPlayThrough?: JsxEventC.Media.t => unit, - onDurationChange?: JsxEventC.Media.t => unit, - onEmptied?: JsxEventC.Media.t => unit, - onEncrypted?: JsxEventC.Media.t => unit, - onEnded?: JsxEventC.Media.t => unit, - onError?: JsxEventC.Media.t => unit, - onLoadedData?: JsxEventC.Media.t => unit, - onLoadedMetadata?: JsxEventC.Media.t => unit, - onLoadStart?: JsxEventC.Media.t => unit, - onPause?: JsxEventC.Media.t => unit, - onPlay?: JsxEventC.Media.t => unit, - onPlaying?: JsxEventC.Media.t => unit, - onProgress?: JsxEventC.Media.t => unit, - onRateChange?: JsxEventC.Media.t => unit, - onSeeked?: JsxEventC.Media.t => unit, - onSeeking?: JsxEventC.Media.t => unit, - onStalled?: JsxEventC.Media.t => unit, - onSuspend?: JsxEventC.Media.t => unit, - onTimeUpdate?: JsxEventC.Media.t => unit, - onVolumeChange?: JsxEventC.Media.t => unit, - onWaiting?: JsxEventC.Media.t => unit, - /* Image events */ - onLoad?: JsxEventC.Image.t => unit /* duplicate */ /* ~onError: ReactEvent.Image.t => unit=?, */, - /* Animation events */ - onAnimationStart?: JsxEventC.Animation.t => unit, - onAnimationEnd?: JsxEventC.Animation.t => unit, - onAnimationIteration?: JsxEventC.Animation.t => unit, - /* Transition events */ - onTransitionEnd?: JsxEventC.Transition.t => unit, - /* svg */ - accentHeight?: string, - accumulate?: string, - additive?: string, - alignmentBaseline?: string, - allowReorder?: string, - alphabetic?: string, - amplitude?: string, - arabicForm?: string, - ascent?: string, - attributeName?: string, - attributeType?: string, - autoReverse?: string, - azimuth?: string, - baseFrequency?: string, - baseProfile?: string, - baselineShift?: string, - bbox?: string, - begin?: string, - @deprecated("Please use begin") - begin_?: string, - bias?: string, - by?: string, - calcMode?: string, - capHeight?: string, - clip?: string, - clipPath?: string, - clipPathUnits?: string, - clipRule?: string, - colorInterpolation?: string, - colorInterpolationFilters?: string, - colorProfile?: string, - colorRendering?: string, - contentScriptType?: string, - contentStyleType?: string, - cursor?: string, - cx?: string, - cy?: string, - d?: string, - decelerate?: string, - descent?: string, - diffuseConstant?: string, - direction?: string, - display?: string, - divisor?: string, - dominantBaseline?: string, - dur?: string, - dx?: string, - dy?: string, - edgeMode?: string, - elevation?: string, - enableBackground?: string, - end?: string, - @deprecated("Please use end") - end_?: string, - exponent?: string, - externalResourcesRequired?: string, - fill?: string, - fillOpacity?: string, - fillRule?: string, - filter?: string, - filterRes?: string, - filterUnits?: string, - floodColor?: string, - floodOpacity?: string, - focusable?: string, - fontFamily?: string, - fontSize?: string, - fontSizeAdjust?: string, - fontStretch?: string, - fontStyle?: string, - fontVariant?: string, - fontWeight?: string, - fomat?: string, - from?: string, - fx?: string, - fy?: string, - g1?: string, - g2?: string, - glyphName?: string, - glyphOrientationHorizontal?: string, - glyphOrientationVertical?: string, - glyphRef?: string, - gradientTransform?: string, - gradientUnits?: string, - hanging?: string, - horizAdvX?: string, - horizOriginX?: string, - ideographic?: string, - imageRendering?: string, - @as("in") - in_?: string /* use this one. Previous one is deprecated */, - in2?: string, - intercept?: string, - k?: string, - k1?: string, - k2?: string, - k3?: string, - k4?: string, - kernelMatrix?: string, - kernelUnitLength?: string, - kerning?: string, - keyPoints?: string, - keySplines?: string, - keyTimes?: string, - lengthAdjust?: string, - letterSpacing?: string, - lightingColor?: string, - limitingConeAngle?: string, - local?: string, - markerEnd?: string, - markerHeight?: string, - markerMid?: string, - markerStart?: string, - markerUnits?: string, - markerWidth?: string, - mask?: string, - maskContentUnits?: string, - maskUnits?: string, - mathematical?: string, - mode?: string, - numOctaves?: string, - offset?: string, - opacity?: string, - operator?: string, - order?: string, - orient?: string, - orientation?: string, - origin?: string, - overflow?: string, - overflowX?: string, - overflowY?: string, - overlinePosition?: string, - overlineThickness?: string, - paintOrder?: string, - panose1?: string, - pathLength?: string, - patternContentUnits?: string, - patternTransform?: string, - patternUnits?: string, - pointerEvents?: string, - points?: string, - pointsAtX?: string, - pointsAtY?: string, - pointsAtZ?: string, - preserveAlpha?: string, - preserveAspectRatio?: string, - primitiveUnits?: string, - r?: string, - radius?: string, - refX?: string, - refY?: string, - renderingIntent?: string, - repeatCount?: string, - repeatDur?: string, - requiredExtensions?: string, - requiredFeatures?: string, - restart?: string, - result?: string, - rotate?: string, - rx?: string, - ry?: string, - scale?: string, - seed?: string, - shapeRendering?: string, - slope?: string, - spacing?: string, - specularConstant?: string, - specularExponent?: string, - speed?: string, - spreadMethod?: string, - startOffset?: string, - stdDeviation?: string, - stemh?: string, - stemv?: string, - stitchTiles?: string, - stopColor?: string, - stopOpacity?: string, - strikethroughPosition?: string, - strikethroughThickness?: string, - string?: string, - stroke?: string, - strokeDasharray?: string, - strokeDashoffset?: string, - strokeLinecap?: string, - strokeLinejoin?: string, - strokeMiterlimit?: string, - strokeOpacity?: string, - strokeWidth?: string, - surfaceScale?: string, - systemLanguage?: string, - tableValues?: string, - targetX?: string, - targetY?: string, - textAnchor?: string, - textDecoration?: string, - textLength?: string, - textRendering?: string, - to?: string, - @deprecated("Please use to") - to_?: string, - transform?: string, - u1?: string, - u2?: string, - underlinePosition?: string, - underlineThickness?: string, - unicode?: string, - unicodeBidi?: string, - unicodeRange?: string, - unitsPerEm?: string, - vAlphabetic?: string, - vHanging?: string, - vIdeographic?: string, - vMathematical?: string, - values?: string, - vectorEffect?: string, - version?: string, - vertAdvX?: string, - vertAdvY?: string, - vertOriginX?: string, - vertOriginY?: string, - viewBox?: string, - viewTarget?: string, - visibility?: string, - /* width::string? => */ - widths?: string, - wordSpacing?: string, - writingMode?: string, - x?: string, - x1?: string, - x2?: string, - xChannelSelector?: string, - xHeight?: string, - xlinkActuate?: string, - xlinkArcrole?: string, - xlinkHref?: string, - xlinkRole?: string, - xlinkShow?: string, - xlinkTitle?: string, - xlinkType?: string, - xmlns?: string, - xmlnsXlink?: string, - xmlBase?: string, - xmlLang?: string, - xmlSpace?: string, - y?: string, - y1?: string, - y2?: string, - yChannelSelector?: string, - z?: string, - zoomAndPan?: string, - /* RDFa */ - about?: string, - datatype?: string, - inlist?: string, - prefix?: string, - property?: string, - resource?: string, - typeof?: string, - vocab?: string, - /* react-specific */ - dangerouslySetInnerHTML?: {"__html": string}, - suppressContentEditableWarning?: bool, -} diff --git a/jscomp/others/jsxDOMStyle.res b/jscomp/others/jsxDOMStyle.res deleted file mode 100644 index 283607e..0000000 --- a/jscomp/others/jsxDOMStyle.res +++ /dev/null @@ -1,437 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t = { - azimuth?: string, - backdropFilter?: string, - background?: string, - backgroundAttachment?: string, - backgroundColor?: string, - backgroundImage?: string, - backgroundPosition?: string, - backgroundRepeat?: string, - border?: string, - borderCollapse?: string, - borderColor?: string, - borderSpacing?: string, - borderStyle?: string, - borderTop?: string, - borderRight?: string, - borderBottom?: string, - borderLeft?: string, - borderTopColor?: string, - borderRightColor?: string, - borderBottomColor?: string, - borderLeftColor?: string, - borderTopStyle?: string, - borderRightStyle?: string, - borderBottomStyle?: string, - borderLeftStyle?: string, - borderTopWidth?: string, - borderRightWidth?: string, - borderBottomWidth?: string, - borderLeftWidth?: string, - borderWidth?: string, - bottom?: string, - captionSide?: string, - clear?: string, - clip?: string, - color?: string, - content?: string, - counterIncrement?: string, - counterReset?: string, - cue?: string, - cueAfter?: string, - cueBefore?: string, - cursor?: string, - direction?: string, - display?: string, - elevation?: string, - emptyCells?: string, - float?: string, - font?: string, - fontFamily?: string, - fontSize?: string, - fontSizeAdjust?: string, - fontStretch?: string, - fontStyle?: string, - fontVariant?: string, - fontWeight?: string, - height?: string, - left?: string, - letterSpacing?: string, - lineHeight?: string, - listStyle?: string, - listStyleImage?: string, - listStylePosition?: string, - listStyleType?: string, - margin?: string, - marginTop?: string, - marginRight?: string, - marginBottom?: string, - marginLeft?: string, - markerOffset?: string, - marks?: string, - maxHeight?: string, - maxWidth?: string, - minHeight?: string, - minWidth?: string, - orphans?: string, - outline?: string, - outlineColor?: string, - outlineStyle?: string, - outlineWidth?: string, - overflow?: string, - overflowX?: string, - overflowY?: string, - padding?: string, - paddingTop?: string, - paddingRight?: string, - paddingBottom?: string, - paddingLeft?: string, - page?: string, - pageBreakAfter?: string, - pageBreakBefore?: string, - pageBreakInside?: string, - pause?: string, - pauseAfter?: string, - pauseBefore?: string, - pitch?: string, - pitchRange?: string, - playDuring?: string, - position?: string, - quotes?: string, - richness?: string, - right?: string, - size?: string, - speak?: string, - speakHeader?: string, - speakNumeral?: string, - speakPunctuation?: string, - speechRate?: string, - stress?: string, - tableLayout?: string, - textAlign?: string, - textDecoration?: string, - textIndent?: string, - textShadow?: string, - textTransform?: string, - top?: string, - unicodeBidi?: string, - verticalAlign?: string, - visibility?: string, - voiceFamily?: string, - volume?: string, - whiteSpace?: string, - widows?: string, - width?: string, - wordSpacing?: string, - zIndex?: string, - /* Below properties based on https://www.w3.org/Style/CSS/all-properties */ - /* Color Level 3 - REC */ - opacity?: string, - /* Backgrounds and Borders Level 3 - CR */ - /* backgroundRepeat - already defined by CSS2Properties */ - /* backgroundAttachment - already defined by CSS2Properties */ - backgroundOrigin?: string, - backgroundSize?: string, - backgroundClip?: string, - borderRadius?: string, - borderTopLeftRadius?: string, - borderTopRightRadius?: string, - borderBottomLeftRadius?: string, - borderBottomRightRadius?: string, - borderImage?: string, - borderImageSource?: string, - borderImageSlice?: string, - borderImageWidth?: string, - borderImageOutset?: string, - borderImageRepeat?: string, - boxShadow?: string, - columns?: string, - /* Multi-column Layout - CR */ - columnCount?: string, - columnFill?: string, - columnGap?: string, - columnRule?: string, - columnRuleColor?: string, - columnRuleStyle?: string, - columnRuleWidth?: string, - columnSpan?: string, - columnWidth?: string, - breakAfter?: string, - breakBefore?: string, - breakInside?: string, - rest?: string, - /* Speech - CR */ - restAfter?: string, - restBefore?: string, - speakAs?: string, - voiceBalance?: string, - voiceDuration?: string, - voicePitch?: string, - voiceRange?: string, - voiceRate?: string, - voiceStress?: string, - voiceVolume?: string, - objectFit?: string, - /* Image Values and Replaced Content Level 3 - CR */ - objectPosition?: string, - imageResolution?: string, - imageOrientation?: string, - alignContent?: string, - /* Flexible Box Layout - CR */ - alignItems?: string, - alignSelf?: string, - flex?: string, - flexBasis?: string, - flexDirection?: string, - flexFlow?: string, - flexGrow?: string, - flexShrink?: string, - flexWrap?: string, - justifyContent?: string, - order?: string, - gap?: string, - textDecorationColor?: string, - /* Text Decoration Level 3 - CR */ - /* textDecoration - already defined by CSS2Properties */ - textDecorationLine?: string, - textDecorationSkip?: string, - textDecorationStyle?: string, - textEmphasis?: string, - textEmphasisColor?: string, - textEmphasisPosition?: string, - textEmphasisStyle?: string, - textUnderlinePosition?: string, - /* textShadow - already defined by CSS2Properties */ - fontFeatureSettings?: string, - /* Fonts Level 3 - CR */ - fontKerning?: string, - fontLanguageOverride?: string, - fontSynthesis?: string, - /* fontSizeAdjust - already defined by CSS2Properties */ - /* fontStretch - already defined by CSS2Properties */ - forntVariantAlternates?: string, - fontVariantCaps?: string, - fontVariantEastAsian?: string, - fontVariantLigatures?: string, - fontVariantNumeric?: string, - fontVariantPosition?: string, - all?: string, - /* Cascading and Inheritance Level 3 - CR */ - glyphOrientationVertical?: string, - /* Writing Modes Level 3 - CR */ - textCombineUpright?: string, - textOrientation?: string, - writingMode?: string, - shapeImageThreshold?: string, - /* Shapes Level 1 - CR */ - shapeMargin?: string, - shapeOutside?: string, - clipPath?: string, - /* Masking Level 1 - CR */ - clipRule?: string, - mask?: string, - maskBorder?: string, - maskBorderMode?: string, - maskBorderOutset?: string, - maskBorderRepeat?: string, - maskBorderSlice?: string, - maskBorderSource?: string, - maskBorderWidth?: string, - maskClip?: string, - maskComposite?: string, - maskImage?: string, - maskMode?: string, - maskOrigin?: string, - maskPosition?: string, - maskRepeat?: string, - maskSize?: string, - maskType?: string, - backgroundBlendMode?: string, - /* Compositing and Blending Level 1 - CR */ - isolation?: string, - mixBlendMode?: string, - boxDecorationBreak?: string, - /* Fragmentation Level 3 - CR */ - boxSizing?: string, - /* breakAfter - already defined by Multi-column Layout */ - /* breakBefore - already defined by Multi-column Layout */ - /* breakInside - already defined by Multi-column Layout */ - /* Basic User Interface Level 3 - CR */ - caretColor?: string, - navDown?: string, - navLeft?: string, - navRight?: string, - navUp?: string, - outlineOffset?: string, - resize?: string, - textOverflow?: string, - grid?: string, - /* Grid Layout Level 1 - CR */ - gridArea?: string, - gridAutoColumns?: string, - gridAutoFlow?: string, - gridAutoRows?: string, - gridColumn?: string, - gridColumnEnd?: string, - gridColumnGap?: string, - gridColumnStart?: string, - gridGap?: string, - gridRow?: string, - gridRowEnd?: string, - gridRowGap?: string, - gridRowStart?: string, - gridTemplate?: string, - gridTemplateAreas?: string, - gridTemplateColumns?: string, - gridTemplateRows?: string, - willChange?: string, - /* Will Change Level 1 - CR */ - hangingPunctuation?: string, - /* Text Level 3 - LC */ - hyphens?: string, - lineBreak?: string, - /* letterSpacing - already defined by CSS2Properties */ - overflowWrap?: string, - tabSize?: string, - textAlignLast?: string, - /* textAlign - already defined by CSS2Properties */ - textJustify?: string, - wordBreak?: string, - wordWrap?: string, - animation?: string, - /* Animations - WD */ - animationDelay?: string, - animationDirection?: string, - animationDuration?: string, - animationFillMode?: string, - animationIterationCount?: string, - animationName?: string, - animationPlayState?: string, - animationTimingFunction?: string, - transition?: string, - /* Transitions - WD */ - transitionDelay?: string, - transitionDuration?: string, - transitionProperty?: string, - transitionTimingFunction?: string, - backfaceVisibility?: string, - /* Transforms Level 1 - WD */ - perspective?: string, - perspectiveOrigin?: string, - transform?: string, - transformOrigin?: string, - transformStyle?: string, - justifyItems?: string, - /* Box Alignment Level 3 - WD */ - /* alignContent - already defined by Flexible Box Layout */ - /* alignItems - already defined by Flexible Box Layout */ - justifySelf?: string, - placeContent?: string, - placeItems?: string, - placeSelf?: string, - appearance?: string, - /* Basic User Interface Level 4 - FPWD */ - caret?: string, - caretAnimation?: string, - caretShape?: string, - userSelect?: string, - maxLines?: string, - /* Overflow Level 3 - WD */ - marqueeDirection?: string, - /* Basix Box Model - WD */ - marqueeLoop?: string, - marqueeSpeed?: string, - marqueeStyle?: string, - overflowStyle?: string, - rotation?: string, - rotationPoint?: string, - alignmentBaseline?: string, - /* SVG 1.1 - REC */ - baselineShift?: string, - colorInterpolation?: string, - colorInterpolationFilters?: string, - colorProfile?: string, - colorRendering?: string, - dominantBaseline?: string, - fill?: string, - fillOpacity?: string, - fillRule?: string, - filter?: string, - floodColor?: string, - floodOpacity?: string, - glyphOrientationHorizontal?: string, - imageRendering?: string, - kerning?: string, - lightingColor?: string, - markerEnd?: string, - markerMid?: string, - markerStart?: string, - pointerEvents?: string, - shapeRendering?: string, - stopColor?: string, - stopOpacity?: string, - stroke?: string, - strokeDasharray?: string, - strokeDashoffset?: string, - strokeLinecap?: string, - strokeLinejoin?: string, - strokeMiterlimit?: string, - strokeOpacity?: string, - strokeWidth?: string, - textAnchor?: string, - textRendering?: string, - rubyAlign?: string, - /* Ruby Layout Level 1 - WD */ - rubyMerge?: string, - rubyPosition?: string, - /* Lists and Counters Level 3 - WD */ - /* listStyle - already defined by CSS2Properties */ - /* listStyleImage - already defined by CSS2Properties */ - /* listStylePosition - already defined by CSS2Properties */ - /* listStyleType - already defined by CSS2Properties */ - /* counterIncrement - already defined by CSS2Properties */ - /* counterReset - already defined by CSS2Properties */ - /* Not added yet - * ------------- - * Generated Content for Paged Media - WD - * Generated Content Level 3 - WD - * Line Grid Level 1 - WD - * Regions - WD - * Inline Layout Level 3 - WD - * Round Display Level 1 - WD - * Image Values and Replaced Content Level 4 - WD - * Positioned Layout Level 3 - WD - * Filter Effects Level 1 - -WD - * Exclusions Level 1 - WD - * Text Level 4 - FPWD - * SVG Markers - FPWD - * Motion Path Level 1 - FPWD - * Color Level 4 - FPWD - * SVG Strokes - FPWD - * Table Level 3 - FPWD - */ -} diff --git a/jscomp/others/jsxDOMU.res b/jscomp/others/jsxDOMU.res deleted file mode 100644 index a427376..0000000 --- a/jscomp/others/jsxDOMU.res +++ /dev/null @@ -1,624 +0,0 @@ -/* Copyright (C) 2022- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Internal: use JsxDOM directly. */ - -@@uncurried - -type style = JsxDOMStyle.t -type domRef - -/* - This list isn't exhaustive. We'll add more as we go. -*/ -type domProps = { - key?: string, - children?: JsxU.element, - ref?: domRef, - /* accessibility */ - /* https://www.w3.org/TR/wai-aria-1.1/ */ - /* https://accessibilityresources.org/ is a great resource for these */ - @as("aria-current") - ariaCurrent?: [#page | #step | #location | #date | #time | #"true" | #"false"], - @as("aria-details") - ariaDetails?: string, - @as("aria-disabled") - ariaDisabled?: bool, - @as("aria-hidden") - ariaHidden?: bool, - @as("aria-invalid") ariaInvalid?: [#grammar | #"false" | #spelling | #"true"], - @as("aria-keyshortcuts") - ariaKeyshortcuts?: string, - @as("aria-label") - ariaLabel?: string, - @as("aria-roledescription") - ariaRoledescription?: string, - /* Widget Attributes */ - @as("aria-autocomplete") ariaAutocomplete?: [#inline | #list | #both | #none], - /* https://www.w3.org/TR/wai-aria-1.1/#valuetype_tristate */ - @as("aria-checked") - ariaChecked?: [#"true" | #"false" | #mixed], - @as("aria-expanded") - ariaExpanded?: bool, - @as("aria-haspopup") - ariaHaspopup?: [#menu | #listbox | #tree | #grid | #dialog | #"true" | #"false"], - @as("aria-level") - ariaLevel?: int, - @as("aria-modal") - ariaModal?: bool, - @as("aria-multiline") - ariaMultiline?: bool, - @as("aria-multiselectable") - ariaMultiselectable?: bool, - @as("aria-orientation") ariaOrientation?: [#horizontal | #vertical | #undefined], - @as("aria-placeholder") - ariaPlaceholder?: string, - /* https://www.w3.org/TR/wai-aria-1.1/#valuetype_tristate */ - @as("aria-pressed") ariaPressed?: [#"true" | #"false" | #mixed], - @as("aria-readonly") - ariaReadonly?: bool, - @as("aria-required") - ariaRequired?: bool, - @as("aria-selected") - ariaSelected?: bool, - @as("aria-sort") - ariaSort?: string, - @as("aria-valuemax") - ariaValuemax?: float, - @as("aria-valuemin") - ariaValuemin?: float, - @as("aria-valuenow") - ariaValuenow?: float, - @as("aria-valuetext") - ariaValuetext?: string, - /* Live Region Attributes */ - @as("aria-atomic") - ariaAtomic?: bool, - @as("aria-busy") - ariaBusy?: bool, - @as("aria-live") ariaLive?: [#off | #polite | #assertive | #rude], - @as("aria-relevant") - ariaRelevant?: string, - /* Drag-and-Drop Attributes */ - @as("aria-dropeffect") ariaDropeffect?: [#copy | #move | #link | #execute | #popup | #none], - @as("aria-grabbed") - ariaGrabbed?: bool, - /* Relationship Attributes */ - @as("aria-activedescendant") - ariaActivedescendant?: string, - @as("aria-colcount") - ariaColcount?: int, - @as("aria-colindex") - ariaColindex?: int, - @as("aria-colspan") - ariaColspan?: int, - @as("aria-controls") - ariaControls?: string, - @as("aria-describedby") - ariaDescribedby?: string, - @as("aria-errormessage") - ariaErrormessage?: string, - @as("aria-flowto") - ariaFlowto?: string, - @as("aria-labelledby") - ariaLabelledby?: string, - @as("aria-owns") - ariaOwns?: string, - @as("aria-posinset") - ariaPosinset?: int, - @as("aria-rowcount") - ariaRowcount?: int, - @as("aria-rowindex") - ariaRowindex?: int, - @as("aria-rowspan") - ariaRowspan?: int, - @as("aria-setsize") - ariaSetsize?: int, - /* react textarea/input */ - defaultChecked?: bool, - defaultValue?: string, - /* global html attributes */ - accessKey?: string, - className?: string /* substitute for "class" */, - contentEditable?: bool, - contextMenu?: string, - @as("data-testid") dataTestId?: string, - dir?: string /* "ltr", "rtl" or "auto" */, - draggable?: bool, - hidden?: bool, - id?: string, - lang?: string, - role?: string /* ARIA role */, - style?: style, - spellCheck?: bool, - tabIndex?: int, - title?: string, - /* html5 microdata */ - itemID?: string, - itemProp?: string, - itemRef?: string, - itemScope?: bool, - itemType?: string /* uri */, - /* tag-specific html attributes */ - accept?: string, - acceptCharset?: string, - action?: string /* uri */, - allowFullScreen?: bool, - alt?: string, - @as("as") - as_?: string, - async?: bool, - autoComplete?: string /* has a fixed, but large-ish, set of possible values */, - autoCapitalize?: string /* Mobile Safari specific */, - autoFocus?: bool, - autoPlay?: bool, - challenge?: string, - charSet?: string, - checked?: bool, - cite?: string /* uri */, - crossOrigin?: string /* anonymous, use-credentials */, - cols?: int, - colSpan?: int, - content?: string, - controls?: bool, - coords?: string /* set of values specifying the coordinates of a region */, - data?: string /* uri */, - dateTime?: string /* "valid date string with optional time" */, - default?: bool, - defer?: bool, - disabled?: bool, - download?: string /* should really be either a boolean, signifying presence, or a string */, - encType?: string /* "application/x-www-form-urlencoded", "multipart/form-data" or "text/plain" */, - form?: string, - formAction?: string /* uri */, - formTarget?: string /* "_blank", "_self", etc. */, - formMethod?: string /* "post", "get", "put" */, - headers?: string, - height?: string /* in html5 this can only be a number, but in html4 it can ba a percentage as well */, - high?: int, - href?: string /* uri */, - hrefLang?: string, - htmlFor?: string /* substitute for "for" */, - httpEquiv?: string /* has a fixed set of possible values */, - icon?: string /* uri? */, - inputMode?: string /* "verbatim", "latin", "numeric", etc. */, - integrity?: string, - keyType?: string, - kind?: string /* has a fixed set of possible values */, - label?: string, - list?: string, - loading?: [#"lazy" | #eager], - loop?: bool, - low?: int, - manifest?: string /* uri */, - max?: string /* should be int or Js.Date.t */, - maxLength?: int, - media?: string /* a valid media query */, - mediaGroup?: string, - method?: string /* "post" or "get" */, - min?: string, - minLength?: int, - multiple?: bool, - muted?: bool, - name?: string, - nonce?: string, - noValidate?: bool, - @as("open") - open_?: bool /* use this one. Previous one is deprecated */, - optimum?: int, - pattern?: string /* valid Js RegExp */, - placeholder?: string, - playsInline?: bool, - poster?: string /* uri */, - preload?: string /* "none", "metadata" or "auto" (and "" as a synonym for "auto") */, - radioGroup?: string, - readOnly?: bool, - rel?: string /* a space- or comma-separated (depending on the element) list of a fixed set of "link types" */, - required?: bool, - reversed?: bool, - rows?: int, - rowSpan?: int, - sandbox?: string /* has a fixed set of possible values */, - scope?: string /* has a fixed set of possible values */, - scoped?: bool, - scrolling?: string /* html4 only, "auto", "yes" or "no" */, - /* seamless - supported by React, but removed from the html5 spec */ - selected?: bool, - shape?: string, - size?: int, - sizes?: string, - span?: int, - src?: string /* uri */, - srcDoc?: string, - srcLang?: string, - srcSet?: string, - start?: int, - step?: float, - summary?: string /* deprecated */, - target?: string, - @as("type") - type_?: string /* has a fixed but large-ish set of possible values */ /* use this one. Previous one is deprecated */, - useMap?: string, - value?: string, - width?: string /* in html5 this can only be a number, but in html4 it can ba a percentage as well */, - wrap?: string /* "hard" or "soft" */, - /* Clipboard events */ - onCopy?: JsxEventU.Clipboard.t => unit, - onCut?: JsxEventU.Clipboard.t => unit, - onPaste?: JsxEventU.Clipboard.t => unit, - /* Composition events */ - onCompositionEnd?: JsxEventU.Composition.t => unit, - onCompositionStart?: JsxEventU.Composition.t => unit, - onCompositionUpdate?: JsxEventU.Composition.t => unit, - /* Keyboard events */ - onKeyDown?: JsxEventU.Keyboard.t => unit, - onKeyPress?: JsxEventU.Keyboard.t => unit, - onKeyUp?: JsxEventU.Keyboard.t => unit, - /* Focus events */ - onFocus?: JsxEventU.Focus.t => unit, - onBlur?: JsxEventU.Focus.t => unit, - /* Form events */ - onBeforeInput?: JsxEventU.Form.t => unit, - onChange?: JsxEventU.Form.t => unit, - onInput?: JsxEventU.Form.t => unit, - onReset?: JsxEventU.Form.t => unit, - onSubmit?: JsxEventU.Form.t => unit, - onInvalid?: JsxEventU.Form.t => unit, - /* Mouse events */ - onClick?: JsxEventU.Mouse.t => unit, - onContextMenu?: JsxEventU.Mouse.t => unit, - onDoubleClick?: JsxEventU.Mouse.t => unit, - onDrag?: JsxEventU.Mouse.t => unit, - onDragEnd?: JsxEventU.Mouse.t => unit, - onDragEnter?: JsxEventU.Mouse.t => unit, - onDragExit?: JsxEventU.Mouse.t => unit, - onDragLeave?: JsxEventU.Mouse.t => unit, - onDragOver?: JsxEventU.Mouse.t => unit, - onDragStart?: JsxEventU.Mouse.t => unit, - onDrop?: JsxEventU.Mouse.t => unit, - onMouseDown?: JsxEventU.Mouse.t => unit, - onMouseEnter?: JsxEventU.Mouse.t => unit, - onMouseLeave?: JsxEventU.Mouse.t => unit, - onMouseMove?: JsxEventU.Mouse.t => unit, - onMouseOut?: JsxEventU.Mouse.t => unit, - onMouseOver?: JsxEventU.Mouse.t => unit, - onMouseUp?: JsxEventU.Mouse.t => unit, - /* Selection events */ - onSelect?: JsxEventU.Selection.t => unit, - /* Touch events */ - onTouchCancel?: JsxEventU.Touch.t => unit, - onTouchEnd?: JsxEventU.Touch.t => unit, - onTouchMove?: JsxEventU.Touch.t => unit, - onTouchStart?: JsxEventU.Touch.t => unit, - // Pointer events - onPointerOver?: JsxEventU.Pointer.t => unit, - onPointerEnter?: JsxEventU.Pointer.t => unit, - onPointerDown?: JsxEventU.Pointer.t => unit, - onPointerMove?: JsxEventU.Pointer.t => unit, - onPointerUp?: JsxEventU.Pointer.t => unit, - onPointerCancel?: JsxEventU.Pointer.t => unit, - onPointerOut?: JsxEventU.Pointer.t => unit, - onPointerLeave?: JsxEventU.Pointer.t => unit, - onGotPointerCapture?: JsxEventU.Pointer.t => unit, - onLostPointerCapture?: JsxEventU.Pointer.t => unit, - /* UI events */ - onScroll?: JsxEventU.UI.t => unit, - /* Wheel events */ - onWheel?: JsxEventU.Wheel.t => unit, - /* Media events */ - onAbort?: JsxEventU.Media.t => unit, - onCanPlay?: JsxEventU.Media.t => unit, - onCanPlayThrough?: JsxEventU.Media.t => unit, - onDurationChange?: JsxEventU.Media.t => unit, - onEmptied?: JsxEventU.Media.t => unit, - onEncrypted?: JsxEventU.Media.t => unit, - onEnded?: JsxEventU.Media.t => unit, - onError?: JsxEventU.Media.t => unit, - onLoadedData?: JsxEventU.Media.t => unit, - onLoadedMetadata?: JsxEventU.Media.t => unit, - onLoadStart?: JsxEventU.Media.t => unit, - onPause?: JsxEventU.Media.t => unit, - onPlay?: JsxEventU.Media.t => unit, - onPlaying?: JsxEventU.Media.t => unit, - onProgress?: JsxEventU.Media.t => unit, - onRateChange?: JsxEventU.Media.t => unit, - onSeeked?: JsxEventU.Media.t => unit, - onSeeking?: JsxEventU.Media.t => unit, - onStalled?: JsxEventU.Media.t => unit, - onSuspend?: JsxEventU.Media.t => unit, - onTimeUpdate?: JsxEventU.Media.t => unit, - onVolumeChange?: JsxEventU.Media.t => unit, - onWaiting?: JsxEventU.Media.t => unit, - /* Image events */ - onLoad?: JsxEventU.Image.t => unit /* duplicate */ /* ~onError: ReactEvent.Image.t => unit=?, */, - /* Animation events */ - onAnimationStart?: JsxEventU.Animation.t => unit, - onAnimationEnd?: JsxEventU.Animation.t => unit, - onAnimationIteration?: JsxEventU.Animation.t => unit, - /* Transition events */ - onTransitionEnd?: JsxEventU.Transition.t => unit, - /* svg */ - accentHeight?: string, - accumulate?: string, - additive?: string, - alignmentBaseline?: string, - allowReorder?: string, - alphabetic?: string, - amplitude?: string, - arabicForm?: string, - ascent?: string, - attributeName?: string, - attributeType?: string, - autoReverse?: string, - azimuth?: string, - baseFrequency?: string, - baseProfile?: string, - baselineShift?: string, - bbox?: string, - begin?: string, - @deprecated("Please use begin") - begin_?: string, - bias?: string, - by?: string, - calcMode?: string, - capHeight?: string, - clip?: string, - clipPath?: string, - clipPathUnits?: string, - clipRule?: string, - colorInterpolation?: string, - colorInterpolationFilters?: string, - colorProfile?: string, - colorRendering?: string, - contentScriptType?: string, - contentStyleType?: string, - cursor?: string, - cx?: string, - cy?: string, - d?: string, - decelerate?: string, - descent?: string, - diffuseConstant?: string, - direction?: string, - display?: string, - divisor?: string, - dominantBaseline?: string, - dur?: string, - dx?: string, - dy?: string, - edgeMode?: string, - elevation?: string, - enableBackground?: string, - end?: string, - @deprecated("Please use end") - end_?: string, - exponent?: string, - externalResourcesRequired?: string, - fill?: string, - fillOpacity?: string, - fillRule?: string, - filter?: string, - filterRes?: string, - filterUnits?: string, - floodColor?: string, - floodOpacity?: string, - focusable?: string, - fontFamily?: string, - fontSize?: string, - fontSizeAdjust?: string, - fontStretch?: string, - fontStyle?: string, - fontVariant?: string, - fontWeight?: string, - fomat?: string, - from?: string, - fx?: string, - fy?: string, - g1?: string, - g2?: string, - glyphName?: string, - glyphOrientationHorizontal?: string, - glyphOrientationVertical?: string, - glyphRef?: string, - gradientTransform?: string, - gradientUnits?: string, - hanging?: string, - horizAdvX?: string, - horizOriginX?: string, - ideographic?: string, - imageRendering?: string, - @as("in") - in_?: string /* use this one. Previous one is deprecated */, - in2?: string, - intercept?: string, - k?: string, - k1?: string, - k2?: string, - k3?: string, - k4?: string, - kernelMatrix?: string, - kernelUnitLength?: string, - kerning?: string, - keyPoints?: string, - keySplines?: string, - keyTimes?: string, - lengthAdjust?: string, - letterSpacing?: string, - lightingColor?: string, - limitingConeAngle?: string, - local?: string, - markerEnd?: string, - markerHeight?: string, - markerMid?: string, - markerStart?: string, - markerUnits?: string, - markerWidth?: string, - mask?: string, - maskContentUnits?: string, - maskUnits?: string, - mathematical?: string, - mode?: string, - numOctaves?: string, - offset?: string, - opacity?: string, - operator?: string, - order?: string, - orient?: string, - orientation?: string, - origin?: string, - overflow?: string, - overflowX?: string, - overflowY?: string, - overlinePosition?: string, - overlineThickness?: string, - paintOrder?: string, - panose1?: string, - pathLength?: string, - patternContentUnits?: string, - patternTransform?: string, - patternUnits?: string, - pointerEvents?: string, - points?: string, - pointsAtX?: string, - pointsAtY?: string, - pointsAtZ?: string, - preserveAlpha?: string, - preserveAspectRatio?: string, - primitiveUnits?: string, - r?: string, - radius?: string, - refX?: string, - refY?: string, - renderingIntent?: string, - repeatCount?: string, - repeatDur?: string, - requiredExtensions?: string, - requiredFeatures?: string, - restart?: string, - result?: string, - rotate?: string, - rx?: string, - ry?: string, - scale?: string, - seed?: string, - shapeRendering?: string, - slope?: string, - spacing?: string, - specularConstant?: string, - specularExponent?: string, - speed?: string, - spreadMethod?: string, - startOffset?: string, - stdDeviation?: string, - stemh?: string, - stemv?: string, - stitchTiles?: string, - stopColor?: string, - stopOpacity?: string, - strikethroughPosition?: string, - strikethroughThickness?: string, - string?: string, - stroke?: string, - strokeDasharray?: string, - strokeDashoffset?: string, - strokeLinecap?: string, - strokeLinejoin?: string, - strokeMiterlimit?: string, - strokeOpacity?: string, - strokeWidth?: string, - surfaceScale?: string, - systemLanguage?: string, - tableValues?: string, - targetX?: string, - targetY?: string, - textAnchor?: string, - textDecoration?: string, - textLength?: string, - textRendering?: string, - to?: string, - @deprecated("Please use to") - to_?: string, - transform?: string, - u1?: string, - u2?: string, - underlinePosition?: string, - underlineThickness?: string, - unicode?: string, - unicodeBidi?: string, - unicodeRange?: string, - unitsPerEm?: string, - vAlphabetic?: string, - vHanging?: string, - vIdeographic?: string, - vMathematical?: string, - values?: string, - vectorEffect?: string, - version?: string, - vertAdvX?: string, - vertAdvY?: string, - vertOriginX?: string, - vertOriginY?: string, - viewBox?: string, - viewTarget?: string, - visibility?: string, - /* width::string? => */ - widths?: string, - wordSpacing?: string, - writingMode?: string, - x?: string, - x1?: string, - x2?: string, - xChannelSelector?: string, - xHeight?: string, - xlinkActuate?: string, - xlinkArcrole?: string, - xlinkHref?: string, - xlinkRole?: string, - xlinkShow?: string, - xlinkTitle?: string, - xlinkType?: string, - xmlns?: string, - xmlnsXlink?: string, - xmlBase?: string, - xmlLang?: string, - xmlSpace?: string, - y?: string, - y1?: string, - y2?: string, - yChannelSelector?: string, - z?: string, - zoomAndPan?: string, - /* RDFa */ - about?: string, - datatype?: string, - inlist?: string, - prefix?: string, - property?: string, - resource?: string, - typeof?: string, - vocab?: string, - /* react-specific */ - dangerouslySetInnerHTML?: {"__html": string}, - suppressContentEditableWarning?: bool, -} diff --git a/jscomp/others/jsxEventC.res b/jscomp/others/jsxEventC.res deleted file mode 100644 index 89fe51d..0000000 --- a/jscomp/others/jsxEventC.res +++ /dev/null @@ -1,348 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Internal: use JsxEvent directly. */ - -type synthetic<'a> - -module MakeEventWithType = ( - Type: { - type t - }, -) => { - @get external bubbles: Type.t => bool = "bubbles" - @get external cancelable: Type.t => bool = "cancelable" - @get external currentTarget: Type.t => {..} = "currentTarget" - - /* Should return Dom.eventTarget */ - @get external defaultPrevented: Type.t => bool = "defaultPrevented" - @get external eventPhase: Type.t => int = "eventPhase" - @get external isTrusted: Type.t => bool = "isTrusted" - @get external nativeEvent: Type.t => {..} = "nativeEvent" - - /* Should return Dom.event */ - @send external preventDefault: Type.t => unit = "preventDefault" - - @send external isDefaultPrevented: Type.t => bool = "isDefaultPrevented" - - @send external stopPropagation: Type.t => unit = "stopPropagation" - - @send external isPropagationStopped: Type.t => bool = "isPropagationStopped" - - @get external target: Type.t => {..} = "target" - - /* Should return Dom.eventTarget */ - @get external timeStamp: Type.t => float = "timeStamp" - @get external type_: Type.t => string = "type" - @send external persist: Type.t => unit = "persist" -} - -module Synthetic = { - type tag - type t = synthetic - - @get external bubbles: synthetic<'a> => bool = "bubbles" - @get external cancelable: synthetic<'a> => bool = "cancelable" - @get external currentTarget: synthetic<'a> => {..} = "currentTarget" - /* Should return Dom.eventTarget */ - - @get external defaultPrevented: synthetic<'a> => bool = "defaultPrevented" - - @get external eventPhase: synthetic<'a> => int = "eventPhase" - @get external isTrusted: synthetic<'a> => bool = "isTrusted" - @get external nativeEvent: synthetic<'a> => {..} = "nativeEvent" - - /* Should return Dom.event */ - @send external preventDefault: synthetic<'a> => unit = "preventDefault" - - @send external isDefaultPrevented: synthetic<'a> => bool = "isDefaultPrevented" - - @send external stopPropagation: synthetic<'a> => unit = "stopPropagation" - - @send external isPropagationStopped: synthetic<'a> => bool = "isPropagationStopped" - - @get external target: synthetic<'a> => {..} = "target" - - /* Should return Dom.eventTarget */ - @get external timeStamp: synthetic<'a> => float = "timeStamp" - @get external type_: synthetic<'a> => string = "type" - @send external persist: synthetic<'a> => unit = "persist" -} - -/* Cast any event type to the general synthetic type. This is safe, since synthetic is more general */ -external toSyntheticEvent: synthetic<'a> => Synthetic.t = "%identity" - -module Clipboard = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external clipboardData: t => {..} = "clipboardData" - /* Should return Dom.dataTransfer */ -} - -module Composition = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external data: t => string = "data" -} - -module Keyboard = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external altKey: t => bool = "altKey" - @get external charCode: t => int = "charCode" - @get external ctrlKey: t => bool = "ctrlKey" - - @send external getModifierState: (t, string) => bool = "getModifierState" - - @get external key: t => string = "key" - @get external keyCode: t => int = "keyCode" - @get external locale: t => string = "locale" - @get external location: t => int = "location" - @get external metaKey: t => bool = "metaKey" - @get external repeat: t => bool = "repeat" - @get external shiftKey: t => bool = "shiftKey" - @get external which: t => int = "which" -} - -module Focus = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get @return(nullable) external relatedTarget: t => option<{..}> = "relatedTarget" - /* Should return Dom.eventTarget */ -} - -module Form = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Mouse = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external altKey: t => bool = "altKey" - @get external button: t => int = "button" - @get external buttons: t => int = "buttons" - @get external clientX: t => int = "clientX" - @get external clientY: t => int = "clientY" - @get external ctrlKey: t => bool = "ctrlKey" - - @get external getModifierState: (t => string) => bool = "getModifierState" - - @get external metaKey: t => bool = "metaKey" - @get external movementX: t => int = "movementX" - @get external movementY: t => int = "movementY" - @get external pageX: t => int = "pageX" - @get external pageY: t => int = "pageY" - - @get @return(nullable) external relatedTarget: t => option<{..}> = "relatedTarget" - - /* Should return Dom.eventTarget */ - @get external screenX: t => int = "screenX" - @get external screenY: t => int = "screenY" - @get external shiftKey: t => bool = "shiftKey" -} - -module Pointer = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - /* UIEvent */ - @get @get - external detail: t => int = "detail" - - /* external view : t -> Dom.window = "view" */ - /* Should return DOMAbstractView/WindowProxy */ - - /* MouseEvent */ - @get external screenX: t => int = "screenX" - @get external screenY: t => int = "screenY" - @get external clientX: t => int = "clientX" - @get external clientY: t => int = "clientY" - @get external pageX: t => int = "pageX" - @get external pageY: t => int = "pageY" - @get external movementX: t => int = "movementX" - @get external movementY: t => int = "movementY" - @get external ctrlKey: t => bool = "ctrlKey" - @get external shiftKey: t => bool = "shiftKey" - @get external altKey: t => bool = "altKey" - @get external metaKey: t => bool = "metaKey" - - @get external getModifierState: (t => string) => bool = "getModifierState" - - @get external button: t => int = "button" - @get external buttons: t => int = "buttons" - - @get @return(nullable) external relatedTarget: t => option<{..}> = "relatedTarget" - /* Should return Dom.eventTarget */ - - /* PointerEvent */ - /* external pointerId : t -> Dom.eventPointerId = "pointerId" [@@bs.get] */ - @get external width: t => float = "width" - @get external height: t => float = "height" - @get external pressure: t => float = "pressure" - @get external tangentialPressure: t => float = "tangentialPressure" - @get external tiltX: t => int = "tiltX" - @get external tiltY: t => int = "tiltY" - @get external twist: t => int = "twist" - @get external pointerType: t => string = "pointerType" - @get external isPrimary: t => bool = "isPrimary" -} - -module Selection = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Touch = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external altKey: t => bool = "altKey" - @get external changedTouches: t => {..} = "changedTouches" - /* Should return Dom.touchList */ - - @get external ctrlKey: t => bool = "ctrlKey" - - @send external getModifierState: (t => string) => bool = "getModifierState" - - @get external metaKey: t => bool = "metaKey" - @get external shiftKey: t => bool = "shiftKey" - @get external targetTouches: t => {..} = "targetTouches" - /* Should return Dom.touchList */ - - @get external touches: t => {..} = "touches" - /* Should return Dom.touchList */ -} - -module UI = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external detail: t => int = "detail" - /* external view : t -> Dom.window = "view" [@@bs.get] */ - /* Should return DOMAbstractView/WindowProxy */ -} - -module Wheel = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external deltaMode: t => int = "deltaMode" - @get external deltaX: t => float = "deltaX" - @get external deltaY: t => float = "deltaY" - @get external deltaZ: t => float = "deltaZ" -} - -module Media = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Image = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Animation = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external animationName: t => string = "animationName" - @get external pseudoElement: t => string = "pseudoElement" - @get external elapsedTime: t => float = "elapsedTime" -} - -module Transition = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external propertyName: t => string = "propertyName" - @get external pseudoElement: t => string = "pseudoElement" - @get external elapsedTime: t => float = "elapsedTime" -} diff --git a/jscomp/others/jsxEventU.res b/jscomp/others/jsxEventU.res deleted file mode 100644 index 449032f..0000000 --- a/jscomp/others/jsxEventU.res +++ /dev/null @@ -1,350 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** Internal: use JsxEvent directly. */ - -@@uncurried - -type synthetic<'a> - -module MakeEventWithType = ( - Type: { - type t - }, -) => { - @get external bubbles: Type.t => bool = "bubbles" - @get external cancelable: Type.t => bool = "cancelable" - @get external currentTarget: Type.t => {..} = "currentTarget" - - /* Should return Dom.eventTarget */ - @get external defaultPrevented: Type.t => bool = "defaultPrevented" - @get external eventPhase: Type.t => int = "eventPhase" - @get external isTrusted: Type.t => bool = "isTrusted" - @get external nativeEvent: Type.t => {..} = "nativeEvent" - - /* Should return Dom.event */ - @send external preventDefault: Type.t => unit = "preventDefault" - - @send external isDefaultPrevented: Type.t => bool = "isDefaultPrevented" - - @send external stopPropagation: Type.t => unit = "stopPropagation" - - @send external isPropagationStopped: Type.t => bool = "isPropagationStopped" - - @get external target: Type.t => {..} = "target" - - /* Should return Dom.eventTarget */ - @get external timeStamp: Type.t => float = "timeStamp" - @get external type_: Type.t => string = "type" - @send external persist: Type.t => unit = "persist" -} - -module Synthetic = { - type tag - type t = synthetic - - @get external bubbles: synthetic<'a> => bool = "bubbles" - @get external cancelable: synthetic<'a> => bool = "cancelable" - @get external currentTarget: synthetic<'a> => {..} = "currentTarget" - /* Should return Dom.eventTarget */ - - @get external defaultPrevented: synthetic<'a> => bool = "defaultPrevented" - - @get external eventPhase: synthetic<'a> => int = "eventPhase" - @get external isTrusted: synthetic<'a> => bool = "isTrusted" - @get external nativeEvent: synthetic<'a> => {..} = "nativeEvent" - - /* Should return Dom.event */ - @send external preventDefault: synthetic<'a> => unit = "preventDefault" - - @send external isDefaultPrevented: synthetic<'a> => bool = "isDefaultPrevented" - - @send external stopPropagation: synthetic<'a> => unit = "stopPropagation" - - @send external isPropagationStopped: synthetic<'a> => bool = "isPropagationStopped" - - @get external target: synthetic<'a> => {..} = "target" - - /* Should return Dom.eventTarget */ - @get external timeStamp: synthetic<'a> => float = "timeStamp" - @get external type_: synthetic<'a> => string = "type" - @send external persist: synthetic<'a> => unit = "persist" -} - -/* Cast any event type to the general synthetic type. This is safe, since synthetic is more general */ -external toSyntheticEvent: synthetic<'a> => Synthetic.t = "%identity" - -module Clipboard = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external clipboardData: t => {..} = "clipboardData" - /* Should return Dom.dataTransfer */ -} - -module Composition = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external data: t => string = "data" -} - -module Keyboard = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external altKey: t => bool = "altKey" - @get external charCode: t => int = "charCode" - @get external ctrlKey: t => bool = "ctrlKey" - - @send external getModifierState: (t, string) => bool = "getModifierState" - - @get external key: t => string = "key" - @get external keyCode: t => int = "keyCode" - @get external locale: t => string = "locale" - @get external location: t => int = "location" - @get external metaKey: t => bool = "metaKey" - @get external repeat: t => bool = "repeat" - @get external shiftKey: t => bool = "shiftKey" - @get external which: t => int = "which" -} - -module Focus = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get @return(nullable) external relatedTarget: t => option<{..}> = "relatedTarget" - /* Should return Dom.eventTarget */ -} - -module Form = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Mouse = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external altKey: t => bool = "altKey" - @get external button: t => int = "button" - @get external buttons: t => int = "buttons" - @get external clientX: t => int = "clientX" - @get external clientY: t => int = "clientY" - @get external ctrlKey: t => bool = "ctrlKey" - - @get external getModifierState: (t => string) => bool = "getModifierState" - - @get external metaKey: t => bool = "metaKey" - @get external movementX: t => int = "movementX" - @get external movementY: t => int = "movementY" - @get external pageX: t => int = "pageX" - @get external pageY: t => int = "pageY" - - @get @return(nullable) external relatedTarget: t => option<{..}> = "relatedTarget" - - /* Should return Dom.eventTarget */ - @get external screenX: t => int = "screenX" - @get external screenY: t => int = "screenY" - @get external shiftKey: t => bool = "shiftKey" -} - -module Pointer = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - /* UIEvent */ - @get @get - external detail: t => int = "detail" - - /* external view : t -> Dom.window = "view" */ - /* Should return DOMAbstractView/WindowProxy */ - - /* MouseEvent */ - @get external screenX: t => int = "screenX" - @get external screenY: t => int = "screenY" - @get external clientX: t => int = "clientX" - @get external clientY: t => int = "clientY" - @get external pageX: t => int = "pageX" - @get external pageY: t => int = "pageY" - @get external movementX: t => int = "movementX" - @get external movementY: t => int = "movementY" - @get external ctrlKey: t => bool = "ctrlKey" - @get external shiftKey: t => bool = "shiftKey" - @get external altKey: t => bool = "altKey" - @get external metaKey: t => bool = "metaKey" - - @get external getModifierState: (t => string) => bool = "getModifierState" - - @get external button: t => int = "button" - @get external buttons: t => int = "buttons" - - @get @return(nullable) external relatedTarget: t => option<{..}> = "relatedTarget" - /* Should return Dom.eventTarget */ - - /* PointerEvent */ - /* external pointerId : t -> Dom.eventPointerId = "pointerId" [@@bs.get] */ - @get external width: t => float = "width" - @get external height: t => float = "height" - @get external pressure: t => float = "pressure" - @get external tangentialPressure: t => float = "tangentialPressure" - @get external tiltX: t => int = "tiltX" - @get external tiltY: t => int = "tiltY" - @get external twist: t => int = "twist" - @get external pointerType: t => string = "pointerType" - @get external isPrimary: t => bool = "isPrimary" -} - -module Selection = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Touch = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external altKey: t => bool = "altKey" - @get external changedTouches: t => {..} = "changedTouches" - /* Should return Dom.touchList */ - - @get external ctrlKey: t => bool = "ctrlKey" - - @send external getModifierState: (t => string) => bool = "getModifierState" - - @get external metaKey: t => bool = "metaKey" - @get external shiftKey: t => bool = "shiftKey" - @get external targetTouches: t => {..} = "targetTouches" - /* Should return Dom.touchList */ - - @get external touches: t => {..} = "touches" - /* Should return Dom.touchList */ -} - -module UI = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external detail: t => int = "detail" - /* external view : t -> Dom.window = "view" [@@bs.get] */ - /* Should return DOMAbstractView/WindowProxy */ -} - -module Wheel = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external deltaMode: t => int = "deltaMode" - @get external deltaX: t => float = "deltaX" - @get external deltaY: t => float = "deltaY" - @get external deltaZ: t => float = "deltaZ" -} - -module Media = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Image = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) -} - -module Animation = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external animationName: t => string = "animationName" - @get external pseudoElement: t => string = "pseudoElement" - @get external elapsedTime: t => float = "elapsedTime" -} - -module Transition = { - type tag - type t = synthetic - - include MakeEventWithType({ - type t = t - }) - - @get external propertyName: t => string = "propertyName" - @get external pseudoElement: t => string = "pseudoElement" - @get external elapsedTime: t => float = "elapsedTime" -} diff --git a/jscomp/others/jsxPPXReactSupportC.res b/jscomp/others/jsxPPXReactSupportC.res deleted file mode 100644 index a024d44..0000000 --- a/jscomp/others/jsxPPXReactSupportC.res +++ /dev/null @@ -1,52 +0,0 @@ -/* Copyright (C) 2022- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Jsx = JsxC - -%%private( - @val - external propsWithKey: ({"key": string}, 'props) => 'props = "Object.assign" - - @inline - let addKeyProp = (~key: option=?, p: 'props): 'props => - switch key { - | Some(key) => propsWithKey({"key": key}, p) - | None => p - } -) - -@module("react") -external createElement: (Jsx.component<'props>, 'props) => Jsx.element = "createElement" - -@variadic @module("react") -external createElementVariadic: (Jsx.component<'props>, 'props, array) => Jsx.element = - "createElement" - -let createElementWithKey = (~key=?, component, props) => - createElement(component, addKeyProp(~key?, props)) - -let createElementVariadicWithKey = (~key=?, component, props, elements) => - createElementVariadic(component, addKeyProp(~key?, props), elements) - -external asyncComponent: promise => Jsx.element = "%identity" diff --git a/jscomp/others/jsxPPXReactSupportU.res b/jscomp/others/jsxPPXReactSupportU.res deleted file mode 100644 index a850efc..0000000 --- a/jscomp/others/jsxPPXReactSupportU.res +++ /dev/null @@ -1,54 +0,0 @@ -/* Copyright (C) 2022- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Jsx = JsxU - -%%private( - @val - external propsWithKey: ({"key": string}, 'props) => 'props = "Object.assign" - - @inline - let addKeyProp = (~key: option=?, p: 'props): 'props => - switch key { - | Some(key) => propsWithKey({"key": key}, p) - | None => p - } -) - -@@uncurried // Can't move this up as @inline not working with uncurried - -@module("react") -external createElement: (Jsx.component<'props>, 'props) => Jsx.element = "createElement" - -@variadic @module("react") -external createElementVariadic: (Jsx.component<'props>, 'props, array) => Jsx.element = - "createElement" - -let createElementWithKey = (~key=?, component, props) => - createElement(component, addKeyProp(~key?, props)) - -let createElementVariadicWithKey = (~key=?, component, props, elements) => - createElementVariadic(component, addKeyProp(~key?, props), elements) - -external asyncComponent: promise => Jsx.element = "%identity" diff --git a/jscomp/others/jsxU.res b/jscomp/others/jsxU.res deleted file mode 100644 index 70f3c67..0000000 --- a/jscomp/others/jsxU.res +++ /dev/null @@ -1,20 +0,0 @@ -/*** Internal: use Jsx directly. */ - -@@uncurried - -type element -type ref - -@val external null: element = "null" - -external float: float => element = "%identity" -external int: int => element = "%identity" -external string: string => element = "%identity" - -external array: array => element = "%identity" - -type componentLike<'props, 'return> = 'props => 'return -type component<'props> = componentLike<'props, element> - -/* this function exists to prepare for making `component` abstract */ -external component: componentLike<'props, element> => component<'props> = "%identity" diff --git a/jscomp/others/map.cppo.res b/jscomp/others/map.cppo.res deleted file mode 100644 index d19d0e6..0000000 --- a/jscomp/others/map.cppo.res +++ /dev/null @@ -1,199 +0,0 @@ -#ifdef TYPE_STRING -type key = string -module I = Belt_internalMapString -#elif defined TYPE_INT -type key = int -module I = Belt_internalMapInt -#else -[%error "unknown type"] -#endif - -module N = Belt_internalAVLtree -module A = Belt_Array - -type t<'a> = N.t - -let empty = None -let isEmpty = N.isEmpty -/* let singleton = N.singleton */ - -let minKey = N.minKey -let minKeyUndefined = N.minKeyUndefined -let maxKey = N.maxKey -let maxKeyUndefined = N.maxKeyUndefined -let minimum = N.minimum -let minUndefined = N.minUndefined -let maximum = N.maximum -let maxUndefined = N.maxUndefined -let forEachU = N.forEachU -let forEach = N.forEach -let mapU = N.mapU -let map = N.map -let mapWithKeyU = N.mapWithKeyU -let mapWithKey = N.mapWithKey -let reduceU = N.reduceU -let reduce = N.reduce -let everyU = N.everyU -let every = N.every -let someU = N.someU -let some = N.some -let keepU = N.keepSharedU -let keep = N.keepShared -let partitionU = N.partitionSharedU -let partition = N.partitionShared -let size = N.size -let toList = N.toList -let toArray = N.toArray -let keysToArray = N.keysToArray -let valuesToArray = N.valuesToArray -let checkInvariantInternal = N.checkInvariantInternal - -let rec set = (t, newK: key, newD: _) => - switch t { - | None => N.singleton(newK, newD) - | Some(n) => - let k = n.N.key - if newK == k { - Some(N.updateValue(n, newD)) - } else { - let v = n.N.value - if newK < k { - N.bal(set(n.N.left, newK, newD), k, v, n.N.right) - } else { - N.bal(n.N.left, k, v, set(n.N.right, newK, newD)) - } - } - } - -let rec updateU = (t, x: key, f) => - switch t { - | None => - switch f(. None) { - | None => t - | Some(data) => N.singleton(x, data) - } - | Some(n) => - let k = n.N.key - if x == k { - switch f(. Some(n.N.value)) { - | None => - let {N.left: l, right: r} = n - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.N.key), ref(rn.N.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - | Some(data) => Some(N.updateValue(n, data)) - } - } else { - let {N.left: l, right: r, value: v} = n - if x < k { - let ll = updateU(l, x, f) - if l === ll { - t - } else { - N.bal(ll, k, v, r) - } - } else { - let rr = updateU(r, x, f) - if r === rr { - t - } else { - N.bal(l, k, v, rr) - } - } - } - } - -let update = (t, x, f) => updateU(t, x, (. a) => f(a)) - -let rec removeAux = (n, x: key) => { - let {N.left: l, key: v, right: r} = n - if x == v { - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(rn)) => - let (kr, vr) = (ref(rn.N.key), ref(rn.N.value)) - let r = N.removeMinAuxWithRef(rn, kr, vr) - N.bal(l, kr.contents, vr.contents, r) - } - } else if x < v { - switch l { - | None => Some(n) - | Some(left) => - let ll = removeAux(left, x) - if ll === l { - Some(n) - } else { - open N - bal(ll, v, n.value, r) - } - } - } else { - switch r { - | None => Some(n) - | Some(right) => - let rr = removeAux(right, x) - N.bal(l, v, n.N.value, rr) - } - } -} - -let remove = (n, x) => - switch n { - | None => None - | Some(n) => removeAux(n, x) - } - -let rec removeMany0 = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeAux(t, ele) - switch u { - | None => u - | Some(t) => removeMany0(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (t, keys) => { - let len = A.length(keys) - switch t { - | None => None - | Some(t) => removeMany0(t, keys, 0, len) - } -} - -let findFirstByU = N.findFirstByU -let findFirstBy = N.findFirstBy - -let mergeMany = (h, arr) => { - let len = A.length(arr) - let v = ref(h) - for i in 0 to len - 1 { - let (key, value) = A.getUnsafe(arr, i) - v.contents = set(v.contents, key, value) - } - v.contents -} - -/* let mergeArray = mergeMany */ - -let has = I.has -let cmpU = I.cmpU -let cmp = I.cmp -let eqU = I.eqU -let eq = I.eq -let get = I.get -let getUndefined = I.getUndefined -let getWithDefault = I.getWithDefault -let getExn = I.getExn -let split = I.split -let mergeU = I.mergeU -let merge = I.merge -let fromArray = I.fromArray diff --git a/jscomp/others/map.cppo.resi b/jscomp/others/map.cppo.resi deleted file mode 100644 index 61cfec2..0000000 --- a/jscomp/others/map.cppo.resi +++ /dev/null @@ -1,181 +0,0 @@ -#ifdef TYPE_STRING -type key = string -#elif defined TYPE_INT -type key = int -#else -[%error "unknown type"] -#endif - -/** The type of maps from type `key` to type `'value`. */ -type t<'value> - -let empty: t<'v> - -let isEmpty: t<'v> => bool - -let has: (t<'v>, key) => bool - -let cmpU: (t<'v>, t<'v>, (. 'v, 'v) => int) => int -let cmp: (t<'v>, t<'v>, ('v, 'v) => int) => int - -let eqU: (t<'v>, t<'v>, (. 'v, 'v) => bool) => bool - -/** -`eq(m1, m2)` tests whether the maps `m1` and `m2` are -equal, that is, contain equal keys and associate them with -equal data. -*/ -let eq: (t<'v>, t<'v>, ('v, 'v) => bool) => bool - -let findFirstByU: (t<'v>, (. key, 'v) => bool) => option<(key, 'v)> - -/** -`findFirstBy(m, p)` uses funcion `f` to find the first key value pair -to match predicate `p`. - -```rescript -let s0 = fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2,"(3, ""))]) -findFirstBy(s0, (k, v) => k == 4) == option((4, "4")) -``` -*/ -let findFirstBy: (t<'v>, (key, 'v) => bool) => option<(key, 'v)> - -let forEachU: (t<'v>, (. key, 'v) => unit) => unit - -/** -`forEach(m, f)` applies `f` to all bindings in map `m`. -`f` receives the key as first argument, and the associated value -as second argument. The bindings are passed to `f` in increasing -order with respect to the ordering over the type of the keys. -*/ -let forEach: (t<'v>, (key, 'v) => unit) => unit - -let reduceU: (t<'v>, 'v2, (. 'v2, key, 'v) => 'v2) => 'v2 - -/** -`reduce(m, a, f)` computes `(f kN dN ... (f k1 d1 a)...)`, -where `k1 ... kN` are the keys of all bindings in `m` -(in increasing order), and `d1 ... dN` are the associated data. -*/ -let reduce: (t<'v>, 'v2, ('v2, key, 'v) => 'v2) => 'v2 - -let everyU: (t<'v>, (. key, 'v) => bool) => bool - -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate `p`. -Order unspecified */ -let every: (t<'v>, (key, 'v) => bool) => bool - -let someU: (t<'v>, (. key, 'v) => bool) => bool - -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate -`p`. Order unspecified */ -let some: (t<'v>, (key, 'v) => bool) => bool - -let size: t<'v> => int - -/** In increasing order. */ -let toList: t<'v> => list<(key, 'v)> - -let toArray: t<'v> => array<(key, 'v)> - -let fromArray: array<(key, 'v)> => t<'v> - -let keysToArray: t<'v> => array - -let valuesToArray: t<'v> => array<'v> - -let minKey: t<_> => option - -let minKeyUndefined: t<_> => Js.undefined - -let maxKey: t<_> => option - -let maxKeyUndefined: t<_> => Js.undefined - -let minimum: t<'v> => option<(key, 'v)> - -let minUndefined: t<'v> => Js.undefined<(key, 'v)> - -let maximum: t<'v> => option<(key, 'v)> - -let maxUndefined: t<'v> => Js.undefined<(key, 'v)> - -let get: (t<'v>, key) => option<'v> - -let getUndefined: (t<'v>, key) => Js.undefined<'v> - -let getWithDefault: (t<'v>, key, 'v) => 'v - -let getExn: (t<'v>, key) => 'v - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/** `remove m x` returns a map containing the same bindings as - `m`, except for `x` which is unbound in the returned map. */ -let remove: (t<'v>, key) => t<'v> - -let removeMany: (t<'v>, array) => t<'v> - -/** -`set(m, x, y)` returns a map containing the same bindings as -`m`, plus a binding of `x` to `y`. If `x` was already bound -in `m`, its previous binding disappears. -*/ -let set: (t<'v>, key, 'v) => t<'v> - -let updateU: (t<'v>, key, (. option<'v>) => option<'v>) => t<'v> -let update: (t<'v>, key, option<'v> => option<'v>) => t<'v> - -let mergeU: (t<'v>, t<'v2>, (. key, option<'v>, option<'v2>) => option<'c>) => t<'c> - -/** -`merge(m1, m2, f)` computes a map whose keys is a subset of keys of `m1` -and of `m2`. The presence of each such binding, and the corresponding -value, is determined with the function `f`. -*/ -let merge: (t<'v>, t<'v2>, (key, option<'v>, option<'v2>) => option<'c>) => t<'c> - -let mergeMany: (t<'v>, array<(key, 'v)>) => t<'v> - -let keepU: (t<'v>, (. key, 'v) => bool) => t<'v> - -/** -`keep(m, p)` returns the map with all the bindings in `m` that satisfy predicate -`p`. -*/ -let keep: (t<'v>, (key, 'v) => bool) => t<'v> - -let partitionU: (t<'v>, (. key, 'v) => bool) => (t<'v>, t<'v>) - -/** -`partition(m, p)` returns a pair of maps `(m1, m2)`, where `m1` contains all the -bindings of `s` that satisfy the predicate `p`, and `m2` is the map with all the -bindings of `s` that do not satisfy `p`. -*/ -let partition: (t<'v>, (key, 'v) => bool) => (t<'v>, t<'v>) - -/** -`split(x, m)` returns a triple `(l, data, r)`, where `l` is the map with all the -bindings of `m` whose key is strictly less than `x`; `r` is the map with all the -bindings of `m` whose key is strictly greater than `x`; `data` is `None` if `m` -contains no binding for `x`, or `Some(v)` if `m` binds `v` to `x`. -*/ -let split: (key, t<'v>) => (t<'v>, option<'v>, t<'v>) - -let mapU: (t<'v>, (. 'v) => 'v2) => t<'v2> - -/** -`map(m, f)` returns a map with same domain as `m`, where the associated value `a` -of all bindings of `m` has been replaced by the result of the application of `f` -to `a`. The bindings are passed to `f` in increasing order with respect to the -ordering over the type of the keys. -*/ -let map: (t<'v>, 'v => 'v2) => t<'v2> - -let mapWithKeyU: (t<'v>, (. key, 'v) => 'v2) => t<'v2> -let mapWithKey: (t<'v>, (key, 'v) => 'v2) => t<'v2> diff --git a/jscomp/others/mapm.cppo.res b/jscomp/others/mapm.cppo.res deleted file mode 100644 index 3ac8ad3..0000000 --- a/jscomp/others/mapm.cppo.res +++ /dev/null @@ -1,183 +0,0 @@ -#ifdef TYPE_INT -module I = Belt_internalMapInt -type key = int -#elif defined TYPE_STRING -module I = Belt_internalMapString -type key = string -#else -[%error "unknown type"] -#endif - -module N = Belt_internalAVLtree -module A = Belt_Array - -type t<'a> = {mutable data: I.t<'a>} - -let make = () => {data: None} -let isEmpty = m => N.isEmpty(m.data) -let clear = m => m.data = None -/* let singleton k v = t ~data:(N.singleton k v) */ - -let minKeyUndefined = m => N.minKeyUndefined(m.data) -let minKey = m => N.minKey(m.data) -let maxKeyUndefined = m => N.maxKeyUndefined(m.data) -let maxKey = m => N.maxKey(m.data) -let minimum = m => N.minimum(m.data) -let minUndefined = m => N.minUndefined(m.data) -let maximum = m => N.maximum(m.data) -let maxUndefined = m => N.maxUndefined(m.data) - -let set = (m: t<_>, k, v) => { - let old_data = m.data - let v = I.addMutate(old_data, k, v) - if v !== old_data { - m.data = v - } -} - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a, b) => f(a, b)) -let mapU = (d, f) => {data: N.mapU(d.data, f)} -let map = (d, f) => mapU(d, (. a) => f(a)) -let mapWithKeyU = (d, f) => {data: N.mapWithKeyU(d.data, f)} -let mapWithKey = (d, f) => mapWithKeyU(d, (. a, b) => f(a, b)) -let reduceU = (d, acc, f) => N.reduceU(d.data, acc, f) -let reduce = (d, acc, f) => reduceU(d, acc, (. a, b, c) => f(a, b, c)) -let everyU = (d, f) => N.everyU(d.data, f) -let every = (d, f) => everyU(d, (. a, b) => f(a, b)) -let someU = (d, f) => N.someU(d.data, f) -let some = (d, f) => someU(d, (. a, b) => f(a, b)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) -let keysToArray = d => N.keysToArray(d.data) -let valuesToArray = d => N.valuesToArray(d.data) -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) -let has = (d, v) => I.has(d.data, v) - -let rec removeMutateAux = (nt, x: key) => { - let k = nt.N.key - if x == k { - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = removeMutateAux(l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeMutateAux(r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(root) => - let newRoot = removeMutateAux(root, v) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec updateDone = (t, x: key, f) => - switch t { - | None => - switch f(. None) { - | Some(data) => N.singleton(x, data) - | None => t - } - | Some(nt) => - let k = nt.N.key - - /* let c = (Belt_Cmp.getCmpInternal cmp) x k [@bs] in */ - if k == x { - switch f(. Some(nt.value)) { - | None => - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (_, Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - | Some(data) => - nt.value = data - Some(nt) - } - } else { - let {N.left: l, right: r} = nt - if x < k { - let ll = updateDone(l, x, f) - nt.left = ll - } else { - nt.right = updateDone(r, x, f) - } - Some(N.balMutate(nt)) - } - } - -let updateU = (t, x, f) => { - let oldRoot = t.data - let newRoot = updateDone(oldRoot, x, f) - if newRoot !== oldRoot { - t.data = newRoot - } -} -let update = (t, x, f) => updateU(t, x, (. a) => f(a)) -let rec removeArrayMutateAux = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = removeMutateAux(t, ele) - switch u { - | None => None - | Some(t) => removeArrayMutateAux(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (d: t<_>, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - let newRoot = removeArrayMutateAux(nt, xs, 0, len) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -/* let split = I.split */ -/* let merge = I.merge */ - -let fromArray = xs => {data: I.fromArray(xs)} - -let cmpU = (d0, d1, f) => I.cmpU(d0.data, d1.data, f) -let cmp = (d0, d1, f) => cmpU(d0, d1, (. a, b) => f(a, b)) - -let eqU = (d0, d1, f) => I.eqU(d0.data, d1.data, f) -let eq = (d0, d1, f) => eqU(d0, d1, (. a, b) => f(a, b)) - -let get = (d, x) => I.get(d.data, x) -let getUndefined = (d, x) => I.getUndefined(d.data, x) -let getWithDefault = (d, x, def) => I.getWithDefault(d.data, x, def) -let getExn = (d, x) => I.getExn(d.data, x) diff --git a/jscomp/others/mapm.cppo.resi b/jscomp/others/mapm.cppo.resi deleted file mode 100644 index c4f1556..0000000 --- a/jscomp/others/mapm.cppo.resi +++ /dev/null @@ -1,143 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -#ifdef TYPE_STRING -type key = string -#elif defined TYPE_INT -type key = int -#else -[%error "unknown type"] -#endif - -type t<'a> - -let make: unit => t<'a> -let clear: t<'a> => unit -let isEmpty: t<'a> => bool - -let has: (t<'a>, key) => bool - -let cmpU: (t<'a>, t<'a>, (. 'a, 'a) => int) => int - -/** -`cmp(m1, m2, cmp)`. First compare by size, if size is the same, compare by key, -value pair -*/ -let cmp: (t<'a>, t<'a>, ('a, 'a) => int) => int - -let eqU: (t<'a>, t<'a>, (. 'a, 'a) => bool) => bool - -/** `eq(m1, m2, cmp)` */ -let eq: (t<'a>, t<'a>, ('a, 'a) => bool) => bool - -let forEachU: (t<'a>, (. key, 'a) => unit) => unit - -/** -`forEach(m, f)` applies `f` to all bindings in map `m`. `f` receives the key as -first argument, and the associated value as second argument. The application -order of `f` is in increasing order. */ -let forEach: (t<'a>, (key, 'a) => unit) => unit - -let reduceU: (t<'a>, 'b, (. 'b, key, 'a) => 'b) => 'b - -/** -`reduce(m, a, f)` computes `(f kN dN ... (f k1 d1 a)...)`, where `k1 ... kN` are -the keys of all bindings in `m` (in increasing order), and `d1 ... dN` are the -associated data. */ -let reduce: (t<'a>, 'b, ('b, key, 'a) => 'b) => 'b - -let everyU: (t<'a>, (. key, 'a) => bool) => bool - -/** -`every(m, p)` checks if all the bindings of the map satisfy the predicate `p`. -The application order of `p` is unspecified. -*/ -let every: (t<'a>, (key, 'a) => bool) => bool - -let someU: (t<'a>, (. key, 'a) => bool) => bool - -/** -`some(m, p)` checks if at least one binding of the map satisfy the predicate `p`. -The application order of `p` is unspecified. -*/ -let some: (t<'a>, (key, 'a) => bool) => bool - -let size: t<'a> => int - -/** In increasing order */ -let toList: t<'a> => list<(key, 'a)> - -/** In increasing order */ -let toArray: t<'a> => array<(key, 'a)> - -let fromArray: array<(key, 'a)> => t<'a> -let keysToArray: t<'a> => array -let valuesToArray: t<'a> => array<'a> -let minKey: t<_> => option -let minKeyUndefined: t<_> => Js.undefined -let maxKey: t<_> => option -let maxKeyUndefined: t<_> => Js.undefined -let minimum: t<'a> => option<(key, 'a)> -let minUndefined: t<'a> => Js.undefined<(key, 'a)> -let maximum: t<'a> => option<(key, 'a)> -let maxUndefined: t<'a> => Js.undefined<(key, 'a)> -let get: (t<'a>, key) => option<'a> -let getUndefined: (t<'a>, key) => Js.undefined<'a> -let getWithDefault: (t<'a>, key, 'a) => 'a -let getExn: (t<'a>, key) => 'a - -/** - **raise** when invariant is not held -*/ -let checkInvariantInternal: t<_> => unit - -/* ************************************************************************** */ - -/* TODO: add functional `merge, partition, keep, split` */ - -/** `remove(m, x)` do the in-place modification */ -let remove: (t<'a>, key) => unit - -let removeMany: (t<'a>, array) => unit - -/** -`set(m, x, y)` do the in-place modification, return `m` for chaining. If `x` was -already bound in `m`, its previous binding disappears. -*/ -let set: (t<'a>, key, 'a) => unit - -let updateU: (t<'a>, key, (. option<'a>) => option<'a>) => unit -let update: (t<'a>, key, option<'a> => option<'a>) => unit - -let mapU: (t<'a>, (. 'a) => 'b) => t<'b> - -/** -`map(m, f)` returns a map with same domain as `m`, where the associated value `a` -of all bindings of `m` has been replaced by the result of the application of `f` -to `a`. The bindings are passed to `f` in increasing order with respect to the -ordering over the type of the keys. */ -let map: (t<'a>, 'a => 'b) => t<'b> - -let mapWithKeyU: (t<'a>, (. key, 'a) => 'b) => t<'b> -let mapWithKey: (t<'a>, (key, 'a) => 'b) => t<'b> diff --git a/jscomp/others/release.ninja b/jscomp/others/release.ninja deleted file mode 100644 index 21b03b8..0000000 --- a/jscomp/others/release.ninja +++ /dev/null @@ -1,161 +0,0 @@ - -bsc_primitive_flags = -no-keep-locs -no-alias-deps -bs-no-version-header -bs-no-check-div-by-zero -nostdlib -bs-cross-module-opt -make-runtime -nopervasives -unsafe -w +50 -warn-error A -bsc_flags = $bsc_primitive_flags -open Belt_internals - -rule cc - command = $bsc -bs-cmi -bs-cmj $bsc_flags -I others $in - description = $in -> $out -rule cc_cmi - command = $bsc -bs-read-cmi -bs-cmi -bs-cmj $bsc_flags -I others $in - description = $in -> $out - -o others/belt.cmj others/belt.cmi : cc others/belt.res | $bsc - bsc_flags = $bsc_primitive_flags -o others/js.cmj others/js.cmi : cc others/js.ml | $bsc - bsc_flags = $bsc_primitive_flags -o others/belt_internals.cmi : cc others/belt_internals.resi | $bsc - bsc_flags = $bsc_primitive_flags -o others/js_OO.cmi others/js_OO.cmj : cc others/js_OO.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_array.cmi others/js_array.cmj : cc others/js_array.res | others/belt_internals.cmi others/js.cmi others/js_array2.cmj $bsc -o others/js_array2.cmi others/js_array2.cmj : cc others/js_array2.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_bigint.cmi others/js_bigint.cmj : cc others/js_bigint.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_blob.cmi others/js_blob.cmj : cc others/js_blob.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_cast.cmj : cc_cmi others/js_cast.res | others/belt_internals.cmi others/js.cmi others/js_cast.cmi $bsc -o others/js_cast.cmi : cc others/js_cast.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_console.cmi others/js_console.cmj : cc others/js_console.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_date.cmi others/js_date.cmj : cc others/js_date.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_dict.cmj : cc_cmi others/js_dict.res | others/belt_internals.cmi others/js.cmi others/js_array2.cmj others/js_dict.cmi $bsc -o others/js_dict.cmi : cc others/js_dict.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_exn.cmj : cc_cmi others/js_exn.res | others/belt_internals.cmi others/js.cmi others/js_exn.cmi $bsc -o others/js_exn.cmi : cc others/js_exn.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_file.cmi others/js_file.cmj : cc others/js_file.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_float.cmi others/js_float.cmj : cc others/js_float.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_global.cmi others/js_global.cmj : cc others/js_global.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_int.cmi others/js_int.cmj : cc others/js_int.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_json.cmj : cc_cmi others/js_json.res | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_array2.cmj others/js_dict.cmj others/js_json.cmi others/js_string.cmj others/js_types.cmj $bsc -o others/js_json.cmi : cc others/js_json.resi | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_dict.cmi others/js_null.cmi others/js_string.cmj others/js_types.cmi $bsc -o others/js_list.cmj : cc_cmi others/js_list.res | others/belt_internals.cmi others/js.cmi others/js_array2.cmj others/js_list.cmi others/js_vector.cmj $bsc -o others/js_list.cmi : cc others/js_list.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_map.cmi others/js_map.cmj : cc others/js_map.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_mapperRt.cmj : cc_cmi others/js_mapperRt.res | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_mapperRt.cmi $bsc -o others/js_mapperRt.cmi : cc others/js_mapperRt.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_math.cmi others/js_math.cmj : cc others/js_math.ml | others/belt_internals.cmi others/js.cmi others/js_int.cmj $bsc -o others/js_null.cmj : cc_cmi others/js_null.res | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_exn.cmj others/js_null.cmi $bsc -o others/js_null.cmi : cc others/js_null.resi | others/belt_internals.cmi others/js.cmi others/js.cmj $bsc -o others/js_null_undefined.cmj : cc_cmi others/js_null_undefined.res | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_null_undefined.cmi $bsc -o others/js_null_undefined.cmi : cc others/js_null_undefined.resi | others/belt_internals.cmi others/js.cmi others/js.cmj $bsc -o others/js_obj.cmi others/js_obj.cmj : cc others/js_obj.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_option.cmj : cc_cmi others/js_option.res | others/belt_internals.cmi others/js.cmi others/js_exn.cmj others/js_option.cmi $bsc -o others/js_option.cmi : cc others/js_option.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_promise.cmi others/js_promise.cmj : cc others/js_promise.res | others/belt_internals.cmi others/js.cmi others/js_promise2.cmj $bsc -o others/js_promise2.cmi others/js_promise2.cmj : cc others/js_promise2.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_re.cmi others/js_re.cmj : cc others/js_re.res | others/belt_internals.cmi others/js.cmi others/js.cmj $bsc -o others/js_result.cmj : cc_cmi others/js_result.res | others/belt_internals.cmi others/js.cmi others/js_result.cmi $bsc -o others/js_result.cmi : cc others/js_result.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_set.cmi others/js_set.cmj : cc others/js_set.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_string.cmi others/js_string.cmj : cc others/js_string.res | others/belt_internals.cmi others/js.cmi others/js_array2.cmj others/js_re.cmj $bsc -o others/js_string2.cmi others/js_string2.cmj : cc others/js_string2.res | others/belt_internals.cmi others/js.cmi others/js_array2.cmj others/js_re.cmj $bsc -o others/js_typed_array.cmi others/js_typed_array.cmj : cc others/js_typed_array.res | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_typed_array2.cmj $bsc -o others/js_typed_array2.cmi others/js_typed_array2.cmj : cc others/js_typed_array2.res | others/belt_internals.cmi others/js.cmi others/js.cmj $bsc -o others/js_types.cmj : cc_cmi others/js_types.res | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_null.cmj others/js_types.cmi $bsc -o others/js_types.cmi : cc others/js_types.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_undefined.cmj : cc_cmi others/js_undefined.res | others/belt_internals.cmi others/js.cmi others/js.cmj others/js_exn.cmj others/js_undefined.cmi $bsc -o others/js_undefined.cmi : cc others/js_undefined.resi | others/belt_internals.cmi others/js.cmi others/js.cmj $bsc -o others/js_vector.cmj : cc_cmi others/js_vector.res | others/belt_internals.cmi others/js.cmi others/js_array2.cmj others/js_vector.cmi $bsc -o others/js_vector.cmi : cc others/js_vector.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/js_weakmap.cmi others/js_weakmap.cmj : cc others/js_weakmap.res | others/belt_internals.cmi others/js.cmi $bsc -o others/js_weakset.cmi others/js_weakset.cmj : cc others/js_weakset.res | others/belt_internals.cmi others/js.cmi $bsc -o others/jsxC.cmi others/jsxC.cmj : cc others/jsxC.res | others/belt_internals.cmi others/js.cmi $bsc -o others/jsxDOMC.cmi others/jsxDOMC.cmj : cc others/jsxDOMC.res | others/belt_internals.cmi others/js.cmi others/jsxC.cmj others/jsxDOMStyle.cmj others/jsxEventC.cmj $bsc -o others/jsxDOMStyle.cmi others/jsxDOMStyle.cmj : cc others/jsxDOMStyle.res | others/belt_internals.cmi others/js.cmi $bsc -o others/jsxDOMU.cmi others/jsxDOMU.cmj : cc others/jsxDOMU.res | others/belt_internals.cmi others/js.cmi others/jsxDOMStyle.cmj others/jsxEventU.cmj others/jsxU.cmj $bsc -o others/jsxEventC.cmi others/jsxEventC.cmj : cc others/jsxEventC.res | others/belt_internals.cmi others/js.cmi $bsc -o others/jsxEventU.cmi others/jsxEventU.cmj : cc others/jsxEventU.res | others/belt_internals.cmi others/js.cmi $bsc -o others/jsxPPXReactSupportC.cmi others/jsxPPXReactSupportC.cmj : cc others/jsxPPXReactSupportC.res | others/belt_internals.cmi others/js.cmi others/jsxC.cmj $bsc -o others/jsxPPXReactSupportU.cmi others/jsxPPXReactSupportU.cmj : cc others/jsxPPXReactSupportU.res | others/belt_internals.cmi others/js.cmi others/jsxU.cmj $bsc -o others/jsxU.cmi others/jsxU.cmj : cc others/jsxU.res | others/belt_internals.cmi others/js.cmi $bsc -o js_pkg : phony others/js_OO.cmi others/js_OO.cmj others/js_array.cmi others/js_array.cmj others/js_array2.cmi others/js_array2.cmj others/js_bigint.cmi others/js_bigint.cmj others/js_blob.cmi others/js_blob.cmj others/js_cast.cmi others/js_cast.cmj others/js_console.cmi others/js_console.cmj others/js_date.cmi others/js_date.cmj others/js_dict.cmi others/js_dict.cmj others/js_exn.cmi others/js_exn.cmj others/js_file.cmi others/js_file.cmj others/js_float.cmi others/js_float.cmj others/js_global.cmi others/js_global.cmj others/js_int.cmi others/js_int.cmj others/js_json.cmi others/js_json.cmj others/js_list.cmi others/js_list.cmj others/js_map.cmi others/js_map.cmj others/js_mapperRt.cmi others/js_mapperRt.cmj others/js_math.cmi others/js_math.cmj others/js_null.cmi others/js_null.cmj others/js_null_undefined.cmi others/js_null_undefined.cmj others/js_obj.cmi others/js_obj.cmj others/js_option.cmi others/js_option.cmj others/js_promise.cmi others/js_promise.cmj others/js_promise2.cmi others/js_promise2.cmj others/js_re.cmi others/js_re.cmj others/js_result.cmi others/js_result.cmj others/js_set.cmi others/js_set.cmj others/js_string.cmi others/js_string.cmj others/js_string2.cmi others/js_string2.cmj others/js_typed_array.cmi others/js_typed_array.cmj others/js_typed_array2.cmi others/js_typed_array2.cmj others/js_types.cmi others/js_types.cmj others/js_undefined.cmi others/js_undefined.cmj others/js_vector.cmi others/js_vector.cmj others/js_weakmap.cmi others/js_weakmap.cmj others/js_weakset.cmi others/js_weakset.cmj others/jsxC.cmi others/jsxC.cmj others/jsxDOMC.cmi others/jsxDOMC.cmj others/jsxDOMStyle.cmi others/jsxDOMStyle.cmj others/jsxDOMU.cmi others/jsxDOMU.cmj others/jsxEventC.cmi others/jsxEventC.cmj others/jsxEventU.cmi others/jsxEventU.cmj others/jsxPPXReactSupportC.cmi others/jsxPPXReactSupportC.cmj others/jsxPPXReactSupportU.cmi others/jsxPPXReactSupportU.cmj others/jsxU.cmi others/jsxU.cmj -o others/belt_Array.cmj : cc_cmi others/belt_Array.res | others/belt.cmi others/belt_Array.cmi others/belt_internals.cmi others/js.cmi others/js.cmj others/js_math.cmj $bsc js_pkg -o others/belt_Array.cmi : cc others/belt_Array.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_Float.cmj : cc_cmi others/belt_Float.res | others/belt.cmi others/belt_Float.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Float.cmi : cc others/belt_Float.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_HashMap.cmj : cc_cmi others/belt_HashMap.res | others/belt.cmi others/belt_Array.cmj others/belt_HashMap.cmi others/belt_HashMapInt.cmj others/belt_HashMapString.cmj others/belt_Id.cmj others/belt_internalBuckets.cmj others/belt_internalBucketsType.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashMap.cmi : cc others/belt_HashMap.resi | others/belt.cmi others/belt_HashMapInt.cmi others/belt_HashMapString.cmi others/belt_Id.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashMapInt.cmj : cc_cmi others/belt_HashMapInt.res | others/belt.cmi others/belt_Array.cmj others/belt_HashMapInt.cmi others/belt_internalBuckets.cmj others/belt_internalBucketsType.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashMapInt.cmi : cc others/belt_HashMapInt.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_HashMapString.cmj : cc_cmi others/belt_HashMapString.res | others/belt.cmi others/belt_Array.cmj others/belt_HashMapString.cmi others/belt_internalBuckets.cmj others/belt_internalBucketsType.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashMapString.cmi : cc others/belt_HashMapString.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_HashSet.cmj : cc_cmi others/belt_HashSet.res | others/belt.cmi others/belt_Array.cmj others/belt_HashSet.cmi others/belt_HashSetInt.cmj others/belt_HashSetString.cmj others/belt_Id.cmj others/belt_internalBucketsType.cmj others/belt_internalSetBuckets.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashSet.cmi : cc others/belt_HashSet.resi | others/belt.cmi others/belt_HashSetInt.cmi others/belt_HashSetString.cmi others/belt_Id.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashSetInt.cmj : cc_cmi others/belt_HashSetInt.res | others/belt.cmi others/belt_Array.cmj others/belt_HashSetInt.cmi others/belt_internalBucketsType.cmj others/belt_internalSetBuckets.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashSetInt.cmi : cc others/belt_HashSetInt.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_HashSetString.cmj : cc_cmi others/belt_HashSetString.res | others/belt.cmi others/belt_Array.cmj others/belt_HashSetString.cmi others/belt_internalBucketsType.cmj others/belt_internalSetBuckets.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_HashSetString.cmi : cc others/belt_HashSetString.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_Id.cmj : cc_cmi others/belt_Id.res | others/belt.cmi others/belt_Id.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Id.cmi : cc others/belt_Id.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_Int.cmj : cc_cmi others/belt_Int.res | others/belt.cmi others/belt_Int.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Int.cmi : cc others/belt_Int.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_List.cmj : cc_cmi others/belt_List.res | others/belt.cmi others/belt_Array.cmj others/belt_List.cmi others/belt_SortArray.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_List.cmi : cc others/belt_List.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_Map.cmj : cc_cmi others/belt_Map.res | others/belt.cmi others/belt_Id.cmj others/belt_Map.cmi others/belt_MapDict.cmj others/belt_MapInt.cmj others/belt_MapString.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Map.cmi : cc others/belt_Map.resi | others/belt.cmi others/belt_Id.cmi others/belt_MapDict.cmi others/belt_MapInt.cmi others/belt_MapString.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MapDict.cmj : cc_cmi others/belt_MapDict.res | others/belt.cmi others/belt_Array.cmj others/belt_Id.cmj others/belt_MapDict.cmi others/belt_internalAVLtree.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MapDict.cmi : cc others/belt_MapDict.resi | others/belt.cmi others/belt_Id.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MapInt.cmj : cc_cmi others/belt_MapInt.res | others/belt.cmi others/belt_Array.cmj others/belt_MapInt.cmi others/belt_internalAVLtree.cmj others/belt_internalMapInt.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MapInt.cmi : cc others/belt_MapInt.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MapString.cmj : cc_cmi others/belt_MapString.res | others/belt.cmi others/belt_Array.cmj others/belt_MapString.cmi others/belt_internalAVLtree.cmj others/belt_internalMapString.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MapString.cmi : cc others/belt_MapString.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableMap.cmj : cc_cmi others/belt_MutableMap.res | others/belt.cmi others/belt_Array.cmj others/belt_Id.cmj others/belt_MutableMap.cmi others/belt_MutableMapInt.cmj others/belt_MutableMapString.cmj others/belt_internalAVLtree.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MutableMap.cmi : cc others/belt_MutableMap.resi | others/belt.cmi others/belt_Id.cmi others/belt_MutableMapInt.cmi others/belt_MutableMapString.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableMapInt.cmj : cc_cmi others/belt_MutableMapInt.res | others/belt.cmi others/belt_Array.cmj others/belt_MutableMapInt.cmi others/belt_internalAVLtree.cmj others/belt_internalMapInt.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MutableMapInt.cmi : cc others/belt_MutableMapInt.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableMapString.cmj : cc_cmi others/belt_MutableMapString.res | others/belt.cmi others/belt_Array.cmj others/belt_MutableMapString.cmi others/belt_internalAVLtree.cmj others/belt_internalMapString.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MutableMapString.cmi : cc others/belt_MutableMapString.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableQueue.cmj : cc_cmi others/belt_MutableQueue.res | others/belt.cmi others/belt_Array.cmj others/belt_MutableQueue.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableQueue.cmi : cc others/belt_MutableQueue.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableSet.cmj : cc_cmi others/belt_MutableSet.res | others/belt.cmi others/belt_Array.cmj others/belt_Id.cmj others/belt_MutableSet.cmi others/belt_MutableSetInt.cmj others/belt_MutableSetString.cmj others/belt_SortArray.cmj others/belt_internalAVLset.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MutableSet.cmi : cc others/belt_MutableSet.resi | others/belt.cmi others/belt_Id.cmi others/belt_MutableSetInt.cmi others/belt_MutableSetString.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableSetInt.cmj : cc_cmi others/belt_MutableSetInt.res | others/belt.cmi others/belt_Array.cmj others/belt_MutableSetInt.cmi others/belt_SortArrayInt.cmj others/belt_internalAVLset.cmj others/belt_internalSetInt.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MutableSetInt.cmi : cc others/belt_MutableSetInt.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableSetString.cmj : cc_cmi others/belt_MutableSetString.res | others/belt.cmi others/belt_Array.cmj others/belt_MutableSetString.cmi others/belt_SortArrayString.cmj others/belt_internalAVLset.cmj others/belt_internalSetString.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_MutableSetString.cmi : cc others/belt_MutableSetString.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableStack.cmj : cc_cmi others/belt_MutableStack.res | others/belt.cmi others/belt_MutableStack.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_MutableStack.cmi : cc others/belt_MutableStack.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_Option.cmj : cc_cmi others/belt_Option.res | others/belt.cmi others/belt_Option.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Option.cmi : cc others/belt_Option.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_Range.cmj : cc_cmi others/belt_Range.res | others/belt.cmi others/belt_Range.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Range.cmi : cc others/belt_Range.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_Result.cmj : cc_cmi others/belt_Result.res | others/belt.cmi others/belt_Result.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Result.cmi : cc others/belt_Result.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_Set.cmj : cc_cmi others/belt_Set.res | others/belt.cmi others/belt_Id.cmj others/belt_Set.cmi others/belt_SetDict.cmj others/belt_SetInt.cmj others/belt_SetString.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_Set.cmi : cc others/belt_Set.resi | others/belt.cmi others/belt_Id.cmi others/belt_SetDict.cmi others/belt_SetInt.cmi others/belt_SetString.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_SetDict.cmj : cc_cmi others/belt_SetDict.res | others/belt.cmi others/belt_Array.cmj others/belt_Id.cmj others/belt_SetDict.cmi others/belt_internalAVLset.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_SetDict.cmi : cc others/belt_SetDict.resi | others/belt.cmi others/belt_Id.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_SetInt.cmj : cc_cmi others/belt_SetInt.res | others/belt.cmi others/belt_Array.cmj others/belt_SetInt.cmi others/belt_internalAVLset.cmj others/belt_internalSetInt.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_SetInt.cmi : cc others/belt_SetInt.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_SetString.cmj : cc_cmi others/belt_SetString.res | others/belt.cmi others/belt_Array.cmj others/belt_SetString.cmi others/belt_internalAVLset.cmj others/belt_internalSetString.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_SetString.cmi : cc others/belt_SetString.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_SortArray.cmj : cc_cmi others/belt_SortArray.res | others/belt.cmi others/belt_Array.cmj others/belt_SortArray.cmi others/belt_SortArrayInt.cmj others/belt_SortArrayString.cmj others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_SortArray.cmi : cc others/belt_SortArray.resi | others/belt.cmi others/belt_SortArrayInt.cmi others/belt_SortArrayString.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_SortArrayInt.cmj : cc_cmi others/belt_SortArrayInt.res | others/belt.cmi others/belt_Array.cmj others/belt_SortArrayInt.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_SortArrayInt.cmi : cc others/belt_SortArrayInt.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_SortArrayString.cmj : cc_cmi others/belt_SortArrayString.res | others/belt.cmi others/belt_Array.cmj others/belt_SortArrayString.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_SortArrayString.cmi : cc others/belt_SortArrayString.resi | others/belt_internals.cmi others/js.cmi $bsc -o others/belt_internalAVLset.cmj : cc_cmi others/belt_internalAVLset.res | others/belt.cmi others/belt_Array.cmj others/belt_Id.cmj others/belt_SortArray.cmj others/belt_internalAVLset.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalAVLset.cmi : cc others/belt_internalAVLset.resi | others/belt.cmi others/belt_Id.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalAVLtree.cmj : cc_cmi others/belt_internalAVLtree.res | others/belt.cmi others/belt_Array.cmj others/belt_Id.cmj others/belt_SortArray.cmj others/belt_internalAVLtree.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalAVLtree.cmi : cc others/belt_internalAVLtree.resi | others/belt.cmi others/belt_Id.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalBuckets.cmj : cc_cmi others/belt_internalBuckets.res | others/belt.cmi others/belt_Array.cmj others/belt_internalBuckets.cmi others/belt_internalBucketsType.cmj others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalBuckets.cmi : cc others/belt_internalBuckets.resi | others/belt.cmi others/belt_internalBucketsType.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_internalBucketsType.cmj : cc_cmi others/belt_internalBucketsType.res | others/belt.cmi others/belt_Array.cmj others/belt_internalBucketsType.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalBucketsType.cmi : cc others/belt_internalBucketsType.resi | others/belt.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalMapInt.cmi others/belt_internalMapInt.cmj : cc others/belt_internalMapInt.res | others/belt.cmi others/belt_Array.cmj others/belt_SortArray.cmj others/belt_internalAVLtree.cmj others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalMapString.cmi others/belt_internalMapString.cmj : cc others/belt_internalMapString.res | others/belt.cmi others/belt_Array.cmj others/belt_SortArray.cmj others/belt_internalAVLtree.cmj others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalSetBuckets.cmj : cc_cmi others/belt_internalSetBuckets.res | others/belt.cmi others/belt_Array.cmj others/belt_internalBucketsType.cmj others/belt_internalSetBuckets.cmi others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalSetBuckets.cmi : cc others/belt_internalSetBuckets.resi | others/belt.cmi others/belt_internalBucketsType.cmi others/belt_internals.cmi others/js.cmi $bsc js_pkg -o others/belt_internalSetInt.cmi others/belt_internalSetInt.cmj : cc others/belt_internalSetInt.res | others/belt.cmi others/belt_Array.cmj others/belt_SortArrayInt.cmj others/belt_internalAVLset.cmj others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/belt_internalSetString.cmi others/belt_internalSetString.cmj : cc others/belt_internalSetString.res | others/belt.cmi others/belt_Array.cmj others/belt_SortArrayString.cmj others/belt_internalAVLset.cmj others/belt_internals.cmi others/js.cmi others/js.cmj $bsc js_pkg -o others/dom.cmi others/dom.cmj : cc others/dom.res | others/belt_internals.cmi others/dom_storage.cmj others/dom_storage2.cmj others/js.cmi $bsc js_pkg -o others/dom_storage.cmi others/dom_storage.cmj : cc others/dom_storage.res | others/belt_internals.cmi others/dom_storage2.cmj others/js.cmi $bsc js_pkg -o others/dom_storage2.cmi others/dom_storage2.cmj : cc others/dom_storage2.res | others/belt_internals.cmi others/js.cmi $bsc -o others : phony others/belt_Array.cmi others/belt_Array.cmj others/belt_Float.cmi others/belt_Float.cmj others/belt_HashMap.cmi others/belt_HashMap.cmj others/belt_HashMapInt.cmi others/belt_HashMapInt.cmj others/belt_HashMapString.cmi others/belt_HashMapString.cmj others/belt_HashSet.cmi others/belt_HashSet.cmj others/belt_HashSetInt.cmi others/belt_HashSetInt.cmj others/belt_HashSetString.cmi others/belt_HashSetString.cmj others/belt_Id.cmi others/belt_Id.cmj others/belt_Int.cmi others/belt_Int.cmj others/belt_List.cmi others/belt_List.cmj others/belt_Map.cmi others/belt_Map.cmj others/belt_MapDict.cmi others/belt_MapDict.cmj others/belt_MapInt.cmi others/belt_MapInt.cmj others/belt_MapString.cmi others/belt_MapString.cmj others/belt_MutableMap.cmi others/belt_MutableMap.cmj others/belt_MutableMapInt.cmi others/belt_MutableMapInt.cmj others/belt_MutableMapString.cmi others/belt_MutableMapString.cmj others/belt_MutableQueue.cmi others/belt_MutableQueue.cmj others/belt_MutableSet.cmi others/belt_MutableSet.cmj others/belt_MutableSetInt.cmi others/belt_MutableSetInt.cmj others/belt_MutableSetString.cmi others/belt_MutableSetString.cmj others/belt_MutableStack.cmi others/belt_MutableStack.cmj others/belt_Option.cmi others/belt_Option.cmj others/belt_Range.cmi others/belt_Range.cmj others/belt_Result.cmi others/belt_Result.cmj others/belt_Set.cmi others/belt_Set.cmj others/belt_SetDict.cmi others/belt_SetDict.cmj others/belt_SetInt.cmi others/belt_SetInt.cmj others/belt_SetString.cmi others/belt_SetString.cmj others/belt_SortArray.cmi others/belt_SortArray.cmj others/belt_SortArrayInt.cmi others/belt_SortArrayInt.cmj others/belt_SortArrayString.cmi others/belt_SortArrayString.cmj others/belt_internalAVLset.cmi others/belt_internalAVLset.cmj others/belt_internalAVLtree.cmi others/belt_internalAVLtree.cmj others/belt_internalBuckets.cmi others/belt_internalBuckets.cmj others/belt_internalBucketsType.cmi others/belt_internalBucketsType.cmj others/belt_internalMapInt.cmi others/belt_internalMapInt.cmj others/belt_internalMapString.cmi others/belt_internalMapString.cmj others/belt_internalSetBuckets.cmi others/belt_internalSetBuckets.cmj others/belt_internalSetInt.cmi others/belt_internalSetInt.cmj others/belt_internalSetString.cmi others/belt_internalSetString.cmj others/dom.cmi others/dom.cmj others/dom_storage.cmi others/dom_storage.cmj others/dom_storage2.cmi others/dom_storage2.cmj diff --git a/jscomp/others/setm.cppo.res b/jscomp/others/setm.cppo.res deleted file mode 100644 index b8c5f6f..0000000 --- a/jscomp/others/setm.cppo.res +++ /dev/null @@ -1,346 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** This module is [`Belt.MutableSet`]() specialized with key type to be a primitive type. - It is more efficient in general, the API is the same with [`Belt_MutableSet`]() except its key type is fixed, - and identity is not needed(using the built-in one) -*/ - -#ifdef TYPE_INT -module I = Belt_internalSetInt -module S = Belt_SortArrayInt -#elif defined TYPE_STRING -module I = Belt_internalSetString -module S = Belt_SortArrayString -#else -[%error "unknown type"] -#endif - -module N = Belt_internalAVLset -module A = Belt_Array - -/** The type of the set elements. */ -type value = I.value - -/** The type of sets. */ -type t = {mutable data: I.t} - -let rec remove0 = (nt, x: value) => { - let k = nt.N.value - if x == k { - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = remove0(l, x) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = remove0(r, x) - Some(N.balMutate(nt)) - } - } -} - -let remove = (d, v) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(oldRoot2) => - let newRoot = remove0(oldRoot2, v) - if newRoot !== oldRoot { - d.data = newRoot - } - } -} - -let rec removeMany0 = (t, xs, i, len) => - if i < len { - let ele = A.getUnsafe(xs, i) - let u = remove0(t, ele) - switch u { - | None => None - | Some(t) => removeMany0(t, xs, i + 1, len) - } - } else { - Some(t) - } - -let removeMany = (d: t, xs) => { - let oldRoot = d.data - switch oldRoot { - | None => () - | Some(nt) => - let len = A.length(xs) - d.data = removeMany0(nt, xs, 0, len) - } -} - -let rec removeCheck0 = (nt, x: value, removed) => { - let k = nt.N.value - if x == k { - let () = removed.contents = true - let {N.left: l, right: r} = nt - switch (l, r) { - | (None, _) => r - | (_, None) => l - | (Some(_), Some(nr)) => - nt.right = N.removeMinAuxWithRootMutate(nt, nr) - Some(N.balMutate(nt)) - } - } else if x < k { - switch nt.left { - | None => Some(nt) - | Some(l) => - nt.left = removeCheck0(l, x, removed) - Some(N.balMutate(nt)) - } - } else { - switch nt.right { - | None => Some(nt) - | Some(r) => - nt.right = removeCheck0(r, x, removed) - Some(N.balMutate(nt)) - } - } -} - -let removeCheck = (d: t, v) => { - let oldRoot = d.data - switch oldRoot { - | None => false - | Some(oldRoot2) => - let removed = ref(false) - let newRoot = removeCheck0(oldRoot2, v, removed) - if newRoot !== oldRoot { - d.data = newRoot - } - removed.contents - } -} - -let rec addCheck0 = (t, x: value, added) => - switch t { - | None => - added.contents = true - N.singleton(x) - | Some(nt) => - let k = nt.N.value - if x == k { - t - } else { - let {N.left: l, right: r} = nt - if x < k { - let ll = addCheck0(l, x, added) - nt.left = ll - } else { - nt.right = addCheck0(r, x, added) - } - Some(N.balMutate(nt)) - } - } - -let addCheck = (m: t, e) => { - let oldRoot = m.data - let added = ref(false) - let newRoot = addCheck0(oldRoot, e, added) - if newRoot !== oldRoot { - m.data = newRoot - } - added.contents -} - -let add = (d, k) => { - let oldRoot = d.data - let v = I.addMutate(oldRoot, k) - if v !== oldRoot { - d.data = v - } -} - -let addArrayMutate = (t, xs) => { - let v = ref(t) - for i in 0 to A.length(xs) - 1 { - v.contents = I.addMutate(v.contents, A.getUnsafe(xs, i)) - } - v.contents -} - -let mergeMany = (d, arr) => d.data = addArrayMutate(d.data, arr) - -let make = () => {data: None} - -let isEmpty = d => N.isEmpty(d.data) - -let minimum = d => N.minimum(d.data) - -let minUndefined = d => N.minUndefined(d.data) - -let maximum = d => N.maximum(d.data) - -let maxUndefined = d => N.maxUndefined(d.data) - -let forEachU = (d, f) => N.forEachU(d.data, f) -let forEach = (d, f) => forEachU(d, (. a) => f(a)) - -let reduceU = (d, acc, cb) => N.reduceU(d.data, acc, cb) -let reduce = (d, acc, cb) => reduceU(d, acc, (. a, b) => cb(a, b)) - -let everyU = (d, p) => N.everyU(d.data, p) -let every = (d, p) => everyU(d, (. a) => p(a)) -let someU = (d, p) => N.someU(d.data, p) -let some = (d, p) => someU(d, (. a) => p(a)) -let size = d => N.size(d.data) -let toList = d => N.toList(d.data) -let toArray = d => N.toArray(d.data) - -let fromSortedArrayUnsafe = xs => {data: N.fromSortedArrayUnsafe(xs)} - -let checkInvariantInternal = d => N.checkInvariantInternal(d.data) - -let fromArray = xs => {data: I.fromArray(xs)} - -let cmp = (d0, d1) => I.cmp(d0.data, d1.data) -let eq = (d0, d1) => I.eq(d0.data, d1.data) -let get = (d, x) => I.get(d.data, x) -let getUndefined = (d, x) => I.getUndefined(d.data, x) -let getExn = (d, x) => I.getExn(d.data, x) - -let split = (d, key) => { - let arr = N.toArray(d.data) - let i = S.binarySearch(arr, key) - let len = A.length(arr) - if i < 0 { - let next = -i - 1 - ( - ( - {data: N.fromSortedArrayAux(arr, 0, next)}, - {data: N.fromSortedArrayAux(arr, next, len - next)}, - ), - false, - ) - } else { - ( - ( - {data: N.fromSortedArrayAux(arr, 0, i)}, - {data: N.fromSortedArrayAux(arr, i + 1, len - i - 1)}, - ), - true, - ) - } -} - -let keepU = (d, p) => {data: N.keepCopyU(d.data, p)} -let keep = (d, p) => keepU(d, (. a) => p(a)) - -let partitionU = (d, p) => { - let (a, b) = N.partitionCopyU(d.data, p) - ({data: a}, {data: b}) -} -let partition = (d, p) => partitionU(d, (. a) => p(a)) - -let subset = (a, b) => I.subset(a.data, b.data) -let intersect = (dataa, datab) => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => make() - | (_, None) => make() - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if ( - A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) || - A.getUnsafe(tmp, totalSize - 1) < A.getUnsafe(tmp, 0) - ) { - make() - } else { - let tmp2 = A.makeUninitializedUnsafe(Pervasives.min(sizea, sizeb)) - let k = S.intersect(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let diff = (dataa, datab): t => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => make() - | (_, None) => {data: N.copy(dataa)} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if ( - A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) || - A.getUnsafe(tmp, totalSize - 1) < A.getUnsafe(tmp, 0) - ) { - {data: N.copy(dataa)} - } else { - let tmp2 = A.makeUninitializedUnsafe(sizea) - let k = S.diff(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let union = (dataa: t, datab: t): t => { - let (dataa, datab) = (dataa.data, datab.data) - switch (dataa, datab) { - | (None, _) => {data: N.copy(datab)} - | (_, None) => {data: N.copy(dataa)} - | (Some(dataa0), Some(datab0)) => - let (sizea, sizeb) = (N.lengthNode(dataa0), N.lengthNode(datab0)) - let totalSize = sizea + sizeb - let tmp = A.makeUninitializedUnsafe(totalSize) - ignore(N.fillArray(dataa0, 0, tmp)) - ignore(N.fillArray(datab0, sizea, tmp)) - if A.getUnsafe(tmp, sizea - 1) < A.getUnsafe(tmp, sizea) { - {data: N.fromSortedArrayAux(tmp, 0, totalSize)} - } else { - let tmp2 = A.makeUninitializedUnsafe(totalSize) - let k = S.union(tmp, 0, sizea, tmp, sizea, sizeb, tmp2, 0) - {data: N.fromSortedArrayAux(tmp2, 0, k)} - } - } -} - -let has = (d, x) => I.has(d.data, x) - -let copy = d => {data: N.copy(d.data)} diff --git a/jscomp/others/setm.cppo.resi b/jscomp/others/setm.cppo.resi deleted file mode 100644 index c51fd0a..0000000 --- a/jscomp/others/setm.cppo.resi +++ /dev/null @@ -1,138 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This module is [`Belt.MutableSet`]() specialized with key type to be a primitive type. - -It is more efficient in general, the API is the same with [`Belt.MutableSet`]() except its key type is fixed, -and identity is not needed(using the built-in one) - -**See** [`Belt.MutableSet`]() -*/ - -#ifdef TYPE_STRING -/** The type of the set elements. */ -type value = string -#elif defined TYPE_INT -/** The type of the set elements. */ -type value = int -#else -[%error "unknown type"] -#endif - -/** The type of sets. */ -type t - -let make: unit => t - -let fromArray: array => t -let fromSortedArrayUnsafe: array => t - -let copy: t => t -let isEmpty: t => bool -let has: (t, value) => bool - -let add: (t, value) => unit -let addCheck: (t, value) => bool -let mergeMany: (t, array) => unit -let remove: (t, value) => unit -let removeCheck: (t, value) => bool -let removeMany: (t, array) => unit - -let union: (t, t) => t -let intersect: (t, t) => t -let diff: (t, t) => t -let subset: (t, t) => bool - -let cmp: (t, t) => int -let eq: (t, t) => bool - -let forEachU: (t, (. value) => unit) => unit - -/** In increasing order*/ -let forEach: (t, value => unit) => unit - -let reduceU: (t, 'a, (. 'a, value) => 'a) => 'a - -/** Iterate in increasing order. */ -let reduce: (t, 'a, ('a, value) => 'a) => 'a - -let everyU: (t, (. value) => bool) => bool - -/** -`every(p, s)` checks if all elements of the set satisfy the predicate `p`. -Order unspecified. */ -let every: (t, value => bool) => bool - -let someU: (t, (. value) => bool) => bool - -/** -`some(p, s)` checks if at least one element of the set satisfies the predicate -`p`. Oder unspecified. -*/ -let some: (t, value => bool) => bool - -let keepU: (t, (. value) => bool) => t - -/** -`keep(s, p)` returns a fresh copy of the set of all elements in `s` that satisfy -predicate `p`. -*/ -let keep: (t, value => bool) => t - -let partitionU: (t, (. value) => bool) => (t, t) - -/** -`partition(s, p)` returns a fresh copy pair of sets `(s1, s2)`, where `s1` is -the set of all the elements of `s` that satisfy the predicate `p`, and `s2` is -the set of all the elements of `s` that do not satisfy `p`. -*/ -let partition: (t, value => bool) => (t, t) - -let size: t => int - -/** In increasing order with respect */ -let toList: t => list - -/** In increasing order with respect */ -let toArray: t => array - -let minimum: t => option -let minUndefined: t => Js.undefined -let maximum: t => option -let maxUndefined: t => Js.undefined - -let get: (t, value) => option -let getUndefined: (t, value) => Js.undefined -let getExn: (t, value) => value - -/** -`split(s, key)` return a fresh copy of each -*/ -let split: (t, value) => ((t, t), bool) - -/** -**raise** when invariant is not held -*/ -let checkInvariantInternal: t => unit diff --git a/jscomp/others/sort.cppo.res b/jscomp/others/sort.cppo.res deleted file mode 100644 index 8c521c5..0000000 --- a/jscomp/others/sort.cppo.res +++ /dev/null @@ -1,310 +0,0 @@ -#ifdef TYPE_INT -type element = int -#elif defined TYPE_STRING -type element = string -#else -[%error "unknown type"] -#endif - -module A = Belt_Array - -let rec sortedLengthAuxMore = (xs: array, prec, acc, len) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if prec > v { - sortedLengthAuxMore(xs, v, acc + 1, len) - } else { - acc - } - } - -let rec sortedLengthAuxLess = (xs: array, prec, acc, len) => - if acc >= len { - acc - } else { - let v = A.getUnsafe(xs, acc) - if prec < v { - sortedLengthAuxLess(xs, v, acc + 1, len) - } else { - acc - } - } - -let strictlySortedLength = (xs: array) => { - let len = A.length(xs) - switch len { - | 0 | 1 => len - | _ => - let (x0, x1) = (A.getUnsafe(xs, 0), A.getUnsafe(xs, 1)) - - /* let c = cmp x0 x1 [@bs] in */ - if x0 < x1 { - sortedLengthAuxLess(xs, x1, 2, len) - } else if x0 > x1 { - -sortedLengthAuxMore(xs, x1, 2, len) - } else { - 1 - } - } -} - -let rec isSortedAux = (a: array, i, last_bound) => - /* when `i = len - 1`, it reaches the last element */ - if i == last_bound { - true - } else if A.getUnsafe(a, i) <= A.getUnsafe(a, i + 1) { - isSortedAux(a, i + 1, last_bound) - } else { - false - } - -let isSorted = a => { - let len = A.length(a) - if len == 0 { - true - } else { - isSortedAux(a, 0, len - 1) - } -} - -let cutoff = 5 - -let merge = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len and src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - if s1 <= s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d + 1) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d + 1, ~len=src2r - i2) - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d + 1) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d + 1, ~len=src1r - i1) - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let union = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - /* `s1` is larger than all elements in `d` */ - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let d = d + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } - } else if s1 == s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - A.blitUnsafe(~src=src2, ~srcOffset=i2, ~dst, ~dstOffset=d, ~len=src2r - i2) - d + src2r - i2 - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - A.setUnsafe(dst, d, s2) - let i2 = i2 + 1 - let d = d + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let intersect = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - /* A.setUnsafe dst d s1; */ - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if s1 == s2 { - A.setUnsafe(dst, d, s1) - let i1 = i1 + 1 - let i2 = i2 + 1 - let d = d + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } else { - /* A.setUnsafe dst d s2; */ - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - d - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let diff = (src: array, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len - let src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - /* let c = cmp s1 s2 [@bs] in */ - if s1 < s2 { - A.setUnsafe(dst, d, s1) - let d = d + 1 - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, A.getUnsafe(src, i1), i2, s2, d) - } else { - d - } - } else if s1 == s2 { - let i1 = i1 + 1 - let i2 = i2 + 1 - if i1 < src1r && i2 < src2r { - loop(i1, A.getUnsafe(src, i1), i2, A.getUnsafe(src2, i2), d) - } else if i1 == src1r { - d - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } else { - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, A.getUnsafe(src2, i2), d) - } else { - A.blitUnsafe(~src, ~srcOffset=i1, ~dst, ~dstOffset=d, ~len=src1r - i1) - d + src1r - i1 - } - } - - loop(src1ofs, A.getUnsafe(src, src1ofs), src2ofs, A.getUnsafe(src2, src2ofs), dstofs) -} - -let insertionSort = (src: array, srcofs, dst, dstofs, len) => - for i in 0 to len - 1 { - let e = A.getUnsafe(src, srcofs + i) - let j = ref(dstofs + i - 1) - while j.contents >= dstofs && A.getUnsafe(dst, j.contents) > e { - A.setUnsafe(dst, j.contents + 1, A.getUnsafe(dst, j.contents)) - j.contents = j.contents - 1 - } - A.setUnsafe(dst, j.contents + 1, e) - } - -let rec sortTo = (src: array, srcofs, dst, dstofs, len) => - if len <= cutoff { - insertionSort(src, srcofs, dst, dstofs, len) - } else { - let l1 = len / 2 - let l2 = len - l1 - sortTo(src, srcofs + l1, dst, dstofs + l1, l2) - sortTo(src, srcofs, src, srcofs + l2, l1) - merge(src, srcofs + l2, l1, dst, dstofs + l1, l2, dst, dstofs) - } - -let stableSortInPlace = (a: array) => { - let l = A.length(a) - if l <= cutoff { - insertionSort(a, 0, a, 0, l) - } else { - let l1 = l / 2 - let l2 = l - l1 - let t = Belt_Array.makeUninitializedUnsafe(l2) - sortTo(a, l1, t, 0, l2) - sortTo(a, 0, a, l2, l1) - merge(a, l2, l1, t, 0, l2, a, 0) - } -} - -let stableSort = a => { - let b = A.copy(a) - stableSortInPlace(b) - b -} - -let rec binarySearchAux = (arr: array, lo, hi, key) => { - let mid = (lo + hi) / 2 - let midVal = A.getUnsafe(arr, mid) - - /* let c = cmp key midVal [@bs] in */ - if key == midVal { - mid - } else if key < midVal { - /* a[lo] =< key < a[mid] <= a[hi] */ - if hi == mid { - if A.getUnsafe(arr, lo) == key { - lo - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, lo, mid, key) - } - } /* a[lo] =< a[mid] < key <= a[hi] */ - else if lo == mid { - if A.getUnsafe(arr, hi) == key { - hi - } else { - -(hi + 1) - } - } else { - binarySearchAux(arr, mid, hi, key) - } -} - -let binarySearch = (sorted: array, key): int => { - let len = A.length(sorted) - if len == 0 { - -1 - } else { - let lo = A.getUnsafe(sorted, 0) - - /* let c = cmp key lo [@bs] in */ - if key < lo { - -1 - } else { - let hi = A.getUnsafe(sorted, len - 1) - - /* let c2 = cmp key hi [@bs]in */ - if key > hi { - -(len + 1) - } else { - binarySearchAux(sorted, 0, len - 1, key) - } - } - } -} diff --git a/jscomp/others/sort.cppo.resi b/jscomp/others/sort.cppo.resi deleted file mode 100644 index 8570da4..0000000 --- a/jscomp/others/sort.cppo.resi +++ /dev/null @@ -1,81 +0,0 @@ -/* Copyright (C) 2017 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** -This is a specialized module for [`Belt_SortArray`](), the docs in that module also -applies here, except the comparator is fixed and inlined -*/ - -#ifdef TYPE_INT -type element = int -#elif defined TYPE_STRING -type element = string -#else -[%error "unknown type"] -#endif - -/** -The same as [`Belt_SortArray.strictlySortedLength`]() except the comparator is fixed - -**return** `+n` means increasing order `-n` means negative order -*/ -let strictlySortedLength: array => int - -/** `sorted(xs)` return true if `xs` is in non strict increasing order */ -let isSorted: array => bool - -/** -The same as [`Belt_SortArray.stableSortInPlaceBy`]() except the comparator is fixed -*/ -let stableSortInPlace: array => unit - -/** -The same as [`Belt_SortArray.stableSortBy`]() except the comparator is fixed -*/ -let stableSort: array => array - -/** -If value is not found and value is less than one or more elements in array, -the negative number returned is the bitwise complement of the index of the first element -that is larger than value. - -If value is not found and value is greater than all elements in array, -the negative number returned is the bitwise complement of -(the index of the last element plus 1) - -for example, if `key` is smaller than all elements return `-1` since `lnot (-1) = 0` -if `key` is larger than all elements return `- (len + 1)` since `lnot (-(len+1)) = len` -*/ -let binarySearch: (array, element) => int - -/** -`union(src, src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs, cmp)` assume -`src` and `src2` is strictly sorted. for equivalent elements, it is picked from -`src` also assume that `dst` is large enough to store all elements -*/ -let union: (array, int, int, array, int, int, array, int) => int - -let intersect: (array, int, int, array, int, int, array, int) => int - -let diff: (array, int, int, array, int, int, array, int) => int diff --git a/jscomp/ounit_tests/.ocamlformat b/jscomp/ounit_tests/.ocamlformat deleted file mode 100644 index 593b6a1..0000000 --- a/jscomp/ounit_tests/.ocamlformat +++ /dev/null @@ -1 +0,0 @@ -disable diff --git a/jscomp/ounit_tests/dune b/jscomp/ounit_tests/dune deleted file mode 100644 index d4d7133..0000000 --- a/jscomp/ounit_tests/dune +++ /dev/null @@ -1,13 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executable - (name ounit_tests_main) - (public_name ounit_tests) - (enabled_if - (<> %{profile} browser)) - (flags - (:standard -w -A)) - (libraries bsb bsb_helper core ounit2)) diff --git a/jscomp/ounit_tests/ounit_array_tests.ml b/jscomp/ounit_tests/ounit_array_tests.ml deleted file mode 100644 index dbf82d5..0000000 --- a/jscomp/ounit_tests/ounit_array_tests.ml +++ /dev/null @@ -1,89 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - -let printer_int_array = fun xs -> - String.concat "," - (List.map string_of_int @@ Array.to_list xs ) - -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [|"a"; "b";"c"|] - Ext_string.equal "--" =~ No_split - end; - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [|"a"; "b";"c";"--"|] - Ext_string.equal "--" =~ Split( [|"a";"b";"c"|], [||]) - end; - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [|"--"; "a"; "b";"c";"--"|] - Ext_string.equal "--" =~ Split ([||], [|"a";"b";"c";"--"|]) - end; - __LOC__ >:: begin fun _ -> - Ext_array.find_and_split - [| "u"; "g"; "--"; "a"; "b";"c";"--"|] - Ext_string.equal "--" =~ Split ([|"u";"g"|], [|"a";"b";"c";"--"|]) - end; - __LOC__ >:: begin fun _ -> - Ext_array.reverse [|1;2|] =~ [|2;1|]; - Ext_array.reverse [||] =~ [||] - end ; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:printer_int_array in - let k x y = Ext_array.of_list_map y x in - k succ [] =~ [||]; - k succ [1] =~ [|2|]; - k succ [1;2;3] =~ [|2;3;4|]; - k succ [1;2;3;4] =~ [|2;3;4;5|]; - k succ [1;2;3;4;5] =~ [|2;3;4;5;6|]; - k succ [1;2;3;4;5;6] =~ [|2;3;4;5;6;7|]; - k succ [1;2;3;4;5;6;7] =~ [|2;3;4;5;6;7;8|]; - end; - __LOC__ >:: begin fun _ -> - Ext_array.to_list_map_acc - [|1;2;3;4;5;6|] [1;2;3] - (fun x -> if x mod 2 = 0 then Some x else None ) - =~ [2;4;6;1;2;3] - end; - __LOC__ >:: begin fun _ -> - Ext_array.to_list_map_acc - [|1;2;3;4;5;6|] [] - (fun x -> if x mod 2 = 0 then Some x else None ) - =~ [2;4;6] - end; - - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_array.for_all2_no_exn - [|1;2;3|] - [|1;2;3|] - (=) - ) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_array.for_all2_no_exn - [||] [||] (=) - ); - OUnit.assert_bool __LOC__ - (not @@ Ext_array.for_all2_no_exn - [||] [|1|] (=) - ) - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (not (Ext_array.for_all2_no_exn - [|1;2;3|] - [|1;2;33|] - (=) - )) - end - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_bal_tree_tests.ml b/jscomp/ounit_tests/ounit_bal_tree_tests.ml deleted file mode 100644 index 647da53..0000000 --- a/jscomp/ounit_tests/ounit_bal_tree_tests.ml +++ /dev/null @@ -1,155 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - -module Set_poly = struct - include Set_int -let of_sorted_list xs = Array.of_list xs |> of_sorted_array -let of_array l = - Ext_array.fold_left l empty add -end -let suites = - __FILE__ >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun n -> n)))) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun n -> 1000-n)))) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_array (Array.init 1000 (fun _ -> Random.int 1000)))) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Set_poly.invariant - (Set_poly.of_sorted_list (Array.to_list (Array.init 1000 (fun n -> n))))) - end; - __LOC__ >:: begin fun _ -> - let arr = Array.init 1000 (fun n -> n) in - let set = (Set_poly.of_sorted_array arr) in - OUnit.assert_bool __LOC__ - (Set_poly.invariant set ); - OUnit.assert_equal 1000 (Set_poly.cardinal set) - end; - __LOC__ >:: begin fun _ -> - for i = 0 to 200 do - let arr = Array.init i (fun n -> n) in - let set = (Set_poly.of_sorted_array arr) in - OUnit.assert_bool __LOC__ - (Set_poly.invariant set ); - OUnit.assert_equal i (Set_poly.cardinal set) - done - end; - __LOC__ >:: begin fun _ -> - let arr_size = 200 in - let arr_sets = Array.make 200 Set_poly.empty in - for i = 0 to arr_size - 1 do - let size = Random.int 1000 in - let arr = Array.init size (fun n -> n) in - arr_sets.(i)<- (Set_poly.of_sorted_array arr) - done; - let large = Array.fold_left Set_poly.union Set_poly.empty arr_sets in - OUnit.assert_bool __LOC__ (Set_poly.invariant large) - end; - - __LOC__ >:: begin fun _ -> - let arr_size = 1_00_000 in - let v = ref Set_int.empty in - for _ = 0 to arr_size - 1 do - let size = Random.int 0x3FFFFFFF in - v := Set_int.add !v size - done; - OUnit.assert_bool __LOC__ (Set_int.invariant !v) - end; - - ] - - -type ident = { stamp : int ; name : string ; mutable flags : int} - -module Set_ident = Set.Make(struct type t = ident - let compare = Stdlib.compare end) - -let compare_ident x y = - let a = compare (x.stamp : int) y.stamp in - if a <> 0 then a - else - let b = compare (x.name : string) y.name in - if b <> 0 then b - else compare (x.flags : int) y.flags - - -let rec add (tree : _ Set_gen.t) x = match tree with - | Empty -> Set_gen.singleton x - | Leaf v -> - let c = compare_ident x v in - if c = 0 then tree else - if c < 0 then - Set_gen.unsafe_two_elements x v - else - Set_gen.unsafe_two_elements v x - | Node {l; v; r} as t -> - let c = compare_ident x v in - if c = 0 then t else - if c < 0 then Set_gen.bal (add l x ) v r else Set_gen.bal l v (add r x ) - -let rec mem (tree : _ Set_gen.t) x = match tree with - | Empty -> false - | Leaf v -> compare_ident x v = 0 - | Node{l; v; r} -> - let c = compare_ident x v in - c = 0 || mem (if c < 0 then l else r) x - -module Ident_set2 = Set.Make(struct type t = ident - let compare = compare_ident - end) - -let bench () = - let times = 1_000_000 in - Ounit_tests_util.time "functor set" begin fun _ -> - let v = ref Set_ident.empty in - for i = 0 to times do - v := Set_ident.add {stamp = i ; name = "name"; flags = -1 } !v - done; - for i = 0 to times do - ignore @@ Set_ident.mem {stamp = i; name = "name" ; flags = -1} !v - done - end ; - Ounit_tests_util.time "functor set (specialized)" begin fun _ -> - let v = ref Ident_set2.empty in - for i = 0 to times do - v := Ident_set2.add {stamp = i ; name = "name"; flags = -1 } !v - done; - for i = 0 to times do - ignore @@ Ident_set2.mem {stamp = i; name = "name" ; flags = -1} !v - done - end ; - - Ounit_tests_util.time "poly set" begin fun _ -> - let module Set_poly = Set_ident in - let v = ref Set_poly.empty in - for i = 0 to times do - v := Set_poly.add {stamp = i ; name = "name"; flags = -1 } !v - done; - for i = 0 to times do - ignore @@ Set_poly.mem {stamp = i; name = "name" ; flags = -1} !v - done; - end; - Ounit_tests_util.time "poly set (specialized)" begin fun _ -> - let v = ref Set_gen.empty in - for i = 0 to times do - v := add !v {stamp = i ; name = "name"; flags = -1 } - done; - for i = 0 to times do - ignore @@ mem !v {stamp = i; name = "name" ; flags = -1} - done - - end ; diff --git a/jscomp/ounit_tests/ounit_bsb_pkg_tests.ml b/jscomp/ounit_tests/ounit_bsb_pkg_tests.ml deleted file mode 100644 index c692fa7..0000000 --- a/jscomp/ounit_tests/ounit_bsb_pkg_tests.ml +++ /dev/null @@ -1,115 +0,0 @@ - - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let printer_string = fun x -> x -let (=~) = OUnit.assert_equal ~printer:printer_string - - -let scope_test s (a,b,c)= - match Bsb_pkg_types.extract_pkg_name_and_file s with - | Scope(a0,b0),c0 -> - a =~ a0 ; b =~ b0 ; c =~ c0 - | Global _,_ -> OUnit.assert_failure __LOC__ - -let global_test s (a,b) = - match Bsb_pkg_types.extract_pkg_name_and_file s with - | Scope _, _ -> - OUnit.assert_failure __LOC__ - | Global a0, b0-> - a=~a0; b=~b0 - -let s_test0 s (a,b)= - match Bsb_pkg_types.string_as_package s with - | Scope(name,scope) -> - a =~ name ; b =~scope - | _ -> OUnit.assert_failure __LOC__ - -let s_test1 s a = - match Bsb_pkg_types.string_as_package s with - | Global x -> - a =~ x - | _ -> OUnit.assert_failure __LOC__ - -let group0 = Map_string.of_list [ - "Liba", - {Bsb_db.info = Impl_intf; dir= "a";syntax_kind=Ml;case = false; - name_sans_extension = "liba"} -] -let group1 = Map_string.of_list [ - "Ciba", - {Bsb_db.info = Impl_intf; dir= "b";syntax_kind=Ml;case = false; - name_sans_extension = "liba"} -] - -let parse_db db : Bsb_db_decode.t = - let buf = Ext_buffer.create 10_000 in - Bsb_db_encode.encode db buf; - let s = Ext_buffer.contents buf in - Bsb_db_decode.decode s - -let suites = - __FILE__ >::: [ - __LOC__ >:: begin fun _ -> - scope_test "@hello/hi" - ("hi", "@hello",""); - - scope_test "@hello/hi/x" - ("hi", "@hello","x"); - - - scope_test "@hello/hi/x/y" - ("hi", "@hello","x/y"); - end ; - __LOC__ >:: begin fun _ -> - global_test "hello" - ("hello",""); - global_test "hello/x" - ("hello","x"); - global_test "hello/x/y" - ("hello","x/y") - end ; - __LOC__ >:: begin fun _ -> - s_test0 "@x/y" ("y","@x"); - s_test0 "@x/y/z" ("y/z","@x"); - s_test1 "xx" "xx"; - s_test1 "xx/yy/zz" "xx/yy/zz" - end; - - __LOC__ >:: begin fun _ -> - match parse_db {lib= group0; dev = group1}with - | {lib = Group {modules = [|"Liba"|]}; - dev = Group {modules = [|"Ciba"|]}} - -> OUnit.assert_bool __LOC__ true - | _ -> - OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match parse_db {lib = group0;dev = Map_string.empty } with - | {lib = Group {modules = [|"Liba"|]}; - dev = Dummy} - -> OUnit.assert_bool __LOC__ true - | _ -> - OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match parse_db {lib = Map_string.empty ; dev = group1} with - | {lib = Dummy; - dev = Group {modules = [|"Ciba"|]} - } - -> OUnit.assert_bool __LOC__ true - | _ -> - OUnit.assert_failure __LOC__ - end - (* __LOC__ >:: begin fun _ -> - OUnit.assert_equal parse_data_one data_one - end ; - __LOC__ >:: begin fun _ -> - - OUnit.assert_equal parse_data_two data_two - end *) - ] - - - diff --git a/jscomp/ounit_tests/ounit_bsb_regex_tests.ml b/jscomp/ounit_tests/ounit_bsb_regex_tests.ml deleted file mode 100644 index 076c244..0000000 --- a/jscomp/ounit_tests/ounit_bsb_regex_tests.ml +++ /dev/null @@ -1,193 +0,0 @@ - - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - - -let test_eq x y = - Bsb_regex.global_substitute ~reg:"\\${rescript:\\([-a-zA-Z0-9]+\\)}" x - (fun _ groups -> - match groups with - | x::_ -> x - | _ -> assert false - ) =~ y - - -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - test_eq - {| hi hi hi ${rescript:name} - ${rescript:x} - ${rescript:u} - |} - {| hi hi hi name - x - u - |} - end; - __LOC__ >:: begin fun _ -> - test_eq "xx" "xx"; - test_eq "${rescript:x}" "x"; - test_eq "a${rescript:x}" "ax"; - - end; - - __LOC__ >:: begin fun _ -> - test_eq "${rescript:x}x" "xx" - end; - - __LOC__ >:: begin fun _ -> - test_eq {| -{ - "name": "${rescript:name}", - "version": "${rescript:proj-version}", - "sources": [ - "src" - ], - "reason" : { "react-jsx" : true}, - "bs-dependencies" : [ - // add your bs-dependencies here - ] -} -|} {| -{ - "name": "name", - "version": "proj-version", - "sources": [ - "src" - ], - "reason" : { "react-jsx" : true}, - "bs-dependencies" : [ - // add your bs-dependencies here - ] -} -|} - end - - ; - __LOC__ >:: begin fun _ -> - test_eq {| -{ - "name": "${rescript:name}", - "version": "${rescript:proj-version}", - "scripts": { - "clean": "bsb -clean", - "clean:all": "bsb -clean-world", - "build": "bsb", - "build:all": "bsb -make-world", - "watch": "bsb -w", - }, - "keywords": [ - "ReScript" - ], - "license": "MIT", - "devDependencies": { - "bs-platform": "${rescript:bs-version}" - } -} -|} {| -{ - "name": "name", - "version": "proj-version", - "scripts": { - "clean": "bsb -clean", - "clean:all": "bsb -clean-world", - "build": "bsb", - "build:all": "bsb -make-world", - "watch": "bsb -w", - }, - "keywords": [ - "ReScript" - ], - "license": "MIT", - "devDependencies": { - "bs-platform": "bs-version" - } -} -|} - end; - __LOC__ >:: begin fun _ -> - test_eq {| -{ - "version": "0.1.0", - "command": "${rescript:bsb}", - "options": { - "cwd": "${workspaceRoot}" - }, - "isShellCommand": true, - "args": [ - "-w" - ], - "showOutput": "always", - "isWatching": true, - "problemMatcher": { - "fileLocation": "absolute", - "owner": "ocaml", - "watching": { - "activeOnStart": true, - "beginsPattern": ">>>> Start compiling", - "endsPattern": ">>>> Finish compiling" - }, - "pattern": [ - { - "regexp": "^File \"(.*)\", line (\\d+)(?:, characters (\\d+)-(\\d+))?:$", - "file": 1, - "line": 2, - "column": 3, - "endColumn": 4 - }, - { - "regexp": "^(?:(?:Parse\\s+)?(Warning|[Ee]rror)(?:\\s+\\d+)?:)?\\s+(.*)$", - "severity": 1, - "message": 2, - "loop": true - } - ] - } -} -|} {| -{ - "version": "0.1.0", - "command": "bsb", - "options": { - "cwd": "${workspaceRoot}" - }, - "isShellCommand": true, - "args": [ - "-w" - ], - "showOutput": "always", - "isWatching": true, - "problemMatcher": { - "fileLocation": "absolute", - "owner": "ocaml", - "watching": { - "activeOnStart": true, - "beginsPattern": ">>>> Start compiling", - "endsPattern": ">>>> Finish compiling" - }, - "pattern": [ - { - "regexp": "^File \"(.*)\", line (\\d+)(?:, characters (\\d+)-(\\d+))?:$", - "file": 1, - "line": 2, - "column": 3, - "endColumn": 4 - }, - { - "regexp": "^(?:(?:Parse\\s+)?(Warning|[Ee]rror)(?:\\s+\\d+)?:)?\\s+(.*)$", - "severity": 1, - "message": 2, - "loop": true - } - ] - } -} -|} - end - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_cmd_tests.ml b/jscomp/ounit_tests/ounit_cmd_tests.ml deleted file mode 100644 index c141f16..0000000 --- a/jscomp/ounit_tests/ounit_cmd_tests.ml +++ /dev/null @@ -1,280 +0,0 @@ -let (//) = Filename.concat - - - - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - - - - - -(* let output_of_exec_command command args = - let readme, writeme = Unix.pipe () in - let pid = Unix.create_process command args Unix.stdin writeme Unix.stderr in - let in_chan = Unix.in_channel_of_descr readme *) - - - -let perform_bsc = Ounit_cmd_util.perform_bsc -let bsc_check_eval = Ounit_cmd_util.bsc_check_eval - -let ok b output = - if not b then - Ounit_cmd_util.debug_output output; - OUnit.assert_bool __LOC__ b - -let suites = - __FILE__ - >::: [ - __LOC__ >:: begin fun _ -> - let v_output = perform_bsc [| "-v" |] in - OUnit.assert_bool __LOC__ ((perform_bsc [| "-h" |]).exit_code = 0 ); - OUnit.assert_bool __LOC__ (v_output.exit_code = 0); - (* Printf.printf "\n*>%s" v_output.stdout; *) - (* Printf.printf "\n*>%s" v_output.stderr ; *) - end; - __LOC__ >:: begin fun _ -> - let v_output = - perform_bsc [| "-bs-eval"; {|let str = "'a'" |}|] in - ok (v_output.exit_code = 0) v_output - end; - __LOC__ >:: begin fun _ -> - let v_output = perform_bsc [|"-bs-eval"; {|type 'a arra = 'a array - external - f : - int -> int -> int arra -> unit - = "" - [@@bs.send.pipe:int] - [@@bs.splice]|}|] in - OUnit.assert_bool __LOC__ (Ext_string.contain_substring v_output.stderr "variadic") - end; - __LOC__ >:: begin fun _ -> - let v_output = perform_bsc [|"-bs-eval"; {|external - f2 : - int -> int -> ?y:int array -> unit - = "" - [@@bs.send.pipe:int] - [@@bs.splice] |}|] in - OUnit.assert_bool __LOC__ (Ext_string.contain_substring v_output.stderr "variadic") - end; - - __LOC__ >:: begin fun _ -> - let should_be_warning = - bsc_check_eval {| external mk : int -> ([`a|`b [@bs.string]]) = "mk" [@@bs.val] |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring - should_be_warning.stderr "Unused") - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| -external ff : - resp -> (_ [@bs.as "x"]) -> int -> unit = - "x" [@@bs.set] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr - "Ill defined" - ) - end; - - __LOC__ >:: begin fun _ -> - (* used in return value - This should fail, we did not - support uncurry return value yet - *) - let should_err = bsc_check_eval {| - external v3 : - int -> int -> (int -> int -> int [@bs.uncurry]) - = "v3"[@@bs.val] - - |} in - (* Ounit_cmd_util.debug_output should_err;*) - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring - should_err.stderr "bs.uncurry") - end ; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external v4 : - (int -> int -> int [@bs.uncurry]) = "" - [@@bs.val] - - |} in - (* Ounit_cmd_util.debug_output should_err ; *) - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring - should_err.stderr "uncurry") - end ; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - {js| \uFFF|js} - |} in - OUnit.assert_bool __LOC__ (not @@ Ext_string.is_empty should_err.stderr) - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external mk : int -> ([`a|`b] [@bs.string]) = "" [@@bs.val] - |} in - OUnit.assert_bool __LOC__ (not @@ Ext_string.is_empty should_err.stderr) - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external mk : int -> ([`a|`b] ) = "mk" [@@bs.val] - |} in - OUnit.assert_bool __LOC__ ( Ext_string.is_empty should_err.stderr) - (* give a warning or ? - ( [`a | `b ] [@bs.string] ) - (* auto-convert to ocaml poly-variant *) - *) - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - type t - external mk : int -> (_ [@bs.as {json| { x : 3 } |json}]) -> t = "mk" [@@bs.val] - |} in - OUnit.assert_bool __LOC__ (Ext_string.is_empty should_err.stderr) - end - ; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - type t - external mk : int -> (_ [@bs.as {json| { "x" : 3 } |json}]) -> t = "mk" [@@bs.val] - |} in - OUnit.assert_bool __LOC__ (Ext_string.is_empty should_err.stderr) - end - ; - (* #1510 *) - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - let should_fail = fun [@bs.this] (Some x) y u -> y + u - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "simple") - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - let should_fail = fun [@bs.this] (Some x as v) y u -> y + u - |} in - (* Ounit_cmd_util.debug_output should_err; *) - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "simple") - end; - - (* __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external f : string -> unit -> unit = "x.y" [@@bs.send] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "Not a valid method name") - end; *) - - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - (* let rec must be rejected *) -type t10 = A of t10 [@@ocaml.unboxed];; -let rec x = A x;; - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "This kind of expression is not allowed") - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - type t = {x: int64} [@@unboxed];; -let rec x = {x = y} and y = 3L;; - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "This kind of expression is not allowed") - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - type r = A of r [@@unboxed];; -let rec y = A y;; - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "This kind of expression is not allowed") - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external f : int = "%identity" -|} in - OUnit.assert_bool __LOC__ - (not (Ext_string.is_empty should_err.stderr)) - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external f : int -> int = "%identity" -|} in - OUnit.assert_bool __LOC__ - (Ext_string.is_empty should_err.stderr) - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external f : int -> int -> int = "%identity" -|} in - OUnit.assert_bool __LOC__ - (not (Ext_string.is_empty should_err.stderr)) - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external f : (int -> int) -> int = "%identity" -|} in - OUnit.assert_bool __LOC__ - ( (Ext_string.is_empty should_err.stderr)) - - end; - - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external f : int -> (int-> int) = "%identity" -|} in - OUnit.assert_bool __LOC__ - (not (Ext_string.is_empty should_err.stderr)) - - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external foo_bar : - (_ [@bs.as "foo"]) -> - string -> - string = "bar" - [@@bs.send] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "Ill defined attribute") - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - external mk : int -> - ( - [`a|`b] - [@bs.string] - ) = "mk" [@@bs.val] - |} in - (* Ounit_cmd_util.debug_output should_err ; *) - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr - "Unused") - end; - __LOC__ >:: begin fun _ -> - let should_err = bsc_check_eval {| - type -'a t = {k : 'a } [@@bs.deriving abstract] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring should_err.stderr "contravariant") - end; - ] - diff --git a/jscomp/ounit_tests/ounit_cmd_util.ml b/jscomp/ounit_tests/ounit_cmd_util.ml deleted file mode 100644 index 9c0faa2..0000000 --- a/jscomp/ounit_tests/ounit_cmd_util.ml +++ /dev/null @@ -1,112 +0,0 @@ -let (//) = Filename.concat - -(** may nonterminate when [cwd] is '.' *) -let rec unsafe_root_dir_aux cwd = - if Sys.file_exists (cwd//Literals.bsconfig_json) then cwd - else unsafe_root_dir_aux (Filename.dirname cwd) - -let project_root = unsafe_root_dir_aux (Sys.getcwd ()) -let jscomp = project_root // "jscomp" - -let dune_bin_dir = project_root // "_build" // "install" // "default" // "bin" -let bsc_exe = dune_bin_dir // "bsc" -let runtime_dir = jscomp // "runtime" -let others_dir = jscomp // "others" - - -let stdlib_dir = jscomp // "stdlib-406" - -(* let rec safe_dup fd = - let new_fd = Unix.dup fd in - if (Obj.magic new_fd : int) >= 3 then - new_fd (* [dup] can not be 0, 1, 2*) - else begin - let res = safe_dup fd in - Unix.close new_fd; - res - end *) - -let safe_close fd = - try Unix.close fd with Unix.Unix_error(_,_,_) -> () - - -type output = { - stderr : string ; - stdout : string ; - exit_code : int -} - -let perform command args = - let new_fd_in, new_fd_out = Unix.pipe () in - let err_fd_in, err_fd_out = Unix.pipe () in - match Unix.fork () with - | 0 -> - begin try - safe_close new_fd_in; - safe_close err_fd_in; - Unix.dup2 err_fd_out Unix.stderr ; - Unix.dup2 new_fd_out Unix.stdout; - Unix.execv command args - with _ -> - exit 127 - end - | pid -> - (* when all the descriptors on a pipe's input are closed and the pipe is - empty, a call to [read] on its output returns zero: end of file. - when all the descriptiors on a pipe's output are closed, a call to - [write] on its input kills the writing process (EPIPE). - *) - safe_close new_fd_out ; - safe_close err_fd_out ; - let in_chan = Unix.in_channel_of_descr new_fd_in in - let err_in_chan = Unix.in_channel_of_descr err_fd_in in - let buf = Buffer.create 1024 in - let err_buf = Buffer.create 1024 in - (try - while true do - Buffer.add_string buf (input_line in_chan ); - Buffer.add_char buf '\n' - done; - with - End_of_file -> ()) ; - (try - while true do - Buffer.add_string err_buf (input_line err_in_chan ); - Buffer.add_char err_buf '\n' - done; - with - End_of_file -> ()) ; - let exit_code = match snd @@ Unix.waitpid [] pid with - | Unix.WEXITED exit_code -> exit_code - | Unix.WSIGNALED _signal_number - | Unix.WSTOPPED _signal_number -> 127 in - { - stdout = Buffer.contents buf ; - stderr = Buffer.contents err_buf; - exit_code - } - - -let perform_bsc args = - perform bsc_exe - (Array.append - [|bsc_exe ; - "-bs-package-name" ; "bs-platform"; - "-bs-no-version-header"; - "-bs-cross-module-opt"; - "-w"; - "-40"; - "-I" ; - runtime_dir ; - "-I"; - others_dir ; - "-I" ; - stdlib_dir - |] args) - -let bsc_check_eval str = - perform_bsc [|"-bs-eval"; str|] - - let debug_output o = - Printf.printf "\nexit_code:%d\nstdout:%s\nstderr:%s\n" - o.exit_code o.stdout o.stderr diff --git a/jscomp/ounit_tests/ounit_cmd_util.mli b/jscomp/ounit_tests/ounit_cmd_util.mli deleted file mode 100644 index 5ee3d69..0000000 --- a/jscomp/ounit_tests/ounit_cmd_util.mli +++ /dev/null @@ -1,16 +0,0 @@ -type output = { - stderr : string ; - stdout : string ; - exit_code : int -} - - -val perform : string -> string array -> output - - -val perform_bsc : string array -> output - - -val bsc_check_eval : string -> output - -val debug_output : output -> unit \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_data_random.ml b/jscomp/ounit_tests/ounit_data_random.ml deleted file mode 100644 index 87dbc49..0000000 --- a/jscomp/ounit_tests/ounit_data_random.ml +++ /dev/null @@ -1,9 +0,0 @@ - - -let min_int x y = - if x < y then x else y - -let random_string chars upper = - let len = Array.length chars in - let string_len = (Random.int (min_int upper len)) in - String.init string_len (fun _i -> chars.(Random.int len )) \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_depends_format_test.ml b/jscomp/ounit_tests/ounit_depends_format_test.ml deleted file mode 100644 index bc7ed6f..0000000 --- a/jscomp/ounit_tests/ounit_depends_format_test.ml +++ /dev/null @@ -1,20 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) (xs : string list) (ys : string list) = - OUnit.assert_equal xs ys - ~printer:(fun xs -> String.concat "," xs ) - -let f (x : string) = - let stru = Parse.implementation (Lexing.from_string x) in - Ast_extract.Set_string.elements (Ast_extract.read_parse_and_extract Ml_binary.Ml stru) - - -let suites = - __FILE__ - >::: [ - __LOC__ >:: begin fun _ -> - f {|module X = List|} =~ ["List"]; - f {|module X = List module X0 = List1|} =~ ["List";"List1"] - end - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_ffi_error_debug_test.ml b/jscomp/ounit_tests/ounit_ffi_error_debug_test.ml deleted file mode 100644 index ceb1b37..0000000 --- a/jscomp/ounit_tests/ounit_ffi_error_debug_test.ml +++ /dev/null @@ -1,78 +0,0 @@ -let (//) = Filename.concat - - - - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - - - - -let bsc_eval = Ounit_cmd_util.bsc_check_eval - -let debug_output = Ounit_cmd_util.debug_output - - -let suites = - __FILE__ - >::: [ - __LOC__ >:: begin fun _ -> - let output = bsc_eval {| -external err : - hi_should_error:([`a of int | `b of string ] [@bs.string]) -> - unit -> _ = "" [@@bs.obj] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring output.stderr "hi_should_error") - end; - __LOC__ >:: begin fun _ -> -let output = bsc_eval {| - external err : - ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> - unit -> _ = "" [@@bs.obj] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring output.stderr "hi_should_error") - end; - __LOC__ >:: begin fun _ -> - let output = bsc_eval {| - external err : - ?hi_should_error:([`a of int | `b of string ] [@bs.string]) -> - unit -> unit = "err" [@@bs.val] - |} in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring output.stderr "hi_should_error") - end; - - __LOC__ >:: begin fun _ -> - (* - Each [@bs.unwrap] variant constructor requires an argument - *) - let output = - bsc_eval {| - external err : - ?hi_should_error:([`a of int | `b] [@bs.unwrap]) -> unit -> unit = "err" [@@bs.val] - |} - in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring output.stderr "unwrap") - end; - - __LOC__ >:: begin fun _ -> - (* - [@bs.unwrap] args are not supported in [@@bs.obj] functions - *) - let output = - bsc_eval {| - external err : - ?hi_should_error:([`a of int] [@bs.unwrap]) -> unit -> _ = "" [@@bs.obj] - |} - in - OUnit.assert_bool __LOC__ - (Ext_string.contain_substring output.stderr "hi_should_error") - end - - ] diff --git a/jscomp/ounit_tests/ounit_hash_set_tests.ml b/jscomp/ounit_tests/ounit_hash_set_tests.ml deleted file mode 100644 index 5d418ea..0000000 --- a/jscomp/ounit_tests/ounit_hash_set_tests.ml +++ /dev/null @@ -1,121 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - -type id = { name : string ; stamp : int } - -module Id_hash_set = Hash_set.Make(struct - type t = id - let equal x y = x.stamp = y.stamp && x.name = y.name - let hash x = Hashtbl.hash x.stamp - end - ) - -let const_tbl = [|"0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "10"; "100"; "99"; "98"; - "97"; "96"; "95"; "94"; "93"; "92"; "91"; "90"; "89"; "88"; "87"; "86"; "85"; - "84"; "83"; "82"; "81"; "80"; "79"; "78"; "77"; "76"; "75"; "74"; "73"; "72"; - "71"; "70"; "69"; "68"; "67"; "66"; "65"; "64"; "63"; "62"; "61"; "60"; "59"; - "58"; "57"; "56"; "55"; "54"; "53"; "52"; "51"; "50"; "49"; "48"; "47"; "46"; - "45"; "44"; "43"; "42"; "41"; "40"; "39"; "38"; "37"; "36"; "35"; "34"; "33"; - "32"; "31"; "30"; "29"; "28"; "27"; "26"; "25"; "24"; "23"; "22"; "21"; "20"; - "19"; "18"; "17"; "16"; "15"; "14"; "13"; "12"; "11"|] -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - let v = Hash_set_poly.create 31 in - for i = 0 to 1000 do - Hash_set_poly.add v i - done ; - OUnit.assert_equal (Hash_set_poly.length v) 1001 - end ; - __LOC__ >:: begin fun _ -> - let v = Hash_set_poly.create 31 in - for _ = 0 to 1_0_000 do - Hash_set_poly.add v 0 - done ; - OUnit.assert_equal (Hash_set_poly.length v) 1 - end ; - __LOC__ >:: begin fun _ -> - let v = Hash_set_poly.create 30 in - for i = 0 to 2_000 do - Hash_set_poly.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - Hash_set_poly.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - assert (Hash_set_poly.mem v {name = "x"; stamp = i}) - done; - OUnit.assert_equal (Hash_set_poly.length v) 2_001; - for i = 1990 to 3_000 do - Hash_set_poly.remove v {name = "x"; stamp = i} - done ; - OUnit.assert_equal (Hash_set_poly.length v) 1990; - (* OUnit.assert_equal (Hash_set.stats v) *) - (* {Hashtbl.num_bindings = 1990; num_buckets = 1024; max_bucket_length = 7; *) - (* bucket_histogram = [|139; 303; 264; 178; 93; 32; 12; 3|]} *) - end ; - __LOC__ >:: begin fun _ -> - let v = Id_hash_set.create 30 in - for i = 0 to 2_000 do - Id_hash_set.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - Id_hash_set.add v {name = "x" ; stamp = i} - done ; - for i = 0 to 2_000 do - assert (Id_hash_set.mem v {name = "x"; stamp = i}) - done; - OUnit.assert_equal (Id_hash_set.length v) 2_001; - for i = 1990 to 3_000 do - Id_hash_set.remove v {name = "x"; stamp = i} - done ; - OUnit.assert_equal (Id_hash_set.length v) 1990; - for i = 1000 to 3990 do - Id_hash_set.remove v { name = "x"; stamp = i } - done; - OUnit.assert_equal (Id_hash_set.length v) 1000; - for i = 1000 to 1100 do - Id_hash_set.add v { name = "x"; stamp = i}; - done; - OUnit.assert_equal (Id_hash_set.length v ) 1101; - for i = 0 to 1100 do - OUnit.assert_bool "exist" (Id_hash_set.mem v {name = "x"; stamp = i}) - done - (* OUnit.assert_equal (Hash_set.stats v) *) - (* {num_bindings = 1990; num_buckets = 1024; max_bucket_length = 8; *) - (* bucket_histogram = [|148; 275; 285; 182; 95; 21; 14; 2; 2|]} *) - - end - ; - __LOC__ >:: begin fun _ -> - let duplicate arr = - let len = Array.length arr in - let rec aux tbl off = - if off >= len then None - else - let curr = (Array.unsafe_get arr off) in - if Hash_set_string.check_add tbl curr then - aux tbl (off + 1) - else Some curr in - aux (Hash_set_string.create len) 0 in - let v = [| "if"; "a"; "b"; "c" |] in - OUnit.assert_equal (duplicate v) None; - OUnit.assert_equal (duplicate [|"if"; "a"; "b"; "b"; "c"|]) (Some "b") - end; - __LOC__ >:: begin fun _ -> - let of_array lst = - let len = Array.length lst in - let tbl = Hash_set_string.create len in - Ext_array.iter lst (Hash_set_string.add tbl) ; tbl in - let hash = of_array const_tbl in - let len = Hash_set_string.length hash in - Hash_set_string.remove hash "x"; - OUnit.assert_equal len (Hash_set_string.length hash); - Hash_set_string.remove hash "0"; - OUnit.assert_equal (len - 1 ) (Hash_set_string.length hash) - end - ] diff --git a/jscomp/ounit_tests/ounit_hash_stubs_test.ml b/jscomp/ounit_tests/ounit_hash_stubs_test.ml deleted file mode 100644 index 859d01c..0000000 --- a/jscomp/ounit_tests/ounit_hash_stubs_test.ml +++ /dev/null @@ -1,74 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - -let count = 2_000_000 - -let bench () = - Ounit_tests_util.time "int hash set" begin fun _ -> - let v = Hash_set_int.create 2_000_000 in - for i = 0 to count do - Hash_set_int.add v i - done ; - for _ = 0 to 3 do - for i = 0 to count do - assert (Hash_set_int.mem v i) - done - done - end; - Ounit_tests_util.time "int hash set" begin fun _ -> - let v = Hash_set_poly.create 2_000_000 in - for i = 0 to count do - Hash_set_poly.add v i - done ; - for _ = 0 to 3 do - for i = 0 to count do - assert (Hash_set_poly.mem v i) - done - done - end - - -type id (* = Ident.t *) = { stamp : int; name : string; mutable flags : int; } -let hash id = Bs_hash_stubs.hash_stamp_and_name id.stamp id.name -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_int 0 =~ Hashtbl.hash 0 - end; - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_int max_int =~ Hashtbl.hash max_int - end; - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_int max_int =~ Hashtbl.hash max_int - end; - __LOC__ >:: begin fun _ -> - Bs_hash_stubs.hash_string "The quick brown fox jumps over the lazy dog" =~ - Hashtbl.hash "The quick brown fox jumps over the lazy dog" - end; - __LOC__ >:: begin fun _ -> - Array.init 100 (fun i -> String.make i 'a' ) - |> Array.iter (fun x -> - Bs_hash_stubs.hash_string x =~ Hashtbl.hash x) - end; - __LOC__ >:: begin fun _ -> - (* only stamp matters here *) - hash {stamp = 1 ; name = "xx"; flags = 0} =~ Bs_hash_stubs.hash_small_int 1 ; - hash {stamp = 11 ; name = "xx"; flags = 0} =~ Bs_hash_stubs.hash_small_int 11; - end; - __LOC__ >:: begin fun _ -> - (* only string matters here *) - hash {stamp = 0 ; name = "Pervasives"; flags = 0} =~ Bs_hash_stubs.hash_string "Pervasives"; - hash {stamp = 0 ; name = "UU"; flags = 0} =~ Bs_hash_stubs.hash_string "UU"; - end; - __LOC__ >:: begin fun _ -> - let v = Array.init 20 (fun i -> i) in - let u = Array.init 30 (fun i -> (0-i) ) in - Bs_hash_stubs.int_unsafe_blit - v 0 u 10 20 ; - OUnit.assert_equal u (Array.init 30 (fun i -> if i < 10 then -i else i - 10)) - end - ] diff --git a/jscomp/ounit_tests/ounit_hashtbl_tests.ml b/jscomp/ounit_tests/ounit_hashtbl_tests.ml deleted file mode 100644 index 96980b8..0000000 --- a/jscomp/ounit_tests/ounit_hashtbl_tests.ml +++ /dev/null @@ -1,53 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal ~printer:Ext_obj.dump - - -let suites = - __FILE__ - >:::[ - (* __LOC__ >:: begin fun _ -> *) - (* let h = Hash_string.create 0 in *) - (* let accu key = *) - (* Hash_string.replace_or_init h key succ 1 in *) - (* let count = 1000 in *) - (* for i = 0 to count - 1 do *) - (* Array.iter accu [|"a";"b";"c";"d";"e";"f"|] *) - (* done; *) - (* Hash_string.length h =~ 6; *) - (* Hash_string.iter (fun _ v -> v =~ count ) h *) - (* end; *) - - "add semantics " >:: begin fun _ -> - let h = Hash_string.create 0 in - let count = 1000 in - for _ = 0 to 1 do - for i = 0 to count - 1 do - Hash_string.add h (string_of_int i) i - done - done ; - Hash_string.length h =~ 2 * count - end; - "replace semantics" >:: begin fun _ -> - let h = Hash_string.create 0 in - let count = 1000 in - for _ = 0 to 1 do - for i = 0 to count - 1 do - Hash_string.replace h (string_of_int i) i - done - done ; - Hash_string.length h =~ count - end; - - __LOC__ >:: begin fun _ -> - let h = Hash_string.create 0 in - let count = 10 in - for i = 0 to count - 1 do - Hash_string.replace h (string_of_int i) i - done; - let xs = Hash_string.to_list h (fun k _ -> k) in - let ys = List.sort compare xs in - ys =~ ["0";"1";"2";"3";"4";"5";"6";"7";"8";"9"] - end - ] diff --git a/jscomp/ounit_tests/ounit_ident_mask_tests.ml b/jscomp/ounit_tests/ounit_ident_mask_tests.ml deleted file mode 100644 index 10a2b46..0000000 --- a/jscomp/ounit_tests/ounit_ident_mask_tests.ml +++ /dev/null @@ -1,53 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - let set = Hash_set_ident_mask.create 0 in - let a,b,_,_ = - Ident.create "a", - Ident.create "b", - Ident.create "c", - Ident.create "d" in - Hash_set_ident_mask.add_unmask set a ; - Hash_set_ident_mask.add_unmask set a ; - Hash_set_ident_mask.add_unmask set b ; - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set a); - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set b ); - Hash_set_ident_mask.iter_and_unmask set (fun id mask -> - if id.Ident.name = "a" then - OUnit.assert_bool __LOC__ mask - else if id.Ident.name = "b" then - OUnit.assert_bool __LOC__ mask - else () - ) ; - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set a ); - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set b ); - end; - __LOC__ >:: begin fun _ -> - let len = 1000 in - let idents = Array.init len (fun i -> Ident.create (string_of_int i)) in - let set = Hash_set_ident_mask.create 0 in - Array.iter (fun i -> Hash_set_ident_mask.add_unmask set i) idents; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)); - done ; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i) ); - done ; - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set idents.(len - 1)) ; - Hash_set_ident_mask.iter_and_unmask set(fun _ _ -> ()) ; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i) ); - done ; - for i = 0 to len - 2 do - OUnit.assert_bool __LOC__ (not @@ Hash_set_ident_mask.mask_and_check_all_hit set idents.(i)); - done ; - OUnit.assert_bool __LOC__ (Hash_set_ident_mask.mask_and_check_all_hit set idents.(len - 1)) ; - - end - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_int_vec_tests.ml b/jscomp/ounit_tests/ounit_int_vec_tests.ml deleted file mode 100644 index dc29ba9..0000000 --- a/jscomp/ounit_tests/ounit_int_vec_tests.ml +++ /dev/null @@ -1,33 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Int_vec_util.mem 3 (Vec_int.of_list [1;2;3])) - ; - OUnit.assert_bool __LOC__ - (not @@ Int_vec_util.mem 0 (Vec_int.of_list [1;2]) ); - - let v = Vec_int.make 100 in - OUnit.assert_bool __LOC__ - (not @@ Int_vec_util.mem 0 v) ; - Vec_int.push v 0; - OUnit.assert_bool __LOC__ - (Int_vec_util.mem 0 v ) - end; - - __LOC__ >:: begin fun _ -> - let u = Vec_int.make 100 in - Vec_int.push u 1; - OUnit.assert_bool __LOC__ - (not @@ Int_vec_util.mem 0 u ); - Vec_int.push u 0; - OUnit.assert_bool __LOC__ - (Int_vec_util.mem 0 u) - end - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_js_regex_checker_tests.ml b/jscomp/ounit_tests/ounit_js_regex_checker_tests.ml deleted file mode 100644 index 0b1e1c3..0000000 --- a/jscomp/ounit_tests/ounit_js_regex_checker_tests.ml +++ /dev/null @@ -1,46 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -open Ext_js_regex - -let suites = - __FILE__ - >::: - [ - "test_empty_string" >:: begin fun _ -> - let b = js_regex_checker "" in - OUnit.assert_equal b false - end; - "test_normal_regex" >:: begin fun _ -> - let b = js_regex_checker "/abc/" in - OUnit.assert_equal b true - end; - "test_wrong_regex_last" >:: begin fun _ -> - let b = js_regex_checker "/abc" in - OUnit.assert_equal b false - end; - "test_regex_with_flag" >:: begin fun _ -> - let b = js_regex_checker "/ss/ig" in - OUnit.assert_equal b true - end; - "test_regex_with_invalid_flag" >:: begin fun _ -> - let b = js_regex_checker "/ss/j" in - OUnit.assert_equal b false - end; - "test_regex_invalid_regex" >:: begin fun _ -> - let b = js_regex_checker "abc/i" in - OUnit.assert_equal b false - end; - "test_regex_empty_pattern" >:: begin fun _ -> - let b = js_regex_checker "//" in - OUnit.assert_equal b true - end; - "test_regex_with_utf8" >:: begin fun _ -> - let b = js_regex_checker "/😃/" in - OUnit.assert_equal b true - end; - "test_regex_repeated_flags" >:: begin fun _ -> - let b = js_regex_checker "/abc/gg" in - OUnit.assert_equal b false - end; - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_json_tests.ml b/jscomp/ounit_tests/ounit_json_tests.ml deleted file mode 100644 index 7990049..0000000 --- a/jscomp/ounit_tests/ounit_json_tests.ml +++ /dev/null @@ -1,185 +0,0 @@ - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) -type t = Ext_json_noloc.t -let rec equal - (x : t) - (y : t) = - match x with - | Null -> (* [%p? Null _ ] *) - begin match y with - | Null -> true - | _ -> false end - | Str str -> - begin match y with - | Str str2 -> str = str2 - | _ -> false end - | Flo flo - -> - begin match y with - | Flo flo2 -> - flo = flo2 - | _ -> false - end - | True -> - begin match y with - | True -> true - | _ -> false - end - | False -> - begin match y with - | False -> true - | _ -> false - end - | Arr content - -> - begin match y with - | Arr content2 - -> - Ext_array.for_all2_no_exn content content2 equal - | _ -> false - end - - | Obj map -> - begin match y with - | Obj map2 -> - let xs = Map_string.bindings map - |> List.sort (fun (a,_) (b,_) -> compare a b) in - let ys = Map_string.bindings map2 - |> List.sort (fun (a,_) (b,_) -> compare a b) in - Ext_list.for_all2_no_exn xs ys (fun (k0,v0) (k1,v1) -> k0=k1 && equal v0 v1) - | _ -> false - end - - -open Ext_json_parse -let (|?) m (key, cb) = - m |> Ext_json.test key cb - -let rec strip (x : Ext_json_types.t) : Ext_json_noloc.t = - let open Ext_json_noloc in - match x with - | True _ -> true_ - | False _ -> false_ - | Null _ -> null - | Flo {flo = s} -> flo s - | Str {str = s} -> str s - | Arr {content } -> arr (Array.map strip content) - | Obj {map} -> - obj (Map_string.map map strip) - -let id_parsing_serializing x = - let normal_s = - Ext_json_noloc.to_string - @@ strip - @@ Ext_json_parse.parse_json_from_string x - in - let normal_ss = - Ext_json_noloc.to_string - @@ strip - @@ Ext_json_parse.parse_json_from_string normal_s - in - if normal_s <> normal_ss then - begin - prerr_endline "ERROR"; - prerr_endline normal_s ; - prerr_endline normal_ss ; - end; - OUnit.assert_equal ~cmp:(fun (x:string) y -> x = y) normal_s normal_ss - -let id_parsing_x2 x = - let stru = Ext_json_parse.parse_json_from_string x |> strip in - let normal_s = Ext_json_noloc.to_string stru in - let normal_ss = strip (Ext_json_parse.parse_json_from_string normal_s) in - if equal stru normal_ss then - true - else begin - prerr_endline "ERROR"; - prerr_endline normal_s; - Format.fprintf Format.err_formatter - "%a@.%a@." Ext_obj.pp_any stru Ext_obj.pp_any normal_ss; - - prerr_endline (Ext_json_noloc.to_string normal_ss); - false - end - -let test_data = - [{| - {} - |}; - {| [] |}; - {| [1,2,3]|}; - {| ["x", "y", 1,2,3 ]|}; - {| { "x" : 3, "y" : "x", "z" : [1,2,3, "x"] }|}; - {| {"x " : true , "y" : false , "z\"" : 1} |} - ] -exception Parse_error -let suites = - __FILE__ - >::: - [ - - __LOC__ >:: begin fun _ -> - List.iter id_parsing_serializing test_data - end; - - __LOC__ >:: begin fun _ -> - List.iteri (fun i x -> OUnit.assert_bool (__LOC__ ^ string_of_int i ) (id_parsing_x2 x)) test_data - end; - "empty_json" >:: begin fun _ -> - let v =parse_json_from_string "{}" in - match v with - | Obj {map = v} -> OUnit.assert_equal (Map_string.is_empty v ) true - | _ -> OUnit.assert_failure "should be empty" - end - ; - "empty_arr" >:: begin fun _ -> - let v =parse_json_from_string "[]" in - match v with - | Arr {content = [||]} -> () - | _ -> OUnit.assert_failure "should be empty" - end - ; - "empty trails" >:: begin fun _ -> - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| [,]|} with _ -> raise Parse_error); - OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| {,}|} with _ -> raise Parse_error - end; - "two trails" >:: begin fun _ -> - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| [1,2,,]|} with _ -> raise Parse_error); - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| { "x": 3, ,}|} with _ -> raise Parse_error) - end; - - "two trails fail" >:: begin fun _ -> - (OUnit.assert_raises Parse_error @@ fun _ -> - try parse_json_from_string {| { "x": 3, 2 ,}|} with _ -> raise Parse_error) - end; - - "trail comma obj" >:: begin fun _ -> - let v = parse_json_from_string {| { "x" : 3 , }|} in - let v1 = parse_json_from_string {| { "x" : 3 , }|} in - let test (v : Ext_json_types.t) = - match v with - | Obj {map = v} -> - v - |? ("x" , `Flo (fun x -> OUnit.assert_equal x "3")) - |> ignore - | _ -> OUnit.assert_failure "trail comma" in - test v ; - test v1 - end - ; - "trail comma arr" >:: begin fun _ -> - let v = parse_json_from_string {| [ 1, 3, ]|} in - let v1 = parse_json_from_string {| [ 1, 3 ]|} in - let test (v : Ext_json_types.t) = - match v with - | Arr { content = [| Flo {flo = "1"} ; Flo { flo = "3"} |] } -> () - | _ -> OUnit.assert_failure "trailing comma array" in - test v ; - test v1 - end - ] diff --git a/jscomp/ounit_tests/ounit_list_test.ml b/jscomp/ounit_tests/ounit_list_test.ml deleted file mode 100644 index 2fe732e..0000000 --- a/jscomp/ounit_tests/ounit_list_test.ml +++ /dev/null @@ -1,145 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal -let printer_int_list = fun xs -> Format.asprintf "%a" - (Format.pp_print_list Format.pp_print_int - ~pp_sep:Format.pp_print_space - ) xs -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.flat_map [1;2] (fun x -> [x;x]) ) [1;1;2;2] - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.flat_map_append - [1;2] [3;4] (fun x -> [x;x]) ) [1;1;2;2;3;4] - end; - __LOC__ >:: begin fun _ -> - - let (=~) = OUnit.assert_equal ~printer:printer_int_list in - (Ext_list.flat_map [] (fun x -> [succ x ])) =~ []; - (Ext_list.flat_map [1] (fun x -> [x;succ x ]) ) =~ [1;2]; - (Ext_list.flat_map [1;2] (fun x -> [x;succ x ])) =~ [1;2;2;3]; - (Ext_list.flat_map [1;2;3] (fun x -> [x;succ x ]) ) =~ [1;2;2;3;3;4] - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.stable_group - [1;2;3;4;3] (=) - ) - ([[1];[2];[4];[3;3]]) - end - ; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:printer_int_list in - let f b _v = if b then 1 else 0 in - Ext_list.map_last [] f =~ []; - Ext_list.map_last [0] f =~ [1]; - Ext_list.map_last [0;0] f =~ [0;1]; - Ext_list.map_last [0;0;0] f =~ [0;0;1]; - Ext_list.map_last [0;0;0;0] f =~ [0;0;0;1]; - Ext_list.map_last [0;0;0;0;0] f =~ [0;0;0;0;1]; - Ext_list.map_last [0;0;0;0;0;0] f =~ [0;0;0;0;0;1]; - Ext_list.map_last [0;0;0;0;0;0;0] f =~ [0;0;0;0;0;0;1]; - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal ( - Ext_list.flat_map_append - [1;2] [false;false] - (fun x -> if x mod 2 = 0 then [true] else []) - ) [true;false;false] - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal ( - Ext_list.map_append - [0;1;2] - ["1";"2";"3"] - (fun x -> string_of_int x) - ) - ["0";"1";"2"; "1";"2";"3"] - end; - - __LOC__ >:: begin fun _ -> - let (a,b) = Ext_list.split_at [1;2;3;4;5;6] 3 in - OUnit.assert_equal (a,b) - ([1;2;3],[4;5;6]); - OUnit.assert_equal (Ext_list.split_at [1] 1) - ([1],[]) ; - OUnit.assert_equal (Ext_list.split_at [1;2;3] 2 ) - ([1;2],[3]) - end; - __LOC__ >:: begin fun _ -> - let printer = fun (a,b) -> - Format.asprintf "([%a],%d)" - (Format.pp_print_list Format.pp_print_int ) a - b - in - let (=~) = OUnit.assert_equal ~printer in - (Ext_list.split_at_last [1;2;3]) - =~ ([1;2],3); - (Ext_list.split_at_last [1;2;3;4;5;6;7;8]) - =~ - ([1;2;3;4;5;6;7],8); - (Ext_list.split_at_last [1;2;3;4;5;6;7;]) - =~ - ([1;2;3;4;5;6],7) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (Ext_list.assoc_by_int [2,"x"; 3,"y"; 1, "z"] 1 None) "z" - end; - __LOC__ >:: begin fun _ -> - Ounit_tests_util.assert_raise_any - (fun _ -> Ext_list.assoc_by_int [2,"x"; 3,"y"; 1, "z"] 11 None ) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (Ext_list.length_compare [0;0;0] 3) `Eq ; - OUnit.assert_equal - (Ext_list.length_compare [0;0;0] 1) `Gt ; - OUnit.assert_equal - (Ext_list.length_compare [0;0;0] 4) `Lt ; - OUnit.assert_equal - (Ext_list.length_compare [] (-1)) `Gt ; - OUnit.assert_equal - (Ext_list.length_compare [] (0)) `Eq ; - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [1;2] [1] 1 ); - OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [1;2] [1;2] 0); - OUnit.assert_bool __LOC__ - (Ext_list.length_larger_than_n [1;2] [] 2) - - end; - - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_list.length_ge [1;2;3] 3 ); - OUnit.assert_bool __LOC__ - (Ext_list.length_ge [] 0 ); - OUnit.assert_bool __LOC__ - (not (Ext_list.length_ge [] 1 )); - - end; - - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal in - - let f p x = Ext_list.exclude_with_val x p in - f (fun x -> x = 1) [1;2;3] =~ (Some [2;3]); - f (fun x -> x = 4) [1;2;3] =~ (None); - f (fun x -> x = 2) [1;2;3;2] =~ (Some [1;3]); - f (fun x -> x = 2) [1;2;2;3;2] =~ (Some [1;3]); - f (fun x -> x = 2) [2;2;2] =~ (Some []); - f (fun x -> x = 3) [2;2;2] =~ (None) - end ; - - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_map_tests.ml b/jscomp/ounit_tests/ounit_map_tests.ml deleted file mode 100644 index d75beb0..0000000 --- a/jscomp/ounit_tests/ounit_map_tests.ml +++ /dev/null @@ -1,59 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - -let test_sorted_strict arr = - let v = Map_int.of_array arr |> Map_int.to_sorted_array in - let arr_copy = Array.copy arr in - Array.sort (fun ((a:int),_) (b,_) -> compare a b ) arr_copy; - v =~ arr_copy - -let suites = - __MODULE__ >::: - [ - __LOC__ >:: begin fun _ -> - [1,"1"; 2,"2"; 12,"12"; 3, "3"] - |> Map_int.of_list - |> Map_int.keys - |> OUnit.assert_equal [1;2;3;12] - end - ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (Map_int.cardinal Map_int.empty) 0 ; - OUnit.assert_equal ([1,"1"; 2,"2"; 12,"12"; 3, "3"] - |> Map_int.of_list|>Map_int.cardinal ) 4 - end; - __LOC__ >:: begin fun _ -> - let v = - [1,"1"; 2,"2"; 12,"12"; 3, "3"] - |> Map_int.of_list - |> Map_int.to_sorted_array in - Array.length v =~ 4 ; - v =~ [|1,"1"; 2,"2"; 3, "3"; 12,"12"; |] - end; - __LOC__ >:: begin fun _ -> - test_sorted_strict [||]; - test_sorted_strict [|1,""|]; - test_sorted_strict [|2,""; 1,""|]; - test_sorted_strict [|2,""; 1,""; 3, ""|]; - test_sorted_strict [|2,""; 1,""; 3, ""; 4,""|] - end; - __LOC__ >:: begin fun _ -> - Map_int.cardinal (Map_int.of_array (Array.init 1000 (fun i -> (i,i)))) - =~ 1000 - end; - __LOC__ >:: begin fun _ -> - let count = 1000 in - let a = Array.init count (fun x -> x ) in - let v = Map_int.empty in - let u = - begin - let v = Array.fold_left (fun acc key -> Map_int.adjust acc key (fun v -> match v with None -> 1 | Some v -> succ v) ) v a in - Array.fold_left (fun acc key -> Map_int.adjust acc key (fun v -> match v with None -> 1 | Some v -> succ v) ) v a - end - in - Map_int.iter u (fun _ v -> v =~ 2 ) ; - Map_int.cardinal u =~ count - end - ] diff --git a/jscomp/ounit_tests/ounit_path_tests.ml b/jscomp/ounit_tests/ounit_path_tests.ml deleted file mode 100644 index 6cb5ad8..0000000 --- a/jscomp/ounit_tests/ounit_path_tests.ml +++ /dev/null @@ -1,145 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - - -let normalize = Ext_path.normalize_absolute_path -let (=~) x y = - OUnit.assert_equal - ~printer:(fun x -> x) - ~cmp:(fun x y -> Ext_string.equal x y ) x y - -let suites = - __FILE__ - >::: - [ - "linux path tests" >:: begin fun _ -> - let norm = - Array.map normalize - [| - "/gsho/./.."; - "/a/b/../c../d/e/f"; - "/a/b/../c/../d/e/f"; - "/gsho/./../.."; - "/a/b/c/d"; - "/a/b/c/d/"; - "/a/"; - "/a"; - "/a.txt/"; - "/a.txt" - |] in - OUnit.assert_equal norm - [| - "/"; - "/a/c../d/e/f"; - "/a/d/e/f"; - "/"; - "/a/b/c/d" ; - "/a/b/c/d"; - "/a"; - "/a"; - "/a.txt"; - "/a.txt" - |] - end; - __LOC__ >:: begin fun _ -> - normalize "/./a/.////////j/k//../////..///././b/./c/d/./." =~ "/a/b/c/d" - end; - __LOC__ >:: begin fun _ -> - normalize "/./a/.////////j/k//../////..///././b/./c/d/././../" =~ "/a/b/c" - end; - - __LOC__ >:: begin fun _ -> - let aux a b result = - - Ext_path.rel_normalized_absolute_path - ~from:a b =~ result ; - - Ext_path.rel_normalized_absolute_path - ~from:(String.sub a 0 (String.length a - 1)) - b =~ result ; - - Ext_path.rel_normalized_absolute_path - ~from:a - (String.sub b 0 (String.length b - 1)) =~ result - ; - - - Ext_path.rel_normalized_absolute_path - ~from:(String.sub a 0 (String.length a - 1 )) - (String.sub b 0 (String.length b - 1)) - =~ result - in - aux - "/a/b/c/" - "/a/b/c/d/" "./d"; - aux - "/a/b/c/" - "/a/b/c/d/e/f/" "./d/e/f" ; - aux - "/a/b/c/d/" - "/a/b/c/" ".." ; - aux - "/a/b/c/d/" - "/a/b/" "../.." ; - aux - "/a/b/c/d/" - "/a/" "../../.." ; - aux - "/a/b/c/d/" - "//" "../../../.." ; - - - end; - (* This is still correct just not optimal depends - on user's perspective *) - __LOC__ >:: begin fun _ -> - Ext_path.rel_normalized_absolute_path - ~from:"/a/b/c/d" - "/x/y" =~ "../../../../x/y" - - end; - - (* used in module system: [es6-global] and [amdjs-global] *) - __LOC__ >:: begin fun _ -> - Ext_path.rel_normalized_absolute_path - ~from:"/usr/local/lib/node_modules/" - "//" =~ "../../../.."; - Ext_path.rel_normalized_absolute_path - ~from:"/usr/local/lib/node_modules/" - "/" =~ "../../../.."; - Ext_path.rel_normalized_absolute_path - ~from:"./" - "./node_modules/xx/./xx.js" =~ "./node_modules/xx/xx.js"; - Ext_path.rel_normalized_absolute_path - ~from:"././" - "./node_modules/xx/./xx.js" =~ "./node_modules/xx/xx.js" - end; - - __LOC__ >:: begin fun _ -> - Ext_path.node_rebase_file - ~to_:( "lib/js/src/a") - ~from:( "lib/js/src") "b" =~ "./a/b" ; - Ext_path.node_rebase_file - ~to_:( "lib/js/src/") - ~from:( "lib/js/src") "b" =~ "./b" ; - Ext_path.node_rebase_file - ~to_:( "lib/js/src") - ~from:("lib/js/src/a") "b" =~ "../b"; - Ext_path.node_rebase_file - ~to_:( "lib/js/src/a") - ~from:("lib/js/") "b" =~ "./src/a/b" ; - Ext_path.node_rebase_file - ~to_:("lib/js/./src/a") - ~from:("lib/js/src/a/") "b" - =~ "./b"; - - Ext_path.node_rebase_file - ~to_:"lib/js/src/a" - ~from: "lib/js/src/a/" "b" - =~ "./b"; - Ext_path.node_rebase_file - ~to_:"lib/js/src/a/" - ~from:"lib/js/src/a/" "b" - =~ "./b" - end - ] diff --git a/jscomp/ounit_tests/ounit_scc_tests.ml b/jscomp/ounit_tests/ounit_scc_tests.ml deleted file mode 100644 index f20c087..0000000 --- a/jscomp/ounit_tests/ounit_scc_tests.ml +++ /dev/null @@ -1,392 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal - -let tiny_test_cases = {| -13 -22 - 4 2 - 2 3 - 3 2 - 6 0 - 0 1 - 2 0 -11 12 -12 9 - 9 10 - 9 11 - 7 9 -10 12 -11 4 - 4 3 - 3 5 - 6 8 - 8 6 - 5 4 - 0 5 - 6 4 - 6 9 - 7 6 -|} - -let medium_test_cases = {| -50 -147 - 0 7 - 0 34 - 1 14 - 1 45 - 1 21 - 1 22 - 1 22 - 1 49 - 2 19 - 2 25 - 2 33 - 3 4 - 3 17 - 3 27 - 3 36 - 3 42 - 4 17 - 4 17 - 4 27 - 5 43 - 6 13 - 6 13 - 6 28 - 6 28 - 7 41 - 7 44 - 8 19 - 8 48 - 9 9 - 9 11 - 9 30 - 9 46 -10 0 -10 7 -10 28 -10 28 -10 28 -10 29 -10 29 -10 34 -10 41 -11 21 -11 30 -12 9 -12 11 -12 21 -12 21 -12 26 -13 22 -13 23 -13 47 -14 8 -14 21 -14 48 -15 8 -15 34 -15 49 -16 9 -17 20 -17 24 -17 38 -18 6 -18 28 -18 32 -18 42 -19 15 -19 40 -20 3 -20 35 -20 38 -20 46 -22 6 -23 11 -23 21 -23 22 -24 4 -24 5 -24 38 -24 43 -25 2 -25 34 -26 9 -26 12 -26 16 -27 5 -27 24 -27 32 -27 31 -27 42 -28 22 -28 29 -28 39 -28 44 -29 22 -29 49 -30 23 -30 37 -31 18 -31 32 -32 5 -32 6 -32 13 -32 37 -32 47 -33 2 -33 8 -33 19 -34 2 -34 19 -34 40 -35 9 -35 37 -35 46 -36 20 -36 42 -37 5 -37 9 -37 35 -37 47 -37 47 -38 35 -38 37 -38 38 -39 18 -39 42 -40 15 -41 28 -41 44 -42 31 -43 37 -43 38 -44 39 -45 8 -45 14 -45 14 -45 15 -45 49 -46 16 -47 23 -47 30 -48 12 -48 21 -48 33 -48 33 -49 34 -49 22 -49 49 -|} -(* -reference output: -http://algs4.cs.princeton.edu/42digraph/KosarajuSharirSCC.java.html -*) - -let handle_lines tiny_test_cases = - match Ext_string.split tiny_test_cases '\n' with - | nodes :: _edges :: rest -> - let nodes_num = int_of_string nodes in - let node_array = - Array.init nodes_num - (fun _ -> Vec_int.empty () ) - in - begin - Ext_list.iter rest (fun x -> - match Ext_string.split x ' ' with - | [ a ; b] -> - let a , b = int_of_string a , int_of_string b in - Vec_int.push node_array.(a) b - | _ -> assert false - ); - node_array - end - | _ -> assert false - -let read_file file = - let in_chan = open_in_bin file in - let nodes_sum = int_of_string (input_line in_chan) in - let node_array = Array.init nodes_sum (fun _ -> Vec_int.empty () ) in - let rec aux () = - match input_line in_chan with - | exception End_of_file -> () - | x -> - begin match Ext_string.split x ' ' with - | [ a ; b] -> - let a , b = int_of_string a , int_of_string b in - Vec_int.push node_array.(a) b - | _ -> (* assert false *) () - end; - aux () in - print_endline "read data into memory"; - aux (); - (fst (Ext_scc.graph_check node_array)) (* 25 *) - - -let test (input : (string * string list) list) = - (* string -> int mapping - *) - let tbl = Hash_string.create 32 in - let idx = ref 0 in - let add x = - if not (Hash_string.mem tbl x ) then - begin - Hash_string.add tbl x !idx ; - incr idx - end in - input |> List.iter - (fun (x,others) -> List.iter add (x::others)); - let nodes_num = Hash_string.length tbl in - let node_array = - Array.init nodes_num - (fun _ -> Vec_int.empty () ) in - input |> - List.iter (fun (x,others) -> - let idx = Hash_string.find_exn tbl x in - others |> - List.iter (fun y -> Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y ) ) - ) ; - Ext_scc.graph_check node_array - -let test2 (input : (string * string list) list) = - (* string -> int mapping - *) - let tbl = Hash_string.create 32 in - let idx = ref 0 in - let add x = - if not (Hash_string.mem tbl x ) then - begin - Hash_string.add tbl x !idx ; - incr idx - end in - input |> List.iter - (fun (x,others) -> List.iter add (x::others)); - let nodes_num = Hash_string.length tbl in - let other_mapping = Array.make nodes_num "" in - Hash_string.iter tbl (fun k v -> other_mapping.(v) <- k ) ; - - let node_array = - Array.init nodes_num - (fun _ -> Vec_int.empty () ) in - input |> - List.iter (fun (x,others) -> - let idx = Hash_string.find_exn tbl x in - others |> - List.iter (fun y -> Vec_int.push node_array.(idx) (Hash_string.find_exn tbl y ) ) - ) ; - let output = Ext_scc.graph node_array in - output |> Int_vec_vec.map_into_array (fun int_vec -> Vec_int.map_into_array (fun i -> other_mapping.(i)) int_vec ) - - -let suites = - __FILE__ - >::: [ - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (fst @@ Ext_scc.graph_check (handle_lines tiny_test_cases)) 5 - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (fst @@ Ext_scc.graph_check (handle_lines medium_test_cases)) 10 - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", []; - ]) (3 , [1;2;1]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", []; - "e", [] - ]) (4, [1;1;2;1]) - (* {[ - a -> b - a -> c - b -> c - b -> d - c -> b - d - e - ]} - {[ - [d ; e ; [b;c] [a] ] - ]} - *) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", ["e"]; - "e", [] - ]) (4 , [1;2;1;1]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", ["e"]; - "e", ["c"] - ]) (2, [1;4]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", ["e"]; - "e", ["a"] - ]) (1, [5]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "a", ["b"]; - "b" , ["c" ]; - "c", [ ]; - "d", []; - "e", [] - ]) (5, [1;1;1;1;1]) - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test [ - "1", ["0"]; - "0" , ["2" ]; - "2", ["1" ]; - "0", ["3"]; - "3", [ "4"] - ]) (3, [3;1;1]) - end ; - (* http://algs4.cs.princeton.edu/42digraph/largeDG.txt *) - (* __LOC__ >:: begin fun _ -> *) - (* OUnit.assert_equal (read_file "largeDG.txt") 25 *) - (* end *) - (* ; *) - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test2 [ - "a", ["b" ; "c"]; - "b" , ["c" ; "d"]; - "c", [ "b"]; - "d", []; - ]) [|[|"d"|]; [|"b"; "c"|]; [|"a"|]|] - end ; - - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (test2 [ - "a", ["b"]; - "b" , ["c" ]; - "c", ["d" ]; - "d", ["e"]; - "e", [] - ]) [|[|"e"|]; [|"d"|]; [|"c"|]; [|"b"|]; [|"a"|]|] - end ; - - ] diff --git a/jscomp/ounit_tests/ounit_sexp_tests.ml b/jscomp/ounit_tests/ounit_sexp_tests.ml deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/ounit_tests/ounit_string_tests.ml b/jscomp/ounit_tests/ounit_string_tests.ml deleted file mode 100644 index 4b7a64f..0000000 --- a/jscomp/ounit_tests/ounit_string_tests.ml +++ /dev/null @@ -1,534 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal ~printer:Ext_obj.dump - -let printer_string = fun x -> x - -let string_eq = OUnit.assert_equal ~printer:(fun id -> id) - -let suites = - __FILE__ >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_bool "not found " (Ext_string.rindex_neg "hello" 'x' < 0 ) - end; - - __LOC__ >:: begin fun _ -> - Ext_string.rindex_neg "hello" 'h' =~ 0 ; - Ext_string.rindex_neg "hello" 'e' =~ 1 ; - Ext_string.rindex_neg "hello" 'l' =~ 3 ; - Ext_string.rindex_neg "hello" 'l' =~ 3 ; - Ext_string.rindex_neg "hello" 'o' =~ 4 ; - end; - (* __LOC__ >:: begin - fun _ -> - let nl cur s = Ext_string.extract_until s cur '\n' in - nl (ref 0) "hello\n" =~ "hello"; - nl (ref 0) "\nhell" =~ ""; - nl (ref 0) "hello" =~ "hello"; - let cur = ref 0 in - let b = "a\nb\nc\nd" in - nl cur b =~ "a"; - nl cur b =~ "b"; - nl cur b =~ "c"; - nl cur b =~ "d"; - nl cur b =~ "" ; - nl cur b =~ "" ; - cur := 0 ; - let b = "a\nb\nc\nd\n" in - nl cur b =~ "a"; - nl cur b =~ "b"; - nl cur b =~ "c"; - nl cur b =~ "d"; - nl cur b =~ "" ; - nl cur b =~ "" ; - end ; *) - __LOC__ >:: begin fun _ -> - let b = "a\nb\nc\nd\n" in - let a = Ext_string.index_count in - a b 0 '\n' 1 =~ 1 ; - a b 0 '\n' 2 =~ 3; - a b 0 '\n' 3 =~ 5; - a b 0 '\n' 4 =~ 7; - a b 0 '\n' 5 =~ -1; - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool "empty string" (Ext_string.rindex_neg "" 'x' < 0 ) - end; - - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (not (Ext_string.for_all_from "xABc"1 - (function 'A' .. 'Z' -> true | _ -> false))); - OUnit.assert_bool __LOC__ - ( (Ext_string.for_all_from "xABC" 1 - (function 'A' .. 'Z' -> true | _ -> false))); - OUnit.assert_bool __LOC__ - ( (Ext_string.for_all_from "xABC" 1_000 - (function 'A' .. 'Z' -> true | _ -> false))); - end; - - (* __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ @@ - List.for_all (fun x -> Ext_string.is_valid_source_name x = Good) - ["x.ml"; "x.mli"; "x.res"; "x.resi"; - "A_x.ml"; "ab.ml"; "a_.ml"; "a__.ml"; - "ax.ml"]; - OUnit.assert_bool __LOC__ @@ not @@ - List.exists (fun x -> Ext_string.is_valid_source_name x = Good) - [".res"; ".resi";"..res"; "..resi"; "..ml"; ".mll~"; - "...ml"; "_.mli"; "_x.ml"; "__.ml"; "__.rei"; - ".#hello.ml"; ".#hello.rei"; "a-.ml"; "a-b.ml"; "-a-.ml" - ; "-.ml" - ] - end; *) - __LOC__ >:: begin fun _ -> - Ext_filename.module_name "a/hello.ml" =~ "Hello"; - Ext_filename.as_module ~basename:"a.ml" =~ Some {module_name = "A"; case = false}; - Ext_filename.as_module ~basename:"Aa.ml" =~ Some {module_name = "Aa"; case = true}; - (* Ext_filename.as_module ~basename:"_Aa.ml" =~ None; *) - Ext_filename.as_module ~basename:"A_a" =~ Some {module_name = "A_a"; case = true}; - Ext_filename.as_module ~basename:"" =~ None; - Ext_filename.as_module ~basename:"a/hello.ml" =~ - None - - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ @@ - List.for_all Ext_namespace.is_valid_npm_package_name - ["x"; "@angualr"; "test"; "hi-x"; "hi-"] - ; - OUnit.assert_bool __LOC__ @@ - List.for_all - (fun x -> not (Ext_namespace.is_valid_npm_package_name x)) - ["x "; "x'"; "Test"; "hI"] - ; - end; - __LOC__ >:: begin fun _ -> - Ext_string.find ~sub:"hello" "xx hello xx" =~ 3 ; - Ext_string.rfind ~sub:"hello" "xx hello xx" =~ 3 ; - Ext_string.find ~sub:"hello" "xx hello hello xx" =~ 3 ; - Ext_string.rfind ~sub:"hello" "xx hello hello xx" =~ 9 ; - end; - __LOC__ >:: begin fun _ -> - Ext_string.non_overlap_count ~sub:"0" "1000,000" =~ 6; - Ext_string.non_overlap_count ~sub:"0" "000000" =~ 6; - Ext_string.non_overlap_count ~sub:"00" "000000" =~ 3; - Ext_string.non_overlap_count ~sub:"00" "00000" =~ 2 - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "abc"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "a"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "b"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" "c"); - OUnit.assert_bool __LOC__ (Ext_string.contain_substring "abc" ""); - OUnit.assert_bool __LOC__ (not @@ Ext_string.contain_substring "abc" "abcc"); - end; - __LOC__ >:: begin fun _ -> - Ext_string.trim " \t\n" =~ ""; - Ext_string.trim " \t\nb" =~ "b"; - Ext_string.trim "b \t\n" =~ "b"; - Ext_string.trim "\t\n b \t\n" =~ "b"; - end; - __LOC__ >:: begin fun _ -> - Ext_string.starts_with "ab" "a" =~ true; - Ext_string.starts_with "ab" "" =~ true; - Ext_string.starts_with "abb" "abb" =~ true; - Ext_string.starts_with "abb" "abbc" =~ false; - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> string_of_bool x ) in - let k = Ext_string.ends_with in - k "xx.ml" ".ml" =~ true; - k "xx.bs.js" ".js" =~ true ; - k "xx" ".x" =~false; - k "xx" "" =~true - end; - __LOC__ >:: begin fun _ -> - Ext_string.ends_with_then_chop "xx.ml" ".ml" =~ Some "xx"; - Ext_string.ends_with_then_chop "xx.ml" ".mll" =~ None - end; - (* __LOC__ >:: begin fun _ -> - Ext_string.starts_with_and_number "js_fn_mk_01" ~offset:0 "js_fn_mk_" =~ 1 ; - Ext_string.starts_with_and_number "js_fn_run_02" ~offset:0 "js_fn_mk_" =~ -1 ; - Ext_string.starts_with_and_number "js_fn_mk_03" ~offset:6 "mk_" =~ 3 ; - Ext_string.starts_with_and_number "js_fn_mk_04" ~offset:6 "run_" =~ -1; - Ext_string.starts_with_and_number "js_fn_run_04" ~offset:6 "run_" =~ 4; - Ext_string.(starts_with_and_number "js_fn_run_04" ~offset:6 "run_" = 3) =~ false - end; *) - __LOC__ >:: begin fun _ -> - Ext_string.for_all "____" (function '_' -> true | _ -> false) - =~ true; - Ext_string.for_all "___-" (function '_' -> true | _ -> false) - =~ false; - Ext_string.for_all "" (function '_' -> true | _ -> false) - =~ true - end; - __LOC__ >:: begin fun _ -> - Ext_string.tail_from "ghsogh" 1 =~ "hsogh"; - Ext_string.tail_from "ghsogh" 0 =~ "ghsogh" - end; - (* __LOC__ >:: begin fun _ -> - Ext_string.digits_of_str "11_js" ~offset:0 2 =~ 11 - end; *) - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.replace_backward_slash "a:\\b\\d" = - "a:/b/d" - ) ; - OUnit.assert_bool __LOC__ - (Ext_string.replace_backward_slash "a:\\b\\d\\" = - "a:/b/d/" - ) ; - OUnit.assert_bool __LOC__ - (Ext_string.replace_slash_backward "a:/b/d/"= - "a:\\b\\d\\" - ) ; - OUnit.assert_bool __LOC__ - (let old = "a:bd" in - Ext_string.replace_backward_slash old == - old - ) ; - OUnit.assert_bool __LOC__ - (let old = "a:bd" in - Ext_string.replace_backward_slash old == - old - ) ; - - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.no_slash "ahgoh" ); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash "" ); - OUnit.assert_bool __LOC__ - (not (Ext_string.no_slash "ahgoh/" )); - OUnit.assert_bool __LOC__ - (not (Ext_string.no_slash "/ahgoh" )); - OUnit.assert_bool __LOC__ - (not (Ext_string.no_slash "/ahgoh/" )); - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ (Ext_string.compare "" "" = 0); - OUnit.assert_bool __LOC__ (Ext_string.compare "0" "0" = 0); - OUnit.assert_bool __LOC__ (Ext_string.compare "" "acd" < 0); - OUnit.assert_bool __LOC__ (Ext_string.compare "acd" "" > 0); - for i = 0 to 256 do - let a = String.init i (fun _ -> '0') in - let b = String.init i (fun _ -> '0') in - OUnit.assert_bool __LOC__ (Ext_string.compare b a = 0); - OUnit.assert_bool __LOC__ (Ext_string.compare a b = 0) - done ; - for i = 0 to 256 do - let a = String.init i (fun _ -> '0') in - let b = String.init i (fun _ -> '0') ^ "\000"in - OUnit.assert_bool __LOC__ (Ext_string.compare a b < 0); - OUnit.assert_bool __LOC__ (Ext_string.compare b a > 0) - done ; - - end; - __LOC__ >:: begin fun _ -> - let slow_compare x y = - let x_len = String.length x in - let y_len = String.length y in - if x_len = y_len then - String.compare x y - else - Stdlib.compare x_len y_len in - let same_sign x y = - if x = 0 then y = 0 - else if x < 0 then y < 0 - else y > 0 in - for _ = 0 to 3000 do - let chars = [|'a';'b';'c';'d'|] in - let x = Ounit_data_random.random_string chars 129 in - let y = Ounit_data_random.random_string chars 129 in - let a = Ext_string.compare x y in - let b = slow_compare x y in - if same_sign a b then OUnit.assert_bool __LOC__ true - else failwith ("incosistent " ^ x ^ " " ^ y ^ " " ^ string_of_int a ^ " " ^ string_of_int b) - done - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat3 "a0" "a1" "a2") "a0a1a2" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat3 "a0" "a11" "") "a0a11" - ); - - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat4 "a0" "a1" "a2" "a3") "a0a1a2a3" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat4 "a0" "a11" "" "a33") "a0a11a33" - ); - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.inter2 "a0" "a1") "a0 a1" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.inter3 "a0" "a1" "a2") "a0 a1 a2" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.inter4 "a0" "a1" "a2" "a3") "a0 a1 a2 a3" - ); - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "" < 0); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "xxx" < 0); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "xxx/" = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "xxx/g/" = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx "/xxx/g/" = 0) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx" 0 < 0); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx/" 1 = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx/g/" 4 = 5); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "xxx/g/" 3 = 3); - OUnit.assert_bool __LOC__ - (Ext_string.no_slash_idx_from "/xxx/g/" 0 = 0) - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [||]) - Ext_string.empty - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0"|]) - "a0" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"|]) - "a0 a1" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"; "a2"|]) - "a0 a1 a2" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"; "a2";"a3"|]) - "a0 a1 a2 a3" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"a0";"a1"; "a2";"a3";""; "a4"|]) - "a0 a1 a2 a3 a4" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"0";"a1"; "2";"a3";""; "a4"|]) - "0 a1 2 a3 a4" - ); - OUnit.assert_bool __LOC__ - (Ext_string.equal - (Ext_string.concat_array Ext_string.single_space [|"0";"a1"; "2";"3";"d"; ""; "e"|]) - "0 a1 2 3 d e" - ); - - end; - - __LOC__ >:: begin fun _ -> - Ext_namespace.namespace_of_package_name "bs-json" - =~ "BsJson" - end; - __LOC__ >:: begin fun _ -> - Ext_namespace.namespace_of_package_name "xx" - =~ "Xx" - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in - Ext_namespace.namespace_of_package_name - "reason-react" - =~ "ReasonReact"; - Ext_namespace.namespace_of_package_name - "Foo_bar" - =~ "Foo_bar"; - Ext_namespace.namespace_of_package_name - "reason" - =~ "Reason"; - Ext_namespace.namespace_of_package_name - "@aa/bb" - =~"AaBb"; - Ext_namespace.namespace_of_package_name - "@A/bb" - =~"ABb" - end; - __LOC__ >:: begin fun _ -> - Ext_namespace.change_ext_ns_suffix "a-b" Literals.suffix_js - =~ "a.js"; - Ext_namespace.change_ext_ns_suffix "a-" Literals.suffix_js - =~ "a.js"; - Ext_namespace.change_ext_ns_suffix "a--" Literals.suffix_js - =~ "a-.js"; - Ext_namespace.change_ext_ns_suffix "AA-b" Literals.suffix_js - =~ "AA.js"; - Ext_namespace.js_name_of_modulename "AA-b" Little Literals.suffix_js - =~ "aA.js"; - Ext_namespace.js_name_of_modulename "AA-b" Upper Literals.suffix_js - =~ "AA.js"; - Ext_namespace.js_name_of_modulename "AA-b" Upper ".bs.js" - =~ "AA.bs.js"; - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> - match x with - | None -> "" - | Some (a,b) -> a ^","^ b - ) in - Ext_namespace.try_split_module_name "Js-X" =~ Some ("X","Js"); - Ext_namespace.try_split_module_name "Js_X" =~ None - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in - let f = Ext_string.capitalize_ascii in - f "x" =~ "X"; - f "X" =~ "X"; - f "" =~ ""; - f "abc" =~ "Abc"; - f "_bc" =~ "_bc"; - let v = "bc" in - f v =~ "Bc"; - v =~ "bc" - end; - __LOC__ >:: begin fun _ -> - let (=~) = OUnit.assert_equal ~printer:printer_string in - Ext_filename.chop_all_extensions_maybe "a.bs.js" =~ "a" ; - Ext_filename.chop_all_extensions_maybe "a.js" =~ "a"; - Ext_filename.chop_all_extensions_maybe "a" =~ "a"; - Ext_filename.chop_all_extensions_maybe "a.x.bs.js" =~ "a" - end; - (* let (=~) = OUnit.assert_equal ~printer:(fun x -> x) in *) - __LOC__ >:: begin fun _ -> - let k = Ext_modulename.js_id_name_of_hint_name in - k "xx" =~ "Xx"; - k "react-dom" =~ "ReactDom"; - k "a/b/react-dom" =~ "ReactDom"; - k "a/b" =~ "B"; - k "a/" =~ "A/" ; (*TODO: warning?*) - k "#moduleid" =~ "Moduleid"; - k "@bundle" =~ "Bundle"; - k "xx#bc" =~ "Xxbc"; - k "hi@myproj" =~ "Himyproj"; - k "ab/c/xx.b.js" =~ "XxBJs"; (* improve it in the future*) - k "c/d/a--b"=~ "AB"; - k "c/d/ac--" =~ "Ac" - end ; - __LOC__ >:: begin fun _ -> - Ext_string.capitalize_sub "ab-Ns.cmi" 2 =~ "Ab"; - Ext_string.capitalize_sub "Ab-Ns.cmi" 2 =~ "Ab"; - Ext_string.capitalize_sub "Ab-Ns.cmi" 3 =~ "Ab-" - end ; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal - (String.length (Digest.string "")) - Ext_digest.length - end; - - __LOC__ >:: begin fun _ -> - let bench = String.concat - ";" (Ext_list.init 11 (fun i -> string_of_int i)) in - let buf = Ext_buffer.create 10 in - OUnit.assert_bool - __LOC__ (Ext_buffer.not_equal buf bench); - for i = 0 to 9 do - Ext_buffer.add_string buf (string_of_int i); - Ext_buffer.add_string buf ";" - done ; - OUnit.assert_bool - __LOC__ (Ext_buffer.not_equal buf bench); - Ext_buffer.add_string buf "10" ; - (* print_endline (Ext_buffer.contents buf); - print_endline bench; *) - OUnit.assert_bool - __LOC__ (not (Ext_buffer.not_equal buf bench)) - end ; - - __LOC__ >:: begin fun _ -> - string_eq (Ext_filename.new_extension "a.c" ".xx") "a.xx"; - string_eq (Ext_filename.new_extension "abb.c" ".xx") "abb.xx"; - string_eq (Ext_filename.new_extension ".c" ".xx") ".xx"; - string_eq (Ext_filename.new_extension "a/b" ".xx") "a/b.xx"; - string_eq (Ext_filename.new_extension "a/b." ".xx") "a/b.xx"; - string_eq (Ext_filename.chop_all_extensions_maybe "a.b.x") "a"; - string_eq (Ext_filename.chop_all_extensions_maybe "a.b") "a"; - string_eq (Ext_filename.chop_all_extensions_maybe ".a.b.x") ""; - string_eq (Ext_filename.chop_all_extensions_maybe "abx") "abx"; - end; - __LOC__ >:: begin fun _ -> - string_eq - (Ext_filename.module_name "a/b/c.d") - "C"; - string_eq - (Ext_filename.module_name "a/b/xc.res") - "Xc"; - string_eq - (Ext_filename.module_name "a/b/xc.resi") - "Xc"; - string_eq - (Ext_filename.module_name "a/b/xc.ml") - "Xc" ; - string_eq - (Ext_filename.module_name "a/b/xc.mli") - "Xc" ; - string_eq - (Ext_filename.module_name "a/b/xc.cppo.mli") - "Xc.cppo"; - string_eq - (Ext_filename.module_name "a/b/xc.cppo.") - "Xc.cppo" ; - string_eq - (Ext_filename.module_name "a/b/xc..") - "Xc." ; - string_eq - (Ext_filename.module_name "a/b/Xc..") - "Xc." ; - string_eq - (Ext_filename.module_name "a/b/.") - "" ; - end; - __LOC__ >:: begin fun _ -> - Ext_string.split "" ':' =~ []; - Ext_string.split "a:b:" ':' =~ ["a";"b"]; - Ext_string.split "a:b:" ':' ~keep_empty:true =~ ["a";"b";""] - end; - __LOC__ >:: begin fun _ -> - let cmp0 = Ext_string.compare in - let cmp1 = Map_string.compare_key in - let f a b = - cmp0 a b =~ cmp1 a b ; - cmp0 b a =~ cmp1 b a - in - (* This is needed since deserialization/serialization - needs to be synced up for .bsbuild decoding - *) - f "a" "A"; - f "bcdef" "abcdef"; - f "" "A"; - f "Abcdef" "abcdef"; - end - ] - diff --git a/jscomp/ounit_tests/ounit_tests_main.ml b/jscomp/ounit_tests/ounit_tests_main.ml deleted file mode 100644 index b3f4543..0000000 --- a/jscomp/ounit_tests/ounit_tests_main.ml +++ /dev/null @@ -1,52 +0,0 @@ -[@@@warning "-32"] - -module Int_array = Vec.Make (struct - type t = int - - let null = 0 -end) - -let v = Int_array.init 10 (fun i -> i) - -let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) - -let ( =~ ) x y = - OUnit.assert_equal ~cmp:(Int_array.equal (fun (x : int) y -> x = y)) x y - -let ( =~~ ) x y = - OUnit.assert_equal - ~cmp:(Int_array.equal (fun (x : int) y -> x = y)) - x (Int_array.of_array y) - -let suites = - __FILE__ - >::: [ - Ounit_vec_test.suites; - Ounit_json_tests.suites; - Ounit_path_tests.suites; - Ounit_array_tests.suites; - Ounit_scc_tests.suites; - Ounit_list_test.suites; - Ounit_hash_set_tests.suites; - Ounit_union_find_tests.suites; - Ounit_bal_tree_tests.suites; - Ounit_hash_stubs_test.suites; - Ounit_map_tests.suites; - Ounit_hashtbl_tests.suites; - Ounit_string_tests.suites; - Ounit_topsort_tests.suites; - (* Ounit_sexp_tests.suites; *) - Ounit_int_vec_tests.suites; - Ounit_ident_mask_tests.suites; - Ounit_cmd_tests.suites; - Ounit_ffi_error_debug_test.suites; - Ounit_js_regex_checker_tests.suites; - Ounit_utf8_test.suites; - Ounit_unicode_tests.suites; - Ounit_bsb_regex_tests.suites; - Ounit_bsb_pkg_tests.suites; - Ounit_depends_format_test.suites; - Ounit_util_tests.suites; - ] - -let _ = OUnit.run_test_tt_main suites diff --git a/jscomp/ounit_tests/ounit_tests_main.mli b/jscomp/ounit_tests/ounit_tests_main.mli deleted file mode 100644 index e69de29..0000000 diff --git a/jscomp/ounit_tests/ounit_tests_util.ml b/jscomp/ounit_tests/ounit_tests_util.ml deleted file mode 100644 index d183634..0000000 --- a/jscomp/ounit_tests/ounit_tests_util.ml +++ /dev/null @@ -1,46 +0,0 @@ -let raises f = - try - ignore (f ()); - None - with e -> - Some e - -let assert_raise_any ?msg (f: unit -> 'a) = - let get_error_string () = - let str = - Format.sprintf - "expected exception, but no exception was raised." - in - match msg with - | None -> - OUnit.assert_failure str - | Some s -> - OUnit.assert_failure (s^"\n"^str) - in - match raises f with - | None -> - OUnit.assert_failure (get_error_string ()) - | Some exn -> - OUnit.assert_bool (Printexc.to_string exn) true - -let time ?nums description f = - match nums with - | None -> - begin - let start = Unix.gettimeofday () in - ignore @@ f (); - let finish = Unix.gettimeofday () in - Printf.printf "\n%s elapsed %f\n" description (finish -. start) ; - flush stdout; - end - - | Some nums -> - begin - let start = Unix.gettimeofday () in - for _i = 0 to nums - 1 do - ignore @@ f (); - done ; - let finish = Unix.gettimeofday () in - Printf.printf "\n%s elapsed %f\n" description (finish -. start) ; - flush stdout; - end diff --git a/jscomp/ounit_tests/ounit_topsort_tests.ml b/jscomp/ounit_tests/ounit_topsort_tests.ml deleted file mode 100644 index 0a94176..0000000 --- a/jscomp/ounit_tests/ounit_topsort_tests.ml +++ /dev/null @@ -1,70 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let handle graph = - let len = List.length graph in - let result = Ext_topsort.Edge_vec.make len in - List.iter (fun (id,deps) -> - Ext_topsort.Edge_vec.push result {id ; deps = Vec_int.of_list deps } - ) graph; - result - - -let graph1 = - [ - 0, [1;2]; - 1, [2;3]; - 2, [4]; - 3, []; - 4, [] - ], [[0]; [1]; [2] ; [3;4]] - - -let graph2 = - [ - 0, [1;2]; - 1, [2;3]; - 2, [4]; - 3, [5]; - 4, [5]; - 5, [] - ], - [[0]; [1]; [2] ; [3;4]; [5]] - -let graph3 = - [ 0,[1;2;3;4;5]; - 1, [6;7;8] ; - 2, [6;7;8]; - 3, [6;7;8]; - 4, [6;7;8]; - 5, [6;7;8]; - 6, []; - 7, [] ; - 8, [] - ], - [[0]; [1;2;3;4;5]; [6; 7; 8]] - - -let expect loc (graph1, v) = - let graph = handle graph1 in - let queue = Ext_topsort.layered_dfs graph in - OUnit.assert_bool loc - (Queue.fold (fun acc x -> Set_int.elements x::acc) [] queue = - v) - - - - - -let (=~) = OUnit.assert_equal -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - expect __LOC__ graph1; - expect __LOC__ graph2 ; - expect __LOC__ graph3 - end - - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_unicode_tests.ml b/jscomp/ounit_tests/ounit_unicode_tests.ml deleted file mode 100644 index 0c289da..0000000 --- a/jscomp/ounit_tests/ounit_unicode_tests.ml +++ /dev/null @@ -1,246 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) a b = - OUnit.assert_equal ~cmp:Ext_string.equal a b - -(** Test for single line *) -let (==~) a b = - OUnit.assert_equal - ( - Ext_list.map (Ast_utf8_string_interp.transform_test a - |> List.filter (fun x -> not @@ Ast_utf8_string_interp.empty_segment x)) - (fun - ({start = {offset = a}; finish = {offset = b}; kind ; content } - : Ast_utf8_string_interp.segment) -> - a,b,kind,content - ) - ) - b - -let (==*) a b = - let segments = - Ext_list.map ( - Ast_utf8_string_interp.transform_test a - |> List.filter (fun x -> not @@ Ast_utf8_string_interp.empty_segment x) - )(fun - ({start = {lnum=la; offset = a}; finish = {lnum = lb; offset = b}; kind ; content } - : Ast_utf8_string_interp.segment) -> - la,a,lb,b,kind,content - ) - in - OUnit.assert_equal segments b - -let varParen : Ast_utf8_string_interp.kind = Var (2,-1) -let var : Ast_utf8_string_interp.kind = Var (1,0) -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test {|x|} =~ {|x|} - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "a\nb" =~ {|a\nb|} - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test - "\\n" =~ "\\n" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test {|\h\e\l\lo \"world\"!|} =~ {|\h\e\l\lo \"world\"!|} - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "\\u{1d306}" =~ "\\u{1d306}" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "unicode escape: \\u{1d306}" =~ "unicode escape: \\u{1d306}" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test "unicode escape: \\u{1d306} with suffix text" =~ "unicode escape: \\u{1d306} with suffix text" - end; - __LOC__ >:: begin fun _ -> - Ast_utf8_string.transform_test - "\\\\\\b\\t\\n\\v\\f\\r\\0\\$" =~ - "\\\\\\b\\t\\n\\v\\f\\r\\0\\$" - end; - - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {|\|} with - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 1 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {|你\|} with - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 2 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {|你BuckleScript,好啊\uffff\|} with - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 23 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {js|\u{110000}|js} with (* bigger than max valid unicode codepoint *) - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 3 - | _ -> OUnit.assert_failure __LOC__ - end ; - __LOC__ >:: begin fun _ -> - match Ast_utf8_string.transform_test - {js|\u{FFFFFFFFFFFFFFFFFFFFFFFFFFFFF}|js} with (* overflow *) - | exception Ast_utf8_string.Error(offset,_) -> - OUnit.assert_equal offset 3 - | _ -> OUnit.assert_failure __LOC__ - end ; - - __LOC__ >:: begin fun _ -> - "hie $x hi 你好" ==~ - [ - 0,4, String, "hie "; - 4,6, var, "x"; - 6,12,String, " hi 你好" - ] - end; - __LOC__ >:: begin fun _ -> - "x" ==~ - [0,1, String, "x"] - end; - - __LOC__ >:: begin fun _ -> - "" ==~ - [] - end; - __LOC__ >:: begin fun _ -> - "你好" ==~ - [0,2,String, "你好"] - end; - __LOC__ >:: begin fun _ -> - "你好$x" ==~ - [0,2,String, "你好"; - 2,4,var, "x"; - - ] - end - ; - __LOC__ >:: begin fun _ -> - "你好$this" ==~ - [ - 0,2,String, "你好"; - 2,7,var, "this"; - ] - end - ; - __LOC__ >:: begin fun _ -> - "你好$(this)" ==~ - [ - 0,2,String, "你好"; - 2,9,varParen, "this" - ]; - - "你好$this)" ==~ - [ - 0,2,String, "你好"; - 2,7,var, "this"; - 7,8,String,")" - ]; - {|\xff\xff你好 $x |} ==~ - [ - 0,11,String, {|\xff\xff你好 |}; - 11,13, var, "x"; - 13,14, String, " " - ]; - {|\xff\xff你好 $x 不吃亏了buckle $y $z = $sum|} - ==~ - [(0, 11, String,{|\xff\xff你好 |} ); - (11, 13, var, "x"); - (13, 25, String,{| 不吃亏了buckle |} ); - (25, 27, var, "y"); - (27, 28, String, " "); - (28, 30, var, "z"); - (30, 33, String, " = "); - (33, 37, var, "sum"); - ] - end - ; - __LOC__ >:: begin fun _ -> - "你好 $(this_is_a_var) x" ==~ - [ - 0,3,String, "你好 "; - 3,19,varParen, "this_is_a_var"; - 19,22, String, " x" - ] - end - ; - - __LOC__ >:: begin fun _ -> - "hi\n$x\n" ==* - [ - 0,0,1,0,String, "hi\\n"; - 1,0,1,2,var, "x" ; - 1,2,2,0,String,"\\n" - ]; - "$x" ==* - [0,0,0,2,var,"x"]; - - - "\n$x\n" ==* - [ - 0,0,1,0,String,"\\n"; - 1,0,1,2,var,"x"; - 1,2,2,0,String,"\\n" - ] - end; - - __LOC__ >:: begin fun _ -> - "\n$(x_this_is_cool) " ==* - [ - 0,0,1,0,String, "\\n"; - 1,0,1,17,varParen, "x_this_is_cool"; - 1,17,1,18,String, " " - ] - end; - __LOC__ >:: begin fun _ -> - " $x + $y = $sum " ==* - [ - 0,0,0,1,String , " "; - 0,1,0,3,var, "x"; - 0,3,0,6,String, " + "; - 0,6,0,8,var, "y"; - 0,8,0,11,String, " = "; - 0,11,0,15,var, "sum"; - 0,15,0,16,String, " " - ] - end; - __LOC__ >:: begin fun _ -> - "中文 | $a " ==* - [ - 0,0,0,5,String, "中文 | "; - 0,5,0,7,var, "a"; - 0,7,0,8,String, " " - ] - end - ; - __LOC__ >:: begin fun _ -> - {|Hello \\$world|} ==* - [ - 0,0,0,8,String,"Hello \\\\"; - 0,8,0,14,var, "world" - ] - end - ; - __LOC__ >:: begin fun _ -> - {|$x)|} ==* - [ - 0,0,0,2,var,"x"; - 0,2,0,3,String,")" - ] - end; - ] diff --git a/jscomp/ounit_tests/ounit_union_find_tests.ml b/jscomp/ounit_tests/ounit_union_find_tests.ml deleted file mode 100644 index 1c8b406..0000000 --- a/jscomp/ounit_tests/ounit_union_find_tests.ml +++ /dev/null @@ -1,984 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal -let tinyUF = {|10 - 4 3 - 3 8 - 6 5 - 9 4 - 2 1 - 8 9 - 5 0 - 7 2 - 6 1 - 1 0 - 6 7 - |} -let mediumUF = {|625 - 528 503 - 548 523 - 389 414 - 446 421 - 552 553 - 154 155 - 173 174 - 373 348 - 567 542 - 44 43 - 370 345 - 546 547 - 204 229 - 404 429 - 240 215 - 364 389 - 612 611 - 513 512 - 377 376 - 468 443 - 410 435 - 243 218 - 347 322 - 580 581 - 188 163 - 61 36 - 545 546 - 93 68 - 84 83 - 94 69 - 7 8 - 619 618 - 314 339 - 155 156 - 150 175 - 605 580 - 118 93 - 385 360 - 459 458 - 167 168 - 107 108 - 44 69 - 335 334 - 251 276 - 196 197 - 501 502 - 212 187 - 251 250 - 269 270 - 332 331 - 125 150 - 391 416 - 366 367 - 65 40 - 515 540 - 248 273 - 34 9 - 480 479 - 198 173 - 463 488 - 111 86 - 524 499 - 28 27 - 323 324 - 198 199 - 146 147 - 133 158 - 416 415 - 103 102 - 457 482 - 57 82 - 88 113 - 535 560 - 181 180 - 605 606 - 481 456 - 127 102 - 470 445 - 229 254 - 169 170 - 386 385 - 383 384 - 153 152 - 541 542 - 36 37 - 474 473 - 126 125 - 534 509 - 154 129 - 591 592 - 161 186 - 209 234 - 88 87 - 61 60 - 161 136 - 472 447 - 239 240 - 102 101 - 342 343 - 566 565 - 567 568 - 41 42 - 154 153 - 471 496 - 358 383 - 423 448 - 241 242 - 292 293 - 363 364 - 361 362 - 258 283 - 75 100 - 61 86 - 81 106 - 52 27 - 230 255 - 309 334 - 378 379 - 136 111 - 439 464 - 532 533 - 166 191 - 523 522 - 210 211 - 115 140 - 347 346 - 218 217 - 561 560 - 526 501 - 174 149 - 258 259 - 77 52 - 36 11 - 307 306 - 577 552 - 62 61 - 450 425 - 569 570 - 268 293 - 79 78 - 233 208 - 571 570 - 534 535 - 527 552 - 224 199 - 409 408 - 521 520 - 621 622 - 493 518 - 107 106 - 511 510 - 298 299 - 37 62 - 224 249 - 405 380 - 236 237 - 120 121 - 393 418 - 206 231 - 287 288 - 593 568 - 34 59 - 483 484 - 226 227 - 73 74 - 276 277 - 588 587 - 288 313 - 410 385 - 506 505 - 597 598 - 337 312 - 55 56 - 300 325 - 135 134 - 4 29 - 501 500 - 438 437 - 311 312 - 598 599 - 320 345 - 211 236 - 587 562 - 74 99 - 473 498 - 278 279 - 394 369 - 123 148 - 233 232 - 252 277 - 177 202 - 160 185 - 331 356 - 192 191 - 119 118 - 576 601 - 317 316 - 462 487 - 42 43 - 336 311 - 515 490 - 13 14 - 210 235 - 473 448 - 342 341 - 340 315 - 413 388 - 514 515 - 144 143 - 146 145 - 541 566 - 128 103 - 184 159 - 488 489 - 454 455 - 82 83 - 70 45 - 221 222 - 241 240 - 412 411 - 591 590 - 592 593 - 276 301 - 452 453 - 256 255 - 397 372 - 201 200 - 232 207 - 466 465 - 561 586 - 417 442 - 409 434 - 238 239 - 389 390 - 26 1 - 510 485 - 283 282 - 281 306 - 449 474 - 324 349 - 121 146 - 111 112 - 434 435 - 507 508 - 103 104 - 319 294 - 455 480 - 558 557 - 291 292 - 553 578 - 392 391 - 552 551 - 55 80 - 538 539 - 367 392 - 340 365 - 272 297 - 266 265 - 401 376 - 279 280 - 516 515 - 178 177 - 572 571 - 154 179 - 263 262 - 6 31 - 323 348 - 481 506 - 178 179 - 526 527 - 444 469 - 273 274 - 132 133 - 275 300 - 261 236 - 344 369 - 63 38 - 5 30 - 301 300 - 86 87 - 9 10 - 344 319 - 428 427 - 400 375 - 350 375 - 235 236 - 337 336 - 616 615 - 381 380 - 58 59 - 492 493 - 555 556 - 459 434 - 368 369 - 407 382 - 166 141 - 70 95 - 380 355 - 34 35 - 49 24 - 126 127 - 403 378 - 509 484 - 613 588 - 208 207 - 143 168 - 406 431 - 263 238 - 595 596 - 218 193 - 183 182 - 195 220 - 381 406 - 64 65 - 371 372 - 531 506 - 218 219 - 144 145 - 475 450 - 547 548 - 363 362 - 337 362 - 214 239 - 110 111 - 600 575 - 105 106 - 147 148 - 599 574 - 622 623 - 319 320 - 36 35 - 258 233 - 266 267 - 481 480 - 414 439 - 169 168 - 479 478 - 224 223 - 181 182 - 351 326 - 466 441 - 85 60 - 140 165 - 91 90 - 263 264 - 188 187 - 446 447 - 607 606 - 341 316 - 143 142 - 443 442 - 354 353 - 162 137 - 281 256 - 549 574 - 407 408 - 575 550 - 171 170 - 389 388 - 390 391 - 250 225 - 536 537 - 227 228 - 84 59 - 139 140 - 485 484 - 573 598 - 356 381 - 314 315 - 299 324 - 370 395 - 166 165 - 63 62 - 507 506 - 426 425 - 479 454 - 545 570 - 376 375 - 572 597 - 606 581 - 278 277 - 303 302 - 190 165 - 230 205 - 175 200 - 529 528 - 18 17 - 458 457 - 514 513 - 617 616 - 298 323 - 162 161 - 471 472 - 81 56 - 182 207 - 539 564 - 573 572 - 596 621 - 64 39 - 571 546 - 554 555 - 388 363 - 351 376 - 304 329 - 123 122 - 135 160 - 157 132 - 599 624 - 451 426 - 162 187 - 502 477 - 508 483 - 141 140 - 303 328 - 551 576 - 471 446 - 161 160 - 465 490 - 3 2 - 138 113 - 309 284 - 452 451 - 414 413 - 540 565 - 210 185 - 350 325 - 383 382 - 2 1 - 598 623 - 97 72 - 485 460 - 315 316 - 19 20 - 31 32 - 546 521 - 320 321 - 29 54 - 330 331 - 92 67 - 480 505 - 274 249 - 22 47 - 304 279 - 493 468 - 424 423 - 39 40 - 164 165 - 269 268 - 445 446 - 228 203 - 384 409 - 390 365 - 283 308 - 374 399 - 361 386 - 94 119 - 237 262 - 43 68 - 295 270 - 400 425 - 360 335 - 122 121 - 469 468 - 189 188 - 377 352 - 367 342 - 67 42 - 616 591 - 442 467 - 558 533 - 395 394 - 3 28 - 476 477 - 257 258 - 280 281 - 517 542 - 505 504 - 302 301 - 14 15 - 523 498 - 393 368 - 46 71 - 141 142 - 477 452 - 535 510 - 237 238 - 232 231 - 5 6 - 75 50 - 278 253 - 68 69 - 584 559 - 503 504 - 281 282 - 19 44 - 411 410 - 290 265 - 579 554 - 85 84 - 65 66 - 9 8 - 484 459 - 427 402 - 195 196 - 617 618 - 418 443 - 101 126 - 268 243 - 92 117 - 290 315 - 562 561 - 255 280 - 488 487 - 578 603 - 80 79 - 57 58 - 77 78 - 417 418 - 246 271 - 95 96 - 234 233 - 530 555 - 543 568 - 396 397 - 22 23 - 29 28 - 502 527 - 12 13 - 217 216 - 522 547 - 357 332 - 543 518 - 151 176 - 69 70 - 556 557 - 247 248 - 513 538 - 204 205 - 604 605 - 528 527 - 455 456 - 624 623 - 284 285 - 27 26 - 94 95 - 486 511 - 192 167 - 372 347 - 129 104 - 349 374 - 313 314 - 354 329 - 294 293 - 377 378 - 291 290 - 433 408 - 57 56 - 215 190 - 467 492 - 383 408 - 569 594 - 209 208 - 2 27 - 466 491 - 147 122 - 112 113 - 21 46 - 284 259 - 563 538 - 392 417 - 458 433 - 464 465 - 297 298 - 336 361 - 607 582 - 553 554 - 225 200 - 186 211 - 33 34 - 237 212 - 52 51 - 620 595 - 492 517 - 585 610 - 257 282 - 520 545 - 541 540 - 269 244 - 609 584 - 109 84 - 247 246 - 562 537 - 172 197 - 166 167 - 264 265 - 129 130 - 89 114 - 204 179 - 51 76 - 415 390 - 54 53 - 219 244 - 491 490 - 494 493 - 87 62 - 158 183 - 517 518 - 358 359 - 105 104 - 285 260 - 343 318 - 348 347 - 615 614 - 169 144 - 53 78 - 494 495 - 576 577 - 23 24 - 22 21 - 41 40 - 467 466 - 112 87 - 245 220 - 442 441 - 411 436 - 256 257 - 469 494 - 441 416 - 132 107 - 468 467 - 345 344 - 608 609 - 358 333 - 418 419 - 430 429 - 130 131 - 127 128 - 115 90 - 364 365 - 296 271 - 260 235 - 229 228 - 232 257 - 189 190 - 234 235 - 195 170 - 117 118 - 487 486 - 203 204 - 142 117 - 582 583 - 561 536 - 7 32 - 387 388 - 333 334 - 420 421 - 317 292 - 327 352 - 564 563 - 39 14 - 177 152 - 144 119 - 426 401 - 248 223 - 566 567 - 53 28 - 106 131 - 473 472 - 525 526 - 327 302 - 382 381 - 222 197 - 610 609 - 522 521 - 291 316 - 339 338 - 328 329 - 31 56 - 247 222 - 185 186 - 554 529 - 393 392 - 108 83 - 514 489 - 48 23 - 37 12 - 46 45 - 25 0 - 463 462 - 101 76 - 11 10 - 548 573 - 137 112 - 123 124 - 359 360 - 489 490 - 368 367 - 71 96 - 229 230 - 496 495 - 366 365 - 86 85 - 496 497 - 482 481 - 326 301 - 278 303 - 139 114 - 71 70 - 275 276 - 223 198 - 590 565 - 496 521 - 16 41 - 501 476 - 371 370 - 511 536 - 577 602 - 37 38 - 423 422 - 71 72 - 399 424 - 171 146 - 32 33 - 157 182 - 608 583 - 474 499 - 205 206 - 539 514 - 601 600 - 419 420 - 208 183 - 537 538 - 110 85 - 105 130 - 288 289 - 455 430 - 531 532 - 337 338 - 227 202 - 120 145 - 559 534 - 261 262 - 241 216 - 379 354 - 430 405 - 241 266 - 396 421 - 317 318 - 139 164 - 310 285 - 478 477 - 532 557 - 238 213 - 195 194 - 359 384 - 243 242 - 432 457 - 422 447 - 519 518 - 271 272 - 12 11 - 478 453 - 453 428 - 614 613 - 138 139 - 96 97 - 399 398 - 55 54 - 199 174 - 566 591 - 213 188 - 488 513 - 169 194 - 603 602 - 293 318 - 432 431 - 524 523 - 30 31 - 88 63 - 172 173 - 510 509 - 272 273 - 559 558 - 494 519 - 374 373 - 547 572 - 263 288 - 17 16 - 78 103 - 542 543 - 131 132 - 519 544 - 504 529 - 60 59 - 356 355 - 341 340 - 415 414 - 285 286 - 439 438 - 588 563 - 25 50 - 463 438 - 581 556 - 244 245 - 500 475 - 93 92 - 274 299 - 351 350 - 152 127 - 472 497 - 440 415 - 214 215 - 231 230 - 80 81 - 550 525 - 511 512 - 483 458 - 67 68 - 255 254 - 589 588 - 147 172 - 454 453 - 587 612 - 343 368 - 508 509 - 240 265 - 49 48 - 184 183 - 583 558 - 164 189 - 461 436 - 109 134 - 196 171 - 156 181 - 124 99 - 531 530 - 116 91 - 431 430 - 326 325 - 44 45 - 507 482 - 557 582 - 519 520 - 167 142 - 469 470 - 563 562 - 507 532 - 94 93 - 3 4 - 366 391 - 456 431 - 524 549 - 489 464 - 397 398 - 98 97 - 377 402 - 413 412 - 148 149 - 91 66 - 308 333 - 16 15 - 312 287 - 212 211 - 486 461 - 571 596 - 226 251 - 356 357 - 145 170 - 295 294 - 308 309 - 163 138 - 364 339 - 416 417 - 402 401 - 302 277 - 349 348 - 582 581 - 176 175 - 254 279 - 589 614 - 322 297 - 587 586 - 221 246 - 526 551 - 159 158 - 460 461 - 452 427 - 329 330 - 321 322 - 82 107 - 462 461 - 495 520 - 303 304 - 90 65 - 295 320 - 160 159 - 463 464 - 10 35 - 619 594 - 403 402 - |} - - -let process_str tinyUF = - match Ext_string.split tinyUF '\n' with - | number :: rest -> - let n = int_of_string number in - let store = Union_find.init n in - List.iter (fun x -> - match Ext_string.quick_split_by_ws x with - | [a;b] -> - let a,b = int_of_string a , int_of_string b in - Union_find.union store a b - | _ -> ()) rest; - Union_find.count store - | _ -> assert false -;; - -let process_file file = - let ichan = open_in_bin file in - let n = int_of_string (input_line ichan) in - let store = Union_find.init n in - let edges = Int_vec_vec.make n in - let rec aux i = - match input_line ichan with - | exception _ -> () - | v -> - begin - (* if i = 0 then - print_endline "processing 100 nodes start"; - *) - begin match Ext_string.quick_split_by_ws v with - | [a;b] -> - let a,b = int_of_string a , int_of_string b in - Int_vec_vec.push edges (Vec_int.of_array [|a;b|]); - | _ -> () - end; - aux ((i+1) mod 10000); - end - in aux 0; - (* indeed, [unsafe_internal_array] is necessary for real performnace *) - let internal = Int_vec_vec.unsafe_internal_array edges in - for i = 0 to Array.length internal - 1 do - let i = Vec_int.unsafe_internal_array (Array.unsafe_get internal i) in - Union_find.union store (Array.unsafe_get i 0) (Array.unsafe_get i 1) - done; - (* Union_find.union store a b *) - Union_find.count store -;; -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (process_str tinyUF) 2 - end; - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (process_str mediumUF) 3 - end; -(* - __LOC__ >:: begin fun _ -> - OUnit.assert_equal (process_file "largeUF.txt") 6 - end; - *) - - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_utf8_test.ml b/jscomp/ounit_tests/ounit_utf8_test.ml deleted file mode 100644 index 7eb0a66..0000000 --- a/jscomp/ounit_tests/ounit_utf8_test.ml +++ /dev/null @@ -1,23 +0,0 @@ - - -(* https://www.cl.cam.ac.uk/~mgk25/ucs/examples/UTF-8-test.txt -*) - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -let (=~) = OUnit.assert_equal -let suites = - __FILE__ - >::: - [ - __LOC__ >:: begin fun _ -> - Ext_utf8.decode_utf8_string - "hello 你好,中华民族 hei" =~ - [104; 101; 108; 108; 111; 32; 20320; 22909; 65292; 20013; 21326; 27665; 26063; 32; 104; 101; 105] - end ; - __LOC__ >:: begin fun _ -> - Ext_utf8.decode_utf8_string - "" =~ [] - end - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_util_tests.ml b/jscomp/ounit_tests/ounit_util_tests.ml deleted file mode 100644 index 0360ffc..0000000 --- a/jscomp/ounit_tests/ounit_util_tests.ml +++ /dev/null @@ -1,67 +0,0 @@ - -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - - -let (=~) = - OUnit.assert_equal - ~printer:Ext_obj.dump -let suites = - __FILE__ >::: - [ - __LOC__ >:: begin fun _ -> - Ext_pervasives.nat_of_string_exn "003" =~ 3; - (try Ext_pervasives.nat_of_string_exn "0a" |> ignore ; 2 with _ -> -1) =~ -1; - end; - __LOC__ >:: begin fun _ -> - let cursor = ref 0 in - let v = Ext_pervasives.parse_nat_of_string "123a" cursor in - (v, !cursor) =~ (123,3); - cursor := 0; - let v = Ext_pervasives.parse_nat_of_string "a" cursor in - (v,!cursor) =~ (0,0) - end; - - (* __LOC__ >:: begin fun _ -> - for i = 0 to 0xff do - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_1 buf i; - let s = Ext_buffer.contents buf in - s =~ String.make 1 (Char.chr i); - Ext_string.get_int_1 s 0 =~ i - done - end; *) - - (* __LOC__ >:: begin fun _ -> - for i = 0x100 to 0xff_ff do - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_2 buf i; - let s = Ext_buffer.contents buf in - Ext_string.get_int_2 s 0 =~ i - done ; - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_3 buf 0x1_ff_ff; - Ext_string.get_int_3 (Ext_buffer.contents buf) 0 =~ 0x1_ff_ff - ; - let buf = Ext_buffer.create 0 in - Ext_buffer.add_int_4 buf 0x1_ff_ff_ff; - Ext_string.get_int_4 (Ext_buffer.contents buf) 0 =~ 0x1_ff_ff_ff - end; *) - __LOC__ >:: begin fun _ -> - let buf = Ext_buffer.create 0 in - Ext_buffer.add_string_char buf "hello" 'v'; - Ext_buffer.contents buf =~ "hellov"; - Ext_buffer.length buf =~ 6 - end; - __LOC__ >:: begin fun _ -> - let buf = Ext_buffer.create 0 in - Ext_buffer.add_char_string buf 'h' "ellov"; - Ext_buffer.contents buf =~ "hellov"; - Ext_buffer.length buf =~ 6 - end; - __LOC__ >:: begin fun _ -> - String.length - (Digest.to_hex(Digest.string "")) =~ 32 - end - - ] \ No newline at end of file diff --git a/jscomp/ounit_tests/ounit_vec_test.ml b/jscomp/ounit_tests/ounit_vec_test.ml deleted file mode 100644 index a834b83..0000000 --- a/jscomp/ounit_tests/ounit_vec_test.ml +++ /dev/null @@ -1,153 +0,0 @@ -let ((>::), - (>:::)) = OUnit.((>::),(>:::)) - -(* open Ext_json *) - -let v = Vec_int.init 10 (fun i -> i);; -let (=~) x y = OUnit.assert_equal ~cmp:(Vec_int.equal (fun (x: int) y -> x=y)) x y -let (=~~) x y - = - OUnit.assert_equal ~cmp:(Vec_int.equal (fun (x: int) y -> x=y)) - x (Vec_int.of_array y) - -let suites = - __FILE__ - >::: - [ - (* idea - [%loc "inplace filter" ] --> __LOC__ ^ "inplace filter" - or "inplace filter" [@bs.loc] - *) - "inplace_filter " ^ __LOC__ >:: begin fun _ -> - v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|]; - - ignore @@ Vec_int.push v 32; - let capacity = Vec_int.capacity v in - v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 32|]; - Vec_int.inplace_filter (fun x -> x mod 2 = 0) v ; - v =~~ [|0; 2; 4; 6; 8; 32|]; - Vec_int.inplace_filter (fun x -> x mod 3 = 0) v ; - v =~~ [|0;6|]; - Vec_int.inplace_filter (fun x -> x mod 3 <> 0) v ; - v =~~ [||]; - OUnit.assert_equal (Vec_int.capacity v ) capacity ; - Vec_int.compact v ; - OUnit.assert_equal (Vec_int.capacity v ) 0 - end - ; - "inplace_filter_from " ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array (Array.init 10 (fun i -> i)) in - v =~~ [|0; 1; 2; 3; 4; 5; 6; 7; 8; 9|]; - Vec_int.push v 96 ; - Vec_int.inplace_filter_from 2 (fun x -> x mod 2 = 0) v ; - v =~~ [|0; 1; 2; 4; 6; 8; 96|]; - Vec_int.inplace_filter_from 2 (fun x -> x mod 3 = 0) v ; - v =~~ [|0; 1; 6; 96|]; - Vec_int.inplace_filter (fun x -> x mod 3 <> 0) v ; - v =~~ [|1|]; - Vec_int.compact v ; - OUnit.assert_equal (Vec_int.capacity v ) 1 - end - ; - "map " ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array (Array.init 1000 (fun i -> i )) in - Vec_int.map succ v =~~ (Array.init 1000 succ) ; - OUnit.assert_bool __LOC__ (Vec_int.exists (fun x -> x >= 999) v ); - OUnit.assert_bool __LOC__ (not (Vec_int.exists (fun x -> x > 1000) v )); - OUnit.assert_equal (Vec_int.last v ) 999 - end ; - __LOC__ >:: begin fun _ -> - let count = 1000 in - let init_array = (Array.init count (fun i -> i)) in - let u = Vec_int.of_array init_array in - let v = Vec_int.inplace_filter_with (fun x -> x mod 2 = 0) ~cb_no:(fun a b -> Set_int.add b a)Set_int.empty u in - let (even,odd) = init_array |> Array.to_list |> List.partition (fun x -> x mod 2 = 0) in - OUnit.assert_equal - (Set_int.elements v) odd ; - u =~~ Array.of_list even - end ; - "filter" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array [|1;2;3;4;5;6|] in - v |> Vec_int.filter (fun x -> x mod 3 = 0) |> (fun x -> x =~~ [|3;6|]); - v =~~ [|1;2;3;4;5;6|]; - Vec_int.pop v ; - v =~~ [|1;2;3;4;5|]; - let count = ref 0 in - let len = Vec_int.length v in - while not (Vec_int.is_empty v ) do - Vec_int.pop v ; - incr count - done; - OUnit.assert_equal len !count - end - ; - __LOC__ >:: begin fun _ -> - let count = 100 in - let v = Vec_int.of_array (Array.init count (fun i -> i)) in - OUnit.assert_bool __LOC__ - (try Vec_int.delete v count; false with _ -> true ); - for i = count - 1 downto 10 do - Vec_int.delete v i ; - done ; - v =~~ [|0;1;2;3;4;5;6;7;8;9|] - end; - "sub" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.make 5 in - OUnit.assert_bool __LOC__ - (try ignore @@ Vec_int.sub v 0 2 ; false with Invalid_argument _ -> true); - Vec_int.push v 1; - OUnit.assert_bool __LOC__ - (try ignore @@ Vec_int.sub v 0 2 ; false with Invalid_argument _ -> true); - Vec_int.push v 2; - ( Vec_int.sub v 0 2 =~~ [|1;2|]) - end; - "reserve" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.empty () in - Vec_int.reserve v 1000 ; - for i = 0 to 900 do - Vec_int.push v i - done ; - OUnit.assert_equal (Vec_int.length v) 901 ; - OUnit.assert_equal (Vec_int.capacity v) 1000 - end ; - "capacity" ^ __LOC__ >:: begin fun _ -> - let v = Vec_int.of_array [|3|] in - Vec_int.reserve v 10 ; - v =~~ [|3 |]; - Vec_int.push v 1 ; - Vec_int.push v 2 ; - Vec_int.push v 5; - v=~~ [|3;1;2;5|]; - OUnit.assert_equal (Vec_int.capacity v ) 10 ; - for i = 0 to 5 do - Vec_int.push v i - done; - v=~~ [|3;1;2;5;0;1;2;3;4;5|]; - Vec_int.push v 100; - v=~~[|3;1;2;5;0;1;2;3;4;5;100|]; - OUnit.assert_equal (Vec_int.capacity v ) 20 - end - ; - __LOC__ >:: begin fun _ -> - let empty = Vec_int.empty () in - Vec_int.push empty 3; - empty =~~ [|3|]; - - end - ; - __LOC__ >:: begin fun _ -> - let lst = [1;2;3;4] in - let v = Vec_int.of_list lst in - OUnit.assert_equal - (Vec_int.map_into_list (fun x -> x + 1) v) - (Ext_list.map lst (fun x -> x + 1) ) - end; - __LOC__ >:: begin fun _ -> - let v = Vec_int.make 4 in - Vec_int.push v 1 ; - Vec_int.push v 2; - Vec_int.reverse_in_place v; - v =~~ [|2;1|] - end - ; - ] diff --git a/jscomp/runtime/Readme.md b/jscomp/runtime/Readme.md deleted file mode 100644 index 243d075..0000000 --- a/jscomp/runtime/Readme.md +++ /dev/null @@ -1,3 +0,0 @@ -# Runtime support - -The build deps are manually maintained. \ No newline at end of file diff --git a/jscomp/runtime/bs_stdlib_mini.resi b/jscomp/runtime/bs_stdlib_mini.resi deleted file mode 100644 index c7f6c29..0000000 --- a/jscomp/runtime/bs_stdlib_mini.resi +++ /dev/null @@ -1,70 +0,0 @@ -/** - Since [others] depend on this file, its public mli files **should not - export types** introduced here, otherwise it would cause - conflicts here. - - If the type exported here is also exported in modules from others, - you will get a type not equivalent. - - - Types defined here but should not export: - - ref (make sure not exported in *.mli in others folder) -*/ -external \"^": (string, string) => string = "#string_append" -external \"=": ('a, 'a) => bool = "%equal" -external \"<>": ('a, 'a) => bool = "%notequal" -external \"==": ('a, 'a) => bool = "%eq" -external \"!=": ('a, 'a) => bool = "%noteq" -external \"<": ('a, 'a) => bool = "%lessthan" -external \">": ('a, 'a) => bool = "%greaterthan" -external \"<=": ('a, 'a) => bool = "%lessequal" -external \">=": ('a, 'a) => bool = "%greaterequal" -external \"+": (int, int) => int = "%addint" -external \"-": (int, int) => int = "%subint" -external \"~-": int => int = "%negint" -external \"*": (int, int) => int = "%mulint" -external \"/": (int, int) => int = "%divint" -external lsl: (int, int) => int = "%lslint" -external lor: (int, int) => int = "%orint" -external land: (int, int) => int = "%andint" -external mod: (int, int) => int = "%modint" -external lsr: (int, int) => int = "%lsrint" -external lxor: (int, int) => int = "%xorint" -external asr: (int, int) => int = "%asrint" -type ref<'a> = {mutable contents: 'a} -external ref: 'a => ref<'a> = "%makemutable" - -external \"||": (bool, bool) => bool = "%sequor" -external \"&&": (bool, bool) => bool = "%sequand" -external not: bool => bool = "%boolnot" - -external raise: exn => 'a = "%raise" -external ignore: 'a => unit = "%ignore" -external \"|>": ('a, 'a => 'b) => 'b = "%revapply" -external \"@@": ('a => 'b, 'a) => 'b = "%apply" - -@val @scope("Math") external \"**": (float, float) => float = "pow" -external \"~-.": float => float = "%negfloat" -external \"+.": (float, float) => float = "%addfloat" -external \"-.": (float, float) => float = "%subfloat" -external \"*.": (float, float) => float = "%mulfloat" -external \"/.": (float, float) => float = "%divfloat" - -module Obj: { - type t - external field: (t, int) => t = "%obj_field" - external set_field: (t, int, t) => unit = "%obj_set_field" - external tag: t => int = "?obj_tag" - external repr: 'a => t = "%identity" - external obj: t => 'a = "%identity" - external magic: 'a => 'b = "%identity" - external size: t => int = "#obj_length" -} - -module Pervasives: { - external compare: ('a, 'a) => int = "%compare" - external not: bool => bool = "%boolnot" - external min: ('a, 'a) => 'a = "%bs_min" - external max: ('a, 'a) => 'a = "%bs_max" - external \"=": ('a, 'a) => bool = "%equal" -} diff --git a/jscomp/runtime/caml.res b/jscomp/runtime/caml.res deleted file mode 100644 index 15a7057..0000000 --- a/jscomp/runtime/caml.res +++ /dev/null @@ -1,162 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let int_compare = (x: int, y: int): int => - if x < y { - -1 - } else if x == y { - 0 - } else { - 1 - } -let bool_compare = (x: bool, y: bool): int => - switch (x, y) { - | (true, true) | (false, false) => 0 - | (true, false) => 1 - | (false, true) => -1 - } - -let float_compare = (x: float, y: float) => - if x == y { - 0 - } else if x < y { - -1 - } else if x > y { - 1 - } else if x == x { - 1 - } else if y == y { - -1 - } else { - 0 - } - -let bigint_compare = (x: bigint, y: bigint) => - if x < y { - -1 - } else if x == y { - 0 - } else { - 1 - } - -/* Lexical order */ -let string_compare = (s1: string, s2: string): int => - if s1 == s2 { - 0 - } else if s1 < s2 { - -1 - } else { - 1 - } - -type selector<'a> = ('a, 'a) => 'a - -/* could be replaced by [Math.min], but it seems those built-ins are slower */ -let bool_min = (x: bool, y): bool => - if x { - y - } else { - x - } -let int_min = (x: int, y: int): int => - if x < y { - x - } else { - y - } -let float_min = (x: float, y) => - if x < y { - x - } else { - y - } -let string_min = (x: string, y) => - if x < y { - x - } else { - y - } - -let bool_max = (x: bool, y): bool => - if x { - x - } else { - y - } -let int_max = (x: int, y: int): int => - if x > y { - x - } else { - y - } -let float_max = (x: float, y) => - if x > y { - x - } else { - y - } -let string_max = (x: string, y) => - if x > y { - x - } else { - y - } -type i64 = Caml_int64_extern.t -let i64_eq = (x: i64, y: i64) => x.lo == y.lo && x.hi == y.hi - -let i64_ge = ({hi, lo}: i64, {hi: other_hi, lo: other_lo}: i64): bool => - if hi > other_hi { - true - } else if hi < other_hi { - false - } else { - lo >= other_lo - } - -let i64_neq = (x, y) => Pervasives.not(i64_eq(x, y)) -let i64_lt = (x, y) => Pervasives.not(i64_ge(x, y)) -let i64_gt = (x: i64, y: i64) => - if x.hi > y.hi { - true - } else if x.hi < y.hi { - false - } else { - x.lo > y.lo - } - -let i64_le = (x, y) => Pervasives.not(i64_gt(x, y)) - -let i64_min = (x, y) => - if i64_lt(x, y) { - x - } else { - y - } -let i64_max = (x, y) => - if i64_gt(x, y) { - x - } else { - y - } diff --git a/jscomp/runtime/caml.resi b/jscomp/runtime/caml.resi deleted file mode 100644 index fe4d629..0000000 --- a/jscomp/runtime/caml.resi +++ /dev/null @@ -1,51 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type selector<'a> = ('a, 'a) => 'a - -let int_compare: (int, int) => int -let bool_compare: (bool, bool) => int -let float_compare: (float, float) => int -let bigint_compare: (bigint, bigint) => int -let string_compare: (string, string) => int - -let bool_min: selector -let int_min: selector -let float_min: selector -let string_min: selector - -let bool_max: selector -let int_max: selector -let float_max: selector -let string_max: selector - -let i64_eq: (Caml_int64_extern.t, Caml_int64_extern.t) => bool -let i64_neq: (Caml_int64_extern.t, Caml_int64_extern.t) => bool -let i64_lt: (Caml_int64_extern.t, Caml_int64_extern.t) => bool -let i64_gt: (Caml_int64_extern.t, Caml_int64_extern.t) => bool -let i64_le: (Caml_int64_extern.t, Caml_int64_extern.t) => bool -let i64_ge: (Caml_int64_extern.t, Caml_int64_extern.t) => bool - -let i64_min: (Caml_int64_extern.t, Caml_int64_extern.t) => Caml_int64_extern.t -let i64_max: (Caml_int64_extern.t, Caml_int64_extern.t) => Caml_int64_extern.t diff --git a/jscomp/runtime/caml_array.res b/jscomp/runtime/caml_array.res deleted file mode 100644 index bcd996a..0000000 --- a/jscomp/runtime/caml_array.res +++ /dev/null @@ -1,107 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@send external dup: (array<'a>, @as(0) _) => array<'a> = "slice" - -%%private(let {unsafe_get, unsafe_set} = module(Caml_array_extern)) - -let sub = (x: array<'a>, offset: int, len: int) => { - let result = Caml_array_extern.new_uninitialized(len) - let j = {contents: 0} and i = {contents: offset} - while j.contents < len { - result->unsafe_set(j.contents, x->unsafe_get(i.contents)) - j.contents = j.contents + 1 - i.contents = i.contents + 1 - } - result -} - -let rec len = (acc, l) => - switch l { - | list{} => acc - | list{x, ...xs} => len(Caml_array_extern.length(x) + acc, xs) - } - -let rec fill = (arr, i, l) => - switch l { - | list{} => () - | list{x, ...xs} => - let l = Caml_array_extern.length(x) - let k = {contents: i} - let j = {contents: 0} - while j.contents < l { - arr->unsafe_set(k.contents, x->unsafe_get(j.contents)) - k.contents = k.contents + 1 - j.contents = j.contents + 1 - } - fill(arr, k.contents, xs) - } - -let concat = (l: list>): array<'a> => { - let v = len(0, l) - let result = Caml_array_extern.new_uninitialized(v) - fill(result, 0, l) - result -} - -let set = (xs, index, newval) => - if index < 0 || index >= Caml_array_extern.length(xs) { - raise(Invalid_argument("index out of bounds")) - } else { - xs->unsafe_set(index, newval) - } - -let get = (xs, index) => - if index < 0 || index >= Caml_array_extern.length(xs) { - raise(Invalid_argument("index out of bounds")) - } else { - xs->unsafe_get(index) - } - -let make = (len, init) => { - let b = Caml_array_extern.new_uninitialized(len) - for i in 0 to len - 1 { - b->unsafe_set(i, init) - } - b -} - -let make_float = len => { - let b = Caml_array_extern.new_uninitialized(len) - for i in 0 to len - 1 { - b->unsafe_set(i, 0.) - } - b -} - -let blit = (a1, i1, a2, i2, len) => - if i2 <= i1 { - for j in 0 to len - 1 { - a2->unsafe_set(j + i2, a1->unsafe_get(j + i1)) - } - } else { - for j in len - 1 downto 0 { - a2->unsafe_set(j + i2, a1->unsafe_get(j + i1)) - } - } diff --git a/jscomp/runtime/caml_array.resi b/jscomp/runtime/caml_array.resi deleted file mode 100644 index af94891..0000000 --- a/jscomp/runtime/caml_array.resi +++ /dev/null @@ -1,39 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let dup: array<'a> => array<'a> - -let sub: (array<'a>, int, int) => array<'a> - -let concat: list> => array<'a> - -let make: (int, 'a) => array<'a> - -let make_float: int => array - -let blit: (array<'a>, int, array<'a>, int, int) => unit - -let get: (array<'a>, int) => 'a - -let set: (array<'a>, int, 'a) => unit diff --git a/jscomp/runtime/caml_array_extern.res b/jscomp/runtime/caml_array_extern.res deleted file mode 100644 index 84b2ac3..0000000 --- a/jscomp/runtime/caml_array_extern.res +++ /dev/null @@ -1,11 +0,0 @@ -@new external new_uninitialized: int => array<'a> = "Array" -@send external append: (array<'a>, array<'a>) => array<'a> = "concat" -external unsafe_get: (array<'a>, int) => 'a = "%array_unsafe_get" -external unsafe_set: (array<'a>, int, 'a) => unit = "%array_unsafe_set" -external length: array<'a> => int = "%array_length" - -/* - Could be replaced by {!Caml_array.caml_make_vect} - Leave here temporarily since we have marked it side effect free internally -*/ -external make: (int, 'a) => array<'a> = "?make_vect" diff --git a/jscomp/runtime/caml_bigint.res b/jscomp/runtime/caml_bigint.res deleted file mode 100644 index bf78dce..0000000 --- a/jscomp/runtime/caml_bigint.res +++ /dev/null @@ -1,37 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let div = (x: bigint, y: bigint) => - if y == 0n { - raise(Division_by_zero) - } else { - Caml_bigint_extern.div(x, y) - } - -let mod_ = (x: bigint, y: bigint) => - if y == 0n { - raise(Division_by_zero) - } else { - Caml_bigint_extern.rem(x, y) - } diff --git a/jscomp/runtime/caml_bigint.resi b/jscomp/runtime/caml_bigint.resi deleted file mode 100644 index 386a1ab..0000000 --- a/jscomp/runtime/caml_bigint.resi +++ /dev/null @@ -1,27 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let div: (bigint, bigint) => bigint - -let mod_: (bigint, bigint) => bigint diff --git a/jscomp/runtime/caml_bigint_extern.res b/jscomp/runtime/caml_bigint_extern.res deleted file mode 100644 index 33f0c43..0000000 --- a/jscomp/runtime/caml_bigint_extern.res +++ /dev/null @@ -1,2 +0,0 @@ -external div: (bigint, bigint) => bigint = "?bigint_div" -external rem: (bigint, bigint) => bigint = "?bigint_mod" diff --git a/jscomp/runtime/caml_bytes.res b/jscomp/runtime/caml_bytes.res deleted file mode 100644 index afab096..0000000 Binary files a/jscomp/runtime/caml_bytes.res and /dev/null differ diff --git a/jscomp/runtime/caml_bytes.resi b/jscomp/runtime/caml_bytes.resi deleted file mode 100644 index a76db5d..0000000 --- a/jscomp/runtime/caml_bytes.resi +++ /dev/null @@ -1,40 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let create: int => bytes - -let get: (bytes, int) => char -let set: (bytes, int, char) => unit - -let bytes_compare: (bytes, bytes) => int - -let bytes_greaterthan: (bytes, bytes) => bool - -let bytes_greaterequal: (bytes, bytes) => bool - -let bytes_lessthan: (bytes, bytes) => bool - -let bytes_lessequal: (bytes, bytes) => bool - -let bytes_equal: (bytes, bytes) => bool diff --git a/jscomp/runtime/caml_exceptions.res b/jscomp/runtime/caml_exceptions.res deleted file mode 100644 index 796e817..0000000 --- a/jscomp/runtime/caml_exceptions.res +++ /dev/null @@ -1,102 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -module Map = { - type t<'k, 'v> - - @new external make: unit => t<'k, 'v> = "Map" - - @send external set: (t<'k, 'v>, 'k, 'v) => unit = "set" - - @send external get: (t<'k, 'v>, 'k) => option<'v> = "get" -} - -type t = {@as("RE_EXN_ID") id: string} - -/** - Could be exported for better inlining - It's common that we have - {[ a = caml_set_oo_id([248,"string",0]) ]} - This can be inlined as - {[ a = caml_set_oo_id([248,"string", caml_oo_last_id++]) ]} -*/ -let idMap: Map.t = Map.make() - -let create = (str: string): string => { - let id = switch idMap->Map.get(str) { - | Some(v) => { - let id = v + 1 - idMap->Map.set(str, id) - id - } - | None => { - let id = 1 - idMap->Map.set(str, id) - id - } - } - - str ++ ("/" ++ (Obj.magic((id: int)): string)) -} - -/** - This function should never throw - It could be either customized exception or built in exception - Note due to that in OCaml extensible variants have the same - runtime representation as exception, so we can not - really tell the difference. - - However, if we make a false alarm, classified extensible variant - as exception, it will be OKAY for nested pattern match - - {[ - match toExn x : exn option with - | Some _ - -> Js.log "Could be an OCaml exception or an open variant" - (* If it is an Open variant, it will never pattern match, - This is Okay, since exception could never have exhaustive pattern match - - *) - | None -> Js.log "Not an OCaml exception for sure" - ]} - - However, there is still something wrong, since if user write such code - {[ - match toExn x with - | Some _ -> (* assert it is indeed an exception *) - (* This assertion is wrong, since it could be an open variant *) - | None -> (* assert it is not an exception *) - ]} - - This is not a problem in `try .. with` since the logic above is not expressible, see more design in [destruct_exn.md] -*/ -let is_extension = (type a, e: a): bool => - if Js.testAny(e) { - false - } else { - Js.typeof((Obj.magic(e): t).id) == "string" - } - -/** FIXME: remove the trailing `/` */ -let exn_slot_name = (x: t): string => x.id diff --git a/jscomp/runtime/caml_exceptions.resi b/jscomp/runtime/caml_exceptions.resi deleted file mode 100644 index da55d4d..0000000 --- a/jscomp/runtime/caml_exceptions.resi +++ /dev/null @@ -1,31 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t = {@as("RE_EXN_ID") id: string} - -let create: string => string - -let is_extension: 'a => bool - -let exn_slot_name: t => string diff --git a/jscomp/runtime/caml_external_polyfill.res b/jscomp/runtime/caml_external_polyfill.res deleted file mode 100644 index 38382a9..0000000 --- a/jscomp/runtime/caml_external_polyfill.res +++ /dev/null @@ -1,51 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type global -let getGlobalThis: (. unit) => global = %raw(` function(){ - if (typeof globalThis !== 'undefined') return globalThis; - if (typeof self !== 'undefined') return self; - if (typeof window !== 'undefined') return window; - if (typeof global !== 'undefined') return global; - if (typeof this !== 'undefined') return this; - throw new Error('Unable to locate global this'); -}`) - -type dyn -let resolve: (. string) => dyn = %raw(`function(s){ - var myGlobal = getGlobalThis(); - if (myGlobal[s] === undefined){ - throw new Error(s + " not polyfilled by ReScript yet\n") - } - return myGlobal[s] -}`) - -/* FIXME: it does not have to global states */ -type fn - -let register: (string, fn) => unit = %raw(` function(s,fn){ - var myGlobal = getGlobalThis(); - myGlobal[s] = fn - return 0 -}`) diff --git a/jscomp/runtime/caml_float.res b/jscomp/runtime/caml_float.res deleted file mode 100644 index 95ac08b..0000000 --- a/jscomp/runtime/caml_float.res +++ /dev/null @@ -1,157 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* borrowed from others/js_math.ml */ -@val external _LOG2E: float = "Math.LOG2E" -@val external _LOG10E: float = "Math.LOG10E" -@val external abs_float: float => float = "Math.abs" -@val external floor: float => float = "Math.floor" -@val @scope("Math") external exp: float => float = "exp" -@val external log: float => float = "Math.log" -@val @scope("Math") external sqrt: float => float = "sqrt" -@val external pow_float: (~base: float, ~exp: float) => float = "Math.pow" -external int_of_float: float => int = "%intoffloat" -external float_of_int: int => float = "%floatofint" - -let int_float_of_bits: int => float = %raw(`function(x){ - return new Float32Array(new Int32Array([x]).buffer)[0] - }`) -/* let int = Int32_array.make [| x |] in - let float32 = Float32_array.fromBuffer ( Int32_array.buffer int) in - Float32_array.unsafe_get float32 0 */ - -let int_bits_of_float: float => int = %raw(`function(x){ - return new Int32Array(new Float32Array([x]).buffer)[0] -}`) -/* let float32 = Float32_array.make [|x|] in - Int32_array.unsafe_get (Int32_array.fromBuffer (Float32_array.buffer float32)) 0 */ - -let modf_float = (x: float): (float, float) => - if Caml_float_extern.isFinite(x) { - let neg = 1. /. x < 0. - let x = abs_float(x) - let i = floor(x) - let f = x -. i - if neg { - (-.f, -.i) - } else { - (f, i) - } - } else if Caml_float_extern.isNaN(x) { - (Caml_float_extern._NaN, Caml_float_extern._NaN) - } else { - (1. /. x, x) - } - -let ldexp_float = (x: float, exp: int): float => { - let (x', exp') = (ref(x), ref(float_of_int(exp))) - if exp'.contents > 1023. { - exp'.contents = exp'.contents -. 1023. - x'.contents = x'.contents *. pow_float(~base=2., ~exp=1023.) - if exp'.contents > 1023. { - /* in case x is subnormal */ - exp'.contents = exp'.contents -. 1023. - x'.contents = x'.contents *. pow_float(~base=2., ~exp=1023.) - } - } else if exp'.contents < -1023. { - exp'.contents = exp'.contents +. 1023. - x'.contents = x'.contents *. pow_float(~base=2., ~exp=-1023.) - } - x'.contents *. pow_float(~base=2., ~exp=exp'.contents) -} - -let frexp_float = (x: float): (float, int) => - if x == 0. || !Caml_float_extern.isFinite(x) { - (x, 0) - } else { - let neg = x < 0. - let x' = ref(abs_float(x)) - let exp = ref(floor(_LOG2E *. log(x'.contents)) +. 1.) - - x'.contents = x'.contents *. pow_float(~base=2., ~exp=-.exp.contents) - if x'.contents < 0.5 { - x'.contents = x'.contents *. 2. - exp.contents = exp.contents -. 1. - } - if neg { - x'.contents = -.x'.contents - } - (x'.contents, int_of_float(exp.contents)) - } - -let copysign_float = (x: float, y: float): float => { - let x = abs_float(x) - let y = if y == 0. { - 1. /. y - } else { - y - } - if y < 0. { - -.x - } else { - x - } -} - -/* http://www.johndcook.com/blog/cpp_expm1/ */ -let expm1_float: float => float = x => - switch x { - | x => - let y = exp(x) - let z = y -. 1. - if abs_float(x) > 1. { - z - } else if z == 0. { - x - } else { - x *. z /. log(y) - } - } - -/* -(* http://blog.csdn.net/liyuanbhu/article/details/8544644 *) -let log1p_float : float -> float = function x -> - let y = 1. +. x in - let z = y -. 1. in - if z = 0. then x else x *. log y /. z */ - -let hypot_float = (x: float, y: float): float => { - let (x0, y0) = (abs_float(x), abs_float(y)) - let a = Pervasives.max(x0, y0) - let b = - Pervasives.min(x0, y0) /. if a != 0. { - a - } else { - 1. - } - a *. sqrt(1. +. b *. b) -} - -/* -let caml_cosh_float x = exp x +. exp (-. x) /. 2. -let caml_sin_float x = exp x -. exp (-. x) /. 2. -let caml_tan_float x = - let y = exp x in - let z = exp (-. x) in - (y +. z) /. (y -. z ) */ diff --git a/jscomp/runtime/caml_float.resi b/jscomp/runtime/caml_float.resi deleted file mode 100644 index 4cb4559..0000000 --- a/jscomp/runtime/caml_float.resi +++ /dev/null @@ -1,39 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@val external floor: float => float = "Math.floor" -external int_of_float: float => int = "%intoffloat" -external float_of_int: int => float = "%floatofint" -let int_float_of_bits: int => float -let int_bits_of_float: float => int - -let modf_float: float => (float, float) - -let ldexp_float: (float, int) => float -let frexp_float: float => (float, int) - -let copysign_float: (float, float) => float -let expm1_float: float => float - -let hypot_float: (float, float) => float diff --git a/jscomp/runtime/caml_float_extern.res b/jscomp/runtime/caml_float_extern.res deleted file mode 100644 index 065c5a5..0000000 --- a/jscomp/runtime/caml_float_extern.res +++ /dev/null @@ -1,7 +0,0 @@ -@val external _NaN: float = "NaN" -@val external isNaN: float => bool = "isNaN" -@val external isFinite: float => bool = "isFinite" -@send external toExponentialWithPrecision: (float, ~digits: int) => string = "toExponential" -@send external toFixed: float => string = "toFixed" -@send external toFixedWithPrecision: (float, ~digits: int) => string = "toFixed" -@val external fromString: string => float = "Number" diff --git a/jscomp/runtime/caml_format.ml b/jscomp/runtime/caml_format.ml deleted file mode 100644 index 6a4a5a8..0000000 --- a/jscomp/runtime/caml_format.ml +++ /dev/null @@ -1,683 +0,0 @@ - - -(* - * Js_of_ocaml runtime support - * http://www.ocsigen.org/js_of_ocaml/ - * Copyright (C) 2010 Jérôme Vouillon - * Laboratoire PPS - CNRS Université Paris Diderot - * Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published * by - * the Free Software Foundation, with linking exception; - * either version 2.1 of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - *) - - - -external (.![]) : string -> int -> int = "%string_unsafe_get" -external (.!()) : string -> int -> char = "%string_unsafe_get" - -let code_0 = "0".![0] -let code_a = "a".![0] -let code_A = "A".![0] - -module Caml_char = struct - external code : char -> int = "%identity" - external unsafe_chr : int -> char = "%identity" -end - -let failwith s = raise (Failure s) -(* let invalid_argument s= raise (Invalid_argument s ) *) - -let (>>>) = Caml_nativeint_extern.shift_right_logical - - - -let (+~) = Caml_nativeint_extern.add -let ( *~ ) = Caml_nativeint_extern.mul - -let parse_digit c = - match c with - | '0' .. '9' - -> Caml_char.code c - code_0 - | 'A' .. 'Z' - -> Caml_char.code c - (code_A - 10) - | 'a' .. 'z' - -> Caml_char.code c - (code_a - 10 ) - | _ -> -1 - -type of_string_base = - | Oct - | Hex - | Dec - | Bin - -let int_of_string_base = function - | Oct -> 8 - | Hex -> 16 - | Dec -> 10 - | Bin -> 2 - -let parse_sign_and_base (s : string) = - let sign = ref 1 in - let base = ref Dec in - let i = ref 0 in - (match s.!(i.contents) with - | '-' -> - sign .contents<- -1; - i.contents <- i.contents + 1 - | '+' -> - i.contents <- i.contents + 1 - | _ -> ()); - if s.!(i.contents) = '0' then - (match s.!(i.contents + 1) with - | ('x' | 'X') - -> base .contents<- Hex; i.contents<- i.contents + 2 - | ( 'o' | 'O') - -> base .contents<- Oct; i .contents<- i.contents + 2 - | ('b' | 'B' ) - -> base .contents<- Bin; i .contents<- i.contents + 2 - | ('u' | 'U') - -> i .contents<- i.contents + 2 - | _ -> ()); - (i.contents, sign.contents, base.contents) - - -let int_of_string (s : string) : int = - let i, sign, hbase = parse_sign_and_base s in - let base = int_of_string_base hbase in - let threshold = (-1 >>> 0) in - let len =Caml_string_extern.length s in - let c = if i < len then s.!(i) else '\000' in - let d = parse_digit c in - let () = - if d < 0 || d >= base then - failwith "int_of_string" in - (* let () = [%bs.debugger] in *) - let rec aux acc k = - if k = len then acc - else - let a = s.!(k) in - if a = '_' then aux acc ( k + 1) - else - let v = parse_digit a in - if v < 0 || v >= base then - failwith "int_of_string" - else - let acc = base *~ acc +~ v in - if acc > threshold then - failwith "int_of_string" - else aux acc ( k + 1) - in - let res = sign *~ aux d (i + 1) in - let or_res = res lor 0 in - (if base = 10 && res <> or_res then - failwith "int_of_string"); - or_res - -let hex_threshold, - dec_threshold, - oct_threshold, - bin_threshold = - 1152921504606846975L, - 1844674407370955161L, - 2305843009213693951L, - 9223372036854775807L - -let int64_of_string s = - let i, sign, hbase = parse_sign_and_base s in - let base = Caml_int64_extern.of_int (int_of_string_base hbase) in - let sign = Caml_int64_extern.of_int sign in - let threshold = - match hbase with - | Hex -> (* 2 ^ 64 - 1 / 16*) - hex_threshold - | Dec -> - dec_threshold - | Oct -> - oct_threshold - | Bin -> - bin_threshold - in - let len =Caml_string_extern.length s in - let c = if i < len then s.!(i) else '\000' in - let d = Caml_int64_extern.of_int (parse_digit c) in - let () = - if d < 0L || d >= base then - failwith "int64_of_string" in - let (+~) = Caml_int64_extern.add in - let ( *~ ) = Caml_int64_extern.mul in - - let rec aux acc k = - if k = len then acc - else - let a = s.!(k) in - if a = '_' then aux acc ( k + 1) - else - let v = Caml_int64_extern.of_int (parse_digit a) in - if v < 0L || v >= base || acc > threshold then - failwith "int64_of_string" - else - let acc = base *~ acc +~ v in - aux acc ( k + 1) - in - let res = sign *~ aux d (i + 1) in - let or_res = Caml_int64_extern.logor res 0L in - (if base = 10L && res <> or_res then - failwith "int64_of_string"); - or_res - -type base = - | Oct | Hex | Dec -let int_of_base = function - | Oct -> 8 - | Hex -> 16 - | Dec -> 10 - -type fmt = { - mutable justify : string; - mutable signstyle : string; - mutable filter : string ; - mutable alternate : bool; - mutable base : base; - mutable signedconv : bool; - mutable width :int; - mutable uppercase : bool; - mutable sign : int; - mutable prec : int; - mutable conv : string -} - -let lowercase (c : char) : char = - if (c >= 'A' && c <= 'Z') - || (c >= '\192' && c <= '\214') - || (c >= '\216' && c <= '\222') - then Caml_char.unsafe_chr(Caml_char.code c + 32) - else c - -let parse_format fmt = - let module String = Caml_string_extern in - let len =Caml_string_extern.length fmt in - if len > 31 then - raise (Invalid_argument "format_int: format too long") ; - let rec aux (f : fmt) i : fmt = - if i >= len then f - else - let c = fmt.[i] in - match c with - | '-' -> - f.justify <- "-"; - aux f (i + 1) - | '+'|' ' - -> - f.signstyle <- Caml_string_extern.of_char c ; - aux f (i + 1) - | '#' -> - f.alternate <- true; - aux f (i + 1) - | '0' -> - f.filter <- "0"; - aux f (i + 1) - | '1' .. '9' - -> - begin - f.width <- 0; - let j = ref i in - - while (let w = fmt.![j.contents] - code_0 in w >=0 && w <= 9 ) do - f.width <- f.width * 10 + fmt.![j.contents] - code_0; - j.contents <- j.contents + 1 - done; - aux f j.contents - end - | '.' - -> - f.prec <- 0; - let j = ref (i + 1 ) in - while (let w = fmt.![j.contents] - code_0 in w >=0 && w <= 9 ) do - f.prec <- f.prec * 10 + fmt.![j.contents] - code_0; - j.contents <- j.contents + 1; - done; - aux f j.contents - | 'd' - | 'i' -> - f.signedconv <- true; - f.base <- Dec; - aux f (i + 1) - | 'u' -> - f.base <- Dec; - aux f (i + 1) - | 'x' -> - f.base <- Hex; - aux f (i + 1) - | 'X' -> - f.base <- Hex; - f.uppercase <- true; - aux f (i + 1) - | 'o' -> - f.base <- Oct; - aux f (i + 1) - (* | 'O' -> base .contents<- 8; uppercase .contents<- true no uppercase for oct *) - | 'e' | 'f' | 'g' - -> - f.signedconv <- true; - f.conv <- Caml_string_extern.of_char c ; - aux f (i + 1) - | 'E' | 'F' | 'G' - -> - f.signedconv <- true; - f.uppercase <- true; - f.conv <- Caml_string_extern.of_char (lowercase c); - aux f (i + 1) - | _ -> - aux f (i + 1) - in - aux { justify = "+" ; - signstyle = "-"; - filter = " " ; - alternate = false ; - base= Dec ; - signedconv= false ; - width = 0 ; - uppercase= false ; - sign = 1 ; - prec = (-1); - conv = "f"} 0 - - - -let finish_formatting (config : fmt) rawbuffer = - let { - justify; - signstyle; - filter ; - alternate; - base; - signedconv; - width; - uppercase; - sign; - prec = _ ; - conv = _ ; - } = config in - let len = ref (Caml_string_extern.length rawbuffer) in - if signedconv && (sign < 0 || signstyle <> "-") then - len.contents <- len.contents + 1; - if alternate then - begin - if base = Oct then - len.contents <- len.contents + 1 - else - if base = Hex then - len.contents<- len.contents + 2 - else () - end ; - let buffer = ref "" in - (* let (+=) buffer s = buffer .contents<- buffer.contents ^ s in - FIXME: should get inlined - *) - (* let (+:) s = buffer .contents<- buffer.contents ^ s in *) - if justify = "+" && filter = " " then - for _ = len.contents to width - 1 do - buffer.contents<- buffer.contents ^ filter - done; - if signedconv then - if sign < 0 then - buffer .contents<- buffer.contents ^ "-" - else if signstyle <> "-" then - buffer .contents<- buffer.contents ^ signstyle - else () ; - if alternate && base = Oct then - buffer .contents<- buffer.contents ^ "0"; - if alternate && base == Hex then - buffer .contents<- buffer.contents ^ "0x"; - - if justify = "+" && filter = "0" then - for _ = len.contents to width - 1 do - buffer .contents<- buffer.contents ^ filter; - done; - begin - if uppercase then - buffer .contents<- buffer.contents ^ Caml_string_extern.toUpperCase rawbuffer - else - buffer .contents<- buffer.contents ^ rawbuffer - end; - if justify = "-" then - for _ = len.contents to width - 1 do - buffer .contents<- buffer.contents ^ " "; - done; - buffer.contents - - - -let aux f (i : int) : string = - let i = - if i < 0 then - if f.signedconv then - begin - f.sign <- -1; - (-i)>>>0 - (* when i is min_int, [-i] could overflow *) - end - else - i >>> 0 - else i in - let s = ref (Caml_string_extern.of_int i ~base:(int_of_base f.base)) in - if f.prec >= 0 then - begin - f.filter <- " "; - let n = f.prec -Caml_string_extern.length s.contents in - if n > 0 then - s .contents<- Caml_string_extern.repeat "0" n ^ s.contents - end ; - finish_formatting f s.contents - -let format_int fmt i = - if fmt = "%d" then Caml_nativeint_extern.to_string i - else - let f = parse_format fmt in - aux f i - -(* This can handle unsigned integer (-1L) and print it as "%Lu" which - will overflow signed integer in general -*) -let dec_of_pos_int64 x = - - - (if x < 0L then - - let wbase = 10L in - let cvtbl = "0123456789" in - let y = Caml_int64.discard_sign x in - (* 2 ^ 63 + y `div_mod` 10 *) - - let quotient_l = 922337203685477580L (* 2 ^ 63 / 10 *) - (* {lo = -858993460n; hi = 214748364n} *) - (* TODO: int64 constant folding so that we can do idiomatic code - 2 ^ 63 / 10 *)in - let modulus_l = 8L in - (* let c, d = Caml_int64.div_mod (Caml_int64.add y modulus_l) wbase in - we can not do the code above, it can overflow when y is really large - *) - let c, d = Caml_int64.div_mod y wbase in - let e ,f = Caml_int64.div_mod (Caml_int64_extern.add modulus_l d) wbase in - let quotient = - (Caml_int64_extern.add (Caml_int64_extern.add quotient_l c ) - e) in - Caml_int64.to_string quotient ^ - (Caml_string_extern.get_string_unsafe - cvtbl (Caml_int64_extern.to_int f)) - else - Caml_int64.to_string x) - -let oct_of_int64 x = - let s = ref "" in - let wbase = 8L in - let cvtbl = "01234567" in - (if x < 0L then - begin - let y = Caml_int64.discard_sign x in - (* 2 ^ 63 + y `div_mod` 8 *) - let quotient_l = 1152921504606846976L - (* {lo = 0n; hi = 268435456n } *) (* 2 ^ 31 / 8 *) - in - - (* let c, d = Caml_int64.div_mod (Caml_int64.add y modulus_l) wbase in - we can not do the code above, it can overflow when y is really large - *) - let c, d = Caml_int64.div_mod y wbase in - - let quotient = - ref (Caml_int64_extern.add quotient_l c ) in - let modulus = ref d in - s .contents<- - Caml_string_extern.get_string_unsafe - cvtbl (Caml_int64_extern.to_int modulus.contents) ^ s.contents ; - - while quotient.contents <> 0L do - let a, b = Caml_int64.div_mod quotient.contents wbase in - quotient .contents<- a; - modulus .contents<- b; - s .contents<- Caml_string_extern.get_string_unsafe cvtbl (Caml_int64_extern.to_int modulus.contents) ^ s.contents ; - done; - end - else - let a, b = Caml_int64.div_mod x wbase in - let quotient = ref a in - let modulus = ref b in - s .contents<- - Caml_string_extern.get_string_unsafe - cvtbl (Caml_int64_extern.to_int modulus.contents) ^ s.contents ; - - while quotient.contents <> 0L do - let a, b = Caml_int64.div_mod (quotient.contents) wbase in - quotient .contents<- a; - modulus .contents<- b; - s .contents<- Caml_string_extern.get_string_unsafe cvtbl (Caml_int64_extern.to_int modulus.contents) ^ s.contents ; - done); s.contents - - -(* FIXME: improve codegen for such cases - let div_mod (x : int64) (y : int64) : int64 * int64 = - let a, b = Caml_int64.(div_mod (unsafe_of_int64 x) (unsafe_of_int64 y)) in - Caml_int64.unsafe_to_int64 a , Caml_int64.unsafe_to_int64 b -*) -let int64_format fmt x = - if fmt = "%d" then Caml_int64.to_string x - else - let f = parse_format fmt in - let x = - if f.signedconv && x < 0L then - begin - f.sign <- -1; - Caml_int64_extern.neg x - end - else x in - let s = - - begin match f.base with - | Hex -> - Caml_int64.to_hex x - | Oct -> - oct_of_int64 x - | Dec -> - dec_of_pos_int64 x - end in - let fill_s = - if f.prec >= 0 then - begin - f.filter <- " "; - let n = f.prec -Caml_string_extern.length s in - if n > 0 then - ("0" |. Caml_string_extern.repeat n) ^ s else s - end else s in - - finish_formatting f fill_s - -let format_float fmt x = - let module String = Caml_string_extern in - let f = parse_format fmt in - let prec = if f.prec < 0 then 6 else f.prec in - let x = if x < 0. then (f.sign <- (-1); -. x) else x in - let s = ref "" in - if Caml_float_extern.isNaN x then - begin - s .contents<- "nan"; - f.filter <- " " - end - else if not (Caml_float_extern.isFinite x) then - begin - s .contents<- "inf"; - f.filter <- " " - end - else - begin - match f.conv with - | "e" - -> - s .contents<- Caml_float_extern.toExponentialWithPrecision x ~digits:prec; - (* exponent should be at least two digits - {[ - (3.3).toExponential() - "3.3e+0" - 3.3e+00 - ]} - *) - let i =Caml_string_extern.length s.contents in - if s.contents.[i-3] = 'e' then - begin - s .contents<- Caml_string_extern.slice s.contents 0 (i - 1) ^ "0" ^ Caml_string_extern.slice_rest s.contents (i - 1) - end - | "f" - -> - (* this will not work large numbers *) - (* ("%3.10f", 3e+56, "300000000000000005792779041490073052596128503513888063488.0000000000") *) - s .contents<- Caml_float_extern.toFixedWithPrecision x ~digits:prec - | "g" -> - let prec = if prec <> 0 then prec else 1 in - s .contents<- Caml_float_extern.toExponentialWithPrecision x ~digits:(prec - 1); - let j = Caml_string_extern.index_of s.contents "e" in - let exp = Caml_float.int_of_float (Caml_float_extern.fromString (Caml_string_extern.slice_rest s.contents (j + 1))) in - if exp < -4 || x >= 1e21 ||Caml_string_extern.length (Caml_float_extern.toFixed x) > prec then - let i = ref (j - 1) in - while s.contents.[i.contents] = '0' do - i.contents <- i.contents - 1 - done; - if s.contents.[i.contents] = '.' then - i.contents <- i.contents - 1 ; - s .contents<- Caml_string_extern.slice s.contents 0 (i.contents+1) ^ Caml_string_extern.slice_rest s.contents j ; - let i =Caml_string_extern.length s.contents in - if s.contents.[i - 3] = 'e' then - s .contents<- Caml_string_extern.slice s.contents 0 (i - 1) ^ "0" ^ Caml_string_extern.slice_rest s.contents (i - 1) - else () - else - let p = ref prec in - if exp < 0 then - begin - p.contents<- p.contents - (exp + 1); - s.contents<- Caml_float_extern.toFixedWithPrecision x ~digits:p.contents - end - else - while (s .contents<- Caml_float_extern.toFixedWithPrecision x ~digits:p.contents;Caml_string_extern.length s.contents > prec + 1) do - p.contents <- p.contents - 1 - done ; - if p.contents <> 0 then - let k = ref (Caml_string_extern.length s.contents - 1) in - while s.contents.[k.contents] = '0' do - k.contents <- k.contents - 1 - done ; - if s.contents.[k.contents] = '.' then - k.contents <- k.contents - 1 ; - s .contents<- Caml_string_extern.slice s.contents 0 (k.contents + 1) - - | _ -> () - end; - finish_formatting f s.contents - - - - -let hexstring_of_float : float -> int -> char -> string = - [%raw{|function(x,prec,style){ - if (!isFinite(x)) { - if (isNaN(x)) return "nan"; - return x > 0 ? "infinity":"-infinity"; - } - var sign = (x==0 && 1/x == -Infinity)?1:(x>=0)?0:1; - if(sign) x = -x; - var exp = 0; - if (x == 0) { } - else if (x < 1) { - while (x < 1 && exp > -1022) { x *= 2; exp-- } - } else { - while (x >= 2) { x /= 2; exp++ } - } - var exp_sign = exp < 0 ? '' : '+'; - var sign_str = ''; - if (sign) sign_str = '-' - else { - switch(style){ - case 43 /* '+' */: sign_str = '+'; break; - case 32 /* ' ' */: sign_str = ' '; break; - default: break; - } - } - if (prec >= 0 && prec < 13) { - /* If a precision is given, and is small, round mantissa accordingly */ - var cst = Math.pow(2,prec * 4); - x = Math.round(x * cst) / cst; - } - var x_str = x.toString(16); - if(prec >= 0){ - var idx = x_str.indexOf('.'); - if(idx<0) { - x_str += '.' + '0'.repeat(prec); - } - else { - var size = idx+1+prec; - if(x_str.length < size) - x_str += '0'.repeat(size - x_str.length); - else - x_str = x_str.substr(0,size); - } - } - return (sign_str + '0x' + x_str + 'p' + exp_sign + exp.toString(10)); -}|}] - - -let float_of_string : string -> exn -> float = - [%raw{|function(s,exn){ - - var res = +s; - if ((s.length > 0) && (res === res)) - return res; - s = s.replace(/_/g, ""); - res = +s; - if (((s.length > 0) && (res === res)) || /^[+-]?nan$/i.test(s)) { - return res; - }; - var m = /^ *([+-]?)0x([0-9a-f]+)\.?([0-9a-f]*)p([+-]?[0-9]+)/i.exec(s); - // 1 2 3 4 - if(m){ - var m3 = m[3].replace(/0+$/,''); - var mantissa = parseInt(m[1] + m[2] + m3, 16); - var exponent = (m[4]|0) - 4*m3.length; - res = mantissa * Math.pow(2, exponent); - return res; - } - if (/^\+?inf(inity)?$/i.test(s)) - return Infinity; - if (/^-inf(inity)?$/i.test(s)) - return -Infinity; - throw exn; -} -|}] - - - -(** - Pervasives.float_of_string : string -> float = "?float_of_string" - Semantics is slightly different from javascript : - console.assert(float_of_string('infinity')===Infinity) - console.assert(float_of_string('Infinity')===Infinity - parseFloat('Infinity') === Infinity - parseFloat('infinity') === Nan -*) -let float_of_string (s : string) : float = - float_of_string s (Failure "float_of_string") - - - - - - diff --git a/jscomp/runtime/caml_format.mli b/jscomp/runtime/caml_format.mli deleted file mode 100644 index 5dbe9d9..0000000 --- a/jscomp/runtime/caml_format.mli +++ /dev/null @@ -1,46 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - - - - - - - -(** *) - -val format_float : string -> float -> string - -val hexstring_of_float : float -> int -> char -> string - -val format_int : string -> int -> string - - - -val float_of_string : string -> float -val int64_format : string -> int64 -> string -val int_of_string : string -> int - -val int64_of_string : string -> int64 - diff --git a/jscomp/runtime/caml_hash.res b/jscomp/runtime/caml_hash.res deleted file mode 100644 index 60542c5..0000000 --- a/jscomp/runtime/caml_hash.res +++ /dev/null @@ -1,151 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ -@@bs.config({flags: ["-bs-noassertfalse"]}) -type rec cell<'a> = { - content: 'a, - mutable next: option>, -} -and t<'a> = { - mutable length: int, - mutable first: option>, - mutable last: option>, -} - -let create_queue = () => { - length: 0, - first: None, - last: None, -} - -/* Added to tail */ -let push_back = (q: t<'a>, v: 'a) => { - let cell = Some({content: v, next: None}) - - switch q.last { - | None => - q.length = 1 - q.first = cell - q.last = cell - | Some(last) => - q.length = q.length + 1 - last.next = cell - q.last = cell - } -} - -let is_empty_queue = q => q.length == 0 - -/* pop from front */ - -let unsafe_pop = (q: t<'a>) => - switch q.first { - | None => assert(false) - | Some(cell) => - let next = cell.next - if next == None { - q.length = 0 - q.first = None - q.last = None - } else { - q.length = q.length - 1 - q.first = next - } - cell.content - } - -let {hash_mix_int, hash_final_mix, hash_mix_string} = module(Caml_hash_primitive) - -let hash = (count: int, _limit, seed: int, obj: Obj.t): int => { - let s = ref(seed) - if Js.typeof(obj) == "number" { - let u = Caml_nativeint_extern.of_float(Obj.magic(obj)) - s.contents = hash_mix_int(s.contents, u + u + 1) - hash_final_mix(s.contents) - } else if Js.typeof(obj) == "string" { - s.contents = hash_mix_string(s.contents, (Obj.magic(obj): string)) - hash_final_mix(s.contents) - } else { - /* TODO: hash [null] [undefined] as well */ - - let queue = create_queue() - let num = ref(count) - let () = { - push_back(queue, obj) - num.contents = num.contents - 1 - } - - while !is_empty_queue(queue) && num.contents > 0 { - let obj = unsafe_pop(queue) - if Js.typeof(obj) == "number" { - let u = Caml_nativeint_extern.of_float(Obj.magic(obj)) - s.contents = hash_mix_int(s.contents, u + u + 1) - num.contents = num.contents - 1 - } else if Js.typeof(obj) == "string" { - s.contents = hash_mix_string(s.contents, (Obj.magic(obj): string)) - num.contents = num.contents - 1 - } else if Js.typeof(obj) == "boolean" { - () - } else if Js.typeof(obj) == "undefined" { - () - } else if Js.typeof(obj) == "symbol" { - () - } else if Js.typeof(obj) == "function" { - () - } else { - let size = Obj.size(obj) - if size != 0 { - let obj_tag = Obj.tag(obj) - let tag = lor(lsl(size, 10), obj_tag) - if obj_tag == 248 /* Obj.object_tag */ { - s.contents = hash_mix_int(s.contents, (Obj.obj(Obj.field(obj, 1)): int)) - } else { - s.contents = hash_mix_int(s.contents, tag) - let block = { - let v = size - 1 - if v < num.contents { - v - } else { - num.contents - } - } - for i in 0 to block { - push_back(queue, Obj.field(obj, i)) - } - } - } else { - let size: int = %raw(`function(obj,cb){ - var size = 0 - for(var k in obj){ - cb(obj[k]) - ++ size - } - return size - }`)(.obj, (. v) => push_back(queue, v)) - s.contents = hash_mix_int(s.contents, lor(lsl(size, 10), 0)) /* tag */ - } - } - } - hash_final_mix(s.contents) - } -} diff --git a/jscomp/runtime/caml_hash.resi b/jscomp/runtime/caml_hash.resi deleted file mode 100644 index da8fd9e..0000000 --- a/jscomp/runtime/caml_hash.resi +++ /dev/null @@ -1,25 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let hash: (int, 'a, int, Obj.t) => int diff --git a/jscomp/runtime/caml_hash_primitive.res b/jscomp/runtime/caml_hash_primitive.res deleted file mode 100644 index 281b623..0000000 --- a/jscomp/runtime/caml_hash_primitive.res +++ /dev/null @@ -1,78 +0,0 @@ -/* Copyright (C) 2018 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let rotl32 = (x: int, n) => lor(lsl(x, n), lsr(x, 32 - n)) - -@send external charCodeAt: (string, int) => int = "charCodeAt" - -let hash_mix_int = (h, d) => { - let d = ref(d) - d.contents = d.contents * 0xcc9e2d51 - d.contents = rotl32(d.contents, 15) - d.contents = d.contents * 0x1b873593 - let h = ref(lxor(h, d.contents)) - h.contents = rotl32(h.contents, 13) - h.contents + lsl(h.contents, 2) + 0xe6546b64 -} - -let hash_final_mix = h => { - let h = ref(lxor(h, lsr(h, 16))) - h.contents = h.contents * 0x85ebca6b - h.contents = lxor(h.contents, lsr(h.contents, 13)) - h.contents = h.contents * 0xc2b2ae35 - lxor(h.contents, lsr(h.contents, 16)) -} -/* Caml_nativeint_extern.logand (h.contents ^ (h.contents >>> 16)) 0x3FFFFFFFn */ - -let hash_mix_string = (h, s) => { - let len = Caml_string_extern.length(s) - let block = len / 4 - 1 - let hash = ref(h) - for i in 0 to block { - let j = 4 * i - let w = lor( - lor(lor(s->charCodeAt(j), lsl(s->charCodeAt(j + 1), 8)), lsl(s->charCodeAt(j + 2), 16)), - lsl(s->charCodeAt(j + 3), 24), - ) - - hash.contents = hash_mix_int(hash.contents, w) - } - let modulo = land(len, 0b11) - if modulo != 0 { - let w = if modulo == 3 { - lor( - lor(lsl(s->charCodeAt(len - 1), 16), lsl(s->charCodeAt(len - 2), 8)), - s->charCodeAt(len - 3), - ) - } else if modulo == 2 { - lor(lsl(s->charCodeAt(len - 1), 8), s->charCodeAt(len - 2)) - } else { - s->charCodeAt(len - 1) - } - - hash.contents = hash_mix_int(hash.contents, w) - } - hash.contents = lxor(hash.contents, len) - hash.contents -} diff --git a/jscomp/runtime/caml_hash_primitive.resi b/jscomp/runtime/caml_hash_primitive.resi deleted file mode 100644 index 7066bf4..0000000 --- a/jscomp/runtime/caml_hash_primitive.resi +++ /dev/null @@ -1,27 +0,0 @@ -/* Copyright (C) 2018 Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let hash_mix_int: (int, int) => int -let hash_mix_string: (int, string) => int -let hash_final_mix: int => int diff --git a/jscomp/runtime/caml_int32.res b/jscomp/runtime/caml_int32.res deleted file mode 100644 index bba66cf..0000000 --- a/jscomp/runtime/caml_int32.res +++ /dev/null @@ -1,37 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let div = (x: int, y: int) => - if y == 0 { - raise(Division_by_zero) - } else { - Caml_nativeint_extern.div(x, y) - } - -let mod_ = (x: int, y: int) => - if y == 0 { - raise(Division_by_zero) - } else { - Caml_nativeint_extern.rem(x, y) - } diff --git a/jscomp/runtime/caml_int32.resi b/jscomp/runtime/caml_int32.resi deleted file mode 100644 index 56ef485..0000000 --- a/jscomp/runtime/caml_int32.resi +++ /dev/null @@ -1,27 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let div: (int, int) => int - -let mod_: (int, int) => int diff --git a/jscomp/runtime/caml_int64.res b/jscomp/runtime/caml_int64.res deleted file mode 100644 index 7958282..0000000 --- a/jscomp/runtime/caml_int64.res +++ /dev/null @@ -1,564 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* This module would only work with js backend, since it requires - [int] behaves as js numbers -*/ - -/* TODO: see GPR#333 - the encoding of int is platform dependent */ - -%%private( - let {shift_right_logical: \">>>~", add: \"+~", mul: \"*~"} = module(Caml_nativeint_extern) -) - -let {i64_eq: eq, i64_ge: ge, i64_gt: gt} = module(Caml) - -let lognot = x => lxor(x, -1) - -/* [hi] is signed - [lo] is unsigned - - signedness does not matter when they are doing int32 bits operation - however, they are different when doing comparison -*/ -type t = Caml_int64_extern.t = {@as("0") hi: int, @as("1") lo: int} - -external unsafe_to_int64: t => int64 = "%identity" -external unsafe_of_int64: int64 => t = "%identity" - -@inline let mk = (~lo, ~hi) => {lo: \">>>~"(lo, 0), hi} -let min_int = mk(~lo=0, ~hi=0x80000000) -/* The high bits are signed 0x80000000 |~ 0 */ - -let max_int = mk(~lo=0xffff_ffff, ~hi=0x7fff_ffff) - -let one = mk(~lo=1, ~hi=0) -let zero = mk(~lo=0, ~hi=0) -let neg_one = mk(~lo=-1, ~hi=-1) - -let neg_signed = x => land(x, 0x8000_0000) != 0 -let non_neg_signed = x => land(x, 0x8000_0000) == 0 -let succ_aux = (~x_lo, ~x_hi) => { - let lo = lor(\"+~"(x_lo, 1), 0) - mk( - ~lo, - ~hi=lor( - \"+~"( - x_hi, - if lo == 0 { - 1 - } else { - 0 - }, - ), - 0, - ), - ) -} -let succ = ({lo: x_lo, hi: x_hi}: t) => succ_aux(~x_lo, ~x_hi) - -let neg = ({lo, hi}) => { - let other_lo = lor(\"+~"(lognot(lo), 1), 0) - mk( - ~lo=other_lo, - ~hi=lor( - \"+~"( - lognot(hi), - if other_lo == 0 { - 1 - } else { - 0 - }, - ), - 0, - ), - ) -} - -let add_aux = ({lo: x_lo, hi: x_hi}: t, ~y_lo, ~y_hi) => { - let lo = lor(\"+~"(x_lo, y_lo), 0) - let overflow = if ( - (neg_signed(x_lo) && (neg_signed(y_lo) || non_neg_signed(lo))) || - (neg_signed(y_lo) && non_neg_signed(lo)) - ) { - /* we can make it symmetric by adding (neg_signed x_lo) but it will make it - verbose and slow - a (b+c) + b (a+c) - --> bc + ac + ab - --> a (b+c) + bc - */ - 1 - } else { - 0 - } - - mk(~lo, ~hi=lor(\"+~"(\"+~"(x_hi, y_hi), overflow), 0)) -} - -let add = (self: t, {lo: y_lo, hi: y_hi}: t) => add_aux(self, ~y_lo, ~y_hi) - -/* let not ( {lo; hi }) = mk ~lo:(lognot lo) ~hi:(lognot hi) */ - -let equal = (x, y) => x.lo == y.lo && x.hi == y.hi -let equal_null = (x, y) => - switch Js.nullToOption(y) { - | None => false - | Some(y) => eq(x, y) - } -let equal_undefined = (x, y) => - switch Js.undefinedToOption(y) { - | None => false - | Some(y) => eq(x, y) - } -let equal_nullable = (x, y) => - switch Js.toOption(y) { - | None => false - | Some(y) => eq(x, y) - } - -/* when [lo] is unsigned integer, [lognot lo] is still an unsigned integer */ -let sub_aux = (x, ~lo, ~hi) => { - let y_lo = \">>>~"(\"+~"(lognot(lo), 1), 0) - let y_hi = lor( - \"+~"( - lognot(hi), - if y_lo == 0 { - 1 - } else { - 0 - }, - ), - 0, - ) - add_aux(x, ~y_lo, ~y_hi) -} - -let sub = (self, {lo, hi}) => sub_aux(self, ~lo, ~hi) - -let lsl_ = ({lo, hi} as x, numBits) => - if numBits == 0 { - x - } else if numBits >= 32 { - mk(~lo=0, ~hi=lsl(lo, numBits - 32)) - } else { - mk(~lo=lsl(lo, numBits), ~hi=lor(\">>>~"(lo, 32 - numBits), lsl(hi, numBits))) - } - -let lsr_ = ({lo, hi} as x, numBits) => - if numBits == 0 { - x - } else { - let offset = numBits - 32 - if offset == 0 { - mk(~lo=hi, ~hi=0) - } else if offset > 0 { - mk(~lo=\">>>~"(hi, offset), ~hi=0) - } else { - mk(~hi=\">>>~"(hi, numBits), ~lo=lor(lsl(hi, -offset), \">>>~"(lo, numBits))) - } - } - -let asr_ = ({lo, hi} as x, numBits) => - if numBits == 0 { - x - } else if numBits < 32 { - mk( - ~hi=asr(hi, numBits), - ~lo=/* zero filled */ - lor(lsl(hi, 32 - numBits), \">>>~"(lo, numBits)), - ) - } else { - mk( - ~hi=if hi >= 0 { - 0 - } else { - -1 - }, - ~lo=asr(hi, numBits - 32), - ) - } - -let is_zero = x => - switch x { - | {lo: 0, hi: 0} => true - | _ => false - } - -let rec mul = (this, other) => - switch (this, other) { - | ({lo: 0, hi: 0}, _) - | (_, {lo: 0, hi: 0}) => zero - | ({lo: 0, hi: -0x80000000}, {lo, _}) - | ({lo, _}, {lo: 0, hi: -0x80000000}) => - if land(lo, 0x1) == 0 { - zero - } else { - min_int - } - | ({lo: this_lo, hi: this_hi}, {lo: other_lo, hi: other_hi}) => - if this_hi < 0 { - if other_hi < 0 { - mul(neg(this), neg(other)) - } else { - neg(mul(neg(this), other)) - } - } else if other_hi < 0 { - neg(mul(this, neg(other))) - } else { - /* TODO: when both are small, use float multiplication */ - let a48 = \">>>~"(this_hi, 16) - let a32 = land(this_hi, 0xffff) - let a16 = \">>>~"(this_lo, 16) - let a00 = land(this_lo, 0xffff) - - let b48 = \">>>~"(other_hi, 16) - let b32 = land(other_hi, 0xffff) - let b16 = \">>>~"(other_lo, 16) - let b00 = land(other_lo, 0xffff) - - let c48 = ref(0) - let c32 = ref(0) - let c16 = ref(0) - - let c00 = \"*~"(a00, b00) - c16.contents = \"+~"(\">>>~"(c00, 16), \"*~"(a16, b00)) - c32.contents = \">>>~"(c16.contents, 16) - c16.contents = \"+~"(land(c16.contents, 0xffff), \"*~"(a00, b16)) - c32.contents = \"+~"(\"+~"(c32.contents, \">>>~"(c16.contents, 16)), \"*~"(a32, b00)) - c48.contents = \">>>~"(c32.contents, 16) - c32.contents = \"+~"(land(c32.contents, 0xffff), \"*~"(a16, b16)) - c48.contents = \"+~"(c48.contents, \">>>~"(c32.contents, 16)) - c32.contents = \"+~"(land(c32.contents, 0xffff), \"*~"(a00, b32)) - c48.contents = \"+~"(c48.contents, \">>>~"(c32.contents, 16)) - c32.contents = land(c32.contents, 0xffff) - c48.contents = land( - \"+~"( - c48.contents, - \"+~"(\"+~"(\"+~"(\"*~"(a48, b00), \"*~"(a32, b16)), \"*~"(a16, b32)), \"*~"(a00, b48)), - ), - 0xffff, - ) - mk( - ~lo=lor(land(c00, 0xffff), lsl(land(c16.contents, 0xffff), 16)), - ~hi=lor(c32.contents, lsl(c48.contents, 16)), - ) - } - } - -/* Dispatched by the compiler, idea: should we do maximum sharing - */ -let xor = ({lo: this_lo, hi: this_hi}, {lo: other_lo, hi: other_hi}) => - mk(~lo=lxor(this_lo, other_lo), ~hi=lxor(this_hi, other_hi)) - -let or_ = ({lo: this_lo, hi: this_hi}, {lo: other_lo, hi: other_hi}) => - mk(~lo=lor(this_lo, other_lo), ~hi=lor(this_hi, other_hi)) - -let and_ = ({lo: this_lo, hi: this_hi}, {lo: other_lo, hi: other_hi}) => - mk(~lo=land(this_lo, other_lo), ~hi=land(this_hi, other_hi)) - -/* TODO: if we encode lo int32 bit as unsigned then - this is not necessary, - however (x>>>0 >>>0) is not that bad -*/ - -let to_float = ({hi, lo}: t) => - Caml_nativeint_extern.to_float(\"+~"(\"*~"(hi, %raw(`0x100000000`)), lo)) - -/** sign: Positive - -FIXME: hex notation -*/ -let two_ptr_32_dbl = 4294967296. /* 2. ** 32 */ -let two_ptr_63_dbl = 9.22337203685477581e+18 /* 2. ** 63. */ -let neg_two_ptr_63 = -9.22337203685477581e+18 /* -. (2. ** 63.) */ - -external mod_float: (float, float) => float = "?fmod_float" -/* note that we make sure the const number can acutally be represented - {[ - (2. ** 63. -. 1. = 2. ** 63.) ;; - ]} -*/ - -let rec of_float = (x: float): t => - if Caml_float_extern.isNaN(x) || Pervasives.not(Caml_float_extern.isFinite(x)) { - zero - } else if x <= neg_two_ptr_63 { - min_int - } else if x +. 1. >= two_ptr_63_dbl { - max_int /* Undefined behavior */ - } else if x < 0. { - neg(of_float(-.x)) - } else { - mk( - ~lo=Caml_nativeint_extern.of_float(mod_float(x, two_ptr_32_dbl)), - ~hi=Caml_nativeint_extern.of_float(x /. two_ptr_32_dbl), - ) - } - -@val @scope("Math") external log2: float = "LN2" -@val @scope("Math") external log: float => float = "log" -@val @scope("Math") external ceil: float => float = "ceil" -@val @scope("Math") external floor: float => float = "floor" -/* external maxFloat : float -> float -> float = "Math.max" [@@bs.val] */ - -/* either top 11 bits are all 0 or all 1 - when it is all 1, we need exclude -2^53 -*/ -let isSafeInteger = ({hi, lo}) => { - let top11Bits = asr(hi, 21) - top11Bits == 0 || (top11Bits == -1 && Pervasives.not(lo == 0 && hi == 0xff_e0_00_00)) -} - -@val external string_of_float: float => string = "String" -let rec to_string = (self: int64) => { - let {hi: self_hi, _} as self = unsafe_of_int64(self) - if isSafeInteger(self) { - string_of_float(to_float(self)) - } else if self_hi < 0 { - if eq(self, min_int) { - "-9223372036854775808" - } else { - "-" ++ to_string(unsafe_to_int64(neg(self))) - } - } else { - /* large positive number */ - let {lo, hi} as approx_div1 = of_float(floor(to_float(self) /. 10.)) - let {lo: rem_lo, hi: rem_hi} = - /* rem should be a pretty small number */ - self - ->sub_aux(~lo=lsl(lo, 3), ~hi=lor(\">>>~"(lo, 29), lsl(hi, 3))) - ->sub_aux(~lo=lsl(lo, 1), ~hi=lor(\">>>~"(lo, 31), lsl(hi, 1))) - - if rem_lo == 0 && rem_hi == 0 { - to_string(unsafe_to_int64(approx_div1)) ++ "0" - } else if rem_hi < 0 { - /* let ( {lo = rem_lo}) = neg rem in */ - let rem_lo = \">>>~"(\"+~"(lognot(rem_lo), 1), 0)->Caml_nativeint_extern.to_float - let delta = ceil(rem_lo /. 10.) - let remainder = 10. *. delta -. rem_lo - approx_div1 - ->sub_aux(~lo=Caml_nativeint_extern.of_float(delta), ~hi=0) - ->unsafe_to_int64 - ->to_string ++ Caml_nativeint_extern.to_string(Caml_nativeint_extern.of_float(remainder)) - } else { - let rem_lo = Caml_nativeint_extern.to_float(rem_lo) - let delta = floor(rem_lo /. 10.) - let remainder = rem_lo -. 10. *. delta - approx_div1 - ->add_aux(~y_lo=Caml_nativeint_extern.of_float(delta), ~y_hi=0) - ->unsafe_to_int64 - ->to_string ++ Caml_nativeint_extern.to_string(Caml_nativeint_extern.of_float(remainder)) - } - } -} - -@inline -let float_max = (a: float, b) => - if a > b { - a - } else { - b - } -let rec div = (self, other) => - switch (self, other) { - | (_, {lo: 0, hi: 0}) => raise(Division_by_zero) - | ({lo: 0, hi: 0}, _) => zero - | ({lo: 0, hi: -0x8000_0000}, _) => - if eq(other, one) || eq(other, neg_one) { - self - } else if eq(other, min_int) { - one - } else { - let {hi: other_hi, _} = other - /* now |other| >= 2, so |this/other| < |MIN_VALUE| */ - let half_this = asr_(self, 1) - let approx = lsl_(div(half_this, other), 1) - switch approx { - | {lo: 0, hi: 0} => - if other_hi < 0 { - one - } else { - neg(one) - } - | _ => - let rem = sub(self, mul(other, approx)) - add(approx, div(rem, other)) - } - } - | (_, {lo: 0, hi: -0x8000_0000}) => zero - | ({lo: _, hi: self_hi}, {lo: _, hi: other_hi}) => - if self_hi < 0 { - if other_hi < 0 { - div(neg(self), neg(other)) - } else { - neg(div(neg(self), other)) - } - } else if other_hi < 0 { - neg(div(self, neg(other))) - } else { - let res = ref(zero) - let rem = ref(self) - /* assert false */ - while ge(rem.contents, other) { - let approx = ref(float_max(1., Caml_float.floor(to_float(rem.contents) /. to_float(other)))) - let log2 = ceil(log(approx.contents) /. log2) - let delta = if log2 <= 48. { - 1. - } else { - 2. ** (log2 -. 48.) - } - let approxRes = ref(of_float(approx.contents)) - let approxRem = ref(mul(approxRes.contents, other)) - while ( - switch approxRem.contents { - | {hi, _} => hi - } < 0 || gt(approxRem.contents, rem.contents) - ) { - approx.contents = approx.contents -. delta - approxRes.contents = of_float(approx.contents) - approxRem.contents = mul(approxRes.contents, other) - } - if is_zero(approxRes.contents) { - approxRes.contents = one - } - res.contents = add(res.contents, approxRes.contents) - rem.contents = sub(rem.contents, approxRem.contents) - } - res.contents - } - } - -let mod_ = (self, other) => sub(self, mul(div(self, other), other)) - -let div_mod = (self: int64, other: int64): (int64, int64) => { - let quotient = div(unsafe_of_int64(self), unsafe_of_int64(other)) - ( - unsafe_to_int64(quotient), - unsafe_to_int64(sub(unsafe_of_int64(self), mul(quotient, unsafe_of_int64(other)))), - ) -} - -/** Note this function is unasfe here, but when combined it is actually safe - In theory, we need do an uint_compare for [lo] components - The thing is [uint_compare] and [int_compare] are specialised - to the same code when translted into js -*/ -@inline -let int_compare = (x: int, y) => - if x < y { - -1 - } else if x == y { - 0 - } else { - 1 - } - -let compare = (self, other) => { - let v = int_compare(self.hi, other.hi) - if v == 0 { - int_compare(self.lo, other.lo) - } else { - v - } -} - -let of_int32 = (lo: int) => - mk( - ~lo, - ~hi=if lo < 0 { - -1 - } else { - 0 - }, - ) - -let to_int32 = x => lor(x.lo, 0) /* signed integer */ - -/* width does matter, will it be relevant to endian order? */ - -let to_hex = (x: int64) => { - let {hi: x_hi, lo: x_lo} = unsafe_of_int64(x) - let aux = (v): string => - Caml_string_extern.of_int(Caml_nativeint_extern.shift_right_logical(v, 0), ~base=16) - - switch (x_hi, x_lo) { - | (0, 0) => "0" - | (_, 0) => aux(x_hi) ++ "00000000" - | (0, _) => aux(x_lo) - | (_, _) => - let lo = aux(x_lo) - let pad = 8 - Caml_string_extern.length(lo) - if pad <= 0 { - aux(x_hi) ++ lo - } else { - aux(x_hi) ++ (Caml_string_extern.repeat("0", pad) ++ lo) - } - } -} - -let discard_sign = (x: int64): int64 => { - let v = unsafe_of_int64(x) - unsafe_to_int64( - switch v { - | v => {...v, hi: land(0x7fff_ffff, v.hi)} - }, - ) -} - -/* >>> 0 does not change its bit representation - it simply makes sure it is an unsigned integer - -1 >>> 0 -> 4294967295 - Which is still (-1) if you interpret it as a signed integer - When we do the call (new Int32Array(x[1], x[0]), it will - convert x[0] from an unsigned integer to signed integer - {[ - new Int32Array([-1 >>> 0]) - Int32Array(1)[-1] - ]} -*/ - -let float_of_bits = (x: t): float => - ( - %raw(`function(lo,hi){ return (new Float64Array(new Int32Array([lo,hi]).buffer))[0]}`): ( - _, - _, - ) => _ - )(x.lo, x.hi) - -/* let to_int32 (x : nativeint) = x |> Caml_nativeint_extern.to_int32 - in - (*TODO: - This should get inlined, we should apply a simple inliner in the js layer, - the thing is its lambda representation is complex but after js layer, - it's qutie simple - *) - let int32 = Int32_array.make [| to_int32 x.lo; to_int32 x.hi |] in - Float64_array.unsafe_get (Float64_array.fromBuffer (Int32_array.buffer int32)) 0 */ - -let bits_of_float: float => t = x => { - let (lo, hi) = (%raw(`function(x){return new Int32Array(new Float64Array([x]).buffer)}`): _ => _)( - x, - ) - mk(~lo, ~hi) -} diff --git a/jscomp/runtime/caml_int64.resi b/jscomp/runtime/caml_int64.resi deleted file mode 100644 index 63f054a..0000000 --- a/jscomp/runtime/caml_int64.resi +++ /dev/null @@ -1,73 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t -let mk: (~lo: int, ~hi: int) => t -let succ: t => t -let min_int: t -let max_int: t -let one: t -let zero: t -let neg_one: t -/* val not : t -> t */ -let of_int32: int => t -let to_int32: t => int - -let add: (t, t) => t -let neg: t => t -let sub: (t, t) => t -let lsl_: (t, int) => t -let lsr_: (t, int) => t -let asr_: (t, int) => t -let is_zero: t => bool -let mul: (t, t) => t -let xor: (t, t) => t -let or_: (t, t) => t -let and_: (t, t) => t - -let equal: (t, t) => bool -let equal_null: (t, Js.null) => bool -let equal_undefined: (t, Js.undefined) => bool -let equal_nullable: (t, Js.nullable) => bool - -let to_float: t => float -let of_float: float => t -let div: (t, t) => t -let mod_: (t, t) => t - -let compare: (t, t) => int - -let float_of_bits: t => float - -/** [bits_of_float fl] it is undefined behaivor when [f] is NaN*/ -let bits_of_float: float => t - -/* val get64 : string -> int -> t */ - -external unsafe_to_int64: t => int64 = "%identity" -external unsafe_of_int64: int64 => t = "%identity" -let div_mod: (int64, int64) => (int64, int64) -let to_hex: int64 => string -let discard_sign: int64 => int64 -let to_string: int64 => string diff --git a/jscomp/runtime/caml_int64_extern.res b/jscomp/runtime/caml_int64_extern.res deleted file mode 100644 index 0dbe54e..0000000 --- a/jscomp/runtime/caml_int64_extern.res +++ /dev/null @@ -1,10 +0,0 @@ -external of_int: int => int64 = "%int64_of_int" -external add: (int64, int64) => int64 = "%int64_add" -external sub: (int64, int64) => int64 = "%int64_sub" -external mul: (int64, int64) => int64 = "%int64_mul" -external div: (int64, int64) => int64 = "%int64_div" -external logor: (int64, int64) => int64 = "%int64_or" -external neg: int64 => int64 = "%int64_neg" -external to_int: int64 => int = "%int64_to_int" - -type t = {@as("0") hi: int, @as("1") lo: int} diff --git a/jscomp/runtime/caml_js_exceptions.res b/jscomp/runtime/caml_js_exceptions.res deleted file mode 100644 index ddf35cc..0000000 --- a/jscomp/runtime/caml_js_exceptions.res +++ /dev/null @@ -1,42 +0,0 @@ -/* Copyright (C) 2015- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -exception Error = JsError - -/** - This function has to be in this module Since - [Error] is defined here -*/ -let internalToOCamlException = (e: unknown) => - if Caml_exceptions.is_extension(e) { - (Obj.magic(e): exn) - } else { - JsError(e) - } - -let as_js_exn = exn => - switch exn { - | Error(t) => Some(t) - | _ => None - } diff --git a/jscomp/runtime/caml_lexer.res b/jscomp/runtime/caml_lexer.res deleted file mode 100644 index 69f228b..0000000 --- a/jscomp/runtime/caml_lexer.res +++ /dev/null @@ -1,335 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type lex_tables -type lexbuf - -/* caml_lex_array("abcd") */ -/* [25185, 25699] */ -/* @param s */ -/* @returns {any[]} */ - -%%raw(` - -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: lexing.c 6045 2004-01-01 16:42:43Z doligez $ */ - -/* The table-driven automaton for lexers generated by camllex. */ - -function caml_lex_array(s) { - var l = s.length / 2; - var a = new Array(l); - // when s.charCodeAt(2 * i + 1 ) > 128 (0x80) - // a[i] < 0 - // for(var i = 0 ; i <= 0xffff; ++i) { if (i << 16 >> 16 !==i){console.log(i<<16>>16, 'vs',i)}} - // - for (var i = 0; i < l; i++) - a[i] = (s.charCodeAt(2 * i) | (s.charCodeAt(2 * i + 1) << 8)) << 16 >> 16; - return a; -} -`) - -/* - * external c_engine : lex_tables -> int -> lexbuf -> int - * lexing.ml - * type lex_tables = { - * lex_base : string; - * lex_backtrk : string; - * lex_default : string; - * lex_trans : string; - * lex_check : string; - * lex_base_code : string; - * lex_backtrk_code : string; - * lex_default_code : string; - * lex_trans_code : string; - * lex_check_code : string; - * lex_code : string; - * } - * - * type lexbuf = { - * refill_buff : lexbuf -> unit ; - * mutable lex_buffer : bytes; - * mutable lex_buffer_len : int; - * mutable lex_abs_pos : int; - * mutable lex_start_pos : int; - * mutable lex_curr_pos : int; - * mutable lex_last_pos : int; - * mutable lex_last_action : int; - * mutable lex_eof_reached : bool; - * mutable lex_mem : int array; - * mutable lex_start_p : position; - * mutable lex_curr_p; - * } - * @param tbl - * @param start_state - * @param lexbuf - * @returns {any} - */ - -let caml_lex_engine_aux: ( - lex_tables, - int, - lexbuf, - exn, -) => int = %raw(`function (tbl, start_state, lexbuf, exn){ - - if (!Array.isArray(tbl.lex_default)) { - tbl.lex_base = caml_lex_array(tbl.lex_base); - tbl.lex_backtrk = caml_lex_array(tbl.lex_backtrk); - tbl.lex_check = caml_lex_array(tbl.lex_check); - tbl.lex_trans = caml_lex_array(tbl.lex_trans); - tbl.lex_default = caml_lex_array(tbl.lex_default); - } - var c; - var state = start_state; - //var buffer = bytes_of_string(lexbuf.lex_buffer); - var buffer = lexbuf.lex_buffer; - if (state >= 0) { - /* First entry */ - lexbuf.lex_last_pos = lexbuf.lex_start_pos = lexbuf.lex_curr_pos; - lexbuf.lex_last_action = -1; - } - else { - /* Reentry after refill */ - state = -state - 1; - } - for (;;) { - /* Lookup base address or action number for current state */ - var base = tbl.lex_base[state]; - if (base < 0) - return -base - 1; - /* See if it's a backtrack point */ - var backtrk = tbl.lex_backtrk[state]; - if (backtrk >= 0) { - lexbuf.lex_last_pos = lexbuf.lex_curr_pos; - lexbuf.lex_last_action = backtrk; - } - /* See if we need a refill */ - if (lexbuf.lex_curr_pos >= lexbuf.lex_buffer_len) { - if (lexbuf.lex_eof_reached === 0) - return -state - 1; - else - c = 256; - } - else { - /* Read next input char */ - c = buffer[lexbuf.lex_curr_pos]; - lexbuf.lex_curr_pos++; - } - /* Determine next state */ - if (tbl.lex_check[base + c] === state) { - state = tbl.lex_trans[base + c]; - } - else { - state = tbl.lex_default[state]; - } - /* If no transition on this char, return to last backtrack point */ - if (state < 0) { - lexbuf.lex_curr_pos = lexbuf.lex_last_pos; - if (lexbuf.lex_last_action == -1) - throw exn - else - return lexbuf.lex_last_action; - } - else { - /* Erase the EOF condition only if the EOF pseudo-character was - consumed by the automaton (i.e. there was no backtrack above) - */ - if (c == 256) - lexbuf.lex_eof_reached = 0; - } - } -} -`) - -let empty_token_lit = "lexing: empty token" - -let lex_engine: (lex_tables, int, lexbuf) => int = (tbls, i, buf) => - caml_lex_engine_aux(tbls, i, buf, Failure(empty_token_lit)) - -%%raw(` - - -/***********************************************/ -/* New lexer engine, with memory of positions */ -/***********************************************/ - -/** - * s -> Lexing.lex_tables.lex_code - * mem -> Lexing.lexbuf.lex_mem (* int array *) - */ - -function caml_lex_run_mem(s, i, mem, curr_pos) { - for (;;) { - var dst = s.charCodeAt(i); - i++; - if (dst == 0xff) - return; - var src = s.charCodeAt(i); - i++; - if (src == 0xff) - mem[dst] = curr_pos; - else - mem[dst] = mem[src]; - } -} - - -/** - * s -> Lexing.lex_tables.lex_code - * mem -> Lexing.lexbuf.lex_mem (* int array *) - */ - -function caml_lex_run_tag(s, i, mem) { - for (;;) { - var dst = s.charCodeAt(i); - i++; - if (dst == 0xff) - return; - var src = s.charCodeAt(i); - i++; - if (src == 0xff) - mem[dst] = -1; - else - mem[dst] = mem[src]; - } -} -`) - -/* - * external c_new_engine : lex_tables -> int -> lexbuf -> int = "?new_lex_engine" - * @param tbl - * @param start_state - * @param lexbuf - * @returns {any} - */ - -let caml_new_lex_engine_aux: ( - lex_tables, - int, - lexbuf, - exn, -) => int = %raw(`function (tbl, start_state, lexbuf, exn) { - - if (!Array.isArray(tbl.lex_default)) { - tbl.lex_base = caml_lex_array(tbl.lex_base); - tbl.lex_backtrk = caml_lex_array(tbl.lex_backtrk); - tbl.lex_check = caml_lex_array(tbl.lex_check); - tbl.lex_trans = caml_lex_array(tbl.lex_trans); - tbl.lex_default = caml_lex_array(tbl.lex_default); - } - if(!Array.isArray(tbl.lex_default_code)){ - tbl.lex_base_code = caml_lex_array(tbl.lex_base_code); - tbl.lex_backtrk_code = caml_lex_array(tbl.lex_backtrk_code); - tbl.lex_check_code = caml_lex_array(tbl.lex_check_code); - tbl.lex_trans_code = caml_lex_array(tbl.lex_trans_code); - tbl.lex_default_code = caml_lex_array(tbl.lex_default_code); - } - var c, state = start_state; - //var buffer = caml_bytes_of_string(lexbuf.lex_buffer); - var buffer = lexbuf.lex_buffer; - if (state >= 0) { - /* First entry */ - lexbuf.lex_last_pos = lexbuf.lex_start_pos = lexbuf.lex_curr_pos; - lexbuf.lex_last_action = -1; - } - else { - /* Reentry after refill */ - state = -state - 1; - } - for (;;) { - /* Lookup base address or action number for current state */ - var base = tbl.lex_base[state]; - if (base < 0) { - var pc_off = tbl.lex_base_code[state]; - caml_lex_run_tag(tbl.lex_code, pc_off, lexbuf.lex_mem); - return -base - 1; - } - /* See if it's a backtrack point */ - var backtrk = tbl.lex_backtrk[state]; - if (backtrk >= 0) { - var pc_off = tbl.lex_backtrk_code[state]; - caml_lex_run_tag(tbl.lex_code, pc_off, lexbuf.lex_mem); - lexbuf.lex_last_pos = lexbuf.lex_curr_pos; - lexbuf.lex_last_action = backtrk; - } - /* See if we need a refill */ - if (lexbuf.lex_curr_pos >= lexbuf.lex_buffer_len) { - if (lexbuf.lex_eof_reached == 0) - return -state - 1; - else - c = 256; - } - else { - /* Read next input char */ - c = buffer[lexbuf.lex_curr_pos]; - lexbuf.lex_curr_pos++; - } - /* Determine next state */ - var pstate = state; - if (tbl.lex_check[base + c] == state) - state = tbl.lex_trans[base + c]; - else - state = tbl.lex_default[state]; - /* If no transition on this char, return to last backtrack point */ - if (state < 0) { - lexbuf.lex_curr_pos = lexbuf.lex_last_pos; - if (lexbuf.lex_last_action == -1) - throw exn; - else - return lexbuf.lex_last_action; - } - else { - /* If some transition, get and perform memory moves */ - var base_code = tbl.lex_base_code[pstate], pc_off; - if (tbl.lex_check_code[base_code + c] == pstate) - pc_off = tbl.lex_trans_code[base_code + c]; - else - pc_off = tbl.lex_default_code[pstate]; - if (pc_off > 0) - caml_lex_run_mem(tbl.lex_code, pc_off, lexbuf.lex_mem, lexbuf.lex_curr_pos); - /* Erase the EOF condition only if the EOF pseudo-character was - consumed by the automaton (i.e. there was no backtrack above) - */ - if (c == 256) - lexbuf.lex_eof_reached = 0; - } - } - } -`) - -let new_lex_engine: (lex_tables, int, lexbuf) => int = (tbl, i, buf) => - caml_new_lex_engine_aux(tbl, i, buf, Failure(empty_token_lit)) diff --git a/jscomp/runtime/caml_lexer.resi b/jscomp/runtime/caml_lexer.resi deleted file mode 100644 index cd01e89..0000000 --- a/jscomp/runtime/caml_lexer.resi +++ /dev/null @@ -1,31 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* the same as Lexing */ -type lex_tables -type lexbuf - -let lex_engine: (lex_tables, int, lexbuf) => int - -let new_lex_engine: (lex_tables, int, lexbuf) => int diff --git a/jscomp/runtime/caml_md5.res b/jscomp/runtime/caml_md5.res deleted file mode 100644 index b6b22d6..0000000 --- a/jscomp/runtime/caml_md5.res +++ /dev/null @@ -1,201 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let lognot = n => lxor(n, -1l) -let cmn = (q, a, b, x, s, t) => { - let a = a + q + x + t - lor(lsl(a, s), lsr(a, 32 - s)) + b -} - -let f = (a, b, c, d, x, s, t) => cmn(lor(land(b, c), land(lognot(b), d)), a, b, x, s, t) - -let g = (a, b, c, d, x, s, t) => cmn(lor(land(b, d), land(c, lognot(d))), a, b, x, s, t) - -let h = (a, b, c, d, x, s, t) => cmn(lxor(lxor(b, c), d), a, b, x, s, t) - -let i = (a, b, c, d, x, s, t) => cmn(lxor(c, lor(b, lognot(d))), a, b, x, s, t) - -let {unsafe_get, unsafe_set} = module(Caml_array_extern) - -let cycle = (x: array, k: array) => { - let a = ref(x->unsafe_get(0)) - let b = ref(x->unsafe_get(1)) - let c = ref(x->unsafe_get(2)) - let d = ref(x->unsafe_get(3)) - - a.contents = f(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(0), 7, 0xd76aa478l) - d.contents = f(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(1), 12, 0xe8c7b756l) - c.contents = f(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(2), 17, 0x242070dbl) - b.contents = f(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(3), 22, 0xc1bdceeel) - - a.contents = f(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(4), 7, 0xf57c0fafl) - d.contents = f(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(5), 12, 0x4787c62al) - c.contents = f(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(6), 17, 0xa8304613l) - b.contents = f(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(7), 22, 0xfd469501l) - - a.contents = f(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(8), 7, 0x698098d8l) - d.contents = f(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(9), 12, 0x8b44f7afl) - c.contents = f(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(10), 17, 0xffff5bb1l) - b.contents = f(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(11), 22, 0x895cd7bel) - a.contents = f(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(12), 7, 0x6b901122l) - d.contents = f(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(13), 12, 0xfd987193l) - c.contents = f(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(14), 17, 0xa679438el) - b.contents = f(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(15), 22, 0x49b40821l) - - a.contents = g(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(1), 5, 0xf61e2562l) - d.contents = g(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(6), 9, 0xc040b340l) - c.contents = g(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(11), 14, 0x265e5a51l) - b.contents = g(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(0), 20, 0xe9b6c7aal) - a.contents = g(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(5), 5, 0xd62f105dl) - d.contents = g(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(10), 9, 0x2441453l) - c.contents = g(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(15), 14, 0xd8a1e681l) - b.contents = g(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(4), 20, 0xe7d3fbc8l) - a.contents = g(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(9), 5, 0x21e1cde6l) - d.contents = g(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(14), 9, 0xc33707d6l) - c.contents = g(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(3), 14, 0xf4d50d87l) - b.contents = g(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(8), 20, 0x455a14edl) - a.contents = g(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(13), 5, 0xa9e3e905l) - d.contents = g(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(2), 9, 0xfcefa3f8l) - c.contents = g(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(7), 14, 0x676f02d9l) - b.contents = g(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(12), 20, 0x8d2a4c8al) - - a.contents = h(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(5), 4, 0xfffa3942l) - d.contents = h(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(8), 11, 0x8771f681l) - c.contents = h(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(11), 16, 0x6d9d6122l) - b.contents = h(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(14), 23, 0xfde5380cl) - a.contents = h(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(1), 4, 0xa4beea44l) - d.contents = h(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(4), 11, 0x4bdecfa9l) - c.contents = h(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(7), 16, 0xf6bb4b60l) - b.contents = h(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(10), 23, 0xbebfbc70l) - a.contents = h(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(13), 4, 0x289b7ec6l) - d.contents = h(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(0), 11, 0xeaa127fal) - c.contents = h(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(3), 16, 0xd4ef3085l) - b.contents = h(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(6), 23, 0x4881d05l) - a.contents = h(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(9), 4, 0xd9d4d039l) - d.contents = h(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(12), 11, 0xe6db99e5l) - c.contents = h(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(15), 16, 0x1fa27cf8l) - b.contents = h(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(2), 23, 0xc4ac5665l) - - a.contents = i(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(0), 6, 0xf4292244l) - d.contents = i(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(7), 10, 0x432aff97l) - c.contents = i(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(14), 15, 0xab9423a7l) - b.contents = i(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(5), 21, 0xfc93a039l) - a.contents = i(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(12), 6, 0x655b59c3l) - d.contents = i(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(3), 10, 0x8f0ccc92l) - c.contents = i(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(10), 15, 0xffeff47dl) - b.contents = i(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(1), 21, 0x85845dd1l) - a.contents = i(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(8), 6, 0x6fa87e4fl) - d.contents = i(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(15), 10, 0xfe2ce6e0l) - c.contents = i(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(6), 15, 0xa3014314l) - b.contents = i(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(13), 21, 0x4e0811a1l) - a.contents = i(a.contents, b.contents, c.contents, d.contents, k->unsafe_get(4), 6, 0xf7537e82l) - d.contents = i(d.contents, a.contents, b.contents, c.contents, k->unsafe_get(11), 10, 0xbd3af235l) - c.contents = i(c.contents, d.contents, a.contents, b.contents, k->unsafe_get(2), 15, 0x2ad7d2bbl) - b.contents = i(b.contents, c.contents, d.contents, a.contents, k->unsafe_get(9), 21, 0xeb86d391l) - - unsafe_set(x, 0, a.contents + x->unsafe_get(0)) - unsafe_set(x, 1, b.contents + x->unsafe_get(1)) - unsafe_set(x, 2, c.contents + x->unsafe_get(2)) - unsafe_set(x, 3, d.contents + x->unsafe_get(3)) -} - -let seed_a = 0x67452301l -let seed_b = 0xefcdab89l -let seed_c = 0x98badcfel -let seed_d = 0x10325476l - -let state = [seed_a, seed_b, seed_c, seed_d] - -let md5blk = [0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l, 0l] - -@send external charCodeAt: (string, int) => int = "charCodeAt" - -let md5_string = (s: string, start: int, len: int): string => { - let s = Caml_string_extern.slice(s, start, len) - let n = Caml_string_extern.length(s) - let () = { - state->unsafe_set(0, seed_a) - state->unsafe_set(1, seed_b) - state->unsafe_set(2, seed_c) - state->unsafe_set(3, seed_d) - for i in 0 to 15 { - md5blk->unsafe_set(i, 0l) - } - } - - let i_end = n / 64 - for i in 1 to i_end { - for j in 0 to 16 - 1 { - let k = i * 64 - 64 + j * 4 - md5blk->unsafe_set( - j, - charCodeAt(s, k) + - lsl(s->charCodeAt(k + 1), 8) + - lsl(s->charCodeAt(k + 2), 16) + - lsl(s->charCodeAt(k + 3), 24), - ) - } - cycle(state, md5blk) - } - - let s_tail = Caml_string_extern.slice_rest(s, i_end * 64) - for kk in 0 to 15 { - md5blk->unsafe_set(kk, 0l) - } - let i_end = Caml_string_extern.length(s_tail) - 1 - for i in 0 to i_end { - md5blk->unsafe_set( - i / 4, - lor(unsafe_get(md5blk, i / 4), lsl(charCodeAt(s_tail, i), lsl(mod(i, 4), 3))), - ) - } - let i = i_end + 1 - md5blk->unsafe_set(i / 4, lor(unsafe_get(md5blk, i / 4), lsl(0x80l, lsl(mod(i, 4), 3)))) - if i > 55 { - cycle(state, md5blk) - for i in 0 to 15 { - md5blk->unsafe_set(i, 0) - } - } - unsafe_set(md5blk, 14, n * 8) - cycle(state, md5blk) - Caml_string_extern.of_small_int32_array([ - land(state->unsafe_get(0), 0xff), - land(asr(state->unsafe_get(0), 8), 0xff), - land(asr(state->unsafe_get(0), 16), 0xff), - land(asr(state->unsafe_get(0), 24), 0xff), - land(state->unsafe_get(1), 0xff), - land(asr(state->unsafe_get(1), 8), 0xff), - land(asr(state->unsafe_get(1), 16), 0xff), - land(asr(state->unsafe_get(1), 24), 0xff), - land(state->unsafe_get(2), 0xff), - land(asr(state->unsafe_get(2), 8), 0xff), - land(asr(state->unsafe_get(2), 16), 0xff), - land(asr(state->unsafe_get(2), 24), 0xff), - land(state->unsafe_get(3), 0xff), - land(asr(state->unsafe_get(3), 8), 0xff), - land(asr(state->unsafe_get(3), 16), 0xff), - land(asr(state->unsafe_get(3), 24), 0xff), - ]) -} diff --git a/jscomp/runtime/caml_md5.resi b/jscomp/runtime/caml_md5.resi deleted file mode 100644 index c7bb429..0000000 --- a/jscomp/runtime/caml_md5.resi +++ /dev/null @@ -1,25 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let md5_string: (string, int, int) => string diff --git a/jscomp/runtime/caml_module.res b/jscomp/runtime/caml_module.res deleted file mode 100644 index a510385..0000000 --- a/jscomp/runtime/caml_module.res +++ /dev/null @@ -1,111 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** This module replaced camlinternalMod completely. - Note we can replace {!CamlinternalMod} completely, but it is not replaced - due to we believe this is an even low level dependency -*/ - -@@warning("-37") /* `Function` may be used in runtime */ - -type rec shape = - | Function - | Lazy - | Class - | Module(array<(shape, string)>) - | Value(Obj.t) -/* ATTENTION: check across versions */ -module Array = Caml_array_extern - -@set_index external set_field: (Obj.t, string, Obj.t) => unit = "" - -@get_index external get_field: (Obj.t, string) => Obj.t = "" - -module type Empty = {} - -/** Note that we have to provide a drop in replacement, since compiler internally will - spit out ("CamlinternalMod".[init_mod|update_mod] unless we intercept it - in the lambda layer -*/ -let init_mod = (loc: (string, int, int), shape: shape) => { - let undef_module = _ => raise(Undefined_recursive_module(loc)) - let rec loop = (shape: shape, struct_: Obj.t, idx) => - switch shape { - | Function => set_field(struct_, idx, Obj.magic(undef_module)) - | Lazy => set_field(struct_, idx, Obj.magic(lazy undef_module)) - | Class => - set_field( - struct_, - idx, - Obj.magic /* ref {!CamlinternalOO.dummy_class loc} */(( - undef_module, - undef_module, - undef_module, - 0, - )), - /* depends on dummy class representation */ - ) - | Module(comps) => - let v = Obj.repr(module({}: Empty)) - set_field(struct_, idx, v) - let len = Array.length(comps) - for i in 0 to len - 1 { - let (shape, name) = Caml_array_extern.unsafe_get(comps, i) - loop(shape, v, name) - } - | Value(v) => set_field(struct_, idx, v) - } - let res = Obj.repr(module({}: Empty)) - let dummy_name = "dummy" - loop(shape, res, dummy_name) - get_field(res, dummy_name) -} - -/* Note the [shape] passed between [init_mod] and [update_mod] is always the same - and we assume [module] is encoded as an array -*/ -let update_mod = (shape: shape, o: Obj.t, n: Obj.t): unit => { - let rec aux = (shape: shape, o, n, parent, i) => - switch shape { - | Function => set_field(parent, i, n) - - | Lazy - | Class => - Caml_obj.update_dummy(o, n) - | Module(comps) => - for i in 0 to Array.length(comps) - 1 { - let (shape, name) = Caml_array_extern.unsafe_get(comps, i) - aux(shape, get_field(o, name), get_field(n, name), o, name) - } - | Value(_) => () - } - switch shape { - | Module(comps) => - for i in 0 to Array.length(comps) - 1 { - let (shape, name) = Caml_array_extern.unsafe_get(comps, i) - aux(shape, get_field(o, name), get_field(n, name), o, name) - } - | _ => assert(false) - } -} diff --git a/jscomp/runtime/caml_module.resi b/jscomp/runtime/caml_module.resi deleted file mode 100644 index 9cb284e..0000000 --- a/jscomp/runtime/caml_module.resi +++ /dev/null @@ -1,5 +0,0 @@ -type shape - -let init_mod: ((string, int, int), shape) => Obj.t - -let update_mod: (shape, Obj.t, Obj.t) => unit diff --git a/jscomp/runtime/caml_nativeint_extern.res b/jscomp/runtime/caml_nativeint_extern.res deleted file mode 100644 index ca19ae8..0000000 --- a/jscomp/runtime/caml_nativeint_extern.res +++ /dev/null @@ -1,10 +0,0 @@ -external add: (int, int) => int = "?nativeint_add" -external div: (int, int) => int = "?nativeint_div" -external rem: (int, int) => int = "?nativeint_mod" -external shift_right_logical: (int, int) => int = "?nativeint_lsr" -external mul: (int, int) => int = "?nativeint_mul" - -external to_float: int => float = "%identity" -external of_float: float => int = "?int_of_float" -/* TODO: this could be promoted to `#int_of_float` */ -@val external to_string: int => string = "String" diff --git a/jscomp/runtime/caml_obj.res b/jscomp/runtime/caml_obj.res deleted file mode 100644 index cd45d64..0000000 --- a/jscomp/runtime/caml_obj.res +++ /dev/null @@ -1,456 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t = Obj.t - -module O = { - @val external isArray: 'a => bool = "Array.isArray" - type key = string - let for_in: (Obj.t, key => unit) => unit = %raw(`function(o,foo){ - for (var x in o) { foo(x) }} - `) - - @scope(("Object", "prototype", "hasOwnProperty")) - @val - /** - JS objects are not guaranteed to have `Object` in their prototype - chain so calling `some_obj.hasOwnProperty(key)` can sometimes throw - an exception when dealing with JS interop. This mainly occurs when - objects are created via `Object.create(null)`. The only safe way - to call this function is directly, e.g. `Object.prototype.hasOwnProperty.call(some_obj, key)`. - */ - external hasOwnProperty: (t, key) => bool = "call" - - @get_index external get_value: (Obj.t, key) => Obj.t = "" -} - -/** - Since now we change it back to use - Array representation - this function is higly dependent - on how objects are encoded in buckle. - - There are potentially some issues with wrong implementation of - `obj_dup`, for example, people call `Obj.dup` for a record, - and new record, since currently, `new record` will generate a - `slice` function (which assume the record is an array), and the - output is no longer an array. (it might be something like { 0 : x , 1 : y} ) - - {[ - let u : record = Obj.dup x in - let h = {u with x = 3} - ]} - - ==> - - {[ - var u = obj_dup (x) - var new_record = u.slice () - - ]} - `obj_dup` is a superset of `array_dup` -*/ -let obj_dup: Obj.t => Obj.t = %raw(`function(x){ - if(Array.isArray(x)){ - var len = x.length - var v = new Array(len) - for(var i = 0 ; i < len ; ++i){ - v[i] = x[i] - } - if(x.TAG !== undefined){ - v.TAG = x.TAG // TODO this can be removed eventually - } - return v - } - return Object.assign({},x) -}`) - -/** - For the empty dummy object, whether it's - [[]] or [{}] depends on how - runtime encoding works, and will affect - js polymorphic comparison(Js.(=)) (fine with caml polymoprhic comparison (Pervasives.equal)) - In most cases, rec value comes from record/modules, - whose tag is 0, we optimize that case -*/ -let update_dummy: (_, _) => unit = %raw(`function(x,y){ - var k - if(Array.isArray(y)){ - for(k = 0; k < y.length ; ++k){ - x[k] = y[k] - } - if(y.TAG !== undefined){ - x.TAG = y.TAG - } - } else { - for (var k in y){ - x[k] = y[k] - } - } -} -`) - -/** TODO: investigate total - [compare x y] returns [0] if [x] is equal to [y], - a negative integer if [x] is less than [y], - and a positive integer if [x] is greater than [y]. - The ordering implemented by compare is compatible with the comparison - predicates [=], [<] and [>] defined above, with one difference on the treatment of the float value - [nan]. - - Namely, the comparison predicates treat nan as different from any other float value, - including itself; while compare treats [nan] as equal to itself and less than any other float value. - This treatment of [nan] ensures that compare defines a total ordering relation. - compare applied to functional values may raise Invalid_argument. compare applied to cyclic structures - may not terminate. - - The compare function can be used as the comparison function required by the [Set.Make] and [Map.Make] functors, - as well as the [List.sort] and [Array.sort] functions. -*/ -let rec compare = (a: Obj.t, b: Obj.t): int => - if a === b { - 0 - } else { - /* front and formoest, we do not compare function values */ - let a_type = Js.typeof(a) - let b_type = Js.typeof(b) - switch (a_type, b_type) { - | ("undefined", _) => -1 - | (_, "undefined") => 1 - /* [a] is of type string, b can not be None, - [a] could be (Some (Some x)) in that case [b] could be [Some None] or [null] - so [b] has to be of type string or null */ - | ("string", "string") => Pervasives.compare((Obj.magic(a): string), Obj.magic(b)) - | ("string", _) => /* [b] could be [Some None] or [null] */ - 1 - | (_, "string") => -1 - | ("boolean", "boolean") => Pervasives.compare((Obj.magic(a): bool), Obj.magic(b)) - | ("boolean", _) => 1 - | (_, "boolean") => -1 - | ("function", "function") => raise(Invalid_argument("compare: functional value")) - | ("function", _) => 1 - | (_, "function") => -1 - | ("bigint", "bigint") - | ("number", "number") => - Pervasives.compare((Obj.magic(a): float), (Obj.magic(b): float)) - | ("number", _) => - if b === Obj.repr(Js.null) || Caml_option.isNested(b) { - 1 - } else { - /* Some (Some ..) < x */ - -1 - } /* Integer < Block in OCaml runtime GPR #1195, except Some.. */ - | (_, "number") => - if a === Obj.repr(Js.null) || Caml_option.isNested(a) { - -1 - } else { - 1 - } - | _ => - if a === Obj.repr(Js.null) { - /* [b] could not be null otherwise would equal */ - if Caml_option.isNested(b) { - 1 - } else { - -1 - } - } else if b === Obj.repr(Js.null) { - if Caml_option.isNested(a) { - -1 - } else { - 1 - } - } else if ( - /* double_array_tag: 254 - */ - Caml_option.isNested(a) - ) { - if Caml_option.isNested(b) { - aux_obj_compare(a, b) - } else { - /* Some None < Some (Some None)) */ - - /* b could not be undefined/None */ - /* Some None < Some .. */ - -1 - } - } else { - let tag_a = Obj.tag(a) - let tag_b = Obj.tag(b) - if tag_a == 248 /* object/exception */ { - Pervasives.compare((Obj.magic(Obj.field(a, 1)): int), Obj.magic(Obj.field(b, 1))) - } else if tag_a == 251 /* abstract_tag */ { - raise(Invalid_argument("equal: abstract value")) - } else if tag_a != tag_b { - if tag_a < tag_b { - -1 - } else { - 1 - } - } else { - let len_a = Obj.size(a) - let len_b = Obj.size(b) - if len_a == len_b { - if O.isArray(a) { - aux_same_length((Obj.magic(a): array), (Obj.magic(b): array), 0, len_a) - } else if %raw(`a instanceof Date && b instanceof Date`) { - %raw(`a - b`) - } else { - aux_obj_compare(a, b) - } - } else if len_a < len_b { - /* at least one is not zero, so it is an array block */ - aux_length_a_short((Obj.magic(a): array), (Obj.magic(b): array), 0, len_a) - } else { - aux_length_b_short((Obj.magic(a): array), (Obj.magic(b): array), 0, len_b) - } - } - } - } - } - -and aux_same_length = (a: array, b: array, i, same_length) => - if i == same_length { - 0 - } else { - let res = compare(Caml_array_extern.unsafe_get(a, i), Caml_array_extern.unsafe_get(b, i)) - - if res != 0 { - res - } else { - aux_same_length(a, b, i + 1, same_length) - } - } - -and aux_length_a_short = (a: array, b: array, i, short_length) => - if i == short_length { - -1 - } else { - let res = compare(Caml_array_extern.unsafe_get(a, i), Caml_array_extern.unsafe_get(b, i)) - - if res != 0 { - res - } else { - aux_length_a_short(a, b, i + 1, short_length) - } - } - -and aux_length_b_short = (a: array, b: array, i, short_length) => - if i == short_length { - 1 - } else { - let res = compare(Caml_array_extern.unsafe_get(a, i), Caml_array_extern.unsafe_get(b, i)) - - if res != 0 { - res - } else { - aux_length_b_short(a, b, i + 1, short_length) - } - } - -and aux_obj_compare = (a: Obj.t, b: Obj.t) => { - let min_key_lhs = ref(None) - let min_key_rhs = ref(None) - let do_key = ((a, b, min_key), key) => - if !O.hasOwnProperty(b, key) || compare(O.get_value(a, key), O.get_value(b, key)) > 0 { - switch min_key.contents { - | None => min_key.contents = Some(key) - | Some(mk) => - if key < mk { - min_key.contents = Some(key) - } - } - } - - let do_key_a = do_key((a, b, min_key_rhs)) - let do_key_b = do_key((b, a, min_key_lhs)) - O.for_in(a, do_key_a) - O.for_in(b, do_key_b) - let res = switch (min_key_lhs.contents, min_key_rhs.contents) { - | (None, None) => 0 - | (Some(_), None) => -1 - | (None, Some(_)) => 1 - | (Some(x), Some(y)) => Pervasives.compare(x, y) - } - - res -} - -type eq = (Obj.t, Obj.t) => bool - -/** It is easier to do equality check than comparision, since as long as its - basic type is not the same, it will not equal -*/ -let rec equal = (a: Obj.t, b: Obj.t): bool => - /* front and formoest, we do not compare function values */ - if a === b { - true - } else { - let a_type = Js.typeof(a) - if ( - a_type == "string" || - (a_type == "number" || - (a_type == "bigint" || - (a_type == "boolean" || - (a_type == "undefined" || a === %raw(`null`))))) - ) { - false - } else { - let b_type = Js.typeof(b) - if a_type == "function" || b_type == "function" { - raise(Invalid_argument("equal: functional value")) - } /* first, check using reference equality */ - else if ( - /* a_type = "object" || "symbol" */ - b_type == "number" || (b_type == "bigint" || (b_type == "undefined" || b === %raw(`null`))) - ) { - false - } else { - /* [a] [b] could not be null, so it can not raise */ - let tag_a = Obj.tag(a) - let tag_b = Obj.tag(b) - if tag_a == 248 /* object/exception */ { - Obj.magic(Obj.field(a, 1)) === Obj.magic(Obj.field(b, 1)) - } else if tag_a == 251 /* abstract_tag */ { - raise(Invalid_argument("equal: abstract value")) - } else if tag_a != tag_b { - false - } else { - let len_a = Obj.size(a) - let len_b = Obj.size(b) - if len_a == len_b { - if O.isArray(a) { - aux_equal_length((Obj.magic(a): array), (Obj.magic(b): array), 0, len_a) - } else if %raw(`a instanceof Date && b instanceof Date`) { - !(Js.unsafe_gt(a, b) || Js.unsafe_lt(a, b)) - } else { - aux_obj_equal(a, b) - } - } else { - false - } - } - } - } - } - -and aux_equal_length = (a: array, b: array, i, same_length) => - if i == same_length { - true - } else { - equal(Caml_array_extern.unsafe_get(a, i), Caml_array_extern.unsafe_get(b, i)) && - aux_equal_length(a, b, i + 1, same_length) - } - -and aux_obj_equal = (a: Obj.t, b: Obj.t) => { - let result = ref(true) - let do_key_a = key => - if !O.hasOwnProperty(b, key) { - result.contents = false - } - - let do_key_b = key => - if !O.hasOwnProperty(a, key) || !equal(O.get_value(b, key), O.get_value(a, key)) { - result.contents = false - } - - O.for_in(a, do_key_a) - if result.contents { - O.for_in(b, do_key_b) - } - result.contents -} - -let equal_null = (x: Obj.t, y: Js.null) => - switch Js.nullToOption(y) { - | None => x === Obj.magic(y) - | Some(y) => equal(x, y) - } - -let equal_undefined = (x: Obj.t, y: Js.undefined) => - switch Js.undefinedToOption(y) { - | None => x === Obj.magic(y) - | Some(y) => equal(x, y) - } - -let equal_nullable = (x: Obj.t, y: Js.nullable) => - switch Js.toOption(y) { - | None => x === Obj.magic(y) - | Some(y) => equal(x, y) - } - -@inline -let isNumberOrBigInt = a => Js.typeof(a) == "number" || Js.typeof(a) == "bigint" - -@inline -let canNumericCompare = (a, b) => isNumberOrBigInt(a) && isNumberOrBigInt(b) - -let notequal = (a, b) => - if canNumericCompare(a, b) { - (Obj.magic(a): float) != (Obj.magic(b): float) - } else { - !equal(a, b) - } - -let greaterequal = (a, b) => - if canNumericCompare(a, b) { - (Obj.magic(a): float) >= (Obj.magic(b): float) - } else { - compare(a, b) >= 0 - } - -let greaterthan = (a, b) => - if canNumericCompare(a, b) { - (Obj.magic(a): float) > (Obj.magic(b): float) - } else { - compare(a, b) > 0 - } - -let lessequal = (a, b) => - if canNumericCompare(a, b) { - (Obj.magic(a): float) <= (Obj.magic(b): float) - } else { - compare(a, b) <= 0 - } - -let lessthan = (a, b) => - if canNumericCompare(a, b) { - (Obj.magic(a): float) < (Obj.magic(b): float) - } else { - compare(a, b) < 0 - } - -let min = (x: Obj.t, y) => - if compare(x, y) <= 0 { - x - } else { - y - } - -let max = (x: Obj.t, y) => - if compare(x, y) >= 0 { - x - } else { - y - } diff --git a/jscomp/runtime/caml_obj.resi b/jscomp/runtime/caml_obj.resi deleted file mode 100644 index d239655..0000000 --- a/jscomp/runtime/caml_obj.resi +++ /dev/null @@ -1,48 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type t = Obj.t - -let obj_dup: Obj.t => Obj.t - -let update_dummy: (Obj.t, Obj.t) => unit - -let compare: (Obj.t, Obj.t) => int - -type eq = (Obj.t, Obj.t) => bool - -let equal: eq - -let equal_null: (Obj.t, Js.null) => bool -let equal_undefined: (Obj.t, Js.undefined) => bool -let equal_nullable: (Obj.t, Js.nullable) => bool - -let notequal: eq -let greaterequal: eq -let greaterthan: eq -let lessthan: eq -let lessequal: eq - -let min: (t, t) => t -let max: (t, t) => t diff --git a/jscomp/runtime/caml_option.res b/jscomp/runtime/caml_option.res deleted file mode 100644 index 3462056..0000000 --- a/jscomp/runtime/caml_option.res +++ /dev/null @@ -1,95 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type nested = {@as("BS_PRIVATE_NESTED_SOME_NONE") depth: int} - -/* INPUT: [x] should not be nullable */ -let isNested = (x: Obj.t): bool => Obj.repr((Obj.magic(x): nested).depth) !== Obj.repr(Js.undefined) - -let some = (x: Obj.t): Obj.t => - if Obj.magic(x) == None { - Obj.repr({depth: 0}) - } /* [x] is neither None nor null so it is safe to do property access */ - else if x !== Obj.repr(Js.null) && isNested(x) { - Obj.repr({depth: (Obj.magic(x): nested).depth + 1}) - } else { - x - } - -let nullable_to_opt = (type t, x: Js.nullable): option => - if Js.isNullable(x) { - None - } else { - Obj.magic(some((Obj.magic(x): 'a))) - } - -let undefined_to_opt = (type t, x: Js.undefined): option => - if Obj.magic(x) === Js.undefined { - None - } else { - Obj.magic(some((Obj.magic(x): 'a))) - } - -let null_to_opt = (type t, x: Js.null): option => - if Obj.magic(x) === Js.null { - None - } else { - Obj.magic(some((Obj.magic(x): 'a))) - } - -/* external valFromOption : 'a option -> 'a = - "#val_from_option" */ - -/** The input is already of [Some] form, [x] is not None, - make sure [x[0]] will not throw */ -let valFromOption = (x: Obj.t): Obj.t => - if x !== Obj.repr(Js.null) && isNested(x) { - let {depth}: nested = Obj.magic(x) - if depth == 0 { - Obj.magic(None) - } else { - Obj.repr({depth: depth - 1}) - } - } else { - Obj.magic(x) - } - -let option_get = (x: option<'a>) => - if x == None { - Caml_undefined_extern.empty - } else { - Obj.magic(valFromOption(Obj.repr(x))) - } - -type poly = { - @as("HASH") hash: int /* Literals.polyvar_hash */, - @as("VAL") value: Obj.t, -} - -/** [input] is optional polymorphic variant */ -let option_unwrap = (x: option) => - switch x { - | None => Obj.repr(x) - | Some(x) => x.value - } diff --git a/jscomp/runtime/caml_option.resi b/jscomp/runtime/caml_option.resi deleted file mode 100644 index 8755bf7..0000000 --- a/jscomp/runtime/caml_option.resi +++ /dev/null @@ -1,46 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type nested = {@as("BS_PRIVATE_NESTED_SOME_NONE") depth: int} - -let nullable_to_opt: Js.null_undefined<'a> => option<'a> - -let undefined_to_opt: Js.undefined<'a> => option<'a> - -let null_to_opt: Js.null<'a> => option<'a> - -let valFromOption: Obj.t => Obj.t - -let some: Obj.t => Obj.t - -let isNested: Obj.t => bool - -let option_get: option => Caml_undefined_extern.t - -type poly - -/** When it is None, return none - When it is (Some (`a 3)) return 3 -*/ -let option_unwrap: option => Obj.t diff --git a/jscomp/runtime/caml_parser.res b/jscomp/runtime/caml_parser.res deleted file mode 100644 index 82add8c..0000000 --- a/jscomp/runtime/caml_parser.res +++ /dev/null @@ -1,390 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -%%raw(` - -/***********************************************************************/ -/* */ -/* Objective Caml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1996 Institut National de Recherche en Informatique et */ -/* en Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU Library General Public License, with */ -/* the special exception on linking described in file ../LICENSE. */ -/* */ -/***********************************************************************/ - -/* $Id: parsing.c 8983 2008-08-06 09:38:25Z xleroy $ */ - -/* The PDA automaton for parsers generated by camlyacc */ - -/* The pushdown automata */ - -/** - * caml_lex_array("abcd") - * [25185, 25699] - * @param s - * @returns {any[]} - * TODO: duplicated with module {!Caml_lex} - */ -function caml_lex_array(s) { - var l = s.length / 2; - var a = new Array(l); - for (var i = 0; i < l; i++) - a[i] = (s.charCodeAt(2 * i) | (s.charCodeAt(2 * i + 1) << 8)) << 16 >> 16; - return a; -} -/** - * Note that TS enum is not friendly to Closure compiler - * @enum{number} - */ -var Automata = { - START: 0, - LOOP: 6, - TOKEN_READ: 1, - TEST_SHIFT: 7, - ERROR_DETECTED: 5, - SHIFT: 8, - SHIFT_RECOVER: 9, - STACK_GROWN_1: 2, - REDUCE: 10, - STACK_GROWN_2: 3, - SEMANTIC_ACTION_COMPUTED: 4 -}; -/** - * @enum{number} - */ -var Result = { - READ_TOKEN: 0, - RAISE_PARSE_ERROR: 1, - GROW_STACKS_1: 2, - GROW_STACKS_2: 3, - COMPUTE_SEMANTIC_ACTION: 4, - CALL_ERROR_FUNCTION: 5 -}; -var PARSER_TRACE = false; -`) - -/* - * external parse_engine : parse_tables -> parser_env -> parser_input -> Obj.t -> parser_output - * parsing.ml - * - * type parse_tables = { - * actions : (parser_env -> Obj.t) array - * transl_const : int array; - * transl_block : int array; - * lhs : string; - * len : string; - * defred : string; - * dgoto : string; - * sindex : string; - * rindex : string; - * gindex : string; - * tablesize : int; - * table : string; - * check : string; - * error_function : string -> unit; - * names_const : string; - * names_block : string - * } - * - * type parser_env = - * { mutable s_stack : int array; (* States *) - * mutable v_stack : Obj.t array; (* Semantic attributes *) - * mutable symb_start_stack : position array; (* Start positions *) - * mutable symb_end_stack : position array; (* End positions *) - * mutable stacksize : int; (* Size of the stacks *) - * mutable stackbase : int; (* Base sp for current parse *) - * mutable curr_char : int; (* Last token read *) - * mutable lval : Obj.t; (* Its semantic attribute *) - * mutable symb_start : position; (* Start pos. of the current symbol*) - * mutable symb_end : position; (* End pos. of the current symbol *) - * mutable asp : int; (* The stack pointer for attributes *) - * mutable rule_len : int; (* Number of rhs items in the rule *) - * mutable rule_number : int; (* Rule number to reduce by *) - * mutable sp : int; (* Saved sp for parse_engine *) - * mutable state : int; (* Saved state for parse_engine *) - * mutable errflag : int } (* Saved error flag for parse_engine *) - * - * type parser_input = - * | Start - * | Token_read - * | Stacks_grown_1 - * | Stacks_grown_2 - * | Semantic_action_computed - * | Error_detected - - * @param tables - * @param env - * @param cmd - * @param arg - * @returns {number} -*/ - -type parse_tables -type parser_env - -let parse_engine: ( - parse_tables, - parser_env, - /* Parsing.parser_input */ Obj.t, - Obj.t, -) => Obj.t = %raw(`function (tables /* parser_table */, env /* parser_env */, cmd /* parser_input*/, arg /* Obj.t*/) { - var ERRCODE = 256; - //var START = 0; - //var TOKEN_READ = 1; - //var STACKS_GROWN_1 = 2; - //var STACKS_GROWN_2 = 3; - //var SEMANTIC_ACTION_COMPUTED = 4; - //var ERROR_DETECTED = 5; - //var loop = 6; - //var testshift = 7; - //var shift = 8; - //var shift_recover = 9; - //var reduce = 10; - // Parsing.parser_env - var env_s_stack = 's_stack'; // array - var env_v_stack = 'v_stack'; // array - var env_symb_start_stack = 'symb_start_stack'; // array - var env_symb_end_stack = 'symb_end_stack'; // array - var env_stacksize = 'stacksize'; - var env_stackbase = 'stackbase'; - var env_curr_char = 'curr_char'; - var env_lval = 'lval'; // Obj.t - var env_symb_start = 'symb_start'; // position - var env_symb_end = 'symb_end'; // position - var env_asp = 'asp'; - var env_rule_len = 'rule_len'; - var env_rule_number = 'rule_number'; - var env_sp = 'sp'; - var env_state = 'state'; - var env_errflag = 'errflag'; - // Parsing.parse_tables - // var _tbl_actions = 1; - var tbl_transl_const = 'transl_const'; // array - var tbl_transl_block = 'transl_block'; // array - var tbl_lhs = 'lhs'; - var tbl_len = 'len'; - var tbl_defred = 'defred'; - var tbl_dgoto = 'dgoto'; - var tbl_sindex = 'sindex'; - var tbl_rindex = 'rindex'; - var tbl_gindex = 'gindex'; - var tbl_tablesize = 'tablesize'; - var tbl_table = 'table'; - var tbl_check = 'check'; - // var _tbl_error_function = 14; - // var _tbl_names_const = 15; - // var _tbl_names_block = 16; - if (!tables.preprocessed) { - tables.defred = caml_lex_array(tables[tbl_defred]); - tables.sindex = caml_lex_array(tables[tbl_sindex]); - tables.check = caml_lex_array(tables[tbl_check]); - tables.rindex = caml_lex_array(tables[tbl_rindex]); - tables.table = caml_lex_array(tables[tbl_table]); - tables.len = caml_lex_array(tables[tbl_len]); - tables.lhs = caml_lex_array(tables[tbl_lhs]); - tables.gindex = caml_lex_array(tables[tbl_gindex]); - tables.dgoto = caml_lex_array(tables[tbl_dgoto]); - tables.preprocessed = true; - } - var res; - var n, n1, n2, state1; - // RESTORE - var sp = env[env_sp]; - var state = env[env_state]; - var errflag = env[env_errflag]; - exit: for (;;) { - //console.error("State", Automata[cmd]); - switch (cmd) { - case Automata.START: - state = 0; - errflag = 0; - // Fall through - case Automata.LOOP: - n = tables.defred[state]; - if (n != 0) { - cmd = Automata.REDUCE; - break; - } - if (env[env_curr_char] >= 0) { - cmd = Automata.TEST_SHIFT; - break; - } - res = Result.READ_TOKEN; - break exit; - /* The ML code calls the lexer and updates */ - /* symb_start and symb_end */ - case Automata.TOKEN_READ: - if (typeof arg !== 'number') { - env[env_curr_char] = tables[tbl_transl_block][arg.TAG | 0 /* + 1 */]; - env[env_lval] = arg._0; // token carries payload - } - else { - env[env_curr_char] = tables[tbl_transl_const][arg /* + 1 */]; - env[env_lval] = 0; // const token - } - if (PARSER_TRACE) { - console.error("State %d, read token", state, arg); - } - // Fall through - case Automata.TEST_SHIFT: - n1 = tables.sindex[state]; - n2 = n1 + env[env_curr_char]; - if (n1 != 0 && n2 >= 0 && n2 <= tables[tbl_tablesize] && - tables.check[n2] == env[env_curr_char]) { - cmd = Automata.SHIFT; - break; - } - n1 = tables.rindex[state]; - n2 = n1 + env[env_curr_char]; - if (n1 != 0 && n2 >= 0 && n2 <= tables[tbl_tablesize] && - tables.check[n2] == env[env_curr_char]) { - n = tables.table[n2]; - cmd = Automata.REDUCE; - break; - } - if (errflag <= 0) { - res = Result.CALL_ERROR_FUNCTION; - break exit; - } - // Fall through - /* The ML code calls the error function */ - case Automata.ERROR_DETECTED: - if (errflag < 3) { - errflag = 3; - for (;;) { - state1 = env[env_s_stack][sp /* + 1*/]; - n1 = tables.sindex[state1]; - n2 = n1 + ERRCODE; - if (n1 != 0 && n2 >= 0 && n2 <= tables[tbl_tablesize] && - tables.check[n2] == ERRCODE) { - cmd = Automata.SHIFT_RECOVER; - break; - } - else { - if (sp <= env[env_stackbase]) - return Result.RAISE_PARSE_ERROR; - /* The ML code raises Parse_error */ - sp--; - } - } - } - else { - if (env[env_curr_char] == 0) - return Result.RAISE_PARSE_ERROR; - /* The ML code raises Parse_error */ - env[env_curr_char] = -1; - cmd = Automata.LOOP; - break; - } - // Fall through - case Automata.SHIFT: - env[env_curr_char] = -1; - if (errflag > 0) - errflag--; - // Fall through - case Automata.SHIFT_RECOVER: - if (PARSER_TRACE) { - console.error("State %d: shift to state %d", state, tables.table[n2]); - } - state = tables.table[n2]; - sp++; - if (sp >= env[env_stacksize]) { - res = Result.GROW_STACKS_1; - break exit; - } - // Fall through - /* The ML code resizes the stacks */ - case Automata.STACK_GROWN_1: - env[env_s_stack][sp /* + 1 */] = state; - env[env_v_stack][sp /* + 1 */] = env[env_lval]; - env[env_symb_start_stack][sp /* + 1 */] = env[env_symb_start]; - env[env_symb_end_stack][sp /* + 1 */] = env[env_symb_end]; - cmd = Automata.LOOP; - break; - case Automata.REDUCE: - if (PARSER_TRACE) { - console.error("State %d : reduce by rule %d", state, n); - } - var m = tables.len[n]; - env[env_asp] = sp; - env[env_rule_number] = n; - env[env_rule_len] = m; - sp = sp - m + 1; - m = tables.lhs[n]; - state1 = env[env_s_stack][sp - 1]; // - n1 = tables.gindex[m]; - n2 = n1 + state1; - if (n1 != 0 && n2 >= 0 && n2 <= tables[tbl_tablesize] && - tables.check[n2] == state1) - state = tables.table[n2]; - else - state = tables.dgoto[m]; - if (sp >= env[env_stacksize]) { - res = Result.GROW_STACKS_2; - break exit; - } - // Fall through - /* The ML code resizes the stacks */ - case Automata.STACK_GROWN_2: - res = Result.COMPUTE_SEMANTIC_ACTION; - break exit; - /* The ML code calls the semantic action */ - case Automata.SEMANTIC_ACTION_COMPUTED: - env[env_s_stack][sp /* + 1 */] = state; - env[env_v_stack][sp /* + 1*/] = arg; - var asp = env[env_asp]; - env[env_symb_end_stack][sp /* + 1*/] = env[env_symb_end_stack][asp /* + 1*/]; - if (sp > asp) { - /* This is an epsilon production. Take symb_start equal to symb_end. */ - env[env_symb_start_stack][sp /* + 1*/] = env[env_symb_end_stack][asp /*+ 1*/]; - } - cmd = Automata.LOOP; - break; - /* Should not happen */ - default: - return Result.RAISE_PARSE_ERROR; - } - } - // SAVE - env[env_sp] = sp; - env[env_state] = state; - env[env_errflag] = errflag; - return res; -}`) - -/** - * external set_trace: bool -> bool = "?set_parser_trace" - * parsing.ml - * @param {boolean} - * @returns {boolean} - */ -let set_parser_trace: bool => bool = %raw(`function (v) { - var old = PARSER_TRACE; - PARSER_TRACE = v; - return old; -}`) diff --git a/jscomp/runtime/caml_parser.resi b/jscomp/runtime/caml_parser.resi deleted file mode 100644 index 57d493c..0000000 --- a/jscomp/runtime/caml_parser.resi +++ /dev/null @@ -1,35 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type parse_tables -type parser_env - -let parse_engine: ( - parse_tables, - parser_env, - Obj.t /* Parsing.parser_input */, - Obj.t, -) => /* parser_output */ Obj.t - -let set_parser_trace: bool => bool diff --git a/jscomp/runtime/caml_splice_call.res b/jscomp/runtime/caml_splice_call.res deleted file mode 100644 index 7c2334c..0000000 --- a/jscomp/runtime/caml_splice_call.res +++ /dev/null @@ -1,68 +0,0 @@ -/* Copyright (C) 2019- Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type obj = Obj.t - -let spliceApply: (obj, obj) => obj = %raw(`function(fn,args){ - var i, argLen; - argLen = args.length - var applied = [] - for(i = 0; i < argLen - 1; ++i){ - applied.push(args[i]) - } - var lastOne = args[argLen - 1] - for(i = 0; i < lastOne.length; ++i ){ - applied.push(lastOne[i]) - } - return fn.apply(null,applied) -}`) - -let spliceNewApply: (obj, obj) => obj = %raw(`function (ctor,args){ - var i, argLen; - argLen = args.length - var applied = [null] // Function.prototype.bind.apply(fn, args) requires the first element in \`args\` to be \`null\` - for(i = 0; i < argLen - 1; ++i){ - applied.push(args[i]) - } - var lastOne = args[argLen - 1] - for(i = 0; i < lastOne.length; ++i ){ - applied.push(lastOne[i]) - } - var C = Function.prototype.bind.apply(ctor, applied) - return new C() -}`) - -let spliceObjApply: (obj, obj, obj) => obj = %raw(`function(obj,name,args){ - var i, argLen; - argLen = args.length - var applied = [] - for(i = 0; i < argLen - 1; ++i){ - applied.push(args[i]) - } - var lastOne = args[argLen - 1] - for(i = 0; i < lastOne.length; ++i ){ - applied.push(lastOne[i]) - } - return (obj[name]).apply(obj,applied) -}`) diff --git a/jscomp/runtime/caml_splice_call.resi b/jscomp/runtime/caml_splice_call.resi deleted file mode 100644 index 1648089..0000000 --- a/jscomp/runtime/caml_splice_call.resi +++ /dev/null @@ -1,31 +0,0 @@ -/* Copyright (C) 2019- Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -type obj = Obj.t - -let spliceApply: (obj, obj) => obj - -let spliceNewApply: (obj, obj) => obj - -let spliceObjApply: (obj, obj, obj) => obj diff --git a/jscomp/runtime/caml_string.res b/jscomp/runtime/caml_string.res deleted file mode 100644 index c70e95c..0000000 --- a/jscomp/runtime/caml_string.res +++ /dev/null @@ -1,39 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* ********************* */ -/* replaced primitives */ -/* Note that we explicitly define [unsafe_set] instead of - using {!Bytes.unsafe_set} since for some standard libraries, - it might point to ["%string_unsafe_set"] -*/ - -let get = (s, i) => - if i >= Caml_string_extern.length(s) || i < 0 { - raise(Invalid_argument("index out of bounds")) - } else { - Caml_string_extern.unsafe_get(s, i) - } - -let make = (n, ch: char): string => Caml_string_extern.of_char(ch)->Caml_string_extern.repeat(n) diff --git a/jscomp/runtime/caml_string.resi b/jscomp/runtime/caml_string.resi deleted file mode 100644 index 162eab1..0000000 --- a/jscomp/runtime/caml_string.resi +++ /dev/null @@ -1,27 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let get: (string, int) => char - -let make: (int, char) => string diff --git a/jscomp/runtime/caml_string_extern.res b/jscomp/runtime/caml_string_extern.res deleted file mode 100644 index 57942ca..0000000 --- a/jscomp/runtime/caml_string_extern.res +++ /dev/null @@ -1,54 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/*** TODO: check with {!String.of_char} - it's quite common that we have - {[ Caml_string_extern.of_char x.[0] ]} - It would be nice to generate code as below - {[ x[0] - ]} -*/ - -/* ATT: this relies on we encode `char' as int */ -@val external of_char: char => string = "String.fromCharCode" -@get_index external get_string_unsafe: (string, int) => string = "" - -@send external toUpperCase: string => string = "toUpperCase" -@send external of_int: (int, ~base: int) => string = "toString" -@send external slice: (string, int, int) => string = "slice" -@send external slice_rest: (string, int) => string = "slice" -@send external index_of: (string, string) => int = "indexOf" - -@val -external of_small_int_array: (@as(json`null`) _, array) => string = "String.fromCharCode.apply" - -@val @variadic external of_small_int32_array: array => string = "String.fromCharCode" - -@send external lastIndexOf: (string, string) => int = "lastIndexOf" /* used in {!Caml_io} */ - -external length: string => int = "%string_length" -external unsafe_get: (string, int) => char = "%string_unsafe_get" -external unsafe_set: (bytes, int, char) => unit = "%bytes_unsafe_set" - -@send external repeat: (string, int) => string = "repeat" diff --git a/jscomp/runtime/caml_sys.res b/jscomp/runtime/caml_sys.res deleted file mode 100644 index 01850a8..0000000 --- a/jscomp/runtime/caml_sys.res +++ /dev/null @@ -1,111 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@get_index external getEnv: ('a, string) => option = "" -let sys_getenv = s => - if ( - Js.typeof(%raw(`process`)) == "undefined" || %raw(`process.env`) == Caml_undefined_extern.empty - ) { - raise(Not_found) - } else { - switch getEnv(%raw(`process.env`), s) { - | None => raise(Not_found) - | Some(x) => x - } - } - -/* https://nodejs.org/dist/latest-v12.x/docs/api/os.html#os_os_platform - The value is set at compile time. Possible values are 'aix', 'darwin','freebsd', 'linux', 'openbsd', 'sunos', and 'win32'. - The return value is equivalent to process.platform. - NodeJS does not support Cygwin very well -*/ -let os_type: unit => string = %raw(`function(_){ - if(typeof process !== 'undefined' && process.platform === 'win32'){ - return "Win32" - } - else { - return "Unix" - } -}`) -/* TODO: improve [js_pass_scope] to avoid remove unused n here */ - -/* let initial_time = now () *. 0.001 */ - -type process -@send external uptime: (process, unit) => float = "uptime" -@send external exit: (process, int) => 'a = "exit" - -let sys_time = () => - if ( - Js.typeof(%raw(`process`)) == "undefined" || - %raw(`process.uptime`) == Caml_undefined_extern.empty - ) { - -1. - } else { - uptime(%raw(`process`), ()) - } - -/* -type spawnResult -external spawnSync : string -> spawnResult = "spawnSync" [@@bs.module "child_process"] - -external readAs : spawnResult -> - < - status : int Js.null; - > Js.t = - "%identity" -*/ - -let sys_getcwd: unit => string = %raw(`function(param){ - if (typeof process === "undefined" || process.cwd === undefined){ - return "/" - } - return process.cwd() - }`) - -/* Called by {!Sys} in the toplevel, should never fail */ -let sys_get_argv = (): (string, array) => - if Js.typeof(%raw(`process`)) == "undefined" { - ("", [""]) - } else { - let argv = %raw(`process.argv`) - if Js.testAny(argv) { - ("", [""]) - } else { - (Caml_array_extern.unsafe_get(argv, 0), argv) - } - } - -/** {!Pervasives.sys_exit} */ -let sys_exit: int => 'a = exit_code => - if Js.typeof(%raw(`process`)) != "undefined" { - exit(%raw(`process`), exit_code) - } - -let sys_is_directory = _s => raise(Failure("sys_is_directory not implemented")) - -/** Need polyfill to make cmdliner work - {!Sys.is_directory} or {!Sys.file_exists} {!Sys.command} -*/ -let sys_file_exists = _s => raise(Failure("sys_file_exists not implemented")) diff --git a/jscomp/runtime/caml_sys.resi b/jscomp/runtime/caml_sys.resi deleted file mode 100644 index 8ebc0c1..0000000 --- a/jscomp/runtime/caml_sys.resi +++ /dev/null @@ -1,38 +0,0 @@ -/* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -let sys_getenv: string => string - -let sys_time: unit => float - -let os_type: unit => string - -let sys_getcwd: unit => string - -let sys_get_argv: unit => (string, array) - -let sys_exit: int => unit - -let sys_is_directory: string => bool -let sys_file_exists: string => bool diff --git a/jscomp/runtime/caml_undefined_extern.res b/jscomp/runtime/caml_undefined_extern.res deleted file mode 100644 index a34355e..0000000 --- a/jscomp/runtime/caml_undefined_extern.res +++ /dev/null @@ -1,4 +0,0 @@ -type t<+'a> -external empty: t<'a> = "#undefined" -external return: 'a => t<'a> = "%identity" -external toOption: t<'a> => option<'a> = "#undefined_to_opt" diff --git a/jscomp/runtime/curry.res b/jscomp/runtime/curry.res deleted file mode 100644 index 7d2fff6..0000000 --- a/jscomp/runtime/curry.res +++ /dev/null @@ -1,358 +0,0 @@ -/* Copyright (C) 2015 - Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -/* Generated by scripts/curry_gen.ml */ -external function_length: 'a => int = "#function_length" -external apply_args: ('a => 'b, array<_>) => 'b = "#apply" - -let _ = Caml_array.sub /* make the build dependency on Caml_array explicit */ -%%private(let sub = Caml_array.sub) -/* Public */ -let rec app = (f, args) => { - let init_arity = function_length(f) - let arity = if init_arity == 0 { - 1 - } else { - init_arity - } /* arity fixing */ - let len = Caml_array_extern.length(args) - let d = arity - len - if d == 0 { - apply_args(f, args) /* f.apply (null,args) */ - } else if d < 0 { - /* TODO: could avoid copy by tracking the index */ - app(Obj.magic(apply_args(f, sub(args, 0, arity))), sub(args, arity, -d)) - } else { - Obj.magic(x => app(f, Caml_array_extern.append(args, [x]))) - } -} - -/* Internal use */ -external apply1: ('a0 => 'a1, 'a0) => 'a1 = "#apply1" -/* Internal use */ -external apply2: (('a0, 'a1) => 'a2, 'a0, 'a1) => 'a2 = "#apply2" -/* Internal use */ -external apply3: (('a0, 'a1, 'a2) => 'a3, 'a0, 'a1, 'a2) => 'a3 = "#apply3" -/* Internal use */ -external apply4: (('a0, 'a1, 'a2, 'a3) => 'a4, 'a0, 'a1, 'a2, 'a3) => 'a4 = "#apply4" -/* Internal use */ -external apply5: (('a0, 'a1, 'a2, 'a3, 'a4) => 'a5, 'a0, 'a1, 'a2, 'a3, 'a4) => 'a5 = "#apply5" -/* Internal use */ -external apply6: (('a0, 'a1, 'a2, 'a3, 'a4, 'a5) => 'a6, 'a0, 'a1, 'a2, 'a3, 'a4, 'a5) => 'a6 = - "#apply6" -/* Internal use */ -external apply7: ( - ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6) => 'a7, - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, - 'a5, - 'a6, -) => 'a7 = "#apply7" -/* Internal use */ -external apply8: ( - ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6, 'a7) => 'a8, - 'a0, - 'a1, - 'a2, - 'a3, - 'a4, - 'a5, - 'a6, - 'a7, -) => 'a8 = "#apply8" - -%%private( - let curry_1 = (o, a0, arity) => - switch arity { - | 1 => apply1(Obj.magic(o), a0) - | 2 => apply2(Obj.magic(o), a0) - | 3 => apply3(Obj.magic(o), a0) - | 4 => apply4(Obj.magic(o), a0) - | 5 => apply5(Obj.magic(o), a0) - | 6 => apply6(Obj.magic(o), a0) - | 7 => apply7(Obj.magic(o), a0) - | _ => Obj.magic(app(o, [a0])) - } -) - -/* Public */ -let _1 = (o, a0) => { - let arity = function_length(o) - if arity == 1 { - apply1(o, a0) - } else { - curry_1(o, a0, arity) - } -} - -/* Public */ -let __1 = o => { - let arity = function_length(o) - if arity == 1 { - o - } else { - a0 => _1(o, a0) - } -} - -%%private( - let curry_2 = (o, a0, a1, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1]) - | 2 => apply2(Obj.magic(o), a0, a1) - | 3 => apply3(Obj.magic(o), a0, a1) - | 4 => apply4(Obj.magic(o), a0, a1) - | 5 => apply5(Obj.magic(o), a0, a1) - | 6 => apply6(Obj.magic(o), a0, a1) - | 7 => apply7(Obj.magic(o), a0, a1) - | _ => Obj.magic(app(o, [a0, a1])) - } -) - -/* Public */ -let _2 = (o, a0, a1) => { - let arity = function_length(o) - if arity == 2 { - apply2(o, a0, a1) - } else { - curry_2(o, a0, a1, arity) - } -} - -/* Public */ -let __2 = o => { - let arity = function_length(o) - if arity == 2 { - o - } else { - (a0, a1) => _2(o, a0, a1) - } -} - -%%private( - let curry_3 = (o, a0, a1, a2, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2]) - | 3 => apply3(Obj.magic(o), a0, a1, a2) - | 4 => apply4(Obj.magic(o), a0, a1, a2) - | 5 => apply5(Obj.magic(o), a0, a1, a2) - | 6 => apply6(Obj.magic(o), a0, a1, a2) - | 7 => apply7(Obj.magic(o), a0, a1, a2) - | _ => Obj.magic(app(o, [a0, a1, a2])) - } -) - -/* Public */ -let _3 = (o, a0, a1, a2) => { - let arity = function_length(o) - if arity == 3 { - apply3(o, a0, a1, a2) - } else { - curry_3(o, a0, a1, a2, arity) - } -} - -/* Public */ -let __3 = o => { - let arity = function_length(o) - if arity == 3 { - o - } else { - (a0, a1, a2) => _3(o, a0, a1, a2) - } -} - -%%private( - let curry_4 = (o, a0, a1, a2, a3, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3]) - | 4 => apply4(Obj.magic(o), a0, a1, a2, a3) - | 5 => apply5(Obj.magic(o), a0, a1, a2, a3) - | 6 => apply6(Obj.magic(o), a0, a1, a2, a3) - | 7 => apply7(Obj.magic(o), a0, a1, a2, a3) - | _ => Obj.magic(app(o, [a0, a1, a2, a3])) - } -) - -/* Public */ -let _4 = (o, a0, a1, a2, a3) => { - let arity = function_length(o) - if arity == 4 { - apply4(o, a0, a1, a2, a3) - } else { - curry_4(o, a0, a1, a2, a3, arity) - } -} - -/* Public */ -let __4 = o => { - let arity = function_length(o) - if arity == 4 { - o - } else { - (a0, a1, a2, a3) => _4(o, a0, a1, a2, a3) - } -} - -%%private( - let curry_5 = (o, a0, a1, a2, a3, a4, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4]) - | 5 => apply5(Obj.magic(o), a0, a1, a2, a3, a4) - | 6 => apply6(Obj.magic(o), a0, a1, a2, a3, a4) - | 7 => apply7(Obj.magic(o), a0, a1, a2, a3, a4) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4])) - } -) - -/* Public */ -let _5 = (o, a0, a1, a2, a3, a4) => { - let arity = function_length(o) - if arity == 5 { - apply5(o, a0, a1, a2, a3, a4) - } else { - curry_5(o, a0, a1, a2, a3, a4, arity) - } -} - -/* Public */ -let __5 = o => { - let arity = function_length(o) - if arity == 5 { - o - } else { - (a0, a1, a2, a3, a4) => _5(o, a0, a1, a2, a3, a4) - } -} - -%%private( - let curry_6 = (o, a0, a1, a2, a3, a4, a5, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5]) - | 6 => apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5) - | 7 => apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5])) - } -) - -/* Public */ -let _6 = (o, a0, a1, a2, a3, a4, a5) => { - let arity = function_length(o) - if arity == 6 { - apply6(o, a0, a1, a2, a3, a4, a5) - } else { - curry_6(o, a0, a1, a2, a3, a4, a5, arity) - } -} - -/* Public */ -let __6 = o => { - let arity = function_length(o) - if arity == 6 { - o - } else { - (a0, a1, a2, a3, a4, a5) => _6(o, a0, a1, a2, a3, a4, a5) - } -} - -%%private( - let curry_7 = (o, a0, a1, a2, a3, a4, a5, a6, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5, a6]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5, a6]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5, a6]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5, a6]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5, a6]) - | 6 => app(apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5), [a6]) - | 7 => apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5, a6])) - } -) - -/* Public */ -let _7 = (o, a0, a1, a2, a3, a4, a5, a6) => { - let arity = function_length(o) - if arity == 7 { - apply7(o, a0, a1, a2, a3, a4, a5, a6) - } else { - curry_7(o, a0, a1, a2, a3, a4, a5, a6, arity) - } -} - -/* Public */ -let __7 = o => { - let arity = function_length(o) - if arity == 7 { - o - } else { - (a0, a1, a2, a3, a4, a5, a6) => _7(o, a0, a1, a2, a3, a4, a5, a6) - } -} - -%%private( - let curry_8 = (o, a0, a1, a2, a3, a4, a5, a6, a7, arity) => - switch arity { - | 1 => app(apply1(Obj.magic(o), a0), [a1, a2, a3, a4, a5, a6, a7]) - | 2 => app(apply2(Obj.magic(o), a0, a1), [a2, a3, a4, a5, a6, a7]) - | 3 => app(apply3(Obj.magic(o), a0, a1, a2), [a3, a4, a5, a6, a7]) - | 4 => app(apply4(Obj.magic(o), a0, a1, a2, a3), [a4, a5, a6, a7]) - | 5 => app(apply5(Obj.magic(o), a0, a1, a2, a3, a4), [a5, a6, a7]) - | 6 => app(apply6(Obj.magic(o), a0, a1, a2, a3, a4, a5), [a6, a7]) - | 7 => app(apply7(Obj.magic(o), a0, a1, a2, a3, a4, a5, a6), [a7]) - | _ => Obj.magic(app(o, [a0, a1, a2, a3, a4, a5, a6, a7])) - } -) - -/* Public */ -let _8 = (o, a0, a1, a2, a3, a4, a5, a6, a7) => { - let arity = function_length(o) - if arity == 8 { - apply8(o, a0, a1, a2, a3, a4, a5, a6, a7) - } else { - curry_8(o, a0, a1, a2, a3, a4, a5, a6, a7, arity) - } -} - -/* Public */ -let __8 = o => { - let arity = function_length(o) - if arity == 8 { - o - } else { - (a0, a1, a2, a3, a4, a5, a6, a7) => _8(o, a0, a1, a2, a3, a4, a5, a6, a7) - } -} diff --git a/jscomp/runtime/js.ml b/jscomp/runtime/js.ml deleted file mode 100644 index c018005..0000000 --- a/jscomp/runtime/js.ml +++ /dev/null @@ -1,260 +0,0 @@ -(* Copyright (C) 2015-2016 Bloomberg Finance L.P. - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) - -[@@@bs.config {flags = [|"-unboxed-types";"-w" ;"-49"|]}] -(* DESIGN: - - It does not have any code, all its code will be inlined so that - there will never be - {[ require('js')]} - - Its interface should be minimal -*) - -(** This library provides bindings and necessary support for JS FFI. - It contains all bindings into [Js] namespace. - - @example {[ - [| 1;2;3;4|] - |. Js.Array2.map (fun x -> x + 1 ) - |. Js.Array2.reduce (+) 0 - |. Js.log - ]} -*) - -(**/**) -(** Types for JS objects *) -type 'a t = < .. > as 'a - -module MapperRt = Js_mapperRt -module Internal = struct - external opaqueFullApply : 'a -> 'a = "%uncurried_apply" - - (* Use opaque instead of [._n] to prevent some optimizations happening *) - external run : (unit -> 'a [@bs]) -> 'a = "#run" - external opaque : 'a -> 'a = "%opaque" - -end -(**/**) - - -type + 'a null = - | Value of 'a - | Null [@as null] -[@@unboxed] -(** nullable, value of this type can be either [null] or ['a] - this type is the same as type [t] in {!Null} -*) - -type + 'a undefined -(** value of this type can be either [undefined] or ['a] - this type is the same as type [t] in {!Undefined} *) - -type + 'a nullable = - | Value of 'a - | Null [@as null] - | Undefined [@as undefined] -[@@unboxed] -(** value of this type can be [undefined], [null] or ['a] - this type is the same as type [t] n {!Null_undefined} *) - -type + 'a null_undefined = 'a nullable - -external toOption : 'a nullable -> 'a option = "#nullable_to_opt" -external undefinedToOption : 'a undefined -> 'a option = "#undefined_to_opt" -external nullToOption : 'a null -> 'a option = "#null_to_opt" - -external isNullable : 'a nullable -> bool = "#is_nullable" - -external import : 'a -> 'a promise = "#import" - -(** The same as {!test} except that it is more permissive on the types of input *) -external testAny : 'a -> bool = "#is_nullable" - - -type (+'a, +'e) promise -(** The promise type, defined here for interoperation across packages - @deprecated please use {!Js.Promise} -*) - -external null : 'a null = "#null" -(** The same as [empty] in {!Js.Null} will be compiled as [null]*) - -external undefined : 'a undefined = "#undefined" -(** The same as [empty] {!Js.Undefined} will be compiled as [undefined]*) - - - -external typeof : 'a -> string = "#typeof" -(** [typeof x] will be compiled as [typeof x] in JS - Please consider functions in {!Types} for a type safe way of reflection -*) - -external log : 'a -> unit = "log" -[@@val] [@@scope "console"] -(** A convenience function to log everything *) - -external log2 : 'a -> 'b -> unit = "log" -[@@bs.val] [@@bs.scope "console"] -external log3 : 'a -> 'b -> 'c -> unit = "log" -[@@bs.val] [@@bs.scope "console"] -external log4 : 'a -> 'b -> 'c -> 'd -> unit = "log" -[@@bs.val] [@@bs.scope "console"] - -external logMany : 'a array -> unit = "log" -[@@bs.val] [@@bs.scope "console"] [@@bs.splice] -(** A convenience function to log more than 4 arguments *) - -external eqNull : 'a -> 'a null -> bool = "%bs_equal_null" -external eqUndefined : 'a -> 'a undefined -> bool = "%bs_equal_undefined" -external eqNullable : 'a -> 'a nullable -> bool = "%bs_equal_nullable" - -(** {4 operators }*) - -external unsafe_lt : 'a -> 'a -> bool = "#unsafe_lt" -(** [unsafe_lt a b] will be compiled as [a < b]. - It is marked as unsafe, since it is impossible - to give a proper semantics for comparision which applies to any type -*) - - -external unsafe_le : 'a -> 'a -> bool = "#unsafe_le" -(** [unsafe_le a b] will be compiled as [a <= b]. - See also {!unsafe_lt} -*) - - -external unsafe_gt : 'a -> 'a -> bool = "#unsafe_gt" -(** [unsafe_gt a b] will be compiled as [a > b]. - See also {!unsafe_lt} -*) - -external unsafe_ge : 'a -> 'a -> bool = "#unsafe_ge" -(** [unsafe_ge a b] will be compiled as [a >= b]. - See also {!unsafe_lt} -*) - - -(** {12 nested modules}*) - -module Null = Js_null -(** Provide utilities around ['a null] *) - -module Undefined = Js_undefined -(** Provide utilities around {!undefined} *) - -module Nullable = Js_null_undefined -(** Provide utilities around {!null_undefined} *) - -module Null_undefined = Js_null_undefined -(** @deprecated please use {!Js.Nullable} *) - -module Exn = Js_exn -(** Provide utilities for dealing with Js exceptions *) - -module Array = Js_array -(** Provide bindings to Js array*) - -module Array2 = Js_array2 -(** Provide bindings to Js array*) - -module String = Js_string -(** Provide bindings to JS string *) - -module String2 = Js_string2 -(** Provide bindings to JS string *) - -module Re = Js_re -(** Provide bindings to Js regex expression *) - -module Promise = Js_promise -(** Provide bindings to JS promise *) - -module Promise2 = Js_promise2 -(** Provide bindings to JS promise *) - -module Date = Js_date -(** Provide bindings for JS Date *) - -module Dict = Js_dict -(** Provide utilities for JS dictionary object *) - -module Global = Js_global -(** Provide bindings to JS global functions in global namespace*) - -module Json = Js_json -(** Provide utilities for json *) - -module Math = Js_math -(** Provide bindings for JS [Math] object *) - -module Obj = Js_obj -(** Provide utilities for {!Js.t} *) - -module Typed_array = Js_typed_array -(** Provide bindings for JS typed array *) - -module TypedArray2 = Js_typed_array2 -(** Provide bindings for JS typed array *) - -module Types = Js_types -(** Provide utilities for manipulating JS types *) - -module Float = Js_float -(** Provide utilities for JS float *) - -module Int = Js_int -(** Provide utilities for int *) - -module BigInt = Js_bigint -(** Provide utilities for bigint *) - -module File = Js_file -(** Provide utilities for File *) - -module Blob = Js_blob -(** Provide utilities for Blob *) - -module Option = Js_option -(** Provide utilities for option *) - -module Result = Js_result -(** Define the interface for result *) - -module List = Js_list -(** Provide utilities for list *) - -module Vector = Js_vector - -module Console = Js_console - -module Set = Js_set -(** Provides bindings for ES6 Set *) - -module WeakSet = Js_weakset -(** Provides bindings for ES6 WeakSet *) - -module Map = Js_map -(** Provides bindings for ES6 Map *) - -module WeakMap = Js_weakmap -(** Provides bindings for ES6 WeakMap *) diff --git a/jscomp/runtime/release.ninja b/jscomp/runtime/release.ninja deleted file mode 100644 index d21ca55..0000000 --- a/jscomp/runtime/release.ninja +++ /dev/null @@ -1,66 +0,0 @@ - -bsc_no_open_flags = -no-keep-locs -no-alias-deps -bs-no-version-header -bs-no-check-div-by-zero -nostdlib -bs-cross-module-opt -make-runtime -nopervasives -unsafe -w +50 -warn-error A -bsc_flags = $bsc_no_open_flags -open Bs_stdlib_mini - -rule cc - command = $bsc -bs-cmi -bs-cmj $bsc_flags -I runtime $in - description = $in -> $out -rule cc_cmi - command = $bsc -bs-read-cmi -bs-cmi -bs-cmj $bsc_flags -I runtime $in - description = $in -> $out - -o runtime/bs_stdlib_mini.cmi : cc runtime/bs_stdlib_mini.resi - bsc_flags = -nostdlib -nopervasives -o runtime/js.cmj runtime/js.cmi : cc runtime/js.ml - bsc_flags = $bsc_no_open_flags -o runtime/caml.cmj : cc_cmi runtime/caml.res | runtime/caml.cmi runtime/caml_int64_extern.cmj -o runtime/caml.cmi : cc runtime/caml.resi | runtime/bs_stdlib_mini.cmi runtime/caml_int64_extern.cmj runtime/js.cmi runtime/js.cmj -o runtime/caml_array.cmj : cc_cmi runtime/caml_array.res | runtime/caml_array.cmi runtime/caml_array_extern.cmj -o runtime/caml_array.cmi : cc runtime/caml_array.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_bigint.cmj : cc_cmi runtime/caml_bigint.res | runtime/caml_bigint.cmi runtime/caml_bigint_extern.cmj -o runtime/caml_bigint.cmi : cc runtime/caml_bigint.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_bytes.cmj : cc_cmi runtime/caml_bytes.res | runtime/caml_bytes.cmi -o runtime/caml_bytes.cmi : cc runtime/caml_bytes.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_exceptions.cmj : cc_cmi runtime/caml_exceptions.res | runtime/caml_exceptions.cmi runtime/js.cmj -o runtime/caml_exceptions.cmi : cc runtime/caml_exceptions.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_float.cmj : cc_cmi runtime/caml_float.res | runtime/caml_float.cmi runtime/caml_float_extern.cmj -o runtime/caml_float.cmi : cc runtime/caml_float.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_format.cmj : cc_cmi runtime/caml_format.ml | runtime/caml.cmj runtime/caml_float.cmj runtime/caml_float_extern.cmj runtime/caml_format.cmi runtime/caml_int64.cmj runtime/caml_int64_extern.cmj runtime/caml_nativeint_extern.cmj runtime/caml_string_extern.cmj -o runtime/caml_format.cmi : cc runtime/caml_format.mli | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_hash.cmj : cc_cmi runtime/caml_hash.res | runtime/caml_hash.cmi runtime/caml_hash_primitive.cmj runtime/caml_nativeint_extern.cmj runtime/js.cmj -o runtime/caml_hash.cmi : cc runtime/caml_hash.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_hash_primitive.cmj : cc_cmi runtime/caml_hash_primitive.res | runtime/caml_hash_primitive.cmi runtime/caml_string_extern.cmj -o runtime/caml_hash_primitive.cmi : cc runtime/caml_hash_primitive.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_int32.cmj : cc_cmi runtime/caml_int32.res | runtime/caml_int32.cmi runtime/caml_nativeint_extern.cmj -o runtime/caml_int32.cmi : cc runtime/caml_int32.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_int64.cmj : cc_cmi runtime/caml_int64.res | runtime/caml.cmj runtime/caml_float.cmj runtime/caml_float_extern.cmj runtime/caml_int64.cmi runtime/caml_int64_extern.cmj runtime/caml_nativeint_extern.cmj runtime/caml_string_extern.cmj runtime/js.cmj -o runtime/caml_int64.cmi : cc runtime/caml_int64.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_lexer.cmj : cc_cmi runtime/caml_lexer.res | runtime/caml_lexer.cmi -o runtime/caml_lexer.cmi : cc runtime/caml_lexer.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_md5.cmj : cc_cmi runtime/caml_md5.res | runtime/caml_array_extern.cmj runtime/caml_md5.cmi runtime/caml_string_extern.cmj -o runtime/caml_md5.cmi : cc runtime/caml_md5.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_module.cmj : cc_cmi runtime/caml_module.res | runtime/caml_array_extern.cmj runtime/caml_module.cmi runtime/caml_obj.cmj -o runtime/caml_module.cmi : cc runtime/caml_module.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_obj.cmj : cc_cmi runtime/caml_obj.res | runtime/caml.cmj runtime/caml_array_extern.cmj runtime/caml_obj.cmi runtime/caml_option.cmj runtime/js.cmj -o runtime/caml_obj.cmi : cc runtime/caml_obj.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_option.cmj : cc_cmi runtime/caml_option.res | runtime/caml_option.cmi runtime/caml_undefined_extern.cmj runtime/js.cmj -o runtime/caml_option.cmi : cc runtime/caml_option.resi | runtime/bs_stdlib_mini.cmi runtime/caml_undefined_extern.cmj runtime/js.cmi runtime/js.cmj -o runtime/caml_parser.cmj : cc_cmi runtime/caml_parser.res | runtime/caml_parser.cmi -o runtime/caml_parser.cmi : cc runtime/caml_parser.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_splice_call.cmj : cc_cmi runtime/caml_splice_call.res | runtime/caml_splice_call.cmi -o runtime/caml_splice_call.cmi : cc runtime/caml_splice_call.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_string.cmj : cc_cmi runtime/caml_string.res | runtime/caml_string.cmi runtime/caml_string_extern.cmj -o runtime/caml_string.cmi : cc runtime/caml_string.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_sys.cmj : cc_cmi runtime/caml_sys.res | runtime/caml_array_extern.cmj runtime/caml_sys.cmi runtime/caml_undefined_extern.cmj runtime/js.cmj -o runtime/caml_sys.cmi : cc runtime/caml_sys.resi | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_array_extern.cmi runtime/caml_array_extern.cmj : cc runtime/caml_array_extern.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_bigint_extern.cmi runtime/caml_bigint_extern.cmj : cc runtime/caml_bigint_extern.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_external_polyfill.cmi runtime/caml_external_polyfill.cmj : cc runtime/caml_external_polyfill.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_float_extern.cmi runtime/caml_float_extern.cmj : cc runtime/caml_float_extern.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_int64_extern.cmi runtime/caml_int64_extern.cmj : cc runtime/caml_int64_extern.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_js_exceptions.cmi runtime/caml_js_exceptions.cmj : cc runtime/caml_js_exceptions.res | runtime/bs_stdlib_mini.cmi runtime/caml_exceptions.cmj runtime/caml_option.cmj runtime/js.cmi runtime/js.cmj -o runtime/caml_nativeint_extern.cmi runtime/caml_nativeint_extern.cmj : cc runtime/caml_nativeint_extern.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_string_extern.cmi runtime/caml_string_extern.cmj : cc runtime/caml_string_extern.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/caml_undefined_extern.cmi runtime/caml_undefined_extern.cmj : cc runtime/caml_undefined_extern.res | runtime/bs_stdlib_mini.cmi runtime/js.cmi runtime/js.cmj -o runtime/curry.cmi runtime/curry.cmj : cc runtime/curry.res | runtime/bs_stdlib_mini.cmi runtime/caml_array.cmj runtime/caml_array_extern.cmj runtime/js.cmi runtime/js.cmj -o runtime : phony runtime/bs_stdlib_mini.cmi runtime/js.cmj runtime/js.cmi runtime/caml.cmi runtime/caml.cmj runtime/caml_array.cmi runtime/caml_array.cmj runtime/caml_bigint.cmi runtime/caml_bigint.cmj runtime/caml_bytes.cmi runtime/caml_bytes.cmj runtime/caml_exceptions.cmi runtime/caml_exceptions.cmj runtime/caml_float.cmi runtime/caml_float.cmj runtime/caml_format.cmi runtime/caml_format.cmj runtime/caml_hash.cmi runtime/caml_hash.cmj runtime/caml_hash_primitive.cmi runtime/caml_hash_primitive.cmj runtime/caml_int32.cmi runtime/caml_int32.cmj runtime/caml_int64.cmi runtime/caml_int64.cmj runtime/caml_lexer.cmi runtime/caml_lexer.cmj runtime/caml_md5.cmi runtime/caml_md5.cmj runtime/caml_module.cmi runtime/caml_module.cmj runtime/caml_obj.cmi runtime/caml_obj.cmj runtime/caml_option.cmi runtime/caml_option.cmj runtime/caml_parser.cmi runtime/caml_parser.cmj runtime/caml_splice_call.cmi runtime/caml_splice_call.cmj runtime/caml_string.cmi runtime/caml_string.cmj runtime/caml_sys.cmi runtime/caml_sys.cmj runtime/caml_array_extern.cmi runtime/caml_array_extern.cmj runtime/caml_bigint_extern.cmi runtime/caml_bigint_extern.cmj runtime/caml_external_polyfill.cmi runtime/caml_external_polyfill.cmj runtime/caml_float_extern.cmi runtime/caml_float_extern.cmj runtime/caml_int64_extern.cmi runtime/caml_int64_extern.cmj runtime/caml_js_exceptions.cmi runtime/caml_js_exceptions.cmj runtime/caml_nativeint_extern.cmi runtime/caml_nativeint_extern.cmj runtime/caml_string_extern.cmi runtime/caml_string_extern.cmj runtime/caml_undefined_extern.cmi runtime/caml_undefined_extern.cmj runtime/curry.cmi runtime/curry.cmj diff --git a/jscomp/stdlib-406/arg.res b/jscomp/stdlib-406/arg.res deleted file mode 100644 index 7dadf08..0000000 --- a/jscomp/stdlib-406/arg.res +++ /dev/null @@ -1,427 +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 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.resi b/jscomp/stdlib-406/arg.resi deleted file mode 100644 index e5b6916..0000000 --- a/jscomp/stdlib-406/arg.resi +++ /dev/null @@ -1,186 +0,0 @@ -/*** Parsing of command line arguments. - - This module provides a general mechanism for extracting options and - arguments from the command line to the program. - - Syntax of command lines: - A keyword is a character string starting with a [-]. - An option is a keyword alone or followed by an argument. - The types of keywords are: [Unit], [Bool], [Set], [Clear], - [String], [Set_string], [Int], [Set_int], [Float], [Set_float], - [Tuple], [Symbol], and [Rest]. - [Unit], [Set] and [Clear] keywords take no argument. A [Rest] - keyword takes the remaining of the command line as arguments. - Every other keyword takes the following word on the command line - as argument. For compatibility with GNU getopt_long, [keyword=arg] - is also allowed. - Arguments not preceded by a keyword are called anonymous arguments. - - 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 -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 d ](two anonymous arguments and a rest option with - two arguments) -*/ - -/** 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 - registered as [Expand f], then the - arguments [f "arg" @ rest] are - processed. Only allowed in - [parse_and_expand_argv_dynamic]. */ - Expand(string => array) - -type key = string -type doc = string -type usage_msg = string -type anon_fun = string => unit - -/** [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 - is found on the command line. - [doc] is a one-line description of this option. - [anon_fun] is called on anonymous arguments. - The functions in [spec] and [anon_fun] are called in the same order - as their arguments appear on the command line. - - If an error occurs, [Arg.parse] exits the program, after printing - to standard error an error message as follows: -- The reason for the error: unknown option, invalid or missing argument, etc. -- [usage_msg] -- The list of options, each followed by the corresponding [doc] string. - Beware: options that have an empty [doc] string will not be included in the - list. - - For the user to be able to specify anonymous arguments starting with a - [-], 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 - -/** 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 - -/** [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] - is the index of the program name (argument 0) in the array. - If an error occurs, [Arg.parse_argv] raises {!Arg.Bad} with - the error message as argument. If option [-help] or [--help] is - given, [Arg.parse_argv] raises {!Arg.Help} with the help message - as argument. -*/ -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 -*/ -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 -*/ -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 - -/** Raised by [Arg.parse_argv] when the user asks for help. */ exception Help(string) - -/** 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. */ -exception Bad(string) - -/** [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}. */ -let usage: (list<(key, spec, doc)>, usage_msg) => unit - -/** 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 - -/** 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. */ -let align: (~limit: int=?, list<(key, spec, doc)>) => list<(key, spec, doc)> - -/** 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. */ -let current: ref diff --git a/jscomp/stdlib-406/array.res b/jscomp/stdlib-406/array.res deleted file mode 100644 index 486217b..0000000 --- a/jscomp/stdlib-406/array.res +++ /dev/null @@ -1,410 +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. */ -/* */ -/* ************************************************************************ */ - -/* Array operations */ - -external length: array<'a> => int = "%array_length" -external get: (array<'a>, int) => 'a = "%array_safe_get" -external set: (array<'a>, int, 'a) => unit = "%array_safe_set" -external unsafe_get: (array<'a>, int) => 'a = "%array_unsafe_get" -external unsafe_set: (array<'a>, int, 'a) => unit = "%array_unsafe_set" -external make: (int, 'a) => array<'a> = "?make_vect" -external create: (int, 'a) => array<'a> = "?make_vect" -external unsafe_sub: (array<'a>, int, int) => array<'a> = "?array_sub" - -@send external append_prim: (array<'a>, array<'a>) => array<'a> = "concat" - -external concat: list> => array<'a> = "?array_concat" -external unsafe_blit: (array<'a>, int, array<'a>, int, int) => unit = "?array_blit" -external create_float: int => array = "?make_float_vect" -let make_float = create_float - -module Floatarray = { - external create: int => floatarray = "?floatarray_create" - external length: floatarray => int = "%floatarray_length" - external get: (floatarray, int) => float = "%floatarray_safe_get" - external set: (floatarray, int, float) => unit = "%floatarray_safe_set" - external unsafe_get: (floatarray, int) => float = "%floatarray_unsafe_get" - external unsafe_set: (floatarray, int, float) => unit = "%floatarray_unsafe_set" -} - -let init = (l, f) => - if l == 0 { - [] - } else if l < 0 { - invalid_arg("Array.init") - } else { - /* See #6575. We could also check for maximum array size, but this depends - on whether we create a float array or a regular one... */ - - let res = create(l, f(0)) - for i in 1 to pred(l) { - unsafe_set(res, i, f(i)) - } - res - } - -let make_matrix = (sx, sy, init) => { - let res = create(sx, []) - for x in 0 to pred(sx) { - unsafe_set(res, x, create(sy, init)) - } - res -} - -let create_matrix = make_matrix - -let copy = a => { - let l = length(a) - if l == 0 { - [] - } else { - unsafe_sub(a, 0, l) - } -} - -let append = (a1, a2) => { - let l1 = length(a1) - if l1 == 0 { - copy(a2) - } else if length(a2) == 0 { - unsafe_sub(a1, 0, l1) - } else { - append_prim(a1, a2) - } -} - -let sub = (a, ofs, len) => - if ofs < 0 || (len < 0 || ofs > length(a) - len) { - invalid_arg("Array.sub") - } else { - unsafe_sub(a, ofs, len) - } - -let fill = (a, ofs, len, v) => - if ofs < 0 || (len < 0 || ofs > length(a) - len) { - invalid_arg("Array.fill") - } else { - for i in ofs to ofs + len - 1 { - unsafe_set(a, i, v) - } - } - -let blit = (a1, ofs1, a2, ofs2, len) => - if len < 0 || (ofs1 < 0 || (ofs1 > length(a1) - len || (ofs2 < 0 || ofs2 > length(a2) - len))) { - invalid_arg("Array.blit") - } else { - unsafe_blit(a1, ofs1, a2, ofs2, len) - } - -let iter = (f, a) => - for i in 0 to length(a) - 1 { - f(unsafe_get(a, i)) - } - -let iter2 = (f, a, b) => - if length(a) != length(b) { - invalid_arg("Array.iter2: arrays must have the same length") - } else { - for i in 0 to length(a) - 1 { - f(unsafe_get(a, i), unsafe_get(b, i)) - } - } - -let map = (f, a) => { - let l = length(a) - if l == 0 { - [] - } else { - let r = create(l, f(unsafe_get(a, 0))) - for i in 1 to l - 1 { - unsafe_set(r, i, f(unsafe_get(a, i))) - } - r - } -} - -let map2 = (f, a, b) => { - let la = length(a) - let lb = length(b) - if la != lb { - invalid_arg("Array.map2: arrays must have the same length") - } else if la == 0 { - [] - } else { - let r = create(la, f(unsafe_get(a, 0), unsafe_get(b, 0))) - for i in 1 to la - 1 { - unsafe_set(r, i, f(unsafe_get(a, i), unsafe_get(b, i))) - } - r - } -} - -let iteri = (f, a) => - for i in 0 to length(a) - 1 { - f(i, unsafe_get(a, i)) - } - -let mapi = (f, a) => { - let l = length(a) - if l == 0 { - [] - } else { - let r = create(l, f(0, unsafe_get(a, 0))) - for i in 1 to l - 1 { - unsafe_set(r, i, f(i, unsafe_get(a, i))) - } - r - } -} - -let to_list = a => { - let rec tolist = (i, res) => - if i < 0 { - res - } else { - tolist(i - 1, list{unsafe_get(a, i), ...res}) - } - tolist(length(a) - 1, list{}) -} - -/* Cannot use List.length here because the List module depends on Array. */ -let rec list_length = (accu, param) => - switch param { - | list{} => accu - | list{_, ...t} => list_length(succ(accu), t) - } - -let of_list = param => - switch param { - | list{} => [] - | list{hd, ...tl} as l => - let a = create(list_length(0, l), hd) - let rec fill = (i, param) => - switch param { - | list{} => a - | list{hd, ...tl} => - unsafe_set(a, i, hd) - fill(i + 1, tl) - } - fill(1, tl) - } - -let fold_left = (f, x, a) => { - let r = ref(x) - for i in 0 to length(a) - 1 { - r := f(r.contents, unsafe_get(a, i)) - } - r.contents -} - -let fold_right = (f, a, x) => { - let r = ref(x) - for i in length(a) - 1 downto 0 { - r := f(unsafe_get(a, i), r.contents) - } - r.contents -} - -let exists = (p, a) => { - let n = length(a) - let rec loop = i => - if i == n { - false - } else if p(unsafe_get(a, i)) { - true - } else { - loop(succ(i)) - } - loop(0) -} - -let for_all = (p, a) => { - let n = length(a) - let rec loop = i => - if i == n { - true - } else if p(unsafe_get(a, i)) { - loop(succ(i)) - } else { - false - } - loop(0) -} - -let mem = (x, a) => { - let n = length(a) - let rec loop = i => - if i == n { - false - } else if compare(unsafe_get(a, i), x) == 0 { - true - } else { - loop(succ(i)) - } - loop(0) -} - -let memq = (x, a) => { - let n = length(a) - let rec loop = i => - if i == n { - false - } else if x === unsafe_get(a, i) { - true - } else { - loop(succ(i)) - } - loop(0) -} - -exception Bottom(int) -let sort = (cmp, a) => { - let maxson = (l, i) => { - let i31 = i + i + i + 1 - let x = ref(i31) - if i31 + 2 < l { - if cmp(get(a, i31), get(a, i31 + 1)) < 0 { - x := i31 + 1 - } - if cmp(get(a, x.contents), get(a, i31 + 2)) < 0 { - x := i31 + 2 - } - x.contents - } else if i31 + 1 < l && cmp(get(a, i31), get(a, i31 + 1)) < 0 { - i31 + 1 - } else if i31 < l { - i31 - } else { - raise(Bottom(i)) - } - } - - let rec trickledown = (l, i, e) => { - let j = maxson(l, i) - if cmp(get(a, j), e) > 0 { - set(a, i, get(a, j)) - trickledown(l, j, e) - } else { - set(a, i, e) - } - } - - let trickle = (l, i, e) => - try trickledown(l, i, e) catch { - | Bottom(i) => set(a, i, e) - } - let rec bubbledown = (l, i) => { - let j = maxson(l, i) - set(a, i, get(a, j)) - bubbledown(l, j) - } - - let bubble = (l, i) => - try bubbledown(l, i) catch { - | Bottom(i) => i - } - let rec trickleup = (i, e) => { - let father = (i - 1) / 3 - assert(i != father) - if cmp(get(a, father), e) < 0 { - set(a, i, get(a, father)) - if father > 0 { - trickleup(father, e) - } else { - set(a, 0, e) - } - } else { - set(a, i, e) - } - } - - let l = length(a) - for i in (l + 1) / 3 - 1 downto 0 { - trickle(l, i, get(a, i)) - } - for i in l - 1 downto 2 { - let e = get(a, i) - set(a, i, get(a, 0)) - trickleup(bubble(i, 0), e) - } - if l > 1 { - let e = get(a, 1) - set(a, 1, get(a, 0)) - set(a, 0, e) - } -} - -let cutoff = 5 -let stable_sort = (cmp, a) => { - let merge = (src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len and src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - if cmp(s1, s2) <= 0 { - set(dst, d, s1) - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, get(a, i1), i2, s2, d + 1) - } else { - blit(src2, i2, dst, d + 1, src2r - i2) - } - } else { - set(dst, d, s2) - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, get(src2, i2), d + 1) - } else { - blit(a, i1, dst, d + 1, src1r - i1) - } - } - loop(src1ofs, get(a, src1ofs), src2ofs, get(src2, src2ofs), dstofs) - } - - let isortto = (srcofs, dst, dstofs, len) => - for i in 0 to len - 1 { - let e = get(a, srcofs + i) - let j = ref(dstofs + i - 1) - while j.contents >= dstofs && cmp(get(dst, j.contents), e) > 0 { - set(dst, j.contents + 1, get(dst, j.contents)) - decr(j) - } - set(dst, j.contents + 1, e) - } - - let rec sortto = (srcofs, dst, dstofs, len) => - if len <= cutoff { - isortto(srcofs, dst, dstofs, len) - } else { - let l1 = len / 2 - let l2 = len - l1 - sortto(srcofs + l1, dst, dstofs + l1, l2) - sortto(srcofs, a, srcofs + l2, l1) - merge(srcofs + l2, l1, dst, dstofs + l1, l2, dst, dstofs) - } - - let l = length(a) - if l <= cutoff { - isortto(0, a, 0, l) - } else { - let l1 = l / 2 - let l2 = l - l1 - let t = make(l2, get(a, 0)) - sortto(l1, t, 0, l2) - sortto(0, a, l2, l1) - merge(l2, l1, t, 0, l2, a, 0) - } -} - -let fast_sort = stable_sort diff --git a/jscomp/stdlib-406/array.resi b/jscomp/stdlib-406/array.resi deleted file mode 100644 index d16f7bb..0000000 --- a/jscomp/stdlib-406/array.resi +++ /dev/null @@ -1,264 +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. */ -/* */ -/* ************************************************************************ */ - -/* Array operations. */ - -/** Return the length (number of elements) of the given array. */ -external length: array<'a> => int = "%array_length" - -/** [Array.get a n] returns the element number [n] of array [a]. - The first element has number 0. - The last element has number [Array.length a - 1]. - You can also write [a.(n)] instead of [Array.get a n]. - - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(Array.length a - 1)]. */ -external get: (array<'a>, int) => 'a = "%array_safe_get" - -/** [Array.set a n x] modifies array [a] in place, replacing - element number [n] with [x]. - You can also write [a.(n) <- x] instead of [Array.set a n x]. - - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [Array.length a - 1]. */ -external set: (array<'a>, int, 'a) => unit = "%array_safe_set" - -/** [Array.make n x] returns a fresh array of length [n], - initialized with [x]. - All the elements of this new array are initially - physically equal to [x] (in the sense of the [==] predicate). - Consequently, if [x] is mutable, it is shared among all elements - of the array, and modifying [x] through one of the array entries - will modify all other entries at the same time. - - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. - If the value of [x] is a floating-point number, then the maximum - size is only [Sys.max_array_length / 2].*/ -external make: (int, 'a) => array<'a> = "?make_vect" - -@deprecated("Use Array.make instead.") -/** @deprecated [Array.create] is an alias for {!Array.make}. */ -external create: (int, 'a) => array<'a> = "?make_vect" - -/** [Array.create_float n] returns a fresh float array of length [n], - with uninitialized data. - @since 4.03 */ -external create_float: int => array = "?make_float_vect" - -@deprecated("Use Array.create_float instead.") -/** @deprecated [Array.make_float] is an alias for {!Array.create_float}. */ -let make_float: int => array - -/** [Array.init n f] returns a fresh array of length [n], - with element number [i] initialized to the result of [f i]. - In other terms, [Array.init n f] tabulates the results of [f] - applied to the integers [0] to [n-1]. - - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. - If the return type of [f] is [float], then the maximum - size is only [Sys.max_array_length / 2].*/ -let init: (int, int => 'a) => array<'a> - -/** [Array.make_matrix dimx dimy e] returns a two-dimensional array - (an array of arrays) with first dimension [dimx] and - second dimension [dimy]. All the elements of this new matrix - are initially physically equal to [e]. - The element ([x,y]) of a matrix [m] is accessed - with the notation [m.(x).(y)]. - - Raise [Invalid_argument] if [dimx] or [dimy] is negative or - greater than {!Sys.max_array_length}. - If the value of [e] is a floating-point number, then the maximum - size is only [Sys.max_array_length / 2]. */ -let make_matrix: (int, int, 'a) => array> - -@deprecated("Use Array.make_matrix instead.") -/** @deprecated [Array.create_matrix] is an alias for {!Array.make_matrix}. */ -let create_matrix: (int, int, 'a) => array> - -/** [Array.append v1 v2] returns a fresh array containing the - concatenation of the arrays [v1] and [v2]. */ -let append: (array<'a>, array<'a>) => array<'a> - -/** Same as {!Array.append}, but concatenates a list of arrays. */ -let concat: list> => array<'a> - -/** [Array.sub a start len] returns a fresh array of length [len], - containing the elements number [start] to [start + len - 1] - of array [a]. - - Raise [Invalid_argument "Array.sub"] if [start] and [len] do not - designate a valid subarray of [a]; that is, if - [start < 0], or [len < 0], or [start + len > Array.length a]. */ -let sub: (array<'a>, int, int) => array<'a> - -/** [Array.copy a] returns a copy of [a], that is, a fresh array - containing the same elements as [a]. */ -let copy: array<'a> => array<'a> - -/** [Array.fill a ofs len x] modifies the array [a] in place, - storing [x] in elements number [ofs] to [ofs + len - 1]. - - Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not - designate a valid subarray of [a]. */ -let fill: (array<'a>, int, int, 'a) => unit - -/** [Array.blit v1 o1 v2 o2 len] copies [len] elements - from array [v1], starting at element number [o1], to array [v2], - starting at element number [o2]. It works correctly even if - [v1] and [v2] are the same array, and the source and - destination chunks overlap. - - Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not - designate a valid subarray of [v1], or if [o2] and [len] do not - designate a valid subarray of [v2]. */ -let blit: (array<'a>, int, array<'a>, int, int) => unit - -/** [Array.to_list a] returns the list of all the elements of [a]. */ -let to_list: array<'a> => list<'a> - -/** [Array.of_list l] returns a fresh array containing the elements - of [l]. */ -let of_list: list<'a> => array<'a> - -/* {1 Iterators} */ - -/** [Array.iter f a] applies function [f] in turn to all - the elements of [a]. It is equivalent to - [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. */ -let iter: ('a => unit, array<'a>) => unit - -/** Same as {!Array.iter}, but the - function is applied with the index of the element as first argument, - and the element itself as second argument. */ -let iteri: ((int, 'a) => unit, array<'a>) => unit - -/** [Array.map f a] applies function [f] to all the elements of [a], - and builds an array with the results returned by [f]: - [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. */ -let map: ('a => 'b, array<'a>) => array<'b> - -/** Same as {!Array.map}, but the - function is applied to the index of the element as first argument, - and the element itself as second argument. */ -let mapi: ((int, 'a) => 'b, array<'a>) => array<'b> - -/** [Array.fold_left f x a] computes - [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], - where [n] is the length of the array [a]. */ -let fold_left: (('a, 'b) => 'a, 'a, array<'b>) => 'a - -/** [Array.fold_right f a x] computes - [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], - where [n] is the length of the array [a]. */ -let fold_right: (('b, 'a) => 'a, array<'b>, 'a) => 'a - -/* {1 Iterators on two arrays} */ - -/** [Array.iter2 f a b] applies function [f] to all the elements of [a] - and [b]. - Raise [Invalid_argument] if the arrays are not the same size. - @since 4.03.0 */ -let iter2: (('a, 'b) => unit, array<'a>, array<'b>) => unit - -/** [Array.map2 f a b] applies function [f] to all the elements of [a] - and [b], and builds an array with the results returned by [f]: - [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]]. - Raise [Invalid_argument] if the arrays are not the same size. - @since 4.03.0 */ -let map2: (('a, 'b) => 'c, array<'a>, array<'b>) => array<'c> - -/* {1 Array scanning} */ - -/** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array - satisfy the predicate [p]. That is, it returns - [(p a1) && (p a2) && ... && (p an)]. - @since 4.03.0 */ -let for_all: ('a => bool, array<'a>) => bool - -/** [Array.exists p [|a1; ...; an|]] checks if at least one element of - the array satisfies the predicate [p]. That is, it returns - [(p a1) || (p a2) || ... || (p an)]. - @since 4.03.0 */ -let exists: ('a => bool, array<'a>) => bool - -/** [mem a l] is true if and only if [a] is equal - to an element of [l]. - @since 4.03.0 */ -let mem: ('a, array<'a>) => bool - -/** Same as {!Array.mem}, but uses physical equality instead of structural - equality to compare array elements. - @since 4.03.0 */ -let memq: ('a, array<'a>) => bool - -/* {1 Sorting} */ - -/** Sort an array in increasing order according to a comparison - function. The comparison function must return 0 if its arguments - compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller (see below for a - complete specification). For example, {!Pervasives.compare} is - a suitable comparison function, provided there are no floating-point - NaN values in the data. After calling [Array.sort], the - array is sorted in place in increasing order. - [Array.sort] is guaranteed to run in constant heap space - and (at most) logarithmic stack space. - - The current implementation uses Heap Sort. It runs in constant - stack space. - - Specification of the comparison function: - Let [a] be the array and [cmp] the comparison function. The following - must be true for all x, y, z in a : -- [cmp x y] > 0 if and only if [cmp y x] < 0 -- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 - - When [Array.sort] returns, [a] contains the same elements as before, - reordered in such a way that for all i and j valid indices of [a] : -- [cmp a.(i) a.(j)] >= 0 if and only if i >= j -*/ -let sort: (('a, 'a) => int, array<'a>) => unit - -/** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. - elements that compare equal are kept in their original order) and - not guaranteed to run in constant heap space. - - The current implementation uses Merge Sort. It uses [n/2] - words of heap space, where [n] is the length of the array. - It is usually faster than the current implementation of {!Array.sort}. -*/ -let stable_sort: (('a, 'a) => int, array<'a>) => unit - -/** Same as {!Array.sort} or {!Array.stable_sort}, whichever is faster - on typical input. -*/ -let fast_sort: (('a, 'a) => int, array<'a>) => unit - -/* {1 Undocumented functions} */ - -/* The following is for system use only. Do not call directly. */ - -external unsafe_get: (array<'a>, int) => 'a = "%array_unsafe_get" -external unsafe_set: (array<'a>, int, 'a) => unit = "%array_unsafe_set" - -module Floatarray: { - external create: int => floatarray = "?floatarray_create" - external length: floatarray => int = "%floatarray_length" - external get: (floatarray, int) => float = "%floatarray_safe_get" - external set: (floatarray, int, float) => unit = "%floatarray_safe_set" - external unsafe_get: (floatarray, int) => float = "%floatarray_unsafe_get" - external unsafe_set: (floatarray, int, float) => unit = "%floatarray_unsafe_set" -} diff --git a/jscomp/stdlib-406/arrayLabels.res b/jscomp/stdlib-406/arrayLabels.res deleted file mode 100644 index e677525..0000000 --- a/jscomp/stdlib-406/arrayLabels.res +++ /dev/null @@ -1,410 +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. */ -/* */ -/* ************************************************************************ */ - -/* Array operations */ - -external length: array<'a> => int = "%array_length" -external get: (array<'a>, int) => 'a = "%array_safe_get" -external set: (array<'a>, int, 'a) => unit = "%array_safe_set" -external unsafe_get: (array<'a>, int) => 'a = "%array_unsafe_get" -external unsafe_set: (array<'a>, int, 'a) => unit = "%array_unsafe_set" -external make: (int, 'a) => array<'a> = "?make_vect" -external create: (int, 'a) => array<'a> = "?make_vect" -external unsafe_sub: (array<'a>, int, int) => array<'a> = "?array_sub" - -@send external append_prim: (array<'a>, array<'a>) => array<'a> = "concat" - -external concat: list> => array<'a> = "?array_concat" -external unsafe_blit: (array<'a>, int, array<'a>, int, int) => unit = "?array_blit" -external create_float: int => array = "?make_float_vect" -let make_float = create_float - -module Floatarray = { - external create: int => floatarray = "?floatarray_create" - external length: floatarray => int = "%floatarray_length" - external get: (floatarray, int) => float = "%floatarray_safe_get" - external set: (floatarray, int, float) => unit = "%floatarray_safe_set" - external unsafe_get: (floatarray, int) => float = "%floatarray_unsafe_get" - external unsafe_set: (floatarray, int, float) => unit = "%floatarray_unsafe_set" -} - -let init = (l, ~f) => - if l == 0 { - [] - } else if l < 0 { - invalid_arg("Array.init") - } else { - /* See #6575. We could also check for maximum array size, but this depends - on whether we create a float array or a regular one... */ - - let res = create(l, f(0)) - for i in 1 to pred(l) { - unsafe_set(res, i, f(i)) - } - res - } - -let make_matrix = (~dimx as sx, ~dimy as sy, init) => { - let res = create(sx, []) - for x in 0 to pred(sx) { - unsafe_set(res, x, create(sy, init)) - } - res -} - -let create_matrix = make_matrix - -let copy = a => { - let l = length(a) - if l == 0 { - [] - } else { - unsafe_sub(a, 0, l) - } -} - -let append = (a1, a2) => { - let l1 = length(a1) - if l1 == 0 { - copy(a2) - } else if length(a2) == 0 { - unsafe_sub(a1, 0, l1) - } else { - append_prim(a1, a2) - } -} - -let sub = (a, ~pos as ofs, ~len) => - if ofs < 0 || (len < 0 || ofs > length(a) - len) { - invalid_arg("Array.sub") - } else { - unsafe_sub(a, ofs, len) - } - -let fill = (a, ~pos as ofs, ~len, v) => - if ofs < 0 || (len < 0 || ofs > length(a) - len) { - invalid_arg("Array.fill") - } else { - for i in ofs to ofs + len - 1 { - unsafe_set(a, i, v) - } - } - -let blit = (~src as a1, ~src_pos as ofs1, ~dst as a2, ~dst_pos as ofs2, ~len) => - if len < 0 || (ofs1 < 0 || (ofs1 > length(a1) - len || (ofs2 < 0 || ofs2 > length(a2) - len))) { - invalid_arg("Array.blit") - } else { - unsafe_blit(a1, ofs1, a2, ofs2, len) - } - -let iter = (~f, a) => - for i in 0 to length(a) - 1 { - f(unsafe_get(a, i)) - } - -let iter2 = (~f, a, b) => - if length(a) != length(b) { - invalid_arg("Array.iter2: arrays must have the same length") - } else { - for i in 0 to length(a) - 1 { - f(unsafe_get(a, i), unsafe_get(b, i)) - } - } - -let map = (~f, a) => { - let l = length(a) - if l == 0 { - [] - } else { - let r = create(l, f(unsafe_get(a, 0))) - for i in 1 to l - 1 { - unsafe_set(r, i, f(unsafe_get(a, i))) - } - r - } -} - -let map2 = (~f, a, b) => { - let la = length(a) - let lb = length(b) - if la != lb { - invalid_arg("Array.map2: arrays must have the same length") - } else if la == 0 { - [] - } else { - let r = create(la, f(unsafe_get(a, 0), unsafe_get(b, 0))) - for i in 1 to la - 1 { - unsafe_set(r, i, f(unsafe_get(a, i), unsafe_get(b, i))) - } - r - } -} - -let iteri = (~f, a) => - for i in 0 to length(a) - 1 { - f(i, unsafe_get(a, i)) - } - -let mapi = (~f, a) => { - let l = length(a) - if l == 0 { - [] - } else { - let r = create(l, f(0, unsafe_get(a, 0))) - for i in 1 to l - 1 { - unsafe_set(r, i, f(i, unsafe_get(a, i))) - } - r - } -} - -let to_list = a => { - let rec tolist = (i, res) => - if i < 0 { - res - } else { - tolist(i - 1, list{unsafe_get(a, i), ...res}) - } - tolist(length(a) - 1, list{}) -} - -/* Cannot use List.length here because the List module depends on Array. */ -let rec list_length = (accu, param) => - switch param { - | list{} => accu - | list{_, ...t} => list_length(succ(accu), t) - } - -let of_list = param => - switch param { - | list{} => [] - | list{hd, ...tl} as l => - let a = create(list_length(0, l), hd) - let rec fill = (i, param) => - switch param { - | list{} => a - | list{hd, ...tl} => - unsafe_set(a, i, hd) - fill(i + 1, tl) - } - fill(1, tl) - } - -let fold_left = (~f, ~init as x, a) => { - let r = ref(x) - for i in 0 to length(a) - 1 { - r := f(r.contents, unsafe_get(a, i)) - } - r.contents -} - -let fold_right = (~f, a, ~init as x) => { - let r = ref(x) - for i in length(a) - 1 downto 0 { - r := f(unsafe_get(a, i), r.contents) - } - r.contents -} - -let exists = (~f as p, a) => { - let n = length(a) - let rec loop = i => - if i == n { - false - } else if p(unsafe_get(a, i)) { - true - } else { - loop(succ(i)) - } - loop(0) -} - -let for_all = (~f as p, a) => { - let n = length(a) - let rec loop = i => - if i == n { - true - } else if p(unsafe_get(a, i)) { - loop(succ(i)) - } else { - false - } - loop(0) -} - -let mem = (x, ~set as a) => { - let n = length(a) - let rec loop = i => - if i == n { - false - } else if compare(unsafe_get(a, i), x) == 0 { - true - } else { - loop(succ(i)) - } - loop(0) -} - -let memq = (x, ~set as a) => { - let n = length(a) - let rec loop = i => - if i == n { - false - } else if x === unsafe_get(a, i) { - true - } else { - loop(succ(i)) - } - loop(0) -} - -exception Bottom(int) -let sort = (~cmp, a) => { - let maxson = (l, i) => { - let i31 = i + i + i + 1 - let x = ref(i31) - if i31 + 2 < l { - if cmp(get(a, i31), get(a, i31 + 1)) < 0 { - x := i31 + 1 - } - if cmp(get(a, x.contents), get(a, i31 + 2)) < 0 { - x := i31 + 2 - } - x.contents - } else if i31 + 1 < l && cmp(get(a, i31), get(a, i31 + 1)) < 0 { - i31 + 1 - } else if i31 < l { - i31 - } else { - raise(Bottom(i)) - } - } - - let rec trickledown = (l, i, e) => { - let j = maxson(l, i) - if cmp(get(a, j), e) > 0 { - set(a, i, get(a, j)) - trickledown(l, j, e) - } else { - set(a, i, e) - } - } - - let trickle = (l, i, e) => - try trickledown(l, i, e) catch { - | Bottom(i) => set(a, i, e) - } - let rec bubbledown = (l, i) => { - let j = maxson(l, i) - set(a, i, get(a, j)) - bubbledown(l, j) - } - - let bubble = (l, i) => - try bubbledown(l, i) catch { - | Bottom(i) => i - } - let rec trickleup = (i, e) => { - let father = (i - 1) / 3 - assert(i != father) - if cmp(get(a, father), e) < 0 { - set(a, i, get(a, father)) - if father > 0 { - trickleup(father, e) - } else { - set(a, 0, e) - } - } else { - set(a, i, e) - } - } - - let l = length(a) - for i in (l + 1) / 3 - 1 downto 0 { - trickle(l, i, get(a, i)) - } - for i in l - 1 downto 2 { - let e = get(a, i) - set(a, i, get(a, 0)) - trickleup(bubble(i, 0), e) - } - if l > 1 { - let e = get(a, 1) - set(a, 1, get(a, 0)) - set(a, 0, e) - } -} - -let cutoff = 5 -let stable_sort = (~cmp, a) => { - let merge = (src1ofs, src1len, src2, src2ofs, src2len, dst, dstofs) => { - let src1r = src1ofs + src1len and src2r = src2ofs + src2len - let rec loop = (i1, s1, i2, s2, d) => - if cmp(s1, s2) <= 0 { - set(dst, d, s1) - let i1 = i1 + 1 - if i1 < src1r { - loop(i1, get(a, i1), i2, s2, d + 1) - } else { - blit(~src=src2, ~src_pos=i2, ~dst, ~dst_pos=d + 1, ~len=src2r - i2) - } - } else { - set(dst, d, s2) - let i2 = i2 + 1 - if i2 < src2r { - loop(i1, s1, i2, get(src2, i2), d + 1) - } else { - blit(~src=a, ~src_pos=i1, ~dst, ~dst_pos=d + 1, ~len=src1r - i1) - } - } - loop(src1ofs, get(a, src1ofs), src2ofs, get(src2, src2ofs), dstofs) - } - - let isortto = (srcofs, dst, dstofs, len) => - for i in 0 to len - 1 { - let e = get(a, srcofs + i) - let j = ref(dstofs + i - 1) - while j.contents >= dstofs && cmp(get(dst, j.contents), e) > 0 { - set(dst, j.contents + 1, get(dst, j.contents)) - decr(j) - } - set(dst, j.contents + 1, e) - } - - let rec sortto = (srcofs, dst, dstofs, len) => - if len <= cutoff { - isortto(srcofs, dst, dstofs, len) - } else { - let l1 = len / 2 - let l2 = len - l1 - sortto(srcofs + l1, dst, dstofs + l1, l2) - sortto(srcofs, a, srcofs + l2, l1) - merge(srcofs + l2, l1, dst, dstofs + l1, l2, dst, dstofs) - } - - let l = length(a) - if l <= cutoff { - isortto(0, a, 0, l) - } else { - let l1 = l / 2 - let l2 = l - l1 - let t = make(l2, get(a, 0)) - sortto(l1, t, 0, l2) - sortto(0, a, l2, l1) - merge(l2, l1, t, 0, l2, a, 0) - } -} - -let fast_sort = stable_sort diff --git a/jscomp/stdlib-406/arrayLabels.resi b/jscomp/stdlib-406/arrayLabels.resi deleted file mode 100644 index 1a21169..0000000 --- a/jscomp/stdlib-406/arrayLabels.resi +++ /dev/null @@ -1,264 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Array operations. */ - -/** Return the length (number of elements) of the given array. */ -external length: array<'a> => int = "%array_length" - -/** [Array.get a n] returns the element number [n] of array [a]. - The first element has number 0. - The last element has number [Array.length a - 1]. - You can also write [a.(n)] instead of [Array.get a n]. - - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [(Array.length a - 1)]. */ -external get: (array<'a>, int) => 'a = "%array_safe_get" - -/** [Array.set a n x] modifies array [a] in place, replacing - element number [n] with [x]. - You can also write [a.(n) <- x] instead of [Array.set a n x]. - - Raise [Invalid_argument "index out of bounds"] - if [n] is outside the range 0 to [Array.length a - 1]. */ -external set: (array<'a>, int, 'a) => unit = "%array_safe_set" - -/** [Array.make n x] returns a fresh array of length [n], - initialized with [x]. - All the elements of this new array are initially - physically equal to [x] (in the sense of the [==] predicate). - Consequently, if [x] is mutable, it is shared among all elements - of the array, and modifying [x] through one of the array entries - will modify all other entries at the same time. - - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. - If the value of [x] is a floating-point number, then the maximum - size is only [Sys.max_array_length / 2].*/ -external make: (int, 'a) => array<'a> = "?make_vect" - -@deprecated("Use Array.make instead.") -/** @deprecated [Array.create] is an alias for {!Array.make}. */ -external create: (int, 'a) => array<'a> = "?make_vect" - -/** [Array.init n f] returns a fresh array of length [n], - with element number [i] initialized to the result of [f i]. - In other terms, [Array.init n f] tabulates the results of [f] - applied to the integers [0] to [n-1]. - - Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. - If the return type of [f] is [float], then the maximum - size is only [Sys.max_array_length / 2].*/ -let init: (int, ~f: int => 'a) => array<'a> - -/** [Array.make_matrix dimx dimy e] returns a two-dimensional array - (an array of arrays) with first dimension [dimx] and - second dimension [dimy]. All the elements of this new matrix - are initially physically equal to [e]. - The element ([x,y]) of a matrix [m] is accessed - with the notation [m.(x).(y)]. - - Raise [Invalid_argument] if [dimx] or [dimy] is negative or - greater than {!Sys.max_array_length}. - If the value of [e] is a floating-point number, then the maximum - size is only [Sys.max_array_length / 2]. */ -let make_matrix: (~dimx: int, ~dimy: int, 'a) => array> - -@deprecated("Use Array.make_matrix instead.") -/** @deprecated [Array.create_matrix] is an alias for - {!Array.make_matrix}. */ -let create_matrix: (~dimx: int, ~dimy: int, 'a) => array> - -/** [Array.append v1 v2] returns a fresh array containing the - concatenation of the arrays [v1] and [v2]. */ -let append: (array<'a>, array<'a>) => array<'a> - -/** Same as {!Array.append}, but concatenates a list of arrays. */ -let concat: list> => array<'a> - -/** [Array.sub a start len] returns a fresh array of length [len], - containing the elements number [start] to [start + len - 1] - of array [a]. - - Raise [Invalid_argument "Array.sub"] if [start] and [len] do not - designate a valid subarray of [a]; that is, if - [start < 0], or [len < 0], or [start + len > Array.length a]. */ -let sub: (array<'a>, ~pos: int, ~len: int) => array<'a> - -/** [Array.copy a] returns a copy of [a], that is, a fresh array - containing the same elements as [a]. */ -let copy: array<'a> => array<'a> - -/** [Array.fill a ofs len x] modifies the array [a] in place, - storing [x] in elements number [ofs] to [ofs + len - 1]. - - Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not - designate a valid subarray of [a]. */ -let fill: (array<'a>, ~pos: int, ~len: int, 'a) => unit - -/** [Array.blit v1 o1 v2 o2 len] copies [len] elements - from array [v1], starting at element number [o1], to array [v2], - starting at element number [o2]. It works correctly even if - [v1] and [v2] are the same array, and the source and - destination chunks overlap. - - Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not - designate a valid subarray of [v1], or if [o2] and [len] do not - designate a valid subarray of [v2]. */ -let blit: (~src: array<'a>, ~src_pos: int, ~dst: array<'a>, ~dst_pos: int, ~len: int) => unit - -/** [Array.to_list a] returns the list of all the elements of [a]. */ -let to_list: array<'a> => list<'a> - -/** [Array.of_list l] returns a fresh array containing the elements - of [l]. */ -let of_list: list<'a> => array<'a> - -/** [Array.iter f a] applies function [f] in turn to all - the elements of [a]. It is equivalent to - [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. */ -let iter: (~f: 'a => unit, array<'a>) => unit - -/** [Array.map f a] applies function [f] to all the elements of [a], - and builds an array with the results returned by [f]: - [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. */ -let map: (~f: 'a => 'b, array<'a>) => array<'b> - -/** Same as {!Array.iter}, but the - function is applied to the index of the element as first argument, - and the element itself as second argument. */ -let iteri: (~f: (int, 'a) => unit, array<'a>) => unit - -/** Same as {!Array.map}, but the - function is applied to the index of the element as first argument, - and the element itself as second argument. */ -let mapi: (~f: (int, 'a) => 'b, array<'a>) => array<'b> - -/** [Array.fold_left f x a] computes - [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], - where [n] is the length of the array [a]. */ -let fold_left: (~f: ('a, 'b) => 'a, ~init: 'a, array<'b>) => 'a - -/** [Array.fold_right f a x] computes - [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], - where [n] is the length of the array [a]. */ -let fold_right: (~f: ('b, 'a) => 'a, array<'b>, ~init: 'a) => 'a - -/* {6 Iterators on two arrays} */ - -/** [Array.iter2 f a b] applies function [f] to all the elements of [a] - and [b]. - Raise [Invalid_argument] if the arrays are not the same size. - @since 4.05.0 */ -let iter2: (~f: ('a, 'b) => unit, array<'a>, array<'b>) => unit - -/** [Array.map2 f a b] applies function [f] to all the elements of [a] - and [b], and builds an array with the results returned by [f]: - [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]]. - Raise [Invalid_argument] if the arrays are not the same size. - @since 4.05.0 */ -let map2: (~f: ('a, 'b) => 'c, array<'a>, array<'b>) => array<'c> - -/* {6 Array scanning} */ - -/** [Array.exists p [|a1; ...; an|]] checks if at least one element of - the array satisfies the predicate [p]. That is, it returns - [(p a1) || (p a2) || ... || (p an)]. - @since 4.03.0 */ -let exists: (~f: 'a => bool, array<'a>) => bool - -/** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array - satisfy the predicate [p]. That is, it returns - [(p a1) && (p a2) && ... && (p an)]. - @since 4.03.0 */ -let for_all: (~f: 'a => bool, array<'a>) => bool - -/** [mem x a] is true if and only if [x] is equal - to an element of [a]. - @since 4.03.0 */ -let mem: ('a, ~set: array<'a>) => bool - -/** Same as {!Array.mem}, but uses physical equality instead of structural - equality to compare list elements. - @since 4.03.0 */ -let memq: ('a, ~set: array<'a>) => bool - -/** [Array.create_float n] returns a fresh float array of length [n], - with uninitialized data. - @since 4.03 */ -external create_float: int => array = "?make_float_vect" - -@deprecated("Use Array.create_float instead.") -/** @deprecated [Array.make_float] is an alias for - {!Array.create_float}. */ -let make_float: int => array - -/* {1 Sorting} */ - -/** Sort an array in increasing order according to a comparison - function. The comparison function must return 0 if its arguments - compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller (see below for a - complete specification). For example, {!Pervasives.compare} is - a suitable comparison function, provided there are no floating-point - NaN values in the data. After calling [Array.sort], the - array is sorted in place in increasing order. - [Array.sort] is guaranteed to run in constant heap space - and (at most) logarithmic stack space. - - The current implementation uses Heap Sort. It runs in constant - stack space. - - Specification of the comparison function: - Let [a] be the array and [cmp] the comparison function. The following - must be true for all x, y, z in a : -- [cmp x y] > 0 if and only if [cmp y x] < 0 -- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 - - When [Array.sort] returns, [a] contains the same elements as before, - reordered in such a way that for all i and j valid indices of [a] : -- [cmp a.(i) a.(j)] >= 0 if and only if i >= j -*/ -let sort: (~cmp: ('a, 'a) => int, array<'a>) => unit - -/** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. - elements that compare equal are kept in their original order) and - not guaranteed to run in constant heap space. - - The current implementation uses Merge Sort. It uses [n/2] - words of heap space, where [n] is the length of the array. - It is usually faster than the current implementation of {!Array.sort}. -*/ -let stable_sort: (~cmp: ('a, 'a) => int, array<'a>) => unit - -/** Same as {!Array.sort} or {!Array.stable_sort}, whichever is - faster on typical input. -*/ -let fast_sort: (~cmp: ('a, 'a) => int, array<'a>) => unit - -/* {1 Undocumented functions} */ - -/* The following is for system use only. Do not call directly. */ - -external unsafe_get: (array<'a>, int) => 'a = "%array_unsafe_get" -external unsafe_set: (array<'a>, int, 'a) => unit = "%array_unsafe_set" - -module Floatarray: { - external create: int => floatarray = "?floatarray_create" - external length: floatarray => int = "%floatarray_length" - external get: (floatarray, int) => float = "%floatarray_safe_get" - external set: (floatarray, int, float) => unit = "%floatarray_safe_set" - external unsafe_get: (floatarray, int) => float = "%floatarray_unsafe_get" - external unsafe_set: (floatarray, int, float) => unit = "%floatarray_unsafe_set" -} diff --git a/jscomp/stdlib-406/buffer.res b/jscomp/stdlib-406/buffer.res deleted file mode 100644 index 6d9db8c..0000000 --- a/jscomp/stdlib-406/buffer.res +++ /dev/null @@ -1,307 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 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. */ -/* */ -/* ************************************************************************ */ - -/* Extensible buffers */ - -type t = { - mutable buffer: bytes, - mutable position: int, - mutable length: int, - initial_buffer: bytes, -} - -let create = n => { - let n = if n < 1 { - 1 - } else { - n - } - let s = Bytes.create(n) - {buffer: s, position: 0, length: n, initial_buffer: s} -} - -let contents = b => Bytes.sub_string(b.buffer, 0, b.position) -let to_bytes = b => Bytes.sub(b.buffer, 0, b.position) - -let sub = (b, ofs, len) => - if ofs < 0 || (len < 0 || ofs > b.position - len) { - invalid_arg("Buffer.sub") - } else { - Bytes.sub_string(b.buffer, ofs, len) - } - -let blit = (src, srcoff, dst, dstoff, len) => - if ( - len < 0 || - (srcoff < 0 || - (srcoff > src.position - len || (dstoff < 0 || dstoff > Bytes.length(dst) - len))) - ) { - invalid_arg("Buffer.blit") - } else { - Bytes.blit(src.buffer, srcoff, dst, dstoff, len) - } - -let nth = (b, ofs) => - if ofs < 0 || ofs >= b.position { - invalid_arg("Buffer.nth") - } else { - Bytes.unsafe_get(b.buffer, ofs) - } - -let length = b => b.position - -let clear = b => b.position = 0 - -let reset = b => { - b.position = 0 - b.buffer = b.initial_buffer - b.length = Bytes.length(b.buffer) -} - -let resize = (b, more) => { - let len = b.length - let new_len = ref(len) - while b.position + more > new_len.contents { - new_len := 2 * new_len.contents - } - let new_buffer = Bytes.create(new_len.contents) - /* PR#6148: let's keep using [blit] rather than [unsafe_blit] in - this tricky function that is slow anyway. */ - Bytes.blit(b.buffer, 0, new_buffer, 0, b.position) - b.buffer = new_buffer - b.length = new_len.contents -} - -let add_char = (b, c) => { - let pos = b.position - if pos >= b.length { - resize(b, 1) - } - Bytes.unsafe_set(b.buffer, pos, c) - b.position = pos + 1 -} - -let add_utf_8_uchar = (b, u) => - switch Uchar.to_int(u) { - | u if u < 0 => assert(false) - | u if u <= 0x007F => add_char(b, Char.unsafe_chr(u)) - | u if u <= 0x07FF => - let pos = b.position - if pos + 2 > b.length { - resize(b, 2) - } - Bytes.unsafe_set(b.buffer, pos, Char.unsafe_chr(lor(0xC0, lsr(u, 6)))) - Bytes.unsafe_set(b.buffer, pos + 1, Char.unsafe_chr(lor(0x80, land(u, 0x3F)))) - b.position = pos + 2 - | u if u <= 0xFFFF => - let pos = b.position - if pos + 3 > b.length { - resize(b, 3) - } - Bytes.unsafe_set(b.buffer, pos, Char.unsafe_chr(lor(0xE0, lsr(u, 12)))) - Bytes.unsafe_set(b.buffer, pos + 1, Char.unsafe_chr(lor(0x80, land(lsr(u, 6), 0x3F)))) - Bytes.unsafe_set(b.buffer, pos + 2, Char.unsafe_chr(lor(0x80, land(u, 0x3F)))) - b.position = pos + 3 - | u if u <= 0x10FFFF => - let pos = b.position - if pos + 4 > b.length { - resize(b, 4) - } - Bytes.unsafe_set(b.buffer, pos, Char.unsafe_chr(lor(0xF0, lsr(u, 18)))) - Bytes.unsafe_set(b.buffer, pos + 1, Char.unsafe_chr(lor(0x80, land(lsr(u, 12), 0x3F)))) - Bytes.unsafe_set(b.buffer, pos + 2, Char.unsafe_chr(lor(0x80, land(lsr(u, 6), 0x3F)))) - Bytes.unsafe_set(b.buffer, pos + 3, Char.unsafe_chr(lor(0x80, land(u, 0x3F)))) - b.position = pos + 4 - | _ => assert(false) - } - -let add_utf_16be_uchar = (b, u) => - switch Uchar.to_int(u) { - | u if u < 0 => assert(false) - | u if u <= 0xFFFF => - let pos = b.position - if pos + 2 > b.length { - resize(b, 2) - } - Bytes.unsafe_set(b.buffer, pos, Char.unsafe_chr(lsr(u, 8))) - Bytes.unsafe_set(b.buffer, pos + 1, Char.unsafe_chr(land(u, 0xFF))) - b.position = pos + 2 - | u if u <= 0x10FFFF => - let u' = u - 0x10000 - let hi = lor(0xD800, lsr(u', 10)) - let lo = lor(0xDC00, land(u', 0x3FF)) - let pos = b.position - if pos + 4 > b.length { - resize(b, 4) - } - Bytes.unsafe_set(b.buffer, pos, Char.unsafe_chr(lsr(hi, 8))) - Bytes.unsafe_set(b.buffer, pos + 1, Char.unsafe_chr(land(hi, 0xFF))) - Bytes.unsafe_set(b.buffer, pos + 2, Char.unsafe_chr(lsr(lo, 8))) - Bytes.unsafe_set(b.buffer, pos + 3, Char.unsafe_chr(land(lo, 0xFF))) - b.position = pos + 4 - | _ => assert(false) - } - -let add_utf_16le_uchar = (b, u) => - switch Uchar.to_int(u) { - | u if u < 0 => assert(false) - | u if u <= 0xFFFF => - let pos = b.position - if pos + 2 > b.length { - resize(b, 2) - } - Bytes.unsafe_set(b.buffer, pos, Char.unsafe_chr(land(u, 0xFF))) - Bytes.unsafe_set(b.buffer, pos + 1, Char.unsafe_chr(lsr(u, 8))) - b.position = pos + 2 - | u if u <= 0x10FFFF => - let u' = u - 0x10000 - let hi = lor(0xD800, lsr(u', 10)) - let lo = lor(0xDC00, land(u', 0x3FF)) - let pos = b.position - if pos + 4 > b.length { - resize(b, 4) - } - Bytes.unsafe_set(b.buffer, pos, Char.unsafe_chr(land(hi, 0xFF))) - Bytes.unsafe_set(b.buffer, pos + 1, Char.unsafe_chr(lsr(hi, 8))) - Bytes.unsafe_set(b.buffer, pos + 2, Char.unsafe_chr(land(lo, 0xFF))) - Bytes.unsafe_set(b.buffer, pos + 3, Char.unsafe_chr(lsr(lo, 8))) - b.position = pos + 4 - | _ => assert(false) - } - -let add_substring = (b, s, offset, len) => { - if offset < 0 || (len < 0 || offset > String.length(s) - len) { - invalid_arg("Buffer.add_substring/add_subbytes") - } - let new_position = b.position + len - if new_position > b.length { - resize(b, len) - } - Bytes.blit_string(s, offset, b.buffer, b.position, len) - b.position = new_position -} - -let add_subbytes = (b, s, offset, len) => add_substring(b, Bytes.unsafe_to_string(s), offset, len) - -let add_string = (b, s) => { - let len = String.length(s) - let new_position = b.position + len - if new_position > b.length { - resize(b, len) - } - Bytes.blit_string(s, 0, b.buffer, b.position, len) - b.position = new_position -} - -let add_bytes = (b, s) => add_string(b, Bytes.unsafe_to_string(s)) - -let add_buffer = (b, bs) => add_subbytes(b, bs.buffer, 0, bs.position) - -let closing = param => - switch param { - | '(' => ')' - | '{' => '}' - | _ => assert(false) - } - -/* opening and closing: open and close characters, typically ( and ) - k: balance of opening and closing chars - s: the string where we are searching - start: the index where we start the search. */ -let advance_to_closing = (opening, closing, k, s, start) => { - let rec advance = (k, i, lim) => - if i >= lim { - raise(Not_found) - } else if String.get(s, i) == opening { - advance(k + 1, i + 1, lim) - } else if String.get(s, i) == closing { - if k == 0 { - i - } else { - advance(k - 1, i + 1, lim) - } - } else { - advance(k, i + 1, lim) - } - advance(k, start, String.length(s)) -} - -let advance_to_non_alpha = (s, start) => { - let rec advance = (i, lim) => - if i >= lim { - lim - } else { - switch String.get(s, i) { - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' => advance(i + 1, lim) - | _ => i - } - } - advance(start, String.length(s)) -} - -/* We are just at the beginning of an ident in s, starting at start. */ -let find_ident = (s, start, lim) => - if start >= lim { - raise(Not_found) - } else { - switch String.get(s, start) { - /* Parenthesized ident ? */ - | ('(' | '{') as c => - let new_start = start + 1 - let stop = advance_to_closing(c, closing(c), 0, s, new_start) - (String.sub(s, new_start, stop - start - 1), stop + 1) - /* Regular ident */ - | _ => - let stop = advance_to_non_alpha(s, start + 1) - (String.sub(s, start, stop - start), stop) - } - } - -/* Substitute $ident, $(ident), or ${ident} in s, - according to the function mapping f. */ -let add_substitute = (b, f, s) => { - let lim = String.length(s) - let rec subst = (previous, i) => - if i < lim { - switch String.get(s, i) { - | '$' as current if previous == '\\' => - add_char(b, current) - subst(' ', i + 1) - | '$' => - let j = i + 1 - let (ident, next_i) = find_ident(s, j, lim) - add_string(b, f(ident)) - subst(' ', next_i) - | current if previous === '\\' => - add_char(b, '\\') - add_char(b, current) - subst(' ', i + 1) - | '\\' as current => subst(current, i + 1) - | current => - add_char(b, current) - subst(current, i + 1) - } - } else if previous == '\\' { - add_char(b, previous) - } - subst(' ', 0) -} - -let truncate = (b, len) => - if len < 0 || len > length(b) { - invalid_arg("Buffer.truncate") - } else { - b.position = len - } diff --git a/jscomp/stdlib-406/buffer.resi b/jscomp/stdlib-406/buffer.resi deleted file mode 100644 index 9929a1d..0000000 --- a/jscomp/stdlib-406/buffer.resi +++ /dev/null @@ -1,148 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Pierre Weis and Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1999 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. */ -/* */ -/* ************************************************************************ */ - -/*** Extensible buffers. - - This module implements buffers that automatically expand - as necessary. It provides accumulative concatenation of strings - in quasi-linear time (instead of quadratic time when strings are - concatenated pairwise). -*/ - -/** The abstract type of buffers. */ -type t - -/** [create n] returns a fresh buffer, initially empty. - The [n] parameter is the initial size of the internal byte sequence - that holds the buffer contents. That byte sequence is automatically - reallocated when more than [n] characters are stored in the buffer, - but shrinks back to [n] characters when [reset] is called. - For best performance, [n] should be of the same order of magnitude - as the number of characters that are expected to be stored in - the buffer (for instance, 80 for a buffer that holds one output - line). Nothing bad will happen if the buffer grows beyond that - limit, however. In doubt, take [n = 16] for instance. - If [n] is not between 1 and {!Sys.max_string_length}, it will - be clipped to that interval. */ -let create: int => t - -/** Return a copy of the current contents of the buffer. - The buffer itself is unchanged. */ -let contents: t => string - -/** Return a copy of the current contents of the buffer. - The buffer itself is unchanged. - @since 4.02 */ -let to_bytes: t => bytes - -/** [Buffer.sub b off len] returns a copy of [len] bytes from the - current contents of the buffer [b], starting at offset [off]. - - Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid - range of [b]. */ -let sub: (t, int, int) => string - -/** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from - the current contents of the buffer [src], starting at offset [srcoff] - to [dst], starting at character [dstoff]. - - Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid - range of [src], or if [dstoff] and [len] do not designate a valid - range of [dst]. - @since 3.11.2 -*/ -let blit: (t, int, bytes, int, int) => unit - -/** Get the n-th character of the buffer. Raise [Invalid_argument] if - index out of bounds */ -let nth: (t, int) => char - -/** Return the number of characters currently contained in the buffer. */ -let length: t => int - -/** Empty the buffer. */ -let clear: t => unit - -/** Empty the buffer and deallocate the internal byte sequence holding the - buffer contents, replacing it with the initial internal byte sequence - of length [n] that was allocated by {!Buffer.create} [n]. - For long-lived buffers that may have grown a lot, [reset] allows - faster reclamation of the space used by the buffer. */ -let reset: t => unit - -/** [add_char b c] appends the character [c] at the end of buffer [b]. */ -let add_char: (t, char) => unit - -/** [add_utf_8_uchar b u] appends the {{:https://tools.ietf.org/html/rfc3629} - UTF-8} encoding of [u] at the end of buffer [b]. - - @since 4.06.0 */ -let add_utf_8_uchar: (t, Uchar.t) => unit - -/** [add_utf_16le_uchar b u] appends the - {{:https://tools.ietf.org/html/rfc2781}UTF-16LE} encoding of [u] - at the end of buffer [b]. - - @since 4.06.0 */ -let add_utf_16le_uchar: (t, Uchar.t) => unit - -/** [add_utf_16be_uchar b u] appends the - {{:https://tools.ietf.org/html/rfc2781}UTF-16BE} encoding of [u] - at the end of buffer [b]. - - @since 4.06.0 */ -let add_utf_16be_uchar: (t, Uchar.t) => unit - -/** [add_string b s] appends the string [s] at the end of buffer [b]. */ -let add_string: (t, string) => unit - -/** [add_bytes b s] appends the byte sequence [s] at the end of buffer [b]. - @since 4.02 */ -let add_bytes: (t, bytes) => unit - -/** [add_substring b s ofs len] takes [len] characters from offset - [ofs] in string [s] and appends them at the end of buffer [b]. */ -let add_substring: (t, string, int, int) => unit - -/** [add_subbytes b s ofs len] takes [len] characters from offset - [ofs] in byte sequence [s] and appends them at the end of buffer [b]. - @since 4.02 */ -let add_subbytes: (t, bytes, int, int) => unit - -/** [add_substitute b f s] appends the string pattern [s] at the end - of buffer [b] with substitution. - The substitution process looks for variables into - the pattern and substitutes each variable name by its value, as - obtained by applying the mapping [f] to the variable name. Inside the - string pattern, a variable name immediately follows a non-escaped - [$] character and is one of the following: - - a non empty sequence of alphanumeric or [_] characters, - - an arbitrary sequence of characters enclosed by a pair of - matching parentheses or curly brackets. - An escaped [$] character is a [$] that immediately follows a backslash - character; it then stands for a plain [$]. - Raise [Not_found] if the closing character of a parenthesized variable - cannot be found. */ -let add_substitute: (t, string => string, string) => unit - -/** [add_buffer b1 b2] appends the current contents of buffer [b2] - at the end of buffer [b1]. [b2] is not modified. */ -let add_buffer: (t, t) => unit - -/** [truncate b len] truncates the length of [b] to [len] - Note: the internal byte sequence is not shortened. - Raise [Invalid_argument] if [len < 0] or [len > length b]. - @since 4.05.0 */ -let truncate: (t, int) => unit diff --git a/jscomp/stdlib-406/bytes.res b/jscomp/stdlib-406/bytes.res deleted file mode 100644 index d7f9c5c..0000000 Binary files a/jscomp/stdlib-406/bytes.res and /dev/null differ diff --git a/jscomp/stdlib-406/bytes.resi b/jscomp/stdlib-406/bytes.resi deleted file mode 100644 index 2b65cb4..0000000 --- a/jscomp/stdlib-406/bytes.resi +++ /dev/null @@ -1,427 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Byte sequence operations. - - A byte sequence is a mutable data structure that contains a - fixed-length sequence of bytes. Each byte can be indexed in - constant time for reading or writing. - - Given a byte sequence [s] of length [l], we can access each of the - [l] bytes of [s] via its index in the sequence. Indexes start at - [0], and we will call an index valid in [s] if it falls within the - range [[0...l-1]] (inclusive). A position is the point between two - bytes or at the beginning or end of the sequence. We call a - position valid in [s] if it falls within the range [[0...l]] - (inclusive). Note that the byte at index [n] is between positions - [n] and [n+1]. - - Two parameters [start] and [len] are said to designate a valid - range of [s] if [len >= 0] and [start] and [start+len] are valid - positions in [s]. - - Byte sequences can be modified in place, for instance via the [set] - and [blit] functions described below. See also strings (module - {!String}), which are almost the same data structure, but cannot be - modified in place. - - Bytes are represented by the OCaml type [char]. - - @since 4.02.0 -*/ - -/** Return the length (number of bytes) of the argument. */ -external length: bytes => int = "%bytes_length" - -/** [get s n] returns the byte at index [n] in argument [s]. - - Raise [Invalid_argument] if [n] is not a valid index in [s]. */ -external get: (bytes, int) => char = "%bytes_safe_get" - -/** [set s n c] modifies [s] in place, replacing the byte at index [n] - with [c]. - - Raise [Invalid_argument] if [n] is not a valid index in [s]. */ -external set: (bytes, int, char) => unit = "%bytes_safe_set" - -/** [create n] returns a new byte sequence of length [n]. The - sequence is uninitialized and contains arbitrary bytes. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -external create: int => bytes = "?create_bytes" - -/** [make n c] returns a new byte sequence of length [n], filled with - the byte [c]. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -let make: (int, char) => bytes - -/** [Bytes.init n f] returns a fresh byte sequence of length [n], with - character [i] initialized to the result of [f i] (in increasing - index order). - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -let init: (int, int => char) => bytes - -/** A byte sequence of size 0. */ -let empty: bytes - -/** Return a new byte sequence that contains the same bytes as the - argument. */ -let copy: bytes => bytes - -/** Return a new byte sequence that contains the same bytes as the - given string. */ -let of_string: string => bytes - -/** Return a new string that contains the same bytes as the given byte - sequence. */ -let to_string: bytes => string - -/** [sub s start len] returns a new byte sequence of length [len], - containing the subsequence of [s] that starts at position [start] - and has length [len]. - - Raise [Invalid_argument] if [start] and [len] do not designate a - valid range of [s]. */ -let sub: (bytes, int, int) => bytes - -/** Same as [sub] but return a string instead of a byte sequence. */ -let sub_string: (bytes, int, int) => string - -/** [extend s left right] returns a new byte sequence that contains - the bytes of [s], with [left] uninitialized bytes prepended and - [right] uninitialized bytes appended to it. If [left] or [right] - is negative, then bytes are removed (instead of appended) from - the corresponding side of [s]. - - Raise [Invalid_argument] if the result length is negative or - longer than {!Sys.max_string_length} bytes. */ -let extend: (bytes, int, int) => bytes - -/** [fill s start len c] modifies [s] in place, replacing [len] - characters with [c], starting at [start]. - - Raise [Invalid_argument] if [start] and [len] do not designate a - valid range of [s]. */ -let fill: (bytes, int, int, char) => unit - -/** [blit src srcoff dst dstoff len] copies [len] bytes from sequence - [src], starting at index [srcoff], to sequence [dst], starting at - index [dstoff]. It works correctly even if [src] and [dst] are the - same byte sequence, and the source and destination intervals - overlap. - - Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid range of [src], or if [dstoff] and [len] - do not designate a valid range of [dst]. */ -let blit: (bytes, int, bytes, int, int) => unit - -/** [blit src srcoff dst dstoff len] copies [len] bytes from string - [src], starting at index [srcoff], to byte sequence [dst], - starting at index [dstoff]. - - Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid range of [src], or if [dstoff] and [len] - do not designate a valid range of [dst]. */ -let blit_string: (string, int, bytes, int, int) => unit - -/** [concat sep sl] concatenates the list of byte sequences [sl], - inserting the separator byte sequence [sep] between each, and - returns the result as a new byte sequence. - - Raise [Invalid_argument] if the result is longer than - {!Sys.max_string_length} bytes. */ -let concat: (bytes, list) => bytes - -/** [cat s1 s2] concatenates [s1] and [s2] and returns the result - as new byte sequence. - - Raise [Invalid_argument] if the result is longer than - {!Sys.max_string_length} bytes. */ -let cat: (bytes, bytes) => bytes - -/** [iter f s] applies function [f] in turn to all the bytes of [s]. - It is equivalent to [f (get s 0); f (get s 1); ...; f (get s - (length s - 1)); ()]. */ -let iter: (char => unit, bytes) => unit - -/** Same as {!Bytes.iter}, but the function is applied to the index of - the byte as first argument and the byte itself as second - argument. */ -let iteri: ((int, char) => unit, bytes) => unit - -/** [map f s] applies function [f] in turn to all the bytes of [s] - (in increasing index order) and stores the resulting bytes in - a new sequence that is returned as the result. */ -let map: (char => char, bytes) => bytes - -/** [mapi f s] calls [f] with each character of [s] and its - index (in increasing index order) and stores the resulting bytes - in a new sequence that is returned as the result. */ -let mapi: ((int, char) => char, bytes) => bytes - -/** Return a copy of the argument, without leading and trailing - whitespace. The bytes regarded as whitespace are the ASCII - characters [' '], ['\x0c'], ['\n'], ['\r'], and ['\t']. */ -let trim: bytes => bytes - -/** Return a copy of the argument, with special characters represented - by escape sequences, following the lexical conventions of OCaml. - All characters outside the ASCII printable range (32..126) are - escaped, as well as backslash and double-quote. - - Raise [Invalid_argument] if the result is longer than - {!Sys.max_string_length} bytes. */ -let escaped: bytes => bytes - -/** [index s c] returns the index of the first occurrence of byte [c] - in [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let index: (bytes, char) => int - -/** [index_opt s c] returns the index of the first occurrence of byte [c] - in [s] or [None] if [c] does not occur in [s]. - @since 4.05 */ -let index_opt: (bytes, char) => option - -/** [rindex s c] returns the index of the last occurrence of byte [c] - in [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let rindex: (bytes, char) => int - -/** [rindex_opt s c] returns the index of the last occurrence of byte [c] - in [s] or [None] if [c] does not occur in [s]. - @since 4.05 */ -let rindex_opt: (bytes, char) => option - -/** [index_from s i c] returns the index of the first occurrence of - byte [c] in [s] after position [i]. [Bytes.index s c] is - equivalent to [Bytes.index_from s 0 c]. - - Raise [Invalid_argument] if [i] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] after position [i]. */ -let index_from: (bytes, int, char) => int - -/** [index_from _opts i c] returns the index of the first occurrence of - byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i]. - [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c]. - - Raise [Invalid_argument] if [i] is not a valid position in [s]. - @since 4.05 */ -let index_from_opt: (bytes, int, char) => option - -/** [rindex_from s i c] returns the index of the last occurrence of - byte [c] in [s] before position [i+1]. [rindex s c] is equivalent - to [rindex_from s (Bytes.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] before position [i+1]. */ -let rindex_from: (bytes, int, char) => int - -/** [rindex_from_opt s i c] returns the index of the last occurrence - of byte [c] in [s] before position [i+1] or [None] if [c] does not - occur in [s] before position [i+1]. [rindex_opt s c] is equivalent to - [rindex_from s (Bytes.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - @since 4.05 */ -let rindex_from_opt: (bytes, int, char) => option - -/** [contains s c] tests if byte [c] appears in [s]. */ -let contains: (bytes, char) => bool - -/** [contains_from s start c] tests if byte [c] appears in [s] after - position [start]. [contains s c] is equivalent to [contains_from - s 0 c]. - - Raise [Invalid_argument] if [start] is not a valid position in [s]. */ -let contains_from: (bytes, int, char) => bool - -/** [rcontains_from s stop c] tests if byte [c] appears in [s] before - position [stop+1]. - - Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid - position in [s]. */ -let rcontains_from: (bytes, int, char) => bool - -/** Return a copy of the argument, with all lowercase letters - translated to uppercase, using the US-ASCII character set. - @since 4.03.0 */ -let uppercase_ascii: bytes => bytes - -/** Return a copy of the argument, with all uppercase letters - translated to lowercase, using the US-ASCII character set. - @since 4.03.0 */ -let lowercase_ascii: bytes => bytes - -/** Return a copy of the argument, with the first character set to uppercase, - using the US-ASCII character set. - @since 4.03.0 */ -let capitalize_ascii: bytes => bytes - -/** Return a copy of the argument, with the first character set to lowercase, - using the US-ASCII character set. - @since 4.03.0 */ -let uncapitalize_ascii: bytes => bytes - -/** An alias for the type of byte sequences. */ -type t = bytes - -/** The comparison function for byte sequences, with the same - specification as {!Pervasives.compare}. Along with the type [t], - this function [compare] allows the module [Bytes] to be passed as - argument to the functors {!Set.Make} and {!Map.Make}. */ -let compare: (t, t) => int - -/** The equality function for byte sequences. - @since 4.03.0 */ -let equal: (t, t) => bool - -/* {3 Unsafe conversions (for advanced users)} - - This section describes unsafe, low-level conversion functions - between [bytes] and [string]. They do not copy the internal data; - used improperly, they can break the immutability invariant on - strings provided by the [-safe-string] option. They are available for - expert library authors, but for most purposes you should use the - always-correct {!Bytes.to_string} and {!Bytes.of_string} instead. -*/ - -/** Unsafely convert a byte sequence into a string. - - To reason about the use of [unsafe_to_string], it is convenient to - consider an "ownership" discipline. A piece of code that - manipulates some data "owns" it; there are several disjoint ownership - modes, including: - - Unique ownership: the data may be accessed and mutated - - Shared ownership: the data has several owners, that may only - access it, not mutate it. - - Unique ownership is linear: passing the data to another piece of - code means giving up ownership (we cannot write the - data again). A unique owner may decide to make the data shared - (giving up mutation rights on it), but shared data may not become - uniquely-owned again. - - [unsafe_to_string s] can only be used when the caller owns the byte - sequence [s] -- either uniquely or as shared immutable data. The - caller gives up ownership of [s], and gains ownership of the - returned string. - - There are two valid use-cases that respect this ownership - discipline: - - 1. Creating a string by initializing and mutating a byte sequence - that is never changed after initialization is performed. - - {[ -let string_init len f : string = - let s = Bytes.create len in - for i = 0 to len - 1 do Bytes.set s i (f i) done; - Bytes.unsafe_to_string s - ]} - - This function is safe because the byte sequence [s] will never be - accessed or mutated after [unsafe_to_string] is called. The - [string_init] code gives up ownership of [s], and returns the - ownership of the resulting string to its caller. - - Note that it would be unsafe if [s] was passed as an additional - parameter to the function [f] as it could escape this way and be - mutated in the future -- [string_init] would give up ownership of - [s] to pass it to [f], and could not call [unsafe_to_string] - safely. - - We have provided the {!String.init}, {!String.map} and - {!String.mapi} functions to cover most cases of building - new strings. You should prefer those over [to_string] or - [unsafe_to_string] whenever applicable. - - 2. Temporarily giving ownership of a byte sequence to a function - that expects a uniquely owned string and returns ownership back, so - that we can mutate the sequence again after the call ended. - - {[ -let bytes_length (s : bytes) = - String.length (Bytes.unsafe_to_string s) - ]} - - In this use-case, we do not promise that [s] will never be mutated - after the call to [bytes_length s]. The {!String.length} function - temporarily borrows unique ownership of the byte sequence - (and sees it as a [string]), but returns this ownership back to - the caller, which may assume that [s] is still a valid byte - sequence after the call. Note that this is only correct because we - know that {!String.length} does not capture its argument -- it could - escape by a side-channel such as a memoization combinator. - - The caller may not mutate [s] while the string is borrowed (it has - temporarily given up ownership). This affects concurrent programs, - but also higher-order functions: if {!String.length} returned - a closure to be called later, [s] should not be mutated until this - closure is fully applied and returns ownership. -*/ -let unsafe_to_string: bytes => string - -/** Unsafely convert a shared string to a byte sequence that should - not be mutated. - - The same ownership discipline that makes [unsafe_to_string] - correct applies to [unsafe_of_string]: you may use it if you were - the owner of the [string] value, and you will own the return - [bytes] in the same mode. - - In practice, unique ownership of string values is extremely - difficult to reason about correctly. You should always assume - strings are shared, never uniquely owned. - - For example, string literals are implicitly shared by the - compiler, so you never uniquely own them. - - {[ -let incorrect = Bytes.unsafe_of_string "hello" -let s = Bytes.of_string "hello" - ]} - - The first declaration is incorrect, because the string literal - ["hello"] could be shared by the compiler with other parts of the - program, and mutating [incorrect] is a bug. You must always use - the second version, which performs a copy and is thus correct. - - Assuming unique ownership of strings that are not string - literals, but are (partly) built from string literals, is also - incorrect. For example, mutating [unsafe_of_string ("foo" ^ s)] - could mutate the shared string ["foo"] -- assuming a rope-like - representation of strings. More generally, functions operating on - strings will assume shared ownership, they do not preserve unique - ownership. It is thus incorrect to assume unique ownership of the - result of [unsafe_of_string]. - - The only case we have reasonable confidence is safe is if the - produced [bytes] is shared -- used as an immutable byte - sequence. This is possibly useful for incremental migration of - low-level programs that manipulate immutable sequences of bytes - (for example {!Marshal.from_bytes}) and previously used the - [string] type for this purpose. -*/ -let unsafe_of_string: string => bytes - -/* The following is for system use only. Do not call directly. */ - -external unsafe_get: (bytes, int) => char = "%bytes_unsafe_get" -external unsafe_set: (bytes, int, char) => unit = "%bytes_unsafe_set" diff --git a/jscomp/stdlib-406/bytesLabels.res b/jscomp/stdlib-406/bytesLabels.res deleted file mode 100644 index 527d76a..0000000 Binary files a/jscomp/stdlib-406/bytesLabels.res and /dev/null differ diff --git a/jscomp/stdlib-406/bytesLabels.resi b/jscomp/stdlib-406/bytesLabels.resi deleted file mode 100644 index 411f939..0000000 --- a/jscomp/stdlib-406/bytesLabels.resi +++ /dev/null @@ -1,269 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Byte sequence operations. - @since 4.02.0 -*/ - -/** Return the length (number of bytes) of the argument. */ -external length: bytes => int = "%bytes_length" - -/** [get s n] returns the byte at index [n] in argument [s]. - - Raise [Invalid_argument] if [n] is not a valid index in [s]. */ -external get: (bytes, int) => char = "%bytes_safe_get" - -/** [set s n c] modifies [s] in place, replacing the byte at index [n] - with [c]. - - Raise [Invalid_argument] if [n] is not a valid index in [s]. */ -external set: (bytes, int, char) => unit = "%bytes_safe_set" - -/** [create n] returns a new byte sequence of length [n]. The - sequence is uninitialized and contains arbitrary bytes. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -external create: int => bytes = "?create_bytes" - -/** [make n c] returns a new byte sequence of length [n], filled with - the byte [c]. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -let make: (int, char) => bytes - -/** [init n f] returns a fresh byte sequence of length [n], - with character [i] initialized to the result of [f i]. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -let init: (int, ~f: int => char) => bytes - -/** A byte sequence of size 0. */ -let empty: bytes - -/** Return a new byte sequence that contains the same bytes as the - argument. */ -let copy: bytes => bytes - -/** Return a new byte sequence that contains the same bytes as the - given string. */ -let of_string: string => bytes - -/** Return a new string that contains the same bytes as the given byte - sequence. */ -let to_string: bytes => string - -/** [sub s start len] returns a new byte sequence of length [len], - containing the subsequence of [s] that starts at position [start] - and has length [len]. - - Raise [Invalid_argument] if [start] and [len] do not designate a - valid range of [s]. */ -let sub: (bytes, ~pos: int, ~len: int) => bytes - -/** Same as [sub] but return a string instead of a byte sequence. */ -let sub_string: (bytes, ~pos: int, ~len: int) => string - -/** [extend s left right] returns a new byte sequence that contains - the bytes of [s], with [left] uninitialized bytes prepended and - [right] uninitialized bytes appended to it. If [left] or [right] - is negative, then bytes are removed (instead of appended) from - the corresponding side of [s]. - - Raise [Invalid_argument] if the result length is negative or - longer than {!Sys.max_string_length} bytes. - @since 4.05.0 */ -let extend: (bytes, ~left: int, ~right: int) => bytes - -/** [fill s start len c] modifies [s] in place, replacing [len] - characters with [c], starting at [start]. - - Raise [Invalid_argument] if [start] and [len] do not designate a - valid range of [s]. */ -let fill: (bytes, ~pos: int, ~len: int, char) => unit - -/** [blit src srcoff dst dstoff len] copies [len] bytes from sequence - [src], starting at index [srcoff], to sequence [dst], starting at - index [dstoff]. It works correctly even if [src] and [dst] are the - same byte sequence, and the source and destination intervals - overlap. - - Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid range of [src], or if [dstoff] and [len] - do not designate a valid range of [dst]. */ -let blit: (~src: bytes, ~src_pos: int, ~dst: bytes, ~dst_pos: int, ~len: int) => unit - -/** [blit src srcoff dst dstoff len] copies [len] bytes from string - [src], starting at index [srcoff], to byte sequence [dst], - starting at index [dstoff]. - - Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid range of [src], or if [dstoff] and [len] - do not designate a valid range of [dst]. - @since 4.05.0 */ -let blit_string: (~src: string, ~src_pos: int, ~dst: bytes, ~dst_pos: int, ~len: int) => unit - -/** [concat sep sl] concatenates the list of byte sequences [sl], - inserting the separator byte sequence [sep] between each, and - returns the result as a new byte sequence. */ -let concat: (~sep: bytes, list) => bytes - -/** [cat s1 s2] concatenates [s1] and [s2] and returns the result - as new byte sequence. - - Raise [Invalid_argument] if the result is longer than - {!Sys.max_string_length} bytes. - @since 4.05.0 */ -let cat: (bytes, bytes) => bytes - -/** [iter f s] applies function [f] in turn to all the bytes of [s]. - It is equivalent to [f (get s 0); f (get s 1); ...; f (get s - (length s - 1)); ()]. */ -let iter: (~f: char => unit, bytes) => unit - -/** Same as {!Bytes.iter}, but the function is applied to the index of - the byte as first argument and the byte itself as second - argument. */ -let iteri: (~f: (int, char) => unit, bytes) => unit - -/** [map f s] applies function [f] in turn to all the bytes of [s] and - stores the resulting bytes in a new sequence that is returned as - the result. */ -let map: (~f: char => char, bytes) => bytes - -/** [mapi f s] calls [f] with each character of [s] and its - index (in increasing index order) and stores the resulting bytes - in a new sequence that is returned as the result. */ -let mapi: (~f: (int, char) => char, bytes) => bytes - -/** Return a copy of the argument, without leading and trailing - whitespace. The bytes regarded as whitespace are the ASCII - characters [' '], ['\x0c'], ['\n'], ['\r'], and ['\t']. */ -let trim: bytes => bytes - -/** Return a copy of the argument, with special characters represented - by escape sequences, following the lexical conventions of OCaml. */ -let escaped: bytes => bytes - -/** [index s c] returns the index of the first occurrence of byte [c] - in [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let index: (bytes, char) => int - -/** [index_opt s c] returns the index of the first occurrence of byte [c] - in [s] or [None] if [c] does not occur in [s]. - @since 4.05 */ -let index_opt: (bytes, char) => option - -/** [rindex s c] returns the index of the last occurrence of byte [c] - in [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let rindex: (bytes, char) => int - -/** [rindex_opt s c] returns the index of the last occurrence of byte [c] - in [s] or [None] if [c] does not occur in [s]. - @since 4.05 */ -let rindex_opt: (bytes, char) => option - -/** [index_from s i c] returns the index of the first occurrence of - byte [c] in [s] after position [i]. [Bytes.index s c] is - equivalent to [Bytes.index_from s 0 c]. - - Raise [Invalid_argument] if [i] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] after position [i]. */ -let index_from: (bytes, int, char) => int - -/** [index_from _opts i c] returns the index of the first occurrence of - byte [c] in [s] after position [i] or [None] if [c] does not occur in [s] after position [i]. - [Bytes.index_opt s c] is equivalent to [Bytes.index_from_opt s 0 c]. - - Raise [Invalid_argument] if [i] is not a valid position in [s]. - @since 4.05 */ -let index_from_opt: (bytes, int, char) => option - -/** [rindex_from s i c] returns the index of the last occurrence of - byte [c] in [s] before position [i+1]. [rindex s c] is equivalent - to [rindex_from s (Bytes.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] before position [i+1]. */ -let rindex_from: (bytes, int, char) => int - -/** [rindex_from_opt s i c] returns the index of the last occurrence - of byte [c] in [s] before position [i+1] or [None] if [c] does not - occur in [s] before position [i+1]. [rindex_opt s c] is equivalent to - [rindex_from s (Bytes.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - @since 4.05 */ -let rindex_from_opt: (bytes, int, char) => option - -/** [contains s c] tests if byte [c] appears in [s]. */ -let contains: (bytes, char) => bool - -/** [contains_from s start c] tests if byte [c] appears in [s] after - position [start]. [contains s c] is equivalent to [contains_from - s 0 c]. - - Raise [Invalid_argument] if [start] is not a valid position in [s]. */ -let contains_from: (bytes, int, char) => bool - -/** [rcontains_from s stop c] tests if byte [c] appears in [s] before - position [stop+1]. - - Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid - position in [s]. */ -let rcontains_from: (bytes, int, char) => bool - -/** Return a copy of the argument, with all lowercase letters - translated to uppercase, using the US-ASCII character set. - @since 4.05.0 */ -let uppercase_ascii: bytes => bytes - -/** Return a copy of the argument, with all uppercase letters - translated to lowercase, using the US-ASCII character set. - @since 4.05.0 */ -let lowercase_ascii: bytes => bytes - -/** Return a copy of the argument, with the first character set to uppercase, - using the US-ASCII character set. - @since 4.05.0 */ -let capitalize_ascii: bytes => bytes - -/** Return a copy of the argument, with the first character set to lowercase, - using the US-ASCII character set. - @since 4.05.0 */ -let uncapitalize_ascii: bytes => bytes - -/** An alias for the type of byte sequences. */ -type t = bytes - -/** The comparison function for byte sequences, with the same - specification as {!Pervasives.compare}. Along with the type [t], - this function [compare] allows the module [Bytes] to be passed as - argument to the functors {!Set.Make} and {!Map.Make}. */ -let compare: (t, t) => int - -/** The equality function for byte sequences. - @since 4.05.0 */ -let equal: (t, t) => bool - -/* The following is for system use only. Do not call directly. */ - -external unsafe_get: (bytes, int) => char = "%bytes_unsafe_get" -external unsafe_set: (bytes, int, char) => unit = "%bytes_unsafe_set" -let unsafe_to_string: bytes => string -let unsafe_of_string: string => bytes diff --git a/jscomp/stdlib-406/callback.res b/jscomp/stdlib-406/callback.res deleted file mode 100644 index 6637889..0000000 --- a/jscomp/stdlib-406/callback.res +++ /dev/null @@ -1,19 +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"]}) -/* Registering OCaml values with the C runtime for later callbacks */ - -let register = (_, _) => () -let register_exception = (_, _) => () diff --git a/jscomp/stdlib-406/callback.resi b/jscomp/stdlib-406/callback.resi deleted file mode 100644 index bff7283..0000000 --- a/jscomp/stdlib-406/callback.resi +++ /dev/null @@ -1,34 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Registering OCaml values with the C runtime. - - This module allows OCaml values to be registered with the C runtime - under a symbolic name, so that C code can later call back registered - OCaml functions, or raise registered OCaml exceptions. -*/ - -/** [Callback.register n v] registers the value [v] under - the name [n]. C code can later retrieve a handle to [v] - by calling [caml_named_value(n)]. */ -let register: (string, 'a) => unit - -/** [Callback.register_exception n exn] registers the - exception contained in the exception value [exn] - under the name [n]. C code can later retrieve a handle to - the exception by calling [caml_named_value(n)]. The exception - value thus obtained is suitable for passing as first argument - to [raise_constant] or [raise_with_arg]. */ -let register_exception: (string, exn) => unit diff --git a/jscomp/stdlib-406/camlinternalLazy.res b/jscomp/stdlib-406/camlinternalLazy.res deleted file mode 100644 index e372785..0000000 --- a/jscomp/stdlib-406/camlinternalLazy.res +++ /dev/null @@ -1,92 +0,0 @@ -/* Copyright (C) 2017 Hongbo Zhang, Authors of ReScript - * - * This program is free software: you can redistribute it and/or modify - * it under the terms of the GNU Lesser General Public License as published by - * the Free Software Foundation, either version 3 of the License, or - * (at your option) any later version. - * - * In addition to the permissions granted to you by the LGPL, you may combine - * or link a "work that uses the Library" with a publicly distributed version - * of this file to produce a combined library or application, then distribute - * that combined work under the terms of your choosing, with no requirement - * to comply with the obligations normally placed on you by section 4 of the - * LGPL version 3 (or the corresponding section of a later version of the LGPL - * should you choose to use a later version). - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public License - * along with this program; if not, write to the Free Software - * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ - -@@bs.config({flags: ["-bs-no-cross-module-opt"]}) - -/* Internals of forcing lazy values. */ -type t<'a> = { - @as("LAZY_DONE") mutable tag: bool, - /* Invariant: name */ - @as("VAL") mutable value: 'a, - /* its type is ['a] or [unit -> 'a ] */ -} - -%%private(external fnToVal: ((. unit) => 'a) => 'a = "%identity") -%%private(external valToFn: 'a => (. unit) => 'a = "%identity") -%%private(external castToConcrete: lazy_t<'a> => t<'a> = "%identity") - -let is_val = (type a, l: lazy_t): bool => castToConcrete(l).tag - -exception Undefined - -%%private( - let forward_with_closure = (type a, blk: t, closure: (. unit) => a): a => { - let result = closure(.) - blk.value = result - blk.tag = true - result - } -) - -%%private(let raise_undefined = (. ()) => raise(Undefined)) - -/* Assume [blk] is a block with tag lazy */ -%%private( - let force_lazy_block = (type a, blk: t): a => { - let closure = valToFn(blk.value) - blk.value = fnToVal(raise_undefined) - try forward_with_closure(blk, closure) catch { - | e => - blk.value = fnToVal((. ()) => raise(e)) - raise(e) - } - } -) - -/* Assume [blk] is a block with tag lazy */ -%%private( - let force_val_lazy_block = (type a, blk: t): a => { - let closure = valToFn(blk.value) - blk.value = fnToVal(raise_undefined) - forward_with_closure(blk, closure) - } -) - -let force = (type a, lzv: lazy_t): a => { - let lzv: t<_> = castToConcrete(lzv) - if lzv.tag { - lzv.value - } else { - force_lazy_block(lzv) - } -} - -let force_val = (type a, lzv: lazy_t): a => { - let lzv: t<_> = castToConcrete(lzv) - if lzv.tag { - lzv.value - } else { - force_val_lazy_block(lzv) - } -} diff --git a/jscomp/stdlib-406/camlinternalLazy.resi b/jscomp/stdlib-406/camlinternalLazy.resi deleted file mode 100644 index 82e0be3..0000000 --- a/jscomp/stdlib-406/camlinternalLazy.resi +++ /dev/null @@ -1,27 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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. */ -/* */ -/* ************************************************************************ */ - -/*** Run-time support for lazy values. - All functions in this module are for system use only, not for the - casual user. */ - -exception Undefined - -let force: lazy_t<'a> => 'a -/* instrumented by {!Matching} */ - -let force_val: lazy_t<'a> => 'a - -let is_val: lazy_t<'a> => bool diff --git a/jscomp/stdlib-406/camlinternalMod.res b/jscomp/stdlib-406/camlinternalMod.res deleted file mode 100644 index 3bf65c6..0000000 --- a/jscomp/stdlib-406/camlinternalMod.res +++ /dev/null @@ -1,21 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2004 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 rec shape = - | Function - | Lazy - | Class - | Module(array) - | Value(Obj.t) diff --git a/jscomp/stdlib-406/camlinternalMod.resi b/jscomp/stdlib-406/camlinternalMod.resi deleted file mode 100644 index e5529a4..0000000 --- a/jscomp/stdlib-406/camlinternalMod.resi +++ /dev/null @@ -1,25 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2004 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. */ -/* */ -/* ************************************************************************ */ - -/*** Run-time support for recursive modules. - All functions in this module are for system use only, not for the - casual user. */ - -type rec shape = - | Function - | Lazy - | Class - | Module(array) - | Value(Obj.t) diff --git a/jscomp/stdlib-406/char.res b/jscomp/stdlib-406/char.res deleted file mode 100644 index afc28ae..0000000 --- a/jscomp/stdlib-406/char.res +++ /dev/null @@ -1,85 +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. */ -/* */ -/* ************************************************************************ */ - -/* Character operations */ - -external code: char => int = "%identity" -external unsafe_chr: int => char = "%identity" - -let chr = n => - if n < 0 || n > 255 { - invalid_arg("Char.chr") - } else { - unsafe_chr(n) - } - -external bytes_create: int => bytes = "?create_bytes" -external bytes_unsafe_set: (bytes, int, char) => unit = "%bytes_unsafe_set" -external unsafe_to_string: bytes => string = "%bytes_to_string" - -let escaped = param => - switch param { - | '\'' => "\\'" - | '\\' => "\\\\" - | '\n' => "\\n" - | '\t' => "\\t" - | '\r' => "\\r" - | '\b' => "\\b" - | ' ' .. '~' as c => - let s = bytes_create(1) - bytes_unsafe_set(s, 0, c) - unsafe_to_string(s) - | c => - let n = code(c) - let s = bytes_create(4) - bytes_unsafe_set(s, 0, '\\') - bytes_unsafe_set(s, 1, unsafe_chr(48 + n / 100)) - bytes_unsafe_set(s, 2, unsafe_chr(48 + mod(n / 10, 10))) - bytes_unsafe_set(s, 3, unsafe_chr(48 + mod(n, 10))) - unsafe_to_string(s) - } - -let lowercase = c => - if (c >= 'A' && c <= 'Z') || ((c >= 'À' && c <= 'Ö') || c >= 'Ø' && c <= 'Þ') { - unsafe_chr(code(c) + 32) - } else { - c - } - -let uppercase = c => - if (c >= 'a' && c <= 'z') || ((c >= 'à' && c <= 'ö') || c >= 'ø' && c <= 'þ') { - unsafe_chr(code(c) - 32) - } else { - c - } - -let lowercase_ascii = c => - if c >= 'A' && c <= 'Z' { - unsafe_chr(code(c) + 32) - } else { - c - } - -let uppercase_ascii = c => - if c >= 'a' && c <= 'z' { - unsafe_chr(code(c) - 32) - } else { - c - } - -type t = char - -let compare = (c1, c2) => code(c1) - code(c2) -let equal = (c1: t, c2: t) => compare(c1, c2) == 0 diff --git a/jscomp/stdlib-406/char.resi b/jscomp/stdlib-406/char.resi deleted file mode 100644 index 78e07aa..0000000 --- a/jscomp/stdlib-406/char.resi +++ /dev/null @@ -1,70 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Character operations. */ - -/** Return the ASCII code of the argument. */ -external code: char => int = "%identity" - -/** Return the character with the given ASCII code. - Raise [Invalid_argument "Char.chr"] if the argument is - outside the range 0--255. */ -let chr: int => char - -/** Return a string representing the given character, - with special characters escaped following the lexical conventions - of OCaml. - All characters outside the ASCII printable range (32..126) are - escaped, as well as backslash, double-quote, and single-quote. */ -let escaped: char => string - -@deprecated("Use Char.lowercase_ascii instead.") -/** Convert the given character to its equivalent lowercase character, - using the ISO Latin-1 (8859-1) character set. - @deprecated Functions operating on Latin-1 character set are deprecated. */ -let lowercase: char => char - -@deprecated("Use Char.uppercase_ascii instead.") -/** Convert the given character to its equivalent uppercase character, - using the ISO Latin-1 (8859-1) character set. - @deprecated Functions operating on Latin-1 character set are deprecated. */ -let uppercase: char => char - -/** Convert the given character to its equivalent lowercase character, - using the US-ASCII character set. - @since 4.03.0 */ -let lowercase_ascii: char => char - -/** Convert the given character to its equivalent uppercase character, - using the US-ASCII character set. - @since 4.03.0 */ -let uppercase_ascii: char => char - -/** An alias for the type of characters. */ -type t = char - -/** The comparison function for characters, with the same specification as - {!Pervasives.compare}. Along with the type [t], this function [compare] - allows the module [Char] to be passed as argument to the functors - {!Set.Make} and {!Map.Make}. */ -let compare: (t, t) => int - -/** The equal function for chars. - @since 4.03.0 */ -let equal: (t, t) => bool - -/* The following is for system use only. Do not call directly. */ - -external unsafe_chr: int => char = "%identity" diff --git a/jscomp/stdlib-406/complex.res b/jscomp/stdlib-406/complex.res deleted file mode 100644 index 4b05610..0000000 --- a/jscomp/stdlib-406/complex.res +++ /dev/null @@ -1,112 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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. */ -/* */ -/* ************************************************************************ */ - -/* Complex numbers */ - -type t = {re: float, im: float} - -let zero = {re: 0.0, im: 0.0} -let one = {re: 1.0, im: 0.0} -let i = {re: 0.0, im: 1.0} - -let add = (x, y) => {re: x.re +. y.re, im: x.im +. y.im} - -let sub = (x, y) => {re: x.re -. y.re, im: x.im -. y.im} - -let neg = x => {re: -.x.re, im: -.x.im} - -let conj = x => {re: x.re, im: -.x.im} - -let mul = (x, y) => { - re: x.re *. y.re -. x.im *. y.im, - im: x.re *. y.im +. x.im *. y.re, -} - -let div = (x, y) => - if abs_float(y.re) >= abs_float(y.im) { - let r = y.im /. y.re - let d = y.re +. r *. y.im - { - re: (x.re +. r *. x.im) /. d, - im: (x.im -. r *. x.re) /. d, - } - } else { - let r = y.re /. y.im - let d = y.im +. r *. y.re - { - re: (r *. x.re +. x.im) /. d, - im: (r *. x.im -. x.re) /. d, - } - } - -let inv = x => div(one, x) - -let norm2 = x => x.re *. x.re +. x.im *. x.im - -let norm = x => { - /* Watch out for overflow in computing re^2 + im^2 */ - let r = abs_float(x.re) - and i = abs_float(x.im) - if r == 0.0 { - i - } else if i == 0.0 { - r - } else if r >= i { - let q = i /. r - r *. sqrt(1.0 +. q *. q) - } else { - let q = r /. i - i *. sqrt(1.0 +. q *. q) - } -} - -let arg = x => atan2(x.im, x.re) - -let polar = (n, a) => {re: cos(a) *. n, im: sin(a) *. n} - -let sqrt = x => - if x.re == 0.0 && x.im == 0.0 { - {re: 0.0, im: 0.0} - } else { - let r = abs_float(x.re) and i = abs_float(x.im) - let w = if r >= i { - let q = i /. r - sqrt(r) *. sqrt(0.5 *. (1.0 +. sqrt(1.0 +. q *. q))) - } else { - let q = r /. i - sqrt(i) *. sqrt(0.5 *. (q +. sqrt(1.0 +. q *. q))) - } - if x.re >= 0.0 { - {re: w, im: 0.5 *. x.im /. w} - } else { - { - re: 0.5 *. i /. w, - im: if x.im >= 0.0 { - w - } else { - -.w - }, - } - } - } - -let exp = x => { - let e = exp(x.re) - {re: e *. cos(x.im), im: e *. sin(x.im)} -} - -let log = x => {re: log(norm(x)), im: atan2(x.im, x.re)} - -let pow = (x, y) => exp(mul(y, log(x))) diff --git a/jscomp/stdlib-406/complex.resi b/jscomp/stdlib-406/complex.resi deleted file mode 100644 index bacdc47..0000000 --- a/jscomp/stdlib-406/complex.resi +++ /dev/null @@ -1,86 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 2002 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. */ -/* */ -/* ************************************************************************ */ - -/*** Complex numbers. - - This module provides arithmetic operations on complex numbers. - Complex numbers are represented by their real and imaginary parts - (cartesian representation). Each part is represented by a - double-precision floating-point number (type [float]). */ - -/** The type of complex numbers. [re] is the real part and [im] the - imaginary part. */ -type t = {re: float, im: float} - -/** The complex number [0]. */ -let zero: t - -/** The complex number [1]. */ -let one: t - -/** The complex number [i]. */ -let i: t - -/** Unary negation. */ -let neg: t => t - -/** Conjugate: given the complex [x + i.y], returns [x - i.y]. */ -let conj: t => t - -/** Addition */ -let add: (t, t) => t - -/** Subtraction */ -let sub: (t, t) => t - -/** Multiplication */ -let mul: (t, t) => t - -/** Multiplicative inverse ([1/z]). */ -let inv: t => t - -/** Division */ -let div: (t, t) => t - -/** Square root. The result [x + i.y] is such that [x > 0] or - [x = 0] and [y >= 0]. - This function has a discontinuity along the negative real axis. */ -let sqrt: t => t - -/** Norm squared: given [x + i.y], returns [x^2 + y^2]. */ -let norm2: t => float - -/** Norm: given [x + i.y], returns [sqrt(x^2 + y^2)]. */ -let norm: t => float - -/** Argument. The argument of a complex number is the angle - in the complex plane between the positive real axis and a line - passing through zero and the number. This angle ranges from - [-pi] to [pi]. This function has a discontinuity along the - negative real axis. */ -let arg: t => float - -/** [polar norm arg] returns the complex having norm [norm] - and argument [arg]. */ -let polar: (float, float) => t - -/** Exponentiation. [exp z] returns [e] to the [z] power. */ -let exp: t => t - -/** Natural logarithm (in base [e]). */ -let log: t => t - -/** Power function. [pow z1 z2] returns [z1] to the [z2] power. */ -let pow: (t, t) => t diff --git a/jscomp/stdlib-406/digest.res b/jscomp/stdlib-406/digest.res deleted file mode 100644 index d922290..0000000 --- a/jscomp/stdlib-406/digest.res +++ /dev/null @@ -1,78 +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. */ -/* */ -/* ************************************************************************ */ - -/* Message digest (MD5) */ - -type t = string - -let compare = String.compare -let equal = String.equal - -external unsafe_string: (string, int, int) => t = "?md5_string" - -let string = str => unsafe_string(str, 0, String.length(str)) - -let bytes = b => string(Bytes.unsafe_to_string(b)) - -let substring = (str, ofs, len) => - if ofs < 0 || (len < 0 || ofs > String.length(str) - len) { - invalid_arg("Digest.substring") - } else { - unsafe_string(str, ofs, len) - } - -let subbytes = (b, ofs, len) => substring(Bytes.unsafe_to_string(b), ofs, len) - -let char_hex = n => - Char.unsafe_chr( - n + if n < 10 { - Char.code('0') - } else { - Char.code('a') - 10 - }, - ) - -let to_hex = d => { - if String.length(d) != 16 { - invalid_arg("Digest.to_hex") - } - let result = Bytes.create(32) - for i in 0 to 15 { - let x = Char.code(String.get(d, i)) - Bytes.unsafe_set(result, i * 2, char_hex(lsr(x, 4))) - Bytes.unsafe_set(result, i * 2 + 1, char_hex(land(x, 0x0f))) - } - Bytes.unsafe_to_string(result) -} - -let from_hex = s => { - if String.length(s) != 32 { - invalid_arg("Digest.from_hex") - } - let digit = c => - switch c { - | '0' .. '9' => Char.code(c) - Char.code('0') - | 'A' .. 'F' => Char.code(c) - Char.code('A') + 10 - | 'a' .. 'f' => Char.code(c) - Char.code('a') + 10 - | _ => raise(Invalid_argument("Digest.from_hex")) - } - - let byte = i => lsl(digit(String.get(s, i)), 4) + digit(String.get(s, i + 1)) - let result = Bytes.create(16) - for i in 0 to 15 { - Bytes.set(result, i, Char.chr(byte(2 * i))) - } - Bytes.unsafe_to_string(result) -} diff --git a/jscomp/stdlib-406/digest.resi b/jscomp/stdlib-406/digest.resi deleted file mode 100644 index bcedb52..0000000 --- a/jscomp/stdlib-406/digest.resi +++ /dev/null @@ -1,67 +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. */ -/* */ -/* ************************************************************************ */ - -/*** MD5 message digest. - - This module provides functions to compute 128-bit 'digests' of - arbitrary-length strings or files. The digests are of cryptographic - quality: it is very hard, given a digest, to forge a string having - that digest. The algorithm used is MD5. This module should not be - used for secure and sensitive cryptographic applications. For these - kind of applications more recent and stronger cryptographic - primitives should be used instead. -*/ - -/** The type of digests: 16-character strings. */ -type t = string - -/** The comparison function for 16-character digest, with the same - specification as {!Pervasives.compare} and the implementation - shared with {!String.compare}. Along with the type [t], this - function [compare] allows the module [Digest] to be passed as - argument to the functors {!Set.Make} and {!Map.Make}. - @since 4.00.0 */ -let compare: (t, t) => int - -/** The equal function for 16-character digest. - @since 4.03.0 */ -let equal: (t, t) => bool - -/** Return the digest of the given string. */ -let string: string => t - -/** Return the digest of the given byte sequence. - @since 4.02.0 */ -let bytes: bytes => t - -/** [Digest.substring s ofs len] returns the digest of the substring - of [s] starting at index [ofs] and containing [len] characters. */ -let substring: (string, int, int) => t - -/** [Digest.subbytes s ofs len] returns the digest of the subsequence - of [s] starting at index [ofs] and containing [len] bytes. - @since 4.02.0 */ -let subbytes: (bytes, int, int) => t - -/** Return the printable hexadecimal representation of the given digest. - Raise [Invalid_argument] if the argument is not exactly 16 bytes. - */ -let to_hex: t => string - -/** Convert a hexadecimal representation back into the corresponding digest. - Raise [Invalid_argument] if the argument is not exactly 32 hexadecimal - characters. - @since 4.00.0 */ -let from_hex: string => t diff --git a/jscomp/stdlib-406/filename.res b/jscomp/stdlib-406/filename.res deleted file mode 100644 index 0dcb014..0000000 --- a/jscomp/stdlib-406/filename.res +++ /dev/null @@ -1,353 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, 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. */ -/* */ -/* ************************************************************************ */ - -let generic_quote = (quotequote, s) => { - let l = String.length(s) - let b = Buffer.create(l + 20) - Buffer.add_char(b, '\'') - for i in 0 to l - 1 { - if String.get(s, i) == '\'' { - Buffer.add_string(b, quotequote) - } else { - Buffer.add_char(b, String.get(s, i)) - } - } - Buffer.add_char(b, '\'') - Buffer.contents(b) -} - -/* This function implements the Open Group specification found here: - [[1]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/basename.html - In step 1 of [[1]], we choose to return "." for empty input. - (for compatibility with previous versions of OCaml) - In step 2, we choose to process "//" normally. - Step 6 is not implemented: we consider that the [suffix] operand is - always absent. Suffixes are handled by [chop_suffix] and [chop_extension]. -*/ -let generic_basename = (is_dir_sep, current_dir_name, name) => { - let rec find_end = n => - if n < 0 { - String.sub(name, 0, 1) - } else if is_dir_sep(name, n) { - find_end(n - 1) - } else { - find_beg(n, n + 1) - } - and find_beg = (n, p) => - if n < 0 { - String.sub(name, 0, p) - } else if is_dir_sep(name, n) { - String.sub(name, n + 1, p - n - 1) - } else { - find_beg(n - 1, p) - } - - if name == "" { - current_dir_name - } else { - find_end(String.length(name) - 1) - } -} - -/* This function implements the Open Group specification found here: - [[2]] http://pubs.opengroup.org/onlinepubs/9699919799/utilities/dirname.html - In step 6 of [[2]], we choose to process "//" normally. -*/ -let generic_dirname = (is_dir_sep, current_dir_name, name) => { - let rec trailing_sep = n => - if n < 0 { - String.sub(name, 0, 1) - } else if is_dir_sep(name, n) { - trailing_sep(n - 1) - } else { - base(n) - } - and base = n => - if n < 0 { - current_dir_name - } else if is_dir_sep(name, n) { - intermediate_sep(n) - } else { - base(n - 1) - } - and intermediate_sep = n => - if n < 0 { - String.sub(name, 0, 1) - } else if is_dir_sep(name, n) { - intermediate_sep(n - 1) - } else { - String.sub(name, 0, n + 1) - } - - if name == "" { - current_dir_name - } else { - trailing_sep(String.length(name) - 1) - } -} - -module Unix = { - let current_dir_name = "." - let parent_dir_name = ".." - let dir_sep = "/" - let is_dir_sep = (s, i) => String.get(s, i) == '/' - let is_relative = n => String.length(n) < 1 || String.get(n, 0) != '/' - let is_implicit = n => - is_relative(n) && - ((String.length(n) < 2 || String.sub(n, 0, 2) != "./") && - (String.length(n) < 3 || String.sub(n, 0, 3) != "../")) - let check_suffix = (name, suff) => - String.length(name) >= String.length(suff) && - String.sub(name, String.length(name) - String.length(suff), String.length(suff)) == suff - let temp_dir_name = try Sys.getenv("TMPDIR") catch { - | Not_found => "/tmp" - } - let quote = generic_quote("'\\''") - let basename = generic_basename(is_dir_sep, current_dir_name) - let dirname = generic_dirname(is_dir_sep, current_dir_name) -} - -module Win32 = { - let current_dir_name = "." - let parent_dir_name = ".." - let dir_sep = "\\" - let is_dir_sep = (s, i) => { - let c = String.get(s, i) - c == '/' || (c == '\\' || c == ':') - } - let is_relative = n => - (String.length(n) < 1 || String.get(n, 0) != '/') && - ((String.length(n) < 1 || String.get(n, 0) != '\\') && - (String.length(n) < 2 || String.get(n, 1) != ':')) - let is_implicit = n => - is_relative(n) && - ((String.length(n) < 2 || String.sub(n, 0, 2) != "./") && - ((String.length(n) < 2 || String.sub(n, 0, 2) != ".\\") && - ((String.length(n) < 3 || String.sub(n, 0, 3) != "../") && - (String.length(n) < 3 || String.sub(n, 0, 3) != "..\\")))) - let check_suffix = (name, suff) => - String.length(name) >= String.length(suff) && { - let s = String.sub(name, String.length(name) - String.length(suff), String.length(suff)) - String.lowercase_ascii(s) == String.lowercase_ascii(suff) - } - let temp_dir_name = try Sys.getenv("TEMP") catch { - | Not_found => "." - } - let quote = s => { - let l = String.length(s) - let b = Buffer.create(l + 20) - Buffer.add_char(b, '"') - let rec loop = i => - if i == l { - Buffer.add_char(b, '"') - } else { - switch String.get(s, i) { - | '"' => loop_bs(0, i) - | '\\' => loop_bs(0, i) - | c => - Buffer.add_char(b, c) - loop(i + 1) - } - } - and loop_bs = (n, i) => - if i == l { - Buffer.add_char(b, '"') - add_bs(n) - } else { - switch String.get(s, i) { - | '"' => - add_bs(2 * n + 1) - Buffer.add_char(b, '"') - loop(i + 1) - | '\\' => loop_bs(n + 1, i + 1) - | _ => - add_bs(n) - loop(i) - } - } - and add_bs = n => - for _j in 1 to n { - Buffer.add_char(b, '\\') - } - - loop(0) - Buffer.contents(b) - } - let has_drive = s => { - let is_letter = param => - switch param { - | 'A' .. 'Z' | 'a' .. 'z' => true - | _ => false - } - - String.length(s) >= 2 && (is_letter(String.get(s, 0)) && String.get(s, 1) == ':') - } - let drive_and_path = s => - if has_drive(s) { - (String.sub(s, 0, 2), String.sub(s, 2, String.length(s) - 2)) - } else { - ("", s) - } - let dirname = s => { - let (drive, path) = drive_and_path(s) - let dir = generic_dirname(is_dir_sep, current_dir_name, path) - drive ++ dir - } - let basename = s => { - let (_drive, path) = drive_and_path(s) - generic_basename(is_dir_sep, current_dir_name, path) - } -} - -module Cygwin = { - let current_dir_name = "." - let parent_dir_name = ".." - let dir_sep = "/" - let is_dir_sep = Win32.is_dir_sep - let is_relative = Win32.is_relative - let is_implicit = Win32.is_implicit - let check_suffix = Win32.check_suffix - let temp_dir_name = Unix.temp_dir_name - let quote = Unix.quote - let basename = generic_basename(is_dir_sep, current_dir_name) - let dirname = generic_dirname(is_dir_sep, current_dir_name) -} - -let ( - current_dir_name, - parent_dir_name, - dir_sep, - is_dir_sep, - is_relative, - is_implicit, - check_suffix, - temp_dir_name, - quote, - basename, - dirname, -) = switch Sys.os_type { -| "Win32" => ( - Win32.current_dir_name, - Win32.parent_dir_name, - Win32.dir_sep, - Win32.is_dir_sep, - Win32.is_relative, - Win32.is_implicit, - Win32.check_suffix, - Win32.temp_dir_name, - Win32.quote, - Win32.basename, - Win32.dirname, - ) -| "Cygwin" => ( - Cygwin.current_dir_name, - Cygwin.parent_dir_name, - Cygwin.dir_sep, - Cygwin.is_dir_sep, - Cygwin.is_relative, - Cygwin.is_implicit, - Cygwin.check_suffix, - Cygwin.temp_dir_name, - Cygwin.quote, - Cygwin.basename, - Cygwin.dirname, - ) -| _ => /* normally "Unix" */ - ( - Unix.current_dir_name, - Unix.parent_dir_name, - Unix.dir_sep, - Unix.is_dir_sep, - Unix.is_relative, - Unix.is_implicit, - Unix.check_suffix, - Unix.temp_dir_name, - Unix.quote, - Unix.basename, - Unix.dirname, - ) -} - -let concat = (dirname, filename) => { - let l = String.length(dirname) - if l == 0 || is_dir_sep(dirname, l - 1) { - dirname ++ filename - } else { - dirname ++ (dir_sep ++ filename) - } -} - -let chop_suffix = (name, suff) => { - let n = String.length(name) - String.length(suff) - if n < 0 { - invalid_arg("Filename.chop_suffix") - } else { - String.sub(name, 0, n) - } -} - -let extension_len = name => { - let rec check = (i0, i) => - if i < 0 || is_dir_sep(name, i) { - 0 - } else if String.get(name, i) == '.' { - check(i0, i - 1) - } else { - String.length(name) - i0 - } - - let rec search_dot = i => - if i < 0 || is_dir_sep(name, i) { - 0 - } else if String.get(name, i) == '.' { - check(i, i - 1) - } else { - search_dot(i - 1) - } - - search_dot(String.length(name) - 1) -} - -let extension = name => { - let l = extension_len(name) - if l == 0 { - "" - } else { - String.sub(name, String.length(name) - l, l) - } -} - -let chop_extension = name => { - let l = extension_len(name) - if l == 0 { - invalid_arg("Filename.chop_extension") - } else { - String.sub(name, 0, String.length(name) - l) - } -} - -let remove_extension = name => { - let l = extension_len(name) - if l == 0 { - name - } else { - String.sub(name, 0, String.length(name) - l) - } -} - -let current_temp_dir_name = ref(temp_dir_name) - -let set_temp_dir_name = s => current_temp_dir_name := s -let get_temp_dir_name = () => current_temp_dir_name.contents diff --git a/jscomp/stdlib-406/filename.resi b/jscomp/stdlib-406/filename.resi deleted file mode 100644 index e9da0f7..0000000 --- a/jscomp/stdlib-406/filename.resi +++ /dev/null @@ -1,132 +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. */ -/* */ -/* ************************************************************************ */ - -/* Operations on file names. */ - -/** The conventional name for the current directory (e.g. [.] in Unix). */ -let current_dir_name: string - -/** The conventional name for the parent of the current directory - (e.g. [..] in Unix). */ -let parent_dir_name: string - -/** The directory separator (e.g. [/] in Unix). @since 3.11.2 */ -let dir_sep: string - -/** [concat dir file] returns a file name that designates file - [file] in directory [dir]. */ -let concat: (string, string) => string - -/** Return [true] if the file name is relative to the current - directory, [false] if it is absolute (i.e. in Unix, starts - with [/]). */ -let is_relative: string => bool - -/** Return [true] if the file name is relative and does not start - with an explicit reference to the current directory ([./] or - [../] in Unix), [false] if it starts with an explicit reference - to the root directory or the current directory. */ -let is_implicit: string => bool - -/** [check_suffix name suff] returns [true] if the filename [name] - ends with the suffix [suff]. */ -let check_suffix: (string, string) => bool - -/** [chop_suffix name suff] removes the suffix [suff] from - the filename [name]. The behavior is undefined if [name] does not - end with the suffix [suff]. */ -let chop_suffix: (string, string) => string - -/** [extension name] is the shortest suffix [ext] of [name0] where: - - - [name0] is the longest suffix of [name] that does not - contain a directory separator; - - [ext] starts with a period; - - [ext] is preceded by at least one non-period character - in [name0]. - - If such a suffix does not exist, [extension name] is the empty - string. - - @since 4.04 -*/ -let extension: string => string - -/** Return the given file name without its extension, as defined - in {!Filename.extension}. If the extension is empty, the function - returns the given file name. - - The following invariant holds for any file name [s]: - - [remove_extension s ^ extension s = s] - - @since 4.04 -*/ -let remove_extension: string => string - -/** Same as {!Filename.remove_extension}, but raise [Invalid_argument] - if the given name has an empty extension. */ -let chop_extension: string => string - -/** Split a file name into directory name / base file name. - If [name] is a valid file name, then [concat (dirname name) (basename name)] - returns a file name which is equivalent to [name]. Moreover, - after setting the current directory to [dirname name] (with {!Sys.chdir}), - references to [basename name] (which is a relative file name) - designate the same file as [name] before the call to {!Sys.chdir}. - - This function conforms to the specification of POSIX.1-2008 for the - [basename] utility. */ -let basename: string => string - -/** See {!Filename.basename}. - This function conforms to the specification of POSIX.1-2008 for the - [dirname] utility. */ -let dirname: string => string - -/** The name of the temporary directory: - Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" - if the variable is not set. - Under Windows, the value of the [TEMP] environment variable, or "." - if the variable is not set. - The temporary directory can be changed with {!Filename.set_temp_dir_name}. - @since 4.00.0 -*/ -let get_temp_dir_name: unit => string - -/** Change the temporary directory returned by {!Filename.get_temp_dir_name} - and used by {!Filename.temp_file} and {!Filename.open_temp_file}. - @since 4.00.0 -*/ -let set_temp_dir_name: string => unit - -@deprecated("Use Filename.get_temp_dir_name instead") -/** The name of the initial temporary directory: - Under Unix, the value of the [TMPDIR] environment variable, or "/tmp" - if the variable is not set. - Under Windows, the value of the [TEMP] environment variable, or "." - if the variable is not set. - @deprecated You should use {!Filename.get_temp_dir_name} instead. - @since 3.09.1 -*/ -let temp_dir_name: string - -/** Return a quoted version of a file name, suitable for use as - one argument in a command line, escaping all meta-characters. - Warning: under Windows, the output is only suitable for use - with programs that follow the standard Windows quoting - conventions. - */ -let quote: string => string diff --git a/jscomp/stdlib-406/genlex.res b/jscomp/stdlib-406/genlex.res deleted file mode 100644 index bb6ef24..0000000 --- a/jscomp/stdlib-406/genlex.res +++ /dev/null @@ -1,353 +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. */ -/* */ -/* ************************************************************************ */ - -type token = - | Kwd(string) - | Ident(string) - | Int(int) - | Float(float) - | String(string) - | Char(char) - -/* The string buffering machinery */ - -let initial_buffer = Bytes.create(32) - -let buffer = ref(initial_buffer) -let bufpos = ref(0) - -let reset_buffer = () => { - buffer := initial_buffer - bufpos := 0 -} - -let store = c => { - if bufpos.contents >= Bytes.length(buffer.contents) { - let newbuffer = Bytes.create(2 * bufpos.contents) - Bytes.blit(buffer.contents, 0, newbuffer, 0, bufpos.contents) - buffer := newbuffer - } - Bytes.set(buffer.contents, bufpos.contents, c) - incr(bufpos) -} - -let get_string = () => { - let s = Bytes.sub_string(buffer.contents, 0, bufpos.contents) - buffer := initial_buffer - s -} - -/* The lexer */ - -let make_lexer = keywords => { - let kwd_table = Hashtbl.create(17) - List.iter(s => Hashtbl.add(kwd_table, s, Kwd(s)), keywords) - let ident_or_keyword = id => - try Hashtbl.find(kwd_table, id) catch { - | Not_found => Ident(id) - } - and keyword_or_error = c => { - let s = String.make(1, c) - try Hashtbl.find(kwd_table, s) catch { - | Not_found => raise(Stream.Error("Illegal character " ++ s)) - } - } - - let rec next_token = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some(' ' | '\n' | '\r' | '\t' | '' | ' ') => - Stream.junk(strm__) - next_token(strm__) - | Some(('A' .. 'Z' | 'a' .. 'z' | '_' | 'À' .. 'ÿ') as c) => - Stream.junk(strm__) - let s = strm__ - reset_buffer() - store(c) - ident(s) - | Some( - ('!' - | '%' - | '&' - | '$' - | '#' - | '+' - | '/' - | ':' - | '<' - | '=' - | '>' - | '?' - | '@' - | '\\' - | '~' - | '^' - | '|' - | '*') as c, - ) => - Stream.junk(strm__) - let s = strm__ - reset_buffer() - store(c) - ident2(s) - | Some('0' .. '9' as c) => - Stream.junk(strm__) - let s = strm__ - reset_buffer() - store(c) - number(s) - | Some('\'') => - Stream.junk(strm__) - let c = try char(strm__) catch { - | Stream.Failure => raise(Stream.Error("")) - } - - switch Stream.peek(strm__) { - | Some('\'') => - Stream.junk(strm__) - Some(Char(c)) - | _ => raise(Stream.Error("")) - } - | Some('"') => - Stream.junk(strm__) - let s = strm__ - reset_buffer() - Some(String(string(s))) - | Some('-') => - Stream.junk(strm__) - neg_number(strm__) - | Some('(') => - Stream.junk(strm__) - maybe_comment(strm__) - | Some(c) => - Stream.junk(strm__) - Some(keyword_or_error(c)) - | _ => None - } - and ident = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some(('A' .. 'Z' | 'a' .. 'z' | 'À' .. 'ÿ' | '0' .. '9' | '_' | '\'') as c) => - Stream.junk(strm__) - let s = strm__ - store(c) - ident(s) - | _ => Some(ident_or_keyword(get_string())) - } - and ident2 = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some( - ('!' - | '%' - | '&' - | '$' - | '#' - | '+' - | '-' - | '/' - | ':' - | '<' - | '=' - | '>' - | '?' - | '@' - | '\\' - | '~' - | '^' - | '|' - | '*') as c, - ) => - Stream.junk(strm__) - let s = strm__ - store(c) - ident2(s) - | _ => Some(ident_or_keyword(get_string())) - } - and neg_number = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('0' .. '9' as c) => - Stream.junk(strm__) - let s = strm__ - reset_buffer() - store('-') - store(c) - number(s) - | _ => - let s = strm__ - reset_buffer() - store('-') - ident2(s) - } - and number = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('0' .. '9' as c) => - Stream.junk(strm__) - let s = strm__ - store(c) - number(s) - | Some('.') => - Stream.junk(strm__) - let s = strm__ - store('.') - decimal_part(s) - | Some('e' | 'E') => - Stream.junk(strm__) - let s = strm__ - store('E') - exponent_part(s) - | _ => Some(Int(int_of_string(get_string()))) - } - and decimal_part = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('0' .. '9' as c) => - Stream.junk(strm__) - let s = strm__ - store(c) - decimal_part(s) - | Some('e' | 'E') => - Stream.junk(strm__) - let s = strm__ - store('E') - exponent_part(s) - | _ => Some(Float(float_of_string(get_string()))) - } - and exponent_part = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some(('+' | '-') as c) => - Stream.junk(strm__) - let s = strm__ - store(c) - end_exponent_part(s) - | _ => end_exponent_part(strm__) - } - and end_exponent_part = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('0' .. '9' as c) => - Stream.junk(strm__) - let s = strm__ - store(c) - end_exponent_part(s) - | _ => Some(Float(float_of_string(get_string()))) - } - and string = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('"') => - Stream.junk(strm__) - get_string() - | Some('\\') => - Stream.junk(strm__) - let c = try escape(strm__) catch { - | Stream.Failure => raise(Stream.Error("")) - } - - let s = strm__ - store(c) - string(s) - | Some(c) => - Stream.junk(strm__) - let s = strm__ - store(c) - string(s) - | _ => raise(Stream.Failure) - } - and char = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('\\') => - Stream.junk(strm__) - try escape(strm__) catch { - | Stream.Failure => raise(Stream.Error("")) - } - | Some(c) => - Stream.junk(strm__) - c - | _ => raise(Stream.Failure) - } - and escape = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('n') => - Stream.junk(strm__) - '\n' - | Some('r') => - Stream.junk(strm__) - '\r' - | Some('t') => - Stream.junk(strm__) - '\t' - | Some('0' .. '9' as c1) => - Stream.junk(strm__) - switch Stream.peek(strm__) { - | Some('0' .. '9' as c2) => - Stream.junk(strm__) - switch Stream.peek(strm__) { - | Some('0' .. '9' as c3) => - Stream.junk(strm__) - Char.chr((Char.code(c1) - 48) * 100 + (Char.code(c2) - 48) * 10 + (Char.code(c3) - 48)) - | _ => raise(Stream.Error("")) - } - | _ => raise(Stream.Error("")) - } - | Some(c) => - Stream.junk(strm__) - c - | _ => raise(Stream.Failure) - } - and maybe_comment = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('*') => - Stream.junk(strm__) - let s = strm__ - comment(s) - next_token(s) - | _ => Some(keyword_or_error('(')) - } - and comment = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('(') => - Stream.junk(strm__) - maybe_nested_comment(strm__) - | Some('*') => - Stream.junk(strm__) - maybe_end_comment(strm__) - | Some(_) => - Stream.junk(strm__) - comment(strm__) - | _ => raise(Stream.Failure) - } - and maybe_nested_comment = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some('*') => - Stream.junk(strm__) - let s = strm__ - comment(s) - comment(s) - | Some(_) => - Stream.junk(strm__) - comment(strm__) - | _ => raise(Stream.Failure) - } - and maybe_end_comment = (strm__: Stream.t<_>) => - switch Stream.peek(strm__) { - | Some(')') => - Stream.junk(strm__) - () - | Some('*') => - Stream.junk(strm__) - maybe_end_comment(strm__) - | Some(_) => - Stream.junk(strm__) - comment(strm__) - | _ => raise(Stream.Failure) - } - - input => Stream.from(_count => next_token(input)) -} diff --git a/jscomp/stdlib-406/genlex.resi b/jscomp/stdlib-406/genlex.resi deleted file mode 100644 index 48dc4f9..0000000 --- a/jscomp/stdlib-406/genlex.resi +++ /dev/null @@ -1,73 +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. */ -/* */ -/* ************************************************************************ */ - -/*** A generic lexical analyzer. - - - This module implements a simple 'standard' lexical analyzer, presented - as a function from character streams to token streams. It implements - roughly the lexical conventions of OCaml, but is parameterized by the - set of keywords of your language. - - - Example: a lexer suitable for a desk calculator is obtained by - {[ let lexer = make_lexer ["+";"-";"*";"/";"let";"="; "("; ")"] ]} - - The associated parser would be a function from [token stream] - to, for instance, [int], and would have rules such as: - - {[ - let rec parse_expr = parser - | [< n1 = parse_atom; n2 = parse_remainder n1 >] -> n2 - and parse_atom = parser - | [< 'Int n >] -> n - | [< 'Kwd "("; n = parse_expr; 'Kwd ")" >] -> n - and parse_remainder n1 = parser - | [< 'Kwd "+"; n2 = parse_expr >] -> n1+n2 - | [< >] -> n1 - ]} - - One should notice that the use of the [parser] keyword and associated - notation for streams are only available through camlp4 extensions. This - means that one has to preprocess its sources {i e. g.} by using the - ["-pp"] command-line switch of the compilers. -*/ - -/** The type of tokens. The lexical classes are: [Int] and [Float] - for integer and floating-point numbers; [String] for - string literals, enclosed in double quotes; [Char] for - character literals, enclosed in single quotes; [Ident] for - identifiers (either sequences of letters, digits, underscores - and quotes, or sequences of 'operator characters' such as - [+], [*], etc); and [Kwd] for keywords (either identifiers or - single 'special characters' such as [(], [}], etc). */ -type token = - | Kwd(string) - | Ident(string) - | Int(int) - | Float(float) - | String(string) - | Char(char) - -/** Construct the lexer function. The first argument is the list of - keywords. An identifier [s] is returned as [Kwd s] if [s] - belongs to this list, and as [Ident s] otherwise. - A special character [s] is returned as [Kwd s] if [s] - belongs to this list, and cause a lexical error (exception - {!Stream.Error} with the offending lexeme as its parameter) otherwise. - Blanks and newlines are skipped. Comments delimited by [(*] and [*)] - are skipped as well, and can be nested. A {!Stream.Failure} exception - is raised if end of stream is unexpectedly reached.*/ -let make_lexer: (list, Stream.t) => Stream.t diff --git a/jscomp/stdlib-406/hashbang b/jscomp/stdlib-406/hashbang deleted file mode 100644 index 04c9334..0000000 --- a/jscomp/stdlib-406/hashbang +++ /dev/null @@ -1 +0,0 @@ -#! \ No newline at end of file diff --git a/jscomp/stdlib-406/hashtbl.res b/jscomp/stdlib-406/hashtbl.res deleted file mode 100644 index b29afbc..0000000 --- a/jscomp/stdlib-406/hashtbl.res +++ /dev/null @@ -1,679 +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. */ -/* */ -/* ************************************************************************ */ - -/* Hash tables */ - -@noalloc external seeded_hash_param: (int, int, int, 'a) => int = "?hash" -/* external old_hash_param : - int -> int -> 'a -> int = "caml_hash_univ_param" [@@noalloc] */ - -let hash = x => seeded_hash_param(10, 100, 0, x) -let hash_param = (n1, n2, x) => seeded_hash_param(n1, n2, 0, x) -let seeded_hash = (seed, x) => seeded_hash_param(10, 100, seed, x) - -/* We do dynamic hashing, and resize the table and rehash the elements - when buckets become too long. */ - -type rec t<'a, 'b> = { - mutable size: int /* number of entries */, - mutable data: array> /* the buckets */, - mutable seed: int /* for randomization */, - mutable initial_size: int /* initial array size */, -} - -and bucketlist<'a, 'b> = - | Empty - | Cons({mutable key: 'a, mutable data: 'b, mutable next: bucketlist<'a, 'b>}) - -/* The sign of initial_size encodes the fact that a traversal is - ongoing or not. - - This disables the efficient in place implementation of resizing. -*/ - -let ongoing_traversal = h => h.initial_size < 0 - -let flip_ongoing_traversal = h => h.initial_size = -h.initial_size - -/* To pick random seeds if requested */ - -let randomized_default = false - -let randomized = ref(randomized_default) - -let randomize = () => randomized := true -let is_randomized = () => randomized.contents - -let prng = lazy Random.State.make_self_init() - -/* Creating a fresh, empty table */ - -let rec power_2_above = (x, n) => - if x >= n { - x - } else if x * 2 < x { - x /* overflow */ - } else { - power_2_above(x * 2, n) - } - -let create = (~random=randomized.contents, initial_size) => { - let s = power_2_above(16, initial_size) - let seed = if random { - Random.State.bits(Lazy.force(prng)) - } else { - 0 - } - {initial_size: s, size: 0, seed, data: Array.make(s, Empty)} -} - -let clear = h => { - h.size = 0 - let len = Array.length(h.data) - for i in 0 to len - 1 { - h.data[i] = Empty - } -} - -let reset = h => { - let len = Array.length(h.data) - if len == abs(h.initial_size) { - clear(h) - } else { - h.size = 0 - h.data = Array.make(abs(h.initial_size), Empty) - } -} - -let copy_bucketlist = param => - switch param { - | Empty => Empty - | Cons({key, data, next}) => - let rec loop = (prec, param) => - switch param { - | Empty => () - | Cons({key, data, next}) => - let r = Cons({key, data, next}) - switch prec { - | Empty => assert(false) - | Cons(prec) => prec.next = r - } - loop(r, next) - } - - let r = Cons({key, data, next}) - loop(r, next) - r - } - -let copy = h => {...h, data: Array.map(copy_bucketlist, h.data)} - -let length = h => h.size - -let resize = (indexfun, h) => { - let odata = h.data - let osize = Array.length(odata) - let nsize = osize * 2 - if nsize >= osize { - let ndata = Array.make(nsize, Empty) - let ndata_tail = Array.make(nsize, Empty) - let inplace = !ongoing_traversal(h) - h.data = ndata /* so that indexfun sees the new bucket count */ - let rec insert_bucket = param => - switch param { - | Empty => () - | Cons({key, data, next}) as cell => - let cell = if inplace { - cell - } else { - Cons({key, data, next: Empty}) - } - - let nidx = indexfun(h, key) - switch ndata_tail[nidx] { - | Empty => ndata[nidx] = cell - | Cons(tail) => tail.next = cell - } - ndata_tail[nidx] = cell - insert_bucket(next) - } - - for i in 0 to osize - 1 { - insert_bucket(odata[i]) - } - if inplace { - for i in 0 to nsize - 1 { - switch ndata_tail[i] { - | Empty => () - | Cons(tail) => tail.next = Empty - } - } - } - } -} - -let key_index = (h, key) => - /* compatibility with old hash tables */ - land(seeded_hash_param(10, 100, h.seed, key), Array.length(h.data) - 1) - -let add = (h, key, data) => { - let i = key_index(h, key) - let bucket = Cons({key, data, next: h.data[i]}) - h.data[i] = bucket - h.size = h.size + 1 - if h.size > lsl(Array.length(h.data), 1) { - resize(key_index, h) - } -} - -let rec remove_bucket = (h, i, key, prec, param) => - switch param { - | Empty => () - | Cons({key: k, next}) as c => - if compare(k, key) == 0 { - h.size = h.size - 1 - switch prec { - | Empty => h.data[i] = next - | Cons(c) => c.next = next - } - } else { - remove_bucket(h, i, key, c, next) - } - } - -let remove = (h, key) => { - let i = key_index(h, key) - remove_bucket(h, i, key, Empty, h.data[i]) -} - -let rec find_rec = (key, param) => - switch param { - | Empty => raise(Not_found) - | Cons({key: k, data, next}) => - if compare(key, k) == 0 { - data - } else { - find_rec(key, next) - } - } - -let find = (h, key) => - switch h.data[key_index(h, key)] { - | Empty => raise(Not_found) - | Cons({key: k1, data: d1, next: next1}) => - if compare(key, k1) == 0 { - d1 - } else { - switch next1 { - | Empty => raise(Not_found) - | Cons({key: k2, data: d2, next: next2}) => - if compare(key, k2) == 0 { - d2 - } else { - switch next2 { - | Empty => raise(Not_found) - | Cons({key: k3, data: d3, next: next3}) => - if compare(key, k3) == 0 { - d3 - } else { - find_rec(key, next3) - } - } - } - } - } - } - -let rec find_rec_opt = (key, param) => - switch param { - | Empty => None - | Cons({key: k, data, next}) => - if compare(key, k) == 0 { - Some(data) - } else { - find_rec_opt(key, next) - } - } - -let find_opt = (h, key) => - switch h.data[key_index(h, key)] { - | Empty => None - | Cons({key: k1, data: d1, next: next1}) => - if compare(key, k1) == 0 { - Some(d1) - } else { - switch next1 { - | Empty => None - | Cons({key: k2, data: d2, next: next2}) => - if compare(key, k2) == 0 { - Some(d2) - } else { - switch next2 { - | Empty => None - | Cons({key: k3, data: d3, next: next3}) => - if compare(key, k3) == 0 { - Some(d3) - } else { - find_rec_opt(key, next3) - } - } - } - } - } - } - -let find_all = (h, key) => { - let rec find_in_bucket = param => - switch param { - | Empty => list{} - | Cons({key: k, data, next}) => - if compare(k, key) == 0 { - list{data, ...find_in_bucket(next)} - } else { - find_in_bucket(next) - } - } - find_in_bucket(h.data[key_index(h, key)]) -} - -let rec replace_bucket = (key, data, param) => - switch param { - | Empty => true - | Cons({key: k, next} as slot) => - if compare(k, key) == 0 { - slot.key = key - slot.data = data - false - } else { - replace_bucket(key, data, next) - } - } - -let replace = (h, key, data) => { - let i = key_index(h, key) - let l = h.data[i] - if replace_bucket(key, data, l) { - h.data[i] = Cons({key, data, next: l}) - h.size = h.size + 1 - if h.size > lsl(Array.length(h.data), 1) { - resize(key_index, h) - } - } -} - -let mem = (h, key) => { - let rec mem_in_bucket = param => - switch param { - | Empty => false - | Cons({key: k, next}) => compare(k, key) == 0 || mem_in_bucket(next) - } - mem_in_bucket(h.data[key_index(h, key)]) -} - -let iter = (f, h) => { - let rec do_bucket = param => - switch param { - | Empty => () - | Cons({key, data, next}) => - f(key, data) - do_bucket(next) - } - let old_trav = ongoing_traversal(h) - if !old_trav { - flip_ongoing_traversal(h) - } - try { - let d = h.data - for i in 0 to Array.length(d) - 1 { - do_bucket(d[i]) - } - if !old_trav { - flip_ongoing_traversal(h) - } - } catch { - | exn if !old_trav => - flip_ongoing_traversal(h) - raise(exn) - } -} - -let rec filter_map_inplace_bucket = (f, h, i, prec, param) => - switch param { - | Empty => - switch prec { - | Empty => h.data[i] = Empty - | Cons(c) => c.next = Empty - } - | Cons({key, data, next} as c) as slot => - switch f(key, data) { - | None => - h.size = h.size - 1 - filter_map_inplace_bucket(f, h, i, prec, next) - | Some(data) => - switch prec { - | Empty => h.data[i] = slot - | Cons(c) => c.next = slot - } - c.data = data - filter_map_inplace_bucket(f, h, i, slot, next) - } - } - -let filter_map_inplace = (f, h) => { - let d = h.data - let old_trav = ongoing_traversal(h) - if !old_trav { - flip_ongoing_traversal(h) - } - try for i in 0 to Array.length(d) - 1 { - filter_map_inplace_bucket(f, h, i, Empty, h.data[i]) - } catch { - | exn if !old_trav => - flip_ongoing_traversal(h) - raise(exn) - } -} - -let fold = (f, h, init) => { - let rec do_bucket = (b, accu) => - switch b { - | Empty => accu - | Cons({key, data, next}) => do_bucket(next, f(key, data, accu)) - } - let old_trav = ongoing_traversal(h) - if !old_trav { - flip_ongoing_traversal(h) - } - try { - let d = h.data - let accu = ref(init) - for i in 0 to Array.length(d) - 1 { - accu := do_bucket(d[i], accu.contents) - } - if !old_trav { - flip_ongoing_traversal(h) - } - accu.contents - } catch { - | exn if !old_trav => - flip_ongoing_traversal(h) - raise(exn) - } -} - -type statistics = { - num_bindings: int, - num_buckets: int, - max_bucket_length: int, - bucket_histogram: array, -} - -let rec bucket_length = (accu, param) => - switch param { - | Empty => accu - | Cons({next}) => bucket_length(accu + 1, next) - } - -let stats = h => { - let mbl = Array.fold_left((m, b) => max(m, bucket_length(0, b)), 0, h.data) - let histo = Array.make(mbl + 1, 0) - Array.iter(b => { - let l = bucket_length(0, b) - histo[l] = histo[l] + 1 - }, h.data) - { - num_bindings: h.size, - num_buckets: Array.length(h.data), - max_bucket_length: mbl, - bucket_histogram: histo, - } -} - -/* Functorial interface */ - -module type HashedType = { - type t - let equal: (t, t) => bool - let hash: t => int -} - -module type SeededHashedType = { - type t - let equal: (t, t) => bool - let hash: (int, t) => int -} - -module type S = { - type key - type t<'a> - let create: int => t<'a> - let clear: t<'a> => unit - let reset: t<'a> => unit - let copy: t<'a> => t<'a> - let add: (t<'a>, key, 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - let find_opt: (t<'a>, key) => option<'a> - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, key, 'a) => unit - let mem: (t<'a>, key) => bool - let iter: ((key, 'a) => unit, t<'a>) => unit - let filter_map_inplace: ((key, 'a) => option<'a>, t<'a>) => unit - let fold: ((key, 'a, 'b) => 'b, t<'a>, 'b) => 'b - let length: t<'a> => int - let stats: t<'a> => statistics -} - -module type SeededS = { - type key - type t<'a> - let create: (~random: bool=?, int) => t<'a> - let clear: t<'a> => unit - let reset: t<'a> => unit - let copy: t<'a> => t<'a> - let add: (t<'a>, key, 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - let find_opt: (t<'a>, key) => option<'a> - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, key, 'a) => unit - let mem: (t<'a>, key) => bool - let iter: ((key, 'a) => unit, t<'a>) => unit - let filter_map_inplace: ((key, 'a) => option<'a>, t<'a>) => unit - let fold: ((key, 'a, 'b) => 'b, t<'a>, 'b) => 'b - let length: t<'a> => int - let stats: t<'a> => statistics -} - -module MakeSeeded = (H: SeededHashedType): (SeededS with type key = H.t) => { - type key = H.t - type hashtbl<'a> = t - type t<'a> = hashtbl<'a> - let create = create - let clear = clear - let reset = reset - let copy = copy - - let key_index = (h, key) => land(H.hash(h.seed, key), Array.length(h.data) - 1) - - let add = (h, key, data) => { - let i = key_index(h, key) - let bucket = Cons({key, data, next: h.data[i]}) - h.data[i] = bucket - h.size = h.size + 1 - if h.size > lsl(Array.length(h.data), 1) { - resize(key_index, h) - } - } - - let rec remove_bucket = (h, i, key, prec, param) => - switch param { - | Empty => () - | Cons({key: k, next}) as c => - if H.equal(k, key) { - h.size = h.size - 1 - switch prec { - | Empty => h.data[i] = next - | Cons(c) => c.next = next - } - } else { - remove_bucket(h, i, key, c, next) - } - } - - let remove = (h, key) => { - let i = key_index(h, key) - remove_bucket(h, i, key, Empty, h.data[i]) - } - - let rec find_rec = (key, param) => - switch param { - | Empty => raise(Not_found) - | Cons({key: k, data, next}) => - if H.equal(key, k) { - data - } else { - find_rec(key, next) - } - } - - let find = (h, key) => - switch h.data[key_index(h, key)] { - | Empty => raise(Not_found) - | Cons({key: k1, data: d1, next: next1}) => - if H.equal(key, k1) { - d1 - } else { - switch next1 { - | Empty => raise(Not_found) - | Cons({key: k2, data: d2, next: next2}) => - if H.equal(key, k2) { - d2 - } else { - switch next2 { - | Empty => raise(Not_found) - | Cons({key: k3, data: d3, next: next3}) => - if H.equal(key, k3) { - d3 - } else { - find_rec(key, next3) - } - } - } - } - } - } - - let rec find_rec_opt = (key, param) => - switch param { - | Empty => None - | Cons({key: k, data, next}) => - if H.equal(key, k) { - Some(data) - } else { - find_rec_opt(key, next) - } - } - - let find_opt = (h, key) => - switch h.data[key_index(h, key)] { - | Empty => None - | Cons({key: k1, data: d1, next: next1}) => - if H.equal(key, k1) { - Some(d1) - } else { - switch next1 { - | Empty => None - | Cons({key: k2, data: d2, next: next2}) => - if H.equal(key, k2) { - Some(d2) - } else { - switch next2 { - | Empty => None - | Cons({key: k3, data: d3, next: next3}) => - if H.equal(key, k3) { - Some(d3) - } else { - find_rec_opt(key, next3) - } - } - } - } - } - } - - let find_all = (h, key) => { - let rec find_in_bucket = param => - switch param { - | Empty => list{} - | Cons({key: k, data: d, next}) => - if H.equal(k, key) { - list{d, ...find_in_bucket(next)} - } else { - find_in_bucket(next) - } - } - find_in_bucket(h.data[key_index(h, key)]) - } - - let rec replace_bucket = (key, data, param) => - switch param { - | Empty => true - | Cons({key: k, next} as slot) => - if H.equal(k, key) { - slot.key = key - slot.data = data - false - } else { - replace_bucket(key, data, next) - } - } - - let replace = (h, key, data) => { - let i = key_index(h, key) - let l = h.data[i] - if replace_bucket(key, data, l) { - h.data[i] = Cons({key, data, next: l}) - h.size = h.size + 1 - if h.size > lsl(Array.length(h.data), 1) { - resize(key_index, h) - } - } - } - - let mem = (h, key) => { - let rec mem_in_bucket = param => - switch param { - | Empty => false - | Cons({key: k, next}) => H.equal(k, key) || mem_in_bucket(next) - } - mem_in_bucket(h.data[key_index(h, key)]) - } - - let iter = iter - let filter_map_inplace = filter_map_inplace - let fold = fold - let length = length - let stats = stats -} - -module Make = (H: HashedType): (S with type key = H.t) => { - include MakeSeeded({ - type t = H.t - let equal = H.equal - let hash = (_seed: int, x) => H.hash(x) - }) - let create = sz => create(~random=false, sz) -} diff --git a/jscomp/stdlib-406/hashtbl.resi b/jscomp/stdlib-406/hashtbl.resi deleted file mode 100644 index 5acfde2..0000000 --- a/jscomp/stdlib-406/hashtbl.resi +++ /dev/null @@ -1,406 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Hash tables and hash functions. - - Hash tables are hashed association tables, with in-place modification. -*/ - -/* {1 Generic interface} */ - -/** The type of hash tables from type ['a] to type ['b]. */ -type t<'a, 'b> - -/** [Hashtbl.create n] creates a new, empty hash table, with - initial size [n]. For best results, [n] should be on the - order of the expected number of elements that will be in - the table. The table grows as needed, so [n] is just an - initial guess. - - The optional [random] parameter (a boolean) controls whether - the internal organization of the hash table is randomized at each - execution of [Hashtbl.create] or deterministic over all executions. - - A hash table that is created with [~random:false] uses a - fixed hash function ({!Hashtbl.hash}) to distribute keys among - buckets. As a consequence, collisions between keys happen - deterministically. In Web-facing applications or other - security-sensitive applications, the deterministic collision - patterns can be exploited by a malicious user to create a - denial-of-service attack: the attacker sends input crafted to - create many collisions in the table, slowing the application down. - - A hash table that is created with [~random:true] uses the seeded - hash function {!Hashtbl.seeded_hash} with a seed that is randomly - chosen at hash table creation time. In effect, the hash function - used is randomly selected among [2^{30}] different hash functions. - All these hash functions have different collision patterns, - rendering ineffective the denial-of-service attack described above. - However, because of randomization, enumerating all elements of the - hash table using {!Hashtbl.fold} or {!Hashtbl.iter} is no longer - deterministic: elements are enumerated in different orders at - different runs of the program. - - If no [~random] parameter is given, hash tables are created - in non-random mode by default. This default can be changed - either programmatically by calling {!Hashtbl.randomize} or by - setting the [R] flag in the [OCAMLRUNPARAM] environment variable. - - @before 4.00.0 the [random] parameter was not present and all - hash tables were created in non-randomized mode. */ -let create: (~random: bool=?, int) => t<'a, 'b> - -/** Empty a hash table. Use [reset] instead of [clear] to shrink the - size of the bucket table to its initial size. */ -let clear: t<'a, 'b> => unit - -/** Empty a hash table and shrink the size of the bucket table - to its initial size. - @since 4.00.0 */ -let reset: t<'a, 'b> => unit - -/** Return a copy of the given hashtable. */ -let copy: t<'a, 'b> => t<'a, 'b> - -/** [Hashtbl.add tbl x y] adds a binding of [x] to [y] in table [tbl]. - Previous bindings for [x] are not removed, but simply - hidden. That is, after performing {!Hashtbl.remove}[ tbl x], - the previous binding for [x], if any, is restored. - (Same behavior as with association lists.) */ -let add: (t<'a, 'b>, 'a, 'b) => unit - -/** [Hashtbl.find tbl x] returns the current binding of [x] in [tbl], - or raises [Not_found] if no such binding exists. */ -let find: (t<'a, 'b>, 'a) => 'b - -/** [Hashtbl.find_opt tbl x] returns the current binding of [x] in [tbl], - or [None] if no such binding exists. - @since 4.05 */ -let find_opt: (t<'a, 'b>, 'a) => option<'b> - -/** [Hashtbl.find_all tbl x] returns the list of all data - associated with [x] in [tbl]. - The current binding is returned first, then the previous - bindings, in reverse order of introduction in the table. */ -let find_all: (t<'a, 'b>, 'a) => list<'b> - -/** [Hashtbl.mem tbl x] checks if [x] is bound in [tbl]. */ -let mem: (t<'a, 'b>, 'a) => bool - -/** [Hashtbl.remove tbl x] removes the current binding of [x] in [tbl], - restoring the previous binding if it exists. - It does nothing if [x] is not bound in [tbl]. */ -let remove: (t<'a, 'b>, 'a) => unit - -/** [Hashtbl.replace tbl x y] replaces the current binding of [x] - in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl], - a binding of [x] to [y] is added to [tbl]. - This is functionally equivalent to {!Hashtbl.remove}[ tbl x] - followed by {!Hashtbl.add}[ tbl x y]. */ -let replace: (t<'a, 'b>, 'a, 'b) => unit - -/** [Hashtbl.iter f tbl] applies [f] to all bindings in table [tbl]. - [f] receives the key as first argument, and the associated value - as second argument. Each binding is presented exactly once to [f]. - - The order in which the bindings are passed to [f] is unspecified. - However, if the table contains several bindings for the same key, - they are passed to [f] in reverse order of introduction, that is, - the most recent binding is passed first. - - If the hash table was created in non-randomized mode, the order - in which the bindings are enumerated is reproducible between - successive runs of the program, and even between minor versions - of OCaml. For randomized hash tables, the order of enumeration - is entirely random. - - The behavior is not defined if the hash table is modified - by [f] during the iteration. -*/ -let iter: (('a, 'b) => unit, t<'a, 'b>) => unit - -/** [Hashtbl.filter_map_inplace f tbl] applies [f] to all bindings in - table [tbl] and update each binding depending on the result of - [f]. If [f] returns [None], the binding is discarded. If it - returns [Some new_val], the binding is update to associate the key - to [new_val]. - - Other comments for {!Hashtbl.iter} apply as well. - @since 4.03.0 */ -let filter_map_inplace: (('a, 'b) => option<'b>, t<'a, 'b>) => unit - -/** [Hashtbl.fold f tbl init] computes - [(f kN dN ... (f k1 d1 init)...)], - where [k1 ... kN] are the keys of all bindings in [tbl], - and [d1 ... dN] are the associated values. - Each binding is presented exactly once to [f]. - - The order in which the bindings are passed to [f] is unspecified. - However, if the table contains several bindings for the same key, - they are passed to [f] in reverse order of introduction, that is, - the most recent binding is passed first. - - If the hash table was created in non-randomized mode, the order - in which the bindings are enumerated is reproducible between - successive runs of the program, and even between minor versions - of OCaml. For randomized hash tables, the order of enumeration - is entirely random. - - The behavior is not defined if the hash table is modified - by [f] during the iteration. -*/ -let fold: (('a, 'b, 'c) => 'c, t<'a, 'b>, 'c) => 'c - -/** [Hashtbl.length tbl] returns the number of bindings in [tbl]. - It takes constant time. Multiple bindings are counted once each, so - [Hashtbl.length] gives the number of times [Hashtbl.iter] calls its - first argument. */ -let length: t<'a, 'b> => int - -/** After a call to [Hashtbl.randomize()], hash tables are created in - randomized mode by default: {!Hashtbl.create} returns randomized - hash tables, unless the [~random:false] optional parameter is given. - The same effect can be achieved by setting the [R] parameter in - the [OCAMLRUNPARAM] environment variable. - - It is recommended that applications or Web frameworks that need to - protect themselves against the denial-of-service attack described - in {!Hashtbl.create} call [Hashtbl.randomize()] at initialization - time. - - Note that once [Hashtbl.randomize()] was called, there is no way - to revert to the non-randomized default behavior of {!Hashtbl.create}. - This is intentional. Non-randomized hash tables can still be - created using [Hashtbl.create ~random:false]. - - @since 4.00.0 */ -let randomize: unit => unit - -/** return if the tables are currently created in randomized mode by default - - @since 4.03.0 */ -let is_randomized: unit => bool - -/** @since 4.00.0 */ -type statistics = { - /** Number of bindings present in the table. - Same value as returned by {!Hashtbl.length}. */ - num_bindings: int, - /** Number of buckets in the table. */ - num_buckets: int, - /** Maximal number of bindings per bucket. */ - max_bucket_length: int, - /** Histogram of bucket sizes. This array [histo] has - length [max_bucket_length + 1]. The value of - [histo.(i)] is the number of buckets whose size is [i]. */ - bucket_histogram: array, -} - -/** [Hashtbl.stats tbl] returns statistics about the table [tbl]: - number of buckets, size of the biggest bucket, distribution of - buckets by size. - @since 4.00.0 */ -let stats: t<'a, 'b> => statistics - -/* {1 Functorial interface} - -The functorial interface allows the use of specific comparison - and hash functions, either for performance/security concerns, - or because keys are not hashable/comparable with the polymorphic builtins. - - For instance, one might want to specialize a table for integer keys: - {[ - module IntHash = - struct - type t = int - let equal i j = i=j - let hash i = i land max_int - end - - module IntHashtbl = Hashtbl.Make(IntHash) - - let h = IntHashtbl.create 17 in - IntHashtbl.add h 12 "hello" - ]} - - This creates a new module [IntHashtbl], with a new type ['a - IntHashtbl.t] of tables from [int] to ['a]. In this example, [h] - contains [string] values so its type is [string IntHashtbl.t]. - - Note that the new type ['a IntHashtbl.t] is not compatible with - the type [('a,'b) Hashtbl.t] of the generic interface. For - example, [Hashtbl.length h] would not type-check, you must use - [IntHashtbl.length]. -*/ - -/** The input signature of the functor {!Hashtbl.Make}. */ -module type HashedType = { - /** The type of the hashtable keys. */ - type t - - /** The equality predicate used to compare keys. */ - let equal: (t, t) => bool - - /** A hashing function on keys. It must be such that if two keys are - equal according to [equal], then they have identical hash values - as computed by [hash]. - Examples: suitable ([equal], [hash]) pairs for arbitrary key - types include -- ([(=)], {!Hashtbl.hash}) for comparing objects by structure - (provided objects do not contain floats) -- ([(fun x y -> compare x y = 0)], {!Hashtbl.hash}) - for comparing objects by structure - and handling {!Pervasives.nan} correctly -- ([(==)], {!Hashtbl.hash}) for comparing objects by physical - equality (e.g. for mutable or cyclic objects). */ - let hash: t => int -} - -/** The output signature of the functor {!Hashtbl.Make}. */ -module type S = { - type key - type t<'a> - let create: int => t<'a> - let clear: t<'a> => unit - /** @since 4.00.0 */ - let reset: t<'a> => unit - - let copy: t<'a> => t<'a> - let add: (t<'a>, key, 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - /** @since 4.05.0 */ - let find_opt: (t<'a>, key) => option<'a> - - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, key, 'a) => unit - let mem: (t<'a>, key) => bool - let iter: ((key, 'a) => unit, t<'a>) => unit - /** @since 4.03.0 */ - let filter_map_inplace: ((key, 'a) => option<'a>, t<'a>) => unit - - let fold: ((key, 'a, 'b) => 'b, t<'a>, 'b) => 'b - let length: t<'a> => int - /** @since 4.00.0 */ - let stats: t<'a> => statistics -} - -/** Functor building an implementation of the hashtable structure. - The functor [Hashtbl.Make] returns a structure containing - a type [key] of keys and a type ['a t] of hash tables - associating data of type ['a] to keys of type [key]. - The operations perform similarly to those of the generic - interface, but use the hashing and equality functions - specified in the functor argument [H] instead of generic - equality and hashing. Since the hash function is not seeded, - the [create] operation of the result structure always returns - non-randomized hash tables. */ -module Make: (H: HashedType) => (S with type key = H.t) - -/** The input signature of the functor {!Hashtbl.MakeSeeded}. - @since 4.00.0 */ -module type SeededHashedType = { - /** The type of the hashtable keys. */ - type t - - /** The equality predicate used to compare keys. */ - let equal: (t, t) => bool - - /** A seeded hashing function on keys. The first argument is - the seed. It must be the case that if [equal x y] is true, - then [hash seed x = hash seed y] for any value of [seed]. - A suitable choice for [hash] is the function {!Hashtbl.seeded_hash} - below. */ - let hash: (int, t) => int -} - -/** The output signature of the functor {!Hashtbl.MakeSeeded}. - @since 4.00.0 */ -module type SeededS = { - type key - type t<'a> - let create: (~random: bool=?, int) => t<'a> - let clear: t<'a> => unit - let reset: t<'a> => unit - let copy: t<'a> => t<'a> - let add: (t<'a>, key, 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - /** @since 4.05.0 */ - let find_opt: (t<'a>, key) => option<'a> - - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, key, 'a) => unit - let mem: (t<'a>, key) => bool - let iter: ((key, 'a) => unit, t<'a>) => unit - /** @since 4.03.0 */ - let filter_map_inplace: ((key, 'a) => option<'a>, t<'a>) => unit - - let fold: ((key, 'a, 'b) => 'b, t<'a>, 'b) => 'b - let length: t<'a> => int - let stats: t<'a> => statistics -} - -/** Functor building an implementation of the hashtable structure. - The functor [Hashtbl.MakeSeeded] returns a structure containing - a type [key] of keys and a type ['a t] of hash tables - associating data of type ['a] to keys of type [key]. - The operations perform similarly to those of the generic - interface, but use the seeded hashing and equality functions - specified in the functor argument [H] instead of generic - equality and hashing. The [create] operation of the - result structure supports the [~random] optional parameter - and returns randomized hash tables if [~random:true] is passed - or if randomization is globally on (see {!Hashtbl.randomize}). - @since 4.00.0 */ -module MakeSeeded: (H: SeededHashedType) => (SeededS with type key = H.t) - -/* {1 The polymorphic hash functions} */ - -/** [Hashtbl.hash x] associates a nonnegative integer to any value of - any type. It is guaranteed that - if [x = y] or [Pervasives.compare x y = 0], then [hash x = hash y]. - Moreover, [hash] always terminates, even on cyclic structures. */ -let hash: 'a => int - -/** A variant of {!Hashtbl.hash} that is further parameterized by - an integer seed. - @since 4.00.0 */ -let seeded_hash: (int, 'a) => int - -/** [Hashtbl.hash_param meaningful total x] computes a hash value for [x], - with the same properties as for [hash]. The two extra integer - parameters [meaningful] and [total] give more precise control over - hashing. Hashing performs a breadth-first, left-to-right traversal - of the structure [x], stopping after [meaningful] meaningful nodes - were encountered, or [total] nodes (meaningful or not) were - encountered. If [total] as specified by the user exceeds a certain - value, currently 256, then it is capped to that value. - Meaningful nodes are: integers; floating-point - numbers; strings; characters; booleans; and constant - constructors. Larger values of [meaningful] and [total] means that - more nodes are taken into account to compute the final hash value, - and therefore collisions are less likely to happen. However, - hashing takes longer. The parameters [meaningful] and [total] - govern the tradeoff between accuracy and speed. As default - choices, {!Hashtbl.hash} and {!Hashtbl.seeded_hash} take - [meaningful = 10] and [total = 100]. */ -let hash_param: (int, int, 'a) => int - -/** A variant of {!Hashtbl.hash_param} that is further parameterized by - an integer seed. Usage: - [Hashtbl.seeded_hash_param meaningful total seed x]. - @since 4.00.0 */ -let seeded_hash_param: (int, int, int, 'a) => int diff --git a/jscomp/stdlib-406/hashtblLabels.res b/jscomp/stdlib-406/hashtblLabels.res deleted file mode 100644 index e9fe63a..0000000 --- a/jscomp/stdlib-406/hashtblLabels.res +++ /dev/null @@ -1,129 +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. */ -/* */ -/* ************************************************************************ */ - -/* Hash tables */ - -type t<'a, 'b> = Hashtbl.t<'a, 'b> - -let { - create, - clear, - reset, - copy, - add, - find, - find_opt, - find_all, - mem, - remove, - replace, - iter, - filter_map_inplace, - fold, - length, - randomize, - is_randomized, - stats, - hash, - seeded_hash, - hash_param, - seeded_hash_param, -} = module(Hashtbl) - -let add = (tbl, ~key, ~data) => add(tbl, key, data) - -let replace = (tbl, ~key, ~data) => replace(tbl, key, data) - -let iter = (~f, tbl) => iter((key, data) => f(~key, ~data), tbl) - -let filter_map_inplace = (~f, tbl) => filter_map_inplace((key, data) => f(~key, ~data), tbl) - -let fold = (~f, tbl, ~init) => fold((key, data, acc) => f(~key, ~data, acc), tbl, init) - -type statistics = Hashtbl.statistics = { - num_bindings: int, - num_buckets: int, - max_bucket_length: int, - bucket_histogram: array, -} - -/* Functorial interface */ - -module type HashedType = Hashtbl.HashedType - -module type SeededHashedType = Hashtbl.SeededHashedType - -module type S = { - type rec key - and t<'a> - let create: int => t<'a> - let clear: t<'a> => unit - let reset: t<'a> => unit - let copy: t<'a> => t<'a> - let add: (t<'a>, ~key: key, ~data: 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - let find_opt: (t<'a>, key) => option<'a> - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, ~key: key, ~data: 'a) => unit - let mem: (t<'a>, key) => bool - let iter: (~f: (~key: key, ~data: 'a) => unit, t<'a>) => unit - let filter_map_inplace: (~f: (~key: key, ~data: 'a) => option<'a>, t<'a>) => unit - let fold: (~f: (~key: key, ~data: 'a, 'b) => 'b, t<'a>, ~init: 'b) => 'b - let length: t<'a> => int - let stats: t<'a> => statistics -} - -module type SeededS = { - type rec key - and t<'a> - let create: (~random: bool=?, int) => t<'a> - let clear: t<'a> => unit - let reset: t<'a> => unit - let copy: t<'a> => t<'a> - let add: (t<'a>, ~key: key, ~data: 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - let find_opt: (t<'a>, key) => option<'a> - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, ~key: key, ~data: 'a) => unit - let mem: (t<'a>, key) => bool - let iter: (~f: (~key: key, ~data: 'a) => unit, t<'a>) => unit - let filter_map_inplace: (~f: (~key: key, ~data: 'a) => option<'a>, t<'a>) => unit - let fold: (~f: (~key: key, ~data: 'a, 'b) => 'b, t<'a>, ~init: 'b) => 'b - let length: t<'a> => int - let stats: t<'a> => statistics -} - -module MakeSeeded = (H: SeededHashedType): (SeededS with type key = H.t) => { - include Hashtbl.MakeSeeded(H) - let add = (tbl, ~key, ~data) => add(tbl, key, data) - let replace = (tbl, ~key, ~data) => replace(tbl, key, data) - - let iter = (~f, tbl) => iter((key, data) => f(~key, ~data), tbl) - - let filter_map_inplace = (~f, tbl) => filter_map_inplace((key, data) => f(~key, ~data), tbl) - - let fold = (~f, tbl, ~init) => fold((key, data, acc) => f(~key, ~data, acc), tbl, init) -} - -module Make = (H: HashedType): (S with type key = H.t) => { - include MakeSeeded({ - type t = H.t - let equal = H.equal - let hash = (_seed: int, x) => H.hash(x) - }) - let create = sz => create(~random=false, sz) -} diff --git a/jscomp/stdlib-406/int32.res b/jscomp/stdlib-406/int32.res deleted file mode 100644 index d3a53db..0000000 --- a/jscomp/stdlib-406/int32.res +++ /dev/null @@ -1,64 +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. */ -/* */ -/* ************************************************************************ */ -type t = int -/* Module [t]: 32-bit integers */ - -external neg: t => t = "%negint" -external add: (t, t) => t = "%addint" -external sub: (t, t) => t = "%subint" -external mul: (t, t) => t = "%mulint" -external div: (t, t) => t = "%divint" -external rem: (t, t) => t = "%modint" -external logand: (t, t) => t = "%andint" -external logor: (t, t) => t = "%orint" -external logxor: (t, t) => t = "%xorint" -external shift_left: (t, int) => t = "%lslint" -external shift_right: (t, int) => t = "%asrint" -external shift_right_logical: (t, int) => t = "%lsrint" -external of_int: int => t = "%identity" -external to_int: t => int = "%identity" -external of_float: float => t = "?int_of_float" -external to_float: t => float = "?int_to_float" -external bits_of_float: float => t = "?int_bits_of_float" -external float_of_bits: t => float = "?int_float_of_bits" - -let zero = 0l -let one = 1l -let minus_one = -1l -let succ = n => add(n, 1l) -let pred = n => sub(n, 1l) -let abs = n => - if n >= 0l { - n - } else { - neg(n) - } -let min_int = 0x80000000l -let max_int = 0x7FFFFFFFl -let lognot = n => logxor(n, -1l) - -external format: (string, t) => string = "?format_int" -let to_string = n => format("%d", n) - -external of_string: string => t = "?int_of_string" - -let of_string_opt = s => - /* TODO: expose a non-raising primitive directly. */ - try Some(of_string(s)) catch { - | Failure(_) => None - } - -let compare = (x: t, y: t) => Pervasives.compare(x, y) -let equal = (x: t, y: t) => compare(x, y) == 0 diff --git a/jscomp/stdlib-406/int32.resi b/jscomp/stdlib-406/int32.resi deleted file mode 100644 index 174036f..0000000 --- a/jscomp/stdlib-406/int32.resi +++ /dev/null @@ -1,176 +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. */ -/* */ -/* ************************************************************************ */ - -/** 32-bit integers. - - This module provides operations on the type [t] - of signed 32-bit integers. Unlike the built-in [int] type, - the type [t] is guaranteed to be exactly 32-bit wide on all - platforms. All arithmetic operations over [t] are taken - modulo 2{^32}. - - Performance notice: values of type [t] occupy more memory - space than values of type [int], and arithmetic operations on - [t] are generally slower than those on [int]. Use [t] - only when the application requires exact 32-bit arithmetic. */ -/** An alias for the type of 32-bit integers. */ -type t = int - -/** The 32-bit integer 0. */ -let zero: t - -/** The 32-bit integer 1. */ -let one: t - -/** The 32-bit integer -1. */ -let minus_one: t - -/** Unary negation. */ -external neg: t => t = "%negint" - -/** Addition. */ -external add: (t, t) => t = "%addint" - -/** Subtraction. */ -external sub: (t, t) => t = "%subint" - -/** Multiplication. */ -external mul: (t, t) => t = "%mulint" - -/** Integer division. Raise [Division_by_zero] if the second - argument is zero. This division rounds the real quotient of - its arguments towards zero, as specified for {!Pervasives.(/)}. */ -external div: (t, t) => t = "%divint" - -/** Integer remainder. If [y] is not zero, the result - of [Int32.rem x y] satisfies the following property: - [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. - If [y = 0], [Int32.rem x y] raises [Division_by_zero]. */ -external rem: (t, t) => t = "%modint" - -/** Successor. [Int32.succ x] is [Int32.add x Int32.one]. */ -let succ: t => t - -/** Predecessor. [Int32.pred x] is [Int32.sub x Int32.one]. */ -let pred: t => t - -/** Return the absolute value of its argument. */ -let abs: t => t - -/** The greatest representable 32-bit integer, 2{^31} - 1. */ -let max_int: t - -/** The smallest representable 32-bit integer, -2{^31}. */ -let min_int: t - -/** Bitwise logical and. */ -external logand: (t, t) => t = "%andint" - -/** Bitwise logical or. */ -external logor: (t, t) => t = "%orint" - -/** Bitwise logical exclusive or. */ -external logxor: (t, t) => t = "%xorint" - -/** Bitwise logical negation. */ -let lognot: t => t - -/** [Int32.shift_left x y] shifts [x] to the left by [y] bits. - The result is unspecified if [y < 0] or [y >= 32]. */ -external shift_left: (t, int) => t = "%lslint" - -/** [Int32.shift_right x y] shifts [x] to the right by [y] bits. - This is an arithmetic shift: the sign bit of [x] is replicated - and inserted in the vacated bits. - The result is unspecified if [y < 0] or [y >= 32]. */ -external shift_right: (t, int) => t = "%asrint" - -/** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. - This is a logical shift: zeroes are inserted in the vacated bits - regardless of the sign of [x]. - The result is unspecified if [y < 0] or [y >= 32]. */ -external shift_right_logical: (t, int) => t = "%lsrint" - -/** Convert the given integer (type [int]) to a 32-bit integer - (type [t]). */ -external of_int: int => t = "%identity" - -/** Convert the given 32-bit integer (type [t]) to an - integer (type [int]). On 32-bit platforms, the 32-bit integer - is taken modulo 2{^31}, i.e. the high-order bit is lost - during the conversion. On 64-bit platforms, the conversion - is exact. */ -external to_int: t => int = "%identity" - -/** Convert the given floating-point number to a 32-bit integer, - discarding the fractional part (truncate towards 0). - The result of the conversion is undefined if, after truncation, - the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. */ -external of_float: float => t = "?int_of_float" - -/** Convert the given 32-bit integer to a floating-point number. */ -external to_float: t => float = "?int_to_float" - -/** Convert the given string to a 32-bit integer. - The string is read in decimal (by default, or if the string - begins with [0u]) or in hexadecimal, octal or binary if the - string begins with [0x], [0o] or [0b] respectively. - - The [0u] prefix reads the input as an unsigned integer in the range - [[0, 2*Int32.max_int+1]]. If the input exceeds {!Int32.max_int} - it is converted to the signed integer - [Int32.min_int + input - Int32.max_int - 1]. - - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Raise [Failure "Int32.of_string"] if the given string is not - a valid representation of an integer, or if the integer represented - exceeds the range of integers representable in type [t]. */ -external of_string: string => t = "?int_of_string" - -/** Same as [of_string], but return [None] instead of raising. - @since 4.05 */ -let of_string_opt: string => option - -/** Return the string representation of its argument, in signed decimal. */ -let to_string: t => string - -/** Return the internal representation of the given float according - to the IEEE 754 floating-point 'single format' bit layout. - Bit 31 of the result represents the sign of the float; - bits 30 to 23 represent the (biased) exponent; bits 22 to 0 - represent the mantissa. */ -external bits_of_float: float => t = "?int_bits_of_float" - -/** Return the floating-point number whose internal representation, - according to the IEEE 754 floating-point 'single format' bit layout, - is the given [t]. */ -external float_of_bits: t => float = "?int_float_of_bits" - -/** The comparison function for 32-bit integers, with the same specification as - {!Pervasives.compare}. Along with the type [t], this function [compare] - allows the module [Int32] to be passed as argument to the functors - {!Set.Make} and {!Map.Make}. */ -let compare: (t, t) => int - -/** The equal function for int32s. - @since 4.03.0 */ -let equal: (t, t) => bool - -/* {1 Deprecated functions} */ - -/** Do not use this deprecated function. Instead, - used {!Printf.sprintf} with a [%l...] format. */ -external format: (string, t) => string = "?format_int" diff --git a/jscomp/stdlib-406/int64.res b/jscomp/stdlib-406/int64.res deleted file mode 100644 index 032a1c4..0000000 --- a/jscomp/stdlib-406/int64.res +++ /dev/null @@ -1,71 +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. */ -/* */ -/* ************************************************************************ */ - -/* Module [Int64]: 64-bit integers */ - -external neg: int64 => int64 = "%int64_neg" -external add: (int64, int64) => int64 = "%int64_add" -external sub: (int64, int64) => int64 = "%int64_sub" -external mul: (int64, int64) => int64 = "%int64_mul" -external div: (int64, int64) => int64 = "%int64_div" -external rem: (int64, int64) => int64 = "%int64_mod" -external logand: (int64, int64) => int64 = "%int64_and" -external logor: (int64, int64) => int64 = "%int64_or" -external logxor: (int64, int64) => int64 = "%int64_xor" -external shift_left: (int64, int) => int64 = "%int64_lsl" -external shift_right: (int64, int) => int64 = "%int64_asr" -external shift_right_logical: (int64, int) => int64 = "%int64_lsr" -external of_int: int => int64 = "%int64_of_int" -external to_int: int64 => int = "%int64_to_int" -external of_float: float => int64 = "?int64_of_float" -external to_float: int64 => float = "?int64_to_float" -external of_int32: int => int64 = "%int64_of_int32" -external to_int32: int64 => int = "%int64_to_int32" - -let zero = 0L -let one = 1L -let minus_one = -1L -/* let succ n = add n 1L */ -external succ: int64 => int64 = "?int64_succ" -let pred = n => sub(n, 1L) -let abs = n => - if n >= 0L { - n - } else { - neg(n) - } -let min_int = 0x8000000000000000L -let max_int = 0x7FFFFFFFFFFFFFFFL -let lognot = n => logxor(n, -1L) - -external format: (string, int64) => string = "?int64_format" -external to_string: int64 => string = "?int64_to_string" - -external of_string: string => int64 = "?int64_of_string" - -let of_string_opt = s => - /* TODO: expose a non-raising primitive directly. */ - try Some(of_string(s)) catch { - | Failure(_) => None - } - -external bits_of_float: float => int64 = "?int64_bits_of_float" - -external float_of_bits: int64 => float = "?int64_float_of_bits" - -type t = int64 - -let compare = (x: t, y: t) => Pervasives.compare(x, y) -let equal = (x: t, y: t) => compare(x, y) == 0 diff --git a/jscomp/stdlib-406/int64.resi b/jscomp/stdlib-406/int64.resi deleted file mode 100644 index aeb0588..0000000 --- a/jscomp/stdlib-406/int64.resi +++ /dev/null @@ -1,189 +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. */ -/* */ -/* ************************************************************************ */ - -/*** 64-bit integers. - - This module provides operations on the type [int64] of - signed 64-bit integers. Unlike the built-in [int] type, - the type [int64] is guaranteed to be exactly 64-bit wide on all - platforms. All arithmetic operations over [int64] are taken - modulo 2{^64} - - Performance notice: values of type [int64] occupy more memory - space than values of type [int], and arithmetic operations on - [int64] are generally slower than those on [int]. Use [int64] - only when the application requires exact 64-bit arithmetic. -*/ - -/** The 64-bit integer 0. */ -let zero: int64 - -/** The 64-bit integer 1. */ -let one: int64 - -/** The 64-bit integer -1. */ -let minus_one: int64 - -/** Unary negation. */ -external neg: int64 => int64 = "%int64_neg" - -/** Addition. */ -external add: (int64, int64) => int64 = "%int64_add" - -/** Subtraction. */ -external sub: (int64, int64) => int64 = "%int64_sub" - -/** Multiplication. */ -external mul: (int64, int64) => int64 = "%int64_mul" - -/** Integer division. Raise [Division_by_zero] if the second - argument is zero. This division rounds the real quotient of - its arguments towards zero, as specified for {!Pervasives.(/)}. */ -external div: (int64, int64) => int64 = "%int64_div" - -/** Integer remainder. If [y] is not zero, the result - of [Int64.rem x y] satisfies the following property: - [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. - If [y = 0], [Int64.rem x y] raises [Division_by_zero]. */ -external rem: (int64, int64) => int64 = "%int64_mod" - -/** Successor. [Int64.succ x] is [Int64.add x Int64.one]. */ -let succ: int64 => int64 - -/** Predecessor. [Int64.pred x] is [Int64.sub x Int64.one]. */ -let pred: int64 => int64 - -/** Return the absolute value of its argument. */ -let abs: int64 => int64 - -/** The greatest representable 64-bit integer, 2{^63} - 1. */ -let max_int: int64 - -/** The smallest representable 64-bit integer, -2{^63}. */ -let min_int: int64 - -/** Bitwise logical and. */ -external logand: (int64, int64) => int64 = "%int64_and" - -/** Bitwise logical or. */ -external logor: (int64, int64) => int64 = "%int64_or" - -/** Bitwise logical exclusive or. */ -external logxor: (int64, int64) => int64 = "%int64_xor" - -/** Bitwise logical negation. */ -let lognot: int64 => int64 - -/** [Int64.shift_left x y] shifts [x] to the left by [y] bits. - The result is unspecified if [y < 0] or [y >= 64]. */ -external shift_left: (int64, int) => int64 = "%int64_lsl" - -/** [Int64.shift_right x y] shifts [x] to the right by [y] bits. - This is an arithmetic shift: the sign bit of [x] is replicated - and inserted in the vacated bits. - The result is unspecified if [y < 0] or [y >= 64]. */ -external shift_right: (int64, int) => int64 = "%int64_asr" - -/** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. - This is a logical shift: zeroes are inserted in the vacated bits - regardless of the sign of [x]. - The result is unspecified if [y < 0] or [y >= 64]. */ -external shift_right_logical: (int64, int) => int64 = "%int64_lsr" - -/** Convert the given integer (type [int]) to a 64-bit integer - (type [int64]). */ -external of_int: int => int64 = "%int64_of_int" - -/** Convert the given 64-bit integer (type [int64]) to an - integer (type [int]). On 64-bit platforms, the 64-bit integer - is taken modulo 2{^63}, i.e. the high-order bit is lost - during the conversion. On 32-bit platforms, the 64-bit integer - is taken modulo 2{^31}, i.e. the top 33 bits are lost - during the conversion. */ -external to_int: int64 => int = "%int64_to_int" - -/** Convert the given floating-point number to a 64-bit integer, - discarding the fractional part (truncate towards 0). - The result of the conversion is undefined if, after truncation, - the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. */ -external of_float: float => int64 = "?int64_of_float" - -/** Convert the given 64-bit integer to a floating-point number. */ -external to_float: int64 => float = "?int64_to_float" - -/** Convert the given 32-bit integer (type [int]) - to a 64-bit integer (type [int64]). */ -external of_int32: int => int64 = "%int64_of_int32" - -/** Convert the given 64-bit integer (type [int64]) to a - 32-bit integer (type [int]). The 64-bit integer - is taken modulo 2{^32}, i.e. the top 32 bits are lost - during the conversion. */ -external to_int32: int64 => int = "%int64_to_int32" - -/** Convert the given string to a 64-bit integer. - The string is read in decimal (by default, or if the string - begins with [0u]) or in hexadecimal, octal or binary if the - string begins with [0x], [0o] or [0b] respectively. - - The [0u] prefix reads the input as an unsigned integer in the range - [[0, 2*Int64.max_int+1]]. If the input exceeds {!Int64.max_int} - it is converted to the signed integer - [Int64.min_int + input - Int64.max_int - 1]. - - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Raise [Failure "Int64.of_string"] if the given string is not - a valid representation of an integer, or if the integer represented - exceeds the range of integers representable in type [int64]. */ -external of_string: string => int64 = "?int64_of_string" - -/** Same as [of_string], but return [None] instead of raising. - @since 4.05 */ -let of_string_opt: string => option - -/** Return the string representation of its argument, in decimal. */ -let to_string: int64 => string - -/** Return the internal representation of the given float according - to the IEEE 754 floating-point 'double format' bit layout. - Bit 63 of the result represents the sign of the float; - bits 62 to 52 represent the (biased) exponent; bits 51 to 0 - represent the mantissa. */ -external bits_of_float: float => int64 = "?int64_bits_of_float" - -/** Return the floating-point number whose internal representation, - according to the IEEE 754 floating-point 'double format' bit layout, - is the given [int64]. */ -external float_of_bits: int64 => float = "?int64_float_of_bits" - -/** An alias for the type of 64-bit integers. */ -type t = int64 - -/** The comparison function for 64-bit integers, with the same specification as - {!Pervasives.compare}. Along with the type [t], this function [compare] - allows the module [Int64] to be passed as argument to the functors - {!Set.Make} and {!Map.Make}. */ -let compare: (t, t) => int - -/** The equal function for int64s. - @since 4.03.0 */ -let equal: (t, t) => bool - -/* {1 Deprecated functions} */ - -/** Do not use this deprecated function. Instead, - used {!Printf.sprintf} with a [%L...] format. */ -external format: (string, int64) => string = "?int64_format" diff --git a/jscomp/stdlib-406/lazy.res b/jscomp/stdlib-406/lazy.res deleted file mode 100644 index 967946d..0000000 --- a/jscomp/stdlib-406/lazy.res +++ /dev/null @@ -1,68 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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. */ -/* */ -/* ************************************************************************ */ - -/* Module [Lazy]: deferred computations */ - -/* - WARNING: some purple magic is going on here. Do not take this file - as an example of how to program in OCaml. -*/ - -/* We make use of two special tags provided by the runtime: - [lazy_tag] and [forward_tag]. - - A value of type ['a Lazy.t] can be one of three things: - 1. A block of size 1 with tag [lazy_tag]. Its field is a closure of - type [unit -> 'a] that computes the value. - 2. A block of size 1 with tag [forward_tag]. Its field is the value - of type ['a] that was computed. - 3. Anything else except a float. This has type ['a] and is the value - that was computed. - Exceptions are stored in format (1). - The GC will magically change things from (2) to (3) according to its - fancy. - - If OCaml was configured with the -flat-float-array option (which is - currently the default), the following is also true: - We cannot use representation (3) for a [float Lazy.t] because - [caml_make_array] assumes that only a [float] value can have tag - [Double_tag]. - - We have to use the built-in type constructor [lazy_t] to - let the compiler implement the special typing and compilation - rules for the [lazy] keyword. -*/ - -type t<'a> = lazy_t<'a> - -exception Undefined = CamlinternalLazy.Undefined - -external force: t<'a> => 'a = "%lazy_force" - -/* let force = force */ - -let force_val = CamlinternalLazy.force_val - -let from_fun = f => lazy f() - -let from_val = v => lazy v - -let is_val = CamlinternalLazy.is_val - -let lazy_from_fun = from_fun - -let lazy_from_val = from_val - -let lazy_is_val = is_val diff --git a/jscomp/stdlib-406/lazy.resi b/jscomp/stdlib-406/lazy.resi deleted file mode 100644 index fee1eef..0000000 --- a/jscomp/stdlib-406/lazy.resi +++ /dev/null @@ -1,91 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Para, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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. */ -/* */ -/* ************************************************************************ */ - -/*** Deferred computations. */ - -/** A value of type ['a Lazy.t] is a deferred computation, called - a suspension, that has a result of type ['a]. The special - expression syntax [lazy (expr)] makes a suspension of the - computation of [expr], without computing [expr] itself yet. - "Forcing" the suspension will then compute [expr] and return its - result. - - Note: [lazy_t] is the built-in type constructor used by the compiler - for the [lazy] keyword. You should not use it directly. Always use - [Lazy.t] instead. - - Note: [Lazy.force] is not thread-safe. If you use this module in - a multi-threaded program, you will need to add some locks. - - Note: if the program is compiled with the [-rectypes] option, - ill-founded recursive definitions of the form [let rec x = lazy x] - or [let rec x = lazy(lazy(...(lazy x)))] are accepted by the type-checker - and lead, when forced, to ill-formed values that trigger infinite - loops in the garbage collector and other parts of the run-time system. - Without the [-rectypes] option, such ill-founded recursive definitions - are rejected by the type-checker. -*/ -type t<'a> = lazy_t<'a> - -exception Undefined - -/* val force : 'a t -> 'a */ -/** [force x] forces the suspension [x] and returns its result. - If [x] has already been forced, [Lazy.force x] returns the - same value again without recomputing it. If it raised an exception, - the same exception is raised again. - Raise {!Undefined} if the forcing of [x] tries to force [x] itself - recursively. -*/ -external force: t<'a> => 'a = "%lazy_force" - -/** [force_val x] forces the suspension [x] and returns its - result. If [x] has already been forced, [force_val x] - returns the same value again without recomputing it. - Raise {!Undefined} if the forcing of [x] tries to force [x] itself - recursively. - If the computation of [x] raises an exception, it is unspecified - whether [force_val x] raises the same exception or {!Undefined}. -*/ -let force_val: t<'a> => 'a - -/** [from_fun f] is the same as [lazy (f ())] but slightly more efficient. - - [from_fun] should only be used if the function [f] is already defined. - In particular it is always less efficient to write - [from_fun (fun () -> expr)] than [lazy expr]. - - @since 4.00.0 */ -let from_fun: (unit => 'a) => t<'a> - -/** [from_val v] returns an already-forced suspension of [v]. - This is for special purposes only and should not be confused with - [lazy (v)]. - @since 4.00.0 */ -let from_val: 'a => t<'a> - -/** [is_val x] returns [true] if [x] has already been forced and - did not raise an exception. - @since 4.00.0 */ -let is_val: t<'a> => bool - -@deprecated("Use Lazy.from_fun instead.") /** @deprecated synonym for [from_fun]. */ -let lazy_from_fun: (unit => 'a) => t<'a> - -@deprecated("Use Lazy.from_val instead.") /** @deprecated synonym for [from_val]. */ -let lazy_from_val: 'a => t<'a> - -@deprecated("Use Lazy.is_val instead.") /** @deprecated synonym for [is_val]. */ -let lazy_is_val: t<'a> => bool diff --git a/jscomp/stdlib-406/lexing.res b/jscomp/stdlib-406/lexing.res deleted file mode 100644 index 2773ecb..0000000 --- a/jscomp/stdlib-406/lexing.res +++ /dev/null @@ -1,245 +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. */ -/* */ -/* ************************************************************************ */ - -/* The run-time library for lexers generated by camllex */ - -type position = { - pos_fname: string, - pos_lnum: int, - pos_bol: int, - pos_cnum: int, -} - -let dummy_pos = { - pos_fname: "", - pos_lnum: 0, - pos_bol: 0, - pos_cnum: -1, -} - -type rec lexbuf = { - refill_buff: lexbuf => unit, - mutable lex_buffer: bytes, - mutable lex_buffer_len: int, - mutable lex_abs_pos: int, - mutable lex_start_pos: int, - mutable lex_curr_pos: int, - mutable lex_last_pos: int, - mutable lex_last_action: int, - mutable lex_eof_reached: bool, - mutable lex_mem: array, - mutable lex_start_p: position, - mutable lex_curr_p: position, -} - -type lex_tables = { - lex_base: string, - lex_backtrk: string, - lex_default: string, - lex_trans: string, - lex_check: string, - lex_base_code: string, - lex_backtrk_code: string, - lex_default_code: string, - lex_trans_code: string, - lex_check_code: string, - lex_code: string, -} - -external c_engine: (lex_tables, int, lexbuf) => int = "?lex_engine" -external c_new_engine: (lex_tables, int, lexbuf) => int = "?new_lex_engine" - -let engine = (tbl, state, buf) => { - let result = c_engine(tbl, state, buf) - if result >= 0 { - buf.lex_start_p = buf.lex_curr_p - buf.lex_curr_p = { - ...buf.lex_curr_p, - pos_cnum: buf.lex_abs_pos + buf.lex_curr_pos, - } - } - result -} - -let new_engine = (tbl, state, buf) => { - let result = c_new_engine(tbl, state, buf) - if result >= 0 { - buf.lex_start_p = buf.lex_curr_p - buf.lex_curr_p = { - ...buf.lex_curr_p, - pos_cnum: buf.lex_abs_pos + buf.lex_curr_pos, - } - } - result -} - -let lex_refill = (read_fun, aux_buffer, lexbuf) => { - let read = read_fun(aux_buffer, Bytes.length(aux_buffer)) - let n = if read > 0 { - read - } else { - lexbuf.lex_eof_reached = true - 0 - } - - /* Current state of the buffer: - <-------|---------------------|-----------> - | junk | valid data | junk | - ^ ^ ^ ^ - 0 start_pos buffer_end Bytes.length buffer - */ - if lexbuf.lex_buffer_len + n > Bytes.length(lexbuf.lex_buffer) { - /* There is not enough space at the end of the buffer */ - if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n <= Bytes.length(lexbuf.lex_buffer) { - /* But there is enough space if we reclaim the junk at the beginning - of the buffer */ - Bytes.blit( - lexbuf.lex_buffer, - lexbuf.lex_start_pos, - lexbuf.lex_buffer, - 0, - lexbuf.lex_buffer_len - lexbuf.lex_start_pos, - ) - } else { - /* We must grow the buffer. Doubling its size will provide enough - space since n <= String.length aux_buffer <= String.length buffer. - Watch out for string length overflow, though. */ - let newlen = 2 * Bytes.length(lexbuf.lex_buffer) - - if lexbuf.lex_buffer_len - lexbuf.lex_start_pos + n > newlen { - failwith("Lexing.lex_refill: cannot grow buffer") - } - let newbuf = Bytes.create(newlen) - /* Copy the valid data to the beginning of the new buffer */ - Bytes.blit( - lexbuf.lex_buffer, - lexbuf.lex_start_pos, - newbuf, - 0, - lexbuf.lex_buffer_len - lexbuf.lex_start_pos, - ) - lexbuf.lex_buffer = newbuf - } - /* Reallocation or not, we have shifted the data left by - start_pos characters; update the positions */ - let s = lexbuf.lex_start_pos - lexbuf.lex_abs_pos = lexbuf.lex_abs_pos + s - lexbuf.lex_curr_pos = lexbuf.lex_curr_pos - s - lexbuf.lex_start_pos = 0 - lexbuf.lex_last_pos = lexbuf.lex_last_pos - s - lexbuf.lex_buffer_len = lexbuf.lex_buffer_len - s - let t = lexbuf.lex_mem - for i in 0 to Array.length(t) - 1 { - let v = t[i] - if v >= 0 { - t[i] = v - s - } - } - } - /* There is now enough space at the end of the buffer */ - Bytes.blit(aux_buffer, 0, lexbuf.lex_buffer, lexbuf.lex_buffer_len, n) - lexbuf.lex_buffer_len = lexbuf.lex_buffer_len + n -} - -let zero_pos = { - pos_fname: "", - pos_lnum: 1, - pos_bol: 0, - pos_cnum: 0, -} - -let from_function = f => { - refill_buff: lex_refill(f, Bytes.create(512)), - lex_buffer: Bytes.create(1024), - lex_buffer_len: 0, - lex_abs_pos: 0, - lex_start_pos: 0, - lex_curr_pos: 0, - lex_last_pos: 0, - lex_last_action: 0, - lex_mem: [], - lex_eof_reached: false, - lex_start_p: zero_pos, - lex_curr_p: zero_pos, -} - -let from_string = s => { - refill_buff: lexbuf => lexbuf.lex_eof_reached = true, - lex_buffer: Bytes.of_string(s) /* have to make a copy for compatibility - with unsafe-string mode */, - lex_buffer_len: String.length(s), - lex_abs_pos: 0, - lex_start_pos: 0, - lex_curr_pos: 0, - lex_last_pos: 0, - lex_last_action: 0, - lex_mem: [], - lex_eof_reached: true, - lex_start_p: zero_pos, - lex_curr_p: zero_pos, -} - -let lexeme = lexbuf => { - let len = lexbuf.lex_curr_pos - lexbuf.lex_start_pos - Bytes.sub_string(lexbuf.lex_buffer, lexbuf.lex_start_pos, len) -} - -let sub_lexeme = (lexbuf, i1, i2) => { - let len = i2 - i1 - Bytes.sub_string(lexbuf.lex_buffer, i1, len) -} - -let sub_lexeme_opt = (lexbuf, i1, i2) => - if i1 >= 0 { - let len = i2 - i1 - Some(Bytes.sub_string(lexbuf.lex_buffer, i1, len)) - } else { - None - } - -let sub_lexeme_char = (lexbuf, i) => Bytes.get(lexbuf.lex_buffer, i) - -let sub_lexeme_char_opt = (lexbuf, i) => - if i >= 0 { - Some(Bytes.get(lexbuf.lex_buffer, i)) - } else { - None - } - -let lexeme_char = (lexbuf, i) => Bytes.get(lexbuf.lex_buffer, lexbuf.lex_start_pos + i) - -let lexeme_start = lexbuf => lexbuf.lex_start_p.pos_cnum -let lexeme_end = lexbuf => lexbuf.lex_curr_p.pos_cnum - -let lexeme_start_p = lexbuf => lexbuf.lex_start_p -let lexeme_end_p = lexbuf => lexbuf.lex_curr_p - -let new_line = lexbuf => { - let lcp = lexbuf.lex_curr_p - lexbuf.lex_curr_p = { - ...lcp, - pos_lnum: lcp.pos_lnum + 1, - pos_bol: lcp.pos_cnum, - } -} - -/* Discard data left in lexer buffer. */ - -let flush_input = lb => { - lb.lex_curr_pos = 0 - lb.lex_abs_pos = 0 - lb.lex_curr_p = {...lb.lex_curr_p, pos_cnum: 0} - lb.lex_buffer_len = 0 -} diff --git a/jscomp/stdlib-406/lexing.resi b/jscomp/stdlib-406/lexing.resi deleted file mode 100644 index 9a84781..0000000 --- a/jscomp/stdlib-406/lexing.resi +++ /dev/null @@ -1,164 +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. */ -/* */ -/* ************************************************************************ */ - -/*** The run-time library for lexers generated by [ocamllex]. */ - -/* {1 Positions} */ - -/** A value of type [position] describes a point in a source file. - [pos_fname] is the file name; [pos_lnum] is the line number; - [pos_bol] is the offset of the beginning of the line (number - of characters between the beginning of the lexbuf and the beginning - of the line); [pos_cnum] is the offset of the position (number of - characters between the beginning of the lexbuf and the position). - The difference between [pos_cnum] and [pos_bol] is the character - offset within the line (i.e. the column number, assuming each - character is one column wide). - - See the documentation of type [lexbuf] for information about - how the lexing engine will manage positions. - */ -type position = { - pos_fname: string, - pos_lnum: int, - pos_bol: int, - pos_cnum: int, -} - -/** A value of type [position], guaranteed to be different from any - valid position. - */ -let dummy_pos: position - -/* {1 Lexer buffers} */ - -/** The type of lexer buffers. A lexer buffer is the argument passed - to the scanning functions defined by the generated scanners. - The lexer buffer holds the current state of the scanner, plus - a function to refill the buffer from the input. - - At each token, the lexing engine will copy [lex_curr_p] to - [lex_start_p], then change the [pos_cnum] field - of [lex_curr_p] by updating it with the number of characters read - since the start of the [lexbuf]. The other fields are left - unchanged by the lexing engine. In order to keep them - accurate, they must be initialised before the first use of the - lexbuf, and updated by the relevant lexer actions (i.e. at each - end of line -- see also [new_line]). - */ -type rec lexbuf = { - refill_buff: lexbuf => unit, - mutable lex_buffer: bytes, - mutable lex_buffer_len: int, - mutable lex_abs_pos: int, - mutable lex_start_pos: int, - mutable lex_curr_pos: int, - mutable lex_last_pos: int, - mutable lex_last_action: int, - mutable lex_eof_reached: bool, - mutable lex_mem: array, - mutable lex_start_p: position, - mutable lex_curr_p: position, -} - -/** Create a lexer buffer which reads from - the given string. Reading starts from the first character in - the string. An end-of-input condition is generated when the - end of the string is reached. */ -let from_string: string => lexbuf - -/** Create a lexer buffer with the given function as its reading method. - When the scanner needs more characters, it will call the given - function, giving it a byte sequence [s] and a byte - count [n]. The function should put [n] bytes or fewer in [s], - starting at index 0, and return the number of bytes - provided. A return value of 0 means end of input. */ -let from_function: ((bytes, int) => int) => lexbuf - -/* {1 Functions for lexer semantic actions} */ - -/* The following functions can be called from the semantic actions - of lexer definitions (the ML code enclosed in braces that - computes the value returned by lexing functions). They give - access to the character string matched by the regular expression - associated with the semantic action. These functions must be - applied to the argument [lexbuf], which, in the code generated by - [ocamllex], is bound to the lexer buffer passed to the parsing - function. */ - -/** [Lexing.lexeme lexbuf] returns the string matched by - the regular expression. */ -let lexeme: lexbuf => string - -/** [Lexing.lexeme_char lexbuf i] returns character number [i] in - the matched string. */ -let lexeme_char: (lexbuf, int) => char - -/** [Lexing.lexeme_start lexbuf] returns the offset in the - input stream of the first character of the matched string. - The first character of the stream has offset 0. */ -let lexeme_start: lexbuf => int - -/** [Lexing.lexeme_end lexbuf] returns the offset in the input stream - of the character following the last character of the matched - string. The first character of the stream has offset 0. */ -let lexeme_end: lexbuf => int - -/** Like [lexeme_start], but return a complete [position] instead - of an offset. */ -let lexeme_start_p: lexbuf => position - -/** Like [lexeme_end], but return a complete [position] instead - of an offset. */ -let lexeme_end_p: lexbuf => position - -/** Update the [lex_curr_p] field of the lexbuf to reflect the start - of a new line. You can call this function in the semantic action - of the rule that matches the end-of-line character. - @since 3.11.0 -*/ -let new_line: lexbuf => unit - -/* {1 Miscellaneous functions} */ - -/** Discard the contents of the buffer and reset the current - position to 0. The next use of the lexbuf will trigger a - refill. */ -let flush_input: lexbuf => unit - -/* The following definitions are used by the generated scanners only. - They are not intended to be used directly by user programs. */ - -let sub_lexeme: (lexbuf, int, int) => string -let sub_lexeme_opt: (lexbuf, int, int) => option -let sub_lexeme_char: (lexbuf, int) => char -let sub_lexeme_char_opt: (lexbuf, int) => option - -type lex_tables = { - lex_base: string, - lex_backtrk: string, - lex_default: string, - lex_trans: string, - lex_check: string, - lex_base_code: string, - lex_backtrk_code: string, - lex_default_code: string, - lex_trans_code: string, - lex_check_code: string, - lex_code: string, -} - -let engine: (lex_tables, int, lexbuf) => int -let new_engine: (lex_tables, int, lexbuf) => int diff --git a/jscomp/stdlib-406/list.res b/jscomp/stdlib-406/list.res deleted file mode 100644 index c8ae708..0000000 --- a/jscomp/stdlib-406/list.res +++ /dev/null @@ -1,749 +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. */ -/* */ -/* ************************************************************************ */ - -/* List operations */ - -let rec length_aux = (len, param) => - switch param { - | list{} => len - | list{_, ...l} => length_aux(len + 1, l) - } - -let length = l => length_aux(0, l) - -let cons = (a, l) => list{a, ...l} - -let hd = param => - switch param { - | list{} => failwith("hd") - | list{a, ..._} => a - } - -let tl = param => - switch param { - | list{} => failwith("tl") - | list{_, ...l} => l - } - -let nth = (l, n) => - if n < 0 { - invalid_arg("List.nth") - } else { - let rec nth_aux = (l, n) => - switch l { - | list{} => failwith("nth") - | list{a, ...l} => - if n == 0 { - a - } else { - nth_aux(l, n - 1) - } - } - nth_aux(l, n) - } - -let nth_opt = (l, n) => - if n < 0 { - invalid_arg("List.nth") - } else { - let rec nth_aux = (l, n) => - switch l { - | list{} => None - | list{a, ...l} => - if n == 0 { - Some(a) - } else { - nth_aux(l, n - 1) - } - } - nth_aux(l, n) - } - -let append = \"@" - -let rec rev_append = (l1, l2) => - switch l1 { - | list{} => l2 - | list{a, ...l} => rev_append(l, list{a, ...l2}) - } - -let rev = l => rev_append(l, list{}) - -let rec init_tailrec_aux = (acc, i, n, f) => - if i >= n { - acc - } else { - init_tailrec_aux(list{f(i), ...acc}, i + 1, n, f) - } - -let rec init_aux = (i, n, f) => - if i >= n { - list{} - } else { - let r = f(i) - list{r, ...init_aux(i + 1, n, f)} - } - -let init = (len, f) => - if len < 0 { - invalid_arg("List.init") - } else if len > 10_000 { - rev(init_tailrec_aux(list{}, 0, len, f)) - } else { - init_aux(0, len, f) - } - -let rec flatten = param => - switch param { - | list{} => list{} - | list{l, ...r} => \"@"(l, flatten(r)) - } - -let concat = flatten - -let rec map = (f, param) => - switch param { - | list{} => list{} - | list{a, ...l} => - let r = f(a) - list{r, ...map(f, l)} - } - -let rec mapi = (i, f, param) => - switch param { - | list{} => list{} - | list{a, ...l} => - let r = f(i, a) - list{r, ...mapi(i + 1, f, l)} - } - -let mapi = (f, l) => mapi(0, f, l) - -let rev_map = (f, l) => { - let rec rmap_f = (accu, param) => - switch param { - | list{} => accu - | list{a, ...l} => rmap_f(list{f(a), ...accu}, l) - } - - rmap_f(list{}, l) -} - -let rec iter = (f, param) => - switch param { - | list{} => () - | list{a, ...l} => - f(a) - iter(f, l) - } - -let rec iteri = (i, f, param) => - switch param { - | list{} => () - | list{a, ...l} => - f(i, a) - iteri(i + 1, f, l) - } - -let iteri = (f, l) => iteri(0, f, l) - -let rec fold_left = (f, accu, l) => - switch l { - | list{} => accu - | list{a, ...l} => fold_left(f, f(accu, a), l) - } - -let rec fold_right = (f, l, accu) => - switch l { - | list{} => accu - | list{a, ...l} => f(a, fold_right(f, l, accu)) - } - -let rec map2 = (f, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => list{} - | (list{a1, ...l1}, list{a2, ...l2}) => - let r = f(a1, a2) - list{r, ...map2(f, l1, l2)} - | (_, _) => invalid_arg("List.map2") - } - -let rev_map2 = (f, l1, l2) => { - let rec rmap2_f = (accu, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => accu - | (list{a1, ...l1}, list{a2, ...l2}) => rmap2_f(list{f(a1, a2), ...accu}, l1, l2) - | (_, _) => invalid_arg("List.rev_map2") - } - - rmap2_f(list{}, l1, l2) -} - -let rec iter2 = (f, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => () - | (list{a1, ...l1}, list{a2, ...l2}) => - f(a1, a2) - iter2(f, l1, l2) - | (_, _) => invalid_arg("List.iter2") - } - -let rec fold_left2 = (f, accu, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => accu - | (list{a1, ...l1}, list{a2, ...l2}) => fold_left2(f, f(accu, a1, a2), l1, l2) - | (_, _) => invalid_arg("List.fold_left2") - } - -let rec fold_right2 = (f, l1, l2, accu) => - switch (l1, l2) { - | (list{}, list{}) => accu - | (list{a1, ...l1}, list{a2, ...l2}) => f(a1, a2, fold_right2(f, l1, l2, accu)) - | (_, _) => invalid_arg("List.fold_right2") - } - -let rec for_all = (p, param) => - switch param { - | list{} => true - | list{a, ...l} => p(a) && for_all(p, l) - } - -let rec exists = (p, param) => - switch param { - | list{} => false - | list{a, ...l} => p(a) || exists(p, l) - } - -let rec for_all2 = (p, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => true - | (list{a1, ...l1}, list{a2, ...l2}) => p(a1, a2) && for_all2(p, l1, l2) - | (_, _) => invalid_arg("List.for_all2") - } - -let rec exists2 = (p, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => false - | (list{a1, ...l1}, list{a2, ...l2}) => p(a1, a2) || exists2(p, l1, l2) - | (_, _) => invalid_arg("List.exists2") - } - -let rec mem = (x, param) => - switch param { - | list{} => false - | list{a, ...l} => compare(a, x) == 0 || mem(x, l) - } - -let rec memq = (x, param) => - switch param { - | list{} => false - | list{a, ...l} => a === x || memq(x, l) - } - -let rec assoc = (x, param) => - switch param { - | list{} => raise(Not_found) - | list{(a, b), ...l} => - if compare(a, x) == 0 { - b - } else { - assoc(x, l) - } - } - -let rec assoc_opt = (x, param) => - switch param { - | list{} => None - | list{(a, b), ...l} => - if compare(a, x) == 0 { - Some(b) - } else { - assoc_opt(x, l) - } - } - -let rec assq = (x, param) => - switch param { - | list{} => raise(Not_found) - | list{(a, b), ...l} => - if a === x { - b - } else { - assq(x, l) - } - } - -let rec assq_opt = (x, param) => - switch param { - | list{} => None - | list{(a, b), ...l} => - if a === x { - Some(b) - } else { - assq_opt(x, l) - } - } - -let rec mem_assoc = (x, param) => - switch param { - | list{} => false - | list{(a, _), ...l} => compare(a, x) == 0 || mem_assoc(x, l) - } - -let rec mem_assq = (x, param) => - switch param { - | list{} => false - | list{(a, _), ...l} => a === x || mem_assq(x, l) - } - -let rec remove_assoc = (x, param) => - switch param { - | list{} => list{} - | list{(a, _) as pair, ...l} => - if compare(a, x) == 0 { - l - } else { - list{pair, ...remove_assoc(x, l)} - } - } - -let rec remove_assq = (x, param) => - switch param { - | list{} => list{} - | list{(a, _) as pair, ...l} => - if a === x { - l - } else { - list{pair, ...remove_assq(x, l)} - } - } - -let rec find = (p, param) => - switch param { - | list{} => raise(Not_found) - | list{x, ...l} => - if p(x) { - x - } else { - find(p, l) - } - } - -let rec find_opt = (p, param) => - switch param { - | list{} => None - | list{x, ...l} => - if p(x) { - Some(x) - } else { - find_opt(p, l) - } - } - -let find_all = p => { - let rec find = (accu, param) => - switch param { - | list{} => rev(accu) - | list{x, ...l} => - if p(x) { - find(list{x, ...accu}, l) - } else { - find(accu, l) - } - } - find(list{}) -} - -let filter = find_all - -let partition = (p, l) => { - let rec part = (yes, no, param) => - switch param { - | list{} => (rev(yes), rev(no)) - | list{x, ...l} => - if p(x) { - part(list{x, ...yes}, no, l) - } else { - part(yes, list{x, ...no}, l) - } - } - part(list{}, list{}, l) -} - -let rec split = param => - switch param { - | list{} => (list{}, list{}) - | list{(x, y), ...l} => - let (rx, ry) = split(l) - (list{x, ...rx}, list{y, ...ry}) - } - -let rec combine = (l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => list{} - | (list{a1, ...l1}, list{a2, ...l2}) => list{(a1, a2), ...combine(l1, l2)} - | (_, _) => invalid_arg("List.combine") - } - -/* sorting */ - -let rec merge = (cmp, l1, l2) => - switch (l1, l2) { - | (list{}, l2) => l2 - | (l1, list{}) => l1 - | (list{h1, ...t1}, list{h2, ...t2}) => - if cmp(h1, h2) <= 0 { - list{h1, ...merge(cmp, t1, l2)} - } else { - list{h2, ...merge(cmp, l1, t2)} - } - } - -let rec chop = (k, l) => - if k == 0 { - l - } else { - switch l { - | list{_, ...t} => chop(k - 1, t) - | _ => assert(false) - } - } - -let stable_sort = (cmp, l) => { - let rec rev_merge = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - if cmp(h1, h2) <= 0 { - rev_merge(t1, l2, list{h1, ...accu}) - } else { - rev_merge(l1, t2, list{h2, ...accu}) - } - } - - let rec rev_merge_rev = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - if cmp(h1, h2) > 0 { - rev_merge_rev(t1, l2, list{h1, ...accu}) - } else { - rev_merge_rev(l1, t2, list{h2, ...accu}) - } - } - - let rec sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - if cmp(x1, x2) <= 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - if cmp(x1, x2) <= 0 { - if cmp(x2, x3) <= 0 { - list{x1, x2, x3} - } else if cmp(x1, x3) <= 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } else if cmp(x1, x3) <= 0 { - list{x2, x1, x3} - } else if cmp(x2, x3) <= 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = rev_sort(n1, l) - let s2 = rev_sort(n2, l2) - rev_merge_rev(s1, s2, list{}) - } - and rev_sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - if cmp(x1, x2) > 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - if cmp(x1, x2) > 0 { - if cmp(x2, x3) > 0 { - list{x1, x2, x3} - } else if cmp(x1, x3) > 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } else if cmp(x1, x3) > 0 { - list{x2, x1, x3} - } else if cmp(x2, x3) > 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = sort(n1, l) - let s2 = sort(n2, l2) - rev_merge(s1, s2, list{}) - } - - let len = length(l) - if len < 2 { - l - } else { - sort(len, l) - } -} - -let sort = stable_sort -let fast_sort = stable_sort - -/* Note: on a list of length between about 100000 (depending on the minor - heap size and the type of the list) and Sys.max_array_size, it is - actually faster to use the following, but it might also use more memory - because the argument list cannot be deallocated incrementally. - - Also, there seems to be a bug in this code or in the - implementation of obj_truncate. - -external obj_truncate : 'a array -> int -> unit = "caml_obj_truncate" - -let array_to_list_in_place a = - let l = Array.length a in - let rec loop accu n p = - if p <= 0 then accu else begin - if p = n then begin - obj_truncate a p; - loop (a.(p-1) :: accu) (n-1000) (p-1) - end else begin - loop (a.(p-1) :: accu) n (p-1) - end - end - in - loop [] (l-1000) l - - -let stable_sort cmp l = - let a = Array.of_list l in - Array.stable_sort cmp a; - array_to_list_in_place a - -*/ - -/* sorting + removing duplicates */ - -let sort_uniq = (cmp, l) => { - let rec rev_merge = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = cmp(h1, h2) - if c == 0 { - rev_merge(t1, t2, list{h1, ...accu}) - } else if c < 0 { - rev_merge(t1, l2, list{h1, ...accu}) - } else { - rev_merge(l1, t2, list{h2, ...accu}) - } - } - - let rec rev_merge_rev = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = cmp(h1, h2) - if c == 0 { - rev_merge_rev(t1, t2, list{h1, ...accu}) - } else if c > 0 { - rev_merge_rev(t1, l2, list{h1, ...accu}) - } else { - rev_merge_rev(l1, t2, list{h2, ...accu}) - } - } - - let rec sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - list{x1} - } else if c < 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x2} - } else if c < 0 { - list{x2, x3} - } else { - list{x3, x2} - } - } else if c < 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x1, x2} - } else if c < 0 { - list{x1, x2, x3} - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x1, x2} - } else if c < 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x2, x1} - } else if c < 0 { - list{x2, x1, x3} - } else { - let c = cmp(x2, x3) - if c == 0 { - list{x2, x1} - } else if c < 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - } - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = rev_sort(n1, l) - let s2 = rev_sort(n2, l2) - rev_merge_rev(s1, s2, list{}) - } - and rev_sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - list{x1} - } else if c > 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x2} - } else if c > 0 { - list{x2, x3} - } else { - list{x3, x2} - } - } else if c > 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x1, x2} - } else if c > 0 { - list{x1, x2, x3} - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x1, x2} - } else if c > 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x2, x1} - } else if c > 0 { - list{x2, x1, x3} - } else { - let c = cmp(x2, x3) - if c == 0 { - list{x2, x1} - } else if c > 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - } - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = sort(n1, l) - let s2 = sort(n2, l2) - rev_merge(s1, s2, list{}) - } - - let len = length(l) - if len < 2 { - l - } else { - sort(len, l) - } -} - -let rec compare_lengths = (l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => 0 - | (list{}, _) => -1 - | (_, list{}) => 1 - | (list{_, ...l1}, list{_, ...l2}) => compare_lengths(l1, l2) - } - -let rec compare_length_with = (l, n) => - switch l { - | list{} => - if n == 0 { - 0 - } else if n > 0 { - -1 - } else { - 1 - } - | list{_, ...l} => - if n <= 0 { - 1 - } else { - compare_length_with(l, n - 1) - } - } diff --git a/jscomp/stdlib-406/list.resi b/jscomp/stdlib-406/list.resi deleted file mode 100644 index 27e82bb..0000000 --- a/jscomp/stdlib-406/list.resi +++ /dev/null @@ -1,333 +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. */ -/* */ -/* ************************************************************************ */ - -/*** List operations. - - Some functions are flagged as not tail-recursive. A tail-recursive - function uses constant stack space, while a non-tail-recursive function - uses stack space proportional to the length of its list argument, which - can be a problem with very long lists. When the function takes several - list arguments, an approximate formula giving stack usage (in some - unspecified constant unit) is shown in parentheses. - - The above considerations can usually be ignored if your lists are not - longer than about 10000 elements. -*/ - -/** Return the length (number of elements) of the given list. */ -let length: list<'a> => int - -/** Compare the lengths of two lists. [compare_lengths l1 l2] is - equivalent to [compare (length l1) (length l2)], except that - the computation stops after itering on the shortest list. - @since 4.05.0 - */ -let compare_lengths: (list<'a>, list<'b>) => int - -/** Compare the length of a list to an integer. [compare_length_with l n] is - equivalent to [compare (length l) n], except that - the computation stops after at most [n] iterations on the list. - @since 4.05.0 -*/ -let compare_length_with: (list<'a>, int) => int - -/** [cons x xs] is [x :: xs] - @since 4.03.0 -*/ -let cons: ('a, list<'a>) => list<'a> - -/** Return the first element of the given list. Raise - [Failure "hd"] if the list is empty. */ -let hd: list<'a> => 'a - -/** Return the given list without its first element. Raise - [Failure "tl"] if the list is empty. */ -let tl: list<'a> => list<'a> - -/** Return the [n]-th element of the given list. - The first element (head of the list) is at position 0. - Raise [Failure "nth"] if the list is too short. - Raise [Invalid_argument "List.nth"] if [n] is negative. */ -let nth: (list<'a>, int) => 'a - -/** Return the [n]-th element of the given list. - The first element (head of the list) is at position 0. - Return [None] if the list is too short. - Raise [Invalid_argument "List.nth"] if [n] is negative. - @since 4.05 -*/ -let nth_opt: (list<'a>, int) => option<'a> - -/** List reversal. */ -let rev: list<'a> => list<'a> - -/** [List.init len f] is [f 0; f 1; ...; f (len-1)], evaluated left to right. - - @raise Invalid_argument if len < 0. - @since 4.06.0 -*/ -let init: (int, int => 'a) => list<'a> - -/** Concatenate two lists. Same as the infix operator [@]. - Not tail-recursive (length of the first argument). */ -let append: (list<'a>, list<'a>) => list<'a> - -/** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. - This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is - tail-recursive and more efficient. */ -let rev_append: (list<'a>, list<'a>) => list<'a> - -/** Concatenate a list of lists. The elements of the argument are all - concatenated together (in the same order) to give the result. - Not tail-recursive - (length of the argument + length of the longest sub-list). */ -let concat: list> => list<'a> - -/** An alias for [concat]. */ -let flatten: list> => list<'a> - -/* {1 Iterators} */ - -/** [List.iter f [a1; ...; an]] applies function [f] in turn to - [a1; ...; an]. It is equivalent to - [begin f a1; f a2; ...; f an; () end]. */ -let iter: ('a => unit, list<'a>) => unit - -/** Same as {!List.iter}, but the function is applied to the index of - the element as first argument (counting from 0), and the element - itself as second argument. - @since 4.00.0 -*/ -let iteri: ((int, 'a) => unit, list<'a>) => unit - -/** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], - and builds the list [[f a1; ...; f an]] - with the results returned by [f]. Not tail-recursive. */ -let map: ('a => 'b, list<'a>) => list<'b> - -/** Same as {!List.map}, but the function is applied to the index of - the element as first argument (counting from 0), and the element - itself as second argument. Not tail-recursive. - @since 4.00.0 -*/ -let mapi: ((int, 'a) => 'b, list<'a>) => list<'b> - -/** [List.rev_map f l] gives the same result as - {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and - more efficient. */ -let rev_map: ('a => 'b, list<'a>) => list<'b> - -/** [List.fold_left f a [b1; ...; bn]] is - [f (... (f (f a b1) b2) ...) bn]. */ -let fold_left: (('a, 'b) => 'a, 'a, list<'b>) => 'a - -/** [List.fold_right f [a1; ...; an] b] is - [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. */ -let fold_right: (('a, 'b) => 'b, list<'a>, 'b) => 'b - -/* {1 Iterators on two lists} */ - -/** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn - [f a1 b1; ...; f an bn]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let iter2: (('a, 'b) => unit, list<'a>, list<'b>) => unit - -/** [List.map2 f [a1; ...; an] [b1; ...; bn]] is - [[f a1 b1; ...; f an bn]]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. Not tail-recursive. */ -let map2: (('a, 'b) => 'c, list<'a>, list<'b>) => list<'c> - -/** [List.rev_map2 f l1 l2] gives the same result as - {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and - more efficient. */ -let rev_map2: (('a, 'b) => 'c, list<'a>, list<'b>) => list<'c> - -/** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is - [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let fold_left2: (('a, 'b, 'c) => 'a, 'a, list<'b>, list<'c>) => 'a - -/** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is - [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. Not tail-recursive. */ -let fold_right2: (('a, 'b, 'c) => 'c, list<'a>, list<'b>, 'c) => 'c - -/* {1 List scanning} */ - -/** [for_all p [a1; ...; an]] checks if all elements of the list - satisfy the predicate [p]. That is, it returns - [(p a1) && (p a2) && ... && (p an)]. */ -let for_all: ('a => bool, list<'a>) => bool - -/** [exists p [a1; ...; an]] checks if at least one element of - the list satisfies the predicate [p]. That is, it returns - [(p a1) || (p a2) || ... || (p an)]. */ -let exists: ('a => bool, list<'a>) => bool - -/** Same as {!List.for_all}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let for_all2: (('a, 'b) => bool, list<'a>, list<'b>) => bool - -/** Same as {!List.exists}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let exists2: (('a, 'b) => bool, list<'a>, list<'b>) => bool - -/** [mem a l] is true if and only if [a] is equal - to an element of [l]. */ -let mem: ('a, list<'a>) => bool - -/** Same as {!List.mem}, but uses physical equality instead of structural - equality to compare list elements. */ -let memq: ('a, list<'a>) => bool - -/* {1 List searching} */ - -/** [find p l] returns the first element of the list [l] - that satisfies the predicate [p]. - Raise [Not_found] if there is no value that satisfies [p] in the - list [l]. */ -let find: ('a => bool, list<'a>) => 'a - -/** [find_opt p l] returns the first element of the list [l] that - satisfies the predicate [p], or [None] if there is no value that - satisfies [p] in the list [l]. - @since 4.05 */ -let find_opt: ('a => bool, list<'a>) => option<'a> - -/** [filter p l] returns all the elements of the list [l] - that satisfy the predicate [p]. The order of the elements - in the input list is preserved. */ -let filter: ('a => bool, list<'a>) => list<'a> - -/** [find_all] is another name for {!List.filter}. */ -let find_all: ('a => bool, list<'a>) => list<'a> - -/** [partition p l] returns a pair of lists [(l1, l2)], where - [l1] is the list of all the elements of [l] that - satisfy the predicate [p], and [l2] is the list of all the - elements of [l] that do not satisfy [p]. - The order of the elements in the input list is preserved. */ -let partition: ('a => bool, list<'a>) => (list<'a>, list<'a>) - -/* {1 Association lists} */ - -/** [assoc a l] returns the value associated with key [a] in the list of - pairs [l]. That is, - [assoc a [ ...; (a,b); ...] = b] - if [(a,b)] is the leftmost binding of [a] in list [l]. - Raise [Not_found] if there is no value associated with [a] in the - list [l]. */ -let assoc: ('a, list<('a, 'b)>) => 'b - -/** [assoc_opt a l] returns the value associated with key [a] in the list of - pairs [l]. That is, - [assoc_opt a [ ...; (a,b); ...] = b] - if [(a,b)] is the leftmost binding of [a] in list [l]. - Returns [None] if there is no value associated with [a] in the - list [l]. - @since 4.05 */ -let assoc_opt: ('a, list<('a, 'b)>) => option<'b> - -/** Same as {!List.assoc}, but uses physical equality instead of structural - equality to compare keys. */ -let assq: ('a, list<('a, 'b)>) => 'b - -/** Same as {!List.assoc_opt}, but uses physical equality instead of structural - equality to compare keys. - @since 4.05 */ -let assq_opt: ('a, list<('a, 'b)>) => option<'b> - -/** Same as {!List.assoc}, but simply return true if a binding exists, - and false if no bindings exist for the given key. */ -let mem_assoc: ('a, list<('a, 'b)>) => bool - -/** Same as {!List.mem_assoc}, but uses physical equality instead of - structural equality to compare keys. */ -let mem_assq: ('a, list<('a, 'b)>) => bool - -/** [remove_assoc a l] returns the list of - pairs [l] without the first pair with key [a], if any. - Not tail-recursive. */ -let remove_assoc: ('a, list<('a, 'b)>) => list<('a, 'b)> - -/** Same as {!List.remove_assoc}, but uses physical equality instead - of structural equality to compare keys. Not tail-recursive. */ -let remove_assq: ('a, list<('a, 'b)>) => list<('a, 'b)> - -/* {1 Lists of pairs} */ - -/** Transform a list of pairs into a pair of lists: - [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. - Not tail-recursive. -*/ -let split: list<('a, 'b)> => (list<'a>, list<'b>) - -/** Transform a pair of lists into a list of pairs: - [combine [a1; ...; an] [b1; ...; bn]] is - [[(a1,b1); ...; (an,bn)]]. - Raise [Invalid_argument] if the two lists - have different lengths. Not tail-recursive. */ -let combine: (list<'a>, list<'b>) => list<('a, 'b)> - -/* {1 Sorting} */ - -/** Sort a list in increasing order according to a comparison - function. The comparison function must return 0 if its arguments - compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller (see Array.sort for - a complete specification). For example, - {!Pervasives.compare} is a suitable comparison function. - The resulting list is sorted in increasing order. - [List.sort] is guaranteed to run in constant heap space - (in addition to the size of the result list) and logarithmic - stack space. - - The current implementation uses Merge Sort. It runs in constant - heap space and logarithmic stack space. -*/ -let sort: (('a, 'a) => int, list<'a>) => list<'a> - -/** Same as {!List.sort}, but the sorting algorithm is guaranteed to - be stable (i.e. elements that compare equal are kept in their - original order) . - - The current implementation uses Merge Sort. It runs in constant - heap space and logarithmic stack space. -*/ -let stable_sort: (('a, 'a) => int, list<'a>) => list<'a> - -/** Same as {!List.sort} or {!List.stable_sort}, whichever is faster - on typical input. */ -let fast_sort: (('a, 'a) => int, list<'a>) => list<'a> - -/** Same as {!List.sort}, but also remove duplicates. - @since 4.02.0 */ -let sort_uniq: (('a, 'a) => int, list<'a>) => list<'a> - -/** Merge two lists: - Assuming that [l1] and [l2] are sorted according to the - comparison function [cmp], [merge cmp l1 l2] will return a - sorted list containing all the elements of [l1] and [l2]. - If several elements compare equal, the elements of [l1] will be - before the elements of [l2]. - Not tail-recursive (sum of the lengths of the arguments). -*/ -let merge: (('a, 'a) => int, list<'a>, list<'a>) => list<'a> diff --git a/jscomp/stdlib-406/listLabels.res b/jscomp/stdlib-406/listLabels.res deleted file mode 100644 index 48d46d9..0000000 --- a/jscomp/stdlib-406/listLabels.res +++ /dev/null @@ -1,748 +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. */ -/* */ -/* ************************************************************************ */ - -/* List operations */ - -let rec length_aux = (len, param) => - switch param { - | list{} => len - | list{_, ...l} => length_aux(len + 1, l) - } - -let length = l => length_aux(0, l) - -let cons = (a, l) => list{a, ...l} - -let hd = param => - switch param { - | list{} => failwith("hd") - | list{a, ..._} => a - } - -let tl = param => - switch param { - | list{} => failwith("tl") - | list{_, ...l} => l - } - -let nth = (l, n) => - if n < 0 { - invalid_arg("List.nth") - } else { - let rec nth_aux = (l, n) => - switch l { - | list{} => failwith("nth") - | list{a, ...l} => - if n == 0 { - a - } else { - nth_aux(l, n - 1) - } - } - nth_aux(l, n) - } - -let nth_opt = (l, n) => - if n < 0 { - invalid_arg("List.nth") - } else { - let rec nth_aux = (l, n) => - switch l { - | list{} => None - | list{a, ...l} => - if n == 0 { - Some(a) - } else { - nth_aux(l, n - 1) - } - } - nth_aux(l, n) - } - -let append = \"@" - -let rec rev_append = (l1, l2) => - switch l1 { - | list{} => l2 - | list{a, ...l} => rev_append(l, list{a, ...l2}) - } - -let rev = l => rev_append(l, list{}) - -let rec init_tailrec_aux = (acc, i, n, f) => - if i >= n { - acc - } else { - init_tailrec_aux(list{f(i), ...acc}, i + 1, n, f) - } - -let rec init_aux = (i, n, f) => - if i >= n { - list{} - } else { - let r = f(i) - list{r, ...init_aux(i + 1, n, f)} - } - -let init = (~len, ~f) => - if len < 0 { - invalid_arg("List.init") - } else if len > 10_000 { - rev(init_tailrec_aux(list{}, 0, len, f)) - } else { - init_aux(0, len, f) - } - -let rec flatten = param => - switch param { - | list{} => list{} - | list{l, ...r} => \"@"(l, flatten(r)) - } - -let concat = flatten - -let rec map = (~f, param) => - switch param { - | list{} => list{} - | list{a, ...l} => - let r = f(a) - list{r, ...map(~f, l)} - } - -let rec mapi = (i, f, param) => - switch param { - | list{} => list{} - | list{a, ...l} => - let r = f(i, a) - list{r, ...mapi(i + 1, f, l)} - } - -let mapi = (~f, l) => mapi(0, f, l) - -let rev_map = (~f, l) => { - let rec rmap_f = (accu, param) => - switch param { - | list{} => accu - | list{a, ...l} => rmap_f(list{f(a), ...accu}, l) - } - - rmap_f(list{}, l) -} - -let rec iter = (~f, param) => - switch param { - | list{} => () - | list{a, ...l} => - f(a) - iter(~f, l) - } - -let rec iteri = (i, f, param) => - switch param { - | list{} => () - | list{a, ...l} => - f(i, a) - iteri(i + 1, f, l) - } - -let iteri = (~f, l) => iteri(0, f, l) - -let rec fold_left = (~f, ~init as accu, l) => - switch l { - | list{} => accu - | list{a, ...l} => fold_left(~f, ~init=f(accu, a), l) - } - -let rec fold_right = (~f, l, ~init as accu) => - switch l { - | list{} => accu - | list{a, ...l} => f(a, fold_right(~f, l, ~init=accu)) - } - -let rec map2 = (~f, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => list{} - | (list{a1, ...l1}, list{a2, ...l2}) => - let r = f(a1, a2) - list{r, ...map2(~f, l1, l2)} - | (_, _) => invalid_arg("List.map2") - } - -let rev_map2 = (~f, l1, l2) => { - let rec rmap2_f = (accu, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => accu - | (list{a1, ...l1}, list{a2, ...l2}) => rmap2_f(list{f(a1, a2), ...accu}, l1, l2) - | (_, _) => invalid_arg("List.rev_map2") - } - - rmap2_f(list{}, l1, l2) -} - -let rec iter2 = (~f, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => () - | (list{a1, ...l1}, list{a2, ...l2}) => - f(a1, a2) - iter2(~f, l1, l2) - | (_, _) => invalid_arg("List.iter2") - } - -let rec fold_left2 = (~f, ~init as accu, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => accu - | (list{a1, ...l1}, list{a2, ...l2}) => fold_left2(~f, ~init=f(accu, a1, a2), l1, l2) - | (_, _) => invalid_arg("List.fold_left2") - } - -let rec fold_right2 = (~f, l1, l2, ~init as accu) => - switch (l1, l2) { - | (list{}, list{}) => accu - | (list{a1, ...l1}, list{a2, ...l2}) => f(a1, a2, fold_right2(~f, l1, l2, ~init=accu)) - | (_, _) => invalid_arg("List.fold_right2") - } - -let rec for_all = (~f as p, param) => - switch param { - | list{} => true - | list{a, ...l} => p(a) && for_all(~f=p, l) - } - -let rec exists = (~f as p, param) => - switch param { - | list{} => false - | list{a, ...l} => p(a) || exists(~f=p, l) - } - -let rec for_all2 = (~f as p, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => true - | (list{a1, ...l1}, list{a2, ...l2}) => p(a1, a2) && for_all2(~f=p, l1, l2) - | (_, _) => invalid_arg("List.for_all2") - } - -let rec exists2 = (~f as p, l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => false - | (list{a1, ...l1}, list{a2, ...l2}) => p(a1, a2) || exists2(~f=p, l1, l2) - | (_, _) => invalid_arg("List.exists2") - } - -let rec mem = (x, ~set) => - switch set { - | list{} => false - | list{a, ...l} => compare(a, x) == 0 || mem(x, ~set=l) - } - -let rec memq = (x, ~set) => - switch set { - | list{} => false - | list{a, ...l} => a === x || memq(x, ~set=l) - } - -let rec assoc = (x, param) => - switch param { - | list{} => raise(Not_found) - | list{(a, b), ...l} => - if compare(a, x) == 0 { - b - } else { - assoc(x, l) - } - } - -let rec assoc_opt = (x, param) => - switch param { - | list{} => None - | list{(a, b), ...l} => - if compare(a, x) == 0 { - Some(b) - } else { - assoc_opt(x, l) - } - } - -let rec assq = (x, param) => - switch param { - | list{} => raise(Not_found) - | list{(a, b), ...l} => - if a === x { - b - } else { - assq(x, l) - } - } - -let rec assq_opt = (x, param) => - switch param { - | list{} => None - | list{(a, b), ...l} => - if a === x { - Some(b) - } else { - assq_opt(x, l) - } - } - -let rec mem_assoc = (x, ~map) => - switch map { - | list{} => false - | list{(a, _), ...l} => compare(a, x) == 0 || mem_assoc(x, ~map=l) - } - -let rec mem_assq = (x, ~map) => - switch map { - | list{} => false - | list{(a, _), ...l} => a === x || mem_assq(x, ~map=l) - } - -let rec remove_assoc = (x, param) => - switch param { - | list{} => list{} - | list{(a, _) as pair, ...l} => - if compare(a, x) == 0 { - l - } else { - list{pair, ...remove_assoc(x, l)} - } - } - -let rec remove_assq = (x, param) => - switch param { - | list{} => list{} - | list{(a, _) as pair, ...l} => - if a === x { - l - } else { - list{pair, ...remove_assq(x, l)} - } - } - -let rec find = (~f as p, param) => - switch param { - | list{} => raise(Not_found) - | list{x, ...l} => - if p(x) { - x - } else { - find(~f=p, l) - } - } - -let rec find_opt = (~f as p, param) => - switch param { - | list{} => None - | list{x, ...l} => - if p(x) { - Some(x) - } else { - find_opt(~f=p, l) - } - } - -let find_all = (~f as p) => { - let rec find = (accu, param) => - switch param { - | list{} => rev(accu) - | list{x, ...l} => - if p(x) { - find(list{x, ...accu}, l) - } else { - find(accu, l) - } - } - find(list{}) -} - -let filter = find_all - -let partition = (~f as p, l) => { - let rec part = (yes, no, param) => - switch param { - | list{} => (rev(yes), rev(no)) - | list{x, ...l} => - if p(x) { - part(list{x, ...yes}, no, l) - } else { - part(yes, list{x, ...no}, l) - } - } - part(list{}, list{}, l) -} - -let rec split = param => - switch param { - | list{} => (list{}, list{}) - | list{(x, y), ...l} => - let (rx, ry) = split(l) - (list{x, ...rx}, list{y, ...ry}) - } - -let rec combine = (l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => list{} - | (list{a1, ...l1}, list{a2, ...l2}) => list{(a1, a2), ...combine(l1, l2)} - | (_, _) => invalid_arg("List.combine") - } - -/* sorting */ - -let rec merge = (~cmp, l1, l2) => - switch (l1, l2) { - | (list{}, l2) => l2 - | (l1, list{}) => l1 - | (list{h1, ...t1}, list{h2, ...t2}) => - if cmp(h1, h2) <= 0 { - list{h1, ...merge(~cmp, t1, l2)} - } else { - list{h2, ...merge(~cmp, l1, t2)} - } - } - -let rec chop = (k, l) => - if k == 0 { - l - } else { - switch l { - | list{_, ...t} => chop(k - 1, t) - | _ => assert(false) - } - } - -let stable_sort = (~cmp, l) => { - let rec rev_merge = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - if cmp(h1, h2) <= 0 { - rev_merge(t1, l2, list{h1, ...accu}) - } else { - rev_merge(l1, t2, list{h2, ...accu}) - } - } - - let rec rev_merge_rev = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - if cmp(h1, h2) > 0 { - rev_merge_rev(t1, l2, list{h1, ...accu}) - } else { - rev_merge_rev(l1, t2, list{h2, ...accu}) - } - } - - let rec sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - if cmp(x1, x2) <= 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - if cmp(x1, x2) <= 0 { - if cmp(x2, x3) <= 0 { - list{x1, x2, x3} - } else if cmp(x1, x3) <= 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } else if cmp(x1, x3) <= 0 { - list{x2, x1, x3} - } else if cmp(x2, x3) <= 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = rev_sort(n1, l) - let s2 = rev_sort(n2, l2) - rev_merge_rev(s1, s2, list{}) - } - and rev_sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - if cmp(x1, x2) > 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - if cmp(x1, x2) > 0 { - if cmp(x2, x3) > 0 { - list{x1, x2, x3} - } else if cmp(x1, x3) > 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } else if cmp(x1, x3) > 0 { - list{x2, x1, x3} - } else if cmp(x2, x3) > 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = sort(n1, l) - let s2 = sort(n2, l2) - rev_merge(s1, s2, list{}) - } - - let len = length(l) - if len < 2 { - l - } else { - sort(len, l) - } -} - -let sort = stable_sort -let fast_sort = stable_sort - -/* Note: on a list of length between about 100000 (depending on the minor - heap size and the type of the list) and Sys.max_array_size, it is - actually faster to use the following, but it might also use more memory - because the argument list cannot be deallocated incrementally. - - Also, there seems to be a bug in this code or in the - implementation of obj_truncate. - -external obj_truncate : 'a array -> int -> unit = "caml_obj_truncate" - -let array_to_list_in_place a = - let l = Array.length a in - let rec loop accu n p = - if p <= 0 then accu else begin - if p = n then begin - obj_truncate a p; - loop (a.(p-1) :: accu) (n-1000) (p-1) - end else begin - loop (a.(p-1) :: accu) n (p-1) - end - end - in - loop [] (l-1000) l - - -let stable_sort cmp l = - let a = Array.of_list l in - Array.stable_sort cmp a; - array_to_list_in_place a -*/ - -/* sorting + removing duplicates */ - -let sort_uniq = (~cmp, l) => { - let rec rev_merge = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = cmp(h1, h2) - if c == 0 { - rev_merge(t1, t2, list{h1, ...accu}) - } else if c < 0 { - rev_merge(t1, l2, list{h1, ...accu}) - } else { - rev_merge(l1, t2, list{h2, ...accu}) - } - } - - let rec rev_merge_rev = (l1, l2, accu) => - switch (l1, l2) { - | (list{}, l2) => rev_append(l2, accu) - | (l1, list{}) => rev_append(l1, accu) - | (list{h1, ...t1}, list{h2, ...t2}) => - let c = cmp(h1, h2) - if c == 0 { - rev_merge_rev(t1, t2, list{h1, ...accu}) - } else if c > 0 { - rev_merge_rev(t1, l2, list{h1, ...accu}) - } else { - rev_merge_rev(l1, t2, list{h2, ...accu}) - } - } - - let rec sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - list{x1} - } else if c < 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x2} - } else if c < 0 { - list{x2, x3} - } else { - list{x3, x2} - } - } else if c < 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x1, x2} - } else if c < 0 { - list{x1, x2, x3} - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x1, x2} - } else if c < 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x2, x1} - } else if c < 0 { - list{x2, x1, x3} - } else { - let c = cmp(x2, x3) - if c == 0 { - list{x2, x1} - } else if c < 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - } - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = rev_sort(n1, l) - let s2 = rev_sort(n2, l2) - rev_merge_rev(s1, s2, list{}) - } - and rev_sort = (n, l) => - switch (n, l) { - | (2, list{x1, x2, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - list{x1} - } else if c > 0 { - list{x1, x2} - } else { - list{x2, x1} - } - | (3, list{x1, x2, x3, ..._}) => - let c = cmp(x1, x2) - if c == 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x2} - } else if c > 0 { - list{x2, x3} - } else { - list{x3, x2} - } - } else if c > 0 { - let c = cmp(x2, x3) - if c == 0 { - list{x1, x2} - } else if c > 0 { - list{x1, x2, x3} - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x1, x2} - } else if c > 0 { - list{x1, x3, x2} - } else { - list{x3, x1, x2} - } - } - } else { - let c = cmp(x1, x3) - if c == 0 { - list{x2, x1} - } else if c > 0 { - list{x2, x1, x3} - } else { - let c = cmp(x2, x3) - if c == 0 { - list{x2, x1} - } else if c > 0 { - list{x2, x3, x1} - } else { - list{x3, x2, x1} - } - } - } - | (n, l) => - let n1 = asr(n, 1) - let n2 = n - n1 - let l2 = chop(n1, l) - let s1 = sort(n1, l) - let s2 = sort(n2, l2) - rev_merge(s1, s2, list{}) - } - - let len = length(l) - if len < 2 { - l - } else { - sort(len, l) - } -} - -let rec compare_lengths = (l1, l2) => - switch (l1, l2) { - | (list{}, list{}) => 0 - | (list{}, _) => -1 - | (_, list{}) => 1 - | (list{_, ...l1}, list{_, ...l2}) => compare_lengths(l1, l2) - } - -let rec compare_length_with = (l, ~len as n) => - switch l { - | list{} => - if n == 0 { - 0 - } else if n > 0 { - -1 - } else { - 1 - } - | list{_, ...l} => - if n <= 0 { - 1 - } else { - compare_length_with(l, ~len=n - 1) - } - } diff --git a/jscomp/stdlib-406/listLabels.resi b/jscomp/stdlib-406/listLabels.resi deleted file mode 100644 index c48e830..0000000 --- a/jscomp/stdlib-406/listLabels.resi +++ /dev/null @@ -1,337 +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. */ -/* */ -/* ************************************************************************ */ - -/*** List operations. - - Some functions are flagged as not tail-recursive. A tail-recursive - function uses constant stack space, while a non-tail-recursive function - uses stack space proportional to the length of its list argument, which - can be a problem with very long lists. When the function takes several - list arguments, an approximate formula giving stack usage (in some - unspecified constant unit) is shown in parentheses. - - The above considerations can usually be ignored if your lists are not - longer than about 10000 elements. -*/ - -/** Return the length (number of elements) of the given list. */ -let length: list<'a> => int - -/** Return the first element of the given list. Raise - [Failure "hd"] if the list is empty. */ -let hd: list<'a> => 'a - -/** Compare the lengths of two lists. [compare_lengths l1 l2] is - equivalent to [compare (length l1) (length l2)], except that - the computation stops after itering on the shortest list. - @since 4.05.0 - */ -let compare_lengths: (list<'a>, list<'b>) => int - -/** Compare the length of a list to an integer. [compare_length_with l n] is - equivalent to [compare (length l) n], except that - the computation stops after at most [n] iterations on the list. - @since 4.05.0 -*/ -let compare_length_with: (list<'a>, ~len: int) => int - -/** [cons x xs] is [x :: xs] - @since 4.05.0 -*/ -let cons: ('a, list<'a>) => list<'a> - -/** Return the given list without its first element. Raise - [Failure "tl"] if the list is empty. */ -let tl: list<'a> => list<'a> - -/** Return the [n]-th element of the given list. - The first element (head of the list) is at position 0. - Raise [Failure "nth"] if the list is too short. - Raise [Invalid_argument "List.nth"] if [n] is negative. */ -let nth: (list<'a>, int) => 'a - -/** Return the [n]-th element of the given list. - The first element (head of the list) is at position 0. - Return [None] if the list is too short. - Raise [Invalid_argument "List.nth"] if [n] is negative. - @since 4.05 -*/ -let nth_opt: (list<'a>, int) => option<'a> - -/** List reversal. */ -let rev: list<'a> => list<'a> - -/** [List.init len f] is [f 0; f 1; ...; f (len-1)], evaluated left to right. - - @raise Invalid_argument if [len < 0]. - @since 4.06.0 -*/ -let init: (~len: int, ~f: int => 'a) => list<'a> - -/** Catenate two lists. Same function as the infix operator [@]. - Not tail-recursive (length of the first argument). The [@] - operator is not tail-recursive either. */ -let append: (list<'a>, list<'a>) => list<'a> - -/** [List.rev_append l1 l2] reverses [l1] and concatenates it with [l2]. - This is equivalent to [(]{!List.rev}[ l1) @ l2], but [rev_append] is - tail-recursive and more efficient. */ -let rev_append: (list<'a>, list<'a>) => list<'a> - -/** Concatenate a list of lists. The elements of the argument are all - concatenated together (in the same order) to give the result. - Not tail-recursive - (length of the argument + length of the longest sub-list). */ -let concat: list> => list<'a> - -/** Same as [concat]. Not tail-recursive - (length of the argument + length of the longest sub-list). */ -let flatten: list> => list<'a> - -/* {1 Iterators} */ - -/** [List.iter f [a1; ...; an]] applies function [f] in turn to - [a1; ...; an]. It is equivalent to - [begin f a1; f a2; ...; f an; () end]. */ -let iter: (~f: 'a => unit, list<'a>) => unit - -/** Same as {!List.iter}, but the function is applied to the index of - the element as first argument (counting from 0), and the element - itself as second argument. - @since 4.00.0 -*/ -let iteri: (~f: (int, 'a) => unit, list<'a>) => unit - -/** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], - and builds the list [[f a1; ...; f an]] - with the results returned by [f]. Not tail-recursive. */ -let map: (~f: 'a => 'b, list<'a>) => list<'b> - -/** Same as {!List.map}, but the function is applied to the index of - the element as first argument (counting from 0), and the element - itself as second argument. - @since 4.00.0 -*/ -let mapi: (~f: (int, 'a) => 'b, list<'a>) => list<'b> - -/** [List.rev_map f l] gives the same result as - {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and - more efficient. */ -let rev_map: (~f: 'a => 'b, list<'a>) => list<'b> - -/** [List.fold_left f a [b1; ...; bn]] is - [f (... (f (f a b1) b2) ...) bn]. */ -let fold_left: (~f: ('a, 'b) => 'a, ~init: 'a, list<'b>) => 'a - -/** [List.fold_right f [a1; ...; an] b] is - [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. */ -let fold_right: (~f: ('a, 'b) => 'b, list<'a>, ~init: 'b) => 'b - -/* {1 Iterators on two lists} */ - -/** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn - [f a1 b1; ...; f an bn]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let iter2: (~f: ('a, 'b) => unit, list<'a>, list<'b>) => unit - -/** [List.map2 f [a1; ...; an] [b1; ...; bn]] is - [[f a1 b1; ...; f an bn]]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. Not tail-recursive. */ -let map2: (~f: ('a, 'b) => 'c, list<'a>, list<'b>) => list<'c> - -/** [List.rev_map2 f l1 l2] gives the same result as - {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and - more efficient. */ -let rev_map2: (~f: ('a, 'b) => 'c, list<'a>, list<'b>) => list<'c> - -/** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is - [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let fold_left2: (~f: ('a, 'b, 'c) => 'a, ~init: 'a, list<'b>, list<'c>) => 'a - -/** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is - [f a1 b1 (f a2 b2 (... (f an bn c) ...))]. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. Not tail-recursive. */ -let fold_right2: (~f: ('a, 'b, 'c) => 'c, list<'a>, list<'b>, ~init: 'c) => 'c - -/* {1 List scanning} */ - -/** [for_all p [a1; ...; an]] checks if all elements of the list - satisfy the predicate [p]. That is, it returns - [(p a1) && (p a2) && ... && (p an)]. */ -let for_all: (~f: 'a => bool, list<'a>) => bool - -/** [exists p [a1; ...; an]] checks if at least one element of - the list satisfies the predicate [p]. That is, it returns - [(p a1) || (p a2) || ... || (p an)]. */ -let exists: (~f: 'a => bool, list<'a>) => bool - -/** Same as {!List.for_all}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let for_all2: (~f: ('a, 'b) => bool, list<'a>, list<'b>) => bool - -/** Same as {!List.exists}, but for a two-argument predicate. - Raise [Invalid_argument] if the two lists are determined - to have different lengths. */ -let exists2: (~f: ('a, 'b) => bool, list<'a>, list<'b>) => bool - -/** [mem a l] is true if and only if [a] is equal - to an element of [l]. */ -let mem: ('a, ~set: list<'a>) => bool - -/** Same as {!List.mem}, but uses physical equality instead of structural - equality to compare list elements. */ -let memq: ('a, ~set: list<'a>) => bool - -/* {1 List searching} */ - -/** [find p l] returns the first element of the list [l] - that satisfies the predicate [p]. - Raise [Not_found] if there is no value that satisfies [p] in the - list [l]. */ -let find: (~f: 'a => bool, list<'a>) => 'a - -/** [find p l] returns the first element of the list [l] - that satisfies the predicate [p]. - Returns [None] if there is no value that satisfies [p] in the - list [l]. - @since 4.05 */ -let find_opt: (~f: 'a => bool, list<'a>) => option<'a> - -/** [filter p l] returns all the elements of the list [l] - that satisfy the predicate [p]. The order of the elements - in the input list is preserved. */ -let filter: (~f: 'a => bool, list<'a>) => list<'a> - -/** [find_all] is another name for {!List.filter}. */ -let find_all: (~f: 'a => bool, list<'a>) => list<'a> - -/** [partition p l] returns a pair of lists [(l1, l2)], where - [l1] is the list of all the elements of [l] that - satisfy the predicate [p], and [l2] is the list of all the - elements of [l] that do not satisfy [p]. - The order of the elements in the input list is preserved. */ -let partition: (~f: 'a => bool, list<'a>) => (list<'a>, list<'a>) - -/* {1 Association lists} */ - -/** [assoc a l] returns the value associated with key [a] in the list of - pairs [l]. That is, - [assoc a [ ...; (a,b); ...] = b] - if [(a,b)] is the leftmost binding of [a] in list [l]. - Raise [Not_found] if there is no value associated with [a] in the - list [l]. */ -let assoc: ('a, list<('a, 'b)>) => 'b - -/** [assoc_opt a l] returns the value associated with key [a] in the list of - pairs [l]. That is, - [assoc a [ ...; (a,b); ...] = b] - if [(a,b)] is the leftmost binding of [a] in list [l]. - Returns [None] if there is no value associated with [a] in the - list [l]. - @since 4.05 -*/ -let assoc_opt: ('a, list<('a, 'b)>) => option<'b> - -/** Same as {!List.assoc}, but uses physical equality instead of - structural equality to compare keys. */ -let assq: ('a, list<('a, 'b)>) => 'b - -/** Same as {!List.assoc_opt}, but uses physical equality instead of - structural equality to compare keys. - @since 4.05.0 */ -let assq_opt: ('a, list<('a, 'b)>) => option<'b> - -/** Same as {!List.assoc}, but simply return true if a binding exists, - and false if no bindings exist for the given key. */ -let mem_assoc: ('a, ~map: list<('a, 'b)>) => bool - -/** Same as {!List.mem_assoc}, but uses physical equality instead of - structural equality to compare keys. */ -let mem_assq: ('a, ~map: list<('a, 'b)>) => bool - -/** [remove_assoc a l] returns the list of - pairs [l] without the first pair with key [a], if any. - Not tail-recursive. */ -let remove_assoc: ('a, list<('a, 'b)>) => list<('a, 'b)> - -/** Same as {!List.remove_assoc}, but uses physical equality instead - of structural equality to compare keys. Not tail-recursive. */ -let remove_assq: ('a, list<('a, 'b)>) => list<('a, 'b)> - -/* {1 Lists of pairs} */ - -/** Transform a list of pairs into a pair of lists: - [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. - Not tail-recursive. -*/ -let split: list<('a, 'b)> => (list<'a>, list<'b>) - -/** Transform a pair of lists into a list of pairs: - [combine [a1; ...; an] [b1; ...; bn]] is - [[(a1,b1); ...; (an,bn)]]. - Raise [Invalid_argument] if the two lists - have different lengths. Not tail-recursive. */ -let combine: (list<'a>, list<'b>) => list<('a, 'b)> - -/* {1 Sorting} */ - -/** Sort a list in increasing order according to a comparison - function. The comparison function must return 0 if its arguments - compare as equal, a positive integer if the first is greater, - and a negative integer if the first is smaller (see Array.sort for - a complete specification). For example, - {!Pervasives.compare} is a suitable comparison function. - The resulting list is sorted in increasing order. - [List.sort] is guaranteed to run in constant heap space - (in addition to the size of the result list) and logarithmic - stack space. - - The current implementation uses Merge Sort. It runs in constant - heap space and logarithmic stack space. -*/ -let sort: (~cmp: ('a, 'a) => int, list<'a>) => list<'a> - -/** Same as {!List.sort}, but the sorting algorithm is guaranteed to - be stable (i.e. elements that compare equal are kept in their - original order) . - - The current implementation uses Merge Sort. It runs in constant - heap space and logarithmic stack space. -*/ -let stable_sort: (~cmp: ('a, 'a) => int, list<'a>) => list<'a> - -/** Same as {!List.sort} or {!List.stable_sort}, whichever is - faster on typical input. */ -let fast_sort: (~cmp: ('a, 'a) => int, list<'a>) => list<'a> - -/** Same as {!List.sort}, but also remove duplicates. - @since 4.03.0 */ -let sort_uniq: (~cmp: ('a, 'a) => int, list<'a>) => list<'a> - -/** Merge two lists: - Assuming that [l1] and [l2] are sorted according to the - comparison function [cmp], [merge cmp l1 l2] will return a - sorted list containing all the elements of [l1] and [l2]. - If several elements compare equal, the elements of [l1] will be - before the elements of [l2]. - Not tail-recursive (sum of the lengths of the arguments). -*/ -let merge: (~cmp: ('a, 'a) => int, list<'a>, list<'a>) => list<'a> diff --git a/jscomp/stdlib-406/map.res b/jscomp/stdlib-406/map.res deleted file mode 100644 index f485f30..0000000 --- a/jscomp/stdlib-406/map.res +++ /dev/null @@ -1,669 +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. */ -/* */ -/* ************************************************************************ */ - -module type OrderedType = { - type t - let compare: (t, t) => int -} - -module type S = { - type key - type t<+'a> - let empty: t<'a> - let is_empty: t<'a> => bool - let mem: (key, t<'a>) => bool - let add: (key, 'a, t<'a>) => t<'a> - let update: (key, option<'a> => option<'a>, t<'a>) => t<'a> - let singleton: (key, 'a) => t<'a> - let remove: (key, t<'a>) => t<'a> - let merge: ((key, option<'a>, option<'b>) => option<'c>, t<'a>, t<'b>) => t<'c> - let union: ((key, 'a, 'a) => option<'a>, t<'a>, t<'a>) => t<'a> - let compare: (('a, 'a) => int, t<'a>, t<'a>) => int - let equal: (('a, 'a) => bool, t<'a>, t<'a>) => bool - let iter: ((key, 'a) => unit, t<'a>) => unit - let fold: ((key, 'a, 'b) => 'b, t<'a>, 'b) => 'b - let for_all: ((key, 'a) => bool, t<'a>) => bool - let exists: ((key, 'a) => bool, t<'a>) => bool - let filter: ((key, 'a) => bool, t<'a>) => t<'a> - let partition: ((key, 'a) => bool, t<'a>) => (t<'a>, t<'a>) - let cardinal: t<'a> => int - let bindings: t<'a> => list<(key, 'a)> - let min_binding: t<'a> => (key, 'a) - let min_binding_opt: t<'a> => option<(key, 'a)> - let max_binding: t<'a> => (key, 'a) - let max_binding_opt: t<'a> => option<(key, 'a)> - let choose: t<'a> => (key, 'a) - let choose_opt: t<'a> => option<(key, 'a)> - let split: (key, t<'a>) => (t<'a>, option<'a>, t<'a>) - let find: (key, t<'a>) => 'a - let find_opt: (key, t<'a>) => option<'a> - let find_first: (key => bool, t<'a>) => (key, 'a) - let find_first_opt: (key => bool, t<'a>) => option<(key, 'a)> - let find_last: (key => bool, t<'a>) => (key, 'a) - let find_last_opt: (key => bool, t<'a>) => option<(key, 'a)> - let map: ('a => 'b, t<'a>) => t<'b> - let mapi: ((key, 'a) => 'b, t<'a>) => t<'b> -} - -module Make = (Ord: OrderedType) => { - type key = Ord.t - - type rec t<'a> = - | Empty - | Node({l: t<'a>, v: key, d: 'a, r: t<'a>, h: int}) - - let height = param => - switch param { - | Empty => 0 - | Node({h}) => h - } - - let create = (l, x, d, r) => { - let hl = height(l) and hr = height(r) - Node({ - l, - v: x, - d, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - - let singleton = (x, d) => Node({l: Empty, v: x, d, r: Empty, h: 1}) - - let bal = (l, x, d, r) => { - let hl = switch l { - | Empty => 0 - | Node({h}) => h - } - let hr = switch r { - | Empty => 0 - | Node({h}) => h - } - if hl > hr + 2 { - switch l { - | Empty => invalid_arg("Map.bal") - | Node({l: ll, v: lv, d: ld, r: lr}) => - if height(ll) >= height(lr) { - create(ll, lv, ld, create(lr, x, d, r)) - } else { - switch lr { - | Empty => invalid_arg("Map.bal") - | Node({l: lrl, v: lrv, d: lrd, r: lrr}) => - create(create(ll, lv, ld, lrl), lrv, lrd, create(lrr, x, d, r)) - } - } - } - } else if hr > hl + 2 { - switch r { - | Empty => invalid_arg("Map.bal") - | Node({l: rl, v: rv, d: rd, r: rr}) => - if height(rr) >= height(rl) { - create(create(l, x, d, rl), rv, rd, rr) - } else { - switch rl { - | Empty => invalid_arg("Map.bal") - | Node({l: rll, v: rlv, d: rld, r: rlr}) => - create(create(l, x, d, rll), rlv, rld, create(rlr, rv, rd, rr)) - } - } - } - } else { - Node({ - l, - v: x, - d, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - } - - let empty = Empty - - let is_empty = param => - switch param { - | Empty => true - | _ => false - } - - let rec add = (x, data, param) => - switch param { - | Empty => Node({l: Empty, v: x, d: data, r: Empty, h: 1}) - | Node({l, v, d, r, h}) as m => - let c = Ord.compare(x, v) - if c == 0 { - if d === data { - m - } else { - Node({l, v: x, d: data, r, h}) - } - } else if c < 0 { - let ll = add(x, data, l) - if l === ll { - m - } else { - bal(ll, v, d, r) - } - } else { - let rr = add(x, data, r) - if r === rr { - m - } else { - bal(l, v, d, rr) - } - } - } - - let rec find = (x, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, d, r}) => - let c = Ord.compare(x, v) - if c == 0 { - d - } else { - find( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let rec find_first_aux = (v0, d0, f, param) => - switch param { - | Empty => (v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_first_aux(v, d, f, l) - } else { - find_first_aux(v0, d0, f, r) - } - } - - let rec find_first = (f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, d, r}) => - if f(v) { - find_first_aux(v, d, f, l) - } else { - find_first(f, r) - } - } - - let rec find_first_opt_aux = (v0, d0, f, param) => - switch param { - | Empty => Some(v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_first_opt_aux(v, d, f, l) - } else { - find_first_opt_aux(v0, d0, f, r) - } - } - - let rec find_first_opt = (f, param) => - switch param { - | Empty => None - | Node({l, v, d, r}) => - if f(v) { - find_first_opt_aux(v, d, f, l) - } else { - find_first_opt(f, r) - } - } - - let rec find_last_aux = (v0, d0, f, param) => - switch param { - | Empty => (v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_last_aux(v, d, f, r) - } else { - find_last_aux(v0, d0, f, l) - } - } - - let rec find_last = (f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, d, r}) => - if f(v) { - find_last_aux(v, d, f, r) - } else { - find_last(f, l) - } - } - - let rec find_last_opt_aux = (v0, d0, f, param) => - switch param { - | Empty => Some(v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_last_opt_aux(v, d, f, r) - } else { - find_last_opt_aux(v0, d0, f, l) - } - } - - let rec find_last_opt = (f, param) => - switch param { - | Empty => None - | Node({l, v, d, r}) => - if f(v) { - find_last_opt_aux(v, d, f, r) - } else { - find_last_opt(f, l) - } - } - - let rec find_opt = (x, param) => - switch param { - | Empty => None - | Node({l, v, d, r}) => - let c = Ord.compare(x, v) - if c == 0 { - Some(d) - } else { - find_opt( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let rec mem = (x, param) => - switch param { - | Empty => false - | Node({l, v, r}) => - let c = Ord.compare(x, v) - c == 0 || - mem( - x, - if c < 0 { - l - } else { - r - }, - ) - } - - let rec min_binding = param => - switch param { - | Empty => raise(Not_found) - | Node({l: Empty, v, d}) => (v, d) - | Node({l}) => min_binding(l) - } - - let rec min_binding_opt = param => - switch param { - | Empty => None - | Node({l: Empty, v, d}) => Some(v, d) - | Node({l}) => min_binding_opt(l) - } - - let rec max_binding = param => - switch param { - | Empty => raise(Not_found) - | Node({v, d, r: Empty}) => (v, d) - | Node({r}) => max_binding(r) - } - - let rec max_binding_opt = param => - switch param { - | Empty => None - | Node({v, d, r: Empty}) => Some(v, d) - | Node({r}) => max_binding_opt(r) - } - - let rec remove_min_binding = param => - switch param { - | Empty => invalid_arg("Map.remove_min_elt") - | Node({l: Empty, r}) => r - | Node({l, v, d, r}) => bal(remove_min_binding(l), v, d, r) - } - - let merge = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => - let (x, d) = min_binding(t2) - bal(t1, x, d, remove_min_binding(t2)) - } - - let rec remove = (x, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r}) as m => - let c = Ord.compare(x, v) - if c == 0 { - merge(l, r) - } else if c < 0 { - let ll = remove(x, l) - if l === ll { - m - } else { - bal(ll, v, d, r) - } - } else { - let rr = remove(x, r) - if r === rr { - m - } else { - bal(l, v, d, rr) - } - } - } - - let rec update = (x, f, param) => - switch param { - | Empty => - switch f(None) { - | None => Empty - | Some(data) => Node({l: Empty, v: x, d: data, r: Empty, h: 1}) - } - | Node({l, v, d, r, h}) as m => - let c = Ord.compare(x, v) - if c == 0 { - switch f(Some(d)) { - | None => merge(l, r) - | Some(data) => - if d === data { - m - } else { - Node({l, v: x, d: data, r, h}) - } - } - } else if c < 0 { - let ll = update(x, f, l) - if l === ll { - m - } else { - bal(ll, v, d, r) - } - } else { - let rr = update(x, f, r) - if r === rr { - m - } else { - bal(l, v, d, rr) - } - } - } - - let rec iter = (f, param) => - switch param { - | Empty => () - | Node({l, v, d, r}) => - iter(f, l) - f(v, d) - iter(f, r) - } - - let rec map = (f, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r, h}) => - let l' = map(f, l) - let d' = f(d) - let r' = map(f, r) - Node({l: l', v, d: d', r: r', h}) - } - - let rec mapi = (f, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r, h}) => - let l' = mapi(f, l) - let d' = f(v, d) - let r' = mapi(f, r) - Node({l: l', v, d: d', r: r', h}) - } - - let rec fold = (f, m, accu) => - switch m { - | Empty => accu - | Node({l, v, d, r}) => fold(f, r, f(v, d, fold(f, l, accu))) - } - - let rec for_all = (p, param) => - switch param { - | Empty => true - | Node({l, v, d, r}) => p(v, d) && (for_all(p, l) && for_all(p, r)) - } - - let rec exists = (p, param) => - switch param { - | Empty => false - | Node({l, v, d, r}) => p(v, d) || (exists(p, l) || exists(p, r)) - } - - /* Beware: those two functions assume that the added k is *strictly* - smaller (or bigger) than all the present keys in the tree; it - does not test for equality with the current min (or max) key. - - Indeed, they are only used during the "join" operation which - respects this precondition. - */ - - let rec add_min_binding = (k, x, param) => - switch param { - | Empty => singleton(k, x) - | Node({l, v, d, r}) => bal(add_min_binding(k, x, l), v, d, r) - } - - let rec add_max_binding = (k, x, param) => - switch param { - | Empty => singleton(k, x) - | Node({l, v, d, r}) => bal(l, v, d, add_max_binding(k, x, r)) - } - - /* Same as create and bal, but no assumptions are made on the - relative heights of l and r. */ - - let rec join = (l, v, d, r) => - switch (l, r) { - | (Empty, _) => add_min_binding(v, d, r) - | (_, Empty) => add_max_binding(v, d, l) - | (Node({l: ll, v: lv, d: ld, r: lr, h: lh}), Node({l: rl, v: rv, d: rd, r: rr, h: rh})) => - if lh > rh + 2 { - bal(ll, lv, ld, join(lr, v, d, r)) - } else if rh > lh + 2 { - bal(join(l, v, d, rl), rv, rd, rr) - } else { - create(l, v, d, r) - } - } - - /* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. */ - - let concat = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => - let (x, d) = min_binding(t2) - join(t1, x, d, remove_min_binding(t2)) - } - - let concat_or_join = (t1, v, d, t2) => - switch d { - | Some(d) => join(t1, v, d, t2) - | None => concat(t1, t2) - } - - let rec split = (x, param) => - switch param { - | Empty => (Empty, None, Empty) - | Node({l, v, d, r}) => - let c = Ord.compare(x, v) - if c == 0 { - (l, Some(d), r) - } else if c < 0 { - let (ll, pres, rl) = split(x, l) - (ll, pres, join(rl, v, d, r)) - } else { - let (lr, pres, rr) = split(x, r) - (join(l, v, d, lr), pres, rr) - } - } - - let rec merge = (f, s1, s2) => - switch (s1, s2) { - | (Empty, Empty) => Empty - | (Node({l: l1, v: v1, d: d1, r: r1, h: h1}), _) if h1 >= height(s2) => - let (l2, d2, r2) = split(v1, s2) - concat_or_join(merge(f, l1, l2), v1, f(v1, Some(d1), d2), merge(f, r1, r2)) - | (_, Node({l: l2, v: v2, d: d2, r: r2})) => - let (l1, d1, r1) = split(v2, s1) - concat_or_join(merge(f, l1, l2), v2, f(v2, d1, Some(d2)), merge(f, r1, r2)) - | _ => assert(false) - } - - let rec union = (f, s1, s2) => - switch (s1, s2) { - | (Empty, s) | (s, Empty) => s - | (Node({l: l1, v: v1, d: d1, r: r1, h: h1}), Node({l: l2, v: v2, d: d2, r: r2, h: h2})) => - if h1 >= h2 { - let (l2, d2, r2) = split(v1, s2) - let l = union(f, l1, l2) and r = union(f, r1, r2) - switch d2 { - | None => join(l, v1, d1, r) - | Some(d2) => concat_or_join(l, v1, f(v1, d1, d2), r) - } - } else { - let (l1, d1, r1) = split(v2, s1) - let l = union(f, l1, l2) and r = union(f, r1, r2) - switch d1 { - | None => join(l, v2, d2, r) - | Some(d1) => concat_or_join(l, v2, f(v2, d1, d2), r) - } - } - } - - let rec filter = (p, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r}) as m => - /* call [p] in the expected left-to-right order */ - let l' = filter(p, l) - let pvd = p(v, d) - let r' = filter(p, r) - if pvd { - if l === l' && r === r' { - m - } else { - join(l', v, d, r') - } - } else { - concat(l', r') - } - } - - let rec partition = (p, param) => - switch param { - | Empty => (Empty, Empty) - | Node({l, v, d, r}) => - /* call [p] in the expected left-to-right order */ - let (lt, lf) = partition(p, l) - let pvd = p(v, d) - let (rt, rf) = partition(p, r) - if pvd { - (join(lt, v, d, rt), concat(lf, rf)) - } else { - (concat(lt, rt), join(lf, v, d, rf)) - } - } - - type rec enumeration<'a> = End | More(key, 'a, t<'a>, enumeration<'a>) - - let rec cons_enum = (m, e) => - switch m { - | Empty => e - | Node({l, v, d, r}) => cons_enum(l, More(v, d, r, e)) - } - - let compare = (cmp, m1, m2) => { - let rec compare_aux = (e1, e2) => - switch (e1, e2) { - | (End, End) => 0 - | (End, _) => -1 - | (_, End) => 1 - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) => - let c = Ord.compare(v1, v2) - if c != 0 { - c - } else { - let c = cmp(d1, d2) - if c != 0 { - c - } else { - compare_aux(cons_enum(r1, e1), cons_enum(r2, e2)) - } - } - } - compare_aux(cons_enum(m1, End), cons_enum(m2, End)) - } - - let equal = (cmp, m1, m2) => { - let rec equal_aux = (e1, e2) => - switch (e1, e2) { - | (End, End) => true - | (End, _) => false - | (_, End) => false - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) => - Ord.compare(v1, v2) == 0 && (cmp(d1, d2) && equal_aux(cons_enum(r1, e1), cons_enum(r2, e2))) - } - equal_aux(cons_enum(m1, End), cons_enum(m2, End)) - } - - let rec cardinal = param => - switch param { - | Empty => 0 - | Node({l, r}) => cardinal(l) + 1 + cardinal(r) - } - - let rec bindings_aux = (accu, param) => - switch param { - | Empty => accu - | Node({l, v, d, r}) => bindings_aux(list{(v, d), ...bindings_aux(accu, r)}, l) - } - - let bindings = s => bindings_aux(list{}, s) - - let choose = min_binding - - let choose_opt = min_binding_opt -} diff --git a/jscomp/stdlib-406/map.resi b/jscomp/stdlib-406/map.resi deleted file mode 100644 index 11458cb..0000000 --- a/jscomp/stdlib-406/map.resi +++ /dev/null @@ -1,310 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Association tables over ordered types. - - This module implements applicative association tables, also known as - finite maps or dictionaries, given a total ordering function - over the keys. - All operations over maps are purely applicative (no side-effects). - The implementation uses balanced binary trees, and therefore searching - and insertion take time logarithmic in the size of the map. - - For instance: - {[ - module IntPairs = - struct - type t = int * int - let compare (x0,y0) (x1,y1) = - match Pervasives.compare x0 x1 with - 0 -> Pervasives.compare y0 y1 - | c -> c - end - - module PairsMap = Map.Make(IntPairs) - - let m = PairsMap.(empty |> add (0,1) \"hello\" |> add (1,0) \"world\") - ]} - - This creates a new module [PairsMap], with a new type ['a PairsMap.t] - of maps from [int * int] to ['a]. In this example, [m] contains [string] - values so its type is [string PairsMap.t]. -*/ - -/** Input signature of the functor {!Map.Make}. */ -module type OrderedType = { - /** The type of the map keys. */ - type t - - /** A total ordering function over the keys. - This is a two-argument function [f] such that - [f e1 e2] is zero if the keys [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is the generic structural - comparison function {!Pervasives.compare}. */ - let compare: (t, t) => int -} - -/** Output signature of the functor {!Map.Make}. */ -module type S = { - /** The type of the map keys. */ - type key - - /** The type of maps from type [key] to type ['a]. */ - type t<+'a> - - /** The empty map. */ - let empty: t<'a> - - /** Test whether a map is empty or not. */ - let is_empty: t<'a> => bool - - /** [mem x m] returns [true] if [m] contains a binding for [x], - and [false] otherwise. */ - let mem: (key, t<'a>) => bool - - /** [add x y m] returns a map containing the same bindings as - [m], plus a binding of [x] to [y]. If [x] was already bound - in [m] to a value that is physically equal to [y], - [m] is returned unchanged (the result of the function is - then physically equal to [m]). Otherwise, the previous binding - of [x] in [m] disappears. - @before 4.03 Physical equality was not ensured. */ - let add: (key, 'a, t<'a>) => t<'a> - - /** [update x f m] returns a map containing the same bindings as - [m], except for the binding of [x]. Depending on the value of - [y] where [y] is [f (find_opt x m)], the binding of [x] is - added, removed or updated. If [y] is [None], the binding is - removed if it exists; otherwise, if [y] is [Some z] then [x] - is associated to [z] in the resulting map. If [x] was already - bound in [m] to a value that is physically equal to [z], [m] - is returned unchanged (the result of the function is then - physically equal to [m]). - @since 4.06.0 - */ - let update: (key, option<'a> => option<'a>, t<'a>) => t<'a> - - /** [singleton x y] returns the one-element map that contains a binding [y] - for [x]. - @since 3.12.0 - */ - let singleton: (key, 'a) => t<'a> - - /** [remove x m] returns a map containing the same bindings as - [m], except for [x] which is unbound in the returned map. - If [x] was not in [m], [m] is returned unchanged - (the result of the function is then physically equal to [m]). - @before 4.03 Physical equality was not ensured. */ - let remove: (key, t<'a>) => t<'a> - - /** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] - and of [m2]. The presence of each such binding, and the corresponding - value, is determined with the function [f]. - In terms of the [find_opt] operation, we have - [find_opt x (merge f m1 m2) = f (find_opt x m1) (find_opt x m2)] - for any key [x], provided that [f None None = None]. - @since 3.12.0 - */ - let merge: ((key, option<'a>, option<'b>) => option<'c>, t<'a>, t<'b>) => t<'c> - - /** [union f m1 m2] computes a map whose keys is the union of keys - of [m1] and of [m2]. When the same binding is defined in both - arguments, the function [f] is used to combine them. - This is a special case of [merge]: [union f m1 m2] is equivalent - to [merge f' m1 m2], where - - [f' None None = None] - - [f' (Some v) None = Some v] - - [f' None (Some v) = Some v] - - [f' (Some v1) (Some v2) = f v1 v2] - - @since 4.03.0 - */ - let union: ((key, 'a, 'a) => option<'a>, t<'a>, t<'a>) => t<'a> - - /** Total ordering between maps. The first argument is a total ordering - used to compare data associated with equal keys in the two maps. */ - let compare: (('a, 'a) => int, t<'a>, t<'a>) => int - - /** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are - equal, that is, contain equal keys and associate them with - equal data. [cmp] is the equality predicate used to compare - the data associated with the keys. */ - let equal: (('a, 'a) => bool, t<'a>, t<'a>) => bool - - /** [iter f m] applies [f] to all bindings in map [m]. - [f] receives the key as first argument, and the associated value - as second argument. The bindings are passed to [f] in increasing - order with respect to the ordering over the type of the keys. */ - let iter: ((key, 'a) => unit, t<'a>) => unit - - /** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], - where [k1 ... kN] are the keys of all bindings in [m] - (in increasing order), and [d1 ... dN] are the associated data. */ - let fold: ((key, 'a, 'b) => 'b, t<'a>, 'b) => 'b - - /** [for_all p m] checks if all the bindings of the map - satisfy the predicate [p]. - @since 3.12.0 - */ - let for_all: ((key, 'a) => bool, t<'a>) => bool - - /** [exists p m] checks if at least one binding of the map - satisfies the predicate [p]. - @since 3.12.0 - */ - let exists: ((key, 'a) => bool, t<'a>) => bool - - /** [filter p m] returns the map with all the bindings in [m] - that satisfy predicate [p]. If [p] satisfies every binding in [m], - [m] is returned unchanged (the result of the function is then - physically equal to [m]) - @since 3.12.0 - @before 4.03 Physical equality was not ensured. - */ - let filter: ((key, 'a) => bool, t<'a>) => t<'a> - - /** [partition p m] returns a pair of maps [(m1, m2)], where - [m1] contains all the bindings of [s] that satisfy the - predicate [p], and [m2] is the map with all the bindings of - [s] that do not satisfy [p]. - @since 3.12.0 - */ - let partition: ((key, 'a) => bool, t<'a>) => (t<'a>, t<'a>) - - /** Return the number of bindings of a map. - @since 3.12.0 - */ - let cardinal: t<'a> => int - - /** Return the list of all bindings of the given map. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Map.Make}. - @since 3.12.0 - */ - let bindings: t<'a> => list<(key, 'a)> - - /** Return the smallest binding of the given map - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the map is empty. - @since 3.12.0 - */ - let min_binding: t<'a> => (key, 'a) - - /** Return the smallest binding of the given map - (with respect to the [Ord.compare] ordering), or [None] - if the map is empty. - @since 4.05 - */ - let min_binding_opt: t<'a> => option<(key, 'a)> - - /** Same as {!Map.S.min_binding}, but returns the largest binding - of the given map. - @since 3.12.0 - */ - let max_binding: t<'a> => (key, 'a) - - /** Same as {!Map.S.min_binding_opt}, but returns the largest binding - of the given map. - @since 4.05 - */ - let max_binding_opt: t<'a> => option<(key, 'a)> - - /** Return one binding of the given map, or raise [Not_found] if - the map is empty. Which binding is chosen is unspecified, - but equal bindings will be chosen for equal maps. - @since 3.12.0 - */ - let choose: t<'a> => (key, 'a) - - /** Return one binding of the given map, or [None] if - the map is empty. Which binding is chosen is unspecified, - but equal bindings will be chosen for equal maps. - @since 4.05 - */ - let choose_opt: t<'a> => option<(key, 'a)> - - /** [split x m] returns a triple [(l, data, r)], where - [l] is the map with all the bindings of [m] whose key - is strictly less than [x]; - [r] is the map with all the bindings of [m] whose key - is strictly greater than [x]; - [data] is [None] if [m] contains no binding for [x], - or [Some v] if [m] binds [v] to [x]. - @since 3.12.0 - */ - let split: (key, t<'a>) => (t<'a>, option<'a>, t<'a>) - - /** [find x m] returns the current binding of [x] in [m], - or raises [Not_found] if no such binding exists. */ - let find: (key, t<'a>) => 'a - - /** [find_opt x m] returns [Some v] if the current binding of [x] - in [m] is [v], or [None] if no such binding exists. - @since 4.05 - */ - let find_opt: (key, t<'a>) => option<'a> - - /** [find_first f m], where [f] is a monotonically increasing function, - returns the binding of [m] with the lowest key [k] such that [f k], - or raises [Not_found] if no such key exists. - - For example, [find_first (fun k -> Ord.compare k x >= 0) m] will return - the first binding [k, v] of [m] where [Ord.compare k x >= 0] - (intuitively: [k >= x]), or raise [Not_found] if [x] is greater than any - element of [m]. - - @since 4.05 - */ - let find_first: (key => bool, t<'a>) => (key, 'a) - - /** [find_first_opt f m], where [f] is a monotonically increasing function, - returns an option containing the binding of [m] with the lowest key [k] - such that [f k], or [None] if no such key exists. - @since 4.05 - */ - let find_first_opt: (key => bool, t<'a>) => option<(key, 'a)> - - /** [find_last f m], where [f] is a monotonically decreasing function, - returns the binding of [m] with the highest key [k] such that [f k], - or raises [Not_found] if no such key exists. - @since 4.05 - */ - let find_last: (key => bool, t<'a>) => (key, 'a) - - /** [find_last_opt f m], where [f] is a monotonically decreasing function, - returns an option containing the binding of [m] with the highest key [k] - such that [f k], or [None] if no such key exists. - @since 4.05 - */ - let find_last_opt: (key => bool, t<'a>) => option<(key, 'a)> - - /** [map f m] returns a map with same domain as [m], where the - associated value [a] of all bindings of [m] has been - replaced by the result of the application of [f] to [a]. - The bindings are passed to [f] in increasing order - with respect to the ordering over the type of the keys. */ - let map: ('a => 'b, t<'a>) => t<'b> - - /** Same as {!Map.S.map}, but the function receives as arguments both the - key and the associated value for each binding of the map. */ - let mapi: ((key, 'a) => 'b, t<'a>) => t<'b> -} - -/** Functor building an implementation of the map structure - given a totally ordered type. */ -module Make: (Ord: OrderedType) => (S with type key = Ord.t) diff --git a/jscomp/stdlib-406/mapLabels.res b/jscomp/stdlib-406/mapLabels.res deleted file mode 100644 index 7a1a395..0000000 --- a/jscomp/stdlib-406/mapLabels.res +++ /dev/null @@ -1,669 +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. */ -/* */ -/* ************************************************************************ */ - -module type OrderedType = { - type t - let compare: (t, t) => int -} - -module type S = { - type key - type t<+'a> - let empty: t<'a> - let is_empty: t<'a> => bool - let mem: (key, t<'a>) => bool - let add: (~key: key, ~data: 'a, t<'a>) => t<'a> - let update: (~key: key, ~f: option<'a> => option<'a>, t<'a>) => t<'a> - let singleton: (key, 'a) => t<'a> - let remove: (key, t<'a>) => t<'a> - let merge: (~f: (key, option<'a>, option<'b>) => option<'c>, t<'a>, t<'b>) => t<'c> - let union: (~f: (key, 'a, 'a) => option<'a>, t<'a>, t<'a>) => t<'a> - let compare: (~cmp: ('a, 'a) => int, t<'a>, t<'a>) => int - let equal: (~cmp: ('a, 'a) => bool, t<'a>, t<'a>) => bool - let iter: (~f: (~key: key, ~data: 'a) => unit, t<'a>) => unit - let fold: (~f: (~key: key, ~data: 'a, 'b) => 'b, t<'a>, ~init: 'b) => 'b - let for_all: (~f: (key, 'a) => bool, t<'a>) => bool - let exists: (~f: (key, 'a) => bool, t<'a>) => bool - let filter: (~f: (key, 'a) => bool, t<'a>) => t<'a> - let partition: (~f: (key, 'a) => bool, t<'a>) => (t<'a>, t<'a>) - let cardinal: t<'a> => int - let bindings: t<'a> => list<(key, 'a)> - let min_binding: t<'a> => (key, 'a) - let min_binding_opt: t<'a> => option<(key, 'a)> - let max_binding: t<'a> => (key, 'a) - let max_binding_opt: t<'a> => option<(key, 'a)> - let choose: t<'a> => (key, 'a) - let choose_opt: t<'a> => option<(key, 'a)> - let split: (key, t<'a>) => (t<'a>, option<'a>, t<'a>) - let find: (key, t<'a>) => 'a - let find_opt: (key, t<'a>) => option<'a> - let find_first: (~f: key => bool, t<'a>) => (key, 'a) - let find_first_opt: (~f: key => bool, t<'a>) => option<(key, 'a)> - let find_last: (~f: key => bool, t<'a>) => (key, 'a) - let find_last_opt: (~f: key => bool, t<'a>) => option<(key, 'a)> - let map: (~f: 'a => 'b, t<'a>) => t<'b> - let mapi: (~f: (key, 'a) => 'b, t<'a>) => t<'b> -} - -module Make = (Ord: OrderedType) => { - type key = Ord.t - - type rec t<'a> = - | Empty - | Node({l: t<'a>, v: key, d: 'a, r: t<'a>, h: int}) - - let height = param => - switch param { - | Empty => 0 - | Node({h}) => h - } - - let create = (l, x, d, r) => { - let hl = height(l) and hr = height(r) - Node({ - l, - v: x, - d, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - - let singleton = (x, d) => Node({l: Empty, v: x, d, r: Empty, h: 1}) - - let bal = (l, x, d, r) => { - let hl = switch l { - | Empty => 0 - | Node({h}) => h - } - let hr = switch r { - | Empty => 0 - | Node({h}) => h - } - if hl > hr + 2 { - switch l { - | Empty => invalid_arg("Map.bal") - | Node({l: ll, v: lv, d: ld, r: lr}) => - if height(ll) >= height(lr) { - create(ll, lv, ld, create(lr, x, d, r)) - } else { - switch lr { - | Empty => invalid_arg("Map.bal") - | Node({l: lrl, v: lrv, d: lrd, r: lrr}) => - create(create(ll, lv, ld, lrl), lrv, lrd, create(lrr, x, d, r)) - } - } - } - } else if hr > hl + 2 { - switch r { - | Empty => invalid_arg("Map.bal") - | Node({l: rl, v: rv, d: rd, r: rr}) => - if height(rr) >= height(rl) { - create(create(l, x, d, rl), rv, rd, rr) - } else { - switch rl { - | Empty => invalid_arg("Map.bal") - | Node({l: rll, v: rlv, d: rld, r: rlr}) => - create(create(l, x, d, rll), rlv, rld, create(rlr, rv, rd, rr)) - } - } - } - } else { - Node({ - l, - v: x, - d, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - } - - let empty = Empty - - let is_empty = param => - switch param { - | Empty => true - | _ => false - } - - let rec add = (~key as x, ~data, param) => - switch param { - | Empty => Node({l: Empty, v: x, d: data, r: Empty, h: 1}) - | Node({l, v, d, r, h}) as m => - let c = Ord.compare(x, v) - if c == 0 { - if d === data { - m - } else { - Node({l, v: x, d: data, r, h}) - } - } else if c < 0 { - let ll = add(~key=x, ~data, l) - if l === ll { - m - } else { - bal(ll, v, d, r) - } - } else { - let rr = add(~key=x, ~data, r) - if r === rr { - m - } else { - bal(l, v, d, rr) - } - } - } - - let rec find = (x, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, d, r}) => - let c = Ord.compare(x, v) - if c == 0 { - d - } else { - find( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let rec find_first_aux = (v0, d0, f, param) => - switch param { - | Empty => (v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_first_aux(v, d, f, l) - } else { - find_first_aux(v0, d0, f, r) - } - } - - let rec find_first = (~f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, d, r}) => - if f(v) { - find_first_aux(v, d, f, l) - } else { - find_first(~f, r) - } - } - - let rec find_first_opt_aux = (v0, d0, f, param) => - switch param { - | Empty => Some(v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_first_opt_aux(v, d, f, l) - } else { - find_first_opt_aux(v0, d0, f, r) - } - } - - let rec find_first_opt = (~f, param) => - switch param { - | Empty => None - | Node({l, v, d, r}) => - if f(v) { - find_first_opt_aux(v, d, f, l) - } else { - find_first_opt(~f, r) - } - } - - let rec find_last_aux = (v0, d0, f, param) => - switch param { - | Empty => (v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_last_aux(v, d, f, r) - } else { - find_last_aux(v0, d0, f, l) - } - } - - let rec find_last = (~f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, d, r}) => - if f(v) { - find_last_aux(v, d, f, r) - } else { - find_last(~f, l) - } - } - - let rec find_last_opt_aux = (v0, d0, f, param) => - switch param { - | Empty => Some(v0, d0) - | Node({l, v, d, r}) => - if f(v) { - find_last_opt_aux(v, d, f, r) - } else { - find_last_opt_aux(v0, d0, f, l) - } - } - - let rec find_last_opt = (~f, param) => - switch param { - | Empty => None - | Node({l, v, d, r}) => - if f(v) { - find_last_opt_aux(v, d, f, r) - } else { - find_last_opt(~f, l) - } - } - - let rec find_opt = (x, param) => - switch param { - | Empty => None - | Node({l, v, d, r}) => - let c = Ord.compare(x, v) - if c == 0 { - Some(d) - } else { - find_opt( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let rec mem = (x, param) => - switch param { - | Empty => false - | Node({l, v, r}) => - let c = Ord.compare(x, v) - c == 0 || - mem( - x, - if c < 0 { - l - } else { - r - }, - ) - } - - let rec min_binding = param => - switch param { - | Empty => raise(Not_found) - | Node({l: Empty, v, d}) => (v, d) - | Node({l}) => min_binding(l) - } - - let rec min_binding_opt = param => - switch param { - | Empty => None - | Node({l: Empty, v, d}) => Some(v, d) - | Node({l}) => min_binding_opt(l) - } - - let rec max_binding = param => - switch param { - | Empty => raise(Not_found) - | Node({v, d, r: Empty}) => (v, d) - | Node({r}) => max_binding(r) - } - - let rec max_binding_opt = param => - switch param { - | Empty => None - | Node({v, d, r: Empty}) => Some(v, d) - | Node({r}) => max_binding_opt(r) - } - - let rec remove_min_binding = param => - switch param { - | Empty => invalid_arg("Map.remove_min_elt") - | Node({l: Empty, r}) => r - | Node({l, v, d, r}) => bal(remove_min_binding(l), v, d, r) - } - - let merge = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => - let (x, d) = min_binding(t2) - bal(t1, x, d, remove_min_binding(t2)) - } - - let rec remove = (x, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r}) as m => - let c = Ord.compare(x, v) - if c == 0 { - merge(l, r) - } else if c < 0 { - let ll = remove(x, l) - if l === ll { - m - } else { - bal(ll, v, d, r) - } - } else { - let rr = remove(x, r) - if r === rr { - m - } else { - bal(l, v, d, rr) - } - } - } - - let rec update = (~key as x, ~f, param) => - switch param { - | Empty => - switch f(None) { - | None => Empty - | Some(data) => Node({l: Empty, v: x, d: data, r: Empty, h: 1}) - } - | Node({l, v, d, r, h}) as m => - let c = Ord.compare(x, v) - if c == 0 { - switch f(Some(d)) { - | None => merge(l, r) - | Some(data) => - if d === data { - m - } else { - Node({l, v: x, d: data, r, h}) - } - } - } else if c < 0 { - let ll = update(~key=x, ~f, l) - if l === ll { - m - } else { - bal(ll, v, d, r) - } - } else { - let rr = update(~key=x, ~f, r) - if r === rr { - m - } else { - bal(l, v, d, rr) - } - } - } - - let rec iter = (~f, param) => - switch param { - | Empty => () - | Node({l, v, d, r}) => - iter(~f, l) - f(~key=v, ~data=d) - iter(~f, r) - } - - let rec map = (~f, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r, h}) => - let l' = map(~f, l) - let d' = f(d) - let r' = map(~f, r) - Node({l: l', v, d: d', r: r', h}) - } - - let rec mapi = (~f, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r, h}) => - let l' = mapi(~f, l) - let d' = f(v, d) - let r' = mapi(~f, r) - Node({l: l', v, d: d', r: r', h}) - } - - let rec fold = (~f, m, ~init as accu) => - switch m { - | Empty => accu - | Node({l, v, d, r}) => fold(~f, r, ~init=f(~key=v, ~data=d, fold(~f, l, ~init=accu))) - } - - let rec for_all = (~f as p, param) => - switch param { - | Empty => true - | Node({l, v, d, r}) => p(v, d) && (for_all(~f=p, l) && for_all(~f=p, r)) - } - - let rec exists = (~f as p, param) => - switch param { - | Empty => false - | Node({l, v, d, r}) => p(v, d) || (exists(~f=p, l) || exists(~f=p, r)) - } - - /* Beware: those two functions assume that the added k is *strictly* - smaller (or bigger) than all the present keys in the tree; it - does not test for equality with the current min (or max) key. - - Indeed, they are only used during the "join" operation which - respects this precondition. - */ - - let rec add_min_binding = (k, x, param) => - switch param { - | Empty => singleton(k, x) - | Node({l, v, d, r}) => bal(add_min_binding(k, x, l), v, d, r) - } - - let rec add_max_binding = (k, x, param) => - switch param { - | Empty => singleton(k, x) - | Node({l, v, d, r}) => bal(l, v, d, add_max_binding(k, x, r)) - } - - /* Same as create and bal, but no assumptions are made on the - relative heights of l and r. */ - - let rec join = (l, v, d, r) => - switch (l, r) { - | (Empty, _) => add_min_binding(v, d, r) - | (_, Empty) => add_max_binding(v, d, l) - | (Node({l: ll, v: lv, d: ld, r: lr, h: lh}), Node({l: rl, v: rv, d: rd, r: rr, h: rh})) => - if lh > rh + 2 { - bal(ll, lv, ld, join(lr, v, d, r)) - } else if rh > lh + 2 { - bal(join(l, v, d, rl), rv, rd, rr) - } else { - create(l, v, d, r) - } - } - - /* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. */ - - let concat = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => - let (x, d) = min_binding(t2) - join(t1, x, d, remove_min_binding(t2)) - } - - let concat_or_join = (t1, v, d, t2) => - switch d { - | Some(d) => join(t1, v, d, t2) - | None => concat(t1, t2) - } - - let rec split = (x, param) => - switch param { - | Empty => (Empty, None, Empty) - | Node({l, v, d, r}) => - let c = Ord.compare(x, v) - if c == 0 { - (l, Some(d), r) - } else if c < 0 { - let (ll, pres, rl) = split(x, l) - (ll, pres, join(rl, v, d, r)) - } else { - let (lr, pres, rr) = split(x, r) - (join(l, v, d, lr), pres, rr) - } - } - - let rec merge = (~f, s1, s2) => - switch (s1, s2) { - | (Empty, Empty) => Empty - | (Node({l: l1, v: v1, d: d1, r: r1, h: h1}), _) if h1 >= height(s2) => - let (l2, d2, r2) = split(v1, s2) - concat_or_join(merge(~f, l1, l2), v1, f(v1, Some(d1), d2), merge(~f, r1, r2)) - | (_, Node({l: l2, v: v2, d: d2, r: r2})) => - let (l1, d1, r1) = split(v2, s1) - concat_or_join(merge(~f, l1, l2), v2, f(v2, d1, Some(d2)), merge(~f, r1, r2)) - | _ => assert(false) - } - - let rec union = (~f, s1, s2) => - switch (s1, s2) { - | (Empty, s) | (s, Empty) => s - | (Node({l: l1, v: v1, d: d1, r: r1, h: h1}), Node({l: l2, v: v2, d: d2, r: r2, h: h2})) => - if h1 >= h2 { - let (l2, d2, r2) = split(v1, s2) - let l = union(~f, l1, l2) and r = union(~f, r1, r2) - switch d2 { - | None => join(l, v1, d1, r) - | Some(d2) => concat_or_join(l, v1, f(v1, d1, d2), r) - } - } else { - let (l1, d1, r1) = split(v2, s1) - let l = union(~f, l1, l2) and r = union(~f, r1, r2) - switch d1 { - | None => join(l, v2, d2, r) - | Some(d1) => concat_or_join(l, v2, f(v2, d1, d2), r) - } - } - } - - let rec filter = (~f as p, param) => - switch param { - | Empty => Empty - | Node({l, v, d, r}) as m => - /* call [p] in the expected left-to-right order */ - let l' = filter(~f=p, l) - let pvd = p(v, d) - let r' = filter(~f=p, r) - if pvd { - if l === l' && r === r' { - m - } else { - join(l', v, d, r') - } - } else { - concat(l', r') - } - } - - let rec partition = (~f as p, param) => - switch param { - | Empty => (Empty, Empty) - | Node({l, v, d, r}) => - /* call [p] in the expected left-to-right order */ - let (lt, lf) = partition(~f=p, l) - let pvd = p(v, d) - let (rt, rf) = partition(~f=p, r) - if pvd { - (join(lt, v, d, rt), concat(lf, rf)) - } else { - (concat(lt, rt), join(lf, v, d, rf)) - } - } - - type rec enumeration<'a> = End | More(key, 'a, t<'a>, enumeration<'a>) - - let rec cons_enum = (m, e) => - switch m { - | Empty => e - | Node({l, v, d, r}) => cons_enum(l, More(v, d, r, e)) - } - - let compare = (~cmp, m1, m2) => { - let rec compare_aux = (e1, e2) => - switch (e1, e2) { - | (End, End) => 0 - | (End, _) => -1 - | (_, End) => 1 - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) => - let c = Ord.compare(v1, v2) - if c != 0 { - c - } else { - let c = cmp(d1, d2) - if c != 0 { - c - } else { - compare_aux(cons_enum(r1, e1), cons_enum(r2, e2)) - } - } - } - compare_aux(cons_enum(m1, End), cons_enum(m2, End)) - } - - let equal = (~cmp, m1, m2) => { - let rec equal_aux = (e1, e2) => - switch (e1, e2) { - | (End, End) => true - | (End, _) => false - | (_, End) => false - | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) => - Ord.compare(v1, v2) == 0 && (cmp(d1, d2) && equal_aux(cons_enum(r1, e1), cons_enum(r2, e2))) - } - equal_aux(cons_enum(m1, End), cons_enum(m2, End)) - } - - let rec cardinal = param => - switch param { - | Empty => 0 - | Node({l, r}) => cardinal(l) + 1 + cardinal(r) - } - - let rec bindings_aux = (accu, param) => - switch param { - | Empty => accu - | Node({l, v, d, r}) => bindings_aux(list{(v, d), ...bindings_aux(accu, r)}, l) - } - - let bindings = s => bindings_aux(list{}, s) - - let choose = min_binding - - let choose_opt = min_binding_opt -} diff --git a/jscomp/stdlib-406/moreLabels.res b/jscomp/stdlib-406/moreLabels.res deleted file mode 100644 index 2fb9e46..0000000 --- a/jscomp/stdlib-406/moreLabels.res +++ /dev/null @@ -1,22 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2001 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. */ -/* */ -/* ************************************************************************ */ - -/* Module [MoreLabels]: meta-module for compatibility labelled libraries */ - -module Hashtbl = HashtblLabels - -module Map = MapLabels - -module Set = SetLabels diff --git a/jscomp/stdlib-406/moreLabels.resi b/jscomp/stdlib-406/moreLabels.resi deleted file mode 100644 index 397641d..0000000 --- a/jscomp/stdlib-406/moreLabels.resi +++ /dev/null @@ -1,182 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2001 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. */ -/* */ -/* ************************************************************************ */ - -/*** Extra labeled libraries. - - This meta-module provides labelized version of the {!Hashtbl}, - {!Map} and {!Set} modules. - - They only differ by their labels. They are provided to help - porting from previous versions of OCaml. - The contents of this module are subject to change. -*/ - -module Hashtbl: { - type t<'a, 'b> = Hashtbl.t<'a, 'b> - let create: (~random: bool=?, int) => t<'a, 'b> - let clear: t<'a, 'b> => unit - let reset: t<'a, 'b> => unit - let copy: t<'a, 'b> => t<'a, 'b> - let add: (t<'a, 'b>, ~key: 'a, ~data: 'b) => unit - let find: (t<'a, 'b>, 'a) => 'b - let find_opt: (t<'a, 'b>, 'a) => option<'b> - let find_all: (t<'a, 'b>, 'a) => list<'b> - let mem: (t<'a, 'b>, 'a) => bool - let remove: (t<'a, 'b>, 'a) => unit - let replace: (t<'a, 'b>, ~key: 'a, ~data: 'b) => unit - let iter: (~f: (~key: 'a, ~data: 'b) => unit, t<'a, 'b>) => unit - let filter_map_inplace: (~f: (~key: 'a, ~data: 'b) => option<'b>, t<'a, 'b>) => unit - let fold: (~f: (~key: 'a, ~data: 'b, 'c) => 'c, t<'a, 'b>, ~init: 'c) => 'c - let length: t<'a, 'b> => int - let randomize: unit => unit - let is_randomized: unit => bool - type statistics = Hashtbl.statistics - let stats: t<'a, 'b> => statistics - module type HashedType = Hashtbl.HashedType - module type SeededHashedType = Hashtbl.SeededHashedType - module type S = { - type rec key - and t<'a> - let create: int => t<'a> - let clear: t<'a> => unit - let reset: t<'a> => unit - let copy: t<'a> => t<'a> - let add: (t<'a>, ~key: key, ~data: 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - let find_opt: (t<'a>, key) => option<'a> - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, ~key: key, ~data: 'a) => unit - let mem: (t<'a>, key) => bool - let iter: (~f: (~key: key, ~data: 'a) => unit, t<'a>) => unit - let filter_map_inplace: (~f: (~key: key, ~data: 'a) => option<'a>, t<'a>) => unit - let fold: (~f: (~key: key, ~data: 'a, 'b) => 'b, t<'a>, ~init: 'b) => 'b - let length: t<'a> => int - let stats: t<'a> => statistics - } - module type SeededS = { - type rec key - and t<'a> - let create: (~random: bool=?, int) => t<'a> - let clear: t<'a> => unit - let reset: t<'a> => unit - let copy: t<'a> => t<'a> - let add: (t<'a>, ~key: key, ~data: 'a) => unit - let remove: (t<'a>, key) => unit - let find: (t<'a>, key) => 'a - let find_opt: (t<'a>, key) => option<'a> - let find_all: (t<'a>, key) => list<'a> - let replace: (t<'a>, ~key: key, ~data: 'a) => unit - let mem: (t<'a>, key) => bool - let iter: (~f: (~key: key, ~data: 'a) => unit, t<'a>) => unit - let filter_map_inplace: (~f: (~key: key, ~data: 'a) => option<'a>, t<'a>) => unit - let fold: (~f: (~key: key, ~data: 'a, 'b) => 'b, t<'a>, ~init: 'b) => 'b - let length: t<'a> => int - let stats: t<'a> => statistics - } - module Make: (H: HashedType) => (S with type key = H.t) - module MakeSeeded: (H: SeededHashedType) => (SeededS with type key = H.t) - let hash: 'a => int - let seeded_hash: (int, 'a) => int - let hash_param: (int, int, 'a) => int - let seeded_hash_param: (int, int, int, 'a) => int -} - -module Map: { - module type OrderedType = Map.OrderedType - module type S = { - type rec key - and t<+'a> - let empty: t<'a> - let is_empty: t<'a> => bool - let mem: (key, t<'a>) => bool - let add: (~key: key, ~data: 'a, t<'a>) => t<'a> - let update: (~key: key, ~f: option<'a> => option<'a>, t<'a>) => t<'a> - let singleton: (key, 'a) => t<'a> - let remove: (key, t<'a>) => t<'a> - let merge: (~f: (key, option<'a>, option<'b>) => option<'c>, t<'a>, t<'b>) => t<'c> - let union: (~f: (key, 'a, 'a) => option<'a>, t<'a>, t<'a>) => t<'a> - let compare: (~cmp: ('a, 'a) => int, t<'a>, t<'a>) => int - let equal: (~cmp: ('a, 'a) => bool, t<'a>, t<'a>) => bool - let iter: (~f: (~key: key, ~data: 'a) => unit, t<'a>) => unit - let fold: (~f: (~key: key, ~data: 'a, 'b) => 'b, t<'a>, ~init: 'b) => 'b - let for_all: (~f: (key, 'a) => bool, t<'a>) => bool - let exists: (~f: (key, 'a) => bool, t<'a>) => bool - let filter: (~f: (key, 'a) => bool, t<'a>) => t<'a> - let partition: (~f: (key, 'a) => bool, t<'a>) => (t<'a>, t<'a>) - let cardinal: t<'a> => int - let bindings: t<'a> => list<(key, 'a)> - let min_binding: t<'a> => (key, 'a) - let min_binding_opt: t<'a> => option<(key, 'a)> - let max_binding: t<'a> => (key, 'a) - let max_binding_opt: t<'a> => option<(key, 'a)> - let choose: t<'a> => (key, 'a) - let choose_opt: t<'a> => option<(key, 'a)> - let split: (key, t<'a>) => (t<'a>, option<'a>, t<'a>) - let find: (key, t<'a>) => 'a - let find_opt: (key, t<'a>) => option<'a> - let find_first: (~f: key => bool, t<'a>) => (key, 'a) - let find_first_opt: (~f: key => bool, t<'a>) => option<(key, 'a)> - let find_last: (~f: key => bool, t<'a>) => (key, 'a) - let find_last_opt: (~f: key => bool, t<'a>) => option<(key, 'a)> - let map: (~f: 'a => 'b, t<'a>) => t<'b> - let mapi: (~f: (key, 'a) => 'b, t<'a>) => t<'b> - } - module Make: (Ord: OrderedType) => (S with type key = Ord.t) -} - -module Set: { - module type OrderedType = Set.OrderedType - module type S = { - type rec elt - and t - let empty: t - let is_empty: t => bool - let mem: (elt, t) => bool - let add: (elt, t) => t - let singleton: elt => t - let remove: (elt, t) => t - let union: (t, t) => t - let inter: (t, t) => t - let diff: (t, t) => t - let compare: (t, t) => int - let equal: (t, t) => bool - let subset: (t, t) => bool - let iter: (~f: elt => unit, t) => unit - let map: (~f: elt => elt, t) => t - let fold: (~f: (elt, 'a) => 'a, t, ~init: 'a) => 'a - let for_all: (~f: elt => bool, t) => bool - let exists: (~f: elt => bool, t) => bool - let filter: (~f: elt => bool, t) => t - let partition: (~f: elt => bool, t) => (t, t) - let cardinal: t => int - let elements: t => list - let min_elt: t => elt - let min_elt_opt: t => option - let max_elt: t => elt - let max_elt_opt: t => option - let choose: t => elt - let choose_opt: t => option - let split: (elt, t) => (t, bool, t) - let find: (elt, t) => elt - let find_opt: (elt, t) => option - let find_first: (~f: elt => bool, t) => elt - let find_first_opt: (~f: elt => bool, t) => option - let find_last: (~f: elt => bool, t) => elt - let find_last_opt: (~f: elt => bool, t) => option - let of_list: list => t - } - module Make: (Ord: OrderedType) => (S with type elt = Ord.t) -} diff --git a/jscomp/stdlib-406/obj.res b/jscomp/stdlib-406/obj.res deleted file mode 100644 index faa1e61..0000000 --- a/jscomp/stdlib-406/obj.res +++ /dev/null @@ -1,29 +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. */ -/* */ -/* ************************************************************************ */ - -/* Operations on internal representations of values */ - -type t - -external repr: 'a => t = "%identity" -external obj: t => 'a = "%identity" -external magic: 'a => 'b = "%identity" -external is_int: t => bool = "%obj_is_int" -@inline(always) let is_block = a => !is_int(a) -external tag: t => int = "?obj_tag" -external size: t => int = "#obj_length" -external field: (t, int) => t = "%obj_field" -external set_field: (t, int, t) => unit = "%obj_set_field" -external dup: t => t = "?obj_dup" diff --git a/jscomp/stdlib-406/obj.resi b/jscomp/stdlib-406/obj.resi deleted file mode 100644 index 28bb954..0000000 --- a/jscomp/stdlib-406/obj.resi +++ /dev/null @@ -1,51 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Operations on internal representations of values. - - Not for the casual user. -*/ - -type t - -external repr: 'a => t = "%identity" -external obj: t => 'a = "%identity" -external magic: 'a => 'b = "%identity" -@inline(always) let is_block: t => bool - -external tag: t => int = "?obj_tag" -/** - Computes the total size (in words, including the headers) of all - heap blocks accessible from the argument. Statically - allocated blocks are excluded. - - @Since 4.04 -*/ -external size: t => int = "#obj_length" - -external field: (t, int) => t = "%obj_field" - -/** When using flambda: - - [set_field] MUST NOT be called on immutable blocks. (Blocks allocated - in C stubs, or with [new_block] below, are always considered mutable.) - - For experts only: - [set_field] et al can be made safe by first wrapping the block in - {!Sys.opaque_identity}, so any information about its contents will not - be propagated. -*/ -external set_field: (t, int, t) => unit = "%obj_set_field" -external dup: t => t = "?obj_dup" diff --git a/jscomp/stdlib-406/parsing.res b/jscomp/stdlib-406/parsing.res deleted file mode 100644 index 6614e94..0000000 --- a/jscomp/stdlib-406/parsing.res +++ /dev/null @@ -1,232 +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. */ -/* */ -/* ************************************************************************ */ - -/* The parsing engine */ - -open Lexing - -/* Internal interface to the parsing engine */ - -type parser_env = { - mutable s_stack: array /* States */, - mutable v_stack: array /* Semantic attributes */, - mutable symb_start_stack: array /* Start positions */, - mutable symb_end_stack: array /* End positions */, - mutable stacksize: int /* Size of the stacks */, - mutable stackbase: int /* Base sp for current parse */, - mutable curr_char: int /* Last token read */, - mutable lval: Obj.t /* Its semantic attribute */, - mutable symb_start: position /* Start pos. of the current symbol */, - mutable symb_end: position /* End pos. of the current symbol */, - mutable asp: int /* The stack pointer for attributes */, - mutable rule_len: int /* Number of rhs items in the rule */, - mutable rule_number: int /* Rule number to reduce by */, - mutable sp: int /* Saved sp for parse_engine */, - mutable state: int /* Saved state for parse_engine */, - mutable errflag: int, -} /* Saved error flag for parse_engine */ - -type parse_tables = { - actions: array Obj.t>, - transl_const: array, - transl_block: array, - lhs: string, - len: string, - defred: string, - dgoto: string, - sindex: string, - rindex: string, - gindex: string, - tablesize: int, - table: string, - check: string, - error_function: string => unit, - names_const: string, - names_block: string, -} - -exception YYexit(Obj.t) -exception Parse_error - -type parser_input = - | Start - | Token_read - | Stacks_grown_1 - | Stacks_grown_2 - | Semantic_action_computed - | Error_detected - -type parser_output = - | Read_token - | Raise_parse_error - | Grow_stacks_1 - | Grow_stacks_2 - | Compute_semantic_action - | Call_error_function - -/* to avoid warnings */ -let _ = list{ - Read_token, - Raise_parse_error, - Grow_stacks_1, - Grow_stacks_2, - Compute_semantic_action, - Call_error_function, -} - -external parse_engine: (parse_tables, parser_env, parser_input, Obj.t) => parser_output = - "?parse_engine" - -external set_trace: bool => bool = "?set_parser_trace" - -let env = { - s_stack: Array.make(100, 0), - v_stack: Array.make(100, Obj.repr()), - symb_start_stack: Array.make(100, dummy_pos), - symb_end_stack: Array.make(100, dummy_pos), - stacksize: 100, - stackbase: 0, - curr_char: 0, - lval: Obj.repr(), - symb_start: dummy_pos, - symb_end: dummy_pos, - asp: 0, - rule_len: 0, - rule_number: 0, - sp: 0, - state: 0, - errflag: 0, -} - -let grow_stacks = () => { - let oldsize = env.stacksize - let newsize = oldsize * 2 - let new_s = Array.make(newsize, 0) - and new_v = Array.make(newsize, Obj.repr()) - and new_start = Array.make(newsize, dummy_pos) - and new_end = Array.make(newsize, dummy_pos) - Array.blit(env.s_stack, 0, new_s, 0, oldsize) - env.s_stack = new_s - Array.blit(env.v_stack, 0, new_v, 0, oldsize) - env.v_stack = new_v - Array.blit(env.symb_start_stack, 0, new_start, 0, oldsize) - env.symb_start_stack = new_start - Array.blit(env.symb_end_stack, 0, new_end, 0, oldsize) - env.symb_end_stack = new_end - env.stacksize = newsize -} - -let clear_parser = () => { - Array.fill(env.v_stack, 0, env.stacksize, Obj.repr()) - env.lval = Obj.repr() -} - -let current_lookahead_fun = ref((_: Obj.t) => false) - -let yyparse = (tables, start, lexer, lexbuf) => { - let rec loop = (cmd, arg) => - switch parse_engine(tables, env, cmd, arg) { - | Read_token => - let t = Obj.repr(lexer(lexbuf)) - env.symb_start = lexbuf.lex_start_p - env.symb_end = lexbuf.lex_curr_p - loop(Token_read, t) - | Raise_parse_error => raise(Parse_error) - | Compute_semantic_action => - let (action, value) = try ( - Semantic_action_computed, - tables.actions[env.rule_number](env), - ) catch { - | Parse_error => (Error_detected, Obj.repr()) - } - loop(action, value) - | Grow_stacks_1 => - grow_stacks() - loop(Stacks_grown_1, Obj.repr()) - | Grow_stacks_2 => - grow_stacks() - loop(Stacks_grown_2, Obj.repr()) - | Call_error_function => - tables.error_function("syntax error") - loop(Error_detected, Obj.repr()) - } - let init_asp = env.asp - and init_sp = env.sp - and init_stackbase = env.stackbase - and init_state = env.state - and init_curr_char = env.curr_char - and init_lval = env.lval - and init_errflag = env.errflag - env.stackbase = env.sp + 1 - env.curr_char = start - env.symb_end = lexbuf.lex_curr_p - try loop(Start, Obj.repr()) catch { - | exn => - let curr_char = env.curr_char - env.asp = init_asp - env.sp = init_sp - env.stackbase = init_stackbase - env.state = init_state - env.curr_char = init_curr_char - env.lval = init_lval - env.errflag = init_errflag - switch exn { - | YYexit(v) => Obj.magic(v) - | _ => - current_lookahead_fun := - ( - tok => - if Js.typeof(tok) != "number" { - tables.transl_block[Obj.tag(tok)] == curr_char - } else { - tables.transl_const[Obj.magic(tok)] == curr_char - } - ) - raise(exn) - } - } -} - -let peek_val = (env, n) => Obj.magic(env.v_stack[env.asp - n]) - -let symbol_start_pos = () => { - let rec loop = i => - if i <= 0 { - env.symb_end_stack[env.asp] - } else { - let st = env.symb_start_stack[env.asp - i + 1] - let en = env.symb_end_stack[env.asp - i + 1] - if st != en { - st - } else { - loop(i - 1) - } - } - - loop(env.rule_len) -} - -let symbol_end_pos = () => env.symb_end_stack[env.asp] -let rhs_start_pos = n => env.symb_start_stack[env.asp - (env.rule_len - n)] -let rhs_end_pos = n => env.symb_end_stack[env.asp - (env.rule_len - n)] - -let symbol_start = () => symbol_start_pos().pos_cnum -let symbol_end = () => symbol_end_pos().pos_cnum -let rhs_start = n => rhs_start_pos(n).pos_cnum -let rhs_end = n => rhs_end_pos(n).pos_cnum - -let is_current_lookahead = tok => current_lookahead_fun.contents(Obj.repr(tok)) - -let parse_error = (_: string) => () diff --git a/jscomp/stdlib-406/parsing.resi b/jscomp/stdlib-406/parsing.resi deleted file mode 100644 index f93fd0f..0000000 --- a/jscomp/stdlib-406/parsing.resi +++ /dev/null @@ -1,101 +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. */ -/* */ -/* ************************************************************************ */ - -/* The run-time library for parsers generated by [ocamlyacc]. */ - -/** [symbol_start] and {!Parsing.symbol_end} are to be called in the - action part of a grammar rule only. They return the offset of the - string that matches the left-hand side of the rule: [symbol_start()] - returns the offset of the first character; [symbol_end()] returns the - offset after the last character. The first character in a file is at - offset 0. */ -let symbol_start: unit => int - -/** See {!Parsing.symbol_start}. */ -let symbol_end: unit => int - -/** Same as {!Parsing.symbol_start} and {!Parsing.symbol_end}, but - return the offset of the string matching the [n]th item on the - right-hand side of the rule, where [n] is the integer parameter - to [rhs_start] and [rhs_end]. [n] is 1 for the leftmost item. */ -let rhs_start: int => int - -/** See {!Parsing.rhs_start}. */ -let rhs_end: int => int - -/** Same as [symbol_start], but return a [position] instead of an offset. */ -let symbol_start_pos: unit => Lexing.position - -/** Same as [symbol_end], but return a [position] instead of an offset. */ -let symbol_end_pos: unit => Lexing.position - -/** Same as [rhs_start], but return a [position] instead of an offset. */ -let rhs_start_pos: int => Lexing.position - -/** Same as [rhs_end], but return a [position] instead of an offset. */ -let rhs_end_pos: int => Lexing.position - -/** Empty the parser stack. Call it just after a parsing function - has returned, to remove all pointers from the parser stack - to structures that were built by semantic actions during parsing. - This is optional, but lowers the memory requirements of the - programs. */ -let clear_parser: unit => unit - -/** Raised when a parser encounters a syntax error. - Can also be raised from the action part of a grammar rule, - to initiate error recovery. */ -exception Parse_error - -/** Control debugging support for [ocamlyacc]-generated parsers. - After [Parsing.set_trace true], the pushdown automaton that - executes the parsers prints a trace of its actions (reading a token, - shifting a state, reducing by a rule) on standard output. - [Parsing.set_trace false] turns this debugging trace off. - The boolean returned is the previous state of the trace flag. - @since 3.11.0 -*/ -let set_trace: bool => bool - -/* The following definitions are used by the generated parsers only. - They are not intended to be used directly by user programs. */ - -type parser_env - -type parse_tables = { - actions: array Obj.t>, - transl_const: array, - transl_block: array, - lhs: string, - len: string, - defred: string, - dgoto: string, - sindex: string, - rindex: string, - gindex: string, - tablesize: int, - table: string, - check: string, - error_function: string => unit, - names_const: string, - names_block: string, -} - -exception YYexit(Obj.t) - -let yyparse: (parse_tables, int, Lexing.lexbuf => 'a, Lexing.lexbuf) => 'b -let peek_val: (parser_env, int) => 'a -let is_current_lookahead: 'a => bool -let parse_error: string => unit diff --git a/jscomp/stdlib-406/pervasives.res b/jscomp/stdlib-406/pervasives.res deleted file mode 100644 index 632d0b7..0000000 --- a/jscomp/stdlib-406/pervasives.res +++ /dev/null @@ -1,322 +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. */ -/* */ -/* ************************************************************************ */ - -module Jsx = JsxC -module JsxEvent = JsxEventC -module JsxDOM = JsxDOMC -module JsxPPXReactSupport = JsxPPXReactSupportC - -module JsxModules = { - module Jsx = JsxC - module JsxEvent = JsxEventC - module JsxDOM = JsxDOMC -} - -/* Internal */ -external __unsafe_cast: 'a => 'b = "%identity" - -/* Exceptions */ - -external raise: exn => 'a = "%raise" -external raise_notrace: exn => 'a = "%raise_notrace" - -let failwith = s => raise(Failure(s)) -let invalid_arg = s => raise(Invalid_argument(s)) - -exception Exit - -/* Composition operators */ - -external \"|>": ('a, 'a => 'b) => 'b = "%revapply" -external \"@@": ('a => 'b, 'a) => 'b = "%apply" - -/* Debugging */ - -external __LOC__: string = "%loc_LOC" -external __FILE__: string = "%loc_FILE" -external __LINE__: int = "%loc_LINE" -external __MODULE__: string = "%loc_MODULE" -external __POS__: (string, int, int, int) = "%loc_POS" - -external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC" -external __LINE_OF__: 'a => (int, 'a) = "%loc_LINE" -external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" - -/* Comparisons */ - -external \"=": ('a, 'a) => bool = "%equal" -external \"<>": ('a, 'a) => bool = "%notequal" -external \"<": ('a, 'a) => bool = "%lessthan" -external \">": ('a, 'a) => bool = "%greaterthan" -external \"<=": ('a, 'a) => bool = "%lessequal" -external \">=": ('a, 'a) => bool = "%greaterequal" -external compare: ('a, 'a) => int = "%compare" -external min: ('a, 'a) => 'a = "%bs_min" -external max: ('a, 'a) => 'a = "%bs_max" -external \"==": ('a, 'a) => bool = "%eq" -external \"!=": ('a, 'a) => bool = "%noteq" - -/* Boolean operations */ - -external not: bool => bool = "%boolnot" - -external \"&&": (bool, bool) => bool = "%sequand" - -external \"||": (bool, bool) => bool = "%sequor" - -/* Integer operations */ - -external \"~-": int => int = "%negint" -external \"~+": int => int = "%identity" -external succ: int => int = "%succint" -external pred: int => int = "%predint" -external \"+": (int, int) => int = "%addint" -external \"-": (int, int) => int = "%subint" -external \"*": (int, int) => int = "%mulint" -external \"/": (int, int) => int = "%divint" -external mod: (int, int) => int = "%modint" - -let abs = x => - if x >= 0 { - x - } else { - -x - } - -external land: (int, int) => int = "%andint" -external lor: (int, int) => int = "%orint" -external lxor: (int, int) => int = "%xorint" - -let lnot = x => lxor(x, -1) - -external lsl: (int, int) => int = "%lslint" -external lsr: (int, int) => int = "%lsrint" -external asr: (int, int) => int = "%asrint" - -let max_int = lsr(-1, 1) -let min_int = max_int + 1 - -/* Floating-point operations */ - -external \"~-.": float => float = "%negfloat" -external \"~+.": float => float = "%identity" -external \"+.": (float, float) => float = "%addfloat" -external \"-.": (float, float) => float = "%subfloat" -external \"*.": (float, float) => float = "%mulfloat" -external \"/.": (float, float) => float = "%divfloat" - -@val @scope("Math") external \"**": (float, float) => float = "pow" -@val @scope("Math") external exp: float => float = "exp" -external expm1: float => float = "?expm1_float" - -@val @scope("Math") external acos: float => float = "acos" -@val @scope("Math") external asin: float => float = "asin" -@val @scope("Math") external atan: float => float = "atan" -@val @scope("Math") external atan2: (float, float) => float = "atan2" -external hypot: (float, float) => float = "?hypot_float" - -@val @scope("Math") external cos: float => float = "cos" -@val @scope("Math") external cosh: float => float = "cosh" -@val @scope("Math") external log: float => float = "log" -@val @scope("Math") external log10: float => float = "log10" -@val @scope("Math") external log1p: float => float = "log1p" -@val @scope("Math") external sin: float => float = "sin" -@val @scope("Math") external sinh: float => float = "sinh" -@val @scope("Math") external sqrt: float => float = "sqrt" -@val @scope("Math") external tan: float => float = "tan" -@val @scope("Math") external tanh: float => float = "tanh" -@val @scope("Math") external ceil: float => float = "ceil" -@val @scope("Math") external floor: float => float = "floor" -@val @scope("Math") external abs_float: float => float = "abs" -external copysign: (float, float) => float = "?copysign_float" -external mod_float: (float, float) => float = "?fmod_float" -external frexp: float => (float, int) = "?frexp_float" -external ldexp: (float, int) => float = "?ldexp_float" -external modf: float => (float, float) = "?modf_float" -external float: int => float = "%floatofint" -external float_of_int: int => float = "%floatofint" -external truncate: float => int = "%intoffloat" -external int_of_float: float => int = "%intoffloat" - -let infinity = 0x1p2047 -let neg_infinity = -0x1p2047 -@val @scope("Number") external nan: float = "NaN" -let max_float = 1.79769313486231571e+308 /* 0x1.ffff_ffff_ffff_fp+1023 */ -let min_float = 2.22507385850720138e-308 /* 0x1p-1022 */ -let epsilon_float = 2.22044604925031308e-16 /* 0x1p-52 */ - -type fpclass = - | FP_normal - | FP_subnormal - | FP_zero - | FP_infinite - | FP_nan - -let classify_float = (x: float): fpclass => - if (%raw(`isFinite`): (. _) => _)(. x) { - if abs_float(x) >= /* 0x1p-1022 */ /* 2.22507385850720138e-308 */ min_float { - FP_normal - } else if x != 0. { - FP_subnormal - } else { - FP_zero - } - } else if (%raw(`isNaN`): (. _) => _)(. x) { - FP_nan - } else { - FP_infinite - } - -/* String and byte sequence operations -- more in modules String and Bytes */ - -external string_length: string => int = "%string_length" - -external \"^": (string, string) => string = "#string_append" -/* Character operations -- more in module Char */ - -external int_of_char: char => int = "%identity" -external unsafe_char_of_int: int => char = "%identity" -let char_of_int = n => - if n < 0 || n > 255 { - invalid_arg("char_of_int") - } else { - unsafe_char_of_int(n) - } - -/* Unit operations */ - -external ignore: 'a => unit = "%ignore" - -/* Pair operations */ - -external fst: (('a, 'b)) => 'a = "%field0" -external snd: (('a, 'b)) => 'b = "%field1" - -/* References */ - -type ref<'a> = {mutable contents: 'a} -external ref: 'a => ref<'a> = "%makemutable" -external \"!": ref<'a> => 'a = "%bs_ref_field0" -external \":=": (ref<'a>, 'a) => unit = "%bs_ref_setfield0" -external incr: ref => unit = "%incr" -external decr: ref => unit = "%decr" - -/* String conversion functions */ -external format_float: (string, float) => string = "?format_float" - -let string_of_bool = b => - if b { - "true" - } else { - "false" - } -let bool_of_string = param => - switch param { - | "true" => true - | "false" => false - | _ => invalid_arg("bool_of_string") - } - -let bool_of_string_opt = param => - switch param { - | "true" => Some(true) - | "false" => Some(false) - | _ => None - } - -@val external string_of_int: int => string = "String" - -external int_of_string: string => int = "?int_of_string" - -let int_of_string_opt = s => - /* TODO: provide this directly as a non-raising primitive. */ - try Some(int_of_string(s)) catch { - | Failure(_) => None - } - -external string_get: (string, int) => char = "%string_safe_get" - -let valid_float_lexem = s => { - let l = string_length(s) - let rec loop = i => - if i >= l { - s ++ "." - } else { - switch string_get(s, i) { - | '0' .. '9' | '-' => loop(i + 1) - | _ => s - } - } - - loop(0) -} - -let string_of_float = f => valid_float_lexem(format_float("%.12g", f)) - -external float_of_string: string => float = "?float_of_string" - -let float_of_string_opt = s => - /* TODO: provide this directly as a non-raising primitive. */ - try Some(float_of_string(s)) catch { - | Failure(_) => None - } - -/* List operations -- more in module List */ - -let rec \"@" = (l1, l2) => - switch l1 { - | list{} => l2 - | list{hd, ...tl} => list{hd, ...\"@"(tl, l2)} - } - -/* Output functions on standard output */ - -@val @scope("console") external print_endline: string => unit = "log" -let print_newline = () => print_endline("") - -/* Output functions on standard error */ - -@val @scope("console") external prerr_endline: string => unit = "error" -let prerr_newline = () => prerr_endline("") - -let print_int = (i: int) => print_endline(string_of_int(i)) -let print_float = (i: float) => print_endline(string_of_float(i)) -let print_string = print_endline - -/* Miscellaneous */ - -external sys_exit: int => 'a = "?sys_exit" - -let exit_function = ref(ignore) - -let at_exit = f => { - let g = exit_function.contents - exit_function := - ( - () => { - f() - g() - } - ) -} - -let do_at_exit = () => exit_function.contents() - -let exit = retcode => { - do_at_exit() - sys_exit(retcode) -} - -type int32 = int diff --git a/jscomp/stdlib-406/pervasives.resi b/jscomp/stdlib-406/pervasives.resi deleted file mode 100644 index 43407ce..0000000 --- a/jscomp/stdlib-406/pervasives.resi +++ /dev/null @@ -1,760 +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. */ -/* */ -/* ************************************************************************ */ - -/*** The initially opened module. - - This module provides the basic operations over the built-in types - (numbers, booleans, byte sequences, strings, exceptions, references, - lists, arrays, input-output channels, ...). - - This module is automatically opened at the beginning of each compilation. - All components of this module can therefore be referred by their short - name, without prefixing them by [Pervasives]. -*/ - -module Jsx = JsxC -module JsxEvent = JsxEventC -module JsxDOM = JsxDOMC -module JsxPPXReactSupport = JsxPPXReactSupportC - -/* For autocomplete */ -module JsxModules: { - module Jsx = JsxC - module JsxEvent = JsxEventC - module JsxDOM = JsxDOMC - // skip JsxPPXReactSupport as it's not user-facing -} - -/* Internal */ -external __unsafe_cast: 'a => 'b = "%identity" -/* 1 Exceptions} */ - -/** Raise the given exception value */ -external raise: exn => 'a = "%raise" - -/** A faster version [raise] which does not record the backtrace. - @since 4.02.0 -*/ -external raise_notrace: exn => 'a = "%raise_notrace" - -/** Raise exception [Invalid_argument] with the given string. */ -let invalid_arg: string => 'a - -/** Raise exception [Failure] with the given string. */ -let failwith: string => 'a - -/** The [Exit] exception is not raised by any library function. It is - provided for use in your programs. */ -exception Exit - -/* {1 Comparisons} */ - -/** [e1 = e2] tests for structural equality of [e1] and [e2]. - Mutable structures (e.g. references and arrays) are equal - if and only if their current contents are structurally equal, - even if the two mutable objects are not the same physical object. - Equality between functional values raises [Invalid_argument]. - Equality between cyclic data structures may not terminate. - Left-associative operator at precedence level 4/11. */ -external \"=": ('a, 'a) => bool = "%equal" - -/** Negation of {!Pervasives.( = )}. - Left-associative operator at precedence level 4/11. */ -external \"<>": ('a, 'a) => bool = "%notequal" - -/** See {!Pervasives.( >= )}. - Left-associative operator at precedence level 4/11. */ -external \"<": ('a, 'a) => bool = "%lessthan" - -/** See {!Pervasives.( >= )}. - Left-associative operator at precedence level 4/11. */ -external \">": ('a, 'a) => bool = "%greaterthan" - -/** See {!Pervasives.( >= )}. - Left-associative operator at precedence level 4/11. */ -external \"<=": ('a, 'a) => bool = "%lessequal" - -/** Structural ordering functions. These functions coincide with - the usual orderings over integers, characters, strings, byte sequences - and floating-point numbers, and extend them to a - total ordering over all types. - The ordering is compatible with [( = )]. As in the case - of [( = )], mutable structures are compared by contents. - Comparison between functional values raises [Invalid_argument]. - Comparison between cyclic structures may not terminate. - Left-associative operator at precedence level 4/11. */ -external \">=": ('a, 'a) => bool = "%greaterequal" - -/** [compare x y] returns [0] if [x] is equal to [y], - a negative integer if [x] is less than [y], and a positive integer - if [x] is greater than [y]. The ordering implemented by [compare] - is compatible with the comparison predicates [=], [<] and [>] - defined above, with one difference on the treatment of the float value - {!Pervasives.nan}. Namely, the comparison predicates treat [nan] - as different from any other float value, including itself; - while [compare] treats [nan] as equal to itself and less than any - other float value. This treatment of [nan] ensures that [compare] - defines a total ordering relation. - - [compare] applied to functional values may raise [Invalid_argument]. - [compare] applied to cyclic structures may not terminate. - - The [compare] function can be used as the comparison function - required by the {!Set.Make} and {!Map.Make} functors, as well as - the {!List.sort} and {!Array.sort} functions. */ -external compare: ('a, 'a) => int = "%compare" - -/** Return the smaller of the two arguments. - The result is unspecified if one of the arguments contains - the float value [nan]. */ -external min: ('a, 'a) => 'a = "%bs_min" - -/** Return the greater of the two arguments. - The result is unspecified if one of the arguments contains - the float value [nan]. */ -external max: ('a, 'a) => 'a = "%bs_max" - -/** [e1 == e2] tests for physical equality of [e1] and [e2]. - On mutable types such as references, arrays, byte sequences, records with - mutable fields and objects with mutable instance variables, - [e1 == e2] is true if and only if physical modification of [e1] - also affects [e2]. - On non-mutable types, the behavior of [( == )] is - implementation-dependent; however, it is guaranteed that - [e1 == e2] implies [compare e1 e2 = 0]. - Left-associative operator at precedence level 4/11. */ -external \"==": ('a, 'a) => bool = "%eq" - -/** Negation of {!Pervasives.( == )}. - Left-associative operator at precedence level 4/11. */ -external \"!=": ('a, 'a) => bool = "%noteq" - -/* {1 Boolean operations} */ - -/** The boolean negation. */ -external not: bool => bool = "%boolnot" - -/** The boolean 'and'. Evaluation is sequential, left-to-right: - in [e1 && e2], [e1] is evaluated first, and if it returns [false], - [e2] is not evaluated at all. - Right-associative operator at precedence level 3/11. */ -external \"&&": (bool, bool) => bool = "%sequand" - -/** The boolean 'or'. Evaluation is sequential, left-to-right: - in [e1 || e2], [e1] is evaluated first, and if it returns [true], - [e2] is not evaluated at all. - Right-associative operator at precedence level 2/11. -*/ -external \"||": (bool, bool) => bool = "%sequor" - -/* {1 Debugging} */ - -/** [__LOC__] returns the location at which this expression appears in - the file currently being parsed by the compiler, with the standard - error format of OCaml: "File %S, line %d, characters %d-%d". - @since 4.02.0 -*/ -external __LOC__: string = "%loc_LOC" - -/** [__FILE__] returns the name of the file currently being - parsed by the compiler. - @since 4.02.0 -*/ -external __FILE__: string = "%loc_FILE" - -/** [__LINE__] returns the line number at which this expression - appears in the file currently being parsed by the compiler. - @since 4.02.0 -*/ -external __LINE__: int = "%loc_LINE" - -/** [__MODULE__] returns the module name of the file being - parsed by the compiler. - @since 4.02.0 -*/ -external __MODULE__: string = "%loc_MODULE" - -/** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding - to the location at which this expression appears in the file - currently being parsed by the compiler. [file] is the current - filename, [lnum] the line number, [cnum] the character position in - the line and [enum] the last character position in the line. - @since 4.02.0 - */ -external __POS__: (string, int, int, int) = "%loc_POS" - -/** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the - location of [expr] in the file currently being parsed by the - compiler, with the standard error format of OCaml: "File %S, line - %d, characters %d-%d". - @since 4.02.0 -*/ -external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC" - -/** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the - line number at which the expression [expr] appears in the file - currently being parsed by the compiler. - @since 4.02.0 - */ -external __LINE_OF__: 'a => (int, 'a) = "%loc_LINE" - -/** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a - tuple [(file,lnum,cnum,enum)] corresponding to the location at - which the expression [expr] appears in the file currently being - parsed by the compiler. [file] is the current filename, [lnum] the - line number, [cnum] the character position in the line and [enum] - the last character position in the line. - @since 4.02.0 - */ -external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" - -/* {1 Composition operators} */ - -/** Reverse-application operator: [x |> f |> g] is exactly equivalent - to [g (f (x))]. - Left-associative operator at precedence level 4/11. - @since 4.01 - */ -external \"|>": ('a, 'a => 'b) => 'b = "%revapply" - -/** Application operator: [g @@ f @@ x] is exactly equivalent to - [g (f (x))]. - Right-associative operator at precedence level 5/11. - @since 4.01 -*/ -external \"@@": ('a => 'b, 'a) => 'b = "%apply" - -/* {1 Integer arithmetic} */ - -/* Integers are 31 bits wide (or 63 bits on 64-bit processors). - All operations are taken modulo 2{^31} (or 2{^63}). - They do not fail on overflow. */ - -/** Unary negation. You can also write [- e] instead of [~- e]. - Unary operator at precedence level 9/11 for [- e] - and 11/11 for [~- e]. */ -external \"~-": int => int = "%negint" - -/** Unary addition. You can also write [+ e] instead of [~+ e]. - Unary operator at precedence level 9/11 for [+ e] - and 11/11 for [~+ e]. - @since 3.12.0 -*/ -external \"~+": int => int = "%identity" - -/** [succ x] is [x + 1]. */ -external succ: int => int = "%succint" - -/** [pred x] is [x - 1]. */ -external pred: int => int = "%predint" - -/** Integer addition. - Left-associative operator at precedence level 6/11. */ -external \"+": (int, int) => int = "%addint" - -/** Integer subtraction. - Left-associative operator at precedence level 6/11. */ -external \"-": (int, int) => int = "%subint" - -/** Integer multiplication. - Left-associative operator at precedence level 7/11. */ -external \"*": (int, int) => int = "%mulint" - -/** Integer division. - Raise [Division_by_zero] if the second argument is 0. - Integer division rounds the real quotient of its arguments towards zero. - More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer - less than or equal to the real quotient of [x] by [y]. Moreover, - [(- x) / y = x / (- y) = - (x / y)]. - Left-associative operator at precedence level 7/11. */ -external \"/": (int, int) => int = "%divint" - -/** Integer remainder. If [y] is not zero, the result - of [x mod y] satisfies the following properties: - [x = (x / y) * y + x mod y] and - [abs(x mod y) <= abs(y) - 1]. - If [y = 0], [x mod y] raises [Division_by_zero]. - Note that [x mod y] is negative only if [x < 0]. - Raise [Division_by_zero] if [y] is zero. - Left-associative operator at precedence level 7/11. */ -external mod: (int, int) => int = "%modint" - -/** Return the absolute value of the argument. Note that this may be - negative if the argument is [min_int]. */ -let abs: int => int - -/** The greatest representable integer. */ -let max_int: int - -/** The smallest representable integer. */ -let min_int: int - -/* {2 Bitwise operations} */ - -/** Bitwise logical and. - Left-associative operator at precedence level 7/11. */ -external land: (int, int) => int = "%andint" - -/** Bitwise logical or. - Left-associative operator at precedence level 7/11. */ -external lor: (int, int) => int = "%orint" - -/** Bitwise logical exclusive or. - Left-associative operator at precedence level 7/11. */ -external lxor: (int, int) => int = "%xorint" - -/** Bitwise logical negation. */ -let lnot: int => int - -/** [n lsl m] shifts [n] to the left by [m] bits. - The result is unspecified if [m < 0] or [m >= bitsize], - where [bitsize] is [32] on a 32-bit platform and - [64] on a 64-bit platform. - Right-associative operator at precedence level 8/11. */ -external lsl: (int, int) => int = "%lslint" - -/** [n lsr m] shifts [n] to the right by [m] bits. - This is a logical shift: zeroes are inserted regardless of - the sign of [n]. - The result is unspecified if [m < 0] or [m >= bitsize]. - Right-associative operator at precedence level 8/11. */ -external lsr: (int, int) => int = "%lsrint" - -/** [n asr m] shifts [n] to the right by [m] bits. - This is an arithmetic shift: the sign bit of [n] is replicated. - The result is unspecified if [m < 0] or [m >= bitsize]. - Right-associative operator at precedence level 8/11. */ -external asr: (int, int) => int = "%asrint" - -/* {1 Floating-point arithmetic} - - OCaml's floating-point numbers follow the - IEEE 754 standard, using double precision (64 bits) numbers. - Floating-point operations never raise an exception on overflow, - underflow, division by zero, etc. Instead, special IEEE numbers - are returned as appropriate, such as [infinity] for [1.0 /. 0.0], - [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') - for [0.0 /. 0.0]. These special numbers then propagate through - floating-point computations as expected: for instance, - [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] - as argument returns [nan] as result. -*/ - -/** Unary negation. You can also write [-. e] instead of [~-. e]. - Unary operator at precedence level 9/11 for [-. e] - and 11/11 for [~-. e]. */ -external \"~-.": float => float = "%negfloat" - -/** Unary addition. You can also write [+. e] instead of [~+. e]. - Unary operator at precedence level 9/11 for [+. e] - and 11/11 for [~+. e]. - @since 3.12.0 -*/ -external \"~+.": float => float = "%identity" - -/** Floating-point addition. - Left-associative operator at precedence level 6/11. */ -external \"+.": (float, float) => float = "%addfloat" - -/** Floating-point subtraction. - Left-associative operator at precedence level 6/11. */ -external \"-.": (float, float) => float = "%subfloat" - -/** Floating-point multiplication. - Left-associative operator at precedence level 7/11. */ -external \"*.": (float, float) => float = "%mulfloat" - -/** Floating-point division. - Left-associative operator at precedence level 7/11. */ -external \"/.": (float, float) => float = "%divfloat" - -@val @scope("Math") /** Exponentiation. */ -external \"**": (float, float) => float = "pow" - -@val @scope("Math") /** Square root. */ -external sqrt: float => float = "sqrt" - -@val @scope("Math") /** Exponential. */ -external exp: float => float = "exp" - -@val @scope("Math") /** Natural logarithm. */ -external log: float => float = "log" - -@val @scope("Math") /** Base 10 logarithm. */ -external log10: float => float = "log10" - -/** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results - even if [x] is close to [0.0]. - @since 3.12.0 -*/ -external expm1: float => float = "?expm1_float" - -@val -@scope("Math") -/** [log1p x] computes [log(1.0 +. x)] (natural logarithm), - giving numerically-accurate results even if [x] is close to [0.0]. - @since 3.12.0 -*/ -external log1p: float => float = "log1p" - -@val @scope("Math") /** Cosine. Argument is in radians. */ -external cos: float => float = "cos" - -@val @scope("Math") /** Sine. Argument is in radians. */ -external sin: float => float = "sin" - -@val @scope("Math") /** Tangent. Argument is in radians. */ -external tan: float => float = "tan" - -@val -@scope("Math") -/** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. - Result is in radians and is between [0.0] and [pi]. */ -external acos: float => float = "acos" - -@val -@scope("Math") -/** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. - Result is in radians and is between [-pi/2] and [pi/2]. */ -external asin: float => float = "asin" - -@val @scope("Math") /** Arc tangent. - Result is in radians and is between [-pi/2] and [pi/2]. */ -external atan: float => float = "atan" - -@val -@scope("Math") -/** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] - and [y] are used to determine the quadrant of the result. - Result is in radians and is between [-pi] and [pi]. */ -external atan2: (float, float) => float = "atan2" - -/** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length - of the hypotenuse of a right-angled triangle with sides of length - [x] and [y], or, equivalently, the distance of the point [(x,y)] - to origin. - @since 4.00.0 */ -external hypot: (float, float) => float = "?hypot_float" - -@val @scope("Math") /** Hyperbolic cosine. Argument is in radians. */ -external cosh: float => float = "cosh" - -@val @scope("Math") /** Hyperbolic sine. Argument is in radians. */ -external sinh: float => float = "sinh" - -@val @scope("Math") /** Hyperbolic tangent. Argument is in radians. */ -external tanh: float => float = "tanh" - -@val -@scope("Math") -/** Round above to an integer value. - [ceil f] returns the least integer value greater than or equal to [f]. - The result is returned as a float. */ -external ceil: float => float = "ceil" - -@val -@scope("Math") -/** Round below to an integer value. - [floor f] returns the greatest integer value less than or - equal to [f]. - The result is returned as a float. */ -external floor: float => float = "floor" - -@val @scope("Math") /** [abs_float f] returns the absolute value of [f]. */ -external abs_float: float => float = "abs" - -/** [copysign x y] returns a float whose absolute value is that of [x] - and whose sign is that of [y]. If [x] is [nan], returns [nan]. - If [y] is [nan], returns either [x] or [-. x], but it is not - specified which. - @since 4.00.0 */ -external copysign: (float, float) => float = "?copysign_float" - -/** [mod_float a b] returns the remainder of [a] with respect to - [b]. The returned value is [a -. n *. b], where [n] - is the quotient [a /. b] rounded towards zero to an integer. */ -external mod_float: (float, float) => float = "?fmod_float" - -/** [frexp f] returns the pair of the significant - and the exponent of [f]. When [f] is zero, the - significant [x] and the exponent [n] of [f] are equal to - zero. When [f] is non-zero, they are defined by - [f = x *. 2 ** n] and [0.5 <= x < 1.0]. */ -external frexp: float => (float, int) = "?frexp_float" - -/** [ldexp x n] returns [x *. 2 ** n]. */ -external ldexp: (float, int) => float = "?ldexp_float" - -/** [modf f] returns the pair of the fractional and integral - part of [f]. */ -external modf: float => (float, float) = "?modf_float" - -/** Same as {!Pervasives.float_of_int}. */ -external float: int => float = "%floatofint" - -/** Convert an integer to floating-point. */ -external float_of_int: int => float = "%floatofint" - -/** Same as {!Pervasives.int_of_float}. */ -external truncate: float => int = "%intoffloat" - -/** Truncate the given floating-point number to an integer. - The result is unspecified if the argument is [nan] or falls outside the - range of representable integers. */ -external int_of_float: float => int = "%intoffloat" - -/** Positive infinity. */ -let infinity: float - -/** Negative infinity. */ -let neg_infinity: float - -@val -@scope("Number") -/** A special floating-point value denoting the result of an - undefined operation such as [0.0 /. 0.0]. Stands for - 'not a number'. Any floating-point operation with [nan] as - argument returns [nan] as result. As for floating-point comparisons, - [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] - if one or both of their arguments is [nan]. */ -external nan: float = "NaN" -/* we could also use [0. /. 0.] */ - -/** The largest positive finite value of type [float]. */ -let max_float: float - -/** The smallest positive, non-zero, non-denormalized value of type [float]. */ -let min_float: float - -/** The difference between [1.0] and the smallest exactly representable - floating-point number greater than [1.0]. */ -let epsilon_float: float - -/** The five classes of floating-point numbers, as determined by - the {!Pervasives.classify_float} function. */ -type fpclass = - | /** Normal number, none of the below */ FP_normal - | /** Number very close to 0.0, has reduced precision */ FP_subnormal - | /** Number is 0.0 or -0.0 */ FP_zero - | /** Number is positive or negative infinity */ FP_infinite - | /** Not a number: result of an undefined operation */ FP_nan - -/** Return the class of the given floating-point number: - normal, subnormal, zero, infinite, or not a number. */ -let classify_float: float => fpclass - -/** {1 String operations} - - More string operations are provided in module {!String}. -*/ -/** String concatenation. - Right-associative operator at precedence level 5/11. */ -external \"^": (string, string) => string = "#string_append" - -/* {1 Character operations} - - More character operations are provided in module {!Char}. -*/ - -/** Return the ASCII code of the argument. */ -external int_of_char: char => int = "%identity" - -/** Return the character with the given ASCII code. - Raise [Invalid_argument "char_of_int"] if the argument is - outside the range 0--255. */ -let char_of_int: int => char - -/* {1 Unit operations} */ - -/** Discard the value of its argument and return [()]. - For instance, [ignore(f x)] discards the result of - the side-effecting function [f]. It is equivalent to - [f x; ()], except that the latter may generate a - compiler warning; writing [ignore(f x)] instead - avoids the warning. */ -external ignore: 'a => unit = "%ignore" - -/* {1 String conversion functions} */ - -/** Return the string representation of a boolean. As the returned values - may be shared, the user should not modify them directly. -*/ -let string_of_bool: bool => string - -/** Convert the given string to a boolean. - Raise [Invalid_argument "bool_of_string"] if the string is not - ["true"] or ["false"]. */ -let bool_of_string: string => bool - -/** Convert the given string to a boolean. - Return [None] if the string is not - ["true"] or ["false"]. - @since 4.05 -*/ -let bool_of_string_opt: string => option - -@val /** Return the string representation of an integer, in decimal. */ -external string_of_int: int => string = "String" - -/** Convert the given string to an integer. - The string is read in decimal (by default, or if the string - begins with [0u]), in hexadecimal (if it begins with [0x] or - [0X]), in octal (if it begins with [0o] or [0O]), or in binary - (if it begins with [0b] or [0B]). - - The [0u] prefix reads the input as an unsigned integer in the range - [[0, 2*max_int+1]]. If the input exceeds {!max_int} - it is converted to the signed integer - [min_int + input - max_int - 1]. - - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Raise [Failure "int_of_string"] if the given string is not - a valid representation of an integer, or if the integer represented - exceeds the range of integers representable in type [int]. */ -external int_of_string: string => int = "?int_of_string" - -/** Same as [int_of_string], but returns [None] instead of raising. - @since 4.05 -*/ -let int_of_string_opt: string => option - -@deprecated("Please use Js.Float.toString instead, string_of_float generates unparseable floats") -/** Return the string representation of a floating-point number. */ -let string_of_float: float => string - -/** Convert the given string to a float. The string is read in decimal - (by default) or in hexadecimal (marked by [0x] or [0X]). - The format of decimal floating-point numbers is - [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. - The format of hexadecimal floating-point numbers is - [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an - hexadecimal digit and [d] for a decimal digit. - In both cases, at least one of the integer and fractional parts must be - given; the exponent part is optional. - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Depending on the execution platforms, other representations of - floating-point numbers can be accepted, but should not be relied upon. - Raise [Failure "float_of_string"] if the given string is not a valid - representation of a float. */ -external float_of_string: string => float = "?float_of_string" - -/** Same as [float_of_string], but returns [None] instead of raising. - @since 4.05 -*/ -let float_of_string_opt: string => option - -/* {1 Pair operations} */ - -/** Return the first component of a pair. */ -external fst: (('a, 'b)) => 'a = "%field0" - -/** Return the second component of a pair. */ -external snd: (('a, 'b)) => 'b = "%field1" - -/* {1 List operations} - - More list operations are provided in module {!List}. -*/ - -@deprecated("Use Belt.List.concat instead") -/** List concatenation. Tail-recursive (length of the first argument). - Right-associative operator at precedence level 5/11. */ -let \"@": (list<'a>, list<'a>) => list<'a> - -type int32 = int - -/** Print a string on standard output. */ -let print_string: string => unit - -/** Print an integer, in decimal, on standard output. */ -let print_int: int => unit - -/** Print a floating-point number, in decimal, on standard output. */ -let print_float: float => unit - -/** Print a floating-point number, in decimal, on standard output. */ -@val -@scope("console") -/** Print a string, followed by a newline character, on - standard output and flush standard output. */ -external print_endline: string => unit = "log" - -/** Print a newline character on standard output, and flush - standard output. This can be used to simulate line - buffering of standard output. */ -let print_newline: unit => unit - -@val -@scope("console") -/** Print a string, followed by a newline character on standard - error and flush standard error. */ -external prerr_endline: string => unit = "error" - -/** Print a newline character on standard error, and flush - standard error. */ -let prerr_newline: unit => unit - -/* {1 References} */ - -/** The type of references (mutable indirection cells) containing - a value of type ['a]. */ -type ref<'a> = {mutable contents: 'a} - -/** Return a fresh reference containing the given value. */ -external ref: 'a => ref<'a> = "%makemutable" - -/** [!r] returns the current contents of reference [r]. - Equivalent to [fun r -> r.contents]. - Unary operator at precedence level 11/11.*/ -external \"!": ref<'a> => 'a = "%bs_ref_field0" - -/** [r := a] stores the value of [a] in reference [r]. - Equivalent to [fun r v -> r.contents <- v]. - Right-associative operator at precedence level 1/11. */ -external \":=": (ref<'a>, 'a) => unit = "%bs_ref_setfield0" - -/** Increment the integer contained in the given reference. - Equivalent to [fun r -> r := succ !r]. */ -external incr: ref => unit = "%incr" - -/** Decrement the integer contained in the given reference. - Equivalent to [fun r -> r := pred !r]. */ -external decr: ref => unit = "%decr" - -/* {1 Program termination} */ - -/** Terminate the process, returning the given status code - to the operating system: usually 0 to indicate no errors, - and a small positive integer to indicate failure. - All open output channels are flushed with [flush_all]. - An implicit [exit 0] is performed each time a program - terminates normally. An implicit [exit 2] is performed if the program - terminates early because of an uncaught exception. */ -let exit: int => 'a - -/** Register the given function to be called at program termination - time. The functions registered with [at_exit] will be called when - the program does any of the following: - - executes {!Pervasives.exit} - - terminates, either normally or because of an uncaught - exception - - executes the C function [caml_shutdown]. - The functions are called in 'last in, first out' order: the - function most recently added with [at_exit] is called first. */ -let at_exit: (unit => unit) => unit - -let valid_float_lexem: string => string diff --git a/jscomp/stdlib-406/pervasivesU.res b/jscomp/stdlib-406/pervasivesU.res deleted file mode 100644 index c044504..0000000 --- a/jscomp/stdlib-406/pervasivesU.res +++ /dev/null @@ -1,321 +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. */ -/* */ -/* ************************************************************************ */ - -@@uncurried - -module Jsx = JsxU -module JsxEvent = JsxEventU -module JsxDOM = JsxDOMU -module JsxPPXReactSupport = JsxPPXReactSupportU -module JsxModules = { - module Jsx = JsxU - module JsxEvent = JsxEventU - module JsxDOM = JsxDOMU -} - -/* Internal */ -external __unsafe_cast: 'a => 'b = "%identity" - -/* Exceptions */ - -external raise: exn => 'a = "%raise" -external raise_notrace: exn => 'a = "%raise_notrace" - -let failwith = s => raise(Failure(s)) -let invalid_arg = s => raise(Invalid_argument(s)) - -exception Exit - -/* Composition operators */ - -external \"|>": ('a, 'a => 'b) => 'b = "%revapply" -external \"@@": ('a => 'b, 'a) => 'b = "%apply" - -/* Debugging */ - -external __LOC__: string = "%loc_LOC" -external __FILE__: string = "%loc_FILE" -external __LINE__: int = "%loc_LINE" -external __MODULE__: string = "%loc_MODULE" -external __POS__: (string, int, int, int) = "%loc_POS" - -external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC" -external __LINE_OF__: 'a => (int, 'a) = "%loc_LINE" -external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" - -/* Comparisons */ - -external \"=": ('a, 'a) => bool = "%equal" -external \"<>": ('a, 'a) => bool = "%notequal" -external \"<": ('a, 'a) => bool = "%lessthan" -external \">": ('a, 'a) => bool = "%greaterthan" -external \"<=": ('a, 'a) => bool = "%lessequal" -external \">=": ('a, 'a) => bool = "%greaterequal" -external compare: ('a, 'a) => int = "%compare" -external min: ('a, 'a) => 'a = "%bs_min" -external max: ('a, 'a) => 'a = "%bs_max" -external \"==": ('a, 'a) => bool = "%eq" -external \"!=": ('a, 'a) => bool = "%noteq" - -/* Boolean operations */ - -external not: bool => bool = "%boolnot" - -external \"&&": (bool, bool) => bool = "%sequand" - -external \"||": (bool, bool) => bool = "%sequor" - -/* Integer operations */ - -external \"~-": int => int = "%negint" -external \"~+": int => int = "%identity" -external succ: int => int = "%succint" -external pred: int => int = "%predint" -external \"+": (int, int) => int = "%addint" -external \"-": (int, int) => int = "%subint" -external \"*": (int, int) => int = "%mulint" -external \"/": (int, int) => int = "%divint" -external mod: (int, int) => int = "%modint" - -let abs = x => - if x >= 0 { - x - } else { - -x - } - -external land: (int, int) => int = "%andint" -external lor: (int, int) => int = "%orint" -external lxor: (int, int) => int = "%xorint" - -let lnot = x => lxor(x, -1) - -external lsl: (int, int) => int = "%lslint" -external lsr: (int, int) => int = "%lsrint" -external asr: (int, int) => int = "%asrint" - -let max_int = lsr(-1, 1) -let min_int = max_int + 1 - -/* Floating-point operations */ - -external \"~-.": float => float = "%negfloat" -external \"~+.": float => float = "%identity" -external \"+.": (float, float) => float = "%addfloat" -external \"-.": (float, float) => float = "%subfloat" -external \"*.": (float, float) => float = "%mulfloat" -external \"/.": (float, float) => float = "%divfloat" - -@val @scope("Math") external \"**": (float, float) => float = "pow" -@val @scope("Math") external exp: float => float = "exp" -external expm1: float => float = "?expm1_float" - -@val @scope("Math") external acos: float => float = "acos" -@val @scope("Math") external asin: float => float = "asin" -@val @scope("Math") external atan: float => float = "atan" -@val @scope("Math") external atan2: (float, float) => float = "atan2" -external hypot: (float, float) => float = "?hypot_float" - -@val @scope("Math") external cos: float => float = "cos" -@val @scope("Math") external cosh: float => float = "cosh" -@val @scope("Math") external log: float => float = "log" -@val @scope("Math") external log10: float => float = "log10" -@val @scope("Math") external log1p: float => float = "log1p" -@val @scope("Math") external sin: float => float = "sin" -@val @scope("Math") external sinh: float => float = "sinh" -@val @scope("Math") external sqrt: float => float = "sqrt" -@val @scope("Math") external tan: float => float = "tan" -@val @scope("Math") external tanh: float => float = "tanh" -@val @scope("Math") external ceil: float => float = "ceil" -@val @scope("Math") external floor: float => float = "floor" -@val @scope("Math") external abs_float: float => float = "abs" -external copysign: (float, float) => float = "?copysign_float" -external mod_float: (float, float) => float = "?fmod_float" -external frexp: float => (float, int) = "?frexp_float" -external ldexp: (float, int) => float = "?ldexp_float" -external modf: float => (float, float) = "?modf_float" -external float: int => float = "%floatofint" -external float_of_int: int => float = "%floatofint" -external truncate: float => int = "%intoffloat" -external int_of_float: float => int = "%intoffloat" - -let infinity = 0x1p2047 -let neg_infinity = -0x1p2047 -@val @scope("Number") external nan: float = "NaN" -let max_float = 1.79769313486231571e+308 /* 0x1.ffff_ffff_ffff_fp+1023 */ -let min_float = 2.22507385850720138e-308 /* 0x1p-1022 */ -let epsilon_float = 2.22044604925031308e-16 /* 0x1p-52 */ - -type fpclass = - | FP_normal - | FP_subnormal - | FP_zero - | FP_infinite - | FP_nan - -let classify_float = (x: float): fpclass => - if (%raw(`isFinite`): _ => _)(x) { - if abs_float(x) >= /* 0x1p-1022 */ /* 2.22507385850720138e-308 */ min_float { - FP_normal - } else if x != 0. { - FP_subnormal - } else { - FP_zero - } - } else if (%raw(`isNaN`): _ => _)(x) { - FP_nan - } else { - FP_infinite - } - -/* String and byte sequence operations -- more in modules String and Bytes */ - -external string_length: string => int = "%string_length" - -external \"^": (string, string) => string = "#string_append" -/* Character operations -- more in module Char */ - -external int_of_char: char => int = "%identity" -external unsafe_char_of_int: int => char = "%identity" -let char_of_int = n => - if n < 0 || n > 255 { - invalid_arg("char_of_int") - } else { - unsafe_char_of_int(n) - } - -/* Unit operations */ - -external ignore: 'a => unit = "%ignore" - -/* Pair operations */ - -external fst: (('a, 'b)) => 'a = "%field0" -external snd: (('a, 'b)) => 'b = "%field1" - -/* References */ - -type ref<'a> = {mutable contents: 'a} -external ref: 'a => ref<'a> = "%makemutable" -external \"!": ref<'a> => 'a = "%bs_ref_field0" -external \":=": (ref<'a>, 'a) => unit = "%bs_ref_setfield0" -external incr: ref => unit = "%incr" -external decr: ref => unit = "%decr" - -/* String conversion functions */ -external format_float: (string, float) => string = "?format_float" - -let string_of_bool = b => - if b { - "true" - } else { - "false" - } -let bool_of_string = param => - switch param { - | "true" => true - | "false" => false - | _ => invalid_arg("bool_of_string") - } - -let bool_of_string_opt = param => - switch param { - | "true" => Some(true) - | "false" => Some(false) - | _ => None - } - -@val external string_of_int: int => string = "String" - -external int_of_string: string => int = "?int_of_string" - -let int_of_string_opt = s => - /* TODO: provide this directly as a non-raising primitive. */ - try Some(int_of_string(s)) catch { - | Failure(_) => None - } - -external string_get: (string, int) => char = "%string_safe_get" - -let valid_float_lexem = s => { - let l = string_length(s) - let rec loop = i => - if i >= l { - s ++ "." - } else { - switch string_get(s, i) { - | '0' .. '9' | '-' => loop(i + 1) - | _ => s - } - } - - loop(0) -} - -let string_of_float = f => valid_float_lexem(format_float("%.12g", f)) - -external float_of_string: string => float = "?float_of_string" - -let float_of_string_opt = s => - /* TODO: provide this directly as a non-raising primitive. */ - try Some(float_of_string(s)) catch { - | Failure(_) => None - } - -/* List operations -- more in module List */ - -let rec \"@" = (l1, l2) => - switch l1 { - | list{} => l2 - | list{hd, ...tl} => list{hd, ...\"@"(tl, l2)} - } - -/* Output functions on standard output */ - -@val @scope("console") external print_endline: string => unit = "log" -let print_newline = () => print_endline("") - -/* Output functions on standard error */ - -@val @scope("console") external prerr_endline: string => unit = "error" -let prerr_newline = () => prerr_endline("") - -let print_int = (i: int) => print_endline(string_of_int(i)) -let print_float = (i: float) => print_endline(string_of_float(i)) -let print_string = print_endline - -/* Miscellaneous */ - -external sys_exit: int => 'a = "?sys_exit" - -let exit_function = ref(ignore) - -let at_exit = f => { - let g = exit_function.contents - exit_function := - () => { - f() - g() - } -} - -let do_at_exit = () => exit_function.contents() - -let exit = retcode => { - do_at_exit() - sys_exit(retcode) -} - -type int32 = int diff --git a/jscomp/stdlib-406/pervasivesU.resi b/jscomp/stdlib-406/pervasivesU.resi deleted file mode 100644 index 4b0f059..0000000 --- a/jscomp/stdlib-406/pervasivesU.resi +++ /dev/null @@ -1,763 +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. */ -/* */ -/* ************************************************************************ */ - -/*** The initially opened module. - - This module provides the basic operations over the built-in types - (numbers, booleans, byte sequences, strings, exceptions, references, - lists, arrays, input-output channels, ...). - - This module is automatically opened at the beginning of each compilation. - All components of this module can therefore be referred by their short - name, without prefixing them by [Pervasives]. -*/ - -@@uncurried - -module Jsx = JsxU -module JsxEvent = JsxEventU -module JsxDOM = JsxDOMU -module JsxPPXReactSupport = JsxPPXReactSupportU - -/* For autocomplete */ -module JsxModules: { - module Jsx = JsxU - module JsxEvent = JsxEventU - module JsxDOM = JsxDOMU - // skip JsxPPXReactSupport as it's not user-facing -} - -/* Internal */ -external __unsafe_cast: 'a => 'b = "%identity" - -/*** {1 Exceptions} */ - -/** Raise the given exception value */ -external raise: exn => 'a = "%raise" - -/** A faster version [raise] which does not record the backtrace. - @since 4.02.0 -*/ -external raise_notrace: exn => 'a = "%raise_notrace" - -/** Raise exception [Invalid_argument] with the given string. */ -let invalid_arg: string => 'a - -/** Raise exception [Failure] with the given string. */ -let failwith: string => 'a - -/** The [Exit] exception is not raised by any library function. It is - provided for use in your programs. */ -exception Exit - -/*** {1 Comparisons} */ - -/** [e1 = e2] tests for structural equality of [e1] and [e2]. - Mutable structures (e.g. references and arrays) are equal - if and only if their current contents are structurally equal, - even if the two mutable objects are not the same physical object. - Equality between functional values raises [Invalid_argument]. - Equality between cyclic data structures may not terminate. - Left-associative operator at precedence level 4/11. */ -external \"=": ('a, 'a) => bool = "%equal" - -/** Negation of {!Pervasives.( = )}. - Left-associative operator at precedence level 4/11. */ -external \"<>": ('a, 'a) => bool = "%notequal" - -/** See {!Pervasives.( >= )}. - Left-associative operator at precedence level 4/11. */ -external \"<": ('a, 'a) => bool = "%lessthan" - -/** See {!Pervasives.( >= )}. - Left-associative operator at precedence level 4/11. */ -external \">": ('a, 'a) => bool = "%greaterthan" - -/** See {!Pervasives.( >= )}. - Left-associative operator at precedence level 4/11. */ -external \"<=": ('a, 'a) => bool = "%lessequal" - -/** Structural ordering functions. These functions coincide with - the usual orderings over integers, characters, strings, byte sequences - and floating-point numbers, and extend them to a - total ordering over all types. - The ordering is compatible with [( = )]. As in the case - of [( = )], mutable structures are compared by contents. - Comparison between functional values raises [Invalid_argument]. - Comparison between cyclic structures may not terminate. - Left-associative operator at precedence level 4/11. */ -external \">=": ('a, 'a) => bool = "%greaterequal" - -/** [compare x y] returns [0] if [x] is equal to [y], - a negative integer if [x] is less than [y], and a positive integer - if [x] is greater than [y]. The ordering implemented by [compare] - is compatible with the comparison predicates [=], [<] and [>] - defined above, with one difference on the treatment of the float value - {!Pervasives.nan}. Namely, the comparison predicates treat [nan] - as different from any other float value, including itself; - while [compare] treats [nan] as equal to itself and less than any - other float value. This treatment of [nan] ensures that [compare] - defines a total ordering relation. - - [compare] applied to functional values may raise [Invalid_argument]. - [compare] applied to cyclic structures may not terminate. - - The [compare] function can be used as the comparison function - required by the {!Set.Make} and {!Map.Make} functors, as well as - the {!List.sort} and {!Array.sort} functions. */ -external compare: ('a, 'a) => int = "%compare" - -/** Return the smaller of the two arguments. - The result is unspecified if one of the arguments contains - the float value [nan]. */ -external min: ('a, 'a) => 'a = "%bs_min" - -/** Return the greater of the two arguments. - The result is unspecified if one of the arguments contains - the float value [nan]. */ -external max: ('a, 'a) => 'a = "%bs_max" - -/** [e1 == e2] tests for physical equality of [e1] and [e2]. - On mutable types such as references, arrays, byte sequences, records with - mutable fields and objects with mutable instance variables, - [e1 == e2] is true if and only if physical modification of [e1] - also affects [e2]. - On non-mutable types, the behavior of [( == )] is - implementation-dependent; however, it is guaranteed that - [e1 == e2] implies [compare e1 e2 = 0]. - Left-associative operator at precedence level 4/11. */ -external \"==": ('a, 'a) => bool = "%eq" - -/** Negation of {!Pervasives.( == )}. - Left-associative operator at precedence level 4/11. */ -external \"!=": ('a, 'a) => bool = "%noteq" - -/*** {1 Boolean operations} */ - -/** The boolean negation. */ -external not: bool => bool = "%boolnot" - -/** The boolean 'and'. Evaluation is sequential, left-to-right: - in [e1 && e2], [e1] is evaluated first, and if it returns [false], - [e2] is not evaluated at all. - Right-associative operator at precedence level 3/11. */ -external \"&&": (bool, bool) => bool = "%sequand" - -/** The boolean 'or'. Evaluation is sequential, left-to-right: - in [e1 || e2], [e1] is evaluated first, and if it returns [true], - [e2] is not evaluated at all. - Right-associative operator at precedence level 2/11. -*/ -external \"||": (bool, bool) => bool = "%sequor" - -/*** {1 Debugging} */ - -/** [__LOC__] returns the location at which this expression appears in - the file currently being parsed by the compiler, with the standard - error format of OCaml: "File %S, line %d, characters %d-%d". - @since 4.02.0 -*/ -external __LOC__: string = "%loc_LOC" - -/** [__FILE__] returns the name of the file currently being - parsed by the compiler. - @since 4.02.0 -*/ -external __FILE__: string = "%loc_FILE" - -/** [__LINE__] returns the line number at which this expression - appears in the file currently being parsed by the compiler. - @since 4.02.0 -*/ -external __LINE__: int = "%loc_LINE" - -/** [__MODULE__] returns the module name of the file being - parsed by the compiler. - @since 4.02.0 -*/ -external __MODULE__: string = "%loc_MODULE" - -/** [__POS__] returns a tuple [(file,lnum,cnum,enum)], corresponding - to the location at which this expression appears in the file - currently being parsed by the compiler. [file] is the current - filename, [lnum] the line number, [cnum] the character position in - the line and [enum] the last character position in the line. - @since 4.02.0 - */ -external __POS__: (string, int, int, int) = "%loc_POS" - -/** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the - location of [expr] in the file currently being parsed by the - compiler, with the standard error format of OCaml: "File %S, line - %d, characters %d-%d". - @since 4.02.0 -*/ -external __LOC_OF__: 'a => (string, 'a) = "%loc_LOC" - -/** [__LINE__ expr] returns a pair [(line, expr)], where [line] is the - line number at which the expression [expr] appears in the file - currently being parsed by the compiler. - @since 4.02.0 - */ -external __LINE_OF__: 'a => (int, 'a) = "%loc_LINE" - -/** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a - tuple [(file,lnum,cnum,enum)] corresponding to the location at - which the expression [expr] appears in the file currently being - parsed by the compiler. [file] is the current filename, [lnum] the - line number, [cnum] the character position in the line and [enum] - the last character position in the line. - @since 4.02.0 - */ -external __POS_OF__: 'a => ((string, int, int, int), 'a) = "%loc_POS" - -/*** {1 Composition operators} */ - -/** Reverse-application operator: [x |> f |> g] is exactly equivalent - to [g (f (x))]. - Left-associative operator at precedence level 4/11. - @since 4.01 - */ -external \"|>": ('a, 'a => 'b) => 'b = "%revapply" - -/** Application operator: [g @@ f @@ x] is exactly equivalent to - [g (f (x))]. - Right-associative operator at precedence level 5/11. - @since 4.01 -*/ -external \"@@": ('a => 'b, 'a) => 'b = "%apply" - -/*** {1 Integer arithmetic} */ - -/*** Integers are 31 bits wide (or 63 bits on 64-bit processors). - All operations are taken modulo 2{^31} (or 2{^63}). - They do not fail on overflow. */ - -/** Unary negation. You can also write [- e] instead of [~- e]. - Unary operator at precedence level 9/11 for [- e] - and 11/11 for [~- e]. */ -external \"~-": int => int = "%negint" - -/** Unary addition. You can also write [+ e] instead of [~+ e]. - Unary operator at precedence level 9/11 for [+ e] - and 11/11 for [~+ e]. - @since 3.12.0 -*/ -external \"~+": int => int = "%identity" - -/** [succ x] is [x + 1]. */ -external succ: int => int = "%succint" - -/** [pred x] is [x - 1]. */ -external pred: int => int = "%predint" - -/** Integer addition. - Left-associative operator at precedence level 6/11. */ -external \"+": (int, int) => int = "%addint" - -/** Integer subtraction. - Left-associative operator at precedence level 6/11. */ -external \"-": (int, int) => int = "%subint" - -/** Integer multiplication. - Left-associative operator at precedence level 7/11. */ -external \"*": (int, int) => int = "%mulint" - -/** Integer division. - Raise [Division_by_zero] if the second argument is 0. - Integer division rounds the real quotient of its arguments towards zero. - More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer - less than or equal to the real quotient of [x] by [y]. Moreover, - [(- x) / y = x / (- y) = - (x / y)]. - Left-associative operator at precedence level 7/11. */ -external \"/": (int, int) => int = "%divint" - -/** Integer remainder. If [y] is not zero, the result - of [x mod y] satisfies the following properties: - [x = (x / y) * y + x mod y] and - [abs(x mod y) <= abs(y) - 1]. - If [y = 0], [x mod y] raises [Division_by_zero]. - Note that [x mod y] is negative only if [x < 0]. - Raise [Division_by_zero] if [y] is zero. - Left-associative operator at precedence level 7/11. */ -external mod: (int, int) => int = "%modint" - -/** Return the absolute value of the argument. Note that this may be - negative if the argument is [min_int]. */ -let abs: int => int - -/** The greatest representable integer. */ -let max_int: int - -/** The smallest representable integer. */ -let min_int: int - -/*** {2 Bitwise operations} */ - -/** Bitwise logical and. - Left-associative operator at precedence level 7/11. */ -external land: (int, int) => int = "%andint" - -/** Bitwise logical or. - Left-associative operator at precedence level 7/11. */ -external lor: (int, int) => int = "%orint" - -/** Bitwise logical exclusive or. - Left-associative operator at precedence level 7/11. */ -external lxor: (int, int) => int = "%xorint" - -/** Bitwise logical negation. */ -let lnot: int => int - -/** [n lsl m] shifts [n] to the left by [m] bits. - The result is unspecified if [m < 0] or [m >= bitsize], - where [bitsize] is [32] on a 32-bit platform and - [64] on a 64-bit platform. - Right-associative operator at precedence level 8/11. */ -external lsl: (int, int) => int = "%lslint" - -/** [n lsr m] shifts [n] to the right by [m] bits. - This is a logical shift: zeroes are inserted regardless of - the sign of [n]. - The result is unspecified if [m < 0] or [m >= bitsize]. - Right-associative operator at precedence level 8/11. */ -external lsr: (int, int) => int = "%lsrint" - -/** [n asr m] shifts [n] to the right by [m] bits. - This is an arithmetic shift: the sign bit of [n] is replicated. - The result is unspecified if [m < 0] or [m >= bitsize]. - Right-associative operator at precedence level 8/11. */ -external asr: (int, int) => int = "%asrint" - -/*** {1 Floating-point arithmetic} - - OCaml's floating-point numbers follow the - IEEE 754 standard, using double precision (64 bits) numbers. - Floating-point operations never raise an exception on overflow, - underflow, division by zero, etc. Instead, special IEEE numbers - are returned as appropriate, such as [infinity] for [1.0 /. 0.0], - [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') - for [0.0 /. 0.0]. These special numbers then propagate through - floating-point computations as expected: for instance, - [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] - as argument returns [nan] as result. -*/ - -/** Unary negation. You can also write [-. e] instead of [~-. e]. - Unary operator at precedence level 9/11 for [-. e] - and 11/11 for [~-. e]. */ -external \"~-.": float => float = "%negfloat" - -/** Unary addition. You can also write [+. e] instead of [~+. e]. - Unary operator at precedence level 9/11 for [+. e] - and 11/11 for [~+. e]. - @since 3.12.0 -*/ -external \"~+.": float => float = "%identity" - -/** Floating-point addition. - Left-associative operator at precedence level 6/11. */ -external \"+.": (float, float) => float = "%addfloat" - -/** Floating-point subtraction. - Left-associative operator at precedence level 6/11. */ -external \"-.": (float, float) => float = "%subfloat" - -/** Floating-point multiplication. - Left-associative operator at precedence level 7/11. */ -external \"*.": (float, float) => float = "%mulfloat" - -/** Floating-point division. - Left-associative operator at precedence level 7/11. */ -external \"/.": (float, float) => float = "%divfloat" - -@val @scope("Math") /** Exponentiation. */ -external \"**": (float, float) => float = "pow" - -@val @scope("Math") /** Square root. */ -external sqrt: float => float = "sqrt" - -@val @scope("Math") /** Exponential. */ -external exp: float => float = "exp" - -@val @scope("Math") /** Natural logarithm. */ -external log: float => float = "log" - -@val @scope("Math") /** Base 10 logarithm. */ -external log10: float => float = "log10" - -/** [expm1 x] computes [exp x -. 1.0], giving numerically-accurate results - even if [x] is close to [0.0]. - @since 3.12.0 -*/ -external expm1: float => float = "?expm1_float" - -@val -@scope("Math") -/** [log1p x] computes [log(1.0 +. x)] (natural logarithm), - giving numerically-accurate results even if [x] is close to [0.0]. - @since 3.12.0 -*/ -external log1p: float => float = "log1p" - -@val @scope("Math") /** Cosine. Argument is in radians. */ -external cos: float => float = "cos" - -@val @scope("Math") /** Sine. Argument is in radians. */ -external sin: float => float = "sin" - -@val @scope("Math") /** Tangent. Argument is in radians. */ -external tan: float => float = "tan" - -@val -@scope("Math") -/** Arc cosine. The argument must fall within the range [[-1.0, 1.0]]. - Result is in radians and is between [0.0] and [pi]. */ -external acos: float => float = "acos" - -@val -@scope("Math") -/** Arc sine. The argument must fall within the range [[-1.0, 1.0]]. - Result is in radians and is between [-pi/2] and [pi/2]. */ -external asin: float => float = "asin" - -@val @scope("Math") /** Arc tangent. - Result is in radians and is between [-pi/2] and [pi/2]. */ -external atan: float => float = "atan" - -@val -@scope("Math") -/** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] - and [y] are used to determine the quadrant of the result. - Result is in radians and is between [-pi] and [pi]. */ -external atan2: (float, float) => float = "atan2" - -/** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length - of the hypotenuse of a right-angled triangle with sides of length - [x] and [y], or, equivalently, the distance of the point [(x,y)] - to origin. - @since 4.00.0 */ -external hypot: (float, float) => float = "?hypot_float" - -@val @scope("Math") /** Hyperbolic cosine. Argument is in radians. */ -external cosh: float => float = "cosh" - -@val @scope("Math") /** Hyperbolic sine. Argument is in radians. */ -external sinh: float => float = "sinh" - -@val @scope("Math") /** Hyperbolic tangent. Argument is in radians. */ -external tanh: float => float = "tanh" - -@val -@scope("Math") -/** Round above to an integer value. - [ceil f] returns the least integer value greater than or equal to [f]. - The result is returned as a float. */ -external ceil: float => float = "ceil" - -@val -@scope("Math") -/** Round below to an integer value. - [floor f] returns the greatest integer value less than or - equal to [f]. - The result is returned as a float. */ -external floor: float => float = "floor" - -@val @scope("Math") /** [abs_float f] returns the absolute value of [f]. */ -external abs_float: float => float = "abs" - -/** [copysign x y] returns a float whose absolute value is that of [x] - and whose sign is that of [y]. If [x] is [nan], returns [nan]. - If [y] is [nan], returns either [x] or [-. x], but it is not - specified which. - @since 4.00.0 */ -external copysign: (float, float) => float = "?copysign_float" - -/** [mod_float a b] returns the remainder of [a] with respect to - [b]. The returned value is [a -. n *. b], where [n] - is the quotient [a /. b] rounded towards zero to an integer. */ -external mod_float: (float, float) => float = "?fmod_float" - -/** [frexp f] returns the pair of the significant - and the exponent of [f]. When [f] is zero, the - significant [x] and the exponent [n] of [f] are equal to - zero. When [f] is non-zero, they are defined by - [f = x *. 2 ** n] and [0.5 <= x < 1.0]. */ -external frexp: float => (float, int) = "?frexp_float" - -/** [ldexp x n] returns [x *. 2 ** n]. */ -external ldexp: (float, int) => float = "?ldexp_float" - -/** [modf f] returns the pair of the fractional and integral - part of [f]. */ -external modf: float => (float, float) = "?modf_float" - -/** Same as {!Pervasives.float_of_int}. */ -external float: int => float = "%floatofint" - -/** Convert an integer to floating-point. */ -external float_of_int: int => float = "%floatofint" - -/** Same as {!Pervasives.int_of_float}. */ -external truncate: float => int = "%intoffloat" - -/** Truncate the given floating-point number to an integer. - The result is unspecified if the argument is [nan] or falls outside the - range of representable integers. */ -external int_of_float: float => int = "%intoffloat" - -/** Positive infinity. */ -let infinity: float - -/** Negative infinity. */ -let neg_infinity: float - -@val -@scope("Number") -/** A special floating-point value denoting the result of an - undefined operation such as [0.0 /. 0.0]. Stands for - 'not a number'. Any floating-point operation with [nan] as - argument returns [nan] as result. As for floating-point comparisons, - [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] - if one or both of their arguments is [nan]. */ -external nan: float = "NaN" -/* we could also use [0. /. 0.] */ - -/** The largest positive finite value of type [float]. */ -let max_float: float - -/** The smallest positive, non-zero, non-denormalized value of type [float]. */ -let min_float: float - -/** The difference between [1.0] and the smallest exactly representable - floating-point number greater than [1.0]. */ -let epsilon_float: float - -/** The five classes of floating-point numbers, as determined by - the {!Pervasives.classify_float} function. */ -type fpclass = - | /** Normal number, none of the below */ FP_normal - | /** Number very close to 0.0, has reduced precision */ FP_subnormal - | /** Number is 0.0 or -0.0 */ FP_zero - | /** Number is positive or negative infinity */ FP_infinite - | /** Not a number: result of an undefined operation */ FP_nan - -/** Return the class of the given floating-point number: - normal, subnormal, zero, infinite, or not a number. */ -let classify_float: float => fpclass - -/** {1 String operations} - - More string operations are provided in module {!String}. -*/ -/** String concatenation. - Right-associative operator at precedence level 5/11. */ -external \"^": (string, string) => string = "#string_append" - -/*** {1 Character operations} - - More character operations are provided in module {!Char}. -*/ - -/** Return the ASCII code of the argument. */ -external int_of_char: char => int = "%identity" - -/** Return the character with the given ASCII code. - Raise [Invalid_argument "char_of_int"] if the argument is - outside the range 0--255. */ -let char_of_int: int => char - -/*** {1 Unit operations} */ - -/** Discard the value of its argument and return [()]. - For instance, [ignore(f x)] discards the result of - the side-effecting function [f]. It is equivalent to - [f x; ()], except that the latter may generate a - compiler warning; writing [ignore(f x)] instead - avoids the warning. */ -external ignore: 'a => unit = "%ignore" - -/*** {1 String conversion functions} */ - -/** Return the string representation of a boolean. As the returned values - may be shared, the user should not modify them directly. -*/ -let string_of_bool: bool => string - -/** Convert the given string to a boolean. - Raise [Invalid_argument "bool_of_string"] if the string is not - ["true"] or ["false"]. */ -let bool_of_string: string => bool - -/** Convert the given string to a boolean. - Return [None] if the string is not - ["true"] or ["false"]. - @since 4.05 -*/ -let bool_of_string_opt: string => option - -@val /** Return the string representation of an integer, in decimal. */ -external string_of_int: int => string = "String" - -/** Convert the given string to an integer. - The string is read in decimal (by default, or if the string - begins with [0u]), in hexadecimal (if it begins with [0x] or - [0X]), in octal (if it begins with [0o] or [0O]), or in binary - (if it begins with [0b] or [0B]). - - The [0u] prefix reads the input as an unsigned integer in the range - [[0, 2*max_int+1]]. If the input exceeds {!max_int} - it is converted to the signed integer - [min_int + input - max_int - 1]. - - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Raise [Failure "int_of_string"] if the given string is not - a valid representation of an integer, or if the integer represented - exceeds the range of integers representable in type [int]. */ -external int_of_string: string => int = "?int_of_string" - -/** Same as [int_of_string], but returns [None] instead of raising. - @since 4.05 -*/ -let int_of_string_opt: string => option - -@deprecated("Please use Js.Float.toString instead, string_of_float generates unparseable floats") -/** Return the string representation of a floating-point number. */ -let string_of_float: float => string - -/** Convert the given string to a float. The string is read in decimal - (by default) or in hexadecimal (marked by [0x] or [0X]). - The format of decimal floating-point numbers is - [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. - The format of hexadecimal floating-point numbers is - [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an - hexadecimal digit and [d] for a decimal digit. - In both cases, at least one of the integer and fractional parts must be - given; the exponent part is optional. - The [_] (underscore) character can appear anywhere in the string - and is ignored. - Depending on the execution platforms, other representations of - floating-point numbers can be accepted, but should not be relied upon. - Raise [Failure "float_of_string"] if the given string is not a valid - representation of a float. */ -external float_of_string: string => float = "?float_of_string" - -/** Same as [float_of_string], but returns [None] instead of raising. - @since 4.05 -*/ -let float_of_string_opt: string => option - -/*** {1 Pair operations} */ - -/** Return the first component of a pair. */ -external fst: (('a, 'b)) => 'a = "%field0" - -/** Return the second component of a pair. */ -external snd: (('a, 'b)) => 'b = "%field1" - -/*** {1 List operations} - - More list operations are provided in module {!List}. -*/ - -@deprecated("Use Belt.List.concat instead") -/** List concatenation. Tail-recursive (length of the first argument). - Right-associative operator at precedence level 5/11. */ -let \"@": (list<'a>, list<'a>) => list<'a> - -type int32 = int - -/** Print a string on standard output. */ -let print_string: string => unit - -/** Print an integer, in decimal, on standard output. */ -let print_int: int => unit - -/** Print a floating-point number, in decimal, on standard output. */ -let print_float: float => unit - -/** Print a floating-point number, in decimal, on standard output. */ -@val -@scope("console") -/** Print a string, followed by a newline character, on - standard output and flush standard output. */ -external print_endline: string => unit = "log" - -/** Print a newline character on standard output, and flush - standard output. This can be used to simulate line - buffering of standard output. */ -let print_newline: unit => unit - -@val -@scope("console") -/** Print a string, followed by a newline character on standard - error and flush standard error. */ -external prerr_endline: string => unit = "error" - -/** Print a newline character on standard error, and flush - standard error. */ -let prerr_newline: unit => unit - -/*** {1 References} */ - -/** The type of references (mutable indirection cells) containing - a value of type ['a]. */ -type ref<'a> = {mutable contents: 'a} - -/** Return a fresh reference containing the given value. */ -external ref: 'a => ref<'a> = "%makemutable" - -/** [!r] returns the current contents of reference [r]. - Equivalent to [fun r -> r.contents]. - Unary operator at precedence level 11/11.*/ -external \"!": ref<'a> => 'a = "%bs_ref_field0" - -/** [r := a] stores the value of [a] in reference [r]. - Equivalent to [fun r v -> r.contents <- v]. - Right-associative operator at precedence level 1/11. */ -external \":=": (ref<'a>, 'a) => unit = "%bs_ref_setfield0" - -/** Increment the integer contained in the given reference. - Equivalent to [fun r -> r := succ !r]. */ -external incr: ref => unit = "%incr" - -/** Decrement the integer contained in the given reference. - Equivalent to [fun r -> r := pred !r]. */ -external decr: ref => unit = "%decr" - -/*** {1 Program termination} */ - -/** Terminate the process, returning the given status code - to the operating system: usually 0 to indicate no errors, - and a small positive integer to indicate failure. - All open output channels are flushed with [flush_all]. - An implicit [exit 0] is performed each time a program - terminates normally. An implicit [exit 2] is performed if the program - terminates early because of an uncaught exception. */ -let exit: int => 'a - -/** Register the given function to be called at program termination - time. The functions registered with [at_exit] will be called when - the program does any of the following: - - executes {!Pervasives.exit} - - terminates, either normally or because of an uncaught - exception - - executes the C function [caml_shutdown]. - The functions are called in 'last in, first out' order: the - function most recently added with [at_exit] is called first. */ -let at_exit: (unit => unit) => unit - -let valid_float_lexem: string => string diff --git a/jscomp/stdlib-406/queue.res b/jscomp/stdlib-406/queue.res deleted file mode 100644 index 89d9297..0000000 --- a/jscomp/stdlib-406/queue.res +++ /dev/null @@ -1,142 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Francois Pottier, projet Cristal, INRIA Rocquencourt */ -/* Jeremie Dimino, Jane Street Europe */ -/* */ -/* Copyright 2002 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. */ -/* */ -/* ************************************************************************ */ - -exception Empty - -type rec cell<'a> = - | Nil - | Cons({content: 'a, mutable next: cell<'a>}) - -type t<'a> = { - mutable length: int, - mutable first: cell<'a>, - mutable last: cell<'a>, -} - -let create = () => { - length: 0, - first: Nil, - last: Nil, -} - -let clear = q => { - q.length = 0 - q.first = Nil - q.last = Nil -} - -let add = (x, q) => { - let cell = Cons({ - content: x, - next: Nil, - }) - switch q.last { - | Nil => - q.length = 1 - q.first = cell - q.last = cell - | Cons(last) => - q.length = q.length + 1 - last.next = cell - q.last = cell - } -} - -let push = add - -let peek = q => - switch q.first { - | Nil => raise(Empty) - | Cons({content}) => content - } - -let top = peek - -let take = q => - switch q.first { - | Nil => raise(Empty) - | Cons({content, next: Nil}) => - clear(q) - content - | Cons({content, next}) => - q.length = q.length - 1 - q.first = next - content - } - -let pop = take - -let copy = { - let rec copy = (q_res, prev, cell) => - switch cell { - | Nil => - q_res.last = prev - q_res - | Cons({content, next}) => - let res = Cons({content, next: Nil}) - switch prev { - | Nil => q_res.first = res - | Cons(p) => p.next = res - } - copy(q_res, res, next) - } - - q => copy({length: q.length, first: Nil, last: Nil}, Nil, q.first) -} - -let is_empty = q => q.length == 0 - -let length = q => q.length - -let iter = { - let rec iter = (f, cell) => - switch cell { - | Nil => () - | Cons({content, next}) => - f(content) - iter(f, next) - } - - (f, q) => iter(f, q.first) -} - -let fold = { - let rec fold = (f, accu, cell) => - switch cell { - | Nil => accu - | Cons({content, next}) => - let accu = f(accu, content) - fold(f, accu, next) - } - - (f, accu, q) => fold(f, accu, q.first) -} - -let transfer = (q1, q2) => - if q1.length > 0 { - switch q2.last { - | Nil => - q2.length = q1.length - q2.first = q1.first - q2.last = q1.last - clear(q1) - | Cons(last) => - q2.length = q2.length + q1.length - last.next = q1.first - q2.last = q1.last - clear(q1) - } - } diff --git a/jscomp/stdlib-406/queue.resi b/jscomp/stdlib-406/queue.resi deleted file mode 100644 index c5ed5ae..0000000 --- a/jscomp/stdlib-406/queue.resi +++ /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. */ -/* */ -/* ************************************************************************ */ - -/*** First-in first-out queues. - - This module implements queues (FIFOs), with in-place modification. - - {b Warning} This module is not thread-safe: each {!Queue.t} value - must be protected from concurrent access (e.g. with a [Mutex.t]). - Failure to do so can lead to a crash. -*/ - -/** The type of queues containing elements of type ['a]. */ -type t<'a> - -/** Raised when {!Queue.take} or {!Queue.peek} is applied to an empty queue. */ exception Empty - -/** Return a new queue, initially empty. */ -let create: unit => t<'a> - -/** [add x q] adds the element [x] at the end of the queue [q]. */ -let add: ('a, t<'a>) => unit - -/** [push] is a synonym for [add]. */ -let push: ('a, t<'a>) => unit - -/** [take q] removes and returns the first element in queue [q], - or raises {!Empty} if the queue is empty. */ -let take: t<'a> => 'a - -/** [pop] is a synonym for [take]. */ -let pop: t<'a> => 'a - -/** [peek q] returns the first element in queue [q], without removing - it from the queue, or raises {!Empty} if the queue is empty. */ -let peek: t<'a> => 'a - -/** [top] is a synonym for [peek]. */ -let top: t<'a> => 'a - -/** Discard all elements from a queue. */ -let clear: t<'a> => unit - -/** Return a copy of the given queue. */ -let copy: t<'a> => t<'a> - -/** Return [true] if the given queue is empty, [false] otherwise. */ -let is_empty: t<'a> => bool - -/** Return the number of elements in a queue. */ -let length: t<'a> => int - -/** [iter f q] applies [f] in turn to all elements of [q], - from the least recently entered to the most recently entered. - The queue itself is unchanged. */ -let iter: ('a => unit, t<'a>) => unit - -/** [fold f accu q] is equivalent to [List.fold_left f accu l], - where [l] is the list of [q]'s elements. The queue remains - unchanged. */ -let fold: (('b, 'a) => 'b, 'b, t<'a>) => 'b - -/** [transfer q1 q2] adds all of [q1]'s elements at the end of - the queue [q2], then clears [q1]. It is equivalent to the - sequence [iter (fun x -> add x q2) q1; clear q1], but runs - in constant time. */ -let transfer: (t<'a>, t<'a>) => unit diff --git a/jscomp/stdlib-406/random.res b/jscomp/stdlib-406/random.res deleted file mode 100644 index 11b4e42..0000000 --- a/jscomp/stdlib-406/random.res +++ /dev/null @@ -1,336 +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. */ -/* */ -/* ************************************************************************ */ - -/* Pseudo-random number generator - This is a lagged-Fibonacci F(55, 24, +) with a modified addition - function to enhance the mixing of bits. - If we use normal addition, the low-order bit fails tests 1 and 7 - of the Diehard test suite, and bits 1 and 2 also fail test 7. - If we use multiplication as suggested by Marsaglia, it doesn't fare - much better. - By mixing the bits of one of the numbers before addition (XOR the - 5 high-order bits into the low-order bits), we get a generator that - passes all the Diehard tests. -*/ - -let random_seed: unit => array = _ => { - let seed: int = %raw("Math.floor(Math.random()*0x7fffffff)") - [seed] -} - -module State = { - type t = {st: array, mutable idx: int} - - let new_state = () => {st: Array.make(55, 0), idx: 0} - let assign = (st1, st2) => { - Array.blit(st2.st, 0, st1.st, 0, 55) - st1.idx = st2.idx - } - - let full_init = (s, seed) => { - let combine = (accu, x) => Digest.string(accu ++ string_of_int(x)) - let extract = d => - Char.code(String.get(d, 0)) + - lsl(Char.code(String.get(d, 1)), 8) + - lsl(Char.code(String.get(d, 2)), 16) + - lsl(Char.code(String.get(d, 3)), 24) - - let seed = if Array.length(seed) == 0 { - [0] - } else { - seed - } - let l = Array.length(seed) - for i in 0 to 54 { - s.st[i] = i - } - let accu = ref("x") - for i in 0 to 54 + max(55, l) { - let j = mod(i, 55) - let k = mod(i, l) - accu := combine(accu.contents, seed[k]) - s.st[j] = land(lxor(s.st[j], extract(accu.contents)), 0x3FFFFFFF) /* PR#5575 */ - } - s.idx = 0 - } - - let make = seed => { - let result = new_state() - full_init(result, seed) - result - } - - let make_self_init = () => make(random_seed()) - - let copy = s => { - let result = new_state() - assign(result, s) - result - } - - /* Returns 30 random bits as an integer 0 <= x < 1073741824 */ - let bits = s => { - s.idx = mod(s.idx + 1, 55) - let curval = s.st[s.idx] - let newval = s.st[mod(s.idx + 24, 55)] + lxor(curval, land(lsr(curval, 25), 0x1F)) - let newval30 = land(newval, 0x3FFFFFFF) /* PR#5575 */ - s.st[s.idx] = newval30 - newval30 - } - - let rec intaux = (s, n) => { - let r = bits(s) - let v = mod(r, n) - if r - v > 0x3FFFFFFF - n + 1 { - intaux(s, n) - } else { - v - } - } - - let int = (s, bound) => - if bound > 0x3FFFFFFF || bound <= 0 { - invalid_arg("Random.int") - } else { - intaux(s, bound) - } - - let rec int32aux = (s, n) => { - let b1 = Int32.of_int(bits(s)) - let b2 = Int32.shift_left(Int32.of_int(land(bits(s), 1)), 30) - let r = Int32.logor(b1, b2) - let v = Int32.rem(r, n) - if Int32.sub(r, v) > Int32.add(Int32.sub(Int32.max_int, n), 1l) { - int32aux(s, n) - } else { - v - } - } - - let int32 = (s, bound) => - if bound <= 0l { - invalid_arg("Random.int32") - } else { - int32aux(s, bound) - } - - let rec int64aux = (s, n) => { - let b1 = Int64.of_int(bits(s)) - let b2 = Int64.shift_left(Int64.of_int(bits(s)), 30) - let b3 = Int64.shift_left(Int64.of_int(land(bits(s), 7)), 60) - let r = Int64.logor(b1, Int64.logor(b2, b3)) - let v = Int64.rem(r, n) - if Int64.sub(r, v) > Int64.add(Int64.sub(Int64.max_int, n), 1L) { - int64aux(s, n) - } else { - v - } - } - - let int64 = (s, bound) => - if bound <= 0L { - invalid_arg("Random.int64") - } else { - int64aux(s, bound) - } - - /* Returns a float 0 <= x <= 1 with at most 60 bits of precision. */ - let rawfloat = s => { - let scale = 1073741824.0 /* 2^30 */ - and r1 = Pervasives.float(bits(s)) - and r2 = Pervasives.float(bits(s)) - (r1 /. scale +. r2) /. scale - } - - let float = (s, bound) => rawfloat(s) *. bound - - let bool = s => land(bits(s), 1) == 0 -} - -/* This is the state you get with [init 27182818] and then applying - the "land 0x3FFFFFFF" filter to them. See #5575, #5793, #5977. */ -let default = { - State.st: [ - 0x3ae2522b, - 0x1d8d4634, - 0x15b4fad0, - 0x18b14ace, - 0x12f8a3c4, - 0x3b086c47, - 0x16d467d6, - 0x101d91c7, - 0x321df177, - 0x0176c193, - 0x1ff72bf1, - 0x1e889109, - 0x0b464b18, - 0x2b86b97c, - 0x0891da48, - 0x03137463, - 0x085ac5a1, - 0x15d61f2f, - 0x3bced359, - 0x29c1c132, - 0x3a86766e, - 0x366d8c86, - 0x1f5b6222, - 0x3ce1b59f, - 0x2ebf78e1, - 0x27cd1b86, - 0x258f3dc3, - 0x389a8194, - 0x02e4c44c, - 0x18c43f7d, - 0x0f6e534f, - 0x1e7df359, - 0x055d0b7e, - 0x10e84e7e, - 0x126198e4, - 0x0e7722cb, - 0x1cbede28, - 0x3391b964, - 0x3d40e92a, - 0x0c59933d, - 0x0b8cd0b7, - 0x24efff1c, - 0x2803fdaa, - 0x08ebc72e, - 0x0f522e32, - 0x05398edc, - 0x2144a04c, - 0x0aef3cbd, - 0x01ad4719, - 0x35b93cd6, - 0x2a559d4f, - 0x1e6fd768, - 0x26e27f36, - 0x186f18c3, - 0x2fbf967a, - ], - State.idx: 0, -} - -let bits = () => State.bits(default) -let int = bound => State.int(default, bound) -let int32 = bound => State.int32(default, bound) - -let int64 = bound => State.int64(default, bound) -let float = scale => State.float(default, scale) -let bool = () => State.bool(default) - -let full_init = seed => State.full_init(default, seed) -let init = seed => State.full_init(default, [seed]) -let self_init = () => full_init(random_seed()) - -/* Manipulating the current state. */ - -let get_state = () => State.copy(default) -let set_state = s => State.assign(default, s) - -/* ******************* - -(* Test functions. Not included in the library. - The [chisquare] function should be called with n > 10r. - It returns a triple (low, actual, high). - If low <= actual <= high, the [g] function passed the test, - otherwise it failed. - - Some results: - -init 27182818; chisquare int 100000 1000 -init 27182818; chisquare int 100000 100 -init 27182818; chisquare int 100000 5000 -init 27182818; chisquare int 1000000 1000 -init 27182818; chisquare int 100000 1024 -init 299792643; chisquare int 100000 1024 -init 14142136; chisquare int 100000 1024 -init 27182818; init_diff 1024; chisquare diff 100000 1024 -init 27182818; init_diff 100; chisquare diff 100000 100 -init 27182818; init_diff2 1024; chisquare diff2 100000 1024 -init 27182818; init_diff2 100; chisquare diff2 100000 100 -init 14142136; init_diff2 100; chisquare diff2 100000 100 -init 299792643; init_diff2 100; chisquare diff2 100000 100 -- : float * float * float = (936.754446796632465, 997.5, 1063.24555320336754) -# - : float * float * float = (80., 89.7400000000052387, 120.) -# - : float * float * float = (4858.57864376269, 5045.5, 5141.42135623731) -# - : float * float * float = -(936.754446796632465, 944.805999999982305, 1063.24555320336754) -# - : float * float * float = (960., 1019.19744000000355, 1088.) -# - : float * float * float = (960., 1059.31776000000536, 1088.) -# - : float * float * float = (960., 1039.98463999999512, 1088.) -# - : float * float * float = (960., 1054.38207999999577, 1088.) -# - : float * float * float = (80., 90.096000000005, 120.) -# - : float * float * float = (960., 1076.78720000000612, 1088.) -# - : float * float * float = (80., 85.1760000000067521, 120.) -# - : float * float * float = (80., 85.2160000000003492, 120.) -# - : float * float * float = (80., 80.6220000000030268, 120.) - -*) - -(* Return the sum of the squares of v[i0,i1[ *) -let rec sumsq v i0 i1 = - if i0 >= i1 then 0.0 - else if i1 = i0 + 1 then Pervasives.float v.(i0) *. Pervasives.float v.(i0) - else sumsq v i0 ((i0+i1)/2) +. sumsq v ((i0+i1)/2) i1 - - -let chisquare g n r = - if n <= 10 * r then invalid_arg "chisquare"; - let f = Array.make r 0 in - for i = 1 to n do - let t = g r in - f.(t) <- f.(t) + 1 - done; - let t = sumsq f 0 r - and r = Pervasives.float r - and n = Pervasives.float n in - let sr = 2.0 *. sqrt r in - (r -. sr, (r *. t /. n) -. n, r +. sr) - - -(* This is to test for linear dependencies between successive random numbers. -*) -let st = ref 0 -let init_diff r = st := int r -let diff r = - let x1 = !st - and x2 = int r - in - st := x2; - if x1 >= x2 then - x1 - x2 - else - r + x1 - x2 - - -let st1 = ref 0 -and st2 = ref 0 - - -(* This is to test for quadratic dependencies between successive random - numbers. -*) -let init_diff2 r = st1 := int r; st2 := int r -let diff2 r = - let x1 = !st1 - and x2 = !st2 - and x3 = int r - in - st1 := x2; - st2 := x3; - (x3 - x2 - x2 + x1 + 2*r) mod r - - -********************/ diff --git a/jscomp/stdlib-406/random.resi b/jscomp/stdlib-406/random.resi deleted file mode 100644 index 05624c9..0000000 --- a/jscomp/stdlib-406/random.resi +++ /dev/null @@ -1,100 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Pseudo-random number generators (PRNG). */ - -/* {1 Basic functions} */ - -/** Initialize the generator, using the argument as a seed. - The same seed will always yield the same sequence of numbers. */ -let init: int => unit - -/** Same as {!Random.init} but takes more data as seed. */ -let full_init: array => unit - -/** Initialize the generator with a random seed chosen - in a system-dependent way. If [/dev/urandom] is available on - the host machine, it is used to provide a highly random initial - seed. Otherwise, a less random seed is computed from system - parameters (current time, process IDs). */ -let self_init: unit => unit - -/** Return 30 random bits in a nonnegative integer. - @before 3.12.0 used a different algorithm (affects all the following - functions) -*/ -let bits: unit => int - -/** [Random.int bound] returns a random integer between 0 (inclusive) - and [bound] (exclusive). [bound] must be greater than 0 and less - than 2{^30}. */ -let int: int => int - -/** [Random.int32 bound] returns a random integer between 0 (inclusive) - and [bound] (exclusive). [bound] must be greater than 0. */ -let int32: Int32.t => Int32.t - -/** [Random.int64 bound] returns a random integer between 0 (inclusive) - and [bound] (exclusive). [bound] must be greater than 0. */ -let int64: Int64.t => Int64.t - -/** [Random.float bound] returns a random floating-point number - between 0 and [bound] (inclusive). If [bound] is - negative, the result is negative or zero. If [bound] is 0, - the result is 0. */ -let float: float => float - -/** [Random.bool ()] returns [true] or [false] with probability 0.5 each. */ -let bool: unit => bool - -/* {1 Advanced functions} */ - -module State: { - /*** The functions from module {!State} manipulate the current state - of the random generator explicitly. - This allows using one or several deterministic PRNGs, - even in a multi-threaded program, without interference from - other parts of the program. - */ - - /** The type of PRNG states. */ - type t - - /** Create a new state and initialize it with the given seed. */ - let make: array => t - - /** Create a new state and initialize it with a system-dependent - low-entropy seed. */ - let make_self_init: unit => t - - /** Return a copy of the given state. */ - let copy: t => t - - let bits: t => int - let int: (t, int) => int - let int32: (t, Int32.t) => Int32.t - let int64: (t, Int64.t) => Int64.t - let float: (t, float) => float - /** These functions are the same as the basic functions, except that they - use (and update) the given PRNG state instead of the default one. - */ - let bool: t => bool -} - -/** Return the current state of the generator used by the basic functions. */ -let get_state: unit => State.t - -/** Set the state of the generator used by the basic functions. */ -let set_state: State.t => unit diff --git a/jscomp/stdlib-406/release.ninja b/jscomp/stdlib-406/release.ninja deleted file mode 100644 index 992f90f..0000000 --- a/jscomp/stdlib-406/release.ninja +++ /dev/null @@ -1,92 +0,0 @@ - -bsc_flags = -no-keep-locs -no-alias-deps -bs-no-version-header -bs-no-check-div-by-zero -nostdlib -bs-cross-module-opt -make-runtime -w -9-3-106 -warn-error A -I others - -rule cc - command = $bsc -bs-cmi -bs-cmj $bsc_flags -I stdlib-406 $in - description = $in -> $out -rule cc_cmi - command = $bsc -bs-read-cmi -bs-cmi -bs-cmj $bsc_flags -I stdlib-406 $in - description = $in -> $out - -o stdlib-406/pervasives.cmj : cc_cmi stdlib-406/pervasives.res | stdlib-406/pervasives.cmi $bsc others - bsc_flags = $bsc_flags -nopervasives -o stdlib-406/pervasives.cmi : cc stdlib-406/pervasives.resi | $bsc others - bsc_flags = $bsc_flags -nopervasives -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.res | stdlib-406/array.cmi $bsc others -o stdlib-406/array.cmi : cc stdlib-406/array.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/arrayLabels.cmj : cc_cmi stdlib-406/arrayLabels.res | stdlib-406/arrayLabels.cmi $bsc others -o stdlib-406/arrayLabels.cmi : cc stdlib-406/arrayLabels.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/buffer.cmj : cc_cmi stdlib-406/buffer.res | stdlib-406/buffer.cmi stdlib-406/bytes.cmj stdlib-406/char.cmj stdlib-406/string.cmj stdlib-406/uchar.cmj $bsc others -o stdlib-406/buffer.cmi : cc stdlib-406/buffer.resi | stdlib-406/pervasives.cmj stdlib-406/uchar.cmi $bsc others -o stdlib-406/bytes.cmj : cc_cmi stdlib-406/bytes.res | stdlib-406/bytes.cmi stdlib-406/char.cmj $bsc others -o stdlib-406/bytes.cmi : cc stdlib-406/bytes.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/bytesLabels.cmj : cc_cmi stdlib-406/bytesLabels.res | stdlib-406/bytesLabels.cmi stdlib-406/char.cmj $bsc others -o stdlib-406/bytesLabels.cmi : cc stdlib-406/bytesLabels.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/callback.cmj : cc_cmi stdlib-406/callback.res | stdlib-406/callback.cmi $bsc others -o stdlib-406/callback.cmi : cc stdlib-406/callback.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/camlinternalLazy.cmj : cc_cmi stdlib-406/camlinternalLazy.res | stdlib-406/camlinternalLazy.cmi $bsc others -o stdlib-406/camlinternalLazy.cmi : cc stdlib-406/camlinternalLazy.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/camlinternalMod.cmj : cc_cmi stdlib-406/camlinternalMod.res | stdlib-406/camlinternalMod.cmi stdlib-406/obj.cmj $bsc others -o stdlib-406/camlinternalMod.cmi : cc stdlib-406/camlinternalMod.resi | stdlib-406/obj.cmi stdlib-406/pervasives.cmj $bsc others -o stdlib-406/char.cmj : cc_cmi stdlib-406/char.res | stdlib-406/char.cmi $bsc others -o stdlib-406/char.cmi : cc stdlib-406/char.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/complex.cmj : cc_cmi stdlib-406/complex.res | stdlib-406/complex.cmi $bsc others -o stdlib-406/complex.cmi : cc stdlib-406/complex.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/digest.cmj : cc_cmi stdlib-406/digest.res | stdlib-406/bytes.cmj stdlib-406/char.cmj stdlib-406/digest.cmi stdlib-406/string.cmj $bsc others -o stdlib-406/digest.cmi : cc stdlib-406/digest.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/filename.cmj : cc_cmi stdlib-406/filename.res | stdlib-406/buffer.cmj stdlib-406/filename.cmi stdlib-406/string.cmj stdlib-406/sys.cmj $bsc others -o stdlib-406/filename.cmi : cc stdlib-406/filename.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/genlex.cmj : cc_cmi stdlib-406/genlex.res | stdlib-406/bytes.cmj stdlib-406/char.cmj stdlib-406/genlex.cmi stdlib-406/hashtbl.cmj stdlib-406/list.cmj stdlib-406/stream.cmj stdlib-406/string.cmj $bsc others -o stdlib-406/genlex.cmi : cc stdlib-406/genlex.resi | stdlib-406/pervasives.cmj stdlib-406/stream.cmi $bsc others -o stdlib-406/hashtbl.cmj : cc_cmi stdlib-406/hashtbl.res | stdlib-406/array.cmj stdlib-406/hashtbl.cmi stdlib-406/lazy.cmj stdlib-406/random.cmj $bsc others -o stdlib-406/hashtbl.cmi : cc stdlib-406/hashtbl.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/hashtblLabels.cmi stdlib-406/hashtblLabels.cmj : cc stdlib-406/hashtblLabels.res | stdlib-406/hashtbl.cmj stdlib-406/pervasives.cmj $bsc others -o stdlib-406/int32.cmj : cc_cmi stdlib-406/int32.res | stdlib-406/int32.cmi $bsc others -o stdlib-406/int32.cmi : cc stdlib-406/int32.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/int64.cmj : cc_cmi stdlib-406/int64.res | stdlib-406/int64.cmi $bsc others -o stdlib-406/int64.cmi : cc stdlib-406/int64.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/lazy.cmj : cc_cmi stdlib-406/lazy.res | stdlib-406/camlinternalLazy.cmj stdlib-406/lazy.cmi $bsc others -o stdlib-406/lazy.cmi : cc stdlib-406/lazy.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/lexing.cmj : cc_cmi stdlib-406/lexing.res | stdlib-406/array.cmj stdlib-406/bytes.cmj stdlib-406/lexing.cmi stdlib-406/string.cmj $bsc others -o stdlib-406/lexing.cmi : cc stdlib-406/lexing.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/list.cmj : cc_cmi stdlib-406/list.res | stdlib-406/list.cmi $bsc others -o stdlib-406/list.cmi : cc stdlib-406/list.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/listLabels.cmj : cc_cmi stdlib-406/listLabels.res | stdlib-406/listLabels.cmi $bsc others -o stdlib-406/listLabels.cmi : cc stdlib-406/listLabels.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/map.cmj : cc_cmi stdlib-406/map.res | stdlib-406/map.cmi $bsc others -o stdlib-406/map.cmi : cc stdlib-406/map.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/mapLabels.cmi stdlib-406/mapLabels.cmj : cc stdlib-406/mapLabels.res | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/moreLabels.cmj : cc_cmi stdlib-406/moreLabels.res | stdlib-406/hashtblLabels.cmj stdlib-406/mapLabels.cmj stdlib-406/moreLabels.cmi stdlib-406/setLabels.cmj $bsc others -o stdlib-406/moreLabels.cmi : cc stdlib-406/moreLabels.resi | stdlib-406/hashtbl.cmi stdlib-406/map.cmi stdlib-406/pervasives.cmj stdlib-406/set.cmi $bsc others -o stdlib-406/obj.cmj : cc_cmi stdlib-406/obj.res | stdlib-406/obj.cmi $bsc others -o stdlib-406/obj.cmi : cc stdlib-406/obj.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/parsing.cmj : cc_cmi stdlib-406/parsing.res | 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.resi | stdlib-406/lexing.cmi stdlib-406/obj.cmi stdlib-406/pervasives.cmj $bsc others -o stdlib-406/pervasivesU.cmj : cc_cmi stdlib-406/pervasivesU.res | stdlib-406/pervasivesU.cmi $bsc others -o stdlib-406/pervasivesU.cmi : cc stdlib-406/pervasivesU.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/queue.cmj : cc_cmi stdlib-406/queue.res | stdlib-406/queue.cmi $bsc others -o stdlib-406/queue.cmi : cc stdlib-406/queue.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/random.cmj : cc_cmi stdlib-406/random.res | stdlib-406/array.cmj stdlib-406/char.cmj stdlib-406/digest.cmj stdlib-406/int32.cmj stdlib-406/int64.cmj stdlib-406/random.cmi stdlib-406/string.cmj $bsc others -o stdlib-406/random.cmi : cc stdlib-406/random.resi | stdlib-406/int32.cmi stdlib-406/int64.cmi stdlib-406/pervasives.cmj $bsc others -o stdlib-406/set.cmj : cc_cmi stdlib-406/set.res | stdlib-406/list.cmj stdlib-406/set.cmi $bsc others -o stdlib-406/set.cmi : cc stdlib-406/set.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/setLabels.cmi stdlib-406/setLabels.cmj : cc stdlib-406/setLabels.res | stdlib-406/list.cmj stdlib-406/pervasives.cmj $bsc others -o stdlib-406/sort.cmj : cc_cmi stdlib-406/sort.res | stdlib-406/array.cmj stdlib-406/sort.cmi $bsc others -o stdlib-406/sort.cmi : cc stdlib-406/sort.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/stack.cmj : cc_cmi stdlib-406/stack.res | stdlib-406/list.cmj stdlib-406/stack.cmi $bsc others -o stdlib-406/stack.cmi : cc stdlib-406/stack.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/stdLabels.cmj : cc_cmi stdlib-406/stdLabels.res | stdlib-406/arrayLabels.cmj stdlib-406/bytesLabels.cmj stdlib-406/listLabels.cmj stdlib-406/stdLabels.cmi stdlib-406/stringLabels.cmj $bsc others -o stdlib-406/stdLabels.cmi : cc stdlib-406/stdLabels.resi | stdlib-406/arrayLabels.cmi stdlib-406/bytesLabels.cmi stdlib-406/listLabels.cmi stdlib-406/pervasives.cmj stdlib-406/stringLabels.cmi $bsc others -o stdlib-406/stream.cmj : cc_cmi stdlib-406/stream.res | stdlib-406/bytes.cmj stdlib-406/lazy.cmj stdlib-406/list.cmj stdlib-406/stream.cmi stdlib-406/string.cmj $bsc others -o stdlib-406/stream.cmi : cc stdlib-406/stream.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/string.cmj : cc_cmi stdlib-406/string.res | stdlib-406/array.cmj stdlib-406/bytes.cmj stdlib-406/string.cmi $bsc others -o stdlib-406/string.cmi : cc stdlib-406/string.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/stringLabels.cmj : cc_cmi stdlib-406/stringLabels.res | stdlib-406/array.cmj stdlib-406/bytes.cmj stdlib-406/stringLabels.cmi $bsc others -o stdlib-406/stringLabels.cmi : cc stdlib-406/stringLabels.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/sys.cmj : cc_cmi stdlib-406/sys.res | stdlib-406/sys.cmi $bsc others -o stdlib-406/sys.cmi : cc stdlib-406/sys.resi | stdlib-406/pervasives.cmj $bsc others -o stdlib-406/uchar.cmj : cc_cmi stdlib-406/uchar.res | stdlib-406/char.cmj stdlib-406/uchar.cmi $bsc others -o stdlib-406/uchar.cmi : cc stdlib-406/uchar.resi | 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/pervasivesU.cmi stdlib-406/pervasivesU.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/stdlib-406/set.res b/jscomp/stdlib-406/set.res deleted file mode 100644 index 49d30ed..0000000 --- a/jscomp/stdlib-406/set.res +++ /dev/null @@ -1,711 +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. */ -/* */ -/* ************************************************************************ */ - -/* Sets over ordered types */ - -module type OrderedType = { - type t - let compare: (t, t) => int -} - -module type S = { - type elt - type t - let empty: t - let is_empty: t => bool - let mem: (elt, t) => bool - let add: (elt, t) => t - let singleton: elt => t - let remove: (elt, t) => t - let union: (t, t) => t - let inter: (t, t) => t - let diff: (t, t) => t - let compare: (t, t) => int - let equal: (t, t) => bool - let subset: (t, t) => bool - let iter: (elt => unit, t) => unit - let map: (elt => elt, t) => t - let fold: ((elt, 'a) => 'a, t, 'a) => 'a - let for_all: (elt => bool, t) => bool - let exists: (elt => bool, t) => bool - let filter: (elt => bool, t) => t - let partition: (elt => bool, t) => (t, t) - let cardinal: t => int - let elements: t => list - let min_elt: t => elt - let min_elt_opt: t => option - let max_elt: t => elt - let max_elt_opt: t => option - let choose: t => elt - let choose_opt: t => option - let split: (elt, t) => (t, bool, t) - let find: (elt, t) => elt - let find_opt: (elt, t) => option - let find_first: (elt => bool, t) => elt - let find_first_opt: (elt => bool, t) => option - let find_last: (elt => bool, t) => elt - let find_last_opt: (elt => bool, t) => option - let of_list: list => t -} - -module Make = (Ord: OrderedType) => { - type elt = Ord.t - type rec t = Empty | Node({l: t, v: elt, r: t, h: int}) - - /* Sets are represented by balanced binary trees (the heights of the - children differ by at most 2 */ - - let height = param => - switch param { - | Empty => 0 - | Node({h}) => h - } - - /* Creates a new node with left son l, value v and right son r. - We must have all elements of l < v < all elements of r. - l and r must be balanced and | height l - height r | <= 2. - Inline expansion of height for better speed. */ - - let create = (l, v, r) => { - let hl = switch l { - | Empty => 0 - | Node({h}) => h - } - let hr = switch r { - | Empty => 0 - | Node({h}) => h - } - Node({ - l, - v, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - - /* Same as create, but performs one step of rebalancing if necessary. - Assumes l and r balanced and | height l - height r | <= 3. - Inline expansion of create for better speed in the most frequent case - where no rebalancing is required. */ - - let bal = (l, v, r) => { - let hl = switch l { - | Empty => 0 - | Node({h}) => h - } - let hr = switch r { - | Empty => 0 - | Node({h}) => h - } - if hl > hr + 2 { - switch l { - | Empty => invalid_arg("Set.bal") - | Node({l: ll, v: lv, r: lr}) => - if height(ll) >= height(lr) { - create(ll, lv, create(lr, v, r)) - } else { - switch lr { - | Empty => invalid_arg("Set.bal") - | Node({l: lrl, v: lrv, r: lrr}) => create(create(ll, lv, lrl), lrv, create(lrr, v, r)) - } - } - } - } else if hr > hl + 2 { - switch r { - | Empty => invalid_arg("Set.bal") - | Node({l: rl, v: rv, r: rr}) => - if height(rr) >= height(rl) { - create(create(l, v, rl), rv, rr) - } else { - switch rl { - | Empty => invalid_arg("Set.bal") - | Node({l: rll, v: rlv, r: rlr}) => create(create(l, v, rll), rlv, create(rlr, rv, rr)) - } - } - } - } else { - Node({ - l, - v, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - } - - /* Insertion of one element */ - - let rec add = (x, param) => - switch param { - | Empty => Node({l: Empty, v: x, r: Empty, h: 1}) - | Node({l, v, r}) as t => - let c = Ord.compare(x, v) - if c == 0 { - t - } else if c < 0 { - let ll = add(x, l) - if l === ll { - t - } else { - bal(ll, v, r) - } - } else { - let rr = add(x, r) - if r === rr { - t - } else { - bal(l, v, rr) - } - } - } - - let singleton = x => Node({l: Empty, v: x, r: Empty, h: 1}) - - /* Beware: those two functions assume that the added v is *strictly* - smaller (or bigger) than all the present elements in the tree; it - does not test for equality with the current min (or max) element. - Indeed, they are only used during the "join" operation which - respects this precondition. - */ - - let rec add_min_element = (x, param) => - switch param { - | Empty => singleton(x) - | Node({l, v, r}) => bal(add_min_element(x, l), v, r) - } - - let rec add_max_element = (x, param) => - switch param { - | Empty => singleton(x) - | Node({l, v, r}) => bal(l, v, add_max_element(x, r)) - } - - /* Same as create and bal, but no assumptions are made on the - relative heights of l and r. */ - - let rec join = (l, v, r) => - switch (l, r) { - | (Empty, _) => add_min_element(v, r) - | (_, Empty) => add_max_element(v, l) - | (Node({l: ll, v: lv, r: lr, h: lh}), Node({l: rl, v: rv, r: rr, h: rh})) => - if lh > rh + 2 { - bal(ll, lv, join(lr, v, r)) - } else if rh > lh + 2 { - bal(join(l, v, rl), rv, rr) - } else { - create(l, v, r) - } - } - - /* Smallest and greatest element of a set */ - - let rec min_elt = param => - switch param { - | Empty => raise(Not_found) - | Node({l: Empty, v}) => v - | Node({l}) => min_elt(l) - } - - let rec min_elt_opt = param => - switch param { - | Empty => None - | Node({l: Empty, v}) => Some(v) - | Node({l}) => min_elt_opt(l) - } - - let rec max_elt = param => - switch param { - | Empty => raise(Not_found) - | Node({v, r: Empty}) => v - | Node({r}) => max_elt(r) - } - - let rec max_elt_opt = param => - switch param { - | Empty => None - | Node({v, r: Empty}) => Some(v) - | Node({r}) => max_elt_opt(r) - } - - /* Remove the smallest element of the given set */ - - let rec remove_min_elt = param => - switch param { - | Empty => invalid_arg("Set.remove_min_elt") - | Node({l: Empty, r}) => r - | Node({l, v, r}) => bal(remove_min_elt(l), v, r) - } - - /* Merge two trees l and r into one. - All elements of l must precede the elements of r. - Assume | height l - height r | <= 2. */ - - let merge = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => bal(t1, min_elt(t2), remove_min_elt(t2)) - } - - /* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. */ - - let concat = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => join(t1, min_elt(t2), remove_min_elt(t2)) - } - - /* Splitting. split x s returns a triple (l, present, r) where - - l is the set of elements of s that are < x - - r is the set of elements of s that are > x - - present is false if s contains no element equal to x, - or true if s contains an element equal to x. */ - - let rec split = (x, param) => - switch param { - | Empty => (Empty, false, Empty) - | Node({l, v, r}) => - let c = Ord.compare(x, v) - if c == 0 { - (l, true, r) - } else if c < 0 { - let (ll, pres, rl) = split(x, l) - (ll, pres, join(rl, v, r)) - } else { - let (lr, pres, rr) = split(x, r) - (join(l, v, lr), pres, rr) - } - } - - /* Implementation of the set operations */ - - let empty = Empty - - let is_empty = param => - switch param { - | Empty => true - | _ => false - } - - let rec mem = (x, param) => - switch param { - | Empty => false - | Node({l, v, r}) => - let c = Ord.compare(x, v) - c == 0 || - mem( - x, - if c < 0 { - l - } else { - r - }, - ) - } - - let rec remove = (x, param) => - switch param { - | Empty => Empty - | Node({l, v, r}) as t => - let c = Ord.compare(x, v) - if c == 0 { - merge(l, r) - } else if c < 0 { - let ll = remove(x, l) - if l === ll { - t - } else { - bal(ll, v, r) - } - } else { - let rr = remove(x, r) - if r === rr { - t - } else { - bal(l, v, rr) - } - } - } - - let rec union = (s1, s2) => - switch (s1, s2) { - | (Empty, t2) => t2 - | (t1, Empty) => t1 - | (Node({l: l1, v: v1, r: r1, h: h1}), Node({l: l2, v: v2, r: r2, h: h2})) => - if h1 >= h2 { - if h2 == 1 { - add(v2, s1) - } else { - let (l2, _, r2) = split(v1, s2) - join(union(l1, l2), v1, union(r1, r2)) - } - } else if h1 == 1 { - add(v1, s2) - } else { - let (l1, _, r1) = split(v2, s1) - join(union(l1, l2), v2, union(r1, r2)) - } - } - - let rec inter = (s1, s2) => - switch (s1, s2) { - | (Empty, _) => Empty - | (_, Empty) => Empty - | (Node({l: l1, v: v1, r: r1}), t2) => - switch split(v1, t2) { - | (l2, false, r2) => concat(inter(l1, l2), inter(r1, r2)) - | (l2, true, r2) => join(inter(l1, l2), v1, inter(r1, r2)) - } - } - - let rec diff = (s1, s2) => - switch (s1, s2) { - | (Empty, _) => Empty - | (t1, Empty) => t1 - | (Node({l: l1, v: v1, r: r1}), t2) => - switch split(v1, t2) { - | (l2, false, r2) => join(diff(l1, l2), v1, diff(r1, r2)) - | (l2, true, r2) => concat(diff(l1, l2), diff(r1, r2)) - } - } - - type rec enumeration = End | More(elt, t, enumeration) - - let rec cons_enum = (s, e) => - switch s { - | Empty => e - | Node({l, v, r}) => cons_enum(l, More(v, r, e)) - } - - let rec compare_aux = (e1, e2) => - switch (e1, e2) { - | (End, End) => 0 - | (End, _) => -1 - | (_, End) => 1 - | (More(v1, r1, e1), More(v2, r2, e2)) => - let c = Ord.compare(v1, v2) - if c != 0 { - c - } else { - compare_aux(cons_enum(r1, e1), cons_enum(r2, e2)) - } - } - - let compare = (s1, s2) => compare_aux(cons_enum(s1, End), cons_enum(s2, End)) - - let equal = (s1, s2) => compare(s1, s2) == 0 - - let rec subset = (s1, s2) => - switch (s1, s2) { - | (Empty, _) => true - | (_, Empty) => false - | (Node({l: l1, v: v1, r: r1}), Node({l: l2, v: v2, r: r2}) as t2) => - let c = Ord.compare(v1, v2) - if c == 0 { - subset(l1, l2) && subset(r1, r2) - } else if c < 0 { - subset(Node({l: l1, v: v1, r: Empty, h: 0}), l2) && subset(r1, t2) - } else { - subset(Node({l: Empty, v: v1, r: r1, h: 0}), r2) && subset(l1, t2) - } - } - - let rec iter = (f, param) => - switch param { - | Empty => () - | Node({l, v, r}) => - iter(f, l) - f(v) - iter(f, r) - } - - let rec fold = (f, s, accu) => - switch s { - | Empty => accu - | Node({l, v, r}) => fold(f, r, f(v, fold(f, l, accu))) - } - - let rec for_all = (p, param) => - switch param { - | Empty => true - | Node({l, v, r}) => p(v) && (for_all(p, l) && for_all(p, r)) - } - - let rec exists = (p, param) => - switch param { - | Empty => false - | Node({l, v, r}) => p(v) || (exists(p, l) || exists(p, r)) - } - - let rec filter = (p, param) => - switch param { - | Empty => Empty - | Node({l, v, r}) as t => - /* call [p] in the expected left-to-right order */ - let l' = filter(p, l) - let pv = p(v) - let r' = filter(p, r) - if pv { - if l === l' && r === r' { - t - } else { - join(l', v, r') - } - } else { - concat(l', r') - } - } - - let rec partition = (p, param) => - switch param { - | Empty => (Empty, Empty) - | Node({l, v, r}) => - /* call [p] in the expected left-to-right order */ - let (lt, lf) = partition(p, l) - let pv = p(v) - let (rt, rf) = partition(p, r) - if pv { - (join(lt, v, rt), concat(lf, rf)) - } else { - (concat(lt, rt), join(lf, v, rf)) - } - } - - let rec cardinal = param => - switch param { - | Empty => 0 - | Node({l, r}) => cardinal(l) + 1 + cardinal(r) - } - - let rec elements_aux = (accu, param) => - switch param { - | Empty => accu - | Node({l, v, r}) => elements_aux(list{v, ...elements_aux(accu, r)}, l) - } - - let elements = s => elements_aux(list{}, s) - - let choose = min_elt - - let choose_opt = min_elt_opt - - let rec find = (x, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, r}) => - let c = Ord.compare(x, v) - if c == 0 { - v - } else { - find( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let rec find_first_aux = (v0, f, param) => - switch param { - | Empty => v0 - | Node({l, v, r}) => - if f(v) { - find_first_aux(v, f, l) - } else { - find_first_aux(v0, f, r) - } - } - - let rec find_first = (f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, r}) => - if f(v) { - find_first_aux(v, f, l) - } else { - find_first(f, r) - } - } - - let rec find_first_opt_aux = (v0, f, param) => - switch param { - | Empty => Some(v0) - | Node({l, v, r}) => - if f(v) { - find_first_opt_aux(v, f, l) - } else { - find_first_opt_aux(v0, f, r) - } - } - - let rec find_first_opt = (f, param) => - switch param { - | Empty => None - | Node({l, v, r}) => - if f(v) { - find_first_opt_aux(v, f, l) - } else { - find_first_opt(f, r) - } - } - - let rec find_last_aux = (v0, f, param) => - switch param { - | Empty => v0 - | Node({l, v, r}) => - if f(v) { - find_last_aux(v, f, r) - } else { - find_last_aux(v0, f, l) - } - } - - let rec find_last = (f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, r}) => - if f(v) { - find_last_aux(v, f, r) - } else { - find_last(f, l) - } - } - - let rec find_last_opt_aux = (v0, f, param) => - switch param { - | Empty => Some(v0) - | Node({l, v, r}) => - if f(v) { - find_last_opt_aux(v, f, r) - } else { - find_last_opt_aux(v0, f, l) - } - } - - let rec find_last_opt = (f, param) => - switch param { - | Empty => None - | Node({l, v, r}) => - if f(v) { - find_last_opt_aux(v, f, r) - } else { - find_last_opt(f, l) - } - } - - let rec find_opt = (x, param) => - switch param { - | Empty => None - | Node({l, v, r}) => - let c = Ord.compare(x, v) - if c == 0 { - Some(v) - } else { - find_opt( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let try_join = (l, v, r) => - /* [join l v r] can only be called when (elements of l < v < - elements of r); use [try_join l v r] when this property may - not hold, but you hope it does hold in the common case */ - if ( - (l == Empty || Ord.compare(max_elt(l), v) < 0) && - (r == Empty || Ord.compare(v, min_elt(r)) < 0) - ) { - join(l, v, r) - } else { - union(l, add(v, r)) - } - - let rec map = (f, param) => - switch param { - | Empty => Empty - | Node({l, v, r}) as t => - /* enforce left-to-right evaluation order */ - let l' = map(f, l) - let v' = f(v) - let r' = map(f, r) - if l === l' && (v === v' && r === r') { - t - } else { - try_join(l', v', r') - } - } - - let of_sorted_list = l => { - let rec sub = (n, l) => - switch (n, l) { - | (0, l) => (Empty, l) - | (1, list{x0, ...l}) => (Node({l: Empty, v: x0, r: Empty, h: 1}), l) - | (2, list{x0, x1, ...l}) => ( - Node({l: Node({l: Empty, v: x0, r: Empty, h: 1}), v: x1, r: Empty, h: 2}), - l, - ) - | (3, list{x0, x1, x2, ...l}) => ( - Node({ - l: Node({l: Empty, v: x0, r: Empty, h: 1}), - v: x1, - r: Node({l: Empty, v: x2, r: Empty, h: 1}), - h: 2, - }), - l, - ) - | (n, l) => - let nl = n / 2 - let (left, l) = sub(nl, l) - switch l { - | list{} => assert(false) - | list{mid, ...l} => - let (right, l) = sub(n - nl - 1, l) - (create(left, mid, right), l) - } - } - - fst(sub(List.length(l), l)) - } - - let of_list = l => - switch l { - | list{} => empty - | list{x0} => singleton(x0) - | list{x0, x1} => add(x1, singleton(x0)) - | list{x0, x1, x2} => add(x2, add(x1, singleton(x0))) - | list{x0, x1, x2, x3} => add(x3, add(x2, add(x1, singleton(x0)))) - | list{x0, x1, x2, x3, x4} => add(x4, add(x3, add(x2, add(x1, singleton(x0))))) - | _ => of_sorted_list(List.sort_uniq(Ord.compare, l)) - } -} diff --git a/jscomp/stdlib-406/set.resi b/jscomp/stdlib-406/set.resi deleted file mode 100644 index 7d68f7b..0000000 --- a/jscomp/stdlib-406/set.resi +++ /dev/null @@ -1,264 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Sets over ordered types. - - This module implements the set data structure, given a total ordering - function over the set elements. All operations over sets - are purely applicative (no side-effects). - The implementation uses balanced binary trees, and is therefore - reasonably efficient: insertion and membership take time - logarithmic in the size of the set, for instance. - - The {!Make} functor constructs implementations for any type, given a - [compare] function. - For instance: - {[ - module IntPairs = - struct - type t = int * int - let compare (x0,y0) (x1,y1) = - match Pervasives.compare x0 x1 with - 0 -> Pervasives.compare y0 y1 - | c -> c - end - - module PairsSet = Set.Make(IntPairs) - - let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13)) - ]} - - This creates a new module [PairsSet], with a new type [PairsSet.t] - of sets of [int * int]. -*/ - -/** Input signature of the functor {!Set.Make}. */ -module type OrderedType = { - /** The type of the set elements. */ - type t - - /** A total ordering function over the set elements. - This is a two-argument function [f] such that - [f e1 e2] is zero if the elements [e1] and [e2] are equal, - [f e1 e2] is strictly negative if [e1] is smaller than [e2], - and [f e1 e2] is strictly positive if [e1] is greater than [e2]. - Example: a suitable ordering function is the generic structural - comparison function {!Pervasives.compare}. */ - let compare: (t, t) => int -} - -/** Output signature of the functor {!Set.Make}. */ -module type S = { - /** The type of the set elements. */ - type elt - - /** The type of sets. */ - type t - - /** The empty set. */ - let empty: t - - /** Test whether a set is empty or not. */ - let is_empty: t => bool - - /** [mem x s] tests whether [x] belongs to the set [s]. */ - let mem: (elt, t) => bool - - /** [add x s] returns a set containing all elements of [s], - plus [x]. If [x] was already in [s], [s] is returned unchanged - (the result of the function is then physically equal to [s]). - @before 4.03 Physical equality was not ensured. */ - let add: (elt, t) => t - - /** [singleton x] returns the one-element set containing only [x]. */ - let singleton: elt => t - - /** [remove x s] returns a set containing all elements of [s], - except [x]. If [x] was not in [s], [s] is returned unchanged - (the result of the function is then physically equal to [s]). - @before 4.03 Physical equality was not ensured. */ - let remove: (elt, t) => t - - /** Set union. */ - let union: (t, t) => t - - /** Set intersection. */ - let inter: (t, t) => t - - /** Set difference. */ - let diff: (t, t) => t - - /** Total ordering between sets. Can be used as the ordering function - for doing sets of sets. */ - let compare: (t, t) => int - - /** [equal s1 s2] tests whether the sets [s1] and [s2] are - equal, that is, contain equal elements. */ - let equal: (t, t) => bool - - /** [subset s1 s2] tests whether the set [s1] is a subset of - the set [s2]. */ - let subset: (t, t) => bool - - /** [iter f s] applies [f] in turn to all elements of [s]. - The elements of [s] are presented to [f] in increasing order - with respect to the ordering over the type of the elements. */ - let iter: (elt => unit, t) => unit - - /** [map f s] is the set whose elements are [f a0],[f a1]... [f - aN], where [a0],[a1]...[aN] are the elements of [s]. - - The elements are passed to [f] in increasing order - with respect to the ordering over the type of the elements. - - If no element of [s] is changed by [f], [s] is returned - unchanged. (If each output of [f] is physically equal to its - input, the returned set is physically equal to [s].) - @since 4.04.0 */ - let map: (elt => elt, t) => t - - /** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], - where [x1 ... xN] are the elements of [s], in increasing order. */ - let fold: ((elt, 'a) => 'a, t, 'a) => 'a - - /** [for_all p s] checks if all elements of the set - satisfy the predicate [p]. */ - let for_all: (elt => bool, t) => bool - - /** [exists p s] checks if at least one element of - the set satisfies the predicate [p]. */ - let exists: (elt => bool, t) => bool - - /** [filter p s] returns the set of all elements in [s] - that satisfy predicate [p]. If [p] satisfies every element in [s], - [s] is returned unchanged (the result of the function is then - physically equal to [s]). - @before 4.03 Physical equality was not ensured.*/ - let filter: (elt => bool, t) => t - - /** [partition p s] returns a pair of sets [(s1, s2)], where - [s1] is the set of all the elements of [s] that satisfy the - predicate [p], and [s2] is the set of all the elements of - [s] that do not satisfy [p]. */ - let partition: (elt => bool, t) => (t, t) - - /** Return the number of elements of a set. */ - let cardinal: t => int - - /** Return the list of all elements of the given set. - The returned list is sorted in increasing order with respect - to the ordering [Ord.compare], where [Ord] is the argument - given to {!Set.Make}. */ - let elements: t => list - - /** Return the smallest element of the given set - (with respect to the [Ord.compare] ordering), or raise - [Not_found] if the set is empty. */ - let min_elt: t => elt - - /** Return the smallest element of the given set - (with respect to the [Ord.compare] ordering), or [None] - if the set is empty. - @since 4.05 - */ - let min_elt_opt: t => option - - /** Same as {!Set.S.min_elt}, but returns the largest element of the - given set. */ - let max_elt: t => elt - - /** Same as {!Set.S.min_elt_opt}, but returns the largest element of the - given set. - @since 4.05 - */ - let max_elt_opt: t => option - - /** Return one element of the given set, or raise [Not_found] if - the set is empty. Which element is chosen is unspecified, - but equal elements will be chosen for equal sets. */ - let choose: t => elt - - /** Return one element of the given set, or [None] if - the set is empty. Which element is chosen is unspecified, - but equal elements will be chosen for equal sets. - @since 4.05 - */ - let choose_opt: t => option - - /** [split x s] returns a triple [(l, present, r)], where - [l] is the set of elements of [s] that are - strictly less than [x]; - [r] is the set of elements of [s] that are - strictly greater than [x]; - [present] is [false] if [s] contains no element equal to [x], - or [true] if [s] contains an element equal to [x]. */ - let split: (elt, t) => (t, bool, t) - - /** [find x s] returns the element of [s] equal to [x] (according - to [Ord.compare]), or raise [Not_found] if no such element - exists. - @since 4.01.0 */ - let find: (elt, t) => elt - - /** [find_opt x s] returns the element of [s] equal to [x] (according - to [Ord.compare]), or [None] if no such element - exists. - @since 4.05 */ - let find_opt: (elt, t) => option - - /** [find_first f s], where [f] is a monotonically increasing function, - returns the lowest element [e] of [s] such that [f e], - or raises [Not_found] if no such element exists. - - For example, [find_first (fun e -> Ord.compare e x >= 0) s] will return - the first element [e] of [s] where [Ord.compare e x >= 0] (intuitively: - [e >= x]), or raise [Not_found] if [x] is greater than any element of - [s]. - - @since 4.05 - */ - let find_first: (elt => bool, t) => elt - - /** [find_first_opt f s], where [f] is a monotonically increasing function, - returns an option containing the lowest element [e] of [s] such that - [f e], or [None] if no such element exists. - @since 4.05 - */ - let find_first_opt: (elt => bool, t) => option - - /** [find_last f s], where [f] is a monotonically decreasing function, - returns the highest element [e] of [s] such that [f e], - or raises [Not_found] if no such element exists. - @since 4.05 - */ - let find_last: (elt => bool, t) => elt - - /** [find_last_opt f s], where [f] is a monotonically decreasing function, - returns an option containing the highest element [e] of [s] such that - [f e], or [None] if no such element exists. - @since 4.05 - */ - let find_last_opt: (elt => bool, t) => option - - /** [of_list l] creates a set from a list of elements. - This is usually more efficient than folding [add] over the list, - except perhaps for lists with many duplicated elements. - @since 4.02.0 */ - let of_list: list => t -} - -/** Functor building an implementation of the set structure - given a totally ordered type. */ -module Make: (Ord: OrderedType) => (S with type elt = Ord.t) diff --git a/jscomp/stdlib-406/setLabels.res b/jscomp/stdlib-406/setLabels.res deleted file mode 100644 index 4e0ed5e..0000000 --- a/jscomp/stdlib-406/setLabels.res +++ /dev/null @@ -1,711 +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. */ -/* */ -/* ************************************************************************ */ - -/* Sets over ordered types */ - -module type OrderedType = { - type t - let compare: (t, t) => int -} - -module type S = { - type elt - type t - let empty: t - let is_empty: t => bool - let mem: (elt, t) => bool - let add: (elt, t) => t - let singleton: elt => t - let remove: (elt, t) => t - let union: (t, t) => t - let inter: (t, t) => t - let diff: (t, t) => t - let compare: (t, t) => int - let equal: (t, t) => bool - let subset: (t, t) => bool - let iter: (~f: elt => unit, t) => unit - let map: (~f: elt => elt, t) => t - let fold: (~f: (elt, 'a) => 'a, t, ~init: 'a) => 'a - let for_all: (~f: elt => bool, t) => bool - let exists: (~f: elt => bool, t) => bool - let filter: (~f: elt => bool, t) => t - let partition: (~f: elt => bool, t) => (t, t) - let cardinal: t => int - let elements: t => list - let min_elt: t => elt - let min_elt_opt: t => option - let max_elt: t => elt - let max_elt_opt: t => option - let choose: t => elt - let choose_opt: t => option - let split: (elt, t) => (t, bool, t) - let find: (elt, t) => elt - let find_opt: (elt, t) => option - let find_first: (~f: elt => bool, t) => elt - let find_first_opt: (~f: elt => bool, t) => option - let find_last: (~f: elt => bool, t) => elt - let find_last_opt: (~f: elt => bool, t) => option - let of_list: list => t -} - -module Make = (Ord: OrderedType) => { - type elt = Ord.t - type rec t = Empty | Node({l: t, v: elt, r: t, h: int}) - - /* Sets are represented by balanced binary trees (the heights of the - children differ by at most 2 */ - - let height = param => - switch param { - | Empty => 0 - | Node({h}) => h - } - - /* Creates a new node with left son l, value v and right son r. - We must have all elements of l < v < all elements of r. - l and r must be balanced and | height l - height r | <= 2. - Inline expansion of height for better speed. */ - - let create = (l, v, r) => { - let hl = switch l { - | Empty => 0 - | Node({h}) => h - } - let hr = switch r { - | Empty => 0 - | Node({h}) => h - } - Node({ - l, - v, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - - /* Same as create, but performs one step of rebalancing if necessary. - Assumes l and r balanced and | height l - height r | <= 3. - Inline expansion of create for better speed in the most frequent case - where no rebalancing is required. */ - - let bal = (l, v, r) => { - let hl = switch l { - | Empty => 0 - | Node({h}) => h - } - let hr = switch r { - | Empty => 0 - | Node({h}) => h - } - if hl > hr + 2 { - switch l { - | Empty => invalid_arg("Set.bal") - | Node({l: ll, v: lv, r: lr}) => - if height(ll) >= height(lr) { - create(ll, lv, create(lr, v, r)) - } else { - switch lr { - | Empty => invalid_arg("Set.bal") - | Node({l: lrl, v: lrv, r: lrr}) => create(create(ll, lv, lrl), lrv, create(lrr, v, r)) - } - } - } - } else if hr > hl + 2 { - switch r { - | Empty => invalid_arg("Set.bal") - | Node({l: rl, v: rv, r: rr}) => - if height(rr) >= height(rl) { - create(create(l, v, rl), rv, rr) - } else { - switch rl { - | Empty => invalid_arg("Set.bal") - | Node({l: rll, v: rlv, r: rlr}) => create(create(l, v, rll), rlv, create(rlr, rv, rr)) - } - } - } - } else { - Node({ - l, - v, - r, - h: if hl >= hr { - hl + 1 - } else { - hr + 1 - }, - }) - } - } - - /* Insertion of one element */ - - let rec add = (x, param) => - switch param { - | Empty => Node({l: Empty, v: x, r: Empty, h: 1}) - | Node({l, v, r}) as t => - let c = Ord.compare(x, v) - if c == 0 { - t - } else if c < 0 { - let ll = add(x, l) - if l === ll { - t - } else { - bal(ll, v, r) - } - } else { - let rr = add(x, r) - if r === rr { - t - } else { - bal(l, v, rr) - } - } - } - - let singleton = x => Node({l: Empty, v: x, r: Empty, h: 1}) - - /* Beware: those two functions assume that the added v is *strictly* - smaller (or bigger) than all the present elements in the tree; it - does not test for equality with the current min (or max) element. - Indeed, they are only used during the "join" operation which - respects this precondition. - */ - - let rec add_min_element = (x, param) => - switch param { - | Empty => singleton(x) - | Node({l, v, r}) => bal(add_min_element(x, l), v, r) - } - - let rec add_max_element = (x, param) => - switch param { - | Empty => singleton(x) - | Node({l, v, r}) => bal(l, v, add_max_element(x, r)) - } - - /* Same as create and bal, but no assumptions are made on the - relative heights of l and r. */ - - let rec join = (l, v, r) => - switch (l, r) { - | (Empty, _) => add_min_element(v, r) - | (_, Empty) => add_max_element(v, l) - | (Node({l: ll, v: lv, r: lr, h: lh}), Node({l: rl, v: rv, r: rr, h: rh})) => - if lh > rh + 2 { - bal(ll, lv, join(lr, v, r)) - } else if rh > lh + 2 { - bal(join(l, v, rl), rv, rr) - } else { - create(l, v, r) - } - } - - /* Smallest and greatest element of a set */ - - let rec min_elt = param => - switch param { - | Empty => raise(Not_found) - | Node({l: Empty, v}) => v - | Node({l}) => min_elt(l) - } - - let rec min_elt_opt = param => - switch param { - | Empty => None - | Node({l: Empty, v}) => Some(v) - | Node({l}) => min_elt_opt(l) - } - - let rec max_elt = param => - switch param { - | Empty => raise(Not_found) - | Node({v, r: Empty}) => v - | Node({r}) => max_elt(r) - } - - let rec max_elt_opt = param => - switch param { - | Empty => None - | Node({v, r: Empty}) => Some(v) - | Node({r}) => max_elt_opt(r) - } - - /* Remove the smallest element of the given set */ - - let rec remove_min_elt = param => - switch param { - | Empty => invalid_arg("Set.remove_min_elt") - | Node({l: Empty, r}) => r - | Node({l, v, r}) => bal(remove_min_elt(l), v, r) - } - - /* Merge two trees l and r into one. - All elements of l must precede the elements of r. - Assume | height l - height r | <= 2. */ - - let merge = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => bal(t1, min_elt(t2), remove_min_elt(t2)) - } - - /* Merge two trees l and r into one. - All elements of l must precede the elements of r. - No assumption on the heights of l and r. */ - - let concat = (t1, t2) => - switch (t1, t2) { - | (Empty, t) => t - | (t, Empty) => t - | (_, _) => join(t1, min_elt(t2), remove_min_elt(t2)) - } - - /* Splitting. split x s returns a triple (l, present, r) where - - l is the set of elements of s that are < x - - r is the set of elements of s that are > x - - present is false if s contains no element equal to x, - or true if s contains an element equal to x. */ - - let rec split = (x, param) => - switch param { - | Empty => (Empty, false, Empty) - | Node({l, v, r}) => - let c = Ord.compare(x, v) - if c == 0 { - (l, true, r) - } else if c < 0 { - let (ll, pres, rl) = split(x, l) - (ll, pres, join(rl, v, r)) - } else { - let (lr, pres, rr) = split(x, r) - (join(l, v, lr), pres, rr) - } - } - - /* Implementation of the set operations */ - - let empty = Empty - - let is_empty = param => - switch param { - | Empty => true - | _ => false - } - - let rec mem = (x, param) => - switch param { - | Empty => false - | Node({l, v, r}) => - let c = Ord.compare(x, v) - c == 0 || - mem( - x, - if c < 0 { - l - } else { - r - }, - ) - } - - let rec remove = (x, param) => - switch param { - | Empty => Empty - | Node({l, v, r}) as t => - let c = Ord.compare(x, v) - if c == 0 { - merge(l, r) - } else if c < 0 { - let ll = remove(x, l) - if l === ll { - t - } else { - bal(ll, v, r) - } - } else { - let rr = remove(x, r) - if r === rr { - t - } else { - bal(l, v, rr) - } - } - } - - let rec union = (s1, s2) => - switch (s1, s2) { - | (Empty, t2) => t2 - | (t1, Empty) => t1 - | (Node({l: l1, v: v1, r: r1, h: h1}), Node({l: l2, v: v2, r: r2, h: h2})) => - if h1 >= h2 { - if h2 == 1 { - add(v2, s1) - } else { - let (l2, _, r2) = split(v1, s2) - join(union(l1, l2), v1, union(r1, r2)) - } - } else if h1 == 1 { - add(v1, s2) - } else { - let (l1, _, r1) = split(v2, s1) - join(union(l1, l2), v2, union(r1, r2)) - } - } - - let rec inter = (s1, s2) => - switch (s1, s2) { - | (Empty, _) => Empty - | (_, Empty) => Empty - | (Node({l: l1, v: v1, r: r1}), t2) => - switch split(v1, t2) { - | (l2, false, r2) => concat(inter(l1, l2), inter(r1, r2)) - | (l2, true, r2) => join(inter(l1, l2), v1, inter(r1, r2)) - } - } - - let rec diff = (s1, s2) => - switch (s1, s2) { - | (Empty, _) => Empty - | (t1, Empty) => t1 - | (Node({l: l1, v: v1, r: r1}), t2) => - switch split(v1, t2) { - | (l2, false, r2) => join(diff(l1, l2), v1, diff(r1, r2)) - | (l2, true, r2) => concat(diff(l1, l2), diff(r1, r2)) - } - } - - type rec enumeration = End | More(elt, t, enumeration) - - let rec cons_enum = (s, e) => - switch s { - | Empty => e - | Node({l, v, r}) => cons_enum(l, More(v, r, e)) - } - - let rec compare_aux = (e1, e2) => - switch (e1, e2) { - | (End, End) => 0 - | (End, _) => -1 - | (_, End) => 1 - | (More(v1, r1, e1), More(v2, r2, e2)) => - let c = Ord.compare(v1, v2) - if c != 0 { - c - } else { - compare_aux(cons_enum(r1, e1), cons_enum(r2, e2)) - } - } - - let compare = (s1, s2) => compare_aux(cons_enum(s1, End), cons_enum(s2, End)) - - let equal = (s1, s2) => compare(s1, s2) == 0 - - let rec subset = (s1, s2) => - switch (s1, s2) { - | (Empty, _) => true - | (_, Empty) => false - | (Node({l: l1, v: v1, r: r1}), Node({l: l2, v: v2, r: r2}) as t2) => - let c = Ord.compare(v1, v2) - if c == 0 { - subset(l1, l2) && subset(r1, r2) - } else if c < 0 { - subset(Node({l: l1, v: v1, r: Empty, h: 0}), l2) && subset(r1, t2) - } else { - subset(Node({l: Empty, v: v1, r: r1, h: 0}), r2) && subset(l1, t2) - } - } - - let rec iter = (~f, param) => - switch param { - | Empty => () - | Node({l, v, r}) => - iter(~f, l) - f(v) - iter(~f, r) - } - - let rec fold = (~f, s, ~init as accu) => - switch s { - | Empty => accu - | Node({l, v, r}) => fold(~f, r, ~init=f(v, fold(~f, l, ~init=accu))) - } - - let rec for_all = (~f as p, param) => - switch param { - | Empty => true - | Node({l, v, r}) => p(v) && (for_all(~f=p, l) && for_all(~f=p, r)) - } - - let rec exists = (~f as p, param) => - switch param { - | Empty => false - | Node({l, v, r}) => p(v) || (exists(~f=p, l) || exists(~f=p, r)) - } - - let rec filter = (~f as p, param) => - switch param { - | Empty => Empty - | Node({l, v, r}) as t => - /* call [p] in the expected left-to-right order */ - let l' = filter(~f=p, l) - let pv = p(v) - let r' = filter(~f=p, r) - if pv { - if l === l' && r === r' { - t - } else { - join(l', v, r') - } - } else { - concat(l', r') - } - } - - let rec partition = (~f as p, param) => - switch param { - | Empty => (Empty, Empty) - | Node({l, v, r}) => - /* call [p] in the expected left-to-right order */ - let (lt, lf) = partition(~f=p, l) - let pv = p(v) - let (rt, rf) = partition(~f=p, r) - if pv { - (join(lt, v, rt), concat(lf, rf)) - } else { - (concat(lt, rt), join(lf, v, rf)) - } - } - - let rec cardinal = param => - switch param { - | Empty => 0 - | Node({l, r}) => cardinal(l) + 1 + cardinal(r) - } - - let rec elements_aux = (accu, param) => - switch param { - | Empty => accu - | Node({l, v, r}) => elements_aux(list{v, ...elements_aux(accu, r)}, l) - } - - let elements = s => elements_aux(list{}, s) - - let choose = min_elt - - let choose_opt = min_elt_opt - - let rec find = (x, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, r}) => - let c = Ord.compare(x, v) - if c == 0 { - v - } else { - find( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let rec find_first_aux = (v0, f, param) => - switch param { - | Empty => v0 - | Node({l, v, r}) => - if f(v) { - find_first_aux(v, f, l) - } else { - find_first_aux(v0, f, r) - } - } - - let rec find_first = (~f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, r}) => - if f(v) { - find_first_aux(v, f, l) - } else { - find_first(~f, r) - } - } - - let rec find_first_opt_aux = (v0, f, param) => - switch param { - | Empty => Some(v0) - | Node({l, v, r}) => - if f(v) { - find_first_opt_aux(v, f, l) - } else { - find_first_opt_aux(v0, f, r) - } - } - - let rec find_first_opt = (~f, param) => - switch param { - | Empty => None - | Node({l, v, r}) => - if f(v) { - find_first_opt_aux(v, f, l) - } else { - find_first_opt(~f, r) - } - } - - let rec find_last_aux = (v0, f, param) => - switch param { - | Empty => v0 - | Node({l, v, r}) => - if f(v) { - find_last_aux(v, f, r) - } else { - find_last_aux(v0, f, l) - } - } - - let rec find_last = (~f, param) => - switch param { - | Empty => raise(Not_found) - | Node({l, v, r}) => - if f(v) { - find_last_aux(v, f, r) - } else { - find_last(~f, l) - } - } - - let rec find_last_opt_aux = (v0, f, param) => - switch param { - | Empty => Some(v0) - | Node({l, v, r}) => - if f(v) { - find_last_opt_aux(v, f, r) - } else { - find_last_opt_aux(v0, f, l) - } - } - - let rec find_last_opt = (~f, param) => - switch param { - | Empty => None - | Node({l, v, r}) => - if f(v) { - find_last_opt_aux(v, f, r) - } else { - find_last_opt(~f, l) - } - } - - let rec find_opt = (x, param) => - switch param { - | Empty => None - | Node({l, v, r}) => - let c = Ord.compare(x, v) - if c == 0 { - Some(v) - } else { - find_opt( - x, - if c < 0 { - l - } else { - r - }, - ) - } - } - - let try_join = (l, v, r) => - /* [join l v r] can only be called when (elements of l < v < - elements of r); use [try_join l v r] when this property may - not hold, but you hope it does hold in the common case */ - if ( - (l == Empty || Ord.compare(max_elt(l), v) < 0) && - (r == Empty || Ord.compare(v, min_elt(r)) < 0) - ) { - join(l, v, r) - } else { - union(l, add(v, r)) - } - - let rec map = (~f, param) => - switch param { - | Empty => Empty - | Node({l, v, r}) as t => - /* enforce left-to-right evaluation order */ - let l' = map(~f, l) - let v' = f(v) - let r' = map(~f, r) - if l === l' && (v === v' && r === r') { - t - } else { - try_join(l', v', r') - } - } - - let of_sorted_list = l => { - let rec sub = (n, l) => - switch (n, l) { - | (0, l) => (Empty, l) - | (1, list{x0, ...l}) => (Node({l: Empty, v: x0, r: Empty, h: 1}), l) - | (2, list{x0, x1, ...l}) => ( - Node({l: Node({l: Empty, v: x0, r: Empty, h: 1}), v: x1, r: Empty, h: 2}), - l, - ) - | (3, list{x0, x1, x2, ...l}) => ( - Node({ - l: Node({l: Empty, v: x0, r: Empty, h: 1}), - v: x1, - r: Node({l: Empty, v: x2, r: Empty, h: 1}), - h: 2, - }), - l, - ) - | (n, l) => - let nl = n / 2 - let (left, l) = sub(nl, l) - switch l { - | list{} => assert(false) - | list{mid, ...l} => - let (right, l) = sub(n - nl - 1, l) - (create(left, mid, right), l) - } - } - - fst(sub(List.length(l), l)) - } - - let of_list = l => - switch l { - | list{} => empty - | list{x0} => singleton(x0) - | list{x0, x1} => add(x1, singleton(x0)) - | list{x0, x1, x2} => add(x2, add(x1, singleton(x0))) - | list{x0, x1, x2, x3} => add(x3, add(x2, add(x1, singleton(x0)))) - | list{x0, x1, x2, x3, x4} => add(x4, add(x3, add(x2, add(x1, singleton(x0))))) - | _ => of_sorted_list(List.sort_uniq(Ord.compare, l)) - } -} diff --git a/jscomp/stdlib-406/sort.res b/jscomp/stdlib-406/sort.res deleted file mode 100644 index ab1713a..0000000 --- a/jscomp/stdlib-406/sort.res +++ /dev/null @@ -1,134 +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. */ -/* */ -/* ************************************************************************ */ - -/* Merging and sorting */ - -open Array - -let rec merge = (order, l1, l2) => - switch l1 { - | list{} => l2 - | list{h1, ...t1} => - switch l2 { - | list{} => l1 - | list{h2, ...t2} => - if order(h1, h2) { - list{h1, ...merge(order, t1, l2)} - } else { - list{h2, ...merge(order, l1, t2)} - } - } - } - -let list = (order, l) => { - let rec initlist = param => - switch param { - | list{} => list{} - | list{e} => list{list{e}} - | list{e1, e2, ...rest} => - list{ - if order(e1, e2) { - list{e1, e2} - } else { - list{e2, e1} - }, - ...initlist(rest), - } - } - let rec merge2 = param => - switch param { - | list{l1, l2, ...rest} => list{merge(order, l1, l2), ...merge2(rest)} - | x => x - } - let rec mergeall = param => - switch param { - | list{} => list{} - | list{l} => l - | llist => mergeall(merge2(llist)) - } - mergeall(initlist(l)) -} - -let swap = (arr, i, j) => { - let tmp = unsafe_get(arr, i) - unsafe_set(arr, i, unsafe_get(arr, j)) - unsafe_set(arr, j, tmp) -} - -/* There is a known performance bug in the code below. If you find - it, don't bother reporting it. You're not supposed to use this - module anyway. */ -let array = (cmp, arr) => { - let rec qsort = (lo, hi) => - if hi - lo >= 6 { - let mid = lsr(lo + hi, 1) - - /* Select median value from among LO, MID, and HI. Rearrange - LO and HI so the three values are sorted. This lowers the - probability of picking a pathological pivot. It also - avoids extra comparisons on i and j in the two tight "while" - loops below. */ - if cmp(unsafe_get(arr, mid), unsafe_get(arr, lo)) { - swap(arr, mid, lo) - } - if cmp(unsafe_get(arr, hi), unsafe_get(arr, mid)) { - swap(arr, mid, hi) - if cmp(unsafe_get(arr, mid), unsafe_get(arr, lo)) { - swap(arr, mid, lo) - } - } - let pivot = unsafe_get(arr, mid) - let i = ref(lo + 1) and j = ref(hi - 1) - if !cmp(pivot, unsafe_get(arr, hi)) || !cmp(unsafe_get(arr, lo), pivot) { - raise(Invalid_argument("Sort.array")) - } - while i.contents < j.contents { - while !cmp(pivot, unsafe_get(arr, i.contents)) { - incr(i) - } - while !cmp(unsafe_get(arr, j.contents), pivot) { - decr(j) - } - if i.contents < j.contents { - swap(arr, i.contents, j.contents) - } - incr(i) - decr(j) - } - - /* Recursion on smaller half, tail-call on larger half */ - if j.contents - lo <= hi - i.contents { - qsort(lo, j.contents) - qsort(i.contents, hi) - } else { - qsort(i.contents, hi) - qsort(lo, j.contents) - } - } - qsort(0, Array.length(arr) - 1) - /* Finish sorting by insertion sort */ - for i in 1 to Array.length(arr) - 1 { - let val_i = unsafe_get(arr, i) - if !cmp(unsafe_get(arr, i - 1), val_i) { - unsafe_set(arr, i, unsafe_get(arr, i - 1)) - let j = ref(i - 1) - while j.contents >= 1 && !cmp(unsafe_get(arr, j.contents - 1), val_i) { - unsafe_set(arr, j.contents, unsafe_get(arr, j.contents - 1)) - decr(j) - } - unsafe_set(arr, j.contents, val_i) - } - } -} diff --git a/jscomp/stdlib-406/sort.resi b/jscomp/stdlib-406/sort.resi deleted file mode 100644 index b4de4f9..0000000 --- a/jscomp/stdlib-406/sort.resi +++ /dev/null @@ -1,44 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Sorting and merging lists. - - @deprecated This module is obsolete and exists only for backward - compatibility. - The sorting functions in {!Array} and {!List} should be used instead. - The new functions are faster and use less memory. -*/ - -@deprecated("Use List.sort instead.") -/** Sort a list in increasing order according to an ordering predicate. - The predicate should return [true] if its first argument is - less than or equal to its second argument. */ -let list: (('a, 'a) => bool, list<'a>) => list<'a> - -@deprecated("Use Array.sort instead.") -/** Sort an array in increasing order according to an - ordering predicate. - The predicate should return [true] if its first argument is - less than or equal to its second argument. - The array is sorted in place. */ -let array: (('a, 'a) => bool, array<'a>) => unit - -@deprecated("Use List.merge instead.") -/** Merge two lists according to the given predicate. - Assuming the two argument lists are sorted according to the - predicate, [merge] returns a sorted list containing the elements - from the two lists. The behavior is undefined if the two - argument lists were not sorted. */ -let merge: (('a, 'a) => bool, list<'a>, list<'a>) => list<'a> diff --git a/jscomp/stdlib-406/stack.res b/jscomp/stdlib-406/stack.res deleted file mode 100644 index ee13834..0000000 --- a/jscomp/stdlib-406/stack.res +++ /dev/null @@ -1,55 +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. */ -/* */ -/* ************************************************************************ */ - -type t<'a> = {mutable c: list<'a>, mutable len: int} - -exception Empty - -let create = () => {c: list{}, len: 0} - -let clear = s => { - s.c = list{} - s.len = 0 -} - -let copy = s => {c: s.c, len: s.len} - -let push = (x, s) => { - s.c = list{x, ...s.c} - s.len = s.len + 1 -} - -let pop = s => - switch s.c { - | list{hd, ...tl} => - s.c = tl - s.len = s.len - 1 - hd - | list{} => raise(Empty) - } - -let top = s => - switch s.c { - | list{hd, ..._} => hd - | list{} => raise(Empty) - } - -let is_empty = s => s.c == list{} - -let length = s => s.len - -let iter = (f, s) => List.iter(f, s.c) - -let fold = (f, acc, s) => List.fold_left(f, acc, s.c) diff --git a/jscomp/stdlib-406/stack.resi b/jscomp/stdlib-406/stack.resi deleted file mode 100644 index 6acaaa7..0000000 --- a/jscomp/stdlib-406/stack.resi +++ /dev/null @@ -1,61 +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. */ -/* */ -/* ************************************************************************ */ - -/*** Last-in first-out stacks. - - This module implements stacks (LIFOs), with in-place modification. -*/ - -/** The type of stacks containing elements of type ['a]. */ -type t<'a> - -/** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. */ exception Empty - -/** Return a new stack, initially empty. */ -let create: unit => t<'a> - -/** [push x s] adds the element [x] at the top of stack [s]. */ -let push: ('a, t<'a>) => unit - -/** [pop s] removes and returns the topmost element in stack [s], - or raises {!Empty} if the stack is empty. */ -let pop: t<'a> => 'a - -/** [top s] returns the topmost element in stack [s], - or raises {!Empty} if the stack is empty. */ -let top: t<'a> => 'a - -/** Discard all elements from a stack. */ -let clear: t<'a> => unit - -/** Return a copy of the given stack. */ -let copy: t<'a> => t<'a> - -/** Return [true] if the given stack is empty, [false] otherwise. */ -let is_empty: t<'a> => bool - -/** Return the number of elements in a stack. Time complexity O(1) */ -let length: t<'a> => int - -/** [iter f s] applies [f] in turn to all elements of [s], - from the element at the top of the stack to the element at the - bottom of the stack. The stack itself is unchanged. */ -let iter: ('a => unit, t<'a>) => unit - -/** [fold f accu s] is [(f (... (f (f accu x1) x2) ...) xn)] - where [x1] is the top of the stack, [x2] the second element, - and [xn] the bottom element. The stack is unchanged. - @since 4.03 */ -let fold: (('b, 'a) => 'b, 'b, t<'a>) => 'b diff --git a/jscomp/stdlib-406/stdLabels.res b/jscomp/stdlib-406/stdLabels.res deleted file mode 100644 index 8e35db9..0000000 --- a/jscomp/stdlib-406/stdLabels.res +++ /dev/null @@ -1,24 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2001 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. */ -/* */ -/* ************************************************************************ */ - -/* Module [StdLabels]: meta-module for labelled libraries */ - -module Array = ArrayLabels - -module List = ListLabels - -module String = StringLabels - -module Bytes = BytesLabels diff --git a/jscomp/stdlib-406/stdLabels.resi b/jscomp/stdlib-406/stdLabels.resi deleted file mode 100644 index a36e9d3..0000000 --- a/jscomp/stdlib-406/stdLabels.resi +++ /dev/null @@ -1,29 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Jacques Garrigue, Kyoto University RIMS */ -/* */ -/* Copyright 2001 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. */ -/* */ -/* ************************************************************************ */ - -/*** Standard labeled libraries. - - This meta-module provides labelized version of the {!Array}, - {!Bytes}, {!List} and {!String} modules. - - They only differ by their labels. Detailed interfaces can be found - in [arrayLabels.mli], [bytesLabels.mli], [listLabels.mli] - and [stringLabels.mli]. -*/ - -module Array = ArrayLabels -module Bytes = BytesLabels -module List = ListLabels -module String = StringLabels diff --git a/jscomp/stdlib-406/stream.res b/jscomp/stdlib-406/stream.res deleted file mode 100644 index d819559..0000000 --- a/jscomp/stdlib-406/stream.res +++ /dev/null @@ -1,260 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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 rec t<'a> = option> -and cell<'a> = {mutable count: int, mutable data: data<'a>} -and data<'a> = - | Sempty - | Scons('a, data<'a>) - | Sapp(data<'a>, data<'a>) - | Slazy(Lazy.t>) - | Sgen(gen<'a>) -and gen<'a> = {mutable curr: option>, func: int => option<'a>} - -exception Failure -exception Error(string) - -let count = param => - switch param { - | None => 0 - | Some({count}) => count - } -let data = param => - switch param { - | None => Sempty - | Some({data}) => data - } - -let rec get_data: - type v. (int, data) => data = - (count, d) => - switch d { - /* Returns either Sempty or Scons(a, _) even when d is a generator - or a buffer. In those cases, the item a is seen as extracted from - the generator/buffer. - The count parameter is used for calling `Sgen-functions'. */ - | Sempty | Scons(_, _) => d - | Sapp(d1, d2) => - switch get_data(count, d1) { - | Scons(a, d11) => Scons(a, Sapp(d11, d2)) - | Sempty => get_data(count, d2) - | _ => assert(false) - } - | Sgen({curr: Some(None)}) => Sempty - | Sgen({curr: Some(Some(a))} as g) => - g.curr = None - Scons(a, d) - | Sgen(g) => - switch g.func(count) { - | None => - g.curr = Some(None) - Sempty - | Some(a) => Scons(a, d) - /* Warning: anyone using g thinks that an item has been read */ - } - | Slazy(f) => get_data(count, Lazy.force(f)) - } - -let rec peek_data: - type v. cell => option = - s => - /* consult the first item of s */ - switch s.data { - | Sempty => None - | Scons(a, _) => Some(a) - | Sapp(_, _) => - switch get_data(s.count, s.data) { - | Scons(a, _) as d => - s.data = d - Some(a) - | Sempty => None - | _ => assert(false) - } - | Slazy(f) => - s.data = Lazy.force(f) - peek_data(s) - | Sgen({curr: Some(a)}) => a - | Sgen(g) => - let x = g.func(s.count) - g.curr = Some(x) - x - } - -let peek = param => - switch param { - | None => None - | Some(s) => peek_data(s) - } - -let rec junk_data: - type v. cell => unit = - s => - switch s.data { - | Scons(_, d) => - s.count = succ(s.count) - s.data = d - | Sgen({curr: Some(_)} as g) => - s.count = succ(s.count) - g.curr = None - | _ => - switch peek_data(s) { - | None => () - | Some(_) => junk_data(s) - } - } - -let junk = param => - switch param { - | None => () - | Some(data) => junk_data(data) - } - -let rec nget_data = (n, s) => - if n <= 0 { - (list{}, s.data, 0) - } else { - switch peek_data(s) { - | Some(a) => - junk_data(s) - let (al, d, k) = nget_data(pred(n), s) - (list{a, ...al}, Scons(a, d), succ(k)) - | None => (list{}, s.data, 0) - } - } - -let npeek_data = (n, s) => { - let (al, d, len) = nget_data(n, s) - s.count = s.count - len - s.data = d - al -} - -let npeek = (n, param) => - switch param { - | None => list{} - | Some(d) => npeek_data(n, d) - } - -let next = s => - switch peek(s) { - | Some(a) => - junk(s) - a - | None => raise(Failure) - } - -let empty = s => - switch peek(s) { - | Some(_) => raise(Failure) - | None => () - } - -let iter = (f, strm) => { - let rec do_rec = () => - switch peek(strm) { - | Some(a) => - junk(strm) - ignore(f(a)) - do_rec() - | None => () - } - - do_rec() -} - -/* Stream building functions */ - -let from = f => Some({count: 0, data: Sgen({curr: None, func: f})}) - -let of_list = l => Some({count: 0, data: List.fold_right((x, l) => Scons(x, l), l, Sempty)}) - -let of_string = s => { - let count = ref(0) - from(_ => { - /* We cannot use the index passed by the [from] function directly - because it returns the current stream count, with absolutely no - guarantee that it will start from 0. For example, in the case - of [Stream.icons 'c' (Stream.from_string "ab")], the first - access to the string will be made with count [1] already. - */ - let c = count.contents - if c < String.length(s) { - incr(count) - Some(String.get(s, c)) - } else { - None - } - }) -} - -let of_bytes = s => { - let count = ref(0) - from(_ => { - let c = count.contents - if c < Bytes.length(s) { - incr(count) - Some(Bytes.get(s, c)) - } else { - None - } - }) -} - -/* Stream expressions builders */ - -let iapp = (i, s) => Some({count: 0, data: Sapp(data(i), data(s))}) -let icons = (i, s) => Some({count: 0, data: Scons(i, data(s))}) -let ising = i => Some({count: 0, data: Scons(i, Sempty)}) - -let lapp = (f, s) => Some({count: 0, data: Slazy(lazy Sapp(data(f()), data(s)))}) - -let lcons = (f, s) => Some({count: 0, data: Slazy(lazy Scons(f(), data(s)))}) -let lsing = f => Some({count: 0, data: Slazy(lazy Scons(f(), Sempty))}) - -let sempty = None -let slazy = f => Some({count: 0, data: Slazy(lazy data(f()))}) - -/* For debugging use */ - -let rec dump: - type v. (v => unit, t) => unit = - (f, s) => { - print_string("{count = ") - print_int(count(s)) - print_string("; data = ") - dump_data(f, data(s)) - print_string("}") - print_newline() - } -and dump_data: - type v. (v => unit, data) => unit = - (f, param) => - switch param { - | Sempty => print_string("Sempty") - | Scons(a, d) => - print_string("Scons (") - f(a) - print_string(", ") - dump_data(f, d) - print_string(")") - | Sapp(d1, d2) => - print_string("Sapp (") - dump_data(f, d1) - print_string(", ") - dump_data(f, d2) - print_string(")") - | Slazy(_) => print_string("Slazy") - | Sgen(_) => print_string("Sgen") - } diff --git a/jscomp/stdlib-406/stream.resi b/jscomp/stdlib-406/stream.resi deleted file mode 100644 index 952e6b9..0000000 --- a/jscomp/stdlib-406/stream.resi +++ /dev/null @@ -1,101 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt */ -/* */ -/* Copyright 1997 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. */ -/* */ -/* ************************************************************************ */ - -/*** Streams and parsers. */ - -/** The type of streams holding values of type ['a]. */ -type t<'a> - -/** Raised by parsers when none of the first components of the stream - patterns is accepted. */ -exception Failure - -/** Raised by parsers when the first component of a stream pattern is - accepted, but one of the following components is rejected. */ -exception Error(string) - -/*** {1 Stream builders} */ - -/** [Stream.from f] returns a stream built from the function [f]. - To create a new stream element, the function [f] is called with - the current stream count. The user function [f] must return either - [Some ] for a value or [None] to specify the end of the - stream. - - Do note that the indices passed to [f] may not start at [0] in the - general case. For example, [[< '0; '1; Stream.from f >]] would call - [f] the first time with count [2]. -*/ -let from: (int => option<'a>) => t<'a> - -/** Return the stream holding the elements of the list in the same - order. */ -let of_list: list<'a> => t<'a> - -/** Return the stream of the characters of the string parameter. */ -let of_string: string => t - -/** Return the stream of the characters of the bytes parameter. - @since 4.02.0 */ -let of_bytes: bytes => t - -/* {1 Stream iterator} */ - -/** [Stream.iter f s] scans the whole stream s, applying function [f] - in turn to each stream element encountered. */ -let iter: ('a => unit, t<'a>) => unit - -/* {1 Predefined parsers} */ - -/** Return the first element of the stream and remove it from the - stream. Raise {!Stream.Failure} if the stream is empty. */ -let next: t<'a> => 'a - -/** Return [()] if the stream is empty, else raise {!Stream.Failure}. */ -let empty: t<'a> => unit - -/* {1 Useful functions} */ - -/** Return [Some] of "the first element" of the stream, or [None] if - the stream is empty. */ -let peek: t<'a> => option<'a> - -/** Remove the first element of the stream, possibly unfreezing - it before. */ -let junk: t<'a> => unit - -/** Return the current count of the stream elements, i.e. the number - of the stream elements discarded. */ -let count: t<'a> => int - -/** [npeek n] returns the list of the [n] first elements of - the stream, or all its remaining elements if less than [n] - elements are available. */ -let npeek: (int, t<'a>) => list<'a> - -/* The following is for system use only. Do not call directly. */ - -let iapp: (t<'a>, t<'a>) => t<'a> -let icons: ('a, t<'a>) => t<'a> -let ising: 'a => t<'a> - -let lapp: (unit => t<'a>, t<'a>) => t<'a> -let lcons: (unit => 'a, t<'a>) => t<'a> -let lsing: (unit => 'a) => t<'a> - -let sempty: t<'a> -let slazy: (unit => t<'a>) => t<'a> - -let dump: ('a => unit, t<'a>) => unit diff --git a/jscomp/stdlib-406/string.res b/jscomp/stdlib-406/string.res deleted file mode 100644 index a038bfd..0000000 --- a/jscomp/stdlib-406/string.res +++ /dev/null @@ -1,235 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2014 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. */ -/* */ -/* ************************************************************************ */ - -/* String operations, based on byte sequence operations */ - -/* WARNING: Some functions in this file are duplicated in bytes.ml for - efficiency reasons. When you modify the one in this file you need to - modify its duplicate in bytes.ml. - These functions have a "duplicated" comment above their definition. -*/ - -external length: string => int = "%string_length" -external get: (string, int) => char = "%string_safe_get" -external unsafe_get: (string, int) => char = "%string_unsafe_get" - -module B = Bytes - -let bts = B.unsafe_to_string -let bos = B.unsafe_of_string - -external make: (int, char) => string = "?string_repeat" - -let init = (n, f) => bts(B.init(n, f)) -let sub = (s, ofs, len) => bts(B.sub(bos(s), ofs, len)) -let blit = B.blit_string - -%%private(@send external join: (array, string) => string = "join") - -let concat = (sep: string, xs: list) => xs->Array.of_list->join(sep) - -/* duplicated in bytes.ml */ -let iter = (f, s) => - for i in 0 to length(s) - 1 { - f(unsafe_get(s, i)) - } - -/* duplicated in bytes.ml */ -let iteri = (f, s) => - for i in 0 to length(s) - 1 { - f(i, unsafe_get(s, i)) - } - -let map = (f, s) => bts(B.map(f, bos(s))) -let mapi = (f, s) => bts(B.mapi(f, bos(s))) - -/* Beware: we cannot use B.trim or B.escape because they always make a - copy, but String.mli spells out some cases where we are not allowed - to make a copy. */ - -let is_space = param => - switch param { - | ' ' | ' ' | '\n' | '\r' | '\t' => true - | _ => false - } - -let trim = s => - if s == "" { - s - } else if is_space(unsafe_get(s, 0)) || is_space(unsafe_get(s, length(s) - 1)) { - bts(B.trim(bos(s))) - } else { - s - } - -let escaped = s => { - let rec needs_escape = i => - if i >= length(s) { - false - } else { - switch unsafe_get(s, i) { - | '"' | '\\' | '\n' | '\t' | '\r' | '\b' => true - | ' ' .. '~' => needs_escape(i + 1) - | _ => true - } - } - - if needs_escape(0) { - bts(B.escaped(bos(s))) - } else { - s - } -} - -/* duplicated in bytes.ml */ -let rec index_rec = (s, lim, i, c) => - if i >= lim { - raise(Not_found) - } else if unsafe_get(s, i) == c { - i - } else { - index_rec(s, lim, i + 1, c) - } - -/* duplicated in bytes.ml */ -let index = (s, c) => index_rec(s, length(s), 0, c) - -/* duplicated in bytes.ml */ -let rec index_rec_opt = (s, lim, i, c) => - if i >= lim { - None - } else if unsafe_get(s, i) == c { - Some(i) - } else { - index_rec_opt(s, lim, i + 1, c) - } - -/* duplicated in bytes.ml */ -let index_opt = (s, c) => index_rec_opt(s, length(s), 0, c) - -/* duplicated in bytes.ml */ -let index_from = (s, i, c) => { - let l = length(s) - if i < 0 || i > l { - invalid_arg("String.index_from / Bytes.index_from") - } else { - index_rec(s, l, i, c) - } -} - -/* duplicated in bytes.ml */ -let index_from_opt = (s, i, c) => { - let l = length(s) - if i < 0 || i > l { - invalid_arg("String.index_from_opt / Bytes.index_from_opt") - } else { - index_rec_opt(s, l, i, c) - } -} - -/* duplicated in bytes.ml */ -let rec rindex_rec = (s, i, c) => - if i < 0 { - raise(Not_found) - } else if unsafe_get(s, i) == c { - i - } else { - rindex_rec(s, i - 1, c) - } - -/* duplicated in bytes.ml */ -let rindex = (s, c) => rindex_rec(s, length(s) - 1, c) - -/* duplicated in bytes.ml */ -let rindex_from = (s, i, c) => - if i < -1 || i >= length(s) { - invalid_arg("String.rindex_from / Bytes.rindex_from") - } else { - rindex_rec(s, i, c) - } - -/* duplicated in bytes.ml */ -let rec rindex_rec_opt = (s, i, c) => - if i < 0 { - None - } else if unsafe_get(s, i) == c { - Some(i) - } else { - rindex_rec_opt(s, i - 1, c) - } - -/* duplicated in bytes.ml */ -let rindex_opt = (s, c) => rindex_rec_opt(s, length(s) - 1, c) - -/* duplicated in bytes.ml */ -let rindex_from_opt = (s, i, c) => - if i < -1 || i >= length(s) { - invalid_arg("String.rindex_from_opt / Bytes.rindex_from_opt") - } else { - rindex_rec_opt(s, i, c) - } - -/* duplicated in bytes.ml */ -let contains_from = (s, i, c) => { - let l = length(s) - if i < 0 || i > l { - invalid_arg("String.contains_from / Bytes.contains_from") - } else { - try { - ignore(index_rec(s, l, i, c)) - true - } catch { - | Not_found => false - } - } -} - -/* duplicated in bytes.ml */ -let contains = (s, c) => contains_from(s, 0, c) - -/* duplicated in bytes.ml */ -let rcontains_from = (s, i, c) => - if i < 0 || i >= length(s) { - invalid_arg("String.rcontains_from / Bytes.rcontains_from") - } else { - try { - ignore(rindex_rec(s, i, c)) - true - } catch { - | Not_found => false - } - } - -let uppercase_ascii = s => bts(B.uppercase_ascii(bos(s))) -let lowercase_ascii = s => bts(B.lowercase_ascii(bos(s))) -let capitalize_ascii = s => bts(B.capitalize_ascii(bos(s))) -let uncapitalize_ascii = s => bts(B.uncapitalize_ascii(bos(s))) - -type t = string - -let compare = (x: t, y: t) => Pervasives.compare(x, y) -let equal: (string, string) => bool = (a, b) => a == b - -let split_on_char = (sep, s) => { - let r = ref(list{}) - let j = ref(length(s)) - for i in length(s) - 1 downto 0 { - if unsafe_get(s, i) == sep { - r := list{sub(s, i + 1, j.contents - i - 1), ...r.contents} - j := i - } - } - list{sub(s, 0, j.contents), ...r.contents} -} diff --git a/jscomp/stdlib-406/string.resi b/jscomp/stdlib-406/string.resi deleted file mode 100644 index 319e089..0000000 --- a/jscomp/stdlib-406/string.resi +++ /dev/null @@ -1,275 +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. */ -/* */ -/* ************************************************************************ */ - -/*** String operations. - - A string is an immutable data structure that contains a - fixed-length sequence of (single-byte) characters. Each character - can be accessed in constant time through its index. - - Given a string [s] of length [l], we can access each of the [l] - characters of [s] via its index in the sequence. Indexes start at - [0], and we will call an index valid in [s] if it falls within the - range [[0...l-1]] (inclusive). A position is the point between two - characters or at the beginning or end of the string. We call a - position valid in [s] if it falls within the range [[0...l]] - (inclusive). Note that the character at index [n] is between - positions [n] and [n+1]. - - Two parameters [start] and [len] are said to designate a valid - substring of [s] if [len >= 0] and [start] and [start+len] are - valid positions in [s]. - - OCaml strings used to be modifiable in place, for instance via the - {!String.set} and {!String.blit} functions described below. This - usage is deprecated and only possible when the compiler is put in - "unsafe-string" mode by giving the [-unsafe-string] command-line - option (which is currently the default for reasons of backward - compatibility). This is done by making the types [string] and - [bytes] (see module {!Bytes}) interchangeable so that functions - expecting byte sequences can also accept strings as arguments and - modify them. - - All new code should avoid this feature and be compiled with the - [-safe-string] command-line option to enforce the separation between - the types [string] and [bytes]. -*/ - -/** Return the length (number of characters) of the given string. */ -external length: string => int = "%string_length" - -/** [String.get s n] returns the character at index [n] in string [s]. - You can also write [s.[n]] instead of [String.get s n]. - - Raise [Invalid_argument] if [n] not a valid index in [s]. */ -external get: (string, int) => char = "%string_safe_get" - -/** [String.make n c] returns a fresh string of length [n], - filled with the character [c]. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -let make: (int, char) => string - -/** [String.init n f] returns a string of length [n], with character - [i] initialized to the result of [f i] (called in increasing - index order). - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. - - @since 4.02.0 -*/ -let init: (int, int => char) => string - -/** [String.sub s start len] returns a fresh string of length [len], - containing the substring of [s] that starts at position [start] and - has length [len]. - - Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]. */ -let sub: (string, int, int) => string - -/** Same as {!Bytes.blit_string}. */ -let blit: (string, int, bytes, int, int) => unit - -/** [String.concat sep sl] concatenates the list of strings [sl], - inserting the separator string [sep] between each. - - Raise [Invalid_argument] if the result is longer than - {!Sys.max_string_length} bytes. */ -let concat: (string, list) => string - -/** [String.iter f s] applies function [f] in turn to all - the characters of [s]. It is equivalent to - [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. */ -let iter: (char => unit, string) => unit - -/** Same as {!String.iter}, but the - function is applied to the index of the element as first argument - (counting from 0), and the character itself as second argument. - @since 4.00.0 */ -let iteri: ((int, char) => unit, string) => unit - -/** [String.map f s] applies function [f] in turn to all the - characters of [s] (in increasing index order) and stores the - results in a new string that is returned. - @since 4.00.0 */ -let map: (char => char, string) => string - -/** [String.mapi f s] calls [f] with each character of [s] and its - index (in increasing index order) and stores the results in a new - string that is returned. - @since 4.02.0 */ -let mapi: ((int, char) => char, string) => string - -/** Return a copy of the argument, without leading and trailing - whitespace. The characters regarded as whitespace are: [' '], - ['\x0c'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor - trailing whitespace character in the argument, return the original - string itself, not a copy. - @since 4.00.0 */ -let trim: string => string - -/** Return a copy of the argument, with special characters - represented by escape sequences, following the lexical - conventions of OCaml. - All characters outside the ASCII printable range (32..126) are - escaped, as well as backslash and double-quote. - - If there is no special character in the argument that needs - escaping, return the original string itself, not a copy. - - Raise [Invalid_argument] if the result is longer than - {!Sys.max_string_length} bytes. - - The function {!Scanf.unescaped} is a left inverse of [escaped], - i.e. [Scanf.unescaped (escaped s) = s] for any string [s] (unless - [escape s] fails). */ -let escaped: string => string - -/** [String.index s c] returns the index of the first - occurrence of character [c] in string [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let index: (string, char) => int - -/** [String.index_opt s c] returns the index of the first - occurrence of character [c] in string [s], or - [None] if [c] does not occur in [s]. - @since 4.05 */ -let index_opt: (string, char) => option - -/** [String.rindex s c] returns the index of the last - occurrence of character [c] in string [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let rindex: (string, char) => int - -/** [String.rindex_opt s c] returns the index of the last occurrence - of character [c] in string [s], or [None] if [c] does not occur in - [s]. - @since 4.05 */ -let rindex_opt: (string, char) => option - -/** [String.index_from s i c] returns the index of the - first occurrence of character [c] in string [s] after position [i]. - [String.index s c] is equivalent to [String.index_from s 0 c]. - - Raise [Invalid_argument] if [i] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] after position [i]. */ -let index_from: (string, int, char) => int - -/** [String.index_from_opt s i c] returns the index of the - first occurrence of character [c] in string [s] after position [i] - or [None] if [c] does not occur in [s] after position [i]. - - [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c]. - Raise [Invalid_argument] if [i] is not a valid position in [s]. - - @since 4.05 -*/ -let index_from_opt: (string, int, char) => option - -/** [String.rindex_from s i c] returns the index of the - last occurrence of character [c] in string [s] before position [i+1]. - [String.rindex s c] is equivalent to - [String.rindex_from s (String.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] before position [i+1]. */ -let rindex_from: (string, int, char) => int - -/** [String.rindex_from_opt s i c] returns the index of the - last occurrence of character [c] in string [s] before position [i+1] - or [None] if [c] does not occur in [s] before position [i+1]. - - [String.rindex_opt s c] is equivalent to - [String.rindex_from_opt s (String.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - - @since 4.05 -*/ -let rindex_from_opt: (string, int, char) => option - -/** [String.contains s c] tests if character [c] - appears in the string [s]. */ -let contains: (string, char) => bool - -/** [String.contains_from s start c] tests if character [c] - appears in [s] after position [start]. - [String.contains s c] is equivalent to - [String.contains_from s 0 c]. - - Raise [Invalid_argument] if [start] is not a valid position in [s]. */ -let contains_from: (string, int, char) => bool - -/** [String.rcontains_from s stop c] tests if character [c] - appears in [s] before position [stop+1]. - - Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid - position in [s]. */ -let rcontains_from: (string, int, char) => bool - -/** Return a copy of the argument, with all lowercase letters - translated to uppercase, using the US-ASCII character set. - @since 4.03.0 */ -let uppercase_ascii: string => string - -/** Return a copy of the argument, with all uppercase letters - translated to lowercase, using the US-ASCII character set. - @since 4.03.0 */ -let lowercase_ascii: string => string - -/** Return a copy of the argument, with the first character set to uppercase, - using the US-ASCII character set. - @since 4.03.0 */ -let capitalize_ascii: string => string - -/** Return a copy of the argument, with the first character set to lowercase, - using the US-ASCII character set. - @since 4.03.0 */ -let uncapitalize_ascii: string => string - -/** An alias for the type of strings. */ -type t = string - -/** The comparison function for strings, with the same specification as - {!Pervasives.compare}. Along with the type [t], this function [compare] - allows the module [String] to be passed as argument to the functors - {!Set.Make} and {!Map.Make}. */ -let compare: (t, t) => int - -/** The equal function for strings. - @since 4.03.0 */ -let equal: (t, t) => bool - -/** [String.split_on_char sep s] returns the list of all (possibly empty) - substrings of [s] that are delimited by the [sep] character. - - The function's output is specified by the following invariants: - - - The list is not empty. - - Concatenating its elements using [sep] as a separator returns a - string equal to the input ([String.concat (String.make 1 sep) - (String.split_on_char sep s) = s]). - - No string in the result contains the [sep] character. - - @since 4.04.0 -*/ -let split_on_char: (char, string) => list - -/* The following is for system use only. Do not call directly. */ - -external unsafe_get: (string, int) => char = "%string_unsafe_get" diff --git a/jscomp/stdlib-406/stringLabels.res b/jscomp/stdlib-406/stringLabels.res deleted file mode 100644 index a9ea486..0000000 --- a/jscomp/stdlib-406/stringLabels.res +++ /dev/null @@ -1,235 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Damien Doligez, projet Gallium, INRIA Rocquencourt */ -/* */ -/* Copyright 2014 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. */ -/* */ -/* ************************************************************************ */ - -/* String operations, based on byte sequence operations */ - -/* WARNING: Some functions in this file are duplicated in bytes.ml for - efficiency reasons. When you modify the one in this file you need to - modify its duplicate in bytes.ml. - These functions have a "duplicated" comment above their definition. -*/ - -external length: string => int = "%string_length" -external get: (string, int) => char = "%string_safe_get" -external unsafe_get: (string, int) => char = "%string_unsafe_get" - -module B = Bytes - -let bts = B.unsafe_to_string -let bos = B.unsafe_of_string - -external make: (int, char) => string = "?string_repeat" - -let init = (n, ~f) => bts(B.init(n, f)) -let sub = (s, ~pos as ofs, ~len) => bts(B.sub(bos(s), ofs, len)) -let blit = (~src, ~src_pos, ~dst, ~dst_pos, ~len) => B.blit_string(src, src_pos, dst, dst_pos, len) - -%%private(@send external join: (array, string) => string = "join") - -let concat = (~sep: string, xs: list) => xs->Array.of_list->join(sep) - -/* duplicated in bytes.ml */ -let iter = (~f, s) => - for i in 0 to length(s) - 1 { - f(unsafe_get(s, i)) - } - -/* duplicated in bytes.ml */ -let iteri = (~f, s) => - for i in 0 to length(s) - 1 { - f(i, unsafe_get(s, i)) - } - -let map = (~f, s) => bts(B.map(f, bos(s))) -let mapi = (~f, s) => bts(B.mapi(f, bos(s))) - -/* Beware: we cannot use B.trim or B.escape because they always make a - copy, but String.mli spells out some cases where we are not allowed - to make a copy. */ - -let is_space = param => - switch param { - | ' ' | ' ' | '\n' | '\r' | '\t' => true - | _ => false - } - -let trim = s => - if s == "" { - s - } else if is_space(unsafe_get(s, 0)) || is_space(unsafe_get(s, length(s) - 1)) { - bts(B.trim(bos(s))) - } else { - s - } - -let escaped = s => { - let rec needs_escape = i => - if i >= length(s) { - false - } else { - switch unsafe_get(s, i) { - | '"' | '\\' | '\n' | '\t' | '\r' | '\b' => true - | ' ' .. '~' => needs_escape(i + 1) - | _ => true - } - } - - if needs_escape(0) { - bts(B.escaped(bos(s))) - } else { - s - } -} - -/* duplicated in bytes.ml */ -let rec index_rec = (s, lim, i, c) => - if i >= lim { - raise(Not_found) - } else if unsafe_get(s, i) == c { - i - } else { - index_rec(s, lim, i + 1, c) - } - -/* duplicated in bytes.ml */ -let index = (s, c) => index_rec(s, length(s), 0, c) - -/* duplicated in bytes.ml */ -let rec index_rec_opt = (s, lim, i, c) => - if i >= lim { - None - } else if unsafe_get(s, i) == c { - Some(i) - } else { - index_rec_opt(s, lim, i + 1, c) - } - -/* duplicated in bytes.ml */ -let index_opt = (s, c) => index_rec_opt(s, length(s), 0, c) - -/* duplicated in bytes.ml */ -let index_from = (s, i, c) => { - let l = length(s) - if i < 0 || i > l { - invalid_arg("String.index_from / Bytes.index_from") - } else { - index_rec(s, l, i, c) - } -} - -/* duplicated in bytes.ml */ -let index_from_opt = (s, i, c) => { - let l = length(s) - if i < 0 || i > l { - invalid_arg("String.index_from_opt / Bytes.index_from_opt") - } else { - index_rec_opt(s, l, i, c) - } -} - -/* duplicated in bytes.ml */ -let rec rindex_rec = (s, i, c) => - if i < 0 { - raise(Not_found) - } else if unsafe_get(s, i) == c { - i - } else { - rindex_rec(s, i - 1, c) - } - -/* duplicated in bytes.ml */ -let rindex = (s, c) => rindex_rec(s, length(s) - 1, c) - -/* duplicated in bytes.ml */ -let rindex_from = (s, i, c) => - if i < -1 || i >= length(s) { - invalid_arg("String.rindex_from / Bytes.rindex_from") - } else { - rindex_rec(s, i, c) - } - -/* duplicated in bytes.ml */ -let rec rindex_rec_opt = (s, i, c) => - if i < 0 { - None - } else if unsafe_get(s, i) == c { - Some(i) - } else { - rindex_rec_opt(s, i - 1, c) - } - -/* duplicated in bytes.ml */ -let rindex_opt = (s, c) => rindex_rec_opt(s, length(s) - 1, c) - -/* duplicated in bytes.ml */ -let rindex_from_opt = (s, i, c) => - if i < -1 || i >= length(s) { - invalid_arg("String.rindex_from_opt / Bytes.rindex_from_opt") - } else { - rindex_rec_opt(s, i, c) - } - -/* duplicated in bytes.ml */ -let contains_from = (s, i, c) => { - let l = length(s) - if i < 0 || i > l { - invalid_arg("String.contains_from / Bytes.contains_from") - } else { - try { - ignore(index_rec(s, l, i, c)) - true - } catch { - | Not_found => false - } - } -} - -/* duplicated in bytes.ml */ -let contains = (s, c) => contains_from(s, 0, c) - -/* duplicated in bytes.ml */ -let rcontains_from = (s, i, c) => - if i < 0 || i >= length(s) { - invalid_arg("String.rcontains_from / Bytes.rcontains_from") - } else { - try { - ignore(rindex_rec(s, i, c)) - true - } catch { - | Not_found => false - } - } - -let uppercase_ascii = s => bts(B.uppercase_ascii(bos(s))) -let lowercase_ascii = s => bts(B.lowercase_ascii(bos(s))) -let capitalize_ascii = s => bts(B.capitalize_ascii(bos(s))) -let uncapitalize_ascii = s => bts(B.uncapitalize_ascii(bos(s))) - -type t = string - -let compare = (x: t, y: t) => Pervasives.compare(x, y) -let equal: (string, string) => bool = (a, b) => a == b - -let split_on_char = (~sep, s) => { - let r = ref(list{}) - let j = ref(length(s)) - for i in length(s) - 1 downto 0 { - if unsafe_get(s, i) == sep { - r := list{sub(s, ~pos=i + 1, ~len=j.contents - i - 1), ...r.contents} - j := i - } - } - list{sub(s, ~pos=0, ~len=j.contents), ...r.contents} -} diff --git a/jscomp/stdlib-406/stringLabels.resi b/jscomp/stdlib-406/stringLabels.resi deleted file mode 100644 index 2886ac2..0000000 --- a/jscomp/stdlib-406/stringLabels.resi +++ /dev/null @@ -1,233 +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. */ -/* */ -/* ************************************************************************ */ - -/*** String operations. */ - -/** Return the length (number of characters) of the given string. */ -external length: string => int = "%string_length" - -/** [String.get s n] returns the character at index [n] in string [s]. - You can also write [s.[n]] instead of [String.get s n]. - - Raise [Invalid_argument] if [n] not a valid index in [s]. */ -external get: (string, int) => char = "%string_safe_get" - -/** [String.make n c] returns a fresh string of length [n], - filled with the character [c]. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. */ -let make: (int, char) => string - -/** [init n f] returns a string of length [n], - with character [i] initialized to the result of [f i]. - - Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. - @since 4.02.0 */ -let init: (int, ~f: int => char) => string - -/** [String.sub s start len] returns a fresh string of length [len], - containing the substring of [s] that starts at position [start] and - has length [len]. - - Raise [Invalid_argument] if [start] and [len] do not - designate a valid substring of [s]. */ -let sub: (string, ~pos: int, ~len: int) => string - -/** [String.blit src srcoff dst dstoff len] copies [len] bytes - from the string [src], starting at index [srcoff], - to byte sequence [dst], starting at character number [dstoff]. - - Raise [Invalid_argument] if [srcoff] and [len] do not - designate a valid range of [src], or if [dstoff] and [len] - do not designate a valid range of [dst]. */ -let blit: (~src: string, ~src_pos: int, ~dst: bytes, ~dst_pos: int, ~len: int) => unit - -/** [String.concat sep sl] concatenates the list of strings [sl], - inserting the separator string [sep] between each. */ -let concat: (~sep: string, list) => string - -/** [String.iter f s] applies function [f] in turn to all - the characters of [s]. It is equivalent to - [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. */ -let iter: (~f: char => unit, string) => unit - -/** Same as {!String.iter}, but the - function is applied to the index of the element as first argument - (counting from 0), and the character itself as second argument. - @since 4.00.0 */ -let iteri: (~f: (int, char) => unit, string) => unit - -/** [String.map f s] applies function [f] in turn to all - the characters of [s] and stores the results in a new string that - is returned. - @since 4.00.0 */ -let map: (~f: char => char, string) => string - -/** [String.mapi f s] calls [f] with each character of [s] and its - index (in increasing index order) and stores the results in a new - string that is returned. - @since 4.02.0 */ -let mapi: (~f: (int, char) => char, string) => string - -/** Return a copy of the argument, without leading and trailing - whitespace. The characters regarded as whitespace are: [' '], - ['\x0c'], ['\n'], ['\r'], and ['\t']. If there is no leading nor - trailing whitespace character in the argument, return the original - string itself, not a copy. - @since 4.00.0 */ -let trim: string => string - -/** Return a copy of the argument, with special characters - represented by escape sequences, following the lexical - conventions of OCaml. If there is no special - character in the argument, return the original string itself, - not a copy. Its inverse function is Scanf.unescaped. */ -let escaped: string => string - -/** [String.index s c] returns the index of the first - occurrence of character [c] in string [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let index: (string, char) => int - -/** [String.index_opt s c] returns the index of the first - occurrence of character [c] in string [s], or - [None] if [c] does not occur in [s]. - @since 4.05 */ -let index_opt: (string, char) => option - -/** [String.rindex s c] returns the index of the last - occurrence of character [c] in string [s]. - - Raise [Not_found] if [c] does not occur in [s]. */ -let rindex: (string, char) => int - -/** [String.rindex_opt s c] returns the index of the last occurrence - of character [c] in string [s], or [None] if [c] does not occur in - [s]. - @since 4.05 */ -let rindex_opt: (string, char) => option - -/** [String.index_from s i c] returns the index of the - first occurrence of character [c] in string [s] after position [i]. - [String.index s c] is equivalent to [String.index_from s 0 c]. - - Raise [Invalid_argument] if [i] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] after position [i]. */ -let index_from: (string, int, char) => int - -/** [String.index_from_opt s i c] returns the index of the - first occurrence of character [c] in string [s] after position [i] - or [None] if [c] does not occur in [s] after position [i]. - - [String.index_opt s c] is equivalent to [String.index_from_opt s 0 c]. - Raise [Invalid_argument] if [i] is not a valid position in [s]. - - @since 4.05 -*/ -let index_from_opt: (string, int, char) => option - -/** [String.rindex_from s i c] returns the index of the - last occurrence of character [c] in string [s] before position [i+1]. - [String.rindex s c] is equivalent to - [String.rindex_from s (String.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - Raise [Not_found] if [c] does not occur in [s] before position [i+1]. */ -let rindex_from: (string, int, char) => int - -/** [String.rindex_from_opt s i c] returns the index of the - last occurrence of character [c] in string [s] before position [i+1] - or [None] if [c] does not occur in [s] before position [i+1]. - - [String.rindex_opt s c] is equivalent to - [String.rindex_from_opt s (String.length s - 1) c]. - - Raise [Invalid_argument] if [i+1] is not a valid position in [s]. - - @since 4.05 -*/ -let rindex_from_opt: (string, int, char) => option - -/** [String.contains s c] tests if character [c] - appears in the string [s]. */ -let contains: (string, char) => bool - -/** [String.contains_from s start c] tests if character [c] - appears in [s] after position [start]. - [String.contains s c] is equivalent to - [String.contains_from s 0 c]. - - Raise [Invalid_argument] if [start] is not a valid position in [s]. */ -let contains_from: (string, int, char) => bool - -/** [String.rcontains_from s stop c] tests if character [c] - appears in [s] before position [stop+1]. - - Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid - position in [s]. */ -let rcontains_from: (string, int, char) => bool - -/** Return a copy of the argument, with all lowercase letters - translated to uppercase, using the US-ASCII character set. - @since 4.05.0 */ -let uppercase_ascii: string => string - -/** Return a copy of the argument, with all uppercase letters - translated to lowercase, using the US-ASCII character set. - @since 4.05.0 */ -let lowercase_ascii: string => string - -/** Return a copy of the argument, with the first character set to uppercase, - using the US-ASCII character set. - @since 4.05.0 */ -let capitalize_ascii: string => string - -/** Return a copy of the argument, with the first character set to lowercase, - using the US-ASCII character set. - @since 4.05.0 */ -let uncapitalize_ascii: string => string - -/** An alias for the type of strings. */ -type t = string - -/** The comparison function for strings, with the same specification as - {!Pervasives.compare}. Along with the type [t], this function [compare] - allows the module [String] to be passed as argument to the functors - {!Set.Make} and {!Map.Make}. */ -let compare: (t, t) => int - -/** The equal function for strings. - @since 4.05.0 */ -let equal: (t, t) => bool - -/** [String.split_on_char sep s] returns the list of all (possibly empty) - substrings of [s] that are delimited by the [sep] character. - - The function's output is specified by the following invariants: - - - The list is not empty. - - Concatenating its elements using [sep] as a separator returns a - string equal to the input ([String.concat (String.make 1 sep) - (String.split_on_char sep s) = s]). - - No string in the result contains the [sep] character. - - @since 4.05.0 -*/ -let split_on_char: (~sep: char, string) => list - -/* The following is for system use only. Do not call directly. */ - -external unsafe_get: (string, int) => char = "%string_unsafe_get" diff --git a/jscomp/stdlib-406/sys.mlp b/jscomp/stdlib-406/sys.mlp deleted file mode 100644 index ca35841..0000000 --- a/jscomp/stdlib-406/sys.mlp +++ /dev/null @@ -1,131 +0,0 @@ -#2 "stdlib/sys.mlp" -(**************************************************************************) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(* WARNING: sys.ml is generated from sys.mlp. DO NOT EDIT sys.ml or - your changes will be lost. -*) - -type backend_type = - | Native - | Bytecode - | Other of string -(* System interface *) - -external get_config: unit -> string * int * bool = "caml_sys_get_config" -external get_argv: unit -> string * string array = "?sys_get_argv" -external big_endian : unit -> bool = "%big_endian" -external word_size : unit -> int = "%word_size" -external int_size : unit -> int = "%int_size" -external max_wosize : unit -> int = "%max_wosize" -external unix : unit -> bool = "%ostype_unix" -external win32 : unit -> bool = "%ostype_win32" -external cygwin : unit -> bool = "%ostype_cygwin" -external get_backend_type : unit -> backend_type = "%backend_type" - -let (executable_name, argv) = get_argv() -let (os_type, _, _) = get_config() -let backend_type = get_backend_type () -let big_endian = big_endian () -let word_size = word_size () -let int_size = int_size () -let unix = unix () -let win32 = win32 () -let cygwin = cygwin () -let max_array_length = max_wosize () -let max_string_length = word_size / 8 * max_array_length - 1 -external runtime_variant : unit -> string = "?runtime_variant" -external runtime_parameters : unit -> string = "?runtime_parameters" - -external file_exists: string -> bool = "?sys_file_exists" -external is_directory : string -> bool = "?sys_is_directory" -external remove: string -> unit = "?sys_remove" -external rename : string -> string -> unit = "?sys_rename" -external getenv: string -> string = "?sys_getenv" - -let getenv_opt s = - (* TODO: expose a non-raising primitive directly. *) - try Some (getenv s) - with Not_found -> None - -external command: string -> int = "caml_sys_system_command" -external time: unit -> (float [@unboxed]) = - "caml_sys_time" "caml_sys_time_unboxed" [@@noalloc] -external chdir: string -> unit = "?sys_chdir" -external getcwd: unit -> string = "?sys_getcwd" -external readdir : string -> string array = "?sys_read_directory" - -let interactive = ref false - -type signal_behavior = - Signal_default - | Signal_ignore - | Signal_handle of (int -> unit) - -external signal : int -> signal_behavior -> signal_behavior - = "caml_install_signal_handler" - -let set_signal sig_num sig_beh = ignore(signal sig_num sig_beh) - -let sigabrt = -1 -let sigalrm = -2 -let sigfpe = -3 -let sighup = -4 -let sigill = -5 -let sigint = -6 -let sigkill = -7 -let sigpipe = -8 -let sigquit = -9 -let sigsegv = -10 -let sigterm = -11 -let sigusr1 = -12 -let sigusr2 = -13 -let sigchld = -14 -let sigcont = -15 -let sigstop = -16 -let sigtstp = -17 -let sigttin = -18 -let sigttou = -19 -let sigvtalrm = -20 -let sigprof = -21 -let sigbus = -22 -let sigpoll = -23 -let sigsys = -24 -let sigtrap = -25 -let sigurg = -26 -let sigxcpu = -27 -let sigxfsz = -28 - -exception Break - -let catch_break on = - if on then - set_signal sigint (Signal_handle(fun _ -> raise Break)) - else - set_signal sigint Signal_default - - -external enable_runtime_warnings: bool -> unit = - "caml_ml_enable_runtime_warnings" -external runtime_warnings_enabled: unit -> bool = - "caml_ml_runtime_warnings_enabled" - -(* The version string is found in file ../VERSION *) - -let ocaml_version = "%%VERSION%%" - -(* Optimization *) - -external opaque_identity : 'a -> 'a = "%opaque" diff --git a/jscomp/stdlib-406/sys.res b/jscomp/stdlib-406/sys.res deleted file mode 100644 index bffe3aa..0000000 --- a/jscomp/stdlib-406/sys.res +++ /dev/null @@ -1,131 +0,0 @@ -@@bs.config({flags: ["-bs-no-cross-module-opt"]}) -/* ************************************************************************ */ -/* */ -/* 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. */ -/* */ -/* ************************************************************************ */ - -/* WARNING: sys.ml is generated from sys.mlp. DO NOT EDIT sys.ml or - your changes will be lost. -*/ - -type backend_type = - | Native - | Bytecode - | Other(string) -/* System interface */ - -external get_argv: unit => (string, array) = "?sys_get_argv" -external big_endian: unit => bool = "%big_endian" -external word_size: unit => int = "%word_size" -external int_size: unit => int = "%int_size" -/* external max_wosize : unit -> int = "%max_wosize" */ -external unix: unit => bool = "%ostype_unix" -external win32: unit => bool = "%ostype_win32" -external cygwin: unit => bool = "%ostype_cygwin" -external get_backend_type: unit => backend_type = "%backend_type" - -let (executable_name, argv) = get_argv() - -external get_os_type: unit => string = "#os_type" -let os_type = get_os_type() -let backend_type = get_backend_type() -let big_endian = big_endian() -let word_size = word_size() -let int_size = int_size() -let unix = unix() -let win32 = win32() -let cygwin = cygwin() - -let max_array_length = 2147483647 /* 2^ 31 - 1 */ -let max_string_length = 2147483647 - -external runtime_variant: unit => string = "?runtime_variant" -external runtime_parameters: unit => string = "?runtime_parameters" - -external file_exists: string => bool = "?sys_file_exists" -external is_directory: string => bool = "?sys_is_directory" -external remove: string => unit = "?sys_remove" -external rename: (string, string) => unit = "?sys_rename" -external getenv: string => string = "?sys_getenv" - -@get_index external getEnv: ('a, string) => option = "" -let getenv_opt = s => - switch %external(process) { - | None => None - | Some(x) => getEnv(x["env"], s) - } - -let command: string => int = _ => 127 -external time: unit => float = "?sys_time" -external chdir: string => unit = "?sys_chdir" -external getcwd: unit => string = "?sys_getcwd" -external readdir: string => array = "?sys_read_directory" - -let interactive = ref(false) - -type signal_behavior = - | Signal_default - | Signal_ignore - | Signal_handle(int => unit) - -let signal: (int, signal_behavior) => signal_behavior = (_, _) => Signal_default - -let set_signal = (sig_num, sig_beh) => ignore(signal(sig_num, sig_beh)) - -let sigabrt = -1 -let sigalrm = -2 -let sigfpe = -3 -let sighup = -4 -let sigill = -5 -let sigint = -6 -let sigkill = -7 -let sigpipe = -8 -let sigquit = -9 -let sigsegv = -10 -let sigterm = -11 -let sigusr1 = -12 -let sigusr2 = -13 -let sigchld = -14 -let sigcont = -15 -let sigstop = -16 -let sigtstp = -17 -let sigttin = -18 -let sigttou = -19 -let sigvtalrm = -20 -let sigprof = -21 -let sigbus = -22 -let sigpoll = -23 -let sigsys = -24 -let sigtrap = -25 -let sigurg = -26 -let sigxcpu = -27 -let sigxfsz = -28 - -exception Break - -let catch_break = on => - if on { - set_signal(sigint, Signal_handle(_ => raise(Break))) - } else { - set_signal(sigint, Signal_default) - } - -let enable_runtime_warnings: bool => unit = _ => () -let runtime_warnings_enabled: unit => bool = _ => false -/* The version string is found in file ../VERSION */ - -let ocaml_version = "4.06.2+BS" - -/* Optimization */ - -external opaque_identity: 'a => 'a = "%opaque" diff --git a/jscomp/stdlib-406/sys.resi b/jscomp/stdlib-406/sys.resi deleted file mode 100644 index 544b643..0000000 --- a/jscomp/stdlib-406/sys.resi +++ /dev/null @@ -1,323 +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. */ -/* */ -/* ************************************************************************ */ - -/*** System interface. - - Every function in this module raises [Sys_error] with an - informative message when the underlying system call signal - an error. -*/ - -/** The command line arguments given to the process. - The first element is the command name used to invoke the program. - The following elements are the command-line arguments - given to the program. */ -let argv: array - -/** The name of the file containing the executable currently running. */ -let executable_name: string - -/** Test if a file with the given name exists. */ -external file_exists: string => bool = "?sys_file_exists" - -/** Returns [true] if the given name refers to a directory, - [false] if it refers to another kind of file. - Raise [Sys_error] if no file exists with the given name. - @since 3.10.0 -*/ -external is_directory: string => bool = "?sys_is_directory" - -/** Remove the given file name from the file system. */ -external remove: string => unit = "?sys_remove" - -/** Rename a file. [rename oldpath newpath] renames the file - called [oldpath], giving it [newpath] as its new name, - moving it between directories if needed. If [newpath] already - exists, its contents will be replaced with those of [oldpath]. - Depending on the operating system, the metadata (permissions, - owner, etc) of [newpath] can either be preserved or be replaced by - those of [oldpath]. - @since 4.06 concerning the "replace existing file" behavior */ -external rename: (string, string) => unit = "?sys_rename" - -/** Return the value associated to a variable in the process - environment. Raise [Not_found] if the variable is unbound. */ -external getenv: string => string = "?sys_getenv" - -/** Return the value associated to a variable in the process - environment or [None] if the variable is unbound. - @since 4.05 -*/ -let getenv_opt: string => option - -/** Execute the given shell command and return its exit code. */ -let command: string => int - -/** Return the processor time, in seconds, used by the program - since the beginning of execution. */ -external time: unit => float = "?sys_time" - -/** Change the current working directory of the process. */ -external chdir: string => unit = "?sys_chdir" - -/** Return the current working directory of the process. */ -external getcwd: unit => string = "?sys_getcwd" - -/** Return the names of all files present in the given directory. - Names denoting the current directory and the parent directory - (["."] and [".."] in Unix) are not returned. Each string in the - result is a file name rather than a complete path. There is no - guarantee that the name strings in the resulting array will appear - in any specific order; they are not, in particular, guaranteed to - appear in alphabetical order. */ -external readdir: string => array = "?sys_read_directory" - -/** This reference is initially set to [false] in standalone - programs and to [true] if the code is being executed under - the interactive toplevel system [ocaml]. */ -let interactive: ref - -/** Operating system currently executing the OCaml program. One of -- ["Unix"] (for all Unix versions, including Linux and Mac OS X), -- ["Win32"] (for MS-Windows, OCaml compiled with MSVC++ or Mingw), -- ["Cygwin"] (for MS-Windows, OCaml compiled with Cygwin). */ -let os_type: string - -/** Currently, the official distribution only supports [Native] and - [Bytecode], but it can be other backends with alternative - compilers, for example, javascript. - - @since 4.04.0 -*/ -type backend_type = - | Native - | Bytecode - | Other(string) - -/** Backend type currently executing the OCaml program. - @since 4.04.0 - */ -let backend_type: backend_type - -/** True if [Sys.os_type = "Unix"]. - @since 4.01.0 */ -let unix: bool - -/** True if [Sys.os_type = "Win32"]. - @since 4.01.0 */ -let win32: bool - -/** True if [Sys.os_type = "Cygwin"]. - @since 4.01.0 */ -let cygwin: bool - -/** Size of one word on the machine currently executing the OCaml - program, in bits: 32 or 64. */ -let word_size: int - -/** Size of an int. It is 31 bits (resp. 63 bits) when using the - OCaml compiler on a 32 bits (resp. 64 bits) platform. It may - differ for other compilers, e.g. it is 32 bits when compiling to - JavaScript. - @since 4.03.0 */ -let int_size: int - -/** Whether the machine currently executing the Caml program is big-endian. - @since 4.00.0 */ -let big_endian: bool - -/** Maximum length of strings and byte sequences. */ -let max_string_length: int - -/** Maximum length of a normal array. The maximum length of a float - array is [max_array_length/2] on 32-bit machines and - [max_array_length] on 64-bit machines. */ -let max_array_length: int - -/** Return the name of the runtime variant the program is running on. - This is normally the argument given to [-runtime-variant] at compile - time, but for byte-code it can be changed after compilation. - @since 4.03.0 */ -external runtime_variant: unit => string = "?runtime_variant" - -/** Return the value of the runtime parameters, in the same format - as the contents of the [OCAMLRUNPARAM] environment variable. - @since 4.03.0 */ -external runtime_parameters: unit => string = "?runtime_parameters" - -/* {1 Signal handling} */ - -/** What to do when receiving a signal: - - [Signal_default]: take the default behavior - (usually: abort the program) - - [Signal_ignore]: ignore the signal - - [Signal_handle f]: call function [f], giving it the signal - number as argument. */ -type signal_behavior = - | Signal_default - | Signal_ignore - | /** */ Signal_handle(int => unit) - -/** Set the behavior of the system on receipt of a given signal. The - first argument is the signal number. Return the behavior - previously associated with the signal. If the signal number is - invalid (or not available on your system), an [Invalid_argument] - exception is raised. */ -let signal: (int, signal_behavior) => signal_behavior - -/** Same as {!Sys.signal} but return value is ignored. */ -let set_signal: (int, signal_behavior) => unit - -/* {2 Signal numbers for the standard POSIX signals.} */ - -/** Abnormal termination */ -let sigabrt: int - -/** Timeout */ -let sigalrm: int - -/** Arithmetic exception */ -let sigfpe: int - -/** Hangup on controlling terminal */ -let sighup: int - -/** Invalid hardware instruction */ -let sigill: int - -/** Interactive interrupt (ctrl-C) */ -let sigint: int - -/** Termination (cannot be ignored) */ -let sigkill: int - -/** Broken pipe */ -let sigpipe: int - -/** Interactive termination */ -let sigquit: int - -/** Invalid memory reference */ -let sigsegv: int - -/** Termination */ -let sigterm: int - -/** Application-defined signal 1 */ -let sigusr1: int - -/** Application-defined signal 2 */ -let sigusr2: int - -/** Child process terminated */ -let sigchld: int - -/** Continue */ -let sigcont: int - -/** Stop */ -let sigstop: int - -/** Interactive stop */ -let sigtstp: int - -/** Terminal read from background process */ -let sigttin: int - -/** Terminal write from background process */ -let sigttou: int - -/** Timeout in virtual time */ -let sigvtalrm: int - -/** Profiling interrupt */ -let sigprof: int - -/** Bus error - @since 4.03 */ -let sigbus: int - -/** Pollable event - @since 4.03 */ -let sigpoll: int - -/** Bad argument to routine - @since 4.03 */ -let sigsys: int - -/** Trace/breakpoint trap - @since 4.03 */ -let sigtrap: int - -/** Urgent condition on socket - @since 4.03 */ -let sigurg: int - -/** Timeout in cpu time - @since 4.03 */ -let sigxcpu: int - -/** File size limit exceeded - @since 4.03 */ -let sigxfsz: int - -/** Exception raised on interactive interrupt if {!Sys.catch_break} - is on. */ exception Break - -/** [catch_break] governs whether interactive interrupt (ctrl-C) - terminates the program or raises the [Break] exception. - Call [catch_break true] to enable raising [Break], - and [catch_break false] to let the system - terminate the program on user interrupt. */ -let catch_break: bool => unit - -/** [ocaml_version] is the version of OCaml. - It is a string of the form ["major.minor[.patchlevel][+additional-info]"], - where [major], [minor], and [patchlevel] are integers, and - [additional-info] is an arbitrary string. The [[.patchlevel]] and - [[+additional-info]] parts may be absent. */ -let ocaml_version: string - -/** Control whether the OCaml runtime system can emit warnings - on stderr. Currently, the only supported warning is triggered - when a channel created by [open_*] functions is finalized without - being closed. Runtime warnings are enabled by default. - - @since 4.03.0 */ -let enable_runtime_warnings: bool => unit - -/** Return whether runtime warnings are currently enabled. - - @since 4.03.0 */ -let runtime_warnings_enabled: unit => bool - -/* {1 Optimization} */ - -/** For the purposes of optimization, [opaque_identity] behaves like an - unknown (and thus possibly side-effecting) function. - - At runtime, [opaque_identity] disappears altogether. - - A typical use of this function is to prevent pure computations from being - optimized away in benchmarking loops. For example: - {[ - for _round = 1 to 100_000 do - ignore (Sys.opaque_identity (my_pure_computation ())) - done - ]} - - @since 4.03.0 -*/ -external opaque_identity: 'a => 'a = "%opaque" diff --git a/jscomp/stdlib-406/uchar.res b/jscomp/stdlib-406/uchar.res deleted file mode 100644 index de27d35..0000000 --- a/jscomp/stdlib-406/uchar.res +++ /dev/null @@ -1,74 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Daniel C. Buenzli */ -/* */ -/* Copyright 2014 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. */ -/* */ -/* ************************************************************************ */ - -external format_int: (string, int) => string = "?format_int" - -let err_no_pred = "U+0000 has no predecessor" -let err_no_succ = "U+10FFFF has no successor" -let err_not_sv = i => format_int("%X", i) ++ " is not an Unicode scalar value" -let err_not_latin1 = u => "U+" ++ (format_int("%04X", u) ++ " is not a latin1 character") - -type t = int - -let min = 0x0000 -let max = 0x10FFFF -let lo_bound = 0xD7FF -let hi_bound = 0xE000 - -let bom = 0xFEFF -let rep = 0xFFFD - -let succ = u => - if u == lo_bound { - hi_bound - } else if u == max { - invalid_arg(err_no_succ) - } else { - u + 1 - } - -let pred = u => - if u == hi_bound { - lo_bound - } else if u == min { - invalid_arg(err_no_pred) - } else { - u - 1 - } - -let is_valid = i => (min <= i && i <= lo_bound) || (hi_bound <= i && i <= max) -let of_int = i => - if is_valid(i) { - i - } else { - invalid_arg(err_not_sv(i)) - } -external unsafe_of_int: int => t = "%identity" -external to_int: t => int = "%identity" - -let is_char = u => u < 256 -let of_char = c => Char.code(c) -let to_char = u => - if u > 255 { - invalid_arg(err_not_latin1(u)) - } else { - Char.unsafe_chr(u) - } - -let unsafe_to_char = Char.unsafe_chr - -let equal: (int, int) => bool = \"=" -let compare: (int, int) => int = Pervasives.compare -let hash = to_int diff --git a/jscomp/stdlib-406/uchar.resi b/jscomp/stdlib-406/uchar.resi deleted file mode 100644 index d837b86..0000000 --- a/jscomp/stdlib-406/uchar.resi +++ /dev/null @@ -1,94 +0,0 @@ -/* ************************************************************************ */ -/* */ -/* OCaml */ -/* */ -/* Daniel C. Buenzli */ -/* */ -/* Copyright 2014 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. */ -/* */ -/* ************************************************************************ */ - -/*** Unicode characters. - - @since 4.03 */ - -/** The type for Unicode characters. - - A value of this type represents an Unicode - {{:http://unicode.org/glossary/#unicode_scalar_value}scalar - value} which is an integer in the ranges [0x0000]...[0xD7FF] or - [0xE000]...[0x10FFFF]. */ -type t - -/** [min] is U+0000. */ -let min: t - -/** [max] is U+10FFFF. */ -let max: t - -/** [bom] is U+FEFF, the - {{:http://unicode.org/glossary/#byte_order_mark}byte order mark} (BOM) - character. - - @since 4.06.0 */ -let bom: t - -/** [rep] is U+FFFD, the - {{:http://unicode.org/glossary/#replacement_character}replacement} - character. - - @since 4.06.0 */ -let rep: t - -/** [succ u] is the scalar value after [u] in the set of Unicode scalar - values. - - @raise Invalid_argument if [u] is {!max}. */ -let succ: t => t - -/** [pred u] is the scalar value before [u] in the set of Unicode scalar - values. - - @raise Invalid_argument if [u] is {!min}. */ -let pred: t => t - -/** [is_valid n] is [true] iff [n] is an Unicode scalar value - (i.e. in the ranges [0x0000]...[0xD7FF] or [0xE000]...[0x10FFFF]).*/ -let is_valid: int => bool - -/** [of_int i] is [i] as an Unicode character. - - @raise Invalid_argument if [i] does not satisfy {!is_valid}. */ -let of_int: int => t - -let unsafe_of_int: int => t - -/** [to_int u] is [u] as an integer. */ -let to_int: t => int - -/** [is_char u] is [true] iff [u] is a latin1 OCaml character. */ -let is_char: t => bool - -/** [of_char c] is [c] as an Unicode character. */ -let of_char: char => t - -/** [to_char u] is [u] as an OCaml latin1 character. - - @raise Invalid_argument if [u] does not satisfy {!is_char}. */ -let to_char: t => char - -let unsafe_to_char: t => char - -/** [equal u u'] is [u = u']. */ -let equal: (t, t) => bool - -/** [compare u u'] is [Pervasives.compare u u']. */ -let compare: (t, t) => int - -/** [hash u] associates a non-negative integer to [u]. */ -let hash: t => int diff --git a/jscomp/syntax/.ocamlformat-ignore b/jscomp/syntax/.ocamlformat-ignore deleted file mode 100644 index 0c4403d..0000000 --- a/jscomp/syntax/.ocamlformat-ignore +++ /dev/null @@ -1 +0,0 @@ -compiler-libs-406/* diff --git a/jscomp/syntax/benchmarks/Benchmark.ml b/jscomp/syntax/benchmarks/Benchmark.ml deleted file mode 100644 index 1a9f3cc..0000000 --- a/jscomp/syntax/benchmarks/Benchmark.ml +++ /dev/null @@ -1,255 +0,0 @@ -module ResParser = Res_core -module Doc = Res_doc -module CommentTable = Res_comments_table -module Parser = Res_parser -module Printer = Res_printer - -module IO : sig - val readFile : string -> string -end = struct - (* random chunk size: 2^15, TODO: why do we guess randomly? *) - let chunkSize = 32768 - - let readFile filename = - let chan = open_in filename in - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = - try input chan chunk 0 chunkSize with Invalid_argument _ -> 0 - in - if len == 0 then ( - close_in_noerr chan; - Buffer.contents buffer) - else ( - Buffer.add_subbytes buffer chunk 0 len; - loop ()) - in - loop () -end - -module Time : sig - type t - - val now : unit -> t - - val toUint64 : t -> int64 [@@live] - - (* let of_uint64_ns ns = ns *) - - val nanosecond : t [@@live] - val microsecond : t [@@live] - val millisecond : t [@@live] - val second : t [@@live] - val minute : t [@@live] - val hour : t [@@live] - - val zero : t - - val diff : t -> t -> t - val add : t -> t -> t - val print : t -> float -end = struct - (* nanoseconds *) - type t = int64 - - let zero = 0L - - let toUint64 s = s - - let nanosecond = 1L - let microsecond = Int64.mul 1000L nanosecond - let millisecond = Int64.mul 1000L microsecond - let second = Int64.mul 1000L millisecond - let minute = Int64.mul 60L second - let hour = Int64.mul 60L minute - - (* TODO: we could do this inside caml_absolute_time *) - external init : unit -> unit = "caml_mach_initialize" - let () = init () - external now : unit -> t = "caml_mach_absolute_time" - - let diff t1 t2 = Int64.sub t2 t1 - let add t1 t2 = Int64.add t1 t2 - let print t = Int64.to_float t *. 1e-6 -end - -module Benchmark : sig - type t - - val make : name:string -> f:(t -> unit) -> unit -> t - val launch : t -> unit - val report : t -> unit -end = struct - type t = { - name: string; - mutable start: Time.t; - mutable n: int; (* current iterations count *) - mutable duration: Time.t; - benchFunc: t -> unit; - mutable timerOn: bool; - (* mutable result: benchmarkResult; *) - (* The initial states *) - mutable startAllocs: float; - mutable startBytes: float; - (* The net total of this test after being run. *) - mutable netAllocs: float; - mutable netBytes: float; - } - - let report b = - print_endline (Format.sprintf "Benchmark: %s" b.name); - print_endline (Format.sprintf "Nbr of iterations: %d" b.n); - print_endline - (Format.sprintf "Benchmark ran during: %fms" (Time.print b.duration)); - print_endline - (Format.sprintf "Avg time/op: %fms" - (Time.print b.duration /. float_of_int b.n)); - print_endline - (Format.sprintf "Allocs/op: %d" - (int_of_float (b.netAllocs /. float_of_int b.n))); - print_endline - (Format.sprintf "B/op: %d" - (int_of_float (b.netBytes /. float_of_int b.n))); - - (* return (float64(r.Bytes) * float64(r.N) / 1e6) / r.T.Seconds() *) - print_newline (); - () - - let make ~name ~f () = - { - name; - start = Time.zero; - n = 0; - benchFunc = f; - duration = Time.zero; - timerOn = false; - startAllocs = 0.; - startBytes = 0.; - netAllocs = 0.; - netBytes = 0.; - } - - (* total amount of memory allocated by the program since it started in words *) - let mallocs () = - let stats = Gc.quick_stat () in - stats.minor_words +. stats.major_words -. stats.promoted_words - - let startTimer b = - if not b.timerOn then ( - let allocatedWords = mallocs () in - b.startAllocs <- allocatedWords; - b.startBytes <- allocatedWords *. 8.; - b.start <- Time.now (); - b.timerOn <- true) - - let stopTimer b = - if b.timerOn then ( - let allocatedWords = mallocs () in - let diff = Time.diff b.start (Time.now ()) in - b.duration <- Time.add b.duration diff; - b.netAllocs <- b.netAllocs +. (allocatedWords -. b.startAllocs); - b.netBytes <- b.netBytes +. ((allocatedWords *. 8.) -. b.startBytes); - b.timerOn <- false) - - let resetTimer b = - if b.timerOn then ( - let allocatedWords = mallocs () in - b.startAllocs <- allocatedWords; - b.netAllocs <- allocatedWords *. 8.; - b.start <- Time.now ()); - b.netAllocs <- 0.; - b.netBytes <- 0. - - let runIteration b n = - Gc.full_major (); - b.n <- n; - resetTimer b; - startTimer b; - b.benchFunc b; - stopTimer b - - let launch b = - (* 150 runs * all the benchmarks means around 1m of benchmark time *) - for n = 1 to 150 do - runIteration b n - done -end - -module Benchmarks : sig - val run : unit -> unit -end = struct - type action = Parse | Print - let string_of_action action = - match action with - | Parse -> "parser" - | Print -> "printer" - - (* TODO: we could at Reason here *) - type lang = Ocaml | Rescript - let string_of_lang lang = - match lang with - | Ocaml -> "ocaml" - | Rescript -> "rescript" - - let parseOcaml src filename = - let lexbuf = Lexing.from_string src in - Location.init lexbuf filename; - Parse.implementation lexbuf - - let parseRescript src filename = - let p = Parser.make src filename in - let structure = ResParser.parseImplementation p in - assert (p.diagnostics == []); - structure - - let benchmark filename lang action = - let src = IO.readFile filename in - let name = - filename ^ " " ^ string_of_lang lang ^ " " ^ string_of_action action - in - let benchmarkFn = - match (lang, action) with - | Rescript, Parse -> - fun _ -> - let _ = Sys.opaque_identity (parseRescript src filename) in - () - | Ocaml, Parse -> - fun _ -> - let _ = Sys.opaque_identity (parseOcaml src filename) in - () - | Rescript, Print -> - let p = Parser.make src filename in - let ast = ResParser.parseImplementation p in - fun _ -> - let _ = - Sys.opaque_identity - (let cmtTbl = CommentTable.make () in - let comments = List.rev p.Parser.comments in - let () = CommentTable.walkStructure ast cmtTbl comments in - Doc.toString ~width:80 (Printer.printStructure ast cmtTbl)) - in - () - | _ -> fun _ -> () - in - let b = Benchmark.make ~name ~f:benchmarkFn () in - Benchmark.launch b; - Benchmark.report b - - let run () = - let dataDir = "jscomp/syntax/benchmarks/data" in - benchmark (Filename.concat dataDir "RedBlackTree.res") Rescript Parse; - benchmark (Filename.concat dataDir "RedBlackTree.ml") Ocaml Parse; - benchmark (Filename.concat dataDir "RedBlackTree.res") Rescript Print; - benchmark - (Filename.concat dataDir "RedBlackTreeNoComments.res") - Rescript Print; - benchmark (Filename.concat dataDir "Napkinscript.res") Rescript Parse; - benchmark (Filename.concat dataDir "Napkinscript.ml") Ocaml Parse; - benchmark (Filename.concat dataDir "Napkinscript.res") Rescript Print; - benchmark (Filename.concat dataDir "HeroGraphic.res") Rescript Parse; - benchmark (Filename.concat dataDir "HeroGraphic.ml") Ocaml Parse; - benchmark (Filename.concat dataDir "HeroGraphic.res") Rescript Print -end - -let () = Benchmarks.run () diff --git a/jscomp/syntax/benchmarks/data/HeroGraphic.ml b/jscomp/syntax/benchmarks/data/HeroGraphic.ml deleted file mode 100644 index 08feb30..0000000 --- a/jscomp/syntax/benchmarks/data/HeroGraphic.ml +++ /dev/null @@ -1,8654 +0,0 @@ -;;[%bs.raw {|require('./HeroGraphic.css')|}] -let make ?(width= "760") ?(height= "380") = - ((svg ~width:((width)) ~height:((height)) - ~viewBox:(("0 0 758 381")) ~fill:(("none") - ) ~xmlns:(("http://www.w3.org/2000/svg") - ) - ~children:[((path - ~d:(("M78.8374 255.364H664.923C664.923 255.364 677.451 256.743 677.451 270.971C677.451 285.2 667.673 288.178 667.673 288.178H579.485C579.485 288.178 592.014 290.163 592.014 304.888C592.014 319.612 582.785 321.101 582.785 321.101H524.544C524.544 321.101 507.676 322.59 508.776 333.896C509.876 345.201 520.204 346.194 520.204 346.194H626.849C626.849 346.194 644.266 347.683 643.166 363.897C642.066 380.11 632.288 380.11 632.288 380.11H186.032C186.032 380.11 166.964 379.118 167.514 364.393C168.064 349.668 186.582 350.661 186.582 350.661H121.801C121.801 350.661 104.628 351.598 104.628 338.252C104.628 320.715 121.862 322.149 121.862 322.149H142.457C142.457 322.149 159.264 323.362 159.264 306.101C159.264 293.748 144.657 292.7 144.657 292.7H77.6151C77.6151 292.7 56.4084 290.439 56.4695 275.769C56.5918 260.879 66.3089 255.364 78.8374 255.364Z") - ) ~fill:(("#0B1627")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.57")) - ~d:(("M393.453 244.555C393.453 244.555 398.709 220.841 391.437 205.344C384.103 189.848 369.68 187.145 369.68 187.145C366.991 161.722 351.59 142.916 317.794 145.288C283.998 147.714 270.614 166.134 270.614 166.134C270.614 166.134 274.342 158.358 267.925 150.251C261.508 142.144 247.757 143.799 247.757 143.799C247.757 143.799 253.502 135.14 241.646 128.578C229.79 122.015 220.378 126.868 220.378 126.868C220.378 126.868 226.55 103.595 203.572 99.1834C180.593 94.7163 163.542 110.379 163.542 110.379C163.542 110.379 153.641 104.753 138.852 109.441C124.001 114.184 122.717 134.203 122.717 134.203C122.717 134.203 90.5713 118.541 55.675 137.457C31.5349 150.527 27.2569 178.377 26.9514 194.425C32.9406 207.495 40.152 215.547 40.152 215.547C31.5349 242.349 51.886 248.14 51.886 248.14H90.0824H358.496L393.453 244.555Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-cloudLeft") - ) ~opacity:(("0.7")) - ~d:(("M0.4885 96.7017H97.599C97.599 96.7017 99.0047 89.1463 88.6152 87.8779C88.6152 87.8779 87.393 74.4216 72.6644 69.6237C57.9359 64.8258 51.2133 72.2157 51.2133 72.2157C51.2133 72.2157 46.6909 67.3075 40.8239 68.0244C34.8958 68.7413 32.4513 75.5246 32.4513 75.5246C32.4513 75.5246 28.9677 73.3187 25.3009 75.1386C21.634 76.9585 21.8174 79.385 21.8174 79.385C21.8174 79.385 17.6005 78.4475 14.6059 78.282C11.6113 78.0615 -2.75056 78.999 0.4885 96.7017Z") - ) ~fill:(("white")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M326.044 228.066H250.141V241.246H326.044V228.066Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M331.606 228.066H291.759V240.198H331.606V228.066Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M432.811 224.15H375.303V240.915H432.811V224.15Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M382.514 226.466H378.419V227.128H382.514V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M389.053 226.466H384.959V227.128H389.053V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M395.531 226.466H391.437V227.128H395.531V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M402.009 226.466H397.915V227.128H402.009V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M408.488 226.466H404.393V227.128H408.488V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M414.966 226.466H410.871V227.128H414.966V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M421.444 226.466H417.349V227.128H421.444V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M427.983 226.466H423.888V227.128H427.983V226.466Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M382.514 228.727H378.419V229.389H382.514V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M389.053 228.727H384.959V229.389H389.053V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M395.531 228.727H391.437V229.389H395.531V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M402.009 228.727H397.915V229.389H402.009V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M408.488 228.727H404.393V229.389H408.488V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M414.966 228.727H410.871V229.389H414.966V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M421.444 228.727H417.349V229.389H421.444V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M427.983 228.727H423.888V229.389H427.983V228.727Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M382.514 230.988H378.419V231.65H382.514V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M389.053 230.988H384.959V231.65H389.053V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M395.531 230.988H391.437V231.65H395.531V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M402.009 230.988H397.915V231.65H402.009V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M408.488 230.988H404.393V231.65H408.488V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M414.966 230.988H410.871V231.65H414.966V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M421.444 230.988H417.349V231.65H421.444V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M427.983 230.988H423.888V231.65H427.983V230.988Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M382.514 233.25H378.419V233.911H382.514V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M389.053 233.25H384.959V233.911H389.053V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M395.531 233.25H391.437V233.911H395.531V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M402.009 233.25H397.915V233.911H402.009V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M408.488 233.25H404.393V233.911H408.488V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M414.966 233.25H410.871V233.911H414.966V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M421.444 233.25H417.349V233.911H421.444V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M427.983 233.25H423.888V233.911H427.983V233.25Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M382.514 235.511H378.419V236.172H382.514V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M389.053 235.511H384.959V236.172H389.053V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M395.531 235.511H391.437V236.172H395.531V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M402.009 235.511H397.915V236.172H402.009V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M408.488 235.511H404.393V236.172H408.488V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M414.966 235.511H410.871V236.172H414.966V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M421.444 235.511H417.349V236.172H421.444V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M427.983 235.511H423.888V236.172H427.983V235.511Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M378.969 224.15H375.303V240.915H378.969V224.15Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 221.999H171.181V225.032H178.087V221.999Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 221.999H179.92V225.032H186.826V221.999Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 221.999H188.66V225.032H195.566V221.999Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 226.411H171.181V229.444H178.087V226.411Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 226.411H179.92V229.444H186.826V226.411Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 226.411H188.66V229.444H195.566V226.411Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M160.914 230.933H112.206V244.555H160.914V230.933Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 220.234H115.689V221.779H117.4V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 220.234H120.701V221.779H122.412V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 220.234H125.651V221.779H127.362V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 220.234H130.601V221.779H132.312V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 220.234H135.551V221.779H137.263V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 220.234H140.563V221.779H142.274V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 220.234H145.513V221.779H147.224V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 220.234H150.463V221.779H152.174V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 220.234H155.413V221.779H157.125V220.234Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 223.819H115.689V225.363H117.4V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 223.819H120.701V225.363H122.412V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 223.819H125.651V225.363H127.362V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 223.819H130.601V225.363H132.312V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 223.819H135.551V225.363H137.263V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 223.819H140.563V225.363H142.274V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 223.819H145.513V225.363H147.224V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 223.819H150.463V225.363H152.174V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 223.819H155.413V225.363H157.125V223.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 227.459H115.689V229.003H117.4V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 227.459H120.701V229.003H122.412V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 227.459H125.651V229.003H127.362V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 227.459H130.601V229.003H132.312V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 227.459H135.551V229.003H137.263V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 227.459H140.563V229.003H142.274V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 227.459H145.513V229.003H147.224V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 227.459H150.463V229.003H152.174V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 227.459H155.413V229.003H157.125V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-wave")) - ~d:(("M81.5264 248.14H667.612C667.612 248.14 680.14 249.518 680.14 263.747C680.14 277.975 670.362 280.953 670.362 280.953H582.174C582.174 280.953 594.703 282.939 594.703 297.663C594.703 312.388 585.474 313.877 585.474 313.877H527.233C527.233 313.877 510.365 315.366 511.465 326.671C512.565 337.977 522.893 338.969 522.893 338.969H629.538C629.538 338.969 646.955 340.458 645.855 356.672C644.755 372.886 634.977 372.886 634.977 372.886H188.721C188.721 372.886 169.653 371.893 170.203 357.168C170.753 342.444 189.271 343.436 189.271 343.436H124.49C124.49 343.436 107.317 344.374 107.317 331.028C107.317 313.491 124.551 314.925 124.551 314.925H145.146C145.146 314.925 161.953 316.138 161.953 298.876C161.953 286.523 147.346 285.475 147.346 285.475H80.3041C80.3041 285.475 59.0975 283.214 59.1586 268.545C59.2808 253.655 68.998 248.14 81.5264 248.14Z") - ) ~fill:(("url(#paint0_linear)") - ) ~fillOpacity:(("0.7") - ) ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.66")) - ~d:(("M112.206 248.14V285.365H147.408C147.408 285.365 151.869 285.696 155.841 288.067H160.914V274.39L169.592 269.923V268.655H181.998H199.477V264.464H201.066V273.949L205.527 274.28V284.979V285.641H203.571V287.35H228.751H252.096V285.641H250.141V284.979V277.424L265.419 278.527H274.831V264.298H279.048V273.674H291.393V286.799H291.82V298.38V299.704H297.26V303.013H300.804V312.002H301.904V303.013H303.31V312.002H304.41V303.013H318.222V312.002H319.322V303.013H320.727V312.002H321.828V303.013H326.228V299.704H331.667V298.38V286.799H341.812V273.839H354.707V273.949H354.89V287.24H390.948V282.497H396.265V290.935H401.948V306.763L405.798 306.983L406.349 307.038L412.582 307.424H412.704L414.966 307.59L415.821 307.645L417.349 307.755L418.205 307.81L419.733 307.921L420.588 307.976L425.233 308.252V304.998H432.933V278.747H439.472L445.034 282.938V293.692H475.285V276.155H508.47V287.295H544.528V282.552H550.639V294.575V295.126H559.806V295.568V297.222H564.757V304.722H566.529V297.167H569.707V295.512V295.071H571.418V308.362H592.319C593.725 305.935 594.703 302.516 594.703 297.608C594.703 282.883 582.174 280.898 582.174 280.898H635.894V248.085H112.206V248.14Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.5")) - ~d:(("M125.712 326.34V326.782H126.14V326.34H129.073L130.54 339.19V339.025L131.885 326.34H134.879L136.346 339.19L137.69 326.34H140.379V326.782H140.929V326.34H141.235V326.23H140.929V321.984H144.169V314.87H124.673C124.673 314.87 123.817 314.814 122.412 314.87V321.929H125.773V326.175V326.34H125.712ZM138.118 321.929H140.379V326.175H137.69L138.118 321.929ZM132.312 321.929H134.329L134.818 326.175H131.823L132.312 321.929ZM126.079 321.929H128.523L129.012 326.175H126.14V321.929H126.079Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M552.717 270.806C552.717 272.57 551.128 274.06 549.111 274.06H480.358C478.402 274.06 476.752 272.626 476.752 270.806C476.752 269.041 478.341 267.552 480.358 267.552H549.173C551.128 267.552 552.717 269.041 552.717 270.806Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M165.008 261.1C165.008 262.313 163.97 263.25 162.625 263.25H153.458C152.113 263.25 151.074 262.313 151.074 261.1C151.074 259.886 152.113 258.949 153.458 258.949H162.625C163.97 258.949 165.008 259.941 165.008 261.1Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M226.673 263.25C226.673 264.464 225.634 265.401 224.289 265.401H192.449C191.104 265.401 190.065 264.464 190.065 263.25C190.065 262.037 191.104 261.1 192.449 261.1H224.289C225.573 261.1 226.673 262.092 226.673 263.25Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M376.036 297.553C376.036 298.27 375.425 298.821 374.63 298.821H361.613C360.819 298.821 360.207 298.27 360.207 297.553C360.207 296.836 360.819 296.284 361.613 296.284H374.63C375.425 296.284 376.036 296.836 376.036 297.553Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-wave")) - ~d:(("M391.681 296.836C391.681 295.733 392.659 294.85 393.881 294.85H479.747C480.969 294.85 481.947 295.733 481.947 296.836C481.947 297.939 480.969 298.821 479.747 298.821H393.881C392.659 298.766 391.681 297.884 391.681 296.836Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M208.4 296.174C208.4 296.891 207.727 297.498 206.933 297.498H194.343C193.549 297.498 192.877 296.891 192.877 296.174C192.877 295.457 193.549 294.85 194.343 294.85H206.872C207.727 294.85 208.4 295.457 208.4 296.174Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-wave")) - ~d:(("M309.788 324.631C309.788 326.009 308.566 327.168 306.977 327.168H236.634C235.106 327.168 233.823 326.065 233.823 324.631C233.823 323.252 235.045 322.094 236.634 322.094H307.038C308.505 322.094 309.788 323.252 309.788 324.631Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M372.186 328.932C372.186 329.925 371.269 330.752 370.169 330.752H355.074C353.974 330.752 353.057 329.925 353.057 328.932C353.057 327.94 353.974 327.112 355.074 327.112H370.169C371.33 327.112 372.186 327.94 372.186 328.932Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M537.255 360.863C537.255 360.477 537.622 360.146 538.05 360.146H551.984C552.412 360.146 552.778 360.477 552.778 360.863C552.778 361.249 552.412 361.58 551.984 361.58H538.05C537.561 361.58 537.255 361.249 537.255 360.863Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M224.656 359.816C224.656 358.823 223.739 357.996 222.639 357.996H212.678C211.578 357.996 210.661 358.823 210.661 359.816C210.661 360.808 211.578 361.635 212.678 361.635H222.639C223.8 361.58 224.656 360.753 224.656 359.816Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M151.136 332.517C151.136 331.524 150.219 330.697 149.119 330.697H141.968C140.868 330.697 139.952 331.524 139.952 332.517C139.952 333.51 140.868 334.337 141.968 334.337H149.119C150.219 334.337 151.136 333.51 151.136 332.517Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M250.202 228.066H205.649V241.246H250.202V228.066Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M630.149 117.052H611.326V120.802H630.149V117.052Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M630.149 119.588H611.326V120.857H630.149V119.588Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M199.538 230.933H160.914V240.529H199.538V230.933Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M339.795 222.606H337.473V224.702H339.795V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M345.234 222.606H342.912V224.702H345.234V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M350.673 222.606H348.351V224.702H350.673V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M356.052 222.606H353.79V224.702H356.052V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M361.552 222.606H359.229V224.702H361.552V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M366.991 222.606H364.669V224.702H366.991V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M372.43 222.606H370.108V224.702H372.43V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 221.007H478.769V222.661H480.175V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 221.007H482.13V222.661H483.536V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 221.007H485.43V222.661H486.836V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 221.007H488.792V222.661H490.197V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.497 221.007H492.092V222.661H493.497V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 221.007H495.453V222.661H496.859V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 221.007H498.814V222.661H500.22V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 221.007H501.931V222.661H503.337V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 221.007H506.087V222.661H507.493V221.007Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 224.26H478.769V225.915H480.175V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M483.536 224.26H482.13V225.915H483.536V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M486.836 224.26H485.43V225.915H486.836V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 224.26H488.792V225.915H490.197V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.497 224.26H492.092V225.915H493.497V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 224.26H495.453V225.915H496.859V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M500.22 224.26H498.814V225.915H500.22V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 224.26H501.931V225.915H503.337V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 224.26H506.087V225.915H507.493V224.26Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 227.569H478.769V229.224H480.175V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 227.569H482.13V229.224H483.536V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 227.569H485.43V229.224H486.836V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 227.569H488.792V229.224H490.197V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.497 227.569H492.092V229.224H493.497V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 227.569H495.453V229.224H496.859V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 227.569H498.814V229.224H500.22V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 227.569H501.931V229.224H503.337V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 227.569H506.087V229.224H507.493V227.569Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 230.878H478.769V232.533H480.175V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 230.878H482.13V232.533H483.536V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 230.878H485.43V232.533H486.836V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 230.878H488.792V232.533H490.197V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.497 230.878H492.092V232.533H493.497V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 230.878H495.453V232.533H496.859V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 230.878H498.814V232.533H500.22V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 230.878H501.931V232.533H503.337V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 230.878H506.087V232.533H507.493V230.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 234.132H478.769V235.786H480.175V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 234.132H482.13V235.786H483.536V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 234.132H485.43V235.786H486.836V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 234.132H488.792V235.786H490.197V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.497 234.132H492.092V235.786H493.497V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 234.132H495.453V235.786H496.859V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 234.132H498.814V235.786H500.22V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 234.132H501.931V235.786H503.337V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 234.132H506.087V235.786H507.493V234.132Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M339.795 228.01H337.473V230.106H339.795V228.01Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M345.234 228.01H342.912V230.106H345.234V228.01Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M350.673 228.01H348.351V230.106H350.673V228.01Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M356.052 228.01H353.79V230.106H356.052V228.01Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M361.552 228.01H359.229V230.106H361.552V228.01Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M366.991 228.01H364.669V230.106H366.991V228.01Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M372.43 228.01H370.108V230.106H372.43V228.01Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M267.925 236.228H266.519V237.496H267.925V236.228Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M271.286 236.228H269.88V237.496H271.286V236.228Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M274.586 236.228H273.181V237.496H274.586V236.228Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M277.886 236.228H276.481V237.496H277.886V236.228Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M281.187 236.228H279.781V237.496H281.187V236.228Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M284.487 236.228H283.081V237.496H284.487V236.228Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M287.787 236.228H286.381V237.496H287.787V236.228Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M375.303 228.066H334.173V240.253H375.303V228.066Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.3")) - ~d:(("M432.811 228.066H375.303V240.253H432.811V228.066Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M444.362 220.4H434.767V223.819H444.362V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M454.69 220.4H445.095V223.819H454.69V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M464.957 220.4H455.362V223.819H464.957V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M475.224 220.4H465.629V223.819H475.224V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 224.536H434.767V227.955H444.362V224.536Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M454.69 224.536H445.095V227.955H454.69V224.536Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 224.536H455.362V227.955H464.957V224.536Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 224.536H465.629V227.955H475.224V224.536Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 228.672H434.767V232.091H444.362V228.672Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M454.69 228.672H445.095V232.091H454.69V228.672Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 228.672H455.362V232.091H464.957V228.672Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 228.672H465.629V232.091H475.224V228.672Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 231.54H434.767V234.959H444.362V231.54Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M454.69 231.54H445.095V234.959H454.69V231.54Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 231.54H455.362V234.959H464.957V231.54Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 231.54H465.629V234.959H475.224V231.54Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.3")) - ~d:(("M476.141 228.01H432.628V241.081H476.141V228.01Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M509.998 230.713H476.08V240.474H509.998V230.713Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.4")) - ~d:(("M548.867 230.713H514.949V240.474H548.867V230.713Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.7")) - ~d:(("M603.809 230.713H578.569V240.474H603.809V230.713Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M128.401 75.3592L130.479 36.0934L132.374 75.3592H128.401Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.477 36.4794V36.0934L128.461 75.3592H128.95C129.744 75.1386 130.539 74.8628 130.539 74.8628V36.4794H130.477Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.207 75.3592L136.285 36.0934L138.179 75.3592H134.207Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.283 36.4794V36.0934L134.266 75.3592H134.755C135.55 75.1386 136.344 74.8628 136.344 74.8628V36.4794H136.283Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.14 62.8405H125.712V73.7599H126.14V62.8405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M140.868 62.8405H140.318V73.7599H140.868V62.8405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M141.174 63.778H125.712V64.0538H141.174V63.778Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M144.107 73.3187H122.351V105.801H144.107V73.3187Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M125.284 75.3592H124.001V76.5173H125.284V75.3592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M128.157 75.3592H126.873V76.5173H128.157V75.3592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.968 75.3592H129.684V76.5173H130.968V75.3592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.84 75.3592H132.557V76.5173H133.84V75.3592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.713 75.3592H135.429V76.5173H136.713V75.3592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.585 75.3592H138.302V76.5173H139.585V75.3592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.457 75.3592H141.174V76.5173H142.457V75.3592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M125.284 77.2343H124.001V78.3924H125.284V77.2343Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M128.157 77.2343H126.873V78.3924H128.157V77.2343Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.968 77.2343H129.684V78.3924H130.968V77.2343Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.84 77.2343H132.557V78.3924H133.84V77.2343Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.713 77.2343H135.429V78.3924H136.713V77.2343Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.585 77.2343H138.302V78.3924H139.585V77.2343Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.457 77.2343H141.174V78.3924H142.457V77.2343Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 79.2747H124.001V79.8262H124.612V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 79.2747H126.506V79.8262H127.118V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 79.2747H129.073V79.8262H129.684V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 79.2747H131.64V79.8262H132.251V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 79.2747H134.146V79.8262H134.757V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 79.2747H136.712V79.8262H137.324V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 79.2747H139.279V79.8262H139.891V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 79.2747H141.785V79.8262H142.396V79.2747Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 81.7564H124.001V82.3079H124.612V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 81.7564H126.506V82.3079H127.118V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 81.7564H129.073V82.3079H129.684V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 81.7564H131.64V82.3079H132.251V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 81.7564H134.146V82.3079H134.757V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 81.7564H136.712V82.3079H137.324V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 81.7564H139.279V82.3079H139.891V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 81.7564H141.785V82.3079H142.396V81.7564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 84.2381H124.001V84.7896H124.612V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 84.2381H126.506V84.7896H127.118V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 84.2381H129.073V84.7896H129.684V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 84.2381H131.64V84.7896H132.251V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 84.2381H134.146V84.7896H134.757V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 84.2381H136.712V84.7896H137.324V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 84.2381H139.279V84.7896H139.891V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 84.2381H141.785V84.7896H142.396V84.2381Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 86.6647H124.001V87.2162H124.612V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 86.6647H126.506V87.2162H127.118V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 86.6647H129.073V87.2162H129.684V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 86.6647H131.64V87.2162H132.251V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 86.6647H134.146V87.2162H134.757V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 86.6647H136.712V87.2162H137.324V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 86.6647H139.279V87.2162H139.891V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 86.6647H141.785V87.2162H142.396V86.6647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 89.1464H124.001V89.6978H124.612V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 89.1464H126.506V89.6978H127.118V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 89.1464H129.073V89.6978H129.684V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 89.1464H131.64V89.6978H132.251V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 89.1464H134.146V89.6978H134.757V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 89.1464H136.712V89.6978H137.324V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 89.1464H139.279V89.6978H139.891V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 89.1464H141.785V89.6978H142.396V89.1464Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 91.628H124.001V92.1795H124.612V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 91.628H126.506V92.1795H127.118V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 91.628H129.073V92.1795H129.684V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M132.251 91.628H131.64V92.1795H132.251V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 91.628H134.146V92.1795H134.757V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 91.628H136.712V92.1795H137.324V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 91.628H139.279V92.1795H139.891V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 91.628H141.785V92.1795H142.396V91.628Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 94.1097H124.001V94.6612H124.612V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 94.1097H126.506V94.6612H127.118V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 94.1097H129.073V94.6612H129.684V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 94.1097H131.64V94.6612H132.251V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 94.1097H134.146V94.6612H134.757V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 94.1097H136.712V94.6612H137.324V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 94.1097H139.279V94.6612H139.891V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 94.1097H141.785V94.6612H142.396V94.1097Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 96.5914H124.001V97.1429H124.612V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 96.5914H126.506V97.1429H127.118V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 96.5914H129.073V97.1429H129.684V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 96.5914H131.64V97.1429H132.251V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 96.5914H134.146V97.1429H134.757V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 96.5914H136.712V97.1429H137.324V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 96.5914H139.279V97.1429H139.891V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 96.5914H141.785V97.1429H142.396V96.5914Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 99.0731H124.001V99.6246H124.612V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 99.0731H126.506V99.6246H127.118V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 99.0731H129.073V99.6246H129.684V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 99.0731H131.64V99.6246H132.251V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 99.0731H134.146V99.6246H134.757V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 99.0731H136.712V99.6246H137.324V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 99.0731H139.279V99.6246H139.891V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 99.0731H141.785V99.6246H142.396V99.0731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 101.279H124.001V101.831H124.612V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.118 101.279H126.506V101.831H127.118V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M129.684 101.279H129.073V101.831H129.684V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.251 101.279H131.64V101.831H132.251V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.757 101.279H134.146V101.831H134.757V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.324 101.279H136.712V101.831H137.324V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.891 101.279H139.279V101.831H139.891V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.396 101.279H141.785V101.831H142.396V101.279Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M144.107 99.1833H122.351V105.746H144.107V99.1833Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M301.904 94.7715H300.804V115.618H301.904V94.7715Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M304.349 94.7715H303.249V115.618H304.349V94.7715Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M319.261 94.7715H318.161V115.618H319.261V94.7715Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M321.766 94.7715H320.666V115.618H321.766V94.7715Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M326.167 114.184H297.26V121.353H326.167V114.184Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M323.722 119.588H299.521V120.305H323.722V119.588Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.707 197.348H201.066V176.833L265.419 167.016H274.831V197.789H278.987V177.494H291.332V149.148H341.751V177.053H354.829V148.1H390.887V158.358H400.787L408.671 169.718V178.818H417.777V166.575H458.54V240.143H133.535L139.707 197.348Z") - ) ~fill:(("#21477C")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M293.287 197.348H354.646V176.833L418.999 167.016H428.411V197.789H432.567V177.494L444.912 157.586V134.203H475.163V172.035H508.409V148.1H544.467V158.358H554.306L562.251 169.718V178.818H571.357V102.492H612.976V240.143H287.115L293.287 197.348Z") - ) ~fill:(("#1B3B68")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M425.172 241.522H401.887V106.077L425.172 102.878V241.522Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M401.887 140.269H396.204V241.522H401.887V140.269Z") - ) ~fill:(("#1073AA")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M432.872 109.937H425.172V241.522H432.872V109.937Z") - ) ~fill:(("#1073AA")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.226 105.47L405.371 105.581V121.298H406.226V105.47Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M410.993 104.809L410.138 104.919V121.298H410.993V104.809Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M408.61 105.139L407.754 105.25V121.298H408.61V105.139Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.377 104.478L412.46 104.588V121.298H413.377V104.478Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M415.76 104.147L414.844 104.257V121.298H415.76V104.147Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M419.61 103.595V121.298H420.527V103.485L419.61 103.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M418.144 103.816L417.227 103.926V121.298H418.144V103.816Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 128.081H403.415V129.129H406.043V128.081Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 128.081H406.96V129.129H409.588V128.081Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 128.081H410.504V129.129H413.132V128.081Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 128.081H414.049V129.129H416.677V128.081Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 128.081H417.594V129.129H420.222V128.081Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 128.081H421.138V129.129H423.766V128.081Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 130.453H403.415V131.501H406.043V130.453Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 130.453H406.96V131.501H409.588V130.453Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 130.453H410.504V131.501H413.132V130.453Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 130.453H414.049V131.501H416.677V130.453Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 130.453H417.594V131.501H420.222V130.453Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 130.453H421.138V131.501H423.766V130.453Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 132.824H403.415V133.872H406.043V132.824Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 132.824H406.96V133.872H409.588V132.824Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 132.824H410.504V133.872H413.132V132.824Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 132.824H414.049V133.872H416.677V132.824Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 132.824H417.594V133.872H420.222V132.824Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 132.824H421.138V133.872H423.766V132.824Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 135.14H403.415V136.188H406.043V135.14Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M409.588 135.14H406.96V136.188H409.588V135.14Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 135.14H410.504V136.188H413.132V135.14Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 135.14H414.049V136.188H416.677V135.14Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 135.14H417.594V136.188H420.222V135.14Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 135.14H421.138V136.188H423.766V135.14Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 137.512H403.415V138.56H406.043V137.512Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 137.512H406.96V138.56H409.588V137.512Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 137.512H410.504V138.56H413.132V137.512Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 137.512H414.049V138.56H416.677V137.512Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 137.512H417.594V138.56H420.222V137.512Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 137.512H421.138V138.56H423.766V137.512Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 139.828H403.415V140.876H406.043V139.828Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 139.828H406.96V140.876H409.588V139.828Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 139.828H410.504V140.876H413.132V139.828Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 139.828H414.049V140.876H416.677V139.828Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 139.828H417.594V140.876H420.222V139.828Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 139.828H421.138V140.876H423.766V139.828Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 142.199H403.415V143.247H406.043V142.199Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 142.199H406.96V143.247H409.588V142.199Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 142.199H410.504V143.247H413.132V142.199Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 142.199H414.049V143.247H416.677V142.199Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 142.199H417.594V143.247H420.222V142.199Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 142.199H421.138V143.247H423.766V142.199Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 144.571H403.415V145.619H406.043V144.571Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 144.571H406.96V145.619H409.588V144.571Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 144.571H410.504V145.619H413.132V144.571Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 144.571H414.049V145.619H416.677V144.571Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 144.571H417.594V145.619H420.222V144.571Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 144.571H421.138V145.619H423.766V144.571Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 146.887H403.415V147.935H406.043V146.887Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 146.887H406.96V147.935H409.588V146.887Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 146.887H410.504V147.935H413.132V146.887Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 146.887H414.049V147.935H416.677V146.887Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 146.887H417.594V147.935H420.222V146.887Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 146.887H421.138V147.935H423.766V146.887Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 149.258H403.415V150.306H406.043V149.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 149.258H406.96V150.306H409.588V149.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 149.258H410.504V150.306H413.132V149.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 149.258H414.049V150.306H416.677V149.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 149.258H417.594V150.306H420.222V149.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 149.258H421.138V150.306H423.766V149.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 151.575H403.415V152.622H406.043V151.575Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 151.575H406.96V152.622H409.588V151.575Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 151.575H410.504V152.622H413.132V151.575Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 151.575H414.049V152.622H416.677V151.575Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 151.575H417.594V152.622H420.222V151.575Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 151.575H421.138V152.622H423.766V151.575Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 153.946H403.415V154.994H406.043V153.946Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 153.946H406.96V154.994H409.588V153.946Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 153.946H410.504V154.994H413.132V153.946Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 153.946H414.049V154.994H416.677V153.946Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 153.946H417.594V154.994H420.222V153.946Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 153.946H421.138V154.994H423.766V153.946Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 163.321H403.415V164.369H406.043V163.321Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 163.321H406.96V164.369H409.588V163.321Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 163.321H410.504V164.369H413.132V163.321Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 163.321H414.049V164.369H416.677V163.321Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 163.321H417.594V164.369H420.222V163.321Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 163.321H421.138V164.369H423.766V163.321Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 165.693H403.415V166.74H406.043V165.693Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 165.693H406.96V166.74H409.588V165.693Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 165.693H410.504V166.74H413.132V165.693Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 165.693H414.049V166.74H416.677V165.693Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 165.693H417.594V166.74H420.222V165.693Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 165.693H421.138V166.74H423.766V165.693Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 168.064H403.415V169.112H406.043V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 168.064H406.96V169.112H409.588V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 168.064H410.504V169.112H413.132V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 168.064H414.049V169.112H416.677V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 168.064H417.594V169.112H420.222V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 168.064H421.138V169.112H423.766V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 170.38H403.415V171.428H406.043V170.38Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M409.588 170.38H406.96V171.428H409.588V170.38Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 170.38H410.504V171.428H413.132V170.38Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 170.38H414.049V171.428H416.677V170.38Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 170.38H417.594V171.428H420.222V170.38Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 170.38H421.138V171.428H423.766V170.38Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 172.752H403.415V173.799H406.043V172.752Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 172.752H406.96V173.799H409.588V172.752Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 172.752H410.504V173.799H413.132V172.752Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 172.752H414.049V173.799H416.677V172.752Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 172.752H417.594V173.799H420.222V172.752Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 172.752H421.138V173.799H423.766V172.752Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 175.068H403.415V176.116H406.043V175.068Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 175.068H406.96V176.116H409.588V175.068Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 175.068H410.504V176.116H413.132V175.068Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 175.068H414.049V176.116H416.677V175.068Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 175.068H417.594V176.116H420.222V175.068Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 175.068H421.138V176.116H423.766V175.068Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 177.439H403.415V178.487H406.043V177.439Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 177.439H406.96V178.487H409.588V177.439Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 177.439H410.504V178.487H413.132V177.439Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 177.439H414.049V178.487H416.677V177.439Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 177.439H417.594V178.487H420.222V177.439Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 177.439H421.138V178.487H423.766V177.439Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 179.811H403.415V180.858H406.043V179.811Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 179.811H406.96V180.858H409.588V179.811Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 179.811H410.504V180.858H413.132V179.811Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 179.811H414.049V180.858H416.677V179.811Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 179.811H417.594V180.858H420.222V179.811Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 179.811H421.138V180.858H423.766V179.811Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 182.127H403.415V183.175H406.043V182.127Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 182.127H406.96V183.175H409.588V182.127Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 182.127H410.504V183.175H413.132V182.127Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 182.127H414.049V183.175H416.677V182.127Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 182.127H417.594V183.175H420.222V182.127Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 182.127H421.138V183.175H423.766V182.127Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 184.498H403.415V185.546H406.043V184.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 184.498H406.96V185.546H409.588V184.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 184.498H410.504V185.546H413.132V184.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 184.498H414.049V185.546H416.677V184.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 184.498H417.594V185.546H420.222V184.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 184.498H421.138V185.546H423.766V184.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 186.87H403.415V187.917H406.043V186.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M409.588 186.87H406.96V187.917H409.588V186.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 186.87H410.504V187.917H413.132V186.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 186.87H414.049V187.917H416.677V186.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 186.87H417.594V187.917H420.222V186.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 186.87H421.138V187.917H423.766V186.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 189.186H403.415V190.234H406.043V189.186Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 189.186H406.96V190.234H409.588V189.186Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 189.186H410.504V190.234H413.132V189.186Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 189.186H414.049V190.234H416.677V189.186Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 189.186H417.594V190.234H420.222V189.186Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 189.186H421.138V190.234H423.766V189.186Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 191.557H403.415V192.605H406.043V191.557Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 191.557H406.96V192.605H409.588V191.557Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 191.557H410.504V192.605H413.132V191.557Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 191.557H414.049V192.605H416.677V191.557Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 191.557H417.594V192.605H420.222V191.557Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 191.557H421.138V192.605H423.766V191.557Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 193.874H403.415V194.921H406.043V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 193.874H406.96V194.921H409.588V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 193.874H410.504V194.921H413.132V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 193.874H414.049V194.921H416.677V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 193.874H417.594V194.921H420.222V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 193.874H421.138V194.921H423.766V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 203.304H403.415V204.352H406.043V203.304Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 203.304H406.96V204.352H409.588V203.304Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 203.304H410.504V204.352H413.132V203.304Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 203.304H414.049V204.352H416.677V203.304Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 203.304H417.594V204.352H420.222V203.304Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 203.304H421.138V204.352H423.766V203.304Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 205.62H403.415V206.668H406.043V205.62Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M409.588 205.62H406.96V206.668H409.588V205.62Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 205.62H410.504V206.668H413.132V205.62Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 205.62H414.049V206.668H416.677V205.62Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 205.62H417.594V206.668H420.222V205.62Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 205.62H421.138V206.668H423.766V205.62Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 207.992H403.415V209.039H406.043V207.992Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 207.992H406.96V209.039H409.588V207.992Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 207.992H410.504V209.039H413.132V207.992Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 207.992H414.049V209.039H416.677V207.992Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 207.992H417.594V209.039H420.222V207.992Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 207.992H421.138V209.039H423.766V207.992Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 210.363H403.415V211.411H406.043V210.363Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 210.363H406.96V211.411H409.588V210.363Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 210.363H410.504V211.411H413.132V210.363Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 210.363H414.049V211.411H416.677V210.363Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 210.363H417.594V211.411H420.222V210.363Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 210.363H421.138V211.411H423.766V210.363Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 212.679H403.415V213.727H406.043V212.679Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 212.679H406.96V213.727H409.588V212.679Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 212.679H410.504V213.727H413.132V212.679Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 212.679H414.049V213.727H416.677V212.679Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 212.679H417.594V213.727H420.222V212.679Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 212.679H421.138V213.727H423.766V212.679Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 215.051H403.415V216.098H406.043V215.051Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 215.051H406.96V216.098H409.588V215.051Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 215.051H410.504V216.098H413.132V215.051Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 215.051H414.049V216.098H416.677V215.051Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 215.051H417.594V216.098H420.222V215.051Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 215.051H421.138V216.098H423.766V215.051Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 217.367H403.415V218.415H406.043V217.367Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 217.367H406.96V218.415H409.588V217.367Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 217.367H410.504V218.415H413.132V217.367Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 217.367H414.049V218.415H416.677V217.367Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 217.367H417.594V218.415H420.222V217.367Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 217.367H421.138V218.415H423.766V217.367Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 219.738H403.415V220.786H406.043V219.738Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 219.738H406.96V220.786H409.588V219.738Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 219.738H410.504V220.786H413.132V219.738Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 219.738H414.049V220.786H416.677V219.738Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 219.738H417.594V220.786H420.222V219.738Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 219.738H421.138V220.786H423.766V219.738Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 222.11H403.415V223.157H406.043V222.11Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M409.588 222.11H406.96V223.157H409.588V222.11Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 222.11H410.504V223.157H413.132V222.11Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 222.11H414.049V223.157H416.677V222.11Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 222.11H417.594V223.157H420.222V222.11Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 222.11H421.138V223.157H423.766V222.11Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 224.426H403.415V225.474H406.043V224.426Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 224.426H406.96V225.474H409.588V224.426Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 224.426H410.504V225.474H413.132V224.426Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 224.426H414.049V225.474H416.677V224.426Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 224.426H417.594V225.474H420.222V224.426Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 224.426H421.138V225.474H423.766V224.426Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 226.797H403.415V227.845H406.043V226.797Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 226.797H406.96V227.845H409.588V226.797Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 226.797H410.504V227.845H413.132V226.797Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 226.797H414.049V227.845H416.677V226.797Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 226.797H417.594V227.845H420.222V226.797Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 226.797H421.138V227.845H423.766V226.797Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 229.113H403.415V230.161H406.043V229.113Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 229.113H406.96V230.161H409.588V229.113Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 229.113H410.504V230.161H413.132V229.113Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 229.113H414.049V230.161H416.677V229.113Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 229.113H417.594V230.161H420.222V229.113Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 229.113H421.138V230.161H423.766V229.113Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 231.485H403.415V232.533H406.043V231.485Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 231.485H406.96V232.533H409.588V231.485Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 231.485H410.504V232.533H413.132V231.485Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 231.485H414.049V232.533H416.677V231.485Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 231.485H417.594V232.533H420.222V231.485Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 231.485H421.138V232.533H423.766V231.485Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M406.043 233.856H403.415V234.904H406.043V233.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M409.588 233.856H406.96V234.904H409.588V233.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M413.132 233.856H410.504V234.904H413.132V233.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M416.677 233.856H414.049V234.904H416.677V233.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M420.222 233.856H417.594V234.904H420.222V233.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M423.766 233.856H421.138V234.904H423.766V233.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.4")) - ~d:(("M425.172 227.955H401.887V240.474H425.172V227.955Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M326.044 212.128H250.141V241.246H326.044V212.128Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M263.83 213.286H252.157V214.72H263.83V213.286Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M276.42 213.286H264.747V214.72H276.42V213.286Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 213.286H277.153V214.72H288.826V213.286Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M263.83 215.878H252.157V217.312H263.83V215.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M276.42 215.878H264.747V217.312H276.42V215.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 215.878H277.153V217.312H288.826V215.878Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M263.83 218.47H252.157V219.904H263.83V218.47Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M276.42 218.47H264.747V219.904H276.42V218.47Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 218.47H277.153V219.904H288.826V218.47Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M263.83 221.062H252.157V222.496H263.83V221.062Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M276.42 221.062H264.747V222.496H276.42V221.062Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 221.062H277.153V222.496H288.826V221.062Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M263.83 223.654H252.157V225.088H263.83V223.654Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M276.42 223.654H264.747V225.088H276.42V223.654Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 223.654H277.153V225.088H288.826V223.654Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M263.83 226.191H252.157V227.624H263.83V226.191Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M276.42 226.191H264.747V227.624H276.42V226.191Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 226.191H277.153V227.624H288.826V226.191Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M263.83 228.783H252.157V230.216H263.83V228.783Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M276.42 228.783H264.747V230.216H276.42V228.783Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 228.783H277.153V230.216H288.826V228.783Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M263.83 231.375H252.157V232.808H263.83V231.375Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M276.42 231.375H264.747V232.808H276.42V231.375Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M288.826 231.375H277.153V232.808H288.826V231.375Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M360.818 199.664H358.191V209.701H360.818V199.664Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M360.818 199.664H358.191V205.014H360.818V199.664Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M368.274 209.701H334.173V215.216H368.274V209.701Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M375.303 215.216H334.173V240.915H375.303V215.216Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M331.606 121.298H291.759V240.253H331.606V121.298Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M299.582 126.592H294.143V127.254H299.582V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M305.449 126.592H300.01V127.254H305.449V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M311.194 126.592H305.754V127.254H311.194V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M316.938 126.592H311.499V127.254H316.938V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.866 126.592H317.427V127.254H322.866V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M328.611 126.592H323.172V127.254H328.611V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M299.582 129.46H294.143V130.122H299.582V129.46Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M305.449 129.46H300.01V130.122H305.449V129.46Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M311.194 129.46H305.755V130.122H311.194V129.46Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M316.938 129.46H311.499V130.122H316.938V129.46Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.866 129.46H317.427V130.122H322.866V129.46Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M328.611 129.46H323.172V130.122H328.611V129.46Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M299.582 132.383H294.143V133.045H299.582V132.383Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M305.449 132.383H300.01V133.045H305.449V132.383Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M311.194 132.383H305.755V133.045H311.194V132.383Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M316.938 132.383H311.499V133.045H316.938V132.383Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.866 132.383H317.427V133.045H322.866V132.383Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M328.611 132.383H323.172V133.045H328.611V132.383Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M299.582 135.251H294.143V135.912H299.582V135.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M305.449 135.251H300.01V135.912H305.449V135.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M311.194 135.251H305.755V135.912H311.194V135.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M316.938 135.251H311.499V135.912H316.938V135.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.866 135.251H317.427V135.912H322.866V135.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M328.611 135.251H323.172V135.912H328.611V135.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M299.582 138.173H294.143V138.835H299.582V138.173Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M305.449 138.173H300.01V138.835H305.449V138.173Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M311.194 138.173H305.755V138.835H311.194V138.173Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M316.938 138.173H311.499V138.835H316.938V138.173Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.866 138.173H317.427V138.835H322.866V138.173Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M328.611 138.173H323.172V138.835H328.611V138.173Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M299.582 141.041H294.143V141.703H299.582V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M305.449 141.041H300.01V141.703H305.449V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M311.194 141.041H305.755V141.703H311.194V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M316.938 141.041H311.499V141.703H316.938V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.866 141.041H317.427V141.703H322.866V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M328.611 141.041H323.172V141.703H328.611V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 144.626H294.143V145.288H298.237V144.626Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 144.626H303.921V145.288H308.016V144.626Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 144.626H313.699V145.288H317.794V144.626Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 144.626H323.478V145.288H327.572V144.626Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 148.045H299.032V148.707H303.127V148.045Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 148.045H308.81V148.707H312.905V148.045Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 148.045H318.589V148.707H322.683V148.045Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 151.519H294.143V152.181H298.237V151.519Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 151.519H303.921V152.181H308.016V151.519Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 151.519H313.699V152.181H317.794V151.519Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 151.519H323.478V152.181H327.572V151.519Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 154.883H299.032V155.545H303.127V154.883Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 154.883H308.81V155.545H312.905V154.883Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 154.883H318.589V155.545H322.683V154.883Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 158.413H294.143V159.075H298.237V158.413Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 158.413H303.921V159.075H308.016V158.413Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 158.413H313.699V159.075H317.794V158.413Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 158.413H323.478V159.075H327.572V158.413Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 161.777H299.032V162.439H303.127V161.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 161.777H308.81V162.439H312.905V161.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 161.777H318.589V162.439H322.683V161.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 165.307H294.143V165.968H298.237V165.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 165.307H303.921V165.968H308.016V165.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 165.307H313.699V165.968H317.794V165.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 165.307H323.478V165.968H327.572V165.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 168.671H299.032V169.332H303.127V168.671Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 168.671H308.81V169.332H312.905V168.671Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 168.671H318.589V169.332H322.683V168.671Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M298.237 172.2H294.143V172.862H298.237V172.2Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M308.016 172.2H303.921V172.862H308.016V172.2Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M317.794 172.2H313.699V172.862H317.794V172.2Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M327.572 172.2H323.478V172.862H327.572V172.2Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 175.564H299.032V176.226H303.127V175.564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 175.564H308.81V176.226H312.905V175.564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 175.564H318.589V176.226H322.683V175.564Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 179.094H294.143V179.755H298.237V179.094Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 179.094H303.921V179.755H308.016V179.094Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 179.094H313.699V179.755H317.794V179.094Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 179.094H323.478V179.755H327.572V179.094Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 182.458H299.032V183.12H303.127V182.458Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 182.458H308.81V183.12H312.905V182.458Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 182.458H318.589V183.12H322.683V182.458Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 185.932H294.143V186.594H298.237V185.932Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 185.932H303.921V186.594H308.016V185.932Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 185.932H313.699V186.594H317.794V185.932Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 185.932H323.478V186.594H327.572V185.932Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 189.351H299.032V190.013H303.127V189.351Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 189.351H308.81V190.013H312.905V189.351Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 189.351H318.589V190.013H322.683V189.351Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 192.826H294.143V193.487H298.237V192.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 192.826H303.921V193.487H308.016V192.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 192.826H313.699V193.487H317.794V192.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 192.826H323.478V193.487H327.572V192.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 196.245H299.032V196.907H303.127V196.245Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 196.245H308.81V196.907H312.905V196.245Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 196.245H318.589V196.907H322.683V196.245Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 199.719H294.143V200.381H298.237V199.719Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 199.719H303.921V200.381H308.016V199.719Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 199.719H313.699V200.381H317.794V199.719Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 199.719H323.478V200.381H327.572V199.719Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 203.138H299.032V203.8H303.127V203.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M312.905 203.138H308.81V203.8H312.905V203.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 203.138H318.589V203.8H322.683V203.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 206.613H294.143V207.275H298.237V206.613Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 206.613H303.921V207.275H308.016V206.613Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 206.613H313.699V207.275H317.794V206.613Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 206.613H323.478V207.275H327.572V206.613Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 209.977H299.032V210.639H303.127V209.977Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 209.977H308.81V210.639H312.905V209.977Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 209.977H318.589V210.639H322.683V209.977Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 213.506H294.143V214.168H298.237V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 213.506H303.921V214.168H308.016V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 213.506H313.699V214.168H317.794V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 213.506H323.478V214.168H327.572V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 216.87H299.032V217.532H303.127V216.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M312.905 216.87H308.81V217.532H312.905V216.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 216.87H318.589V217.532H322.683V216.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M298.237 220.4H294.143V221.062H298.237V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M308.016 220.4H303.921V221.062H308.016V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M317.794 220.4H313.699V221.062H317.794V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M327.572 220.4H323.478V221.062H327.572V220.4Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 223.764H299.032V224.426H303.127V223.764Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 223.764H308.81V224.426H312.905V223.764Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 223.764H318.589V224.426H322.683V223.764Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M298.237 227.294H294.143V227.955H298.237V227.294Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M308.016 227.294H303.921V227.955H308.016V227.294Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M317.794 227.294H313.699V227.955H317.794V227.294Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M327.572 227.294H323.478V227.955H327.572V227.294Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M303.127 230.658H299.032V231.319H303.127V230.658Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M312.905 230.658H308.81V231.319H312.905V230.658Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M322.683 230.658H318.589V231.319H322.683V230.658Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M199.538 188.303H169.531V240.695H199.538V188.303Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 191.226H171.181V194.26H178.087V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 191.226H179.92V194.26H186.826V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 191.226H188.66V194.26H195.566V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 195.638H171.181V198.671H178.087V195.638Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 195.638H179.92V198.671H186.826V195.638Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 195.638H188.66V198.671H195.566V195.638Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 200.05H171.181V203.083H178.087V200.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M186.826 200.05H179.92V203.083H186.826V200.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M195.566 200.05H188.66V203.083H195.566V200.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 204.407H171.181V207.44H178.087V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 204.407H179.92V207.44H186.826V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 204.407H188.66V207.44H195.566V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 208.819H171.181V211.852H178.087V208.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 208.819H179.92V211.852H186.826V208.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 208.819H188.66V211.852H195.566V208.819Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 213.231H171.181V216.264H178.087V213.231Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 213.231H179.92V216.264H186.826V213.231Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 213.231H188.66V216.264H195.566V213.231Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M178.087 217.587H171.181V220.621H178.087V217.587Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M186.826 217.587H179.92V220.621H186.826V217.587Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M195.566 217.587H188.66V220.621H195.566V217.587Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M160.914 175.84L169.653 185.546V244.555H160.914V175.84Z") - ) ~fill:(("#1474AA")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M163.542 242.57V178.763L160.914 175.895V241.963C162.014 242.349 163.542 242.57 163.542 242.57Z") - ) ~fill:(("#1474AA")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M154.191 108.448H144.046V146.335H154.191V108.448Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M151.991 108.448H144.046V146.335H151.991V108.448Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M160.914 146.335H112.206V244.555H160.914V146.335Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.835 105.746H117.462V146.335H147.835V105.746Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 115.066H119.539V116.059H120.639V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 115.066H122.656V116.059H123.756V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 115.066H125.773V116.059H126.873V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 115.066H128.951V116.059H130.051V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 115.066H132.068V116.059H133.168V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 115.066H135.185V116.059H136.285V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 115.066H138.363V116.059H139.463V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.58 115.066H141.479V116.059H142.58V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 115.066H144.596V116.059H145.696V115.066Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 118.871H119.539V119.864H120.639V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 118.871H122.656V119.864H123.756V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 118.871H125.773V119.864H126.873V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 118.871H128.951V119.864H130.051V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 118.871H132.068V119.864H133.168V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 118.871H135.185V119.864H136.285V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 118.871H138.363V119.864H139.463V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.58 118.871H141.479V119.864H142.58V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 118.871H144.596V119.864H145.696V118.871Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 122.732H119.539V123.724H120.639V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 122.732H122.656V123.724H123.756V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 122.732H125.773V123.724H126.873V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 122.732H128.951V123.724H130.051V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 122.732H132.068V123.724H133.168V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 122.732H135.185V123.724H136.285V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 122.732H138.363V123.724H139.463V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.58 122.732H141.479V123.724H142.58V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 122.732H144.596V123.724H145.696V122.732Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 126.592H119.539V127.585H120.639V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 126.592H122.656V127.585H123.756V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 126.592H125.773V127.585H126.873V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 126.592H128.951V127.585H130.051V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 126.592H132.068V127.585H133.168V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 126.592H135.185V127.585H136.285V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 126.592H138.363V127.585H139.463V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.58 126.592H141.479V127.585H142.58V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 126.592H144.596V127.585H145.696V126.592Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 130.397H119.539V131.39H120.639V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 130.397H122.656V131.39H123.756V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 130.397H125.773V131.39H126.873V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 130.397H128.951V131.39H130.051V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 130.397H132.068V131.39H133.168V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 130.397H135.185V131.39H136.285V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 130.397H138.363V131.39H139.463V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M142.58 130.397H141.479V131.39H142.58V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 130.397H144.596V131.39H145.696V130.397Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 134.258H119.539V135.251H120.639V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 134.258H122.656V135.251H123.756V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 134.258H125.773V135.251H126.873V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 134.258H128.951V135.251H130.051V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 134.258H132.068V135.251H133.168V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 134.258H135.185V135.251H136.285V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 134.258H138.363V135.251H139.463V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.58 134.258H141.479V135.251H142.58V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 134.258H144.596V135.251H145.696V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 138.063H119.539V139.056H120.639V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 138.063H122.656V139.056H123.756V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 138.063H125.773V139.056H126.873V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 138.063H128.951V139.056H130.051V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 138.063H132.068V139.056H133.168V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 138.063H135.185V139.056H136.285V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 138.063H138.363V139.056H139.463V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.58 138.063H141.479V139.056H142.58V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 138.063H144.596V139.056H145.696V138.063Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M120.639 141.924H119.539V142.916H120.639V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.756 141.924H122.656V142.916H123.756V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.873 141.924H125.773V142.916H126.873V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.051 141.924H128.951V142.916H130.051V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.168 141.924H132.068V142.916H133.168V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.285 141.924H135.185V142.916H136.285V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M139.463 141.924H138.363V142.916H139.463V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.58 141.924H141.479V142.916H142.58V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 141.924H144.596V142.916H145.696V141.924Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M121.556 109.496H119.539V111.316H121.556V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.94 109.496H121.923V111.316H123.94V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.384 109.496H124.367V111.316H126.384V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M128.768 109.496H126.751V111.316H128.768V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M131.212 109.496H129.195V111.316H131.212V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.596 109.496H131.579V111.316H133.596V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.04 109.496H134.023V111.316H136.04V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M138.424 109.496H136.407V111.316H138.424V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M140.868 109.496H138.851V111.316H140.868V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M143.252 109.496H141.235V111.316H143.252V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 109.496H143.68V111.316H145.696V109.496Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M121.556 111.647H119.539V113.467H121.556V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M123.94 111.647H121.923V113.467H123.94V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.384 111.647H124.367V113.467H126.384V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M128.768 111.647H126.751V113.467H128.768V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M131.212 111.647H129.195V113.467H131.212V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M133.596 111.647H131.579V113.467H133.596V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M136.04 111.647H134.023V113.467H136.04V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M138.424 111.647H136.407V113.467H138.424V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M140.868 111.647H138.851V113.467H140.868V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M143.252 111.647H141.235V113.467H143.252V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 111.647H143.68V113.467H145.696V111.647Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M117.462 141.317V146.335H144.046H147.835H154.191V141.317H117.462Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M118.928 150.968H115.689V153.891H118.928V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.778 150.968H119.539V153.891H122.778V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.568 150.968H123.328V153.891H126.568V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.418 150.968H127.179V153.891H130.418V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.268 150.968H131.029V153.891H134.268V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M138.057 150.968H134.818V153.891H138.057V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M141.907 150.968H138.668V153.891H141.907V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 150.968H142.457V153.891H145.696V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M149.546 150.968H146.307V153.891H149.546V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M153.336 150.968H150.097V153.891H153.336V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.186 150.968H153.947V153.891H157.186V150.968Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M118.928 154.442H115.689V157.365H118.928V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 158.634H115.689V160.178H117.4V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 158.634H120.701V160.178H122.412V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 158.634H125.651V160.178H127.362V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 158.634H130.601V160.178H132.312V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 158.634H135.551V160.178H137.263V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 158.634H140.563V160.178H142.274V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 158.634H145.513V160.178H147.224V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 158.634H150.463V160.178H152.174V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 158.634H155.414V160.178H157.125V158.634Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 162.273H115.689V163.818H117.4V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 162.273H120.701V163.818H122.412V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 162.273H125.651V163.818H127.362V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 162.273H130.601V163.818H132.312V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 162.273H135.551V163.818H137.263V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 162.273H140.563V163.818H142.274V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 162.273H145.513V163.818H147.224V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 162.273H150.463V163.818H152.174V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 162.273H155.414V163.818H157.125V162.273Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 165.913H115.689V167.457H117.4V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 165.913H120.701V167.457H122.412V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 165.913H125.651V167.457H127.362V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 165.913H130.601V167.457H132.312V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 165.913H135.551V167.457H137.263V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 165.913H140.563V167.457H142.274V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 165.913H145.513V167.457H147.224V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 165.913H150.463V167.457H152.174V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 165.913H155.414V167.457H157.125V165.913Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 169.498H115.689V171.042H117.4V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 169.498H120.701V171.042H122.412V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 169.498H125.651V171.042H127.362V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 169.498H130.601V171.042H132.312V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 169.498H135.551V171.042H137.263V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 169.498H140.563V171.042H142.274V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 169.498H145.513V171.042H147.224V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 169.498H150.463V171.042H152.174V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 169.498H155.414V171.042H157.125V169.498Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 173.138H115.689V174.682H117.4V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 173.138H120.701V174.682H122.412V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 173.138H125.651V174.682H127.362V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 173.138H130.601V174.682H132.312V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 173.138H135.551V174.682H137.263V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 173.138H140.563V174.682H142.274V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 173.138H145.513V174.682H147.224V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 173.138H150.463V174.682H152.174V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 173.138H155.414V174.682H157.125V173.138Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 176.777H115.689V178.322H117.4V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 176.777H120.701V178.322H122.412V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 176.777H125.651V178.322H127.362V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 176.777H130.601V178.322H132.312V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 176.777H135.551V178.322H137.263V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 176.777H140.563V178.322H142.274V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 176.777H145.513V178.322H147.224V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 176.777H150.463V178.322H152.174V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 176.777H155.414V178.322H157.125V176.777Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 180.362H115.689V181.906H117.4V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 180.362H120.701V181.906H122.412V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 180.362H125.651V181.906H127.362V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 180.362H130.601V181.906H132.312V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 180.362H135.551V181.906H137.263V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 180.362H140.563V181.906H142.274V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 180.362H145.513V181.906H147.224V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 180.362H150.463V181.906H152.174V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 180.362H155.414V181.906H157.125V180.362Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 184.002H115.689V185.546H117.4V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 184.002H120.701V185.546H122.412V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 184.002H125.651V185.546H127.362V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 184.002H130.601V185.546H132.312V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 184.002H135.551V185.546H137.263V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 184.002H140.563V185.546H142.274V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 184.002H145.513V185.546H147.224V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 184.002H150.463V185.546H152.174V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 184.002H155.414V185.546H157.125V184.002Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 187.642H115.689V189.186H117.4V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 187.642H120.701V189.186H122.412V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 187.642H125.651V189.186H127.362V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 187.642H130.601V189.186H132.312V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 187.642H135.551V189.186H137.263V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 187.642H140.563V189.186H142.274V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 187.642H145.513V189.186H147.224V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 187.642H150.463V189.186H152.174V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 187.642H155.414V189.186H157.125V187.642Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 191.226H115.689V192.771H117.4V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 191.226H120.701V192.771H122.412V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 191.226H125.651V192.771H127.362V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 191.226H130.601V192.771H132.312V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 191.226H135.551V192.771H137.263V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 191.226H140.563V192.771H142.274V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 191.226H145.513V192.771H147.224V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 191.226H150.463V192.771H152.174V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 191.226H155.414V192.771H157.125V191.226Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 194.866H115.689V196.41H117.4V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 194.866H120.701V196.41H122.412V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 194.866H125.651V196.41H127.362V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 194.866H130.601V196.41H132.312V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 194.866H135.551V196.41H137.263V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 194.866H140.563V196.41H142.274V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 194.866H145.513V196.41H147.224V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 194.866H150.463V196.41H152.174V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 194.866H155.414V196.41H157.125V194.866Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 198.506H115.689V200.05H117.4V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 198.506H120.701V200.05H122.412V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 198.506H125.651V200.05H127.362V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 198.506H130.601V200.05H132.312V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 198.506H135.551V200.05H137.263V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 198.506H140.563V200.05H142.274V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 198.506H145.513V200.05H147.224V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 198.506H150.463V200.05H152.174V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 198.506H155.414V200.05H157.125V198.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 202.091H115.689V203.635H117.4V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 202.091H120.701V203.635H122.412V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 202.091H125.651V203.635H127.362V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 202.091H130.601V203.635H132.312V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 202.091H135.551V203.635H137.263V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 202.091H140.563V203.635H142.274V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 202.091H145.513V203.635H147.224V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 202.091H150.463V203.635H152.174V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 202.091H155.414V203.635H157.125V202.091Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 205.73H115.689V207.275H117.4V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 205.73H120.701V207.275H122.412V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 205.73H125.651V207.275H127.362V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 205.73H130.601V207.275H132.312V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 205.73H135.551V207.275H137.263V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 205.73H140.563V207.275H142.274V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 205.73H145.513V207.275H147.224V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 205.73H150.463V207.275H152.174V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 205.73H155.414V207.275H157.125V205.73Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 209.37H115.689V210.914H117.4V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 209.37H120.701V210.914H122.412V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 209.37H125.651V210.914H127.362V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 209.37H130.601V210.914H132.312V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 209.37H135.551V210.914H137.263V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 209.37H140.563V210.914H142.274V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 209.37H145.513V210.914H147.224V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 209.37H150.463V210.914H152.174V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 209.37H155.414V210.914H157.125V209.37Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 212.955H115.689V214.499H117.4V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 212.955H120.701V214.499H122.412V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 212.955H125.651V214.499H127.362V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 212.955H130.601V214.499H132.312V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 212.955H135.551V214.499H137.263V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 212.955H140.563V214.499H142.274V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 212.955H145.513V214.499H147.224V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 212.955H150.463V214.499H152.174V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 212.955H155.414V214.499H157.125V212.955Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M117.4 216.595H115.689V218.139H117.4V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.412 216.595H120.701V218.139H122.412V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M127.362 216.595H125.651V218.139H127.362V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M132.312 216.595H130.601V218.139H132.312V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M137.263 216.595H135.551V218.139H137.263V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M142.274 216.595H140.563V218.139H142.274V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M147.224 216.595H145.513V218.139H147.224V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M152.174 216.595H150.463V218.139H152.174V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.125 216.595H155.414V218.139H157.125V216.595Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M122.778 154.442H119.539V157.365H122.778V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M126.568 154.442H123.328V157.365H126.568V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M130.418 154.442H127.179V157.365H130.418V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M134.268 154.442H131.029V157.365H134.268V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M138.057 154.442H134.818V157.365H138.057V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M141.907 154.442H138.668V157.365H141.907V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M145.696 154.442H142.457V157.365H145.696V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M149.546 154.442H146.307V157.365H149.546V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M153.336 154.442H150.097V157.365H153.336V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M157.186 154.442H153.947V157.365H157.186V154.442Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M509.998 178.597H476.08V240.474H509.998V178.597Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M250.141 150.968H205.588V241.246H250.141V150.968Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 157.475H209.377V159.351H213.594V157.475Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 160.288H216.161V162.163H220.378V160.288Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 160.288H233.151V162.163H237.368V160.288Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 157.475H224.534V159.351H228.751V157.475Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 157.475H241.646V159.351H245.863V157.475Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 164.204H209.377V166.079H213.594V164.204Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 167.016H216.161V168.891H220.378V167.016Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 167.016H233.151V168.891H237.368V167.016Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 164.204H224.534V166.079H228.751V164.204Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 164.204H241.646V166.079H245.863V164.204Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 170.932H209.377V172.807H213.594V170.932Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 173.689H216.161V175.564H220.378V173.689Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 173.689H233.151V175.564H237.368V173.689Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 170.932H224.534V172.807H228.751V170.932Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 170.932H241.646V172.807H245.863V170.932Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 177.605H209.377V179.48H213.594V177.605Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 180.417H216.161V182.292H220.378V180.417Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 180.417H233.151V182.292H237.368V180.417Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 177.605H224.534V179.48H228.751V177.605Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 177.605H241.646V179.48H245.863V177.605Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 184.333H209.377V186.208H213.594V184.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 187.145H216.161V189.02H220.378V187.145Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 187.145H233.151V189.02H237.368V187.145Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 184.333H224.534V186.208H228.751V184.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 184.333H241.646V186.208H245.863V184.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 191.061H209.377V192.936H213.594V191.061Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 193.874H216.161V195.749H220.378V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 193.874H233.151V195.749H237.368V193.874Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 191.061H224.534V192.936H228.751V191.061Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 191.061H241.646V192.936H245.863V191.061Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 197.789H209.377V199.664H213.594V197.789Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 200.602H216.161V202.477H220.378V200.602Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 200.602H233.151V202.477H237.368V200.602Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 197.789H224.534V199.664H228.751V197.789Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 197.789H241.646V199.664H245.863V197.789Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 204.517H209.377V206.392H213.594V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 207.33H216.161V209.205H220.378V207.33Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 207.33H233.151V209.205H237.368V207.33Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 204.517H224.534V206.392H228.751V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 204.517H241.646V206.392H245.863V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 211.245H209.377V213.12H213.594V211.245Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 214.003H216.161V215.878H220.378V214.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 214.003H233.151V215.878H237.368V214.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 211.245H224.534V213.12H228.751V211.245Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 211.245H241.646V213.12H245.863V211.245Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 217.918H209.377V219.793H213.594V217.918Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 220.731H216.161V222.606H220.378V220.731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 220.731H233.151V222.606H237.368V220.731Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 217.918H224.534V219.793H228.751V217.918Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 217.918H241.646V219.793H245.863V217.918Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M213.594 224.646H209.377V226.521H213.594V224.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M220.378 227.459H216.161V229.334H220.378V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M237.368 227.459H233.151V229.334H237.368V227.459Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M228.751 224.646H224.534V226.521H228.751V224.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 224.646H241.646V226.521H245.863V224.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M476.141 192.55H432.628V241.081H476.141V192.55Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M465.996 185.27H441.306V192.55H465.996V185.27Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M465.996 184.057H441.306V185.27H465.996V184.057Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M465.996 178.873H441.306V180.086H465.996V178.873Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.163 180.086H442.406V184.057H464.163V180.086Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.163 180.086H442.406V180.858H464.163V180.086Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M442.406 178.873L448.884 165.527H458.051L464.957 178.873H442.406Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M531.877 158.964L514.765 181.741V240.364H531.877H549.05V181.741L531.877 158.964Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 189.241H514.765V189.958H549.05V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 190.785H514.765V191.502H549.05V190.785Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 192.385H514.765V193.101H549.05V192.385Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 193.984H514.765V194.701H549.05V193.984Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 195.528H514.765V196.245H549.05V195.528Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 197.127H514.765V197.844H549.05V197.127Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 198.671H514.765V199.388H549.05V198.671Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 200.271H514.765V200.988H549.05V200.271Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 201.87H514.765V202.587H549.05V201.87Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 203.414H514.765V204.131H549.05V203.414Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 205.014H514.765V205.73H549.05V205.014Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 206.613H514.765V207.33H549.05V206.613Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 208.157H514.765V208.874H549.05V208.157Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 209.756H514.765V210.473H549.05V209.756Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 211.3H514.765V212.017H549.05V211.3Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 212.9H514.765V213.617H549.05V212.9Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 214.499H514.765V215.216H549.05V214.499Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 216.043H514.765V216.76H549.05V216.043Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 217.643H514.765V218.36H549.05V217.643Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 219.187H514.765V219.904H549.05V219.187Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 220.786H514.765V221.503H549.05V220.786Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 222.385H514.765V223.102H549.05V222.385Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M549.05 223.93H514.765V224.646H549.05V223.93Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 225.529H514.765V226.246H549.05V225.529Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 227.128H514.765V227.845H549.05V227.128Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 228.672H514.765V229.389H549.05V228.672Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 230.272H514.765V230.989H549.05V230.272Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 231.816H514.765V232.533H549.05V231.816Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 233.415H514.765V234.132H549.05V233.415Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 235.014H514.765V235.731H549.05V235.014Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 236.559H514.765V237.275H549.05V236.559Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M549.05 181.741L531.877 158.964L514.765 181.741L530.594 206.282L549.05 181.741Z") - ) ~fill:(("#1073AA")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M578.568 240.75V162.218L590.975 141.593L603.747 160.84V240.75H578.568Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M587.552 161.832H594.825L591.036 143.026L587.552 161.832Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M635.894 120.802H605.581V241.081H635.894V120.802Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M182.059 188.303H169.531V240.695H182.059V188.303Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M250.141 150.968H205.588V153.064H250.141V150.968Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M252.096 147.99H203.572V151.74H252.096V147.99Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.4")) - ~d:(("M228.751 241.246V147.99H203.572V151.685H205.588V241.246H228.751Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M331.606 121.298H291.759V124.166H331.606V121.298Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M336.801 199.664H334.173V209.701H336.801V199.664Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M336.801 199.664H334.173V205.014H336.801V199.664Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M338.94 211.962H337.106V213.672H338.94V211.962Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M343.34 211.962H341.506V213.672H343.34V211.962Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M347.801 211.962H345.968V213.672H347.801V211.962Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M352.201 211.962H350.368V213.672H352.201V211.962Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M356.602 211.962H354.768V213.672H356.602V211.962Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M361.002 211.962H359.168V213.672H361.002V211.962Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M365.402 211.962H363.569V213.672H365.402V211.962Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M339.795 217.146H337.473V219.242H339.795V217.146Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M345.234 217.146H342.912V219.242H345.234V217.146Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M350.673 217.146H348.351V219.242H350.673V217.146Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M356.052 217.146H353.79V219.242H356.052V217.146Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M361.552 217.146H359.229V219.242H361.552V217.146Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M366.991 217.146H364.669V219.242H366.991V217.146Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M372.43 217.146H370.108V219.242H372.43V217.146Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 181.52H478.769V183.175H480.175V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M483.536 181.52H482.13V183.175H483.536V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M486.836 181.52H485.43V183.175H486.836V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 181.52H488.792V183.175H490.197V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 181.52H492.092V183.175H493.498V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 181.52H495.453V183.175H496.859V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M500.22 181.52H498.814V183.175H500.22V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 181.52H501.931V183.175H503.337V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 181.52H506.087V183.175H507.493V181.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 184.774H478.769V186.428H480.175V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 184.774H482.13V186.428H483.536V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 184.774H485.43V186.428H486.836V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 184.774H488.792V186.428H490.197V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 184.774H492.092V186.428H493.498V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 184.774H495.453V186.428H496.859V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 184.774H498.814V186.428H500.22V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 184.774H501.931V186.428H503.337V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 184.774H506.087V186.428H507.493V184.774Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 188.083H478.769V189.737H480.175V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 188.083H482.13V189.737H483.536V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 188.083H485.43V189.737H486.836V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 188.083H488.792V189.737H490.197V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 188.083H492.092V189.737H493.498V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 188.083H495.453V189.737H496.859V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 188.083H498.814V189.737H500.22V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 188.083H501.931V189.737H503.337V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 188.083H506.087V189.737H507.493V188.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 191.392H478.769V193.046H480.175V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 191.392H482.13V193.046H483.536V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 191.392H485.43V193.046H486.836V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 191.392H488.792V193.046H490.197V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 191.392H492.092V193.046H493.498V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 191.392H495.453V193.046H496.859V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 191.392H498.814V193.046H500.22V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 191.392H501.931V193.046H503.337V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 191.392H506.087V193.046H507.493V191.392Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 194.646H478.769V196.3H480.175V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M483.536 194.646H482.13V196.3H483.536V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M486.836 194.646H485.43V196.3H486.836V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 194.646H488.792V196.3H490.197V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 194.646H492.092V196.3H493.498V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 194.646H495.453V196.3H496.859V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M500.22 194.646H498.814V196.3H500.22V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 194.646H501.931V196.3H503.337V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 194.646H506.087V196.3H507.493V194.646Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 197.954H478.769V199.609H480.175V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 197.954H482.13V199.609H483.536V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 197.954H485.43V199.609H486.836V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 197.954H488.792V199.609H490.197V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 197.954H492.092V199.609H493.498V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 197.954H495.453V199.609H496.859V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 197.954H498.814V199.609H500.22V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 197.954H501.931V199.609H503.337V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 197.954H506.087V199.609H507.493V197.954Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 201.263H478.769V202.918H480.175V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 201.263H482.13V202.918H483.536V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 201.263H485.43V202.918H486.836V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 201.263H488.792V202.918H490.197V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 201.263H492.092V202.918H493.498V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 201.263H495.453V202.918H496.859V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 201.263H498.814V202.918H500.22V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 201.263H501.931V202.918H503.337V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 201.263H506.087V202.918H507.493V201.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 204.517H478.769V206.172H480.175V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 204.517H482.13V206.172H483.536V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 204.517H485.43V206.172H486.836V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 204.517H488.792V206.172H490.197V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 204.517H492.092V206.172H493.498V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 204.517H495.453V206.172H496.859V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 204.517H498.814V206.172H500.22V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 204.517H501.931V206.172H503.337V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 204.517H506.087V206.172H507.493V204.517Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 207.826H478.769V209.481H480.175V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 207.826H482.13V209.481H483.536V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 207.826H485.43V209.481H486.836V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 207.826H488.792V209.481H490.197V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 207.826H492.092V209.481H493.498V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 207.826H495.453V209.481H496.859V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 207.826H498.814V209.481H500.22V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 207.826H501.931V209.481H503.337V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 207.826H506.087V209.481H507.493V207.826Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 211.135H478.769V212.789H480.175V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 211.135H482.13V212.789H483.536V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 211.135H485.43V212.789H486.836V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 211.135H488.792V212.789H490.197V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 211.135H492.092V212.789H493.498V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 211.135H495.453V212.789H496.859V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 211.135H498.814V212.789H500.22V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 211.135H501.931V212.789H503.337V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 211.135H506.087V212.789H507.493V211.135Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 214.389H478.769V216.043H480.175V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 214.389H482.13V216.043H483.536V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 214.389H485.43V216.043H486.836V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 214.389H488.792V216.043H490.197V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 214.389H492.092V216.043H493.498V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 214.389H495.453V216.043H496.859V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 214.389H498.814V216.043H500.22V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 214.389H501.931V216.043H503.337V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 214.389H506.087V216.043H507.493V214.389Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M480.175 217.698H478.769V219.352H480.175V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M483.536 217.698H482.13V219.352H483.536V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.836 217.698H485.43V219.352H486.836V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.197 217.698H488.792V219.352H490.197V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M493.498 217.698H492.092V219.352H493.498V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M496.859 217.698H495.453V219.352H496.859V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M500.22 217.698H498.814V219.352H500.22V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M503.337 217.698H501.931V219.352H503.337V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M507.493 217.698H506.087V219.352H507.493V217.698Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M360.88 197.844H334.173V203.911H360.88V197.844Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M337.84 199.333H336.312V200.712H337.84V199.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M341.384 199.333H339.856V200.712H341.384V199.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M344.929 199.333H343.401V200.712H344.929V199.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M348.473 199.333H346.946V200.712H348.473V199.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M352.079 199.333H350.551V200.712H352.079V199.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M355.624 199.333H354.096V200.712H355.624V199.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M359.168 199.333H357.641V200.712H359.168V199.333Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.5")) - ~d:(("M368.274 212.459H334.173V215.216H368.274V212.459Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M446.317 186.594H443.811V188.028H446.317V186.594Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M449.617 186.594H447.112V188.028H449.617V186.594Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M452.918 186.594H450.412V188.028H452.918V186.594Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M456.157 186.594H453.651V188.028H456.157V186.594Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M459.457 186.594H456.951V188.028H459.457V186.594Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M462.757 186.594H460.251V188.028H462.757V186.594Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M446.317 188.524H443.811V189.958H446.317V188.524Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M449.617 188.524H447.112V189.958H449.617V188.524Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M452.918 188.524H450.412V189.958H452.918V188.524Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M456.157 188.524H453.651V189.958H456.157V188.524Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M459.457 188.524H456.951V189.958H459.457V188.524Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M462.757 188.524H460.251V189.958H462.757V188.524Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M446.317 190.454H443.811V191.888H446.317V190.454Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M449.617 190.454H447.112V191.888H449.617V190.454Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M452.918 190.454H450.412V191.888H452.918V190.454Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M456.157 190.454H453.651V191.888H456.157V190.454Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M459.457 190.454H456.951V191.888H459.457V190.454Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M462.757 190.454H460.251V191.888H462.757V190.454Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.5")) - ~d:(("M465.996 190.454H441.306V192.55H465.996V190.454Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 195.473H434.767V198.892H444.362V195.473Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M454.69 195.473H445.095V198.892H454.69V195.473Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 195.473H455.362V198.892H464.957V195.473Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 195.473H465.629V198.892H475.224V195.473Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 199.609H434.767V203.028H444.362V199.609Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M454.69 199.609H445.095V203.028H454.69V199.609Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 199.609H455.362V203.028H464.957V199.609Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 199.609H465.629V203.028H475.224V199.609Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M444.362 203.8H434.767V207.219H444.362V203.8Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M454.69 203.8H445.095V207.219H454.69V203.8Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M464.957 203.8H455.362V207.219H464.957V203.8Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M475.224 203.8H465.629V207.219H475.224V203.8Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 207.936H434.767V211.356H444.362V207.936Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M454.69 207.936H445.095V211.356H454.69V207.936Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 207.936H455.362V211.356H464.957V207.936Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 207.936H465.629V211.356H475.224V207.936Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 212.073H434.767V215.492H444.362V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M454.69 212.073H445.095V215.492H454.69V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 212.073H455.362V215.492H464.957V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 212.073H465.629V215.492H475.224V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M444.362 216.209H434.767V219.628H444.362V216.209Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M454.69 216.209H445.095V219.628H454.69V216.209Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M464.957 216.209H455.362V219.628H464.957V216.209Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M475.224 216.209H465.629V219.628H475.224V216.209Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M476.141 192.55H467.402V240.474H476.141V192.55Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.646 126.647H559.745V134.313H569.646V126.647Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.646 130.287H559.745V133.431H569.646V130.287Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M566.468 110.379H564.695V128.853H566.468V110.379Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M573.863 132.383H550.578V240.474H573.863V132.383Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M573.863 131.17H550.578V239.261H573.863V131.17Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 140.765H551.678V142.034H553.023V140.765Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 140.765H554.917V142.034H556.262V140.765Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 140.765H558.156V142.034H559.501V140.765Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 140.765H561.396V142.034H562.74V140.765Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 140.765H564.634V142.034H565.979V140.765Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 140.765H567.812V142.034H569.157V140.765Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 140.765H571.052V142.034H572.396V140.765Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 143.743H551.678V145.012H553.023V143.743Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 143.743H554.917V145.012H556.262V143.743Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 143.743H558.156V145.012H559.501V143.743Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 143.743H561.396V145.012H562.74V143.743Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 143.743H564.634V145.012H565.979V143.743Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 143.743H567.812V145.012H569.157V143.743Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 143.743H571.052V145.012H572.396V143.743Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 149.865H551.678V151.133H553.023V149.865Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 149.865H554.917V151.133H556.262V149.865Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 149.865H558.156V151.133H559.501V149.865Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 149.865H561.396V151.133H562.74V149.865Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 149.865H564.634V151.133H565.979V149.865Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 149.865H567.812V151.133H569.157V149.865Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 149.865H571.052V151.133H572.396V149.865Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 152.843H551.678V154.111H553.023V152.843Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 152.843H554.917V154.111H556.262V152.843Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 152.843H558.156V154.111H559.501V152.843Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 152.843H561.396V154.111H562.74V152.843Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 152.843H564.634V154.111H565.979V152.843Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 152.843H567.812V154.111H569.157V152.843Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 152.843H571.052V154.111H572.396V152.843Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 158.964H551.678V160.233H553.023V158.964Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 158.964H554.917V160.233H556.262V158.964Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 158.964H558.156V160.233H559.501V158.964Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 158.964H561.396V160.233H562.74V158.964Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 158.964H564.634V160.233H565.979V158.964Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 158.964H567.812V160.233H569.157V158.964Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 158.964H571.052V160.233H572.396V158.964Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 161.942H551.678V163.211H553.023V161.942Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 161.942H554.917V163.211H556.262V161.942Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 161.942H558.156V163.211H559.501V161.942Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 161.942H561.396V163.211H562.74V161.942Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 161.942H564.634V163.211H565.979V161.942Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 161.942H567.812V163.211H569.157V161.942Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 161.942H571.052V163.211H572.396V161.942Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 168.064H551.678V169.332H553.023V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 168.064H554.917V169.332H556.262V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 168.064H558.156V169.332H559.501V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 168.064H561.396V169.332H562.74V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 168.064H564.634V169.332H565.979V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 168.064H567.812V169.332H569.157V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 168.064H571.052V169.332H572.396V168.064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 171.042H551.678V172.31H553.023V171.042Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 171.042H554.917V172.31H556.262V171.042Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 171.042H558.156V172.31H559.501V171.042Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M562.74 171.042H561.396V172.31H562.74V171.042Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 171.042H564.634V172.31H565.979V171.042Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 171.042H567.812V172.31H569.157V171.042Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 171.042H571.052V172.31H572.396V171.042Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 177.163H551.678V178.432H553.023V177.163Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 177.163H554.917V178.432H556.262V177.163Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 177.163H558.156V178.432H559.501V177.163Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 177.163H561.396V178.432H562.74V177.163Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 177.163H564.634V178.432H565.979V177.163Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 177.163H567.812V178.432H569.157V177.163Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 177.163H571.052V178.432H572.396V177.163Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 180.141H551.678V181.41H553.023V180.141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 180.141H554.917V181.41H556.262V180.141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 180.141H558.156V181.41H559.501V180.141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M562.74 180.141H561.396V181.41H562.74V180.141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 180.141H564.634V181.41H565.979V180.141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 180.141H567.812V181.41H569.157V180.141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 180.141H571.052V181.41H572.396V180.141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 186.263H551.678V187.531H553.023V186.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 186.263H554.917V187.531H556.262V186.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 186.263H558.156V187.531H559.501V186.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 186.263H561.396V187.531H562.74V186.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 186.263H564.634V187.531H565.979V186.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 186.263H567.812V187.531H569.157V186.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 186.263H571.052V187.531H572.396V186.263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 189.241H551.678V190.509H553.023V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 189.241H554.917V190.509H556.262V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 189.241H558.156V190.509H559.501V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 189.241H561.396V190.509H562.74V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 189.241H564.634V190.509H565.979V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 189.241H567.812V190.509H569.157V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 189.241H571.052V190.509H572.396V189.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 195.307H551.678V196.576H553.023V195.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 195.307H554.917V196.576H556.262V195.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 195.307H558.156V196.576H559.501V195.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 195.307H561.396V196.576H562.74V195.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 195.307H564.634V196.576H565.979V195.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 195.307H567.812V196.576H569.157V195.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 195.307H571.052V196.576H572.396V195.307Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 198.341H551.678V199.609H553.023V198.341Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 198.341H554.917V199.609H556.262V198.341Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 198.341H558.156V199.609H559.501V198.341Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 198.341H561.396V199.609H562.74V198.341Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 198.341H564.634V199.609H565.979V198.341Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 198.341H567.812V199.609H569.157V198.341Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 198.341H571.052V199.609H572.396V198.341Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 204.407H551.678V205.675H553.023V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 204.407H554.917V205.675H556.262V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 204.407H558.156V205.675H559.501V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 204.407H561.396V205.675H562.74V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 204.407H564.634V205.675H565.979V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 204.407H567.812V205.675H569.157V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 204.407H571.052V205.675H572.396V204.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 207.44H551.678V208.708H553.023V207.44Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 207.44H554.917V208.708H556.262V207.44Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 207.44H558.156V208.708H559.501V207.44Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M562.74 207.44H561.396V208.708H562.74V207.44Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 207.44H564.634V208.708H565.979V207.44Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 207.44H567.812V208.708H569.157V207.44Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 207.44H571.052V208.708H572.396V207.44Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 213.506H551.678V214.775H553.023V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 213.506H554.917V214.775H556.262V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 213.506H558.156V214.775H559.501V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 213.506H561.396V214.775H562.74V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 213.506H564.634V214.775H565.979V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 213.506H567.812V214.775H569.157V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 213.506H571.052V214.775H572.396V213.506Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 216.484H551.678V217.753H553.023V216.484Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 216.484H554.917V217.753H556.262V216.484Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 216.484H558.156V217.753H559.501V216.484Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 216.484H561.396V217.753H562.74V216.484Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 216.484H564.634V217.753H565.979V216.484Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 216.484H567.812V217.753H569.157V216.484Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 216.484H571.052V217.753H572.396V216.484Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 222.606H551.678V223.874H553.023V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 222.606H554.917V223.874H556.262V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 222.606H558.156V223.874H559.501V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 222.606H561.396V223.874H562.74V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 222.606H564.634V223.874H565.979V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 222.606H567.812V223.874H569.157V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 222.606H571.052V223.874H572.396V222.606Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 225.584H551.678V226.852H553.023V225.584Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 225.584H554.917V226.852H556.262V225.584Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 225.584H558.156V226.852H559.501V225.584Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 225.584H561.396V226.852H562.74V225.584Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 225.584H564.634V226.852H565.979V225.584Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 225.584H567.812V226.852H569.157V225.584Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 225.584H571.052V226.852H572.396V225.584Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 231.705H551.678V232.974H553.023V231.705Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 231.705H554.917V232.974H556.262V231.705Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 231.705H558.156V232.974H559.501V231.705Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 231.705H561.396V232.974H562.74V231.705Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 231.705H564.634V232.974H565.979V231.705Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 231.705H567.812V232.974H569.157V231.705Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 231.705H571.052V232.974H572.396V231.705Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M553.023 234.683H551.678V235.952H553.023V234.683Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M556.262 234.683H554.917V235.952H556.262V234.683Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M559.501 234.683H558.156V235.952H559.501V234.683Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M562.74 234.683H561.396V235.952H562.74V234.683Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M565.979 234.683H564.634V235.952H565.979V234.683Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M569.157 234.683H567.812V235.952H569.157V234.683Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M572.396 234.683H571.052V235.952H572.396V234.683Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.3")) - ~d:(("M573.863 230.988H550.578V240.474H573.863V230.988Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.6")) - ~d:(("M562.068 131.17H550.578V240.364H562.068V131.17Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M531.877 158.964L549.05 181.741L530.594 206.282L514.765 181.741L531.877 158.964Z") - ) ~stroke:(("#E37056")) - ~strokeWidth:(("3")) - ~strokeMiterlimit:(("10")) - ~strokeLinecap:(("round")) - ~strokeLinejoin:(("round")) ~children:[] - ()) - [@JSX ]); - ((path - ~d:(("M579.73 161.667H584.986L590.425 143.247L579.73 161.667Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M602.77 161.667H597.575L591.586 143.247L602.77 161.667Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M590.058 165.251H589.386V180.472H590.058V165.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M588.897 165.858H588.225V181.079H588.897V165.858Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M587.797 166.41H587.125V181.631H587.797V166.41Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M586.697 167.016H586.025V182.237H586.697V167.016Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M585.536 167.623H584.863V182.844H585.536V167.623Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M584.435 168.174H583.763V183.395H584.435V168.174Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M583.336 168.781H582.663V184.002H583.336V168.781Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M582.174 169.332H581.502V184.553H582.174V169.332Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M593.542 165.251H592.869V180.472H593.542V165.251Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M594.703 165.858H594.03V181.079H594.703V165.858Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M595.803 166.41H595.13V181.631H595.803V166.41Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M596.903 167.016H596.231V182.237H596.903V167.016Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M598.064 167.623H597.392V182.844H598.064V167.623Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M599.164 168.174H598.492V183.395H599.164V168.174Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M600.264 168.781H599.592V184.002H600.264V168.781Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M601.425 169.332H600.753V184.553H601.425V169.332Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M590.058 182.734H589.386V197.955H590.058V182.734Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M588.897 183.285H588.225V198.506H588.897V183.285Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M587.797 183.892H587.125V199.113H587.797V183.892Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M586.697 184.443H586.025V199.664H586.697V184.443Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M585.536 185.05H584.863V200.271H585.536V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M584.435 185.656H583.763V200.877H584.435V185.656Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M583.336 186.208H582.663V201.429H583.336V186.208Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M582.174 186.815H581.502V202.036H582.174V186.815Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M593.542 182.734H592.869V197.955H593.542V182.734Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M594.703 183.285H594.03V198.506H594.703V183.285Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M595.803 183.892H595.13V199.113H595.803V183.892Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M596.903 184.443H596.231V199.664H596.903V184.443Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M598.064 185.05H597.392V200.271H598.064V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M599.164 185.656H598.492V200.877H599.164V185.656Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M600.264 186.208H599.592V201.429H600.264V186.208Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M601.425 186.814H600.753V202.035H601.425V186.814Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M590.058 200.16H589.386V215.381H590.058V200.16Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M588.897 200.767H588.225V215.988H588.897V200.767Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M587.797 201.319H587.125V216.54H587.797V201.319Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M586.697 201.925H586.025V217.146H586.697V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M585.536 202.532H584.863V217.753H585.536V202.532Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M584.435 203.083H583.763V218.304H584.435V203.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M583.336 203.69H582.663V218.911H583.336V203.69Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M582.174 204.241H581.502V219.462H582.174V204.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M593.542 200.16H592.869V215.381H593.542V200.16Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M594.703 200.767H594.03V215.988H594.703V200.767Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M595.803 201.318H595.13V216.54H595.803V201.318Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M596.903 201.925H596.231V217.146H596.903V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M598.064 202.532H597.392V217.753H598.064V202.532Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M599.164 203.083H598.492V218.304H599.164V203.083Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M600.264 203.69H599.592V218.911H600.264V203.69Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M601.425 204.241H600.753V219.462H601.425V204.241Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M590.058 217.643H589.386V232.864H590.058V217.643Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M588.897 218.194H588.225V233.415H588.897V218.194Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M587.797 218.801H587.125V234.022H587.797V218.801Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M586.697 219.407H586.025V234.628H586.697V219.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M585.536 219.959H584.863V235.18H585.536V219.959Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M584.435 220.565H583.763V235.786H584.435V220.565Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M583.336 221.117H582.663V236.338H583.336V221.117Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M582.174 221.724H581.502V236.945H582.174V221.724Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M593.542 217.643H592.869V232.864H593.542V217.643Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M594.703 218.194H594.03V233.415H594.703V218.194Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M595.803 218.801H595.13V234.022H595.803V218.801Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M596.903 219.407H596.231V234.628H596.903V219.407Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M598.064 219.959H597.392V235.18H598.064V219.959Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M599.164 220.565H598.492V235.786H599.164V220.565Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M600.264 221.117H599.592V236.338H600.264V221.117Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M601.425 221.724H600.753V236.945H601.425V221.724Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 134.258H608.331V135.692H609.92V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 134.258H612.976V135.692H614.565V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 134.258H617.62V135.692H619.21V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 134.258H622.265V135.692H623.854V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 134.258H626.91V135.692H628.499V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 134.258H631.555V135.692H633.144V134.258Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 137.622H608.331V139.056H609.92V137.622Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 137.622H612.976V139.056H614.565V137.622Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 137.622H617.62V139.056H619.21V137.622Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 137.622H622.265V139.056H623.854V137.622Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 137.622H626.91V139.056H628.499V137.622Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 137.622H631.555V139.056H633.144V137.622Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 141.041H608.331V142.475H609.92V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 141.041H612.976V142.475H614.565V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 141.041H617.62V142.475H619.21V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 141.041H622.265V142.475H623.854V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 141.041H626.91V142.475H628.499V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 141.041H631.555V142.475H633.144V141.041Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 144.405H608.331V145.839H609.92V144.405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 144.405H612.976V145.839H614.565V144.405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 144.405H617.62V145.839H619.21V144.405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 144.405H622.265V145.839H623.854V144.405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 144.405H626.91V145.839H628.499V144.405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 144.405H631.555V145.839H633.144V144.405Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 147.769H608.331V149.203H609.92V147.769Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 147.769H612.976V149.203H614.565V147.769Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 147.769H617.62V149.203H619.21V147.769Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 147.769H622.265V149.203H623.854V147.769Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 147.769H626.91V149.203H628.499V147.769Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 147.769H631.555V149.203H633.144V147.769Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 151.188H608.331V152.622H609.92V151.188Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 151.188H612.976V152.622H614.565V151.188Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 151.188H617.62V152.622H619.21V151.188Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 151.188H622.265V152.622H623.854V151.188Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 151.188H626.91V152.622H628.499V151.188Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 151.188H631.555V152.622H633.144V151.188Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 154.553H608.331V155.986H609.92V154.553Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 154.553H612.976V155.986H614.565V154.553Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 154.553H617.62V155.986H619.21V154.553Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 154.553H622.265V155.986H623.854V154.553Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 154.553H626.91V155.986H628.499V154.553Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 154.553H631.555V155.986H633.144V154.553Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 157.972H608.331V159.406H609.92V157.972Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 157.972H612.976V159.406H614.565V157.972Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 157.972H617.62V159.406H619.21V157.972Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 157.972H622.265V159.406H623.854V157.972Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 157.972H626.91V159.406H628.499V157.972Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 157.972H631.555V159.406H633.144V157.972Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M609.92 161.336H608.331V162.77H609.92V161.336Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 161.336H612.976V162.77H614.565V161.336Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 161.336H617.62V162.77H619.21V161.336Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 161.336H622.265V162.77H623.854V161.336Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 161.336H626.91V162.77H628.499V161.336Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 161.336H631.555V162.77H633.144V161.336Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M609.92 164.7H608.331V166.134H609.92V164.7Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M614.565 164.7H612.976V166.134H614.565V164.7Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 164.7H617.62V166.134H619.21V164.7Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M623.854 164.7H622.265V166.134H623.854V164.7Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M628.499 164.7H626.91V166.134H628.499V164.7Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M633.144 164.7H631.555V166.134H633.144V164.7Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 168.119H608.331V169.553H609.92V168.119Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 168.119H612.976V169.553H614.565V168.119Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 168.119H617.62V169.553H619.21V168.119Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 168.119H622.265V169.553H623.854V168.119Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 168.119H626.91V169.553H628.499V168.119Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 168.119H631.555V169.553H633.144V168.119Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 171.483H608.331V172.917H609.92V171.483Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 171.483H612.976V172.917H614.565V171.483Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 171.483H617.62V172.917H619.21V171.483Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 171.483H622.265V172.917H623.854V171.483Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 171.483H626.91V172.917H628.499V171.483Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 171.483H631.555V172.917H633.144V171.483Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 174.902H608.331V176.336H609.92V174.902Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 174.902H612.976V176.336H614.565V174.902Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 174.902H617.62V176.336H619.21V174.902Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 174.902H622.265V176.336H623.854V174.902Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 174.902H626.91V176.336H628.499V174.902Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 174.902H631.555V176.336H633.144V174.902Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M609.92 178.266H608.331V179.7H609.92V178.266Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 178.266H612.976V179.7H614.565V178.266Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 178.266H617.62V179.7H619.21V178.266Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 178.266H622.265V179.7H623.854V178.266Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M628.499 178.266H626.91V179.7H628.499V178.266Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 178.266H631.555V179.7H633.144V178.266Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M609.92 181.63H608.331V183.064H609.92V181.63Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 181.63H612.976V183.064H614.565V181.63Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 181.63H617.62V183.064H619.21V181.63Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 181.63H622.265V183.064H623.854V181.63Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M628.499 181.63H626.91V183.064H628.499V181.63Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 181.63H631.555V183.064H633.144V181.63Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M609.92 185.05H608.331V186.484H609.92V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 185.05H612.976V186.484H614.565V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 185.05H617.62V186.484H619.21V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 185.05H622.265V186.484H623.854V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M628.499 185.05H626.91V186.484H628.499V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 185.05H631.555V186.484H633.144V185.05Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 188.414H608.331V189.848H609.92V188.414Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 188.414H612.976V189.848H614.565V188.414Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 188.414H617.62V189.848H619.21V188.414Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 188.414H622.265V189.848H623.854V188.414Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 188.414H626.91V189.848H628.499V188.414Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 188.414H631.555V189.848H633.144V188.414Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 191.833H608.331V193.267H609.92V191.833Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 191.833H612.976V193.267H614.565V191.833Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 191.833H617.62V193.267H619.21V191.833Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 191.833H622.265V193.267H623.854V191.833Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 191.833H626.91V193.267H628.499V191.833Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 191.833H631.555V193.267H633.144V191.833Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 195.197H608.331V196.631H609.92V195.197Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 195.197H612.976V196.631H614.565V195.197Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 195.197H617.62V196.631H619.21V195.197Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 195.197H622.265V196.631H623.854V195.197Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 195.197H626.91V196.631H628.499V195.197Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 195.197H631.555V196.631H633.144V195.197Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M609.92 198.616H608.331V200.05H609.92V198.616Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 198.616H612.976V200.05H614.565V198.616Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 198.616H617.62V200.05H619.21V198.616Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 198.616H622.265V200.05H623.854V198.616Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 198.616H626.91V200.05H628.499V198.616Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 198.616H631.555V200.05H633.144V198.616Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 201.925H608.331V203.359H609.92V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 201.925H612.976V203.359H614.565V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 201.925H617.62V203.359H619.21V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 201.925H622.265V203.359H623.854V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 201.925H626.91V203.359H628.499V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 201.925H631.555V203.359H633.144V201.925Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 205.344H608.331V206.778H609.92V205.344Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 205.344H612.976V206.778H614.565V205.344Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 205.344H617.62V206.778H619.21V205.344Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 205.344H622.265V206.778H623.854V205.344Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 205.344H626.91V206.778H628.499V205.344Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 205.344H631.555V206.778H633.144V205.344Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 208.708H608.331V210.142H609.92V208.708Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 208.708H612.976V210.142H614.565V208.708Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 208.708H617.62V210.142H619.21V208.708Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 208.708H622.265V210.142H623.854V208.708Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 208.708H626.91V210.142H628.499V208.708Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 208.708H631.555V210.142H633.144V208.708Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 212.073H608.331V213.506H609.92V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 212.073H612.976V213.506H614.565V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 212.073H617.62V213.506H619.21V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 212.073H622.265V213.506H623.854V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 212.073H626.91V213.506H628.499V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 212.073H631.555V213.506H633.144V212.073Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 215.492H608.331V216.926H609.92V215.492Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 215.492H612.976V216.926H614.565V215.492Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 215.492H617.62V216.926H619.21V215.492Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 215.492H622.265V216.926H623.854V215.492Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 215.492H626.91V216.926H628.499V215.492Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 215.492H631.555V216.926H633.144V215.492Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M609.92 218.856H608.331V220.29H609.92V218.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 218.856H612.976V220.29H614.565V218.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 218.856H617.62V220.29H619.21V218.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 218.856H622.265V220.29H623.854V218.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 218.856H626.91V220.29H628.499V218.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 218.856H631.555V220.29H633.144V218.856Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 222.275H608.331V223.709H609.92V222.275Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 222.275H612.976V223.709H614.565V222.275Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 222.275H617.62V223.709H619.21V222.275Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 222.275H622.265V223.709H623.854V222.275Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 222.275H626.91V223.709H628.499V222.275Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 222.275H631.555V223.709H633.144V222.275Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 225.639H608.331V227.073H609.92V225.639Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 225.639H612.976V227.073H614.565V225.639Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 225.639H617.62V227.073H619.21V225.639Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 225.639H622.265V227.073H623.854V225.639Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 225.639H626.91V227.073H628.499V225.639Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 225.639H631.555V227.073H633.144V225.639Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 229.003H608.331V230.437H609.92V229.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 229.003H612.976V230.437H614.565V229.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 229.003H617.62V230.437H619.21V229.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 229.003H622.265V230.437H623.854V229.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 229.003H626.91V230.437H628.499V229.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 229.003H631.555V230.437H633.144V229.003Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M609.92 232.422H608.331V233.856H609.92V232.422Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M614.565 232.422H612.976V233.856H614.565V232.422Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~d:(("M619.21 232.422H617.62V233.856H619.21V232.422Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M623.854 232.422H622.265V233.856H623.854V232.422Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M628.499 232.422H626.91V233.856H628.499V232.422Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M633.144 232.422H631.555V233.856H633.144V232.422Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.7")) - ~d:(("M635.894 230.713H605.581V240.474H635.894V230.713Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-cloudRight") - ) ~opacity:(("0.7")) - ~d:(("M609.126 61.903H757.878C757.878 61.903 760.078 50.3218 744.127 48.3364C744.127 48.3364 742.232 27.7108 719.742 20.3761C697.252 13.0413 686.924 24.3468 686.924 24.3468C686.924 24.3468 680.018 16.8466 670.973 17.8944C661.928 18.9422 658.139 29.4205 658.139 29.4205C658.139 29.4205 652.822 26.0564 647.2 28.869C641.577 31.6815 641.883 35.3765 641.883 35.3765C641.883 35.3765 635.405 33.9426 630.821 33.6669C626.238 33.3912 604.237 34.825 609.126 61.903Z") - ) ~fill:(("white")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.5")) - ~d:(("M406.715 74.3666H472.413C472.413 74.3666 472.169 68.2451 465.079 68.2451C465.079 68.2451 463.063 64.8258 452.918 62.7302C442.773 60.6897 432.139 65.4876 432.139 65.4876C432.139 65.4876 429.45 63.8883 426.455 63.8883C423.461 63.8883 422.422 67.3075 422.422 67.3075C422.422 67.3075 406.715 64.881 406.715 74.3666Z") - ) ~fill:(("white")) - ~children:[] ()) - [@JSX ]); - ((path ~opacity:(("0.5")) - ~d:(("M233.09 126.647H283.02C283.02 126.647 277.581 121.022 267.192 117.493C256.802 113.963 250.141 117.493 250.141 117.493C250.141 117.493 247.207 114.68 242.807 117.493C238.407 120.305 239.385 121.298 239.385 121.298C239.385 121.298 231.99 120.36 233.09 126.647Z") - ) ~fill:(("white")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M173.992 45.193C173.992 39.0715 178.392 33.9427 184.504 32.1779C183.037 31.7367 181.509 31.5161 179.859 31.5161C171.487 31.5161 164.703 37.6376 164.703 45.193C164.703 52.7483 171.487 58.8698 179.859 58.8698C181.509 58.8698 183.037 58.6492 184.504 58.208C178.454 56.4433 173.992 51.3145 173.992 45.193Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M245.863 68.4656L246.474 69.5686L247.818 69.734L246.84 70.5613L247.085 71.7194L245.863 71.1679L244.701 71.7194L244.946 70.5613L243.968 69.734L245.313 69.5686L245.863 68.4656Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M334.173 43.2627L334.784 44.4208L336.189 44.5863L335.15 45.5238L335.395 46.7371L334.173 46.1856L332.889 46.7371L333.134 45.5238L332.156 44.5863L333.561 44.4208L334.173 43.2627Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M377.136 23.9056L377.686 24.9534L378.969 25.1188L378.053 25.8909L378.236 27.0491L377.136 26.4976L376.036 27.0491L376.219 25.8909L375.303 25.1188L376.586 24.9534L377.136 23.9056Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M498.815 134.644L499.365 135.692L500.587 135.857L499.67 136.629L499.915 137.732L498.815 137.236L497.653 137.732L497.898 136.629L496.981 135.857L498.203 135.692L498.815 134.644Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M354.096 0.90863L354.646 1.90131L355.868 2.06675L355.013 2.89398L355.196 3.99695L354.096 3.50061L352.935 3.99695L353.179 2.89398L352.263 2.06675L353.546 1.90131L354.096 0.90863Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M160.914 17.9495L161.464 18.9422L162.747 19.1076L161.831 19.9349L162.075 21.0378L160.914 20.4864L159.814 21.0378L159.997 19.9349L159.142 19.1076L160.364 18.9422L160.914 17.9495Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M40.8243 164.314L41.3743 165.362L42.6577 165.527L41.741 166.299L41.9244 167.457L40.8243 166.906L39.7243 167.457L39.9076 166.299L38.9909 165.527L40.2743 165.362L40.8243 164.314Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M380.497 53.9064L381.108 55.0093L382.453 55.1748L381.475 56.002L381.658 57.2153L380.497 56.6638L379.275 57.2153L379.519 56.002L378.542 55.1748L379.886 55.0093L380.497 53.9064Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M216.161 102.272L216.833 103.54L218.361 103.706L217.261 104.643L217.506 106.022L216.161 105.36L214.817 106.022L215.122 104.643L214.022 103.706L215.489 103.54L216.161 102.272Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M97.6606 109.993L98.1495 110.985L99.3718 111.151L98.5162 111.923L98.6995 112.971L97.6606 112.474L96.5605 112.971L96.7439 111.923L95.8883 111.151L97.1105 110.985L97.6606 109.993Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M90.9991 146.28L91.5491 147.273L92.7714 147.438L91.8547 148.21L92.0992 149.258L90.9991 148.762L89.9602 149.258L90.1435 148.21L89.2879 147.438L90.4491 147.273L90.9991 146.28Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M105.239 55.7263L105.728 56.6087L106.828 56.7741L106.033 57.4359L106.217 58.4286L105.239 57.9323L104.261 58.4286L104.444 57.4359L103.711 56.7741L104.75 56.6087L105.239 55.7263Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M115.689 19.4937L116.3 20.5415L117.584 20.7069L116.606 21.5342L116.85 22.6371L115.689 22.0856L114.589 22.6371L114.772 21.5342L113.856 20.7069L115.139 20.5415L115.689 19.4937Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M486.164 101.831L486.347 102.217L486.836 102.272L486.469 102.603L486.592 102.989L486.164 102.823L485.736 102.989L485.797 102.603L485.492 102.272L485.981 102.217L486.164 101.831Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M418.999 18.3907L419.305 18.887L419.977 18.9973L419.488 19.4385L419.61 19.99L418.999 19.7143L418.449 19.99L418.51 19.4385L418.082 18.9973L418.694 18.887L418.999 18.3907Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M558.156 67.9141L558.89 69.2377L560.418 69.4031L559.318 70.451L559.562 71.8848L558.156 71.1679L556.751 71.8848L556.995 70.451L555.834 69.4031L557.423 69.2377L558.156 67.9141Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-starCenterLeft") - ) - ~d:(("M380.497 100.893L381.17 102.161L382.759 102.382L381.658 103.375L381.903 104.809L380.497 104.147L379.092 104.809L379.336 103.375L378.175 102.382L379.764 102.161L380.497 100.893Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-startRight") - ) - ~d:(("M160.914 73.9805L161.647 75.2489L163.236 75.4695L162.075 76.4621L162.319 77.896L160.914 77.2342L159.508 77.896L159.814 76.4621L158.653 75.4695L160.242 75.2489L160.914 73.9805Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M348.473 94.3854L349.146 95.709L350.735 95.8744L349.635 96.9223L349.879 98.3561L348.473 97.6392L347.068 98.3561L347.312 96.9223L346.151 95.8744L347.74 95.709L348.473 94.3854Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M527.783 46.7922L528.271 47.7849L529.494 47.9504L528.638 48.7224L528.822 49.7703L527.783 49.2739L526.682 49.7703L526.866 48.7224L526.01 47.9504L527.233 47.7849L527.783 46.7922Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-starCenterLeft") - ) - ~d:(("M531.877 90.9662L532.427 91.9589L533.649 92.1244L532.733 92.8964L532.977 93.9443L531.877 93.4479L530.838 93.9443L531.022 92.8964L530.166 92.1244L531.388 91.9589L531.877 90.9662Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M632.349 87.8779L632.716 88.4846L633.449 88.5949L632.899 89.0912L633.021 89.753L632.349 89.4221L631.677 89.753L631.799 89.0912L631.249 88.5949L632.043 88.4846L632.349 87.8779Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M683.196 143.357L683.991 144.846L685.824 145.067L684.48 146.225L684.785 147.824L683.196 147.052L681.607 147.824L681.913 146.225L680.629 145.067L682.402 144.846L683.196 143.357Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-starRight") - ) - ~d:(("M669.873 94.3854L671.095 96.7017L673.907 97.0326L671.89 98.7973L672.379 101.334L669.873 100.121L667.368 101.334L667.856 98.7973L665.84 97.0326L668.59 96.7017L669.873 94.3854Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path ~className:(("HeroGraphic-starCenter") - ) - ~d:(("M261.997 28.0417L263.28 30.3028L266.03 30.6888L264.014 32.4536L264.502 34.9904L261.997 33.7771L259.552 34.9904L259.98 32.4536L257.963 30.6888L260.774 30.3028L261.997 28.0417Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M608.331 26.0012L608.698 26.6079L609.431 26.7182L608.881 27.2145L609.003 27.8763L608.331 27.6005L607.659 27.8763L607.781 27.2145L607.231 26.7182L607.964 26.6079L608.331 26.0012Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M656.123 163.211L656.489 163.873L657.284 163.983L656.673 164.479L656.856 165.141L656.123 164.81L655.45 165.141L655.572 164.479L655.022 163.983L655.817 163.873L656.123 163.211Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M497.959 92.4553L498.326 93.117L499.12 93.2273L498.509 93.7237L498.692 94.3855L497.959 94.0546L497.287 94.3855L497.409 93.7237L496.859 93.2273L497.653 93.117L497.959 92.4553Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M506.087 78.8887L506.393 79.4953L507.187 79.6056L506.637 80.1019L506.759 80.8189L506.087 80.488L505.354 80.8189L505.476 80.1019L504.926 79.6056L505.72 79.4953L506.087 78.8887Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M546.239 110.048L546.973 111.426L548.745 111.647L547.461 112.75L547.767 114.294L546.239 113.577L544.711 114.294L544.956 112.75L543.733 111.647L545.445 111.426L546.239 110.048Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M481.947 38.52L482.436 39.4023L483.536 39.5678L482.742 40.2847L482.925 41.2222L481.947 40.7811L480.969 41.2222L481.153 40.2847L480.358 39.5678L481.458 39.4023L481.947 38.52Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M304.349 67.142L304.838 68.0244L305.938 68.1347L305.143 68.8516L305.327 69.8443L304.349 69.348L303.371 69.8443L303.554 68.8516L302.76 68.1347L303.86 68.0244L304.349 67.142Z") - ) ~fill:(("#E37056")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M643.105 244.279C643.105 246.43 641.15 248.195 638.766 248.195H90.0824C87.699 248.195 85.7433 246.43 85.7433 244.279C85.7433 242.129 87.699 240.364 90.0824 240.364H638.766C641.211 240.364 643.105 242.129 643.105 244.279Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M643.105 244.22C643.105 246.371 641.15 248.135 638.766 248.135H90.0824C87.699 248.135 85.7433 246.371 85.7433 244.22C85.7433 242.069 87.699 240.304 90.0824 240.304H638.766C641.211 240.304 643.105 242.069 643.105 244.22Z") - ) ~fill:(("#2484C6")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M124.612 231.485C124.612 231.485 123.817 225.86 127.118 223.985C130.418 222.165 131.64 222.165 131.64 222.165C131.64 222.165 130.54 218.911 133.351 217.477C136.163 216.043 137.446 217.477 137.446 217.477C137.446 217.477 137.752 212.128 141.541 210.97C145.269 209.867 146.246 210.97 146.246 210.97C146.246 210.97 147.958 203.58 153.458 202.697C158.958 201.815 158.958 203.635 158.958 203.635C158.958 203.635 159.569 202.532 162.686 202.422C165.803 202.311 165.681 204.021 165.681 204.021C165.681 204.021 167.697 203.028 170.387 203.58C173.076 204.131 173.076 206.558 173.076 206.558C173.076 206.558 174.298 204.738 179.676 208.543C184.993 212.348 184.198 218.856 184.198 218.856C184.198 218.856 188.293 219.021 188.721 220.676C189.21 222.385 188.11 223.929 188.11 223.929C188.11 223.929 192.938 223.488 193.427 226.025C193.916 228.562 192.815 229.83 192.815 229.83C192.815 229.83 194.527 230.823 194.71 232.919C194.893 235.014 194.71 236.007 194.71 236.007C194.71 236.007 196.299 236.448 196.605 239.371C196.91 242.349 195.504 244.445 195.504 244.445C195.504 244.445 195.504 247.643 191.899 248.195C188.293 248.801 119.112 248.195 119.112 248.195C119.112 248.195 117.095 245.272 118.317 243.728C119.539 242.184 120.334 242.184 120.334 242.184C120.334 242.184 120.028 240.198 120.028 239.757C120.028 239.316 122.351 238.489 122.351 238.489C122.351 238.489 120.762 237.386 121.556 236.393C122.351 235.4 123.451 234.959 123.451 234.959C123.451 234.959 120.578 232.367 124.612 231.485Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M191.654 238.599C191.654 238.599 191.776 232.919 195.443 232.367C199.11 231.816 199.416 232.367 199.416 232.367C199.416 232.367 199.721 230.327 201.433 229.996C203.144 229.61 203.572 229.996 203.572 229.996C203.572 229.996 204.61 226.852 207.85 226.08C211.089 225.308 212.739 229.389 212.739 229.389C212.739 229.389 214.694 228.562 216.283 229.113C217.872 229.665 217.261 231.209 217.261 231.209C217.261 231.209 218.545 230.823 218.85 231.761C219.156 232.698 218.85 233.139 218.85 233.139C218.85 233.139 220.5 232.422 221.417 234.132C222.334 235.897 222.028 236.889 222.028 236.889C222.028 236.889 223.556 235.897 224.045 237.441C224.534 238.985 224.534 239.537 224.534 239.537C224.534 239.537 227.773 238.709 228.017 239.978C228.262 241.246 226.062 242.459 226.062 242.459C226.062 242.459 227.467 243.452 227.467 244.665C227.467 245.879 226.734 246.044 226.734 246.32C226.734 246.596 227.223 247.588 227.162 248.36C227.039 249.077 189.271 248.36 189.271 248.36L191.654 238.599Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M247.329 238.599C247.329 238.599 247.452 232.919 251.118 232.367C254.785 231.816 255.091 232.367 255.091 232.367C255.091 232.367 255.396 230.327 257.108 229.996C258.819 229.61 259.247 229.996 259.247 229.996C259.247 229.996 260.286 226.852 263.525 226.08C266.764 225.308 268.414 229.389 268.414 229.389C268.414 229.389 270.369 228.562 271.958 229.113C273.547 229.665 272.936 231.209 272.936 231.209C272.936 231.209 274.22 230.823 274.525 231.761C274.831 232.698 274.525 233.139 274.525 233.139C274.525 233.139 276.175 232.422 277.092 234.132C278.009 235.897 277.703 236.889 277.703 236.889C277.703 236.889 279.231 235.897 279.72 237.441C280.209 238.985 280.209 239.537 280.209 239.537C280.209 239.537 283.448 238.709 283.692 239.978C283.937 241.246 281.737 242.459 281.737 242.459C281.737 242.459 283.142 243.452 283.142 244.665C283.142 245.879 282.409 246.044 282.409 246.32C282.409 246.596 282.898 247.588 282.837 248.36C282.714 249.077 244.946 248.36 244.946 248.36L247.329 238.599Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M222.089 241.687C222.089 241.687 219.828 233.967 220.989 232.202C222.089 230.437 222.089 230.437 222.089 230.437C222.089 230.437 220.989 228.617 222.089 227.955C223.189 227.294 223.189 227.294 223.189 227.294C223.189 227.294 223.189 224.702 224.839 224.095C226.489 223.433 226.978 224.095 226.978 224.095C226.978 224.095 227.101 220.124 228.69 219.959C230.34 219.793 230.523 220.676 230.523 220.676C230.523 220.676 230.34 218.029 232.54 217.091C234.801 216.154 236.512 218.47 236.512 218.47C236.512 218.47 239.14 218.58 239.568 220.29C239.996 222.054 239.568 223.047 239.568 223.047C239.568 223.047 241.707 223.654 241.401 225.915C241.096 228.176 241.096 228.176 241.096 228.176C241.096 228.176 244.946 226.687 245.985 228.176C247.024 229.665 245.985 230.547 245.985 230.547C245.985 230.547 247.696 230.382 247.696 231.926C247.696 233.47 247.696 234.297 247.696 234.297C247.696 234.297 249.713 233.856 249.957 235.566C250.141 237.331 249.041 238.489 249.041 238.489C249.041 238.489 250.08 239.867 249.957 241.081C249.835 242.294 249.102 242.901 249.102 242.901C249.102 242.901 251.057 242.625 251.546 244.445C252.035 246.265 251.057 246.926 251.057 246.926L251.73 248.526H223.8L222.089 241.687Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M488.547 236.889C488.547 236.889 487.997 233.029 490.258 231.761C492.52 230.492 493.375 230.492 493.375 230.492C493.375 230.492 492.642 228.286 494.536 227.294C496.492 226.301 497.348 227.294 497.348 227.294C497.348 227.294 497.592 223.599 500.159 222.827C502.726 222.054 503.398 222.827 503.398 222.827C503.398 222.827 504.559 217.753 508.348 217.146C512.137 216.54 512.137 217.808 512.137 217.808C512.137 217.808 512.565 217.036 514.704 216.981C516.843 216.926 516.721 218.084 516.721 218.084C516.721 218.084 518.127 217.422 519.96 217.808C521.793 218.194 521.793 219.849 521.793 219.849C521.793 219.849 522.649 218.58 526.316 221.227C529.983 223.819 529.433 228.286 529.433 228.286C529.433 228.286 532.244 228.397 532.55 229.555C532.855 230.713 532.122 231.761 532.122 231.761C532.122 231.761 535.483 231.485 535.789 233.194C536.094 234.959 535.361 235.786 535.361 235.786C535.361 235.786 536.522 236.448 536.644 237.937C536.766 239.371 536.644 240.088 536.644 240.088C536.644 240.088 537.744 240.364 537.928 242.404C538.172 244.445 537.194 245.879 537.194 245.879C537.194 245.879 537.194 248.085 534.75 248.471C532.305 248.912 484.758 248.471 484.758 248.471C484.758 248.471 483.352 246.485 484.208 245.382C485.064 244.334 485.614 244.334 485.614 244.334C485.614 244.334 485.369 242.956 485.369 242.68C485.369 242.404 486.958 241.798 486.958 241.798C486.958 241.798 485.858 241.026 486.408 240.364C486.958 239.702 487.692 239.371 487.692 239.371C487.692 239.371 485.797 237.441 488.547 236.889Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M533.038 238.599C533.038 238.599 533.161 232.919 536.827 232.367C540.494 231.816 540.8 232.367 540.8 232.367C540.8 232.367 541.105 230.327 542.817 229.996C544.528 229.61 544.956 229.996 544.956 229.996C544.956 229.996 545.995 226.852 549.234 226.08C552.473 225.308 554.123 229.389 554.123 229.389C554.123 229.389 556.078 228.562 557.667 229.113C559.318 229.665 558.645 231.209 558.645 231.209C558.645 231.209 559.929 230.823 560.234 231.761C560.54 232.698 560.234 233.139 560.234 233.139C560.234 233.139 561.884 232.422 562.801 234.132C563.718 235.897 563.412 236.889 563.412 236.889C563.412 236.889 564.94 235.897 565.429 237.441C565.918 238.985 565.918 239.537 565.918 239.537C565.918 239.537 569.157 238.709 569.401 239.978C569.585 241.246 567.446 242.459 567.446 242.459C567.446 242.459 568.851 243.452 568.851 244.665C568.851 245.879 568.118 246.044 568.118 246.32C568.118 246.596 568.607 247.588 568.546 248.36C568.424 249.077 530.655 248.36 530.655 248.36L533.038 238.599Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M588.713 238.599C588.713 238.599 588.836 232.919 592.503 232.367C596.169 231.816 596.475 232.367 596.475 232.367C596.475 232.367 596.781 230.327 598.492 229.996C600.203 229.61 600.631 229.996 600.631 229.996C600.631 229.996 601.67 226.852 604.909 226.08C608.148 225.308 609.798 229.389 609.798 229.389C609.798 229.389 611.754 228.562 613.343 229.113C614.993 229.665 614.32 231.209 614.32 231.209C614.32 231.209 615.604 230.823 615.909 231.761C616.215 232.698 615.909 233.139 615.909 233.139C615.909 233.139 617.559 232.422 618.476 234.132C619.393 235.897 619.087 236.889 619.087 236.889C619.087 236.889 620.615 235.897 621.104 237.441C621.593 238.985 621.593 239.537 621.593 239.537C621.593 239.537 624.832 238.709 625.077 239.978C625.26 241.246 623.121 242.459 623.121 242.459C623.121 242.459 624.527 243.452 624.527 244.665C624.527 245.879 623.793 246.044 623.793 246.32C623.793 246.596 624.282 247.588 624.221 248.36C624.099 249.077 586.33 248.36 586.33 248.36L588.713 238.599Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M490.808 240.805C490.808 240.805 490.747 236.338 487.875 235.897C485.003 235.456 484.758 235.897 484.758 235.897C484.758 235.897 484.514 234.297 483.169 234.022C481.825 233.746 481.519 234.022 481.519 234.022C481.519 234.022 480.725 231.54 478.158 230.933C475.591 230.327 474.308 233.525 474.308 233.525C474.308 233.525 472.78 232.864 471.496 233.305C470.213 233.746 470.702 234.959 470.702 234.959C470.702 234.959 469.724 234.684 469.48 235.4C469.235 236.117 469.48 236.503 469.48 236.503C469.48 236.503 468.196 235.952 467.463 237.276C466.729 238.654 466.974 239.426 466.974 239.426C466.974 239.426 465.752 238.654 465.385 239.868C464.957 241.081 464.957 241.522 464.957 241.522C464.957 241.522 462.39 240.86 462.268 241.908C462.085 242.901 463.796 243.838 463.796 243.838C463.796 243.838 462.696 244.61 462.696 245.548C462.696 246.485 463.246 246.651 463.246 246.816C463.246 246.982 462.818 247.809 462.94 248.416C463.001 248.967 492.581 248.416 492.581 248.416L490.808 240.805Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((path - ~d:(("M563.473 241.687C563.473 241.687 561.212 233.967 562.373 232.202C563.473 230.437 563.473 230.437 563.473 230.437C563.473 230.437 562.373 228.617 563.473 227.955C564.573 227.294 564.573 227.294 564.573 227.294C564.573 227.294 564.573 224.702 566.223 224.095C567.874 223.433 568.362 224.095 568.362 224.095C568.362 224.095 568.485 220.124 570.074 219.959C571.724 219.793 571.907 220.676 571.907 220.676C571.907 220.676 571.724 218.029 573.924 217.091C576.185 216.154 577.896 218.47 577.896 218.47C577.896 218.47 580.524 218.58 580.952 220.29C581.38 222.054 580.952 223.047 580.952 223.047C580.952 223.047 583.091 223.654 582.785 225.915C582.48 228.176 582.48 228.176 582.48 228.176C582.48 228.176 586.33 226.687 587.369 228.176C588.408 229.665 587.369 230.547 587.369 230.547C587.369 230.547 589.08 230.382 589.08 231.926C589.08 233.47 589.08 234.297 589.08 234.297C589.08 234.297 591.097 233.856 591.341 235.566C591.525 237.331 590.425 238.489 590.425 238.489C590.425 238.489 591.464 239.867 591.341 241.081C591.219 242.294 590.486 242.901 590.486 242.901C590.486 242.901 592.442 242.625 592.93 244.445C593.419 246.265 592.442 246.926 592.442 246.926L593.114 248.526H565.184L563.473 241.687Z") - ) ~fill:(("#0D1522")) - ~children:[] ()) - [@JSX ]); - ((defs - ~children:[((linearGradient ~id:(("paint0_linear") - ) ~x1:(("374.5") - ) ~y1:(("180.64") - ) ~x2:(("362.765") - ) ~y2:(("435.722") - ) - ~gradientUnits:(("userSpaceOnUse") - ) - ~children:[((stop ~offset:(("0.0658436") - ) - ~stopColor:(("#3A7DDD") - ) - ~children:[] ()) - [@JSX ]); - ((stop ~offset:(("0.4001") - ) - ~stopColor:(("#265291") - ) - ~children:[] ()) - [@JSX ]); - ((stop ~offset:(("0.571") - ) - ~stopColor:(("#1D3E6E") - ) - ~children:[] ()) - [@JSX ]); - ((stop ~offset:(("0.7224") - ) - ~stopColor:(("#173156") - ) - ~children:[] ()) - [@JSX ]); - ((stop ~offset:(("0.8486") - ) - ~stopColor:(("#10213A") - ) - ~children:[] ()) - [@JSX ]); - ((stop ~offset:(("0.9342") - ) - ~stopColor:(("#091321") - ) - ~children:[] ()) - [@JSX ])] ()) - [@JSX ])] ()) - [@JSX ])] ()) - [@JSX ])[@@react.component ] \ No newline at end of file diff --git a/jscomp/syntax/benchmarks/data/HeroGraphic.res b/jscomp/syntax/benchmarks/data/HeroGraphic.res deleted file mode 100644 index 53decfa..0000000 --- a/jscomp/syntax/benchmarks/data/HeroGraphic.res +++ /dev/null @@ -1,2009 +0,0 @@ -%bs.raw(`require('./HeroGraphic.css')`) - -@react.component -let make = (~width="760", ~height="380") => - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/jscomp/syntax/benchmarks/data/Napkinscript.ml b/jscomp/syntax/benchmarks/data/Napkinscript.ml deleted file mode 100644 index 9412f0b..0000000 --- a/jscomp/syntax/benchmarks/data/Napkinscript.ml +++ /dev/null @@ -1,19541 +0,0 @@ -module MiniBuffer : sig - type t - val add_char : t -> char -> unit - val add_string : t -> string -> unit - val contents : t -> string - val create : int -> t - val flush_newline : t -> unit - val length : t -> int - val unsafe_get : t -> int -> char -end = struct - type t = { - mutable buffer : bytes; - mutable position : int; - mutable length : int; - } - - let create n = - let n = if n < 1 then 1 else n in - let s = (Bytes.create [@doesNotRaise]) n in - {buffer = s; position = 0; length = n} - - let contents b = Bytes.sub_string b.buffer 0 b.position - - let unsafe_get b ofs = - Bytes.unsafe_get b.buffer ofs - - let length b = b.position - - (* Can't be called directly, don't add to the interface *) - let resize_internal b more = - let len = b.length in - let new_len = ref len in - while b.position + more > !new_len do new_len := 2 * !new_len done; - if !new_len > Sys.max_string_length then begin - if b.position + more <= Sys.max_string_length - then new_len := Sys.max_string_length - end; - let new_buffer = (Bytes.create [@doesNotRaise]) !new_len in - (* PR#6148: let's keep using [blit] rather than [unsafe_blit] in - this tricky function that is slow anyway. *) - Bytes.blit b.buffer 0 new_buffer 0 b.position [@doesNotRaise]; - b.buffer <- new_buffer; - b.length <- !new_len - - let add_char b c = - let pos = b.position in - if pos >= b.length then resize_internal b 1; - Bytes.unsafe_set b.buffer pos c; - b.position <- pos + 1 - - let add_string b s = - let len = String.length s in - let new_position = b.position + len in - if new_position > b.length then resize_internal b len; - Bytes.blit_string s 0 b.buffer b.position len [@doesNotRaise]; - b.position <- new_position - - (* adds newline and trims all preceding whitespace *) - let flush_newline b = - let position = ref (b.position) in - while (Bytes.unsafe_get b.buffer (!position - 1)) = ' ' && !position >= 0 do - position := !position - 1; - done; - b.position <- !position; - add_char b '\n' -end - -module Doc = struct - type mode = Break | Flat - - type lineStyle = - | Classic (* fits? -> replace with space *) - | Soft (* fits? -> replaced with nothing *) - | Hard (* always included, forces breaks in parents *) - - type t = - | Nil - | Text of string - | Concat of t list - | Indent of t - | IfBreaks of {yes: t; no: t} - | LineSuffix of t - | LineBreak of lineStyle - | Group of {shouldBreak: bool; doc: t} - | CustomLayout of t list - | BreakParent - (* | Cursor *) - - let nil = Nil - let line = LineBreak Classic - let hardLine = LineBreak Hard - let softLine = LineBreak Soft - let text s = Text s - let concat l = Concat l - let indent d = Indent d - let ifBreaks t f = IfBreaks {yes = t; no = f} - let lineSuffix d = LineSuffix d - let group d = Group {shouldBreak = false; doc = d} - let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} - let customLayout gs = CustomLayout gs - let breakParent = BreakParent - (* let cursor = Cursor *) - - let space = Text " " - let comma = Text "," - let dot = Text "." - let dotdot = Text ".." - let dotdotdot = Text "..." - let lessThan = Text "<" - let greaterThan = Text ">" - let lbrace = Text "{" - let rbrace = Text "}" - let lparen = Text "(" - let rparen = Text ")" - let lbracket = Text "[" - let rbracket = Text "]" - let question = Text "?" - let tilde = Text "~" - let equal = Text "=" - let trailingComma = IfBreaks {yes = comma; no = nil} - let doubleQuote = Text "\"" - - let propagateForcedBreaks doc = - let rec walk doc = match doc with - | Text _ | Nil | LineSuffix _ -> - (false, doc) - | BreakParent -> - (true, Nil) - | LineBreak Hard -> - (true, doc) - | LineBreak (Classic | Soft) -> - (false, doc) - | Indent children -> - let (childForcesBreak, newChildren) = walk children in - (childForcesBreak, Indent newChildren) - | IfBreaks {yes = trueDoc; no = falseDoc} -> - let (falseForceBreak, falseDoc) = walk falseDoc in - if falseForceBreak then - let (_, trueDoc) = walk trueDoc in - (true, trueDoc) - else - let forceBreak, trueDoc = walk trueDoc in - (forceBreak, IfBreaks {yes = trueDoc; no = falseDoc}) - | Group {shouldBreak = forceBreak; doc = children} -> - let (childForcesBreak, newChildren) = walk children in - let shouldBreak = forceBreak || childForcesBreak in - (shouldBreak, Group {shouldBreak; doc = newChildren}) - | Concat children -> - let (forceBreak, newChildren) = List.fold_left (fun (forceBreak, newChildren) child -> - let (childForcesBreak, newChild) = walk child in - (forceBreak || childForcesBreak, newChild::newChildren) - ) (false, []) children - in - (forceBreak, Concat (List.rev newChildren)) - | CustomLayout children -> - (* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here *) - let children = match walk (Concat children) with - | (_, Concat children) -> children - | _ -> assert false - in - (false, CustomLayout children) - in - let (_, processedDoc) = walk doc in - processedDoc - - let join ~sep docs = - let rec loop acc sep docs = - match docs with - | [] -> List.rev acc - | [x] -> List.rev (x::acc) - | x::xs -> loop (sep::x::acc) sep xs - in - Concat(loop [] sep docs) - - let rec fits w doc = match doc with - | _ when w < 0 -> false - | [] -> true - | (_ind, _mode, Text txt)::rest -> fits (w - String.length txt) rest - | (ind, mode, Indent doc)::rest -> fits w ((ind + 2, mode, doc)::rest) - | (_ind, Flat, LineBreak break)::rest -> - if break = Hard then true - else - let w = if break = Classic then w - 1 else w in - fits w rest - | (_ind, _mode, Nil)::rest -> fits w rest - | (_ind, Break, LineBreak _break)::_rest -> true - | (ind, mode, Group {shouldBreak = forceBreak; doc})::rest -> - let mode = if forceBreak then Break else mode in - fits w ((ind, mode, doc)::rest) - | (ind, mode, IfBreaks {yes = breakDoc; no = flatDoc})::rest -> - if mode = Break then - fits w ((ind, mode, breakDoc)::rest) - else - fits w ((ind, mode, flatDoc)::rest) - | (ind, mode, Concat docs)::rest -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - fits w (List.append ops rest) - (* | (_ind, _mode, Cursor)::rest -> fits w rest *) - | (_ind, _mode, LineSuffix _)::rest -> fits w rest - | (_ind, _mode, BreakParent)::rest -> fits w rest - | (ind, mode, CustomLayout (hd::_))::rest -> - (* TODO: if we have nested custom layouts, what we should do here? *) - fits w ((ind, mode, hd)::rest) - | (_ind, _mode, CustomLayout _)::rest -> - fits w rest - - let toString ~width doc = - let doc = propagateForcedBreaks doc in - let buffer = MiniBuffer.create 1000 in - - let rec process ~pos lineSuffices stack = - match stack with - | ((ind, mode, doc) as cmd)::rest -> - begin match doc with - | Nil | BreakParent -> - process ~pos lineSuffices rest - | Text txt -> - MiniBuffer.add_string buffer txt; - process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> - process ~pos ((ind, mode, doc)::lineSuffices) rest - | Concat docs -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - process ~pos lineSuffices (List.append ops rest) - | Indent doc -> - process ~pos lineSuffices ((ind + 2, mode, doc)::rest) - | IfBreaks {yes = breakDoc; no = flatDoc} -> - if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc)::rest) - else - process ~pos lineSuffices ((ind, mode, flatDoc)::rest) - | LineBreak lineStyle -> - if mode = Break then ( - begin match lineSuffices with - | [] -> - MiniBuffer.flush_newline buffer; - MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); - process ~pos:ind [] rest - | _docs -> - process ~pos:ind [] (List.concat [List.rev lineSuffices; cmd::rest]) - end - ) else (* mode = Flat *) ( - let pos = match lineStyle with - | Classic -> MiniBuffer.add_string buffer " "; pos + 1 - | Hard -> MiniBuffer.flush_newline buffer; 0 - | Soft -> pos - in - process ~pos lineSuffices rest - ) - | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc)::rest)) then - process ~pos lineSuffices ((ind, Break, doc)::rest) - else - process ~pos lineSuffices ((ind, Flat, doc)::rest) - | CustomLayout docs -> - let rec findGroupThatFits groups = match groups with - | [] -> Nil - | [lastGroup] -> lastGroup - | doc::docs -> - if (fits (width - pos) ((ind, Flat, doc)::rest)) then - doc - else - findGroupThatFits docs - in - let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc)::rest) - end - | [] -> - begin match lineSuffices with - | [] -> () - | suffices -> - process ~pos:0 [] (List.rev suffices) - end - in - process ~pos:0 [] [0, Flat, doc]; - - let len = MiniBuffer.length buffer in - if len > 0 && MiniBuffer.unsafe_get buffer (len - 1) != '\n' then - MiniBuffer.add_char buffer '\n'; - MiniBuffer.contents buffer - - - let debug t = - let rec toDoc = function - | Nil -> text "nil" - | BreakParent -> text "breakparent" - | Text txt -> text ("text(" ^ txt ^ ")") - | LineSuffix doc -> group( - concat [ - text "linesuffix("; - indent ( - concat [line; toDoc doc] - ); - line; - text ")" - ] - ) - | Concat docs -> group( - concat [ - text "concat("; - indent ( - concat [ - line; - join ~sep:(concat [text ","; line]) - (List.map toDoc docs) ; - ] - ); - line; - text ")" - ] - ) - | CustomLayout docs -> group( - concat [ - text "customLayout("; - indent ( - concat [ - line; - join ~sep:(concat [text ","; line]) - (List.map toDoc docs) ; - ] - ); - line; - text ")" - ] - ) - | Indent doc -> - concat [ - text "indent("; - softLine; - toDoc doc; - softLine; - text ")"; - ] - | IfBreaks {yes = trueDoc; no = falseDoc} -> - group( - concat [ - text "ifBreaks("; - indent ( - concat [ - line; - toDoc trueDoc; - concat [text ","; line]; - toDoc falseDoc; - ] - ); - line; - text ")" - ] - ) - | LineBreak break -> - let breakTxt = match break with - | Classic -> "Classic" - | Soft -> "Soft" - | Hard -> "Hard" - in - text ("LineBreak(" ^ breakTxt ^ ")") - | Group {shouldBreak; doc} -> - group( - concat [ - text "Group("; - indent ( - concat [ - line; - text ("shouldBreak: " ^ (string_of_bool shouldBreak)); - concat [text ","; line]; - toDoc doc; - ] - ); - line; - text ")" - ] - ) - in - let doc = toDoc t in - toString ~width:10 doc |> print_endline - [@@live] -end - -module Sexp: sig - type t - - val atom: string -> t - val list: t list -> t - val toString: t -> string -end = struct - type t = - | Atom of string - | List of t list - - let atom s = Atom s - let list l = List l - - let rec toDoc t = - match t with - | Atom s -> Doc.text s - | List [] -> Doc.text "()" - | List [sexpr] -> Doc.concat [Doc.lparen; toDoc sexpr; Doc.rparen;] - | List (hd::tail) -> - Doc.group ( - Doc.concat [ - Doc.lparen; - toDoc hd; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line (List.map toDoc tail); - ] - ); - Doc.rparen; - ] - ) - - let toString sexpr = - let doc = toDoc sexpr in - Doc.toString ~width:80 doc -end - -module SexpAst: sig - val implementation: Parsetree.structure -> Sexp.t - val interface: Parsetree.signature -> Sexp.t -end = struct - open Parsetree - - let mapEmpty ~f items = - match items with - | [] -> [Sexp.list []] - | items -> List.map f items - - let string txt = - Sexp.atom ("\"" ^ txt ^ "\"") - - let char c = - Sexp.atom ("'" ^ (Char.escaped c) ^ "'") - - let optChar oc = - match oc with - | None -> Sexp.atom "None" - | Some c -> - Sexp.list [ - Sexp.atom "Some"; - char c - ] - - let longident l = - let rec loop l = match l with - | Longident.Lident ident -> Sexp.list [ - Sexp.atom "Lident"; - string ident; - ] - | Longident.Ldot (lident, txt) -> - Sexp.list [ - Sexp.atom "Ldot"; - loop lident; - string txt; - ] - | Longident.Lapply (l1, l2) -> - Sexp.list [ - Sexp.atom "Lapply"; - loop l1; - loop l2; - ] - in - Sexp.list [ - Sexp.atom "longident"; - loop l; - ] - - let closedFlag flag = match flag with - | Asttypes.Closed -> Sexp.atom "Closed" - | Open -> Sexp.atom "Open" - - let directionFlag flag = match flag with - | Asttypes.Upto -> Sexp.atom "Upto" - | Downto -> Sexp.atom "Downto" - - let recFlag flag = match flag with - | Asttypes.Recursive -> Sexp.atom "Recursive" - | Nonrecursive -> Sexp.atom "Nonrecursive" - - let overrideFlag flag = match flag with - | Asttypes.Override -> Sexp.atom "Override" - | Fresh -> Sexp.atom "Fresh" - - let privateFlag flag = match flag with - | Asttypes.Public -> Sexp.atom "Public" - | Private -> Sexp.atom "Private" - - let mutableFlag flag = match flag with - | Asttypes.Immutable -> Sexp.atom "Immutable" - | Mutable -> Sexp.atom "Mutable" - - let variance v = match v with - | Asttypes.Covariant -> Sexp.atom "Covariant" - | Contravariant -> Sexp.atom "Contravariant" - | Invariant -> Sexp.atom "Invariant" - - let argLabel lbl = match lbl with - | Asttypes.Nolabel -> Sexp.atom "Nolabel" - | Labelled txt -> Sexp.list [ - Sexp.atom "Labelled"; - string txt; - ] - | Optional txt -> Sexp.list [ - Sexp.atom "Optional"; - string txt; - ] - - let constant c = - let sexpr = match c with - | Pconst_integer (txt, tag) -> - Sexp.list [ - Sexp.atom "Pconst_integer"; - string txt; - optChar tag; - ] - | Pconst_char c -> - Sexp.list [ - Sexp.atom "Pconst_char"; - Sexp.atom (Char.escaped c); - ] - | Pconst_string (txt, tag) -> - Sexp.list [ - Sexp.atom "Pconst_string"; - string txt; - match tag with - | Some txt -> Sexp.list [ - Sexp.atom "Some"; - string txt; - ] - | None -> Sexp.atom "None"; - ] - | Pconst_float (txt, tag) -> - Sexp.list [ - Sexp.atom "Pconst_float"; - string txt; - optChar tag; - ] - in - Sexp.list [ - Sexp.atom "constant"; - sexpr - ] - - let rec structure s = - Sexp.list ( - (Sexp.atom "structure")::(List.map structureItem s) - ) - - and structureItem si = - let desc = match si.pstr_desc with - | Pstr_eval (expr, attrs) -> - Sexp.list [ - Sexp.atom "Pstr_eval"; - expression expr; - attributes attrs; - ] - | Pstr_value (flag, vbs) -> - Sexp.list [ - Sexp.atom "Pstr_value"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs) - ] - | Pstr_primitive (vd) -> - Sexp.list [ - Sexp.atom "Pstr_primitive"; - valueDescription vd; - ] - | Pstr_type (flag, tds) -> - Sexp.list [ - Sexp.atom "Pstr_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration tds) - ] - | Pstr_typext typext -> - Sexp.list [ - Sexp.atom "Pstr_type"; - typeExtension typext; - ] - | Pstr_exception ec -> - Sexp.list [ - Sexp.atom "Pstr_exception"; - extensionConstructor ec; - ] - | Pstr_module mb -> - Sexp.list [ - Sexp.atom "Pstr_module"; - moduleBinding mb; - ] - | Pstr_recmodule mbs -> - Sexp.list [ - Sexp.atom "Pstr_recmodule"; - Sexp.list (mapEmpty ~f:moduleBinding mbs); - ] - | Pstr_modtype modTypDecl -> - Sexp.list [ - Sexp.atom "Pstr_modtype"; - moduleTypeDeclaration modTypDecl; - ] - | Pstr_open openDesc -> - Sexp.list [ - Sexp.atom "Pstr_open"; - openDescription openDesc; - ] - | Pstr_class _ -> Sexp.atom "Pstr_class" - | Pstr_class_type _ -> Sexp.atom "Pstr_class_type" - | Pstr_include id -> - Sexp.list [ - Sexp.atom "Pstr_include"; - includeDeclaration id; - ] - | Pstr_attribute attr -> - Sexp.list [ - Sexp.atom "Pstr_attribute"; - attribute attr; - ] - | Pstr_extension (ext, attrs) -> - Sexp.list [ - Sexp.atom "Pstr_extension"; - extension ext; - attributes attrs; - ] - in - Sexp.list [ - Sexp.atom "structure_item"; - desc; - ] - - and includeDeclaration id = - Sexp.list [ - Sexp.atom "include_declaration"; - moduleExpression id.pincl_mod; - attributes id.pincl_attributes; - ] - - and openDescription od = - Sexp.list [ - Sexp.atom "open_description"; - longident od.popen_lid.Asttypes.txt; - attributes od.popen_attributes; - ] - - and moduleTypeDeclaration mtd = - Sexp.list [ - Sexp.atom "module_type_declaration"; - string mtd.pmtd_name.Asttypes.txt; - (match mtd.pmtd_type with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [ - Sexp.atom "Some"; - moduleType modType; - ]); - attributes mtd.pmtd_attributes; - ] - - and moduleBinding mb = - Sexp.list [ - Sexp.atom "module_binding"; - string mb.pmb_name.Asttypes.txt; - moduleExpression mb.pmb_expr; - attributes mb.pmb_attributes; - ] - - and moduleExpression me = - let desc = match me.pmod_desc with - | Pmod_ident modName -> - Sexp.list [ - Sexp.atom "Pmod_ident"; - longident modName.Asttypes.txt; - ] - | Pmod_structure s -> - Sexp.list [ - Sexp.atom "Pmod_structure"; - structure s; - ] - | Pmod_functor (lbl, optModType, modExpr) -> - Sexp.list [ - Sexp.atom "Pmod_functor"; - string lbl.Asttypes.txt; - (match optModType with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [ - Sexp.atom "Some"; - moduleType modType; - ]); - moduleExpression modExpr; - ] - | Pmod_apply (callModExpr, modExprArg) -> - Sexp.list [ - Sexp.atom "Pmod_apply"; - moduleExpression callModExpr; - moduleExpression modExprArg; - ] - | Pmod_constraint (modExpr, modType) -> - Sexp.list [ - Sexp.atom "Pmod_constraint"; - moduleExpression modExpr; - moduleType modType; - ] - | Pmod_unpack expr -> - Sexp.list [ - Sexp.atom "Pmod_unpack"; - expression expr; - ] - | Pmod_extension ext -> - Sexp.list [ - Sexp.atom "Pmod_extension"; - extension ext; - ] - in - Sexp.list [ - Sexp.atom "module_expr"; - desc; - attributes me.pmod_attributes; - ] - - and moduleType mt = - let desc = match mt.pmty_desc with - | Pmty_ident longidentLoc -> - Sexp.list [ - Sexp.atom "Pmty_ident"; - longident longidentLoc.Asttypes.txt; - ] - | Pmty_signature s -> - Sexp.list [ - Sexp.atom "Pmty_signature"; - signature s; - ] - | Pmty_functor (lbl, optModType, modType) -> - Sexp.list [ - Sexp.atom "Pmty_functor"; - string lbl.Asttypes.txt; - (match optModType with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [ - Sexp.atom "Some"; - moduleType modType; - ]); - moduleType modType; - ] - | Pmty_alias longidentLoc -> - Sexp.list [ - Sexp.atom "Pmty_alias"; - longident longidentLoc.Asttypes.txt; - ] - | Pmty_extension ext -> - Sexp.list [ - Sexp.atom "Pmty_extension"; - extension ext; - ] - | Pmty_typeof modExpr -> - Sexp.list [ - Sexp.atom "Pmty_typeof"; - moduleExpression modExpr; - ] - | Pmty_with (modType, withConstraints) -> - Sexp.list [ - Sexp.atom "Pmty_with"; - moduleType modType; - Sexp.list (mapEmpty ~f:withConstraint withConstraints); - ] - in - Sexp.list [ - Sexp.atom "module_type"; - desc; - attributes mt.pmty_attributes; - ] - - and withConstraint wc = match wc with - | Pwith_type (longidentLoc, td) -> - Sexp.list [ - Sexp.atom "Pmty_with"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; - ] - | Pwith_module (l1, l2) -> - Sexp.list [ - Sexp.atom "Pwith_module"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] - | Pwith_typesubst (longidentLoc, td) -> - Sexp.list [ - Sexp.atom "Pwith_typesubst"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; - ] - | Pwith_modsubst (l1, l2) -> - Sexp.list [ - Sexp.atom "Pwith_modsubst"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] - - and signature s = - Sexp.list ( - (Sexp.atom "signature")::(List.map signatureItem s) - ) - - and signatureItem si = - let descr = match si.psig_desc with - | Psig_value vd -> - Sexp.list [ - Sexp.atom "Psig_value"; - valueDescription vd; - ] - | Psig_type (flag, typeDeclarations) -> - Sexp.list [ - Sexp.atom "Psig_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration typeDeclarations); - ] - | Psig_typext typExt -> - Sexp.list [ - Sexp.atom "Psig_typext"; - typeExtension typExt; - ] - | Psig_exception extConstr -> - Sexp.list [ - Sexp.atom "Psig_exception"; - extensionConstructor extConstr; - ] - | Psig_module modDecl -> - Sexp.list [ - Sexp.atom "Psig_module"; - moduleDeclaration modDecl; - ] - | Psig_recmodule modDecls -> - Sexp.list [ - Sexp.atom "Psig_recmodule"; - Sexp.list (mapEmpty ~f:moduleDeclaration modDecls); - ] - | Psig_modtype modTypDecl -> - Sexp.list [ - Sexp.atom "Psig_modtype"; - moduleTypeDeclaration modTypDecl; - ] - | Psig_open openDesc -> - Sexp.list [ - Sexp.atom "Psig_open"; - openDescription openDesc; - ] - | Psig_include inclDecl -> - Sexp.list [ - Sexp.atom "Psig_include"; - includeDescription inclDecl - ] - | Psig_class _ -> Sexp.list [Sexp.atom "Psig_class";] - | Psig_class_type _ -> Sexp.list [ Sexp.atom "Psig_class_type"; ] - | Psig_attribute attr -> - Sexp.list [ - Sexp.atom "Psig_attribute"; - attribute attr; - ] - | Psig_extension (ext, attrs) -> - Sexp.list [ - Sexp.atom "Psig_extension"; - extension ext; - attributes attrs; - ] - in - Sexp.list [ - Sexp.atom "signature_item"; - descr; - ] - - and includeDescription id = - Sexp.list [ - Sexp.atom "include_description"; - moduleType id.pincl_mod; - attributes id.pincl_attributes; - ] - - and moduleDeclaration md = - Sexp.list [ - Sexp.atom "module_declaration"; - string md.pmd_name.Asttypes.txt; - moduleType md.pmd_type; - attributes md.pmd_attributes; - ] - - and valueBinding vb = - Sexp.list [ - Sexp.atom "value_binding"; - pattern vb.pvb_pat; - expression vb.pvb_expr; - attributes vb.pvb_attributes; - ] - - and valueDescription vd = - Sexp.list [ - Sexp.atom "value_description"; - string vd.pval_name.Asttypes.txt; - coreType vd.pval_type; - Sexp.list (mapEmpty ~f:string vd.pval_prim); - attributes vd.pval_attributes; - ] - - and typeDeclaration td = - Sexp.list [ - Sexp.atom "type_declaration"; - string td.ptype_name.Asttypes.txt; - Sexp.list [ - Sexp.atom "ptype_params"; - Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> - Sexp.list [ - coreType typexpr; - variance var; - ]) td.ptype_params) - ]; - Sexp.list [ - Sexp.atom "ptype_cstrs"; - Sexp.list (mapEmpty ~f:(fun (typ1, typ2, _loc) -> - Sexp.list [ - coreType typ1; - coreType typ2; - ]) td.ptype_cstrs) - ]; - Sexp.list [ - Sexp.atom "ptype_kind"; - typeKind td.ptype_kind; - ]; - Sexp.list [ - Sexp.atom "ptype_manifest"; - match td.ptype_manifest with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ] - ]; - Sexp.list [ - Sexp.atom "ptype_private"; - privateFlag td.ptype_private; - ]; - attributes td.ptype_attributes; - ] - - and extensionConstructor ec = - Sexp.list [ - Sexp.atom "extension_constructor"; - string ec.pext_name.Asttypes.txt; - extensionConstructorKind ec.pext_kind; - attributes ec.pext_attributes; - ] - - and extensionConstructorKind kind = match kind with - | Pext_decl (args, optTypExpr) -> - Sexp.list [ - Sexp.atom "Pext_decl"; - constructorArguments args; - match optTypExpr with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ] - ] - | Pext_rebind longidentLoc -> - Sexp.list [ - Sexp.atom "Pext_rebind"; - longident longidentLoc.Asttypes.txt; - ] - - and typeExtension te = - Sexp.list [ - Sexp.atom "type_extension"; - Sexp.list [ - Sexp.atom "ptyext_path"; - longident te.ptyext_path.Asttypes.txt; - ]; - Sexp.list [ - Sexp.atom "ptyext_parms"; - Sexp.list (mapEmpty ~f:(fun (typexpr, var) -> - Sexp.list [ - coreType typexpr; - variance var; - ]) te.ptyext_params) - ]; - Sexp.list [ - Sexp.atom "ptyext_constructors"; - Sexp.list (mapEmpty ~f:extensionConstructor te.ptyext_constructors); - ]; - Sexp.list [ - Sexp.atom "ptyext_private"; - privateFlag te.ptyext_private; - ]; - attributes te.ptyext_attributes; - ] - - and typeKind kind = match kind with - | Ptype_abstract -> Sexp.atom "Ptype_abstract" - | Ptype_variant constrDecls -> - Sexp.list [ - Sexp.atom "Ptype_variant"; - Sexp.list (mapEmpty ~f:constructorDeclaration constrDecls); - ] - | Ptype_record lblDecls -> - Sexp.list [ - Sexp.atom "Ptype_record"; - Sexp.list (mapEmpty ~f:labelDeclaration lblDecls); - ] - | Ptype_open -> Sexp.atom "Ptype_open" - - and constructorDeclaration cd = - Sexp.list [ - Sexp.atom "constructor_declaration"; - string cd.pcd_name.Asttypes.txt; - Sexp.list [ - Sexp.atom "pcd_args"; - constructorArguments cd.pcd_args; - ]; - Sexp.list [ - Sexp.atom "pcd_res"; - match cd.pcd_res with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ] - ]; - attributes cd.pcd_attributes; - ] - - and constructorArguments args = match args with - | Pcstr_tuple types -> - Sexp.list [ - Sexp.atom "Pcstr_tuple"; - Sexp.list (mapEmpty ~f:coreType types) - ] - | Pcstr_record lds -> - Sexp.list [ - Sexp.atom "Pcstr_record"; - Sexp.list (mapEmpty ~f:labelDeclaration lds) - ] - - and labelDeclaration ld = - Sexp.list [ - Sexp.atom "label_declaration"; - string ld.pld_name.Asttypes.txt; - mutableFlag ld.pld_mutable; - coreType ld.pld_type; - attributes ld.pld_attributes; - ] - - and expression expr = - let desc = match expr.pexp_desc with - | Pexp_ident longidentLoc -> - Sexp.list [ - Sexp.atom "Pexp_ident"; - longident longidentLoc.Asttypes.txt; - ] - | Pexp_constant c -> - Sexp.list [ - Sexp.atom "Pexp_constant"; - constant c - ] - | Pexp_let (flag, vbs, expr) -> - Sexp.list [ - Sexp.atom "Pexp_let"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs); - expression expr; - ] - | Pexp_function cases -> - Sexp.list [ - Sexp.atom "Pexp_function"; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_fun (argLbl, exprOpt, pat, expr) -> - Sexp.list [ - Sexp.atom "Pexp_fun"; - argLabel argLbl; - (match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [ - Sexp.atom "Some"; - expression expr; - ]); - pattern pat; - expression expr; - ] - | Pexp_apply (expr, args) -> - Sexp.list [ - Sexp.atom "Pexp_apply"; - expression expr; - Sexp.list (mapEmpty ~f:(fun (argLbl, expr) -> Sexp.list [ - argLabel argLbl; - expression expr - ]) args); - ] - | Pexp_match (expr, cases) -> - Sexp.list [ - Sexp.atom "Pexp_match"; - expression expr; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_try (expr, cases) -> - Sexp.list [ - Sexp.atom "Pexp_try"; - expression expr; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_tuple exprs -> - Sexp.list [ - Sexp.atom "Pexp_tuple"; - Sexp.list (mapEmpty ~f:expression exprs); - ] - | Pexp_construct (longidentLoc, exprOpt) -> - Sexp.list [ - Sexp.atom "Pexp_construct"; - longident longidentLoc.Asttypes.txt; - match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; - expression expr; - ] - ] - | Pexp_variant (lbl, exprOpt) -> - Sexp.list [ - Sexp.atom "Pexp_variant"; - string lbl; - match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; - expression expr; - ] - ] - | Pexp_record (rows, optExpr) -> - Sexp.list [ - Sexp.atom "Pexp_record"; - Sexp.list (mapEmpty ~f:(fun (longidentLoc, expr) -> Sexp.list [ - longident longidentLoc.Asttypes.txt; - expression expr; - ]) rows); - (match optExpr with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; - expression expr; - ]); - ] - | Pexp_field (expr, longidentLoc) -> - Sexp.list [ - Sexp.atom "Pexp_field"; - expression expr; - longident longidentLoc.Asttypes.txt; - ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - Sexp.list [ - Sexp.atom "Pexp_setfield"; - expression expr1; - longident longidentLoc.Asttypes.txt; - expression expr2; - ] - | Pexp_array exprs -> - Sexp.list [ - Sexp.atom "Pexp_array"; - Sexp.list (mapEmpty ~f:expression exprs); - ] - | Pexp_ifthenelse (expr1, expr2, optExpr) -> - Sexp.list [ - Sexp.atom "Pexp_ifthenelse"; - expression expr1; - expression expr2; - (match optExpr with - | None -> Sexp.atom "None" - | Some expr -> - Sexp.list [ - Sexp.atom "Some"; - expression expr; - ]); - ] - | Pexp_sequence (expr1, expr2) -> - Sexp.list [ - Sexp.atom "Pexp_sequence"; - expression expr1; - expression expr2; - ] - | Pexp_while (expr1, expr2) -> - Sexp.list [ - Sexp.atom "Pexp_while"; - expression expr1; - expression expr2; - ] - | Pexp_for (pat, e1, e2, flag, e3) -> - Sexp.list [ - Sexp.atom "Pexp_for"; - pattern pat; - expression e1; - expression e2; - directionFlag flag; - expression e3; - ] - | Pexp_constraint (expr, typexpr) -> - Sexp.list [ - Sexp.atom "Pexp_constraint"; - expression expr; - coreType typexpr; - ] - | Pexp_coerce (expr, optTyp, typexpr) -> - Sexp.list [ - Sexp.atom "Pexp_coerce"; - expression expr; - (match optTyp with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [ - Sexp.atom "Some"; - coreType typ; - ]); - coreType typexpr; - ] - | Pexp_send _ -> - Sexp.list [ - Sexp.atom "Pexp_send"; - ] - | Pexp_new _ -> - Sexp.list [ - Sexp.atom "Pexp_new"; - ] - | Pexp_setinstvar _ -> - Sexp.list [ - Sexp.atom "Pexp_setinstvar"; - ] - | Pexp_override _ -> - Sexp.list [ - Sexp.atom "Pexp_override"; - ] - | Pexp_letmodule (modName, modExpr, expr) -> - Sexp.list [ - Sexp.atom "Pexp_letmodule"; - string modName.Asttypes.txt; - moduleExpression modExpr; - expression expr; - ] - | Pexp_letexception (extConstr, expr) -> - Sexp.list [ - Sexp.atom "Pexp_letexception"; - extensionConstructor extConstr; - expression expr; - ] - | Pexp_assert expr -> - Sexp.list [ - Sexp.atom "Pexp_assert"; - expression expr; - ] - | Pexp_lazy expr -> - Sexp.list [ - Sexp.atom "Pexp_lazy"; - expression expr; - ] - | Pexp_poly _ -> - Sexp.list [ - Sexp.atom "Pexp_poly"; - ] - | Pexp_object _ -> - Sexp.list [ - Sexp.atom "Pexp_object"; - ] - | Pexp_newtype (lbl, expr) -> - Sexp.list [ - Sexp.atom "Pexp_newtype"; - string lbl.Asttypes.txt; - expression expr; - ] - | Pexp_pack modExpr -> - Sexp.list [ - Sexp.atom "Pexp_pack"; - moduleExpression modExpr; - ] - | Pexp_open (flag, longidentLoc, expr) -> - Sexp.list [ - Sexp.atom "Pexp_open"; - overrideFlag flag; - longident longidentLoc.Asttypes.txt; - expression expr; - ] - | Pexp_extension ext -> - Sexp.list [ - Sexp.atom "Pexp_extension"; - extension ext; - ] - | Pexp_unreachable -> Sexp.atom "Pexp_unreachable" - in - Sexp.list [ - Sexp.atom "expression"; - desc; - ] - - and case c = - Sexp.list [ - Sexp.atom "case"; - Sexp.list [ - Sexp.atom "pc_lhs"; - pattern c.pc_lhs; - ]; - Sexp.list [ - Sexp.atom "pc_guard"; - match c.pc_guard with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [ - Sexp.atom "Some"; - expression expr; - ] - ]; - Sexp.list [ - Sexp.atom "pc_rhs"; - expression c.pc_rhs; - ] - ] - - and pattern p = - let descr = match p.ppat_desc with - | Ppat_any -> - Sexp.atom "Ppat_any" - | Ppat_var var -> - Sexp.list [ - Sexp.atom "Ppat_var"; - string var.Location.txt; - ] - | Ppat_alias (p, alias) -> - Sexp.list [ - Sexp.atom "Ppat_alias"; - pattern p; - string alias.txt; - ] - | Ppat_constant c -> - Sexp.list [ - Sexp.atom "Ppat_constant"; - constant c; - ] - | Ppat_interval (lo, hi) -> - Sexp.list [ - Sexp.atom "Ppat_interval"; - constant lo; - constant hi; - ] - | Ppat_tuple (patterns) -> - Sexp.list [ - Sexp.atom "Ppat_tuple"; - Sexp.list (mapEmpty ~f:pattern patterns); - ] - | Ppat_construct (longidentLoc, optPattern) -> - Sexp.list [ - Sexp.atom "Ppat_construct"; - longident longidentLoc.Location.txt; - match optPattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [ - Sexp.atom "some"; - pattern p; - ] - ] - | Ppat_variant (lbl, optPattern) -> - Sexp.list [ - Sexp.atom "Ppat_variant"; - string lbl; - match optPattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [ - Sexp.atom "Some"; - pattern p; - ] - ] - | Ppat_record (rows, flag) -> - Sexp.list [ - Sexp.atom "Ppat_record"; - closedFlag flag; - Sexp.list (mapEmpty ~f:(fun (longidentLoc, p) -> - Sexp.list [ - longident longidentLoc.Location.txt; - pattern p; - ] - ) rows) - ] - | Ppat_array patterns -> - Sexp.list [ - Sexp.atom "Ppat_array"; - Sexp.list (mapEmpty ~f:pattern patterns); - ] - | Ppat_or (p1, p2) -> - Sexp.list [ - Sexp.atom "Ppat_or"; - pattern p1; - pattern p2; - ] - | Ppat_constraint (p, typexpr) -> - Sexp.list [ - Sexp.atom "Ppat_constraint"; - pattern p; - coreType typexpr; - ] - | Ppat_type longidentLoc -> - Sexp.list [ - Sexp.atom "Ppat_type"; - longident longidentLoc.Location.txt - ] - | Ppat_lazy p -> - Sexp.list [ - Sexp.atom "Ppat_lazy"; - pattern p; - ] - | Ppat_unpack stringLoc -> - Sexp.list [ - Sexp.atom "Ppat_unpack"; - string stringLoc.Location.txt; - ] - | Ppat_exception p -> - Sexp.list [ - Sexp.atom "Ppat_exception"; - pattern p; - ] - | Ppat_extension ext -> - Sexp.list [ - Sexp.atom "Ppat_extension"; - extension ext; - ] - | Ppat_open (longidentLoc, p) -> - Sexp.list [ - Sexp.atom "Ppat_open"; - longident longidentLoc.Location.txt; - pattern p; - ] - in - Sexp.list [ - Sexp.atom "pattern"; - descr; - ] - - and objectField field = match field with - | Otag (lblLoc, attrs, typexpr) -> - Sexp.list [ - Sexp.atom "Otag"; - string lblLoc.txt; - attributes attrs; - coreType typexpr; - ] - | Oinherit typexpr -> - Sexp.list [ - Sexp.atom "Oinherit"; - coreType typexpr; - ] - - and rowField field = match field with - | Rtag (labelLoc, attrs, truth, types) -> - Sexp.list [ - Sexp.atom "Rtag"; - string labelLoc.txt; - attributes attrs; - Sexp.atom (if truth then "true" else "false"); - Sexp.list (mapEmpty ~f:coreType types); - ] - | Rinherit typexpr -> - Sexp.list [ - Sexp.atom "Rinherit"; - coreType typexpr; - ] - - and packageType (modNameLoc, packageConstraints) = - Sexp.list [ - Sexp.atom "package_type"; - longident modNameLoc.Asttypes.txt; - Sexp.list (mapEmpty ~f:(fun (modNameLoc, typexpr) -> - Sexp.list [ - longident modNameLoc.Asttypes.txt; - coreType typexpr; - ] - ) packageConstraints) - ] - - and coreType typexpr = - let desc = match typexpr.ptyp_desc with - | Ptyp_any -> Sexp.atom "Ptyp_any" - | Ptyp_var var -> Sexp.list [ - Sexp.atom "Ptyp_var"; - string var - ] - | Ptyp_arrow (argLbl, typ1, typ2) -> - Sexp.list [ - Sexp.atom "Ptyp_arrow"; - argLabel argLbl; - coreType typ1; - coreType typ2; - ] - | Ptyp_tuple types -> - Sexp.list [ - Sexp.atom "Ptyp_tuple"; - Sexp.list (mapEmpty ~f:coreType types); - ] - | Ptyp_constr (longidentLoc, types) -> - Sexp.list [ - Sexp.atom "Ptyp_constr"; - longident longidentLoc.txt; - Sexp.list (mapEmpty ~f:coreType types); - ] - | Ptyp_alias (typexpr, alias) -> - Sexp.list [ - Sexp.atom "Ptyp_alias"; - coreType typexpr; - string alias; - ] - | Ptyp_object (fields, flag) -> - Sexp.list [ - Sexp.atom "Ptyp_object"; - closedFlag flag; - Sexp.list (mapEmpty ~f:objectField fields) - ] - | Ptyp_class (longidentLoc, types) -> - Sexp.list [ - Sexp.atom "Ptyp_class"; - longident longidentLoc.Location.txt; - Sexp.list (mapEmpty ~f:coreType types) - ] - | Ptyp_variant (fields, flag, optLabels) -> - Sexp.list [ - Sexp.atom "Ptyp_variant"; - Sexp.list (mapEmpty ~f:rowField fields); - closedFlag flag; - match optLabels with - | None -> Sexp.atom "None" - | Some lbls -> Sexp.list (mapEmpty ~f:string lbls); - ] - | Ptyp_poly (lbls, typexpr) -> - Sexp.list [ - Sexp.atom "Ptyp_poly"; - Sexp.list (mapEmpty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); - coreType typexpr; - ] - | Ptyp_package (package) -> - Sexp.list [ - Sexp.atom "Ptyp_package"; - packageType package; - ] - | Ptyp_extension (ext) -> - Sexp.list [ - Sexp.atom "Ptyp_extension"; - extension ext; - ] - in - Sexp.list [ - Sexp.atom "core_type"; - desc; - ] - - and payload p = - match p with - | PStr s -> - Sexp.list ( - (Sexp.atom "PStr")::(mapEmpty ~f:structureItem s) - ) - | PSig s -> - Sexp.list [ - Sexp.atom "PSig"; - signature s; - ] - | PTyp ct -> - Sexp.list [ - Sexp.atom "PTyp"; - coreType ct - ] - | PPat (pat, optExpr) -> - Sexp.list [ - Sexp.atom "PPat"; - pattern pat; - match optExpr with - | Some expr -> Sexp.list [ - Sexp.atom "Some"; - expression expr; - ] - | None -> Sexp.atom "None"; - ] - - and attribute (stringLoc, p) = - Sexp.list [ - Sexp.atom "attribute"; - Sexp.atom stringLoc.Asttypes.txt; - payload p; - ] - - and extension (stringLoc, p) = - Sexp.list [ - Sexp.atom "extension"; - Sexp.atom stringLoc.Asttypes.txt; - payload p; - ] - - and attributes attrs = - let sexprs = mapEmpty ~f:attribute attrs in - Sexp.list ((Sexp.atom "attributes")::sexprs) - - let implementation = structure - let interface = signature -end - -module IO: sig - val readFile: string -> string - val readStdin: unit -> string -end = struct - (* random chunk size: 2^15, TODO: why do we guess randomly? *) - let chunkSize = 32768 - - let readFile filename = - let chan = open_in filename in - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input chan chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr chan; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () - - let readStdin () = - let buffer = Buffer.create chunkSize in - let chunk = (Bytes.create [@doesNotRaise]) chunkSize in - let rec loop () = - let len = try input stdin chunk 0 chunkSize with Invalid_argument _ -> 0 in - if len == 0 then ( - close_in_noerr stdin; - Buffer.contents buffer - ) else ( - Buffer.add_subbytes buffer chunk 0 len; - loop () - ) - in - loop () -end - -module CharacterCodes = struct - let eof = -1 - - let space = 0x0020 - let newline = 0x0A (* \n *) [@@live] - let lineFeed = 0x0A (* \n *) - let carriageReturn = 0x0D (* \r *) - let lineSeparator = 0x2028 - let paragraphSeparator = 0x2029 - - let tab = 0x09 - - let bang = 0x21 - let dot = 0x2E - let colon = 0x3A - let comma = 0x2C - let backtick = 0x60 - (* let question = 0x3F *) - let semicolon = 0x3B - let underscore = 0x5F - let singleQuote = 0x27 - let doubleQuote = 0x22 - let equal = 0x3D - let bar = 0x7C - let tilde = 0x7E - let question = 0x3F - let ampersand = 0x26 - let at = 0x40 - let dollar = 0x24 - let percent = 0x25 - - let lparen = 0x28 - let rparen = 0x29 - let lbracket = 0x5B - let rbracket = 0x5D - let lbrace = 0x7B - let rbrace = 0x7D - - let forwardslash = 0x2F (* / *) - let backslash = 0x5C (* \ *) - - let greaterThan = 0x3E - let hash = 0x23 - let lessThan = 0x3C - - let minus = 0x2D - let plus = 0x2B - let asterisk = 0x2A - - let _0 = 0x30 - let _1 = 0x31 [@@live] - let _2 = 0x32 [@@live] - let _3 = 0x33 [@@live] - let _4 = 0x34 [@@live] - let _5 = 0x35 [@@live] - let _6 = 0x36 [@@live] - let _7 = 0x37 [@@live] - let _8 = 0x38 [@@live] - let _9 = 0x39 - - module Lower = struct - let a = 0x61 - let b = 0x62 - let c = 0x63 [@@live] - let d = 0x64 [@@live] - let e = 0x65 - let f = 0x66 - let g = 0x67 - let h = 0x68 [@@live] - let i = 0x69 [@@live] - let j = 0x6A [@@live] - let k = 0x6B [@@live] - let l = 0x6C [@@live] - let m = 0x6D [@@live] - let n = 0x6E - let o = 0x6F - let p = 0x70 - let q = 0x71 [@@live] - let r = 0x72 - let s = 0x73 [@@live] - let t = 0x74 - let u = 0x75 [@@live] - let v = 0x76 [@@live] - let w = 0x77 [@@live] - let x = 0x78 - let y = 0x79 [@@live] - let z = 0x7A - end - - module Upper = struct - let a = 0x41 - (* let b = 0x42 *) - let c = 0x43 [@@live] - let d = 0x44 [@@live] - let e = 0x45 [@@live] - let f = 0x46 [@@live] - let g = 0x47 - let h = 0x48 [@@live] - let i = 0x49 [@@live] - let j = 0x4A [@@live] - let k = 0x4B [@@live] - let l = 0x4C [@@live] - let m = 0x4D [@@live] - let b = 0x4E [@@live] - let o = 0x4F [@@live] - let p = 0x50 [@@live] - let q = 0x51 [@@live] - let r = 0x52 [@@live] - let s = 0x53 [@@live] - let t = 0x54 [@@live] - let u = 0x55 [@@live] - let v = 0x56 [@@live] - let w = 0x57 [@@live] - let x = 0x58 [@@live] - let y = 0x59 [@@live] - let z = 0x5a - end - - (* returns lower-case ch, ch should be ascii *) - let lower ch = - (* if ch >= Lower.a && ch <= Lower.z then ch else ch + 32 *) - 32 lor ch - - let isLetter ch = - Lower.a <= ch && ch <= Lower.z || - Upper.a <= ch && ch <= Upper.z - - let isUpperCase ch = - Upper.a <= ch && ch <= Upper.z - - let isDigit ch = _0 <= ch && ch <= _9 - - let isHex ch = - (_0 <= ch && ch <= _9) || - (Lower.a <= (lower ch) && (lower ch) <= Lower.f) - - (* - // ES5 7.3: - // The ECMAScript line terminator characters are listed in Table 3. - // Table 3: Line Terminator Characters - // Code Unit Value Name Formal Name - // \u000A Line Feed - // \u000D Carriage Return - // \u2028 Line separator - // \u2029 Paragraph separator - // Only the characters in Table 3 are treated as line terminators. Other new line or line - // breaking characters are treated as white space but not as line terminators. - *) - let isLineBreak ch = - ch == lineFeed - || ch == carriageReturn - || ch == lineSeparator - || ch == paragraphSeparator - - let digitValue ch = - if _0 <= ch && ch <= _9 then - ch - 48 - else if Lower.a <= (lower ch) && (lower ch) <= Lower.f then - (lower ch) - Lower.a + 10 - else - 16 (* larger than any legal value *) -end - -module Comment: sig - type t - - val toString: t -> string - - val loc: t -> Location.t - val txt: t -> string - val prevTokEndPos: t -> Lexing.position - - val setPrevTokEndPos: t -> Lexing.position -> unit - - val isSingleLineComment: t -> bool - - val makeSingleLineComment: loc:Location.t -> string -> t - val makeMultiLineComment: loc:Location.t -> string -> t - val fromOcamlComment: - loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t - val trimSpaces: string -> string -end = struct - type style = - | SingleLine - | MultiLine - - let styleToString s = match s with - | SingleLine -> "SingleLine" - | MultiLine -> "MultiLine" - - type t = { - txt: string; - style: style; - loc: Location.t; - mutable prevTokEndPos: Lexing.position; - } - - let loc t = t.loc - let txt t = t.txt - let prevTokEndPos t = t.prevTokEndPos - - let setPrevTokEndPos t pos = - t.prevTokEndPos <- pos - - let isSingleLineComment t = match t.style with - | SingleLine -> true - | MultiLine -> false - - let toString t = - Format.sprintf - "(txt: %s\nstyle: %s\nlines: %d-%d)" - t.txt - (styleToString t.style) - t.loc.loc_start.pos_lnum - t.loc.loc_end.pos_lnum - - let makeSingleLineComment ~loc txt = { - txt; - loc; - style = SingleLine; - prevTokEndPos = Lexing.dummy_pos; - } - - let makeMultiLineComment ~loc txt = { - txt; - loc; - style = MultiLine; - prevTokEndPos = Lexing.dummy_pos; - } - - let fromOcamlComment ~loc ~txt ~prevTokEndPos = { - txt; - loc; - style = MultiLine; - prevTokEndPos = prevTokEndPos - } - - let trimSpaces s = - let len = String.length s in - if len = 0 then s - else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' then ( - let b = Bytes.of_string s in - let i = ref 0 in - while !i < len && (Bytes.unsafe_get b !i) = ' ' do - incr i - done; - let j = ref (len - 1) in - while !j >= !i && (Bytes.unsafe_get b !j) = ' ' do - decr j - done; - if !j >= !i then - (Bytes.sub [@doesNotRaise]) b !i (!j - !i + 1) |> Bytes.to_string - else - "" - ) else s -end - -module Token = struct - type t = - | Open - | True | False - | Character of char - | Int of {i: string; suffix: char option} - | Float of {f: string; suffix: char option} - | String of string - | Lident of string - | Uident of string - | As - | Dot | DotDot | DotDotDot - | Bang - | Semicolon - | Let - | And - | Rec - | Underscore - | SingleQuote - | Equal | EqualEqual | EqualEqualEqual - | Bar - | Lparen - | Rparen - | Lbracket - | Rbracket - | Lbrace - | Rbrace - | Colon - | Comma - | Eof - | Exception - | Backslash [@live] - | Forwardslash | ForwardslashDot - | Asterisk | AsteriskDot | Exponentiation - | Minus | MinusDot - | Plus | PlusDot | PlusPlus | PlusEqual - | ColonGreaterThan - | GreaterThan - | LessThan - | LessThanSlash - | Hash | HashEqual | HashHash - | Assert - | Lazy - | Tilde - | Question - | If | Else | For | In | To | Downto | While | Switch - | When - | EqualGreater | MinusGreater - | External - | Typ - | Private - | Mutable - | Constraint - | Include - | Module - | Of - | With - | Land | Lor - | Band (* Bitwise and: & *) - | BangEqual | BangEqualEqual - | LessEqual | GreaterEqual - | ColonEqual - | At | AtAt - | Percent | PercentPercent - | Comment of Comment.t - | List - | TemplateTail of string - | TemplatePart of string - | Backtick - | BarGreater - | Try | Catch - | Import - | Export - - let precedence = function - | HashEqual | ColonEqual -> 1 - | Lor -> 2 - | Land -> 3 - | Equal | EqualEqual | EqualEqualEqual | LessThan | GreaterThan - | BangEqual | BangEqualEqual | LessEqual | GreaterEqual | BarGreater -> 4 - | Plus | PlusDot | Minus | MinusDot | PlusPlus -> 5 - | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot -> 6 - | Exponentiation -> 7 - | MinusGreater -> 8 - | Dot -> 9 - | _ -> 0 - - let toString = function - | Open -> "open" - | True -> "true" | False -> "false" - | Character c -> "'" ^ (Char.escaped c) ^ "'" - | String s -> s - | Lident str -> str - | Uident str -> str - | Dot -> "." | DotDot -> ".." | DotDotDot -> "..." - | Int {i} -> "int " ^ i - | Float {f} -> "Float: " ^ f - | Bang -> "!" - | Semicolon -> ";" - | Let -> "let" - | And -> "and" - | Rec -> "rec" - | Underscore -> "_" - | SingleQuote -> "'" - | Equal -> "=" | EqualEqual -> "==" | EqualEqualEqual -> "===" - | Eof -> "eof" - | Bar -> "|" - | As -> "as" - | Lparen -> "(" | Rparen -> ")" - | Lbracket -> "[" | Rbracket -> "]" - | Lbrace -> "{" | Rbrace -> "}" - | ColonGreaterThan -> ":>" - | Colon -> ":" - | Comma -> "," - | Minus -> "-" | MinusDot -> "-." - | Plus -> "+" | PlusDot -> "+." | PlusPlus -> "++" | PlusEqual -> "+=" - | Backslash -> "\\" - | Forwardslash -> "/" | ForwardslashDot -> "/." - | Exception -> "exception" - | Hash -> "#" | HashHash -> "##" | HashEqual -> "#=" - | GreaterThan -> ">" - | LessThan -> "<" - | LessThanSlash -> " "*" | AsteriskDot -> "*." | Exponentiation -> "**" - | Assert -> "assert" - | Lazy -> "lazy" - | Tilde -> "tilde" - | Question -> "?" - | If -> "if" - | Else -> "else" - | For -> "for" - | In -> "in" - | To -> "to" - | Downto -> "downto" - | While -> "while" - | Switch -> "switch" - | When -> "when" - | EqualGreater -> "=>" | MinusGreater -> "->" - | External -> "external" - | Typ -> "type" - | Private -> "private" - | Constraint -> "constraint" - | Mutable -> "mutable" - | Include -> "include" - | Module -> "module" - | Of -> "of" - | With -> "with" - | Lor -> "||" - | Band -> "&" | Land -> "&&" - | BangEqual -> "!=" | BangEqualEqual -> "!==" - | GreaterEqual -> ">=" | LessEqual -> "<=" - | ColonEqual -> ":=" - | At -> "@" | AtAt -> "@@" - | Percent -> "%" | PercentPercent -> "%%" - | Comment c -> "Comment(" ^ (Comment.toString c) ^ ")" - | List -> "list" - | TemplatePart text -> text ^ "${" - | TemplateTail text -> "TemplateTail(" ^ text ^ ")" - | Backtick -> "`" - | BarGreater -> "|>" - | Try -> "try" | Catch -> "catch" - | Import -> "import" - | Export -> "export" - - let keywordTable = function - | "true" -> True - | "false" -> False - | "open" -> Open - | "let" -> Let - | "rec" -> Rec - | "and" -> And - | "as" -> As - | "exception" -> Exception - | "assert" -> Assert - | "lazy" -> Lazy - | "if" -> If - | "else" -> Else - | "for" -> For - | "in" -> In - | "to" -> To - | "downto" -> Downto - | "while" -> While - | "switch" -> Switch - | "when" -> When - | "external" -> External - | "type" -> Typ - | "private" -> Private - | "mutable" -> Mutable - | "constraint" -> Constraint - | "include" -> Include - | "module" -> Module - | "of" -> Of - | "list" -> List - | "with" -> With - | "try" -> Try - | "catch" -> Catch - | "import" -> Import - | "export" -> Export - | _ -> raise Not_found - [@@raises Not_found] - - let isKeyword = function - | True | False | Open | Let | Rec | And | As - | Exception | Assert | Lazy | If | Else | For | In | To - | Downto | While | Switch | When | External | Typ | Private - | Mutable | Constraint | Include | Module | Of - | Land | Lor | List | With - | Try | Catch | Import | Export -> true - | _ -> false - - let lookupKeyword str = - try keywordTable str with - | Not_found -> - if CharacterCodes.isUpperCase (int_of_char (str.[0] [@doesNotRaise])) then - Uident str - else Lident str - - let isKeywordTxt str = - try let _ = keywordTable str in true with - | Not_found -> false -end - -module Grammar = struct - type t = - | OpenDescription (* open Belt *) - | ModuleLongIdent (* Foo or Foo.Bar *) [@live] - | Ternary (* condExpr ? trueExpr : falseExpr *) - | Es6ArrowExpr - | Jsx - | JsxAttribute - | JsxChild [@live] - | ExprOperand - | ExprUnary - | ExprSetField - | ExprBinaryAfterOp of Token.t - | ExprBlock - | ExprCall - | ExprList - | ExprArrayAccess - | ExprArrayMutation - | ExprIf - | IfCondition | IfBranch | ElseBranch - | TypeExpression - | External - | PatternMatching - | PatternMatchCase - | LetBinding - | PatternList - | PatternOcamlList - | PatternRecord - - | TypeDef - | TypeConstrName - | TypeParams - | TypeParam [@live] - | PackageConstraint - - | TypeRepresentation - - | RecordDecl - | ConstructorDeclaration - | ParameterList - | StringFieldDeclarations - | FieldDeclarations - | TypExprList - | FunctorArgs - | ModExprList - | TypeParameters - | RecordRows - | RecordRowsStringKey - | ArgumentList - | Signature - | Specification - | Structure - | Implementation - | Attribute - | TypeConstraint - | Primitive - | AtomicTypExpr - | ListExpr - | JsFfiImport - - let toString = function - | OpenDescription -> "an open description" - | ModuleLongIdent -> "a module identifier" - | Ternary -> "a ternary expression" - | Es6ArrowExpr -> "an es6 arrow function" - | Jsx -> "a jsx expression" - | JsxAttribute -> "a jsx attribute" - | ExprOperand -> "a basic expression" - | ExprUnary -> "a unary expression" - | ExprBinaryAfterOp op -> "an expression after the operator \"" ^ Token.toString op ^ "\"" - | ExprIf -> "an if expression" - | IfCondition -> "the condition of an if expression" - | IfBranch -> "the true-branch of an if expression" - | ElseBranch -> "the else-branch of an if expression" - | TypeExpression -> "a type" - | External -> "an external" - | PatternMatching -> "the cases of a pattern match" - | ExprBlock -> "a block with expressions" - | ExprSetField -> "a record field mutation" - | ExprCall -> "a function application" - | ExprArrayAccess -> "an array access expression" - | ExprArrayMutation -> "an array mutation" - | LetBinding -> "a let binding" - | TypeDef -> "a type definition" - | TypeParams -> "type parameters" - | TypeParam -> "a type parameter" - | TypeConstrName -> "a type-constructor name" - | TypeRepresentation -> "a type representation" - | RecordDecl -> "a record declaration" - | PatternMatchCase -> "a pattern match case" - | ConstructorDeclaration -> "a constructor declaration" - | ExprList -> "multiple expressions" - | PatternList -> "multiple patterns" - | PatternOcamlList -> "a list pattern" - | PatternRecord -> "a record pattern" - | ParameterList -> "parameters" - | StringFieldDeclarations -> "string field declarations" - | FieldDeclarations -> "field declarations" - | TypExprList -> "list of types" - | FunctorArgs -> "functor arguments" - | ModExprList -> "list of module expressions" - | TypeParameters -> "list of type parameters" - | RecordRows -> "rows of a record" - | RecordRowsStringKey -> "rows of a record with string keys" - | ArgumentList -> "arguments" - | Signature -> "signature" - | Specification -> "specification" - | Structure -> "structure" - | Implementation -> "implementation" - | Attribute -> "an attribute" - | TypeConstraint -> "constraints on a type" - | Primitive -> "an external primitive" - | AtomicTypExpr -> "a type" - | ListExpr -> "an ocaml list expr" - | PackageConstraint -> "a package constraint" - | JsFfiImport -> "js ffi import" - | JsxChild -> "jsx child" - - let isSignatureItemStart = function - | Token.At - | Let - | Typ - | External - | Exception - | Open - | Include - | Module - | AtAt - | PercentPercent -> true - | _ -> false - - let isAtomicPatternStart = function - | Token.Int _ | String _ | Character _ - | Lparen | Lbracket | Lbrace - | Underscore - | Lident _ | Uident _ | List - | Exception | Lazy - | Percent -> true - | _ -> false - - let isAtomicExprStart = function - | Token.True | False - | Int _ | String _ | Float _ | Character _ - | Backtick - | Uident _ | Lident _ | Hash - | Lparen - | List - | Lbracket - | Lbrace - | LessThan - | Module - | Percent -> true - | _ -> false - - let isAtomicTypExprStart = function - | Token.SingleQuote | Underscore - | Lparen | Lbrace - | Uident _ | Lident _ | List - | Percent -> true - | _ -> false - - let isExprStart = function - | Token.True | False - | Int _ | String _ | Float _ | Character _ | Backtick - | Underscore (* _ => doThings() *) - | Uident _ | Lident _ | Hash - | Lparen | List | Module | Lbracket | Lbrace - | LessThan - | Minus | MinusDot | Plus | PlusDot | Bang - | Percent | At - | If | Switch | While | For | Assert | Lazy | Try -> true - | _ -> false - - let isJsxAttributeStart = function - | Token.Lident _ | Question -> true - | _ -> false - - let isStructureItemStart = function - | Token.Open - | Let - | Typ - | External | Import | Export - | Exception - | Include - | Module - | AtAt - | PercentPercent - | At -> true - | t when isExprStart t -> true - | _ -> false - - let isPatternStart = function - | Token.Int _ | Float _ | String _ | Character _ | True | False | Minus | Plus - | Lparen | Lbracket | Lbrace | List - | Underscore - | Lident _ | Uident _ | Hash | HashHash - | Exception | Lazy | Percent | Module - | At -> true - | _ -> false - - let isParameterStart = function - | Token.Typ | Tilde | Dot -> true - | token when isPatternStart token -> true - | _ -> false - - (* TODO: overparse Uident ? *) - let isStringFieldDeclStart = function - | Token.String _ | At -> true - | _ -> false - - (* TODO: overparse Uident ? *) - let isFieldDeclStart = function - | Token.At | Mutable | Lident _ | List -> true - (* recovery, TODO: this is not ideal… *) - | Uident _ -> true - | t when Token.isKeyword t -> true - | _ -> false - - let isRecordDeclStart = function - | Token.At - | Mutable - | Lident _ | List -> true - | _ -> false - - let isTypExprStart = function - | Token.At - | SingleQuote - | Underscore - | Lparen | Lbracket - | Uident _ | Lident _ | List - | Module - | Percent - | Lbrace -> true - | _ -> false - - let isTypeParameterStart = function - | Token.Tilde | Dot -> true - | token when isTypExprStart token -> true - | _ -> false - - let isTypeParamStart = function - | Token.Plus | Minus | SingleQuote | Underscore -> true - | _ -> false - - let isFunctorArgStart = function - | Token.At | Uident _ | Underscore - | Percent - | Lbrace - | Lparen -> true - | _ -> false - - let isModExprStart = function - | Token.At | Percent - | Uident _ | Lbrace | Lparen -> true - | _ -> false - - let isRecordRowStart = function - | Token.DotDotDot -> true - | Token.Uident _ | Lident _ | List -> true - (* TODO *) - | t when Token.isKeyword t -> true - | _ -> false - - let isRecordRowStringKeyStart = function - | Token.String _ -> true - | _ -> false - - let isArgumentStart = function - | Token.Tilde | Dot | Underscore -> true - | t when isExprStart t -> true - | _ -> false - - let isPatternMatchStart = function - | Token.Bar -> true - | t when isPatternStart t -> true - | _ -> false - - let isPatternOcamlListStart = function - | Token.DotDotDot -> true - | t when isPatternStart t -> true - | _ -> false - - let isPatternRecordItemStart = function - | Token.DotDotDot | Uident _ | Lident _ | List | Underscore -> true - | _ -> false - - let isAttributeStart = function - | Token.At -> true - | _ -> false - - let isJsFfiImportStart = function - | Token.Lident _ | At -> true - | _ -> false - - let isJsxChildStart = isAtomicExprStart - - let isBlockExprStart = function - | Token.At | Hash | Percent | Minus | MinusDot | Plus | PlusDot | Bang - | True | False | Int _ | String _ | Character _ | Lident _ | Uident _ - | Lparen | List | Lbracket | Lbrace | Forwardslash | Assert - | Lazy | If | For | While | Switch | Open | Module | Exception | Let - | LessThan | Backtick | Try | Underscore -> true - | _ -> false - - let isListElement grammar token = - match grammar with - | ExprList -> token = Token.DotDotDot || isExprStart token - | ListExpr -> token = DotDotDot || isExprStart token - | PatternList -> token = DotDotDot || isPatternStart token - | ParameterList -> isParameterStart token - | StringFieldDeclarations -> isStringFieldDeclStart token - | FieldDeclarations -> isFieldDeclStart token - | RecordDecl -> isRecordDeclStart token - | TypExprList -> isTypExprStart token || token = Token.LessThan - | TypeParams -> isTypeParamStart token - | FunctorArgs -> isFunctorArgStart token - | ModExprList -> isModExprStart token - | TypeParameters -> isTypeParameterStart token - | RecordRows -> isRecordRowStart token - | RecordRowsStringKey -> isRecordRowStringKeyStart token - | ArgumentList -> isArgumentStart token - | Signature | Specification -> isSignatureItemStart token - | Structure | Implementation -> isStructureItemStart token - | PatternMatching -> isPatternMatchStart token - | PatternOcamlList -> isPatternOcamlListStart token - | PatternRecord -> isPatternRecordItemStart token - | Attribute -> isAttributeStart token - | TypeConstraint -> token = Constraint - | PackageConstraint -> token = And - | ConstructorDeclaration -> token = Bar - | Primitive -> begin match token with Token.String _ -> true | _ -> false end - | JsxAttribute -> isJsxAttributeStart token - | JsFfiImport -> isJsFfiImportStart token - | _ -> false - - let isListTerminator grammar token = - match grammar, token with - | _, Token.Eof - | ExprList, (Rparen | Forwardslash | Rbracket) - | ListExpr, Rparen - | ArgumentList, Rparen - | TypExprList, (Rparen | Forwardslash | GreaterThan | Equal) - | ModExprList, Rparen - | (PatternList | PatternOcamlList | PatternRecord), - (Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) | In (* for expressions *) | Equal (* let {x} = foo *)) - | ExprBlock, Rbrace - | (Structure | Signature), Rbrace - | TypeParams, Rparen - | ParameterList, (EqualGreater | Lbrace) - | JsxAttribute, (Forwardslash | GreaterThan) - | JsFfiImport, Rbrace - | StringFieldDeclarations, Rbrace -> true - - | Attribute, token when token <> At -> true - | TypeConstraint, token when token <> Constraint -> true - | PackageConstraint, token when token <> And -> true - | ConstructorDeclaration, token when token <> Bar -> true - | Primitive, Semicolon -> true - | Primitive, token when isStructureItemStart token -> true - - | _ -> false - - let isPartOfList grammar token = - isListElement grammar token || isListTerminator grammar token -end - -module Reporting = struct - module TerminalDoc = struct - type break = - | Never - | Always - - type document = - | Nil - | Group of {break: break; doc: document} - | Text of string - | Indent of {amount: int; doc: document} - | Append of {doc1: document; doc2: document} - - let group ~break doc = Group {break; doc} - let text txt = Text (txt) - let indent i d = Indent {amount = i; doc = d} - let append d1 d2 = Append {doc1 = d1; doc2 = d2} - let nil = Nil - - type stack = - | Empty - | Cons of {doc: document; stack: stack} - - let push stack doc = Cons {doc; stack} - - type mode = - | Flat - | Break - - let toString (* ~width *) (doc : document) = - let buffer = Buffer.create 100 in - let rec loop stack mode offset = - match stack with - | Empty -> () - | Cons {doc; stack = rest} -> - begin match doc with - | Nil -> loop rest mode offset - | Text txt -> - Buffer.add_string buffer txt; - loop rest mode (offset + (String.length txt)) - | Indent {amount = i; doc} -> - let indentation = (String.make [@doesNotRaise]) i ' ' in - Buffer.add_string buffer indentation; - loop (push rest doc) mode (offset + i) - | Append {doc1; doc2} -> - let rest = push rest doc2 in - let rest = push rest - (match mode = Flat with - | true -> Nil - | false -> text "\n") - in - let rest = push rest doc1 in - loop rest mode offset - | Group {break; doc} -> - let rest = push rest doc in - begin match break with - | Always -> loop rest Break offset - | Never -> loop rest Flat offset - end - end - in - loop (push Empty doc) Flat 0; - Buffer.contents buffer - end - - type color = - | NoColor [@live] - | Red [@live] - - type style = { - underline: bool; [@live] - color: color; [@live] - } - - let highlight ~from ~len txt = - if from < 0 || (String.length txt) == 0 || (from >= String.length txt) then txt else - let before = try String.sub txt 0 from with Invalid_argument _ -> "" in - let content = - "\027[31m" ^ (try String.sub txt from len with Invalid_argument _ -> "") ^ "\027[0m" - in - let after = try String.sub txt (from + len) (String.length txt - (from + len)) with Invalid_argument _ -> "" in - before ^ content ^ after - - let underline ~from ~len txt = - let open TerminalDoc in - let indent = (String.make [@doesNotRaise]) from ' ' in - let underline = (String.make [@doesNotRaise]) len '^' in - let line = highlight ~from:0 ~len underline in - group ~break:Always - (append (text txt) (text (indent ^ line))) - - let rec drop n l = - if n == 1 then l - else drop (n - 1) (match l with | _x::xs -> xs | _ -> l) - - let rec take n l = - match l with - | _ when n == 0 -> [] - | [] -> [] - | x::xs -> x::(take (n -1) xs) - - (* TODO: cleanup *) - let renderCodeContext ~missing (src : string) startPos endPos = - let open Lexing in - let startCol = (startPos.pos_cnum - startPos.pos_bol) in - let endCol = endPos.pos_cnum - startPos.pos_cnum + startCol in - let startLine = max 1 (startPos.pos_lnum - 2) in (* 2 lines before *) - let lines = String.split_on_char '\n' src in - let endLine = - let len = List.length lines in - min len (startPos.pos_lnum + 3) (* 2 lines after *) - in - let lines = - lines - |> drop startLine - |> take (endLine - startLine) - |> Array.of_list - in - - let renderLine x ix = - let x = if ix = startPos.pos_lnum then - begin match missing with - | Some _len -> x ^ (String.make 10 ' ' [@doesNotRaise]) - | None -> x - end - else - x - in - - let open TerminalDoc in - let rowNr = - let txt = string_of_int ix in - let len = String.length txt in - if ix = startPos.pos_lnum then - highlight ~from:0 ~len txt - else txt - in - let len = - let len = if endCol >= 0 then - endCol - startCol - else - 1 - in - if (startCol + len) > String.length x then String.length x - startCol - 1 else len - in - let line = - if ix = startPos.pos_lnum then - begin match missing with - | Some len -> - underline - ~from:( - startCol + String.length (String.length (string_of_int ix) |> string_of_int) + 5 - ) ~len x - | None -> - let len = if startCol + len > String.length x then - (String.length x) - startCol - else - len - in - text (highlight ~from:startCol ~len x) - end - else text x - in - group ~break:Never - (append - (append (text rowNr) (text " │")) - (indent 2 line)) - in - - let reportDoc = ref TerminalDoc.nil in - - let linesLen = Array.length lines in - for i = 0 to (linesLen - 1) do - let line = try (Array.get [@doesNotRaise]) lines i with Invalid_argument _ -> "" in - reportDoc := - let open TerminalDoc in - let ix = startLine + i in - group ~break:Always (append !reportDoc (renderLine line ix)) - done; - - TerminalDoc.toString !reportDoc - - type problem = - | Unexpected of Token.t [@live] - | Expected of {token: Token.t; pos: Lexing.position; context: Grammar.t option} [@live] - | Message of string [@live] - | Uident [@live] - | Lident [@live] - | Unbalanced of Token.t [@live] - - type parseError = Lexing.position * problem -end - -module Diagnostics: sig - type t - type category - type report - - type reportStyle - val parseReportStyle: string -> reportStyle - - val unexpected: Token.t -> (Grammar.t * Lexing.position) list -> category - val expected: ?grammar:Grammar.t -> Lexing.position -> Token.t -> category - val uident: Token.t -> category - val lident: Token.t -> category - val unclosedString: category - val unclosedTemplate: category - val unclosedComment: category - val unknownUchar: int -> category - val message: string -> category - - val make: - filename: string - -> startPos: Lexing.position - -> endPos: Lexing.position - -> category - -> t - - val stringOfReport: style:reportStyle -> t list -> string -> string -end = struct - type category = - | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} - | Expected of {context: Grammar.t option; pos: Lexing.position (* prev token end*); token: Token.t} - | Message of string - | Uident of Token.t - | Lident of Token.t - | UnclosedString - | UnclosedTemplate - | UnclosedComment - | UnknownUchar of int - - type t = { - filename: string; - startPos: Lexing.position; - endPos: Lexing.position; - category: category; - } - - type report = t list - - (* TODO: add json here *) - type reportStyle = - | Pretty - | Plain - - let parseReportStyle txt = match (String.lowercase_ascii txt) with - | "plain" -> Plain - | _ -> Pretty - - let defaultUnexpected token = - "I'm not sure what to parse here when looking at \"" ^ (Token.toString token) ^ "\"." - - let explain t = - match t.category with - | Uident currentToken -> - begin match currentToken with - | Lident lident -> - let guess = String.capitalize_ascii lident in - "Did you mean `" ^ guess ^"` instead of `" ^ lident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword." - | _ -> - "At this point, I'm looking for an uppercased identifier like `Belt` or `Array`" - end - | Lident currentToken -> - begin match currentToken with - | Uident uident -> - let guess = String.uncapitalize_ascii uident in - "Did you mean `" ^ guess ^"` instead of `" ^ uident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ token ^ "\"" - | Underscore -> - "`_` isn't a valid name." - | _ -> - "I'm expecting an lowercased identifier like `name` or `age`" - end - | Message txt -> txt - | UnclosedString -> - "This string is missing a double quote at the end" - | UnclosedTemplate -> - "Did you forget to close this template expression with a backtick?" - | UnclosedComment -> - "This comment seems to be missing a closing `*/`" - | UnknownUchar uchar -> - begin match uchar with - | 94 (* ^ *) -> - "Hmm, not sure what I should do here with this character.\nIf you're trying to deref an expression, use `foo.contents` instead." - | _ -> - "Hmm, I have no idea what this character means…" - end - | Expected {context; token = t} -> - let hint = match context with - | Some grammar -> "It signals the start of " ^ (Grammar.toString grammar) - | None -> "" - in - "Did you forget a `" ^ (Token.toString t) ^ "` here? " ^ hint - | Unexpected {token = t; context = breadcrumbs} -> - let name = (Token.toString t) in - begin match breadcrumbs with - | (AtomicTypExpr, _)::breadcrumbs -> - begin match breadcrumbs, t with - | ((StringFieldDeclarations | FieldDeclarations) , _) :: _, (String _ | At | Rbrace | Comma | Eof) -> - "I'm missing a type here" - | _, t when Grammar.isStructureItemStart t || t = Eof -> - "Missing a type here" - | _ -> - defaultUnexpected t - end - | (ExprOperand, _)::breadcrumbs -> - begin match breadcrumbs, t with - | (ExprBlock, _) :: _, Rbrace -> - "It seems that this expression block is empty" - | (ExprBlock, _) :: _, Bar -> (* Pattern matching *) - "Looks like there might be an expression missing here" - | (ExprSetField, _) :: _, _ -> - "It seems that this record field mutation misses an expression" - | (ExprArrayMutation, _) :: _, _ -> - "Seems that an expression is missing, with what do I mutate the array?" - | ((ExprBinaryAfterOp _ | ExprUnary), _) ::_, _ -> - "Did you forget to write an expression here?" - | (Grammar.LetBinding, _)::_, _ -> - "This let-binding misses an expression" - | _::_, (Rbracket | Rbrace) -> - "Missing expression" - | _ -> - "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - end - | (TypeParam, _)::_ -> - begin match t with - | Lident ident -> - "Did you mean '" ^ ident ^"? A Type parameter starts with a quote." - | _ -> - "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - end - | _ -> - (* TODO: match on circumstance to verify Lident needed ? *) - if Token.isKeyword t then - "`" ^ name ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ (Token.toString t) ^ "\"" - else - "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - end - - let toPlainString t buffer = - Buffer.add_string buffer t.filename; - Buffer.add_char buffer '('; - Buffer.add_string buffer (string_of_int t.startPos.pos_cnum); - Buffer.add_char buffer ','; - Buffer.add_string buffer (string_of_int t.endPos.pos_cnum); - Buffer.add_char buffer ')'; - Buffer.add_char buffer ':'; - Buffer.add_string buffer (explain t) - - let toString t src = - let open Lexing in - let startchar = t.startPos.pos_cnum - t.startPos.pos_bol in - let endchar = t.endPos.pos_cnum - t.startPos.pos_cnum + startchar in - let locationInfo = - Printf.sprintf (* ReasonLanguageServer requires the following format *) - "File \"%s\", line %d, characters %d-%d:" - t.filename - t.startPos.pos_lnum - startchar - endchar - in - let code = - let missing = match t.category with - | Expected {token = t} -> - Some (String.length (Token.toString t)) - | _ -> None - in - Reporting.renderCodeContext ~missing src t.startPos t.endPos - in - let explanation = explain t in - Printf.sprintf "%s\n\n%s\n\n%s\n\n" locationInfo code explanation - - let make ~filename ~startPos ~endPos category = { - filename; - startPos; - endPos; - category - } - - let stringOfReport ~style diagnostics src = - match style with - | Pretty -> - List.fold_left (fun report diagnostic -> - report ^ (toString diagnostic src) ^ "\n" - ) "\n" (List.rev diagnostics) - | Plain -> - let buffer = Buffer.create 100 in - List.iter (fun diagnostic -> - toPlainString diagnostic buffer; - Buffer.add_char buffer '\n'; - ) diagnostics; - Buffer.contents buffer - - let unexpected token context = - Unexpected {token; context} - - let expected ?grammar pos token = - Expected {context = grammar; pos; token} - - let uident currentToken = Uident currentToken - let lident currentToken = Lident currentToken - let unclosedString = UnclosedString - let unclosedComment = UnclosedComment - let unclosedTemplate = UnclosedTemplate - let unknownUchar code = UnknownUchar code - let message txt = Message txt -end - -(* Collection of utilities to view the ast in a more a convenient form, - * allowing for easier processing. - * Example: given a ptyp_arrow type, what are its arguments and what is the - * returnType? *) -module ParsetreeViewer : sig - (* Restructures a nested tree of arrow types into its args & returnType - * The parsetree contains: a => b => c => d, for printing purposes - * we restructure the tree into (a, b, c) and its returnType d *) - val arrowType: Parsetree.core_type -> - Parsetree.attributes * - (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list * - Parsetree.core_type - - val functorType: Parsetree.module_type -> - (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * - Parsetree.module_type - - (* filters @bs out of the provided attributes *) - val processUncurriedAttribute: Parsetree.attributes -> bool * Parsetree.attributes - - (* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } - * The purpose of this function is to flatten nested ifs into one sequence. - * Basically compute: ([if, else if, else if, else if], else) *) - val collectIfExpressions: - Parsetree.expression -> - (Parsetree.expression * Parsetree.expression) list * Parsetree.expression option - - val collectListExpressions: - Parsetree.expression -> (Parsetree.expression list * Parsetree.expression option) - - type funParamKind = - | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; - } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} - - val funExpr: - Parsetree.expression -> - Parsetree.attributes * - funParamKind list * - Parsetree.expression - - (* example: - * `makeCoordinate({ - * x: 1, - * y: 2, - * })` - * Notice howe `({` and `})` "hug" or stick to each other *) - val isHuggableExpression: Parsetree.expression -> bool - - val isHuggablePattern: Parsetree.pattern -> bool - - val isHuggableRhs: Parsetree.expression -> bool - - val operatorPrecedence: string -> int - - val isUnaryExpression: Parsetree.expression -> bool - val isBinaryOperator: string -> bool - val isBinaryExpression: Parsetree.expression -> bool - - val flattenableOperators: string -> string -> bool - - val hasAttributes: Parsetree.attributes -> bool - - val isArrayAccess: Parsetree.expression -> bool - val isTernaryExpr: Parsetree.expression -> bool - - val collectTernaryParts: Parsetree.expression -> ((Parsetree.expression * Parsetree.expression) list * Parsetree.expression) - - val parametersShouldHug: - funParamKind list -> bool - - val filterTernaryAttributes: Parsetree.attributes -> Parsetree.attributes - - val isJsxExpression: Parsetree.expression -> bool - val hasJsxAttribute: Parsetree.attributes -> bool - - val shouldIndentBinaryExpr: Parsetree.expression -> bool - val shouldInlineRhsBinaryExpr: Parsetree.expression -> bool - val filterPrinteableAttributes: Parsetree.attributes -> Parsetree.attributes - val partitionPrinteableAttributes: Parsetree.attributes -> (Parsetree.attributes * Parsetree.attributes) - - val requiresSpecialCallbackPrintingLastArg: (Asttypes.arg_label * Parsetree.expression) list -> bool - val requiresSpecialCallbackPrintingFirstArg: (Asttypes.arg_label * Parsetree.expression) list -> bool - - val modExprApply : Parsetree.module_expr -> ( - Parsetree.module_expr list * Parsetree.module_expr - ) - - val modExprFunctor : Parsetree.module_expr -> ( - (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) list * - Parsetree.module_expr - ) - - val splitGenTypeAttr : Parsetree.attributes -> (bool * Parsetree.attributes) - - val collectPatternsFromListConstruct: - Parsetree.pattern list -> Parsetree.pattern -> - (Parsetree.pattern list * Parsetree.pattern) - - val isBlockExpr : Parsetree.expression -> bool - - val isTemplateLiteral: Parsetree.expression -> bool - - val collectOrPatternChain: - Parsetree.pattern -> Parsetree.pattern list - - val processBracesAttr : Parsetree.expression -> (Parsetree.attribute option * Parsetree.expression) - - val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes - - val isBracedExpr : Parsetree.expression -> bool - - val isPipeExpr : Parsetree.expression -> bool - - val extractValueDescriptionFromModExpr: Parsetree.module_expr -> Parsetree.value_description list - - type jsImportScope = - | JsGlobalImport (* nothing *) - | JsModuleImport of string (* from "path" *) - | JsScopedImport of string list (* window.location *) - - val classifyJsImport: Parsetree.value_description -> jsImportScope - - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - val rewriteUnderscoreApply: Parsetree.expression -> Parsetree.expression - - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - val isUnderscoreApplySugar: Parsetree.expression -> bool -end = struct - open Parsetree - - let arrowType ct = - let rec process attrsBefore acc typ = match typ with - | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = []} -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = [({txt ="bs"}, _) ] as attrs} -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) - | {ptyp_desc = Ptyp_arrow ((Labelled _ | Optional _) as lbl, typ1, typ2); ptyp_attributes = attrs} -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | typ -> - (attrsBefore, List.rev acc, typ) - in - begin match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> - process attrs [] {typ with ptyp_attributes = []} - | typ -> process [] [] typ - end - - let functorType modtype = - let rec process acc modtype = match modtype with - | {pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs} -> - let arg = (attrs, lbl, argType) in - process (arg::acc) returnType - | modType -> - (List.rev acc, modType) - in - process [] modtype - - let processUncurriedAttribute attrs = - let rec process uncurriedSpotted acc attrs = - match attrs with - | [] -> (uncurriedSpotted, List.rev acc) - | ({Location.txt = "bs"}, _)::rest -> process true acc rest - | attr::rest -> process uncurriedSpotted (attr::acc) rest - in - process false [] attrs - - let collectIfExpressions expr = - let rec collect acc expr = match expr.pexp_desc with - | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> - collect ((ifExpr, thenExpr)::acc) elseExpr - | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> - let ifs = List.rev ((ifExpr, thenExpr)::acc) in - (ifs, elseExpr) - | _ -> - (List.rev acc, Some expr) - in - collect [] expr - - let collectListExpressions expr = - let rec collect acc expr = match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - (List.rev acc, None) - | Pexp_construct ( - {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple (hd::[tail])} - ) -> - collect (hd::acc) tail - | _ -> - (List.rev acc, Some expr) - in - collect [] expr - - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - let rewriteUnderscoreApply expr = - match expr.pexp_desc with - | Pexp_fun ( - Nolabel, - None, - {ppat_desc = Ppat_var {txt="__x"}}, - ({pexp_desc = Pexp_apply (callExpr, args)} as e) - ) -> - let newArgs = List.map (fun arg -> - match arg with - | ( - lbl, - ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} as argExpr) - ) -> - (lbl, {argExpr with pexp_desc = Pexp_ident ({lid with txt = Longident.Lident "_"})}) - | arg -> arg - ) args in - {e with pexp_desc = Pexp_apply (callExpr, newArgs)} - | _ -> expr - - type funParamKind = - | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; - } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} - - let funExpr expr = - (* Turns (type t, type u, type z) into "type t u z" *) - let rec collectNewTypes acc returnExpr = - match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} -> - collectNewTypes (stringLoc::acc) returnExpr - | returnExpr -> - (List.rev acc, returnExpr) - in - let rec collect attrsBefore acc expr = match expr with - | {pexp_desc = Pexp_fun ( - Nolabel, - None, - {ppat_desc = Ppat_var {txt="__x"}}, - {pexp_desc = Pexp_apply _} - )} -> - (attrsBefore, List.rev acc, rewriteUnderscoreApply expr) - | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []} -> - let parameter = Parameter { - attrs = []; - lbl = lbl; - defaultExpr = defaultExpr; - pat = pattern; - } in - collect attrsBefore (parameter::acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let (stringLocs, returnExpr) = collectNewTypes [stringLoc] rest in - let param = NewTypes {attrs; locs = stringLocs} in - collect attrsBefore (param::acc) returnExpr - | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = [({txt = "bs"}, _)] as attrs} -> - let parameter = Parameter { - attrs = attrs; - lbl = lbl; - defaultExpr = defaultExpr; - pat = pattern; - } in - collect attrsBefore (parameter::acc) returnExpr - | { - pexp_desc = Pexp_fun ((Labelled _ | Optional _) as lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = attrs - } -> - let parameter = Parameter { - attrs = attrs; - lbl = lbl; - defaultExpr = defaultExpr; - pat = pattern; - } in - collect attrsBefore (parameter::acc) returnExpr - | expr -> - (attrsBefore, List.rev acc, expr) - in - begin match expr with - | {pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs} as expr -> - collect attrs [] {expr with pexp_attributes = []} - | expr -> collect [] [] expr - end - - let processBracesAttr expr = - match expr.pexp_attributes with - | (({txt = "res.braces"}, _) as attr)::attrs -> - (Some attr, {expr with pexp_attributes = attrs}) - | _ -> - (None, expr) - - let filterParsingAttrs attrs = - List.filter (fun attr -> - match attr with - | ({Location.txt = ("res.ternary" | "res.braces" | "bs" | "res.namedArgLoc")}, _) -> false - | _ -> true - ) attrs - - let isBlockExpr expr = - match expr.pexp_desc with - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_let _ - | Pexp_open _ - | Pexp_sequence _ -> true - | _ -> false - - let isBracedExpr expr = - match processBracesAttr expr with - | (Some _, _) -> true - | _ -> false - - let isHuggableExpression expr = - match expr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj"}, _) - | Pexp_record _ -> true - | _ when isBlockExpr expr -> true - | _ when isBracedExpr expr -> true - | _ -> false - - let isHuggableRhs expr = - match expr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj"}, _) - | Pexp_record _ -> true - | _ when isBracedExpr expr -> true - | _ -> false - - let isHuggablePattern pattern = - match pattern.ppat_desc with - | Ppat_array _ - | Ppat_tuple _ - | Ppat_record _ - | Ppat_construct _ -> true - | _ -> false - - let operatorPrecedence operator = match operator with - | ":=" -> 1 - | "||" -> 2 - | "&&" -> 3 - | "=" | "==" | "<" | ">" | "!=" | "<>" | "!==" | "<=" | ">=" | "|>" -> 4 - | "+" | "+." | "-" | "-." | "^" -> 5 - | "*" | "*." | "/" | "/." -> 6 - | "**" -> 7 - | "#" | "##" | "|." -> 8 - | _ -> 0 - - let isUnaryOperator operator = match operator with - | "~+" | "~+." | "~-" | "~-." | "not" -> true - | _ -> false - - let isUnaryExpression expr = match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, _arg] - ) when isUnaryOperator operator -> true - | _ -> false - - let isBinaryOperator operator = match operator with - | ":=" - | "||" - | "&&" - | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" | "|>" - | "+" | "+." | "-" | "-." | "^" - | "*" | "*." | "/" | "/." - | "**" - | "|." | "<>" -> true - | _ -> false - - let isBinaryExpression expr = match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, _operand1); (Nolabel, _operand2)] - ) when isBinaryOperator operator -> true - | _ -> false - - let isEqualityOperator operator = match operator with - | "=" | "==" | "<>" | "!=" -> true - | _ -> false - - let flattenableOperators parentOperator childOperator = - let precParent = operatorPrecedence parentOperator in - let precChild = operatorPrecedence childOperator in - if precParent == precChild then - not ( - isEqualityOperator parentOperator && - isEqualityOperator childOperator - ) - else - false - - let hasAttributes attrs = - List.exists (fun attr -> match attr with - | ({Location.txt = "bs" | "res.ternary" | "res.braces"}, _) -> false - | _ -> true - ) attrs - - let isArrayAccess expr = match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [Nolabel, _parentExpr; Nolabel, _memberExpr] - ) -> true - | _ -> false - - let rec hasTernaryAttribute attrs = - match attrs with - | [] -> false - | ({Location.txt="res.ternary"},_)::_ -> true - | _::attrs -> hasTernaryAttribute attrs - - let isTernaryExpr expr = match expr with - | { - pexp_attributes = attrs; - pexp_desc = Pexp_ifthenelse _ - } when hasTernaryAttribute attrs -> true - | _ -> false - - let collectTernaryParts expr = - let rec collect acc expr = match expr with - | { - pexp_attributes = attrs; - pexp_desc = Pexp_ifthenelse (condition, consequent, Some(alternate)) - } when hasTernaryAttribute attrs -> collect ((condition, consequent)::acc) alternate - | alternate -> (List.rev acc, alternate) - in - collect [] expr - - let parametersShouldHug parameters = match parameters with - | [Parameter { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = pat - }] when isHuggablePattern pat -> true - | _ -> false - - let filterTernaryAttributes attrs = - List.filter (fun attr -> match attr with - |({Location.txt="res.ternary"},_) -> false - | _ -> true - ) attrs - - let isJsxExpression expr = - let rec loop attrs = - match attrs with - | [] -> false - | ({Location.txt = "JSX"}, _)::_ -> true - | _::attrs -> loop attrs - in - match expr.pexp_desc with - | Pexp_apply _ -> - loop expr.Parsetree.pexp_attributes - | _ -> false - - let hasJsxAttribute attributes = match attributes with - | ({Location.txt = "JSX"},_)::_ -> true - | _ -> false - - let shouldIndentBinaryExpr expr = - let samePrecedenceSubExpression operator subExpression = - match subExpression with - | {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, - [Nolabel, _lhs; Nolabel, _rhs] - )} when isBinaryOperator subOperator -> - flattenableOperators operator subOperator - | _ -> true - in - match expr with - | {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, lhs; Nolabel, _rhs] - )} when isBinaryOperator operator -> - isEqualityOperator operator || - not (samePrecedenceSubExpression operator lhs) || - operator = ":=" - | _ -> false - - let shouldInlineRhsBinaryExpr rhs = match rhs.pexp_desc with - | Parsetree.Pexp_constant _ - | Pexp_let _ - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_sequence _ - | Pexp_open _ - | Pexp_ifthenelse _ - | Pexp_for _ - | Pexp_while _ - | Pexp_try _ - | Pexp_array _ - | Pexp_record _ -> true - | _ -> false - - let filterPrinteableAttributes attrs = - List.filter (fun attr -> match attr with - | ({Location.txt="bs" | "res.ternary"}, _) -> false - | _ -> true - ) attrs - - let partitionPrinteableAttributes attrs = - List.partition (fun attr -> match attr with - | ({Location.txt="bs" | "res.ternary"}, _) -> false - | _ -> true - ) attrs - - let requiresSpecialCallbackPrintingLastArg args = - let rec loop args = match args with - | [] -> false - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false - | _::rest -> loop rest - in - loop args - - let requiresSpecialCallbackPrintingFirstArg args = - let rec loop args = match args with - | [] -> true - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::_ -> false - | _::rest -> loop rest - in - match args with - | [(_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})] -> false - | (_, {pexp_desc = Pexp_fun _ | Pexp_newtype _})::rest -> loop rest - | _ -> false - - let modExprApply modExpr = - let rec loop acc modExpr = match modExpr with - | {pmod_desc = Pmod_apply (next, arg)} -> - loop (arg::acc) next - | _ -> (acc, modExpr) - in - loop [] modExpr - - let modExprFunctor modExpr = - let rec loop acc modExpr = match modExpr with - | {pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} -> - let param = (attrs, lbl, modType) in - loop (param::acc) returnModExpr - | returnModExpr -> - (List.rev acc, returnModExpr) - in - loop [] modExpr - - let splitGenTypeAttr attrs = - match attrs with - | ({Location.txt = "genType"}, _)::attrs -> (true, attrs) - | attrs -> (false, attrs) - - let rec collectPatternsFromListConstruct acc pattern = - let open Parsetree in - match pattern.ppat_desc with - | Ppat_construct( - {txt = Longident.Lident "::"}, - Some {ppat_desc=Ppat_tuple (pat::rest::[])} - ) -> - collectPatternsFromListConstruct (pat::acc) rest - | _ -> List.rev acc, pattern - - let rec isTemplateLiteral expr = - let isPexpConstantString expr = match expr.pexp_desc with - | Pexp_constant (Pconst_string (_, Some _)) -> true - | _ -> false - in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [Nolabel, arg1; Nolabel, arg2] - ) when not (isPexpConstantString arg1 && isPexpConstantString arg2) -> - isTemplateLiteral arg1 || isTemplateLiteral arg2 - | Pexp_constant (Pconst_string (_, Some _)) -> true - | _ -> false - - (* Blue | Red | Green -> [Blue; Red; Green] *) - let collectOrPatternChain pat = - let rec loop pattern chain = - match pattern.ppat_desc with - | Ppat_or (left, right) -> loop left (right::chain) - | _ -> pattern::chain - in - loop pat [] - - let isPipeExpr expr = match expr.pexp_desc with - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|>") }}, - [(Nolabel, _operand1); (Nolabel, _operand2)] - ) -> true - | _ -> false - - let extractValueDescriptionFromModExpr modExpr = - let rec loop structure acc = - match structure with - | [] -> List.rev acc - | structureItem::structure -> - begin match structureItem.Parsetree.pstr_desc with - | Pstr_primitive vd -> loop structure (vd::acc) - | _ -> loop structure acc - end - in - match modExpr.pmod_desc with - | Pmod_structure structure -> loop structure [] - | _ -> [] - - type jsImportScope = - | JsGlobalImport (* nothing *) - | JsModuleImport of string (* from "path" *) - | JsScopedImport of string list (* window.location *) - - let classifyJsImport valueDescription = - let rec loop attrs = - let open Parsetree in - match attrs with - | [] -> JsGlobalImport - | ({Location.txt = "bs.scope"}, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _)}])::_ -> - JsScopedImport [s] - | ({Location.txt = "genType.import"}, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (s, _))}, _)}])::_ -> - JsModuleImport s - | ({Location.txt = "bs.scope"}, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_tuple exprs}, _)}])::_ -> - let scopes = List.fold_left (fun acc curr -> - match curr.Parsetree.pexp_desc with - | Pexp_constant (Pconst_string (s, _)) -> s::acc - | _ -> acc - ) [] exprs - in - JsScopedImport (List.rev scopes) - | _::attrs -> - loop attrs - in - loop valueDescription.pval_attributes - - let isUnderscoreApplySugar expr = - match expr.pexp_desc with - | Pexp_fun ( - Nolabel, - None, - {ppat_desc = Ppat_var {txt="__x"}}, - {pexp_desc = Pexp_apply _} - ) -> true - | _ -> false -end - -module Parens: sig - type kind = Parenthesized | Braced of Location.t | Nothing - - val expr: Parsetree.expression -> kind - val structureExpr: Parsetree.expression -> kind - - val unaryExprOperand: Parsetree.expression -> kind - - val binaryExprOperand: isLhs:bool -> Parsetree.expression -> kind - val subBinaryExprOperand: string -> string -> bool - val rhsBinaryExprOperand: string -> Parsetree.expression -> bool - val flattenOperandRhs: string -> Parsetree.expression -> bool - - val lazyOrAssertExprRhs: Parsetree.expression -> kind - - val fieldExpr: Parsetree.expression -> kind - - val setFieldExprRhs: Parsetree.expression -> kind - - val ternaryOperand: Parsetree.expression -> kind - - val jsxPropExpr: Parsetree.expression -> kind - val jsxChildExpr: Parsetree.expression -> kind - - val binaryExpr: Parsetree.expression -> kind - val modTypeFunctorReturn: Parsetree.module_type -> bool - val modTypeWithOperand: Parsetree.module_type -> bool - val modExprFunctorConstraint: Parsetree.module_type -> bool - - val bracedExpr: Parsetree.expression -> bool - val callExpr: Parsetree.expression -> kind - - val includeModExpr : Parsetree.module_expr -> bool -end = struct - type kind = Parenthesized | Braced of Location.t | Nothing - - let expr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | _ -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | _ -> Nothing - end - - let callExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | _ -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | _ when ParsetreeViewer.isUnaryExpression expr || ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end - - let structureExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | _ when ParsetreeViewer.hasAttributes expr.pexp_attributes && - not (ParsetreeViewer.isJsxExpression expr) -> Parenthesized - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | _ -> Nothing - end - - let unaryExprOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | expr when - ParsetreeViewer.isUnaryExpression expr || - ParsetreeViewer.isBinaryExpression expr - -> Parenthesized - | {pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_extension _ (* readability? maybe remove *) - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end - - let binaryExprOperand ~isLhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _} -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - } when isLhs -> Parenthesized - | _ -> Nothing - end - - let subBinaryExprOperand parentOperator childOperator = - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence childOperator in - precParent > precChild || - (precParent == precChild && - not (ParsetreeViewer.flattenableOperators parentOperator childOperator)) || - (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) - (parentOperator = "||" && childOperator = "&&") - - let rhsBinaryExprOperand parentOperator rhs = - match rhs.Parsetree.pexp_desc with - | Parsetree.Pexp_apply( - {pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [_, _left; _, _right] - ) when ParsetreeViewer.isBinaryOperator operator -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent == precChild - | _ -> false - - let flattenOperandRhs parentOperator rhs = - match rhs.Parsetree.pexp_desc with - | Parsetree.Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [_, _left; _, _right] - ) when ParsetreeViewer.isBinaryOperator operator -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent >= precChild || rhs.pexp_attributes <> [] - | Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ) -> false - | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_setfield _ - | Pexp_constraint _ -> true - | _ when ParsetreeViewer.isTernaryExpr rhs -> true - | _ -> false - - let lazyOrAssertExprRhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | {pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end - - let isNegativeConstant constant = - let isNeg txt = - let len = String.length txt in - len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' - in - match constant with - | Parsetree.Pconst_integer (i, _) | Pconst_float (i, _) when isNeg i -> true - | _ -> false - - let fieldExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = attrs} when - begin match ParsetreeViewer.filterParsingAttrs attrs with - | _::_ -> true - | [] -> false - end - -> Parenthesized - | expr when - ParsetreeViewer.isBinaryExpression expr || - ParsetreeViewer.isUnaryExpression expr - -> Parenthesized - | {pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constant c } when isNegativeConstant c -> Parenthesized - | {pexp_desc = Pexp_fun _} - when ParsetreeViewer.isUnderscoreApplySugar expr -> Nothing - | {pexp_desc = - Pexp_lazy _ - | Pexp_assert _ - | Pexp_extension _ (* %extension.x vs (%extension).x *) - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_function _ - | Pexp_constraint _ - | Pexp_setfield _ - | Pexp_match _ - | Pexp_try _ - | Pexp_while _ - | Pexp_for _ - | Pexp_ifthenelse _ - } -> Parenthesized - | _ -> Nothing - end - - let setFieldExprRhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | _ -> Nothing - end - - let ternaryOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - )} -> Nothing - | {pexp_desc = Pexp_constraint _ } -> Parenthesized - | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> - let (_attrsOnArrow, _parameters, returnExpr) = ParsetreeViewer.funExpr expr in - begin match returnExpr.pexp_desc with - | Pexp_constraint _ -> Parenthesized - | _ -> Nothing - end - | _ -> Nothing - end - - let startsWithMinus txt = - let len = String.length txt in - if len == 0 then - false - else - let s = (String.get [@doesNotRaise]) txt 0 in - s = '-' - - let jsxPropExpr expr = - match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_let _ - | Pexp_sequence _ - | Pexp_letexception _ - | Pexp_letmodule _ - | Pexp_open _ -> Nothing - | _ -> - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - begin match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []} - when startsWithMinus x -> Parenthesized - | {Parsetree.pexp_desc = - Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | - Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | - Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | - Pexp_let _ | Pexp_tuple _; - pexp_attributes = [] - } -> Nothing - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ); pexp_attributes = []} -> Nothing - | _ -> Parenthesized - end - end - - let jsxChildExpr expr = - match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_let _ - | Pexp_sequence _ - | Pexp_letexception _ - | Pexp_letmodule _ - | Pexp_open _ -> Nothing - | _ -> - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - begin match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | _ -> - begin match expr with - | {Parsetree.pexp_desc = Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = [] - } when startsWithMinus x -> Parenthesized - | {Parsetree.pexp_desc = - Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ | Pexp_variant _ | - Pexp_array _ | Pexp_pack _ | Pexp_record _ | Pexp_extension _ | - Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ | Pexp_sequence _ | - Pexp_let _; - pexp_attributes = [] - } -> Nothing - | {Parsetree.pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ); pexp_attributes = []} -> Nothing - | expr when ParsetreeViewer.isJsxExpression expr -> Nothing - | _ -> Parenthesized - end - end - - let binaryExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced(bracesLoc) - | None -> - begin match expr with - | {Parsetree.pexp_attributes = _::_} as expr - when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | _ -> Nothing - end - - let modTypeFunctorReturn modType = match modType with - | {Parsetree.pmty_desc = Pmty_with _} -> true - | _ -> false - - (* Add parens for readability: - module type Functor = SetLike => Set with type t = A.t - This is actually: - module type Functor = (SetLike => Set) with type t = A.t - *) - let modTypeWithOperand modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _} -> true - | _ -> false - - let modExprFunctorConstraint modType = match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true - | _ -> false - - let bracedExpr expr = match expr.Parsetree.pexp_desc with - | Pexp_constraint ( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ) -> false - | Pexp_constraint _ -> true - | _ -> false - - let includeModExpr modExpr = match modExpr.Parsetree.pmod_desc with - | Parsetree.Pmod_constraint _ -> true - | _ -> false -end - -module CommentTable = struct - type t = { - leading: (Location.t, Comment.t list) Hashtbl.t; - inside: (Location.t, Comment.t list) Hashtbl.t; - trailing: (Location.t, Comment.t list) Hashtbl.t; - } - - let make () = { - leading = Hashtbl.create 100; - inside = Hashtbl.create 100; - trailing = Hashtbl.create 100; - } - - let empty = make () - - let log t = - let open Location in - let leadingStuff = Hashtbl.fold (fun (k : Location.t) (v : Comment.t list) acc -> - let loc = Doc.concat [ - Doc.lbracket; - Doc.text (string_of_int k.loc_start.pos_lnum); - Doc.text ":"; - Doc.text (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); - Doc.text "-"; - Doc.text (string_of_int k.loc_end.pos_lnum); - Doc.text ":"; - Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); - Doc.rbracket; - ] in - let doc = Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - loc; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.comma (List.map (fun c -> Doc.text (Comment.txt c)) v) - ] - ); - Doc.line; - ] - ) in - doc::acc - ) t.leading [] - in - let trailingStuff = Hashtbl.fold (fun (k : Location.t) (v : Comment.t list) acc -> - let loc = Doc.concat [ - Doc.lbracket; - Doc.text (string_of_int k.loc_start.pos_lnum); - Doc.text ":"; - Doc.text (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); - Doc.text "-"; - Doc.text (string_of_int k.loc_end.pos_lnum); - Doc.text ":"; - Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); - Doc.rbracket; - ] in - let doc = Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - loc; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun c -> Doc.text (Comment.txt c)) v) - ] - ); - Doc.line; - ] - ) in - doc::acc - ) t.trailing [] - in - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "leading comments:"; - Doc.line; - Doc.indent (Doc.concat leadingStuff); - Doc.line; - Doc.line; - Doc.text "trailing comments:"; - Doc.indent (Doc.concat trailingStuff); - Doc.line; - Doc.line; - ] - ) |> Doc.toString ~width:80 |> print_endline - [@@live] - let attach tbl loc comments = - match comments with - | [] -> () - | comments -> Hashtbl.replace tbl loc comments - - let partitionByLoc comments loc = - let rec loop (leading, inside, trailing) comments = - let open Location in - match comments with - | comment::rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment::leading, inside, trailing) rest - else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then - loop (leading, inside, comment::trailing) rest - else - loop (leading, comment::inside, trailing) rest - | [] -> (List.rev leading, List.rev inside, List.rev trailing) - in - loop ([], [], []) comments - - let partitionLeadingTrailing comments loc = - let rec loop (leading, trailing) comments = - let open Location in - match comments with - | comment::rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment::leading, trailing) rest - else - loop (leading, comment::trailing) rest - | [] -> (List.rev leading, List.rev trailing) - in - loop ([], []) comments - - let partitionByOnSameLine loc comments = - let rec loop (onSameLine, onOtherLine) comments = - let open Location in - match comments with - | [] -> (List.rev onSameLine, List.rev onOtherLine) - | comment::rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then - loop (comment::onSameLine, onOtherLine) rest - else - loop (onSameLine, comment::onOtherLine) rest - in - loop ([], []) comments - - let partitionAdjacentTrailing loc1 comments = - let open Location in - let open Lexing in - let rec loop ~prevEndPos afterLoc1 comments = - match comments with - | [] -> (List.rev afterLoc1, []) - | (comment::rest) as comments -> - let cmtPrevEndPos = Comment.prevTokEndPos comment in - if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then - let commentEnd = (Comment.loc comment).loc_end in - loop ~prevEndPos:commentEnd (comment::afterLoc1) rest - else - (List.rev afterLoc1, comments) - in - loop ~prevEndPos:loc1.loc_end [] comments - - let rec collectListPatterns acc pattern = - let open Parsetree in - match pattern.ppat_desc with - | Ppat_construct( - {txt = Longident.Lident "::"}, - Some {ppat_desc=Ppat_tuple (pat::rest::[])} - ) -> - collectListPatterns (pat::acc) rest - | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> - List.rev acc - | _ -> List.rev (pattern::acc) - - let rec collectListExprs acc expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_construct( - {txt = Longident.Lident "::"}, - Some {pexp_desc=Pexp_tuple (expr::rest::[])} - ) -> - collectListExprs (expr::acc) rest - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - List.rev acc - | _ -> List.rev (expr::acc) - - (* TODO: use ParsetreeViewer *) - let arrowType ct = - let open Parsetree in - let rec process attrsBefore acc typ = match typ with - | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = []} -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel as lbl, typ1, typ2); ptyp_attributes = [({txt ="bs"}, _) ] as attrs} -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) - | {ptyp_desc = Ptyp_arrow ((Labelled _ | Optional _) as lbl, typ1, typ2); ptyp_attributes = attrs} -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg::acc) typ2 - | typ -> - (attrsBefore, List.rev acc, typ) - in - begin match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as typ -> - process attrs [] {typ with ptyp_attributes = []} - | typ -> process [] [] typ - end - - (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) - let modExprApply modExpr = - let rec loop acc modExpr = match modExpr with - | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> - loop (arg::acc) next - | _ -> (modExpr::acc) - in - loop [] modExpr - - (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) - let modExprFunctor modExpr = - let rec loop acc modExpr = match modExpr with - | {Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); pmod_attributes = attrs} -> - let param = (attrs, lbl, modType) in - loop (param::acc) returnModExpr - | returnModExpr -> - (List.rev acc, returnModExpr) - in - loop [] modExpr - - let functorType modtype = - let rec process acc modtype = match modtype with - | {Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); pmty_attributes = attrs} -> - let arg = (attrs, lbl, argType) in - process (arg::acc) returnType - | modType -> - (List.rev acc, modType) - in - process [] modtype - - let funExpr expr = - let open Parsetree in - (* Turns (type t, type u, type z) into "type t u z" *) - let rec collectNewTypes acc returnExpr = - match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} -> - collectNewTypes (stringLoc::acc) returnExpr - | returnExpr -> - let loc = match (acc, List.rev acc) with - | (_startLoc::_, endLoc::_) -> { endLoc.loc with loc_end = endLoc.loc.loc_end } - | _ -> Location.none - in - let txt = List.fold_right (fun curr acc -> acc ^ " " ^ curr.Location.txt) acc "type" in - (Location.mkloc txt loc, returnExpr) - in - (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, - * otherwise this function would need to return a variant: - * | NormalParamater(...) - * | NewType(...) - * This complicates printing with an extra variant/boxing/allocation for a code-path - * that is not often used. Lets just keep it simple for now *) - let rec collect attrsBefore acc expr = match expr with - | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = []} -> - let parameter = ([], lbl, defaultExpr, pattern) in - collect attrsBefore (parameter::acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let (var, returnExpr) = collectNewTypes [stringLoc] rest in - let parameter = ( - attrs, - Asttypes.Nolabel, - None, - Ast_helper.Pat.var ~loc:stringLoc.loc var - ) in - collect attrsBefore (parameter::acc) returnExpr - | {pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); pexp_attributes = [({txt = "bs"}, _)] as attrs} -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter::acc) returnExpr - | { - pexp_desc = Pexp_fun ((Labelled _ | Optional _) as lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = attrs - } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter::acc) returnExpr - | expr -> - (attrsBefore, List.rev acc, expr) - in - begin match expr with - | {pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); pexp_attributes = attrs} as expr -> - collect attrs [] {expr with pexp_attributes = []} - | expr -> collect [] [] expr - end - - let rec isBlockExpr expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_let _ - | Pexp_open _ - | Pexp_sequence _ -> true - | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true - | Pexp_constraint (expr, _) when isBlockExpr expr -> true - | Pexp_field (expr, _) when isBlockExpr expr -> true - | Pexp_setfield (expr, _, _) when isBlockExpr expr -> true - | _ -> false - - let rec walkStructure s t comments = - match s with - | _ when comments = [] -> () - | [] -> attach t.inside Location.none comments - | s -> - walkList - ~getLoc:(fun n -> n.Parsetree.pstr_loc) - ~walkNode:walkStructureItem - s - t - comments - - and walkStructureItem si t comments = - match si.Parsetree.pstr_desc with - | _ when comments = [] -> () - | Pstr_primitive valueDescription -> - walkValueDescription valueDescription t comments - | Pstr_open openDescription -> - walkOpenDescription openDescription t comments - | Pstr_value (_, valueBindings) -> - walkValueBindings valueBindings t comments - | Pstr_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments - | Pstr_eval (expr, _) -> - walkExpr expr t comments - | Pstr_module moduleBinding -> - walkModuleBinding moduleBinding t comments - | Pstr_recmodule moduleBindings -> - walkList - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~walkNode:walkModuleBinding - moduleBindings - t - comments - | Pstr_modtype modTypDecl -> - walkModuleTypeDeclaration modTypDecl t comments - | Pstr_attribute attribute -> - walkAttribute attribute t comments - | Pstr_extension (extension, _) -> - walkExtension extension t comments - | Pstr_include includeDeclaration -> - walkIncludeDeclaration includeDeclaration t comments - | Pstr_exception extensionConstructor -> - walkExtConstr extensionConstructor t comments - | Pstr_typext typeExtension -> - walkTypeExtension typeExtension t comments - | Pstr_class_type _ | Pstr_class _ -> () - - and walkValueDescription vd t comments = - let (leading, trailing) = - partitionLeadingTrailing comments vd.pval_name.loc in - attach t.leading vd.pval_name.loc leading; - let (afterName, rest) = - partitionAdjacentTrailing vd.pval_name.loc trailing in - attach t.trailing vd.pval_name.loc afterName; - let (before, inside, after) = - partitionByLoc rest vd.pval_type.ptyp_loc - in - attach t.leading vd.pval_type.ptyp_loc before; - walkTypExpr vd.pval_type t inside; - attach t.trailing vd.pval_type.ptyp_loc after - - and walkTypeExtension te t comments = - let (leading, trailing) = - partitionLeadingTrailing comments te.ptyext_path.loc in - attach t.leading te.ptyext_path.loc leading; - let (afterPath, rest) = - partitionAdjacentTrailing te.ptyext_path.loc trailing in - attach t.trailing te.ptyext_path.loc afterPath; - - (* type params *) - let rest = match te.ptyext_params with - | [] -> rest - | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam - ~newlineDelimited:false - typeParams - t - rest - in - walkList - ~getLoc:(fun n -> n.Parsetree.pext_loc) - ~walkNode:walkExtConstr - te.ptyext_constructors - t - rest - - and walkIncludeDeclaration inclDecl t comments = - let (before, inside, after) = - partitionByLoc comments inclDecl.pincl_mod.pmod_loc in - attach t.leading inclDecl.pincl_mod.pmod_loc before; - walkModExpr inclDecl.pincl_mod t inside; - attach t.trailing inclDecl.pincl_mod.pmod_loc after - - and walkModuleTypeDeclaration mtd t comments = - let (leading, trailing) = - partitionLeadingTrailing comments mtd.pmtd_name.loc in - attach t.leading mtd.pmtd_name.loc leading; - begin match mtd.pmtd_type with - | None -> - attach t.trailing mtd.pmtd_name.loc trailing - | Some modType -> - let (afterName, rest) = partitionAdjacentTrailing mtd.pmtd_name.loc trailing in - attach t.trailing mtd.pmtd_name.loc afterName; - let (before, inside, after) = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - end - - and walkModuleBinding mb t comments = - let (leading, trailing) = partitionLeadingTrailing comments mb.pmb_name.loc in - attach t.leading mb.pmb_name.loc leading; - let (afterName, rest) = partitionAdjacentTrailing mb.pmb_name.loc trailing in - attach t.trailing mb.pmb_name.loc afterName; - let (leading, inside, trailing) = partitionByLoc rest mb.pmb_expr.pmod_loc in - begin match mb.pmb_expr.pmod_desc with - | Pmod_constraint _ -> - walkModExpr mb.pmb_expr t (List.concat [leading; inside]); - | _ -> - attach t.leading mb.pmb_expr.pmod_loc leading; - walkModExpr mb.pmb_expr t inside; - end; - attach t.trailing mb.pmb_expr.pmod_loc trailing - - and walkSignature signature t comments = - match signature with - | _ when comments = [] -> () - | [] -> attach t.inside Location.none comments - | _s -> - walkList - ~getLoc:(fun n -> n.Parsetree.psig_loc) - ~walkNode:walkSignatureItem - signature - t - comments - - and walkSignatureItem si t comments = - match si.psig_desc with - | _ when comments = [] -> () - | Psig_value valueDescription -> - walkValueDescription valueDescription t comments - | Psig_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments - | Psig_typext typeExtension -> - walkTypeExtension typeExtension t comments - | Psig_exception extensionConstructor -> - walkExtConstr extensionConstructor t comments - | Psig_module moduleDeclaration -> - walkModuleDeclaration moduleDeclaration t comments - | Psig_recmodule moduleDeclarations -> - walkList - ~getLoc:(fun n -> n.Parsetree.pmd_loc) - ~walkNode:walkModuleDeclaration - moduleDeclarations - t - comments - | Psig_modtype moduleTypeDeclaration -> - walkModuleTypeDeclaration moduleTypeDeclaration t comments - | Psig_open openDescription -> - walkOpenDescription openDescription t comments - | Psig_include includeDescription -> - walkIncludeDescription includeDescription t comments - | Psig_attribute attribute -> - walkAttribute attribute t comments - | Psig_extension (extension, _) -> - walkExtension extension t comments - | Psig_class _ | Psig_class_type _ -> () - - and walkIncludeDescription id t comments = - let (before, inside, after) = - partitionByLoc comments id.pincl_mod.pmty_loc in - attach t.leading id.pincl_mod.pmty_loc before; - walkModType id.pincl_mod t inside; - attach t.trailing id.pincl_mod.pmty_loc after - - and walkModuleDeclaration md t comments = - let (leading, trailing) = partitionLeadingTrailing comments md.pmd_name.loc in - attach t.leading md.pmd_name.loc leading; - let (afterName, rest) = partitionAdjacentTrailing md.pmd_name.loc trailing in - attach t.trailing md.pmd_name.loc afterName; - let (leading, inside, trailing) = partitionByLoc rest md.pmd_type.pmty_loc in - attach t.leading md.pmd_type.pmty_loc leading; - walkModType md.pmd_type t inside; - attach t.trailing md.pmd_type.pmty_loc trailing - - and walkList: - 'node. - ?prevLoc:Location.t -> - getLoc:('node -> Location.t) -> - walkNode:('node -> t -> Comment.t list -> unit) -> - 'node list -> t -> Comment.t list -> unit - = fun ?prevLoc ~getLoc ~walkNode l t comments -> - let open Location in - match l with - | _ when comments = [] -> () - | [] -> - begin match prevLoc with - | Some loc -> - attach t.trailing loc comments - | None -> () - end - | node::rest -> - let currLoc = getLoc node in - let (leading, inside, trailing) = partitionByLoc comments currLoc in - begin match prevLoc with - | None -> (* first node, all leading comments attach here *) - attach t.leading currLoc leading - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then - let (afterPrev, beforeCurr) = partitionAdjacentTrailing prevLoc leading in - let () = attach t.trailing prevLoc afterPrev in - attach t.leading currLoc beforeCurr - else - let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine prevLoc leading in - let () = attach t.trailing prevLoc onSameLineAsPrev in - let (leading, _inside, _trailing) = partitionByLoc afterPrev currLoc in - attach t.leading currLoc leading - end; - walkNode node t inside; - walkList ~prevLoc:currLoc ~getLoc ~walkNode rest t trailing - - (* The parsetree doesn't always contain location info about the opening or - * closing token of a "list-of-things". This routine visits the whole list, - * but returns any remaining comments that likely fall after the whole list. *) - and visitListButContinueWithRemainingComments: - 'node. - ?prevLoc:Location.t -> - newlineDelimited:bool -> - getLoc:('node -> Location.t) -> - walkNode:('node -> t -> Comment.t list -> unit) -> - 'node list -> t -> Comment.t list -> Comment.t list - = fun ?prevLoc ~newlineDelimited ~getLoc ~walkNode l t comments -> - let open Location in - match l with - | _ when comments = [] -> [] - | [] -> - begin match prevLoc with - | Some loc -> - let (afterPrev, rest) = - if newlineDelimited then - partitionByOnSameLine loc comments - else - partitionAdjacentTrailing loc comments - in - attach t.trailing loc afterPrev; - rest - | None -> comments - end - | node::rest -> - let currLoc = getLoc node in - let (leading, inside, trailing) = partitionByLoc comments currLoc in - let () = match prevLoc with - | None -> (* first node, all leading comments attach here *) - attach t.leading currLoc leading; - () - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then - let (afterPrev, beforeCurr) = partitionAdjacentTrailing prevLoc leading in - let () = attach t.trailing prevLoc afterPrev in - let () = attach t.leading currLoc beforeCurr in - () - else - let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine prevLoc leading in - let () = attach t.trailing prevLoc onSameLineAsPrev in - let (leading, _inside, _trailing) = partitionByLoc afterPrev currLoc in - let () = attach t.leading currLoc leading in - () - in - walkNode node t inside; - visitListButContinueWithRemainingComments - ~prevLoc:currLoc ~getLoc ~walkNode ~newlineDelimited - rest t trailing - - and walkValueBindings vbs t comments = - walkList - ~getLoc:(fun n -> n.Parsetree.pvb_loc) - ~walkNode:walkValueBinding - vbs - t - comments - - and walkOpenDescription openDescription t comments = - let loc = openDescription.popen_lid.loc in - let (leading, trailing) = partitionLeadingTrailing comments loc in - attach t.leading loc leading; - attach t.trailing loc trailing; - - and walkTypeDeclarations typeDeclarations t comments = - walkList - ~getLoc:(fun n -> n.Parsetree.ptype_loc) - ~walkNode:walkTypeDeclaration - typeDeclarations - t - comments - - and walkTypeParam (typexpr, _variance) t comments = - walkTypExpr typexpr t comments - - and walkTypeDeclaration td t comments = - let (beforeName, rest) = - partitionLeadingTrailing comments td.ptype_name.loc in - attach t.leading td.ptype_name.loc beforeName; - - let (afterName, rest) = - partitionAdjacentTrailing td.ptype_name.loc rest in - attach t.trailing td.ptype_name.loc afterName; - - (* type params *) - let rest = match td.ptype_params with - | [] -> rest - | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam - ~newlineDelimited:false - typeParams - t - rest - in - - (* manifest: = typexpr *) - let rest = match td.ptype_manifest with - | Some typexpr -> - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - let (afterTyp, rest) = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - - let rest = match td.ptype_kind with - | Ptype_abstract | Ptype_open -> rest - | Ptype_record labelDeclarations -> - let () = walkList - ~getLoc:(fun ld -> ld.Parsetree.pld_loc) - ~walkNode:walkLabelDeclaration - labelDeclarations - t - rest - in - [] - | Ptype_variant constructorDeclarations -> - walkConstructorDeclarations constructorDeclarations t rest - in - attach t.trailing td.ptype_loc rest - - and walkLabelDeclarations lds t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun ld -> ld.Parsetree.pld_loc) - ~walkNode:walkLabelDeclaration - ~newlineDelimited:false - lds - t - comments - - and walkLabelDeclaration ld t comments = - let (beforeName, rest) = - partitionLeadingTrailing comments ld.pld_name.loc in - attach t.leading ld.pld_name.loc beforeName; - let (afterName, rest) = partitionAdjacentTrailing ld.pld_name.loc rest in - attach t.trailing ld.pld_name.loc afterName; - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc rest ld.pld_type.ptyp_loc in - attach t.leading ld.pld_type.ptyp_loc beforeTyp; - walkTypExpr ld.pld_type t insideTyp; - attach t.trailing ld.pld_type.ptyp_loc afterTyp - - and walkConstructorDeclarations cds t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) - ~walkNode:walkConstructorDeclaration - ~newlineDelimited:false - cds - t - comments - - and walkConstructorDeclaration cd t comments = - let (beforeName, rest) = - partitionLeadingTrailing comments cd.pcd_name.loc in - attach t.leading cd.pcd_name.loc beforeName; - let (afterName, rest) = - partitionAdjacentTrailing cd.pcd_name.loc rest in - attach t.trailing cd.pcd_name.loc afterName; - let rest = walkConstructorArguments cd.pcd_args t rest in - - let rest = match cd.pcd_res with - | Some typexpr -> - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - let (afterTyp, rest) = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - attach t.trailing cd.pcd_loc rest - - and walkConstructorArguments args t comments = - match args with - | Pcstr_tuple typexprs -> - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkTypExpr - ~newlineDelimited:false - typexprs - t - comments - | Pcstr_record labelDeclarations -> - walkLabelDeclarations labelDeclarations t comments - - and walkValueBinding vb t comments = - let open Location in - - let vb = - let open Parsetree in - match (vb.pvb_pat, vb.pvb_expr) with - | {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, - {pexp_desc = Pexp_constraint (expr, _typ)} -> - {vb with - pvb_pat = Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} pat t; - pvb_expr = expr; - } - | {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_::_, t)})}, - {pexp_desc = Pexp_fun _} -> - {vb with - pvb_pat = {vb.pvb_pat with - ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}}} - | _ -> vb - in - let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in - let exprLoc = vb.Parsetree.pvb_expr.pexp_loc in - - let (leading, inside, trailing) = - partitionByLoc comments patternLoc in - - (* everything before start of pattern can only be leading on the pattern: - * let |* before *| a = 1 *) - attach t.leading patternLoc leading; - walkPattern vb.Parsetree.pvb_pat t inside; - (* let pattern = expr -> pattern and expr on the same line *) - (* if patternLoc.loc_end.pos_lnum == exprLoc.loc_start.pos_lnum then ( *) - let (afterPat, surroundingExpr) = - partitionAdjacentTrailing patternLoc trailing - in - attach t.trailing patternLoc afterPat; - let (beforeExpr, insideExpr, afterExpr) = - partitionByLoc surroundingExpr exprLoc in - if isBlockExpr vb.pvb_expr then ( - walkExpr vb.pvb_expr t (List.concat [beforeExpr; insideExpr; afterExpr]) - ) else ( - attach t.leading exprLoc beforeExpr; - walkExpr vb.Parsetree.pvb_expr t insideExpr; - attach t.trailing exprLoc afterExpr - ) - - and walkExpr expr t comments = - let open Location in - match expr.Parsetree.pexp_desc with - | _ when comments = [] -> () - | Pexp_constant _ -> - let (leading, trailing) = - partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - attach t.trailing expr.pexp_loc trailing; - | Pexp_ident longident -> - let (leading, trailing) = - partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing; - | Pexp_let (_recFlag, valueBindings, expr2) -> - let comments = visitListButContinueWithRemainingComments - ~getLoc:(fun n -> - if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then - n.pvb_expr.pexp_loc - else - n.Parsetree.pvb_loc - ) - ~walkNode:walkValueBinding - ~newlineDelimited:true - valueBindings - t - comments - in - if isBlockExpr expr2 then ( - walkExpr expr2 t comments; - ) else ( - let (leading, inside, trailing) = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - ) - | Pexp_sequence (expr1, expr2) -> - let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in - let comments = if isBlockExpr expr1 then ( - let (afterExpr, comments) = partitionByOnSameLine expr1.pexp_loc trailing in - walkExpr expr1 t (List.concat [leading; inside; afterExpr]); - comments - ) else ( - attach t.leading expr1.pexp_loc leading; - walkExpr expr1 t inside; - let (afterExpr, comments) = partitionByOnSameLine expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - comments - ) in - if isBlockExpr expr2 then ( - walkExpr expr2 t comments - ) else ( - let (leading, inside, trailing) = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - ) - | Pexp_open (_override, longident, expr2) -> - let (leading, comments) = - partitionLeadingTrailing comments expr.pexp_loc in - attach - t.leading - {expr.pexp_loc with loc_end = longident.loc.loc_end} - leading; - let (leading, trailing) = - partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - let (afterLongident, rest) = - partitionByOnSameLine longident.loc trailing in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then ( - walkExpr expr2 t rest - ) else ( - let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - ) - | Pexp_extension ( - {txt = "bs.obj"}, - PStr [{ - pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, []) - }] - ) -> - walkList - ~getLoc:(fun ( - (longident, expr): (Longident.t Asttypes.loc * Parsetree.expression) - ) -> { - longident.loc with loc_end = expr.pexp_loc.loc_end - }) - ~walkNode:walkExprRecordRow - rows - t - comments - | Pexp_extension extension -> - walkExtension extension t comments - | Pexp_letexception (extensionConstructor, expr2) -> - let (leading, comments) = - partitionLeadingTrailing comments expr.pexp_loc in - attach - t.leading - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} - leading; - let (leading, inside, trailing) = - partitionByLoc comments extensionConstructor.pext_loc in - attach t.leading extensionConstructor.pext_loc leading; - walkExtConstr extensionConstructor t inside; - let (afterExtConstr, rest) = - partitionByOnSameLine extensionConstructor.pext_loc trailing in - attach t.trailing extensionConstructor.pext_loc afterExtConstr; - if isBlockExpr expr2 then ( - walkExpr expr2 t rest - ) else ( - let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - ) - | Pexp_letmodule (stringLoc, modExpr, expr2) -> - let (leading, comments) = - partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} leading; - let (leading, trailing) = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - let (afterString, rest) = - partitionAdjacentTrailing stringLoc.loc trailing in - attach t.trailing stringLoc.loc afterString; - let (beforeModExpr, insideModExpr, afterModExpr) = - partitionByLoc rest modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc beforeModExpr; - walkModExpr modExpr t insideModExpr; - let (afterModExpr, rest) = - partitionByOnSameLine modExpr.pmod_loc afterModExpr in - attach t.trailing modExpr.pmod_loc afterModExpr; - if isBlockExpr expr2 then ( - walkExpr expr2 t rest; - ) else ( - let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - ) - | Pexp_assert expr - | Pexp_lazy expr -> - if isBlockExpr expr then ( - walkExpr expr t comments - ) else ( - let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc trailing - ) - | Pexp_coerce (expr, optTypexpr, typexpr) -> - let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - let (afterExpr, rest) = - partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let rest = match optTypexpr with - | Some typexpr -> - let (leading, inside, trailing) = partitionByLoc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkTypExpr typexpr t inside; - let (afterTyp, rest) = - partitionAdjacentTrailing typexpr.ptyp_loc trailing in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - let (leading, inside, trailing) = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkTypExpr typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing - | Pexp_constraint (expr, typexpr) -> - let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - let (afterExpr, rest) = - partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let (leading, inside, trailing) = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkTypExpr typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing - | Pexp_tuple [] - | Pexp_array [] - | Pexp_construct({txt = Longident.Lident "[]"}, _) -> - attach t.inside expr.pexp_loc comments - | Pexp_construct({txt = Longident.Lident "::"}, _) -> - walkList - ~getLoc:(fun n -> n.Parsetree.pexp_loc) - ~walkNode:walkExpr - (collectListExprs [] expr) - t - comments - | Pexp_construct (longident, args) -> - let (leading, trailing) = - partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - begin match args with - | Some expr -> - let (afterLongident, rest) = - partitionAdjacentTrailing longident.loc trailing in - attach t.trailing longident.loc afterLongident; - walkExpr expr t rest - | None -> - attach t.trailing longident.loc trailing - end - | Pexp_variant (_label, None) -> - () - | Pexp_variant (_label, Some expr) -> - walkExpr expr t comments - | Pexp_array exprs | Pexp_tuple exprs -> - walkList - ~getLoc:(fun n -> n.Parsetree.pexp_loc) - ~walkNode:walkExpr - exprs - t - comments - | Pexp_record (rows, spreadExpr) -> - let comments = match spreadExpr with - | None -> comments - | Some expr -> - let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - rest - in - walkList - ~getLoc:(fun ( - (longident, expr): (Longident.t Asttypes.loc * Parsetree.expression) - ) -> { - longident.loc with loc_end = expr.pexp_loc.loc_end - }) - ~walkNode:walkExprRecordRow - rows - t - comments - | Pexp_field (expr, longident) -> - let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in - let trailing = if isBlockExpr expr then ( - let (afterExpr, rest) = - partitionAdjacentTrailing expr.pexp_loc trailing in - walkExpr expr t (List.concat [leading; inside; afterExpr]); - rest - ) else ( - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - trailing - ) in - let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let (leading, trailing) = partitionLeadingTrailing rest longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pexp_setfield (expr1, longident, expr2) -> - let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in - let rest = if isBlockExpr expr1 then ( - let (afterExpr, rest) = - partitionAdjacentTrailing expr1.pexp_loc trailing in - walkExpr expr1 t (List.concat [leading; inside; afterExpr]); - rest - ) else ( - let (afterExpr, rest) = - partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.leading expr1.pexp_loc leading; - walkExpr expr1 t inside; - attach t.trailing expr1.pexp_loc afterExpr; - rest - ) in - let (beforeLongident, afterLongident) = partitionLeadingTrailing rest longident.loc in - attach t.leading longident.loc beforeLongident; - let (afterLongident, rest) = partitionAdjacentTrailing longident.loc afterLongident in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then - walkExpr expr2 t rest - else ( - let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - ) - | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> - let (leading, inside, trailing) = partitionByLoc comments ifExpr.pexp_loc in - let comments = if isBlockExpr ifExpr then ( - let (afterExpr, comments) = partitionAdjacentTrailing ifExpr.pexp_loc trailing in - walkExpr ifExpr t (List.concat [leading; inside; afterExpr]); - comments - ) else ( - attach t.leading ifExpr.pexp_loc leading; - walkExpr ifExpr t inside; - let (afterExpr, comments) = partitionAdjacentTrailing ifExpr.pexp_loc trailing in - attach t.trailing ifExpr.pexp_loc afterExpr; - comments - ) in - let (leading, inside, trailing) = partitionByLoc comments thenExpr.pexp_loc in - let comments = if isBlockExpr thenExpr then ( - let (afterExpr, trailing) = partitionAdjacentTrailing thenExpr.pexp_loc trailing in - walkExpr thenExpr t (List.concat [leading; inside; afterExpr]); - trailing - ) else ( - attach t.leading thenExpr.pexp_loc leading; - walkExpr thenExpr t inside; - let (afterExpr, comments) = partitionAdjacentTrailing thenExpr.pexp_loc trailing in - attach t.trailing thenExpr.pexp_loc afterExpr; - comments - ) in - begin match elseExpr with - | None -> () - | Some expr -> - if isBlockExpr expr then - walkExpr expr t comments - else ( - let (leading, inside, trailing) = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc trailing - ) - end - | Pexp_while (expr1, expr2) -> - let (leading, inside, trailing) = partitionByLoc comments expr1.pexp_loc in - let rest = if isBlockExpr expr1 then - let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in - walkExpr expr1 t (List.concat [leading; inside; afterExpr]); - rest - else ( - attach t.leading expr1.pexp_loc leading; - walkExpr expr1 t inside; - let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - rest - ) in - if isBlockExpr expr2 then ( - walkExpr expr2 t rest - ) else ( - let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - ) - | Pexp_for (pat, expr1, expr2, _, expr3) -> - let (leading, inside, trailing) = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let (afterPat, rest) = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.trailing pat.ppat_loc afterPat; - let (leading, inside, trailing) = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc leading; - walkExpr expr1 t inside; - let (afterExpr, rest) = partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - let (leading, inside, trailing) = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpr expr2 t inside; - let (afterExpr, rest) = partitionAdjacentTrailing expr2.pexp_loc trailing in - attach t.trailing expr2.pexp_loc afterExpr; - if isBlockExpr expr3 then ( - walkExpr expr3 t rest - ) else ( - let (leading, inside, trailing) = partitionByLoc rest expr3.pexp_loc in - attach t.leading expr3.pexp_loc leading; - walkExpr expr3 t inside; - attach t.trailing expr3.pexp_loc trailing - ) - | Pexp_pack modExpr -> - let (before, inside, after) = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> - let (before, inside, after) = partitionByLoc comments expr.pexp_loc in - let after = if isBlockExpr expr then ( - let (afterExpr, rest) = - partitionAdjacentTrailing expr.pexp_loc after in - walkExpr expr t (List.concat [before; inside; afterExpr]); - rest - ) else ( - attach t.leading expr.pexp_loc before; - walkExpr expr t inside; - after - ) in - let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc after in - attach t.trailing expr.pexp_loc afterExpr; - walkList - ~getLoc:(fun n -> {n.Parsetree.pc_lhs.ppat_loc with - loc_end = n.pc_rhs.pexp_loc.loc_end}) - ~walkNode:walkCase - cases - t - rest - (* unary expression: todo use parsetreeviewer *) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident - ("~+" | "~+." | "~-" | "~-." | "not" | "!") - }}, - [Nolabel, argExpr] - ) -> - let (before, inside, after) = partitionByLoc comments argExpr.pexp_loc in - attach t.leading argExpr.pexp_loc before; - walkExpr argExpr t inside; - attach t.trailing argExpr.pexp_loc after - (* binary expression *) - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident - (":=" | "||" | "&&" | "=" | "==" | "<" | ">" - | "!=" | "!==" | "<=" | ">=" | "|>" | "+" | "+." - | "-" | "-." | "++" | "^" | "*" | "*." | "/" - | "/." | "**" | "|." | "<>") }}, - [(Nolabel, operand1); (Nolabel, operand2)] - ) -> - let (before, inside, after) = partitionByLoc comments operand1.pexp_loc in - attach t.leading operand1.pexp_loc before; - walkExpr operand1 t inside; - let (afterOperand1, rest) = - partitionAdjacentTrailing operand1.pexp_loc after in - attach t.trailing operand1.pexp_loc afterOperand1; - let (before, inside, after) = partitionByLoc rest operand2.pexp_loc in - attach t.leading operand2.pexp_loc before; - walkExpr operand2 t inside; (* (List.concat [inside; after]); *) - attach t.trailing operand2.pexp_loc after; - | Pexp_apply (callExpr, arguments) -> - let (before, inside, after) = partitionByLoc comments callExpr.pexp_loc in - let after = if isBlockExpr callExpr then ( - let (afterExpr, rest) = - partitionAdjacentTrailing callExpr.pexp_loc after in - walkExpr callExpr t (List.concat [before; inside; afterExpr]); - rest - ) else ( - attach t.leading callExpr.pexp_loc before; - walkExpr callExpr t inside; - after - ) in - let (afterExpr, rest) = partitionAdjacentTrailing callExpr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr; - walkList - ~getLoc:(fun (_argLabel, expr) -> - let loc = match expr.Parsetree.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> - expr.pexp_loc - in - loc) - ~walkNode:walkExprArgument - arguments - t - rest - | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> - let (_, parameters, returnExpr) = funExpr expr in - let comments = visitListButContinueWithRemainingComments - ~newlineDelimited:false - ~walkNode:walkExprPararameter - ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> - let open Parsetree in - let startPos = match pattern.ppat_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_attrs -> - loc.loc_start - | _ -> - pattern.ppat_loc.loc_start - in - match exprOpt with - | None -> {pattern.ppat_loc with loc_start = startPos} - | Some expr -> { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end - } - ) - parameters - t - comments - in - begin match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) - when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum - -> - let (leading, inside, trailing) = partitionByLoc comments typ.ptyp_loc in - attach t.leading typ.ptyp_loc leading; - walkTypExpr typ t inside; - let (afterTyp, comments) = - partitionAdjacentTrailing typ.ptyp_loc trailing in - attach t.trailing typ.ptyp_loc afterTyp; - if isBlockExpr expr then - walkExpr expr t comments - else ( - let (leading, inside, trailing) = - partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc trailing - ) - | _ -> - if isBlockExpr returnExpr then - walkExpr returnExpr t comments - else ( - let (leading, inside, trailing) = - partitionByLoc comments returnExpr.pexp_loc in - attach t.leading returnExpr.pexp_loc leading; - walkExpr returnExpr t inside; - attach t.trailing returnExpr.pexp_loc trailing - ) - end - | _ -> () - - and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = - let (leading, inside, trailing) = partitionByLoc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - begin match exprOpt with - | Some expr -> - let (_afterPat, rest) = - partitionAdjacentTrailing pattern.ppat_loc trailing in - attach t.trailing pattern.ppat_loc trailing; - if isBlockExpr expr then - walkExpr expr t rest - else ( - let (leading, inside, trailing) = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc trailing - ) - | None -> - attach t.trailing pattern.ppat_loc trailing - end - - and walkExprArgument (_argLabel, expr) t comments = - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_attrs -> - let (leading, trailing) = partitionLeadingTrailing comments loc in - attach t.leading loc leading; - let (afterLabel, rest) = partitionAdjacentTrailing loc trailing in - attach t.trailing loc afterLabel; - let (before, inside, after) = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc after - | _ -> - let (before, inside, after) = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc after - - and walkCase case t comments = - let (before, inside, after) = partitionByLoc comments case.pc_lhs.ppat_loc in - (* cases don't have a location on their own, leading comments should go - * after the bar on the pattern *) - walkPattern case.pc_lhs t (List.concat [before; inside]); - let (afterPat, rest) = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; - let comments = match case.pc_guard with - | Some expr -> - let (before, inside, after) = partitionByLoc rest expr.pexp_loc in - let (afterExpr, rest) = partitionAdjacentTrailing expr.pexp_loc after in - if isBlockExpr expr then ( - walkExpr expr t (List.concat [before; inside; afterExpr]) - ) else ( - attach t.leading expr.pexp_loc before; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc afterExpr; - ); - rest - | None -> rest - in - if isBlockExpr case.pc_rhs then ( - walkExpr case.pc_rhs t comments - ) else ( - let (before, inside, after) = partitionByLoc comments case.pc_rhs.pexp_loc in - attach t.leading case.pc_rhs.pexp_loc before; - walkExpr case.pc_rhs t inside; - attach t.trailing case.pc_rhs.pexp_loc after - ) - - and walkExprRecordRow (longident, expr) t comments = - let (beforeLongident, afterLongident) = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - let (afterLongident, rest) = - partitionAdjacentTrailing longident.loc afterLongident in - attach t.trailing longident.loc afterLongident; - let (leading, inside, trailing) = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc trailing - - and walkExtConstr extConstr t comments = - let (leading, trailing) = - partitionLeadingTrailing comments extConstr.pext_name.loc in - attach t.leading extConstr.pext_name.loc leading; - let (afterName, rest) = - partitionAdjacentTrailing extConstr.pext_name.loc trailing in - attach t.trailing extConstr.pext_name.loc afterName; - walkExtensionConstructorKind extConstr.pext_kind t rest - - and walkExtensionConstructorKind kind t comments = - match kind with - | Pext_rebind longident -> - let (leading, trailing) = - partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pext_decl (constructorArguments, maybeTypExpr) -> - let rest = walkConstructorArguments constructorArguments t comments in - begin match maybeTypExpr with - | None -> () - | Some typexpr -> - let (before, inside, after) = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc before; - walkTypExpr typexpr t inside; - attach t.trailing typexpr.ptyp_loc after - end - - and walkModExpr modExpr t comments = - match modExpr.pmod_desc with - | Pmod_ident longident -> - let (before, after) = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc before; - attach t.trailing longident.loc after - | Pmod_structure structure -> - walkStructure structure t comments - | Pmod_extension extension -> - walkExtension extension t comments - | Pmod_unpack expr -> - let (before, inside, after) = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpr expr t inside; - attach t.trailing expr.pexp_loc after - | Pmod_constraint (modexpr, modtype) -> - if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( - let (before, inside, after) = partitionByLoc comments modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModExpr modexpr t inside; - let (after, rest) = partitionAdjacentTrailing modexpr.pmod_loc after in - attach t.trailing modexpr.pmod_loc after; - let (before, inside, after) = partitionByLoc rest modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - attach t.trailing modtype.pmty_loc after - ) else ( - let (before, inside, after) = partitionByLoc comments modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - let (after, rest) = partitionAdjacentTrailing modtype.pmty_loc after in - attach t.trailing modtype.pmty_loc after; - let (before, inside, after) = partitionByLoc rest modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModExpr modexpr t inside; - attach t.trailing modexpr.pmod_loc after; - ) - | Pmod_apply (_callModExpr, _argModExpr) -> - let modExprs = modExprApply modExpr in - walkList - ~getLoc:(fun n -> n.Parsetree.pmod_loc) - ~walkNode:walkModExpr - modExprs - t - comments - | Pmod_functor _ -> - let (parameters, returnModExpr) = modExprFunctor modExpr in - let comments = visitListButContinueWithRemainingComments - ~getLoc:(fun - (_, lbl, modTypeOption) -> match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - ) - ~walkNode:walkModExprParameter - ~newlineDelimited:false - parameters - t - comments - in - begin match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) - when modType.pmty_loc.loc_end.pos_cnum <= modExpr.pmod_loc.loc_start.pos_cnum -> - let (before, inside, after) = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - let (after, rest) = partitionAdjacentTrailing modType.pmty_loc after in - attach t.trailing modType.pmty_loc after; - let (before, inside, after) = partitionByLoc rest modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | _ -> - let (before, inside, after) = partitionByLoc comments returnModExpr.pmod_loc in - attach t.leading returnModExpr.pmod_loc before; - walkModExpr returnModExpr t inside; - attach t.trailing returnModExpr.pmod_loc after - end - - and walkModExprParameter parameter t comments = - let (_attrs, lbl, modTypeOption) = parameter in - let (leading, trailing) = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc leading; - begin match modTypeOption with - | None -> attach t.trailing lbl.loc trailing - | Some modType -> - let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let (before, inside, after) = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after; - end - - and walkModType modType t comments = - match modType.pmty_desc with - | Pmty_ident longident | Pmty_alias longident -> - let (leading, trailing) = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing; - | Pmty_signature signature -> - walkSignature signature t comments - | Pmty_extension extension -> - walkExtension extension t comments - | Pmty_typeof modExpr -> - let (before, inside, after) = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after; - | Pmty_with (modType, _withConstraints) -> - let (before, inside, after) = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - (* TODO: withConstraints*) - | Pmty_functor _ -> - let (parameters, returnModType) = functorType modType in - let comments = visitListButContinueWithRemainingComments - ~getLoc:(fun - (_, lbl, modTypeOption) -> match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - if lbl.txt = "_" then modType.Parsetree.pmty_loc - else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - ) - ~walkNode:walkModTypeParameter - ~newlineDelimited:false - parameters - t - comments - in - let (before, inside, after) = partitionByLoc comments returnModType.pmty_loc in - attach t.leading returnModType.pmty_loc before; - walkModType returnModType t inside; - attach t.trailing returnModType.pmty_loc after - - and walkModTypeParameter (_, lbl, modTypeOption) t comments = - let (leading, trailing) = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc leading; - begin match modTypeOption with - | None -> attach t.trailing lbl.loc trailing - | Some modType -> - let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let (before, inside, after) = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after; - end - - and walkPattern pat t comments = - let open Location in - match pat.Parsetree.ppat_desc with - | _ when comments = [] -> () - | Ppat_alias (pat, alias) -> - let (leading, inside, trailing) = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let (afterPat, rest) = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.leading pat.ppat_loc leading; - attach t.trailing pat.ppat_loc afterPat; - let (beforeAlias, afterAlias) = partitionLeadingTrailing rest alias.loc in - attach t.leading alias.loc beforeAlias; - attach t.trailing alias.loc afterAlias - | Ppat_tuple [] - | Ppat_array [] - | Ppat_construct({txt = Longident.Lident "()"}, _) - | Ppat_construct({txt = Longident.Lident "[]"}, _) -> - attach t.inside pat.ppat_loc comments; - | Ppat_array patterns -> - walkList - ~getLoc:(fun n -> n.Parsetree.ppat_loc) - ~walkNode:walkPattern - patterns - t - comments - | Ppat_tuple patterns -> - walkList - ~getLoc:(fun n -> n.Parsetree.ppat_loc) - ~walkNode:walkPattern - patterns - t - comments - | Ppat_construct({txt = Longident.Lident "::"}, _) -> - walkList - ~getLoc:(fun n -> n.Parsetree.ppat_loc) - ~walkNode:walkPattern - (collectListPatterns [] pat) - t - comments - | Ppat_construct (constr, None) -> - let (beforeConstr, afterConstr) = - partitionLeadingTrailing comments constr.loc - in - attach t.leading constr.loc beforeConstr; - attach t.trailing constr.loc afterConstr - | Ppat_construct (constr, Some pat) -> - let (leading, trailing) = partitionLeadingTrailing comments constr.loc in - attach t.leading constr.loc leading; - let (leading, inside, trailing) = partitionByLoc trailing pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - attach t.trailing pat.ppat_loc trailing - | Ppat_variant (_label, None) -> - () - | Ppat_variant (_label, Some pat) -> - walkPattern pat t comments - | Ppat_type _ -> - () - | Ppat_record (recordRows, _) -> - walkList - ~getLoc:(fun ( - (longidentLoc, pattern): (Longident.t Asttypes.loc * Parsetree.pattern) - ) -> { - longidentLoc.loc with - loc_end = pattern.Parsetree.ppat_loc.loc_end - }) - ~walkNode:walkPatternRecordRow - recordRows - t - comments - | Ppat_or (pattern1, pattern2) -> - let (beforePattern1, insidePattern1, afterPattern1) = - partitionByLoc comments pattern1.ppat_loc - in - attach t.leading pattern1.ppat_loc beforePattern1; - walkPattern pattern1 t insidePattern1; - let (afterPattern1, rest) = - partitionAdjacentTrailing pattern1.ppat_loc afterPattern1 - in - attach t.trailing pattern1.ppat_loc afterPattern1; - let (beforePattern2, insidePattern2, afterPattern2) = - partitionByLoc rest pattern2.ppat_loc - in - attach t.leading pattern2.ppat_loc beforePattern2; - walkPattern pattern2 t insidePattern2; - attach t.trailing pattern2.ppat_loc afterPattern2 - | Ppat_constraint (pattern, typ) -> - let (beforePattern, insidePattern, afterPattern) = - partitionByLoc comments pattern.ppat_loc - in - attach t.leading pattern.ppat_loc beforePattern; - walkPattern pattern t insidePattern; - let (afterPattern, rest) = - partitionAdjacentTrailing pattern.ppat_loc afterPattern - in - attach t.trailing pattern.ppat_loc afterPattern; - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc rest typ.ptyp_loc - in - attach t.leading typ.ptyp_loc beforeTyp; - walkTypExpr typ t insideTyp; - attach t.trailing typ.ptyp_loc afterTyp - | Ppat_lazy pattern | Ppat_exception pattern -> - let (leading, inside, trailing) = partitionByLoc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing - | Ppat_unpack stringLoc -> - let (leading, trailing) = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - attach t.trailing stringLoc.loc trailing - | Ppat_extension extension -> - walkExtension extension t comments - | _ -> () - - (* name: firstName *) - and walkPatternRecordRow row t comments = - match row with - (* punned {x}*) - | ({Location.txt=Longident.Lident ident; loc = longidentLoc}, - {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt -> - let (beforeLbl, afterLbl) = - partitionLeadingTrailing comments longidentLoc - in - attach t.leading longidentLoc beforeLbl; - attach t.trailing longidentLoc afterLbl - | (longident, pattern) -> - let (beforeLbl, afterLbl) = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLbl; - let (afterLbl, rest) = partitionAdjacentTrailing longident.loc afterLbl in - attach t.trailing longident.loc afterLbl; - let (leading, inside, trailing) = partitionByLoc rest pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing - - and walkTypExpr typ t comments = - match typ.Parsetree.ptyp_desc with - | _ when comments = [] -> () - | Ptyp_tuple typexprs -> - walkList - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkTypExpr - typexprs - t - comments - | Ptyp_extension extension -> - walkExtension extension t comments - | Ptyp_package packageType -> - walkPackageType packageType t comments - | Ptyp_alias (typexpr, _alias) -> - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp; - | Ptyp_poly (strings, typexpr) -> - let comments = visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Asttypes.loc) - ~walkNode:(fun longident t comments -> - let (beforeLongident, afterLongident) = - partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident - ) - ~newlineDelimited:false - strings - t - comments - in - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | Ptyp_constr (longident, typexprs) -> - let (beforeLongident, _afterLongident) = - partitionLeadingTrailing comments longident.loc in - let (afterLongident, rest) = - partitionAdjacentTrailing longident.loc comments in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident; - walkList - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkTypExpr - typexprs - t - rest - | Ptyp_arrow _ -> - let (_, parameters, typexpr) = arrowType typ in - let comments = walkTypeParameters parameters t comments in - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | Ptyp_object (fields, _) -> - walkTypObjectFields fields t comments - | _ -> () - - and walkTypObjectFields fields t comments = - walkList - ~getLoc:(fun field -> - match field with - | Parsetree.Otag (lbl, _, typ) -> - {lbl.loc with loc_end = typ.ptyp_loc.loc_end} - | _ -> Location.none - ) - ~walkNode:walkTypObjectField - fields - t - comments - - and walkTypObjectField field t comments = - match field with - | Otag (lbl, _, typexpr) -> - let (beforeLbl, afterLbl) = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc beforeLbl; - let (afterLbl, rest) = partitionAdjacentTrailing lbl.loc afterLbl in - attach t.trailing lbl.loc afterLbl; - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | _ -> () - - and walkTypeParameters typeParameters t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, _, typexpr) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParameter - ~newlineDelimited:false - typeParameters - t - comments - - and walkTypeParameter (_attrs, _lbl, typexpr) t comments = - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc comments typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - - and walkPackageType packageType t comments = - let (longident, packageConstraints) = packageType in - let (beforeLongident, afterLongident) = - partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLongident; - let (afterLongident, rest) = - partitionAdjacentTrailing longident.loc afterLongident in - attach t.trailing longident.loc afterLongident; - walkPackageConstraints packageConstraints t rest - - and walkPackageConstraints packageConstraints t comments = - walkList - ~getLoc:(fun (longident, typexpr) -> {longident.Asttypes.loc with - loc_end = typexpr.Parsetree.ptyp_loc.loc_end - }) - ~walkNode:walkPackageConstraint - packageConstraints - t - comments - - and walkPackageConstraint packageConstraint t comments = - let (longident, typexpr) = packageConstraint in - let (beforeLongident, afterLongident) = - partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLongident; - let (afterLongident, rest) = - partitionAdjacentTrailing longident.loc afterLongident in - attach t.trailing longident.loc afterLongident; - let (beforeTyp, insideTyp, afterTyp) = - partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkTypExpr typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp; - - and walkExtension extension t comments = - let (id, payload) = extension in - let (beforeId, afterId) = partitionLeadingTrailing comments id.loc in - attach t.leading id.loc beforeId; - let (afterId, rest) = partitionAdjacentTrailing id.loc afterId in - attach t.trailing id.loc afterId; - walkPayload payload t rest - - and walkAttribute (id, payload) t comments = - let (beforeId, afterId) = partitionLeadingTrailing comments id.loc in - attach t.leading id.loc beforeId; - let (afterId, rest) = partitionAdjacentTrailing id.loc afterId in - attach t.trailing id.loc afterId; - walkPayload payload t rest - - and walkPayload payload t comments = - match payload with - | PStr s -> walkStructure s t comments - | _ -> () - -end - -module Printer = struct - let addParens doc = - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - doc - ] - ); - Doc.softLine; - Doc.rparen; - ] - ) - - let addBraces doc = - Doc.group ( - Doc.concat [ - Doc.lbrace; - doc; - Doc.rbrace; - ] - ) - - let getFirstLeadingComment tbl loc = - match Hashtbl.find tbl.CommentTable.leading loc with - | comment::_ -> Some comment - | [] -> None - | exception Not_found -> None - - let printMultilineCommentContent txt = - (* Turns - * |* first line - * * second line - * * third line *| - * Into - * |* first line - * * second line - * * third line *| - * - * What makes a comment suitable for this kind of indentation? - * -> multiple lines + every line starts with a star - *) - let rec indentStars lines acc = - match lines with - | [] -> Doc.nil - | [lastLine] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if String.length line > 0 then Doc.space else Doc.nil in - List.rev (trailingSpace::doc::acc) |> Doc.concat - | line::lines -> - let line = String.trim line in - let len = String.length line in - if len > 0 && (String.get [@doesNotRaise]) line 0 == '*' then - let doc = Doc.text (" " ^ (String.trim line)) in - indentStars lines (Doc.hardLine::doc::acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && (String.unsafe_get txt (len - 1) = ' ') then - Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [Doc.text content; trailingSpace] - in - let lines = String.split_on_char '\n' txt in - match lines with - | [] -> Doc.text "/* */" - | [line] -> Doc.concat [ - Doc.text "/* "; - Doc.text (Comment.trimSpaces line); - Doc.text " */"; - ] - | first::rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat [ - Doc.text "/*"; - if String.length firstLine > 0 && not (String.equal firstLine "*") then - Doc.space else Doc.nil; - indentStars rest [Doc.hardLine; Doc.text firstLine]; - Doc.text "*/"; - ] - - let printTrailingComment (nodeLoc : Location.t) comment = - let singleLine = Comment.isSingleLineComment comment in - let content = - let txt = Comment.txt comment in - if singleLine then - Doc.text ("// " ^ String.trim txt) - else - printMultilineCommentContent txt - in - let diff = - let cmtStart = (Comment.loc comment).loc_start in - let prevTokEndPos = Comment.prevTokEndPos comment in - cmtStart.pos_lnum - prevTokEndPos.pos_lnum - in - let isBelow = - (Comment.loc comment).loc_start.pos_lnum > nodeLoc.loc_end.pos_lnum in - if diff > 0 || isBelow then - Doc.concat [ - Doc.breakParent; - Doc.lineSuffix( - (Doc.concat [Doc.hardLine; if diff > 1 then Doc.hardLine else Doc.nil; content]) - ) - ] - else if not singleLine then - Doc.concat [Doc.space; content] - else - Doc.lineSuffix (Doc.concat [Doc.space; content]) - - let printLeadingComment ?nextComment comment = - let singleLine = Comment.isSingleLineComment comment in - let content = - let txt = Comment.txt comment in - if singleLine then - Doc.text ("// " ^ String.trim txt) - else - printMultilineCommentContent txt - in - let separator = Doc.concat [ - if singleLine then Doc.concat [ - Doc.hardLine; - Doc.breakParent; - ] else Doc.nil; - (match nextComment with - | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else - if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else if diff == 1 then Doc.hardLine - else - Doc.space - | None -> Doc.nil) - ] - in - Doc.concat [ - content; - separator; - ] - - let printCommentsInside cmtTbl loc = - let rec loop acc comments = - match comments with - | [] -> Doc.nil - | [comment] -> - let cmtDoc = printLeadingComment comment in - let doc = Doc.group ( - Doc.concat [ - Doc.concat (List.rev (cmtDoc::acc)); - ] - ) - in - doc - | comment::((nextComment::_comments) as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc::acc) rest - in - match Hashtbl.find cmtTbl.CommentTable.inside loc with - | exception Not_found -> Doc.nil - | comments -> - Hashtbl.remove cmtTbl.inside loc; - Doc.group ( - loop [] comments - ) - - let printLeadingComments node tbl loc = - let rec loop acc comments = - match comments with - | [] -> node - | [comment] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then - Doc.space - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else - Doc.hardLine - in - let doc = Doc.group ( - Doc.concat [ - Doc.concat (List.rev (cmtDoc::acc)); - separator; - node - ] - ) - in - doc - | comment::((nextComment::_comments) as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc::acc) rest - in - match Hashtbl.find tbl loc with - | exception Not_found -> node - | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments - - let printTrailingComments node tbl loc = - let rec loop acc comments = - match comments with - | [] -> Doc.concat (List.rev acc) - | comment::comments -> - let cmtDoc = printTrailingComment loc comment in - loop (cmtDoc::acc) comments - in - match Hashtbl.find tbl loc with - | exception Not_found -> node - | [] -> node - | (_first::_) as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop [] comments in - Doc.concat [ - node; - cmtsDoc; - ] - - let printComments doc (tbl: CommentTable.t) loc = - let docWithLeadingComments = printLeadingComments doc tbl.leading loc in - printTrailingComments docWithLeadingComments tbl.trailing loc - - let printList ~getLoc ~nodes ~print ?(forceBreak=false) t = - let rec loop (prevLoc: Location.t) acc nodes = - match nodes with - | [] -> (prevLoc, Doc.concat (List.rev acc)) - | node::nodes -> - let loc = getLoc node in - let startPos = match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else - Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc::sep::acc) nodes - in - match nodes with - | [] -> Doc.nil - | node::nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let (lastLoc, docs) = loop firstLoc [doc] nodes in - let forceBreak = - forceBreak || - firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs - - let printListi ~getLoc ~nodes ~print ?(forceBreak=false) t = - let rec loop i (prevLoc: Location.t) acc nodes = - match nodes with - | [] -> (prevLoc, Doc.concat (List.rev acc)) - | node::nodes -> - let loc = getLoc node in - let startPos = match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else - Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc::sep::acc) nodes - in - match nodes with - | [] -> Doc.nil - | node::nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let (lastLoc, docs) = loop 1 firstLoc [doc] nodes in - let forceBreak = - forceBreak || - firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs - - let rec printLongidentAux accu = function - | Longident.Lident s -> (Doc.text s) :: accu - | Ldot(lid, s) -> printLongidentAux ((Doc.text s) :: accu) lid - | Lapply(lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - (Doc.concat [d1; Doc.lparen; d2; Doc.rparen]) :: accu - - let printLongident = function - | Longident.Lident txt -> Doc.text txt - | lid -> Doc.join ~sep:Doc.dot (printLongidentAux [] lid) - - type identifierStyle = - | ExoticIdent - | NormalIdent - - let classifyIdentContent ?(allowUident=false) txt = - let len = String.length txt in - let rec go i = - if i == len then NormalIdent - else - let c = String.unsafe_get txt i in - if i == 0 && not ( - (allowUident && (c >= 'A' && c <= 'Z')) || - (c >= 'a' && c <= 'z') || c = '_' || (c >= '0' && c <= '9')) then - ExoticIdent - else if not ( - (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || c = '\'' - || c = '_' - || (c >= '0' && c <= '9')) - then - ExoticIdent - else - go (i + 1) - in - if Token.isKeywordTxt txt && txt <> "list" then - ExoticIdent - else - go 0 - - let printIdentLike ?allowUident txt = - match classifyIdentContent ?allowUident txt with - | ExoticIdent -> Doc.concat [ - Doc.text "\\\""; - Doc.text txt; - Doc.text"\"" - ] - | NormalIdent -> Doc.text txt - - let printLident l = match l with - | Longident.Lident txt -> printIdentLike txt - | Longident.Ldot (path, txt) -> - let txts = Longident.flatten path in - Doc.concat [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | _ -> Doc.text("printLident: Longident.Lapply is not supported") - - let printLongidentLocation l cmtTbl = - let doc = printLongident l.Location.txt in - printComments doc cmtTbl l.loc - - (* Module.SubModule.x *) - let printLidentPath path cmtTbl = - let doc = printLident path.Location.txt in - printComments doc cmtTbl path.loc - - (* Module.SubModule.x or Module.SubModule.X *) - let printIdentPath path cmtTbl = - let doc = printLident path.Location.txt in - printComments doc cmtTbl path.loc - - let printStringLoc sloc cmtTbl = - let doc = printIdentLike sloc.Location.txt in - printComments doc cmtTbl sloc.loc - - let printConstant c = match c with - | Parsetree.Pconst_integer (s, suffix) -> - begin match suffix with - | Some c -> Doc.text (s ^ (Char.escaped c)) - | None -> Doc.text s - end - | Pconst_string (txt, None) -> - Doc.text ("\"" ^ txt ^ "\"") - | Pconst_string (txt, Some prefix) -> - Doc.concat [ - if prefix = "" then Doc.nil else Doc.text prefix; - Doc.text ("`" ^ txt ^ "`") - ] - | Pconst_float (s, _) -> Doc.text s - | Pconst_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") - - let rec printStructure (s : Parsetree.structure) t = - match s with - | [] -> printCommentsInside t Location.none - | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:printStructureItem - t - - and printStructureItem (si: Parsetree.structure_item) cmtTbl = - match si.pstr_desc with - | Pstr_value(rec_flag, valueBindings) -> - let recFlag = match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~recFlag valueBindings cmtTbl - | Pstr_type(recFlag, typeDeclarations) -> - let recFlag = match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~recFlag typeDeclarations cmtTbl - | Pstr_primitive valueDescription -> - printValueDescription valueDescription cmtTbl - | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ - printAttributes attrs; - exprDoc; - ] - | Pstr_attribute attr -> Doc.concat [ - Doc.text "@"; - printAttributeWithComments attr cmtTbl - ] - | Pstr_extension (extension, attrs) -> Doc.concat [ - printAttributes attrs; - Doc.concat [printExtensionWithComments ~atModuleLvl:true extension cmtTbl]; - ] - | Pstr_include includeDeclaration -> - printIncludeDeclaration includeDeclaration cmtTbl - | Pstr_open openDescription -> - printOpenDescription openDescription cmtTbl - | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration modTypeDecl cmtTbl - | Pstr_module moduleBinding -> - printModuleBinding ~isRec:false moduleBinding cmtTbl 0 - | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~isRec:true) - cmtTbl - | Pstr_exception extensionConstructor -> - printExceptionDef extensionConstructor cmtTbl - | Pstr_typext typeExtension -> - printTypeExtension typeExtension cmtTbl - | Pstr_class _ | Pstr_class_type _ -> Doc.nil - - and printTypeExtension (te : Parsetree.type_extension) cmtTbl = - let prefix = Doc.text "type " in - let name = printLidentPath te.ptyext_path cmtTbl in - let typeParams = printTypeParams te.ptyext_params cmtTbl in - let extensionConstructors = - let ecs = te.ptyext_constructors in - let forceBreak = - match (ecs, List.rev ecs) with - | (first::_, last::_) -> - first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum || - first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum - | _ -> false - in - let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [ - Doc.text "private"; - Doc.line; - ] - | Public -> Doc.nil - in - let rows = - printListi - ~getLoc:(fun n -> n.Parsetree.pext_loc) - ~print:printExtensionConstructor - ~nodes: ecs - ~forceBreak - cmtTbl - in - Doc.breakableGroup ~forceBreak ( - Doc.indent ( - Doc.concat [ - Doc.line; - privateFlag; - rows; - (* Doc.join ~sep:Doc.line ( *) - (* List.mapi printExtensionConstructor ecs *) - (* ) *) - ] - ) - ) - in - Doc.group ( - Doc.concat [ - printAttributes ~loc: te.ptyext_path.loc te.ptyext_attributes; - prefix; - name; - typeParams; - Doc.text " +="; - extensionConstructors; - ] - ) - - and printModuleBinding ~isRec moduleBinding cmtTbl i = - let prefix = if i = 0 then - Doc.concat [ - Doc.text "module "; - if isRec then Doc.text "rec " else Doc.nil; - ] - else - Doc.text "and " - in - let (modExprDoc, modConstraintDoc) = - match moduleBinding.pmb_expr with - | {pmod_desc = Pmod_constraint (modExpr, modType)} -> - ( - printModExpr modExpr cmtTbl, - Doc.concat [ - Doc.text ": "; - printModType modType cmtTbl - ] - ) - | modExpr -> - (printModExpr modExpr cmtTbl, Doc.nil) - in - let modName = - let doc = Doc.text moduleBinding.pmb_name.Location.txt in - printComments doc cmtTbl moduleBinding.pmb_name.loc - in - let doc = Doc.concat [ - printAttributes ~loc:moduleBinding.pmb_name.loc moduleBinding.pmb_attributes; - prefix; - modName; - modConstraintDoc; - Doc.text " = "; - modExprDoc; - ] in - printComments doc cmtTbl moduleBinding.pmb_loc - - and printModuleTypeDeclaration (modTypeDecl : Parsetree.module_type_declaration) cmtTbl = - let modName = - let doc = Doc.text modTypeDecl.pmtd_name.txt in - printComments doc cmtTbl modTypeDecl.pmtd_name.loc - in - Doc.concat [ - printAttributes modTypeDecl.pmtd_attributes; - Doc.text "module type "; - modName; - (match modTypeDecl.pmtd_type with - | None -> Doc.nil - | Some modType -> Doc.concat [ - Doc.text " = "; - printModType modType cmtTbl; - ]); - ] - - and printModType modType cmtTbl = - let modTypeDoc = match modType.pmty_desc with - | Parsetree.Pmty_ident longident -> - Doc.concat [ - printAttributes ~loc:longident.loc modType.pmty_attributes; - printLongidentLocation longident cmtTbl - ] - | Pmty_signature signature -> - let signatureDoc = Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.line; - printSignature signature cmtTbl; - ] - ); - Doc.line; - Doc.rbrace; - ] - ) in - Doc.concat [ - printAttributes modType.pmty_attributes; - signatureDoc - ] - | Pmty_functor _ -> - let (parameters, returnType) = ParsetreeViewer.functorType modType in - let parametersDoc = match parameters with - | [] -> Doc.nil - | [attrs, {Location.txt = "_"; loc}, Some modType] -> - let cmtLoc = - {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - let doc = Doc.concat [ - attrs; - printModType modType cmtTbl - ] in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (attrs, lbl, modType) -> - let cmtLoc = match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.Asttypes.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - let lblDoc = if lbl.Location.txt = "_" then Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = Doc.concat [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> Doc.concat [ - if lbl.txt = "_" then Doc.nil else Doc.text ": "; - printModType modType cmtTbl; - ]); - ] in - printComments doc cmtTbl cmtLoc - ) params - ); - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - let returnDoc = - let doc = printModType returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group ( - Doc.concat [ - parametersDoc; - Doc.group ( - Doc.concat [ - Doc.text " =>"; - Doc.line; - returnDoc; - ] - ) - ] - ) - | Pmty_typeof modExpr -> Doc.concat [ - Doc.text "module type of "; - printModExpr modExpr cmtTbl - ] - | Pmty_extension extension -> printExtensionWithComments ~atModuleLvl:false extension cmtTbl - | Pmty_alias longident -> Doc.concat [ - Doc.text "module "; - printLongidentLocation longident cmtTbl; - ] - | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group ( - Doc.concat [ - operand; - Doc.indent ( - Doc.concat [ - Doc.line; - printWithConstraints withConstraints cmtTbl; - ] - ) - ] - ) - in - let attrsAlreadyPrinted = match modType.pmty_desc with - | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true - | _ -> false - in - let doc =Doc.concat [ - if attrsAlreadyPrinted then Doc.nil else printAttributes modType.pmty_attributes; - modTypeDoc; - ] in - printComments doc cmtTbl modType.pmty_loc - - and printWithConstraints withConstraints cmtTbl = - let rows = List.mapi (fun i withConstraint -> - Doc.group ( - Doc.concat [ - if i == 0 then Doc.text "with " else Doc.text "and "; - printWithConstraint withConstraint cmtTbl; - ] - ) - ) withConstraints - in - Doc.join ~sep:Doc.line rows - - and printWithConstraint (withConstraint : Parsetree.with_constraint) cmtTbl = - match withConstraint with - (* with type X.t = ... *) - | Pwith_type (longident, typeDeclaration) -> - Doc.group (printTypeDeclaration - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" - ~recFlag:Doc.nil - 0 - typeDeclaration - CommentTable.empty) - (* with module X.Y = Z *) - | Pwith_module ({txt = longident1}, {txt = longident2}) -> - Doc.concat [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printLongident longident2; - ] - ) - ] - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group(printTypeDeclaration - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" - ~recFlag:Doc.nil - 0 - typeDeclaration - CommentTable.empty) - | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> - Doc.concat [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent ( - Doc.concat [ - Doc.line; - printLongident longident2; - ] - ) - ] - - and printSignature signature cmtTbl = - match signature with - | [] -> printCommentsInside cmtTbl Location.none - | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:printSignatureItem - cmtTbl - - and printSignatureItem (si : Parsetree.signature_item) cmtTbl = - match si.psig_desc with - | Parsetree.Psig_value valueDescription -> - printValueDescription valueDescription cmtTbl - | Psig_type (recFlag, typeDeclarations) -> - let recFlag = match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~recFlag typeDeclarations cmtTbl - | Psig_typext typeExtension -> - printTypeExtension typeExtension cmtTbl - | Psig_exception extensionConstructor -> - printExceptionDef extensionConstructor cmtTbl - | Psig_module moduleDeclaration -> - printModuleDeclaration moduleDeclaration cmtTbl - | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations moduleDeclarations cmtTbl - | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration modTypeDecl cmtTbl - | Psig_open openDescription -> - printOpenDescription openDescription cmtTbl - | Psig_include includeDescription -> - printIncludeDescription includeDescription cmtTbl - | Psig_attribute attr -> Doc.concat [ - Doc.text "@"; - printAttributeWithComments attr cmtTbl - ] - | Psig_extension (extension, attrs) -> Doc.concat [ - printAttributes attrs; - Doc.concat [printExtensionWithComments ~atModuleLvl:true extension cmtTbl]; - ] - | Psig_class _ | Psig_class_type _ -> Doc.nil - - and printRecModuleDeclarations moduleDeclarations cmtTbl = - printListi - ~getLoc:(fun n -> n.Parsetree.pmd_loc) - ~nodes:moduleDeclarations - ~print:printRecModuleDeclaration - cmtTbl - - and printRecModuleDeclaration md cmtTbl i = - let body = match md.pmd_type.pmty_desc with - | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] - | _ -> - let needsParens = match md.pmd_type.pmty_desc with - | Pmty_with _ -> true - | _ -> false - in - let modTypeDoc = - let doc = printModType md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [Doc.text ": "; modTypeDoc] - in - let prefix = if i < 1 then "module rec " else "and " in - Doc.concat [ - printAttributes ~loc:md.pmd_name.loc md.pmd_attributes; - Doc.text prefix; - printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; - body - ] - - and printModuleDeclaration (md: Parsetree.module_declaration) cmtTbl = - let body = match md.pmd_type.pmty_desc with - | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] - | _ -> Doc.concat [Doc.text ": "; printModType md.pmd_type cmtTbl] - in - Doc.concat [ - printAttributes ~loc:md.pmd_name.loc md.pmd_attributes; - Doc.text "module "; - printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; - body - ] - - and printOpenDescription (openDescription : Parsetree.open_description) p = - Doc.concat [ - printAttributes openDescription.popen_attributes; - Doc.text "open"; - (match openDescription.popen_override with - | Asttypes.Fresh -> Doc.space - | Asttypes.Override -> Doc.text "! "); - printLongidentLocation openDescription.popen_lid p - ] - - and printIncludeDescription (includeDescription: Parsetree.include_description) cmtTbl = - Doc.concat [ - printAttributes includeDescription.pincl_attributes; - Doc.text "include "; - printModType includeDescription.pincl_mod cmtTbl; - ] - - and printIncludeDeclaration (includeDeclaration : Parsetree.include_declaration) cmtTbl = - let isJsFfiImport = List.exists (fun attr -> - match attr with - | ({Location.txt = "ns.jsFfi"}, _) -> true - | _ -> false - ) includeDeclaration.pincl_attributes - in - if isJsFfiImport then - printJsFfiImportDeclaration includeDeclaration cmtTbl - else - Doc.concat [ - printAttributes includeDeclaration.pincl_attributes; - Doc.text "include "; - let includeDoc = - printModExpr includeDeclaration.pincl_mod cmtTbl - in - if Parens.includeModExpr includeDeclaration.pincl_mod then - addParens includeDoc - else includeDoc; - ] - - and printJsFfiImport (valueDescription: Parsetree.value_description) cmtTbl = - let attrs = List.filter (fun attr -> - match attr with - | ({Location.txt = "bs.val" | "genType.import" | "bs.scope" }, _) -> false - | _ -> true - ) valueDescription.pval_attributes in - let (ident, alias) = match valueDescription.pval_prim with - | primitive::_ -> - if primitive <> valueDescription.pval_name.txt then - ( - printIdentLike primitive, - Doc.concat [ - Doc.text " as "; - printIdentLike valueDescription.pval_name.txt; - ] - ) - else - (printIdentLike primitive, Doc.nil) - | _ -> - (printIdentLike valueDescription.pval_name.txt, Doc.nil) - in - Doc.concat [ - printAttributes ~loc:valueDescription.pval_name.loc attrs; - ident; - alias; - Doc.text ": "; - printTypExpr valueDescription.pval_type cmtTbl; - ] - - and printJsFfiImportScope (scope: ParsetreeViewer.jsImportScope) = - match scope with - | JsGlobalImport -> Doc.nil - | JsModuleImport modName -> - Doc.concat [ - Doc.text " from "; - Doc.doubleQuote; - Doc.text modName; - Doc.doubleQuote; - ] - | JsScopedImport idents -> - Doc.concat [ - Doc.text " from "; - Doc.join ~sep:Doc.dot (List.map Doc.text idents) - ] - - and printJsFfiImportDeclaration (includeDeclaration: Parsetree.include_declaration) cmtTbl = - let attrs = List.filter (fun attr -> - match attr with - | ({Location.txt = "ns.jsFfi"}, _) -> false - | _ -> true - ) includeDeclaration.pincl_attributes - in - let imports = ParsetreeViewer.extractValueDescriptionFromModExpr includeDeclaration.pincl_mod in - let scope = match imports with - | vd::_ -> ParsetreeViewer.classifyJsImport vd - | [] -> ParsetreeViewer.JsGlobalImport - in - let scopeDoc = printJsFfiImportScope scope in - Doc.group ( - Doc.concat [ - printAttributes attrs; - Doc.text "import "; - Doc.group ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun vd -> printJsFfiImport vd cmtTbl) imports - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] - ); - scopeDoc; - ] - ) - - and printValueBindings ~recFlag (vbs: Parsetree.value_binding list) cmtTbl = - printListi - ~getLoc:(fun vb -> vb.Parsetree.pvb_loc) - ~nodes:vbs - ~print:(printValueBinding ~recFlag) - cmtTbl - - and printValueDescription valueDescription cmtTbl = - let isExternal = - match valueDescription.pval_prim with | [] -> false | _ -> true - in - Doc.group ( - Doc.concat [ - printAttributes valueDescription.pval_attributes; - Doc.text (if isExternal then "external " else "let "); - printComments - (printIdentLike valueDescription.pval_name.txt) - cmtTbl - valueDescription.pval_name.loc; - Doc.text ": "; - printTypExpr valueDescription.pval_type cmtTbl; - if isExternal then - Doc.group ( - Doc.concat [ - Doc.text " ="; - Doc.indent( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line ( - List.map(fun s -> Doc.concat [ - Doc.text "\""; - Doc.text s; - Doc.text "\""; - ]) - valueDescription.pval_prim - ); - ] - ) - ] - ) - else Doc.nil - ] - ) - - and printTypeDeclarations ~recFlag typeDeclarations cmtTbl = - printListi - ~getLoc:(fun n -> n.Parsetree.ptype_loc) - ~nodes:typeDeclarations - ~print:(printTypeDeclaration2 ~recFlag) - cmtTbl - - (* - * type_declaration = { - * ptype_name: string loc; - * ptype_params: (core_type * variance) list; - * (* ('a1,...'an) t; None represents _*) - * ptype_cstrs: (core_type * core_type * Location.t) list; - * (* ... constraint T1=T1' ... constraint Tn=Tn' *) - * ptype_kind: type_kind; - * ptype_private: private_flag; (* = private ... *) - * ptype_manifest: core_type option; (* = T *) - * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - * ptype_loc: Location.t; - * } - * - * - * type t (abstract, no manifest) - * type t = T0 (abstract, manifest=T0) - * type t = C of T | ... (variant, no manifest) - * type t = T0 = C of T | ... (variant, manifest=T0) - * type t = {l: T; ...} (record, no manifest) - * type t = T0 = {l : T; ...} (record, manifest=T0) - * type t = .. (open, no manifest) - * - * - * and type_kind = - * | Ptype_abstract - * | Ptype_variant of constructor_declaration list - * (* Invariant: non-empty list *) - * | Ptype_record of label_declaration list - * (* Invariant: non-empty list *) - * | Ptype_open - *) - and printTypeDeclaration ~name ~equalSign ~recFlag i (td: Parsetree.type_declaration) cmtTbl = - let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr td.ptype_attributes in - let attrs = printAttributes ~loc:td.ptype_loc attrs in - let prefix = if i > 0 then - Doc.concat [ - Doc.text "and "; - if hasGenType then Doc.text "export " else Doc.nil - ] - else - Doc.concat [ - Doc.text (if hasGenType then "export type " else "type "); - recFlag - ] - in - let typeName = name in - let typeParams = printTypeParams td.ptype_params cmtTbl in - let manifestAndKind = match td.ptype_kind with - | Ptype_abstract -> - begin match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> - Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr typ cmtTbl; - ] - end - | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record(lds) -> - let manifest = match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; - ] - in - Doc.concat [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration lds cmtTbl; - ] - | Ptype_variant(cds) -> - let manifest = match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; - ] - in - Doc.concat [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; - ] - in - let constraints = printTypeDefinitionConstraints td.ptype_cstrs in - Doc.group ( - Doc.concat [ - attrs; - prefix; - typeName; - typeParams; - manifestAndKind; - constraints; - ] - ) - - and printTypeDeclaration2 ~recFlag (td: Parsetree.type_declaration) cmtTbl i = - let name = - let doc = printIdentLike td.Parsetree.ptype_name.txt in - printComments doc cmtTbl td.ptype_name.loc - in - let equalSign = "=" in - let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr td.ptype_attributes in - let attrs = printAttributes ~loc:td.ptype_loc attrs in - let prefix = if i > 0 then - Doc.concat [ - Doc.text "and "; - if hasGenType then Doc.text "export " else Doc.nil - ] - else - Doc.concat [ - Doc.text (if hasGenType then "export type " else "type "); - recFlag - ] - in - let typeName = name in - let typeParams = printTypeParams td.ptype_params cmtTbl in - let manifestAndKind = match td.ptype_kind with - | Ptype_abstract -> - begin match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> - Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr typ cmtTbl; - ] - end - | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record(lds) -> - let manifest = match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; - ] - in - Doc.concat [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration lds cmtTbl; - ] - | Ptype_variant(cds) -> - let manifest = match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ cmtTbl; - ] - in - Doc.concat [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~privateFlag:td.ptype_private cds cmtTbl; - ] - in - let constraints = printTypeDefinitionConstraints td.ptype_cstrs in - Doc.group ( - Doc.concat [ - attrs; - prefix; - typeName; - typeParams; - manifestAndKind; - constraints; - ] - ) - - and printTypeDefinitionConstraints cstrs = - match cstrs with - | [] -> Doc.nil - | cstrs -> Doc.indent ( - Doc.group ( - Doc.concat [ - Doc.line; - Doc.group( - Doc.join ~sep:Doc.line ( - List.map printTypeDefinitionConstraint cstrs - ) - ) - ] - ) - ) - - and printTypeDefinitionConstraint ((typ1, typ2, _loc ): Parsetree.core_type * Parsetree.core_type * Location.t) = - Doc.concat [ - Doc.text "constraint "; - printTypExpr typ1 CommentTable.empty; - Doc.text " = "; - printTypExpr typ2 CommentTable.empty; - ] - - and printPrivateFlag (flag : Asttypes.private_flag) = match flag with - | Private -> Doc.text "private " - | Public -> Doc.nil - - and printTypeParams typeParams cmtTbl = - match typeParams with - | [] -> Doc.nil - | typeParams -> - Doc.group ( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun typeParam -> - let doc = printTypeParam typeParam cmtTbl in - printComments doc cmtTbl (fst typeParam).Parsetree.ptyp_loc - ) typeParams - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - ) - - and printTypeParam (param : (Parsetree.core_type * Asttypes.variance)) cmtTbl = - let (typ, variance) = param in - let printedVariance = match variance with - | Covariant -> Doc.text "+" - | Contravariant -> Doc.text "-" - | Invariant -> Doc.nil - in - Doc.concat [ - printedVariance; - printTypExpr typ cmtTbl - ] - - and printRecordDeclaration (lds: Parsetree.label_declaration list) cmtTbl = - let forceBreak = match (lds, List.rev lds) with - | (first::_, last::_) -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun ld -> - let doc = printLabelDeclaration ld cmtTbl in - printComments doc cmtTbl ld.Parsetree.pld_loc - ) lds) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] - ) - - and printConstructorDeclarations - ~privateFlag (cds: Parsetree.constructor_declaration list) cmtTbl - = - let forceBreak = match (cds, List.rev cds) with - | (first::_, last::_) -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum - | _ -> false - in - let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [ - Doc.text "private"; - Doc.line; - ] - | Public -> Doc.nil - in - let rows = - printListi - ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) - ~nodes:cds - ~print:(fun cd cmtTbl i -> - let doc = printConstructorDeclaration2 i cd cmtTbl in - printComments doc cmtTbl cd.Parsetree.pcd_loc - ) - ~forceBreak - cmtTbl - in - Doc.breakableGroup ~forceBreak ( - Doc.indent ( - Doc.concat [ - Doc.line; - privateFlag; - rows; - ] - ) - ) - - and printConstructorDeclaration2 i (cd : Parsetree.constructor_declaration) cmtTbl = - let attrs = printAttributes cd.pcd_attributes in - let bar = if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil - in - let constrName = - let doc = Doc.text cd.pcd_name.txt in - printComments doc cmtTbl cd.pcd_name.loc - in - let constrArgs = printConstructorArguments ~indent:true cd.pcd_args cmtTbl in - let gadt = match cd.pcd_res with - | None -> Doc.nil - | Some(typ) -> Doc.indent ( - Doc.concat [ - Doc.text ": "; - printTypExpr typ cmtTbl; - ] - ) - in - Doc.concat [ - bar; - Doc.group ( - Doc.concat [ - attrs; (* TODO: fix parsing of attributes, so when can print them above the bar? *) - constrName; - constrArgs; - gadt; - ] - ) - ] - - and printConstructorArguments ~indent (cdArgs : Parsetree.constructor_arguments) cmtTbl = - match cdArgs with - | Pcstr_tuple [] -> Doc.nil - | Pcstr_tuple types -> - let args = Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun typexpr -> - printTypExpr typexpr cmtTbl - ) types - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] in - Doc.group ( - if indent then Doc.indent args else args - ) - | Pcstr_record lds -> - let args = Doc.concat [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun ld -> - let doc = printLabelDeclaration ld cmtTbl in - printComments doc cmtTbl ld.Parsetree.pld_loc - ) lds) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] in - if indent then Doc.indent args else args - - and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = - let attrs = printAttributes ~loc:ld.pld_name.loc ld.pld_attributes in - let mutableFlag = match ld.pld_mutable with - | Mutable -> Doc.text "mutable " - | Immutable -> Doc.nil - in - let name = - let doc = printIdentLike ld.pld_name.txt in - printComments doc cmtTbl ld.pld_name.loc - in - Doc.group ( - Doc.concat [ - attrs; - mutableFlag; - name; - Doc.text ": "; - printTypExpr ld.pld_type cmtTbl; - ] - ) - - and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = - let renderedType = match typExpr.ptyp_desc with - | Ptyp_any -> Doc.text "_" - | Ptyp_var var -> Doc.concat [ - Doc.text "'"; - printIdentLike var; - ] - | Ptyp_extension(extension) -> - printExtensionWithComments ~atModuleLvl:false extension cmtTbl - | Ptyp_alias(typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = match typ.ptyp_desc with - | Ptyp_arrow _ -> true - | _ -> false - in - let doc = printTypExpr typ cmtTbl in - if needsParens then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else - doc - in - Doc.concat [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] - | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, [{ptyp_desc = Ptyp_object (_fields, _openFlag)} as typ]) -> - let bsObject = printTypExpr typ cmtTbl in - begin match typExpr.ptyp_attributes with - | [] -> bsObject - | attrs -> - Doc.concat [ - Doc.group ( - Doc.join ~sep:Doc.line (List.map printAttribute attrs) - ); - Doc.space; - printTypExpr typ cmtTbl; - ] - end - | Ptyp_constr(longidentLoc, [{ ptyp_desc = Parsetree.Ptyp_tuple tuple }]) -> - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.group( - Doc.concat([ - constrName; - Doc.lessThan; - printTupleType ~inline:true tuple cmtTbl; - Doc.greaterThan; - ]) - ) - | Ptyp_constr(longidentLoc, constrArgs) -> - let constrName = printLidentPath longidentLoc cmtTbl in - begin match constrArgs with - | [] -> constrName - | [{ - Parsetree.ptyp_desc = - Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, - [{ptyp_desc = Ptyp_object (fields, openFlag)}]) - }] -> - Doc.concat([ - constrName; - Doc.lessThan; - printBsObjectSugar ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ]) - | _args -> Doc.group( - Doc.concat([ - constrName; - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map - (fun typexpr -> printTypExpr typexpr cmtTbl) - constrArgs - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) - ) - end - | Ptyp_arrow _ -> - let (attrsBefore, args, returnType) = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr returnType cmtTbl in - if returnTypeNeedsParens then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let (isUncurried, attrs) = - ParsetreeViewer.processUncurriedAttribute attrsBefore - in - begin match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = if hasAttrsBefore then - Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrsBefore); - Doc.space; - ] - else Doc.nil - in - let typDoc = - let doc = printTypExpr n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ -> addParens doc - | _ -> doc - in - Doc.group ( - Doc.concat [ - Doc.group attrs; - Doc.group ( - if hasAttrsBefore then - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - typDoc; - Doc.text " => "; - returnDoc; - ] - ); - Doc.softLine; - Doc.rparen - ] - else - Doc.concat [ - typDoc; - Doc.text " => "; - returnDoc; - ] - ) - ] - ) - | args -> - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.space; - ] - in - let renderedArgs = Doc.concat [ - attrs; - Doc.text "("; - Doc.indent ( - Doc.concat [ - Doc.softLine; - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun tp -> printTypeParameter tp cmtTbl) args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] in - Doc.group ( - Doc.concat [ - renderedArgs; - Doc.text " => "; - returnDoc; - ] - ) - end - | Ptyp_tuple types -> printTupleType ~inline:false types cmtTbl - | Ptyp_object (fields, openFlag) -> - printBsObjectSugar ~inline:false fields openFlag cmtTbl - | Ptyp_poly([], typ) -> - printTypExpr typ cmtTbl - | Ptyp_poly(stringLocs, typ) -> - Doc.concat [ - Doc.join ~sep:Doc.space (List.map (fun {Location.txt; loc} -> - let doc = Doc.concat [Doc.text "'"; Doc.text txt] in - printComments doc cmtTbl loc - ) stringLocs); - Doc.dot; - Doc.space; - printTypExpr typ cmtTbl - ] - | Ptyp_package packageType -> - printPackageType ~printModuleKeywordAndParens:true packageType cmtTbl - | Ptyp_class _ -> - Doc.text "classes are not supported in types" - | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let printRowField = function - | Parsetree.Rtag ({txt}, attrs, true, []) -> - Doc.concat [ - printAttributes attrs; - Doc.concat [Doc.text "#"; printIdentLike ~allowUident:true txt] - ] - | Rtag ({txt}, attrs, truth, types) -> - let doType t = match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr t cmtTbl - | _ -> Doc.concat [ Doc.lparen; printTypExpr t cmtTbl; Doc.rparen ] - in - let printedTypes = List.map doType types in - let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes in - let cases = if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases in - Doc.group (Doc.concat [ - printAttributes attrs; - Doc.concat [Doc.text "#"; printIdentLike ~allowUident:true txt]; - cases - ]) - | Rinherit coreType -> - printTypExpr coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in - let cases = if docs = [] then cases else Doc.concat [Doc.text "| "; cases] in - let openingSymbol = - if closedFlag = Open - then Doc.greaterThan - else if labelsOpt = None - then Doc.nil - else Doc.lessThan in - let hasLabels = labelsOpt <> None && labelsOpt <> Some [] in - let labels = match labelsOpt with - | None - | Some([]) -> - Doc.nil - | Some(labels) -> - Doc.concat (List.map (fun label -> Doc.concat [Doc.line; Doc.text "#" ; printIdentLike ~allowUident:true label] ) labels) - in - let closingSymbol = if hasLabels then Doc.text " >" else Doc.nil in - Doc.group (Doc.concat [Doc.lbracket; openingSymbol; Doc.line; cases; closingSymbol; labels; Doc.line; Doc.rbracket]) - in - let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with - | Ptyp_arrow _ (* es6 arrow types print their own attributes *) - | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, _) -> true - | _ -> false - in - let doc = begin match typExpr.ptyp_attributes with - | _::_ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - renderedType; - ] - ) - | _ -> renderedType - end - in - printComments doc cmtTbl typExpr.ptyp_loc - - and printBsObjectSugar ~inline fields openFlag cmtTbl = - let doc = match fields with - | [] -> Doc.concat [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace - ] - | fields -> - Doc.concat [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> Doc.dotdot); - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun field -> printObjectField field cmtTbl) fields - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] - in - if inline then doc else Doc.group doc - - and printTupleType ~inline (types: Parsetree.core_type list) cmtTbl = - let tuple = Doc.concat([ - Doc.lparen; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun typexpr -> printTypExpr typexpr cmtTbl) types - ) - ]) - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - if inline == false then Doc.group(tuple) else tuple - - and printObjectField (field : Parsetree.object_field) cmtTbl = - match field with - | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = Doc.concat [ - printAttributes ~loc:labelLoc.loc attrs; - lbl; - Doc.text ": "; - printTypExpr typ cmtTbl; - ] in - let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in - printComments doc cmtTbl cmtLoc - | _ -> Doc.nil - - (* es6 arrow type arg - * type t = (~foo: string, ~bar: float=?, unit) => unit - * i.e. ~foo: string, ~bar: float *) - and printTypeParameter (attrs, lbl, typ) cmtTbl = - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - let label = match lbl with - | Asttypes.Nolabel -> Doc.nil - | Labelled lbl -> Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - ] - | Optional lbl -> Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - ] - in - let optionalIndicator = match lbl with - | Asttypes.Nolabel - | Labelled _ -> Doc.nil - | Optional _lbl -> Doc.text "=?" - in - let doc = Doc.group ( - Doc.concat [ - uncurried; - attrs; - label; - printTypExpr typ cmtTbl; - optionalIndicator; - ] - ) in - printComments doc cmtTbl typ.ptyp_loc - - and printValueBinding ~recFlag vb cmtTbl i = - let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr vb.pvb_attributes in - let attrs = printAttributes ~loc:vb.pvb_pat.ppat_loc attrs in - let header = - if i == 0 then - Doc.concat [ - if hasGenType then Doc.text "export " else Doc.text "let "; - recFlag - ] else - Doc.concat [ - Doc.text "and "; - if hasGenType then Doc.text "export " else Doc.nil - ] - in - match vb with - | {pvb_pat = - {ppat_desc = Ppat_constraint (pattern, {ptyp_desc = Ptyp_poly _})}; - pvb_expr = - {pexp_desc = Pexp_newtype _} as expr - } -> - let (_attrs, parameters, returnExpr) = ParsetreeViewer.funExpr expr in - let abstractType = match parameters with - | [NewTypes {locs = vars}] -> - Doc.concat [ - Doc.text "type "; - Doc.join ~sep:Doc.space (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - begin match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - Doc.group ( - Doc.concat [ - attrs; - header; - printPattern pattern cmtTbl; - Doc.text ":"; - Doc.indent ( - Doc.concat [ - Doc.line; - abstractType; - Doc.space; - printTypExpr typ cmtTbl; - Doc.text " ="; - Doc.concat [ - Doc.line; - printExpressionWithComments expr cmtTbl; - ] - ] - ) - ] - ) - | _ -> Doc.nil - end - | _ -> - let (optBraces, expr) = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = printExpressionWithComments vb.pvb_expr cmtTbl in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - if ParsetreeViewer.isPipeExpr vb.pvb_expr then - Doc.customLayout [ - Doc.group ( - Doc.concat [ - attrs; - header; - printPattern vb.pvb_pat cmtTbl; - Doc.text " ="; - Doc.space; - printedExpr; - ] - ); - Doc.group ( - Doc.concat [ - attrs; - header; - printPattern vb.pvb_pat cmtTbl; - Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printedExpr; - ] - ) - ] - ); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> - ParsetreeViewer.isBinaryExpression expr || - (match vb.pvb_expr with - | { - pexp_attributes = [({Location.txt="res.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _) - } -> - ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes || - ParsetreeViewer.isArrayAccess e - ) - in - Doc.group ( - Doc.concat [ - attrs; - header; - printPattern vb.pvb_pat cmtTbl; - Doc.text " ="; - if shouldIndent then - Doc.indent ( - Doc.concat [ - Doc.line; - printedExpr; - ] - ) - else - Doc.concat [ - Doc.space; - printedExpr; - ] - ] - ) - - and printPackageType ~printModuleKeywordAndParens (packageType: Parsetree.package_type) cmtTbl = - let doc = match packageType with - | (longidentLoc, []) -> Doc.group( - Doc.concat [ - printLongidentLocation longidentLoc cmtTbl; - ] - ) - | (longidentLoc, packageConstraints) -> Doc.group( - Doc.concat [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints packageConstraints cmtTbl; - Doc.softLine; - ] - ) - in - if printModuleKeywordAndParens then - Doc.concat[ - Doc.text "module("; - doc; - Doc.rparen - ] - else - doc - - and printPackageConstraints packageConstraints cmtTbl = - Doc.concat [ - Doc.text " with"; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line ( - List.mapi (fun i pc -> - let (longident, typexpr) = pc in - let cmtLoc = {longident.Asttypes.loc with - loc_end = typexpr.Parsetree.ptyp_loc.loc_end - } in - let doc = printPackageConstraint i cmtTbl pc in - printComments doc cmtTbl cmtLoc - ) packageConstraints - ) - ] - ) - ] - - and printPackageConstraint i cmtTbl (longidentLoc, typ) = - let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in - Doc.concat [ - prefix; - printLongidentLocation longidentLoc cmtTbl; - Doc.text " = "; - printTypExpr typ cmtTbl; - ] - - and printExtensionWithComments ~atModuleLvl (stringLoc, payload) cmtTbl = - let extName = - let doc = Doc.concat [ - Doc.text "%"; - if atModuleLvl then Doc.text "%" else Doc.nil; - Doc.text stringLoc.Location.txt; - ] in - printComments doc cmtTbl stringLoc.Location.loc - in - match payload with - | Parsetree.PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments expr cmtTbl in - let needsParens = match attrs with | [] -> false | _ -> true in - Doc.group ( - Doc.concat [ - extName; - addParens ( - Doc.concat [ - printAttributes attrs; - if needsParens then addParens exprDoc else exprDoc; - ] - ) - ] - ) - | _ -> extName - - and printPattern (p : Parsetree.pattern) cmtTbl = - let patternWithoutAttributes = match p.ppat_desc with - | Ppat_any -> Doc.text "_" - | Ppat_var var -> printIdentLike var.txt - | Ppat_constant c -> printConstant c - | Ppat_tuple patterns -> - Doc.group( - Doc.concat([ - Doc.lparen; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun pat -> - printPattern pat cmtTbl) patterns) - ]) - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen - ]) - ) - | Ppat_array [] -> - Doc.concat [ - Doc.lbracket; - printCommentsInside cmtTbl p.ppat_loc; - Doc.rbracket; - ] - | Ppat_array patterns -> - Doc.group( - Doc.concat([ - Doc.text "["; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun pat -> - printPattern pat cmtTbl) patterns) - ]) - ); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - ) - | Ppat_construct({txt = Longident.Lident "()"}, _) -> - Doc.concat [ - Doc.lparen; - printCommentsInside cmtTbl p.ppat_loc; - Doc.rparen; - ] - | Ppat_construct({txt = Longident.Lident "[]"}, _) -> - Doc.concat [ - Doc.text "list["; - printCommentsInside cmtTbl p.ppat_loc; - Doc.rbracket; - ] - | Ppat_construct({txt = Longident.Lident "::"}, _) -> - let (patterns, tail) = ParsetreeViewer.collectPatternsFromListConstruct [] p in - let shouldHug = match (patterns, tail) with - | ([pat], - {ppat_desc = Ppat_construct({txt = Longident.Lident "[]"}, _)}) when ParsetreeViewer.isHuggablePattern pat -> true - | _ -> false - in - let children = Doc.concat([ - if shouldHug then Doc.nil else Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun pat -> - printPattern pat cmtTbl) patterns); - begin match tail.Parsetree.ppat_desc with - | Ppat_construct({txt = Longident.Lident "[]"}, _) -> Doc.nil - | _ -> - let doc = Doc.concat [Doc.text "..."; printPattern tail cmtTbl] in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat([Doc.text ","; Doc.line; tail]) - end; - ]) in - Doc.group( - Doc.concat([ - Doc.text "list["; - if shouldHug then children else Doc.concat [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - ]; - Doc.rbracket; - ]) - ) - | Ppat_construct(constrName, constructorArgs) -> - let constrName = printLongident constrName.txt in - let argsDoc = match constructorArgs with - | None -> Doc.nil - | Some({ppat_loc; ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) -> - Doc.concat [ - Doc.lparen; - printCommentsInside cmtTbl ppat_loc; - Doc.rparen; - ] - | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) -> - Doc.concat [ - Doc.lparen; - Doc.softLine; - printCommentsInside cmtTbl loc; - Doc.rparen; - ] - (* Some((1, 2) *) - | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) -> - Doc.concat [ - Doc.lparen; - printPattern arg cmtTbl; - Doc.rparen; - ] - | Some({ppat_desc = Ppat_tuple patterns}) -> - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun pat -> printPattern pat cmtTbl) patterns - ); - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some(arg) -> - let argDoc = printPattern arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat [ - Doc.lparen; - if shouldHug then argDoc - else Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - argDoc; - ] - ); - Doc.trailingComma; - Doc.softLine; - ]; - Doc.rparen; - - ] - in - Doc.group(Doc.concat [constrName; argsDoc]) - | Ppat_variant (label, None) -> - Doc.concat [Doc.text "#"; printIdentLike ~allowUident:true label] - | Ppat_variant (label, variantArgs) -> - let variantName = - Doc.concat [Doc.text "#"; printIdentLike ~allowUident:true label] in - let argsDoc = match variantArgs with - | None -> Doc.nil - | Some({ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}) -> - Doc.text "()" - | Some({ppat_desc = Ppat_tuple []; ppat_loc = loc}) -> - Doc.concat [ - Doc.lparen; - Doc.softLine; - printCommentsInside cmtTbl loc; - Doc.rparen; - ] - (* Some((1, 2) *) - | Some({ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as arg]}) -> - Doc.concat [ - Doc.lparen; - printPattern arg cmtTbl; - Doc.rparen; - ] - | Some({ppat_desc = Ppat_tuple patterns}) -> - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun pat -> printPattern pat cmtTbl) patterns - ); - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some(arg) -> - let argDoc = printPattern arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat [ - Doc.lparen; - if shouldHug then argDoc - else Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - argDoc; - ] - ); - Doc.trailingComma; - Doc.softLine; - ]; - Doc.rparen; - - ] - in - Doc.group(Doc.concat [variantName; argsDoc]) - | Ppat_type ident -> - Doc.concat [Doc.text "##"; printIdentPath ident cmtTbl] - | Ppat_record(rows, openFlag) -> - Doc.group( - Doc.concat([ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun row -> printPatternRecordRow row cmtTbl) rows); - begin match openFlag with - | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] - | Closed -> Doc.nil - end; - ] - ); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) - ) - - | Ppat_exception p -> - let needsParens = match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern p cmtTbl in - if needsParens then - Doc.concat [Doc.text "("; p; Doc.text ")"] - else - p - in - Doc.group ( - Doc.concat [Doc.text "exception"; Doc.line; pat] - ) - | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = List.mapi (fun i pat -> - let patternDoc = printPattern pat cmtTbl in - Doc.concat [ - if i == 0 then Doc.nil else Doc.concat [Doc.line; Doc.text "| "]; - match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc - ] - ) orChain in - Doc.group (Doc.concat docs) - | Ppat_extension ext -> - printExtensionWithComments ~atModuleLvl:false ext cmtTbl - | Ppat_lazy p -> - let needsParens = match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern p cmtTbl in - if needsParens then - Doc.concat [Doc.text "("; p; Doc.text ")"] - else - p - in - Doc.concat [Doc.text "lazy "; pat] - | Ppat_alias (p, aliasLoc) -> - let needsParens = match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern p cmtTbl in - if needsParens then - Doc.concat [Doc.text "("; p; Doc.text ")"] - else - p - in - Doc.concat([ - renderedPattern; - Doc.text " as "; - printStringLoc aliasLoc cmtTbl; - ]) - - (* Note: module(P : S) is represented as *) - (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) - | Ppat_constraint ({ppat_desc = Ppat_unpack stringLoc}, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> - Doc.concat [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl - ptyp_loc; - Doc.rparen; - ] - | Ppat_constraint (pattern, typ) -> - Doc.concat [ - printPattern pattern cmtTbl; - Doc.text ": "; - printTypExpr typ cmtTbl; - ] - - (* Note: module(P : S) is represented as *) - (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) - | Ppat_unpack stringLoc -> - Doc.concat [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] - | Ppat_interval (a, b) -> - Doc.concat [ - printConstant a; - Doc.text " .. "; - printConstant b; - ] - | Ppat_open _ -> Doc.nil - in - let doc = match p.ppat_attributes with - | [] -> patternWithoutAttributes - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - patternWithoutAttributes; - ] - ) - in - printComments doc cmtTbl p.ppat_loc - - and printPatternRecordRow row cmtTbl = - match row with - (* punned {x}*) - | ({Location.txt=Longident.Lident ident} as longident, - {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt -> - printLidentPath longident cmtTbl - | (longident, pattern) -> - let locForComments = { - longident.loc with - loc_end = pattern.Parsetree.ppat_loc.loc_end - } in - let doc = Doc.group ( - Doc.concat([ - printLidentPath longident cmtTbl; - Doc.text ": "; - Doc.indent( - Doc.concat [ - Doc.softLine; - printPattern pattern cmtTbl; - ] - ) - ]) - ) in - printComments doc cmtTbl locForComments - - and printExpressionWithComments expr cmtTbl = - let doc = printExpression expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc - - and printExpression (e : Parsetree.expression) cmtTbl = - let printedExpression = match e.pexp_desc with - | Parsetree.Pexp_constant c -> printConstant c - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment e cmtTbl - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat [ - Doc.text "list["; - printCommentsInside cmtTbl e.pexp_loc; - Doc.rbracket; - ] - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let (expressions, spread) = ParsetreeViewer.collectListExpressions e in - let spreadDoc = match spread with - | Some(expr) -> Doc.concat [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - ] - | None -> Doc.nil - in - Doc.group( - Doc.concat([ - Doc.text "list["; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - ) - expressions); - spreadDoc; - ]) - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - ) - | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = match args with - | None -> Doc.nil - | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) -> - Doc.text "()" - (* Some((1, 2)) *) - | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) -> - Doc.concat [ - Doc.lparen; - (let doc = printExpressionWithComments arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some({pexp_desc = Pexp_tuple args }) -> - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map - (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some(arg) -> - let argDoc = - let doc = printExpressionWithComments arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat [ - Doc.lparen; - if shouldHug then argDoc - else Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - argDoc; - ] - ); - Doc.trailingComma; - Doc.softLine; - ]; - Doc.rparen; - ] - in - Doc.group(Doc.concat [constr; args]) - | Pexp_ident path -> - printLidentPath path cmtTbl - | Pexp_tuple exprs -> - Doc.group( - Doc.concat([ - Doc.lparen; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs) - ]) - ); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) - ) - | Pexp_array [] -> - Doc.concat [ - Doc.lbracket; - printCommentsInside cmtTbl e.pexp_loc; - Doc.rbracket; - ] - | Pexp_array exprs -> - Doc.group( - Doc.concat([ - Doc.lbracket; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - ) exprs) - ]) - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - ) - | Pexp_variant (label, args) -> - let variantName = - Doc.concat [Doc.text "#"; printIdentLike ~allowUident:true label] in - let args = match args with - | None -> Doc.nil - | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) -> - Doc.text "()" - (* #poly((1, 2) *) - | Some({pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _} as arg]}) -> - Doc.concat [ - Doc.lparen; - (let doc = printExpressionWithComments arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some({pexp_desc = Pexp_tuple args }) -> - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map - (fun expr -> - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some(arg) -> - let argDoc = - let doc = printExpressionWithComments arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat [ - Doc.lparen; - if shouldHug then argDoc - else Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - argDoc; - ] - ); - Doc.trailingComma; - Doc.softLine; - ]; - Doc.rparen; - ] - in - Doc.group(Doc.concat [variantName; args]) - | Pexp_record (rows, spreadExpr) -> - let spread = match spreadExpr with - | None -> Doc.nil - | Some expr -> Doc.concat [ - Doc.dotdotdot; - (let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak ( - Doc.concat([ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - spread; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun row -> printRecordRow row cmtTbl) rows) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - ) - | Pexp_extension extension -> - begin match extension with - | ( - {txt = "bs.obj"}, - PStr [{ - pstr_loc = loc; - pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, []) - }] - ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = - loc.loc_start.pos_lnum < loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak ( - Doc.concat([ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun row -> printBsObjectRow row cmtTbl) rows) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - ) - | extension -> - printExtensionWithComments ~atModuleLvl:false extension cmtTbl - end - | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral e cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression e cmtTbl - else - printPexpApply e cmtTbl - | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ - lhs; - Doc.dot; - printLidentPath longidentLoc cmtTbl; - ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr e.pexp_attributes expr1 longidentLoc expr2 e.pexp_loc cmtTbl - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - if ParsetreeViewer.isTernaryExpr e then - let (parts, alternate) = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = match parts with - | (condition1, consequent1)::rest -> - Doc.group (Doc.concat [ - printTernaryOperand condition1 cmtTbl; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.indent ( - Doc.concat [ - Doc.text "? "; - printTernaryOperand consequent1 cmtTbl - ] - ); - Doc.concat ( - List.map (fun (condition, consequent) -> - Doc.concat [ - Doc.line; - Doc.text ": "; - printTernaryOperand condition cmtTbl; - Doc.line; - Doc.text "? "; - printTernaryOperand consequent cmtTbl; - ] - ) rest - ); - Doc.line; - Doc.text ": "; - Doc.indent (printTernaryOperand alternate cmtTbl); - ] - ) - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false | _ -> true - in - Doc.concat [ - printAttributes attrs; - if needsParens then addParens ternaryDoc else ternaryDoc; - ] - else - let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in - let ifDocs = Doc.join ~sep:Doc.space ( - List.mapi (fun i (ifExpr, thenExpr) -> - let ifTxt = if i > 0 then Doc.text "else if " else Doc.text "if " in - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~braces:true ifExpr cmtTbl - else - let doc = printExpressionWithComments ifExpr cmtTbl in - match Parens.expr ifExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat [ - ifTxt; - Doc.group (condition); - Doc.space; - let thenExpr = match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | (Some _, expr) -> expr - | _ -> thenExpr - in - printExpressionBlock ~braces:true thenExpr cmtTbl; - ] - ) ifs - ) in - let elseDoc = match elseExpr with - | None -> Doc.nil - | Some expr -> Doc.concat [ - Doc.text " else "; - printExpressionBlock ~braces:true expr cmtTbl; - ] - in - Doc.concat [ - printAttributes e.pexp_attributes; - ifDocs; - elseDoc; - ] - | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "while "; - if ParsetreeViewer.isBlockExpr expr1 then - condition - else - Doc.group ( - Doc.ifBreaks (addParens condition) condition - ); - Doc.space; - printExpressionBlock ~braces:true expr2 cmtTbl; - ] - ) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "for "; - printPattern pattern cmtTbl; - Doc.text " in "; - (let doc = printExpressionWithComments fromExpr cmtTbl in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = printExpressionWithComments toExpr cmtTbl in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~braces:true body cmtTbl; - ] - ) - | Pexp_constraint( - {pexp_desc = Pexp_pack modExpr}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} - ) -> - Doc.group ( - Doc.concat [ - Doc.text "module("; - Doc.indent ( - Doc.concat [ - Doc.softLine; - printModExpr modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl - ptyp_loc - ] - ); - Doc.softLine; - Doc.rparen; - ] - ) - - | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ - exprDoc; - Doc.text ": "; - printTypExpr typ cmtTbl; - ] - | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~braces:true e cmtTbl - | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~braces:true e cmtTbl - | Pexp_assert expr -> - let rhs = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.lazyOrAssertExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ - Doc.text "assert "; - rhs; - ] - | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.lazyOrAssertExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group ( - Doc.concat [ - Doc.text "lazy "; - rhs; - ] - ) - | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~braces:true e cmtTbl - | Pexp_pack (modExpr) -> - Doc.group (Doc.concat [ - Doc.text "module("; - Doc.indent ( - Doc.concat [ - Doc.softLine; - printModExpr modExpr cmtTbl; - ] - ); - Doc.softLine; - Doc.rparen; - ]) - | Pexp_sequence _ -> - printExpressionBlock ~braces:true e cmtTbl - | Pexp_let _ -> - printExpressionBlock ~braces:true e cmtTbl - | Pexp_fun (Nolabel, None, {ppat_desc = Ppat_var {txt="__x"}}, ({pexp_desc = Pexp_apply _})) -> - - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments (ParsetreeViewer.rewriteUnderscoreApply e) cmtTbl - | Pexp_fun _ | Pexp_newtype _ -> - let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in - let (uncurried, attrs) = - ParsetreeViewer.processUncurriedAttribute attrsOnArrow - in - let (returnExpr, typConstraint) = match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> ( - {expr with pexp_attributes = List.concat [ - expr.pexp_attributes; - returnExpr.pexp_attributes; - ]}, - Some typ - ) - | _ -> (returnExpr, None) - in - let hasConstraint = match typConstraint with | Some _ -> true | None -> false in - let parametersDoc = printExprFunParameters - ~inCallback:false - ~uncurried - ~hasConstraint - parameters - cmtTbl - in - let returnExprDoc = - let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = match (returnExpr.pexp_desc, optBraces) with - | (_, Some _ ) -> true - | ((Pexp_array _ - | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _), _) -> true - | _ -> false - in - let shouldIndent = match returnExpr.pexp_desc with - | Pexp_sequence _ - | Pexp_let _ - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_open _ -> false - | _ -> true - in - let returnDoc = - let doc = printExpressionWithComments returnExpr cmtTbl in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces - | Nothing -> doc - in - if shouldInline then Doc.concat [ - Doc.space; - returnDoc; - ] else - Doc.group ( - if shouldIndent then - Doc.indent ( - Doc.concat [ - Doc.line; - returnDoc; - ] - ) - else - Doc.concat [ - Doc.space; - returnDoc - ] - ) - in - let typConstraintDoc = match typConstraint with - | Some(typ) -> Doc.concat [Doc.text ": "; printTypExpr typ cmtTbl] - | _ -> Doc.nil - in - let attrs = printAttributes attrs in - Doc.group ( - Doc.concat [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ] - ) - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases cases cmtTbl; - ] - | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [ - Doc.text "switch "; - exprDoc; - Doc.space; - printCases cases cmtTbl; - ] - | Pexp_function cases -> - Doc.concat [ - Doc.text "x => switch x "; - printCases cases cmtTbl; - ] - | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments expr cmtTbl in - let docTyp = printTypExpr typ cmtTbl in - let ofType = match typOpt with - | None -> Doc.nil - | Some(typ1) -> - Doc.concat [Doc.text ": "; printTypExpr typ1 cmtTbl] - in - Doc.concat [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] - | Pexp_send _ -> - Doc.text "Pexp_send not implemented in printer" - | Pexp_new _ -> - Doc.text "Pexp_new not implemented in printer" - | Pexp_setinstvar _ -> - Doc.text "Pexp_setinstvar not implemented in printer" - | Pexp_override _ -> - Doc.text "Pexp_override not implemented in printer" - | Pexp_poly _ -> - Doc.text "Pexp_poly not implemented in printer" - | Pexp_object _ -> - Doc.text "Pexp_object not implemented in printer" - in - let shouldPrintItsOwnAttributes = match e.pexp_desc with - | Pexp_apply _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_setfield _ - | Pexp_ifthenelse _ -> true - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> true - | _ -> false - in - match e.pexp_attributes with - | [] -> printedExpression - | attrs when not shouldPrintItsOwnAttributes -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - printedExpression; - ] - ) - | _ -> printedExpression - - and printPexpFun ~inCallback e cmtTbl = - let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in - let (uncurried, attrs) = - ParsetreeViewer.processUncurriedAttribute attrsOnArrow - in - let (returnExpr, typConstraint) = match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> ( - {expr with pexp_attributes = List.concat [ - expr.pexp_attributes; - returnExpr.pexp_attributes; - ]}, - Some typ - ) - | _ -> (returnExpr, None) - in - let parametersDoc = printExprFunParameters - ~inCallback - ~uncurried - ~hasConstraint:(match typConstraint with | Some _ -> true | None -> false) - parameters cmtTbl in - let returnShouldIndent = match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ -> false - | _ -> true - in - let returnExprDoc = - let (optBraces, _) = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = match (returnExpr.pexp_desc, optBraces) with - | (_, Some _) -> true - | ((Pexp_array _ - | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _), _) -> true - | _ -> false - in - let returnDoc = - let doc = printExpressionWithComments returnExpr cmtTbl in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces - | Nothing -> doc - in - if shouldInline then Doc.concat [ - Doc.space; - returnDoc; - ] else - Doc.group ( - if returnShouldIndent then - Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.line; - returnDoc; - ] - ); - if inCallback then Doc.softLine else Doc.nil; - ] - else - Doc.concat [ - Doc.space; - returnDoc; - ] - ) - in - let typConstraintDoc = match typConstraint with - | Some(typ) -> Doc.concat [ - Doc.text ": "; - printTypExpr typ cmtTbl - ] - | _ -> Doc.nil - in - Doc.group ( - Doc.concat [ - printAttributes attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ] - ) - - and printTernaryOperand expr cmtTbl = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.ternaryOperand expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - - and printSetFieldExpr attrs lhs longidentLoc rhs loc cmtTbl = - let rhsDoc = - let doc = printExpressionWithComments rhs cmtTbl in - match Parens.setFieldExprRhs rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - let lhsDoc = - let doc = printExpressionWithComments lhs cmtTbl in - match Parens.fieldExpr lhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc lhs braces - | Nothing -> doc - in - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = Doc.group (Doc.concat [ - lhsDoc; - Doc.dot; - printLidentPath longidentLoc cmtTbl; - Doc.text " ="; - if shouldIndent then Doc.group ( - Doc.indent ( - (Doc.concat [Doc.line; rhsDoc]) - ) - ) else - Doc.concat [Doc.space; rhsDoc] - ]) in - let doc = match attrs with - | [] -> doc - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - doc - ] - ) - in - printComments doc cmtTbl loc - - and printTemplateLiteral expr cmtTbl = - let tag = ref "j" in - let rec walkExpr expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [Nolabel, arg1; Nolabel, arg2] - ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [lhs; rhs] - | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - Doc.text txt - | _ -> - let doc = printExpressionWithComments expr cmtTbl in - Doc.concat [Doc.text "${"; doc; Doc.rbrace] - in - let content = walkExpr expr in - Doc.concat [ - if !tag = "j" then Doc.nil else Doc.text !tag; - Doc.text "`"; - content; - Doc.text "`" - ] - - and printUnaryExpression expr cmtTbl = - let printUnaryOperator op = Doc.text ( - match op with - | "~+" -> "+" - | "~+." -> "+." - | "~-" -> "-" - | "~-." -> "-." - | "not" -> "!" - | _ -> assert false - ) in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, operand] - ) -> - let printedOperand = - let doc = printExpressionWithComments operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [ - printUnaryOperator operator; - printedOperand; - ] in - printComments doc cmtTbl expr.pexp_loc - | _ -> assert false - - and printBinaryExpression (expr : Parsetree.expression) cmtTbl = - let printBinaryOperator ~inlineRhs operator = - let operatorTxt = match operator with - | "|." -> "->" - | "^" -> "++" - | "=" -> "==" - | "==" -> "===" - | "<>" -> "!=" - | "!=" -> "!==" - | txt -> txt - in - let spacingBeforeOperator = - if operator = "|." then Doc.softLine - else if operator = "|>" then Doc.line - else Doc.space; - in - let spacingAfterOperator = - if operator = "|." then Doc.nil - else if operator = "|>" then Doc.space - else if inlineRhs then Doc.space else Doc.line - in - Doc.concat [ - spacingBeforeOperator; - Doc.text operatorTxt; - spacingAfterOperator; - ] - in - let printOperand ~isLhs expr parentOperator = - let rec flatten ~isLhs expr parentOperator = - if ParsetreeViewer.isBinaryExpression expr then - begin match expr with - | {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [_, left; _, right] - )} -> - if ParsetreeViewer.flattenableOperators parentOperator operator && - not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let (_, rightAttrs) = - ParsetreeViewer.partitionPrinteableAttributes right.pexp_attributes - in - let doc = - printExpressionWithComments - {right with pexp_attributes = rightAttrs} - cmtTbl - in - let doc = if Parens.flattenOperandRhs parentOperator right then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else - doc - in - let printeableAttrs = - ParsetreeViewer.filterPrinteableAttributes right.pexp_attributes - in - Doc.concat [printAttributes printeableAttrs; doc] - in - let doc = Doc.concat [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] in - let doc = - if not isLhs && (Parens.rhsBinaryExprOperand operator expr) then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else ( - let doc = printExpressionWithComments {expr with pexp_attributes = []} cmtTbl in - let doc = if Parens.subBinaryExprOperand parentOperator operator || - (expr.pexp_attributes <> [] && - (ParsetreeViewer.isBinaryExpression expr || - ParsetreeViewer.isTernaryExpr expr)) - then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in Doc.concat [ - printAttributes expr.pexp_attributes; - doc - ] - ) - | _ -> assert false - end - else - begin match expr.pexp_desc with - | Pexp_setfield (lhs, field, rhs) -> - let doc = printSetFieldExpr expr.pexp_attributes lhs field rhs expr.pexp_loc cmtTbl in - if isLhs then addParens doc else doc - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] - ) -> - let rhsDoc = printExpressionWithComments rhs cmtTbl in - let lhsDoc = printExpressionWithComments lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = Doc.group ( - Doc.concat [ - lhsDoc; - Doc.text " ="; - if shouldIndent then Doc.group ( - Doc.indent (Doc.concat [Doc.line; rhsDoc]) - ) else - Doc.concat [Doc.space; rhsDoc] - ] - ) in - let doc = match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - doc - ] - ) - in - if isLhs then addParens doc else doc - | _ -> - let doc = printExpressionWithComments expr cmtTbl in - begin match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - end - end - in - flatten ~isLhs expr parentOperator - in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, - [Nolabel, lhs; Nolabel, rhs] - ) when not ( - ParsetreeViewer.isBinaryExpression lhs || - ParsetreeViewer.isBinaryExpression rhs - ) -> - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.group ( - Doc.concat [ - lhsDoc; - (match op with - | "|." -> Doc.text "->" - | "|>" -> Doc.text " |> " - | _ -> assert false); - rhsDoc; - ] - ) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, lhs; Nolabel, rhs] - ) -> - let right = - let operatorWithRhs = - let rhsDoc = printOperand ~isLhs:false rhs operator in - Doc.concat [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) operator; - rhsDoc; - ] in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = Doc.group ( - Doc.concat [ - printOperand ~isLhs:true lhs operator; - right - ] - ) in - Doc.group ( - Doc.concat [ - printAttributes expr.pexp_attributes; - match Parens.binaryExpr {expr with - pexp_attributes = List.filter (fun attr -> - match attr with - | ({Location.txt = ("res.braces")}, _) -> false - | _ -> true - ) expr.pexp_attributes - } with - | Braced(bracesLoc) -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc; - ] - ) - | _ -> Doc.nil - - (* callExpr(arg1, arg2) *) - and printPexpApply expr cmtTbl = - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [Nolabel, parentExpr; Nolabel, memberExpr] - ) -> - let parentDoc = - let doc = printExpressionWithComments parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments memberExpr cmtTbl - in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [Nolabel, lhs; Nolabel, rhs] - ) -> - let rhsDoc = - let doc = printExpressionWithComments rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = not (ParsetreeViewer.isBracedExpr rhs) && ParsetreeViewer.isBinaryExpression rhs in - let doc = Doc.group( - Doc.concat [ - printExpressionWithComments lhs cmtTbl; - Doc.text " ="; - if shouldIndent then Doc.group ( - Doc.indent ( - (Doc.concat [Doc.line; rhsDoc]) - ) - ) else - Doc.concat [Doc.space; rhsDoc] - ] - ) in - begin match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - doc - ] - ) - end - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [Nolabel, parentExpr; Nolabel, memberExpr] - ) -> - let member = - let memberDoc = - let doc = printExpressionWithComments memberExpr cmtTbl in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc else ( - Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - memberDoc; - ] - ); - Doc.softLine - ] - ) - in - let parentDoc = - let doc = printExpressionWithComments parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [Nolabel, parentExpr; Nolabel, memberExpr; Nolabel, targetExpr] - ) -> - let member = - let memberDoc = - let doc = printExpressionWithComments memberExpr cmtTbl in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc else ( - Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - memberDoc; - ] - ); - Doc.softLine - ] - ) - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then - false - else - ParsetreeViewer.isBinaryExpression targetExpr || - (match targetExpr with - | { - pexp_attributes = [({Location.txt="res.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _) - } -> - ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes || - ParsetreeViewer.isArrayAccess e - ) - in - let targetExpr = - let doc = printExpressionWithComments targetExpr cmtTbl in - match Parens.expr targetExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces - | Nothing -> doc - in - let parentDoc = - let doc = printExpressionWithComments parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group ( - Doc.concat [ - printAttributes expr.pexp_attributes; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - if shouldIndentTargetExpr then - Doc.indent ( - Doc.concat [ - Doc.line; - targetExpr; - ] - ) - else - Doc.concat [ - Doc.space; - targetExpr; - ] - ] - ) - (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ( - {pexp_desc = Pexp_ident lident}, - args - ) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression lident args cmtTbl - | Pexp_apply (callExpr, args) -> - let args = List.map (fun (lbl, arg) -> - (lbl, ParsetreeViewer.rewriteUnderscoreApply arg) - ) args - in - let (uncurried, attrs) = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes - in - let callExprDoc = - let doc = printExpressionWithComments callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc - in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl - in - Doc.concat [ - printAttributes attrs; - callExprDoc; - argsDoc; - ] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl - in - Doc.concat [ - printAttributes attrs; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~uncurried args cmtTbl in - Doc.concat [ - printAttributes attrs; - callExprDoc; - argsDoc; - ] - | _ -> assert false - - and printJsxExpression lident args cmtTbl = - let name = printJsxName lident in - let (formattedProps, children) = printJsxProps args cmtTbl in - (*
*) - let isSelfClosing = match children with | [] -> true | _ -> false in - Doc.group ( - Doc.concat [ - Doc.group ( - Doc.concat [ - printComments (Doc.concat [Doc.lessThan; name]) cmtTbl lident.Asttypes.loc; - formattedProps; - if isSelfClosing then Doc.concat [Doc.line; Doc.text "/>"] else Doc.nil - ] - ); - if isSelfClosing then Doc.nil - else - Doc.concat [ - Doc.greaterThan; - Doc.indent ( - Doc.concat [ - Doc.line; - printJsxChildren children cmtTbl; - ] - ); - Doc.line; - Doc.text "" in - let closing = Doc.text "" in - let (children, _) = ParsetreeViewer.collectListExpressions expr in - Doc.group ( - Doc.concat [ - opening; - begin match children with - | [] -> Doc.nil - | children -> - Doc.indent ( - Doc.concat [ - Doc.line; - printJsxChildren children cmtTbl; - ] - ) - end; - Doc.line; - closing; - ] - ) - - and printJsxChildren (children: Parsetree.expression list) cmtTbl = - Doc.group ( - Doc.join ~sep:Doc.line ( - List.map (fun expr -> - let exprDoc = printExpressionWithComments expr cmtTbl in - match Parens.jsxChildExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - addBraces (if Parens.bracedExpr expr then addParens exprDoc else exprDoc) - | Nothing -> exprDoc - ) children - ) - ) - - and printJsxProps args cmtTbl = - let rec loop props args = - match args with - | [] -> (Doc.nil, []) - | [ - (Asttypes.Labelled "children", children); - ( - Asttypes.Nolabel, - {Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} - ) - ] -> - let formattedProps = Doc.indent ( - match props with - | [] -> Doc.nil - | props -> - Doc.concat [ - Doc.line; - Doc.group ( - Doc.join ~sep:Doc.line (props |> List.rev) - ) - ] - ) in - let (children, _) = ParsetreeViewer.collectListExpressions children in - (formattedProps, children) - | arg::args -> - let propDoc = printJsxProp arg cmtTbl in - loop (propDoc::props) args - in - loop [] args - - and printJsxProp arg cmtTbl = - match arg with - | ( - (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl, - { - Parsetree.pexp_attributes = [({Location.txt = "res.namedArgLoc"; loc = argLoc}, _)]; - pexp_desc = Pexp_ident {txt = Longident.Lident ident} - } - ) when lblTxt = ident (* jsx punning *) -> - begin match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> - printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [ - Doc.question; - printIdentLike ident; - ] in - printComments doc cmtTbl argLoc - end - | ( - (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl, - { - Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident ident} - } - ) when lblTxt = ident (* jsx punning when printing from Reason *) -> - begin match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [ - Doc.question; - printIdentLike ident; - ] - end - | (lbl, expr) -> - let (argLoc, expr) = match expr.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> - Location.none, expr - in - let lblDoc = match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal; Doc.question] - | Nolabel -> Doc.nil - in - let exprDoc = - let doc = printExpression expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced(_) -> - (* {(20: int)} make sure that we also protect the expression inside *) - addBraces (if Parens.bracedExpr expr then addParens doc else doc) - | _ -> doc - in - let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - printComments - (Doc.concat [ - lblDoc; - exprDoc; - ]) - cmtTbl - fullLoc - - (* div -> div. - * Navabar.createElement -> Navbar - * Staff.Users.createElement -> Staff.Users *) - and printJsxName {txt = lident} = - let rec flatten acc lident = match lident with - | Longident.Lident txt -> txt::acc - | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt::acc in - flatten acc lident - | _ -> acc - in - match lident with - | Longident.Lident txt -> Doc.text txt - | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) - - and printArgumentsWithCallbackInFirstPosition ~uncurried args cmtTbl = - let (callback, printedArgs) = match args with - | (lbl, expr)::args -> - let lblDoc = match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ - Doc.tilde; printIdentLike txt; Doc.equal; - ] - | Asttypes.Optional txt -> - Doc.concat [ - Doc.tilde; printIdentLike txt; Doc.equal; Doc.question; - ] - in - let callback = Doc.concat [ - lblDoc; - printPexpFun ~inCallback:true expr cmtTbl - ] in - let printedArgs = List.map (fun arg -> - printArgument arg cmtTbl - ) args |> Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - in - (callback, printedArgs) - | _ -> assert false - in - (* Thing.map((arg1, arg2) => MyModuleBlah.toList(argument), foo) *) - (* Thing.map((arg1, arg2) => { - * MyModuleBlah.toList(argument) - * }, longArgumet, veryLooooongArgument) - *) - let fitsOnOneLine = Doc.concat [ - if uncurried then Doc.text "(. " else Doc.lparen; - callback; - Doc.comma; - Doc.line; - printedArgs; - Doc.rparen; - ] in - - (* Thing.map( - * (param1, parm2) => doStuff(param1, parm2), - * arg1, - * arg2, - * arg3, - * ) - *) - let breakAllArgs = printArguments ~uncurried args cmtTbl in - Doc.customLayout [ - fitsOnOneLine; - breakAllArgs; - ] - - and printArgumentsWithCallbackInLastPosition ~uncurried args cmtTbl = - let rec loop acc args = match args with - | [] -> (Doc.nil, Doc.nil) - | [lbl, expr] -> - let lblDoc = match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [ - Doc.tilde; printIdentLike txt; Doc.equal; - ] - | Asttypes.Optional txt -> - Doc.concat [ - Doc.tilde; printIdentLike txt; Doc.equal; Doc.question; - ] - in - let callback = printPexpFun ~inCallback:true expr cmtTbl in - (Doc.concat (List.rev acc), Doc.concat [lblDoc; callback]) - | arg::args -> - let argDoc = printArgument arg cmtTbl in - loop (Doc.line::Doc.comma::argDoc::acc) args - in - let (printedArgs, callback) = loop [] args in - - (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *) - let fitsOnOneLine = Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - printedArgs; - callback; - Doc.rparen; - ] in - - (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => - * MyModuleBlah.toList(argument) - * ) - *) - let arugmentsFitOnOneLine = - Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - Doc.softLine; - printedArgs; - Doc.breakableGroup ~forceBreak:true callback; - Doc.softLine; - Doc.rparen; - ] - in - - (* Thing.map( - * arg1, - * arg2, - * arg3, - * (param1, parm2) => doStuff(param1, parm2) - * ) - *) - let breakAllArgs = printArguments ~uncurried args cmtTbl in - Doc.customLayout [ - fitsOnOneLine; - arugmentsFitOnOneLine; - breakAllArgs; - ] - - and printArguments ~uncurried (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl = - match args with - | [Nolabel, {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}] -> - if uncurried then Doc.text "(.)" else Doc.text "()" - | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - argDoc; - Doc.rparen; - ] - | args -> Doc.group ( - Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - Doc.indent ( - Doc.concat [ - if uncurried then Doc.line else Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun arg -> printArgument arg cmtTbl) args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - -(* - * argument ::= - * | _ (* syntax sugar *) - * | expr - * | expr : type - * | ~ label-name - * | ~ label-name - * | ~ label-name ? - * | ~ label-name = expr - * | ~ label-name = _ (* syntax sugar *) - * | ~ label-name = expr : type - * | ~ label-name = ? expr - * | ~ label-name = ? _ (* syntax sugar *) - * | ~ label-name = ? expr : type *) - and printArgument (argLbl, arg) cmtTbl = - match (argLbl, arg) with - (* ~a (punned)*) - | ( - (Asttypes.Labelled lbl), - ({pexp_desc=Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = ([] | [({Location.txt = "res.namedArgLoc";}, _)]) - } as argExpr) - ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = match arg.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ - Doc.tilde; - printIdentLike lbl - ] in - printComments doc cmtTbl loc - - (* ~a: int (punned)*) - | ( - (Asttypes.Labelled lbl), - {pexp_desc = Pexp_constraint ( - {pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr, - typ - ); - pexp_loc; - pexp_attributes = ([] | [({Location.txt = "res.namedArgLoc";}, _)]) as attrs - } - ) when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = match attrs with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_ -> - {loc with loc_end = pexp_loc.loc_end} - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr typ cmtTbl; - ] in - printComments doc cmtTbl loc - (* ~a? (optional lbl punned)*) - | ( - (Asttypes.Optional lbl), - {pexp_desc=Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = ([] | [({Location.txt = "res.namedArgLoc";}, _)]) - } - ) when lbl = name -> - let loc = match arg.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [ - Doc.tilde; - printIdentLike lbl; - Doc.question; - ] in - printComments doc cmtTbl loc - | (_lbl, expr) -> - let (argLoc, expr) = match expr.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> - expr.pexp_loc, expr - in - let printedLbl = match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in - printComments doc cmtTbl argLoc - | Asttypes.Optional lbl -> - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] in - printComments doc cmtTbl argLoc - in - let printedExpr = - let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - let doc = Doc.concat [ - printedLbl; - printedExpr; - ] in - printComments doc cmtTbl loc - - and printCases (cases: Parsetree.case list) cmtTbl = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.concat [ - Doc.line; - printList - ~getLoc:(fun n -> {n.Parsetree.pc_lhs.ppat_loc with - loc_end = - match ParsetreeViewer.processBracesAttr n.Parsetree.pc_rhs with - | (None, _) -> n.pc_rhs.pexp_loc.loc_end - | (Some ({loc}, _), _) -> loc.Location.loc_end - }) - ~print:printCase - ~nodes:cases - cmtTbl - ]; - Doc.line; - Doc.rbrace; - ] - ) - - and printCase (case: Parsetree.case) cmtTbl = - let rhs = match case.pc_rhs.pexp_desc with - | Pexp_let _ - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_open _ - | Pexp_sequence _ -> - printExpressionBlock ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) case.pc_rhs cmtTbl - | _ -> - let doc = printExpressionWithComments case.pc_rhs cmtTbl in - begin match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc - end - - in - let guard = match case.pc_guard with - | None -> Doc.nil - | Some expr -> Doc.group ( - Doc.concat [ - Doc.line; - Doc.text "when "; - printExpressionWithComments expr cmtTbl; - ] - ) - in - let shouldInlineRhs = match case.pc_rhs.pexp_desc with - | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) - | Pexp_constant _ - | Pexp_ident _ -> true - | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true - | _ -> false - in - let shouldIndentPattern = match case.pc_lhs.ppat_desc with - | Ppat_or _ -> false - | _ -> true - in - let patternDoc = - let doc = printPattern case.pc_lhs cmtTbl in - match case.pc_lhs.ppat_desc with - | Ppat_constraint _ -> addParens doc - | _ -> doc - in - let content = Doc.concat [ - if shouldIndentPattern then Doc.indent patternDoc else patternDoc; - Doc.indent guard; - Doc.text " =>"; - Doc.indent ( - Doc.concat [ - if shouldInlineRhs then Doc.space else Doc.line; - rhs; - ] - ) - ] in - Doc.group ( - Doc.concat [ - Doc.text "| "; - content; - ] - ) - - and printExprFunParameters ~inCallback ~uncurried ~hasConstraint parameters cmtTbl = - match parameters with - (* let f = _ => () *) - | [ParsetreeViewer.Parameter { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_any} - }] when not uncurried -> - if hasConstraint then Doc.text "(_)" else Doc.text "_" - (* let f = a => () *) - | [ParsetreeViewer.Parameter { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_var stringLoc} - }] when not uncurried -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - if hasConstraint then addParens var else var - in - printComments txtDoc cmtTbl stringLoc.loc - (* let f = () => () *) - | [ParsetreeViewer.Parameter { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = {ppat_desc = Ppat_construct({txt = Longident.Lident "()"}, None)} - }] when not uncurried -> - Doc.text "()" - (* let f = (~greeting, ~from as hometown, ~x=?) => () *) - | parameters -> - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = Doc.concat [ - if shouldHug || inCallback then Doc.nil else Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; if inCallback then Doc.space else Doc.line]) - (List.map (fun p -> printExpFunParameter p cmtTbl) parameters) - ] in - Doc.group ( - Doc.concat [ - lparen; - if shouldHug || inCallback then - printedParamaters - else Doc.indent printedParamaters; - if shouldHug || inCallback then - Doc.nil - else - Doc.concat [Doc.trailingComma; Doc.softLine]; - Doc.rparen; - ] - ) - - and printExpFunParameter parameter cmtTbl = - match parameter with - | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - Doc.text "type "; - Doc.join ~sep:Doc.space (List.map (fun lbl -> - printComments (printIdentLike lbl.Asttypes.txt) cmtTbl lbl.Asttypes.loc - ) lbls) - ] - ) - | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = printAttributes attrs in - (* =defaultValue *) - let defaultExprDoc = match defaultExpr with - | Some expr -> Doc.concat [ - Doc.text "="; - printExpressionWithComments expr cmtTbl - ] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = match (lbl, pattern) with - | (Asttypes.Nolabel, pattern) -> printPattern pattern cmtTbl - | ( - (Asttypes.Labelled lbl | Optional lbl), - {ppat_desc = Ppat_var stringLoc; - ppat_attributes = ([] | [({Location.txt = "res.namedArgLoc";}, _)]) - } - ) when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - ] - | ( - (Asttypes.Labelled lbl | Optional lbl), - ({ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, typ); - ppat_attributes = ([] | [({Location.txt = "res.namedArgLoc";}, _)]) - }) - ) when lbl = txt -> - (* ~d: e *) - Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr typ cmtTbl; - ] - | ((Asttypes.Labelled lbl | Optional lbl), pattern) -> - (* ~b as c *) - Doc.concat [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern pattern cmtTbl - ] - in - let optionalLabelSuffix = match (lbl, defaultExpr) with - | (Asttypes.Optional _, None) -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = Doc.group ( - Doc.concat [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; - ] - ) in - let cmtLoc = match defaultExpr with - | None -> - begin match pattern.ppat_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_ -> - {loc with loc_end = pattern.ppat_loc.loc_end} - | _ -> pattern.ppat_loc - end - | Some expr -> - let startPos = match pattern.ppat_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _)::_ -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end - } - in - printComments doc cmtTbl cmtLoc - - and printExpressionBlock ~braces expr cmtTbl = - let rec collectRows acc expr = match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let letModuleDoc = Doc.concat [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr modExpr cmtTbl; - ] in - let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in - collectRows ((loc, letModuleDoc)::acc) expr2 - | Pexp_letexception (extensionConstructor, expr2) -> - let loc = - let loc = {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let letExceptionDoc = printExceptionDef extensionConstructor cmtTbl in - collectRows ((loc, letExceptionDoc)::acc) expr2 - | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = Doc.concat [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] in - let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in - collectRows ((loc, openDoc)::acc) expr2 - | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc)::acc) expr2 - | Pexp_let (recFlag, valueBindings, expr2) -> - let loc = - let loc = match (valueBindings, List.rev valueBindings) with - | (vb::_, lastVb::_) -> {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} - | _ -> Location.none - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let recFlag = match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = printValueBindings ~recFlag valueBindings cmtTbl in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - begin match expr2.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> - List.rev ((loc, letDoc)::acc) - | _ -> - collectRows ((loc, letDoc)::acc) expr2 - end - | _ -> - let exprDoc = - let doc = printExpression expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc)::acc) - in - let rows = collectRows [] expr in - let block = - printList - ~getLoc:fst - ~nodes:rows - ~print:(fun (_, doc) _ -> doc) - ~forceBreak:true - cmtTbl - in - Doc.breakableGroup ~forceBreak:true ( - if braces then - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.line; - block; - ] - ); - Doc.line; - Doc.rbrace; - ] - else block - ) - - (* - * // user types: - * let f = (a, b) => { a + b } - * - * // printer: everything is on one line - * let f = (a, b) => { a + b } - * - * // user types: over multiple lines - * let f = (a, b) => { - * a + b - * } - * - * // printer: over multiple lines - * let f = (a, b) => { - * a + b - * } - *) - and printBraces doc expr bracesLoc = - let overMultipleLines = - let open Location in - bracesLoc.loc_end.pos_lnum > bracesLoc.loc_start.pos_lnum - in - match expr.Parsetree.pexp_desc with - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_let _ - | Pexp_open _ - | Pexp_sequence _ -> - (* already has braces *) - doc - | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - if Parens.bracedExpr expr then addParens doc else doc; - ] - ); - Doc.softLine; - Doc.rbrace; - ] - ) - - and printOverrideFlag overrideFlag = match overrideFlag with - | Asttypes.Override -> Doc.text "!" - | Fresh -> Doc.nil - - and printDirectionFlag flag = match flag with - | Asttypes.Downto -> Doc.text " downto " - | Asttypes.Upto -> Doc.text " to " - - and printRecordRow (lbl, expr) cmtTbl = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in - let doc = Doc.group (Doc.concat [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - (let doc = printExpressionWithComments expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) in - printComments doc cmtTbl cmtLoc - - and printBsObjectRow (lbl, expr) cmtTbl = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in - let lblDoc = - let doc = Doc.concat [ - Doc.text "\""; - printLongident lbl.txt; - Doc.text "\""; - ] in - printComments doc cmtTbl lbl.loc - in - let doc = Doc.concat [ - lblDoc; - Doc.text ": "; - printExpressionWithComments expr cmtTbl - ] in - printComments doc cmtTbl cmtLoc - - (* The optional loc indicates whether we need to print the attributes in - * relation to some location. In practise this means the following: - * `@attr type t = string` -> on the same line, print on the same line - * `@attr - * type t = string` -> attr is on prev line, print the attributes - * with a line break between, we respect the users' original layout *) - and printAttributes ?loc (attrs: Parsetree.attributes) = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> Doc.nil - | attrs -> - let lineBreak = match loc with - | None -> Doc.line - | Some loc -> begin match List.rev attrs with - | ({loc = firstLoc}, _)::_ when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine; - | _ -> Doc.line - end - in - Doc.concat [ - Doc.group (Doc.join ~sep:Doc.line (List.map printAttribute attrs)); - lineBreak; - ] - - and printAttribute ((id, payload) : Parsetree.attribute) = - let attrName = Doc.concat [ - Doc.text "@"; - Doc.text id.txt - ] in - match payload with - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpression expr CommentTable.empty in - let needsParens = match attrs with | [] -> false | _ -> true in - Doc.group ( - Doc.concat [ - attrName; - addParens ( - Doc.concat [ - printAttributes attrs; - if needsParens then addParens exprDoc else exprDoc; - ] - ) - ] - ) - | PTyp typ -> - Doc.group ( - Doc.concat [ - attrName; - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.text ": "; - printTypExpr typ CommentTable.empty; - ] - ); - Doc.softLine; - Doc.rparen; - ] - ) - | _ -> attrName - - and printAttributeWithComments ((id, payload) : Parsetree.attribute) cmtTbl = - let attrName = Doc.text ("@" ^ id.txt) in - match payload with - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments expr cmtTbl in - let needsParens = match attrs with | [] -> false | _ -> true in - Doc.group ( - Doc.concat [ - attrName; - addParens ( - Doc.concat [ - printAttributes attrs; - if needsParens then addParens exprDoc else exprDoc; - ] - ) - ] - ) - | _ -> attrName - - and printModExpr modExpr cmtTbl = - let doc = match modExpr.pmod_desc with - | Pmod_ident longidentLoc -> - printLongidentLocation longidentLoc cmtTbl - | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - printStructure structure cmtTbl; - ]; - ); - Doc.softLine; - Doc.rbrace; - ] - ) - | Pmod_unpack expr -> - let shouldHug = match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint ( - {pexp_desc = Pexp_let _ }, - {ptyp_desc = Ptyp_package _packageType} - ) -> true - | _ -> false - in - let (expr, moduleConstraint) = match expr.pexp_desc with - | Pexp_constraint ( - expr, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} - ) -> - let packageDoc = - let doc = printPackageType ~printModuleKeywordAndParens:false packageType cmtTbl in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = Doc.group (Doc.concat [ - Doc.text ":"; - Doc.indent ( - Doc.concat [ - Doc.line; - packageDoc - ] - ) - ]) in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = Doc.group(Doc.concat [ - printExpressionWithComments expr cmtTbl; - moduleConstraint; - ]) in - Doc.group ( - Doc.concat [ - Doc.text "unpack("; - if shouldHug then unpackDoc - else - Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - unpackDoc; - ] - ); - Doc.softLine; - ]; - Doc.rparen; - ] - ) - | Pmod_extension extension -> - printExtensionWithComments ~atModuleLvl:false extension cmtTbl - | Pmod_apply _ -> - let (args, callExpr) = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = match args with - | [{pmod_desc = Pmod_structure []}] -> true - | _ -> false - in - let shouldHug = match args with - | [{pmod_desc = Pmod_structure _}] -> true - | _ -> false - in - Doc.group ( - Doc.concat [ - printModExpr callExpr cmtTbl; - if isUnitSugar then - printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl - else - Doc.concat [ - Doc.lparen; - if shouldHug then - printModApplyArg (List.hd args [@doesNotRaise]) cmtTbl - else - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun modArg -> printModApplyArg modArg cmtTbl) args - ) - ] - ); - if not shouldHug then - Doc.concat [ - Doc.trailingComma; - Doc.softLine; - ] - else Doc.nil; - Doc.rparen; - ] - ] - ) - | Pmod_constraint (modExpr, modType) -> - Doc.concat [ - printModExpr modExpr cmtTbl; - Doc.text ": "; - printModType modType cmtTbl; - ] - | Pmod_functor _ -> - printModFunctor modExpr cmtTbl - in - printComments doc cmtTbl modExpr.pmod_loc - - and printModFunctor modExpr cmtTbl = - let (parameters, returnModExpr) = ParsetreeViewer.modExprFunctor modExpr in - (* let shouldInline = match returnModExpr.pmod_desc with *) - (* | Pmod_structure _ | Pmod_ident _ -> true *) - (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) - (* | _ -> false *) - (* in *) - let (returnConstraint, returnModExpr) = match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [ - Doc.text ": "; - constraintDoc; - ] in - (modConstraint, printModExpr modExpr cmtTbl) - | _ -> (Doc.nil, printModExpr returnModExpr cmtTbl) - in - let parametersDoc = match parameters with - | [(attrs, {txt = "*"}, None)] -> - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - Doc.group (Doc.concat [ - attrs; - Doc.text "()" - ]) - | [([], {txt = lbl}, None)] -> Doc.text lbl - | parameters -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun param -> printModFunctorParam param cmtTbl) parameters - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - parametersDoc; - returnConstraint; - Doc.text " => "; - returnModExpr - ] - ) - - and printModFunctorParam (attrs, lbl, optModType) cmtTbl = - let cmtLoc = match optModType with - | None -> lbl.Asttypes.loc - | Some modType -> {lbl.loc with loc_end = - modType.Parsetree.pmty_loc.loc_end - } - in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - let lblDoc = - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = Doc.group ( - Doc.concat [ - attrs; - lblDoc; - (match optModType with - | None -> Doc.nil - | Some modType -> - Doc.concat [ - Doc.text ": "; - printModType modType cmtTbl - ]); - ] - ) in - printComments doc cmtTbl cmtLoc - - and printModApplyArg modExpr cmtTbl = - match modExpr.pmod_desc with - | Pmod_structure [] -> Doc.text "()" - | _ -> printModExpr modExpr cmtTbl - - - and printExceptionDef (constr : Parsetree.extension_constructor) cmtTbl = - let kind = match constr.pext_kind with - | Pext_rebind longident -> Doc.indent ( - Doc.concat [ - Doc.text " ="; - Doc.line; - printLongidentLocation longident cmtTbl; - ] - ) - | Pext_decl (Pcstr_tuple [], None) -> Doc.nil - | Pext_decl (args, gadt) -> - let gadtDoc = match gadt with - | Some typ -> Doc.concat [ - Doc.text ": "; - printTypExpr typ cmtTbl - ] - | None -> Doc.nil - in - Doc.concat [ - printConstructorArguments ~indent:false args cmtTbl; - gadtDoc - ] - in - let name = - printComments - (Doc.text constr.pext_name.txt) - cmtTbl - constr.pext_name.loc - in - let doc = Doc.group ( - Doc.concat [ - printAttributes constr.pext_attributes; - Doc.text "exception "; - name; - kind - ] - ) in - printComments doc cmtTbl constr.pext_loc - - and printExtensionConstructor (constr : Parsetree.extension_constructor) cmtTbl i = - let attrs = printAttributes constr.pext_attributes in - let bar = if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil - in - let kind = match constr.pext_kind with - | Pext_rebind longident -> Doc.indent ( - Doc.concat [ - Doc.text " ="; - Doc.line; - printLongidentLocation longident cmtTbl; - ] - ) - | Pext_decl (Pcstr_tuple [], None) -> Doc.nil - | Pext_decl (args, gadt) -> - let gadtDoc = match gadt with - | Some typ -> Doc.concat [ - Doc.text ": "; - printTypExpr typ cmtTbl; - ] - | None -> Doc.nil - in - Doc.concat [ - printConstructorArguments ~indent:false args cmtTbl; - gadtDoc - ] - in - let name = - printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc - in - Doc.concat [ - bar; - Doc.group ( - Doc.concat [ - attrs; - name; - kind; - ] - ) - ] - - let printImplementation ~width (s: Parsetree.structure) comments = - let cmtTbl = CommentTable.make () in - CommentTable.walkStructure s cmtTbl comments; - (* CommentTable.log cmtTbl; *) - let doc = printStructure s cmtTbl in - (* Doc.debug doc; *) - let stringDoc = Doc.toString ~width doc in - print_string stringDoc - - let printInterface ~width (s: Parsetree.signature) comments = - let cmtTbl = CommentTable.make () in - CommentTable.walkSignature s cmtTbl comments; - let stringDoc = Doc.toString ~width (printSignature s cmtTbl) in - print_string stringDoc - -end - -module Scanner = struct - type mode = Template | Jsx | Diamond - - type t = { - filename: string; - src: bytes; - mutable err: - startPos: Lexing.position - -> endPos: Lexing.position - -> Diagnostics.category - -> unit; - mutable ch: int; (* current character *) - mutable offset: int; (* character offset *) - mutable rdOffset: int; (* reading offset (position after current character) *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; - } - - let setDiamondMode scanner = - scanner.mode <- Diamond::scanner.mode - - let setTemplateMode scanner = - scanner.mode <- Template::scanner.mode - - let setJsxMode scanner = - scanner.mode <- Jsx::scanner.mode - - let popMode scanner mode = - match scanner.mode with - | m::ms when m = mode -> - scanner.mode <- ms - | _ -> () - - let inDiamondMode scanner = match scanner.mode with - | Diamond::_ -> true - | _ -> false - - let inJsxMode scanner = match scanner.mode with - | Jsx::_ -> true - | _ -> false - - let inTemplateMode scanner = match scanner.mode with - | Template::_ -> true - | _ -> false - - let position scanner = Lexing.{ - pos_fname = scanner.filename; - (* line number *) - pos_lnum = scanner.lnum; - (* offset of the beginning of the line (number - of characters between the beginning of the scanner and the beginning - of the line) *) - pos_bol = scanner.lineOffset; - (* [pos_cnum] is the offset of the position (number of - characters between the beginning of the scanner and the position). *) - pos_cnum = scanner.offset; - } - - let next scanner = - if scanner.rdOffset < (Bytes.length scanner.src) then ( - scanner.offset <- scanner.rdOffset; - let ch = (Bytes.get [@doesNotRaise]) scanner.src scanner.rdOffset in - scanner.rdOffset <- scanner.rdOffset + 1; - scanner.ch <- int_of_char ch - ) else ( - scanner.offset <- Bytes.length scanner.src; - scanner.ch <- -1 - ) - - let peek scanner = - if scanner.rdOffset < (Bytes.length scanner.src) then - int_of_char (Bytes.unsafe_get scanner.src scanner.rdOffset) - else - -1 - - let make b filename = - let scanner = { - filename; - src = b; - err = (fun ~startPos:_ ~endPos:_ _ -> ()); - ch = CharacterCodes.space; - offset = 0; - rdOffset = 0; - lineOffset = 0; - lnum = 1; - mode = []; - } in - next scanner; - scanner - - let skipWhitespace scanner = - let rec scan () = - if scanner.ch == CharacterCodes.space || scanner.ch == CharacterCodes.tab then ( - next scanner; - scan() - ) else if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - next scanner; - scan() - ) else ( - () - ) - in - scan() - - let scanIdentifier scanner = - let startOff = scanner.offset in - while ( - CharacterCodes.isLetter scanner.ch || - CharacterCodes.isDigit scanner.ch || - CharacterCodes.underscore == scanner.ch || - CharacterCodes.singleQuote == scanner.ch - ) do - next scanner - done; - let str = Bytes.sub_string scanner.src startOff (scanner.offset - startOff) in - Token.lookupKeyword str - - let scanDigits scanner ~base = - if base <= 10 then ( - while CharacterCodes.isDigit scanner.ch || scanner.ch == CharacterCodes.underscore do - next scanner - done; - ) else ( - while CharacterCodes.isHex scanner.ch || scanner.ch == CharacterCodes.underscore do - next scanner - done; - ) - - (* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *) - let scanNumber scanner = - let startOff = scanner.offset in - - (* integer part *) - let base, _prefix = if scanner.ch != CharacterCodes.dot then ( - if scanner.ch == CharacterCodes._0 then ( - next scanner; - let ch = CharacterCodes.lower scanner.ch in - if ch == CharacterCodes.Lower.x then ( - next scanner; - 16, 'x' - ) else if ch == CharacterCodes.Lower.o then ( - next scanner; - 8, 'o' - ) else if ch == CharacterCodes.Lower.b then ( - next scanner; - 2, 'b' - ) else ( - 8, '0' - ) - ) else ( - 10, ' ' - ) - ) else (10, ' ') - in - scanDigits scanner ~base; - - (* *) - let isFloat = if CharacterCodes.dot == scanner.ch then ( - next scanner; - scanDigits scanner ~base; - true - ) else ( - false - ) in - - (* exponent part *) - let isFloat = - if let exp = CharacterCodes.lower scanner.ch in - exp == CharacterCodes.Lower.e || exp == CharacterCodes.Lower.p - then ( - next scanner; - if scanner.ch == CharacterCodes.plus || scanner.ch == CharacterCodes.minus then - next scanner; - scanDigits scanner ~base; - true - ) else - isFloat - in - let literal = - Bytes.sub_string scanner.src startOff (scanner.offset - startOff) - in - - (* suffix *) - let suffix = - if scanner.ch >= CharacterCodes.Lower.g && scanner.ch <= CharacterCodes.Lower.z - || scanner.ch >= CharacterCodes.Upper.g && scanner.ch <= CharacterCodes.Upper.z - then ( - let ch = scanner.ch in - next scanner; - Some (Char.unsafe_chr ch) - ) else - None - in - if isFloat then - Token.Float {f = literal; suffix} - else - Token.Int {i = literal; suffix} - - let scanExoticIdentifier scanner = - next scanner; - let buffer = Buffer.create 20 in - let startPos = position scanner in - - let rec scan () = - if scanner.ch == CharacterCodes.eof then - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?") - else if scanner.ch == CharacterCodes.doubleQuote then ( - next scanner - ) else if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.message "Did you forget a \" here?"); - next scanner - ) else ( - Buffer.add_char buffer ((Char.chr [@doesNotRaise]) scanner.ch); - next scanner; - scan() - ) - in - scan(); - Token.Lident (Buffer.contents buffer) - - let scanStringEscapeSequence ~startPos scanner = - (* \ already consumed *) - if CharacterCodes.Lower.n == scanner.ch - || CharacterCodes.Lower.t == scanner.ch - || CharacterCodes.Lower.b == scanner.ch - || CharacterCodes.Lower.r == scanner.ch - || CharacterCodes.backslash == scanner.ch - || CharacterCodes.space == scanner.ch - || CharacterCodes.singleQuote == scanner.ch - || CharacterCodes.doubleQuote == scanner.ch - then - next scanner - else - let (n, base, max) = - if CharacterCodes.isDigit scanner.ch then - (* decimal *) - (3, 10, 255) - else if scanner.ch == CharacterCodes.Lower.o then - (* octal *) - let () = next scanner in - (3, 8, 255) - else if scanner.ch == CharacterCodes.Lower.x then - (* hex *) - let () = next scanner in - (2, 16, 255) - else - (* unknown escape sequence - * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) - (* let pos = position scanner in *) - (* let () = *) - (* let msg = if scanner.ch == -1 then *) - (* "unclosed escape sequence" *) - (* else "unknown escape sequence" *) - (* in *) - (* scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) *) - (* in *) - (-1, -1, -1) - in - if n < 0 then () - else - let rec while_ n x = - if n == 0 then x - else - let d = CharacterCodes.digitValue scanner.ch in - if d >= base then - let pos = position scanner in - let msg = if scanner.ch == -1 then - "unclosed escape sequence" - else "unknown escape sequence" - in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); - -1 - else - let () = next scanner in - while_ (n - 1) (x * base + d) - in - let x = while_ n 0 in - if x > max then - let pos = position scanner in - let msg = "invalid escape sequence (value too high)" in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); - () - - let scanString scanner = - let offs = scanner.offset in - - let startPos = position scanner in - let rec scan () = - if scanner.ch == CharacterCodes.eof then - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedString - else if scanner.ch == CharacterCodes.doubleQuote then ( - next scanner; - ) else if scanner.ch == CharacterCodes.backslash then ( - let startPos = position scanner in - next scanner; - scanStringEscapeSequence ~startPos scanner; - scan () - ) else if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - next scanner; - scan () - ) else ( - next scanner; - scan () - ) - in - scan (); - Token.String (Bytes.sub_string scanner.src offs (scanner.offset - offs - 1)) - - (* I wonder if this gets inlined *) - let convertNumber scanner ~n ~base = - let x = ref 0 in - for _ = n downto 1 do - let d = CharacterCodes.digitValue scanner.ch in - x := (!x * base) + d; - next scanner - done; - !x - - let scanEscape scanner = - (* let offset = scanner.offset in *) - let c = match scanner.ch with - | 98 (* b *) -> next scanner; '\008' - | 110 (* n *) -> next scanner; '\010' - | 114 (* r *) -> next scanner; '\013' - | 116 (* t *) -> next scanner; '\009' - | ch when CharacterCodes.isDigit ch -> - let x = convertNumber scanner ~n:3 ~base:10 in - (Char.chr [@doesNotRaise]) x - | ch when ch == CharacterCodes.Lower.x -> - next scanner; - let x = convertNumber scanner ~n:2 ~base:16 in - (Char.chr [@doesNotRaise]) x - | ch when ch == CharacterCodes.Lower.o -> - next scanner; - let x = convertNumber scanner ~n:3 ~base:8 in - (Char.chr [@doesNotRaise]) x - | ch -> - next scanner; - (Char.chr [@doesNotRaise]) ch - in - next scanner; (* Consume \' *) - Token.Character c - - let scanSingleLineComment scanner = - let startOff = scanner.offset in - let startPos = position scanner in - while not (CharacterCodes.isLineBreak scanner.ch) && scanner.ch >= 0 do - next scanner - done; - let endPos = position scanner in - Token.Comment ( - Comment.makeSingleLineComment - ~loc:(Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false}) - (Bytes.sub_string scanner.src startOff (scanner.offset - startOff)) - ) - - let scanMultiLineComment scanner = - let startOff = scanner.offset in - let startPos = position scanner in - let rec scan ~depth () = - if scanner.ch == CharacterCodes.asterisk && - peek scanner == CharacterCodes.forwardslash then ( - next scanner; - next scanner; - if depth > 0 then scan ~depth:(depth - 1) () else () - ) else if scanner.ch == CharacterCodes.eof then ( - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment - ) else if scanner.ch == CharacterCodes.forwardslash - && peek scanner == CharacterCodes. asterisk then ( - next scanner; - next scanner; - scan ~depth:(depth + 1) () - ) else ( - if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - ); - next scanner; - scan ~depth () - ) - in - scan ~depth:0 (); - Token.Comment ( - Comment.makeMultiLineComment - ~loc:(Location.{loc_start = startPos; loc_end = (position scanner); loc_ghost = false}) - (Bytes.sub_string scanner.src startOff (scanner.offset - 2 - startOff)) - ) - - let scanTemplate scanner = - let startOff = scanner.offset in - let startPos = position scanner in - - let rec scan () = - if scanner.ch == CharacterCodes.eof then ( - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; - popMode scanner Template; - Token.TemplateTail( - Bytes.sub_string scanner.src startOff (scanner.offset - 2 - startOff) - ) - ) - else if scanner.ch == CharacterCodes.backslash then ( - next scanner; - if scanner.ch == CharacterCodes.backtick - || scanner.ch == CharacterCodes.backslash - || scanner.ch == CharacterCodes.dollar - then next scanner; - scan() - ) else if scanner.ch == CharacterCodes.backtick then ( - next scanner; - let contents = - Bytes.sub_string scanner.src startOff (scanner.offset - 1 - startOff) - in - popMode scanner Template; - Token.TemplateTail contents - ) else if scanner.ch == CharacterCodes.dollar && - peek scanner == CharacterCodes.lbrace - then ( - next scanner; (* consume $ *) - next scanner; (* consume { *) - let contents = - Bytes.sub_string scanner.src startOff (scanner.offset - 2 - startOff) - in - popMode scanner Template; - Token.TemplatePart contents - ) else ( - if CharacterCodes.isLineBreak scanner.ch then ( - scanner.lineOffset <- scanner.offset + 1; - scanner.lnum <- scanner.lnum + 1; - ); - next scanner; - scan() - ) - in - scan() - - let rec scan scanner = - if not (inTemplateMode scanner) then skipWhitespace scanner; - let startPos = position scanner in - let ch = scanner.ch in - let token = if inTemplateMode scanner then - scanTemplate scanner - else if ch == CharacterCodes.underscore then ( - let nextCh = peek scanner in - if nextCh == CharacterCodes.underscore || CharacterCodes.isDigit nextCh || CharacterCodes.isLetter nextCh then - scanIdentifier scanner - else ( - next scanner; - Token.Underscore - ) - ) else if CharacterCodes.isLetter ch then - scanIdentifier scanner - else if CharacterCodes.isDigit ch then - scanNumber scanner - else begin - next scanner; - if ch == CharacterCodes.dot then - if scanner.ch == CharacterCodes.dot then ( - next scanner; - if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.DotDotDot - ) else ( - Token.DotDot - ) - ) else ( - Token.Dot - ) - else if ch == CharacterCodes.doubleQuote then - scanString scanner - else if ch == CharacterCodes.singleQuote then ( - if scanner.ch == CharacterCodes.backslash - && not ((peek scanner) == CharacterCodes.doubleQuote) (* start of exotic ident *) - then ( - next scanner; - scanEscape scanner - ) else if (peek scanner) == CharacterCodes.singleQuote then ( - let ch = scanner.ch in - next scanner; - next scanner; - Token.Character ((Char.chr [@doesNotRaise]) ch) - ) else ( - SingleQuote - ) - ) else if ch == CharacterCodes.bang then - if scanner.ch == CharacterCodes.equal then ( - next scanner; - if scanner.ch == CharacterCodes.equal then ( - next scanner; - Token.BangEqualEqual - ) else ( - Token.BangEqual - ) - ) else ( - Token.Bang - ) - else if ch == CharacterCodes.semicolon then - Token.Semicolon - else if ch == CharacterCodes.equal then ( - if scanner.ch == CharacterCodes.greaterThan then ( - next scanner; - Token.EqualGreater - ) else if scanner.ch == CharacterCodes.equal then ( - next scanner; - if scanner.ch == CharacterCodes.equal then ( - next scanner; - Token.EqualEqualEqual - ) else ( - Token.EqualEqual - ) - ) else ( - Token.Equal - ) - ) else if ch == CharacterCodes.bar then - if scanner.ch == CharacterCodes.bar then ( - next scanner; - Token.Lor - ) else if scanner.ch == CharacterCodes.greaterThan then ( - next scanner; - Token.BarGreater - ) else ( - Token.Bar - ) - else if ch == CharacterCodes.ampersand then - if scanner.ch == CharacterCodes.ampersand then ( - next scanner; - Token.Land - ) else ( - Token.Band - ) - else if ch == CharacterCodes.lparen then - Token.Lparen - else if ch == CharacterCodes.rparen then - Token.Rparen - else if ch == CharacterCodes.lbracket then - Token.Lbracket - else if ch == CharacterCodes.rbracket then - Token.Rbracket - else if ch == CharacterCodes.lbrace then - Token.Lbrace - else if ch == CharacterCodes.rbrace then - Token.Rbrace - else if ch == CharacterCodes.comma then - Token.Comma - else if ch == CharacterCodes.colon then - if scanner.ch == CharacterCodes.equal then( - next scanner; - Token.ColonEqual - ) else if (scanner.ch == CharacterCodes.greaterThan) then ( - next scanner; - Token.ColonGreaterThan - ) else ( - Token.Colon - ) - else if ch == CharacterCodes.backslash then - scanExoticIdentifier scanner - else if ch == CharacterCodes.forwardslash then - if scanner.ch == CharacterCodes.forwardslash then ( - next scanner; - scanSingleLineComment scanner - ) else if (scanner.ch == CharacterCodes.asterisk) then ( - next scanner; - scanMultiLineComment scanner - ) else if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.ForwardslashDot - ) else ( - Token.Forwardslash - ) - else if ch == CharacterCodes.minus then - if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.MinusDot - ) else if scanner.ch == CharacterCodes.greaterThan then ( - next scanner; - Token.MinusGreater; - ) else ( - Token.Minus - ) - else if ch == CharacterCodes.plus then - if scanner.ch == CharacterCodes.dot then ( - next scanner; - Token.PlusDot - ) else if scanner.ch == CharacterCodes.plus then ( - next scanner; - Token.PlusPlus - ) else if scanner.ch == CharacterCodes.equal then ( - next scanner; - Token.PlusEqual - ) else ( - Token.Plus - ) - else if ch == CharacterCodes.greaterThan then - if scanner.ch == CharacterCodes.equal && not (inDiamondMode scanner) then ( - next scanner; - Token.GreaterEqual - ) else ( - Token.GreaterThan - ) - else if ch == CharacterCodes.lessThan then - (* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the < - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate *) - let reconsiderLessThan scanner = - (* < consumed *) - skipWhitespace scanner; - if scanner.ch == CharacterCodes.forwardslash then - let () = next scanner in - Token.LessThanSlash - else - Token.LessThan - - (* If an operator has whitespace around both sides, it's a binary operator *) - let isBinaryOp src startCnum endCnum = - if startCnum == 0 then false - else - let leftOk = - let c = - (startCnum - 1) - |> (Bytes.get [@doesNotRaise]) src - |> Char.code - in - c == CharacterCodes.space || - c == CharacterCodes.tab || - CharacterCodes.isLineBreak c - in - let rightOk = - let c = - if endCnum == Bytes.length src then -1 - else endCnum |> (Bytes.get [@doesNotRaise]) src |> Char.code - in - c == CharacterCodes.space || - c == CharacterCodes.tab || - CharacterCodes.isLineBreak c || - c == CharacterCodes.eof - in - leftOk && rightOk -end - -(* AST for js externals *) -module JsFfi = struct - type scope = - | Global - | Module of string (* bs.module("path") *) - | Scope of Longident.t (* bs.scope(/"window", "location"/) *) - - type label_declaration = { - jld_attributes: Parsetree.attributes; [@live] - jld_name: string; - jld_alias: string; - jld_type: Parsetree.core_type; - jld_loc: Location.t - } - - type importSpec = - | Default of label_declaration - | Spec of label_declaration list - - type import_description = { - jid_loc: Location.t; - jid_spec: importSpec; - jid_scope: scope; - jid_attributes: Parsetree.attributes; - } - - let decl ~attrs ~loc ~name ~alias ~typ = { - jld_loc = loc; - jld_attributes = attrs; - jld_name = name; - jld_alias = alias; - jld_type = typ - } - - let importDescr ~attrs ~scope ~importSpec ~loc = { - jid_loc = loc; - jid_spec = importSpec; - jid_scope = scope; - jid_attributes = attrs; - } - - let toParsetree importDescr = - let bsVal = (Location.mknoloc "bs.val", Parsetree.PStr []) in - let attrs = match importDescr.jid_scope with - | Global -> [bsVal] - (* @genType.import("./MyMath"), - * @genType.import(/"./MyMath", "default"/) *) - | Module s -> - let structure = [ - Parsetree.Pconst_string (s, None) - |> Ast_helper.Exp.constant - |> Ast_helper.Str.eval - ] in - let genType = (Location.mknoloc "genType.import", Parsetree.PStr structure) in - [genType] - | Scope longident -> - let structureItem = - let expr = match Longident.flatten longident |> List.map (fun s -> - Ast_helper.Exp.constant (Parsetree.Pconst_string (s, None)) - ) with - | [expr] -> expr - | [] as exprs | (_ as exprs) -> exprs |> Ast_helper.Exp.tuple - in - Ast_helper.Str.eval expr - in - let bsScope = ( - Location.mknoloc "bs.scope", - Parsetree. PStr [structureItem] - ) in - [bsVal; bsScope] - in - let valueDescrs = match importDescr.jid_spec with - | Default decl -> - let prim = [decl.jld_name] in - let allAttrs = - List.concat [attrs; importDescr.jid_attributes] - |> List.map (fun attr -> match attr with - | ( - {Location.txt = "genType.import"} as id, - Parsetree.PStr [{pstr_desc = Parsetree.Pstr_eval (moduleName, _) }] - ) -> - let default = - Parsetree.Pconst_string ("default", None) |> Ast_helper.Exp.constant - in - let structureItem = - [moduleName; default] - |> Ast_helper.Exp.tuple - |> Ast_helper.Str.eval - in - (id, Parsetree.PStr [structureItem]) - | attr -> attr - ) - in - [Ast_helper.Val.mk - ~loc:importDescr.jid_loc - ~prim - ~attrs:allAttrs - (Location.mknoloc decl.jld_alias) - decl.jld_type - |> Ast_helper.Str.primitive] - | Spec decls -> - List.map (fun decl -> - let prim = [decl.jld_name] in - let allAttrs = List.concat [attrs; decl.jld_attributes] in - Ast_helper.Val.mk - ~loc:importDescr.jid_loc - ~prim - ~attrs:allAttrs - (Location.mknoloc decl.jld_alias) - decl.jld_type - |> Ast_helper.Str.primitive ~loc:decl.jld_loc - ) decls - in - let jsFfiAttr = (Location.mknoloc "ns.jsFfi", Parsetree.PStr []) in - Ast_helper.Mod.structure ~loc:importDescr.jid_loc valueDescrs - |> Ast_helper.Incl.mk ~attrs:[jsFfiAttr] ~loc:importDescr.jid_loc - |> Ast_helper.Str.include_ ~loc:importDescr.jid_loc -end - -module ParsetreeCompatibility = struct - let concatLongidents l1 l2 = - let parts1 = Longident.flatten l1 in - let parts2 = Longident.flatten l2 in - match List.concat [parts1; parts2] |> Longident.unflatten with - | Some longident -> longident - | None -> l2 - - (* TODO: support nested open's ? *) - let rec rewritePpatOpen longidentOpen pat = - let open Parsetree in - match pat.ppat_desc with - | Ppat_array (first::rest) -> - (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) - {pat with ppat_desc = Ppat_array ((rewritePpatOpen longidentOpen first)::rest)} - | Ppat_tuple (first::rest) -> - (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) - {pat with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen first)::rest)} - | Ppat_construct( - {txt = Longident.Lident "::"} as listConstructor, - Some ({ppat_desc=Ppat_tuple (pat::rest)} as element) - ) -> - (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) - {pat with ppat_desc = - Ppat_construct ( - listConstructor, - Some {element with ppat_desc = Ppat_tuple ((rewritePpatOpen longidentOpen pat)::rest)} - ) - } - | Ppat_construct ({txt = constructor} as longidentLoc, optPattern) -> - (* Foo.(Bar(a)) -> Foo.Bar(a) *) - {pat with ppat_desc = - Ppat_construct ( - {longidentLoc with txt = concatLongidents longidentOpen constructor}, - optPattern - ) - } - | Ppat_record (({txt = lbl} as longidentLoc, firstPat)::rest, flag) -> - (* Foo.{x} -> {Foo.x: x} *) - let firstRow = ( - {longidentLoc with txt = concatLongidents longidentOpen lbl}, - firstPat - ) in - {pat with ppat_desc = Ppat_record (firstRow::rest, flag)} - | Ppat_or (pat1, pat2) -> - {pat with ppat_desc = Ppat_or ( - rewritePpatOpen longidentOpen pat1, - rewritePpatOpen longidentOpen pat2 - )} - | Ppat_constraint (pattern, typ) -> - {pat with ppat_desc = Ppat_constraint ( - rewritePpatOpen longidentOpen pattern, - typ - )} - | Ppat_type ({txt = constructor} as longidentLoc) -> - {pat with ppat_desc = Ppat_type ( - {longidentLoc with txt = concatLongidents longidentOpen constructor} - )} - | Ppat_lazy p -> - {pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p)} - | Ppat_exception p -> - {pat with ppat_desc = Ppat_exception (rewritePpatOpen longidentOpen p)} - | _ -> pat - - let rec rewriteReasonFastPipe expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "|."}} as op, - [Asttypes.Nolabel, lhs; Nolabel, rhs] - ); pexp_attributes = subAttrs}, - args - ) -> - let rhsLoc = {rhs.pexp_loc with loc_end = expr.pexp_loc.loc_end} in - let newLhs = - let expr = rewriteReasonFastPipe lhs in - {expr with pexp_attributes = subAttrs} - in - let allArgs = - (Asttypes.Nolabel, newLhs)::[ - Asttypes.Nolabel, Ast_helper.Exp.apply ~loc:rhsLoc rhs args - ] - in - Ast_helper.Exp.apply ~attrs:expr.pexp_attributes ~loc:expr.pexp_loc op allArgs - | _ -> expr - - let makeReasonArityMapper ~forPrinter = - let open Ast_mapper in - { default_mapper with - expr = begin fun mapper expr -> - match expr with - (* Don't mind this case, Reason doesn't handle this. *) - (* | {pexp_desc = Pexp_variant (lbl, args); pexp_loc; pexp_attributes} -> *) - (* let newArgs = match args with *) - (* | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args-> *) - (* if forPrinter then args else Some sp *) - (* | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp *) - (* | _ -> args *) - (* in *) - (* default_mapper.expr mapper {pexp_desc=Pexp_variant(lbl, newArgs); pexp_loc; pexp_attributes} *) - | {pexp_desc=Pexp_construct(lid, args); pexp_loc; pexp_attributes} -> - let newArgs = match args with - | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args -> - if forPrinter then args else Some sp - | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp - | _ -> args - in - default_mapper.expr mapper { pexp_desc=Pexp_construct(lid, newArgs); pexp_loc; pexp_attributes} - | expr -> - default_mapper.expr mapper (rewriteReasonFastPipe expr) - end; - pat = begin fun mapper pattern -> - match pattern with - (* Don't mind this case, Reason doesn't handle this. *) - (* | {ppat_desc = Ppat_variant (lbl, args); ppat_loc; ppat_attributes} -> *) - (* let newArgs = match args with *) - (* | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> *) - (* if forPrinter then args else Some sp *) - (* | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp *) - (* | _ -> args *) - (* in *) - (* default_mapper.pat mapper {ppat_desc = Ppat_variant (lbl, newArgs); ppat_loc; ppat_attributes;} *) - | {ppat_desc=Ppat_construct(lid, args); - ppat_loc; - ppat_attributes} -> - let new_args = match args with - | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> - if forPrinter then args else Some sp - | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp - | _ -> args in - default_mapper.pat mapper { ppat_desc=Ppat_construct(lid, new_args); ppat_loc; ppat_attributes;} - | x -> default_mapper.pat mapper x - end; - } - - let escapeTemplateLiteral s = - let len = String.length s in - let b = Buffer.create len in - let i = ref 0 in - while !i < len do - let c = (String.get [@doesNotRaise]) s !i in - if c = '`' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '`'; - incr i; - ) else if c = '$' then ( - if !i + 1 < len then ( - let c2 = (String.get [@doesNotRaise]) s (!i + 1) in - if c2 = '{' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '$'; - Buffer.add_char b '{'; - ) else ( - Buffer.add_char b c; - Buffer.add_char b c2; - ); - i := !i + 2; - ) else ( - Buffer.add_char b c; - incr i - ) - ) else if c = '\\' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\'; - incr i; - ) else ( - Buffer.add_char b c; - incr i - ) - done; - Buffer.contents b - - let escapeStringContents s = - let len = String.length s in - let b = Buffer.create len in - - let i = ref 0 in - - while !i < len do - let c = String.unsafe_get s !i in - if c = '\\' then ( - incr i; - Buffer.add_char b c; - let c = String.unsafe_get s !i in - if !i < len then - let () = Buffer.add_char b c in - incr i - else - () - ) else if c = '"' then ( - Buffer.add_char b '\\'; - Buffer.add_char b c; - incr i; - ) else ( - Buffer.add_char b c; - incr i; - ) - done; - Buffer.contents b - - let looksLikeRecursiveTypeDeclaration typeDeclaration = - let open Parsetree in - let name = typeDeclaration.ptype_name.txt in - let rec checkKind kind = - match kind with - | Ptype_abstract | Ptype_open -> false - | Ptype_variant constructorDeclarations -> - List.exists checkConstructorDeclaration constructorDeclarations - | Ptype_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations - - and checkConstructorDeclaration constrDecl = - checkConstructorArguments constrDecl.pcd_args - || (match constrDecl.pcd_res with - | Some typexpr -> - checkTypExpr typexpr - | None -> false - ) - - and checkLabelDeclaration labelDeclaration = - checkTypExpr labelDeclaration.pld_type - - and checkConstructorArguments constrArg = - match constrArg with - | Pcstr_tuple types -> - List.exists checkTypExpr types - | Pcstr_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations - - and checkTypExpr typ = - match typ.ptyp_desc with - | Ptyp_any -> false - | Ptyp_var _ -> false - | Ptyp_object _ -> false - | Ptyp_class _ -> false - | Ptyp_package _ -> false - | Ptyp_extension _ -> false - | Ptyp_arrow (_lbl, typ1, typ2) -> - checkTypExpr typ1 || checkTypExpr typ2 - | Ptyp_tuple types -> - List.exists checkTypExpr types - | Ptyp_constr ({txt = longident}, types) -> - (match longident with - | Lident ident -> ident = name - | _ -> false - ) || - List.exists checkTypExpr types - | Ptyp_alias (typ, _) -> checkTypExpr typ - | Ptyp_variant (rowFields, _, _) -> - List.exists checkRowFields rowFields - | Ptyp_poly (_, typ) -> - checkTypExpr typ - - and checkRowFields rowField = - match rowField with - | Rtag (_, _, _, types) -> - List.exists checkTypExpr types - | Rinherit typexpr -> - checkTypExpr typexpr - in - checkKind typeDeclaration.ptype_kind - - - let filterReasonRawLiteral attrs = - List.filter (fun attr -> - match attr with - | ({Location.txt = ("reason.raw_literal")}, _) -> false - | _ -> true - ) attrs - - let stringLiteralMapper stringData = - let isSameLocation l1 l2 = - let open Location in - l1.loc_start.pos_cnum == l2.loc_start.pos_cnum - in - let remainingStringData = stringData in - let open Ast_mapper in - { default_mapper with - expr = (fun mapper expr -> - match expr.pexp_desc with - | Pexp_constant (Pconst_string (_txt, None)) -> - begin match - List.find_opt (fun (_stringData, stringLoc) -> - isSameLocation stringLoc expr.pexp_loc - ) remainingStringData - with - | Some(stringData, _) -> - let stringData = - let attr = List.find_opt (fun attr -> match attr with - | ({Location.txt = ("reason.raw_literal")}, _) -> true - | _ -> false - ) expr.pexp_attributes in - match attr with - | Some (_, PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (raw, _))}, _)}]) -> - raw - | _ -> (String.sub [@doesNotRaise]) stringData 1 (String.length stringData - 2) - in - {expr with - pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; - pexp_desc = Pexp_constant (Pconst_string (stringData, None)) - } - | None -> - default_mapper.expr mapper expr - end - | _ -> default_mapper.expr mapper expr - ) - } - - let normalize = - let open Ast_mapper in - { default_mapper with - attributes = (fun mapper attrs -> - attrs - |> List.filter (fun attr -> - match attr with - | ({Location.txt = ( - "reason.preserve_braces" - | "explicit_arity" - | "implicity_arity" - )}, _) -> false - | _ ->true - ) - |> default_mapper.attributes mapper - ); - pat = begin fun mapper p -> - match p.ppat_desc with - | Ppat_open ({txt = longidentOpen}, pattern) -> - let p = rewritePpatOpen longidentOpen pattern in - default_mapper.pat mapper p - | _ -> - default_mapper.pat mapper p - end; - expr = (fun mapper expr -> - match expr.pexp_desc with - | Pexp_constant (Pconst_string (txt, None)) -> - let raw = escapeStringContents txt in - let s = Parsetree.Pconst_string (raw, None) in - let expr = Ast_helper.Exp.constant - ~attrs:expr.pexp_attributes - ~loc:expr.pexp_loc s - in - expr - | Pexp_constant (Pconst_string (txt, tag)) -> - let s = Parsetree.Pconst_string ((escapeTemplateLiteral txt), tag) in - Ast_helper.Exp.constant - ~attrs:(mapper.attributes mapper expr.pexp_attributes) - ~loc:expr.pexp_loc - s - | Pexp_function cases -> - let loc = match (cases, List.rev cases) with - | (first::_), (last::_) -> - {first.pc_lhs.ppat_loc with loc_end = last.pc_rhs.pexp_loc.loc_end} - | _ -> Location.none - in - Ast_helper.Exp.fun_ ~loc - Asttypes.Nolabel None (Ast_helper.Pat.var (Location.mknoloc "x")) - (Ast_helper.Exp.match_ ~loc - (Ast_helper.Exp.ident (Location.mknoloc (Longident.Lident "x"))) - (default_mapper.cases mapper cases) - ) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "!"}}, - [Asttypes.Nolabel, operand] - ) -> - (* turn `!foo` into `foo.contents` *) - Ast_helper.Exp.field ~loc:expr.pexp_loc ~attrs:expr.pexp_attributes - operand - (Location.mknoloc (Longident.Lident "contents")) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}} as op, - [Asttypes.Nolabel, lhs; Nolabel, ({pexp_desc = Pexp_constant (Pconst_string (txt, None))} as stringExpr)] - ) -> - let ident = Ast_helper.Exp.ident ~loc:stringExpr.pexp_loc - (Location.mkloc (Longident.Lident txt) stringExpr.pexp_loc) - in - Ast_helper.Exp.apply ~loc:expr.pexp_loc ~attrs:expr.pexp_attributes - op [Asttypes.Nolabel, lhs; Nolabel, ident] - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "@@"}}, - [Asttypes.Nolabel, callExpr; Nolabel, argExpr] - ) -> - Ast_helper.Exp.apply (mapper.expr mapper callExpr) [ - Asttypes.Nolabel, mapper.expr mapper argExpr - ] - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "@"}}, - [Nolabel, arg1; Nolabel, arg2] - ) -> - let listConcat = Longident.Ldot (Longident.Lident "List", "append") in - Ast_helper.Exp.apply - (Ast_helper.Exp.ident (Location.mknoloc listConcat)) - [Nolabel, mapper.expr mapper arg1; Nolabel, mapper.expr mapper arg2] - | Pexp_match ( - condition, - [ - {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "true"}, None)}; pc_rhs = thenExpr }; - {pc_lhs = {ppat_desc = Ppat_construct ({txt = Longident.Lident "false"}, None)}; pc_rhs = elseExpr }; - ] - ) -> - let ternaryMarker = (Location.mknoloc "res.ternary", Parsetree.PStr []) in - Ast_helper.Exp.ifthenelse - ~loc:expr.pexp_loc - ~attrs:(ternaryMarker::expr.pexp_attributes) - (default_mapper.expr mapper condition) - (default_mapper.expr mapper thenExpr) - (Some (default_mapper.expr mapper elseExpr)) - | _ -> default_mapper.expr mapper expr - ); - structure_item = begin fun mapper structureItem -> - match structureItem.pstr_desc with - (* heuristic: if we have multiple type declarations, mark them recursive *) - | Pstr_type (recFlag, typeDeclarations) -> - let flag = match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - {structureItem with pstr_desc = Pstr_type ( - flag, - List.map (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration - ) typeDeclarations - )} - | _ -> default_mapper.structure_item mapper structureItem - end; - signature_item = begin fun mapper signatureItem -> - match signatureItem.psig_desc with - (* heuristic: if we have multiple type declarations, mark them recursive *) - | Psig_type (recFlag, typeDeclarations) -> - let flag = match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - {signatureItem with psig_desc = Psig_type ( - flag, - List.map (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration - ) typeDeclarations - )} - | _ -> default_mapper.signature_item mapper signatureItem - end; - value_binding = begin fun mapper vb -> - match vb with - | { - pvb_pat = {ppat_desc = Ppat_var _} as pat; - pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } - } when expr_loc.loc_ghost -> - (* let t: t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end} - pat typ in - {vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} - | { - pvb_pat = {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], _)})} ; - pvb_expr = {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ) } - } when expr_loc.loc_ghost -> - (* let t: . t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end} - pat typ in - {vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes} - | _ -> default_mapper.value_binding mapper vb - end; - } - - let normalizeReasonArityStructure ~forPrinter s = - let mapper = makeReasonArityMapper ~forPrinter in - mapper.Ast_mapper.structure mapper s - - let normalizeReasonAritySignature ~forPrinter s = - let mapper = makeReasonArityMapper ~forPrinter in - mapper.Ast_mapper.signature mapper s - - let structure s = normalize.Ast_mapper.structure normalize s - let signature s = normalize.Ast_mapper.signature normalize s - - let replaceStringLiteralStructure stringData structure = - let mapper = stringLiteralMapper stringData in - mapper.Ast_mapper.structure mapper structure - - let replaceStringLiteralSignature stringData signature = - let mapper = stringLiteralMapper stringData in - mapper.Ast_mapper.signature mapper signature -end - -module OcamlParser = Parser - -module Parser = struct - type mode = ParseForTypeChecker | Default - - type regionStatus = Report | Silent - - type t = { - mode: mode; - mutable scanner: Scanner.t; - mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; - mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; - mutable diagnostics: Diagnostics.t list; - mutable comments: Comment.t list; - mutable regions: regionStatus ref list; - } - - let err ?startPos ?endPos p error = - let d = Diagnostics.make - ~filename:p.scanner.filename - ~startPos:(match startPos with | Some pos -> pos | None -> p.startPos) - ~endPos:(match endPos with | Some pos -> pos | None -> p.endPos) - error - in - try - if (!(List.hd p.regions) = Report) then ( - p.diagnostics <- d::p.diagnostics; - List.hd p.regions := Silent - ) - with Failure _ -> () - - let beginRegion p = - p.regions <- ref Report :: p.regions - let endRegion p = - try p.regions <- List.tl p.regions with Failure _ -> () - - (* Advance to the next non-comment token and store any encountered comment - * in the parser's state. Every comment contains the end position of it's - * previous token to facilite comment interleaving *) - let rec next ?prevEndPos p = - let prevEndPos = match prevEndPos with Some pos -> pos | None -> p.endPos in - let (startPos, endPos, token) = Scanner.scan p.scanner in - match token with - | Comment c -> - Comment.setPrevTokEndPos c p.endPos; - p.comments <- c::p.comments; - p.prevEndPos <- p.endPos; - p.endPos <- endPos; - next ~prevEndPos p - | _ -> - p.token <- token; - (* p.prevEndPos <- prevEndPos; *) - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos - - let checkProgress ~prevEndPos ~result p = - if p.endPos == prevEndPos - then None - else Some result - - let make ?(mode=ParseForTypeChecker) src filename = - let scanner = Scanner.make (Bytes.of_string src) filename in - let parserState = { - mode; - scanner; - token = Token.Eof; - startPos = Lexing.dummy_pos; - prevEndPos = Lexing.dummy_pos; - endPos = Lexing.dummy_pos; - breadcrumbs = []; - errors = []; - diagnostics = []; - comments = []; - regions = [ref Report]; - } in - parserState.scanner.err <- (fun ~startPos ~endPos error -> - let diagnostic = Diagnostics.make - ~filename - ~startPos - ~endPos - error - in - parserState.diagnostics <- diagnostic::parserState.diagnostics - ); - next parserState; - parserState - - let leaveBreadcrumb p circumstance = - let crumb = (circumstance, p.startPos) in - p.breadcrumbs <- crumb::p.breadcrumbs - - let eatBreadcrumb p = - match p.breadcrumbs with - | [] -> () - | _::crumbs -> p.breadcrumbs <- crumbs - - let optional p token = - if p.token = token then - let () = next p in true - else - false - - let expect ?grammar token p = - if p.token = token then - next p - else - let error = Diagnostics.expected ?grammar p.prevEndPos token in - err ~startPos:p.prevEndPos p error - - (* Don't use immutable copies here, it trashes certain heuristics - * in the ocaml compiler, resulting in massive slowdowns of the parser *) - let lookahead p callback = - let err = p.scanner.err in - let ch = p.scanner.ch in - let offset = p.scanner.offset in - let rdOffset = p.scanner.rdOffset in - let lineOffset = p.scanner.lineOffset in - let lnum = p.scanner.lnum in - let mode = p.scanner.mode in - let token = p.token in - let startPos = p.startPos in - let endPos = p.endPos in - let prevEndPos = p.prevEndPos in - let breadcrumbs = p.breadcrumbs in - let errors = p.errors in - let diagnostics = p.diagnostics in - let comments = p.comments in - - let res = callback p in - - p.scanner.err <- err; - p.scanner.ch <- ch; - p.scanner.offset <- offset; - p.scanner.rdOffset <- rdOffset; - p.scanner.lineOffset <- lineOffset; - p.scanner.lnum <- lnum; - p.scanner.mode <- mode; - p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; - p.breadcrumbs <- breadcrumbs; - p.errors <- errors; - p.diagnostics <- diagnostics; - p.comments <- comments; - - res -end - -module NapkinScript = struct - let mkLoc startLoc endLoc = Location.{ - loc_start = startLoc; - loc_end = endLoc; - loc_ghost = false; - } - - - module Recover = struct - type action = unit option (* None is abort, Some () is retry *) - - let defaultExpr () = - let id = Location.mknoloc "napkinscript.exprhole" in - Ast_helper.Exp.mk (Pexp_extension (id, PStr [])) - - let defaultType () = - let id = Location.mknoloc "napkinscript.typehole" in - Ast_helper.Typ.extension (id, PStr []) - - let defaultPattern () = - let id = Location.mknoloc "napkinscript.patternhole" in - Ast_helper.Pat.extension (id, PStr []) - (* Ast_helper.Pat.any () *) - - let defaultModuleExpr () = Ast_helper.Mod.structure [] - let defaultModuleType () = Ast_helper.Mty.signature [] - - let recoverEqualGreater p = - Parser.expect EqualGreater p; - match p.Parser.token with - | MinusGreater -> Parser.next p - | _ -> () - - let shouldAbortListParse p = - let rec check breadcrumbs = - match breadcrumbs with - | [] -> false - | (grammar, _)::rest -> - if Grammar.isPartOfList grammar p.Parser.token then - true - else - check rest - in - check p.breadcrumbs - end - - module ErrorMessages = struct - let listPatternSpread = "List pattern matches only supports one `...` spread, at the end. -Explanation: a list spread at the tail is efficient, but a spread in the middle would create new list[s]; out of performance concern, our pattern matching currently guarantees to never create new intermediate data." - - let recordPatternSpread = "Record's `...` spread is not supported in pattern matches. -Explanation: you can't collect a subset of a record's field into its own record, since a record needs an explicit declaration and that subset wouldn't have one. -Solution: you need to pull out each field you want explicitly." - - let recordPatternUnderscore = "Record patterns only support one `_`, at the end." - [@@live] - - let arrayPatternSpread = "Array's `...` spread is not supported in pattern matches. -Explanation: such spread would create a subarray; out of performance concern, our pattern matching currently guarantees to never create new intermediate data. -Solution: if it's to validate the first few elements, use a `when` clause + Array size check + `get` checks on the current pattern. If it's to obtain a subarray, use `Array.sub` or `Belt.Array.slice`." - - let arrayExprSpread = "Arrays can't use the `...` spread currently. Please use `concat` or other Array helpers." - - let recordExprSpread = "Records can only have one `...` spread, at the beginning. -Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway." - - let listExprSpread = "Lists can only have one `...` spread, and at the end. -Explanation: lists are singly-linked list, where a node contains a value and points to the next node. `list[a, ...bc]` efficiently creates a new item and links `bc` as its next nodes. `[...bc, a]` would be expensive, as it'd need to traverse `bc` and prepend each item to `a` one by one. We therefore disallow such syntax sugar. -Solution: directly use `concat`." - - let variantIdent = "A polymorphic variant (e.g. #id) must start with an alphabetical letter." -end - - - let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) - let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr []) - let ternaryAttr = (Location.mknoloc "res.ternary", Parsetree.PStr []) - let makeBracesAttr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr []) - - type typDefOrExt = - | TypeDef of {recFlag: Asttypes.rec_flag; types: Parsetree.type_declaration list} - | TypeExt of Parsetree.type_extension - - type labelledParameter = - | TermParameter of - {uncurried: bool; attrs: Parsetree.attributes; label: Asttypes.arg_label; expr: Parsetree.expression option; - pat: Parsetree.pattern; pos: Lexing.position} - | TypeParameter of {uncurried: bool; attrs: Parsetree.attributes; locs: string Location.loc list; pos: Lexing.position} - - type recordPatternItem = - | PatUnderscore - | PatField of (Ast_helper.lid * Parsetree.pattern) - - type context = - | OrdinaryExpr - | TernaryTrueBranchExpr - | WhenExpr - - let getClosingToken = function - | Token.Lparen -> Token.Rparen - | Lbrace -> Rbrace - | Lbracket -> Rbracket - | _ -> assert false - - let rec goToClosing closingToken state = - match (state.Parser.token, closingToken) with - | (Rparen, Token.Rparen) | (Rbrace, Rbrace) | (Rbracket, Rbracket) -> - Parser.next state; - () - | (Token.Lbracket | Lparen | Lbrace) as t, _ -> - Parser.next state; - goToClosing (getClosingToken t) state; - goToClosing closingToken state - | ((Rparen | Token.Rbrace | Rbracket | Eof), _) -> - () (* TODO: how do report errors here? *) - | _ -> - Parser.next state; - goToClosing closingToken state - - (* Madness *) - let isEs6ArrowExpression ~inTernary p = - Parser.lookahead p (fun state -> - match state.Parser.token with - | Lident _ | List | Underscore -> - Parser.next state; - begin match state.Parser.token with - (* Don't think that this valid - * Imagine: let x = (a: int) - * This is a parenthesized expression with a type constraint, wait for - * the arrow *) - (* | Colon when not inTernary -> true *) - | EqualGreater -> true - | _ -> false - end - | Lparen -> - let prevEndPos = state.prevEndPos in - Parser.next state; - begin match state.token with - | Rparen -> - Parser.next state; - begin match state.Parser.token with - | Colon when not inTernary -> true - | EqualGreater -> true - | _ -> false - end - | Dot (* uncurried *) -> true - | Tilde -> true - | Backtick -> false (* (` always indicates the start of an expr, can't be es6 parameter *) - | _ -> - goToClosing Rparen state; - begin match state.Parser.token with - | EqualGreater -> true - (* | Lbrace TODO: detect missing =>, is this possible? *) - | Colon when not inTernary -> true - | Rparen -> - (* imagine having something as : - * switch colour { - * | Red - * when l == l' - * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) - * We'll arrive at the outer rparen just before the =>. - * This is not an es6 arrow. - * *) - false - | _ -> - Parser.next state; - (* error recovery, peek at the next token, - * (elements, providerId] => { - * in the example above, we have an unbalanced ] here - *) - begin match state.Parser.token with - | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum -> true - | _ -> false - end - end - end - | _ -> false) - - - let isEs6ArrowFunctor p = - Parser.lookahead p (fun state -> - match state.Parser.token with - (* | Uident _ | Underscore -> *) - (* Parser.next state; *) - (* begin match state.Parser.token with *) - (* | EqualGreater -> true *) - (* | _ -> false *) - (* end *) - | Lparen -> - Parser.next state; - begin match state.token with - | Rparen -> - Parser.next state; - begin match state.token with - | Colon | EqualGreater -> true - | _ -> false - end - | _ -> - goToClosing Rparen state; - begin match state.Parser.token with - | EqualGreater | Lbrace -> true - | Colon -> true - | _ -> false - end - end - | _ -> false - ) - - let isEs6ArrowType p = - Parser.lookahead p (fun state -> - match state.Parser.token with - | Lparen -> - Parser.next state; - begin match state.Parser.token with - | Rparen -> - Parser.next state; - begin match state.Parser.token with - | EqualGreater -> true - | _ -> false - end - | Tilde | Dot -> true - | _ -> - goToClosing Rparen state; - begin match state.Parser.token with - | EqualGreater -> true - | _ -> false - end - end - | Tilde -> true - | _ -> false - ) - - let buildLongident words = match List.rev words with - | [] -> assert false - | hd::tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl - - let makeInfixOperator p token startPos endPos = - let stringifiedToken = - if token = Token.MinusGreater then "|." - else if token = Token.PlusPlus then "^" - else if token = Token.BangEqual then "<>" - else if token = Token.BangEqualEqual then "!=" - else if token = Token.Equal then ( - (* TODO: could have a totally different meaning like x->fooSet(y)*) - Parser.err ~startPos ~endPos p ( - Diagnostics.message "Did you mean `==` here?" - ); - "=" - ) else if token = Token.EqualEqual then "=" - else if token = Token.EqualEqualEqual then "==" - else Token.toString token - in - let loc = mkLoc startPos endPos in - let operator = Location.mkloc - (Longident.Lident stringifiedToken) loc - in - Ast_helper.Exp.ident ~loc operator - - let negateString s = - if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' - then (String.sub [@doesNotRaise]) s 1 (String.length s - 1) - else "-" ^ s - - let makeUnaryExpr startPos tokenEnd token operand = - match token, operand.Parsetree.pexp_desc with - | (Token.Plus | PlusDot), Pexp_constant((Pconst_integer _ | Pconst_float _)) -> - operand - | Minus, Pexp_constant(Pconst_integer (n,m)) -> - {operand with pexp_desc = Pexp_constant(Pconst_integer (negateString n,m))} - | (Minus | MinusDot), Pexp_constant(Pconst_float (n,m)) -> - {operand with pexp_desc = Pexp_constant(Pconst_float (negateString n,m))} - | (Token.Plus | PlusDot | Minus | MinusDot ), _ -> - let tokenLoc = mkLoc startPos tokenEnd in - let operator = "~" ^ Token.toString token in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident operator) tokenLoc)) - [Nolabel, operand] - | Token.Bang, _ -> - let tokenLoc = mkLoc startPos tokenEnd in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident "not") tokenLoc)) - [Nolabel, operand] - | _ -> - operand - - let makeListExpression loc seq extOpt = - let rec handleSeq = function - | [] -> - begin match extOpt with - | Some ext -> ext - | None -> - let loc = {loc with Location.loc_ghost = true} in - let nil = Location.mkloc (Longident.Lident "[]") loc in - Ast_helper.Exp.construct ~loc nil None - end - | e1 :: el -> - let exp_el = handleSeq el in - let loc = mkLoc - e1.Parsetree.pexp_loc.Location.loc_start - exp_el.pexp_loc.loc_end - in - let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "::") loc) - (Some arg) - in - let expr = handleSeq seq in - {expr with pexp_loc = loc} - - let makeListPattern loc seq ext_opt = - let rec handle_seq = function - [] -> - let base_case = match ext_opt with - | Some ext -> - ext - | None -> - let loc = { loc with Location.loc_ghost = true} in - let nil = { Location.txt = Longident.Lident "[]"; loc } in - Ast_helper.Pat.construct ~loc nil None - in - base_case - | p1 :: pl -> - let pat_pl = handle_seq pl in - let loc = - mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in - let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - Ast_helper.Pat.mk ~loc (Ppat_construct(Location.mkloc (Longident.Lident "::") loc, Some arg)) - in - handle_seq seq - - - (* {"foo": bar} -> Js.t({. foo: bar}) - * {.. "foo": bar} -> Js.t({.. foo: bar}) - * {..} -> Js.t({..}) *) - let makeBsObjType ~attrs ~loc ~closed rows = - let obj = Ast_helper.Typ.object_ ~loc rows closed in - let jsDotTCtor = - Location.mkloc (Longident.Ldot (Longident.Lident "Js", "t")) loc - in - Ast_helper.Typ.constr ~loc ~attrs jsDotTCtor [obj] - - (* TODO: diagnostic reporting *) - let lidentOfPath longident = - match Longident.flatten longident |> List.rev with - | [] -> "" - | ident::_ -> ident - - let makeNewtypes ~attrs ~loc newtypes exp = - let expr = List.fold_right (fun newtype exp -> - Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp)) - ) newtypes exp - in {expr with pexp_attributes = attrs} - - (* locally abstract types syntax sugar - * Transforms - * let f: type t u v. = (foo : list) => ... - * into - * let f = (type t u v. foo : list) => ... - *) - let wrapTypeAnnotation ~loc newtypes core_type body = - let exp = makeNewtypes ~attrs:[] ~loc newtypes - (Ast_helper.Exp.constraint_ ~loc body core_type) - in - let typ = Ast_helper.Typ.poly ~loc newtypes - (Ast_helper.Typ.varify_constructors newtypes core_type) - in - (exp, typ) - - (** - * process the occurrence of _ in the arguments of a function application - * replace _ with a new variable, currently __x, in the arguments - * return a wrapping function that wraps ((__x) => ...) around an expression - * e.g. foo(_, 3) becomes (__x) => foo(__x, 3) - *) - let processUnderscoreApplication args = - let open Parsetree in - let exp_question = ref None in - let hidden_var = "__x" in - let check_arg ((lab, exp) as arg) = - match exp.pexp_desc with - | Pexp_ident ({ txt = Lident "_"} as id) -> - let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in - let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in - exp_question := Some new_exp; - (lab, new_exp) - | _ -> - arg - in - let args = List.map check_arg args in - let wrap exp_apply = - match !exp_question with - | Some {pexp_loc=loc} -> - let pattern = Ast_helper.Pat.mk (Ppat_var (Location.mkloc hidden_var loc)) ~loc in - Ast_helper.Exp.mk (Pexp_fun (Nolabel, None, pattern, exp_apply)) ~loc - | None -> - exp_apply - in - (args, wrap) - - let rec parseLident p = - let recoverLident p = - if ( - Token.isKeyword p.Parser.token && - p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum - ) - then ( - Parser.err p (Diagnostics.lident p.Parser.token); - Parser.next p; - None - ) else ( - let rec loop p = - if not (Recover.shouldAbortListParse p) - then begin - Parser.next p; - loop p - end - in - Parser.next p; - loop p; - match p.Parser.token with - | Lident _ -> Some () - | _ -> None - ) - in - let startPos = p.Parser.startPos in - match p.Parser.token with - | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) - | List -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - ("list", loc) - | _ -> - begin match recoverLident p with - | Some () -> - parseLident p - | None -> - ("_", mkLoc startPos p.prevEndPos) - end - - let parseIdent ~msg ~startPos p = - match p.Parser.token with - | Lident ident - | Uident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) - | List -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - ("list", loc) - | _token -> - Parser.err p (Diagnostics.message msg); - Parser.next p; - ("_", mkLoc startPos p.prevEndPos) - - let parseHashIdent ~startPos p = - Parser.expect Hash p; - parseIdent ~startPos ~msg:ErrorMessages.variantIdent p - - (* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) - let parseValuePath p = - let startPos = p.Parser.startPos in - let rec aux p path = - match p.Parser.token with - | List -> Longident.Ldot(path, "list") - | Lident ident -> Longident.Ldot(path, ident) - | Uident uident -> - Parser.next p; - Parser.expect Dot p; - aux p (Ldot (path, uident)) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Longident.Lident "_" - in - let ident = match p.Parser.token with - | List -> Longident.Lident "list" - | Lident ident -> Longident.Lident ident - | Uident ident -> - Parser.next p; - Parser.expect Dot p; - aux p (Lident ident) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Longident.Lident "_" - in - Parser.next p; - Location.mkloc ident (mkLoc startPos p.prevEndPos) - - let parseValuePathTail p startPos ident = - let rec loop p path = - match p.Parser.token with - | Lident ident -> - Parser.next p; - Location.mkloc (Longident.Ldot(path, ident)) (mkLoc startPos p.prevEndPos) - | List -> - Parser.next p; - Location.mkloc (Longident.Ldot(path, "list")) (mkLoc startPos p.prevEndPos) - | Uident ident -> - Parser.next p; - Parser.expect Dot p; - loop p (Longident.Ldot (path, ident)) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mknoloc path - in - loop p ident - - let parseModuleLongIdentTail ~lowercase p startPos ident = - let rec loop p acc = - match p.Parser.token with - | List when lowercase -> - Parser.next p; - let lident = (Longident.Ldot (acc, "list")) in - Location.mkloc lident (mkLoc startPos p.prevEndPos) - | Lident ident when lowercase -> - Parser.next p; - let lident = (Longident.Ldot (acc, ident)) in - Location.mkloc lident (mkLoc startPos p.prevEndPos) - | Uident ident -> - Parser.next p; - let endPos = p.prevEndPos in - let lident = (Longident.Ldot (acc, ident)) in - begin match p.Parser.token with - | Dot -> - Parser.next p; - loop p lident - | _ -> Location.mkloc lident (mkLoc startPos endPos) - end - | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc acc (mkLoc startPos p.prevEndPos) - in - loop p ident - - (* Parses module identifiers: - Foo - Foo.Bar *) - let parseModuleLongIdent ~lowercase p = - (* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *) - let startPos = p.Parser.startPos in - let moduleIdent = match p.Parser.token with - | List when lowercase -> - let loc = mkLoc startPos p.endPos in - Parser.next p; - Location.mkloc (Longident.Lident "list") loc - | Lident ident when lowercase -> - let loc = mkLoc startPos p.endPos in - let lident = Longident.Lident ident in - Parser.next p; - Location.mkloc lident loc - | Uident ident -> - let lident = Longident.Lident ident in - let endPos = p.endPos in - Parser.next p; - begin match p.Parser.token with - | Dot -> - Parser.next p; - parseModuleLongIdentTail ~lowercase p startPos lident - | _ -> Location.mkloc lident (mkLoc startPos endPos) - end - | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) - in - (* Parser.eatBreadcrumb p; *) - moduleIdent - - (* `window.location` or `Math` or `Foo.Bar` *) - let parseIdentPath p = - let rec loop p acc = - match p.Parser.token with - | Uident ident | Lident ident -> - Parser.next p; - let lident = (Longident.Ldot (acc, ident)) in - begin match p.Parser.token with - | Dot -> - Parser.next p; - loop p lident - | _ -> lident - end - | _t -> acc - in - match p.Parser.token with - | Lident ident | Uident ident -> - Parser.next p; - begin match p.Parser.token with - | Dot -> - Parser.next p; - loop p (Longident.Lident ident) - | _ -> Longident.Lident ident - end - | _ -> - Longident.Lident "_" - - let verifyJsxOpeningClosingName p nameExpr = - let closing = match p.Parser.token with - | Lident lident -> Parser.next p; Longident.Lident lident - | Uident _ -> - (parseModuleLongIdent ~lowercase:false p).txt - | _ -> Longident.Lident "" - in - match nameExpr.Parsetree.pexp_desc with - | Pexp_ident openingIdent -> - let opening = - let withoutCreateElement = - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") - in - match (Longident.unflatten withoutCreateElement) with - | Some li -> li - | None -> Longident.Lident "" - in - opening = closing - | _ -> assert false - - let string_of_pexp_ident nameExpr = - match nameExpr.Parsetree.pexp_desc with - | Pexp_ident openingIdent -> - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") - |> String.concat "." - | _ -> "" - - (* open-def ::= - * | open module-path - * | open! module-path *) - let parseOpenDescription ~attrs p = - Parser.leaveBreadcrumb p Grammar.OpenDescription; - let startPos = p.Parser.startPos in - Parser.expect Open p; - let override = if Parser.optional p Token.Bang then - Asttypes.Override - else - Asttypes.Fresh - in - let modident = parseModuleLongIdent ~lowercase:false p in - let loc = mkLoc startPos p.prevEndPos in - Parser.eatBreadcrumb p; - Ast_helper.Opn.mk ~loc ~attrs ~override modident - - let hexValue x = - match x with - | '0' .. '9' -> - (Char.code x) - 48 - | 'A' .. 'Z' -> - (Char.code x) - 55 - | 'a' .. 'z' -> - (Char.code x) - 97 - | _ -> 16 - - let parseStringLiteral s = - let len = String.length s in - let b = Buffer.create (String.length s) in - - let rec loop i = - if i = len then - () - else - let c = String.unsafe_get s i in - match c with - | '\\' as c -> - let nextIx = i + 1 in - if nextIx < len then - let nextChar = String.unsafe_get s nextIx in - begin match nextChar with - | 'n' -> - Buffer.add_char b '\010'; - loop (nextIx + 1) - | 'r' -> - Buffer.add_char b '\013'; - loop (nextIx + 1) - | 'b' -> - Buffer.add_char b '\008'; - loop (nextIx + 1) - | 't' -> - Buffer.add_char b '\009'; - loop (nextIx + 1) - | '\\' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | ' ' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | '\'' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | '\"' as c -> - Buffer.add_char b c; - loop (nextIx + 1) - | '0' .. '9' -> - if nextIx + 2 < len then - let c0 = nextChar in - let c1 = (String.unsafe_get s (nextIx + 1)) in - let c2 = (String.unsafe_get s (nextIx + 2)) in - let c = - 100 * (Char.code c0 - 48) + - 10 * (Char.code c1 - 48) + - (Char.code c2 - 48) - in - if (c < 0 || c > 255) then ( - Buffer.add_char b '\\'; - Buffer.add_char b c0; - Buffer.add_char b c1; - Buffer.add_char b c2; - loop (nextIx + 3) - ) else ( - Buffer.add_char b (Char.unsafe_chr c); - loop (nextIx + 3) - ) - else ( - Buffer.add_char b '\\'; - Buffer.add_char b nextChar; - loop (nextIx + 1) - ) - | 'o' -> - if nextIx + 3 < len then - let c0 = (String.unsafe_get s (nextIx + 1)) in - let c1 = (String.unsafe_get s (nextIx + 2)) in - let c2 = (String.unsafe_get s (nextIx + 3)) in - let c = - 64 * (Char.code c0 - 48) + - 8 * (Char.code c1 - 48) + - (Char.code c2 - 48) - in - if (c < 0 || c > 255) then ( - Buffer.add_char b '\\'; - Buffer.add_char b '0'; - Buffer.add_char b c0; - Buffer.add_char b c1; - Buffer.add_char b c2; - loop (nextIx + 4) - ) else ( - Buffer.add_char b (Char.unsafe_chr c); - loop (nextIx + 4) - ) - else ( - Buffer.add_char b '\\'; - Buffer.add_char b nextChar; - loop (nextIx + 1) - ) - | 'x' as c -> - if nextIx + 2 < len then - let c0 = (String.unsafe_get s (nextIx + 1)) in - let c1 = (String.unsafe_get s (nextIx + 2)) in - let c = (16 * (hexValue c0)) + (hexValue c1) in - if (c < 0 || c > 255) then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'x'; - Buffer.add_char b c0; - Buffer.add_char b c1; - loop (nextIx + 3) - ) else ( - Buffer.add_char b (Char.unsafe_chr c); - loop (nextIx + 3) - ) - else ( - Buffer.add_char b '\\'; - Buffer.add_char b c; - loop (nextIx + 2) - ) - | _ -> - Buffer.add_char b c; - Buffer.add_char b nextChar; - loop (nextIx + 1) - end - else ( - Buffer.add_char b c; - () - ) - | c -> - Buffer.add_char b c; - loop (i + 1) - in - loop 0; - Buffer.contents b - - let parseTemplateStringLiteral s = - let len = String.length s in - let b = Buffer.create len in - - let rec loop i = - if i < len then - let c = String.unsafe_get s i in - match c with - | '\\' as c -> - if i + 1 < len then - let nextChar = String.unsafe_get s (i + 1) in - begin match nextChar with - | '\\' as c -> - Buffer.add_char b c; - loop (i + 2) - | '$' as c -> - Buffer.add_char b c; - loop (i + 2) - | '`' as c -> - Buffer.add_char b c; - loop (i + 2) - | c -> - Buffer.add_char b '\\'; - Buffer.add_char b c; - loop (i + 2) - end - else ( - Buffer.add_char b c - ) - - | c -> - Buffer.add_char b c; - loop (i + 1) - - else - () - in - loop 0; - Buffer.contents b - - (* constant ::= integer-literal *) - (* ∣ float-literal *) - (* ∣ string-literal *) - let parseConstant p = - let isNegative = match p.Parser.token with - | Token.Minus -> Parser.next p; true - | Plus -> Parser.next p; false - | _ -> false - in - let constant = match p.Parser.token with - | Int {i; suffix} -> - let intTxt = if isNegative then "-" ^ i else i in - Parsetree.Pconst_integer (intTxt, suffix) - | Float {f; suffix} -> - let floatTxt = if isNegative then "-" ^ f else f in - Parsetree.Pconst_float (floatTxt, suffix) - | String s -> - let txt = if p.mode = ParseForTypeChecker then - parseStringLiteral s - else - s - in - Pconst_string(txt, None) - | Character c -> Pconst_char c - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Pconst_string("", None) - in - Parser.next p; - constant - - let parseCommaDelimitedRegion p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> - begin match p.Parser.token with - | Comma -> - Parser.next p; - loop (node::nodes) - | token when token = closing || token = Eof -> - List.rev (node::nodes) - | _ -> - if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then - Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node::nodes) - end - | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then - List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes - ); - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - - let parseCommaDelimitedReversedList p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> - begin match p.Parser.token with - | Comma -> - Parser.next p; - loop (node::nodes) - | token when token = closing || token = Eof -> - (node::nodes) - | _ -> - if not (p.token = Eof || p.token = closing || Recover.shouldAbortListParse p) then - Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node::nodes) - end - | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p then - nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes - ); - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - - let parseDelimitedRegion p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> - loop (node::nodes) - | None -> - if ( - p.Parser.token = Token.Eof || - p.token = closing || - Recover.shouldAbortListParse p - ) then - List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes - ) - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - - let parseRegion p ~grammar ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> - loop (node::nodes) - | None -> - if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then - List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes - ) - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - - (* let-binding ::= pattern = expr *) - (* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr *) - (* ∣ value-name : poly-typexpr = expr *) - - (* pattern ::= value-name *) - (* ∣ _ *) - (* ∣ constant *) - (* ∣ pattern as value-name *) - (* ∣ ( pattern ) *) - (* ∣ ( pattern : typexpr ) *) - (* ∣ pattern | pattern *) - (* ∣ constr pattern *) - (* ∣ #variant variant-pattern *) - (* ∣ ##type *) - (* ∣ / pattern { , pattern }+ / *) - (* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } *) - (* ∣ [ pattern { ; pattern } [ ; ] ] *) - (* ∣ pattern :: pattern *) - (* ∣ [| pattern { ; pattern } [ ; ] |] *) - (* ∣ char-literal .. char-literal *) - (* ∣ exception pattern *) - let rec parsePattern ?(alias=true) ?(or_=true) p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - let pat = match p.Parser.token with - | (True | False) as token -> - let endPos = p.endPos in - Parser.next p; - let loc = mkLoc startPos endPos in - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) None - | Int _ | String _ | Float _ | Character _ | Minus | Plus -> - let c = parseConstant p in - begin match p.token with - | DotDot -> - Parser.next p; - let c2 = parseConstant p in - Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 - | _ -> - Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c - end - | Lparen -> - Parser.next p; - begin match p.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct ~loc lid None - | _ -> - let pat = parseConstrainedPattern p in - begin match p.token with - | Comma -> - Parser.next p; - parseTuplePattern ~attrs ~first:pat ~startPos p - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - {pat with ppat_loc = loc} - end - end - | Lbracket -> - parseArrayPattern ~attrs p - | Lbrace -> - parseRecordPattern ~attrs p - | Underscore -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - Ast_helper.Pat.any ~loc ~attrs () - | Lident ident -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc) - | Uident _ -> - let constr = parseModuleLongIdent ~lowercase:false p in - begin match p.Parser.token with - | Lparen -> - parseConstructorPatternArgs p constr startPos attrs - | _ -> - Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None - end - | Hash -> - let (ident, loc) = parseHashIdent ~startPos p in - begin match p.Parser.token with - | Lparen -> - parseVariantPatternArgs p ident startPos attrs - | _ -> - Ast_helper.Pat.variant ~loc ~attrs ident None - end - | HashHash -> - Parser.next p; - let ident = parseValuePath p in - let loc = mkLoc startPos ident.loc.loc_end in - Ast_helper.Pat.type_ ~loc ~attrs ident - | Exception -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.exception_ ~loc ~attrs pat - | Lazy -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.lazy_ ~loc ~attrs pat - | List -> - Parser.next p; - begin match p.token with - | Lbracket -> - parseListPattern ~startPos ~attrs p - | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.var ~loc ~attrs (Location.mkloc "list" loc) - end - | Module -> - parseModulePattern ~attrs p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.extension ~loc ~attrs extension - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart with - | None -> - Recover.defaultPattern() - | Some () -> - parsePattern p - end - in - let pat = if alias then parseAliasPattern ~attrs pat p else pat in - if or_ then parseOrPattern pat p else pat - - and skipTokensAndMaybeRetry p ~isStartOfGrammar = - if Token.isKeyword p.Parser.token - && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum - then ( - Parser.next p; - None - ) else ( - if Recover.shouldAbortListParse p then - begin - if isStartOfGrammar p.Parser.token then - begin - Parser.next p; - Some () - end - else - None - end - else - begin - Parser.next p; - let rec loop p = - if not (Recover.shouldAbortListParse p) - then begin - Parser.next p; - loop p - end in - loop p; - if isStartOfGrammar p.Parser.token then - Some () - else - None - end - ) - - (* alias ::= pattern as lident *) - and parseAliasPattern ~attrs pattern p = - match p.Parser.token with - | As -> - Parser.next p; - let (name, loc) = parseLident p in - let name = Location.mkloc name loc in - Ast_helper.Pat.alias - ~loc:({pattern.ppat_loc with loc_end = p.prevEndPos}) - ~attrs - pattern - name - | _ -> pattern - - (* or ::= pattern | pattern - * precedence: Red | Blue | Green is interpreted as (Red | Blue) | Green *) - and parseOrPattern pattern1 p = - let rec loop pattern1 = - match p.Parser.token with - | Bar -> - Parser.next p; - let pattern2 = parsePattern ~or_:false p in - let loc = { pattern1.Parsetree.ppat_loc with - loc_end = pattern2.ppat_loc.loc_end - } in - loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) - | _ -> pattern1 - in - loop pattern1 - - and parseNonSpreadPattern ~msg p = - let () = match p.Parser.token with - | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p; - | _ -> () - in - match p.Parser.token with - | token when Grammar.isPatternStart token -> - let pat = parsePattern p in - begin match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Some (Ast_helper.Pat.constraint_ ~loc pat typ) - | _ -> Some pat - end - | _ -> None - - and parseConstrainedPattern p = - let pat = parsePattern p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Ast_helper.Pat.constraint_ ~loc pat typ - | _ -> pat - - and parseConstrainedPatternRegion p = - match p.Parser.token with - | token when Grammar.isPatternStart token -> - Some (parseConstrainedPattern p) - | _ -> None - - (* field ::= - * | longident - * | longident : pattern - * | longident as lident - * - * row ::= - * | field , - * | field , _ - * | field , _, - *) - and parseRecordPatternField p = - let startPos = p.Parser.startPos in - let label = parseValuePath p in - let pattern = match p.Parser.token with - | Colon -> - Parser.next p; - parsePattern p - | _ -> - Ast_helper.Pat.var - ~loc:label.loc - (Location.mkloc (Longident.last label.txt) label.loc) - in - match p.token with - | As -> - Parser.next p; - let (name, loc) = parseLident p in - let name = Location.mkloc name loc in - let aliasPattern = Ast_helper.Pat.alias - ~loc:(mkLoc startPos p.prevEndPos) - pattern - name - in - (Location.mkloc label.txt (mkLoc startPos aliasPattern.ppat_loc.loc_end), aliasPattern) - | _ -> - (label, pattern) - - (* TODO: there are better representations than PatField|Underscore ? *) - and parseRecordPatternItem p = - match p.Parser.token with - | DotDotDot -> - Parser.next p; - Some (true, PatField (parseRecordPatternField p)) - | Uident _ | Lident _ -> - Some (false, PatField (parseRecordPatternField p)) - | Underscore -> - Parser.next p; - Some (false, PatUnderscore) - | _ -> - None - - and parseRecordPattern ~attrs p = - let startPos = p.startPos in - Parser.expect Lbrace p; - let rawFields = - parseCommaDelimitedReversedList p - ~grammar:PatternRecord - ~closing:Rbrace - ~f:parseRecordPatternItem - in - Parser.expect Rbrace p; - let (fields, closedFlag) = - let (rawFields, flag) = match rawFields with - | (_hasSpread, PatUnderscore)::rest -> - (rest, Asttypes.Open) - | rawFields -> - (rawFields, Asttypes.Closed) - in - List.fold_left (fun (fields, flag) curr -> - let (hasSpread, field) = curr in - match field with - | PatField field -> - if hasSpread then ( - let (_, pattern) = field in - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message ErrorMessages.recordPatternSpread) - ); - (field::fields, flag) - | PatUnderscore -> - (fields, flag) - ) ([], flag) rawFields - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.record ~loc ~attrs fields closedFlag - - and parseTuplePattern ~attrs ~first ~startPos p = - let patterns = - parseCommaDelimitedRegion p - ~grammar:Grammar.PatternList - ~closing:Rparen - ~f:parseConstrainedPatternRegion - in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.tuple ~loc ~attrs (first::patterns) - - and parsePatternRegion p = - match p.Parser.token with - | DotDotDot -> - Parser.next p; - Some (true, parseConstrainedPattern p) - | token when Grammar.isPatternStart token -> - Some (false, parseConstrainedPattern p) - | _ -> None - - and parseModulePattern ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Module p; - Parser.expect Lparen p; - let uident = match p.token with - | Uident uident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc uident loc - | _ -> (* TODO: error recovery *) - Location.mknoloc "_" - in - begin match p.token with - | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let packageTypAttrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in - Ast_helper.Pat.constraint_ - ~loc - ~attrs - unpack - packageType - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.unpack ~loc ~attrs uident - end - - and parseListPattern ~startPos ~attrs p = - Parser.expect Lbracket p; - let listPatterns = - parseCommaDelimitedReversedList p - ~grammar:Grammar.PatternOcamlList - ~closing:Rbracket - ~f:parsePatternRegion - in - Parser.expect Rbracket p; - let loc = mkLoc startPos p.prevEndPos in - let filterSpread (hasSpread, pattern) = - if hasSpread then ( - Parser.err - ~startPos:pattern.Parsetree.ppat_loc.loc_start - p - (Diagnostics.message ErrorMessages.listPatternSpread); - pattern - ) else - pattern - in - match listPatterns with - | (true, pattern)::patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns (Some pattern) in - {pat with ppat_loc = loc; ppat_attributes = attrs;} - | patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns None in - {pat with ppat_loc = loc; ppat_attributes = attrs;} - - and parseArrayPattern ~attrs p = - let startPos = p.startPos in - Parser.expect Lbracket p; - let patterns = - parseCommaDelimitedRegion - p - ~grammar:Grammar.PatternList - ~closing:Rbracket - ~f:(parseNonSpreadPattern ~msg:ErrorMessages.arrayPatternSpread) - in - Parser.expect Rbracket p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.array ~loc ~attrs patterns - - and parseConstructorPatternArgs p constr startPos attrs = - let lparen = p.startPos in - Parser.expect Lparen p; - let args = parseCommaDelimitedRegion - p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion - in - Parser.expect Rparen p; - let args = match args with - | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some ( - Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None - ) - | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some pat - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern - | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - in - Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args - - and parseVariantPatternArgs p ident startPos attrs = - let lparen = p.startPos in - Parser.expect Lparen p; - let patterns = - parseCommaDelimitedRegion - p ~grammar:Grammar.PatternList ~closing:Rparen ~f:parseConstrainedPatternRegion in - let args = - match patterns with - | [{ppat_desc = Ppat_tuple _} as pat] as patterns -> - if p.mode = ParseForTypeChecker then - (* #ident(1, 2) for type-checker *) - Some pat - else - (* #ident((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern - | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - in - Parser.expect Rparen p; - Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args - - and parseExpr ?(context=OrdinaryExpr) p = - let expr = parseOperandExpr ~context p in - let expr = parseBinaryExpr ~context ~a:expr p 1 in - parseTernaryExpr expr p - - (* expr ? expr : expr *) - and parseTernaryExpr leftOperand p = - match p.Parser.token with - | Question -> - Parser.leaveBreadcrumb p Grammar.Ternary; - Parser.next p; - let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in - Parser.expect Colon p; - let falseBranch = parseExpr p in - Parser.eatBreadcrumb p; - let loc = {leftOperand.Parsetree.pexp_loc with - loc_start = leftOperand.pexp_loc.loc_start; - loc_end = falseBranch.Parsetree.pexp_loc.loc_end; - } in - Ast_helper.Exp.ifthenelse - ~attrs:[ternaryAttr] ~loc - leftOperand trueBranch (Some falseBranch) - | _ -> - leftOperand - - and parseEs6ArrowExpression ?parameters p = - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; - let parameters = match parameters with - | Some params -> params - | None -> parseParameters p - in - let returnType = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseTypExpr ~es6Arrow:false p) - | _ -> - None - in - Parser.expect EqualGreater p; - let body = - let expr = parseExpr p in - match returnType with - | Some typ -> - Ast_helper.Exp.constraint_ - ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) expr typ - | None -> expr - in - Parser.eatBreadcrumb p; - let endPos = p.prevEndPos in - let arrowExpr = - List.fold_right (fun parameter expr -> - match parameter with - | TermParameter {uncurried; attrs; label = lbl; expr = defaultExpr; pat; pos = startPos} -> - let attrs = if uncurried then uncurryAttr::attrs else attrs in - Ast_helper.Exp.fun_ ~loc:(mkLoc startPos endPos) ~attrs lbl defaultExpr pat expr - | TypeParameter {uncurried; attrs; locs = newtypes; pos = startPos} -> - let attrs = if uncurried then uncurryAttr::attrs else attrs in - makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr - ) parameters body - in - {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} - - (* - * uncurried_parameter ::= - * | . parameter - * - * parameter ::= - * | pattern - * | pattern : type - * | ~ labelName - * | ~ labelName as pattern - * | ~ labelName as pattern : type - * | ~ labelName = expr - * | ~ labelName as pattern = expr - * | ~ labelName as pattern : type = expr - * | ~ labelName = ? - * | ~ labelName as pattern = ? - * | ~ labelName as pattern : type = ? - * - * labelName ::= lident - *) - and parseParameter p = - if ( - p.Parser.token = Token.Typ || - p.token = Tilde || - p.token = Dot || - Grammar.isPatternStart p.token - ) then ( - let startPos = p.Parser.startPos in - let uncurried = Parser.optional p Token.Dot in - (* two scenarios: - * attrs ~lbl ... - * attrs pattern - * Attributes before a labelled arg, indicate that it's on the whole arrow expr - * Otherwise it's part of the pattern - * *) - let attrs = parseAttributes p in - if p.Parser.token = Typ then ( - Parser.next p; - let lidents = parseLidentList p in - Some (TypeParameter {uncurried; attrs; locs = lidents; pos = startPos}) - ) else ( - let (attrs, lbl, pat) = match p.Parser.token with - | Tilde -> - Parser.next p; - let (lblName, loc) = parseLident p in - let propLocAttr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in - begin match p.Parser.token with - | Comma | Equal | Rparen -> - let loc = mkLoc startPos p.prevEndPos in - ( - attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:[propLocAttr] ~loc (Location.mkloc lblName loc) - ) - | Colon -> - let lblEnd = p.prevEndPos in - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos lblEnd in - let pat = - let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.constraint_ ~attrs:[propLocAttr] ~loc pat typ in - (attrs, Asttypes.Labelled lblName, pat) - | As -> - Parser.next p; - let pat = - let pat = parseConstrainedPattern p in - {pat with ppat_attributes = propLocAttr::pat.ppat_attributes} - in - (attrs, Asttypes.Labelled lblName, pat) - | t -> - Parser.err p (Diagnostics.unexpected t p.breadcrumbs); - let loc = mkLoc startPos p.prevEndPos in - ( - attrs, - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) - ) - end - | _ -> - let pattern = parseConstrainedPattern p in - let attrs = List.concat [attrs; pattern.ppat_attributes] in - ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) - in - match p.Parser.token with - | Equal -> - Parser.next p; - let lbl = match lbl with - | Asttypes.Labelled lblName -> Asttypes.Optional lblName - | Asttypes.Optional _ as lbl -> lbl - | Asttypes.Nolabel -> Asttypes.Nolabel - in - begin match p.Parser.token with - | Question -> - Parser.next p; - Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in - Some (TermParameter {uncurried; attrs; label = lbl; expr = Some expr; pat; pos = startPos}) - end - | _ -> - Some (TermParameter {uncurried; attrs; label = lbl; expr = None; pat; pos = startPos}) - ) - ) else None - - and parseParameterList p = - let parameters = - parseCommaDelimitedRegion - ~grammar:Grammar.ParameterList - ~f:parseParameter - ~closing:Rparen - p - in - Parser.expect Rparen p; - parameters - - (* parameters ::= - * | _ - * | lident - * | () - * | (.) - * | ( parameter {, parameter} [,] ) - *) - and parseParameters p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [TermParameter { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); - pos = startPos; - }] - | List -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [TermParameter { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ~loc (Location.mkloc "list" loc); - pos = startPos; - }] - | Underscore -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.any ~loc (); pos = startPos}] - | Lparen -> - Parser.next p; - begin match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = Ast_helper.Pat.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None - in - [TermParameter {uncurried = false; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] - | Dot -> - Parser.next p; - begin match p.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = Ast_helper.Pat.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None - in - [TermParameter {uncurried = true; attrs = []; label = Asttypes.Nolabel; expr = None; pat = unitPattern; pos = startPos}] - | _ -> - begin match parseParameterList p with - | (TermParameter {attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest -> - (TermParameter {uncurried = true; attrs; label = lbl; expr = defaultExpr; pat = pattern; pos = startPos})::rest - | parameters -> parameters - end - end - | _ -> parseParameterList p - end - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - [] - - and parseCoercedExpr ~(expr: Parsetree.expression) p = - Parser.expect ColonGreaterThan p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start p.prevEndPos in - Ast_helper.Exp.coerce ~loc expr None typ - - and parseConstrainedOrCoercedExpr p = - let expr = parseExpr p in - match p.Parser.token with - | ColonGreaterThan -> - parseCoercedExpr ~expr p - | Colon -> - Parser.next p; - begin match p.token with - | _ -> - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - begin match p.token with - | ColonGreaterThan -> - parseCoercedExpr ~expr p - | _ -> - expr - end - end - | _ -> expr - - - and parseConstrainedExprRegion p = - match p.Parser.token with - | token when Grammar.isExprStart token -> - let expr = parseExpr p in - begin match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr - end - | _ -> None - - (* Atomic expressions represent unambiguous expressions. - * This means that regardless of the context, these expressions - * are always interpreted correctly. *) - and parseAtomicExpr p = - Parser.leaveBreadcrumb p Grammar.ExprOperand; - let startPos = p.Parser.startPos in - let expr = match p.Parser.token with - | (True | False) as token -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) None - | Int _ | String _ | Float _ | Character _ -> - let c = parseConstant p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constant ~loc c - | Backtick -> - let expr = parseTemplateExpr p in - {expr with pexp_loc = mkLoc startPos p.prevEndPos} - | Uident _ | Lident _ -> - parseValueOrConstructor p - | Hash -> - parsePolyVariantExpr p - | Lparen -> - Parser.next p; - begin match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None - | _t -> - let expr = parseConstrainedOrCoercedExpr p in - begin match p.token with - | Comma -> - Parser.next p; - parseTupleExpr ~startPos ~first:expr p - | _ -> - Parser.expect Rparen p; - expr - (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} - * What does this location mean here? It means that when there's - * a parenthesized we keep the location here for whitespace interleaving. - * Without the closing paren in the location there will always be an extra - * line. For now we don't include it, because it does weird things - * with for comments. *) - end - end - | List -> - Parser.next p; - begin match p.token with - | Lbracket -> - parseListExpr ~startPos p - | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "list") loc) - end - | Module -> - Parser.next p; - parseFirstClassModuleExpr ~startPos p - | Lbracket -> - parseArrayExp p - | Lbrace -> - parseBracedOrRecordExpr p - | LessThan -> - parseJsx p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.extension ~loc extension - | Underscore as token -> - (* This case is for error recovery. Not sure if it's the correct place *) - Parser.err p (Diagnostics.lident token); - Parser.next p; - Recover.defaultExpr () - | token -> - let errPos = p.prevEndPos in - begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart with - | None -> - Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultExpr () - | Some () -> parseAtomicExpr p - end - in - Parser.eatBreadcrumb p; - expr - - (* module(module-expr) - * module(module-expr : package-type) *) - and parseFirstClassModuleExpr ~startPos p = - Parser.expect Lparen p; - - let modExpr = parseModuleExpr p in - let modEndLoc = p.prevEndPos in - begin match p.Parser.token with - | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos modEndLoc in - let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constraint_ ~loc firstClassModule packageType - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.pack ~loc modExpr - end - - and parseBracketAccess p expr startPos = - Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; - let lbracket = p.startPos in - Parser.next p; - let stringStart = p.startPos in - match p.Parser.token with - | String s -> - Parser.next p; - let stringEnd = p.prevEndPos in - Parser.expect Rbracket p; - let rbracket = p.prevEndPos in - let e = - let identLoc = mkLoc stringStart stringEnd in - let loc = mkLoc lbracket rbracket in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "##") loc)) - [Nolabel, expr; Nolabel, (Ast_helper.Exp.ident ~loc:identLoc (Location.mkloc (Longident.Lident s) identLoc))] - in - let e = parsePrimaryExpr ~operand:e p in - let equalStart = p.startPos in - begin match p.token with - | Equal -> - Parser.next p; - let equalEnd = p.prevEndPos in - let rhsExpr = parseExpr p in - let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in - let operatorLoc = mkLoc equalStart equalEnd in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc:operatorLoc (Location.mkloc (Longident.Lident "#=") operatorLoc)) - [Nolabel, e; Nolabel, rhsExpr] - | _ -> e - end - | _ -> - let accessExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Rbracket p; - let rbracket = p.prevEndPos in - let arrayLoc = mkLoc lbracket rbracket in - begin match p.token with - | Equal -> - Parser.leaveBreadcrumb p ExprArrayMutation; - Parser.next p; - let rhsExpr = parseExpr p in - let arraySet = Location.mkloc - (Longident.Ldot(Lident "Array", "set")) - arrayLoc - in - let endPos = p.prevEndPos in - let arraySet = Ast_helper.Exp.apply - ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) - [Nolabel, expr; Nolabel, accessExpr; Nolabel, rhsExpr] - in - Parser.eatBreadcrumb p; - arraySet - | _ -> - let endPos = p.prevEndPos in - let e = - Ast_helper.Exp.apply - ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident - ~loc:arrayLoc - (Location.mkloc (Longident.Ldot(Lident "Array", "get")) arrayLoc) - ) - [Nolabel, expr; Nolabel, accessExpr] - in - Parser.eatBreadcrumb p; - parsePrimaryExpr ~operand:e p - end - - (* * A primary expression represents - * - atomic-expr - * - john.age - * - array[0] - * - applyFunctionTo(arg1, arg2) - * - * The "operand" represents the expression that is operated on - *) - and parsePrimaryExpr ~operand ?(noCall=false) p = - let startPos = operand.pexp_loc.loc_start in - let rec loop p expr = - match p.Parser.token with - | Dot -> - Parser.next p; - let lident = parseValuePath p in - begin match p.Parser.token with - | Equal when noCall = false -> - Parser.leaveBreadcrumb p Grammar.ExprSetField; - Parser.next p; - let targetExpr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in - Parser.eatBreadcrumb p; - setfield - | _ -> - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - loop p (Ast_helper.Exp.field ~loc expr lident) - end - | Lbracket when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - parseBracketAccess p expr startPos - | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseCallExpr p expr) - | Backtick when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - begin match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident ident} -> - parseTemplateExpr ~prefix:ident p - | _ -> - Parser.err - ~startPos:expr.pexp_loc.loc_start - ~endPos:expr.pexp_loc.loc_end - p - (Diagnostics.message "Tagged template literals are currently restricted to identifiers like: json`null`."); - parseTemplateExpr p - end - | _ -> expr - in - loop p operand - - (* a unary expression is an expression with only one operand and - * unary operator. Examples: - * -1 - * !condition - * -. 1.6 - *) - and parseUnaryExpr p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | (Minus | MinusDot | Plus | PlusDot | Bang) as token -> - Parser.leaveBreadcrumb p Grammar.ExprUnary; - let tokenEnd = p.endPos in - Parser.next p; - let operand = parseUnaryExpr p in - let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in - Parser.eatBreadcrumb p; - unaryExpr - | _ -> - parsePrimaryExpr ~operand:(parseAtomicExpr p) p - - (* Represents an "operand" in a binary expression. - * If you have `a + b`, `a` and `b` both represent - * the operands of the binary expression with opeartor `+` *) - and parseOperandExpr ~context p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - let expr = match p.Parser.token with - | Assert -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.assert_ ~loc expr - | Lazy -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.lazy_ ~loc expr - | Try -> - parseTryExpression p - | If -> - parseIfExpression p - | For -> - parseForExpression p - | While -> - parseWhileExpression p - | Switch -> - parseSwitchExpression p - | _ -> - if (context != WhenExpr) && - isEs6ArrowExpression ~inTernary:(context=TernaryTrueBranchExpr) p - then - parseEs6ArrowExpression p - else - parseUnaryExpr p - in - (* let endPos = p.Parser.prevEndPos in *) - {expr with - pexp_attributes = List.concat[expr.Parsetree.pexp_attributes; attrs]; - (* pexp_loc = mkLoc startPos endPos *) - } - - (* a binary expression is an expression that combines two expressions with an - * operator. Examples: - * a + b - * f(x) |> g(y) - *) - and parseBinaryExpr ?(context=OrdinaryExpr) ?a p prec = - let a = match a with - | Some e -> e - | None -> parseOperandExpr ~context p - in - let rec loop a = - let token = p.Parser.token in - let tokenPrec = - match token with - (* Can the minus be interpreted as a binary operator? Or is it a unary? - * let w = { - * x - * -10 - * } - * vs - * let w = { - * width - * - gap - * } - * - * First case is unary, second is a binary operator. - * See Scanner.isBinaryOp *) - | Minus | MinusDot | LessThan when not ( - Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum p.endPos.pos_cnum - ) && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> -1 - | token -> Token.precedence token - in - if tokenPrec < prec then a - else begin - Parser.leaveBreadcrumb p (Grammar.ExprBinaryAfterOp token); - let startPos = p.startPos in - Parser.next p; - let endPos = p.prevEndPos in - let b = parseBinaryExpr ~context p (tokenPrec + 1) in - let loc = mkLoc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in - let expr = Ast_helper.Exp.apply - ~loc - (makeInfixOperator p token startPos endPos) - [Nolabel, a; Nolabel, b] - in - loop expr - end - in - loop a - - (* If we even need this, determines if < might be the start of jsx. Not 100% complete *) - (* and isStartOfJsx p = *) - (* Parser.lookahead p (fun p -> *) - (* match p.Parser.token with *) - (* | LessThan -> *) - (* Parser.next p; *) - (* begin match p.token with *) - (* | GreaterThan (* <> *) -> true *) - (* | Lident _ | Uident _ | List -> *) - (* ignore (parseJsxName p); *) - (* begin match p.token with *) - (* | GreaterThan (*
*) -> true *) - (* | Question (* true *) - (* | Lident _ | List -> *) - (* Parser.next p; *) - (* begin match p.token with *) - (* | Equal (* true *) - (* | _ -> false (* TODO *) *) - (* end *) - (* | Forwardslash (* *) - (* Parser.next p; *) - (* begin match p.token with *) - (* | GreaterThan (* *) -> true *) - (* | _ -> false *) - (* end *) - (* | _ -> *) - (* false *) - (* end *) - (* | _ -> false *) - (* end *) - (* | _ -> false *) - (* ) *) - - and parseTemplateExpr ?(prefix="") p = - let hiddenOperator = - let op = Location.mknoloc (Longident.Lident "^") in - Ast_helper.Exp.ident op - in - let rec loop acc p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | TemplateTail txt -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - if String.length txt > 0 then - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - let str = Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) in - Ast_helper.Exp.apply ~loc hiddenOperator - [Nolabel, acc; Nolabel, str] - else - acc - | TemplatePart txt -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let expr = parseExprBlock p in - let fullLoc = mkLoc startPos p.prevEndPos in - Scanner.setTemplateMode p.scanner; - Parser.expect Rbrace p; - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - let str = Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) in - let next = - let a = if String.length txt > 0 then - Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator [Nolabel, acc; Nolabel, str] - else acc - in - Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator - [Nolabel, a; Nolabel, expr] - in - loop next p - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - acc - in - Scanner.setTemplateMode p.scanner; - Parser.expect Backtick p; - let startPos = p.Parser.startPos in - match p.Parser.token with - | TemplateTail txt -> - let loc = mkLoc startPos p.endPos in - Parser.next p; - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - Ast_helper.Exp.constant ~loc (Pconst_string(txt, Some prefix)) - | TemplatePart txt -> - let constantLoc = mkLoc startPos p.endPos in - Parser.next p; - let expr = parseExprBlock p in - let fullLoc = mkLoc startPos p.prevEndPos in - Scanner.setTemplateMode p.scanner; - Parser.expect Rbrace p; - let txt = if p.mode = ParseForTypeChecker then parseTemplateStringLiteral txt else txt in - let str = Ast_helper.Exp.constant ~loc:constantLoc (Pconst_string(txt, Some prefix)) in - let next = - if String.length txt > 0 then - Ast_helper.Exp.apply ~loc:fullLoc hiddenOperator [Nolabel, str; Nolabel, expr] - else - expr - in - loop next p - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Ast_helper.Exp.constant (Pconst_string("", None)) - - (* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => - * Also overparse constraints: - * let x = { - * let a = 1 - * a + pi: int - * } - * - * We want to give a nice error message in these cases - * *) - and overParseConstrainedOrCoercedOrArrowExpression p expr = - match p.Parser.token with - | ColonGreaterThan -> - parseCoercedExpr ~expr p - | Colon -> - Parser.next p; - let typ = parseTypExpr ~es6Arrow:false p in - begin match p.Parser.token with - | EqualGreater -> - Parser.next p; - let body = parseExpr p in - let pat = match expr.pexp_desc with - | Pexp_ident longident -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc - (Longident.flatten longident.txt |> String.concat ".") - longident.loc) - (* TODO: can we convert more expressions to patterns?*) - | _ -> - Ast_helper.Pat.var ~loc:expr.pexp_loc (Location.mkloc "pattern" expr.pexp_loc) - in - let arrow1 = Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel - None - pat - (Ast_helper.Exp.constraint_ body typ) - in - let arrow2 = Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel - None - (Ast_helper.Pat.constraint_ pat typ) - body - in - let msg = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "Did you mean to annotate the parameter type or the return type?"; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.text "1) "; - Printer.printExpression arrow1 CommentTable.empty; - Doc.line; - Doc.text "2) "; - Printer.printExpression arrow2 CommentTable.empty; - ] - ) - ] - ) |> Doc.toString ~width:80 - in - Parser.err - ~startPos:expr.pexp_loc.loc_start - ~endPos:body.pexp_loc.loc_end - p - (Diagnostics.message msg); - arrow1 - | _ -> - let open Parsetree in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - let () = Parser.err - ~startPos:expr.pexp_loc.loc_start - ~endPos:typ.ptyp_loc.loc_end - p - (Diagnostics.message - (Doc.breakableGroup ~forceBreak:true (Doc.concat [ - Doc.text "Expressions with type constraints need to be wrapped in parens:"; - Doc.indent ( - Doc.concat [ - Doc.line; - Printer.addParens (Printer.printExpression expr CommentTable.empty); - ] - ) - ]) |> Doc.toString ~width:80 - )) - in - expr - end - | _ -> expr - - and parseLetBindingBody ~startPos ~attrs p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.LetBinding; - let pat, exp = - let pat = parsePattern p in - match p.Parser.token with - | Colon -> - Parser.next p; - begin match p.token with - | Typ -> (* locally abstract types *) - Parser.next p; - let newtypes = parseLidentList p in - Parser.expect Dot p; - let typ = parseTypExpr p in - Parser.expect Equal p; - let expr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in - let pat = Ast_helper.Pat.constraint_ ~loc pat poly in - (pat, exp) - | _ -> - let polyType = parsePolyTypeExpr p in - let loc = {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} in - let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in - Parser.expect Token.Equal p; - let exp = parseExpr p in - let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in - (pat, exp) - end - | _ -> - Parser.expect Token.Equal p; - let exp = overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) in - (pat, exp) - in - let loc = mkLoc startPos p.prevEndPos in - let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in - Parser.eatBreadcrumb p; - Parser.endRegion p; - vb - - (* TODO: find a better way? Is it possible? - * let a = 1 - * @attr - * and b = 2 - * - * The problem is that without semi we need a lookahead to determine - * if the attr is on the letbinding or the start of a new thing - * - * let a = 1 - * @attr - * let b = 1 - * - * Here @attr should attach to something "new": `let b = 1` - * The parser state is forked, which is quite expensive… - *) - and parseAttributesAndBinding (p : Parser.t) = - let err = p.scanner.err in - let ch = p.scanner.ch in - let offset = p.scanner.offset in - let rdOffset = p.scanner.rdOffset in - let lineOffset = p.scanner.lineOffset in - let lnum = p.scanner.lnum in - let mode = p.scanner.mode in - let token = p.token in - let startPos = p.startPos in - let endPos = p.endPos in - let prevEndPos = p.prevEndPos in - let breadcrumbs = p.breadcrumbs in - let errors = p.errors in - let diagnostics = p.diagnostics in - let comments = p.comments in - - match p.Parser.token with - | At -> - let attrs = parseAttributes p in - begin match p.Parser.token with - | And -> - attrs - | _ -> - p.scanner.err <- err; - p.scanner.ch <- ch; - p.scanner.offset <- offset; - p.scanner.rdOffset <- rdOffset; - p.scanner.lineOffset <- lineOffset; - p.scanner.lnum <- lnum; - p.scanner.mode <- mode; - p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; - p.breadcrumbs <- breadcrumbs; - p.errors <- errors; - p.diagnostics <- diagnostics; - p.comments <- comments; - [] - end - | _ -> [] - - (* definition ::= let [rec] let-binding { and let-binding } *) - and parseLetBindings ~attrs p = - let startPos = p.Parser.startPos in - Parser.optional p Let |> ignore; - let recFlag = if Parser.optional p Token.Rec then - Asttypes.Recursive - else - Asttypes.Nonrecursive - in - let first = parseLetBindingBody ~startPos ~attrs p in - - let rec loop p bindings = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - Parser.next p; - let attrs = match p.token with - | Export -> - let exportLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - genTypeAttr::attrs - | _ -> attrs - in - ignore(Parser.optional p Let); (* overparse for fault tolerance *) - let letBinding = parseLetBindingBody ~startPos ~attrs p in - loop p (letBinding::bindings) - | _ -> - List.rev bindings - in - (recFlag, loop p [first]) - - (* - * div -> div - * Foo -> Foo.createElement - * Foo.Bar -> Foo.Bar.createElement - *) - and parseJsxName p = - let longident = match p.Parser.token with - | Lident ident -> - let identStart = p.startPos in - let identEnd = p.endPos in - Parser.next p; - let loc = mkLoc identStart identEnd in - Location.mkloc (Longident.Lident ident) loc - | Uident _ -> - let longident = parseModuleLongIdent ~lowercase:false p in - Location.mkloc (Longident.Ldot (longident.txt, "createElement")) longident.loc - | _ -> - let msg = "A jsx name should start with a lowercase or uppercase identifier, like: div in
or Navbar in " - in - Parser.err p (Diagnostics.message msg); - Location.mknoloc (Longident.Lident "_") - in - Ast_helper.Exp.ident ~loc:longident.loc longident - - and parseJsxOpeningOrSelfClosingElement ~startPos p = - let jsxStartPos = p.Parser.startPos in - let name = parseJsxName p in - let jsxProps = parseJsxProps p in - let children = match p.Parser.token with - | Forwardslash -> (* *) - let childrenStartPos = p.Parser.startPos in - Parser.next p; - let childrenEndPos = p.Parser.startPos in - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc [] None (* no children *) - | GreaterThan -> (* bar *) - let childrenStartPos = p.Parser.startPos in - Scanner.setJsxMode p.scanner; - Parser.next p; - let (spread, children) = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - let () = match p.token with - | LessThanSlash -> Parser.next p - | LessThan -> Parser.next p; Parser.expect Forwardslash p - | token when Grammar.isStructureItemStart token -> () - | _ -> Parser.expect LessThanSlash p - in - begin match p.Parser.token with - | Lident _ | Uident _ when verifyJsxOpeningClosingName p name -> - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - ( match spread, children with - | true, child :: _ -> - child - | _ -> - makeListExpression loc children None - ) - | token -> - let () = if Grammar.isStructureItemStart token then ( - let closing = "" in - let msg = Diagnostics.message ("Missing " ^ closing) in - Parser.err ~startPos ~endPos:p.prevEndPos p msg; - ) else ( - let opening = "" in - let msg = "Closing jsx name should be the same as the opening name. Did you mean " ^ opening ^ " ?" in - Parser.err ~startPos ~endPos:p.prevEndPos p (Diagnostics.message msg); - Parser.expect GreaterThan p - ) - in - let loc = mkLoc childrenStartPos childrenEndPos in - ( match spread, children with - | true, child :: _ -> - child - | _ -> - makeListExpression loc children None - ) - end - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - makeListExpression Location.none [] None - in - let jsxEndPos = p.prevEndPos in - let loc = mkLoc jsxStartPos jsxEndPos in - Ast_helper.Exp.apply - ~loc - name - (List.concat [jsxProps; [ - (Asttypes.Labelled "children", children); - (Asttypes.Nolabel, Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) None) - ]]) - - (* - * jsx ::= - * | <> jsx-children - * | - * | jsx-children - * - * jsx-children ::= primary-expr* * => 0 or more - *) - and parseJsx p = - Parser.leaveBreadcrumb p Grammar.Jsx; - let startPos = p.Parser.startPos in - Parser.expect LessThan p; - let jsxExpr = match p.Parser.token with - | Lident _ | Uident _ -> - parseJsxOpeningOrSelfClosingElement ~startPos p - | GreaterThan -> (* fragment: <> foo *) - parseJsxFragment p - | _ -> - parseJsxName p - in - {jsxExpr with pexp_attributes = [jsxAttr]} - - (* - * jsx-fragment ::= - * | <> - * | <> jsx-children - *) - and parseJsxFragment p = - let childrenStartPos = p.Parser.startPos in - Scanner.setJsxMode p.scanner; - Parser.expect GreaterThan p; - let (_spread, children) = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - Parser.expect LessThanSlash p; - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc children None - - - (* - * jsx-prop ::= - * | lident - * | ?lident - * | lident = jsx_expr - * | lident = ?jsx_expr - *) - and parseJsxProp p = - Parser.leaveBreadcrumb p Grammar.JsxAttribute; - match p.Parser.token with - | Question | Lident _ -> - let optional = Parser.optional p Question in - let (name, loc) = parseLident p in - let propLocAttr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in - (* optional punning: *) - if optional then - Some ( - Asttypes.Optional name, - Ast_helper.Exp.ident ~attrs:[propLocAttr] - ~loc (Location.mkloc (Longident.Lident name) loc) - ) - else begin - match p.Parser.token with - | Equal -> - Parser.next p; - (* no punning *) - let optional = Parser.optional p Question in - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr::e.pexp_attributes} - in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr) - | _ -> - let attrExpr = - Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] - (Location.mknoloc (Longident.Lident name)) in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr) - end - | _ -> - None - - and parseJsxProps p = - parseRegion - ~grammar:Grammar.JsxAttribute - ~f:parseJsxProp - p - - and parseJsxChildren p = - let rec loop p children = - match p.Parser.token with - | Token.Eof | LessThanSlash -> - Scanner.popMode p.scanner Jsx; - List.rev children - | LessThan -> - (* Imagine:
< - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate *) - let token = Scanner.reconsiderLessThan p.scanner in - if token = LessThan then - let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in - loop p (child::children) - else (* LessThanSlash *) - let () = p.token <- token in - let () = Scanner.popMode p.scanner Jsx in - List.rev children - | token when Grammar.isJsxChildStart token -> - let () = Scanner.popMode p.scanner Jsx in - let child = parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p in - loop p (child::children) - | _ -> - Scanner.popMode p.scanner Jsx; - List.rev children - in - match p.Parser.token with - | DotDotDot -> - Parser.next p; - (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) - | _ -> (false, loop p []) - - and parseBracedOrRecordExpr p = - let startPos = p.Parser.startPos in - Parser.expect Lbrace p; - match p.Parser.token with - | Rbrace -> - Parser.err p (Diagnostics.unexpected Rbrace p.breadcrumbs); - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - Ast_helper.Exp.construct ~attrs:[braces] ~loc - (Location.mkloc (Longident.Lident "()") loc) None - | DotDotDot -> - (* beginning of record spread, parse record *) - Parser.next p; - let spreadExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in - Parser.expect Rbrace p; - expr - | String s -> - let field = - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc (Longident.Lident s) loc - in - begin match p.Parser.token with - | Colon -> - Parser.next p; - let fieldExpr = parseExpr p in - Parser.optional p Comma |> ignore; - let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in - Parser.expect Rbrace p; - expr - | _ -> - let constant = Ast_helper.Exp.constant ~loc:field.loc (Parsetree.Pconst_string(s, None)) in - let a = parsePrimaryExpr ~operand:constant p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - begin match p.Parser.token with - | Semicolon -> - Parser.next p; - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - end - | Uident _ | Lident _ -> - let valueOrConstructor = parseValueOrConstructor p in - begin match valueOrConstructor.pexp_desc with - | Pexp_ident pathIdent -> - let identEndPos = p.prevEndPos in - begin match p.Parser.token with - | Comma -> - Parser.next p; - let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in - Parser.expect Rbrace p; - expr - | Colon -> - Parser.next p; - let fieldExpr = parseExpr p in - begin match p.token with - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None - | _ -> - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in - Parser.expect Rbrace p; - expr - end - (* error case *) - | Lident _ -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in - Parser.expect Rbrace p; - expr - ) else ( - Parser.expect Colon p; - let expr = parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p in - Parser.expect Rbrace p; - expr - ) - | Semicolon -> - Parser.next p; - let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - | EqualGreater -> - let loc = mkLoc startPos identEndPos in - let ident = Location.mkloc (Longident.last pathIdent.txt) loc in - let a = parseEs6ArrowExpression - ~parameters:[TermParameter { - uncurried = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ident; - pos = startPos; - }] - p - in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - begin match p.Parser.token with - | Semicolon -> - Parser.next p; - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - | _ -> - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = parsePrimaryExpr ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - begin match p.Parser.token with - | Semicolon -> - Parser.next p; - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - end - | _ -> - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = parsePrimaryExpr ~operand:valueOrConstructor p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - begin match p.Parser.token with - | Semicolon -> - Parser.next p; - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces::e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - end - end - | _ -> - let expr = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces::expr.pexp_attributes} - - and parseRecordRowWithStringKey p = - match p.Parser.token with - | String s -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let field = Location.mkloc (Longident.Lident s) loc in - begin match p.Parser.token with - | Colon -> - Parser.next p; - let fieldExpr = parseExpr p in - Some (field, fieldExpr) - | _ -> - Some (field, Ast_helper.Exp.ident ~loc:field.loc field) - end - | _ -> None - - and parseRecordRow p = - let () = match p.Parser.token with - | Token.DotDotDot -> - Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); - Parser.next p; - | _ -> () - in - match p.Parser.token with - | Lident _ | Uident _ | List -> - let field = parseValuePath p in - begin match p.Parser.token with - | Colon -> - Parser.next p; - let fieldExpr = parseExpr p in - Some (field, fieldExpr) - | _ -> - Some (field, Ast_helper.Exp.ident ~loc:field.loc field) - end - | _ -> None - - and parseRecordExprWithStringKeys ~startPos firstRow p = - let rows = firstRow::( - parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey ~closing:Rbrace ~f:parseRecordRowWithStringKey p - ) in - let loc = mkLoc startPos p.endPos in - let recordStrExpr = Ast_helper.Str.eval ~loc ( - Ast_helper.Exp.record ~loc rows None - ) in - Ast_helper.Exp.extension ~loc - (Location.mkloc "bs.obj" loc, Parsetree.PStr [recordStrExpr]) - - and parseRecordExpr ~startPos ?(spread=None) rows p = - let exprs = - parseCommaDelimitedRegion - ~grammar:Grammar.RecordRows - ~closing:Rbrace - ~f:parseRecordRow p - in - let rows = List.concat [rows; exprs] in - let () = match rows with - | [] -> - let msg = "Record spread needs at least one field that's updated" in - Parser.err p (Diagnostics.message msg); - | _rows -> () - in - let loc = mkLoc startPos p.endPos in - Ast_helper.Exp.record ~loc rows spread - - and parseExprBlockItem p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Module -> - Parser.next p; - begin match p.token with - | Lparen -> - parseFirstClassModuleExpr ~startPos p - | _ -> - let name = match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = parseModuleBindingBody p in - Parser.optional p Semicolon |> ignore; - let expr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letmodule ~loc name body expr - end - | Exception -> - let extensionConstructor = parseExceptionDef ~attrs p in - Parser.optional p Semicolon |> ignore; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr - | Open -> - let od = parseOpenDescription ~attrs p in - Parser.optional p Semicolon |> ignore; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr - | Let -> - let (recFlag, letBindings) = parseLetBindings ~attrs p in - let next = match p.Parser.token with - | Semicolon -> - Parser.next p; - if Grammar.isBlockExprStart p.Parser.token then - parseExprBlock p - else - let loc = mkLoc p.startPos p.endPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) None - | token when Grammar.isBlockExprStart token -> - parseExprBlock p - | _ -> - let loc = mkLoc p.startPos p.endPos in - Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) None - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.let_ ~loc recFlag letBindings next - | _ -> - let e1 = - let expr = parseExpr p in - {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} - in - ignore (Parser.optional p Semicolon); - if Grammar.isBlockExprStart p.Parser.token then - let e2 = parseExprBlock p in - let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc e1 e2 - else e1 - - (* blockExpr ::= expr - * | expr ; - * | expr ; blockExpr - * | module ... ; blockExpr - * | open ... ; blockExpr - * | exception ... ; blockExpr - * | let ... - * | let ... ; - * | let ... ; blockExpr - * - * note: semi should be made optional - * a block of expression is always - *) - and parseExprBlock ?first p = - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let item = match first with - | Some e -> e - | None -> parseExprBlockItem p - in - let blockExpr = match p.Parser.token with - | Semicolon -> - Parser.next p; - if Grammar.isBlockExprStart p.Parser.token then - let next = parseExprBlockItem p in - ignore(Parser.optional p Semicolon); - let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc item next - else - item - | token when Grammar.isBlockExprStart token -> - let next = parseExprBlockItem p in - ignore(Parser.optional p Semicolon); - let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc item next - | _ -> - item - in - Parser.eatBreadcrumb p; - overParseConstrainedOrCoercedOrArrowExpression p blockExpr - - and parseTryExpression p = - let startPos = p.Parser.startPos in - Parser.expect Try p; - let expr = parseExpr ~context:WhenExpr p in - Parser.expect Catch p; - Parser.expect Lbrace p; - let cases = parsePatternMatching p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.try_ ~loc expr cases - - and parseIfExpression p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.ExprIf; - let startPos = p.Parser.startPos in - Parser.expect If p; - Parser.leaveBreadcrumb p Grammar.IfCondition; - (* doesn't make sense to try es6 arrow here? *) - let conditionExpr = parseExpr ~context:WhenExpr p in - Parser.eatBreadcrumb p; - Parser.leaveBreadcrumb p IfBranch; - Parser.expect Lbrace p; - let thenExpr = parseExprBlock p in - Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - let elseExpr = match p.Parser.token with - | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = match p.token with - | If -> - parseIfExpression p - | _ -> - Parser.expect Lbrace p; - let blockExpr = parseExprBlock p in - Parser.expect Rbrace p; - blockExpr - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - Some elseExpr - | _ -> - Parser.endRegion p; - None - in - let loc = mkLoc startPos p.prevEndPos in - Parser.eatBreadcrumb p; - Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr - - and parseForRest hasOpeningParen pattern startPos p = - Parser.expect In p; - let e1 = parseExpr p in - let direction = match p.Parser.token with - | To -> Asttypes.Upto - | Downto -> Asttypes.Downto - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Asttypes.Upto - in - Parser.next p; - let e2 = parseExpr ~context:WhenExpr p in - if hasOpeningParen then Parser.expect Rparen p; - Parser.expect Lbrace p; - let bodyExpr = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.for_ ~loc pattern e1 e2 direction bodyExpr - - and parseForExpression p = - let startPos = p.Parser.startPos in - Parser.expect For p; - match p.token with - | Lparen -> - let lparen = p.startPos in - Parser.next p; - begin match p.token with - | Rparen -> - Parser.next p; - let unitPattern = - let loc = mkLoc lparen p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid None - in - parseForRest false (parseAliasPattern ~attrs:[] unitPattern p) startPos p - | _ -> - let pat = parsePattern p in - begin match p.token with - | Comma -> - Parser.next p; - let tuplePattern = - parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p - in - let pattern = parseAliasPattern ~attrs:[] tuplePattern p in - parseForRest false pattern startPos p - | _ -> - parseForRest true pat startPos p - end - end - | _ -> - parseForRest false (parsePattern p) startPos p - - and parseWhileExpression p = - let startPos = p.Parser.startPos in - Parser.expect While p; - let expr1 = parseExpr ~context:WhenExpr p in - Parser.expect Lbrace p; - let expr2 = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.while_ ~loc expr1 expr2 - - and parsePatternMatchCase p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.PatternMatchCase; - match p.Parser.token with - | Token.Bar -> - Parser.next p; - let lhs = parsePattern p in - let guard = match p.Parser.token with - | When -> - Parser.next p; - Some (parseExpr ~context:WhenExpr p) - | _ -> - None - in - let () = match p.token with - | EqualGreater -> Parser.next p - | _ -> Recover.recoverEqualGreater p - in - let rhs = parseExprBlock p in - Parser.endRegion p; - Parser.eatBreadcrumb p; - Some (Ast_helper.Exp.case lhs ?guard rhs) - | _ -> - Parser.endRegion p; - None - - and parsePatternMatching p = - Parser.leaveBreadcrumb p Grammar.PatternMatching; - let cases = - parseDelimitedRegion - ~grammar:Grammar.PatternMatching - ~closing:Rbrace - ~f:parsePatternMatchCase - p - in - let () = match cases with - | [] -> Parser.err ~startPos:p.prevEndPos p ( - Diagnostics.message "Pattern matching needs at least one case" - ) - | _ -> () - in - cases - - and parseSwitchExpression p = - let startPos = p.Parser.startPos in - Parser.expect Switch p; - let switchExpr = parseExpr ~context:WhenExpr p in - Parser.expect Lbrace p; - let cases = parsePatternMatching p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.match_ ~loc switchExpr cases - - (* - * argument ::= - * | _ (* syntax sugar *) - * | expr - * | expr : type - * | ~ label-name - * | ~ label-name - * | ~ label-name ? - * | ~ label-name = expr - * | ~ label-name = _ (* syntax sugar *) - * | ~ label-name = expr : type - * | ~ label-name = ? expr - * | ~ label-name = ? _ (* syntax sugar *) - * | ~ label-name = ? expr : type - * - * uncurried_argument ::= - * | . argument - *) - and parseArgument p = - if ( - p.Parser.token = Token.Tilde || - p.token = Dot || - p.token = Underscore || - Grammar.isExprStart p.token - ) then ( - match p.Parser.token with - | Dot -> - let uncurried = true in - let startPos = p.Parser.startPos in - Parser.next(p); - begin match p.token with - (* apply(.) *) - | Rparen -> - let loc = mkLoc startPos p.prevEndPos in - let unitExpr = Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) None - in - Some (uncurried, Asttypes.Nolabel, unitExpr) - | _ -> - parseArgument2 p ~uncurried - end - | _ -> - parseArgument2 p ~uncurried:false - ) else - None - - and parseArgument2 p ~uncurried = - match p.Parser.token with - (* foo(_), do not confuse with foo(_ => x), TODO: performance *) - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let exp = Ast_helper.Exp.ident ~loc ( - Location.mkloc (Longident.Lident "_") loc - ) in - Some (uncurried, Asttypes.Nolabel, exp) - | Tilde -> - Parser.next p; - (* TODO: nesting of pattern matches not intuitive for error recovery *) - begin match p.Parser.token with - | Lident ident -> - let startPos = p.startPos in - Parser.next p; - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - let propLocAttr = (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) in - let identExpr = Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc ( - Location.mkloc (Longident.Lident ident) loc - ) in - begin match p.Parser.token with - | Question -> - Parser.next p; - Some (uncurried, Asttypes.Optional ident, identExpr) - | Equal -> - Parser.next p; - let label = match p.Parser.token with - | Question -> - Parser.next p; - Asttypes.Optional ident - | _ -> - Labelled ident - in - let expr = match p.Parser.token with - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Ast_helper.Exp.ident ~loc ( - Location.mkloc (Longident.Lident "_") loc - ) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in - {expr with pexp_attributes = propLocAttr::expr.pexp_attributes} - in - Some (uncurried, label, expr) - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - let expr = Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ in - Some (uncurried, Labelled ident, expr) - | _ -> - Some (uncurried, Labelled ident, identExpr) - end - | t -> - Parser.err p (Diagnostics.lident t); - Some (uncurried, Nolabel, Recover.defaultExpr ()) - end - | _ -> Some (uncurried, Nolabel, parseConstrainedOrCoercedExpr p) - - and parseCallExpr p funExpr = - Parser.expect Lparen p; - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.ExprCall; - let args = - parseCommaDelimitedRegion - ~grammar:Grammar.ArgumentList - ~closing:Rparen - ~f:parseArgument p - in - Parser.expect Rparen p; - let args = match args with - | [] -> - let loc = mkLoc startPos p.prevEndPos in - (* No args -> unit sugar: `foo()` *) - [ false, - Asttypes.Nolabel, - Ast_helper.Exp.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None - ] - | args -> args - in - let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in - let args = match args with - | (u, lbl, expr)::args -> - let group (grp, acc) (uncurried, lbl, expr) = - let (_u, grp) = grp in - if uncurried == true then - ((true, [lbl, expr]), ((_u, (List.rev grp))::acc)) - else - ((_u, ((lbl, expr)::grp)), acc) - in - let ((_u, grp), acc) = List.fold_left group((u, [lbl, expr]), []) args in - List.rev ((_u, (List.rev grp))::acc) - | [] -> [] - in - let apply = List.fold_left (fun callBody group -> - let (uncurried, args) = group in - let (args, wrap) = processUnderscoreApplication args in - let exp = if uncurried then - let attrs = [uncurryAttr] in - Ast_helper.Exp.apply ~loc ~attrs callBody args - else - Ast_helper.Exp.apply ~loc callBody args - in - wrap exp - ) funExpr args - in - Parser.eatBreadcrumb p; - apply - - and parseValueOrConstructor p = - let startPos = p.Parser.startPos in - let rec aux p acc = - match p.Parser.token with - | Uident ident -> - let endPosLident = p.endPos in - Parser.next p; - begin match p.Parser.token with - | Dot -> - Parser.next p; - aux p (ident::acc) - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let lident = buildLongident (ident::acc) in - let tail = match args with - | [] -> None - | [{Parsetree.pexp_desc = Pexp_tuple _} as arg] as args -> - let loc = mkLoc lparen rparen in - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some arg - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc args) - | [arg] -> - Some arg - | args -> - let loc = mkLoc lparen rparen in - Some (Ast_helper.Exp.tuple ~loc args) - in - let loc = mkLoc startPos p.prevEndPos in - let identLoc = mkLoc startPos endPosLident in - Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail - | _ -> - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident::acc) in - Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None - end - | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident::acc) in - Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) - | List -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident ("list"::acc) in - Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) - | token -> - Parser.next p; - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultExpr() - in - aux p [] - - and parsePolyVariantExpr p = - let startPos = p.startPos in - let (ident, _loc) = parseHashIdent ~startPos p in - begin match p.Parser.token with - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let loc_paren = mkLoc lparen rparen in - let tail = match args with - | [] -> None - | [{Parsetree.pexp_desc = Pexp_tuple _} as expr ] as args -> - if p.mode = ParseForTypeChecker then - (* #a(1, 2) for type-checker *) - Some expr - else - (* #a((1, 2)) for type-checker *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - | [arg] -> Some arg - | args -> - (* #a((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident tail - | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident None - end - - and parseConstructorArgs p = - let lparen = p.Parser.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion - ~grammar:Grammar.ExprList ~f:parseConstrainedExprRegion ~closing:Rparen p - in - Parser.expect Rparen p; - match args with - | [] -> - let loc = mkLoc lparen p.prevEndPos in - [Ast_helper.Exp.construct - ~loc (Location.mkloc (Longident.Lident "()") loc) None] - | args -> args - - and parseTupleExpr ~first ~startPos p = - let exprs = - parseCommaDelimitedRegion - p ~grammar:Grammar.ExprList ~closing:Rparen ~f:parseConstrainedExprRegion - in - Parser.expect Rparen p; - Ast_helper.Exp.tuple ~loc:(mkLoc startPos p.prevEndPos) (first::exprs) - - and parseSpreadExprRegion p = - match p.Parser.token with - | DotDotDot -> - Parser.next p; - let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr) - | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p) - | _ -> None - - and parseListExpr ~startPos p = - Parser.expect Lbracket p; - let listExprs = - parseCommaDelimitedReversedList - p ~grammar:Grammar.ListExpr ~closing:Rbracket ~f:parseSpreadExprRegion - in - Parser.expect Rbracket p; - let loc = mkLoc startPos p.prevEndPos in - match listExprs with - | (true, expr)::exprs -> - let exprs = exprs |> List.map snd |> List.rev in - makeListExpression loc exprs (Some expr) - | exprs -> - let exprs = - exprs - |> List.map (fun (spread, expr) -> - if spread then - Parser.err p (Diagnostics.message ErrorMessages.listExprSpread); - expr) - |> List.rev - in - makeListExpression loc exprs None - - (* Overparse ... and give a nice error message *) - and parseNonSpreadExp ~msg p = - let () = match p.Parser.token with - | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p; - | _ -> () - in - match p.Parser.token with - | token when Grammar.isExprStart token -> - let expr = parseExpr p in - begin match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr - end - | _ -> None - - and parseArrayExp p = - let startPos = p.Parser.startPos in - Parser.expect Lbracket p; - let exprs = - parseCommaDelimitedRegion - p - ~grammar:Grammar.ExprList - ~closing:Rbracket - ~f:(parseNonSpreadExp ~msg:ErrorMessages.arrayExprSpread) - in - Parser.expect Rbracket p; - Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) exprs - - (* TODO: check attributes in the case of poly type vars, - * might be context dependend: parseFieldDeclaration (see ocaml) *) - and parsePolyTypeExpr p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | SingleQuote -> - let vars = parseTypeVarList p in - begin match vars with - | _v1::_v2::_ -> - Parser.expect Dot p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | [var] -> - begin match p.Parser.token with - | Dot -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | EqualGreater -> - Parser.next p; - let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - | _ -> - Ast_helper.Typ.var ~loc:var.loc var.txt - end - | _ -> assert false - end - | _ -> - parseTypExpr p - - (* 'a 'b 'c *) - and parseTypeVarList p = - let rec loop p vars = - match p.Parser.token with - | SingleQuote -> - Parser.next p; - let (lident, loc) = parseLident p in - let var = Location.mkloc lident loc in - loop p (var::vars) - | _ -> - List.rev vars - in - loop p [] - - and parseLidentList p = - let rec loop p ls = - match p.Parser.token with - | Lident lident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - loop p ((Location.mkloc lident loc)::ls) - | _ -> - List.rev ls - in - loop p [] - - and parseAtomicTypExpr ~attrs p = - Parser.leaveBreadcrumb p Grammar.AtomicTypExpr; - let startPos = p.Parser.startPos in - let typ = match p.Parser.token with - | SingleQuote -> - Parser.next p; - let (ident, loc) = parseLident p in - Ast_helper.Typ.var ~loc ~attrs ident - | Underscore -> - let endPos = p.endPos in - Parser.next p; - Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () - | Lparen -> - Parser.next p; - begin match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - Ast_helper.Typ.constr ~attrs unitConstr [] - | _ -> - let t = parseTypExpr p in - begin match p.token with - | Comma -> - Parser.next p; - parseTupleType ~attrs ~first:t ~startPos p - | _ -> - Parser.expect Rparen p; - {t with - ptyp_loc = mkLoc startPos p.prevEndPos; - ptyp_attributes = List.concat [attrs; t.ptyp_attributes]} - end - end - | Lbracket -> - parsePolymorphicVariantType ~attrs p - | Uident _ | Lident _ | List -> - let constr = parseValuePath p in - let args = parseTypeConstructorArgs ~constrName:constr p in - Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args - | Module -> - Parser.next p; - Parser.expect Lparen p; - let packageType = parsePackageType ~startPos ~attrs p in - Parser.expect Rparen p; - {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.extension ~attrs ~loc extension - | Lbrace -> - parseBsObjectType ~attrs p - | token -> - begin match skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart with - | Some () -> - parseAtomicTypExpr ~attrs p - | None -> - Parser.err ~startPos:p.prevEndPos p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultType() - end - in - Parser.eatBreadcrumb p; - typ - - (* package-type ::= - | modtype-path - ∣ modtype-path with package-constraint { and package-constraint } - *) - and parsePackageType ~startPos ~attrs p = - let modTypePath = parseModuleLongIdent ~lowercase:true p in - begin match p.Parser.token with - | With -> - Parser.next p; - let constraints = parsePackageConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath constraints - | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath [] - end - - (* package-constraint { and package-constraint } *) - and parsePackageConstraints p = - let first = - Parser.expect Typ p; - let typeConstr = parseValuePath p in - Parser.expect Equal p; - let typ = parseTypExpr p in - (typeConstr, typ) - in - let rest = parseRegion - ~grammar:Grammar.PackageConstraint - ~f:parsePackageConstraint - p - in - first::rest - - (* and type typeconstr = typexpr *) - and parsePackageConstraint p = - match p.Parser.token with - | And -> - Parser.next p; - Parser.expect Typ p; - let typeConstr = parseValuePath p in - Parser.expect Equal p; - let typ = parseTypExpr p in - Some (typeConstr, typ) - | _ -> None - - and parseBsObjectType ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Lbrace p; - let closedFlag = match p.token with - | DotDot -> Parser.next p; Asttypes.Open - | Dot -> Parser.next p; Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - makeBsObjType ~attrs ~loc ~closed:closedFlag fields - - (* TODO: check associativity in combination with attributes *) - and parseTypeAlias p typ = - match p.Parser.token with - | As -> - Parser.next p; - Parser.expect SingleQuote p; - let (ident, _loc) = parseLident p in - (* TODO: how do we parse attributes here? *) - Ast_helper.Typ.alias ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) typ ident - | _ -> typ - - - (* type_parameter ::= - * | type_expr - * | ~ident: type_expr - * | ~ident: type_expr=? - * - * note: - * | attrs ~ident: type_expr -> attrs are on the arrow - * | attrs type_expr -> attrs are here part of the type_expr - * - * uncurried_type_parameter ::= - * | . type_parameter - *) - and parseTypeParameter p = - if ( - p.Parser.token = Token.Tilde || - p.token = Dot || - Grammar.isTypExprStart p.token - ) then ( - let startPos = p.Parser.startPos in - let uncurried = Parser.optional p Dot in - let attrs = parseAttributes p in - match p.Parser.token with - | Tilde -> - Parser.next p; - let (name, _loc) = parseLident p in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parseTypExpr p in - begin match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> - Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) - end - | Lident _ | List -> - let (name, loc) = parseLident p in - begin match p.token with - | Colon -> - let () = - let error = Diagnostics.message - ("Parameter names start with a `~`, like: ~" ^ name) - in - Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error - in - Parser.next p; - let typ = parseTypExpr p in - begin match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Some (uncurried, attrs, Asttypes.Optional name, typ, startPos) - | _ -> - Some (uncurried, attrs, Asttypes.Labelled name, typ, startPos) - end - | _ -> - let constr = Location.mkloc (Longident.Lident name) loc in - let args = parseTypeConstructorArgs ~constrName:constr p in - let typ = Ast_helper.Typ.constr ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args - in - - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - let typ = parseTypeAlias p typ in - Some (uncurried, [], Asttypes.Nolabel, typ, startPos) - end - | _ -> - let typ = parseTypExpr p in - let typWithAttributes = {typ with ptyp_attributes = List.concat[attrs; typ.ptyp_attributes]} in - Some (uncurried, [], Asttypes.Nolabel, typWithAttributes, startPos) - ) else - None - - (* (int, ~x:string, float) *) - and parseTypeParameters p = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - let typ = Ast_helper.Typ.constr unitConstr [] in - [(false, [], Asttypes.Nolabel, typ, startPos)] - | _ -> - let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen ~f:parseTypeParameter p - in - Parser.expect Rparen p; - params - - and parseEs6ArrowType ~attrs p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Tilde -> - Parser.next p; - let (name, _loc) = parseLident p in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parseTypExpr ~alias:false ~es6Arrow:false p in - let arg = match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Asttypes.Optional name - | _ -> - Asttypes.Labelled name - in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - Ast_helper.Typ.arrow ~attrs arg typ returnType - | _ -> - let parameters = parseTypeParameters p in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let endPos = p.prevEndPos in - let typ = List.fold_right (fun (uncurried, attrs, argLbl, typ, startPos) t -> - let attrs = if uncurried then uncurryAttr::attrs else attrs in - Ast_helper.Typ.arrow ~loc:(mkLoc startPos endPos) ~attrs argLbl typ t - ) parameters returnType - in - {typ with - ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; - ptyp_loc = mkLoc startPos p.prevEndPos} - - (* - * typexpr ::= - * | 'ident - * | _ - * | (typexpr) - * | typexpr => typexpr --> es6 arrow - * | (typexpr, typexpr) => typexpr --> es6 arrow - * | /typexpr, typexpr, typexpr/ --> tuple - * | typeconstr - * | typeconstr - * | typeconstr - * | typexpr as 'ident - * | %attr-id --> extension - * | %attr-id(payload) --> extension - * - * typeconstr ::= - * | lident - * | uident.lident - * | uident.uident.lident --> long module path - *) - and parseTypExpr ?attrs ?(es6Arrow=true) ?(alias=true) p = - (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) - let startPos = p.Parser.startPos in - let attrs = match attrs with - | Some attrs -> - attrs - | None -> - parseAttributes p in - let typ = if es6Arrow && isEs6ArrowType p then - parseEs6ArrowType ~attrs p - else - let typ = parseAtomicTypExpr ~attrs p in - parseArrowTypeRest ~es6Arrow ~startPos typ p - in - let typ = if alias then parseTypeAlias p typ else typ in - (* Parser.eatBreadcrumb p; *) - typ - - and parseArrowTypeRest ~es6Arrow ~startPos typ p = - match p.Parser.token with - | (EqualGreater | MinusGreater) as token when es6Arrow == true -> - (* error recovery *) - if token = MinusGreater then ( - Parser.expect EqualGreater p; - ); - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - | _ -> typ - - and parseTypExprRegion p = - if Grammar.isTypExprStart p.Parser.token then - Some (parseTypExpr p) - else - None - - and parseTupleType ~attrs ~first ~startPos p = - let typexprs = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p - in - Parser.expect Rparen p; - let tupleLoc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc (first::typexprs) - - and parseTypeConstructorArgRegion p = - if Grammar.isTypExprStart p.Parser.token then - Some (parseTypExpr p) - else if p.token = LessThan then ( - Parser.next p; - parseTypeConstructorArgRegion p - ) else - None - - (* Js.Nullable.value<'a> *) - and parseTypeConstructorArgs ~constrName p = - let opening = p.Parser.token in - let openingStartPos = p.startPos in - match opening with - | LessThan | Lparen -> - Scanner.setDiamondMode p.scanner; - Parser.next p; - let typeArgs = - (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:GreaterThan - ~f:parseTypeConstructorArgRegion - p - in - let () = match p.token with - | Rparen when opening = Token.Lparen -> - let typ = Ast_helper.Typ.constr constrName typeArgs in - let msg = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent ( - Doc.concat [ - Doc.line; - Printer.printTypExpr typ CommentTable.empty; - ] - ) - ] - ) |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> - Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - typeArgs - | _ -> [] - - (* string-field-decl ::= - * | string: poly-typexpr - * | attributes string-field-decl *) - and parseStringFieldDeclaration p = - let attrs = parseAttributes p in - match p.Parser.token with - | String name -> - let nameStartPos = p.startPos in - let nameEndPos = p.endPos in - Parser.next p; - let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some(Parsetree.Otag (fieldName, attrs, typ)) - | _token -> - None - - (* field-decl ::= - * | [mutable] field-name : poly-typexpr - * | attributes field-decl *) - and parseFieldDeclaration p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - let mut = if Parser.optional p Token.Mutable then - Asttypes.Mutable - else - Asttypes.Immutable - in - let (lident, loc) = match p.token with - | List -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - ("list", loc) - | _ -> parseLident p - in - let name = Location.mkloc lident loc in - let typ = match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] - in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - Ast_helper.Type.field ~attrs ~loc ~mut name typ - - - and parseFieldDeclarationRegion p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - let mut = if Parser.optional p Token.Mutable then - Asttypes.Mutable - else - Asttypes.Immutable - in - match p.token with - | Lident _ | List -> - let (lident, loc) = match p.token with - | List -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - ("list", loc) - | _ -> parseLident p - in - let name = Location.mkloc lident loc in - let typ = match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] - in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - Some(Ast_helper.Type.field ~attrs ~loc ~mut name typ) - | _ -> - None - - (* record-decl ::= - * | { field-decl } - * | { field-decl, field-decl } - * | { field-decl, field-decl, field-decl, } - *) - and parseRecordDeclaration p = - Parser.leaveBreadcrumb p Grammar.RecordDecl; - Parser.expect Lbrace p; - let rows = - parseCommaDelimitedRegion - ~grammar:Grammar.RecordDecl - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - in - Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - rows - - (* constr-args ::= - * | (typexpr) - * | (typexpr, typexpr) - * | (typexpr, typexpr, typexpr,) - * | (record-decl) - * - * TODO: should we overparse inline-records in every position? - * Give a good error message afterwards? - *) - and parseConstrDeclArgs p = - let constrArgs = match p.Parser.token with - | Lparen -> - Parser.next p; - (* TODO: this could use some cleanup/stratification *) - begin match p.Parser.token with - | Lbrace -> - let lbrace = p.startPos in - Parser.next p; - let startPos = p.Parser.startPos in - begin match p.Parser.token with - | DotDot | Dot -> - let closedFlag = match p.token with - | DotDot -> Parser.next p; Asttypes.Open - | Dot -> Parser.next p; Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ::moreArgs) - | _ -> - let attrs = parseAttributes p in - begin match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - begin match field with - | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - end - in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - ) in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ::moreArgs) - | _ -> - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - | attrs -> - let first = - let field = parseFieldDeclaration p in - Parser.expect Comma p; - {field with Parsetree.pld_attributes = attrs} - in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - ) - in - let () = match fields with - | [] -> Parser.err ~startPos:lbrace p ( - Diagnostics.message "An inline record declaration needs at least one field" - ) - | _ -> () - in - Parser.expect Rbrace p; - Parser.optional p Comma |> ignore; - Parser.expect Rparen p; - Parsetree.Pcstr_record fields - end - end - | _ -> - let args = - parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple args - end - | _ -> Pcstr_tuple [] - in - let res = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseTypExpr p) - | _ -> None - in - (constrArgs, res) - - (* constr-decl ::= - * | constr-name - * | attrs constr-name - * | constr-name const-args - * | attrs constr-name const-args *) - and parseTypeConstructorDeclarationWithBar p = - match p.Parser.token with - | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - Some (parseTypeConstructorDeclaration ~startPos p) - | _ -> None - - and parseTypeConstructorDeclaration ~startPos p = - Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration; - let attrs = parseAttributes p in - match p.Parser.token with - | Uident uident -> - let uidentLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let (args, res) = parseConstrDeclArgs p in - Parser.eatBreadcrumb p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.constructor ~loc ~attrs ?res ~args (Location.mkloc uident uidentLoc) - | t -> - Parser.err p (Diagnostics.uident t); - Ast_helper.Type.constructor (Location.mknoloc "_") - - (* [|] constr-decl { | constr-decl } *) - and parseTypeConstructorDeclarations ?first p = - let firstConstrDecl = match first with - | None -> - let startPos = p.Parser.startPos in - ignore (Parser.optional p Token.Bar); - parseTypeConstructorDeclaration ~startPos p - | Some firstConstrDecl -> - firstConstrDecl - in - firstConstrDecl::( - parseRegion - ~grammar:Grammar.ConstructorDeclaration - ~f:parseTypeConstructorDeclarationWithBar - p - ) - - (* - * type-representation ::= - * ∣ = [ | ] constr-decl { | constr-decl } - * ∣ = private [ | ] constr-decl { | constr-decl } - * | = | - * ∣ = private | - * ∣ = record-decl - * ∣ = private record-decl - * | = .. - *) - and parseTypeRepresentation p = - Parser.leaveBreadcrumb p Grammar.TypeRepresentation; - (* = consumed *) - let privateFlag = - if Parser.optional p Token.Private - then Asttypes.Private - else Asttypes.Public - in - let kind = match p.Parser.token with - | Bar | Uident _ -> - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) - | Lbrace -> - Parsetree.Ptype_record (parseRecordDeclaration p) - | DotDot -> - Parser.next p; - Ptype_open - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - (* TODO: I have no idea if this is even remotely a good idea *) - Parsetree.Ptype_variant [] - in - Parser.eatBreadcrumb p; - (privateFlag, kind) - - (* type-param ::= - * | variance 'lident - * | variance _ - * - * variance ::= - * | + - * | - - * | (* empty *) - *) - and parseTypeParam p = - let variance = match p.Parser.token with - | Plus -> Parser.next p; Asttypes.Covariant - | Minus -> Parser.next p; Contravariant - | _ -> Invariant - in - match p.Parser.token with - | SingleQuote -> - Parser.next p; - let (ident, loc) = parseLident p in - Some (Ast_helper.Typ.var ~loc ident, variance) - | Underscore -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Some (Ast_helper.Typ.any ~loc (), variance) - (* TODO: should we try parsing lident as 'ident ? *) - | _token -> - None - - (* type-params ::= - * | - * ∣ - * ∣ - * ∣ - * - * TODO: when we have pretty-printer show an error - * with the actual code corrected. *) - and parseTypeParams ~parent p = - let opening = p.Parser.token in - match opening with - | LessThan | Lparen when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> - Scanner.setDiamondMode p.scanner; - let openingStartPos = p.startPos in - Parser.leaveBreadcrumb p Grammar.TypeParams; - Parser.next p; - let params = - parseCommaDelimitedRegion - ~grammar:Grammar.TypeParams - ~closing:GreaterThan - ~f:parseTypeParam - p - in - let () = match p.token with - | Rparen when opening = Token.Lparen -> - let msg = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.concat [ - Printer.printLongident parent.Location.txt; - Printer.printTypeParams params CommentTable.empty; - ] - ] - ) - ] - ) |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> - Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - Parser.eatBreadcrumb p; - params - | _ -> [] - - (* type-constraint ::= constraint ' ident = typexpr *) - and parseTypeConstraint p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Token.Constraint -> - Parser.next p; - Parser.expect SingleQuote p; - begin match p.Parser.token with - | Lident ident -> - let identLoc = mkLoc startPos p.endPos in - Parser.next p; - Parser.expect Equal p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) - | t -> - Parser.err p (Diagnostics.lident t); - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.any (), parseTypExpr p, loc) - end - | _ -> None - - (* type-constraints ::= - * | (* empty *) - * | type-constraint - * | type-constraint type-constraint - * | type-constraint type-constraint type-constraint (* 0 or more *) - *) - and parseTypeConstraints p = - parseRegion - ~grammar:Grammar.TypeConstraint - ~f:parseTypeConstraint - p - - and parseTypeEquationOrConstrDecl p = - let uidentStartPos = p.Parser.startPos in - match p.Parser.token with - | Uident uident -> - Parser.next p; - begin match p.Parser.token with - | Dot -> - Parser.next p; - let typeConstr = - parseValuePathTail p uidentStartPos (Longident.Lident uident) - in - let loc = mkLoc uidentStartPos p.prevEndPos in - let typ = parseTypeAlias p ( - Ast_helper.Typ.constr ~loc typeConstr (parseTypeConstructorArgs ~constrName:typeConstr p) - ) in - begin match p.token with - | Equal -> - Parser.next p; - let (priv, kind) = parseTypeRepresentation p in - (Some typ, priv, kind) - | EqualGreater -> - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc uidentStartPos p.prevEndPos in - let arrowType = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in - let typ = parseTypeAlias p arrowType in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - end - | _ -> - let uidentEndPos = p.endPos in - let (args, res) = parseConstrDeclArgs p in - let first = Some ( - let uidentLoc = mkLoc uidentStartPos uidentEndPos in - Ast_helper.Type.constructor - ~loc:(mkLoc uidentStartPos p.prevEndPos) - ?res - ~args - (Location.mkloc uident uidentLoc) - ) in - (None, Asttypes.Public, Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first)) - end - | t -> - Parser.err p (Diagnostics.uident t); - (* TODO: is this a good idea? *) - (None, Asttypes.Public, Parsetree.Ptype_abstract) - - and parseRecordOrBsObjectDecl p = - let startPos = p.Parser.startPos in - Parser.expect Lbrace p; - match p.Parser.token with - | DotDot | Dot -> - let closedFlag = match p.token with - | DotDot -> Parser.next p; Asttypes.Open - | Dot -> Parser.next p; Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> - let attrs = parseAttributes p in - begin match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - begin match field with - | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - end - in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace - ~f:parseStringFieldDeclaration - p - ) - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - makeBsObjType ~attrs:[] ~loc ~closed:closedFlag fields |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> - Parser.leaveBreadcrumb p Grammar.RecordDecl; - let fields = match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - | attr::_ as attrs -> - let first = - let field = parseFieldDeclaration p in - Parser.optional p Comma |> ignore; - {field with - Parsetree.pld_attributes = attrs; - pld_loc = { - field.Parsetree.pld_loc with loc_start = - (attr |> fst).loc.loc_start - } - } - in - first::( - parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace - ~f:parseFieldDeclarationRegion - p - ) - in - let () = match fields with - | [] -> Parser.err ~startPos p ( - Diagnostics.message "A record needs at least one field" - ) - | _ -> () - in - Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - (None, Asttypes.Public, Parsetree.Ptype_record fields) - end - - and parsePrivateEqOrRepr p = - Parser.expect Private p; - match p.Parser.token with - | Lbrace -> - let (manifest, _ ,kind) = parseRecordOrBsObjectDecl p in - (manifest, Asttypes.Private, kind) - | Uident _ -> - let (manifest, _, kind) = parseTypeEquationOrConstrDecl p in - (manifest, Asttypes.Private, kind) - | Bar | DotDot -> - let (_, kind) = parseTypeRepresentation p in - (None, Asttypes.Private, kind) - | t when Grammar.isTypExprStart t -> - (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) - | _ -> - let (_, kind) = parseTypeRepresentation p in - (None, Asttypes.Private, kind) - - (* - polymorphic-variant-type ::= - | [ tag-spec-first { | tag-spec } ] - | [> [ tag-spec ] { | tag-spec } ] - | [< [|] tag-spec-full { | tag-spec-full } [ > { `tag-name }+ ] ] - - tag-spec-first ::= `tag-name [ of typexpr ] - | [ typexpr ] | tag-spec - - tag-spec ::= `tag-name [ of typexpr ] - | typexpr - - tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ] - | typexpr - *) - and parsePolymorphicVariantType ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Lbracket p; - match p.token with - | GreaterThan -> - Parser.next p; - let rowFields = - begin match p.token with - | Rbracket -> - [] - | Bar -> - parseTagSpecs p - | _ -> - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p - end - in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc rowFields Open None in - Parser.expect Rbracket p; - variant - | LessThan -> - Parser.next p; - Parser.optional p Bar |> ignore; - let rowField = parseTagSpecFull p in - let rowFields = parseTagSpecFulls p in - let tagNames = - if p.token == GreaterThan - then begin - Parser.next p; - let rec loop p = match p.Parser.token with - | Rbracket -> [] - | _ -> - let (ident, _loc) = parseHashIdent ~startPos:p.startPos p in - ident :: loop p - in - loop p - end - else [] in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed (Some tagNames) in - Parser.expect Rbracket p; - variant - | _ -> - let rowFields1 = parseTagSpecFirst p in - let rowFields2 = parseTagSpecs p in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None in - Parser.expect Rbracket p; - variant - - and parseTagSpecFulls p = - match p.Parser.token with - | Rbracket -> - [] - | GreaterThan -> - [] - | Bar -> - Parser.next p; - let rowField = parseTagSpecFull p in - rowField ::parseTagSpecFulls p - | _ -> - [] - - and parseTagSpecFull p = - let attrs = parseAttributes p in - match p.Parser.token with - | Hash -> - parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p - | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ - - and parseTagSpecs p = - match p.Parser.token with - | Bar -> - Parser.next p; - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p - | _ -> - [] - - and parseTagSpec p = - let attrs = parseAttributes p in - match p.Parser.token with - | Hash -> - parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p - | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ - - and parseTagSpecFirst p = - let attrs = parseAttributes p in - match p.Parser.token with - | Bar -> - Parser.next p; - [parseTagSpec p] - | Hash -> - [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] - | _ -> - let typ = parseTypExpr ~attrs p in - Parser.expect Bar p; - [Parsetree.Rinherit typ; parseTagSpec p] - - and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = - let startPos = p.Parser.startPos in - let (ident, loc) = parseHashIdent ~startPos p in - let rec loop p = - match p.Parser.token with - | Band when full -> - Parser.next p; - let rowField = parsePolymorphicVariantTypeArgs p in - rowField :: loop p - | _ -> - [] - in - let firstTuple, tagContainsAConstantEmptyConstructor = - match p.Parser.token with - | Band when full -> - Parser.next p; - [parsePolymorphicVariantTypeArgs p], true - | Lparen -> - [parsePolymorphicVariantTypeArgs p], false - | _ -> - [], true - in - let tuples = firstTuple @ loop p in - Parsetree.Rtag ( - Location.mkloc ident loc, - attrs, - tagContainsAConstantEmptyConstructor, - tuples - ) - - and parsePolymorphicVariantTypeArgs p = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - let args = parseCommaDelimitedRegion - ~grammar:Grammar.TypExprList - ~closing:Rparen - ~f:parseTypExprRegion - p - in - Parser.expect Rparen p; - let attrs = [] in - let loc = mkLoc startPos p.prevEndPos in - match args with - | [{ptyp_desc = Ptyp_tuple _} as typ] as types -> - if p.mode = ParseForTypeChecker then - typ - else - Ast_helper.Typ.tuple ~loc ~attrs types - | [typ] -> typ - | types -> Ast_helper.Typ.tuple ~loc ~attrs types - - and parseTypeEquationAndRepresentation p = - match p.Parser.token with - | Equal | Bar as token -> - if token = Bar then Parser.expect Equal p; - Parser.next p; - begin match p.Parser.token with - | Uident _ -> - parseTypeEquationOrConstrDecl p - | Lbrace -> - parseRecordOrBsObjectDecl p - | Private -> - parsePrivateEqOrRepr p - | Bar | DotDot -> - let (priv, kind) = parseTypeRepresentation p in - (None, priv, kind) - | _ -> - let manifest = Some (parseTypExpr p) in - begin match p.Parser.token with - | Equal -> - Parser.next p; - let (priv, kind) = parseTypeRepresentation p in - (manifest, priv, kind) - | _ -> - (manifest, Public, Parsetree.Ptype_abstract) - end - end - | _ -> (None, Public, Parsetree.Ptype_abstract) - - (* type-definition ::= type [rec] typedef { and typedef } - * typedef ::= typeconstr-name [type-params] type-information - * type-information ::= [type-equation] [type-representation] { type-constraint } - * type-equation ::= = typexpr *) - and parseTypeDef ~attrs ~startPos p = - Parser.leaveBreadcrumb p Grammar.TypeDef; - (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *) - Parser.leaveBreadcrumb p Grammar.TypeConstrName; - let (name, loc) = parseLident p in - let typeConstrName = Location.mkloc name loc in - Parser.eatBreadcrumb p; - let params = - let constrName = Location.mkloc (Longident.Lident name) loc in - parseTypeParams ~parent:constrName p in - let typeDef = - let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in - let cstrs = parseTypeConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.mk - ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest typeConstrName - in - Parser.eatBreadcrumb p; - typeDef - - and parseTypeExtension ~params ~attrs ~name p = - Parser.expect PlusEqual p; - let priv = - if Parser.optional p Token.Private - then Asttypes.Private - else Asttypes.Public - in - let constrStart = p.Parser.startPos in - Parser.optional p Bar |> ignore; - let first = - let (attrs, name, kind) = match p.Parser.token with - | Bar -> - Parser.next p; - parseConstrDef ~parseAttrs:true p - | _ -> - parseConstrDef ~parseAttrs:true p - in - let loc = mkLoc constrStart p.prevEndPos in - Ast_helper.Te.constructor ~loc ~attrs name kind - in - let rec loop p cs = - match p.Parser.token with - | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - let (attrs, name, kind) = parseConstrDef ~parseAttrs:true p in - let extConstr = - Ast_helper.Te.constructor ~attrs ~loc:(mkLoc startPos p.prevEndPos) name kind - in - loop p (extConstr::cs) - | _ -> - List.rev cs - in - let constructors = loop p [first] in - Ast_helper.Te.mk ~attrs ~params ~priv name constructors - - and parseTypeDefinitions ~attrs ~name ~params ~startPos p = - let typeDef = - let (manifest, priv, kind) = parseTypeEquationAndRepresentation p in - let cstrs = parseTypeConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.mk - ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - {name with txt = lidentOfPath name.Location.txt} - in - let rec loop p defs = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - Parser.next p; - let attrs = match p.token with - | Export -> - let exportLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - genTypeAttr::attrs - | _ -> attrs - in - let typeDef = parseTypeDef ~attrs ~startPos p in - loop p (typeDef::defs) - | _ -> - List.rev defs - in - loop p [typeDef] - - (* TODO: decide if we really want type extensions (eg. type x += Blue) - * It adds quite a bit of complexity that can be avoided, - * implemented for now. Needed to get a feel for the complexities of - * this territory of the grammar *) - and parseTypeDefinitionOrExtension ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Token.Typ p; - let recFlag = match p.token with - | Rec -> Parser.next p; Asttypes.Recursive - | Lident "nonrec" -> - Parser.next p; - Asttypes.Nonrecursive - | _ -> Asttypes.Nonrecursive - in - let name = parseValuePath p in - let params = parseTypeParams ~parent:name p in - match p.Parser.token with - | PlusEqual -> - TypeExt(parseTypeExtension ~params ~attrs ~name p) - | _ -> - let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in - TypeDef {recFlag; types = typeDefs} - - and parsePrimitive p = - match p.Parser.token with - | String s -> Parser.next p; Some s - | _ -> None - - and parsePrimitives p = - match (parseRegion ~grammar:Grammar.Primitive ~f:parsePrimitive p) with - | [] -> - let msg = "An external definition should have at least one primitive. Example: \"setTimeout\"" in - Parser.err p (Diagnostics.message msg); - [] - | primitives -> primitives - - (* external value-name : typexp = external-declaration *) - and parseExternalDef ~attrs p = - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.External; - Parser.expect Token.External p; - let (name, loc) = parseLident p in - let name = Location.mkloc name loc in - Parser.expect ~grammar:(Grammar.TypeExpression) Colon p; - let typExpr = parseTypExpr p in - Parser.expect Equal p; - let prim = parsePrimitives p in - let loc = mkLoc startPos p.prevEndPos in - let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in - Parser.eatBreadcrumb p; - vb - - (* constr-def ::= - * | constr-decl - * | constr-name = constr - * - * constr-decl ::= constr-name constr-args - * constr-name ::= uident - * constr ::= path-uident *) - and parseConstrDef ~parseAttrs p = - let attrs = if parseAttrs then parseAttributes p else [] in - let name = match p.Parser.token with - | Uident name -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc name loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let kind = match p.Parser.token with - | Lparen -> - let (args, res) = parseConstrDeclArgs p in - Parsetree.Pext_decl (args, res) - | Equal -> - Parser.next p; - let longident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pext_rebind longident - | _ -> - Parsetree.Pext_decl (Pcstr_tuple [], None) - in - (attrs, name, kind) - - (* - * exception-definition ::= - * | exception constr-decl - * ∣ exception constr-name = constr - * - * constr-name ::= uident - * constr ::= long_uident *) - and parseExceptionDef ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Token.Exception p; - let (_, name, kind) = parseConstrDef ~parseAttrs:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Te.constructor ~loc ~attrs name kind - - (* module structure on the file level *) - and parseImplementation p : Parsetree.structure = - parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion - [@@progress (Parser.next, Parser.expect, Parser.checkProgress)] - - and parseStructureItemRegion p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Open -> - let openDescription = parseOpenDescription ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.open_ ~loc openDescription) - | Let -> - let (recFlag, letBindings) = parseLetBindings ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.value ~loc recFlag letBindings) - | Typ -> - Parser.beginRegion p; - begin match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_ ~loc recFlag types) - | TypeExt(ext) -> - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_extension ~loc ext) - end - | External -> - let externalDef = parseExternalDef ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.primitive ~loc externalDef) - | Import -> - let importDescr = parseJsImport ~startPos ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - let structureItem = JsFfi.toParsetree importDescr in - Some {structureItem with pstr_loc = loc} - | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.exception_ ~loc exceptionDef) - | Include -> - let includeStatement = parseIncludeStatement ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.include_ ~loc includeStatement) - | Export -> - let structureItem = parseJsExport ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some {structureItem with pstr_loc = loc} - | Module -> - let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some {structureItem with pstr_loc = loc} - | AtAt -> - let attr = parseStandaloneAttribute p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.attribute ~loc attr) - | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.extension ~attrs ~loc extension) - | token when Grammar.isExprStart token -> - let prevEndPos = p.Parser.endPos in - let exp = parseExpr p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Parser.checkProgress ~prevEndPos ~result:(Ast_helper.Str.eval ~loc ~attrs exp) p - | _ -> None - - and parseJsImport ~startPos ~attrs p = - Parser.expect Token.Import p; - let importSpec = match p.Parser.token with - | Token.Lident _ | Token.At -> - let decl = match parseJsFfiDeclaration p with - | Some decl -> decl - | None -> assert false - in - JsFfi.Default decl - | _ -> JsFfi.Spec(parseJsFfiDeclarations p) - in - let scope = parseJsFfiScope p in - let loc = mkLoc startPos p.prevEndPos in - JsFfi.importDescr ~attrs ~importSpec ~scope ~loc - - and parseJsExport ~attrs p = - let exportStart = p.Parser.startPos in - Parser.expect Token.Export p; - let exportLoc = mkLoc exportStart p.prevEndPos in - let genTypeAttr = (Location.mkloc "genType" exportLoc, Parsetree.PStr []) in - let attrs = genTypeAttr::attrs in - match p.Parser.token with - | Typ -> - begin match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - Ast_helper.Str.type_ recFlag types - | TypeExt(ext) -> - Ast_helper.Str.type_extension ext - end - | (* Let *) _ -> - let (recFlag, letBindings) = parseLetBindings ~attrs p in - Ast_helper.Str.value recFlag letBindings - - and parseJsFfiScope p = - match p.Parser.token with - | Token.Lident "from" -> - Parser.next p; - begin match p.token with - | String s -> Parser.next p; JsFfi.Module s - | Uident _ | Lident _ -> - let value = parseIdentPath p in - JsFfi.Scope value - | _ -> JsFfi.Global - end - | _ -> JsFfi.Global - - and parseJsFfiDeclarations p = - Parser.expect Token.Lbrace p; - let decls = parseCommaDelimitedRegion - ~grammar:Grammar.JsFfiImport - ~closing:Rbrace - ~f:parseJsFfiDeclaration - p - in - Parser.expect Rbrace p; - decls - - and parseJsFfiDeclaration p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Lident _ -> - let (ident, _) = parseLident p in - let alias = match p.token with - | As -> - Parser.next p; - let (ident, _) = parseLident p in - ident - | _ -> - ident - in - Parser.expect Token.Colon p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Some (JsFfi.decl ~loc ~alias ~attrs ~name:ident ~typ) - | _ -> None - - (* include-statement ::= include module-expr *) - and parseIncludeStatement ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Token.Include p; - let modExpr = parseModuleExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Incl.mk ~loc ~attrs modExpr - - and parseAtomicModuleExpr p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Uident _ident -> - let longident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mod.ident ~loc:longident.loc longident - | Lbrace -> - Parser.next p; - let structure = Ast_helper.Mod.structure ( - parseDelimitedRegion - ~grammar:Grammar.Structure - ~closing:Rbrace - ~f:parseStructureItemRegion - p - ) in - Parser.expect Rbrace p; - let endPos = p.prevEndPos in - {structure with pmod_loc = mkLoc startPos endPos} - | Lparen -> - Parser.next p; - let modExpr = match p.token with - | Rparen -> - Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] - | _ -> - parseConstrainedModExpr p - in - Parser.expect Rparen p; - modExpr - | Lident "unpack" -> (* TODO: should this be made a keyword?? *) - Parser.next p; - Parser.expect Lparen p; - let expr = parseExpr p in - begin match p.Parser.token with - | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let constraintExpr = Ast_helper.Exp.constraint_ - ~loc - expr packageType - in - Ast_helper.Mod.unpack ~loc constraintExpr - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.unpack ~loc expr - end - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.extension ~loc extension - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleExpr() - - and parsePrimaryModExpr p = - let startPos = p.Parser.startPos in - let modExpr = parseAtomicModuleExpr p in - let rec loop p modExpr = - match p.Parser.token with - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseModuleApplication p modExpr) - | _ -> modExpr - in - let modExpr = loop p modExpr in - {modExpr with pmod_loc = mkLoc startPos p.prevEndPos} - - (* - * functor-arg ::= - * | uident : modtype - * | _ : modtype - * | modtype --> "punning" for _ : modtype - * | attributes functor-arg - *) - and parseFunctorArg p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Uident ident -> - Parser.next p; - let uidentEndPos = p.prevEndPos in - begin match p.Parser.token with - | Colon -> - Parser.next p; - let moduleType = parseModuleType p in - let loc = mkLoc startPos uidentEndPos in - let argName = Location.mkloc ident loc in - Some (attrs, argName, Some moduleType, startPos) - | Dot -> - Parser.next p; - let moduleType = - let moduleLongIdent = - parseModuleLongIdentTail ~lowercase:false p startPos (Longident.Lident ident) in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent - in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos) - | _ -> - let loc = mkLoc startPos uidentEndPos in - let modIdent = Location.mkloc (Longident.Lident ident) loc in - let moduleType = Ast_helper.Mty.ident ~loc modIdent in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos) - end - | Underscore -> - Parser.next p; - let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in - Parser.expect Colon p; - let moduleType = parseModuleType p in - Some (attrs, argName, Some moduleType, startPos) - | _ -> - None - - and parseFunctorArgs p = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion - ~grammar:Grammar.FunctorArgs - ~closing:Rparen - ~f:parseFunctorArg - p - in - Parser.expect Rparen p; - match args with - | [] -> - [[], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos] - | args -> args - - and parseFunctorModuleExpr p = - let startPos = p.Parser.startPos in - let args = parseFunctorArgs p in - let returnType = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseModuleType ~es6Arrow:false p) - | _ -> None - in - Parser.expect EqualGreater p; - let rhsModuleExpr = - let modExpr = parseModuleExpr p in - match returnType with - | Some modType -> - Ast_helper.Mod.constraint_ - ~loc:(mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) - modExpr modType - | None -> modExpr - in - let endPos = p.prevEndPos in - let modExpr = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mod.functor_ - ~loc:(mkLoc startPos endPos) - ~attrs - name moduleType acc - ) args rhsModuleExpr - in - {modExpr with pmod_loc = mkLoc startPos endPos} - - (* module-expr ::= - * | module-path - * ∣ { structure-items } - * ∣ functorArgs => module-expr - * ∣ module-expr(module-expr) - * ∣ ( module-expr ) - * ∣ ( module-expr : module-type ) - * | extension - * | attributes module-expr *) - and parseModuleExpr p = - let attrs = parseAttributes p in - let modExpr = if isEs6ArrowFunctor p then - parseFunctorModuleExpr p - else - parsePrimaryModExpr p - in - {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} - - and parseConstrainedModExpr p = - let modExpr = parseModuleExpr p in - match p.Parser.token with - | Colon -> - Parser.next p; - let modType = parseModuleType p in - let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in - Ast_helper.Mod.constraint_ ~loc modExpr modType - | _ -> modExpr - - and parseConstrainedModExprRegion p = - if Grammar.isModExprStart p.Parser.token then - Some (parseConstrainedModExpr p) - else - None - - and parseModuleApplication p modExpr = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion - ~grammar:Grammar.ModExprList - ~closing:Rparen - ~f:parseConstrainedModExprRegion - p - in - Parser.expect Rparen p; - let args = match args with - | [] -> - let loc = mkLoc startPos p.prevEndPos in - [Ast_helper.Mod.structure ~loc []] - | args -> args - in - List.fold_left (fun modExpr arg -> - Ast_helper.Mod.apply - ~loc:(mkLoc modExpr.Parsetree.pmod_loc.loc_start arg.Parsetree.pmod_loc.loc_end) - modExpr arg - ) modExpr args - - and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Module p; - match p.Parser.token with - | Typ -> parseModuleTypeImpl ~attrs startPos p - | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - Ast_helper.Str.eval ~attrs expr - | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p - - and parseModuleTypeImpl ~attrs startPos p = - Parser.expect Typ p; - let nameStart = p.Parser.startPos in - let name = match p.Parser.token with - | List -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc "list" loc - | Lident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc - | Uident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - Parser.expect Equal p; - let moduleType = parseModuleType p in - let moduleTypeDeclaration = - Ast_helper.Mtd.mk - ~attrs - ~loc:(mkLoc nameStart p.prevEndPos) - ~typ:moduleType - name - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Str.modtype ~loc moduleTypeDeclaration - - (* definition ::= - ∣ module rec module-name : module-type = module-expr { and module-name - : module-type = module-expr } *) - and parseMaybeRecModuleBinding ~attrs ~startPos p = - match p.Parser.token with - | Token.Rec -> - Parser.next p; - Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) - | _ -> - Ast_helper.Str.module_ (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) - - and parseModuleBinding ~attrs ~startPos p = - let name = match p.Parser.token with - | Uident ident -> - let startPos = p.Parser.startPos in - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = parseModuleBindingBody p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mb.mk ~attrs ~loc name body - - and parseModuleBindingBody p = - (* TODO: make required with good error message when rec module binding *) - let returnModType = match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseModuleType p) - | _ -> None - in - Parser.expect Equal p; - let modExpr = parseModuleExpr p in - match returnModType with - | Some modType -> - Ast_helper.Mod.constraint_ - ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) - modExpr modType - | None -> modExpr - - - (* module-name : module-type = module-expr - * { and module-name : module-type = module-expr } *) - and parseModuleBindings ~attrs ~startPos p = - let rec loop p acc = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - Parser.next p; - ignore(Parser.optional p Module); (* over-parse for fault-tolerance *) - let modBinding = parseModuleBinding ~attrs ~startPos p in - loop p (modBinding::acc) - | _ -> List.rev acc - in - let first = parseModuleBinding ~attrs ~startPos p in - loop p [first] - - and parseAtomicModuleType p = - let startPos = p.Parser.startPos in - let moduleType = match p.Parser.token with - | Uident _ | Lident _ | List -> - (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } - * lets go with uppercase terminal for now *) - let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent - | Lparen -> - Parser.next p; - let mty = parseModuleType p in - Parser.expect Rparen p; - {mty with pmty_loc = mkLoc startPos p.prevEndPos} - | Lbrace -> - Parser.next p; - let spec = - parseDelimitedRegion - ~grammar:Grammar.Signature - ~closing:Rbrace - ~f:parseSignatureItemRegion - p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.signature ~loc spec - | Module -> (* TODO: check if this is still atomic when implementing first class modules*) - parseModuleTypeOf p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.extension ~loc extension - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType() - in - let moduleTypeLoc = mkLoc startPos p.prevEndPos in - {moduleType with pmty_loc = moduleTypeLoc} - - and parseFunctorModuleType p = - let startPos = p.Parser.startPos in - let args = parseFunctorArgs p in - Parser.expect EqualGreater p; - let rhs = parseModuleType p in - let endPos = p.prevEndPos in - let modType = List.fold_right (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mty.functor_ - ~loc:(mkLoc startPos endPos) - ~attrs - name moduleType acc - ) args rhs - in - {modType with pmty_loc = mkLoc startPos endPos} - - (* Module types are the module-level equivalent of type expressions: they - * specify the general shape and type properties of modules. - * - * module-type ::= - * | modtype-path - * | { signature } - * | ( module-type ) --> parenthesized module-type - * | functor-args => module-type --> functor - * | module-type => module-type --> functor - * | module type of module-expr - * | attributes module-type - * | module-type with-mod-constraints - * | extension - *) - and parseModuleType ?(es6Arrow=true) ?(with_=true) p = - let attrs = parseAttributes p in - let modty = if es6Arrow && isEs6ArrowFunctor p then - parseFunctorModuleType p - else - let modty = parseAtomicModuleType p in - match p.Parser.token with - | EqualGreater when es6Arrow == true -> - Parser.next p; - let rhs = parseModuleType ~with_:false p in - let str = Location.mknoloc "_" in - let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.functor_ ~loc str (Some modty) rhs - | _ -> modty - in - let moduleType = { modty with - pmty_attributes = List.concat [modty.pmty_attributes; attrs] - } in - if with_ then - parseWithConstraints moduleType p - else moduleType - - - and parseWithConstraints moduleType p = - match p.Parser.token with - | With -> - Parser.next p; - let first = parseWithConstraint p in - let rec loop p acc = - match p.Parser.token with - | And -> - Parser.next p; - loop p ((parseWithConstraint p)::acc) - | _ -> - List.rev acc - in - let constraints = loop p [first] in - let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.with_ ~loc moduleType constraints - | _ -> - moduleType - - (* mod-constraint ::= - * | type typeconstr type-equation type-constraints? - * ∣ type typeconstr-name := typexpr - * ∣ module module-path = extended-module-path - * ∣ module module-path := extended-module-path - * - * TODO: split this up into multiple functions, better errors *) - and parseWithConstraint p = - match p.Parser.token with - | Module -> - Parser.next p; - let modulePath = parseModuleLongIdent ~lowercase:false p in - begin match p.Parser.token with - | ColonEqual -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident) - | Equal -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_module (modulePath, lident) - | token -> - (* TODO: revisit *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident) - end - | Typ -> - Parser.next p; - let typeConstr = parseValuePath p in - let params = parseTypeParams ~parent:typeConstr p in - begin match p.Parser.token with - | ColonEqual -> - Parser.next p; - let typExpr = parseTypExpr p in - Parsetree.Pwith_typesubst ( - typeConstr, - Ast_helper.Type.mk - ~loc:typeConstr.loc - ~params - ~manifest:typExpr - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) - ) - | Equal -> - Parser.next p; - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type ( - typeConstr, - Ast_helper.Type.mk - ~loc:typeConstr.loc - ~params - ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) - ) - | token -> - (* TODO: revisit *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type ( - typeConstr, - Ast_helper.Type.mk - ~loc:typeConstr.loc - ~params - ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) - ) - end - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - exit (-1) (* TODO: handle this case *) - - and parseModuleTypeOf p = - let startPos = p.Parser.startPos in - Parser.expect Module p; - Parser.expect Typ p; - Parser.expect Of p; - let moduleExpr = parseModuleExpr p in - Ast_helper.Mty.typeof_ ~loc:(mkLoc startPos p.prevEndPos) moduleExpr - - (* module signature on the file level *) - and parseSpecification p = - parseRegion ~grammar:Grammar.Specification ~f:parseSignatureItemRegion p - [@@progress (Parser.next, Parser.expect, Parser.checkProgress)] - - and parseSignatureItemRegion p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Let -> - Parser.beginRegion p; - let valueDesc = parseSignLetDesc ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.value ~loc valueDesc) - | Typ -> - Parser.beginRegion p; - begin match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.type_ ~loc recFlag types) - | TypeExt(ext) -> - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.type_extension ~loc ext) - end - | External -> - let externalDef = parseExternalDef ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.value ~loc externalDef) - | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.exception_ ~loc exceptionDef) - | Open -> - let openDescription = parseOpenDescription ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.open_ ~loc openDescription) - | Include -> - Parser.next p; - let moduleType = parseModuleType p in - let includeDescription = Ast_helper.Incl.mk - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs - moduleType - in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.include_ ~loc includeDescription) - | Module -> - Parser.next p; - begin match p.Parser.token with - | Uident _ -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.module_ ~loc modDecl) - | Rec -> - let recModule = parseRecModuleSpec ~attrs ~startPos p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.rec_module ~loc recModule) - | Typ -> - Some (parseModuleTypeDeclaration ~attrs ~startPos p) - | _t -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.module_ ~loc modDecl) - end - | AtAt -> - let attr = parseStandaloneAttribute p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.attribute ~loc attr) - | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - Parser.optional p Semicolon |> ignore; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.extension ~attrs ~loc extension) - | Import -> - Parser.next p; - parseSignatureItemRegion p - | _ -> - None - - (* module rec module-name : module-type { and module-name: module-type } *) - and parseRecModuleSpec ~attrs ~startPos p = - Parser.expect Rec p; - let rec loop p spec = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - (* TODO: give a good error message when with constraint, no parens - * and ASet: (Set.S with type elt = A.t) - * and BTree: (Btree.S with type elt = A.t) - * Without parens, the `and` signals the start of another - * `with-constraint` - *) - Parser.expect And p; - let decl = parseRecModuleDeclaration ~attrs ~startPos p in - loop p (decl::spec) - | _ -> - List.rev spec - in - let first = parseRecModuleDeclaration ~attrs ~startPos p in - loop p [first] - - (* module-name : module-type *) - and parseRecModuleDeclaration ~attrs ~startPos p = - let name = match p.Parser.token with - | Uident modName -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc modName loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - Parser.expect Colon p; - let modType = parseModuleType p in - Ast_helper.Md.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs name modType - - and parseModuleDeclarationOrAlias ~attrs p = - let startPos = p.Parser.startPos in - let moduleName = match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.Parser.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = match p.Parser.token with - | Colon -> - Parser.next p; - parseModuleType p - | Equal -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mty.alias lident - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType() - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Md.mk ~loc ~attrs moduleName body - - and parseModuleTypeDeclaration ~attrs ~startPos p = - Parser.expect Typ p; - let moduleName = match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | Lident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let typ = match p.Parser.token with - | Equal -> - Parser.next p; - Some (parseModuleType p) - | _ -> None - in - let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in - Ast_helper.Sig.modtype ~loc:(mkLoc startPos p.prevEndPos) moduleDecl - - and parseSignLetDesc ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Let p; - let (name, loc) = parseLident p in - let name = Location.mkloc name loc in - Parser.expect Colon p; - let typExpr = parsePolyTypeExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Val.mk ~loc ~attrs name typExpr - -(* attr-id ::= lowercase-ident - ∣ capitalized-ident - ∣ attr-id . attr-id *) - and parseAttributeId p = - let startPos = p.Parser.startPos in - let rec loop p acc = - match p.Parser.token with - | Lident ident | Uident ident -> - Parser.next p; - let id = acc ^ ident in - begin match p.Parser.token with - | Dot -> Parser.next p; loop p (id ^ ".") - | _ -> id - end - | token when Token.isKeyword token -> - Parser.next p; - let id = acc ^ (Token.toString token) in - begin match p.Parser.token with - | Dot -> Parser.next p; loop p (id ^ ".") - | _ -> id - end - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - acc - in - let id = loop p "" in - let endPos = p.prevEndPos in - Location.mkloc id (mkLoc startPos endPos) - - (* - * payload ::= empty - * | ( structure-item ) - * - * TODO: what about multiple structure items? - * @attr({let x = 1; let x = 2}) - * - * Also what about type-expressions and specifications? - * @attr(:myType) ??? - *) - and parsePayload p = - match p.Parser.token with - | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> - Parser.next p; - begin match p.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - Parser.expect Rparen p; - Parsetree.PTyp typ - | _ -> - let items = parseDelimitedRegion - ~grammar:Grammar.Structure - ~closing:Rparen - ~f:parseStructureItemRegion - p - in - Parser.expect Rparen p; - Parsetree.PStr items - end - | _ -> Parsetree.PStr [] - - (* type attribute = string loc * payload *) - and parseAttribute p = - match p.Parser.token with - | At -> - Parser.next p; - let attrId = parseAttributeId p in - let payload = parsePayload p in - Some(attrId, payload) - | _ -> None - - and parseAttributes p = - parseRegion p - ~grammar:Grammar.Attribute - ~f:parseAttribute - - (* - * standalone-attribute ::= - * | @@ atribute-id - * | @@ attribute-id ( structure-item ) - *) - and parseStandaloneAttribute p = - Parser.expect AtAt p; - let attrId = parseAttributeId p in - let payload = parsePayload p in - (attrId, payload) - - (* extension ::= % attr-id attr-payload - * | %% attr-id( - * expr ::= ... - * ∣ extension - * - * typexpr ::= ... - * ∣ extension - * - * pattern ::= ... - * ∣ extension - * - * module-expr ::= ... - * ∣ extension - * - * module-type ::= ... - * ∣ extension - * - * class-expr ::= ... - * ∣ extension - * - * class-type ::= ... - * ∣ extension - * - * - * item extension nodes usable in structures and signature - * - * item-extension ::= %% attr-id - * | %% attr-id(structure-item) - * - * attr-payload ::= structure-item - * - * ~moduleLanguage represents whether we're on the module level or not - *) - and parseExtension ?(moduleLanguage=false) p = - if moduleLanguage then - Parser.expect PercentPercent p - else - Parser.expect Percent p; - let attrId = parseAttributeId p in - let payload = parsePayload p in - (attrId, payload) -end - -module OutcomePrinter: sig - open Format - open Outcometree - - val out_value : (formatter -> out_value -> unit) ref [@@live] - val out_type : (formatter -> out_type -> unit) ref [@@live] - val out_class_type : (formatter -> out_class_type -> unit) ref [@@live] - val out_module_type : (formatter -> out_module_type -> unit) ref [@@live] - val out_sig_item : (formatter -> out_sig_item -> unit) ref [@@live] - val out_signature : (formatter -> out_sig_item list -> unit) ref [@@live] - val out_type_extension : (formatter -> out_type_extension -> unit) ref [@@live] - val out_phrase : (formatter -> out_phrase -> unit) ref [@@live] - - val parenthesized_ident : string -> bool [@@live] -end = struct - (* Napkin doesn't have parenthesized identifiers. - * We don't support custom operators. *) - let parenthesized_ident _name = true - - (* TODO: better allocation strategy for the buffer *) - let escapeStringContents s = - let len = String.length s in - let b = Buffer.create len in - for i = 0 to len - 1 do - let c = (String.get [@doesNotRaise]) s i in - if c = '\008' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'b'; - ) else if c = '\009' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 't'; - ) else if c = '\010' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'n'; - ) else if c = '\013' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'r'; - ) else if c = '\034' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '"'; - ) else if c = '\092' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\'; - ) else ( - Buffer.add_char b c; - ); - done; - Buffer.contents b - - (* let rec print_ident fmt ident = match ident with - | Outcometree.Oide_ident s -> Format.pp_print_string fmt s - | Oide_dot (id, s) -> - print_ident fmt id; - Format.pp_print_char fmt '.'; - Format.pp_print_string fmt s - | Oide_apply (id1, id2) -> - print_ident fmt id1; - Format.pp_print_char fmt '('; - print_ident fmt id2; - Format.pp_print_char fmt ')' *) - - let rec printOutIdentDoc (ident : Outcometree.out_ident) = - match ident with - | Oide_ident s -> Doc.text s - | Oide_dot (ident, s) -> Doc.concat [ - printOutIdentDoc ident; - Doc.dot; - Doc.text s; - ] - | Oide_apply (call, arg) ->Doc.concat [ - printOutIdentDoc call; - Doc.lparen; - printOutIdentDoc arg; - Doc.rparen; - ] - - let printOutAttributeDoc (outAttribute: Outcometree.out_attribute) = - Doc.concat [ - Doc.text "@"; - Doc.text outAttribute.oattr_name; - ] - - let printOutAttributesDoc (attrs: Outcometree.out_attribute list) = - match attrs with - | [] -> Doc.nil - | attrs -> - Doc.concat [ - Doc.group ( - Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs) - ); - Doc.line; - ] - - let rec collectArrowArgs (outType: Outcometree.out_type) args = - match outType with - | Otyp_arrow (label, argType, returnType) -> - let arg = (label, argType) in - collectArrowArgs returnType (arg::args) - | _ as returnType -> - (List.rev args, returnType) - - let rec collectFunctorArgs (outModuleType: Outcometree.out_module_type) args = - match outModuleType with - | Omty_functor (lbl, optModType, returnModType) -> - let arg = (lbl, optModType) in - collectFunctorArgs returnModType (arg::args) - | _ -> - (List.rev args, outModuleType) - - let rec printOutTypeDoc (outType: Outcometree.out_type) = - match outType with - | Otyp_abstract | Otyp_variant _ (* don't support poly-variants atm *) | Otyp_open -> Doc.nil - | Otyp_alias (typ, aliasTxt) -> - Doc.concat [ - printOutTypeDoc typ; - Doc.text " as '"; - Doc.text aliasTxt - ] - | Otyp_constr (outIdent, []) -> - printOutIdentDoc outIdent - | Otyp_manifest (typ1, typ2) -> - Doc.concat [ - printOutTypeDoc typ1; - Doc.text " = "; - printOutTypeDoc typ2; - ] - | Otyp_record record -> - printRecordDeclarationDoc ~inline:true record - | Otyp_stuff txt -> Doc.text txt - | Otyp_var (ng, s) -> Doc.concat [ - Doc.text ("'" ^ (if ng then "_" else "")); - Doc.text s - ] - | Otyp_object (fields, rest) -> printObjectFields fields rest - | Otyp_class _ -> Doc.nil - | Otyp_attribute (typ, attribute) -> - Doc.group ( - Doc.concat [ - printOutAttributeDoc attribute; - Doc.line; - printOutTypeDoc typ; - ] - ) - (* example: Red | Blue | Green | CustomColour(float, float, float) *) - | Otyp_sum constructors -> - printOutConstructorsDoc constructors - - (* example: {"name": string, "age": int} *) - | Otyp_constr ( - (Oide_dot ((Oide_ident "Js"), "t")), - [Otyp_object (fields, rest)] - ) -> printObjectFields fields rest - - (* example: node *) - | Otyp_constr (outIdent, args) -> - let argsDoc = match args with - | [] -> Doc.nil - | args -> - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - in - Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - argsDoc; - ] - ) - | Otyp_tuple tupleArgs -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc tupleArgs - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - | Otyp_poly (vars, outType) -> - Doc.group ( - Doc.concat [ - Doc.join ~sep:Doc.space ( - List.map (fun var -> Doc.text ("'" ^ var)) vars - ); - printOutTypeDoc outType; - ] - ) - | Otyp_arrow _ as typ -> - let (typArgs, typ) = collectArrowArgs typ [] in - let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, typ) -> - if lbl = "" then - printOutTypeDoc typ - else - Doc.group ( - Doc.concat [ - Doc.text ("~" ^ lbl ^ ": "); - printOutTypeDoc typ - ] - ) - ) typArgs - ) in - let argsDoc = - let needsParens = match typArgs with - | [_, (Otyp_tuple _ | Otyp_arrow _)] -> true - (* single argument should not be wrapped *) - | ["", _] -> false - | _ -> true - in - if needsParens then - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - args; - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - else args - in - Doc.concat [ - argsDoc; - Doc.text " => "; - printOutTypeDoc typ; - ] - | Otyp_module (_modName, _stringList, _outTypes) -> - Doc.nil - - and printObjectFields fields rest = - let dots = match rest with - | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") - | None -> Doc.nil - in - Doc.group ( - Doc.concat [ - Doc.lbrace; - dots; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, outType) -> Doc.group ( - Doc.concat [ - Doc.text ("\"" ^ lbl ^ "\": "); - printOutTypeDoc outType; - ] - )) fields - ) - ] - ); - Doc.softLine; - Doc.trailingComma; - Doc.rbrace; - ] - ) - - - and printOutConstructorsDoc constructors = - Doc.group ( - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line ( - List.mapi (fun i constructor -> - Doc.concat [ - if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil; - printOutConstructorDoc constructor; - ] - ) constructors - ) - ] - ) - ) - - and printOutConstructorDoc (name, args, gadt) = - let gadtDoc = match gadt with - | Some outType -> - Doc.concat [ - Doc.text ": "; - printOutTypeDoc outType - ] - | None -> Doc.nil - in - let argsDoc = match args with - | [] -> Doc.nil - | [Otyp_record record] -> - (* inline records - * | Root({ - * mutable value: 'value, - * mutable updatedTime: float, - * }) - *) - Doc.concat [ - Doc.lparen; - Doc.indent ( - printRecordDeclarationDoc ~inline:true record; - ); - Doc.rparen; - ] - | _types -> - Doc.indent ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutTypeDoc args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - Doc.text name; - argsDoc; - gadtDoc - ] - ) - - and printRecordDeclRowDoc (name, mut, arg) = - Doc.group ( - Doc.concat [ - if mut then Doc.text "mutable " else Doc.nil; - Doc.text name; - Doc.text ": "; - printOutTypeDoc arg; - ] - ) - - and printRecordDeclarationDoc ~inline rows = - let content = Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printRecordDeclRowDoc rows - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] in - if not inline then - Doc.group content - else content - - let printOutType fmt outType = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeDoc outType)) - - let printTypeParameterDoc (typ, (co, cn)) = - Doc.concat [ - if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil; - if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ) - ] - - - let rec printOutSigItemDoc (outSigItem : Outcometree.out_sig_item) = - match outSigItem with - | Osig_class _ | Osig_class_type _ -> Doc.nil - | Osig_ellipsis -> Doc.dotdotdot - | Osig_value valueDecl -> - Doc.group ( - Doc.concat [ - printOutAttributesDoc valueDecl.oval_attributes; - Doc.text ( - match valueDecl.oval_prims with | [] -> "let " | _ -> "external " - ); - Doc.text valueDecl.oval_name; - Doc.text ":"; - Doc.space; - printOutTypeDoc valueDecl.oval_type; - match valueDecl.oval_prims with - | [] -> Doc.nil - | primitives -> Doc.indent ( - Doc.concat [ - Doc.text " ="; - Doc.line; - Doc.group ( - Doc.join ~sep:Doc.line (List.map (fun prim -> Doc.text ("\"" ^ prim ^ "\"")) primitives) - ) - ] - ) - ] - ) - | Osig_typext (outExtensionConstructor, _outExtStatus) -> - printOutExtensionConstructorDoc outExtensionConstructor - | Osig_modtype (modName, Omty_signature []) -> - Doc.concat [ - Doc.text "module type "; - Doc.text modName; - ] - | Osig_modtype (modName, outModuleType) -> - Doc.group ( - Doc.concat [ - Doc.text "module type "; - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModuleType; - ] - ) - | Osig_module (modName, Omty_alias ident, _) -> - Doc.group ( - Doc.concat [ - Doc.text "module "; - Doc.text modName; - Doc.text " ="; - Doc.line; - printOutIdentDoc ident; - ] - ) - | Osig_module (modName, outModType, outRecStatus) -> - Doc.group ( - Doc.concat [ - Doc.text ( - match outRecStatus with - | Orec_not -> "module " - | Orec_first -> "module rec " - | Orec_next -> "and" - ); - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModType; - ] - ) - | Osig_type (outTypeDecl, outRecStatus) -> - (* TODO: manifest ? *) - let attrs = match outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed with - | false, false -> Doc.nil - | true, false -> - Doc.concat [Doc.text "@immediate"; Doc.line] - | false, true -> - Doc.concat [Doc.text "@unboxed"; Doc.line] - | true, true -> - Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] - in - let kw = Doc.text ( - match outRecStatus with - | Orec_not -> "type " - | Orec_first -> "type rec " - | Orec_next -> "and " - ) in - let typeParams = match outTypeDecl.otype_params with - | [] -> Doc.nil - | _params -> Doc.group ( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypeParameterDoc outTypeDecl.otype_params - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - ) - in - let privateDoc = match outTypeDecl.otype_private with - | Asttypes.Private -> Doc.text "private " - | Public -> Doc.nil - in - let kind = match outTypeDecl.otype_type with - | Otyp_open -> Doc.concat [ - Doc.text " = "; - privateDoc; - Doc.text ".."; - ] - | Otyp_abstract -> Doc.nil - | Otyp_record record -> Doc.concat [ - Doc.text " = "; - privateDoc; - printRecordDeclarationDoc ~inline:false record; - ] - | typ -> Doc.concat [ - Doc.text " = "; - printOutTypeDoc typ - ] - in - let constraints = match outTypeDecl.otype_cstrs with - | [] -> Doc.nil - | _ -> Doc.group ( - Doc.concat [ - Doc.line; - Doc.indent ( - Doc.concat [ - Doc.hardLine; - Doc.join ~sep:Doc.line (List.map (fun (typ1, typ2) -> - Doc.group ( - Doc.concat [ - Doc.text "constraint "; - printOutTypeDoc typ1; - Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutTypeDoc typ2; - ] - ) - ] - ) - ) outTypeDecl.otype_cstrs) - ] - ) - ] - ) in - Doc.group ( - Doc.concat [ - attrs; - Doc.group ( - Doc.concat [ - attrs; - kw; - Doc.text outTypeDecl.otype_name; - typeParams; - kind - ] - ); - constraints - ] - ) - - and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = - match outModType with - | Omty_abstract -> Doc.nil - | Omty_ident ident -> printOutIdentDoc ident - (* example: module Increment = (M: X_int) => X_int *) - | Omty_functor _ -> - let (args, returnModType) = collectFunctorArgs outModType [] in - let argsDoc = match args with - | [_, None] -> Doc.text "()" - | args -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (lbl, optModType) -> Doc.group ( - Doc.concat [ - Doc.text lbl; - match optModType with - | None -> Doc.nil - | Some modType -> Doc.concat [ - Doc.text ": "; - printOutModuleTypeDoc modType; - ] - ] - )) args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - argsDoc; - Doc.text " => "; - printOutModuleTypeDoc returnModType - ] - ) - | Omty_signature [] -> Doc.nil - | Omty_signature signature -> - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutSignatureDoc signature; - ] - ); - Doc.softLine; - Doc.rbrace; - ] - ) - | Omty_alias _ident -> Doc.nil - - and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | Outcometree.Osig_typext(ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - Outcometree.Osig_typext(ext, Oext_next) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - items - in - let te = - { Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - let doc = printOutTypeExtensionDoc te in - loop items (doc::acc) - | item::items -> - let doc = printOutSigItemDoc item in - loop items (doc::acc) - in - match loop signature [] with - | [doc] -> doc - | docs -> - Doc.breakableGroup ~forceBreak:true ( - Doc.join ~sep:Doc.line docs - ) - - and printOutExtensionConstructorDoc (outExt : Outcometree.out_extension_constructor) = - let typeParams = match outExt.oext_type_params with - | [] -> Doc.nil - | params -> - Doc.group( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) - params - - ) - ] - ); - Doc.softLine; - Doc.greaterThan; - ] - ) - - in - Doc.group ( - Doc.concat [ - Doc.text "type "; - Doc.text outExt.oext_type_name; - typeParams; - Doc.text " +="; - Doc.line; - if outExt.oext_private = Asttypes.Private then - Doc.text "private " - else - Doc.nil; - printOutConstructorDoc - (outExt.oext_name, outExt.oext_args, outExt.oext_ret_type) - ] - ) - - and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = - let typeParams = match typeExtension.otyext_params with - | [] -> Doc.nil - | params -> - Doc.group( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map - (fun ty -> Doc.text (if ty = "_" then ty else "'" ^ ty)) - params - - ) - ] - ); - Doc.softLine; - Doc.greaterThan; - ] - ) - - in - Doc.group ( - Doc.concat [ - Doc.text "type "; - Doc.text typeExtension.otyext_name; - typeParams; - Doc.text " +="; - if typeExtension.otyext_private = Asttypes.Private then - Doc.text "private " - else - Doc.nil; - printOutConstructorsDoc typeExtension.otyext_constructors; - ] - ) - - let printOutSigItem fmt outSigItem = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSigItemDoc outSigItem)) - - let printOutSignature fmt signature = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSignatureDoc signature)) - - let validFloatLexeme s = - let l = String.length s in - let rec loop i = - if i >= l then s ^ "." else - match (s.[i] [@doesNotRaise]) with - | '0' .. '9' | '-' -> loop (i+1) - | _ -> s - in loop 0 - - let floatRepres f = - match classify_float f with - | FP_nan -> "nan" - | FP_infinite -> - if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = (float_of_string [@doesNotRaise]) s1 then s1 else - let s2 = Printf.sprintf "%.15g" f in - if f = (float_of_string [@doesNotRaise]) s2 then s2 else - Printf.sprintf "%.18g" f - in validFloatLexeme float_val - - let rec printOutValueDoc (outValue : Outcometree.out_value) = - match outValue with - | Oval_array outValues -> - Doc.group ( - Doc.concat [ - Doc.lbracket; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ] - ) - | Oval_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") - | Oval_constr (outIdent, outValues) -> - Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - | Oval_ellipsis -> Doc.text "..." - | Oval_int i -> Doc.text (Format.sprintf "%i" i) - | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) - | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) - | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) - | Oval_float f -> Doc.text (floatRepres f) - | Oval_list outValues -> - Doc.group ( - Doc.concat [ - Doc.text "list["; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ] - ) - | Oval_printer fn -> - let fmt = Format.str_formatter in - fn fmt; - let str = Format.flush_str_formatter () in - Doc.text str - | Oval_record rows -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (outIdent, outValue) -> Doc.group ( - Doc.concat [ - printOutIdentDoc outIdent; - Doc.text ": "; - printOutValueDoc outValue; - ] - ) - ) rows - ); - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escapeStringContents txt) - | Oval_stuff txt -> Doc.text txt - | Oval_tuple outValues -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printOutValueDoc outValues - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - (* Not supported by NapkinScript *) - | Oval_variant _ -> Doc.nil - - let printOutExceptionDoc exc outValue = - match exc with - | Sys.Break -> Doc.text "Interrupted." - | Out_of_memory -> Doc.text "Out of memory during evaluation." - | Stack_overflow -> - Doc.text "Stack overflow during evaluation (looping recursion?)." - | _ -> - Doc.group ( - Doc.indent( - Doc.concat [ - Doc.text "Exception:"; - Doc.line; - printOutValueDoc outValue; - ] - ) - ) - - let printOutPhraseSignature signature = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | (Outcometree.Osig_typext(ext, Oext_first), None)::signature -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Outcometree.Osig_typext(ext, Oext_next), None)::items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type)::acc) - items - | _ -> (List.rev acc, items) - in - let exts, signature = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] - signature - in - let te = - { Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private } - in - let doc = printOutTypeExtensionDoc te in - loop signature (doc::acc) - | (sigItem, optOutValue)::signature -> - let doc = match optOutValue with - | None -> - printOutSigItemDoc sigItem - | Some outValue -> - Doc.group ( - Doc.concat [ - printOutSigItemDoc sigItem; - Doc.text " = "; - printOutValueDoc outValue; - ] - ) - in - loop signature (doc::acc) - in - Doc.breakableGroup ~forceBreak:true ( - Doc.join ~sep:Doc.line (loop signature []) - ) - - let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = - match outPhrase with - | Ophr_eval (outValue, outType) -> - Doc.group ( - Doc.concat [ - Doc.text "- : "; - printOutTypeDoc outType; - Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printOutValueDoc outValue; - ] - ) - ] - ) - | Ophr_signature [] -> Doc.nil - | Ophr_signature signature -> printOutPhraseSignature signature - | Ophr_exception (exc, outValue) -> - printOutExceptionDoc exc outValue - - let printOutPhase fmt outPhrase = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutPhraseDoc outPhrase)) - - let printOutModuleType fmt outModuleType = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType)) - - let printOutTypeExtension fmt typeExtension = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension)) - - let printOutValue fmt outValue = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutValueDoc outValue)) - - (* Not supported in Napkin *) - let printOutClassType _fmt _ = () - - let out_value = ref printOutValue - let out_type = ref printOutType - let out_module_type = ref printOutModuleType - let out_sig_item = ref printOutSigItem - let out_signature = ref printOutSignature - let out_type_extension = ref printOutTypeExtension - let out_phrase = ref printOutPhase [@live] - let out_class_type = ref printOutClassType -end - -module Repl = struct - let parseToplevelPhrase filename = - let src = IO.readFile filename in - let p = Parser.make src filename in - Parsetree.Ptop_def (NapkinScript.parseImplementation p) - - let typeAndPrintOutcome filename = - Compmisc.init_path false; - let env = Compmisc.initial_env () in - try - let sstr = match parseToplevelPhrase filename with - | Parsetree.Ptop_def sstr -> sstr - | _ -> assert false - in - let (_str, signature, _newenv) = Typemod.type_toplevel_phrase env sstr in - let outSigItems = Printtyp.tree_of_signature signature in - let fmt = Format.str_formatter in - !OutcomePrinter.out_signature fmt outSigItems; - let result = Format.flush_str_formatter () in - print_string result - with - | Typetexp.Error (_, _, err) -> - let fmt = Format.str_formatter in - Typetexp.report_error env fmt err; - let result = Format.flush_str_formatter () in - let () = print_endline result in - () - | _ -> print_endline "catch all" -end - -(* command line flags *) -module Clflags: sig - val recover: bool ref - val print: string ref - val width: int ref - val origin: string ref - val files: string list ref - val interface: bool ref - val report: string ref - - val parse: unit -> unit - val outcome: bool ref -end = struct - let recover = ref false - let width = ref 100 - - let files = ref [] - let addFilename filename = files := filename::(!files) - - let print = ref "" - let outcome = ref false - let origin = ref "" - let interface = ref false - let report = ref "pretty" - - let usage = "Usage: napkinscript \nOptions are:" - - let spec = [ - ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); - ("-print", Arg.String (fun txt -> print := txt), "Print either binary, ocaml or ast"); - ("-parse", Arg.String (fun txt -> origin := txt), "Parse ocaml or napkinscript"); - ("-outcome", Arg.Bool (fun printOutcomeTree -> outcome := printOutcomeTree), "print outcometree"); - ("-width", Arg.Int (fun w -> width := w), "Specify the line length that the printer will wrap on" ); - ("-interface", Arg.Unit (fun () -> interface := true), "Parse as interface"); - ("-report", Arg.String (fun txt -> report := txt), "Stylize errors and messages using color and context. Accepts `Pretty` and `Plain`. Default `Plain`") - ] - - let parse () = Arg.parse spec addFilename usage -end - -module Driver: sig - val processFile: - isInterface: bool - -> width: int - -> recover: bool - -> origin:string - -> target:string - -> report:string - -> string - -> unit -end = struct - type 'a file_kind = - | Structure: Parsetree.structure file_kind - | Signature: Parsetree.signature file_kind - - let parseNapkin (type a) (kind : a file_kind) p : a = - match kind with - | Structure -> NapkinScript.parseImplementation p - | Signature -> NapkinScript.parseSpecification p - - let extractOcamlStringData filename = - let lexbuf = if String.length filename > 0 then - IO.readFile filename |> Lexing.from_string - else - Lexing.from_channel stdin - in - let stringLocs = ref [] in - let rec next () = - let token = Lexer.token_with_comments lexbuf in - match token with - | OcamlParser.STRING (_txt, None) -> - let open Location in - let loc = { - loc_start = lexbuf.lex_start_p; - loc_end = lexbuf.Lexing.lex_curr_p; - loc_ghost = false; - } in - let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in - let txt = Bytes.to_string ( - (Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer loc.loc_start.pos_cnum len - ) in - stringLocs := (txt, loc)::(!stringLocs); - next(); - | OcamlParser.EOF -> () - | _ -> next() - in - next(); - List.rev !stringLocs - - let parseOcaml (type a) (kind : a file_kind) filename : a = - let lexbuf = if String.length filename > 0 then - IO.readFile filename |> Lexing.from_string - else - Lexing.from_channel stdin - in - let stringData = extractOcamlStringData filename in - match kind with - | Structure -> - Parse.implementation lexbuf - |> ParsetreeCompatibility.replaceStringLiteralStructure stringData - |> ParsetreeCompatibility.structure - | Signature -> - Parse.interface lexbuf - |> ParsetreeCompatibility.replaceStringLiteralSignature stringData - |> ParsetreeCompatibility.signature - - let parseNapkinFile ~destination kind filename = - let src = if String.length filename > 0 then - IO.readFile filename - else - IO.readStdin () - in - let p = - let mode = match destination with - | "napkinscript" | "ns" | "sexp" -> Parser.Default - | _ -> Parser.ParseForTypeChecker - in - Parser.make ~mode src filename in - let ast = parseNapkin kind p in - let report = match p.diagnostics with - | [] -> None - | diagnostics -> Some(diagnostics) - in - (ast, report, p) - - let parseOcamlFile kind filename = - let ast = parseOcaml kind filename in - let lexbuf2 = if String.length filename > 0 then - IO.readFile filename |> Lexing.from_string - else - Lexing.from_channel stdin - in - let comments = - let rec next (prevTokEndPos : Lexing.position) comments lb = - let token = Lexer.token_with_comments lb in - match token with - | OcamlParser.EOF -> comments - | OcamlParser.COMMENT (txt, loc) -> - let comment = Comment.fromOcamlComment - ~loc - ~prevTokEndPos - ~txt - in - next loc.Location.loc_end (comment::comments) lb - | _ -> - next lb.Lexing.lex_curr_p comments lb - in - let cmts = next lexbuf2.Lexing.lex_start_p [] lexbuf2 in - cmts - in - let p = Parser.make "" filename in - p.comments <- comments; - (ast, None, p) - - let reasonFilename = ref "" - let commentData = ref [] - let stringData = ref [] - - let parseReasonBinaryFromStdin (type a) (kind : a file_kind) filename :a = - let chan, close = - match String.length filename == 0 with - | true -> stdin, (fun _ -> ()) - | false -> - let file_chan = open_in_bin filename in - seek_in file_chan 0; - file_chan, close_in_noerr - in - let ic = chan in - let magic = match kind with - | Structure -> Config.ast_impl_magic_number - | Signature -> Config.ast_intf_magic_number - in - let buffer = (really_input_string [@doesNotRaise]) ic (String.length magic) in - assert(buffer = magic); - let filename = input_value ic in - reasonFilename := filename; - let ast = input_value ic in - close chan; - - let src = - if String.length filename > 0 then IO.readFile filename - else IO.readStdin () - in - - let scanner = Scanner.make (Bytes.of_string src) filename in - - let rec next prevEndPos scanner = - let (startPos, endPos, token) = Scanner.scan scanner in - match token with - | Eof -> () - | Comment c -> - Comment.setPrevTokEndPos c prevEndPos; - commentData := c::(!commentData); - next endPos scanner - | String _ -> - let loc = {Location.loc_start = startPos; loc_end = endPos; loc_ghost = false} in - let len = endPos.pos_cnum - startPos.pos_cnum in - let txt = (String.sub [@doesNotRaise]) src startPos.pos_cnum len in - stringData := (txt, loc)::(!stringData); - next endPos scanner - | _ -> - next endPos scanner - in - - next Lexing.dummy_pos scanner; - - match kind with - | Structure -> - ast - |> ParsetreeCompatibility.replaceStringLiteralStructure !stringData - |> ParsetreeCompatibility.normalizeReasonArityStructure ~forPrinter:true - |> ParsetreeCompatibility.structure - | Signature -> - ast - |> ParsetreeCompatibility.replaceStringLiteralSignature !stringData - |> ParsetreeCompatibility.normalizeReasonAritySignature ~forPrinter:true - |> ParsetreeCompatibility.signature - - let isReasonDocComment (comment: Comment.t) = - let content = Comment.txt comment in - let len = String.length content in - if len = 0 then true - else if len >= 2 && (String.unsafe_get content 0 = '*' && String.unsafe_get content 1 = '*') then false - else if len >= 1 && (String.unsafe_get content 0 = '*') then true - else false - - - let parseReasonBinary kind filename = - let ast = parseReasonBinaryFromStdin kind filename in - let p = Parser.make "" !reasonFilename in - p.comments <- List.filter (fun c -> not (isReasonDocComment c)) !commentData; - (ast, None, p) - - let parseImplementation ~origin ~destination filename = - match origin with - | "ml" | "ocaml" -> - parseOcamlFile Structure filename - | "reasonBinary" -> - parseReasonBinary Structure filename - | _ -> - parseNapkinFile ~destination Structure filename - - let parseInterface ~destination ~origin filename = - match origin with - | "ml" | "ocaml" -> - parseOcamlFile Signature filename - | "reasonBinary" -> - parseReasonBinary Signature filename - | _ -> - parseNapkinFile ~destination Signature filename - - let process ~reportStyle parseFn printFn recover filename = - let (ast, report, parserState) = parseFn filename in - match report with - | Some report when recover = true -> - printFn ast parserState; - prerr_string ( - Diagnostics.stringOfReport - ~style:(Diagnostics.parseReportStyle reportStyle) - report (Bytes.to_string parserState.Parser.scanner.src) - ); - | Some report -> - prerr_string ( - Diagnostics.stringOfReport - ~style:(Diagnostics.parseReportStyle reportStyle) - report (Bytes.to_string parserState.Parser.scanner.src) - ); - exit 1 - | None -> - printFn ast parserState - - type action = - | ProcessImplementation - | ProcessInterface - - let printImplementation ~target ~width filename ast _parserState = - match target with - | "ml" | "ocaml" -> - Pprintast.structure Format.std_formatter ast - | "ns" | "napkinscript" -> - Printer.printImplementation ~width ast (List.rev _parserState.Parser.comments) - | "ast" -> - Printast.implementation Format.std_formatter ast - | "sexp" -> - ast |> SexpAst.implementation |> Sexp.toString |> print_string - | _ -> (* default binary *) - output_string stdout Config.ast_impl_magic_number; - output_value stdout filename; - output_value stdout ast - - let printInterface ~target ~width filename ast _parserState = - match target with - | "ml" | "ocaml" -> Pprintast.signature Format.std_formatter ast - | "ns" | "napkinscript" -> - Printer.printInterface ~width ast (List.rev _parserState.Parser.comments) - | "ast" -> Printast.interface Format.std_formatter ast - | "sexp" -> - ast |> SexpAst.interface |> Sexp.toString |> print_string - | _ -> (* default binary *) - output_string stdout Config.ast_intf_magic_number; - output_value stdout filename; - output_value stdout ast - - let processFile ~isInterface ~width ~recover ~origin ~target ~report filename = - try - let len = String.length filename in - let action = - if isInterface || len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i' then - ProcessInterface - else ProcessImplementation - in - match action with - | ProcessImplementation -> - process - ~reportStyle:report - (parseImplementation ~origin ~destination:target) - (printImplementation ~target ~width filename) recover filename - | ProcessInterface -> - process - ~reportStyle:report - (parseInterface ~origin ~destination:target) - (printInterface ~target ~width filename) recover filename - with - | Failure txt -> - prerr_string txt; - prerr_newline(); - exit 1 - | _ -> exit 1 -end - -let () = - Clflags.parse (); - if !Clflags.outcome then ( - Repl.typeAndPrintOutcome (List.hd !Clflags.files) - ) else ( - let () = match !Clflags.files with - | (_file::_) as files -> - List.iter (fun filename -> - Driver.processFile - ~isInterface:!Clflags.interface - ~width:!Clflags.width - ~recover:!Clflags.recover - ~target:!Clflags.print - ~origin:!Clflags.origin - ~report:!Clflags.report - filename - ) files; - | [] -> - Driver.processFile - ~isInterface:!Clflags.interface - ~width:!Clflags.width - ~recover:!Clflags.recover - ~target:!Clflags.print - ~origin:!Clflags.origin - ~report:!Clflags.report - "" - in - exit 0 - ) diff --git a/jscomp/syntax/benchmarks/data/Napkinscript.res b/jscomp/syntax/benchmarks/data/Napkinscript.res deleted file mode 100644 index f69bff3..0000000 --- a/jscomp/syntax/benchmarks/data/Napkinscript.res +++ /dev/null @@ -1,20680 +0,0 @@ -module MiniBuffer: { - type t - let add_char: (t, char) => unit - let add_string: (t, string) => unit - let contents: t => string - let create: int => t - let flush_newline: t => unit - let length: t => int - let unsafe_get: (t, int) => char -} = { - type t = { - mutable buffer: bytes, - mutable position: int, - mutable length: int, - } - - let create = n => { - let n = if n < 1 { - 1 - } else { - n - } - let s = (@doesNotRaise Bytes.create)(n) - {buffer: s, position: 0, length: n} - } - - let contents = b => Bytes.sub_string(b.buffer, 0, b.position) - - let unsafe_get = (b, ofs) => Bytes.unsafe_get(b.buffer, ofs) - - let length = b => b.position - - /* Can't be called directly, don't add to the interface */ - let resize_internal = (b, more) => { - let len = b.length - let new_len = ref(len) - while b.position + more > new_len.contents { - new_len := 2 * new_len.contents - } - if new_len.contents > Sys.max_string_length { - if b.position + more <= Sys.max_string_length { - new_len := Sys.max_string_length - } - } - let new_buffer = (@doesNotRaise Bytes.create)(new_len.contents) - /* PR#6148: let's keep using [blit] rather than [unsafe_blit] in - this tricky function that is slow anyway. */ - @doesNotRaise - Bytes.blit(b.buffer, 0, new_buffer, 0, b.position) - b.buffer = new_buffer - b.length = new_len.contents - } - - let add_char = (b, c) => { - let pos = b.position - if pos >= b.length { - resize_internal(b, 1) - } - Bytes.unsafe_set(b.buffer, pos, c) - b.position = pos + 1 - } - - let add_string = (b, s) => { - let len = String.length(s) - let new_position = b.position + len - if new_position > b.length { - resize_internal(b, len) - } - @doesNotRaise - Bytes.blit_string(s, 0, b.buffer, b.position, len) - b.position = new_position - } - - /* adds newline and trims all preceding whitespace */ - let flush_newline = b => { - let position = ref(b.position) - while Bytes.unsafe_get(b.buffer, position.contents - 1) == ' ' && position.contents >= 0 { - position := position.contents - 1 - } - b.position = position.contents - add_char(b, '\n') - } -} - -module Doc = { - type mode = Break | Flat - - type lineStyle = - | Classic /* fits? -> replace with space */ - | Soft /* fits? -> replaced with nothing */ - | Hard /* always included, forces breaks in parents */ - - type rec t = - | Nil - | Text(string) - | Concat(list) - | Indent(t) - | IfBreaks({yes: t, no: t}) - | LineSuffix(t) - | LineBreak(lineStyle) - | Group({shouldBreak: bool, doc: t}) - | CustomLayout(list) - | BreakParent - /* | Cursor */ - - let nil = Nil - let line = LineBreak(Classic) - let hardLine = LineBreak(Hard) - let softLine = LineBreak(Soft) - let text = s => Text(s) - let concat = l => Concat(l) - let indent = d => Indent(d) - let ifBreaks = (t, f) => IfBreaks({yes: t, no: f}) - let lineSuffix = d => LineSuffix(d) - let group = d => Group({shouldBreak: false, doc: d}) - let breakableGroup = (~forceBreak, d) => Group({shouldBreak: forceBreak, doc: d}) - let customLayout = gs => CustomLayout(gs) - let breakParent = BreakParent - /* let cursor = Cursor */ - - let space = Text(" ") - let comma = Text(",") - let dot = Text(".") - let dotdot = Text("..") - let dotdotdot = Text("...") - let lessThan = Text("<") - let greaterThan = Text(">") - let lbrace = Text("{") - let rbrace = Text("}") - let lparen = Text("(") - let rparen = Text(")") - let lbracket = Text("[") - let rbracket = Text("]") - let question = Text("?") - let tilde = Text("~") - let equal = Text("=") - let trailingComma = IfBreaks({yes: comma, no: nil}) - let doubleQuote = Text("\"") - - let propagateForcedBreaks = doc => { - let rec walk = doc => - switch doc { - | Text(_) | Nil | LineSuffix(_) => (false, doc) - | BreakParent => (true, Nil) - | LineBreak(Hard) => (true, doc) - | LineBreak(Classic | Soft) => (false, doc) - | Indent(children) => - let (childForcesBreak, newChildren) = walk(children) - (childForcesBreak, Indent(newChildren)) - | IfBreaks({yes: trueDoc, no: falseDoc}) => - let (falseForceBreak, falseDoc) = walk(falseDoc) - if falseForceBreak { - let (_, trueDoc) = walk(trueDoc) - (true, trueDoc) - } else { - let (forceBreak, trueDoc) = walk(trueDoc) - (forceBreak, IfBreaks({yes: trueDoc, no: falseDoc})) - } - | Group({shouldBreak: forceBreak, doc: children}) => - let (childForcesBreak, newChildren) = walk(children) - let shouldBreak = forceBreak || childForcesBreak - (shouldBreak, Group({shouldBreak: shouldBreak, doc: newChildren})) - | Concat(children) => - let (forceBreak, newChildren) = List.fold_left(((forceBreak, newChildren), child) => { - let (childForcesBreak, newChild) = walk(child) - (forceBreak || childForcesBreak, list{newChild, ...newChildren}) - }, (false, list{}), children) - - (forceBreak, Concat(List.rev(newChildren))) - | CustomLayout(children) => - /* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here */ - let children = switch walk(Concat(children)) { - | (_, Concat(children)) => children - | _ => assert false - } - - (false, CustomLayout(children)) - } - - let (_, processedDoc) = walk(doc) - processedDoc - } - - let join = (~sep, docs) => { - let rec loop = (acc, sep, docs) => - switch docs { - | list{} => List.rev(acc) - | list{x} => List.rev(list{x, ...acc}) - | list{x, ...xs} => loop(list{sep, x, ...acc}, sep, xs) - } - - Concat(loop(list{}, sep, docs)) - } - - let rec fits = (w, doc) => - switch doc { - | _ when w < 0 => false - | list{} => true - | list{(_ind, _mode, Text(txt)), ...rest} => fits(w - String.length(txt), rest) - | list{(ind, mode, Indent(doc)), ...rest} => fits(w, list{(ind + 2, mode, doc), ...rest}) - | list{(_ind, Flat, LineBreak(break)), ...rest} => - if break == Hard { - true - } else { - let w = if break == Classic { - w - 1 - } else { - w - } - fits(w, rest) - } - | list{(_ind, _mode, Nil), ...rest} => fits(w, rest) - | list{(_ind, Break, LineBreak(_break)), ..._rest} => true - | list{(ind, mode, Group({shouldBreak: forceBreak, doc})), ...rest} => - let mode = if forceBreak { - Break - } else { - mode - } - fits(w, list{(ind, mode, doc), ...rest}) - | list{(ind, mode, IfBreaks({yes: breakDoc, no: flatDoc})), ...rest} => - if mode == Break { - fits(w, list{(ind, mode, breakDoc), ...rest}) - } else { - fits(w, list{(ind, mode, flatDoc), ...rest}) - } - | list{(ind, mode, Concat(docs)), ...rest} => - let ops = List.map(doc => (ind, mode, doc), docs) - fits(w, List.append(ops, rest)) - /* | (_ind, _mode, Cursor)::rest -> fits w rest */ - | list{(_ind, _mode, LineSuffix(_)), ...rest} => fits(w, rest) - | list{(_ind, _mode, BreakParent), ...rest} => fits(w, rest) - | list{(ind, mode, CustomLayout(list{hd, ..._})), ...rest} => - /* TODO: if we have nested custom layouts, what we should do here? */ - fits(w, list{(ind, mode, hd), ...rest}) - | list{(_ind, _mode, CustomLayout(_)), ...rest} => fits(w, rest) - } - - let toString = (~width, doc) => { - let doc = propagateForcedBreaks(doc) - let buffer = MiniBuffer.create(1000) - - let rec process = (~pos, lineSuffices, stack) => - switch stack { - | list{(ind, mode, doc) as cmd, ...rest} => - switch doc { - | Nil | BreakParent => process(~pos, lineSuffices, rest) - | Text(txt) => - MiniBuffer.add_string(buffer, txt) - process(~pos=String.length(txt) + pos, lineSuffices, rest) - | LineSuffix(doc) => process(~pos, list{(ind, mode, doc), ...lineSuffices}, rest) - | Concat(docs) => - let ops = List.map(doc => (ind, mode, doc), docs) - process(~pos, lineSuffices, List.append(ops, rest)) - | Indent(doc) => process(~pos, lineSuffices, list{(ind + 2, mode, doc), ...rest}) - | IfBreaks({yes: breakDoc, no: flatDoc}) => - if mode == Break { - process(~pos, lineSuffices, list{(ind, mode, breakDoc), ...rest}) - } else { - process(~pos, lineSuffices, list{(ind, mode, flatDoc), ...rest}) - } - | LineBreak(lineStyle) => - if mode == Break { - switch lineSuffices { - | list{} => - MiniBuffer.flush_newline(buffer) - MiniBuffer.add_string(buffer, @doesNotRaise String.make(ind, ' ')) - process(~pos=ind, list{}, rest) - | _docs => - process( - ~pos=ind, - list{}, - List.concat(list{List.rev(lineSuffices), list{cmd, ...rest}}), - ) - } - } else { - /* mode = Flat */ - let pos = switch lineStyle { - | Classic => - MiniBuffer.add_string(buffer, " ") - pos + 1 - | Hard => - MiniBuffer.flush_newline(buffer) - 0 - | Soft => pos - } - - process(~pos, lineSuffices, rest) - } - | Group({shouldBreak, doc}) => - if shouldBreak || !fits(width - pos, list{(ind, Flat, doc), ...rest}) { - process(~pos, lineSuffices, list{(ind, Break, doc), ...rest}) - } else { - process(~pos, lineSuffices, list{(ind, Flat, doc), ...rest}) - } - | CustomLayout(docs) => - let rec findGroupThatFits = groups => - switch groups { - | list{} => Nil - | list{lastGroup} => lastGroup - | list{doc, ...docs} => - if fits(width - pos, list{(ind, Flat, doc), ...rest}) { - doc - } else { - findGroupThatFits(docs) - } - } - - let doc = findGroupThatFits(docs) - process(~pos, lineSuffices, list{(ind, Flat, doc), ...rest}) - } - | list{} => - switch lineSuffices { - | list{} => () - | suffices => process(~pos=0, list{}, List.rev(suffices)) - } - } - - process(~pos=0, list{}, list{(0, Flat, doc)}) - - let len = MiniBuffer.length(buffer) - if len > 0 && MiniBuffer.unsafe_get(buffer, len - 1) !== '\n' { - MiniBuffer.add_char(buffer, '\n') - } - MiniBuffer.contents(buffer) - } - - @live - let debug = t => { - let rec toDoc = x => - switch x { - | Nil => text("nil") - | BreakParent => text("breakparent") - | Text(txt) => text("text(" ++ (txt ++ ")")) - | LineSuffix(doc) => - group( - concat(list{ - text("linesuffix("), - indent(concat(list{line, toDoc(doc)})), - line, - text(")"), - }), - ) - | Concat(docs) => - group( - concat(list{ - text("concat("), - indent( - concat(list{line, join(~sep=concat(list{text(","), line}), List.map(toDoc, docs))}), - ), - line, - text(")"), - }), - ) - | CustomLayout(docs) => - group( - concat(list{ - text("customLayout("), - indent( - concat(list{line, join(~sep=concat(list{text(","), line}), List.map(toDoc, docs))}), - ), - line, - text(")"), - }), - ) - | Indent(doc) => concat(list{text("indent("), softLine, toDoc(doc), softLine, text(")")}) - | IfBreaks({yes: trueDoc, no: falseDoc}) => - group( - concat(list{ - text("ifBreaks("), - indent( - concat(list{line, toDoc(trueDoc), concat(list{text(","), line}), toDoc(falseDoc)}), - ), - line, - text(")"), - }), - ) - | LineBreak(break) => - let breakTxt = switch break { - | Classic => "Classic" - | Soft => "Soft" - | Hard => "Hard" - } - - text("LineBreak(" ++ (breakTxt ++ ")")) - | Group({shouldBreak, doc}) => - group( - concat(list{ - text("Group("), - indent( - concat(list{ - line, - text("shouldBreak: " ++ string_of_bool(shouldBreak)), - concat(list{text(","), line}), - toDoc(doc), - }), - ), - line, - text(")"), - }), - ) - } - - let doc = toDoc(t) - toString(~width=10, doc) |> print_endline - } -} - -module Sexp: { - type t - - let atom: string => t - let list: list => t - let toString: t => string -} = { - type rec t = - | Atom(string) - | List(list) - - let atom = s => Atom(s) - let list = l => List(l) - - let rec toDoc = t => - switch t { - | Atom(s) => Doc.text(s) - | List(list{}) => Doc.text("()") - | List(list{sexpr}) => Doc.concat(list{Doc.lparen, toDoc(sexpr), Doc.rparen}) - | List(list{hd, ...tail}) => - Doc.group( - Doc.concat(list{ - Doc.lparen, - toDoc(hd), - Doc.indent(Doc.concat(list{Doc.line, Doc.join(~sep=Doc.line, List.map(toDoc, tail))})), - Doc.rparen, - }), - ) - } - - let toString = sexpr => { - let doc = toDoc(sexpr) - Doc.toString(~width=80, doc) - } -} - -module SexpAst: { - let implementation: Parsetree.structure => Sexp.t - let interface: Parsetree.signature => Sexp.t -} = { - open Parsetree - - let mapEmpty = (~f, items) => - switch items { - | list{} => list{Sexp.list(list{})} - | items => List.map(f, items) - } - - let string = txt => Sexp.atom("\"" ++ (txt ++ "\"")) - - let char = c => Sexp.atom("'" ++ (Char.escaped(c) ++ "'")) - - let optChar = oc => - switch oc { - | None => Sexp.atom("None") - | Some(c) => Sexp.list(list{Sexp.atom("Some"), char(c)}) - } - - let longident = l => { - let rec loop = l => - switch l { - | Longident.Lident(ident) => Sexp.list(list{Sexp.atom("Lident"), string(ident)}) - | Longident.Ldot(lident, txt) => Sexp.list(list{Sexp.atom("Ldot"), loop(lident), string(txt)}) - | Longident.Lapply(l1, l2) => Sexp.list(list{Sexp.atom("Lapply"), loop(l1), loop(l2)}) - } - - Sexp.list(list{Sexp.atom("longident"), loop(l)}) - } - - let closedFlag = flag => - switch flag { - | Asttypes.Closed => Sexp.atom("Closed") - | Open => Sexp.atom("Open") - } - - let directionFlag = flag => - switch flag { - | Asttypes.Upto => Sexp.atom("Upto") - | Downto => Sexp.atom("Downto") - } - - let recFlag = flag => - switch flag { - | Asttypes.Recursive => Sexp.atom("Recursive") - | Nonrecursive => Sexp.atom("Nonrecursive") - } - - let overrideFlag = flag => - switch flag { - | Asttypes.Override => Sexp.atom("Override") - | Fresh => Sexp.atom("Fresh") - } - - let privateFlag = flag => - switch flag { - | Asttypes.Public => Sexp.atom("Public") - | Private => Sexp.atom("Private") - } - - let mutableFlag = flag => - switch flag { - | Asttypes.Immutable => Sexp.atom("Immutable") - | Mutable => Sexp.atom("Mutable") - } - - let variance = v => - switch v { - | Asttypes.Covariant => Sexp.atom("Covariant") - | Contravariant => Sexp.atom("Contravariant") - | Invariant => Sexp.atom("Invariant") - } - - let argLabel = lbl => - switch lbl { - | Asttypes.Nolabel => Sexp.atom("Nolabel") - | Labelled(txt) => Sexp.list(list{Sexp.atom("Labelled"), string(txt)}) - | Optional(txt) => Sexp.list(list{Sexp.atom("Optional"), string(txt)}) - } - - let constant = c => { - let sexpr = switch c { - | Pconst_integer(txt, tag) => - Sexp.list(list{Sexp.atom("Pconst_integer"), string(txt), optChar(tag)}) - | Pconst_char(c) => Sexp.list(list{Sexp.atom("Pconst_char"), Sexp.atom(Char.escaped(c))}) - | Pconst_string(txt, tag) => - Sexp.list(list{ - Sexp.atom("Pconst_string"), - string(txt), - switch tag { - | Some(txt) => Sexp.list(list{Sexp.atom("Some"), string(txt)}) - | None => Sexp.atom("None") - }, - }) - | Pconst_float(txt, tag) => - Sexp.list(list{Sexp.atom("Pconst_float"), string(txt), optChar(tag)}) - } - - Sexp.list(list{Sexp.atom("constant"), sexpr}) - } - - let rec structure = s => Sexp.list(list{Sexp.atom("structure"), ...List.map(structureItem, s)}) - - and structureItem = si => { - let desc = switch si.pstr_desc { - | Pstr_eval(expr, attrs) => - Sexp.list(list{Sexp.atom("Pstr_eval"), expression(expr), attributes(attrs)}) - | Pstr_value(flag, vbs) => - Sexp.list(list{ - Sexp.atom("Pstr_value"), - recFlag(flag), - Sexp.list(mapEmpty(~f=valueBinding, vbs)), - }) - | Pstr_primitive(vd) => Sexp.list(list{Sexp.atom("Pstr_primitive"), valueDescription(vd)}) - | Pstr_type(flag, tds) => - Sexp.list(list{ - Sexp.atom("Pstr_type"), - recFlag(flag), - Sexp.list(mapEmpty(~f=typeDeclaration, tds)), - }) - | Pstr_typext(typext) => Sexp.list(list{Sexp.atom("Pstr_type"), typeExtension(typext)}) - | Pstr_exception(ec) => Sexp.list(list{Sexp.atom("Pstr_exception"), extensionConstructor(ec)}) - | Pstr_module(mb) => Sexp.list(list{Sexp.atom("Pstr_module"), moduleBinding(mb)}) - | Pstr_recmodule(mbs) => - Sexp.list(list{Sexp.atom("Pstr_recmodule"), Sexp.list(mapEmpty(~f=moduleBinding, mbs))}) - | Pstr_modtype(modTypDecl) => - Sexp.list(list{Sexp.atom("Pstr_modtype"), moduleTypeDeclaration(modTypDecl)}) - | Pstr_open(openDesc) => Sexp.list(list{Sexp.atom("Pstr_open"), openDescription(openDesc)}) - | Pstr_class(_) => Sexp.atom("Pstr_class") - | Pstr_class_type(_) => Sexp.atom("Pstr_class_type") - | Pstr_include(id) => Sexp.list(list{Sexp.atom("Pstr_include"), includeDeclaration(id)}) - | Pstr_attribute(attr) => Sexp.list(list{Sexp.atom("Pstr_attribute"), attribute(attr)}) - | Pstr_extension(ext, attrs) => - Sexp.list(list{Sexp.atom("Pstr_extension"), extension(ext), attributes(attrs)}) - } - - Sexp.list(list{Sexp.atom("structure_item"), desc}) - } - - and includeDeclaration = id => - Sexp.list(list{ - Sexp.atom("include_declaration"), - moduleExpression(id.pincl_mod), - attributes(id.pincl_attributes), - }) - - and openDescription = od => - Sexp.list(list{ - Sexp.atom("open_description"), - longident(od.popen_lid.Asttypes.txt), - attributes(od.popen_attributes), - }) - - and moduleTypeDeclaration = mtd => - Sexp.list(list{ - Sexp.atom("module_type_declaration"), - string(mtd.pmtd_name.Asttypes.txt), - switch mtd.pmtd_type { - | None => Sexp.atom("None") - | Some(modType) => Sexp.list(list{Sexp.atom("Some"), moduleType(modType)}) - }, - attributes(mtd.pmtd_attributes), - }) - - and moduleBinding = mb => - Sexp.list(list{ - Sexp.atom("module_binding"), - string(mb.pmb_name.Asttypes.txt), - moduleExpression(mb.pmb_expr), - attributes(mb.pmb_attributes), - }) - - and moduleExpression = me => { - let desc = switch me.pmod_desc { - | Pmod_ident(modName) => - Sexp.list(list{Sexp.atom("Pmod_ident"), longident(modName.Asttypes.txt)}) - | Pmod_structure(s) => Sexp.list(list{Sexp.atom("Pmod_structure"), structure(s)}) - | Pmod_functor(lbl, optModType, modExpr) => - Sexp.list(list{ - Sexp.atom("Pmod_functor"), - string(lbl.Asttypes.txt), - switch optModType { - | None => Sexp.atom("None") - | Some(modType) => Sexp.list(list{Sexp.atom("Some"), moduleType(modType)}) - }, - moduleExpression(modExpr), - }) - | Pmod_apply(callModExpr, modExprArg) => - Sexp.list(list{ - Sexp.atom("Pmod_apply"), - moduleExpression(callModExpr), - moduleExpression(modExprArg), - }) - | Pmod_constraint(modExpr, modType) => - Sexp.list(list{Sexp.atom("Pmod_constraint"), moduleExpression(modExpr), moduleType(modType)}) - | Pmod_unpack(expr) => Sexp.list(list{Sexp.atom("Pmod_unpack"), expression(expr)}) - | Pmod_extension(ext) => Sexp.list(list{Sexp.atom("Pmod_extension"), extension(ext)}) - } - - Sexp.list(list{Sexp.atom("module_expr"), desc, attributes(me.pmod_attributes)}) - } - - and moduleType = mt => { - let desc = switch mt.pmty_desc { - | Pmty_ident(longidentLoc) => - Sexp.list(list{Sexp.atom("Pmty_ident"), longident(longidentLoc.Asttypes.txt)}) - | Pmty_signature(s) => Sexp.list(list{Sexp.atom("Pmty_signature"), signature(s)}) - | Pmty_functor(lbl, optModType, modType) => - Sexp.list(list{ - Sexp.atom("Pmty_functor"), - string(lbl.Asttypes.txt), - switch optModType { - | None => Sexp.atom("None") - | Some(modType) => Sexp.list(list{Sexp.atom("Some"), moduleType(modType)}) - }, - moduleType(modType), - }) - | Pmty_alias(longidentLoc) => - Sexp.list(list{Sexp.atom("Pmty_alias"), longident(longidentLoc.Asttypes.txt)}) - | Pmty_extension(ext) => Sexp.list(list{Sexp.atom("Pmty_extension"), extension(ext)}) - | Pmty_typeof(modExpr) => Sexp.list(list{Sexp.atom("Pmty_typeof"), moduleExpression(modExpr)}) - | Pmty_with(modType, withConstraints) => - Sexp.list(list{ - Sexp.atom("Pmty_with"), - moduleType(modType), - Sexp.list(mapEmpty(~f=withConstraint, withConstraints)), - }) - } - - Sexp.list(list{Sexp.atom("module_type"), desc, attributes(mt.pmty_attributes)}) - } - - and withConstraint = wc => - switch wc { - | Pwith_type(longidentLoc, td) => - Sexp.list(list{ - Sexp.atom("Pmty_with"), - longident(longidentLoc.Asttypes.txt), - typeDeclaration(td), - }) - | Pwith_module(l1, l2) => - Sexp.list(list{ - Sexp.atom("Pwith_module"), - longident(l1.Asttypes.txt), - longident(l2.Asttypes.txt), - }) - | Pwith_typesubst(longidentLoc, td) => - Sexp.list(list{ - Sexp.atom("Pwith_typesubst"), - longident(longidentLoc.Asttypes.txt), - typeDeclaration(td), - }) - | Pwith_modsubst(l1, l2) => - Sexp.list(list{ - Sexp.atom("Pwith_modsubst"), - longident(l1.Asttypes.txt), - longident(l2.Asttypes.txt), - }) - } - - and signature = s => Sexp.list(list{Sexp.atom("signature"), ...List.map(signatureItem, s)}) - - and signatureItem = si => { - let descr = switch si.psig_desc { - | Psig_value(vd) => Sexp.list(list{Sexp.atom("Psig_value"), valueDescription(vd)}) - | Psig_type(flag, typeDeclarations) => - Sexp.list(list{ - Sexp.atom("Psig_type"), - recFlag(flag), - Sexp.list(mapEmpty(~f=typeDeclaration, typeDeclarations)), - }) - | Psig_typext(typExt) => Sexp.list(list{Sexp.atom("Psig_typext"), typeExtension(typExt)}) - | Psig_exception(extConstr) => - Sexp.list(list{Sexp.atom("Psig_exception"), extensionConstructor(extConstr)}) - | Psig_module(modDecl) => Sexp.list(list{Sexp.atom("Psig_module"), moduleDeclaration(modDecl)}) - | Psig_recmodule(modDecls) => - Sexp.list(list{ - Sexp.atom("Psig_recmodule"), - Sexp.list(mapEmpty(~f=moduleDeclaration, modDecls)), - }) - | Psig_modtype(modTypDecl) => - Sexp.list(list{Sexp.atom("Psig_modtype"), moduleTypeDeclaration(modTypDecl)}) - | Psig_open(openDesc) => Sexp.list(list{Sexp.atom("Psig_open"), openDescription(openDesc)}) - | Psig_include(inclDecl) => - Sexp.list(list{Sexp.atom("Psig_include"), includeDescription(inclDecl)}) - | Psig_class(_) => Sexp.list(list{Sexp.atom("Psig_class")}) - | Psig_class_type(_) => Sexp.list(list{Sexp.atom("Psig_class_type")}) - | Psig_attribute(attr) => Sexp.list(list{Sexp.atom("Psig_attribute"), attribute(attr)}) - | Psig_extension(ext, attrs) => - Sexp.list(list{Sexp.atom("Psig_extension"), extension(ext), attributes(attrs)}) - } - - Sexp.list(list{Sexp.atom("signature_item"), descr}) - } - - and includeDescription = id => - Sexp.list(list{ - Sexp.atom("include_description"), - moduleType(id.pincl_mod), - attributes(id.pincl_attributes), - }) - - and moduleDeclaration = md => - Sexp.list(list{ - Sexp.atom("module_declaration"), - string(md.pmd_name.Asttypes.txt), - moduleType(md.pmd_type), - attributes(md.pmd_attributes), - }) - - and valueBinding = vb => - Sexp.list(list{ - Sexp.atom("value_binding"), - pattern(vb.pvb_pat), - expression(vb.pvb_expr), - attributes(vb.pvb_attributes), - }) - - and valueDescription = vd => - Sexp.list(list{ - Sexp.atom("value_description"), - string(vd.pval_name.Asttypes.txt), - coreType(vd.pval_type), - Sexp.list(mapEmpty(~f=string, vd.pval_prim)), - attributes(vd.pval_attributes), - }) - - and typeDeclaration = td => - Sexp.list(list{ - Sexp.atom("type_declaration"), - string(td.ptype_name.Asttypes.txt), - Sexp.list(list{ - Sexp.atom("ptype_params"), - Sexp.list( - mapEmpty( - ~f=((typexpr, var)) => Sexp.list(list{coreType(typexpr), variance(var)}), - td.ptype_params, - ), - ), - }), - Sexp.list(list{ - Sexp.atom("ptype_cstrs"), - Sexp.list( - mapEmpty( - ~f=((typ1, typ2, _loc)) => Sexp.list(list{coreType(typ1), coreType(typ2)}), - td.ptype_cstrs, - ), - ), - }), - Sexp.list(list{Sexp.atom("ptype_kind"), typeKind(td.ptype_kind)}), - Sexp.list(list{ - Sexp.atom("ptype_manifest"), - switch td.ptype_manifest { - | None => Sexp.atom("None") - | Some(typ) => Sexp.list(list{Sexp.atom("Some"), coreType(typ)}) - }, - }), - Sexp.list(list{Sexp.atom("ptype_private"), privateFlag(td.ptype_private)}), - attributes(td.ptype_attributes), - }) - - and extensionConstructor = ec => - Sexp.list(list{ - Sexp.atom("extension_constructor"), - string(ec.pext_name.Asttypes.txt), - extensionConstructorKind(ec.pext_kind), - attributes(ec.pext_attributes), - }) - - and extensionConstructorKind = kind => - switch kind { - | Pext_decl(args, optTypExpr) => - Sexp.list(list{ - Sexp.atom("Pext_decl"), - constructorArguments(args), - switch optTypExpr { - | None => Sexp.atom("None") - | Some(typ) => Sexp.list(list{Sexp.atom("Some"), coreType(typ)}) - }, - }) - | Pext_rebind(longidentLoc) => - Sexp.list(list{Sexp.atom("Pext_rebind"), longident(longidentLoc.Asttypes.txt)}) - } - - and typeExtension = te => - Sexp.list(list{ - Sexp.atom("type_extension"), - Sexp.list(list{Sexp.atom("ptyext_path"), longident(te.ptyext_path.Asttypes.txt)}), - Sexp.list(list{ - Sexp.atom("ptyext_parms"), - Sexp.list( - mapEmpty( - ~f=((typexpr, var)) => Sexp.list(list{coreType(typexpr), variance(var)}), - te.ptyext_params, - ), - ), - }), - Sexp.list(list{ - Sexp.atom("ptyext_constructors"), - Sexp.list(mapEmpty(~f=extensionConstructor, te.ptyext_constructors)), - }), - Sexp.list(list{Sexp.atom("ptyext_private"), privateFlag(te.ptyext_private)}), - attributes(te.ptyext_attributes), - }) - - and typeKind = kind => - switch kind { - | Ptype_abstract => Sexp.atom("Ptype_abstract") - | Ptype_variant(constrDecls) => - Sexp.list(list{ - Sexp.atom("Ptype_variant"), - Sexp.list(mapEmpty(~f=constructorDeclaration, constrDecls)), - }) - | Ptype_record(lblDecls) => - Sexp.list(list{Sexp.atom("Ptype_record"), Sexp.list(mapEmpty(~f=labelDeclaration, lblDecls))}) - | Ptype_open => Sexp.atom("Ptype_open") - } - - and constructorDeclaration = cd => - Sexp.list(list{ - Sexp.atom("constructor_declaration"), - string(cd.pcd_name.Asttypes.txt), - Sexp.list(list{Sexp.atom("pcd_args"), constructorArguments(cd.pcd_args)}), - Sexp.list(list{ - Sexp.atom("pcd_res"), - switch cd.pcd_res { - | None => Sexp.atom("None") - | Some(typ) => Sexp.list(list{Sexp.atom("Some"), coreType(typ)}) - }, - }), - attributes(cd.pcd_attributes), - }) - - and constructorArguments = args => - switch args { - | Pcstr_tuple(types) => - Sexp.list(list{Sexp.atom("Pcstr_tuple"), Sexp.list(mapEmpty(~f=coreType, types))}) - | Pcstr_record(lds) => - Sexp.list(list{Sexp.atom("Pcstr_record"), Sexp.list(mapEmpty(~f=labelDeclaration, lds))}) - } - - and labelDeclaration = ld => - Sexp.list(list{ - Sexp.atom("label_declaration"), - string(ld.pld_name.Asttypes.txt), - mutableFlag(ld.pld_mutable), - coreType(ld.pld_type), - attributes(ld.pld_attributes), - }) - - and expression = expr => { - let desc = switch expr.pexp_desc { - | Pexp_ident(longidentLoc) => - Sexp.list(list{Sexp.atom("Pexp_ident"), longident(longidentLoc.Asttypes.txt)}) - | Pexp_constant(c) => Sexp.list(list{Sexp.atom("Pexp_constant"), constant(c)}) - | Pexp_let(flag, vbs, expr) => - Sexp.list(list{ - Sexp.atom("Pexp_let"), - recFlag(flag), - Sexp.list(mapEmpty(~f=valueBinding, vbs)), - expression(expr), - }) - | Pexp_function(cases) => - Sexp.list(list{Sexp.atom("Pexp_function"), Sexp.list(mapEmpty(~f=case, cases))}) - | Pexp_fun(argLbl, exprOpt, pat, expr) => - Sexp.list(list{ - Sexp.atom("Pexp_fun"), - argLabel(argLbl), - switch exprOpt { - | None => Sexp.atom("None") - | Some(expr) => Sexp.list(list{Sexp.atom("Some"), expression(expr)}) - }, - pattern(pat), - expression(expr), - }) - | Pexp_apply(expr, args) => - Sexp.list(list{ - Sexp.atom("Pexp_apply"), - expression(expr), - Sexp.list( - mapEmpty( - ~f=((argLbl, expr)) => Sexp.list(list{argLabel(argLbl), expression(expr)}), - args, - ), - ), - }) - | Pexp_match(expr, cases) => - Sexp.list(list{ - Sexp.atom("Pexp_match"), - expression(expr), - Sexp.list(mapEmpty(~f=case, cases)), - }) - | Pexp_try(expr, cases) => - Sexp.list(list{Sexp.atom("Pexp_try"), expression(expr), Sexp.list(mapEmpty(~f=case, cases))}) - | Pexp_tuple(exprs) => - Sexp.list(list{Sexp.atom("Pexp_tuple"), Sexp.list(mapEmpty(~f=expression, exprs))}) - | Pexp_construct(longidentLoc, exprOpt) => - Sexp.list(list{ - Sexp.atom("Pexp_construct"), - longident(longidentLoc.Asttypes.txt), - switch exprOpt { - | None => Sexp.atom("None") - | Some(expr) => Sexp.list(list{Sexp.atom("Some"), expression(expr)}) - }, - }) - | Pexp_variant(lbl, exprOpt) => - Sexp.list(list{ - Sexp.atom("Pexp_variant"), - string(lbl), - switch exprOpt { - | None => Sexp.atom("None") - | Some(expr) => Sexp.list(list{Sexp.atom("Some"), expression(expr)}) - }, - }) - | Pexp_record(rows, optExpr) => - Sexp.list(list{ - Sexp.atom("Pexp_record"), - Sexp.list( - mapEmpty( - ~f=((longidentLoc, expr)) => - Sexp.list(list{longident(longidentLoc.Asttypes.txt), expression(expr)}), - rows, - ), - ), - switch optExpr { - | None => Sexp.atom("None") - | Some(expr) => Sexp.list(list{Sexp.atom("Some"), expression(expr)}) - }, - }) - | Pexp_field(expr, longidentLoc) => - Sexp.list(list{ - Sexp.atom("Pexp_field"), - expression(expr), - longident(longidentLoc.Asttypes.txt), - }) - | Pexp_setfield(expr1, longidentLoc, expr2) => - Sexp.list(list{ - Sexp.atom("Pexp_setfield"), - expression(expr1), - longident(longidentLoc.Asttypes.txt), - expression(expr2), - }) - | Pexp_array(exprs) => - Sexp.list(list{Sexp.atom("Pexp_array"), Sexp.list(mapEmpty(~f=expression, exprs))}) - | Pexp_ifthenelse(expr1, expr2, optExpr) => - Sexp.list(list{ - Sexp.atom("Pexp_ifthenelse"), - expression(expr1), - expression(expr2), - switch optExpr { - | None => Sexp.atom("None") - | Some(expr) => Sexp.list(list{Sexp.atom("Some"), expression(expr)}) - }, - }) - | Pexp_sequence(expr1, expr2) => - Sexp.list(list{Sexp.atom("Pexp_sequence"), expression(expr1), expression(expr2)}) - | Pexp_while(expr1, expr2) => - Sexp.list(list{Sexp.atom("Pexp_while"), expression(expr1), expression(expr2)}) - | Pexp_for(pat, e1, e2, flag, e3) => - Sexp.list(list{ - Sexp.atom("Pexp_for"), - pattern(pat), - expression(e1), - expression(e2), - directionFlag(flag), - expression(e3), - }) - | Pexp_constraint(expr, typexpr) => - Sexp.list(list{Sexp.atom("Pexp_constraint"), expression(expr), coreType(typexpr)}) - | Pexp_coerce(expr, optTyp, typexpr) => - Sexp.list(list{ - Sexp.atom("Pexp_coerce"), - expression(expr), - switch optTyp { - | None => Sexp.atom("None") - | Some(typ) => Sexp.list(list{Sexp.atom("Some"), coreType(typ)}) - }, - coreType(typexpr), - }) - | Pexp_send(_) => Sexp.list(list{Sexp.atom("Pexp_send")}) - | Pexp_new(_) => Sexp.list(list{Sexp.atom("Pexp_new")}) - | Pexp_setinstvar(_) => Sexp.list(list{Sexp.atom("Pexp_setinstvar")}) - | Pexp_override(_) => Sexp.list(list{Sexp.atom("Pexp_override")}) - | Pexp_letmodule(modName, modExpr, expr) => - Sexp.list(list{ - Sexp.atom("Pexp_letmodule"), - string(modName.Asttypes.txt), - moduleExpression(modExpr), - expression(expr), - }) - | Pexp_letexception(extConstr, expr) => - Sexp.list(list{ - Sexp.atom("Pexp_letexception"), - extensionConstructor(extConstr), - expression(expr), - }) - | Pexp_assert(expr) => Sexp.list(list{Sexp.atom("Pexp_assert"), expression(expr)}) - | Pexp_lazy(expr) => Sexp.list(list{Sexp.atom("Pexp_lazy"), expression(expr)}) - | Pexp_poly(_) => Sexp.list(list{Sexp.atom("Pexp_poly")}) - | Pexp_object(_) => Sexp.list(list{Sexp.atom("Pexp_object")}) - | Pexp_newtype(lbl, expr) => - Sexp.list(list{Sexp.atom("Pexp_newtype"), string(lbl.Asttypes.txt), expression(expr)}) - | Pexp_pack(modExpr) => Sexp.list(list{Sexp.atom("Pexp_pack"), moduleExpression(modExpr)}) - | Pexp_open(flag, longidentLoc, expr) => - Sexp.list(list{ - Sexp.atom("Pexp_open"), - overrideFlag(flag), - longident(longidentLoc.Asttypes.txt), - expression(expr), - }) - | Pexp_extension(ext) => Sexp.list(list{Sexp.atom("Pexp_extension"), extension(ext)}) - | Pexp_unreachable => Sexp.atom("Pexp_unreachable") - } - - Sexp.list(list{Sexp.atom("expression"), desc}) - } - - and case = c => - Sexp.list(list{ - Sexp.atom("case"), - Sexp.list(list{Sexp.atom("pc_lhs"), pattern(c.pc_lhs)}), - Sexp.list(list{ - Sexp.atom("pc_guard"), - switch c.pc_guard { - | None => Sexp.atom("None") - | Some(expr) => Sexp.list(list{Sexp.atom("Some"), expression(expr)}) - }, - }), - Sexp.list(list{Sexp.atom("pc_rhs"), expression(c.pc_rhs)}), - }) - - and pattern = p => { - let descr = switch p.ppat_desc { - | Ppat_any => Sexp.atom("Ppat_any") - | Ppat_var(var) => Sexp.list(list{Sexp.atom("Ppat_var"), string(var.Location.txt)}) - | Ppat_alias(p, alias) => - Sexp.list(list{Sexp.atom("Ppat_alias"), pattern(p), string(alias.txt)}) - | Ppat_constant(c) => Sexp.list(list{Sexp.atom("Ppat_constant"), constant(c)}) - | Ppat_interval(lo, hi) => - Sexp.list(list{Sexp.atom("Ppat_interval"), constant(lo), constant(hi)}) - | Ppat_tuple(patterns) => - Sexp.list(list{Sexp.atom("Ppat_tuple"), Sexp.list(mapEmpty(~f=pattern, patterns))}) - | Ppat_construct(longidentLoc, optPattern) => - Sexp.list(list{ - Sexp.atom("Ppat_construct"), - longident(longidentLoc.Location.txt), - switch optPattern { - | None => Sexp.atom("None") - | Some(p) => Sexp.list(list{Sexp.atom("some"), pattern(p)}) - }, - }) - | Ppat_variant(lbl, optPattern) => - Sexp.list(list{ - Sexp.atom("Ppat_variant"), - string(lbl), - switch optPattern { - | None => Sexp.atom("None") - | Some(p) => Sexp.list(list{Sexp.atom("Some"), pattern(p)}) - }, - }) - | Ppat_record(rows, flag) => - Sexp.list(list{ - Sexp.atom("Ppat_record"), - closedFlag(flag), - Sexp.list( - mapEmpty( - ~f=((longidentLoc, p)) => - Sexp.list(list{longident(longidentLoc.Location.txt), pattern(p)}), - rows, - ), - ), - }) - | Ppat_array(patterns) => - Sexp.list(list{Sexp.atom("Ppat_array"), Sexp.list(mapEmpty(~f=pattern, patterns))}) - | Ppat_or(p1, p2) => Sexp.list(list{Sexp.atom("Ppat_or"), pattern(p1), pattern(p2)}) - | Ppat_constraint(p, typexpr) => - Sexp.list(list{Sexp.atom("Ppat_constraint"), pattern(p), coreType(typexpr)}) - | Ppat_type(longidentLoc) => - Sexp.list(list{Sexp.atom("Ppat_type"), longident(longidentLoc.Location.txt)}) - | Ppat_lazy(p) => Sexp.list(list{Sexp.atom("Ppat_lazy"), pattern(p)}) - | Ppat_unpack(stringLoc) => - Sexp.list(list{Sexp.atom("Ppat_unpack"), string(stringLoc.Location.txt)}) - | Ppat_exception(p) => Sexp.list(list{Sexp.atom("Ppat_exception"), pattern(p)}) - | Ppat_extension(ext) => Sexp.list(list{Sexp.atom("Ppat_extension"), extension(ext)}) - | Ppat_open(longidentLoc, p) => - Sexp.list(list{Sexp.atom("Ppat_open"), longident(longidentLoc.Location.txt), pattern(p)}) - } - - Sexp.list(list{Sexp.atom("pattern"), descr}) - } - - and objectField = field => - switch field { - | Otag(lblLoc, attrs, typexpr) => - Sexp.list(list{Sexp.atom("Otag"), string(lblLoc.txt), attributes(attrs), coreType(typexpr)}) - | Oinherit(typexpr) => Sexp.list(list{Sexp.atom("Oinherit"), coreType(typexpr)}) - } - - and rowField = field => - switch field { - | Rtag(labelLoc, attrs, truth, types) => - Sexp.list(list{ - Sexp.atom("Rtag"), - string(labelLoc.txt), - attributes(attrs), - Sexp.atom( - if truth { - "true" - } else { - "false" - }, - ), - Sexp.list(mapEmpty(~f=coreType, types)), - }) - | Rinherit(typexpr) => Sexp.list(list{Sexp.atom("Rinherit"), coreType(typexpr)}) - } - - and packageType = ((modNameLoc, packageConstraints)) => - Sexp.list(list{ - Sexp.atom("package_type"), - longident(modNameLoc.Asttypes.txt), - Sexp.list( - mapEmpty( - ~f=((modNameLoc, typexpr)) => - Sexp.list(list{longident(modNameLoc.Asttypes.txt), coreType(typexpr)}), - packageConstraints, - ), - ), - }) - - and coreType = typexpr => { - let desc = switch typexpr.ptyp_desc { - | Ptyp_any => Sexp.atom("Ptyp_any") - | Ptyp_var(var) => Sexp.list(list{Sexp.atom("Ptyp_var"), string(var)}) - | Ptyp_arrow(argLbl, typ1, typ2) => - Sexp.list(list{Sexp.atom("Ptyp_arrow"), argLabel(argLbl), coreType(typ1), coreType(typ2)}) - | Ptyp_tuple(types) => - Sexp.list(list{Sexp.atom("Ptyp_tuple"), Sexp.list(mapEmpty(~f=coreType, types))}) - | Ptyp_constr(longidentLoc, types) => - Sexp.list(list{ - Sexp.atom("Ptyp_constr"), - longident(longidentLoc.txt), - Sexp.list(mapEmpty(~f=coreType, types)), - }) - | Ptyp_alias(typexpr, alias) => - Sexp.list(list{Sexp.atom("Ptyp_alias"), coreType(typexpr), string(alias)}) - | Ptyp_object(fields, flag) => - Sexp.list(list{ - Sexp.atom("Ptyp_object"), - closedFlag(flag), - Sexp.list(mapEmpty(~f=objectField, fields)), - }) - | Ptyp_class(longidentLoc, types) => - Sexp.list(list{ - Sexp.atom("Ptyp_class"), - longident(longidentLoc.Location.txt), - Sexp.list(mapEmpty(~f=coreType, types)), - }) - | Ptyp_variant(fields, flag, optLabels) => - Sexp.list(list{ - Sexp.atom("Ptyp_variant"), - Sexp.list(mapEmpty(~f=rowField, fields)), - closedFlag(flag), - switch optLabels { - | None => Sexp.atom("None") - | Some(lbls) => Sexp.list(mapEmpty(~f=string, lbls)) - }, - }) - | Ptyp_poly(lbls, typexpr) => - Sexp.list(list{ - Sexp.atom("Ptyp_poly"), - Sexp.list(mapEmpty(~f=lbl => string(lbl.Asttypes.txt), lbls)), - coreType(typexpr), - }) - | Ptyp_package(package) => Sexp.list(list{Sexp.atom("Ptyp_package"), packageType(package)}) - | Ptyp_extension(ext) => Sexp.list(list{Sexp.atom("Ptyp_extension"), extension(ext)}) - } - - Sexp.list(list{Sexp.atom("core_type"), desc}) - } - - and payload = p => - switch p { - | PStr(s) => Sexp.list(list{Sexp.atom("PStr"), ...mapEmpty(~f=structureItem, s)}) - | PSig(s) => Sexp.list(list{Sexp.atom("PSig"), signature(s)}) - | PTyp(ct) => Sexp.list(list{Sexp.atom("PTyp"), coreType(ct)}) - | PPat(pat, optExpr) => - Sexp.list(list{ - Sexp.atom("PPat"), - pattern(pat), - switch optExpr { - | Some(expr) => Sexp.list(list{Sexp.atom("Some"), expression(expr)}) - | None => Sexp.atom("None") - }, - }) - } - - and attribute = ((stringLoc, p)) => - Sexp.list(list{Sexp.atom("attribute"), Sexp.atom(stringLoc.Asttypes.txt), payload(p)}) - - and extension = ((stringLoc, p)) => - Sexp.list(list{Sexp.atom("extension"), Sexp.atom(stringLoc.Asttypes.txt), payload(p)}) - - and attributes = attrs => { - let sexprs = mapEmpty(~f=attribute, attrs) - Sexp.list(list{Sexp.atom("attributes"), ...sexprs}) - } - - let implementation = structure - let interface = signature -} - -module IO: { - let readFile: string => string - let readStdin: unit => string -} = { - /* random chunk size: 2^15, TODO: why do we guess randomly? */ - let chunkSize = 32768 - - let readFile = filename => { - let chan = open_in(filename) - let buffer = Buffer.create(chunkSize) - let chunk = (@doesNotRaise Bytes.create)(chunkSize) - let rec loop = () => { - let len = try input(chan, chunk, 0, chunkSize) catch { - | Invalid_argument(_) => 0 - } - if len === 0 { - close_in_noerr(chan) - Buffer.contents(buffer) - } else { - Buffer.add_subbytes(buffer, chunk, 0, len) - loop() - } - } - - loop() - } - - let readStdin = () => { - let buffer = Buffer.create(chunkSize) - let chunk = (@doesNotRaise Bytes.create)(chunkSize) - let rec loop = () => { - let len = try input(stdin, chunk, 0, chunkSize) catch { - | Invalid_argument(_) => 0 - } - if len === 0 { - close_in_noerr(stdin) - Buffer.contents(buffer) - } else { - Buffer.add_subbytes(buffer, chunk, 0, len) - loop() - } - } - - loop() - } -} - -module CharacterCodes = { - let eof = -1 - - let space = 0x0020 - @live let newline = 0x0A /* \n */ - let lineFeed = 0x0A /* \n */ - let carriageReturn = 0x0D /* \r */ - let lineSeparator = 0x2028 - let paragraphSeparator = 0x2029 - - let tab = 0x09 - - let bang = 0x21 - let dot = 0x2E - let colon = 0x3A - let comma = 0x2C - let backtick = 0x60 - /* let question = 0x3F */ - let semicolon = 0x3B - let underscore = 0x5F - let singleQuote = 0x27 - let doubleQuote = 0x22 - let equal = 0x3D - let bar = 0x7C - let tilde = 0x7E - let question = 0x3F - let ampersand = 0x26 - let at = 0x40 - let dollar = 0x24 - let percent = 0x25 - - let lparen = 0x28 - let rparen = 0x29 - let lbracket = 0x5B - let rbracket = 0x5D - let lbrace = 0x7B - let rbrace = 0x7D - - let forwardslash = 0x2F /* / */ - let backslash = 0x5C /* \ */ - - let greaterThan = 0x3E - let hash = 0x23 - let lessThan = 0x3C - - let minus = 0x2D - let plus = 0x2B - let asterisk = 0x2A - - let _0 = 0x30 - @live let _1 = 0x31 - @live let _2 = 0x32 - @live let _3 = 0x33 - @live let _4 = 0x34 - @live let _5 = 0x35 - @live let _6 = 0x36 - @live let _7 = 0x37 - @live let _8 = 0x38 - let _9 = 0x39 - - module Lower = { - let a = 0x61 - let b = 0x62 - @live let c = 0x63 - @live let d = 0x64 - let e = 0x65 - let f = 0x66 - let g = 0x67 - @live let h = 0x68 - @live let i = 0x69 - @live let j = 0x6A - @live let k = 0x6B - @live let l = 0x6C - @live let m = 0x6D - let n = 0x6E - let o = 0x6F - let p = 0x70 - @live let q = 0x71 - let r = 0x72 - @live let s = 0x73 - let t = 0x74 - @live let u = 0x75 - @live let v = 0x76 - @live let w = 0x77 - let x = 0x78 - @live let y = 0x79 - let z = 0x7A - } - - module Upper = { - let a = 0x41 - /* let b = 0x42 */ - @live let c = 0x43 - @live let d = 0x44 - @live let e = 0x45 - @live let f = 0x46 - let g = 0x47 - @live let h = 0x48 - @live let i = 0x49 - @live let j = 0x4A - @live let k = 0x4B - @live let l = 0x4C - @live let m = 0x4D - @live let b = 0x4E - @live let o = 0x4F - @live let p = 0x50 - @live let q = 0x51 - @live let r = 0x52 - @live let s = 0x53 - @live let t = 0x54 - @live let u = 0x55 - @live let v = 0x56 - @live let w = 0x57 - @live let x = 0x58 - @live let y = 0x59 - let z = 0x5a - } - - /* returns lower-case ch, ch should be ascii */ - let lower = ch => - /* if ch >= Lower.a && ch <= Lower.z then ch else ch + 32 */ - lor(32, ch) - - let isLetter = ch => (Lower.a <= ch && ch <= Lower.z) || (Upper.a <= ch && ch <= Upper.z) - - let isUpperCase = ch => Upper.a <= ch && ch <= Upper.z - - let isDigit = ch => _0 <= ch && ch <= _9 - - let isHex = ch => (_0 <= ch && ch <= _9) || (Lower.a <= lower(ch) && lower(ch) <= Lower.f) - - /* - // ES5 7.3: - // The ECMAScript line terminator characters are listed in Table 3. - // Table 3: Line Terminator Characters - // Code Unit Value Name Formal Name - // \u000A Line Feed - // \u000D Carriage Return - // \u2028 Line separator - // \u2029 Paragraph separator - // Only the characters in Table 3 are treated as line terminators. Other new line or line - // breaking characters are treated as white space but not as line terminators. - */ - let isLineBreak = ch => - ch === lineFeed || - (ch === carriageReturn || - (ch === lineSeparator || ch === paragraphSeparator)) - - let digitValue = ch => - if _0 <= ch && ch <= _9 { - ch - 48 - } else if Lower.a <= lower(ch) && lower(ch) <= Lower.f { - lower(ch) - Lower.a + 10 - } else { - 16 - } /* larger than any legal value */ -} - -module Comment: { - type t - - let toString: t => string - - let loc: t => Location.t - let txt: t => string - let prevTokEndPos: t => Lexing.position - - let setPrevTokEndPos: (t, Lexing.position) => unit - - let isSingleLineComment: t => bool - - let makeSingleLineComment: (~loc: Location.t, string) => t - let makeMultiLineComment: (~loc: Location.t, string) => t - let fromOcamlComment: (~loc: Location.t, ~txt: string, ~prevTokEndPos: Lexing.position) => t - let trimSpaces: string => string -} = { - type style = - | SingleLine - | MultiLine - - let styleToString = s => - switch s { - | SingleLine => "SingleLine" - | MultiLine => "MultiLine" - } - - type t = { - txt: string, - style: style, - loc: Location.t, - mutable prevTokEndPos: Lexing.position, - } - - let loc = t => t.loc - let txt = t => t.txt - let prevTokEndPos = t => t.prevTokEndPos - - let setPrevTokEndPos = (t, pos) => t.prevTokEndPos = pos - - let isSingleLineComment = t => - switch t.style { - | SingleLine => true - | MultiLine => false - } - - let toString = t => - Format.sprintf( - "(txt: %s\nstyle: %s\nlines: %d-%d)", - t.txt, - styleToString(t.style), - t.loc.loc_start.pos_lnum, - t.loc.loc_end.pos_lnum, - ) - - let makeSingleLineComment = (~loc, txt) => { - txt: txt, - loc: loc, - style: SingleLine, - prevTokEndPos: Lexing.dummy_pos, - } - - let makeMultiLineComment = (~loc, txt) => { - txt: txt, - loc: loc, - style: MultiLine, - prevTokEndPos: Lexing.dummy_pos, - } - - let fromOcamlComment = (~loc, ~txt, ~prevTokEndPos) => { - txt: txt, - loc: loc, - style: MultiLine, - prevTokEndPos: prevTokEndPos, - } - - let trimSpaces = s => { - let len = String.length(s) - if len == 0 { - s - } else if String.unsafe_get(s, 0) == ' ' || String.unsafe_get(s, len - 1) == ' ' { - let b = Bytes.of_string(s) - let i = ref(0) - while i.contents < len && Bytes.unsafe_get(b, i.contents) == ' ' { - incr(i) - } - let j = ref(len - 1) - while j.contents >= i.contents && Bytes.unsafe_get(b, j.contents) == ' ' { - decr(j) - } - if j.contents >= i.contents { - (@doesNotRaise Bytes.sub)(b, i.contents, j.contents - i.contents + 1) |> Bytes.to_string - } else { - "" - } - } else { - s - } - } -} - -module Token = { - type t = - | Open - | True - | False - | Character(char) - | Int({i: string, suffix: option}) - | Float({f: string, suffix: option}) - | String(string) - | Lident(string) - | Uident(string) - | As - | Dot - | DotDot - | DotDotDot - | Bang - | Semicolon - | Let - | And - | Rec - | Underscore - | SingleQuote - | Equal - | EqualEqual - | EqualEqualEqual - | Bar - | Lparen - | Rparen - | Lbracket - | Rbracket - | Lbrace - | Rbrace - | Colon - | Comma - | Eof - | Exception - | @live Backslash - | Forwardslash - | ForwardslashDot - | Asterisk - | AsteriskDot - | Exponentiation - | Minus - | MinusDot - | Plus - | PlusDot - | PlusPlus - | PlusEqual - | ColonGreaterThan - | GreaterThan - | LessThan - | LessThanSlash - | Hash - | HashEqual - | HashHash - | Assert - | Lazy - | Tilde - | Question - | If - | Else - | For - | In - | To - | Downto - | While - | Switch - | When - | EqualGreater - | MinusGreater - | External - | Typ - | Private - | Mutable - | Constraint - | Include - | Module - | Of - | With - | Land - | Lor - | Band /* Bitwise and: & */ - | BangEqual - | BangEqualEqual - | LessEqual - | GreaterEqual - | ColonEqual - | At - | AtAt - | Percent - | PercentPercent - | Comment(Comment.t) - | List - | TemplateTail(string) - | TemplatePart(string) - | Backtick - | BarGreater - | Try - | Catch - | Import - | Export - - let precedence = x => - switch x { - | HashEqual | ColonEqual => 1 - | Lor => 2 - | Land => 3 - | Equal - | EqualEqual - | EqualEqualEqual - | LessThan - | GreaterThan - | BangEqual - | BangEqualEqual - | LessEqual - | GreaterEqual - | BarGreater => 4 - | Plus | PlusDot | Minus | MinusDot | PlusPlus => 5 - | Asterisk | AsteriskDot | Forwardslash | ForwardslashDot => 6 - | Exponentiation => 7 - | MinusGreater => 8 - | Dot => 9 - | _ => 0 - } - - let toString = x => - switch x { - | Open => "open" - | True => "true" - | False => "false" - | Character(c) => "'" ++ (Char.escaped(c) ++ "'") - | String(s) => s - | Lident(str) => str - | Uident(str) => str - | Dot => "." - | DotDot => ".." - | DotDotDot => "..." - | Int({i}) => "int " ++ i - | Float({f}) => "Float: " ++ f - | Bang => "!" - | Semicolon => ";" - | Let => "let" - | And => "and" - | Rec => "rec" - | Underscore => "_" - | SingleQuote => "'" - | Equal => "=" - | EqualEqual => "==" - | EqualEqualEqual => "===" - | Eof => "eof" - | Bar => "|" - | As => "as" - | Lparen => "(" - | Rparen => ")" - | Lbracket => "[" - | Rbracket => "]" - | Lbrace => "{" - | Rbrace => "}" - | ColonGreaterThan => ":>" - | Colon => ":" - | Comma => "," - | Minus => "-" - | MinusDot => "-." - | Plus => "+" - | PlusDot => "+." - | PlusPlus => "++" - | PlusEqual => "+=" - | Backslash => "\\" - | Forwardslash => "/" - | ForwardslashDot => "/." - | Exception => "exception" - | Hash => "#" - | HashHash => "##" - | HashEqual => "#=" - | GreaterThan => ">" - | LessThan => "<" - | LessThanSlash => " "*" - | AsteriskDot => "*." - | Exponentiation => "**" - | Assert => "assert" - | Lazy => "lazy" - | Tilde => "tilde" - | Question => "?" - | If => "if" - | Else => "else" - | For => "for" - | In => "in" - | To => "to" - | Downto => "downto" - | While => "while" - | Switch => "switch" - | When => "when" - | EqualGreater => "=>" - | MinusGreater => "->" - | External => "external" - | Typ => "type" - | Private => "private" - | Constraint => "constraint" - | Mutable => "mutable" - | Include => "include" - | Module => "module" - | Of => "of" - | With => "with" - | Lor => "||" - | Band => "&" - | Land => "&&" - | BangEqual => "!=" - | BangEqualEqual => "!==" - | GreaterEqual => ">=" - | LessEqual => "<=" - | ColonEqual => ":=" - | At => "@" - | AtAt => "@@" - | Percent => "%" - | PercentPercent => "%%" - | Comment(c) => "Comment(" ++ (Comment.toString(c) ++ ")") - | List => "list" - | TemplatePart(text) => text ++ "${" - | TemplateTail(text) => "TemplateTail(" ++ (text ++ ")") - | Backtick => "`" - | BarGreater => "|>" - | Try => "try" - | Catch => "catch" - | Import => "import" - | Export => "export" - } - - @raises(Not_found) - let keywordTable = x => - switch x { - | "true" => True - | "false" => False - | "open" => Open - | "let" => Let - | "rec" => Rec - | "and" => And - | "as" => As - | "exception" => Exception - | "assert" => Assert - | "lazy" => Lazy - | "if" => If - | "else" => Else - | "for" => For - | "in" => In - | "to" => To - | "downto" => Downto - | "while" => While - | "switch" => Switch - | "when" => When - | "external" => External - | "type" => Typ - | "private" => Private - | "mutable" => Mutable - | "constraint" => Constraint - | "include" => Include - | "module" => Module - | "of" => Of - | "list" => List - | "with" => With - | "try" => Try - | "catch" => Catch - | "import" => Import - | "export" => Export - | _ => raise(Not_found) - } - - let isKeyword = x => - switch x { - | True - | False - | Open - | Let - | Rec - | And - | As - | Exception - | Assert - | Lazy - | If - | Else - | For - | In - | To - | Downto - | While - | Switch - | When - | External - | Typ - | Private - | Mutable - | Constraint - | Include - | Module - | Of - | Land - | Lor - | List - | With - | Try - | Catch - | Import - | Export => true - | _ => false - } - - let lookupKeyword = str => - try keywordTable(str) catch { - | Not_found => - if CharacterCodes.isUpperCase(int_of_char(@doesNotRaise String.get(str, 0))) { - Uident(str) - } else { - Lident(str) - } - } - - let isKeywordTxt = str => - try { - let _ = keywordTable(str) - true - } catch { - | Not_found => false - } -} - -module Grammar = { - type t = - | OpenDescription /* open Belt */ - | @live ModuleLongIdent /* Foo or Foo.Bar */ - | Ternary /* condExpr ? trueExpr : falseExpr */ - | Es6ArrowExpr - | Jsx - | JsxAttribute - | @live JsxChild - | ExprOperand - | ExprUnary - | ExprSetField - | ExprBinaryAfterOp(Token.t) - | ExprBlock - | ExprCall - | ExprList - | ExprArrayAccess - | ExprArrayMutation - | ExprIf - | IfCondition - | IfBranch - | ElseBranch - | TypeExpression - | External - | PatternMatching - | PatternMatchCase - | LetBinding - | PatternList - | PatternOcamlList - | PatternRecord - - | TypeDef - | TypeConstrName - | TypeParams - | @live TypeParam - | PackageConstraint - - | TypeRepresentation - - | RecordDecl - | ConstructorDeclaration - | ParameterList - | StringFieldDeclarations - | FieldDeclarations - | TypExprList - | FunctorArgs - | ModExprList - | TypeParameters - | RecordRows - | RecordRowsStringKey - | ArgumentList - | Signature - | Specification - | Structure - | Implementation - | Attribute - | TypeConstraint - | Primitive - | AtomicTypExpr - | ListExpr - | JsFfiImport - - let toString = x => - switch x { - | OpenDescription => "an open description" - | ModuleLongIdent => "a module identifier" - | Ternary => "a ternary expression" - | Es6ArrowExpr => "an es6 arrow function" - | Jsx => "a jsx expression" - | JsxAttribute => "a jsx attribute" - | ExprOperand => "a basic expression" - | ExprUnary => "a unary expression" - | ExprBinaryAfterOp(op) => "an expression after the operator \"" ++ (Token.toString(op) ++ "\"") - | ExprIf => "an if expression" - | IfCondition => "the condition of an if expression" - | IfBranch => "the true-branch of an if expression" - | ElseBranch => "the else-branch of an if expression" - | TypeExpression => "a type" - | External => "an external" - | PatternMatching => "the cases of a pattern match" - | ExprBlock => "a block with expressions" - | ExprSetField => "a record field mutation" - | ExprCall => "a function application" - | ExprArrayAccess => "an array access expression" - | ExprArrayMutation => "an array mutation" - | LetBinding => "a let binding" - | TypeDef => "a type definition" - | TypeParams => "type parameters" - | TypeParam => "a type parameter" - | TypeConstrName => "a type-constructor name" - | TypeRepresentation => "a type representation" - | RecordDecl => "a record declaration" - | PatternMatchCase => "a pattern match case" - | ConstructorDeclaration => "a constructor declaration" - | ExprList => "multiple expressions" - | PatternList => "multiple patterns" - | PatternOcamlList => "a list pattern" - | PatternRecord => "a record pattern" - | ParameterList => "parameters" - | StringFieldDeclarations => "string field declarations" - | FieldDeclarations => "field declarations" - | TypExprList => "list of types" - | FunctorArgs => "functor arguments" - | ModExprList => "list of module expressions" - | TypeParameters => "list of type parameters" - | RecordRows => "rows of a record" - | RecordRowsStringKey => "rows of a record with string keys" - | ArgumentList => "arguments" - | Signature => "signature" - | Specification => "specification" - | Structure => "structure" - | Implementation => "implementation" - | Attribute => "an attribute" - | TypeConstraint => "constraints on a type" - | Primitive => "an external primitive" - | AtomicTypExpr => "a type" - | ListExpr => "an ocaml list expr" - | PackageConstraint => "a package constraint" - | JsFfiImport => "js ffi import" - | JsxChild => "jsx child" - } - - let isSignatureItemStart = x => - switch x { - | Token.At - | Let - | Typ - | External - | Exception - | Open - | Include - | Module - | AtAt - | PercentPercent => true - | _ => false - } - - let isAtomicPatternStart = x => - switch x { - | Token.Int(_) - | String(_) - | Character(_) - | Lparen - | Lbracket - | Lbrace - | Underscore - | Lident(_) - | Uident(_) - | List - | Exception - | Lazy - | Percent => true - | _ => false - } - - let isAtomicExprStart = x => - switch x { - | Token.True - | False - | Int(_) - | String(_) - | Float(_) - | Character(_) - | Backtick - | Uident(_) - | Lident(_) - | Hash - | Lparen - | List - | Lbracket - | Lbrace - | LessThan - | Module - | Percent => true - | _ => false - } - - let isAtomicTypExprStart = x => - switch x { - | Token.SingleQuote - | Underscore - | Lparen - | Lbrace - | Uident(_) - | Lident(_) - | List - | Percent => true - | _ => false - } - - let isExprStart = x => - switch x { - | Token.True - | False - | Int(_) - | String(_) - | Float(_) - | Character(_) - | Backtick - | Underscore - | Uident(_) - | Lident(_) - | Hash - | Lparen - | List - | Module - | Lbracket - | Lbrace - | LessThan - | Minus - | MinusDot - | Plus - | PlusDot - | Bang - | Percent - | At - | If - | Switch - | While - | For - | Assert - | Lazy - | Try => true - | _ => false - } - - let isJsxAttributeStart = x => - switch x { - | Token.Lident(_) | Question => true - | _ => false - } - - let isStructureItemStart = x => - switch x { - | Token.Open - | Let - | Typ - | External - | Import - | Export - | Exception - | Include - | Module - | AtAt - | PercentPercent - | At => true - | t when isExprStart(t) => true - | _ => false - } - - let isPatternStart = x => - switch x { - | Token.Int(_) - | Float(_) - | String(_) - | Character(_) - | True - | False - | Minus - | Plus - | Lparen - | Lbracket - | Lbrace - | List - | Underscore - | Lident(_) - | Uident(_) - | Hash - | HashHash - | Exception - | Lazy - | Percent - | Module - | At => true - | _ => false - } - - let isParameterStart = x => - switch x { - | Token.Typ | Tilde | Dot => true - | token when isPatternStart(token) => true - | _ => false - } - - /* TODO: overparse Uident ? */ - let isStringFieldDeclStart = x => - switch x { - | Token.String(_) | At => true - | _ => false - } - - /* TODO: overparse Uident ? */ - let isFieldDeclStart = x => - switch x { - | Token.At | Mutable | Lident(_) | List => true - /* recovery, TODO: this is not ideal… */ - | Uident(_) => true - | t when Token.isKeyword(t) => true - | _ => false - } - - let isRecordDeclStart = x => - switch x { - | Token.At | Mutable | Lident(_) | List => true - | _ => false - } - - let isTypExprStart = x => - switch x { - | Token.At - | SingleQuote - | Underscore - | Lparen - | Lbracket - | Uident(_) - | Lident(_) - | List - | Module - | Percent - | Lbrace => true - | _ => false - } - - let isTypeParameterStart = x => - switch x { - | Token.Tilde | Dot => true - | token when isTypExprStart(token) => true - | _ => false - } - - let isTypeParamStart = x => - switch x { - | Token.Plus | Minus | SingleQuote | Underscore => true - | _ => false - } - - let isFunctorArgStart = x => - switch x { - | Token.At | Uident(_) | Underscore | Percent | Lbrace | Lparen => true - | _ => false - } - - let isModExprStart = x => - switch x { - | Token.At | Percent | Uident(_) | Lbrace | Lparen => true - | _ => false - } - - let isRecordRowStart = x => - switch x { - | Token.DotDotDot => true - | Token.Uident(_) | Lident(_) | List => true - /* TODO */ - | t when Token.isKeyword(t) => true - | _ => false - } - - let isRecordRowStringKeyStart = x => - switch x { - | Token.String(_) => true - | _ => false - } - - let isArgumentStart = x => - switch x { - | Token.Tilde | Dot | Underscore => true - | t when isExprStart(t) => true - | _ => false - } - - let isPatternMatchStart = x => - switch x { - | Token.Bar => true - | t when isPatternStart(t) => true - | _ => false - } - - let isPatternOcamlListStart = x => - switch x { - | Token.DotDotDot => true - | t when isPatternStart(t) => true - | _ => false - } - - let isPatternRecordItemStart = x => - switch x { - | Token.DotDotDot | Uident(_) | Lident(_) | List | Underscore => true - | _ => false - } - - let isAttributeStart = x => - switch x { - | Token.At => true - | _ => false - } - - let isJsFfiImportStart = x => - switch x { - | Token.Lident(_) | At => true - | _ => false - } - - let isJsxChildStart = isAtomicExprStart - - let isBlockExprStart = x => - switch x { - | Token.At - | Hash - | Percent - | Minus - | MinusDot - | Plus - | PlusDot - | Bang - | True - | False - | Int(_) - | String(_) - | Character(_) - | Lident(_) - | Uident(_) - | Lparen - | List - | Lbracket - | Lbrace - | Forwardslash - | Assert - | Lazy - | If - | For - | While - | Switch - | Open - | Module - | Exception - | Let - | LessThan - | Backtick - | Try - | Underscore => true - | _ => false - } - - let isListElement = (grammar, token) => - switch grammar { - | ExprList => token == Token.DotDotDot || isExprStart(token) - | ListExpr => token == DotDotDot || isExprStart(token) - | PatternList => token == DotDotDot || isPatternStart(token) - | ParameterList => isParameterStart(token) - | StringFieldDeclarations => isStringFieldDeclStart(token) - | FieldDeclarations => isFieldDeclStart(token) - | RecordDecl => isRecordDeclStart(token) - | TypExprList => isTypExprStart(token) || token == Token.LessThan - | TypeParams => isTypeParamStart(token) - | FunctorArgs => isFunctorArgStart(token) - | ModExprList => isModExprStart(token) - | TypeParameters => isTypeParameterStart(token) - | RecordRows => isRecordRowStart(token) - | RecordRowsStringKey => isRecordRowStringKeyStart(token) - | ArgumentList => isArgumentStart(token) - | Signature | Specification => isSignatureItemStart(token) - | Structure | Implementation => isStructureItemStart(token) - | PatternMatching => isPatternMatchStart(token) - | PatternOcamlList => isPatternOcamlListStart(token) - | PatternRecord => isPatternRecordItemStart(token) - | Attribute => isAttributeStart(token) - | TypeConstraint => token == Constraint - | PackageConstraint => token == And - | ConstructorDeclaration => token == Bar - | Primitive => - switch token { - | Token.String(_) => true - | _ => false - } - | JsxAttribute => isJsxAttributeStart(token) - | JsFfiImport => isJsFfiImportStart(token) - | _ => false - } - - let isListTerminator = (grammar, token) => - switch (grammar, token) { - | (_, Token.Eof) - | (ExprList, Rparen | Forwardslash | Rbracket) - | (ListExpr, Rparen) - | (ArgumentList, Rparen) - | (TypExprList, Rparen | Forwardslash | GreaterThan | Equal) - | (ModExprList, Rparen) - | ( - PatternList | PatternOcamlList | PatternRecord, - Forwardslash | Rbracket | Rparen | EqualGreater | In | Equal /* let {x} = foo */, - ) - | (ExprBlock, Rbrace) - | (Structure | Signature, Rbrace) - | (TypeParams, Rparen) - | (ParameterList, EqualGreater | Lbrace) - | (JsxAttribute, Forwardslash | GreaterThan) - | (JsFfiImport, Rbrace) - | (StringFieldDeclarations, Rbrace) => true - - | (Attribute, token) when token != At => true - | (TypeConstraint, token) when token != Constraint => true - | (PackageConstraint, token) when token != And => true - | (ConstructorDeclaration, token) when token != Bar => true - | (Primitive, Semicolon) => true - | (Primitive, token) when isStructureItemStart(token) => true - - | _ => false - } - - let isPartOfList = (grammar, token) => - isListElement(grammar, token) || isListTerminator(grammar, token) -} - -module Reporting = { - module TerminalDoc = { - type break = - | Never - | Always - - type rec document = - | Nil - | Group({break: break, doc: document}) - | Text(string) - | Indent({amount: int, doc: document}) - | Append({doc1: document, doc2: document}) - - let group = (~break, doc) => Group({break: break, doc: doc}) - let text = txt => Text(txt) - let indent = (i, d) => Indent({amount: i, doc: d}) - let append = (d1, d2) => Append({doc1: d1, doc2: d2}) - let nil = Nil - - type rec stack = - | Empty - | Cons({doc: document, stack: stack}) - - let push = (stack, doc) => Cons({doc: doc, stack: stack}) - - type mode = - | Flat - | Break - - let toString /* ~width */ = (doc: document) => { - let buffer = Buffer.create(100) - let rec loop = (stack, mode, offset) => - switch stack { - | Empty => () - | Cons({doc, stack: rest}) => - switch doc { - | Nil => loop(rest, mode, offset) - | Text(txt) => - Buffer.add_string(buffer, txt) - loop(rest, mode, offset + String.length(txt)) - | Indent({amount: i, doc}) => - let indentation = (@doesNotRaise String.make)(i, ' ') - Buffer.add_string(buffer, indentation) - loop(push(rest, doc), mode, offset + i) - | Append({doc1, doc2}) => - let rest = push(rest, doc2) - let rest = push(rest, mode == Flat ? Nil : text("\n")) - - let rest = push(rest, doc1) - loop(rest, mode, offset) - | Group({break, doc}) => - let rest = push(rest, doc) - switch break { - | Always => loop(rest, Break, offset) - | Never => loop(rest, Flat, offset) - } - } - } - - loop(push(Empty, doc), Flat, 0) - Buffer.contents(buffer) - } - } - - type color = - | @live NoColor - | @live Red - - type style = { - @live underline: bool, - @live color: color, - } - - let highlight = (~from, ~len, txt) => - if from < 0 || (String.length(txt) === 0 || from >= String.length(txt)) { - txt - } else { - let before = try String.sub(txt, 0, from) catch { - | Invalid_argument(_) => "" - } - let content = - "\027[31m" ++ - (try String.sub(txt, from, len) catch { - | Invalid_argument(_) => "" - } ++ - "\027[0m") - - let after = try String.sub(txt, from + len, String.length(txt) - (from + len)) catch { - | Invalid_argument(_) => "" - } - before ++ (content ++ after) - } - - let underline = (~from, ~len, txt) => { - open TerminalDoc - let indent = (@doesNotRaise String.make)(from, ' ') - let underline = (@doesNotRaise String.make)(len, '^') - let line = highlight(~from=0, ~len, underline) - group(~break=Always, append(text(txt), text(indent ++ line))) - } - - let rec drop = (n, l) => - if n === 1 { - l - } else { - drop( - n - 1, - switch l { - | list{_x, ...xs} => xs - | _ => l - }, - ) - } - - let rec take = (n, l) => - switch l { - | _ when n === 0 => list{} - | list{} => list{} - | list{x, ...xs} => list{x, ...take(n - 1, xs)} - } - - /* TODO: cleanup */ - let renderCodeContext = (~missing, src: string, startPos, endPos) => { - open Lexing - let startCol = startPos.pos_cnum - startPos.pos_bol - let endCol = endPos.pos_cnum - startPos.pos_cnum + startCol - let startLine = max(1, startPos.pos_lnum - 2) /* 2 lines before */ - let lines = String.split_on_char('\n', src) - let endLine = { - let len = List.length(lines) - min(len, startPos.pos_lnum + 3) - } /* 2 lines after */ - - let lines = lines |> drop(startLine) |> take(endLine - startLine) |> Array.of_list - - let renderLine = (x, ix) => { - let x = if ix == startPos.pos_lnum { - switch missing { - | Some(_len) => x ++ @doesNotRaise String.make(10, ' ') - | None => x - } - } else { - x - } - - open TerminalDoc - let rowNr = { - let txt = string_of_int(ix) - let len = String.length(txt) - if ix == startPos.pos_lnum { - highlight(~from=0, ~len, txt) - } else { - txt - } - } - - let len = { - let len = if endCol >= 0 { - endCol - startCol - } else { - 1 - } - - if startCol + len > String.length(x) { - String.length(x) - startCol - 1 - } else { - len - } - } - - let line = if ix == startPos.pos_lnum { - switch missing { - | Some(len) => - underline( - ~from=startCol + String.length(String.length(string_of_int(ix)) |> string_of_int) + 5, - ~len, - x, - ) - | None => - let len = if startCol + len > String.length(x) { - String.length(x) - startCol - } else { - len - } - - text(highlight(~from=startCol, ~len, x)) - } - } else { - text(x) - } - - group(~break=Never, append(append(text(rowNr), text(" │")), indent(2, line))) - } - - let reportDoc = ref(TerminalDoc.nil) - - let linesLen = Array.length(lines) - for i in 0 to linesLen - 1 { - let line = try lines[i] catch { - | Invalid_argument(_) => "" - } - reportDoc := { - open TerminalDoc - let ix = startLine + i - group(~break=Always, append(reportDoc.contents, renderLine(line, ix))) - } - } - - TerminalDoc.toString(reportDoc.contents) - } - - type problem = - | @live Unexpected(Token.t) - | @live Expected({token: Token.t, pos: Lexing.position, context: option}) - | @live Message(string) - | @live Uident - | @live Lident - | @live Unbalanced(Token.t) - - type parseError = (Lexing.position, problem) -} - -module Diagnostics: { - type t - type category - type report - - type reportStyle - let parseReportStyle: string => reportStyle - - let unexpected: (Token.t, list<(Grammar.t, Lexing.position)>) => category - let expected: (~grammar: Grammar.t=?, Lexing.position, Token.t) => category - let uident: Token.t => category - let lident: Token.t => category - let unclosedString: category - let unclosedTemplate: category - let unclosedComment: category - let unknownUchar: int => category - let message: string => category - - let make: (~filename: string, ~startPos: Lexing.position, ~endPos: Lexing.position, category) => t - - let stringOfReport: (~style: reportStyle, list, string) => string -} = { - type category = - | Unexpected({token: Token.t, context: list<(Grammar.t, Lexing.position)>}) - | Expected({ - context: option, - pos: Lexing.position /* prev token end */, - token: Token.t, - }) - | Message(string) - | Uident(Token.t) - | Lident(Token.t) - | UnclosedString - | UnclosedTemplate - | UnclosedComment - | UnknownUchar(int) - - type t = { - filename: string, - startPos: Lexing.position, - endPos: Lexing.position, - category: category, - } - - type report = list - - /* TODO: add json here */ - type reportStyle = - | Pretty - | Plain - - let parseReportStyle = txt => - switch String.lowercase_ascii(txt) { - | "plain" => Plain - | _ => Pretty - } - - let defaultUnexpected = token => - "I'm not sure what to parse here when looking at \"" ++ (Token.toString(token) ++ "\".") - - let explain = t => - switch t.category { - | Uident(currentToken) => - switch currentToken { - | Lident(lident) => - let guess = String.capitalize_ascii(lident) - "Did you mean `" ++ (guess ++ ("` instead of `" ++ (lident ++ "`?"))) - | t when Token.isKeyword(t) => - let token = Token.toString(t) - "`" ++ (token ++ "` is a reserved keyword.") - | _ => "At this point, I'm looking for an uppercased identifier like `Belt` or `Array`" - } - | Lident(currentToken) => - switch currentToken { - | Uident(uident) => - let guess = String.uncapitalize_ascii(uident) - "Did you mean `" ++ (guess ++ ("` instead of `" ++ (uident ++ "`?"))) - | t when Token.isKeyword(t) => - let token = Token.toString(t) - "`" ++ - (token ++ - ("` is a reserved keyword. Keywords need to be escaped: \\\"" ++ (token ++ "\""))) - | Underscore => "`_` isn't a valid name." - | _ => "I'm expecting an lowercased identifier like `name` or `age`" - } - | Message(txt) => txt - | UnclosedString => "This string is missing a double quote at the end" - | UnclosedTemplate => "Did you forget to close this template expression with a backtick?" - | UnclosedComment => "This comment seems to be missing a closing `*/`" - | UnknownUchar(uchar) => - switch uchar { - | 94 /* ^ */ => "Hmm, not sure what I should do here with this character.\nIf you're trying to deref an expression, use `foo.contents` instead." - | _ => "Hmm, I have no idea what this character means…" - } - | Expected({context, token: t}) => - let hint = switch context { - | Some(grammar) => "It signals the start of " ++ Grammar.toString(grammar) - | None => "" - } - - "Did you forget a `" ++ (Token.toString(t) ++ ("` here? " ++ hint)) - | Unexpected({token: t, context: breadcrumbs}) => - let name = Token.toString(t) - switch breadcrumbs { - | list{(AtomicTypExpr, _), ...breadcrumbs} => - switch (breadcrumbs, t) { - | ( - list{(StringFieldDeclarations | FieldDeclarations, _), ..._}, - String(_) | At | Rbrace | Comma | Eof, - ) => "I'm missing a type here" - | (_, t) when Grammar.isStructureItemStart(t) || t == Eof => "Missing a type here" - | _ => defaultUnexpected(t) - } - | list{(ExprOperand, _), ...breadcrumbs} => - switch (breadcrumbs, t) { - | (list{(ExprBlock, _), ..._}, Rbrace) => "It seems that this expression block is empty" - | (list{(ExprBlock, _), ..._}, Bar) => /* Pattern matching */ - "Looks like there might be an expression missing here" - | ( - list{(ExprSetField, _), ..._}, - _, - ) => "It seems that this record field mutation misses an expression" - | ( - list{(ExprArrayMutation, _), ..._}, - _, - ) => "Seems that an expression is missing, with what do I mutate the array?" - | ( - list{(ExprBinaryAfterOp(_) | ExprUnary, _), ..._}, - _, - ) => "Did you forget to write an expression here?" - | (list{(Grammar.LetBinding, _), ..._}, _) => "This let-binding misses an expression" - | (list{_, ..._}, Rbracket | Rbrace) => "Missing expression" - | _ => "I'm not sure what to parse here when looking at \"" ++ (name ++ "\".") - } - | list{(TypeParam, _), ..._} => - switch t { - | Lident(ident) => "Did you mean '" ++ (ident ++ "? A Type parameter starts with a quote.") - | _ => "I'm not sure what to parse here when looking at \"" ++ (name ++ "\".") - } - | _ => - /* TODO: match on circumstance to verify Lident needed ? */ - if Token.isKeyword(t) { - "`" ++ - (name ++ - ("` is a reserved keyword. Keywords need to be escaped: \\\"" ++ - (Token.toString(t) ++ - "\""))) - } else { - "I'm not sure what to parse here when looking at \"" ++ (name ++ "\".") - } - } - } - - let toPlainString = (t, buffer) => { - Buffer.add_string(buffer, t.filename) - Buffer.add_char(buffer, '(') - Buffer.add_string(buffer, string_of_int(t.startPos.pos_cnum)) - Buffer.add_char(buffer, ',') - Buffer.add_string(buffer, string_of_int(t.endPos.pos_cnum)) - Buffer.add_char(buffer, ')') - Buffer.add_char(buffer, ':') - Buffer.add_string(buffer, explain(t)) - } - - let toString = (t, src) => { - open Lexing - let startchar = t.startPos.pos_cnum - t.startPos.pos_bol - let endchar = t.endPos.pos_cnum - t.startPos.pos_cnum + startchar - let locationInfo = Printf.sprintf /* ReasonLanguageServer requires the following format */( - "File \"%s\", line %d, characters %d-%d:", - t.filename, - t.startPos.pos_lnum, - startchar, - endchar, - ) - - let code = { - let missing = switch t.category { - | Expected({token: t}) => Some(String.length(Token.toString(t))) - | _ => None - } - - Reporting.renderCodeContext(~missing, src, t.startPos, t.endPos) - } - - let explanation = explain(t) - Printf.sprintf("%s\n\n%s\n\n%s\n\n", locationInfo, code, explanation) - } - - let make = (~filename, ~startPos, ~endPos, category) => { - filename: filename, - startPos: startPos, - endPos: endPos, - category: category, - } - - let stringOfReport = (~style, diagnostics, src) => - switch style { - | Pretty => - List.fold_left( - (report, diagnostic) => report ++ (toString(diagnostic, src) ++ "\n"), - "\n", - List.rev(diagnostics), - ) - | Plain => - let buffer = Buffer.create(100) - List.iter(diagnostic => { - toPlainString(diagnostic, buffer) - Buffer.add_char(buffer, '\n') - }, diagnostics) - Buffer.contents(buffer) - } - - let unexpected = (token, context) => Unexpected({token: token, context: context}) - - let expected = (~grammar=?, pos, token) => Expected({context: grammar, pos: pos, token: token}) - - let uident = currentToken => Uident(currentToken) - let lident = currentToken => Lident(currentToken) - let unclosedString = UnclosedString - let unclosedComment = UnclosedComment - let unclosedTemplate = UnclosedTemplate - let unknownUchar = code => UnknownUchar(code) - let message = txt => Message(txt) -} - -/* Collection of utilities to view the ast in a more a convenient form, - * allowing for easier processing. - * Example: given a ptyp_arrow type, what are its arguments and what is the - * returnType? */ -module ParsetreeViewer: { - /* Restructures a nested tree of arrow types into its args & returnType - * The parsetree contains: a => b => c => d, for printing purposes - * we restructure the tree into (a, b, c) and its returnType d */ - let arrowType: Parsetree.core_type => ( - Parsetree.attributes, - list<(Parsetree.attributes, Asttypes.arg_label, Parsetree.core_type)>, - Parsetree.core_type, - ) - - let functorType: Parsetree.module_type => ( - list<(Parsetree.attributes, Asttypes.loc, option)>, - Parsetree.module_type, - ) - - /* filters @bs out of the provided attributes */ - let processUncurriedAttribute: Parsetree.attributes => (bool, Parsetree.attributes) - - /* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } - * The purpose of this function is to flatten nested ifs into one sequence. - * Basically compute: ([if, else if, else if, else if], else) */ - let collectIfExpressions: Parsetree.expression => ( - list<(Parsetree.expression, Parsetree.expression)>, - option, - ) - - let collectListExpressions: Parsetree.expression => ( - list, - option, - ) - - type funParamKind = - | Parameter({ - attrs: Parsetree.attributes, - lbl: Asttypes.arg_label, - defaultExpr: option, - pat: Parsetree.pattern, - }) - | NewTypes({attrs: Parsetree.attributes, locs: list>}) - - let funExpr: Parsetree.expression => ( - Parsetree.attributes, - list, - Parsetree.expression, - ) - - /* example: - * `makeCoordinate({ - * x: 1, - * y: 2, - * })` - * Notice howe `({` and `})` "hug" or stick to each other */ - let isHuggableExpression: Parsetree.expression => bool - - let isHuggablePattern: Parsetree.pattern => bool - - let isHuggableRhs: Parsetree.expression => bool - - let operatorPrecedence: string => int - - let isUnaryExpression: Parsetree.expression => bool - let isBinaryOperator: string => bool - let isBinaryExpression: Parsetree.expression => bool - - let flattenableOperators: (string, string) => bool - - let hasAttributes: Parsetree.attributes => bool - - let isArrayAccess: Parsetree.expression => bool - let isTernaryExpr: Parsetree.expression => bool - - let collectTernaryParts: Parsetree.expression => ( - list<(Parsetree.expression, Parsetree.expression)>, - Parsetree.expression, - ) - - let parametersShouldHug: list => bool - - let filterTernaryAttributes: Parsetree.attributes => Parsetree.attributes - - let isJsxExpression: Parsetree.expression => bool - let hasJsxAttribute: Parsetree.attributes => bool - - let shouldIndentBinaryExpr: Parsetree.expression => bool - let shouldInlineRhsBinaryExpr: Parsetree.expression => bool - let filterPrinteableAttributes: Parsetree.attributes => Parsetree.attributes - let partitionPrinteableAttributes: Parsetree.attributes => ( - Parsetree.attributes, - Parsetree.attributes, - ) - - let requiresSpecialCallbackPrintingLastArg: list<( - Asttypes.arg_label, - Parsetree.expression, - )> => bool - let requiresSpecialCallbackPrintingFirstArg: list<( - Asttypes.arg_label, - Parsetree.expression, - )> => bool - - let modExprApply: Parsetree.module_expr => (list, Parsetree.module_expr) - - let modExprFunctor: Parsetree.module_expr => ( - list<(Parsetree.attributes, Asttypes.loc, option)>, - Parsetree.module_expr, - ) - - let splitGenTypeAttr: Parsetree.attributes => (bool, Parsetree.attributes) - - let collectPatternsFromListConstruct: ( - list, - Parsetree.pattern, - ) => (list, Parsetree.pattern) - - let isBlockExpr: Parsetree.expression => bool - - let isTemplateLiteral: Parsetree.expression => bool - - let collectOrPatternChain: Parsetree.pattern => list - - let processBracesAttr: Parsetree.expression => (option, Parsetree.expression) - - let filterParsingAttrs: Parsetree.attributes => Parsetree.attributes - - let isBracedExpr: Parsetree.expression => bool - - let isPipeExpr: Parsetree.expression => bool - - let extractValueDescriptionFromModExpr: Parsetree.module_expr => list - - type jsImportScope = - | JsGlobalImport /* nothing */ - | JsModuleImport(string) /* from "path" */ - | JsScopedImport(list) /* window.location */ - - let classifyJsImport: Parsetree.value_description => jsImportScope - - /* (__x) => f(a, __x, c) -----> f(a, _, c) */ - let rewriteUnderscoreApply: Parsetree.expression => Parsetree.expression - - /* (__x) => f(a, __x, c) -----> f(a, _, c) */ - let isUnderscoreApplySugar: Parsetree.expression => bool -} = { - open Parsetree - - let arrowType = ct => { - let rec process = (attrsBefore, acc, typ) => - switch typ { - | {ptyp_desc: Ptyp_arrow(Nolabel as lbl, typ1, typ2), ptyp_attributes: list{}} => - let arg = (list{}, lbl, typ1) - process(attrsBefore, list{arg, ...acc}, typ2) - | { - ptyp_desc: Ptyp_arrow(Nolabel as lbl, typ1, typ2), - ptyp_attributes: list{({txt: "bs"}, _)} as attrs, - } => - let arg = (attrs, lbl, typ1) - process(attrsBefore, list{arg, ...acc}, typ2) - | {ptyp_desc: Ptyp_arrow(Nolabel, _typ1, _typ2), ptyp_attributes: _attrs} as returnType => - let args = List.rev(acc) - (attrsBefore, args, returnType) - | { - ptyp_desc: Ptyp_arrow((Labelled(_) | Optional(_)) as lbl, typ1, typ2), - ptyp_attributes: attrs, - } => - let arg = (attrs, lbl, typ1) - process(attrsBefore, list{arg, ...acc}, typ2) - | typ => (attrsBefore, List.rev(acc), typ) - } - - switch ct { - | {ptyp_desc: Ptyp_arrow(Nolabel, _typ1, _typ2), ptyp_attributes: attrs} as typ => - process(attrs, list{}, {...typ, ptyp_attributes: list{}}) - | typ => process(list{}, list{}, typ) - } - } - - let functorType = modtype => { - let rec process = (acc, modtype) => - switch modtype { - | {pmty_desc: Pmty_functor(lbl, argType, returnType), pmty_attributes: attrs} => - let arg = (attrs, lbl, argType) - process(list{arg, ...acc}, returnType) - | modType => (List.rev(acc), modType) - } - - process(list{}, modtype) - } - - let processUncurriedAttribute = attrs => { - let rec process = (uncurriedSpotted, acc, attrs) => - switch attrs { - | list{} => (uncurriedSpotted, List.rev(acc)) - | list{({Location.txt: "bs"}, _), ...rest} => process(true, acc, rest) - | list{attr, ...rest} => process(uncurriedSpotted, list{attr, ...acc}, rest) - } - - process(false, list{}, attrs) - } - - let collectIfExpressions = expr => { - let rec collect = (acc, expr) => - switch expr.pexp_desc { - | Pexp_ifthenelse(ifExpr, thenExpr, Some(elseExpr)) => - collect(list{(ifExpr, thenExpr), ...acc}, elseExpr) - | Pexp_ifthenelse(ifExpr, thenExpr, None as elseExpr) => - let ifs = List.rev(list{(ifExpr, thenExpr), ...acc}) - (ifs, elseExpr) - | _ => (List.rev(acc), Some(expr)) - } - - collect(list{}, expr) - } - - let collectListExpressions = expr => { - let rec collect = (acc, expr) => - switch expr.pexp_desc { - | Pexp_construct({txt: Longident.Lident("[]")}, _) => (List.rev(acc), None) - | Pexp_construct( - {txt: Longident.Lident("::")}, - Some({pexp_desc: Pexp_tuple(list{hd, tail})}), - ) => - collect(list{hd, ...acc}, tail) - | _ => (List.rev(acc), Some(expr)) - } - - collect(list{}, expr) - } - - /* (__x) => f(a, __x, c) -----> f(a, _, c) */ - let rewriteUnderscoreApply = expr => - switch expr.pexp_desc { - | Pexp_fun( - Nolabel, - None, - {ppat_desc: Ppat_var({txt: "__x"})}, - {pexp_desc: Pexp_apply(callExpr, args)} as e, - ) => - let newArgs = List.map(arg => - switch arg { - | (lbl, {pexp_desc: Pexp_ident({txt: Longident.Lident("__x")} as lid)} as argExpr) => ( - lbl, - {...argExpr, pexp_desc: Pexp_ident({...lid, txt: Longident.Lident("_")})}, - ) - | arg => arg - } - , args) - {...e, pexp_desc: Pexp_apply(callExpr, newArgs)} - | _ => expr - } - - type funParamKind = - | Parameter({ - attrs: Parsetree.attributes, - lbl: Asttypes.arg_label, - defaultExpr: option, - pat: Parsetree.pattern, - }) - | NewTypes({attrs: Parsetree.attributes, locs: list>}) - - let funExpr = expr => { - /* Turns (type t, type u, type z) into "type t u z" */ - let rec collectNewTypes = (acc, returnExpr) => - switch returnExpr { - | {pexp_desc: Pexp_newtype(stringLoc, returnExpr), pexp_attributes: list{}} => - collectNewTypes(list{stringLoc, ...acc}, returnExpr) - | returnExpr => (List.rev(acc), returnExpr) - } - - let rec collect = (attrsBefore, acc, expr) => - switch expr { - | { - pexp_desc: - Pexp_fun( - Nolabel, - None, - {ppat_desc: Ppat_var({txt: "__x"})}, - {pexp_desc: Pexp_apply(_)}, - ), - } => (attrsBefore, List.rev(acc), rewriteUnderscoreApply(expr)) - | {pexp_desc: Pexp_fun(lbl, defaultExpr, pattern, returnExpr), pexp_attributes: list{}} => - let parameter = Parameter({ - attrs: list{}, - lbl: lbl, - defaultExpr: defaultExpr, - pat: pattern, - }) - collect(attrsBefore, list{parameter, ...acc}, returnExpr) - | {pexp_desc: Pexp_newtype(stringLoc, rest), pexp_attributes: attrs} => - let (stringLocs, returnExpr) = collectNewTypes(list{stringLoc}, rest) - let param = NewTypes({attrs: attrs, locs: stringLocs}) - collect(attrsBefore, list{param, ...acc}, returnExpr) - | { - pexp_desc: Pexp_fun(lbl, defaultExpr, pattern, returnExpr), - pexp_attributes: list{({txt: "bs"}, _)} as attrs, - } => - let parameter = Parameter({ - attrs: attrs, - lbl: lbl, - defaultExpr: defaultExpr, - pat: pattern, - }) - collect(attrsBefore, list{parameter, ...acc}, returnExpr) - | { - pexp_desc: Pexp_fun((Labelled(_) | Optional(_)) as lbl, defaultExpr, pattern, returnExpr), - pexp_attributes: attrs, - } => - let parameter = Parameter({ - attrs: attrs, - lbl: lbl, - defaultExpr: defaultExpr, - pat: pattern, - }) - collect(attrsBefore, list{parameter, ...acc}, returnExpr) - | expr => (attrsBefore, List.rev(acc), expr) - } - - switch expr { - | { - pexp_desc: Pexp_fun(Nolabel, _defaultExpr, _pattern, _returnExpr), - pexp_attributes: attrs, - } as expr => - collect(attrs, list{}, {...expr, pexp_attributes: list{}}) - | expr => collect(list{}, list{}, expr) - } - } - - let processBracesAttr = expr => - switch expr.pexp_attributes { - | list{({txt: "res.braces"}, _) as attr, ...attrs} => ( - Some(attr), - {...expr, pexp_attributes: attrs}, - ) - | _ => (None, expr) - } - - let filterParsingAttrs = attrs => List.filter(attr => - switch attr { - | ({Location.txt: "res.ternary" | "res.braces" | "bs" | "res.namedArgLoc"}, _) => false - | _ => true - } - , attrs) - - let isBlockExpr = expr => - switch expr.pexp_desc { - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_let(_) - | Pexp_open(_) - | Pexp_sequence(_) => true - | _ => false - } - - let isBracedExpr = expr => - switch processBracesAttr(expr) { - | (Some(_), _) => true - | _ => false - } - - let isHuggableExpression = expr => - switch expr.pexp_desc { - | Pexp_array(_) - | Pexp_tuple(_) - | Pexp_construct({txt: Longident.Lident("::" | "[]")}, _) - | Pexp_extension({txt: "bs.obj"}, _) - | Pexp_record(_) => true - | _ when isBlockExpr(expr) => true - | _ when isBracedExpr(expr) => true - | _ => false - } - - let isHuggableRhs = expr => - switch expr.pexp_desc { - | Pexp_array(_) - | Pexp_tuple(_) - | Pexp_construct({txt: Longident.Lident("::" | "[]")}, _) - | Pexp_extension({txt: "bs.obj"}, _) - | Pexp_record(_) => true - | _ when isBracedExpr(expr) => true - | _ => false - } - - let isHuggablePattern = pattern => - switch pattern.ppat_desc { - | Ppat_array(_) | Ppat_tuple(_) | Ppat_record(_) | Ppat_construct(_) => true - | _ => false - } - - let operatorPrecedence = operator => - switch operator { - | ":=" => 1 - | "||" => 2 - | "&&" => 3 - | "=" | "==" | "<" | ">" | "!=" | "<>" | "!==" | "<=" | ">=" | "|>" => 4 - | "+" | "+." | "-" | "-." | "^" => 5 - | "*" | "*." | "/" | "/." => 6 - | "**" => 7 - | "#" | "##" | "|." => 8 - | _ => 0 - } - - let isUnaryOperator = operator => - switch operator { - | "~+" | "~+." | "~-" | "~-." | "not" => true - | _ => false - } - - let isUnaryExpression = expr => - switch expr.pexp_desc { - | Pexp_apply({pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, list{(Nolabel, _arg)}) - when isUnaryOperator(operator) => true - | _ => false - } - - let isBinaryOperator = operator => - switch operator { - | ":=" - | "||" - | "&&" - | "=" - | "==" - | "<" - | ">" - | "!=" - | "!==" - | "<=" - | ">=" - | "|>" - | "+" - | "+." - | "-" - | "-." - | "^" - | "*" - | "*." - | "/" - | "/." - | "**" - | "|." - | "<>" => true - | _ => false - } - - let isBinaryExpression = expr => - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list{(Nolabel, _operand1), (Nolabel, _operand2)}, - ) when isBinaryOperator(operator) => true - | _ => false - } - - let isEqualityOperator = operator => - switch operator { - | "=" | "==" | "<>" | "!=" => true - | _ => false - } - - let flattenableOperators = (parentOperator, childOperator) => { - let precParent = operatorPrecedence(parentOperator) - let precChild = operatorPrecedence(childOperator) - if precParent === precChild { - !(isEqualityOperator(parentOperator) && isEqualityOperator(childOperator)) - } else { - false - } - } - - let hasAttributes = attrs => List.exists(attr => - switch attr { - | ({Location.txt: "bs" | "res.ternary" | "res.braces"}, _) => false - | _ => true - } - , attrs) - - let isArrayAccess = expr => - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Ldot(Lident("Array"), "get")})}, - list{(Nolabel, _parentExpr), (Nolabel, _memberExpr)}, - ) => true - | _ => false - } - - let rec hasTernaryAttribute = attrs => - switch attrs { - | list{} => false - | list{({Location.txt: "res.ternary"}, _), ..._} => true - | list{_, ...attrs} => hasTernaryAttribute(attrs) - } - - let isTernaryExpr = expr => - switch expr { - | {pexp_attributes: attrs, pexp_desc: Pexp_ifthenelse(_)} - when hasTernaryAttribute(attrs) => true - | _ => false - } - - let collectTernaryParts = expr => { - let rec collect = (acc, expr) => - switch expr { - | {pexp_attributes: attrs, pexp_desc: Pexp_ifthenelse(condition, consequent, Some(alternate))} - when hasTernaryAttribute(attrs) => - collect(list{(condition, consequent), ...acc}, alternate) - | alternate => (List.rev(acc), alternate) - } - - collect(list{}, expr) - } - - let parametersShouldHug = parameters => - switch parameters { - | list{Parameter({attrs: list{}, lbl: Asttypes.Nolabel, defaultExpr: None, pat})} - when isHuggablePattern(pat) => true - | _ => false - } - - let filterTernaryAttributes = attrs => List.filter(attr => - switch attr { - | ({Location.txt: "res.ternary"}, _) => false - | _ => true - } - , attrs) - - let isJsxExpression = expr => { - let rec loop = attrs => - switch attrs { - | list{} => false - | list{({Location.txt: "JSX"}, _), ..._} => true - | list{_, ...attrs} => loop(attrs) - } - - switch expr.pexp_desc { - | Pexp_apply(_) => loop(expr.Parsetree.pexp_attributes) - | _ => false - } - } - - let hasJsxAttribute = attributes => - switch attributes { - | list{({Location.txt: "JSX"}, _), ..._} => true - | _ => false - } - - let shouldIndentBinaryExpr = expr => { - let samePrecedenceSubExpression = (operator, subExpression) => - switch subExpression { - | { - pexp_desc: - Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(subOperator)})}, - list{(Nolabel, _lhs), (Nolabel, _rhs)}, - ), - } when isBinaryOperator(subOperator) => - flattenableOperators(operator, subOperator) - | _ => true - } - - switch expr { - | { - pexp_desc: - Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list{(Nolabel, lhs), (Nolabel, _rhs)}, - ), - } when isBinaryOperator(operator) => - isEqualityOperator(operator) || - (!samePrecedenceSubExpression(operator, lhs) || - operator == ":=") - | _ => false - } - } - - let shouldInlineRhsBinaryExpr = rhs => - switch rhs.pexp_desc { - | Parsetree.Pexp_constant(_) - | Pexp_let(_) - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_sequence(_) - | Pexp_open(_) - | Pexp_ifthenelse(_) - | Pexp_for(_) - | Pexp_while(_) - | Pexp_try(_) - | Pexp_array(_) - | Pexp_record(_) => true - | _ => false - } - - let filterPrinteableAttributes = attrs => List.filter(attr => - switch attr { - | ({Location.txt: "bs" | "res.ternary"}, _) => false - | _ => true - } - , attrs) - - let partitionPrinteableAttributes = attrs => List.partition(attr => - switch attr { - | ({Location.txt: "bs" | "res.ternary"}, _) => false - | _ => true - } - , attrs) - - let requiresSpecialCallbackPrintingLastArg = args => { - let rec loop = args => - switch args { - | list{} => false - | list{(_, {pexp_desc: Pexp_fun(_) | Pexp_newtype(_)})} => true - | list{(_, {pexp_desc: Pexp_fun(_) | Pexp_newtype(_)}), ..._} => false - | list{_, ...rest} => loop(rest) - } - - loop(args) - } - - let requiresSpecialCallbackPrintingFirstArg = args => { - let rec loop = args => - switch args { - | list{} => true - | list{(_, {pexp_desc: Pexp_fun(_) | Pexp_newtype(_)}), ..._} => false - | list{_, ...rest} => loop(rest) - } - - switch args { - | list{(_, {pexp_desc: Pexp_fun(_) | Pexp_newtype(_)})} => false - | list{(_, {pexp_desc: Pexp_fun(_) | Pexp_newtype(_)}), ...rest} => loop(rest) - | _ => false - } - } - - let modExprApply = modExpr => { - let rec loop = (acc, modExpr) => - switch modExpr { - | {pmod_desc: Pmod_apply(next, arg)} => loop(list{arg, ...acc}, next) - | _ => (acc, modExpr) - } - - loop(list{}, modExpr) - } - - let modExprFunctor = modExpr => { - let rec loop = (acc, modExpr) => - switch modExpr { - | {pmod_desc: Pmod_functor(lbl, modType, returnModExpr), pmod_attributes: attrs} => - let param = (attrs, lbl, modType) - loop(list{param, ...acc}, returnModExpr) - | returnModExpr => (List.rev(acc), returnModExpr) - } - - loop(list{}, modExpr) - } - - let splitGenTypeAttr = attrs => - switch attrs { - | list{({Location.txt: "genType"}, _), ...attrs} => (true, attrs) - | attrs => (false, attrs) - } - - let rec collectPatternsFromListConstruct = (acc, pattern) => { - open Parsetree - switch pattern.ppat_desc { - | Ppat_construct( - {txt: Longident.Lident("::")}, - Some({ppat_desc: Ppat_tuple(list{pat, rest})}), - ) => - collectPatternsFromListConstruct(list{pat, ...acc}, rest) - | _ => (List.rev(acc), pattern) - } - } - - let rec isTemplateLiteral = expr => { - let isPexpConstantString = expr => - switch expr.pexp_desc { - | Pexp_constant(Pconst_string(_, Some(_))) => true - | _ => false - } - - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("^")})}, - list{(Nolabel, arg1), (Nolabel, arg2)}, - ) when !(isPexpConstantString(arg1) && isPexpConstantString(arg2)) => - isTemplateLiteral(arg1) || isTemplateLiteral(arg2) - | Pexp_constant(Pconst_string(_, Some(_))) => true - | _ => false - } - } - - /* Blue | Red | Green -> [Blue; Red; Green] */ - let collectOrPatternChain = pat => { - let rec loop = (pattern, chain) => - switch pattern.ppat_desc { - | Ppat_or(left, right) => loop(left, list{right, ...chain}) - | _ => list{pattern, ...chain} - } - - loop(pat, list{}) - } - - let isPipeExpr = expr => - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("|." | "|>")})}, - list{(Nolabel, _operand1), (Nolabel, _operand2)}, - ) => true - | _ => false - } - - let extractValueDescriptionFromModExpr = modExpr => { - let rec loop = (structure, acc) => - switch structure { - | list{} => List.rev(acc) - | list{structureItem, ...structure} => - switch structureItem.Parsetree.pstr_desc { - | Pstr_primitive(vd) => loop(structure, list{vd, ...acc}) - | _ => loop(structure, acc) - } - } - - switch modExpr.pmod_desc { - | Pmod_structure(structure) => loop(structure, list{}) - | _ => list{} - } - } - - type jsImportScope = - | JsGlobalImport /* nothing */ - | JsModuleImport(string) /* from "path" */ - | JsScopedImport(list) /* window.location */ - - let classifyJsImport = valueDescription => { - let rec loop = attrs => { - open Parsetree - switch attrs { - | list{} => JsGlobalImport - | list{ - ( - {Location.txt: "bs.scope"}, - PStr(list{{pstr_desc: Pstr_eval({pexp_desc: Pexp_constant(Pconst_string(s, _))}, _)}}), - ), - ..._, - } => - JsScopedImport(list{s}) - | list{ - ( - {Location.txt: "genType.import"}, - PStr(list{{pstr_desc: Pstr_eval({pexp_desc: Pexp_constant(Pconst_string(s, _))}, _)}}), - ), - ..._, - } => - JsModuleImport(s) - | list{ - ( - {Location.txt: "bs.scope"}, - PStr(list{{pstr_desc: Pstr_eval({pexp_desc: Pexp_tuple(exprs)}, _)}}), - ), - ..._, - } => - let scopes = List.fold_left((acc, curr) => - switch curr.Parsetree.pexp_desc { - | Pexp_constant(Pconst_string(s, _)) => list{s, ...acc} - | _ => acc - } - , list{}, exprs) - - JsScopedImport(List.rev(scopes)) - | list{_, ...attrs} => loop(attrs) - } - } - - loop(valueDescription.pval_attributes) - } - - let isUnderscoreApplySugar = expr => - switch expr.pexp_desc { - | Pexp_fun( - Nolabel, - None, - {ppat_desc: Ppat_var({txt: "__x"})}, - {pexp_desc: Pexp_apply(_)}, - ) => true - | _ => false - } -} - -module Parens: { - type kind = Parenthesized | Braced(Location.t) | Nothing - - let expr: Parsetree.expression => kind - let structureExpr: Parsetree.expression => kind - - let unaryExprOperand: Parsetree.expression => kind - - let binaryExprOperand: (~isLhs: bool, Parsetree.expression) => kind - let subBinaryExprOperand: (string, string) => bool - let rhsBinaryExprOperand: (string, Parsetree.expression) => bool - let flattenOperandRhs: (string, Parsetree.expression) => bool - - let lazyOrAssertExprRhs: Parsetree.expression => kind - - let fieldExpr: Parsetree.expression => kind - - let setFieldExprRhs: Parsetree.expression => kind - - let ternaryOperand: Parsetree.expression => kind - - let jsxPropExpr: Parsetree.expression => kind - let jsxChildExpr: Parsetree.expression => kind - - let binaryExpr: Parsetree.expression => kind - let modTypeFunctorReturn: Parsetree.module_type => bool - let modTypeWithOperand: Parsetree.module_type => bool - let modExprFunctorConstraint: Parsetree.module_type => bool - - let bracedExpr: Parsetree.expression => bool - let callExpr: Parsetree.expression => kind - - let includeModExpr: Parsetree.module_expr => bool -} = { - type kind = Parenthesized | Braced(Location.t) | Nothing - - let expr = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | _ => - switch expr { - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - } => - Nothing - | {pexp_desc: Pexp_constraint(_)} => Parenthesized - | _ => Nothing - } - } - } - - let callExpr = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | _ => - switch expr { - | {Parsetree.pexp_attributes: attrs} - when switch ParsetreeViewer.filterParsingAttrs(attrs) { - | list{_, ..._} => true - | list{} => false - } => - Parenthesized - | _ - when ParsetreeViewer.isUnaryExpression(expr) || ParsetreeViewer.isBinaryExpression(expr) => - Parenthesized - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - } => - Nothing - | {pexp_desc: Pexp_fun(_)} when ParsetreeViewer.isUnderscoreApplySugar(expr) => Nothing - | { - pexp_desc: - Pexp_lazy(_) - | Pexp_assert(_) - | Pexp_fun(_) - | Pexp_newtype(_) - | Pexp_function(_) - | Pexp_constraint(_) - | Pexp_setfield(_) - | Pexp_match(_) - | Pexp_try(_) - | Pexp_while(_) - | Pexp_for(_) - | Pexp_ifthenelse(_), - } => - Parenthesized - | _ => Nothing - } - } - } - - let structureExpr = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | _ - when ParsetreeViewer.hasAttributes(expr.pexp_attributes) && - !ParsetreeViewer.isJsxExpression(expr) => - Parenthesized - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - } => - Nothing - | {pexp_desc: Pexp_constraint(_)} => Parenthesized - | _ => Nothing - } - } - } - - let unaryExprOperand = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | {Parsetree.pexp_attributes: attrs} - when switch ParsetreeViewer.filterParsingAttrs(attrs) { - | list{_, ..._} => true - | list{} => false - } => - Parenthesized - | expr - when ParsetreeViewer.isUnaryExpression(expr) || ParsetreeViewer.isBinaryExpression(expr) => - Parenthesized - | {pexp_desc: Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)})} => - Nothing - | {pexp_desc: Pexp_fun(_)} when ParsetreeViewer.isUnderscoreApplySugar(expr) => Nothing - | { - pexp_desc: - Pexp_lazy(_) - | Pexp_assert(_) - | Pexp_fun(_) - | Pexp_newtype(_) - | Pexp_function(_) - | Pexp_constraint(_) - | Pexp_setfield(_) - | Pexp_extension(_) - | Pexp_match(_) - | Pexp_try(_) - | Pexp_while(_) - | Pexp_for(_) - | Pexp_ifthenelse(_), - } => - Parenthesized - | _ => Nothing - } - } - } - - let binaryExprOperand = (~isLhs, expr) => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - } => - Nothing - | {pexp_desc: Pexp_fun(_)} when ParsetreeViewer.isUnderscoreApplySugar(expr) => Nothing - | {pexp_desc: Pexp_constraint(_) | Pexp_fun(_) | Pexp_function(_) | Pexp_newtype(_)} => - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression(expr) => Parenthesized - | expr when ParsetreeViewer.isTernaryExpr(expr) => Parenthesized - | {pexp_desc: Pexp_lazy(_) | Pexp_assert(_)} when isLhs => Parenthesized - | _ => Nothing - } - } - } - - let subBinaryExprOperand = (parentOperator, childOperator) => { - let precParent = ParsetreeViewer.operatorPrecedence(parentOperator) - let precChild = ParsetreeViewer.operatorPrecedence(childOperator) - precParent > precChild || - ((precParent === precChild && - !ParsetreeViewer.flattenableOperators(parentOperator, childOperator)) || - /* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… */ - parentOperator == "||" && childOperator == "&&") - } - - let rhsBinaryExprOperand = (parentOperator, rhs) => - switch rhs.Parsetree.pexp_desc { - | Parsetree.Pexp_apply( - {pexp_attributes: list{}, pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list{(_, _left), (_, _right)}, - ) when ParsetreeViewer.isBinaryOperator(operator) => - let precParent = ParsetreeViewer.operatorPrecedence(parentOperator) - let precChild = ParsetreeViewer.operatorPrecedence(operator) - precParent === precChild - | _ => false - } - - let flattenOperandRhs = (parentOperator, rhs) => - switch rhs.Parsetree.pexp_desc { - | Parsetree.Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list{(_, _left), (_, _right)}, - ) when ParsetreeViewer.isBinaryOperator(operator) => - let precParent = ParsetreeViewer.operatorPrecedence(parentOperator) - let precChild = ParsetreeViewer.operatorPrecedence(operator) - precParent >= precChild || rhs.pexp_attributes != list{} - | Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}) => false - | Pexp_fun(_) when ParsetreeViewer.isUnderscoreApplySugar(rhs) => false - | Pexp_fun(_) | Pexp_newtype(_) | Pexp_setfield(_) | Pexp_constraint(_) => true - | _ when ParsetreeViewer.isTernaryExpr(rhs) => true - | _ => false - } - - let lazyOrAssertExprRhs = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | {Parsetree.pexp_attributes: attrs} - when switch ParsetreeViewer.filterParsingAttrs(attrs) { - | list{_, ..._} => true - | list{} => false - } => - Parenthesized - | expr when ParsetreeViewer.isBinaryExpression(expr) => Parenthesized - | {pexp_desc: Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)})} => - Nothing - | {pexp_desc: Pexp_fun(_)} when ParsetreeViewer.isUnderscoreApplySugar(expr) => Nothing - | { - pexp_desc: - Pexp_lazy(_) - | Pexp_assert(_) - | Pexp_fun(_) - | Pexp_newtype(_) - | Pexp_function(_) - | Pexp_constraint(_) - | Pexp_setfield(_) - | Pexp_match(_) - | Pexp_try(_) - | Pexp_while(_) - | Pexp_for(_) - | Pexp_ifthenelse(_), - } => - Parenthesized - | _ => Nothing - } - } - } - - let isNegativeConstant = constant => { - let isNeg = txt => { - let len = String.length(txt) - len > 0 && (@doesNotRaise String.get)(txt, 0) == '-' - } - - switch constant { - | Parsetree.Pconst_integer(i, _) | Pconst_float(i, _) when isNeg(i) => true - | _ => false - } - } - - let fieldExpr = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | {Parsetree.pexp_attributes: attrs} - when switch ParsetreeViewer.filterParsingAttrs(attrs) { - | list{_, ..._} => true - | list{} => false - } => - Parenthesized - | expr - when ParsetreeViewer.isBinaryExpression(expr) || ParsetreeViewer.isUnaryExpression(expr) => - Parenthesized - | {pexp_desc: Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)})} => - Nothing - | {pexp_desc: Pexp_constant(c)} when isNegativeConstant(c) => Parenthesized - | {pexp_desc: Pexp_fun(_)} when ParsetreeViewer.isUnderscoreApplySugar(expr) => Nothing - | { - pexp_desc: - Pexp_lazy(_) - | Pexp_assert(_) - | Pexp_extension(_) - | Pexp_fun(_) - | Pexp_newtype(_) - | Pexp_function(_) - | Pexp_constraint(_) - | Pexp_setfield(_) - | Pexp_match(_) - | Pexp_try(_) - | Pexp_while(_) - | Pexp_for(_) - | Pexp_ifthenelse(_), - } => - Parenthesized - | _ => Nothing - } - } - } - - let setFieldExprRhs = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - } => - Nothing - | {pexp_desc: Pexp_constraint(_)} => Parenthesized - | _ => Nothing - } - } - } - - let ternaryOperand = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - } => - Nothing - | {pexp_desc: Pexp_constraint(_)} => Parenthesized - | {pexp_desc: Pexp_fun(_) | Pexp_newtype(_)} => - let (_attrsOnArrow, _parameters, returnExpr) = ParsetreeViewer.funExpr(expr) - switch returnExpr.pexp_desc { - | Pexp_constraint(_) => Parenthesized - | _ => Nothing - } - | _ => Nothing - } - } - } - - let startsWithMinus = txt => { - let len = String.length(txt) - if len === 0 { - false - } else { - let s = (@doesNotRaise String.get)(txt, 0) - s == '-' - } - } - - let jsxPropExpr = expr => - switch expr.Parsetree.pexp_desc { - | Parsetree.Pexp_let(_) - | Pexp_sequence(_) - | Pexp_letexception(_) - | Pexp_letmodule(_) - | Pexp_open(_) => - Nothing - | _ => - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | { - Parsetree.pexp_desc: Pexp_constant(Pconst_integer(x, _) | Pconst_float(x, _)), - pexp_attributes: list{}, - } when startsWithMinus(x) => - Parenthesized - | { - Parsetree.pexp_desc: - Pexp_ident(_) - | Pexp_constant(_) - | Pexp_field(_) - | Pexp_construct(_) - | Pexp_variant(_) - | Pexp_array(_) - | Pexp_pack(_) - | Pexp_record(_) - | Pexp_extension(_) - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_open(_) - | Pexp_sequence(_) - | Pexp_let(_) - | Pexp_tuple(_), - pexp_attributes: list{}, - } => - Nothing - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - pexp_attributes: list{}, - } => - Nothing - | _ => Parenthesized - } - } - } - - let jsxChildExpr = expr => - switch expr.Parsetree.pexp_desc { - | Parsetree.Pexp_let(_) - | Pexp_sequence(_) - | Pexp_letexception(_) - | Pexp_letmodule(_) - | Pexp_open(_) => - Nothing - | _ => - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | _ => - switch expr { - | { - Parsetree.pexp_desc: Pexp_constant(Pconst_integer(x, _) | Pconst_float(x, _)), - pexp_attributes: list{}, - } when startsWithMinus(x) => - Parenthesized - | { - Parsetree.pexp_desc: - Pexp_ident(_) - | Pexp_constant(_) - | Pexp_field(_) - | Pexp_construct(_) - | Pexp_variant(_) - | Pexp_array(_) - | Pexp_pack(_) - | Pexp_record(_) - | Pexp_extension(_) - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_open(_) - | Pexp_sequence(_) - | Pexp_let(_), - pexp_attributes: list{}, - } => - Nothing - | { - Parsetree.pexp_desc: - Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}), - pexp_attributes: list{}, - } => - Nothing - | expr when ParsetreeViewer.isJsxExpression(expr) => Nothing - | _ => Parenthesized - } - } - } - - let binaryExpr = expr => { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(expr) - switch optBraces { - | Some({Location.loc: bracesLoc}, _) => Braced(bracesLoc) - | None => - switch expr { - | {Parsetree.pexp_attributes: list{_, ..._}} as expr - when ParsetreeViewer.isBinaryExpression(expr) => - Parenthesized - | _ => Nothing - } - } - } - - let modTypeFunctorReturn = modType => - switch modType { - | {Parsetree.pmty_desc: Pmty_with(_)} => true - | _ => false - } - - /* Add parens for readability: - module type Functor = SetLike => Set with type t = A.t - This is actually: - module type Functor = (SetLike => Set) with type t = A.t - */ - let modTypeWithOperand = modType => - switch modType { - | {Parsetree.pmty_desc: Pmty_functor(_)} => true - | _ => false - } - - let modExprFunctorConstraint = modType => - switch modType { - | {Parsetree.pmty_desc: Pmty_functor(_) | Pmty_with(_)} => true - | _ => false - } - - let bracedExpr = expr => - switch expr.Parsetree.pexp_desc { - | Pexp_constraint({pexp_desc: Pexp_pack(_)}, {ptyp_desc: Ptyp_package(_)}) => false - | Pexp_constraint(_) => true - | _ => false - } - - let includeModExpr = modExpr => - switch modExpr.Parsetree.pmod_desc { - | Parsetree.Pmod_constraint(_) => true - | _ => false - } -} - -module CommentTable = { - type t = { - leading: Hashtbl.t>, - inside: Hashtbl.t>, - trailing: Hashtbl.t>, - } - - let make = () => { - leading: Hashtbl.create(100), - inside: Hashtbl.create(100), - trailing: Hashtbl.create(100), - } - - let empty = make() - - @live - let log = t => { - open Location - let leadingStuff = Hashtbl.fold((k: Location.t, v: list, acc) => { - let loc = Doc.concat(list{ - Doc.lbracket, - Doc.text(string_of_int(k.loc_start.pos_lnum)), - Doc.text(":"), - Doc.text(string_of_int(k.loc_start.pos_cnum - k.loc_start.pos_bol)), - Doc.text("-"), - Doc.text(string_of_int(k.loc_end.pos_lnum)), - Doc.text(":"), - Doc.text(string_of_int(k.loc_end.pos_cnum - k.loc_end.pos_bol)), - Doc.rbracket, - }) - let doc = Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - loc, - Doc.indent( - Doc.concat(list{ - Doc.line, - Doc.join(~sep=Doc.comma, List.map(c => Doc.text(Comment.txt(c)), v)), - }), - ), - Doc.line, - }), - ) - list{doc, ...acc} - }, t.leading, list{}) - - let trailingStuff = Hashtbl.fold((k: Location.t, v: list, acc) => { - let loc = Doc.concat(list{ - Doc.lbracket, - Doc.text(string_of_int(k.loc_start.pos_lnum)), - Doc.text(":"), - Doc.text(string_of_int(k.loc_start.pos_cnum - k.loc_start.pos_bol)), - Doc.text("-"), - Doc.text(string_of_int(k.loc_end.pos_lnum)), - Doc.text(":"), - Doc.text(string_of_int(k.loc_end.pos_cnum - k.loc_end.pos_bol)), - Doc.rbracket, - }) - let doc = Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - loc, - Doc.indent( - Doc.concat(list{ - Doc.line, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(c => Doc.text(Comment.txt(c)), v), - ), - }), - ), - Doc.line, - }), - ) - list{doc, ...acc} - }, t.trailing, list{}) - - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.text("leading comments:"), - Doc.line, - Doc.indent(Doc.concat(leadingStuff)), - Doc.line, - Doc.line, - Doc.text("trailing comments:"), - Doc.indent(Doc.concat(trailingStuff)), - Doc.line, - Doc.line, - }), - ) - |> Doc.toString(~width=80) - |> print_endline - } - let attach = (tbl, loc, comments) => - switch comments { - | list{} => () - | comments => Hashtbl.replace(tbl, loc, comments) - } - - let partitionByLoc = (comments, loc) => { - let rec loop = ((leading, inside, trailing), comments) => { - open Location - switch comments { - | list{comment, ...rest} => - let cmtLoc = Comment.loc(comment) - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum { - loop((list{comment, ...leading}, inside, trailing), rest) - } else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum { - loop((leading, inside, list{comment, ...trailing}), rest) - } else { - loop((leading, list{comment, ...inside}, trailing), rest) - } - | list{} => (List.rev(leading), List.rev(inside), List.rev(trailing)) - } - } - - loop((list{}, list{}, list{}), comments) - } - - let partitionLeadingTrailing = (comments, loc) => { - let rec loop = ((leading, trailing), comments) => { - open Location - switch comments { - | list{comment, ...rest} => - let cmtLoc = Comment.loc(comment) - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum { - loop((list{comment, ...leading}, trailing), rest) - } else { - loop((leading, list{comment, ...trailing}), rest) - } - | list{} => (List.rev(leading), List.rev(trailing)) - } - } - - loop((list{}, list{}), comments) - } - - let partitionByOnSameLine = (loc, comments) => { - let rec loop = ((onSameLine, onOtherLine), comments) => { - open Location - switch comments { - | list{} => (List.rev(onSameLine), List.rev(onOtherLine)) - | list{comment, ...rest} => - let cmtLoc = Comment.loc(comment) - if cmtLoc.loc_start.pos_lnum === loc.loc_end.pos_lnum { - loop((list{comment, ...onSameLine}, onOtherLine), rest) - } else { - loop((onSameLine, list{comment, ...onOtherLine}), rest) - } - } - } - - loop((list{}, list{}), comments) - } - - let partitionAdjacentTrailing = (loc1, comments) => { - open Location - open Lexing - let rec loop = (~prevEndPos, afterLoc1, comments) => - switch comments { - | list{} => (List.rev(afterLoc1), list{}) - | list{comment, ...rest} as comments => - let cmtPrevEndPos = Comment.prevTokEndPos(comment) - if prevEndPos.Lexing.pos_cnum === cmtPrevEndPos.pos_cnum { - let commentEnd = Comment.loc(comment).loc_end - loop(~prevEndPos=commentEnd, list{comment, ...afterLoc1}, rest) - } else { - (List.rev(afterLoc1), comments) - } - } - - loop(~prevEndPos=loc1.loc_end, list{}, comments) - } - - let rec collectListPatterns = (acc, pattern) => { - open Parsetree - switch pattern.ppat_desc { - | Ppat_construct( - {txt: Longident.Lident("::")}, - Some({ppat_desc: Ppat_tuple(list{pat, rest})}), - ) => - collectListPatterns(list{pat, ...acc}, rest) - | Ppat_construct({txt: Longident.Lident("[]")}, None) => List.rev(acc) - | _ => List.rev(list{pattern, ...acc}) - } - } - - let rec collectListExprs = (acc, expr) => { - open Parsetree - switch expr.pexp_desc { - | Pexp_construct( - {txt: Longident.Lident("::")}, - Some({pexp_desc: Pexp_tuple(list{expr, rest})}), - ) => - collectListExprs(list{expr, ...acc}, rest) - | Pexp_construct({txt: Longident.Lident("[]")}, _) => List.rev(acc) - | _ => List.rev(list{expr, ...acc}) - } - } - - /* TODO: use ParsetreeViewer */ - let arrowType = ct => { - open Parsetree - let rec process = (attrsBefore, acc, typ) => - switch typ { - | {ptyp_desc: Ptyp_arrow(Nolabel as lbl, typ1, typ2), ptyp_attributes: list{}} => - let arg = (list{}, lbl, typ1) - process(attrsBefore, list{arg, ...acc}, typ2) - | { - ptyp_desc: Ptyp_arrow(Nolabel as lbl, typ1, typ2), - ptyp_attributes: list{({txt: "bs"}, _)} as attrs, - } => - let arg = (attrs, lbl, typ1) - process(attrsBefore, list{arg, ...acc}, typ2) - | {ptyp_desc: Ptyp_arrow(Nolabel, _typ1, _typ2), ptyp_attributes: _attrs} as returnType => - let args = List.rev(acc) - (attrsBefore, args, returnType) - | { - ptyp_desc: Ptyp_arrow((Labelled(_) | Optional(_)) as lbl, typ1, typ2), - ptyp_attributes: attrs, - } => - let arg = (attrs, lbl, typ1) - process(attrsBefore, list{arg, ...acc}, typ2) - | typ => (attrsBefore, List.rev(acc), typ) - } - - switch ct { - | {ptyp_desc: Ptyp_arrow(Nolabel, _typ1, _typ2), ptyp_attributes: attrs} as typ => - process(attrs, list{}, {...typ, ptyp_attributes: list{}}) - | typ => process(list{}, list{}, typ) - } - } - - /* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? */ - let modExprApply = modExpr => { - let rec loop = (acc, modExpr) => - switch modExpr { - | {Parsetree.pmod_desc: Pmod_apply(next, arg)} => loop(list{arg, ...acc}, next) - | _ => list{modExpr, ...acc} - } - - loop(list{}, modExpr) - } - - /* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? */ - let modExprFunctor = modExpr => { - let rec loop = (acc, modExpr) => - switch modExpr { - | {Parsetree.pmod_desc: Pmod_functor(lbl, modType, returnModExpr), pmod_attributes: attrs} => - let param = (attrs, lbl, modType) - loop(list{param, ...acc}, returnModExpr) - | returnModExpr => (List.rev(acc), returnModExpr) - } - - loop(list{}, modExpr) - } - - let functorType = modtype => { - let rec process = (acc, modtype) => - switch modtype { - | {Parsetree.pmty_desc: Pmty_functor(lbl, argType, returnType), pmty_attributes: attrs} => - let arg = (attrs, lbl, argType) - process(list{arg, ...acc}, returnType) - | modType => (List.rev(acc), modType) - } - - process(list{}, modtype) - } - - let funExpr = expr => { - open Parsetree - /* Turns (type t, type u, type z) into "type t u z" */ - let rec collectNewTypes = (acc, returnExpr) => - switch returnExpr { - | {pexp_desc: Pexp_newtype(stringLoc, returnExpr), pexp_attributes: list{}} => - collectNewTypes(list{stringLoc, ...acc}, returnExpr) - | returnExpr => - let loc = switch (acc, List.rev(acc)) { - | (list{_startLoc, ..._}, list{endLoc, ..._}) => { - ...endLoc.loc, - loc_end: endLoc.loc.loc_end, - } - | _ => Location.none - } - - let txt = List.fold_right((curr, acc) => acc ++ (" " ++ curr.Location.txt), acc, "type") - (Location.mkloc(txt, loc), returnExpr) - } - - /* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, - * otherwise this function would need to return a variant: - * | NormalParamater(...) - * | NewType(...) - * This complicates printing with an extra variant/boxing/allocation for a code-path - * that is not often used. Lets just keep it simple for now */ - let rec collect = (attrsBefore, acc, expr) => - switch expr { - | {pexp_desc: Pexp_fun(lbl, defaultExpr, pattern, returnExpr), pexp_attributes: list{}} => - let parameter = (list{}, lbl, defaultExpr, pattern) - collect(attrsBefore, list{parameter, ...acc}, returnExpr) - | {pexp_desc: Pexp_newtype(stringLoc, rest), pexp_attributes: attrs} => - let (var, returnExpr) = collectNewTypes(list{stringLoc}, rest) - let parameter = (attrs, Asttypes.Nolabel, None, Ast_helper.Pat.var(~loc=stringLoc.loc, var)) - collect(attrsBefore, list{parameter, ...acc}, returnExpr) - | { - pexp_desc: Pexp_fun(lbl, defaultExpr, pattern, returnExpr), - pexp_attributes: list{({txt: "bs"}, _)} as attrs, - } => - let parameter = (attrs, lbl, defaultExpr, pattern) - collect(attrsBefore, list{parameter, ...acc}, returnExpr) - | { - pexp_desc: Pexp_fun((Labelled(_) | Optional(_)) as lbl, defaultExpr, pattern, returnExpr), - pexp_attributes: attrs, - } => - let parameter = (attrs, lbl, defaultExpr, pattern) - collect(attrsBefore, list{parameter, ...acc}, returnExpr) - | expr => (attrsBefore, List.rev(acc), expr) - } - - switch expr { - | { - pexp_desc: Pexp_fun(Nolabel, _defaultExpr, _pattern, _returnExpr), - pexp_attributes: attrs, - } as expr => - collect(attrs, list{}, {...expr, pexp_attributes: list{}}) - | expr => collect(list{}, list{}, expr) - } - } - - let rec isBlockExpr = expr => { - open Parsetree - switch expr.pexp_desc { - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_let(_) - | Pexp_open(_) - | Pexp_sequence(_) => true - | Pexp_apply(callExpr, _) when isBlockExpr(callExpr) => true - | Pexp_constraint(expr, _) when isBlockExpr(expr) => true - | Pexp_field(expr, _) when isBlockExpr(expr) => true - | Pexp_setfield(expr, _, _) when isBlockExpr(expr) => true - | _ => false - } - } - - let rec walkStructure = (s, t, comments) => - switch s { - | _ when comments == list{} => () - | list{} => attach(t.inside, Location.none, comments) - | s => walkList(~getLoc=n => n.Parsetree.pstr_loc, ~walkNode=walkStructureItem, s, t, comments) - } - - and walkStructureItem = (si, t, comments) => - switch si.Parsetree.pstr_desc { - | _ when comments == list{} => () - | Pstr_primitive(valueDescription) => walkValueDescription(valueDescription, t, comments) - | Pstr_open(openDescription) => walkOpenDescription(openDescription, t, comments) - | Pstr_value(_, valueBindings) => walkValueBindings(valueBindings, t, comments) - | Pstr_type(_, typeDeclarations) => walkTypeDeclarations(typeDeclarations, t, comments) - | Pstr_eval(expr, _) => walkExpr(expr, t, comments) - | Pstr_module(moduleBinding) => walkModuleBinding(moduleBinding, t, comments) - | Pstr_recmodule(moduleBindings) => - walkList( - ~getLoc=mb => mb.Parsetree.pmb_loc, - ~walkNode=walkModuleBinding, - moduleBindings, - t, - comments, - ) - | Pstr_modtype(modTypDecl) => walkModuleTypeDeclaration(modTypDecl, t, comments) - | Pstr_attribute(attribute) => walkAttribute(attribute, t, comments) - | Pstr_extension(extension, _) => walkExtension(extension, t, comments) - | Pstr_include(includeDeclaration) => walkIncludeDeclaration(includeDeclaration, t, comments) - | Pstr_exception(extensionConstructor) => walkExtConstr(extensionConstructor, t, comments) - | Pstr_typext(typeExtension) => walkTypeExtension(typeExtension, t, comments) - | Pstr_class_type(_) | Pstr_class(_) => () - } - - and walkValueDescription = (vd, t, comments) => { - let (leading, trailing) = partitionLeadingTrailing(comments, vd.pval_name.loc) - attach(t.leading, vd.pval_name.loc, leading) - let (afterName, rest) = partitionAdjacentTrailing(vd.pval_name.loc, trailing) - attach(t.trailing, vd.pval_name.loc, afterName) - let (before, inside, after) = partitionByLoc(rest, vd.pval_type.ptyp_loc) - - attach(t.leading, vd.pval_type.ptyp_loc, before) - walkTypExpr(vd.pval_type, t, inside) - attach(t.trailing, vd.pval_type.ptyp_loc, after) - } - - and walkTypeExtension = (te, t, comments) => { - let (leading, trailing) = partitionLeadingTrailing(comments, te.ptyext_path.loc) - attach(t.leading, te.ptyext_path.loc, leading) - let (afterPath, rest) = partitionAdjacentTrailing(te.ptyext_path.loc, trailing) - attach(t.trailing, te.ptyext_path.loc, afterPath) - - /* type params */ - let rest = switch te.ptyext_params { - | list{} => rest - | typeParams => - visitListButContinueWithRemainingComments( - ~getLoc=((typexpr, _variance)) => typexpr.Parsetree.ptyp_loc, - ~walkNode=walkTypeParam, - ~newlineDelimited=false, - typeParams, - t, - rest, - ) - } - - walkList( - ~getLoc=n => n.Parsetree.pext_loc, - ~walkNode=walkExtConstr, - te.ptyext_constructors, - t, - rest, - ) - } - - and walkIncludeDeclaration = (inclDecl, t, comments) => { - let (before, inside, after) = partitionByLoc(comments, inclDecl.pincl_mod.pmod_loc) - attach(t.leading, inclDecl.pincl_mod.pmod_loc, before) - walkModExpr(inclDecl.pincl_mod, t, inside) - attach(t.trailing, inclDecl.pincl_mod.pmod_loc, after) - } - - and walkModuleTypeDeclaration = (mtd, t, comments) => { - let (leading, trailing) = partitionLeadingTrailing(comments, mtd.pmtd_name.loc) - attach(t.leading, mtd.pmtd_name.loc, leading) - switch mtd.pmtd_type { - | None => attach(t.trailing, mtd.pmtd_name.loc, trailing) - | Some(modType) => - let (afterName, rest) = partitionAdjacentTrailing(mtd.pmtd_name.loc, trailing) - attach(t.trailing, mtd.pmtd_name.loc, afterName) - let (before, inside, after) = partitionByLoc(rest, modType.pmty_loc) - attach(t.leading, modType.pmty_loc, before) - walkModType(modType, t, inside) - attach(t.trailing, modType.pmty_loc, after) - } - } - - and walkModuleBinding = (mb, t, comments) => { - let (leading, trailing) = partitionLeadingTrailing(comments, mb.pmb_name.loc) - attach(t.leading, mb.pmb_name.loc, leading) - let (afterName, rest) = partitionAdjacentTrailing(mb.pmb_name.loc, trailing) - attach(t.trailing, mb.pmb_name.loc, afterName) - let (leading, inside, trailing) = partitionByLoc(rest, mb.pmb_expr.pmod_loc) - switch mb.pmb_expr.pmod_desc { - | Pmod_constraint(_) => walkModExpr(mb.pmb_expr, t, List.concat(list{leading, inside})) - | _ => - attach(t.leading, mb.pmb_expr.pmod_loc, leading) - walkModExpr(mb.pmb_expr, t, inside) - } - attach(t.trailing, mb.pmb_expr.pmod_loc, trailing) - } - - and walkSignature = (signature, t, comments) => - switch signature { - | _ when comments == list{} => () - | list{} => attach(t.inside, Location.none, comments) - | _s => - walkList( - ~getLoc=n => n.Parsetree.psig_loc, - ~walkNode=walkSignatureItem, - signature, - t, - comments, - ) - } - - and walkSignatureItem = (si, t, comments) => - switch si.psig_desc { - | _ when comments == list{} => () - | Psig_value(valueDescription) => walkValueDescription(valueDescription, t, comments) - | Psig_type(_, typeDeclarations) => walkTypeDeclarations(typeDeclarations, t, comments) - | Psig_typext(typeExtension) => walkTypeExtension(typeExtension, t, comments) - | Psig_exception(extensionConstructor) => walkExtConstr(extensionConstructor, t, comments) - | Psig_module(moduleDeclaration) => walkModuleDeclaration(moduleDeclaration, t, comments) - | Psig_recmodule(moduleDeclarations) => - walkList( - ~getLoc=n => n.Parsetree.pmd_loc, - ~walkNode=walkModuleDeclaration, - moduleDeclarations, - t, - comments, - ) - | Psig_modtype(moduleTypeDeclaration) => - walkModuleTypeDeclaration(moduleTypeDeclaration, t, comments) - | Psig_open(openDescription) => walkOpenDescription(openDescription, t, comments) - | Psig_include(includeDescription) => walkIncludeDescription(includeDescription, t, comments) - | Psig_attribute(attribute) => walkAttribute(attribute, t, comments) - | Psig_extension(extension, _) => walkExtension(extension, t, comments) - | Psig_class(_) | Psig_class_type(_) => () - } - - and walkIncludeDescription = (id, t, comments) => { - let (before, inside, after) = partitionByLoc(comments, id.pincl_mod.pmty_loc) - attach(t.leading, id.pincl_mod.pmty_loc, before) - walkModType(id.pincl_mod, t, inside) - attach(t.trailing, id.pincl_mod.pmty_loc, after) - } - - and walkModuleDeclaration = (md, t, comments) => { - let (leading, trailing) = partitionLeadingTrailing(comments, md.pmd_name.loc) - attach(t.leading, md.pmd_name.loc, leading) - let (afterName, rest) = partitionAdjacentTrailing(md.pmd_name.loc, trailing) - attach(t.trailing, md.pmd_name.loc, afterName) - let (leading, inside, trailing) = partitionByLoc(rest, md.pmd_type.pmty_loc) - attach(t.leading, md.pmd_type.pmty_loc, leading) - walkModType(md.pmd_type, t, inside) - attach(t.trailing, md.pmd_type.pmty_loc, trailing) - } - - and walkList: 'node. ( - ~prevLoc: Location.t=?, - ~getLoc: 'node => Location.t, - ~walkNode: ('node, t, list) => unit, - list<'node>, - t, - list, - ) => unit = (~prevLoc=?, ~getLoc, ~walkNode, l, t, comments) => { - open Location - switch l { - | _ when comments == list{} => () - | list{} => - switch prevLoc { - | Some(loc) => attach(t.trailing, loc, comments) - | None => () - } - | list{node, ...rest} => - let currLoc = getLoc(node) - let (leading, inside, trailing) = partitionByLoc(comments, currLoc) - switch prevLoc { - | None => - /* first node, all leading comments attach here */ - attach(t.leading, currLoc, leading) - | Some(prevLoc) => - /* Same line */ - if prevLoc.loc_end.pos_lnum === currLoc.loc_start.pos_lnum { - let (afterPrev, beforeCurr) = partitionAdjacentTrailing(prevLoc, leading) - let () = attach(t.trailing, prevLoc, afterPrev) - attach(t.leading, currLoc, beforeCurr) - } else { - let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine(prevLoc, leading) - let () = attach(t.trailing, prevLoc, onSameLineAsPrev) - let (leading, _inside, _trailing) = partitionByLoc(afterPrev, currLoc) - attach(t.leading, currLoc, leading) - } - } - walkNode(node, t, inside) - walkList(~prevLoc=currLoc, ~getLoc, ~walkNode, rest, t, trailing) - } - } - - /* The parsetree doesn't always contain location info about the opening or - * closing token of a "list-of-things". This routine visits the whole list, - * but returns any remaining comments that likely fall after the whole list. */ - and visitListButContinueWithRemainingComments: 'node. ( - ~prevLoc: Location.t=?, - ~newlineDelimited: bool, - ~getLoc: 'node => Location.t, - ~walkNode: ('node, t, list) => unit, - list<'node>, - t, - list, - ) => list = (~prevLoc=?, ~newlineDelimited, ~getLoc, ~walkNode, l, t, comments) => { - open Location - switch l { - | _ when comments == list{} => list{} - | list{} => - switch prevLoc { - | Some(loc) => - let (afterPrev, rest) = if newlineDelimited { - partitionByOnSameLine(loc, comments) - } else { - partitionAdjacentTrailing(loc, comments) - } - - attach(t.trailing, loc, afterPrev) - rest - | None => comments - } - | list{node, ...rest} => - let currLoc = getLoc(node) - let (leading, inside, trailing) = partitionByLoc(comments, currLoc) - let () = switch prevLoc { - | None => - /* first node, all leading comments attach here */ - attach(t.leading, currLoc, leading) - () - | Some(prevLoc) => - /* Same line */ - if prevLoc.loc_end.pos_lnum === currLoc.loc_start.pos_lnum { - let (afterPrev, beforeCurr) = partitionAdjacentTrailing(prevLoc, leading) - let () = attach(t.trailing, prevLoc, afterPrev) - let () = attach(t.leading, currLoc, beforeCurr) - } else { - let (onSameLineAsPrev, afterPrev) = partitionByOnSameLine(prevLoc, leading) - let () = attach(t.trailing, prevLoc, onSameLineAsPrev) - let (leading, _inside, _trailing) = partitionByLoc(afterPrev, currLoc) - let () = attach(t.leading, currLoc, leading) - } - } - - walkNode(node, t, inside) - visitListButContinueWithRemainingComments( - ~prevLoc=currLoc, - ~getLoc, - ~walkNode, - ~newlineDelimited, - rest, - t, - trailing, - ) - } - } - - and walkValueBindings = (vbs, t, comments) => - walkList(~getLoc=n => n.Parsetree.pvb_loc, ~walkNode=walkValueBinding, vbs, t, comments) - - and walkOpenDescription = (openDescription, t, comments) => { - let loc = openDescription.popen_lid.loc - let (leading, trailing) = partitionLeadingTrailing(comments, loc) - attach(t.leading, loc, leading) - attach(t.trailing, loc, trailing) - } - - and walkTypeDeclarations = (typeDeclarations, t, comments) => - walkList( - ~getLoc=n => n.Parsetree.ptype_loc, - ~walkNode=walkTypeDeclaration, - typeDeclarations, - t, - comments, - ) - - and walkTypeParam = ((typexpr, _variance), t, comments) => walkTypExpr(typexpr, t, comments) - - and walkTypeDeclaration = (td, t, comments) => { - let (beforeName, rest) = partitionLeadingTrailing(comments, td.ptype_name.loc) - attach(t.leading, td.ptype_name.loc, beforeName) - - let (afterName, rest) = partitionAdjacentTrailing(td.ptype_name.loc, rest) - attach(t.trailing, td.ptype_name.loc, afterName) - - /* type params */ - let rest = switch td.ptype_params { - | list{} => rest - | typeParams => - visitListButContinueWithRemainingComments( - ~getLoc=((typexpr, _variance)) => typexpr.Parsetree.ptyp_loc, - ~walkNode=walkTypeParam, - ~newlineDelimited=false, - typeParams, - t, - rest, - ) - } - - /* manifest: = typexpr */ - let rest = switch td.ptype_manifest { - | Some(typexpr) => - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(rest, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - let (afterTyp, rest) = partitionAdjacentTrailing(typexpr.Parsetree.ptyp_loc, afterTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - rest - | None => rest - } - - let rest = switch td.ptype_kind { - | Ptype_abstract | Ptype_open => rest - | Ptype_record(labelDeclarations) => - let () = walkList( - ~getLoc=ld => ld.Parsetree.pld_loc, - ~walkNode=walkLabelDeclaration, - labelDeclarations, - t, - rest, - ) - - list{} - | Ptype_variant(constructorDeclarations) => - walkConstructorDeclarations(constructorDeclarations, t, rest) - } - - attach(t.trailing, td.ptype_loc, rest) - } - - and walkLabelDeclarations = (lds, t, comments) => - visitListButContinueWithRemainingComments( - ~getLoc=ld => ld.Parsetree.pld_loc, - ~walkNode=walkLabelDeclaration, - ~newlineDelimited=false, - lds, - t, - comments, - ) - - and walkLabelDeclaration = (ld, t, comments) => { - let (beforeName, rest) = partitionLeadingTrailing(comments, ld.pld_name.loc) - attach(t.leading, ld.pld_name.loc, beforeName) - let (afterName, rest) = partitionAdjacentTrailing(ld.pld_name.loc, rest) - attach(t.trailing, ld.pld_name.loc, afterName) - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(rest, ld.pld_type.ptyp_loc) - attach(t.leading, ld.pld_type.ptyp_loc, beforeTyp) - walkTypExpr(ld.pld_type, t, insideTyp) - attach(t.trailing, ld.pld_type.ptyp_loc, afterTyp) - } - - and walkConstructorDeclarations = (cds, t, comments) => - visitListButContinueWithRemainingComments( - ~getLoc=cd => cd.Parsetree.pcd_loc, - ~walkNode=walkConstructorDeclaration, - ~newlineDelimited=false, - cds, - t, - comments, - ) - - and walkConstructorDeclaration = (cd, t, comments) => { - let (beforeName, rest) = partitionLeadingTrailing(comments, cd.pcd_name.loc) - attach(t.leading, cd.pcd_name.loc, beforeName) - let (afterName, rest) = partitionAdjacentTrailing(cd.pcd_name.loc, rest) - attach(t.trailing, cd.pcd_name.loc, afterName) - let rest = walkConstructorArguments(cd.pcd_args, t, rest) - - let rest = switch cd.pcd_res { - | Some(typexpr) => - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(rest, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - let (afterTyp, rest) = partitionAdjacentTrailing(typexpr.Parsetree.ptyp_loc, afterTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - rest - | None => rest - } - - attach(t.trailing, cd.pcd_loc, rest) - } - - and walkConstructorArguments = (args, t, comments) => - switch args { - | Pcstr_tuple(typexprs) => - visitListButContinueWithRemainingComments( - ~getLoc=n => n.Parsetree.ptyp_loc, - ~walkNode=walkTypExpr, - ~newlineDelimited=false, - typexprs, - t, - comments, - ) - | Pcstr_record(labelDeclarations) => walkLabelDeclarations(labelDeclarations, t, comments) - } - - and walkValueBinding = (vb, t, comments) => { - open Location - - let vb = { - open Parsetree - switch (vb.pvb_pat, vb.pvb_expr) { - | ( - {ppat_desc: Ppat_constraint(pat, {ptyp_desc: Ptyp_poly(list{}, t)})}, - {pexp_desc: Pexp_constraint(expr, _typ)}, - ) => { - ...vb, - pvb_pat: Ast_helper.Pat.constraint_( - ~loc={...pat.ppat_loc, loc_end: t.Parsetree.ptyp_loc.loc_end}, - pat, - t, - ), - pvb_expr: expr, - } - | ( - {ppat_desc: Ppat_constraint(pat, {ptyp_desc: Ptyp_poly(list{_, ..._}, t)})}, - {pexp_desc: Pexp_fun(_)}, - ) => { - ...vb, - pvb_pat: { - ...vb.pvb_pat, - ppat_loc: {...pat.ppat_loc, loc_end: t.ptyp_loc.loc_end}, - }, - } - | _ => vb - } - } - - let patternLoc = vb.Parsetree.pvb_pat.ppat_loc - let exprLoc = vb.Parsetree.pvb_expr.pexp_loc - - let (leading, inside, trailing) = partitionByLoc(comments, patternLoc) - - /* everything before start of pattern can only be leading on the pattern: - * let |* before *| a = 1 */ - attach(t.leading, patternLoc, leading) - walkPattern(vb.Parsetree.pvb_pat, t, inside) - /* let pattern = expr -> pattern and expr on the same line */ - /* if patternLoc.loc_end.pos_lnum == exprLoc.loc_start.pos_lnum then ( */ - let (afterPat, surroundingExpr) = partitionAdjacentTrailing(patternLoc, trailing) - - attach(t.trailing, patternLoc, afterPat) - let (beforeExpr, insideExpr, afterExpr) = partitionByLoc(surroundingExpr, exprLoc) - if isBlockExpr(vb.pvb_expr) { - walkExpr(vb.pvb_expr, t, List.concat(list{beforeExpr, insideExpr, afterExpr})) - } else { - attach(t.leading, exprLoc, beforeExpr) - walkExpr(vb.Parsetree.pvb_expr, t, insideExpr) - attach(t.trailing, exprLoc, afterExpr) - } - } - - and walkExpr = (expr, t, comments) => { - open Location - switch expr.Parsetree.pexp_desc { - | _ when comments == list{} => () - | Pexp_constant(_) => - let (leading, trailing) = partitionLeadingTrailing(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - attach(t.trailing, expr.pexp_loc, trailing) - | Pexp_ident(longident) => - let (leading, trailing) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, leading) - attach(t.trailing, longident.loc, trailing) - | Pexp_let(_recFlag, valueBindings, expr2) => - let comments = visitListButContinueWithRemainingComments(~getLoc=n => - if n.Parsetree.pvb_pat.ppat_loc.loc_ghost { - n.pvb_expr.pexp_loc - } else { - n.Parsetree.pvb_loc - } - , ~walkNode=walkValueBinding, ~newlineDelimited=true, valueBindings, t, comments) - - if isBlockExpr(expr2) { - walkExpr(expr2, t, comments) - } else { - let (leading, inside, trailing) = partitionByLoc(comments, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - attach(t.trailing, expr2.pexp_loc, trailing) - } - | Pexp_sequence(expr1, expr2) => - let (leading, inside, trailing) = partitionByLoc(comments, expr1.pexp_loc) - let comments = if isBlockExpr(expr1) { - let (afterExpr, comments) = partitionByOnSameLine(expr1.pexp_loc, trailing) - walkExpr(expr1, t, List.concat(list{leading, inside, afterExpr})) - comments - } else { - attach(t.leading, expr1.pexp_loc, leading) - walkExpr(expr1, t, inside) - let (afterExpr, comments) = partitionByOnSameLine(expr1.pexp_loc, trailing) - attach(t.trailing, expr1.pexp_loc, afterExpr) - comments - } - if isBlockExpr(expr2) { - walkExpr(expr2, t, comments) - } else { - let (leading, inside, trailing) = partitionByLoc(comments, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - attach(t.trailing, expr2.pexp_loc, trailing) - } - | Pexp_open(_override, longident, expr2) => - let (leading, comments) = partitionLeadingTrailing(comments, expr.pexp_loc) - attach(t.leading, {...expr.pexp_loc, loc_end: longident.loc.loc_end}, leading) - let (leading, trailing) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, leading) - let (afterLongident, rest) = partitionByOnSameLine(longident.loc, trailing) - attach(t.trailing, longident.loc, afterLongident) - if isBlockExpr(expr2) { - walkExpr(expr2, t, rest) - } else { - let (leading, inside, trailing) = partitionByLoc(rest, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - attach(t.trailing, expr2.pexp_loc, trailing) - } - | Pexp_extension( - {txt: "bs.obj"}, - PStr(list{{pstr_desc: Pstr_eval({pexp_desc: Pexp_record(rows, _)}, list{})}}), - ) => - walkList(~getLoc=((longident, expr): (Asttypes.loc, Parsetree.expression)) => { - ...longident.loc, - loc_end: expr.pexp_loc.loc_end, - }, ~walkNode=walkExprRecordRow, rows, t, comments) - | Pexp_extension(extension) => walkExtension(extension, t, comments) - | Pexp_letexception(extensionConstructor, expr2) => - let (leading, comments) = partitionLeadingTrailing(comments, expr.pexp_loc) - attach(t.leading, {...expr.pexp_loc, loc_end: extensionConstructor.pext_loc.loc_end}, leading) - let (leading, inside, trailing) = partitionByLoc(comments, extensionConstructor.pext_loc) - attach(t.leading, extensionConstructor.pext_loc, leading) - walkExtConstr(extensionConstructor, t, inside) - let (afterExtConstr, rest) = partitionByOnSameLine(extensionConstructor.pext_loc, trailing) - attach(t.trailing, extensionConstructor.pext_loc, afterExtConstr) - if isBlockExpr(expr2) { - walkExpr(expr2, t, rest) - } else { - let (leading, inside, trailing) = partitionByLoc(rest, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - attach(t.trailing, expr2.pexp_loc, trailing) - } - | Pexp_letmodule(stringLoc, modExpr, expr2) => - let (leading, comments) = partitionLeadingTrailing(comments, expr.pexp_loc) - attach(t.leading, {...expr.pexp_loc, loc_end: modExpr.pmod_loc.loc_end}, leading) - let (leading, trailing) = partitionLeadingTrailing(comments, stringLoc.loc) - attach(t.leading, stringLoc.loc, leading) - let (afterString, rest) = partitionAdjacentTrailing(stringLoc.loc, trailing) - attach(t.trailing, stringLoc.loc, afterString) - let (beforeModExpr, insideModExpr, afterModExpr) = partitionByLoc(rest, modExpr.pmod_loc) - attach(t.leading, modExpr.pmod_loc, beforeModExpr) - walkModExpr(modExpr, t, insideModExpr) - let (afterModExpr, rest) = partitionByOnSameLine(modExpr.pmod_loc, afterModExpr) - attach(t.trailing, modExpr.pmod_loc, afterModExpr) - if isBlockExpr(expr2) { - walkExpr(expr2, t, rest) - } else { - let (leading, inside, trailing) = partitionByLoc(rest, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - attach(t.trailing, expr2.pexp_loc, trailing) - } - | Pexp_assert(expr) | Pexp_lazy(expr) => - if isBlockExpr(expr) { - walkExpr(expr, t, comments) - } else { - let (leading, inside, trailing) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, trailing) - } - | Pexp_coerce(expr, optTypexpr, typexpr) => - let (leading, inside, trailing) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, trailing) - attach(t.trailing, expr.pexp_loc, afterExpr) - let rest = switch optTypexpr { - | Some(typexpr) => - let (leading, inside, trailing) = partitionByLoc(comments, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, leading) - walkTypExpr(typexpr, t, inside) - let (afterTyp, rest) = partitionAdjacentTrailing(typexpr.ptyp_loc, trailing) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - rest - | None => rest - } - - let (leading, inside, trailing) = partitionByLoc(rest, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, leading) - walkTypExpr(typexpr, t, inside) - attach(t.trailing, typexpr.ptyp_loc, trailing) - | Pexp_constraint(expr, typexpr) => - let (leading, inside, trailing) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, trailing) - attach(t.trailing, expr.pexp_loc, afterExpr) - let (leading, inside, trailing) = partitionByLoc(rest, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, leading) - walkTypExpr(typexpr, t, inside) - attach(t.trailing, typexpr.ptyp_loc, trailing) - | Pexp_tuple(list{}) | Pexp_array(list{}) | Pexp_construct({txt: Longident.Lident("[]")}, _) => - attach(t.inside, expr.pexp_loc, comments) - | Pexp_construct({txt: Longident.Lident("::")}, _) => - walkList( - ~getLoc=n => n.Parsetree.pexp_loc, - ~walkNode=walkExpr, - collectListExprs(list{}, expr), - t, - comments, - ) - | Pexp_construct(longident, args) => - let (leading, trailing) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, leading) - switch args { - | Some(expr) => - let (afterLongident, rest) = partitionAdjacentTrailing(longident.loc, trailing) - attach(t.trailing, longident.loc, afterLongident) - walkExpr(expr, t, rest) - | None => attach(t.trailing, longident.loc, trailing) - } - | Pexp_variant(_label, None) => () - | Pexp_variant(_label, Some(expr)) => walkExpr(expr, t, comments) - | Pexp_array(exprs) | Pexp_tuple(exprs) => - walkList(~getLoc=n => n.Parsetree.pexp_loc, ~walkNode=walkExpr, exprs, t, comments) - | Pexp_record(rows, spreadExpr) => - let comments = switch spreadExpr { - | None => comments - | Some(expr) => - let (leading, inside, trailing) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, trailing) - attach(t.trailing, expr.pexp_loc, afterExpr) - rest - } - - walkList(~getLoc=((longident, expr): (Asttypes.loc, Parsetree.expression)) => { - ...longident.loc, - loc_end: expr.pexp_loc.loc_end, - }, ~walkNode=walkExprRecordRow, rows, t, comments) - | Pexp_field(expr, longident) => - let (leading, inside, trailing) = partitionByLoc(comments, expr.pexp_loc) - let trailing = if isBlockExpr(expr) { - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, trailing) - walkExpr(expr, t, List.concat(list{leading, inside, afterExpr})) - rest - } else { - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - trailing - } - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, trailing) - attach(t.trailing, expr.pexp_loc, afterExpr) - let (leading, trailing) = partitionLeadingTrailing(rest, longident.loc) - attach(t.leading, longident.loc, leading) - attach(t.trailing, longident.loc, trailing) - | Pexp_setfield(expr1, longident, expr2) => - let (leading, inside, trailing) = partitionByLoc(comments, expr1.pexp_loc) - let rest = if isBlockExpr(expr1) { - let (afterExpr, rest) = partitionAdjacentTrailing(expr1.pexp_loc, trailing) - walkExpr(expr1, t, List.concat(list{leading, inside, afterExpr})) - rest - } else { - let (afterExpr, rest) = partitionAdjacentTrailing(expr1.pexp_loc, trailing) - attach(t.leading, expr1.pexp_loc, leading) - walkExpr(expr1, t, inside) - attach(t.trailing, expr1.pexp_loc, afterExpr) - rest - } - let (beforeLongident, afterLongident) = partitionLeadingTrailing(rest, longident.loc) - attach(t.leading, longident.loc, beforeLongident) - let (afterLongident, rest) = partitionAdjacentTrailing(longident.loc, afterLongident) - attach(t.trailing, longident.loc, afterLongident) - if isBlockExpr(expr2) { - walkExpr(expr2, t, rest) - } else { - let (leading, inside, trailing) = partitionByLoc(rest, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - attach(t.trailing, expr2.pexp_loc, trailing) - } - | Pexp_ifthenelse(ifExpr, thenExpr, elseExpr) => - let (leading, inside, trailing) = partitionByLoc(comments, ifExpr.pexp_loc) - let comments = if isBlockExpr(ifExpr) { - let (afterExpr, comments) = partitionAdjacentTrailing(ifExpr.pexp_loc, trailing) - walkExpr(ifExpr, t, List.concat(list{leading, inside, afterExpr})) - comments - } else { - attach(t.leading, ifExpr.pexp_loc, leading) - walkExpr(ifExpr, t, inside) - let (afterExpr, comments) = partitionAdjacentTrailing(ifExpr.pexp_loc, trailing) - attach(t.trailing, ifExpr.pexp_loc, afterExpr) - comments - } - let (leading, inside, trailing) = partitionByLoc(comments, thenExpr.pexp_loc) - let comments = if isBlockExpr(thenExpr) { - let (afterExpr, trailing) = partitionAdjacentTrailing(thenExpr.pexp_loc, trailing) - walkExpr(thenExpr, t, List.concat(list{leading, inside, afterExpr})) - trailing - } else { - attach(t.leading, thenExpr.pexp_loc, leading) - walkExpr(thenExpr, t, inside) - let (afterExpr, comments) = partitionAdjacentTrailing(thenExpr.pexp_loc, trailing) - attach(t.trailing, thenExpr.pexp_loc, afterExpr) - comments - } - switch elseExpr { - | None => () - | Some(expr) => - if isBlockExpr(expr) { - walkExpr(expr, t, comments) - } else { - let (leading, inside, trailing) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, trailing) - } - } - | Pexp_while(expr1, expr2) => - let (leading, inside, trailing) = partitionByLoc(comments, expr1.pexp_loc) - let rest = if isBlockExpr(expr1) { - let (afterExpr, rest) = partitionAdjacentTrailing(expr1.pexp_loc, trailing) - walkExpr(expr1, t, List.concat(list{leading, inside, afterExpr})) - rest - } else { - attach(t.leading, expr1.pexp_loc, leading) - walkExpr(expr1, t, inside) - let (afterExpr, rest) = partitionAdjacentTrailing(expr1.pexp_loc, trailing) - attach(t.trailing, expr1.pexp_loc, afterExpr) - rest - } - if isBlockExpr(expr2) { - walkExpr(expr2, t, rest) - } else { - let (leading, inside, trailing) = partitionByLoc(rest, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - attach(t.trailing, expr2.pexp_loc, trailing) - } - | Pexp_for(pat, expr1, expr2, _, expr3) => - let (leading, inside, trailing) = partitionByLoc(comments, pat.ppat_loc) - attach(t.leading, pat.ppat_loc, leading) - walkPattern(pat, t, inside) - let (afterPat, rest) = partitionAdjacentTrailing(pat.ppat_loc, trailing) - attach(t.trailing, pat.ppat_loc, afterPat) - let (leading, inside, trailing) = partitionByLoc(rest, expr1.pexp_loc) - attach(t.leading, expr1.pexp_loc, leading) - walkExpr(expr1, t, inside) - let (afterExpr, rest) = partitionAdjacentTrailing(expr1.pexp_loc, trailing) - attach(t.trailing, expr1.pexp_loc, afterExpr) - let (leading, inside, trailing) = partitionByLoc(rest, expr2.pexp_loc) - attach(t.leading, expr2.pexp_loc, leading) - walkExpr(expr2, t, inside) - let (afterExpr, rest) = partitionAdjacentTrailing(expr2.pexp_loc, trailing) - attach(t.trailing, expr2.pexp_loc, afterExpr) - if isBlockExpr(expr3) { - walkExpr(expr3, t, rest) - } else { - let (leading, inside, trailing) = partitionByLoc(rest, expr3.pexp_loc) - attach(t.leading, expr3.pexp_loc, leading) - walkExpr(expr3, t, inside) - attach(t.trailing, expr3.pexp_loc, trailing) - } - | Pexp_pack(modExpr) => - let (before, inside, after) = partitionByLoc(comments, modExpr.pmod_loc) - attach(t.leading, modExpr.pmod_loc, before) - walkModExpr(modExpr, t, inside) - attach(t.trailing, modExpr.pmod_loc, after) - | Pexp_match(expr, cases) | Pexp_try(expr, cases) => - let (before, inside, after) = partitionByLoc(comments, expr.pexp_loc) - let after = if isBlockExpr(expr) { - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, after) - walkExpr(expr, t, List.concat(list{before, inside, afterExpr})) - rest - } else { - attach(t.leading, expr.pexp_loc, before) - walkExpr(expr, t, inside) - after - } - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, after) - attach(t.trailing, expr.pexp_loc, afterExpr) - walkList(~getLoc=n => { - ...n.Parsetree.pc_lhs.ppat_loc, - loc_end: n.pc_rhs.pexp_loc.loc_end, - }, ~walkNode=walkCase, cases, t, rest) - /* unary expression: todo use parsetreeviewer */ - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("~+" | "~+." | "~-" | "~-." | "not" | "!")})}, - list{(Nolabel, argExpr)}, - ) => - let (before, inside, after) = partitionByLoc(comments, argExpr.pexp_loc) - attach(t.leading, argExpr.pexp_loc, before) - walkExpr(argExpr, t, inside) - attach(t.trailing, argExpr.pexp_loc, after) - /* binary expression */ - | Pexp_apply( - { - pexp_desc: - Pexp_ident({ - txt: - Longident.Lident( - ":=" - | "||" - | "&&" - | "=" - | "==" - | "<" - | ">" - | "!=" - | "!==" - | "<=" - | ">=" - | "|>" - | "+" - | "+." - | "-" - | "-." - | "++" - | "^" - | "*" - | "*." - | "/" - | "/." - | "**" - | "|." - | "<>", - ), - }), - }, - list{(Nolabel, operand1), (Nolabel, operand2)}, - ) => - let (before, inside, after) = partitionByLoc(comments, operand1.pexp_loc) - attach(t.leading, operand1.pexp_loc, before) - walkExpr(operand1, t, inside) - let (afterOperand1, rest) = partitionAdjacentTrailing(operand1.pexp_loc, after) - attach(t.trailing, operand1.pexp_loc, afterOperand1) - let (before, inside, after) = partitionByLoc(rest, operand2.pexp_loc) - attach(t.leading, operand2.pexp_loc, before) - walkExpr(operand2, t, inside) /* (List.concat [inside; after]); */ - attach(t.trailing, operand2.pexp_loc, after) - | Pexp_apply(callExpr, arguments) => - let (before, inside, after) = partitionByLoc(comments, callExpr.pexp_loc) - let after = if isBlockExpr(callExpr) { - let (afterExpr, rest) = partitionAdjacentTrailing(callExpr.pexp_loc, after) - walkExpr(callExpr, t, List.concat(list{before, inside, afterExpr})) - rest - } else { - attach(t.leading, callExpr.pexp_loc, before) - walkExpr(callExpr, t, inside) - after - } - let (afterExpr, rest) = partitionAdjacentTrailing(callExpr.pexp_loc, after) - attach(t.trailing, callExpr.pexp_loc, afterExpr) - walkList(~getLoc=((_argLabel, expr)) => { - let loc = switch expr.Parsetree.pexp_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._attrs} => { - ...loc, - loc_end: expr.pexp_loc.loc_end, - } - | _ => expr.pexp_loc - } - - loc - }, ~walkNode=walkExprArgument, arguments, t, rest) - | Pexp_fun(_, _, _, _) | Pexp_newtype(_) => - let (_, parameters, returnExpr) = funExpr(expr) - let comments = visitListButContinueWithRemainingComments( - ~newlineDelimited=false, - ~walkNode=walkExprPararameter, - ~getLoc=((_attrs, _argLbl, exprOpt, pattern)) => { - open Parsetree - let startPos = switch pattern.ppat_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._attrs} => loc.loc_start - | _ => pattern.ppat_loc.loc_start - } - - switch exprOpt { - | None => {...pattern.ppat_loc, loc_start: startPos} - | Some(expr) => { - ...pattern.ppat_loc, - loc_start: startPos, - loc_end: expr.pexp_loc.loc_end, - } - } - }, - parameters, - t, - comments, - ) - - switch returnExpr.pexp_desc { - | Pexp_constraint(expr, typ) - when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum => - let (leading, inside, trailing) = partitionByLoc(comments, typ.ptyp_loc) - attach(t.leading, typ.ptyp_loc, leading) - walkTypExpr(typ, t, inside) - let (afterTyp, comments) = partitionAdjacentTrailing(typ.ptyp_loc, trailing) - attach(t.trailing, typ.ptyp_loc, afterTyp) - if isBlockExpr(expr) { - walkExpr(expr, t, comments) - } else { - let (leading, inside, trailing) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, trailing) - } - | _ => - if isBlockExpr(returnExpr) { - walkExpr(returnExpr, t, comments) - } else { - let (leading, inside, trailing) = partitionByLoc(comments, returnExpr.pexp_loc) - attach(t.leading, returnExpr.pexp_loc, leading) - walkExpr(returnExpr, t, inside) - attach(t.trailing, returnExpr.pexp_loc, trailing) - } - } - | _ => () - } - } - - and walkExprPararameter = ((_attrs, _argLbl, exprOpt, pattern), t, comments) => { - let (leading, inside, trailing) = partitionByLoc(comments, pattern.ppat_loc) - attach(t.leading, pattern.ppat_loc, leading) - walkPattern(pattern, t, inside) - switch exprOpt { - | Some(expr) => - let (_afterPat, rest) = partitionAdjacentTrailing(pattern.ppat_loc, trailing) - attach(t.trailing, pattern.ppat_loc, trailing) - if isBlockExpr(expr) { - walkExpr(expr, t, rest) - } else { - let (leading, inside, trailing) = partitionByLoc(rest, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, trailing) - } - | None => attach(t.trailing, pattern.ppat_loc, trailing) - } - } - - and walkExprArgument = ((_argLabel, expr), t, comments) => - switch expr.Parsetree.pexp_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._attrs} => - let (leading, trailing) = partitionLeadingTrailing(comments, loc) - attach(t.leading, loc, leading) - let (afterLabel, rest) = partitionAdjacentTrailing(loc, trailing) - attach(t.trailing, loc, afterLabel) - let (before, inside, after) = partitionByLoc(rest, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, before) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, after) - | _ => - let (before, inside, after) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, before) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, after) - } - - and walkCase = (case, t, comments) => { - let (before, inside, after) = partitionByLoc(comments, case.pc_lhs.ppat_loc) - /* cases don't have a location on their own, leading comments should go - * after the bar on the pattern */ - walkPattern(case.pc_lhs, t, List.concat(list{before, inside})) - let (afterPat, rest) = partitionAdjacentTrailing(case.pc_lhs.ppat_loc, after) - attach(t.trailing, case.pc_lhs.ppat_loc, afterPat) - let comments = switch case.pc_guard { - | Some(expr) => - let (before, inside, after) = partitionByLoc(rest, expr.pexp_loc) - let (afterExpr, rest) = partitionAdjacentTrailing(expr.pexp_loc, after) - if isBlockExpr(expr) { - walkExpr(expr, t, List.concat(list{before, inside, afterExpr})) - } else { - attach(t.leading, expr.pexp_loc, before) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, afterExpr) - } - rest - | None => rest - } - - if isBlockExpr(case.pc_rhs) { - walkExpr(case.pc_rhs, t, comments) - } else { - let (before, inside, after) = partitionByLoc(comments, case.pc_rhs.pexp_loc) - attach(t.leading, case.pc_rhs.pexp_loc, before) - walkExpr(case.pc_rhs, t, inside) - attach(t.trailing, case.pc_rhs.pexp_loc, after) - } - } - - and walkExprRecordRow = ((longident, expr), t, comments) => { - let (beforeLongident, afterLongident) = partitionLeadingTrailing(comments, longident.loc) - - attach(t.leading, longident.loc, beforeLongident) - let (afterLongident, rest) = partitionAdjacentTrailing(longident.loc, afterLongident) - attach(t.trailing, longident.loc, afterLongident) - let (leading, inside, trailing) = partitionByLoc(rest, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, leading) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, trailing) - } - - and walkExtConstr = (extConstr, t, comments) => { - let (leading, trailing) = partitionLeadingTrailing(comments, extConstr.pext_name.loc) - attach(t.leading, extConstr.pext_name.loc, leading) - let (afterName, rest) = partitionAdjacentTrailing(extConstr.pext_name.loc, trailing) - attach(t.trailing, extConstr.pext_name.loc, afterName) - walkExtensionConstructorKind(extConstr.pext_kind, t, rest) - } - - and walkExtensionConstructorKind = (kind, t, comments) => - switch kind { - | Pext_rebind(longident) => - let (leading, trailing) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, leading) - attach(t.trailing, longident.loc, trailing) - | Pext_decl(constructorArguments, maybeTypExpr) => - let rest = walkConstructorArguments(constructorArguments, t, comments) - switch maybeTypExpr { - | None => () - | Some(typexpr) => - let (before, inside, after) = partitionByLoc(rest, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, before) - walkTypExpr(typexpr, t, inside) - attach(t.trailing, typexpr.ptyp_loc, after) - } - } - - and walkModExpr = (modExpr, t, comments) => - switch modExpr.pmod_desc { - | Pmod_ident(longident) => - let (before, after) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, before) - attach(t.trailing, longident.loc, after) - | Pmod_structure(structure) => walkStructure(structure, t, comments) - | Pmod_extension(extension) => walkExtension(extension, t, comments) - | Pmod_unpack(expr) => - let (before, inside, after) = partitionByLoc(comments, expr.pexp_loc) - attach(t.leading, expr.pexp_loc, before) - walkExpr(expr, t, inside) - attach(t.trailing, expr.pexp_loc, after) - | Pmod_constraint(modexpr, modtype) => - if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end { - let (before, inside, after) = partitionByLoc(comments, modexpr.pmod_loc) - attach(t.leading, modexpr.pmod_loc, before) - walkModExpr(modexpr, t, inside) - let (after, rest) = partitionAdjacentTrailing(modexpr.pmod_loc, after) - attach(t.trailing, modexpr.pmod_loc, after) - let (before, inside, after) = partitionByLoc(rest, modtype.pmty_loc) - attach(t.leading, modtype.pmty_loc, before) - walkModType(modtype, t, inside) - attach(t.trailing, modtype.pmty_loc, after) - } else { - let (before, inside, after) = partitionByLoc(comments, modtype.pmty_loc) - attach(t.leading, modtype.pmty_loc, before) - walkModType(modtype, t, inside) - let (after, rest) = partitionAdjacentTrailing(modtype.pmty_loc, after) - attach(t.trailing, modtype.pmty_loc, after) - let (before, inside, after) = partitionByLoc(rest, modexpr.pmod_loc) - attach(t.leading, modexpr.pmod_loc, before) - walkModExpr(modexpr, t, inside) - attach(t.trailing, modexpr.pmod_loc, after) - } - | Pmod_apply(_callModExpr, _argModExpr) => - let modExprs = modExprApply(modExpr) - walkList(~getLoc=n => n.Parsetree.pmod_loc, ~walkNode=walkModExpr, modExprs, t, comments) - | Pmod_functor(_) => - let (parameters, returnModExpr) = modExprFunctor(modExpr) - let comments = visitListButContinueWithRemainingComments(~getLoc=((_, lbl, modTypeOption)) => - switch modTypeOption { - | None => lbl.Asttypes.loc - | Some(modType) => {...lbl.loc, loc_end: modType.Parsetree.pmty_loc.loc_end} - } - , ~walkNode=walkModExprParameter, ~newlineDelimited=false, parameters, t, comments) - - switch returnModExpr.pmod_desc { - | Pmod_constraint(modExpr, modType) - when modType.pmty_loc.loc_end.pos_cnum <= modExpr.pmod_loc.loc_start.pos_cnum => - let (before, inside, after) = partitionByLoc(comments, modType.pmty_loc) - attach(t.leading, modType.pmty_loc, before) - walkModType(modType, t, inside) - let (after, rest) = partitionAdjacentTrailing(modType.pmty_loc, after) - attach(t.trailing, modType.pmty_loc, after) - let (before, inside, after) = partitionByLoc(rest, modExpr.pmod_loc) - attach(t.leading, modExpr.pmod_loc, before) - walkModExpr(modExpr, t, inside) - attach(t.trailing, modExpr.pmod_loc, after) - | _ => - let (before, inside, after) = partitionByLoc(comments, returnModExpr.pmod_loc) - attach(t.leading, returnModExpr.pmod_loc, before) - walkModExpr(returnModExpr, t, inside) - attach(t.trailing, returnModExpr.pmod_loc, after) - } - } - - and walkModExprParameter = (parameter, t, comments) => { - let (_attrs, lbl, modTypeOption) = parameter - let (leading, trailing) = partitionLeadingTrailing(comments, lbl.loc) - attach(t.leading, lbl.loc, leading) - switch modTypeOption { - | None => attach(t.trailing, lbl.loc, trailing) - | Some(modType) => - let (afterLbl, rest) = partitionAdjacentTrailing(lbl.loc, trailing) - attach(t.trailing, lbl.loc, afterLbl) - let (before, inside, after) = partitionByLoc(rest, modType.pmty_loc) - attach(t.leading, modType.pmty_loc, before) - walkModType(modType, t, inside) - attach(t.trailing, modType.pmty_loc, after) - } - } - - and walkModType = (modType, t, comments) => - switch modType.pmty_desc { - | Pmty_ident(longident) | Pmty_alias(longident) => - let (leading, trailing) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, leading) - attach(t.trailing, longident.loc, trailing) - | Pmty_signature(signature) => walkSignature(signature, t, comments) - | Pmty_extension(extension) => walkExtension(extension, t, comments) - | Pmty_typeof(modExpr) => - let (before, inside, after) = partitionByLoc(comments, modExpr.pmod_loc) - attach(t.leading, modExpr.pmod_loc, before) - walkModExpr(modExpr, t, inside) - attach(t.trailing, modExpr.pmod_loc, after) - | Pmty_with(modType, _withConstraints) => - let (before, inside, after) = partitionByLoc(comments, modType.pmty_loc) - attach(t.leading, modType.pmty_loc, before) - walkModType(modType, t, inside) - attach(t.trailing, modType.pmty_loc, after) - /* TODO: withConstraints */ - | Pmty_functor(_) => - let (parameters, returnModType) = functorType(modType) - let comments = visitListButContinueWithRemainingComments(~getLoc=((_, lbl, modTypeOption)) => - switch modTypeOption { - | None => lbl.Asttypes.loc - | Some(modType) => - if lbl.txt == "_" { - modType.Parsetree.pmty_loc - } else { - {...lbl.loc, loc_end: modType.Parsetree.pmty_loc.loc_end} - } - } - , ~walkNode=walkModTypeParameter, ~newlineDelimited=false, parameters, t, comments) - - let (before, inside, after) = partitionByLoc(comments, returnModType.pmty_loc) - attach(t.leading, returnModType.pmty_loc, before) - walkModType(returnModType, t, inside) - attach(t.trailing, returnModType.pmty_loc, after) - } - - and walkModTypeParameter = ((_, lbl, modTypeOption), t, comments) => { - let (leading, trailing) = partitionLeadingTrailing(comments, lbl.loc) - attach(t.leading, lbl.loc, leading) - switch modTypeOption { - | None => attach(t.trailing, lbl.loc, trailing) - | Some(modType) => - let (afterLbl, rest) = partitionAdjacentTrailing(lbl.loc, trailing) - attach(t.trailing, lbl.loc, afterLbl) - let (before, inside, after) = partitionByLoc(rest, modType.pmty_loc) - attach(t.leading, modType.pmty_loc, before) - walkModType(modType, t, inside) - attach(t.trailing, modType.pmty_loc, after) - } - } - - and walkPattern = (pat, t, comments) => { - open Location - switch pat.Parsetree.ppat_desc { - | _ when comments == list{} => () - | Ppat_alias(pat, alias) => - let (leading, inside, trailing) = partitionByLoc(comments, pat.ppat_loc) - attach(t.leading, pat.ppat_loc, leading) - walkPattern(pat, t, inside) - let (afterPat, rest) = partitionAdjacentTrailing(pat.ppat_loc, trailing) - attach(t.leading, pat.ppat_loc, leading) - attach(t.trailing, pat.ppat_loc, afterPat) - let (beforeAlias, afterAlias) = partitionLeadingTrailing(rest, alias.loc) - attach(t.leading, alias.loc, beforeAlias) - attach(t.trailing, alias.loc, afterAlias) - | Ppat_tuple(list{}) - | Ppat_array(list{}) - | Ppat_construct({txt: Longident.Lident("()")}, _) - | Ppat_construct({txt: Longident.Lident("[]")}, _) => - attach(t.inside, pat.ppat_loc, comments) - | Ppat_array(patterns) => - walkList(~getLoc=n => n.Parsetree.ppat_loc, ~walkNode=walkPattern, patterns, t, comments) - | Ppat_tuple(patterns) => - walkList(~getLoc=n => n.Parsetree.ppat_loc, ~walkNode=walkPattern, patterns, t, comments) - | Ppat_construct({txt: Longident.Lident("::")}, _) => - walkList( - ~getLoc=n => n.Parsetree.ppat_loc, - ~walkNode=walkPattern, - collectListPatterns(list{}, pat), - t, - comments, - ) - | Ppat_construct(constr, None) => - let (beforeConstr, afterConstr) = partitionLeadingTrailing(comments, constr.loc) - - attach(t.leading, constr.loc, beforeConstr) - attach(t.trailing, constr.loc, afterConstr) - | Ppat_construct(constr, Some(pat)) => - let (leading, trailing) = partitionLeadingTrailing(comments, constr.loc) - attach(t.leading, constr.loc, leading) - let (leading, inside, trailing) = partitionByLoc(trailing, pat.ppat_loc) - attach(t.leading, pat.ppat_loc, leading) - walkPattern(pat, t, inside) - attach(t.trailing, pat.ppat_loc, trailing) - | Ppat_variant(_label, None) => () - | Ppat_variant(_label, Some(pat)) => walkPattern(pat, t, comments) - | Ppat_type(_) => () - | Ppat_record(recordRows, _) => walkList(~getLoc=((longidentLoc, pattern): ( - Asttypes.loc, - Parsetree.pattern, - )) => { - ...longidentLoc.loc, - loc_end: pattern.Parsetree.ppat_loc.loc_end, - }, ~walkNode=walkPatternRecordRow, recordRows, t, comments) - | Ppat_or(pattern1, pattern2) => - let (beforePattern1, insidePattern1, afterPattern1) = partitionByLoc( - comments, - pattern1.ppat_loc, - ) - - attach(t.leading, pattern1.ppat_loc, beforePattern1) - walkPattern(pattern1, t, insidePattern1) - let (afterPattern1, rest) = partitionAdjacentTrailing(pattern1.ppat_loc, afterPattern1) - - attach(t.trailing, pattern1.ppat_loc, afterPattern1) - let (beforePattern2, insidePattern2, afterPattern2) = partitionByLoc(rest, pattern2.ppat_loc) - - attach(t.leading, pattern2.ppat_loc, beforePattern2) - walkPattern(pattern2, t, insidePattern2) - attach(t.trailing, pattern2.ppat_loc, afterPattern2) - | Ppat_constraint(pattern, typ) => - let (beforePattern, insidePattern, afterPattern) = partitionByLoc(comments, pattern.ppat_loc) - - attach(t.leading, pattern.ppat_loc, beforePattern) - walkPattern(pattern, t, insidePattern) - let (afterPattern, rest) = partitionAdjacentTrailing(pattern.ppat_loc, afterPattern) - - attach(t.trailing, pattern.ppat_loc, afterPattern) - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(rest, typ.ptyp_loc) - - attach(t.leading, typ.ptyp_loc, beforeTyp) - walkTypExpr(typ, t, insideTyp) - attach(t.trailing, typ.ptyp_loc, afterTyp) - | Ppat_lazy(pattern) | Ppat_exception(pattern) => - let (leading, inside, trailing) = partitionByLoc(comments, pattern.ppat_loc) - attach(t.leading, pattern.ppat_loc, leading) - walkPattern(pattern, t, inside) - attach(t.trailing, pattern.ppat_loc, trailing) - | Ppat_unpack(stringLoc) => - let (leading, trailing) = partitionLeadingTrailing(comments, stringLoc.loc) - attach(t.leading, stringLoc.loc, leading) - attach(t.trailing, stringLoc.loc, trailing) - | Ppat_extension(extension) => walkExtension(extension, t, comments) - | _ => () - } - } - - /* name: firstName */ - and walkPatternRecordRow = (row, t, comments) => - switch row { - /* punned {x} */ - | ( - {Location.txt: Longident.Lident(ident), loc: longidentLoc}, - {Parsetree.ppat_desc: Ppat_var({txt, _})}, - ) when ident == txt => - let (beforeLbl, afterLbl) = partitionLeadingTrailing(comments, longidentLoc) - - attach(t.leading, longidentLoc, beforeLbl) - attach(t.trailing, longidentLoc, afterLbl) - | (longident, pattern) => - let (beforeLbl, afterLbl) = partitionLeadingTrailing(comments, longident.loc) - - attach(t.leading, longident.loc, beforeLbl) - let (afterLbl, rest) = partitionAdjacentTrailing(longident.loc, afterLbl) - attach(t.trailing, longident.loc, afterLbl) - let (leading, inside, trailing) = partitionByLoc(rest, pattern.ppat_loc) - attach(t.leading, pattern.ppat_loc, leading) - walkPattern(pattern, t, inside) - attach(t.trailing, pattern.ppat_loc, trailing) - } - - and walkTypExpr = (typ, t, comments) => - switch typ.Parsetree.ptyp_desc { - | _ when comments == list{} => () - | Ptyp_tuple(typexprs) => - walkList(~getLoc=n => n.Parsetree.ptyp_loc, ~walkNode=walkTypExpr, typexprs, t, comments) - | Ptyp_extension(extension) => walkExtension(extension, t, comments) - | Ptyp_package(packageType) => walkPackageType(packageType, t, comments) - | Ptyp_alias(typexpr, _alias) => - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(comments, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - | Ptyp_poly(strings, typexpr) => - let comments = visitListButContinueWithRemainingComments( - ~getLoc=n => n.Asttypes.loc, - ~walkNode=(longident, t, comments) => { - let (beforeLongident, afterLongident) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, beforeLongident) - attach(t.trailing, longident.loc, afterLongident) - }, - ~newlineDelimited=false, - strings, - t, - comments, - ) - - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(comments, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - | Ptyp_constr(longident, typexprs) => - let (beforeLongident, _afterLongident) = partitionLeadingTrailing(comments, longident.loc) - let (afterLongident, rest) = partitionAdjacentTrailing(longident.loc, comments) - attach(t.leading, longident.loc, beforeLongident) - attach(t.trailing, longident.loc, afterLongident) - walkList(~getLoc=n => n.Parsetree.ptyp_loc, ~walkNode=walkTypExpr, typexprs, t, rest) - | Ptyp_arrow(_) => - let (_, parameters, typexpr) = arrowType(typ) - let comments = walkTypeParameters(parameters, t, comments) - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(comments, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - | Ptyp_object(fields, _) => walkTypObjectFields(fields, t, comments) - | _ => () - } - - and walkTypObjectFields = (fields, t, comments) => walkList(~getLoc=field => - switch field { - | Parsetree.Otag(lbl, _, typ) => {...lbl.loc, loc_end: typ.ptyp_loc.loc_end} - | _ => Location.none - } - , ~walkNode=walkTypObjectField, fields, t, comments) - - and walkTypObjectField = (field, t, comments) => - switch field { - | Otag(lbl, _, typexpr) => - let (beforeLbl, afterLbl) = partitionLeadingTrailing(comments, lbl.loc) - attach(t.leading, lbl.loc, beforeLbl) - let (afterLbl, rest) = partitionAdjacentTrailing(lbl.loc, afterLbl) - attach(t.trailing, lbl.loc, afterLbl) - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(rest, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - | _ => () - } - - and walkTypeParameters = (typeParameters, t, comments) => - visitListButContinueWithRemainingComments( - ~getLoc=((_, _, typexpr)) => typexpr.Parsetree.ptyp_loc, - ~walkNode=walkTypeParameter, - ~newlineDelimited=false, - typeParameters, - t, - comments, - ) - - and walkTypeParameter = ((_attrs, _lbl, typexpr), t, comments) => { - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(comments, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - } - - and walkPackageType = (packageType, t, comments) => { - let (longident, packageConstraints) = packageType - let (beforeLongident, afterLongident) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, beforeLongident) - let (afterLongident, rest) = partitionAdjacentTrailing(longident.loc, afterLongident) - attach(t.trailing, longident.loc, afterLongident) - walkPackageConstraints(packageConstraints, t, rest) - } - - and walkPackageConstraints = (packageConstraints, t, comments) => walkList(~getLoc=(( - longident, - typexpr, - )) => { - ...longident.Asttypes.loc, - loc_end: typexpr.Parsetree.ptyp_loc.loc_end, - }, ~walkNode=walkPackageConstraint, packageConstraints, t, comments) - - and walkPackageConstraint = (packageConstraint, t, comments) => { - let (longident, typexpr) = packageConstraint - let (beforeLongident, afterLongident) = partitionLeadingTrailing(comments, longident.loc) - attach(t.leading, longident.loc, beforeLongident) - let (afterLongident, rest) = partitionAdjacentTrailing(longident.loc, afterLongident) - attach(t.trailing, longident.loc, afterLongident) - let (beforeTyp, insideTyp, afterTyp) = partitionByLoc(rest, typexpr.ptyp_loc) - attach(t.leading, typexpr.ptyp_loc, beforeTyp) - walkTypExpr(typexpr, t, insideTyp) - attach(t.trailing, typexpr.ptyp_loc, afterTyp) - } - - and walkExtension = (extension, t, comments) => { - let (id, payload) = extension - let (beforeId, afterId) = partitionLeadingTrailing(comments, id.loc) - attach(t.leading, id.loc, beforeId) - let (afterId, rest) = partitionAdjacentTrailing(id.loc, afterId) - attach(t.trailing, id.loc, afterId) - walkPayload(payload, t, rest) - } - - and walkAttribute = ((id, payload), t, comments) => { - let (beforeId, afterId) = partitionLeadingTrailing(comments, id.loc) - attach(t.leading, id.loc, beforeId) - let (afterId, rest) = partitionAdjacentTrailing(id.loc, afterId) - attach(t.trailing, id.loc, afterId) - walkPayload(payload, t, rest) - } - - and walkPayload = (payload, t, comments) => - switch payload { - | PStr(s) => walkStructure(s, t, comments) - | _ => () - } -} - -module Printer = { - let addParens = doc => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent(Doc.concat(list{Doc.softLine, doc})), - Doc.softLine, - Doc.rparen, - }), - ) - - let addBraces = doc => Doc.group(Doc.concat(list{Doc.lbrace, doc, Doc.rbrace})) - - let getFirstLeadingComment = (tbl, loc) => - switch Hashtbl.find(tbl.CommentTable.leading, loc) { - | list{comment, ..._} => Some(comment) - | list{} => None - | exception Not_found => None - } - - let printMultilineCommentContent = txt => { - /* Turns - * |* first line - * * second line - * * third line *| - * Into - * |* first line - * * second line - * * third line *| - * - * What makes a comment suitable for this kind of indentation? - * -> multiple lines + every line starts with a star - */ - let rec indentStars = (lines, acc) => - switch lines { - | list{} => Doc.nil - | list{lastLine} => - let line = String.trim(lastLine) - let doc = Doc.text(" " ++ line) - let trailingSpace = if String.length(line) > 0 { - Doc.space - } else { - Doc.nil - } - List.rev(list{trailingSpace, doc, ...acc}) |> Doc.concat - | list{line, ...lines} => - let line = String.trim(line) - let len = String.length(line) - if len > 0 && (@doesNotRaise String.get)(line, 0) === '*' { - let doc = Doc.text(" " ++ String.trim(line)) - indentStars(lines, list{Doc.hardLine, doc, ...acc}) - } else { - let trailingSpace = { - let len = String.length(txt) - if len > 0 && String.unsafe_get(txt, len - 1) == ' ' { - Doc.space - } else { - Doc.nil - } - } - - let content = Comment.trimSpaces(txt) - Doc.concat(list{Doc.text(content), trailingSpace}) - } - } - - let lines = String.split_on_char('\n', txt) - switch lines { - | list{} => Doc.text("/* */") - | list{line} => - Doc.concat(list{Doc.text("/* "), Doc.text(Comment.trimSpaces(line)), Doc.text(" */")}) - | list{first, ...rest} => - let firstLine = Comment.trimSpaces(first) - Doc.concat(list{ - Doc.text("/*"), - if String.length(firstLine) > 0 && !String.equal(firstLine, "*") { - Doc.space - } else { - Doc.nil - }, - indentStars(rest, list{Doc.hardLine, Doc.text(firstLine)}), - Doc.text("*/"), - }) - } - } - - let printTrailingComment = (nodeLoc: Location.t, comment) => { - let singleLine = Comment.isSingleLineComment(comment) - let content = { - let txt = Comment.txt(comment) - if singleLine { - Doc.text("// " ++ String.trim(txt)) - } else { - printMultilineCommentContent(txt) - } - } - - let diff = { - let cmtStart = Comment.loc(comment).loc_start - let prevTokEndPos = Comment.prevTokEndPos(comment) - cmtStart.pos_lnum - prevTokEndPos.pos_lnum - } - - let isBelow = Comment.loc(comment).loc_start.pos_lnum > nodeLoc.loc_end.pos_lnum - if diff > 0 || isBelow { - Doc.concat(list{ - Doc.breakParent, - Doc.lineSuffix( - Doc.concat(list{ - Doc.hardLine, - if diff > 1 { - Doc.hardLine - } else { - Doc.nil - }, - content, - }), - ), - }) - } else if !singleLine { - Doc.concat(list{Doc.space, content}) - } else { - Doc.lineSuffix(Doc.concat(list{Doc.space, content})) - } - } - - let printLeadingComment = (~nextComment=?, comment) => { - let singleLine = Comment.isSingleLineComment(comment) - let content = { - let txt = Comment.txt(comment) - if singleLine { - Doc.text("// " ++ String.trim(txt)) - } else { - printMultilineCommentContent(txt) - } - } - - let separator = Doc.concat(list{ - if singleLine { - Doc.concat(list{Doc.hardLine, Doc.breakParent}) - } else { - Doc.nil - }, - switch nextComment { - | Some(next) => - let nextLoc = Comment.loc(next) - let currLoc = Comment.loc(comment) - let diff = nextLoc.Location.loc_start.pos_lnum - currLoc.Location.loc_end.pos_lnum - - let nextSingleLine = Comment.isSingleLineComment(next) - if singleLine && nextSingleLine { - if diff > 1 { - Doc.hardLine - } else { - Doc.nil - } - } else if singleLine && !nextSingleLine { - if diff > 1 { - Doc.hardLine - } else { - Doc.nil - } - } else if diff > 1 { - Doc.concat(list{Doc.hardLine, Doc.hardLine}) - } else if diff === 1 { - Doc.hardLine - } else { - Doc.space - } - | None => Doc.nil - }, - }) - - Doc.concat(list{content, separator}) - } - - let printCommentsInside = (cmtTbl, loc) => { - let rec loop = (acc, comments) => - switch comments { - | list{} => Doc.nil - | list{comment} => - let cmtDoc = printLeadingComment(comment) - let doc = Doc.group(Doc.concat(list{Doc.concat(List.rev(list{cmtDoc, ...acc}))})) - - doc - | list{comment, ...list{nextComment, ..._comments} as rest} => - let cmtDoc = printLeadingComment(~nextComment, comment) - loop(list{cmtDoc, ...acc}, rest) - } - - switch Hashtbl.find(cmtTbl.CommentTable.inside, loc) { - | exception Not_found => Doc.nil - | comments => - Hashtbl.remove(cmtTbl.inside, loc) - Doc.group(loop(list{}, comments)) - } - } - - let printLeadingComments = (node, tbl, loc) => { - let rec loop = (acc, comments) => - switch comments { - | list{} => node - | list{comment} => - let cmtDoc = printLeadingComment(comment) - let diff = loc.Location.loc_start.pos_lnum - Comment.loc(comment).Location.loc_end.pos_lnum - - let separator = if Comment.isSingleLineComment(comment) { - if diff > 1 { - Doc.hardLine - } else { - Doc.nil - } - } else if diff === 0 { - Doc.space - } else if diff > 1 { - Doc.concat(list{Doc.hardLine, Doc.hardLine}) - } else { - Doc.hardLine - } - - let doc = Doc.group( - Doc.concat(list{Doc.concat(List.rev(list{cmtDoc, ...acc})), separator, node}), - ) - - doc - | list{comment, ...list{nextComment, ..._comments} as rest} => - let cmtDoc = printLeadingComment(~nextComment, comment) - loop(list{cmtDoc, ...acc}, rest) - } - - switch Hashtbl.find(tbl, loc) { - | exception Not_found => node - | comments => - /* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once */ - Hashtbl.remove(tbl, loc) - loop(list{}, comments) - } - } - - let printTrailingComments = (node, tbl, loc) => { - let rec loop = (acc, comments) => - switch comments { - | list{} => Doc.concat(List.rev(acc)) - | list{comment, ...comments} => - let cmtDoc = printTrailingComment(loc, comment) - loop(list{cmtDoc, ...acc}, comments) - } - - switch Hashtbl.find(tbl, loc) { - | exception Not_found => node - | list{} => node - | list{_first, ..._} as comments => - /* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once */ - Hashtbl.remove(tbl, loc) - let cmtsDoc = loop(list{}, comments) - Doc.concat(list{node, cmtsDoc}) - } - } - - let printComments = (doc, tbl: CommentTable.t, loc) => { - let docWithLeadingComments = printLeadingComments(doc, tbl.leading, loc) - printTrailingComments(docWithLeadingComments, tbl.trailing, loc) - } - - let printList = (~getLoc, ~nodes, ~print, ~forceBreak=false, t) => { - let rec loop = (prevLoc: Location.t, acc, nodes) => - switch nodes { - | list{} => (prevLoc, Doc.concat(List.rev(acc))) - | list{node, ...nodes} => - let loc = getLoc(node) - let startPos = switch getFirstLeadingComment(t, loc) { - | None => loc.loc_start - | Some(comment) => Comment.loc(comment).loc_start - } - - let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 { - Doc.concat(list{Doc.hardLine, Doc.hardLine}) - } else { - Doc.hardLine - } - - let doc = printComments(print(node, t), t, loc) - loop(loc, list{doc, sep, ...acc}, nodes) - } - - switch nodes { - | list{} => Doc.nil - | list{node, ...nodes} => - let firstLoc = getLoc(node) - let doc = printComments(print(node, t), t, firstLoc) - let (lastLoc, docs) = loop(firstLoc, list{doc}, nodes) - let forceBreak = forceBreak || firstLoc.loc_start.pos_lnum !== lastLoc.loc_end.pos_lnum - - Doc.breakableGroup(~forceBreak, docs) - } - } - - let printListi = (~getLoc, ~nodes, ~print, ~forceBreak=false, t) => { - let rec loop = (i, prevLoc: Location.t, acc, nodes) => - switch nodes { - | list{} => (prevLoc, Doc.concat(List.rev(acc))) - | list{node, ...nodes} => - let loc = getLoc(node) - let startPos = switch getFirstLeadingComment(t, loc) { - | None => loc.loc_start - | Some(comment) => Comment.loc(comment).loc_start - } - - let sep = if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 { - Doc.concat(list{Doc.hardLine, Doc.hardLine}) - } else { - Doc.line - } - - let doc = printComments(print(node, t, i), t, loc) - loop(i + 1, loc, list{doc, sep, ...acc}, nodes) - } - - switch nodes { - | list{} => Doc.nil - | list{node, ...nodes} => - let firstLoc = getLoc(node) - let doc = printComments(print(node, t, 0), t, firstLoc) - let (lastLoc, docs) = loop(1, firstLoc, list{doc}, nodes) - let forceBreak = forceBreak || firstLoc.loc_start.pos_lnum !== lastLoc.loc_end.pos_lnum - - Doc.breakableGroup(~forceBreak, docs) - } - } - - let rec printLongidentAux = (accu, x) => - switch x { - | Longident.Lident(s) => list{Doc.text(s), ...accu} - | Ldot(lid, s) => printLongidentAux(list{Doc.text(s), ...accu}, lid) - | Lapply(lid1, lid2) => - let d1 = Doc.join(~sep=Doc.dot, printLongidentAux(list{}, lid1)) - let d2 = Doc.join(~sep=Doc.dot, printLongidentAux(list{}, lid2)) - list{Doc.concat(list{d1, Doc.lparen, d2, Doc.rparen}), ...accu} - } - - let printLongident = x => - switch x { - | Longident.Lident(txt) => Doc.text(txt) - | lid => Doc.join(~sep=Doc.dot, printLongidentAux(list{}, lid)) - } - - type identifierStyle = - | ExoticIdent - | NormalIdent - - let classifyIdentContent = (~allowUident=false, txt) => { - let len = String.length(txt) - let rec go = i => - if i === len { - NormalIdent - } else { - let c = String.unsafe_get(txt, i) - if ( - i === 0 && - !( - (allowUident && (c >= 'A' && c <= 'Z')) || - ((c >= 'a' && c <= 'z') || - (c == '_' || (c >= '0' && c <= '9'))) - ) - ) { - ExoticIdent - } else if ( - !( - (c >= 'a' && c <= 'z') || - ((c >= 'A' && c <= 'Z') || - (c == '\'' || (c == '_' || c >= '0' && c <= '9'))) - ) - ) { - ExoticIdent - } else { - go(i + 1) - } - } - - if Token.isKeywordTxt(txt) && txt != "list" { - ExoticIdent - } else { - go(0) - } - } - - let printIdentLike = (~allowUident=?, txt) => - switch classifyIdentContent(~allowUident?, txt) { - | ExoticIdent => Doc.concat(list{Doc.text("\\\""), Doc.text(txt), Doc.text("\"")}) - | NormalIdent => Doc.text(txt) - } - - let printLident = l => - switch l { - | Longident.Lident(txt) => printIdentLike(txt) - | Longident.Ldot(path, txt) => - let txts = Longident.flatten(path) - Doc.concat(list{ - Doc.join(~sep=Doc.dot, List.map(Doc.text, txts)), - Doc.dot, - printIdentLike(txt), - }) - | _ => Doc.text("printLident: Longident.Lapply is not supported") - } - - let printLongidentLocation = (l, cmtTbl) => { - let doc = printLongident(l.Location.txt) - printComments(doc, cmtTbl, l.loc) - } - - /* Module.SubModule.x */ - let printLidentPath = (path, cmtTbl) => { - let doc = printLident(path.Location.txt) - printComments(doc, cmtTbl, path.loc) - } - - /* Module.SubModule.x or Module.SubModule.X */ - let printIdentPath = (path, cmtTbl) => { - let doc = printLident(path.Location.txt) - printComments(doc, cmtTbl, path.loc) - } - - let printStringLoc = (sloc, cmtTbl) => { - let doc = printIdentLike(sloc.Location.txt) - printComments(doc, cmtTbl, sloc.loc) - } - - let printConstant = c => - switch c { - | Parsetree.Pconst_integer(s, suffix) => - switch suffix { - | Some(c) => Doc.text(s ++ Char.escaped(c)) - | None => Doc.text(s) - } - | Pconst_string(txt, None) => Doc.text("\"" ++ (txt ++ "\"")) - | Pconst_string(txt, Some(prefix)) => - Doc.concat(list{ - if prefix == "" { - Doc.nil - } else { - Doc.text(prefix) - }, - Doc.text("`" ++ (txt ++ "`")), - }) - | Pconst_float(s, _) => Doc.text(s) - | Pconst_char(c) => Doc.text("'" ++ (Char.escaped(c) ++ "'")) - } - - let rec printStructure = (s: Parsetree.structure, t) => - switch s { - | list{} => printCommentsInside(t, Location.none) - | structure => - printList(~getLoc=s => s.Parsetree.pstr_loc, ~nodes=structure, ~print=printStructureItem, t) - } - - and printStructureItem = (si: Parsetree.structure_item, cmtTbl) => - switch si.pstr_desc { - | Pstr_value(rec_flag, valueBindings) => - let recFlag = switch rec_flag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - printValueBindings(~recFlag, valueBindings, cmtTbl) - | Pstr_type(recFlag, typeDeclarations) => - let recFlag = switch recFlag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - printTypeDeclarations(~recFlag, typeDeclarations, cmtTbl) - | Pstr_primitive(valueDescription) => printValueDescription(valueDescription, cmtTbl) - | Pstr_eval(expr, attrs) => - let exprDoc = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.structureExpr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - Doc.concat(list{printAttributes(attrs), exprDoc}) - | Pstr_attribute(attr) => - Doc.concat(list{Doc.text("@"), printAttributeWithComments(attr, cmtTbl)}) - | Pstr_extension(extension, attrs) => - Doc.concat(list{ - printAttributes(attrs), - Doc.concat(list{printExtensionWithComments(~atModuleLvl=true, extension, cmtTbl)}), - }) - | Pstr_include(includeDeclaration) => printIncludeDeclaration(includeDeclaration, cmtTbl) - | Pstr_open(openDescription) => printOpenDescription(openDescription, cmtTbl) - | Pstr_modtype(modTypeDecl) => printModuleTypeDeclaration(modTypeDecl, cmtTbl) - | Pstr_module(moduleBinding) => printModuleBinding(~isRec=false, moduleBinding, cmtTbl, 0) - | Pstr_recmodule(moduleBindings) => - printListi( - ~getLoc=mb => mb.Parsetree.pmb_loc, - ~nodes=moduleBindings, - ~print=printModuleBinding(~isRec=true), - cmtTbl, - ) - | Pstr_exception(extensionConstructor) => printExceptionDef(extensionConstructor, cmtTbl) - | Pstr_typext(typeExtension) => printTypeExtension(typeExtension, cmtTbl) - | Pstr_class(_) | Pstr_class_type(_) => Doc.nil - } - - and printTypeExtension = (te: Parsetree.type_extension, cmtTbl) => { - let prefix = Doc.text("type ") - let name = printLidentPath(te.ptyext_path, cmtTbl) - let typeParams = printTypeParams(te.ptyext_params, cmtTbl) - let extensionConstructors = { - let ecs = te.ptyext_constructors - let forceBreak = switch (ecs, List.rev(ecs)) { - | (list{first, ..._}, list{last, ..._}) => - first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum || - first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum - | _ => false - } - - let privateFlag = switch te.ptyext_private { - | Asttypes.Private => Doc.concat(list{Doc.text("private"), Doc.line}) - | Public => Doc.nil - } - - let rows = printListi( - ~getLoc=n => n.Parsetree.pext_loc, - ~print=printExtensionConstructor, - ~nodes=ecs, - ~forceBreak, - cmtTbl, - ) - - Doc.breakableGroup( - ~forceBreak, - Doc.indent( - Doc.concat(list{ - Doc.line, - privateFlag, - rows, - /* Doc.join ~sep:Doc.line ( */ - /* List.mapi printExtensionConstructor ecs */ - /* ) */ - }), - ), - ) - } - - Doc.group( - Doc.concat(list{ - printAttributes(~loc=te.ptyext_path.loc, te.ptyext_attributes), - prefix, - name, - typeParams, - Doc.text(" +="), - extensionConstructors, - }), - ) - } - - and printModuleBinding = (~isRec, moduleBinding, cmtTbl, i) => { - let prefix = if i == 0 { - Doc.concat(list{ - Doc.text("module "), - if isRec { - Doc.text("rec ") - } else { - Doc.nil - }, - }) - } else { - Doc.text("and ") - } - - let (modExprDoc, modConstraintDoc) = switch moduleBinding.pmb_expr { - | {pmod_desc: Pmod_constraint(modExpr, modType)} => ( - printModExpr(modExpr, cmtTbl), - Doc.concat(list{Doc.text(": "), printModType(modType, cmtTbl)}), - ) - | modExpr => (printModExpr(modExpr, cmtTbl), Doc.nil) - } - - let modName = { - let doc = Doc.text(moduleBinding.pmb_name.Location.txt) - printComments(doc, cmtTbl, moduleBinding.pmb_name.loc) - } - - let doc = Doc.concat(list{ - printAttributes(~loc=moduleBinding.pmb_name.loc, moduleBinding.pmb_attributes), - prefix, - modName, - modConstraintDoc, - Doc.text(" = "), - modExprDoc, - }) - printComments(doc, cmtTbl, moduleBinding.pmb_loc) - } - - and printModuleTypeDeclaration = (modTypeDecl: Parsetree.module_type_declaration, cmtTbl) => { - let modName = { - let doc = Doc.text(modTypeDecl.pmtd_name.txt) - printComments(doc, cmtTbl, modTypeDecl.pmtd_name.loc) - } - - Doc.concat(list{ - printAttributes(modTypeDecl.pmtd_attributes), - Doc.text("module type "), - modName, - switch modTypeDecl.pmtd_type { - | None => Doc.nil - | Some(modType) => Doc.concat(list{Doc.text(" = "), printModType(modType, cmtTbl)}) - }, - }) - } - - and printModType = (modType, cmtTbl) => { - let modTypeDoc = switch modType.pmty_desc { - | Parsetree.Pmty_ident(longident) => - Doc.concat(list{ - printAttributes(~loc=longident.loc, modType.pmty_attributes), - printLongidentLocation(longident, cmtTbl), - }) - | Pmty_signature(signature) => - let signatureDoc = Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.lbrace, - Doc.indent(Doc.concat(list{Doc.line, printSignature(signature, cmtTbl)})), - Doc.line, - Doc.rbrace, - }), - ) - Doc.concat(list{printAttributes(modType.pmty_attributes), signatureDoc}) - | Pmty_functor(_) => - let (parameters, returnType) = ParsetreeViewer.functorType(modType) - let parametersDoc = switch parameters { - | list{} => Doc.nil - | list{(attrs, {Location.txt: "_", loc}, Some(modType))} => - let cmtLoc = {...loc, loc_end: modType.Parsetree.pmty_loc.loc_end} - - let attrs = switch attrs { - | list{} => Doc.nil - | attrs => - Doc.concat(list{Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), Doc.line}) - } - let doc = Doc.concat(list{attrs, printModType(modType, cmtTbl)}) - printComments(doc, cmtTbl, cmtLoc) - | params => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map((( - attrs, - lbl, - modType, - )) => { - let cmtLoc = switch modType { - | None => lbl.Asttypes.loc - | Some(modType) => { - ...lbl.Asttypes.loc, - loc_end: modType.Parsetree.pmty_loc.loc_end, - } - } - - let attrs = switch attrs { - | list{} => Doc.nil - | attrs => - Doc.concat(list{ - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.line, - }) - } - let lblDoc = if lbl.Location.txt == "_" { - Doc.nil - } else { - let doc = Doc.text(lbl.txt) - printComments(doc, cmtTbl, lbl.loc) - } - - let doc = Doc.concat(list{ - attrs, - lblDoc, - switch modType { - | None => Doc.nil - | Some(modType) => - Doc.concat(list{ - if lbl.txt == "_" { - Doc.nil - } else { - Doc.text(": ") - }, - printModType(modType, cmtTbl), - }) - }, - }) - printComments(doc, cmtTbl, cmtLoc) - }, params)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - } - - let returnDoc = { - let doc = printModType(returnType, cmtTbl) - if Parens.modTypeFunctorReturn(returnType) { - addParens(doc) - } else { - doc - } - } - - Doc.group( - Doc.concat(list{ - parametersDoc, - Doc.group(Doc.concat(list{Doc.text(" =>"), Doc.line, returnDoc})), - }), - ) - | Pmty_typeof(modExpr) => - Doc.concat(list{Doc.text("module type of "), printModExpr(modExpr, cmtTbl)}) - | Pmty_extension(extension) => printExtensionWithComments(~atModuleLvl=false, extension, cmtTbl) - | Pmty_alias(longident) => - Doc.concat(list{Doc.text("module "), printLongidentLocation(longident, cmtTbl)}) - | Pmty_with(modType, withConstraints) => - let operand = { - let doc = printModType(modType, cmtTbl) - if Parens.modTypeWithOperand(modType) { - addParens(doc) - } else { - doc - } - } - - Doc.group( - Doc.concat(list{ - operand, - Doc.indent(Doc.concat(list{Doc.line, printWithConstraints(withConstraints, cmtTbl)})), - }), - ) - } - - let attrsAlreadyPrinted = switch modType.pmty_desc { - | Pmty_functor(_) | Pmty_signature(_) | Pmty_ident(_) => true - | _ => false - } - - let doc = Doc.concat(list{ - if attrsAlreadyPrinted { - Doc.nil - } else { - printAttributes(modType.pmty_attributes) - }, - modTypeDoc, - }) - printComments(doc, cmtTbl, modType.pmty_loc) - } - - and printWithConstraints = (withConstraints, cmtTbl) => { - let rows = List.mapi((i, withConstraint) => - Doc.group( - Doc.concat(list{ - if i === 0 { - Doc.text("with ") - } else { - Doc.text("and ") - }, - printWithConstraint(withConstraint, cmtTbl), - }), - ) - , withConstraints) - - Doc.join(~sep=Doc.line, rows) - } - - and printWithConstraint = (withConstraint: Parsetree.with_constraint, cmtTbl) => - switch withConstraint { - /* with type X.t = ... */ - | Pwith_type(longident, typeDeclaration) => - Doc.group( - printTypeDeclaration( - ~name=printLidentPath(longident, cmtTbl), - ~equalSign="=", - ~recFlag=Doc.nil, - 0, - typeDeclaration, - CommentTable.empty, - ), - ) - /* with module X.Y = Z */ - | Pwith_module({txt: longident1}, {txt: longident2}) => - Doc.concat(list{ - Doc.text("module "), - printLongident(longident1), - Doc.text(" ="), - Doc.indent(Doc.concat(list{Doc.line, printLongident(longident2)})), - }) - /* with type X.t := ..., same format as [Pwith_type] */ - | Pwith_typesubst(longident, typeDeclaration) => - Doc.group( - printTypeDeclaration( - ~name=printLidentPath(longident, cmtTbl), - ~equalSign=":=", - ~recFlag=Doc.nil, - 0, - typeDeclaration, - CommentTable.empty, - ), - ) - | Pwith_modsubst({txt: longident1}, {txt: longident2}) => - Doc.concat(list{ - Doc.text("module "), - printLongident(longident1), - Doc.text(" :="), - Doc.indent(Doc.concat(list{Doc.line, printLongident(longident2)})), - }) - } - - and printSignature = (signature, cmtTbl) => - switch signature { - | list{} => printCommentsInside(cmtTbl, Location.none) - | signature => - printList( - ~getLoc=s => s.Parsetree.psig_loc, - ~nodes=signature, - ~print=printSignatureItem, - cmtTbl, - ) - } - - and printSignatureItem = (si: Parsetree.signature_item, cmtTbl) => - switch si.psig_desc { - | Parsetree.Psig_value(valueDescription) => printValueDescription(valueDescription, cmtTbl) - | Psig_type(recFlag, typeDeclarations) => - let recFlag = switch recFlag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - printTypeDeclarations(~recFlag, typeDeclarations, cmtTbl) - | Psig_typext(typeExtension) => printTypeExtension(typeExtension, cmtTbl) - | Psig_exception(extensionConstructor) => printExceptionDef(extensionConstructor, cmtTbl) - | Psig_module(moduleDeclaration) => printModuleDeclaration(moduleDeclaration, cmtTbl) - | Psig_recmodule(moduleDeclarations) => printRecModuleDeclarations(moduleDeclarations, cmtTbl) - | Psig_modtype(modTypeDecl) => printModuleTypeDeclaration(modTypeDecl, cmtTbl) - | Psig_open(openDescription) => printOpenDescription(openDescription, cmtTbl) - | Psig_include(includeDescription) => printIncludeDescription(includeDescription, cmtTbl) - | Psig_attribute(attr) => - Doc.concat(list{Doc.text("@"), printAttributeWithComments(attr, cmtTbl)}) - | Psig_extension(extension, attrs) => - Doc.concat(list{ - printAttributes(attrs), - Doc.concat(list{printExtensionWithComments(~atModuleLvl=true, extension, cmtTbl)}), - }) - | Psig_class(_) | Psig_class_type(_) => Doc.nil - } - - and printRecModuleDeclarations = (moduleDeclarations, cmtTbl) => - printListi( - ~getLoc=n => n.Parsetree.pmd_loc, - ~nodes=moduleDeclarations, - ~print=printRecModuleDeclaration, - cmtTbl, - ) - - and printRecModuleDeclaration = (md, cmtTbl, i) => { - let body = switch md.pmd_type.pmty_desc { - | Parsetree.Pmty_alias(longident) => - Doc.concat(list{Doc.text(" = "), printLongidentLocation(longident, cmtTbl)}) - | _ => - let needsParens = switch md.pmd_type.pmty_desc { - | Pmty_with(_) => true - | _ => false - } - - let modTypeDoc = { - let doc = printModType(md.pmd_type, cmtTbl) - if needsParens { - addParens(doc) - } else { - doc - } - } - - Doc.concat(list{Doc.text(": "), modTypeDoc}) - } - - let prefix = if i < 1 { - "module rec " - } else { - "and " - } - Doc.concat(list{ - printAttributes(~loc=md.pmd_name.loc, md.pmd_attributes), - Doc.text(prefix), - printComments(Doc.text(md.pmd_name.txt), cmtTbl, md.pmd_name.loc), - body, - }) - } - - and printModuleDeclaration = (md: Parsetree.module_declaration, cmtTbl) => { - let body = switch md.pmd_type.pmty_desc { - | Parsetree.Pmty_alias(longident) => - Doc.concat(list{Doc.text(" = "), printLongidentLocation(longident, cmtTbl)}) - | _ => Doc.concat(list{Doc.text(": "), printModType(md.pmd_type, cmtTbl)}) - } - - Doc.concat(list{ - printAttributes(~loc=md.pmd_name.loc, md.pmd_attributes), - Doc.text("module "), - printComments(Doc.text(md.pmd_name.txt), cmtTbl, md.pmd_name.loc), - body, - }) - } - - and printOpenDescription = (openDescription: Parsetree.open_description, p) => - Doc.concat(list{ - printAttributes(openDescription.popen_attributes), - Doc.text("open"), - switch openDescription.popen_override { - | Asttypes.Fresh => Doc.space - | Asttypes.Override => Doc.text("! ") - }, - printLongidentLocation(openDescription.popen_lid, p), - }) - - and printIncludeDescription = (includeDescription: Parsetree.include_description, cmtTbl) => - Doc.concat(list{ - printAttributes(includeDescription.pincl_attributes), - Doc.text("include "), - printModType(includeDescription.pincl_mod, cmtTbl), - }) - - and printIncludeDeclaration = (includeDeclaration: Parsetree.include_declaration, cmtTbl) => { - let isJsFfiImport = List.exists(attr => - switch attr { - | ({Location.txt: "ns.jsFfi"}, _) => true - | _ => false - } - , includeDeclaration.pincl_attributes) - - if isJsFfiImport { - printJsFfiImportDeclaration(includeDeclaration, cmtTbl) - } else { - Doc.concat(list{ - printAttributes(includeDeclaration.pincl_attributes), - Doc.text("include "), - { - let includeDoc = printModExpr(includeDeclaration.pincl_mod, cmtTbl) - - if Parens.includeModExpr(includeDeclaration.pincl_mod) { - addParens(includeDoc) - } else { - includeDoc - } - }, - }) - } - } - - and printJsFfiImport = (valueDescription: Parsetree.value_description, cmtTbl) => { - let attrs = List.filter(attr => - switch attr { - | ({Location.txt: "bs.val" | "genType.import" | "bs.scope"}, _) => false - | _ => true - } - , valueDescription.pval_attributes) - let (ident, alias) = switch valueDescription.pval_prim { - | list{primitive, ..._} => - if primitive != valueDescription.pval_name.txt { - ( - printIdentLike(primitive), - Doc.concat(list{Doc.text(" as "), printIdentLike(valueDescription.pval_name.txt)}), - ) - } else { - (printIdentLike(primitive), Doc.nil) - } - | _ => (printIdentLike(valueDescription.pval_name.txt), Doc.nil) - } - - Doc.concat(list{ - printAttributes(~loc=valueDescription.pval_name.loc, attrs), - ident, - alias, - Doc.text(": "), - printTypExpr(valueDescription.pval_type, cmtTbl), - }) - } - - and printJsFfiImportScope = (scope: ParsetreeViewer.jsImportScope) => - switch scope { - | JsGlobalImport => Doc.nil - | JsModuleImport(modName) => - Doc.concat(list{Doc.text(" from "), Doc.doubleQuote, Doc.text(modName), Doc.doubleQuote}) - | JsScopedImport(idents) => - Doc.concat(list{Doc.text(" from "), Doc.join(~sep=Doc.dot, List.map(Doc.text, idents))}) - } - - and printJsFfiImportDeclaration = (includeDeclaration: Parsetree.include_declaration, cmtTbl) => { - let attrs = List.filter(attr => - switch attr { - | ({Location.txt: "ns.jsFfi"}, _) => false - | _ => true - } - , includeDeclaration.pincl_attributes) - - let imports = ParsetreeViewer.extractValueDescriptionFromModExpr(includeDeclaration.pincl_mod) - let scope = switch imports { - | list{vd, ..._} => ParsetreeViewer.classifyJsImport(vd) - | list{} => ParsetreeViewer.JsGlobalImport - } - - let scopeDoc = printJsFfiImportScope(scope) - Doc.group( - Doc.concat(list{ - printAttributes(attrs), - Doc.text("import "), - Doc.group( - Doc.concat(list{ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(vd => printJsFfiImport(vd, cmtTbl), imports), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - }), - ), - scopeDoc, - }), - ) - } - - and printValueBindings = (~recFlag, vbs: list, cmtTbl) => - printListi( - ~getLoc=vb => vb.Parsetree.pvb_loc, - ~nodes=vbs, - ~print=printValueBinding(~recFlag), - cmtTbl, - ) - - and printValueDescription = (valueDescription, cmtTbl) => { - let isExternal = switch valueDescription.pval_prim { - | list{} => false - | _ => true - } - - Doc.group( - Doc.concat(list{ - printAttributes(valueDescription.pval_attributes), - Doc.text( - if isExternal { - "external " - } else { - "let " - }, - ), - printComments( - printIdentLike(valueDescription.pval_name.txt), - cmtTbl, - valueDescription.pval_name.loc, - ), - Doc.text(": "), - printTypExpr(valueDescription.pval_type, cmtTbl), - if isExternal { - Doc.group( - Doc.concat(list{ - Doc.text(" ="), - Doc.indent( - Doc.concat(list{ - Doc.line, - Doc.join( - ~sep=Doc.line, - List.map( - s => Doc.concat(list{Doc.text("\""), Doc.text(s), Doc.text("\"")}), - valueDescription.pval_prim, - ), - ), - }), - ), - }), - ) - } else { - Doc.nil - }, - }), - ) - } - - and printTypeDeclarations = (~recFlag, typeDeclarations, cmtTbl) => - printListi( - ~getLoc=n => n.Parsetree.ptype_loc, - ~nodes=typeDeclarations, - ~print=printTypeDeclaration2(~recFlag), - cmtTbl, - ) - - /* - * type_declaration = { - * ptype_name: string loc; - * ptype_params: (core_type * variance) list; - * (* ('a1,...'an) t; None represents _*) - * ptype_cstrs: (core_type * core_type * Location.t) list; - * (* ... constraint T1=T1' ... constraint Tn=Tn' *) - * ptype_kind: type_kind; - * ptype_private: private_flag; (* = private ... *) - * ptype_manifest: core_type option; (* = T *) - * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - * ptype_loc: Location.t; - * } - * - * - * type t (abstract, no manifest) - * type t = T0 (abstract, manifest=T0) - * type t = C of T | ... (variant, no manifest) - * type t = T0 = C of T | ... (variant, manifest=T0) - * type t = {l: T; ...} (record, no manifest) - * type t = T0 = {l : T; ...} (record, manifest=T0) - * type t = .. (open, no manifest) - * - * - * and type_kind = - * | Ptype_abstract - * | Ptype_variant of constructor_declaration list - * (* Invariant: non-empty list *) - * | Ptype_record of label_declaration list - * (* Invariant: non-empty list *) - * | Ptype_open - */ - and printTypeDeclaration = ( - ~name, - ~equalSign, - ~recFlag, - i, - td: Parsetree.type_declaration, - cmtTbl, - ) => { - let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr(td.ptype_attributes) - let attrs = printAttributes(~loc=td.ptype_loc, attrs) - let prefix = if i > 0 { - Doc.concat(list{ - Doc.text("and "), - if hasGenType { - Doc.text("export ") - } else { - Doc.nil - }, - }) - } else { - Doc.concat(list{ - Doc.text( - if hasGenType { - "export type " - } else { - "type " - }, - ), - recFlag, - }) - } - - let typeName = name - let typeParams = printTypeParams(td.ptype_params, cmtTbl) - let manifestAndKind = switch td.ptype_kind { - | Ptype_abstract => - switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printPrivateFlag(td.ptype_private), - printTypExpr(typ, cmtTbl), - }) - } - | Ptype_open => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printPrivateFlag(td.ptype_private), - Doc.text(".."), - }) - | Ptype_record(lds) => - let manifest = switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printTypExpr(typ, cmtTbl), - }) - } - - Doc.concat(list{ - manifest, - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printPrivateFlag(td.ptype_private), - printRecordDeclaration(lds, cmtTbl), - }) - | Ptype_variant(cds) => - let manifest = switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printTypExpr(typ, cmtTbl), - }) - } - - Doc.concat(list{ - manifest, - Doc.concat(list{Doc.space, Doc.text(equalSign)}), - printConstructorDeclarations(~privateFlag=td.ptype_private, cds, cmtTbl), - }) - } - - let constraints = printTypeDefinitionConstraints(td.ptype_cstrs) - Doc.group(Doc.concat(list{attrs, prefix, typeName, typeParams, manifestAndKind, constraints})) - } - - and printTypeDeclaration2 = (~recFlag, td: Parsetree.type_declaration, cmtTbl, i) => { - let name = { - let doc = printIdentLike(td.Parsetree.ptype_name.txt) - printComments(doc, cmtTbl, td.ptype_name.loc) - } - - let equalSign = "=" - let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr(td.ptype_attributes) - let attrs = printAttributes(~loc=td.ptype_loc, attrs) - let prefix = if i > 0 { - Doc.concat(list{ - Doc.text("and "), - if hasGenType { - Doc.text("export ") - } else { - Doc.nil - }, - }) - } else { - Doc.concat(list{ - Doc.text( - if hasGenType { - "export type " - } else { - "type " - }, - ), - recFlag, - }) - } - - let typeName = name - let typeParams = printTypeParams(td.ptype_params, cmtTbl) - let manifestAndKind = switch td.ptype_kind { - | Ptype_abstract => - switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printPrivateFlag(td.ptype_private), - printTypExpr(typ, cmtTbl), - }) - } - | Ptype_open => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printPrivateFlag(td.ptype_private), - Doc.text(".."), - }) - | Ptype_record(lds) => - let manifest = switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printTypExpr(typ, cmtTbl), - }) - } - - Doc.concat(list{ - manifest, - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printPrivateFlag(td.ptype_private), - printRecordDeclaration(lds, cmtTbl), - }) - | Ptype_variant(cds) => - let manifest = switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list{ - Doc.concat(list{Doc.space, Doc.text(equalSign), Doc.space}), - printTypExpr(typ, cmtTbl), - }) - } - - Doc.concat(list{ - manifest, - Doc.concat(list{Doc.space, Doc.text(equalSign)}), - printConstructorDeclarations(~privateFlag=td.ptype_private, cds, cmtTbl), - }) - } - - let constraints = printTypeDefinitionConstraints(td.ptype_cstrs) - Doc.group(Doc.concat(list{attrs, prefix, typeName, typeParams, manifestAndKind, constraints})) - } - - and printTypeDefinitionConstraints = cstrs => - switch cstrs { - | list{} => Doc.nil - | cstrs => - Doc.indent( - Doc.group( - Doc.concat(list{ - Doc.line, - Doc.group(Doc.join(~sep=Doc.line, List.map(printTypeDefinitionConstraint, cstrs))), - }), - ), - ) - } - - and printTypeDefinitionConstraint = ( - (typ1, typ2, _loc): (Parsetree.core_type, Parsetree.core_type, Location.t), - ) => - Doc.concat(list{ - Doc.text("constraint "), - printTypExpr(typ1, CommentTable.empty), - Doc.text(" = "), - printTypExpr(typ2, CommentTable.empty), - }) - - and printPrivateFlag = (flag: Asttypes.private_flag) => - switch flag { - | Private => Doc.text("private ") - | Public => Doc.nil - } - - and printTypeParams = (typeParams, cmtTbl) => - switch typeParams { - | list{} => Doc.nil - | typeParams => - Doc.group( - Doc.concat(list{ - Doc.lessThan, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(typeParam => { - let doc = printTypeParam(typeParam, cmtTbl) - printComments(doc, cmtTbl, fst(typeParam).Parsetree.ptyp_loc) - }, typeParams)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.greaterThan, - }), - ) - } - - and printTypeParam = (param: (Parsetree.core_type, Asttypes.variance), cmtTbl) => { - let (typ, variance) = param - let printedVariance = switch variance { - | Covariant => Doc.text("+") - | Contravariant => Doc.text("-") - | Invariant => Doc.nil - } - - Doc.concat(list{printedVariance, printTypExpr(typ, cmtTbl)}) - } - - and printRecordDeclaration = (lds: list, cmtTbl) => { - let forceBreak = switch (lds, List.rev(lds)) { - | (list{first, ..._}, list{last, ..._}) => - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum - | _ => false - } - - Doc.breakableGroup( - ~forceBreak, - Doc.concat(list{ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(ld => { - let doc = printLabelDeclaration(ld, cmtTbl) - printComments(doc, cmtTbl, ld.Parsetree.pld_loc) - }, lds)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - }), - ) - } - - and printConstructorDeclarations = ( - ~privateFlag, - cds: list, - cmtTbl, - ) => { - let forceBreak = switch (cds, List.rev(cds)) { - | (list{first, ..._}, list{last, ..._}) => - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum - | _ => false - } - - let privateFlag = switch privateFlag { - | Asttypes.Private => Doc.concat(list{Doc.text("private"), Doc.line}) - | Public => Doc.nil - } - - let rows = printListi( - ~getLoc=cd => cd.Parsetree.pcd_loc, - ~nodes=cds, - ~print=(cd, cmtTbl, i) => { - let doc = printConstructorDeclaration2(i, cd, cmtTbl) - printComments(doc, cmtTbl, cd.Parsetree.pcd_loc) - }, - ~forceBreak, - cmtTbl, - ) - - Doc.breakableGroup(~forceBreak, Doc.indent(Doc.concat(list{Doc.line, privateFlag, rows}))) - } - - and printConstructorDeclaration2 = (i, cd: Parsetree.constructor_declaration, cmtTbl) => { - let attrs = printAttributes(cd.pcd_attributes) - let bar = if i > 0 { - Doc.text("| ") - } else { - Doc.ifBreaks(Doc.text("| "), Doc.nil) - } - - let constrName = { - let doc = Doc.text(cd.pcd_name.txt) - printComments(doc, cmtTbl, cd.pcd_name.loc) - } - - let constrArgs = printConstructorArguments(~indent=true, cd.pcd_args, cmtTbl) - let gadt = switch cd.pcd_res { - | None => Doc.nil - | Some(typ) => Doc.indent(Doc.concat(list{Doc.text(": "), printTypExpr(typ, cmtTbl)})) - } - - Doc.concat(list{ - bar, - Doc.group( - Doc.concat(list{ - attrs /* TODO: fix parsing of attributes, so when can print them above the bar? */, - constrName, - constrArgs, - gadt, - }), - ), - }) - } - - and printConstructorArguments = (~indent, cdArgs: Parsetree.constructor_arguments, cmtTbl) => - switch cdArgs { - | Pcstr_tuple(list{}) => Doc.nil - | Pcstr_tuple(types) => - let args = Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(typexpr => printTypExpr(typexpr, cmtTbl), types), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }) - Doc.group( - if indent { - Doc.indent(args) - } else { - args - }, - ) - | Pcstr_record(lds) => - let args = Doc.concat(list{ - Doc.lparen, - /* manually inline the printRecordDeclaration, gives better layout */ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(ld => { - let doc = printLabelDeclaration(ld, cmtTbl) - printComments(doc, cmtTbl, ld.Parsetree.pld_loc) - }, lds)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - Doc.rparen, - }) - if indent { - Doc.indent(args) - } else { - args - } - } - - and printLabelDeclaration = (ld: Parsetree.label_declaration, cmtTbl) => { - let attrs = printAttributes(~loc=ld.pld_name.loc, ld.pld_attributes) - let mutableFlag = switch ld.pld_mutable { - | Mutable => Doc.text("mutable ") - | Immutable => Doc.nil - } - - let name = { - let doc = printIdentLike(ld.pld_name.txt) - printComments(doc, cmtTbl, ld.pld_name.loc) - } - - Doc.group( - Doc.concat(list{attrs, mutableFlag, name, Doc.text(": "), printTypExpr(ld.pld_type, cmtTbl)}), - ) - } - - and printTypExpr = (typExpr: Parsetree.core_type, cmtTbl) => { - let renderedType = switch typExpr.ptyp_desc { - | Ptyp_any => Doc.text("_") - | Ptyp_var(var) => Doc.concat(list{Doc.text("'"), printIdentLike(var)}) - | Ptyp_extension(extension) => printExtensionWithComments(~atModuleLvl=false, extension, cmtTbl) - | Ptyp_alias(typ, alias) => - let typ = { - /* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning. */ - let needsParens = switch typ.ptyp_desc { - | Ptyp_arrow(_) => true - | _ => false - } - - let doc = printTypExpr(typ, cmtTbl) - if needsParens { - Doc.concat(list{Doc.lparen, doc, Doc.rparen}) - } else { - doc - } - } - - Doc.concat(list{ - typ, - Doc.text(" as "), - Doc.concat(list{Doc.text("'"), printIdentLike(alias)}), - }) - | Ptyp_constr( - {txt: Longident.Ldot(Longident.Lident("Js"), "t")}, - list{{ptyp_desc: Ptyp_object(_fields, _openFlag)} as typ}, - ) => - let bsObject = printTypExpr(typ, cmtTbl) - switch typExpr.ptyp_attributes { - | list{} => bsObject - | attrs => - Doc.concat(list{ - Doc.group(Doc.join(~sep=Doc.line, List.map(printAttribute, attrs))), - Doc.space, - printTypExpr(typ, cmtTbl), - }) - } - | Ptyp_constr(longidentLoc, list{{ptyp_desc: Parsetree.Ptyp_tuple(tuple)}}) => - let constrName = printLidentPath(longidentLoc, cmtTbl) - Doc.group( - Doc.concat(list{ - constrName, - Doc.lessThan, - printTupleType(~inline=true, tuple, cmtTbl), - Doc.greaterThan, - }), - ) - | Ptyp_constr(longidentLoc, constrArgs) => - let constrName = printLidentPath(longidentLoc, cmtTbl) - switch constrArgs { - | list{} => constrName - | list{{ - Parsetree.ptyp_desc: - Ptyp_constr( - {txt: Longident.Ldot(Longident.Lident("Js"), "t")}, - list{{ptyp_desc: Ptyp_object(fields, openFlag)}}, - ), - }} => - Doc.concat(list{ - constrName, - Doc.lessThan, - printBsObjectSugar(~inline=true, fields, openFlag, cmtTbl), - Doc.greaterThan, - }) - | _args => - Doc.group( - Doc.concat(list{ - constrName, - Doc.lessThan, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(typexpr => printTypExpr(typexpr, cmtTbl), constrArgs), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.greaterThan, - }), - ) - } - | Ptyp_arrow(_) => - let (attrsBefore, args, returnType) = ParsetreeViewer.arrowType(typExpr) - let returnTypeNeedsParens = switch returnType.ptyp_desc { - | Ptyp_alias(_) => true - | _ => false - } - - let returnDoc = { - let doc = printTypExpr(returnType, cmtTbl) - if returnTypeNeedsParens { - Doc.concat(list{Doc.lparen, doc, Doc.rparen}) - } else { - doc - } - } - - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute(attrsBefore) - - switch args { - | list{} => Doc.nil - | list{(list{}, Nolabel, n)} when !isUncurried => - let hasAttrsBefore = !(attrs == list{}) - let attrs = if hasAttrsBefore { - Doc.concat(list{ - Doc.join(~sep=Doc.line, List.map(printAttribute, attrsBefore)), - Doc.space, - }) - } else { - Doc.nil - } - - let typDoc = { - let doc = printTypExpr(n, cmtTbl) - switch n.ptyp_desc { - | Ptyp_arrow(_) | Ptyp_tuple(_) => addParens(doc) - | _ => doc - } - } - - Doc.group( - Doc.concat(list{ - Doc.group(attrs), - Doc.group( - if hasAttrsBefore { - Doc.concat(list{ - Doc.lparen, - Doc.indent(Doc.concat(list{Doc.softLine, typDoc, Doc.text(" => "), returnDoc})), - Doc.softLine, - Doc.rparen, - }) - } else { - Doc.concat(list{typDoc, Doc.text(" => "), returnDoc}) - }, - ), - }), - ) - | args => - let attrs = switch attrs { - | list{} => Doc.nil - | attrs => - Doc.concat(list{Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), Doc.space}) - } - - let renderedArgs = Doc.concat(list{ - attrs, - Doc.text("("), - Doc.indent( - Doc.concat(list{ - Doc.softLine, - if isUncurried { - Doc.concat(list{Doc.dot, Doc.space}) - } else { - Doc.nil - }, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(tp => printTypeParameter(tp, cmtTbl), args), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.text(")"), - }) - Doc.group(Doc.concat(list{renderedArgs, Doc.text(" => "), returnDoc})) - } - | Ptyp_tuple(types) => printTupleType(~inline=false, types, cmtTbl) - | Ptyp_object(fields, openFlag) => printBsObjectSugar(~inline=false, fields, openFlag, cmtTbl) - | Ptyp_poly(list{}, typ) => printTypExpr(typ, cmtTbl) - | Ptyp_poly(stringLocs, typ) => Doc.concat(list{Doc.join(~sep=Doc.space, List.map(({ - Location.txt: txt, - loc, - }) => { - let doc = Doc.concat(list{Doc.text("'"), Doc.text(txt)}) - printComments(doc, cmtTbl, loc) - }, stringLocs)), Doc.dot, Doc.space, printTypExpr(typ, cmtTbl)}) - | Ptyp_package(packageType) => - printPackageType(~printModuleKeywordAndParens=true, packageType, cmtTbl) - | Ptyp_class(_) => Doc.text("classes are not supported in types") - | Ptyp_variant(rowFields, closedFlag, labelsOpt) => - let printRowField = x => - switch x { - | Parsetree.Rtag({txt}, attrs, true, list{}) => - Doc.concat(list{ - printAttributes(attrs), - Doc.concat(list{Doc.text("#"), printIdentLike(~allowUident=true, txt)}), - }) - | Rtag({txt}, attrs, truth, types) => - let doType = t => - switch t.Parsetree.ptyp_desc { - | Ptyp_tuple(_) => printTypExpr(t, cmtTbl) - | _ => Doc.concat(list{Doc.lparen, printTypExpr(t, cmtTbl), Doc.rparen}) - } - - let printedTypes = List.map(doType, types) - let cases = Doc.join(~sep=Doc.concat(list{Doc.line, Doc.text("& ")}), printedTypes) - let cases = if truth { - Doc.concat(list{Doc.line, Doc.text("& "), cases}) - } else { - cases - } - Doc.group( - Doc.concat(list{ - printAttributes(attrs), - Doc.concat(list{Doc.text("#"), printIdentLike(~allowUident=true, txt)}), - cases, - }), - ) - | Rinherit(coreType) => printTypExpr(coreType, cmtTbl) - } - - let docs = List.map(printRowField, rowFields) - let cases = Doc.join(~sep=Doc.concat(list{Doc.line, Doc.text("| ")}), docs) - let cases = if docs == list{} { - cases - } else { - Doc.concat(list{Doc.text("| "), cases}) - } - let openingSymbol = if closedFlag == Open { - Doc.greaterThan - } else if labelsOpt == None { - Doc.nil - } else { - Doc.lessThan - } - let hasLabels = labelsOpt != None && labelsOpt != Some(list{}) - let labels = switch labelsOpt { - | None | Some(list{}) => Doc.nil - | Some(labels) => - Doc.concat( - List.map( - label => - Doc.concat(list{Doc.line, Doc.text("#"), printIdentLike(~allowUident=true, label)}), - labels, - ), - ) - } - - let closingSymbol = if hasLabels { - Doc.text(" >") - } else { - Doc.nil - } - Doc.group( - Doc.concat(list{ - Doc.lbracket, - openingSymbol, - Doc.line, - cases, - closingSymbol, - labels, - Doc.line, - Doc.rbracket, - }), - ) - } - - let shouldPrintItsOwnAttributes = switch typExpr.ptyp_desc { - | Ptyp_arrow(_) /* es6 arrow types print their own attributes */ - | Ptyp_constr({txt: Longident.Ldot(Longident.Lident("Js"), "t")}, _) => true - | _ => false - } - - let doc = switch typExpr.ptyp_attributes { - | list{_, ..._} as attrs when !shouldPrintItsOwnAttributes => - Doc.group(Doc.concat(list{printAttributes(attrs), renderedType})) - | _ => renderedType - } - - printComments(doc, cmtTbl, typExpr.ptyp_loc) - } - - and printBsObjectSugar = (~inline, fields, openFlag, cmtTbl) => { - let doc = switch fields { - | list{} => - Doc.concat(list{ - Doc.lbrace, - switch openFlag { - | Asttypes.Closed => Doc.dot - | Open => Doc.dotdot - }, - Doc.rbrace, - }) - | fields => - Doc.concat(list{ - Doc.lbrace, - switch openFlag { - | Asttypes.Closed => Doc.nil - | Open => Doc.dotdot - }, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(field => printObjectField(field, cmtTbl), fields), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - }) - } - - if inline { - doc - } else { - Doc.group(doc) - } - } - - and printTupleType = (~inline, types: list, cmtTbl) => { - let tuple = Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(typexpr => printTypExpr(typexpr, cmtTbl), types), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }) - - if inline === false { - Doc.group(tuple) - } else { - tuple - } - } - - and printObjectField = (field: Parsetree.object_field, cmtTbl) => - switch field { - | Otag(labelLoc, attrs, typ) => - let lbl = { - let doc = Doc.text("\"" ++ (labelLoc.txt ++ "\"")) - printComments(doc, cmtTbl, labelLoc.loc) - } - - let doc = Doc.concat(list{ - printAttributes(~loc=labelLoc.loc, attrs), - lbl, - Doc.text(": "), - printTypExpr(typ, cmtTbl), - }) - let cmtLoc = {...labelLoc.loc, loc_end: typ.ptyp_loc.loc_end} - printComments(doc, cmtTbl, cmtLoc) - | _ => Doc.nil - } - - /* es6 arrow type arg - * type t = (~foo: string, ~bar: float=?, unit) => unit - * i.e. ~foo: string, ~bar: float */ - and printTypeParameter = ((attrs, lbl, typ), cmtTbl) => { - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute(attrs) - let uncurried = if isUncurried { - Doc.concat(list{Doc.dot, Doc.space}) - } else { - Doc.nil - } - let attrs = switch attrs { - | list{} => Doc.nil - | attrs => Doc.concat(list{Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), Doc.line}) - } - let label = switch lbl { - | Asttypes.Nolabel => Doc.nil - | Labelled(lbl) => Doc.concat(list{Doc.text("~"), printIdentLike(lbl), Doc.text(": ")}) - | Optional(lbl) => Doc.concat(list{Doc.text("~"), printIdentLike(lbl), Doc.text(": ")}) - } - - let optionalIndicator = switch lbl { - | Asttypes.Nolabel | Labelled(_) => Doc.nil - | Optional(_lbl) => Doc.text("=?") - } - - let doc = Doc.group( - Doc.concat(list{uncurried, attrs, label, printTypExpr(typ, cmtTbl), optionalIndicator}), - ) - printComments(doc, cmtTbl, typ.ptyp_loc) - } - - and printValueBinding = (~recFlag, vb, cmtTbl, i) => { - let (hasGenType, attrs) = ParsetreeViewer.splitGenTypeAttr(vb.pvb_attributes) - let attrs = printAttributes(~loc=vb.pvb_pat.ppat_loc, attrs) - let header = if i === 0 { - Doc.concat(list{ - if hasGenType { - Doc.text("export ") - } else { - Doc.text("let ") - }, - recFlag, - }) - } else { - Doc.concat(list{ - Doc.text("and "), - if hasGenType { - Doc.text("export ") - } else { - Doc.nil - }, - }) - } - - switch vb { - | { - pvb_pat: {ppat_desc: Ppat_constraint(pattern, {ptyp_desc: Ptyp_poly(_)})}, - pvb_expr: {pexp_desc: Pexp_newtype(_)} as expr, - } => - let (_attrs, parameters, returnExpr) = ParsetreeViewer.funExpr(expr) - let abstractType = switch parameters { - | list{NewTypes({locs: vars})} => - Doc.concat(list{ - Doc.text("type "), - Doc.join(~sep=Doc.space, List.map(var => Doc.text(var.Asttypes.txt), vars)), - Doc.dot, - }) - | _ => Doc.nil - } - - switch returnExpr.pexp_desc { - | Pexp_constraint(expr, typ) => - Doc.group( - Doc.concat(list{ - attrs, - header, - printPattern(pattern, cmtTbl), - Doc.text(":"), - Doc.indent( - Doc.concat(list{ - Doc.line, - abstractType, - Doc.space, - printTypExpr(typ, cmtTbl), - Doc.text(" ="), - Doc.concat(list{Doc.line, printExpressionWithComments(expr, cmtTbl)}), - }), - ), - }), - ) - | _ => Doc.nil - } - | _ => - let (optBraces, expr) = ParsetreeViewer.processBracesAttr(vb.pvb_expr) - let printedExpr = { - let doc = printExpressionWithComments(vb.pvb_expr, cmtTbl) - switch Parens.expr(vb.pvb_expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - if ParsetreeViewer.isPipeExpr(vb.pvb_expr) { - Doc.customLayout(list{ - Doc.group( - Doc.concat(list{ - attrs, - header, - printPattern(vb.pvb_pat, cmtTbl), - Doc.text(" ="), - Doc.space, - printedExpr, - }), - ), - Doc.group( - Doc.concat(list{ - attrs, - header, - printPattern(vb.pvb_pat, cmtTbl), - Doc.text(" ="), - Doc.indent(Doc.concat(list{Doc.line, printedExpr})), - }), - ), - }) - } else { - let shouldIndent = switch optBraces { - | Some(_) => false - | _ => - ParsetreeViewer.isBinaryExpression(expr) || - switch vb.pvb_expr { - | { - pexp_attributes: list{({Location.txt: "res.ternary"}, _)}, - pexp_desc: Pexp_ifthenelse(ifExpr, _, _), - } => - ParsetreeViewer.isBinaryExpression(ifExpr) || - ParsetreeViewer.hasAttributes(ifExpr.pexp_attributes) - | {pexp_desc: Pexp_newtype(_)} => false - | e => - ParsetreeViewer.hasAttributes(e.pexp_attributes) || ParsetreeViewer.isArrayAccess(e) - } - } - - Doc.group( - Doc.concat(list{ - attrs, - header, - printPattern(vb.pvb_pat, cmtTbl), - Doc.text(" ="), - if shouldIndent { - Doc.indent(Doc.concat(list{Doc.line, printedExpr})) - } else { - Doc.concat(list{Doc.space, printedExpr}) - }, - }), - ) - } - } - } - - and printPackageType = ( - ~printModuleKeywordAndParens, - packageType: Parsetree.package_type, - cmtTbl, - ) => { - let doc = switch packageType { - | (longidentLoc, list{}) => - Doc.group(Doc.concat(list{printLongidentLocation(longidentLoc, cmtTbl)})) - | (longidentLoc, packageConstraints) => - Doc.group( - Doc.concat(list{ - printLongidentLocation(longidentLoc, cmtTbl), - printPackageConstraints(packageConstraints, cmtTbl), - Doc.softLine, - }), - ) - } - - if printModuleKeywordAndParens { - Doc.concat(list{Doc.text("module("), doc, Doc.rparen}) - } else { - doc - } - } - - and printPackageConstraints = (packageConstraints, cmtTbl) => - Doc.concat(list{ - Doc.text(" with"), - Doc.indent(Doc.concat(list{Doc.line, Doc.join(~sep=Doc.line, List.mapi((i, pc) => { - let (longident, typexpr) = pc - let cmtLoc = { - ...longident.Asttypes.loc, - loc_end: typexpr.Parsetree.ptyp_loc.loc_end, - } - let doc = printPackageConstraint(i, cmtTbl, pc) - printComments(doc, cmtTbl, cmtLoc) - }, packageConstraints))})), - }) - - and printPackageConstraint = (i, cmtTbl, (longidentLoc, typ)) => { - let prefix = if i === 0 { - Doc.text("type ") - } else { - Doc.text("and type ") - } - Doc.concat(list{ - prefix, - printLongidentLocation(longidentLoc, cmtTbl), - Doc.text(" = "), - printTypExpr(typ, cmtTbl), - }) - } - - and printExtensionWithComments = (~atModuleLvl, (stringLoc, payload), cmtTbl) => { - let extName = { - let doc = Doc.concat(list{ - Doc.text("%"), - if atModuleLvl { - Doc.text("%") - } else { - Doc.nil - }, - Doc.text(stringLoc.Location.txt), - }) - printComments(doc, cmtTbl, stringLoc.Location.loc) - } - - switch payload { - | Parsetree.PStr(list{{pstr_desc: Pstr_eval(expr, attrs)}}) => - let exprDoc = printExpressionWithComments(expr, cmtTbl) - let needsParens = switch attrs { - | list{} => false - | _ => true - } - Doc.group( - Doc.concat(list{ - extName, - addParens( - Doc.concat(list{ - printAttributes(attrs), - if needsParens { - addParens(exprDoc) - } else { - exprDoc - }, - }), - ), - }), - ) - | _ => extName - } - } - - and printPattern = (p: Parsetree.pattern, cmtTbl) => { - let patternWithoutAttributes = switch p.ppat_desc { - | Ppat_any => Doc.text("_") - | Ppat_var(var) => printIdentLike(var.txt) - | Ppat_constant(c) => printConstant(c) - | Ppat_tuple(patterns) => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.text(","), Doc.line}), - List.map(pat => printPattern(pat, cmtTbl), patterns), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - | Ppat_array(list{}) => - Doc.concat(list{Doc.lbracket, printCommentsInside(cmtTbl, p.ppat_loc), Doc.rbracket}) - | Ppat_array(patterns) => - Doc.group( - Doc.concat(list{ - Doc.text("["), - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.text(","), Doc.line}), - List.map(pat => printPattern(pat, cmtTbl), patterns), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.text("]"), - }), - ) - | Ppat_construct({txt: Longident.Lident("()")}, _) => - Doc.concat(list{Doc.lparen, printCommentsInside(cmtTbl, p.ppat_loc), Doc.rparen}) - | Ppat_construct({txt: Longident.Lident("[]")}, _) => - Doc.concat(list{Doc.text("list["), printCommentsInside(cmtTbl, p.ppat_loc), Doc.rbracket}) - | Ppat_construct({txt: Longident.Lident("::")}, _) => - let (patterns, tail) = ParsetreeViewer.collectPatternsFromListConstruct(list{}, p) - let shouldHug = switch (patterns, tail) { - | (list{pat}, {ppat_desc: Ppat_construct({txt: Longident.Lident("[]")}, _)}) - when ParsetreeViewer.isHuggablePattern(pat) => true - | _ => false - } - - let children = Doc.concat(list{ - if shouldHug { - Doc.nil - } else { - Doc.softLine - }, - Doc.join( - ~sep=Doc.concat(list{Doc.text(","), Doc.line}), - List.map(pat => printPattern(pat, cmtTbl), patterns), - ), - switch tail.Parsetree.ppat_desc { - | Ppat_construct({txt: Longident.Lident("[]")}, _) => Doc.nil - | _ => - let doc = Doc.concat(list{Doc.text("..."), printPattern(tail, cmtTbl)}) - let tail = printComments(doc, cmtTbl, tail.ppat_loc) - Doc.concat(list{Doc.text(","), Doc.line, tail}) - }, - }) - Doc.group( - Doc.concat(list{ - Doc.text("list["), - if shouldHug { - children - } else { - Doc.concat(list{ - Doc.indent(children), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - }) - }, - Doc.rbracket, - }), - ) - | Ppat_construct(constrName, constructorArgs) => - let constrName = printLongident(constrName.txt) - let argsDoc = switch constructorArgs { - | None => Doc.nil - | Some({ppat_loc, ppat_desc: Ppat_construct({txt: Longident.Lident("()")}, _)}) => - Doc.concat(list{Doc.lparen, printCommentsInside(cmtTbl, ppat_loc), Doc.rparen}) - | Some({ppat_desc: Ppat_tuple(list{}), ppat_loc: loc}) => - Doc.concat(list{Doc.lparen, Doc.softLine, printCommentsInside(cmtTbl, loc), Doc.rparen}) - /* Some((1, 2) */ - | Some({ppat_desc: Ppat_tuple(list{{ppat_desc: Ppat_tuple(_)} as arg})}) => - Doc.concat(list{Doc.lparen, printPattern(arg, cmtTbl), Doc.rparen}) - | Some({ppat_desc: Ppat_tuple(patterns)}) => - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(pat => printPattern(pat, cmtTbl), patterns), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }) - | Some(arg) => - let argDoc = printPattern(arg, cmtTbl) - let shouldHug = ParsetreeViewer.isHuggablePattern(arg) - Doc.concat(list{ - Doc.lparen, - if shouldHug { - argDoc - } else { - Doc.concat(list{ - Doc.indent(Doc.concat(list{Doc.softLine, argDoc})), - Doc.trailingComma, - Doc.softLine, - }) - }, - Doc.rparen, - }) - } - - Doc.group(Doc.concat(list{constrName, argsDoc})) - | Ppat_variant(label, None) => - Doc.concat(list{Doc.text("#"), printIdentLike(~allowUident=true, label)}) - | Ppat_variant(label, variantArgs) => - let variantName = Doc.concat(list{Doc.text("#"), printIdentLike(~allowUident=true, label)}) - let argsDoc = switch variantArgs { - | None => Doc.nil - | Some({ppat_desc: Ppat_construct({txt: Longident.Lident("()")}, _)}) => Doc.text("()") - | Some({ppat_desc: Ppat_tuple(list{}), ppat_loc: loc}) => - Doc.concat(list{Doc.lparen, Doc.softLine, printCommentsInside(cmtTbl, loc), Doc.rparen}) - /* Some((1, 2) */ - | Some({ppat_desc: Ppat_tuple(list{{ppat_desc: Ppat_tuple(_)} as arg})}) => - Doc.concat(list{Doc.lparen, printPattern(arg, cmtTbl), Doc.rparen}) - | Some({ppat_desc: Ppat_tuple(patterns)}) => - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(pat => printPattern(pat, cmtTbl), patterns), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }) - | Some(arg) => - let argDoc = printPattern(arg, cmtTbl) - let shouldHug = ParsetreeViewer.isHuggablePattern(arg) - Doc.concat(list{ - Doc.lparen, - if shouldHug { - argDoc - } else { - Doc.concat(list{ - Doc.indent(Doc.concat(list{Doc.softLine, argDoc})), - Doc.trailingComma, - Doc.softLine, - }) - }, - Doc.rparen, - }) - } - - Doc.group(Doc.concat(list{variantName, argsDoc})) - | Ppat_type(ident) => Doc.concat(list{Doc.text("##"), printIdentPath(ident, cmtTbl)}) - | Ppat_record(rows, openFlag) => - Doc.group( - Doc.concat(list{ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.text(","), Doc.line}), - List.map(row => printPatternRecordRow(row, cmtTbl), rows), - ), - switch openFlag { - | Open => Doc.concat(list{Doc.text(","), Doc.line, Doc.text("_")}) - | Closed => Doc.nil - }, - }), - ), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - Doc.rbrace, - }), - ) - - | Ppat_exception(p) => - let needsParens = switch p.ppat_desc { - | Ppat_or(_, _) | Ppat_alias(_, _) => true - | _ => false - } - - let pat = { - let p = printPattern(p, cmtTbl) - if needsParens { - Doc.concat(list{Doc.text("("), p, Doc.text(")")}) - } else { - p - } - } - - Doc.group(Doc.concat(list{Doc.text("exception"), Doc.line, pat})) - | Ppat_or(_) => - /* Blue | Red | Green -> [Blue; Red; Green] */ - let orChain = ParsetreeViewer.collectOrPatternChain(p) - let docs = List.mapi((i, pat) => { - let patternDoc = printPattern(pat, cmtTbl) - Doc.concat(list{ - if i === 0 { - Doc.nil - } else { - Doc.concat(list{Doc.line, Doc.text("| ")}) - }, - switch pat.ppat_desc { - /* (Blue | Red) | (Green | Black) | White */ - | Ppat_or(_) => addParens(patternDoc) - | _ => patternDoc - }, - }) - }, orChain) - Doc.group(Doc.concat(docs)) - | Ppat_extension(ext) => printExtensionWithComments(~atModuleLvl=false, ext, cmtTbl) - | Ppat_lazy(p) => - let needsParens = switch p.ppat_desc { - | Ppat_or(_, _) | Ppat_alias(_, _) => true - | _ => false - } - - let pat = { - let p = printPattern(p, cmtTbl) - if needsParens { - Doc.concat(list{Doc.text("("), p, Doc.text(")")}) - } else { - p - } - } - - Doc.concat(list{Doc.text("lazy "), pat}) - | Ppat_alias(p, aliasLoc) => - let needsParens = switch p.ppat_desc { - | Ppat_or(_, _) | Ppat_alias(_, _) => true - | _ => false - } - - let renderedPattern = { - let p = printPattern(p, cmtTbl) - if needsParens { - Doc.concat(list{Doc.text("("), p, Doc.text(")")}) - } else { - p - } - } - - Doc.concat(list{renderedPattern, Doc.text(" as "), printStringLoc(aliasLoc, cmtTbl)}) - - /* Note: module(P : S) is represented as */ - /* Ppat_constraint(Ppat_unpack, Ptyp_package) */ - | Ppat_constraint( - {ppat_desc: Ppat_unpack(stringLoc)}, - {ptyp_desc: Ptyp_package(packageType), ptyp_loc}, - ) => - Doc.concat(list{ - Doc.text("module("), - printComments(Doc.text(stringLoc.txt), cmtTbl, stringLoc.loc), - Doc.text(": "), - printComments( - printPackageType(~printModuleKeywordAndParens=false, packageType, cmtTbl), - cmtTbl, - ptyp_loc, - ), - Doc.rparen, - }) - | Ppat_constraint(pattern, typ) => - Doc.concat(list{printPattern(pattern, cmtTbl), Doc.text(": "), printTypExpr(typ, cmtTbl)}) - - /* Note: module(P : S) is represented as */ - /* Ppat_constraint(Ppat_unpack, Ptyp_package) */ - | Ppat_unpack(stringLoc) => - Doc.concat(list{ - Doc.text("module("), - printComments(Doc.text(stringLoc.txt), cmtTbl, stringLoc.loc), - Doc.rparen, - }) - | Ppat_interval(a, b) => Doc.concat(list{printConstant(a), Doc.text(" .. "), printConstant(b)}) - | Ppat_open(_) => Doc.nil - } - - let doc = switch p.ppat_attributes { - | list{} => patternWithoutAttributes - | attrs => Doc.group(Doc.concat(list{printAttributes(attrs), patternWithoutAttributes})) - } - - printComments(doc, cmtTbl, p.ppat_loc) - } - - and printPatternRecordRow = (row, cmtTbl) => - switch row { - /* punned {x} */ - | ( - {Location.txt: Longident.Lident(ident)} as longident, - {Parsetree.ppat_desc: Ppat_var({txt, _})}, - ) when ident == txt => - printLidentPath(longident, cmtTbl) - | (longident, pattern) => - let locForComments = { - ...longident.loc, - loc_end: pattern.Parsetree.ppat_loc.loc_end, - } - let doc = Doc.group( - Doc.concat(list{ - printLidentPath(longident, cmtTbl), - Doc.text(": "), - Doc.indent(Doc.concat(list{Doc.softLine, printPattern(pattern, cmtTbl)})), - }), - ) - printComments(doc, cmtTbl, locForComments) - } - - and printExpressionWithComments = (expr, cmtTbl) => { - let doc = printExpression(expr, cmtTbl) - printComments(doc, cmtTbl, expr.Parsetree.pexp_loc) - } - - and printExpression = (e: Parsetree.expression, cmtTbl) => { - let printedExpression = switch e.pexp_desc { - | Parsetree.Pexp_constant(c) => printConstant(c) - | Pexp_construct(_) when ParsetreeViewer.hasJsxAttribute(e.pexp_attributes) => - printJsxFragment(e, cmtTbl) - | Pexp_construct({txt: Longident.Lident("()")}, _) => Doc.text("()") - | Pexp_construct({txt: Longident.Lident("[]")}, _) => - Doc.concat(list{Doc.text("list["), printCommentsInside(cmtTbl, e.pexp_loc), Doc.rbracket}) - | Pexp_construct({txt: Longident.Lident("::")}, _) => - let (expressions, spread) = ParsetreeViewer.collectListExpressions(e) - let spreadDoc = switch spread { - | Some(expr) => - Doc.concat(list{ - Doc.text(","), - Doc.line, - Doc.dotdotdot, - { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, - }) - | None => Doc.nil - } - - Doc.group( - Doc.concat(list{ - Doc.text("list["), - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.text(","), Doc.line}), List.map(expr => { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, expressions)), - spreadDoc, - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbracket, - }), - ) - | Pexp_construct(longidentLoc, args) => - let constr = printLongidentLocation(longidentLoc, cmtTbl) - let args = switch args { - | None => Doc.nil - | Some({pexp_desc: Pexp_construct({txt: Longident.Lident("()")}, _)}) => Doc.text("()") - /* Some((1, 2)) */ - | Some({pexp_desc: Pexp_tuple(list{{pexp_desc: Pexp_tuple(_)} as arg})}) => - Doc.concat(list{ - Doc.lparen, - { - let doc = printExpressionWithComments(arg, cmtTbl) - switch Parens.expr(arg) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, arg, braces) - | Nothing => doc - } - }, - Doc.rparen, - }) - | Some({pexp_desc: Pexp_tuple(args)}) => - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(expr => { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, args)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }) - | Some(arg) => - let argDoc = { - let doc = printExpressionWithComments(arg, cmtTbl) - switch Parens.expr(arg) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, arg, braces) - | Nothing => doc - } - } - - let shouldHug = ParsetreeViewer.isHuggableExpression(arg) - Doc.concat(list{ - Doc.lparen, - if shouldHug { - argDoc - } else { - Doc.concat(list{ - Doc.indent(Doc.concat(list{Doc.softLine, argDoc})), - Doc.trailingComma, - Doc.softLine, - }) - }, - Doc.rparen, - }) - } - - Doc.group(Doc.concat(list{constr, args})) - | Pexp_ident(path) => printLidentPath(path, cmtTbl) - | Pexp_tuple(exprs) => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.text(","), Doc.line}), List.map(expr => { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, exprs)), - }), - ), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - Doc.rparen, - }), - ) - | Pexp_array(list{}) => - Doc.concat(list{Doc.lbracket, printCommentsInside(cmtTbl, e.pexp_loc), Doc.rbracket}) - | Pexp_array(exprs) => - Doc.group( - Doc.concat(list{ - Doc.lbracket, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.text(","), Doc.line}), List.map(expr => { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, exprs)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbracket, - }), - ) - | Pexp_variant(label, args) => - let variantName = Doc.concat(list{Doc.text("#"), printIdentLike(~allowUident=true, label)}) - let args = switch args { - | None => Doc.nil - | Some({pexp_desc: Pexp_construct({txt: Longident.Lident("()")}, _)}) => Doc.text("()") - /* #poly((1, 2) */ - | Some({pexp_desc: Pexp_tuple(list{{pexp_desc: Pexp_tuple(_)} as arg})}) => - Doc.concat(list{ - Doc.lparen, - { - let doc = printExpressionWithComments(arg, cmtTbl) - switch Parens.expr(arg) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, arg, braces) - | Nothing => doc - } - }, - Doc.rparen, - }) - | Some({pexp_desc: Pexp_tuple(args)}) => - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(expr => { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, args)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }) - | Some(arg) => - let argDoc = { - let doc = printExpressionWithComments(arg, cmtTbl) - switch Parens.expr(arg) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, arg, braces) - | Nothing => doc - } - } - - let shouldHug = ParsetreeViewer.isHuggableExpression(arg) - Doc.concat(list{ - Doc.lparen, - if shouldHug { - argDoc - } else { - Doc.concat(list{ - Doc.indent(Doc.concat(list{Doc.softLine, argDoc})), - Doc.trailingComma, - Doc.softLine, - }) - }, - Doc.rparen, - }) - } - - Doc.group(Doc.concat(list{variantName, args})) - | Pexp_record(rows, spreadExpr) => - let spread = switch spreadExpr { - | None => Doc.nil - | Some(expr) => - Doc.concat(list{ - Doc.dotdotdot, - { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, - Doc.comma, - Doc.line, - }) - } - - /* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group */ - let forceBreak = e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - - Doc.breakableGroup( - ~forceBreak, - Doc.concat(list{ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - spread, - Doc.join( - ~sep=Doc.concat(list{Doc.text(","), Doc.line}), - List.map(row => printRecordRow(row, cmtTbl), rows), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - }), - ) - | Pexp_extension(extension) => - switch extension { - | ( - {txt: "bs.obj"}, - PStr(list{{ - pstr_loc: loc, - pstr_desc: Pstr_eval({pexp_desc: Pexp_record(rows, _)}, list{}), - }}), - ) => - /* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group */ - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum - - Doc.breakableGroup( - ~forceBreak, - Doc.concat(list{ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.text(","), Doc.line}), - List.map(row => printBsObjectRow(row, cmtTbl), rows), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - }), - ) - | extension => printExtensionWithComments(~atModuleLvl=false, extension, cmtTbl) - } - | Pexp_apply(_) => - if ParsetreeViewer.isUnaryExpression(e) { - printUnaryExpression(e, cmtTbl) - } else if ParsetreeViewer.isTemplateLiteral(e) { - printTemplateLiteral(e, cmtTbl) - } else if ParsetreeViewer.isBinaryExpression(e) { - printBinaryExpression(e, cmtTbl) - } else { - printPexpApply(e, cmtTbl) - } - | Pexp_unreachable => Doc.dot - | Pexp_field(expr, longidentLoc) => - let lhs = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.fieldExpr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - Doc.concat(list{lhs, Doc.dot, printLidentPath(longidentLoc, cmtTbl)}) - | Pexp_setfield(expr1, longidentLoc, expr2) => - printSetFieldExpr(e.pexp_attributes, expr1, longidentLoc, expr2, e.pexp_loc, cmtTbl) - | Pexp_ifthenelse(_ifExpr, _thenExpr, _elseExpr) => - if ParsetreeViewer.isTernaryExpr(e) { - let (parts, alternate) = ParsetreeViewer.collectTernaryParts(e) - let ternaryDoc = switch parts { - | list{(condition1, consequent1), ...rest} => - Doc.group( - Doc.concat(list{ - printTernaryOperand(condition1, cmtTbl), - Doc.indent( - Doc.concat(list{ - Doc.line, - Doc.indent( - Doc.concat(list{Doc.text("? "), printTernaryOperand(consequent1, cmtTbl)}), - ), - Doc.concat( - List.map( - ((condition, consequent)) => - Doc.concat(list{ - Doc.line, - Doc.text(": "), - printTernaryOperand(condition, cmtTbl), - Doc.line, - Doc.text("? "), - printTernaryOperand(consequent, cmtTbl), - }), - rest, - ), - ), - Doc.line, - Doc.text(": "), - Doc.indent(printTernaryOperand(alternate, cmtTbl)), - }), - ), - }), - ) - | _ => Doc.nil - } - - let attrs = ParsetreeViewer.filterTernaryAttributes(e.pexp_attributes) - let needsParens = switch ParsetreeViewer.filterParsingAttrs(attrs) { - | list{} => false - | _ => true - } - - Doc.concat(list{ - printAttributes(attrs), - if needsParens { - addParens(ternaryDoc) - } else { - ternaryDoc - }, - }) - } else { - let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions(e) - let ifDocs = Doc.join(~sep=Doc.space, List.mapi((i, (ifExpr, thenExpr)) => { - let ifTxt = if i > 0 { - Doc.text("else if ") - } else { - Doc.text("if ") - } - let condition = if ParsetreeViewer.isBlockExpr(ifExpr) { - printExpressionBlock(~braces=true, ifExpr, cmtTbl) - } else { - let doc = printExpressionWithComments(ifExpr, cmtTbl) - switch Parens.expr(ifExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, ifExpr, braces) - | Nothing => Doc.ifBreaks(addParens(doc), doc) - } - } - - Doc.concat(list{ - ifTxt, - Doc.group(condition), - Doc.space, - { - let thenExpr = switch ParsetreeViewer.processBracesAttr(thenExpr) { - /* This case only happens when coming from Reason, we strip braces */ - | (Some(_), expr) => expr - | _ => thenExpr - } - - printExpressionBlock(~braces=true, thenExpr, cmtTbl) - }, - }) - }, ifs)) - let elseDoc = switch elseExpr { - | None => Doc.nil - | Some(expr) => - Doc.concat(list{Doc.text(" else "), printExpressionBlock(~braces=true, expr, cmtTbl)}) - } - - Doc.concat(list{printAttributes(e.pexp_attributes), ifDocs, elseDoc}) - } - | Pexp_while(expr1, expr2) => - let condition = { - let doc = printExpressionWithComments(expr1, cmtTbl) - switch Parens.expr(expr1) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr1, braces) - | Nothing => doc - } - } - - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.text("while "), - if ParsetreeViewer.isBlockExpr(expr1) { - condition - } else { - Doc.group(Doc.ifBreaks(addParens(condition), condition)) - }, - Doc.space, - printExpressionBlock(~braces=true, expr2, cmtTbl), - }), - ) - | Pexp_for(pattern, fromExpr, toExpr, directionFlag, body) => - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.text("for "), - printPattern(pattern, cmtTbl), - Doc.text(" in "), - { - let doc = printExpressionWithComments(fromExpr, cmtTbl) - switch Parens.expr(fromExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, fromExpr, braces) - | Nothing => doc - } - }, - printDirectionFlag(directionFlag), - { - let doc = printExpressionWithComments(toExpr, cmtTbl) - switch Parens.expr(toExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, toExpr, braces) - | Nothing => doc - } - }, - Doc.space, - printExpressionBlock(~braces=true, body, cmtTbl), - }), - ) - | Pexp_constraint( - {pexp_desc: Pexp_pack(modExpr)}, - {ptyp_desc: Ptyp_package(packageType), ptyp_loc}, - ) => - Doc.group( - Doc.concat(list{ - Doc.text("module("), - Doc.indent( - Doc.concat(list{ - Doc.softLine, - printModExpr(modExpr, cmtTbl), - Doc.text(": "), - printComments( - printPackageType(~printModuleKeywordAndParens=false, packageType, cmtTbl), - cmtTbl, - ptyp_loc, - ), - }), - ), - Doc.softLine, - Doc.rparen, - }), - ) - - | Pexp_constraint(expr, typ) => - let exprDoc = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - Doc.concat(list{exprDoc, Doc.text(": "), printTypExpr(typ, cmtTbl)}) - | Pexp_letmodule({txt: _modName}, _modExpr, _expr) => - printExpressionBlock(~braces=true, e, cmtTbl) - | Pexp_letexception(_extensionConstructor, _expr) => - printExpressionBlock(~braces=true, e, cmtTbl) - | Pexp_assert(expr) => - let rhs = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.lazyOrAssertExprRhs(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - Doc.concat(list{Doc.text("assert "), rhs}) - | Pexp_lazy(expr) => - let rhs = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.lazyOrAssertExprRhs(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - Doc.group(Doc.concat(list{Doc.text("lazy "), rhs})) - | Pexp_open(_overrideFlag, _longidentLoc, _expr) => - printExpressionBlock(~braces=true, e, cmtTbl) - | Pexp_pack(modExpr) => - Doc.group( - Doc.concat(list{ - Doc.text("module("), - Doc.indent(Doc.concat(list{Doc.softLine, printModExpr(modExpr, cmtTbl)})), - Doc.softLine, - Doc.rparen, - }), - ) - | Pexp_sequence(_) => printExpressionBlock(~braces=true, e, cmtTbl) - | Pexp_let(_) => printExpressionBlock(~braces=true, e, cmtTbl) - | Pexp_fun(Nolabel, None, {ppat_desc: Ppat_var({txt: "__x"})}, {pexp_desc: Pexp_apply(_)}) => - /* (__x) => f(a, __x, c) -----> f(a, _, c) */ - printExpressionWithComments(ParsetreeViewer.rewriteUnderscoreApply(e), cmtTbl) - | Pexp_fun(_) | Pexp_newtype(_) => - let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr(e) - let (uncurried, attrs) = ParsetreeViewer.processUncurriedAttribute(attrsOnArrow) - - let (returnExpr, typConstraint) = switch returnExpr.pexp_desc { - | Pexp_constraint(expr, typ) => ( - { - ...expr, - pexp_attributes: List.concat(list{expr.pexp_attributes, returnExpr.pexp_attributes}), - }, - Some(typ), - ) - | _ => (returnExpr, None) - } - - let hasConstraint = switch typConstraint { - | Some(_) => true - | None => false - } - let parametersDoc = printExprFunParameters( - ~inCallback=false, - ~uncurried, - ~hasConstraint, - parameters, - cmtTbl, - ) - - let returnExprDoc = { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(returnExpr) - let shouldInline = switch (returnExpr.pexp_desc, optBraces) { - | (_, Some(_)) => true - | (Pexp_array(_) | Pexp_tuple(_) | Pexp_construct(_, Some(_)) | Pexp_record(_), _) => true - | _ => false - } - - let shouldIndent = switch returnExpr.pexp_desc { - | Pexp_sequence(_) - | Pexp_let(_) - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_open(_) => false - | _ => true - } - - let returnDoc = { - let doc = printExpressionWithComments(returnExpr, cmtTbl) - switch Parens.expr(returnExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, returnExpr, braces) - | Nothing => doc - } - } - - if shouldInline { - Doc.concat(list{Doc.space, returnDoc}) - } else { - Doc.group( - if shouldIndent { - Doc.indent(Doc.concat(list{Doc.line, returnDoc})) - } else { - Doc.concat(list{Doc.space, returnDoc}) - }, - ) - } - } - - let typConstraintDoc = switch typConstraint { - | Some(typ) => Doc.concat(list{Doc.text(": "), printTypExpr(typ, cmtTbl)}) - | _ => Doc.nil - } - - let attrs = printAttributes(attrs) - Doc.group( - Doc.concat(list{attrs, parametersDoc, typConstraintDoc, Doc.text(" =>"), returnExprDoc}), - ) - | Pexp_try(expr, cases) => - let exprDoc = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - Doc.concat(list{Doc.text("try "), exprDoc, Doc.text(" catch "), printCases(cases, cmtTbl)}) - | Pexp_match(expr, cases) => - let exprDoc = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - Doc.concat(list{Doc.text("switch "), exprDoc, Doc.space, printCases(cases, cmtTbl)}) - | Pexp_function(cases) => - Doc.concat(list{Doc.text("x => switch x "), printCases(cases, cmtTbl)}) - | Pexp_coerce(expr, typOpt, typ) => - let docExpr = printExpressionWithComments(expr, cmtTbl) - let docTyp = printTypExpr(typ, cmtTbl) - let ofType = switch typOpt { - | None => Doc.nil - | Some(typ1) => Doc.concat(list{Doc.text(": "), printTypExpr(typ1, cmtTbl)}) - } - - Doc.concat(list{Doc.lparen, docExpr, ofType, Doc.text(" :> "), docTyp, Doc.rparen}) - | Pexp_send(_) => Doc.text("Pexp_send not implemented in printer") - | Pexp_new(_) => Doc.text("Pexp_new not implemented in printer") - | Pexp_setinstvar(_) => Doc.text("Pexp_setinstvar not implemented in printer") - | Pexp_override(_) => Doc.text("Pexp_override not implemented in printer") - | Pexp_poly(_) => Doc.text("Pexp_poly not implemented in printer") - | Pexp_object(_) => Doc.text("Pexp_object not implemented in printer") - } - - let shouldPrintItsOwnAttributes = switch e.pexp_desc { - | Pexp_apply(_) | Pexp_fun(_) | Pexp_newtype(_) | Pexp_setfield(_) | Pexp_ifthenelse(_) => true - | Pexp_construct(_) when ParsetreeViewer.hasJsxAttribute(e.pexp_attributes) => true - | _ => false - } - - switch e.pexp_attributes { - | list{} => printedExpression - | attrs when !shouldPrintItsOwnAttributes => - Doc.group(Doc.concat(list{printAttributes(attrs), printedExpression})) - | _ => printedExpression - } - } - - and printPexpFun = (~inCallback, e, cmtTbl) => { - let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr(e) - let (uncurried, attrs) = ParsetreeViewer.processUncurriedAttribute(attrsOnArrow) - - let (returnExpr, typConstraint) = switch returnExpr.pexp_desc { - | Pexp_constraint(expr, typ) => ( - { - ...expr, - pexp_attributes: List.concat(list{expr.pexp_attributes, returnExpr.pexp_attributes}), - }, - Some(typ), - ) - | _ => (returnExpr, None) - } - - let parametersDoc = printExprFunParameters( - ~inCallback, - ~uncurried, - ~hasConstraint=switch typConstraint { - | Some(_) => true - | None => false - }, - parameters, - cmtTbl, - ) - let returnShouldIndent = switch returnExpr.pexp_desc { - | Pexp_sequence(_) - | Pexp_let(_) - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_open(_) => false - | _ => true - } - - let returnExprDoc = { - let (optBraces, _) = ParsetreeViewer.processBracesAttr(returnExpr) - let shouldInline = switch (returnExpr.pexp_desc, optBraces) { - | (_, Some(_)) => true - | (Pexp_array(_) | Pexp_tuple(_) | Pexp_construct(_, Some(_)) | Pexp_record(_), _) => true - | _ => false - } - - let returnDoc = { - let doc = printExpressionWithComments(returnExpr, cmtTbl) - switch Parens.expr(returnExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, returnExpr, braces) - | Nothing => doc - } - } - - if shouldInline { - Doc.concat(list{Doc.space, returnDoc}) - } else { - Doc.group( - if returnShouldIndent { - Doc.concat(list{ - Doc.indent(Doc.concat(list{Doc.line, returnDoc})), - if inCallback { - Doc.softLine - } else { - Doc.nil - }, - }) - } else { - Doc.concat(list{Doc.space, returnDoc}) - }, - ) - } - } - - let typConstraintDoc = switch typConstraint { - | Some(typ) => Doc.concat(list{Doc.text(": "), printTypExpr(typ, cmtTbl)}) - | _ => Doc.nil - } - - Doc.group( - Doc.concat(list{ - printAttributes(attrs), - parametersDoc, - typConstraintDoc, - Doc.text(" =>"), - returnExprDoc, - }), - ) - } - - and printTernaryOperand = (expr, cmtTbl) => { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.ternaryOperand(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - and printSetFieldExpr = (attrs, lhs, longidentLoc, rhs, loc, cmtTbl) => { - let rhsDoc = { - let doc = printExpressionWithComments(rhs, cmtTbl) - switch Parens.setFieldExprRhs(rhs) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, rhs, braces) - | Nothing => doc - } - } - - let lhsDoc = { - let doc = printExpressionWithComments(lhs, cmtTbl) - switch Parens.fieldExpr(lhs) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, lhs, braces) - | Nothing => doc - } - } - - let shouldIndent = ParsetreeViewer.isBinaryExpression(rhs) - let doc = Doc.group( - Doc.concat(list{ - lhsDoc, - Doc.dot, - printLidentPath(longidentLoc, cmtTbl), - Doc.text(" ="), - if shouldIndent { - Doc.group(Doc.indent(Doc.concat(list{Doc.line, rhsDoc}))) - } else { - Doc.concat(list{Doc.space, rhsDoc}) - }, - }), - ) - let doc = switch attrs { - | list{} => doc - | attrs => Doc.group(Doc.concat(list{printAttributes(attrs), doc})) - } - - printComments(doc, cmtTbl, loc) - } - - and printTemplateLiteral = (expr, cmtTbl) => { - let tag = ref("j") - let rec walkExpr = expr => { - open Parsetree - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("^")})}, - list{(Nolabel, arg1), (Nolabel, arg2)}, - ) => - let lhs = walkExpr(arg1) - let rhs = walkExpr(arg2) - Doc.concat(list{lhs, rhs}) - | Pexp_constant(Pconst_string(txt, Some(prefix))) => - tag := prefix - Doc.text(txt) - | _ => - let doc = printExpressionWithComments(expr, cmtTbl) - Doc.concat(list{Doc.text("${"), doc, Doc.rbrace}) - } - } - - let content = walkExpr(expr) - Doc.concat(list{ - if tag.contents == "j" { - Doc.nil - } else { - Doc.text(tag.contents) - }, - Doc.text("`"), - content, - Doc.text("`"), - }) - } - - and printUnaryExpression = (expr, cmtTbl) => { - let printUnaryOperator = op => - Doc.text( - switch op { - | "~+" => "+" - | "~+." => "+." - | "~-" => "-" - | "~-." => "-." - | "not" => "!" - | _ => assert false - }, - ) - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list{(Nolabel, operand)}, - ) => - let printedOperand = { - let doc = printExpressionWithComments(operand, cmtTbl) - switch Parens.unaryExprOperand(operand) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, operand, braces) - | Nothing => doc - } - } - - let doc = Doc.concat(list{printUnaryOperator(operator), printedOperand}) - printComments(doc, cmtTbl, expr.pexp_loc) - | _ => assert false - } - } - - and printBinaryExpression = (expr: Parsetree.expression, cmtTbl) => { - let printBinaryOperator = (~inlineRhs, operator) => { - let operatorTxt = switch operator { - | "|." => "->" - | "^" => "++" - | "=" => "==" - | "==" => "===" - | "<>" => "!=" - | "!=" => "!==" - | txt => txt - } - - let spacingBeforeOperator = if operator == "|." { - Doc.softLine - } else if operator == "|>" { - Doc.line - } else { - Doc.space - } - - let spacingAfterOperator = if operator == "|." { - Doc.nil - } else if operator == "|>" { - Doc.space - } else if inlineRhs { - Doc.space - } else { - Doc.line - } - - Doc.concat(list{spacingBeforeOperator, Doc.text(operatorTxt), spacingAfterOperator}) - } - - let printOperand = (~isLhs, expr, parentOperator) => { - let rec flatten = (~isLhs, expr, parentOperator) => - if ParsetreeViewer.isBinaryExpression(expr) { - switch expr { - | { - pexp_desc: - Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list{(_, left), (_, right)}, - ), - } => - if ( - ParsetreeViewer.flattenableOperators(parentOperator, operator) && - !ParsetreeViewer.hasAttributes(expr.pexp_attributes) - ) { - let leftPrinted = flatten(~isLhs=true, left, operator) - let rightPrinted = { - let (_, rightAttrs) = ParsetreeViewer.partitionPrinteableAttributes( - right.pexp_attributes, - ) - - let doc = printExpressionWithComments( - {...right, pexp_attributes: rightAttrs}, - cmtTbl, - ) - - let doc = if Parens.flattenOperandRhs(parentOperator, right) { - Doc.concat(list{Doc.lparen, doc, Doc.rparen}) - } else { - doc - } - - let printeableAttrs = ParsetreeViewer.filterPrinteableAttributes( - right.pexp_attributes, - ) - - Doc.concat(list{printAttributes(printeableAttrs), doc}) - } - - let doc = Doc.concat(list{ - leftPrinted, - printBinaryOperator(~inlineRhs=false, operator), - rightPrinted, - }) - let doc = if !isLhs && Parens.rhsBinaryExprOperand(operator, expr) { - Doc.concat(list{Doc.lparen, doc, Doc.rparen}) - } else { - doc - } - - printComments(doc, cmtTbl, expr.pexp_loc) - } else { - let doc = printExpressionWithComments({...expr, pexp_attributes: list{}}, cmtTbl) - let doc = if ( - Parens.subBinaryExprOperand(parentOperator, operator) || - (expr.pexp_attributes != list{} && - (ParsetreeViewer.isBinaryExpression(expr) || ParsetreeViewer.isTernaryExpr(expr))) - ) { - Doc.concat(list{Doc.lparen, doc, Doc.rparen}) - } else { - doc - } - Doc.concat(list{printAttributes(expr.pexp_attributes), doc}) - } - | _ => assert false - } - } else { - switch expr.pexp_desc { - | Pexp_setfield(lhs, field, rhs) => - let doc = printSetFieldExpr( - expr.pexp_attributes, - lhs, - field, - rhs, - expr.pexp_loc, - cmtTbl, - ) - if isLhs { - addParens(doc) - } else { - doc - } - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("#=")})}, - list{(Nolabel, lhs), (Nolabel, rhs)}, - ) => - let rhsDoc = printExpressionWithComments(rhs, cmtTbl) - let lhsDoc = printExpressionWithComments(lhs, cmtTbl) - /* TODO: unify indentation of "=" */ - let shouldIndent = ParsetreeViewer.isBinaryExpression(rhs) - let doc = Doc.group( - Doc.concat(list{ - lhsDoc, - Doc.text(" ="), - if shouldIndent { - Doc.group(Doc.indent(Doc.concat(list{Doc.line, rhsDoc}))) - } else { - Doc.concat(list{Doc.space, rhsDoc}) - }, - }), - ) - let doc = switch expr.pexp_attributes { - | list{} => doc - | attrs => Doc.group(Doc.concat(list{printAttributes(attrs), doc})) - } - - if isLhs { - addParens(doc) - } else { - doc - } - | _ => - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.binaryExprOperand(~isLhs, expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - } - - flatten(~isLhs, expr, parentOperator) - } - - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(("|." | "|>") as op)})}, - list{(Nolabel, lhs), (Nolabel, rhs)}, - ) - when !(ParsetreeViewer.isBinaryExpression(lhs) || ParsetreeViewer.isBinaryExpression(rhs)) => - let lhsDoc = printOperand(~isLhs=true, lhs, op) - let rhsDoc = printOperand(~isLhs=false, rhs, op) - Doc.group( - Doc.concat(list{ - lhsDoc, - switch op { - | "|." => Doc.text("->") - | "|>" => Doc.text(" |> ") - | _ => assert false - }, - rhsDoc, - }), - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list{(Nolabel, lhs), (Nolabel, rhs)}, - ) => - let right = { - let operatorWithRhs = { - let rhsDoc = printOperand(~isLhs=false, rhs, operator) - Doc.concat(list{ - printBinaryOperator( - ~inlineRhs=ParsetreeViewer.shouldInlineRhsBinaryExpr(rhs), - operator, - ), - rhsDoc, - }) - } - if ParsetreeViewer.shouldIndentBinaryExpr(expr) { - Doc.group(Doc.indent(operatorWithRhs)) - } else { - operatorWithRhs - } - } - - let doc = Doc.group(Doc.concat(list{printOperand(~isLhs=true, lhs, operator), right})) - Doc.group( - Doc.concat(list{ - printAttributes(expr.pexp_attributes), - switch Parens.binaryExpr({ - ...expr, - pexp_attributes: List.filter(attr => - switch attr { - | ({Location.txt: "res.braces"}, _) => false - | _ => true - } - , expr.pexp_attributes), - }) { - | Braced(bracesLoc) => printBraces(doc, expr, bracesLoc) - | Parenthesized => addParens(doc) - | Nothing => doc - }, - }), - ) - | _ => Doc.nil - } - } - - /* callExpr(arg1, arg2) */ - and printPexpApply = (expr, cmtTbl) => - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("##")})}, - list{(Nolabel, parentExpr), (Nolabel, memberExpr)}, - ) => - let parentDoc = { - let doc = printExpressionWithComments(parentExpr, cmtTbl) - switch Parens.unaryExprOperand(parentExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, parentExpr, braces) - | Nothing => doc - } - } - - let member = { - let memberDoc = switch memberExpr.pexp_desc { - | Pexp_ident(lident) => - printComments(printLongident(lident.txt), cmtTbl, memberExpr.pexp_loc) - | _ => printExpressionWithComments(memberExpr, cmtTbl) - } - - Doc.concat(list{Doc.text("\""), memberDoc, Doc.text("\"")}) - } - - Doc.group( - Doc.concat(list{ - printAttributes(expr.pexp_attributes), - parentDoc, - Doc.lbracket, - member, - Doc.rbracket, - }), - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("#=")})}, - list{(Nolabel, lhs), (Nolabel, rhs)}, - ) => - let rhsDoc = { - let doc = printExpressionWithComments(rhs, cmtTbl) - switch Parens.expr(rhs) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, rhs, braces) - | Nothing => doc - } - } - - /* TODO: unify indentation of "=" */ - let shouldIndent = - !ParsetreeViewer.isBracedExpr(rhs) && ParsetreeViewer.isBinaryExpression(rhs) - let doc = Doc.group( - Doc.concat(list{ - printExpressionWithComments(lhs, cmtTbl), - Doc.text(" ="), - if shouldIndent { - Doc.group(Doc.indent(Doc.concat(list{Doc.line, rhsDoc}))) - } else { - Doc.concat(list{Doc.space, rhsDoc}) - }, - }), - ) - switch expr.pexp_attributes { - | list{} => doc - | attrs => Doc.group(Doc.concat(list{printAttributes(attrs), doc})) - } - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Ldot(Lident("Array"), "get")})}, - list{(Nolabel, parentExpr), (Nolabel, memberExpr)}, - ) => - let member = { - let memberDoc = { - let doc = printExpressionWithComments(memberExpr, cmtTbl) - switch Parens.expr(memberExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, memberExpr, braces) - | Nothing => doc - } - } - - let shouldInline = switch memberExpr.pexp_desc { - | Pexp_constant(_) | Pexp_ident(_) => true - | _ => false - } - - if shouldInline { - memberDoc - } else { - Doc.concat(list{Doc.indent(Doc.concat(list{Doc.softLine, memberDoc})), Doc.softLine}) - } - } - - let parentDoc = { - let doc = printExpressionWithComments(parentExpr, cmtTbl) - switch Parens.unaryExprOperand(parentExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, parentExpr, braces) - | Nothing => doc - } - } - - Doc.group( - Doc.concat(list{ - printAttributes(expr.pexp_attributes), - parentDoc, - Doc.lbracket, - member, - Doc.rbracket, - }), - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Ldot(Lident("Array"), "set")})}, - list{(Nolabel, parentExpr), (Nolabel, memberExpr), (Nolabel, targetExpr)}, - ) => - let member = { - let memberDoc = { - let doc = printExpressionWithComments(memberExpr, cmtTbl) - switch Parens.expr(memberExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, memberExpr, braces) - | Nothing => doc - } - } - - let shouldInline = switch memberExpr.pexp_desc { - | Pexp_constant(_) | Pexp_ident(_) => true - | _ => false - } - - if shouldInline { - memberDoc - } else { - Doc.concat(list{Doc.indent(Doc.concat(list{Doc.softLine, memberDoc})), Doc.softLine}) - } - } - - let shouldIndentTargetExpr = if ParsetreeViewer.isBracedExpr(targetExpr) { - false - } else { - ParsetreeViewer.isBinaryExpression(targetExpr) || - switch targetExpr { - | { - pexp_attributes: list{({Location.txt: "res.ternary"}, _)}, - pexp_desc: Pexp_ifthenelse(ifExpr, _, _), - } => - ParsetreeViewer.isBinaryExpression(ifExpr) || - ParsetreeViewer.hasAttributes(ifExpr.pexp_attributes) - | {pexp_desc: Pexp_newtype(_)} => false - | e => ParsetreeViewer.hasAttributes(e.pexp_attributes) || ParsetreeViewer.isArrayAccess(e) - } - } - - let targetExpr = { - let doc = printExpressionWithComments(targetExpr, cmtTbl) - switch Parens.expr(targetExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, targetExpr, braces) - | Nothing => doc - } - } - - let parentDoc = { - let doc = printExpressionWithComments(parentExpr, cmtTbl) - switch Parens.unaryExprOperand(parentExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, parentExpr, braces) - | Nothing => doc - } - } - - Doc.group( - Doc.concat(list{ - printAttributes(expr.pexp_attributes), - parentDoc, - Doc.lbracket, - member, - Doc.rbracket, - Doc.text(" ="), - if shouldIndentTargetExpr { - Doc.indent(Doc.concat(list{Doc.line, targetExpr})) - } else { - Doc.concat(list{Doc.space, targetExpr}) - }, - }), - ) - /* TODO: cleanup, are those branches even remotely performant? */ - | Pexp_apply({pexp_desc: Pexp_ident(lident)}, args) - when ParsetreeViewer.isJsxExpression(expr) => - printJsxExpression(lident, args, cmtTbl) - | Pexp_apply(callExpr, args) => - let args = List.map(((lbl, arg)) => (lbl, ParsetreeViewer.rewriteUnderscoreApply(arg)), args) - - let (uncurried, attrs) = ParsetreeViewer.processUncurriedAttribute(expr.pexp_attributes) - - let callExprDoc = { - let doc = printExpressionWithComments(callExpr, cmtTbl) - switch Parens.callExpr(callExpr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, callExpr, braces) - | Nothing => doc - } - } - - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg(args) { - let argsDoc = printArgumentsWithCallbackInFirstPosition(~uncurried, args, cmtTbl) - - Doc.concat(list{printAttributes(attrs), callExprDoc, argsDoc}) - } else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg(args) { - let argsDoc = printArgumentsWithCallbackInLastPosition(~uncurried, args, cmtTbl) - - Doc.concat(list{printAttributes(attrs), callExprDoc, argsDoc}) - } else { - let argsDoc = printArguments(~uncurried, args, cmtTbl) - Doc.concat(list{printAttributes(attrs), callExprDoc, argsDoc}) - } - | _ => assert false - } - - and printJsxExpression = (lident, args, cmtTbl) => { - let name = printJsxName(lident) - let (formattedProps, children) = printJsxProps(args, cmtTbl) - /*
*/ - let isSelfClosing = switch children { - | list{} => true - | _ => false - } - Doc.group( - Doc.concat(list{ - Doc.group( - Doc.concat(list{ - printComments(Doc.concat(list{Doc.lessThan, name}), cmtTbl, lident.Asttypes.loc), - formattedProps, - if isSelfClosing { - Doc.concat(list{Doc.line, Doc.text("/>")}) - } else { - Doc.nil - }, - }), - ), - if isSelfClosing { - Doc.nil - } else { - Doc.concat(list{ - Doc.greaterThan, - Doc.indent(Doc.concat(list{Doc.line, printJsxChildren(children, cmtTbl)})), - Doc.line, - Doc.text(" { - let opening = Doc.text("<>") - let closing = Doc.text("") - let (children, _) = ParsetreeViewer.collectListExpressions(expr) - Doc.group( - Doc.concat(list{ - opening, - switch children { - | list{} => Doc.nil - | children => Doc.indent(Doc.concat(list{Doc.line, printJsxChildren(children, cmtTbl)})) - }, - Doc.line, - closing, - }), - ) - } - - and printJsxChildren = (children: list, cmtTbl) => - Doc.group(Doc.join(~sep=Doc.line, List.map(expr => { - let exprDoc = printExpressionWithComments(expr, cmtTbl) - switch Parens.jsxChildExpr(expr) { - | Parenthesized | Braced(_) => - /* {(20: int)} make sure that we also protect the expression inside */ - addBraces( - if Parens.bracedExpr(expr) { - addParens(exprDoc) - } else { - exprDoc - }, - ) - | Nothing => exprDoc - } - }, children))) - - and printJsxProps = (args, cmtTbl) => { - let rec loop = (props, args) => - switch args { - | list{} => (Doc.nil, list{}) - | list{ - (Asttypes.Labelled("children"), children), - ( - Asttypes.Nolabel, - {Parsetree.pexp_desc: Pexp_construct({txt: Longident.Lident("()")}, None)}, - ), - } => - let formattedProps = Doc.indent( - switch props { - | list{} => Doc.nil - | props => - Doc.concat(list{Doc.line, Doc.group(Doc.join(~sep=Doc.line, props |> List.rev))}) - }, - ) - let (children, _) = ParsetreeViewer.collectListExpressions(children) - (formattedProps, children) - | list{arg, ...args} => - let propDoc = printJsxProp(arg, cmtTbl) - loop(list{propDoc, ...props}, args) - } - - loop(list{}, args) - } - - and printJsxProp = (arg, cmtTbl) => - switch arg { - | ( - (Asttypes.Labelled(lblTxt) | Optional(lblTxt)) as lbl, - { - Parsetree.pexp_attributes: list{({Location.txt: "res.namedArgLoc", loc: argLoc}, _)}, - pexp_desc: Pexp_ident({txt: Longident.Lident(ident)}), - }, - ) when lblTxt == ident /* jsx punning */ => - switch lbl { - | Nolabel => Doc.nil - | Labelled(_lbl) => printComments(printIdentLike(ident), cmtTbl, argLoc) - | Optional(_lbl) => - let doc = Doc.concat(list{Doc.question, printIdentLike(ident)}) - printComments(doc, cmtTbl, argLoc) - } - | ( - (Asttypes.Labelled(lblTxt) | Optional(lblTxt)) as lbl, - {Parsetree.pexp_attributes: list{}, pexp_desc: Pexp_ident({txt: Longident.Lident(ident)})}, - ) when lblTxt == ident /* jsx punning when printing from Reason */ => - switch lbl { - | Nolabel => Doc.nil - | Labelled(_lbl) => printIdentLike(ident) - | Optional(_lbl) => Doc.concat(list{Doc.question, printIdentLike(ident)}) - } - | (lbl, expr) => - let (argLoc, expr) = switch expr.pexp_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ...attrs} => ( - loc, - {...expr, pexp_attributes: attrs}, - ) - | _ => (Location.none, expr) - } - - let lblDoc = switch lbl { - | Asttypes.Labelled(lbl) => - let lbl = printComments(printIdentLike(lbl), cmtTbl, argLoc) - Doc.concat(list{lbl, Doc.equal}) - | Asttypes.Optional(lbl) => - let lbl = printComments(printIdentLike(lbl), cmtTbl, argLoc) - Doc.concat(list{lbl, Doc.equal, Doc.question}) - | Nolabel => Doc.nil - } - - let exprDoc = { - let doc = printExpression(expr, cmtTbl) - switch Parens.jsxPropExpr(expr) { - | Parenthesized | Braced(_) => - /* {(20: int)} make sure that we also protect the expression inside */ - addBraces( - if Parens.bracedExpr(expr) { - addParens(doc) - } else { - doc - }, - ) - | _ => doc - } - } - - let fullLoc = {...argLoc, loc_end: expr.pexp_loc.loc_end} - printComments(Doc.concat(list{lblDoc, exprDoc}), cmtTbl, fullLoc) - } - - /* div -> div. - * Navabar.createElement -> Navbar - * Staff.Users.createElement -> Staff.Users */ - and printJsxName = ({txt: lident}) => { - let rec flatten = (acc, lident) => - switch lident { - | Longident.Lident(txt) => list{txt, ...acc} - | Ldot(lident, txt) => - let acc = if txt == "createElement" { - acc - } else { - list{txt, ...acc} - } - flatten(acc, lident) - | _ => acc - } - - switch lident { - | Longident.Lident(txt) => Doc.text(txt) - | _ as lident => - let segments = flatten(list{}, lident) - Doc.join(~sep=Doc.dot, List.map(Doc.text, segments)) - } - } - - and printArgumentsWithCallbackInFirstPosition = (~uncurried, args, cmtTbl) => { - let (callback, printedArgs) = switch args { - | list{(lbl, expr), ...args} => - let lblDoc = switch lbl { - | Asttypes.Nolabel => Doc.nil - | Asttypes.Labelled(txt) => Doc.concat(list{Doc.tilde, printIdentLike(txt), Doc.equal}) - | Asttypes.Optional(txt) => - Doc.concat(list{Doc.tilde, printIdentLike(txt), Doc.equal, Doc.question}) - } - - let callback = Doc.concat(list{lblDoc, printPexpFun(~inCallback=true, expr, cmtTbl)}) - let printedArgs = - List.map(arg => printArgument(arg, cmtTbl), args) |> Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - ) - - (callback, printedArgs) - | _ => assert false - } - - /* Thing.map((arg1, arg2) => MyModuleBlah.toList(argument), foo) */ - /* Thing.map((arg1, arg2) => { - * MyModuleBlah.toList(argument) - * }, longArgumet, veryLooooongArgument) - */ - let fitsOnOneLine = Doc.concat(list{ - if uncurried { - Doc.text("(. ") - } else { - Doc.lparen - }, - callback, - Doc.comma, - Doc.line, - printedArgs, - Doc.rparen, - }) - - /* Thing.map( - * (param1, parm2) => doStuff(param1, parm2), - * arg1, - * arg2, - * arg3, - * ) - */ - let breakAllArgs = printArguments(~uncurried, args, cmtTbl) - Doc.customLayout(list{fitsOnOneLine, breakAllArgs}) - } - - and printArgumentsWithCallbackInLastPosition = (~uncurried, args, cmtTbl) => { - let rec loop = (acc, args) => - switch args { - | list{} => (Doc.nil, Doc.nil) - | list{(lbl, expr)} => - let lblDoc = switch lbl { - | Asttypes.Nolabel => Doc.nil - | Asttypes.Labelled(txt) => Doc.concat(list{Doc.tilde, printIdentLike(txt), Doc.equal}) - | Asttypes.Optional(txt) => - Doc.concat(list{Doc.tilde, printIdentLike(txt), Doc.equal, Doc.question}) - } - - let callback = printPexpFun(~inCallback=true, expr, cmtTbl) - (Doc.concat(List.rev(acc)), Doc.concat(list{lblDoc, callback})) - | list{arg, ...args} => - let argDoc = printArgument(arg, cmtTbl) - loop(list{Doc.line, Doc.comma, argDoc, ...acc}, args) - } - - let (printedArgs, callback) = loop(list{}, args) - - /* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) */ - let fitsOnOneLine = Doc.concat(list{ - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - printedArgs, - callback, - Doc.rparen, - }) - - /* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => - * MyModuleBlah.toList(argument) - * ) - */ - let arugmentsFitOnOneLine = Doc.concat(list{ - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - Doc.softLine, - printedArgs, - Doc.breakableGroup(~forceBreak=true, callback), - Doc.softLine, - Doc.rparen, - }) - - /* Thing.map( - * arg1, - * arg2, - * arg3, - * (param1, parm2) => doStuff(param1, parm2) - * ) - */ - let breakAllArgs = printArguments(~uncurried, args, cmtTbl) - Doc.customLayout(list{fitsOnOneLine, arugmentsFitOnOneLine, breakAllArgs}) - } - - and printArguments = ( - ~uncurried, - args: list<(Asttypes.arg_label, Parsetree.expression)>, - cmtTbl, - ) => - switch args { - | list{(Nolabel, {pexp_desc: Pexp_construct({txt: Longident.Lident("()")}, _)})} => - if uncurried { - Doc.text("(.)") - } else { - Doc.text("()") - } - | list{(Nolabel, arg)} when ParsetreeViewer.isHuggableExpression(arg) => - let argDoc = { - let doc = printExpressionWithComments(arg, cmtTbl) - switch Parens.expr(arg) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, arg, braces) - | Nothing => doc - } - } - - Doc.concat(list{ - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - argDoc, - Doc.rparen, - }) - | args => - Doc.group( - Doc.concat(list{ - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - Doc.indent( - Doc.concat(list{ - if uncurried { - Doc.line - } else { - Doc.softLine - }, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(arg => printArgument(arg, cmtTbl), args), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - } - - /* - * argument ::= - * | _ (* syntax sugar *) - * | expr - * | expr : type - * | ~ label-name - * | ~ label-name - * | ~ label-name ? - * | ~ label-name = expr - * | ~ label-name = _ (* syntax sugar *) - * | ~ label-name = expr : type - * | ~ label-name = ? expr - * | ~ label-name = ? _ (* syntax sugar *) - * | ~ label-name = ? expr : type */ - and printArgument = ((argLbl, arg), cmtTbl) => - switch (argLbl, arg) { - /* ~a (punned) */ - | ( - Asttypes.Labelled(lbl), - { - pexp_desc: Pexp_ident({txt: Longident.Lident(name)}), - pexp_attributes: list{} | list{({Location.txt: "res.namedArgLoc"}, _)}, - } as argExpr, - ) when lbl == name && !ParsetreeViewer.isBracedExpr(argExpr) => - let loc = switch arg.pexp_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._} => loc - | _ => arg.pexp_loc - } - - let doc = Doc.concat(list{Doc.tilde, printIdentLike(lbl)}) - printComments(doc, cmtTbl, loc) - - /* ~a: int (punned) */ - | ( - Asttypes.Labelled(lbl), - { - pexp_desc: - Pexp_constraint({pexp_desc: Pexp_ident({txt: Longident.Lident(name)})} as argExpr, typ), - pexp_loc, - pexp_attributes: (list{} | list{({Location.txt: "res.namedArgLoc"}, _)}) as attrs, - }, - ) when lbl == name && !ParsetreeViewer.isBracedExpr(argExpr) => - let loc = switch attrs { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._} => { - ...loc, - loc_end: pexp_loc.loc_end, - } - | _ => arg.pexp_loc - } - - let doc = Doc.concat(list{ - Doc.tilde, - printIdentLike(lbl), - Doc.text(": "), - printTypExpr(typ, cmtTbl), - }) - printComments(doc, cmtTbl, loc) - /* ~a? (optional lbl punned) */ - | ( - Asttypes.Optional(lbl), - { - pexp_desc: Pexp_ident({txt: Longident.Lident(name)}), - pexp_attributes: list{} | list{({Location.txt: "res.namedArgLoc"}, _)}, - }, - ) when lbl == name => - let loc = switch arg.pexp_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._} => loc - | _ => arg.pexp_loc - } - - let doc = Doc.concat(list{Doc.tilde, printIdentLike(lbl), Doc.question}) - printComments(doc, cmtTbl, loc) - | (_lbl, expr) => - let (argLoc, expr) = switch expr.pexp_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ...attrs} => ( - loc, - {...expr, pexp_attributes: attrs}, - ) - | _ => (expr.pexp_loc, expr) - } - - let printedLbl = switch argLbl { - | Asttypes.Nolabel => Doc.nil - | Asttypes.Labelled(lbl) => - let doc = Doc.concat(list{Doc.tilde, printIdentLike(lbl), Doc.equal}) - printComments(doc, cmtTbl, argLoc) - | Asttypes.Optional(lbl) => - let doc = Doc.concat(list{Doc.tilde, printIdentLike(lbl), Doc.equal, Doc.question}) - printComments(doc, cmtTbl, argLoc) - } - - let printedExpr = { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - let loc = {...argLoc, loc_end: expr.pexp_loc.loc_end} - let doc = Doc.concat(list{printedLbl, printedExpr}) - printComments(doc, cmtTbl, loc) - } - - and printCases = (cases: list, cmtTbl) => - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{Doc.lbrace, Doc.concat(list{Doc.line, printList(~getLoc=n => { - ...n.Parsetree.pc_lhs.ppat_loc, - loc_end: switch ParsetreeViewer.processBracesAttr(n.Parsetree.pc_rhs) { - | (None, _) => n.pc_rhs.pexp_loc.loc_end - | (Some({loc}, _), _) => loc.Location.loc_end - }, - }, ~print=printCase, ~nodes=cases, cmtTbl)}), Doc.line, Doc.rbrace}), - ) - - and printCase = (case: Parsetree.case, cmtTbl) => { - let rhs = switch case.pc_rhs.pexp_desc { - | Pexp_let(_) | Pexp_letmodule(_) | Pexp_letexception(_) | Pexp_open(_) | Pexp_sequence(_) => - printExpressionBlock(~braces=ParsetreeViewer.isBracedExpr(case.pc_rhs), case.pc_rhs, cmtTbl) - | _ => - let doc = printExpressionWithComments(case.pc_rhs, cmtTbl) - switch Parens.expr(case.pc_rhs) { - | Parenthesized => addParens(doc) - | _ => doc - } - } - - let guard = switch case.pc_guard { - | None => Doc.nil - | Some(expr) => - Doc.group( - Doc.concat(list{Doc.line, Doc.text("when "), printExpressionWithComments(expr, cmtTbl)}), - ) - } - - let shouldInlineRhs = switch case.pc_rhs.pexp_desc { - | Pexp_construct({txt: Longident.Lident("()" | "true" | "false")}, _) - | Pexp_constant(_) - | Pexp_ident(_) => true - | _ when ParsetreeViewer.isHuggableRhs(case.pc_rhs) => true - | _ => false - } - - let shouldIndentPattern = switch case.pc_lhs.ppat_desc { - | Ppat_or(_) => false - | _ => true - } - - let patternDoc = { - let doc = printPattern(case.pc_lhs, cmtTbl) - switch case.pc_lhs.ppat_desc { - | Ppat_constraint(_) => addParens(doc) - | _ => doc - } - } - - let content = Doc.concat(list{ - if shouldIndentPattern { - Doc.indent(patternDoc) - } else { - patternDoc - }, - Doc.indent(guard), - Doc.text(" =>"), - Doc.indent( - Doc.concat(list{ - if shouldInlineRhs { - Doc.space - } else { - Doc.line - }, - rhs, - }), - ), - }) - Doc.group(Doc.concat(list{Doc.text("| "), content})) - } - - and printExprFunParameters = (~inCallback, ~uncurried, ~hasConstraint, parameters, cmtTbl) => - switch parameters { - /* let f = _ => () */ - | list{ParsetreeViewer.Parameter({ - attrs: list{}, - lbl: Asttypes.Nolabel, - defaultExpr: None, - pat: {Parsetree.ppat_desc: Ppat_any}, - })} when !uncurried => - if hasConstraint { - Doc.text("(_)") - } else { - Doc.text("_") - } - /* let f = a => () */ - | list{ParsetreeViewer.Parameter({ - attrs: list{}, - lbl: Asttypes.Nolabel, - defaultExpr: None, - pat: {Parsetree.ppat_desc: Ppat_var(stringLoc)}, - })} when !uncurried => - let txtDoc = { - let var = printIdentLike(stringLoc.txt) - if hasConstraint { - addParens(var) - } else { - var - } - } - - printComments(txtDoc, cmtTbl, stringLoc.loc) - /* let f = () => () */ - | list{ParsetreeViewer.Parameter({ - attrs: list{}, - lbl: Asttypes.Nolabel, - defaultExpr: None, - pat: {ppat_desc: Ppat_construct({txt: Longident.Lident("()")}, None)}, - })} when !uncurried => - Doc.text("()") - /* let f = (~greeting, ~from as hometown, ~x=?) => () */ - | parameters => - let lparen = if uncurried { - Doc.text("(. ") - } else { - Doc.lparen - } - let shouldHug = ParsetreeViewer.parametersShouldHug(parameters) - let printedParamaters = Doc.concat(list{ - if shouldHug || inCallback { - Doc.nil - } else { - Doc.softLine - }, - Doc.join( - ~sep=Doc.concat(list{ - Doc.comma, - if inCallback { - Doc.space - } else { - Doc.line - }, - }), - List.map(p => printExpFunParameter(p, cmtTbl), parameters), - ), - }) - Doc.group( - Doc.concat(list{ - lparen, - if shouldHug || inCallback { - printedParamaters - } else { - Doc.indent(printedParamaters) - }, - if shouldHug || inCallback { - Doc.nil - } else { - Doc.concat(list{Doc.trailingComma, Doc.softLine}) - }, - Doc.rparen, - }), - ) - } - - and printExpFunParameter = (parameter, cmtTbl) => - switch parameter { - | ParsetreeViewer.NewTypes({attrs, locs: lbls}) => - Doc.group( - Doc.concat(list{ - printAttributes(attrs), - Doc.text("type "), - Doc.join( - ~sep=Doc.space, - List.map( - lbl => printComments(printIdentLike(lbl.Asttypes.txt), cmtTbl, lbl.Asttypes.loc), - lbls, - ), - ), - }), - ) - | Parameter({attrs, lbl, defaultExpr, pat: pattern}) => - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute(attrs) - let uncurried = if isUncurried { - Doc.concat(list{Doc.dot, Doc.space}) - } else { - Doc.nil - } - let attrs = printAttributes(attrs) - /* =defaultValue */ - let defaultExprDoc = switch defaultExpr { - | Some(expr) => Doc.concat(list{Doc.text("="), printExpressionWithComments(expr, cmtTbl)}) - | None => Doc.nil - } - - /* ~from as hometown - * ~from -> punning */ - let labelWithPattern = switch (lbl, pattern) { - | (Asttypes.Nolabel, pattern) => printPattern(pattern, cmtTbl) - | ( - Asttypes.Labelled(lbl) | Optional(lbl), - { - ppat_desc: Ppat_var(stringLoc), - ppat_attributes: list{} | list{({Location.txt: "res.namedArgLoc"}, _)}, - }, - ) when lbl == stringLoc.txt => - /* ~d */ - Doc.concat(list{Doc.text("~"), printIdentLike(lbl)}) - | ( - Asttypes.Labelled(lbl) | Optional(lbl), - { - ppat_desc: Ppat_constraint({ppat_desc: Ppat_var({txt})}, typ), - ppat_attributes: list{} | list{({Location.txt: "res.namedArgLoc"}, _)}, - }, - ) when lbl == txt => - /* ~d: e */ - Doc.concat(list{ - Doc.text("~"), - printIdentLike(lbl), - Doc.text(": "), - printTypExpr(typ, cmtTbl), - }) - | (Asttypes.Labelled(lbl) | Optional(lbl), pattern) => - /* ~b as c */ - Doc.concat(list{ - Doc.text("~"), - printIdentLike(lbl), - Doc.text(" as "), - printPattern(pattern, cmtTbl), - }) - } - - let optionalLabelSuffix = switch (lbl, defaultExpr) { - | (Asttypes.Optional(_), None) => Doc.text("=?") - | _ => Doc.nil - } - - let doc = Doc.group( - Doc.concat(list{uncurried, attrs, labelWithPattern, defaultExprDoc, optionalLabelSuffix}), - ) - let cmtLoc = switch defaultExpr { - | None => - switch pattern.ppat_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._} => { - ...loc, - loc_end: pattern.ppat_loc.loc_end, - } - | _ => pattern.ppat_loc - } - | Some(expr) => - let startPos = switch pattern.ppat_attributes { - | list{({Location.txt: "res.namedArgLoc", loc}, _), ..._} => loc.loc_start - | _ => pattern.ppat_loc.loc_start - } - { - ...pattern.ppat_loc, - loc_start: startPos, - loc_end: expr.pexp_loc.loc_end, - } - } - - printComments(doc, cmtTbl, cmtLoc) - } - - and printExpressionBlock = (~braces, expr, cmtTbl) => { - let rec collectRows = (acc, expr) => - switch expr.Parsetree.pexp_desc { - | Parsetree.Pexp_letmodule(modName, modExpr, expr2) => - let name = { - let doc = Doc.text(modName.txt) - printComments(doc, cmtTbl, modName.loc) - } - - let letModuleDoc = Doc.concat(list{ - Doc.text("module "), - name, - Doc.text(" = "), - printModExpr(modExpr, cmtTbl), - }) - let loc = {...expr.pexp_loc, loc_end: modExpr.pmod_loc.loc_end} - collectRows(list{(loc, letModuleDoc), ...acc}, expr2) - | Pexp_letexception(extensionConstructor, expr2) => - let loc = { - let loc = {...expr.pexp_loc, loc_end: extensionConstructor.pext_loc.loc_end} - switch getFirstLeadingComment(cmtTbl, loc) { - | None => loc - | Some(comment) => - let cmtLoc = Comment.loc(comment) - {...cmtLoc, loc_end: loc.loc_end} - } - } - - let letExceptionDoc = printExceptionDef(extensionConstructor, cmtTbl) - collectRows(list{(loc, letExceptionDoc), ...acc}, expr2) - | Pexp_open(overrideFlag, longidentLoc, expr2) => - let openDoc = Doc.concat(list{ - Doc.text("open"), - printOverrideFlag(overrideFlag), - Doc.space, - printLongidentLocation(longidentLoc, cmtTbl), - }) - let loc = {...expr.pexp_loc, loc_end: longidentLoc.loc.loc_end} - collectRows(list{(loc, openDoc), ...acc}, expr2) - | Pexp_sequence(expr1, expr2) => - let exprDoc = { - let doc = printExpression(expr1, cmtTbl) - switch Parens.expr(expr1) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr1, braces) - | Nothing => doc - } - } - - let loc = expr1.pexp_loc - collectRows(list{(loc, exprDoc), ...acc}, expr2) - | Pexp_let(recFlag, valueBindings, expr2) => - let loc = { - let loc = switch (valueBindings, List.rev(valueBindings)) { - | (list{vb, ..._}, list{lastVb, ..._}) => {...vb.pvb_loc, loc_end: lastVb.pvb_loc.loc_end} - | _ => Location.none - } - - switch getFirstLeadingComment(cmtTbl, loc) { - | None => loc - | Some(comment) => - let cmtLoc = Comment.loc(comment) - {...cmtLoc, loc_end: loc.loc_end} - } - } - - let recFlag = switch recFlag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - let letDoc = printValueBindings(~recFlag, valueBindings, cmtTbl) - /* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - */ - switch expr2.pexp_desc { - | Pexp_construct({txt: Longident.Lident("()")}, _) => List.rev(list{(loc, letDoc), ...acc}) - | _ => collectRows(list{(loc, letDoc), ...acc}, expr2) - } - | _ => - let exprDoc = { - let doc = printExpression(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - } - - List.rev(list{(expr.pexp_loc, exprDoc), ...acc}) - } - - let rows = collectRows(list{}, expr) - let block = printList( - ~getLoc=fst, - ~nodes=rows, - ~print=((_, doc), _) => doc, - ~forceBreak=true, - cmtTbl, - ) - - Doc.breakableGroup( - ~forceBreak=true, - if braces { - Doc.concat(list{ - Doc.lbrace, - Doc.indent(Doc.concat(list{Doc.line, block})), - Doc.line, - Doc.rbrace, - }) - } else { - block - }, - ) - } - - /* - * // user types: - * let f = (a, b) => { a + b } - * - * // printer: everything is on one line - * let f = (a, b) => { a + b } - * - * // user types: over multiple lines - * let f = (a, b) => { - * a + b - * } - * - * // printer: over multiple lines - * let f = (a, b) => { - * a + b - * } - */ - and printBraces = (doc, expr, bracesLoc) => { - let overMultipleLines = { - open Location - bracesLoc.loc_end.pos_lnum > bracesLoc.loc_start.pos_lnum - } - - switch expr.Parsetree.pexp_desc { - | Pexp_letmodule(_) - | Pexp_letexception(_) - | Pexp_let(_) - | Pexp_open(_) - | Pexp_sequence(_) => /* already has braces */ - doc - | _ => - Doc.breakableGroup( - ~forceBreak=overMultipleLines, - Doc.concat(list{ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - if Parens.bracedExpr(expr) { - addParens(doc) - } else { - doc - }, - }), - ), - Doc.softLine, - Doc.rbrace, - }), - ) - } - } - - and printOverrideFlag = overrideFlag => - switch overrideFlag { - | Asttypes.Override => Doc.text("!") - | Fresh => Doc.nil - } - - and printDirectionFlag = flag => - switch flag { - | Asttypes.Downto => Doc.text(" downto ") - | Asttypes.Upto => Doc.text(" to ") - } - - and printRecordRow = ((lbl, expr), cmtTbl) => { - let cmtLoc = {...lbl.loc, loc_end: expr.pexp_loc.loc_end} - let doc = Doc.group( - Doc.concat(list{ - printLidentPath(lbl, cmtTbl), - Doc.text(": "), - { - let doc = printExpressionWithComments(expr, cmtTbl) - switch Parens.expr(expr) { - | Parens.Parenthesized => addParens(doc) - | Braced(braces) => printBraces(doc, expr, braces) - | Nothing => doc - } - }, - }), - ) - printComments(doc, cmtTbl, cmtLoc) - } - - and printBsObjectRow = ((lbl, expr), cmtTbl) => { - let cmtLoc = {...lbl.loc, loc_end: expr.pexp_loc.loc_end} - let lblDoc = { - let doc = Doc.concat(list{Doc.text("\""), printLongident(lbl.txt), Doc.text("\"")}) - printComments(doc, cmtTbl, lbl.loc) - } - - let doc = Doc.concat(list{lblDoc, Doc.text(": "), printExpressionWithComments(expr, cmtTbl)}) - printComments(doc, cmtTbl, cmtLoc) - } - - /* The optional loc indicates whether we need to print the attributes in - * relation to some location. In practise this means the following: - * `@attr type t = string` -> on the same line, print on the same line - * `@attr - * type t = string` -> attr is on prev line, print the attributes - * with a line break between, we respect the users' original layout */ - and printAttributes = (~loc=?, attrs: Parsetree.attributes) => - switch ParsetreeViewer.filterParsingAttrs(attrs) { - | list{} => Doc.nil - | attrs => - let lineBreak = switch loc { - | None => Doc.line - | Some(loc) => - switch List.rev(attrs) { - | list{({loc: firstLoc}, _), ..._} - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum => Doc.hardLine - | _ => Doc.line - } - } - - Doc.concat(list{ - Doc.group(Doc.join(~sep=Doc.line, List.map(printAttribute, attrs))), - lineBreak, - }) - } - - and printAttribute = ((id, payload): Parsetree.attribute) => { - let attrName = Doc.concat(list{Doc.text("@"), Doc.text(id.txt)}) - switch payload { - | PStr(list{{pstr_desc: Pstr_eval(expr, attrs)}}) => - let exprDoc = printExpression(expr, CommentTable.empty) - let needsParens = switch attrs { - | list{} => false - | _ => true - } - Doc.group( - Doc.concat(list{ - attrName, - addParens( - Doc.concat(list{ - printAttributes(attrs), - if needsParens { - addParens(exprDoc) - } else { - exprDoc - }, - }), - ), - }), - ) - | PTyp(typ) => - Doc.group( - Doc.concat(list{ - attrName, - Doc.lparen, - Doc.indent( - Doc.concat(list{Doc.softLine, Doc.text(": "), printTypExpr(typ, CommentTable.empty)}), - ), - Doc.softLine, - Doc.rparen, - }), - ) - | _ => attrName - } - } - - and printAttributeWithComments = ((id, payload): Parsetree.attribute, cmtTbl) => { - let attrName = Doc.text("@" ++ id.txt) - switch payload { - | PStr(list{{pstr_desc: Pstr_eval(expr, attrs)}}) => - let exprDoc = printExpressionWithComments(expr, cmtTbl) - let needsParens = switch attrs { - | list{} => false - | _ => true - } - Doc.group( - Doc.concat(list{ - attrName, - addParens( - Doc.concat(list{ - printAttributes(attrs), - if needsParens { - addParens(exprDoc) - } else { - exprDoc - }, - }), - ), - }), - ) - | _ => attrName - } - } - - and printModExpr = (modExpr, cmtTbl) => { - let doc = switch modExpr.pmod_desc { - | Pmod_ident(longidentLoc) => printLongidentLocation(longidentLoc, cmtTbl) - | Pmod_structure(structure) => - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.lbrace, - Doc.indent(Doc.concat(list{Doc.softLine, printStructure(structure, cmtTbl)})), - Doc.softLine, - Doc.rbrace, - }), - ) - | Pmod_unpack(expr) => - let shouldHug = switch expr.pexp_desc { - | Pexp_let(_) => true - | Pexp_constraint({pexp_desc: Pexp_let(_)}, {ptyp_desc: Ptyp_package(_packageType)}) => true - | _ => false - } - - let (expr, moduleConstraint) = switch expr.pexp_desc { - | Pexp_constraint(expr, {ptyp_desc: Ptyp_package(packageType), ptyp_loc}) => - let packageDoc = { - let doc = printPackageType(~printModuleKeywordAndParens=false, packageType, cmtTbl) - printComments(doc, cmtTbl, ptyp_loc) - } - - let typeDoc = Doc.group( - Doc.concat(list{Doc.text(":"), Doc.indent(Doc.concat(list{Doc.line, packageDoc}))}), - ) - (expr, typeDoc) - | _ => (expr, Doc.nil) - } - - let unpackDoc = Doc.group( - Doc.concat(list{printExpressionWithComments(expr, cmtTbl), moduleConstraint}), - ) - Doc.group( - Doc.concat(list{ - Doc.text("unpack("), - if shouldHug { - unpackDoc - } else { - Doc.concat(list{Doc.indent(Doc.concat(list{Doc.softLine, unpackDoc})), Doc.softLine}) - }, - Doc.rparen, - }), - ) - | Pmod_extension(extension) => printExtensionWithComments(~atModuleLvl=false, extension, cmtTbl) - | Pmod_apply(_) => - let (args, callExpr) = ParsetreeViewer.modExprApply(modExpr) - let isUnitSugar = switch args { - | list{{pmod_desc: Pmod_structure(list{})}} => true - | _ => false - } - - let shouldHug = switch args { - | list{{pmod_desc: Pmod_structure(_)}} => true - | _ => false - } - - Doc.group( - Doc.concat(list{ - printModExpr(callExpr, cmtTbl), - if isUnitSugar { - printModApplyArg(@doesNotRaise List.hd(args), cmtTbl) - } else { - Doc.concat(list{ - Doc.lparen, - if shouldHug { - printModApplyArg(@doesNotRaise List.hd(args), cmtTbl) - } else { - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(modArg => printModApplyArg(modArg, cmtTbl), args), - ), - }), - ) - }, - if !shouldHug { - Doc.concat(list{Doc.trailingComma, Doc.softLine}) - } else { - Doc.nil - }, - Doc.rparen, - }) - }, - }), - ) - | Pmod_constraint(modExpr, modType) => - Doc.concat(list{printModExpr(modExpr, cmtTbl), Doc.text(": "), printModType(modType, cmtTbl)}) - | Pmod_functor(_) => printModFunctor(modExpr, cmtTbl) - } - - printComments(doc, cmtTbl, modExpr.pmod_loc) - } - - and printModFunctor = (modExpr, cmtTbl) => { - let (parameters, returnModExpr) = ParsetreeViewer.modExprFunctor(modExpr) - /* let shouldInline = match returnModExpr.pmod_desc with */ - /* | Pmod_structure _ | Pmod_ident _ -> true */ - /* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true */ - /* | _ -> false */ - /* in */ - let (returnConstraint, returnModExpr) = switch returnModExpr.pmod_desc { - | Pmod_constraint(modExpr, modType) => - let constraintDoc = { - let doc = printModType(modType, cmtTbl) - if Parens.modExprFunctorConstraint(modType) { - addParens(doc) - } else { - doc - } - } - - let modConstraint = Doc.concat(list{Doc.text(": "), constraintDoc}) - (modConstraint, printModExpr(modExpr, cmtTbl)) - | _ => (Doc.nil, printModExpr(returnModExpr, cmtTbl)) - } - - let parametersDoc = switch parameters { - | list{(attrs, {txt: "*"}, None)} => - let attrs = switch attrs { - | list{} => Doc.nil - | attrs => - Doc.concat(list{Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), Doc.line}) - } - Doc.group(Doc.concat(list{attrs, Doc.text("()")})) - | list{(list{}, {txt: lbl}, None)} => Doc.text(lbl) - | parameters => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(param => printModFunctorParam(param, cmtTbl), parameters), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - } - - Doc.group(Doc.concat(list{parametersDoc, returnConstraint, Doc.text(" => "), returnModExpr})) - } - - and printModFunctorParam = ((attrs, lbl, optModType), cmtTbl) => { - let cmtLoc = switch optModType { - | None => lbl.Asttypes.loc - | Some(modType) => { - ...lbl.loc, - loc_end: modType.Parsetree.pmty_loc.loc_end, - } - } - - let attrs = switch attrs { - | list{} => Doc.nil - | attrs => Doc.concat(list{Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), Doc.line}) - } - let lblDoc = { - let doc = Doc.text(lbl.txt) - printComments(doc, cmtTbl, lbl.loc) - } - - let doc = Doc.group( - Doc.concat(list{ - attrs, - lblDoc, - switch optModType { - | None => Doc.nil - | Some(modType) => Doc.concat(list{Doc.text(": "), printModType(modType, cmtTbl)}) - }, - }), - ) - printComments(doc, cmtTbl, cmtLoc) - } - - and printModApplyArg = (modExpr, cmtTbl) => - switch modExpr.pmod_desc { - | Pmod_structure(list{}) => Doc.text("()") - | _ => printModExpr(modExpr, cmtTbl) - } - - and printExceptionDef = (constr: Parsetree.extension_constructor, cmtTbl) => { - let kind = switch constr.pext_kind { - | Pext_rebind(longident) => - Doc.indent( - Doc.concat(list{Doc.text(" ="), Doc.line, printLongidentLocation(longident, cmtTbl)}), - ) - | Pext_decl(Pcstr_tuple(list{}), None) => Doc.nil - | Pext_decl(args, gadt) => - let gadtDoc = switch gadt { - | Some(typ) => Doc.concat(list{Doc.text(": "), printTypExpr(typ, cmtTbl)}) - | None => Doc.nil - } - - Doc.concat(list{printConstructorArguments(~indent=false, args, cmtTbl), gadtDoc}) - } - - let name = printComments(Doc.text(constr.pext_name.txt), cmtTbl, constr.pext_name.loc) - - let doc = Doc.group( - Doc.concat(list{printAttributes(constr.pext_attributes), Doc.text("exception "), name, kind}), - ) - printComments(doc, cmtTbl, constr.pext_loc) - } - - and printExtensionConstructor = (constr: Parsetree.extension_constructor, cmtTbl, i) => { - let attrs = printAttributes(constr.pext_attributes) - let bar = if i > 0 { - Doc.text("| ") - } else { - Doc.ifBreaks(Doc.text("| "), Doc.nil) - } - - let kind = switch constr.pext_kind { - | Pext_rebind(longident) => - Doc.indent( - Doc.concat(list{Doc.text(" ="), Doc.line, printLongidentLocation(longident, cmtTbl)}), - ) - | Pext_decl(Pcstr_tuple(list{}), None) => Doc.nil - | Pext_decl(args, gadt) => - let gadtDoc = switch gadt { - | Some(typ) => Doc.concat(list{Doc.text(": "), printTypExpr(typ, cmtTbl)}) - | None => Doc.nil - } - - Doc.concat(list{printConstructorArguments(~indent=false, args, cmtTbl), gadtDoc}) - } - - let name = printComments(Doc.text(constr.pext_name.txt), cmtTbl, constr.pext_name.loc) - - Doc.concat(list{bar, Doc.group(Doc.concat(list{attrs, name, kind}))}) - } - - let printImplementation = (~width, s: Parsetree.structure, comments) => { - let cmtTbl = CommentTable.make() - CommentTable.walkStructure(s, cmtTbl, comments) - /* CommentTable.log cmtTbl; */ - let doc = printStructure(s, cmtTbl) - /* Doc.debug doc; */ - let stringDoc = Doc.toString(~width, doc) - print_string(stringDoc) - } - - let printInterface = (~width, s: Parsetree.signature, comments) => { - let cmtTbl = CommentTable.make() - CommentTable.walkSignature(s, cmtTbl, comments) - let stringDoc = Doc.toString(~width, printSignature(s, cmtTbl)) - print_string(stringDoc) - } -} - -module Scanner = { - type mode = Template | Jsx | Diamond - - type t = { - filename: string, - src: bytes, - mutable err: ( - ~startPos: Lexing.position, - ~endPos: Lexing.position, - Diagnostics.category, - ) => unit, - mutable ch: int /* current character */, - mutable offset: int /* character offset */, - mutable rdOffset: int /* reading offset (position after current character) */, - mutable lineOffset: int /* current line offset */, - mutable lnum: int /* current line number */, - mutable mode: list, - } - - let setDiamondMode = scanner => scanner.mode = list{Diamond, ...scanner.mode} - - let setTemplateMode = scanner => scanner.mode = list{Template, ...scanner.mode} - - let setJsxMode = scanner => scanner.mode = list{Jsx, ...scanner.mode} - - let popMode = (scanner, mode) => - switch scanner.mode { - | list{m, ...ms} when m == mode => scanner.mode = ms - | _ => () - } - - let inDiamondMode = scanner => - switch scanner.mode { - | list{Diamond, ..._} => true - | _ => false - } - - let inJsxMode = scanner => - switch scanner.mode { - | list{Jsx, ..._} => true - | _ => false - } - - let inTemplateMode = scanner => - switch scanner.mode { - | list{Template, ..._} => true - | _ => false - } - - let position = scanner => { - open Lexing - { - pos_fname: scanner.filename, - /* line number */ - pos_lnum: scanner.lnum, - /* offset of the beginning of the line (number - of characters between the beginning of the scanner and the beginning - of the line) */ - pos_bol: scanner.lineOffset, - /* [pos_cnum] is the offset of the position (number of - characters between the beginning of the scanner and the position). */ - pos_cnum: scanner.offset, - } - } - - let next = scanner => - if scanner.rdOffset < Bytes.length(scanner.src) { - scanner.offset = scanner.rdOffset - let ch = (@doesNotRaise Bytes.get)(scanner.src, scanner.rdOffset) - scanner.rdOffset = scanner.rdOffset + 1 - scanner.ch = int_of_char(ch) - } else { - scanner.offset = Bytes.length(scanner.src) - scanner.ch = -1 - } - - let peek = scanner => - if scanner.rdOffset < Bytes.length(scanner.src) { - int_of_char(Bytes.unsafe_get(scanner.src, scanner.rdOffset)) - } else { - -1 - } - - let make = (b, filename) => { - let scanner = { - filename: filename, - src: b, - err: (~startPos as _, ~endPos as _, _) => (), - ch: CharacterCodes.space, - offset: 0, - rdOffset: 0, - lineOffset: 0, - lnum: 1, - mode: list{}, - } - next(scanner) - scanner - } - - let skipWhitespace = scanner => { - let rec scan = () => - if scanner.ch === CharacterCodes.space || scanner.ch === CharacterCodes.tab { - next(scanner) - scan() - } else if CharacterCodes.isLineBreak(scanner.ch) { - scanner.lineOffset = scanner.offset + 1 - scanner.lnum = scanner.lnum + 1 - next(scanner) - scan() - } else { - () - } - - scan() - } - - let scanIdentifier = scanner => { - let startOff = scanner.offset - while ( - CharacterCodes.isLetter(scanner.ch) || - (CharacterCodes.isDigit(scanner.ch) || - (CharacterCodes.underscore === scanner.ch || CharacterCodes.singleQuote === scanner.ch)) - ) { - next(scanner) - } - let str = Bytes.sub_string(scanner.src, startOff, scanner.offset - startOff) - Token.lookupKeyword(str) - } - - let scanDigits = (scanner, ~base) => - if base <= 10 { - while CharacterCodes.isDigit(scanner.ch) || scanner.ch === CharacterCodes.underscore { - next(scanner) - } - } else { - while CharacterCodes.isHex(scanner.ch) || scanner.ch === CharacterCodes.underscore { - next(scanner) - } - } - - /* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] */ - let scanNumber = scanner => { - let startOff = scanner.offset - - /* integer part */ - let (base, _prefix) = if scanner.ch !== CharacterCodes.dot { - if scanner.ch === CharacterCodes._0 { - next(scanner) - let ch = CharacterCodes.lower(scanner.ch) - if ch === CharacterCodes.Lower.x { - next(scanner) - (16, 'x') - } else if ch === CharacterCodes.Lower.o { - next(scanner) - (8, 'o') - } else if ch === CharacterCodes.Lower.b { - next(scanner) - (2, 'b') - } else { - (8, '0') - } - } else { - (10, ' ') - } - } else { - (10, ' ') - } - - scanDigits(scanner, ~base) - - /* */ - let isFloat = if CharacterCodes.dot === scanner.ch { - next(scanner) - scanDigits(scanner, ~base) - true - } else { - false - } - - /* exponent part */ - let isFloat = if { - let exp = CharacterCodes.lower(scanner.ch) - exp === CharacterCodes.Lower.e || exp === CharacterCodes.Lower.p - } { - next(scanner) - if scanner.ch === CharacterCodes.plus || scanner.ch === CharacterCodes.minus { - next(scanner) - } - scanDigits(scanner, ~base) - true - } else { - isFloat - } - - let literal = Bytes.sub_string(scanner.src, startOff, scanner.offset - startOff) - - /* suffix */ - let suffix = if ( - (scanner.ch >= CharacterCodes.Lower.g && scanner.ch <= CharacterCodes.Lower.z) || - (scanner.ch >= CharacterCodes.Upper.g && scanner.ch <= CharacterCodes.Upper.z) - ) { - let ch = scanner.ch - next(scanner) - Some(Char.unsafe_chr(ch)) - } else { - None - } - - if isFloat { - Token.Float({f: literal, suffix: suffix}) - } else { - Token.Int({i: literal, suffix: suffix}) - } - } - - let scanExoticIdentifier = scanner => { - next(scanner) - let buffer = Buffer.create(20) - let startPos = position(scanner) - - let rec scan = () => - if scanner.ch === CharacterCodes.eof { - let endPos = position(scanner) - scanner.err(~startPos, ~endPos, Diagnostics.message("Did you forget a \" here?")) - } else if scanner.ch === CharacterCodes.doubleQuote { - next(scanner) - } else if CharacterCodes.isLineBreak(scanner.ch) { - scanner.lineOffset = scanner.offset + 1 - scanner.lnum = scanner.lnum + 1 - let endPos = position(scanner) - scanner.err(~startPos, ~endPos, Diagnostics.message("Did you forget a \" here?")) - next(scanner) - } else { - Buffer.add_char(buffer, (@doesNotRaise Char.chr)(scanner.ch)) - next(scanner) - scan() - } - - scan() - Token.Lident(Buffer.contents(buffer)) - } - - let scanStringEscapeSequence = (~startPos, scanner) => - /* \ already consumed */ - if ( - CharacterCodes.Lower.n === scanner.ch || - (CharacterCodes.Lower.t === scanner.ch || - (CharacterCodes.Lower.b === scanner.ch || - (CharacterCodes.Lower.r === scanner.ch || - (CharacterCodes.backslash === scanner.ch || - (CharacterCodes.space === scanner.ch || - (CharacterCodes.singleQuote === scanner.ch || - CharacterCodes.doubleQuote === scanner.ch)))))) - ) { - next(scanner) - } else { - let (n, base, max) = if CharacterCodes.isDigit(scanner.ch) { - /* decimal */ - (3, 10, 255) - } else if scanner.ch === CharacterCodes.Lower.o { - /* octal */ - let () = next(scanner) - (3, 8, 255) - } else if scanner.ch === CharacterCodes.Lower.x { - /* hex */ - let () = next(scanner) - (2, 16, 255) - } else { - /* unknown escape sequence - * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat */ - /* let pos = position scanner in */ - /* let () = */ - /* let msg = if scanner.ch == -1 then */ - /* "unclosed escape sequence" */ - /* else "unknown escape sequence" */ - /* in */ - /* scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) */ - /* in */ - (-1, -1, -1) - } - - if n < 0 { - () - } else { - let rec while_ = (n, x) => - if n === 0 { - x - } else { - let d = CharacterCodes.digitValue(scanner.ch) - if d >= base { - let pos = position(scanner) - let msg = if scanner.ch === -1 { - "unclosed escape sequence" - } else { - "unknown escape sequence" - } - - scanner.err(~startPos, ~endPos=pos, Diagnostics.message(msg)) - -1 - } else { - let () = next(scanner) - while_(n - 1, x * base + d) - } - } - - let x = while_(n, 0) - if x > max { - let pos = position(scanner) - let msg = "invalid escape sequence (value too high)" - scanner.err(~startPos, ~endPos=pos, Diagnostics.message(msg)) - () - } - } - } - - let scanString = scanner => { - let offs = scanner.offset - - let startPos = position(scanner) - let rec scan = () => - if scanner.ch === CharacterCodes.eof { - let endPos = position(scanner) - scanner.err(~startPos, ~endPos, Diagnostics.unclosedString) - } else if scanner.ch === CharacterCodes.doubleQuote { - next(scanner) - } else if scanner.ch === CharacterCodes.backslash { - let startPos = position(scanner) - next(scanner) - scanStringEscapeSequence(~startPos, scanner) - scan() - } else if CharacterCodes.isLineBreak(scanner.ch) { - scanner.lineOffset = scanner.offset + 1 - scanner.lnum = scanner.lnum + 1 - next(scanner) - scan() - } else { - next(scanner) - scan() - } - - scan() - Token.String(Bytes.sub_string(scanner.src, offs, scanner.offset - offs - 1)) - } - - /* I wonder if this gets inlined */ - let convertNumber = (scanner, ~n, ~base) => { - let x = ref(0) - for _ in n downto 1 { - let d = CharacterCodes.digitValue(scanner.ch) - x := x.contents * base + d - next(scanner) - } - x.contents - } - - let scanEscape = scanner => { - /* let offset = scanner.offset in */ - let c = switch scanner.ch { - | 98 /* b */ => - next(scanner) - '\b' - | 110 /* n */ => - next(scanner) - '\n' - | 114 /* r */ => - next(scanner) - '\r' - | 116 /* t */ => - next(scanner) - '\t' - | ch when CharacterCodes.isDigit(ch) => - let x = convertNumber(scanner, ~n=3, ~base=10) - (@doesNotRaise Char.chr)(x) - | ch when ch === CharacterCodes.Lower.x => - next(scanner) - let x = convertNumber(scanner, ~n=2, ~base=16) - (@doesNotRaise Char.chr)(x) - | ch when ch === CharacterCodes.Lower.o => - next(scanner) - let x = convertNumber(scanner, ~n=3, ~base=8) - (@doesNotRaise Char.chr)(x) - | ch => - next(scanner) - (@doesNotRaise Char.chr)(ch) - } - - next(scanner) /* Consume \' */ - Token.Character(c) - } - - let scanSingleLineComment = scanner => { - let startOff = scanner.offset - let startPos = position(scanner) - while !CharacterCodes.isLineBreak(scanner.ch) && scanner.ch >= 0 { - next(scanner) - } - let endPos = position(scanner) - Token.Comment( - Comment.makeSingleLineComment( - ~loc={ - open Location - {loc_start: startPos, loc_end: endPos, loc_ghost: false} - }, - Bytes.sub_string(scanner.src, startOff, scanner.offset - startOff), - ), - ) - } - - let scanMultiLineComment = scanner => { - let startOff = scanner.offset - let startPos = position(scanner) - let rec scan = (~depth, ()) => - if scanner.ch === CharacterCodes.asterisk && peek(scanner) === CharacterCodes.forwardslash { - next(scanner) - next(scanner) - if depth > 0 { - scan(~depth=depth - 1, ()) - } else { - () - } - } else if scanner.ch === CharacterCodes.eof { - let endPos = position(scanner) - scanner.err(~startPos, ~endPos, Diagnostics.unclosedComment) - } else if ( - scanner.ch === CharacterCodes.forwardslash && peek(scanner) === CharacterCodes.asterisk - ) { - next(scanner) - next(scanner) - scan(~depth=depth + 1, ()) - } else { - if CharacterCodes.isLineBreak(scanner.ch) { - scanner.lineOffset = scanner.offset + 1 - scanner.lnum = scanner.lnum + 1 - } - next(scanner) - scan(~depth, ()) - } - - scan(~depth=0, ()) - Token.Comment( - Comment.makeMultiLineComment( - ~loc={ - open Location - {loc_start: startPos, loc_end: position(scanner), loc_ghost: false} - }, - Bytes.sub_string(scanner.src, startOff, scanner.offset - 2 - startOff), - ), - ) - } - - let scanTemplate = scanner => { - let startOff = scanner.offset - let startPos = position(scanner) - - let rec scan = () => - if scanner.ch === CharacterCodes.eof { - let endPos = position(scanner) - scanner.err(~startPos, ~endPos, Diagnostics.unclosedTemplate) - popMode(scanner, Template) - Token.TemplateTail(Bytes.sub_string(scanner.src, startOff, scanner.offset - 2 - startOff)) - } else if scanner.ch === CharacterCodes.backslash { - next(scanner) - if ( - scanner.ch === CharacterCodes.backtick || - (scanner.ch === CharacterCodes.backslash || - scanner.ch === CharacterCodes.dollar) - ) { - next(scanner) - } - scan() - } else if scanner.ch === CharacterCodes.backtick { - next(scanner) - let contents = Bytes.sub_string(scanner.src, startOff, scanner.offset - 1 - startOff) - - popMode(scanner, Template) - Token.TemplateTail(contents) - } else if scanner.ch === CharacterCodes.dollar && peek(scanner) === CharacterCodes.lbrace { - next(scanner) /* consume $ */ - next(scanner) /* consume { */ - let contents = Bytes.sub_string(scanner.src, startOff, scanner.offset - 2 - startOff) - - popMode(scanner, Template) - Token.TemplatePart(contents) - } else { - if CharacterCodes.isLineBreak(scanner.ch) { - scanner.lineOffset = scanner.offset + 1 - scanner.lnum = scanner.lnum + 1 - } - next(scanner) - scan() - } - - scan() - } - - let rec scan = scanner => { - if !inTemplateMode(scanner) { - skipWhitespace(scanner) - } - let startPos = position(scanner) - let ch = scanner.ch - let token = if inTemplateMode(scanner) { - scanTemplate(scanner) - } else if ch === CharacterCodes.underscore { - let nextCh = peek(scanner) - if ( - nextCh === CharacterCodes.underscore || - (CharacterCodes.isDigit(nextCh) || - CharacterCodes.isLetter(nextCh)) - ) { - scanIdentifier(scanner) - } else { - next(scanner) - Token.Underscore - } - } else if CharacterCodes.isLetter(ch) { - scanIdentifier(scanner) - } else if CharacterCodes.isDigit(ch) { - scanNumber(scanner) - } else { - next(scanner) - if ch === CharacterCodes.dot { - if scanner.ch === CharacterCodes.dot { - next(scanner) - if scanner.ch === CharacterCodes.dot { - next(scanner) - Token.DotDotDot - } else { - Token.DotDot - } - } else { - Token.Dot - } - } else if ch === CharacterCodes.doubleQuote { - scanString(scanner) - } else if ch === CharacterCodes.singleQuote { - if ( - scanner.ch === CharacterCodes.backslash && !(peek(scanner) === CharacterCodes.doubleQuote) - ) { - /* start of exotic ident */ - - next(scanner) - scanEscape(scanner) - } else if peek(scanner) === CharacterCodes.singleQuote { - let ch = scanner.ch - next(scanner) - next(scanner) - Token.Character((@doesNotRaise Char.chr)(ch)) - } else { - SingleQuote - } - } else if ch === CharacterCodes.bang { - if scanner.ch === CharacterCodes.equal { - next(scanner) - if scanner.ch === CharacterCodes.equal { - next(scanner) - Token.BangEqualEqual - } else { - Token.BangEqual - } - } else { - Token.Bang - } - } else if ch === CharacterCodes.semicolon { - Token.Semicolon - } else if ch === CharacterCodes.equal { - if scanner.ch === CharacterCodes.greaterThan { - next(scanner) - Token.EqualGreater - } else if scanner.ch === CharacterCodes.equal { - next(scanner) - if scanner.ch === CharacterCodes.equal { - next(scanner) - Token.EqualEqualEqual - } else { - Token.EqualEqual - } - } else { - Token.Equal - } - } else if ch === CharacterCodes.bar { - if scanner.ch === CharacterCodes.bar { - next(scanner) - Token.Lor - } else if scanner.ch === CharacterCodes.greaterThan { - next(scanner) - Token.BarGreater - } else { - Token.Bar - } - } else if ch === CharacterCodes.ampersand { - if scanner.ch === CharacterCodes.ampersand { - next(scanner) - Token.Land - } else { - Token.Band - } - } else if ch === CharacterCodes.lparen { - Token.Lparen - } else if ch === CharacterCodes.rparen { - Token.Rparen - } else if ch === CharacterCodes.lbracket { - Token.Lbracket - } else if ch === CharacterCodes.rbracket { - Token.Rbracket - } else if ch === CharacterCodes.lbrace { - Token.Lbrace - } else if ch === CharacterCodes.rbrace { - Token.Rbrace - } else if ch === CharacterCodes.comma { - Token.Comma - } else if ch === CharacterCodes.colon { - if scanner.ch === CharacterCodes.equal { - next(scanner) - Token.ColonEqual - } else if scanner.ch === CharacterCodes.greaterThan { - next(scanner) - Token.ColonGreaterThan - } else { - Token.Colon - } - } else if ch === CharacterCodes.backslash { - scanExoticIdentifier(scanner) - } else if ch === CharacterCodes.forwardslash { - if scanner.ch === CharacterCodes.forwardslash { - next(scanner) - scanSingleLineComment(scanner) - } else if scanner.ch === CharacterCodes.asterisk { - next(scanner) - scanMultiLineComment(scanner) - } else if scanner.ch === CharacterCodes.dot { - next(scanner) - Token.ForwardslashDot - } else { - Token.Forwardslash - } - } else if ch === CharacterCodes.minus { - if scanner.ch === CharacterCodes.dot { - next(scanner) - Token.MinusDot - } else if scanner.ch === CharacterCodes.greaterThan { - next(scanner) - Token.MinusGreater - } else { - Token.Minus - } - } else if ch === CharacterCodes.plus { - if scanner.ch === CharacterCodes.dot { - next(scanner) - Token.PlusDot - } else if scanner.ch === CharacterCodes.plus { - next(scanner) - Token.PlusPlus - } else if scanner.ch === CharacterCodes.equal { - next(scanner) - Token.PlusEqual - } else { - Token.Plus - } - } else if ch === CharacterCodes.greaterThan { - if scanner.ch === CharacterCodes.equal && !inDiamondMode(scanner) { - next(scanner) - Token.GreaterEqual - } else { - Token.GreaterThan - } - } else if ch === CharacterCodes.lessThan { - /* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the < - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate */ - let reconsiderLessThan = scanner => { - /* < consumed */ - skipWhitespace(scanner) - if scanner.ch === CharacterCodes.forwardslash { - let () = next(scanner) - Token.LessThanSlash - } else { - Token.LessThan - } - } - - /* If an operator has whitespace around both sides, it's a binary operator */ - let isBinaryOp = (src, startCnum, endCnum) => - if startCnum === 0 { - false - } else { - let leftOk = { - let c = startCnum - 1 |> (@doesNotRaise Bytes.get)(src) |> Char.code - - c === CharacterCodes.space || (c === CharacterCodes.tab || CharacterCodes.isLineBreak(c)) - } - - let rightOk = { - let c = if endCnum === Bytes.length(src) { - -1 - } else { - endCnum |> (@doesNotRaise Bytes.get)(src) |> Char.code - } - - c === CharacterCodes.space || - (c === CharacterCodes.tab || - (CharacterCodes.isLineBreak(c) || c === CharacterCodes.eof)) - } - - leftOk && rightOk - } -} - -/* AST for js externals */ -module JsFfi = { - type scope = - | Global - | Module(string) /* bs.module("path") */ - | Scope(Longident.t) /* bs.scope(/"window", "location"/) */ - - type label_declaration = { - @live jld_attributes: Parsetree.attributes, - jld_name: string, - jld_alias: string, - jld_type: Parsetree.core_type, - jld_loc: Location.t, - } - - type importSpec = - | Default(label_declaration) - | Spec(list) - - type import_description = { - jid_loc: Location.t, - jid_spec: importSpec, - jid_scope: scope, - jid_attributes: Parsetree.attributes, - } - - let decl = (~attrs, ~loc, ~name, ~alias, ~typ) => { - jld_loc: loc, - jld_attributes: attrs, - jld_name: name, - jld_alias: alias, - jld_type: typ, - } - - let importDescr = (~attrs, ~scope, ~importSpec, ~loc) => { - jid_loc: loc, - jid_spec: importSpec, - jid_scope: scope, - jid_attributes: attrs, - } - - let toParsetree = importDescr => { - let bsVal = (Location.mknoloc("bs.val"), Parsetree.PStr(list{})) - let attrs = switch importDescr.jid_scope { - | Global => list{bsVal} - /* @genType.import("./MyMath"), - * @genType.import(/"./MyMath", "default"/) */ - | Module(s) => - let structure = list{ - Parsetree.Pconst_string(s, None) |> Ast_helper.Exp.constant |> Ast_helper.Str.eval, - } - let genType = (Location.mknoloc("genType.import"), Parsetree.PStr(structure)) - list{genType} - | Scope(longident) => - let structureItem = { - let expr = switch Longident.flatten(longident) |> List.map(s => - Ast_helper.Exp.constant(Parsetree.Pconst_string(s, None)) - ) { - | list{expr} => expr - | list{} as exprs | _ as exprs => exprs |> Ast_helper.Exp.tuple - } - - Ast_helper.Str.eval(expr) - } - - let bsScope = (Location.mknoloc("bs.scope"), Parsetree.PStr(list{structureItem})) - list{bsVal, bsScope} - } - - let valueDescrs = switch importDescr.jid_spec { - | Default(decl) => - let prim = list{decl.jld_name} - let allAttrs = List.concat(list{attrs, importDescr.jid_attributes}) |> List.map(attr => - switch attr { - | ( - {Location.txt: "genType.import"} as id, - Parsetree.PStr(list{{pstr_desc: Parsetree.Pstr_eval(moduleName, _)}}), - ) => - let default = Parsetree.Pconst_string("default", None) |> Ast_helper.Exp.constant - - let structureItem = - list{moduleName, default} |> Ast_helper.Exp.tuple |> Ast_helper.Str.eval - - (id, Parsetree.PStr(list{structureItem})) - | attr => attr - } - ) - - list{ - Ast_helper.Val.mk( - ~loc=importDescr.jid_loc, - ~prim, - ~attrs=allAttrs, - Location.mknoloc(decl.jld_alias), - decl.jld_type, - ) |> Ast_helper.Str.primitive, - } - | Spec(decls) => List.map(decl => { - let prim = list{decl.jld_name} - let allAttrs = List.concat(list{attrs, decl.jld_attributes}) - Ast_helper.Val.mk( - ~loc=importDescr.jid_loc, - ~prim, - ~attrs=allAttrs, - Location.mknoloc(decl.jld_alias), - decl.jld_type, - ) |> Ast_helper.Str.primitive(~loc=decl.jld_loc) - }, decls) - } - - let jsFfiAttr = (Location.mknoloc("ns.jsFfi"), Parsetree.PStr(list{})) - Ast_helper.Mod.structure(~loc=importDescr.jid_loc, valueDescrs) - |> Ast_helper.Incl.mk(~attrs=list{jsFfiAttr}, ~loc=importDescr.jid_loc) - |> Ast_helper.Str.include_(~loc=importDescr.jid_loc) - } -} - -module ParsetreeCompatibility = { - let concatLongidents = (l1, l2) => { - let parts1 = Longident.flatten(l1) - let parts2 = Longident.flatten(l2) - switch List.concat(list{parts1, parts2}) |> Longident.unflatten { - | Some(longident) => longident - | None => l2 - } - } - - /* TODO: support nested open's ? */ - let rec rewritePpatOpen = (longidentOpen, pat) => { - open Parsetree - switch pat.ppat_desc { - | Ppat_array(list{first, ...rest}) => /* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] */ - {...pat, ppat_desc: Ppat_array(list{rewritePpatOpen(longidentOpen, first), ...rest})} - | Ppat_tuple(list{first, ...rest}) => /* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) */ - {...pat, ppat_desc: Ppat_tuple(list{rewritePpatOpen(longidentOpen, first), ...rest})} - | Ppat_construct( - {txt: Longident.Lident("::")} as listConstructor, - Some({ppat_desc: Ppat_tuple(list{pat, ...rest})} as element), - ) => /* Color.(list{Red, Blue, Green}) -> list{Color.Red, Blue, Green} */ - { - ...pat, - ppat_desc: Ppat_construct( - listConstructor, - Some({ - ...element, - ppat_desc: Ppat_tuple(list{rewritePpatOpen(longidentOpen, pat), ...rest}), - }), - ), - } - | Ppat_construct( - {txt: constructor} as longidentLoc, - optPattern, - ) => /* Foo.(Bar(a)) -> Foo.Bar(a) */ - { - ...pat, - ppat_desc: Ppat_construct( - {...longidentLoc, txt: concatLongidents(longidentOpen, constructor)}, - optPattern, - ), - } - | Ppat_record(list{({txt: lbl} as longidentLoc, firstPat), ...rest}, flag) => - /* Foo.{x} -> {Foo.x: x} */ - let firstRow = ({...longidentLoc, txt: concatLongidents(longidentOpen, lbl)}, firstPat) - {...pat, ppat_desc: Ppat_record(list{firstRow, ...rest}, flag)} - | Ppat_or(pat1, pat2) => { - ...pat, - ppat_desc: Ppat_or( - rewritePpatOpen(longidentOpen, pat1), - rewritePpatOpen(longidentOpen, pat2), - ), - } - | Ppat_constraint(pattern, typ) => { - ...pat, - ppat_desc: Ppat_constraint(rewritePpatOpen(longidentOpen, pattern), typ), - } - | Ppat_type({txt: constructor} as longidentLoc) => { - ...pat, - ppat_desc: Ppat_type({ - ...longidentLoc, - txt: concatLongidents(longidentOpen, constructor), - }), - } - | Ppat_lazy(p) => {...pat, ppat_desc: Ppat_lazy(rewritePpatOpen(longidentOpen, p))} - | Ppat_exception(p) => {...pat, ppat_desc: Ppat_exception(rewritePpatOpen(longidentOpen, p))} - | _ => pat - } - } - - let rec rewriteReasonFastPipe = expr => { - open Parsetree - switch expr.pexp_desc { - | Pexp_apply( - { - pexp_desc: - Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("|.")})} as op, - list{(Asttypes.Nolabel, lhs), (Nolabel, rhs)}, - ), - pexp_attributes: subAttrs, - }, - args, - ) => - let rhsLoc = {...rhs.pexp_loc, loc_end: expr.pexp_loc.loc_end} - let newLhs = { - let expr = rewriteReasonFastPipe(lhs) - {...expr, pexp_attributes: subAttrs} - } - - let allArgs = list{ - (Asttypes.Nolabel, newLhs), - (Asttypes.Nolabel, Ast_helper.Exp.apply(~loc=rhsLoc, rhs, args)), - } - - Ast_helper.Exp.apply(~attrs=expr.pexp_attributes, ~loc=expr.pexp_loc, op, allArgs) - | _ => expr - } - } - - let makeReasonArityMapper = (~forPrinter) => { - open Ast_mapper - { - ...default_mapper, - expr: (mapper, expr) => - switch expr { - /* Don't mind this case, Reason doesn't handle this. */ - /* | {pexp_desc = Pexp_variant (lbl, args); pexp_loc; pexp_attributes} -> */ - /* let newArgs = match args with */ - /* | (Some {pexp_desc = Pexp_tuple [{pexp_desc = Pexp_tuple _ } as sp]}) as args-> */ - /* if forPrinter then args else Some sp */ - /* | Some {pexp_desc = Pexp_tuple [sp]} -> Some sp */ - /* | _ -> args */ - /* in */ - /* default_mapper.expr mapper {pexp_desc=Pexp_variant(lbl, newArgs); pexp_loc; pexp_attributes} */ - | {pexp_desc: Pexp_construct(lid, args), pexp_loc, pexp_attributes} => - let newArgs = switch args { - | Some({pexp_desc: Pexp_tuple(list{{pexp_desc: Pexp_tuple(_)} as sp})}) as args => - if forPrinter { - args - } else { - Some(sp) - } - | Some({pexp_desc: Pexp_tuple(list{sp})}) => Some(sp) - | _ => args - } - - default_mapper.expr( - mapper, - { - pexp_desc: Pexp_construct(lid, newArgs), - pexp_loc: pexp_loc, - pexp_attributes: pexp_attributes, - }, - ) - | expr => default_mapper.expr(mapper, rewriteReasonFastPipe(expr)) - }, - pat: (mapper, pattern) => - switch pattern { - /* Don't mind this case, Reason doesn't handle this. */ - /* | {ppat_desc = Ppat_variant (lbl, args); ppat_loc; ppat_attributes} -> */ - /* let newArgs = match args with */ - /* | (Some {ppat_desc = Ppat_tuple [{ppat_desc = Ppat_tuple _} as sp]}) as args -> */ - /* if forPrinter then args else Some sp */ - /* | Some {ppat_desc = Ppat_tuple [sp]} -> Some sp */ - /* | _ -> args */ - /* in */ - /* default_mapper.pat mapper {ppat_desc = Ppat_variant (lbl, newArgs); ppat_loc; ppat_attributes;} */ - | {ppat_desc: Ppat_construct(lid, args), ppat_loc, ppat_attributes} => - let new_args = switch args { - | Some({ppat_desc: Ppat_tuple(list{{ppat_desc: Ppat_tuple(_)} as sp})}) as args => - if forPrinter { - args - } else { - Some(sp) - } - | Some({ppat_desc: Ppat_tuple(list{sp})}) => Some(sp) - | _ => args - } - default_mapper.pat( - mapper, - { - ppat_desc: Ppat_construct(lid, new_args), - ppat_loc: ppat_loc, - ppat_attributes: ppat_attributes, - }, - ) - | x => default_mapper.pat(mapper, x) - }, - } - } - - let escapeTemplateLiteral = s => { - let len = String.length(s) - let b = Buffer.create(len) - let i = ref(0) - while i.contents < len { - let c = (@doesNotRaise String.get)(s, i.contents) - if c == '`' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '`') - incr(i) - } else if c == '$' { - if i.contents + 1 < len { - let c2 = (@doesNotRaise String.get)(s, i.contents + 1) - if c2 == '{' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '$') - Buffer.add_char(b, '{') - } else { - Buffer.add_char(b, c) - Buffer.add_char(b, c2) - } - i := i.contents + 2 - } else { - Buffer.add_char(b, c) - incr(i) - } - } else if c == '\\' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '\\') - incr(i) - } else { - Buffer.add_char(b, c) - incr(i) - } - } - Buffer.contents(b) - } - - let escapeStringContents = s => { - let len = String.length(s) - let b = Buffer.create(len) - - let i = ref(0) - - while i.contents < len { - let c = String.unsafe_get(s, i.contents) - if c == '\\' { - incr(i) - Buffer.add_char(b, c) - let c = String.unsafe_get(s, i.contents) - if i.contents < len { - let () = Buffer.add_char(b, c) - incr(i) - } else { - () - } - } else if c == '"' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, c) - incr(i) - } else { - Buffer.add_char(b, c) - incr(i) - } - } - Buffer.contents(b) - } - - let looksLikeRecursiveTypeDeclaration = typeDeclaration => { - open Parsetree - let name = typeDeclaration.ptype_name.txt - let rec checkKind = kind => - switch kind { - | Ptype_abstract | Ptype_open => false - | Ptype_variant(constructorDeclarations) => - List.exists(checkConstructorDeclaration, constructorDeclarations) - | Ptype_record(labelDeclarations) => List.exists(checkLabelDeclaration, labelDeclarations) - } - - and checkConstructorDeclaration = constrDecl => - checkConstructorArguments(constrDecl.pcd_args) || - switch constrDecl.pcd_res { - | Some(typexpr) => checkTypExpr(typexpr) - | None => false - } - - and checkLabelDeclaration = labelDeclaration => checkTypExpr(labelDeclaration.pld_type) - - and checkConstructorArguments = constrArg => - switch constrArg { - | Pcstr_tuple(types) => List.exists(checkTypExpr, types) - | Pcstr_record(labelDeclarations) => List.exists(checkLabelDeclaration, labelDeclarations) - } - - and checkTypExpr = typ => - switch typ.ptyp_desc { - | Ptyp_any => false - | Ptyp_var(_) => false - | Ptyp_object(_) => false - | Ptyp_class(_) => false - | Ptyp_package(_) => false - | Ptyp_extension(_) => false - | Ptyp_arrow(_lbl, typ1, typ2) => checkTypExpr(typ1) || checkTypExpr(typ2) - | Ptyp_tuple(types) => List.exists(checkTypExpr, types) - | Ptyp_constr({txt: longident}, types) => - switch longident { - | Lident(ident) => ident == name - | _ => false - } || - List.exists(checkTypExpr, types) - | Ptyp_alias(typ, _) => checkTypExpr(typ) - | Ptyp_variant(rowFields, _, _) => List.exists(checkRowFields, rowFields) - | Ptyp_poly(_, typ) => checkTypExpr(typ) - } - - and checkRowFields = rowField => - switch rowField { - | Rtag(_, _, _, types) => List.exists(checkTypExpr, types) - | Rinherit(typexpr) => checkTypExpr(typexpr) - } - - checkKind(typeDeclaration.ptype_kind) - } - - let filterReasonRawLiteral = attrs => List.filter(attr => - switch attr { - | ({Location.txt: "reason.raw_literal"}, _) => false - | _ => true - } - , attrs) - - let stringLiteralMapper = stringData => { - let isSameLocation = (l1, l2) => { - open Location - l1.loc_start.pos_cnum === l2.loc_start.pos_cnum - } - - let remainingStringData = stringData - open Ast_mapper - { - ...default_mapper, - expr: (mapper, expr) => - switch expr.pexp_desc { - | Pexp_constant(Pconst_string(_txt, None)) => - switch List.find_opt( - ((_stringData, stringLoc)) => isSameLocation(stringLoc, expr.pexp_loc), - remainingStringData, - ) { - | Some(stringData, _) => - let stringData = { - let attr = List.find_opt(attr => - switch attr { - | ({Location.txt: "reason.raw_literal"}, _) => true - | _ => false - } - , expr.pexp_attributes) - switch attr { - | Some( - _, - PStr(list{{ - pstr_desc: Pstr_eval({pexp_desc: Pexp_constant(Pconst_string(raw, _))}, _), - }}), - ) => raw - | _ => (@doesNotRaise String.sub)(stringData, 1, String.length(stringData) - 2) - } - } - - { - ...expr, - pexp_attributes: filterReasonRawLiteral(expr.pexp_attributes), - pexp_desc: Pexp_constant(Pconst_string(stringData, None)), - } - | None => default_mapper.expr(mapper, expr) - } - | _ => default_mapper.expr(mapper, expr) - }, - } - } - - let normalize = { - open Ast_mapper - { - ...default_mapper, - attributes: (mapper, attrs) => attrs |> List.filter(attr => - switch attr { - | ( - {Location.txt: "reason.preserve_braces" | "explicit_arity" | "implicity_arity"}, - _, - ) => false - | _ => true - } - ) |> default_mapper.attributes(mapper), - pat: (mapper, p) => - switch p.ppat_desc { - | Ppat_open({txt: longidentOpen}, pattern) => - let p = rewritePpatOpen(longidentOpen, pattern) - default_mapper.pat(mapper, p) - | _ => default_mapper.pat(mapper, p) - }, - expr: (mapper, expr) => - switch expr.pexp_desc { - | Pexp_constant(Pconst_string(txt, None)) => - let raw = escapeStringContents(txt) - let s = Parsetree.Pconst_string(raw, None) - let expr = Ast_helper.Exp.constant(~attrs=expr.pexp_attributes, ~loc=expr.pexp_loc, s) - - expr - | Pexp_constant(Pconst_string(txt, tag)) => - let s = Parsetree.Pconst_string(escapeTemplateLiteral(txt), tag) - Ast_helper.Exp.constant( - ~attrs=mapper.attributes(mapper, expr.pexp_attributes), - ~loc=expr.pexp_loc, - s, - ) - | Pexp_function(cases) => - let loc = switch (cases, List.rev(cases)) { - | (list{first, ..._}, list{last, ..._}) => { - ...first.pc_lhs.ppat_loc, - loc_end: last.pc_rhs.pexp_loc.loc_end, - } - | _ => Location.none - } - - Ast_helper.Exp.fun_( - ~loc, - Asttypes.Nolabel, - None, - Ast_helper.Pat.var(Location.mknoloc("x")), - Ast_helper.Exp.match_( - ~loc, - Ast_helper.Exp.ident(Location.mknoloc(Longident.Lident("x"))), - default_mapper.cases(mapper, cases), - ), - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("!")})}, - list{(Asttypes.Nolabel, operand)}, - ) => - /* turn `!foo` into `foo.contents` */ - Ast_helper.Exp.field( - ~loc=expr.pexp_loc, - ~attrs=expr.pexp_attributes, - operand, - Location.mknoloc(Longident.Lident("contents")), - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("##")})} as op, - list{ - (Asttypes.Nolabel, lhs), - (Nolabel, {pexp_desc: Pexp_constant(Pconst_string(txt, None))} as stringExpr), - }, - ) => - let ident = Ast_helper.Exp.ident( - ~loc=stringExpr.pexp_loc, - Location.mkloc(Longident.Lident(txt), stringExpr.pexp_loc), - ) - - Ast_helper.Exp.apply( - ~loc=expr.pexp_loc, - ~attrs=expr.pexp_attributes, - op, - list{(Asttypes.Nolabel, lhs), (Nolabel, ident)}, - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("@@")})}, - list{(Asttypes.Nolabel, callExpr), (Nolabel, argExpr)}, - ) => - Ast_helper.Exp.apply( - mapper.expr(mapper, callExpr), - list{(Asttypes.Nolabel, mapper.expr(mapper, argExpr))}, - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("@")})}, - list{(Nolabel, arg1), (Nolabel, arg2)}, - ) => - let listConcat = Longident.Ldot(Longident.Lident("List"), "append") - Ast_helper.Exp.apply( - Ast_helper.Exp.ident(Location.mknoloc(listConcat)), - list{(Nolabel, mapper.expr(mapper, arg1)), (Nolabel, mapper.expr(mapper, arg2))}, - ) - | Pexp_match( - condition, - list{ - { - pc_lhs: {ppat_desc: Ppat_construct({txt: Longident.Lident("true")}, None)}, - pc_rhs: thenExpr, - }, - { - pc_lhs: {ppat_desc: Ppat_construct({txt: Longident.Lident("false")}, None)}, - pc_rhs: elseExpr, - }, - }, - ) => - let ternaryMarker = (Location.mknoloc("res.ternary"), Parsetree.PStr(list{})) - Ast_helper.Exp.ifthenelse( - ~loc=expr.pexp_loc, - ~attrs=list{ternaryMarker, ...expr.pexp_attributes}, - default_mapper.expr(mapper, condition), - default_mapper.expr(mapper, thenExpr), - Some(default_mapper.expr(mapper, elseExpr)), - ) - | _ => default_mapper.expr(mapper, expr) - }, - structure_item: (mapper, structureItem) => - switch structureItem.pstr_desc { - /* heuristic: if we have multiple type declarations, mark them recursive */ - | Pstr_type(recFlag, typeDeclarations) => - let flag = switch typeDeclarations { - | list{td} => - if looksLikeRecursiveTypeDeclaration(td) { - Asttypes.Recursive - } else { - Asttypes.Nonrecursive - } - | _ => recFlag - } - - { - ...structureItem, - pstr_desc: Pstr_type( - flag, - List.map( - typeDeclaration => default_mapper.type_declaration(mapper, typeDeclaration), - typeDeclarations, - ), - ), - } - | _ => default_mapper.structure_item(mapper, structureItem) - }, - signature_item: (mapper, signatureItem) => - switch signatureItem.psig_desc { - /* heuristic: if we have multiple type declarations, mark them recursive */ - | Psig_type(recFlag, typeDeclarations) => - let flag = switch typeDeclarations { - | list{td} => - if looksLikeRecursiveTypeDeclaration(td) { - Asttypes.Recursive - } else { - Asttypes.Nonrecursive - } - | _ => recFlag - } - - { - ...signatureItem, - psig_desc: Psig_type( - flag, - List.map( - typeDeclaration => default_mapper.type_declaration(mapper, typeDeclaration), - typeDeclarations, - ), - ), - } - | _ => default_mapper.signature_item(mapper, signatureItem) - }, - value_binding: (mapper, vb) => - switch vb { - | { - pvb_pat: {ppat_desc: Ppat_var(_)} as pat, - pvb_expr: {pexp_loc: expr_loc, pexp_desc: Pexp_constraint(expr, typ)}, - } when expr_loc.loc_ghost => - /* let t: t = (expr : t) -> let t: t = expr */ - let typ = default_mapper.typ(mapper, typ) - let pat = default_mapper.pat(mapper, pat) - let expr = mapper.expr(mapper, expr) - let newPattern = Ast_helper.Pat.constraint_( - ~loc={...pat.ppat_loc, loc_end: typ.ptyp_loc.loc_end}, - pat, - typ, - ) - { - ...vb, - pvb_pat: newPattern, - pvb_expr: expr, - pvb_attributes: default_mapper.attributes(mapper, vb.pvb_attributes), - } - | { - pvb_pat: {ppat_desc: Ppat_constraint(pat, {ptyp_desc: Ptyp_poly(list{}, _)})}, - pvb_expr: {pexp_loc: expr_loc, pexp_desc: Pexp_constraint(expr, typ)}, - } when expr_loc.loc_ghost => - /* let t: . t = (expr : t) -> let t: t = expr */ - let typ = default_mapper.typ(mapper, typ) - let pat = default_mapper.pat(mapper, pat) - let expr = mapper.expr(mapper, expr) - let newPattern = Ast_helper.Pat.constraint_( - ~loc={...pat.ppat_loc, loc_end: typ.ptyp_loc.loc_end}, - pat, - typ, - ) - { - ...vb, - pvb_pat: newPattern, - pvb_expr: expr, - pvb_attributes: default_mapper.attributes(mapper, vb.pvb_attributes), - } - | _ => default_mapper.value_binding(mapper, vb) - }, - } - } - - let normalizeReasonArityStructure = (~forPrinter, s) => { - let mapper = makeReasonArityMapper(~forPrinter) - mapper.Ast_mapper.structure(mapper, s) - } - - let normalizeReasonAritySignature = (~forPrinter, s) => { - let mapper = makeReasonArityMapper(~forPrinter) - mapper.Ast_mapper.signature(mapper, s) - } - - let structure = s => normalize.Ast_mapper.structure(normalize, s) - let signature = s => normalize.Ast_mapper.signature(normalize, s) - - let replaceStringLiteralStructure = (stringData, structure) => { - let mapper = stringLiteralMapper(stringData) - mapper.Ast_mapper.structure(mapper, structure) - } - - let replaceStringLiteralSignature = (stringData, signature) => { - let mapper = stringLiteralMapper(stringData) - mapper.Ast_mapper.signature(mapper, signature) - } -} - -module OcamlParser = Parser - -module Parser = { - type mode = ParseForTypeChecker | Default - - type regionStatus = Report | Silent - - type t = { - mode: mode, - mutable scanner: Scanner.t, - mutable token: Token.t, - mutable startPos: Lexing.position, - mutable endPos: Lexing.position, - mutable prevEndPos: Lexing.position, - mutable breadcrumbs: list<(Grammar.t, Lexing.position)>, - mutable errors: list, - mutable diagnostics: list, - mutable comments: list, - mutable regions: list>, - } - - let err = (~startPos=?, ~endPos=?, p, error) => { - let d = Diagnostics.make( - ~filename=p.scanner.filename, - ~startPos=switch startPos { - | Some(pos) => pos - | None => p.startPos - }, - ~endPos=switch endPos { - | Some(pos) => pos - | None => p.endPos - }, - error, - ) - - try if List.hd(p.regions).contents == Report { - p.diagnostics = list{d, ...p.diagnostics} - List.hd(p.regions) := Silent - } catch { - | Failure(_) => () - } - } - - let beginRegion = p => p.regions = list{ref(Report), ...p.regions} - let endRegion = p => - try p.regions = List.tl(p.regions) catch { - | Failure(_) => () - } - - /* Advance to the next non-comment token and store any encountered comment - * in the parser's state. Every comment contains the end position of it's - * previous token to facilite comment interleaving */ - let rec next = (~prevEndPos=?, p) => { - let prevEndPos = switch prevEndPos { - | Some(pos) => pos - | None => p.endPos - } - let (startPos, endPos, token) = Scanner.scan(p.scanner) - switch token { - | Comment(c) => - Comment.setPrevTokEndPos(c, p.endPos) - p.comments = list{c, ...p.comments} - p.prevEndPos = p.endPos - p.endPos = endPos - next(~prevEndPos, p) - | _ => - p.token = token - - /* p.prevEndPos <- prevEndPos; */ - p.prevEndPos = prevEndPos - p.startPos = startPos - p.endPos = endPos - } - } - - let checkProgress = (~prevEndPos, ~result, p) => - if p.endPos === prevEndPos { - None - } else { - Some(result) - } - - let make = (~mode=ParseForTypeChecker, src, filename) => { - let scanner = Scanner.make(Bytes.of_string(src), filename) - let parserState = { - mode: mode, - scanner: scanner, - token: Token.Eof, - startPos: Lexing.dummy_pos, - prevEndPos: Lexing.dummy_pos, - endPos: Lexing.dummy_pos, - breadcrumbs: list{}, - errors: list{}, - diagnostics: list{}, - comments: list{}, - regions: list{ref(Report)}, - } - parserState.scanner.err = (~startPos, ~endPos, error) => { - let diagnostic = Diagnostics.make(~filename, ~startPos, ~endPos, error) - - parserState.diagnostics = list{diagnostic, ...parserState.diagnostics} - } - next(parserState) - parserState - } - - let leaveBreadcrumb = (p, circumstance) => { - let crumb = (circumstance, p.startPos) - p.breadcrumbs = list{crumb, ...p.breadcrumbs} - } - - let eatBreadcrumb = p => - switch p.breadcrumbs { - | list{} => () - | list{_, ...crumbs} => p.breadcrumbs = crumbs - } - - let optional = (p, token) => - if p.token == token { - let () = next(p) - true - } else { - false - } - - let expect = (~grammar=?, token, p) => - if p.token == token { - next(p) - } else { - let error = Diagnostics.expected(~grammar?, p.prevEndPos, token) - err(~startPos=p.prevEndPos, p, error) - } - - /* Don't use immutable copies here, it trashes certain heuristics - * in the ocaml compiler, resulting in massive slowdowns of the parser */ - let lookahead = (p, callback) => { - let err = p.scanner.err - let ch = p.scanner.ch - let offset = p.scanner.offset - let rdOffset = p.scanner.rdOffset - let lineOffset = p.scanner.lineOffset - let lnum = p.scanner.lnum - let mode = p.scanner.mode - let token = p.token - let startPos = p.startPos - let endPos = p.endPos - let prevEndPos = p.prevEndPos - let breadcrumbs = p.breadcrumbs - let errors = p.errors - let diagnostics = p.diagnostics - let comments = p.comments - - let res = callback(p) - - p.scanner.err = err - p.scanner.ch = ch - p.scanner.offset = offset - p.scanner.rdOffset = rdOffset - p.scanner.lineOffset = lineOffset - p.scanner.lnum = lnum - p.scanner.mode = mode - p.token = token - p.startPos = startPos - p.endPos = endPos - p.prevEndPos = prevEndPos - p.breadcrumbs = breadcrumbs - p.errors = errors - p.diagnostics = diagnostics - p.comments = comments - - res - } -} - -module NapkinScript = { - let mkLoc = (startLoc, endLoc) => { - open Location - { - loc_start: startLoc, - loc_end: endLoc, - loc_ghost: false, - } - } - - module Recover = { - type action = option /* None is abort, Some () is retry */ - - let defaultExpr = () => { - let id = Location.mknoloc("napkinscript.exprhole") - Ast_helper.Exp.mk(Pexp_extension(id, PStr(list{}))) - } - - let defaultType = () => { - let id = Location.mknoloc("napkinscript.typehole") - Ast_helper.Typ.extension((id, PStr(list{}))) - } - - let defaultPattern = () => { - let id = Location.mknoloc("napkinscript.patternhole") - Ast_helper.Pat.extension((id, PStr(list{}))) - } - /* Ast_helper.Pat.any () */ - - let defaultModuleExpr = () => Ast_helper.Mod.structure(list{}) - let defaultModuleType = () => Ast_helper.Mty.signature(list{}) - - let recoverEqualGreater = p => { - Parser.expect(EqualGreater, p) - switch p.Parser.token { - | MinusGreater => Parser.next(p) - | _ => () - } - } - - let shouldAbortListParse = p => { - let rec check = breadcrumbs => - switch breadcrumbs { - | list{} => false - | list{(grammar, _), ...rest} => - if Grammar.isPartOfList(grammar, p.Parser.token) { - true - } else { - check(rest) - } - } - - check(p.breadcrumbs) - } - } - - module ErrorMessages = { - let listPatternSpread = "List pattern matches only supports one `...` spread, at the end. -Explanation: a list spread at the tail is efficient, but a spread in the middle would create new list{s}; out of performance concern, our pattern matching currently guarantees to never create new intermediate data." - - let recordPatternSpread = "Record's `...` spread is not supported in pattern matches. -Explanation: you can't collect a subset of a record's field into its own record, since a record needs an explicit declaration and that subset wouldn't have one. -Solution: you need to pull out each field you want explicitly." - - @live let recordPatternUnderscore = "Record patterns only support one `_`, at the end." - - let arrayPatternSpread = "Array's `...` spread is not supported in pattern matches. -Explanation: such spread would create a subarray; out of performance concern, our pattern matching currently guarantees to never create new intermediate data. -Solution: if it's to validate the first few elements, use a `when` clause + Array size check + `get` checks on the current pattern. If it's to obtain a subarray, use `Array.sub` or `Belt.Array.slice`." - - let arrayExprSpread = "Arrays can't use the `...` spread currently. Please use `concat` or other Array helpers." - - let recordExprSpread = "Records can only have one `...` spread, at the beginning. -Explanation: since records have a known, fixed shape, a spread like `{a, ...b}` wouldn't make sense, as `b` would override every field of `a` anyway." - - let listExprSpread = "Lists can only have one `...` spread, and at the end. -Explanation: lists are singly-linked list, where a node contains a value and points to the next node. `list{a, ...bc}` efficiently creates a new item and links `bc` as its next nodes. `[...bc, a]` would be expensive, as it'd need to traverse `bc` and prepend each item to `a` one by one. We therefore disallow such syntax sugar. -Solution: directly use `concat`." - - let variantIdent = "A polymorphic variant (e.g. #id) must start with an alphabetical letter." - } - - let jsxAttr = (Location.mknoloc("JSX"), Parsetree.PStr(list{})) - let uncurryAttr = (Location.mknoloc("bs"), Parsetree.PStr(list{})) - let ternaryAttr = (Location.mknoloc("res.ternary"), Parsetree.PStr(list{})) - let makeBracesAttr = loc => (Location.mkloc("res.braces", loc), Parsetree.PStr(list{})) - - type typDefOrExt = - | TypeDef({recFlag: Asttypes.rec_flag, types: list}) - | TypeExt(Parsetree.type_extension) - - type labelledParameter = - | TermParameter({ - uncurried: bool, - attrs: Parsetree.attributes, - label: Asttypes.arg_label, - expr: option, - pat: Parsetree.pattern, - pos: Lexing.position, - }) - | TypeParameter({ - uncurried: bool, - attrs: Parsetree.attributes, - locs: list>, - pos: Lexing.position, - }) - - type recordPatternItem = - | PatUnderscore - | PatField((Ast_helper.lid, Parsetree.pattern)) - - type context = - | OrdinaryExpr - | TernaryTrueBranchExpr - | WhenExpr - - let getClosingToken = x => - switch x { - | Token.Lparen => Token.Rparen - | Lbrace => Rbrace - | Lbracket => Rbracket - | _ => assert false - } - - let rec goToClosing = (closingToken, state) => - switch (state.Parser.token, closingToken) { - | (Rparen, Token.Rparen) | (Rbrace, Rbrace) | (Rbracket, Rbracket) => - Parser.next(state) - () - | ((Token.Lbracket | Lparen | Lbrace) as t, _) => - Parser.next(state) - goToClosing(getClosingToken(t), state) - goToClosing(closingToken, state) - | (Rparen | Token.Rbrace | Rbracket | Eof, _) => () /* TODO: how do report errors here? */ - | _ => - Parser.next(state) - goToClosing(closingToken, state) - } - - /* Madness */ - let isEs6ArrowExpression = (~inTernary, p) => Parser.lookahead(p, state => - switch state.Parser.token { - | Lident(_) | List | Underscore => - Parser.next(state) - switch state.Parser.token { - /* Don't think that this valid - * Imagine: let x = (a: int) - * This is a parenthesized expression with a type constraint, wait for - * the arrow */ - /* | Colon when not inTernary -> true */ - | EqualGreater => true - | _ => false - } - | Lparen => - let prevEndPos = state.prevEndPos - Parser.next(state) - switch state.token { - | Rparen => - Parser.next(state) - switch state.Parser.token { - | Colon when !inTernary => true - | EqualGreater => true - | _ => false - } - | Dot /* uncurried */ => true - | Tilde => true - | Backtick => false /* (` always indicates the start of an expr, can't be es6 parameter */ - | _ => - goToClosing(Rparen, state) - switch state.Parser.token { - | EqualGreater => true - /* | Lbrace TODO: detect missing =>, is this possible? */ - | Colon when !inTernary => true - | Rparen => /* imagine having something as : - * switch colour { - * | Red - * when l == l' - * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) - * We'll arrive at the outer rparen just before the =>. - * This is not an es6 arrow. - * */ - false - | _ => - Parser.next(state) - /* error recovery, peek at the next token, - * (elements, providerId] => { - * in the example above, we have an unbalanced ] here - */ - switch state.Parser.token { - | EqualGreater when state.startPos.pos_lnum === prevEndPos.pos_lnum => true - | _ => false - } - } - } - | _ => false - } - ) - - let isEs6ArrowFunctor = p => Parser.lookahead(p, state => - switch state.Parser.token { - /* | Uident _ | Underscore -> */ - /* Parser.next state; */ - /* begin match state.Parser.token with */ - /* | EqualGreater -> true */ - /* | _ -> false */ - /* end */ - | Lparen => - Parser.next(state) - switch state.token { - | Rparen => - Parser.next(state) - switch state.token { - | Colon | EqualGreater => true - | _ => false - } - | _ => - goToClosing(Rparen, state) - switch state.Parser.token { - | EqualGreater | Lbrace => true - | Colon => true - | _ => false - } - } - | _ => false - } - ) - - let isEs6ArrowType = p => Parser.lookahead(p, state => - switch state.Parser.token { - | Lparen => - Parser.next(state) - switch state.Parser.token { - | Rparen => - Parser.next(state) - switch state.Parser.token { - | EqualGreater => true - | _ => false - } - | Tilde | Dot => true - | _ => - goToClosing(Rparen, state) - switch state.Parser.token { - | EqualGreater => true - | _ => false - } - } - | Tilde => true - | _ => false - } - ) - - let buildLongident = words => - switch List.rev(words) { - | list{} => assert false - | list{hd, ...tl} => List.fold_left((p, s) => Longident.Ldot(p, s), Lident(hd), tl) - } - - let makeInfixOperator = (p, token, startPos, endPos) => { - let stringifiedToken = if token == Token.MinusGreater { - "|." - } else if token == Token.PlusPlus { - "^" - } else if token == Token.BangEqual { - "<>" - } else if token == Token.BangEqualEqual { - "!=" - } else if token == Token.Equal { - /* TODO: could have a totally different meaning like x->fooSet(y) */ - Parser.err(~startPos, ~endPos, p, Diagnostics.message("Did you mean `==` here?")) - "=" - } else if token == Token.EqualEqual { - "=" - } else if token == Token.EqualEqualEqual { - "==" - } else { - Token.toString(token) - } - - let loc = mkLoc(startPos, endPos) - let operator = Location.mkloc(Longident.Lident(stringifiedToken), loc) - - Ast_helper.Exp.ident(~loc, operator) - } - - let negateString = s => - if String.length(s) > 0 && @doesNotRaise String.get(s, 0) == '-' { - (@doesNotRaise String.sub)(s, 1, String.length(s) - 1) - } else { - "-" ++ s - } - - let makeUnaryExpr = (startPos, tokenEnd, token, operand) => - switch (token, operand.Parsetree.pexp_desc) { - | (Token.Plus | PlusDot, Pexp_constant(Pconst_integer(_) | Pconst_float(_))) => operand - | (Minus, Pexp_constant(Pconst_integer(n, m))) => { - ...operand, - pexp_desc: Pexp_constant(Pconst_integer(negateString(n), m)), - } - | (Minus | MinusDot, Pexp_constant(Pconst_float(n, m))) => { - ...operand, - pexp_desc: Pexp_constant(Pconst_float(negateString(n), m)), - } - | (Token.Plus | PlusDot | Minus | MinusDot, _) => - let tokenLoc = mkLoc(startPos, tokenEnd) - let operator = "~" ++ Token.toString(token) - Ast_helper.Exp.apply( - ~loc=mkLoc(startPos, operand.Parsetree.pexp_loc.loc_end), - Ast_helper.Exp.ident(~loc=tokenLoc, Location.mkloc(Longident.Lident(operator), tokenLoc)), - list{(Nolabel, operand)}, - ) - | (Token.Bang, _) => - let tokenLoc = mkLoc(startPos, tokenEnd) - Ast_helper.Exp.apply( - ~loc=mkLoc(startPos, operand.Parsetree.pexp_loc.loc_end), - Ast_helper.Exp.ident(~loc=tokenLoc, Location.mkloc(Longident.Lident("not"), tokenLoc)), - list{(Nolabel, operand)}, - ) - | _ => operand - } - - let makeListExpression = (loc, seq, extOpt) => { - let rec handleSeq = x => - switch x { - | list{} => - switch extOpt { - | Some(ext) => ext - | None => - let loc = {...loc, Location.loc_ghost: true} - let nil = Location.mkloc(Longident.Lident("[]"), loc) - Ast_helper.Exp.construct(~loc, nil, None) - } - | list{e1, ...el} => - let exp_el = handleSeq(el) - let loc = mkLoc(e1.Parsetree.pexp_loc.Location.loc_start, exp_el.pexp_loc.loc_end) - - let arg = Ast_helper.Exp.tuple(~loc, list{e1, exp_el}) - Ast_helper.Exp.construct(~loc, Location.mkloc(Longident.Lident("::"), loc), Some(arg)) - } - - let expr = handleSeq(seq) - {...expr, pexp_loc: loc} - } - - let makeListPattern = (loc, seq, ext_opt) => { - let rec handle_seq = x => - switch x { - | list{} => - let base_case = switch ext_opt { - | Some(ext) => ext - | None => - let loc = {...loc, Location.loc_ghost: true} - let nil = {Location.txt: Longident.Lident("[]"), loc: loc} - Ast_helper.Pat.construct(~loc, nil, None) - } - - base_case - | list{p1, ...pl} => - let pat_pl = handle_seq(pl) - let loc = mkLoc(p1.Parsetree.ppat_loc.loc_start, pat_pl.ppat_loc.loc_end) - let arg = Ast_helper.Pat.mk(~loc, Ppat_tuple(list{p1, pat_pl})) - Ast_helper.Pat.mk( - ~loc, - Ppat_construct(Location.mkloc(Longident.Lident("::"), loc), Some(arg)), - ) - } - - handle_seq(seq) - } - - /* {"foo": bar} -> Js.t({. foo: bar}) - * {.. "foo": bar} -> Js.t({.. foo: bar}) - * {..} -> Js.t({..}) */ - let makeBsObjType = (~attrs, ~loc, ~closed, rows) => { - let obj = Ast_helper.Typ.object_(~loc, rows, closed) - let jsDotTCtor = Location.mkloc(Longident.Ldot(Longident.Lident("Js"), "t"), loc) - - Ast_helper.Typ.constr(~loc, ~attrs, jsDotTCtor, list{obj}) - } - - /* TODO: diagnostic reporting */ - let lidentOfPath = longident => - switch Longident.flatten(longident) |> List.rev { - | list{} => "" - | list{ident, ..._} => ident - } - - let makeNewtypes = (~attrs, ~loc, newtypes, exp) => { - let expr = List.fold_right( - (newtype, exp) => Ast_helper.Exp.mk(~loc, Pexp_newtype(newtype, exp)), - newtypes, - exp, - ) - {...expr, pexp_attributes: attrs} - } - - /* locally abstract types syntax sugar - * Transforms - * let f: type t u v. = (foo : list) => ... - * into - * let f = (type t u v. foo : list) => ... - */ - let wrapTypeAnnotation = (~loc, newtypes, core_type, body) => { - let exp = makeNewtypes( - ~attrs=list{}, - ~loc, - newtypes, - Ast_helper.Exp.constraint_(~loc, body, core_type), - ) - - let typ = Ast_helper.Typ.poly( - ~loc, - newtypes, - Ast_helper.Typ.varify_constructors(newtypes, core_type), - ) - - (exp, typ) - } - - @ocaml.doc( - " - * process the occurrence of _ in the arguments of a function application - * replace _ with a new variable, currently __x, in the arguments - * return a wrapping function that wraps ((__x) => ...) around an expression - * e.g. foo(_, 3) becomes (__x) => foo(__x, 3) - " - ) - let processUnderscoreApplication = args => { - open Parsetree - let exp_question = ref(None) - let hidden_var = "__x" - let check_arg = ((lab, exp) as arg) => - switch exp.pexp_desc { - | Pexp_ident({txt: Lident("_")} as id) => - let new_id = Location.mkloc(Longident.Lident(hidden_var), id.loc) - let new_exp = Ast_helper.Exp.mk(Pexp_ident(new_id), ~loc=exp.pexp_loc) - exp_question := Some(new_exp) - (lab, new_exp) - | _ => arg - } - - let args = List.map(check_arg, args) - let wrap = exp_apply => - switch exp_question.contents { - | Some({pexp_loc: loc}) => - let pattern = Ast_helper.Pat.mk(Ppat_var(Location.mkloc(hidden_var, loc)), ~loc) - Ast_helper.Exp.mk(Pexp_fun(Nolabel, None, pattern, exp_apply), ~loc) - | None => exp_apply - } - - (args, wrap) - } - - let rec parseLident = p => { - let recoverLident = p => - if Token.isKeyword(p.Parser.token) && p.Parser.prevEndPos.pos_lnum === p.startPos.pos_lnum { - Parser.err(p, Diagnostics.lident(p.Parser.token)) - Parser.next(p) - None - } else { - let rec loop = p => - if !Recover.shouldAbortListParse(p) { - Parser.next(p) - loop(p) - } - - Parser.next(p) - loop(p) - switch p.Parser.token { - | Lident(_) => Some() - | _ => None - } - } - - let startPos = p.Parser.startPos - switch p.Parser.token { - | Lident(ident) => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - (ident, loc) - | List => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - ("list", loc) - | _ => - switch recoverLident(p) { - | Some() => parseLident(p) - | None => ("_", mkLoc(startPos, p.prevEndPos)) - } - } - } - - let parseIdent = (~msg, ~startPos, p) => - switch p.Parser.token { - | Lident(ident) | Uident(ident) => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - (ident, loc) - | List => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - ("list", loc) - | _token => - Parser.err(p, Diagnostics.message(msg)) - Parser.next(p) - ("_", mkLoc(startPos, p.prevEndPos)) - } - - let parseHashIdent = (~startPos, p) => { - Parser.expect(Hash, p) - parseIdent(~startPos, ~msg=ErrorMessages.variantIdent, p) - } - - /* Ldot (Ldot (Lident "Foo", "Bar"), "baz") */ - let parseValuePath = p => { - let startPos = p.Parser.startPos - let rec aux = (p, path) => - switch p.Parser.token { - | List => Longident.Ldot(path, "list") - | Lident(ident) => Longident.Ldot(path, ident) - | Uident(uident) => - Parser.next(p) - Parser.expect(Dot, p) - aux(p, Ldot(path, uident)) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Longident.Lident("_") - } - - let ident = switch p.Parser.token { - | List => Longident.Lident("list") - | Lident(ident) => Longident.Lident(ident) - | Uident(ident) => - Parser.next(p) - Parser.expect(Dot, p) - aux(p, Lident(ident)) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Longident.Lident("_") - } - - Parser.next(p) - Location.mkloc(ident, mkLoc(startPos, p.prevEndPos)) - } - - let parseValuePathTail = (p, startPos, ident) => { - let rec loop = (p, path) => - switch p.Parser.token { - | Lident(ident) => - Parser.next(p) - Location.mkloc(Longident.Ldot(path, ident), mkLoc(startPos, p.prevEndPos)) - | List => - Parser.next(p) - Location.mkloc(Longident.Ldot(path, "list"), mkLoc(startPos, p.prevEndPos)) - | Uident(ident) => - Parser.next(p) - Parser.expect(Dot, p) - loop(p, Longident.Ldot(path, ident)) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Location.mknoloc(path) - } - - loop(p, ident) - } - - let parseModuleLongIdentTail = (~lowercase, p, startPos, ident) => { - let rec loop = (p, acc) => - switch p.Parser.token { - | List when lowercase => - Parser.next(p) - let lident = Longident.Ldot(acc, "list") - Location.mkloc(lident, mkLoc(startPos, p.prevEndPos)) - | Lident(ident) when lowercase => - Parser.next(p) - let lident = Longident.Ldot(acc, ident) - Location.mkloc(lident, mkLoc(startPos, p.prevEndPos)) - | Uident(ident) => - Parser.next(p) - let endPos = p.prevEndPos - let lident = Longident.Ldot(acc, ident) - switch p.Parser.token { - | Dot => - Parser.next(p) - loop(p, lident) - | _ => Location.mkloc(lident, mkLoc(startPos, endPos)) - } - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mkloc(acc, mkLoc(startPos, p.prevEndPos)) - } - - loop(p, ident) - } - - /* Parses module identifiers: - Foo - Foo.Bar */ - let parseModuleLongIdent = (~lowercase, p) => { - /* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; */ - let startPos = p.Parser.startPos - let moduleIdent = switch p.Parser.token { - | List when lowercase => - let loc = mkLoc(startPos, p.endPos) - Parser.next(p) - Location.mkloc(Longident.Lident("list"), loc) - | Lident(ident) when lowercase => - let loc = mkLoc(startPos, p.endPos) - let lident = Longident.Lident(ident) - Parser.next(p) - Location.mkloc(lident, loc) - | Uident(ident) => - let lident = Longident.Lident(ident) - let endPos = p.endPos - Parser.next(p) - switch p.Parser.token { - | Dot => - Parser.next(p) - parseModuleLongIdentTail(~lowercase, p, startPos, lident) - | _ => Location.mkloc(lident, mkLoc(startPos, endPos)) - } - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mkloc(Longident.Lident("_"), mkLoc(startPos, p.prevEndPos)) - } - - /* Parser.eatBreadcrumb p; */ - moduleIdent - } - - /* `window.location` or `Math` or `Foo.Bar` */ - let parseIdentPath = p => { - let rec loop = (p, acc) => - switch p.Parser.token { - | Uident(ident) | Lident(ident) => - Parser.next(p) - let lident = Longident.Ldot(acc, ident) - switch p.Parser.token { - | Dot => - Parser.next(p) - loop(p, lident) - | _ => lident - } - | _t => acc - } - - switch p.Parser.token { - | Lident(ident) | Uident(ident) => - Parser.next(p) - switch p.Parser.token { - | Dot => - Parser.next(p) - loop(p, Longident.Lident(ident)) - | _ => Longident.Lident(ident) - } - | _ => Longident.Lident("_") - } - } - - let verifyJsxOpeningClosingName = (p, nameExpr) => { - let closing = switch p.Parser.token { - | Lident(lident) => - Parser.next(p) - Longident.Lident(lident) - | Uident(_) => parseModuleLongIdent(~lowercase=false, p).txt - | _ => Longident.Lident("") - } - - switch nameExpr.Parsetree.pexp_desc { - | Pexp_ident(openingIdent) => - let opening = { - let withoutCreateElement = - Longident.flatten(openingIdent.txt) |> List.filter(s => s != "createElement") - - switch Longident.unflatten(withoutCreateElement) { - | Some(li) => li - | None => Longident.Lident("") - } - } - - opening == closing - | _ => assert false - } - } - - let string_of_pexp_ident = nameExpr => - switch nameExpr.Parsetree.pexp_desc { - | Pexp_ident(openingIdent) => - Longident.flatten(openingIdent.txt) - |> List.filter(s => s != "createElement") - |> String.concat(".") - | _ => "" - } - - /* open-def ::= - * | open module-path - * | open! module-path */ - let parseOpenDescription = (~attrs, p) => { - Parser.leaveBreadcrumb(p, Grammar.OpenDescription) - let startPos = p.Parser.startPos - Parser.expect(Open, p) - let override = if Parser.optional(p, Token.Bang) { - Asttypes.Override - } else { - Asttypes.Fresh - } - - let modident = parseModuleLongIdent(~lowercase=false, p) - let loc = mkLoc(startPos, p.prevEndPos) - Parser.eatBreadcrumb(p) - Ast_helper.Opn.mk(~loc, ~attrs, ~override, modident) - } - - let hexValue = x => - switch x { - | '0' .. '9' => Char.code(x) - 48 - | 'A' .. 'Z' => Char.code(x) - 55 - | 'a' .. 'z' => Char.code(x) - 97 - | _ => 16 - } - - let parseStringLiteral = s => { - let len = String.length(s) - let b = Buffer.create(String.length(s)) - - let rec loop = i => - if i == len { - () - } else { - let c = String.unsafe_get(s, i) - switch c { - | '\\' as c => - let nextIx = i + 1 - if nextIx < len { - let nextChar = String.unsafe_get(s, nextIx) - switch nextChar { - | 'n' => - Buffer.add_char(b, '\n') - loop(nextIx + 1) - | 'r' => - Buffer.add_char(b, '\r') - loop(nextIx + 1) - | 'b' => - Buffer.add_char(b, '\b') - loop(nextIx + 1) - | 't' => - Buffer.add_char(b, '\t') - loop(nextIx + 1) - | '\\' as c => - Buffer.add_char(b, c) - loop(nextIx + 1) - | ' ' as c => - Buffer.add_char(b, c) - loop(nextIx + 1) - | '\'' as c => - Buffer.add_char(b, c) - loop(nextIx + 1) - | '"' as c => - Buffer.add_char(b, c) - loop(nextIx + 1) - | '0' .. '9' => - if nextIx + 2 < len { - let c0 = nextChar - let c1 = String.unsafe_get(s, nextIx + 1) - let c2 = String.unsafe_get(s, nextIx + 2) - let c = - 100 * (Char.code(c0) - 48) + 10 * (Char.code(c1) - 48) + (Char.code(c2) - 48) - - if c < 0 || c > 255 { - Buffer.add_char(b, '\\') - Buffer.add_char(b, c0) - Buffer.add_char(b, c1) - Buffer.add_char(b, c2) - loop(nextIx + 3) - } else { - Buffer.add_char(b, Char.unsafe_chr(c)) - loop(nextIx + 3) - } - } else { - Buffer.add_char(b, '\\') - Buffer.add_char(b, nextChar) - loop(nextIx + 1) - } - | 'o' => - if nextIx + 3 < len { - let c0 = String.unsafe_get(s, nextIx + 1) - let c1 = String.unsafe_get(s, nextIx + 2) - let c2 = String.unsafe_get(s, nextIx + 3) - let c = 64 * (Char.code(c0) - 48) + 8 * (Char.code(c1) - 48) + (Char.code(c2) - 48) - - if c < 0 || c > 255 { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '0') - Buffer.add_char(b, c0) - Buffer.add_char(b, c1) - Buffer.add_char(b, c2) - loop(nextIx + 4) - } else { - Buffer.add_char(b, Char.unsafe_chr(c)) - loop(nextIx + 4) - } - } else { - Buffer.add_char(b, '\\') - Buffer.add_char(b, nextChar) - loop(nextIx + 1) - } - | 'x' as c => - if nextIx + 2 < len { - let c0 = String.unsafe_get(s, nextIx + 1) - let c1 = String.unsafe_get(s, nextIx + 2) - let c = 16 * hexValue(c0) + hexValue(c1) - if c < 0 || c > 255 { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 'x') - Buffer.add_char(b, c0) - Buffer.add_char(b, c1) - loop(nextIx + 3) - } else { - Buffer.add_char(b, Char.unsafe_chr(c)) - loop(nextIx + 3) - } - } else { - Buffer.add_char(b, '\\') - Buffer.add_char(b, c) - loop(nextIx + 2) - } - | _ => - Buffer.add_char(b, c) - Buffer.add_char(b, nextChar) - loop(nextIx + 1) - } - } else { - Buffer.add_char(b, c) - () - } - | c => - Buffer.add_char(b, c) - loop(i + 1) - } - } - - loop(0) - Buffer.contents(b) - } - - let parseTemplateStringLiteral = s => { - let len = String.length(s) - let b = Buffer.create(len) - - let rec loop = i => - if i < len { - let c = String.unsafe_get(s, i) - switch c { - | '\\' as c => - if i + 1 < len { - let nextChar = String.unsafe_get(s, i + 1) - switch nextChar { - | '\\' as c => - Buffer.add_char(b, c) - loop(i + 2) - | '$' as c => - Buffer.add_char(b, c) - loop(i + 2) - | '`' as c => - Buffer.add_char(b, c) - loop(i + 2) - | c => - Buffer.add_char(b, '\\') - Buffer.add_char(b, c) - loop(i + 2) - } - } else { - Buffer.add_char(b, c) - } - - | c => - Buffer.add_char(b, c) - loop(i + 1) - } - } else { - () - } - - loop(0) - Buffer.contents(b) - } - - /* constant ::= integer-literal */ - /* ∣ float-literal */ - /* ∣ string-literal */ - let parseConstant = p => { - let isNegative = switch p.Parser.token { - | Token.Minus => - Parser.next(p) - true - | Plus => - Parser.next(p) - false - | _ => false - } - - let constant = switch p.Parser.token { - | Int({i, suffix}) => - let intTxt = if isNegative { - "-" ++ i - } else { - i - } - Parsetree.Pconst_integer(intTxt, suffix) - | Float({f, suffix}) => - let floatTxt = if isNegative { - "-" ++ f - } else { - f - } - Parsetree.Pconst_float(floatTxt, suffix) - | String(s) => - let txt = if p.mode == ParseForTypeChecker { - parseStringLiteral(s) - } else { - s - } - - Pconst_string(txt, None) - | Character(c) => Pconst_char(c) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Pconst_string("", None) - } - - Parser.next(p) - constant - } - - let parseCommaDelimitedRegion = (p, ~grammar, ~closing, ~f) => { - Parser.leaveBreadcrumb(p, grammar) - let rec loop = nodes => - switch f(p) { - | Some(node) => - switch p.Parser.token { - | Comma => - Parser.next(p) - loop(list{node, ...nodes}) - | token when token == closing || token == Eof => List.rev(list{node, ...nodes}) - | _ => - if !(p.token == Eof || (p.token == closing || Recover.shouldAbortListParse(p))) { - Parser.expect(Comma, p) - } - if p.token == Semicolon { - Parser.next(p) - } - loop(list{node, ...nodes}) - } - | None => - if p.token == Eof || (p.token == closing || Recover.shouldAbortListParse(p)) { - List.rev(nodes) - } else { - Parser.err(p, Diagnostics.unexpected(p.token, p.breadcrumbs)) - Parser.next(p) - loop(nodes) - } - } - - let nodes = loop(list{}) - Parser.eatBreadcrumb(p) - nodes - } - - let parseCommaDelimitedReversedList = (p, ~grammar, ~closing, ~f) => { - Parser.leaveBreadcrumb(p, grammar) - let rec loop = nodes => - switch f(p) { - | Some(node) => - switch p.Parser.token { - | Comma => - Parser.next(p) - loop(list{node, ...nodes}) - | token when token == closing || token == Eof => list{node, ...nodes} - | _ => - if !(p.token == Eof || (p.token == closing || Recover.shouldAbortListParse(p))) { - Parser.expect(Comma, p) - } - if p.token == Semicolon { - Parser.next(p) - } - loop(list{node, ...nodes}) - } - | None => - if p.token == Eof || (p.token == closing || Recover.shouldAbortListParse(p)) { - nodes - } else { - Parser.err(p, Diagnostics.unexpected(p.token, p.breadcrumbs)) - Parser.next(p) - loop(nodes) - } - } - - let nodes = loop(list{}) - Parser.eatBreadcrumb(p) - nodes - } - - let parseDelimitedRegion = (p, ~grammar, ~closing, ~f) => { - Parser.leaveBreadcrumb(p, grammar) - let rec loop = nodes => - switch f(p) { - | Some(node) => loop(list{node, ...nodes}) - | None => - if p.Parser.token == Token.Eof || (p.token == closing || Recover.shouldAbortListParse(p)) { - List.rev(nodes) - } else { - Parser.err(p, Diagnostics.unexpected(p.token, p.breadcrumbs)) - Parser.next(p) - loop(nodes) - } - } - - let nodes = loop(list{}) - Parser.eatBreadcrumb(p) - nodes - } - - let parseRegion = (p, ~grammar, ~f) => { - Parser.leaveBreadcrumb(p, grammar) - let rec loop = nodes => - switch f(p) { - | Some(node) => loop(list{node, ...nodes}) - | None => - if p.Parser.token == Token.Eof || Recover.shouldAbortListParse(p) { - List.rev(nodes) - } else { - Parser.err(p, Diagnostics.unexpected(p.token, p.breadcrumbs)) - Parser.next(p) - loop(nodes) - } - } - - let nodes = loop(list{}) - Parser.eatBreadcrumb(p) - nodes - } - - /* let-binding ::= pattern = expr */ - /* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr */ - /* ∣ value-name : poly-typexpr = expr */ - - /* pattern ::= value-name */ - /* ∣ _ */ - /* ∣ constant */ - /* ∣ pattern as value-name */ - /* ∣ ( pattern ) */ - /* ∣ ( pattern : typexpr ) */ - /* ∣ pattern | pattern */ - /* ∣ constr pattern */ - /* ∣ #variant variant-pattern */ - /* ∣ ##type */ - /* ∣ / pattern { , pattern }+ / */ - /* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } */ - /* ∣ [ pattern { ; pattern } [ ; ] ] */ - /* ∣ pattern :: pattern */ - /* ∣ [| pattern { ; pattern } [ ; ] |] */ - /* ∣ char-literal .. char-literal */ - /* ∣ exception pattern */ - let rec parsePattern = (~alias=true, ~or_=true, p) => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - let pat = switch p.Parser.token { - | (True | False) as token => - let endPos = p.endPos - Parser.next(p) - let loc = mkLoc(startPos, endPos) - Ast_helper.Pat.construct( - ~loc, - Location.mkloc(Longident.Lident(Token.toString(token)), loc), - None, - ) - | Int(_) | String(_) | Float(_) | Character(_) | Minus | Plus => - let c = parseConstant(p) - switch p.token { - | DotDot => - Parser.next(p) - let c2 = parseConstant(p) - Ast_helper.Pat.interval(~loc=mkLoc(startPos, p.prevEndPos), c, c2) - | _ => Ast_helper.Pat.constant(~loc=mkLoc(startPos, p.prevEndPos), c) - } - | Lparen => - Parser.next(p) - switch p.token { - | Rparen => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let lid = Location.mkloc(Longident.Lident("()"), loc) - Ast_helper.Pat.construct(~loc, lid, None) - | _ => - let pat = parseConstrainedPattern(p) - switch p.token { - | Comma => - Parser.next(p) - parseTuplePattern(~attrs, ~first=pat, ~startPos, p) - | _ => - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, p.prevEndPos) - {...pat, ppat_loc: loc} - } - } - | Lbracket => parseArrayPattern(~attrs, p) - | Lbrace => parseRecordPattern(~attrs, p) - | Underscore => - let endPos = p.endPos - let loc = mkLoc(startPos, endPos) - Parser.next(p) - Ast_helper.Pat.any(~loc, ~attrs, ()) - | Lident(ident) => - let endPos = p.endPos - let loc = mkLoc(startPos, endPos) - Parser.next(p) - Ast_helper.Pat.var(~loc, ~attrs, Location.mkloc(ident, loc)) - | Uident(_) => - let constr = parseModuleLongIdent(~lowercase=false, p) - switch p.Parser.token { - | Lparen => parseConstructorPatternArgs(p, constr, startPos, attrs) - | _ => Ast_helper.Pat.construct(~loc=constr.loc, ~attrs, constr, None) - } - | Hash => - let (ident, loc) = parseHashIdent(~startPos, p) - switch p.Parser.token { - | Lparen => parseVariantPatternArgs(p, ident, startPos, attrs) - | _ => Ast_helper.Pat.variant(~loc, ~attrs, ident, None) - } - | HashHash => - Parser.next(p) - let ident = parseValuePath(p) - let loc = mkLoc(startPos, ident.loc.loc_end) - Ast_helper.Pat.type_(~loc, ~attrs, ident) - | Exception => - Parser.next(p) - let pat = parsePattern(~alias=false, ~or_=false, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.exception_(~loc, ~attrs, pat) - | Lazy => - Parser.next(p) - let pat = parsePattern(~alias=false, ~or_=false, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.lazy_(~loc, ~attrs, pat) - | List => - Parser.next(p) - switch p.token { - | Lbracket => parseListPattern(~startPos, ~attrs, p) - | _ => - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.var(~loc, ~attrs, Location.mkloc("list", loc)) - } - | Module => parseModulePattern(~attrs, p) - | Percent => - let extension = parseExtension(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.extension(~loc, ~attrs, extension) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - switch skipTokensAndMaybeRetry(p, ~isStartOfGrammar=Grammar.isAtomicPatternStart) { - | None => Recover.defaultPattern() - | Some() => parsePattern(p) - } - } - - let pat = if alias { - parseAliasPattern(~attrs, pat, p) - } else { - pat - } - if or_ { - parseOrPattern(pat, p) - } else { - pat - } - } - - and skipTokensAndMaybeRetry = (p, ~isStartOfGrammar) => - if Token.isKeyword(p.Parser.token) && p.Parser.prevEndPos.pos_lnum === p.startPos.pos_lnum { - Parser.next(p) - None - } else if Recover.shouldAbortListParse(p) { - if isStartOfGrammar(p.Parser.token) { - Parser.next(p) - Some() - } else { - None - } - } else { - Parser.next(p) - let rec loop = p => - if !Recover.shouldAbortListParse(p) { - Parser.next(p) - loop(p) - } - loop(p) - if isStartOfGrammar(p.Parser.token) { - Some() - } else { - None - } - } - - /* alias ::= pattern as lident */ - and parseAliasPattern = (~attrs, pattern, p) => - switch p.Parser.token { - | As => - Parser.next(p) - let (name, loc) = parseLident(p) - let name = Location.mkloc(name, loc) - Ast_helper.Pat.alias(~loc={...pattern.ppat_loc, loc_end: p.prevEndPos}, ~attrs, pattern, name) - | _ => pattern - } - - /* or ::= pattern | pattern - * precedence: Red | Blue | Green is interpreted as (Red | Blue) | Green */ - and parseOrPattern = (pattern1, p) => { - let rec loop = pattern1 => - switch p.Parser.token { - | Bar => - Parser.next(p) - let pattern2 = parsePattern(~or_=false, p) - let loc = { - ...pattern1.Parsetree.ppat_loc, - loc_end: pattern2.ppat_loc.loc_end, - } - loop(Ast_helper.Pat.or_(~loc, pattern1, pattern2)) - | _ => pattern1 - } - - loop(pattern1) - } - - and parseNonSpreadPattern = (~msg, p) => { - let () = switch p.Parser.token { - | DotDotDot => - Parser.err(p, Diagnostics.message(msg)) - Parser.next(p) - | _ => () - } - - switch p.Parser.token { - | token when Grammar.isPatternStart(token) => - let pat = parsePattern(p) - switch p.Parser.token { - | Colon => - Parser.next(p) - let typ = parseTypExpr(p) - let loc = mkLoc(pat.ppat_loc.loc_start, typ.Parsetree.ptyp_loc.loc_end) - Some(Ast_helper.Pat.constraint_(~loc, pat, typ)) - | _ => Some(pat) - } - | _ => None - } - } - - and parseConstrainedPattern = p => { - let pat = parsePattern(p) - switch p.Parser.token { - | Colon => - Parser.next(p) - let typ = parseTypExpr(p) - let loc = mkLoc(pat.ppat_loc.loc_start, typ.Parsetree.ptyp_loc.loc_end) - Ast_helper.Pat.constraint_(~loc, pat, typ) - | _ => pat - } - } - - and parseConstrainedPatternRegion = p => - switch p.Parser.token { - | token when Grammar.isPatternStart(token) => Some(parseConstrainedPattern(p)) - | _ => None - } - - /* field ::= - * | longident - * | longident : pattern - * | longident as lident - * - * row ::= - * | field , - * | field , _ - * | field , _, - */ - and parseRecordPatternField = p => { - let startPos = p.Parser.startPos - let label = parseValuePath(p) - let pattern = switch p.Parser.token { - | Colon => - Parser.next(p) - parsePattern(p) - | _ => Ast_helper.Pat.var(~loc=label.loc, Location.mkloc(Longident.last(label.txt), label.loc)) - } - - switch p.token { - | As => - Parser.next(p) - let (name, loc) = parseLident(p) - let name = Location.mkloc(name, loc) - let aliasPattern = Ast_helper.Pat.alias(~loc=mkLoc(startPos, p.prevEndPos), pattern, name) - - (Location.mkloc(label.txt, mkLoc(startPos, aliasPattern.ppat_loc.loc_end)), aliasPattern) - | _ => (label, pattern) - } - } - - /* TODO: there are better representations than PatField|Underscore ? */ - and parseRecordPatternItem = p => - switch p.Parser.token { - | DotDotDot => - Parser.next(p) - Some(true, PatField(parseRecordPatternField(p))) - | Uident(_) | Lident(_) => Some(false, PatField(parseRecordPatternField(p))) - | Underscore => - Parser.next(p) - Some(false, PatUnderscore) - | _ => None - } - - and parseRecordPattern = (~attrs, p) => { - let startPos = p.startPos - Parser.expect(Lbrace, p) - let rawFields = parseCommaDelimitedReversedList( - p, - ~grammar=PatternRecord, - ~closing=Rbrace, - ~f=parseRecordPatternItem, - ) - - Parser.expect(Rbrace, p) - let (fields, closedFlag) = { - let (rawFields, flag) = switch rawFields { - | list{(_hasSpread, PatUnderscore), ...rest} => (rest, Asttypes.Open) - | rawFields => (rawFields, Asttypes.Closed) - } - - List.fold_left(((fields, flag), curr) => { - let (hasSpread, field) = curr - switch field { - | PatField(field) => - if hasSpread { - let (_, pattern) = field - Parser.err( - ~startPos=pattern.Parsetree.ppat_loc.loc_start, - p, - Diagnostics.message(ErrorMessages.recordPatternSpread), - ) - } - (list{field, ...fields}, flag) - | PatUnderscore => (fields, flag) - } - }, (list{}, flag), rawFields) - } - - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.record(~loc, ~attrs, fields, closedFlag) - } - - and parseTuplePattern = (~attrs, ~first, ~startPos, p) => { - let patterns = parseCommaDelimitedRegion( - p, - ~grammar=Grammar.PatternList, - ~closing=Rparen, - ~f=parseConstrainedPatternRegion, - ) - - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.tuple(~loc, ~attrs, list{first, ...patterns}) - } - - and parsePatternRegion = p => - switch p.Parser.token { - | DotDotDot => - Parser.next(p) - Some(true, parseConstrainedPattern(p)) - | token when Grammar.isPatternStart(token) => Some(false, parseConstrainedPattern(p)) - | _ => None - } - - and parseModulePattern = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Module, p) - Parser.expect(Lparen, p) - let uident = switch p.token { - | Uident(uident) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Location.mkloc(uident, loc) - | _ => - /* TODO: error recovery */ - Location.mknoloc("_") - } - - switch p.token { - | Colon => - let colonStart = p.Parser.startPos - Parser.next(p) - let packageTypAttrs = parseAttributes(p) - let packageType = parsePackageType(~startPos=colonStart, ~attrs=packageTypAttrs, p) - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, p.prevEndPos) - let unpack = Ast_helper.Pat.unpack(~loc=uident.loc, uident) - Ast_helper.Pat.constraint_(~loc, ~attrs, unpack, packageType) - | _ => - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.unpack(~loc, ~attrs, uident) - } - } - - and parseListPattern = (~startPos, ~attrs, p) => { - Parser.expect(Lbracket, p) - let listPatterns = parseCommaDelimitedReversedList( - p, - ~grammar=Grammar.PatternOcamlList, - ~closing=Rbracket, - ~f=parsePatternRegion, - ) - - Parser.expect(Rbracket, p) - let loc = mkLoc(startPos, p.prevEndPos) - let filterSpread = ((hasSpread, pattern)) => - if hasSpread { - Parser.err( - ~startPos=pattern.Parsetree.ppat_loc.loc_start, - p, - Diagnostics.message(ErrorMessages.listPatternSpread), - ) - pattern - } else { - pattern - } - - switch listPatterns { - | list{(true, pattern), ...patterns} => - let patterns = patterns |> List.map(filterSpread) |> List.rev - let pat = makeListPattern(loc, patterns, Some(pattern)) - {...pat, ppat_loc: loc, ppat_attributes: attrs} - | patterns => - let patterns = patterns |> List.map(filterSpread) |> List.rev - let pat = makeListPattern(loc, patterns, None) - {...pat, ppat_loc: loc, ppat_attributes: attrs} - } - } - - and parseArrayPattern = (~attrs, p) => { - let startPos = p.startPos - Parser.expect(Lbracket, p) - let patterns = parseCommaDelimitedRegion( - p, - ~grammar=Grammar.PatternList, - ~closing=Rbracket, - ~f=parseNonSpreadPattern(~msg=ErrorMessages.arrayPatternSpread), - ) - - Parser.expect(Rbracket, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.array(~loc, ~attrs, patterns) - } - - and parseConstructorPatternArgs = (p, constr, startPos, attrs) => { - let lparen = p.startPos - Parser.expect(Lparen, p) - let args = parseCommaDelimitedRegion( - p, - ~grammar=Grammar.PatternList, - ~closing=Rparen, - ~f=parseConstrainedPatternRegion, - ) - - Parser.expect(Rparen, p) - let args = switch args { - | list{} => - let loc = mkLoc(lparen, p.prevEndPos) - Some(Ast_helper.Pat.construct(~loc, Location.mkloc(Longident.Lident("()"), loc), None)) - | list{{ppat_desc: Ppat_tuple(_)} as pat} as patterns => - if p.mode == ParseForTypeChecker { - /* Some(1, 2) for type-checker */ - Some(pat) - } else { - /* Some((1, 2)) for printer */ - Some(Ast_helper.Pat.tuple(~loc=mkLoc(lparen, p.endPos), patterns)) - } - | list{pattern} => Some(pattern) - | patterns => Some(Ast_helper.Pat.tuple(~loc=mkLoc(lparen, p.endPos), patterns)) - } - - Ast_helper.Pat.construct(~loc=mkLoc(startPos, p.prevEndPos), ~attrs, constr, args) - } - - and parseVariantPatternArgs = (p, ident, startPos, attrs) => { - let lparen = p.startPos - Parser.expect(Lparen, p) - let patterns = parseCommaDelimitedRegion( - p, - ~grammar=Grammar.PatternList, - ~closing=Rparen, - ~f=parseConstrainedPatternRegion, - ) - let args = switch patterns { - | list{{ppat_desc: Ppat_tuple(_)} as pat} as patterns => - if p.mode == ParseForTypeChecker { - /* #ident(1, 2) for type-checker */ - Some(pat) - } else { - /* #ident((1, 2)) for printer */ - Some(Ast_helper.Pat.tuple(~loc=mkLoc(lparen, p.endPos), patterns)) - } - | list{pattern} => Some(pattern) - | patterns => Some(Ast_helper.Pat.tuple(~loc=mkLoc(lparen, p.endPos), patterns)) - } - - Parser.expect(Rparen, p) - Ast_helper.Pat.variant(~loc=mkLoc(startPos, p.prevEndPos), ~attrs, ident, args) - } - - and parseExpr = (~context=OrdinaryExpr, p) => { - let expr = parseOperandExpr(~context, p) - let expr = parseBinaryExpr(~context, ~a=expr, p, 1) - parseTernaryExpr(expr, p) - } - - /* expr ? expr : expr */ - and parseTernaryExpr = (leftOperand, p) => - switch p.Parser.token { - | Question => - Parser.leaveBreadcrumb(p, Grammar.Ternary) - Parser.next(p) - let trueBranch = parseExpr(~context=TernaryTrueBranchExpr, p) - Parser.expect(Colon, p) - let falseBranch = parseExpr(p) - Parser.eatBreadcrumb(p) - let loc = { - ...leftOperand.Parsetree.pexp_loc, - loc_start: leftOperand.pexp_loc.loc_start, - loc_end: falseBranch.Parsetree.pexp_loc.loc_end, - } - Ast_helper.Exp.ifthenelse( - ~attrs=list{ternaryAttr}, - ~loc, - leftOperand, - trueBranch, - Some(falseBranch), - ) - | _ => leftOperand - } - - and parseEs6ArrowExpression = (~parameters=?, p) => { - let startPos = p.Parser.startPos - Parser.leaveBreadcrumb(p, Grammar.Es6ArrowExpr) - let parameters = switch parameters { - | Some(params) => params - | None => parseParameters(p) - } - - let returnType = switch p.Parser.token { - | Colon => - Parser.next(p) - Some(parseTypExpr(~es6Arrow=false, p)) - | _ => None - } - - Parser.expect(EqualGreater, p) - let body = { - let expr = parseExpr(p) - switch returnType { - | Some(typ) => - Ast_helper.Exp.constraint_( - ~loc=mkLoc(expr.pexp_loc.loc_start, typ.Parsetree.ptyp_loc.loc_end), - expr, - typ, - ) - | None => expr - } - } - - Parser.eatBreadcrumb(p) - let endPos = p.prevEndPos - let arrowExpr = List.fold_right((parameter, expr) => - switch parameter { - | TermParameter({uncurried, attrs, label: lbl, expr: defaultExpr, pat, pos: startPos}) => - let attrs = if uncurried { - list{uncurryAttr, ...attrs} - } else { - attrs - } - Ast_helper.Exp.fun_(~loc=mkLoc(startPos, endPos), ~attrs, lbl, defaultExpr, pat, expr) - | TypeParameter({uncurried, attrs, locs: newtypes, pos: startPos}) => - let attrs = if uncurried { - list{uncurryAttr, ...attrs} - } else { - attrs - } - makeNewtypes(~attrs, ~loc=mkLoc(startPos, endPos), newtypes, expr) - } - , parameters, body) - - {...arrowExpr, pexp_loc: {...arrowExpr.pexp_loc, loc_start: startPos}} - } - - /* - * uncurried_parameter ::= - * | . parameter - * - * parameter ::= - * | pattern - * | pattern : type - * | ~ labelName - * | ~ labelName as pattern - * | ~ labelName as pattern : type - * | ~ labelName = expr - * | ~ labelName as pattern = expr - * | ~ labelName as pattern : type = expr - * | ~ labelName = ? - * | ~ labelName as pattern = ? - * | ~ labelName as pattern : type = ? - * - * labelName ::= lident - */ - and parseParameter = p => - if ( - p.Parser.token == Token.Typ || - (p.token == Tilde || - (p.token == Dot || Grammar.isPatternStart(p.token))) - ) { - let startPos = p.Parser.startPos - let uncurried = Parser.optional(p, Token.Dot) - /* two scenarios: - * attrs ~lbl ... - * attrs pattern - * Attributes before a labelled arg, indicate that it's on the whole arrow expr - * Otherwise it's part of the pattern - * */ - let attrs = parseAttributes(p) - if p.Parser.token == Typ { - Parser.next(p) - let lidents = parseLidentList(p) - Some(TypeParameter({uncurried: uncurried, attrs: attrs, locs: lidents, pos: startPos})) - } else { - let (attrs, lbl, pat) = switch p.Parser.token { - | Tilde => - Parser.next(p) - let (lblName, loc) = parseLident(p) - let propLocAttr = (Location.mkloc("res.namedArgLoc", loc), Parsetree.PStr(list{})) - switch p.Parser.token { - | Comma | Equal | Rparen => - let loc = mkLoc(startPos, p.prevEndPos) - ( - attrs, - Asttypes.Labelled(lblName), - Ast_helper.Pat.var(~attrs=list{propLocAttr}, ~loc, Location.mkloc(lblName, loc)), - ) - | Colon => - let lblEnd = p.prevEndPos - Parser.next(p) - let typ = parseTypExpr(p) - let loc = mkLoc(startPos, lblEnd) - let pat = { - let pat = Ast_helper.Pat.var(~loc, Location.mkloc(lblName, loc)) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Pat.constraint_(~attrs=list{propLocAttr}, ~loc, pat, typ) - } - (attrs, Asttypes.Labelled(lblName), pat) - | As => - Parser.next(p) - let pat = { - let pat = parseConstrainedPattern(p) - {...pat, ppat_attributes: list{propLocAttr, ...pat.ppat_attributes}} - } - - (attrs, Asttypes.Labelled(lblName), pat) - | t => - Parser.err(p, Diagnostics.unexpected(t, p.breadcrumbs)) - let loc = mkLoc(startPos, p.prevEndPos) - ( - attrs, - Asttypes.Labelled(lblName), - Ast_helper.Pat.var(~loc, Location.mkloc(lblName, loc)), - ) - } - | _ => - let pattern = parseConstrainedPattern(p) - let attrs = List.concat(list{attrs, pattern.ppat_attributes}) - (list{}, Asttypes.Nolabel, {...pattern, ppat_attributes: attrs}) - } - - switch p.Parser.token { - | Equal => - Parser.next(p) - let lbl = switch lbl { - | Asttypes.Labelled(lblName) => Asttypes.Optional(lblName) - | Asttypes.Optional(_) as lbl => lbl - | Asttypes.Nolabel => Asttypes.Nolabel - } - - switch p.Parser.token { - | Question => - Parser.next(p) - Some( - TermParameter({ - uncurried: uncurried, - attrs: attrs, - label: lbl, - expr: None, - pat: pat, - pos: startPos, - }), - ) - | _ => - let expr = parseConstrainedOrCoercedExpr(p) - Some( - TermParameter({ - uncurried: uncurried, - attrs: attrs, - label: lbl, - expr: Some(expr), - pat: pat, - pos: startPos, - }), - ) - } - | _ => - Some( - TermParameter({ - uncurried: uncurried, - attrs: attrs, - label: lbl, - expr: None, - pat: pat, - pos: startPos, - }), - ) - } - } - } else { - None - } - - and parseParameterList = p => { - let parameters = parseCommaDelimitedRegion( - ~grammar=Grammar.ParameterList, - ~f=parseParameter, - ~closing=Rparen, - p, - ) - - Parser.expect(Rparen, p) - parameters - } - - /* parameters ::= - * | _ - * | lident - * | () - * | (.) - * | ( parameter {, parameter} [,] ) - */ - and parseParameters = p => { - let startPos = p.Parser.startPos - switch p.Parser.token { - | Lident(ident) => - Parser.next(p) - let loc = mkLoc(startPos, p.Parser.prevEndPos) - list{ - TermParameter({ - uncurried: false, - attrs: list{}, - label: Asttypes.Nolabel, - expr: None, - pat: Ast_helper.Pat.var(~loc, Location.mkloc(ident, loc)), - pos: startPos, - }), - } - | List => - Parser.next(p) - let loc = mkLoc(startPos, p.Parser.prevEndPos) - list{ - TermParameter({ - uncurried: false, - attrs: list{}, - label: Asttypes.Nolabel, - expr: None, - pat: Ast_helper.Pat.var(~loc, Location.mkloc("list", loc)), - pos: startPos, - }), - } - | Underscore => - Parser.next(p) - let loc = mkLoc(startPos, p.Parser.prevEndPos) - list{ - TermParameter({ - uncurried: false, - attrs: list{}, - label: Asttypes.Nolabel, - expr: None, - pat: Ast_helper.Pat.any(~loc, ()), - pos: startPos, - }), - } - | Lparen => - Parser.next(p) - switch p.Parser.token { - | Rparen => - Parser.next(p) - let loc = mkLoc(startPos, p.Parser.prevEndPos) - let unitPattern = Ast_helper.Pat.construct( - ~loc, - Location.mkloc(Longident.Lident("()"), loc), - None, - ) - - list{ - TermParameter({ - uncurried: false, - attrs: list{}, - label: Asttypes.Nolabel, - expr: None, - pat: unitPattern, - pos: startPos, - }), - } - | Dot => - Parser.next(p) - switch p.token { - | Rparen => - Parser.next(p) - let loc = mkLoc(startPos, p.Parser.prevEndPos) - let unitPattern = Ast_helper.Pat.construct( - ~loc, - Location.mkloc(Longident.Lident("()"), loc), - None, - ) - - list{ - TermParameter({ - uncurried: true, - attrs: list{}, - label: Asttypes.Nolabel, - expr: None, - pat: unitPattern, - pos: startPos, - }), - } - | _ => - switch parseParameterList(p) { - | list{ - TermParameter({attrs, label: lbl, expr: defaultExpr, pat: pattern, pos: startPos}), - ...rest, - } => list{ - TermParameter({ - uncurried: true, - attrs: attrs, - label: lbl, - expr: defaultExpr, - pat: pattern, - pos: startPos, - }), - ...rest, - } - | parameters => parameters - } - } - | _ => parseParameterList(p) - } - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - list{} - } - } - - and parseCoercedExpr = (~expr: Parsetree.expression, p) => { - Parser.expect(ColonGreaterThan, p) - let typ = parseTypExpr(p) - let loc = mkLoc(expr.pexp_loc.loc_start, p.prevEndPos) - Ast_helper.Exp.coerce(~loc, expr, None, typ) - } - - and parseConstrainedOrCoercedExpr = p => { - let expr = parseExpr(p) - switch p.Parser.token { - | ColonGreaterThan => parseCoercedExpr(~expr, p) - | Colon => - Parser.next(p) - switch p.token { - | _ => - let typ = parseTypExpr(p) - let loc = mkLoc(expr.pexp_loc.loc_start, typ.ptyp_loc.loc_end) - let expr = Ast_helper.Exp.constraint_(~loc, expr, typ) - switch p.token { - | ColonGreaterThan => parseCoercedExpr(~expr, p) - | _ => expr - } - } - | _ => expr - } - } - - and parseConstrainedExprRegion = p => - switch p.Parser.token { - | token when Grammar.isExprStart(token) => - let expr = parseExpr(p) - switch p.Parser.token { - | Colon => - Parser.next(p) - let typ = parseTypExpr(p) - let loc = mkLoc(expr.pexp_loc.loc_start, typ.ptyp_loc.loc_end) - Some(Ast_helper.Exp.constraint_(~loc, expr, typ)) - | _ => Some(expr) - } - | _ => None - } - - /* Atomic expressions represent unambiguous expressions. - * This means that regardless of the context, these expressions - * are always interpreted correctly. */ - and parseAtomicExpr = p => { - Parser.leaveBreadcrumb(p, Grammar.ExprOperand) - let startPos = p.Parser.startPos - let expr = switch p.Parser.token { - | (True | False) as token => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.construct( - ~loc, - Location.mkloc(Longident.Lident(Token.toString(token)), loc), - None, - ) - | Int(_) | String(_) | Float(_) | Character(_) => - let c = parseConstant(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.constant(~loc, c) - | Backtick => - let expr = parseTemplateExpr(p) - {...expr, pexp_loc: mkLoc(startPos, p.prevEndPos)} - | Uident(_) | Lident(_) => parseValueOrConstructor(p) - | Hash => parsePolyVariantExpr(p) - | Lparen => - Parser.next(p) - switch p.Parser.token { - | Rparen => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.construct(~loc, Location.mkloc(Longident.Lident("()"), loc), None) - | _t => - let expr = parseConstrainedOrCoercedExpr(p) - switch p.token { - | Comma => - Parser.next(p) - parseTupleExpr(~startPos, ~first=expr, p) - | _ => - Parser.expect(Rparen, p) - expr - /* {expr with pexp_loc = mkLoc startPos p.prevEndPos} - * What does this location mean here? It means that when there's - * a parenthesized we keep the location here for whitespace interleaving. - * Without the closing paren in the location there will always be an extra - * line. For now we don't include it, because it does weird things - * with for comments. */ - } - } - | List => - Parser.next(p) - switch p.token { - | Lbracket => parseListExpr(~startPos, p) - | _ => - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.ident(~loc, Location.mkloc(Longident.Lident("list"), loc)) - } - | Module => - Parser.next(p) - parseFirstClassModuleExpr(~startPos, p) - | Lbracket => parseArrayExp(p) - | Lbrace => parseBracedOrRecordExpr(p) - | LessThan => parseJsx(p) - | Percent => - let extension = parseExtension(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.extension(~loc, extension) - | Underscore as token => - /* This case is for error recovery. Not sure if it's the correct place */ - Parser.err(p, Diagnostics.lident(token)) - Parser.next(p) - Recover.defaultExpr() - | token => - let errPos = p.prevEndPos - switch skipTokensAndMaybeRetry(p, ~isStartOfGrammar=Grammar.isAtomicExprStart) { - | None => - Parser.err(~startPos=errPos, p, Diagnostics.unexpected(token, p.breadcrumbs)) - Recover.defaultExpr() - | Some() => parseAtomicExpr(p) - } - } - - Parser.eatBreadcrumb(p) - expr - } - - /* module(module-expr) - * module(module-expr : package-type) */ - and parseFirstClassModuleExpr = (~startPos, p) => { - Parser.expect(Lparen, p) - - let modExpr = parseModuleExpr(p) - let modEndLoc = p.prevEndPos - switch p.Parser.token { - | Colon => - let colonStart = p.Parser.startPos - Parser.next(p) - let attrs = parseAttributes(p) - let packageType = parsePackageType(~startPos=colonStart, ~attrs, p) - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, modEndLoc) - let firstClassModule = Ast_helper.Exp.pack(~loc, modExpr) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.constraint_(~loc, firstClassModule, packageType) - | _ => - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.pack(~loc, modExpr) - } - } - - and parseBracketAccess = (p, expr, startPos) => { - Parser.leaveBreadcrumb(p, Grammar.ExprArrayAccess) - let lbracket = p.startPos - Parser.next(p) - let stringStart = p.startPos - switch p.Parser.token { - | String(s) => - Parser.next(p) - let stringEnd = p.prevEndPos - Parser.expect(Rbracket, p) - let rbracket = p.prevEndPos - let e = { - let identLoc = mkLoc(stringStart, stringEnd) - let loc = mkLoc(lbracket, rbracket) - Ast_helper.Exp.apply( - ~loc, - Ast_helper.Exp.ident(~loc, Location.mkloc(Longident.Lident("##"), loc)), - list{ - (Nolabel, expr), - ( - Nolabel, - Ast_helper.Exp.ident(~loc=identLoc, Location.mkloc(Longident.Lident(s), identLoc)), - ), - }, - ) - } - - let e = parsePrimaryExpr(~operand=e, p) - let equalStart = p.startPos - switch p.token { - | Equal => - Parser.next(p) - let equalEnd = p.prevEndPos - let rhsExpr = parseExpr(p) - let loc = mkLoc(startPos, rhsExpr.pexp_loc.loc_end) - let operatorLoc = mkLoc(equalStart, equalEnd) - Ast_helper.Exp.apply( - ~loc, - Ast_helper.Exp.ident( - ~loc=operatorLoc, - Location.mkloc(Longident.Lident("#="), operatorLoc), - ), - list{(Nolabel, e), (Nolabel, rhsExpr)}, - ) - | _ => e - } - | _ => - let accessExpr = parseConstrainedOrCoercedExpr(p) - Parser.expect(Rbracket, p) - let rbracket = p.prevEndPos - let arrayLoc = mkLoc(lbracket, rbracket) - switch p.token { - | Equal => - Parser.leaveBreadcrumb(p, ExprArrayMutation) - Parser.next(p) - let rhsExpr = parseExpr(p) - let arraySet = Location.mkloc(Longident.Ldot(Lident("Array"), "set"), arrayLoc) - - let endPos = p.prevEndPos - let arraySet = Ast_helper.Exp.apply( - ~loc=mkLoc(startPos, endPos), - Ast_helper.Exp.ident(~loc=arrayLoc, arraySet), - list{(Nolabel, expr), (Nolabel, accessExpr), (Nolabel, rhsExpr)}, - ) - - Parser.eatBreadcrumb(p) - arraySet - | _ => - let endPos = p.prevEndPos - let e = Ast_helper.Exp.apply( - ~loc=mkLoc(startPos, endPos), - Ast_helper.Exp.ident( - ~loc=arrayLoc, - Location.mkloc(Longident.Ldot(Lident("Array"), "get"), arrayLoc), - ), - list{(Nolabel, expr), (Nolabel, accessExpr)}, - ) - - Parser.eatBreadcrumb(p) - parsePrimaryExpr(~operand=e, p) - } - } - } - - /* * A primary expression represents - * - atomic-expr - * - john.age - * - array[0] - * - applyFunctionTo(arg1, arg2) - * - * The "operand" represents the expression that is operated on - */ - and parsePrimaryExpr = (~operand, ~noCall=false, p) => { - let startPos = operand.pexp_loc.loc_start - let rec loop = (p, expr) => - switch p.Parser.token { - | Dot => - Parser.next(p) - let lident = parseValuePath(p) - switch p.Parser.token { - | Equal when noCall == false => - Parser.leaveBreadcrumb(p, Grammar.ExprSetField) - Parser.next(p) - let targetExpr = parseExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - let setfield = Ast_helper.Exp.setfield(~loc, expr, lident, targetExpr) - Parser.eatBreadcrumb(p) - setfield - | _ => - let endPos = p.prevEndPos - let loc = mkLoc(startPos, endPos) - loop(p, Ast_helper.Exp.field(~loc, expr, lident)) - } - | Lbracket when noCall == false && p.prevEndPos.pos_lnum === p.startPos.pos_lnum => - parseBracketAccess(p, expr, startPos) - | Lparen when noCall == false && p.prevEndPos.pos_lnum === p.startPos.pos_lnum => - loop(p, parseCallExpr(p, expr)) - | Backtick when noCall == false && p.prevEndPos.pos_lnum === p.startPos.pos_lnum => - switch expr.pexp_desc { - | Pexp_ident({txt: Longident.Lident(ident)}) => parseTemplateExpr(~prefix=ident, p) - | _ => - Parser.err( - ~startPos=expr.pexp_loc.loc_start, - ~endPos=expr.pexp_loc.loc_end, - p, - Diagnostics.message( - "Tagged template literals are currently restricted to identifiers like: json`null`.", - ), - ) - parseTemplateExpr(p) - } - | _ => expr - } - - loop(p, operand) - } - - /* a unary expression is an expression with only one operand and - * unary operator. Examples: - * -1 - * !condition - * -. 1.6 - */ - and parseUnaryExpr = p => { - let startPos = p.Parser.startPos - switch p.Parser.token { - | (Minus | MinusDot | Plus | PlusDot | Bang) as token => - Parser.leaveBreadcrumb(p, Grammar.ExprUnary) - let tokenEnd = p.endPos - Parser.next(p) - let operand = parseUnaryExpr(p) - let unaryExpr = makeUnaryExpr(startPos, tokenEnd, token, operand) - Parser.eatBreadcrumb(p) - unaryExpr - | _ => parsePrimaryExpr(~operand=parseAtomicExpr(p), p) - } - } - - /* Represents an "operand" in a binary expression. - * If you have `a + b`, `a` and `b` both represent - * the operands of the binary expression with opeartor `+` */ - and parseOperandExpr = (~context, p) => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - let expr = switch p.Parser.token { - | Assert => - Parser.next(p) - let expr = parseUnaryExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.assert_(~loc, expr) - | Lazy => - Parser.next(p) - let expr = parseUnaryExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.lazy_(~loc, expr) - | Try => parseTryExpression(p) - | If => parseIfExpression(p) - | For => parseForExpression(p) - | While => parseWhileExpression(p) - | Switch => parseSwitchExpression(p) - | _ => - if ( - context !== WhenExpr && isEs6ArrowExpression(~inTernary=context == TernaryTrueBranchExpr, p) - ) { - parseEs6ArrowExpression(p) - } else { - parseUnaryExpr(p) - } - } - - /* let endPos = p.Parser.prevEndPos in */ - { - ...expr, - pexp_attributes: List.concat(list{expr.Parsetree.pexp_attributes, attrs}), - /* pexp_loc = mkLoc startPos endPos */ - } - } - - /* a binary expression is an expression that combines two expressions with an - * operator. Examples: - * a + b - * f(x) |> g(y) - */ - and parseBinaryExpr = (~context=OrdinaryExpr, ~a=?, p, prec) => { - let a = switch a { - | Some(e) => e - | None => parseOperandExpr(~context, p) - } - - let rec loop = a => { - let token = p.Parser.token - let tokenPrec = switch token { - /* Can the minus be interpreted as a binary operator? Or is it a unary? - * let w = { - * x - * -10 - * } - * vs - * let w = { - * width - * - gap - * } - * - * First case is unary, second is a binary operator. - * See Scanner.isBinaryOp */ - | Minus | MinusDot | LessThan - when !Scanner.isBinaryOp(p.scanner.src, p.startPos.pos_cnum, p.endPos.pos_cnum) && - p.startPos.pos_lnum > p.prevEndPos.pos_lnum => -1 - | token => Token.precedence(token) - } - - if tokenPrec < prec { - a - } else { - Parser.leaveBreadcrumb(p, Grammar.ExprBinaryAfterOp(token)) - let startPos = p.startPos - Parser.next(p) - let endPos = p.prevEndPos - let b = parseBinaryExpr(~context, p, tokenPrec + 1) - let loc = mkLoc(a.Parsetree.pexp_loc.loc_start, b.pexp_loc.loc_end) - let expr = Ast_helper.Exp.apply( - ~loc, - makeInfixOperator(p, token, startPos, endPos), - list{(Nolabel, a), (Nolabel, b)}, - ) - - loop(expr) - } - } - - loop(a) - } - - /* If we even need this, determines if < might be the start of jsx. Not 100% complete */ - /* and isStartOfJsx p = */ - /* Parser.lookahead p (fun p -> */ - /* match p.Parser.token with */ - /* | LessThan -> */ - /* Parser.next p; */ - /* begin match p.token with */ - /* | GreaterThan (* <> *) -> true */ - /* | Lident _ | Uident _ | List -> */ - /* ignore (parseJsxName p); */ - /* begin match p.token with */ - /* | GreaterThan (*
*) -> true */ - /* | Question (* true */ - /* | Lident _ | List -> */ - /* Parser.next p; */ - /* begin match p.token with */ - /* | Equal (* true */ - /* | _ -> false (* TODO *) */ - /* end */ - /* | Forwardslash (* */ - /* Parser.next p; */ - /* begin match p.token with */ - /* | GreaterThan (* *) -> true */ - /* | _ -> false */ - /* end */ - /* | _ -> */ - /* false */ - /* end */ - /* | _ -> false */ - /* end */ - /* | _ -> false */ - /* ) */ - - and parseTemplateExpr = (~prefix="", p) => { - let hiddenOperator = { - let op = Location.mknoloc(Longident.Lident("^")) - Ast_helper.Exp.ident(op) - } - - let rec loop = (acc, p) => { - let startPos = p.Parser.startPos - switch p.Parser.token { - | TemplateTail(txt) => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - if String.length(txt) > 0 { - let txt = if p.mode == ParseForTypeChecker { - parseTemplateStringLiteral(txt) - } else { - txt - } - let str = Ast_helper.Exp.constant(~loc, Pconst_string(txt, Some(prefix))) - Ast_helper.Exp.apply(~loc, hiddenOperator, list{(Nolabel, acc), (Nolabel, str)}) - } else { - acc - } - | TemplatePart(txt) => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let expr = parseExprBlock(p) - let fullLoc = mkLoc(startPos, p.prevEndPos) - Scanner.setTemplateMode(p.scanner) - Parser.expect(Rbrace, p) - let txt = if p.mode == ParseForTypeChecker { - parseTemplateStringLiteral(txt) - } else { - txt - } - let str = Ast_helper.Exp.constant(~loc, Pconst_string(txt, Some(prefix))) - let next = { - let a = if String.length(txt) > 0 { - Ast_helper.Exp.apply(~loc=fullLoc, hiddenOperator, list{(Nolabel, acc), (Nolabel, str)}) - } else { - acc - } - - Ast_helper.Exp.apply(~loc=fullLoc, hiddenOperator, list{(Nolabel, a), (Nolabel, expr)}) - } - - loop(next, p) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - acc - } - } - - Scanner.setTemplateMode(p.scanner) - Parser.expect(Backtick, p) - let startPos = p.Parser.startPos - switch p.Parser.token { - | TemplateTail(txt) => - let loc = mkLoc(startPos, p.endPos) - Parser.next(p) - let txt = if p.mode == ParseForTypeChecker { - parseTemplateStringLiteral(txt) - } else { - txt - } - Ast_helper.Exp.constant(~loc, Pconst_string(txt, Some(prefix))) - | TemplatePart(txt) => - let constantLoc = mkLoc(startPos, p.endPos) - Parser.next(p) - let expr = parseExprBlock(p) - let fullLoc = mkLoc(startPos, p.prevEndPos) - Scanner.setTemplateMode(p.scanner) - Parser.expect(Rbrace, p) - let txt = if p.mode == ParseForTypeChecker { - parseTemplateStringLiteral(txt) - } else { - txt - } - let str = Ast_helper.Exp.constant(~loc=constantLoc, Pconst_string(txt, Some(prefix))) - let next = if String.length(txt) > 0 { - Ast_helper.Exp.apply(~loc=fullLoc, hiddenOperator, list{(Nolabel, str), (Nolabel, expr)}) - } else { - expr - } - - loop(next, p) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Ast_helper.Exp.constant(Pconst_string("", None)) - } - } - - /* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => - * Also overparse constraints: - * let x = { - * let a = 1 - * a + pi: int - * } - * - * We want to give a nice error message in these cases - * */ - and overParseConstrainedOrCoercedOrArrowExpression = (p, expr) => - switch p.Parser.token { - | ColonGreaterThan => parseCoercedExpr(~expr, p) - | Colon => - Parser.next(p) - let typ = parseTypExpr(~es6Arrow=false, p) - switch p.Parser.token { - | EqualGreater => - Parser.next(p) - let body = parseExpr(p) - let pat = switch expr.pexp_desc { - | Pexp_ident(longident) => - Ast_helper.Pat.var( - ~loc=expr.pexp_loc, - Location.mkloc(Longident.flatten(longident.txt) |> String.concat("."), longident.loc), - ) - /* TODO: can we convert more expressions to patterns? */ - | _ => Ast_helper.Pat.var(~loc=expr.pexp_loc, Location.mkloc("pattern", expr.pexp_loc)) - } - - let arrow1 = Ast_helper.Exp.fun_( - ~loc=mkLoc(expr.pexp_loc.loc_start, body.pexp_loc.loc_end), - Asttypes.Nolabel, - None, - pat, - Ast_helper.Exp.constraint_(body, typ), - ) - - let arrow2 = Ast_helper.Exp.fun_( - ~loc=mkLoc(expr.pexp_loc.loc_start, body.pexp_loc.loc_end), - Asttypes.Nolabel, - None, - Ast_helper.Pat.constraint_(pat, typ), - body, - ) - - let msg = - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.text("Did you mean to annotate the parameter type or the return type?"), - Doc.indent( - Doc.concat(list{ - Doc.line, - Doc.text("1) "), - Printer.printExpression(arrow1, CommentTable.empty), - Doc.line, - Doc.text("2) "), - Printer.printExpression(arrow2, CommentTable.empty), - }), - ), - }), - ) |> Doc.toString(~width=80) - - Parser.err( - ~startPos=expr.pexp_loc.loc_start, - ~endPos=body.pexp_loc.loc_end, - p, - Diagnostics.message(msg), - ) - arrow1 - | _ => - open Parsetree - let loc = mkLoc(expr.pexp_loc.loc_start, typ.ptyp_loc.loc_end) - let expr = Ast_helper.Exp.constraint_(~loc, expr, typ) - let () = Parser.err( - ~startPos=expr.pexp_loc.loc_start, - ~endPos=typ.ptyp_loc.loc_end, - p, - Diagnostics.message( - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.text("Expressions with type constraints need to be wrapped in parens:"), - Doc.indent( - Doc.concat(list{ - Doc.line, - Printer.addParens(Printer.printExpression(expr, CommentTable.empty)), - }), - ), - }), - ) |> Doc.toString(~width=80), - ), - ) - - expr - } - | _ => expr - } - - and parseLetBindingBody = (~startPos, ~attrs, p) => { - Parser.beginRegion(p) - Parser.leaveBreadcrumb(p, Grammar.LetBinding) - let (pat, exp) = { - let pat = parsePattern(p) - switch p.Parser.token { - | Colon => - Parser.next(p) - switch p.token { - | Typ => - /* locally abstract types */ - Parser.next(p) - let newtypes = parseLidentList(p) - Parser.expect(Dot, p) - let typ = parseTypExpr(p) - Parser.expect(Equal, p) - let expr = parseExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - let (exp, poly) = wrapTypeAnnotation(~loc, newtypes, typ, expr) - let pat = Ast_helper.Pat.constraint_(~loc, pat, poly) - (pat, exp) - | _ => - let polyType = parsePolyTypeExpr(p) - let loc = {...pat.ppat_loc, loc_end: polyType.Parsetree.ptyp_loc.loc_end} - let pat = Ast_helper.Pat.constraint_(~loc, pat, polyType) - Parser.expect(Token.Equal, p) - let exp = parseExpr(p) - let exp = overParseConstrainedOrCoercedOrArrowExpression(p, exp) - (pat, exp) - } - | _ => - Parser.expect(Token.Equal, p) - let exp = overParseConstrainedOrCoercedOrArrowExpression(p, parseExpr(p)) - (pat, exp) - } - } - - let loc = mkLoc(startPos, p.prevEndPos) - let vb = Ast_helper.Vb.mk(~loc, ~attrs, pat, exp) - Parser.eatBreadcrumb(p) - Parser.endRegion(p) - vb - } - - /* TODO: find a better way? Is it possible? - * let a = 1 - * @attr - * and b = 2 - * - * The problem is that without semi we need a lookahead to determine - * if the attr is on the letbinding or the start of a new thing - * - * let a = 1 - * @attr - * let b = 1 - * - * Here @attr should attach to something "new": `let b = 1` - * The parser state is forked, which is quite expensive… - */ - and parseAttributesAndBinding = (p: Parser.t) => { - let err = p.scanner.err - let ch = p.scanner.ch - let offset = p.scanner.offset - let rdOffset = p.scanner.rdOffset - let lineOffset = p.scanner.lineOffset - let lnum = p.scanner.lnum - let mode = p.scanner.mode - let token = p.token - let startPos = p.startPos - let endPos = p.endPos - let prevEndPos = p.prevEndPos - let breadcrumbs = p.breadcrumbs - let errors = p.errors - let diagnostics = p.diagnostics - let comments = p.comments - - switch p.Parser.token { - | At => - let attrs = parseAttributes(p) - switch p.Parser.token { - | And => attrs - | _ => - p.scanner.err = err - p.scanner.ch = ch - p.scanner.offset = offset - p.scanner.rdOffset = rdOffset - p.scanner.lineOffset = lineOffset - p.scanner.lnum = lnum - p.scanner.mode = mode - p.token = token - p.startPos = startPos - p.endPos = endPos - p.prevEndPos = prevEndPos - p.breadcrumbs = breadcrumbs - p.errors = errors - p.diagnostics = diagnostics - p.comments = comments - list{} - } - | _ => list{} - } - } - - /* definition ::= let [rec] let-binding { and let-binding } */ - and parseLetBindings = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.optional(p, Let) |> ignore - let recFlag = if Parser.optional(p, Token.Rec) { - Asttypes.Recursive - } else { - Asttypes.Nonrecursive - } - - let first = parseLetBindingBody(~startPos, ~attrs, p) - - let rec loop = (p, bindings) => { - let startPos = p.Parser.startPos - let attrs = parseAttributesAndBinding(p) - switch p.Parser.token { - | And => - Parser.next(p) - let attrs = switch p.token { - | Export => - let exportLoc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - let genTypeAttr = (Location.mkloc("genType", exportLoc), Parsetree.PStr(list{})) - list{genTypeAttr, ...attrs} - | _ => attrs - } - - ignore(Parser.optional(p, Let)) /* overparse for fault tolerance */ - let letBinding = parseLetBindingBody(~startPos, ~attrs, p) - loop(p, list{letBinding, ...bindings}) - | _ => List.rev(bindings) - } - } - - (recFlag, loop(p, list{first})) - } - - /* - * div -> div - * Foo -> Foo.createElement - * Foo.Bar -> Foo.Bar.createElement - */ - and parseJsxName = p => { - let longident = switch p.Parser.token { - | Lident(ident) => - let identStart = p.startPos - let identEnd = p.endPos - Parser.next(p) - let loc = mkLoc(identStart, identEnd) - Location.mkloc(Longident.Lident(ident), loc) - | Uident(_) => - let longident = parseModuleLongIdent(~lowercase=false, p) - Location.mkloc(Longident.Ldot(longident.txt, "createElement"), longident.loc) - | _ => - let msg = "A jsx name should start with a lowercase or uppercase identifier, like: div in
or Navbar in " - - Parser.err(p, Diagnostics.message(msg)) - Location.mknoloc(Longident.Lident("_")) - } - - Ast_helper.Exp.ident(~loc=longident.loc, longident) - } - - and parseJsxOpeningOrSelfClosingElement = (~startPos, p) => { - let jsxStartPos = p.Parser.startPos - let name = parseJsxName(p) - let jsxProps = parseJsxProps(p) - let children = switch p.Parser.token { - | Forwardslash => - /* */ - let childrenStartPos = p.Parser.startPos - Parser.next(p) - let childrenEndPos = p.Parser.startPos - Parser.expect(GreaterThan, p) - let loc = mkLoc(childrenStartPos, childrenEndPos) - makeListExpression(loc, list{}, None) /* no children */ - | GreaterThan => - /* bar */ - let childrenStartPos = p.Parser.startPos - Scanner.setJsxMode(p.scanner) - Parser.next(p) - let (spread, children) = parseJsxChildren(p) - let childrenEndPos = p.Parser.startPos - let () = switch p.token { - | LessThanSlash => Parser.next(p) - | LessThan => - Parser.next(p) - Parser.expect(Forwardslash, p) - | token when Grammar.isStructureItemStart(token) => () - | _ => Parser.expect(LessThanSlash, p) - } - - switch p.Parser.token { - | Lident(_) | Uident(_) when verifyJsxOpeningClosingName(p, name) => - Parser.expect(GreaterThan, p) - let loc = mkLoc(childrenStartPos, childrenEndPos) - switch (spread, children) { - | (true, list{child, ..._}) => child - | _ => makeListExpression(loc, children, None) - } - | token => - let () = if Grammar.isStructureItemStart(token) { - let closing = "") - let msg = Diagnostics.message("Missing " ++ closing) - Parser.err(~startPos, ~endPos=p.prevEndPos, p, msg) - } else { - let opening = "") - let msg = - "Closing jsx name should be the same as the opening name. Did you mean " ++ - (opening ++ - " ?") - Parser.err(~startPos, ~endPos=p.prevEndPos, p, Diagnostics.message(msg)) - Parser.expect(GreaterThan, p) - } - - let loc = mkLoc(childrenStartPos, childrenEndPos) - switch (spread, children) { - | (true, list{child, ..._}) => child - | _ => makeListExpression(loc, children, None) - } - } - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - makeListExpression(Location.none, list{}, None) - } - - let jsxEndPos = p.prevEndPos - let loc = mkLoc(jsxStartPos, jsxEndPos) - Ast_helper.Exp.apply( - ~loc, - name, - List.concat(list{ - jsxProps, - list{ - (Asttypes.Labelled("children"), children), - ( - Asttypes.Nolabel, - Ast_helper.Exp.construct(Location.mknoloc(Longident.Lident("()")), None), - ), - }, - }), - ) - } - - /* - * jsx ::= - * | <> jsx-children - * | - * | jsx-children - * - * jsx-children ::= primary-expr* * => 0 or more - */ - and parseJsx = p => { - Parser.leaveBreadcrumb(p, Grammar.Jsx) - let startPos = p.Parser.startPos - Parser.expect(LessThan, p) - let jsxExpr = switch p.Parser.token { - | Lident(_) | Uident(_) => parseJsxOpeningOrSelfClosingElement(~startPos, p) - | GreaterThan => - /* fragment: <> foo */ - parseJsxFragment(p) - | _ => parseJsxName(p) - } - - {...jsxExpr, pexp_attributes: list{jsxAttr}} - } - - /* - * jsx-fragment ::= - * | <> - * | <> jsx-children - */ - and parseJsxFragment = p => { - let childrenStartPos = p.Parser.startPos - Scanner.setJsxMode(p.scanner) - Parser.expect(GreaterThan, p) - let (_spread, children) = parseJsxChildren(p) - let childrenEndPos = p.Parser.startPos - Parser.expect(LessThanSlash, p) - Parser.expect(GreaterThan, p) - let loc = mkLoc(childrenStartPos, childrenEndPos) - makeListExpression(loc, children, None) - } - - /* - * jsx-prop ::= - * | lident - * | ?lident - * | lident = jsx_expr - * | lident = ?jsx_expr - */ - and parseJsxProp = p => { - Parser.leaveBreadcrumb(p, Grammar.JsxAttribute) - switch p.Parser.token { - | Question | Lident(_) => - let optional = Parser.optional(p, Question) - let (name, loc) = parseLident(p) - let propLocAttr = (Location.mkloc("res.namedArgLoc", loc), Parsetree.PStr(list{})) - /* optional punning: */ - if optional { - Some( - Asttypes.Optional(name), - Ast_helper.Exp.ident( - ~attrs=list{propLocAttr}, - ~loc, - Location.mkloc(Longident.Lident(name), loc), - ), - ) - } else { - switch p.Parser.token { - | Equal => - Parser.next(p) - /* no punning */ - let optional = Parser.optional(p, Question) - let attrExpr = { - let e = parsePrimaryExpr(~operand=parseAtomicExpr(p), p) - {...e, pexp_attributes: list{propLocAttr, ...e.pexp_attributes}} - } - - let label = if optional { - Asttypes.Optional(name) - } else { - Asttypes.Labelled(name) - } - - Some(label, attrExpr) - | _ => - let attrExpr = Ast_helper.Exp.ident( - ~loc, - ~attrs=list{propLocAttr}, - Location.mknoloc(Longident.Lident(name)), - ) - let label = if optional { - Asttypes.Optional(name) - } else { - Asttypes.Labelled(name) - } - - Some(label, attrExpr) - } - } - | _ => None - } - } - - and parseJsxProps = p => parseRegion(~grammar=Grammar.JsxAttribute, ~f=parseJsxProp, p) - - and parseJsxChildren = p => { - let rec loop = (p, children) => - switch p.Parser.token { - | Token.Eof | LessThanSlash => - Scanner.popMode(p.scanner, Jsx) - List.rev(children) - | LessThan => - /* Imagine:
< - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate */ - let token = Scanner.reconsiderLessThan(p.scanner) - if token == LessThan { - let child = parsePrimaryExpr(~operand=parseAtomicExpr(p), ~noCall=true, p) - loop(p, list{child, ...children}) - } else { - /* LessThanSlash */ - let () = p.token = token - let () = Scanner.popMode(p.scanner, Jsx) - List.rev(children) - } - | token when Grammar.isJsxChildStart(token) => - let () = Scanner.popMode(p.scanner, Jsx) - let child = parsePrimaryExpr(~operand=parseAtomicExpr(p), ~noCall=true, p) - loop(p, list{child, ...children}) - | _ => - Scanner.popMode(p.scanner, Jsx) - List.rev(children) - } - - switch p.Parser.token { - | DotDotDot => - Parser.next(p) - (true, list{parsePrimaryExpr(~operand=parseAtomicExpr(p), ~noCall=true, p)}) - | _ => (false, loop(p, list{})) - } - } - - and parseBracedOrRecordExpr = p => { - let startPos = p.Parser.startPos - Parser.expect(Lbrace, p) - switch p.Parser.token { - | Rbrace => - Parser.err(p, Diagnostics.unexpected(Rbrace, p.breadcrumbs)) - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - Ast_helper.Exp.construct( - ~attrs=list{braces}, - ~loc, - Location.mkloc(Longident.Lident("()"), loc), - None, - ) - | DotDotDot => - /* beginning of record spread, parse record */ - Parser.next(p) - let spreadExpr = parseConstrainedOrCoercedExpr(p) - Parser.expect(Comma, p) - let expr = parseRecordExpr(~startPos, ~spread=Some(spreadExpr), list{}, p) - Parser.expect(Rbrace, p) - expr - | String(s) => - let field = { - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Location.mkloc(Longident.Lident(s), loc) - } - - switch p.Parser.token { - | Colon => - Parser.next(p) - let fieldExpr = parseExpr(p) - Parser.optional(p, Comma) |> ignore - let expr = parseRecordExprWithStringKeys(~startPos, (field, fieldExpr), p) - Parser.expect(Rbrace, p) - expr - | _ => - let constant = Ast_helper.Exp.constant(~loc=field.loc, Parsetree.Pconst_string(s, None)) - let a = parsePrimaryExpr(~operand=constant, p) - let e = parseBinaryExpr(~a, p, 1) - let e = parseTernaryExpr(e, p) - switch p.Parser.token { - | Semicolon => - Parser.next(p) - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - | Rbrace => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...e, pexp_attributes: list{braces, ...e.pexp_attributes}} - | _ => - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - } - } - | Uident(_) | Lident(_) => - let valueOrConstructor = parseValueOrConstructor(p) - switch valueOrConstructor.pexp_desc { - | Pexp_ident(pathIdent) => - let identEndPos = p.prevEndPos - switch p.Parser.token { - | Comma => - Parser.next(p) - let expr = parseRecordExpr(~startPos, list{(pathIdent, valueOrConstructor)}, p) - Parser.expect(Rbrace, p) - expr - | Colon => - Parser.next(p) - let fieldExpr = parseExpr(p) - switch p.token { - | Rbrace => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.record(~loc, list{(pathIdent, fieldExpr)}, None) - | _ => - Parser.expect(Comma, p) - let expr = parseRecordExpr(~startPos, list{(pathIdent, fieldExpr)}, p) - Parser.expect(Rbrace, p) - expr - } - /* error case */ - | Lident(_) => - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum { - Parser.expect(Comma, p) - let expr = parseRecordExpr(~startPos, list{(pathIdent, valueOrConstructor)}, p) - Parser.expect(Rbrace, p) - expr - } else { - Parser.expect(Colon, p) - let expr = parseRecordExpr(~startPos, list{(pathIdent, valueOrConstructor)}, p) - Parser.expect(Rbrace, p) - expr - } - | Semicolon => - Parser.next(p) - let expr = parseExprBlock(~first=Ast_helper.Exp.ident(pathIdent), p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - | Rbrace => - Parser.next(p) - let expr = Ast_helper.Exp.ident(~loc=pathIdent.loc, pathIdent) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - | EqualGreater => - let loc = mkLoc(startPos, identEndPos) - let ident = Location.mkloc(Longident.last(pathIdent.txt), loc) - let a = parseEs6ArrowExpression( - ~parameters=list{ - TermParameter({ - uncurried: false, - attrs: list{}, - label: Asttypes.Nolabel, - expr: None, - pat: Ast_helper.Pat.var(ident), - pos: startPos, - }), - }, - p, - ) - - let e = parseBinaryExpr(~a, p, 1) - let e = parseTernaryExpr(e, p) - switch p.Parser.token { - | Semicolon => - Parser.next(p) - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - | Rbrace => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...e, pexp_attributes: list{braces, ...e.pexp_attributes}} - | _ => - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - } - | _ => - Parser.leaveBreadcrumb(p, Grammar.ExprBlock) - let a = parsePrimaryExpr(~operand=Ast_helper.Exp.ident(~loc=pathIdent.loc, pathIdent), p) - let e = parseBinaryExpr(~a, p, 1) - let e = parseTernaryExpr(e, p) - Parser.eatBreadcrumb(p) - switch p.Parser.token { - | Semicolon => - Parser.next(p) - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - | Rbrace => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...e, pexp_attributes: list{braces, ...e.pexp_attributes}} - | _ => - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - } - } - | _ => - Parser.leaveBreadcrumb(p, Grammar.ExprBlock) - let a = parsePrimaryExpr(~operand=valueOrConstructor, p) - let e = parseBinaryExpr(~a, p, 1) - let e = parseTernaryExpr(e, p) - Parser.eatBreadcrumb(p) - switch p.Parser.token { - | Semicolon => - Parser.next(p) - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - | Rbrace => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...e, pexp_attributes: list{braces, ...e.pexp_attributes}} - | _ => - let expr = parseExprBlock(~first=e, p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - } - } - | _ => - let expr = parseExprBlock(p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let braces = makeBracesAttr(loc) - {...expr, pexp_attributes: list{braces, ...expr.pexp_attributes}} - } - } - - and parseRecordRowWithStringKey = p => - switch p.Parser.token { - | String(s) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - let field = Location.mkloc(Longident.Lident(s), loc) - switch p.Parser.token { - | Colon => - Parser.next(p) - let fieldExpr = parseExpr(p) - Some(field, fieldExpr) - | _ => Some(field, Ast_helper.Exp.ident(~loc=field.loc, field)) - } - | _ => None - } - - and parseRecordRow = p => { - let () = switch p.Parser.token { - | Token.DotDotDot => - Parser.err(p, Diagnostics.message(ErrorMessages.recordExprSpread)) - Parser.next(p) - | _ => () - } - - switch p.Parser.token { - | Lident(_) | Uident(_) | List => - let field = parseValuePath(p) - switch p.Parser.token { - | Colon => - Parser.next(p) - let fieldExpr = parseExpr(p) - Some(field, fieldExpr) - | _ => Some(field, Ast_helper.Exp.ident(~loc=field.loc, field)) - } - | _ => None - } - } - - and parseRecordExprWithStringKeys = (~startPos, firstRow, p) => { - let rows = list{ - firstRow, - ...parseCommaDelimitedRegion( - ~grammar=Grammar.RecordRowsStringKey, - ~closing=Rbrace, - ~f=parseRecordRowWithStringKey, - p, - ), - } - let loc = mkLoc(startPos, p.endPos) - let recordStrExpr = Ast_helper.Str.eval(~loc, Ast_helper.Exp.record(~loc, rows, None)) - Ast_helper.Exp.extension( - ~loc, - (Location.mkloc("bs.obj", loc), Parsetree.PStr(list{recordStrExpr})), - ) - } - - and parseRecordExpr = (~startPos, ~spread=None, rows, p) => { - let exprs = parseCommaDelimitedRegion( - ~grammar=Grammar.RecordRows, - ~closing=Rbrace, - ~f=parseRecordRow, - p, - ) - - let rows = List.concat(list{rows, exprs}) - let () = switch rows { - | list{} => - let msg = "Record spread needs at least one field that's updated" - Parser.err(p, Diagnostics.message(msg)) - | _rows => () - } - - let loc = mkLoc(startPos, p.endPos) - Ast_helper.Exp.record(~loc, rows, spread) - } - - and parseExprBlockItem = p => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - switch p.Parser.token { - | Module => - Parser.next(p) - switch p.token { - | Lparen => parseFirstClassModuleExpr(~startPos, p) - | _ => - let name = switch p.Parser.token { - | Uident(ident) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Location.mkloc(ident, loc) - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mknoloc("_") - } - - let body = parseModuleBindingBody(p) - Parser.optional(p, Semicolon) |> ignore - let expr = parseExprBlock(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.letmodule(~loc, name, body, expr) - } - | Exception => - let extensionConstructor = parseExceptionDef(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let blockExpr = parseExprBlock(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.letexception(~loc, extensionConstructor, blockExpr) - | Open => - let od = parseOpenDescription(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let blockExpr = parseExprBlock(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.open_(~loc, od.popen_override, od.popen_lid, blockExpr) - | Let => - let (recFlag, letBindings) = parseLetBindings(~attrs, p) - let next = switch p.Parser.token { - | Semicolon => - Parser.next(p) - if Grammar.isBlockExprStart(p.Parser.token) { - parseExprBlock(p) - } else { - let loc = mkLoc(p.startPos, p.endPos) - Ast_helper.Exp.construct(~loc, Location.mkloc(Longident.Lident("()"), loc), None) - } - | token when Grammar.isBlockExprStart(token) => parseExprBlock(p) - | _ => - let loc = mkLoc(p.startPos, p.endPos) - Ast_helper.Exp.construct(~loc, Location.mkloc(Longident.Lident("()"), loc), None) - } - - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.let_(~loc, recFlag, letBindings, next) - | _ => - let e1 = { - let expr = parseExpr(p) - {...expr, pexp_attributes: List.concat(list{attrs, expr.pexp_attributes})} - } - - ignore(Parser.optional(p, Semicolon)) - if Grammar.isBlockExprStart(p.Parser.token) { - let e2 = parseExprBlock(p) - let loc = {...e1.pexp_loc, loc_end: e2.pexp_loc.loc_end} - Ast_helper.Exp.sequence(~loc, e1, e2) - } else { - e1 - } - } - } - - /* blockExpr ::= expr - * | expr ; - * | expr ; blockExpr - * | module ... ; blockExpr - * | open ... ; blockExpr - * | exception ... ; blockExpr - * | let ... - * | let ... ; - * | let ... ; blockExpr - * - * note: semi should be made optional - * a block of expression is always - */ - and parseExprBlock = (~first=?, p) => { - Parser.leaveBreadcrumb(p, Grammar.ExprBlock) - let item = switch first { - | Some(e) => e - | None => parseExprBlockItem(p) - } - - let blockExpr = switch p.Parser.token { - | Semicolon => - Parser.next(p) - if Grammar.isBlockExprStart(p.Parser.token) { - let next = parseExprBlockItem(p) - ignore(Parser.optional(p, Semicolon)) - let loc = {...item.pexp_loc, loc_end: next.pexp_loc.loc_end} - Ast_helper.Exp.sequence(~loc, item, next) - } else { - item - } - | token when Grammar.isBlockExprStart(token) => - let next = parseExprBlockItem(p) - ignore(Parser.optional(p, Semicolon)) - let loc = {...item.pexp_loc, loc_end: next.pexp_loc.loc_end} - Ast_helper.Exp.sequence(~loc, item, next) - | _ => item - } - - Parser.eatBreadcrumb(p) - overParseConstrainedOrCoercedOrArrowExpression(p, blockExpr) - } - - and parseTryExpression = p => { - let startPos = p.Parser.startPos - Parser.expect(Try, p) - let expr = parseExpr(~context=WhenExpr, p) - Parser.expect(Catch, p) - Parser.expect(Lbrace, p) - let cases = parsePatternMatching(p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.try_(~loc, expr, cases) - } - - and parseIfExpression = p => { - Parser.beginRegion(p) - Parser.leaveBreadcrumb(p, Grammar.ExprIf) - let startPos = p.Parser.startPos - Parser.expect(If, p) - Parser.leaveBreadcrumb(p, Grammar.IfCondition) - /* doesn't make sense to try es6 arrow here? */ - let conditionExpr = parseExpr(~context=WhenExpr, p) - Parser.eatBreadcrumb(p) - Parser.leaveBreadcrumb(p, IfBranch) - Parser.expect(Lbrace, p) - let thenExpr = parseExprBlock(p) - Parser.expect(Rbrace, p) - Parser.eatBreadcrumb(p) - let elseExpr = switch p.Parser.token { - | Else => - Parser.endRegion(p) - Parser.leaveBreadcrumb(p, Grammar.ElseBranch) - Parser.next(p) - Parser.beginRegion(p) - let elseExpr = switch p.token { - | If => parseIfExpression(p) - | _ => - Parser.expect(Lbrace, p) - let blockExpr = parseExprBlock(p) - Parser.expect(Rbrace, p) - blockExpr - } - - Parser.eatBreadcrumb(p) - Parser.endRegion(p) - Some(elseExpr) - | _ => - Parser.endRegion(p) - None - } - - let loc = mkLoc(startPos, p.prevEndPos) - Parser.eatBreadcrumb(p) - Ast_helper.Exp.ifthenelse(~loc, conditionExpr, thenExpr, elseExpr) - } - - and parseForRest = (hasOpeningParen, pattern, startPos, p) => { - Parser.expect(In, p) - let e1 = parseExpr(p) - let direction = switch p.Parser.token { - | To => Asttypes.Upto - | Downto => Asttypes.Downto - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Asttypes.Upto - } - - Parser.next(p) - let e2 = parseExpr(~context=WhenExpr, p) - if hasOpeningParen { - Parser.expect(Rparen, p) - } - Parser.expect(Lbrace, p) - let bodyExpr = parseExprBlock(p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.for_(~loc, pattern, e1, e2, direction, bodyExpr) - } - - and parseForExpression = p => { - let startPos = p.Parser.startPos - Parser.expect(For, p) - switch p.token { - | Lparen => - let lparen = p.startPos - Parser.next(p) - switch p.token { - | Rparen => - Parser.next(p) - let unitPattern = { - let loc = mkLoc(lparen, p.prevEndPos) - let lid = Location.mkloc(Longident.Lident("()"), loc) - Ast_helper.Pat.construct(lid, None) - } - - parseForRest(false, parseAliasPattern(~attrs=list{}, unitPattern, p), startPos, p) - | _ => - let pat = parsePattern(p) - switch p.token { - | Comma => - Parser.next(p) - let tuplePattern = parseTuplePattern(~attrs=list{}, ~startPos=lparen, ~first=pat, p) - - let pattern = parseAliasPattern(~attrs=list{}, tuplePattern, p) - parseForRest(false, pattern, startPos, p) - | _ => parseForRest(true, pat, startPos, p) - } - } - | _ => parseForRest(false, parsePattern(p), startPos, p) - } - } - - and parseWhileExpression = p => { - let startPos = p.Parser.startPos - Parser.expect(While, p) - let expr1 = parseExpr(~context=WhenExpr, p) - Parser.expect(Lbrace, p) - let expr2 = parseExprBlock(p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.while_(~loc, expr1, expr2) - } - - and parsePatternMatchCase = p => { - Parser.beginRegion(p) - Parser.leaveBreadcrumb(p, Grammar.PatternMatchCase) - switch p.Parser.token { - | Token.Bar => - Parser.next(p) - let lhs = parsePattern(p) - let guard = switch p.Parser.token { - | When => - Parser.next(p) - Some(parseExpr(~context=WhenExpr, p)) - | _ => None - } - - let () = switch p.token { - | EqualGreater => Parser.next(p) - | _ => Recover.recoverEqualGreater(p) - } - - let rhs = parseExprBlock(p) - Parser.endRegion(p) - Parser.eatBreadcrumb(p) - Some(Ast_helper.Exp.case(lhs, ~guard?, rhs)) - | _ => - Parser.endRegion(p) - None - } - } - - and parsePatternMatching = p => { - Parser.leaveBreadcrumb(p, Grammar.PatternMatching) - let cases = parseDelimitedRegion( - ~grammar=Grammar.PatternMatching, - ~closing=Rbrace, - ~f=parsePatternMatchCase, - p, - ) - - let () = switch cases { - | list{} => - Parser.err( - ~startPos=p.prevEndPos, - p, - Diagnostics.message("Pattern matching needs at least one case"), - ) - | _ => () - } - - cases - } - - and parseSwitchExpression = p => { - let startPos = p.Parser.startPos - Parser.expect(Switch, p) - let switchExpr = parseExpr(~context=WhenExpr, p) - Parser.expect(Lbrace, p) - let cases = parsePatternMatching(p) - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.match_(~loc, switchExpr, cases) - } - - /* - * argument ::= - * | _ (* syntax sugar *) - * | expr - * | expr : type - * | ~ label-name - * | ~ label-name - * | ~ label-name ? - * | ~ label-name = expr - * | ~ label-name = _ (* syntax sugar *) - * | ~ label-name = expr : type - * | ~ label-name = ? expr - * | ~ label-name = ? _ (* syntax sugar *) - * | ~ label-name = ? expr : type - * - * uncurried_argument ::= - * | . argument - */ - and parseArgument = p => - if ( - p.Parser.token == Token.Tilde || - (p.token == Dot || - (p.token == Underscore || Grammar.isExprStart(p.token))) - ) { - switch p.Parser.token { - | Dot => - let uncurried = true - let startPos = p.Parser.startPos - Parser.next(p) - switch p.token { - /* apply(.) */ - | Rparen => - let loc = mkLoc(startPos, p.prevEndPos) - let unitExpr = Ast_helper.Exp.construct( - ~loc, - Location.mkloc(Longident.Lident("()"), loc), - None, - ) - - Some(uncurried, Asttypes.Nolabel, unitExpr) - | _ => parseArgument2(p, ~uncurried) - } - | _ => parseArgument2(p, ~uncurried=false) - } - } else { - None - } - - and parseArgument2 = (p, ~uncurried) => - switch p.Parser.token { - /* foo(_), do not confuse with foo(_ => x), TODO: performance */ - | Underscore when !isEs6ArrowExpression(~inTernary=false, p) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - let exp = Ast_helper.Exp.ident(~loc, Location.mkloc(Longident.Lident("_"), loc)) - Some(uncurried, Asttypes.Nolabel, exp) - | Tilde => - Parser.next(p) - /* TODO: nesting of pattern matches not intuitive for error recovery */ - switch p.Parser.token { - | Lident(ident) => - let startPos = p.startPos - Parser.next(p) - let endPos = p.prevEndPos - let loc = mkLoc(startPos, endPos) - let propLocAttr = (Location.mkloc("res.namedArgLoc", loc), Parsetree.PStr(list{})) - let identExpr = Ast_helper.Exp.ident( - ~attrs=list{propLocAttr}, - ~loc, - Location.mkloc(Longident.Lident(ident), loc), - ) - switch p.Parser.token { - | Question => - Parser.next(p) - Some(uncurried, Asttypes.Optional(ident), identExpr) - | Equal => - Parser.next(p) - let label = switch p.Parser.token { - | Question => - Parser.next(p) - Asttypes.Optional(ident) - | _ => Labelled(ident) - } - - let expr = switch p.Parser.token { - | Underscore when !isEs6ArrowExpression(~inTernary=false, p) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Ast_helper.Exp.ident(~loc, Location.mkloc(Longident.Lident("_"), loc)) - | _ => - let expr = parseConstrainedOrCoercedExpr(p) - {...expr, pexp_attributes: list{propLocAttr, ...expr.pexp_attributes}} - } - - Some(uncurried, label, expr) - | Colon => - Parser.next(p) - let typ = parseTypExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - let expr = Ast_helper.Exp.constraint_(~attrs=list{propLocAttr}, ~loc, identExpr, typ) - Some(uncurried, Labelled(ident), expr) - | _ => Some(uncurried, Labelled(ident), identExpr) - } - | t => - Parser.err(p, Diagnostics.lident(t)) - Some(uncurried, Nolabel, Recover.defaultExpr()) - } - | _ => Some(uncurried, Nolabel, parseConstrainedOrCoercedExpr(p)) - } - - and parseCallExpr = (p, funExpr) => { - Parser.expect(Lparen, p) - let startPos = p.Parser.startPos - Parser.leaveBreadcrumb(p, Grammar.ExprCall) - let args = parseCommaDelimitedRegion( - ~grammar=Grammar.ArgumentList, - ~closing=Rparen, - ~f=parseArgument, - p, - ) - - Parser.expect(Rparen, p) - let args = switch args { - | list{} => - let loc = mkLoc(startPos, p.prevEndPos) - /* No args -> unit sugar: `foo()` */ - list{ - ( - false, - Asttypes.Nolabel, - Ast_helper.Exp.construct(~loc, Location.mkloc(Longident.Lident("()"), loc), None), - ), - } - | args => args - } - - let loc = {...funExpr.pexp_loc, loc_end: p.prevEndPos} - let args = switch args { - | list{(u, lbl, expr), ...args} => - let group = ((grp, acc), (uncurried, lbl, expr)) => { - let (_u, grp) = grp - if uncurried === true { - ((true, list{(lbl, expr)}), list{(_u, List.rev(grp)), ...acc}) - } else { - ((_u, list{(lbl, expr), ...grp}), acc) - } - } - - let ((_u, grp), acc) = List.fold_left(group, ((u, list{(lbl, expr)}), list{}), args) - List.rev(list{(_u, List.rev(grp)), ...acc}) - | list{} => list{} - } - - let apply = List.fold_left((callBody, group) => { - let (uncurried, args) = group - let (args, wrap) = processUnderscoreApplication(args) - let exp = if uncurried { - let attrs = list{uncurryAttr} - Ast_helper.Exp.apply(~loc, ~attrs, callBody, args) - } else { - Ast_helper.Exp.apply(~loc, callBody, args) - } - - wrap(exp) - }, funExpr, args) - - Parser.eatBreadcrumb(p) - apply - } - - and parseValueOrConstructor = p => { - let startPos = p.Parser.startPos - let rec aux = (p, acc) => - switch p.Parser.token { - | Uident(ident) => - let endPosLident = p.endPos - Parser.next(p) - switch p.Parser.token { - | Dot => - Parser.next(p) - aux(p, list{ident, ...acc}) - | Lparen when p.prevEndPos.pos_lnum === p.startPos.pos_lnum => - let lparen = p.startPos - let args = parseConstructorArgs(p) - let rparen = p.prevEndPos - let lident = buildLongident(list{ident, ...acc}) - let tail = switch args { - | list{} => None - | list{{Parsetree.pexp_desc: Pexp_tuple(_)} as arg} as args => - let loc = mkLoc(lparen, rparen) - if p.mode == ParseForTypeChecker { - /* Some(1, 2) for type-checker */ - Some(arg) - } else { - /* Some((1, 2)) for printer */ - Some(Ast_helper.Exp.tuple(~loc, args)) - } - | list{arg} => Some(arg) - | args => - let loc = mkLoc(lparen, rparen) - Some(Ast_helper.Exp.tuple(~loc, args)) - } - - let loc = mkLoc(startPos, p.prevEndPos) - let identLoc = mkLoc(startPos, endPosLident) - Ast_helper.Exp.construct(~loc, Location.mkloc(lident, identLoc), tail) - | _ => - let loc = mkLoc(startPos, p.prevEndPos) - let lident = buildLongident(list{ident, ...acc}) - Ast_helper.Exp.construct(~loc, Location.mkloc(lident, loc), None) - } - | Lident(ident) => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let lident = buildLongident(list{ident, ...acc}) - Ast_helper.Exp.ident(~loc, Location.mkloc(lident, loc)) - | List => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let lident = buildLongident(list{"list", ...acc}) - Ast_helper.Exp.ident(~loc, Location.mkloc(lident, loc)) - | token => - Parser.next(p) - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Recover.defaultExpr() - } - - aux(p, list{}) - } - - and parsePolyVariantExpr = p => { - let startPos = p.startPos - let (ident, _loc) = parseHashIdent(~startPos, p) - switch p.Parser.token { - | Lparen when p.prevEndPos.pos_lnum === p.startPos.pos_lnum => - let lparen = p.startPos - let args = parseConstructorArgs(p) - let rparen = p.prevEndPos - let loc_paren = mkLoc(lparen, rparen) - let tail = switch args { - | list{} => None - | list{{Parsetree.pexp_desc: Pexp_tuple(_)} as expr} as args => - if p.mode == ParseForTypeChecker { - /* #a(1, 2) for type-checker */ - Some(expr) - } else { - /* #a((1, 2)) for type-checker */ - Some(Ast_helper.Exp.tuple(~loc=loc_paren, args)) - } - | list{arg} => Some(arg) - | args => - /* #a((1, 2)) for printer */ - Some(Ast_helper.Exp.tuple(~loc=loc_paren, args)) - } - - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.variant(~loc, ident, tail) - | _ => - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Exp.variant(~loc, ident, None) - } - } - - and parseConstructorArgs = p => { - let lparen = p.Parser.startPos - Parser.expect(Lparen, p) - let args = parseCommaDelimitedRegion( - ~grammar=Grammar.ExprList, - ~f=parseConstrainedExprRegion, - ~closing=Rparen, - p, - ) - - Parser.expect(Rparen, p) - switch args { - | list{} => - let loc = mkLoc(lparen, p.prevEndPos) - list{Ast_helper.Exp.construct(~loc, Location.mkloc(Longident.Lident("()"), loc), None)} - | args => args - } - } - - and parseTupleExpr = (~first, ~startPos, p) => { - let exprs = parseCommaDelimitedRegion( - p, - ~grammar=Grammar.ExprList, - ~closing=Rparen, - ~f=parseConstrainedExprRegion, - ) - - Parser.expect(Rparen, p) - Ast_helper.Exp.tuple(~loc=mkLoc(startPos, p.prevEndPos), list{first, ...exprs}) - } - - and parseSpreadExprRegion = p => - switch p.Parser.token { - | DotDotDot => - Parser.next(p) - let expr = parseConstrainedOrCoercedExpr(p) - Some(true, expr) - | token when Grammar.isExprStart(token) => Some(false, parseConstrainedOrCoercedExpr(p)) - | _ => None - } - - and parseListExpr = (~startPos, p) => { - Parser.expect(Lbracket, p) - let listExprs = parseCommaDelimitedReversedList( - p, - ~grammar=Grammar.ListExpr, - ~closing=Rbracket, - ~f=parseSpreadExprRegion, - ) - - Parser.expect(Rbracket, p) - let loc = mkLoc(startPos, p.prevEndPos) - switch listExprs { - | list{(true, expr), ...exprs} => - let exprs = exprs |> List.map(snd) |> List.rev - makeListExpression(loc, exprs, Some(expr)) - | exprs => - let exprs = exprs |> List.map(((spread, expr)) => { - if spread { - Parser.err(p, Diagnostics.message(ErrorMessages.listExprSpread)) - } - expr - }) |> List.rev - - makeListExpression(loc, exprs, None) - } - } - - /* Overparse ... and give a nice error message */ - and parseNonSpreadExp = (~msg, p) => { - let () = switch p.Parser.token { - | DotDotDot => - Parser.err(p, Diagnostics.message(msg)) - Parser.next(p) - | _ => () - } - - switch p.Parser.token { - | token when Grammar.isExprStart(token) => - let expr = parseExpr(p) - switch p.Parser.token { - | Colon => - Parser.next(p) - let typ = parseTypExpr(p) - let loc = mkLoc(expr.pexp_loc.loc_start, typ.ptyp_loc.loc_end) - Some(Ast_helper.Exp.constraint_(~loc, expr, typ)) - | _ => Some(expr) - } - | _ => None - } - } - - and parseArrayExp = p => { - let startPos = p.Parser.startPos - Parser.expect(Lbracket, p) - let exprs = parseCommaDelimitedRegion( - p, - ~grammar=Grammar.ExprList, - ~closing=Rbracket, - ~f=parseNonSpreadExp(~msg=ErrorMessages.arrayExprSpread), - ) - - Parser.expect(Rbracket, p) - Ast_helper.Exp.array(~loc=mkLoc(startPos, p.prevEndPos), exprs) - } - - /* TODO: check attributes in the case of poly type vars, - * might be context dependend: parseFieldDeclaration (see ocaml) */ - and parsePolyTypeExpr = p => { - let startPos = p.Parser.startPos - switch p.Parser.token { - | SingleQuote => - let vars = parseTypeVarList(p) - switch vars { - | list{_v1, _v2, ..._} => - Parser.expect(Dot, p) - let typ = parseTypExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.poly(~loc, vars, typ) - | list{var} => - switch p.Parser.token { - | Dot => - Parser.next(p) - let typ = parseTypExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.poly(~loc, vars, typ) - | EqualGreater => - Parser.next(p) - let typ = Ast_helper.Typ.var(~loc=var.loc, var.txt) - let returnType = parseTypExpr(~alias=false, p) - let loc = mkLoc(typ.Parsetree.ptyp_loc.loc_start, p.prevEndPos) - Ast_helper.Typ.arrow(~loc, Asttypes.Nolabel, typ, returnType) - | _ => Ast_helper.Typ.var(~loc=var.loc, var.txt) - } - | _ => assert false - } - | _ => parseTypExpr(p) - } - } - - /* 'a 'b 'c */ - and parseTypeVarList = p => { - let rec loop = (p, vars) => - switch p.Parser.token { - | SingleQuote => - Parser.next(p) - let (lident, loc) = parseLident(p) - let var = Location.mkloc(lident, loc) - loop(p, list{var, ...vars}) - | _ => List.rev(vars) - } - - loop(p, list{}) - } - - and parseLidentList = p => { - let rec loop = (p, ls) => - switch p.Parser.token { - | Lident(lident) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - loop(p, list{Location.mkloc(lident, loc), ...ls}) - | _ => List.rev(ls) - } - - loop(p, list{}) - } - - and parseAtomicTypExpr = (~attrs, p) => { - Parser.leaveBreadcrumb(p, Grammar.AtomicTypExpr) - let startPos = p.Parser.startPos - let typ = switch p.Parser.token { - | SingleQuote => - Parser.next(p) - let (ident, loc) = parseLident(p) - Ast_helper.Typ.var(~loc, ~attrs, ident) - | Underscore => - let endPos = p.endPos - Parser.next(p) - Ast_helper.Typ.any(~loc=mkLoc(startPos, endPos), ~attrs, ()) - | Lparen => - Parser.next(p) - switch p.Parser.token { - | Rparen => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let unitConstr = Location.mkloc(Longident.Lident("unit"), loc) - Ast_helper.Typ.constr(~attrs, unitConstr, list{}) - | _ => - let t = parseTypExpr(p) - switch p.token { - | Comma => - Parser.next(p) - parseTupleType(~attrs, ~first=t, ~startPos, p) - | _ => - Parser.expect(Rparen, p) - { - ...t, - ptyp_loc: mkLoc(startPos, p.prevEndPos), - ptyp_attributes: List.concat(list{attrs, t.ptyp_attributes}), - } - } - } - | Lbracket => parsePolymorphicVariantType(~attrs, p) - | Uident(_) | Lident(_) | List => - let constr = parseValuePath(p) - let args = parseTypeConstructorArgs(~constrName=constr, p) - Ast_helper.Typ.constr(~loc=mkLoc(startPos, p.prevEndPos), ~attrs, constr, args) - | Module => - Parser.next(p) - Parser.expect(Lparen, p) - let packageType = parsePackageType(~startPos, ~attrs, p) - Parser.expect(Rparen, p) - {...packageType, ptyp_loc: mkLoc(startPos, p.prevEndPos)} - | Percent => - let extension = parseExtension(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.extension(~attrs, ~loc, extension) - | Lbrace => parseBsObjectType(~attrs, p) - | token => - switch skipTokensAndMaybeRetry(p, ~isStartOfGrammar=Grammar.isAtomicTypExprStart) { - | Some() => parseAtomicTypExpr(~attrs, p) - | None => - Parser.err(~startPos=p.prevEndPos, p, Diagnostics.unexpected(token, p.breadcrumbs)) - Recover.defaultType() - } - } - - Parser.eatBreadcrumb(p) - typ - } - - /* package-type ::= - | modtype-path - ∣ modtype-path with package-constraint { and package-constraint } - */ - and parsePackageType = (~startPos, ~attrs, p) => { - let modTypePath = parseModuleLongIdent(~lowercase=true, p) - switch p.Parser.token { - | With => - Parser.next(p) - let constraints = parsePackageConstraints(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.package(~loc, ~attrs, modTypePath, constraints) - | _ => - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.package(~loc, ~attrs, modTypePath, list{}) - } - } - - /* package-constraint { and package-constraint } */ - and parsePackageConstraints = p => { - let first = { - Parser.expect(Typ, p) - let typeConstr = parseValuePath(p) - Parser.expect(Equal, p) - let typ = parseTypExpr(p) - (typeConstr, typ) - } - - let rest = parseRegion(~grammar=Grammar.PackageConstraint, ~f=parsePackageConstraint, p) - - list{first, ...rest} - } - - /* and type typeconstr = typexpr */ - and parsePackageConstraint = p => - switch p.Parser.token { - | And => - Parser.next(p) - Parser.expect(Typ, p) - let typeConstr = parseValuePath(p) - Parser.expect(Equal, p) - let typ = parseTypExpr(p) - Some(typeConstr, typ) - | _ => None - } - - and parseBsObjectType = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Lbrace, p) - let closedFlag = switch p.token { - | DotDot => - Parser.next(p) - Asttypes.Open - | Dot => - Parser.next(p) - Asttypes.Closed - | _ => Asttypes.Closed - } - - let fields = parseCommaDelimitedRegion( - ~grammar=Grammar.StringFieldDeclarations, - ~closing=Rbrace, - ~f=parseStringFieldDeclaration, - p, - ) - - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - makeBsObjType(~attrs, ~loc, ~closed=closedFlag, fields) - } - - /* TODO: check associativity in combination with attributes */ - and parseTypeAlias = (p, typ) => - switch p.Parser.token { - | As => - Parser.next(p) - Parser.expect(SingleQuote, p) - let (ident, _loc) = parseLident(p) - /* TODO: how do we parse attributes here? */ - Ast_helper.Typ.alias(~loc=mkLoc(typ.Parsetree.ptyp_loc.loc_start, p.prevEndPos), typ, ident) - | _ => typ - } - - /* type_parameter ::= - * | type_expr - * | ~ident: type_expr - * | ~ident: type_expr=? - * - * note: - * | attrs ~ident: type_expr -> attrs are on the arrow - * | attrs type_expr -> attrs are here part of the type_expr - * - * uncurried_type_parameter ::= - * | . type_parameter - */ - and parseTypeParameter = p => - if p.Parser.token == Token.Tilde || (p.token == Dot || Grammar.isTypExprStart(p.token)) { - let startPos = p.Parser.startPos - let uncurried = Parser.optional(p, Dot) - let attrs = parseAttributes(p) - switch p.Parser.token { - | Tilde => - Parser.next(p) - let (name, _loc) = parseLident(p) - Parser.expect(~grammar=Grammar.TypeExpression, Colon, p) - let typ = parseTypExpr(p) - switch p.Parser.token { - | Equal => - Parser.next(p) - Parser.expect(Question, p) - Some(uncurried, attrs, Asttypes.Optional(name), typ, startPos) - | _ => Some(uncurried, attrs, Asttypes.Labelled(name), typ, startPos) - } - | Lident(_) | List => - let (name, loc) = parseLident(p) - switch p.token { - | Colon => - let () = { - let error = Diagnostics.message("Parameter names start with a `~`, like: ~" ++ name) - - Parser.err(~startPos=loc.loc_start, ~endPos=loc.loc_end, p, error) - } - - Parser.next(p) - let typ = parseTypExpr(p) - switch p.Parser.token { - | Equal => - Parser.next(p) - Parser.expect(Question, p) - Some(uncurried, attrs, Asttypes.Optional(name), typ, startPos) - | _ => Some(uncurried, attrs, Asttypes.Labelled(name), typ, startPos) - } - | _ => - let constr = Location.mkloc(Longident.Lident(name), loc) - let args = parseTypeConstructorArgs(~constrName=constr, p) - let typ = Ast_helper.Typ.constr(~loc=mkLoc(startPos, p.prevEndPos), ~attrs, constr, args) - - let typ = parseArrowTypeRest(~es6Arrow=true, ~startPos, typ, p) - let typ = parseTypeAlias(p, typ) - Some(uncurried, list{}, Asttypes.Nolabel, typ, startPos) - } - | _ => - let typ = parseTypExpr(p) - let typWithAttributes = { - ...typ, - ptyp_attributes: List.concat(list{attrs, typ.ptyp_attributes}), - } - Some(uncurried, list{}, Asttypes.Nolabel, typWithAttributes, startPos) - } - } else { - None - } - - /* (int, ~x:string, float) */ - and parseTypeParameters = p => { - let startPos = p.Parser.startPos - Parser.expect(Lparen, p) - switch p.Parser.token { - | Rparen => - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - let unitConstr = Location.mkloc(Longident.Lident("unit"), loc) - let typ = Ast_helper.Typ.constr(unitConstr, list{}) - list{(false, list{}, Asttypes.Nolabel, typ, startPos)} - | _ => - let params = parseCommaDelimitedRegion( - ~grammar=Grammar.TypeParameters, - ~closing=Rparen, - ~f=parseTypeParameter, - p, - ) - - Parser.expect(Rparen, p) - params - } - } - - and parseEs6ArrowType = (~attrs, p) => { - let startPos = p.Parser.startPos - switch p.Parser.token { - | Tilde => - Parser.next(p) - let (name, _loc) = parseLident(p) - Parser.expect(~grammar=Grammar.TypeExpression, Colon, p) - let typ = parseTypExpr(~alias=false, ~es6Arrow=false, p) - let arg = switch p.Parser.token { - | Equal => - Parser.next(p) - Parser.expect(Question, p) - Asttypes.Optional(name) - | _ => Asttypes.Labelled(name) - } - - Parser.expect(EqualGreater, p) - let returnType = parseTypExpr(~alias=false, p) - Ast_helper.Typ.arrow(~attrs, arg, typ, returnType) - | _ => - let parameters = parseTypeParameters(p) - Parser.expect(EqualGreater, p) - let returnType = parseTypExpr(~alias=false, p) - let endPos = p.prevEndPos - let typ = List.fold_right(((uncurried, attrs, argLbl, typ, startPos), t) => { - let attrs = if uncurried { - list{uncurryAttr, ...attrs} - } else { - attrs - } - Ast_helper.Typ.arrow(~loc=mkLoc(startPos, endPos), ~attrs, argLbl, typ, t) - }, parameters, returnType) - - { - ...typ, - ptyp_attributes: List.concat(list{typ.ptyp_attributes, attrs}), - ptyp_loc: mkLoc(startPos, p.prevEndPos), - } - } - } - - /* - * typexpr ::= - * | 'ident - * | _ - * | (typexpr) - * | typexpr => typexpr --> es6 arrow - * | (typexpr, typexpr) => typexpr --> es6 arrow - * | /typexpr, typexpr, typexpr/ --> tuple - * | typeconstr - * | typeconstr - * | typeconstr - * | typexpr as 'ident - * | %attr-id --> extension - * | %attr-id(payload) --> extension - * - * typeconstr ::= - * | lident - * | uident.lident - * | uident.uident.lident --> long module path - */ - and parseTypExpr = (~attrs=?, ~es6Arrow=true, ~alias=true, p) => { - /* Parser.leaveBreadcrumb p Grammar.TypeExpression; */ - let startPos = p.Parser.startPos - let attrs = switch attrs { - | Some(attrs) => attrs - | None => parseAttributes(p) - } - let typ = if es6Arrow && isEs6ArrowType(p) { - parseEs6ArrowType(~attrs, p) - } else { - let typ = parseAtomicTypExpr(~attrs, p) - parseArrowTypeRest(~es6Arrow, ~startPos, typ, p) - } - - let typ = if alias { - parseTypeAlias(p, typ) - } else { - typ - } - - /* Parser.eatBreadcrumb p; */ - typ - } - - and parseArrowTypeRest = (~es6Arrow, ~startPos, typ, p) => - switch p.Parser.token { - | (EqualGreater | MinusGreater) as token when es6Arrow === true => - /* error recovery */ - if token == MinusGreater { - Parser.expect(EqualGreater, p) - } - Parser.next(p) - let returnType = parseTypExpr(~alias=false, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.arrow(~loc, Asttypes.Nolabel, typ, returnType) - | _ => typ - } - - and parseTypExprRegion = p => - if Grammar.isTypExprStart(p.Parser.token) { - Some(parseTypExpr(p)) - } else { - None - } - - and parseTupleType = (~attrs, ~first, ~startPos, p) => { - let typexprs = parseCommaDelimitedRegion( - ~grammar=Grammar.TypExprList, - ~closing=Rparen, - ~f=parseTypExprRegion, - p, - ) - - Parser.expect(Rparen, p) - let tupleLoc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.tuple(~attrs, ~loc=tupleLoc, list{first, ...typexprs}) - } - - and parseTypeConstructorArgRegion = p => - if Grammar.isTypExprStart(p.Parser.token) { - Some(parseTypExpr(p)) - } else if p.token == LessThan { - Parser.next(p) - parseTypeConstructorArgRegion(p) - } else { - None - } - - /* Js.Nullable.value<'a> */ - and parseTypeConstructorArgs = (~constrName, p) => { - let opening = p.Parser.token - let openingStartPos = p.startPos - switch opening { - | LessThan | Lparen => - Scanner.setDiamondMode(p.scanner) - Parser.next(p) - let typeArgs = /* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? */ - parseCommaDelimitedRegion( - ~grammar=Grammar.TypExprList, - ~closing=GreaterThan, - ~f=parseTypeConstructorArgRegion, - p, - ) - - let () = switch p.token { - | Rparen when opening == Token.Lparen => - let typ = Ast_helper.Typ.constr(constrName, typeArgs) - let msg = - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.text("Type parameters require angle brackets:"), - Doc.indent(Doc.concat(list{Doc.line, Printer.printTypExpr(typ, CommentTable.empty)})), - }), - ) |> Doc.toString(~width=80) - - Parser.err(~startPos=openingStartPos, p, Diagnostics.message(msg)) - Parser.next(p) - | _ => Parser.expect(GreaterThan, p) - } - - Scanner.popMode(p.scanner, Diamond) - typeArgs - | _ => list{} - } - } - - /* string-field-decl ::= - * | string: poly-typexpr - * | attributes string-field-decl */ - and parseStringFieldDeclaration = p => { - let attrs = parseAttributes(p) - switch p.Parser.token { - | String(name) => - let nameStartPos = p.startPos - let nameEndPos = p.endPos - Parser.next(p) - let fieldName = Location.mkloc(name, mkLoc(nameStartPos, nameEndPos)) - Parser.expect(~grammar=Grammar.TypeExpression, Colon, p) - let typ = parsePolyTypeExpr(p) - Some(Parsetree.Otag(fieldName, attrs, typ)) - | _token => None - } - } - - /* field-decl ::= - * | [mutable] field-name : poly-typexpr - * | attributes field-decl */ - and parseFieldDeclaration = p => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - let mut = if Parser.optional(p, Token.Mutable) { - Asttypes.Mutable - } else { - Asttypes.Immutable - } - - let (lident, loc) = switch p.token { - | List => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - ("list", loc) - | _ => parseLident(p) - } - - let name = Location.mkloc(lident, loc) - let typ = switch p.Parser.token { - | Colon => - Parser.next(p) - parsePolyTypeExpr(p) - | _ => Ast_helper.Typ.constr(~loc=name.loc, {...name, txt: Lident(name.txt)}, list{}) - } - - let loc = mkLoc(startPos, typ.ptyp_loc.loc_end) - Ast_helper.Type.field(~attrs, ~loc, ~mut, name, typ) - } - - and parseFieldDeclarationRegion = p => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - let mut = if Parser.optional(p, Token.Mutable) { - Asttypes.Mutable - } else { - Asttypes.Immutable - } - - switch p.token { - | Lident(_) | List => - let (lident, loc) = switch p.token { - | List => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - ("list", loc) - | _ => parseLident(p) - } - - let name = Location.mkloc(lident, loc) - let typ = switch p.Parser.token { - | Colon => - Parser.next(p) - parsePolyTypeExpr(p) - | _ => Ast_helper.Typ.constr(~loc=name.loc, {...name, txt: Lident(name.txt)}, list{}) - } - - let loc = mkLoc(startPos, typ.ptyp_loc.loc_end) - Some(Ast_helper.Type.field(~attrs, ~loc, ~mut, name, typ)) - | _ => None - } - } - - /* record-decl ::= - * | { field-decl } - * | { field-decl, field-decl } - * | { field-decl, field-decl, field-decl, } - */ - and parseRecordDeclaration = p => { - Parser.leaveBreadcrumb(p, Grammar.RecordDecl) - Parser.expect(Lbrace, p) - let rows = parseCommaDelimitedRegion( - ~grammar=Grammar.RecordDecl, - ~closing=Rbrace, - ~f=parseFieldDeclarationRegion, - p, - ) - - Parser.expect(Rbrace, p) - Parser.eatBreadcrumb(p) - rows - } - - /* constr-args ::= - * | (typexpr) - * | (typexpr, typexpr) - * | (typexpr, typexpr, typexpr,) - * | (record-decl) - * - * TODO: should we overparse inline-records in every position? - * Give a good error message afterwards? - */ - and parseConstrDeclArgs = p => { - let constrArgs = switch p.Parser.token { - | Lparen => - Parser.next(p) - /* TODO: this could use some cleanup/stratification */ - switch p.Parser.token { - | Lbrace => - let lbrace = p.startPos - Parser.next(p) - let startPos = p.Parser.startPos - switch p.Parser.token { - | DotDot | Dot => - let closedFlag = switch p.token { - | DotDot => - Parser.next(p) - Asttypes.Open - | Dot => - Parser.next(p) - Asttypes.Closed - | _ => Asttypes.Closed - } - - let fields = parseCommaDelimitedRegion( - ~grammar=Grammar.StringFieldDeclarations, - ~closing=Rbrace, - ~f=parseStringFieldDeclaration, - p, - ) - - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let typ = makeBsObjType(~attrs=list{}, ~loc, ~closed=closedFlag, fields) - Parser.optional(p, Comma) |> ignore - let moreArgs = parseCommaDelimitedRegion( - ~grammar=Grammar.TypExprList, - ~closing=Rparen, - ~f=parseTypExprRegion, - p, - ) - - Parser.expect(Rparen, p) - Parsetree.Pcstr_tuple(list{typ, ...moreArgs}) - | _ => - let attrs = parseAttributes(p) - switch p.Parser.token { - | String(_) => - let closedFlag = Asttypes.Closed - let fields = switch attrs { - | list{} => - parseCommaDelimitedRegion( - ~grammar=Grammar.StringFieldDeclarations, - ~closing=Rbrace, - ~f=parseStringFieldDeclaration, - p, - ) - | attrs => - let first = { - Parser.leaveBreadcrumb(p, Grammar.StringFieldDeclarations) - let field = switch parseStringFieldDeclaration(p) { - | Some(field) => field - | None => assert false - } - - /* parse comma after first */ - let () = switch p.Parser.token { - | Rbrace | Eof => () - | Comma => Parser.next(p) - | _ => Parser.expect(Comma, p) - } - - Parser.eatBreadcrumb(p) - switch field { - | Parsetree.Otag(label, _, ct) => Parsetree.Otag(label, attrs, ct) - | Oinherit(ct) => Oinherit(ct) - } - } - - list{ - first, - ...parseCommaDelimitedRegion( - ~grammar=Grammar.StringFieldDeclarations, - ~closing=Rbrace, - ~f=parseStringFieldDeclaration, - p, - ), - } - } - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let typ = makeBsObjType(~attrs=list{}, ~loc, ~closed=closedFlag, fields) - Parser.optional(p, Comma) |> ignore - let moreArgs = parseCommaDelimitedRegion( - ~grammar=Grammar.TypExprList, - ~closing=Rparen, - ~f=parseTypExprRegion, - p, - ) - - Parser.expect(Rparen, p) - Parsetree.Pcstr_tuple(list{typ, ...moreArgs}) - | _ => - let fields = switch attrs { - | list{} => - parseCommaDelimitedRegion( - ~grammar=Grammar.FieldDeclarations, - ~closing=Rbrace, - ~f=parseFieldDeclarationRegion, - p, - ) - | attrs => - let first = { - let field = parseFieldDeclaration(p) - Parser.expect(Comma, p) - {...field, Parsetree.pld_attributes: attrs} - } - - list{ - first, - ...parseCommaDelimitedRegion( - ~grammar=Grammar.FieldDeclarations, - ~closing=Rbrace, - ~f=parseFieldDeclarationRegion, - p, - ), - } - } - - let () = switch fields { - | list{} => - Parser.err( - ~startPos=lbrace, - p, - Diagnostics.message("An inline record declaration needs at least one field"), - ) - | _ => () - } - - Parser.expect(Rbrace, p) - Parser.optional(p, Comma) |> ignore - Parser.expect(Rparen, p) - Parsetree.Pcstr_record(fields) - } - } - | _ => - let args = parseCommaDelimitedRegion( - ~grammar=Grammar.TypExprList, - ~closing=Rparen, - ~f=parseTypExprRegion, - p, - ) - - Parser.expect(Rparen, p) - Parsetree.Pcstr_tuple(args) - } - | _ => Pcstr_tuple(list{}) - } - - let res = switch p.Parser.token { - | Colon => - Parser.next(p) - Some(parseTypExpr(p)) - | _ => None - } - - (constrArgs, res) - } - - /* constr-decl ::= - * | constr-name - * | attrs constr-name - * | constr-name const-args - * | attrs constr-name const-args */ - and parseTypeConstructorDeclarationWithBar = p => - switch p.Parser.token { - | Bar => - let startPos = p.Parser.startPos - Parser.next(p) - Some(parseTypeConstructorDeclaration(~startPos, p)) - | _ => None - } - - and parseTypeConstructorDeclaration = (~startPos, p) => { - Parser.leaveBreadcrumb(p, Grammar.ConstructorDeclaration) - let attrs = parseAttributes(p) - switch p.Parser.token { - | Uident(uident) => - let uidentLoc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - let (args, res) = parseConstrDeclArgs(p) - Parser.eatBreadcrumb(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Type.constructor(~loc, ~attrs, ~res?, ~args, Location.mkloc(uident, uidentLoc)) - | t => - Parser.err(p, Diagnostics.uident(t)) - Ast_helper.Type.constructor(Location.mknoloc("_")) - } - } - - /* [|] constr-decl { | constr-decl } */ - and parseTypeConstructorDeclarations = (~first=?, p) => { - let firstConstrDecl = switch first { - | None => - let startPos = p.Parser.startPos - ignore(Parser.optional(p, Token.Bar)) - parseTypeConstructorDeclaration(~startPos, p) - | Some(firstConstrDecl) => firstConstrDecl - } - - list{ - firstConstrDecl, - ...parseRegion( - ~grammar=Grammar.ConstructorDeclaration, - ~f=parseTypeConstructorDeclarationWithBar, - p, - ), - } - } - - /* - * type-representation ::= - * ∣ = [ | ] constr-decl { | constr-decl } - * ∣ = private [ | ] constr-decl { | constr-decl } - * | = | - * ∣ = private | - * ∣ = record-decl - * ∣ = private record-decl - * | = .. - */ - and parseTypeRepresentation = p => { - Parser.leaveBreadcrumb(p, Grammar.TypeRepresentation) - /* = consumed */ - let privateFlag = if Parser.optional(p, Token.Private) { - Asttypes.Private - } else { - Asttypes.Public - } - - let kind = switch p.Parser.token { - | Bar | Uident(_) => Parsetree.Ptype_variant(parseTypeConstructorDeclarations(p)) - | Lbrace => Parsetree.Ptype_record(parseRecordDeclaration(p)) - | DotDot => - Parser.next(p) - Ptype_open - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - /* TODO: I have no idea if this is even remotely a good idea */ - Parsetree.Ptype_variant(list{}) - } - - Parser.eatBreadcrumb(p) - (privateFlag, kind) - } - - /* type-param ::= - * | variance 'lident - * | variance _ - * - * variance ::= - * | + - * | - - * | (* empty *) - */ - and parseTypeParam = p => { - let variance = switch p.Parser.token { - | Plus => - Parser.next(p) - Asttypes.Covariant - | Minus => - Parser.next(p) - Contravariant - | _ => Invariant - } - - switch p.Parser.token { - | SingleQuote => - Parser.next(p) - let (ident, loc) = parseLident(p) - Some(Ast_helper.Typ.var(~loc, ident), variance) - | Underscore => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Some(Ast_helper.Typ.any(~loc, ()), variance) - /* TODO: should we try parsing lident as 'ident ? */ - | _token => None - } - } - - /* type-params ::= - * | - * ∣ - * ∣ - * ∣ - * - * TODO: when we have pretty-printer show an error - * with the actual code corrected. */ - and parseTypeParams = (~parent, p) => { - let opening = p.Parser.token - switch opening { - | LessThan | Lparen when p.startPos.pos_lnum === p.prevEndPos.pos_lnum => - Scanner.setDiamondMode(p.scanner) - let openingStartPos = p.startPos - Parser.leaveBreadcrumb(p, Grammar.TypeParams) - Parser.next(p) - let params = parseCommaDelimitedRegion( - ~grammar=Grammar.TypeParams, - ~closing=GreaterThan, - ~f=parseTypeParam, - p, - ) - - let () = switch p.token { - | Rparen when opening == Token.Lparen => - let msg = - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.text("Type parameters require angle brackets:"), - Doc.indent( - Doc.concat(list{ - Doc.line, - Doc.concat(list{ - Printer.printLongident(parent.Location.txt), - Printer.printTypeParams(params, CommentTable.empty), - }), - }), - ), - }), - ) |> Doc.toString(~width=80) - - Parser.err(~startPos=openingStartPos, p, Diagnostics.message(msg)) - Parser.next(p) - | _ => Parser.expect(GreaterThan, p) - } - - Scanner.popMode(p.scanner, Diamond) - Parser.eatBreadcrumb(p) - params - | _ => list{} - } - } - - /* type-constraint ::= constraint ' ident = typexpr */ - and parseTypeConstraint = p => { - let startPos = p.Parser.startPos - switch p.Parser.token { - | Token.Constraint => - Parser.next(p) - Parser.expect(SingleQuote, p) - switch p.Parser.token { - | Lident(ident) => - let identLoc = mkLoc(startPos, p.endPos) - Parser.next(p) - Parser.expect(Equal, p) - let typ = parseTypExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Typ.var(~loc=identLoc, ident), typ, loc) - | t => - Parser.err(p, Diagnostics.lident(t)) - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Typ.any(), parseTypExpr(p), loc) - } - | _ => None - } - } - - /* type-constraints ::= - * | (* empty *) - * | type-constraint - * | type-constraint type-constraint - * | type-constraint type-constraint type-constraint (* 0 or more *) - */ - and parseTypeConstraints = p => - parseRegion(~grammar=Grammar.TypeConstraint, ~f=parseTypeConstraint, p) - - and parseTypeEquationOrConstrDecl = p => { - let uidentStartPos = p.Parser.startPos - switch p.Parser.token { - | Uident(uident) => - Parser.next(p) - switch p.Parser.token { - | Dot => - Parser.next(p) - let typeConstr = parseValuePathTail(p, uidentStartPos, Longident.Lident(uident)) - - let loc = mkLoc(uidentStartPos, p.prevEndPos) - let typ = parseTypeAlias( - p, - Ast_helper.Typ.constr( - ~loc, - typeConstr, - parseTypeConstructorArgs(~constrName=typeConstr, p), - ), - ) - switch p.token { - | Equal => - Parser.next(p) - let (priv, kind) = parseTypeRepresentation(p) - (Some(typ), priv, kind) - | EqualGreater => - Parser.next(p) - let returnType = parseTypExpr(~alias=false, p) - let loc = mkLoc(uidentStartPos, p.prevEndPos) - let arrowType = Ast_helper.Typ.arrow(~loc, Asttypes.Nolabel, typ, returnType) - let typ = parseTypeAlias(p, arrowType) - (Some(typ), Asttypes.Public, Parsetree.Ptype_abstract) - | _ => (Some(typ), Asttypes.Public, Parsetree.Ptype_abstract) - } - | _ => - let uidentEndPos = p.endPos - let (args, res) = parseConstrDeclArgs(p) - let first = Some({ - let uidentLoc = mkLoc(uidentStartPos, uidentEndPos) - Ast_helper.Type.constructor( - ~loc=mkLoc(uidentStartPos, p.prevEndPos), - ~res?, - ~args, - Location.mkloc(uident, uidentLoc), - ) - }) - ( - None, - Asttypes.Public, - Parsetree.Ptype_variant(parseTypeConstructorDeclarations(p, ~first?)), - ) - } - | t => - Parser.err(p, Diagnostics.uident(t)) - /* TODO: is this a good idea? */ - (None, Asttypes.Public, Parsetree.Ptype_abstract) - } - } - - and parseRecordOrBsObjectDecl = p => { - let startPos = p.Parser.startPos - Parser.expect(Lbrace, p) - switch p.Parser.token { - | DotDot | Dot => - let closedFlag = switch p.token { - | DotDot => - Parser.next(p) - Asttypes.Open - | Dot => - Parser.next(p) - Asttypes.Closed - | _ => Asttypes.Closed - } - - let fields = parseCommaDelimitedRegion( - ~grammar=Grammar.StringFieldDeclarations, - ~closing=Rbrace, - ~f=parseStringFieldDeclaration, - p, - ) - - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let typ = makeBsObjType(~attrs=list{}, ~loc, ~closed=closedFlag, fields) |> parseTypeAlias(p) - - let typ = parseArrowTypeRest(~es6Arrow=true, ~startPos, typ, p) - (Some(typ), Asttypes.Public, Parsetree.Ptype_abstract) - | _ => - let attrs = parseAttributes(p) - switch p.Parser.token { - | String(_) => - let closedFlag = Asttypes.Closed - let fields = switch attrs { - | list{} => - parseCommaDelimitedRegion( - ~grammar=Grammar.StringFieldDeclarations, - ~closing=Rbrace, - ~f=parseStringFieldDeclaration, - p, - ) - | attrs => - let first = { - Parser.leaveBreadcrumb(p, Grammar.StringFieldDeclarations) - let field = switch parseStringFieldDeclaration(p) { - | Some(field) => field - | None => assert false - } - - /* parse comma after first */ - let () = switch p.Parser.token { - | Rbrace | Eof => () - | Comma => Parser.next(p) - | _ => Parser.expect(Comma, p) - } - - Parser.eatBreadcrumb(p) - switch field { - | Parsetree.Otag(label, _, ct) => Parsetree.Otag(label, attrs, ct) - | Oinherit(ct) => Oinherit(ct) - } - } - - list{ - first, - ...parseCommaDelimitedRegion( - ~grammar=Grammar.StringFieldDeclarations, - ~closing=Rbrace, - ~f=parseStringFieldDeclaration, - p, - ), - } - } - - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - let typ = - makeBsObjType(~attrs=list{}, ~loc, ~closed=closedFlag, fields) |> parseTypeAlias(p) - - let typ = parseArrowTypeRest(~es6Arrow=true, ~startPos, typ, p) - (Some(typ), Asttypes.Public, Parsetree.Ptype_abstract) - | _ => - Parser.leaveBreadcrumb(p, Grammar.RecordDecl) - let fields = switch attrs { - | list{} => - parseCommaDelimitedRegion( - ~grammar=Grammar.FieldDeclarations, - ~closing=Rbrace, - ~f=parseFieldDeclarationRegion, - p, - ) - | list{attr, ..._} as attrs => - let first = { - let field = parseFieldDeclaration(p) - Parser.optional(p, Comma) |> ignore - { - ...field, - Parsetree.pld_attributes: attrs, - pld_loc: { - ...field.Parsetree.pld_loc, - loc_start: (attr |> fst).loc.loc_start, - }, - } - } - - list{ - first, - ...parseCommaDelimitedRegion( - ~grammar=Grammar.FieldDeclarations, - ~closing=Rbrace, - ~f=parseFieldDeclarationRegion, - p, - ), - } - } - - let () = switch fields { - | list{} => - Parser.err(~startPos, p, Diagnostics.message("A record needs at least one field")) - | _ => () - } - - Parser.expect(Rbrace, p) - Parser.eatBreadcrumb(p) - (None, Asttypes.Public, Parsetree.Ptype_record(fields)) - } - } - } - - and parsePrivateEqOrRepr = p => { - Parser.expect(Private, p) - switch p.Parser.token { - | Lbrace => - let (manifest, _, kind) = parseRecordOrBsObjectDecl(p) - (manifest, Asttypes.Private, kind) - | Uident(_) => - let (manifest, _, kind) = parseTypeEquationOrConstrDecl(p) - (manifest, Asttypes.Private, kind) - | Bar | DotDot => - let (_, kind) = parseTypeRepresentation(p) - (None, Asttypes.Private, kind) - | t when Grammar.isTypExprStart(t) => ( - Some(parseTypExpr(p)), - Asttypes.Private, - Parsetree.Ptype_abstract, - ) - | _ => - let (_, kind) = parseTypeRepresentation(p) - (None, Asttypes.Private, kind) - } - } - - /* - polymorphic-variant-type ::= - | [ tag-spec-first { | tag-spec } ] - | [> [ tag-spec ] { | tag-spec } ] - | [< [|] tag-spec-full { | tag-spec-full } [ > { `tag-name }+ ] ] - - tag-spec-first ::= `tag-name [ of typexpr ] - | [ typexpr ] | tag-spec - - tag-spec ::= `tag-name [ of typexpr ] - | typexpr - - tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ] - | typexpr - */ - and parsePolymorphicVariantType = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Lbracket, p) - switch p.token { - | GreaterThan => - Parser.next(p) - let rowFields = switch p.token { - | Rbracket => list{} - | Bar => parseTagSpecs(p) - | _ => - let rowField = parseTagSpec(p) - list{rowField, ...parseTagSpecs(p)} - } - - let variant = { - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.variant(~attrs, ~loc, rowFields, Open, None) - } - Parser.expect(Rbracket, p) - variant - | LessThan => - Parser.next(p) - Parser.optional(p, Bar) |> ignore - let rowField = parseTagSpecFull(p) - let rowFields = parseTagSpecFulls(p) - let tagNames = if p.token === GreaterThan { - Parser.next(p) - let rec loop = p => - switch p.Parser.token { - | Rbracket => list{} - | _ => - let (ident, _loc) = parseHashIdent(~startPos=p.startPos, p) - list{ident, ...loop(p)} - } - - loop(p) - } else { - list{} - } - let variant = { - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.variant(~attrs, ~loc, list{rowField, ...rowFields}, Closed, Some(tagNames)) - } - Parser.expect(Rbracket, p) - variant - | _ => - let rowFields1 = parseTagSpecFirst(p) - let rowFields2 = parseTagSpecs(p) - let variant = { - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Typ.variant(~attrs, ~loc, \"@"(rowFields1, rowFields2), Closed, None) - } - Parser.expect(Rbracket, p) - variant - } - } - - and parseTagSpecFulls = p => - switch p.Parser.token { - | Rbracket => list{} - | GreaterThan => list{} - | Bar => - Parser.next(p) - let rowField = parseTagSpecFull(p) - list{rowField, ...parseTagSpecFulls(p)} - | _ => list{} - } - - and parseTagSpecFull = p => { - let attrs = parseAttributes(p) - switch p.Parser.token { - | Hash => parsePolymorphicVariantTypeSpecHash(~attrs, ~full=true, p) - | _ => - let typ = parseTypExpr(~attrs, p) - Parsetree.Rinherit(typ) - } - } - - and parseTagSpecs = p => - switch p.Parser.token { - | Bar => - Parser.next(p) - let rowField = parseTagSpec(p) - list{rowField, ...parseTagSpecs(p)} - | _ => list{} - } - - and parseTagSpec = p => { - let attrs = parseAttributes(p) - switch p.Parser.token { - | Hash => parsePolymorphicVariantTypeSpecHash(~attrs, ~full=false, p) - | _ => - let typ = parseTypExpr(~attrs, p) - Parsetree.Rinherit(typ) - } - } - - and parseTagSpecFirst = p => { - let attrs = parseAttributes(p) - switch p.Parser.token { - | Bar => - Parser.next(p) - list{parseTagSpec(p)} - | Hash => list{parsePolymorphicVariantTypeSpecHash(~attrs, ~full=false, p)} - | _ => - let typ = parseTypExpr(~attrs, p) - Parser.expect(Bar, p) - list{Parsetree.Rinherit(typ), parseTagSpec(p)} - } - } - - and parsePolymorphicVariantTypeSpecHash = (~attrs, ~full, p): Parsetree.row_field => { - let startPos = p.Parser.startPos - let (ident, loc) = parseHashIdent(~startPos, p) - let rec loop = p => - switch p.Parser.token { - | Band when full => - Parser.next(p) - let rowField = parsePolymorphicVariantTypeArgs(p) - list{rowField, ...loop(p)} - | _ => list{} - } - - let (firstTuple, tagContainsAConstantEmptyConstructor) = switch p.Parser.token { - | Band when full => - Parser.next(p) - (list{parsePolymorphicVariantTypeArgs(p)}, true) - | Lparen => (list{parsePolymorphicVariantTypeArgs(p)}, false) - | _ => (list{}, true) - } - - let tuples = \"@"(firstTuple, loop(p)) - Parsetree.Rtag(Location.mkloc(ident, loc), attrs, tagContainsAConstantEmptyConstructor, tuples) - } - - and parsePolymorphicVariantTypeArgs = p => { - let startPos = p.Parser.startPos - Parser.expect(Lparen, p) - let args = parseCommaDelimitedRegion( - ~grammar=Grammar.TypExprList, - ~closing=Rparen, - ~f=parseTypExprRegion, - p, - ) - - Parser.expect(Rparen, p) - let attrs = list{} - let loc = mkLoc(startPos, p.prevEndPos) - switch args { - | list{{ptyp_desc: Ptyp_tuple(_)} as typ} as types => - if p.mode == ParseForTypeChecker { - typ - } else { - Ast_helper.Typ.tuple(~loc, ~attrs, types) - } - | list{typ} => typ - | types => Ast_helper.Typ.tuple(~loc, ~attrs, types) - } - } - - and parseTypeEquationAndRepresentation = p => - switch p.Parser.token { - | (Equal | Bar) as token => - if token == Bar { - Parser.expect(Equal, p) - } - Parser.next(p) - switch p.Parser.token { - | Uident(_) => parseTypeEquationOrConstrDecl(p) - | Lbrace => parseRecordOrBsObjectDecl(p) - | Private => parsePrivateEqOrRepr(p) - | Bar | DotDot => - let (priv, kind) = parseTypeRepresentation(p) - (None, priv, kind) - | _ => - let manifest = Some(parseTypExpr(p)) - switch p.Parser.token { - | Equal => - Parser.next(p) - let (priv, kind) = parseTypeRepresentation(p) - (manifest, priv, kind) - | _ => (manifest, Public, Parsetree.Ptype_abstract) - } - } - | _ => (None, Public, Parsetree.Ptype_abstract) - } - - /* type-definition ::= type [rec] typedef { and typedef } - * typedef ::= typeconstr-name [type-params] type-information - * type-information ::= [type-equation] [type-representation] { type-constraint } - * type-equation ::= = typexpr */ - and parseTypeDef = (~attrs, ~startPos, p) => { - Parser.leaveBreadcrumb(p, Grammar.TypeDef) - /* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in */ - Parser.leaveBreadcrumb(p, Grammar.TypeConstrName) - let (name, loc) = parseLident(p) - let typeConstrName = Location.mkloc(name, loc) - Parser.eatBreadcrumb(p) - let params = { - let constrName = Location.mkloc(Longident.Lident(name), loc) - parseTypeParams(~parent=constrName, p) - } - let typeDef = { - let (manifest, priv, kind) = parseTypeEquationAndRepresentation(p) - let cstrs = parseTypeConstraints(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Type.mk(~loc, ~attrs, ~priv, ~kind, ~params, ~cstrs, ~manifest?, typeConstrName) - } - - Parser.eatBreadcrumb(p) - typeDef - } - - and parseTypeExtension = (~params, ~attrs, ~name, p) => { - Parser.expect(PlusEqual, p) - let priv = if Parser.optional(p, Token.Private) { - Asttypes.Private - } else { - Asttypes.Public - } - - let constrStart = p.Parser.startPos - Parser.optional(p, Bar) |> ignore - let first = { - let (attrs, name, kind) = switch p.Parser.token { - | Bar => - Parser.next(p) - parseConstrDef(~parseAttrs=true, p) - | _ => parseConstrDef(~parseAttrs=true, p) - } - - let loc = mkLoc(constrStart, p.prevEndPos) - Ast_helper.Te.constructor(~loc, ~attrs, name, kind) - } - - let rec loop = (p, cs) => - switch p.Parser.token { - | Bar => - let startPos = p.Parser.startPos - Parser.next(p) - let (attrs, name, kind) = parseConstrDef(~parseAttrs=true, p) - let extConstr = Ast_helper.Te.constructor( - ~attrs, - ~loc=mkLoc(startPos, p.prevEndPos), - name, - kind, - ) - - loop(p, list{extConstr, ...cs}) - | _ => List.rev(cs) - } - - let constructors = loop(p, list{first}) - Ast_helper.Te.mk(~attrs, ~params, ~priv, name, constructors) - } - - and parseTypeDefinitions = (~attrs, ~name, ~params, ~startPos, p) => { - let typeDef = { - let (manifest, priv, kind) = parseTypeEquationAndRepresentation(p) - let cstrs = parseTypeConstraints(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Type.mk( - ~loc, - ~attrs, - ~priv, - ~kind, - ~params, - ~cstrs, - ~manifest?, - {...name, txt: lidentOfPath(name.Location.txt)}, - ) - } - - let rec loop = (p, defs) => { - let startPos = p.Parser.startPos - let attrs = parseAttributesAndBinding(p) - switch p.Parser.token { - | And => - Parser.next(p) - let attrs = switch p.token { - | Export => - let exportLoc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - let genTypeAttr = (Location.mkloc("genType", exportLoc), Parsetree.PStr(list{})) - list{genTypeAttr, ...attrs} - | _ => attrs - } - - let typeDef = parseTypeDef(~attrs, ~startPos, p) - loop(p, list{typeDef, ...defs}) - | _ => List.rev(defs) - } - } - - loop(p, list{typeDef}) - } - - /* TODO: decide if we really want type extensions (eg. type x += Blue) - * It adds quite a bit of complexity that can be avoided, - * implemented for now. Needed to get a feel for the complexities of - * this territory of the grammar */ - and parseTypeDefinitionOrExtension = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Token.Typ, p) - let recFlag = switch p.token { - | Rec => - Parser.next(p) - Asttypes.Recursive - | Lident("nonrec") => - Parser.next(p) - Asttypes.Nonrecursive - | _ => Asttypes.Nonrecursive - } - - let name = parseValuePath(p) - let params = parseTypeParams(~parent=name, p) - switch p.Parser.token { - | PlusEqual => TypeExt(parseTypeExtension(~params, ~attrs, ~name, p)) - | _ => - let typeDefs = parseTypeDefinitions(~attrs, ~name, ~params, ~startPos, p) - TypeDef({recFlag: recFlag, types: typeDefs}) - } - } - - and parsePrimitive = p => - switch p.Parser.token { - | String(s) => - Parser.next(p) - Some(s) - | _ => None - } - - and parsePrimitives = p => - switch parseRegion(~grammar=Grammar.Primitive, ~f=parsePrimitive, p) { - | list{} => - let msg = "An external definition should have at least one primitive. Example: \"setTimeout\"" - Parser.err(p, Diagnostics.message(msg)) - list{} - | primitives => primitives - } - - /* external value-name : typexp = external-declaration */ - and parseExternalDef = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.leaveBreadcrumb(p, Grammar.External) - Parser.expect(Token.External, p) - let (name, loc) = parseLident(p) - let name = Location.mkloc(name, loc) - Parser.expect(~grammar=Grammar.TypeExpression, Colon, p) - let typExpr = parseTypExpr(p) - Parser.expect(Equal, p) - let prim = parsePrimitives(p) - let loc = mkLoc(startPos, p.prevEndPos) - let vb = Ast_helper.Val.mk(~loc, ~attrs, ~prim, name, typExpr) - Parser.eatBreadcrumb(p) - vb - } - - /* constr-def ::= - * | constr-decl - * | constr-name = constr - * - * constr-decl ::= constr-name constr-args - * constr-name ::= uident - * constr ::= path-uident */ - and parseConstrDef = (~parseAttrs, p) => { - let attrs = if parseAttrs { - parseAttributes(p) - } else { - list{} - } - let name = switch p.Parser.token { - | Uident(name) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Location.mkloc(name, loc) - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mknoloc("_") - } - - let kind = switch p.Parser.token { - | Lparen => - let (args, res) = parseConstrDeclArgs(p) - Parsetree.Pext_decl(args, res) - | Equal => - Parser.next(p) - let longident = parseModuleLongIdent(~lowercase=false, p) - Parsetree.Pext_rebind(longident) - | _ => Parsetree.Pext_decl(Pcstr_tuple(list{}), None) - } - - (attrs, name, kind) - } - - /* - * exception-definition ::= - * | exception constr-decl - * ∣ exception constr-name = constr - * - * constr-name ::= uident - * constr ::= long_uident */ - and parseExceptionDef = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Token.Exception, p) - let (_, name, kind) = parseConstrDef(~parseAttrs=false, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Te.constructor(~loc, ~attrs, name, kind) - } - - /* module structure on the file level */ - @progress((Parser.next, Parser.expect, Parser.checkProgress)) - and parseImplementation = (p): Parsetree.structure => - parseRegion(p, ~grammar=Grammar.Implementation, ~f=parseStructureItemRegion) - - and parseStructureItemRegion = p => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - switch p.Parser.token { - | Open => - let openDescription = parseOpenDescription(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Str.open_(~loc, openDescription)) - | Let => - let (recFlag, letBindings) = parseLetBindings(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Str.value(~loc, recFlag, letBindings)) - | Typ => - Parser.beginRegion(p) - switch parseTypeDefinitionOrExtension(~attrs, p) { - | TypeDef({recFlag, types}) => - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Parser.endRegion(p) - Some(Ast_helper.Str.type_(~loc, recFlag, types)) - | TypeExt(ext) => - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Parser.endRegion(p) - Some(Ast_helper.Str.type_extension(~loc, ext)) - } - | External => - let externalDef = parseExternalDef(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Str.primitive(~loc, externalDef)) - | Import => - let importDescr = parseJsImport(~startPos, ~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - let structureItem = JsFfi.toParsetree(importDescr) - Some({...structureItem, pstr_loc: loc}) - | Exception => - let exceptionDef = parseExceptionDef(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Str.exception_(~loc, exceptionDef)) - | Include => - let includeStatement = parseIncludeStatement(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Str.include_(~loc, includeStatement)) - | Export => - let structureItem = parseJsExport(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some({...structureItem, pstr_loc: loc}) - | Module => - let structureItem = parseModuleOrModuleTypeImplOrPackExpr(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some({...structureItem, pstr_loc: loc}) - | AtAt => - let attr = parseStandaloneAttribute(p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Str.attribute(~loc, attr)) - | PercentPercent => - let extension = parseExtension(~moduleLanguage=true, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Str.extension(~attrs, ~loc, extension)) - | token when Grammar.isExprStart(token) => - let prevEndPos = p.Parser.endPos - let exp = parseExpr(p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Parser.checkProgress(~prevEndPos, ~result=Ast_helper.Str.eval(~loc, ~attrs, exp), p) - | _ => None - } - } - - and parseJsImport = (~startPos, ~attrs, p) => { - Parser.expect(Token.Import, p) - let importSpec = switch p.Parser.token { - | Token.Lident(_) | Token.At => - let decl = switch parseJsFfiDeclaration(p) { - | Some(decl) => decl - | None => assert false - } - - JsFfi.Default(decl) - | _ => JsFfi.Spec(parseJsFfiDeclarations(p)) - } - - let scope = parseJsFfiScope(p) - let loc = mkLoc(startPos, p.prevEndPos) - JsFfi.importDescr(~attrs, ~importSpec, ~scope, ~loc) - } - - and parseJsExport = (~attrs, p) => { - let exportStart = p.Parser.startPos - Parser.expect(Token.Export, p) - let exportLoc = mkLoc(exportStart, p.prevEndPos) - let genTypeAttr = (Location.mkloc("genType", exportLoc), Parsetree.PStr(list{})) - let attrs = list{genTypeAttr, ...attrs} - switch p.Parser.token { - | Typ => - switch parseTypeDefinitionOrExtension(~attrs, p) { - | TypeDef({recFlag, types}) => Ast_helper.Str.type_(recFlag, types) - | TypeExt(ext) => Ast_helper.Str.type_extension(ext) - } - /* Let */ | _ => - let (recFlag, letBindings) = parseLetBindings(~attrs, p) - Ast_helper.Str.value(recFlag, letBindings) - } - } - - and parseJsFfiScope = p => - switch p.Parser.token { - | Token.Lident("from") => - Parser.next(p) - switch p.token { - | String(s) => - Parser.next(p) - JsFfi.Module(s) - | Uident(_) | Lident(_) => - let value = parseIdentPath(p) - JsFfi.Scope(value) - | _ => JsFfi.Global - } - | _ => JsFfi.Global - } - - and parseJsFfiDeclarations = p => { - Parser.expect(Token.Lbrace, p) - let decls = parseCommaDelimitedRegion( - ~grammar=Grammar.JsFfiImport, - ~closing=Rbrace, - ~f=parseJsFfiDeclaration, - p, - ) - - Parser.expect(Rbrace, p) - decls - } - - and parseJsFfiDeclaration = p => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - switch p.Parser.token { - | Lident(_) => - let (ident, _) = parseLident(p) - let alias = switch p.token { - | As => - Parser.next(p) - let (ident, _) = parseLident(p) - ident - | _ => ident - } - - Parser.expect(Token.Colon, p) - let typ = parseTypExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Some(JsFfi.decl(~loc, ~alias, ~attrs, ~name=ident, ~typ)) - | _ => None - } - } - - /* include-statement ::= include module-expr */ - and parseIncludeStatement = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Token.Include, p) - let modExpr = parseModuleExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Incl.mk(~loc, ~attrs, modExpr) - } - - and parseAtomicModuleExpr = p => { - let startPos = p.Parser.startPos - switch p.Parser.token { - | Uident(_ident) => - let longident = parseModuleLongIdent(~lowercase=false, p) - Ast_helper.Mod.ident(~loc=longident.loc, longident) - | Lbrace => - Parser.next(p) - let structure = Ast_helper.Mod.structure( - parseDelimitedRegion( - ~grammar=Grammar.Structure, - ~closing=Rbrace, - ~f=parseStructureItemRegion, - p, - ), - ) - Parser.expect(Rbrace, p) - let endPos = p.prevEndPos - {...structure, pmod_loc: mkLoc(startPos, endPos)} - | Lparen => - Parser.next(p) - let modExpr = switch p.token { - | Rparen => Ast_helper.Mod.structure(~loc=mkLoc(startPos, p.prevEndPos), list{}) - | _ => parseConstrainedModExpr(p) - } - - Parser.expect(Rparen, p) - modExpr - | Lident("unpack") => - /* TODO: should this be made a keyword?? */ - Parser.next(p) - Parser.expect(Lparen, p) - let expr = parseExpr(p) - switch p.Parser.token { - | Colon => - let colonStart = p.Parser.startPos - Parser.next(p) - let attrs = parseAttributes(p) - let packageType = parsePackageType(~startPos=colonStart, ~attrs, p) - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, p.prevEndPos) - let constraintExpr = Ast_helper.Exp.constraint_(~loc, expr, packageType) - - Ast_helper.Mod.unpack(~loc, constraintExpr) - | _ => - Parser.expect(Rparen, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Mod.unpack(~loc, expr) - } - | Percent => - let extension = parseExtension(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Mod.extension(~loc, extension) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Recover.defaultModuleExpr() - } - } - - and parsePrimaryModExpr = p => { - let startPos = p.Parser.startPos - let modExpr = parseAtomicModuleExpr(p) - let rec loop = (p, modExpr) => - switch p.Parser.token { - | Lparen when p.prevEndPos.pos_lnum === p.startPos.pos_lnum => - loop(p, parseModuleApplication(p, modExpr)) - | _ => modExpr - } - - let modExpr = loop(p, modExpr) - {...modExpr, pmod_loc: mkLoc(startPos, p.prevEndPos)} - } - - /* - * functor-arg ::= - * | uident : modtype - * | _ : modtype - * | modtype --> "punning" for _ : modtype - * | attributes functor-arg - */ - and parseFunctorArg = p => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - switch p.Parser.token { - | Uident(ident) => - Parser.next(p) - let uidentEndPos = p.prevEndPos - switch p.Parser.token { - | Colon => - Parser.next(p) - let moduleType = parseModuleType(p) - let loc = mkLoc(startPos, uidentEndPos) - let argName = Location.mkloc(ident, loc) - Some(attrs, argName, Some(moduleType), startPos) - | Dot => - Parser.next(p) - let moduleType = { - let moduleLongIdent = parseModuleLongIdentTail( - ~lowercase=false, - p, - startPos, - Longident.Lident(ident), - ) - Ast_helper.Mty.ident(~loc=moduleLongIdent.loc, moduleLongIdent) - } - - let argName = Location.mknoloc("_") - Some(attrs, argName, Some(moduleType), startPos) - | _ => - let loc = mkLoc(startPos, uidentEndPos) - let modIdent = Location.mkloc(Longident.Lident(ident), loc) - let moduleType = Ast_helper.Mty.ident(~loc, modIdent) - let argName = Location.mknoloc("_") - Some(attrs, argName, Some(moduleType), startPos) - } - | Underscore => - Parser.next(p) - let argName = Location.mkloc("_", mkLoc(startPos, p.prevEndPos)) - Parser.expect(Colon, p) - let moduleType = parseModuleType(p) - Some(attrs, argName, Some(moduleType), startPos) - | _ => None - } - } - - and parseFunctorArgs = p => { - let startPos = p.Parser.startPos - Parser.expect(Lparen, p) - let args = parseCommaDelimitedRegion( - ~grammar=Grammar.FunctorArgs, - ~closing=Rparen, - ~f=parseFunctorArg, - p, - ) - - Parser.expect(Rparen, p) - switch args { - | list{} => list{(list{}, Location.mkloc("*", mkLoc(startPos, p.prevEndPos)), None, startPos)} - | args => args - } - } - - and parseFunctorModuleExpr = p => { - let startPos = p.Parser.startPos - let args = parseFunctorArgs(p) - let returnType = switch p.Parser.token { - | Colon => - Parser.next(p) - Some(parseModuleType(~es6Arrow=false, p)) - | _ => None - } - - Parser.expect(EqualGreater, p) - let rhsModuleExpr = { - let modExpr = parseModuleExpr(p) - switch returnType { - | Some(modType) => - Ast_helper.Mod.constraint_( - ~loc=mkLoc(modExpr.pmod_loc.loc_start, modType.Parsetree.pmty_loc.loc_end), - modExpr, - modType, - ) - | None => modExpr - } - } - - let endPos = p.prevEndPos - let modExpr = List.fold_right( - ((attrs, name, moduleType, startPos), acc) => - Ast_helper.Mod.functor_(~loc=mkLoc(startPos, endPos), ~attrs, name, moduleType, acc), - args, - rhsModuleExpr, - ) - - {...modExpr, pmod_loc: mkLoc(startPos, endPos)} - } - - /* module-expr ::= - * | module-path - * ∣ { structure-items } - * ∣ functorArgs => module-expr - * ∣ module-expr(module-expr) - * ∣ ( module-expr ) - * ∣ ( module-expr : module-type ) - * | extension - * | attributes module-expr */ - and parseModuleExpr = p => { - let attrs = parseAttributes(p) - let modExpr = if isEs6ArrowFunctor(p) { - parseFunctorModuleExpr(p) - } else { - parsePrimaryModExpr(p) - } - - {...modExpr, pmod_attributes: List.concat(list{modExpr.pmod_attributes, attrs})} - } - - and parseConstrainedModExpr = p => { - let modExpr = parseModuleExpr(p) - switch p.Parser.token { - | Colon => - Parser.next(p) - let modType = parseModuleType(p) - let loc = mkLoc(modExpr.pmod_loc.loc_start, modType.pmty_loc.loc_end) - Ast_helper.Mod.constraint_(~loc, modExpr, modType) - | _ => modExpr - } - } - - and parseConstrainedModExprRegion = p => - if Grammar.isModExprStart(p.Parser.token) { - Some(parseConstrainedModExpr(p)) - } else { - None - } - - and parseModuleApplication = (p, modExpr) => { - let startPos = p.Parser.startPos - Parser.expect(Lparen, p) - let args = parseCommaDelimitedRegion( - ~grammar=Grammar.ModExprList, - ~closing=Rparen, - ~f=parseConstrainedModExprRegion, - p, - ) - - Parser.expect(Rparen, p) - let args = switch args { - | list{} => - let loc = mkLoc(startPos, p.prevEndPos) - list{Ast_helper.Mod.structure(~loc, list{})} - | args => args - } - - List.fold_left( - (modExpr, arg) => - Ast_helper.Mod.apply( - ~loc=mkLoc(modExpr.Parsetree.pmod_loc.loc_start, arg.Parsetree.pmod_loc.loc_end), - modExpr, - arg, - ), - modExpr, - args, - ) - } - - and parseModuleOrModuleTypeImplOrPackExpr = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Module, p) - switch p.Parser.token { - | Typ => parseModuleTypeImpl(~attrs, startPos, p) - | Lparen => - let expr = parseFirstClassModuleExpr(~startPos, p) - Ast_helper.Str.eval(~attrs, expr) - | _ => parseMaybeRecModuleBinding(~attrs, ~startPos, p) - } - } - - and parseModuleTypeImpl = (~attrs, startPos, p) => { - Parser.expect(Typ, p) - let nameStart = p.Parser.startPos - let name = switch p.Parser.token { - | List => - Parser.next(p) - let loc = mkLoc(nameStart, p.prevEndPos) - Location.mkloc("list", loc) - | Lident(ident) => - Parser.next(p) - let loc = mkLoc(nameStart, p.prevEndPos) - Location.mkloc(ident, loc) - | Uident(ident) => - Parser.next(p) - let loc = mkLoc(nameStart, p.prevEndPos) - Location.mkloc(ident, loc) - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mknoloc("_") - } - - Parser.expect(Equal, p) - let moduleType = parseModuleType(p) - let moduleTypeDeclaration = Ast_helper.Mtd.mk( - ~attrs, - ~loc=mkLoc(nameStart, p.prevEndPos), - ~typ=moduleType, - name, - ) - - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Str.modtype(~loc, moduleTypeDeclaration) - } - - /* definition ::= - ∣ module rec module-name : module-type = module-expr { and module-name - : module-type = module-expr } */ - and parseMaybeRecModuleBinding = (~attrs, ~startPos, p) => - switch p.Parser.token { - | Token.Rec => - Parser.next(p) - Ast_helper.Str.rec_module(parseModuleBindings(~startPos, ~attrs, p)) - | _ => Ast_helper.Str.module_(parseModuleBinding(~attrs, ~startPos=p.Parser.startPos, p)) - } - - and parseModuleBinding = (~attrs, ~startPos, p) => { - let name = switch p.Parser.token { - | Uident(ident) => - let startPos = p.Parser.startPos - Parser.next(p) - let loc = mkLoc(startPos, p.prevEndPos) - Location.mkloc(ident, loc) - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mknoloc("_") - } - - let body = parseModuleBindingBody(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Mb.mk(~attrs, ~loc, name, body) - } - - and parseModuleBindingBody = p => { - /* TODO: make required with good error message when rec module binding */ - let returnModType = switch p.Parser.token { - | Colon => - Parser.next(p) - Some(parseModuleType(p)) - | _ => None - } - - Parser.expect(Equal, p) - let modExpr = parseModuleExpr(p) - switch returnModType { - | Some(modType) => - Ast_helper.Mod.constraint_( - ~loc=mkLoc(modType.pmty_loc.loc_start, modExpr.pmod_loc.loc_end), - modExpr, - modType, - ) - | None => modExpr - } - } - - /* module-name : module-type = module-expr - * { and module-name : module-type = module-expr } */ - and parseModuleBindings = (~attrs, ~startPos, p) => { - let rec loop = (p, acc) => { - let startPos = p.Parser.startPos - let attrs = parseAttributesAndBinding(p) - switch p.Parser.token { - | And => - Parser.next(p) - ignore(Parser.optional(p, Module)) /* over-parse for fault-tolerance */ - let modBinding = parseModuleBinding(~attrs, ~startPos, p) - loop(p, list{modBinding, ...acc}) - | _ => List.rev(acc) - } - } - - let first = parseModuleBinding(~attrs, ~startPos, p) - loop(p, list{first}) - } - - and parseAtomicModuleType = p => { - let startPos = p.Parser.startPos - let moduleType = switch p.Parser.token { - | Uident(_) | Lident(_) | List => - /* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } - * lets go with uppercase terminal for now */ - let moduleLongIdent = parseModuleLongIdent(~lowercase=true, p) - Ast_helper.Mty.ident(~loc=moduleLongIdent.loc, moduleLongIdent) - | Lparen => - Parser.next(p) - let mty = parseModuleType(p) - Parser.expect(Rparen, p) - {...mty, pmty_loc: mkLoc(startPos, p.prevEndPos)} - | Lbrace => - Parser.next(p) - let spec = parseDelimitedRegion( - ~grammar=Grammar.Signature, - ~closing=Rbrace, - ~f=parseSignatureItemRegion, - p, - ) - - Parser.expect(Rbrace, p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Mty.signature(~loc, spec) - | Module => - /* TODO: check if this is still atomic when implementing first class modules */ - parseModuleTypeOf(p) - | Percent => - let extension = parseExtension(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Mty.extension(~loc, extension) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Recover.defaultModuleType() - } - - let moduleTypeLoc = mkLoc(startPos, p.prevEndPos) - {...moduleType, pmty_loc: moduleTypeLoc} - } - - and parseFunctorModuleType = p => { - let startPos = p.Parser.startPos - let args = parseFunctorArgs(p) - Parser.expect(EqualGreater, p) - let rhs = parseModuleType(p) - let endPos = p.prevEndPos - let modType = List.fold_right( - ((attrs, name, moduleType, startPos), acc) => - Ast_helper.Mty.functor_(~loc=mkLoc(startPos, endPos), ~attrs, name, moduleType, acc), - args, - rhs, - ) - - {...modType, pmty_loc: mkLoc(startPos, endPos)} - } - - /* Module types are the module-level equivalent of type expressions: they - * specify the general shape and type properties of modules. - * - * module-type ::= - * | modtype-path - * | { signature } - * | ( module-type ) --> parenthesized module-type - * | functor-args => module-type --> functor - * | module-type => module-type --> functor - * | module type of module-expr - * | attributes module-type - * | module-type with-mod-constraints - * | extension - */ - and parseModuleType = (~es6Arrow=true, ~with_=true, p) => { - let attrs = parseAttributes(p) - let modty = if es6Arrow && isEs6ArrowFunctor(p) { - parseFunctorModuleType(p) - } else { - let modty = parseAtomicModuleType(p) - switch p.Parser.token { - | EqualGreater when es6Arrow === true => - Parser.next(p) - let rhs = parseModuleType(~with_=false, p) - let str = Location.mknoloc("_") - let loc = mkLoc(modty.pmty_loc.loc_start, p.prevEndPos) - Ast_helper.Mty.functor_(~loc, str, Some(modty), rhs) - | _ => modty - } - } - - let moduleType = { - ...modty, - pmty_attributes: List.concat(list{modty.pmty_attributes, attrs}), - } - if with_ { - parseWithConstraints(moduleType, p) - } else { - moduleType - } - } - - and parseWithConstraints = (moduleType, p) => - switch p.Parser.token { - | With => - Parser.next(p) - let first = parseWithConstraint(p) - let rec loop = (p, acc) => - switch p.Parser.token { - | And => - Parser.next(p) - loop(p, list{parseWithConstraint(p), ...acc}) - | _ => List.rev(acc) - } - - let constraints = loop(p, list{first}) - let loc = mkLoc(moduleType.pmty_loc.loc_start, p.prevEndPos) - Ast_helper.Mty.with_(~loc, moduleType, constraints) - | _ => moduleType - } - - /* mod-constraint ::= - * | type typeconstr type-equation type-constraints? - * ∣ type typeconstr-name := typexpr - * ∣ module module-path = extended-module-path - * ∣ module module-path := extended-module-path - * - * TODO: split this up into multiple functions, better errors */ - and parseWithConstraint = p => - switch p.Parser.token { - | Module => - Parser.next(p) - let modulePath = parseModuleLongIdent(~lowercase=false, p) - switch p.Parser.token { - | ColonEqual => - Parser.next(p) - let lident = parseModuleLongIdent(~lowercase=false, p) - Parsetree.Pwith_modsubst(modulePath, lident) - | Equal => - Parser.next(p) - let lident = parseModuleLongIdent(~lowercase=false, p) - Parsetree.Pwith_module(modulePath, lident) - | token => - /* TODO: revisit */ - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - let lident = parseModuleLongIdent(~lowercase=false, p) - Parsetree.Pwith_modsubst(modulePath, lident) - } - | Typ => - Parser.next(p) - let typeConstr = parseValuePath(p) - let params = parseTypeParams(~parent=typeConstr, p) - switch p.Parser.token { - | ColonEqual => - Parser.next(p) - let typExpr = parseTypExpr(p) - Parsetree.Pwith_typesubst( - typeConstr, - Ast_helper.Type.mk( - ~loc=typeConstr.loc, - ~params, - ~manifest=typExpr, - Location.mkloc(Longident.last(typeConstr.txt), typeConstr.loc), - ), - ) - | Equal => - Parser.next(p) - let typExpr = parseTypExpr(p) - let typeConstraints = parseTypeConstraints(p) - Parsetree.Pwith_type( - typeConstr, - Ast_helper.Type.mk( - ~loc=typeConstr.loc, - ~params, - ~manifest=typExpr, - ~cstrs=typeConstraints, - Location.mkloc(Longident.last(typeConstr.txt), typeConstr.loc), - ), - ) - | token => - /* TODO: revisit */ - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - let typExpr = parseTypExpr(p) - let typeConstraints = parseTypeConstraints(p) - Parsetree.Pwith_type( - typeConstr, - Ast_helper.Type.mk( - ~loc=typeConstr.loc, - ~params, - ~manifest=typExpr, - ~cstrs=typeConstraints, - Location.mkloc(Longident.last(typeConstr.txt), typeConstr.loc), - ), - ) - } - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - exit(-1) - } /* TODO: handle this case */ - - and parseModuleTypeOf = p => { - let startPos = p.Parser.startPos - Parser.expect(Module, p) - Parser.expect(Typ, p) - Parser.expect(Of, p) - let moduleExpr = parseModuleExpr(p) - Ast_helper.Mty.typeof_(~loc=mkLoc(startPos, p.prevEndPos), moduleExpr) - } - - /* module signature on the file level */ - @progress((Parser.next, Parser.expect, Parser.checkProgress)) - and parseSpecification = p => - parseRegion(~grammar=Grammar.Specification, ~f=parseSignatureItemRegion, p) - - and parseSignatureItemRegion = p => { - let startPos = p.Parser.startPos - let attrs = parseAttributes(p) - switch p.Parser.token { - | Let => - Parser.beginRegion(p) - let valueDesc = parseSignLetDesc(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Parser.endRegion(p) - Some(Ast_helper.Sig.value(~loc, valueDesc)) - | Typ => - Parser.beginRegion(p) - switch parseTypeDefinitionOrExtension(~attrs, p) { - | TypeDef({recFlag, types}) => - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Parser.endRegion(p) - Some(Ast_helper.Sig.type_(~loc, recFlag, types)) - | TypeExt(ext) => - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Parser.endRegion(p) - Some(Ast_helper.Sig.type_extension(~loc, ext)) - } - | External => - let externalDef = parseExternalDef(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.value(~loc, externalDef)) - | Exception => - let exceptionDef = parseExceptionDef(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.exception_(~loc, exceptionDef)) - | Open => - let openDescription = parseOpenDescription(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.open_(~loc, openDescription)) - | Include => - Parser.next(p) - let moduleType = parseModuleType(p) - let includeDescription = Ast_helper.Incl.mk( - ~loc=mkLoc(startPos, p.prevEndPos), - ~attrs, - moduleType, - ) - - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.include_(~loc, includeDescription)) - | Module => - Parser.next(p) - switch p.Parser.token { - | Uident(_) => - let modDecl = parseModuleDeclarationOrAlias(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.module_(~loc, modDecl)) - | Rec => - let recModule = parseRecModuleSpec(~attrs, ~startPos, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.rec_module(~loc, recModule)) - | Typ => Some(parseModuleTypeDeclaration(~attrs, ~startPos, p)) - | _t => - let modDecl = parseModuleDeclarationOrAlias(~attrs, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.module_(~loc, modDecl)) - } - | AtAt => - let attr = parseStandaloneAttribute(p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.attribute(~loc, attr)) - | PercentPercent => - let extension = parseExtension(~moduleLanguage=true, p) - Parser.optional(p, Semicolon) |> ignore - let loc = mkLoc(startPos, p.prevEndPos) - Some(Ast_helper.Sig.extension(~attrs, ~loc, extension)) - | Import => - Parser.next(p) - parseSignatureItemRegion(p) - | _ => None - } - } - - /* module rec module-name : module-type { and module-name: module-type } */ - and parseRecModuleSpec = (~attrs, ~startPos, p) => { - Parser.expect(Rec, p) - let rec loop = (p, spec) => { - let startPos = p.Parser.startPos - let attrs = parseAttributesAndBinding(p) - switch p.Parser.token { - | And => - /* TODO: give a good error message when with constraint, no parens - * and ASet: (Set.S with type elt = A.t) - * and BTree: (Btree.S with type elt = A.t) - * Without parens, the `and` signals the start of another - * `with-constraint` - */ - Parser.expect(And, p) - let decl = parseRecModuleDeclaration(~attrs, ~startPos, p) - loop(p, list{decl, ...spec}) - | _ => List.rev(spec) - } - } - - let first = parseRecModuleDeclaration(~attrs, ~startPos, p) - loop(p, list{first}) - } - - /* module-name : module-type */ - and parseRecModuleDeclaration = (~attrs, ~startPos, p) => { - let name = switch p.Parser.token { - | Uident(modName) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Location.mkloc(modName, loc) - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mknoloc("_") - } - - Parser.expect(Colon, p) - let modType = parseModuleType(p) - Ast_helper.Md.mk(~loc=mkLoc(startPos, p.prevEndPos), ~attrs, name, modType) - } - - and parseModuleDeclarationOrAlias = (~attrs, p) => { - let startPos = p.Parser.startPos - let moduleName = switch p.Parser.token { - | Uident(ident) => - let loc = mkLoc(p.Parser.startPos, p.endPos) - Parser.next(p) - Location.mkloc(ident, loc) - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mknoloc("_") - } - - let body = switch p.Parser.token { - | Colon => - Parser.next(p) - parseModuleType(p) - | Equal => - Parser.next(p) - let lident = parseModuleLongIdent(~lowercase=false, p) - Ast_helper.Mty.alias(lident) - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - Recover.defaultModuleType() - } - - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Md.mk(~loc, ~attrs, moduleName, body) - } - - and parseModuleTypeDeclaration = (~attrs, ~startPos, p) => { - Parser.expect(Typ, p) - let moduleName = switch p.Parser.token { - | Uident(ident) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Location.mkloc(ident, loc) - | Lident(ident) => - let loc = mkLoc(p.startPos, p.endPos) - Parser.next(p) - Location.mkloc(ident, loc) - | t => - Parser.err(p, Diagnostics.uident(t)) - Location.mknoloc("_") - } - - let typ = switch p.Parser.token { - | Equal => - Parser.next(p) - Some(parseModuleType(p)) - | _ => None - } - - let moduleDecl = Ast_helper.Mtd.mk(~attrs, ~typ?, moduleName) - Ast_helper.Sig.modtype(~loc=mkLoc(startPos, p.prevEndPos), moduleDecl) - } - - and parseSignLetDesc = (~attrs, p) => { - let startPos = p.Parser.startPos - Parser.expect(Let, p) - let (name, loc) = parseLident(p) - let name = Location.mkloc(name, loc) - Parser.expect(Colon, p) - let typExpr = parsePolyTypeExpr(p) - let loc = mkLoc(startPos, p.prevEndPos) - Ast_helper.Val.mk(~loc, ~attrs, name, typExpr) - } - - /* attr-id ::= lowercase-ident - ∣ capitalized-ident - ∣ attr-id . attr-id */ - and parseAttributeId = p => { - let startPos = p.Parser.startPos - let rec loop = (p, acc) => - switch p.Parser.token { - | Lident(ident) | Uident(ident) => - Parser.next(p) - let id = acc ++ ident - switch p.Parser.token { - | Dot => - Parser.next(p) - loop(p, id ++ ".") - | _ => id - } - | token when Token.isKeyword(token) => - Parser.next(p) - let id = acc ++ Token.toString(token) - switch p.Parser.token { - | Dot => - Parser.next(p) - loop(p, id ++ ".") - | _ => id - } - | token => - Parser.err(p, Diagnostics.unexpected(token, p.breadcrumbs)) - acc - } - - let id = loop(p, "") - let endPos = p.prevEndPos - Location.mkloc(id, mkLoc(startPos, endPos)) - } - - /* - * payload ::= empty - * | ( structure-item ) - * - * TODO: what about multiple structure items? - * @attr({let x = 1; let x = 2}) - * - * Also what about type-expressions and specifications? - * @attr(:myType) ??? - */ - and parsePayload = p => - switch p.Parser.token { - | Lparen when p.startPos.pos_cnum == p.prevEndPos.pos_cnum => - Parser.next(p) - switch p.token { - | Colon => - Parser.next(p) - let typ = parseTypExpr(p) - Parser.expect(Rparen, p) - Parsetree.PTyp(typ) - | _ => - let items = parseDelimitedRegion( - ~grammar=Grammar.Structure, - ~closing=Rparen, - ~f=parseStructureItemRegion, - p, - ) - - Parser.expect(Rparen, p) - Parsetree.PStr(items) - } - | _ => Parsetree.PStr(list{}) - } - - /* type attribute = string loc * payload */ - and parseAttribute = p => - switch p.Parser.token { - | At => - Parser.next(p) - let attrId = parseAttributeId(p) - let payload = parsePayload(p) - Some(attrId, payload) - | _ => None - } - - and parseAttributes = p => parseRegion(p, ~grammar=Grammar.Attribute, ~f=parseAttribute) - - /* - * standalone-attribute ::= - * | @@ atribute-id - * | @@ attribute-id ( structure-item ) - */ - and parseStandaloneAttribute = p => { - Parser.expect(AtAt, p) - let attrId = parseAttributeId(p) - let payload = parsePayload(p) - (attrId, payload) - } - - /* extension ::= % attr-id attr-payload - * | %% attr-id( - * expr ::= ... - * ∣ extension - * - * typexpr ::= ... - * ∣ extension - * - * pattern ::= ... - * ∣ extension - * - * module-expr ::= ... - * ∣ extension - * - * module-type ::= ... - * ∣ extension - * - * class-expr ::= ... - * ∣ extension - * - * class-type ::= ... - * ∣ extension - * - * - * item extension nodes usable in structures and signature - * - * item-extension ::= %% attr-id - * | %% attr-id(structure-item) - * - * attr-payload ::= structure-item - * - * ~moduleLanguage represents whether we're on the module level or not - */ - and parseExtension = (~moduleLanguage=false, p) => { - if moduleLanguage { - Parser.expect(PercentPercent, p) - } else { - Parser.expect(Percent, p) - } - let attrId = parseAttributeId(p) - let payload = parsePayload(p) - (attrId, payload) - } -} - -module OutcomePrinter: { - open Format - open Outcometree - - @live let out_value: ref<(formatter, out_value) => unit> - @live let out_type: ref<(formatter, out_type) => unit> - @live let out_class_type: ref<(formatter, out_class_type) => unit> - @live let out_module_type: ref<(formatter, out_module_type) => unit> - @live let out_sig_item: ref<(formatter, out_sig_item) => unit> - @live let out_signature: ref<(formatter, list) => unit> - @live let out_type_extension: ref<(formatter, out_type_extension) => unit> - @live let out_phrase: ref<(formatter, out_phrase) => unit> - - @live let parenthesized_ident: string => bool -} = { - /* Napkin doesn't have parenthesized identifiers. - * We don't support custom operators. */ - let parenthesized_ident = _name => true - - /* TODO: better allocation strategy for the buffer */ - let escapeStringContents = s => { - let len = String.length(s) - let b = Buffer.create(len) - for i in 0 to len - 1 { - let c = (@doesNotRaise String.get)(s, i) - if c == '\b' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 'b') - } else if c == '\t' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 't') - } else if c == '\n' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 'n') - } else if c == '\r' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 'r') - } else if c == '"' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '"') - } else if c == '\\' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '\\') - } else { - Buffer.add_char(b, c) - } - } - Buffer.contents(b) - } - - /* let rec print_ident fmt ident = match ident with - | Outcometree.Oide_ident s -> Format.pp_print_string fmt s - | Oide_dot (id, s) -> - print_ident fmt id; - Format.pp_print_char fmt '.'; - Format.pp_print_string fmt s - | Oide_apply (id1, id2) -> - print_ident fmt id1; - Format.pp_print_char fmt '('; - print_ident fmt id2; - Format.pp_print_char fmt ')' */ - - let rec printOutIdentDoc = (ident: Outcometree.out_ident) => - switch ident { - | Oide_ident(s) => Doc.text(s) - | Oide_dot(ident, s) => Doc.concat(list{printOutIdentDoc(ident), Doc.dot, Doc.text(s)}) - | Oide_apply(call, arg) => - Doc.concat(list{printOutIdentDoc(call), Doc.lparen, printOutIdentDoc(arg), Doc.rparen}) - } - - let printOutAttributeDoc = (outAttribute: Outcometree.out_attribute) => - Doc.concat(list{Doc.text("@"), Doc.text(outAttribute.oattr_name)}) - - let printOutAttributesDoc = (attrs: list) => - switch attrs { - | list{} => Doc.nil - | attrs => - Doc.concat(list{ - Doc.group(Doc.join(~sep=Doc.line, List.map(printOutAttributeDoc, attrs))), - Doc.line, - }) - } - - let rec collectArrowArgs = (outType: Outcometree.out_type, args) => - switch outType { - | Otyp_arrow(label, argType, returnType) => - let arg = (label, argType) - collectArrowArgs(returnType, list{arg, ...args}) - | _ as returnType => (List.rev(args), returnType) - } - - let rec collectFunctorArgs = (outModuleType: Outcometree.out_module_type, args) => - switch outModuleType { - | Omty_functor(lbl, optModType, returnModType) => - let arg = (lbl, optModType) - collectFunctorArgs(returnModType, list{arg, ...args}) - | _ => (List.rev(args), outModuleType) - } - - let rec printOutTypeDoc = (outType: Outcometree.out_type) => - switch outType { - | Otyp_abstract | Otyp_variant(_) | Otyp_open => Doc.nil - | Otyp_alias(typ, aliasTxt) => - Doc.concat(list{printOutTypeDoc(typ), Doc.text(" as '"), Doc.text(aliasTxt)}) - | Otyp_constr(outIdent, list{}) => printOutIdentDoc(outIdent) - | Otyp_manifest(typ1, typ2) => - Doc.concat(list{printOutTypeDoc(typ1), Doc.text(" = "), printOutTypeDoc(typ2)}) - | Otyp_record(record) => printRecordDeclarationDoc(~inline=true, record) - | Otyp_stuff(txt) => Doc.text(txt) - | Otyp_var(ng, s) => - Doc.concat(list{ - Doc.text( - "'" ++ if ng { - "_" - } else { - "" - }, - ), - Doc.text(s), - }) - | Otyp_object(fields, rest) => printObjectFields(fields, rest) - | Otyp_class(_) => Doc.nil - | Otyp_attribute(typ, attribute) => - Doc.group(Doc.concat(list{printOutAttributeDoc(attribute), Doc.line, printOutTypeDoc(typ)})) - /* example: Red | Blue | Green | CustomColour(float, float, float) */ - | Otyp_sum(constructors) => printOutConstructorsDoc(constructors) - - /* example: {"name": string, "age": int} */ - | Otyp_constr(Oide_dot(Oide_ident("Js"), "t"), list{Otyp_object(fields, rest)}) => - printObjectFields(fields, rest) - - /* example: node */ - | Otyp_constr(outIdent, args) => - let argsDoc = switch args { - | list{} => Doc.nil - | args => - Doc.concat(list{ - Doc.lessThan, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(printOutTypeDoc, args)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.greaterThan, - }) - } - - Doc.group(Doc.concat(list{printOutIdentDoc(outIdent), argsDoc})) - | Otyp_tuple(tupleArgs) => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(printOutTypeDoc, tupleArgs), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - | Otyp_poly(vars, outType) => - Doc.group( - Doc.concat(list{ - Doc.join(~sep=Doc.space, List.map(var => Doc.text("'" ++ var), vars)), - printOutTypeDoc(outType), - }), - ) - | Otyp_arrow(_) as typ => - let (typArgs, typ) = collectArrowArgs(typ, list{}) - let args = Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(((lbl, typ)) => - if lbl == "" { - printOutTypeDoc(typ) - } else { - Doc.group(Doc.concat(list{Doc.text("~" ++ (lbl ++ ": ")), printOutTypeDoc(typ)})) - } - , typArgs)) - let argsDoc = { - let needsParens = switch typArgs { - | list{(_, Otyp_tuple(_) | Otyp_arrow(_))} => true - /* single argument should not be wrapped */ - | list{("", _)} => false - | _ => true - } - - if needsParens { - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent(Doc.concat(list{Doc.softLine, args})), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - } else { - args - } - } - - Doc.concat(list{argsDoc, Doc.text(" => "), printOutTypeDoc(typ)}) - | Otyp_module(_modName, _stringList, _outTypes) => Doc.nil - } - - and printObjectFields = (fields, rest) => { - let dots = switch rest { - | Some(non_gen) => - Doc.text( - if non_gen { - "_" - } else { - "" - } ++ "..", - ) - | None => Doc.nil - } - - Doc.group( - Doc.concat(list{ - Doc.lbrace, - dots, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map( - ((lbl, outType)) => - Doc.group( - Doc.concat(list{Doc.text("\"" ++ (lbl ++ "\": ")), printOutTypeDoc(outType)}), - ), - fields, - ), - ), - }), - ), - Doc.softLine, - Doc.trailingComma, - Doc.rbrace, - }), - ) - } - - and printOutConstructorsDoc = constructors => - Doc.group( - Doc.indent(Doc.concat(list{Doc.line, Doc.join(~sep=Doc.line, List.mapi((i, constructor) => - Doc.concat(list{ - if i > 0 { - Doc.text("| ") - } else { - Doc.ifBreaks(Doc.text("| "), Doc.nil) - }, - printOutConstructorDoc(constructor), - }) - , constructors))})), - ) - - and printOutConstructorDoc = ((name, args, gadt)) => { - let gadtDoc = switch gadt { - | Some(outType) => Doc.concat(list{Doc.text(": "), printOutTypeDoc(outType)}) - | None => Doc.nil - } - - let argsDoc = switch args { - | list{} => Doc.nil - | list{Otyp_record(record)} => - /* inline records - * | Root({ - * mutable value: 'value, - * mutable updatedTime: float, - * }) - */ - Doc.concat(list{ - Doc.lparen, - Doc.indent(printRecordDeclarationDoc(~inline=true, record)), - Doc.rparen, - }) - | _types => - Doc.indent( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(printOutTypeDoc, args)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - } - - Doc.group(Doc.concat(list{Doc.text(name), argsDoc, gadtDoc})) - } - - and printRecordDeclRowDoc = ((name, mut, arg)) => - Doc.group( - Doc.concat(list{ - if mut { - Doc.text("mutable ") - } else { - Doc.nil - }, - Doc.text(name), - Doc.text(": "), - printOutTypeDoc(arg), - }), - ) - - and printRecordDeclarationDoc = (~inline, rows) => { - let content = Doc.concat(list{ - Doc.lbrace, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(printRecordDeclRowDoc, rows), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - }) - if !inline { - Doc.group(content) - } else { - content - } - } - - let printOutType = (fmt, outType) => - Format.pp_print_string(fmt, Doc.toString(~width=80, printOutTypeDoc(outType))) - - let printTypeParameterDoc = ((typ, (co, cn))) => - Doc.concat(list{ - if !cn { - Doc.text("+") - } else if !co { - Doc.text("-") - } else { - Doc.nil - }, - if typ == "_" { - Doc.text("_") - } else { - Doc.text("'" ++ typ) - }, - }) - - let rec printOutSigItemDoc = (outSigItem: Outcometree.out_sig_item) => - switch outSigItem { - | Osig_class(_) | Osig_class_type(_) => Doc.nil - | Osig_ellipsis => Doc.dotdotdot - | Osig_value(valueDecl) => - Doc.group( - Doc.concat(list{ - printOutAttributesDoc(valueDecl.oval_attributes), - Doc.text( - switch valueDecl.oval_prims { - | list{} => "let " - | _ => "external " - }, - ), - Doc.text(valueDecl.oval_name), - Doc.text(":"), - Doc.space, - printOutTypeDoc(valueDecl.oval_type), - switch valueDecl.oval_prims { - | list{} => Doc.nil - | primitives => - Doc.indent( - Doc.concat(list{ - Doc.text(" ="), - Doc.line, - Doc.group( - Doc.join( - ~sep=Doc.line, - List.map(prim => Doc.text("\"" ++ (prim ++ "\"")), primitives), - ), - ), - }), - ) - }, - }), - ) - | Osig_typext(outExtensionConstructor, _outExtStatus) => - printOutExtensionConstructorDoc(outExtensionConstructor) - | Osig_modtype(modName, Omty_signature(list{})) => - Doc.concat(list{Doc.text("module type "), Doc.text(modName)}) - | Osig_modtype(modName, outModuleType) => - Doc.group( - Doc.concat(list{ - Doc.text("module type "), - Doc.text(modName), - Doc.text(" = "), - printOutModuleTypeDoc(outModuleType), - }), - ) - | Osig_module(modName, Omty_alias(ident), _) => - Doc.group( - Doc.concat(list{ - Doc.text("module "), - Doc.text(modName), - Doc.text(" ="), - Doc.line, - printOutIdentDoc(ident), - }), - ) - | Osig_module(modName, outModType, outRecStatus) => - Doc.group( - Doc.concat(list{ - Doc.text( - switch outRecStatus { - | Orec_not => "module " - | Orec_first => "module rec " - | Orec_next => "and" - }, - ), - Doc.text(modName), - Doc.text(" = "), - printOutModuleTypeDoc(outModType), - }), - ) - | Osig_type(outTypeDecl, outRecStatus) => - /* TODO: manifest ? */ - let attrs = switch (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) { - | (false, false) => Doc.nil - | (true, false) => Doc.concat(list{Doc.text("@immediate"), Doc.line}) - | (false, true) => Doc.concat(list{Doc.text("@unboxed"), Doc.line}) - | (true, true) => Doc.concat(list{Doc.text("@immediate @unboxed"), Doc.line}) - } - - let kw = Doc.text( - switch outRecStatus { - | Orec_not => "type " - | Orec_first => "type rec " - | Orec_next => "and " - }, - ) - let typeParams = switch outTypeDecl.otype_params { - | list{} => Doc.nil - | _params => - Doc.group( - Doc.concat(list{ - Doc.lessThan, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(printTypeParameterDoc, outTypeDecl.otype_params), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.greaterThan, - }), - ) - } - - let privateDoc = switch outTypeDecl.otype_private { - | Asttypes.Private => Doc.text("private ") - | Public => Doc.nil - } - - let kind = switch outTypeDecl.otype_type { - | Otyp_open => Doc.concat(list{Doc.text(" = "), privateDoc, Doc.text("..")}) - | Otyp_abstract => Doc.nil - | Otyp_record(record) => - Doc.concat(list{ - Doc.text(" = "), - privateDoc, - printRecordDeclarationDoc(~inline=false, record), - }) - | typ => Doc.concat(list{Doc.text(" = "), printOutTypeDoc(typ)}) - } - - let constraints = switch outTypeDecl.otype_cstrs { - | list{} => Doc.nil - | _ => - Doc.group( - Doc.concat(list{ - Doc.line, - Doc.indent( - Doc.concat(list{ - Doc.hardLine, - Doc.join( - ~sep=Doc.line, - List.map( - ((typ1, typ2)) => - Doc.group( - Doc.concat(list{ - Doc.text("constraint "), - printOutTypeDoc(typ1), - Doc.text(" ="), - Doc.indent(Doc.concat(list{Doc.line, printOutTypeDoc(typ2)})), - }), - ), - outTypeDecl.otype_cstrs, - ), - ), - }), - ), - }), - ) - } - Doc.group( - Doc.concat(list{ - attrs, - Doc.group( - Doc.concat(list{attrs, kw, Doc.text(outTypeDecl.otype_name), typeParams, kind}), - ), - constraints, - }), - ) - } - - and printOutModuleTypeDoc = (outModType: Outcometree.out_module_type) => - switch outModType { - | Omty_abstract => Doc.nil - | Omty_ident(ident) => printOutIdentDoc(ident) - /* example: module Increment = (M: X_int) => X_int */ - | Omty_functor(_) => - let (args, returnModType) = collectFunctorArgs(outModType, list{}) - let argsDoc = switch args { - | list{(_, None)} => Doc.text("()") - | args => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(((lbl, optModType)) => - Doc.group( - Doc.concat(list{ - Doc.text(lbl), - switch optModType { - | None => Doc.nil - | Some(modType) => - Doc.concat(list{Doc.text(": "), printOutModuleTypeDoc(modType)}) - }, - }), - ) - , args)), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - } - - Doc.group(Doc.concat(list{argsDoc, Doc.text(" => "), printOutModuleTypeDoc(returnModType)})) - | Omty_signature(list{}) => Doc.nil - | Omty_signature(signature) => - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list{ - Doc.lbrace, - Doc.indent(Doc.concat(list{Doc.line, printOutSignatureDoc(signature)})), - Doc.softLine, - Doc.rbrace, - }), - ) - | Omty_alias(_ident) => Doc.nil - } - - and printOutSignatureDoc = (signature: list) => { - let rec loop = (signature, acc) => - switch signature { - | list{} => List.rev(acc) - | list{Outcometree.Osig_typext(ext, Oext_first), ...items} => - /* Gather together the extension constructors */ - let rec gather_extensions = (acc, items) => - switch items { - | list{Outcometree.Osig_typext(ext, Oext_next), ...items} => - gather_extensions( - list{(ext.oext_name, ext.oext_args, ext.oext_ret_type), ...acc}, - items, - ) - | _ => (List.rev(acc), items) - } - - let (exts, items) = gather_extensions( - list{(ext.oext_name, ext.oext_args, ext.oext_ret_type)}, - items, - ) - - let te = { - Outcometree.otyext_name: ext.oext_type_name, - otyext_params: ext.oext_type_params, - otyext_constructors: exts, - otyext_private: ext.oext_private, - } - - let doc = printOutTypeExtensionDoc(te) - loop(items, list{doc, ...acc}) - | list{item, ...items} => - let doc = printOutSigItemDoc(item) - loop(items, list{doc, ...acc}) - } - - switch loop(signature, list{}) { - | list{doc} => doc - | docs => Doc.breakableGroup(~forceBreak=true, Doc.join(~sep=Doc.line, docs)) - } - } - - and printOutExtensionConstructorDoc = (outExt: Outcometree.out_extension_constructor) => { - let typeParams = switch outExt.oext_type_params { - | list{} => Doc.nil - | params => - Doc.group( - Doc.concat(list{ - Doc.lessThan, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(ty => - Doc.text( - if ty == "_" { - ty - } else { - "'" ++ ty - }, - ) - , params)), - }), - ), - Doc.softLine, - Doc.greaterThan, - }), - ) - } - - Doc.group( - Doc.concat(list{ - Doc.text("type "), - Doc.text(outExt.oext_type_name), - typeParams, - Doc.text(" +="), - Doc.line, - if outExt.oext_private == Asttypes.Private { - Doc.text("private ") - } else { - Doc.nil - }, - printOutConstructorDoc((outExt.oext_name, outExt.oext_args, outExt.oext_ret_type)), - }), - ) - } - - and printOutTypeExtensionDoc = (typeExtension: Outcometree.out_type_extension) => { - let typeParams = switch typeExtension.otyext_params { - | list{} => Doc.nil - | params => - Doc.group( - Doc.concat(list{ - Doc.lessThan, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join(~sep=Doc.concat(list{Doc.comma, Doc.line}), List.map(ty => - Doc.text( - if ty == "_" { - ty - } else { - "'" ++ ty - }, - ) - , params)), - }), - ), - Doc.softLine, - Doc.greaterThan, - }), - ) - } - - Doc.group( - Doc.concat(list{ - Doc.text("type "), - Doc.text(typeExtension.otyext_name), - typeParams, - Doc.text(" +="), - if typeExtension.otyext_private == Asttypes.Private { - Doc.text("private ") - } else { - Doc.nil - }, - printOutConstructorsDoc(typeExtension.otyext_constructors), - }), - ) - } - - let printOutSigItem = (fmt, outSigItem) => - Format.pp_print_string(fmt, Doc.toString(~width=80, printOutSigItemDoc(outSigItem))) - - let printOutSignature = (fmt, signature) => - Format.pp_print_string(fmt, Doc.toString(~width=80, printOutSignatureDoc(signature))) - - let validFloatLexeme = s => { - let l = String.length(s) - let rec loop = i => - if i >= l { - s ++ "." - } else { - switch @doesNotRaise - String.get(s, i) { - | '0' .. '9' | '-' => loop(i + 1) - | _ => s - } - } - loop(0) - } - - let floatRepres = f => - switch classify_float(f) { - | FP_nan => "nan" - | FP_infinite => - if f < 0.0 { - "neg_infinity" - } else { - "infinity" - } - | _ => - let float_val = { - let s1 = Printf.sprintf("%.12g", f) - if f == (@doesNotRaise float_of_string)(s1) { - s1 - } else { - let s2 = Printf.sprintf("%.15g", f) - if f == (@doesNotRaise float_of_string)(s2) { - s2 - } else { - Printf.sprintf("%.18g", f) - } - } - } - validFloatLexeme(float_val) - } - - let rec printOutValueDoc = (outValue: Outcometree.out_value) => - switch outValue { - | Oval_array(outValues) => - Doc.group( - Doc.concat(list{ - Doc.lbracket, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(printOutValueDoc, outValues), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbracket, - }), - ) - | Oval_char(c) => Doc.text("'" ++ (Char.escaped(c) ++ "'")) - | Oval_constr(outIdent, outValues) => - Doc.group( - Doc.concat(list{ - printOutIdentDoc(outIdent), - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(printOutValueDoc, outValues), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - | Oval_ellipsis => Doc.text("...") - | Oval_int(i) => Doc.text(Format.sprintf("%i", i)) - | Oval_int32(i) => Doc.text(Format.sprintf("%lil", i)) - | Oval_int64(i) => Doc.text(Format.sprintf("%LiL", i)) - | Oval_nativeint(i) => Doc.text(Format.sprintf("%nin", i)) - | Oval_float(f) => Doc.text(floatRepres(f)) - | Oval_list(outValues) => - Doc.group( - Doc.concat(list{ - Doc.text("list["), - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(printOutValueDoc, outValues), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbracket, - }), - ) - | Oval_printer(fn) => - let fmt = Format.str_formatter - fn(fmt) - let str = Format.flush_str_formatter() - Doc.text(str) - | Oval_record(rows) => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map( - ((outIdent, outValue)) => - Doc.group( - Doc.concat(list{ - printOutIdentDoc(outIdent), - Doc.text(": "), - printOutValueDoc(outValue), - }), - ), - rows, - ), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - | Oval_string(txt, _sizeToPrint, _kind) => Doc.text(escapeStringContents(txt)) - | Oval_stuff(txt) => Doc.text(txt) - | Oval_tuple(outValues) => - Doc.group( - Doc.concat(list{ - Doc.lparen, - Doc.indent( - Doc.concat(list{ - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list{Doc.comma, Doc.line}), - List.map(printOutValueDoc, outValues), - ), - }), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - }), - ) - /* Not supported by NapkinScript */ - | Oval_variant(_) => Doc.nil - } - - let printOutExceptionDoc = (exc, outValue) => - switch exc { - | Sys.Break => Doc.text("Interrupted.") - | Out_of_memory => Doc.text("Out of memory during evaluation.") - | Stack_overflow => Doc.text("Stack overflow during evaluation (looping recursion?).") - | _ => - Doc.group( - Doc.indent(Doc.concat(list{Doc.text("Exception:"), Doc.line, printOutValueDoc(outValue)})), - ) - } - - let printOutPhraseSignature = signature => { - let rec loop = (signature, acc) => - switch signature { - | list{} => List.rev(acc) - | list{(Outcometree.Osig_typext(ext, Oext_first), None), ...signature} => - /* Gather together extension constructors */ - let rec gather_extensions = (acc, items) => - switch items { - | list{(Outcometree.Osig_typext(ext, Oext_next), None), ...items} => - gather_extensions( - list{(ext.oext_name, ext.oext_args, ext.oext_ret_type), ...acc}, - items, - ) - | _ => (List.rev(acc), items) - } - - let (exts, signature) = gather_extensions( - list{(ext.oext_name, ext.oext_args, ext.oext_ret_type)}, - signature, - ) - - let te = { - Outcometree.otyext_name: ext.oext_type_name, - otyext_params: ext.oext_type_params, - otyext_constructors: exts, - otyext_private: ext.oext_private, - } - - let doc = printOutTypeExtensionDoc(te) - loop(signature, list{doc, ...acc}) - | list{(sigItem, optOutValue), ...signature} => - let doc = switch optOutValue { - | None => printOutSigItemDoc(sigItem) - | Some(outValue) => - Doc.group( - Doc.concat(list{ - printOutSigItemDoc(sigItem), - Doc.text(" = "), - printOutValueDoc(outValue), - }), - ) - } - - loop(signature, list{doc, ...acc}) - } - - Doc.breakableGroup(~forceBreak=true, Doc.join(~sep=Doc.line, loop(signature, list{}))) - } - - let printOutPhraseDoc = (outPhrase: Outcometree.out_phrase) => - switch outPhrase { - | Ophr_eval(outValue, outType) => - Doc.group( - Doc.concat(list{ - Doc.text("- : "), - printOutTypeDoc(outType), - Doc.text(" ="), - Doc.indent(Doc.concat(list{Doc.line, printOutValueDoc(outValue)})), - }), - ) - | Ophr_signature(list{}) => Doc.nil - | Ophr_signature(signature) => printOutPhraseSignature(signature) - | Ophr_exception(exc, outValue) => printOutExceptionDoc(exc, outValue) - } - - let printOutPhase = (fmt, outPhrase) => - Format.pp_print_string(fmt, Doc.toString(~width=80, printOutPhraseDoc(outPhrase))) - - let printOutModuleType = (fmt, outModuleType) => - Format.pp_print_string(fmt, Doc.toString(~width=80, printOutModuleTypeDoc(outModuleType))) - - let printOutTypeExtension = (fmt, typeExtension) => - Format.pp_print_string(fmt, Doc.toString(~width=80, printOutTypeExtensionDoc(typeExtension))) - - let printOutValue = (fmt, outValue) => - Format.pp_print_string(fmt, Doc.toString(~width=80, printOutValueDoc(outValue))) - - /* Not supported in Napkin */ - let printOutClassType = (_fmt, _) => () - - let out_value = ref(printOutValue) - let out_type = ref(printOutType) - let out_module_type = ref(printOutModuleType) - let out_sig_item = ref(printOutSigItem) - let out_signature = ref(printOutSignature) - let out_type_extension = ref(printOutTypeExtension) - let out_phrase = @live ref(printOutPhase) - let out_class_type = ref(printOutClassType) -} - -module Repl = { - let parseToplevelPhrase = filename => { - let src = IO.readFile(filename) - let p = Parser.make(src, filename) - Parsetree.Ptop_def(NapkinScript.parseImplementation(p)) - } - - let typeAndPrintOutcome = filename => { - Compmisc.init_path(false) - let env = Compmisc.initial_env() - try { - let sstr = switch parseToplevelPhrase(filename) { - | Parsetree.Ptop_def(sstr) => sstr - | _ => assert false - } - - let (_str, signature, _newenv) = Typemod.type_toplevel_phrase(env, sstr) - let outSigItems = Printtyp.tree_of_signature(signature) - let fmt = Format.str_formatter - OutcomePrinter.out_signature.contents(fmt, outSigItems) - let result = Format.flush_str_formatter() - print_string(result) - } catch { - | Typetexp.Error(_, _, err) => - let fmt = Format.str_formatter - Typetexp.report_error(env, fmt, err) - let result = Format.flush_str_formatter() - let () = print_endline(result) - | _ => print_endline("catch all") - } - } -} - -/* command line flags */ -module Clflags: { - let recover: ref - let print: ref - let width: ref - let origin: ref - let files: ref> - let interface: ref - let report: ref - - let parse: unit => unit - let outcome: ref -} = { - let recover = ref(false) - let width = ref(100) - - let files = ref(list{}) - let addFilename = filename => files := list{filename, ...files.contents} - - let print = ref("") - let outcome = ref(false) - let origin = ref("") - let interface = ref(false) - let report = ref("pretty") - - let usage = "Usage: napkinscript \nOptions are:" - - let spec = list{ - ("-recover", Arg.Unit(() => recover := true), "Emit partial ast"), - ("-print", Arg.String(txt => print := txt), "Print either binary, ocaml or ast"), - ("-parse", Arg.String(txt => origin := txt), "Parse ocaml or napkinscript"), - ("-outcome", Arg.Bool(printOutcomeTree => outcome := printOutcomeTree), "print outcometree"), - ("-width", Arg.Int(w => width := w), "Specify the line length that the printer will wrap on"), - ("-interface", Arg.Unit(() => interface := true), "Parse as interface"), - ( - "-report", - Arg.String(txt => report := txt), - "Stylize errors and messages using color and context. Accepts `Pretty` and `Plain`. Default `Plain`", - ), - } - - let parse = () => Arg.parse(spec, addFilename, usage) -} - -module Driver: { - let processFile: ( - ~isInterface: bool, - ~width: int, - ~recover: bool, - ~origin: string, - ~target: string, - ~report: string, - string, - ) => unit -} = { - type rec file_kind<'a> = - | Structure: file_kind - | Signature: file_kind - - let parseNapkin = (type a, kind: file_kind, p): a => - switch kind { - | Structure => NapkinScript.parseImplementation(p) - | Signature => NapkinScript.parseSpecification(p) - } - - let extractOcamlStringData = filename => { - let lexbuf = if String.length(filename) > 0 { - IO.readFile(filename) |> Lexing.from_string - } else { - Lexing.from_channel(stdin) - } - - let stringLocs = ref(list{}) - let rec next = () => { - let token = Lexer.token_with_comments(lexbuf) - switch token { - | OcamlParser.STRING(_txt, None) => - open Location - let loc = { - loc_start: lexbuf.lex_start_p, - loc_end: lexbuf.Lexing.lex_curr_p, - loc_ghost: false, - } - let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum - let txt = Bytes.to_string( - (@doesNotRaise Bytes.sub)(lexbuf.Lexing.lex_buffer, loc.loc_start.pos_cnum, len), - ) - stringLocs := list{(txt, loc), ...stringLocs.contents} - next() - | OcamlParser.EOF => () - | _ => next() - } - } - - next() - List.rev(stringLocs.contents) - } - - let parseOcaml = (type a, kind: file_kind, filename): a => { - let lexbuf = if String.length(filename) > 0 { - IO.readFile(filename) |> Lexing.from_string - } else { - Lexing.from_channel(stdin) - } - - let stringData = extractOcamlStringData(filename) - switch kind { - | Structure => - Parse.implementation(lexbuf) - |> ParsetreeCompatibility.replaceStringLiteralStructure(stringData) - |> ParsetreeCompatibility.structure - | Signature => - Parse.interface(lexbuf) - |> ParsetreeCompatibility.replaceStringLiteralSignature(stringData) - |> ParsetreeCompatibility.signature - } - } - - let parseNapkinFile = (~destination, kind, filename) => { - let src = if String.length(filename) > 0 { - IO.readFile(filename) - } else { - IO.readStdin() - } - - let p = { - let mode = switch destination { - | "napkinscript" | "ns" | "sexp" => Parser.Default - | _ => Parser.ParseForTypeChecker - } - - Parser.make(~mode, src, filename) - } - let ast = parseNapkin(kind, p) - let report = switch p.diagnostics { - | list{} => None - | diagnostics => Some(diagnostics) - } - - (ast, report, p) - } - - let parseOcamlFile = (kind, filename) => { - let ast = parseOcaml(kind, filename) - let lexbuf2 = if String.length(filename) > 0 { - IO.readFile(filename) |> Lexing.from_string - } else { - Lexing.from_channel(stdin) - } - - let comments = { - let rec next = (prevTokEndPos: Lexing.position, comments, lb) => { - let token = Lexer.token_with_comments(lb) - switch token { - | OcamlParser.EOF => comments - | OcamlParser.COMMENT(txt, loc) => - let comment = Comment.fromOcamlComment(~loc, ~prevTokEndPos, ~txt) - - next(loc.Location.loc_end, list{comment, ...comments}, lb) - | _ => next(lb.Lexing.lex_curr_p, comments, lb) - } - } - - let cmts = next(lexbuf2.Lexing.lex_start_p, list{}, lexbuf2) - cmts - } - - let p = Parser.make("", filename) - p.comments = comments - (ast, None, p) - } - - let reasonFilename = ref("") - let commentData = ref(list{}) - let stringData = ref(list{}) - - let parseReasonBinaryFromStdin = (type a, kind: file_kind, filename): a => { - let (chan, close) = - String.length(filename) === 0 - ? (stdin, _ => ()) - : { - let file_chan = open_in_bin(filename) - seek_in(file_chan, 0) - (file_chan, close_in_noerr) - } - - let ic = chan - let magic = switch kind { - | Structure => Config.ast_impl_magic_number - | Signature => Config.ast_intf_magic_number - } - - let buffer = (@doesNotRaise really_input_string)(ic, String.length(magic)) - assert (buffer == magic) - let filename = input_value(ic) - reasonFilename := filename - let ast = input_value(ic) - close(chan) - - let src = if String.length(filename) > 0 { - IO.readFile(filename) - } else { - IO.readStdin() - } - - let scanner = Scanner.make(Bytes.of_string(src), filename) - - let rec next = (prevEndPos, scanner) => { - let (startPos, endPos, token) = Scanner.scan(scanner) - switch token { - | Eof => () - | Comment(c) => - Comment.setPrevTokEndPos(c, prevEndPos) - commentData := list{c, ...commentData.contents} - next(endPos, scanner) - | String(_) => - let loc = {Location.loc_start: startPos, loc_end: endPos, loc_ghost: false} - let len = endPos.pos_cnum - startPos.pos_cnum - let txt = (@doesNotRaise String.sub)(src, startPos.pos_cnum, len) - stringData := list{(txt, loc), ...stringData.contents} - next(endPos, scanner) - | _ => next(endPos, scanner) - } - } - - next(Lexing.dummy_pos, scanner) - - switch kind { - | Structure => - ast - |> ParsetreeCompatibility.replaceStringLiteralStructure(stringData.contents) - |> ParsetreeCompatibility.normalizeReasonArityStructure(~forPrinter=true) - |> ParsetreeCompatibility.structure - | Signature => - ast - |> ParsetreeCompatibility.replaceStringLiteralSignature(stringData.contents) - |> ParsetreeCompatibility.normalizeReasonAritySignature(~forPrinter=true) - |> ParsetreeCompatibility.signature - } - } - - let isReasonDocComment = (comment: Comment.t) => { - let content = Comment.txt(comment) - let len = String.length(content) - if len == 0 { - true - } else if ( - len >= 2 && (String.unsafe_get(content, 0) == '*' && String.unsafe_get(content, 1) == '*') - ) { - false - } else if len >= 1 && String.unsafe_get(content, 0) == '*' { - true - } else { - false - } - } - - let parseReasonBinary = (kind, filename) => { - let ast = parseReasonBinaryFromStdin(kind, filename) - let p = Parser.make("", reasonFilename.contents) - p.comments = List.filter(c => !isReasonDocComment(c), commentData.contents) - (ast, None, p) - } - - let parseImplementation = (~origin, ~destination, filename) => - switch origin { - | "ml" | "ocaml" => parseOcamlFile(Structure, filename) - | "reasonBinary" => parseReasonBinary(Structure, filename) - | _ => parseNapkinFile(~destination, Structure, filename) - } - - let parseInterface = (~destination, ~origin, filename) => - switch origin { - | "ml" | "ocaml" => parseOcamlFile(Signature, filename) - | "reasonBinary" => parseReasonBinary(Signature, filename) - | _ => parseNapkinFile(~destination, Signature, filename) - } - - let process = (~reportStyle, parseFn, printFn, recover, filename) => { - let (ast, report, parserState) = parseFn(filename) - switch report { - | Some(report) when recover == true => - printFn(ast, parserState) - prerr_string( - Diagnostics.stringOfReport( - ~style=Diagnostics.parseReportStyle(reportStyle), - report, - Bytes.to_string(parserState.Parser.scanner.src), - ), - ) - | Some(report) => - prerr_string( - Diagnostics.stringOfReport( - ~style=Diagnostics.parseReportStyle(reportStyle), - report, - Bytes.to_string(parserState.Parser.scanner.src), - ), - ) - exit(1) - | None => printFn(ast, parserState) - } - } - - type action = - | ProcessImplementation - | ProcessInterface - - let printImplementation = (~target, ~width, filename, ast, _parserState) => - switch target { - | "ml" | "ocaml" => Pprintast.structure(Format.std_formatter, ast) - | "ns" | "napkinscript" => - Printer.printImplementation(~width, ast, List.rev(_parserState.Parser.comments)) - | "ast" => Printast.implementation(Format.std_formatter, ast) - | "sexp" => ast |> SexpAst.implementation |> Sexp.toString |> print_string - | _ => - /* default binary */ - output_string(stdout, Config.ast_impl_magic_number) - output_value(stdout, filename) - output_value(stdout, ast) - } - - let printInterface = (~target, ~width, filename, ast, _parserState) => - switch target { - | "ml" | "ocaml" => Pprintast.signature(Format.std_formatter, ast) - | "ns" | "napkinscript" => - Printer.printInterface(~width, ast, List.rev(_parserState.Parser.comments)) - | "ast" => Printast.interface(Format.std_formatter, ast) - | "sexp" => ast |> SexpAst.interface |> Sexp.toString |> print_string - | _ => - /* default binary */ - output_string(stdout, Config.ast_intf_magic_number) - output_value(stdout, filename) - output_value(stdout, ast) - } - - let processFile = (~isInterface, ~width, ~recover, ~origin, ~target, ~report, filename) => - try { - let len = String.length(filename) - let action = if ( - isInterface || (len > 0 && (@doesNotRaise String.get)(filename, len - 1) == 'i') - ) { - ProcessInterface - } else { - ProcessImplementation - } - - switch action { - | ProcessImplementation => - process( - ~reportStyle=report, - parseImplementation(~origin, ~destination=target), - printImplementation(~target, ~width, filename), - recover, - filename, - ) - | ProcessInterface => - process( - ~reportStyle=report, - parseInterface(~origin, ~destination=target), - printInterface(~target, ~width, filename), - recover, - filename, - ) - } - } catch { - | Failure(txt) => - prerr_string(txt) - prerr_newline() - exit(1) - | _ => exit(1) - } -} - -let () = { - Clflags.parse() - if Clflags.outcome.contents { - Repl.typeAndPrintOutcome(List.hd(Clflags.files.contents)) - } else { - let () = switch Clflags.files.contents { - | list{_file, ..._} as files => - List.iter( - filename => - Driver.processFile( - ~isInterface=Clflags.interface.contents, - ~width=Clflags.width.contents, - ~recover=Clflags.recover.contents, - ~target=Clflags.print.contents, - ~origin=Clflags.origin.contents, - ~report=Clflags.report.contents, - filename, - ), - files, - ) - | list{} => - Driver.processFile( - ~isInterface=Clflags.interface.contents, - ~width=Clflags.width.contents, - ~recover=Clflags.recover.contents, - ~target=Clflags.print.contents, - ~origin=Clflags.origin.contents, - ~report=Clflags.report.contents, - "", - ) - } - - exit(0) - } -} diff --git a/jscomp/syntax/benchmarks/data/PrinterNapkin.ml b/jscomp/syntax/benchmarks/data/PrinterNapkin.ml deleted file mode 100644 index f9ce817..0000000 --- a/jscomp/syntax/benchmarks/data/PrinterNapkin.ml +++ /dev/null @@ -1,3501 +0,0 @@ -module Printer = { - type rec printer = { - src: bytes, - comments: CommentAst.t, - } - - let rec collectPatternsFromListConstruct = (acc, pattern) => - { - open Parsetree - switch pattern.ppat_desc { - | Ppat_construct( - {txt: Longident.Lident("::")}, - Some({ppat_desc: Ppat_tuple(list(pat, rest))}), - ) => - collectPatternsFromListConstruct(list(pat, ...acc), rest) - | _ => /List.rev(acc), pattern/ - } - } - - let addParens = doc => - Doc.group( - Doc.concat(list( - Doc.lparen, - Doc.indent(Doc.concat(list(Doc.softLine, doc))), - Doc.softLine, - Doc.rparen, - )), - ) - - let addBraces = doc => - Doc.group(Doc.concat(list(Doc.lbrace, doc, Doc.rbrace))) - - let interleaveWhitespace = ( - ~forceBreak=false, - rows: list, - ) => { - let rec loop = (prevLoc, acc, rows) => - switch rows { - | list() => Doc.concat(List.rev(acc)) - | list(/loc, doc/, ...rest) => - if ( - loc.Location.loc_start.pos_lnum - - prevLoc.Location.loc_end.pos_lnum > 1 - ) { - loop(loc, list(doc, Doc.line, Doc.line, ...acc), rest) - } else { - loop(loc, list(doc, Doc.line, ...acc), rest) - } - } - - switch rows { - | list() => Doc.nil - | list(/firstLoc, firstDoc/, ...rest) => - let forceBreak = - forceBreak || - switch List.rev(rest) { - | list(/lastLoc, _/, ..._) => - firstLoc.loc_start.pos_lnum !== lastLoc.loc_end.pos_lnum - | _ => false - } - - Doc.breakableGroup(~forceBreak, loop(firstLoc, list(firstDoc), rest)) - } - } - - let printLongident = l => - switch l { - | Longident.Lident(lident) => Doc.text(lident) - | Longident.Ldot(lident, txt) as l => - let txts = Longident.flatten(l) - Doc.join(~sep=Doc.dot, List.map(Doc.text, txts)) - | _ => failwith("unsupported ident") - } - - let escapeStringContents = s => { - let len = String.length(s) - let b = Buffer.create(len) - for i in 0 to len - 1 { - let c = String.get(s, i) - if c == '\b' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 'b') - } else if c == '\t' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 't') - } else if c == '\n' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 'n') - } else if c == '\r' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, 'r') - } else if c == '"' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '"') - } else if c == '\\' { - Buffer.add_char(b, '\\') - Buffer.add_char(b, '\\') - } else { - Buffer.add_char(b, c) - } - } - Buffer.contents(b) - } - - let printConstant = c => - switch c { - | Parsetree.Pconst_integer(s, _) => Doc.text(s) - | Pconst_string(s, _) => Doc.text("\"" ++ escapeStringContents(s) ++ "\"") - | Pconst_float(s, _) => Doc.text(s) - | Pconst_char(c) => Doc.text("'" ++ Char.escaped(c) ++ "'") - } - - let rec printStructure = (s: Parsetree.structure) => - interleaveWhitespace( - List.map(si => /si.Parsetree.pstr_loc, printStructureItem(si)/, s), - ) - - and printStructureItem = (si: Parsetree.structure_item) => - switch si.pstr_desc { - | Pstr_value(rec_flag, valueBindings) => - let recFlag = switch rec_flag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - printValueBindings(~recFlag, valueBindings) - | Pstr_type(recFlag, typeDeclarations) => - let recFlag = switch recFlag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - printTypeDeclarations(~recFlag, typeDeclarations) - | Pstr_primitive(valueDescription) => - printValueDescription(valueDescription) - | Pstr_eval(expr, attrs) => - let needsParens = switch expr { - | { - pexp_attributes: list(/{txt: "res.ternary"}, _/), - pexp_desc: Pexp_ifthenelse(_), - } => - false - | _ when ParsetreeViewer.hasAttributes(expr.pexp_attributes) => true - | _ => false - } - - let exprDoc = { - let doc = printExpression(expr) - if needsParens { - addParens(doc) - } else { - doc - } - } - - Doc.concat(list(printAttributes(attrs), exprDoc)) - | Pstr_attribute(attr) => - Doc.concat(list(Doc.text("@"), printAttribute(attr))) - | Pstr_extension(extension, attrs) => - Doc.concat(list( - printAttributes(attrs), - Doc.concat(list(Doc.text("%"), printExtension(extension))), - )) - | Pstr_include(includeDeclaration) => - printIncludeDeclaration(includeDeclaration) - | Pstr_open(openDescription) => printOpenDescription(openDescription) - | Pstr_modtype(modTypeDecl) => printModuleTypeDeclaration(modTypeDecl) - | Pstr_module(moduleBinding) => - printModuleBinding(~isRec=false, 0, moduleBinding) - | Pstr_recmodule(moduleBindings) => - Doc.join( - ~sep=Doc.line, - List.mapi( - (i, mb) => printModuleBinding(~isRec=true, i, mb), - moduleBindings, - ), - ) - | Pstr_exception(extensionConstructor) => - printExceptionDef(extensionConstructor) - | Pstr_typext(typeExtension) => printTypeExtension(typeExtension) - | Pstr_class(_) | Pstr_class_type(_) => Doc.nil - } - - and printTypeExtension = (te: Parsetree.type_extension) => { - let prefix = Doc.text("type ") - let name = printLongident(te.ptyext_path.txt) - let typeParams = switch te.ptyext_params { - | list() => Doc.nil - | typeParams => - Doc.group( - Doc.concat(list( - Doc.lessThan, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printTypeParam, typeParams), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.greaterThan, - )), - ) - } - - let extensionConstructors = { - let ecs = te.ptyext_constructors - let forceBreak = switch /ecs, List.rev(ecs)/ { - | /list(first, ..._), list(last, ..._)/ => - first.pext_loc.loc_start.pos_lnum > - te.ptyext_path.loc.loc_end.pos_lnum || - first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum - | _ => false - } - - let privateFlag = switch te.ptyext_private { - | Asttypes.Private => Doc.concat(list(Doc.text("private"), Doc.line)) - | Public => Doc.nil - } - - Doc.breakableGroup( - ~forceBreak, - Doc.indent( - Doc.concat(list( - Doc.line, - privateFlag, - Doc.join(~sep=Doc.line, List.mapi(printExtensionConstructor, ecs)), - )), - ), - ) - } - - Doc.group( - Doc.concat(list( - printAttributes(~loc=te.ptyext_path.loc, te.ptyext_attributes), - prefix, - name, - typeParams, - Doc.text(" +="), - extensionConstructors, - )), - ) - } - - and printModuleBinding = (~isRec, i, moduleBinding) => { - let prefix = if i == 0 { - Doc.concat(list( - Doc.text("module "), - if isRec { - Doc.text("rec ") - } else { - Doc.nil - }, - )) - } else { - Doc.text("and ") - } - - let /modExprDoc, modConstraintDoc/ = switch moduleBinding.pmb_expr { - | {pmod_desc: Pmod_constraint(modExpr, modType)} => - / - printModExpr(modExpr), - Doc.concat(list(Doc.text(": "), printModType(modType))), - / - | modExpr => /printModExpr(modExpr), Doc.nil/ - } - - Doc.concat(list( - printAttributes( - ~loc=moduleBinding.pmb_name.loc, - moduleBinding.pmb_attributes, - ), - prefix, - Doc.text(moduleBinding.pmb_name.Location.txt), - modConstraintDoc, - Doc.text(" = "), - modExprDoc, - )) - } - - and printModuleTypeDeclaration = ( - modTypeDecl: Parsetree.module_type_declaration, - ) => - Doc.concat(list( - printAttributes(modTypeDecl.pmtd_attributes), - Doc.text("module type "), - Doc.text(modTypeDecl.pmtd_name.txt), - switch modTypeDecl.pmtd_type { - | None => Doc.nil - | Some(modType) => - Doc.concat(list(Doc.text(" = "), printModType(modType))) - }, - )) - - and printModType = modType => { - let modTypeDoc = switch modType.pmty_desc { - | Parsetree.Pmty_ident({txt: longident, loc}) => - Doc.concat(list( - printAttributes(~loc, modType.pmty_attributes), - printLongident(longident), - )) - | Pmty_signature(signature) => - let signatureDoc = Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list( - Doc.lbrace, - Doc.indent(Doc.concat(list(Doc.line, printSignature(signature)))), - Doc.line, - Doc.rbrace, - )), - ) - Doc.concat(list(printAttributes(modType.pmty_attributes), signatureDoc)) - | Pmty_functor(_) => - let /parameters, returnType/ = ParsetreeViewer.functorType(modType) - let parametersDoc = switch parameters { - | list() => Doc.nil - | list(/attrs, {Location.txt: "_"}, Some(modType)/) => - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.line, - )) - } - Doc.concat(list(attrs, printModType(modType))) - | params => - Doc.group( - Doc.concat(list( - Doc.lparen, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map( - (/attrs, lbl, modType/) => { - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join( - ~sep=Doc.line, - List.map(printAttribute, attrs), - ), - Doc.line, - )) - } - Doc.concat(list( - attrs, - if lbl.Location.txt == "_" { - Doc.nil - } else { - Doc.text(lbl.txt) - }, - switch modType { - | None => Doc.nil - | Some(modType) => - Doc.concat(list( - if lbl.txt == "_" { - Doc.nil - } else { - Doc.text(": ") - }, - printModType(modType), - )) - }, - )) - }, - params, - ), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - )), - ) - } - - let returnDoc = { - let doc = printModType(returnType) - if Parens.modTypeFunctorReturn(returnType) { - addParens(doc) - } else { - doc - } - } - - Doc.group( - Doc.concat(list( - parametersDoc, - Doc.group(Doc.concat(list(Doc.text(" =>"), Doc.line, returnDoc))), - )), - ) - | Pmty_typeof(modExpr) => - Doc.concat(list(Doc.text("module type of "), printModExpr(modExpr))) - | Pmty_extension(extension) => printExtension(extension) - | Pmty_alias({txt: longident}) => - Doc.concat(list(Doc.text("module "), printLongident(longident))) - | Pmty_with(modType, withConstraints) => - let operand = { - let doc = printModType(modType) - if Parens.modTypeWithOperand(modType) { - addParens(doc) - } else { - doc - } - } - - Doc.group( - Doc.concat(list( - operand, - Doc.indent( - Doc.concat(list(Doc.line, printWithConstraints(withConstraints))), - ), - )), - ) - } - - let attrsAlreadyPrinted = switch modType.pmty_desc { - | (Pmty_functor(_) | Pmty_signature(_)) | Pmty_ident(_) => true - | _ => false - } - Doc.concat(list( - if attrsAlreadyPrinted { - Doc.nil - } else { - printAttributes(modType.pmty_attributes) - }, - modTypeDoc, - )) - } - - and printWithConstraints = withConstraints => { - let rows = List.mapi( - (i, withConstraint) => - Doc.group( - Doc.concat(list( - if i === 0 { - Doc.text("with ") - } else { - Doc.text("and ") - }, - printWithConstraint(withConstraint), - )), - ), - withConstraints, - ) - - Doc.join(~sep=Doc.line, rows) - } - - and printWithConstraint = (withConstraint: Parsetree.with_constraint) => - switch withConstraint { - | Pwith_type({txt: longident}, typeDeclaration) => - Doc.group( - printTypeDeclaration( - ~name=printLongident(longident), - ~equalSign="=", - ~recFlag=Doc.nil, - 0, - typeDeclaration, - ), - ) - | Pwith_module({txt: longident1}, {txt: longident2}) => - Doc.concat(list( - Doc.text("module "), - printLongident(longident1), - Doc.text(" ="), - Doc.indent(Doc.concat(list(Doc.line, printLongident(longident2)))), - )) - | Pwith_typesubst({txt: longident}, typeDeclaration) => - Doc.group( - printTypeDeclaration( - ~name=printLongident(longident), - ~equalSign=":=", - ~recFlag=Doc.nil, - 0, - typeDeclaration, - ), - ) - | Pwith_modsubst({txt: longident1}, {txt: longident2}) => - Doc.concat(list( - Doc.text("module "), - printLongident(longident1), - Doc.text(" :="), - Doc.indent(Doc.concat(list(Doc.line, printLongident(longident2)))), - )) - } - - and printSignature = signature => - interleaveWhitespace( - List.map( - si => /si.Parsetree.psig_loc, printSignatureItem(si)/, - signature, - ), - ) - - and printSignatureItem = (si: Parsetree.signature_item) => - switch si.psig_desc { - | Parsetree.Psig_value(valueDescription) => - printValueDescription(valueDescription) - | Psig_type(recFlag, typeDeclarations) => - let recFlag = switch recFlag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - printTypeDeclarations(~recFlag, typeDeclarations) - | Psig_typext(typeExtension) => printTypeExtension(typeExtension) - | Psig_exception(extensionConstructor) => - printExceptionDef(extensionConstructor) - | Psig_module(moduleDeclaration) => - printModuleDeclaration(moduleDeclaration) - | Psig_recmodule(moduleDeclarations) => - printRecModuleDeclarations(moduleDeclarations) - | Psig_modtype(modTypeDecl) => printModuleTypeDeclaration(modTypeDecl) - | Psig_open(openDescription) => printOpenDescription(openDescription) - | Psig_include(includeDescription) => - printIncludeDescription(includeDescription) - | Psig_attribute(attr) => - Doc.concat(list(Doc.text("@"), printAttribute(attr))) - | Psig_extension(extension, attrs) => - Doc.concat(list( - printAttributes(attrs), - Doc.concat(list(Doc.text("%"), printExtension(extension))), - )) - | Psig_class(_) | Psig_class_type(_) => Doc.nil - } - - and printRecModuleDeclarations = moduleDeclarations => - Doc.group( - Doc.join( - ~sep=Doc.line, - List.mapi( - (i, md: Parsetree.module_declaration) => { - let body = switch md.pmd_type.pmty_desc { - | Parsetree.Pmty_alias({txt: longident}) => - Doc.concat(list(Doc.text(" = "), printLongident(longident))) - | _ => - let needsParens = switch md.pmd_type.pmty_desc { - | Pmty_with(_) => true - | _ => false - } - - let modTypeDoc = { - let doc = printModType(md.pmd_type) - if needsParens { - addParens(doc) - } else { - doc - } - } - - Doc.concat(list(Doc.text(": "), modTypeDoc)) - } - - let prefix = if i < 1 { - "module rec " - } else { - "and " - } - Doc.concat(list( - printAttributes(~loc=md.pmd_name.loc, md.pmd_attributes), - Doc.text(prefix), - Doc.text(md.pmd_name.txt), - body, - )) - }, - moduleDeclarations, - ), - ), - ) - - and printModuleDeclaration = (md: Parsetree.module_declaration) => { - let body = switch md.pmd_type.pmty_desc { - | Parsetree.Pmty_alias({txt: longident}) => - Doc.concat(list(Doc.text(" = "), printLongident(longident))) - | _ => Doc.concat(list(Doc.text(": "), printModType(md.pmd_type))) - } - - Doc.concat(list( - printAttributes(~loc=md.pmd_name.loc, md.pmd_attributes), - Doc.text("module "), - Doc.text(md.pmd_name.txt), - body, - )) - } - - and printOpenDescription = (openDescription: Parsetree.open_description) => - Doc.concat(list( - printAttributes(openDescription.popen_attributes), - Doc.text("open"), - switch openDescription.popen_override { - | Asttypes.Fresh => Doc.space - | Asttypes.Override => Doc.text("! ") - }, - printLongident(openDescription.popen_lid.txt), - )) - - and printIncludeDescription = ( - includeDescription: Parsetree.include_description, - ) => - Doc.concat(list( - printAttributes(includeDescription.pincl_attributes), - Doc.text("include "), - printModType(includeDescription.pincl_mod), - )) - - and printIncludeDeclaration = ( - includeDeclaration: Parsetree.include_declaration, - ) => - Doc.concat(list( - printAttributes(includeDeclaration.pincl_attributes), - Doc.text("include "), - printModExpr(includeDeclaration.pincl_mod), - )) - - and printValueBindings = (~recFlag, vbs: list) => { - let rows = List.mapi( - (i, vb) => { - let doc = printValueBinding(~recFlag, i, vb) - /vb.Parsetree.pvb_loc, doc/ - }, - vbs, - ) - - interleaveWhitespace(rows) - } - - and printValueDescription = valueDescription => { - let isExternal = switch valueDescription.pval_prim { - | list() => false - | _ => true - } - - Doc.group( - Doc.concat(list( - Doc.text( - if isExternal { - "external " - } else { - "let " - }, - ), - Doc.text(valueDescription.pval_name.txt), - Doc.text(": "), - printTypExpr(valueDescription.pval_type), - if isExternal { - Doc.group( - Doc.concat(list( - Doc.text(" ="), - Doc.indent( - Doc.concat(list( - Doc.line, - Doc.join( - ~sep=Doc.line, - List.map( - s => - Doc.concat(list( - Doc.text("\""), - Doc.text(s), - Doc.text("\""), - )), - valueDescription.pval_prim, - ), - ), - )), - ), - )), - ) - } else { - Doc.nil - }, - )), - ) - } - - and printTypeDeclarations = (~recFlag, typeDeclarations) => { - let rows = List.mapi( - (i, td) => { - let doc = printTypeDeclaration( - ~name=Doc.text(td.Parsetree.ptype_name.txt), - ~equalSign="=", - ~recFlag, - i, - td, - ) - - /td.Parsetree.ptype_loc, doc/ - }, - typeDeclarations, - ) - interleaveWhitespace(rows) - } - - and printTypeDeclaration = ( - ~name, - ~equalSign, - ~recFlag, - i, - td: Parsetree.type_declaration, - ) => { - let attrs = printAttributes(~loc=td.ptype_loc, td.ptype_attributes) - let prefix = if i > 0 { - Doc.text("and ") - } else { - Doc.concat(list(Doc.text("type "), recFlag)) - } - - let typeName = name - let typeParams = switch td.ptype_params { - | list() => Doc.nil - | typeParams => - Doc.group( - Doc.concat(list( - Doc.lessThan, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printTypeParam, typeParams), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.greaterThan, - )), - ) - } - - let manifestAndKind = switch td.ptype_kind { - | Ptype_abstract => - switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list( - Doc.concat(list(Doc.space, Doc.text(equalSign), Doc.space)), - printPrivateFlag(td.ptype_private), - printTypExpr(typ), - )) - } - | Ptype_open => - Doc.concat(list( - Doc.concat(list(Doc.space, Doc.text(equalSign), Doc.space)), - printPrivateFlag(td.ptype_private), - Doc.text(".."), - )) - | Ptype_record(lds) => - let manifest = switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list( - Doc.concat(list(Doc.space, Doc.text(equalSign), Doc.space)), - printTypExpr(typ), - )) - } - - Doc.concat(list( - manifest, - Doc.concat(list(Doc.space, Doc.text(equalSign), Doc.space)), - printPrivateFlag(td.ptype_private), - printRecordDeclaration(lds), - )) - | Ptype_variant(cds) => - let manifest = switch td.ptype_manifest { - | None => Doc.nil - | Some(typ) => - Doc.concat(list( - Doc.concat(list(Doc.space, Doc.text(equalSign), Doc.space)), - printTypExpr(typ), - )) - } - - Doc.concat(list( - manifest, - Doc.concat(list(Doc.space, Doc.text(equalSign))), - printConstructorDeclarations(~privateFlag=td.ptype_private, cds), - )) - } - - let constraints = printTypeDefinitionConstraints(td.ptype_cstrs) - Doc.group( - Doc.concat(list( - attrs, - prefix, - typeName, - typeParams, - manifestAndKind, - constraints, - )), - ) - } - - and printTypeDefinitionConstraints = cstrs => - switch cstrs { - | list() => Doc.nil - | cstrs => - Doc.indent( - Doc.group( - Doc.concat(list( - Doc.line, - Doc.group( - Doc.join( - ~sep=Doc.line, - List.map(printTypeDefinitionConstraint, cstrs), - ), - ), - )), - ), - ) - } - - and printTypeDefinitionConstraint = ( - /typ1, typ2, _loc/: /Parsetree.core_type, Parsetree.core_type, Location.t/, - ) => - Doc.concat(list( - Doc.text("constraint "), - printTypExpr(typ1), - Doc.text(" = "), - printTypExpr(typ2), - )) - - and printPrivateFlag = (flag: Asttypes.private_flag) => - switch flag { - | Private => Doc.text("private ") - | Public => Doc.nil - } - - and printTypeParam = (param: /Parsetree.core_type, Asttypes.variance/) => { - let /typ, variance/ = param - let printedVariance = switch variance { - | Covariant => Doc.text("+") - | Contravariant => Doc.text("-") - | Invariant => Doc.nil - } - - Doc.concat(list(printedVariance, printTypExpr(typ))) - } - - and printRecordDeclaration = (lds: list) => { - let forceBreak = switch /lds, List.rev(lds)/ { - | /list(first, ..._), list(last, ..._)/ => - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum - | _ => false - } - - Doc.breakableGroup( - ~forceBreak, - Doc.concat(list( - Doc.lbrace, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printLabelDeclaration, lds), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - )), - ) - } - - and printConstructorDeclarations = ( - ~privateFlag, - cds: list, - ) => { - let forceBreak = switch /cds, List.rev(cds)/ { - | /list(first, ..._), list(last, ..._)/ => - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum - | _ => false - } - - let privateFlag = switch privateFlag { - | Asttypes.Private => Doc.concat(list(Doc.text("private"), Doc.line)) - | Public => Doc.nil - } - - Doc.breakableGroup( - ~forceBreak, - Doc.indent( - Doc.concat(list( - Doc.line, - privateFlag, - Doc.join(~sep=Doc.line, List.mapi(printConstructorDeclaration, cds)), - )), - ), - ) - } - - and printConstructorDeclaration = ( - i, - cd: Parsetree.constructor_declaration, - ) => { - let attrs = printAttributes(cd.pcd_attributes) - let bar = if i > 0 { - Doc.text("| ") - } else { - Doc.ifBreaks(Doc.text("| "), Doc.nil) - } - - let constrName = Doc.text(cd.pcd_name.txt) - let constrArgs = printConstructorArguments(cd.pcd_args) - let gadt = switch cd.pcd_res { - | None => Doc.nil - | Some(typ) => - Doc.indent(Doc.concat(list(Doc.text(": "), printTypExpr(typ)))) - } - - Doc.concat(list( - bar, - Doc.group(Doc.concat(list(attrs, constrName, constrArgs, gadt))), - )) - } - - and printConstructorArguments = (cdArgs: Parsetree.constructor_arguments) => - switch cdArgs { - | Pcstr_tuple(list()) => Doc.nil - | Pcstr_tuple(types) => - Doc.group( - Doc.indent( - Doc.concat(list( - Doc.lparen, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printTypExpr, types), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - )), - ), - ) - | Pcstr_record(lds) => - Doc.indent( - Doc.concat(list( - Doc.lparen, - Doc.lbrace, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printLabelDeclaration, lds), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - Doc.rparen, - )), - ) - } - - and printLabelDeclaration = (ld: Parsetree.label_declaration) => { - let attrs = printAttributes(~loc=ld.pld_name.loc, ld.pld_attributes) - let mutableFlag = switch ld.pld_mutable { - | Mutable => Doc.text("mutable ") - | Immutable => Doc.nil - } - - let name = Doc.text(ld.pld_name.txt) - Doc.group( - Doc.concat(list( - attrs, - mutableFlag, - name, - Doc.text(": "), - printTypExpr(ld.pld_type), - )), - ) - } - - and printTypExpr = (typExpr: Parsetree.core_type) => { - let renderedType = switch typExpr.ptyp_desc { - | Ptyp_any => Doc.text("_") - | Ptyp_var(var) => Doc.text("'" ++ var) - | Ptyp_extension(extension) => printExtension(extension) - | Ptyp_alias(typ, alias) => - let typ = { - let needsParens = switch typ.ptyp_desc { - | Ptyp_arrow(_) => true - | _ => false - } - - let doc = printTypExpr(typ) - if needsParens { - Doc.concat(list(Doc.lparen, doc, Doc.rparen)) - } else { - doc - } - } - - Doc.concat(list(typ, Doc.text(" as "), Doc.text("'" ++ alias))) - | Ptyp_constr( - {txt: Longident.Ldot(Longident.Lident("Js"), "t")}, - list(typ), - ) => - let bsObject = printTypExpr(typ) - switch typExpr.ptyp_attributes { - | list() => bsObject - | attrs => - Doc.concat(list( - Doc.group(Doc.join(~sep=Doc.line, List.map(printAttribute, attrs))), - Doc.space, - printTypExpr(typ), - )) - } - | Ptyp_constr( - longidentLoc, - list({ptyp_desc: Parsetree.Ptyp_tuple(tuple)}), - ) => - let constrName = printLongident(longidentLoc.txt) - Doc.group( - Doc.concat(list( - constrName, - Doc.lessThan, - printTupleType(~inline=true, tuple), - Doc.greaterThan, - )), - ) - | Ptyp_constr(longidentLoc, constrArgs) => - let constrName = printLongident(longidentLoc.txt) - switch constrArgs { - | list() => constrName - | list({ - Parsetree.ptyp_desc: - Ptyp_constr( - {txt: Longident.Ldot(Longident.Lident("Js"), "t")}, - list({ptyp_desc: Ptyp_object(fields, openFlag)}), - ), - }) => - Doc.concat(list( - constrName, - Doc.lessThan, - printBsObjectSugar(~inline=true, fields, openFlag), - Doc.greaterThan, - )) - | args => - Doc.group( - Doc.concat(list( - constrName, - Doc.lessThan, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printTypExpr, constrArgs), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.greaterThan, - )), - ) - } - | Ptyp_arrow(_) => - let /attrsBefore, args, returnType/ = ParsetreeViewer.arrowType(typExpr) - let returnTypeNeedsParens = switch returnType.ptyp_desc { - | Ptyp_alias(_) => true - | _ => false - } - - let returnDoc = { - let doc = printTypExpr(returnType) - if returnTypeNeedsParens { - Doc.concat(list(Doc.lparen, doc, Doc.rparen)) - } else { - doc - } - } - - let /isUncurried, attrs/ = ParsetreeViewer.processUncurriedAttribute( - attrsBefore, - ) - switch args { - | list() => Doc.nil - | list(/list(), Nolabel, n/) when !isUncurried => - let hasAttrsBefore = !(attrs == list()) - let attrs = if hasAttrsBefore { - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrsBefore)), - Doc.space, - )) - } else { - Doc.nil - } - - Doc.group( - Doc.concat(list( - Doc.group(attrs), - Doc.group( - if hasAttrsBefore { - Doc.concat(list( - Doc.lparen, - Doc.indent( - Doc.concat(list( - Doc.softLine, - printTypExpr(n), - Doc.text(" => "), - returnDoc, - )), - ), - Doc.softLine, - Doc.rparen, - )) - } else { - Doc.concat(list(printTypExpr(n), Doc.text(" => "), returnDoc)) - }, - ), - )), - ) - | args => - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.space, - )) - } - - let renderedArgs = Doc.concat(list( - attrs, - Doc.text("("), - Doc.indent( - Doc.concat(list( - Doc.softLine, - if isUncurried { - Doc.concat(list(Doc.dot, Doc.space)) - } else { - Doc.nil - }, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printTypeParameter, args), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.text(")"), - )) - Doc.group(Doc.concat(list(renderedArgs, Doc.text(" => "), returnDoc))) - } - | Ptyp_tuple(types) => printTupleType(~inline=false, types) - | Ptyp_object(fields, openFlag) => - printBsObjectSugar(~inline=false, fields, openFlag) - | Ptyp_poly(stringLocs, typ) => - Doc.concat(list( - Doc.join( - ~sep=Doc.space, - List.map(({Location.txt: txt}) => Doc.text("'" ++ txt), stringLocs), - ), - Doc.dot, - Doc.space, - printTypExpr(typ), - )) - | Ptyp_package(packageType) => - printPackageType(~printModuleKeywordAndParens=true, packageType) - | Ptyp_class(_) => failwith("classes are not supported in types") - | Ptyp_variant(_) => - failwith("Polymorphic variants currently not supported") - } - - let shouldPrintItsOwnAttributes = switch typExpr.ptyp_desc { - | Ptyp_arrow(_) - | Ptyp_constr({txt: Longident.Ldot(Longident.Lident("Js"), "t")}, _) => - true - | _ => false - } - - switch typExpr.ptyp_attributes { - | list(_, ..._) as attrs when !shouldPrintItsOwnAttributes => - Doc.group(Doc.concat(list(printAttributes(attrs), renderedType))) - | _ => renderedType - } - } - - and printBsObjectSugar = (~inline, fields, openFlag) => { - let flag = switch openFlag { - | Asttypes.Closed => Doc.nil - | Open => Doc.dotdot - } - - let doc = Doc.concat(list( - Doc.lbrace, - flag, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printObjectField, fields), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - )) - if inline { - doc - } else { - Doc.group(doc) - } - } - - and printTupleType = (~inline, types: list) => { - let tuple = Doc.concat(list( - Doc.text("/"), - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printTypExpr, types), - ), - )), - ), - Doc.softLine, - Doc.text("/"), - )) - - if inline === false { - Doc.group(tuple) - } else { - tuple - } - } - - and printObjectField = (field: Parsetree.object_field) => - switch field { - | Otag(labelLoc, attrs, typ) => - Doc.concat(list( - Doc.text("\"" ++ labelLoc.txt ++ "\""), - Doc.text(": "), - printTypExpr(typ), - )) - | _ => Doc.nil - } - - and printTypeParameter = (/attrs, lbl, typ/) => { - let /isUncurried, attrs/ = ParsetreeViewer.processUncurriedAttribute(attrs) - let uncurried = if isUncurried { - Doc.concat(list(Doc.dot, Doc.space)) - } else { - Doc.nil - } - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.line, - )) - } - let label = switch lbl { - | Asttypes.Nolabel => Doc.nil - | Labelled(lbl) => Doc.text("~" ++ lbl ++ ": ") - | Optional(lbl) => Doc.text("~" ++ lbl ++ ": ") - } - - let optionalIndicator = switch lbl { - | Asttypes.Nolabel | Labelled(_) => Doc.nil - | Optional(lbl) => Doc.text("=?") - } - - Doc.group( - Doc.concat(list( - uncurried, - attrs, - label, - printTypExpr(typ), - optionalIndicator, - )), - ) - } - - and printValueBinding = (~recFlag, i, vb) => { - let isGhost = ParsetreeViewer.isGhostUnitBinding(i, vb) - let header = if isGhost { - Doc.nil - } else if i === 0 { - Doc.concat(list(Doc.text("let "), recFlag)) - } else { - Doc.text("and ") - } - - let printedExpr = { - let exprDoc = printExpression(vb.pvb_expr) - let needsParens = switch vb.pvb_expr.pexp_desc { - | Pexp_constraint( - {pexp_desc: Pexp_pack(_)}, - {ptyp_desc: Ptyp_package(_)}, - ) => - false - | Pexp_constraint(_) => true - | _ => false - } - - if needsParens { - addParens(exprDoc) - } else { - exprDoc - } - } - - if isGhost { - printedExpr - } else { - let shouldIndent = - ParsetreeViewer.isBinaryExpression(vb.pvb_expr) || - switch vb.pvb_expr { - | { - pexp_attributes: list(/{Location.txt: "res.ternary"}, _/), - pexp_desc: Pexp_ifthenelse(ifExpr, _, _), - } => - ParsetreeViewer.isBinaryExpression(ifExpr) || - ParsetreeViewer.hasAttributes(ifExpr.pexp_attributes) - | {pexp_desc: Pexp_newtype(_)} => false - | e => - ParsetreeViewer.hasAttributes(e.pexp_attributes) || - ParsetreeViewer.isArrayAccess(e) - } - - Doc.concat(list( - printAttributes(~loc=vb.pvb_loc, vb.pvb_attributes), - header, - printPattern(vb.pvb_pat), - Doc.text(" ="), - if shouldIndent { - Doc.indent(Doc.concat(list(Doc.line, printedExpr))) - } else { - Doc.concat(list(Doc.space, printedExpr)) - }, - )) - } - } - - and printPackageType = ( - ~printModuleKeywordAndParens, - packageType: Parsetree.package_type, - ) => { - let doc = switch packageType { - | /longidentLoc, list()/ => - Doc.group(Doc.concat(list(printLongident(longidentLoc.txt)))) - | /longidentLoc, packageConstraints/ => - Doc.group( - Doc.concat(list( - printLongident(longidentLoc.txt), - printPackageConstraints(packageConstraints), - Doc.softLine, - )), - ) - } - - if printModuleKeywordAndParens { - Doc.concat(list(Doc.text("module("), doc, Doc.rparen)) - } else { - doc - } - } - - and printPackageConstraints = packageConstraints => - Doc.concat(list( - Doc.text(" with"), - Doc.indent( - Doc.concat(list( - Doc.line, - Doc.join( - ~sep=Doc.line, - List.mapi(printPackageconstraint, packageConstraints), - ), - )), - ), - )) - - and printPackageconstraint = (i, /longidentLoc, typ/) => { - let prefix = if i === 0 { - Doc.text("type ") - } else { - Doc.text("and type ") - } - Doc.concat(list( - prefix, - printLongident(longidentLoc.Location.txt), - Doc.text(" = "), - printTypExpr(typ), - )) - } - - and printExtension = (/stringLoc, payload/) => { - let extName = Doc.text("%" ++ stringLoc.Location.txt) - switch payload { - | PStr(list({pstr_desc: Pstr_eval(expr, attrs)})) => - let exprDoc = printExpression(expr) - let needsParens = switch attrs { - | list() => false - | _ => true - } - Doc.group( - Doc.concat(list( - extName, - addParens( - Doc.concat(list( - printAttributes(attrs), - if needsParens { - addParens(exprDoc) - } else { - exprDoc - }, - )), - ), - )), - ) - | _ => extName - } - } - - and printPattern = (p: Parsetree.pattern) => { - let patternWithoutAttributes = switch p.ppat_desc { - | Ppat_any => Doc.text("_") - | Ppat_var(stringLoc) => Doc.text(stringLoc.txt) - | Ppat_constant(c) => printConstant(c) - | Ppat_tuple(patterns) => - Doc.group( - Doc.concat(list( - Doc.text("/"), - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printPattern, patterns), - ), - )), - ), - Doc.softLine, - Doc.text("/"), - )), - ) - | Ppat_array(patterns) => - Doc.group( - Doc.concat(list( - Doc.text("["), - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printPattern, patterns), - ), - )), - ), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - Doc.text("]"), - )), - ) - | Ppat_construct({txt: Longident.Lident("[]")}, _) => Doc.text("list()") - | Ppat_construct({txt: Longident.Lident("::")}, _) => - let /patterns, tail/ = collectPatternsFromListConstruct(list(), p) - let shouldHug = switch /patterns, tail/ { - | / - list(pat), - {ppat_desc: Ppat_construct({txt: Longident.Lident("[]")}, _)} - / when ParsetreeViewer.isHuggablePattern(pat) => - true - | _ => false - } - - let children = Doc.concat(list( - if shouldHug { - Doc.nil - } else { - Doc.softLine - }, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printPattern, patterns), - ), - switch tail.Parsetree.ppat_desc { - | Ppat_construct({txt: Longident.Lident("[]")}, _) => Doc.nil - | _ => - Doc.concat(list( - Doc.text(","), - Doc.line, - Doc.text("..."), - printPattern(tail), - )) - }, - )) - Doc.group( - Doc.concat(list( - Doc.text("list("), - if shouldHug { - children - } else { - Doc.concat(list( - Doc.indent(children), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - )) - }, - Doc.text(")"), - )), - ) - | Ppat_construct(constrName, constructorArgs) => - let constrName = printLongident(constrName.txt) - switch constructorArgs { - | None => constrName - | Some(args) => - let args = switch args.ppat_desc { - | Ppat_construct({txt: Longident.Lident("()")}, None) => list(Doc.nil) - | Ppat_tuple(patterns) => List.map(printPattern, patterns) - | _ => list(printPattern(args)) - } - - Doc.group( - Doc.concat(list( - constrName, - Doc.text("("), - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join(~sep=Doc.concat(list(Doc.text(","), Doc.line)), args), - )), - ), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - Doc.text(")"), - )), - ) - } - | Ppat_record(rows, openFlag) => - Doc.group( - Doc.concat(list( - Doc.text("{"), - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printPatternRecordRow, rows), - ), - switch openFlag { - | Open => Doc.concat(list(Doc.text(","), Doc.line, Doc.text("_"))) - | Closed => Doc.nil - }, - )), - ), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - Doc.text("}"), - )), - ) - | Ppat_exception(p) => - let needsParens = switch p.ppat_desc { - | Ppat_or(_, _) | Ppat_alias(_, _) => true - | _ => false - } - - let pat = { - let p = printPattern(p) - if needsParens { - Doc.concat(list(Doc.text("("), p, Doc.text(")"))) - } else { - p - } - } - - Doc.group(Doc.concat(list(Doc.text("exception"), Doc.line, pat))) - | Ppat_or(p1, p2) => - let p1 = { - let p = printPattern(p1) - switch p1.ppat_desc { - | Ppat_or(_, _) => Doc.concat(list(Doc.text("("), p, Doc.text(")"))) - | _ => p - } - } - - let p2 = { - let p = printPattern(p2) - switch p2.ppat_desc { - | Ppat_or(_, _) => Doc.concat(list(Doc.text("("), p, Doc.text(")"))) - | _ => p - } - } - - Doc.group(Doc.concat(list(p1, Doc.line, Doc.text("| "), p2))) - | Ppat_extension(ext) => printExtension(ext) - | Ppat_lazy(p) => - let needsParens = switch p.ppat_desc { - | Ppat_or(_, _) | Ppat_alias(_, _) => true - | _ => false - } - - let pat = { - let p = printPattern(p) - if needsParens { - Doc.concat(list(Doc.text("("), p, Doc.text(")"))) - } else { - p - } - } - - Doc.concat(list(Doc.text("lazy "), pat)) - | Ppat_alias(p, aliasLoc) => - let needsParens = switch p.ppat_desc { - | Ppat_or(_, _) | Ppat_alias(_, _) => true - | _ => false - } - - let renderedPattern = { - let p = printPattern(p) - if needsParens { - Doc.concat(list(Doc.text("("), p, Doc.text(")"))) - } else { - p - } - } - - Doc.concat(list( - renderedPattern, - Doc.text(" as "), - Doc.text(aliasLoc.txt), - )) - | Ppat_constraint( - {ppat_desc: Ppat_unpack(stringLoc)}, - {ptyp_desc: Ptyp_package(packageType)}, - ) => - Doc.concat(list( - Doc.text("module("), - Doc.text(stringLoc.txt), - Doc.text(": "), - printPackageType(~printModuleKeywordAndParens=false, packageType), - Doc.rparen, - )) - | Ppat_constraint(pattern, typ) => - Doc.concat(list(printPattern(pattern), Doc.text(": "), printTypExpr(typ))) - | Ppat_unpack(stringLoc) => - Doc.concat(list(Doc.text("module("), Doc.text(stringLoc.txt), Doc.rparen)) - | _ => failwith("unsupported pattern") - } - - switch p.ppat_attributes { - | list() => patternWithoutAttributes - | attrs => - Doc.group( - Doc.concat(list(printAttributes(attrs), patternWithoutAttributes)), - ) - } - } - - and printPatternRecordRow = row => - switch row { - | / - {Location.txt: Longident.Lident(ident)}, - {Parsetree.ppat_desc: Ppat_var({txt, _})} - / when ident == txt => - Doc.text(ident) - | /longident, pattern/ => - Doc.group( - Doc.concat(list( - printLongident(longident.txt), - Doc.text(": "), - Doc.indent(Doc.concat(list(Doc.softLine, printPattern(pattern)))), - )), - ) - } - - and printExpression = (e: Parsetree.expression) => { - let printedExpression = switch e.pexp_desc { - | Parsetree.Pexp_constant(c) => printConstant(c) - | Pexp_construct(_) - when ParsetreeViewer.hasJsxAttribute(e.pexp_attributes) => - printJsxFragment(e) - | Pexp_construct({txt: Longident.Lident("()")}, _) => Doc.text("()") - | Pexp_construct({txt: Longident.Lident("[]")}, _) => Doc.text("list()") - | Pexp_construct({txt: Longident.Lident("::")}, _) => - let /expressions, spread/ = ParsetreeViewer.collectListExpressions(e) - let spreadDoc = switch spread { - | Some(expr) => - Doc.concat(list( - Doc.text(","), - Doc.line, - Doc.dotdotdot, - printExpression(expr), - )) - | None => Doc.nil - } - - Doc.group( - Doc.concat(list( - Doc.text("list("), - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printExpression, expressions), - ), - spreadDoc, - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - )), - ) - | Pexp_construct(longidentLoc, args) => - let constr = printLongident(longidentLoc.txt) - let args = switch args { - | None => Doc.nil - | Some({pexp_desc: Pexp_construct({txt: Longident.Lident("()")}, _)}) => - Doc.text("()") - | Some({pexp_desc: Pexp_tuple(args)}) => - Doc.concat(list( - Doc.lparen, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printExpression, args), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - )) - | Some(arg) => - let argDoc = printExpression(arg) - let shouldHug = ParsetreeViewer.isHuggableExpression(arg) - Doc.concat(list( - Doc.lparen, - if shouldHug { - argDoc - } else { - Doc.concat(list( - Doc.indent(Doc.concat(list(Doc.softLine, argDoc))), - Doc.trailingComma, - Doc.softLine, - )) - }, - Doc.rparen, - )) - } - - Doc.group(Doc.concat(list(constr, args))) - | Pexp_ident(longidentLoc) => printLongident(longidentLoc.txt) - | Pexp_tuple(exprs) => - Doc.group( - Doc.concat(list( - Doc.text("/"), - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printExpression, exprs), - ), - )), - ), - Doc.ifBreaks(Doc.text(","), Doc.nil), - Doc.softLine, - Doc.text("/"), - )), - ) - | Pexp_array(list()) => Doc.text("[]") - | Pexp_array(exprs) => - Doc.group( - Doc.concat(list( - Doc.lbracket, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printExpression, exprs), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbracket, - )), - ) - | Pexp_record(rows, spreadExpr) => - let spread = switch spreadExpr { - | None => Doc.nil - | Some(expr) => - Doc.concat(list( - Doc.dotdotdot, - printExpression(expr), - Doc.comma, - Doc.line, - )) - } - - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - - Doc.breakableGroup( - ~forceBreak, - Doc.concat(list( - Doc.lbrace, - Doc.indent( - Doc.concat(list( - Doc.softLine, - spread, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printRecordRow, rows), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - )), - ) - | Pexp_extension(extension) => - switch extension { - | / - {txt: "bs.obj"}, - PStr( - list({ - pstr_loc: loc, - pstr_desc: Pstr_eval({pexp_desc: Pexp_record(rows, _)}, list()), - }), - ) - / => - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum - - Doc.breakableGroup( - ~forceBreak, - Doc.concat(list( - Doc.lbrace, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.text(","), Doc.line)), - List.map(printBsObjectRow, rows), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rbrace, - )), - ) - | extension => printExtension(extension) - } - | Pexp_apply(_) => - if ParsetreeViewer.isUnaryExpression(e) { - printUnaryExpression(e) - } else if ParsetreeViewer.isBinaryExpression(e) { - printBinaryExpression(e) - } else { - printPexpApply(e) - } - | Pexp_unreachable => Doc.dot - | Pexp_field(expr, longidentLoc) => - let lhs = { - let doc = printExpression(expr) - if Parens.fieldExpr(expr) { - addParens(doc) - } else { - doc - } - } - - Doc.concat(list(lhs, Doc.dot, printLongident(longidentLoc.txt))) - | Pexp_setfield(expr1, longidentLoc, expr2) => - printSetFieldExpr(e.pexp_attributes, expr1, longidentLoc, expr2) - | Pexp_ifthenelse(ifExpr, thenExpr, elseExpr) => - if ParsetreeViewer.isTernaryExpr(e) { - let /parts, alternate/ = ParsetreeViewer.collectTernaryParts(e) - let ternaryDoc = switch parts { - | list(/condition1, consequent1/, ...rest) => - Doc.group( - Doc.concat(list( - printTernaryOperand(condition1), - Doc.indent( - Doc.concat(list( - Doc.line, - Doc.indent( - Doc.concat(list( - Doc.text("? "), - printTernaryOperand(consequent1), - )), - ), - Doc.concat( - List.map( - (/condition, consequent/) => - Doc.concat(list( - Doc.line, - Doc.text(": "), - printTernaryOperand(condition), - Doc.line, - Doc.text("? "), - printTernaryOperand(consequent), - )), - rest, - ), - ), - Doc.line, - Doc.text(": "), - Doc.indent(printTernaryOperand(alternate)), - )), - ), - )), - ) - | _ => Doc.nil - } - - let attrs = ParsetreeViewer.filterTernaryAttributes(e.pexp_attributes) - let needsParens = switch attrs { - | list() => false - | _ => true - } - Doc.concat(list( - printAttributes(attrs), - if needsParens { - addParens(ternaryDoc) - } else { - ternaryDoc - }, - )) - } else { - let /ifs, elseExpr/ = ParsetreeViewer.collectIfExpressions(e) - let ifDocs = Doc.join( - ~sep=Doc.space, - List.mapi( - (i, /ifExpr, thenExpr/) => { - let ifTxt = if i > 0 { - Doc.text("else if ") - } else { - Doc.text("if ") - } - let condition = printExpression(ifExpr) - Doc.concat(list( - ifTxt, - Doc.group(Doc.ifBreaks(addParens(condition), condition)), - Doc.space, - printExpressionBlock(~braces=true, thenExpr), - )) - }, - ifs, - ), - ) - let elseDoc = switch elseExpr { - | None => Doc.nil - | Some(expr) => - Doc.concat(list( - Doc.text(" else "), - printExpressionBlock(~braces=true, expr), - )) - } - - Doc.concat(list(printAttributes(e.pexp_attributes), ifDocs, elseDoc)) - } - | Pexp_while(expr1, expr2) => - let condition = printExpression(expr1) - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list( - Doc.text("while "), - Doc.group(Doc.ifBreaks(addParens(condition), condition)), - Doc.space, - printExpressionBlock(~braces=true, expr2), - )), - ) - | Pexp_for(pattern, fromExpr, toExpr, directionFlag, body) => - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list( - Doc.text("for "), - printPattern(pattern), - Doc.text(" in "), - printExpression(fromExpr), - printDirectionFlag(directionFlag), - printExpression(toExpr), - Doc.space, - printExpressionBlock(~braces=true, body), - )), - ) - | Pexp_constraint( - {pexp_desc: Pexp_pack(modExpr)}, - {ptyp_desc: Ptyp_package(packageType)}, - ) => - Doc.group( - Doc.concat(list( - Doc.text("module("), - Doc.indent( - Doc.concat(list( - Doc.softLine, - printModExpr(modExpr), - Doc.text(": "), - printPackageType(~printModuleKeywordAndParens=false, packageType), - )), - ), - Doc.softLine, - Doc.rparen, - )), - ) - | Pexp_constraint(expr, typ) => - Doc.concat(list(printExpression(expr), Doc.text(": "), printTypExpr(typ))) - | Pexp_letmodule({txt: modName}, modExpr, expr) => - printExpressionBlock(~braces=true, e) - | Pexp_letexception(extensionConstructor, expr) => - printExpressionBlock(~braces=true, e) - | Pexp_assert(expr) => - let rhs = { - let doc = printExpression(expr) - if Parens.lazyOrAssertExprRhs(expr) { - addParens(doc) - } else { - doc - } - } - - Doc.concat(list(Doc.text("assert "), rhs)) - | Pexp_lazy(expr) => - let rhs = { - let doc = printExpression(expr) - if Parens.lazyOrAssertExprRhs(expr) { - addParens(doc) - } else { - doc - } - } - - Doc.concat(list(Doc.text("lazy "), rhs)) - | Pexp_open(overrideFlag, longidentLoc, expr) => - printExpressionBlock(~braces=true, e) - | Pexp_pack(modExpr) => - Doc.group( - Doc.concat(list( - Doc.text("module("), - Doc.indent(Doc.concat(list(Doc.softLine, printModExpr(modExpr)))), - Doc.softLine, - Doc.rparen, - )), - ) - | Pexp_sequence(_) => printExpressionBlock(~braces=true, e) - | Pexp_let(_) => printExpressionBlock(~braces=true, e) - | Pexp_fun(_) | Pexp_newtype(_) => - let /attrsOnArrow, parameters, returnExpr/ = ParsetreeViewer.funExpr(e) - let /uncurried, attrs/ = ParsetreeViewer.processUncurriedAttribute( - attrsOnArrow, - ) - - let /returnExpr, typConstraint/ = switch returnExpr.pexp_desc { - | Pexp_constraint(expr, typ) => /expr, Some(typ)/ - | _ => /returnExpr, None/ - } - - let parametersDoc = printExprFunParameters( - ~inCallback=false, - ~uncurried, - parameters, - ) - let returnExprDoc = { - let shouldInline = switch returnExpr.pexp_desc { - | ((Pexp_array(_) | Pexp_tuple(_)) | Pexp_construct(_, Some(_))) - | Pexp_record(_) => - true - | _ => false - } - - let shouldIndent = switch returnExpr.pexp_desc { - | ((Pexp_sequence(_) | Pexp_let(_)) | Pexp_letmodule(_)) - | Pexp_letexception(_) => - false - | _ => true - } - - let returnDoc = printExpression(returnExpr) - if shouldInline { - Doc.concat(list(Doc.space, returnDoc)) - } else { - Doc.group( - if shouldIndent { - Doc.indent(Doc.concat(list(Doc.line, returnDoc))) - } else { - Doc.concat(list(Doc.space, returnDoc)) - }, - ) - } - } - - let typConstraintDoc = switch typConstraint { - | Some(typ) => Doc.concat(list(Doc.text(": "), printTypExpr(typ))) - | _ => Doc.nil - } - - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.space, - )) - } - - Doc.group( - Doc.concat(list( - attrs, - parametersDoc, - typConstraintDoc, - Doc.text(" =>"), - returnExprDoc, - )), - ) - | Pexp_try(expr, cases) => - Doc.concat(list( - Doc.text("try "), - printExpression(expr), - Doc.text(" catch "), - printCases(cases), - )) - | Pexp_match(expr, cases) => - Doc.concat(list( - Doc.text("switch "), - printExpression(expr), - Doc.space, - printCases(cases), - )) - | _ => failwith("expression not yet implemented in printer") - } - - let shouldPrintItsOwnAttributes = switch e.pexp_desc { - | (((Pexp_apply(_) | Pexp_fun(_)) | Pexp_newtype(_)) | Pexp_setfield(_)) - | Pexp_ifthenelse(_) => - true - | Pexp_construct(_) - when ParsetreeViewer.hasJsxAttribute(e.pexp_attributes) => - true - | _ => false - } - - switch e.pexp_attributes { - | list() => printedExpression - | attrs when !shouldPrintItsOwnAttributes => - Doc.group(Doc.concat(list(printAttributes(attrs), printedExpression))) - | _ => printedExpression - } - } - - and printPexpFun = (~inCallback, e) => { - let /attrsOnArrow, parameters, returnExpr/ = ParsetreeViewer.funExpr(e) - let /uncurried, attrs/ = ParsetreeViewer.processUncurriedAttribute( - attrsOnArrow, - ) - - let /returnExpr, typConstraint/ = switch returnExpr.pexp_desc { - | Pexp_constraint(expr, typ) => /expr, Some(typ)/ - | _ => /returnExpr, None/ - } - - let parametersDoc = printExprFunParameters( - ~inCallback, - ~uncurried, - parameters, - ) - let returnShouldIndent = switch returnExpr.pexp_desc { - | ((Pexp_sequence(_) | Pexp_let(_)) | Pexp_letmodule(_)) - | Pexp_letexception(_) => - false - | _ => true - } - - let returnExprDoc = { - let shouldInline = switch returnExpr.pexp_desc { - | ((Pexp_array(_) | Pexp_tuple(_)) | Pexp_construct(_, Some(_))) - | Pexp_record(_) => - true - | _ => false - } - - let returnDoc = printExpression(returnExpr) - if shouldInline { - Doc.concat(list(Doc.space, returnDoc)) - } else { - Doc.group( - if returnShouldIndent { - Doc.concat(list( - Doc.indent(Doc.concat(list(Doc.line, returnDoc))), - if inCallback { - Doc.softLine - } else { - Doc.nil - }, - )) - } else { - Doc.concat(list(Doc.space, returnDoc)) - }, - ) - } - } - - let typConstraintDoc = switch typConstraint { - | Some(typ) => Doc.concat(list(Doc.text(": "), printTypExpr(typ))) - | _ => Doc.nil - } - - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.space, - )) - } - - Doc.group( - Doc.concat(list( - attrs, - parametersDoc, - typConstraintDoc, - Doc.text(" =>"), - returnExprDoc, - )), - ) - } - - and printTernaryOperand = expr => { - let doc = printExpression(expr) - if Parens.ternaryOperand(expr) { - addParens(doc) - } else { - doc - } - } - - and printSetFieldExpr = (attrs, lhs, longidentLoc, rhs) => { - let rhsDoc = { - let doc = printExpression(rhs) - if Parens.setFieldExprRhs(rhs) { - addParens(doc) - } else { - doc - } - } - - let lhsDoc = { - let doc = printExpression(lhs) - if Parens.fieldExpr(lhs) { - addParens(doc) - } else { - doc - } - } - - let shouldIndent = ParsetreeViewer.isBinaryExpression(rhs) - let doc = Doc.concat(list( - lhsDoc, - Doc.dot, - printLongident(longidentLoc.txt), - Doc.text(" ="), - if shouldIndent { - Doc.group(Doc.indent(Doc.concat(list(Doc.line, rhsDoc)))) - } else { - Doc.concat(list(Doc.space, rhsDoc)) - }, - )) - switch attrs { - | list() => doc - | attrs => Doc.group(Doc.concat(list(printAttributes(attrs), doc))) - } - } - - and printUnaryExpression = expr => { - let printUnaryOperator = op => - Doc.text( - switch op { - | "~+" => "+" - | "~+." => "+." - | "~-" => "-" - | "~-." => "-." - | "not" => "!" - | "!" => "&" - | _ => assert false - }, - ) - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list(/Nolabel, operand/), - ) => - let printedOperand = { - let doc = printExpression(operand) - if Parens.unaryExprOperand(operand) { - addParens(doc) - } else { - doc - } - } - - Doc.concat(list(printUnaryOperator(operator), printedOperand)) - | _ => assert false - } - } - - and printBinaryExpression = (expr: Parsetree.expression) => { - let printBinaryOperator = (~inlineRhs, operator) => { - let operatorTxt = switch operator { - | "|." => "->" - | "^" => "++" - | "=" => "==" - | "==" => "===" - | "<>" => "!=" - | "!=" => "!==" - | txt => txt - } - - let spacingBeforeOperator = if operator == "|." { - Doc.softLine - } else if operator == "|>" { - Doc.line - } else { - Doc.space - } - - let spacingAfterOperator = if operator == "|." { - Doc.nil - } else if operator == "|>" { - Doc.space - } else if inlineRhs { - Doc.space - } else { - Doc.line - } - - Doc.concat(list( - spacingBeforeOperator, - Doc.text(operatorTxt), - spacingAfterOperator, - )) - } - - let printOperand = (~isLhs, expr, parentOperator) => { - let rec flatten = (~isLhs, expr, parentOperator) => - if ParsetreeViewer.isBinaryExpression(expr) { - switch expr { - | { - pexp_desc: - Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list(/_, left/, /_, right/), - ), - } => - if ( - ParsetreeViewer.flattenableOperators(parentOperator, operator) && - !ParsetreeViewer.hasAttributes(expr.pexp_attributes) - ) { - let leftPrinted = flatten(~isLhs=true, left, operator) - let rightPrinted = { - let / - _, - rightAttrs - / = ParsetreeViewer.partitionPrinteableAttributes( - right.pexp_attributes, - ) - - let doc = printExpression({ - ...right, - pexp_attributes: rightAttrs, - }) - let doc = if Parens.flattenOperandRhs(parentOperator, right) { - Doc.concat(list(Doc.lparen, doc, Doc.rparen)) - } else { - doc - } - - let printeableAttrs = ParsetreeViewer.filterPrinteableAttributes( - right.pexp_attributes, - ) - - Doc.concat(list(printAttributes(printeableAttrs), doc)) - } - - Doc.concat(list( - leftPrinted, - printBinaryOperator(~inlineRhs=false, operator), - rightPrinted, - )) - } else { - let doc = printExpression({...expr, pexp_attributes: list()}) - let doc = if ( - Parens.subBinaryExprOperand(parentOperator, operator) || - ((expr.pexp_attributes != list()) && - (ParsetreeViewer.isBinaryExpression(expr) || - ParsetreeViewer.isTernaryExpr(expr))) - ) { - Doc.concat(list(Doc.lparen, doc, Doc.rparen)) - } else { - doc - } - Doc.concat(list(printAttributes(expr.pexp_attributes), doc)) - } - | _ => assert false - } - } else { - switch expr.pexp_desc { - | Pexp_setfield(lhs, field, rhs) => - let doc = printSetFieldExpr(expr.pexp_attributes, lhs, field, rhs) - if isLhs { - addParens(doc) - } else { - doc - } - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("#=")})}, - list(/Nolabel, lhs/, /Nolabel, rhs/), - ) => - let rhsDoc = printExpression(rhs) - let lhsDoc = printExpression(lhs) - - let shouldIndent = ParsetreeViewer.isBinaryExpression(rhs) - let doc = Doc.group( - Doc.concat(list( - lhsDoc, - Doc.text(" ="), - if shouldIndent { - Doc.group(Doc.indent(Doc.concat(list(Doc.line, rhsDoc)))) - } else { - Doc.concat(list(Doc.space, rhsDoc)) - }, - )), - ) - let doc = switch expr.pexp_attributes { - | list() => doc - | attrs => Doc.group(Doc.concat(list(printAttributes(attrs), doc))) - } - - if isLhs { - addParens(doc) - } else { - doc - } - | _ => - let doc = printExpression(expr) - if Parens.binaryExprOperand(~isLhs, expr, parentOperator) { - addParens(doc) - } else { - doc - } - } - } - - flatten(~isLhs, expr, parentOperator) - } - - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(("|." | "|>") as op)})}, - list(/Nolabel, lhs/, /Nolabel, rhs/), - ) - when !( - ParsetreeViewer.isBinaryExpression(lhs) || - ParsetreeViewer.isBinaryExpression(rhs) - ) => - let lhsDoc = printOperand(~isLhs=true, lhs, op) - let rhsDoc = printOperand(~isLhs=false, rhs, op) - Doc.concat(list( - lhsDoc, - switch op { - | "|." => Doc.text("->") - | "|>" => Doc.text(" |> ") - | _ => assert false - }, - rhsDoc, - )) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident(operator)})}, - list(/Nolabel, lhs/, /Nolabel, rhs/), - ) => - let right = { - let operatorWithRhs = Doc.concat(list( - printBinaryOperator( - ~inlineRhs=ParsetreeViewer.shouldInlineRhsBinaryExpr(rhs), - operator, - ), - printOperand(~isLhs=false, rhs, operator), - )) - if ParsetreeViewer.shouldIndentBinaryExpr(expr) { - Doc.group(Doc.indent(operatorWithRhs)) - } else { - operatorWithRhs - } - } - - let doc = Doc.group( - Doc.concat(list(printOperand(~isLhs=true, lhs, operator), right)), - ) - Doc.concat(list( - printAttributes(expr.pexp_attributes), - if Parens.binaryExpr(expr) { - addParens(doc) - } else { - doc - }, - )) - | _ => Doc.nil - } - } - - and printPexpApply = expr => - switch expr.pexp_desc { - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("##")})}, - list(/Nolabel, parentExpr/, /Nolabel, memberExpr/), - ) => - let member = { - let memberDoc = printExpression(memberExpr) - Doc.concat(list(Doc.text("\""), memberDoc, Doc.text("\""))) - } - - Doc.group( - Doc.concat(list( - printAttributes(expr.pexp_attributes), - printExpression(parentExpr), - Doc.lbracket, - member, - Doc.rbracket, - )), - ) - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Lident("#=")})}, - list(/Nolabel, lhs/, /Nolabel, rhs/), - ) => - let rhsDoc = printExpression(rhs) - - let shouldIndent = ParsetreeViewer.isBinaryExpression(rhs) - let doc = Doc.group( - Doc.concat(list( - printExpression(lhs), - Doc.text(" ="), - if shouldIndent { - Doc.group(Doc.indent(Doc.concat(list(Doc.line, rhsDoc)))) - } else { - Doc.concat(list(Doc.space, rhsDoc)) - }, - )), - ) - switch expr.pexp_attributes { - | list() => doc - | attrs => Doc.group(Doc.concat(list(printAttributes(attrs), doc))) - } - | Pexp_apply( - {pexp_desc: Pexp_ident({txt: Longident.Ldot(Lident("Array"), "get")})}, - list(/Nolabel, parentExpr/, /Nolabel, memberExpr/), - ) => - let member = { - let memberDoc = printExpression(memberExpr) - let shouldInline = switch memberExpr.pexp_desc { - | Pexp_constant(_) | Pexp_ident(_) => true - | _ => false - } - - if shouldInline { - memberDoc - } else { - Doc.concat(list( - Doc.indent(Doc.concat(list(Doc.softLine, memberDoc))), - Doc.softLine, - )) - } - } - - Doc.group( - Doc.concat(list( - printAttributes(expr.pexp_attributes), - printExpression(parentExpr), - Doc.lbracket, - member, - Doc.rbracket, - )), - ) - | Pexp_apply({pexp_desc: Pexp_ident({txt: lident})}, args) - when ParsetreeViewer.isJsxExpression(expr) => - printJsxExpression(lident, args) - | Pexp_apply(callExpr, args) => - let /uncurried, attrs/ = ParsetreeViewer.processUncurriedAttribute( - expr.pexp_attributes, - ) - - let callExprDoc = printExpression(callExpr) - if ParsetreeViewer.requiresSpecialCallbackPrinting(args) { - let argsDoc = printArgumentsWithCallback(~uncurried, args) - Doc.concat(list(printAttributes(attrs), callExprDoc, argsDoc)) - } else { - let argsDoc = printArguments(~uncurried, args) - Doc.concat(list(printAttributes(attrs), callExprDoc, argsDoc)) - } - | _ => assert false - } - - and printJsxExpression = (lident, args) => { - let name = printJsxName(lident) - let /formattedProps, children/ = formatJsxProps(args) - - let isSelfClosing = switch children { - | list() => true - | _ => false - } - Doc.group( - Doc.concat(list( - Doc.group( - Doc.concat(list( - Doc.lessThan, - name, - formattedProps, - if isSelfClosing { - Doc.concat(list(Doc.line, Doc.text("/>"))) - } else { - Doc.nil - }, - )), - ), - if isSelfClosing { - Doc.nil - } else { - Doc.concat(list( - Doc.greaterThan, - Doc.indent(Doc.concat(list(Doc.line, printJsxChildren(children)))), - Doc.line, - Doc.text(" { - let opening = Doc.text("<>") - let closing = Doc.text("") - let /children, _/ = ParsetreeViewer.collectListExpressions(expr) - Doc.group( - Doc.concat(list( - opening, - switch children { - | list() => Doc.nil - | children => - Doc.indent(Doc.concat(list(Doc.line, printJsxChildren(children)))) - }, - Doc.line, - closing, - )), - ) - } - - and printJsxChildren = (children: list) => - Doc.group( - Doc.join( - ~sep=Doc.line, - List.map( - expr => { - let exprDoc = printExpression(expr) - if Parens.jsxChildExpr(expr) { - addBraces(exprDoc) - } else { - exprDoc - } - }, - children, - ), - ), - ) - - and formatJsxProps = args => { - let rec loop = (props, args) => - switch args { - | list() => /Doc.nil, list()/ - | list( - /Asttypes.Labelled("children"), children/, - / - Asttypes.Nolabel, - { - Parsetree.pexp_desc: - Pexp_construct({txt: Longident.Lident("()")}, None), - } - /, - ) => - let formattedProps = Doc.indent( - switch props { - | list() => Doc.nil - | props => - Doc.concat(list( - Doc.line, - Doc.group(Doc.join(~sep=Doc.line, props |> List.rev)), - )) - }, - ) - let /children, _/ = ParsetreeViewer.collectListExpressions(children) - /formattedProps, children/ - | list(arg, ...args) => - let propDoc = formatJsxProp(arg) - loop(list(propDoc, ...props), args) - } - - loop(list(), args) - } - - and formatJsxProp = arg => - switch arg { - | / - (Asttypes.Labelled(lblTxt) | Optional(lblTxt)) as lbl, - { - Parsetree.pexp_attributes: list(), - pexp_desc: Pexp_ident({txt: Longident.Lident(ident)}), - } - / when lblTxt == ident => - switch lbl { - | Nolabel => Doc.nil - | Labelled(lbl) => Doc.text(lbl) - | Optional(lbl) => Doc.text("?" ++ lbl) - } - | /lbl, expr/ => - let lblDoc = switch lbl { - | Asttypes.Labelled(lbl) => Doc.text(lbl ++ "=") - | Asttypes.Optional(lbl) => Doc.text(lbl ++ "=?") - | Nolabel => Doc.nil - } - - let exprDoc = printExpression(expr) - Doc.concat(list( - lblDoc, - if Parens.jsxPropExpr(expr) { - addBraces(exprDoc) - } else { - exprDoc - }, - )) - } - - and printJsxName = lident => { - let rec flatten = (acc, lident) => - switch lident { - | Longident.Lident(txt) => list(txt, ...acc) - | Ldot(lident, txt) => - let acc = if txt == "createElement" { - acc - } else { - list(txt, ...acc) - } - flatten(acc, lident) - | _ => acc - } - - switch lident { - | Longident.Lident(txt) => Doc.text(txt) - | _ as lident => - let segments = flatten(list(), lident) - Doc.join(~sep=Doc.dot, List.map(Doc.text, segments)) - } - } - - and printArgumentsWithCallback = (~uncurried, args) => { - let rec loop = (acc, args) => - switch args { - | list() => /Doc.nil, Doc.nil/ - | list(/_lbl, expr/) => - let callback = printPexpFun(~inCallback=true, expr) - /Doc.concat(List.rev(acc)), callback/ - | list(arg, ...args) => - let argDoc = printArgument(arg) - loop(list(Doc.line, Doc.comma, argDoc, ...acc), args) - } - - let /printedArgs, callback/ = loop(list(), args) - - let fitsOnOneLine = Doc.concat(list( - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - Doc.concat(list(printedArgs, callback)), - Doc.rparen, - )) - - let arugmentsFitOnOneLine = Doc.concat(list( - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - Doc.concat(list( - Doc.softLine, - printedArgs, - Doc.breakableGroup(~forceBreak=true, callback), - )), - Doc.softLine, - Doc.rparen, - )) - - let breakAllArgs = printArguments(~uncurried, args) - Doc.customLayout(list(fitsOnOneLine, arugmentsFitOnOneLine, breakAllArgs)) - } - - and printArguments = ( - ~uncurried, - args: list, - ) => - switch args { - | list(/ - Nolabel, - {pexp_desc: Pexp_construct({txt: Longident.Lident("()")}, _)} - /) => - if uncurried { - Doc.text("(.)") - } else { - Doc.text("()") - } - | list(/Nolabel, arg/) when ParsetreeViewer.isHuggableExpression(arg) => - Doc.concat(list( - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - printExpression(arg), - Doc.rparen, - )) - | args => - Doc.group( - Doc.concat(list( - if uncurried { - Doc.text("(.") - } else { - Doc.lparen - }, - Doc.indent( - Doc.concat(list( - if uncurried { - Doc.line - } else { - Doc.softLine - }, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printArgument, args), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - )), - ) - } - - and printArgument = ( - /argLbl, arg/: /Asttypes.arg_label, Parsetree.expression/, - ) => - switch /argLbl, arg/ { - | / - Asttypes.Labelled(lbl), - {pexp_desc: Pexp_ident({txt: Longident.Lident(name)})} - / when lbl == name => - Doc.text("~" ++ lbl) - | / - Asttypes.Optional(lbl), - {pexp_desc: Pexp_ident({txt: Longident.Lident(name)})} - / when lbl == name => - Doc.text("~" ++ lbl ++ "?") - | /lbl, expr/ => - let printedLbl = switch argLbl { - | Asttypes.Nolabel => Doc.nil - | Asttypes.Labelled(lbl) => Doc.text("~" ++ lbl ++ "=") - | Asttypes.Optional(lbl) => Doc.text("~" ++ lbl ++ "=?") - } - - let printedExpr = printExpression(expr) - Doc.concat(list(printedLbl, printedExpr)) - } - - and printCases = (cases: list) => - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list( - Doc.lbrace, - Doc.concat(list( - Doc.line, - Doc.join(~sep=Doc.line, List.map(printCase, cases)), - )), - Doc.line, - Doc.rbrace, - )), - ) - - and printCase = (case: Parsetree.case) => { - let rhs = switch case.pc_rhs.pexp_desc { - | (((Pexp_let(_) | Pexp_letmodule(_)) | Pexp_letexception(_)) - | Pexp_open(_)) - | Pexp_sequence(_) => - printExpressionBlock(~braces=false, case.pc_rhs) - | _ => printExpression(case.pc_rhs) - } - - let guard = switch case.pc_guard { - | None => Doc.nil - | Some(expr) => - Doc.group( - Doc.concat(list(Doc.line, Doc.text("when "), printExpression(expr))), - ) - } - - Doc.group( - Doc.concat(list( - Doc.text("| "), - Doc.indent( - Doc.concat(list( - printPattern(case.pc_lhs), - guard, - Doc.text(" =>"), - Doc.line, - rhs, - )), - ), - )), - ) - } - - and printExprFunParameters = (~inCallback, ~uncurried, parameters) => - switch parameters { - | list(/list(), Asttypes.Nolabel, None, {Parsetree.ppat_desc: Ppat_any}/) - when !uncurried => - Doc.text("_") - | list(/ - list(), - Asttypes.Nolabel, - None, - {Parsetree.ppat_desc: Ppat_var(stringLoc)} - /) when !uncurried => - Doc.text(stringLoc.txt) - | list(/ - list(), - Nolabel, - None, - {ppat_desc: Ppat_construct({txt: Longident.Lident("()")}, None)} - /) when !uncurried => - Doc.text("()") - | parameters => - let lparen = if uncurried { - Doc.text("(. ") - } else { - Doc.lparen - } - let shouldHug = ParsetreeViewer.parametersShouldHug(parameters) - let printedParamaters = Doc.concat(list( - if shouldHug || inCallback { - Doc.nil - } else { - Doc.softLine - }, - Doc.join( - ~sep=Doc.concat(list( - Doc.comma, - if inCallback { - Doc.space - } else { - Doc.line - }, - )), - List.map(printExpFunParameter, parameters), - ), - )) - Doc.group( - Doc.concat(list( - lparen, - if shouldHug || inCallback { - printedParamaters - } else { - Doc.indent(printedParamaters) - }, - if shouldHug || inCallback { - Doc.nil - } else { - Doc.concat(list(Doc.trailingComma, Doc.softLine)) - }, - Doc.rparen, - )), - ) - } - - and printExpFunParameter = (/attrs, lbl, defaultExpr, pattern/) => { - let /isUncurried, attrs/ = ParsetreeViewer.processUncurriedAttribute(attrs) - let uncurried = if isUncurried { - Doc.concat(list(Doc.dot, Doc.space)) - } else { - Doc.nil - } - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.line, - )) - } - - let defaultExprDoc = switch defaultExpr { - | Some(expr) => Doc.concat(list(Doc.text("="), printExpression(expr))) - | None => Doc.nil - } - - let labelWithPattern = switch /lbl, pattern/ { - | /Asttypes.Nolabel, pattern/ => printPattern(pattern) - | /Asttypes.Labelled(lbl) | Optional(lbl), {ppat_desc: Ppat_var(stringLoc)}/ - when lbl == stringLoc.txt => - Doc.concat(list(Doc.text("~"), Doc.text(lbl))) - | /Asttypes.Labelled(lbl) | Optional(lbl), pattern/ => - Doc.concat(list( - Doc.text("~"), - Doc.text(lbl), - Doc.text(" as "), - printPattern(pattern), - )) - } - - let optionalLabelSuffix = switch /lbl, defaultExpr/ { - | /Asttypes.Optional(_), None/ => Doc.text("=?") - | _ => Doc.nil - } - - Doc.group( - Doc.concat(list( - uncurried, - attrs, - labelWithPattern, - defaultExprDoc, - optionalLabelSuffix, - )), - ) - } - - and printExpressionBlock = (~braces, expr) => { - let rec collectRows = (acc, expr) => - switch expr.Parsetree.pexp_desc { - | Parsetree.Pexp_letmodule({txt: modName, loc: modLoc}, modExpr, expr) => - let letModuleDoc = Doc.concat(list( - Doc.text("module "), - Doc.text(modName), - Doc.text(" = "), - printModExpr(modExpr), - )) - let loc = {...modLoc, loc_end: modExpr.pmod_loc.loc_end} - collectRows(list(/loc, letModuleDoc/, ...acc), expr) - | Pexp_letexception(extensionConstructor, expr) => - let letExceptionDoc = printExceptionDef(extensionConstructor) - let loc = extensionConstructor.pext_loc - collectRows(list(/loc, letExceptionDoc/, ...acc), expr) - | Pexp_open(overrideFlag, longidentLoc, expr) => - let openDoc = Doc.concat(list( - Doc.text("open"), - printOverrideFlag(overrideFlag), - Doc.space, - printLongident(longidentLoc.txt), - )) - let loc = longidentLoc.loc - collectRows(list(/loc, openDoc/, ...acc), expr) - | Pexp_sequence(expr1, expr2) => - let exprDoc = { - let doc = printExpression(expr1) - if Parens.blockExpr(expr1) { - addParens(doc) - } else { - doc - } - } - - let loc = expr1.pexp_loc - collectRows(list(/loc, exprDoc/, ...acc), expr2) - | Pexp_let(recFlag, valueBindings, expr) => - let recFlag = switch recFlag { - | Asttypes.Nonrecursive => Doc.nil - | Asttypes.Recursive => Doc.text("rec ") - } - - let letDoc = printValueBindings(~recFlag, valueBindings) - let loc = switch /valueBindings, List.rev(valueBindings)/ { - | /list({pvb_loc: firstLoc}, ..._), list({pvb_loc: lastLoc}, ..._)/ => - {...firstLoc, loc_end: lastLoc.loc_end} - | _ => Location.none - } - - collectRows(list(/loc, letDoc/, ...acc), expr) - | _ => - let exprDoc = { - let doc = printExpression(expr) - if Parens.blockExpr(expr) { - addParens(doc) - } else { - doc - } - } - - List.rev(list(/expr.pexp_loc, exprDoc/, ...acc)) - } - - let block = - collectRows(list(), expr) |> interleaveWhitespace(~forceBreak=true) - Doc.breakableGroup( - ~forceBreak=true, - if braces { - Doc.concat(list( - Doc.lbrace, - Doc.indent(Doc.concat(list(Doc.line, block))), - Doc.line, - Doc.rbrace, - )) - } else { - block - }, - ) - } - - and printOverrideFlag = overrideFlag => - switch overrideFlag { - | Asttypes.Override => Doc.text("!") - | Fresh => Doc.nil - } - - and printDirectionFlag = flag => - switch flag { - | Asttypes.Downto => Doc.text(" downto ") - | Asttypes.Upto => Doc.text(" to ") - } - - and printRecordRow = (/lbl, expr/) => - Doc.concat(list( - printLongident(lbl.txt), - Doc.text(": "), - printExpression(expr), - )) - - and printBsObjectRow = (/lbl, expr/) => - Doc.concat(list( - Doc.text("\""), - printLongident(lbl.txt), - Doc.text("\""), - Doc.text(": "), - printExpression(expr), - )) - - and printAttributes = (~loc=?, attrs: Parsetree.attributes) => - switch attrs { - | list() => Doc.nil - | attrs => - let lineBreak = switch loc { - | None => Doc.line - | Some(loc) => - switch List.rev(attrs) { - | list(/{loc: firstLoc}, _/, ..._) - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum => - Doc.literalLine - | _ => Doc.line - } - } - - Doc.concat(list( - Doc.group(Doc.join(~sep=Doc.line, List.map(printAttribute, attrs))), - lineBreak, - )) - } - - and printAttribute = (/id, payload/: Parsetree.attribute) => { - let attrName = Doc.text("@" ++ id.txt) - switch payload { - | PStr(list({pstr_desc: Pstr_eval(expr, attrs)})) => - let exprDoc = printExpression(expr) - let needsParens = switch attrs { - | list() => false - | _ => true - } - Doc.group( - Doc.concat(list( - attrName, - addParens( - Doc.concat(list( - printAttributes(attrs), - if needsParens { - addParens(exprDoc) - } else { - exprDoc - }, - )), - ), - )), - ) - | _ => attrName - } - } - - and printModExpr = modExpr => - switch modExpr.pmod_desc { - | Pmod_ident(longidentLoc) => printLongident(longidentLoc.txt) - | Pmod_structure(structure) => - Doc.breakableGroup( - ~forceBreak=true, - Doc.concat(list( - Doc.lbrace, - Doc.indent(Doc.concat(list(Doc.softLine, printStructure(structure)))), - Doc.softLine, - Doc.rbrace, - )), - ) - | Pmod_unpack(expr) => - let shouldHug = switch expr.pexp_desc { - | Pexp_let(_) => true - | Pexp_constraint( - {pexp_desc: Pexp_let(_)}, - {ptyp_desc: Ptyp_package(packageType)}, - ) => - true - | _ => false - } - - let /expr, moduleConstraint/ = switch expr.pexp_desc { - | Pexp_constraint(expr, {ptyp_desc: Ptyp_package(packageType)}) => - let typeDoc = Doc.group( - Doc.concat(list( - Doc.text(":"), - Doc.indent( - Doc.concat(list( - Doc.line, - printPackageType( - ~printModuleKeywordAndParens=false, - packageType, - ), - )), - ), - )), - ) - /expr, typeDoc/ - | _ => /expr, Doc.nil/ - } - - let unpackDoc = Doc.group( - Doc.concat(list(printExpression(expr), moduleConstraint)), - ) - Doc.group( - Doc.concat(list( - Doc.text("unpack("), - if shouldHug { - unpackDoc - } else { - Doc.concat(list( - Doc.indent(Doc.concat(list(Doc.softLine, unpackDoc))), - Doc.softLine, - )) - }, - Doc.rparen, - )), - ) - | Pmod_extension(extension) => printExtension(extension) - | Pmod_apply(_) => - let /args, callExpr/ = ParsetreeViewer.modExprApply(modExpr) - let isUnitSugar = switch args { - | list({pmod_desc: Pmod_structure(list())}) => true - | _ => false - } - - let shouldHug = switch args { - | list({pmod_desc: Pmod_structure(_)}) => true - | _ => false - } - - Doc.group( - Doc.concat(list( - printModExpr(callExpr), - if isUnitSugar { - printModApplyArg(List.hd(args)) - } else { - Doc.concat(list( - Doc.lparen, - if shouldHug { - printModApplyArg(List.hd(args)) - } else { - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printModApplyArg, args), - ), - )), - ) - }, - if !shouldHug { - Doc.concat(list(Doc.trailingComma, Doc.softLine)) - } else { - Doc.nil - }, - Doc.rparen, - )) - }, - )), - ) - | Pmod_constraint(modExpr, modType) => - Doc.concat(list( - printModExpr(modExpr), - Doc.text(": "), - printModType(modType), - )) - | Pmod_functor(_) => printModFunctor(modExpr) - } - - and printModFunctor = modExpr => { - let /parameters, returnModExpr/ = ParsetreeViewer.modExprFunctor(modExpr) - - let /returnConstraint, returnModExpr/ = switch returnModExpr.pmod_desc { - | Pmod_constraint(modExpr, modType) => - let constraintDoc = { - let doc = printModType(modType) - if Parens.modExprFunctorConstraint(modType) { - addParens(doc) - } else { - doc - } - } - - let modConstraint = Doc.concat(list(Doc.text(": "), constraintDoc)) - /modConstraint, printModExpr(modExpr)/ - | _ => /Doc.nil, printModExpr(returnModExpr)/ - } - - let parametersDoc = switch parameters { - | list(/attrs, {txt: "*"}, None/) => - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.line, - )) - } - Doc.group(Doc.concat(list(attrs, Doc.text("()")))) - | list(/list(), {txt: lbl}, None/) => Doc.text(lbl) - | parameters => - Doc.group( - Doc.concat(list( - Doc.lparen, - Doc.indent( - Doc.concat(list( - Doc.softLine, - Doc.join( - ~sep=Doc.concat(list(Doc.comma, Doc.line)), - List.map(printModFunctorParam, parameters), - ), - )), - ), - Doc.trailingComma, - Doc.softLine, - Doc.rparen, - )), - ) - } - - Doc.group( - Doc.concat(list( - parametersDoc, - returnConstraint, - Doc.text(" => "), - returnModExpr, - )), - ) - } - - and printModFunctorParam = (/attrs, lbl, optModType/) => { - let attrs = switch attrs { - | list() => Doc.nil - | attrs => - Doc.concat(list( - Doc.join(~sep=Doc.line, List.map(printAttribute, attrs)), - Doc.line, - )) - } - Doc.group( - Doc.concat(list( - attrs, - Doc.text(lbl.txt), - switch optModType { - | None => Doc.nil - | Some(modType) => - Doc.concat(list(Doc.text(": "), printModType(modType))) - }, - )), - ) - } - - and printModApplyArg = modExpr => - switch modExpr.pmod_desc { - | Pmod_structure(list()) => Doc.text("()") - | _ => printModExpr(modExpr) - } - - and printExceptionDef = (constr: Parsetree.extension_constructor) => { - let kind = switch constr.pext_kind { - | Pext_rebind({txt: longident}) => - Doc.indent( - Doc.concat(list(Doc.text(" ="), Doc.line, printLongident(longident))), - ) - | Pext_decl(Pcstr_tuple(list()), None) => Doc.nil - | Pext_decl(args, gadt) => - let gadtDoc = switch gadt { - | Some(typ) => Doc.concat(list(Doc.text(": "), printTypExpr(typ))) - | None => Doc.nil - } - - Doc.concat(list(printConstructorArguments(args), gadtDoc)) - } - - Doc.group( - Doc.concat(list( - printAttributes(constr.pext_attributes), - Doc.text("exception "), - Doc.text(constr.pext_name.txt), - kind, - )), - ) - } - - and printExtensionConstructor = ( - i, - constr: Parsetree.extension_constructor, - ) => { - let attrs = printAttributes(constr.pext_attributes) - let bar = if i > 0 { - Doc.text("| ") - } else { - Doc.ifBreaks(Doc.text("| "), Doc.nil) - } - - let kind = switch constr.pext_kind { - | Pext_rebind({txt: longident}) => - Doc.indent( - Doc.concat(list(Doc.text(" ="), Doc.line, printLongident(longident))), - ) - | Pext_decl(Pcstr_tuple(list()), None) => Doc.nil - | Pext_decl(args, gadt) => - let gadtDoc = switch gadt { - | Some(typ) => Doc.concat(list(Doc.text(": "), printTypExpr(typ))) - | None => Doc.nil - } - - Doc.concat(list(printConstructorArguments(args), gadtDoc)) - } - - Doc.concat(list( - bar, - Doc.group(Doc.concat(list(attrs, Doc.text(constr.pext_name.txt), kind))), - )) - } - - let printImplementation = (s: Parsetree.structure, comments, src) => { - let t = CommentAst.initStructure(s, comments) - - let stringDoc = Doc.toString(~width=80, printStructure(s)) - print_endline(stringDoc) - print_newline() - } - - let printInterface = (s: Parsetree.signature) => { - let stringDoc = Doc.toString(~width=80, printSignature(s)) - print_endline(stringDoc) - print_newline() - } -} - - - diff --git a/jscomp/syntax/benchmarks/data/PrinterOcaml.ml b/jscomp/syntax/benchmarks/data/PrinterOcaml.ml deleted file mode 100644 index 089beaf..0000000 --- a/jscomp/syntax/benchmarks/data/PrinterOcaml.ml +++ /dev/null @@ -1,3228 +0,0 @@ -module Printer = struct - type printer = { - src: bytes; - comments: CommentAst.t; - } - - - (* TODO: should this go inside a ast utility module? *) - let rec collectPatternsFromListConstruct acc pattern = - let open Parsetree in - match pattern.ppat_desc with - | Ppat_construct( - {txt = Longident.Lident "::"}, - Some {ppat_desc=Ppat_tuple (pat::rest::[])} - ) -> - collectPatternsFromListConstruct (pat::acc) rest - | _ -> List.rev acc, pattern - - let addParens doc = - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - doc - ] - ); - Doc.softLine; - Doc.rparen; - ] - ) - - let addBraces doc = - Doc.group ( - Doc.concat [ - Doc.lbrace; - doc; - Doc.rbrace; - ] - ) - - (* This could be done in one pass by collecting locations as we go? *) - let interleaveWhitespace ?(forceBreak=false) (rows: (Location.t * Doc.t) list) = - let rec loop prevLoc acc rows = - match rows with - | [] -> Doc.concat (List.rev acc) - | (loc, doc)::rest -> - if loc.Location.loc_start.pos_lnum - prevLoc.Location.loc_end.pos_lnum > 1 then - loop loc (doc::Doc.line::Doc.line::acc) rest - else - loop loc (doc::Doc.line::acc) rest - in - match rows with - | [] -> Doc.nil - | (firstLoc, firstDoc)::rest -> - (* TODO: perf, reversing the list twice! *) - let forceBreak = forceBreak || (match List.rev rest with - | (lastLoc, _)::_ -> - firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - | _ -> false) - in - Doc.breakableGroup ~forceBreak ( - loop firstLoc [firstDoc] rest - ) - - let printLongident l = match l with - | Longident.Lident lident -> Doc.text lident - | Longident.Ldot (lident, txt) as l -> - let txts = Longident.flatten l in - Doc.join ~sep:Doc.dot (List.map Doc.text txts) - | _ -> failwith "unsupported ident" - - (* TODO: better allocation strategy for the buffer *) - let escapeStringContents s = - let len = String.length s in - let b = Buffer.create len in - for i = 0 to len - 1 do - let c = String.get s i in - if c = '\008' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'b'; - ) else if c = '\009' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 't'; - ) else if c = '\010' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'n'; - ) else if c = '\013' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'r'; - ) else if c = '\034' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '"'; - ) else if c = '\092' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\'; - )else ( - Buffer.add_char b c; - ); - done; - Buffer.contents b - - let printConstant c = match c with - | Parsetree.Pconst_integer (s, _) -> Doc.text s - | Pconst_string (s, _) -> Doc.text ("\"" ^ (escapeStringContents s) ^ "\"") - | Pconst_float (s, _) -> Doc.text s - | Pconst_char c -> Doc.text ("'" ^ (Char.escaped c) ^ "'") - - let rec printStructure (s : Parsetree.structure) = - interleaveWhitespace ( - List.map (fun si -> (si.Parsetree.pstr_loc, printStructureItem si)) s - ) - - and printStructureItem (si: Parsetree.structure_item) = - match si.pstr_desc with - | Pstr_value(rec_flag, valueBindings) -> - let recFlag = match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~recFlag valueBindings - | Pstr_type(recFlag, typeDeclarations) -> - let recFlag = match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~recFlag typeDeclarations - | Pstr_primitive valueDescription -> - printValueDescription valueDescription - | Pstr_eval (expr, attrs) -> - let needsParens = match expr with - | {pexp_attributes=[({txt="res.ternary"},_)]; pexp_desc = Pexp_ifthenelse _} -> false - | _ when ParsetreeViewer.hasAttributes expr.pexp_attributes -> true - | _ -> false - in - let exprDoc = - let doc = printExpression expr in - if needsParens then addParens doc else doc - in - Doc.concat [ - printAttributes attrs; - exprDoc; - ] - | Pstr_attribute attr -> Doc.concat [Doc.text "@"; printAttribute attr] - | Pstr_extension (extension, attrs) -> Doc.concat [ - printAttributes attrs; - Doc.concat [Doc.text "%";printExtension extension]; - ] - | Pstr_include includeDeclaration -> - printIncludeDeclaration includeDeclaration - | Pstr_open openDescription -> - printOpenDescription openDescription - | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration modTypeDecl - | Pstr_module moduleBinding -> - printModuleBinding ~isRec:false 0 moduleBinding - | Pstr_recmodule moduleBindings -> - Doc.join ~sep:Doc.line (List.mapi (fun i mb -> - printModuleBinding ~isRec:true i mb - ) moduleBindings) - | Pstr_exception extensionConstructor -> - printExceptionDef extensionConstructor; - | Pstr_typext typeExtension -> - printTypeExtension typeExtension - | Pstr_class _ | Pstr_class_type _ -> Doc.nil - - and printTypeExtension (te : Parsetree.type_extension) = - let prefix = Doc.text "type " in - let name = printLongident te.ptyext_path.txt in - let typeParams = match te.ptyext_params with - | [] -> Doc.nil - | typeParams -> Doc.group ( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypeParam typeParams - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - ) - in - let extensionConstructors = - let ecs = te.ptyext_constructors in - let forceBreak = - match (ecs, List.rev ecs) with - | (first::_, last::_) -> - first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum || - first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum - | _ -> false - in - let privateFlag = match te.ptyext_private with - | Asttypes.Private -> Doc.concat [ - Doc.text "private"; - Doc.line; - ] - | Public -> Doc.nil - in - Doc.breakableGroup ~forceBreak ( - Doc.indent ( - Doc.concat [ - Doc.line; - privateFlag; - Doc.join ~sep:Doc.line ( - List.mapi printExtensionConstructor ecs - ) - ] - ) - ) - in - Doc.group ( - Doc.concat [ - printAttributes ~loc: te.ptyext_path.loc te.ptyext_attributes; - prefix; - name; - typeParams; - Doc.text " +="; - extensionConstructors; - ] - ) - - and printModuleBinding ~isRec i moduleBinding = - let prefix = if i = 0 then - Doc.concat [ - Doc.text "module "; - if isRec then Doc.text "rec " else Doc.nil; - ] - else - Doc.text "and " - in - let (modExprDoc, modConstraintDoc) = - match moduleBinding.pmb_expr with - | {pmod_desc = Pmod_constraint (modExpr, modType)} -> - ( - printModExpr modExpr, - Doc.concat [ - Doc.text ": "; - printModType modType - ] - ) - | modExpr -> - (printModExpr modExpr, Doc.nil) - in - Doc.concat [ - printAttributes ~loc:moduleBinding.pmb_name.loc moduleBinding.pmb_attributes; - prefix; - Doc.text moduleBinding.pmb_name.Location.txt; - modConstraintDoc; - Doc.text " = "; - modExprDoc; - ] - - and printModuleTypeDeclaration (modTypeDecl : Parsetree.module_type_declaration) = - Doc.concat [ - printAttributes modTypeDecl.pmtd_attributes; - Doc.text "module type "; - Doc.text modTypeDecl.pmtd_name.txt; - (match modTypeDecl.pmtd_type with - | None -> Doc.nil - | Some modType -> Doc.concat [ - Doc.text " = "; - printModType modType; - ]); - ] - - and printModType modType = - let modTypeDoc = match modType.pmty_desc with - | Parsetree.Pmty_ident {txt = longident; loc} -> - Doc.concat [ - printAttributes ~loc modType.pmty_attributes; - printLongident longident - ] - | Pmty_signature signature -> - let signatureDoc = Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.line; - printSignature signature; - ] - ); - Doc.line; - Doc.rbrace; - ] - ) in - Doc.concat [ - printAttributes modType.pmty_attributes; - signatureDoc - ] - | Pmty_functor _ -> - let (parameters, returnType) = ParsetreeViewer.functorType modType in - let parametersDoc = match parameters with - | [] -> Doc.nil - | [attrs, {Location.txt = "_"}, Some modType] -> - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - Doc.concat [ - attrs; - printModType modType - ] - | params -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map (fun (attrs, lbl, modType) -> - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - Doc.concat [ - attrs; - if lbl.Location.txt = "_" then Doc.nil else Doc.text lbl.txt; - (match modType with - | None -> Doc.nil - | Some modType -> Doc.concat [ - if lbl.txt = "_" then Doc.nil else Doc.text ": "; - printModType modType; - ]); - ] - ) params - ); - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - let returnDoc = - let doc = printModType returnType in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group ( - Doc.concat [ - parametersDoc; - Doc.group ( - Doc.concat [ - Doc.text " =>"; - Doc.line; - returnDoc; - ] - ) - ] - ) - | Pmty_typeof modExpr -> Doc.concat [ - Doc.text "module type of "; - printModExpr modExpr; - ] - | Pmty_extension extension -> printExtension extension - | Pmty_alias {txt = longident} -> Doc.concat [ - Doc.text "module "; - printLongident longident; - ] - | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType modType in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group ( - Doc.concat [ - operand; - Doc.indent ( - Doc.concat [ - Doc.line; - printWithConstraints withConstraints; - ] - ) - ] - ) - in - let attrsAlreadyPrinted = match modType.pmty_desc with - | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true - | _ -> false in - Doc.concat [ - if attrsAlreadyPrinted then Doc.nil else printAttributes modType.pmty_attributes; - modTypeDoc; - ] - - and printWithConstraints withConstraints = - let rows =List.mapi (fun i withConstraint -> - Doc.group ( - Doc.concat [ - if i == 0 then Doc.text "with " else Doc.text "and "; - printWithConstraint withConstraint; - ] - ) - ) withConstraints - in - Doc.join ~sep:Doc.line rows - - and printWithConstraint (withConstraint : Parsetree.with_constraint) = - match withConstraint with - (* with type X.t = ... *) - | Pwith_type ({txt = longident}, typeDeclaration) -> - Doc.group (printTypeDeclaration - ~name:(printLongident longident) - ~equalSign:"=" - ~recFlag:Doc.nil - 0 - typeDeclaration) - (* with module X.Y = Z *) - | Pwith_module ({txt = longident1}, {txt = longident2}) -> - Doc.concat [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent ( - Doc.concat [ - Doc.line; - printLongident longident2; - ] - ) - ] - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_typesubst ({txt = longident}, typeDeclaration) -> - Doc.group(printTypeDeclaration - ~name:(printLongident longident) - ~equalSign:":=" - ~recFlag:Doc.nil - 0 - typeDeclaration) - | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> - Doc.concat [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent ( - Doc.concat [ - Doc.line; - printLongident longident2; - ] - ) - ] - - and printSignature signature = - interleaveWhitespace ( - List.map (fun si -> (si.Parsetree.psig_loc, printSignatureItem si)) signature - ) - - and printSignatureItem (si : Parsetree.signature_item) = - match si.psig_desc with - | Parsetree.Psig_value valueDescription -> - printValueDescription valueDescription - | Psig_type (recFlag, typeDeclarations) -> - let recFlag = match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~recFlag typeDeclarations - | Psig_typext typeExtension -> - printTypeExtension typeExtension - | Psig_exception extensionConstructor -> - printExceptionDef extensionConstructor - | Psig_module moduleDeclaration -> - printModuleDeclaration moduleDeclaration - | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations moduleDeclarations - | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration modTypeDecl - | Psig_open openDescription -> - printOpenDescription openDescription - | Psig_include includeDescription -> - printIncludeDescription includeDescription - | Psig_attribute attr -> Doc.concat [Doc.text "@"; printAttribute attr] - | Psig_extension (extension, attrs) -> Doc.concat [ - printAttributes attrs; - Doc.concat [Doc.text "%";printExtension extension]; - ] - | Psig_class _ | Psig_class_type _ -> Doc.nil - - and printRecModuleDeclarations moduleDeclarations = - Doc.group ( - Doc.join ~sep:Doc.line ( - List.mapi (fun i (md: Parsetree.module_declaration) -> - let body = match md.pmd_type.pmty_desc with - | Parsetree.Pmty_alias {txt = longident } -> - Doc.concat [Doc.text " = "; printLongident longident] - | _ -> - let needsParens = match md.pmd_type.pmty_desc with - | Pmty_with _ -> true - | _ -> false - in - let modTypeDoc = - let doc = printModType md.pmd_type in - if needsParens then addParens doc else doc - in - Doc.concat [Doc.text ": "; modTypeDoc] - in - let prefix = if i < 1 then "module rec " else "and " in - Doc.concat [ - printAttributes ~loc:md.pmd_name.loc md.pmd_attributes; - Doc.text prefix; - Doc.text md.pmd_name.txt; - body - ] - ) moduleDeclarations - ) - ) - - and printModuleDeclaration (md: Parsetree.module_declaration) = - let body = match md.pmd_type.pmty_desc with - | Parsetree.Pmty_alias {txt = longident } -> - Doc.concat [Doc.text " = "; printLongident longident] - | _ -> Doc.concat [Doc.text ": "; printModType md.pmd_type] - in - Doc.concat [ - printAttributes ~loc:md.pmd_name.loc md.pmd_attributes; - Doc.text "module "; - Doc.text md.pmd_name.txt; - body - ] - - and printOpenDescription (openDescription : Parsetree.open_description) = - Doc.concat [ - printAttributes openDescription.popen_attributes; - Doc.text "open"; - (match openDescription.popen_override with - | Asttypes.Fresh -> Doc.space - | Asttypes.Override -> Doc.text "! "); - printLongident openDescription.popen_lid.txt - ] - - and printIncludeDescription (includeDescription: Parsetree.include_description) = - Doc.concat [ - printAttributes includeDescription.pincl_attributes; - Doc.text "include "; - printModType includeDescription.pincl_mod; - ] - - and printIncludeDeclaration (includeDeclaration : Parsetree.include_declaration) = - Doc.concat [ - printAttributes includeDeclaration.pincl_attributes; - Doc.text "include "; - printModExpr includeDeclaration.pincl_mod; - ] - - - and printValueBindings ~recFlag (vbs: Parsetree.value_binding list) = - let rows = List.mapi (fun i vb -> - let doc = printValueBinding ~recFlag i vb in - (vb.Parsetree.pvb_loc, doc) - ) vbs - in - interleaveWhitespace rows - - (* - * type value_description = { - * pval_name : string Asttypes.loc; - * pval_type : Parsetree.core_type; - * pval_prim : string list; - * pval_attributes : Parsetree.attributes; - * pval_loc : Location.t; - * } - *) - and printValueDescription valueDescription = - let isExternal = - match valueDescription.pval_prim with | [] -> false | _ -> true - in - Doc.group ( - Doc.concat [ - Doc.text (if isExternal then "external " else "let "); - Doc.text valueDescription.pval_name.txt; - Doc.text ": "; - printTypExpr valueDescription.pval_type; - if isExternal then - Doc.group ( - Doc.concat [ - Doc.text " ="; - Doc.indent( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line ( - List.map(fun s -> Doc.concat [ - Doc.text "\""; - Doc.text s; - Doc.text "\""; - ]) - valueDescription.pval_prim - ); - ] - ) - ] - ) - else Doc.nil - ] - ) - - and printTypeDeclarations ~recFlag typeDeclarations = - let rows = List.mapi (fun i td -> - let doc = printTypeDeclaration - ~name:(Doc.text td.Parsetree.ptype_name.txt) - ~equalSign:"=" - ~recFlag - i td - in - (td.Parsetree.ptype_loc, doc) - ) typeDeclarations in - interleaveWhitespace rows - - (* - * type_declaration = { - * ptype_name: string loc; - * ptype_params: (core_type * variance) list; - * (* ('a1,...'an) t; None represents _*) - * ptype_cstrs: (core_type * core_type * Location.t) list; - * (* ... constraint T1=T1' ... constraint Tn=Tn' *) - * ptype_kind: type_kind; - * ptype_private: private_flag; (* = private ... *) - * ptype_manifest: core_type option; (* = T *) - * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - * ptype_loc: Location.t; - * } - * - * - * type t (abstract, no manifest) - * type t = T0 (abstract, manifest=T0) - * type t = C of T | ... (variant, no manifest) - * type t = T0 = C of T | ... (variant, manifest=T0) - * type t = {l: T; ...} (record, no manifest) - * type t = T0 = {l : T; ...} (record, manifest=T0) - * type t = .. (open, no manifest) - * - * - * and type_kind = - * | Ptype_abstract - * | Ptype_variant of constructor_declaration list - * (* Invariant: non-empty list *) - * | Ptype_record of label_declaration list - * (* Invariant: non-empty list *) - * | Ptype_open - *) - and printTypeDeclaration ~name ~equalSign ~recFlag i (td: Parsetree.type_declaration) = - let attrs = printAttributes ~loc:td.ptype_loc td.ptype_attributes in - let prefix = if i > 0 then - Doc.text "and " - else - Doc.concat [Doc.text "type "; recFlag] - in - let typeName = name in - let typeParams = match td.ptype_params with - | [] -> Doc.nil - | typeParams -> Doc.group ( - Doc.concat [ - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypeParam typeParams - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - ) - in - let manifestAndKind = match td.ptype_kind with - | Ptype_abstract -> - begin match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> - Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr typ; - ] - end - | Ptype_open -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record(lds) -> - let manifest = match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ; - ] - in - Doc.concat [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration lds; - ] - | Ptype_variant(cds) -> - let manifest = match td.ptype_manifest with - | None -> Doc.nil - | Some(typ) -> Doc.concat [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr typ; - ] - in - Doc.concat [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~privateFlag:td.ptype_private cds; - ] - in - let constraints = printTypeDefinitionConstraints td.ptype_cstrs in - Doc.group ( - Doc.concat [ - attrs; - prefix; - typeName; - typeParams; - manifestAndKind; - constraints; - ] - ) - - and printTypeDefinitionConstraints cstrs = - match cstrs with - | [] -> Doc.nil - | cstrs -> Doc.indent ( - Doc.group ( - Doc.concat [ - Doc.line; - Doc.group( - Doc.join ~sep:Doc.line ( - List.map printTypeDefinitionConstraint cstrs - ) - ) - ] - ) - ) - - and printTypeDefinitionConstraint ((typ1, typ2, _loc ): Parsetree.core_type * Parsetree.core_type * Location.t) = - Doc.concat [ - Doc.text "constraint "; - printTypExpr typ1; - Doc.text " = "; - printTypExpr typ2; - ] - - and printPrivateFlag (flag : Asttypes.private_flag) = match flag with - | Private -> Doc.text "private " - | Public -> Doc.nil - - and printTypeParam (param : (Parsetree.core_type * Asttypes.variance)) = - let (typ, variance) = param in - let printedVariance = match variance with - | Covariant -> Doc.text "+" - | Contravariant -> Doc.text "-" - | Invariant -> Doc.nil - in - Doc.concat [ - printedVariance; - printTypExpr typ - ] - - and printRecordDeclaration (lds: Parsetree.label_declaration list) = - let forceBreak = match (lds, List.rev lds) with - | (first::_, last::_) -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printLabelDeclaration lds) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] - ) - - and printConstructorDeclarations ~privateFlag (cds: Parsetree.constructor_declaration list) = - let forceBreak = match (cds, List.rev cds) with - | (first::_, last::_) -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum - | _ -> false - in - let privateFlag = match privateFlag with - | Asttypes.Private -> Doc.concat [ - Doc.text "private"; - Doc.line; - ] - | Public -> Doc.nil - in - Doc.breakableGroup ~forceBreak ( - Doc.indent ( - Doc.concat [ - Doc.line; - privateFlag; - Doc.join ~sep:Doc.line ( - List.mapi printConstructorDeclaration cds - ) - ] - ) - ) - - (* - * { - * pcd_name: string loc; - * pcd_args: constructor_arguments; - * pcd_res: core_type option; - * pcd_loc: Location.t; - * pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) - * } - *) - and printConstructorDeclaration i (cd : Parsetree.constructor_declaration) = - let attrs = printAttributes cd.pcd_attributes in - let bar = if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil - in - let constrName = Doc.text cd.pcd_name.txt in - let constrArgs = printConstructorArguments cd.pcd_args in - let gadt = match cd.pcd_res with - | None -> Doc.nil - | Some(typ) -> Doc.indent ( - Doc.concat [ - Doc.text ": "; - printTypExpr typ; - ] - ) - in - Doc.concat [ - bar; - Doc.group ( - Doc.concat [ - attrs; (* TODO: fix parsing of attributes, so when can print them above the bar? *) - constrName; - constrArgs; - gadt; - ] - ) - ] - - and printConstructorArguments (cdArgs : Parsetree.constructor_arguments) = - match cdArgs with - | Pcstr_tuple [] -> Doc.nil - | Pcstr_tuple types -> Doc.group ( - Doc.indent ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypExpr types - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - ) - | Pcstr_record lds -> - Doc.indent ( - Doc.concat [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printLabelDeclaration lds) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - ) - - - and printLabelDeclaration (ld : Parsetree.label_declaration) = - let attrs = printAttributes ~loc:ld.pld_name.loc ld.pld_attributes in - let mutableFlag = match ld.pld_mutable with - | Mutable -> Doc.text "mutable " - | Immutable -> Doc.nil - in - let name = Doc.text ld.pld_name.txt in - Doc.group ( - Doc.concat [ - attrs; - mutableFlag; - name; - Doc.text ": "; - printTypExpr ld.pld_type; - ] - ) - - and printTypExpr (typExpr : Parsetree.core_type) = - let renderedType = match typExpr.ptyp_desc with - | Ptyp_any -> Doc.text "_" - | Ptyp_var var -> Doc.text ("'" ^ var) - | Ptyp_extension(extension) -> - printExtension extension - | Ptyp_alias(typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = match typ.ptyp_desc with - | Ptyp_arrow _ -> true - | _ -> false - in - let doc = printTypExpr typ in - if needsParens then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else - doc - in - Doc.concat [typ; Doc.text " as "; Doc.text ("'" ^ alias)] - | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, [typ]) -> - let bsObject = printTypExpr typ in - begin match typExpr.ptyp_attributes with - | [] -> bsObject - | attrs -> - Doc.concat [ - Doc.group ( - Doc.join ~sep:Doc.line (List.map printAttribute attrs) - ); - Doc.space; - printTypExpr typ; - ] - end - | Ptyp_constr(longidentLoc, [{ ptyp_desc = Parsetree.Ptyp_tuple tuple }]) -> - let constrName = printLongident longidentLoc.txt in - Doc.group( - Doc.concat([ - constrName; - Doc.lessThan; - printTupleType ~inline:true tuple; - Doc.greaterThan; - ]) - ) - | Ptyp_constr(longidentLoc, constrArgs) -> - let constrName = printLongident longidentLoc.txt in - begin match constrArgs with - | [] -> constrName - | [{ - Parsetree.ptyp_desc = - Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, - [{ptyp_desc = Ptyp_object (fields, openFlag)}]) - }] -> - Doc.concat([ - constrName; - Doc.lessThan; - printBsObjectSugar ~inline:true fields openFlag; - Doc.greaterThan; - ]) - | args -> Doc.group( - Doc.concat([ - constrName; - Doc.lessThan; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypExpr constrArgs - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) - ) - end - | Ptyp_arrow _ -> - let (attrsBefore, args, returnType) = ParsetreeViewer.arrowType typExpr in - let returnTypeNeedsParens = match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr returnType in - if returnTypeNeedsParens then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrsBefore in - begin match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not isUncurried -> - let hasAttrsBefore = not (attrs = []) in - let attrs = if hasAttrsBefore then - Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrsBefore); - Doc.space; - ] - else Doc.nil - in - Doc.group ( - Doc.concat [ - Doc.group attrs; - Doc.group ( - if hasAttrsBefore then - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - printTypExpr n; - Doc.text " => "; - returnDoc; - ] - ); - Doc.softLine; - Doc.rparen - ] - else - Doc.concat [ - printTypExpr n; - Doc.text " => "; - returnDoc; - ] - ) - ] - ) - | args -> - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.space; - ] - in - let renderedArgs = Doc.concat [ - attrs; - Doc.text "("; - Doc.indent ( - Doc.concat [ - Doc.softLine; - if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypeParameter args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] in - Doc.group ( - Doc.concat [ - renderedArgs; - Doc.text " => "; - returnDoc; - ] - ) - end - | Ptyp_tuple types -> printTupleType ~inline:false types - | Ptyp_object (fields, openFlag) -> - printBsObjectSugar ~inline:false fields openFlag - | Ptyp_poly(stringLocs, typ) -> - Doc.concat [ - Doc.join ~sep:Doc.space (List.map (fun {Location.txt} -> - Doc.text ("'" ^ txt)) stringLocs); - Doc.dot; - Doc.space; - printTypExpr typ - ] - | Ptyp_package packageType -> - printPackageType ~printModuleKeywordAndParens:true packageType - | Ptyp_class _ -> failwith "classes are not supported in types" - | Ptyp_variant _ -> failwith "Polymorphic variants currently not supported" - in - let shouldPrintItsOwnAttributes = match typExpr.ptyp_desc with - | Ptyp_arrow _ (* es6 arrow types print their own attributes *) - | Ptyp_constr({txt = Longident.Ldot(Longident.Lident "Js", "t")}, _) -> true - | _ -> false - in - begin match typExpr.ptyp_attributes with - | _::_ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - renderedType; - ] - ) - | _ -> renderedType - end - - and printBsObjectSugar ~inline fields openFlag = - let flag = match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> Doc.dotdot - in - let doc = Doc.concat [ - Doc.lbrace; - flag; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printObjectField fields - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] in - if inline then doc else Doc.group doc - - - and printTupleType ~inline (types: Parsetree.core_type list) = - let tuple = Doc.concat([ - Doc.text "/"; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printTypExpr types - ) - ]) - ); - (* Doc.trailingComma; *) (* Trailing comma not supported in tuples right now‚ͬ†*) - Doc.softLine; - Doc.text "/"; - ]) - in - if inline == false then Doc.group(tuple) else tuple - - and printObjectField (field : Parsetree.object_field) = - match field with - | Otag (labelLoc, attrs, typ) -> - Doc.concat [ - Doc.text ("\"" ^ labelLoc.txt ^ "\""); - Doc.text ": "; - printTypExpr typ; - ] - | _ -> Doc.nil - - (* es6 arrow type arg - * type t = (~foo: string, ~bar: float=?, unit) => unit - * i.e. ~foo: string, ~bar: float *) - and printTypeParameter (attrs, lbl, typ) = - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - let label = match lbl with - | Asttypes.Nolabel -> Doc.nil - | Labelled lbl -> Doc.text ("~" ^ lbl ^ ": ") - | Optional lbl -> Doc.text ("~" ^ lbl ^ ": ") - in - let optionalIndicator = match lbl with - | Asttypes.Nolabel - | Labelled _ -> Doc.nil - | Optional lbl -> Doc.text "=?" - in - Doc.group ( - Doc.concat [ - uncurried; - attrs; - label; - printTypExpr typ; - optionalIndicator; - ] - ) - - - (* - * { - * pvb_pat: pattern; - * pvb_expr: expression; - * pvb_attributes: attributes; - * pvb_loc: Location.t; - * } - *) - and printValueBinding ~recFlag i vb = - let isGhost = ParsetreeViewer.isGhostUnitBinding i vb in - let header = if isGhost then Doc.nil else - if i == 0 then Doc.concat [Doc.text "let "; recFlag] - else Doc.text "and " - in - let printedExpr = - let exprDoc = printExpression vb.pvb_expr in - let needsParens = match vb.pvb_expr.pexp_desc with - | Pexp_constraint( - {pexp_desc = Pexp_pack _}, - {ptyp_desc = Ptyp_package _} - ) -> false - | Pexp_constraint _ -> true - | _ -> false - in - if needsParens then addParens exprDoc else exprDoc - in - if isGhost then - printedExpr - else - let shouldIndent = - ParsetreeViewer.isBinaryExpression vb.pvb_expr || - (match vb.pvb_expr with - | { - pexp_attributes = [({Location.txt="res.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _) - } -> - ParsetreeViewer.isBinaryExpression ifExpr || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | { pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes || - ParsetreeViewer.isArrayAccess e - ) - in - Doc.concat [ - printAttributes ~loc:vb.pvb_loc vb.pvb_attributes; - header; - printPattern vb.pvb_pat; - Doc.text " ="; - if shouldIndent then - Doc.indent ( - Doc.concat [ - Doc.line; - printedExpr; - ] - ) - else - Doc.concat [ - Doc.space; - printedExpr; - ] - ] - - and printPackageType ~printModuleKeywordAndParens (packageType: Parsetree.package_type) = - let doc = match packageType with - | (longidentLoc, []) -> Doc.group( - Doc.concat [ - printLongident longidentLoc.txt; - ] - ) - | (longidentLoc, packageConstraints) -> Doc.group( - Doc.concat [ - printLongident longidentLoc.txt; - printPackageConstraints packageConstraints; - Doc.softLine; - ] - ) - in - if printModuleKeywordAndParens then - Doc.concat[ - Doc.text "module("; - doc; - Doc.rparen - ] - else - doc - - - - - and printPackageConstraints packageConstraints = - Doc.concat [ - Doc.text " with"; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line ( - List.mapi printPackageconstraint packageConstraints - ) - ] - ) - ] - - and printPackageconstraint i (longidentLoc, typ) = - let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in - Doc.concat [ - prefix; - printLongident longidentLoc.Location.txt; - Doc.text " = "; - printTypExpr typ - ] - - and printExtension (stringLoc, payload) = - let extName = Doc.text ("%" ^ stringLoc.Location.txt) in - match payload with - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpression expr in - let needsParens = match attrs with | [] -> false | _ -> true in - Doc.group ( - Doc.concat [ - extName; - addParens ( - Doc.concat [ - printAttributes attrs; - if needsParens then addParens exprDoc else exprDoc; - ] - ) - ] - ) - | _ -> extName - - and printPattern (p : Parsetree.pattern) = - let patternWithoutAttributes = match p.ppat_desc with - | Ppat_any -> Doc.text "_" - | Ppat_var stringLoc -> Doc.text (stringLoc.txt) - | Ppat_constant c -> printConstant c - | Ppat_tuple patterns -> - Doc.group( - Doc.concat([ - Doc.text "/"; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printPattern patterns) - ]) - ); - (* Doc.ifBreaks (Doc.text ",") Doc.nil; *) - Doc.softLine; - Doc.text "/"; - ]) - ) - | Ppat_array patterns -> - Doc.group( - Doc.concat([ - Doc.text "["; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printPattern patterns) - ]) - ); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.text "]"; - ]) - ) - | Ppat_construct({txt = Longident.Lident "[]"}, _) -> - Doc.text "list()" - | Ppat_construct({txt = Longident.Lident "::"}, _) -> - let (patterns, tail) = collectPatternsFromListConstruct [] p in - let shouldHug = match (patterns, tail) with - | ([pat], - {ppat_desc = Ppat_construct({txt = Longident.Lident "[]"}, _)}) when ParsetreeViewer.isHuggablePattern pat -> true - | _ -> false - in - let children = Doc.concat([ - if shouldHug then Doc.nil else Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printPattern patterns); - begin match tail.Parsetree.ppat_desc with - | Ppat_construct({txt = Longident.Lident "[]"}, _) -> Doc.nil - | _ -> Doc.concat([Doc.text ","; Doc.line; Doc.text "..."; printPattern tail]) - end; - ]) in - Doc.group( - Doc.concat([ - Doc.text "list("; - if shouldHug then children else Doc.concat [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - ]; - Doc.text ")"; - ]) - ) - | Ppat_construct(constrName, constructorArgs) -> - let constrName = printLongident constrName.txt in - begin match constructorArgs with - | None -> constrName - | Some(args) -> - let args = match args.ppat_desc with - | Ppat_construct({txt = Longident.Lident "()"}, None) -> [Doc.nil] - | Ppat_tuple(patterns) -> List.map printPattern patterns - | _ -> [printPattern args] - in - Doc.group( - Doc.concat([ - constrName; - Doc.text "("; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - args - ] - ); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.text ")"; - ]) - ) - end - | Ppat_record(rows, openFlag) -> - Doc.group( - Doc.concat([ - Doc.text "{"; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printPatternRecordRow rows); - begin match openFlag with - | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] - | Closed -> Doc.nil - end; - ] - ); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.text "}"; - ]) - ) - - | Ppat_exception p -> - let needsParens = match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern p in - if needsParens then - Doc.concat [Doc.text "("; p; Doc.text ")"] - else - p - in - Doc.group ( - Doc.concat [ Doc.text "exception"; Doc.line; pat ] - ) - | Ppat_or (p1, p2) -> - let p1 = - let p = printPattern p1 in - match p1.ppat_desc with - | Ppat_or (_, _) -> Doc.concat [Doc.text "("; p; Doc.text ")"] - | _ -> p - in - let p2 = - let p = printPattern p2 in - match p2.ppat_desc with - | Ppat_or (_, _) -> Doc.concat [Doc.text "("; p; Doc.text ")"] - | _ -> p - in - Doc.group( - Doc.concat([p1; Doc.line; Doc.text "| "; p2]) - ) - | Ppat_extension ext -> - printExtension ext - | Ppat_lazy p -> - let needsParens = match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern p in - if needsParens then - Doc.concat [Doc.text "("; p; Doc.text ")"] - else - p - in - Doc.concat [Doc.text "lazy "; pat] - | Ppat_alias (p, aliasLoc) -> - let needsParens = match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern p in - if needsParens then - Doc.concat [Doc.text "("; p; Doc.text ")"] - else - p - in - Doc.concat([ - renderedPattern; - Doc.text " as "; - Doc.text aliasLoc.txt - ]) - - (* Note: module(P : S) is represented as *) - (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) - | Ppat_constraint ({ppat_desc = Ppat_unpack stringLoc}, {ptyp_desc = Ptyp_package packageType}) -> - Doc.concat [ - Doc.text "module("; - Doc.text stringLoc.txt; - Doc.text ": "; - printPackageType ~printModuleKeywordAndParens:false packageType; - Doc.rparen; - ] - | Ppat_constraint (pattern, typ) -> - Doc.concat [ - printPattern pattern; - Doc.text ": "; - printTypExpr typ; - ] - - (* Note: module(P : S) is represented as *) - (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) - | Ppat_unpack stringLoc -> - Doc.concat [ - Doc.text "module("; - Doc.text stringLoc.txt; - Doc.rparen; - ] - | _ -> failwith "unsupported pattern" - in - begin match p.ppat_attributes with - | [] -> patternWithoutAttributes - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - patternWithoutAttributes; - ] - ) - end - - and printPatternRecordRow row = - match row with - (* punned {x}*) - | ({Location.txt=Longident.Lident ident}, - {Parsetree.ppat_desc=Ppat_var {txt;_}}) when ident = txt -> - Doc.text ident - | (longident, pattern) -> - Doc.group ( - Doc.concat([ - printLongident longident.txt; - Doc.text ": "; - Doc.indent( - Doc.concat [ - Doc.softLine; - printPattern pattern; - ] - ) - ]) - ) - - and printExpression (e : Parsetree.expression) = - let printedExpression = match e.pexp_desc with - | Parsetree.Pexp_constant c -> printConstant c - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment e - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> Doc.text "list()" - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let (expressions, spread) = ParsetreeViewer.collectListExpressions e in - let spreadDoc = match spread with - | Some(expr) -> Doc.concat [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - printExpression expr - ] - | None -> Doc.nil - in - Doc.group( - Doc.concat([ - Doc.text "list("; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printExpression expressions); - spreadDoc; - ]) - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - ) - | Pexp_construct (longidentLoc, args) -> - let constr = printLongident longidentLoc.txt in - let args = match args with - | None -> Doc.nil - | Some({pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}) -> - Doc.text "()" - | Some({pexp_desc = Pexp_tuple args }) -> - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printExpression args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some(arg) -> - let argDoc = printExpression arg in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat [ - Doc.lparen; - if shouldHug then argDoc - else Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - argDoc; - ] - ); - Doc.trailingComma; - Doc.softLine; - ]; - Doc.rparen; - ] - in - Doc.group(Doc.concat [constr; args]) - | Pexp_ident(longidentLoc) -> - printLongident longidentLoc.txt - | Pexp_tuple exprs -> - Doc.group( - Doc.concat([ - Doc.text "/"; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printExpression exprs) - ]) - ); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.text "/"; - ]) - ) - | Pexp_array [] -> Doc.text "[]" - | Pexp_array exprs -> - Doc.group( - Doc.concat([ - Doc.lbracket; - Doc.indent ( - Doc.concat([ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printExpression exprs) - ]) - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - ) - | Pexp_record (rows, spreadExpr) -> - let spread = match spreadExpr with - | None -> Doc.nil - | Some expr -> Doc.concat [ - Doc.dotdotdot; - printExpression expr; - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak ( - Doc.concat([ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - spread; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printRecordRow rows) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - ) - | Pexp_extension extension -> - begin match extension with - | ( - {txt = "bs.obj"}, - PStr [{ - pstr_loc = loc; - pstr_desc = Pstr_eval({pexp_desc = Pexp_record (rows, _)}, []) - }] - ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = - loc.loc_start.pos_lnum < loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak ( - Doc.concat([ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map printBsObjectRow rows) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - ) - | extension -> - printExtension extension - end - | Pexp_apply _ -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression e - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression e - else - printPexpApply e - | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpression expr in - if Parens.fieldExpr expr then addParens doc else doc - in - Doc.concat [ - lhs; - Doc.dot; - printLongident longidentLoc.txt; - ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr e.pexp_attributes expr1 longidentLoc expr2 - | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> - if ParsetreeViewer.isTernaryExpr e then - let (parts, alternate) = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = match parts with - | (condition1, consequent1)::rest -> - Doc.group (Doc.concat [ - printTernaryOperand condition1; - Doc.indent ( - Doc.concat [ - Doc.line; - Doc.indent (Doc.concat [Doc.text "? "; printTernaryOperand consequent1]); - Doc.concat ( - List.map (fun (condition, consequent) -> - Doc.concat [ - Doc.line; - Doc.text ": "; - printTernaryOperand condition; - Doc.line; - Doc.text "? "; - printTernaryOperand consequent; - ] - ) rest - ); - Doc.line; - Doc.text ": "; - Doc.indent (printTernaryOperand alternate); - ] - ) - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = match attrs with | [] -> false | _ -> true in - Doc.concat [ - printAttributes attrs; - if needsParens then addParens ternaryDoc else ternaryDoc; - ] - else - let (ifs, elseExpr) = ParsetreeViewer.collectIfExpressions e in - let ifDocs = Doc.join ~sep:Doc.space ( - List.mapi (fun i (ifExpr, thenExpr) -> - let ifTxt = if i > 0 then Doc.text "else if " else Doc.text "if " in - let condition = printExpression ifExpr in - Doc.concat [ - ifTxt; - Doc.group ( - Doc.ifBreaks (addParens condition) condition; - ); - Doc.space; - printExpressionBlock ~braces:true thenExpr; - ] - ) ifs - ) in - let elseDoc = match elseExpr with - | None -> Doc.nil - | Some expr -> Doc.concat [ - Doc.text " else "; - printExpressionBlock ~braces:true expr; - ] - in - Doc.concat [ - printAttributes e.pexp_attributes; - ifDocs; - elseDoc; - ] - | Pexp_while (expr1, expr2) -> - let condition = printExpression expr1 in - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "while "; - Doc.group ( - Doc.ifBreaks (addParens condition) condition - ); - Doc.space; - printExpressionBlock ~braces:true expr2; - ] - ) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.text "for "; - printPattern pattern; - Doc.text " in "; - printExpression fromExpr; - printDirectionFlag directionFlag; - printExpression toExpr; - Doc.space; - printExpressionBlock ~braces:true body; - ] - ) - | Pexp_constraint( - {pexp_desc = Pexp_pack modExpr}, - {ptyp_desc = Ptyp_package packageType} - ) -> - Doc.group ( - Doc.concat [ - Doc.text "module("; - Doc.indent ( - Doc.concat [ - Doc.softLine; - printModExpr modExpr; - Doc.text ": "; - printPackageType ~printModuleKeywordAndParens:false packageType; - ] - ); - Doc.softLine; - Doc.rparen; - ] - ) - - | Pexp_constraint (expr, typ) -> - Doc.concat [ - printExpression expr; - Doc.text ": "; - printTypExpr typ; - ] - | Pexp_letmodule ({txt = modName}, modExpr, expr) -> - printExpressionBlock ~braces:true e - - | Pexp_letexception (extensionConstructor, expr) -> - printExpressionBlock ~braces:true e - | Pexp_assert expr -> - let rhs = - let doc = printExpression expr in - if Parens.lazyOrAssertExprRhs expr then addParens doc else doc - in - Doc.concat [ - Doc.text "assert "; - rhs; - ] - | Pexp_lazy expr -> - let rhs = - let doc = printExpression expr in - if Parens.lazyOrAssertExprRhs expr then addParens doc else doc - in - Doc.concat [ - Doc.text "lazy "; - rhs; - ] - | Pexp_open (overrideFlag, longidentLoc, expr) -> - printExpressionBlock ~braces:true e - | Pexp_pack (modExpr) -> - Doc.group (Doc.concat [ - Doc.text "module("; - Doc.indent ( - Doc.concat [ - Doc.softLine; - printModExpr modExpr; - ] - ); - Doc.softLine; - Doc.rparen; - ]) - | Pexp_sequence _ -> - printExpressionBlock ~braces:true e - | Pexp_let _ -> - printExpressionBlock ~braces:true e - | Pexp_fun _ | Pexp_newtype _ -> - let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in - let (uncurried, attrs) = - ParsetreeViewer.processUncurriedAttribute attrsOnArrow - in - let (returnExpr, typConstraint) = match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> (expr, Some typ) - | _ -> (returnExpr, None) - in - let parametersDoc = printExprFunParameters ~inCallback:false ~uncurried parameters in - let returnExprDoc = - let shouldInline = match returnExpr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ -> true - | _ -> false - in - let shouldIndent = match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ -> false - | _ -> true - in - let returnDoc = printExpression returnExpr in - if shouldInline then Doc.concat [ - Doc.space; - returnDoc; - ] else - Doc.group ( - if shouldIndent then - Doc.indent ( - Doc.concat [ - Doc.line; - returnDoc; - ] - ) - else - Doc.concat [ - Doc.space; - returnDoc - ] - ) - in - let typConstraintDoc = match typConstraint with - | Some(typ) -> Doc.concat [Doc.text ": "; printTypExpr typ] - | _ -> Doc.nil - in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.space; - ] - in - Doc.group ( - Doc.concat [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ] - ) - | Pexp_try (expr, cases) -> - Doc.concat [ - Doc.text "try "; - printExpression expr; - Doc.text " catch "; - printCases cases; - ] - | Pexp_match (expr, cases) -> - Doc.concat [ - Doc.text "switch "; - printExpression expr; - Doc.space; - printCases cases; - ] - | _ -> failwith "expression not yet implemented in printer" - in - let shouldPrintItsOwnAttributes = match e.pexp_desc with - | Pexp_apply _ - | Pexp_fun _ - | Pexp_newtype _ - | Pexp_setfield _ - | Pexp_ifthenelse _ -> true - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> true - | _ -> false - in - begin match e.pexp_attributes with - | [] -> printedExpression - | attrs when not shouldPrintItsOwnAttributes -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - printedExpression; - ] - ) - | _ -> printedExpression - end - - and printPexpFun ~inCallback e = - let (attrsOnArrow, parameters, returnExpr) = ParsetreeViewer.funExpr e in - let (uncurried, attrs) = - ParsetreeViewer.processUncurriedAttribute attrsOnArrow - in - let (returnExpr, typConstraint) = match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> (expr, Some typ) - | _ -> (returnExpr, None) - in - let parametersDoc = printExprFunParameters ~inCallback ~uncurried parameters in - let returnShouldIndent = match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ -> false - | _ -> true - in - let returnExprDoc = - let shouldInline = match returnExpr.pexp_desc with - | Pexp_array _ - | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ -> true - | _ -> false - in - let returnDoc = printExpression returnExpr in - if shouldInline then Doc.concat [ - Doc.space; - returnDoc; - ] else - Doc.group ( - if returnShouldIndent then - Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.line; - returnDoc; - ] - ); - if inCallback then Doc.softLine else Doc.nil; - ] - else - Doc.concat [ - Doc.space; - returnDoc; - ] - ) - in - let typConstraintDoc = match typConstraint with - | Some(typ) -> Doc.concat [Doc.text ": "; printTypExpr typ] - | _ -> Doc.nil - in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.space; - ] - in - Doc.group ( - Doc.concat [ - attrs; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ] - ) - - and printTernaryOperand expr = - let doc = printExpression expr in - if Parens.ternaryOperand expr then addParens doc else doc - - and printSetFieldExpr attrs lhs longidentLoc rhs = - let rhsDoc = - let doc = printExpression rhs in - if Parens.setFieldExprRhs rhs then addParens doc else doc - in - let lhsDoc = - let doc = printExpression lhs in - if Parens.fieldExpr lhs then addParens doc else doc - in - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = Doc.concat [ - lhsDoc; - Doc.dot; - printLongident longidentLoc.txt; - Doc.text " ="; - if shouldIndent then Doc.group ( - Doc.indent ( - (Doc.concat [Doc.line; rhsDoc]) - ) - ) else - Doc.concat [Doc.space; rhsDoc] - ] in - match attrs with - | [] -> doc - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - doc - ] - ) - - and printUnaryExpression expr = - let printUnaryOperator op = Doc.text ( - match op with - | "~+" -> "+" - | "~+." -> "+." - | "~-" -> "-" - | "~-." -> "-." - | "not" -> "!" - | "!" -> "&" - | _ -> assert false - ) in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, operand] - ) -> - let printedOperand = - let doc = printExpression operand in - if Parens.unaryExprOperand operand then addParens doc else doc - in - Doc.concat [ - printUnaryOperator operator; - printedOperand; - ] - | _ -> assert false - - and printBinaryExpression (expr : Parsetree.expression) = - let printBinaryOperator ~inlineRhs operator = - let operatorTxt = match operator with - | "|." -> "->" - | "^" -> "++" - | "=" -> "==" - | "==" -> "===" - | "<>" -> "!=" - | "!=" -> "!==" - | txt -> txt - in - let spacingBeforeOperator = - if operator = "|." then Doc.softLine - else if operator = "|>" then Doc.line - else Doc.space; - in - let spacingAfterOperator = - if operator = "|." then Doc.nil - else if operator = "|>" then Doc.space - else if inlineRhs then Doc.space else Doc.line - in - Doc.concat [ - spacingBeforeOperator; - Doc.text operatorTxt; - spacingAfterOperator; - ] - in - let printOperand ~isLhs expr parentOperator = - let rec flatten ~isLhs expr parentOperator = - if ParsetreeViewer.isBinaryExpression expr then - begin match expr with - | {pexp_desc = Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [_, left; _, right] - )} -> - if ParsetreeViewer.flattenableOperators parentOperator operator && - not (ParsetreeViewer.hasAttributes expr.pexp_attributes) then - let leftPrinted = flatten ~isLhs:true left operator in - let rightPrinted = - let (_, rightAttrs) = - ParsetreeViewer.partitionPrinteableAttributes right.pexp_attributes - in - let doc = - printExpression {right with pexp_attributes = rightAttrs } in - let doc = if Parens.flattenOperandRhs parentOperator right then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else - doc - in - let printeableAttrs = - ParsetreeViewer.filterPrinteableAttributes right.pexp_attributes - in - Doc.concat [printAttributes printeableAttrs; doc] - in - Doc.concat [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - else - let doc = printExpression {expr with pexp_attributes = []} in - let doc = if Parens.subBinaryExprOperand parentOperator operator || - (expr.pexp_attributes <> [] && - (ParsetreeViewer.isBinaryExpression expr || - ParsetreeViewer.isTernaryExpr expr)) then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in Doc.concat [ - printAttributes expr.pexp_attributes; - doc - ] - | _ -> assert false - end - else - begin match expr.pexp_desc with - | Pexp_setfield (lhs, field, rhs) -> - let doc = printSetFieldExpr expr.pexp_attributes lhs field rhs in - if isLhs then addParens doc else doc - | Pexp_apply( - {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] - ) -> - let rhsDoc = printExpression rhs in - let lhsDoc = printExpression lhs in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = Doc.group( - Doc.concat [ - lhsDoc; - Doc.text " ="; - if shouldIndent then Doc.group ( - Doc.indent (Doc.concat [Doc.line; rhsDoc]) - ) else - Doc.concat [Doc.space; rhsDoc] - ] - ) in - let doc = match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - doc - ] - ) - in - if isLhs then addParens doc else doc - | _ -> - let doc = printExpression expr in - if Parens.binaryExprOperand ~isLhs expr parentOperator then - addParens doc - else doc - end - in - flatten ~isLhs expr parentOperator - in - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident (("|." | "|>") as op)}}, - [Nolabel, lhs; Nolabel, rhs] - ) when not ( - ParsetreeViewer.isBinaryExpression lhs || - ParsetreeViewer.isBinaryExpression rhs - ) -> - let lhsDoc = printOperand ~isLhs:true lhs op in - let rhsDoc = printOperand ~isLhs:false rhs op in - Doc.concat [ - lhsDoc; - (match op with - | "|." -> Doc.text "->" - | "|>" -> Doc.text " |> " - | _ -> assert false); - rhsDoc; - ] - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [Nolabel, lhs; Nolabel, rhs] - ) -> - let right = - let operatorWithRhs = Doc.concat [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) operator; - printOperand ~isLhs:false rhs operator; - ] in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = Doc.group ( - Doc.concat [ - printOperand ~isLhs:true lhs operator; - right - ] - ) in - Doc.concat [ - printAttributes expr.pexp_attributes; - if Parens.binaryExpr expr then addParens doc else doc - ] - | _ -> Doc.nil - - (* callExpr(arg1, arg2)*) - and printPexpApply expr = - match expr.pexp_desc with - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [Nolabel, parentExpr; Nolabel, memberExpr] - ) -> - let member = - let memberDoc = printExpression memberExpr in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes; - printExpression parentExpr; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [Nolabel, lhs; Nolabel, rhs] - ) -> - let rhsDoc = printExpression rhs in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = Doc.group( - Doc.concat [ - printExpression lhs; - Doc.text " ="; - if shouldIndent then Doc.group ( - Doc.indent ( - (Doc.concat [Doc.line; rhsDoc]) - ) - ) else - Doc.concat [Doc.space; rhsDoc] - ] - ) in - begin match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group ( - Doc.concat [ - printAttributes attrs; - doc - ] - ) - end - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [Nolabel, parentExpr; Nolabel, memberExpr] - ) -> - let member = - let memberDoc = printExpression memberExpr in - let shouldInline = match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc else ( - Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - memberDoc; - ] - ); - Doc.softLine - ] - ) - in - Doc.group (Doc.concat [ - printAttributes expr.pexp_attributes; - printExpression parentExpr; - Doc.lbracket; - member; - Doc.rbracket; - ]) - (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ( - {pexp_desc = Pexp_ident {txt = lident}}, - args - ) when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression lident args - | Pexp_apply (callExpr, args) -> - let (uncurried, attrs) = - ParsetreeViewer.processUncurriedAttribute expr.pexp_attributes - in - let callExprDoc = printExpression callExpr in - if ParsetreeViewer.requiresSpecialCallbackPrinting args then - let argsDoc = printArgumentsWithCallback ~uncurried args in - Doc.concat [ - printAttributes attrs; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~uncurried args in - Doc.concat [ - printAttributes attrs; - callExprDoc; - argsDoc; - ] - | _ -> assert false - - and printJsxExpression lident args = - let name = printJsxName lident in - let (formattedProps, children) = formatJsxProps args in - (*
*) - let isSelfClosing = match children with | [] -> true | _ -> false in - Doc.group ( - Doc.concat [ - Doc.group ( - Doc.concat [ - Doc.lessThan; - name; - formattedProps; - if isSelfClosing then Doc.concat [Doc.line; Doc.text "/>"] else Doc.nil - ] - ); - if isSelfClosing then Doc.nil - else - Doc.concat [ - Doc.greaterThan; - Doc.indent ( - Doc.concat [ - Doc.line; - printJsxChildren children; - ] - ); - Doc.line; - Doc.text "" in - let closing = Doc.text "" in - let (children, _) = ParsetreeViewer.collectListExpressions expr in - Doc.group ( - Doc.concat [ - opening; - begin match children with - | [] -> Doc.nil - | children -> - Doc.indent ( - Doc.concat [ - Doc.line; - printJsxChildren children; - ] - ) - end; - Doc.line; - closing; - ] - ) - - and printJsxChildren (children: Parsetree.expression list) = - Doc.group ( - Doc.join ~sep:Doc.line ( - List.map (fun expr -> - let exprDoc = printExpression expr in - if Parens.jsxChildExpr expr then addBraces exprDoc else exprDoc - ) children - ) - ) - - and formatJsxProps args = - let rec loop props args = - match args with - | [] -> (Doc.nil, []) - | [ - (Asttypes.Labelled "children", children); - ( - Asttypes.Nolabel, - {Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} - ) - ] -> - let formattedProps = Doc.indent ( - match props with - | [] -> Doc.nil - | props -> - Doc.concat [ - Doc.line; - Doc.group ( - Doc.join ~sep:Doc.line (props |> List.rev) - ) - ] - ) in - let (children, _) = ParsetreeViewer.collectListExpressions children in - (formattedProps, children) - | arg::args -> - let propDoc = formatJsxProp arg in - loop (propDoc::props) args - in - loop [] args - - and formatJsxProp arg = - match arg with - | ( - (Asttypes.Labelled lblTxt | Optional lblTxt) as lbl, - { - Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident ident} - } - ) when lblTxt = ident (* jsx punning *) -> - - begin match lbl with - | Nolabel -> Doc.nil - | Labelled lbl -> Doc.text lbl - | Optional lbl -> Doc.text ("?" ^ lbl) - end - | (lbl, expr) -> - let lblDoc = match lbl with - | Asttypes.Labelled lbl -> Doc.text (lbl ^ "=") - | Asttypes.Optional lbl -> Doc.text (lbl ^ "=?") - | Nolabel -> Doc.nil - in - let exprDoc = printExpression expr in - Doc.concat [ - lblDoc; - if Parens.jsxPropExpr expr then addBraces exprDoc else exprDoc; - ] - - (* div -> div. - * Navabar.createElement -> Navbar - * Staff.Users.createElement -> Staff.Users *) - and printJsxName lident = - let rec flatten acc lident = match lident with - | Longident.Lident txt -> txt::acc - | Ldot (lident, txt) -> - let acc = if txt = "createElement" then acc else txt::acc in - flatten acc lident - | _ -> acc - in - match lident with - | Longident.Lident txt -> Doc.text txt - | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot (List.map Doc.text segments) - - and printArgumentsWithCallback ~uncurried args = - let rec loop acc args = match args with - | [] -> (Doc.nil, Doc.nil) - | [_lbl, expr] -> - let callback = printPexpFun ~inCallback:true expr in - (Doc.concat (List.rev acc), callback) - | arg::args -> - let argDoc = printArgument arg in - loop (Doc.line::Doc.comma::argDoc::acc) args - in - let (printedArgs, callback) = loop [] args in - - (* Thing.map(foo,(arg1, arg2) => MyModuleBlah.toList(argument)) *) - let fitsOnOneLine = Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - Doc.concat [ - printedArgs; - callback; - ]; - Doc.rparen; - ] in - - (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => - * MyModuleBlah.toList(argument) - * ) - *) - let arugmentsFitOnOneLine = - Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - Doc.concat [ - Doc.softLine; - printedArgs; - Doc.breakableGroup ~forceBreak:true callback; - ]; - Doc.softLine; - Doc.rparen; - ] - in - - (* Thing.map( - * arg1, - * arg2, - * arg3, - * (param1, parm2) => doStuff(param1, parm2) - * ) - *) - let breakAllArgs = printArguments ~uncurried args in - Doc.customLayout [ - fitsOnOneLine; - arugmentsFitOnOneLine; - breakAllArgs; - ] - - and printArguments ~uncurried (args : (Asttypes.arg_label * Parsetree.expression) list) = - match args with - | [Nolabel, {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}] -> - if uncurried then Doc.text "(.)" else Doc.text "()" - | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> - Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - printExpression arg; - Doc.rparen; - ] - | args -> Doc.group ( - Doc.concat [ - if uncurried then Doc.text "(." else Doc.lparen; - Doc.indent ( - Doc.concat [ - if uncurried then Doc.line else Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printArgument args - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - -(* - * argument ::= - * | _ (* syntax sugar *) - * | expr - * | expr : type - * | ~ label-name - * | ~ label-name - * | ~ label-name ? - * | ~ label-name = expr - * | ~ label-name = _ (* syntax sugar *) - * | ~ label-name = expr : type - * | ~ label-name = ? expr - * | ~ label-name = ? _ (* syntax sugar *) - * | ~ label-name = ? expr : type *) - and printArgument ((argLbl, arg) : Asttypes.arg_label * Parsetree.expression) = - match (argLbl, arg) with - (* ~a (punned)*) - | ( - (Asttypes.Labelled lbl), - {pexp_desc=Pexp_ident {txt =Longident.Lident name}} - ) when lbl = name -> - Doc.text ("~" ^ lbl) - (* ~a? (optional lbl punned)*) - | ( - (Asttypes.Optional lbl), - {pexp_desc=Pexp_ident {txt =Longident.Lident name}} - ) when lbl = name -> - Doc.text ("~" ^ lbl ^ "?") - | (lbl, expr) -> - let printedLbl = match argLbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled lbl -> Doc.text ("~" ^ lbl ^ "=") - | Asttypes.Optional lbl -> Doc.text ("~" ^ lbl ^ "=?") - in - let printedExpr = printExpression expr in - Doc.concat [ - printedLbl; - printedExpr; - ] - - and printCases (cases: Parsetree.case list) = - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.concat [ - Doc.line; - Doc.join ~sep:Doc.line ( - List.map printCase cases - ) - ]; - Doc.line; - Doc.rbrace; - ] - ) - - and printCase (case: Parsetree.case) = - let rhs = match case.pc_rhs.pexp_desc with - | Pexp_let _ - | Pexp_letmodule _ - | Pexp_letexception _ - | Pexp_open _ - | Pexp_sequence _ -> - printExpressionBlock ~braces:false case.pc_rhs - | _ -> printExpression case.pc_rhs - in - let guard = match case.pc_guard with - | None -> Doc.nil - | Some expr -> Doc.group ( - Doc.concat [ - Doc.line; - Doc.text "when "; - printExpression expr; - ] - ) - in - Doc.group ( - Doc.concat [ - Doc.text "| "; - Doc.indent ( - Doc.concat [ - printPattern case.pc_lhs; - guard; - Doc.text " =>"; - Doc.line; - rhs; - ] - ); - ] - ) - - and printExprFunParameters ~inCallback ~uncurried parameters = - match parameters with - (* let f = _ => () *) - | [([], Asttypes.Nolabel, None, {Parsetree.ppat_desc = Ppat_any})] when not uncurried -> - Doc.text "_" - (* let f = a => () *) - | [([], Asttypes.Nolabel, None, {Parsetree.ppat_desc = Ppat_var stringLoc})] when not uncurried -> - Doc.text stringLoc.txt - (* let f = () => () *) - | [([], Nolabel, None, {ppat_desc = Ppat_construct({txt = Longident.Lident "()"}, None)})] when not uncurried -> - Doc.text "()" - (* let f = (~greeting, ~from as hometown, ~x=?) => () *) - | parameters -> - let lparen = if uncurried then Doc.text "(. " else Doc.lparen in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = Doc.concat [ - if shouldHug || inCallback then Doc.nil else Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; if inCallback then Doc.space else Doc.line]) - (List.map printExpFunParameter parameters) - ] in - Doc.group ( - Doc.concat [ - lparen; - if shouldHug || inCallback then printedParamaters else Doc.indent (printedParamaters); - if shouldHug || inCallback then Doc.nil else Doc.concat [Doc.trailingComma; Doc.softLine]; - Doc.rparen; - ] - ) - - and printExpFunParameter (attrs, lbl, defaultExpr, pattern) = - let (isUncurried, attrs) = ParsetreeViewer.processUncurriedAttribute attrs in - let uncurried = if isUncurried then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - (* =defaultValue *) - let defaultExprDoc = match defaultExpr with - | Some expr -> Doc.concat [ - Doc.text "="; - printExpression expr - ] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = match (lbl, pattern) with - | (Asttypes.Nolabel, pattern) -> printPattern pattern - | ( - (Asttypes.Labelled lbl | Optional lbl), - {ppat_desc = Ppat_var stringLoc} - ) when lbl = stringLoc.txt -> - Doc.concat [ - Doc.text "~"; - Doc.text lbl; - ] - | ((Asttypes.Labelled lbl | Optional lbl), pattern) -> - Doc.concat [ - Doc.text "~"; - Doc.text lbl; - Doc.text " as "; - printPattern pattern; - ] - in - let optionalLabelSuffix = match (lbl, defaultExpr) with - | (Asttypes.Optional _, None) -> Doc.text "=?" - | _ -> Doc.nil - in - Doc.group ( - Doc.concat [ - uncurried; - attrs; - labelWithPattern; - defaultExprDoc; - optionalLabelSuffix; - ] - ) - - (* - * let x = { - * module Foo = Bar - * exception Exit - * open Belt - * let a = 1 - * let b = 2 - * sideEffect() - * a + b - * } - * What is an expr-block ? Everything between { ... } - *) - and printExpressionBlock ~braces expr = - let rec collectRows acc expr = match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_letmodule ({txt = modName; loc = modLoc}, modExpr, expr) -> - let letModuleDoc = Doc.concat [ - Doc.text "module "; - Doc.text modName; - Doc.text " = "; - printModExpr modExpr; - ] in - let loc = {modLoc with loc_end = modExpr.pmod_loc.loc_end} in - collectRows ((loc, letModuleDoc)::acc) expr - | Pexp_letexception (extensionConstructor, expr) -> - let letExceptionDoc = printExceptionDef extensionConstructor in - let loc = extensionConstructor.pext_loc in - collectRows ((loc, letExceptionDoc)::acc) expr - | Pexp_open (overrideFlag, longidentLoc, expr) -> - let openDoc = Doc.concat [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongident longidentLoc.txt; - ] in - let loc = longidentLoc.loc in - collectRows ((loc, openDoc)::acc) expr - | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression expr1 in - if Parens.blockExpr expr1 then addParens doc else doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc)::acc) expr2 - | Pexp_let (recFlag, valueBindings, expr) -> - let recFlag = match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = printValueBindings ~recFlag valueBindings in - let loc = match (valueBindings, List.rev valueBindings) with - | ({pvb_loc = firstLoc}::_,{pvb_loc = lastLoc}::_) -> - {firstLoc with loc_end = lastLoc.loc_end} - | _ -> Location.none - in - collectRows((loc, letDoc)::acc) expr - | _ -> - let exprDoc = - let doc = printExpression expr in - if Parens.blockExpr expr then addParens doc else doc - in - List.rev ((expr.pexp_loc, exprDoc)::acc) - in - let block = collectRows [] expr |> interleaveWhitespace ~forceBreak:true in - Doc.breakableGroup ~forceBreak:true ( - if braces then - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.line; - block; - ] - ); - Doc.line; - Doc.rbrace; - ] - else block - ) - - and printOverrideFlag overrideFlag = match overrideFlag with - | Asttypes.Override -> Doc.text "!" - | Fresh -> Doc.nil - - and printDirectionFlag flag = match flag with - | Asttypes.Downto -> Doc.text " downto " - | Asttypes.Upto -> Doc.text " to " - - and printRecordRow (lbl, expr) = - Doc.concat [ - printLongident lbl.txt; - Doc.text ": "; - printExpression expr; - ] - - and printBsObjectRow (lbl, expr) = - Doc.concat [ - Doc.text "\""; - printLongident lbl.txt; - Doc.text "\""; - Doc.text ": "; - printExpression expr; - ] - (* The optional loc indicates whether we need to print the attributes in - * relation to some location. In practise this means the following: - * `@attr type t = string` -> on the same line, print on the same line - * `@attr - * type t = string` -> attr is on prev line, print the attributes - * with a line break between, we respect the users' original layout *) - and printAttributes ?loc (attrs: Parsetree.attributes) = - match attrs with - | [] -> Doc.nil - | attrs -> - let lineBreak = match loc with - | None -> Doc.line - | Some loc -> begin match List.rev attrs with - | ({loc = firstLoc}, _)::_ when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.literalLine; - | _ -> Doc.line - end - in - Doc.concat [ - Doc.group (Doc.join ~sep:Doc.line (List.map printAttribute attrs)); - lineBreak; - ] - - and printAttribute ((id, payload) : Parsetree.attribute) = - let attrName = Doc.text ("@" ^ id.txt) in - match payload with - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpression expr in - let needsParens = match attrs with | [] -> false | _ -> true in - Doc.group ( - Doc.concat [ - attrName; - addParens ( - Doc.concat [ - printAttributes attrs; - if needsParens then addParens exprDoc else exprDoc; - ] - ) - ] - ) - | _ -> attrName - - - and printModExpr modExpr = - match modExpr.pmod_desc with - | Pmod_ident longidentLoc -> - printLongident longidentLoc.txt - | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true ( - Doc.concat [ - Doc.lbrace; - Doc.indent ( - Doc.concat [ - Doc.softLine; - printStructure structure; - ]; - ); - Doc.softLine; - Doc.rbrace; - ] - ) - | Pmod_unpack expr -> - let shouldHug = match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint ( - {pexp_desc = Pexp_let _ }, - {ptyp_desc = Ptyp_package packageType} - ) -> true - | _ -> false - in - let (expr, moduleConstraint) = match expr.pexp_desc with - | Pexp_constraint ( - expr, - {ptyp_desc = Ptyp_package packageType} - ) -> - let typeDoc = Doc.group (Doc.concat [ - Doc.text ":"; - Doc.indent ( - Doc.concat [ - Doc.line; - printPackageType ~printModuleKeywordAndParens:false packageType - ] - ) - ]) in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = Doc.group(Doc.concat [ - printExpression expr; - moduleConstraint; - ]) in - Doc.group ( - Doc.concat [ - Doc.text "unpack("; - if shouldHug then unpackDoc - else - Doc.concat [ - Doc.indent ( - Doc.concat [ - Doc.softLine; - unpackDoc; - ] - ); - Doc.softLine; - ]; - Doc.rparen; - ] - ) - | Pmod_extension extension -> - printExtension extension - | Pmod_apply _ -> - let (args, callExpr) = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = match args with - | [{pmod_desc = Pmod_structure []}] -> true - | _ -> false - in - let shouldHug = match args with - | [{pmod_desc = Pmod_structure _}] -> true - | _ -> false - in - Doc.group ( - Doc.concat [ - printModExpr callExpr; - if isUnitSugar then - printModApplyArg (List.hd args) - else - Doc.concat [ - Doc.lparen; - if shouldHug then - printModApplyArg (List.hd args) - else - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printModApplyArg args - ) - ] - ); - if not shouldHug then - Doc.concat [ - Doc.trailingComma; - Doc.softLine; - ] - else Doc.nil; - Doc.rparen; - ] - ] - ) - | Pmod_constraint (modExpr, modType) -> - Doc.concat [ - printModExpr modExpr; - Doc.text ": "; - printModType modType; - ] - | Pmod_functor _ -> - printModFunctor modExpr - - and printModFunctor modExpr = - let (parameters, returnModExpr) = ParsetreeViewer.modExprFunctor modExpr in - (* let shouldInline = match returnModExpr.pmod_desc with *) - (* | Pmod_structure _ | Pmod_ident _ -> true *) - (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) - (* | _ -> false *) - (* in *) - let (returnConstraint, returnModExpr) = match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType modType in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [ - Doc.text ": "; - constraintDoc; - ] in - (modConstraint, printModExpr modExpr) - | _ -> (Doc.nil, printModExpr returnModExpr) - in - let parametersDoc = match parameters with - | [(attrs, {txt = "*"}, None)] -> - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - Doc.group (Doc.concat [ - attrs; - Doc.text "()" - ]) - | [([], {txt = lbl}, None)] -> Doc.text lbl - | parameters -> - Doc.group ( - Doc.concat [ - Doc.lparen; - Doc.indent ( - Doc.concat [ - Doc.softLine; - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) ( - List.map printModFunctorParam parameters - ) - ] - ); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - ) - in - Doc.group ( - Doc.concat [ - parametersDoc; - returnConstraint; - Doc.text " => "; - returnModExpr - - ] - ) - - and printModFunctorParam (attrs, lbl, optModType) = - let attrs = match attrs with - | [] -> Doc.nil - | attrs -> Doc.concat [ - Doc.join ~sep:Doc.line (List.map printAttribute attrs); - Doc.line; - ] in - Doc.group ( - Doc.concat [ - attrs; - Doc.text lbl.txt; - (match optModType with - | None -> Doc.nil - | Some modType -> - Doc.concat [ - Doc.text ": "; - printModType modType - ]); - ] - ) - - and printModApplyArg modExpr = - match modExpr.pmod_desc with - | Pmod_structure [] -> Doc.text "()" - | _ -> printModExpr modExpr - - - and printExceptionDef (constr : Parsetree.extension_constructor) = - let kind = match constr.pext_kind with - | Pext_rebind {txt = longident} -> Doc.indent ( - Doc.concat [ - Doc.text " ="; - Doc.line; - printLongident longident; - ] - ) - | Pext_decl (Pcstr_tuple [], None) -> Doc.nil - | Pext_decl (args, gadt) -> - let gadtDoc = match gadt with - | Some typ -> Doc.concat [ - Doc.text ": "; - printTypExpr typ; - ] - | None -> Doc.nil - in - Doc.concat [ - printConstructorArguments args; - gadtDoc - ] - in - Doc.group ( - Doc.concat [ - printAttributes constr.pext_attributes; - Doc.text "exception "; - Doc.text constr.pext_name.txt; - kind - ] - ) - - and printExtensionConstructor i (constr : Parsetree.extension_constructor) = - let attrs = printAttributes constr.pext_attributes in - let bar = if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil - in - let kind = match constr.pext_kind with - | Pext_rebind {txt = longident} -> Doc.indent ( - Doc.concat [ - Doc.text " ="; - Doc.line; - printLongident longident; - ] - ) - | Pext_decl (Pcstr_tuple [], None) -> Doc.nil - | Pext_decl (args, gadt) -> - let gadtDoc = match gadt with - | Some typ -> Doc.concat [ - Doc.text ": "; - printTypExpr typ; - ] - | None -> Doc.nil - in - Doc.concat [ - printConstructorArguments args; - gadtDoc - ] - in - Doc.concat [ - bar; - Doc.group ( - Doc.concat [ - attrs; - Doc.text constr.pext_name.txt; - kind; - ] - ) - ] - - let printImplementation (s: Parsetree.structure) comments src = - let t = CommentAst.initStructure s comments in - - let stringDoc = Doc.toString ~width:80 (printStructure s) in - print_endline stringDoc; - print_newline() - - let printInterface (s: Parsetree.signature) = - let stringDoc = Doc.toString ~width:80 (printSignature s) in - print_endline stringDoc; - print_newline() -end - diff --git a/jscomp/syntax/benchmarks/data/RedBlackTree.ml b/jscomp/syntax/benchmarks/data/RedBlackTree.ml deleted file mode 100644 index 6e2551c..0000000 --- a/jscomp/syntax/benchmarks/data/RedBlackTree.ml +++ /dev/null @@ -1,498 +0,0 @@ -type nonrec nodeColor = - | Red - | Black -type 'value node = - { - mutable left: 'value node option ; - mutable right: 'value node option ; - mutable parent: 'value node option ; - mutable sum: float ; - mutable color: nodeColor ; - mutable height: float ; - mutable value: 'value } -type nonrec 'value t = - { - mutable size: int ; - mutable root: 'value node option ; - compare: (('value -> 'value -> int)[@bs ]) } -let createNode ~color ~value ~height = - { left = None; right = None; parent = None; sum = 0.; height; value; color - } -external castNotOption : 'a option -> 'a = "%identity" -let updateSum node = - let leftSum = match node.left with | None -> 0. | Some left -> left.sum in - let rightSum = match node.right with | None -> 0. | Some right -> right.sum in - node.sum <- ((leftSum +. rightSum) +. node.height) -let rec updateSumRecursive rbt node = - updateSum node; - (match node.parent with - | None -> () - | Some parent -> rbt |. (updateSumRecursive parent)) -let grandParentOf node = - match node.parent with | None -> None | Some ref_ -> ref_.parent -let isLeft node = - match node.parent with - | None -> false - | Some parent -> (Some node) == parent.left -let leftOrRightSet ~node x value = - ((if isLeft node then x.left <- value else x.right <- value)[@res.ternary ]) -let siblingOf node = - if isLeft node - then (castNotOption node.parent).right - else (castNotOption node.parent).left -let uncleOf node = - match grandParentOf node with - | None -> None - | Some grandParentOfNode -> - if isLeft (castNotOption node.parent) - then grandParentOfNode.right - else grandParentOfNode.left -let rec findNode rbt node value = - match node with - | None -> None - | Some node -> - let cmp = ((rbt.compare value node.value)[@bs ]) in - if cmp == 0 - then Some node - else - if cmp < 0 - then findNode rbt node.left value - else findNode rbt node.right value -let has rbt value = (findNode rbt rbt.root value) != None -let rec peekMinNode node = - match node with - | None -> None - | Some node -> - ((if node.left == None then Some node else node.left |. peekMinNode) - [@res.ternary ]) -let rec peekMaxNode node = - match node with - | None -> None - | Some node -> - ((if node.right == None then Some node else node.right |. peekMaxNode) - [@res.ternary ]) -let rotateLeft rbt node = - let parent = node.parent in - let right = node.right in - (match parent with - | Some parent -> parent |. (leftOrRightSet ~node right) - | None -> rbt.root <- right); - node.parent <- right; - (let right = right |. castNotOption in - let rightLeft = right.left in - node.right <- rightLeft; - (match rightLeft with - | Some rightLeft -> rightLeft.parent <- (Some node) - | None -> ()); - right.parent <- parent; - right.left <- (Some node); - updateSum node; - updateSum right) -let rotateRight rbt node = - let parent = node.parent in - let left = node.left in - (match parent with - | Some parent -> parent |. (leftOrRightSet ~node left) - | None -> rbt.root <- left); - node.parent <- left; - (let left = left |. castNotOption in - let leftRight = left.right in - node.left <- leftRight; - (match leftRight with - | Some leftRight -> leftRight.parent <- (Some node) - | None -> ()); - left.parent <- parent; - left.right <- (Some node); - updateSum node; - updateSum left) -let rec findInsert rbt node nodeToInsert value = - match node with - | None -> None - | Some node -> - let cmp = ((rbt.compare value node.value)[@bs ]) in - if cmp == 0 - then Some node - else - if cmp < 0 - then - (if node.left != None - then rbt |. (findInsert node.left nodeToInsert value) - else - (nodeToInsert.parent <- (Some node); - node.left <- (Some nodeToInsert); - None)) - else - if node.right != None - then rbt |. (findInsert node.right nodeToInsert value) - else - (nodeToInsert.parent <- (Some node); - node.right <- (Some nodeToInsert); - None) -let rec _addLoop rbt currentNode = - if (Some currentNode) == rbt.root - then currentNode.color <- Black - else - if (currentNode.parent |. castNotOption).color == Black - then () - else - if - (let uncle = uncleOf currentNode in - (uncle != None) && ((uncle |. castNotOption).color == Red)) - then - ((currentNode.parent |. castNotOption).color <- Black; - ((uncleOf currentNode) |. castNotOption).color <- Black; - ((grandParentOf currentNode) |. castNotOption).color <- Red; - _addLoop rbt ((grandParentOf currentNode) |. castNotOption)) - else - (let currentNode = - if - (not (isLeft currentNode)) && - (isLeft (currentNode.parent |. castNotOption)) - then - (rotateLeft rbt (currentNode.parent |. castNotOption); - currentNode.left |. castNotOption) - else - if - (isLeft currentNode) && - (not (isLeft (currentNode.parent |. castNotOption))) - then - (rotateRight rbt (currentNode.parent |. castNotOption); - currentNode.right |. castNotOption) - else currentNode in - (currentNode.parent |. castNotOption).color <- Black; - ((grandParentOf currentNode) |. castNotOption).color <- Red; - if isLeft currentNode - then rotateRight rbt ((grandParentOf currentNode) |. castNotOption) - else rotateLeft rbt ((grandParentOf currentNode) |. castNotOption)) -let add rbt value ~height = - rbt.size <- (rbt.size + 1); - (let nodeToInsert = createNode ~value ~color:Red ~height in - let inserted = - if rbt.root == None - then (rbt.root <- (Some nodeToInsert); true) - else - (let foundNode = findInsert rbt rbt.root nodeToInsert value in - foundNode == None) in - if inserted - then - (rbt |. (updateSumRecursive nodeToInsert); - _addLoop rbt nodeToInsert; - Some nodeToInsert) - else None) -let removeNode rbt node = - let nodeToRemove = - match ((node.left), (node.right)) with - | (Some _, Some _) -> - let successor = (peekMinNode node.right) |. castNotOption in - (node.value <- (successor.value); - node.height <- (successor.height); - successor) - | _ -> node in - let successor = - match nodeToRemove.left with | None -> nodeToRemove.right | left -> left in - let (successor, isLeaf) = - match successor with - | None -> - let leaf = createNode ~value:([%bs.raw "0"]) ~color:Black ~height:0. in - let isLeaf = ((fun x -> x == leaf)[@bs ]) in (leaf, isLeaf) - | Some successor -> (successor, (((fun _ -> false))[@bs ])) in - let nodeParent = nodeToRemove.parent in - successor.parent <- nodeParent; - (match nodeParent with - | None -> () - | Some parent -> - parent |. (leftOrRightSet ~node:nodeToRemove (Some successor))); - rbt |. (updateSumRecursive successor); - if nodeToRemove.color == Black - then - (if successor.color == Red - then - (successor.color <- Black; - if successor.parent == None then rbt.root <- (Some successor)) - else - (let break = ref false in - let successorRef = ref successor in - while not break.contents do - let successor = successorRef.contents in - match successor.parent with - | None -> (rbt.root <- (Some successor); break.contents <- true) - | Some successorParent -> - let sibling = siblingOf successor in - (if - (sibling != None) && - ((sibling |. castNotOption).color == Red) - then - (successorParent.color <- Red; - (sibling |. castNotOption).color <- Black; - if isLeft successor - then rotateLeft rbt successorParent - else rotateRight rbt successorParent); - (let sibling = siblingOf successor in - let siblingNN = sibling |. castNotOption in - if - (successorParent.color == Black) && - ((sibling == None) || - (((siblingNN.color == Black) && - ((siblingNN.left == None) || - ((siblingNN.left |. castNotOption).color == - Black))) - && - ((siblingNN.right == None) || - ((siblingNN.right |. castNotOption).color == - Black)))) - then - (if sibling != None then siblingNN.color <- Red; - successorRef.contents <- successorParent) - else - if - (successorParent.color == Red) && - ((sibling == None) || - (((siblingNN.color == Black) && - ((siblingNN.left == None) || - ((siblingNN.left |. castNotOption).color == - Black))) - && - ((siblingNN.right == None) || - ((siblingNN.right |. castNotOption).color == - Black)))) - then - (if sibling != None then siblingNN.color <- Red; - successorParent.color <- Black; - break.contents <- true) - else - if - (sibling != None) && - ((sibling |. castNotOption).color == Black) - then - (let sibling = sibling |. castNotOption in - if - (((isLeft successor) && - ((sibling.right == None) || - ((sibling.right |. castNotOption).color == - Black))) - && (sibling.left != None)) - && ((sibling.left |. castNotOption).color == Red) - then - (sibling.color <- Red; - (sibling.left |. castNotOption).color <- Black; - rotateRight rbt sibling) - else - if - (((not (isLeft successor)) && - ((sibling.left == None) || - ((sibling.left |. castNotOption).color == - Black))) - && (sibling.right != None)) - && - ((sibling.right |. castNotOption).color == Red) - then - (sibling.color <- Red; - (sibling.right |. castNotOption).color <- Black; - rotateLeft rbt sibling); - break.contents <- true) - else - (let sibling = siblingOf successor in - let sibling = sibling |. castNotOption in - sibling.color <- (successorParent.color); - if isLeft successor - then - ((sibling.right |. castNotOption).color <- Black; - rotateRight rbt successorParent) - else - ((sibling.left |. castNotOption).color <- Black; - rotateLeft rbt successorParent)))) - done)); - if ((isLeaf successor)[@bs ]) - then - (if rbt.root == (Some successor) then rbt.root <- None; - (match successor.parent with - | None -> () - | Some parent -> parent |. (leftOrRightSet ~node:successor None))) -let remove rbt value = - match findNode rbt rbt.root value with - | Some node -> (rbt |. (removeNode node); rbt.size <- (rbt.size - 1); true) - | None -> false -let rec findNodeThroughCallback rbt node cb = - match node with - | None -> None - | Some node -> - let cmp = ((cb node)[@bs ]) in - if cmp == 0 - then Some node - else - if cmp < 0 - then findNodeThroughCallback rbt node.left cb - else findNodeThroughCallback rbt node.right cb -let removeThroughCallback rbt cb = - match findNodeThroughCallback rbt rbt.root cb with - | Some node -> (rbt |. (removeNode node); rbt.size <- (rbt.size - 1); true) - | None -> false -let make ~compare = { size = 0; root = None; compare } -let makeWith array ~compare = - let rbt = make ~compare in - array |. - (Js.Array2.forEach - (fun (value, height) -> (add rbt value ~height) |. ignore)); - rbt -let rec heightOfInterval rbt node lhs rhs = - match node with - | None -> 0. - | Some n -> - if (lhs == None) && (rhs == None) - then n.sum - else - if - (lhs != None) && - (((rbt.compare n.value (lhs |. castNotOption))[@bs ]) < 0) - then rbt |. (heightOfInterval n.right lhs rhs) - else - if - (rhs != None) && - (((rbt.compare n.value (rhs |. castNotOption))[@bs ]) > 0) - then rbt |. (heightOfInterval n.left lhs rhs) - else - (n.height +. (rbt |. (heightOfInterval n.left lhs None))) +. - (rbt |. (heightOfInterval n.right None rhs)) -let heightOfInterval rbt lhs rhs = heightOfInterval rbt rbt.root lhs rhs -let rec firstVisibleNode node top = - match node with - | None -> None - | Some node -> - if node.sum <= top - then None - else - (let nodeHeight = node.height in - let sumLeft = - match node.left with | None -> 0.0 | Some left -> left.sum in - if sumLeft > top - then firstVisibleNode node.left top - else - if (sumLeft +. nodeHeight) > top - then Some node - else - (let offset = sumLeft +. nodeHeight in - firstVisibleNode node.right (top -. offset))) -let lastVisibleNode node top = - match firstVisibleNode node top with - | None -> node |. peekMaxNode - | first -> first -let firstVisibleValue rbt ~top = - match firstVisibleNode rbt.root top with - | None -> None - | Some node -> Some (node.value) -let rec leftmost node = - match node.left with | None -> node | Some node -> node |. leftmost -let rec firstRightParent node = - match node.parent with - | None -> None - | Some parent -> - ((if isLeft node then Some parent else parent |. firstRightParent) - [@res.ternary ]) -let nextNode node = - match node.right with - | None -> node |. firstRightParent - | Some right -> Some (right |. leftmost) -let rec sumLeftSpine node ~fromRightChild = - let leftSpine = - match node.left with - | None -> node.height - | Some left -> ((if fromRightChild then node.height +. left.sum else 0.0) - [@res.ternary ]) in - match node.parent with - | None -> leftSpine - | Some parent -> - leftSpine +. - (parent |. - (sumLeftSpine ~fromRightChild:(parent.right == (Some node)))) -let getY node = (node |. (sumLeftSpine ~fromRightChild:true)) -. node.height -let rec iterate ~inclusive firstNode lastNode ~callback = - match firstNode with - | None -> () - | Some node -> - (if inclusive then ((callback node)[@bs ]); - if firstNode != lastNode - then - (if not inclusive then ((callback node)[@bs ]); - iterate ~inclusive (node |. nextNode) lastNode ~callback)) -let rec iterateWithY ?y ~inclusive firstNode lastNode ~callback = - match firstNode with - | None -> () - | Some node -> - let y = match y with | None -> node |. getY | Some y -> y in - (if inclusive then ((callback node y)[@bs ]); - if firstNode != lastNode - then - (if not inclusive then ((callback node y)[@bs ]); - iterateWithY ~y:(y +. node.height) ~inclusive (node |. nextNode) - lastNode ~callback)) -let rec updateSum node ~delta = - match node with - | None -> () - | Some node -> - (node.sum <- (node.sum +. delta); node.parent |. (updateSum ~delta)) -let updateHeight node ~height = - let delta = height -. node.height in - node.height <- height; (Some node) |. (updateSum ~delta) -type nonrec 'value oldNewVisible = - { - mutable old: 'value array ; - mutable new_: 'value array } -let getAnchorDelta rbt ~anchor = - match anchor with - | None -> 0.0 - | Some (value, y) -> - (match rbt |. (findNode rbt.root value) with - | Some node -> y -. (node |. getY) - | None -> 0.0) -let onChangedVisible ?(anchor= None) rbt ~oldNewVisible ~top:top_ - ~bottom:bottom_ ~appear ~remained ~disappear = - let old = oldNewVisible.new_ in - let new_ = oldNewVisible.old in - (new_ |. - (Js.Array2.removeCountInPlace ~pos:0 ~count:(new_ |. Js.Array2.length))) - |. ignore; - oldNewVisible.old <- old; - oldNewVisible.new_ <- new_; - (let anchorDelta = rbt |. (getAnchorDelta ~anchor) in - let top = top_ -. anchorDelta in - let top = ((if top < 0.0 then 0.0 else top)[@res.ternary ]) in - let bottom = bottom_ -. anchorDelta in - let first = firstVisibleNode rbt.root top in - let last = lastVisibleNode rbt.root bottom in - let oldLen = old |. Js.Array2.length in - let oldIter = ref 0 in - iterateWithY ~inclusive:true first last - ((fun node -> - fun y_ -> - let y = y_ +. anchorDelta in - if y >= 0.0 - then - (while - (oldIter.contents < oldLen) && - (((rbt.compare (Js.Array2.unsafe_get old oldIter.contents) - node.value) - [@bs ]) < 0) - do - (((disappear (Js.Array2.unsafe_get old oldIter.contents)) - [@bs ]); - oldIter.contents <- (oldIter.contents + 1)) - done; - (new_ |. (Js.Array2.push node.value)) |. ignore; - if oldIter.contents < oldLen - then - (let cmp = - ((rbt.compare (Js.Array2.unsafe_get old oldIter.contents) - node.value) - [@bs ]) in - if cmp = 0 - then - (((remained node y) - [@bs ]); - oldIter.contents <- (oldIter.contents + 1)) - else ((appear node y)[@bs ])) - else ((appear node y)[@bs ])))[@bs ]); - while oldIter.contents < oldLen do - (((disappear (Js.Array2.unsafe_get old oldIter.contents)) - [@bs ]); - oldIter.contents <- (oldIter.contents + 1)) - done) diff --git a/jscomp/syntax/benchmarks/data/RedBlackTree.res b/jscomp/syntax/benchmarks/data/RedBlackTree.res deleted file mode 100644 index fbf68c2..0000000 --- a/jscomp/syntax/benchmarks/data/RedBlackTree.res +++ /dev/null @@ -1,751 +0,0 @@ -/* -Credit to Wikipedia's article on [Red-black -tree](http://en.wikipedia.org/wiki/Red–black_tree) - -**Note:** doesn't handle duplicate entries. This is by design. - -## Overview example: - -``` -var rbt = new RedBlackTree([7, 5, 1, 8]) -rbt.add(2) // => 2 -rbt.add(10) // => 10 -rbt.has(5) // => true -rbt.remove(8) // => 8 -``` - -## Properties: - -- size: The total number of items. -*/ - -type nodeColor = - | Red - | Black - -/* -Property of a red-black tree, taken from Wikipedia: -1. A node is either red or black. -2. Root is black. -3. Leaves are all null and considered black. -4. Both children of a red node are black. -5. Every path from a node to any of its descendent leaves contains the same -number of black nodes. -*/ - -type rec node<'value> = { - mutable left: option>, - mutable right: option>, - mutable parent: option>, - mutable sum: float, - mutable color : nodeColor, - mutable height: float, - mutable value: 'value, -} - -type t<'value> = { - mutable size: int, - mutable root: option>, - compare: (. 'value, 'value) => int, -} - -let createNode = (~color, ~value, ~height) => - {left:None, right:None, parent:None, sum:0., height, value, color} - -external castNotOption: option<'a> => 'a = "%identity" - -let updateSum = (node) => { - let leftSum = switch node.left { - | None => 0. - | Some(left) => left.sum - } - let rightSum = switch node.right { - | None => 0. - | Some(right) => right.sum - } - node.sum = leftSum +. rightSum +. node.height -} - -/* Update the sum for the node and parents recursively. */ -let rec updateSumRecursive = (rbt, node) => { - updateSum(node) - switch node.parent { - | None => () - | Some(parent) => - rbt->updateSumRecursive(parent) - } -} - -let grandParentOf = node => { - switch node.parent { - | None => None - | Some(ref_) => ref_.parent - } -} - -let isLeft = node => { - switch node.parent { - | None => false - | Some(parent) => Some(node) === parent.left - } -} - -let leftOrRightSet = (~node, x, value) => { - isLeft(node) ? x.left=value : x.right=value -} - -let siblingOf = node => { - if isLeft(node) { - castNotOption(node.parent).right - } else { - castNotOption(node.parent).left - } -} - -let uncleOf = node => { - switch grandParentOf(node) { - | None => None - | Some(grandParentOfNode) => - if isLeft(castNotOption(node.parent)) { - grandParentOfNode.right - } else { - grandParentOfNode.left - } - } -} - -let rec findNode = (rbt, node, value) => { - switch node { - | None => None - | Some(node) => - let cmp = rbt.compare(. value, node.value) - if cmp === 0 { - Some(node) - } else if cmp < 0 { - findNode(rbt, node.left, value) - } else { - findNode(rbt, node.right, value) - } - } -} - -let has = (rbt, value) => findNode(rbt, rbt.root, value) !== None - -let rec peekMinNode = node => switch node { - | None => None - | Some(node) => - node.left === None ? Some(node) : node.left->peekMinNode -} - -let rec peekMaxNode = node => switch node { - | None => None - | Some(node) => - node.right === None ? Some(node) : node.right->peekMaxNode -} - -let rotateLeft = (rbt, node) => { - let parent = node.parent - let right = node.right - switch parent { - | Some(parent) => - parent->leftOrRightSet(~node, right) - | None => - rbt.root = right - } - node.parent = right - let right = right->castNotOption // precondition - let rightLeft = right.left - node.right = rightLeft - switch rightLeft { - | Some(rightLeft) => - rightLeft.parent = Some(node) - | None => - () - } - right.parent = parent - right.left = Some(node) - updateSum(node) - updateSum(right) -} - -let rotateRight = (rbt, node) => { - let parent = node.parent - let left = node.left - switch parent { - | Some(parent) => - parent->leftOrRightSet(~node, left) - | None => - rbt.root = left - } - node.parent = left - let left = left->castNotOption // precondition - let leftRight = left.right - node.left = leftRight - switch leftRight { - | Some(leftRight) => - leftRight.parent = Some(node) - | None => - () - } - left.parent = parent - left.right = Some(node) - updateSum(node) - updateSum(left) -} - -let rec findInsert = (rbt, node, nodeToInsert, value) => { - switch node { - | None => None - | Some(node) => { - let cmp = rbt.compare(. value, node.value) - if cmp === 0 { - Some(node) - } else { - if cmp < 0 { - if node.left !== None { - rbt->findInsert(node.left, nodeToInsert, value) - } else { - nodeToInsert.parent = Some(node) - node.left = Some(nodeToInsert) - None - } - } else { - if node.right !== None { - rbt->findInsert(node.right, nodeToInsert, value) - } else { - nodeToInsert.parent = Some(node) - node.right = Some(nodeToInsert) - None - } - } - } - } - } -} - -// After adding the node, we need to operate on it to preserve the tree's -// properties by filtering it through a series of cases. It'd be easier if -// there's tail recursion in JavaScript, as some cases fix the node but -// restart the cases on the node's ancestor. We'll have to use loops for now. - -let rec _addLoop = (rbt, currentNode) => { - // Case 1: node is root. Violates 1. Paint it black. - if Some(currentNode) === rbt.root { - currentNode.color = Black - } - - // Case 2: parent black. No properties violated. After that, parent is sure - // to be red. - else if (currentNode.parent->castNotOption).color === Black { - () - } - - // Case 3: if node's parent and uncle are red, they are painted black. - // Their parent (node's grandparent) should be painted red, and the - // grandparent red. Note that node certainly has a grandparent, since at - // this point, its parent's red, which can't be the root. - - // After the painting, the grandparent might violate 2 or 4. - else if({ - let uncle = uncleOf(currentNode) - uncle !== None && (uncle->castNotOption).color === Red - }) { - (currentNode.parent->castNotOption).color = Black - (uncleOf(currentNode)->castNotOption).color = Black - (grandParentOf(currentNode)->castNotOption).color = Red - _addLoop(rbt, grandParentOf(currentNode)->castNotOption) - } - else { - // At this point, uncle is either black or doesn't exist. - - // Case 4: parent red, uncle black, node is right child, parent is left - // child. Do a left rotation. Then, former parent passes through case 5. - let currentNode = - if !isLeft(currentNode) && isLeft(currentNode.parent->castNotOption) { - rotateLeft(rbt, currentNode.parent->castNotOption) - currentNode.left->castNotOption - } else if isLeft(currentNode) && !isLeft(currentNode.parent->castNotOption) { - rotateRight(rbt, currentNode.parent->castNotOption) - currentNode.right->castNotOption - } else { - currentNode - } - - // Case 5: parent red, uncle black, node is left child, parent is left - // child. Right rotation. Switch parent and grandparent's color. - (currentNode.parent->castNotOption).color = Black - (grandParentOf(currentNode)->castNotOption).color = Red - if isLeft(currentNode) { - rotateRight(rbt, grandParentOf(currentNode)->castNotOption) - } else { - rotateLeft(rbt, grandParentOf(currentNode)->castNotOption) - } - } -} - -let add = (rbt, value, ~height) => { - // Again, make sure to not pass a value already in the tree. - // - // _Returns:_ value added. - rbt.size = rbt.size + 1 - let nodeToInsert = createNode(~value, ~color=Red, ~height) - let inserted = - if rbt.root === None { - rbt.root = Some(nodeToInsert) - true - } - else { - let foundNode = findInsert(rbt, rbt.root, nodeToInsert, value) - foundNode === None - } - if inserted { - rbt->updateSumRecursive(nodeToInsert) - - _addLoop(rbt, nodeToInsert) - Some(nodeToInsert) - } else { - None - } -} - - -// To simplify removal cases, we can notice this: -// 1. Node has no child. -// 2. Node has two children. Select the smallest child on the right branch -// (leftmost) and copy its value into the node to delete. This replacement node -// certainly has less than two children or it wouldn't be the smallest. Then -// delete this replacement node. -// 3. Node has one child. -// They all come down to removing a node with maximum one child. -let removeNode = (rbt, node) => { - let nodeToRemove = - switch (node.left, node.right) { - | (Some(_), Some(_)) => - let successor = peekMinNode(node.right)->castNotOption - node.value = successor.value - node.height = successor.height - successor - | _ => node - } - // At this point, the node to remove has only one child. - let successor = switch nodeToRemove.left { - | None => nodeToRemove.right - | left => left - } - let (successor, isLeaf) = switch successor { - | None => - let leaf = createNode(~value=%bs.raw("0"), ~color=Black, ~height=0.) - let isLeaf = (. x) => x === leaf; - (leaf, isLeaf) - | Some(successor) => - (successor, (. _) => false) - } - let nodeParent = nodeToRemove.parent - successor.parent = nodeParent - switch nodeParent { - | None => () - | Some(parent) => - parent->leftOrRightSet(~node=nodeToRemove, Some(successor)) - } - - rbt->updateSumRecursive(successor) - - // We're done if node's red. If it's black and its child that took its place - // is red, change it to black. If both are black, we do cases checking like - // in insert. - if nodeToRemove.color === Black { - if successor.color === Red { - successor.color = Black - if successor.parent === None { - rbt.root = Some(successor) - } - } else { - let break = ref(false) - let successorRef = ref(successor) - while !break.contents { - let successor = successorRef.contents - // Case 1: node is root. Done. - switch successor.parent { - | None => - rbt.root = Some(successor) - break.contents = true - | Some(successorParent) => - // Case 2: sibling red. Flip color of P and S. Left rotate P. - let sibling = siblingOf(successor) - if sibling !== None && (sibling->castNotOption).color === Red { - successorParent.color = Red - (sibling->castNotOption).color = Black - if isLeft(successor) { - rotateLeft(rbt, successorParent) - } else { - rotateRight(rbt, successorParent) - } - } - - // Case 3: parent, sibling and sibling children all black. Paint - // sibling red. Rebalance parent. - let sibling = siblingOf(successor) - let siblingNN = sibling->castNotOption - if - successorParent.color === Black && - ( sibling === None || - ( siblingNN.color === Black && - ( siblingNN.left === None || - (siblingNN.left->castNotOption).color === Black ) && - ( siblingNN.right === None || - (siblingNN.right->castNotOption).color === Black))) - { - if sibling !== None { - siblingNN.color = Red - } - successorRef.contents = successorParent - // continue - } else if - // Case 4: sibling and sibling children black. Node parent red. Swap - // color of sibling and node parent. - successorParent.color === Red && - ( sibling === None || - ( siblingNN.color === Black && - ( siblingNN.left === None || - (siblingNN.left->castNotOption).color === Black) && - ( siblingNN.right === None || - (siblingNN.right->castNotOption).color === Black))) - { - if sibling !== None { - siblingNN.color = Red - } - successorParent.color = Black - break.contents = true - } else if - // Case 5: sibling black, sibling left child red, right child black, - // node is left child. Rotate right sibling. Swap color of sibling and - // its new parent. - sibling !== None && (sibling->castNotOption).color === Black - { - let sibling = sibling->castNotOption - if - isLeft(successor) && - (sibling.right === None || (sibling.right->castNotOption).color === Black) && - sibling.left !== None && - (sibling.left->castNotOption).color === Red { - sibling.color = Red - (sibling.left->castNotOption).color = Black - rotateRight(rbt, sibling) - } else if - !isLeft(successor) && - (sibling.left === None || (sibling.left->castNotOption).color === Black) && - sibling.right !== None && - (sibling.right->castNotOption).color === Red - { - sibling.color = Red - (sibling.right->castNotOption).color = Black - rotateLeft(rbt, sibling) - } - break.contents = true - } else { - // Case 6: sibling black, sibling right child red, node is left child. - // Rotate left node parent. Swap color of parent and sibling. Paint - // sibling right child black. - let sibling = siblingOf(successor) - let sibling = sibling->castNotOption - sibling.color = successorParent.color - if isLeft(successor) { - (sibling.right->castNotOption).color = Black - rotateRight(rbt, successorParent) - } else { - (sibling.left->castNotOption).color = Black - rotateLeft(rbt, successorParent) - } - } - } - } - } - } - // Don't forget to detatch the artificially created leaf. - if isLeaf(. successor) { - if rbt.root === Some(successor) { - rbt.root = None - } - switch successor.parent { - | None => () - | Some(parent) => - parent->leftOrRightSet(~node=successor, None) - } - } -} - -let remove = (rbt, value) => { - switch findNode(rbt, rbt.root, value) { - | Some(node) => - rbt->removeNode(node) - rbt.size = rbt.size - 1 - true - | None => - false - } -} - -let rec findNodeThroughCallback = (rbt, node, cb) => { - switch node { - | None => None - | Some(node) => - let cmp = cb(. node) - if cmp === 0 { - Some(node) - } else if cmp < 0 { - findNodeThroughCallback(rbt, node.left, cb) - } else { - findNodeThroughCallback(rbt, node.right, cb) - } - } -} - -let removeThroughCallback = (rbt, cb) => { - switch findNodeThroughCallback(rbt, rbt.root, cb) { - | Some(node) => - rbt->removeNode(node) - rbt.size = rbt.size - 1 - true - | None => - false - } -} - -let make = (~compare) => {size: 0, root: None, compare} - -let makeWith = (array, ~compare) => { - let rbt = make(~compare) - array->Js.Array2.forEach(((value, height)) => add(rbt,value, ~height)->ignore) - rbt -} - -// sum of the heights of the elements in [lhs ... rhs] -// both lhs and rhs are optional -let rec heightOfInterval = (rbt, node, lhs, rhs) => { - switch node { - | None => 0. - | Some(n) => - //Js.log4("heightOfInterval n:", n.value, lhs, rhs) - if lhs === None && rhs === None { - n.sum - } else if lhs !== None && rbt.compare(. n.value, lhs->castNotOption) < 0 { - // to the lhs of the interval - rbt->heightOfInterval(n.right, lhs, rhs) - } else if rhs !== None && rbt.compare(. n.value, rhs->castNotOption) > 0 { - // to the rhs of the interval - rbt->heightOfInterval(n.left, lhs, rhs) - } else { - // in the interval - n.height +. - rbt->heightOfInterval(n.left, lhs, None) +. - rbt->heightOfInterval(n.right, None, rhs) - } - } -} - -let heightOfInterval = (rbt, lhs, rhs) => { - //Js.log("-----------") - heightOfInterval(rbt, rbt.root, lhs, rhs) -} - -// Return a node at y such that y <= top < y + node.height -let rec firstVisibleNode = (node, top) => { - switch node { - | None => None - | Some(node) => - //Js.log4("firstVisibleNode", node.value, "top:", top) - if node.sum <= top { - // no node is visible - None - } else { - let nodeHeight = node.height - let sumLeft = switch node.left { - | None => 0.0 - | Some(left) => left.sum - } - if sumLeft > top { - firstVisibleNode(node.left, top) - } else if sumLeft +. nodeHeight > top { - // found - Some(node) - } else { - let offset = sumLeft +. nodeHeight - firstVisibleNode(node.right, top -. offset) - } - } - } -} - -let lastVisibleNode = (node, top) => { - switch firstVisibleNode(node, top) { - | None => - node->peekMaxNode - | first => first - } -} - -// Find the value of the first visible node starting from top -let firstVisibleValue = (rbt, ~top) => - switch firstVisibleNode(rbt.root, top) { - | None => None - | Some(node) => Some(node.value) -} - -let rec leftmost = node => switch node.left { - | None => node - | Some(node) => node->leftmost -} - -let rec firstRightParent = node => { - switch node.parent { - | None => None - | Some(parent) => - isLeft(node) ? Some(parent) : parent->firstRightParent - } -} - -let nextNode = node => { - switch node.right { - | None => - node->firstRightParent - | Some(right) => - Some(right->leftmost) - } -} - -let rec sumLeftSpine = (node, ~fromRightChild) => { - let leftSpine = switch node.left { - | None => node.height - | Some(left) => fromRightChild ? node.height +. left.sum : 0.0 - } - switch node.parent { - | None => - leftSpine - | Some(parent) => - leftSpine +. parent->sumLeftSpine(~fromRightChild = parent.right === Some(node)) - } -} - -let getY = node => - node->sumLeftSpine(~fromRightChild=true) -. node.height - -let rec iterate = (~inclusive, firstNode, lastNode, ~callback) => { - switch firstNode { - | None => () - | Some(node) => - if inclusive { callback(. node) } - if firstNode !== lastNode { - if !inclusive { callback (.node) } - iterate(~inclusive, node->nextNode, lastNode, ~callback) - } - } -} - -let rec iterateWithY = (~y=?, ~inclusive, firstNode, lastNode, ~callback) => { - switch firstNode { - | None => () - | Some(node) => - let y = switch y { - | None => node->getY - | Some(y) => y - } - if inclusive { - callback(. node, y) - } - if firstNode !== lastNode { - if !inclusive { - callback (.node, y) - } - iterateWithY(~y=y+.node.height, ~inclusive, node->nextNode, lastNode, ~callback) - } - } -} - -let rec updateSum = (node, ~delta) => switch node { - | None => () - | Some(node) => - node.sum = node.sum +. delta - node.parent->updateSum(~delta) -} - -let updateHeight = (node, ~height) => { - let delta = height -. node.height - node.height = height - Some(node)->updateSum(~delta) -} - -type oldNewVisible<'value> = { - mutable old: array<'value>, - mutable new: array<'value>, -}; - -let getAnchorDelta = (rbt, ~anchor) => { - switch anchor { - | None => 0.0 - | Some((value, y)) => - switch rbt->findNode(rbt.root, value) { - | Some(node) => y -. node->getY - | None => 0.0 - } - } -} - -let onChangedVisible = - ( - ~anchor=None, - rbt, - ~oldNewVisible, - ~top as top_, - ~bottom as bottom_, - ~appear, - ~remained, - ~disappear, - ) => - { - let old = oldNewVisible.new - let new = oldNewVisible.old - // empty new - new->Js.Array2.removeCountInPlace(~pos=0, ~count=new->Js.Array2.length)->ignore - oldNewVisible.old = old - oldNewVisible.new = new - - let anchorDelta = rbt->getAnchorDelta(~anchor) - //Js.log2("anchorDelta", anchorDelta) - let top = top_ -. anchorDelta - let top = top < 0.0 ? 0.0 : top // anchoring can make top negative - let bottom = bottom_ -. anchorDelta - - let first = firstVisibleNode(rbt.root, top) - let last = lastVisibleNode(rbt.root, bottom) - - let oldLen = old->Js.Array2.length - let oldIter = ref(0) - iterateWithY(~inclusive=true, first, last, ~callback=(. node, y_) => { - let y = y_ +. anchorDelta - if y >= 0.0 { // anchoring can make y negative - while ( - oldIter.contents < oldLen && - rbt.compare(. Js.Array2.unsafe_get(old, oldIter.contents), node.value) < 0 - ) { - disappear(. Js.Array2.unsafe_get(old, oldIter.contents)) - oldIter.contents = oldIter.contents + 1 - } - new->Js.Array2.push(node.value)->ignore - if (oldIter.contents < oldLen) { - let cmp = rbt.compare(. Js.Array2.unsafe_get(old, oldIter.contents), node.value) - if cmp == 0 { - remained(. node, y) - oldIter.contents = oldIter.contents + 1 - } else { - appear(. node, y) - } - } else { - appear(. node, y) - } - } - }) - while (oldIter.contents < oldLen) { - disappear(. Js.Array2.unsafe_get(old, oldIter.contents)) - oldIter.contents = oldIter.contents + 1 - } -}; diff --git a/jscomp/syntax/benchmarks/data/RedBlackTreeNoComments.res b/jscomp/syntax/benchmarks/data/RedBlackTreeNoComments.res deleted file mode 100644 index 67a2a54..0000000 --- a/jscomp/syntax/benchmarks/data/RedBlackTreeNoComments.res +++ /dev/null @@ -1,643 +0,0 @@ -type nodeColor = - | Red - | Black - -type rec node<'value> = { - mutable left: option>, - mutable right: option>, - mutable parent: option>, - mutable sum: float, - mutable color: nodeColor, - mutable height: float, - mutable value: 'value, -} - -type t<'value> = { - mutable size: int, - mutable root: option>, - compare: (. 'value, 'value) => int, -} - -let createNode = (~color, ~value, ~height) => { - left: None, - right: None, - parent: None, - sum: 0., - height: height, - value: value, - color: color, -} - -external castNotOption: option<'a> => 'a = "%identity" - -let updateSum = node => { - let leftSum = switch node.left { - | None => 0. - | Some(left) => left.sum - } - let rightSum = switch node.right { - | None => 0. - | Some(right) => right.sum - } - node.sum = leftSum +. rightSum +. node.height -} - -let rec updateSumRecursive = (rbt, node) => { - updateSum(node) - switch node.parent { - | None => () - | Some(parent) => rbt->updateSumRecursive(parent) - } -} - -let grandParentOf = node => - switch node.parent { - | None => None - | Some(ref_) => ref_.parent - } - -let isLeft = node => - switch node.parent { - | None => false - | Some(parent) => Some(node) === parent.left - } - -let leftOrRightSet = (~node, x, value) => - isLeft(node) - ? x.left = value - : x.right = value - -let siblingOf = node => - if isLeft(node) { - castNotOption(node.parent).right - } else { - castNotOption(node.parent).left - } - -let uncleOf = node => - switch grandParentOf(node) { - | None => None - | Some(grandParentOfNode) => - if isLeft(castNotOption(node.parent)) { - grandParentOfNode.right - } else { - grandParentOfNode.left - } - } - -let rec findNode = (rbt, node, value) => - switch node { - | None => None - | Some(node) => - let cmp = rbt.compare(. value, node.value) - if cmp === 0 { - Some(node) - } else if cmp < 0 { - findNode(rbt, node.left, value) - } else { - findNode(rbt, node.right, value) - } - } - -let has = (rbt, value) => findNode(rbt, rbt.root, value) !== None - -let rec peekMinNode = node => - switch node { - | None => None - | Some(node) => node.left === None ? Some(node) : node.left->peekMinNode - } - -let rec peekMaxNode = node => - switch node { - | None => None - | Some(node) => node.right === None ? Some(node) : node.right->peekMaxNode - } - -let rotateLeft = (rbt, node) => { - let parent = node.parent - let right = node.right - switch parent { - | Some(parent) => parent->leftOrRightSet(~node, right) - | None => rbt.root = right - } - node.parent = right - let right = right->castNotOption - let rightLeft = right.left - node.right = rightLeft - switch rightLeft { - | Some(rightLeft) => rightLeft.parent = Some(node) - | None => () - } - right.parent = parent - right.left = Some(node) - updateSum(node) - updateSum(right) -} - -let rotateRight = (rbt, node) => { - let parent = node.parent - let left = node.left - switch parent { - | Some(parent) => parent->leftOrRightSet(~node, left) - | None => rbt.root = left - } - node.parent = left - let left = left->castNotOption - let leftRight = left.right - node.left = leftRight - switch leftRight { - | Some(leftRight) => leftRight.parent = Some(node) - | None => () - } - left.parent = parent - left.right = Some(node) - updateSum(node) - updateSum(left) -} - -let rec findInsert = (rbt, node, nodeToInsert, value) => - switch node { - | None => None - | Some(node) => - let cmp = rbt.compare(. value, node.value) - if cmp === 0 { - Some(node) - } else if cmp < 0 { - if node.left !== None { - rbt->findInsert(node.left, nodeToInsert, value) - } else { - nodeToInsert.parent = Some(node) - node.left = Some(nodeToInsert) - None - } - } else if node.right !== None { - rbt->findInsert(node.right, nodeToInsert, value) - } else { - nodeToInsert.parent = Some(node) - node.right = Some(nodeToInsert) - None - } - } - -let rec _addLoop = (rbt, currentNode) => - if Some(currentNode) === rbt.root { - currentNode.color = Black - } else if (currentNode.parent->castNotOption).color === Black { - () - } else if { - let uncle = uncleOf(currentNode) - uncle !== None && (uncle->castNotOption).color === Red - } { - (currentNode.parent->castNotOption).color = Black - (uncleOf(currentNode)->castNotOption).color = Black - (grandParentOf(currentNode)->castNotOption).color = Red - _addLoop(rbt, grandParentOf(currentNode)->castNotOption) - } else { - let currentNode = if ( - !isLeft(currentNode) && isLeft(currentNode.parent->castNotOption) - ) { - rotateLeft(rbt, currentNode.parent->castNotOption) - currentNode.left->castNotOption - } else if ( - isLeft(currentNode) && !isLeft(currentNode.parent->castNotOption) - ) { - rotateRight(rbt, currentNode.parent->castNotOption) - currentNode.right->castNotOption - } else { - currentNode - } - - (currentNode.parent->castNotOption).color = Black - (grandParentOf(currentNode)->castNotOption).color = Red - if isLeft(currentNode) { - rotateRight(rbt, grandParentOf(currentNode)->castNotOption) - } else { - rotateLeft(rbt, grandParentOf(currentNode)->castNotOption) - } - } - -let add = (rbt, value, ~height) => { - rbt.size = rbt.size + 1 - let nodeToInsert = createNode(~value, ~color=Red, ~height) - let inserted = if rbt.root === None { - rbt.root = Some(nodeToInsert) - true - } else { - let foundNode = findInsert(rbt, rbt.root, nodeToInsert, value) - foundNode === None - } - if inserted { - rbt->updateSumRecursive(nodeToInsert) - - _addLoop(rbt, nodeToInsert) - Some(nodeToInsert) - } else { - None - } -} - -let removeNode = (rbt, node) => { - let nodeToRemove = switch (node.left, node.right) { - | (Some(_), Some(_)) => - let successor = peekMinNode(node.right)->castNotOption - node.value = successor.value - node.height = successor.height - successor - | _ => node - } - - let successor = switch nodeToRemove.left { - | None => nodeToRemove.right - | left => left - } - let (successor, isLeaf) = switch successor { - | None => - let leaf = createNode(~value=%bs.raw("0"), ~color=Black, ~height=0.) - let isLeaf = (. x) => x === leaf - (leaf, isLeaf) - | Some(successor) => (successor, (. _) => false) - } - let nodeParent = nodeToRemove.parent - successor.parent = nodeParent - switch nodeParent { - | None => () - | Some(parent) => parent->leftOrRightSet(~node=nodeToRemove, Some(successor)) - } - - rbt->updateSumRecursive(successor) - - if nodeToRemove.color === Black { - if successor.color === Red { - successor.color = Black - if successor.parent === None { - rbt.root = Some(successor) - } - } else { - let break = ref(false) - let successorRef = ref(successor) - while !break.contents { - let successor = successorRef.contents - - switch successor.parent { - | None => - rbt.root = Some(successor) - break.contents = true - | Some(successorParent) => - let sibling = siblingOf(successor) - if sibling !== None && (sibling->castNotOption).color === Red { - successorParent.color = Red - (sibling->castNotOption).color = Black - if isLeft(successor) { - rotateLeft(rbt, successorParent) - } else { - rotateRight(rbt, successorParent) - } - } - - let sibling = siblingOf(successor) - let siblingNN = sibling->castNotOption - if ( - successorParent.color === Black && - (sibling === None || - (siblingNN.color === Black && - (siblingNN.left === None || - (siblingNN.left->castNotOption).color === Black) && - (siblingNN.right === None || - (siblingNN.right->castNotOption).color === Black))) - ) { - if sibling !== None { - siblingNN.color = Red - } - successorRef.contents = successorParent - } else if ( - successorParent.color === Red && - (sibling === None || - (siblingNN.color === Black && - (siblingNN.left === None || - (siblingNN.left->castNotOption).color === Black) && - (siblingNN.right === None || - (siblingNN.right->castNotOption).color === Black))) - ) { - if sibling !== None { - siblingNN.color = Red - } - successorParent.color = Black - break.contents = true - } else if ( - sibling !== None && (sibling->castNotOption).color === Black - ) { - let sibling = sibling->castNotOption - if ( - isLeft(successor) && - (sibling.right === None || - (sibling.right->castNotOption).color === Black) && - sibling.left !== None && - (sibling.left->castNotOption).color === Red - ) { - sibling.color = Red - (sibling.left->castNotOption).color = Black - rotateRight(rbt, sibling) - } else if ( - !isLeft(successor) && - (sibling.left === None || - (sibling.left->castNotOption).color === Black) && - sibling.right !== None && - (sibling.right->castNotOption).color === Red - ) { - sibling.color = Red - (sibling.right->castNotOption).color = Black - rotateLeft(rbt, sibling) - } - break.contents = true - } else { - let sibling = siblingOf(successor) - let sibling = sibling->castNotOption - sibling.color = successorParent.color - if isLeft(successor) { - (sibling.right->castNotOption).color = Black - rotateRight(rbt, successorParent) - } else { - (sibling.left->castNotOption).color = Black - rotateLeft(rbt, successorParent) - } - } - } - } - } - } - - if isLeaf(. successor) { - if rbt.root === Some(successor) { - rbt.root = None - } - switch successor.parent { - | None => () - | Some(parent) => parent->leftOrRightSet(~node=successor, None) - } - } -} - -let remove = (rbt, value) => - switch findNode(rbt, rbt.root, value) { - | Some(node) => - rbt->removeNode(node) - rbt.size = rbt.size - 1 - true - | None => false - } - -let rec findNodeThroughCallback = (rbt, node, cb) => - switch node { - | None => None - | Some(node) => - let cmp = cb(. node) - if cmp === 0 { - Some(node) - } else if cmp < 0 { - findNodeThroughCallback(rbt, node.left, cb) - } else { - findNodeThroughCallback(rbt, node.right, cb) - } - } - -let removeThroughCallback = (rbt, cb) => - switch findNodeThroughCallback(rbt, rbt.root, cb) { - | Some(node) => - rbt->removeNode(node) - rbt.size = rbt.size - 1 - true - | None => false - } - -let make = (~compare) => {size: 0, root: None, compare: compare} - -let makeWith = (array, ~compare) => { - let rbt = make(~compare) - array->Js.Array2.forEach(((value, height)) => - add(rbt, value, ~height)->ignore - ) - rbt -} - -let rec heightOfInterval = (rbt, node, lhs, rhs) => - switch node { - | None => 0. - | Some(n) => - if lhs === None && rhs === None { - n.sum - } else if lhs !== None && rbt.compare(. n.value, lhs->castNotOption) < 0 { - rbt->heightOfInterval(n.right, lhs, rhs) - } else if rhs !== None && rbt.compare(. n.value, rhs->castNotOption) > 0 { - rbt->heightOfInterval(n.left, lhs, rhs) - } else { - n.height +. - rbt->heightOfInterval(n.left, lhs, None) +. - rbt->heightOfInterval(n.right, None, rhs) - } - } - -let heightOfInterval = (rbt, lhs, rhs) => - heightOfInterval(rbt, rbt.root, lhs, rhs) - -let rec firstVisibleNode = (node, top) => - switch node { - | None => None - | Some(node) => - if node.sum <= top { - None - } else { - let nodeHeight = node.height - let sumLeft = switch node.left { - | None => 0.0 - | Some(left) => left.sum - } - if sumLeft > top { - firstVisibleNode(node.left, top) - } else if sumLeft +. nodeHeight > top { - Some(node) - } else { - let offset = sumLeft +. nodeHeight - firstVisibleNode(node.right, top -. offset) - } - } - } - -let lastVisibleNode = (node, top) => - switch firstVisibleNode(node, top) { - | None => node->peekMaxNode - | first => first - } - -let firstVisibleValue = (rbt, ~top) => - switch firstVisibleNode(rbt.root, top) { - | None => None - | Some(node) => Some(node.value) - } - -let rec leftmost = node => - switch node.left { - | None => node - | Some(node) => node->leftmost - } - -let rec firstRightParent = node => - switch node.parent { - | None => None - | Some(parent) => isLeft(node) ? Some(parent) : parent->firstRightParent - } - -let nextNode = node => - switch node.right { - | None => node->firstRightParent - | Some(right) => Some(right->leftmost) - } - -let rec sumLeftSpine = (node, ~fromRightChild) => { - let leftSpine = switch node.left { - | None => node.height - | Some(left) => fromRightChild ? node.height +. left.sum : 0.0 - } - switch node.parent { - | None => leftSpine - | Some(parent) => - leftSpine +. - parent->sumLeftSpine(~fromRightChild=parent.right === Some(node)) - } -} - -let getY = node => node->sumLeftSpine(~fromRightChild=true) -. node.height - -let rec iterate = (~inclusive, firstNode, lastNode, ~callback) => - switch firstNode { - | None => () - | Some(node) => - if inclusive { - callback(. node) - } - if firstNode !== lastNode { - if !inclusive { - callback(. node) - } - iterate(~inclusive, node->nextNode, lastNode, ~callback) - } - } - -let rec iterateWithY = (~y=?, ~inclusive, firstNode, lastNode, ~callback) => - switch firstNode { - | None => () - | Some(node) => - let y = switch y { - | None => node->getY - | Some(y) => y - } - if inclusive { - callback(. node, y) - } - if firstNode !== lastNode { - if !inclusive { - callback(. node, y) - } - iterateWithY( - ~y=y +. node.height, - ~inclusive, - node->nextNode, - lastNode, - ~callback, - ) - } - } - -let rec updateSum = (node, ~delta) => - switch node { - | None => () - | Some(node) => - node.sum = node.sum +. delta - node.parent->updateSum(~delta) - } - -let updateHeight = (node, ~height) => { - let delta = height -. node.height - node.height = height - Some(node)->updateSum(~delta) -} - -type oldNewVisible<'value> = { - mutable old: array<'value>, - mutable new: array<'value>, -} - -let getAnchorDelta = (rbt, ~anchor) => - switch anchor { - | None => 0.0 - | Some(value, y) => - switch rbt->findNode(rbt.root, value) { - | Some(node) => y -. node->getY - | None => 0.0 - } - } - -let onChangedVisible = ( - ~anchor=None, - rbt, - ~oldNewVisible, - ~top as top_, - ~bottom as bottom_, - ~appear, - ~remained, - ~disappear, -) => { - let old = oldNewVisible.new - let new = oldNewVisible.old - - new - ->Js.Array2.removeCountInPlace(~pos=0, ~count=new->Js.Array2.length) - ->ignore - oldNewVisible.old = old - oldNewVisible.new = new - - let anchorDelta = rbt->getAnchorDelta(~anchor) - - let top = top_ -. anchorDelta - let top = top < 0.0 ? 0.0 : top - let bottom = bottom_ -. anchorDelta - - let first = firstVisibleNode(rbt.root, top) - let last = lastVisibleNode(rbt.root, bottom) - - let oldLen = old->Js.Array2.length - let oldIter = ref(0) - iterateWithY(~inclusive=true, first, last, (. node, y_) => { - let y = y_ +. anchorDelta - if y >= 0.0 { - while ( - oldIter.contents < oldLen && - rbt.compare(. - Js.Array2.unsafe_get(old, oldIter.contents), - node.value, - ) < 0 - ) { - disappear(. Js.Array2.unsafe_get(old, oldIter.contents)) - oldIter.contents = oldIter.contents + 1 - } - new->Js.Array2.push(node.value)->ignore - if oldIter.contents < oldLen { - let cmp = rbt.compare(. - Js.Array2.unsafe_get(old, oldIter.contents), - node.value, - ) - if cmp == 0 { - remained(. node, y) - oldIter.contents = oldIter.contents + 1 - } else { - appear(. node, y) - } - } else { - appear(. node, y) - } - } - }) - while oldIter.contents < oldLen { - disappear(. Js.Array2.unsafe_get(old, oldIter.contents)) - oldIter.contents = oldIter.contents + 1 - } -} diff --git a/jscomp/syntax/benchmarks/dune b/jscomp/syntax/benchmarks/dune deleted file mode 100644 index 6d507d6..0000000 --- a/jscomp/syntax/benchmarks/dune +++ /dev/null @@ -1,27 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executable - (name benchmark) - (public_name syntax_benchmarks) - (enabled_if - (and - (<> %{profile} browser) - (or - (= %{system} macosx) - ; or one of Linuxes (see https://github.com/ocaml/ocaml/issues/10613) - (= %{system} linux) - (= %{system} linux_elf) - (= %{system} elf) - (= %{system} linux_eabihf) - (= %{system} linux_eabi)))) - (flags - (:standard -w -A)) - (foreign_stubs - (language c) - (names time)) - (libraries syntax)) - -(data_only_dirs data) diff --git a/jscomp/syntax/benchmarks/time.c b/jscomp/syntax/benchmarks/time.c deleted file mode 100644 index df29af7..0000000 --- a/jscomp/syntax/benchmarks/time.c +++ /dev/null @@ -1,44 +0,0 @@ -#include -#include - -// -// Platform-specific includes -// -#if (defined(__MACH__) && defined(__APPLE__)) -#include -#elif defined(__linux__) -#include -#endif - -// -// Platform-specific globals -// -#if (defined(__MACH__) && defined(__APPLE__)) -static mach_timebase_info_data_t info; -#endif - -// -// Exported functions -// -CAMLprim value caml_mach_initialize(value unit) { -#if (defined(__MACH__) && defined(__APPLE__)) - mach_timebase_info(&info); -#endif - - return Val_unit; -} - -CAMLprim value caml_mach_absolute_time(value unit) { - uint64_t result = 0; - -#if (defined(__MACH__) && defined(__APPLE__)) - uint64_t now = mach_absolute_time(); - result = (now * info.numer) / info.denom; -#elif defined(__linux__) - struct timespec now; - clock_gettime(CLOCK_MONOTONIC, &now); - result = now.tv_sec * 1000 + now.tv_nsec / 1000000; -#endif - - return caml_copy_int64(result); -} diff --git a/jscomp/syntax/cli/dune b/jscomp/syntax/cli/dune deleted file mode 100644 index f7815b0..0000000 --- a/jscomp/syntax/cli/dune +++ /dev/null @@ -1,13 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executable - (name res_cli) - (public_name res_parser) - (enabled_if - (<> %{profile} browser)) - (flags - (:standard -w -A)) - (libraries syntax)) diff --git a/jscomp/syntax/cli/res_cli.ml b/jscomp/syntax/cli/res_cli.ml deleted file mode 100644 index 23d9006..0000000 --- a/jscomp/syntax/cli/res_cli.ml +++ /dev/null @@ -1,320 +0,0 @@ -(* - This CLI isn't used apart for this repo's testing purposes. The syntax - itself is used by ReScript's compiler programmatically through various other apis. -*) - -(* - This is OCaml's Misc.ml's Color module. More specifically, this is - ReScript's OCaml fork's Misc.ml's Color module: - https://github.com/rescript-lang/ocaml/blob/92e58bedced8d7e3e177677800a38922327ab860/utils/misc.ml#L540 - - The syntax's printing's coloring logic depends on: - 1. a global mutable variable that's set in the compiler: Misc.Color.color_enabled - 2. the colors tags supported by Misc.Color, e.g. style_of_tag, which Format - tags like @{hello@} use - 3. etc. - - When this syntax is programmatically used inside ReScript, the various - Format tags like and get properly colored depending on the - above points. - - But when used by this cli file, that coloring logic doesn't render properly - because we're compiling against vanilla OCaml 4.06 instead of ReScript's - OCaml fork. For example, the vanilla compiler doesn't support the `dim` - color (grey). So we emulate the right coloring logic by copy pasting how our - forked OCaml compiler does it. -*) -module Color = struct - (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) - type color = - | Black [@live] - | Red - | Green [@live] - | Yellow - | Blue [@live] - | Magenta - | Cyan - | White [@live] - - type style = - | FG of color (* foreground *) - | BG of color [@live] (* background *) - | Bold - | Reset - | Dim - - let ansi_of_color = function - | Black -> "0" - | Red -> "1" - | Green -> "2" - | Yellow -> "3" - | Blue -> "4" - | Magenta -> "5" - | Cyan -> "6" - | White -> "7" - - let code_of_style = function - | FG c -> "3" ^ ansi_of_color c - | BG c -> "4" ^ ansi_of_color c - | Bold -> "1" - | Reset -> "0" - | Dim -> "2" - - let ansi_of_style_l l = - let s = - match l with - | [] -> code_of_style Reset - | [s] -> code_of_style s - | _ -> String.concat ";" (List.map code_of_style l) - in - "\x1b[" ^ s ^ "m" - - type styles = {error: style list; warning: style list; loc: style list} - - let default_styles = - {warning = [Bold; FG Magenta]; error = [Bold; FG Red]; loc = [Bold]} - - let cur_styles = ref default_styles - - (* let get_styles () = !cur_styles *) - (* let set_styles s = cur_styles := s *) - - (* map a tag to a style, if the tag is known. - @raise Not_found otherwise *) - let style_of_tag s = - match s with - | Format.String_tag "error" -> !cur_styles.error - | Format.String_tag "warning" -> !cur_styles.warning - | Format.String_tag "loc" -> !cur_styles.loc - | Format.String_tag "info" -> [Bold; FG Yellow] - | Format.String_tag "dim" -> [Dim] - | Format.String_tag "filename" -> [FG Cyan] - | _ -> raise Not_found - [@@raises Not_found] - - let color_enabled = ref true - - (* either prints the tag of [s] or delegates to [or_else] *) - let mark_open_tag ~or_else s = - try - let style = style_of_tag s in - if !color_enabled then ansi_of_style_l style else "" - with Not_found -> or_else s - - let mark_close_tag ~or_else s = - try - let _ = style_of_tag s in - if !color_enabled then ansi_of_style_l [Reset] else "" - with Not_found -> or_else s - - (* add color handling to formatter [ppf] *) - let set_color_tag_handling ppf = - let open Format in - let functions = pp_get_formatter_stag_functions ppf () in - let functions' = - { - functions with - mark_open_stag = mark_open_tag ~or_else:functions.mark_open_stag; - mark_close_stag = mark_close_tag ~or_else:functions.mark_close_stag; - } - in - pp_set_mark_tags ppf true; - (* enable tags *) - pp_set_formatter_stag_functions ppf functions'; - (* also setup margins *) - pp_set_margin ppf (pp_get_margin std_formatter ()); - () - - external isatty : out_channel -> bool = "caml_sys_isatty" - - (* reasonable heuristic on whether colors should be enabled *) - let should_enable_color () = - let term = try Sys.getenv "TERM" with Not_found -> "" in - term <> "dumb" && term <> "" && isatty stderr - - type setting = Auto [@live] | Always [@live] | Never [@live] - - let setup = - let first = ref true in - (* initialize only once *) - let formatter_l = - [Format.std_formatter; Format.err_formatter; Format.str_formatter] - in - fun o -> - if !first then ( - first := false; - Format.set_mark_tags true; - List.iter set_color_tag_handling formatter_l; - color_enabled := - match o with - | Some Always -> true - | Some Auto -> should_enable_color () - | Some Never -> false - | None -> should_enable_color ()); - () -end - -(* command line flags *) -module ResClflags : sig - val recover : bool ref - val print : string ref - val width : int ref - val origin : string ref - val file : string ref - val interface : bool ref - val jsxVersion : int ref - val jsxModule : string ref - val jsxMode : string ref - val typechecker : bool ref - - val parse : unit -> unit -end = struct - let recover = ref false - let width = ref 100 - - let print = ref "res" - let origin = ref "" - let interface = ref false - let jsxVersion = ref (-1) - let jsxModule = ref "react" - let jsxMode = ref "automatic" - let file = ref "" - let typechecker = ref false - - let usage = - "\n\ - **This command line is for the repo developer's testing purpose only. DO \ - NOT use it in production**!\n\n" - ^ "Usage:\n res_parser \n\n" ^ "Examples:\n" - ^ " res_parser myFile.res\n" - ^ " res_parser -parse ml -print res myFile.ml\n" - ^ " res_parser -parse res -print binary -interface myFile.resi\n\n" - ^ "Options are:" - - let spec = - [ - ("-recover", Arg.Unit (fun () -> recover := true), "Emit partial ast"); - ( "-parse", - Arg.String (fun txt -> origin := txt), - "Parse ml or res. Default: res" ); - ( "-print", - Arg.String (fun txt -> print := txt), - "Print either binary, ml, ast, sexp, comments or res. Default: res" ); - ( "-width", - Arg.Int (fun w -> width := w), - "Specify the line length for the printer (formatter)" ); - ( "-interface", - Arg.Unit (fun () -> interface := true), - "Parse as interface" ); - ( "-jsx-version", - Arg.Int (fun i -> jsxVersion := i), - "Apply a specific built-in ppx before parsing, none or 3, 4. Default: \ - none" ); - ( "-jsx-module", - Arg.String (fun txt -> jsxModule := txt), - "Specify the jsx module. Default: react" ); - ( "-jsx-mode", - Arg.String (fun txt -> jsxMode := txt), - "Specify the jsx mode, classic or automatic. Default: automatic" ); - ( "-typechecker", - Arg.Unit (fun () -> typechecker := true), - "Parses the ast as it would be passed to the typechecker and not the \ - printer" ); - ] - - let parse () = Arg.parse spec (fun f -> file := f) usage -end - -module CliArgProcessor = struct - type backend = Parser : 'diagnostics Res_driver.parsingEngine -> backend - [@@unboxed] - - let processFile ~isInterface ~width ~recover ~origin ~target ~jsxVersion - ~jsxModule ~jsxMode ~typechecker filename = - let len = String.length filename in - let processInterface = - isInterface - || (len > 0 && (String.get [@doesNotRaise]) filename (len - 1) = 'i') - in - let parsingEngine = - match origin with - | "ml" -> Parser Res_driver_ml_parser.parsingEngine - | "res" -> Parser Res_driver.parsingEngine - | "" -> ( - match Filename.extension filename with - | ".ml" | ".mli" -> Parser Res_driver_ml_parser.parsingEngine - | _ -> Parser Res_driver.parsingEngine) - | origin -> - print_endline - ("-parse needs to be either ml or res. You provided " ^ origin); - exit 1 - in - let printEngine = - match target with - | "binary" -> Res_driver_binary.printEngine - | "ml" -> Res_driver_ml_parser.printEngine - | "ast" -> Res_ast_debugger.printEngine - | "sexp" -> Res_ast_debugger.sexpPrintEngine - | "comments" -> Res_ast_debugger.commentsPrintEngine - | "res" -> Res_driver.printEngine - | target -> - print_endline - ("-print needs to be either binary, ml, ast, sexp, comments or res. \ - You provided " ^ target); - exit 1 - in - - let forPrinter = - match target with - | ("res" | "sexp") when not typechecker -> true - | _ -> false - in - - let (Parser backend) = parsingEngine in - (* This is the whole purpose of the Color module above *) - Color.setup None; - if processInterface then - let parseResult = backend.parseInterface ~forPrinter ~filename in - if parseResult.invalid then ( - backend.stringOfDiagnostics ~source:parseResult.source - ~filename:parseResult.filename parseResult.diagnostics; - if recover then - printEngine.printInterface ~width ~filename - ~comments:parseResult.comments parseResult.parsetree - else exit 1) - else - let parsetree = - Jsx_ppx.rewrite_signature ~jsxVersion ~jsxModule ~jsxMode - parseResult.parsetree - in - printEngine.printInterface ~width ~filename - ~comments:parseResult.comments parsetree - else - let parseResult = backend.parseImplementation ~forPrinter ~filename in - if parseResult.invalid then ( - backend.stringOfDiagnostics ~source:parseResult.source - ~filename:parseResult.filename parseResult.diagnostics; - if recover then - printEngine.printImplementation ~width ~filename - ~comments:parseResult.comments parseResult.parsetree - else exit 1) - else - let parsetree = - Jsx_ppx.rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode - parseResult.parsetree - in - printEngine.printImplementation ~width ~filename - ~comments:parseResult.comments parsetree - [@@raises exit] -end - -let () = - if not !Sys.interactive then ( - ResClflags.parse (); - CliArgProcessor.processFile ~isInterface:!ResClflags.interface - ~width:!ResClflags.width ~recover:!ResClflags.recover - ~target:!ResClflags.print ~origin:!ResClflags.origin - ~jsxVersion:!ResClflags.jsxVersion ~jsxModule:!ResClflags.jsxModule - ~jsxMode:!ResClflags.jsxMode ~typechecker:!ResClflags.typechecker - !ResClflags.file) -[@@raises exit] diff --git a/jscomp/syntax/dune b/jscomp/syntax/dune deleted file mode 100644 index 0a8105d..0000000 --- a/jscomp/syntax/dune +++ /dev/null @@ -1,9 +0,0 @@ -(dirs compiler-libs-406 src cli benchmarks testrunner) - -(env - (dev - (flags - (:standard -w -A))) - (release - (flags - (:standard -w -A)))) diff --git a/jscomp/syntax/src/dune b/jscomp/syntax/src/dune deleted file mode 100644 index 428528a..0000000 --- a/jscomp/syntax/src/dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name syntax) - (wrapped false) - (flags - (:standard -w -A)) - (libraries ml)) diff --git a/jscomp/syntax/src/jsx_common.ml b/jscomp/syntax/src/jsx_common.ml deleted file mode 100644 index 5379e10..0000000 --- a/jscomp/syntax/src/jsx_common.ml +++ /dev/null @@ -1,82 +0,0 @@ -open Asttypes -open Parsetree - -type jsxConfig = { - mutable version: int; - mutable module_: string; - mutable mode: string; - mutable nestedModules: string list; - mutable hasComponent: bool; -} - -(* Helper method to look up the [@react.component] attribute *) -let hasAttr (loc, _) = - match loc.txt with - | "react.component" | "jsx.component" -> true - | _ -> false - -(* Iterate over the attributes and try to find the [@react.component] attribute *) -let hasAttrOnBinding {pvb_attributes} = - List.find_opt hasAttr pvb_attributes <> None - -let coreTypeOfAttrs attributes = - List.find_map - (fun ({txt}, payload) -> - match (txt, payload) with - | ("react.component" | "jsx.component"), PTyp coreType -> Some coreType - | _ -> None) - attributes - -let typVarsOfCoreType {ptyp_desc} = - match ptyp_desc with - | Ptyp_constr (_, coreTypes) -> - List.filter - (fun {ptyp_desc} -> - match ptyp_desc with - | Ptyp_var _ -> true - | _ -> false) - coreTypes - | _ -> [] - -let raiseError ~loc msg = Location.raise_errorf ~loc msg - -let raiseErrorMultipleComponent ~loc = - raiseError ~loc - "Only one component definition is allowed for each module. Move to a \ - submodule or other file if necessary." - -let optionalAttr = ({txt = "res.optional"; loc = Location.none}, PStr []) - -let extractUncurried typ = - if Ast_uncurried.coreTypeIsUncurriedFun typ then - let _arity, t = Ast_uncurried.coreTypeExtractUncurriedFun typ in - t - else typ - -let removeArity binding = - let rec removeArityRecord expr = - match expr.pexp_desc with - | _ when Ast_uncurried.exprIsUncurriedFun expr -> - Ast_uncurried.exprExtractUncurriedFun expr - | Pexp_newtype (label, e) -> - {expr with pexp_desc = Pexp_newtype (label, removeArityRecord e)} - | Pexp_apply (forwardRef, [(label, e)]) -> - { - expr with - pexp_desc = Pexp_apply (forwardRef, [(label, removeArityRecord e)]); - } - | _ -> expr - in - {binding with pvb_expr = removeArityRecord binding.pvb_expr} - -let async_component ~async expr = - if async then - let open Ast_helper in - Exp.apply - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "JsxPPXReactSupport", "asyncComponent"); - }) - [(Nolabel, expr)] - else expr diff --git a/jscomp/syntax/src/jsx_ppx.ml b/jscomp/syntax/src/jsx_ppx.ml deleted file mode 100644 index e0e1cac..0000000 --- a/jscomp/syntax/src/jsx_ppx.ml +++ /dev/null @@ -1,176 +0,0 @@ -open Ast_mapper -open Asttypes -open Parsetree -open Longident - -let getPayloadFields payload = - match payload with - | PStr - ({ - pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); - } - :: _rest) -> - recordFields - | _ -> [] - -type configKey = Int | String - -let getJsxConfigByKey ~key ~type_ recordFields = - let values = - List.filter_map - (fun ((lid, expr) : Longident.t Location.loc * expression) -> - match (type_, lid, expr) with - | ( Int, - {txt = Lident k}, - {pexp_desc = Pexp_constant (Pconst_integer (value, None))} ) - when k = key -> - Some value - | ( String, - {txt = Lident k}, - (* accept both normal strings and "js" strings *) - {pexp_desc = Pexp_constant (Pconst_string (value, _))} ) - when k = key -> - Some value - | _ -> None) - recordFields - in - match values with - | [] -> None - | [v] | v :: _ -> Some v - -let getInt ~key fields = - match fields |> getJsxConfigByKey ~key ~type_:Int with - | None -> None - | Some s -> int_of_string_opt s - -let getString ~key fields = fields |> getJsxConfigByKey ~key ~type_:String - -let updateConfig config payload = - let fields = getPayloadFields payload in - let moduleRaw = getString ~key:"module_" fields in - let isGeneric = - match moduleRaw |> Option.map (fun m -> String.lowercase_ascii m) with - | Some "react" | None -> false - | Some _ -> true - in - (match (isGeneric, getInt ~key:"version" fields) with - | true, _ -> config.Jsx_common.version <- 4 - | false, Some i -> config.Jsx_common.version <- i - | _ -> ()); - (match moduleRaw with - | None -> () - | Some s -> config.module_ <- s); - match (isGeneric, getString ~key:"mode" fields) with - | true, _ -> config.mode <- "automatic" - | false, Some s -> config.mode <- s - | _ -> () - -let isJsxConfigAttr ((loc, _) : attribute) = loc.txt = "jsxConfig" - -let processConfigAttribute attribute config = - if isJsxConfigAttr attribute then updateConfig config (snd attribute) - -let getMapper ~config = - let expr3, module_binding3, transformSignatureItem3, transformStructureItem3 = - Reactjs_jsx_v3.jsxMapper ~config - in - let expr4, module_binding4, transformSignatureItem4, transformStructureItem4 = - Jsx_v4.jsxMapper ~config - in - - let expr mapper e = - match config.version with - | 3 -> expr3 mapper e - | 4 -> expr4 mapper e - | _ -> default_mapper.expr mapper e - in - let module_binding mapper mb = - match config.version with - | 3 -> module_binding3 mapper mb - | 4 -> module_binding4 mapper mb - | _ -> default_mapper.module_binding mapper mb - in - let saveConfig () = - { - config with - version = config.version; - module_ = config.module_; - mode = config.mode; - hasComponent = config.hasComponent; - } - in - let restoreConfig oldConfig = - config.version <- oldConfig.Jsx_common.version; - config.module_ <- oldConfig.module_; - config.mode <- oldConfig.mode; - config.hasComponent <- oldConfig.hasComponent - in - let signature mapper items = - let oldConfig = saveConfig () in - config.hasComponent <- false; - let result = - List.map - (fun item -> - (match item.psig_desc with - | Psig_attribute attr -> processConfigAttribute attr config - | _ -> ()); - let item = default_mapper.signature_item mapper item in - if config.version = 3 then transformSignatureItem3 item - else if config.version = 4 then transformSignatureItem4 item - else [item]) - items - |> List.flatten - in - restoreConfig oldConfig; - result - in - let structure mapper items = - let oldConfig = saveConfig () in - config.hasComponent <- false; - let result = - List.map - (fun item -> - (match item.pstr_desc with - | Pstr_attribute attr -> processConfigAttribute attr config - | _ -> ()); - let item = default_mapper.structure_item mapper item in - if config.version = 3 then transformStructureItem3 item - else if config.version = 4 then transformStructureItem4 item - else [item]) - items - |> List.flatten - in - restoreConfig oldConfig; - result - in - - {default_mapper with expr; module_binding; signature; structure} - -let rewrite_implementation ~jsxVersion ~jsxModule ~jsxMode - (code : Parsetree.structure) : Parsetree.structure = - let config = - { - Jsx_common.version = jsxVersion; - module_ = jsxModule; - mode = jsxMode; - nestedModules = []; - hasComponent = false; - } - in - let mapper = getMapper ~config in - mapper.structure mapper code - -let rewrite_signature ~jsxVersion ~jsxModule ~jsxMode - (code : Parsetree.signature) : Parsetree.signature = - let config = - { - Jsx_common.version = jsxVersion; - module_ = jsxModule; - mode = jsxMode; - nestedModules = []; - hasComponent = false; - } - in - let mapper = getMapper ~config in - mapper.signature mapper code diff --git a/jscomp/syntax/src/jsx_ppx.mli b/jscomp/syntax/src/jsx_ppx.mli deleted file mode 100644 index 36a8468..0000000 --- a/jscomp/syntax/src/jsx_ppx.mli +++ /dev/null @@ -1,23 +0,0 @@ -(* - This is the module that handles turning Reason JSX' agnostic function call into - a ReasonReact-specific function call. Aka, this is a macro, using OCaml's ppx - facilities; https://whitequark.org/blog/2014/04/16/a-guide-to-extension- - points-in-ocaml/ - You wouldn't use this file directly; it's used by ReScript's - rescript.json. Specifically, there's a field called `react-jsx` inside the - field `reason`, which enables this ppx through some internal call in bsb -*) - -val rewrite_implementation : - jsxVersion:int -> - jsxModule:string -> - jsxMode:string -> - Parsetree.structure -> - Parsetree.structure - -val rewrite_signature : - jsxVersion:int -> - jsxModule:string -> - jsxMode:string -> - Parsetree.signature -> - Parsetree.signature diff --git a/jscomp/syntax/src/jsx_v4.ml b/jscomp/syntax/src/jsx_v4.ml deleted file mode 100644 index 89427fb..0000000 --- a/jscomp/syntax/src/jsx_v4.ml +++ /dev/null @@ -1,1481 +0,0 @@ -open Ast_helper -open Ast_mapper -open Asttypes -open Parsetree -open Longident - -let moduleAccessName config value = - String.capitalize_ascii config.Jsx_common.module_ ^ "." ^ value - |> Longident.parse - -let nolabel = Nolabel - -let labelled str = Labelled str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false - -let isForwardRef = function - | {pexp_desc = Pexp_ident {txt = Ldot (Lident "React", "forwardRef")}} -> true - | _ -> false - -let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" - -let optionalAttrs = [Jsx_common.optionalAttr] - -let constantString ~loc str = - Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) - -(* {} empty record *) -let emptyRecord ~loc = Exp.record ~loc [] None - -let unitExpr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None - -let safeTypeFromValue valueStr = - let valueStr = getLabel valueStr in - if valueStr = "" || (valueStr.[0] [@doesNotRaise]) <> '_' then valueStr - else "T" ^ valueStr - -let refTypeVar loc = Typ.var ~loc "ref" - -let refType loc = - Typ.constr ~loc - {loc; txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")} - [refTypeVar loc] - -type 'a children = ListLiteral of 'a | Exact of 'a - -(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) -let transformChildrenIfListUpper ~mapper theList = - let rec transformChildren_ theList accum = - (* not in the sense of converting a list to an array; convert the AST - reprensentation of a list to the AST reprensentation of an array *) - match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array (List.rev accum))) - | { - pexp_desc = - Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); - } -> - transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> Exact (mapper.expr mapper notAList) - in - transformChildren_ theList [] - -let transformChildrenIfList ~mapper theList = - let rec transformChildren_ theList accum = - (* not in the sense of converting a list to an array; convert the AST - reprensentation of a list to the AST reprensentation of an array *) - match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array (List.rev accum) - | { - pexp_desc = - Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); - } -> - transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> mapper.expr mapper notAList - in - transformChildren_ theList [] - -let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = - let rec allButLast_ lst acc = - match lst with - | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - Jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" - | arg :: rest -> allButLast_ rest (arg :: acc) - in - let allButLast lst = allButLast_ lst [] |> List.rev in - match - List.partition - (fun (label, _) -> label = labelled "children") - propsAndChildren - with - | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct {loc = Location.none; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) - | _ -> - Jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" - -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) - -(* Helper method to filter out any attribute that isn't [@react.component] *) -let otherAttrsPure (loc, _) = - match loc.txt with - | "react.component" | "jsx.component" -> false - | _ -> true - -(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) -let rec getFnName binding = - match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - Jsx_common.raiseError ~loc:ppat_loc - "JSX component calls cannot be destructured." - -let makeNewBinding binding expression newName = - match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - Jsx_common.raiseError ~loc:pvb_loc - "JSX component calls cannot be destructured." - -(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) -let filenameFromLoc (pstr_loc : Location.t) = - let fileName = - match pstr_loc.loc_start.pos_fname with - | "" -> !Location.input_name - | fileName -> fileName - in - let fileName = - try Filename.chop_extension (Filename.basename fileName) - with Invalid_argument _ -> fileName - in - let fileName = String.capitalize_ascii fileName in - fileName - -(* Build a string representation of a module name with segments separated by $ *) -let makeModuleName fileName nestedModules fnName = - let fullModuleName = - match (fileName, nestedModules, fnName) with - (* TODO: is this even reachable? It seems like the fileName always exists *) - | "", nestedModules, "make" -> nestedModules - | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) - | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules - | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) - in - let fullModuleName = String.concat "$" fullModuleName in - fullModuleName - -(* - AST node builders - These functions help us build AST nodes that are needed when transforming a [@react.component] into a - constructor and a props external - *) - -(* make record from props and spread props if exists *) -let recordFromProps ~loc ~removeKey callArguments = - let spreadPropsLabel = "_spreadProps" in - let rec removeLastPositionUnitAux props acc = - match props with - | [] -> acc - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - Jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" - | ((Labelled txt, {pexp_loc}) as prop) :: rest - | ((Optional txt, {pexp_loc}) as prop) :: rest -> - if txt = spreadPropsLabel then - match acc with - | [] -> removeLastPositionUnitAux rest (prop :: acc) - | _ -> - Jsx_common.raiseError ~loc:pexp_loc - "JSX: use {...p} {x: v} not {x: v} {...p} \n\ - \ multiple spreads {...p} {...p} not allowed." - else removeLastPositionUnitAux rest (prop :: acc) - in - let props, propsToSpread = - removeLastPositionUnitAux callArguments [] - |> List.rev - |> List.partition (fun (label, _) -> label <> labelled "_spreadProps") - in - let props = - if removeKey then - props |> List.filter (fun (arg_label, _) -> "key" <> getLabel arg_label) - else props - in - - let processProp (arg_label, ({pexp_loc} as pexpr)) = - (* In case filed label is "key" only then change expression to option *) - let id = getLabel arg_label in - if isOptional arg_label then - ( {txt = Lident id; loc = pexp_loc}, - {pexpr with pexp_attributes = optionalAttrs} ) - else ({txt = Lident id; loc = pexp_loc}, pexpr) - in - let fields = props |> List.map processProp in - let spreadFields = - propsToSpread |> List.map (fun (_, expression) -> expression) - in - match (fields, spreadFields) with - | [], [spreadProps] | [], spreadProps :: _ -> spreadProps - | _, [] -> - { - pexp_desc = Pexp_record (fields, None); - pexp_loc = loc; - pexp_attributes = []; - } - | _, [spreadProps] - (* take the first spreadProps only *) - | _, spreadProps :: _ -> - { - pexp_desc = Pexp_record (fields, Some spreadProps); - pexp_loc = loc; - pexp_attributes = []; - } - -(* make type params for make fn arguments *) -(* let make = ({id, name, children}: props<'id, 'name, 'children>) *) -let makePropsTypeParamsTvar namedTypeList = - namedTypeList - |> List.filter_map (fun (_isOptional, label, _, loc, _interiorType) -> - if label = "key" then None - else Some (Typ.var ~loc @@ safeTypeFromValue (Labelled label))) - -let stripOption coreType = - match coreType with - | {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, coreTypes)} -> - List.nth_opt coreTypes 0 [@doesNotRaise] - | _ -> Some coreType - -let stripJsNullable coreType = - match coreType with - | { - ptyp_desc = - Ptyp_constr ({txt = Ldot (Ldot (Lident "Js", "Nullable"), "t")}, coreTypes); - } -> - List.nth_opt coreTypes 0 [@doesNotRaise] - | _ -> Some coreType - -(* Make type params of the props type *) -(* (Sig) let make: React.componentLike, React.element> *) -(* (Str) let make = ({x, _}: props<'x>) => body *) -(* (Str) external make: React.componentLike, React.element> = "default" *) -let makePropsTypeParams ?(stripExplicitOption = false) - ?(stripExplicitJsNullableOfRef = false) namedTypeList = - namedTypeList - |> List.filter_map (fun (isOptional, label, _, loc, interiorType) -> - if label = "key" then None - (* TODO: Worth thinking how about "ref_" or "_ref" usages *) - else if label = "ref" then - (* - If ref has a type annotation then use it, else 'ref. - For example, if JSX ppx is used for React Native, type would be different. - *) - match interiorType with - | {ptyp_desc = Ptyp_any} -> Some (refTypeVar loc) - | _ -> - (* Strip explicit Js.Nullable.t in case of forwardRef *) - if stripExplicitJsNullableOfRef then stripJsNullable interiorType - else Some interiorType - (* Strip the explicit option type in implementation *) - (* let make = (~x: option=?) => ... *) - else if isOptional && stripExplicitOption then stripOption interiorType - else Some interiorType) - -let makeLabelDecls namedTypeList = - let rec checkDuplicatedLabel l = - let rec mem_label ((_, (la : string), _, _, _) as x) = function - | [] -> false - | (_, (lb : string), _, _, _) :: l -> lb = la || mem_label x l - in - match l with - | [] -> () - | hd :: tl -> - if mem_label hd tl then - let _, label, _, loc, _ = hd in - Jsx_common.raiseError ~loc "JSX: found the duplicated prop `%s`" label - else checkDuplicatedLabel tl - in - let () = namedTypeList |> List.rev |> checkDuplicatedLabel in - - namedTypeList - |> List.map (fun (isOptional, label, attrs, loc, interiorType) -> - if label = "key" then - Type.field ~loc ~attrs:(optionalAttrs @ attrs) {txt = label; loc} - interiorType - else if isOptional then - Type.field ~loc ~attrs:(optionalAttrs @ attrs) {txt = label; loc} - (Typ.var @@ safeTypeFromValue @@ Labelled label) - else - Type.field ~loc ~attrs {txt = label; loc} - (Typ.var @@ safeTypeFromValue @@ Labelled label)) - -let makeTypeDecls ~attrs propsName loc namedTypeList = - let labelDeclList = makeLabelDecls namedTypeList in - (* 'id, 'className, ... *) - let params = - makePropsTypeParamsTvar namedTypeList - |> List.map (fun coreType -> (coreType, Invariant)) - in - [ - Type.mk ~attrs ~loc ~params {txt = propsName; loc} - ~kind:(Ptype_record labelDeclList); - ] - -let makeTypeDeclsWithCoreType propsName loc coreType typVars = - [ - Type.mk ~loc {txt = propsName; loc} ~kind:Ptype_abstract - ~params:(typVars |> List.map (fun v -> (v, Invariant))) - ~manifest:coreType; - ] - -let live_attr = ({txt = "live"; loc = Location.none}, PStr []) - -(* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordType ~coreTypeOfAttr ~external_ ~typVarsOfCoreType propsName - loc namedTypeList = - let attrs = if external_ then [live_attr] else [] in - Str.type_ Nonrecursive - (match coreTypeOfAttr with - | None -> makeTypeDecls ~attrs propsName loc namedTypeList - | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) - -(* type props<'x, 'y, ...> = { x: 'x, y?: 'y, ... } *) -let makePropsRecordTypeSig ~coreTypeOfAttr ~external_ ~typVarsOfCoreType - propsName loc namedTypeList = - let attrs = if external_ then [live_attr] else [] in - Sig.type_ Nonrecursive - (match coreTypeOfAttr with - | None -> makeTypeDecls ~attrs propsName loc namedTypeList - | Some coreType -> - makeTypeDeclsWithCoreType propsName loc coreType typVarsOfCoreType) - -let transformUppercaseCall3 ~config modulePath mapper jsxExprLoc callExprLoc - attrs callArguments = - let children, argsWithLabels = - extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments - in - let argsForMake = argsWithLabels in - let childrenExpr = transformChildrenIfListUpper ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) - in - let childrenArg = ref None in - let args = - recursivelyTransformedArgsForMake - @ - match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] - | ListLiteral expression -> ( - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - match config.Jsx_common.mode with - | "automatic" -> - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = moduleAccessName config "array"; loc = Location.none}) - [(Nolabel, expression)] ); - ] - | _ -> - [ - ( labelled "children", - Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "null")} - ); - ]) - in - - let isCap str = String.capitalize_ascii str = str in - let ident ~suffix = - match modulePath with - | Lident _ -> Ldot (modulePath, suffix) - | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, suffix) - | modulePath -> modulePath - in - let isEmptyRecord {pexp_desc} = - match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true - | _ -> false - in - - (* handle key, ref, children *) - (* React.createElement(Component.make, props, ...children) *) - let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in - let props = - if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record - in - let keyProp = - args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) - in - let makeID = - Exp.ident ~loc:callExprLoc {txt = ident ~suffix:"make"; loc = callExprLoc} - in - match config.mode with - (* The new jsx transform *) - | "automatic" -> - let jsxExpr, keyAndUnit = - match (!childrenArg, keyProp) with - | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = moduleAccessName config "jsxKeyed"}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | None, [] -> - ( Exp.ident {loc = Location.none; txt = moduleAccessName config "jsx"}, - [] ) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = moduleAccessName config "jsxsKeyed"}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = moduleAccessName config "jsxs"}, - [] ) - in - Exp.apply ~loc:jsxExprLoc ~attrs jsxExpr - ([(nolabel, makeID); (nolabel, props)] @ keyAndUnit) - | _ -> ( - match (!childrenArg, keyProp) with - | None, key :: _ -> - Exp.apply ~loc:jsxExprLoc ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "JsxPPXReactSupport", "createElementWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props)] - | None, [] -> - Exp.apply ~loc:jsxExprLoc ~attrs - (Exp.ident - {loc = Location.none; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, makeID); (nolabel, props)] - | Some children, key :: _ -> - Exp.apply ~loc:jsxExprLoc ~attrs - (Exp.ident - { - loc = Location.none; - txt = - Ldot (Lident "JsxPPXReactSupport", "createElementVariadicWithKey"); - }) - [key; (nolabel, makeID); (nolabel, props); (nolabel, children)] - | Some children, [] -> - Exp.apply ~loc:jsxExprLoc ~attrs - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "React", "createElementVariadic"); - }) - [(nolabel, makeID); (nolabel, props); (nolabel, children)]) - -let transformLowercaseCall3 ~config mapper jsxExprLoc callExprLoc attrs - callArguments id = - let componentNameExpr = constantString ~loc:callExprLoc id in - match config.Jsx_common.mode with - (* the new jsx transform *) - | "automatic" -> - let elementBinding = - match config.module_ |> String.lowercase_ascii with - | "react" -> Lident "ReactDOM" - | _generic -> moduleAccessName config "Elements" - in - - let children, nonChildrenProps = - extractChildren ~removeLastPositionUnit:true ~loc:jsxExprLoc callArguments - in - let argsForMake = nonChildrenProps in - let childrenExpr = transformChildrenIfListUpper ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) - in - let childrenArg = ref None in - let args = - recursivelyTransformedArgsForMake - @ - match childrenExpr with - | Exact children -> - [ - ( labelled "children", - Exp.apply ~attrs:optionalAttrs - (Exp.ident - { - txt = Ldot (elementBinding, "someElement"); - loc = Location.none; - }) - [(Nolabel, children)] ); - ] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] - | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.apply - (Exp.ident - {txt = moduleAccessName config "array"; loc = Location.none}) - [(Nolabel, expression)] ); - ] - in - let isEmptyRecord {pexp_desc} = - match pexp_desc with - | Pexp_record (labelDecls, _) when List.length labelDecls = 0 -> true - | _ -> false - in - let record = recordFromProps ~loc:jsxExprLoc ~removeKey:true args in - let props = - if isEmptyRecord record then emptyRecord ~loc:jsxExprLoc else record - in - let keyProp = - args |> List.filter (fun (arg_label, _) -> "key" = getLabel arg_label) - in - let jsxExpr, keyAndUnit = - match (!childrenArg, keyProp) with - | None, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (elementBinding, "jsxKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | None, [] -> - (Exp.ident {loc = Location.none; txt = Ldot (elementBinding, "jsx")}, []) - | Some _, key :: _ -> - ( Exp.ident - {loc = Location.none; txt = Ldot (elementBinding, "jsxsKeyed")}, - [key; (nolabel, unitExpr ~loc:Location.none)] ) - | Some _, [] -> - ( Exp.ident {loc = Location.none; txt = Ldot (elementBinding, "jsxs")}, - [] ) - in - Exp.apply ~loc:jsxExprLoc ~attrs jsxExpr - ([(nolabel, componentNameExpr); (nolabel, props)] @ keyAndUnit) - | _ -> - let children, nonChildrenProps = - extractChildren ~loc:jsxExprLoc callArguments - in - let childrenExpr = transformChildrenIfList ~mapper children in - let createElementCall = - match children with - (* [@JSX] div(~children=[a]), coming from
a
*) - | { - pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); - } -> - "createDOMElementVariadic" - (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." - in - let args = - match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - | nonEmptyProps -> - let propsRecord = - recordFromProps ~loc:Location.none ~removeKey:false nonEmptyProps - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOM.domProps(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsRecord); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - in - Exp.apply ~loc:jsxExprLoc ~attrs - (* ReactDOM.createElement *) - (Exp.ident - { - loc = Location.none; - txt = Ldot (Lident "ReactDOM", createElementCall); - }) - args - -let rec recursivelyTransformNamedArgsForMake expr args newtypes coreType = - match expr.pexp_desc with - (* TODO: make this show up with a loc. *) - | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" - | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Please use `forwardRef` API \ - instead." - | Pexp_fun (arg, default, pattern, expression) - when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = - match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option<%s>=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | { - ppat_desc = - ( Ppat_alias (_, {txt}) - | Ppat_var {txt} - | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) ); - } -> - txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, {ptyp_desc = Ptyp_package _})} -> None - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in - - recursivelyTransformNamedArgsForMake expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes coreType - | Pexp_fun - ( Nolabel, - _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, - _expression ) -> - (args, newtypes, coreType) - | Pexp_fun - ( Nolabel, - _, - ({ - ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); - } as pattern), - _expression ) -> - if txt = "ref" then - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in - (* The ref arguement of forwardRef should be optional *) - ( (Optional "ref", None, pattern, txt, pattern.ppat_loc, type_) :: args, - newtypes, - coreType ) - else (args, newtypes, coreType) - | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." - | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake expression args (label :: newtypes) - coreType - | Pexp_constraint (expression, coreType) -> - recursivelyTransformNamedArgsForMake expression args newtypes - (Some coreType) - | _ -> (args, newtypes, coreType) - -let argToType types - ((name, default, {ppat_attributes = attrs}, _alias, loc, type_) : - arg_label * expression option * pattern * label * 'loc * core_type option) - = - match (type_, name, default) with - | Some type_, name, _ when isOptional name -> - (true, getLabel name, attrs, loc, type_) :: types - | Some type_, name, _ -> (false, getLabel name, attrs, loc, type_) :: types - | None, name, _ when isOptional name -> - (true, getLabel name, attrs, loc, Typ.any ~loc ()) :: types - | None, name, _ when isLabelled name -> - (false, getLabel name, attrs, loc, Typ.any ~loc ()) :: types - | _ -> types - -let hasDefaultValue nameArgList = - nameArgList - |> List.exists (fun (name, default, _, _, _, _) -> - Option.is_some default && isOptional name) - -let argToConcreteType types (name, attrs, loc, type_) = - match name with - | name when isLabelled name -> - (false, getLabel name, attrs, loc, type_) :: types - | name when isOptional name -> - (true, getLabel name, attrs, loc, type_) :: types - | _ -> types - -let check_string_int_attribute_iter = - let attribute _ ({txt; loc}, _) = - if txt = "string" || txt = "int" then - Jsx_common.raiseError ~loc - "@string and @int attributes not supported. See \ - https://github.com/rescript-lang/rescript-compiler/issues/5724" - in - - {Ast_iterator.default_iterator with attribute} - -let checkMultipleComponents ~config ~loc = - (* If there is another component, throw error *) - if config.Jsx_common.hasComponent then - Jsx_common.raiseErrorMultipleComponent ~loc - else config.hasComponent <- true - -let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression)} - -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc - "JSX component calls can only be on function definitions or component \ - wrappers (forwardRef, memo)." - in - spelunkForFunExpression expression - -let modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc ~attrs:binding.pvb_attributes - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) - in - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - {expression with pexp_desc = Pexp_fun (label, default, pattern, exp)} ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, - _internalExpression ); - } -> - ((fun a -> a), false, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ((Labelled _ | Optional _), _default, _pattern, _internalExpression); - } -> - ((fun a -> a), false, expression) - (* let make = (prop) => ... *) - | {pexp_desc = Pexp_fun (_nolabel, _default, pattern, _internalExpression)} - -> - if !hasApplication then ((fun a -> a), false, expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ instead of a \ - name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, _, exp = spelunkForFunExpression internalExpression in - let hasForwardRef = isForwardRef wrapperExpression in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasForwardRef, - exp ) - | {pexp_desc = Pexp_sequence (wrapperExpression, internalExpression)} -> - let wrap, hasForwardRef, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasForwardRef, - {expression with pexp_desc = Pexp_sequence (wrapperExpression, exp)} ) - | e -> ((fun a -> a), false, e) - in - let wrapExpression, hasForwardRef, expression = - spelunkForFunExpression expression - in - (wrapExpressionWithBinding wrapExpression, hasForwardRef, expression) - -let vbMatch ~expr (name, default, _, alias, loc, _) = - let label = getLabel name in - match default with - | Some default -> - let value_binding = - Vb.mk - (Pat.var (Location.mkloc alias loc)) - (Exp.match_ - (Exp.ident {txt = Lident ("__" ^ alias); loc = Location.none}) - [ - Exp.case - (Pat.construct - (Location.mknoloc @@ Lident "Some") - (Some (Pat.var (Location.mknoloc label)))) - (Exp.ident (Location.mknoloc @@ Lident label)); - Exp.case - (Pat.construct (Location.mknoloc @@ Lident "None") None) - default; - ]) - in - Exp.let_ Nonrecursive [value_binding] expr - | None -> expr - -let vbMatchExpr namedArgList expr = - let rec aux namedArgList = - match namedArgList with - | [] -> expr - | namedArg :: rest -> vbMatch namedArg ~expr:(aux rest) - in - aux (List.rev namedArgList) - -let mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding = - if Jsx_common.hasAttrOnBinding binding then ( - checkMultipleComponents ~config ~loc:pstr_loc; - let binding = Jsx_common.removeArity binding in - let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs binding.pvb_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map Jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - pvb_attributes = binding.pvb_attributes |> List.filter otherAttrsPure; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName config.nestedModules fnName in - let bindingWrapper, hasForwardRef, expression = - modifiedBinding ~bindingLoc ~bindingPatLoc ~fnName binding - in - let isAsync = - Ext_list.find_first binding.pvb_expr.pexp_attributes Ast_async.is_async - |> Option.is_some - in - (* do stuff here! *) - let namedArgList, newtypes, _typeConstraints = - recursivelyTransformNamedArgsForMake - (modifiedBindingOld binding) - [] [] None - in - let namedTypeList = List.fold_left argToType [] namedArgList in - (* type props = { ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~external_:false ~typVarsOfCoreType - "props" pstr_loc namedTypeList - in - let innerExpression = - Exp.apply - (Exp.ident - (Location.mknoloc - @@ Lident - (match recFlag with - | Recursive -> internalFnName - | Nonrecursive -> fnName))) - ([(Nolabel, Exp.ident (Location.mknoloc @@ Lident "props"))] - @ - match hasForwardRef with - | true -> [(Nolabel, Exp.ident (Location.mknoloc @@ Lident "ref"))] - | false -> []) - in - let makePropsPattern = function - | [] -> Pat.var @@ Location.mknoloc "props" - | _ -> - Pat.constraint_ - (Pat.var @@ Location.mknoloc "props") - (Typ.constr (Location.mknoloc @@ Lident "props") [Typ.any ()]) - in - let innerExpression = - Jsx_common.async_component ~async:isAsync innerExpression - in - let fullExpression = - (* React component name should start with uppercase letter *) - (* let make = { let \"App" = props => make(props); \"App" } *) - (* let make = React.forwardRef({ - let \"App" = (props, ref) => make({...props, ref: @optional (Js.Nullabel.toOption(ref))}) - })*) - Exp.fun_ nolabel None - (match coreTypeOfAttr with - | None -> makePropsPattern namedTypeList - | Some _ -> makePropsPattern typVarsOfCoreType) - (if hasForwardRef then - Exp.fun_ nolabel None - (Pat.var @@ Location.mknoloc "ref") - innerExpression - else innerExpression) - in - let fullExpression = - if !Config.uncurried = Uncurried then - fullExpression - |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc - ~arity:(if hasForwardRef then 2 else 1) - else fullExpression - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:pstr_loc {loc = emptyLoc; txt = Lident txt}) - in - let rec stripConstraintUnpack ~label pattern = - match pattern with - | {ppat_desc = Ppat_constraint (_, {ptyp_desc = Ptyp_package _})} -> - pattern - | {ppat_desc = Ppat_constraint (pattern, _)} -> - stripConstraintUnpack ~label pattern - | _ -> pattern - in - let safePatternLabel pattern = - match pattern with - | {ppat_desc = Ppat_var {txt; loc}} -> - {pattern with ppat_desc = Ppat_var {txt = "__" ^ txt; loc}} - | {ppat_desc = Ppat_alias (p, {txt; loc})} -> - {pattern with ppat_desc = Ppat_alias (p, {txt = "__" ^ txt; loc})} - | _ -> pattern - in - let rec returnedExpression patternsWithLabel patternsWithNolabel - ({pexp_desc} as expr) = - match pexp_desc with - | Pexp_newtype (_, expr) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_constraint (expr, _) -> - returnedExpression patternsWithLabel patternsWithNolabel expr - | Pexp_fun - ( _arg_label, - _default, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}, - expr ) -> - (patternsWithLabel, patternsWithNolabel, expr) - | Pexp_fun (arg_label, default, ({ppat_loc; ppat_desc} as pattern), expr) - -> ( - let patternWithoutConstraint = - stripConstraintUnpack ~label:(getLabel arg_label) pattern - in - (* - If prop has the default value as Ident, it will get a build error - when the referenced Ident value and the prop have the same name. - So we add a "__" to label to resolve the build error. - *) - let patternWithSafeLabel = - match default with - | Some _ -> safePatternLabel patternWithoutConstraint - | _ -> patternWithoutConstraint - in - if isLabelled arg_label || isOptional arg_label then - returnedExpression - (( {loc = ppat_loc; txt = Lident (getLabel arg_label)}, - { - patternWithSafeLabel with - ppat_attributes = - (if isOptional arg_label then optionalAttrs else []) - @ pattern.ppat_attributes; - } ) - :: patternsWithLabel) - patternsWithNolabel expr - else - (* Special case of nolabel arg "ref" in forwardRef fn *) - (* let make = React.forwardRef(ref => body) *) - match ppat_desc with - | Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) - -> - returnedExpression patternsWithLabel - (( {loc = ppat_loc; txt = Lident txt}, - { - pattern with - ppat_attributes = optionalAttrs @ pattern.ppat_attributes; - } ) - :: patternsWithNolabel) - expr - | _ -> returnedExpression patternsWithLabel patternsWithNolabel expr) - | _ -> (patternsWithLabel, patternsWithNolabel, expr) - in - let patternsWithLabel, patternsWithNolabel, expression = - returnedExpression [] [] expression - in - (* add pattern matching for optional prop value *) - let expression = - if hasDefaultValue namedArgList then vbMatchExpr namedArgList expression - else expression - in - (* (ref) => expr *) - let expression = - List.fold_left - (fun expr (_, pattern) -> - let pattern = - match pattern.ppat_desc with - | Ppat_var {txt} when txt = "ref" -> - Pat.constraint_ pattern (refType Location.none) - | _ -> pattern - in - Exp.fun_ Nolabel None pattern expr) - expression patternsWithNolabel - in - (* ({a, b, _}: props<'a, 'b>) *) - let recordPattern = - match patternsWithLabel with - | [] -> Pat.any () - | _ -> Pat.record (List.rev patternsWithLabel) Open - in - let expression = - Exp.fun_ Nolabel None - (Pat.constraint_ recordPattern - (Typ.constr ~loc:emptyLoc - {txt = Lident "props"; loc = emptyLoc} - (match coreTypeOfAttr with - | None -> - makePropsTypeParams ~stripExplicitOption:true - ~stripExplicitJsNullableOfRef:hasForwardRef namedTypeList - | Some _ -> ( - match typVarsOfCoreType with - | [] -> [] - | _ -> [Typ.any ()])))) - expression - in - let expression = Ast_async.add_async_attribute ~async:isAsync expression in - let expression = - (* Add new tupes (type a,b,c) to make's definition *) - newtypes - |> List.fold_left (fun e newtype -> Exp.newtype newtype e) expression - in - (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) - let binding, newBinding = - match recFlag with - | Recursive -> - ( bindingWrapper - (Exp.let_ ~loc:emptyLoc Nonrecursive - [makeNewBinding binding expression internalFnName] - (Exp.let_ ~loc:emptyLoc Nonrecursive - [ - Vb.mk (Pat.var {loc = emptyLoc; txt = fnName}) fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName}))), - None ) - | Nonrecursive -> - ( { - binding with - pvb_expr = expression; - pvb_pat = Pat.var {txt = fnName; loc = Location.none}; - }, - Some (bindingWrapper fullExpression) ) - in - (Some propsRecordType, binding, newBinding)) - else (None, binding, None) - -let transformStructureItem ~config item = - match item with - (* external *) - | { - pstr_loc; - pstr_desc = - Pstr_primitive ({pval_attributes; pval_type} as value_description); - } as pstr -> ( - match List.filter Jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - checkMultipleComponents ~config ~loc:pstr_loc; - check_string_int_attribute_iter.structure_item - check_string_int_attribute_iter item; - let pval_type = Jsx_common.extractUncurried pval_type in - let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map Jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types - ({ptyp_loc; ptyp_desc; ptyp_attributes} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_attributes, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - ( returnValue, - (name, ptyp_attributes, returnValue.ptyp_loc, type_) :: types ) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr ~loc:pstr_loc - (Location.mkloc (Lident "props") pstr_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> ( - match typVarsOfCoreType with - | [] -> [] - | _ -> [Typ.any ()])) - in - (* type props<'x, 'y> = { x: 'x, y?: 'y, ... } *) - let propsRecordType = - makePropsRecordType ~coreTypeOfAttr ~external_:true ~typVarsOfCoreType - "props" pstr_loc namedTypeList - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = moduleAccessName config "componentLike"}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure] - | _ -> - Jsx_common.raiseError ~loc:pstr_loc - "Only one JSX component call can exist on a component at one time") - (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let processBinding binding (newItems, bindings, newBindings) = - let newItem, binding, newBinding = - mapBinding ~config ~emptyLoc ~pstr_loc ~fileName ~recFlag binding - in - let newItems = - match newItem with - | Some item -> item :: newItems - | None -> newItems - in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings - in - (newItems, binding :: bindings, newBindings) - in - let newItems, bindings, newBindings = - List.fold_right processBinding valueBindings ([], [], []) - in - newItems - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] - -let transformSignatureItem ~config item = - match item with - | { - psig_loc; - psig_desc = Psig_value ({pval_attributes; pval_type} as psig_desc); - } as psig -> ( - match List.filter Jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - checkMultipleComponents ~config ~loc:psig_loc; - let pval_type = Jsx_common.extractUncurried pval_type in - check_string_int_attribute_iter.signature_item - check_string_int_attribute_iter item; - let coreTypeOfAttr = Jsx_common.coreTypeOfAttrs pval_attributes in - let typVarsOfCoreType = - coreTypeOfAttr - |> Option.map Jsx_common.typVarsOfCoreType - |> Option.value ~default:[] - in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow - ( name, - ({ptyp_attributes = attrs} as type_), - ({ptyp_desc = Ptyp_arrow _} as rest) ) - when isOptional name || isLabelled name -> - getPropTypes ((name, attrs, ptyp_loc, type_) :: types) rest - | Ptyp_arrow - (Nolabel, {ptyp_desc = Ptyp_constr ({txt = Lident "unit"}, _)}, rest) - -> - getPropTypes types rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, ({ptyp_attributes = attrs} as type_), returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, attrs, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let retPropsType = - Typ.constr - (Location.mkloc (Lident "props") psig_loc) - (match coreTypeOfAttr with - | None -> makePropsTypeParams namedTypeList - | Some _ -> ( - match typVarsOfCoreType with - | [] -> [] - | _ -> [Typ.any ()])) - in - let external_ = psig_desc.pval_prim <> [] in - let propsRecordType = - makePropsRecordTypeSig ~coreTypeOfAttr ~external_ ~typVarsOfCoreType - "props" psig_loc namedTypeList - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = moduleAccessName config "componentLike"}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [propsRecordType; newStructure] - | _ -> - Jsx_common.raiseError ~loc:psig_loc - "Only one JSX component call can exist on a component at one time") - | _ -> [item] - -let transformJsxCall ~config mapper callExpression callArguments jsxExprLoc - attrs = - match callExpression.pexp_desc with - | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - Jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> - transformUppercaseCall3 ~config modulePath mapper jsxExprLoc loc attrs - callArguments - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOM.createElement(~props=ReactDOM.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> - transformLowercaseCall3 ~config mapper jsxExprLoc loc attrs callArguments - id - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - Jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We saw \ - `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - Jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") - | _ -> - Jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." - -let expr ~config mapper expression = - match expression with - (* Does the function application have the @JSX attribute? *) - | { - pexp_desc = Pexp_apply (callExpression, callArguments); - pexp_attributes; - pexp_loc; - } -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall ~config mapper callExpression callArguments pexp_loc - nonJSXAttributes) - (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) - | { - pexp_desc = - ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); - pexp_attributes; - } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - match config.mode with - | "automatic" -> - Exp.ident ~loc {loc; txt = moduleAccessName config "jsxFragment"} - | "classic" | _ -> - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "fragment")} - in - let childrenExpr = transformChildrenIfList ~mapper listItems in - let recordOfChildren children = - Exp.record [(Location.mknoloc (Lident "children"), children)] None - in - let applyJsxArray expr = - Exp.apply - (Exp.ident - {txt = moduleAccessName config "array"; loc = Location.none}) - [(Nolabel, expr)] - in - let countOfChildren = function - | {pexp_desc = Pexp_array children} -> List.length children - | _ -> 0 - in - let transformChildrenToProps childrenExpr = - match childrenExpr with - | {pexp_desc = Pexp_array children} -> ( - match children with - | [] -> emptyRecord ~loc:Location.none - | [child] -> recordOfChildren child - | _ -> ( - match config.mode with - | "automatic" -> recordOfChildren @@ applyJsxArray childrenExpr - | "classic" | _ -> emptyRecord ~loc:Location.none)) - | _ -> ( - match config.mode with - | "automatic" -> recordOfChildren @@ applyJsxArray childrenExpr - | "classic" | _ -> emptyRecord ~loc:Location.none) - in - let args = - (nolabel, fragment) - :: (nolabel, transformChildrenToProps childrenExpr) - :: - (match config.mode with - | "classic" when countOfChildren childrenExpr > 1 -> - [(nolabel, childrenExpr)] - | _ -> []) - in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOM.createElement *) - (match config.mode with - | "automatic" -> - if countOfChildren childrenExpr > 1 then - Exp.ident ~loc {loc; txt = moduleAccessName config "jsxs"} - else Exp.ident ~loc {loc; txt = moduleAccessName config "jsx"} - | "classic" | _ -> - if countOfChildren childrenExpr > 1 then - Exp.ident ~loc - {loc; txt = Ldot (Lident "React", "createElementVariadic")} - else - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")}) - args) - (* Delegate to the default mapper, a deep identity traversal *) - | e -> default_mapper.expr mapper e - -let module_binding ~(config : Jsx_common.jsxConfig) mapper module_binding = - config.nestedModules <- module_binding.pmb_name.txt :: config.nestedModules; - let mapped = default_mapper.module_binding mapper module_binding in - let () = - match config.nestedModules with - | _ :: rest -> config.nestedModules <- rest - | [] -> () - in - mapped - -(* TODO: some line number might still be wrong *) -let jsxMapper ~config = - let expr = expr ~config in - let module_binding = module_binding ~config in - let transformStructureItem = transformStructureItem ~config in - let transformSignatureItem = transformSignatureItem ~config in - (expr, module_binding, transformSignatureItem, transformStructureItem) diff --git a/jscomp/syntax/src/reactjs_jsx_v3.ml b/jscomp/syntax/src/reactjs_jsx_v3.ml deleted file mode 100644 index 83316c9..0000000 --- a/jscomp/syntax/src/reactjs_jsx_v3.ml +++ /dev/null @@ -1,1196 +0,0 @@ -open Ast_helper -open Ast_mapper -open Asttypes -open Parsetree -open Longident - -let nolabel = Nolabel - -let labelled str = Labelled str - -let optional str = Optional str - -let isOptional str = - match str with - | Optional _ -> true - | _ -> false - -let isLabelled str = - match str with - | Labelled _ -> true - | _ -> false - -let getLabel str = - match str with - | Optional str | Labelled str -> str - | Nolabel -> "" - -let optionIdent = Lident "option" - -let constantString ~loc str = - Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) - -let safeTypeFromValue valueStr = - let valueStr = getLabel valueStr in - if valueStr = "" || (valueStr.[0] [@doesNotRaise]) <> '_' then valueStr - else "T" ^ valueStr - -let keyType loc = - Typ.constr ~loc {loc; txt = optionIdent} - [Typ.constr ~loc {loc; txt = Lident "string"} []] - -type 'a children = ListLiteral of 'a | Exact of 'a - -type componentConfig = {propsName: string} - -(* if children is a list, convert it to an array while mapping each element. If not, just map over it, as usual *) -let transformChildrenIfListUpper ~loc ~mapper theList = - let rec transformChildren_ theList accum = - (* not in the sense of converting a list to an array; convert the AST - reprensentation of a list to the AST reprensentation of an array *) - match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> ( - match accum with - | [singleElement] -> Exact singleElement - | accum -> ListLiteral (Exp.array ~loc (List.rev accum))) - | { - pexp_desc = - Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); - } -> - transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> Exact (mapper.expr mapper notAList) - in - transformChildren_ theList [] - -let transformChildrenIfList ~loc ~mapper theList = - let rec transformChildren_ theList accum = - (* not in the sense of converting a list to an array; convert the AST - reprensentation of a list to the AST reprensentation of an array *) - match theList with - | {pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> - Exp.array ~loc (List.rev accum) - | { - pexp_desc = - Pexp_construct - ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple [v; acc]}); - } -> - transformChildren_ acc (mapper.expr mapper v :: accum) - | notAList -> mapper.expr mapper notAList - in - transformChildren_ theList [] - -let extractChildren ?(removeLastPositionUnit = false) ~loc propsAndChildren = - let rec allButLast_ lst acc = - match lst with - | [] -> [] - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> - acc - | (Nolabel, {pexp_loc}) :: _rest -> - Jsx_common.raiseError ~loc:pexp_loc - "JSX: found non-labelled argument before the last position" - | arg :: rest -> allButLast_ rest (arg :: acc) - in - let allButLast lst = allButLast_ lst [] |> List.rev in - match - List.partition - (fun (label, _) -> label = labelled "children") - propsAndChildren - with - | [], props -> - (* no children provided? Place a placeholder list *) - ( Exp.construct ~loc {loc; txt = Lident "[]"} None, - if removeLastPositionUnit then allButLast props else props ) - | [(_, childrenExpr)], props -> - (childrenExpr, if removeLastPositionUnit then allButLast props else props) - | _ -> - Jsx_common.raiseError ~loc - "JSX: somehow there's more than one `children` label" - -let unerasableIgnore loc = - ( {loc; txt = "warning"}, - PStr [Str.eval (Exp.constant (Pconst_string ("-16", None)))] ) - -let merlinFocus = ({loc = Location.none; txt = "merlin.focus"}, PStr []) - -(* Helper method to filter out any attribute that isn't [@react.component] *) -let otherAttrsPure (loc, _) = loc.txt <> "react.component" - -(* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *) -let rec getFnName binding = - match binding with - | {ppat_desc = Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_constraint (pat, _)} -> getFnName pat - | {ppat_loc} -> - Jsx_common.raiseError ~loc:ppat_loc - "react.component calls cannot be destructured." - -let makeNewBinding binding expression newName = - match binding with - | {pvb_pat = {ppat_desc = Ppat_var ppat_var} as pvb_pat} -> - { - binding with - pvb_pat = - {pvb_pat with ppat_desc = Ppat_var {ppat_var with txt = newName}}; - pvb_expr = expression; - pvb_attributes = [merlinFocus]; - } - | {pvb_loc} -> - Jsx_common.raiseError ~loc:pvb_loc - "react.component calls cannot be destructured." - -(* Lookup the value of `props` otherwise raise Invalid_argument error *) -let getPropsNameValue _acc (loc, exp) = - match (loc, exp) with - | {txt = Lident "props"}, {pexp_desc = Pexp_ident {txt = Lident str}} -> - {propsName = str} - | {txt; loc}, _ -> - Jsx_common.raiseError ~loc - "react.component only accepts props as an option, given: { %s }" - (Longident.last txt) - -(* Lookup the `props` record or string as part of [@react.component] and store the name for use when rewriting *) -let getPropsAttr payload = - let defaultProps = {propsName = "Props"} in - match payload with - | Some - (PStr - ({ - pstr_desc = - Pstr_eval ({pexp_desc = Pexp_record (recordFields, None)}, _); - } - :: _rest)) -> - List.fold_left getPropsNameValue defaultProps recordFields - | Some - (PStr - ({ - pstr_desc = - Pstr_eval ({pexp_desc = Pexp_ident {txt = Lident "props"}}, _); - } - :: _rest)) -> - {propsName = "props"} - | Some (PStr ({pstr_desc = Pstr_eval (_, _); pstr_loc} :: _rest)) -> - Jsx_common.raiseError ~loc:pstr_loc - "react.component accepts a record config with props as an options." - | _ -> defaultProps - -(* Plucks the label, loc, and type_ from an AST node *) -let pluckLabelDefaultLocType (label, default, _, _, loc, type_) = - (label, default, loc, type_) - -(* Lookup the filename from the location information on the AST node and turn it into a valid module identifier *) -let filenameFromLoc (pstr_loc : Location.t) = - let fileName = - match pstr_loc.loc_start.pos_fname with - | "" -> !Location.input_name - | fileName -> fileName - in - let fileName = - try Filename.chop_extension (Filename.basename fileName) - with Invalid_argument _ -> fileName - in - let fileName = String.capitalize_ascii fileName in - fileName - -(* Build a string representation of a module name with segments separated by $ *) -let makeModuleName fileName nestedModules fnName = - let fullModuleName = - match (fileName, nestedModules, fnName) with - (* TODO: is this even reachable? It seems like the fileName always exists *) - | "", nestedModules, "make" -> nestedModules - | "", nestedModules, fnName -> List.rev (fnName :: nestedModules) - | fileName, nestedModules, "make" -> fileName :: List.rev nestedModules - | fileName, nestedModules, fnName -> - fileName :: List.rev (fnName :: nestedModules) - in - let fullModuleName = String.concat "$" fullModuleName in - fullModuleName - -(* - AST node builders - These functions help us build AST nodes that are needed when transforming a [@react.component] into a - constructor and a props external -*) - -(* Build an AST node representing all named args for the `external` definition for a component's props *) -let rec recursivelyMakeNamedArgsForExternal list args = - match list with - | (label, default, loc, interiorType) :: tl -> - recursivelyMakeNamedArgsForExternal tl - (Typ.arrow ~loc label - (match (label, interiorType, default) with - (* ~foo=1 *) - | label, None, Some _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo: int=1 *) - | _label, Some type_, Some _ -> type_ - (* ~foo: option=? *) - | ( label, - Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, - _ ) - | ( label, - Some - { - ptyp_desc = - Ptyp_constr - ({txt = Ldot (Lident "*predef*", "option")}, [type_]); - }, - _ ) - (* ~foo: int=? - note this isnt valid. but we want to get a type error *) - | label, Some type_, _ - when isOptional label -> - type_ - (* ~foo=? *) - | label, None, _ when isOptional label -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - (* ~foo *) - | label, None, _ -> - { - ptyp_desc = Ptyp_var (safeTypeFromValue label); - ptyp_loc = loc; - ptyp_attributes = []; - } - | _label, Some type_, _ -> type_) - args) - | [] -> args - -(* Build an AST node for the [@bs.obj] representing props for a component *) -let makePropsValue fnName loc namedArgListWithKeyAndRef propsType = - let propsName = fnName ^ "Props" in - { - pval_name = {txt = propsName; loc}; - pval_type = - recursivelyMakeNamedArgsForExternal namedArgListWithKeyAndRef - (Typ.arrow nolabel - { - ptyp_desc = Ptyp_constr ({txt = Lident "unit"; loc}, []); - ptyp_loc = loc; - ptyp_attributes = []; - } - propsType); - pval_prim = [""]; - pval_attributes = [({txt = "bs.obj"; loc}, PStr [])]; - pval_loc = loc; - } - -(* Build an AST node representing an `external` with the definition of the [@bs.obj] *) -let makePropsExternal fnName loc namedArgListWithKeyAndRef propsType = - { - pstr_loc = loc; - pstr_desc = - Pstr_primitive - (makePropsValue fnName loc namedArgListWithKeyAndRef propsType); - } - -(* Build an AST node for the signature of the `external` definition *) -let makePropsExternalSig fnName loc namedArgListWithKeyAndRef propsType = - { - psig_loc = loc; - psig_desc = - Psig_value (makePropsValue fnName loc namedArgListWithKeyAndRef propsType); - } - -(* Build an AST node for the props name when converted to an object inside the function signature *) -let makePropsName ~loc name = - {ppat_desc = Ppat_var {txt = name; loc}; ppat_loc = loc; ppat_attributes = []} - -let makeObjectField loc (str, attrs, type_) = - Otag ({loc; txt = str}, attrs, type_) - -(* Build an AST node representing a "closed" object representing a component's props *) -let makePropsType ~loc namedTypeList = - Typ.mk ~loc - (Ptyp_object (List.map (makeObjectField loc) namedTypeList, Closed)) - -(* Builds an AST node for the entire `external` definition of props *) -let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList = - makePropsExternal fnName loc - (List.map pluckLabelDefaultLocType namedArgListWithKeyAndRef) - (makePropsType ~loc namedTypeList) - -let newtypeToVar newtype type_ = - let var_desc = Ptyp_var ("type-" ^ newtype) in - let typ (mapper : Ast_mapper.mapper) typ = - match typ.ptyp_desc with - | Ptyp_constr ({txt = Lident name}, _) when name = newtype -> - {typ with ptyp_desc = var_desc} - | _ -> Ast_mapper.default_mapper.typ mapper typ - in - let mapper = {Ast_mapper.default_mapper with typ} in - mapper.typ mapper type_ - -(* TODO: some line number might still be wrong *) -let jsxMapper ~config = - let transformUppercaseCall3 modulePath mapper loc attrs _ callArguments = - let children, argsWithLabels = - extractChildren ~loc ~removeLastPositionUnit:true callArguments - in - let argsForMake = argsWithLabels in - let childrenExpr = transformChildrenIfListUpper ~loc ~mapper children in - let recursivelyTransformedArgsForMake = - argsForMake - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) - in - let childrenArg = ref None in - let args = - recursivelyTransformedArgsForMake - @ (match childrenExpr with - | Exact children -> [(labelled "children", children)] - | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] - | ListLiteral expression -> - (* this is a hack to support react components that introspect into their children *) - childrenArg := Some expression; - [ - ( labelled "children", - Exp.ident ~loc {loc; txt = Ldot (Lident "React", "null")} ); - ]) - @ [(nolabel, Exp.construct ~loc {loc; txt = Lident "()"} None)] - in - let isCap str = String.capitalize_ascii str = str in - let ident = - match modulePath with - | Lident _ -> Ldot (modulePath, "make") - | Ldot (_modulePath, value) as fullPath when isCap value -> - Ldot (fullPath, "make") - | modulePath -> modulePath - in - let propsIdent = - match ident with - | Lident path -> Lident (path ^ "Props") - | Ldot (ident, path) -> Ldot (ident, path ^ "Props") - | _ -> - Jsx_common.raiseError ~loc - "JSX name can't be the result of function applications" - in - let props = - Exp.apply ~attrs ~loc (Exp.ident ~loc {loc; txt = propsIdent}) args - in - (* handle key, ref, children *) - (* React.createElement(Component.make, props, ...children) *) - match !childrenArg with - | None -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc {loc; txt = Ldot (Lident "React", "createElement")}) - [(nolabel, Exp.ident ~loc {txt = ident; loc}); (nolabel, props)] - | Some children -> - Exp.apply ~loc ~attrs - (Exp.ident ~loc - {loc; txt = Ldot (Lident "React", "createElementVariadic")}) - [ - (nolabel, Exp.ident ~loc {txt = ident; loc}); - (nolabel, props); - (nolabel, children); - ] - in - - let transformLowercaseCall3 mapper loc attrs callArguments id = - let children, nonChildrenProps = extractChildren ~loc callArguments in - let componentNameExpr = constantString ~loc id in - let childrenExpr = transformChildrenIfList ~loc ~mapper children in - let createElementCall = - match children with - (* [@JSX] div(~children=[a]), coming from
a
*) - | { - pexp_desc = - ( Pexp_construct ({txt = Lident "::"}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"}, None) ); - } -> - "createDOMElementVariadic" - (* [@JSX] div(~children= value), coming from
...(value)
*) - | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc - "A spread as a DOM element's children don't make sense written \ - together. You can simply remove the spread." - in - let args = - match nonChildrenProps with - | [_justTheUnitArgumentAtEnd] -> - [ - (* "div" *) - (nolabel, componentNameExpr); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - | nonEmptyProps -> - let propsCall = - Exp.apply ~loc - (Exp.ident ~loc {loc; txt = Ldot (Lident "ReactDOMRe", "domProps")}) - (nonEmptyProps - |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression))) - in - [ - (* "div" *) - (nolabel, componentNameExpr); - (* ReactDOMRe.props(~className=blabla, ~foo=bar, ()) *) - (labelled "props", propsCall); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs - (* ReactDOMRe.createElement *) - (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", createElementCall)}) - args - in - - let rec recursivelyTransformNamedArgsForMake expr args newtypes = - match expr.pexp_desc with - (* TODO: make this show up with a loc. *) - | Pexp_fun (Labelled "key", _, _, _) | Pexp_fun (Optional "key", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc - "Key cannot be accessed inside of a component. Don't worry - you can \ - always key a component from its parent!" - | Pexp_fun (Labelled "ref", _, _, _) | Pexp_fun (Optional "ref", _, _, _) -> - Jsx_common.raiseError ~loc:expr.pexp_loc - "Ref cannot be passed as a normal prop. Either give the prop a \ - different name or use the `forwardRef` API instead." - | Pexp_fun (arg, default, pattern, expression) - when isOptional arg || isLabelled arg -> - let () = - match (isOptional arg, pattern, default) with - | true, {ppat_desc = Ppat_constraint (_, {ptyp_desc})}, None -> ( - match ptyp_desc with - | Ptyp_constr ({txt = Lident "option"}, [_]) -> () - | _ -> - let currentType = - match ptyp_desc with - | Ptyp_constr ({txt}, []) -> - String.concat "." (Longident.flatten txt) - | Ptyp_constr ({txt}, _innerTypeArgs) -> - String.concat "." (Longident.flatten txt) ^ "(...)" - | _ -> "..." - in - Location.prerr_warning pattern.ppat_loc - (Preprocessor - (Printf.sprintf - "React: optional argument annotations must have explicit \ - `option`. Did you mean `option<%s>=?`?" - currentType))) - | _ -> () - in - let alias = - match pattern with - | {ppat_desc = Ppat_alias (_, {txt}) | Ppat_var {txt}} -> txt - | {ppat_desc = Ppat_any} -> "_" - | _ -> getLabel arg - in - let type_ = - match pattern with - | {ppat_desc = Ppat_constraint (_, type_)} -> Some type_ - | _ -> None - in - - recursivelyTransformNamedArgsForMake expression - ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) - newtypes - | Pexp_fun - ( Nolabel, - _, - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}, - _expression ) -> - (args, newtypes, None) - | Pexp_fun - ( Nolabel, - _, - { - ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); - }, - _expression ) -> - (args, newtypes, Some txt) - | Pexp_fun (Nolabel, _, pattern, _expression) -> - Location.raise_errorf ~loc:pattern.ppat_loc - "React: react.component refs only support plain arguments and type \ - annotations." - | Pexp_newtype (label, expression) -> - recursivelyTransformNamedArgsForMake expression args (label :: newtypes) - | Pexp_constraint (expression, _typ) -> - recursivelyTransformNamedArgsForMake expression args newtypes - | _ -> (args, newtypes, None) - in - - let argToType types (name, default, _noLabelName, _alias, loc, type_) = - match (type_, name, default) with - | Some {ptyp_desc = Ptyp_constr ({txt = Lident "option"}, [type_])}, name, _ - when isOptional name -> - ( getLabel name, - [], - { - type_ with - ptyp_desc = - Ptyp_constr ({loc = type_.ptyp_loc; txt = optionIdent}, [type_]); - } ) - :: types - | Some type_, name, Some _default -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_constr ({loc; txt = optionIdent}, [type_]); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | Some type_, name, _ -> (getLabel name, [], type_) :: types - | None, name, _ when isOptional name -> - ( getLabel name, - [], - { - ptyp_desc = - Ptyp_constr - ( {loc; txt = optionIdent}, - [ - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - }; - ] ); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | None, name, _ when isLabelled name -> - ( getLabel name, - [], - { - ptyp_desc = Ptyp_var (safeTypeFromValue name); - ptyp_loc = loc; - ptyp_attributes = []; - } ) - :: types - | _ -> types - in - - let argToConcreteType types (name, loc, type_) = - match name with - | name when isLabelled name -> (getLabel name, [], type_) :: types - | name when isOptional name -> - (getLabel name, [], Typ.constr ~loc {loc; txt = optionIdent} [type_]) - :: types - | _ -> types - in - - let nestedModules = ref [] in - let transformStructureItem item = - match item with - (* external *) - | { - pstr_loc; - pstr_desc = - Pstr_primitive - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as - value_description); - } as pstr -> ( - match List.filter Jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let pval_type = Jsx_common.extractUncurried pval_type in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isLabelled name || isOptional name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isLabelled name || isOptional name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None (* default *), loc, Some type_) - in - let retPropsType = makePropsType ~loc:pstr_loc namedTypeList in - let externalPropsDecl = - makePropsExternal fnName pstr_loc - ((optional "key", None, pstr_loc, Some (keyType pstr_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = pstr_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - pstr with - pstr_desc = - Pstr_primitive - { - value_description with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - Jsx_common.raiseError ~loc:pstr_loc - "Only one react.component call can exist on a component at one time") - (* let component = ... *) - | {pstr_loc; pstr_desc = Pstr_value (recFlag, valueBindings)} -> ( - let fileName = filenameFromLoc pstr_loc in - let emptyLoc = Location.in_file fileName in - let mapBinding binding = - if Jsx_common.hasAttrOnBinding binding then - let binding = Jsx_common.removeArity binding in - let bindingLoc = binding.pvb_loc in - let bindingPatLoc = binding.pvb_pat.ppat_loc in - let binding = - { - binding with - pvb_pat = {binding.pvb_pat with ppat_loc = emptyLoc}; - pvb_loc = emptyLoc; - } - in - let fnName = getFnName binding.pvb_pat in - let internalFnName = fnName ^ "$Internal" in - let fullModuleName = makeModuleName fileName !nestedModules fnName in - let modifiedBindingOld binding = - let expression = binding.pvb_expr in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> - expression - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (_recursive, _vbs, returnExpression)} -> - (* here's where we spelunk! *) - spelunkForFunExpression returnExpression - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply - (_wrapperExpression, [(Nolabel, innerFunctionExpression)]); - } -> - spelunkForFunExpression innerFunctionExpression - | { - pexp_desc = - Pexp_sequence (_wrapperExpression, innerFunctionExpression); - } -> - spelunkForFunExpression innerFunctionExpression - | {pexp_desc = Pexp_constraint (innerFunctionExpression, _typ)} -> - spelunkForFunExpression innerFunctionExpression - | {pexp_loc} -> - Jsx_common.raiseError ~loc:pexp_loc - "react.component calls can only be on function definitions \ - or component wrappers (forwardRef, memo)." - in - spelunkForFunExpression expression - in - let modifiedBinding binding = - let hasApplication = ref false in - let wrapExpressionWithBinding expressionFn expression = - Vb.mk ~loc:bindingLoc - ~attrs:(List.filter otherAttrsPure binding.pvb_attributes) - (Pat.var ~loc:bindingPatLoc {loc = bindingPatLoc; txt = fnName}) - (expressionFn expression) - in - let expression = binding.pvb_expr in - let unerasableIgnoreExp exp = - { - exp with - pexp_attributes = - unerasableIgnore emptyLoc :: exp.pexp_attributes; - } - in - (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) - let rec spelunkForFunExpression expression = - match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ( ((Labelled _ | Optional _) as label), - default, - pattern, - ({pexp_desc = Pexp_fun _} as internalExpression) ); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - unerasableIgnoreExp - { - expression with - pexp_desc = Pexp_fun (label, default, pattern, exp); - } ) - (* let make = (()) => ... *) - (* let make = (_) => ... *) - | { - pexp_desc = - Pexp_fun - ( Nolabel, - _default, - { - ppat_desc = - Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; - }, - _internalExpression ); - } -> - ((fun a -> a), true, expression) - (* let make = (~prop) => ... *) - | { - pexp_desc = - Pexp_fun - ( (Labelled _ | Optional _), - _default, - _pattern, - _internalExpression ); - } -> - ((fun a -> a), false, unerasableIgnoreExp expression) - (* let make = (prop) => ... *) - | { - pexp_desc = - Pexp_fun (_nolabel, _default, pattern, _internalExpression); - } -> - if hasApplication.contents then - ((fun a -> a), false, unerasableIgnoreExp expression) - else - Location.raise_errorf ~loc:pattern.ppat_loc - "React: props need to be labelled arguments.\n\ - \ If you are working with refs be sure to wrap with \ - React.forwardRef.\n\ - \ If your component doesn't have any props use () or _ \ - instead of a name." - (* let make = {let foo = bar in (~prop) => ...} *) - | {pexp_desc = Pexp_let (recursive, vbs, internalExpression)} -> - (* here's where we spelunk! *) - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - {expression with pexp_desc = Pexp_let (recursive, vbs, exp)} - ) - (* let make = React.forwardRef((~prop) => ...) *) - | { - pexp_desc = - Pexp_apply (wrapperExpression, [(Nolabel, internalExpression)]); - } -> - let () = hasApplication := true in - let _, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( (fun exp -> Exp.apply wrapperExpression [(nolabel, exp)]), - hasUnit, - exp ) - | { - pexp_desc = Pexp_sequence (wrapperExpression, internalExpression); - } -> - let wrap, hasUnit, exp = - spelunkForFunExpression internalExpression - in - ( wrap, - hasUnit, - { - expression with - pexp_desc = Pexp_sequence (wrapperExpression, exp); - } ) - | e -> ((fun a -> a), false, e) - in - let wrapExpression, hasUnit, expression = - spelunkForFunExpression expression - in - (wrapExpressionWithBinding wrapExpression, hasUnit, expression) - in - let bindingWrapper, hasUnit, expression = modifiedBinding binding in - let reactComponentAttribute = - try Some (List.find Jsx_common.hasAttr binding.pvb_attributes) - with Not_found -> None - in - let _attr_loc, payload = - match reactComponentAttribute with - | Some (loc, payload) -> (loc.loc, Some payload) - | None -> (emptyLoc, None) - in - let props = getPropsAttr payload in - (* do stuff here! *) - let namedArgList, newtypes, forwardRef = - recursivelyTransformNamedArgsForMake - (modifiedBindingOld binding) - [] [] - in - let namedArgListWithKeyAndRef = - ( optional "key", - None, - Pat.var {txt = "key"; loc = emptyLoc}, - "key", - emptyLoc, - Some (keyType emptyLoc) ) - :: namedArgList - in - let namedArgListWithKeyAndRef = - match forwardRef with - | Some _ -> - ( optional "ref", - None, - Pat.var {txt = "key"; loc = emptyLoc}, - "ref", - emptyLoc, - None ) - :: namedArgListWithKeyAndRef - | None -> namedArgListWithKeyAndRef - in - let namedArgListWithKeyAndRefForNew = - match forwardRef with - | Some txt -> - namedArgList - @ [ - ( nolabel, - None, - Pat.var {txt; loc = emptyLoc}, - txt, - emptyLoc, - None ); - ] - | None -> namedArgList - in - let pluckArg (label, _, _, alias, loc, _) = - let labelString = - match label with - | label when isOptional label || isLabelled label -> - getLabel label - | _ -> "" - in - ( label, - match labelString with - | "" -> Exp.ident ~loc {txt = Lident alias; loc} - | labelString -> - Exp.apply ~loc - (Exp.ident ~loc {txt = Lident "##"; loc}) - [ - (nolabel, Exp.ident ~loc {txt = Lident props.propsName; loc}); - (nolabel, Exp.ident ~loc {txt = Lident labelString; loc}); - ] ) - in - let namedTypeList = List.fold_left argToType [] namedArgList in - let loc = emptyLoc in - let externalArgs = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, c, d, e, maybeTyp) -> - match maybeTyp with - | Some typ -> - (a, b, c, d, e, Some (newtypeToVar newtype.txt typ)) - | None -> (a, b, c, d, e, None)) - args) - namedArgListWithKeyAndRef newtypes - in - let externalTypes = - (* translate newtypes to type variables *) - List.fold_left - (fun args newtype -> - List.map - (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) - args) - namedTypeList newtypes - in - let externalDecl = - makeExternalDecl fnName loc externalArgs externalTypes - in - let innerExpressionArgs = - List.map pluckArg namedArgListWithKeyAndRefForNew - @ - if hasUnit then - [(Nolabel, Exp.construct {loc; txt = Lident "()"} None)] - else [] - in - let innerExpression = - Exp.apply - (Exp.ident - { - loc; - txt = - Lident - (match recFlag with - | Recursive -> internalFnName - | Nonrecursive -> fnName); - }) - innerExpressionArgs - in - let innerExpressionWithRef = - match forwardRef with - | Some txt -> - { - innerExpression with - pexp_desc = - Pexp_fun - ( nolabel, - None, - { - ppat_desc = Ppat_var {txt; loc = emptyLoc}; - ppat_loc = emptyLoc; - ppat_attributes = []; - }, - innerExpression ); - } - | None -> innerExpression - in - let fullExpression = - Exp.fun_ nolabel None - { - ppat_desc = - Ppat_constraint - ( makePropsName ~loc:emptyLoc props.propsName, - makePropsType ~loc:emptyLoc externalTypes ); - ppat_loc = emptyLoc; - ppat_attributes = []; - } - innerExpressionWithRef - in - let fullExpression = - if !Config.uncurried = Uncurried then - fullExpression - |> Ast_uncurried.uncurriedFun ~loc:fullExpression.pexp_loc - ~arity:1 - else fullExpression - in - let fullExpression = - match fullModuleName with - | "" -> fullExpression - | txt -> - Exp.let_ Nonrecursive - [ - Vb.mk ~loc:emptyLoc - (Pat.var ~loc:emptyLoc {loc = emptyLoc; txt}) - fullExpression; - ] - (Exp.ident ~loc:emptyLoc {loc = emptyLoc; txt = Lident txt}) - in - let bindings, newBinding = - match recFlag with - | Recursive -> - ( [ - bindingWrapper - (Exp.let_ ~loc:emptyLoc Recursive - [ - makeNewBinding binding expression internalFnName; - Vb.mk - (Pat.var {loc = emptyLoc; txt = fnName}) - fullExpression; - ] - (Exp.ident {loc = emptyLoc; txt = Lident fnName})); - ], - None ) - | Nonrecursive -> - ( [{binding with pvb_expr = expression}], - Some (bindingWrapper fullExpression) ) - in - (Some externalDecl, bindings, newBinding) - else (None, [binding], None) - in - let structuresAndBinding = List.map mapBinding valueBindings in - let otherStructures (extern, binding, newBinding) - (externs, bindings, newBindings) = - let externs = - match extern with - | Some extern -> extern :: externs - | None -> externs - in - let newBindings = - match newBinding with - | Some newBinding -> newBinding :: newBindings - | None -> newBindings - in - (externs, binding @ bindings, newBindings) - in - let externs, bindings, newBindings = - List.fold_right otherStructures structuresAndBinding ([], [], []) - in - externs - @ [{pstr_loc; pstr_desc = Pstr_value (recFlag, bindings)}] - @ - match newBindings with - | [] -> [] - | newBindings -> - [{pstr_loc = emptyLoc; pstr_desc = Pstr_value (recFlag, newBindings)}]) - | _ -> [item] - in - - let transformSignatureItem item = - match item with - | { - psig_loc; - psig_desc = - Psig_value - ({pval_name = {txt = fnName}; pval_attributes; pval_type} as - psig_desc); - } as psig -> ( - match List.filter Jsx_common.hasAttr pval_attributes with - | [] -> [item] - | [_] -> - let pval_type = Jsx_common.extractUncurried pval_type in - let rec getPropTypes types ({ptyp_loc; ptyp_desc} as fullType) = - match ptyp_desc with - | Ptyp_arrow (name, type_, ({ptyp_desc = Ptyp_arrow _} as rest)) - when isOptional name || isLabelled name -> - getPropTypes ((name, ptyp_loc, type_) :: types) rest - | Ptyp_arrow (Nolabel, _type, rest) -> getPropTypes types rest - | Ptyp_arrow (name, type_, returnValue) - when isOptional name || isLabelled name -> - (returnValue, (name, returnValue.ptyp_loc, type_) :: types) - | _ -> (fullType, types) - in - let innerType, propTypes = getPropTypes [] pval_type in - let namedTypeList = List.fold_left argToConcreteType [] propTypes in - let pluckLabelAndLoc (label, loc, type_) = - (label, None, loc, Some type_) - in - let retPropsType = makePropsType ~loc:psig_loc namedTypeList in - let externalPropsDecl = - makePropsExternalSig fnName psig_loc - ((optional "key", None, psig_loc, Some (keyType psig_loc)) - :: List.map pluckLabelAndLoc propTypes) - retPropsType - in - (* can't be an arrow because it will defensively uncurry *) - let newExternalType = - Ptyp_constr - ( {loc = psig_loc; txt = Ldot (Lident "React", "componentLike")}, - [retPropsType; innerType] ) - in - let newStructure = - { - psig with - psig_desc = - Psig_value - { - psig_desc with - pval_type = {pval_type with ptyp_desc = newExternalType}; - pval_attributes = List.filter otherAttrsPure pval_attributes; - }; - } - in - [externalPropsDecl; newStructure] - | _ -> - Jsx_common.raiseError ~loc:psig_loc - "Only one react.component call can exist on a component at one time") - | _ -> [item] - in - - let transformJsxCall mapper callExpression callArguments attrs = - match callExpression.pexp_desc with - | Pexp_ident caller -> ( - match caller with - | {txt = Lident "createElement"; loc} -> - Jsx_common.raiseError ~loc - "JSX: `createElement` should be preceeded by a module name." - (* Foo.createElement(~prop1=foo, ~prop2=bar, ~children=[], ()) *) - | {loc; txt = Ldot (modulePath, ("createElement" | "make"))} -> ( - match config.Jsx_common.version with - | 3 -> - transformUppercaseCall3 modulePath mapper loc attrs callExpression - callArguments - | _ -> Jsx_common.raiseError ~loc "JSX: the JSX version must be 3") - (* div(~prop1=foo, ~prop2=bar, ~children=[bla], ()) *) - (* turn that into - ReactDOMRe.createElement(~props=ReactDOMRe.props(~props1=foo, ~props2=bar, ()), [|bla|]) *) - | {loc; txt = Lident id} -> ( - match config.version with - | 3 -> transformLowercaseCall3 mapper loc attrs callArguments id - | _ -> Jsx_common.raiseError ~loc "JSX: the JSX version must be 3") - | {txt = Ldot (_, anythingNotCreateElementOrMake); loc} -> - Jsx_common.raiseError ~loc - "JSX: the JSX attribute should be attached to a \ - `YourModuleName.createElement` or `YourModuleName.make` call. We \ - saw `%s` instead" - anythingNotCreateElementOrMake - | {txt = Lapply _; loc} -> - (* don't think there's ever a case where this is reached *) - Jsx_common.raiseError ~loc - "JSX: encountered a weird case while processing the code. Please \ - report this!") - | _ -> - Jsx_common.raiseError ~loc:callExpression.pexp_loc - "JSX: `createElement` should be preceeded by a simple, direct module \ - name." - in - - let expr mapper expression = - match expression with - (* Does the function application have the @JSX attribute? *) - | {pexp_desc = Pexp_apply (callExpression, callArguments); pexp_attributes} - -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - transformJsxCall mapper callExpression callArguments nonJSXAttributes) - (* is it a list with jsx attribute? Reason <>foo desugars to [@JSX][foo]*) - | { - pexp_desc = - ( Pexp_construct - ({txt = Lident "::"; loc}, Some {pexp_desc = Pexp_tuple _}) - | Pexp_construct ({txt = Lident "[]"; loc}, None) ); - pexp_attributes; - } as listItems -> ( - let jsxAttribute, nonJSXAttributes = - List.partition - (fun (attribute, _) -> attribute.txt = "JSX") - pexp_attributes - in - match (jsxAttribute, nonJSXAttributes) with - (* no JSX attribute *) - | [], _ -> default_mapper.expr mapper expression - | _, nonJSXAttributes -> - let loc = {loc with loc_ghost = true} in - let fragment = - Exp.ident ~loc {loc; txt = Ldot (Lident "ReasonReact", "fragment")} - in - let childrenExpr = transformChildrenIfList ~loc ~mapper listItems in - let args = - [ - (* "div" *) - (nolabel, fragment); - (* [|moreCreateElementCallsHere|] *) - (nolabel, childrenExpr); - ] - in - Exp.apply - ~loc (* throw away the [@JSX] attribute and keep the others, if any *) - ~attrs:nonJSXAttributes - (* ReactDOMRe.createElement *) - (Exp.ident ~loc - {loc; txt = Ldot (Lident "ReactDOMRe", "createElement")}) - args) - (* Delegate to the default mapper, a deep identity traversal *) - | e -> default_mapper.expr mapper e - in - - let module_binding mapper module_binding = - let _ = nestedModules := module_binding.pmb_name.txt :: !nestedModules in - let mapped = default_mapper.module_binding mapper module_binding in - let () = - match !nestedModules with - | _ :: rest -> nestedModules := rest - | [] -> () - in - mapped - in - (expr, module_binding, transformSignatureItem, transformStructureItem) diff --git a/jscomp/syntax/src/res_ast_conversion.ml b/jscomp/syntax/src/res_ast_conversion.ml deleted file mode 100644 index b8c419b..0000000 --- a/jscomp/syntax/src/res_ast_conversion.ml +++ /dev/null @@ -1,593 +0,0 @@ -let concatLongidents l1 l2 = - let parts1 = Longident.flatten l1 in - let parts2 = Longident.flatten l2 in - match List.concat [parts1; parts2] |> Longident.unflatten with - | Some longident -> longident - | None -> l2 - -(* TODO: support nested open's ? *) -let rec rewritePpatOpen longidentOpen pat = - match pat.Parsetree.ppat_desc with - | Ppat_array (first :: rest) -> - (* Color.[Red, Blue, Green] -> [Color.Red, Blue, Green] *) - { - pat with - ppat_desc = Ppat_array (rewritePpatOpen longidentOpen first :: rest); - } - | Ppat_tuple (first :: rest) -> - (* Color.(Red, Blue, Green) -> (Color.Red, Blue, Green) *) - { - pat with - ppat_desc = Ppat_tuple (rewritePpatOpen longidentOpen first :: rest); - } - | Ppat_construct - ( ({txt = Longident.Lident "::"} as listConstructor), - Some ({ppat_desc = Ppat_tuple (pat :: rest)} as element) ) -> - (* Color.(list[Red, Blue, Green]) -> list[Color.Red, Blue, Green] *) - { - pat with - ppat_desc = - Ppat_construct - ( listConstructor, - Some - { - element with - ppat_desc = - Ppat_tuple (rewritePpatOpen longidentOpen pat :: rest); - } ); - } - | Ppat_construct (({txt = constructor} as longidentLoc), optPattern) -> - (* Foo.(Bar(a)) -> Foo.Bar(a) *) - { - pat with - ppat_desc = - Ppat_construct - ( {longidentLoc with txt = concatLongidents longidentOpen constructor}, - optPattern ); - } - | Ppat_record ((({txt = lbl} as longidentLoc), firstPat) :: rest, flag) -> - (* Foo.{x} -> {Foo.x: x} *) - let firstRow = - ({longidentLoc with txt = concatLongidents longidentOpen lbl}, firstPat) - in - {pat with ppat_desc = Ppat_record (firstRow :: rest, flag)} - | Ppat_or (pat1, pat2) -> - { - pat with - ppat_desc = - Ppat_or - ( rewritePpatOpen longidentOpen pat1, - rewritePpatOpen longidentOpen pat2 ); - } - | Ppat_constraint (pattern, typ) -> - { - pat with - ppat_desc = Ppat_constraint (rewritePpatOpen longidentOpen pattern, typ); - } - | Ppat_type ({txt = constructor} as longidentLoc) -> - { - pat with - ppat_desc = - Ppat_type - {longidentLoc with txt = concatLongidents longidentOpen constructor}; - } - | Ppat_lazy p -> - {pat with ppat_desc = Ppat_lazy (rewritePpatOpen longidentOpen p)} - | Ppat_exception p -> - {pat with ppat_desc = Ppat_exception (rewritePpatOpen longidentOpen p)} - | _ -> pat - -let escapeTemplateLiteral s = - let len = String.length s in - let b = Buffer.create len in - let i = ref 0 in - while !i < len do - let c = (String.get [@doesNotRaise]) s !i in - if c = '`' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '`'; - incr i) - else if c = '$' then - if !i + 1 < len then ( - let c2 = (String.get [@doesNotRaise]) s (!i + 1) in - if c2 = '{' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '$'; - Buffer.add_char b '{') - else ( - Buffer.add_char b c; - Buffer.add_char b c2); - i := !i + 2) - else ( - Buffer.add_char b c; - incr i) - else if c = '\\' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\'; - incr i) - else ( - Buffer.add_char b c; - incr i) - done; - Buffer.contents b - -let escapeStringContents s = - let len = String.length s in - let b = Buffer.create len in - - let i = ref 0 in - - while !i < len do - let c = String.unsafe_get s !i in - if c = '\\' then ( - incr i; - Buffer.add_char b c; - let c = String.unsafe_get s !i in - if !i < len then - let () = Buffer.add_char b c in - incr i - else ()) - else if c = '"' then ( - Buffer.add_char b '\\'; - Buffer.add_char b c; - incr i) - else ( - Buffer.add_char b c; - incr i) - done; - Buffer.contents b - -let looksLikeRecursiveTypeDeclaration typeDeclaration = - let open Parsetree in - let name = typeDeclaration.ptype_name.txt in - let rec checkKind kind = - match kind with - | Ptype_abstract | Ptype_open -> false - | Ptype_variant constructorDeclarations -> - List.exists checkConstructorDeclaration constructorDeclarations - | Ptype_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations - and checkConstructorDeclaration constrDecl = - checkConstructorArguments constrDecl.pcd_args - || - match constrDecl.pcd_res with - | Some typexpr -> checkTypExpr typexpr - | None -> false - and checkLabelDeclaration labelDeclaration = - checkTypExpr labelDeclaration.pld_type - and checkConstructorArguments constrArg = - match constrArg with - | Pcstr_tuple types -> List.exists checkTypExpr types - | Pcstr_record labelDeclarations -> - List.exists checkLabelDeclaration labelDeclarations - and checkTypExpr typ = - match typ.ptyp_desc with - | Ptyp_any -> false - | Ptyp_var _ -> false - | Ptyp_object (fields, _) -> List.exists checkObjectField fields - | Ptyp_class _ -> false - | Ptyp_package _ -> false - | Ptyp_extension _ -> false - | Ptyp_arrow (_lbl, typ1, typ2) -> checkTypExpr typ1 || checkTypExpr typ2 - | Ptyp_tuple types -> List.exists checkTypExpr types - | Ptyp_constr ({txt = longident}, types) -> - (match longident with - | Lident ident -> ident = name - | _ -> false) - || List.exists checkTypExpr types - | Ptyp_alias (typ, _) -> checkTypExpr typ - | Ptyp_variant (rowFields, _, _) -> List.exists checkRowFields rowFields - | Ptyp_poly (_, typ) -> checkTypExpr typ - and checkObjectField field = - match field with - | Otag (_label, _attrs, typ) -> checkTypExpr typ - | Oinherit typ -> checkTypExpr typ - and checkRowFields rowField = - match rowField with - | Rtag (_, _, _, types) -> List.exists checkTypExpr types - | Rinherit typexpr -> checkTypExpr typexpr - and checkManifest manifest = - match manifest with - | Some typ -> checkTypExpr typ - | None -> false - in - checkKind typeDeclaration.ptype_kind - || checkManifest typeDeclaration.ptype_manifest - -let filterReasonRawLiteral attrs = - List.filter - (fun attr -> - match attr with - | {Location.txt = "reason.raw_literal"}, _ -> false - | _ -> true) - attrs - -let stringLiteralMapper stringData = - let isSameLocation l1 l2 = - let open Location in - l1.loc_start.pos_cnum == l2.loc_start.pos_cnum - in - let remainingStringData = stringData in - let open Ast_mapper in - { - default_mapper with - expr = - (fun mapper expr -> - match expr.pexp_desc with - | Pexp_constant (Pconst_string (_txt, None)) -> ( - match - List.find_opt - (fun (_stringData, stringLoc) -> - isSameLocation stringLoc expr.pexp_loc) - remainingStringData - with - | Some (stringData, _) -> - let stringData = - let attr = - List.find_opt - (fun attr -> - match attr with - | {Location.txt = "reason.raw_literal"}, _ -> true - | _ -> false) - expr.pexp_attributes - in - match attr with - | Some - ( _, - PStr - [ - { - pstr_desc = - Pstr_eval - ( { - pexp_desc = - Pexp_constant (Pconst_string (raw, _)); - }, - _ ); - }; - ] ) -> - raw - | _ -> - (String.sub [@doesNotRaise]) stringData 1 - (String.length stringData - 2) - in - { - expr with - pexp_attributes = filterReasonRawLiteral expr.pexp_attributes; - pexp_desc = Pexp_constant (Pconst_string (stringData, None)); - } - | None -> default_mapper.expr mapper expr) - | _ -> default_mapper.expr mapper expr); - } - -let hasUncurriedAttribute attrs = - List.exists - (fun attr -> - match attr with - | {Asttypes.txt = "bs"}, Parsetree.PStr [] -> true - | _ -> false) - attrs - -let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) - -let normalize = - let open Ast_mapper in - { - default_mapper with - extension = - (fun mapper ext -> - match ext with - | id, payload -> - ( {id with txt = Res_printer.convertBsExtension id.txt}, - default_mapper.payload mapper payload )); - attribute = - (fun mapper attr -> - match attr with - | id, payload -> - ( {id with txt = Res_printer.convertBsExternalAttribute id.txt}, - default_mapper.payload mapper payload )); - attributes = - (fun mapper attrs -> - attrs - |> List.filter (fun attr -> - match attr with - | ( { - Location.txt = - ( "reason.preserve_braces" | "explicit_arity" - | "implicity_arity" ); - }, - _ ) -> - false - | _ -> true) - |> default_mapper.attributes mapper); - pat = - (fun mapper p -> - match p.ppat_desc with - | Ppat_open ({txt = longidentOpen}, pattern) -> - let p = rewritePpatOpen longidentOpen pattern in - default_mapper.pat mapper p - | Ppat_constant (Pconst_string (txt, tag)) -> - let newTag = - match tag with - (* transform {|abc|} into {js|abc|js}, because `template string` is interpreted as {js||js} *) - | Some "" -> Some "js" - | tag -> tag - in - let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in - { - p with - ppat_attributes = - templateLiteralAttr :: mapper.attributes mapper p.ppat_attributes; - ppat_desc = Ppat_constant s; - } - | _ -> default_mapper.pat mapper p); - typ = - (fun mapper typ -> - match typ.ptyp_desc with - | Ptyp_constr - ({txt = Longident.Ldot (Longident.Lident "Js", "t")}, [arg]) -> - (* Js.t({"a": b}) -> {"a": b} - Since compiler >9.0.1 objects don't need Js.t wrapping anymore *) - mapper.typ mapper arg - | _ -> default_mapper.typ mapper typ); - expr = - (fun mapper expr -> - match expr.pexp_desc with - | Pexp_constant (Pconst_string (txt, None)) -> - let raw = escapeStringContents txt in - let s = Parsetree.Pconst_string (raw, None) in - {expr with pexp_desc = Pexp_constant s} - | Pexp_constant (Pconst_string (txt, tag)) -> - let newTag = - match tag with - (* transform {|abc|} into {js|abc|js}, we want to preserve unicode by default *) - | Some "" -> Some "js" - | tag -> tag - in - let s = Parsetree.Pconst_string (escapeTemplateLiteral txt, newTag) in - { - expr with - pexp_attributes = - templateLiteralAttr - :: mapper.attributes mapper expr.pexp_attributes; - pexp_desc = Pexp_constant s; - } - | Pexp_apply - ( callExpr, - [ - ( Nolabel, - ({ - pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); - pexp_attributes = []; - } as unitExpr) ); - ] ) - when hasUncurriedAttribute expr.pexp_attributes -> - { - expr with - pexp_attributes = mapper.attributes mapper expr.pexp_attributes; - pexp_desc = - Pexp_apply - ( callExpr, - [ - ( Nolabel, - { - unitExpr with - pexp_loc = {unitExpr.pexp_loc with loc_ghost = true}; - } ); - ] ); - } - | Pexp_function cases -> - let loc = - match (cases, List.rev cases) with - | first :: _, last :: _ -> - { - first.pc_lhs.ppat_loc with - loc_end = last.pc_rhs.pexp_loc.loc_end; - } - | _ -> Location.none - in - let var = - { - Parsetree.ppat_loc = Location.none; - ppat_attributes = []; - ppat_desc = Ppat_var (Location.mknoloc "x"); - } - in - { - pexp_loc = loc; - pexp_attributes = []; - pexp_desc = - Pexp_fun - ( Asttypes.Nolabel, - None, - var, - { - pexp_loc = loc; - pexp_attributes = []; - pexp_desc = - Pexp_match - ( { - pexp_loc = Location.none; - pexp_attributes = []; - pexp_desc = - Pexp_ident - (Location.mknoloc (Longident.Lident "x")); - }, - mapper.cases mapper cases ); - } ); - } - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "!"}}, - [(Asttypes.Nolabel, operand)] ) -> - (* turn `!foo` into `foo.contents` *) - { - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - pexp_desc = - Pexp_field - ( mapper.expr mapper operand, - Location.mknoloc (Longident.Lident "contents") ); - } - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [ - (Asttypes.Nolabel, lhs); - ( Nolabel, - { - pexp_desc = - ( Pexp_constant (Pconst_string (txt, None)) - | Pexp_ident {txt = Longident.Lident txt} ); - pexp_loc = labelLoc; - } ); - ] ) -> - let label = Location.mkloc txt labelLoc in - { - pexp_loc = expr.pexp_loc; - pexp_attributes = expr.pexp_attributes; - pexp_desc = Pexp_send (mapper.expr mapper lhs, label); - } - | Pexp_match - ( condition, - [ - { - pc_lhs = - { - ppat_desc = - Ppat_construct ({txt = Longident.Lident "true"}, None); - }; - pc_rhs = thenExpr; - }; - { - pc_lhs = - { - ppat_desc = - Ppat_construct ({txt = Longident.Lident "false"}, None); - }; - pc_rhs = elseExpr; - }; - ] ) -> - let ternaryMarker = - (Location.mknoloc "res.ternary", Parsetree.PStr []) - in - { - Parsetree.pexp_loc = expr.pexp_loc; - pexp_desc = - Pexp_ifthenelse - ( mapper.expr mapper condition, - mapper.expr mapper thenExpr, - Some (mapper.expr mapper elseExpr) ); - pexp_attributes = ternaryMarker :: expr.pexp_attributes; - } - | _ -> default_mapper.expr mapper expr); - structure_item = - (fun mapper structureItem -> - match structureItem.pstr_desc with - (* heuristic: if we have multiple type declarations, mark them recursive *) - | Pstr_type ((Recursive as recFlag), typeDeclarations) -> - let flag = - match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - { - structureItem with - pstr_desc = - Pstr_type - ( flag, - List.map - (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration) - typeDeclarations ); - } - | _ -> default_mapper.structure_item mapper structureItem); - signature_item = - (fun mapper signatureItem -> - match signatureItem.psig_desc with - (* heuristic: if we have multiple type declarations, mark them recursive *) - | Psig_type ((Recursive as recFlag), typeDeclarations) -> - let flag = - match typeDeclarations with - | [td] -> - if looksLikeRecursiveTypeDeclaration td then Asttypes.Recursive - else Asttypes.Nonrecursive - | _ -> recFlag - in - { - signatureItem with - psig_desc = - Psig_type - ( flag, - List.map - (fun typeDeclaration -> - default_mapper.type_declaration mapper typeDeclaration) - typeDeclarations ); - } - | _ -> default_mapper.signature_item mapper signatureItem); - value_binding = - (fun mapper vb -> - match vb with - | { - pvb_pat = {ppat_desc = Ppat_var _} as pat; - pvb_expr = - {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ)}; - } - when expr_loc.loc_ghost -> - (* let t: t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = - { - Parsetree.ppat_loc = - {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; - ppat_attributes = []; - ppat_desc = Ppat_constraint (pat, typ); - } - in - { - vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; - } - | { - pvb_pat = - {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], _)})}; - pvb_expr = - {pexp_loc = expr_loc; pexp_desc = Pexp_constraint (expr, typ)}; - } - when expr_loc.loc_ghost -> - (* let t: . t = (expr : t) -> let t: t = expr *) - let typ = default_mapper.typ mapper typ in - let pat = default_mapper.pat mapper pat in - let expr = mapper.expr mapper expr in - let newPattern = - { - Parsetree.ppat_loc = - {pat.ppat_loc with loc_end = typ.ptyp_loc.loc_end}; - ppat_attributes = []; - ppat_desc = Ppat_constraint (pat, typ); - } - in - { - vb with - pvb_pat = newPattern; - pvb_expr = expr; - pvb_attributes = default_mapper.attributes mapper vb.pvb_attributes; - } - | _ -> default_mapper.value_binding mapper vb); - } - -let structure s = normalize.Ast_mapper.structure normalize s -let signature s = normalize.Ast_mapper.signature normalize s - -let replaceStringLiteralStructure stringData structure = - let mapper = stringLiteralMapper stringData in - mapper.Ast_mapper.structure mapper structure - -let replaceStringLiteralSignature stringData signature = - let mapper = stringLiteralMapper stringData in - mapper.Ast_mapper.signature mapper signature diff --git a/jscomp/syntax/src/res_ast_conversion.mli b/jscomp/syntax/src/res_ast_conversion.mli deleted file mode 100644 index 32163e8..0000000 --- a/jscomp/syntax/src/res_ast_conversion.mli +++ /dev/null @@ -1,18 +0,0 @@ -(* The purpose of this module is to convert a parsetree coming from the reason - * or ocaml parser, into something consumable by the rescript printer. *) - -(* Ocaml/Reason parser interprets string literals: i.e. escape sequences and unicode. - * For printing purposes you want to preserve the original string. - * Example: "😎" is interpreted as "\240\159\152\142" - * The purpose of this routine is to place the original string back in - * the parsetree for printing purposes. Unicode and escape sequences - * shouldn't be mangled when *) -val replaceStringLiteralStructure : - (string * Location.t) list -> Parsetree.structure -> Parsetree.structure -val replaceStringLiteralSignature : - (string * Location.t) list -> Parsetree.signature -> Parsetree.signature - -(* transform parts of the parsetree into a suitable parsetree suitable - * for printing. Example: convert reason ternaries into rescript ternaries *) -val structure : Parsetree.structure -> Parsetree.structure -val signature : Parsetree.signature -> Parsetree.signature diff --git a/jscomp/syntax/src/res_ast_debugger.ml b/jscomp/syntax/src/res_ast_debugger.ml deleted file mode 100644 index 150ff78..0000000 --- a/jscomp/syntax/src/res_ast_debugger.ml +++ /dev/null @@ -1,949 +0,0 @@ -module Doc = Res_doc -module CommentTable = Res_comments_table - -let printEngine = - Res_driver. - { - printImplementation = - (fun ~width:_ ~filename:_ ~comments:_ structure -> - Printast.implementation Format.std_formatter structure); - printInterface = - (fun ~width:_ ~filename:_ ~comments:_ signature -> - Printast.interface Format.std_formatter signature); - } - -module Sexp : sig - type t - - val atom : string -> t - val list : t list -> t - val toString : t -> string -end = struct - type t = Atom of string | List of t list - - let atom s = Atom s - let list l = List l - - let rec toDoc t = - match t with - | Atom s -> Doc.text s - | List [] -> Doc.text "()" - | List [sexpr] -> Doc.concat [Doc.lparen; toDoc sexpr; Doc.rparen] - | List (hd :: tail) -> - Doc.group - (Doc.concat - [ - Doc.lparen; - toDoc hd; - Doc.indent - (Doc.concat - [Doc.line; Doc.join ~sep:Doc.line (List.map toDoc tail)]); - Doc.rparen; - ]) - - let toString sexpr = - let doc = toDoc sexpr in - Doc.toString ~width:80 doc -end - -module SexpAst = struct - open Parsetree - - let mapEmpty ~f items = - match items with - | [] -> [Sexp.list []] - | items -> List.map f items - - let string txt = Sexp.atom ("\"" ^ txt ^ "\"") - - let char c = Sexp.atom ("'" ^ Char.escaped c ^ "'") - - let optChar oc = - match oc with - | None -> Sexp.atom "None" - | Some c -> Sexp.list [Sexp.atom "Some"; char c] - - let longident l = - let rec loop l = - match l with - | Longident.Lident ident -> Sexp.list [Sexp.atom "Lident"; string ident] - | Longident.Ldot (lident, txt) -> - Sexp.list [Sexp.atom "Ldot"; loop lident; string txt] - | Longident.Lapply (l1, l2) -> - Sexp.list [Sexp.atom "Lapply"; loop l1; loop l2] - in - Sexp.list [Sexp.atom "longident"; loop l] - - let closedFlag flag = - match flag with - | Asttypes.Closed -> Sexp.atom "Closed" - | Open -> Sexp.atom "Open" - - let directionFlag flag = - match flag with - | Asttypes.Upto -> Sexp.atom "Upto" - | Downto -> Sexp.atom "Downto" - - let recFlag flag = - match flag with - | Asttypes.Recursive -> Sexp.atom "Recursive" - | Nonrecursive -> Sexp.atom "Nonrecursive" - - let overrideFlag flag = - match flag with - | Asttypes.Override -> Sexp.atom "Override" - | Fresh -> Sexp.atom "Fresh" - - let privateFlag flag = - match flag with - | Asttypes.Public -> Sexp.atom "Public" - | Private -> Sexp.atom "Private" - - let mutableFlag flag = - match flag with - | Asttypes.Immutable -> Sexp.atom "Immutable" - | Mutable -> Sexp.atom "Mutable" - - let variance v = - match v with - | Asttypes.Covariant -> Sexp.atom "Covariant" - | Contravariant -> Sexp.atom "Contravariant" - | Invariant -> Sexp.atom "Invariant" - - let argLabel lbl = - match lbl with - | Asttypes.Nolabel -> Sexp.atom "Nolabel" - | Labelled txt -> Sexp.list [Sexp.atom "Labelled"; string txt] - | Optional txt -> Sexp.list [Sexp.atom "Optional"; string txt] - - let constant c = - let sexpr = - match c with - | Pconst_integer (txt, tag) -> - Sexp.list [Sexp.atom "Pconst_integer"; string txt; optChar tag] - | Pconst_char _ -> Sexp.list [Sexp.atom "Pconst_char"] - | Pconst_string (_, Some "INTERNAL_RES_CHAR_CONTENTS") -> - Sexp.list [Sexp.atom "Pconst_char"] - | Pconst_string (txt, tag) -> - Sexp.list - [ - Sexp.atom "Pconst_string"; - string txt; - (match tag with - | Some txt -> Sexp.list [Sexp.atom "Some"; string txt] - | None -> Sexp.atom "None"); - ] - | Pconst_float (txt, tag) -> - Sexp.list [Sexp.atom "Pconst_float"; string txt; optChar tag] - in - Sexp.list [Sexp.atom "constant"; sexpr] - - let rec structure s = - Sexp.list (Sexp.atom "structure" :: List.map structureItem s) - - and structureItem si = - let desc = - match si.pstr_desc with - | Pstr_eval (expr, attrs) -> - Sexp.list [Sexp.atom "Pstr_eval"; expression expr; attributes attrs] - | Pstr_value (flag, vbs) -> - Sexp.list - [ - Sexp.atom "Pstr_value"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs); - ] - | Pstr_primitive vd -> - Sexp.list [Sexp.atom "Pstr_primitive"; valueDescription vd] - | Pstr_type (flag, tds) -> - Sexp.list - [ - Sexp.atom "Pstr_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration tds); - ] - | Pstr_typext typext -> - Sexp.list [Sexp.atom "Pstr_type"; typeExtension typext] - | Pstr_exception ec -> - Sexp.list [Sexp.atom "Pstr_exception"; extensionConstructor ec] - | Pstr_module mb -> Sexp.list [Sexp.atom "Pstr_module"; moduleBinding mb] - | Pstr_recmodule mbs -> - Sexp.list - [ - Sexp.atom "Pstr_recmodule"; Sexp.list (mapEmpty ~f:moduleBinding mbs); - ] - | Pstr_modtype modTypDecl -> - Sexp.list [Sexp.atom "Pstr_modtype"; moduleTypeDeclaration modTypDecl] - | Pstr_open openDesc -> - Sexp.list [Sexp.atom "Pstr_open"; openDescription openDesc] - | Pstr_class _ -> Sexp.atom "Pstr_class" - | Pstr_class_type _ -> Sexp.atom "Pstr_class_type" - | Pstr_include id -> - Sexp.list [Sexp.atom "Pstr_include"; includeDeclaration id] - | Pstr_attribute attr -> - Sexp.list [Sexp.atom "Pstr_attribute"; attribute attr] - | Pstr_extension (ext, attrs) -> - Sexp.list [Sexp.atom "Pstr_extension"; extension ext; attributes attrs] - in - Sexp.list [Sexp.atom "structure_item"; desc] - - and includeDeclaration id = - Sexp.list - [ - Sexp.atom "include_declaration"; - moduleExpression id.pincl_mod; - attributes id.pincl_attributes; - ] - - and openDescription od = - Sexp.list - [ - Sexp.atom "open_description"; - longident od.popen_lid.Asttypes.txt; - attributes od.popen_attributes; - ] - - and moduleTypeDeclaration mtd = - Sexp.list - [ - Sexp.atom "module_type_declaration"; - string mtd.pmtd_name.Asttypes.txt; - (match mtd.pmtd_type with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); - attributes mtd.pmtd_attributes; - ] - - and moduleBinding mb = - Sexp.list - [ - Sexp.atom "module_binding"; - string mb.pmb_name.Asttypes.txt; - moduleExpression mb.pmb_expr; - attributes mb.pmb_attributes; - ] - - and moduleExpression me = - let desc = - match me.pmod_desc with - | Pmod_ident modName -> - Sexp.list [Sexp.atom "Pmod_ident"; longident modName.Asttypes.txt] - | Pmod_structure s -> Sexp.list [Sexp.atom "Pmod_structure"; structure s] - | Pmod_functor (lbl, optModType, modExpr) -> - Sexp.list - [ - Sexp.atom "Pmod_functor"; - string lbl.Asttypes.txt; - (match optModType with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); - moduleExpression modExpr; - ] - | Pmod_apply (callModExpr, modExprArg) -> - Sexp.list - [ - Sexp.atom "Pmod_apply"; - moduleExpression callModExpr; - moduleExpression modExprArg; - ] - | Pmod_constraint (modExpr, modType) -> - Sexp.list - [ - Sexp.atom "Pmod_constraint"; - moduleExpression modExpr; - moduleType modType; - ] - | Pmod_unpack expr -> Sexp.list [Sexp.atom "Pmod_unpack"; expression expr] - | Pmod_extension ext -> - Sexp.list [Sexp.atom "Pmod_extension"; extension ext] - in - Sexp.list [Sexp.atom "module_expr"; desc; attributes me.pmod_attributes] - - and moduleType mt = - let desc = - match mt.pmty_desc with - | Pmty_ident longidentLoc -> - Sexp.list [Sexp.atom "Pmty_ident"; longident longidentLoc.Asttypes.txt] - | Pmty_signature s -> Sexp.list [Sexp.atom "Pmty_signature"; signature s] - | Pmty_functor (lbl, optModType, modType) -> - Sexp.list - [ - Sexp.atom "Pmty_functor"; - string lbl.Asttypes.txt; - (match optModType with - | None -> Sexp.atom "None" - | Some modType -> Sexp.list [Sexp.atom "Some"; moduleType modType]); - moduleType modType; - ] - | Pmty_alias longidentLoc -> - Sexp.list [Sexp.atom "Pmty_alias"; longident longidentLoc.Asttypes.txt] - | Pmty_extension ext -> - Sexp.list [Sexp.atom "Pmty_extension"; extension ext] - | Pmty_typeof modExpr -> - Sexp.list [Sexp.atom "Pmty_typeof"; moduleExpression modExpr] - | Pmty_with (modType, withConstraints) -> - Sexp.list - [ - Sexp.atom "Pmty_with"; - moduleType modType; - Sexp.list (mapEmpty ~f:withConstraint withConstraints); - ] - in - Sexp.list [Sexp.atom "module_type"; desc; attributes mt.pmty_attributes] - - and withConstraint wc = - match wc with - | Pwith_type (longidentLoc, td) -> - Sexp.list - [ - Sexp.atom "Pmty_with"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; - ] - | Pwith_module (l1, l2) -> - Sexp.list - [ - Sexp.atom "Pwith_module"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] - | Pwith_typesubst (longidentLoc, td) -> - Sexp.list - [ - Sexp.atom "Pwith_typesubst"; - longident longidentLoc.Asttypes.txt; - typeDeclaration td; - ] - | Pwith_modsubst (l1, l2) -> - Sexp.list - [ - Sexp.atom "Pwith_modsubst"; - longident l1.Asttypes.txt; - longident l2.Asttypes.txt; - ] - - and signature s = Sexp.list (Sexp.atom "signature" :: List.map signatureItem s) - - and signatureItem si = - let descr = - match si.psig_desc with - | Psig_value vd -> Sexp.list [Sexp.atom "Psig_value"; valueDescription vd] - | Psig_type (flag, typeDeclarations) -> - Sexp.list - [ - Sexp.atom "Psig_type"; - recFlag flag; - Sexp.list (mapEmpty ~f:typeDeclaration typeDeclarations); - ] - | Psig_typext typExt -> - Sexp.list [Sexp.atom "Psig_typext"; typeExtension typExt] - | Psig_exception extConstr -> - Sexp.list [Sexp.atom "Psig_exception"; extensionConstructor extConstr] - | Psig_module modDecl -> - Sexp.list [Sexp.atom "Psig_module"; moduleDeclaration modDecl] - | Psig_recmodule modDecls -> - Sexp.list - [ - Sexp.atom "Psig_recmodule"; - Sexp.list (mapEmpty ~f:moduleDeclaration modDecls); - ] - | Psig_modtype modTypDecl -> - Sexp.list [Sexp.atom "Psig_modtype"; moduleTypeDeclaration modTypDecl] - | Psig_open openDesc -> - Sexp.list [Sexp.atom "Psig_open"; openDescription openDesc] - | Psig_include inclDecl -> - Sexp.list [Sexp.atom "Psig_include"; includeDescription inclDecl] - | Psig_class _ -> Sexp.list [Sexp.atom "Psig_class"] - | Psig_class_type _ -> Sexp.list [Sexp.atom "Psig_class_type"] - | Psig_attribute attr -> - Sexp.list [Sexp.atom "Psig_attribute"; attribute attr] - | Psig_extension (ext, attrs) -> - Sexp.list [Sexp.atom "Psig_extension"; extension ext; attributes attrs] - in - Sexp.list [Sexp.atom "signature_item"; descr] - - and includeDescription id = - Sexp.list - [ - Sexp.atom "include_description"; - moduleType id.pincl_mod; - attributes id.pincl_attributes; - ] - - and moduleDeclaration md = - Sexp.list - [ - Sexp.atom "module_declaration"; - string md.pmd_name.Asttypes.txt; - moduleType md.pmd_type; - attributes md.pmd_attributes; - ] - - and valueBinding vb = - Sexp.list - [ - Sexp.atom "value_binding"; - pattern vb.pvb_pat; - expression vb.pvb_expr; - attributes vb.pvb_attributes; - ] - - and valueDescription vd = - Sexp.list - [ - Sexp.atom "value_description"; - string vd.pval_name.Asttypes.txt; - coreType vd.pval_type; - Sexp.list (mapEmpty ~f:string vd.pval_prim); - attributes vd.pval_attributes; - ] - - and typeDeclaration td = - Sexp.list - [ - Sexp.atom "type_declaration"; - string td.ptype_name.Asttypes.txt; - Sexp.list - [ - Sexp.atom "ptype_params"; - Sexp.list - (mapEmpty - ~f:(fun (typexpr, var) -> - Sexp.list [coreType typexpr; variance var]) - td.ptype_params); - ]; - Sexp.list - [ - Sexp.atom "ptype_cstrs"; - Sexp.list - (mapEmpty - ~f:(fun (typ1, typ2, _loc) -> - Sexp.list [coreType typ1; coreType typ2]) - td.ptype_cstrs); - ]; - Sexp.list [Sexp.atom "ptype_kind"; typeKind td.ptype_kind]; - Sexp.list - [ - Sexp.atom "ptype_manifest"; - (match td.ptype_manifest with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); - ]; - Sexp.list [Sexp.atom "ptype_private"; privateFlag td.ptype_private]; - attributes td.ptype_attributes; - ] - - and extensionConstructor ec = - Sexp.list - [ - Sexp.atom "extension_constructor"; - string ec.pext_name.Asttypes.txt; - extensionConstructorKind ec.pext_kind; - attributes ec.pext_attributes; - ] - - and extensionConstructorKind kind = - match kind with - | Pext_decl (args, optTypExpr) -> - Sexp.list - [ - Sexp.atom "Pext_decl"; - constructorArguments args; - (match optTypExpr with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); - ] - | Pext_rebind longidentLoc -> - Sexp.list [Sexp.atom "Pext_rebind"; longident longidentLoc.Asttypes.txt] - - and typeExtension te = - Sexp.list - [ - Sexp.atom "type_extension"; - Sexp.list - [Sexp.atom "ptyext_path"; longident te.ptyext_path.Asttypes.txt]; - Sexp.list - [ - Sexp.atom "ptyext_parms"; - Sexp.list - (mapEmpty - ~f:(fun (typexpr, var) -> - Sexp.list [coreType typexpr; variance var]) - te.ptyext_params); - ]; - Sexp.list - [ - Sexp.atom "ptyext_constructors"; - Sexp.list (mapEmpty ~f:extensionConstructor te.ptyext_constructors); - ]; - Sexp.list [Sexp.atom "ptyext_private"; privateFlag te.ptyext_private]; - attributes te.ptyext_attributes; - ] - - and typeKind kind = - match kind with - | Ptype_abstract -> Sexp.atom "Ptype_abstract" - | Ptype_variant constrDecls -> - Sexp.list - [ - Sexp.atom "Ptype_variant"; - Sexp.list (mapEmpty ~f:constructorDeclaration constrDecls); - ] - | Ptype_record lblDecls -> - Sexp.list - [ - Sexp.atom "Ptype_record"; - Sexp.list (mapEmpty ~f:labelDeclaration lblDecls); - ] - | Ptype_open -> Sexp.atom "Ptype_open" - - and constructorDeclaration cd = - Sexp.list - [ - Sexp.atom "constructor_declaration"; - string cd.pcd_name.Asttypes.txt; - Sexp.list [Sexp.atom "pcd_args"; constructorArguments cd.pcd_args]; - Sexp.list - [ - Sexp.atom "pcd_res"; - (match cd.pcd_res with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); - ]; - attributes cd.pcd_attributes; - ] - - and constructorArguments args = - match args with - | Pcstr_tuple types -> - Sexp.list - [Sexp.atom "Pcstr_tuple"; Sexp.list (mapEmpty ~f:coreType types)] - | Pcstr_record lds -> - Sexp.list - [Sexp.atom "Pcstr_record"; Sexp.list (mapEmpty ~f:labelDeclaration lds)] - - and labelDeclaration ld = - Sexp.list - [ - Sexp.atom "label_declaration"; - string ld.pld_name.Asttypes.txt; - mutableFlag ld.pld_mutable; - coreType ld.pld_type; - attributes ld.pld_attributes; - ] - - and expression expr = - let desc = - match expr.pexp_desc with - | Pexp_ident longidentLoc -> - Sexp.list [Sexp.atom "Pexp_ident"; longident longidentLoc.Asttypes.txt] - | Pexp_constant c -> Sexp.list [Sexp.atom "Pexp_constant"; constant c] - | Pexp_let (flag, vbs, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_let"; - recFlag flag; - Sexp.list (mapEmpty ~f:valueBinding vbs); - expression expr; - ] - | Pexp_function cases -> - Sexp.list - [Sexp.atom "Pexp_function"; Sexp.list (mapEmpty ~f:case cases)] - | Pexp_fun (argLbl, exprOpt, pat, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_fun"; - argLabel argLbl; - (match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - pattern pat; - expression expr; - ] - | Pexp_apply (expr, args) -> - Sexp.list - [ - Sexp.atom "Pexp_apply"; - expression expr; - Sexp.list - (mapEmpty - ~f:(fun (argLbl, expr) -> - Sexp.list [argLabel argLbl; expression expr]) - args); - ] - | Pexp_match (expr, cases) -> - Sexp.list - [ - Sexp.atom "Pexp_match"; - expression expr; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_try (expr, cases) -> - Sexp.list - [ - Sexp.atom "Pexp_try"; - expression expr; - Sexp.list (mapEmpty ~f:case cases); - ] - | Pexp_tuple exprs -> - Sexp.list - [Sexp.atom "Pexp_tuple"; Sexp.list (mapEmpty ~f:expression exprs)] - | Pexp_construct (longidentLoc, exprOpt) -> - Sexp.list - [ - Sexp.atom "Pexp_construct"; - longident longidentLoc.Asttypes.txt; - (match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ] - | Pexp_variant (lbl, exprOpt) -> - Sexp.list - [ - Sexp.atom "Pexp_variant"; - string lbl; - (match exprOpt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ] - | Pexp_record (rows, optExpr) -> - Sexp.list - [ - Sexp.atom "Pexp_record"; - Sexp.list - (mapEmpty - ~f:(fun (longidentLoc, expr) -> - Sexp.list - [longident longidentLoc.Asttypes.txt; expression expr]) - rows); - (match optExpr with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ] - | Pexp_field (expr, longidentLoc) -> - Sexp.list - [ - Sexp.atom "Pexp_field"; - expression expr; - longident longidentLoc.Asttypes.txt; - ] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - Sexp.list - [ - Sexp.atom "Pexp_setfield"; - expression expr1; - longident longidentLoc.Asttypes.txt; - expression expr2; - ] - | Pexp_array exprs -> - Sexp.list - [Sexp.atom "Pexp_array"; Sexp.list (mapEmpty ~f:expression exprs)] - | Pexp_ifthenelse (expr1, expr2, optExpr) -> - Sexp.list - [ - Sexp.atom "Pexp_ifthenelse"; - expression expr1; - expression expr2; - (match optExpr with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ] - | Pexp_sequence (expr1, expr2) -> - Sexp.list - [Sexp.atom "Pexp_sequence"; expression expr1; expression expr2] - | Pexp_while (expr1, expr2) -> - Sexp.list [Sexp.atom "Pexp_while"; expression expr1; expression expr2] - | Pexp_for (pat, e1, e2, flag, e3) -> - Sexp.list - [ - Sexp.atom "Pexp_for"; - pattern pat; - expression e1; - expression e2; - directionFlag flag; - expression e3; - ] - | Pexp_constraint (expr, typexpr) -> - Sexp.list - [Sexp.atom "Pexp_constraint"; expression expr; coreType typexpr] - | Pexp_coerce (expr, optTyp, typexpr) -> - Sexp.list - [ - Sexp.atom "Pexp_coerce"; - expression expr; - (match optTyp with - | None -> Sexp.atom "None" - | Some typ -> Sexp.list [Sexp.atom "Some"; coreType typ]); - coreType typexpr; - ] - | Pexp_send _ -> Sexp.list [Sexp.atom "Pexp_send"] - | Pexp_new _ -> Sexp.list [Sexp.atom "Pexp_new"] - | Pexp_setinstvar _ -> Sexp.list [Sexp.atom "Pexp_setinstvar"] - | Pexp_override _ -> Sexp.list [Sexp.atom "Pexp_override"] - | Pexp_letmodule (modName, modExpr, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_letmodule"; - string modName.Asttypes.txt; - moduleExpression modExpr; - expression expr; - ] - | Pexp_letexception (extConstr, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_letexception"; - extensionConstructor extConstr; - expression expr; - ] - | Pexp_assert expr -> Sexp.list [Sexp.atom "Pexp_assert"; expression expr] - | Pexp_lazy expr -> Sexp.list [Sexp.atom "Pexp_lazy"; expression expr] - | Pexp_poly _ -> Sexp.list [Sexp.atom "Pexp_poly"] - | Pexp_object _ -> Sexp.list [Sexp.atom "Pexp_object"] - | Pexp_newtype (lbl, expr) -> - Sexp.list - [Sexp.atom "Pexp_newtype"; string lbl.Asttypes.txt; expression expr] - | Pexp_pack modExpr -> - Sexp.list [Sexp.atom "Pexp_pack"; moduleExpression modExpr] - | Pexp_open (flag, longidentLoc, expr) -> - Sexp.list - [ - Sexp.atom "Pexp_open"; - overrideFlag flag; - longident longidentLoc.Asttypes.txt; - expression expr; - ] - | Pexp_extension ext -> - Sexp.list [Sexp.atom "Pexp_extension"; extension ext] - | Pexp_unreachable -> Sexp.atom "Pexp_unreachable" - in - Sexp.list [Sexp.atom "expression"; desc] - - and case c = - Sexp.list - [ - Sexp.atom "case"; - Sexp.list [Sexp.atom "pc_lhs"; pattern c.pc_lhs]; - Sexp.list - [ - Sexp.atom "pc_guard"; - (match c.pc_guard with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - ]; - Sexp.list [Sexp.atom "pc_rhs"; expression c.pc_rhs]; - ] - - and pattern p = - let descr = - match p.ppat_desc with - | Ppat_any -> Sexp.atom "Ppat_any" - | Ppat_var var -> - Sexp.list [Sexp.atom "Ppat_var"; string var.Location.txt] - | Ppat_alias (p, alias) -> - Sexp.list [Sexp.atom "Ppat_alias"; pattern p; string alias.txt] - | Ppat_constant c -> Sexp.list [Sexp.atom "Ppat_constant"; constant c] - | Ppat_interval (lo, hi) -> - Sexp.list [Sexp.atom "Ppat_interval"; constant lo; constant hi] - | Ppat_tuple patterns -> - Sexp.list - [Sexp.atom "Ppat_tuple"; Sexp.list (mapEmpty ~f:pattern patterns)] - | Ppat_construct (longidentLoc, optPattern) -> - Sexp.list - [ - Sexp.atom "Ppat_construct"; - longident longidentLoc.Location.txt; - (match optPattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [Sexp.atom "some"; pattern p]); - ] - | Ppat_variant (lbl, optPattern) -> - Sexp.list - [ - Sexp.atom "Ppat_variant"; - string lbl; - (match optPattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [Sexp.atom "Some"; pattern p]); - ] - | Ppat_record (rows, flag) -> - Sexp.list - [ - Sexp.atom "Ppat_record"; - closedFlag flag; - Sexp.list - (mapEmpty - ~f:(fun (longidentLoc, p) -> - Sexp.list [longident longidentLoc.Location.txt; pattern p]) - rows); - ] - | Ppat_array patterns -> - Sexp.list - [Sexp.atom "Ppat_array"; Sexp.list (mapEmpty ~f:pattern patterns)] - | Ppat_or (p1, p2) -> - Sexp.list [Sexp.atom "Ppat_or"; pattern p1; pattern p2] - | Ppat_constraint (p, typexpr) -> - Sexp.list [Sexp.atom "Ppat_constraint"; pattern p; coreType typexpr] - | Ppat_type longidentLoc -> - Sexp.list [Sexp.atom "Ppat_type"; longident longidentLoc.Location.txt] - | Ppat_lazy p -> Sexp.list [Sexp.atom "Ppat_lazy"; pattern p] - | Ppat_unpack stringLoc -> - Sexp.list [Sexp.atom "Ppat_unpack"; string stringLoc.Location.txt] - | Ppat_exception p -> Sexp.list [Sexp.atom "Ppat_exception"; pattern p] - | Ppat_extension ext -> - Sexp.list [Sexp.atom "Ppat_extension"; extension ext] - | Ppat_open (longidentLoc, p) -> - Sexp.list - [ - Sexp.atom "Ppat_open"; longident longidentLoc.Location.txt; pattern p; - ] - in - Sexp.list [Sexp.atom "pattern"; descr] - - and objectField field = - match field with - | Otag (lblLoc, attrs, typexpr) -> - Sexp.list - [ - Sexp.atom "Otag"; string lblLoc.txt; attributes attrs; coreType typexpr; - ] - | Oinherit typexpr -> Sexp.list [Sexp.atom "Oinherit"; coreType typexpr] - - and rowField field = - match field with - | Rtag (labelLoc, attrs, truth, types) -> - Sexp.list - [ - Sexp.atom "Rtag"; - string labelLoc.txt; - attributes attrs; - Sexp.atom (if truth then "true" else "false"); - Sexp.list (mapEmpty ~f:coreType types); - ] - | Rinherit typexpr -> Sexp.list [Sexp.atom "Rinherit"; coreType typexpr] - - and packageType (modNameLoc, packageConstraints) = - Sexp.list - [ - Sexp.atom "package_type"; - longident modNameLoc.Asttypes.txt; - Sexp.list - (mapEmpty - ~f:(fun (modNameLoc, typexpr) -> - Sexp.list [longident modNameLoc.Asttypes.txt; coreType typexpr]) - packageConstraints); - ] - - and coreType typexpr = - let desc = - match typexpr.ptyp_desc with - | Ptyp_any -> Sexp.atom "Ptyp_any" - | Ptyp_var var -> Sexp.list [Sexp.atom "Ptyp_var"; string var] - | Ptyp_arrow (argLbl, typ1, typ2) -> - Sexp.list - [ - Sexp.atom "Ptyp_arrow"; argLabel argLbl; coreType typ1; coreType typ2; - ] - | Ptyp_tuple types -> - Sexp.list - [Sexp.atom "Ptyp_tuple"; Sexp.list (mapEmpty ~f:coreType types)] - | Ptyp_constr (longidentLoc, types) -> - Sexp.list - [ - Sexp.atom "Ptyp_constr"; - longident longidentLoc.txt; - Sexp.list (mapEmpty ~f:coreType types); - ] - | Ptyp_alias (typexpr, alias) -> - Sexp.list [Sexp.atom "Ptyp_alias"; coreType typexpr; string alias] - | Ptyp_object (fields, flag) -> - Sexp.list - [ - Sexp.atom "Ptyp_object"; - closedFlag flag; - Sexp.list (mapEmpty ~f:objectField fields); - ] - | Ptyp_class (longidentLoc, types) -> - Sexp.list - [ - Sexp.atom "Ptyp_class"; - longident longidentLoc.Location.txt; - Sexp.list (mapEmpty ~f:coreType types); - ] - | Ptyp_variant (fields, flag, optLabels) -> - Sexp.list - [ - Sexp.atom "Ptyp_variant"; - Sexp.list (mapEmpty ~f:rowField fields); - closedFlag flag; - (match optLabels with - | None -> Sexp.atom "None" - | Some lbls -> Sexp.list (mapEmpty ~f:string lbls)); - ] - | Ptyp_poly (lbls, typexpr) -> - Sexp.list - [ - Sexp.atom "Ptyp_poly"; - Sexp.list (mapEmpty ~f:(fun lbl -> string lbl.Asttypes.txt) lbls); - coreType typexpr; - ] - | Ptyp_package package -> - Sexp.list [Sexp.atom "Ptyp_package"; packageType package] - | Ptyp_extension ext -> - Sexp.list [Sexp.atom "Ptyp_extension"; extension ext] - in - Sexp.list [Sexp.atom "core_type"; desc] - - and payload p = - match p with - | PStr s -> Sexp.list (Sexp.atom "PStr" :: mapEmpty ~f:structureItem s) - | PSig s -> Sexp.list [Sexp.atom "PSig"; signature s] - | PTyp ct -> Sexp.list [Sexp.atom "PTyp"; coreType ct] - | PPat (pat, optExpr) -> - Sexp.list - [ - Sexp.atom "PPat"; - pattern pat; - (match optExpr with - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr] - | None -> Sexp.atom "None"); - ] - - and attribute (stringLoc, p) = - Sexp.list - [Sexp.atom "attribute"; Sexp.atom stringLoc.Asttypes.txt; payload p] - - and extension (stringLoc, p) = - Sexp.list - [Sexp.atom "extension"; Sexp.atom stringLoc.Asttypes.txt; payload p] - - and attributes attrs = - let sexprs = mapEmpty ~f:attribute attrs in - Sexp.list (Sexp.atom "attributes" :: sexprs) - - let printEngine = - Res_driver. - { - printImplementation = - (fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> structure |> Sexp.toString |> print_string); - printInterface = - (fun ~width:_ ~filename:_ ~comments:_ parsetree -> - parsetree |> signature |> Sexp.toString |> print_string); - } -end - -let sexpPrintEngine = SexpAst.printEngine - -let commentsPrintEngine = - { - Res_driver.printImplementation = - (fun ~width:_ ~filename:_ ~comments s -> - let cmtTbl = CommentTable.make () in - CommentTable.walkStructure s cmtTbl comments; - CommentTable.log cmtTbl); - printInterface = - (fun ~width:_ ~filename:_ ~comments s -> - let cmtTbl = CommentTable.make () in - CommentTable.walkSignature s cmtTbl comments; - CommentTable.log cmtTbl); - } diff --git a/jscomp/syntax/src/res_ast_debugger.mli b/jscomp/syntax/src/res_ast_debugger.mli deleted file mode 100644 index 1b325b7..0000000 --- a/jscomp/syntax/src/res_ast_debugger.mli +++ /dev/null @@ -1,3 +0,0 @@ -val printEngine : Res_driver.printEngine -val sexpPrintEngine : Res_driver.printEngine -val commentsPrintEngine : Res_driver.printEngine diff --git a/jscomp/syntax/src/res_comment.ml b/jscomp/syntax/src/res_comment.ml deleted file mode 100644 index 579b5d3..0000000 --- a/jscomp/syntax/src/res_comment.ml +++ /dev/null @@ -1,67 +0,0 @@ -type style = SingleLine | MultiLine | DocComment | ModuleComment - -let styleToString s = - match s with - | SingleLine -> "SingleLine" - | MultiLine -> "MultiLine" - | DocComment -> "DocComment" - | ModuleComment -> "ModuleComment" - -type t = { - txt: string; - style: style; - loc: Location.t; - mutable prevTokEndPos: Lexing.position; -} - -let loc t = t.loc -let txt t = t.txt -let prevTokEndPos t = t.prevTokEndPos - -let setPrevTokEndPos t pos = t.prevTokEndPos <- pos - -let isSingleLineComment t = t.style = SingleLine - -let isDocComment t = t.style = DocComment - -let isModuleComment t = t.style = ModuleComment - -let toString t = - let {Location.loc_start; loc_end} = t.loc in - Format.sprintf "(txt: %s\nstyle: %s\nlocation: %d,%d-%d,%d)" t.txt - (styleToString t.style) loc_start.pos_lnum - (loc_start.pos_cnum - loc_start.pos_bol) - loc_end.pos_lnum - (loc_end.pos_cnum - loc_end.pos_bol) - -let makeSingleLineComment ~loc txt = - {txt; loc; style = SingleLine; prevTokEndPos = Lexing.dummy_pos} - -let makeMultiLineComment ~loc ~docComment ~standalone txt = - { - txt; - loc; - style = - (if docComment then if standalone then ModuleComment else DocComment - else MultiLine); - prevTokEndPos = Lexing.dummy_pos; - } - -let fromOcamlComment ~loc ~txt ~prevTokEndPos = - {txt; loc; style = MultiLine; prevTokEndPos} - -let trimSpaces s = - let len = String.length s in - if len = 0 then s - else if String.unsafe_get s 0 = ' ' || String.unsafe_get s (len - 1) = ' ' - then ( - let i = ref 0 in - while !i < len && String.unsafe_get s !i = ' ' do - incr i - done; - let j = ref (len - 1) in - while !j >= !i && String.unsafe_get s !j = ' ' do - decr j - done; - if !j >= !i then (String.sub [@doesNotRaise]) s !i (!j - !i + 1) else "") - else s diff --git a/jscomp/syntax/src/res_comment.mli b/jscomp/syntax/src/res_comment.mli deleted file mode 100644 index f1d5424..0000000 --- a/jscomp/syntax/src/res_comment.mli +++ /dev/null @@ -1,22 +0,0 @@ -type t - -val toString : t -> string - -val loc : t -> Location.t -val txt : t -> string -val prevTokEndPos : t -> Lexing.position - -val setPrevTokEndPos : t -> Lexing.position -> unit - -val isDocComment : t -> bool - -val isModuleComment : t -> bool - -val isSingleLineComment : t -> bool - -val makeSingleLineComment : loc:Location.t -> string -> t -val makeMultiLineComment : - loc:Location.t -> docComment:bool -> standalone:bool -> string -> t -val fromOcamlComment : - loc:Location.t -> txt:string -> prevTokEndPos:Lexing.position -> t -val trimSpaces : string -> string diff --git a/jscomp/syntax/src/res_comments_table.ml b/jscomp/syntax/src/res_comments_table.ml deleted file mode 100644 index b23e65c..0000000 --- a/jscomp/syntax/src/res_comments_table.ml +++ /dev/null @@ -1,1913 +0,0 @@ -module Comment = Res_comment -module Doc = Res_doc -module ParsetreeViewer = Res_parsetree_viewer - -type t = { - leading: (Location.t, Comment.t list) Hashtbl.t; - inside: (Location.t, Comment.t list) Hashtbl.t; - trailing: (Location.t, Comment.t list) Hashtbl.t; -} - -let make () = - { - leading = Hashtbl.create 100; - inside = Hashtbl.create 100; - trailing = Hashtbl.create 100; - } - -let copy tbl = - { - leading = Hashtbl.copy tbl.leading; - inside = Hashtbl.copy tbl.inside; - trailing = Hashtbl.copy tbl.trailing; - } - -let empty = make () - -let printEntries tbl = - let open Location in - Hashtbl.fold - (fun (k : Location.t) (v : Comment.t list) acc -> - let loc = - Doc.concat - [ - Doc.lbracket; - Doc.text (string_of_int k.loc_start.pos_lnum); - Doc.text ":"; - Doc.text - (string_of_int (k.loc_start.pos_cnum - k.loc_start.pos_bol)); - Doc.text "-"; - Doc.text (string_of_int k.loc_end.pos_lnum); - Doc.text ":"; - Doc.text (string_of_int (k.loc_end.pos_cnum - k.loc_end.pos_bol)); - Doc.rbracket; - ] - in - let doc = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - loc; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun c -> Doc.text (Comment.txt c)) v); - ]); - Doc.line; - ]) - in - doc :: acc) - tbl [] - -let log t = - let leadingStuff = printEntries t.leading in - let trailingStuff = printEntries t.trailing in - let stuffInside = printEntries t.inside in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "leading comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat leadingStuff]); - Doc.line; - Doc.text "comments inside:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat stuffInside]); - Doc.line; - Doc.text "trailing comments:"; - Doc.indent (Doc.concat [Doc.line; Doc.concat trailingStuff]); - Doc.line; - ]) - |> Doc.toString ~width:80 |> print_endline - -let attach tbl loc comments = - match comments with - | [] -> () - | comments -> Hashtbl.replace tbl loc comments - -let partitionByLoc comments loc = - let rec loop (leading, inside, trailing) comments = - let open Location in - match comments with - | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, inside, trailing) rest - else if cmtLoc.loc_start.pos_cnum >= loc.loc_end.pos_cnum then - loop (leading, inside, comment :: trailing) rest - else loop (leading, comment :: inside, trailing) rest - | [] -> (List.rev leading, List.rev inside, List.rev trailing) - in - loop ([], [], []) comments - -let partitionLeadingTrailing comments loc = - let rec loop (leading, trailing) comments = - let open Location in - match comments with - | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_end.pos_cnum <= loc.loc_start.pos_cnum then - loop (comment :: leading, trailing) rest - else loop (leading, comment :: trailing) rest - | [] -> (List.rev leading, List.rev trailing) - in - loop ([], []) comments - -let partitionByOnSameLine loc comments = - let rec loop (onSameLine, onOtherLine) comments = - let open Location in - match comments with - | [] -> (List.rev onSameLine, List.rev onOtherLine) - | comment :: rest -> - let cmtLoc = Comment.loc comment in - if cmtLoc.loc_start.pos_lnum == loc.loc_end.pos_lnum then - loop (comment :: onSameLine, onOtherLine) rest - else loop (onSameLine, comment :: onOtherLine) rest - in - loop ([], []) comments - -let partitionAdjacentTrailing loc1 comments = - let open Location in - let open Lexing in - let rec loop ~prevEndPos afterLoc1 comments = - match comments with - | [] -> (List.rev afterLoc1, []) - | comment :: rest as comments -> - let cmtPrevEndPos = Comment.prevTokEndPos comment in - if prevEndPos.Lexing.pos_cnum == cmtPrevEndPos.pos_cnum then - let commentEnd = (Comment.loc comment).loc_end in - loop ~prevEndPos:commentEnd (comment :: afterLoc1) rest - else (List.rev afterLoc1, comments) - in - loop ~prevEndPos:loc1.loc_end [] comments - -let rec collectListPatterns acc pattern = - let open Parsetree in - match pattern.ppat_desc with - | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectListPatterns (pat :: acc) rest - | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> List.rev acc - | _ -> List.rev (pattern :: acc) - -let rec collectListExprs acc expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [expr; rest]}) - -> - collectListExprs (expr :: acc) rest - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc - | _ -> List.rev (expr :: acc) - -(* TODO: use ParsetreeViewer *) -let arrowType ct = - let open Parsetree in - let rec process attrsBefore acc typ = - match typ with - | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); - ptyp_attributes = []; - } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 - | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); - ptyp_attributes = [({txt = "bs"}, _)] as attrs; - } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) - | { - ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); - ptyp_attributes = attrs; - } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 - | typ -> (attrsBefore, List.rev acc, typ) - in - match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} - | typ -> process [] [] typ - -(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) -let modExprApply modExpr = - let rec loop acc modExpr = - match modExpr with - | {Parsetree.pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next - | _ -> modExpr :: acc - in - loop [] modExpr - -(* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) -let modExprFunctor modExpr = - let rec loop acc modExpr = - match modExpr with - | { - Parsetree.pmod_desc = Pmod_functor (lbl, modType, returnModExpr); - pmod_attributes = attrs; - } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr - | returnModExpr -> (List.rev acc, returnModExpr) - in - loop [] modExpr - -let functorType modtype = - let rec process acc modtype = - match modtype with - | { - Parsetree.pmty_desc = Pmty_functor (lbl, argType, returnType); - pmty_attributes = attrs; - } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType - | modType -> (List.rev acc, modType) - in - process [] modtype - -let funExpr expr = - let open Parsetree in - (* Turns (type t, type u, type z) into "type t u z" *) - let rec collectNewTypes acc returnExpr = - match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} - -> - collectNewTypes (stringLoc :: acc) returnExpr - | returnExpr -> - let loc = - match (acc, List.rev acc) with - | _startLoc :: _, endLoc :: _ -> - {endLoc.loc with loc_end = endLoc.loc.loc_end} - | _ -> Location.none - in - let txt = - List.fold_right - (fun curr acc -> acc ^ " " ^ curr.Location.txt) - acc "type" - in - (Location.mkloc txt loc, returnExpr) - in - (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, - * otherwise this function would need to return a variant: - * | NormalParamater(...) - * | NewType(...) - * This complicates printing with an extra variant/boxing/allocation for a code-path - * that is not often used. Lets just keep it simple for now *) - let rec collect attrsBefore acc expr = - match expr with - | { - pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = []; - } -> - let parameter = ([], lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let var, returnExpr = collectNewTypes [stringLoc] rest in - let parameter = - ( attrs, - Asttypes.Nolabel, - None, - Ast_helper.Pat.var ~loc:stringLoc.loc var ) - in - collect attrsBefore (parameter :: acc) returnExpr - | { - pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = [({txt = "bs"}, _)] as attrs; - } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | { - pexp_desc = - Pexp_fun - (((Labelled _ | Optional _) as lbl), defaultExpr, pattern, returnExpr); - pexp_attributes = attrs; - } -> - let parameter = (attrs, lbl, defaultExpr, pattern) in - collect attrsBefore (parameter :: acc) returnExpr - | expr -> (attrsBefore, List.rev acc, expr) - in - match expr with - | { - pexp_desc = Pexp_fun (Nolabel, _defaultExpr, _pattern, _returnExpr); - pexp_attributes = attrs; - } as expr -> - collect attrs [] {expr with pexp_attributes = []} - | expr -> collect [] [] expr - -let rec isBlockExpr expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ - | Pexp_sequence _ -> - true - | Pexp_apply (callExpr, _) when isBlockExpr callExpr -> true - | Pexp_constraint (expr, _) when isBlockExpr expr -> true - | Pexp_field (expr, _) when isBlockExpr expr -> true - | Pexp_setfield (expr, _, _) when isBlockExpr expr -> true - | _ -> false - -let isIfThenElseExpr expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_ifthenelse _ -> true - | _ -> false - -type node = - | Case of Parsetree.case - | CoreType of Parsetree.core_type - | ExprArgument of Parsetree.expression - | Expression of Parsetree.expression - | ExprRecordRow of Longident.t Asttypes.loc * Parsetree.expression - | ExtensionConstructor of Parsetree.extension_constructor - | LabelDeclaration of Parsetree.label_declaration - | ModuleBinding of Parsetree.module_binding - | ModuleDeclaration of Parsetree.module_declaration - | ModuleExpr of Parsetree.module_expr - | ObjectField of Parsetree.object_field - | PackageConstraint of Longident.t Asttypes.loc * Parsetree.core_type - | Pattern of Parsetree.pattern - | PatternRecordRow of Longident.t Asttypes.loc * Parsetree.pattern - | RowField of Parsetree.row_field - | SignatureItem of Parsetree.signature_item - | StructureItem of Parsetree.structure_item - | TypeDeclaration of Parsetree.type_declaration - | ValueBinding of Parsetree.value_binding - -let getLoc node = - let open Parsetree in - match node with - | Case case -> - { - case.pc_lhs.ppat_loc with - loc_end = - (match ParsetreeViewer.processBracesAttr case.pc_rhs with - | None, _ -> case.pc_rhs.pexp_loc.loc_end - | Some ({loc}, _), _ -> loc.Location.loc_end); - } - | CoreType ct -> ct.ptyp_loc - | ExprArgument expr -> ( - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc) - | Expression e -> ( - match e.pexp_attributes with - | ({txt = "res.braces" | "ns.braces"; loc}, _) :: _ -> loc - | _ -> e.pexp_loc) - | ExprRecordRow (li, e) -> {li.loc with loc_end = e.pexp_loc.loc_end} - | ExtensionConstructor ec -> ec.pext_loc - | LabelDeclaration ld -> ld.pld_loc - | ModuleBinding mb -> mb.pmb_loc - | ModuleDeclaration md -> md.pmd_loc - | ModuleExpr me -> me.pmod_loc - | ObjectField field -> ( - match field with - | Parsetree.Otag (lbl, _, typ) -> - {lbl.loc with loc_end = typ.ptyp_loc.loc_end} - | _ -> Location.none) - | PackageConstraint (li, te) -> {li.loc with loc_end = te.ptyp_loc.loc_end} - | Pattern p -> p.ppat_loc - | PatternRecordRow (li, p) -> {li.loc with loc_end = p.ppat_loc.loc_end} - | RowField rf -> ( - match rf with - | Parsetree.Rtag ({loc}, _, _, _) -> loc - | Rinherit {ptyp_loc} -> ptyp_loc) - | SignatureItem si -> si.psig_loc - | StructureItem si -> si.pstr_loc - | TypeDeclaration td -> td.ptype_loc - | ValueBinding vb -> vb.pvb_loc - -let rec walkStructure s t comments = - match s with - | _ when comments = [] -> () - | [] -> attach t.inside Location.none comments - | s -> walkList (s |> List.map (fun si -> StructureItem si)) t comments - -and walkStructureItem si t comments = - match si.Parsetree.pstr_desc with - | _ when comments = [] -> () - | Pstr_primitive valueDescription -> - walkValueDescription valueDescription t comments - | Pstr_open openDescription -> walkOpenDescription openDescription t comments - | Pstr_value (_, valueBindings) -> walkValueBindings valueBindings t comments - | Pstr_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments - | Pstr_eval (expr, _) -> walkExpression expr t comments - | Pstr_module moduleBinding -> walkModuleBinding moduleBinding t comments - | Pstr_recmodule moduleBindings -> - walkList - (moduleBindings |> List.map (fun mb -> ModuleBinding mb)) - t comments - | Pstr_modtype modTypDecl -> walkModuleTypeDeclaration modTypDecl t comments - | Pstr_attribute attribute -> walkAttribute attribute t comments - | Pstr_extension (extension, _) -> walkExtension extension t comments - | Pstr_include includeDeclaration -> - walkIncludeDeclaration includeDeclaration t comments - | Pstr_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments - | Pstr_typext typeExtension -> walkTypeExtension typeExtension t comments - | Pstr_class_type _ | Pstr_class _ -> () - -and walkValueDescription vd t comments = - let leading, trailing = partitionLeadingTrailing comments vd.pval_name.loc in - attach t.leading vd.pval_name.loc leading; - let afterName, rest = partitionAdjacentTrailing vd.pval_name.loc trailing in - attach t.trailing vd.pval_name.loc afterName; - let before, inside, after = partitionByLoc rest vd.pval_type.ptyp_loc in - attach t.leading vd.pval_type.ptyp_loc before; - walkCoreType vd.pval_type t inside; - attach t.trailing vd.pval_type.ptyp_loc after - -and walkTypeExtension te t comments = - let leading, trailing = - partitionLeadingTrailing comments te.ptyext_path.loc - in - attach t.leading te.ptyext_path.loc leading; - let afterPath, rest = partitionAdjacentTrailing te.ptyext_path.loc trailing in - attach t.trailing te.ptyext_path.loc afterPath; - - (* type params *) - let rest = - match te.ptyext_params with - | [] -> rest - | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest - in - walkList - (te.ptyext_constructors |> List.map (fun ec -> ExtensionConstructor ec)) - t rest - -and walkIncludeDeclaration inclDecl t comments = - let before, inside, after = - partitionByLoc comments inclDecl.pincl_mod.pmod_loc - in - attach t.leading inclDecl.pincl_mod.pmod_loc before; - walkModuleExpr inclDecl.pincl_mod t inside; - attach t.trailing inclDecl.pincl_mod.pmod_loc after - -and walkModuleTypeDeclaration mtd t comments = - let leading, trailing = partitionLeadingTrailing comments mtd.pmtd_name.loc in - attach t.leading mtd.pmtd_name.loc leading; - match mtd.pmtd_type with - | None -> attach t.trailing mtd.pmtd_name.loc trailing - | Some modType -> - let afterName, rest = - partitionAdjacentTrailing mtd.pmtd_name.loc trailing - in - attach t.trailing mtd.pmtd_name.loc afterName; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - -and walkModuleBinding mb t comments = - let leading, trailing = partitionLeadingTrailing comments mb.pmb_name.loc in - attach t.leading mb.pmb_name.loc leading; - let afterName, rest = partitionAdjacentTrailing mb.pmb_name.loc trailing in - attach t.trailing mb.pmb_name.loc afterName; - let leading, inside, trailing = partitionByLoc rest mb.pmb_expr.pmod_loc in - (match mb.pmb_expr.pmod_desc with - | Pmod_constraint _ -> - walkModuleExpr mb.pmb_expr t (List.concat [leading; inside]) - | _ -> - attach t.leading mb.pmb_expr.pmod_loc leading; - walkModuleExpr mb.pmb_expr t inside); - attach t.trailing mb.pmb_expr.pmod_loc trailing - -and walkSignature signature t comments = - match signature with - | _ when comments = [] -> () - | [] -> attach t.inside Location.none comments - | _s -> - walkList (signature |> List.map (fun si -> SignatureItem si)) t comments - -and walkSignatureItem (si : Parsetree.signature_item) t comments = - match si.psig_desc with - | _ when comments = [] -> () - | Psig_value valueDescription -> - walkValueDescription valueDescription t comments - | Psig_type (_, typeDeclarations) -> - walkTypeDeclarations typeDeclarations t comments - | Psig_typext typeExtension -> walkTypeExtension typeExtension t comments - | Psig_exception extensionConstructor -> - walkExtensionConstructor extensionConstructor t comments - | Psig_module moduleDeclaration -> - walkModuleDeclaration moduleDeclaration t comments - | Psig_recmodule moduleDeclarations -> - walkList - (moduleDeclarations |> List.map (fun md -> ModuleDeclaration md)) - t comments - | Psig_modtype moduleTypeDeclaration -> - walkModuleTypeDeclaration moduleTypeDeclaration t comments - | Psig_open openDescription -> walkOpenDescription openDescription t comments - | Psig_include includeDescription -> - walkIncludeDescription includeDescription t comments - | Psig_attribute attribute -> walkAttribute attribute t comments - | Psig_extension (extension, _) -> walkExtension extension t comments - | Psig_class _ | Psig_class_type _ -> () - -and walkIncludeDescription id t comments = - let before, inside, after = partitionByLoc comments id.pincl_mod.pmty_loc in - attach t.leading id.pincl_mod.pmty_loc before; - walkModType id.pincl_mod t inside; - attach t.trailing id.pincl_mod.pmty_loc after - -and walkModuleDeclaration md t comments = - let leading, trailing = partitionLeadingTrailing comments md.pmd_name.loc in - attach t.leading md.pmd_name.loc leading; - let afterName, rest = partitionAdjacentTrailing md.pmd_name.loc trailing in - attach t.trailing md.pmd_name.loc afterName; - let leading, inside, trailing = partitionByLoc rest md.pmd_type.pmty_loc in - attach t.leading md.pmd_type.pmty_loc leading; - walkModType md.pmd_type t inside; - attach t.trailing md.pmd_type.pmty_loc trailing - -and walkNode node tbl comments = - match node with - | Case c -> walkCase c tbl comments - | CoreType ct -> walkCoreType ct tbl comments - | ExprArgument ea -> walkExprArgument ea tbl comments - | Expression e -> walkExpression e tbl comments - | ExprRecordRow (ri, e) -> walkExprRecordRow (ri, e) tbl comments - | ExtensionConstructor ec -> walkExtensionConstructor ec tbl comments - | LabelDeclaration ld -> walkLabelDeclaration ld tbl comments - | ModuleBinding mb -> walkModuleBinding mb tbl comments - | ModuleDeclaration md -> walkModuleDeclaration md tbl comments - | ModuleExpr me -> walkModuleExpr me tbl comments - | ObjectField f -> walkObjectField f tbl comments - | PackageConstraint (li, te) -> walkPackageConstraint (li, te) tbl comments - | Pattern p -> walkPattern p tbl comments - | PatternRecordRow (li, p) -> walkPatternRecordRow (li, p) tbl comments - | RowField rf -> walkRowField rf tbl comments - | SignatureItem si -> walkSignatureItem si tbl comments - | StructureItem si -> walkStructureItem si tbl comments - | TypeDeclaration td -> walkTypeDeclaration td tbl comments - | ValueBinding vb -> walkValueBinding vb tbl comments - -and walkList : ?prevLoc:Location.t -> node list -> t -> Comment.t list -> unit = - fun ?prevLoc l t comments -> - match l with - | _ when comments = [] -> () - | [] -> ( - match prevLoc with - | Some loc -> attach t.trailing loc comments - | None -> ()) - | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - (match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then ( - let afterPrev, beforeCurr = partitionAdjacentTrailing prevLoc leading in - attach t.trailing prevLoc afterPrev; - attach t.leading currLoc beforeCurr) - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading - in - attach t.trailing prevLoc onSameLineAsPrev; - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - attach t.leading currLoc leading); - walkNode node t inside; - walkList ~prevLoc:currLoc rest t trailing - -(* The parsetree doesn't always contain location info about the opening or - * closing token of a "list-of-things". This routine visits the whole list, - * but returns any remaining comments that likely fall after the whole list. *) -and visitListButContinueWithRemainingComments : - 'node. - ?prevLoc:Location.t -> - newlineDelimited:bool -> - getLoc:('node -> Location.t) -> - walkNode:('node -> t -> Comment.t list -> unit) -> - 'node list -> - t -> - Comment.t list -> - Comment.t list = - fun ?prevLoc ~newlineDelimited ~getLoc ~walkNode l t comments -> - let open Location in - match l with - | _ when comments = [] -> [] - | [] -> ( - match prevLoc with - | Some loc -> - let afterPrev, rest = - if newlineDelimited then partitionByOnSameLine loc comments - else partitionAdjacentTrailing loc comments - in - attach t.trailing loc afterPrev; - rest - | None -> comments) - | node :: rest -> - let currLoc = getLoc node in - let leading, inside, trailing = partitionByLoc comments currLoc in - let () = - match prevLoc with - | None -> - (* first node, all leading comments attach here *) - attach t.leading currLoc leading; - () - | Some prevLoc -> - (* Same line *) - if prevLoc.loc_end.pos_lnum == currLoc.loc_start.pos_lnum then - let afterPrev, beforeCurr = - partitionAdjacentTrailing prevLoc leading - in - let () = attach t.trailing prevLoc afterPrev in - let () = attach t.leading currLoc beforeCurr in - () - else - let onSameLineAsPrev, afterPrev = - partitionByOnSameLine prevLoc leading - in - let () = attach t.trailing prevLoc onSameLineAsPrev in - let leading, _inside, _trailing = partitionByLoc afterPrev currLoc in - let () = attach t.leading currLoc leading in - () - in - walkNode node t inside; - visitListButContinueWithRemainingComments ~prevLoc:currLoc ~getLoc ~walkNode - ~newlineDelimited rest t trailing - -and walkValueBindings vbs t comments = - walkList (vbs |> List.map (fun vb -> ValueBinding vb)) t comments - -and walkOpenDescription openDescription t comments = - let loc = openDescription.popen_lid.loc in - let leading, trailing = partitionLeadingTrailing comments loc in - attach t.leading loc leading; - attach t.trailing loc trailing - -and walkTypeDeclarations typeDeclarations t comments = - walkList - (typeDeclarations |> List.map (fun td -> TypeDeclaration td)) - t comments - -and walkTypeParam (typexpr, _variance) t comments = - walkCoreType typexpr t comments - -and walkTypeDeclaration (td : Parsetree.type_declaration) t comments = - let beforeName, rest = partitionLeadingTrailing comments td.ptype_name.loc in - attach t.leading td.ptype_name.loc beforeName; - - let afterName, rest = partitionAdjacentTrailing td.ptype_name.loc rest in - attach t.trailing td.ptype_name.loc afterName; - - (* type params *) - let rest = - match td.ptype_params with - | [] -> rest - | typeParams -> - visitListButContinueWithRemainingComments - ~getLoc:(fun (typexpr, _variance) -> typexpr.Parsetree.ptyp_loc) - ~walkNode:walkTypeParam ~newlineDelimited:false typeParams t rest - in - - (* manifest: = typexpr *) - let rest = - match td.ptype_manifest with - | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - - let rest = - match td.ptype_kind with - | Ptype_abstract | Ptype_open -> rest - | Ptype_record labelDeclarations -> - let () = - if labelDeclarations = [] then attach t.inside td.ptype_loc rest - else - walkList - (labelDeclarations |> List.map (fun ld -> LabelDeclaration ld)) - t rest - in - [] - | Ptype_variant constructorDeclarations -> - walkConstructorDeclarations constructorDeclarations t rest - in - attach t.trailing td.ptype_loc rest - -and walkLabelDeclarations lds t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun ld -> ld.Parsetree.pld_loc) - ~walkNode:walkLabelDeclaration ~newlineDelimited:false lds t comments - -and walkLabelDeclaration ld t comments = - let beforeName, rest = partitionLeadingTrailing comments ld.pld_name.loc in - attach t.leading ld.pld_name.loc beforeName; - let afterName, rest = partitionAdjacentTrailing ld.pld_name.loc rest in - attach t.trailing ld.pld_name.loc afterName; - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest ld.pld_type.ptyp_loc - in - attach t.leading ld.pld_type.ptyp_loc beforeTyp; - walkCoreType ld.pld_type t insideTyp; - attach t.trailing ld.pld_type.ptyp_loc afterTyp - -and walkConstructorDeclarations cds t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) - ~walkNode:walkConstructorDeclaration ~newlineDelimited:false cds t comments - -and walkConstructorDeclaration cd t comments = - let beforeName, rest = partitionLeadingTrailing comments cd.pcd_name.loc in - attach t.leading cd.pcd_name.loc beforeName; - let afterName, rest = partitionAdjacentTrailing cd.pcd_name.loc rest in - attach t.trailing cd.pcd_name.loc afterName; - let rest = walkConstructorArguments cd.pcd_args t rest in - - let rest = - match cd.pcd_res with - | Some typexpr -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc rest typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.Parsetree.ptyp_loc afterTyp - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - attach t.trailing cd.pcd_loc rest - -and walkConstructorArguments args t comments = - match args with - | Pcstr_tuple typexprs -> - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Parsetree.ptyp_loc) - ~walkNode:walkCoreType ~newlineDelimited:false typexprs t comments - | Pcstr_record labelDeclarations -> - walkLabelDeclarations labelDeclarations t comments - -and walkValueBinding vb t comments = - let open Location in - let vb = - let open Parsetree in - match (vb.pvb_pat, vb.pvb_expr) with - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, - {pexp_desc = Pexp_constraint (expr, _typ)} ) -> - { - vb with - pvb_pat = - Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} - pat t; - pvb_expr = expr; - } - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_ :: _, t)})}, - {pexp_desc = Pexp_fun _} ) -> - { - vb with - pvb_pat = - { - vb.pvb_pat with - ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - } - | ( ({ - ppat_desc = - Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_ :: _, t)} as typ)); - } as constrainedPattern), - {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} - ) -> - (* - * The location of the Ptyp_poly on the pattern is the whole thing. - * let x: - * type t. (int, int) => int = - * (a, b) => { - * // comment - * a + b - * } - *) - { - vb with - pvb_pat = - { - constrainedPattern with - ppat_desc = Ppat_constraint (pat, typ); - ppat_loc = - {constrainedPattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - pvb_expr = expr; - } - | _ -> vb - in - let patternLoc = vb.Parsetree.pvb_pat.ppat_loc in - let exprLoc = vb.Parsetree.pvb_expr.pexp_loc in - let expr = vb.pvb_expr in - - let leading, inside, trailing = partitionByLoc comments patternLoc in - - (* everything before start of pattern can only be leading on the pattern: - * let |* before *| a = 1 *) - attach t.leading patternLoc leading; - walkPattern vb.Parsetree.pvb_pat t inside; - let afterPat, surroundingExpr = - partitionAdjacentTrailing patternLoc trailing - in - attach t.trailing patternLoc afterPat; - let beforeExpr, insideExpr, afterExpr = - partitionByLoc surroundingExpr exprLoc - in - if isBlockExpr expr then - walkExpression expr t (List.concat [beforeExpr; insideExpr; afterExpr]) - else ( - attach t.leading exprLoc beforeExpr; - walkExpression expr t insideExpr; - attach t.trailing exprLoc afterExpr) - -and walkExpression expr t comments = - let open Location in - match expr.Parsetree.pexp_desc with - | _ when comments = [] -> () - | Pexp_constant _ -> - let leading, trailing = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - attach t.trailing expr.pexp_loc trailing - | Pexp_ident longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pexp_let - ( _recFlag, - valueBindings, - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} ) -> - walkValueBindings valueBindings t comments - | Pexp_let (_recFlag, valueBindings, expr2) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> - if n.Parsetree.pvb_pat.ppat_loc.loc_ghost then n.pvb_expr.pexp_loc - else n.Parsetree.pvb_loc) - ~walkNode:walkValueBinding ~newlineDelimited:true valueBindings t - comments - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_sequence (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let comments = - if isBlockExpr expr1 then ( - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, comments = - partitionByOnSameLine expr1.pexp_loc trailing - in - attach t.trailing expr1.pexp_loc afterExpr; - comments) - in - if isBlockExpr expr2 then walkExpression expr2 t comments - else - let leading, inside, trailing = partitionByLoc comments expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_open (_override, longident, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = longident.loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - let afterLongident, rest = partitionByOnSameLine longident.loc trailing in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_extension - ( {txt = "bs.obj" | "obj"}, - PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] - ) -> - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments - | Pexp_extension extension -> walkExtension extension t comments - | Pexp_letexception (extensionConstructor, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} - leading; - let leading, inside, trailing = - partitionByLoc comments extensionConstructor.pext_loc - in - attach t.leading extensionConstructor.pext_loc leading; - walkExtensionConstructor extensionConstructor t inside; - let afterExtConstr, rest = - partitionByOnSameLine extensionConstructor.pext_loc trailing - in - attach t.trailing extensionConstructor.pext_loc afterExtConstr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_letmodule (stringLoc, modExpr, expr2) -> - let leading, comments = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading - {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} - leading; - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - let afterString, rest = partitionAdjacentTrailing stringLoc.loc trailing in - attach t.trailing stringLoc.loc afterString; - let beforeModExpr, insideModExpr, afterModExpr = - partitionByLoc rest modExpr.pmod_loc - in - attach t.leading modExpr.pmod_loc beforeModExpr; - walkModuleExpr modExpr t insideModExpr; - let afterModExpr, rest = - partitionByOnSameLine modExpr.pmod_loc afterModExpr - in - attach t.trailing modExpr.pmod_loc afterModExpr; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_assert expr | Pexp_lazy expr -> - if isBlockExpr expr then walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | Pexp_coerce (expr, optTypexpr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let rest = - match optTypexpr with - | Some typexpr -> - let leading, inside, trailing = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - let afterTyp, rest = - partitionAdjacentTrailing typexpr.ptyp_loc trailing - in - attach t.trailing typexpr.ptyp_loc afterTyp; - rest - | None -> rest - in - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing - | Pexp_constraint (expr, typexpr) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc leading; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc trailing - | Pexp_tuple [] - | Pexp_array [] - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside expr.pexp_loc comments - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListExprs [] expr |> List.map (fun e -> Expression e)) - t comments - | Pexp_construct (longident, args) -> ( - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - match args with - | Some expr -> - let afterLongident, rest = - partitionAdjacentTrailing longident.loc trailing - in - attach t.trailing longident.loc afterLongident; - walkExpression expr t rest - | None -> attach t.trailing longident.loc trailing) - | Pexp_variant (_label, None) -> () - | Pexp_variant (_label, Some expr) -> walkExpression expr t comments - | Pexp_array exprs | Pexp_tuple exprs -> - walkList (exprs |> List.map (fun e -> Expression e)) t comments - | Pexp_record (rows, spreadExpr) -> - if rows = [] then attach t.inside expr.pexp_loc comments - else - let comments = - match spreadExpr with - | None -> comments - | Some expr -> - let leading, inside, trailing = - partitionByLoc comments expr.pexp_loc - in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing - in - attach t.trailing expr.pexp_loc afterExpr; - rest - in - walkList - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) - t comments - | Pexp_field (expr, longident) -> - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - let trailing = - if isBlockExpr expr then ( - let afterExpr, rest = - partitionAdjacentTrailing expr.pexp_loc trailing - in - walkExpression expr t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - trailing) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc trailing in - attach t.trailing expr.pexp_loc afterExpr; - let leading, trailing = partitionLeadingTrailing rest longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pexp_setfield (expr1, longident, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) - else - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - attach t.trailing expr1.pexp_loc afterExpr; - rest - in - let beforeLongident, afterLongident = - partitionLeadingTrailing rest longident.loc - in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident - in - attach t.trailing longident.loc afterLongident; - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_ifthenelse (ifExpr, thenExpr, elseExpr) -> ( - let leading, rest = partitionLeadingTrailing comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - let leading, inside, trailing = partitionByLoc rest ifExpr.pexp_loc in - let comments = - if isBlockExpr ifExpr then ( - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - walkExpression ifExpr t (List.concat [leading; inside; afterExpr]); - comments) - else ( - attach t.leading ifExpr.pexp_loc leading; - walkExpression ifExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing ifExpr.pexp_loc trailing - in - attach t.trailing ifExpr.pexp_loc afterExpr; - comments) - in - let leading, inside, trailing = partitionByLoc comments thenExpr.pexp_loc in - let comments = - if isBlockExpr thenExpr then ( - let afterExpr, trailing = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - walkExpression thenExpr t (List.concat [leading; inside; afterExpr]); - trailing) - else ( - attach t.leading thenExpr.pexp_loc leading; - walkExpression thenExpr t inside; - let afterExpr, comments = - partitionAdjacentTrailing thenExpr.pexp_loc trailing - in - attach t.trailing thenExpr.pexp_loc afterExpr; - comments) - in - match elseExpr with - | None -> () - | Some expr -> - if isBlockExpr expr || isIfThenElseExpr expr then - walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing) - | Pexp_while (expr1, expr2) -> - let leading, inside, trailing = partitionByLoc comments expr1.pexp_loc in - let rest = - if isBlockExpr expr1 then ( - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - walkExpression expr1 t (List.concat [leading; inside; afterExpr]); - rest) - else ( - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = - partitionAdjacentTrailing expr1.pexp_loc trailing - in - attach t.trailing expr1.pexp_loc afterExpr; - rest) - in - if isBlockExpr expr2 then walkExpression expr2 t rest - else - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - attach t.trailing expr2.pexp_loc trailing - | Pexp_for (pat, expr1, expr2, _, expr3) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.trailing pat.ppat_loc afterPat; - let leading, inside, trailing = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc leading; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc trailing in - attach t.trailing expr1.pexp_loc afterExpr; - let leading, inside, trailing = partitionByLoc rest expr2.pexp_loc in - attach t.leading expr2.pexp_loc leading; - walkExpression expr2 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr2.pexp_loc trailing in - attach t.trailing expr2.pexp_loc afterExpr; - if isBlockExpr expr3 then walkExpression expr3 t rest - else - let leading, inside, trailing = partitionByLoc rest expr3.pexp_loc in - attach t.leading expr3.pexp_loc leading; - walkExpression expr3 t inside; - attach t.trailing expr3.pexp_loc trailing - | Pexp_pack modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pexp_match (expr1, [case; elseBranch]) - when Res_parsetree_viewer.hasIfLetAttribute expr.pexp_attributes -> - let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in - attach t.leading case.pc_lhs.ppat_loc before; - walkPattern case.pc_lhs t inside; - let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; - let before, inside, after = partitionByLoc rest expr1.pexp_loc in - attach t.leading expr1.pexp_loc before; - walkExpression expr1 t inside; - let afterExpr, rest = partitionAdjacentTrailing expr1.pexp_loc after in - attach t.trailing expr1.pexp_loc afterExpr; - let before, inside, after = partitionByLoc rest case.pc_rhs.pexp_loc in - let after = - if isBlockExpr case.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - walkExpression case.pc_rhs t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading case.pc_rhs.pexp_loc before; - walkExpression case.pc_rhs t inside; - after) - in - let afterExpr, rest = - partitionAdjacentTrailing case.pc_rhs.pexp_loc after - in - attach t.trailing case.pc_rhs.pexp_loc afterExpr; - let before, inside, after = - partitionByLoc rest elseBranch.pc_rhs.pexp_loc - in - let after = - if isBlockExpr elseBranch.pc_rhs then ( - let afterExpr, rest = - partitionAdjacentTrailing elseBranch.pc_rhs.pexp_loc after - in - walkExpression elseBranch.pc_rhs t - (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading elseBranch.pc_rhs.pexp_loc before; - walkExpression elseBranch.pc_rhs t inside; - after) - in - attach t.trailing elseBranch.pc_rhs.pexp_loc after - | Pexp_match (expr, cases) | Pexp_try (expr, cases) -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - let after = - if isBlockExpr expr then ( - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - walkExpression expr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - after) - in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - attach t.trailing expr.pexp_loc afterExpr; - walkList (cases |> List.map (fun case -> Case case)) t rest - (* unary expression: todo use parsetreeviewer *) - | Pexp_apply - ( { - pexp_desc = - Pexp_ident - { - txt = - Longident.Lident ("~+" | "~+." | "~-" | "~-." | "not" | "!"); - }; - }, - [(Nolabel, argExpr)] ) -> - let before, inside, after = partitionByLoc comments argExpr.pexp_loc in - attach t.leading argExpr.pexp_loc before; - walkExpression argExpr t inside; - attach t.trailing argExpr.pexp_loc after - (* binary expression *) - | Pexp_apply - ( { - pexp_desc = - Pexp_ident - { - txt = - Longident.Lident - ( ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" - | "<=" | ">=" | "|>" | "+" | "+." | "-" | "-." | "++" | "^" - | "*" | "*." | "/" | "/." | "**" | "|." | "|.u" | "<>" ); - }; - }, - [(Nolabel, operand1); (Nolabel, operand2)] ) -> - let before, inside, after = partitionByLoc comments operand1.pexp_loc in - attach t.leading operand1.pexp_loc before; - walkExpression operand1 t inside; - let afterOperand1, rest = - partitionAdjacentTrailing operand1.pexp_loc after - in - attach t.trailing operand1.pexp_loc afterOperand1; - let before, inside, after = partitionByLoc rest operand2.pexp_loc in - attach t.leading operand2.pexp_loc before; - walkExpression operand2 t inside; - (* (List.concat [inside; after]); *) - attach t.trailing operand2.pexp_loc after - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> - walkList [Expression parentExpr; Expression memberExpr] t comments - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) - -> - walkList - [Expression parentExpr; Expression memberExpr; Expression targetExpr] - t comments - | Pexp_apply (callExpr, arguments) -> - let before, inside, after = partitionByLoc comments callExpr.pexp_loc in - let after = - if isBlockExpr callExpr then ( - let afterExpr, rest = - partitionAdjacentTrailing callExpr.pexp_loc after - in - walkExpression callExpr t (List.concat [before; inside; afterExpr]); - rest) - else ( - attach t.leading callExpr.pexp_loc before; - walkExpression callExpr t inside; - after) - in - if ParsetreeViewer.isJsxExpression expr then ( - let props = - arguments - |> List.filter (fun (label, _) -> - match label with - | Asttypes.Labelled "children" -> false - | Asttypes.Nolabel -> false - | _ -> true) - in - let maybeChildren = - arguments - |> List.find_opt (fun (label, _) -> - label = Asttypes.Labelled "children") - in - match maybeChildren with - (* There is no need to deal with this situation as the children cannot be NONE *) - | None -> () - | Some (_, children) -> - let leading, inside, _ = partitionByLoc after children.pexp_loc in - if props = [] then - (* All comments inside a tag are trailing comments of the tag if there are no props -
- *) - let afterExpr, _ = - partitionAdjacentTrailing callExpr.pexp_loc after - in - attach t.trailing callExpr.pexp_loc afterExpr - else - walkList (props |> List.map (fun (_, e) -> ExprArgument e)) t leading; - walkExpression children t inside) - else - let afterExpr, rest = partitionAdjacentTrailing callExpr.pexp_loc after in - attach t.trailing callExpr.pexp_loc afterExpr; - walkList (arguments |> List.map (fun (_, e) -> ExprArgument e)) t rest - | Pexp_fun (_, _, _, _) | Pexp_newtype _ -> ( - let _, parameters, returnExpr = funExpr expr in - let comments = - visitListButContinueWithRemainingComments ~newlineDelimited:false - ~walkNode:walkExprPararameter - ~getLoc:(fun (_attrs, _argLbl, exprOpt, pattern) -> - let open Parsetree in - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> - loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - match exprOpt with - | None -> {pattern.ppat_loc with loc_start = startPos} - | Some expr -> - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - }) - parameters t comments - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) - when expr.pexp_loc.loc_start.pos_cnum >= typ.ptyp_loc.loc_end.pos_cnum -> - let leading, inside, trailing = partitionByLoc comments typ.ptyp_loc in - attach t.leading typ.ptyp_loc leading; - walkCoreType typ t inside; - let afterTyp, comments = - partitionAdjacentTrailing typ.ptyp_loc trailing - in - attach t.trailing typ.ptyp_loc afterTyp; - if isBlockExpr expr then walkExpression expr t comments - else - let leading, inside, trailing = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | Pexp_construct ({txt = Longident.Lident "Function$"}, Some returnExpr) -> - walkExpression returnExpr t comments - | _ -> - if isBlockExpr returnExpr then walkExpression returnExpr t comments - else - let leading, inside, trailing = - partitionByLoc comments returnExpr.pexp_loc - in - attach t.leading returnExpr.pexp_loc leading; - walkExpression returnExpr t inside; - attach t.trailing returnExpr.pexp_loc trailing) - | _ -> () - -and walkExprPararameter (_attrs, _argLbl, exprOpt, pattern) t comments = - let leading, inside, trailing = partitionByLoc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - match exprOpt with - | Some expr -> - let _afterPat, rest = partitionAdjacentTrailing pattern.ppat_loc trailing in - attach t.trailing pattern.ppat_loc trailing; - if isBlockExpr expr then walkExpression expr t rest - else - let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - | None -> attach t.trailing pattern.ppat_loc trailing - -and walkExprArgument expr t comments = - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> - let leading, trailing = partitionLeadingTrailing comments loc in - attach t.leading loc leading; - let afterLabel, rest = partitionAdjacentTrailing loc trailing in - attach t.trailing loc afterLabel; - let before, inside, after = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after - | _ -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after - -and walkCase (case : Parsetree.case) t comments = - let before, inside, after = partitionByLoc comments case.pc_lhs.ppat_loc in - (* cases don't have a location on their own, leading comments should go - * after the bar on the pattern *) - walkPattern case.pc_lhs t (List.concat [before; inside]); - let afterPat, rest = partitionAdjacentTrailing case.pc_lhs.ppat_loc after in - attach t.trailing case.pc_lhs.ppat_loc afterPat; - let comments = - match case.pc_guard with - | Some expr -> - let before, inside, after = partitionByLoc rest expr.pexp_loc in - let afterExpr, rest = partitionAdjacentTrailing expr.pexp_loc after in - if isBlockExpr expr then - walkExpression expr t (List.concat [before; inside; afterExpr]) - else ( - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc afterExpr); - rest - | None -> rest - in - if isBlockExpr case.pc_rhs then walkExpression case.pc_rhs t comments - else - let before, inside, after = partitionByLoc comments case.pc_rhs.pexp_loc in - attach t.leading case.pc_rhs.pexp_loc before; - walkExpression case.pc_rhs t inside; - attach t.trailing case.pc_rhs.pexp_loc after - -and walkExprRecordRow (longident, expr) t comments = - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident - in - attach t.trailing longident.loc afterLongident; - let leading, inside, trailing = partitionByLoc rest expr.pexp_loc in - attach t.leading expr.pexp_loc leading; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc trailing - -and walkExtensionConstructor extConstr t comments = - let leading, trailing = - partitionLeadingTrailing comments extConstr.pext_name.loc - in - attach t.leading extConstr.pext_name.loc leading; - let afterName, rest = - partitionAdjacentTrailing extConstr.pext_name.loc trailing - in - attach t.trailing extConstr.pext_name.loc afterName; - walkExtensionConstructorKind extConstr.pext_kind t rest - -and walkExtensionConstructorKind kind t comments = - match kind with - | Pext_rebind longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pext_decl (constructorArguments, maybeTypExpr) -> ( - let rest = walkConstructorArguments constructorArguments t comments in - match maybeTypExpr with - | None -> () - | Some typexpr -> - let before, inside, after = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc before; - walkCoreType typexpr t inside; - attach t.trailing typexpr.ptyp_loc after) - -and walkModuleExpr modExpr t comments = - match modExpr.pmod_desc with - | Pmod_ident longident -> - let before, after = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc before; - attach t.trailing longident.loc after - | Pmod_structure [] -> attach t.inside modExpr.pmod_loc comments - | Pmod_structure structure -> walkStructure structure t comments - | Pmod_extension extension -> walkExtension extension t comments - | Pmod_unpack expr -> - let before, inside, after = partitionByLoc comments expr.pexp_loc in - attach t.leading expr.pexp_loc before; - walkExpression expr t inside; - attach t.trailing expr.pexp_loc after - | Pmod_constraint (modexpr, modtype) -> - if modtype.pmty_loc.loc_start >= modexpr.pmod_loc.loc_end then ( - let before, inside, after = partitionByLoc comments modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - let after, rest = partitionAdjacentTrailing modexpr.pmod_loc after in - attach t.trailing modexpr.pmod_loc after; - let before, inside, after = partitionByLoc rest modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - attach t.trailing modtype.pmty_loc after) - else - let before, inside, after = partitionByLoc comments modtype.pmty_loc in - attach t.leading modtype.pmty_loc before; - walkModType modtype t inside; - let after, rest = partitionAdjacentTrailing modtype.pmty_loc after in - attach t.trailing modtype.pmty_loc after; - let before, inside, after = partitionByLoc rest modexpr.pmod_loc in - attach t.leading modexpr.pmod_loc before; - walkModuleExpr modexpr t inside; - attach t.trailing modexpr.pmod_loc after - | Pmod_apply (_callModExpr, _argModExpr) -> - let modExprs = modExprApply modExpr in - walkList (modExprs |> List.map (fun me -> ModuleExpr me)) t comments - | Pmod_functor _ -> ( - let parameters, returnModExpr = modExprFunctor modExpr in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModExprParameter ~newlineDelimited:false parameters t - comments - in - match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) - when modType.pmty_loc.loc_end.pos_cnum - <= modExpr.pmod_loc.loc_start.pos_cnum -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - let after, rest = partitionAdjacentTrailing modType.pmty_loc after in - attach t.trailing modType.pmty_loc after; - let before, inside, after = partitionByLoc rest modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | _ -> - let before, inside, after = - partitionByLoc comments returnModExpr.pmod_loc - in - attach t.leading returnModExpr.pmod_loc before; - walkModuleExpr returnModExpr t inside; - attach t.trailing returnModExpr.pmod_loc after) - -and walkModExprParameter parameter t comments = - let _attrs, lbl, modTypeOption = parameter in - let leading, trailing = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc leading; - match modTypeOption with - | None -> attach t.trailing lbl.loc trailing - | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - -and walkModType modType t comments = - match modType.pmty_desc with - | Pmty_ident longident | Pmty_alias longident -> - let leading, trailing = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc leading; - attach t.trailing longident.loc trailing - | Pmty_signature [] -> attach t.inside modType.pmty_loc comments - | Pmty_signature signature -> walkSignature signature t comments - | Pmty_extension extension -> walkExtension extension t comments - | Pmty_typeof modExpr -> - let before, inside, after = partitionByLoc comments modExpr.pmod_loc in - attach t.leading modExpr.pmod_loc before; - walkModuleExpr modExpr t inside; - attach t.trailing modExpr.pmod_loc after - | Pmty_with (modType, _withConstraints) -> - let before, inside, after = partitionByLoc comments modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - (* TODO: withConstraints*) - | Pmty_functor _ -> - let parameters, returnModType = functorType modType in - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, lbl, modTypeOption) -> - match modTypeOption with - | None -> lbl.Asttypes.loc - | Some modType -> - if lbl.txt = "_" then modType.Parsetree.pmty_loc - else {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end}) - ~walkNode:walkModTypeParameter ~newlineDelimited:false parameters t - comments - in - let before, inside, after = - partitionByLoc comments returnModType.pmty_loc - in - attach t.leading returnModType.pmty_loc before; - walkModType returnModType t inside; - attach t.trailing returnModType.pmty_loc after - -and walkModTypeParameter (_, lbl, modTypeOption) t comments = - let leading, trailing = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc leading; - match modTypeOption with - | None -> attach t.trailing lbl.loc trailing - | Some modType -> - let afterLbl, rest = partitionAdjacentTrailing lbl.loc trailing in - attach t.trailing lbl.loc afterLbl; - let before, inside, after = partitionByLoc rest modType.pmty_loc in - attach t.leading modType.pmty_loc before; - walkModType modType t inside; - attach t.trailing modType.pmty_loc after - -and walkPattern pat t comments = - let open Location in - match pat.Parsetree.ppat_desc with - | _ when comments = [] -> () - | Ppat_alias (pat, alias) -> - let leading, inside, trailing = partitionByLoc comments pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - let afterPat, rest = partitionAdjacentTrailing pat.ppat_loc trailing in - attach t.leading pat.ppat_loc leading; - attach t.trailing pat.ppat_loc afterPat; - let beforeAlias, afterAlias = partitionLeadingTrailing rest alias.loc in - attach t.leading alias.loc beforeAlias; - attach t.trailing alias.loc afterAlias - | Ppat_tuple [] - | Ppat_array [] - | Ppat_construct ({txt = Longident.Lident "()"}, _) - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - attach t.inside pat.ppat_loc comments - | Ppat_array patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments - | Ppat_tuple patterns -> - walkList (patterns |> List.map (fun p -> Pattern p)) t comments - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - walkList - (collectListPatterns [] pat |> List.map (fun p -> Pattern p)) - t comments - | Ppat_construct (constr, None) -> - let beforeConstr, afterConstr = - partitionLeadingTrailing comments constr.loc - in - attach t.leading constr.loc beforeConstr; - attach t.trailing constr.loc afterConstr - | Ppat_construct (constr, Some pat) -> - let leading, trailing = partitionLeadingTrailing comments constr.loc in - attach t.leading constr.loc leading; - let afterConstructor, rest = - partitionAdjacentTrailing constr.loc trailing - in - attach t.trailing constr.loc afterConstructor; - let leading, inside, trailing = partitionByLoc rest pat.ppat_loc in - attach t.leading pat.ppat_loc leading; - walkPattern pat t inside; - attach t.trailing pat.ppat_loc trailing - | Ppat_variant (_label, None) -> () - | Ppat_variant (_label, Some pat) -> walkPattern pat t comments - | Ppat_type _ -> () - | Ppat_record (recordRows, _) -> - walkList - (recordRows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) - t comments - | Ppat_or _ -> - walkList - (Res_parsetree_viewer.collectOrPatternChain pat - |> List.map (fun pat -> Pattern pat)) - t comments - | Ppat_constraint (pattern, typ) -> - let beforePattern, insidePattern, afterPattern = - partitionByLoc comments pattern.ppat_loc - in - attach t.leading pattern.ppat_loc beforePattern; - walkPattern pattern t insidePattern; - let afterPattern, rest = - partitionAdjacentTrailing pattern.ppat_loc afterPattern - in - attach t.trailing pattern.ppat_loc afterPattern; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typ.ptyp_loc in - attach t.leading typ.ptyp_loc beforeTyp; - walkCoreType typ t insideTyp; - attach t.trailing typ.ptyp_loc afterTyp - | Ppat_lazy pattern | Ppat_exception pattern -> - let leading, inside, trailing = partitionByLoc comments pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing - | Ppat_unpack stringLoc -> - let leading, trailing = partitionLeadingTrailing comments stringLoc.loc in - attach t.leading stringLoc.loc leading; - attach t.trailing stringLoc.loc trailing - | Ppat_extension extension -> walkExtension extension t comments - | _ -> () - -(* name: firstName *) -and walkPatternRecordRow row t comments = - match row with - (* punned {x}*) - | ( {Location.txt = Longident.Lident ident; loc = longidentLoc}, - {Parsetree.ppat_desc = Ppat_var {txt; _}} ) - when ident = txt -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longidentLoc in - attach t.leading longidentLoc beforeLbl; - attach t.trailing longidentLoc afterLbl - | longident, pattern -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments longident.loc in - attach t.leading longident.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing longident.loc afterLbl in - attach t.trailing longident.loc afterLbl; - let leading, inside, trailing = partitionByLoc rest pattern.ppat_loc in - attach t.leading pattern.ppat_loc leading; - walkPattern pattern t inside; - attach t.trailing pattern.ppat_loc trailing - -and walkRowField (rowField : Parsetree.row_field) t comments = - match rowField with - | Parsetree.Rtag ({loc}, _, _, _) -> - let before, after = partitionLeadingTrailing comments loc in - attach t.leading loc before; - attach t.trailing loc after - | Rinherit _ -> () - -and walkCoreType typ t comments = - match typ.Parsetree.ptyp_desc with - | _ when comments = [] -> () - | Ptyp_tuple typexprs -> - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t comments - | Ptyp_extension extension -> walkExtension extension t comments - | Ptyp_package packageType -> walkPackageType packageType t comments - | Ptyp_alias (typexpr, _alias) -> - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | Ptyp_poly (strings, typexpr) -> - let comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun n -> n.Asttypes.loc) - ~walkNode:(fun longident t comments -> - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident) - ~newlineDelimited:false strings t comments - in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | Ptyp_variant (rowFields, _, _) -> - walkList (rowFields |> List.map (fun rf -> RowField rf)) t comments - | Ptyp_constr - ({txt = Lident "function$"}, [({ptyp_desc = Ptyp_arrow _} as desc); _]) -> - walkCoreType desc t comments - | Ptyp_constr (longident, typexprs) -> - let beforeLongident, _afterLongident = - partitionLeadingTrailing comments longident.loc - in - let afterLongident, rest = - partitionAdjacentTrailing longident.loc comments - in - attach t.leading longident.loc beforeLongident; - attach t.trailing longident.loc afterLongident; - walkList (typexprs |> List.map (fun ct -> CoreType ct)) t rest - | Ptyp_arrow _ -> - let _, parameters, typexpr = arrowType typ in - let comments = walkTypeParameters parameters t comments in - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | Ptyp_object (fields, _) -> walkTypObjectFields fields t comments - | _ -> () - -and walkTypObjectFields fields t comments = - walkList (fields |> List.map (fun f -> ObjectField f)) t comments - -and walkObjectField field t comments = - match field with - | Otag (lbl, _, typexpr) -> - let beforeLbl, afterLbl = partitionLeadingTrailing comments lbl.loc in - attach t.leading lbl.loc beforeLbl; - let afterLbl, rest = partitionAdjacentTrailing lbl.loc afterLbl in - attach t.trailing lbl.loc afterLbl; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - | _ -> () - -and walkTypeParameters typeParameters t comments = - visitListButContinueWithRemainingComments - ~getLoc:(fun (_, _, typexpr) -> - match typexpr.Parsetree.ptyp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = typexpr.ptyp_loc.loc_end} - | _ -> typexpr.ptyp_loc) - ~walkNode:walkTypeParameter ~newlineDelimited:false typeParameters t - comments - -and walkTypeParameter (_attrs, _lbl, typexpr) t comments = - let beforeTyp, insideTyp, afterTyp = - partitionByLoc comments typexpr.ptyp_loc - in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - -and walkPackageType packageType t comments = - let longident, packageConstraints = packageType in - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident - in - attach t.trailing longident.loc afterLongident; - walkPackageConstraints packageConstraints t rest - -and walkPackageConstraints packageConstraints t comments = - walkList - (packageConstraints |> List.map (fun (li, te) -> PackageConstraint (li, te))) - t comments - -and walkPackageConstraint packageConstraint t comments = - let longident, typexpr = packageConstraint in - let beforeLongident, afterLongident = - partitionLeadingTrailing comments longident.loc - in - attach t.leading longident.loc beforeLongident; - let afterLongident, rest = - partitionAdjacentTrailing longident.loc afterLongident - in - attach t.trailing longident.loc afterLongident; - let beforeTyp, insideTyp, afterTyp = partitionByLoc rest typexpr.ptyp_loc in - attach t.leading typexpr.ptyp_loc beforeTyp; - walkCoreType typexpr t insideTyp; - attach t.trailing typexpr.ptyp_loc afterTyp - -and walkExtension extension t comments = - let id, payload = extension in - let beforeId, afterId = partitionLeadingTrailing comments id.loc in - attach t.leading id.loc beforeId; - let afterId, rest = partitionAdjacentTrailing id.loc afterId in - attach t.trailing id.loc afterId; - walkPayload payload t rest - -and walkAttribute (id, payload) t comments = - let beforeId, afterId = partitionLeadingTrailing comments id.loc in - attach t.leading id.loc beforeId; - let afterId, rest = partitionAdjacentTrailing id.loc afterId in - attach t.trailing id.loc afterId; - walkPayload payload t rest - -and walkPayload payload t comments = - match payload with - | PStr s -> walkStructure s t comments - | _ -> () diff --git a/jscomp/syntax/src/res_core.ml b/jscomp/syntax/src/res_core.ml deleted file mode 100644 index 2a08074..0000000 --- a/jscomp/syntax/src/res_core.ml +++ /dev/null @@ -1,6634 +0,0 @@ -module Doc = Res_doc -module Grammar = Res_grammar -module Token = Res_token -module Diagnostics = Res_diagnostics -module CommentTable = Res_comments_table -module ResPrinter = Res_printer -module Scanner = Res_scanner -module Parser = Res_parser - -module LoopProgress = struct - let listRest list = - match list with - | [] -> assert false - | _ :: rest -> rest -end - -let mkLoc startLoc endLoc = - Location.{loc_start = startLoc; loc_end = endLoc; loc_ghost = false} - -module Recover = struct - let defaultExpr () = - let id = Location.mknoloc "rescript.exprhole" in - Ast_helper.Exp.mk (Pexp_extension (id, PStr [])) - - let defaultType () = - let id = Location.mknoloc "rescript.typehole" in - Ast_helper.Typ.extension (id, PStr []) - - let defaultPattern () = - let id = Location.mknoloc "rescript.patternhole" in - Ast_helper.Pat.extension (id, PStr []) - - let defaultModuleExpr () = Ast_helper.Mod.structure [] - let defaultModuleType () = Ast_helper.Mty.signature [] - - let defaultSignatureItem = - let id = Location.mknoloc "rescript.sigitemhole" in - Ast_helper.Sig.extension (id, PStr []) - - let recoverEqualGreater p = - Parser.expect EqualGreater p; - match p.Parser.token with - | MinusGreater -> Parser.next p - | _ -> () - - let shouldAbortListParse p = - let rec check breadcrumbs = - match breadcrumbs with - | [] -> false - | (grammar, _) :: rest -> - if Grammar.isPartOfList grammar p.Parser.token then true else check rest - in - check p.breadcrumbs -end - -module ErrorMessages = struct - let listPatternSpread = - "List pattern matches only supports one `...` spread, at the end.\n\ - Explanation: a list spread at the tail is efficient, but a spread in the \ - middle would create new lists; out of performance concern, our pattern \ - matching currently guarantees to never create new intermediate data." - - let recordPatternSpread = - "Record's `...` spread is not supported in pattern matches.\n\ - Explanation: you can't collect a subset of a record's field into its own \ - record, since a record needs an explicit declaration and that subset \ - wouldn't have one.\n\ - Solution: you need to pull out each field you want explicitly." - (* let recordPatternUnderscore = "Record patterns only support one `_`, at the end." *) - [@@live] - - let arrayPatternSpread = - "Array's `...` spread is not supported in pattern matches.\n\ - Explanation: such spread would create a subarray; out of performance \ - concern, our pattern matching currently guarantees to never create new \ - intermediate data.\n\ - Solution: if it's to validate the first few elements, use a `when` clause \ - + Array size check + `get` checks on the current pattern. If it's to \ - obtain a subarray, use `Array.sub` or `Belt.Array.slice`." - - let recordExprSpread = - "Records can only have one `...` spread, at the beginning.\n\ - Explanation: since records have a known, fixed shape, a spread like `{a, \ - ...b}` wouldn't make sense, as `b` would override every field of `a` \ - anyway." - - let variantIdent = - "A polymorphic variant (e.g. #id) must start with an alphabetical letter \ - or be a number (e.g. #742)" - - let experimentalIfLet expr = - let switchExpr = {expr with Parsetree.pexp_attributes = []} in - Doc.concat - [ - Doc.text "If-let is currently highly experimental."; - Doc.line; - Doc.text "Use a regular `switch` with pattern matching instead:"; - Doc.concat - [ - Doc.hardLine; - Doc.hardLine; - ResPrinter.printExpression switchExpr CommentTable.empty; - ]; - ] - |> Doc.toString ~width:80 - - let typeParam = - "A type param consists of a singlequote followed by a name like `'a` or \ - `'A`" - let typeVar = - "A type variable consists of a singlequote followed by a name like `'a` or \ - `'A`" - - let attributeWithoutNode (attr : Parsetree.attribute) = - let {Asttypes.txt = attrName}, _ = attr in - "Did you forget to attach `" ^ attrName - ^ "` to an item?\n Standalone attributes start with `@@` like: `@@" - ^ attrName ^ "`" - - let typeDeclarationNameLongident longident = - "A type declaration's name cannot contain a module access. Did you mean `" - ^ Longident.last longident ^ "`?" - - let tupleSingleElement = "A tuple needs at least two elements" - - let missingTildeLabeledParameter name = - if name = "" then "A labeled parameter starts with a `~`." - else "A labeled parameter starts with a `~`. Did you mean: `~" ^ name ^ "`?" - - let stringInterpolationInPattern = - "String interpolation is not supported in pattern matching." - - let spreadInRecordDeclaration = - "A record type declaration doesn't support the ... spread. Only an object \ - (with quoted field names) does." - - let objectQuotedFieldName name = - "An object type declaration needs quoted field names. Did you mean \"" - ^ name ^ "\"?" - - let forbiddenInlineRecordDeclaration = - "An inline record type declaration is only allowed in a variant \ - constructor's declaration" - - let polyVarIntWithSuffix number = - "A numeric polymorphic variant cannot be followed by a letter. Did you \ - mean `#" ^ number ^ "`?" -end - -module InExternal = struct - let status = ref false -end - -let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) -let uncurriedAppAttr = (Location.mknoloc "res.uapp", Parsetree.PStr []) -let ternaryAttr = (Location.mknoloc "res.ternary", Parsetree.PStr []) -let ifLetAttr = (Location.mknoloc "res.iflet", Parsetree.PStr []) -let optionalAttr = (Location.mknoloc "res.optional", Parsetree.PStr []) -let makeAwaitAttr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) -let makeAsyncAttr loc = (Location.mkloc "res.async" loc, Parsetree.PStr []) - -let makeExpressionOptional ~optional (e : Parsetree.expression) = - if optional then {e with pexp_attributes = optionalAttr :: e.pexp_attributes} - else e -let makePatternOptional ~optional (p : Parsetree.pattern) = - if optional then {p with ppat_attributes = optionalAttr :: p.ppat_attributes} - else p - -let suppressFragileMatchWarningAttr = - ( Location.mknoloc "warning", - Parsetree.PStr - [ - Ast_helper.Str.eval - (Ast_helper.Exp.constant (Pconst_string ("-4", None))); - ] ) -let makeBracesAttr loc = (Location.mkloc "res.braces" loc, Parsetree.PStr []) -let templateLiteralAttr = (Location.mknoloc "res.template", Parsetree.PStr []) - -let taggedTemplateLiteralAttr = - (Location.mknoloc "res.taggedTemplate", Parsetree.PStr []) - -let spreadAttr = (Location.mknoloc "res.spread", Parsetree.PStr []) - -type argument = { - dotted: bool; - label: Asttypes.arg_label; - expr: Parsetree.expression; -} - -type typeParameter = { - dotted: bool; - attrs: Ast_helper.attrs; - label: Asttypes.arg_label; - typ: Parsetree.core_type; - startPos: Lexing.position; -} - -type typDefOrExt = - | TypeDef of { - recFlag: Asttypes.rec_flag; - types: Parsetree.type_declaration list; - } - | TypeExt of Parsetree.type_extension - -type labelledParameter = - | TermParameter of { - dotted: bool; - attrs: Parsetree.attributes; - label: Asttypes.arg_label; - expr: Parsetree.expression option; - pat: Parsetree.pattern; - pos: Lexing.position; - } - | TypeParameter of { - dotted: bool; - attrs: Parsetree.attributes; - locs: string Location.loc list; - pos: Lexing.position; - } - -type recordPatternItem = - | PatUnderscore - | PatField of (Ast_helper.lid * Parsetree.pattern) - -type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr - -let getClosingToken = function - | Token.Lparen -> Token.Rparen - | Lbrace -> Rbrace - | Lbracket -> Rbracket - | List -> Rbrace - | LessThan -> GreaterThan - | _ -> assert false - -let rec goToClosing closingToken state = - match (state.Parser.token, closingToken) with - | Rparen, Token.Rparen - | Rbrace, Rbrace - | Rbracket, Rbracket - | GreaterThan, GreaterThan -> - Parser.next state; - () - | ((Token.Lbracket | Lparen | Lbrace | List | LessThan) as t), _ -> - Parser.next state; - goToClosing (getClosingToken t) state; - goToClosing closingToken state - | (Rparen | Token.Rbrace | Rbracket | Eof), _ -> - () (* TODO: how do report errors here? *) - | _ -> - Parser.next state; - goToClosing closingToken state - -(* Madness *) -let isEs6ArrowExpression ~inTernary p = - Parser.lookahead p (fun state -> - let async = - match state.Parser.token with - | Lident "async" -> - Parser.next state; - true - | _ -> false - in - match state.Parser.token with - | Lident _ | Underscore -> ( - Parser.next state; - match state.Parser.token with - (* Don't think that this valid - * Imagine: let x = (a: int) - * This is a parenthesized expression with a type constraint, wait for - * the arrow *) - (* | Colon when not inTernary -> true *) - | EqualGreater -> true - | _ -> false) - | Lparen -> ( - let prevEndPos = state.prevEndPos in - Parser.next state; - match state.token with - (* arrived at `()` here *) - | Rparen -> ( - Parser.next state; - match state.Parser.token with - (* arrived at `() :` here *) - | Colon when not inTernary -> ( - Parser.next state; - match state.Parser.token with - (* arrived at `() :typ` here *) - | Lident _ -> ( - Parser.next state; - (match state.Parser.token with - (* arrived at `() :typ<` here *) - | LessThan -> - Parser.next state; - goToClosing GreaterThan state - | _ -> ()); - match state.Parser.token with - (* arrived at `() :typ =>` or `() :typ<'a,'b> =>` here *) - | EqualGreater -> true - | _ -> false) - | _ -> true) - | EqualGreater -> true - | _ -> false) - | Dot (* uncurried *) -> true - | Tilde when not async -> true - | Backtick -> - false - (* (` always indicates the start of an expr, can't be es6 parameter *) - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater -> true - (* | Lbrace TODO: detect missing =>, is this possible? *) - | Colon when not inTernary -> true - | Rparen -> - (* imagine having something as : - * switch colour { - * | Red - * when l == l' - * || (&Clflags.classic && (l == Nolabel && !is_optional(l'))) => (t1, t2) - * We'll arrive at the outer rparen just before the =>. - * This is not an es6 arrow. - * *) - false - | _ -> ( - Parser.nextUnsafe state; - (* error recovery, peek at the next token, - * (elements, providerId] => { - * in the example above, we have an unbalanced ] here - *) - match state.Parser.token with - | EqualGreater when state.startPos.pos_lnum == prevEndPos.pos_lnum - -> - true - | _ -> false))) - | _ -> false) - -let isEs6ArrowFunctor p = - Parser.lookahead p (fun state -> - match state.Parser.token with - (* | Uident _ | Underscore -> *) - (* Parser.next state; *) - (* begin match state.Parser.token with *) - (* | EqualGreater -> true *) - (* | _ -> false *) - (* end *) - | Lparen -> ( - Parser.next state; - match state.token with - | Rparen -> ( - Parser.next state; - match state.token with - | Colon | EqualGreater -> true - | _ -> false) - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater | Lbrace -> true - | Colon -> true - | _ -> false)) - | _ -> false) - -let isEs6ArrowType p = - Parser.lookahead p (fun state -> - match state.Parser.token with - | Lparen -> ( - Parser.next state; - match state.Parser.token with - | Rparen -> ( - Parser.next state; - match state.Parser.token with - | EqualGreater -> true - | _ -> false) - | Tilde | Dot -> true - | _ -> ( - goToClosing Rparen state; - match state.Parser.token with - | EqualGreater -> true - | _ -> false)) - | Tilde -> true - | _ -> false) - -let buildLongident words = - match List.rev words with - | [] -> assert false - | hd :: tl -> List.fold_left (fun p s -> Longident.Ldot (p, s)) (Lident hd) tl - -let makeInfixOperator (p : Parser.t) token startPos endPos = - let stringifiedToken = - if token = Token.MinusGreater then - if p.uncurried_config = Legacy then "|." else "|.u" - else if token = Token.PlusPlus then "^" - else if token = Token.BangEqual then "<>" - else if token = Token.BangEqualEqual then "!=" - else if token = Token.Equal then ( - (* TODO: could have a totally different meaning like x->fooSet(y)*) - Parser.err ~startPos ~endPos p - (Diagnostics.message "Did you mean `==` here?"); - "=") - else if token = Token.EqualEqual then "=" - else if token = Token.EqualEqualEqual then "==" - else Token.toString token - in - let loc = mkLoc startPos endPos in - let operator = Location.mkloc (Longident.Lident stringifiedToken) loc in - Ast_helper.Exp.ident ~loc operator - -let negateString s = - if String.length s > 0 && (s.[0] [@doesNotRaise]) = '-' then - (String.sub [@doesNotRaise]) s 1 (String.length s - 1) - else "-" ^ s - -let makeUnaryExpr startPos tokenEnd token operand = - match (token, operand.Parsetree.pexp_desc) with - | (Token.Plus | PlusDot), Pexp_constant (Pconst_integer _ | Pconst_float _) -> - operand - | Minus, Pexp_constant (Pconst_integer (n, m)) -> - { - operand with - pexp_desc = Pexp_constant (Pconst_integer (negateString n, m)); - } - | (Minus | MinusDot), Pexp_constant (Pconst_float (n, m)) -> - {operand with pexp_desc = Pexp_constant (Pconst_float (negateString n, m))} - | (Token.Plus | PlusDot | Minus | MinusDot), _ -> - let tokenLoc = mkLoc startPos tokenEnd in - let operator = "~" ^ Token.toString token in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident operator) tokenLoc)) - [(Nolabel, operand)] - | Token.Bang, _ -> - let tokenLoc = mkLoc startPos tokenEnd in - Ast_helper.Exp.apply - ~loc:(mkLoc startPos operand.Parsetree.pexp_loc.loc_end) - (Ast_helper.Exp.ident ~loc:tokenLoc - (Location.mkloc (Longident.Lident "not") tokenLoc)) - [(Nolabel, operand)] - | _ -> operand - -let makeListExpression loc seq extOpt = - let rec handleSeq = function - | [] -> ( - match extOpt with - | Some ext -> ext - | None -> - let loc = {loc with Location.loc_ghost = true} in - let nil = Location.mkloc (Longident.Lident "[]") loc in - Ast_helper.Exp.construct ~loc nil None) - | e1 :: el -> - let exp_el = handleSeq el in - let loc = - mkLoc e1.Parsetree.pexp_loc.Location.loc_start exp_el.pexp_loc.loc_end - in - let arg = Ast_helper.Exp.tuple ~loc [e1; exp_el] in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "::") loc) - (Some arg) - in - let expr = handleSeq seq in - {expr with pexp_loc = loc} - -let makeListPattern loc seq ext_opt = - let rec handle_seq = function - | [] -> - let base_case = - match ext_opt with - | Some ext -> ext - | None -> - let loc = {loc with Location.loc_ghost = true} in - let nil = {Location.txt = Longident.Lident "[]"; loc} in - Ast_helper.Pat.construct ~loc nil None - in - base_case - | p1 :: pl -> - let pat_pl = handle_seq pl in - let loc = mkLoc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in - let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in - Ast_helper.Pat.mk ~loc - (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) - in - handle_seq seq - -(* TODO: diagnostic reporting *) -let lidentOfPath longident = - match Longident.flatten longident |> List.rev with - | [] -> "" - | ident :: _ -> ident - -let makeNewtypes ~attrs ~loc newtypes exp = - let expr = - List.fold_right - (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) - newtypes exp - in - {expr with pexp_attributes = attrs} - -(* locally abstract types syntax sugar - * Transforms - * let f: type t u v. = (foo : list) => ... - * into - * let f = (type t u v. foo : list) => ... - *) -let wrapTypeAnnotation ~loc newtypes core_type body = - let exp = - makeNewtypes ~attrs:[] ~loc newtypes - (Ast_helper.Exp.constraint_ ~loc body core_type) - in - let typ = - Ast_helper.Typ.poly ~loc newtypes - (Ast_helper.Typ.varify_constructors newtypes core_type) - in - (exp, typ) - -(** - * process the occurrence of _ in the arguments of a function application - * replace _ with a new variable, currently __x, in the arguments - * return a wrapping function that wraps ((__x) => ...) around an expression - * e.g. foo(_, 3) becomes (__x) => foo(__x, 3) - *) -let processUnderscoreApplication (p : Parser.t) args = - let exp_question = ref None in - let hidden_var = "__x" in - let check_arg ((lab, exp) as arg) = - match exp.Parsetree.pexp_desc with - | Pexp_ident ({txt = Lident "_"} as id) -> - let new_id = Location.mkloc (Longident.Lident hidden_var) id.loc in - let new_exp = Ast_helper.Exp.mk (Pexp_ident new_id) ~loc:exp.pexp_loc in - exp_question := Some new_exp; - (lab, new_exp) - | _ -> arg - in - let args = List.map check_arg args in - let wrap (exp_apply : Parsetree.expression) = - match !exp_question with - | Some {pexp_loc = loc} -> - let pattern = - Ast_helper.Pat.mk - (Ppat_var (Location.mkloc hidden_var loc)) - ~loc:Location.none - in - let funExpr = Ast_helper.Exp.fun_ ~loc Nolabel None pattern exp_apply in - if p.uncurried_config = Legacy then funExpr - else Ast_uncurried.uncurriedFun ~loc ~arity:1 funExpr - | None -> exp_apply - in - (args, wrap) - -(* Transform A.a into a. For use with punned record fields as in {A.a, b}. *) -let removeModuleNameFromPunnedFieldValue exp = - match exp.Parsetree.pexp_desc with - | Pexp_ident pathIdent -> - { - exp with - pexp_desc = - Pexp_ident {pathIdent with txt = Lident (Longident.last pathIdent.txt)}; - } - | _ -> exp - -let rec parseLident p = - let recoverLident p = - if - Token.isKeyword p.Parser.token - && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum - then ( - Parser.err p (Diagnostics.lident p.Parser.token); - Parser.next p; - None) - else - let rec loop p = - if (not (Recover.shouldAbortListParse p)) && p.token <> Eof then ( - Parser.next p; - loop p) - in - Parser.err p (Diagnostics.lident p.Parser.token); - Parser.next p; - loop p; - match p.Parser.token with - | Lident _ -> Some () - | _ -> None - in - let startPos = p.Parser.startPos in - match p.Parser.token with - | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) - | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("_", mkLoc startPos p.prevEndPos) - | _ -> ( - match recoverLident p with - | Some () -> parseLident p - | None -> ("_", mkLoc startPos p.prevEndPos)) - -let parseIdent ~msg ~startPos p = - match p.Parser.token with - | Lident ident | Uident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - (ident, loc) - | token - when Token.isKeyword token && p.prevEndPos.pos_lnum == p.startPos.pos_lnum - -> - let tokenTxt = Token.toString token in - let msg = - "`" ^ tokenTxt - ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" ^ tokenTxt - ^ "\"" - in - Parser.err ~startPos p (Diagnostics.message msg); - Parser.next p; - (tokenTxt, mkLoc startPos p.prevEndPos) - | _token -> - Parser.err ~startPos p (Diagnostics.message msg); - Parser.next p; - ("", mkLoc startPos p.prevEndPos) - -let parseHashIdent ~startPos p = - Parser.expect Hash p; - match p.token with - | String text -> - Parser.next p; - (text, mkLoc startPos p.prevEndPos) - | Int {i; suffix} -> - let () = - match suffix with - | Some _ -> - Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () - in - Parser.next p; - (i, mkLoc startPos p.prevEndPos) - | Eof -> - Parser.err ~startPos p (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) - | _ -> parseIdent ~startPos ~msg:ErrorMessages.variantIdent p - -(* Ldot (Ldot (Lident "Foo", "Bar"), "baz") *) -let parseValuePath p = - let startPos = p.Parser.startPos in - let rec aux p path = - let startPos = p.Parser.startPos in - let token = p.token in - - Parser.next p; - if p.Parser.token = Dot then ( - Parser.expect Dot p; - - match p.Parser.token with - | Lident ident -> Longident.Ldot (path, ident) - | Uident uident -> aux p (Ldot (path, uident)) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Longident.Ldot (path, "_")) - else ( - Parser.err p ~startPos ~endPos:p.prevEndPos (Diagnostics.lident token); - path) - in - let ident = - match p.Parser.token with - | Lident ident -> - Parser.next p; - Longident.Lident ident - | Uident ident -> - let res = aux p (Lident ident) in - Parser.nextUnsafe p; - res - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parser.nextUnsafe p; - Longident.Lident "_" - in - Location.mkloc ident (mkLoc startPos p.prevEndPos) - -let parseValuePathAfterDot p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Lident _ | Uident _ -> parseValuePath p - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) - -let parseValuePathTail p startPos ident = - let rec loop p path = - match p.Parser.token with - | Lident ident -> - Parser.next p; - Location.mkloc - (Longident.Ldot (path, ident)) - (mkLoc startPos p.prevEndPos) - | Uident ident -> - Parser.next p; - Parser.expect Dot p; - loop p (Longident.Ldot (path, ident)) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Location.mkloc (Longident.Ldot (path, "_")) (mkLoc startPos p.prevEndPos) - in - loop p ident - -let parseModuleLongIdentTail ~lowercase p startPos ident = - let rec loop p acc = - match p.Parser.token with - | Lident ident when lowercase -> - Parser.next p; - let lident = Longident.Ldot (acc, ident) in - Location.mkloc lident (mkLoc startPos p.prevEndPos) - | Uident ident -> ( - Parser.next p; - let endPos = p.prevEndPos in - let lident = Longident.Ldot (acc, ident) in - match p.Parser.token with - | Dot -> - Parser.next p; - loop p lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) - | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Ldot (acc, "_")) (mkLoc startPos p.prevEndPos) - in - loop p ident - -(* Parses module identifiers: - Foo - Foo.Bar *) -let parseModuleLongIdent ~lowercase p = - (* Parser.leaveBreadcrumb p Reporting.ModuleLongIdent; *) - let startPos = p.Parser.startPos in - let moduleIdent = - match p.Parser.token with - | Lident ident when lowercase -> - let loc = mkLoc startPos p.endPos in - let lident = Longident.Lident ident in - Parser.next p; - Location.mkloc lident loc - | Uident ident -> ( - let lident = Longident.Lident ident in - let endPos = p.endPos in - Parser.next p; - match p.Parser.token with - | Dot -> - Parser.next p; - parseModuleLongIdentTail ~lowercase p startPos lident - | _ -> Location.mkloc lident (mkLoc startPos endPos)) - | t -> - Parser.err p (Diagnostics.uident t); - Location.mkloc (Longident.Lident "_") (mkLoc startPos p.prevEndPos) - in - (* Parser.eatBreadcrumb p; *) - moduleIdent - -let verifyJsxOpeningClosingName p nameExpr = - let closing = - match p.Parser.token with - | Lident lident -> - Parser.next p; - Longident.Lident lident - | Uident _ -> (parseModuleLongIdent ~lowercase:true p).txt - | _ -> Longident.Lident "" - in - match nameExpr.Parsetree.pexp_desc with - | Pexp_ident openingIdent -> - let opening = - let withoutCreateElement = - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") - in - match Longident.unflatten withoutCreateElement with - | Some li -> li - | None -> Longident.Lident "" - in - opening = closing - | _ -> assert false - -let string_of_pexp_ident nameExpr = - match nameExpr.Parsetree.pexp_desc with - | Pexp_ident openingIdent -> - Longident.flatten openingIdent.txt - |> List.filter (fun s -> s <> "createElement") - |> String.concat "." - | _ -> "" - -(* open-def ::= - * | open module-path - * | open! module-path *) -let parseOpenDescription ~attrs p = - Parser.leaveBreadcrumb p Grammar.OpenDescription; - let startPos = p.Parser.startPos in - Parser.expect Open p; - let override = - if Parser.optional p Token.Bang then Asttypes.Override else Asttypes.Fresh - in - let modident = parseModuleLongIdent ~lowercase:false p in - let loc = mkLoc startPos p.prevEndPos in - Parser.eatBreadcrumb p; - Ast_helper.Opn.mk ~loc ~attrs ~override modident - -(* constant ::= integer-literal *) -(* ∣ float-literal *) -(* ∣ string-literal *) -let parseConstant p = - let isNegative = - match p.Parser.token with - | Token.Minus -> - Parser.next p; - true - | Plus -> - Parser.next p; - false - | _ -> false - in - let constant = - match p.Parser.token with - | Int {i; suffix} -> - (* Only decimal literal is allowed for bigint *) - if suffix = Some 'n' && not (Bigint_utils.is_valid i) then - Parser.err p - (Diagnostics.message - "Invalid bigint literal. Only decimal literal is allowed for \ - bigint."); - let intTxt = if isNegative then "-" ^ i else i in - Parsetree.Pconst_integer (intTxt, suffix) - | Float {f; suffix} -> - let floatTxt = if isNegative then "-" ^ f else f in - Parsetree.Pconst_float (floatTxt, suffix) - | String s -> - Pconst_string (s, if p.mode = ParseForTypeChecker then Some "js" else None) - | Codepoint {c; original} -> - if p.mode = ParseForTypeChecker then Pconst_char c - else - (* Pconst_char char does not have enough information for formatting. - * When parsing for the printer, we encode the char contents as a string - * with a special prefix. *) - Pconst_string (original, Some "INTERNAL_RES_CHAR_CONTENTS") - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Pconst_string ("", None) - in - Parser.nextUnsafe p; - constant - -let parseTemplateConstant ~prefix (p : Parser.t) = - (* Arrived at the ` char *) - let startPos = p.startPos in - Parser.nextTemplateLiteralToken p; - match p.token with - | TemplateTail (txt, _) -> - Parser.next p; - Parsetree.Pconst_string (txt, prefix) - | _ -> - let rec skipTokens () = - if p.token <> Eof then ( - Parser.next p; - match p.token with - | Backtick -> - Parser.next p; - () - | _ -> skipTokens ()) - in - skipTokens (); - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.stringInterpolationInPattern); - Pconst_string ("", None) - -let parseCommaDelimitedRegion p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> ( - match p.Parser.token with - | Comma -> - Parser.next p; - loop (node :: nodes) - | token when token = closing || token = Eof -> List.rev (node :: nodes) - | _ when Grammar.isListElement grammar p.token -> - (* missing comma between nodes in the region and the current token - * looks like the start of something valid in the current region. - * Example: - * type student<'extraInfo> = { - * name: string, - * age: int - * otherInfo: 'extraInfo - * } - * There is a missing comma between `int` and `otherInfo`. - * `otherInfo` looks like a valid start of the record declaration. - * We report the error here and then continue parsing the region. - *) - Parser.expect Comma p; - loop (node :: nodes) - | _ -> - if - not - (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) - then Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node :: nodes)) - | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p - then List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - -let parseCommaDelimitedReversedList p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> ( - match p.Parser.token with - | Comma -> - Parser.next p; - loop (node :: nodes) - | token when token = closing || token = Eof -> node :: nodes - | _ when Grammar.isListElement grammar p.token -> - (* missing comma between nodes in the region and the current token - * looks like the start of something valid in the current region. - * Example: - * type student<'extraInfo> = { - * name: string, - * age: int - * otherInfo: 'extraInfo - * } - * There is a missing comma between `int` and `otherInfo`. - * `otherInfo` looks like a valid start of the record declaration. - * We report the error here and then continue parsing the region. - *) - Parser.expect Comma p; - loop (node :: nodes) - | _ -> - if - not - (p.token = Eof || p.token = closing - || Recover.shouldAbortListParse p) - then Parser.expect Comma p; - if p.token = Semicolon then Parser.next p; - loop (node :: nodes)) - | None -> - if p.token = Eof || p.token = closing || Recover.shouldAbortListParse p - then nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - -let parseDelimitedRegion p ~grammar ~closing ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> loop (node :: nodes) - | None -> - if - p.Parser.token = Token.Eof || p.token = closing - || Recover.shouldAbortListParse p - then List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - -let parseRegion p ~grammar ~f = - Parser.leaveBreadcrumb p grammar; - let rec loop nodes = - match f p with - | Some node -> loop (node :: nodes) - | None -> - if p.Parser.token = Token.Eof || Recover.shouldAbortListParse p then - List.rev nodes - else ( - Parser.err p (Diagnostics.unexpected p.token p.breadcrumbs); - Parser.next p; - loop nodes) - in - let nodes = loop [] in - Parser.eatBreadcrumb p; - nodes - -(* let-binding ::= pattern = expr *) -(* ∣ value-name { parameter } [: typexpr] [:> typexpr] = expr *) -(* ∣ value-name : poly-typexpr = expr *) - -(* pattern ::= value-name *) -(* ∣ _ *) -(* ∣ constant *) -(* ∣ pattern as value-name *) -(* ∣ ( pattern ) *) -(* ∣ ( pattern : typexpr ) *) -(* ∣ pattern | pattern *) -(* ∣ constr pattern *) -(* ∣ #variant variant-pattern *) -(* ∣ #...type *) -(* ∣ / pattern { , pattern }+ / *) -(* ∣ { field [: typexpr] [= pattern] { ; field [: typexpr] [= pattern] } [; _ ] [ ; ] } *) -(* ∣ [ pattern { ; pattern } [ ; ] ] *) -(* ∣ pattern :: pattern *) -(* ∣ [| pattern { ; pattern } [ ; ] |] *) -(* ∣ char-literal .. char-literal *) -(* ∣ exception pattern *) -let rec parsePattern ?(alias = true) ?(or_ = true) p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - let pat = - match p.Parser.token with - | (True | False) as token -> - let endPos = p.endPos in - Parser.next p; - let loc = mkLoc startPos endPos in - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) - None - | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( - let c = parseConstant p in - match p.token with - | DotDot -> - Parser.next p; - let c2 = parseConstant p in - Ast_helper.Pat.interval ~loc:(mkLoc startPos p.prevEndPos) c c2 - | _ -> Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) c) - | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some "js") p in - Ast_helper.Pat.constant ~attrs:[templateLiteralAttr] - ~loc:(mkLoc startPos p.prevEndPos) - constant - | Lparen -> ( - Parser.next p; - match p.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct ~loc lid None - | _ -> ( - let pat = parseConstrainedPattern p in - match p.token with - | Comma -> - Parser.next p; - parseTuplePattern ~attrs ~first:pat ~startPos p - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - { - pat with - ppat_loc = loc; - ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; - })) - | Lbracket -> parseArrayPattern ~attrs p - | Lbrace -> parseRecordPattern ~attrs p - | Underscore -> - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - Ast_helper.Pat.any ~loc ~attrs () - | Lident ident -> ( - let endPos = p.endPos in - let loc = mkLoc startPos endPos in - Parser.next p; - match p.token with - | Backtick -> - let constant = parseTemplateConstant ~prefix:(Some ident) p in - Ast_helper.Pat.constant ~loc:(mkLoc startPos p.prevEndPos) constant - | _ -> Ast_helper.Pat.var ~loc ~attrs (Location.mkloc ident loc)) - | Uident _ -> ( - let constr = parseModuleLongIdent ~lowercase:false p in - match p.Parser.token with - | Lparen -> parseConstructorPatternArgs p constr startPos attrs - | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) - | Hash -> ( - Parser.next p; - if p.Parser.token == DotDotDot then ( - Parser.next p; - let ident = parseValuePath p in - let loc = mkLoc startPos ident.loc.loc_end in - Ast_helper.Pat.type_ ~loc ~attrs ident) - else - let ident, loc = - match p.token with - | String text -> - Parser.next p; - (text, mkLoc startPos p.prevEndPos) - | Int {i; suffix} -> - let () = - match suffix with - | Some _ -> - Parser.err p - (Diagnostics.message (ErrorMessages.polyVarIntWithSuffix i)) - | None -> () - in - Parser.next p; - (i, mkLoc startPos p.prevEndPos) - | Eof -> - Parser.err ~startPos p - (Diagnostics.unexpected p.token p.breadcrumbs); - ("", mkLoc startPos p.prevEndPos) - | _ -> parseIdent ~msg:ErrorMessages.variantIdent ~startPos p - in - match p.Parser.token with - | Lparen -> parseVariantPatternArgs p ident startPos attrs - | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) - | Exception -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.exception_ ~loc ~attrs pat - | Lazy -> - Parser.next p; - let pat = parsePattern ~alias:false ~or_:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.lazy_ ~loc ~attrs pat - | List -> - Parser.next p; - parseListPattern ~startPos ~attrs p - | Module -> parseModulePattern ~attrs p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.extension ~loc ~attrs extension - | Eof -> - Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultPattern () - | token -> ( - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicPatternStart - with - | None -> Recover.defaultPattern () - | Some () -> parsePattern p) - in - let pat = if alias then parseAliasPattern ~attrs pat p else pat in - if or_ then parseOrPattern pat p else pat - -and skipTokensAndMaybeRetry p ~isStartOfGrammar = - if - Token.isKeyword p.Parser.token - && p.Parser.prevEndPos.pos_lnum == p.startPos.pos_lnum - then ( - Parser.next p; - None) - else if Recover.shouldAbortListParse p then - if isStartOfGrammar p.Parser.token then ( - Parser.next p; - Some ()) - else None - else ( - Parser.next p; - let rec loop p = - if not (Recover.shouldAbortListParse p) then ( - Parser.next p; - loop p) - in - loop p; - if isStartOfGrammar p.Parser.token then Some () else None) - -(* alias ::= pattern as lident *) -and parseAliasPattern ~attrs pattern p = - match p.Parser.token with - | As -> - Parser.next p; - let name, loc = parseLident p in - let name = Location.mkloc name loc in - Ast_helper.Pat.alias - ~loc:{pattern.ppat_loc with loc_end = p.prevEndPos} - ~attrs pattern name - | _ -> pattern - -(* or ::= pattern | pattern - * precedence: Red | Blue | Green is interpreted as (Red | Blue) | Green *) -and parseOrPattern pattern1 p = - let rec loop pattern1 = - match p.Parser.token with - | Bar -> - Parser.next p; - let pattern2 = parsePattern ~or_:false p in - let loc = - {pattern1.Parsetree.ppat_loc with loc_end = pattern2.ppat_loc.loc_end} - in - loop (Ast_helper.Pat.or_ ~loc pattern1 pattern2) - | _ -> pattern1 - in - loop pattern1 - -and parseNonSpreadPattern ~msg p = - let () = - match p.Parser.token with - | DotDotDot -> - Parser.err p (Diagnostics.message msg); - Parser.next p - | _ -> () - in - match p.Parser.token with - | token when Grammar.isPatternStart token -> ( - let pat = parsePattern p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Some (Ast_helper.Pat.constraint_ ~loc pat typ) - | _ -> Some pat) - | _ -> None - -and parseConstrainedPattern p = - let pat = parsePattern p in - match p.Parser.token with - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc pat.ppat_loc.loc_start typ.Parsetree.ptyp_loc.loc_end in - Ast_helper.Pat.constraint_ ~loc pat typ - | _ -> pat - -and parseConstrainedPatternRegion p = - match p.Parser.token with - | token when Grammar.isPatternStart token -> Some (parseConstrainedPattern p) - | _ -> None - -and parseOptionalLabel p = - match p.Parser.token with - | Question -> - Parser.next p; - true - | _ -> false - -(* field ::= - * | longident - * | longident : pattern - * | longident as lident - * - * row ::= - * | field , - * | field , _ - * | field , _, - *) -and parseRecordPatternRowField ~attrs p = - let label = parseValuePath p in - let pattern = - match p.Parser.token with - | Colon -> - Parser.next p; - let optional = parseOptionalLabel p in - let pat = parsePattern p in - makePatternOptional ~optional pat - | _ -> - Ast_helper.Pat.var ~loc:label.loc ~attrs - (Location.mkloc (Longident.last label.txt) label.loc) - in - (label, pattern) - -(* TODO: there are better representations than PatField|Underscore ? *) -and parseRecordPatternRow p = - let attrs = parseAttributes p in - match p.Parser.token with - | DotDotDot -> - Parser.next p; - Some (true, PatField (parseRecordPatternRowField ~attrs p)) - | Uident _ | Lident _ -> - Some (false, PatField (parseRecordPatternRowField ~attrs p)) - | Question -> ( - Parser.next p; - match p.token with - | Uident _ | Lident _ -> - let lid, pat = parseRecordPatternRowField ~attrs p in - Some (false, PatField (lid, makePatternOptional ~optional:true pat)) - | _ -> None) - | Underscore -> - Parser.next p; - Some (false, PatUnderscore) - | _ -> None - -and parseRecordPattern ~attrs p = - let startPos = p.startPos in - Parser.expect Lbrace p; - let rawFields = - parseCommaDelimitedReversedList p ~grammar:PatternRecord ~closing:Rbrace - ~f:parseRecordPatternRow - in - Parser.expect Rbrace p; - let fields, closedFlag = - let rawFields, flag = - match rawFields with - | (_hasSpread, PatUnderscore) :: rest -> (rest, Asttypes.Open) - | rawFields -> (rawFields, Asttypes.Closed) - in - List.fold_left - (fun (fields, flag) curr -> - let hasSpread, field = curr in - match field with - | PatField field -> - (if hasSpread then - let _, pattern = field in - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.recordPatternSpread)); - (field :: fields, flag) - | PatUnderscore -> (fields, flag)) - ([], flag) rawFields - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.record ~loc ~attrs fields closedFlag - -and parseTuplePattern ~attrs ~first ~startPos p = - let patterns = - first - :: parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen - ~f:parseConstrainedPatternRegion - in - Parser.expect Rparen p; - let () = - match patterns with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) - | _ -> () - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.tuple ~loc ~attrs patterns - -and parsePatternRegion p = - match p.Parser.token with - | DotDotDot -> - Parser.next p; - Some (true, parseConstrainedPattern p) - | token when Grammar.isPatternStart token -> - Some (false, parseConstrainedPattern p) - | _ -> None - -and parseModulePattern ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Module p; - Parser.expect Lparen p; - let uident = - match p.token with - | Uident uident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc uident loc - | _ -> - (* TODO: error recovery *) - Location.mknoloc "_" - in - match p.token with - | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let packageTypAttrs = parseAttributes p in - let packageType = - parsePackageType ~startPos:colonStart ~attrs:packageTypAttrs p - in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let unpack = Ast_helper.Pat.unpack ~loc:uident.loc uident in - Ast_helper.Pat.constraint_ ~loc ~attrs unpack packageType - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.unpack ~loc ~attrs uident - -and parseListPattern ~startPos ~attrs p = - let listPatterns = - parseCommaDelimitedReversedList p ~grammar:Grammar.PatternOcamlList - ~closing:Rbrace ~f:parsePatternRegion - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let filterSpread (hasSpread, pattern) = - if hasSpread then ( - Parser.err ~startPos:pattern.Parsetree.ppat_loc.loc_start p - (Diagnostics.message ErrorMessages.listPatternSpread); - pattern) - else pattern - in - match listPatterns with - | (true, pattern) :: patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns (Some pattern) in - {pat with ppat_loc = loc; ppat_attributes = attrs} - | patterns -> - let patterns = patterns |> List.map filterSpread |> List.rev in - let pat = makeListPattern loc patterns None in - {pat with ppat_loc = loc; ppat_attributes = attrs} - -and parseArrayPattern ~attrs p = - let startPos = p.startPos in - Parser.expect Lbracket p; - let patterns = - parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rbracket - ~f:(parseNonSpreadPattern ~msg:ErrorMessages.arrayPatternSpread) - in - Parser.expect Rbracket p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.array ~loc ~attrs patterns - -and parseConstructorPatternArgs p constr startPos attrs = - let lparen = p.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen - ~f:parseConstrainedPatternRegion - in - Parser.expect Rparen p; - let args = - match args with - | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some pat - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern - | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - in - Ast_helper.Pat.construct ~loc:(mkLoc startPos p.prevEndPos) ~attrs constr args - -and parseVariantPatternArgs p ident startPos attrs = - let lparen = p.startPos in - Parser.expect Lparen p; - let patterns = - parseCommaDelimitedRegion p ~grammar:Grammar.PatternList ~closing:Rparen - ~f:parseConstrainedPatternRegion - in - let args = - match patterns with - | [] -> - let loc = mkLoc lparen p.prevEndPos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* #ident(1, 2) for type-checker *) - Some pat - else - (* #ident((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - | [pattern] -> Some pattern - | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mkLoc lparen p.endPos) patterns) - in - Parser.expect Rparen p; - Ast_helper.Pat.variant ~loc:(mkLoc startPos p.prevEndPos) ~attrs ident args - -and parseExpr ?(context = OrdinaryExpr) p = - let expr = parseOperandExpr ~context p in - let expr = parseBinaryExpr ~context ~a:expr p 1 in - parseTernaryExpr expr p - -(* expr ? expr : expr *) -and parseTernaryExpr leftOperand p = - match p.Parser.token with - | Question -> - Parser.leaveBreadcrumb p Grammar.Ternary; - Parser.next p; - let trueBranch = parseExpr ~context:TernaryTrueBranchExpr p in - Parser.expect Colon p; - let falseBranch = parseExpr p in - Parser.eatBreadcrumb p; - let loc = - { - leftOperand.Parsetree.pexp_loc with - loc_start = leftOperand.pexp_loc.loc_start; - loc_end = falseBranch.Parsetree.pexp_loc.loc_end; - } - in - Ast_helper.Exp.ifthenelse ~attrs:[ternaryAttr] ~loc leftOperand trueBranch - (Some falseBranch) - | _ -> leftOperand - -and parseEs6ArrowExpression ?(arrowAttrs = []) ?(arrowStartPos = None) ?context - ?parameters p = - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.Es6ArrowExpr; - (* Parsing function parameters and attributes: - 1. Basically, attributes outside of `(...)` are added to the function, except - the uncurried attribute `(.)` is added to the function. e.g. async, uncurried - - 2. Attributes inside `(...)` are added to the arguments regardless of whether - labeled, optional or nolabeled *) - let parameters = - match parameters with - | Some params -> params - | None -> parseParameters p - in - let parameters = - let updateAttrs attrs = arrowAttrs @ attrs in - let updatePos pos = - match arrowStartPos with - | Some startPos -> startPos - | None -> pos - in - match parameters with - | TermParameter p :: rest -> - TermParameter {p with attrs = updateAttrs p.attrs; pos = updatePos p.pos} - :: rest - | TypeParameter p :: rest -> - TypeParameter {p with attrs = updateAttrs p.attrs; pos = updatePos p.pos} - :: rest - | [] -> parameters - in - let parameters = - (* Propagate any dots from type parameters to the first term *) - let rec loop ~dotInType params = - match params with - | (TypeParameter {dotted} as p) :: _ -> - let rest = LoopProgress.listRest params in - (* Tell termination checker about progress *) - p :: loop ~dotInType:(dotInType || dotted) rest - | TermParameter termParam :: rest -> - TermParameter {termParam with dotted = dotInType || termParam.dotted} - :: rest - | [] -> [] - in - loop ~dotInType:false parameters - in - let returnType = - match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseTypExpr ~es6Arrow:false p) - | _ -> None - in - Parser.expect EqualGreater p; - let body = - let expr = parseExpr ?context p in - match returnType with - | Some typ -> - Ast_helper.Exp.constraint_ - ~loc:(mkLoc expr.pexp_loc.loc_start typ.Parsetree.ptyp_loc.loc_end) - expr typ - | None -> expr - in - Parser.eatBreadcrumb p; - let endPos = p.prevEndPos in - let termParameters = - parameters - |> List.filter (function - | TermParameter _ -> true - | TypeParameter _ -> false) - in - let bodyNeedsBraces = - let isFun = - match body.pexp_desc with - | Pexp_fun _ -> true - | _ -> false - in - match termParameters with - | TermParameter {dotted} :: _ - when p.uncurried_config |> Res_uncurried.fromDotted ~dotted && isFun -> - true - | TermParameter _ :: rest when p.uncurried_config = Legacy && isFun -> - rest - |> List.exists (function - | TermParameter {dotted} -> dotted - | _ -> false) - | _ -> false - in - let body = - if bodyNeedsBraces then - { - body with - pexp_attributes = makeBracesAttr body.pexp_loc :: body.pexp_attributes; - } - else body - in - let _paramNum, arrowExpr, _arity = - List.fold_right - (fun parameter (termParamNum, expr, arity) -> - match parameter with - | TermParameter - { - dotted; - attrs; - label = lbl; - expr = defaultExpr; - pat; - pos = startPos; - } -> - let loc = mkLoc startPos endPos in - let funExpr = - Ast_helper.Exp.fun_ ~loc ~attrs lbl defaultExpr pat expr - in - let uncurried = - p.uncurried_config |> Res_uncurried.fromDotted ~dotted - in - if uncurried && (termParamNum = 1 || p.uncurried_config = Legacy) then - (termParamNum - 1, Ast_uncurried.uncurriedFun ~loc ~arity funExpr, 1) - else (termParamNum - 1, funExpr, arity + 1) - | TypeParameter {dotted = _; attrs; locs = newtypes; pos = startPos} -> - ( termParamNum, - makeNewtypes ~attrs ~loc:(mkLoc startPos endPos) newtypes expr, - arity )) - parameters - (List.length termParameters, body, 1) - in - {arrowExpr with pexp_loc = {arrowExpr.pexp_loc with loc_start = startPos}} - -(* - * dotted_parameter ::= - * | . parameter - * - * parameter ::= - * | pattern - * | pattern : type - * | ~ labelName - * | ~ labelName as pattern - * | ~ labelName as pattern : type - * | ~ labelName = expr - * | ~ labelName as pattern = expr - * | ~ labelName as pattern : type = expr - * | ~ labelName = ? - * | ~ labelName as pattern = ? - * | ~ labelName as pattern : type = ? - * - * labelName ::= lident - *) -and parseParameter p = - if - p.Parser.token = Token.Typ || p.token = Tilde || p.token = Dot - || Grammar.isPatternStart p.token - then - let startPos = p.Parser.startPos in - let dotted = Parser.optional p Token.Dot in - let attrs = parseAttributes p in - if p.Parser.token = Typ then ( - Parser.next p; - let lidents = parseLidentList p in - Some (TypeParameter {dotted; attrs; locs = lidents; pos = startPos})) - else - let attrs, lbl, pat = - match p.Parser.token with - | Tilde -> ( - Parser.next p; - let lblName, loc = parseLident p in - let propLocAttr = - (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) - in - match p.Parser.token with - | Comma | Equal | Rparen -> - let loc = mkLoc startPos p.prevEndPos in - ( [], - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:(propLocAttr :: attrs) ~loc - (Location.mkloc lblName loc) ) - | Colon -> - let lblEnd = p.prevEndPos in - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos lblEnd in - let pat = - let pat = Ast_helper.Pat.var ~loc (Location.mkloc lblName loc) in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Pat.constraint_ ~attrs:(propLocAttr :: attrs) ~loc pat - typ - in - ([], Asttypes.Labelled lblName, pat) - | As -> - Parser.next p; - let pat = - let pat = parseConstrainedPattern p in - { - pat with - ppat_attributes = (propLocAttr :: attrs) @ pat.ppat_attributes; - } - in - ([], Asttypes.Labelled lblName, pat) - | t -> - Parser.err p (Diagnostics.unexpected t p.breadcrumbs); - let loc = mkLoc startPos p.prevEndPos in - ( [], - Asttypes.Labelled lblName, - Ast_helper.Pat.var ~attrs:(propLocAttr :: attrs) ~loc - (Location.mkloc lblName loc) )) - | _ -> - let pattern = parseConstrainedPattern p in - let attrs = List.concat [pattern.ppat_attributes; attrs] in - ([], Asttypes.Nolabel, {pattern with ppat_attributes = attrs}) - in - match p.Parser.token with - | Equal -> ( - Parser.next p; - let lbl = - match lbl with - | Asttypes.Labelled lblName -> Asttypes.Optional lblName - | Asttypes.Nolabel -> - let lblName = - match pat.ppat_desc with - | Ppat_var var -> var.txt - | _ -> "" - in - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter lblName)); - Asttypes.Optional lblName - | lbl -> lbl - in - match p.Parser.token with - | Question -> - Parser.next p; - Some - (TermParameter - {dotted; attrs; label = lbl; expr = None; pat; pos = startPos}) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in - Some - (TermParameter - { - dotted; - attrs; - label = lbl; - expr = Some expr; - pat; - pos = startPos; - })) - | _ -> - Some - (TermParameter - {dotted; attrs; label = lbl; expr = None; pat; pos = startPos}) - else None - -and parseParameterList p = - let parameters = - parseCommaDelimitedRegion ~grammar:Grammar.ParameterList ~f:parseParameter - ~closing:Rparen p - in - Parser.expect Rparen p; - parameters - -(* parameters ::= - * | _ - * | lident - * | () - * | (.) - * | ( parameter {, parameter} [,] ) - *) -and parseParameters p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [ - TermParameter - { - dotted = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); - pos = startPos; - }; - ] - | Underscore -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - [ - TermParameter - { - dotted = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.any ~loc (); - pos = startPos; - }; - ] - | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - [ - TermParameter - { - dotted = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = unitPattern; - pos = startPos; - }; - ] - | Dot -> ( - Parser.next p; - match p.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.Parser.prevEndPos in - let unitPattern = - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - [ - TermParameter - { - dotted = true; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = unitPattern; - pos = startPos; - }; - ] - | _ -> ( - match parseParameterList p with - | TermParameter p :: rest -> - TermParameter {p with dotted = true; pos = startPos} :: rest - | TypeParameter p :: rest -> - TypeParameter {p with dotted = true; pos = startPos} :: rest - | parameters -> parameters)) - | _ -> parseParameterList p) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - [] - -and parseCoercedExpr ~(expr : Parsetree.expression) p = - Parser.expect ColonGreaterThan p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start p.prevEndPos in - Ast_helper.Exp.coerce ~loc expr None typ - -and parseConstrainedOrCoercedExpr p = - let expr = parseExpr p in - match p.Parser.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p - | Colon -> ( - Parser.next p; - match p.token with - | _ -> ( - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - match p.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p - | _ -> expr)) - | _ -> expr - -and parseConstrainedExprRegion p = - match p.Parser.token with - | token when Grammar.isExprStart token -> ( - let expr = parseExpr p in - match p.Parser.token with - | ColonGreaterThan -> Some (parseCoercedExpr ~expr p) - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - Some (Ast_helper.Exp.constraint_ ~loc expr typ) - | _ -> Some expr) - | _ -> None - -(* Atomic expressions represent unambiguous expressions. - * This means that regardless of the context, these expressions - * are always interpreted correctly. *) -and parseAtomicExpr p = - Parser.leaveBreadcrumb p Grammar.ExprOperand; - let startPos = p.Parser.startPos in - let expr = - match p.Parser.token with - | (True | False) as token -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident (Token.toString token)) loc) - None - | Int _ | String _ | Float _ | Codepoint _ -> - let c = parseConstant p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constant ~loc c - | Backtick -> - let expr = parseTemplateExpr p in - {expr with pexp_loc = mkLoc startPos p.prevEndPos} - | Uident _ | Lident _ -> parseValueOrConstructor p - | Hash -> parsePolyVariantExpr p - | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - | _t -> ( - let expr = parseConstrainedOrCoercedExpr p in - match p.token with - | Comma -> - Parser.next p; - parseTupleExpr ~startPos ~first:expr p - | _ -> - Parser.expect Rparen p; - expr - (* {expr with pexp_loc = mkLoc startPos p.prevEndPos} - * What does this location mean here? It means that when there's - * a parenthesized we keep the location here for whitespace interleaving. - * Without the closing paren in the location there will always be an extra - * line. For now we don't include it, because it does weird things - * with for comments. *))) - | List -> - Parser.next p; - parseListExpr ~startPos p - | Module -> - Parser.next p; - parseFirstClassModuleExpr ~startPos p - | Lbracket -> parseArrayExp p - | Lbrace -> parseBracedOrRecordExpr p - | LessThan -> parseJsx p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.extension ~loc extension - | Underscore as token -> - (* This case is for error recovery. Not sure if it's the correct place *) - Parser.err p (Diagnostics.lident token); - Parser.next p; - Recover.defaultExpr () - | Eof -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultExpr () - | token -> ( - let errPos = p.prevEndPos in - Parser.err ~startPos:errPos p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicExprStart - with - | None -> Recover.defaultExpr () - | Some () -> parseAtomicExpr p) - in - Parser.eatBreadcrumb p; - expr - -(* module(module-expr) - * module(module-expr : package-type) *) -and parseFirstClassModuleExpr ~startPos p = - Parser.expect Lparen p; - - let modExpr = parseModuleExpr p in - let modEndLoc = p.prevEndPos in - match p.Parser.token with - | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos modEndLoc in - let firstClassModule = Ast_helper.Exp.pack ~loc modExpr in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.constraint_ ~loc firstClassModule packageType - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.pack ~loc modExpr - -and parseBracketAccess p expr startPos = - Parser.leaveBreadcrumb p Grammar.ExprArrayAccess; - let lbracket = p.startPos in - Parser.expect Lbracket p; - let stringStart = p.startPos in - match p.Parser.token with - | String s -> ( - Parser.next p; - let stringEnd = p.prevEndPos in - Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in - let e = - let identLoc = mkLoc stringStart stringEnd in - let loc = mkLoc startPos rbracket in - Ast_helper.Exp.send ~loc expr (Location.mkloc s identLoc) - in - let e = parsePrimaryExpr ~operand:e p in - let equalStart = p.startPos in - match p.token with - | Equal -> - Parser.next p; - let equalEnd = p.prevEndPos in - let rhsExpr = parseExpr p in - let loc = mkLoc startPos rhsExpr.pexp_loc.loc_end in - let operatorLoc = mkLoc equalStart equalEnd in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc:operatorLoc - (Location.mkloc (Longident.Lident "#=") operatorLoc)) - [(Nolabel, e); (Nolabel, rhsExpr)] - | _ -> e) - | _ -> ( - let accessExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Rbracket p; - Parser.eatBreadcrumb p; - let rbracket = p.prevEndPos in - let arrayLoc = mkLoc lbracket rbracket in - match p.token with - | Equal -> - Parser.leaveBreadcrumb p ExprArrayMutation; - Parser.next p; - let rhsExpr = parseExpr p in - let arraySet = - Location.mkloc (Longident.Ldot (Lident "Array", "set")) arrayLoc - in - let endPos = p.prevEndPos in - let arraySet = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc arraySet) - [(Nolabel, expr); (Nolabel, accessExpr); (Nolabel, rhsExpr)] - in - Parser.eatBreadcrumb p; - arraySet - | _ -> - let endPos = p.prevEndPos in - let e = - Ast_helper.Exp.apply ~loc:(mkLoc startPos endPos) - (Ast_helper.Exp.ident ~loc:arrayLoc - (Location.mkloc (Longident.Ldot (Lident "Array", "get")) arrayLoc)) - [(Nolabel, expr); (Nolabel, accessExpr)] - in - parsePrimaryExpr ~operand:e p) - -(* * A primary expression represents - * - atomic-expr - * - john.age - * - array[0] - * - applyFunctionTo(arg1, arg2) - * - * The "operand" represents the expression that is operated on - *) -and parsePrimaryExpr ~operand ?(noCall = false) p = - let startPos = operand.pexp_loc.loc_start in - let rec loop p expr = - match p.Parser.token with - | Dot -> ( - Parser.next p; - let lident = parseValuePathAfterDot p in - match p.Parser.token with - | Equal when noCall = false -> - Parser.leaveBreadcrumb p Grammar.ExprSetField; - Parser.next p; - let targetExpr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let setfield = Ast_helper.Exp.setfield ~loc expr lident targetExpr in - Parser.eatBreadcrumb p; - setfield - | _ -> - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - loop p (Ast_helper.Exp.field ~loc expr lident)) - | Lbracket - when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - parseBracketAccess p expr startPos - | Lparen when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum - -> - loop p (parseCallExpr p expr) - | Backtick - when noCall = false && p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> ( - match expr.pexp_desc with - | Pexp_ident long_ident -> parseTemplateExpr ~prefix:long_ident p - | _ -> - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:expr.pexp_loc.loc_end p - (Diagnostics.message - "Tagged template literals are currently restricted to names like: \ - json`null`."); - parseTemplateExpr p) - | _ -> expr - in - loop p operand - -(* a unary expression is an expression with only one operand and - * unary operator. Examples: - * -1 - * !condition - * -. 1.6 - *) -and parseUnaryExpr p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | (Minus | MinusDot | Plus | PlusDot | Bang) as token -> - Parser.leaveBreadcrumb p Grammar.ExprUnary; - let tokenEnd = p.endPos in - Parser.next p; - let operand = parseUnaryExpr p in - let unaryExpr = makeUnaryExpr startPos tokenEnd token operand in - Parser.eatBreadcrumb p; - unaryExpr - | _ -> parsePrimaryExpr ~operand:(parseAtomicExpr p) p - -(* Represents an "operand" in a binary expression. - * If you have `a + b`, `a` and `b` both represent - * the operands of the binary expression with opeartor `+` *) -and parseOperandExpr ~context p = - let startPos = p.Parser.startPos in - let attrs = ref (parseAttributes p) in - let expr = - match p.Parser.token with - | Assert -> - Parser.next p; - let expr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.assert_ ~loc expr - | Lident "async" - (* we need to be careful when we're in a ternary true branch: - `condition ? ternary-true-branch : false-branch` - Arrow expressions could be of the form: `async (): int => stuff()` - But if we're in a ternary, the `:` of the ternary takes precedence - *) - when isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p - -> - let arrowAttrs = !attrs in - let () = attrs := [] in - parseAsyncArrowExpression ~arrowAttrs p - | Await -> parseAwaitExpression p - | Lazy -> - Parser.next p; - let expr = parseUnaryExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.lazy_ ~loc expr - | Try -> parseTryExpression p - | If -> parseIfOrIfLetExpression p - | For -> parseForExpression p - | While -> parseWhileExpression p - | Switch -> parseSwitchExpression p - | _ -> - if - context != WhenExpr - && isEs6ArrowExpression ~inTernary:(context = TernaryTrueBranchExpr) p - then - let arrowAttrs = !attrs in - let () = attrs := [] in - parseEs6ArrowExpression ~arrowAttrs ~context p - else parseUnaryExpr p - in - (* let endPos = p.Parser.prevEndPos in *) - { - expr with - pexp_attributes = List.concat [expr.Parsetree.pexp_attributes; !attrs]; - (* pexp_loc = mkLoc startPos endPos *) - } - -(* a binary expression is an expression that combines two expressions with an - * operator. Examples: - * a + b - * f(x) |> g(y) - *) -and parseBinaryExpr ?(context = OrdinaryExpr) ?a p prec = - let a = - match a with - | Some e -> e - | None -> parseOperandExpr ~context p - in - let rec loop a = - let token = p.Parser.token in - let tokenPrec = - match token with - (* Can the minus be interpreted as a binary operator? Or is it a unary? - * let w = { - * x - * -10 - * } - * vs - * let w = { - * width - * - gap - * } - * - * First case is unary, second is a binary operator. - * See Scanner.isBinaryOp *) - | (Minus | MinusDot | LessThan) - when (not - (Scanner.isBinaryOp p.scanner.src p.startPos.pos_cnum - p.endPos.pos_cnum)) - && p.startPos.pos_lnum > p.prevEndPos.pos_lnum -> - -1 - | token -> Token.precedence token - in - if tokenPrec < prec then a - else ( - Parser.leaveBreadcrumb p (Grammar.ExprBinaryAfterOp token); - let startPos = p.startPos in - Parser.next p; - let endPos = p.prevEndPos in - let tokenPrec = - (* exponentiation operator is right-associative *) - if token = Exponentiation then tokenPrec else tokenPrec + 1 - in - let b = parseBinaryExpr ~context p tokenPrec in - let loc = mkLoc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in - let expr = - match (token, b.pexp_desc) with - | BarGreater, Pexp_apply (funExpr, args) - when p.uncurried_config = Uncurried -> - {b with pexp_desc = Pexp_apply (funExpr, args @ [(Nolabel, a)])} - | BarGreater, _ when p.uncurried_config = Uncurried -> - Ast_helper.Exp.apply ~loc b [(Nolabel, a)] - | _ -> - Ast_helper.Exp.apply ~loc - (makeInfixOperator p token startPos endPos) - [(Nolabel, a); (Nolabel, b)] - in - Parser.eatBreadcrumb p; - loop expr) - in - loop a - -(* If we even need this, determines if < might be the start of jsx. Not 100% complete *) -(* and isStartOfJsx p = *) -(* Parser.lookahead p (fun p -> *) -(* match p.Parser.token with *) -(* | LessThan -> *) -(* Parser.next p; *) -(* begin match p.token with *) -(* | GreaterThan (* <> *) -> true *) -(* | Lident _ | Uident _ | List -> *) -(* ignore (parseJsxName p); *) -(* begin match p.token with *) -(* | GreaterThan (*
*) -> true *) -(* | Question (* true *) -(* | Lident _ | List -> *) -(* Parser.next p; *) -(* begin match p.token with *) -(* | Equal (* true *) -(* | _ -> false (* TODO *) *) -(* end *) -(* | Forwardslash (* *) -(* Parser.next p; *) -(* begin match p.token with *) -(* | GreaterThan (* *) -> true *) -(* | _ -> false *) -(* end *) -(* | _ -> *) -(* false *) -(* end *) -(* | _ -> false *) -(* end *) -(* | _ -> false *) -(* ) *) - -and parseTemplateExpr ?prefix p = - let partPrefix = - (* we could stop treating js and j prefix as something special - for json, we would first need to remove @as(json`true`) feature *) - match prefix with - | Some {txt = Longident.Lident (("js" | "j" | "json") as prefix); _} -> - Some prefix - | _ -> Some "js" - in - - let parseParts p = - let rec aux acc = - let startPos = p.Parser.startPos in - Parser.nextTemplateLiteralToken p; - match p.token with - | TemplateTail (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, partPrefix)) - in - List.rev ((str, None) :: acc) - | TemplatePart (txt, lastPos) -> - Parser.next p; - let loc = mkLoc startPos lastPos in - let expr = parseExprBlock p in - let str = - Ast_helper.Exp.constant ~attrs:[templateLiteralAttr] ~loc - (Pconst_string (txt, partPrefix)) - in - aux ((str, Some expr) :: acc) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - [] - in - aux [] - in - let parts = parseParts p in - let strings = List.map fst parts in - let values = Ext_list.filter_map parts snd in - - let genTaggedTemplateCall (lident_loc : Longident.t Location.loc) = - let ident = Ast_helper.Exp.ident ~attrs:[] ~loc:lident_loc.loc lident_loc in - let strings_array = - Ast_helper.Exp.array ~attrs:[] ~loc:Location.none strings - in - let values_array = - Ast_helper.Exp.array ~attrs:[] ~loc:Location.none values - in - Ast_helper.Exp.apply - ~attrs:[taggedTemplateLiteralAttr] - ~loc:lident_loc.loc ident - [(Nolabel, strings_array); (Nolabel, values_array)] - in - - let hiddenOperator = - let op = Location.mknoloc (Longident.Lident "^") in - Ast_helper.Exp.ident op - in - let concat (e1 : Parsetree.expression) (e2 : Parsetree.expression) = - let loc = mkLoc e1.pexp_loc.loc_start e2.pexp_loc.loc_end in - Ast_helper.Exp.apply ~attrs:[templateLiteralAttr] ~loc hiddenOperator - [(Nolabel, e1); (Nolabel, e2)] - in - let genInterpolatedString () = - let subparts = - List.flatten - (List.map - (fun part -> - match part with - | s, Some v -> [s; v] - | s, None -> [s]) - parts) - in - let exprOption = - List.fold_left - (fun acc subpart -> - Some - (match acc with - | Some expr -> concat expr subpart - | None -> subpart)) - None subparts - in - match exprOption with - | Some expr -> expr - | None -> Ast_helper.Exp.constant (Pconst_string ("", None)) - in - - match prefix with - | Some {txt = Longident.Lident ("js" | "j" | "json"); _} | None -> - genInterpolatedString () - | Some lident_loc -> genTaggedTemplateCall lident_loc - -(* Overparse: let f = a : int => a + 1, is it (a : int) => or (a): int => - * Also overparse constraints: - * let x = { - * let a = 1 - * a + pi: int - * } - * - * We want to give a nice error message in these cases - * *) -and overParseConstrainedOrCoercedOrArrowExpression p expr = - match p.Parser.token with - | ColonGreaterThan -> parseCoercedExpr ~expr p - | Colon -> ( - Parser.next p; - let typ = parseTypExpr ~es6Arrow:false p in - match p.Parser.token with - | EqualGreater -> - Parser.next p; - let body = parseExpr p in - let pat = - match expr.pexp_desc with - | Pexp_ident longident -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc - (Longident.flatten longident.txt |> String.concat ".") - longident.loc) - (* TODO: can we convert more expressions to patterns?*) - | _ -> - Ast_helper.Pat.var ~loc:expr.pexp_loc - (Location.mkloc "pattern" expr.pexp_loc) - in - let arrow1 = - Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel None pat - (Ast_helper.Exp.constraint_ body typ) - in - let arrow2 = - Ast_helper.Exp.fun_ - ~loc:(mkLoc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - Asttypes.Nolabel None - (Ast_helper.Pat.constraint_ pat typ) - body - in - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text - "Did you mean to annotate the parameter type or the return \ - type?"; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.text "1) "; - ResPrinter.printExpression arrow1 CommentTable.empty; - Doc.line; - Doc.text "2) "; - ResPrinter.printExpression arrow2 CommentTable.empty; - ]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:expr.pexp_loc.loc_start ~endPos:body.pexp_loc.loc_end - p (Diagnostics.message msg); - arrow1 - | _ -> - let loc = mkLoc expr.pexp_loc.loc_start typ.ptyp_loc.loc_end in - let expr = Ast_helper.Exp.constraint_ ~loc expr typ in - let () = - Parser.err ~startPos:expr.pexp_loc.loc_start - ~endPos:typ.ptyp_loc.loc_end p - (Diagnostics.message - (Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text - "Expressions with type constraints need to be wrapped \ - in parens:"; - Doc.indent - (Doc.concat - [ - Doc.line; - ResPrinter.addParens - (ResPrinter.printExpression expr - CommentTable.empty); - ]); - ]) - |> Doc.toString ~width:80)) - in - expr) - | _ -> expr - -and parseLetBindingBody ~startPos ~attrs p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.LetBinding; - let pat, exp = - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; - match p.Parser.token with - | Colon -> ( - Parser.next p; - match p.token with - | Typ -> - (* locally abstract types *) - Parser.next p; - let newtypes = parseLidentList p in - Parser.expect Dot p; - let typ = parseTypExpr p in - Parser.expect Equal p; - let expr = parseExpr p in - let loc = mkLoc startPos p.prevEndPos in - let exp, poly = wrapTypeAnnotation ~loc newtypes typ expr in - let pat = Ast_helper.Pat.constraint_ ~loc pat poly in - (pat, exp) - | _ -> - let polyType = parsePolyTypeExpr p in - let loc = - {pat.ppat_loc with loc_end = polyType.Parsetree.ptyp_loc.loc_end} - in - let pat = Ast_helper.Pat.constraint_ ~loc pat polyType in - Parser.expect Token.Equal p; - let exp = parseExpr p in - let exp = overParseConstrainedOrCoercedOrArrowExpression p exp in - (pat, exp)) - | _ -> - Parser.expect Token.Equal p; - let exp = - overParseConstrainedOrCoercedOrArrowExpression p (parseExpr p) - in - (pat, exp) - in - let loc = mkLoc startPos p.prevEndPos in - let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in - Parser.eatBreadcrumb p; - Parser.endRegion p; - vb - -(* TODO: find a better way? Is it possible? - * let a = 1 - * @attr - * and b = 2 - * - * The problem is that without semi we need a lookahead to determine - * if the attr is on the letbinding or the start of a new thing - * - * let a = 1 - * @attr - * let b = 1 - * - * Here @attr should attach to something "new": `let b = 1` - * The parser state is forked, which is quite expensive… - *) -and parseAttributesAndBinding (p : Parser.t) = - let err = p.scanner.err in - let ch = p.scanner.ch in - let offset = p.scanner.offset in - let offset16 = p.scanner.offset16 in - let lineOffset = p.scanner.lineOffset in - let lnum = p.scanner.lnum in - let mode = p.scanner.mode in - let token = p.token in - let startPos = p.startPos in - let endPos = p.endPos in - let prevEndPos = p.prevEndPos in - let breadcrumbs = p.breadcrumbs in - let errors = p.errors in - let diagnostics = p.diagnostics in - let comments = p.comments in - - match p.Parser.token with - | At | DocComment (_, _) -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | And -> attrs - | _ -> - p.scanner.err <- err; - p.scanner.ch <- ch; - p.scanner.offset <- offset; - p.scanner.offset16 <- offset16; - p.scanner.lineOffset <- lineOffset; - p.scanner.lnum <- lnum; - p.scanner.mode <- mode; - p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; - p.breadcrumbs <- breadcrumbs; - p.errors <- errors; - p.diagnostics <- diagnostics; - p.comments <- comments; - []) - | _ -> [] - -(* definition ::= let [rec] let-binding { and let-binding } *) -and parseLetBindings ~attrs ~startPos p = - Parser.optional p Let |> ignore; - let recFlag = - if Parser.optional p Token.Rec then Asttypes.Recursive - else Asttypes.Nonrecursive - in - let first = parseLetBindingBody ~startPos ~attrs p in - - let rec loop p bindings = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - Parser.next p; - ignore (Parser.optional p Let); - (* overparse for fault tolerance *) - let letBinding = parseLetBindingBody ~startPos ~attrs p in - loop p (letBinding :: bindings) - | _ -> List.rev bindings - in - (recFlag, loop p [first]) - -(* - * div -> div - * Foo -> Foo.createElement - * Foo.Bar -> Foo.Bar.createElement - *) -and parseJsxName p = - let longident = - match p.Parser.token with - | Lident ident -> - let identStart = p.startPos in - let identEnd = p.endPos in - Parser.next p; - let loc = mkLoc identStart identEnd in - Location.mkloc (Longident.Lident ident) loc - | Uident _ -> - let longident = parseModuleLongIdent ~lowercase:true p in - Location.mkloc - (Longident.Ldot (longident.txt, "createElement")) - longident.loc - | _ -> - let msg = - "A jsx name must be a lowercase or uppercase name, like: div in
or Navbar in " - in - Parser.err p (Diagnostics.message msg); - Location.mknoloc (Longident.Lident "_") - in - Ast_helper.Exp.ident ~loc:longident.loc longident - -and parseJsxOpeningOrSelfClosingElement ~startPos p = - let jsxStartPos = p.Parser.startPos in - let name = parseJsxName p in - let jsxProps = parseJsxProps p in - let children = - match p.Parser.token with - | Forwardslash -> - (* *) - let childrenStartPos = p.Parser.startPos in - Parser.next p; - let childrenEndPos = p.Parser.startPos in - Scanner.popMode p.scanner Jsx; - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc [] None (* no children *) - | GreaterThan -> ( - (* bar *) - let childrenStartPos = p.Parser.startPos in - Parser.next p; - let spread, children = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - let () = - match p.token with - | LessThanSlash -> Parser.next p - | LessThan -> - Parser.next p; - Parser.expect Forwardslash p - | token when Grammar.isStructureItemStart token -> () - | _ -> Parser.expect LessThanSlash p - in - match p.Parser.token with - | (Lident _ | Uident _) when verifyJsxOpeningClosingName p name -> ( - Scanner.popMode p.scanner Jsx; - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - match (spread, children) with - | true, child :: _ -> child - | _ -> makeListExpression loc children None) - | token -> ( - Scanner.popMode p.scanner Jsx; - let () = - if Grammar.isStructureItemStart token then - let closing = "" in - let msg = Diagnostics.message ("Missing " ^ closing) in - Parser.err ~startPos ~endPos:p.prevEndPos p msg - else - let opening = "" in - let msg = - "Closing jsx name should be the same as the opening name. Did \ - you mean " ^ opening ^ " ?" - in - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message msg); - Parser.expect GreaterThan p - in - let loc = mkLoc childrenStartPos childrenEndPos in - match (spread, children) with - | true, child :: _ -> child - | _ -> makeListExpression loc children None)) - | token -> - Scanner.popMode p.scanner Jsx; - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - makeListExpression Location.none [] None - in - let jsxEndPos = p.prevEndPos in - let loc = mkLoc jsxStartPos jsxEndPos in - Ast_helper.Exp.apply ~loc name - (List.concat - [ - jsxProps; - [ - (Asttypes.Labelled "children", children); - ( Asttypes.Nolabel, - Ast_helper.Exp.construct - (Location.mknoloc (Longident.Lident "()")) - None ); - ]; - ]) - -(* - * jsx ::= - * | <> jsx-children - * | - * | jsx-children - * - * jsx-children ::= primary-expr* * => 0 or more - *) -and parseJsx p = - Scanner.setJsxMode p.Parser.scanner; - Parser.leaveBreadcrumb p Grammar.Jsx; - let startPos = p.Parser.startPos in - Parser.expect LessThan p; - let jsxExpr = - match p.Parser.token with - | Lident _ | Uident _ -> parseJsxOpeningOrSelfClosingElement ~startPos p - | GreaterThan -> - (* fragment: <> foo *) - parseJsxFragment p - | _ -> parseJsxName p - in - Parser.eatBreadcrumb p; - {jsxExpr with pexp_attributes = [jsxAttr]} - -(* - * jsx-fragment ::= - * | <> - * | <> jsx-children - *) -and parseJsxFragment p = - let childrenStartPos = p.Parser.startPos in - Parser.expect GreaterThan p; - let _spread, children = parseJsxChildren p in - let childrenEndPos = p.Parser.startPos in - if p.token = LessThan then p.token <- Scanner.reconsiderLessThan p.scanner; - Parser.expect LessThanSlash p; - Scanner.popMode p.scanner Jsx; - Parser.expect GreaterThan p; - let loc = mkLoc childrenStartPos childrenEndPos in - makeListExpression loc children None - -(* - * jsx-prop ::= - * | lident - * | ?lident - * | lident = jsx_expr - * | lident = ?jsx_expr - * | {...jsx_expr} - *) -and parseJsxProp p = - match p.Parser.token with - | Question | Lident _ -> ( - let optional = Parser.optional p Question in - let name, loc = parseLident p in - let propLocAttr = - (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) - in - (* optional punning: *) - if optional then - Some - ( Asttypes.Optional name, - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc - (Location.mkloc (Longident.Lident name) loc) ) - else - match p.Parser.token with - | Equal -> - Parser.next p; - (* no punning *) - let optional = Parser.optional p Question in - Scanner.popMode p.scanner Jsx; - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} - in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr) - | _ -> - let attrExpr = - Ast_helper.Exp.ident ~loc ~attrs:[propLocAttr] - (Location.mkloc (Longident.Lident name) loc) - in - let label = - if optional then Asttypes.Optional name else Asttypes.Labelled name - in - Some (label, attrExpr)) - (* {...props} *) - | Lbrace -> ( - Scanner.popMode p.scanner Jsx; - Parser.next p; - match p.Parser.token with - | DotDotDot -> ( - Scanner.popMode p.scanner Jsx; - Parser.next p; - let loc = mkLoc p.Parser.startPos p.prevEndPos in - let propLocAttr = - (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) - in - let attrExpr = - let e = parsePrimaryExpr ~operand:(parseExpr p) p in - {e with pexp_attributes = propLocAttr :: e.pexp_attributes} - in - (* using label "spreadProps" to distinguish from others *) - let label = Asttypes.Labelled "_spreadProps" in - match p.Parser.token with - | Rbrace -> - Parser.next p; - Scanner.setJsxMode p.scanner; - Some (label, attrExpr) - | _ -> None) - | _ -> None) - | _ -> None - -and parseJsxProps p = - parseRegion ~grammar:Grammar.JsxAttribute ~f:parseJsxProp p - -and parseJsxChildren p = - Scanner.popMode p.scanner Jsx; - let rec loop p children = - match p.Parser.token with - | Token.Eof | LessThanSlash -> children - | LessThan -> - (* Imagine:
< - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate *) - let token = Scanner.reconsiderLessThan p.scanner in - if token = LessThan then - let child = - parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p - in - loop p (child :: children) - else - (* LessThanSlash *) - let () = p.token <- token in - children - | token when Grammar.isJsxChildStart token -> - let child = - parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p - in - loop p (child :: children) - | _ -> children - in - let spread, children = - match p.Parser.token with - | DotDotDot -> - Parser.next p; - (true, [parsePrimaryExpr ~operand:(parseAtomicExpr p) ~noCall:true p]) - | _ -> - let children = List.rev (loop p []) in - (false, children) - in - Scanner.setJsxMode p.scanner; - (spread, children) - -and parseBracedOrRecordExpr p = - let startPos = p.Parser.startPos in - Parser.expect Lbrace p; - match p.Parser.token with - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [] None - | DotDotDot -> - (* beginning of record spread, parse record *) - Parser.next p; - let spreadExpr = parseConstrainedOrCoercedExpr p in - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos ~spread:(Some spreadExpr) [] p in - Parser.expect Rbrace p; - expr - | String s -> ( - let field = - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc (Longident.Lident s) loc - in - match p.Parser.token with - | Colon -> - Parser.next p; - let fieldExpr = parseExpr p in - Parser.optional p Comma |> ignore; - let expr = parseRecordExprWithStringKeys ~startPos (field, fieldExpr) p in - Parser.expect Rbrace p; - expr - | _ -> ( - let tag = if p.mode = ParseForTypeChecker then Some "js" else None in - let constant = - Ast_helper.Exp.constant ~loc:field.loc - (Parsetree.Pconst_string (s, tag)) - in - let a = parsePrimaryExpr ~operand:constant p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - { - expr with - Parsetree.pexp_attributes = braces :: expr.Parsetree.pexp_attributes; - } - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) - | Question -> - let expr = parseRecordExpr ~startPos [] p in - Parser.expect Rbrace p; - expr - (* - The branch below takes care of the "braced" expression {async}. - The big reason that we need all these branches is that {x} isn't a record with a punned field x, but a braced expression… There's lots of "ambiguity" between a record with a single punned field and a braced expression… - What is {x}? - 1) record {x: x} - 2) expression x which happens to wrapped in braces - Due to historical reasons, we always follow 2 - *) - | Lident "async" when isEs6ArrowExpression ~inTernary:false p -> - let expr = parseAsyncArrowExpression p in - let expr = parseExprBlock ~first:expr p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Uident _ | Lident _ -> ( - let startToken = p.token in - let valueOrConstructor = parseValueOrConstructor p in - match valueOrConstructor.pexp_desc with - | Pexp_ident pathIdent -> ( - let identEndPos = p.prevEndPos in - match p.Parser.token with - | Comma -> - Parser.next p; - let valueOrConstructor = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue valueOrConstructor - | _ -> valueOrConstructor - in - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr - | Colon -> ( - Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in - match p.token with - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.record ~loc [(pathIdent, fieldExpr)] None - | _ -> - Parser.expect Comma p; - let expr = parseRecordExpr ~startPos [(pathIdent, fieldExpr)] p in - Parser.expect Rbrace p; - expr) - (* error case *) - | Lident _ -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then ( - Parser.expect Comma p; - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr) - else ( - Parser.expect Colon p; - let expr = - parseRecordExpr ~startPos [(pathIdent, valueOrConstructor)] p - in - Parser.expect Rbrace p; - expr) - | Semicolon -> - let expr = parseExprBlock ~first:(Ast_helper.Exp.ident pathIdent) p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let expr = Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent in - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | EqualGreater -> ( - let loc = mkLoc startPos identEndPos in - let ident = Location.mkloc (Longident.last pathIdent.txt) loc in - let a = - parseEs6ArrowExpression - ~parameters: - [ - TermParameter - { - dotted = false; - attrs = []; - label = Asttypes.Nolabel; - expr = None; - pat = Ast_helper.Pat.var ~loc:ident.loc ident; - pos = startPos; - }; - ] - p - in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes}) - | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = - parsePrimaryExpr - ~operand:(Ast_helper.Exp.ident ~loc:pathIdent.loc pathIdent) - p - in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) - | _ -> ( - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let a = parsePrimaryExpr ~operand:valueOrConstructor p in - let e = parseBinaryExpr ~a p 1 in - let e = parseTernaryExpr e p in - Parser.eatBreadcrumb p; - match p.Parser.token with - | Semicolon -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - | Rbrace -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {e with pexp_attributes = braces :: e.pexp_attributes} - | _ -> - let expr = parseExprBlock ~first:e p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes})) - | _ -> - let expr = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let braces = makeBracesAttr loc in - {expr with pexp_attributes = braces :: expr.pexp_attributes} - -and parseRecordExprRowWithStringKey p = - match p.Parser.token with - | String s -> ( - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let field = Location.mkloc (Longident.Lident s) loc in - match p.Parser.token with - | Colon -> - Parser.next p; - let fieldExpr = parseExpr p in - Some (field, fieldExpr) - | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) - | _ -> None - -and parseRecordExprRow p = - let attrs = parseAttributes p in - let () = - match p.Parser.token with - | Token.DotDotDot -> - Parser.err p (Diagnostics.message ErrorMessages.recordExprSpread); - Parser.next p - | _ -> () - in - match p.Parser.token with - | Lident _ | Uident _ -> ( - let startToken = p.token in - let field = parseValuePath p in - match p.Parser.token with - | Colon -> - Parser.next p; - let optional = parseOptionalLabel p in - let fieldExpr = parseExpr p in - let fieldExpr = makeExpressionOptional ~optional fieldExpr in - Some (field, fieldExpr) - | _ -> - let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in - let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value - | _ -> value - in - Some (field, value)) - | Question -> ( - Parser.next p; - match p.Parser.token with - | Lident _ | Uident _ -> - let startToken = p.token in - let field = parseValuePath p in - let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in - let value = - match startToken with - | Uident _ -> removeModuleNameFromPunnedFieldValue value - | _ -> value - in - Some (field, makeExpressionOptional ~optional:true value) - | _ -> None) - | _ -> None - -and parseRecordExprWithStringKeys ~startPos firstRow p = - let rows = - firstRow - :: parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey - ~closing:Rbrace ~f:parseRecordExprRowWithStringKey p - in - let loc = mkLoc startPos p.endPos in - let recordStrExpr = - Ast_helper.Str.eval ~loc (Ast_helper.Exp.record ~loc rows None) - in - Ast_helper.Exp.extension ~loc - (Location.mkloc "obj" loc, Parsetree.PStr [recordStrExpr]) - -and parseRecordExpr ~startPos ?(spread = None) rows p = - let exprs = - parseCommaDelimitedRegion ~grammar:Grammar.RecordRows ~closing:Rbrace - ~f:parseRecordExprRow p - in - let rows = List.concat [rows; exprs] in - let () = - match rows with - | [] -> - let msg = "Record spread needs at least one field that's updated" in - Parser.err p (Diagnostics.message msg) - | _rows -> () - in - let loc = mkLoc startPos p.endPos in - Ast_helper.Exp.record ~loc rows spread - -and parseNewlineOrSemicolonExprBlock p = - match p.Parser.token with - | Semicolon -> Parser.next p - | token when Grammar.isBlockExprStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive expressions on a line must be separated by ';' or a \ - newline") - | _ -> () - -and parseExprBlockItem p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Module -> ( - Parser.next p; - match p.token with - | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - parseTernaryExpr expr p - | _ -> - let name = - match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = parseModuleBindingBody p in - parseNewlineOrSemicolonExprBlock p; - let expr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letmodule ~loc name body expr) - | Exception -> - let extensionConstructor = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.letexception ~loc extensionConstructor blockExpr - | Open -> - let od = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = parseExprBlock p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.open_ ~loc od.popen_override od.popen_lid blockExpr - | Let -> - let recFlag, letBindings = parseLetBindings ~attrs ~startPos p in - parseNewlineOrSemicolonExprBlock p; - let next = - if Grammar.isBlockExprStart p.Parser.token then parseExprBlock p - else - let loc = mkLoc p.startPos p.endPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.let_ ~loc recFlag letBindings next - | _ -> - let e1 = - let expr = parseExpr p in - {expr with pexp_attributes = List.concat [attrs; expr.pexp_attributes]} - in - parseNewlineOrSemicolonExprBlock p; - if Grammar.isBlockExprStart p.Parser.token then - let e2 = parseExprBlock p in - let loc = {e1.pexp_loc with loc_end = e2.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc e1 e2 - else e1 - -(* blockExpr ::= expr - * | expr ; - * | expr ; blockExpr - * | module ... ; blockExpr - * | open ... ; blockExpr - * | exception ... ; blockExpr - * | let ... - * | let ... ; - * | let ... ; blockExpr - * - * note: semi should be made optional - * a block of expression is always - *) -and parseExprBlock ?first p = - Parser.leaveBreadcrumb p Grammar.ExprBlock; - let item = - match first with - | Some e -> e - | None -> parseExprBlockItem p - in - parseNewlineOrSemicolonExprBlock p; - let blockExpr = - if Grammar.isBlockExprStart p.Parser.token then - let next = parseExprBlockItem p in - let loc = {item.pexp_loc with loc_end = next.pexp_loc.loc_end} in - Ast_helper.Exp.sequence ~loc item next - else item - in - Parser.eatBreadcrumb p; - overParseConstrainedOrCoercedOrArrowExpression p blockExpr - -and parseAsyncArrowExpression ?(arrowAttrs = []) p = - let startPos = p.Parser.startPos in - Parser.expect (Lident "async") p; - let asyncAttr = makeAsyncAttr (mkLoc startPos p.prevEndPos) in - parseEs6ArrowExpression ~arrowAttrs:(asyncAttr :: arrowAttrs) - ~arrowStartPos:(Some startPos) p - -and parseAwaitExpression p = - let awaitLoc = mkLoc p.Parser.startPos p.endPos in - let awaitAttr = makeAwaitAttr awaitLoc in - Parser.expect Await p; - let tokenPrec = Token.precedence MinusGreater in - let expr = parseBinaryExpr ~context:OrdinaryExpr p tokenPrec in - { - expr with - pexp_attributes = awaitAttr :: expr.pexp_attributes; - pexp_loc = {expr.pexp_loc with loc_start = awaitLoc.loc_start}; - } - -and parseTryExpression p = - let startPos = p.Parser.startPos in - Parser.expect Try p; - let expr = parseExpr ~context:WhenExpr p in - Parser.expect Res_token.catch p; - Parser.expect Lbrace p; - let cases = parsePatternMatching p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.try_ ~loc expr cases - -and parseIfCondition p = - Parser.leaveBreadcrumb p Grammar.IfCondition; - (* doesn't make sense to try es6 arrow here? *) - let conditionExpr = parseExpr ~context:WhenExpr p in - Parser.eatBreadcrumb p; - conditionExpr - -and parseThenBranch p = - Parser.leaveBreadcrumb p IfBranch; - Parser.expect Lbrace p; - let thenExpr = parseExprBlock p in - Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - thenExpr - -and parseElseBranch p = - Parser.expect Lbrace p; - let blockExpr = parseExprBlock p in - Parser.expect Rbrace p; - blockExpr - -and parseIfExpr startPos p = - let conditionExpr = parseIfCondition p in - let thenExpr = parseThenBranch p in - let elseExpr = - match p.Parser.token with - | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = - match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - Some elseExpr - | _ -> - Parser.endRegion p; - None - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.ifthenelse ~loc conditionExpr thenExpr elseExpr - -and parseIfLetExpr startPos p = - let pattern = parsePattern p in - Parser.expect Equal p; - let conditionExpr = parseIfCondition p in - let thenExpr = parseThenBranch p in - let elseExpr = - match p.Parser.token with - | Else -> - Parser.endRegion p; - Parser.leaveBreadcrumb p Grammar.ElseBranch; - Parser.next p; - Parser.beginRegion p; - let elseExpr = - match p.token with - | If -> parseIfOrIfLetExpression p - | _ -> parseElseBranch p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - elseExpr - | _ -> - Parser.endRegion p; - let startPos = p.Parser.startPos in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.match_ - ~attrs:[ifLetAttr; suppressFragileMatchWarningAttr] - ~loc conditionExpr - [ - Ast_helper.Exp.case pattern thenExpr; - Ast_helper.Exp.case (Ast_helper.Pat.any ()) elseExpr; - ] - -and parseIfOrIfLetExpression p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.ExprIf; - let startPos = p.Parser.startPos in - Parser.expect If p; - let expr = - match p.Parser.token with - | Let -> - Parser.next p; - let ifLetExpr = parseIfLetExpr startPos p in - Parser.err ~startPos:ifLetExpr.pexp_loc.loc_start - ~endPos:ifLetExpr.pexp_loc.loc_end p - (Diagnostics.message (ErrorMessages.experimentalIfLet ifLetExpr)); - ifLetExpr - | _ -> parseIfExpr startPos p - in - Parser.eatBreadcrumb p; - expr - -and parseForRest hasOpeningParen pattern startPos p = - Parser.expect In p; - let e1 = parseExpr p in - let direction = - match p.Parser.token with - | Lident "to" -> Asttypes.Upto - | Lident "downto" -> Asttypes.Downto - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Asttypes.Upto - in - if p.Parser.token = Eof then - Parser.err ~startPos:p.startPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs) - else Parser.next p; - let e2 = parseExpr ~context:WhenExpr p in - if hasOpeningParen then Parser.expect Rparen p; - Parser.expect Lbrace p; - let bodyExpr = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.for_ ~loc pattern e1 e2 direction bodyExpr - -and parseForExpression p = - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.ExprFor; - Parser.expect For p; - Parser.beginRegion p; - let forExpr = - match p.token with - | Lparen -> ( - let lparen = p.startPos in - Parser.next p; - match p.token with - | Rparen -> - Parser.next p; - let unitPattern = - let loc = mkLoc lparen p.prevEndPos in - let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid None - in - parseForRest false - (parseAliasPattern ~attrs:[] unitPattern p) - startPos p - | _ -> ( - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; - match p.token with - | Comma -> - Parser.next p; - let tuplePattern = - parseTuplePattern ~attrs:[] ~startPos:lparen ~first:pat p - in - let pattern = parseAliasPattern ~attrs:[] tuplePattern p in - parseForRest false pattern startPos p - | _ -> parseForRest true pat startPos p)) - | _ -> - Parser.leaveBreadcrumb p Grammar.Pattern; - let pat = parsePattern p in - Parser.eatBreadcrumb p; - parseForRest false pat startPos p - in - Parser.eatBreadcrumb p; - Parser.endRegion p; - forExpr - -and parseWhileExpression p = - let startPos = p.Parser.startPos in - Parser.expect While p; - let expr1 = parseExpr ~context:WhenExpr p in - Parser.expect Lbrace p; - let expr2 = parseExprBlock p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.while_ ~loc expr1 expr2 - -and parsePatternGuard p = - match p.Parser.token with - | When | If -> - Parser.next p; - Some (parseExpr ~context:WhenExpr p) - | _ -> None - -and parsePatternMatchCase p = - Parser.beginRegion p; - Parser.leaveBreadcrumb p Grammar.PatternMatchCase; - match p.Parser.token with - | Token.Bar -> - Parser.next p; - Parser.leaveBreadcrumb p Grammar.Pattern; - let lhs = parsePattern p in - Parser.eatBreadcrumb p; - let guard = parsePatternGuard p in - let () = - match p.token with - | EqualGreater -> Parser.next p - | _ -> Recover.recoverEqualGreater p - in - let rhs = parseExprBlock p in - Parser.endRegion p; - Parser.eatBreadcrumb p; - Some (Ast_helper.Exp.case lhs ?guard rhs) - | _ -> - Parser.endRegion p; - Parser.eatBreadcrumb p; - None - -and parsePatternMatching p = - let cases = - parseDelimitedRegion ~grammar:Grammar.PatternMatching ~closing:Rbrace - ~f:parsePatternMatchCase p - in - let () = - match cases with - | [] -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.message "Pattern matching needs at least one case") - | _ -> () - in - cases - -and parseSwitchExpression p = - let startPos = p.Parser.startPos in - Parser.expect Switch p; - let switchExpr = parseExpr ~context:WhenExpr p in - Parser.expect Lbrace p; - let cases = parsePatternMatching p in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.match_ ~loc switchExpr cases - -(* - * argument ::= - * | _ (* syntax sugar *) - * | expr - * | expr : type - * | ~ label-name - * | ~ label-name - * | ~ label-name ? - * | ~ label-name = expr - * | ~ label-name = _ (* syntax sugar *) - * | ~ label-name = expr : type - * | ~ label-name = ? expr - * | ~ label-name = ? _ (* syntax sugar *) - * | ~ label-name = ? expr : type - * - * dotted_argument ::= - * | . argument - *) -and parseArgument p : argument option = - if - p.Parser.token = Token.Tilde - || p.token = Dot || p.token = Underscore - || Grammar.isExprStart p.token - then - match p.Parser.token with - | Dot -> ( - let dotted = true in - Parser.next p; - match p.token with - (* apply(.) *) - | Rparen -> - let unitExpr = - Ast_helper.Exp.construct - (Location.mknoloc (Longident.Lident "()")) - None - in - Some {dotted; label = Asttypes.Nolabel; expr = unitExpr} - | _ -> parseArgument2 p ~dotted) - | _ -> parseArgument2 p ~dotted:false - else None - -and parseArgument2 p ~dotted : argument option = - match p.Parser.token with - (* foo(_), do not confuse with foo(_ => x), TODO: performance *) - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - let expr = - Ast_helper.Exp.ident ~loc (Location.mkloc (Longident.Lident "_") loc) - in - Some {dotted; label = Nolabel; expr} - | Tilde -> ( - Parser.next p; - (* TODO: nesting of pattern matches not intuitive for error recovery *) - match p.Parser.token with - | Lident ident -> ( - let startPos = p.startPos in - Parser.next p; - let endPos = p.prevEndPos in - let loc = mkLoc startPos endPos in - let propLocAttr = - (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) - in - let identExpr = - Ast_helper.Exp.ident ~attrs:[propLocAttr] ~loc - (Location.mkloc (Longident.Lident ident) loc) - in - match p.Parser.token with - | Question -> - Parser.next p; - Some {dotted; label = Optional ident; expr = identExpr} - | Equal -> - Parser.next p; - let label = - match p.Parser.token with - | Question -> - Parser.next p; - Asttypes.Optional ident - | _ -> Labelled ident - in - let expr = - match p.Parser.token with - | Underscore when not (isEs6ArrowExpression ~inTernary:false p) -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Ast_helper.Exp.ident ~loc - (Location.mkloc (Longident.Lident "_") loc) - | _ -> - let expr = parseConstrainedOrCoercedExpr p in - {expr with pexp_attributes = propLocAttr :: expr.pexp_attributes} - in - Some {dotted; label; expr} - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - let expr = - Ast_helper.Exp.constraint_ ~attrs:[propLocAttr] ~loc identExpr typ - in - Some {dotted; label = Labelled ident; expr} - | _ -> Some {dotted; label = Labelled ident; expr = identExpr}) - | t -> - Parser.err p (Diagnostics.lident t); - Some {dotted; label = Nolabel; expr = Recover.defaultExpr ()}) - | _ -> Some {dotted; label = Nolabel; expr = parseConstrainedOrCoercedExpr p} - -and parseCallExpr p funExpr = - Parser.expect Lparen p; - let startPos = p.Parser.startPos in - Parser.leaveBreadcrumb p Grammar.ExprCall; - let args = - parseCommaDelimitedRegion ~grammar:Grammar.ArgumentList ~closing:Rparen - ~f:parseArgument p - in - let resPartialAttr = - let loc = mkLoc startPos p.prevEndPos in - (Location.mkloc "res.partial" loc, Parsetree.PStr []) - in - let isPartial = - match p.token with - | DotDotDot when args <> [] -> - Parser.next p; - true - | _ -> false - in - Parser.expect Rparen p; - let args = - match args with - | [] -> - let loc = mkLoc startPos p.prevEndPos in - (* No args -> unit sugar: `foo()` *) - [ - { - dotted = false; - label = Nolabel; - expr = - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None; - }; - ] - | [ - { - dotted = true; - label = Nolabel; - expr = - { - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None); - pexp_loc = loc; - pexp_attributes = []; - } as expr; - }; - ] - when (not loc.loc_ghost) && p.mode = ParseForTypeChecker && not isPartial - -> - (* Since there is no syntax space for arity zero vs arity one, - * we expand - * `fn(. ())` into - * `fn(. {let __res_unit = (); __res_unit})` - * when the parsetree is intended for type checking - * - * Note: - * `fn(.)` is treated as zero arity application. - * The invisible unit expression here has loc_ghost === true - * - * Related: https://github.com/rescript-lang/syntax/issues/138 - *) - [ - { - dotted = true; - label = Nolabel; - expr = - Ast_helper.Exp.let_ Asttypes.Nonrecursive - [ - Ast_helper.Vb.mk - (Ast_helper.Pat.var (Location.mknoloc "__res_unit")) - expr; - ] - (Ast_helper.Exp.ident - (Location.mknoloc (Longident.Lident "__res_unit"))); - }; - ] - | args -> args - in - let loc = {funExpr.pexp_loc with loc_end = p.prevEndPos} in - let args = - match args with - | {dotted = d; label = lbl; expr} :: args -> - let group (grp, acc) {dotted; label = lbl; expr} = - let _d, grp = grp in - if dotted == true then ((true, [(lbl, expr)]), (_d, List.rev grp) :: acc) - else ((_d, (lbl, expr) :: grp), acc) - in - let (_d, grp), acc = List.fold_left group ((d, [(lbl, expr)]), []) args in - List.rev ((_d, List.rev grp) :: acc) - | [] -> [] - in - let apply = - Ext_list.fold_left args funExpr (fun callBody group -> - let dotted, args = group in - let args, wrap = processUnderscoreApplication p args in - let exp = - let uncurried = - p.uncurried_config |> Res_uncurried.fromDotted ~dotted - in - let attrs = if uncurried then [uncurriedAppAttr] else [] in - let attrs = if isPartial then resPartialAttr :: attrs else attrs in - Ast_helper.Exp.apply ~loc ~attrs callBody args - in - wrap exp) - in - - Parser.eatBreadcrumb p; - apply - -and parseValueOrConstructor p = - let startPos = p.Parser.startPos in - let rec aux p acc = - match p.Parser.token with - | Uident ident -> ( - let endPosLident = p.endPos in - Parser.next p; - match p.Parser.token with - | Dot -> - Parser.next p; - aux p (ident :: acc) - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let lident = buildLongident (ident :: acc) in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as arg)] as args -> - let loc = mkLoc lparen rparen in - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some arg - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc args) - | [arg] -> Some arg - | args -> - let loc = mkLoc lparen rparen in - Some (Ast_helper.Exp.tuple ~loc args) - in - let loc = mkLoc startPos p.prevEndPos in - let identLoc = mkLoc startPos endPosLident in - Ast_helper.Exp.construct ~loc (Location.mkloc lident identLoc) tail - | _ -> - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in - Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) - | Lident ident -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let lident = buildLongident (ident :: acc) in - Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) - | token -> - if acc = [] then ( - Parser.nextUnsafe p; - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultExpr ()) - else - let loc = mkLoc startPos p.prevEndPos in - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = buildLongident ("_" :: acc) in - Ast_helper.Exp.ident ~loc (Location.mkloc lident loc) - in - aux p [] - -and parsePolyVariantExpr p = - let startPos = p.startPos in - let ident, _loc = parseHashIdent ~startPos p in - match p.Parser.token with - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - let lparen = p.startPos in - let args = parseConstructorArgs p in - let rparen = p.prevEndPos in - let loc_paren = mkLoc lparen rparen in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as expr)] as args -> - if p.mode = ParseForTypeChecker then - (* #a(1, 2) for type-checker *) - Some expr - else - (* #a((1, 2)) for type-checker *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - | [arg] -> Some arg - | args -> - (* #a((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident tail - | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.variant ~loc ident None - -and parseConstructorArgs p = - let lparen = p.Parser.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion ~grammar:Grammar.ExprList - ~f:parseConstrainedExprRegion ~closing:Rparen p - in - Parser.expect Rparen p; - match args with - | [] -> - let loc = mkLoc lparen p.prevEndPos in - [ - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None; - ] - | args -> args - -and parseTupleExpr ~first ~startPos p = - let exprs = - first - :: parseCommaDelimitedRegion p ~grammar:Grammar.ExprList ~closing:Rparen - ~f:parseConstrainedExprRegion - in - Parser.expect Rparen p; - let () = - match exprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) - | _ -> () - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Exp.tuple ~loc exprs - -and parseSpreadExprRegionWithLoc p = - let startPos = p.Parser.prevEndPos in - match p.Parser.token with - | DotDotDot -> - Parser.next p; - let expr = parseConstrainedOrCoercedExpr p in - Some (true, expr, startPos, p.prevEndPos) - | token when Grammar.isExprStart token -> - Some (false, parseConstrainedOrCoercedExpr p, startPos, p.prevEndPos) - | _ -> None - -and parseListExpr ~startPos p = - let split_by_spread exprs = - List.fold_left - (fun acc curr -> - match (curr, acc) with - | (true, expr, startPos, endPos), _ -> - (* find a spread expression, prepend a new sublist *) - ([], Some expr, startPos, endPos) :: acc - | ( (false, expr, startPos, _endPos), - (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> - (* find a non-spread expression, and the accumulated is not empty, - * prepend to the first sublist, and update the loc of the first sublist *) - (expr :: no_spreads, spread, startPos, accEndPos) :: acc - | (false, expr, startPos, endPos), [] -> - (* find a non-spread expression, and the accumulated is empty *) - [([expr], None, startPos, endPos)]) - [] exprs - in - let make_sub_expr = function - | exprs, Some spread, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs (Some spread) - | exprs, None, startPos, endPos -> - makeListExpression (mkLoc startPos endPos) exprs None - in - let listExprsRev = - parseCommaDelimitedReversedList p ~grammar:Grammar.ListExpr ~closing:Rbrace - ~f:parseSpreadExprRegionWithLoc - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - match split_by_spread listExprsRev with - | [] -> makeListExpression loc [] None - | [(exprs, Some spread, _, _)] -> makeListExpression loc exprs (Some spread) - | [(exprs, None, _, _)] -> makeListExpression loc exprs None - | exprs -> - let listExprs = List.map make_sub_expr exprs in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] - (Location.mkloc - (Longident.Ldot - (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany")) - loc)) - [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] - -and parseArrayExp p = - let startPos = p.Parser.startPos in - Parser.expect Lbracket p; - let split_by_spread exprs = - List.fold_left - (fun acc curr -> - match (curr, acc) with - | (true, expr, startPos, endPos), _ -> - (* find a spread expression, prepend a new sublist *) - ([], Some expr, startPos, endPos) :: acc - | ( (false, expr, startPos, _endPos), - (no_spreads, spread, _accStartPos, accEndPos) :: acc ) -> - (* find a non-spread expression, and the accumulated is not empty, - * prepend to the first sublist, and update the loc of the first sublist *) - (expr :: no_spreads, spread, startPos, accEndPos) :: acc - | (false, expr, startPos, endPos), [] -> - (* find a non-spread expression, and the accumulated is empty *) - [([expr], None, startPos, endPos)]) - [] exprs - in - let listExprsRev = - parseCommaDelimitedReversedList p ~grammar:Grammar.ExprList - ~closing:Rbracket ~f:parseSpreadExprRegionWithLoc - in - Parser.expect Rbracket p; - let loc = mkLoc startPos p.prevEndPos in - let collectExprs = function - | [], Some spread, _startPos, _endPos -> [spread] - | exprs, Some spread, _startPos, _endPos -> - let els = Ast_helper.Exp.array ~loc exprs in - [els; spread] - | exprs, None, _startPos, _endPos -> - let els = Ast_helper.Exp.array ~loc exprs in - [els] - in - match split_by_spread listExprsRev with - | [] -> Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) [] - | [(exprs, None, _, _)] -> - Ast_helper.Exp.array ~loc:(mkLoc startPos p.prevEndPos) exprs - | exprs -> - let xs = List.map collectExprs exprs in - let listExprs = - List.fold_right - (fun exprs1 acc -> - List.fold_right (fun expr1 acc1 -> expr1 :: acc1) exprs1 acc) - xs [] - in - Ast_helper.Exp.apply ~loc - (Ast_helper.Exp.ident ~loc ~attrs:[spreadAttr] - (Location.mkloc - (Longident.Ldot - (Longident.Ldot (Longident.Lident "Belt", "Array"), "concatMany")) - loc)) - [(Asttypes.Nolabel, Ast_helper.Exp.array ~loc listExprs)] - -(* TODO: check attributes in the case of poly type vars, - * might be context dependend: parseFieldDeclaration (see ocaml) *) -and parsePolyTypeExpr p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | SingleQuote -> ( - let vars = parseTypeVarList p in - match vars with - | _v1 :: _v2 :: _ -> - Parser.expect Dot p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | [var] -> ( - match p.Parser.token with - | Dot -> - Parser.next p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.poly ~loc vars typ - | EqualGreater -> - Parser.next p; - let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos in - let tFun = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in - if p.uncurried_config = Legacy then tFun - else Ast_uncurried.uncurriedType ~loc ~arity:1 tFun - | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) - | _ -> assert false) - | _ -> parseTypExpr p - -(* 'a 'b 'c *) -and parseTypeVarList p = - let rec loop p vars = - match p.Parser.token with - | SingleQuote -> - Parser.next p; - let lident, loc = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - let var = Location.mkloc lident loc in - loop p (var :: vars) - | _ -> List.rev vars - in - loop p [] - -and parseLidentList p = - let rec loop p ls = - match p.Parser.token with - | Lident lident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - loop p (Location.mkloc lident loc :: ls) - | _ -> List.rev ls - in - loop p [] - -and parseAtomicTypExpr ~attrs p = - Parser.leaveBreadcrumb p Grammar.AtomicTypExpr; - let startPos = p.Parser.startPos in - let typ = - match p.Parser.token with - | SingleQuote -> - Parser.next p; - let ident, loc = - if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeVar ~startPos:p.startPos p - in - Ast_helper.Typ.var ~loc ~attrs ident - | Underscore -> - let endPos = p.endPos in - Parser.next p; - Ast_helper.Typ.any ~loc:(mkLoc startPos endPos) ~attrs () - | Lparen -> ( - Parser.next p; - match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - Ast_helper.Typ.constr ~attrs unitConstr [] - | _ -> ( - let t = parseTypExpr p in - match p.token with - | Comma -> - Parser.next p; - parseTupleType ~attrs ~first:t ~startPos p - | _ -> - Parser.expect Rparen p; - { - t with - ptyp_loc = mkLoc startPos p.prevEndPos; - ptyp_attributes = List.concat [attrs; t.ptyp_attributes]; - })) - | Lbracket -> parsePolymorphicVariantType ~attrs p - | Uident _ | Lident _ -> - let constr = parseValuePath p in - let args = parseTypeConstructorArgs ~constrName:constr p in - Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs constr args - | Module -> - Parser.next p; - Parser.expect Lparen p; - let packageType = parsePackageType ~startPos ~attrs p in - Parser.expect Rparen p; - {packageType with ptyp_loc = mkLoc startPos p.prevEndPos} - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.extension ~attrs ~loc extension - | Lbrace -> parseRecordOrObjectType ~attrs p - | Eof -> - Parser.err p (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - Recover.defaultType () - | token -> ( - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - match - skipTokensAndMaybeRetry p ~isStartOfGrammar:Grammar.isAtomicTypExprStart - with - | Some () -> parseAtomicTypExpr ~attrs p - | None -> - Parser.err ~startPos:p.prevEndPos p - (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultType ()) - in - Parser.eatBreadcrumb p; - typ - -(* package-type ::= - | modtype-path - ∣ modtype-path with package-constraint { and package-constraint } -*) -and parsePackageType ~startPos ~attrs p = - let modTypePath = parseModuleLongIdent ~lowercase:true p in - match p.Parser.token with - | Lident "with" -> - Parser.next p; - let constraints = parsePackageConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath constraints - | _ -> - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.package ~loc ~attrs modTypePath [] - -(* package-constraint { and package-constraint } *) -and parsePackageConstraints p = - let first = - Parser.expect Typ p; - let typeConstr = parseValuePath p in - Parser.expect Equal p; - let typ = parseTypExpr p in - (typeConstr, typ) - in - let rest = - parseRegion ~grammar:Grammar.PackageConstraint ~f:parsePackageConstraint p - in - first :: rest - -(* and type typeconstr = typexpr *) -and parsePackageConstraint p = - match p.Parser.token with - | And -> - Parser.next p; - Parser.expect Typ p; - let typeConstr = parseValuePath p in - Parser.expect Equal p; - let typ = parseTypExpr p in - Some (typeConstr, typ) - | _ -> None - -and parseRecordOrObjectType ~attrs p = - (* for inline record in constructor *) - let startPos = p.Parser.startPos in - Parser.expect Lbrace p; - let closedFlag = - match p.token with - | DotDot -> - Parser.next p; - Asttypes.Open - | Dot -> - Parser.next p; - Asttypes.Closed - | _ -> Asttypes.Closed - in - let () = - match p.token with - | Lident _ -> - Parser.err p - (Diagnostics.message ErrorMessages.forbiddenInlineRecordDeclaration) - | _ -> () - in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.object_ ~loc ~attrs fields closedFlag - -(* TODO: check associativity in combination with attributes *) -and parseTypeAlias p typ = - match p.Parser.token with - | As -> - Parser.next p; - Parser.expect SingleQuote p; - let ident, _loc = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - (* TODO: how do we parse attributes here? *) - Ast_helper.Typ.alias - ~loc:(mkLoc typ.Parsetree.ptyp_loc.loc_start p.prevEndPos) - typ ident - | _ -> typ - -(* type_parameter ::= - * | type_expr - * | ~ident: type_expr - * | ~ident: type_expr=? - * - * note: - * | attrs ~ident: type_expr -> attrs are on the arrow - * | attrs type_expr -> attrs are here part of the type_expr - * - * dotted_type_parameter ::= - * | . type_parameter -*) -and parseTypeParameter p = - let docAttr : Parsetree.attributes = - match p.Parser.token with - | DocComment (loc, s) -> - Parser.next p; - [docCommentToAttribute loc s] - | _ -> [] - in - if - p.Parser.token = Token.Tilde - || p.token = Dot - || Grammar.isTypExprStart p.token - then - let startPos = p.Parser.startPos in - let dotted = Parser.optional p Dot in - let attrs = docAttr @ parseAttributes p in - match p.Parser.token with - | Tilde -> ( - Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = - (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) - in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = - let typ = parseTypExpr p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} - in - match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Some {dotted; attrs; label = Optional name; typ; startPos} - | _ -> Some {dotted; attrs; label = Labelled name; typ; startPos}) - | Lident _ -> ( - let name, loc = parseLident p in - match p.token with - | Colon -> ( - let () = - let error = - Diagnostics.message - (ErrorMessages.missingTildeLabeledParameter name) - in - Parser.err ~startPos:loc.loc_start ~endPos:loc.loc_end p error - in - Parser.next p; - let typ = parseTypExpr p in - match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Some {dotted; attrs; label = Optional name; typ; startPos} - | _ -> Some {dotted; attrs; label = Labelled name; typ; startPos}) - | _ -> - let constr = Location.mkloc (Longident.Lident name) loc in - let args = parseTypeConstructorArgs ~constrName:constr p in - let typ = - Ast_helper.Typ.constr - ~loc:(mkLoc startPos p.prevEndPos) - ~attrs constr args - in - - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - let typ = parseTypeAlias p typ in - Some {dotted; attrs = []; label = Nolabel; typ; startPos}) - | _ -> - let typ = parseTypExpr p in - let typWithAttributes = - {typ with ptyp_attributes = List.concat [attrs; typ.ptyp_attributes]} - in - Some - {dotted; attrs = []; label = Nolabel; typ = typWithAttributes; startPos} - else None - -(* (int, ~x:string, float) *) -and parseTypeParameters p = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - match p.Parser.token with - | Rparen -> - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let unitConstr = Location.mkloc (Longident.Lident "unit") loc in - let typ = Ast_helper.Typ.constr unitConstr [] in - [{dotted = false; attrs = []; label = Nolabel; typ; startPos}] - | _ -> - let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParameters ~closing:Rparen - ~f:parseTypeParameter p - in - Parser.expect Rparen p; - params - -and parseEs6ArrowType ~attrs p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Tilde -> - Parser.next p; - let name, loc = parseLident p in - let lblLocAttr = - (Location.mkloc "res.namedArgLoc" loc, Parsetree.PStr []) - in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = - let typ = parseTypExpr ~alias:false ~es6Arrow:false p in - {typ with ptyp_attributes = lblLocAttr :: typ.ptyp_attributes} - in - let arg = - match p.Parser.token with - | Equal -> - Parser.next p; - Parser.expect Question p; - Asttypes.Optional name - | _ -> Asttypes.Labelled name - in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.arrow ~loc ~attrs arg typ returnType - | DocComment _ -> assert false - | _ -> - let parameters = parseTypeParameters p in - Parser.expect EqualGreater p; - let returnType = parseTypExpr ~alias:false p in - let endPos = p.prevEndPos in - let returnTypeArity = - match parameters with - | _ when p.uncurried_config <> Legacy -> 0 - | _ -> - if parameters |> List.exists (function {dotted; typ = _} -> dotted) - then 0 - else - let _, args, _ = Res_parsetree_viewer.arrowType returnType in - List.length args - in - let _paramNum, typ, _arity = - List.fold_right - (fun {dotted; attrs; label = argLbl; typ; startPos} (paramNum, t, arity) -> - let uncurried = - p.uncurried_config |> Res_uncurried.fromDotted ~dotted - in - let loc = mkLoc startPos endPos in - let arity = - (* Workaround for ~lbl: @as(json`false`) _, which changes the arity *) - match argLbl with - | Labelled _s -> - let typ_is_any = - match typ.ptyp_desc with - | Ptyp_any -> true - | _ -> false - in - let has_as = - Ext_list.exists typ.ptyp_attributes (fun (x, _) -> x.txt = "as") - in - if !InExternal.status && typ_is_any && has_as then arity - 1 - else arity - | _ -> arity - in - let tArg = Ast_helper.Typ.arrow ~loc ~attrs argLbl typ t in - if uncurried && (paramNum = 1 || p.uncurried_config = Legacy) then - (paramNum - 1, Ast_uncurried.uncurriedType ~loc ~arity tArg, 1) - else (paramNum - 1, tArg, arity + 1)) - parameters - (List.length parameters, returnType, returnTypeArity + 1) - in - { - typ with - ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; - ptyp_loc = mkLoc startPos p.prevEndPos; - } - -(* - * typexpr ::= - * | 'ident - * | _ - * | (typexpr) - * | typexpr => typexpr --> es6 arrow - * | (typexpr, typexpr) => typexpr --> es6 arrow - * | /typexpr, typexpr, typexpr/ --> tuple - * | typeconstr - * | typeconstr - * | typeconstr - * | typexpr as 'ident - * | %attr-id --> extension - * | %attr-id(payload) --> extension - * - * typeconstr ::= - * | lident - * | uident.lident - * | uident.uident.lident --> long module path - *) -and parseTypExpr ?attrs ?(es6Arrow = true) ?(alias = true) p = - (* Parser.leaveBreadcrumb p Grammar.TypeExpression; *) - let startPos = p.Parser.startPos in - let attrs = - match attrs with - | Some attrs -> attrs - | None -> parseAttributes p - in - let typ = - if es6Arrow && isEs6ArrowType p then parseEs6ArrowType ~attrs p - else - let typ = parseAtomicTypExpr ~attrs p in - parseArrowTypeRest ~es6Arrow ~startPos typ p - in - let typ = if alias then parseTypeAlias p typ else typ in - (* Parser.eatBreadcrumb p; *) - typ - -and parseArrowTypeRest ~es6Arrow ~startPos typ p = - match p.Parser.token with - | (EqualGreater | MinusGreater) as token when es6Arrow == true -> - (* error recovery *) - if token = MinusGreater then Parser.expect EqualGreater p; - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc startPos p.prevEndPos in - let arrowTyp = Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType in - if p.uncurried_config = Legacy then arrowTyp - else Ast_uncurried.uncurriedType ~loc ~arity:1 arrowTyp - | _ -> typ - -and parseTypExprRegion p = - if Grammar.isTypExprStart p.Parser.token then Some (parseTypExpr p) else None - -and parseTupleType ~attrs ~first ~startPos p = - let typexprs = - first - :: parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - let () = - match typexprs with - | [_] -> - Parser.err ~startPos ~endPos:p.prevEndPos p - (Diagnostics.message ErrorMessages.tupleSingleElement) - | _ -> () - in - let tupleLoc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.tuple ~attrs ~loc:tupleLoc typexprs - -and parseTypeConstructorArgRegion p = - if Grammar.isTypExprStart p.Parser.token then Some (parseTypExpr p) - else if p.token = LessThan then ( - Parser.next p; - parseTypeConstructorArgRegion p) - else None - -(* Js.Nullable.value<'a> *) -and parseTypeConstructorArgs ~constrName p = - let opening = p.Parser.token in - let openingStartPos = p.startPos in - match opening with - | LessThan | Lparen -> - Scanner.setDiamondMode p.scanner; - Parser.next p; - let typeArgs = - (* TODO: change Grammar.TypExprList to TypArgList!!! Why did I wrote this? *) - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:GreaterThan ~f:parseTypeConstructorArgRegion p - in - let () = - match p.token with - | Rparen when opening = Token.Lparen -> - let typ = Ast_helper.Typ.constr constrName typeArgs in - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent - (Doc.concat - [Doc.line; ResPrinter.printTypExpr typ CommentTable.empty]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - typeArgs - | _ -> [] - -(* string-field-decl ::= - * | string: poly-typexpr - * | attributes string-field-decl *) -and parseStringFieldDeclaration p = - let attrs = parseAttributes p in - match p.Parser.token with - | String name -> - let nameStartPos = p.startPos in - let nameEndPos = p.endPos in - Parser.next p; - let fieldName = Location.mkloc name (mkLoc nameStartPos nameEndPos) in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) - | DotDotDot -> - Parser.next p; - let typ = parseTypExpr p in - Some (Parsetree.Oinherit typ) - | Lident name -> - let nameLoc = mkLoc p.startPos p.endPos in - Parser.err p - (Diagnostics.message (ErrorMessages.objectQuotedFieldName name)); - Parser.next p; - let fieldName = Location.mkloc name nameLoc in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typ = parsePolyTypeExpr p in - Some (Parsetree.Otag (fieldName, attrs, typ)) - | _token -> None - -(* field-decl ::= - * | [mutable] field-name : poly-typexpr - * | attributes field-decl *) -and parseFieldDeclaration p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - let mut = - if Parser.optional p Token.Mutable then Asttypes.Mutable - else Asttypes.Immutable - in - let lident, loc = - match p.token with - | _ -> parseLident p - in - let optional = parseOptionalLabel p in - let name = Location.mkloc lident loc in - let typ = - match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] - in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - (optional, Ast_helper.Type.field ~attrs ~loc ~mut name typ) - -and parseFieldDeclarationRegion ?foundObjectField p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - let mut = - if Parser.optional p Token.Mutable then Asttypes.Mutable - else Asttypes.Immutable - in - match p.token with - | DotDotDot -> - Parser.next p; - let name = Location.mkloc "..." (mkLoc startPos p.prevEndPos) in - let typ = parsePolyTypeExpr p in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) - | String s when foundObjectField <> None -> - Option.get foundObjectField := true; - Parser.next p; - let name = Location.mkloc s (mkLoc startPos p.prevEndPos) in - Parser.expect Colon p; - let typ = parsePolyTypeExpr p in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) - | Lident _ -> - let lident, loc = parseLident p in - let name = Location.mkloc lident loc in - let optional = parseOptionalLabel p in - let typ = - match p.Parser.token with - | Colon -> - Parser.next p; - parsePolyTypeExpr p - | _ -> - Ast_helper.Typ.constr ~loc:name.loc ~attrs - {name with txt = Lident name.txt} - [] - in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - let attrs = if optional then optionalAttr :: attrs else attrs in - Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) - | _ -> - if attrs <> [] then - Parser.err ~startPos p - (Diagnostics.message - "Attributes and doc comments can only be used at the beginning of a \ - field declaration"); - if mut = Mutable then - Parser.err ~startPos p - (Diagnostics.message - "The `mutable` qualifier can only be used at the beginning of a \ - field declaration"); - None - -(* record-decl ::= - * | { field-decl } - * | { field-decl, field-decl } - * | { field-decl, field-decl, field-decl, } - *) -and parseRecordDeclaration p = - Parser.leaveBreadcrumb p Grammar.RecordDecl; - Parser.expect Lbrace p; - let rows = - parseCommaDelimitedRegion ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:parseFieldDeclarationRegion p - in - Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - rows - -(* constr-args ::= - * | (typexpr) - * | (typexpr, typexpr) - * | (typexpr, typexpr, typexpr,) - * | (record-decl) - * - * TODO: should we overparse inline-records in every position? - * Give a good error message afterwards? - *) -and parseConstrDeclArgs p = - let constrArgs = - match p.Parser.token with - | Lparen -> ( - Parser.next p; - (* TODO: this could use some cleanup/stratification *) - match p.Parser.token with - | Lbrace -> ( - Parser.next p; - let startPos = p.Parser.startPos in - match p.Parser.token with - | DotDot | Dot -> - let closedFlag = - match p.token with - | DotDot -> - Parser.next p; - Asttypes.Open - | Dot -> - Parser.next p; - Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | DotDotDot -> - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in - (* start of object type spreading, e.g. `User({...a, "u": int})` *) - Parser.next p; - let typ = parseTypExpr p in - let () = - match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.next p - | _ -> Parser.expect Comma p - in - let () = - match p.token with - | Lident _ -> - Parser.err ~startPos:dotdotdotStart ~endPos:dotdotdotEnd p - (Diagnostics.message ErrorMessages.spreadInRecordDeclaration) - | _ -> () - in - let fields = - Parsetree.Oinherit typ - :: parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc fields Asttypes.Closed - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | _ -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in - let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = - match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = - match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - match field with - | Parsetree.Otag (label, _, ct) -> - Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - in - first - :: parseCommaDelimitedRegion - ~grammar:Grammar.StringFieldDeclarations ~closing:Rbrace - ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - Parser.optional p Comma |> ignore; - let moreArgs = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList - ~closing:Rparen ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple (typ :: moreArgs) - | _ -> - let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - | attrs -> - let first = - let optional, field = parseFieldDeclaration p in - let attrs = - if optional then optionalAttr :: attrs else attrs - in - {field with Parsetree.pld_attributes = attrs} - in - if p.token = Rbrace then [first] - else ( - Parser.expect Comma p; - first - :: parseCommaDelimitedRegion - ~grammar:Grammar.FieldDeclarations ~closing:Rbrace - ~f:parseFieldDeclarationRegion p) - in - Parser.expect Rbrace p; - Parser.optional p Comma |> ignore; - Parser.expect Rparen p; - Parsetree.Pcstr_record fields)) - | _ -> - let args = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - Parsetree.Pcstr_tuple args) - | _ -> Pcstr_tuple [] - in - let res = - match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseTypExpr p) - | _ -> None - in - (constrArgs, res) - -(* constr-decl ::= - * | constr-name - * | attrs constr-name - * | constr-name const-args - * | attrs constr-name const-args *) -and parseTypeConstructorDeclarationWithBar p = - match p.Parser.token with - | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - Some (parseTypeConstructorDeclaration ~startPos p) - | _ -> None - -and parseTypeConstructorDeclaration ~startPos p = - Parser.leaveBreadcrumb p Grammar.ConstructorDeclaration; - let attrs = parseAttributes p in - match p.Parser.token with - | DotDotDot -> - Parser.next p; - let name = Location.mkloc "..." (mkLoc startPos p.prevEndPos) in - let typ = parsePolyTypeExpr p in - let loc = mkLoc startPos typ.ptyp_loc.loc_end in - Ast_helper.Type.constructor ~loc ~attrs ~args:(Pcstr_tuple [typ]) name - | Uident uident -> - let uidentLoc = mkLoc p.startPos p.endPos in - Parser.next p; - let args, res = parseConstrDeclArgs p in - Parser.eatBreadcrumb p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.constructor ~loc ~attrs ?res ~args - (Location.mkloc uident uidentLoc) - | t -> - Parser.err p (Diagnostics.uident t); - Ast_helper.Type.constructor (Location.mknoloc "_") - -(* [|] constr-decl { | constr-decl } *) -and parseTypeConstructorDeclarations ?first p = - let firstConstrDecl = - match first with - | None -> - let startPos = p.Parser.startPos in - ignore (Parser.optional p Token.Bar); - parseTypeConstructorDeclaration ~startPos p - | Some firstConstrDecl -> firstConstrDecl - in - firstConstrDecl - :: parseRegion ~grammar:Grammar.ConstructorDeclaration - ~f:parseTypeConstructorDeclarationWithBar p - -(* - * type-representation ::= - * ∣ = [ | ] constr-decl { | constr-decl } - * ∣ = private [ | ] constr-decl { | constr-decl } - * | = | - * ∣ = private | - * ∣ = record-decl - * ∣ = private record-decl - * | = .. - *) -and parseTypeRepresentation p = - Parser.leaveBreadcrumb p Grammar.TypeRepresentation; - (* = consumed *) - let privateFlag = - if Parser.optional p Token.Private then Asttypes.Private - else Asttypes.Public - in - let kind = - match p.Parser.token with - | Bar | Uident _ -> - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p) - | Lbrace -> Parsetree.Ptype_record (parseRecordDeclaration p) - | DotDot -> - Parser.next p; - Ptype_open - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - (* TODO: I have no idea if this is even remotely a good idea *) - Parsetree.Ptype_variant [] - in - Parser.eatBreadcrumb p; - (privateFlag, kind) - -(* type-param ::= - * | variance 'lident - * | variance 'uident - * | variance _ - * - * variance ::= - * | + - * | - - * | (* empty *) - *) -and parseTypeParam p = - let variance = - match p.Parser.token with - | Plus -> - Parser.next p; - Asttypes.Covariant - | Minus -> - Parser.next p; - Contravariant - | _ -> Invariant - in - match p.Parser.token with - | SingleQuote -> - Parser.next p; - let ident, loc = - if p.Parser.token = Eof then ( - Parser.err ~startPos:p.startPos p - (Diagnostics.unexpected p.Parser.token p.breadcrumbs); - ("", mkLoc p.startPos p.prevEndPos)) - else parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - Some (Ast_helper.Typ.var ~loc ident, variance) - | Underscore -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Some (Ast_helper.Typ.any ~loc (), variance) - | (Uident _ | Lident _) as token -> - Parser.err p - (Diagnostics.message - ("Type params start with a singlequote: '" ^ Token.toString token)); - let ident, loc = - parseIdent ~msg:ErrorMessages.typeParam ~startPos:p.startPos p - in - Some (Ast_helper.Typ.var ~loc ident, variance) - | _token -> None - -(* type-params ::= - * | - * ∣ - * ∣ - * ∣ - * - * TODO: when we have pretty-printer show an error - * with the actual code corrected. *) -and parseTypeParams ~parent p = - let opening = p.Parser.token in - match opening with - | (LessThan | Lparen) when p.startPos.pos_lnum == p.prevEndPos.pos_lnum -> - Scanner.setDiamondMode p.scanner; - let openingStartPos = p.startPos in - Parser.leaveBreadcrumb p Grammar.TypeParams; - Parser.next p; - let params = - parseCommaDelimitedRegion ~grammar:Grammar.TypeParams ~closing:GreaterThan - ~f:parseTypeParam p - in - let () = - match p.token with - | Rparen when opening = Token.Lparen -> - let msg = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "Type parameters require angle brackets:"; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.concat - [ - ResPrinter.printLongident parent.Location.txt; - ResPrinter.printTypeParams params CommentTable.empty; - ]; - ]); - ]) - |> Doc.toString ~width:80 - in - Parser.err ~startPos:openingStartPos p (Diagnostics.message msg); - Parser.next p - | _ -> Parser.expect GreaterThan p - in - Scanner.popMode p.scanner Diamond; - Parser.eatBreadcrumb p; - params - | _ -> [] - -(* type-constraint ::= constraint ' ident = typexpr *) -and parseTypeConstraint p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Token.Constraint -> ( - Parser.next p; - Parser.expect SingleQuote p; - match p.Parser.token with - | Lident ident | Uident ident -> - let identLoc = mkLoc startPos p.endPos in - Parser.next p; - Parser.expect Equal p; - let typ = parseTypExpr p in - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.var ~loc:identLoc ident, typ, loc) - | t -> - Parser.err p (Diagnostics.lident t); - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Typ.any (), parseTypExpr p, loc)) - | _ -> None - -(* type-constraints ::= - * | (* empty *) - * | type-constraint - * | type-constraint type-constraint - * | type-constraint type-constraint type-constraint (* 0 or more *) - *) -and parseTypeConstraints p = - parseRegion ~grammar:Grammar.TypeConstraint ~f:parseTypeConstraint p - -and parseTypeEquationOrConstrDecl p = - let uidentStartPos = p.Parser.startPos in - match p.Parser.token with - | Uident uident -> ( - Parser.next p; - match p.Parser.token with - | Dot -> ( - Parser.next p; - let typeConstr = - parseValuePathTail p uidentStartPos (Longident.Lident uident) - in - let loc = mkLoc uidentStartPos p.prevEndPos in - let typ = - parseTypeAlias p - (Ast_helper.Typ.constr ~loc typeConstr - (parseTypeConstructorArgs ~constrName:typeConstr p)) - in - match p.token with - | Equal -> - Parser.next p; - let priv, kind = parseTypeRepresentation p in - (Some typ, priv, kind) - | EqualGreater -> - Parser.next p; - let returnType = parseTypExpr ~alias:false p in - let loc = mkLoc uidentStartPos p.prevEndPos in - let arrowType = - Ast_helper.Typ.arrow ~loc Asttypes.Nolabel typ returnType - in - let uncurried = p.uncurried_config <> Legacy in - let arrowType = - if uncurried then Ast_uncurried.uncurriedType ~loc ~arity:1 arrowType - else arrowType - in - let typ = parseTypeAlias p arrowType in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> (Some typ, Asttypes.Public, Parsetree.Ptype_abstract)) - | _ -> - let uidentEndPos = p.prevEndPos in - let args, res = parseConstrDeclArgs p in - let first = - Some - (let uidentLoc = mkLoc uidentStartPos uidentEndPos in - Ast_helper.Type.constructor - ~loc:(mkLoc uidentStartPos p.prevEndPos) - ?res ~args - (Location.mkloc uident uidentLoc)) - in - ( None, - Asttypes.Public, - Parsetree.Ptype_variant (parseTypeConstructorDeclarations p ?first) )) - | t -> - Parser.err p (Diagnostics.uident t); - (* TODO: is this a good idea? *) - (None, Asttypes.Public, Parsetree.Ptype_abstract) - -and parseRecordOrObjectDecl p = - let startPos = p.Parser.startPos in - Parser.expect Lbrace p; - match p.Parser.token with - | DotDot | Dot -> - let closedFlag = - match p.token with - | DotDot -> - Parser.next p; - Asttypes.Open - | Dot -> - Parser.next p; - Asttypes.Closed - | _ -> Asttypes.Closed - in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | DotDotDot -> ( - let dotdotdotStart = p.startPos in - let dotdotdotEnd = p.endPos in - (* start of object type spreading, e.g. `type u = {...a, "u": int}` *) - Parser.next p; - let typ = parseTypExpr p in - match p.token with - | Rbrace -> - (* {...x}, spread without extra fields *) - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - let dotField = - Ast_helper.Type.field ~loc - {txt = "..."; loc = mkLoc dotdotdotStart dotdotdotEnd} - typ - in - let kind = Parsetree.Ptype_record [dotField] in - (None, Public, kind) - | _ -> - Parser.expect Comma p; - let loc = mkLoc startPos p.prevEndPos in - let dotField = - Ast_helper.Type.field ~loc - {txt = "..."; loc = mkLoc dotdotdotStart dotdotdotEnd} - typ - in - let foundObjectField = ref false in - let fields = - parseCommaDelimitedRegion ~grammar:Grammar.RecordDecl ~closing:Rbrace - ~f:(parseFieldDeclarationRegion ~foundObjectField) - p - in - Parser.expect Rbrace p; - if !foundObjectField then - let fields = - Ext_list.map fields (fun ld -> - match ld.pld_name.txt with - | "..." -> Parsetree.Oinherit ld.pld_type - | _ -> Otag (ld.pld_name, ld.pld_attributes, ld.pld_type)) - in - let dotField = Parsetree.Oinherit typ in - let typ_obj = Ast_helper.Typ.object_ (dotField :: fields) Closed in - let typ_obj = parseTypeAlias p typ_obj in - let typ_obj = parseArrowTypeRest ~es6Arrow:true ~startPos typ_obj p in - (Some typ_obj, Public, Ptype_abstract) - else - let kind = Parsetree.Ptype_record (dotField :: fields) in - (None, Public, kind)) - | _ -> ( - let attrs = parseAttributes p in - match p.Parser.token with - | String _ -> - let closedFlag = Asttypes.Closed in - let fields = - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - | attrs -> - let first = - Parser.leaveBreadcrumb p Grammar.StringFieldDeclarations; - let field = - match parseStringFieldDeclaration p with - | Some field -> field - | None -> assert false - in - (* parse comma after first *) - let () = - match p.Parser.token with - | Rbrace | Eof -> () - | Comma -> Parser.next p - | _ -> Parser.expect Comma p - in - Parser.eatBreadcrumb p; - match field with - | Parsetree.Otag (label, _, ct) -> Parsetree.Otag (label, attrs, ct) - | Oinherit ct -> Oinherit ct - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.StringFieldDeclarations - ~closing:Rbrace ~f:parseStringFieldDeclaration p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - let typ = - Ast_helper.Typ.object_ ~loc ~attrs:[] fields closedFlag - |> parseTypeAlias p - in - let typ = parseArrowTypeRest ~es6Arrow:true ~startPos typ p in - (Some typ, Asttypes.Public, Parsetree.Ptype_abstract) - | _ -> - Parser.leaveBreadcrumb p Grammar.RecordDecl; - let fields = - (* XXX *) - match attrs with - | [] -> - parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - | attr :: _ as attrs -> - let first = - let optional, field = parseFieldDeclaration p in - let attrs = if optional then optionalAttr :: attrs else attrs in - Parser.optional p Comma |> ignore; - { - field with - Parsetree.pld_attributes = attrs; - pld_loc = - { - field.Parsetree.pld_loc with - loc_start = (attr |> fst).loc.loc_start; - }; - } - in - first - :: parseCommaDelimitedRegion ~grammar:Grammar.FieldDeclarations - ~closing:Rbrace ~f:parseFieldDeclarationRegion p - in - Parser.expect Rbrace p; - Parser.eatBreadcrumb p; - (None, Asttypes.Public, Parsetree.Ptype_record fields)) - -and parsePrivateEqOrRepr p = - Parser.expect Private p; - match p.Parser.token with - | Lbrace -> - let manifest, _, kind = parseRecordOrObjectDecl p in - (manifest, Asttypes.Private, kind) - | Uident _ -> - let manifest, _, kind = parseTypeEquationOrConstrDecl p in - (manifest, Asttypes.Private, kind) - | Bar | DotDot -> - let _, kind = parseTypeRepresentation p in - (None, Asttypes.Private, kind) - | t when Grammar.isTypExprStart t -> - (Some (parseTypExpr p), Asttypes.Private, Parsetree.Ptype_abstract) - | _ -> - let _, kind = parseTypeRepresentation p in - (None, Asttypes.Private, kind) - -(* - polymorphic-variant-type ::= - | [ tag-spec-first { | tag-spec } ] - | [> [ tag-spec ] { | tag-spec } ] - | [< [|] tag-spec-full { | tag-spec-full } [ > { `tag-name }+ ] ] - - tag-spec-first ::= `tag-name [ of typexpr ] - | [ typexpr ] | tag-spec - - tag-spec ::= `tag-name [ of typexpr ] - | typexpr - - tag-spec-full ::= `tag-name [ of [&] typexpr { & typexpr } ] - | typexpr -*) -and parsePolymorphicVariantType ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Lbracket p; - match p.token with - | GreaterThan -> - Parser.next p; - let rowFields = - match p.token with - | Rbracket -> [] - | Bar -> parseTagSpecs p - | _ -> - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p - in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc rowFields Open None - in - Parser.expect Rbracket p; - variant - | LessThan -> - Parser.next p; - Parser.optional p Bar |> ignore; - let rowField = parseTagSpecFull p in - let rowFields = parseTagSpecFulls p in - let tagNames = parseTagNames p in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowField :: rowFields) Closed - (Some tagNames) - in - Parser.expect Rbracket p; - variant - | _ -> - let rowFields1 = parseTagSpecFirst p in - let rowFields2 = parseTagSpecs p in - let variant = - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Typ.variant ~attrs ~loc (rowFields1 @ rowFields2) Closed None - in - Parser.expect Rbracket p; - variant - -and parseTagName p = - match p.Parser.token with - | Hash -> - let ident, _loc = parseHashIdent ~startPos:p.startPos p in - Some ident - | _ -> None - -and parseTagNames p = - if p.Parser.token == GreaterThan then ( - Parser.next p; - parseRegion p ~grammar:Grammar.TagNames ~f:parseTagName) - else [] - -and parseTagSpecFulls p = - match p.Parser.token with - | Rbracket -> [] - | GreaterThan -> [] - | Bar -> - Parser.next p; - let rowField = parseTagSpecFull p in - rowField :: parseTagSpecFulls p - | _ -> [] - -and parseTagSpecFull p = - let attrs = parseAttributes p in - match p.Parser.token with - | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:true p - | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ - -and parseTagSpecs p = - match p.Parser.token with - | Bar -> - Parser.next p; - let rowField = parseTagSpec p in - rowField :: parseTagSpecs p - | _ -> [] - -and parseTagSpec p = - let attrs = parseAttributes p in - match p.Parser.token with - | Hash -> parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p - | _ -> - let typ = parseTypExpr ~attrs p in - Parsetree.Rinherit typ - -and parseTagSpecFirst p = - let attrs = parseAttributes p in - match p.Parser.token with - | Bar -> - Parser.next p; - [parseTagSpec p] - | Hash -> [parsePolymorphicVariantTypeSpecHash ~attrs ~full:false p] - | _ -> ( - let typ = parseTypExpr ~attrs p in - match p.token with - | Rbracket -> - (* example: [ListStyleType.t] *) - [Parsetree.Rinherit typ] - | _ -> - Parser.expect Bar p; - [Parsetree.Rinherit typ; parseTagSpec p]) - -and parsePolymorphicVariantTypeSpecHash ~attrs ~full p : Parsetree.row_field = - let startPos = p.Parser.startPos in - let ident, loc = parseHashIdent ~startPos p in - let rec loop p = - match p.Parser.token with - | Band when full -> - Parser.next p; - let rowField = parsePolymorphicVariantTypeArgs p in - rowField :: loop p - | _ -> [] - in - let firstTuple, tagContainsAConstantEmptyConstructor = - match p.Parser.token with - | Band when full -> - Parser.next p; - ([parsePolymorphicVariantTypeArgs p], true) - | Lparen -> ([parsePolymorphicVariantTypeArgs p], false) - | _ -> ([], true) - in - let tuples = firstTuple @ loop p in - Parsetree.Rtag - ( Location.mkloc ident loc, - attrs, - tagContainsAConstantEmptyConstructor, - tuples ) - -and parsePolymorphicVariantTypeArgs p = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion ~grammar:Grammar.TypExprList ~closing:Rparen - ~f:parseTypExprRegion p - in - Parser.expect Rparen p; - let attrs = [] in - let loc = mkLoc startPos p.prevEndPos in - match args with - | [({ptyp_desc = Ptyp_tuple _} as typ)] as types -> - if p.mode = ParseForTypeChecker then typ - else Ast_helper.Typ.tuple ~loc ~attrs types - | [typ] -> typ - | types -> Ast_helper.Typ.tuple ~loc ~attrs types - -and parseTypeEquationAndRepresentation p = - match p.Parser.token with - | (Equal | Bar) as token -> ( - if token = Bar then Parser.expect Equal p; - Parser.next p; - match p.Parser.token with - | Uident _ -> parseTypeEquationOrConstrDecl p - | Lbrace -> parseRecordOrObjectDecl p - | Private -> parsePrivateEqOrRepr p - | Bar | DotDot -> - let priv, kind = parseTypeRepresentation p in - (None, priv, kind) - | _ -> ( - let manifest = Some (parseTypExpr p) in - match p.Parser.token with - | Equal -> - Parser.next p; - let priv, kind = parseTypeRepresentation p in - (manifest, priv, kind) - | _ -> (manifest, Public, Parsetree.Ptype_abstract))) - | _ -> (None, Public, Parsetree.Ptype_abstract) - -(* type-definition ::= type [rec] typedef { and typedef } - * typedef ::= typeconstr-name [type-params] type-information - * type-information ::= [type-equation] [type-representation] { type-constraint } - * type-equation ::= = typexpr *) -and parseTypeDef ~attrs ~startPos p = - Parser.leaveBreadcrumb p Grammar.TypeDef; - (* let attrs = match attrs with | Some attrs -> attrs | None -> parseAttributes p in *) - Parser.leaveBreadcrumb p Grammar.TypeConstrName; - let name, loc = parseLident p in - let typeConstrName = Location.mkloc name loc in - Parser.eatBreadcrumb p; - let params = - let constrName = Location.mkloc (Longident.Lident name) loc in - parseTypeParams ~parent:constrName p - in - let typeDef = - let manifest, priv, kind = parseTypeEquationAndRepresentation p in - let cstrs = parseTypeConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - typeConstrName - in - Parser.eatBreadcrumb p; - typeDef - -and parseTypeExtension ~params ~attrs ~name p = - Parser.expect PlusEqual p; - let priv = - if Parser.optional p Token.Private then Asttypes.Private - else Asttypes.Public - in - let constrStart = p.Parser.startPos in - Parser.optional p Bar |> ignore; - let first = - let attrs, name, kind = - match p.Parser.token with - | Bar -> - Parser.next p; - parseConstrDef ~parseAttrs:true p - | _ -> parseConstrDef ~parseAttrs:true p - in - let loc = mkLoc constrStart p.prevEndPos in - Ast_helper.Te.constructor ~loc ~attrs name kind - in - let rec loop p cs = - match p.Parser.token with - | Bar -> - let startPos = p.Parser.startPos in - Parser.next p; - let attrs, name, kind = parseConstrDef ~parseAttrs:true p in - let extConstr = - Ast_helper.Te.constructor ~attrs - ~loc:(mkLoc startPos p.prevEndPos) - name kind - in - loop p (extConstr :: cs) - | _ -> List.rev cs - in - let constructors = loop p [first] in - Ast_helper.Te.mk ~attrs ~params ~priv name constructors - -and parseTypeDefinitions ~attrs ~name ~params ~startPos p = - let typeDef = - let manifest, priv, kind = parseTypeEquationAndRepresentation p in - let cstrs = parseTypeConstraints p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Type.mk ~loc ~attrs ~priv ~kind ~params ~cstrs ?manifest - {name with txt = lidentOfPath name.Location.txt} - in - let rec loop p defs = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - Parser.next p; - let typeDef = parseTypeDef ~attrs ~startPos p in - loop p (typeDef :: defs) - | _ -> List.rev defs - in - loop p [typeDef] - -(* TODO: decide if we really want type extensions (eg. type x += Blue) - * It adds quite a bit of complexity that can be avoided, - * implemented for now. Needed to get a feel for the complexities of - * this territory of the grammar *) -and parseTypeDefinitionOrExtension ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Token.Typ p; - let recFlag = - match p.token with - | Rec -> - Parser.next p; - Asttypes.Recursive - | Lident "nonrec" -> - Parser.next p; - Asttypes.Nonrecursive - | _ -> Asttypes.Nonrecursive - in - let name = parseValuePath p in - let params = parseTypeParams ~parent:name p in - match p.Parser.token with - | PlusEqual -> TypeExt (parseTypeExtension ~params ~attrs ~name p) - | _ -> - (* shape of type name should be Lident, i.e. `t` is accepted. `User.t` not *) - let () = - match name.Location.txt with - | Lident _ -> () - | longident -> - Parser.err ~startPos:name.loc.loc_start ~endPos:name.loc.loc_end p - (longident |> ErrorMessages.typeDeclarationNameLongident - |> Diagnostics.message) - in - let typeDefs = parseTypeDefinitions ~attrs ~name ~params ~startPos p in - TypeDef {recFlag; types = typeDefs} - -(* external value-name : typexp = external-declaration *) -and parseExternalDef ~attrs ~startPos p = - let inExternal = !InExternal.status in - InExternal.status := true; - Parser.leaveBreadcrumb p Grammar.External; - Parser.expect Token.External p; - let name, loc = parseLident p in - let name = Location.mkloc name loc in - Parser.expect ~grammar:Grammar.TypeExpression Colon p; - let typExpr = parseTypExpr p in - let equalStart = p.startPos in - let equalEnd = p.endPos in - Parser.expect Equal p; - let prim = - match p.token with - | String s -> - Parser.next p; - [s] - | _ -> - Parser.err ~startPos:equalStart ~endPos:equalEnd p - (Diagnostics.message - ("An external requires the name of the JS value you're referring \ - to, like \"" ^ name.txt ^ "\".")); - [] - in - let loc = mkLoc startPos p.prevEndPos in - let vb = Ast_helper.Val.mk ~loc ~attrs ~prim name typExpr in - Parser.eatBreadcrumb p; - InExternal.status := inExternal; - vb - -(* constr-def ::= - * | constr-decl - * | constr-name = constr - * - * constr-decl ::= constr-name constr-args - * constr-name ::= uident - * constr ::= path-uident *) -and parseConstrDef ~parseAttrs p = - let attrs = if parseAttrs then parseAttributes p else [] in - let name = - match p.Parser.token with - | Uident name -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc name loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let kind = - match p.Parser.token with - | Lparen -> - let args, res = parseConstrDeclArgs p in - Parsetree.Pext_decl (args, res) - | Equal -> - Parser.next p; - let longident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pext_rebind longident - | Colon -> - Parser.next p; - let typ = parseTypExpr p in - Parsetree.Pext_decl (Pcstr_tuple [], Some typ) - | _ -> Parsetree.Pext_decl (Pcstr_tuple [], None) - in - (attrs, name, kind) - -(* - * exception-definition ::= - * | exception constr-decl - * ∣ exception constr-name = constr - * - * constr-name ::= uident - * constr ::= long_uident *) -and parseExceptionDef ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Token.Exception p; - let _, name, kind = parseConstrDef ~parseAttrs:false p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Te.constructor ~loc ~attrs name kind - -and parseNewlineOrSemicolonStructure p = - match p.Parser.token with - | Semicolon -> Parser.next p - | token when Grammar.isStructureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive statements on a line must be separated by ';' or a \ - newline") - | _ -> () - -and parseStructureItemRegion p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.open_ ~loc openDescription) - | Let -> - let recFlag, letBindings = parseLetBindings ~attrs ~startPos p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.value ~loc recFlag letBindings) - | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_ ~loc recFlag types) - | TypeExt ext -> - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Str.type_extension ~loc ext)) - | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.primitive ~loc externalDef) - | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.exception_ ~loc exceptionDef) - | Include -> - let includeStatement = parseIncludeStatement ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.include_ ~loc includeStatement) - | Module -> - Parser.beginRegion p; - let structureItem = parseModuleOrModuleTypeImplOrPackExpr ~attrs p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some {structureItem with pstr_loc = loc} - | ModuleComment (loc, s) -> - Parser.next p; - Some - (Ast_helper.Str.attribute ~loc - ( {txt = "res.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] )) - | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.attribute ~loc attr) - | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Str.extension ~attrs ~loc extension) - | token when Grammar.isExprStart token -> - let prevEndPos = p.Parser.endPos in - let exp = parseExpr p in - parseNewlineOrSemicolonStructure p; - let loc = mkLoc startPos p.prevEndPos in - Parser.checkProgress ~prevEndPos - ~result:(Ast_helper.Str.eval ~loc ~attrs exp) - p - | _ -> ( - match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - let expr = parseExpr p in - Some - (Ast_helper.Str.eval ~loc:(mkLoc p.startPos p.prevEndPos) ~attrs expr) - | _ -> None) -[@@progress Parser.next, Parser.expect, LoopProgress.listRest] - -(* include-statement ::= include module-expr *) -and parseIncludeStatement ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Token.Include p; - let modExpr = parseModuleExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Incl.mk ~loc ~attrs modExpr - -and parseAtomicModuleExpr p = - let startPos = p.Parser.startPos in - match p.Parser.token with - | Uident _ident -> - let longident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mod.ident ~loc:longident.loc longident - | Lbrace -> - Parser.next p; - let structure = - Ast_helper.Mod.structure - (parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rbrace - ~f:parseStructureItemRegion p) - in - Parser.expect Rbrace p; - let endPos = p.prevEndPos in - {structure with pmod_loc = mkLoc startPos endPos} - | Lparen -> - Parser.next p; - let modExpr = - match p.token with - | Rparen -> Ast_helper.Mod.structure ~loc:(mkLoc startPos p.prevEndPos) [] - | _ -> parseConstrainedModExpr p - in - Parser.expect Rparen p; - modExpr - | Lident "unpack" -> ( - (* TODO: should this be made a keyword?? *) - Parser.next p; - Parser.expect Lparen p; - let expr = parseExpr p in - match p.Parser.token with - | Colon -> - let colonStart = p.Parser.startPos in - Parser.next p; - let attrs = parseAttributes p in - let packageType = parsePackageType ~startPos:colonStart ~attrs p in - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - let constraintExpr = Ast_helper.Exp.constraint_ ~loc expr packageType in - Ast_helper.Mod.unpack ~loc constraintExpr - | _ -> - Parser.expect Rparen p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.unpack ~loc expr) - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mod.extension ~loc extension - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleExpr () - -and parsePrimaryModExpr p = - let startPos = p.Parser.startPos in - let modExpr = parseAtomicModuleExpr p in - let rec loop p modExpr = - match p.Parser.token with - | Lparen when p.prevEndPos.pos_lnum == p.startPos.pos_lnum -> - loop p (parseModuleApplication p modExpr) - | _ -> modExpr - in - let modExpr = loop p modExpr in - {modExpr with pmod_loc = mkLoc startPos p.prevEndPos} - -(* - * functor-arg ::= - * | uident : modtype - * | _ : modtype - * | modtype --> "punning" for _ : modtype - * | attributes functor-arg - *) -and parseFunctorArg p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Uident ident -> ( - Parser.next p; - let uidentEndPos = p.prevEndPos in - match p.Parser.token with - | Colon -> - Parser.next p; - let moduleType = parseModuleType p in - let loc = mkLoc startPos uidentEndPos in - let argName = Location.mkloc ident loc in - Some (attrs, argName, Some moduleType, startPos) - | Dot -> - Parser.next p; - let moduleType = - let moduleLongIdent = - parseModuleLongIdentTail ~lowercase:false p startPos - (Longident.Lident ident) - in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent - in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos) - | _ -> - let loc = mkLoc startPos uidentEndPos in - let modIdent = Location.mkloc (Longident.Lident ident) loc in - let moduleType = Ast_helper.Mty.ident ~loc modIdent in - let argName = Location.mknoloc "_" in - Some (attrs, argName, Some moduleType, startPos)) - | Underscore -> - Parser.next p; - let argName = Location.mkloc "_" (mkLoc startPos p.prevEndPos) in - Parser.expect Colon p; - let moduleType = parseModuleType p in - Some (attrs, argName, Some moduleType, startPos) - | Lparen -> - Parser.next p; - Parser.expect Rparen p; - let argName = Location.mkloc "*" (mkLoc startPos p.prevEndPos) in - Some (attrs, argName, None, startPos) - | _ -> None - -and parseFunctorArgs p = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion ~grammar:Grammar.FunctorArgs ~closing:Rparen - ~f:parseFunctorArg p - in - Parser.expect Rparen p; - match args with - | [] -> - [([], Location.mkloc "*" (mkLoc startPos p.prevEndPos), None, startPos)] - | args -> args - -and parseFunctorModuleExpr p = - let startPos = p.Parser.startPos in - let args = parseFunctorArgs p in - let returnType = - match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseModuleType ~es6Arrow:false p) - | _ -> None - in - Parser.expect EqualGreater p; - let rhsModuleExpr = - let modExpr = parseModuleExpr p in - match returnType with - | Some modType -> - Ast_helper.Mod.constraint_ - ~loc: - (mkLoc modExpr.pmod_loc.loc_start modType.Parsetree.pmty_loc.loc_end) - modExpr modType - | None -> modExpr - in - let endPos = p.prevEndPos in - let modExpr = - List.fold_right - (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mod.functor_ ~loc:(mkLoc startPos endPos) ~attrs name - moduleType acc) - args rhsModuleExpr - in - {modExpr with pmod_loc = mkLoc startPos endPos} - -(* module-expr ::= - * | module-path - * ∣ { structure-items } - * ∣ functorArgs => module-expr - * ∣ module-expr(module-expr) - * ∣ ( module-expr ) - * ∣ ( module-expr : module-type ) - * | extension - * | attributes module-expr *) -and parseModuleExpr p = - let hasAwait, loc_await = - let startPos = p.startPos in - match p.Parser.token with - | Await -> - Parser.expect Await p; - let endPos = p.endPos in - (true, mkLoc startPos endPos) - | _ -> (false, mkLoc startPos startPos) - in - let attrs = parseAttributes p in - let attrs = - if hasAwait then - (({txt = "res.await"; loc = loc_await}, PStr []) : Parsetree.attribute) - :: attrs - else attrs - in - let modExpr = - if isEs6ArrowFunctor p then parseFunctorModuleExpr p - else parsePrimaryModExpr p - in - {modExpr with pmod_attributes = List.concat [modExpr.pmod_attributes; attrs]} - -and parseConstrainedModExpr p = - let modExpr = parseModuleExpr p in - match p.Parser.token with - | Colon -> - Parser.next p; - let modType = parseModuleType p in - let loc = mkLoc modExpr.pmod_loc.loc_start modType.pmty_loc.loc_end in - Ast_helper.Mod.constraint_ ~loc modExpr modType - | _ -> modExpr - -and parseConstrainedModExprRegion p = - if Grammar.isModExprStart p.Parser.token then Some (parseConstrainedModExpr p) - else None - -and parseModuleApplication p modExpr = - let startPos = p.Parser.startPos in - Parser.expect Lparen p; - let args = - parseCommaDelimitedRegion ~grammar:Grammar.ModExprList ~closing:Rparen - ~f:parseConstrainedModExprRegion p - in - Parser.expect Rparen p; - let args = - match args with - | [] -> - let loc = mkLoc startPos p.prevEndPos in - [Ast_helper.Mod.structure ~loc []] - | args -> args - in - List.fold_left - (fun modExpr arg -> - Ast_helper.Mod.apply - ~loc: - (mkLoc modExpr.Parsetree.pmod_loc.loc_start - arg.Parsetree.pmod_loc.loc_end) - modExpr arg) - modExpr args - -and parseModuleOrModuleTypeImplOrPackExpr ~attrs p = - let startPos = p.Parser.startPos in - Parser.expect Module p; - match p.Parser.token with - | Typ -> parseModuleTypeImpl ~attrs startPos p - | Lparen -> - let expr = parseFirstClassModuleExpr ~startPos p in - let a = parsePrimaryExpr ~operand:expr p in - let expr = parseBinaryExpr ~a p 1 in - let expr = parseTernaryExpr expr p in - Ast_helper.Str.eval ~attrs expr - | _ -> parseMaybeRecModuleBinding ~attrs ~startPos p - -and parseModuleTypeImpl ~attrs startPos p = - Parser.expect Typ p; - let nameStart = p.Parser.startPos in - let name = - match p.Parser.token with - | Lident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc - | Uident ident -> - Parser.next p; - let loc = mkLoc nameStart p.prevEndPos in - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - Parser.expect Equal p; - let moduleType = parseModuleType p in - let moduleTypeDeclaration = - Ast_helper.Mtd.mk ~attrs - ~loc:(mkLoc nameStart p.prevEndPos) - ~typ:moduleType name - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Str.modtype ~loc moduleTypeDeclaration - -(* definition ::= - ∣ module rec module-name : module-type = module-expr { and module-name - : module-type = module-expr } *) -and parseMaybeRecModuleBinding ~attrs ~startPos p = - match p.Parser.token with - | Token.Rec -> - Parser.next p; - Ast_helper.Str.rec_module (parseModuleBindings ~startPos ~attrs p) - | _ -> - Ast_helper.Str.module_ - (parseModuleBinding ~attrs ~startPos:p.Parser.startPos p) - -and parseModuleBinding ~attrs ~startPos p = - let name = - match p.Parser.token with - | Uident ident -> - let startPos = p.Parser.startPos in - Parser.next p; - let loc = mkLoc startPos p.prevEndPos in - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = parseModuleBindingBody p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mb.mk ~attrs ~loc name body - -and parseModuleBindingBody p = - (* TODO: make required with good error message when rec module binding *) - let returnModType = - match p.Parser.token with - | Colon -> - Parser.next p; - Some (parseModuleType p) - | _ -> None - in - Parser.expect Equal p; - let modExpr = parseModuleExpr p in - match returnModType with - | Some modType -> - Ast_helper.Mod.constraint_ - ~loc:(mkLoc modType.pmty_loc.loc_start modExpr.pmod_loc.loc_end) - modExpr modType - | None -> modExpr - -(* module-name : module-type = module-expr - * { and module-name : module-type = module-expr } *) -and parseModuleBindings ~attrs ~startPos p = - let rec loop p acc = - let startPos = p.Parser.startPos in - let docAttr : Parsetree.attributes = - match p.Parser.token with - | DocComment (loc, s) -> - Parser.next p; - [docCommentToAttribute loc s] - | _ -> [] - in - let attrs = docAttr @ parseAttributesAndBinding p in - match p.Parser.token with - | And -> - Parser.next p; - ignore (Parser.optional p Module); - (* over-parse for fault-tolerance *) - let modBinding = parseModuleBinding ~attrs ~startPos p in - loop p (modBinding :: acc) - | _ -> List.rev acc - in - let first = parseModuleBinding ~attrs ~startPos p in - loop p [first] - -and parseAtomicModuleType p = - let startPos = p.Parser.startPos in - let moduleType = - match p.Parser.token with - | Uident _ | Lident _ -> - (* Ocaml allows module types to end with lowercase: module Foo : bar = { ... } - * lets go with uppercase terminal for now *) - let moduleLongIdent = parseModuleLongIdent ~lowercase:true p in - Ast_helper.Mty.ident ~loc:moduleLongIdent.loc moduleLongIdent - | Lparen -> - Parser.next p; - let mty = parseModuleType p in - Parser.expect Rparen p; - {mty with pmty_loc = mkLoc startPos p.prevEndPos} - | Lbrace -> - Parser.next p; - let spec = - parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rbrace - ~f:parseSignatureItemRegion p - in - Parser.expect Rbrace p; - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.signature ~loc spec - | Module -> - (* TODO: check if this is still atomic when implementing first class modules*) - parseModuleTypeOf p - | Percent -> - let extension = parseExtension p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Mty.extension ~loc extension - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () - in - let moduleTypeLoc = mkLoc startPos p.prevEndPos in - {moduleType with pmty_loc = moduleTypeLoc} - -and parseFunctorModuleType p = - let startPos = p.Parser.startPos in - let args = parseFunctorArgs p in - Parser.expect EqualGreater p; - let rhs = parseModuleType p in - let endPos = p.prevEndPos in - let modType = - List.fold_right - (fun (attrs, name, moduleType, startPos) acc -> - Ast_helper.Mty.functor_ ~loc:(mkLoc startPos endPos) ~attrs name - moduleType acc) - args rhs - in - {modType with pmty_loc = mkLoc startPos endPos} - -(* Module types are the module-level equivalent of type expressions: they - * specify the general shape and type properties of modules. - * - * module-type ::= - * | modtype-path - * | { signature } - * | ( module-type ) --> parenthesized module-type - * | functor-args => module-type --> functor - * | module-type => module-type --> functor - * | module type of module-expr - * | attributes module-type - * | module-type with-mod-constraints - * | extension - *) -and parseModuleType ?(es6Arrow = true) ?(with_ = true) p = - let attrs = parseAttributes p in - let modty = - if es6Arrow && isEs6ArrowFunctor p then parseFunctorModuleType p - else - let modty = parseAtomicModuleType p in - match p.Parser.token with - | EqualGreater when es6Arrow == true -> - Parser.next p; - let rhs = parseModuleType ~with_:false p in - let str = Location.mknoloc "_" in - let loc = mkLoc modty.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.functor_ ~loc str (Some modty) rhs - | _ -> modty - in - let moduleType = - {modty with pmty_attributes = List.concat [modty.pmty_attributes; attrs]} - in - if with_ then parseWithConstraints moduleType p else moduleType - -and parseWithConstraints moduleType p = - match p.Parser.token with - | Lident "with" -> - Parser.next p; - let first = parseWithConstraint p in - let rec loop p acc = - match p.Parser.token with - | And -> - Parser.next p; - loop p (parseWithConstraint p :: acc) - | _ -> List.rev acc - in - let constraints = loop p [first] in - let loc = mkLoc moduleType.pmty_loc.loc_start p.prevEndPos in - Ast_helper.Mty.with_ ~loc moduleType constraints - | _ -> moduleType - -(* mod-constraint ::= - * | type typeconstr type-equation type-constraints? - * ∣ type typeconstr-name := typexpr - * ∣ module module-path = extended-module-path - * ∣ module module-path := extended-module-path - * - * TODO: split this up into multiple functions, better errors *) -and parseWithConstraint p = - match p.Parser.token with - | Module -> ( - Parser.next p; - let modulePath = parseModuleLongIdent ~lowercase:false p in - match p.Parser.token with - | ColonEqual -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident) - | Equal -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_module (modulePath, lident) - | token -> - (* TODO: revisit *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let lident = parseModuleLongIdent ~lowercase:false p in - Parsetree.Pwith_modsubst (modulePath, lident)) - | Typ -> ( - Parser.next p; - let typeConstr = parseValuePath p in - let params = parseTypeParams ~parent:typeConstr p in - match p.Parser.token with - | ColonEqual -> - Parser.next p; - let typExpr = parseTypExpr p in - Parsetree.Pwith_typesubst - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) - | Equal -> - Parser.next p; - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) ) - | token -> - (* TODO: revisit *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - let typExpr = parseTypExpr p in - let typeConstraints = parseTypeConstraints p in - Parsetree.Pwith_type - ( typeConstr, - Ast_helper.Type.mk ~loc:typeConstr.loc ~params ~manifest:typExpr - ~cstrs:typeConstraints - (Location.mkloc (Longident.last typeConstr.txt) typeConstr.loc) )) - | token -> - (* TODO: implement recovery strategy *) - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Parsetree.Pwith_type - ( Location.mknoloc (Longident.Lident ""), - Ast_helper.Type.mk ~params:[] ~manifest:(Recover.defaultType ()) - ~cstrs:[] (Location.mknoloc "") ) - -and parseModuleTypeOf p = - let startPos = p.Parser.startPos in - Parser.expect Module p; - Parser.expect Typ p; - Parser.expect Of p; - let moduleExpr = parseModuleExpr p in - Ast_helper.Mty.typeof_ ~loc:(mkLoc startPos p.prevEndPos) moduleExpr - -and parseNewlineOrSemicolonSignature p = - match p.Parser.token with - | Semicolon -> Parser.next p - | token when Grammar.isSignatureItemStart token -> - if p.prevEndPos.pos_lnum < p.startPos.pos_lnum then () - else - Parser.err ~startPos:p.prevEndPos ~endPos:p.endPos p - (Diagnostics.message - "consecutive specifications on a line must be separated by ';' or a \ - newline") - | _ -> () - -and parseSignatureItemRegion p = - let startPos = p.Parser.startPos in - let attrs = parseAttributes p in - match p.Parser.token with - | Let -> - Parser.beginRegion p; - let valueDesc = parseSignLetDesc ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.value ~loc valueDesc) - | Typ -> ( - Parser.beginRegion p; - match parseTypeDefinitionOrExtension ~attrs p with - | TypeDef {recFlag; types} -> - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.type_ ~loc recFlag types) - | TypeExt ext -> - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.type_extension ~loc ext)) - | External -> - let externalDef = parseExternalDef ~attrs ~startPos p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.value ~loc externalDef) - | Exception -> - let exceptionDef = parseExceptionDef ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.exception_ ~loc exceptionDef) - | Open -> - let openDescription = parseOpenDescription ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.open_ ~loc openDescription) - | Include -> - Parser.next p; - let moduleType = parseModuleType p in - let includeDescription = - Ast_helper.Incl.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs moduleType - in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.include_ ~loc includeDescription) - | Module -> ( - Parser.beginRegion p; - Parser.next p; - match p.Parser.token with - | Uident _ -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl) - | Rec -> - let recModule = parseRecModuleSpec ~attrs ~startPos p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.rec_module ~loc recModule) - | Typ -> - let modTypeDecl = parseModuleTypeDeclaration ~attrs ~startPos p in - Parser.endRegion p; - Some modTypeDecl - | _t -> - let modDecl = parseModuleDeclarationOrAlias ~attrs p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Parser.endRegion p; - Some (Ast_helper.Sig.module_ ~loc modDecl)) - | AtAt -> - let attr = parseStandaloneAttribute p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.attribute ~loc attr) - | ModuleComment (loc, s) -> - Parser.next p; - Some - (Ast_helper.Sig.attribute ~loc - ( {txt = "res.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] )) - | PercentPercent -> - let extension = parseExtension ~moduleLanguage:true p in - parseNewlineOrSemicolonSignature p; - let loc = mkLoc startPos p.prevEndPos in - Some (Ast_helper.Sig.extension ~attrs ~loc extension) - | _ -> ( - match attrs with - | (({Asttypes.loc = attrLoc}, _) as attr) :: _ -> - Parser.err ~startPos:attrLoc.loc_start ~endPos:attrLoc.loc_end p - (Diagnostics.message (ErrorMessages.attributeWithoutNode attr)); - Some Recover.defaultSignatureItem - | _ -> None) -[@@progress Parser.next, Parser.expect, LoopProgress.listRest] - -(* module rec module-name : module-type { and module-name: module-type } *) -and parseRecModuleSpec ~attrs ~startPos p = - Parser.expect Rec p; - let rec loop p spec = - let startPos = p.Parser.startPos in - let attrs = parseAttributesAndBinding p in - match p.Parser.token with - | And -> - (* TODO: give a good error message when with constraint, no parens - * and ASet: (Set.S with type elt = A.t) - * and BTree: (Btree.S with type elt = A.t) - * Without parens, the `and` signals the start of another - * `with-constraint` - *) - Parser.expect And p; - let decl = parseRecModuleDeclaration ~attrs ~startPos p in - loop p (decl :: spec) - | _ -> List.rev spec - in - let first = parseRecModuleDeclaration ~attrs ~startPos p in - loop p [first] - -(* module-name : module-type *) -and parseRecModuleDeclaration ~attrs ~startPos p = - let name = - match p.Parser.token with - | Uident modName -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc modName loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - Parser.expect Colon p; - let modType = parseModuleType p in - Ast_helper.Md.mk ~loc:(mkLoc startPos p.prevEndPos) ~attrs name modType - -and parseModuleDeclarationOrAlias ~attrs p = - let startPos = p.Parser.startPos in - let moduleName = - match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.Parser.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let body = - match p.Parser.token with - | Colon -> - Parser.next p; - parseModuleType p - | Equal -> - Parser.next p; - let lident = parseModuleLongIdent ~lowercase:false p in - Ast_helper.Mty.alias lident - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - Recover.defaultModuleType () - in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Md.mk ~loc ~attrs moduleName body - -and parseModuleTypeDeclaration ~attrs ~startPos p = - Parser.expect Typ p; - let moduleName = - match p.Parser.token with - | Uident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | Lident ident -> - let loc = mkLoc p.startPos p.endPos in - Parser.next p; - Location.mkloc ident loc - | t -> - Parser.err p (Diagnostics.uident t); - Location.mknoloc "_" - in - let typ = - match p.Parser.token with - | Equal -> - Parser.next p; - Some (parseModuleType p) - | _ -> None - in - let moduleDecl = Ast_helper.Mtd.mk ~attrs ?typ moduleName in - Ast_helper.Sig.modtype ~loc:(mkLoc startPos p.prevEndPos) moduleDecl - -and parseSignLetDesc ~attrs p = - let startPos = p.Parser.startPos in - Parser.optional p Let |> ignore; - let name, loc = parseLident p in - let name = Location.mkloc name loc in - Parser.expect Colon p; - let typExpr = parsePolyTypeExpr p in - let loc = mkLoc startPos p.prevEndPos in - Ast_helper.Val.mk ~loc ~attrs name typExpr - -(* attr-id ::= lowercase-ident - ∣ capitalized-ident - ∣ attr-id . attr-id *) -and parseAttributeId ~startPos p = - let rec loop p acc = - match p.Parser.token with - | Lident ident | Uident ident -> ( - Parser.next p; - let id = acc ^ ident in - match p.Parser.token with - | Dot -> - Parser.next p; - loop p (id ^ ".") - | _ -> id) - | token when Token.isKeyword token -> ( - Parser.next p; - let id = acc ^ Token.toString token in - match p.Parser.token with - | Dot -> - Parser.next p; - loop p (id ^ ".") - | _ -> id) - | token -> - Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - acc - in - let id = loop p "" in - let endPos = p.prevEndPos in - Location.mkloc id (mkLoc startPos endPos) - -(* - * payload ::= empty - * | ( structure-item ) - * - * TODO: what about multiple structure items? - * @attr({let x = 1; let x = 2}) - * - * Also what about type-expressions and specifications? - * @attr(:myType) ??? - *) -and parsePayload p = - match p.Parser.token with - | Lparen when p.startPos.pos_cnum = p.prevEndPos.pos_cnum -> ( - Parser.leaveBreadcrumb p Grammar.AttributePayload; - Parser.next p; - match p.token with - | Colon -> - Parser.next p; - let payload = - if Grammar.isSignatureItemStart p.token then - Parsetree.PSig - (parseDelimitedRegion ~grammar:Grammar.Signature ~closing:Rparen - ~f:parseSignatureItemRegion p) - else Parsetree.PTyp (parseTypExpr p) - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - payload - | Question -> - Parser.next p; - let pattern = parsePattern p in - let expr = - match p.token with - | When | If -> - Parser.next p; - Some (parseExpr p) - | _ -> None - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - Parsetree.PPat (pattern, expr) - | _ -> - let items = - parseDelimitedRegion ~grammar:Grammar.Structure ~closing:Rparen - ~f:parseStructureItemRegion p - in - Parser.expect Rparen p; - Parser.eatBreadcrumb p; - Parsetree.PStr items) - | _ -> Parsetree.PStr [] - -(* type attribute = string loc * payload *) -and parseAttribute p = - match p.Parser.token with - | At -> - let startPos = p.startPos in - Parser.next p; - let attrId = parseAttributeId ~startPos p in - let payload = parsePayload p in - Some (attrId, payload) - | DocComment (loc, s) -> - Parser.next p; - Some (docCommentToAttribute loc s) - | _ -> None - -and docCommentToAttribute loc s : Parsetree.attribute = - ( {txt = "res.doc"; loc}, - PStr - [ - Ast_helper.Str.eval ~loc - (Ast_helper.Exp.constant ~loc (Pconst_string (s, None))); - ] ) - -and parseAttributes p = - parseRegion p ~grammar:Grammar.Attribute ~f:parseAttribute - -(* - * standalone-attribute ::= - * | @@ atribute-id - * | @@ attribute-id ( structure-item ) - *) -and parseStandaloneAttribute p = - let startPos = p.startPos in - Parser.expect AtAt p; - let attrId = parseAttributeId ~startPos p in - let attrId = - match attrId.txt with - | "uncurried.swap" -> - p.uncurried_config <- Config.Swap; - attrId - | "uncurried" -> - p.uncurried_config <- Config.Uncurried; - attrId - | _ -> attrId - in - let payload = parsePayload p in - (attrId, payload) - -(* extension ::= % attr-id attr-payload - * | %% attr-id( - * expr ::= ... - * ∣ extension - * - * typexpr ::= ... - * ∣ extension - * - * pattern ::= ... - * ∣ extension - * - * module-expr ::= ... - * ∣ extension - * - * module-type ::= ... - * ∣ extension - * - * class-expr ::= ... - * ∣ extension - * - * class-type ::= ... - * ∣ extension - * - * - * item extension nodes usable in structures and signature - * - * item-extension ::= %% attr-id - * | %% attr-id(structure-item) - * - * attr-payload ::= structure-item - * - * ~moduleLanguage represents whether we're on the module level or not - *) -and parseExtension ?(moduleLanguage = false) p = - let startPos = p.Parser.startPos in - if moduleLanguage then Parser.expect PercentPercent p - else Parser.expect Percent p; - let attrId = parseAttributeId ~startPos p in - let payload = parsePayload p in - (attrId, payload) - -(* module signature on the file level *) -let parseSpecification p : Parsetree.signature = - parseRegion p ~grammar:Grammar.Specification ~f:parseSignatureItemRegion - -(* module structure on the file level *) -let parseImplementation p : Parsetree.structure = - parseRegion p ~grammar:Grammar.Implementation ~f:parseStructureItemRegion diff --git a/jscomp/syntax/src/res_core.mli b/jscomp/syntax/src/res_core.mli deleted file mode 100644 index e77ca30..0000000 --- a/jscomp/syntax/src/res_core.mli +++ /dev/null @@ -1,2 +0,0 @@ -val parseImplementation : Res_parser.t -> Parsetree.structure -val parseSpecification : Res_parser.t -> Parsetree.signature diff --git a/jscomp/syntax/src/res_diagnostics.ml b/jscomp/syntax/src/res_diagnostics.ml deleted file mode 100644 index 3b1da15..0000000 --- a/jscomp/syntax/src/res_diagnostics.ml +++ /dev/null @@ -1,172 +0,0 @@ -module Grammar = Res_grammar -module Token = Res_token - -type category = - | Unexpected of {token: Token.t; context: (Grammar.t * Lexing.position) list} - | Expected of { - context: Grammar.t option; - pos: Lexing.position; (* prev token end*) - token: Token.t; - } - | Message of string - | Uident of Token.t - | Lident of Token.t - | UnclosedString - | UnclosedTemplate - | UnclosedComment - | UnknownUchar of Char.t - -type t = { - startPos: Lexing.position; - endPos: Lexing.position; - category: category; -} - -type report = t list - -let getStartPos t = t.startPos -let getEndPos t = t.endPos - -let defaultUnexpected token = - "I'm not sure what to parse here when looking at \"" ^ Token.toString token - ^ "\"." - -let reservedKeyword token = - let tokenTxt = Token.toString token in - "`" ^ tokenTxt ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ tokenTxt ^ "\"" - -let explain t = - match t.category with - | Uident currentToken -> ( - match currentToken with - | Lident lident -> - let guess = String.capitalize_ascii lident in - "Did you mean `" ^ guess ^ "` instead of `" ^ lident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword." - | _ -> - "At this point, I'm looking for an uppercased name like `Belt` or `Array`" - ) - | Lident currentToken -> ( - match currentToken with - | Uident uident -> - let guess = String.uncapitalize_ascii uident in - "Did you mean `" ^ guess ^ "` instead of `" ^ uident ^ "`?" - | t when Token.isKeyword t -> - let token = Token.toString t in - "`" ^ token ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ token ^ "\"" - | Underscore -> "`_` isn't a valid name." - | _ -> "I'm expecting a lowercase name like `user or `age`") - | Message txt -> txt - | UnclosedString -> "This string is missing a double quote at the end" - | UnclosedTemplate -> - "Did you forget to close this template expression with a backtick?" - | UnclosedComment -> "This comment seems to be missing a closing `*/`" - | UnknownUchar uchar -> ( - match uchar with - | '^' -> - "Not sure what to do with this character.\n" - ^ " If you're trying to dereference a mutable value, use \ - `myValue.contents` instead.\n" - ^ " To concatenate strings, use `\"a\" ++ \"b\"` instead." - | _ -> "Not sure what to do with this character.") - | Expected {context; token = t} -> - let hint = - match context with - | Some grammar -> " It signals the start of " ^ Grammar.toString grammar - | None -> "" - in - "Did you forget a `" ^ Token.toString t ^ "` here?" ^ hint - | Unexpected {token = t; context = breadcrumbs} -> ( - let name = Token.toString t in - match breadcrumbs with - | (AtomicTypExpr, _) :: breadcrumbs -> ( - match (breadcrumbs, t) with - | ( ((StringFieldDeclarations | FieldDeclarations), _) :: _, - (String _ | At | Rbrace | Comma | Eof) ) -> - "I'm missing a type here" - | _, t when Grammar.isStructureItemStart t || t = Eof -> - "Missing a type here" - | _ -> defaultUnexpected t) - | (ExprOperand, _) :: breadcrumbs -> ( - match (breadcrumbs, t) with - | (ExprBlock, _) :: _, Rbrace -> - "It seems that this expression block is empty" - | (ExprBlock, _) :: _, Bar -> - (* Pattern matching *) - "Looks like there might be an expression missing here" - | (ExprSetField, _) :: _, _ -> - "It seems that this record field mutation misses an expression" - | (ExprArrayMutation, _) :: _, _ -> - "Seems that an expression is missing, with what do I mutate the array?" - | ((ExprBinaryAfterOp _ | ExprUnary), _) :: _, _ -> - "Did you forget to write an expression here?" - | (Grammar.LetBinding, _) :: _, _ -> - "This let-binding misses an expression" - | _ :: _, (Rbracket | Rbrace | Eof) -> "Missing expression" - | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - ) - | (TypeParam, _) :: _ -> ( - match t with - | Lident ident -> - "Did you mean '" ^ ident ^ "? A Type parameter starts with a quote." - | _ -> "I'm not sure what to parse here when looking at \"" ^ name ^ "\"." - ) - | (Pattern, _) :: breadcrumbs -> ( - match (t, breadcrumbs) with - | Equal, (LetBinding, _) :: _ -> - "I was expecting a name for this let-binding. Example: `let message = \ - \"hello\"`" - | In, (ExprFor, _) :: _ -> - "A for-loop has the following form: `for i in 0 to 10`. Did you forget \ - to supply a name before `in`?" - | EqualGreater, (PatternMatchCase, _) :: _ -> - "I was expecting a pattern to match on before the `=>`" - | token, _ when Token.isKeyword t -> reservedKeyword token - | token, _ -> defaultUnexpected token) - | _ -> - (* TODO: match on circumstance to verify Lident needed ? *) - if Token.isKeyword t then - "`" ^ name - ^ "` is a reserved keyword. Keywords need to be escaped: \\\"" - ^ Token.toString t ^ "\"" - else "I'm not sure what to parse here when looking at \"" ^ name ^ "\".") - -let make ~startPos ~endPos category = {startPos; endPos; category} - -let printReport diagnostics src = - let rec print diagnostics src = - match diagnostics with - | [] -> () - | d :: rest -> - Location.report_error ~src:(Some src) Format.err_formatter - Location. - { - loc = {loc_start = d.startPos; loc_end = d.endPos; loc_ghost = false}; - msg = explain d; - sub = []; - if_highlight = ""; - }; - (match rest with - | [] -> () - | _ -> Format.fprintf Format.err_formatter "@."); - print rest src - in - Format.fprintf Format.err_formatter "@["; - print (List.rev diagnostics) src; - Format.fprintf Format.err_formatter "@]@." - -let unexpected token context = Unexpected {token; context} - -let expected ?grammar pos token = Expected {context = grammar; pos; token} - -let uident currentToken = Uident currentToken -let lident currentToken = Lident currentToken -let unclosedString = UnclosedString -let unclosedComment = UnclosedComment -let unclosedTemplate = UnclosedTemplate -let unknownUchar code = UnknownUchar code -let message txt = Message txt diff --git a/jscomp/syntax/src/res_diagnostics.mli b/jscomp/syntax/src/res_diagnostics.mli deleted file mode 100644 index 0ae74ce..0000000 --- a/jscomp/syntax/src/res_diagnostics.mli +++ /dev/null @@ -1,25 +0,0 @@ -module Token = Res_token -module Grammar = Res_grammar - -type t -type category -type report - -val getStartPos : t -> Lexing.position [@@live] (* for playground *) -val getEndPos : t -> Lexing.position [@@live] (* for playground *) - -val explain : t -> string [@@live] (* for playground *) - -val unexpected : Token.t -> (Grammar.t * Lexing.position) list -> category -val expected : ?grammar:Grammar.t -> Lexing.position -> Token.t -> category -val uident : Token.t -> category -val lident : Token.t -> category -val unclosedString : category -val unclosedTemplate : category -val unclosedComment : category -val unknownUchar : Char.t -> category -val message : string -> category - -val make : startPos:Lexing.position -> endPos:Lexing.position -> category -> t - -val printReport : t list -> string -> unit diff --git a/jscomp/syntax/src/res_doc.ml b/jscomp/syntax/src/res_doc.ml deleted file mode 100644 index fe626e4..0000000 --- a/jscomp/syntax/src/res_doc.ml +++ /dev/null @@ -1,350 +0,0 @@ -module MiniBuffer = Res_minibuffer - -type mode = Break | Flat - -type lineStyle = - | Classic (* fits? -> replace with space *) - | Soft (* fits? -> replaced with nothing *) - | Hard - (* always included, forces breaks in parents *) - (* always included, forces breaks in parents, but doesn't increase indentation - use case: template literals, multiline string content *) - | Literal - -type t = - | Nil - | Text of string - | Concat of t list - | Indent of t - | IfBreaks of {yes: t; no: t; mutable broken: bool} - (* when broken is true, treat as the yes branch *) - | LineSuffix of t - | LineBreak of lineStyle - | Group of {mutable shouldBreak: bool; doc: t} - | CustomLayout of t list - | BreakParent - -let nil = Nil -let line = LineBreak Classic -let hardLine = LineBreak Hard -let softLine = LineBreak Soft -let literalLine = LineBreak Literal -let text s = Text s - -(* Optimization. We eagerly collapse and reduce whatever allocation we can *) -let rec _concat acc l = - match l with - | Text s1 :: Text s2 :: rest -> Text (s1 ^ s2) :: _concat acc rest - | Nil :: rest -> _concat acc rest - | Concat l2 :: rest -> - _concat (_concat acc rest) l2 (* notice the order here *) - | x :: rest -> - let rest1 = _concat acc rest in - if rest1 == rest then l else x :: rest1 - | [] -> acc - -let concat l = Concat (_concat [] l) - -let indent d = Indent d -let ifBreaks t f = IfBreaks {yes = t; no = f; broken = false} -let lineSuffix d = LineSuffix d -let group d = Group {shouldBreak = false; doc = d} -let breakableGroup ~forceBreak d = Group {shouldBreak = forceBreak; doc = d} -let customLayout gs = CustomLayout gs -let breakParent = BreakParent - -let space = Text " " -let comma = Text "," -let dot = Text "." -let dotdot = Text ".." -let dotdotdot = Text "..." -let lessThan = Text "<" -let greaterThan = Text ">" -let lbrace = Text "{" -let rbrace = Text "}" -let lparen = Text "(" -let rparen = Text ")" -let lbracket = Text "[" -let rbracket = Text "]" -let question = Text "?" -let tilde = Text "~" -let equal = Text "=" -let trailingComma = ifBreaks comma nil -let doubleQuote = Text "\"" - -let propagateForcedBreaks doc = - let rec walk doc = - match doc with - | Text _ | Nil | LineSuffix _ -> false - | BreakParent -> true - | LineBreak (Hard | Literal) -> true - | LineBreak (Classic | Soft) -> false - | Indent children -> - let childForcesBreak = walk children in - childForcesBreak - | IfBreaks ({yes = trueDoc; no = falseDoc} as ib) -> - let falseForceBreak = walk falseDoc in - if falseForceBreak then ( - let _ = walk trueDoc in - ib.broken <- true; - true) - else - let forceBreak = walk trueDoc in - forceBreak - | Group ({shouldBreak = forceBreak; doc = children} as gr) -> - let childForcesBreak = walk children in - let shouldBreak = forceBreak || childForcesBreak in - gr.shouldBreak <- shouldBreak; - shouldBreak - | Concat children -> - List.fold_left - (fun forceBreak child -> - let childForcesBreak = walk child in - forceBreak || childForcesBreak) - false children - | CustomLayout children -> - (* When using CustomLayout, we don't want to propagate forced breaks - * from the children up. By definition it picks the first layout that fits - * otherwise it takes the last of the list. - * However we do want to propagate forced breaks in the sublayouts. They - * might need to be broken. We just don't propagate them any higher here *) - let _ = walk (Concat children) in - false - in - let _ = walk doc in - () - -(* See documentation in interface file *) -let rec willBreak doc = - match doc with - | LineBreak (Hard | Literal) | BreakParent | Group {shouldBreak = true} -> - true - | Group {doc} | Indent doc | CustomLayout (doc :: _) -> willBreak doc - | Concat docs -> List.exists willBreak docs - | IfBreaks {yes; no} -> willBreak yes || willBreak no - | _ -> false - -let join ~sep docs = - let rec loop acc sep docs = - match docs with - | [] -> List.rev acc - | [x] -> List.rev (x :: acc) - | x :: xs -> loop (sep :: x :: acc) sep xs - in - concat (loop [] sep docs) - -let joinWithSep docsWithSep = - let rec loop acc docs = - match docs with - | [] -> List.rev acc - | [(x, _sep)] -> List.rev (x :: acc) - | (x, sep) :: xs -> loop (sep :: x :: acc) xs - in - concat (loop [] docsWithSep) - -let fits w stack = - let width = ref w in - let result = ref None in - - let rec calculate indent mode doc = - match (mode, doc) with - | _ when result.contents != None -> () - | _ when width.contents < 0 -> result := Some false - | _, Nil | _, LineSuffix _ | _, BreakParent -> () - | _, Text txt -> width := width.contents - String.length txt - | _, Indent doc -> calculate (indent + 2) mode doc - | Flat, LineBreak Hard | Flat, LineBreak Literal -> result := Some true - | Flat, LineBreak Classic -> width := width.contents - 1 - | Flat, LineBreak Soft -> () - | Break, LineBreak _ -> result := Some true - | _, Group {shouldBreak = true; doc} -> calculate indent Break doc - | _, Group {doc} -> calculate indent mode doc - | _, IfBreaks {yes = breakDoc; broken = true} -> - calculate indent mode breakDoc - | Break, IfBreaks {yes = breakDoc} -> calculate indent mode breakDoc - | Flat, IfBreaks {no = flatDoc} -> calculate indent mode flatDoc - | _, Concat docs -> calculateConcat indent mode docs - | _, CustomLayout (hd :: _) -> - (* TODO: if we have nested custom layouts, what we should do here? *) - calculate indent mode hd - | _, CustomLayout [] -> () - and calculateConcat indent mode docs = - if result.contents == None then - match docs with - | [] -> () - | doc :: rest -> - calculate indent mode doc; - calculateConcat indent mode rest - in - let rec calculateAll stack = - match (result.contents, stack) with - | Some r, _ -> r - | None, [] -> !width >= 0 - | None, (indent, mode, doc) :: rest -> - calculate indent mode doc; - calculateAll rest - in - calculateAll stack - -let toString ~width doc = - propagateForcedBreaks doc; - let buffer = MiniBuffer.create 1000 in - - let rec process ~pos lineSuffices stack = - match stack with - | ((ind, mode, doc) as cmd) :: rest -> ( - match doc with - | Nil | BreakParent -> process ~pos lineSuffices rest - | Text txt -> - MiniBuffer.add_string buffer txt; - process ~pos:(String.length txt + pos) lineSuffices rest - | LineSuffix doc -> process ~pos ((ind, mode, doc) :: lineSuffices) rest - | Concat docs -> - let ops = List.map (fun doc -> (ind, mode, doc)) docs in - process ~pos lineSuffices (List.append ops rest) - | Indent doc -> process ~pos lineSuffices ((ind + 2, mode, doc) :: rest) - | IfBreaks {yes = breakDoc; broken = true} -> - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - | IfBreaks {yes = breakDoc; no = flatDoc} -> - if mode = Break then - process ~pos lineSuffices ((ind, mode, breakDoc) :: rest) - else process ~pos lineSuffices ((ind, mode, flatDoc) :: rest) - | LineBreak lineStyle -> - if mode = Break then - match lineSuffices with - | [] -> - if lineStyle = Literal then ( - MiniBuffer.add_char buffer '\n'; - process ~pos:0 [] rest) - else ( - MiniBuffer.flush_newline buffer; - MiniBuffer.add_string buffer (String.make ind ' ' [@doesNotRaise]); - process ~pos:ind [] rest) - | _docs -> - process ~pos:ind [] - (List.concat [List.rev lineSuffices; cmd :: rest]) - else - (* mode = Flat *) - let pos = - match lineStyle with - | Classic -> - MiniBuffer.add_string buffer " "; - pos + 1 - | Hard -> - MiniBuffer.flush_newline buffer; - 0 - | Literal -> - MiniBuffer.add_char buffer '\n'; - 0 - | Soft -> pos - in - process ~pos lineSuffices rest - | Group {shouldBreak; doc} -> - if shouldBreak || not (fits (width - pos) ((ind, Flat, doc) :: rest)) - then process ~pos lineSuffices ((ind, Break, doc) :: rest) - else process ~pos lineSuffices ((ind, Flat, doc) :: rest) - | CustomLayout docs -> - let rec findGroupThatFits groups = - match groups with - | [] -> Nil - | [lastGroup] -> lastGroup - | doc :: docs -> - if fits (width - pos) ((ind, Flat, doc) :: rest) then doc - else findGroupThatFits docs - in - let doc = findGroupThatFits docs in - process ~pos lineSuffices ((ind, Flat, doc) :: rest)) - | [] -> ( - match lineSuffices with - | [] -> () - | suffices -> process ~pos:0 [] (List.rev suffices)) - in - process ~pos:0 [] [(0, Flat, doc)]; - MiniBuffer.contents buffer - -let debug t = - let rec toDoc = function - | Nil -> text "nil" - | BreakParent -> text "breakparent" - | Text txt -> text ("text(\"" ^ txt ^ "\")") - | LineSuffix doc -> - group - (concat - [ - text "linesuffix("; - indent (concat [line; toDoc doc]); - line; - text ")"; - ]) - | Concat [] -> text "concat()" - | Concat docs -> - group - (concat - [ - text "concat("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) - | CustomLayout docs -> - group - (concat - [ - text "customLayout("; - indent - (concat - [ - line; - join ~sep:(concat [text ","; line]) (List.map toDoc docs); - ]); - line; - text ")"; - ]) - | Indent doc -> - concat [text "indent("; softLine; toDoc doc; softLine; text ")"] - | IfBreaks {yes = trueDoc; broken = true} -> toDoc trueDoc - | IfBreaks {yes = trueDoc; no = falseDoc} -> - group - (concat - [ - text "ifBreaks("; - indent - (concat - [line; toDoc trueDoc; concat [text ","; line]; toDoc falseDoc]); - line; - text ")"; - ]) - | LineBreak break -> - let breakTxt = - match break with - | Classic -> "Classic" - | Soft -> "Soft" - | Hard -> "Hard" - | Literal -> "Liteal" - in - text ("LineBreak(" ^ breakTxt ^ ")") - | Group {shouldBreak; doc} -> - group - (concat - [ - text "Group("; - indent - (concat - [ - line; - text ("{shouldBreak: " ^ string_of_bool shouldBreak ^ "}"); - concat [text ","; line]; - toDoc doc; - ]); - line; - text ")"; - ]) - in - let doc = toDoc t in - toString ~width:10 doc |> print_endline -[@@live] diff --git a/jscomp/syntax/src/res_driver.ml b/jscomp/syntax/src/res_driver.ml deleted file mode 100644 index a82c9a2..0000000 --- a/jscomp/syntax/src/res_driver.ml +++ /dev/null @@ -1,161 +0,0 @@ -module IO = Res_io - -type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Res_comment.t list; -} - -type 'diagnostics parsingEngine = { - parseImplementation: - forPrinter:bool -> - filename:string -> - (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: - forPrinter:bool -> - filename:string -> - (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; -} - -type printEngine = { - printImplementation: - width:int -> - filename:string -> - comments:Res_comment.t list -> - Parsetree.structure -> - unit; - printInterface: - width:int -> - filename:string -> - comments:Res_comment.t list -> - Parsetree.signature -> - unit; -} - -let setup ~filename ~forPrinter () = - let src = IO.readFile ~filename in - let mode = if forPrinter then Res_parser.Default else ParseForTypeChecker in - Res_parser.make ~mode src filename - -let setupFromSource ~displayFilename ~source ~forPrinter () = - let mode = if forPrinter then Res_parser.Default else ParseForTypeChecker in - Res_parser.make ~mode source displayFilename - -let parsingEngine = - { - parseImplementation = - (fun ~forPrinter ~filename -> - let engine = setup ~filename ~forPrinter () in - let structure = Res_core.parseImplementation engine in - let invalid, diagnostics = - match engine.diagnostics with - | [] as diagnostics -> (false, diagnostics) - | _ as diagnostics -> (true, diagnostics) - in - { - filename = engine.scanner.filename; - source = engine.scanner.src; - parsetree = structure; - diagnostics; - invalid; - comments = List.rev engine.comments; - }); - parseInterface = - (fun ~forPrinter ~filename -> - let engine = setup ~filename ~forPrinter () in - let signature = Res_core.parseSpecification engine in - let invalid, diagnostics = - match engine.diagnostics with - | [] as diagnostics -> (false, diagnostics) - | _ as diagnostics -> (true, diagnostics) - in - { - filename = engine.scanner.filename; - source = engine.scanner.src; - parsetree = signature; - diagnostics; - invalid; - comments = List.rev engine.comments; - }); - stringOfDiagnostics = - (fun ~source ~filename:_ diagnostics -> - Res_diagnostics.printReport diagnostics source); - } - -let parseImplementationFromSource ~forPrinter ~displayFilename ~source = - let engine = setupFromSource ~displayFilename ~source ~forPrinter () in - let structure = Res_core.parseImplementation engine in - let invalid, diagnostics = - match engine.diagnostics with - | [] as diagnostics -> (false, diagnostics) - | _ as diagnostics -> (true, diagnostics) - in - { - filename = engine.scanner.filename; - source = engine.scanner.src; - parsetree = structure; - diagnostics; - invalid; - comments = List.rev engine.comments; - } - -let parseInterfaceFromSource ~forPrinter ~displayFilename ~source = - let engine = setupFromSource ~displayFilename ~source ~forPrinter () in - let signature = Res_core.parseSpecification engine in - let invalid, diagnostics = - match engine.diagnostics with - | [] as diagnostics -> (false, diagnostics) - | _ as diagnostics -> (true, diagnostics) - in - { - filename = engine.scanner.filename; - source = engine.scanner.src; - parsetree = signature; - diagnostics; - invalid; - comments = List.rev engine.comments; - } - -let printEngine = - { - printImplementation = - (fun ~width ~filename:_ ~comments structure -> - print_string - (Res_printer.printImplementation ~width structure ~comments)); - printInterface = - (fun ~width ~filename:_ ~comments signature -> - print_string (Res_printer.printInterface ~width signature ~comments)); - } - -let parse_implementation ?(ignoreParseErrors = false) sourcefile = - Location.input_name := sourcefile; - let parseResult = - parsingEngine.parseImplementation ~forPrinter:false ~filename:sourcefile - in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - parseResult.parsetree -[@@raises exit] - -let parse_interface ?(ignoreParseErrors = false) sourcefile = - Location.input_name := sourcefile; - let parseResult = - parsingEngine.parseInterface ~forPrinter:false ~filename:sourcefile - in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - parseResult.parsetree -[@@raises exit] - -(* suppress unused optional arg *) -let _ = - fun s -> - ( parse_implementation ~ignoreParseErrors:false s, - parse_interface ~ignoreParseErrors:false s ) -[@@raises exit] diff --git a/jscomp/syntax/src/res_driver.mli b/jscomp/syntax/src/res_driver.mli deleted file mode 100644 index ddc2647..0000000 --- a/jscomp/syntax/src/res_driver.mli +++ /dev/null @@ -1,62 +0,0 @@ -type ('ast, 'diagnostics) parseResult = { - filename: string; [@live] - source: string; - parsetree: 'ast; - diagnostics: 'diagnostics; - invalid: bool; - comments: Res_comment.t list; -} - -type 'diagnostics parsingEngine = { - parseImplementation: - forPrinter:bool -> - filename:string -> - (Parsetree.structure, 'diagnostics) parseResult; - parseInterface: - forPrinter:bool -> - filename:string -> - (Parsetree.signature, 'diagnostics) parseResult; - stringOfDiagnostics: source:string -> filename:string -> 'diagnostics -> unit; -} - -val parseImplementationFromSource : - forPrinter:bool -> - displayFilename:string -> - source:string -> - (Parsetree.structure, Res_diagnostics.t list) parseResult -[@@live] - -val parseInterfaceFromSource : - forPrinter:bool -> - displayFilename:string -> - source:string -> - (Parsetree.signature, Res_diagnostics.t list) parseResult -[@@live] - -type printEngine = { - printImplementation: - width:int -> - filename:string -> - comments:Res_comment.t list -> - Parsetree.structure -> - unit; - printInterface: - width:int -> - filename:string -> - comments:Res_comment.t list -> - Parsetree.signature -> - unit; -} - -val parsingEngine : Res_diagnostics.t list parsingEngine - -val printEngine : printEngine - -(* ReScript implementation parsing compatible with ocaml pparse driver. Used by the compiler. *) -val parse_implementation : - ?ignoreParseErrors:bool -> string -> Parsetree.structure -[@@live] [@@raises Location.Error] - -(* ReScript interface parsing compatible with ocaml pparse driver. Used by the compiler *) -val parse_interface : ?ignoreParseErrors:bool -> string -> Parsetree.signature -[@@live] [@@raises Location.Error] diff --git a/jscomp/syntax/src/res_driver_binary.mli b/jscomp/syntax/src/res_driver_binary.mli deleted file mode 100644 index 7991ba8..0000000 --- a/jscomp/syntax/src/res_driver_binary.mli +++ /dev/null @@ -1 +0,0 @@ -val printEngine : Res_driver.printEngine diff --git a/jscomp/syntax/src/res_driver_ml_parser.ml b/jscomp/syntax/src/res_driver_ml_parser.ml deleted file mode 100644 index 0d6a99e..0000000 --- a/jscomp/syntax/src/res_driver_ml_parser.ml +++ /dev/null @@ -1,100 +0,0 @@ -module OcamlParser = Parser -module IO = Res_io - -let setup ~filename = - if String.length filename > 0 then ( - Location.input_name := filename; - IO.readFile ~filename |> Lexing.from_string) - else Lexing.from_channel stdin - -let extractOcamlConcreteSyntax filename = - let lexbuf = - if String.length filename > 0 then - IO.readFile ~filename |> Lexing.from_string - else Lexing.from_channel stdin - in - let stringLocs = ref [] in - let commentData = ref [] in - let rec next (prevTokEndPos : Lexing.position) () = - let token = Lexer.token_with_comments lexbuf in - match token with - | OcamlParser.COMMENT (txt, loc) -> - let comment = Res_comment.fromOcamlComment ~loc ~prevTokEndPos ~txt in - commentData := comment :: !commentData; - next loc.Location.loc_end () - | OcamlParser.STRING (_txt, None) -> - let open Location in - let loc = - { - loc_start = lexbuf.lex_start_p; - loc_end = lexbuf.Lexing.lex_curr_p; - loc_ghost = false; - } - in - let len = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in - let txt = - Bytes.to_string - ((Bytes.sub [@doesNotRaise]) lexbuf.Lexing.lex_buffer - loc.loc_start.pos_cnum len) - in - stringLocs := (txt, loc) :: !stringLocs; - next lexbuf.Lexing.lex_curr_p () - | OcamlParser.EOF -> () - | _ -> next lexbuf.Lexing.lex_curr_p () - in - next lexbuf.Lexing.lex_start_p (); - (List.rev !stringLocs, List.rev !commentData) - -let parsingEngine = - { - Res_driver.parseImplementation = - (fun ~forPrinter:_ ~filename -> - let lexbuf = setup ~filename in - let stringData, comments = - extractOcamlConcreteSyntax !Location.input_name - in - let structure = - Parse.implementation lexbuf - |> Res_ast_conversion.replaceStringLiteralStructure stringData - |> Res_ast_conversion.structure - in - { - filename = !Location.input_name; - source = Bytes.to_string lexbuf.lex_buffer; - parsetree = structure; - diagnostics = (); - invalid = false; - comments; - }); - parseInterface = - (fun ~forPrinter:_ ~filename -> - let lexbuf = setup ~filename in - let stringData, comments = - extractOcamlConcreteSyntax !Location.input_name - in - let signature = - Parse.interface lexbuf - |> Res_ast_conversion.replaceStringLiteralSignature stringData - |> Res_ast_conversion.signature - in - { - filename = !Location.input_name; - source = Bytes.to_string lexbuf.lex_buffer; - parsetree = signature; - diagnostics = (); - invalid = false; - comments; - }); - stringOfDiagnostics = (fun ~source:_ ~filename:_ _diagnostics -> ()); - } - -let printEngine = - Res_driver. - { - printImplementation = - (fun ~width:_ ~filename:_ ~comments:_ structure -> - Pprintast.structure Format.std_formatter structure); - printInterface = - (fun ~width:_ ~filename:_ ~comments:_ signature -> - Pprintast.signature Format.std_formatter signature); - } diff --git a/jscomp/syntax/src/res_driver_ml_parser.mli b/jscomp/syntax/src/res_driver_ml_parser.mli deleted file mode 100644 index 55a99c4..0000000 --- a/jscomp/syntax/src/res_driver_ml_parser.mli +++ /dev/null @@ -1,10 +0,0 @@ -(* This module represents a general interface to parse marshalled reason ast *) - -(* extracts comments and the original string data from an ocaml file *) -val extractOcamlConcreteSyntax : - string -> (string * Location.t) list * Res_comment.t list -[@@live] - -val parsingEngine : unit Res_driver.parsingEngine - -val printEngine : Res_driver.printEngine diff --git a/jscomp/syntax/src/res_grammar.ml b/jscomp/syntax/src/res_grammar.ml deleted file mode 100644 index 61e6f4e..0000000 --- a/jscomp/syntax/src/res_grammar.ml +++ /dev/null @@ -1,326 +0,0 @@ -module Token = Res_token - -type t = - | OpenDescription (* open Belt *) - | ModuleLongIdent (* Foo or Foo.Bar *) [@live] - | Ternary (* condExpr ? trueExpr : falseExpr *) - | Es6ArrowExpr - | Jsx - | JsxAttribute - | JsxChild [@live] - | ExprOperand - | ExprUnary - | ExprSetField - | ExprBinaryAfterOp of Token.t - | ExprBlock - | ExprCall - | ExprList - | ExprArrayAccess - | ExprArrayMutation - | ExprIf - | ExprFor - | IfCondition - | IfBranch - | ElseBranch - | TypeExpression - | External - | PatternMatching - | PatternMatchCase - | LetBinding - | PatternList - | PatternOcamlList - | PatternRecord - | TypeDef - | TypeConstrName - | TypeParams - | TypeParam [@live] - | PackageConstraint - | TypeRepresentation - | RecordDecl - | ConstructorDeclaration - | ParameterList - | StringFieldDeclarations - | FieldDeclarations - | TypExprList - | FunctorArgs - | ModExprList - | TypeParameters - | RecordRows - | RecordRowsStringKey - | ArgumentList - | Signature - | Specification - | Structure - | Implementation - | Attribute - | TypeConstraint - | AtomicTypExpr - | ListExpr - | Pattern - | AttributePayload - | TagNames - -let toString = function - | OpenDescription -> "an open description" - | ModuleLongIdent -> "a module path" - | Ternary -> "a ternary expression" - | Es6ArrowExpr -> "an es6 arrow function" - | Jsx -> "a jsx expression" - | JsxAttribute -> "a jsx attribute" - | ExprOperand -> "a basic expression" - | ExprUnary -> "a unary expression" - | ExprBinaryAfterOp op -> - "an expression after the operator \"" ^ Token.toString op ^ "\"" - | ExprIf -> "an if expression" - | IfCondition -> "the condition of an if expression" - | IfBranch -> "the true-branch of an if expression" - | ElseBranch -> "the else-branch of an if expression" - | TypeExpression -> "a type" - | External -> "an external" - | PatternMatching -> "the cases of a pattern match" - | ExprBlock -> "a block with expressions" - | ExprSetField -> "a record field mutation" - | ExprCall -> "a function application" - | ExprArrayAccess -> "an array access expression" - | ExprArrayMutation -> "an array mutation" - | LetBinding -> "a let binding" - | TypeDef -> "a type definition" - | TypeParams -> "type parameters" - | TypeParam -> "a type parameter" - | TypeConstrName -> "a type-constructor name" - | TypeRepresentation -> "a type representation" - | RecordDecl -> "a record declaration" - | PatternMatchCase -> "a pattern match case" - | ConstructorDeclaration -> "a constructor declaration" - | ExprList -> "multiple expressions" - | PatternList -> "multiple patterns" - | PatternOcamlList -> "a list pattern" - | PatternRecord -> "a record pattern" - | ParameterList -> "parameters" - | StringFieldDeclarations -> "string field declarations" - | FieldDeclarations -> "field declarations" - | TypExprList -> "list of types" - | FunctorArgs -> "functor arguments" - | ModExprList -> "list of module expressions" - | TypeParameters -> "list of type parameters" - | RecordRows -> "rows of a record" - | RecordRowsStringKey -> "rows of a record with string keys" - | ArgumentList -> "arguments" - | Signature -> "signature" - | Specification -> "specification" - | Structure -> "structure" - | Implementation -> "implementation" - | Attribute -> "an attribute" - | TypeConstraint -> "constraints on a type" - | AtomicTypExpr -> "a type" - | ListExpr -> "an ocaml list expr" - | PackageConstraint -> "a package constraint" - | JsxChild -> "jsx child" - | Pattern -> "pattern" - | ExprFor -> "a for expression" - | AttributePayload -> "an attribute payload" - | TagNames -> "tag names" - -let isSignatureItemStart = function - | Token.At | Let | Typ | External | Exception | Open | Include | Module | AtAt - | PercentPercent -> - true - | _ -> false - -let isAtomicPatternStart = function - | Token.Int _ | String _ | Codepoint _ | Backtick | Lparen | Lbracket | Lbrace - | Underscore | Lident _ | Uident _ | List | Exception | Lazy | Percent -> - true - | _ -> false - -let isAtomicExprStart = function - | Token.True | False | Int _ | String _ | Float _ | Codepoint _ | Backtick - | Uident _ | Lident _ | Hash | Lparen | List | Lbracket | Lbrace | LessThan - | Module | Percent -> - true - | _ -> false - -let isAtomicTypExprStart = function - | Token.SingleQuote | Underscore | Lparen | Lbrace | Uident _ | Lident _ - | Percent -> - true - | _ -> false - -let isExprStart = function - | Token.Assert | At | Await | Backtick | Bang | Codepoint _ | False | Float _ - | For | Hash | If | Int _ | Lazy | Lbrace | Lbracket | LessThan | Lident _ - | List | Lparen | Minus | MinusDot | Module | Percent | Plus | PlusDot - | String _ | Switch | True | Try | Uident _ | Underscore (* _ => doThings() *) - | While -> - true - | _ -> false - -let isJsxAttributeStart = function - | Token.Lident _ | Question | Lbrace -> true - | _ -> false - -let isStructureItemStart = function - | Token.Open | Let | Typ | External | Exception | Include | Module | AtAt - | PercentPercent | At -> - true - | t when isExprStart t -> true - | _ -> false - -let isPatternStart = function - | Token.Int _ | Float _ | String _ | Codepoint _ | Backtick | True | False - | Minus | Plus | Lparen | Lbracket | Lbrace | List | Underscore | Lident _ - | Uident _ | Hash | Exception | Lazy | Percent | Module | At -> - true - | _ -> false - -let isParameterStart = function - | Token.Typ | Tilde | Dot -> true - | token when isPatternStart token -> true - | _ -> false - -(* TODO: overparse Uident ? *) -let isStringFieldDeclStart = function - | Token.String _ | Lident _ | At | DotDotDot -> true - | _ -> false - -(* TODO: overparse Uident ? *) -let isFieldDeclStart = function - | Token.At | Mutable | Lident _ -> true - (* recovery, TODO: this is not ideal… *) - | Uident _ -> true - | t when Token.isKeyword t -> true - | _ -> false - -let isRecordDeclStart = function - | Token.At | Mutable | Lident _ | DotDotDot | String _ -> true - | _ -> false - -let isTypExprStart = function - | Token.At | SingleQuote | Underscore | Lparen | Lbracket | Uident _ - | Lident _ | Module | Percent | Lbrace -> - true - | _ -> false - -let isTypeParameterStart = function - | Token.Tilde | Dot -> true - | token when isTypExprStart token -> true - | _ -> false - -let isTypeParamStart = function - | Token.Plus | Minus | SingleQuote | Underscore -> true - | _ -> false - -let isFunctorArgStart = function - | Token.At | Uident _ | Underscore | Percent | Lbrace | Lparen -> true - | _ -> false - -let isModExprStart = function - | Token.At | Percent | Uident _ | Lbrace | Lparen | Lident "unpack" | Await -> - true - | _ -> false - -let isRecordRowStart = function - | Token.DotDotDot -> true - | Token.Uident _ | Lident _ -> true - (* TODO *) - | t when Token.isKeyword t -> true - | _ -> false - -let isRecordRowStringKeyStart = function - | Token.String _ -> true - | _ -> false - -let isArgumentStart = function - | Token.Tilde | Dot | Underscore -> true - | t when isExprStart t -> true - | _ -> false - -let isPatternMatchStart = function - | Token.Bar -> true - | t when isPatternStart t -> true - | _ -> false - -let isPatternOcamlListStart = function - | Token.DotDotDot -> true - | t when isPatternStart t -> true - | _ -> false - -let isPatternRecordItemStart = function - | Token.DotDotDot | Uident _ | Lident _ | Underscore -> true - | _ -> false - -let isAttributeStart = function - | Token.At -> true - | _ -> false - -let isJsxChildStart = isAtomicExprStart - -let isBlockExprStart = function - | Token.Assert | At | Await | Backtick | Bang | Codepoint _ | Exception - | False | Float _ | For | Forwardslash | Hash | If | Int _ | Lazy | Lbrace - | Lbracket | LessThan | Let | Lident _ | List | Lparen | Minus | MinusDot - | Module | Open | Percent | Plus | PlusDot | String _ | Switch | True | Try - | Uident _ | Underscore | While -> - true - | _ -> false - -let isListElement grammar token = - match grammar with - | ExprList -> token = Token.DotDotDot || isExprStart token - | ListExpr -> token = DotDotDot || isExprStart token - | PatternList -> token = DotDotDot || isPatternStart token - | ParameterList -> isParameterStart token - | StringFieldDeclarations -> isStringFieldDeclStart token - | FieldDeclarations -> isFieldDeclStart token - | RecordDecl -> isRecordDeclStart token - | TypExprList -> isTypExprStart token || token = Token.LessThan - | TypeParams -> isTypeParamStart token - | FunctorArgs -> isFunctorArgStart token - | ModExprList -> isModExprStart token - | TypeParameters -> isTypeParameterStart token - | RecordRows -> isRecordRowStart token - | RecordRowsStringKey -> isRecordRowStringKeyStart token - | ArgumentList -> isArgumentStart token - | Signature | Specification -> isSignatureItemStart token - | Structure | Implementation -> isStructureItemStart token - | PatternMatching -> isPatternMatchStart token - | PatternOcamlList -> isPatternOcamlListStart token - | PatternRecord -> isPatternRecordItemStart token - | Attribute -> isAttributeStart token - | TypeConstraint -> token = Constraint - | PackageConstraint -> token = And - | ConstructorDeclaration -> token = Bar - | JsxAttribute -> isJsxAttributeStart token - | AttributePayload -> token = Lparen - | TagNames -> token = Hash - | _ -> false - -let isListTerminator grammar token = - match (grammar, token) with - | _, Token.Eof - | ExprList, (Rparen | Forwardslash | Rbracket) - | ListExpr, Rparen - | ArgumentList, (Rparen | DotDotDot) - | TypExprList, (Rparen | Forwardslash | GreaterThan | Equal) - | ModExprList, Rparen - | ( (PatternList | PatternOcamlList | PatternRecord), - ( Forwardslash | Rbracket | Rparen | EqualGreater (* pattern matching => *) - | In (* for expressions *) - | Equal (* let {x} = foo *) ) ) - | ExprBlock, Rbrace - | (Structure | Signature), Rbrace - | TypeParams, Rparen - | ParameterList, (EqualGreater | Lbrace) - | JsxAttribute, (Forwardslash | GreaterThan) - | StringFieldDeclarations, Rbrace -> - true - | Attribute, token when token <> At -> true - | TypeConstraint, token when token <> Constraint -> true - | PackageConstraint, token when token <> And -> true - | ConstructorDeclaration, token when token <> Bar -> true - | AttributePayload, Rparen -> true - | TagNames, Rbracket -> true - | _ -> false - -let isPartOfList grammar token = - isListElement grammar token || isListTerminator grammar token diff --git a/jscomp/syntax/src/res_io.ml b/jscomp/syntax/src/res_io.ml deleted file mode 100644 index e5934b8..0000000 --- a/jscomp/syntax/src/res_io.ml +++ /dev/null @@ -1,14 +0,0 @@ -let readFile ~filename = - let chan = open_in_bin filename in - let content = - try really_input_string chan (in_channel_length chan) - with End_of_file -> "" - in - close_in_noerr chan; - content - -let writeFile ~filename ~contents:txt = - let chan = open_out_bin filename in - output_string chan txt; - close_out chan -[@@raises Sys_error] diff --git a/jscomp/syntax/src/res_io.mli b/jscomp/syntax/src/res_io.mli deleted file mode 100644 index dcc6e14..0000000 --- a/jscomp/syntax/src/res_io.mli +++ /dev/null @@ -1,7 +0,0 @@ -(* utilities to read and write to/from files or stdin *) - -(* reads the contents of "filename" into a string *) -val readFile : filename:string -> string - -(* writes "content" into file with name "filename" *) -val writeFile : filename:string -> contents:string -> unit diff --git a/jscomp/syntax/src/res_multi_printer.ml b/jscomp/syntax/src/res_multi_printer.ml deleted file mode 100644 index 98cd1d4..0000000 --- a/jscomp/syntax/src/res_multi_printer.ml +++ /dev/null @@ -1,119 +0,0 @@ -let defaultPrintWidth = 100 - -(* Look at rescript.json (or bsconfig.json) to set Uncurried or Legacy mode if it contains "uncurried": false *) -let getUncurriedFromConfig ~filename = - let rec findConfig ~dir = - let config = Filename.concat dir "rescript.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) - else - let config = Filename.concat dir "bsconfig.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) - else - let parent = Filename.dirname dir in - if parent = dir then None else findConfig ~dir:parent - in - let rec findFromNodeModules ~dir = - let parent = Filename.dirname dir in - if Filename.basename dir = "node_modules" then - let config = Filename.concat parent "rescript.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) - else - let config = Filename.concat parent "bsconfig.json" in - if Sys.file_exists config then Some (Res_io.readFile ~filename:config) - else None - else if parent = dir then None - else findFromNodeModules ~dir:parent - in - let dir = - if Filename.is_relative filename then - Filename.dirname (Filename.concat (Sys.getcwd ()) filename) - else Filename.dirname filename - in - let config () = - match findConfig ~dir with - | None -> - (* The editor calls format on a temporary file. So bsconfig can't be found. - This looks outside the node_modules containing the bsc binary *) - let dir = (Filename.dirname Sys.argv.(0) [@doesNotRaise]) in - findFromNodeModules ~dir - | x -> x - in - match config () with - | exception _ -> () - | None -> () - | Some config -> - let lines = config |> String.split_on_char '\n' in - let is_legacy_uncurried = - lines - |> List.exists (fun line -> - let is_uncurried_option = ref false in - let is_option_falsy = ref false in - let words = line |> String.split_on_char ' ' in - words - |> List.iter (fun word -> - match word with - | "\"uncurried\"" | "\"uncurried\":" -> - is_uncurried_option := true - | "\"uncurried\":false" | "\"uncurried\":false," -> - is_uncurried_option := true; - is_option_falsy := true - | "false" | ":false" | "false," | ":false," -> - is_option_falsy := true - | _ -> ()); - !is_uncurried_option && !is_option_falsy) - in - if not is_legacy_uncurried then Config.uncurried := Uncurried - -(* print res files to res syntax *) -let printRes ~ignoreParseErrors ~isInterface ~filename = - getUncurriedFromConfig ~filename; - if isInterface then ( - let parseResult = - Res_driver.parsingEngine.parseInterface ~forPrinter:true ~filename - in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - Res_printer.printInterface ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree) - else - let parseResult = - Res_driver.parsingEngine.parseImplementation ~forPrinter:true ~filename - in - if parseResult.invalid then ( - Res_diagnostics.printReport parseResult.diagnostics parseResult.source; - if not ignoreParseErrors then exit 1); - Res_printer.printImplementation ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree -[@@raises exit] - -(* print ocaml files to res syntax *) -let printMl ~isInterface ~filename = - if isInterface then - let parseResult = - Res_driver_ml_parser.parsingEngine.parseInterface ~forPrinter:true - ~filename - in - Res_printer.printInterface ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree - else - let parseResult = - Res_driver_ml_parser.parsingEngine.parseImplementation ~forPrinter:true - ~filename - in - Res_printer.printImplementation ~width:defaultPrintWidth - ~comments:parseResult.comments parseResult.parsetree - -(* print the given file named input to from "language" to res, general interface exposed by the compiler *) -let print ?(ignoreParseErrors = false) language ~input = - let isInterface = - let len = String.length input in - len > 0 && String.unsafe_get input (len - 1) = 'i' - in - match language with - | `res -> printRes ~ignoreParseErrors ~isInterface ~filename:input - | `ml -> printMl ~isInterface ~filename:input -[@@raises exit] - -(* suppress unused optional arg *) -let _ = fun s -> print ~ignoreParseErrors:false s [@@raises exit] diff --git a/jscomp/syntax/src/res_multi_printer.mli b/jscomp/syntax/src/res_multi_printer.mli deleted file mode 100644 index 1d15c71..0000000 --- a/jscomp/syntax/src/res_multi_printer.mli +++ /dev/null @@ -1,3 +0,0 @@ -(* Interface to print source code from different languages to res. - * Takes a filename called "input" and returns the corresponding formatted res syntax *) -val print : ?ignoreParseErrors:bool -> [`ml | `res] -> input:string -> string diff --git a/jscomp/syntax/src/res_outcome_printer.ml b/jscomp/syntax/src/res_outcome_printer.ml deleted file mode 100644 index f704bd8..0000000 --- a/jscomp/syntax/src/res_outcome_printer.ml +++ /dev/null @@ -1,1174 +0,0 @@ -(* For the curious: the outcome printer is a printer to print data - * from the outcometree.mli file in the ocaml compiler. - * The outcome tree is used by: - * - ocaml's toplevel/repl, print results/errors - * - super errors, print nice errors - * - editor tooling, e.g. show type on hover - * - * In general it represent messages to show results or errors to the user. *) - -module Doc = Res_doc -module Token = Res_token - -let rec unsafe_for_all_range s ~start ~finish p = - start > finish - || p (String.unsafe_get s start) - && unsafe_for_all_range s ~start:(start + 1) ~finish p - -let for_all_from s start p = - let len = String.length s in - unsafe_for_all_range s ~start ~finish:(len - 1) p - -(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) -let isValidNumericPolyvarNumber (x : string) = - let len = String.length x in - len > 0 - && - let a = Char.code (String.unsafe_get x 0) in - a <= 57 - && - if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) - else a >= 48 - -type identifierStyle = ExoticIdent | NormalIdent - -let classifyIdentContent ~allowUident txt = - let len = String.length txt in - let rec go i = - if i == len then NormalIdent - else - let c = String.unsafe_get txt i in - if - i == 0 - && not - ((allowUident && c >= 'A' && c <= 'Z') - || (c >= 'a' && c <= 'z') - || c = '_') - then ExoticIdent - else if - not - ((c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || c = '\'' || c = '_' - || (c >= '0' && c <= '9')) - then ExoticIdent - else go (i + 1) - in - if Token.isKeywordTxt txt then ExoticIdent else go 0 - -let printIdentLike ~allowUident txt = - match classifyIdentContent ~allowUident txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] - | NormalIdent -> Doc.text txt - -let printPolyVarIdent txt = - (* numeric poly-vars don't need quotes: #644 *) - if isValidNumericPolyvarNumber txt then Doc.text txt - else - match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] - | NormalIdent -> Doc.text txt - -(* ReScript doesn't have parenthesized identifiers. - * We don't support custom operators. *) -let parenthesized_ident _name = true - -(* TODO: better allocation strategy for the buffer *) -let escapeStringContents s = - let len = String.length s in - let b = Buffer.create len in - for i = 0 to len - 1 do - let c = (String.get [@doesNotRaise]) s i in - if c = '\008' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'b') - else if c = '\009' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 't') - else if c = '\010' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'n') - else if c = '\013' then ( - Buffer.add_char b '\\'; - Buffer.add_char b 'r') - else if c = '\034' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '"') - else if c = '\092' then ( - Buffer.add_char b '\\'; - Buffer.add_char b '\\') - else Buffer.add_char b c - done; - Buffer.contents b - -(* let rec print_ident fmt ident = match ident with - | Outcometree.Oide_ident s -> Format.pp_print_string fmt s - | Oide_dot (id, s) -> - print_ident fmt id; - Format.pp_print_char fmt '.'; - Format.pp_print_string fmt s - | Oide_apply (id1, id2) -> - print_ident fmt id1; - Format.pp_print_char fmt '('; - print_ident fmt id2; - Format.pp_print_char fmt ')' *) - -let rec printOutIdentDoc ?(allowUident = true) (ident : Outcometree.out_ident) = - match ident with - | Oide_ident s -> printIdentLike ~allowUident s - | Oide_dot (ident, s) -> - Doc.concat [printOutIdentDoc ident; Doc.dot; Doc.text s] - | Oide_apply (call, arg) -> - Doc.concat - [printOutIdentDoc call; Doc.lparen; printOutIdentDoc arg; Doc.rparen] - -let printOutAttributeDoc (outAttribute : Outcometree.out_attribute) = - Doc.concat [Doc.text "@"; Doc.text outAttribute.oattr_name] - -let printOutAttributesDoc (attrs : Outcometree.out_attribute list) = - match attrs with - | [] -> Doc.nil - | attrs -> - Doc.concat - [ - Doc.group (Doc.join ~sep:Doc.line (List.map printOutAttributeDoc attrs)); - Doc.line; - ] - -let rec collectArrowArgs (outType : Outcometree.out_type) args = - match outType with - | Otyp_arrow (label, argType, returnType) -> - let arg = (label, argType) in - collectArrowArgs returnType (arg :: args) - | _ as returnType -> (List.rev args, returnType) - -let rec collectFunctorArgs (outModuleType : Outcometree.out_module_type) args = - match outModuleType with - | Omty_functor (lbl, optModType, returnModType) -> - let arg = (lbl, optModType) in - collectFunctorArgs returnModType (arg :: args) - | _ -> (List.rev args, outModuleType) - -let rec printOutTypeDoc (outType : Outcometree.out_type) = - match outType with - | Otyp_abstract | Otyp_open -> Doc.nil - | Otyp_variant (nonGen, outVariant, closed, labels) -> - (* bool * out_variant * bool * (string list) option *) - let opening = - match (closed, labels) with - | true, None -> (* [#A | #B] *) Doc.softLine - | false, None -> - (* [> #A | #B] *) - Doc.concat [Doc.greaterThan; Doc.line] - | true, Some [] -> - (* [< #A | #B] *) - Doc.concat [Doc.lessThan; Doc.line] - | true, Some _ -> - (* [< #A | #B > #X #Y ] *) - Doc.concat [Doc.lessThan; Doc.line] - | false, Some _ -> - (* impossible!? ocaml seems to print ?, see oprint.ml in 4.06 *) - Doc.concat [Doc.text "?"; Doc.line] - in - Doc.group - (Doc.concat - [ - (if nonGen then Doc.text "_" else Doc.nil); - Doc.lbracket; - Doc.indent (Doc.concat [opening; printOutVariant outVariant]); - (match labels with - | None | Some [] -> Doc.nil - | Some tags -> - Doc.group - (Doc.concat - [ - Doc.space; - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> printIdentLike ~allowUident:true lbl) - tags); - ])); - Doc.softLine; - Doc.rbracket; - ]) - | Otyp_alias (typ, aliasTxt) -> - Doc.concat - [ - Doc.lparen; - printOutTypeDoc typ; - Doc.text " as '"; - Doc.text aliasTxt; - Doc.rparen; - ] - | Otyp_constr (Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), "arity0"), [typ]) - -> - (* Compatibility with compiler up to v10.x *) - Doc.concat [Doc.text "(. ()) => "; printOutTypeDoc typ] - | Otyp_constr - ( Oide_dot (Oide_dot (Oide_ident "Js", "Fn"), _), - [(Otyp_arrow _ as arrowType)] ) -> - (* Compatibility with compiler up to v10.x *) - printOutArrowType ~uncurried:true arrowType - | Otyp_constr (Oide_ident "function$", [(Otyp_arrow _ as arrowType); _arity]) - -> - (* function$<(int, int) => int, [#2]> -> (. int, int) => int *) - printOutArrowType ~uncurried:true arrowType - | Otyp_constr (Oide_ident "function$", [Otyp_var _; _arity]) -> - (* function$<'a, arity> -> _ => _ *) - printOutTypeDoc (Otyp_stuff "_ => _") - | Otyp_constr (outIdent, []) -> printOutIdentDoc ~allowUident:false outIdent - | Otyp_manifest (typ1, typ2) -> - Doc.concat [printOutTypeDoc typ1; Doc.text " = "; printOutTypeDoc typ2] - | Otyp_record record -> printRecordDeclarationDoc ~inline:true record - | Otyp_stuff txt -> Doc.text txt - | Otyp_var (ng, s) -> - Doc.concat [Doc.text ("'" ^ if ng then "_" else ""); Doc.text s] - | Otyp_object (fields, rest) -> printObjectFields fields rest - | Otyp_class _ -> Doc.nil - | Otyp_attribute (typ, attribute) -> - Doc.group - (Doc.concat - [printOutAttributeDoc attribute; Doc.line; printOutTypeDoc typ]) - (* example: Red | Blue | Green | CustomColour(float, float, float) *) - | Otyp_sum constructors -> printOutConstructorsDoc constructors - (* example: {"name": string, "age": int} *) - | Otyp_constr (Oide_dot (Oide_ident "Js", "t"), [Otyp_object (fields, rest)]) - -> - printObjectFields fields rest - (* example: node *) - | Otyp_constr (outIdent, args) -> - let argsDoc = - match args with - | [] -> Doc.nil - | args -> - Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ] - in - Doc.group (Doc.concat [printOutIdentDoc outIdent; argsDoc]) - | Otyp_tuple tupleArgs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc tupleArgs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - | Otyp_poly (vars, outType) -> - Doc.group - (Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text ("'" ^ var)) vars); - Doc.dot; - Doc.space; - printOutTypeDoc outType; - ]) - | Otyp_arrow _ as typ -> printOutArrowType ~uncurried:false typ - | Otyp_module (modName, stringList, outTypes) -> - let packageTypeDoc = - match (stringList, outTypes) with - | [], [] -> Doc.nil - | labels, types -> - let i = ref 0 in - let package = - Doc.join ~sep:Doc.line - ((List.map2 [@doesNotRaise]) - (fun lbl typ -> - Doc.concat - [ - Doc.text - (if i.contents > 0 then "and type " else "with type "); - Doc.text lbl; - Doc.text " = "; - printOutTypeDoc typ; - ]) - labels types) - in - Doc.indent (Doc.concat [Doc.line; package]) - in - Doc.concat - [ - Doc.text "module"; - Doc.lparen; - Doc.text modName; - packageTypeDoc; - Doc.rparen; - ] - -and printOutArrowType ~uncurried typ = - let uncurried = Res_uncurried.getDotted ~uncurried !Config.uncurried in - let typArgs, typ = collectArrowArgs typ [] in - let args = - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (lbl, typ) -> - let lblLen = String.length lbl in - if lblLen = 0 then printOutTypeDoc typ - else - let lbl, optionalIndicator = - (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) - match String.unsafe_get lbl 0 with - | '?' -> - ((String.sub [@doesNotRaise]) lbl 1 (lblLen - 1), Doc.text "=?") - | _ -> (lbl, Doc.nil) - in - Doc.group - (Doc.concat - [ - Doc.text ("~" ^ lbl ^ ": "); - printOutTypeDoc typ; - optionalIndicator; - ])) - typArgs) - in - let argsDoc = - let needsParens = - match typArgs with - | _ when uncurried -> true - | [ - ( _, - ( Otyp_tuple _ | Otyp_arrow _ - | Otyp_constr (Oide_ident "function$", [Otyp_arrow _; _]) ) ); - ] -> - true - (* single argument should not be wrapped *) - | [("", _)] -> false - | _ -> true - in - if needsParens then - Doc.group - (Doc.concat - [ - (if uncurried then Doc.text "(. " else Doc.lparen); - Doc.indent (Doc.concat [Doc.softLine; args]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - else args - in - Doc.concat [argsDoc; Doc.text " => "; printOutTypeDoc typ] - -and printOutVariant variant = - match variant with - | Ovar_fields fields -> - (* (string * bool * out_type list) list *) - Doc.join ~sep:Doc.line - ((* - * [< | #T([< u2]) & ([< u2]) & ([< u1])] --> no ampersand - * [< | #S & ([< u2]) & ([< u2]) & ([< u1])] --> ampersand - *) - List.mapi - (fun i (name, ampersand, types) -> - let needsParens = - match types with - | [Outcometree.Otyp_tuple _] -> false - | _ -> true - in - Doc.concat - [ - (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); - Doc.group - (Doc.concat - [ - Doc.text "#"; - printPolyVarIdent name; - (match types with - | [] -> Doc.nil - | types -> - Doc.concat - [ - (if ampersand then Doc.text " & " else Doc.nil); - Doc.indent - (Doc.concat - [ - Doc.join - ~sep:(Doc.concat [Doc.text " &"; Doc.line]) - (List.map - (fun typ -> - let outTypeDoc = - printOutTypeDoc typ - in - if needsParens then - Doc.concat - [ - Doc.lparen; - outTypeDoc; - Doc.rparen; - ] - else outTypeDoc) - types); - ]); - ]); - ]); - ]) - fields) - | Ovar_typ typ -> printOutTypeDoc typ - -and printObjectFields fields rest = - let dots = - match rest with - | Some non_gen -> Doc.text ((if non_gen then "_" else "") ^ "..") - | None -> if fields = [] then Doc.dot else Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.lbrace; - dots; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (lbl, outType) -> - Doc.group - (Doc.concat - [ - Doc.text ("\"" ^ lbl ^ "\": "); - printOutTypeDoc outType; - ])) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - -and printOutConstructorsDoc constructors = - Doc.group - (Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join ~sep:Doc.line - (List.mapi - (fun i constructor -> - Doc.concat - [ - (if i > 0 then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil); - printOutConstructorDoc constructor; - ]) - constructors); - ])) - -and printOutConstructorDoc (name, args, gadt, repr) = - let reprDoc = - match repr with - | None -> Doc.nil - | Some s -> Doc.text (s ^ " ") - in - let gadtDoc = - match gadt with - | Some outType -> Doc.concat [Doc.text ": "; printOutTypeDoc outType] - | None -> Doc.nil - in - let argsDoc = - match args with - | [] -> Doc.nil - | [Otyp_record record] -> - (* inline records - * | Root({ - * mutable value: 'value, - * mutable updatedTime: float, - * }) - *) - Doc.concat - [ - Doc.lparen; - Doc.indent (printRecordDeclarationDoc ~inline:true record); - Doc.rparen; - ] - | _types -> - Doc.indent - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutTypeDoc args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - Doc.group (Doc.concat [reprDoc; Doc.text name; argsDoc; gadtDoc]) - -and printRecordDeclRowDoc (name, mut, opt, arg) = - Doc.group - (Doc.concat - [ - (if mut then Doc.text "mutable " else Doc.nil); - printIdentLike ~allowUident:false name; - (if opt then Doc.text "?" else Doc.nil); - Doc.text ": "; - printOutTypeDoc arg; - ]) - -and printRecordDeclarationDoc ~inline rows = - let content = - Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printRecordDeclRowDoc rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] - in - if not inline then Doc.group content else content - -let printOutType fmt outType = - Format.pp_print_string fmt (Doc.toString ~width:80 (printOutTypeDoc outType)) - -let printTypeParameterDoc (typ, (co, cn)) = - Doc.concat - [ - (if not cn then Doc.text "+" else if not co then Doc.text "-" else Doc.nil); - (if typ = "_" then Doc.text "_" else Doc.text ("'" ^ typ)); - ] - -let rec printOutSigItemDoc ?(printNameAsIs = false) - (outSigItem : Outcometree.out_sig_item) = - match outSigItem with - | Osig_class _ | Osig_class_type _ -> Doc.nil - | Osig_ellipsis -> Doc.dotdotdot - | Osig_value valueDecl -> - Doc.group - (Doc.concat - [ - printOutAttributesDoc valueDecl.oval_attributes; - Doc.text - (match valueDecl.oval_prims with - | [] -> "let " - | _ -> "external "); - Doc.text valueDecl.oval_name; - Doc.text ":"; - Doc.space; - printOutTypeDoc valueDecl.oval_type; - (match valueDecl.oval_prims with - | [] -> Doc.nil - | primitives -> - Doc.indent - (Doc.concat - [ - Doc.text " ="; - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map - (fun prim -> - let prim = - if - prim <> "" - && (prim.[0] [@doesNotRaise]) = '\132' - then "#rescript-external" - else prim - in - (* not display those garbage '\132' is a magic number for marshal *) - Doc.text ("\"" ^ prim ^ "\"")) - primitives)); - ])); - ]) - | Osig_typext (outExtensionConstructor, _outExtStatus) -> - printOutExtensionConstructorDoc outExtensionConstructor - | Osig_modtype (modName, Omty_signature []) -> - Doc.concat [Doc.text "module type "; Doc.text modName] - | Osig_modtype (modName, outModuleType) -> - Doc.group - (Doc.concat - [ - Doc.text "module type "; - Doc.text modName; - Doc.text " = "; - printOutModuleTypeDoc outModuleType; - ]) - | Osig_module (modName, Omty_alias ident, _) -> - Doc.group - (Doc.concat - [ - Doc.text "module "; - Doc.text modName; - Doc.text " ="; - Doc.line; - printOutIdentDoc ident; - ]) - | Osig_module (modName, outModType, outRecStatus) -> - Doc.group - (Doc.concat - [ - Doc.text - (match outRecStatus with - | Orec_not -> "module " - | Orec_first -> "module rec " - | Orec_next -> "and "); - Doc.text modName; - Doc.text ": "; - printOutModuleTypeDoc outModType; - ]) - | Osig_type (outTypeDecl, outRecStatus) -> - (* TODO: manifest ? *) - let attrs = - match (outTypeDecl.otype_immediate, outTypeDecl.otype_unboxed) with - | false, false -> Doc.nil - | true, false -> Doc.concat [Doc.text "@immediate"; Doc.line] - | false, true -> Doc.concat [Doc.text "@unboxed"; Doc.line] - | true, true -> Doc.concat [Doc.text "@immediate @unboxed"; Doc.line] - in - let kw = - Doc.text - (match outRecStatus with - | Orec_not -> "type " - | Orec_first -> "type rec " - | Orec_next -> "and ") - in - let typeParams = - match outTypeDecl.otype_params with - | [] -> Doc.nil - | _params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printTypeParameterDoc outTypeDecl.otype_params); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) - in - let privateDoc = - match outTypeDecl.otype_private with - | Asttypes.Private -> Doc.text "private " - | Public -> Doc.nil - in - let kind = - match outTypeDecl.otype_type with - | Otyp_open -> Doc.concat [Doc.text " = "; privateDoc; Doc.text ".."] - | Otyp_abstract -> Doc.nil - | Otyp_record record -> - Doc.concat - [ - Doc.text " = "; - privateDoc; - printRecordDeclarationDoc ~inline:false record; - ] - | typ -> Doc.concat [Doc.text " = "; printOutTypeDoc typ] - in - let constraints = - match outTypeDecl.otype_cstrs with - | [] -> Doc.nil - | _ -> - Doc.group - (Doc.indent - (Doc.concat - [ - Doc.hardLine; - Doc.join ~sep:Doc.line - (List.map - (fun (typ1, typ2) -> - Doc.group - (Doc.concat - [ - Doc.text "constraint "; - printOutTypeDoc typ1; - Doc.text " ="; - Doc.space; - printOutTypeDoc typ2; - ])) - outTypeDecl.otype_cstrs); - ])) - in - Doc.group - (Doc.concat - [ - attrs; - Doc.group - (Doc.concat - [ - kw; - (if printNameAsIs then Doc.text outTypeDecl.otype_name - else printIdentLike ~allowUident:false outTypeDecl.otype_name); - typeParams; - kind; - ]); - constraints; - ]) - -and printOutModuleTypeDoc (outModType : Outcometree.out_module_type) = - match outModType with - | Omty_abstract -> Doc.nil - | Omty_ident ident -> printOutIdentDoc ident - (* example: module Increment = (M: X_int) => X_int *) - | Omty_functor _ -> - let args, returnModType = collectFunctorArgs outModType [] in - let argsDoc = - match args with - | [(_, None)] -> Doc.text "()" - | args -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (lbl, optModType) -> - Doc.group - (Doc.concat - [ - Doc.text lbl; - (match optModType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - Doc.text ": "; - printOutModuleTypeDoc modType; - ]); - ])) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - Doc.group - (Doc.concat - [argsDoc; Doc.text " => "; printOutModuleTypeDoc returnModType]) - | Omty_signature [] -> Doc.nil - | Omty_signature signature -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; printOutSignatureDoc signature]); - Doc.softLine; - Doc.rbrace; - ]) - | Omty_alias _ident -> Doc.nil - -and printOutSignatureDoc (signature : Outcometree.out_sig_item list) = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | Outcometree.Osig_typext (ext, Oext_first) :: items -> - (* Gather together the extension constructors *) - let rec gather_extensions acc items = - match items with - | Outcometree.Osig_typext (ext, Oext_next) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) - :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, items = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] - items - in - let te = - { - Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - let doc = printOutTypeExtensionDoc te in - loop items (doc :: acc) - | item :: items -> - let doc = printOutSigItemDoc ~printNameAsIs:false item in - loop items (doc :: acc) - in - match loop signature [] with - | [doc] -> doc - | docs -> Doc.breakableGroup ~forceBreak:true (Doc.join ~sep:Doc.line docs) - -and printOutExtensionConstructorDoc - (outExt : Outcometree.out_extension_constructor) = - let typeParams = - match outExt.oext_type_params with - | [] -> Doc.nil - | params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ty -> - Doc.text (if ty = "_" then ty else "'" ^ ty)) - params); - ]); - Doc.softLine; - Doc.greaterThan; - ]) - in - - Doc.group - (Doc.concat - [ - Doc.text "type "; - printIdentLike ~allowUident:false outExt.oext_type_name; - typeParams; - Doc.text " += "; - Doc.line; - (if outExt.oext_private = Asttypes.Private then Doc.text "private " - else Doc.nil); - printOutConstructorDoc - ( outExt.oext_name, - outExt.oext_args, - outExt.oext_ret_type, - outExt.oext_repr ); - ]) - -and printOutTypeExtensionDoc (typeExtension : Outcometree.out_type_extension) = - let typeParams = - match typeExtension.otyext_params with - | [] -> Doc.nil - | params -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ty -> - Doc.text (if ty = "_" then ty else "'" ^ ty)) - params); - ]); - Doc.softLine; - Doc.greaterThan; - ]) - in - - Doc.group - (Doc.concat - [ - Doc.text "type "; - printIdentLike ~allowUident:false typeExtension.otyext_name; - typeParams; - Doc.text " += "; - (if typeExtension.otyext_private = Asttypes.Private then - Doc.text "private " - else Doc.nil); - printOutConstructorsDoc typeExtension.otyext_constructors; - ]) - -let printOutSigItem fmt outSigItem = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSigItemDoc outSigItem)) - -let printOutSignature fmt signature = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutSignatureDoc signature)) - -let validFloatLexeme s = - let l = String.length s in - let rec loop i = - if i >= l then s ^ "." - else - match s.[i] [@doesNotRaise] with - | '0' .. '9' | '-' -> loop (i + 1) - | _ -> s - in - loop 0 - -let floatRepres f = - match classify_float f with - | FP_nan -> "nan" - | FP_infinite -> if f < 0.0 then "neg_infinity" else "infinity" - | _ -> - let float_val = - let s1 = Printf.sprintf "%.12g" f in - if f = (float_of_string [@doesNotRaise]) s1 then s1 - else - let s2 = Printf.sprintf "%.15g" f in - if f = (float_of_string [@doesNotRaise]) s2 then s2 - else Printf.sprintf "%.18g" f - in - validFloatLexeme float_val - -let rec printOutValueDoc (outValue : Outcometree.out_value) = - match outValue with - | Oval_array outValues -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - | Oval_char c -> Doc.text ("'" ^ Char.escaped c ^ "'") - | Oval_constr (outIdent, outValues) -> - Doc.group - (Doc.concat - [ - printOutIdentDoc outIdent; - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - | Oval_ellipsis -> Doc.text "..." - | Oval_int i -> Doc.text (Format.sprintf "%i" i) - | Oval_int32 i -> Doc.text (Format.sprintf "%lil" i) - | Oval_int64 i -> Doc.text (Format.sprintf "%LiL" i) - | Oval_nativeint i -> Doc.text (Format.sprintf "%nin" i) - | Oval_float f -> Doc.text (floatRepres f) - | Oval_list outValues -> - Doc.group - (Doc.concat - [ - Doc.text "list["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - | Oval_printer fn -> - let fmt = Format.str_formatter in - fn fmt; - let str = Format.flush_str_formatter () in - Doc.text str - | Oval_record rows -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (outIdent, outValue) -> - Doc.group - (Doc.concat - [ - printOutIdentDoc outIdent; - Doc.text ": "; - printOutValueDoc outValue; - ])) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - | Oval_string (txt, _sizeToPrint, _kind) -> - Doc.text (escapeStringContents txt) - | Oval_stuff txt -> Doc.text txt - | Oval_tuple outValues -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map printOutValueDoc outValues); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - (* Not supported by ReScript *) - | Oval_variant _ -> Doc.nil - -let printOutExceptionDoc exc outValue = - match exc with - | Sys.Break -> Doc.text "Interrupted." - | Out_of_memory -> Doc.text "Out of memory during evaluation." - | Stack_overflow -> - Doc.text "Stack overflow during evaluation (looping recursion?)." - | _ -> - Doc.group - (Doc.indent - (Doc.concat - [Doc.text "Exception:"; Doc.line; printOutValueDoc outValue])) - -let printOutPhraseSignature signature = - let rec loop signature acc = - match signature with - | [] -> List.rev acc - | (Outcometree.Osig_typext (ext, Oext_first), None) :: signature -> - (* Gather together extension constructors *) - let rec gather_extensions acc items = - match items with - | (Outcometree.Osig_typext (ext, Oext_next), None) :: items -> - gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr) - :: acc) - items - | _ -> (List.rev acc, items) - in - let exts, signature = - gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type, ext.oext_repr)] - signature - in - let te = - { - Outcometree.otyext_name = ext.oext_type_name; - otyext_params = ext.oext_type_params; - otyext_constructors = exts; - otyext_private = ext.oext_private; - } - in - let doc = printOutTypeExtensionDoc te in - loop signature (doc :: acc) - | (sigItem, optOutValue) :: signature -> - let doc = - match optOutValue with - | None -> printOutSigItemDoc sigItem - | Some outValue -> - Doc.group - (Doc.concat - [ - printOutSigItemDoc sigItem; - Doc.text " = "; - printOutValueDoc outValue; - ]) - in - loop signature (doc :: acc) - in - Doc.breakableGroup ~forceBreak:true - (Doc.join ~sep:Doc.line (loop signature [])) - -let printOutPhraseDoc (outPhrase : Outcometree.out_phrase) = - match outPhrase with - | Ophr_eval (outValue, outType) -> - Doc.group - (Doc.concat - [ - Doc.text "- : "; - printOutTypeDoc outType; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printOutValueDoc outValue]); - ]) - | Ophr_signature [] -> Doc.nil - | Ophr_signature signature -> printOutPhraseSignature signature - | Ophr_exception (exc, outValue) -> printOutExceptionDoc exc outValue - -let printOutPhrase fmt outPhrase = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutPhraseDoc outPhrase)) - -let printOutModuleType fmt outModuleType = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutModuleTypeDoc outModuleType)) - -let printOutTypeExtension fmt typeExtension = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutTypeExtensionDoc typeExtension)) - -let printOutValue fmt outValue = - Format.pp_print_string fmt - (Doc.toString ~width:80 (printOutValueDoc outValue)) - -(* Not supported in ReScript *) -(* Oprint.out_class_type *) -let setup = - lazy - (Oprint.out_value := printOutValue; - Oprint.out_type := printOutType; - Oprint.out_module_type := printOutModuleType; - Oprint.out_sig_item := printOutSigItem; - Oprint.out_signature := printOutSignature; - Oprint.out_type_extension := printOutTypeExtension; - Oprint.out_phrase := printOutPhrase) diff --git a/jscomp/syntax/src/res_parens.ml b/jscomp/syntax/src/res_parens.ml deleted file mode 100644 index 83ae636..0000000 --- a/jscomp/syntax/src/res_parens.ml +++ /dev/null @@ -1,482 +0,0 @@ -module ParsetreeViewer = Res_parsetree_viewer -type kind = Parenthesized | Braced of Location.t | Nothing - -let expr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) - -let exprRecordRowRhs e = - let kind = expr e in - match kind with - | Nothing when Res_parsetree_viewer.hasOptionalAttribute e.pexp_attributes - -> ( - match e.pexp_desc with - | Pexp_ifthenelse _ | Pexp_fun _ -> Parenthesized - | _ -> kind) - | _ -> kind - -let callExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | _ -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | _ - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when Ast_uncurried.exprIsUncurriedFun expr -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) - -let structureExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | _ - when ParsetreeViewer.hasAttributes expr.pexp_attributes - && not (ParsetreeViewer.isJsxExpression expr) -> - Parenthesized - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) - -let unaryExprOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isUnaryExpression expr - || ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some expr)} - when ParsetreeViewer.isUnderscoreApplySugar expr -> - Nothing - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some _)} -> - Parenthesized - | _ -> Nothing) - -let binaryExprOperand ~isLhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - Pexp_constraint _ | Pexp_fun _ | Pexp_function _ | Pexp_newtype _; - } -> - Parenthesized - | _ when Ast_uncurried.exprIsUncurriedFun expr -> Parenthesized - | expr when ParsetreeViewer.isBinaryExpression expr -> Parenthesized - | expr when ParsetreeViewer.isTernaryExpr expr -> Parenthesized - | {pexp_desc = Pexp_lazy _ | Pexp_assert _} when isLhs -> Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | {Parsetree.pexp_attributes = attrs} -> - if ParsetreeViewer.hasPrintableAttributes attrs then Parenthesized - else Nothing) - -let subBinaryExprOperand parentOperator childOperator = - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence childOperator in - precParent > precChild - || precParent == precChild - && not (ParsetreeViewer.flattenableOperators parentOperator childOperator) - || (* a && b || c, add parens to (a && b) for readability, who knows the difference by heart… *) - (parentOperator = "||" && childOperator = "&&") - -let rhsBinaryExprOperand parentOperator rhs = - match rhs.Parsetree.pexp_desc with - | Parsetree.Pexp_apply - ( { - pexp_attributes = []; - pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; - }, - [(_, _left); (_, _right)] ) - when ParsetreeViewer.isBinaryOperator operator - && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent == precChild - | _ -> false - -let flattenOperandRhs parentOperator rhs = - match rhs.Parsetree.pexp_desc with - | Parsetree.Pexp_apply - ( { - pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; - }, - [(_, _left); (_, _right)] ) - when ParsetreeViewer.isBinaryOperator operator - && not (operatorLoc.loc_ghost && operator = "^") -> - let precParent = ParsetreeViewer.operatorPrecedence parentOperator in - let precChild = ParsetreeViewer.operatorPrecedence operator in - precParent >= precChild || rhs.pexp_attributes <> [] - | Pexp_construct ({txt = Lident "Function$"}, Some _) -> true - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false - | Pexp_fun _ when ParsetreeViewer.isUnderscoreApplySugar rhs -> false - | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true - | _ when ParsetreeViewer.isTernaryExpr rhs -> true - | _ -> false - -let binaryOperatorInsideAwaitNeedsParens operator = - ParsetreeViewer.operatorPrecedence operator - < ParsetreeViewer.operatorPrecedence "|." - -let lazyOrAssertOrAwaitExprRhs ?(inAwait = false) expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | { - pexp_desc = - Pexp_apply ({pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, _); - } - when ParsetreeViewer.isBinaryExpression expr -> - if inAwait && not (binaryOperatorInsideAwaitNeedsParens operator) then - Nothing - else Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ - | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ - | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ - when (not inAwait) - && ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | _ -> Nothing) - -let isNegativeConstant constant = - let isNeg txt = - let len = String.length txt in - len > 0 && (String.get [@doesNotRaise]) txt 0 = '-' - in - match constant with - | (Parsetree.Pconst_integer (i, _) | Pconst_float (i, _)) when isNeg i -> true - | _ -> false - -let fieldExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | {Parsetree.pexp_attributes = attrs} - when match ParsetreeViewer.filterParsingAttrs attrs with - | _ :: _ -> true - | [] -> false -> - Parenthesized - | expr - when ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isUnaryExpression expr -> - Parenthesized - | { - pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constant c} when isNegativeConstant c -> Parenthesized - | {pexp_desc = Pexp_fun _} when ParsetreeViewer.isUnderscoreApplySugar expr - -> - Nothing - | { - pexp_desc = - ( Pexp_lazy _ | Pexp_assert _ - | Pexp_extension _ (* %extension.x vs (%extension).x *) | Pexp_fun _ - | Pexp_newtype _ | Pexp_function _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ - | Pexp_ifthenelse _ ); - } -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some expr)} - when ParsetreeViewer.isUnderscoreApplySugar expr -> - Nothing - | {pexp_desc = Pexp_construct ({txt = Lident "Function$"}, Some _)} -> - Parenthesized - | _ -> Nothing) - -let setFieldExprRhs expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ -> Nothing) - -let ternaryOperand expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - } -> - Nothing - | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ when Res_parsetree_viewer.isFunNewtype expr -> ( - let _uncurried, _attrsOnArrow, _parameters, returnExpr = - ParsetreeViewer.funExpr expr - in - match returnExpr.pexp_desc with - | Pexp_constraint _ -> Parenthesized - | _ -> Nothing) - | _ -> Nothing) - -let startsWithMinus txt = - let len = String.length txt in - if len == 0 then false - else - let s = (String.get [@doesNotRaise]) txt 0 in - s = '-' - -let jsxPropExpr expr = - match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ - | Pexp_letmodule _ | Pexp_open _ -> - Nothing - | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ | Pexp_tuple _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | _ -> Parenthesized)) - -let jsxChildExpr expr = - match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_let _ | Pexp_sequence _ | Pexp_letexception _ - | Pexp_letmodule _ | Pexp_open _ -> - Nothing - | _ -> ( - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | _ -> ( - match expr with - | { - Parsetree.pexp_desc = - Pexp_constant (Pconst_integer (x, _) | Pconst_float (x, _)); - pexp_attributes = []; - } - when startsWithMinus x -> - Parenthesized - | _ when ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes -> - Parenthesized - | { - Parsetree.pexp_desc = - ( Pexp_ident _ | Pexp_constant _ | Pexp_field _ | Pexp_construct _ - | Pexp_variant _ | Pexp_array _ | Pexp_pack _ | Pexp_record _ - | Pexp_extension _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ | Pexp_sequence _ | Pexp_let _ ); - pexp_attributes = []; - } -> - Nothing - | { - Parsetree.pexp_desc = - Pexp_constraint - ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}); - pexp_attributes = []; - } -> - Nothing - | expr when ParsetreeViewer.isJsxExpression expr -> Nothing - | _ -> Parenthesized)) - -let binaryExpr expr = - let optBraces, _ = ParsetreeViewer.processBracesAttr expr in - match optBraces with - | Some ({Location.loc = bracesLoc}, _) -> Braced bracesLoc - | None -> ( - match expr with - | {Parsetree.pexp_attributes = _ :: _} as expr - when ParsetreeViewer.isBinaryExpression expr -> - Parenthesized - | _ -> Nothing) - -let modTypeFunctorReturn modType = - match modType with - | {Parsetree.pmty_desc = Pmty_with _} -> true - | _ -> false - -(* Add parens for readability: - module type Functor = SetLike => Set with type t = A.t - This is actually: - module type Functor = (SetLike => Set) with type t = A.t -*) -let modTypeWithOperand modType = - match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true - | _ -> false - -let modExprFunctorConstraint modType = - match modType with - | {Parsetree.pmty_desc = Pmty_functor _ | Pmty_with _} -> true - | _ -> false - -let bracedExpr expr = - match expr.Parsetree.pexp_desc with - | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> - false - | Pexp_constraint _ -> true - | _ -> false - -let includeModExpr modExpr = - match modExpr.Parsetree.pmod_desc with - | Parsetree.Pmod_constraint _ -> true - | _ -> false - -let modExprParens modExpr = - match modExpr with - | { - Parsetree.pmod_desc = - Pmod_constraint - ( {Parsetree.pmod_desc = Pmod_structure _}, - {Parsetree.pmty_desc = Pmty_signature [{psig_desc = Psig_module _}]} ); - } -> - false - | { - Parsetree.pmod_desc = - Pmod_constraint - (_, {Parsetree.pmty_desc = Pmty_signature [{psig_desc = Psig_module _}]}); - } -> - true - | _ -> false - -let arrowReturnTypExpr typExpr = - match typExpr.Parsetree.ptyp_desc with - | Parsetree.Ptyp_arrow _ -> true - | _ when Ast_uncurried.coreTypeIsUncurriedFun typExpr -> true - | _ -> false - -let patternRecordRowRhs (pattern : Parsetree.pattern) = - match pattern.ppat_desc with - | Ppat_constraint ({ppat_desc = Ppat_unpack _}, {ptyp_desc = Ptyp_package _}) - -> - false - | Ppat_constraint _ -> true - | _ -> false diff --git a/jscomp/syntax/src/res_parens.mli b/jscomp/syntax/src/res_parens.mli deleted file mode 100644 index 5d1abf9..0000000 --- a/jscomp/syntax/src/res_parens.mli +++ /dev/null @@ -1,41 +0,0 @@ -type kind = Parenthesized | Braced of Location.t | Nothing - -val expr : Parsetree.expression -> kind -val structureExpr : Parsetree.expression -> kind - -val unaryExprOperand : Parsetree.expression -> kind - -val binaryExprOperand : isLhs:bool -> Parsetree.expression -> kind -val subBinaryExprOperand : string -> string -> bool -val rhsBinaryExprOperand : string -> Parsetree.expression -> bool -val flattenOperandRhs : string -> Parsetree.expression -> bool - -val binaryOperatorInsideAwaitNeedsParens : string -> bool -val lazyOrAssertOrAwaitExprRhs : ?inAwait:bool -> Parsetree.expression -> kind - -val fieldExpr : Parsetree.expression -> kind - -val setFieldExprRhs : Parsetree.expression -> kind - -val ternaryOperand : Parsetree.expression -> kind - -val jsxPropExpr : Parsetree.expression -> kind -val jsxChildExpr : Parsetree.expression -> kind - -val binaryExpr : Parsetree.expression -> kind -val modTypeFunctorReturn : Parsetree.module_type -> bool -val modTypeWithOperand : Parsetree.module_type -> bool -val modExprFunctorConstraint : Parsetree.module_type -> bool - -val bracedExpr : Parsetree.expression -> bool -val callExpr : Parsetree.expression -> kind - -val includeModExpr : Parsetree.module_expr -> bool - -val modExprParens : Parsetree.module_expr -> bool - -val arrowReturnTypExpr : Parsetree.core_type -> bool - -val patternRecordRowRhs : Parsetree.pattern -> bool - -val exprRecordRowRhs : Parsetree.expression -> kind diff --git a/jscomp/syntax/src/res_parser.ml b/jscomp/syntax/src/res_parser.ml deleted file mode 100644 index ca39cfc..0000000 --- a/jscomp/syntax/src/res_parser.ml +++ /dev/null @@ -1,195 +0,0 @@ -module Scanner = Res_scanner -module Diagnostics = Res_diagnostics -module Token = Res_token -module Grammar = Res_grammar -module Reporting = Res_reporting - -module Comment = Res_comment - -type mode = ParseForTypeChecker | Default - -type regionStatus = Report | Silent - -type t = { - mode: mode; - mutable scanner: Scanner.t; - mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; - mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; - mutable diagnostics: Diagnostics.t list; - mutable comments: Comment.t list; - mutable regions: regionStatus ref list; - mutable uncurried_config: Config.uncurried; -} - -let err ?startPos ?endPos p error = - match p.regions with - | ({contents = Report} as region) :: _ -> - let d = - Diagnostics.make - ~startPos: - (match startPos with - | Some pos -> pos - | None -> p.startPos) - ~endPos: - (match endPos with - | Some pos -> pos - | None -> p.endPos) - error - in - p.diagnostics <- d :: p.diagnostics; - region := Silent - | _ -> () - -let beginRegion p = p.regions <- ref Report :: p.regions -let endRegion p = - match p.regions with - | [] -> () - | _ :: rest -> p.regions <- rest - -let docCommentToAttributeToken comment = - let txt = Comment.txt comment in - let loc = Comment.loc comment in - Token.DocComment (loc, txt) - -let moduleCommentToAttributeToken comment = - let txt = Comment.txt comment in - let loc = Comment.loc comment in - Token.ModuleComment (loc, txt) - -(* Advance to the next non-comment token and store any encountered comment - * in the parser's state. Every comment contains the end position of its - * previous token to facilite comment interleaving *) -let rec next ?prevEndPos p = - if p.token = Eof then assert false; - let prevEndPos = - match prevEndPos with - | Some pos -> pos - | None -> p.endPos - in - let startPos, endPos, token = Scanner.scan p.scanner in - match token with - | Comment c -> - if Comment.isDocComment c then ( - p.token <- docCommentToAttributeToken c; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos) - else if Comment.isModuleComment c then ( - p.token <- moduleCommentToAttributeToken c; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos) - else ( - Comment.setPrevTokEndPos c p.endPos; - p.comments <- c :: p.comments; - p.prevEndPos <- p.endPos; - p.endPos <- endPos; - next ~prevEndPos p) - | _ -> - p.token <- token; - p.prevEndPos <- prevEndPos; - p.startPos <- startPos; - p.endPos <- endPos - -let nextUnsafe p = if p.token <> Eof then next p - -let nextTemplateLiteralToken p = - let startPos, endPos, token = Scanner.scanTemplateLiteralToken p.scanner in - p.token <- token; - p.prevEndPos <- p.endPos; - p.startPos <- startPos; - p.endPos <- endPos - -let checkProgress ~prevEndPos ~result p = - if p.endPos == prevEndPos then None else Some result - -let make ?(mode = ParseForTypeChecker) src filename = - let scanner = Scanner.make ~filename src in - let parserState = - { - mode; - scanner; - token = Token.Semicolon; - startPos = Lexing.dummy_pos; - prevEndPos = Lexing.dummy_pos; - endPos = Lexing.dummy_pos; - breadcrumbs = []; - errors = []; - diagnostics = []; - comments = []; - regions = [ref Report]; - uncurried_config = !Config.uncurried; - } - in - parserState.scanner.err <- - (fun ~startPos ~endPos error -> - let diagnostic = Diagnostics.make ~startPos ~endPos error in - parserState.diagnostics <- diagnostic :: parserState.diagnostics); - next parserState; - parserState - -let leaveBreadcrumb p circumstance = - let crumb = (circumstance, p.startPos) in - p.breadcrumbs <- crumb :: p.breadcrumbs - -let eatBreadcrumb p = - match p.breadcrumbs with - | [] -> () - | _ :: crumbs -> p.breadcrumbs <- crumbs - -let optional p token = - if p.token = token then - let () = next p in - true - else false - -let expect ?grammar token p = - if p.token = token then next p - else - let error = Diagnostics.expected ?grammar p.prevEndPos token in - err ~startPos:p.prevEndPos p error - -(* Don't use immutable copies here, it trashes certain heuristics - * in the ocaml compiler, resulting in massive slowdowns of the parser *) -let lookahead p callback = - let err = p.scanner.err in - let ch = p.scanner.ch in - let offset = p.scanner.offset in - let offset16 = p.scanner.offset16 in - let lineOffset = p.scanner.lineOffset in - let lnum = p.scanner.lnum in - let mode = p.scanner.mode in - let token = p.token in - let startPos = p.startPos in - let endPos = p.endPos in - let prevEndPos = p.prevEndPos in - let breadcrumbs = p.breadcrumbs in - let errors = p.errors in - let diagnostics = p.diagnostics in - let comments = p.comments in - let uncurried_config = p.uncurried_config in - - let res = callback p in - - p.scanner.err <- err; - p.scanner.ch <- ch; - p.scanner.offset <- offset; - p.scanner.offset16 <- offset16; - p.scanner.lineOffset <- lineOffset; - p.scanner.lnum <- lnum; - p.scanner.mode <- mode; - p.token <- token; - p.startPos <- startPos; - p.endPos <- endPos; - p.prevEndPos <- prevEndPos; - p.breadcrumbs <- breadcrumbs; - p.errors <- errors; - p.diagnostics <- diagnostics; - p.comments <- comments; - p.uncurried_config <- uncurried_config; - - res diff --git a/jscomp/syntax/src/res_parser.mli b/jscomp/syntax/src/res_parser.mli deleted file mode 100644 index 9544a7c..0000000 --- a/jscomp/syntax/src/res_parser.mli +++ /dev/null @@ -1,48 +0,0 @@ -module Scanner = Res_scanner -module Token = Res_token -module Grammar = Res_grammar -module Reporting = Res_reporting -module Diagnostics = Res_diagnostics -module Comment = Res_comment - -type mode = ParseForTypeChecker | Default - -type regionStatus = Report | Silent - -type t = { - mode: mode; - mutable scanner: Scanner.t; - mutable token: Token.t; - mutable startPos: Lexing.position; - mutable endPos: Lexing.position; - mutable prevEndPos: Lexing.position; - mutable breadcrumbs: (Grammar.t * Lexing.position) list; - mutable errors: Reporting.parseError list; - mutable diagnostics: Diagnostics.t list; - mutable comments: Comment.t list; - mutable regions: regionStatus ref list; - mutable uncurried_config: Config.uncurried; -} - -val make : ?mode:mode -> string -> string -> t - -val expect : ?grammar:Grammar.t -> Token.t -> t -> unit -val optional : t -> Token.t -> bool -val next : ?prevEndPos:Lexing.position -> t -> unit -val nextUnsafe : t -> unit (* Does not assert on Eof, makes no progress *) -val nextTemplateLiteralToken : t -> unit -val lookahead : t -> (t -> 'a) -> 'a -val err : - ?startPos:Lexing.position -> - ?endPos:Lexing.position -> - t -> - Diagnostics.category -> - unit - -val leaveBreadcrumb : t -> Grammar.t -> unit -val eatBreadcrumb : t -> unit - -val beginRegion : t -> unit -val endRegion : t -> unit - -val checkProgress : prevEndPos:Lexing.position -> result:'a -> t -> 'a option diff --git a/jscomp/syntax/src/res_parsetree_viewer.ml b/jscomp/syntax/src/res_parsetree_viewer.ml deleted file mode 100644 index 9d8d594..0000000 --- a/jscomp/syntax/src/res_parsetree_viewer.ml +++ /dev/null @@ -1,756 +0,0 @@ -open Parsetree - -let arrowType ?(arity = max_int) ct = - let rec process attrsBefore acc typ arity = - match typ with - | typ when arity <= 0 -> (attrsBefore, List.rev acc, typ) - | { - ptyp_desc = Ptyp_arrow ((Nolabel as lbl), typ1, typ2); - ptyp_attributes = []; - } -> - let arg = ([], lbl, typ1) in - process attrsBefore (arg :: acc) typ2 (arity - 1) - | { - ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); - ptyp_attributes = [({txt = "bs"}, _)]; - } -> - (* stop here, the uncurried attribute always indicates the beginning of an arrow function - * e.g. `(. int) => (. int)` instead of `(. int, . int)` *) - (attrsBefore, List.rev acc, typ) - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = _attrs} - as returnType -> - let args = List.rev acc in - (attrsBefore, args, returnType) - | { - ptyp_desc = Ptyp_arrow (((Labelled _ | Optional _) as lbl), typ1, typ2); - ptyp_attributes = attrs; - } -> - let arg = (attrs, lbl, typ1) in - process attrsBefore (arg :: acc) typ2 (arity - 1) - | typ -> (attrsBefore, List.rev acc, typ) - in - match ct with - | {ptyp_desc = Ptyp_arrow (Nolabel, _typ1, _typ2); ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} arity - | typ -> process [] [] typ arity - -let functorType modtype = - let rec process acc modtype = - match modtype with - | { - pmty_desc = Pmty_functor (lbl, argType, returnType); - pmty_attributes = attrs; - } -> - let arg = (attrs, lbl, argType) in - process (arg :: acc) returnType - | modType -> (List.rev acc, modType) - in - process [] modtype - -let processBsAttribute attrs = - let rec process bsSpotted acc attrs = - match attrs with - | [] -> (bsSpotted, List.rev acc) - | ({Location.txt = "bs"}, _) :: rest -> process true acc rest - | attr :: rest -> process bsSpotted (attr :: acc) rest - in - process false [] attrs - -let processUncurriedAppAttribute attrs = - let rec process uncurriedApp acc attrs = - match attrs with - | [] -> (uncurriedApp, List.rev acc) - | ( { - Location.txt = - "bs" (* still support @bs to convert .ml files *) | "res.uapp"; - }, - _ ) - :: rest -> - process true acc rest - | attr :: rest -> process uncurriedApp (attr :: acc) rest - in - process false [] attrs - -let hasPartialAttribute attrs = - List.exists - (function - | {Location.txt = "res.partial"}, _ -> true - | _ -> false) - attrs - -let processPartialAppAttribute attrs = - let rec process partialApp acc attrs = - match attrs with - | [] -> (partialApp, List.rev acc) - | ({Location.txt = "res.partial"}, _) :: rest -> process true acc rest - | attr :: rest -> process partialApp (attr :: acc) rest - in - process false [] attrs - -type functionAttributesInfo = { - async: bool; - bs: bool; - attributes: Parsetree.attributes; -} - -let processFunctionAttributes attrs = - let rec process async bs acc attrs = - match attrs with - | [] -> {async; bs; attributes = List.rev acc} - | ({Location.txt = "bs"}, _) :: rest -> process async true acc rest - | ({Location.txt = "res.async"}, _) :: rest -> process true bs acc rest - | attr :: rest -> process async bs (attr :: acc) rest - in - process false false [] attrs - -let hasAwaitAttribute attrs = - List.exists - (function - | {Location.txt = "res.await"}, _ -> true - | _ -> false) - attrs - -let collectArrayExpressions expr = - match expr.pexp_desc with - | Pexp_array exprs -> (exprs, None) - | _ -> ([], Some expr) - -let collectListExpressions expr = - let rec collect acc expr = - match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) - | Pexp_construct - ( {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple (hd :: [tail])} ) -> - collect (hd :: acc) tail - | _ -> (List.rev acc, Some expr) - in - collect [] expr - -(* (__x) => f(a, __x, c) -----> f(a, _, c) *) -let rewriteUnderscoreApply expr = - let expr_fun = - if Ast_uncurried.exprIsUncurriedFun expr then - Ast_uncurried.exprExtractUncurriedFun expr - else expr - in - match expr_fun.pexp_desc with - | Pexp_fun - ( Nolabel, - None, - {ppat_desc = Ppat_var {txt = "__x"}}, - ({pexp_desc = Pexp_apply (callExpr, args)} as e) ) -> - let newArgs = - List.map - (fun arg -> - match arg with - | ( lbl, - ({pexp_desc = Pexp_ident ({txt = Longident.Lident "__x"} as lid)} - as argExpr) ) -> - ( lbl, - { - argExpr with - pexp_desc = Pexp_ident {lid with txt = Longident.Lident "_"}; - } ) - | arg -> arg) - args - in - {e with pexp_desc = Pexp_apply (callExpr, newArgs)} - | _ -> expr - -type funParamKind = - | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; - } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} - -let funExpr expr = - (* Turns (type t, type u, type z) into "type t u z" *) - let rec collectNewTypes acc returnExpr = - match returnExpr with - | {pexp_desc = Pexp_newtype (stringLoc, returnExpr); pexp_attributes = []} - -> - collectNewTypes (stringLoc :: acc) returnExpr - | returnExpr -> (List.rev acc, returnExpr) - in - let rec collect ~uncurried ~nFun attrsBefore acc expr = - match expr with - | { - pexp_desc = - Pexp_fun - ( Nolabel, - None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ); - } -> - (uncurried, attrsBefore, List.rev acc, rewriteUnderscoreApply expr) - | {pexp_desc = Pexp_newtype (stringLoc, rest); pexp_attributes = attrs} -> - let stringLocs, returnExpr = collectNewTypes [stringLoc] rest in - let param = NewTypes {attrs; locs = stringLocs} in - collect ~uncurried ~nFun attrsBefore (param :: acc) returnExpr - | { - pexp_desc = Pexp_fun (lbl, defaultExpr, pattern, returnExpr); - pexp_attributes = []; - } -> - let parameter = Parameter {attrs = []; lbl; defaultExpr; pat = pattern} in - collect ~uncurried ~nFun:(nFun + 1) attrsBefore (parameter :: acc) - returnExpr - (* If a fun has an attribute, then it stops here and makes currying. - i.e attributes outside of (...), uncurried `(.)` and `async` make currying *) - | {pexp_desc = Pexp_fun _} -> (uncurried, attrsBefore, List.rev acc, expr) - | expr when nFun = 0 && Ast_uncurried.exprIsUncurriedFun expr -> - let expr = Ast_uncurried.exprExtractUncurriedFun expr in - collect ~uncurried:true ~nFun attrsBefore acc expr - | expr -> (uncurried, attrsBefore, List.rev acc, expr) - in - match expr with - | {pexp_desc = Pexp_fun _ | Pexp_newtype _} -> - collect ~uncurried:false ~nFun:0 expr.pexp_attributes [] - {expr with pexp_attributes = []} - | _ when Ast_uncurried.exprIsUncurriedFun expr -> - let expr = Ast_uncurried.exprExtractUncurriedFun expr in - collect ~uncurried:true ~nFun:0 expr.pexp_attributes [] - {expr with pexp_attributes = []} - | _ -> collect ~uncurried:false ~nFun:0 [] [] expr - -let processBracesAttr expr = - match expr.pexp_attributes with - | (({txt = "res.braces" | "ns.braces"}, _) as attr) :: attrs -> - (Some attr, {expr with pexp_attributes = attrs}) - | _ -> (None, expr) - -let filterParsingAttrs attrs = - List.filter - (fun attr -> - match attr with - | ( { - Location.txt = - ( "bs" | "res.uapp" | "res.arity" | "res.braces" | "ns.braces" - | "res.iflet" | "res.namedArgLoc" | "res.optional" | "res.ternary" - | "res.async" | "res.await" | "res.template" - | "res.taggedTemplate" ); - }, - _ ) -> - false - | _ -> true) - attrs - -let isBlockExpr expr = - match expr.pexp_desc with - | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ - | Pexp_sequence _ -> - true - | _ -> false - -let isBracedExpr expr = - match processBracesAttr expr with - | Some _, _ -> true - | _ -> false - -let isMultilineText txt = - let len = String.length txt in - let rec check i = - if i >= len then false - else - let c = String.unsafe_get txt i in - match c with - | '\010' | '\013' -> true - | '\\' -> if i + 2 = len then false else check (i + 2) - | _ -> check (i + 1) - in - check 0 - -let isHuggableExpression expr = - match expr.pexp_desc with - | Pexp_array _ | Pexp_tuple _ - | Pexp_constant (Pconst_string (_, Some _)) - | Pexp_construct ({txt = Longident.Lident ("::" | "[]")}, _) - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) - | Pexp_record _ -> - true - | _ when isBlockExpr expr -> true - | _ when isBracedExpr expr -> true - | Pexp_constant (Pconst_string (txt, None)) when isMultilineText txt -> true - | _ -> false - -let isHuggableRhs expr = - match expr.pexp_desc with - | Pexp_array _ | Pexp_tuple _ - | Pexp_extension ({txt = "bs.obj" | "obj"}, _) - | Pexp_record _ -> - true - | _ when isBracedExpr expr -> true - | _ -> false - -let isHuggablePattern pattern = - match pattern.ppat_desc with - | Ppat_array _ | Ppat_tuple _ | Ppat_record _ | Ppat_variant _ - | Ppat_construct _ -> - true - | _ -> false - -let operatorPrecedence operator = - match operator with - | ":=" -> 1 - | "||" -> 2 - | "&&" -> 3 - | "=" | "==" | "<" | ">" | "!=" | "<>" | "!==" | "<=" | ">=" | "|>" -> 4 - | "+" | "+." | "-" | "-." | "^" -> 5 - | "*" | "*." | "/" | "/." -> 6 - | "**" -> 7 - | "#" | "##" | "|." | "|.u" -> 8 - | _ -> 0 - -let isUnaryOperator operator = - match operator with - | "~+" | "~+." | "~-" | "~-." | "not" -> true - | _ -> false - -let isUnaryExpression expr = - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, _arg)] ) - when isUnaryOperator operator -> - true - | _ -> false - -(* TODO: tweak this to check for ghost ^ as template literal *) -let isBinaryOperator operator = - match operator with - | ":=" | "||" | "&&" | "=" | "==" | "<" | ">" | "!=" | "!==" | "<=" | ">=" - | "|>" | "+" | "+." | "-" | "-." | "^" | "*" | "*." | "/" | "/." | "**" | "|." - | "|.u" | "<>" -> - true - | _ -> false - -let isBinaryExpression expr = - match expr.pexp_desc with - | Pexp_apply - ( { - pexp_desc = - Pexp_ident {txt = Longident.Lident operator; loc = operatorLoc}; - }, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) - when isBinaryOperator operator - && not (operatorLoc.loc_ghost && operator = "^") - (* template literal *) -> - true - | _ -> false - -let isEqualityOperator operator = - match operator with - | "=" | "==" | "<>" | "!=" -> true - | _ -> false - -let isRhsBinaryOperator operator = - match operator with - | "**" -> true - | _ -> false - -let flattenableOperators parentOperator childOperator = - let precParent = operatorPrecedence parentOperator in - let precChild = operatorPrecedence childOperator in - if precParent == precChild then - not (isEqualityOperator parentOperator && isEqualityOperator childOperator) - else false - -let rec hasIfLetAttribute attrs = - match attrs with - | [] -> false - | ({Location.txt = "res.iflet"}, _) :: _ -> true - | _ :: attrs -> hasIfLetAttribute attrs - -let isIfLetExpr expr = - match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_match _} - when hasIfLetAttribute attrs -> - true - | _ -> false - -let rec hasOptionalAttribute attrs = - match attrs with - | [] -> false - | ({Location.txt = "ns.optional" | "res.optional"}, _) :: _ -> true - | _ :: attrs -> hasOptionalAttribute attrs - -let hasAttributes attrs = - List.exists - (fun attr -> - match attr with - | ( { - Location.txt = - ( "bs" | "res.uapp" | "res.arity" | "res.braces" | "ns.braces" - | "res.iflet" | "res.ternary" | "res.async" | "res.await" - | "res.template" ); - }, - _ ) -> - false - (* Remove the fragile pattern warning for iflet expressions *) - | ( {Location.txt = "warning"}, - PStr - [ - { - pstr_desc = - Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", None))}, _); - }; - ] ) -> - not (hasIfLetAttribute attrs) - | _ -> true) - attrs - -let isArrayAccess expr = - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, _parentExpr); (Nolabel, _memberExpr)] ) -> - true - | _ -> false - -type ifConditionKind = - | If of Parsetree.expression - | IfLet of Parsetree.pattern * Parsetree.expression - -let collectIfExpressions expr = - let rec collect acc expr = - let exprLoc = expr.pexp_loc in - match expr.pexp_desc with - | Pexp_ifthenelse (ifExpr, thenExpr, Some elseExpr) -> - collect ((exprLoc, If ifExpr, thenExpr) :: acc) elseExpr - | Pexp_ifthenelse (ifExpr, thenExpr, (None as elseExpr)) -> - let ifs = List.rev ((exprLoc, If ifExpr, thenExpr) :: acc) in - (ifs, elseExpr) - | Pexp_match - ( condition, - [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; - { - pc_rhs = - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}; - }; - ] ) - when isIfLetExpr expr -> - let ifs = - List.rev ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) - in - (ifs, None) - | Pexp_match - ( condition, - [ - {pc_lhs = pattern; pc_guard = None; pc_rhs = thenExpr}; - {pc_rhs = elseExpr}; - ] ) - when isIfLetExpr expr -> - collect ((exprLoc, IfLet (pattern, condition), thenExpr) :: acc) elseExpr - | _ -> (List.rev acc, Some expr) - in - collect [] expr - -let rec hasTernaryAttribute attrs = - match attrs with - | [] -> false - | ({Location.txt = "res.ternary"}, _) :: _ -> true - | _ :: attrs -> hasTernaryAttribute attrs - -let isTernaryExpr expr = - match expr with - | {pexp_attributes = attrs; pexp_desc = Pexp_ifthenelse _} - when hasTernaryAttribute attrs -> - true - | _ -> false - -let collectTernaryParts expr = - let rec collect acc expr = - match expr with - | { - pexp_attributes = attrs; - pexp_desc = Pexp_ifthenelse (condition, consequent, Some alternate); - } - when hasTernaryAttribute attrs -> - collect ((condition, consequent) :: acc) alternate - | alternate -> (List.rev acc, alternate) - in - collect [] expr - -let parametersShouldHug parameters = - match parameters with - | [Parameter {attrs = []; lbl = Asttypes.Nolabel; defaultExpr = None; pat}] - when isHuggablePattern pat -> - true - | _ -> false - -let filterTernaryAttributes attrs = - List.filter - (fun attr -> - match attr with - | {Location.txt = "res.ternary"}, _ -> false - | _ -> true) - attrs - -let filterFragileMatchAttributes attrs = - List.filter - (fun attr -> - match attr with - | ( {Location.txt = "warning"}, - PStr - [ - { - pstr_desc = - Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string ("-4", _))}, _); - }; - ] ) -> - false - | _ -> true) - attrs - -let isJsxExpression expr = - let rec loop attrs = - match attrs with - | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true - | _ :: attrs -> loop attrs - in - match expr.pexp_desc with - | Pexp_apply _ -> loop expr.Parsetree.pexp_attributes - | _ -> false - -let hasJsxAttribute attributes = - let rec loop attrs = - match attrs with - | [] -> false - | ({Location.txt = "JSX"}, _) :: _ -> true - | _ :: attrs -> loop attrs - in - loop attributes - -let shouldIndentBinaryExpr expr = - let samePrecedenceSubExpression operator subExpression = - match subExpression with - | { - pexp_desc = - Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident subOperator}}, - [(Nolabel, _lhs); (Nolabel, _rhs)] ); - } - when isBinaryOperator subOperator -> - flattenableOperators operator subOperator - | _ -> true - in - match expr with - | { - pexp_desc = - Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, _rhs)] ); - } - when isBinaryOperator operator -> - isEqualityOperator operator - || (not (samePrecedenceSubExpression operator lhs)) - || operator = ":=" - | _ -> false - -let shouldInlineRhsBinaryExpr rhs = - match rhs.pexp_desc with - | Parsetree.Pexp_constant _ | Pexp_let _ | Pexp_letmodule _ - | Pexp_letexception _ | Pexp_sequence _ | Pexp_open _ | Pexp_ifthenelse _ - | Pexp_for _ | Pexp_while _ | Pexp_try _ | Pexp_array _ | Pexp_record _ -> - true - | _ -> false - -let isPrintableAttribute attr = - match attr with - | ( { - Location.txt = - ( "bs" | "res.uapp" | "res.arity" | "res.iflet" | "res.braces" - | "ns.braces" | "JSX" | "res.async" | "res.await" | "res.template" - | "res.ternary" ); - }, - _ ) -> - false - | _ -> true - -let hasPrintableAttributes attrs = List.exists isPrintableAttribute attrs - -let filterPrintableAttributes attrs = List.filter isPrintableAttribute attrs - -let partitionPrintableAttributes attrs = - List.partition isPrintableAttribute attrs - -let isFunNewtype expr = - match expr.pexp_desc with - | Pexp_fun _ | Pexp_newtype _ -> true - | _ -> Ast_uncurried.exprIsUncurriedFun expr - -let requiresSpecialCallbackPrintingLastArg args = - let rec loop args = - match args with - | [] -> false - | [(_, expr)] when isFunNewtype expr -> true - | (_, expr) :: _ when isFunNewtype expr -> false - | _ :: rest -> loop rest - in - loop args - -let requiresSpecialCallbackPrintingFirstArg args = - let rec loop args = - match args with - | [] -> true - | (_, expr) :: _ when isFunNewtype expr -> false - | _ :: rest -> loop rest - in - match args with - | [(_, expr)] when isFunNewtype expr -> false - | (_, expr) :: rest when isFunNewtype expr -> loop rest - | _ -> false - -let modExprApply modExpr = - let rec loop acc modExpr = - match modExpr with - | {pmod_desc = Pmod_apply (next, arg)} -> loop (arg :: acc) next - | _ -> (acc, modExpr) - in - loop [] modExpr - -let modExprFunctor modExpr = - let rec loop acc modExpr = - match modExpr with - | { - pmod_desc = Pmod_functor (lbl, modType, returnModExpr); - pmod_attributes = attrs; - } -> - let param = (attrs, lbl, modType) in - loop (param :: acc) returnModExpr - | returnModExpr -> (List.rev acc, returnModExpr) - in - loop [] modExpr - -let rec collectPatternsFromListConstruct acc pattern = - let open Parsetree in - match pattern.ppat_desc with - | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> - collectPatternsFromListConstruct (pat :: acc) rest - | _ -> (List.rev acc, pattern) - -let hasTemplateLiteralAttr attrs = - List.exists - (fun attr -> - match attr with - | {Location.txt = "res.template"}, _ -> true - | _ -> false) - attrs - -let hasTaggedTemplateLiteralAttr attrs = - List.exists - (fun attr -> - match attr with - | {Location.txt = "res.taggedTemplate"}, _ -> true - | _ -> false) - attrs - -let isTemplateLiteral expr = - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, _); (Nolabel, _)] ) - when hasTemplateLiteralAttr expr.pexp_attributes -> - true - | Pexp_constant (Pconst_string (_, Some "")) -> true - | Pexp_constant _ when hasTemplateLiteralAttr expr.pexp_attributes -> true - | _ -> false - -let isTaggedTemplateLiteral expr = - match expr with - | {pexp_desc = Pexp_apply _; pexp_attributes = attrs} -> - hasTaggedTemplateLiteralAttr attrs - | _ -> false - -let hasSpreadAttr attrs = - List.exists - (fun attr -> - match attr with - | {Location.txt = "res.spread"}, _ -> true - | _ -> false) - attrs - -let isSpreadBeltListConcat expr = - match expr.pexp_desc with - | Pexp_ident - { - txt = - Longident.Ldot - (Longident.Ldot (Longident.Lident "Belt", "List"), "concatMany"); - } -> - hasSpreadAttr expr.pexp_attributes - | _ -> false - -let isSpreadBeltArrayConcat expr = - match expr.pexp_desc with - | Pexp_ident - { - txt = - Longident.Ldot - (Longident.Ldot (Longident.Lident "Belt", "Array"), "concatMany"); - } -> - hasSpreadAttr expr.pexp_attributes - | _ -> false - -(* Blue | Red | Green -> [Blue; Red; Green] *) -let collectOrPatternChain pat = - let rec loop pattern chain = - match pattern.ppat_desc with - | Ppat_or (left, right) -> loop left (right :: chain) - | _ -> pattern :: chain - in - loop pat [] - -let isSinglePipeExpr expr = - (* handles: - * x - * ->Js.Dict.get("wm-property") - * ->Option.flatMap(Js.Json.decodeString) - * ->Option.flatMap(x => - * switch x { - * | "like-of" => Some(#like) - * | "repost-of" => Some(#repost) - * | _ => None - * } - * ) - *) - let isPipeExpr expr = - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|.u" | "|>")}}, - [(Nolabel, _operand1); (Nolabel, _operand2)] ) -> - true - | _ -> false - in - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident ("|." | "|.u" | "|>")}}, - [(Nolabel, operand1); (Nolabel, _operand2)] ) - when not (isPipeExpr operand1) -> - true - | _ -> false - -let isUnderscoreApplySugar expr = - match expr.pexp_desc with - | Pexp_fun - ( Nolabel, - None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) -> - true - | _ -> false - -let isRewrittenUnderscoreApplySugar expr = - match expr.pexp_desc with - | Pexp_ident {txt = Longident.Lident "_"} -> true - | _ -> false diff --git a/jscomp/syntax/src/res_parsetree_viewer.mli b/jscomp/syntax/src/res_parsetree_viewer.mli deleted file mode 100644 index d1bb8df..0000000 --- a/jscomp/syntax/src/res_parsetree_viewer.mli +++ /dev/null @@ -1,174 +0,0 @@ -(* Restructures a nested tree of arrow types into its args & returnType - * The parsetree contains: a => b => c => d, for printing purposes - * we restructure the tree into (a, b, c) and its returnType d *) -val arrowType : - ?arity:int -> - Parsetree.core_type -> - Parsetree.attributes - * (Parsetree.attributes * Asttypes.arg_label * Parsetree.core_type) list - * Parsetree.core_type - -val functorType : - Parsetree.module_type -> - (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) - list - * Parsetree.module_type - -(* filters @bs out of the provided attributes *) -val processBsAttribute : Parsetree.attributes -> bool * Parsetree.attributes - -val processUncurriedAppAttribute : - Parsetree.attributes -> bool * Parsetree.attributes - -val processPartialAppAttribute : - Parsetree.attributes -> bool * Parsetree.attributes - -type functionAttributesInfo = { - async: bool; - bs: bool; - attributes: Parsetree.attributes; -} - -val hasPartialAttribute : Parsetree.attributes -> bool - -(* determines whether a function is async and/or uncurried based on the given attributes *) -val processFunctionAttributes : Parsetree.attributes -> functionAttributesInfo - -val hasAwaitAttribute : Parsetree.attributes -> bool - -type ifConditionKind = - | If of Parsetree.expression - | IfLet of Parsetree.pattern * Parsetree.expression - -(* if ... else if ... else ... is represented as nested expressions: if ... else { if ... } - * The purpose of this function is to flatten nested ifs into one sequence. - * Basically compute: ([if, else if, else if, else if], else) *) -val collectIfExpressions : - Parsetree.expression -> - (Location.t * ifConditionKind * Parsetree.expression) list - * Parsetree.expression option - -val collectArrayExpressions : - Parsetree.expression -> - Parsetree.expression list * Parsetree.expression option - -val collectListExpressions : - Parsetree.expression -> - Parsetree.expression list * Parsetree.expression option - -type funParamKind = - | Parameter of { - attrs: Parsetree.attributes; - lbl: Asttypes.arg_label; - defaultExpr: Parsetree.expression option; - pat: Parsetree.pattern; - } - | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} - -val funExpr : - Parsetree.expression -> - bool * Parsetree.attributes * funParamKind list * Parsetree.expression - -(* example: - * `makeCoordinate({ - * x: 1, - * y: 2, - * })` - * Notice howe `({` and `})` "hug" or stick to each other *) -val isHuggableExpression : Parsetree.expression -> bool - -val isHuggablePattern : Parsetree.pattern -> bool - -val isHuggableRhs : Parsetree.expression -> bool - -val operatorPrecedence : string -> int - -val isUnaryExpression : Parsetree.expression -> bool -val isBinaryOperator : string -> bool -val isBinaryExpression : Parsetree.expression -> bool -val isRhsBinaryOperator : string -> bool - -val flattenableOperators : string -> string -> bool - -val hasAttributes : Parsetree.attributes -> bool - -val isArrayAccess : Parsetree.expression -> bool -val isTernaryExpr : Parsetree.expression -> bool -val isIfLetExpr : Parsetree.expression -> bool - -val collectTernaryParts : - Parsetree.expression -> - (Parsetree.expression * Parsetree.expression) list * Parsetree.expression - -val parametersShouldHug : funParamKind list -> bool - -val filterTernaryAttributes : Parsetree.attributes -> Parsetree.attributes -val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes - -val isJsxExpression : Parsetree.expression -> bool -val hasJsxAttribute : Parsetree.attributes -> bool -val hasOptionalAttribute : Parsetree.attributes -> bool - -val shouldIndentBinaryExpr : Parsetree.expression -> bool -val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool -val hasPrintableAttributes : Parsetree.attributes -> bool -val filterPrintableAttributes : Parsetree.attributes -> Parsetree.attributes -val partitionPrintableAttributes : - Parsetree.attributes -> Parsetree.attributes * Parsetree.attributes - -val requiresSpecialCallbackPrintingLastArg : - (Asttypes.arg_label * Parsetree.expression) list -> bool -val requiresSpecialCallbackPrintingFirstArg : - (Asttypes.arg_label * Parsetree.expression) list -> bool - -val modExprApply : - Parsetree.module_expr -> Parsetree.module_expr list * Parsetree.module_expr - -(* Collection of utilities to view the ast in a more a convenient form, - * allowing for easier processing. - * Example: given a ptyp_arrow type, what are its arguments and what is the - * returnType? *) - -val modExprFunctor : - Parsetree.module_expr -> - (Parsetree.attributes * string Asttypes.loc * Parsetree.module_type option) - list - * Parsetree.module_expr - -val collectPatternsFromListConstruct : - Parsetree.pattern list -> - Parsetree.pattern -> - Parsetree.pattern list * Parsetree.pattern - -val isBlockExpr : Parsetree.expression -> bool - -val isTemplateLiteral : Parsetree.expression -> bool -val isTaggedTemplateLiteral : Parsetree.expression -> bool -val hasTemplateLiteralAttr : Parsetree.attributes -> bool - -val isSpreadBeltListConcat : Parsetree.expression -> bool - -val isSpreadBeltArrayConcat : Parsetree.expression -> bool - -val collectOrPatternChain : Parsetree.pattern -> Parsetree.pattern list - -val processBracesAttr : - Parsetree.expression -> Parsetree.attribute option * Parsetree.expression - -val filterParsingAttrs : Parsetree.attributes -> Parsetree.attributes - -val isBracedExpr : Parsetree.expression -> bool - -val isSinglePipeExpr : Parsetree.expression -> bool - -(* (__x) => f(a, __x, c) -----> f(a, _, c) *) -val rewriteUnderscoreApply : Parsetree.expression -> Parsetree.expression - -(* (__x) => f(a, __x, c) -----> f(a, _, c) *) -val isUnderscoreApplySugar : Parsetree.expression -> bool - -val hasIfLetAttribute : Parsetree.attributes -> bool - -val isRewrittenUnderscoreApplySugar : Parsetree.expression -> bool - -val isFunNewtype : Parsetree.expression -> bool diff --git a/jscomp/syntax/src/res_printer.ml b/jscomp/syntax/src/res_printer.ml deleted file mode 100644 index 376e9ca..0000000 --- a/jscomp/syntax/src/res_printer.ml +++ /dev/null @@ -1,5795 +0,0 @@ -module Doc = Res_doc -module CommentTable = Res_comments_table -module Comment = Res_comment -module Token = Res_token -module Parens = Res_parens -module ParsetreeViewer = Res_parsetree_viewer - -type callbackStyle = - (* regular arrow function, example: `let f = x => x + 1` *) - | NoCallback - (* `Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument))` *) - | FitsOnOneLine - (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => - * MyModuleBlah.toList(argument) - * ) - *) - | ArgumentsFitOnOneLine - -(* Since compiler version 8.3, the bs. prefix is no longer needed *) -(* Synced from - https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_external_process.ml#L291-L367 *) -let convertBsExternalAttribute = function - | "bs.as" -> "as" - | "bs.deriving" -> "deriving" - | "bs.get" -> "get" - | "bs.get_index" -> "get_index" - | "bs.ignore" -> "ignore" - | "bs.inline" -> "inline" - | "bs.int" -> "int" - | "bs.meth" -> "meth" - | "bs.module" -> "module" - | "bs.new" -> "new" - | "bs.obj" -> "obj" - | "bs.optional" -> "optional" - | "bs.return" -> "return" - | "bs.send" -> "send" - | "bs.scope" -> "scope" - | "bs.set" -> "set" - | "bs.set_index" -> "set_index" - | "bs.splice" | "bs.variadic" -> "variadic" - | "bs.string" -> "string" - | "bs.this" -> "this" - | "bs.uncurry" -> "uncurry" - | "bs.unwrap" -> "unwrap" - | "bs.val" -> "val" - (* bs.send.pipe shouldn't be transformed *) - | txt -> txt - -(* These haven't been needed for a long time now *) -(* Synced from - https://github.com/rescript-lang/rescript-compiler/blob/29174de1a5fde3b16cf05d10f5ac109cfac5c4ca/jscomp/frontend/ast_exp_extension.ml *) -let convertBsExtension = function - | "bs.debugger" -> "debugger" - | "bs.external" -> "raw" - (* We should never see this one since we use the sugared object form, but still *) - | "bs.obj" -> "obj" - | "bs.raw" -> "raw" - | "bs.re" -> "re" - (* TODO: what about bs.time and bs.node? *) - | txt -> txt - -let addParens doc = - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent (Doc.concat [Doc.softLine; doc]); - Doc.softLine; - Doc.rparen; - ]) - -let addBraces doc = - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent (Doc.concat [Doc.softLine; doc]); - Doc.softLine; - Doc.rbrace; - ]) - -let addAsync doc = Doc.concat [Doc.text "async "; doc] - -let getFirstLeadingComment tbl loc = - match Hashtbl.find tbl.CommentTable.leading loc with - | comment :: _ -> Some comment - | [] -> None - | exception Not_found -> None - -(* Checks if `loc` has a leading line comment, i.e. `// comment above`*) -let hasLeadingLineComment tbl loc = - match getFirstLeadingComment tbl loc with - | Some comment -> Comment.isSingleLineComment comment - | None -> false - -let hasCommentBelow tbl loc = - match Hashtbl.find tbl.CommentTable.trailing loc with - | comment :: _ -> - let commentLoc = Comment.loc comment in - commentLoc.Location.loc_start.pos_lnum > loc.Location.loc_end.pos_lnum - | [] -> false - | exception Not_found -> false - -let hasNestedJsxOrMoreThanOneChild expr = - let rec loop inRecursion expr = - match expr.Parsetree.pexp_desc with - | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) - -> - if inRecursion || ParsetreeViewer.isJsxExpression hd then true - else loop true tail - | _ -> false - in - loop false expr - -let hasCommentsInside tbl loc = - match Hashtbl.find_opt tbl.CommentTable.inside loc with - | None -> false - | _ -> true - -let hasTrailingComments tbl loc = - match Hashtbl.find_opt tbl.CommentTable.trailing loc with - | None -> false - | _ -> true - -let printMultilineCommentContent txt = - (* Turns - * |* first line - * * second line - * * third line *| - * Into - * |* first line - * * second line - * * third line *| - * - * What makes a comment suitable for this kind of indentation? - * -> multiple lines + every line starts with a star - *) - let rec indentStars lines acc = - match lines with - | [] -> Doc.nil - | [lastLine] -> - let line = String.trim lastLine in - let doc = Doc.text (" " ^ line) in - let trailingSpace = if line = "" then Doc.nil else Doc.space in - List.rev (trailingSpace :: doc :: acc) |> Doc.concat - | line :: lines -> - let line = String.trim line in - if line != "" && String.unsafe_get line 0 == '*' then - let doc = Doc.text (" " ^ line) in - indentStars lines (Doc.hardLine :: doc :: acc) - else - let trailingSpace = - let len = String.length txt in - if len > 0 && String.unsafe_get txt (len - 1) = ' ' then Doc.space - else Doc.nil - in - let content = Comment.trimSpaces txt in - Doc.concat [Doc.text content; trailingSpace] - in - let lines = String.split_on_char '\n' txt in - match lines with - | [] -> Doc.text "/* */" - | [line] -> - Doc.concat - [Doc.text "/* "; Doc.text (Comment.trimSpaces line); Doc.text " */"] - | first :: rest -> - let firstLine = Comment.trimSpaces first in - Doc.concat - [ - Doc.text "/*"; - (match firstLine with - | "" | "*" -> Doc.nil - | _ -> Doc.space); - indentStars rest [Doc.hardLine; Doc.text firstLine]; - Doc.text "*/"; - ] - -let printTrailingComment (prevLoc : Location.t) (nodeLoc : Location.t) comment = - let singleLine = Comment.isSingleLineComment comment in - let content = - let txt = Comment.txt comment in - if singleLine then Doc.text ("//" ^ txt) - else printMultilineCommentContent txt - in - let diff = - let cmtStart = (Comment.loc comment).loc_start in - cmtStart.pos_lnum - prevLoc.loc_end.pos_lnum - in - let isBelow = - (Comment.loc comment).loc_start.pos_lnum > nodeLoc.loc_end.pos_lnum - in - if diff > 0 || isBelow then - Doc.concat - [ - Doc.breakParent; - Doc.lineSuffix - (Doc.concat - [ - Doc.hardLine; - (if diff > 1 then Doc.hardLine else Doc.nil); - content; - ]); - ] - else if not singleLine then Doc.concat [Doc.space; content] - else Doc.lineSuffix (Doc.concat [Doc.space; content]) - -let printLeadingComment ?nextComment comment = - let singleLine = Comment.isSingleLineComment comment in - let content = - let txt = Comment.txt comment in - if singleLine then Doc.text ("//" ^ txt) - else printMultilineCommentContent txt - in - let separator = - Doc.concat - [ - (if singleLine then Doc.concat [Doc.hardLine; Doc.breakParent] - else Doc.nil); - (match nextComment with - | Some next -> - let nextLoc = Comment.loc next in - let currLoc = Comment.loc comment in - let diff = - nextLoc.Location.loc_start.pos_lnum - - currLoc.Location.loc_end.pos_lnum - in - let nextSingleLine = Comment.isSingleLineComment next in - if singleLine && nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if singleLine && not nextSingleLine then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else if diff == 1 then Doc.hardLine - else Doc.space - | None -> Doc.nil); - ] - in - Doc.concat [content; separator] - -(* This function is used for printing comments inside an empty block *) -let printCommentsInside cmtTbl loc = - let printComment comment = - let singleLine = Comment.isSingleLineComment comment in - let txt = Comment.txt comment in - if singleLine then Doc.text ("//" ^ txt) - else printMultilineCommentContent txt - in - let forceBreak = - loc.Location.loc_start.pos_lnum <> loc.Location.loc_end.pos_lnum - in - let rec loop acc comments = - match comments with - | [] -> Doc.nil - | [comment] -> - let cmtDoc = printComment comment in - let cmtsDoc = Doc.concat (Doc.softLine :: List.rev (cmtDoc :: acc)) in - let doc = - Doc.breakableGroup ~forceBreak - (Doc.concat [Doc.ifBreaks (Doc.indent cmtsDoc) cmtsDoc; Doc.softLine]) - in - doc - | comment :: rest -> - let cmtDoc = Doc.concat [printComment comment; Doc.line] in - loop (cmtDoc :: acc) rest - in - match Hashtbl.find cmtTbl.CommentTable.inside loc with - | exception Not_found -> Doc.nil - | comments -> - Hashtbl.remove cmtTbl.inside loc; - loop [] comments - -(* This function is used for printing comments inside an empty file *) -let printCommentsInsideFile cmtTbl = - let rec loop acc comments = - match comments with - | [] -> Doc.nil - | [comment] -> - let cmtDoc = printLeadingComment comment in - let doc = - Doc.group (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc))]) - in - doc - | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest - in - match Hashtbl.find cmtTbl.CommentTable.inside Location.none with - | exception Not_found -> Doc.nil - | comments -> - Hashtbl.remove cmtTbl.inside Location.none; - Doc.group (loop [] comments) - -let printLeadingComments node tbl loc = - let rec loop acc comments = - match comments with - | [] -> node - | [comment] -> - let cmtDoc = printLeadingComment comment in - let diff = - loc.Location.loc_start.pos_lnum - - (Comment.loc comment).Location.loc_end.pos_lnum - in - let separator = - if Comment.isSingleLineComment comment then - if diff > 1 then Doc.hardLine else Doc.nil - else if diff == 0 then Doc.space - else if diff > 1 then Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = - Doc.group - (Doc.concat [Doc.concat (List.rev (cmtDoc :: acc)); separator; node]) - in - doc - | comment :: (nextComment :: _comments as rest) -> - let cmtDoc = printLeadingComment ~nextComment comment in - loop (cmtDoc :: acc) rest - in - match Hashtbl.find tbl loc with - | exception Not_found -> node - | comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - loop [] comments - -let printTrailingComments node tbl loc = - let rec loop prev acc comments = - match comments with - | [] -> Doc.concat (List.rev acc) - | comment :: comments -> - let cmtDoc = printTrailingComment prev loc comment in - loop (Comment.loc comment) (cmtDoc :: acc) comments - in - match Hashtbl.find tbl loc with - | exception Not_found -> node - | [] -> node - | _first :: _ as comments -> - (* Remove comments from tbl: Some ast nodes have the same location. - * We only want to print comments once *) - Hashtbl.remove tbl loc; - let cmtsDoc = loop loc [] comments in - Doc.concat [node; cmtsDoc] - -let printComments doc (tbl : CommentTable.t) loc = - let docWithLeadingComments = printLeadingComments doc tbl.leading loc in - printTrailingComments docWithLeadingComments tbl.trailing loc - -let printList ~getLoc ~nodes ~print ?(forceBreak = false) t = - let rec loop (prevLoc : Location.t) acc nodes = - match nodes with - | [] -> (prevLoc, Doc.concat (List.rev acc)) - | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.hardLine - in - let doc = printComments (print node t) t loc in - loop loc (doc :: sep :: acc) nodes - in - match nodes with - | [] -> Doc.nil - | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t) t firstLoc in - let lastLoc, docs = loop firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs - -let printListi ~getLoc ~nodes ~print ?(forceBreak = false) t = - let rec loop i (prevLoc : Location.t) acc nodes = - match nodes with - | [] -> (prevLoc, Doc.concat (List.rev acc)) - | node :: nodes -> - let loc = getLoc node in - let startPos = - match getFirstLeadingComment t loc with - | None -> loc.loc_start - | Some comment -> (Comment.loc comment).loc_start - in - let sep = - if startPos.pos_lnum - prevLoc.loc_end.pos_lnum > 1 then - Doc.concat [Doc.hardLine; Doc.hardLine] - else Doc.line - in - let doc = printComments (print node t i) t loc in - loop (i + 1) loc (doc :: sep :: acc) nodes - in - match nodes with - | [] -> Doc.nil - | node :: nodes -> - let firstLoc = getLoc node in - let doc = printComments (print node t 0) t firstLoc in - let lastLoc, docs = loop 1 firstLoc [doc] nodes in - let forceBreak = - forceBreak || firstLoc.loc_start.pos_lnum != lastLoc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak docs - -let rec printLongidentAux accu = function - | Longident.Lident s -> Doc.text s :: accu - | Ldot (lid, s) -> printLongidentAux (Doc.text s :: accu) lid - | Lapply (lid1, lid2) -> - let d1 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid1) in - let d2 = Doc.join ~sep:Doc.dot (printLongidentAux [] lid2) in - Doc.concat [d1; Doc.lparen; d2; Doc.rparen] :: accu - -let printLongident = function - | Longident.Lident txt -> Doc.text txt - | lid -> Doc.join ~sep:Doc.dot (printLongidentAux [] lid) - -type identifierStyle = ExoticIdent | NormalIdent - -let classifyIdentContent ?(allowUident = false) ?(allowHyphen = false) txt = - if Token.isKeywordTxt txt then ExoticIdent - else - let len = String.length txt in - let rec loop i = - if i == len then NormalIdent - else if i == 0 then - match String.unsafe_get txt i with - | 'A' .. 'Z' when allowUident -> loop (i + 1) - | 'a' .. 'z' | '_' -> loop (i + 1) - | '-' when allowHyphen -> loop (i + 1) - | _ -> ExoticIdent - else - match String.unsafe_get txt i with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '\'' | '_' -> loop (i + 1) - | '-' when allowHyphen -> loop (i + 1) - | _ -> ExoticIdent - in - loop 0 - -let printIdentLike ?allowUident ?allowHyphen txt = - match classifyIdentContent ?allowUident ?allowHyphen txt with - | ExoticIdent -> Doc.concat [Doc.text "\\\""; Doc.text txt; Doc.text "\""] - | NormalIdent -> Doc.text txt - -let rec unsafe_for_all_range s ~start ~finish p = - start > finish - || p (String.unsafe_get s start) - && unsafe_for_all_range s ~start:(start + 1) ~finish p - -let for_all_from s start p = - let len = String.length s in - unsafe_for_all_range s ~start ~finish:(len - 1) p - -(* See https://github.com/rescript-lang/rescript-compiler/blob/726cfa534314b586e5b5734471bc2023ad99ebd9/jscomp/ext/ext_string.ml#L510 *) -let isValidNumericPolyvarNumber (x : string) = - let len = String.length x in - len > 0 - && - let a = Char.code (String.unsafe_get x 0) in - a <= 57 - && - if len > 1 then - a > 48 - && for_all_from x 1 (function - | '0' .. '9' -> true - | _ -> false) - else a >= 48 - -(* Exotic identifiers in poly-vars have a "lighter" syntax: #"ease-in" *) -let printPolyVarIdent txt = - (* numeric poly-vars don't need quotes: #644 *) - if isValidNumericPolyvarNumber txt then Doc.text txt - else - match classifyIdentContent ~allowUident:true txt with - | ExoticIdent -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] - | NormalIdent -> ( - match txt with - | "" -> Doc.concat [Doc.text "\""; Doc.text txt; Doc.text "\""] - | _ -> Doc.text txt) - -let polyVarIdentToString polyVarIdent = - Doc.concat [Doc.text "#"; printPolyVarIdent polyVarIdent] - |> Doc.toString ~width:80 - -let printLident l = - let flatLidOpt lid = - let rec flat accu = function - | Longident.Lident s -> Some (s :: accu) - | Ldot (lid, s) -> flat (s :: accu) lid - | Lapply (_, _) -> None - in - flat [] lid - in - match l with - | Longident.Lident txt -> printIdentLike txt - | Longident.Ldot (path, txt) -> - let doc = - match flatLidOpt path with - | Some txts -> - Doc.concat - [ - Doc.join ~sep:Doc.dot (List.map Doc.text txts); - Doc.dot; - printIdentLike txt; - ] - | None -> Doc.text "printLident: Longident.Lapply is not supported" - in - doc - | Lapply (_, _) -> Doc.text "printLident: Longident.Lapply is not supported" - -let printLongidentLocation l cmtTbl = - let doc = printLongident l.Location.txt in - printComments doc cmtTbl l.loc - -(* Module.SubModule.x *) -let printLidentPath path cmtTbl = - let doc = printLident path.Location.txt in - printComments doc cmtTbl path.loc - -(* Module.SubModule.x or Module.SubModule.X *) -let printIdentPath path cmtTbl = - let doc = printLident path.Location.txt in - printComments doc cmtTbl path.loc - -let printStringLoc sloc cmtTbl = - let doc = printIdentLike sloc.Location.txt in - printComments doc cmtTbl sloc.loc - -let printStringContents txt = - let lines = String.split_on_char '\n' txt in - Doc.join ~sep:Doc.literalLine (List.map Doc.text lines) - -let printConstant ?(templateLiteral = false) c = - match c with - | Parsetree.Pconst_integer (s, suffix) -> ( - match suffix with - | Some c -> Doc.text (s ^ Char.escaped c) - | None -> Doc.text s) - | Pconst_string (txt, None) -> - Doc.concat [Doc.text "\""; printStringContents txt; Doc.text "\""] - | Pconst_string (txt, Some prefix) -> - if prefix = "INTERNAL_RES_CHAR_CONTENTS" then - Doc.concat [Doc.text "'"; Doc.text txt; Doc.text "'"] - else - let lquote, rquote = - if templateLiteral then ("`", "`") else ("\"", "\"") - in - Doc.concat - [ - (if prefix = "js" then Doc.nil else Doc.text prefix); - Doc.text lquote; - printStringContents txt; - Doc.text rquote; - ] - | Pconst_float (s, _) -> Doc.text s - | Pconst_char c -> - let str = - match Char.unsafe_chr c with - | '\'' -> "\\'" - | '\\' -> "\\\\" - | '\n' -> "\\n" - | '\t' -> "\\t" - | '\r' -> "\\r" - | '\b' -> "\\b" - | ' ' .. '~' as c -> - let s = (Bytes.create [@doesNotRaise]) 1 in - Bytes.unsafe_set s 0 c; - Bytes.unsafe_to_string s - | _ -> Res_utf8.encodeCodePoint c - in - Doc.text ("'" ^ str ^ "'") - -let printOptionalLabel attrs = - if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" - else Doc.nil - -module State = struct - let customLayoutThreshold = 2 - - type t = {customLayout: int; mutable uncurried_config: Config.uncurried} - - let init () = {customLayout = 0; uncurried_config = !Config.uncurried} - - let nextCustomLayout t = {t with customLayout = t.customLayout + 1} - - let shouldBreakCallback t = t.customLayout > customLayoutThreshold -end - -let rec printStructure ~state (s : Parsetree.structure) t = - match s with - | [] -> printCommentsInsideFile t - | structure -> - printList - ~getLoc:(fun s -> s.Parsetree.pstr_loc) - ~nodes:structure - ~print:(printStructureItem ~state) - t - -and printStructureItem ~state (si : Parsetree.structure_item) cmtTbl = - match si.pstr_desc with - | Pstr_value (rec_flag, valueBindings) -> - let recFlag = - match rec_flag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printValueBindings ~state ~recFlag valueBindings cmtTbl - | Pstr_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl - | Pstr_primitive valueDescription -> - printValueDescription ~state valueDescription cmtTbl - | Pstr_eval (expr, attrs) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.structureExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [printAttributes ~state attrs cmtTbl; exprDoc] - | Pstr_attribute attr -> - fst (printAttribute ~state ~standalone:true attr cmtTbl) - | Pstr_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~state attrs cmtTbl; - Doc.concat [printExtension ~state ~atModuleLvl:true extension cmtTbl]; - ] - | Pstr_include includeDeclaration -> - printIncludeDeclaration ~state includeDeclaration cmtTbl - | Pstr_open openDescription -> - printOpenDescription ~state openDescription cmtTbl - | Pstr_modtype modTypeDecl -> - printModuleTypeDeclaration ~state modTypeDecl cmtTbl - | Pstr_module moduleBinding -> - printModuleBinding ~state ~isRec:false moduleBinding cmtTbl 0 - | Pstr_recmodule moduleBindings -> - printListi - ~getLoc:(fun mb -> mb.Parsetree.pmb_loc) - ~nodes:moduleBindings - ~print:(printModuleBinding ~state ~isRec:true) - cmtTbl - | Pstr_exception extensionConstructor -> - printExceptionDef ~state extensionConstructor cmtTbl - | Pstr_typext typeExtension -> printTypeExtension ~state typeExtension cmtTbl - | Pstr_class _ | Pstr_class_type _ -> Doc.nil - -and printTypeExtension ~state (te : Parsetree.type_extension) cmtTbl = - let prefix = Doc.text "type " in - let name = printLidentPath te.ptyext_path cmtTbl in - let typeParams = printTypeParams ~state te.ptyext_params cmtTbl in - let extensionConstructors = - let ecs = te.ptyext_constructors in - let forceBreak = - match (ecs, List.rev ecs) with - | first :: _, last :: _ -> - first.pext_loc.loc_start.pos_lnum > te.ptyext_path.loc.loc_end.pos_lnum - || first.pext_loc.loc_start.pos_lnum < last.pext_loc.loc_end.pos_lnum - | _ -> false - in - let privateFlag = - match te.ptyext_private with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] - | Public -> Doc.nil - in - let rows = - printListi - ~getLoc:(fun n -> n.Parsetree.pext_loc) - ~print:(printExtensionConstructor ~state) - ~nodes:ecs ~forceBreak cmtTbl - in - Doc.breakableGroup ~forceBreak - (Doc.indent - (Doc.concat - [ - Doc.line; - privateFlag; - rows; - (* Doc.join ~sep:Doc.line ( *) - (* List.mapi printExtensionConstructor ecs *) - (* ) *) - ])) - in - Doc.group - (Doc.concat - [ - printAttributes ~state ~loc:te.ptyext_path.loc te.ptyext_attributes - cmtTbl; - prefix; - name; - typeParams; - Doc.text " +="; - extensionConstructors; - ]) - -and printModuleBinding ~state ~isRec moduleBinding cmtTbl i = - let prefix = - if i = 0 then - Doc.concat - [Doc.text "module "; (if isRec then Doc.text "rec " else Doc.nil)] - else Doc.text "and " - in - let modExprDoc, modConstraintDoc = - match moduleBinding.pmb_expr with - | {pmod_desc = Pmod_constraint (modExpr, modType)} - when not - (ParsetreeViewer.hasAwaitAttribute - moduleBinding.pmb_expr.pmod_attributes) -> - ( printModExpr ~state modExpr cmtTbl, - Doc.concat [Doc.text ": "; printModType ~state modType cmtTbl] ) - | modExpr -> (printModExpr ~state modExpr cmtTbl, Doc.nil) - in - let modExprDocParens = - if Parens.modExprParens moduleBinding.pmb_expr then - Doc.concat [Doc.lparen; modExprDoc; Doc.rparen] - else modExprDoc - in - let modName = - let doc = Doc.text moduleBinding.pmb_name.Location.txt in - printComments doc cmtTbl moduleBinding.pmb_name.loc - in - let doc = - Doc.concat - [ - printAttributes ~state ~loc:moduleBinding.pmb_name.loc - moduleBinding.pmb_attributes cmtTbl; - prefix; - modName; - modConstraintDoc; - Doc.text " = "; - modExprDocParens; - ] - in - printComments doc cmtTbl moduleBinding.pmb_loc - -and printModuleTypeDeclaration ~state - (modTypeDecl : Parsetree.module_type_declaration) cmtTbl = - let modName = - let doc = Doc.text modTypeDecl.pmtd_name.txt in - printComments doc cmtTbl modTypeDecl.pmtd_name.loc - in - Doc.concat - [ - printAttributes ~state modTypeDecl.pmtd_attributes cmtTbl; - Doc.text "module type "; - modName; - (match modTypeDecl.pmtd_type with - | None -> Doc.nil - | Some modType -> - Doc.concat [Doc.text " = "; printModType ~state modType cmtTbl]); - ] - -and printModType ~state modType cmtTbl = - let modTypeDoc = - match modType.pmty_desc with - | Parsetree.Pmty_ident longident -> - Doc.concat - [ - printAttributes ~state ~loc:longident.loc modType.pmty_attributes - cmtTbl; - printLongidentLocation longident cmtTbl; - ] - | Pmty_signature [] -> - if hasCommentsInside cmtTbl modType.pmty_loc then - let doc = printCommentsInside cmtTbl modType.pmty_loc in - Doc.concat [Doc.lbrace; doc; Doc.rbrace] - else - let shouldBreak = - modType.pmty_loc.loc_start.pos_lnum - < modType.pmty_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat [Doc.lbrace; Doc.softLine; Doc.softLine; Doc.rbrace]) - | Pmty_signature signature -> - let signatureDoc = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat [Doc.line; printSignature ~state signature cmtTbl]); - Doc.line; - Doc.rbrace; - ]) - in - Doc.concat - [printAttributes ~state modType.pmty_attributes cmtTbl; signatureDoc] - | Pmty_functor _ -> - let parameters, returnType = ParsetreeViewer.functorType modType in - let parametersDoc = - match parameters with - | [] -> Doc.nil - | [(attrs, {Location.txt = "_"; loc}, Some modType)] -> - let cmtLoc = - {loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - in - let attrs = printAttributes ~state attrs cmtTbl in - let doc = Doc.concat [attrs; printModType ~state modType cmtTbl] in - printComments doc cmtTbl cmtLoc - | params -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun (attrs, lbl, modType) -> - let cmtLoc = - match modType with - | None -> lbl.Asttypes.loc - | Some modType -> - { - lbl.Asttypes.loc with - loc_end = - modType.Parsetree.pmty_loc.loc_end; - } - in - let attrs = - printAttributes ~state attrs cmtTbl - in - let lblDoc = - if lbl.Location.txt = "_" || lbl.txt = "*" then - Doc.nil - else - let doc = Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - attrs; - lblDoc; - (match modType with - | None -> Doc.nil - | Some modType -> - Doc.concat - [ - (if lbl.txt = "_" then Doc.nil - else Doc.text ": "); - printModType ~state modType cmtTbl; - ]); - ] - in - printComments doc cmtTbl cmtLoc) - params); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - let returnDoc = - let doc = printModType ~state returnType cmtTbl in - if Parens.modTypeFunctorReturn returnType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - parametersDoc; - Doc.group (Doc.concat [Doc.text " =>"; Doc.line; returnDoc]); - ]) - | Pmty_typeof modExpr -> - Doc.concat - [Doc.text "module type of "; printModExpr ~state modExpr cmtTbl] - | Pmty_extension extension -> - printExtension ~state ~atModuleLvl:false extension cmtTbl - | Pmty_alias longident -> - Doc.concat [Doc.text "module "; printLongidentLocation longident cmtTbl] - | Pmty_with (modType, withConstraints) -> - let operand = - let doc = printModType ~state modType cmtTbl in - if Parens.modTypeWithOperand modType then addParens doc else doc - in - Doc.group - (Doc.concat - [ - operand; - Doc.indent - (Doc.concat - [Doc.line; printWithConstraints ~state withConstraints cmtTbl]); - ]) - in - let attrsAlreadyPrinted = - match modType.pmty_desc with - | Pmty_functor _ | Pmty_signature _ | Pmty_ident _ -> true - | _ -> false - in - let doc = - Doc.concat - [ - (if attrsAlreadyPrinted then Doc.nil - else printAttributes ~state modType.pmty_attributes cmtTbl); - modTypeDoc; - ] - in - printComments doc cmtTbl modType.pmty_loc - -and printWithConstraints ~state withConstraints cmtTbl = - let rows = - List.mapi - (fun i withConstraint -> - Doc.group - (Doc.concat - [ - (if i == 0 then Doc.text "with " else Doc.text "and "); - printWithConstraint ~state withConstraint cmtTbl; - ])) - withConstraints - in - Doc.join ~sep:Doc.line rows - -and printWithConstraint ~state (withConstraint : Parsetree.with_constraint) - cmtTbl = - match withConstraint with - (* with type X.t = ... *) - | Pwith_type (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~state - ~name:(printLidentPath longident cmtTbl) - ~equalSign:"=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - (* with module X.Y = Z *) - | Pwith_module ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] - (* with type X.t := ..., same format as [Pwith_type] *) - | Pwith_typesubst (longident, typeDeclaration) -> - Doc.group - (printTypeDeclaration ~state - ~name:(printLidentPath longident cmtTbl) - ~equalSign:":=" ~recFlag:Doc.nil 0 typeDeclaration CommentTable.empty) - | Pwith_modsubst ({txt = longident1}, {txt = longident2}) -> - Doc.concat - [ - Doc.text "module "; - printLongident longident1; - Doc.text " :="; - Doc.indent (Doc.concat [Doc.line; printLongident longident2]); - ] - -and printSignature ~state signature cmtTbl = - match signature with - | [] -> printCommentsInsideFile cmtTbl - | signature -> - printList - ~getLoc:(fun s -> s.Parsetree.psig_loc) - ~nodes:signature - ~print:(printSignatureItem ~state) - cmtTbl - -and printSignatureItem ~state (si : Parsetree.signature_item) cmtTbl = - match si.psig_desc with - | Parsetree.Psig_value valueDescription -> - printValueDescription ~state valueDescription cmtTbl - | Psig_type (recFlag, typeDeclarations) -> - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl - | Psig_typext typeExtension -> printTypeExtension ~state typeExtension cmtTbl - | Psig_exception extensionConstructor -> - printExceptionDef ~state extensionConstructor cmtTbl - | Psig_module moduleDeclaration -> - printModuleDeclaration ~state moduleDeclaration cmtTbl - | Psig_recmodule moduleDeclarations -> - printRecModuleDeclarations ~state moduleDeclarations cmtTbl - | Psig_modtype modTypeDecl -> - printModuleTypeDeclaration ~state modTypeDecl cmtTbl - | Psig_open openDescription -> - printOpenDescription ~state openDescription cmtTbl - | Psig_include includeDescription -> - printIncludeDescription ~state includeDescription cmtTbl - | Psig_attribute attr -> - fst (printAttribute ~state ~standalone:true attr cmtTbl) - | Psig_extension (extension, attrs) -> - Doc.concat - [ - printAttributes ~state attrs cmtTbl; - Doc.concat [printExtension ~state ~atModuleLvl:true extension cmtTbl]; - ] - | Psig_class _ | Psig_class_type _ -> Doc.nil - -and printRecModuleDeclarations ~state moduleDeclarations cmtTbl = - printListi - ~getLoc:(fun n -> n.Parsetree.pmd_loc) - ~nodes:moduleDeclarations - ~print:(printRecModuleDeclaration ~state) - cmtTbl - -and printRecModuleDeclaration ~state md cmtTbl i = - let body = - match md.pmd_type.pmty_desc with - | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] - | _ -> - let needsParens = - match md.pmd_type.pmty_desc with - | Pmty_with _ -> true - | _ -> false - in - let modTypeDoc = - let doc = printModType ~state md.pmd_type cmtTbl in - if needsParens then addParens doc else doc - in - Doc.concat [Doc.text ": "; modTypeDoc] - in - let prefix = if i < 1 then "module rec " else "and " in - Doc.concat - [ - printAttributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; - Doc.text prefix; - printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; - body; - ] - -and printModuleDeclaration ~state (md : Parsetree.module_declaration) cmtTbl = - let body = - match md.pmd_type.pmty_desc with - | Parsetree.Pmty_alias longident -> - Doc.concat [Doc.text " = "; printLongidentLocation longident cmtTbl] - | _ -> Doc.concat [Doc.text ": "; printModType ~state md.pmd_type cmtTbl] - in - Doc.concat - [ - printAttributes ~state ~loc:md.pmd_name.loc md.pmd_attributes cmtTbl; - Doc.text "module "; - printComments (Doc.text md.pmd_name.txt) cmtTbl md.pmd_name.loc; - body; - ] - -and printOpenDescription ~state (openDescription : Parsetree.open_description) - cmtTbl = - Doc.concat - [ - printAttributes ~state openDescription.popen_attributes cmtTbl; - Doc.text "open"; - (match openDescription.popen_override with - | Asttypes.Fresh -> Doc.space - | Asttypes.Override -> Doc.text "! "); - printLongidentLocation openDescription.popen_lid cmtTbl; - ] - -and printIncludeDescription ~state - (includeDescription : Parsetree.include_description) cmtTbl = - Doc.concat - [ - printAttributes ~state includeDescription.pincl_attributes cmtTbl; - Doc.text "include "; - printModType ~state includeDescription.pincl_mod cmtTbl; - ] - -and printIncludeDeclaration ~state - (includeDeclaration : Parsetree.include_declaration) cmtTbl = - Doc.concat - [ - printAttributes ~state includeDeclaration.pincl_attributes cmtTbl; - Doc.text "include "; - (let includeDoc = - printModExpr ~state includeDeclaration.pincl_mod cmtTbl - in - if Parens.includeModExpr includeDeclaration.pincl_mod then - addParens includeDoc - else includeDoc); - ] - -and printValueBindings ~state ~recFlag (vbs : Parsetree.value_binding list) - cmtTbl = - printListi - ~getLoc:(fun vb -> vb.Parsetree.pvb_loc) - ~nodes:vbs - ~print:(printValueBinding ~state ~recFlag) - cmtTbl - -and printValueDescription ~state valueDescription cmtTbl = - let isExternal = - match valueDescription.pval_prim with - | [] -> false - | _ -> true - in - let attrs = - printAttributes ~state ~loc:valueDescription.pval_name.loc - valueDescription.pval_attributes cmtTbl - in - let header = if isExternal then "external " else "let " in - Doc.group - (Doc.concat - [ - attrs; - Doc.text header; - printComments - (printIdentLike valueDescription.pval_name.txt) - cmtTbl valueDescription.pval_name.loc; - Doc.text ": "; - printTypExpr ~state valueDescription.pval_type cmtTbl; - (if isExternal then - Doc.group - (Doc.concat - [ - Doc.text " ="; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.join ~sep:Doc.line - (List.map - (fun s -> - Doc.concat - [Doc.text "\""; Doc.text s; Doc.text "\""]) - valueDescription.pval_prim); - ]); - ]) - else Doc.nil); - ]) - -and printTypeDeclarations ~state ~recFlag typeDeclarations cmtTbl = - printListi - ~getLoc:(fun n -> n.Parsetree.ptype_loc) - ~nodes:typeDeclarations - ~print:(printTypeDeclaration2 ~state ~recFlag) - cmtTbl - -(* - * type_declaration = { - * ptype_name: string loc; - * ptype_params: (core_type * variance) list; - * (* ('a1,...'an) t; None represents _*) - * ptype_cstrs: (core_type * core_type * Location.t) list; - * (* ... constraint T1=T1' ... constraint Tn=Tn' *) - * ptype_kind: type_kind; - * ptype_private: private_flag; (* = private ... *) - * ptype_manifest: core_type option; (* = T *) - * ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) - * ptype_loc: Location.t; - * } - * - * - * type t (abstract, no manifest) - * type t = T0 (abstract, manifest=T0) - * type t = C of T | ... (variant, no manifest) - * type t = T0 = C of T | ... (variant, manifest=T0) - * type t = {l: T; ...} (record, no manifest) - * type t = T0 = {l : T; ...} (record, manifest=T0) - * type t = .. (open, no manifest) - * - * - * and type_kind = - * | Ptype_abstract - * | Ptype_variant of constructor_declaration list - * (* Invariant: non-empty list *) - * | Ptype_record of label_declaration list - * (* Invariant: non-empty list *) - * | Ptype_open - *) -and printTypeDeclaration ~state ~name ~equalSign ~recFlag i - (td : Parsetree.type_declaration) cmtTbl = - let attrs = - printAttributes ~state ~loc:td.ptype_loc td.ptype_attributes cmtTbl - in - let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] - in - let typeName = name in - let typeParams = printTypeParams ~state td.ptype_params cmtTbl in - let manifestAndKind = - match td.ptype_kind with - | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr ~state typ cmtTbl; - ]) - | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record lds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~state lds cmtTbl; - ] - | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~state ~privateFlag:td.ptype_private cds - cmtTbl; - ] - in - let constraints = printTypeDefinitionConstraints ~state td.ptype_cstrs in - Doc.group - (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) - -and printTypeDeclaration2 ~state ~recFlag (td : Parsetree.type_declaration) - cmtTbl i = - let name = - let doc = printIdentLike td.Parsetree.ptype_name.txt in - printComments doc cmtTbl td.ptype_name.loc - in - let equalSign = "=" in - let attrs = - printAttributes ~state ~loc:td.ptype_loc td.ptype_attributes cmtTbl - in - let prefix = - if i > 0 then Doc.text "and " else Doc.concat [Doc.text "type "; recFlag] - in - let typeName = name in - let typeParams = printTypeParams ~state td.ptype_params cmtTbl in - let manifestAndKind = - match td.ptype_kind with - | Ptype_abstract -> ( - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printTypExpr ~state typ cmtTbl; - ]) - | Ptype_open -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - Doc.text ".."; - ] - | Ptype_record lds -> - if lds = [] then - Doc.concat - [ - Doc.space; - Doc.text equalSign; - Doc.space; - Doc.lbrace; - printCommentsInside cmtTbl td.ptype_loc; - Doc.rbrace; - ] - else - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printPrivateFlag td.ptype_private; - printRecordDeclaration ~state lds cmtTbl; - ] - | Ptype_variant cds -> - let manifest = - match td.ptype_manifest with - | None -> Doc.nil - | Some typ -> - Doc.concat - [ - Doc.concat [Doc.space; Doc.text equalSign; Doc.space]; - printTypExpr ~state typ cmtTbl; - ] - in - Doc.concat - [ - manifest; - Doc.concat [Doc.space; Doc.text equalSign]; - printConstructorDeclarations ~state ~privateFlag:td.ptype_private cds - cmtTbl; - ] - in - let constraints = printTypeDefinitionConstraints ~state td.ptype_cstrs in - Doc.group - (Doc.concat - [attrs; prefix; typeName; typeParams; manifestAndKind; constraints]) - -and printTypeDefinitionConstraints ~state cstrs = - match cstrs with - | [] -> Doc.nil - | cstrs -> - Doc.indent - (Doc.group - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line - (List.map (printTypeDefinitionConstraint ~state) cstrs)); - ])) - -and printTypeDefinitionConstraint ~state - ((typ1, typ2, _loc) : - Parsetree.core_type * Parsetree.core_type * Location.t) = - Doc.concat - [ - Doc.text "constraint "; - printTypExpr ~state typ1 CommentTable.empty; - Doc.text " = "; - printTypExpr ~state typ2 CommentTable.empty; - ] - -and printPrivateFlag (flag : Asttypes.private_flag) = - match flag with - | Private -> Doc.text "private " - | Public -> Doc.nil - -and printTypeParams ~state typeParams cmtTbl = - match typeParams with - | [] -> Doc.nil - | typeParams -> - Doc.group - (Doc.concat - [ - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typeParam -> - let doc = printTypeParam ~state typeParam cmtTbl in - printComments doc cmtTbl - (fst typeParam).Parsetree.ptyp_loc) - typeParams); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ]) - -and printTypeParam ~state (param : Parsetree.core_type * Asttypes.variance) - cmtTbl = - let typ, variance = param in - let printedVariance = - match variance with - | Covariant -> Doc.text "+" - | Contravariant -> Doc.text "-" - | Invariant -> Doc.nil - in - Doc.concat [printedVariance; printTypExpr ~state typ cmtTbl] - -and printRecordDeclaration ~state (lds : Parsetree.label_declaration list) - cmtTbl = - let forceBreak = - match (lds, List.rev lds) with - | first :: _, last :: _ -> - first.pld_loc.loc_start.pos_lnum < last.pld_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ld -> - let doc = printLabelDeclaration ~state ld cmtTbl in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - -and printConstructorDeclarations ~state ~privateFlag - (cds : Parsetree.constructor_declaration list) cmtTbl = - let forceBreak = - match (cds, List.rev cds) with - | first :: _, last :: _ -> - first.pcd_loc.loc_start.pos_lnum < last.pcd_loc.loc_end.pos_lnum - | _ -> false - in - let privateFlag = - match privateFlag with - | Asttypes.Private -> Doc.concat [Doc.text "private"; Doc.line] - | Public -> Doc.nil - in - let rows = - printListi - ~getLoc:(fun cd -> cd.Parsetree.pcd_loc) - ~nodes:cds - ~print:(fun cd cmtTbl i -> - let doc = printConstructorDeclaration2 ~state i cd cmtTbl in - printComments doc cmtTbl cd.Parsetree.pcd_loc) - ~forceBreak cmtTbl - in - Doc.breakableGroup ~forceBreak - (Doc.indent (Doc.concat [Doc.line; privateFlag; rows])) - -and printConstructorDeclaration2 ~state i - (cd : Parsetree.constructor_declaration) cmtTbl = - let attrs = printAttributes ~state cd.pcd_attributes cmtTbl in - let isDotDotDot = cd.pcd_name.txt = "..." in - let bar = - if i > 0 || cd.pcd_attributes <> [] || isDotDotDot then Doc.text "| " - else Doc.ifBreaks (Doc.text "| ") Doc.nil - in - let constrName = - let doc = Doc.text cd.pcd_name.txt in - printComments doc cmtTbl cd.pcd_name.loc - in - let constrArgs = - printConstructorArguments ~isDotDotDot ~state ~indent:true cd.pcd_args - cmtTbl - in - let gadt = - match cd.pcd_res with - | None -> Doc.nil - | Some typ -> - Doc.indent (Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl]) - in - Doc.concat - [ - bar; - Doc.group - (Doc.concat - [ - attrs; - (* TODO: fix parsing of attributes, so when can print them above the bar? *) - constrName; - constrArgs; - gadt; - ]); - ] - -and printConstructorArguments ?(isDotDotDot = false) ~state ~indent - (cdArgs : Parsetree.constructor_arguments) cmtTbl = - match cdArgs with - | Pcstr_tuple [] -> Doc.nil - | Pcstr_tuple types -> - let args = - Doc.concat - [ - (if isDotDotDot then Doc.nil else Doc.lparen); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> printTypExpr ~state typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - (if isDotDotDot then Doc.nil else Doc.rparen); - ] - in - Doc.group (if indent then Doc.indent args else args) - | Pcstr_record lds -> - let args = - Doc.concat - [ - Doc.lparen; - (* manually inline the printRecordDeclaration, gives better layout *) - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun ld -> - let doc = printLabelDeclaration ~state ld cmtTbl in - printComments doc cmtTbl ld.Parsetree.pld_loc) - lds); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - Doc.rparen; - ] - in - if indent then Doc.indent args else args - -and printLabelDeclaration ~state (ld : Parsetree.label_declaration) cmtTbl = - let attrs = - printAttributes ~state ~loc:ld.pld_name.loc ld.pld_attributes cmtTbl - in - let mutableFlag = - match ld.pld_mutable with - | Mutable -> Doc.text "mutable " - | Immutable -> Doc.nil - in - let name, isDot = - let doc, isDot = - if ld.pld_name.txt = "..." then (Doc.text ld.pld_name.txt, true) - else (printIdentLike ld.pld_name.txt, false) - in - (printComments doc cmtTbl ld.pld_name.loc, isDot) - in - let optional = printOptionalLabel ld.pld_attributes in - Doc.group - (Doc.concat - [ - attrs; - mutableFlag; - name; - optional; - (if isDot then Doc.nil else Doc.text ": "); - printTypExpr ~state ld.pld_type cmtTbl; - ]) - -and printTypExpr ~(state : State.t) (typExpr : Parsetree.core_type) cmtTbl = - let printArrow ~uncurried ?(arity = max_int) typExpr = - let attrsBefore, args, returnType = - ParsetreeViewer.arrowType ~arity typExpr - in - let dotted, attrsBefore = - let dotted = - state.uncurried_config |> Res_uncurried.getDotted ~uncurried - in - (* Converting .ml code to .res requires processing uncurried attributes *) - let hasBs, attrs = ParsetreeViewer.processBsAttribute attrsBefore in - (dotted || hasBs, attrs) - in - let returnTypeNeedsParens = - match returnType.ptyp_desc with - | Ptyp_alias _ -> true - | _ -> false - in - let returnDoc = - let doc = printTypExpr ~state returnType cmtTbl in - if returnTypeNeedsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - match args with - | [] -> Doc.nil - | [([], Nolabel, n)] when not dotted -> - let hasAttrsBefore = not (attrsBefore = []) in - let attrs = - if hasAttrsBefore then - printAttributes ~state ~inline:true attrsBefore cmtTbl - else Doc.nil - in - let typDoc = - let doc = printTypExpr ~state n cmtTbl in - match n.ptyp_desc with - | Ptyp_arrow _ | Ptyp_tuple _ | Ptyp_alias _ -> addParens doc - | _ when Ast_uncurried.coreTypeIsUncurriedFun n -> addParens doc - | _ -> doc - in - Doc.group - (Doc.concat - [ - Doc.group attrs; - Doc.group - (if hasAttrsBefore then - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [Doc.softLine; typDoc; Doc.text " => "; returnDoc]); - Doc.softLine; - Doc.rparen; - ] - else Doc.concat [typDoc; Doc.text " => "; returnDoc]); - ]) - | args -> - let attrs = printAttributes ~state ~inline:true attrsBefore cmtTbl in - let renderedArgs = - Doc.concat - [ - attrs; - Doc.text "("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if dotted then Doc.concat [Doc.dot; Doc.space] else Doc.nil); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun tp -> printTypeParameter ~state tp cmtTbl) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text ")"; - ] - in - Doc.group (Doc.concat [renderedArgs; Doc.text " => "; returnDoc]) - in - let renderedType = - match typExpr.ptyp_desc with - | Ptyp_any -> Doc.text "_" - | Ptyp_var var -> - Doc.concat [Doc.text "'"; printIdentLike ~allowUident:true var] - | Ptyp_extension extension -> - printExtension ~state ~atModuleLvl:false extension cmtTbl - | Ptyp_alias (typ, alias) -> - let typ = - (* Technically type t = (string, float) => unit as 'x, doesn't require - * parens around the arrow expression. This is very confusing though. - * Is the "as" part of "unit" or "(string, float) => unit". By printing - * parens we guide the user towards its meaning.*) - let needsParens = - match typ.ptyp_desc with - | Ptyp_arrow _ -> true - | _ when Ast_uncurried.coreTypeIsUncurriedFun typ -> true - | _ -> false - in - let doc = printTypExpr ~state typ cmtTbl in - if needsParens then Doc.concat [Doc.lparen; doc; Doc.rparen] else doc - in - Doc.concat - [typ; Doc.text " as "; Doc.concat [Doc.text "'"; printIdentLike alias]] - (* object printings *) - | Ptyp_object (fields, openFlag) -> - printObject ~state ~inline:false fields openFlag cmtTbl - | Ptyp_arrow _ -> printArrow ~uncurried:false typExpr - | Ptyp_constr _ when Ast_uncurried.coreTypeIsUncurriedFun typExpr -> - let arity, tArg = Ast_uncurried.coreTypeExtractUncurriedFun typExpr in - printArrow ~uncurried:true ~arity tArg - | Ptyp_constr (longidentLoc, [{ptyp_desc = Ptyp_object (fields, openFlag)}]) - -> - (* for foo<{"a": b}>, when the object is long and needs a line break, we - want the <{ and }> to stay hugged together *) - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.concat - [ - constrName; - Doc.lessThan; - printObject ~state ~inline:true fields openFlag cmtTbl; - Doc.greaterThan; - ] - | Ptyp_constr (longidentLoc, [{ptyp_desc = Parsetree.Ptyp_tuple tuple}]) -> - let constrName = printLidentPath longidentLoc cmtTbl in - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - printTupleType ~state ~inline:true tuple cmtTbl; - Doc.greaterThan; - ]) - | Ptyp_constr (longidentLoc, constrArgs) -> ( - let constrName = printLidentPath longidentLoc cmtTbl in - match constrArgs with - | [] -> constrName - | _args -> - Doc.group - (Doc.concat - [ - constrName; - Doc.lessThan; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> printTypExpr ~state typexpr cmtTbl) - constrArgs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.greaterThan; - ])) - | Ptyp_tuple types -> printTupleType ~state ~inline:false types cmtTbl - | Ptyp_poly ([], typ) -> printTypExpr ~state typ cmtTbl - | Ptyp_poly (stringLocs, typ) -> - Doc.concat - [ - Doc.join ~sep:Doc.space - (List.map - (fun {Location.txt; loc} -> - let doc = Doc.concat [Doc.text "'"; Doc.text txt] in - printComments doc cmtTbl loc) - stringLocs); - Doc.dot; - Doc.space; - printTypExpr ~state typ cmtTbl; - ] - | Ptyp_package packageType -> - printPackageType ~state ~printModuleKeywordAndParens:true packageType - cmtTbl - | Ptyp_class _ -> Doc.text "classes are not supported in types" - | Ptyp_variant (rowFields, closedFlag, labelsOpt) -> - let forceBreak = - typExpr.ptyp_loc.Location.loc_start.pos_lnum - < typExpr.ptyp_loc.loc_end.pos_lnum - in - let printRowField = function - | Parsetree.Rtag ({txt; loc}, attrs, true, []) -> - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~state attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - ]) - in - printComments doc cmtTbl loc - | Rtag ({txt}, attrs, truth, types) -> - let doType t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> printTypExpr ~state t cmtTbl - | _ -> - Doc.concat [Doc.lparen; printTypExpr ~state t cmtTbl; Doc.rparen] - in - let printedTypes = List.map doType types in - let cases = - Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printedTypes - in - let cases = - if truth then Doc.concat [Doc.line; Doc.text "& "; cases] else cases - in - Doc.group - (Doc.concat - [ - printAttributes ~state attrs cmtTbl; - Doc.concat [Doc.text "#"; printPolyVarIdent txt]; - cases; - ]) - | Rinherit coreType -> printTypExpr ~state coreType cmtTbl - in - let docs = List.map printRowField rowFields in - let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "| "]) docs in - let cases = - if docs = [] then cases - else Doc.concat [Doc.ifBreaks (Doc.text "| ") Doc.nil; cases] - in - let openingSymbol = - if closedFlag = Open then Doc.concat [Doc.greaterThan; Doc.line] - else if labelsOpt = None then Doc.softLine - else Doc.concat [Doc.lessThan; Doc.line] - in - let labels = - match labelsOpt with - | None | Some [] -> Doc.nil - | Some labels -> - Doc.concat - (List.map - (fun label -> - Doc.concat [Doc.line; Doc.text "#"; printPolyVarIdent label]) - labels) - in - let closingSymbol = - match labelsOpt with - | None | Some [] -> Doc.nil - | _ -> Doc.text " >" - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat [openingSymbol; cases; closingSymbol; labels]); - Doc.softLine; - Doc.rbracket; - ]) - in - let shouldPrintItsOwnAttributes = - match typExpr.ptyp_desc with - | Ptyp_arrow _ (* es6 arrow types print their own attributes *) -> true - | _ -> false - in - let doc = - match typExpr.ptyp_attributes with - | _ :: _ as attrs when not shouldPrintItsOwnAttributes -> - Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; renderedType]) - | _ -> renderedType - in - printComments doc cmtTbl typExpr.ptyp_loc - -and printObject ~state ~inline fields openFlag cmtTbl = - let doc = - match fields with - | [] -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.dot - | Open -> Doc.dotdot); - Doc.rbrace; - ] - | fields -> - Doc.concat - [ - Doc.lbrace; - (match openFlag with - | Asttypes.Closed -> Doc.nil - | Open -> ( - match fields with - (* handle `type t = {.. ...objType, "x": int}` - * .. and ... should have a space in between *) - | Oinherit _ :: _ -> Doc.text ".. " - | _ -> Doc.dotdot)); - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun field -> printObjectField ~state field cmtTbl) - fields); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ] - in - if inline then doc else Doc.group doc - -and printTupleType ~state ~inline (types : Parsetree.core_type list) cmtTbl = - let tuple = - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun typexpr -> printTypExpr ~state typexpr cmtTbl) - types); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - in - if inline == false then Doc.group tuple else tuple - -and printObjectField ~state (field : Parsetree.object_field) cmtTbl = - match field with - | Otag (labelLoc, attrs, typ) -> - let lbl = - let doc = Doc.text ("\"" ^ labelLoc.txt ^ "\"") in - printComments doc cmtTbl labelLoc.loc - in - let doc = - Doc.concat - [ - printAttributes ~state ~loc:labelLoc.loc attrs cmtTbl; - lbl; - Doc.text ": "; - printTypExpr ~state typ cmtTbl; - ] - in - let cmtLoc = {labelLoc.loc with loc_end = typ.ptyp_loc.loc_end} in - printComments doc cmtTbl cmtLoc - | Oinherit typexpr -> - Doc.concat [Doc.dotdotdot; printTypExpr ~state typexpr cmtTbl] - -(* es6 arrow type arg - * type t = (~foo: string, ~bar: float=?, unit) => unit - * i.e. ~foo: string, ~bar: float *) -and printTypeParameter ~state (attrs, lbl, typ) cmtTbl = - (* Converting .ml code to .res requires processing uncurried attributes *) - let hasBs, attrs = ParsetreeViewer.processBsAttribute attrs in - let dotted = if hasBs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = printAttributes ~state attrs cmtTbl in - let label = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Labelled lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] - | Optional lbl -> - Doc.concat [Doc.text "~"; printIdentLike lbl; Doc.text ": "] - in - let optionalIndicator = - match lbl with - | Asttypes.Nolabel | Labelled _ -> Doc.nil - | Optional _lbl -> Doc.text "=?" - in - let loc, typ = - match typ.ptyp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> - ( {loc with loc_end = typ.ptyp_loc.loc_end}, - {typ with ptyp_attributes = attrs} ) - | _ -> (typ.ptyp_loc, typ) - in - let doc = - Doc.group - (Doc.concat - [ - dotted; - attrs; - label; - printTypExpr ~state typ cmtTbl; - optionalIndicator; - ]) - in - printComments doc cmtTbl loc - -and printValueBinding ~state ~recFlag (vb : Parsetree.value_binding) cmtTbl i = - let attrs = - printAttributes ~state ~loc:vb.pvb_pat.ppat_loc vb.pvb_attributes cmtTbl - in - let header = - if i == 0 then Doc.concat [Doc.text "let "; recFlag] else Doc.text "and " - in - match vb with - | { - pvb_pat = - { - ppat_desc = - Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as patTyp)); - }; - pvb_expr = {pexp_desc = Pexp_newtype _} as expr; - } -> ( - let _uncurried, _attrs, parameters, returnExpr = - ParsetreeViewer.funExpr expr - in - let abstractType = - match parameters with - | [NewTypes {locs = vars}] -> - Doc.concat - [ - Doc.text "type "; - Doc.join ~sep:Doc.space - (List.map (fun var -> Doc.text var.Asttypes.txt) vars); - Doc.dot; - ] - | _ -> Doc.nil - in - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~state pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~state typ cmtTbl; - Doc.text " ="; - Doc.concat - [Doc.line; printExpressionWithComments ~state expr cmtTbl]; - ]); - ]) - | _ -> - (* Example: - * let cancel_and_collect_callbacks: - * 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = * (type x, callbacks_accumulator, p: promise<_, _, c>) - *) - Doc.group - (Doc.concat - [ - attrs; - header; - printPattern ~state pattern cmtTbl; - Doc.text ":"; - Doc.indent - (Doc.concat - [ - Doc.line; - abstractType; - Doc.space; - printTypExpr ~state patTyp cmtTbl; - Doc.text " ="; - Doc.concat - [Doc.line; printExpressionWithComments ~state expr cmtTbl]; - ]); - ])) - | _ -> - let optBraces, expr = ParsetreeViewer.processBracesAttr vb.pvb_expr in - let printedExpr = - let doc = printExpressionWithComments ~state vb.pvb_expr cmtTbl in - match Parens.expr vb.pvb_expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let patternDoc = printPattern ~state vb.pvb_pat cmtTbl in - (* - * we want to optimize the layout of one pipe: - * let tbl = data->Js.Array2.reduce((map, curr) => { - * ... - * }) - * important is that we don't do this for multiple pipes: - * let decoratorTags = - * items - * ->Js.Array2.filter(items => {items.category === Decorators}) - * ->Belt.Array.map(...) - * Multiple pipes chained together lend themselves more towards the last layout. - *) - if ParsetreeViewer.isSinglePipeExpr vb.pvb_expr then - Doc.customLayout - [ - Doc.group - (Doc.concat - [ - attrs; header; patternDoc; Doc.text " ="; Doc.space; printedExpr; - ]); - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - Doc.indent (Doc.concat [Doc.line; printedExpr]); - ]); - ] - else - let shouldIndent = - match optBraces with - | Some _ -> false - | _ -> ( - ParsetreeViewer.isBinaryExpression expr - || - match vb.pvb_expr with - | { - pexp_attributes = [({Location.txt = "res.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | {pexp_attributes = [({Location.txt = "res.taggedTemplate"}, _)]} -> - false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e) - in - Doc.group - (Doc.concat - [ - attrs; - header; - patternDoc; - Doc.text " ="; - (if shouldIndent then - Doc.indent (Doc.concat [Doc.line; printedExpr]) - else Doc.concat [Doc.space; printedExpr]); - ]) - -and printPackageType ~state ~printModuleKeywordAndParens - (packageType : Parsetree.package_type) cmtTbl = - let doc = - match packageType with - | longidentLoc, [] -> - Doc.group (Doc.concat [printLongidentLocation longidentLoc cmtTbl]) - | longidentLoc, packageConstraints -> - Doc.group - (Doc.concat - [ - printLongidentLocation longidentLoc cmtTbl; - printPackageConstraints ~state packageConstraints cmtTbl; - Doc.softLine; - ]) - in - if printModuleKeywordAndParens then - Doc.concat [Doc.text "module("; doc; Doc.rparen] - else doc - -and printPackageConstraints ~state packageConstraints cmtTbl = - Doc.concat - [ - Doc.text " with"; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.join ~sep:Doc.line - (List.mapi - (fun i pc -> - let longident, typexpr = pc in - let cmtLoc = - { - longident.Asttypes.loc with - loc_end = typexpr.Parsetree.ptyp_loc.loc_end; - } - in - let doc = printPackageConstraint ~state i cmtTbl pc in - printComments doc cmtTbl cmtLoc) - packageConstraints); - ]); - ] - -and printPackageConstraint ~state i cmtTbl (longidentLoc, typ) = - let prefix = if i == 0 then Doc.text "type " else Doc.text "and type " in - Doc.concat - [ - prefix; - printLongidentLocation longidentLoc cmtTbl; - Doc.text " = "; - printTypExpr ~state typ cmtTbl; - ] - -and printExtension ~state ~atModuleLvl (stringLoc, payload) cmtTbl = - let txt = convertBsExtension stringLoc.Location.txt in - let extName = - let doc = - Doc.concat - [ - Doc.text "%"; - (if atModuleLvl then Doc.text "%" else Doc.nil); - Doc.text txt; - ] - in - printComments doc cmtTbl stringLoc.Location.loc - in - Doc.group (Doc.concat [extName; printPayload ~state payload cmtTbl]) - -and printPattern ~state (p : Parsetree.pattern) cmtTbl = - let patternWithoutAttributes = - match p.ppat_desc with - | Ppat_any -> Doc.text "_" - | Ppat_var var -> printIdentLike var.txt - | Ppat_constant c -> - let templateLiteral = - ParsetreeViewer.hasTemplateLiteralAttr p.ppat_attributes - in - printConstant ~templateLiteral c - | Ppat_tuple patterns -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~state pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - | Ppat_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl p.ppat_loc; Doc.rbracket] - | Ppat_array patterns -> - Doc.group - (Doc.concat - [ - Doc.text "["; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun pat -> printPattern ~state pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.text "]"; - ]) - | Ppat_construct ({txt = Longident.Lident "()"}, _) -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl p.ppat_loc; Doc.rparen] - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl p.ppat_loc; Doc.rbrace] - | Ppat_construct ({txt = Longident.Lident "::"}, _) -> - let patterns, tail = - ParsetreeViewer.collectPatternsFromListConstruct [] p - in - let shouldHug = - match (patterns, tail) with - | [pat], {ppat_desc = Ppat_construct ({txt = Longident.Lident "[]"}, _)} - when ParsetreeViewer.isHuggablePattern pat -> - true - | _ -> false - in - let children = - Doc.concat - [ - (if shouldHug then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map (fun pat -> printPattern ~state pat cmtTbl) patterns); - (match tail.Parsetree.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "[]"}, _) -> Doc.nil - | _ -> - let doc = - Doc.concat [Doc.text "..."; printPattern ~state tail cmtTbl] - in - let tail = printComments doc cmtTbl tail.ppat_loc in - Doc.concat [Doc.text ","; Doc.line; tail]); - ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - (if shouldHug then children - else - Doc.concat - [ - Doc.indent children; - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - ]); - Doc.rbrace; - ]) - | Ppat_construct (constrName, constructorArgs) -> - let constrName = printLongidentLocation constrName cmtTbl in - let argsDoc = - match constructorArgs with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); - } -> - Doc.concat - [Doc.lparen; printCommentsInside cmtTbl ppat_loc; Doc.rparen] - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; printPattern ~state arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~state pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~state arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constrName; argsDoc]) - | Ppat_variant (label, None) -> - Doc.concat [Doc.text "#"; printPolyVarIdent label] - | Ppat_variant (label, variantArgs) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let argsDoc = - match variantArgs with - | None -> Doc.nil - | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; printCommentsInside cmtTbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; printPattern ~state arg cmtTbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> printPattern ~state pat cmtTbl) - patterns); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = printPattern ~state arg cmtTbl in - let shouldHug = ParsetreeViewer.isHuggablePattern arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; argsDoc]) - | Ppat_type ident -> - Doc.concat [Doc.text "#..."; printIdentPath ident cmtTbl] - | Ppat_record (rows, openFlag) -> - Doc.group - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> printPatternRecordRow ~state row cmtTbl) - rows); - (match openFlag with - | Open -> Doc.concat [Doc.text ","; Doc.line; Doc.text "_"] - | Closed -> Doc.nil); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rbrace; - ]) - | Ppat_exception p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~state p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.group (Doc.concat [Doc.text "exception"; Doc.line; pat]) - | Ppat_or _ -> - (* Blue | Red | Green -> [Blue; Red; Green] *) - let orChain = ParsetreeViewer.collectOrPatternChain p in - let docs = - List.mapi - (fun i pat -> - let patternDoc = printPattern ~state pat cmtTbl in - Doc.concat - [ - (if i == 0 then Doc.nil else Doc.concat [Doc.line; Doc.text "| "]); - (match pat.ppat_desc with - (* (Blue | Red) | (Green | Black) | White *) - | Ppat_or _ -> addParens patternDoc - | _ -> patternDoc); - ]) - orChain - in - let isSpreadOverMultipleLines = - match (orChain, List.rev orChain) with - | first :: _, last :: _ -> - first.ppat_loc.loc_start.pos_lnum < last.ppat_loc.loc_end.pos_lnum - | _ -> false - in - Doc.breakableGroup ~forceBreak:isSpreadOverMultipleLines (Doc.concat docs) - | Ppat_extension ext -> printExtension ~state ~atModuleLvl:false ext cmtTbl - | Ppat_lazy p -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let pat = - let p = printPattern ~state p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat [Doc.text "lazy "; pat] - | Ppat_alias (p, aliasLoc) -> - let needsParens = - match p.ppat_desc with - | Ppat_or (_, _) | Ppat_alias (_, _) -> true - | _ -> false - in - let renderedPattern = - let p = printPattern ~state p cmtTbl in - if needsParens then Doc.concat [Doc.text "("; p; Doc.text ")"] else p - in - Doc.concat - [renderedPattern; Doc.text " as "; printStringLoc aliasLoc cmtTbl] - (* Note: module(P : S) is represented as *) - (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) - | Ppat_constraint - ( {ppat_desc = Ppat_unpack stringLoc}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.text ": "; - printComments - (printPackageType ~state ~printModuleKeywordAndParens:false - packageType cmtTbl) - cmtTbl ptyp_loc; - Doc.rparen; - ] - | Ppat_constraint (pattern, typ) -> - Doc.concat - [ - printPattern ~state pattern cmtTbl; - Doc.text ": "; - printTypExpr ~state typ cmtTbl; - ] - (* Note: module(P : S) is represented as *) - (* Ppat_constraint(Ppat_unpack, Ptyp_package) *) - | Ppat_unpack stringLoc -> - Doc.concat - [ - Doc.text "module("; - printComments (Doc.text stringLoc.txt) cmtTbl stringLoc.loc; - Doc.rparen; - ] - | Ppat_interval (a, b) -> - Doc.concat [printConstant a; Doc.text " .. "; printConstant b] - | Ppat_open _ -> Doc.nil - in - let doc = - match p.ppat_attributes with - | [] -> patternWithoutAttributes - | attrs -> - Doc.group - (Doc.concat - [printAttributes ~state attrs cmtTbl; patternWithoutAttributes]) - in - printComments doc cmtTbl p.ppat_loc - -and printPatternRecordRow ~state row cmtTbl = - match row with - (* punned {x}*) - | ( ({Location.txt = Longident.Lident ident} as longident), - {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) - when ident = txt -> - Doc.concat - [ - printOptionalLabel ppat_attributes; - printAttributes ~state ppat_attributes cmtTbl; - printLidentPath longident cmtTbl; - ] - | longident, pattern -> - let locForComments = - {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} - in - let rhsDoc = - let doc = printPattern ~state pattern cmtTbl in - let doc = - if Parens.patternRecordRowRhs pattern then addParens doc else doc - in - Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] - in - let doc = - Doc.group - (Doc.concat - [ - printLidentPath longident cmtTbl; - Doc.text ":"; - (if ParsetreeViewer.isHuggablePattern pattern then - Doc.concat [Doc.space; rhsDoc] - else Doc.indent (Doc.concat [Doc.line; rhsDoc])); - ]) - in - printComments doc cmtTbl locForComments - -and printExpressionWithComments ~state expr cmtTbl : Doc.t = - let doc = printExpression ~state expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc - -and printIfChain ~state pexp_attributes ifs elseExpr cmtTbl = - let ifDocs = - Doc.join ~sep:Doc.space - (List.mapi - (fun i (outerLoc, ifExpr, thenExpr) -> - let ifTxt = if i > 0 then Doc.text "else if " else Doc.text "if " in - let doc = - match ifExpr with - | ParsetreeViewer.If ifExpr -> - let condition = - if ParsetreeViewer.isBlockExpr ifExpr then - printExpressionBlock ~state ~braces:true ifExpr cmtTbl - else - let doc = printExpressionWithComments ~state ifExpr cmtTbl in - match Parens.expr ifExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc ifExpr braces - | Nothing -> Doc.ifBreaks (addParens doc) doc - in - Doc.concat - [ - ifTxt; - Doc.group condition; - Doc.space; - (let thenExpr = - match ParsetreeViewer.processBracesAttr thenExpr with - (* This case only happens when coming from Reason, we strip braces *) - | Some _, expr -> expr - | _ -> thenExpr - in - printExpressionBlock ~state ~braces:true thenExpr cmtTbl); - ] - | IfLet (pattern, conditionExpr) -> - let conditionDoc = - let doc = - printExpressionWithComments ~state conditionExpr cmtTbl - in - match Parens.expr conditionExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc conditionExpr braces - | Nothing -> doc - in - Doc.concat - [ - ifTxt; - Doc.text "let "; - printPattern ~state pattern cmtTbl; - Doc.text " = "; - conditionDoc; - Doc.space; - printExpressionBlock ~state ~braces:true thenExpr cmtTbl; - ] - in - printLeadingComments doc cmtTbl.leading outerLoc) - ifs) - in - let elseDoc = - match elseExpr with - | None -> Doc.nil - | Some expr -> - Doc.concat - [ - Doc.text " else "; printExpressionBlock ~state ~braces:true expr cmtTbl; - ] - in - let attrs = ParsetreeViewer.filterFragileMatchAttributes pexp_attributes in - Doc.concat [printAttributes ~state attrs cmtTbl; ifDocs; elseDoc] - -and printExpression ~state (e : Parsetree.expression) cmtTbl = - let printArrow e = - let uncurried, attrsOnArrow, parameters, returnExpr = - ParsetreeViewer.funExpr e - in - let ParsetreeViewer.{async; bs; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes attrsOnArrow - in - let uncurried = uncurried || bs in - let returnExpr, typConstraint = - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let hasConstraint = - match typConstraint with - | Some _ -> true - | None -> false - in - let parametersDoc = - printExprFunParameters ~state ~inCallback:NoCallback ~uncurried ~async - ~hasConstraint parameters cmtTbl - in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false - in - let shouldIndent = - match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ -> - false - | _ -> true - in - let returnDoc = - let doc = printExpressionWithComments ~state returnExpr cmtTbl in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces - | Nothing -> doc - in - if shouldInline then Doc.concat [Doc.space; returnDoc] - else - Doc.group - (if shouldIndent then Doc.indent (Doc.concat [Doc.line; returnDoc]) - else Doc.concat [Doc.space; returnDoc]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> - let typDoc = - let doc = printTypExpr ~state typ cmtTbl in - if Parens.arrowReturnTypExpr typ then addParens doc else doc - in - Doc.concat [Doc.text ": "; typDoc] - | _ -> Doc.nil - in - let attrs = printAttributes ~state attrs cmtTbl in - Doc.group - (Doc.concat - [attrs; parametersDoc; typConstraintDoc; Doc.text " =>"; returnExprDoc]) - in - let uncurried = Ast_uncurried.exprIsUncurriedFun e in - let e_fun = - if uncurried then Ast_uncurried.exprExtractUncurriedFun e else e - in - let printedExpression = - match e_fun.pexp_desc with - | Pexp_fun - ( Nolabel, - None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ) - | Pexp_construct - ( {txt = Lident "Function$"}, - Some - { - pexp_desc = - Pexp_fun - ( Nolabel, - None, - {ppat_desc = Ppat_var {txt = "__x"}}, - {pexp_desc = Pexp_apply _} ); - } ) -> - (* (__x) => f(a, __x, c) -----> f(a, _, c) *) - printExpressionWithComments ~state - (ParsetreeViewer.rewriteUnderscoreApply e_fun) - cmtTbl - | Pexp_fun _ | Pexp_newtype _ -> printArrow e - | Parsetree.Pexp_constant c -> - printConstant ~templateLiteral:(ParsetreeViewer.isTemplateLiteral e) c - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - printJsxFragment ~state e cmtTbl - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> Doc.text "()" - | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> - Doc.concat - [Doc.text "list{"; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let expressions, spread = ParsetreeViewer.collectListExpressions e in - let spreadDoc = - match spread with - | Some expr -> - Doc.concat - [ - Doc.text ","; - Doc.line; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~state expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - | Pexp_construct (longidentLoc, args) -> - let constr = printLongidentLocation longidentLoc cmtTbl in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* Some((1, 2)) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~state arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~state expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~state arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [constr; args]) - | Pexp_ident path -> printLidentPath path cmtTbl - | Pexp_tuple exprs -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~state expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.ifBreaks (Doc.text ",") Doc.nil; - Doc.softLine; - Doc.rparen; - ]) - | Pexp_array [] -> - Doc.concat - [Doc.lbracket; printCommentsInside cmtTbl e.pexp_loc; Doc.rbracket] - | Pexp_array exprs -> - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~state expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - exprs); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - | Pexp_variant (label, args) -> - let variantName = Doc.concat [Doc.text "#"; printPolyVarIdent label] in - let args = - match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> - Doc.text "()" - (* #poly((1, 2) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = printExpressionWithComments ~state arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - printExpressionWithComments ~state expr cmtTbl - in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ] - | Some arg -> - let argDoc = - let doc = printExpressionWithComments ~state arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - let shouldHug = ParsetreeViewer.isHuggableExpression arg in - Doc.concat - [ - Doc.lparen; - (if shouldHug then argDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; argDoc]); - Doc.trailingComma; - Doc.softLine; - ]); - Doc.rparen; - ] - in - Doc.group (Doc.concat [variantName; args]) - | Pexp_record (rows, spreadExpr) -> - if rows = [] then - Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl e.pexp_loc; Doc.rbrace] - else - let spread = - match spreadExpr with - | None -> Doc.nil - | Some ({pexp_desc} as expr) -> - let doc = - match pexp_desc with - | Pexp_ident {txt = expr} -> printLident expr - | _ -> printExpression ~state expr cmtTbl - in - let docWithSpread = - Doc.concat - [ - Doc.dotdotdot; - (match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - in - Doc.concat - [ - printComments docWithSpread cmtTbl expr.Parsetree.pexp_loc; - Doc.comma; - Doc.line; - ] - in - (* If the record is written over multiple lines, break automatically - * `let x = {a: 1, b: 3}` -> same line, break when line-width exceeded - * `let x = { - * a: 1, - * b: 2, - * }` -> record is written on multiple lines, break the group *) - let forceBreak = - e.pexp_loc.loc_start.pos_lnum < e.pexp_loc.loc_end.pos_lnum - in - let punningAllowed = - match (spreadExpr, rows) with - | None, [_] -> false (* disallow punning for single-element records *) - | _ -> true - in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - spread; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> - printExpressionRecordRow ~state row cmtTbl - punningAllowed) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - | Pexp_extension extension -> ( - match extension with - | ( {txt = "bs.obj" | "obj"}, - PStr - [ - { - pstr_loc = loc; - pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, []); - }; - ] ) -> - (* If the object is written over multiple lines, break automatically - * `let x = {"a": 1, "b": 3}` -> same line, break when line-width exceeded - * `let x = { - * "a": 1, - * "b": 2, - * }` -> object is written on multiple lines, break the group *) - let forceBreak = loc.loc_start.pos_lnum < loc.loc_end.pos_lnum in - Doc.breakableGroup ~forceBreak - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> printBsObjectRow ~state row cmtTbl) - rows); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - | extension -> printExtension ~state ~atModuleLvl:false extension cmtTbl) - | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) - when ParsetreeViewer.isSpreadBeltArrayConcat e -> - printBeltArrayConcatApply ~state subLists cmtTbl - | Pexp_apply (e, [(Nolabel, {pexp_desc = Pexp_array subLists})]) - when ParsetreeViewer.isSpreadBeltListConcat e -> - printBeltListConcatApply ~state subLists cmtTbl - | Pexp_apply (callExpr, args) -> - if ParsetreeViewer.isUnaryExpression e then - printUnaryExpression ~state e cmtTbl - else if ParsetreeViewer.isTemplateLiteral e then - printTemplateLiteral ~state e cmtTbl - else if ParsetreeViewer.isTaggedTemplateLiteral e then - printTaggedTemplateLiteral ~state callExpr args cmtTbl - else if ParsetreeViewer.isBinaryExpression e then - printBinaryExpression ~state e cmtTbl - else printPexpApply ~state e cmtTbl - | Pexp_unreachable -> Doc.dot - | Pexp_field (expr, longidentLoc) -> - let lhs = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.fieldExpr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [lhs; Doc.dot; printLidentPath longidentLoc cmtTbl] - | Pexp_setfield (expr1, longidentLoc, expr2) -> - printSetFieldExpr ~state e.pexp_attributes expr1 longidentLoc expr2 - e.pexp_loc cmtTbl - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) - when ParsetreeViewer.isTernaryExpr e -> - let parts, alternate = ParsetreeViewer.collectTernaryParts e in - let ternaryDoc = - match parts with - | (condition1, consequent1) :: rest -> - Doc.group - (Doc.concat - [ - printTernaryOperand ~state condition1 cmtTbl; - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.indent - (Doc.concat - [ - Doc.text "? "; - printTernaryOperand ~state consequent1 cmtTbl; - ]); - Doc.concat - (List.map - (fun (condition, consequent) -> - Doc.concat - [ - Doc.line; - Doc.text ": "; - printTernaryOperand ~state condition cmtTbl; - Doc.line; - Doc.text "? "; - printTernaryOperand ~state consequent cmtTbl; - ]) - rest); - Doc.line; - Doc.text ": "; - Doc.indent (printTernaryOperand ~state alternate cmtTbl); - ]); - ]) - | _ -> Doc.nil - in - let attrs = ParsetreeViewer.filterTernaryAttributes e.pexp_attributes in - let needsParens = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> false - | _ -> true - in - Doc.concat - [ - printAttributes ~state attrs cmtTbl; - (if needsParens then addParens ternaryDoc else ternaryDoc); - ] - | Pexp_ifthenelse (_ifExpr, _thenExpr, _elseExpr) -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~state e.pexp_attributes ifs elseExpr cmtTbl - | Pexp_while (expr1, expr2) -> - let condition = - let doc = printExpressionWithComments ~state expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "while "; - (if ParsetreeViewer.isBlockExpr expr1 then condition - else Doc.group (Doc.ifBreaks (addParens condition) condition)); - Doc.space; - printExpressionBlock ~state ~braces:true expr2 cmtTbl; - ]) - | Pexp_for (pattern, fromExpr, toExpr, directionFlag, body) -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.text "for "; - printPattern ~state pattern cmtTbl; - Doc.text " in "; - (let doc = printExpressionWithComments ~state fromExpr cmtTbl in - match Parens.expr fromExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc fromExpr braces - | Nothing -> doc); - printDirectionFlag directionFlag; - (let doc = printExpressionWithComments ~state toExpr cmtTbl in - match Parens.expr toExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc toExpr braces - | Nothing -> doc); - Doc.space; - printExpressionBlock ~state ~braces:true body cmtTbl; - ]) - | Pexp_constraint - ( {pexp_desc = Pexp_pack modExpr}, - {ptyp_desc = Ptyp_package packageType; ptyp_loc} ) -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printModExpr ~state modExpr cmtTbl; - Doc.text ": "; - printComments - (printPackageType ~state - ~printModuleKeywordAndParens:false packageType cmtTbl) - cmtTbl ptyp_loc; - ]); - Doc.softLine; - Doc.rparen; - ]) - | Pexp_constraint (expr, typ) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat [exprDoc; Doc.text ": "; printTypExpr ~state typ cmtTbl] - | Pexp_letmodule ({txt = _modName}, _modExpr, _expr) -> - printExpressionBlock ~state ~braces:true e cmtTbl - | Pexp_letexception (_extensionConstructor, _expr) -> - printExpressionBlock ~state ~braces:true e cmtTbl - | Pexp_assert expr -> - let expr = printExpressionWithComments ~state expr cmtTbl in - Doc.concat [Doc.text "assert("; expr; Doc.text ")"] - | Pexp_lazy expr -> - let rhs = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.lazyOrAssertOrAwaitExprRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [Doc.text "lazy "; rhs]) - | Pexp_open (_overrideFlag, _longidentLoc, _expr) -> - printExpressionBlock ~state ~braces:true e cmtTbl - | Pexp_pack modExpr -> - Doc.group - (Doc.concat - [ - Doc.text "module("; - Doc.indent - (Doc.concat [Doc.softLine; printModExpr ~state modExpr cmtTbl]); - Doc.softLine; - Doc.rparen; - ]) - | Pexp_sequence _ -> printExpressionBlock ~state ~braces:true e cmtTbl - | Pexp_let _ -> printExpressionBlock ~state ~braces:true e cmtTbl - | Pexp_try (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [ - Doc.text "try "; - exprDoc; - Doc.text " catch "; - printCases ~state cases cmtTbl; - ] - | Pexp_match (_, [_; _]) when ParsetreeViewer.isIfLetExpr e -> - let ifs, elseExpr = ParsetreeViewer.collectIfExpressions e in - printIfChain ~state e.pexp_attributes ifs elseExpr cmtTbl - | Pexp_match (expr, cases) -> - let exprDoc = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.concat - [Doc.text "switch "; exprDoc; Doc.space; printCases ~state cases cmtTbl] - | Pexp_function cases -> - Doc.concat [Doc.text "x => switch x "; printCases ~state cases cmtTbl] - | Pexp_coerce (expr, typOpt, typ) -> - let docExpr = printExpressionWithComments ~state expr cmtTbl in - let docTyp = printTypExpr ~state typ cmtTbl in - let ofType = - match typOpt with - | None -> Doc.nil - | Some typ1 -> - Doc.concat [Doc.text ": "; printTypExpr ~state typ1 cmtTbl] - in - Doc.concat - [Doc.lparen; docExpr; ofType; Doc.text " :> "; docTyp; Doc.rparen] - | Pexp_send (parentExpr, label) -> - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = printComments (Doc.text label.txt) cmtTbl label.loc in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group (Doc.concat [parentDoc; Doc.lbracket; member; Doc.rbracket]) - | Pexp_new _ -> Doc.text "Pexp_new not implemented in printer" - | Pexp_setinstvar _ -> Doc.text "Pexp_setinstvar not implemented in printer" - | Pexp_override _ -> Doc.text "Pexp_override not implemented in printer" - | Pexp_poly _ -> Doc.text "Pexp_poly not implemented in printer" - | Pexp_object _ -> Doc.text "Pexp_object not implemented in printer" - in - let exprWithAwait = - if ParsetreeViewer.hasAwaitAttribute e.pexp_attributes then - let rhs = - match - Parens.lazyOrAssertOrAwaitExprRhs ~inAwait:true - { - e with - pexp_attributes = - List.filter - (function - | {Location.txt = "res.braces" | "ns.braces"}, _ -> false - | _ -> true) - e.pexp_attributes; - } - with - | Parens.Parenthesized -> addParens printedExpression - | Braced braces -> printBraces printedExpression e braces - | Nothing -> printedExpression - in - Doc.concat [Doc.text "await "; rhs] - else printedExpression - in - let shouldPrintItsOwnAttributes = - match e.pexp_desc with - | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ - | Pexp_ifthenelse _ -> - true - | Pexp_match _ when ParsetreeViewer.isIfLetExpr e -> true - | Pexp_construct _ when ParsetreeViewer.hasJsxAttribute e.pexp_attributes -> - true - | _ -> false - in - match e.pexp_attributes with - | [] -> exprWithAwait - | attrs when not shouldPrintItsOwnAttributes -> - Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; exprWithAwait]) - | _ -> exprWithAwait - -and printPexpFun ~state ~inCallback e cmtTbl = - let uncurried, attrsOnArrow, parameters, returnExpr = - ParsetreeViewer.funExpr e - in - let ParsetreeViewer.{async; bs; attributes = attrs} = - ParsetreeViewer.processFunctionAttributes attrsOnArrow - in - let uncurried = bs || uncurried in - let returnExpr, typConstraint = - match returnExpr.pexp_desc with - | Pexp_constraint (expr, typ) -> - ( { - expr with - pexp_attributes = - List.concat [expr.pexp_attributes; returnExpr.pexp_attributes]; - }, - Some typ ) - | _ -> (returnExpr, None) - in - let parametersDoc = - printExprFunParameters ~state ~inCallback ~async ~uncurried - ~hasConstraint: - (match typConstraint with - | Some _ -> true - | None -> false) - parameters cmtTbl - in - let returnShouldIndent = - match returnExpr.pexp_desc with - | Pexp_sequence _ | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ - | Pexp_open _ -> - false - | _ -> true - in - let returnExprDoc = - let optBraces, _ = ParsetreeViewer.processBracesAttr returnExpr in - let shouldInline = - match (returnExpr.pexp_desc, optBraces) with - | _, Some _ -> true - | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) - | Pexp_record _ ), - _ ) -> - true - | _ -> false - in - let returnDoc = - let doc = printExpressionWithComments ~state returnExpr cmtTbl in - match Parens.expr returnExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc returnExpr braces - | Nothing -> doc - in - if shouldInline then Doc.concat [Doc.space; returnDoc] - else - Doc.group - (if returnShouldIndent then - Doc.concat - [ - Doc.indent (Doc.concat [Doc.line; returnDoc]); - (match inCallback with - | FitsOnOneLine | ArgumentsFitOnOneLine -> Doc.softLine - | _ -> Doc.nil); - ] - else Doc.concat [Doc.space; returnDoc]) - in - let typConstraintDoc = - match typConstraint with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] - | _ -> Doc.nil - in - Doc.concat - [ - printAttributes ~state attrs cmtTbl; - parametersDoc; - typConstraintDoc; - Doc.text " =>"; - returnExprDoc; - ] - -and printTernaryOperand ~state expr cmtTbl = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.ternaryOperand expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - -and printSetFieldExpr ~state attrs lhs longidentLoc rhs loc cmtTbl = - let rhsDoc = - let doc = printExpressionWithComments ~state rhs cmtTbl in - match Parens.setFieldExprRhs rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - let lhsDoc = - let doc = printExpressionWithComments ~state lhs cmtTbl in - match Parens.fieldExpr lhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc lhs braces - | Nothing -> doc - in - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = - Doc.group - (Doc.concat - [ - lhsDoc; - Doc.dot; - printLidentPath longidentLoc cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); - ]) - in - let doc = - match attrs with - | [] -> doc - | attrs -> Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) - in - printComments doc cmtTbl loc - -and printTemplateLiteral ~state expr cmtTbl = - let tag = ref "js" in - let rec walkExpr expr = - let open Parsetree in - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"}}, - [(Nolabel, arg1); (Nolabel, arg2)] ) -> - let lhs = walkExpr arg1 in - let rhs = walkExpr arg2 in - Doc.concat [lhs; rhs] - | Pexp_constant (Pconst_string (txt, Some prefix)) -> - tag := prefix; - printStringContents txt - | _ -> - let doc = printExpressionWithComments ~state expr cmtTbl in - let doc = - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - Doc.group (Doc.concat [Doc.text "${"; Doc.indent doc; Doc.rbrace]) - in - let content = walkExpr expr in - Doc.concat - [ - (if !tag = "js" then Doc.nil else Doc.text !tag); - Doc.text "`"; - content; - Doc.text "`"; - ] - -and printTaggedTemplateLiteral ~state callExpr args cmtTbl = - let stringsList, valuesList = - match args with - | [ - (_, {Parsetree.pexp_desc = Pexp_array strings}); - (_, {Parsetree.pexp_desc = Pexp_array values}); - ] -> - (strings, values) - | _ -> assert false - in - - let strings = - List.map - (fun x -> - match x with - | {Parsetree.pexp_desc = Pexp_constant (Pconst_string (txt, _))} -> - printStringContents txt - | _ -> assert false) - stringsList - in - - let values = - List.map - (fun x -> - Doc.concat - [ - Doc.text "${"; - printExpressionWithComments ~state x cmtTbl; - Doc.text "}"; - ]) - valuesList - in - - let process strings values = - let rec aux acc = function - | [], [] -> acc - | a_head :: a_rest, b -> aux (Doc.concat [acc; a_head]) (b, a_rest) - | _ -> assert false - in - aux Doc.nil (strings, values) - in - - let content : Doc.t = process strings values in - - let tag = printExpressionWithComments ~state callExpr cmtTbl in - Doc.concat [tag; Doc.text "`"; content; Doc.text "`"] - -and printUnaryExpression ~state expr cmtTbl = - let printUnaryOperator op = - Doc.text - (match op with - | "~+" -> "+" - | "~+." -> "+." - | "~-" -> "-" - | "~-." -> "-." - | "not" -> "!" - | _ -> assert false) - in - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, operand)] ) -> - let printedOperand = - let doc = printExpressionWithComments ~state operand cmtTbl in - match Parens.unaryExprOperand operand with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc operand braces - | Nothing -> doc - in - let doc = Doc.concat [printUnaryOperator operator; printedOperand] in - printComments doc cmtTbl expr.pexp_loc - | _ -> assert false - -and printBinaryExpression ~state (expr : Parsetree.expression) cmtTbl = - let printBinaryOperator ~inlineRhs operator = - let operatorTxt = - match operator with - | "|." | "|.u" -> "->" - | "^" -> "++" - | "=" -> "==" - | "==" -> "===" - | "<>" -> "!=" - | "!=" -> "!==" - | txt -> txt - in - let spacingBeforeOperator = - if operator = "|." || operator = "|.u" then Doc.softLine - else if operator = "|>" then Doc.line - else Doc.space - in - let spacingAfterOperator = - if operator = "|." || operator = "|.u" then Doc.nil - else if operator = "|>" then Doc.space - else if inlineRhs then Doc.space - else Doc.line - in - Doc.concat - [spacingBeforeOperator; Doc.text operatorTxt; spacingAfterOperator] - in - let printOperand ~isLhs ~isMultiline expr parentOperator = - let rec flatten ~isLhs ~isMultiline expr parentOperator = - if ParsetreeViewer.isBinaryExpression expr then - match expr with - | { - pexp_desc = - Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(_, left); (_, right)] ); - } -> - if - ParsetreeViewer.flattenableOperators parentOperator operator - && not (ParsetreeViewer.hasAttributes expr.pexp_attributes) - then - let leftPrinted = flatten ~isLhs:true ~isMultiline left operator in - let rightPrinted = - let rightPrinteableAttrs, rightInternalAttrs = - ParsetreeViewer.partitionPrintableAttributes - right.pexp_attributes - in - let doc = - printExpressionWithComments ~state - {right with pexp_attributes = rightInternalAttrs} - cmtTbl - in - let doc = - if Parens.flattenOperandRhs parentOperator right then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - let doc = - Doc.concat - [printAttributes ~state rightPrinteableAttrs cmtTbl; doc] - in - match rightPrinteableAttrs with - | [] -> doc - | _ -> addParens doc - in - let isAwait = - ParsetreeViewer.hasAwaitAttribute expr.pexp_attributes - in - let doc = - if isAwait then - let parens = - Res_parens.binaryOperatorInsideAwaitNeedsParens operator - in - Doc.concat - [ - Doc.lparen; - Doc.text "await "; - (if parens then Doc.lparen else Doc.nil); - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - (if parens then Doc.rparen else Doc.nil); - Doc.rparen; - ] - else - match operator with - | ("|." | "|.u") when isMultiline -> - (* If the pipe-chain is written over multiple lines, break automatically - * `let x = a->b->c -> same line, break when line-width exceeded - * `let x = a-> - * b->c` -> pipe-chain is written on multiple lines, break the group *) - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ]) - | _ -> - Doc.concat - [ - leftPrinted; - printBinaryOperator ~inlineRhs:false operator; - rightPrinted; - ] - in - - let doc = - if (not isLhs) && Parens.rhsBinaryExprOperand operator expr then - Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - printComments doc cmtTbl expr.pexp_loc - else - let printeableAttrs, internalAttrs = - ParsetreeViewer.partitionPrintableAttributes expr.pexp_attributes - in - let doc = - printExpressionWithComments ~state - {expr with pexp_attributes = internalAttrs} - cmtTbl - in - let doc = - if - Parens.subBinaryExprOperand parentOperator operator - || printeableAttrs <> [] - && (ParsetreeViewer.isBinaryExpression expr - || ParsetreeViewer.isTernaryExpr expr) - then Doc.concat [Doc.lparen; doc; Doc.rparen] - else doc - in - Doc.concat [printAttributes ~state printeableAttrs cmtTbl; doc] - | _ -> assert false - else - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "^"; loc}}, - [(Nolabel, _); (Nolabel, _)] ) - when loc.loc_ghost -> - let doc = printTemplateLiteral ~state expr cmtTbl in - printComments doc cmtTbl expr.Parsetree.pexp_loc - | Pexp_setfield (lhs, field, rhs) -> - let doc = - printSetFieldExpr ~state expr.pexp_attributes lhs field rhs - expr.pexp_loc cmtTbl - in - if isLhs then addParens doc else doc - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let rhsDoc = printExpressionWithComments ~state rhs cmtTbl in - let lhsDoc = printExpressionWithComments ~state lhs cmtTbl in - (* TODO: unify indentation of "=" *) - let shouldIndent = ParsetreeViewer.isBinaryExpression rhs in - let doc = - Doc.group - (Doc.concat - [ - lhsDoc; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); - ]) - in - let doc = - match expr.pexp_attributes with - | [] -> doc - | attrs -> - Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) - in - if isLhs then addParens doc else doc - | _ -> ( - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.binaryExprOperand ~isLhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - in - flatten ~isLhs ~isMultiline expr parentOperator - in - match expr.pexp_desc with - | Pexp_apply - ( { - pexp_desc = - Pexp_ident {txt = Longident.Lident (("|." | "|.u" | "|>") as op)}; - }, - [(Nolabel, lhs); (Nolabel, rhs)] ) - when not - (ParsetreeViewer.isBinaryExpression lhs - || ParsetreeViewer.isBinaryExpression rhs - || printAttributes ~state expr.pexp_attributes cmtTbl <> Doc.nil) -> - let lhsHasCommentBelow = hasCommentBelow cmtTbl lhs.pexp_loc in - let lhsDoc = printOperand ~isLhs:true ~isMultiline:false lhs op in - let rhsDoc = printOperand ~isLhs:false ~isMultiline:false rhs op in - Doc.group - (Doc.concat - [ - printAttributes ~state expr.pexp_attributes cmtTbl; - lhsDoc; - (match (lhsHasCommentBelow, op) with - | true, ("|." | "|.u") -> Doc.concat [Doc.softLine; Doc.text "->"] - | false, ("|." | "|.u") -> Doc.text "->" - | true, "|>" -> Doc.concat [Doc.line; Doc.text "|> "] - | false, "|>" -> Doc.text " |> " - | _ -> Doc.nil); - rhsDoc; - ]) - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident operator}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> - let isMultiline = - lhs.pexp_loc.loc_start.pos_lnum < rhs.pexp_loc.loc_start.pos_lnum - in - - let right = - let operatorWithRhs = - let rhsDoc = - printOperand - ~isLhs:(ParsetreeViewer.isRhsBinaryOperator operator) - ~isMultiline rhs operator - in - Doc.concat - [ - printBinaryOperator - ~inlineRhs:(ParsetreeViewer.shouldInlineRhsBinaryExpr rhs) - operator; - rhsDoc; - ] - in - if ParsetreeViewer.shouldIndentBinaryExpr expr then - Doc.group (Doc.indent operatorWithRhs) - else operatorWithRhs - in - let doc = - Doc.group - (Doc.concat - [ - printOperand - ~isLhs:(not @@ ParsetreeViewer.isRhsBinaryOperator operator) - ~isMultiline lhs operator; - right; - ]) - in - Doc.group - (Doc.concat - [ - printAttributes ~state expr.pexp_attributes cmtTbl; - (match - Parens.binaryExpr - { - expr with - pexp_attributes = - ParsetreeViewer.filterPrintableAttributes - expr.pexp_attributes; - } - with - | Braced bracesLoc -> printBraces doc expr bracesLoc - | Parenthesized -> addParens doc - | Nothing -> doc); - ]) - | _ -> Doc.nil - -and printBeltArrayConcatApply ~state subLists cmtTbl = - let makeSpreadDoc commaBeforeSpread = function - | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - let makeSubListDoc (expressions, spread) = - let commaBeforeSpread = - match expressions with - | [] -> Doc.nil - | _ -> Doc.concat [Doc.text ","; Doc.line] - in - let spreadDoc = makeSpreadDoc commaBeforeSpread spread in - Doc.concat - [ - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ] - in - Doc.group - (Doc.concat - [ - Doc.lbracket; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map makeSubListDoc - (List.map ParsetreeViewer.collectArrayExpressions subLists)); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbracket; - ]) - -and printBeltListConcatApply ~state subLists cmtTbl = - let makeSpreadDoc commaBeforeSpread = function - | Some expr -> - Doc.concat - [ - commaBeforeSpread; - Doc.dotdotdot; - (let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - | None -> Doc.nil - in - let makeSubListDoc (expressions, spread) = - let commaBeforeSpread = - match expressions with - | [] -> Doc.nil - | _ -> Doc.concat [Doc.text ","; Doc.line] - in - let spreadDoc = makeSpreadDoc commaBeforeSpread spread in - Doc.concat - [ - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun expr -> - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc) - expressions); - spreadDoc; - ] - in - Doc.group - (Doc.concat - [ - Doc.text "list{"; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map makeSubListDoc - (List.map ParsetreeViewer.collectListExpressions subLists)); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rbrace; - ]) - -(* callExpr(arg1, arg2) *) -and printPexpApply ~state expr cmtTbl = - match expr.pexp_desc with - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "##"}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) -> - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - let member = - let memberDoc = - match memberExpr.pexp_desc with - | Pexp_ident lident -> - printComments (printLongident lident.txt) cmtTbl memberExpr.pexp_loc - | _ -> printExpressionWithComments ~state memberExpr cmtTbl - in - Doc.concat [Doc.text "\""; memberDoc; Doc.text "\""] - in - Doc.group - (Doc.concat - [ - printAttributes ~state expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Lident "#="}}, - [(Nolabel, lhs); (Nolabel, rhs)] ) -> ( - let rhsDoc = - let doc = printExpressionWithComments ~state rhs cmtTbl in - match Parens.expr rhs with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc rhs braces - | Nothing -> doc - in - (* TODO: unify indentation of "=" *) - let shouldIndent = - (not (ParsetreeViewer.isBracedExpr rhs)) - && ParsetreeViewer.isBinaryExpression rhs - in - let doc = - Doc.group - (Doc.concat - [ - printExpressionWithComments ~state lhs cmtTbl; - Doc.text " ="; - (if shouldIndent then - Doc.group (Doc.indent (Doc.concat [Doc.line; rhsDoc])) - else Doc.concat [Doc.space; rhsDoc]); - ]) - in - match expr.pexp_attributes with - | [] -> doc - | attrs -> Doc.group (Doc.concat [printAttributes ~state attrs cmtTbl; doc]) - ) - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "get")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr)] ) - when not (ParsetreeViewer.isRewrittenUnderscoreApplySugar parentExpr) -> - (* Don't print the Array.get(_, 0) sugar a.k.a. (__x) => Array.get(__x, 0) as _[0] *) - let member = - let memberDoc = - let doc = printExpressionWithComments ~state memberExpr cmtTbl in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~state expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - ]) - | Pexp_apply - ( {pexp_desc = Pexp_ident {txt = Longident.Ldot (Lident "Array", "set")}}, - [(Nolabel, parentExpr); (Nolabel, memberExpr); (Nolabel, targetExpr)] ) - -> - let member = - let memberDoc = - let doc = printExpressionWithComments ~state memberExpr cmtTbl in - match Parens.expr memberExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc memberExpr braces - | Nothing -> doc - in - let shouldInline = - match memberExpr.pexp_desc with - | Pexp_constant _ | Pexp_ident _ -> true - | _ -> false - in - if shouldInline then memberDoc - else - Doc.concat - [Doc.indent (Doc.concat [Doc.softLine; memberDoc]); Doc.softLine] - in - let shouldIndentTargetExpr = - if ParsetreeViewer.isBracedExpr targetExpr then false - else - ParsetreeViewer.isBinaryExpression targetExpr - || - match targetExpr with - | { - pexp_attributes = [({Location.txt = "res.ternary"}, _)]; - pexp_desc = Pexp_ifthenelse (ifExpr, _, _); - } -> - ParsetreeViewer.isBinaryExpression ifExpr - || ParsetreeViewer.hasAttributes ifExpr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false - | e -> - ParsetreeViewer.hasAttributes e.pexp_attributes - || ParsetreeViewer.isArrayAccess e - in - let targetExpr = - let doc = printExpressionWithComments ~state targetExpr cmtTbl in - match Parens.expr targetExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc targetExpr braces - | Nothing -> doc - in - let parentDoc = - let doc = printExpressionWithComments ~state parentExpr cmtTbl in - match Parens.unaryExprOperand parentExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc parentExpr braces - | Nothing -> doc - in - Doc.group - (Doc.concat - [ - printAttributes ~state expr.pexp_attributes cmtTbl; - parentDoc; - Doc.lbracket; - member; - Doc.rbracket; - Doc.text " ="; - (if shouldIndentTargetExpr then - Doc.indent (Doc.concat [Doc.line; targetExpr]) - else Doc.concat [Doc.space; targetExpr]); - ]) - (* TODO: cleanup, are those branches even remotely performant? *) - | Pexp_apply ({pexp_desc = Pexp_ident lident}, args) - when ParsetreeViewer.isJsxExpression expr -> - printJsxExpression ~state lident args cmtTbl - | Pexp_apply (callExpr, args) -> - let args = - List.map - (fun (lbl, arg) -> (lbl, ParsetreeViewer.rewriteUnderscoreApply arg)) - args - in - let uncurried, attrs = - ParsetreeViewer.processUncurriedAppAttribute expr.pexp_attributes - in - let partial, attrs = ParsetreeViewer.processPartialAppAttribute attrs in - let args = - if partial then - let loc = - {Asttypes.txt = "res.partial"; Asttypes.loc = expr.pexp_loc} - in - let attr = (loc, Parsetree.PTyp (Ast_helper.Typ.any ())) in - let dummy = - Ast_helper.Exp.constant ~attrs:[attr] (Ast_helper.Const.int 0) - in - args @ [(Asttypes.Labelled "...", dummy)] - else args - in - let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in - let callExprDoc = - let doc = printExpressionWithComments ~state callExpr cmtTbl in - match Parens.callExpr callExpr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc callExpr braces - | Nothing -> doc - in - if ParsetreeViewer.requiresSpecialCallbackPrintingFirstArg args then - let argsDoc = - printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl - in - Doc.concat [printAttributes ~state attrs cmtTbl; callExprDoc; argsDoc] - else if ParsetreeViewer.requiresSpecialCallbackPrintingLastArg args then - let argsDoc = - printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl - in - (* - * Fixes the following layout (the `[` and `]` should break): - * [fn(x => { - * let _ = x - * }), fn(y => { - * let _ = y - * }), fn(z => { - * let _ = z - * })] - * See `Doc.willBreak documentation in interface file for more context. - * Context: - * https://github.com/rescript-lang/syntax/issues/111 - * https://github.com/rescript-lang/syntax/issues/166 - *) - let maybeBreakParent = - if Doc.willBreak argsDoc then Doc.breakParent else Doc.nil - in - Doc.concat - [ - maybeBreakParent; - printAttributes ~state attrs cmtTbl; - callExprDoc; - argsDoc; - ] - else - let argsDoc = printArguments ~state ~dotted ~partial args cmtTbl in - Doc.concat [printAttributes ~state attrs cmtTbl; callExprDoc; argsDoc] - | _ -> assert false - -and printJsxExpression ~state lident args cmtTbl = - let name = printJsxName lident in - let formattedProps, children = printJsxProps ~state args cmtTbl in - (*
*) - let hasChildren = - match children with - | Some - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); - } -> - false - | None -> false - | _ -> true - in - let isSelfClosing = - match children with - | Some - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); - pexp_loc = loc; - } -> - not (hasCommentsInside cmtTbl loc) - | _ -> false - in - let printChildren children = - let lineSep = - match children with - | Some expr -> - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line - | None -> Doc.line - in - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - (match children with - | Some childrenExpression -> - printJsxChildren ~state childrenExpression ~sep:lineSep cmtTbl - | None -> Doc.nil); - ]); - lineSep; - ] - in - Doc.group - (Doc.concat - [ - Doc.group - (Doc.concat - [ - printComments - (Doc.concat [Doc.lessThan; name]) - cmtTbl lident.Asttypes.loc; - formattedProps; - (match children with - | Some - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); - } - when isSelfClosing -> - Doc.text "/>" - | _ -> - (* if tag A has trailing comments then put > on the next line - - - *) - if hasTrailingComments cmtTbl lident.Asttypes.loc then - Doc.concat [Doc.softLine; Doc.greaterThan] - else Doc.greaterThan); - ]); - (if isSelfClosing then Doc.nil - else - Doc.concat - [ - (if hasChildren then printChildren children - else - match children with - | Some - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, None); - pexp_loc = loc; - } -> - printCommentsInside cmtTbl loc - | _ -> Doc.nil); - Doc.text "" in - let closing = Doc.text "" in - let lineSep = - if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line - in - Doc.group - (Doc.concat - [ - opening; - (match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil - | _ -> - Doc.indent - (Doc.concat - [Doc.line; printJsxChildren ~state expr ~sep:lineSep cmtTbl])); - lineSep; - closing; - ]) - -and printJsxChildren ~state (childrenExpr : Parsetree.expression) ~sep cmtTbl = - match childrenExpr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "::"}, _) -> - let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in - Doc.group - (Doc.join ~sep - (List.map - (fun (expr : Parsetree.expression) -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let exprDoc = printExpressionWithComments ~state expr cmtTbl in - let addParensOrBraces exprDoc = - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = - if Parens.bracedExpr expr then addParens exprDoc else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - in - match Parens.jsxChildExpr expr with - | Nothing -> exprDoc - | Parenthesized -> addParensOrBraces exprDoc - | Braced bracesLoc -> - printComments (addParensOrBraces exprDoc) cmtTbl bracesLoc) - children)) - | _ -> - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl childrenExpr.pexp_loc - in - let exprDoc = printExpressionWithComments ~state childrenExpr cmtTbl in - Doc.concat - [ - Doc.dotdotdot; - (match Parens.jsxChildExpr childrenExpr with - | Parenthesized | Braced _ -> - let innerDoc = - if Parens.bracedExpr childrenExpr then addParens exprDoc - else exprDoc - in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | Nothing -> exprDoc); - ] - -and printJsxProps ~state args cmtTbl : Doc.t * Parsetree.expression option = - (* This function was introduced because we have different formatting behavior for self-closing tags and other tags - we always put /> on a new line for self-closing tag when it breaks - - - - - - we should remove this function once the format is unified - *) - let isSelfClosing children = - match children with - | { - Parsetree.pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None); - pexp_loc = loc; - } -> - not (hasCommentsInside cmtTbl loc) - | _ -> false - in - let rec loop props args = - match args with - | [] -> (Doc.nil, None) - | [ - (Asttypes.Labelled "children", children); - ( Asttypes.Nolabel, - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); - } ); - ] -> - let doc = if isSelfClosing children then Doc.line else Doc.nil in - (doc, Some children) - | ((_, expr) as lastProp) - :: [ - (Asttypes.Labelled "children", children); - ( Asttypes.Nolabel, - { - Parsetree.pexp_desc = - Pexp_construct ({txt = Longident.Lident "()"}, None); - } ); - ] -> - let loc = - match expr.Parsetree.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _attrs -> - {loc with loc_end = expr.pexp_loc.loc_end} - | _ -> expr.pexp_loc - in - let trailingCommentsPresent = hasTrailingComments cmtTbl loc in - let propDoc = printJsxProp ~state lastProp cmtTbl in - let formattedProps = - Doc.concat - [ - Doc.indent - (Doc.concat - [ - Doc.line; - Doc.group - (Doc.join ~sep:Doc.line (propDoc :: props |> List.rev)); - ]); - (* print > on new line if the last prop has trailing comments *) - (match (isSelfClosing children, trailingCommentsPresent) with - (* we always put /> on a new line when a self-closing tag breaks *) - | true, _ -> Doc.line - | false, true -> Doc.softLine - | false, false -> Doc.nil); - ] - in - (formattedProps, Some children) - | arg :: args -> - let propDoc = printJsxProp ~state arg cmtTbl in - loop (propDoc :: props) args - in - loop [] args - -and printJsxProp ~state arg cmtTbl = - match arg with - | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), - { - Parsetree.pexp_attributes = - [({Location.txt = "res.namedArgLoc"; loc = argLoc}, _)]; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; - } ) - when lblTxt = ident (* jsx punning *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printComments (printIdentLike ident) cmtTbl argLoc - | Optional _lbl -> - let doc = Doc.concat [Doc.question; printIdentLike ident] in - printComments doc cmtTbl argLoc) - | ( ((Asttypes.Labelled lblTxt | Optional lblTxt) as lbl), - { - Parsetree.pexp_attributes = []; - pexp_desc = Pexp_ident {txt = Longident.Lident ident}; - } ) - when lblTxt = ident (* jsx punning when printing from Reason *) -> ( - match lbl with - | Nolabel -> Doc.nil - | Labelled _lbl -> printIdentLike ident - | Optional _lbl -> Doc.concat [Doc.question; printIdentLike ident]) - | Asttypes.Labelled "_spreadProps", expr -> - let doc = printExpressionWithComments ~state expr cmtTbl in - Doc.concat [Doc.lbrace; Doc.dotdotdot; doc; Doc.rbrace] - | lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (Location.none, expr) - in - let lblDoc = - match lbl with - | Asttypes.Labelled lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal] - | Asttypes.Optional lbl -> - let lbl = printComments (printIdentLike lbl) cmtTbl argLoc in - Doc.concat [lbl; Doc.equal; Doc.question] - | Nolabel -> Doc.nil - in - let exprDoc = - let leadingLineCommentPresent = - hasLeadingLineComment cmtTbl expr.pexp_loc - in - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.jsxPropExpr expr with - | Parenthesized | Braced _ -> - (* {(20: int)} make sure that we also protect the expression inside *) - let innerDoc = if Parens.bracedExpr expr then addParens doc else doc in - if leadingLineCommentPresent then addBraces innerDoc - else Doc.concat [Doc.lbrace; innerDoc; Doc.rbrace] - | _ -> doc - in - let fullLoc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - printComments (Doc.concat [lblDoc; exprDoc]) cmtTbl fullLoc - -(* div -> div. - * Navabar.createElement -> Navbar - * Staff.Users.createElement -> Staff.Users *) -and printJsxName {txt = lident} = - let printIdent = printIdentLike ~allowUident:true ~allowHyphen:true in - let rec flatten acc lident = - match lident with - | Longident.Lident txt -> printIdent txt :: acc - | Ldot (lident, "createElement") -> flatten acc lident - | Ldot (lident, txt) -> flatten (printIdent txt :: acc) lident - | _ -> acc - in - match lident with - | Longident.Lident txt -> printIdent txt - | _ as lident -> - let segments = flatten [] lident in - Doc.join ~sep:Doc.dot segments - -and printArgumentsWithCallbackInFirstPosition ~dotted ~state args cmtTbl = - (* Because the same subtree gets printed twice, we need to copy the cmtTbl. - * consumed comments need to be marked not-consumed and reprinted… - * Cheng's different comment algorithm will solve this. *) - let state = State.nextCustomLayout state in - let cmtTblCopy = CommentTable.copy cmtTbl in - let callback, printedArgs = - match args with - | (lbl, expr) :: args -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callback = - Doc.concat - [lblDoc; printPexpFun ~state ~inCallback:FitsOnOneLine expr cmtTbl] - in - let callback = lazy (printComments callback cmtTbl expr.pexp_loc) in - let printedArgs = - lazy - (Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map (fun arg -> printArgument ~state arg cmtTbl) args)) - in - (callback, printedArgs) - | _ -> assert false - in - - (* Thing.map((arg1, arg2) => MyModuleBlah.toList(argument), foo) *) - (* Thing.map((arg1, arg2) => { - * MyModuleBlah.toList(argument) - * }, longArgumet, veryLooooongArgument) - *) - let fitsOnOneLine = - lazy - (Doc.concat - [ - (if dotted then Doc.text "(. " else Doc.lparen); - Lazy.force callback; - Doc.comma; - Doc.line; - Lazy.force printedArgs; - Doc.rparen; - ]) - in - - (* Thing.map( - * (param1, parm2) => doStuff(param1, parm2), - * arg1, - * arg2, - * arg3, - * ) - *) - let breakAllArgs = lazy (printArguments ~state ~dotted args cmtTblCopy) in - - (* Sometimes one of the non-callback arguments will break. - * There might be a single line comment in there, or a multiline string etc. - * showDialog( - * ~onConfirm={() => ()}, - * ` - * Do you really want to leave this workspace? - * Some more text with detailed explanations... - * `, - * ~danger=true, - * // comment --> here a single line comment - * ~confirmText="Yes, I am sure!", - * ) - * In this case, we always want the arguments broken over multiple lines, - * like a normal function call. - *) - if state |> State.shouldBreakCallback then Lazy.force breakAllArgs - else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else Doc.customLayout [Lazy.force fitsOnOneLine; Lazy.force breakAllArgs] - -and printArgumentsWithCallbackInLastPosition ~state ~dotted args cmtTbl = - (* Because the same subtree gets printed twice, we need to copy the cmtTbl. - * consumed comments need to be marked not-consumed and reprinted… - * Cheng's different comment algorithm will solve this. *) - let state = state |> State.nextCustomLayout in - let cmtTblCopy = CommentTable.copy cmtTbl in - let cmtTblCopy2 = CommentTable.copy cmtTbl in - let rec loop acc args = - match args with - | [] -> (lazy Doc.nil, lazy Doc.nil, lazy Doc.nil) - | [(lbl, expr)] -> - let lblDoc = - match lbl with - | Asttypes.Nolabel -> Doc.nil - | Asttypes.Labelled txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal] - | Asttypes.Optional txt -> - Doc.concat [Doc.tilde; printIdentLike txt; Doc.equal; Doc.question] - in - let callbackFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~state ~inCallback:FitsOnOneLine expr cmtTbl - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTbl expr.pexp_loc) - in - let callbackArgumentsFitsOnOneLine = - lazy - (let pexpFunDoc = - printPexpFun ~state ~inCallback:ArgumentsFitOnOneLine expr - cmtTblCopy - in - let doc = Doc.concat [lblDoc; pexpFunDoc] in - printComments doc cmtTblCopy expr.pexp_loc) - in - ( lazy (Doc.concat (List.rev acc)), - callbackFitsOnOneLine, - callbackArgumentsFitsOnOneLine ) - | arg :: args -> - let argDoc = printArgument ~state arg cmtTbl in - loop (Doc.line :: Doc.comma :: argDoc :: acc) args - in - let printedArgs, callback, callback2 = loop [] args in - - (* Thing.map(foo, (arg1, arg2) => MyModuleBlah.toList(argument)) *) - let fitsOnOneLine = - lazy - (Doc.concat - [ - (if dotted then Doc.text "(." else Doc.lparen); - Lazy.force printedArgs; - Lazy.force callback; - Doc.rparen; - ]) - in - - (* Thing.map(longArgumet, veryLooooongArgument, (arg1, arg2) => - * MyModuleBlah.toList(argument) - * ) - *) - let arugmentsFitOnOneLine = - lazy - (Doc.concat - [ - (if dotted then Doc.text "(." else Doc.lparen); - Lazy.force printedArgs; - Doc.breakableGroup ~forceBreak:true (Lazy.force callback2); - Doc.rparen; - ]) - in - - (* Thing.map( - * arg1, - * arg2, - * arg3, - * (param1, parm2) => doStuff(param1, parm2) - * ) - *) - let breakAllArgs = lazy (printArguments ~state ~dotted args cmtTblCopy2) in - - (* Sometimes one of the non-callback arguments will break. - * There might be a single line comment in there, or a multiline string etc. - * showDialog( - * ` - * Do you really want to leave this workspace? - * Some more text with detailed explanations... - * `, - * ~danger=true, - * // comment --> here a single line comment - * ~confirmText="Yes, I am sure!", - * ~onConfirm={() => ()}, - * ) - * In this case, we always want the arguments broken over multiple lines, - * like a normal function call. - *) - if state |> State.shouldBreakCallback then Lazy.force breakAllArgs - else if Doc.willBreak (Lazy.force printedArgs) then Lazy.force breakAllArgs - else - Doc.customLayout - [ - Lazy.force fitsOnOneLine; - Lazy.force arugmentsFitOnOneLine; - Lazy.force breakAllArgs; - ] - -and printArguments ~state ~dotted ?(partial = false) - (args : (Asttypes.arg_label * Parsetree.expression) list) cmtTbl = - match args with - | [ - ( Nolabel, - { - pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _); - pexp_loc = loc; - } ); - ] -> ( - (* See "parseCallExpr", ghost unit expression is used the implement - * arity zero vs arity one syntax. - * Related: https://github.com/rescript-lang/syntax/issues/138 *) - match (dotted, loc.loc_ghost) with - | true, true -> Doc.text "(.)" (* arity zero *) - | true, false -> Doc.text "(. ())" (* arity one *) - | _ -> Doc.text "()") - | [(Nolabel, arg)] when ParsetreeViewer.isHuggableExpression arg -> - let argDoc = - let doc = printExpressionWithComments ~state arg cmtTbl in - match Parens.expr arg with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc arg braces - | Nothing -> doc - in - Doc.concat - [(if dotted then Doc.text "(. " else Doc.lparen); argDoc; Doc.rparen] - | args -> - (* Avoid printing trailing comma when there is ... in function application *) - let hasPartialAttr, printedArgs = - List.fold_right - (fun arg (flag, acc) -> - let _, expr = arg in - let hasPartialAttr = - ParsetreeViewer.hasPartialAttribute expr.Parsetree.pexp_attributes - in - let doc = printArgument ~state arg cmtTbl in - (flag || hasPartialAttr, doc :: acc)) - args (false, []) - in - Doc.group - (Doc.concat - [ - (if dotted then Doc.text "(." else Doc.lparen); - Doc.indent - (Doc.concat - [ - (if dotted then Doc.line else Doc.softLine); - Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) printedArgs; - ]); - (if partial || hasPartialAttr then Doc.nil else Doc.trailingComma); - Doc.softLine; - Doc.rparen; - ]) - -(* - * argument ::= - * | _ (* syntax sugar *) - * | expr - * | expr : type - * | ~ label-name - * | ~ label-name - * | ~ label-name ? - * | ~ label-name = expr - * | ~ label-name = _ (* syntax sugar *) - * | ~ label-name = expr : type - * | ~ label-name = ? expr - * | ~ label-name = ? _ (* syntax sugar *) - * | ~ label-name = ? expr : type *) -and printArgument ~state (argLbl, arg) cmtTbl = - match (argLbl, arg) with - (* ~a (punned)*) - | ( Labelled lbl, - ({ - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "res.namedArgLoc"}, _)]; - } as argExpr) ) - when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl] in - printComments doc cmtTbl loc - (* ~a: int (punned)*) - | ( Labelled lbl, - { - pexp_desc = - Pexp_constraint - ( ({pexp_desc = Pexp_ident {txt = Longident.Lident name}} as argExpr), - typ ); - pexp_loc; - pexp_attributes = - ([] | [({Location.txt = "res.namedArgLoc"}, _)]) as attrs; - } ) - when lbl = name && not (ParsetreeViewer.isBracedExpr argExpr) -> - let loc = - match attrs with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pexp_loc.loc_end} - | _ -> arg.pexp_loc - in - let doc = - Doc.concat - [ - Doc.tilde; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~state typ cmtTbl; - ] - in - printComments doc cmtTbl loc - (* ~a? (optional lbl punned)*) - | ( Optional lbl, - { - pexp_desc = Pexp_ident {txt = Longident.Lident name}; - pexp_attributes = [] | [({Location.txt = "res.namedArgLoc"}, _)]; - } ) - when lbl = name -> - let loc = - match arg.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc - | _ -> arg.pexp_loc - in - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.question] in - printComments doc cmtTbl loc - | _lbl, expr -> - let argLoc, expr = - match expr.pexp_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: attrs -> - (loc, {expr with pexp_attributes = attrs}) - | _ -> (expr.pexp_loc, expr) - in - let printedLbl, dotdotdot = - match argLbl with - | Nolabel -> (Doc.nil, false) - | Labelled "..." -> - let doc = Doc.text "..." in - (printComments doc cmtTbl argLoc, true) - | Labelled lbl -> - let doc = Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal] in - (printComments doc cmtTbl argLoc, false) - | Optional lbl -> - let doc = - Doc.concat [Doc.tilde; printIdentLike lbl; Doc.equal; Doc.question] - in - (printComments doc cmtTbl argLoc, false) - in - let printedExpr = - let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - let loc = {argLoc with loc_end = expr.pexp_loc.loc_end} in - let doc = - if dotdotdot then printedLbl else Doc.concat [printedLbl; printedExpr] - in - printComments doc cmtTbl loc - -and printCases ~state (cases : Parsetree.case list) cmtTbl = - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.concat - [ - Doc.line; - printList - ~getLoc:(fun n -> - { - n.Parsetree.pc_lhs.ppat_loc with - loc_end = - (match ParsetreeViewer.processBracesAttr n.pc_rhs with - | None, _ -> n.pc_rhs.pexp_loc.loc_end - | Some ({loc}, _), _ -> loc.Location.loc_end); - }) - ~print:(printCase ~state) ~nodes:cases cmtTbl; - ]; - Doc.line; - Doc.rbrace; - ]) - -and printCase ~state (case : Parsetree.case) cmtTbl = - let rhs = - match case.pc_rhs.pexp_desc with - | Pexp_let _ | Pexp_letmodule _ | Pexp_letexception _ | Pexp_open _ - | Pexp_sequence _ -> - printExpressionBlock ~state - ~braces:(ParsetreeViewer.isBracedExpr case.pc_rhs) - case.pc_rhs cmtTbl - | _ -> ( - let doc = printExpressionWithComments ~state case.pc_rhs cmtTbl in - match Parens.expr case.pc_rhs with - | Parenthesized -> addParens doc - | _ -> doc) - in - - let guard = - match case.pc_guard with - | None -> Doc.nil - | Some expr -> - Doc.group - (Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~state expr cmtTbl; - ]) - in - let shouldInlineRhs = - match case.pc_rhs.pexp_desc with - | Pexp_construct ({txt = Longident.Lident ("()" | "true" | "false")}, _) - | Pexp_constant _ | Pexp_ident _ -> - true - | _ when ParsetreeViewer.isHuggableRhs case.pc_rhs -> true - | _ -> false - in - let shouldIndentPattern = - match case.pc_lhs.ppat_desc with - | Ppat_or _ -> false - | _ -> true - in - let patternDoc = - let doc = printPattern ~state case.pc_lhs cmtTbl in - match case.pc_lhs.ppat_desc with - | Ppat_constraint _ -> addParens doc - | _ -> doc - in - let content = - Doc.concat - [ - (if shouldIndentPattern then Doc.indent patternDoc else patternDoc); - Doc.indent guard; - Doc.text " =>"; - Doc.indent - (Doc.concat [(if shouldInlineRhs then Doc.space else Doc.line); rhs]); - ] - in - Doc.group (Doc.concat [Doc.text "| "; content]) - -and printExprFunParameters ~state ~inCallback ~async ~uncurried ~hasConstraint - parameters cmtTbl = - let dotted = state.uncurried_config |> Res_uncurried.getDotted ~uncurried in - match parameters with - (* let f = _ => () *) - | [ - ParsetreeViewer.Parameter - { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = {Parsetree.ppat_desc = Ppat_any; ppat_loc}; - }; - ] - when not dotted -> - let any = - let doc = if hasConstraint then Doc.text "(_)" else Doc.text "_" in - printComments doc cmtTbl ppat_loc - in - if async then addAsync any else any - (* let f = a => () *) - | [ - ParsetreeViewer.Parameter - { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = - { - Parsetree.ppat_desc = Ppat_var stringLoc; - Parsetree.ppat_attributes = attrs; - }; - }; - ] - when not dotted -> - let txtDoc = - let var = printIdentLike stringLoc.txt in - let var = - match attrs with - | [] -> if hasConstraint then addParens var else var - | attrs -> - let attrs = printAttributes ~state attrs cmtTbl in - addParens (Doc.concat [attrs; var]) - in - if async then addAsync var else var - in - printComments txtDoc cmtTbl stringLoc.loc - (* let f = () => () *) - | [ - ParsetreeViewer.Parameter - { - attrs = []; - lbl = Asttypes.Nolabel; - defaultExpr = None; - pat = - {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; - }; - ] - when not dotted -> - let doc = - let lparenRparen = Doc.text "()" in - if async then addAsync lparenRparen else lparenRparen - in - printComments doc cmtTbl loc - (* let f = (~greeting, ~from as hometown, ~x=?) => () *) - | parameters -> - let inCallback = - match inCallback with - | FitsOnOneLine -> true - | _ -> false - in - let maybeAsyncLparen = - let lparen = if dotted then Doc.text "(. " else Doc.lparen in - if async then addAsync lparen else lparen - in - let shouldHug = ParsetreeViewer.parametersShouldHug parameters in - let printedParamaters = - Doc.concat - [ - (if shouldHug || inCallback then Doc.nil else Doc.softLine); - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun p -> printExpFunParameter ~state p cmtTbl) - parameters); - ] - in - Doc.group - (Doc.concat - [ - maybeAsyncLparen; - (if shouldHug || inCallback then printedParamaters - else - Doc.concat - [Doc.indent printedParamaters; Doc.trailingComma; Doc.softLine]); - Doc.rparen; - ]) - -and printExpFunParameter ~state parameter cmtTbl = - match parameter with - | ParsetreeViewer.NewTypes {attrs; locs = lbls} -> - Doc.group - (Doc.concat - [ - printAttributes ~state attrs cmtTbl; - Doc.text "type "; - (* XX *) - Doc.join ~sep:Doc.space - (List.map - (fun lbl -> - printComments - (printIdentLike lbl.Asttypes.txt) - cmtTbl lbl.Asttypes.loc) - lbls); - ]) - | Parameter {attrs; lbl; defaultExpr; pat = pattern} -> - let hasBs, attrs = ParsetreeViewer.processBsAttribute attrs in - let dotted = if hasBs then Doc.concat [Doc.dot; Doc.space] else Doc.nil in - let attrs = printAttributes ~state attrs cmtTbl in - (* =defaultValue *) - let defaultExprDoc = - match defaultExpr with - | Some expr -> - Doc.concat - [Doc.text "="; printExpressionWithComments ~state expr cmtTbl] - | None -> Doc.nil - in - (* ~from as hometown - * ~from -> punning *) - let labelWithPattern = - match (lbl, pattern) with - | Asttypes.Nolabel, pattern -> printPattern ~state pattern cmtTbl - | ( (Asttypes.Labelled lbl | Optional lbl), - {ppat_desc = Ppat_var stringLoc; ppat_attributes} ) - when lbl = stringLoc.txt -> - (* ~d *) - Doc.concat - [ - printAttributes ~state ppat_attributes cmtTbl; - Doc.text "~"; - printIdentLike lbl; - ] - | ( (Asttypes.Labelled lbl | Optional lbl), - { - ppat_desc = Ppat_constraint ({ppat_desc = Ppat_var {txt}}, typ); - ppat_attributes; - } ) - when lbl = txt -> - (* ~d: e *) - Doc.concat - [ - printAttributes ~state ppat_attributes cmtTbl; - Doc.text "~"; - printIdentLike lbl; - Doc.text ": "; - printTypExpr ~state typ cmtTbl; - ] - | (Asttypes.Labelled lbl | Optional lbl), pattern -> - (* ~b as c *) - Doc.concat - [ - Doc.text "~"; - printIdentLike lbl; - Doc.text " as "; - printPattern ~state pattern cmtTbl; - ] - in - let optionalLabelSuffix = - match (lbl, defaultExpr) with - | Asttypes.Optional _, None -> Doc.text "=?" - | _ -> Doc.nil - in - let doc = - Doc.group - (Doc.concat - [ - dotted; attrs; labelWithPattern; defaultExprDoc; optionalLabelSuffix; - ]) - in - let cmtLoc = - match defaultExpr with - | None -> ( - match pattern.ppat_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> - {loc with loc_end = pattern.ppat_loc.loc_end} - | _ -> pattern.ppat_loc) - | Some expr -> - let startPos = - match pattern.ppat_attributes with - | ({Location.txt = "res.namedArgLoc"; loc}, _) :: _ -> loc.loc_start - | _ -> pattern.ppat_loc.loc_start - in - { - pattern.ppat_loc with - loc_start = startPos; - loc_end = expr.pexp_loc.loc_end; - } - in - printComments doc cmtTbl cmtLoc - -and printExpressionBlock ~state ~braces expr cmtTbl = - let rec collectRows acc expr = - match expr.Parsetree.pexp_desc with - | Parsetree.Pexp_letmodule (modName, modExpr, expr2) -> - let name = - let doc = Doc.text modName.txt in - printComments doc cmtTbl modName.loc - in - let name, modExpr = - match modExpr.pmod_desc with - | Pmod_constraint (modExpr2, modType) - when not (ParsetreeViewer.hasAwaitAttribute modExpr.pmod_attributes) - -> - let name = - Doc.concat [name; Doc.text ": "; printModType ~state modType cmtTbl] - in - (name, modExpr2) - | _ -> (name, modExpr) - in - let letModuleDoc = - Doc.concat - [ - Doc.text "module "; - name; - Doc.text " = "; - printModExpr ~state modExpr cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = modExpr.pmod_loc.loc_end} in - collectRows ((loc, letModuleDoc) :: acc) expr2 - | Pexp_letexception (extensionConstructor, expr2) -> - let loc = - let loc = - {expr.pexp_loc with loc_end = extensionConstructor.pext_loc.loc_end} - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let letExceptionDoc = - printExceptionDef ~state extensionConstructor cmtTbl - in - collectRows ((loc, letExceptionDoc) :: acc) expr2 - | Pexp_open (overrideFlag, longidentLoc, expr2) -> - let openDoc = - Doc.concat - [ - Doc.text "open"; - printOverrideFlag overrideFlag; - Doc.space; - printLongidentLocation longidentLoc cmtTbl; - ] - in - let loc = {expr.pexp_loc with loc_end = longidentLoc.loc.loc_end} in - collectRows ((loc, openDoc) :: acc) expr2 - | Pexp_sequence (expr1, expr2) -> - let exprDoc = - let doc = printExpression ~state expr1 cmtTbl in - match Parens.expr expr1 with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr1 braces - | Nothing -> doc - in - let loc = expr1.pexp_loc in - collectRows ((loc, exprDoc) :: acc) expr2 - | Pexp_let (recFlag, valueBindings, expr2) -> ( - let loc = - let loc = - match (valueBindings, List.rev valueBindings) with - | vb :: _, lastVb :: _ -> - {vb.pvb_loc with loc_end = lastVb.pvb_loc.loc_end} - | _ -> Location.none - in - match getFirstLeadingComment cmtTbl loc with - | None -> loc - | Some comment -> - let cmtLoc = Comment.loc comment in - {cmtLoc with loc_end = loc.loc_end} - in - let recFlag = - match recFlag with - | Asttypes.Nonrecursive -> Doc.nil - | Asttypes.Recursive -> Doc.text "rec " - in - let letDoc = printValueBindings ~state ~recFlag valueBindings cmtTbl in - (* let () = { - * let () = foo() - * () - * } - * We don't need to print the () on the last line of the block - *) - match expr2.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "()"}, _) -> - List.rev ((loc, letDoc) :: acc) - | _ -> collectRows ((loc, letDoc) :: acc) expr2) - | _ -> - let exprDoc = - let doc = printExpression ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc - in - List.rev ((expr.pexp_loc, exprDoc) :: acc) - in - let rows = collectRows [] expr in - let block = - printList ~getLoc:fst ~nodes:rows - ~print:(fun (_, doc) _ -> doc) - ~forceBreak:true cmtTbl - in - Doc.breakableGroup ~forceBreak:true - (if braces then - Doc.concat - [ - Doc.lbrace; - Doc.indent (Doc.concat [Doc.line; block]); - Doc.line; - Doc.rbrace; - ] - else block) - -(* - * // user types: - * let f = (a, b) => { a + b } - * - * // printer: everything is on one line - * let f = (a, b) => { a + b } - * - * // user types: over multiple lines - * let f = (a, b) => { - * a + b - * } - * - * // printer: over multiple lines - * let f = (a, b) => { - * a + b - * } - *) -and printBraces doc expr bracesLoc = - let overMultipleLines = - let open Location in - bracesLoc.loc_end.pos_lnum > bracesLoc.loc_start.pos_lnum - in - match expr.Parsetree.pexp_desc with - | Pexp_letmodule _ | Pexp_letexception _ | Pexp_let _ | Pexp_open _ - | Pexp_sequence _ -> - (* already has braces *) - doc - | _ -> - Doc.breakableGroup ~forceBreak:overMultipleLines - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [ - Doc.softLine; - (if Parens.bracedExpr expr then addParens doc else doc); - ]); - Doc.softLine; - Doc.rbrace; - ]) - -and printOverrideFlag overrideFlag = - match overrideFlag with - | Asttypes.Override -> Doc.text "!" - | Fresh -> Doc.nil - -and printDirectionFlag flag = - match flag with - | Asttypes.Downto -> Doc.text " downto " - | Asttypes.Upto -> Doc.text " to " - -and printExpressionRecordRow ~state (lbl, expr) cmtTbl punningAllowed = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in - let doc = - Doc.group - (match expr.pexp_desc with - | Pexp_ident {txt = Lident key; loc = _keyLoc} - when punningAllowed && Longident.last lbl.txt = key -> - (* print punned field *) - Doc.concat - [ - printAttributes ~state expr.pexp_attributes cmtTbl; - printOptionalLabel expr.pexp_attributes; - printLidentPath lbl cmtTbl; - ] - | _ -> - Doc.concat - [ - printLidentPath lbl cmtTbl; - Doc.text ": "; - printOptionalLabel expr.pexp_attributes; - (let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.exprRecordRowRhs expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ]) - in - printComments doc cmtTbl cmtLoc - -and printBsObjectRow ~state (lbl, expr) cmtTbl = - let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in - let lblDoc = - let doc = - Doc.concat [Doc.text "\""; printLongident lbl.txt; Doc.text "\""] - in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.concat - [ - lblDoc; - Doc.text ": "; - (let doc = printExpressionWithComments ~state expr cmtTbl in - match Parens.expr expr with - | Parens.Parenthesized -> addParens doc - | Braced braces -> printBraces doc expr braces - | Nothing -> doc); - ] - in - printComments doc cmtTbl cmtLoc - -(* The optional loc indicates whether we need to print the attributes in - * relation to some location. In practise this means the following: - * `@attr type t = string` -> on the same line, print on the same line - * `@attr - * type t = string` -> attr is on prev line, print the attributes - * with a line break between, we respect the users' original layout *) -and printAttributes ?loc ?(inline = false) ~state (attrs : Parsetree.attributes) - cmtTbl = - match ParsetreeViewer.filterParsingAttrs attrs with - | [] -> Doc.nil - | attrs -> - let lineBreak = - match loc with - | None -> Doc.line - | Some loc -> ( - match List.rev attrs with - | ({loc = firstLoc}, _) :: _ - when loc.loc_start.pos_lnum > firstLoc.loc_end.pos_lnum -> - Doc.hardLine - | _ -> Doc.line) - in - Doc.concat - [ - Doc.group - (Doc.joinWithSep - (List.map (fun attr -> printAttribute ~state attr cmtTbl) attrs)); - (if inline then Doc.space else lineBreak); - ] - -and printPayload ~state (payload : Parsetree.payload) cmtTbl = - match payload with - | PStr [] -> Doc.nil - | PStr [{pstr_desc = Pstr_eval (expr, attrs)}] -> - let exprDoc = printExpressionWithComments ~state expr cmtTbl in - let needsParens = - match attrs with - | [] -> false - | _ -> true - in - let shouldHug = ParsetreeViewer.isHuggableExpression expr in - if shouldHug then - Doc.concat - [ - Doc.lparen; - printAttributes ~state attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - Doc.rparen; - ] - else - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - printAttributes ~state attrs cmtTbl; - (if needsParens then addParens exprDoc else exprDoc); - ]); - Doc.softLine; - Doc.rparen; - ] - | PStr [({pstr_desc = Pstr_value (_recFlag, _bindings)} as si)] -> - addParens (printStructureItem ~state si cmtTbl) - | PStr structure -> addParens (printStructure ~state structure cmtTbl) - | PTyp typ -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent (Doc.concat [Doc.line; printTypExpr ~state typ cmtTbl]); - Doc.softLine; - Doc.rparen; - ] - | PPat (pat, optExpr) -> - let whenDoc = - match optExpr with - | Some expr -> - Doc.concat - [ - Doc.line; - Doc.text "if "; - printExpressionWithComments ~state expr cmtTbl; - ] - | None -> Doc.nil - in - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.text "? "; - printPattern ~state pat cmtTbl; - whenDoc; - ]); - Doc.softLine; - Doc.rparen; - ] - | PSig signature -> - Doc.concat - [ - Doc.lparen; - Doc.text ":"; - Doc.indent - (Doc.concat [Doc.line; printSignature ~state signature cmtTbl]); - Doc.softLine; - Doc.rparen; - ] - -and printAttribute ?(standalone = false) ~state - ((id, payload) : Parsetree.attribute) cmtTbl = - match (id, payload) with - | ( {txt = "res.doc"}, - PStr - [ - { - pstr_desc = - Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (txt, _))}, _); - }; - ] ) -> - ( Doc.concat - [ - Doc.text (if standalone then "/***" else "/**"); - Doc.text txt; - Doc.text "*/"; - ], - Doc.hardLine ) - | _ -> - let id = - match id.txt with - | "uncurried.swap" -> - state.uncurried_config <- Config.Swap; - id - | "uncurried" -> - state.uncurried_config <- Config.Uncurried; - id - | _ -> id - in - ( Doc.group - (Doc.concat - [ - Doc.text (if standalone then "@@" else "@"); - Doc.text (convertBsExternalAttribute id.txt); - printPayload ~state payload cmtTbl; - ]), - Doc.line ) - -and printModExpr ~state modExpr cmtTbl = - let doc = - match modExpr.pmod_desc with - | Pmod_ident longidentLoc -> printLongidentLocation longidentLoc cmtTbl - | Pmod_structure [] -> - let shouldBreak = - modExpr.pmod_loc.loc_start.pos_lnum < modExpr.pmod_loc.loc_end.pos_lnum - in - Doc.breakableGroup ~forceBreak:shouldBreak - (Doc.concat - [Doc.lbrace; printCommentsInside cmtTbl modExpr.pmod_loc; Doc.rbrace]) - | Pmod_structure structure -> - Doc.breakableGroup ~forceBreak:true - (Doc.concat - [ - Doc.lbrace; - Doc.indent - (Doc.concat - [Doc.softLine; printStructure ~state structure cmtTbl]); - Doc.softLine; - Doc.rbrace; - ]) - | Pmod_unpack expr -> - let shouldHug = - match expr.pexp_desc with - | Pexp_let _ -> true - | Pexp_constraint - ({pexp_desc = Pexp_let _}, {ptyp_desc = Ptyp_package _packageType}) - -> - true - | _ -> false - in - let expr, moduleConstraint = - match expr.pexp_desc with - | Pexp_constraint - (expr, {ptyp_desc = Ptyp_package packageType; ptyp_loc}) -> - let packageDoc = - let doc = - printPackageType ~state ~printModuleKeywordAndParens:false - packageType cmtTbl - in - printComments doc cmtTbl ptyp_loc - in - let typeDoc = - Doc.group - (Doc.concat - [Doc.text ":"; Doc.indent (Doc.concat [Doc.line; packageDoc])]) - in - (expr, typeDoc) - | _ -> (expr, Doc.nil) - in - let unpackDoc = - Doc.group - (Doc.concat - [printExpressionWithComments ~state expr cmtTbl; moduleConstraint]) - in - Doc.group - (Doc.concat - [ - Doc.text "unpack("; - (if shouldHug then unpackDoc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.softLine; unpackDoc]); - Doc.softLine; - ]); - Doc.rparen; - ]) - | Pmod_extension extension -> - printExtension ~state ~atModuleLvl:false extension cmtTbl - | Pmod_apply _ -> - let args, callExpr = ParsetreeViewer.modExprApply modExpr in - let isUnitSugar = - match args with - | [{pmod_desc = Pmod_structure []}] -> true - | _ -> false - in - let shouldHug = - match args with - | [{pmod_desc = Pmod_structure _}] -> true - | _ -> false - in - Doc.group - (Doc.concat - [ - printModExpr ~state callExpr cmtTbl; - (if isUnitSugar then - printModApplyArg ~state (List.hd args [@doesNotRaise]) cmtTbl - else - Doc.concat - [ - Doc.lparen; - (if shouldHug then - printModApplyArg ~state - (List.hd args [@doesNotRaise]) - cmtTbl - else - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun modArg -> - printModApplyArg ~state modArg cmtTbl) - args); - ])); - (if not shouldHug then - Doc.concat [Doc.trailingComma; Doc.softLine] - else Doc.nil); - Doc.rparen; - ]); - ]) - | Pmod_constraint (modExpr, modType) -> - Doc.concat - [ - printModExpr ~state modExpr cmtTbl; - Doc.text ": "; - printModType ~state modType cmtTbl; - ] - | Pmod_functor _ -> printModFunctor ~state modExpr cmtTbl - in - let doc = - if ParsetreeViewer.hasAwaitAttribute modExpr.pmod_attributes then - match modExpr.pmod_desc with - | Pmod_constraint _ -> - Doc.concat [Doc.text "await "; Doc.lparen; doc; Doc.rparen] - | _ -> Doc.concat [Doc.text "await "; doc] - else doc - in - printComments doc cmtTbl modExpr.pmod_loc - -and printModFunctor ~state modExpr cmtTbl = - let parameters, returnModExpr = ParsetreeViewer.modExprFunctor modExpr in - (* let shouldInline = match returnModExpr.pmod_desc with *) - (* | Pmod_structure _ | Pmod_ident _ -> true *) - (* | Pmod_constraint ({pmod_desc = Pmod_structure _}, _) -> true *) - (* | _ -> false *) - (* in *) - let returnConstraint, returnModExpr = - match returnModExpr.pmod_desc with - | Pmod_constraint (modExpr, modType) -> - let constraintDoc = - let doc = printModType ~state modType cmtTbl in - if Parens.modExprFunctorConstraint modType then addParens doc else doc - in - let modConstraint = Doc.concat [Doc.text ": "; constraintDoc] in - (modConstraint, printModExpr ~state modExpr cmtTbl) - | _ -> (Doc.nil, printModExpr ~state returnModExpr cmtTbl) - in - let parametersDoc = - match parameters with - | [(attrs, {txt = "*"}, None)] -> - Doc.group - (Doc.concat [printAttributes ~state attrs cmtTbl; Doc.text "()"]) - | [([], {txt = lbl}, None)] -> Doc.text lbl - | parameters -> - Doc.group - (Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.softLine; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun param -> printModFunctorParam ~state param cmtTbl) - parameters); - ]); - Doc.trailingComma; - Doc.softLine; - Doc.rparen; - ]) - in - Doc.group - (Doc.concat - [parametersDoc; returnConstraint; Doc.text " => "; returnModExpr]) - -and printModFunctorParam ~state (attrs, lbl, optModType) cmtTbl = - let cmtLoc = - match optModType with - | None -> lbl.Asttypes.loc - | Some modType -> - {lbl.loc with loc_end = modType.Parsetree.pmty_loc.loc_end} - in - let attrs = printAttributes ~state attrs cmtTbl in - let lblDoc = - let doc = if lbl.txt = "*" then Doc.text "()" else Doc.text lbl.txt in - printComments doc cmtTbl lbl.loc - in - let doc = - Doc.group - (Doc.concat - [ - attrs; - lblDoc; - (match optModType with - | None -> Doc.nil - | Some modType -> - Doc.concat [Doc.text ": "; printModType ~state modType cmtTbl]); - ]) - in - printComments doc cmtTbl cmtLoc - -and printModApplyArg ~state modExpr cmtTbl = - match modExpr.pmod_desc with - | Pmod_structure [] -> Doc.text "()" - | _ -> printModExpr ~state modExpr cmtTbl - -and printExceptionDef ~state (constr : Parsetree.extension_constructor) cmtTbl = - let kind = - match constr.pext_kind with - | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) - | Pext_decl (Pcstr_tuple [], None) -> Doc.nil - | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [printConstructorArguments ~state ~indent:false args cmtTbl; gadtDoc] - in - let name = - printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc - in - let doc = - Doc.group - (Doc.concat - [ - printAttributes ~state constr.pext_attributes cmtTbl; - Doc.text "exception "; - name; - kind; - ]) - in - printComments doc cmtTbl constr.pext_loc - -and printExtensionConstructor ~state (constr : Parsetree.extension_constructor) - cmtTbl i = - let attrs = printAttributes ~state constr.pext_attributes cmtTbl in - let bar = - if i > 0 then Doc.text "| " else Doc.ifBreaks (Doc.text "| ") Doc.nil - in - let kind = - match constr.pext_kind with - | Pext_rebind longident -> - Doc.indent - (Doc.concat - [Doc.text " ="; Doc.line; printLongidentLocation longident cmtTbl]) - | Pext_decl (Pcstr_tuple [], None) -> Doc.nil - | Pext_decl (args, gadt) -> - let gadtDoc = - match gadt with - | Some typ -> Doc.concat [Doc.text ": "; printTypExpr ~state typ cmtTbl] - | None -> Doc.nil - in - Doc.concat - [printConstructorArguments ~state ~indent:false args cmtTbl; gadtDoc] - in - let name = - printComments (Doc.text constr.pext_name.txt) cmtTbl constr.pext_name.loc - in - Doc.concat [bar; Doc.group (Doc.concat [attrs; name; kind])] - -let printTypeParams params = printTypeParams ~state:(State.init ()) params -let printTypExpr t = printTypExpr ~state:(State.init ()) t -let printExpression e = printExpression ~state:(State.init ()) e -let printPattern p = printPattern ~state:(State.init ()) p - -let printImplementation ~width (s : Parsetree.structure) ~comments = - let cmtTbl = CommentTable.make () in - CommentTable.walkStructure s cmtTbl comments; - (* CommentTable.log cmtTbl; *) - let doc = printStructure ~state:(State.init ()) s cmtTbl in - (* Doc.debug doc; *) - Doc.toString ~width doc ^ "\n" - -let printInterface ~width (s : Parsetree.signature) ~comments = - let cmtTbl = CommentTable.make () in - CommentTable.walkSignature s cmtTbl comments; - Doc.toString ~width (printSignature ~state:(State.init ()) s cmtTbl) ^ "\n" - -let printStructure = printStructure ~state:(State.init ()) diff --git a/jscomp/syntax/src/res_printer.mli b/jscomp/syntax/src/res_printer.mli deleted file mode 100644 index 3647dc3..0000000 --- a/jscomp/syntax/src/res_printer.mli +++ /dev/null @@ -1,28 +0,0 @@ -val convertBsExternalAttribute : string -> string -val convertBsExtension : string -> string - -val printTypeParams : - (Parsetree.core_type * Asttypes.variance) list -> - Res_comments_table.t -> - Res_doc.t - -val printLongident : Longident.t -> Res_doc.t - -val printTypExpr : Parsetree.core_type -> Res_comments_table.t -> Res_doc.t - -val addParens : Res_doc.t -> Res_doc.t - -val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t - -val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t -[@@live] - -val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t -[@@live] - -val printImplementation : - width:int -> Parsetree.structure -> comments:Res_comment.t list -> string -val printInterface : - width:int -> Parsetree.signature -> comments:Res_comment.t list -> string - -val polyVarIdentToString : string -> string [@@live] diff --git a/jscomp/syntax/src/res_scanner.ml b/jscomp/syntax/src/res_scanner.ml deleted file mode 100644 index 40d7590..0000000 --- a/jscomp/syntax/src/res_scanner.ml +++ /dev/null @@ -1,948 +0,0 @@ -module Diagnostics = Res_diagnostics -module Token = Res_token -module Comment = Res_comment - -type mode = Jsx | Diamond - -(* We hide the implementation detail of the scanner reading character. Our char - will also contain the special -1 value to indicate end-of-file. This isn't - ideal; we should clean this up *) -let hackyEOFChar = Char.unsafe_chr (-1) -type charEncoding = Char.t - -type t = { - filename: string; - src: string; - mutable err: - startPos:Lexing.position -> - endPos:Lexing.position -> - Diagnostics.category -> - unit; - mutable ch: charEncoding; (* current character *) - mutable offset: int; (* current byte offset *) - mutable offset16: int; - (* current number of utf16 code units since line start *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; -} - -let setDiamondMode scanner = scanner.mode <- Diamond :: scanner.mode - -let setJsxMode scanner = scanner.mode <- Jsx :: scanner.mode - -let popMode scanner mode = - match scanner.mode with - | m :: ms when m = mode -> scanner.mode <- ms - | _ -> () - -let inDiamondMode scanner = - match scanner.mode with - | Diamond :: _ -> true - | _ -> false - -let inJsxMode scanner = - match scanner.mode with - | Jsx :: _ -> true - | _ -> false - -let position scanner = - Lexing. - { - pos_fname = scanner.filename; - (* line number *) - pos_lnum = scanner.lnum; - (* offset of the beginning of the line (number - of bytes between the beginning of the scanner and the beginning - of the line) *) - pos_bol = scanner.lineOffset; - (* [pos_cnum - pos_bol] is the number of utf16 code units since line start *) - pos_cnum = scanner.lineOffset + scanner.offset16; - } - -(* Small debugging util - ❯ echo 'let msg = "hello"' | ./lib/rescript.exe - let msg = "hello" - ^-^ let 0-3 - let msg = "hello" - ^-^ msg 4-7 - let msg = "hello" - ^ = 8-9 - let msg = "hello" - ^-----^ string "hello" 10-17 - let msg = "hello" - ^ eof 18-18 - let msg = "hello" -*) -let _printDebug ~startPos ~endPos scanner token = - let open Lexing in - print_string scanner.src; - print_string ((String.make [@doesNotRaise]) startPos.pos_cnum ' '); - print_char '^'; - (match endPos.pos_cnum - startPos.pos_cnum with - | 0 -> if token = Token.Eof then () else assert false - | 1 -> () - | n -> - print_string ((String.make [@doesNotRaise]) (n - 2) '-'); - print_char '^'); - print_char ' '; - print_string (Res_token.toString token); - print_char ' '; - print_int startPos.pos_cnum; - print_char '-'; - print_int endPos.pos_cnum; - print_endline "" -[@@live] - -let next scanner = - let nextOffset = scanner.offset + 1 in - let utf16len = - match Ext_utf8.classify scanner.ch with - | Single _ | Invalid -> 1 - | Leading (n, _) -> ( (((n + 1) / 2) [@doesNotRaise])) - | Cont _ -> 0 - in - let newline = - scanner.ch = '\n' - (* What about CRLF (\r + \n) on windows? - \r\n will always be terminated by a \n - -> we can just bump the line count on \n *) - in - if newline then ( - scanner.lineOffset <- nextOffset; - scanner.offset16 <- 0; - scanner.lnum <- scanner.lnum + 1) - else scanner.offset16 <- scanner.offset16 + utf16len; - if nextOffset < String.length scanner.src then ( - scanner.offset <- nextOffset; - scanner.ch <- String.unsafe_get scanner.src nextOffset) - else ( - scanner.offset <- String.length scanner.src; - scanner.offset16 <- scanner.offset - scanner.lineOffset; - scanner.ch <- hackyEOFChar) - -let next2 scanner = - next scanner; - next scanner - -let next3 scanner = - next scanner; - next scanner; - next scanner - -let peek scanner = - if scanner.offset + 1 < String.length scanner.src then - String.unsafe_get scanner.src (scanner.offset + 1) - else hackyEOFChar - -let peek2 scanner = - if scanner.offset + 2 < String.length scanner.src then - String.unsafe_get scanner.src (scanner.offset + 2) - else hackyEOFChar - -let peek3 scanner = - if scanner.offset + 3 < String.length scanner.src then - String.unsafe_get scanner.src (scanner.offset + 3) - else hackyEOFChar - -let make ~filename src = - { - filename; - src; - err = (fun ~startPos:_ ~endPos:_ _ -> ()); - ch = (if src = "" then hackyEOFChar else String.unsafe_get src 0); - offset = 0; - offset16 = 0; - lineOffset = 0; - lnum = 1; - mode = []; - } - -(* generic helpers *) - -let isWhitespace ch = - match ch with - | ' ' | '\t' | '\n' | '\r' -> true - | _ -> false - -let rec skipWhitespace scanner = - if isWhitespace scanner.ch then ( - next scanner; - skipWhitespace scanner) - -let digitValue ch = - match ch with - | '0' .. '9' -> Char.code ch - 48 - | 'a' .. 'f' -> Char.code ch - Char.code 'a' + 10 - | 'A' .. 'F' -> Char.code ch + 32 - Char.code 'a' + 10 - | _ -> 16 (* larger than any legal value *) - -(* scanning helpers *) - -let scanIdentifier scanner = - let startOff = scanner.offset in - let rec skipGoodChars scanner = - match (scanner.ch, inJsxMode scanner) with - | ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\''), false -> - next scanner; - skipGoodChars scanner - | ('A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' | '-'), true -> - next scanner; - skipGoodChars scanner - | _ -> () - in - skipGoodChars scanner; - let str = - (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) - in - if '{' == scanner.ch && str = "list" then ( - next scanner; - (* TODO: this isn't great *) - Token.lookupKeyword "list{") - else Token.lookupKeyword str - -let scanDigits scanner ~base = - if base <= 10 then - let rec loop scanner = - match scanner.ch with - | '0' .. '9' | '_' -> - next scanner; - loop scanner - | _ -> () - in - loop scanner - else - let rec loop scanner = - match scanner.ch with - (* hex *) - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' | '_' -> - next scanner; - loop scanner - | _ -> () - in - loop scanner - -(* float: (0…9) { 0…9∣ _ } [. { 0…9∣ _ }] [(e∣ E) [+∣ -] (0…9) { 0…9∣ _ }] *) -let scanNumber scanner = - let startOff = scanner.offset in - - (* integer part *) - let base = - match scanner.ch with - | '0' -> ( - match peek scanner with - | 'x' | 'X' -> - next2 scanner; - 16 - | 'o' | 'O' -> - next2 scanner; - 8 - | 'b' | 'B' -> - next2 scanner; - 2 - | _ -> - next scanner; - 8) - | _ -> 10 - in - scanDigits scanner ~base; - - (* *) - let isFloat = - if '.' == scanner.ch then ( - next scanner; - scanDigits scanner ~base; - true) - else false - in - - (* exponent part *) - let isFloat = - match scanner.ch with - | 'e' | 'E' | 'p' | 'P' -> - (match peek scanner with - | '+' | '-' -> next2 scanner - | _ -> next scanner); - scanDigits scanner ~base; - true - | _ -> isFloat - in - let literal = - (String.sub [@doesNotRaise]) scanner.src startOff (scanner.offset - startOff) - in - - (* suffix *) - let suffix = - match scanner.ch with - | ('g' .. 'z' | 'G' .. 'Z') as ch -> - next scanner; - Some ch - | _ -> None - in - if isFloat then Token.Float {f = literal; suffix} - else Token.Int {i = literal; suffix} - -let scanExoticIdentifier scanner = - (* TODO: are we disregarding the current char...? Should be a quote *) - next scanner; - let buffer = Buffer.create 20 in - let startPos = position scanner in - - let rec scan () = - match scanner.ch with - | '"' -> next scanner - | '\n' | '\r' -> - (* line break *) - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "A quoted identifier can't contain line breaks."); - next scanner - | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos - (Diagnostics.message "Did you forget a \" here?") - | ch -> - Buffer.add_char buffer ch; - next scanner; - scan () - in - scan (); - (* TODO: do we really need to create a new buffer instead of substring once? *) - Token.Lident (Buffer.contents buffer) - -let scanStringEscapeSequence ~startPos scanner = - let scan ~n ~base ~max = - let rec loop n x = - if n == 0 then x - else - let d = digitValue scanner.ch in - if d >= base then ( - let pos = position scanner in - let msg = - if scanner.ch == hackyEOFChar then "unclosed escape sequence" - else "unknown escape sequence" - in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg); - -1) - else - let () = next scanner in - loop (n - 1) ((x * base) + d) - in - let x = loop n 0 in - if x > max || (0xD800 <= x && x < 0xE000) then - let pos = position scanner in - let msg = "escape sequence is invalid unicode code point" in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) - in - match scanner.ch with - (* \ already consumed *) - | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> next scanner - | '0' - when let c = peek scanner in - c < '0' || c > '9' -> - (* Allow \0 *) - next scanner - | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 - | 'x' -> - (* hex *) - next scanner; - scan ~n:2 ~base:16 ~max:255 - | 'u' -> ( - next scanner; - match scanner.ch with - | '{' -> ( - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) - next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - match scanner.ch with - | '}' -> next scanner - | _ -> ()) - | _ -> scan ~n:4 ~base:16 ~max:Res_utf8.max) - | _ -> - (* unknown escape sequence - * TODO: we should warn the user here. Let's not make it a hard error for now, for reason compat *) - (* - let pos = position scanner in - let msg = - if ch == -1 then "unclosed escape sequence" - else "unknown escape sequence" - in - scanner.err ~startPos ~endPos:pos (Diagnostics.message msg) - *) - () - -let scanString scanner = - (* assumption: we've just matched a quote *) - let startPosWithQuote = position scanner in - next scanner; - - (* If the text needs changing, a buffer is used *) - let buf = Buffer.create 0 in - let firstCharOffset = scanner.offset in - let lastOffsetInBuf = ref firstCharOffset in - - let bringBufUpToDate ~startOffset = - let strUpToNow = - (String.sub scanner.src !lastOffsetInBuf - (startOffset - !lastOffsetInBuf) [@doesNotRaise]) - in - Buffer.add_string buf strUpToNow; - lastOffsetInBuf := startOffset - in - - let result ~firstCharOffset ~lastCharOffset = - if Buffer.length buf = 0 then - (String.sub [@doesNotRaise]) scanner.src firstCharOffset - (lastCharOffset - firstCharOffset) - else ( - bringBufUpToDate ~startOffset:lastCharOffset; - Buffer.contents buf) - in - - let rec scan () = - match scanner.ch with - | '"' -> - let lastCharOffset = scanner.offset in - next scanner; - result ~firstCharOffset ~lastCharOffset - | '\\' -> - let startPos = position scanner in - let startOffset = scanner.offset + 1 in - next scanner; - scanStringEscapeSequence ~startPos scanner; - let endOffset = scanner.offset in - convertOctalToHex ~startOffset ~endOffset - | ch when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; - let lastCharOffset = scanner.offset in - result ~firstCharOffset ~lastCharOffset - | _ -> - next scanner; - scan () - and convertOctalToHex ~startOffset ~endOffset = - let len = endOffset - startOffset in - let isDigit = function - | '0' .. '9' -> true - | _ -> false - in - let txt = scanner.src in - let isNumericEscape = - len = 3 - && (isDigit txt.[startOffset] [@doesNotRaise]) - && (isDigit txt.[startOffset + 1] [@doesNotRaise]) - && (isDigit txt.[startOffset + 2] [@doesNotRaise]) - in - if isNumericEscape then ( - let strDecimal = (String.sub txt startOffset 3 [@doesNotRaise]) in - bringBufUpToDate ~startOffset; - let strHex = Res_string.convertDecimalToHex ~strDecimal in - lastOffsetInBuf := startOffset + 3; - Buffer.add_string buf strHex; - scan ()) - else scan () - in - Token.String (scan ()) - -let scanEscape scanner = - (* '\' consumed *) - let offset = scanner.offset - 1 in - let convertNumber scanner ~n ~base = - let x = ref 0 in - for _ = n downto 1 do - let d = digitValue scanner.ch in - x := (!x * base) + d; - next scanner - done; - let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl - in - let codepoint = - match scanner.ch with - | '0' .. '9' -> convertNumber scanner ~n:3 ~base:10 - | 'b' -> - next scanner; - 8 - | 'n' -> - next scanner; - 10 - | 'r' -> - next scanner; - 13 - | 't' -> - next scanner; - 009 - | 'x' -> - next scanner; - convertNumber scanner ~n:2 ~base:16 - | 'o' -> - next scanner; - convertNumber scanner ~n:3 ~base:8 - | 'u' -> ( - next scanner; - match scanner.ch with - | '{' -> - (* unicode code point escape sequence: '\u{7A}', one or more hex digits *) - next scanner; - let x = ref 0 in - while - match scanner.ch with - | '0' .. '9' | 'a' .. 'f' | 'A' .. 'F' -> true - | _ -> false - do - x := (!x * 16) + digitValue scanner.ch; - next scanner - done; - (* consume '}' in '\u{7A}' *) - (match scanner.ch with - | '}' -> next scanner - | _ -> ()); - let c = !x in - if Res_utf8.isValidCodePoint c then c else Res_utf8.repl - | _ -> - (* unicode escape sequence: '\u007A', exactly 4 hex digits *) - convertNumber scanner ~n:4 ~base:16) - | ch -> - next scanner; - Char.code ch - in - let contents = - (String.sub [@doesNotRaise]) scanner.src offset (scanner.offset - offset) - in - next scanner; - (* Consume \' *) - (* TODO: do we know it's \' ? *) - Token.Codepoint {c = codepoint; original = contents} - -let scanSingleLineComment scanner = - let startOff = scanner.offset in - let startPos = position scanner in - let rec skip scanner = - match scanner.ch with - | '\n' | '\r' -> () - | ch when ch == hackyEOFChar -> () - | _ -> - next scanner; - skip scanner - in - skip scanner; - let endPos = position scanner in - Token.Comment - (Comment.makeSingleLineComment - ~loc:Location.{loc_start = startPos; loc_end = endPos; loc_ghost = false} - ((String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - startOff))) - -let scanMultiLineComment scanner = - (* assumption: we're only ever using this helper in `scan` after detecting a comment *) - let docComment = peek2 scanner = '*' && peek3 scanner <> '/' (* no /**/ *) in - let standalone = docComment && peek3 scanner = '*' (* /*** *) in - let contentStartOff = - scanner.offset + if docComment then if standalone then 4 else 3 else 2 - in - let startPos = position scanner in - let rec scan ~depth = - (* invariant: depth > 0 right after this match. See assumption *) - match (scanner.ch, peek scanner) with - | '/', '*' -> - next2 scanner; - scan ~depth:(depth + 1) - | '*', '/' -> - next2 scanner; - if depth > 1 then scan ~depth:(depth - 1) - | ch, _ when ch == hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedComment - | _ -> - next scanner; - scan ~depth - in - scan ~depth:0; - let length = scanner.offset - 2 - contentStartOff in - let length = if length < 0 (* in case of EOF *) then 0 else length in - Token.Comment - (Comment.makeMultiLineComment ~docComment ~standalone - ~loc: - Location. - {loc_start = startPos; loc_end = position scanner; loc_ghost = false} - ((String.sub [@doesNotRaise]) scanner.src contentStartOff length)) - -let scanTemplateLiteralToken scanner = - let startOff = scanner.offset in - - (* if starting } here, consume it *) - if scanner.ch == '}' then next scanner; - - let startPos = position scanner in - - let rec scan () = - let lastPos = position scanner in - match scanner.ch with - | '`' -> - next scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 1 - startOff) - in - Token.TemplateTail (contents, lastPos) - | '$' -> ( - match peek scanner with - | '{' -> - next2 scanner; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (scanner.offset - 2 - startOff) - in - Token.TemplatePart (contents, lastPos) - | _ -> - next scanner; - scan ()) - | '\\' -> ( - match peek scanner with - | '`' | '\\' | '$' | '\n' | '\r' -> - (* line break *) - next2 scanner; - scan () - | _ -> - next scanner; - scan ()) - | ch when ch = hackyEOFChar -> - let endPos = position scanner in - scanner.err ~startPos ~endPos Diagnostics.unclosedTemplate; - let contents = - (String.sub [@doesNotRaise]) scanner.src startOff - (max (scanner.offset - 1 - startOff) 0) - in - Token.TemplateTail (contents, lastPos) - | _ -> - next scanner; - scan () - in - let token = scan () in - let endPos = position scanner in - (startPos, endPos, token) - -let rec scan scanner = - skipWhitespace scanner; - let startPos = position scanner in - - let token = - match scanner.ch with - (* peeking 0 char *) - | 'A' .. 'Z' | 'a' .. 'z' -> scanIdentifier scanner - | '0' .. '9' -> scanNumber scanner - | '`' -> - next scanner; - Token.Backtick - | '~' -> - next scanner; - Token.Tilde - | '?' -> - next scanner; - Token.Question - | ';' -> - next scanner; - Token.Semicolon - | '(' -> - next scanner; - Token.Lparen - | ')' -> - next scanner; - Token.Rparen - | '[' -> - next scanner; - Token.Lbracket - | ']' -> - next scanner; - Token.Rbracket - | '{' -> - next scanner; - Token.Lbrace - | '}' -> - next scanner; - Token.Rbrace - | ',' -> - next scanner; - Token.Comma - | '"' -> scanString scanner - (* peeking 1 char *) - | '_' -> ( - match peek scanner with - | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> scanIdentifier scanner - | _ -> - next scanner; - Token.Underscore) - | '#' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.HashEqual - | _ -> - next scanner; - Token.Hash) - | '*' -> ( - match peek scanner with - | '*' -> - next2 scanner; - Token.Exponentiation - | '.' -> - next2 scanner; - Token.AsteriskDot - | _ -> - next scanner; - Token.Asterisk) - | '@' -> ( - match peek scanner with - | '@' -> - next2 scanner; - Token.AtAt - | _ -> - next scanner; - Token.At) - | '%' -> ( - match peek scanner with - | '%' -> - next2 scanner; - Token.PercentPercent - | _ -> - next scanner; - Token.Percent) - | '|' -> ( - match peek scanner with - | '|' -> - next2 scanner; - Token.Lor - | '>' -> - next2 scanner; - Token.BarGreater - | _ -> - next scanner; - Token.Bar) - | '&' -> ( - match peek scanner with - | '&' -> - next2 scanner; - Token.Land - | _ -> - next scanner; - Token.Band) - | ':' -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.ColonEqual - | '>' -> - next2 scanner; - Token.ColonGreaterThan - | _ -> - next scanner; - Token.Colon) - | '\\' -> - next scanner; - scanExoticIdentifier scanner - | '/' -> ( - match peek scanner with - | '/' -> - next2 scanner; - scanSingleLineComment scanner - | '*' -> scanMultiLineComment scanner - | '.' -> - next2 scanner; - Token.ForwardslashDot - | _ -> - next scanner; - Token.Forwardslash) - | '-' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.MinusDot - | '>' -> - next2 scanner; - Token.MinusGreater - | _ -> - next scanner; - Token.Minus) - | '+' -> ( - match peek scanner with - | '.' -> - next2 scanner; - Token.PlusDot - | '+' -> - next2 scanner; - Token.PlusPlus - | '=' -> - next2 scanner; - Token.PlusEqual - | _ -> - next scanner; - Token.Plus) - | '>' -> ( - match peek scanner with - | '=' when not (inDiamondMode scanner) -> - next2 scanner; - Token.GreaterEqual - | _ -> - next scanner; - Token.GreaterThan) - | '<' when not (inJsxMode scanner) -> ( - match peek scanner with - | '=' -> - next2 scanner; - Token.LessEqual - | _ -> - next scanner; - Token.LessThan) - (* special handling for JSX < *) - | '<' -> ( - (* Imagine the following:
< - * < indicates the start of a new jsx-element, the parser expects - * the name of a new element after the < - * Example:
- * This signals a closing element. To simulate the two-token lookahead, - * the - next scanner; - Token.LessThanSlash - | '=' -> - next scanner; - Token.LessEqual - | _ -> Token.LessThan) - (* peeking 2 chars *) - | '.' -> ( - match (peek scanner, peek2 scanner) with - | '.', '.' -> - next3 scanner; - Token.DotDotDot - | '.', _ -> - next2 scanner; - Token.DotDot - | _ -> - next scanner; - Token.Dot) - | '\'' -> ( - match (peek scanner, peek2 scanner) with - | '\\', '"' -> - (* careful with this one! We're next-ing _once_ (not twice), - then relying on matching on the quote *) - next scanner; - SingleQuote - | '\\', _ -> - next2 scanner; - scanEscape scanner - | ch, '\'' -> - let offset = scanner.offset + 1 in - next3 scanner; - Token.Codepoint - { - c = Char.code ch; - original = (String.sub [@doesNotRaise]) scanner.src offset 1; - } - | ch, _ -> - next scanner; - let offset = scanner.offset in - let offset16 = scanner.offset16 in - let codepoint, length = - Res_utf8.decodeCodePoint scanner.offset scanner.src - (String.length scanner.src) - in - for _ = 0 to length - 1 do - next scanner - done; - if scanner.ch = '\'' then ( - let contents = - (String.sub [@doesNotRaise]) scanner.src offset length - in - next scanner; - Token.Codepoint {c = codepoint; original = contents}) - else ( - scanner.ch <- ch; - scanner.offset <- offset; - scanner.offset16 <- offset16; - SingleQuote)) - | '!' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.BangEqualEqual - | '=', _ -> - next2 scanner; - Token.BangEqual - | _ -> - next scanner; - Token.Bang) - | '=' -> ( - match (peek scanner, peek2 scanner) with - | '=', '=' -> - next3 scanner; - Token.EqualEqualEqual - | '=', _ -> - next2 scanner; - Token.EqualEqual - | '>', _ -> - next2 scanner; - Token.EqualGreater - | _ -> - next scanner; - Token.Equal) - (* special cases *) - | ch when ch == hackyEOFChar -> - next scanner; - Token.Eof - | ch -> - (* if we arrive here, we're dealing with an unknown character, - * report the error and continue scanning… *) - next scanner; - let endPos = position scanner in - scanner.err ~startPos ~endPos (Diagnostics.unknownUchar ch); - let _, _, token = scan scanner in - token - in - let endPos = position scanner in - (* _printDebug ~startPos ~endPos scanner token; *) - (startPos, endPos, token) - -(* misc helpers used elsewhere *) - -(* Imagine:
< - * is `<` the start of a jsx-child?
- * reconsiderLessThan peeks at the next token and - * determines the correct token to disambiguate *) -let reconsiderLessThan scanner = - (* < consumed *) - skipWhitespace scanner; - if scanner.ch == '/' then - let () = next scanner in - Token.LessThanSlash - else Token.LessThan - -(* If an operator has whitespace around both sides, it's a binary operator *) -(* TODO: this helper seems out of place *) -let isBinaryOp src startCnum endCnum = - if startCnum == 0 then false - else ( - (* we're gonna put some assertions and invariant checks here because this is - used outside of the scanner's normal invariant assumptions *) - assert (endCnum >= 0); - assert (startCnum > 0 && startCnum < String.length src); - let leftOk = isWhitespace (String.unsafe_get src (startCnum - 1)) in - (* we need some stronger confidence that endCnum is ok *) - let rightOk = - endCnum >= String.length src - || isWhitespace (String.unsafe_get src endCnum) - in - leftOk && rightOk) diff --git a/jscomp/syntax/src/res_scanner.mli b/jscomp/syntax/src/res_scanner.mli deleted file mode 100644 index cc00269..0000000 --- a/jscomp/syntax/src/res_scanner.mli +++ /dev/null @@ -1,36 +0,0 @@ -type mode = Jsx | Diamond - -type charEncoding - -type t = { - filename: string; - src: string; - mutable err: - startPos:Lexing.position -> - endPos:Lexing.position -> - Res_diagnostics.category -> - unit; - mutable ch: charEncoding; (* current character *) - mutable offset: int; (* current byte offset *) - mutable offset16: int; - (* current number of utf16 code units since line start *) - mutable lineOffset: int; (* current line offset *) - mutable lnum: int; (* current line number *) - mutable mode: mode list; -} - -val make : filename:string -> string -> t - -(* TODO: make this a record *) -val scan : t -> Lexing.position * Lexing.position * Res_token.t - -val isBinaryOp : string -> int -> int -> bool - -val setJsxMode : t -> unit -val setDiamondMode : t -> unit -val popMode : t -> mode -> unit - -val reconsiderLessThan : t -> Res_token.t - -val scanTemplateLiteralToken : - t -> Lexing.position * Lexing.position * Res_token.t diff --git a/jscomp/syntax/src/res_string.ml b/jscomp/syntax/src/res_string.ml deleted file mode 100644 index a4ecba1..0000000 --- a/jscomp/syntax/src/res_string.ml +++ /dev/null @@ -1,11 +0,0 @@ -let hexTable = - [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; |] - [@ocamlformat "disable"] - -let convertDecimalToHex ~strDecimal = - try - let intNum = int_of_string strDecimal in - let c1 = Array.get hexTable (intNum lsr 4) in - let c2 = Array.get hexTable (intNum land 15) in - "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] - with Invalid_argument _ | Failure _ -> strDecimal diff --git a/jscomp/syntax/src/res_uncurried.ml b/jscomp/syntax/src/res_uncurried.ml deleted file mode 100644 index 1a777e1..0000000 --- a/jscomp/syntax/src/res_uncurried.ml +++ /dev/null @@ -1,11 +0,0 @@ -(* For parsing *) -let fromDotted ~dotted = function - | Config.Legacy -> dotted - | Swap -> not dotted - | Uncurried -> true - -(* For printing *) -let getDotted ~uncurried = function - | Config.Legacy -> uncurried - | Swap -> not uncurried - | Uncurried -> false diff --git a/jscomp/syntax/src/res_utf8.mli b/jscomp/syntax/src/res_utf8.mli deleted file mode 100644 index 7dcb342..0000000 --- a/jscomp/syntax/src/res_utf8.mli +++ /dev/null @@ -1,9 +0,0 @@ -val repl : int - -val max : int - -val decodeCodePoint : int -> string -> int -> int * int - -val encodeCodePoint : int -> string - -val isValidCodePoint : int -> bool diff --git a/jscomp/syntax/testrunner/dune b/jscomp/syntax/testrunner/dune deleted file mode 100644 index c605c17..0000000 --- a/jscomp/syntax/testrunner/dune +++ /dev/null @@ -1,13 +0,0 @@ -(env - (static - (flags - (:standard -ccopt -static)))) - -(executable - (name res_test) - (public_name syntax_tests) - (enabled_if - (<> %{profile} browser)) - (flags - (:standard -w -A)) - (libraries syntax core)) diff --git a/jscomp/syntax/testrunner/res_test.ml b/jscomp/syntax/testrunner/res_test.ml deleted file mode 100644 index acda80f..0000000 --- a/jscomp/syntax/testrunner/res_test.ml +++ /dev/null @@ -1,158 +0,0 @@ -module IO = Res_io - -let dataDir = "jscomp/syntax/tests" - -(* test printing of .res file*) -let () = - let filename = Filename.concat dataDir "api/resSyntax.res" in - let prettySource = Res_multi_printer.print `res ~input:filename in - assert ( - prettySource - = {|// test file - -if true { - Js.log("true") -} else { - Js.log("false") -} -|}) - -(* test printing of .resi file*) -let () = - let filename = Filename.concat dataDir "api/resiSyntax.resi" in - let prettySource = Res_multi_printer.print `res ~input:filename in - assert (prettySource = {|// test interface file - -let x: int -|}) - -(* test printing of ocaml .ml file *) -let () = - let filename = Filename.concat dataDir "api/mlSyntax.ml" in - let prettySource = Res_multi_printer.print `ml ~input:filename in - assert ( - prettySource - = {|/* test ml file */ - -let () = print_endline("hello world") - -let unicode = "🙈 😅 🙌" - -let d = `Sehr Schön` -|}) - -(* test printing of ocaml .mli file *) -let () = - let filename = Filename.concat dataDir "api/mliSyntax.mli" in - let prettySource = Res_multi_printer.print `ml ~input:filename in - assert ( - prettySource - = {|/* test mli file */ - -let x: int - -/* comment */ -let y: float -|}) - -let () = print_endline "✅ multi printer api tests" - -module OutcomePrinterTests = struct - let signatureToOutcome structure = - Lazy.force Res_outcome_printer.setup; - - Clflags.include_dirs := - Filename.concat "lib" "ocaml" :: !Clflags.include_dirs; - Res_compmisc.init_path (); - Clflags.nopervasives := true; - let env = Res_compmisc.initial_env () in - try - let _typedStructure, signature, _newenv = - Typemod.type_toplevel_phrase env structure - in - signature |> Printtyp.tree_of_signature - |> !Oprint.out_signature Format.str_formatter; - Format.flush_str_formatter () - with - | Typetexp.Error (_, _, err) -> - Typetexp.report_error env Format.str_formatter err; - prerr_string (Format.flush_str_formatter ()); - exit 1 - | Typemod.Error (_, _, err) -> - Typemod.report_error env Format.str_formatter err; - prerr_string (Format.flush_str_formatter ()); - exit 1 - | Typedecl.Error (_, err) -> - Typedecl.report_error Format.str_formatter err; - prerr_string (Format.flush_str_formatter ()); - exit 1 - | e -> - prerr_string - ("Unknown error while trying to print outcome tree.\n" - ^ "We don't display all the outcome type errors; try adding the new \ - case to the `try` pattern match.\n"); - raise e - - (* `tests/oprint/oprint.res` will be read into memory and typechecked. - * The inferred signature (i.e. the type of the module `oprint.res`) will - * then be converted to the outcome tree. - * The outcome tree is printed to a string - * and stored in a snapshot `tests/oprint/expected/oprint.resi.txt` *) - let run () = - let filename = Filename.concat dataDir "oprint/oprint.res" in - let result = - Res_driver.parsingEngine.parseImplementation ~forPrinter:false ~filename - in - let signature = - if result.Res_driver.invalid then ( - Res_driver.parsingEngine.stringOfDiagnostics ~source:result.source - ~filename:result.filename result.diagnostics; - exit 1) - else result.Res_driver.parsetree - in - IO.writeFile - ~filename:(Filename.concat dataDir "oprint/expected/oprint.resi.txt") - ~contents:(signatureToOutcome signature) -end - -module ParserApiTest = struct - let makeDefault () = - let src = " let x = 1\nlet y = 2\nlet z = 3" in - let parser = Res_parser.make src "test.res" in - assert (parser.scanner.lnum == 1); - assert (parser.scanner.lineOffset == 0); - assert (parser.scanner.offset == 6); - assert (parser.token = Res_token.Let); - print_endline "✅ Parser make: initializes parser and checking offsets" - - let unixLf () = - let src = "let x = 1\nlet y = 2\nlet z = 3" in - let parser = Res_parser.make src "test.res" in - (match Res_core.parseImplementation parser with - | [x; y; z] -> - assert (x.pstr_loc.loc_start.pos_lnum = 1); - assert (y.pstr_loc.loc_start.pos_lnum = 2); - assert (z.pstr_loc.loc_start.pos_lnum = 3) - | _ -> assert false); - print_endline "✅ Parser handles LF correct" - - let windowsCrlf () = - let src = "let x = 1\r\nlet y = 2\r\nlet z = 3" in - let parser = Res_parser.make src "test.res" in - (match Res_core.parseImplementation parser with - | [x; y; z] -> - assert (x.pstr_loc.loc_start.pos_lnum = 1); - assert (y.pstr_loc.loc_start.pos_lnum = 2); - assert (z.pstr_loc.loc_start.pos_lnum = 3) - | _ -> assert false); - print_endline "✅ Parser handles CRLF correct" - - let run () = - makeDefault (); - unixLf (); - windowsCrlf () -end - -let () = OutcomePrinterTests.run () -let () = ParserApiTest.run () -let () = Res_utf8_test.run () diff --git a/jscomp/syntax/testrunner/res_utf8_test.ml b/jscomp/syntax/testrunner/res_utf8_test.ml deleted file mode 100644 index 5546ae3..0000000 --- a/jscomp/syntax/testrunner/res_utf8_test.ml +++ /dev/null @@ -1,93 +0,0 @@ -type utf8Test = {codepoint: int; str: string; size: int} - -let utf8CodePointTests = - [| - {codepoint = 0x00; str = "\x00"; size = 1}; - {codepoint = 0x01; str = "\x01"; size = 1}; - {codepoint = 0x7e; str = "\x7e"; size = 1}; - {codepoint = 0x7f; str = "\x7f"; size = 1}; - {codepoint = 0x0080; str = "\xc2\x80"; size = 2}; - {codepoint = 0x0081; str = "\xc2\x81"; size = 2}; - {codepoint = 0x00bf; str = "\xc2\xbf"; size = 2}; - {codepoint = 0x00c0; str = "\xc3\x80"; size = 2}; - {codepoint = 0x00c1; str = "\xc3\x81"; size = 2}; - {codepoint = 0x00c8; str = "\xc3\x88"; size = 2}; - {codepoint = 0x00d0; str = "\xc3\x90"; size = 2}; - {codepoint = 0x00e0; str = "\xc3\xa0"; size = 2}; - {codepoint = 0x00f0; str = "\xc3\xb0"; size = 2}; - {codepoint = 0x00f8; str = "\xc3\xb8"; size = 2}; - {codepoint = 0x00ff; str = "\xc3\xbf"; size = 2}; - {codepoint = 0x0100; str = "\xc4\x80"; size = 2}; - {codepoint = 0x07ff; str = "\xdf\xbf"; size = 2}; - {codepoint = 0x0400; str = "\xd0\x80"; size = 2}; - {codepoint = 0x0800; str = "\xe0\xa0\x80"; size = 3}; - {codepoint = 0x0801; str = "\xe0\xa0\x81"; size = 3}; - {codepoint = 0x1000; str = "\xe1\x80\x80"; size = 3}; - {codepoint = 0xd000; str = "\xed\x80\x80"; size = 3}; - {codepoint = 0xd7ff; str = "\xed\x9f\xbf"; size = 3}; - {codepoint = 0xe000; str = "\xee\x80\x80"; size = 3}; - {codepoint = 0xfffe; str = "\xef\xbf\xbe"; size = 3}; - {codepoint = 0xffff; str = "\xef\xbf\xbf"; size = 3}; - {codepoint = 0x10000; str = "\xf0\x90\x80\x80"; size = 4}; - {codepoint = 0x10001; str = "\xf0\x90\x80\x81"; size = 4}; - {codepoint = 0x40000; str = "\xf1\x80\x80\x80"; size = 4}; - {codepoint = 0x10fffe; str = "\xf4\x8f\xbf\xbe"; size = 4}; - {codepoint = 0x10ffff; str = "\xf4\x8f\xbf\xbf"; size = 4}; - {codepoint = 0xFFFD; str = "\xef\xbf\xbd"; size = 3}; - |] - -let surrogateRange = - [| - {codepoint = 0xFFFD; str = "\xed\xa0\x80"; size = 1}; - {codepoint = 0xFFFD; str = "\xed\xbf\xbf"; size = 1}; - |] - -let testDecode () = - Array.iter - (fun t -> - let len = String.length t.str in - let codepoint, size = Res_utf8.decodeCodePoint 0 t.str len in - assert (codepoint = t.codepoint); - assert (size = t.size)) - utf8CodePointTests - -let testDecodeSurrogateRange () = - Array.iter - (fun t -> - let len = String.length t.str in - let codepoint, size = Res_utf8.decodeCodePoint 0 t.str len in - assert (codepoint = t.codepoint); - assert (size = t.size)) - surrogateRange - -let testEncode () = - Array.iter - (fun t -> - let encodedString = Res_utf8.encodeCodePoint t.codepoint in - assert (encodedString = t.str)) - utf8CodePointTests - -let validCodePointsTests = - [| - (0, true); - (Char.code 'e', true); - (Res_utf8.max, true); - (0xD7FF, true); - (0xD800, false); - (0xDFFF, false); - (0xE000, true); - (Res_utf8.max + 1, false); - (-1, false); - |] - -let testIsValidCodePoint () = - Array.iter - (fun (codePoint, t) -> assert (Res_utf8.isValidCodePoint codePoint = t)) - validCodePointsTests - -let run () = - testDecode (); - testDecodeSurrogateRange (); - testEncode (); - testIsValidCodePoint (); - print_endline "✅ utf8 tests" diff --git a/jscomp/syntax/tests/api/mlSyntax.ml b/jscomp/syntax/tests/api/mlSyntax.ml deleted file mode 100644 index 33d3236..0000000 --- a/jscomp/syntax/tests/api/mlSyntax.ml +++ /dev/null @@ -1,7 +0,0 @@ -(* test ml file *) - -let () = print_endline "hello world" - -let unicode = "🙈 😅 🙌" - -let d = {|Sehr Schön|} diff --git a/jscomp/syntax/tests/api/mliSyntax.mli b/jscomp/syntax/tests/api/mliSyntax.mli deleted file mode 100644 index 4bba276..0000000 --- a/jscomp/syntax/tests/api/mliSyntax.mli +++ /dev/null @@ -1,6 +0,0 @@ -(* test mli file *) - -val x: int - -(* comment *) -val y: float diff --git a/jscomp/syntax/tests/api/reasonSyntax.res b/jscomp/syntax/tests/api/reasonSyntax.res deleted file mode 100644 index 54bfdf9..0000000 --- a/jscomp/syntax/tests/api/reasonSyntax.res +++ /dev/null @@ -1,8 +0,0 @@ -// test .re file -let \"+++" = (a, b) => a + b - -let unicode = "🙈 😅 🙌" - -let d = `Sehr Schön` /* test */ - -let () = print_endline("foo") diff --git a/jscomp/syntax/tests/api/reiSyntax.resi b/jscomp/syntax/tests/api/reiSyntax.resi deleted file mode 100644 index bf897f3..0000000 --- a/jscomp/syntax/tests/api/reiSyntax.resi +++ /dev/null @@ -1,2 +0,0 @@ -// test .rei file -let x: int diff --git a/jscomp/syntax/tests/api/resReactJsx.res b/jscomp/syntax/tests/api/resReactJsx.res deleted file mode 100644 index e236abf..0000000 --- a/jscomp/syntax/tests/api/resReactJsx.res +++ /dev/null @@ -1,6 +0,0 @@ -// test React JSX file - -@react.component -let make = (~msg) => { -
{msg->React.string}
-} diff --git a/jscomp/syntax/tests/api/resSyntax.res b/jscomp/syntax/tests/api/resSyntax.res deleted file mode 100644 index 2d6f904..0000000 --- a/jscomp/syntax/tests/api/resSyntax.res +++ /dev/null @@ -1,7 +0,0 @@ -// test file - -if true { - Js.log("true") -} else { - Js.log("false") -} diff --git a/jscomp/syntax/tests/api/resiSyntax.resi b/jscomp/syntax/tests/api/resiSyntax.resi deleted file mode 100644 index c415b91..0000000 --- a/jscomp/syntax/tests/api/resiSyntax.resi +++ /dev/null @@ -1,3 +0,0 @@ -// test interface file - -let x: int diff --git a/jscomp/syntax/tests/conversion/reason/attributes.res b/jscomp/syntax/tests/conversion/reason/attributes.res deleted file mode 100644 index ff549e3..0000000 --- a/jscomp/syntax/tests/conversion/reason/attributes.res +++ /dev/null @@ -1,22 +0,0 @@ -module Color: { - type t = private string - - @inline("red") let red: t - @inline("black") let black: t -} = { - type t = string - - @inline let red = "red" - @inline let black = "black" -} - -@send external map: (array<'a>, 'a => 'b) => array<'b> = "map" -@send external filter: (array<'a>, 'a => 'b) => array<'b> = "filter" -list{1, 2, 3}->map(a => a + 1)->filter(a => modulo(a, 2) == 0)->Js.log - -type t -@new external make: unit => t = "DOMParser" -@bs.send.pipe(: t) -external parseHtmlFromString: (string, @as("text/html") _) => Dom.htmlDocument = "parseFromString" - -Js.log(make() |> parseHtmlFromString("sdsd")) diff --git a/jscomp/syntax/tests/conversion/reason/bracedJsx.res b/jscomp/syntax/tests/conversion/reason/bracedJsx.res deleted file mode 100644 index 0cbb8f4..0000000 --- a/jscomp/syntax/tests/conversion/reason/bracedJsx.res +++ /dev/null @@ -1,147 +0,0 @@ -open Belt - -type action = - | RunCommand - | SetValue(string) - -type line = - | User(string) - | System(string) - -type state = { - history: array, - input: string, -} - -module Styles = { - open Css - let terminal = style(list{ - margin(10->px), - backgroundColor("222"->hex), - borderRadius(10->px), - padding(10->px), - color("fff"->hex), - height(300->px), - overflowY(auto), - fontFamily(#custom(Theme.codeFontFamily)), - unsafe("WebkitOverflowScrolling", "touch"), - }) - let line = style(list{whiteSpace(#preWrap)}) - let input = style(list{ - backgroundColor("222"->hex), - fontFamily(#custom(Theme.codeFontFamily)), - color("fff"->hex), - fontSize(16->px), - borderWidth(zero), - margin(zero), - padding(zero), - outlineStyle(none), - }) - let title = style(list{ - fontSize(48->px), - fontWeight(extraBold), - marginTop(20->px), - marginBottom(20->px), - textAlign(center), - }) -} - -@react.component -let make = () => { - let containerRef = React.useRef(Js.Nullable.null) - - let (state, send) = React.useReducer((state, action) => - switch action { - | RunCommand => { - input: "", - history: Array.concat( - state.history, - [ - User(state.input), - switch state.input->Js.String.trim { - | "" => System("") - | "help" => - System(`available commands: -- help -- ls -- cat `) - | "ls" => - System(`- hack-website.sh -- go-to-home.sh -- nuclear-codes.txt`) - | "cat" => System("cat: missing argument") - | "cat hack-website.sh" - | "cat ./hack-website.sh" => - System("# seriously?\necho \"lol\"") - | "hack-website.sh" - | "./hack-website.sh" => - System("lol") - | "cat nuclear-codes.txt" - | "cat ./nuclear-codes.txt" => - System("000000") - | "go-to-home.sh" - | "./go-to-home.sh" => - Js.Global.setTimeout(() => ReasonReact.Router.push("/"), 1_000)->ignore - System("Redirecting ...") - | "cat go-to-home.sh" - | "cat ./go-to-home.sh" => - System("ReasonReact.Router.push(\"/\")") - | _ => System("command not found: " ++ (state.input ++ "\ntry command 'help'")) - }, - ], - ), - } - | SetValue(input) => {...state, input: input} - } - , {history: [], input: ""}) - - React.useEffect1(() => { - switch containerRef.current->Js.Nullable.toOption { - | Some(containerRef) => - open Webapi.Dom - containerRef->Element.setScrollTop(containerRef->Element.scrollHeight->float_of_int) - | None => () - } - None - }, [state.history]) - - let userPrefix = "~ " - -
{"Erreur"->ReasonReact.string}
-
(event->ReactEvent.Mouse.target)["querySelector"]("input")["focus"]()} - ref={containerRef->ReactDOMRe.Ref.domRef}> - {state.history - ->Array.mapWithIndex((index, item) => -
- {ReasonReact.string( - switch item { - | User(value) => userPrefix ++ value - | System(value) => value - }, - )} -
- ) - ->ReasonReact.array} -
- {userPrefix->ReasonReact.string} - { send(SetValue((event->ReactEvent.Form.target)["value"]))} - onKeyDown={event => { - if event->ReactEvent.Keyboard.key == "Enter" { - send(RunCommand) - } - if event->ReactEvent.Keyboard.key == "Tab" { - event->ReactEvent.Keyboard.preventDefault - } - }} - />->ReasonReact.cloneElement(~props={"autoCapitalize": "off"}, [])} -
-
-
-} diff --git a/jscomp/syntax/tests/conversion/reason/braces.res b/jscomp/syntax/tests/conversion/reason/braces.res deleted file mode 100644 index cf164c9..0000000 --- a/jscomp/syntax/tests/conversion/reason/braces.res +++ /dev/null @@ -1,24 +0,0 @@ -let f = () => id -let f = () => id - -if isArray(children) { - // Scenario 1 - let code = children->asStringArray->Js.Array2.joinWith("") - {code->s} -} else if isObject(children) { - // Scenario 2 - children->asElement -} else { - // Scenario 3 - let code = unknownAsString(children) - makeCodeElement(~code, ~metastring, ~lang) -} - -let getDailyNewCases = x => - switch x { - | First(ret) => ret - | Pair({prevRecord, record}) => - let confirmed = record.confirmed - prevRecord.confirmed - let deaths = record.deaths - prevRecord.deaths - {confirmed: confirmed, deaths: deaths} - } diff --git a/jscomp/syntax/tests/conversion/reason/comments.res b/jscomp/syntax/tests/conversion/reason/comments.res deleted file mode 100644 index 948e3ba..0000000 --- a/jscomp/syntax/tests/conversion/reason/comments.res +++ /dev/null @@ -1,770 +0,0 @@ -// comment 1 -let /* a */ x /* b */ = /* c */ 1 /* comment 2 */ - -// comment 3 - -// comment 4 -let x = 1 /* 5 */ -/* 6 */ - -let f = ( - // 1 - a, //2 - // 3 - b, -) => { - // 5 - x: 1, // 6 - // 7 - y: 2, // 8 -} -/* **** comment */ -/* ** comment */ -/* comment */ -/* ** comment */ -/* *** comment */ -/* **** comment */ - -/* ** */ -/* *** */ - -/* ** */ - -/* (** comment *) */ -/* (*** comment *) */ -/* *(*** comment *) */ - -/* comment * */ -/* comment ** */ -/* comment *** */ -/* comment **** */ - -let testingNotQuiteEndOfLineComments = list{ - "Item 1" /* Comment For First Item */, - "Item 2" /* Comment For Second Item */, - "Item 3" /* Comment For Third Item */, - "Item 4" /* Comment For Fourth Item - but no semi */, - /* Comment after last item in list. */ -} /* Comment after list bracket */ - -let testingEndOfLineComments = list{ - "Item 1" /* Comment For First Item */, - "Item 2" /* Comment For Second Item */, - "Item 3" /* Comment For Third Item */, - "Item 4" /* Comment For Fourth Item - but before semi */, - /* Comment after last item in list. */ -} /* Comment after list bracket */ - -/* This time no space between bracket and comment */ -let testingEndOfLineComments = list{} /* Comment after list bracket */ - -type t = (int, int) /* End of line on t */ - -type t22 = /* End of t22 line on type t22 = */ -(int, int) - -type variant = - /* Comment above X */ - | X(int) /* End of line on X */ - /* Comment above Y */ - | Y(int) /* End of line on Y */ -/* Comment on entire type def for variant */ - -type rec x = { - /* not attached *above* x */ - fieldOne: int, -} /* Attached end of line after x */ -and y = { - /* not attached *above* y */ - fieldTwo: int, -} /* Attached end of line after y */ - -let result = switch X(3) { -| X(x) => - /* Where does this comment go? */ - let tmp = x - x + tmp -| Y(x) => - /* How about this one */ - let tmp = x - x + tmp -} - -let result = switch None { -| Some({fieldOne: 20}) => - /* Where does this comment go? */ - let tmp = 0 - 2 + tmp -| Some({fieldOne: n}) => - /* How about this one */ - let tmp = n - n + tmp -| None => 20 -} - -type pointWithManyKindsOfComments = { - /* Line before x */ - x: string /* x field */, - /* Line before y */ - y: string /* y field */, - /* Final row of record */ -} - -type typeParamPointWithComments<'a> = { - /* Line before x */ - x: 'a /* x field */, - /* Line before y */ - y: 'a /* y field */, - /* Final row of record */ -} - -let name_equal = (x, y) => x == y - -let equal = (i1, i2) => i1.contents === i2.contents && true /* most unlikely first */ - -let equal = (i1, i2) => compare(compare(0, 0), compare(1, 1)) /* END OF LINE HERE */ - -module Temp = { - let v = true - let logIt = (str, ()) => print_string(str) -} - -let store_attributes = arg => { - let attributes_file = "test" - let proc_name = attributes_file ++ ".proc" - let should_write = - /* only overwrite defined procedures */ - Temp.v || !Temp.v - if should_write { - Temp.logIt(proc_name, ()) - } -} -3 // - -3 //- - -3 //- - -3 /* - */ -// **** comment -/* ** comment */ -@ocaml.doc(" docstring ") -@ocaml.doc(" docstring ") -@ocaml.doc(" ") -@ocaml.doc("") -@ocaml.doc(" (** comment *) ") -@ocaml.doc(" (*** comment *) ") -@ocaml.doc(" - * Multiline - ") -@ocaml.doc(" Multiline - * - ") -@ocaml.doc(" - ** - ") -module // comment - -/* ** comment */ -/* *** comment */ -/* **** comment */ - -/* ** */ -/* *** */ - -/* ** */ - -// (** comment *) -// (*** comment *) -// *(*** comment *) -// comment * -// comment ** -// comment *** -// comment **** - -JustString = { - include Map.Make(Int32) // Comment eol include -} - -let testingEndOfLineComments = list{ - "Item 1" /* Comment For First Item */, - "Item 2" /* Comment For Second Item */, - "Item 3" /* Comment For Third Item */, - "Item 4" /* Comment For Fourth Item - but before trailing comma */, - // Comment after last item in list. -} /* Comment after rbracket */ - -// But if you place them after the comma at eol, they're preserved as such -let testingEndOfLineComments = list{ - "Item 1", // Comment For First Item - "Item 2", // Comment For Second Item - "Item 3", // Comment For Third Item - "Item 4" /* Comment For Fourth Item - but before trailing comma */, - // Comment after last item in list. -} /* Comment after rbracket */ - -// The space between ; and comment shoudn't matter -let testPlacementOfTrailingComment = list{ - "Item 0", - // Comment after last item in list. -} // Comment after semi - -// The space between ; and comment shoudn't matter -let testPlacementOfTrailingComment = list{ - "Item 0", - // Comment after last item in list. -} // Comment after semi - -// Try again but without other things in the list -let testPlacementOfTrailingComment = list{"Item 0"} // Comment after semi - -// The space between ; and comment shoudn't matter -let testPlacementOfTrailingComment = list{ - "Item 0", - // Comment after last item in list. -} // Comment after semi - -let testingEndOfLineComments = list{} // Comment after entire let binding - -// The following is not yet idempotent -// let myFunction -// withFirstArg // First arg -// andSecondArg => { // Second Arg -// withFirstArg + andSecondArg /* before semi */ ; -// }; - -let myFunction = // First arg -( - withFirstArg, - // Second Arg - andSecondArg, -) => withFirstArg + andSecondArg // After Semi - -type point = { - x: string, // x field - y: string, // y field -} - -type pointWithManyKindsOfComments = { - // Line before x - x: string, // x field - // Line before y - y: string, // y field - // Final row of record -} - -type typeParamPointWithComments<'a> = { - // Line before x - x: 'a, // x field - // Line before y - y: 'a, // y field - // Final row of record -} - -// Now, interleaving comments in type params -// Type name -type typeParamPointWithComments2< - 'a, - // The b type apram - 'b, -> = { - // Line before x - x: 'a, // x field - // Line before y - y: 'a, // y field - // Final row of record -} - -/* The way the last row comment is formatted is suboptimal becuase - * record type definitions do not include enough location information */ -type anotherpoint = { - x: string, // x field - y: string, // y field - // comment as last row of record -} - -type t = (int, int) // End of line on t -type t2 = (int, int) // End of line on (int, int) - -type t3 = (int, int) // End of line on (int, int) - -type variant = - | X(int, int) // End of line on X - | Y(int, int) // End of line on Y -// Comment on entire type def for variant - -// Before let -let res = // Before switch -switch X(2, 3) { -// Above X line -| X(_) => "result of X" // End of arrow and X line -// Above Y line -| Y(_) => "result of Y" // End of arrow and Y line -} // After final semi in switch - -let res = switch X(2, 3) { -| X(0, 0) => // After X arrow - "result of X" // End of X body line -| X(1, 0) /* Before X's arrow */ => "result of X" // End of X body line -| X(_) => // After X _ arrow - "result of X" // End of X body line -// Above Y line -| Y(_) => // Comment above Y body - "result of Y" -} - -type variant2 = - // Comment above X - | X(int, int) // End of line on X - // Comment above Y - | Y(int, int) - -type variant3 = - // Comment above X - | X(int, int) // End of line on X - // Comment above Y - | Y(int, int) // End of line on Y - -type rec x = { - // not attached *above* x - fieldOne: int, - fieldA: int, -} // Attached end of line after x -and y = { - // not attached *above* y - fieldTwo: int, -} // Attached end of line after y - -type rec x2 = { - // not attached *above* x2 - fieldOne: int, - fieldA: int, -} // Attached end of line after x2 -and y2 = { - // not attached *above* y2 - fieldTwo: int, -} - -let result = switch None { -| Some({fieldOne: 20, fieldA: a}) => - // Where does this comment go? - let tmp = 0 - 2 + tmp -| Some({fieldOne: n, fieldA: a}) => - // How about this one - let tmp = n - n + tmp -| None => 20 -} - -let res = // Before switch -switch X(2, 3) { -// Above X line -| X(_) => "result of X" // End of arrow and X line -// Above Y line -| Y(_) => "result of Y" // End of arrow and Y line -} - -/* - * Now these end of line comments *should* be retained. - */ -let result = switch None { -| Some({fieldOne: 20, fieldA: a}) => - let tmp = 0 - 2 + tmp -| Some({fieldOne: n, fieldA: a}) => - let tmp = n - n + tmp -| None => 20 -} - -/* - * These end of line comments *should* be retained. - * To get the simple expression eol comment to be retained, we just need to - * implement label breaking eol behavior much like we did with sequences. - * Otherwise, right now they are not idempotent. - */ -let res = switch X(2, 3) { -// Above X line -| X(_, _) => "result of X" // retain this // retain this - -// Above Y line -| Y(_) => "result of Y" // End of arrow and Y line -} - -/* type optionalTuple = */ -/* | OptTup( */ -/* option( */ -/* ( */ -/* int, */ -/* int */ -/* ), */ -/* ), */ -/* ); */ - -type optionTuple = option<(int, int)> // First int // Second int - -type intPair = (int, int) // First int // Second int - -type intPair2 = ( - // First int - int, - // Second int - int, -) - -let result = @ocaml.doc("") (2 + 3) - -// This is not yet idempotent -// { -// /**/ -// (+) 2 3 -// }; - -let a = () -for i in 0 to 10 { - // bla - a -} - -if true { - () -} - -type color = - | Red(int) // After red end of line - | Black(int) // After black end of line - | Green(int) // After green end of line -// On next line after color type def - -let blahCurriedX = (x, x) => - switch x { - | Red(10) - | Black(20) - | Green(10) => 1 // After or pattern green - | Red(x) => 0 // After red - | Black(x) => 0 // After black - | Green(x) => 0 - } // After second green -// On next line after blahCurriedX def - -let name_equal = (x, y) => x == y - -let equal = (i1, i2) => i1.contents === i2.contents && true // most unlikely first - -let equal = (i1, i2) => compare(compare(0, 0), compare(1, 1)) // END OF LINE HERE - -let tuple_equal = ((i1, i2)) => i1 == i2 - -let tuple_equal = ((csu, mgd)) => - // Some really long comments, see https://github.com/facebook/reason/issues/811 - tuple_equal((csu, mgd)) - -let trueThing = true - -for i in 0 to 1 { - // comment - print_newline() -} - -while trueThing { - // comment - print_newline() -} - -if trueThing { - // comment - print_newline() -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} else { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} else { - // Comment before print - print_newline() -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() -} - -if trueThing { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} else { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} else { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() // eol - // Comment before print - print_newline() // eol - // Comment after final print -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() // eol - // Comment before print - print_newline() // eol - // Comment after final print -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() -} - -let f = (a, b, c, d) => a + b + c + d - -while trueThing { - f( - // a - 1, - // b - 2, - // c - 3, - // d - 4, - // does work - ) -} -while trueThing { - f( - // a - 1, - // b - 2, - // c - 3, - // d - 4, // does work - ) -} - -ignore((_really, _long, _printWidth, _exceeded, _here) => { - // First comment - let x = 0 - x + x - // Closing comment -}) - -ignore((_xxx, _yyy) => { - // First comment - let x = 0 - x + x - // Closing comment -}) - -type tester<'a, 'b> = - | TwoArgsConstructor('a, 'b) - | OneTupleArgConstructor(('a, 'b)) -let callFunctionTwoArgs = (a, b) => () -let callFunctionOneTuple = tuple => () - -let y = TwoArgsConstructor(1, 2) //eol1 // eol2 - -let y = callFunctionTwoArgs(1, 2) //eol1 // eol2 - -let y = OneTupleArgConstructor((1, 2)) //eol1 // eol2 - -let y = callFunctionOneTuple((1, 2)) //eol1 // eol2 - -type polyRecord<'a, 'b> = { - fieldOne: 'a, - fieldTwo: 'b, -} - -let r = { - fieldOne: 1, //eol1 - fieldTwo: 2, // eol2 -} - -let r = { - fieldOne: 1, //eol1 - fieldTwo: 2, // eol2 with trailing comma -} - -let y = TwoArgsConstructor("1", "2") //eol1 // eol2 - -let y = callFunctionTwoArgs("1", "2") //eol1 // eol2 - -let y = OneTupleArgConstructor(("1", "2")) //eol1 // eol2 - -let y = callFunctionOneTuple(("1", "2")) //eol1 // eol2 - -let r = { - fieldOne: "1", //eol1 - fieldTwo: "2", // eol2 -} - -let r = { - fieldOne: "1", //eol1 - fieldTwo: "2", // eol2 with trailing comma -} - -let identifier = "hello" - -let y = TwoArgsConstructor(identifier, identifier) //eol1 // eol2 - -let y = callFunctionTwoArgs(identifier, identifier) //eol1 // eol2 - -let y = OneTupleArgConstructor((identifier, identifier)) //eol1 // eol2 - -let y = callFunctionOneTuple((identifier, identifier)) //eol1 // eol2 - -let r = { - fieldOne: identifier, //eol1 - fieldTwo: identifier, // eol2 -} - -let r = { - fieldOne: identifier, //eol1 - fieldTwo: identifier, // eol2 with trailing comma -} - -let y = TwoArgsConstructor((identifier: string), (identifier: string)) //eol1 // eol2 - -let y = callFunctionTwoArgs((identifier: string), (identifier: string)) //eol1 // eol2 - -let y = OneTupleArgConstructor(((identifier: string), (identifier: string))) //eol1 // eol2 - -let y = callFunctionOneTuple(((identifier: string), (identifier: string))) //eol1 // eol2 - -let r = { - fieldOne: (identifier: string), //eol1 - fieldTwo: (identifier: string), // eol2 -} - -let r = { - fieldOne: (identifier: string), //eol1 - fieldTwo: (identifier: string), // eol2 with trailing comma -} - -// whitespace interleaving - -// comment1 -// comment2 - -// whitespace above & below - -let r = { - fieldOne: (identifier: string), //eol1 - // c1 - - // c2 - - // c3 - // c4 - - // c5 - fieldTwo: (identifier: string), // eol2 with trailing comma -} -// trailing - -// trailing whitespace above -// attach - -// last comment diff --git a/jscomp/syntax/tests/conversion/reason/destructiveSubstitutionSubModules.ml b/jscomp/syntax/tests/conversion/reason/destructiveSubstitutionSubModules.ml deleted file mode 100644 index f6060c1..0000000 --- a/jscomp/syntax/tests/conversion/reason/destructiveSubstitutionSubModules.ml +++ /dev/null @@ -1,51 +0,0 @@ -module type Id = - sig type t val toString : t -> string val ofString : string -> t option end -module type A = sig module Id : Id type name = string val name : name end -module type B = sig module A : A val fullName : A.Id.t -> string end -module MakeB(A:A): B with module A.Id := A.Id = - (struct - module A = A - let fullName id = A.name ^ ("-" ^ (A.Id.toString id)) - end) -module StringId : Id = - struct - type t = string - external toString : t -> string = "%identity" - external ofString : string -> t = "%identity" - let ofString id = ((Some ((id |> ofString)))[@explicit_arity ]) - end -module A = struct module Id = StringId - type name = string - let name = "A" end -module B = (MakeB)(A) -let test = - match "someId" |> StringId.ofString with - | ((Some (id))[@explicit_arity ]) -> ((Some ((id |> B.fullName))) - [@explicit_arity ]) - | None as none -> none - -module type Printable = sig - type t - val print : Format.formatter -> t -> unit -end - -module type Comparable = sig - type t - val compare : t -> t -> int -end - -module type PrintableComparable = sig - include Printable - include Comparable with type t := t -end - -module type S = Comparable with type t := int - -module type S = sig - type u - include Comparable with type t := u -end - -module type ComparableInt = Comparable with type t = int - -module type CompareInt = ComparableInt with type t := int diff --git a/jscomp/syntax/tests/conversion/reason/docComments.ml b/jscomp/syntax/tests/conversion/reason/docComments.ml deleted file mode 100644 index 4a6a782..0000000 --- a/jscomp/syntax/tests/conversion/reason/docComments.ml +++ /dev/null @@ -1,40 +0,0 @@ -(** The first special comment of the file is the comment associated - to the whole module. *) - - (** The comment for function f *) - let f x y = x + y - - (** This comment is not attached to any element since there is another - special comment just before the next element. *) - - (** Comment for exception My_exception, even with a simple comment - between the special comment and the exception.*) - (* A simple comment. *) - exception My_exception of (int -> int) * int - - (** Comment for type weather *) - type weather = - | Rain of int (** The comment for constructor Rain *) - | Sun (** The comment for constructor Sun *) - - (** The comment for type my_record *) - type my_record = { - foo : int ; (** Comment for field foo *) - bar : string ; (** Comment for field bar *) - } - - (** The comment for module Foo *) - module Foo = - struct - (** The comment for x *) - let x = 0 - (** A special comment in the class, but not associated to any element. *) - end - - (** The comment for module type my_module_type. *) - module type my_module_type = - sig - (* Comment for value x. *) - val x : int - (* ... *) - end diff --git a/jscomp/syntax/tests/conversion/reason/docComments.mli b/jscomp/syntax/tests/conversion/reason/docComments.mli deleted file mode 100644 index bfde148..0000000 --- a/jscomp/syntax/tests/conversion/reason/docComments.mli +++ /dev/null @@ -1,70 +0,0 @@ -(** The first special comment of the file is the comment associated - with the whole module.*) - - - (** Special comments can be placed between elements and are kept - by the OCamldoc tool, but are not associated to any element. - @-tags in these comments are ignored.*) - - (*******************************************************************) - (** Comments like the one above, with more than two asterisks, - are ignored. *) - - (** The comment for function f. *) - val f : int -> int -> int - (** The continuation of the comment for function f. *) - - (** Comment for exception My_exception, even with a simple comment - between the special comment and the exception.*) - (* Hello, I'm a simple comment :-) *) - exception My_exception of (int -> int) * int - - (** Comment for type weather *) - type weather = - | Rain of int (** The comment for constructor Rain *) - | Sun (** The comment for constructor Sun *) - - (** Comment for type weather2 *) - type weather2 = - | Rain of int (** The comment for constructor Rain *) - | Sun (** The comment for constructor Sun *) - (** I can continue the comment for type weather2 here - because there is already a comment associated to the last constructor.*) - - (** The comment for type my_record *) - type my_record = { - foo : int ; (** Comment for field foo *) - bar : string ; (** Comment for field bar *) - } - (** Continuation of comment for type my_record *) - - (** Comment for foo *) - val foo : string - (** This comment is associated to foo and not to bar. *) - val bar : string - (** This comment is associated to bar. *) - - (** The comment for module Foo *) - module Foo : - sig - (** The comment for x *) - val x : int - - (** A special comment that is kept but not associated to any element *) - end - - (** The comment for module type my_module_type. *) - module type my_module_type = - sig - (** The comment for value x. *) - val x : int - - (** The comment for module M. *) - module M : - sig - (** The comment for value y. *) - val y : int - - (* ... *) - end - end diff --git a/jscomp/syntax/tests/conversion/reason/docComments.res b/jscomp/syntax/tests/conversion/reason/docComments.res deleted file mode 100644 index 2628830..0000000 --- a/jscomp/syntax/tests/conversion/reason/docComments.res +++ /dev/null @@ -1,11 +0,0 @@ -@ocaml.doc(" foo ") -let x = 1 - -@ocaml.doc("") -let x = 1 - -/* ** foo */ -let x = 1 - -/* **** foo */ -let x = 1 diff --git a/jscomp/syntax/tests/conversion/reason/expected/attributes.res.txt b/jscomp/syntax/tests/conversion/reason/expected/attributes.res.txt deleted file mode 100644 index ff549e3..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/attributes.res.txt +++ /dev/null @@ -1,22 +0,0 @@ -module Color: { - type t = private string - - @inline("red") let red: t - @inline("black") let black: t -} = { - type t = string - - @inline let red = "red" - @inline let black = "black" -} - -@send external map: (array<'a>, 'a => 'b) => array<'b> = "map" -@send external filter: (array<'a>, 'a => 'b) => array<'b> = "filter" -list{1, 2, 3}->map(a => a + 1)->filter(a => modulo(a, 2) == 0)->Js.log - -type t -@new external make: unit => t = "DOMParser" -@bs.send.pipe(: t) -external parseHtmlFromString: (string, @as("text/html") _) => Dom.htmlDocument = "parseFromString" - -Js.log(make() |> parseHtmlFromString("sdsd")) diff --git a/jscomp/syntax/tests/conversion/reason/expected/bracedJsx.res.txt b/jscomp/syntax/tests/conversion/reason/expected/bracedJsx.res.txt deleted file mode 100644 index b49e82f..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/bracedJsx.res.txt +++ /dev/null @@ -1,147 +0,0 @@ -open Belt - -type action = - | RunCommand - | SetValue(string) - -type line = - | User(string) - | System(string) - -type state = { - history: array, - input: string, -} - -module Styles = { - open Css - let terminal = style(list{ - margin(10->px), - backgroundColor("222"->hex), - borderRadius(10->px), - padding(10->px), - color("fff"->hex), - height(300->px), - overflowY(auto), - fontFamily(#custom(Theme.codeFontFamily)), - unsafe("WebkitOverflowScrolling", "touch"), - }) - let line = style(list{whiteSpace(#preWrap)}) - let input = style(list{ - backgroundColor("222"->hex), - fontFamily(#custom(Theme.codeFontFamily)), - color("fff"->hex), - fontSize(16->px), - borderWidth(zero), - margin(zero), - padding(zero), - outlineStyle(none), - }) - let title = style(list{ - fontSize(48->px), - fontWeight(extraBold), - marginTop(20->px), - marginBottom(20->px), - textAlign(center), - }) -} - -@react.component -let make = () => { - let containerRef = React.useRef(Js.Nullable.null) - - let (state, send) = React.useReducer((state, action) => - switch action { - | RunCommand => { - input: "", - history: Array.concat( - state.history, - [ - User(state.input), - switch state.input->Js.String.trim { - | "" => System("") - | "help" => - System(`available commands: -- help -- ls -- cat `) - | "ls" => - System(`- hack-website.sh -- go-to-home.sh -- nuclear-codes.txt`) - | "cat" => System("cat: missing argument") - | "cat hack-website.sh" - | "cat ./hack-website.sh" => - System("# seriously?\necho \"lol\"") - | "hack-website.sh" - | "./hack-website.sh" => - System("lol") - | "cat nuclear-codes.txt" - | "cat ./nuclear-codes.txt" => - System("000000") - | "go-to-home.sh" - | "./go-to-home.sh" => - Js.Global.setTimeout(() => ReasonReact.Router.push("/"), 1_000)->ignore - System("Redirecting ...") - | "cat go-to-home.sh" - | "cat ./go-to-home.sh" => - System("ReasonReact.Router.push(\"/\")") - | _ => System("command not found: " ++ (state.input ++ "\ntry command 'help'")) - }, - ], - ), - } - | SetValue(input) => {...state, input} - } - , {history: [], input: ""}) - - React.useEffect1(() => { - switch containerRef.current->Js.Nullable.toOption { - | Some(containerRef) => - open Webapi.Dom - containerRef->Element.setScrollTop(containerRef->Element.scrollHeight->float_of_int) - | None => () - } - None - }, [state.history]) - - let userPrefix = "~ " - -
{"Erreur"->ReasonReact.string}
-
(event->ReactEvent.Mouse.target)["querySelector"]("input")["focus"]()} - ref={containerRef->ReactDOMRe.Ref.domRef}> - {state.history - ->Array.mapWithIndex((index, item) => -
- {ReasonReact.string( - switch item { - | User(value) => userPrefix ++ value - | System(value) => value - }, - )} -
- ) - ->ReasonReact.array} -
- {userPrefix->ReasonReact.string} - { send(SetValue((event->ReactEvent.Form.target)["value"]))} - onKeyDown={event => { - if event->ReactEvent.Keyboard.key == "Enter" { - send(RunCommand) - } - if event->ReactEvent.Keyboard.key == "Tab" { - event->ReactEvent.Keyboard.preventDefault - } - }} - />->ReasonReact.cloneElement(~props={"autoCapitalize": "off"}, [])} -
-
-
-} diff --git a/jscomp/syntax/tests/conversion/reason/expected/braces.res.txt b/jscomp/syntax/tests/conversion/reason/expected/braces.res.txt deleted file mode 100644 index 0a3e335..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/braces.res.txt +++ /dev/null @@ -1,24 +0,0 @@ -let f = () => id -let f = () => id - -if isArray(children) { - // Scenario 1 - let code = children->asStringArray->Js.Array2.joinWith("") - {code->s} -} else if isObject(children) { - // Scenario 2 - children->asElement -} else { - // Scenario 3 - let code = unknownAsString(children) - makeCodeElement(~code, ~metastring, ~lang) -} - -let getDailyNewCases = x => - switch x { - | First(ret) => ret - | Pair({prevRecord, record}) => - let confirmed = record.confirmed - prevRecord.confirmed - let deaths = record.deaths - prevRecord.deaths - {confirmed, deaths} - } diff --git a/jscomp/syntax/tests/conversion/reason/expected/comments.res.txt b/jscomp/syntax/tests/conversion/reason/expected/comments.res.txt deleted file mode 100644 index 948e3ba..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/comments.res.txt +++ /dev/null @@ -1,770 +0,0 @@ -// comment 1 -let /* a */ x /* b */ = /* c */ 1 /* comment 2 */ - -// comment 3 - -// comment 4 -let x = 1 /* 5 */ -/* 6 */ - -let f = ( - // 1 - a, //2 - // 3 - b, -) => { - // 5 - x: 1, // 6 - // 7 - y: 2, // 8 -} -/* **** comment */ -/* ** comment */ -/* comment */ -/* ** comment */ -/* *** comment */ -/* **** comment */ - -/* ** */ -/* *** */ - -/* ** */ - -/* (** comment *) */ -/* (*** comment *) */ -/* *(*** comment *) */ - -/* comment * */ -/* comment ** */ -/* comment *** */ -/* comment **** */ - -let testingNotQuiteEndOfLineComments = list{ - "Item 1" /* Comment For First Item */, - "Item 2" /* Comment For Second Item */, - "Item 3" /* Comment For Third Item */, - "Item 4" /* Comment For Fourth Item - but no semi */, - /* Comment after last item in list. */ -} /* Comment after list bracket */ - -let testingEndOfLineComments = list{ - "Item 1" /* Comment For First Item */, - "Item 2" /* Comment For Second Item */, - "Item 3" /* Comment For Third Item */, - "Item 4" /* Comment For Fourth Item - but before semi */, - /* Comment after last item in list. */ -} /* Comment after list bracket */ - -/* This time no space between bracket and comment */ -let testingEndOfLineComments = list{} /* Comment after list bracket */ - -type t = (int, int) /* End of line on t */ - -type t22 = /* End of t22 line on type t22 = */ -(int, int) - -type variant = - /* Comment above X */ - | X(int) /* End of line on X */ - /* Comment above Y */ - | Y(int) /* End of line on Y */ -/* Comment on entire type def for variant */ - -type rec x = { - /* not attached *above* x */ - fieldOne: int, -} /* Attached end of line after x */ -and y = { - /* not attached *above* y */ - fieldTwo: int, -} /* Attached end of line after y */ - -let result = switch X(3) { -| X(x) => - /* Where does this comment go? */ - let tmp = x - x + tmp -| Y(x) => - /* How about this one */ - let tmp = x - x + tmp -} - -let result = switch None { -| Some({fieldOne: 20}) => - /* Where does this comment go? */ - let tmp = 0 - 2 + tmp -| Some({fieldOne: n}) => - /* How about this one */ - let tmp = n - n + tmp -| None => 20 -} - -type pointWithManyKindsOfComments = { - /* Line before x */ - x: string /* x field */, - /* Line before y */ - y: string /* y field */, - /* Final row of record */ -} - -type typeParamPointWithComments<'a> = { - /* Line before x */ - x: 'a /* x field */, - /* Line before y */ - y: 'a /* y field */, - /* Final row of record */ -} - -let name_equal = (x, y) => x == y - -let equal = (i1, i2) => i1.contents === i2.contents && true /* most unlikely first */ - -let equal = (i1, i2) => compare(compare(0, 0), compare(1, 1)) /* END OF LINE HERE */ - -module Temp = { - let v = true - let logIt = (str, ()) => print_string(str) -} - -let store_attributes = arg => { - let attributes_file = "test" - let proc_name = attributes_file ++ ".proc" - let should_write = - /* only overwrite defined procedures */ - Temp.v || !Temp.v - if should_write { - Temp.logIt(proc_name, ()) - } -} -3 // - -3 //- - -3 //- - -3 /* - */ -// **** comment -/* ** comment */ -@ocaml.doc(" docstring ") -@ocaml.doc(" docstring ") -@ocaml.doc(" ") -@ocaml.doc("") -@ocaml.doc(" (** comment *) ") -@ocaml.doc(" (*** comment *) ") -@ocaml.doc(" - * Multiline - ") -@ocaml.doc(" Multiline - * - ") -@ocaml.doc(" - ** - ") -module // comment - -/* ** comment */ -/* *** comment */ -/* **** comment */ - -/* ** */ -/* *** */ - -/* ** */ - -// (** comment *) -// (*** comment *) -// *(*** comment *) -// comment * -// comment ** -// comment *** -// comment **** - -JustString = { - include Map.Make(Int32) // Comment eol include -} - -let testingEndOfLineComments = list{ - "Item 1" /* Comment For First Item */, - "Item 2" /* Comment For Second Item */, - "Item 3" /* Comment For Third Item */, - "Item 4" /* Comment For Fourth Item - but before trailing comma */, - // Comment after last item in list. -} /* Comment after rbracket */ - -// But if you place them after the comma at eol, they're preserved as such -let testingEndOfLineComments = list{ - "Item 1", // Comment For First Item - "Item 2", // Comment For Second Item - "Item 3", // Comment For Third Item - "Item 4" /* Comment For Fourth Item - but before trailing comma */, - // Comment after last item in list. -} /* Comment after rbracket */ - -// The space between ; and comment shoudn't matter -let testPlacementOfTrailingComment = list{ - "Item 0", - // Comment after last item in list. -} // Comment after semi - -// The space between ; and comment shoudn't matter -let testPlacementOfTrailingComment = list{ - "Item 0", - // Comment after last item in list. -} // Comment after semi - -// Try again but without other things in the list -let testPlacementOfTrailingComment = list{"Item 0"} // Comment after semi - -// The space between ; and comment shoudn't matter -let testPlacementOfTrailingComment = list{ - "Item 0", - // Comment after last item in list. -} // Comment after semi - -let testingEndOfLineComments = list{} // Comment after entire let binding - -// The following is not yet idempotent -// let myFunction -// withFirstArg // First arg -// andSecondArg => { // Second Arg -// withFirstArg + andSecondArg /* before semi */ ; -// }; - -let myFunction = // First arg -( - withFirstArg, - // Second Arg - andSecondArg, -) => withFirstArg + andSecondArg // After Semi - -type point = { - x: string, // x field - y: string, // y field -} - -type pointWithManyKindsOfComments = { - // Line before x - x: string, // x field - // Line before y - y: string, // y field - // Final row of record -} - -type typeParamPointWithComments<'a> = { - // Line before x - x: 'a, // x field - // Line before y - y: 'a, // y field - // Final row of record -} - -// Now, interleaving comments in type params -// Type name -type typeParamPointWithComments2< - 'a, - // The b type apram - 'b, -> = { - // Line before x - x: 'a, // x field - // Line before y - y: 'a, // y field - // Final row of record -} - -/* The way the last row comment is formatted is suboptimal becuase - * record type definitions do not include enough location information */ -type anotherpoint = { - x: string, // x field - y: string, // y field - // comment as last row of record -} - -type t = (int, int) // End of line on t -type t2 = (int, int) // End of line on (int, int) - -type t3 = (int, int) // End of line on (int, int) - -type variant = - | X(int, int) // End of line on X - | Y(int, int) // End of line on Y -// Comment on entire type def for variant - -// Before let -let res = // Before switch -switch X(2, 3) { -// Above X line -| X(_) => "result of X" // End of arrow and X line -// Above Y line -| Y(_) => "result of Y" // End of arrow and Y line -} // After final semi in switch - -let res = switch X(2, 3) { -| X(0, 0) => // After X arrow - "result of X" // End of X body line -| X(1, 0) /* Before X's arrow */ => "result of X" // End of X body line -| X(_) => // After X _ arrow - "result of X" // End of X body line -// Above Y line -| Y(_) => // Comment above Y body - "result of Y" -} - -type variant2 = - // Comment above X - | X(int, int) // End of line on X - // Comment above Y - | Y(int, int) - -type variant3 = - // Comment above X - | X(int, int) // End of line on X - // Comment above Y - | Y(int, int) // End of line on Y - -type rec x = { - // not attached *above* x - fieldOne: int, - fieldA: int, -} // Attached end of line after x -and y = { - // not attached *above* y - fieldTwo: int, -} // Attached end of line after y - -type rec x2 = { - // not attached *above* x2 - fieldOne: int, - fieldA: int, -} // Attached end of line after x2 -and y2 = { - // not attached *above* y2 - fieldTwo: int, -} - -let result = switch None { -| Some({fieldOne: 20, fieldA: a}) => - // Where does this comment go? - let tmp = 0 - 2 + tmp -| Some({fieldOne: n, fieldA: a}) => - // How about this one - let tmp = n - n + tmp -| None => 20 -} - -let res = // Before switch -switch X(2, 3) { -// Above X line -| X(_) => "result of X" // End of arrow and X line -// Above Y line -| Y(_) => "result of Y" // End of arrow and Y line -} - -/* - * Now these end of line comments *should* be retained. - */ -let result = switch None { -| Some({fieldOne: 20, fieldA: a}) => - let tmp = 0 - 2 + tmp -| Some({fieldOne: n, fieldA: a}) => - let tmp = n - n + tmp -| None => 20 -} - -/* - * These end of line comments *should* be retained. - * To get the simple expression eol comment to be retained, we just need to - * implement label breaking eol behavior much like we did with sequences. - * Otherwise, right now they are not idempotent. - */ -let res = switch X(2, 3) { -// Above X line -| X(_, _) => "result of X" // retain this // retain this - -// Above Y line -| Y(_) => "result of Y" // End of arrow and Y line -} - -/* type optionalTuple = */ -/* | OptTup( */ -/* option( */ -/* ( */ -/* int, */ -/* int */ -/* ), */ -/* ), */ -/* ); */ - -type optionTuple = option<(int, int)> // First int // Second int - -type intPair = (int, int) // First int // Second int - -type intPair2 = ( - // First int - int, - // Second int - int, -) - -let result = @ocaml.doc("") (2 + 3) - -// This is not yet idempotent -// { -// /**/ -// (+) 2 3 -// }; - -let a = () -for i in 0 to 10 { - // bla - a -} - -if true { - () -} - -type color = - | Red(int) // After red end of line - | Black(int) // After black end of line - | Green(int) // After green end of line -// On next line after color type def - -let blahCurriedX = (x, x) => - switch x { - | Red(10) - | Black(20) - | Green(10) => 1 // After or pattern green - | Red(x) => 0 // After red - | Black(x) => 0 // After black - | Green(x) => 0 - } // After second green -// On next line after blahCurriedX def - -let name_equal = (x, y) => x == y - -let equal = (i1, i2) => i1.contents === i2.contents && true // most unlikely first - -let equal = (i1, i2) => compare(compare(0, 0), compare(1, 1)) // END OF LINE HERE - -let tuple_equal = ((i1, i2)) => i1 == i2 - -let tuple_equal = ((csu, mgd)) => - // Some really long comments, see https://github.com/facebook/reason/issues/811 - tuple_equal((csu, mgd)) - -let trueThing = true - -for i in 0 to 1 { - // comment - print_newline() -} - -while trueThing { - // comment - print_newline() -} - -if trueThing { - // comment - print_newline() -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} else { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} else { - // Comment before print - print_newline() -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() - // Comment before print - print_newline() - // Comment after final print -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() -} - -if trueThing { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} else { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} - -// Comment before if test -if trueThing { - // Comment before print - print_newline() -} else { - // Comment before print - print_newline() // eol print - // Comment before print - print_newline() // eol print - // Comment after print -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() // eol - // Comment before print - print_newline() // eol - // Comment after final print -} - -// Comment before while test -while trueThing { - // Comment before print - print_newline() -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() // eol - // Comment before print - print_newline() // eol - // Comment after final print -} - -// Comment before for test -for i in 0 to 100 { - // Comment before print - print_newline() -} - -let f = (a, b, c, d) => a + b + c + d - -while trueThing { - f( - // a - 1, - // b - 2, - // c - 3, - // d - 4, - // does work - ) -} -while trueThing { - f( - // a - 1, - // b - 2, - // c - 3, - // d - 4, // does work - ) -} - -ignore((_really, _long, _printWidth, _exceeded, _here) => { - // First comment - let x = 0 - x + x - // Closing comment -}) - -ignore((_xxx, _yyy) => { - // First comment - let x = 0 - x + x - // Closing comment -}) - -type tester<'a, 'b> = - | TwoArgsConstructor('a, 'b) - | OneTupleArgConstructor(('a, 'b)) -let callFunctionTwoArgs = (a, b) => () -let callFunctionOneTuple = tuple => () - -let y = TwoArgsConstructor(1, 2) //eol1 // eol2 - -let y = callFunctionTwoArgs(1, 2) //eol1 // eol2 - -let y = OneTupleArgConstructor((1, 2)) //eol1 // eol2 - -let y = callFunctionOneTuple((1, 2)) //eol1 // eol2 - -type polyRecord<'a, 'b> = { - fieldOne: 'a, - fieldTwo: 'b, -} - -let r = { - fieldOne: 1, //eol1 - fieldTwo: 2, // eol2 -} - -let r = { - fieldOne: 1, //eol1 - fieldTwo: 2, // eol2 with trailing comma -} - -let y = TwoArgsConstructor("1", "2") //eol1 // eol2 - -let y = callFunctionTwoArgs("1", "2") //eol1 // eol2 - -let y = OneTupleArgConstructor(("1", "2")) //eol1 // eol2 - -let y = callFunctionOneTuple(("1", "2")) //eol1 // eol2 - -let r = { - fieldOne: "1", //eol1 - fieldTwo: "2", // eol2 -} - -let r = { - fieldOne: "1", //eol1 - fieldTwo: "2", // eol2 with trailing comma -} - -let identifier = "hello" - -let y = TwoArgsConstructor(identifier, identifier) //eol1 // eol2 - -let y = callFunctionTwoArgs(identifier, identifier) //eol1 // eol2 - -let y = OneTupleArgConstructor((identifier, identifier)) //eol1 // eol2 - -let y = callFunctionOneTuple((identifier, identifier)) //eol1 // eol2 - -let r = { - fieldOne: identifier, //eol1 - fieldTwo: identifier, // eol2 -} - -let r = { - fieldOne: identifier, //eol1 - fieldTwo: identifier, // eol2 with trailing comma -} - -let y = TwoArgsConstructor((identifier: string), (identifier: string)) //eol1 // eol2 - -let y = callFunctionTwoArgs((identifier: string), (identifier: string)) //eol1 // eol2 - -let y = OneTupleArgConstructor(((identifier: string), (identifier: string))) //eol1 // eol2 - -let y = callFunctionOneTuple(((identifier: string), (identifier: string))) //eol1 // eol2 - -let r = { - fieldOne: (identifier: string), //eol1 - fieldTwo: (identifier: string), // eol2 -} - -let r = { - fieldOne: (identifier: string), //eol1 - fieldTwo: (identifier: string), // eol2 with trailing comma -} - -// whitespace interleaving - -// comment1 -// comment2 - -// whitespace above & below - -let r = { - fieldOne: (identifier: string), //eol1 - // c1 - - // c2 - - // c3 - // c4 - - // c5 - fieldTwo: (identifier: string), // eol2 with trailing comma -} -// trailing - -// trailing whitespace above -// attach - -// last comment diff --git a/jscomp/syntax/tests/conversion/reason/expected/destructiveSubstitutionSubModules.ml.txt b/jscomp/syntax/tests/conversion/reason/expected/destructiveSubstitutionSubModules.ml.txt deleted file mode 100644 index 81c1f50..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/destructiveSubstitutionSubModules.ml.txt +++ /dev/null @@ -1,60 +0,0 @@ -module type Id = { - type t - let toString: t => string - let ofString: string => option -} -module type A = { - module Id: Id - type name = string - let name: name -} -module type B = { - module A: A - let fullName: A.Id.t => string -} -module MakeB = (A: A): (B with module A.Id := A.Id) => { - module A = A - let fullName = id => A.name ++ ("-" ++ A.Id.toString(id)) -} -module StringId: Id = { - type t = string - external toString: t => string = "%identity" - external ofString: string => t = "%identity" - let ofString = id => Some(id |> ofString) -} -module A = { - module Id = StringId - type name = string - let name = "A" -} -module B = MakeB(A) -let test = switch "someId" |> StringId.ofString { -| Some(id) => Some(id |> B.fullName) -| None as none => none -} - -module type Printable = { - type t - let print: (Format.formatter, t) => unit -} - -module type Comparable = { - type t - let compare: (t, t) => int -} - -module type PrintableComparable = { - include Printable - include Comparable with type t := t -} - -module type S = Comparable with type t := int - -module type S = { - type u - include Comparable with type t := u -} - -module type ComparableInt = Comparable with type t = int - -module type CompareInt = ComparableInt with type t := int diff --git a/jscomp/syntax/tests/conversion/reason/expected/docComments.ml.txt b/jscomp/syntax/tests/conversion/reason/expected/docComments.ml.txt deleted file mode 100644 index 7b31e47..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/docComments.ml.txt +++ /dev/null @@ -1,40 +0,0 @@ -@@ocaml.text(" The first special comment of the file is the comment associated - to the whole module. ") - -@ocaml.doc(" The comment for function f ") -let f = (x, y) => x + y - -@@ocaml.text(" This comment is not attached to any element since there is another - special comment just before the next element. ") - -/* A simple comment. */ -@ocaml.doc(" Comment for exception My_exception, even with a simple comment - between the special comment and the exception.") -exception My_exception(int => int, int) - -@ocaml.doc(" Comment for type weather ") -type weather = - | @ocaml.doc(" The comment for constructor Rain ") Rain(int) - | @ocaml.doc(" The comment for constructor Sun ") Sun - -@ocaml.doc(" The comment for type my_record ") -type my_record = { - @ocaml.doc(" Comment for field foo ") - foo: int, - @ocaml.doc(" Comment for field bar ") - bar: string, -} - -@ocaml.doc(" The comment for module Foo ") -module Foo = { - @ocaml.doc(" The comment for x ") - @ocaml.doc(" A special comment in the class, but not associated to any element. ") - let x = 0 -} - -@ocaml.doc(" The comment for module type my_module_type. ") -module type my_module_type = { - /* Comment for value x. */ - let x: int - /* ... */ -} diff --git a/jscomp/syntax/tests/conversion/reason/expected/docComments.mli.txt b/jscomp/syntax/tests/conversion/reason/expected/docComments.mli.txt deleted file mode 100644 index 1ca939e..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/docComments.mli.txt +++ /dev/null @@ -1,69 +0,0 @@ -@@ocaml.text(" The first special comment of the file is the comment associated - with the whole module.") - -@@ocaml.text(" Special comments can be placed between elements and are kept - by the OCamldoc tool, but are not associated to any element. - @-tags in these comments are ignored.") - -@@ocaml.text(/* ***************************************************************** */ -" Comments like the one above, with more than two asterisks, - are ignored. ") - -@ocaml.doc(" The comment for function f. ") -@ocaml.doc(" The continuation of the comment for function f. ") -let f: (int, int) => int - -/* Hello, I'm a simple comment :-) */ -@ocaml.doc(" Comment for exception My_exception, even with a simple comment - between the special comment and the exception.") -exception My_exception(int => int, int) - -@ocaml.doc(" Comment for type weather ") -type weather = - | @ocaml.doc(" The comment for constructor Rain ") Rain(int) - | @ocaml.doc(" The comment for constructor Sun ") Sun - -@ocaml.doc(" Comment for type weather2 ") -@ocaml.doc(" I can continue the comment for type weather2 here - because there is already a comment associated to the last constructor.") -type weather2 = - | @ocaml.doc(" The comment for constructor Rain ") Rain(int) - | @ocaml.doc(" The comment for constructor Sun ") Sun - -@ocaml.doc(" The comment for type my_record ") -@ocaml.doc(" Continuation of comment for type my_record ") -type my_record = { - @ocaml.doc(" Comment for field foo ") - foo: int, - @ocaml.doc(" Comment for field bar ") - bar: string, -} - -@ocaml.doc(" Comment for foo ") @ocaml.doc(" This comment is associated to foo and not to bar. ") -let foo: string - -@ocaml.doc(" This comment is associated to foo and not to bar. ") -@ocaml.doc(" This comment is associated to bar. ") -let bar: string - -@ocaml.doc(" The comment for module Foo ") -module Foo: { - @ocaml.doc(" The comment for x ") - let x: int - - @@ocaml.text(" A special comment that is kept but not associated to any element ") -} - -@ocaml.doc(" The comment for module type my_module_type. ") -module type my_module_type = { - @ocaml.doc(" The comment for value x. ") - let x: int - - @ocaml.doc(" The comment for module M. ") - module M: { - @ocaml.doc(" The comment for value y. ") - let y: int - - /* ... */ - } -} diff --git a/jscomp/syntax/tests/conversion/reason/expected/docComments.res.txt b/jscomp/syntax/tests/conversion/reason/expected/docComments.res.txt deleted file mode 100644 index 2628830..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/docComments.res.txt +++ /dev/null @@ -1,11 +0,0 @@ -@ocaml.doc(" foo ") -let x = 1 - -@ocaml.doc("") -let x = 1 - -/* ** foo */ -let x = 1 - -/* **** foo */ -let x = 1 diff --git a/jscomp/syntax/tests/conversion/reason/expected/extension.res.txt b/jscomp/syntax/tests/conversion/reason/expected/extension.res.txt deleted file mode 100644 index 0a6ff92..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/extension.res.txt +++ /dev/null @@ -1,10 +0,0 @@ -// here -%%raw(` eval( -__gc, -1, -0 -) - `) - -let x = %raw("10") -let y = %raw("20") diff --git a/jscomp/syntax/tests/conversion/reason/expected/fastPipe.res.txt b/jscomp/syntax/tests/conversion/reason/expected/fastPipe.res.txt deleted file mode 100644 index a7007b6..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/fastPipe.res.txt +++ /dev/null @@ -1,24 +0,0 @@ -a->f(b, c)->g(d, e) - -Element.querySelectorAll(selector, element) -->NodeList.toArray -->Array.keepMap(Element.ofNode) -->Array.getBy(node => node->Element.textContent === content) - -let x = @attr ((@attr2 a)->f(b)->c(d)) - -5->doStuff(3, _, 7) - -(event->target)["value"] - -(Route.urlToRoute(url)->ChangeView->self).send -Route.urlToRoute(url)->ChangeView->self.send - -let aggregateTotal = (forecast, ~audienceType) => - Js.Nullable.toOption(forecast["audiences"]) - ->Option.flatMap(item => Js.Dict.get(item, audienceType)) - ->Option.map(item => { - pages: item["reach"]["pages"], - views: item["reach"]["views"], - sample: item["reach"]["sample"], - }) diff --git a/jscomp/syntax/tests/conversion/reason/expected/gentype.res.txt b/jscomp/syntax/tests/conversion/reason/expected/gentype.res.txt deleted file mode 100644 index 0ce4deb..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/gentype.res.txt +++ /dev/null @@ -1,28 +0,0 @@ -module M: { - @genType @after - type t - - @genType @after - let x: int - - @foo - type e = .. -} = { - type t - let x = 34 - type e = .. -} - -module type MT = { - @genType @after - type t - - @genType @after - let x: int - - @foo - type e = .. -} - -@genType("ddd") -let x = 42 diff --git a/jscomp/syntax/tests/conversion/reason/expected/gentype.resi.txt b/jscomp/syntax/tests/conversion/reason/expected/gentype.resi.txt deleted file mode 100644 index 90cc39f..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/gentype.resi.txt +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let x: int diff --git a/jscomp/syntax/tests/conversion/reason/expected/jsObject.res.txt b/jscomp/syntax/tests/conversion/reason/expected/jsObject.res.txt deleted file mode 100644 index 0c591da..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/jsObject.res.txt +++ /dev/null @@ -1,26 +0,0 @@ -let component = props["Component"] - -let element = props["element"] - -let y = {"age": 30} -let y = {"age": 30, "name": "steve"} - -type propField<'a> = {.} -type propField<'a> = {..} as 'a -type propField<'a> = {..} as 'a -type propField<'a> = Js.nullable<{..} as 'a> - -type propField<'a> = {"a": b} -type propField<'a> = {.."a": b} -type propField<'a> = {"a": {"b": c}} - -user["address"] -user["address"]["street"] -user["address"]["street"]["log"] - -user["address"] = "Avenue 1" -user["address"]["street"] = "Avenue" -user["address"]["street"]["number"] = "1" - -school["print"](direction["name"], studentHead["name"]) -city["getSchool"]()["print"](direction["name"], studentHead["name"]) diff --git a/jscomp/syntax/tests/conversion/reason/expected/jsObject.resi.txt b/jscomp/syntax/tests/conversion/reason/expected/jsObject.resi.txt deleted file mode 100644 index f9ca82b..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/jsObject.resi.txt +++ /dev/null @@ -1,8 +0,0 @@ -type propField<'a> = {.} -type propField<'a> = {..} as 'a -type propField<'a> = {..} as 'a -type propField<'a> = Js.nullable<{..} as 'a> - -type propField<'a> = {"a": b} -type propField<'a> = {.."a": b} -type propField<'a> = {"a": {"b": c}} diff --git a/jscomp/syntax/tests/conversion/reason/expected/jsxProps.res.txt b/jscomp/syntax/tests/conversion/reason/expected/jsxProps.res.txt deleted file mode 100644 index d368bc9..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/jsxProps.res.txt +++ /dev/null @@ -1,17 +0,0 @@ -let handleClick = (href, event) => - if !ReactEvent.Mouse.defaultPrevented(event) { - ReactEvent.Mouse.preventDefault(event) - ReasonReact.Router.push(href) - } - -@react.component -let make = (~href, ~className="", ~children) => - handleClick(href, event)}> children - - ...{x =>
} - -
...element
-
...{a => 1}
-
...
-
...[a, b]
-
...{(1, 2)}
diff --git a/jscomp/syntax/tests/conversion/reason/expected/letBinding.res.txt b/jscomp/syntax/tests/conversion/reason/expected/letBinding.res.txt deleted file mode 100644 index 525c159..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/letBinding.res.txt +++ /dev/null @@ -1,14 +0,0 @@ -let deltaMode: t => Webapi__Dom__Types.deltaMode = self => - Webapi__Dom__Types.decodeDeltaMode(deltaMode(self)) - -let fromJs: ResourceIo.campaignWeeklyPlanning => t = weeklyPlanning => ( - weeklyPlanning["monday"]->dayFromJs, - weeklyPlanning["tuesday"]->dayFromJs, - weeklyPlanning["wednesday"]->dayFromJs, - weeklyPlanning["thursday"]->dayFromJs, - weeklyPlanning["friday"]->dayFromJs, - weeklyPlanning["saturday"]->dayFromJs, - weeklyPlanning["sunday"]->dayFromJs, -) - -let newChapter: Video.chapter = {startTime: percent *. duration} diff --git a/jscomp/syntax/tests/conversion/reason/expected/letprivate.res.txt b/jscomp/syntax/tests/conversion/reason/expected/letprivate.res.txt deleted file mode 100644 index d8b86ef..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/letprivate.res.txt +++ /dev/null @@ -1 +0,0 @@ -%%private(let x = 34) diff --git a/jscomp/syntax/tests/conversion/reason/expected/modType.res.txt b/jscomp/syntax/tests/conversion/reason/expected/modType.res.txt deleted file mode 100644 index 260265c..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/modType.res.txt +++ /dev/null @@ -1,15 +0,0 @@ -module Same = (Na: N, Nb: N): ((S with type number1 = Na.number) with type number2 = Nb.number) => { - type number1 = Na.number - type number2 = Nb.number - let rec sim = ((n, m)) => - if Na.is_zero(n) { - Nb.is_zero(m) - } else { - sim((Na.pred(n), Nb.pred(m))) - } - let similar = ((n, m)) => - try sim((n, m)) catch { - | Na.Too_small => false - | Nb.Too_small => false - } -} diff --git a/jscomp/syntax/tests/conversion/reason/expected/moduleLanguage.res.txt b/jscomp/syntax/tests/conversion/reason/expected/moduleLanguage.res.txt deleted file mode 100644 index 724dfc6..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/moduleLanguage.res.txt +++ /dev/null @@ -1 +0,0 @@ -let someFunctorAsFunction = (x: module(MT)): module(ResT) => module(SomeFunctor(unpack(x))) diff --git a/jscomp/syntax/tests/conversion/reason/expected/namedArgs.res.txt b/jscomp/syntax/tests/conversion/reason/expected/namedArgs.res.txt deleted file mode 100644 index eb0d820..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/namedArgs.res.txt +++ /dev/null @@ -1,63 +0,0 @@ -let wizard = Wizard.make( - ~spriteSheet=wizard, - ~hp=999999999999999, - ~mp=50, - //~coordinates={x: 0., y:0. z: 0.}, - ~coordinates={x: 40, y: 100., z: 0.}, - // /* c0 */ ~gpuCoordinates= /* c1 */ gpuBuffer[10] /* c2 */, // trailing -) - -apply( - // above - ~aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa, - // below - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb, - // here - ~cccccccccccccccccccccccccccccccc, -) - -applyOptional( - // above - ~aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa?, - // below - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb?, - // here - ~cccccccccccccccccccccccccccccccc?, -) - -foo( - // c0 - ~aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: int, - // c1 - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbb: int, - // c2 - ~cccccccccccccccccccccccccccccc: int, -) - -let f = ( - ~isItemActive=?, - // array((name, href)) - ~headers: array<(string, string)>, - ~moduleName: string, - // foo - ~x, - // above - /* c0 */ ~d: /* c1 */ e, // end - ~from as // does it work - hometown, -) => { - let a = 1 - let b = 2 - a + b -} - -@react.component -let make = ( - ~theme: ColorTheme.t, - ~components: Mdx.Components.t, - ~sidebarState: (bool, (bool => bool) => unit), - // (Sidebar, toggleSidebar) ... for toggling sidebar in mobile view - ~sidebar: React.element, - ~breadcrumbs: option>=?, - ~children, -) => () diff --git a/jscomp/syntax/tests/conversion/reason/expected/object.ml.txt b/jscomp/syntax/tests/conversion/reason/expected/object.ml.txt deleted file mode 100644 index 3afee67..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/object.ml.txt +++ /dev/null @@ -1,4 +0,0 @@ -type hi = {"z": int} -type u<'a> = {.. ...hi, "x": int, "y": int} as 'a -type u1<'a> = {.. ...hi} as 'a -type u2<'a> = {.. ...hi, ...hi, "y": int, ...hi} as 'a diff --git a/jscomp/syntax/tests/conversion/reason/expected/openPattern.res.txt b/jscomp/syntax/tests/conversion/reason/expected/openPattern.res.txt deleted file mode 100644 index 2855827..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/openPattern.res.txt +++ /dev/null @@ -1,23 +0,0 @@ -let {T.a: a} = a() -let [Color.Blue] = a() -let list{Color.Blue} = a() -let (Color.Blue, Red) = a() - -let Color.Blue = blue - -module Color = { - type t = Red | Blue | Green - let red = Red - let blue = Blue - let green = Green -} - -let () = switch (Color.red, Color.blue, Color.green) { -| (Color.Red, Blue, Green) => Js.log("hello world") -| _ => () -} - -let () = switch [Color.red, Color.blue, Color.green] { -| [Color.Red, Blue, Green] => Js.log("hello world") -| _ => () -} diff --git a/jscomp/syntax/tests/conversion/reason/expected/ppx.res.txt b/jscomp/syntax/tests/conversion/reason/expected/ppx.res.txt deleted file mode 100644 index 3f0dda1..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/ppx.res.txt +++ /dev/null @@ -1,55 +0,0 @@ -%graphql( - ` - query Site { - site { - siteMetadata { - title - description - siteUrl - } - } - } -` - {taggedTemplate: false} -) - -module Form = %form( - type input = { - name: string, - email: string, - message: string, - @as("form-name") - formName: string, - } - type output = input - let validators = { - name: { - strategy: OnFirstBlur, - validate: ({name, _}) => - switch name { - | "" => Error("Name is required.") - | name => Ok(name) - }, - }, - email: { - strategy: OnFirstBlur, - validate: ({email, _}) => - switch email { - | "" => Error("Email is required.") - | email => Ok(email) - }, - }, - message: { - strategy: OnFirstBlur, - validate: ({message, _}) => - switch message { - | "" => Error("Message is required.") - | message => Ok(message) - }, - }, - formName: { - strategy: OnSubmit, - validate: ({formName, _}) => Ok(formName), - }, - } -) diff --git a/jscomp/syntax/tests/conversion/reason/expected/recursiveType.ml.txt b/jscomp/syntax/tests/conversion/reason/expected/recursiveType.ml.txt deleted file mode 100644 index b77962f..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/recursiveType.ml.txt +++ /dev/null @@ -1,3 +0,0 @@ -type rec tree = {"label": string, "left": option, "right": option} - -type t = t diff --git a/jscomp/syntax/tests/conversion/reason/expected/refSugar.ml.txt b/jscomp/syntax/tests/conversion/reason/expected/refSugar.ml.txt deleted file mode 100644 index 96255e4..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/refSugar.ml.txt +++ /dev/null @@ -1 +0,0 @@ -let x = foo.contents diff --git a/jscomp/syntax/tests/conversion/reason/expected/refSugarReason.res.txt b/jscomp/syntax/tests/conversion/reason/expected/refSugarReason.res.txt deleted file mode 100644 index 96255e4..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/refSugarReason.res.txt +++ /dev/null @@ -1 +0,0 @@ -let x = foo.contents diff --git a/jscomp/syntax/tests/conversion/reason/expected/singleLineComments.res.txt b/jscomp/syntax/tests/conversion/reason/expected/singleLineComments.res.txt deleted file mode 100644 index c5a75c2..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/singleLineComments.res.txt +++ /dev/null @@ -1,18 +0,0 @@ -// This is the implementation of the _app.js file - -// Resources: -// -------------- -// Really good article on state persistence within layouts: -// https://adamwathan.me/2019/10/17/persistent-layout-patterns-in-nextjs/ - -/* - a - - */ - -/* - a - -*/ -let x = 1 -// here diff --git a/jscomp/syntax/tests/conversion/reason/expected/string.res.txt b/jscomp/syntax/tests/conversion/reason/expected/string.res.txt deleted file mode 100644 index a85d0bb..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/string.res.txt +++ /dev/null @@ -1,36 +0,0 @@ -%%raw("define(x.y, 'userAgent', {value: 'USER_AGENT_STRING'})") - -%%raw("define(x.y, 'userAgent', {value: 'USER_AGENT_STRING'})") - -let x = `This is a long string with a slash and line break \\ -carriage return` - -let x = "\"" -let y = "\n" - -(<> {"\n"->React.string} ) - -// The `//` should not result into an extra comment -let x = j`https://www.apple.com` -let x = `https://www.apple.com` -let x = `https://www.apple.com` -let x = `https://www.apple.com` -let x = sql`https://www.apple.com` - -// /* */ should not result in an extra comments -let x = j`/* https://www.apple.com */` -let x = `/* https://www.apple.com*/` -let x = `/*https://www.apple.com*/` -let x = `/*https://www.apple.com*/` -let x = sql`/*https://www.apple.com*/` - -let x = `\`https://\${appleWebsite}\`` - -let var1 = "three" -let var2 = "a string" - -switch (var1, var2) { -| (`3`, `a string`) => Js.log("worked") -| (` test with \` \${here} \``, _) => Js.log("escapes ` and ${") -| _ => Js.log("didn't match") -} diff --git a/jscomp/syntax/tests/conversion/reason/expected/ternary.res.txt b/jscomp/syntax/tests/conversion/reason/expected/ternary.res.txt deleted file mode 100644 index 3c90de0..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/ternary.res.txt +++ /dev/null @@ -1 +0,0 @@ -let a = x ? 1 : 2 diff --git a/jscomp/syntax/tests/conversion/reason/expected/uncurrried.res.txt b/jscomp/syntax/tests/conversion/reason/expected/uncurrried.res.txt deleted file mode 100644 index 48283a4..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/uncurrried.res.txt +++ /dev/null @@ -1,64 +0,0 @@ -// ok -let updateBriefletNarrative = (. updateObj) => Js.log("patented merge algorithm goes here") - -// this is a bug in Reason, the . will be parsed wrong and disappear. -/* updateBriefletNarrative(. briefletNarrativeUpdateObj); */ - -// this is a bug in Reason, the . will be parsed wrong and disappear. -/* foo(. 3); */ - -module D = { - // this is a bug in Reason, the . will be parsed wrong and disappear. - /* foo(. 3); */ -} - -// ok -let x = foo(. 3) - -let x = { - let a = 3 - // ok - foo(. a) -} - -let x = { - // ok - let f = (. a, b) => apply(. a + b) - let a = 3 - // ok - foo(. a) - // ok - f(. 2, 2) -} - -// ok -let () = switch something(. x, y) { -| None => - // ok - log(. a, b) -| Some(_) => - let a = 1 - // ok - log(. a, 2) -} - -let () = { - // ok - let dontDoThisAhome = (. a, b) => (. c, d) => (. e, f) => a + b + c + d + e + f - // ok - dontDoThisAhome(. a, b)(. c, d)(. e, f) -} - -let _ = library.getBalance(. account)->Promise.Js.catch(_ => Promise.resolved(None)) - -let _ = - library.getBalance(. account) - ->Promise.Js.catch(_ => Promise.resolved(None)) - ->Promise.get(newBalance => - dispatch( - LoadAddress( - account, - newBalance->Belt.Option.flatMap(balance => Eth.make(balance.toString(.))), - ), - ) - ) diff --git a/jscomp/syntax/tests/conversion/reason/expected/underscoreSugar.res.txt b/jscomp/syntax/tests/conversion/reason/expected/underscoreSugar.res.txt deleted file mode 100644 index 9330f5c..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/underscoreSugar.res.txt +++ /dev/null @@ -1 +0,0 @@ -let photo = pricedRoom["room"]["photos"] |> filterNone |> Array.get(_, 0) diff --git a/jscomp/syntax/tests/conversion/reason/expected/unicode.res.txt b/jscomp/syntax/tests/conversion/reason/expected/unicode.res.txt deleted file mode 100644 index 332b911..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/unicode.res.txt +++ /dev/null @@ -1,5 +0,0 @@ -let x = "✅ foo bar" - -let x = "\n okokok" - -let z = "\t \b \n okok 🙈" diff --git a/jscomp/syntax/tests/conversion/reason/expected/variant.res.txt b/jscomp/syntax/tests/conversion/reason/expected/variant.res.txt deleted file mode 100644 index 2864a7d..0000000 --- a/jscomp/syntax/tests/conversion/reason/expected/variant.res.txt +++ /dev/null @@ -1 +0,0 @@ -type t = | @foo X diff --git a/jscomp/syntax/tests/conversion/reason/extension.res b/jscomp/syntax/tests/conversion/reason/extension.res deleted file mode 100644 index 0a6ff92..0000000 --- a/jscomp/syntax/tests/conversion/reason/extension.res +++ /dev/null @@ -1,10 +0,0 @@ -// here -%%raw(` eval( -__gc, -1, -0 -) - `) - -let x = %raw("10") -let y = %raw("20") diff --git a/jscomp/syntax/tests/conversion/reason/fastPipe.res b/jscomp/syntax/tests/conversion/reason/fastPipe.res deleted file mode 100644 index c758fcc..0000000 --- a/jscomp/syntax/tests/conversion/reason/fastPipe.res +++ /dev/null @@ -1,24 +0,0 @@ -a->f(b, c)->g(d, e) - -Element.querySelectorAll(selector, element) -->NodeList.toArray -->Array.keepMap(Element.ofNode) -->Array.getBy(node => node->Element.textContent === content) - -let x = @attr (@attr2 a->f(b)->c(d)) - -5->doStuff(3, _, 7) - -(event->target)["value"] - -(Route.urlToRoute(url)->ChangeView->self).send -Route.urlToRoute(url)->ChangeView->self.send - -let aggregateTotal = (forecast, ~audienceType) => - Js.Nullable.toOption(forecast["audiences"]) - ->Option.flatMap(item => Js.Dict.get(item, audienceType)) - ->Option.map(item => { - pages: item["reach"]["pages"], - views: item["reach"]["views"], - sample: item["reach"]["sample"], - }) diff --git a/jscomp/syntax/tests/conversion/reason/gentype.res b/jscomp/syntax/tests/conversion/reason/gentype.res deleted file mode 100644 index 0ce4deb..0000000 --- a/jscomp/syntax/tests/conversion/reason/gentype.res +++ /dev/null @@ -1,28 +0,0 @@ -module M: { - @genType @after - type t - - @genType @after - let x: int - - @foo - type e = .. -} = { - type t - let x = 34 - type e = .. -} - -module type MT = { - @genType @after - type t - - @genType @after - let x: int - - @foo - type e = .. -} - -@genType("ddd") -let x = 42 diff --git a/jscomp/syntax/tests/conversion/reason/gentype.resi b/jscomp/syntax/tests/conversion/reason/gentype.resi deleted file mode 100644 index 90cc39f..0000000 --- a/jscomp/syntax/tests/conversion/reason/gentype.resi +++ /dev/null @@ -1,2 +0,0 @@ -@genType -let x: int diff --git a/jscomp/syntax/tests/conversion/reason/jsObject.res b/jscomp/syntax/tests/conversion/reason/jsObject.res deleted file mode 100644 index 0c591da..0000000 --- a/jscomp/syntax/tests/conversion/reason/jsObject.res +++ /dev/null @@ -1,26 +0,0 @@ -let component = props["Component"] - -let element = props["element"] - -let y = {"age": 30} -let y = {"age": 30, "name": "steve"} - -type propField<'a> = {.} -type propField<'a> = {..} as 'a -type propField<'a> = {..} as 'a -type propField<'a> = Js.nullable<{..} as 'a> - -type propField<'a> = {"a": b} -type propField<'a> = {.."a": b} -type propField<'a> = {"a": {"b": c}} - -user["address"] -user["address"]["street"] -user["address"]["street"]["log"] - -user["address"] = "Avenue 1" -user["address"]["street"] = "Avenue" -user["address"]["street"]["number"] = "1" - -school["print"](direction["name"], studentHead["name"]) -city["getSchool"]()["print"](direction["name"], studentHead["name"]) diff --git a/jscomp/syntax/tests/conversion/reason/jsObject.resi b/jscomp/syntax/tests/conversion/reason/jsObject.resi deleted file mode 100644 index f9ca82b..0000000 --- a/jscomp/syntax/tests/conversion/reason/jsObject.resi +++ /dev/null @@ -1,8 +0,0 @@ -type propField<'a> = {.} -type propField<'a> = {..} as 'a -type propField<'a> = {..} as 'a -type propField<'a> = Js.nullable<{..} as 'a> - -type propField<'a> = {"a": b} -type propField<'a> = {.."a": b} -type propField<'a> = {"a": {"b": c}} diff --git a/jscomp/syntax/tests/conversion/reason/jsxProps.res b/jscomp/syntax/tests/conversion/reason/jsxProps.res deleted file mode 100644 index d368bc9..0000000 --- a/jscomp/syntax/tests/conversion/reason/jsxProps.res +++ /dev/null @@ -1,17 +0,0 @@ -let handleClick = (href, event) => - if !ReactEvent.Mouse.defaultPrevented(event) { - ReactEvent.Mouse.preventDefault(event) - ReasonReact.Router.push(href) - } - -@react.component -let make = (~href, ~className="", ~children) => -
handleClick(href, event)}> children - - ...{x =>
} - -
...element
-
...{a => 1}
-
...
-
...[a, b]
-
...{(1, 2)}
diff --git a/jscomp/syntax/tests/conversion/reason/letBinding.res b/jscomp/syntax/tests/conversion/reason/letBinding.res deleted file mode 100644 index 525c159..0000000 --- a/jscomp/syntax/tests/conversion/reason/letBinding.res +++ /dev/null @@ -1,14 +0,0 @@ -let deltaMode: t => Webapi__Dom__Types.deltaMode = self => - Webapi__Dom__Types.decodeDeltaMode(deltaMode(self)) - -let fromJs: ResourceIo.campaignWeeklyPlanning => t = weeklyPlanning => ( - weeklyPlanning["monday"]->dayFromJs, - weeklyPlanning["tuesday"]->dayFromJs, - weeklyPlanning["wednesday"]->dayFromJs, - weeklyPlanning["thursday"]->dayFromJs, - weeklyPlanning["friday"]->dayFromJs, - weeklyPlanning["saturday"]->dayFromJs, - weeklyPlanning["sunday"]->dayFromJs, -) - -let newChapter: Video.chapter = {startTime: percent *. duration} diff --git a/jscomp/syntax/tests/conversion/reason/letprivate.res b/jscomp/syntax/tests/conversion/reason/letprivate.res deleted file mode 100644 index d8b86ef..0000000 --- a/jscomp/syntax/tests/conversion/reason/letprivate.res +++ /dev/null @@ -1 +0,0 @@ -%%private(let x = 34) diff --git a/jscomp/syntax/tests/conversion/reason/modType.res b/jscomp/syntax/tests/conversion/reason/modType.res deleted file mode 100644 index 260265c..0000000 --- a/jscomp/syntax/tests/conversion/reason/modType.res +++ /dev/null @@ -1,15 +0,0 @@ -module Same = (Na: N, Nb: N): ((S with type number1 = Na.number) with type number2 = Nb.number) => { - type number1 = Na.number - type number2 = Nb.number - let rec sim = ((n, m)) => - if Na.is_zero(n) { - Nb.is_zero(m) - } else { - sim((Na.pred(n), Nb.pred(m))) - } - let similar = ((n, m)) => - try sim((n, m)) catch { - | Na.Too_small => false - | Nb.Too_small => false - } -} diff --git a/jscomp/syntax/tests/conversion/reason/moduleLanguage.res b/jscomp/syntax/tests/conversion/reason/moduleLanguage.res deleted file mode 100644 index 724dfc6..0000000 --- a/jscomp/syntax/tests/conversion/reason/moduleLanguage.res +++ /dev/null @@ -1 +0,0 @@ -let someFunctorAsFunction = (x: module(MT)): module(ResT) => module(SomeFunctor(unpack(x))) diff --git a/jscomp/syntax/tests/conversion/reason/namedArgs.res b/jscomp/syntax/tests/conversion/reason/namedArgs.res deleted file mode 100644 index eb0d820..0000000 --- a/jscomp/syntax/tests/conversion/reason/namedArgs.res +++ /dev/null @@ -1,63 +0,0 @@ -let wizard = Wizard.make( - ~spriteSheet=wizard, - ~hp=999999999999999, - ~mp=50, - //~coordinates={x: 0., y:0. z: 0.}, - ~coordinates={x: 40, y: 100., z: 0.}, - // /* c0 */ ~gpuCoordinates= /* c1 */ gpuBuffer[10] /* c2 */, // trailing -) - -apply( - // above - ~aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa, - // below - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb, - // here - ~cccccccccccccccccccccccccccccccc, -) - -applyOptional( - // above - ~aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa?, - // below - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb?, - // here - ~cccccccccccccccccccccccccccccccc?, -) - -foo( - // c0 - ~aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa: int, - // c1 - ~bbbbbbbbbbbbbbbbbbbbbbbbbbbbbb: int, - // c2 - ~cccccccccccccccccccccccccccccc: int, -) - -let f = ( - ~isItemActive=?, - // array((name, href)) - ~headers: array<(string, string)>, - ~moduleName: string, - // foo - ~x, - // above - /* c0 */ ~d: /* c1 */ e, // end - ~from as // does it work - hometown, -) => { - let a = 1 - let b = 2 - a + b -} - -@react.component -let make = ( - ~theme: ColorTheme.t, - ~components: Mdx.Components.t, - ~sidebarState: (bool, (bool => bool) => unit), - // (Sidebar, toggleSidebar) ... for toggling sidebar in mobile view - ~sidebar: React.element, - ~breadcrumbs: option>=?, - ~children, -) => () diff --git a/jscomp/syntax/tests/conversion/reason/object.ml b/jscomp/syntax/tests/conversion/reason/object.ml deleted file mode 100644 index 6209959..0000000 --- a/jscomp/syntax/tests/conversion/reason/object.ml +++ /dev/null @@ -1,4 +0,0 @@ -type hi = < z : int > -type 'a u = < hi ; x : int ; y : int; .. > as 'a -type 'a u1 = < hi; .. > as 'a -type 'a u2 = < hi ; hi; y : int ; hi; .. > as 'a diff --git a/jscomp/syntax/tests/conversion/reason/openPattern.res b/jscomp/syntax/tests/conversion/reason/openPattern.res deleted file mode 100644 index 2855827..0000000 --- a/jscomp/syntax/tests/conversion/reason/openPattern.res +++ /dev/null @@ -1,23 +0,0 @@ -let {T.a: a} = a() -let [Color.Blue] = a() -let list{Color.Blue} = a() -let (Color.Blue, Red) = a() - -let Color.Blue = blue - -module Color = { - type t = Red | Blue | Green - let red = Red - let blue = Blue - let green = Green -} - -let () = switch (Color.red, Color.blue, Color.green) { -| (Color.Red, Blue, Green) => Js.log("hello world") -| _ => () -} - -let () = switch [Color.red, Color.blue, Color.green] { -| [Color.Red, Blue, Green] => Js.log("hello world") -| _ => () -} diff --git a/jscomp/syntax/tests/conversion/reason/ppx.res b/jscomp/syntax/tests/conversion/reason/ppx.res deleted file mode 100644 index 3f0dda1..0000000 --- a/jscomp/syntax/tests/conversion/reason/ppx.res +++ /dev/null @@ -1,55 +0,0 @@ -%graphql( - ` - query Site { - site { - siteMetadata { - title - description - siteUrl - } - } - } -` - {taggedTemplate: false} -) - -module Form = %form( - type input = { - name: string, - email: string, - message: string, - @as("form-name") - formName: string, - } - type output = input - let validators = { - name: { - strategy: OnFirstBlur, - validate: ({name, _}) => - switch name { - | "" => Error("Name is required.") - | name => Ok(name) - }, - }, - email: { - strategy: OnFirstBlur, - validate: ({email, _}) => - switch email { - | "" => Error("Email is required.") - | email => Ok(email) - }, - }, - message: { - strategy: OnFirstBlur, - validate: ({message, _}) => - switch message { - | "" => Error("Message is required.") - | message => Ok(message) - }, - }, - formName: { - strategy: OnSubmit, - validate: ({formName, _}) => Ok(formName), - }, - } -) diff --git a/jscomp/syntax/tests/conversion/reason/recursiveType.ml b/jscomp/syntax/tests/conversion/reason/recursiveType.ml deleted file mode 100644 index 6a378ee..0000000 --- a/jscomp/syntax/tests/conversion/reason/recursiveType.ml +++ /dev/null @@ -1,4 +0,0 @@ -type tree = - < label: string ;left: tree option ;right: tree option > Js.t - -type nonrec t = t diff --git a/jscomp/syntax/tests/conversion/reason/refSugar.ml b/jscomp/syntax/tests/conversion/reason/refSugar.ml deleted file mode 100644 index 6aa9cea..0000000 --- a/jscomp/syntax/tests/conversion/reason/refSugar.ml +++ /dev/null @@ -1 +0,0 @@ -let x = !foo diff --git a/jscomp/syntax/tests/conversion/reason/refSugarReason.res b/jscomp/syntax/tests/conversion/reason/refSugarReason.res deleted file mode 100644 index 96255e4..0000000 --- a/jscomp/syntax/tests/conversion/reason/refSugarReason.res +++ /dev/null @@ -1 +0,0 @@ -let x = foo.contents diff --git a/jscomp/syntax/tests/conversion/reason/singleLineComments.res b/jscomp/syntax/tests/conversion/reason/singleLineComments.res deleted file mode 100644 index c5a75c2..0000000 --- a/jscomp/syntax/tests/conversion/reason/singleLineComments.res +++ /dev/null @@ -1,18 +0,0 @@ -// This is the implementation of the _app.js file - -// Resources: -// -------------- -// Really good article on state persistence within layouts: -// https://adamwathan.me/2019/10/17/persistent-layout-patterns-in-nextjs/ - -/* - a - - */ - -/* - a - -*/ -let x = 1 -// here diff --git a/jscomp/syntax/tests/conversion/reason/string.res b/jscomp/syntax/tests/conversion/reason/string.res deleted file mode 100644 index a85d0bb..0000000 --- a/jscomp/syntax/tests/conversion/reason/string.res +++ /dev/null @@ -1,36 +0,0 @@ -%%raw("define(x.y, 'userAgent', {value: 'USER_AGENT_STRING'})") - -%%raw("define(x.y, 'userAgent', {value: 'USER_AGENT_STRING'})") - -let x = `This is a long string with a slash and line break \\ -carriage return` - -let x = "\"" -let y = "\n" - -(<> {"\n"->React.string} ) - -// The `//` should not result into an extra comment -let x = j`https://www.apple.com` -let x = `https://www.apple.com` -let x = `https://www.apple.com` -let x = `https://www.apple.com` -let x = sql`https://www.apple.com` - -// /* */ should not result in an extra comments -let x = j`/* https://www.apple.com */` -let x = `/* https://www.apple.com*/` -let x = `/*https://www.apple.com*/` -let x = `/*https://www.apple.com*/` -let x = sql`/*https://www.apple.com*/` - -let x = `\`https://\${appleWebsite}\`` - -let var1 = "three" -let var2 = "a string" - -switch (var1, var2) { -| (`3`, `a string`) => Js.log("worked") -| (` test with \` \${here} \``, _) => Js.log("escapes ` and ${") -| _ => Js.log("didn't match") -} diff --git a/jscomp/syntax/tests/conversion/reason/ternary.res b/jscomp/syntax/tests/conversion/reason/ternary.res deleted file mode 100644 index 3c90de0..0000000 --- a/jscomp/syntax/tests/conversion/reason/ternary.res +++ /dev/null @@ -1 +0,0 @@ -let a = x ? 1 : 2 diff --git a/jscomp/syntax/tests/conversion/reason/uncurrried.res b/jscomp/syntax/tests/conversion/reason/uncurrried.res deleted file mode 100644 index b273f54..0000000 --- a/jscomp/syntax/tests/conversion/reason/uncurrried.res +++ /dev/null @@ -1,64 +0,0 @@ -// ok -let updateBriefletNarrative = (. updateObj) => Js.log("patented merge algorithm goes here") - -// this is a bug in Reason, the . will be parsed wrong and disappear. -/* updateBriefletNarrative(. briefletNarrativeUpdateObj); */ - -// this is a bug in Reason, the . will be parsed wrong and disappear. -/* foo(. 3); */ - -module D = { - // this is a bug in Reason, the . will be parsed wrong and disappear. - /* foo(. 3); */ -} - -// ok -let x = foo(. 3) - -let x = { - let a = 3 - // ok - foo(. a) -} - -let x = { - // ok - let f = (. a, b) => apply(. a + b) - let a = 3 - // ok - foo(. a) - // ok - f(. 2, 2) -} - -// ok -let () = switch something(. x, y) { -| None => - // ok - log(. a, b) -| Some(_) => - let a = 1 - // ok - log(. a, 2) -} - -let () = { - // ok - let dontDoThisAhome = (. a, b, . c, d, . e, f) => a + b + c + d + e + f - // ok - dontDoThisAhome(. a, b)(. c, d)(. e, f) -} - -let _ = library.getBalance(. account)->Promise.Js.catch(_ => Promise.resolved(None)) - -let _ = - library.getBalance(. account) - ->Promise.Js.catch(_ => Promise.resolved(None)) - ->Promise.get(newBalance => - dispatch( - LoadAddress( - account, - newBalance->Belt.Option.flatMap(balance => Eth.make(balance.toString(.))), - ), - ) - ) diff --git a/jscomp/syntax/tests/conversion/reason/underscoreSugar.res b/jscomp/syntax/tests/conversion/reason/underscoreSugar.res deleted file mode 100644 index 9330f5c..0000000 --- a/jscomp/syntax/tests/conversion/reason/underscoreSugar.res +++ /dev/null @@ -1 +0,0 @@ -let photo = pricedRoom["room"]["photos"] |> filterNone |> Array.get(_, 0) diff --git a/jscomp/syntax/tests/conversion/reason/unicode.res b/jscomp/syntax/tests/conversion/reason/unicode.res deleted file mode 100644 index 332b911..0000000 --- a/jscomp/syntax/tests/conversion/reason/unicode.res +++ /dev/null @@ -1,5 +0,0 @@ -let x = "✅ foo bar" - -let x = "\n okokok" - -let z = "\t \b \n okok 🙈" diff --git a/jscomp/syntax/tests/conversion/reason/variant.res b/jscomp/syntax/tests/conversion/reason/variant.res deleted file mode 100644 index 2864a7d..0000000 --- a/jscomp/syntax/tests/conversion/reason/variant.res +++ /dev/null @@ -1 +0,0 @@ -type t = | @foo X diff --git a/jscomp/syntax/tests/idempotency/bs-css/Css.res b/jscomp/syntax/tests/idempotency/bs-css/Css.res deleted file mode 100644 index 492b63b..0000000 --- a/jscomp/syntax/tests/idempotency/bs-css/Css.res +++ /dev/null @@ -1,16 +0,0 @@ -include Css_Legacy_Core -include Css_Colors - -include Css_Legacy_Core.Make({ - exception NotImplemented - - let make = (. _) => raise(NotImplemented) - let mergeStyles = (. _) => raise(NotImplemented) - let injectRule = (. _) => () - let injectRaw = (. _) => () - let makeKeyFrames = (. _) => raise(NotImplemented) -}) - -external unsafeJsonToStyles: Js.Json.t => ReactDOMRe.Style.t = "%identity" - -let style = rules => rules->toJson->unsafeJsonToStyles diff --git a/jscomp/syntax/tests/idempotency/bs-css/CssEmotion.res b/jscomp/syntax/tests/idempotency/bs-css/CssEmotion.res deleted file mode 100644 index 97b2eed..0000000 --- a/jscomp/syntax/tests/idempotency/bs-css/CssEmotion.res +++ /dev/null @@ -1,35 +0,0 @@ -include Css_Legacy_Core -include Css_Colors - -include Css_Legacy_Core.Make({ - @module("emotion") - external mergeStyles: (. array) => string = "cx" - - @module("emotion") external make: (. Js.Json.t) => string = "css" - - @module("emotion") - external injectRule: (. Js.Json.t) => unit = "injectGlobal" - - @module("emotion") - external injectRaw: (. string) => unit = "injectGlobal" - - @module("emotion") - external makeKeyFrames: (. Js.Dict.t) => string = "keyframes" -}) - -type cache - -@module("emotion") external cache: cache = "cache" - -let fontFace = (~fontFamily, ~src, ~fontStyle=?, ~fontWeight=?, ~fontDisplay=?, ()) => { - let asString = Css_Legacy_Core.fontFace( - ~fontFamily, - ~src, - ~fontStyle?, - ~fontWeight?, - ~fontDisplay?, - (), - ) - insertRule(asString) - fontFamily -} diff --git a/jscomp/syntax/tests/idempotency/bs-css/CssEmotionJs.res b/jscomp/syntax/tests/idempotency/bs-css/CssEmotionJs.res deleted file mode 100644 index 8e711f2..0000000 --- a/jscomp/syntax/tests/idempotency/bs-css/CssEmotionJs.res +++ /dev/null @@ -1,29 +0,0 @@ -include Css_Js_Core -include Css_Colors - -include Css_Js_Core.Make({ - @module("emotion") - external mergeStyles: (. array) => string = "cx" - - @module("emotion") external make: (. Js.Json.t) => string = "css" - - @module("emotion") - external injectRule: (. Js.Json.t) => unit = "injectGlobal" - - @module("emotion") - external injectRaw: (. string) => unit = "injectGlobal" - - @module("emotion") - external makeKeyFrames: (. Js.Dict.t) => string = "keyframes" -}) - -type cache - -@module("emotion") external cache: cache = "cache" - -let fontFace = (~fontFamily, ~src, ~fontStyle=?, ~fontWeight=?, ~fontDisplay=?, ()) => { - insertRule(. - Css_Js_Core.fontFace(~fontFamily, ~src, ~fontStyle?, ~fontWeight?, ~fontDisplay?, ()), - ) - fontFamily -} diff --git a/jscomp/syntax/tests/idempotency/bs-css/CssJs.res b/jscomp/syntax/tests/idempotency/bs-css/CssJs.res deleted file mode 100644 index ad8caf1..0000000 --- a/jscomp/syntax/tests/idempotency/bs-css/CssJs.res +++ /dev/null @@ -1,16 +0,0 @@ -include Css_Js_Core -include Css_Colors - -include Css_Js_Core.Make({ - exception NotImplemented - - let make = (. _) => raise(NotImplemented) - let mergeStyles = (. _) => raise(NotImplemented) - let injectRule = (. _) => () - let injectRaw = (. _) => () - let makeKeyFrames = (. _) => raise(NotImplemented) -}) - -external unsafeJsonToStyles: Js.Json.t => ReactDOMRe.Style.t = "%identity" - -let style = (. rules) => rules->toJson->unsafeJsonToStyles diff --git a/jscomp/syntax/tests/idempotency/bs-css/Css_AtomicTypes.res b/jscomp/syntax/tests/idempotency/bs-css/Css_AtomicTypes.res deleted file mode 100644 index 18d2935..0000000 --- a/jscomp/syntax/tests/idempotency/bs-css/Css_AtomicTypes.res +++ /dev/null @@ -1,1823 +0,0 @@ -let join = (strings, separator) => { - let rec run = (strings, acc) => - switch strings { - | list{} => acc - | list{x} => acc ++ x - | list{x, ...xs} => run(xs, acc ++ (x ++ separator)) - } - run(strings, "") -} - -module Cascading = { - type t = [#initial | #inherit_ | #unset] - - let initial = #initial - let inherit_ = #inherit_ - let unset = #unset - - let toString = x => - switch x { - | #initial => "initial" - | #inherit_ => "inherit" - | #unset => "unset" - } -} - -module Var = { - type t = [#var(string) | #varDefault(string, string)] - - let var = x => #var(x) - let varDefault = (x, default) => #varDefault(x, default) - - let prefix = x => Js.String.startsWith("--", x) ? x : "--" ++ x - - let toString = x => - switch x { - | #var(x) => "var(" ++ (prefix(x) ++ ")") - | #varDefault(x, v) => "var(" ++ (prefix(x) ++ ("," ++ (v ++ ")"))) - } -} - -module Time = { - type t = [#s(float) | #ms(float)] - - let s = x => #s(x) - let ms = x => #ms(x) - - let toString = x => - switch x { - | #s(v) => Js.Float.toString(v) ++ "s" - | #ms(v) => Js.Float.toString(v) ++ "ms" - } -} - -module Percentage = { - type t = [#percent(float)] - - let pct = x => #percent(x) - - let toString = x => - switch x { - | #percent(x) => Js.Float.toString(x) ++ "%" - } -} - -module Url = { - type t = [#url(string)] - - let toString = x => - switch x { - | #url(s) => "url(" ++ (s ++ ")") - } -} - -module Length = { - type rec t = [ - | #ch(float) - | #em(float) - | #ex(float) - | #rem(float) - | #vh(float) - | #vw(float) - | #vmin(float) - | #vmax(float) - | #px(int) - | #pxFloat(float) - | #cm(float) - | #mm(float) - | #inch(float) - | #pc(float) - | #pt(int) - | #zero - | #calc([#add | #sub], t, t) - | #percent(float) - ] - - let ch = x => #ch(x) - let em = x => #em(x) - let ex = x => #ex(x) - let rem = x => #rem(x) - let vh = x => #vh(x) - let vw = x => #vw(x) - let vmin = x => #vmin(x) - let vmax = x => #vmax(x) - let px = x => #px(x) - let pxFloat = x => #pxFloat(x) - let cm = x => #cm(x) - let mm = x => #mm(x) - let inch = x => #inch(x) - let pc = x => #pc(x) - let pt = x => #pt(x) - let zero = #zero - - let rec toString = x => - switch x { - | #ch(x) => Js.Float.toString(x) ++ "ch" - | #em(x) => Js.Float.toString(x) ++ "em" - | #ex(x) => Js.Float.toString(x) ++ "ex" - | #rem(x) => Js.Float.toString(x) ++ "rem" - | #vh(x) => Js.Float.toString(x) ++ "vh" - | #vw(x) => Js.Float.toString(x) ++ "vw" - | #vmin(x) => Js.Float.toString(x) ++ "vmin" - | #vmax(x) => Js.Float.toString(x) ++ "vmax" - | #px(x) => Js.Int.toString(x) ++ "px" - | #pxFloat(x) => Js.Float.toString(x) ++ "px" - | #cm(x) => Js.Float.toString(x) ++ "cm" - | #mm(x) => Js.Float.toString(x) ++ "mm" - | #inch(x) => Js.Float.toString(x) ++ "in" - | #pc(x) => Js.Float.toString(x) ++ "pc" - | #pt(x) => Js.Int.toString(x) ++ "pt" - | #zero => "0" - - | #calc(#add, a, b) => "calc(" ++ (toString(a) ++ (" + " ++ (toString(b) ++ ")"))) - | #calc(#sub, a, b) => "calc(" ++ (toString(a) ++ (" - " ++ (toString(b) ++ ")"))) - | #percent(x) => Js.Float.toString(x) ++ "%" - } -} - -module Angle = { - type t = [#deg(float) | #rad(float) | #grad(float) | #turn(float)] - - let deg = (x: float) => #deg(x) - let rad = (x: float) => #rad(x) - let grad = (x: float) => #grad(x) - let turn = (x: float) => #turn(x) - - let toString = x => - switch x { - | #deg(x) => Js.Float.toString(x) ++ "deg" - | #rad(x) => Js.Float.toString(x) ++ "rad" - | #grad(x) => Js.Float.toString(x) ++ "grad" - | #turn(x) => Js.Float.toString(x) ++ "turn" - } -} - -module Direction = { - type t = [#ltr | #rtl] - - let ltr = #ltr - let rtl = #rtl - - let toString = x => - switch x { - | #ltr => "ltr" - | #rtl => "rtl" - } -} - -module Position = { - type t = [#absolute | #relative | #static | #fixed | #sticky] - - let absolute = #absolute - let relative = #relative - let static = #static - let fixed = #fixed - let sticky = #sticky - - let toString = x => - switch x { - | #absolute => "absolute" - | #relative => "relative" - | #static => "static" - | #fixed => "fixed" - | #sticky => "sticky" - } -} - -module Resize = { - type t = [#none | #both | #horizontal | #vertical | #block | #inline] - - let none = #none - let both = #both - let horizontal = #horizontal - let vertical = #vertical - let block = #block - let inline = #inline - - let toString = x => - switch x { - | #none => "none" - | #both => "both" - | #horizontal => "horizontal" - | #vertical => "vertical" - | #block => "block" - | #inline => "inline" - } -} - -module FontVariant = { - type t = [#normal | #smallCaps] - - let normal = #normal - let smallCaps = #smallCaps - - let toString = x => - switch x { - | #normal => "normal" - | #smallCaps => "smallCaps" - } -} - -module FontStyle = { - type t = [#normal | #italic | #oblique] - - let normal = #normal - let italic = #italic - let oblique = #oblique - - let toString = x => - switch x { - | #normal => "normal" - | #italic => "italic" - | #oblique => "oblique" - } -} - -module FlexBasis = { - type t = [ - | #auto - | #fill - | #content - | #maxContent - | #minContent - | #fitContent - ] - - let fill = #fill - let content = #content - let maxContent = #maxContent - let minContent = #minContent - let fitContent = #fitContent - - let toString = x => - switch x { - | #auto => "auto" - | #fill => "fill" - | #content => "content" - | #maxContent => "max-content" - | #minContent => "min-content" - | #fitContent => "fit-content" - } -} - -module Overflow = { - type t = [#hidden | #visible | #scroll | #auto] - - let hidden = #hidden - let visible = #visible - let scroll = #scroll - let auto = #auto - - let toString = x => - switch x { - | #hidden => "hidden" - | #visible => "visible" - | #scroll => "scroll" - | #auto => "auto" - } -} - -module Margin = { - type t = [#auto] - - let auto = #auto - - let toString = x => - switch x { - | #auto => "auto" - } -} - -module GridAutoFlow = { - type t = [#column | #row | #columnDense | #rowDense] - - let toString = x => - switch x { - | #column => "column" - | #row => "row" - | #columnDense => "column dense" - | #rowDense => "row dense" - } -} - -module ColumnGap = { - type t = [#normal] - - let toString = x => - switch x { - | #normal => "normal" - } -} - -module VerticalAlign = { - type t = [ - | #baseline - | #sub - | #super - | #top - | #textTop - | #middle - | #bottom - | #textBottom - ] - - let toString = x => - switch x { - | #baseline => "baseline" - | #sub => "sub" - | #super => "super" - | #top => "top" - | #textTop => "text-top" - | #middle => "middle" - | #bottom => "bottom" - | #textBottom => "text-bottom" - } -} - -module TimingFunction = { - type t = [ - | #linear - | #ease - | #easeIn - | #easeOut - | #easeInOut - | #stepStart - | #stepEnd - | #steps(int, [#start | #end_]) - | #cubicBezier(float, float, float, float) - ] - - let linear = #linear - let ease = #ease - let easeIn = #easeIn - let easeInOut = #easeInOut - let easeOut = #easeOut - let stepStart = #stepStart - let stepEnd = #stepEnd - let steps = (i, dir) => #steps(i, dir) - let cubicBezier = (a, b, c, d) => #cubicBezier(a, b, c, d) - - let toString = x => - switch x { - | #linear => "linear" - | #ease => "ease" - | #easeIn => "ease-in" - | #easeOut => "ease-out" - | #easeInOut => "ease-in-out" - | #stepStart => "step-start" - | #stepEnd => "step-end" - | #steps(i, #start) => "steps(" ++ (Js.Int.toString(i) ++ ", start)") - | #steps(i, #end_) => "steps(" ++ (Js.Int.toString(i) ++ ", end)") - | #cubicBezier(a, b, c, d) => - "cubic-bezier(" ++ - (Js.Float.toString(a) ++ - (", " ++ - (Js.Float.toString(b) ++ - (", " ++ (Js.Float.toString(c) ++ (", " ++ (Js.Float.toString(d) ++ ")"))))))) - } -} - -module RepeatValue = { - type t = [#autoFill | #autoFit | #num(int)] - - let toString = x => - switch x { - | #autoFill => "auto-fill" - | #autoFit => "auto-fit" - | #num(x) => Js.Int.toString(x) - } -} - -module ListStyleType = { - type t = [ - | #disc - | #circle - | #square - | #decimal - | #lowerAlpha - | #upperAlpha - | #lowerGreek - | #lowerLatin - | #upperLatin - | #lowerRoman - | #upperRoman - | #none - ] - - let toString = x => - switch x { - | #disc => "disc" - | #circle => "circle" - | #square => "square" - | #decimal => "decimal" - | #lowerAlpha => "lower-alpha" - | #upperAlpha => "upper-alpha" - | #lowerGreek => "lower-greek" - | #lowerLatin => "lower-latin" - | #upperLatin => "upper-latin" - | #lowerRoman => "lower-roman" - | #upperRoman => "upper-roman" - | #none => "none" - } -} - -module ListStylePosition = { - type t = [#inside | #outside] - - let toString = x => - switch x { - | #inside => "inside" - | #outside => "outside" - } -} - -module OutlineStyle = { - type t = [ - | #none - | #hidden - | #dotted - | #dashed - | #solid - | #double - | #groove - | #ridge - | #inset - | #outset - ] - - let toString = x => - switch x { - | #none => "none" - | #hidden => "hidden" - | #dotted => "dotted" - | #dashed => "dashed" - | #solid => "solid" - | #double => "double" - | #groove => "grove" - | #ridge => "ridge" - | #inset => "inset" - | #outset => "outset" - } -} - -module FontWeight = { - type t = [ - | #num(int) - | #thin - | #extraLight - | #light - | #normal - | #medium - | #semiBold - | #bold - | #extraBold - | #black - | #lighter - | #bolder - ] - - let thin = #thin - let extraLight = #extraLight - let light = #light - let medium = #medium - let semiBold = #semiBold - let bold = #bold - let extraBold = #extraBold - let lighter = #lighter - let bolder = #bolder - - let toString = x => - switch x { - | #num(n) => Js.Int.toString(n) - | #thin => "100" - | #extraLight => "200" - | #light => "300" - | #normal => "400" - | #medium => "500" - | #semiBold => "600" - | #bold => "700" - | #extraBold => "800" - | #black => "900" - | #lighter => "lighter" - | #bolder => "bolder" - } -} - -module Transform = { - type t = [ - | #translate(Length.t, Length.t) - | #translate3d(Length.t, Length.t, Length.t) - | #translateX(Length.t) - | #translateY(Length.t) - | #translateZ(Length.t) - | #scale(float, float) - | #scale3d(float, float, float) - | #scaleX(float) - | #scaleY(float) - | #scaleZ(float) - | #rotate(Angle.t) - | #rotate3d(float, float, float, Angle.t) - | #rotateX(Angle.t) - | #rotateY(Angle.t) - | #rotateZ(Angle.t) - | #skew(Angle.t, Angle.t) - | #skewX(Angle.t) - | #skewY(Angle.t) - | #perspective(int) - ] - - let translate = (x, y) => #translate(x, y) - let translate3d = (x, y, z) => #translate3d(x, y, z) - let translateX = x => #translateX(x) - let translateY = y => #translateY(y) - let translateZ = z => #translateZ(z) - let scale = (x, y) => #scale(x, y) - let scale3d = (x, y, z) => #scale3d(x, y, z) - let scaleX = x => #scaleX(x) - let scaleY = x => #scaleY(x) - let scaleZ = x => #scaleZ(x) - let rotate = a => #rotate(a) - let rotate3d = (x, y, z, a) => #rotate3d(x, y, z, a) - let rotateX = a => #rotateX(a) - let rotateY = a => #rotateY(a) - let rotateZ = a => #rotateZ(a) - let skew = (a, a') => #skew(a, a') - let skewX = a => #skewX(a) - let skewY = a => #skewY(a) - - let string_of_scale = (x, y) => - "scale(" ++ (Js.Float.toString(x) ++ (", " ++ (Js.Float.toString(y) ++ ")"))) - - let string_of_translate3d = (x, y, z) => - "translate3d(" ++ - (Length.toString(x) ++ - (", " ++ (Length.toString(y) ++ (", " ++ (Length.toString(z) ++ ")"))))) - - let toString = x => - switch x { - | #translate(x, y) => - "translate(" ++ (Length.toString(x) ++ (", " ++ (Length.toString(y) ++ ")"))) - | #translate3d(x, y, z) => string_of_translate3d(x, y, z) - | #translateX(x) => "translateX(" ++ (Length.toString(x) ++ ")") - | #translateY(y) => "translateY(" ++ (Length.toString(y) ++ ")") - | #translateZ(z) => "translateZ(" ++ (Length.toString(z) ++ ")") - | #scale(x, y) => string_of_scale(x, y) - | #scale3d(x, y, z) => - "scale3d(" ++ - (Js.Float.toString(x) ++ - (", " ++ (Js.Float.toString(y) ++ (", " ++ (Js.Float.toString(z) ++ ")"))))) - | #scaleX(x) => "scaleX(" ++ (Js.Float.toString(x) ++ ")") - | #scaleY(y) => "scaleY(" ++ (Js.Float.toString(y) ++ ")") - | #scaleZ(z) => "scaleZ(" ++ (Js.Float.toString(z) ++ ")") - | #rotate(a) => "rotate(" ++ (Angle.toString(a) ++ ")") - | #rotate3d(x, y, z, a) => - "rotate3d(" ++ - (Js.Float.toString(x) ++ - (", " ++ - (Js.Float.toString(y) ++ - (", " ++ (Js.Float.toString(z) ++ (", " ++ (Angle.toString(a) ++ ")"))))))) - | #rotateX(a) => "rotateX(" ++ (Angle.toString(a) ++ ")") - | #rotateY(a) => "rotateY(" ++ (Angle.toString(a) ++ ")") - | #rotateZ(a) => "rotateZ(" ++ (Angle.toString(a) ++ ")") - | #skew(x, y) => "skew(" ++ (Angle.toString(x) ++ (", " ++ (Angle.toString(y) ++ ")"))) - | #skewX(a) => "skewX(" ++ (Angle.toString(a) ++ ")") - | #skewY(a) => "skewY(" ++ (Angle.toString(a) ++ ")") - | #perspective(x) => "perspective(" ++ (Js.Int.toString(x) ++ ")") - } -} - -module AnimationDirection = { - type t = [#normal | #reverse | #alternate | #alternateReverse] - - let toString = x => - switch x { - | #normal => "normal" - | #reverse => "reverse" - | #alternate => "alternate" - | #alternateReverse => "alternate-reverse" - } -} - -module AnimationFillMode = { - type t = [#none | #forwards | #backwards | #both] - - let toString = x => - switch x { - | #none => "none" - | #forwards => "forwards" - | #backwards => "backwards" - | #both => "both" - } -} - -module AnimationIterationCount = { - type t = [#infinite | #count(int)] - - let toString = x => - switch x { - | #infinite => "infinite" - | #count(x) => Js.Int.toString(x) - } -} - -module AnimationPlayState = { - type t = [#paused | #running] - - let toString = x => - switch x { - | #paused => "paused" - | #running => "running" - } -} - -module Cursor = { - type t = [ - | #auto - | #default - | #none - | #contextMenu - | #help - | #pointer - | #progress - | #wait - | #cell - | #crosshair - | #text - | #verticalText - | #alias - | #copy - | #move - | #noDrop - | #notAllowed - | #grab - | #grabbing - | #allScroll - | #colResize - | #rowResize - | #nResize - | #eResize - | #sResize - | #wResize - | #neResize - | #nwResize - | #seResize - | #swResize - | #ewResize - | #nsResize - | #neswResize - | #nwseResize - | #zoomIn - | #zoomOut - ] - - let auto = #auto - let default = #default - let none = #none - let contextMenu = #contextMenu - let help = #help - let pointer = #pointer - let progress = #progress - let wait = #wait - let cell = #cell - let crosshair = #crosshair - let text = #text - let verticalText = #verticalText - let alias = #alias - let copy = #copy - let move = #move - let noDrop = #noDrop - let notAllowed = #notAllowed - let grab = #grab - let grabbing = #grabbing - let allScroll = #allScroll - let colResize = #colResize - let rowResize = #rowResize - let nResize = #nResize - let eResize = #eResize - let sResize = #sResize - let wResize = #wResize - let neResize = #neResize - let nwResize = #nwResize - let seResize = #seResize - let swResize = #swResize - let ewResize = #ewResize - let nsResize = #nsResize - let neswResize = #neswResize - let nwseResize = #nwseResize - let zoomIn = #zoomIn - let zoomOut = #zoomOut - - let toString = x => - switch x { - | #auto => "auto" - | #default => "default" - | #none => "none" - | #contextMenu => "context-menu" - | #help => "help" - | #pointer => "pointer" - | #progress => "progress" - | #wait => "wait" - | #cell => "cell" - | #crosshair => "crosshair" - | #text => "text" - | #verticalText => "vertical-text" - | #alias => "alias" - | #copy => "copy" - | #move => "move" - | #noDrop => "no-drop" - | #notAllowed => "not-allowed" - | #grab => "grab" - | #grabbing => "grabbing" - | #allScroll => "all-scroll" - | #colResize => "col-resize" - | #rowResize => "row-resize" - | #nResize => "n-resize" - | #eResize => "e-resize" - | #sResize => "s-resize" - | #wResize => "w-resize" - | #neResize => "ne-resize" - | #nwResize => "nw-resize" - | #seResize => "se-resize" - | #swResize => "sw-resize" - | #ewResize => "ew-resize" - | #nsResize => "ns-resize" - | #neswResize => "nesw-resize" - | #nwseResize => "nwse-resize" - | #zoomIn => "zoom-in" - | #zoomOut => "zoom-out" - } -} - -module Color = { - type t = [ - | #rgb(int, int, int) - | #rgba(int, int, int, [#num(float) | Percentage.t]) - | #hsl(Angle.t, Percentage.t, Percentage.t) - | #hsla(Angle.t, Percentage.t, Percentage.t, [#num(float) | Percentage.t]) - | #hex(string) - | #transparent - | #currentColor - ] - - let rgb = (r, g, b) => #rgb(r, g, b) - let rgba = (r, g, b, a) => #rgba(r, g, b, a) - let hsl = (h, s, l) => #hsl(h, s, l) - let hsla = (h, s, l, a) => #hsla(h, s, l, a) - let hex = x => #hex(x) - let transparent = #transparent - let currentColor = #currentColor - - let string_of_alpha = x => - switch x { - | #num(f) => Js.Float.toString(f) - | #...Percentage.t as pc => Percentage.toString(pc) - } - - let toString = x => - switch x { - | #rgb(r, g, b) => - "rgb(" ++ - (Js.Int.toString(r) ++ - (", " ++ (Js.Int.toString(g) ++ (", " ++ (Js.Int.toString(b) ++ ")"))))) - | #rgba(r, g, b, a) => - "rgba(" ++ - (Js.Int.toString(r) ++ - (", " ++ - (Js.Int.toString(g) ++ - (", " ++ (Js.Int.toString(b) ++ (", " ++ (string_of_alpha(a) ++ ")"))))))) - | #hsl(h, s, l) => - "hsl(" ++ - (Angle.toString(h) ++ - (", " ++ (Percentage.toString(s) ++ (", " ++ (Percentage.toString(l) ++ ")"))))) - | #hsla(h, s, l, a) => - "hsla(" ++ - (Angle.toString(h) ++ - (", " ++ - (Percentage.toString(s) ++ - (", " ++ (Percentage.toString(l) ++ (", " ++ (string_of_alpha(a) ++ ")"))))))) - | #hex(s) => "#" ++ s - | #transparent => "transparent" - | #currentColor => "currentColor" - } -} - -module BorderStyle = { - type t = [ - | #none - | #hidden - | #dotted - | #dashed - | #solid - | #double - | #groove - | #ridge - | #inset - | #outset - ] - - let toString = x => - switch x { - | #none => "none" - | #hidden => "hidden" - | #dotted => "dotted" - | #dashed => "dashed" - | #solid => "solid" - | #double => "double" - | #groove => "groove" - | #ridge => "ridge" - | #inset => "inset" - | #outset => "outset" - } -} - -module PointerEvents = { - type t = [#auto | #none] - - let toString = x => - switch x { - | #auto => "auto" - | #none => "none" - } -} - -module Perspective = { - type t = [#none] - - let toString = x => - switch x { - | #none => "none" - } -} - -module LetterSpacing = { - type t = [#normal] - - let normal = #normal - - let toString = x => - switch x { - | #normal => "normal" - } -} - -module LineHeight = { - type t = [#normal | #abs(float)] - - let toString = x => - switch x { - | #normal => "normal" - | #abs(x) => Js.Float.toString(x) - } -} - -module WordSpacing = { - type t = [#normal] - - let toString = x => - switch x { - | #normal => "normal" - } -} - -module DisplayOutside = { - type t = [#block | #inline | #runIn] - - let toString = x => - switch x { - | #block => "block" - | #inline => "inline" - | #runIn => "run-in" - } -} - -module DisplayInside = { - type t = [#table | #flex | #grid] - - let toString = x => - switch x { - | #table => "table" - | #flex => "flex" - | #grid => "grid" - } -} - -module DisplayListItem = { - type t = [#listItem] - - let toString = x => - switch x { - | #listItem => "list-item" - } -} - -module DisplayInternal = { - type t = [ - | #tableRowGroup - | #tableHeaderGroup - | #tableFooterGroup - | #tableRow - | #tableCell - | #tableColumnGroup - | #tableColumn - | #tableCaption - ] - - let toString = x => - switch x { - | #tableRowGroup => "table-row-group" - | #tableHeaderGroup => "table-header-group" - | #tableFooterGroup => "table-footer-group" - | #tableRow => "table-row" - | #tableCell => "table-cell" - | #tableColumnGroup => "table-column-group" - | #tableColumn => "table-column" - | #tableCaption => "table-caption" - } -} - -module DisplayBox = { - type t = [#contents | #none] - - let toString = x => - switch x { - | #contents => "contents" - | #none => "none" - } -} - -module DisplayLegacy = { - type t = [#inlineBlock | #inlineFlex | #inlineGrid | #inlineTable] - - let toString = x => - switch x { - | #inlineBlock => "inline-block" - | #inlineFlex => "inline-flex" - | #inlineGrid => "inline-grid" - | #inlineTable => "inline-table" - } -} - -module JustifySelf = { - type t = [#auto | #normal | #stretch] - - let toString = x => - switch x { - | #auto => "auto" - | #normal => "normal" - | #stretch => "stretch" - } -} - -module PositionalAlignment = { - type t = [ - | #center - | #start - | #end_ - | #flexStart - | #flexEnd - | #selfStart - | #selfEnd - | #left - | #right - ] - - let toString = x => - switch x { - | #center => "center" - | #start => "start" - | #end_ => "end" - | #flexStart => "flex-start" - | #flexEnd => "flex-end" - | #selfStart => "self-start" - | #selfEnd => "self-end" - | #left => "left" - | #right => "right" - } -} - -module OverflowAlignment = { - type t = [ - | #safe(PositionalAlignment.t) - | #unsafe(PositionalAlignment.t) - ] - - let toString = x => - switch x { - | #safe(pa) => "safe " ++ PositionalAlignment.toString(pa) - | #unsafe(pa) => "unsafe " ++ PositionalAlignment.toString(pa) - } -} - -module BaselineAlignment = { - type t = [#baseline | #firstBaseline | #lastBaseline] - - let toString = x => - switch x { - | #baseline => "baseline" - | #firstBaseline => "first baseline" - | #lastBaseline => "last baseline" - } -} - -module NormalAlignment = { - type t = [#normal] - - let toString = x => - switch x { - | #normal => "normal" - } -} - -module DistributedAlignment = { - type t = [#spaceBetween | #spaceAround | #spaceEvenly | #stretch] - - let toString = x => - switch x { - | #spaceBetween => "space-between" - | #spaceAround => "space-around" - | #spaceEvenly => "space-evenly" - | #stretch => "stretch" - } -} - -module LegacyAlignment = { - type t = [#legacy | #legacyRight | #legacyLeft | #legacyCenter] - - let toString = x => - switch x { - | #legacy => "legacy" - | #legacyRight => "legacy right" - | #legacyLeft => "legacy left" - | #legacyCenter => "legacy center" - } -} - -module TextAlign = { - type t = [#left | #right | #center | #justify] - - let toString = x => - switch x { - | #left => "left" - | #right => "right" - | #center => "center" - | #justify => "justify" - } -} - -module WordBreak = { - type t = [#normal | #breakAll | #keepAll] - - let toString = x => - switch x { - | #normal => "normal" - | #breakAll => "break-all" - | #keepAll => "keep-all" - } -} - -module WhiteSpace = { - type t = [#normal | #nowrap | #pre | #preLine | #preWrap | #breakSpaces] - - let toString = x => - switch x { - | #normal => "normal" - | #nowrap => "nowrap" - | #pre => "pre" - | #preLine => "pre-line" - | #preWrap => "pre-wrap" - | #breakSpaces => "break-spaces" - } -} - -module AlignItems = { - type t = [#normal | #stretch] - - let toString = x => - switch x { - | #normal => "normal" - | #stretch => "stretch" - } -} - -module AlignSelf = { - type t = [#auto | #normal | #stretch] - - let toString = x => - switch x { - | #auto => "auto" - | #normal => "normal" - | #stretch => "stretch" - } -} - -module AlignContent = { - type t = [#center | #start | #end_ | #flexStart | #flexEnd] - - let toString = x => - switch x { - | #center => "center" - | #start => "start" - | #end_ => "end" - | #flexStart => "flex-start" - | #flexEnd => "flex-end" - } -} - -module ObjectFit = { - type t = [#fill | #contain | #cover | #none | #scaleDown] - - let toString = x => - switch x { - | #fill => "fill" - | #contain => "contain" - | #cover => "cover" - | #none => "none" - | #scaleDown => "scale-down" - } -} - -module Clear = { - type t = [#none | #left | #right | #both | #inlineStart | #inlineEnd] - - let toString = x => - switch x { - | #none => "none" - | #left => "left" - | #right => "right" - | #both => "both" - | #inlineStart => "inline-start" - | #inlineEnd => "inline-end" - } -} - -module Float = { - type t = [#left | #right | #none | #inlineStart | #inlineEnd] - - let toString = x => - switch x { - | #left => "left" - | #right => "right" - | #none => "none" - | #inlineStart => "inline-start" - | #inlineEnd => "inline-end" - } -} - -module Visibility = { - type t = [#visible | #hidden | #collapse] - - let toString = x => - switch x { - | #visible => "visible" - | #hidden => "hidden" - | #collapse => "collapse" - } -} - -module TableLayout = { - type t = [#auto | #fixed] - - let toString = x => - switch x { - | #auto => "auto" - | #fixed => "fixed" - } -} - -module BorderCollapse = { - type t = [#collapse | #separate] - - let toString = x => - switch x { - | #collapse => "collapse" - | #separate => "separate" - } -} - -module FlexWrap = { - type t = [#nowrap | #wrap | #wrapReverse] - - let toString = x => - switch x { - | #nowrap => "nowrap" - | #wrap => "wrap" - | #wrapReverse => "wrap-reverse" - } -} - -module FlexDirection = { - type t = [#row | #rowReverse | #column | #columnReverse] - - let toString = x => - switch x { - | #row => "row" - | #rowReverse => "row-reverse" - | #column => "column" - | #columnReverse => "column-reverse" - } -} - -module BoxSizing = { - type t = [#contentBox | #borderBox] - - let toString = x => - switch x { - | #contentBox => "content-box" - | #borderBox => "border-box" - } -} - -module ColumnCount = { - type t = [#auto | #count(int)] - - let toString = x => - switch x { - | #auto => "auto" - | #count(v) => Js.Int.toString(v) - } -} - -module UserSelect = { - type t = [#none | #auto | #text | #contain | #all] - - let toString = x => - switch x { - | #none => "none" - | #auto => "auto" - | #text => "text" - | #contain => "contain" - | #all => "all" - } -} - -module TextTransform = { - type t = [#none | #capitalize | #uppercase | #lowercase] - - let toString = x => - switch x { - | #none => "none" - | #capitalize => "capitalize" - | #uppercase => "uppercase" - | #lowercase => "lowercase" - } -} - -module GridTemplateAreas = { - type t = [#none | #areas(list)] - - let areas = x => #areas(x) - - let toString = x => - switch x { - | #none => "none" - | #areas(l) => - String.trim(List.fold_left((carry, elem) => carry ++ ("'" ++ (elem ++ "' ")), "", l)) - } -} - -module GridArea = { - type t = [ - | #auto - | #ident(string) - | #num(int) - | #numIdent(int, string) - | #span([#num(int) | #ident(string)]) - ] - - let auto = #auto - let ident = x => #ident(x) - let num = x => #num(x) - let numIdent = (x, y) => #numIdent(x, y) - let span = x => #span(x) - - let toString = t => - switch t { - | #auto => "auto" - | #ident(s) => s - | #num(i) => string_of_int(i) - | #numIdent(i, s) => string_of_int(i) ++ (" " ++ s) - | #span(e) => - "span " ++ - switch e { - | #num(i) => string_of_int(i) - | #ident(s) => s - } - } -} - -module BackdropFilter = { - type t = [ - | #blur(Length.t) - | #brightness([#num(int) | #percent(float)]) - | #contrast([#num(int) | #percent(float)]) - | #dropShadow([#num(int) | #percent(float)]) - | #grayscale([#num(int) | #percent(float)]) - | #hueRotate([Angle.t | #zero]) - | #invert([#num(int) | #percent(float)]) - | #none - | #opacity([#num(int) | #percent(float)]) - | #saturate([#num(int) | #percent(float)]) - | #sepia([#num(int) | #percent(float)]) - ] - - let string_of_percent = p => Js.Float.toString(p) ++ "%" - - let toString = x => - switch x { - | #blur(#...Length.t as b) => "blur(" ++ (Length.toString(b) ++ ")") - | #brightness(#num(b)) => "brightness(" ++ (string_of_int(b) ++ ")") - | #brightness(#percent(b)) => "brightness(" ++ (string_of_percent(b) ++ ")") - | #contrast(#num(c)) => "contrast(" ++ (string_of_int(c) ++ ")") - | #contrast(#percent(c)) => "contrast(" ++ (string_of_percent(c) ++ ")") - | #dropShadow(#num(i)) => "drop-shadow(" ++ (string_of_int(i) ++ ")") - | #dropShadow(#percent(i)) => "drop-shadow(" ++ (string_of_percent(i) ++ ")") - | #grayscale(#num(i)) => "grayscale(" ++ (string_of_int(i) ++ ")") - | #grayscale(#percent(i)) => "grayscale(" ++ (string_of_percent(i) ++ ")") - | #hueRotate(#...Angle.t as h) => "hue-rotate(" ++ (Angle.toString(h) ++ ")") - | #hueRotate(#zero) => "hue-rotate(0deg)" - | #invert(#num(i)) => "invert(" ++ (string_of_int(i) ++ ")") - | #invert(#percent(i)) => "invert(" ++ (string_of_percent(i) ++ ")") - | #none => "none" - | #opacity(#num(i)) => "opacity(" ++ (string_of_int(i) ++ ")") - | #opacity(#percent(i)) => "opacity(" ++ (string_of_percent(i) ++ ")") - | #saturate(#num(i)) => "saturate(" ++ (string_of_int(i) ++ ")") - | #saturate(#percent(i)) => "saturate(" ++ (string_of_percent(i) ++ ")") - | #sepia(#num(i)) => "sepia(" ++ (string_of_int(i) ++ ")") - | #sepia(#percent(i)) => "sepia(" ++ (string_of_percent(i) ++ ")") - } -} - -module BackgroundAttachment = { - type t = [#scroll | #fixed | #local] - - let toString = x => - switch x { - | #scroll => "scroll" - | #fixed => "fixed" - | #local => "local" - } -} - -module BackgroundClip = { - type t = [#borderBox | #paddingBox | #contentBox] - - let toString = x => - switch x { - | #borderBox => "border-box" - | #contentBox => "content-box" - | #paddingBox => "padding-box" - } -} - -module BackgroundOrigin = { - type t = [#borderBox | #paddingBox | #contentBox] - - let toString = x => - switch x { - | #borderBox => "border-box" - | #contentBox => "content-box" - | #paddingBox => "padding-box" - } -} - -module BackgroundPosition = { - module X = { - type t = [#left | #right | #center] - - let toString = x => - switch x { - | #left => "left" - | #right => "right" - | #center => "center" - } - } - - module Y = { - type t = [#top | #bottom | #center] - - let toString = x => - switch x { - | #top => "top" - | #bottom => "bottom" - | #center => "center" - } - } - - type t = [X.t | Y.t] - - let toString = x => - switch x { - | #left => "left" - | #right => "right" - | #top => "top" - | #bottom => "bottom" - | #center => "center" - } -} - -module BackgroundRepeat = { - type twoValue = [#repeat | #space | #round | #noRepeat] - type t = [#repeatX | #repeatY | twoValue] - type horizontal = twoValue - type vertical = twoValue - - let toString = x => - switch x { - | #repeatX => "repeat-x" - | #repeatY => "repeat-y" - | #repeat => "repeat" - | #space => "space" - | #round => "round" - | #noRepeat => "no-repeat" - } -} - -module TextOverflow = { - type t = [#clip | #ellipsis | #string(string)] - - let toString = x => - switch x { - | #clip => "clip" - | #ellipsis => "ellipsis" - | #string(s) => s - } -} - -module TextDecorationLine = { - type t = [#none | #underline | #overline | #lineThrough | #blink] - - let toString = x => - switch x { - | #none => "none" - | #underline => "underline" - | #overline => "overline" - | #lineThrough => "line-through" - | #blink => "blink" - } -} - -module TextDecorationStyle = { - type t = [#solid | #double | #dotted | #dashed | #wavy] - - let toString = x => - switch x { - | #solid => "solid" - | #double => "double" - | #dotted => "dotted" - | #dashed => "dashed" - | #wavy => "wavy" - } -} - -module Width = { - type t = [#auto | #fitContent] - - let toString = x => - switch x { - | #auto => "auto" - | #fitContent => "fit-content" - } -} - -module MaxWidth = { - type t = [#none] - - let toString = x => - switch x { - | #none => "none" - } -} - -module Height = { - type t = [#auto] - - let toString = x => - switch x { - | #auto => "auto" - } -} - -module MaxHeight = { - type t = [#none] - - let toString = x => - switch x { - | #none => "none" - } -} - -module OverflowWrap = { - type t = [#normal | #breakWord | #anywhere] - - let toString = x => - switch x { - | #normal => "normal" - | #breakWord => "break-word" - | #anywhere => "anywhere" - } -} - -module Gradient = { - type t<'colorOrVar> = [ - | #linearGradient(Angle.t, list<(Length.t, [< Color.t | Var.t] as 'colorOrVar)>) - | #repeatingLinearGradient(Angle.t, list<(Length.t, [< Color.t | Var.t] as 'colorOrVar)>) - | #radialGradient(list<(Length.t, [< Color.t | Var.t] as 'colorOrVar)>) - | #repeatingRadialGradient(list<(Length.t, [< Color.t | Var.t] as 'colorOrVar)>) - ] - - let linearGradient = (angle, stops) => #linearGradient(angle, stops) - let repeatingLinearGradient = (angle, stops) => #repeatingLinearGradient(angle, stops) - let radialGradient = stops => #radialGradient(stops) - let repeatingRadialGradient = stops => #repeatingRadialGradient(stops) - - let string_of_color = x => - switch x { - | #...Color.t as co => Color.toString(co) - | #...Var.t as va => Var.toString(va) - } - let string_of_stops = stops => - stops->Belt.List.map(((l, c)) => string_of_color(c) ++ (" " ++ Length.toString(l)))->join(", ") - - let toString = x => - switch x { - | #linearGradient(angle, stops) => - "linear-gradient(" ++ (Angle.toString(angle) ++ (", " ++ (string_of_stops(stops) ++ ")"))) - | #repeatingLinearGradient(angle, stops) => - "repeating-linear-gradient(" ++ - (Angle.toString(angle) ++ - (", " ++ (string_of_stops(stops) ++ ")"))) - | #radialGradient(stops) => "radial-gradient(" ++ (string_of_stops(stops) ++ ")") - | #repeatingRadialGradient(stops) => - "repeating-radial-gradient(" ++ (string_of_stops(stops) ++ ")") - } -} - -module BackgroundImage = { - type t = [#none] - - let toString = x => - switch x { - | #none => "none" - } -} - -module GeometyBox = { - type t = [ - | #marginBox - | #borderBox - | #paddingBox - | #contentBox - | #fillBox - | #strokeBox - | #viewBox - ] - - let marginBox = #marginBox - let borderBox = #borderBox - let paddingBox = #paddingBox - let contentBox = #contentBox - let fillBox = #fillBox - let strokeBox = #strokeBox - let viewBox = #viewBox - - let toString = x => - switch x { - | #marginBox => "margin-box" - | #borderBox => "border-box" - | #paddingBox => "padding-box" - | #contentBox => "content-box" - | #fillBox => "fill-box" - | #strokeBox => "stroke-box" - | #viewBox => "view-box" - } -} - -module ClipPath = { - type t = [#none] - - let toString = x => - switch x { - | #none => "none" - } -} - -module BackfaceVisibility = { - type t = [#visible | #hidden] - - let toString = x => - switch x { - | #visible => "visible" - | #hidden => "hidden" - } -} - -module Flex = { - type t = [#auto | #initial | #none] - - let toString = x => - switch x { - | #auto => "auto" - | #initial => "initial" - | #none => "none" - } -} - -module TransformStyle = { - type t = [#preserve3d | #flat] - - let toString = x => - switch x { - | #preserve3d => "preserve-3d" - | #flat => "flat" - } -} - -module ListStyleImage = { - type t = [#none] - - let toString = x => - switch x { - | #none => "none" - } -} - -module FontFamilyName = { - type t = [ - | #custom(string) - | #serif - | #sansSerif - | #cursive - | #fantasy - | #monospace - | #systemUi - | #emoji - | #math - | #fangsong - ] - - let custom = #custom - let serif = #serif - let sansSerif = #sansSerif - let cursive = #cursive - let fantasy = #fantasy - let monospace = #monospace - let systemUi = #systemUi - let emoji = #emoji - let math = #math - let fangsong = #fangsong - - let toString = x => - switch x { - | #custom(name) => name - | #serif => "serif" - | #sansSerif => "sans-serif" - | #cursive => "cursive" - | #fantasy => "fantasy" - | #monospace => "monospace" - | #systemUi => "system-ui" - | #emoji => "emoji" - | #math => "math" - | #fangsong => "fangsong" - } -} - -module FontDisplay = { - type t = [#auto | #block | #swap | #fallback | #optional] - - let auto = #auto - let block = #block - let swap = #swap - let fallback = #fallback - let optional = #optional - - let toString = x => - switch x { - | #auto => "auto" - | #block => "block" - | #swap => "swap" - | #fallback => "fallback" - | #optional => "optional" - } -} - -module CounterStyleType = { - type t = [ListStyleType.t] - - let toString = x => - switch x { - | #...ListStyleType.t as c => ListStyleType.toString(c) - } -} - -module Counter = { - type style = [CounterStyleType.t | #unset] - type t = [#counter(string, style)] - - let counter = (~style=#unset, name) => #counter(name, style) - - let toString = x => - switch x { - | #counter(counter, style) => - switch style { - | #unset => "counter(" ++ (counter ++ ")") - | #...CounterStyleType.t as t => - "counter(" ++ (counter ++ ("," ++ (CounterStyleType.toString(t) ++ ")"))) - } - } -} - -module Counters = { - type style = [CounterStyleType.t | #unset] - type t = [#counters(string, string, style)] - - let counters = (~style=#unset, ~separator="", name) => #counters(name, separator, style) - - let toString = x => - switch x { - | #counters(name, separator, style) => - switch style { - | #unset => "counters(" ++ (name ++ (",\"" ++ (separator ++ "\")"))) - | #...CounterStyleType.t as s => - "counters(" ++ - (name ++ - (",\"" ++ (separator ++ ("\"," ++ (CounterStyleType.toString(s) ++ ")"))))) - } - } -} - -module CounterIncrement = { - type t = [#none | #increment(string, int)] - - let increment = (~value=1, name) => #increment(name, value) - - let toString = x => - switch x { - | #none => "none" - | #increment(name, value) => name ++ (" " ++ string_of_int(value)) - } -} - -module CounterReset = { - type t = [#none | #reset(string, int)] - - let reset = (~value=0, name) => #reset(name, value) - - let toString = x => - switch x { - | #none => "none" - | #reset(name, value) => name ++ (" " ++ string_of_int(value)) - } -} - -module CounterSet = { - type t = [#none | #set(string, int)] - - let set = (~value=0, name) => #set(name, value) - - let toString = x => - switch x { - | #none => "none" - | #set(name, value) => name ++ (" " ++ string_of_int(value)) - } -} - -module Content = { - type t = [ - | #none - | #normal - | #openQuote - | #closeQuote - | #noOpenQuote - | #noCloseQuote - | #attr(string) - | #text(string) - ] - - let toString = x => - switch x { - | #none => "none" - | #normal => "normal" - | #openQuote => "open-quote" - | #closeQuote => "close-quote" - | #noOpenQuote => "no-open-quote" - | #noCloseQuote => "no-close-quote" - | #attr(name) => "attr(" ++ (name ++ ")") - | #text(string) => j`"$string"` - } -} - -module SVG = { - module Fill = { - type t = [#none | #contextFill | #contextStroke] - - let contextFill = #contextFill - let contextStroke = #contextStroke - - let toString = x => - switch x { - | #none => "none" - | #contextFill => "context-fill" - | #contextStroke => "context-stroke" - } - } -} diff --git a/jscomp/syntax/tests/idempotency/bs-css/Css_AtomicTypes.resi b/jscomp/syntax/tests/idempotency/bs-css/Css_AtomicTypes.resi deleted file mode 100644 index 549b7dd..0000000 --- a/jscomp/syntax/tests/idempotency/bs-css/Css_AtomicTypes.resi +++ /dev/null @@ -1,1342 +0,0 @@ -// Docs copied from MDN - -module Cascading: { - type t = [#initial | #inherit_ | #unset] - - let initial: [> t] - let inherit_: [> t] - let unset: [> t] - - let toString: t => string -} - -module Var: { - type t = [#var(string) | #varDefault(string, string)] - - let var: string => [> t] - let varDefault: (string, string) => [> t] - - let toString: t => string -} - -module Time: { - @ocaml.doc(" - The